diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..a5309e6b9 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +build*/ diff --git a/.gitmodules b/.gitmodules index 9eac6ee69..f4bfd21ee 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,7 @@ [submodule "fix"] path = fix url = gerrit:GSI-fix + [submodule "libsrc"] path = libsrc url = gerrit:GSI-libsrc diff --git a/CMakeLists.txt b/CMakeLists.txt index a76c7a032..1f9b06cf4 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -6,6 +6,7 @@ if( NOT DEFINED ENV{CC} ) find_path( intelComp "ifort" ) find_path( pgiComp "pgf90" ) if( crayComp ) + message("Setting CrayLinuxEnvironment") set(CMAKE_SYSTEM_NAME "CrayLinuxEnvironment") set(CMAKE_C_COMPILER "${crayComp}/cc") set(CMAKE_CXX_COMPILER "${crayComp}/CC") @@ -32,16 +33,44 @@ endif() project(GSI) enable_language (Fortran) option(USE_WRF "Find WRF object files and build regional GSI model" ON) + option(USE_BASELIBS "Look for and use GMAO Baselibs" OFF) option(BUILD_GLOBAL "Build GSI without WRF (regional) module " OFF) - option(BUILD_GSI "Build the GSI model" ON) option(BUILD_ENKF "Build the Enkf executable " ON) - option(BUILD_GFS "Build the Enkf with GFS module " ON) - option(BUILD_NMMB "Build the Enkf with NMMB module " OFF) - option(BUILD_WRF "Build the Enkf with WRF module " OFF) - option(BUILD_CORELIBS "Build the Core libraries " OFF) + option(USE_BASELINE "Use baseline control runs" ON) + SET(ENKF_MODE "GFS" CACHE STRING "EnKF build mode: GFS, WRF, NMMB") + string(TOUPPER ${ENKF_MODE} ENKF_MODE) + if (ENKF_MODE MATCHES "^GFS$") + message("Build the EnKF with GFS module") + option(BUILD_GFS "Build the Enkf with GFS module " ON) + option(BUILD_NMMB "Build the Enkf with NMMB module " OFF) + option(BUILD_WRF "Build the Enkf with WRF module " OFF) + elseif (ENKF_MODE MATCHES "^WRF$") + message("Build the EnKF with WRF module") + option(BUILD_GFS "Build the Enkf with GFS module " OFF) + option(BUILD_NMMB "Build the Enkf with NMMB module " OFF) + option(BUILD_WRF "Build the Enkf with WRF module " ON) + elseif (ENKF_MODE MATCHES "^NMMB$") + message("Build the EnKF with NMMB module") + option(BUILD_GFS "Build the Enkf with GFS module " OFF) + option(BUILD_NMMB "Build the Enkf with NMMB module " ON) + option(BUILD_WRF "Build the Enkf with WRF module " OFF) + else() + message("unkown ENKF_MODE: ${ENKF_MODE} !\nBuild the EnKF with GFS module by default") + option(BUILD_GFS "Build the Enkf with GFS module " ON) + option(BUILD_NMMB "Build the Enkf with NMMB module " OFF) + option(BUILD_WRF "Build the Enkf with WRF module " OFF) + endif() option(BUILD_UTIL "Build the Enkf utilities " OFF) + + option(BUILD_UTIL_COM "Build community utilities " OFF) + option(BUILD_ENKF_PREPROCESS_ARW "Build enkf preprocess for ARW " OFF) + option(BUILD_COV_CALC "Build the Desroziers utility" OFF) + option(BUILD_NCDIAG "Build the NCDIAG libraries" ON) + option(BUILD_NCDIAG_SERIAL "Build the serial NCDIAG libraries" ON) option(BUILD_REG_TESTING "Build the Regression Testing Suite" ON) option(BUILD_UNIT_TESTING "Build the Unit Testing Suite" OFF) + option(MPI3 "Build EnKF with MPI3" OFF) + option(BUILD_GSDCLOUD_ARW "Build the GSD cloud analysis " OFF) cmake_minimum_required(VERSION 2.8) set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/cmake/Modules/") set(CMAKE_LIBRARY_OUTPUT_DIRECTORY "${PROJECT_BINARY_DIR}/lib") @@ -49,51 +78,80 @@ project(GSI) SET(ARCHIVE_OUTPUT_PATH ${PROJECT_BINARY_DIR}/lib) set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) set(CMAKE_INCLUDE_OUTPUT_DIRECTORY "${PROJECT_BINARY_DIR}/include") + set(CMAKE_INCLUDE_4_OUTPUT_DIRECTORY "${PROJECT_BINARY_DIR}/include4") set(Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") set(CMAKE_Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") file(MAKE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}) + file(MAKE_DIRECTORY ${CMAKE_INCLUDE_4_OUTPUT_DIRECTORY}) include(${CMAKE_SOURCE_DIR}/cmake/Modules/setPlatformVariables.cmake) - include(${CMAKE_SOURCE_DIR}/cmake/Modules/setCompilerFlags.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/setIntelFlags.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/setGNUFlags.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/setPGIFlags.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/setHOST.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/Cheyenne.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/Discover.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/Generic.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/Gaea.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/Jet.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/S4.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/Hera.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/WCOSS-C.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/WCOSS-D.cmake) + include(${CMAKE_SOURCE_DIR}/cmake/Modules/platforms/WCOSS.cmake) if(BUILD_REG_TESTING) set(CTEST_TEST_TIMEOUT 86400 ) find_package(GSICONTROL) include( CTest ) endif(BUILD_REG_TESTING) + if(MPI3) + set( MPI3FLAG "-DMPI3" CACHE INTERNAL "" ) + else() + set( MPI3FLAG "" CACHE INTERNAL "" ) + endif() + cmake_policy(SET CMP0009 NEW) - site_name(HOSTNAME) - string(REGEX MATCH "s4-" HOST-S4 ${HOSTNAME} ) - string(REGEX MATCH "tfe[0-9]" HOST-Theia ${HOSTNAME} ) - string(REGEX MATCH "g[0-9][0-9]a" HOST-Gyre ${HOSTNAME} ) - string(REGEX MATCH "t[0-9][0-9]a" HOST-Tide ${HOSTNAME} ) - string(REGEX MATCH "llogin" HOST-Luna ${HOSTNAME} ) - string(REGEX MATCH "slogin" HOST-Surge ${HOSTNAME} ) - if( HOST-S4 ) - set( host "S4" ) - setS4() - elseif(( HOST-Tide ) OR ( HOST-Gyre ) ) - set( host "WCOSS" ) - setWCOSS() - elseif( HOST-Theia ) - set( host "THEIA" ) - setTHEIA() - elseif( ( crayComp ) OR ( HOST-Luna) OR ( HOST-Surge ) ) - find_path( crayComp "ftn" ) - set( host "LUNA" ) - setCRAY() - else( ) - set( host "GENERIC" ) - setGeneric() + find_package(OpenMP) + message("found openmp with flag ${OPENMP_Fortran_FLAGS}") + +# Set Host specific flags and options + setHOST() + + if(FIND_HDF5_HL) + find_package(HDF5 COMPONENTS C HL Fortran_HL ) + elseif(FIND_HDF5) + find_package(HDF5) endif() MESSAGE(${CMAKE_CURRENT_SOURCE_DIR}) # make sure that the default is a RELEASE if (NOT CMAKE_BUILD_TYPE) set (CMAKE_BUILD_TYPE RELEASE CACHE STRING - "Choose the type of build, options are: None Debug Release." + "Choose the type of build, options are: PRODUCTION Debug Release." FORCE) endif (NOT CMAKE_BUILD_TYPE) - set(CMAKE_Fortran_FLAGS_RELEASE "") + + STRING(COMPARE EQUAL ${CMAKE_BUILD_TYPE} "RelWithDebInfo" BUILD_RELEASE) + STRING(COMPARE EQUAL ${CMAKE_BUILD_TYPE} "PRODUCTION" BUILD_PRODUCTION) + STRING(COMPARE EQUAL ${CMAKE_BUILD_TYPE} "PROFILE" BUILD_PROFILE) + if( BUILD_PRODUCTION ) + set( CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_SOURCE_DIR}/exec ) + endif() + if( BUILD_PROFILE ) + set(CMAKE_SKIP_RPATH "TRUE") + if(NOT ENV{TAU_MAKEFILE}) + message("Must set TAU MAKEFILE environment variable to build in profiling mode") + exit() + endif() + endif() + + if(BUILD_GSDCLOUD_ARW) + set(GSDCLOUDOPT "-DRR_CLOUDANALYSIS" CACHE INTERNAL "" ) + else(BUILD_GSDCLOUD_ARW) + set( GSDCLOUDOPT "" CACHE INTERNAL "" ) + endif(BUILD_GSDCLOUD_ARW) + + set(CMAKE_Fortran_FLAGS_RELEASE "") if (CMAKE_CXX_COMPILER_ID MATCHES "GNU*") message("Setting GNU flags") setGNU() @@ -105,38 +163,44 @@ project(GSI) setPGI() endif() - set(intsize 4) - set(doublesize 4) - set(libsuffix "_i${intsize}r${doublesize}") - if( NOT(HOST-Luna) AND NOT(HOST-Surge) ) - find_package(MPI REQUIRED) - endif() + find_package(MPI REQUIRED) + message("MPI version is ${MPI_Fortran_VERSION}") + message("MPI f90 version is ${MPI_Fortran_HAVE_F90_MODULE}") + message("MPI f08 version is ${MPI_Fortran_HAVE_F08_MODULE}") + add_definitions(${MPI_Fortran_COMPILE_FLAGS}) include_directories(${MPI_Fortran_INCLUDE_DIRS} ${MPI_INCLUDE_PATH} "./" ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}) link_directories(${MPI_Fortran_LIBRARIES} ${ARCHIVE_OUTPUT_PATH} ) - - - find_package( NetCDF REQUIRED) - if(NETCDF4) - if(CMAKE_MAJOR_VERSION GREATER 2) - find_package( HDF5 COMPONENTS C HL Fortran_HL REQUIRED ) - else() - find_package( HDF5 ) +# if( (HOST-Discover) AND (NOT HOST-Generic)) + if( USE_BASELIBS ) + find_package(Baselibs REQUIRED) + else() + find_package( NetCDF REQUIRED) + if(NETCDF4) + if(CMAKE_MAJOR_VERSION GREATER 2) + find_package( ZLIB ) + endif() + find_package( CURL ) endif() - find_package( CURL ) endif() - if( NOT crayComp ) - message(" trying to find lapack") + if(( NOT HOST-WCOSS_D ) AND ( NOT HOST-WCOSS_C ) AND ( NOT HOST-Gaea ) ) + message(" trying to find lapack, ${host}") find_package( LAPACK ) endif() - if(USE_WRF) +# build the WRF I/O libraries + if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/libsrc/wrflib) + add_subdirectory(libsrc/wrflib) + else() + message("libsrc/wrflib not pulled from git, looking for WRF dependencies locally") + message("libsrc/wrflib not pulled from git, looking for WRF dependencies locally") find_package( WRF ) endif() + # default installation get_filename_component (default_prefix ".." ABSOLUTE) - set (CMAKE_INSTALL_PREFIX ${default_prefix} CACHE STRING "set prefix" - FORCE) +# set (CMAKE_INSTALL_PREFIX ${default_prefix} CACHE STRING "set prefix" +# FORCE) # FFLAGS depend on the compiler @@ -148,29 +212,80 @@ project(GSI) if(BUILD_CORELIBS ) message("setting values for corelibs") - set(BUILD_CRTM "ON" CACHE STRING "Build the CRTM library" ) set(BUILD_BACIO "ON" CACHE STRING "Build the BACIO library" ) set(BUILD_BUFR "ON" CACHE STRING "Build the BUFR library" ) set(BUILD_SFCIO "ON" CACHE STRING "Build the SFCIO library" ) set(BUILD_SIGIO "ON" CACHE STRING "Build the SIGIO library" ) set(BUILD_NEMSIO "ON" CACHE STRING "Build the NEMSIO library" ) set(BUILD_SP "ON" CACHE STRING "Build the SP library" ) - set(BUILD_EMC "ON" CACHE STRING "Build the EMC library" ) + set(BUILD_CRTM "ON" CACHE STRING "Build the CRTM library" ) + set(BUILD_W3EMC "ON" CACHE STRING "Build the EMC library" ) set(BUILD_NCO "ON" CACHE STRING "Build the NCO library" ) - set(FIND_SRC ON ) - else() - set(FIND_SRC OFF) - endif() - find_package( CORELIBS ) - if(BUILD_CORELIBS) - add_subdirectory(core-libs) endif() + find_package( BACIO ) + find_package( BUFR ) + find_package( SIGIO ) + find_package( NEMSIO ) + find_package( CRTM ) + find_package( SP ) + find_package( SFCIO ) + find_package( W3EMC ) + find_package( W3NCO ) - add_subdirectory(src) - add_subdirectory(src/enkf) + if(BUILD_NCDIAG) + set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/libsrc/ncdiag/include") + add_subdirectory(src/ncdiag) + set(NCDIAG_LIBRARIES ncdiag ) + endif(BUILD_NCDIAG) - set(GSILIB gsilib) + find_package( BACIO ) + find_package( BUFR ) + find_package( SIGIO ) + find_package( NEMSIO ) + find_package( CRTM ) + find_package( SP ) + find_package( SFCIO ) + find_package( W3EMC ) + find_package( W3NCO ) + if(BUILD_GSDCLOUD_ARW) + set(GSDCLOUD_DIR "${CMAKE_SOURCE_DIR}/libsrc/GSD/gsdcloud") + set(gsdcloud gsdcloud_arw) + add_subdirectory(libsrc/GSD/gsdcloud) + set(GSDCLOUD_LIBRARY ${gsdcloud} ) + else(BUILD_GSDCLOUD_ARW) + set(GSDCLOUD_LIBRARY "") + endif(BUILD_GSDCLOUD_ARW) + + add_subdirectory(src/gsi) + if(BUILD_ENKF) + add_subdirectory(src/enkf) + endif(BUILD_ENKF) + if(BUILD_UTIL) + add_subdirectory(util/EnKF/gfs/src) + add_subdirectory(util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd) + add_subdirectory(util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd) + add_subdirectory(util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radang.fd) + add_subdirectory(util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcoef.fd) + add_subdirectory(util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radbcor.fd) + add_subdirectory(util/Radiance_Monitor/nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd) + endif(BUILD_UTIL) + find_package( NDATE ) + if( NOT NDATE ) + add_subdirectory(util/ndate) + endif() + if(BUILD_ENKF_PREPROCESS_ARW) + add_subdirectory(util/EnKF/arw/src) + endif(BUILD_ENKF_PREPROCESS_ARW) + if(BUILD_UTIL_COM) + add_subdirectory(util/Analysis_Utilities/read_diag) + add_subdirectory(util/radar_process/radialwind) + add_subdirectory(util/radar_process/reflectivity) + add_subdirectory(util/bufr_tools) + endif(BUILD_UTIL_COM) + if(BUILD_COV_CALC) + add_subdirectory(util/Correlated_Obs) + endif (BUILD_COV_CALC) if(BUILD_UNIT_TESTING) set(CTEST_TEST_TIMEOUT 400 ) find_package(GSICONTROL) @@ -178,19 +293,21 @@ project(GSI) add_subdirectory(unit-tests) endif(BUILD_UNIT_TESTING) if(BUILD_REG_TESTING) + if(USE_BASELINE) + set(BASELINE_FLAG "1") + else() + set(BASELINE_FLAG "0") + endif(USE_BASELINE) if(USE_WRF) - file(WRITE "${PROJECT_BINARY_DIR}/regression_var.out" "${CMAKE_SOURCE_DIR}/regression/regression_var.sh ${host} ${CMAKE_SOURCE_DIR}/.. ${PROJECT_BINARY_DIR} ${CMAKE_SOURCE_DIR} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/gsi.x${debug_suffix} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/enkf_gfs.x${debug_suffix} ${GSICONTROL} ${ENKFCONTROL} ") - set( REG_TEST_NAMES "global_T62;global_T62_ozonly;global_4dvar_T62;global_4denvar_T126;global_lanczos_T62;arw_netcdf; - arw_binary;nmm_binary;nmm_netcdf;nmmb_nems_4denvar;hwrf_nmm_d2;hwrf_nmm_d3;rtma;global_enkf_T62") + file(WRITE "${PROJECT_BINARY_DIR}/regression_var.out" "${CMAKE_SOURCE_DIR}/regression/regression_var.sh ${host} ${CMAKE_SOURCE_DIR}/.. ${PROJECT_BINARY_DIR} ${CMAKE_SOURCE_DIR} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/${GSIEXEC} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/${ENKFEXEC} ${GSICONTROL} ${ENKFCONTROL} ${BASELINE_FLAG} ") + set( REG_TEST_NAMES "global_T62;global_T62_ozonly;global_4dvar_T62;global_4denvar_T126;global_fv3_4denvar_T126;global_lanczos_T62;arw_netcdf; + arw_binary;nmm_binary;nmm_netcdf;nmmb_nems_4denvar;hwrf_nmm_d2;hwrf_nmm_d3;rtma;global_enkf_T62;netcdf_fv3_regional;global_C96_fv3aero") else() - file(WRITE "${PROJECT_BINARY_DIR}/regression_var.out" "${CMAKE_SOURCE_DIR}/regression/regression_var.sh ${host} ${CMAKE_SOURCE_DIR}/.. ${PROJECT_BINARY_DIR} ${CMAKE_SOURCE_DIR} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/gsi_global.x${debug_suffix} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/enkf.x${debug_suffix} ${GSICONTROL} ${ENKFCONTROL} ") - set( REG_TEST_NAMES "global_T62;global_T62_ozonly;global_4dvar_T62;global_lanczos_T62;global_nemsio_T62") + file(WRITE "${PROJECT_BINARY_DIR}/regression_var.out" "${CMAKE_SOURCE_DIR}/regression/regression_var.sh ${host} ${CMAKE_SOURCE_DIR}/.. ${PROJECT_BINARY_DIR} ${CMAKE_SOURCE_DIR} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/${GSIEXEC} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/${ENKFEXEC} ${GSICONTROL} ${ENKFCONTROL} ${BASELINE_FLAG} ") + set( REG_TEST_NAMES "global_T62;global_T62_ozonly;global_4dvar_T62;global_lanczos_T62;global_nemsio_T62;global_C96_fv3aero") endif() foreach( REG_TEST ${REG_TEST_NAMES} ) add_test(NAME ${REG_TEST} WORKING_DIRECTORY ${CMAKE_SOURCE_DIR}/regression COMMAND regression_driver.sh ${REG_TEST} ${PROJECT_BINARY_DIR}) endforeach( REG_TEST ) set_tests_properties( ${REG_TEST_NAMES} PROPERTIES TIMEOUT 86400 ) endif() - if(BUILD_UTIL) - add_subdirectory(util/EnKF/gfs/src) - endif(BUILD_UTIL) diff --git a/clean b/clean new file mode 100755 index 000000000..297b7acf2 --- /dev/null +++ b/clean @@ -0,0 +1,23 @@ +#!/bin/sh + +set -xe + +echo "Cleaning up the build and/or exec dir for ProdGSI ..." +if [[ "$1" == '-a' ]] ; then + +if [[ -d build ]] ; then + rm -r ./build +fi +if [[ -d exec ]] ; then + rm -r ./exec +fi + +else + +if [[ -d build ]] ; then + rm -r ./build +fi + +fi + +exit diff --git a/cmake/Modules/FindBACIO.cmake b/cmake/Modules/FindBACIO.cmake new file mode 100644 index 000000000..04410f631 --- /dev/null +++ b/cmake/Modules/FindBACIO.cmake @@ -0,0 +1,55 @@ +# This module defines +# CORE_INCS +# List of include file paths for all required modules for GSI +# CORE_LIBRARIES +# Full list of libraries required to link GSI executable +include(findHelpers) +if(DEFINED ENV{BACIO_VER}) + set(BACIO_VER $ENV{BACIO_VER}) + STRING(REGEX REPLACE "v" "" BACIO_VER ${BACIO_VER}) +endif() +if(NOT BUILD_BACIO ) + if(DEFINED ENV{BACIO_LIB4}) + set(BACIO_LIBRARY $ENV{BACIO_LIB4} ) + else() + find_library( BACIO_LIBRARY + NAMES libbacio.a libbacio_4.a libbacio_v${BACIO_VER}_4.a + HINTS $ENV{COREPATH}/lib /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/bacio/v${BACIO_VER} + ${COREPATH}/bacio/v${BACIO_VER}/intel + ${COREPATH}/bacio/v${BACIO_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH} + ) + message("Found BACIO library ${BACIO_LIBRARY}") + endif() +endif() +if( NOT BACIO_LIBRARY ) # didn't find the library, so build it from source + message("Could not find BACIO library, so building from libsrc") + if( DEFINED ENV{BACIO_SRC} ) + set( BACIO_DIR $ENV{BACIO_SRC} CACHE STRING "BACIO Source Directory" ) + else() + findSrc( "bacio" BACIO_VER BACIO_DIR ) + set(BACIOINC "${CMAKE_BINARY_DIR}/include") + endif() + set( libsuffix "_v${BACIO_VER}${debug_suffix}" ) + set( bacio "bacio${libsuffix}") + set( BUILD_BACIO "ON" CACHE INTERNAL "Build Bacio library" ) + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/bacio) + set( BACIO_LIBRARY ${bacio} ) + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${BACIO_LIBRARY} ) + else() + set( CORE_BUILT ${BACIO_LIBRARY} ) + endif() +else( NOT BACIO_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${BACIO_LIBRARY} ) + else() + set( CORE_LIBRARIES ${BACIO_LIBRARY} ) + endif() +endif( NOT BACIO_LIBRARY ) + +set( BACIO_LIBRARY_PATH ${BACIO_LIBRARY} CACHE STRING "BACIO Library Location" ) + diff --git a/cmake/Modules/FindBUFR.cmake b/cmake/Modules/FindBUFR.cmake new file mode 100644 index 000000000..58527743b --- /dev/null +++ b/cmake/Modules/FindBUFR.cmake @@ -0,0 +1,60 @@ +# This module defines +# CORE_INCS +# List of include file paths for all required modules for GSI +# CORE_LIBRARIES +# Full list of libraries required to link GSI executable +include(findHelpers) +if(DEFINED ENV{BUFR_VER}) + set(BUFR_VER $ENV{BUFR_VER}) + STRING(REGEX REPLACE "v" "" BUFR_VER ${BUFR_VER}) +endif() + +set( NO_DEFAULT_PATH ) +if(NOT BUILD_BUFR ) + if(DEFINED ENV{BUFR_LIBd} ) + set(BUFR_LIBRARY $ENV{BUFR_LIBd} ) + message("BUFR library ${BUFR_LIBRARY} set via Environment variable") + else() + find_library( BUFR_LIBRARY + NAMES libbufr.a libbufr_d_64.a libbufr_i4r8.a libbufr_v${BUFR_VER}_d_64.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/bufr/v${BUFR_VER} + ${COREPATH}/bufr/v${BUFR_VER}/intel + ${COREPATH}/bufr/v${BUFR_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + set( bufr "bufr_v${BUFR_VER}") + message("Found BUFR library ${BUFR_LIBRARY}") + endif() +endif() +if( NOT BUFR_LIBRARY ) # didn't find the library, so build it from source + message("Could not find BUFR library, so building from libsrc") + if( NOT DEFINED ENV{BUFR_SRC} ) + findSrc( "bufr" BUFR_VER BUFR_DIR ) + else() + set( BUFR_DIR "$ENV{BUFR_SRC}/libsrc" CACHE STRING "BUFR Source Location") + endif() + set( libsuffix "_v${BUFR_VER}${debug_suffix}" ) + set( BUFR_LIBRARY "${LIBRARY_OUTPUT_PATH}/libbufr${libsuffix}.a" CACHE STRING "BUFR Library" ) + set( bufr "bufr${libsuffix}") + set( BUILD_BUFR "ON" CACHE INTERNAL "Build the BUFR library") + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/bufr) + set( BUFR_LIBRARY ${bufr} ) + + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${BUFR_LIBRARY} ) + else() + set( CORE_BUILT ${BUFR_LIBRARY} ) + endif() +else( NOT BUFR_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${BUFR_LIBRARY} ) + else() + set( CORE_LIBRARIES ${BUFR_LIBRARY} ) + endif() +endif() +set( BUFR_LIBRARY_PATH ${BUFR_LIBRARY} CACHE STRING "BUFR Library Location" ) + diff --git a/cmake/Modules/FindBaselibs.cmake b/cmake/Modules/FindBaselibs.cmake new file mode 100644 index 000000000..793cb9a5d --- /dev/null +++ b/cmake/Modules/FindBaselibs.cmake @@ -0,0 +1,68 @@ +if (NOT BASEDIR) + if(${COMPILER_TYPE} STREQUAL "intel" ) + string(REGEX MATCH "mpt" MPT ${MPI_Fortran_INCLUDE_PATH}) + string(REGEX MATCH "impi" IMPI ${MPI_Fortran_INCLUDE_PATH}) + message("REGEX returns ${MPT} ") + if( MPT MATCHES "mpt" ) + message("setting mpt paths ") + set(BASEDIR "/discover/swdev/mathomp4/Baselibs/GMAO-Baselibs-5_0_2/x86_64-unknown-linux-gnu/ifort_15.0.2.164-mpt_2.14/Linux") + elseif( IMPI MATCHES "impi" ) + set(BASEDIR "/discover/swdev/mathomp4/Baselibs/GMAO-Baselibs-5_0_2/x86_64-unknown-linux-gnu/ifort_16.0.3.210-intelmpi_5.1.3.210/Linux") + else() + message (FATAL_ERROR "ERROR: Could not find matching BASELIBS Must specify a value for BASEDIR with cmake ... -DBASEDIR=.") + endif() + message("compiler version is ${COMPILER_VERSION}") + endif() + if(${COMPILER_TYPE} STREQUAL "gnu" ) + string(REGEX MATCH "openmpi" OPENMPI ${MPI_Fortran_INCLUDE_PATH}) + message("REGEX returns ${OPENMPI} ") + if( OPENMPI MATCHES "openmpi" ) + message("setting openmpi paths ") + set(BASEDIR "/discover/swdev/mathomp4/Baselibs/GMAO-Baselibs-4_0_8/x86_64-unknown-linux-gnu/gfortran_7.2.0-openmpi_3.0.0/Linux") + else() + message (FATAL_ERROR "ERROR: Could not find matching BASELIBS Must specify a value for BASEDIR with cmake ... -DBASEDIR=.") + endif() + message("compiler version is ${COMPILER_VERSION}") + endif() + if(${COMPILER_TYPE} STREQUAL "pgi" ) + string(REGEX MATCH "openmpi" OPENMPI ${MPI_Fortran_INCLUDE_PATH}) + if( OPENMPI MATCHES "openmpi" ) + set(BASEDIR "/discover/swdev/mathomp4/Baselibs/GMAO-Baselibs-5_0_1/x86_64-unknown-linux-gnu/pgfortran_16.5-openmpi_1.10.3/Linux") + else() + message (FATAL_ERROR "ERROR: Could not find matching BASELIBS Must specify a value for BASEDIR with cmake ... -DBASEDIR=.") + endif() + message("compiler version is ${COMPILER_VERSION}") + endif() +endif () +if (ESMA_SDF) + message (FATAL_ERROR "ERROR: -hdf option was thought to be obsolete when CMake was crafted.") +endif () + +link_directories (${BASEDIR}/lib) + +#------------------------------------------------------------------ +# netcdf +# The following command provides the list of libraries that netcdf +# uses. Unfortunately it also includes the library path and "-l" +# prefixes, which CMake handles in a different manner. So we need so +# strip off that item from the list +execute_process ( + COMMAND ${BASEDIR}/bin/nf-config --flibs + OUTPUT_VARIABLE LIB_NETCDF + ) + +string(REGEX MATCHALL " -l[^ ]*" _full_libs "${LIB_NETCDF}") +set (NETCDF_LIBRARIES) +foreach (lib ${_full_libs}) + string (REPLACE "-l" "" _tmp ${lib}) + string (STRIP ${_tmp} _tmp) + list (APPEND NETCDF_LIBRARIES ${_tmp}) +endforeach() +#------------------------------------------------------------------ + +list(APPEND NETCDF_INCLUDES ${BASEDIR}/include/netcdf) +list(APPEND NETCDF_INCLUDES ${BASEDIR}/include/hdf5) + +message(STATUS "NETCDF_INCLUDES: ${NETCDF_INCLUDES}") +message(STATUS "NETCDF_LIBRARIES: ${NETCDF_LIBRARIES}") + diff --git a/cmake/Modules/FindCORELIBS.cmake b/cmake/Modules/FindCORELIBS.cmake index 05890ae7d..711864ebc 100644 --- a/cmake/Modules/FindCORELIBS.cmake +++ b/cmake/Modules/FindCORELIBS.cmake @@ -1,193 +1,13 @@ -function (findSrc varName version varDir ) - if(EXISTS ${CMAKE_SOURCE_DIR}/libsrc/${varName}) - set( ${varDir} "${CMAKE_SOURCE_DIR}/libsrc/${varName}" PARENT_SCOPE) - set( ${varCacheName} "${CMAKE_SOURCE_DIR}/libsrc/${varName}" CACHE STRING "" FORCE ) - else() - set(searchName ${varName}_v${${version}}) - message("searching for source for ${searchName} in ${CRTM_BASE}") - string( TOLOWER ${varName} varNameLower ) - find_path( TMP_DIR - NAMES ${searchName} - HINTS - ${CMAKE_SOURCE_DIR}/../libs - ${CRTM_BASE}/${version} - ${CRTM_BASE}/${varName} - ${CRTM_BASE}/${varName}/${version} - ${CRTM_BASE}/${varNameLower} - ${CRTM_BASE}/${varNameLower}/${version} - ${COREPATH}/sorc - $ENV{${varDir}}/libsrc - $ENV{${varDir}}/lib/sorc - $ENV{CORPATH}/lib/sorc - ${CMAKE_SOURCE_DIR}/core-libs/${varName} - ) - if( NOT TMP_DIR ) - message("didn't find directory") - set(secondSearchName v${${version}}) - find_path( TMP2_DIR - NAMES ${secondSearchName} - HINTS - ${CRTM_BASE}/${varName} - ) - endif() - set( varCacheName "${varDir}_SRC" ) - file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/*.f*" "${TMP_DIR}/${varName}_v${${version}}/*.F*") - if( f_FILES ) - set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}" PARENT_SCOPE) - set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}" CACHE STRING "" FORCE ) - else() - file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/src/*.f*" "${TMP_DIR}/${varName}_v${${version}}/src/*.F*") - if( f_FILES ) - set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}/src" PARENT_SCOPE) - set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}/src" CACHE STRING "" FORCE ) - else() - file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/libsrc/*.f*" "${TMP_DIR}/${varName}_v${${version}}/src/*.F*") - if( f_FILES ) - set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}/libsrc" PARENT_SCOPE) - set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}/libsrc" CACHE STRING "" FORCE ) - else() - file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/sorc/*.f*" "${TMP_DIR}/${varName}_v${${version}}/sorc/*.F*") - if( f_FILES ) - set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}/sorc" PARENT_SCOPE) - set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}/sorc" CACHE STRING "" FORCE ) - else() - file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/sorc/libsrc/*.f*" - "${TMP_DIR}/${varName}_v${${version}}/sorc/libsrc/*.F*") - if( f_FILES ) - set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}/sorc/libsrc" PARENT_SCOPE) - set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}/sorc/libsrc" CACHE STRING "" FORCE ) - else() - file(GLOB f_FILES "${TMP2_DIR}/v${${version}}/src/*.f*" - "${TMP_DIR}/v${${version}}/src/*.F*") - if( f_FILES ) - set( ${varDir} "${TMP2_DIR}/v${${version}}/src" PARENT_SCOPE) - set( ${varCacheName} "${TMP2_DIR}/v${${version}}/src" CACHE STRING "" FORCE ) - endif() - endif() - endif() - endif() - endif() - endif() - if( NOT f_FILES ) # look for source that is of a different version - message("WARNING: Did not find ${${version}} of ${varName}, looking for alternates") - findOtherVersion( TMP_DIR ${varName} srcPath ${version} ) - file(GLOB f_FILES "${srcPath}/*.f*" "${srcPath}/*.F*") - if( f_FILES ) - set( ${varDir} "${srcPath}" PARENT_SCOPE) - set( ${varCacheName} "${srcPath}" CACHE STRING "" FORCE ) - else() - file(GLOB f_FILES "${srcPath}/src/*.f*" "${srcPath}/src/*.F*") - if( f_FILES ) - set( ${varDir} "${srcPath}/src" PARENT_SCOPE) - set( ${varCacheName} "${srcPath}/src" CACHE STRING "" FORCE ) - else() - file(GLOB f_FILES "${srcPath}/libsrc/*.f*" "${srcPath}/src/*.F*") - if( f_FILES ) - set( ${varDir} "${srcPath}/libsrc" PARENT_SCOPE) - set( ${varCacheName} "${srcPath}/libsrc" CACHE STRING "" FORCE ) - else() - file(GLOB f_FILES "${srcPath}/sorc/*.f*" "${srcPath}/sorc/*.F*") - if( f_FILES ) - set( ${varDir} "${srcPath}/sorc" PARENT_SCOPE) - set( ${varCacheName} "${srcPath}/sorc" CACHE STRING "" FORCE ) - else() - file(GLOB f_FILES "${srcPath}/sorc/libsrc/*.f*" - "${srcPath}/sorc/libsrc/*.F*") - if( f_FILES ) - set( ${varDir} "${srcPath}/sorc/libsrc" PARENT_SCOPE) - set( ${varCacheName} "${srcPath}/sorc/libsrc" CACHE STRING "" FORCE ) - endif() - endif() - endif() - endif() - endif() - endif() - endif() -endfunction() - -function (findInc incName version incFile ) - cmake_policy(SET CMP0011 NEW) - cmake_policy(SET CMP0009 NEW) - STRING(COMPARE EQUAL ${incFile} "CRTMINC" USECRTMBASE ) - if(( USECRTMBASE ) AND ( CRTM_BASE )) - execute_process(COMMAND find ${CRTM_BASE} -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) -# file(GLOB_RECURSE INCFILES ${CRTM_BASE}/*${CRTM_VER}*/*mod ) -# file(GLOB_RECURSE INCFILES2 ${CRTM_BASE}/crtm/*${CRTM_VER}*/*/*mod ) -# list(APPEND INCFILES ${INCFILES2} ) - else() - if(crayComp) - if(CMAKE_CXX_COMPILER_ID STREQUAL "Intel") - execute_process(COMMAND find ${COREPATH}/${incName}/v${${version}}/intel -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) - else() - execute_process(COMMAND find ${COREPATH}/${incName}/v${${version}}/cray -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) - endif() - else() - execute_process(COMMAND find ${COREPATH}/${incName} -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) - endif() - if( NOT (INCFILES) ) - execute_process(COMMAND find ${COREPATH}/sorc -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) - endif() - endif() -# message("incfiles are ${INCFILES}") - if( INCFILES ) - string(REGEX REPLACE "\n" ";" INCFILES ${INCFILES} ) - endif() - foreach( INC_FILE in ${INCFILES} ) - string(REGEX MATCH ${${version}} MATCHFOUND ${INC_FILE} ) -# message("matchfound is ${MATCHFOUND}, version is ${${version}} for ${INC_FILE}") - if( MATCHFOUND ) - message("found ${INC_FILE}") - string(REGEX REPLACE "${incName}_module.mod" "" INCPATH ${INC_FILE} ) - set( ${incFile} ${INCPATH} PARENT_SCOPE ) - return() - endif() - endforeach() - file(GLOB_RECURSE INCFILES ${COREPATH}/${incName}_module.mod ) - list(LENGTH INCFILES numFiles) - if(numFiles EQUAL 1) - get_filename_component( INCPATH ${INCFILES} DIRECTORY ) - else() - foreach( INC_FILE in ${INCFILES} ) - get_filename_component( INCPATH ${INC_FILE} DIRECTORY ) -# message("WARNING: Did not find explicit version ${${version}} of ${incName} module, using un-versioned path") -# set( ${incFile} ${INCPATH} PARENT_SCOPE ) -# return() - endforeach() - endif() - set( ${incFile} ${INCPATH} PARENT_SCOPE ) -endfunction() - -function (findOtherVersion rootPath srcName srcPath newVer ) - file(GLOB SRCDIRS ${${rootPath}}/${srcName}* ) - foreach( SRC_DIR in ${SRCDIRS} ) - string(REGEX MATCH ${srcName} MATCHFOUND ${SRC_DIR} ) - if( MATCHFOUND ) - set( ${srcPath} ${SRC_DIR} PARENT_SCOPE ) - string(REGEX MATCH "[0-9].[0-9].[0-9]" ALTVER ${SRC_DIR} ) - message("Found ${ALTVER} of ${srcName}. Proceeding with Alternative") - set( ${newVer} ${ALTVER} PARENT_SCOPE ) - return() - endif() - endforeach() -endfunction() - # This module defines # CORE_INCS # List of include file paths for all required modules for GSI # CORE_LIBRARIES # Full list of libraries required to link GSI executable -if(DEFINED ENV{BACIO_VER}) - set(BACIO_VER $ENV{BACIO_VER}) - STRING(REGEX REPLACE "v" "" BACIO_VER ${BACIO_VER}) -endif() +include(findHelpers) if(DEFINED ENV{BUFR_VER}) set(BUFR_VER $ENV{BUFR_VER}) STRING(REGEX REPLACE "v" "" BUFR_VER ${BUFR_VER}) endif() -if(DEFINED ENV{CRTM_VER}) - set(CRTM_VER $ENV{CRTM_VER}) - STRING(REGEX REPLACE "v" "" CRTM_VER ${CRTM_VER}) -endif() if(DEFINED ENV{NEMSIO_VER}) set(NEMSIO_VER $ENV{NEMSIO_VER}) STRING(REGEX REPLACE "v" "" NEMSIO_VER ${NEMSIO_VER}) @@ -215,49 +35,6 @@ endif() set (CORE_DEPS " ") set( NO_DEFAULT_PATH ) -if(NOT BUILD_CRTM ) - if(DEFINED ENV{CRTM_LIB} ) - set(CRTM_LIBRARY $ENV{CRTM_LIB} ) - set(CRTMINC $ENV{CRTM_INC} ) - message("CRTM library ${CRTM_LIBRARY} set via Environment variable") - else() - findInc( crtm CRTM_VER CRTMINC ) - find_library( CRTM_LIBRARY - NAMES libcrtm_v${CRTM_VER}.a libcrtm.a libCRTM.a - HINTS - /usr/local/jcsda/nwprod_gdas_2014 - ${CRTM_BASE} - ${CRTM_BASE}/lib - ${CRTM_BASE}/${CRTM_VER} - ${CRTM_BASE}/${CRTM_VER}/lib - ${CRTM_BASE}/v${CRTM_VER}/intel - ${COREPATH} - ${COREPATH}/lib - $ENV{COREPATH} - $ENV{COREPATH}/lib - $ENV{COREPATH}/include - ${CORECRTM}/crtm/${CRTM_VER} - /nwprod2/lib/crtm/v${CRTM_VER} - PATH_SUFFIXES - lib - ${NO_DEFAULT_PATH}) - set( crtm "crtm_v${CRTM_VER}") - message("Found CRTM library ${CRTM_LIBRARY}") - endif() -else() - if( NOT DEFINED ENV{CRTM_SRC} ) - if( FIND_SRC ) - findSrc( "crtm" CRTM_VER CRTM_DIR ) - set(CRTMINC "${CMAKE_BINARY_DIR}/include") - endif() - else() - set( CRTM_DIR "$ENV{CRTM_SRC}/libsrc" CACHE STRING "CRTM Source Location") - set(CRTMINC "${CORECRTM}/crtm/${CRTM_VER}/incmod/crtm_v${CRTM_VER}") - endif() - set( libsuffix "_v${CRTM_VER}${debug_suffix}" ) - set( CRTM_LIBRARY "${LIBRARY_OUTPUT_PATH}/libcrtm${libsuffix}.a" CACHE STRING "CRTM Library" ) - set( crtm "crtm${libsuffix}") -endif() if(NOT BUILD_EMC ) if(DEFINED ENV{W3EMC_LIBd} ) set(W3EMC_LIBRARY $ENV{W3EMC_LIBd} ) @@ -268,7 +45,7 @@ if(NOT BUILD_EMC ) HINTS $ENV{COREPATH}/lib/incmod/w3emc_4 $ENV{COREPATH}/include - /usr/local/jcsda/nwprod_gdas_2014/lib/incmod/w3emc_4 + /usr/local/jcsda/nwprod_gdas_2014/lib/lib/incmod/w3emc_4 ${COREPATH}/w3emc/v${W3EMC_VER}/incmod/w3emc_v${W3EMC_VER}_d ${COREPATH}/w3emc/v${W3EMC_VER}/intel/w3emc_v${W3EMC_VER}_d ) @@ -276,7 +53,7 @@ if(NOT BUILD_EMC ) NAMES libw3emc_4.a libw3emc_i4r8.a libw3emc_v${W3EMC_VER}_d.a HINTS $ENV{COREPATH}/lib - /usr/local/jcsda/nwprod_gdas_2014 + /usr/local/jcsda/nwprod_gdas_2014/lib ${COREPATH}/w3emc/v${W3EMC_VER} ${COREPATH}/w3emc/v${W3EMC_VER}/intel PATH_SUFFIXES @@ -304,7 +81,7 @@ if(NOT BUILD_NCO ) NAMES libw3nco_v${W3NCO_VER}_d.a libw3nco_d.a libw3nco_i4r8.a HINTS $ENV{COREPATH}/lib - /usr/local/jcsda/nwprod_gdas_2014 + /usr/local/jcsda/nwprod_gdas_2014/lib ${COREPATH}/w3nco/v${W3NCO_VER} ${COREPATH}/w3nco/v${W3NCO_VER}/intel PATH_SUFFIXES @@ -324,33 +101,6 @@ else() set( W3NCO_LIBRARY "${LIBRARY_OUTPUT_PATH}/libw3nco${libsuffix}.a" CACHE STRING "W3NCO Library" ) set( w3nco "w3nco${libsuffix}") endif() -if(NOT BUILD_BACIO ) - if(DEFINED ENV{BACIO_LIB4}) - set(BACIO_LIBRARY $ENV{BACIO_LIB4} ) - else() - find_library( BACIO_LIBRARY - NAMES libbacio.a libbacio_4.a libbacio_v${BACIO_VER}_4.a - HINTS $ENV{COREPATH}/lib /usr/local/jcsda/nwprod_gdas_2014 - ${COREPATH}/bacio/v${BACIO_VER} - ${COREPATH}/bacio/v${BACIO_VER}/intel - PATH_SUFFIXES - lib - ${NO_DEFAULT_PATH} - ) - message("Found BACIO library ${BACIO_LIBRARY}") - endif() -else() - if( DEFINED ENV{BACIO_SRC} ) - set( BACIO_DIR $ENV{BACIO_SRC} CACHE STRING "BACIO Source Directory" ) - else() - if( FIND_SRC ) - findSrc( "bacio" BACIO_VER BACIO_DIR ) - endif() - endif() - set( libsuffix "_v${BACIO_VER}${debug_suffix}" ) - set( BACIO_LIBRARY "${LIBRARY_OUTPUT_PATH}/libbacio${libsuffix}.a" CACHE STRING "BACIO Library" ) - set( bacio "bacio${libsuffix}") -endif() if(NOT BUILD_BUFR ) if(DEFINED ENV{BUFR_LIBd} ) set(BUFR_LIBRARY $ENV{BUFR_LIBd} ) @@ -359,7 +109,7 @@ if(NOT BUILD_BUFR ) NAMES libbufr.a libbufr_d_64.a libbufr_i4r8.a libbufr_v${BUFR_VER}_d_64.a HINTS $ENV{COREPATH}/lib - /usr/local/jcsda/nwprod_gdas_2014 + /usr/local/jcsda/nwprod_gdas_2014/lib ${COREPATH}/bufr/v${BUFR_VER} ${COREPATH}/bufr/v${BUFR_VER}/intel PATH_SUFFIXES @@ -390,7 +140,7 @@ if(NOT BUILD_SFCIO ) NAMES libsfcio.a libsfcio_4.a libsfcio_i4r4.a libsfcio_v${SFCIO_VER}_4.a HINTS $ENV{COREPATH}/lib - /usr/local/jcsda/nwprod_gdas_2014 + /usr/local/jcsda/nwprod_gdas_2014/lib ${COREPATH}/sfcio/v${SFCIO_VER} ${COREPATH}/sfcio/v${SFCIO_VER}/intel PATH_SUFFIXES @@ -422,7 +172,7 @@ if(NOT BUILD_SIGIO ) NAMES libsigio.a libsigio_4.a libsigio_i4r4.a libsigio_v${SIGIO_VER}_4.a HINTS $ENV{COREPATH}/lib - /usr/local/jcsda/nwprod_gdas_2014 + /usr/local/jcsda/nwprod_gdas_2014/lib ${COREPATH}/sigio/v${SIGIO_VER} ${COREPATH}/sigio/v${SIGIO_VER}/intel PATH_SUFFIXES @@ -454,7 +204,7 @@ if(NOT BUILD_NEMSIO ) NAMES libnemsio.a libnemsio_v${NEMSIO_VER}.a HINTS $ENV{COREPATH}/lib - /usr/local/jcsda/nwprod_gdas_2014 + /usr/local/jcsda/nwprod_gdas_2014/lib ${COREPATH}/nemsio/v${NEMSIO_VER} ${COREPATH}/nemsio/v${NEMSIO_VER}/intel PATH_SUFFIXES @@ -483,7 +233,7 @@ if(NOT BUILD_SP ) NAMES libsp_d.a libsp_i4r8.a libsp_v${SP_VER}_d.a HINTS $ENV{COREPATH}/lib - /usr/local/jcsda/nwprod_gdas_2014 + /usr/local/jcsda/nwprod_gdas_2014/lib ${COREPATH}/sp/v${SP_VER} ${COREPATH}/sp/v${SP_VER}/intel PATH_SUFFIXES @@ -505,13 +255,17 @@ else() set( sp "sp${libsuffix}") endif() -set( CORE_LIBRARIES ${CRTM_LIBRARY} ${SFCIO_LIBRARY} ${SIGIO_LIBRARY} +if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${SFCIO_LIBRARY} ${SIGIO_LIBRARY} ${NEMSIO_LIBRARY} ${SP_LIBRARY} ${W3NCO_LIBRARY} ${BUFR_LIBRARY} - ${BACIO_LIBRARY} ${W3EMC_LIBRARY} ) -set( CORE_INCS ${INCLUDE_OUTPUT_PATH} ${CRTMINC} ${SFCIOINC} ${SIGIOINC} ${NEMSIOINC} ${W3EMCINC} ) - -set( CRTM_LIBRARY_PATH ${CRTM_LIBRARY} CACHE STRING "CRTM Library Location" ) -set( CRTM_INCLUDE_PATH ${CRTMINC} CACHE STRING "CRTM Include Location" ) + ${W3EMC_LIBRARY} CACHE INTERNAL "List of Core libs" ) + list( APPEND CORE_INCS ${INCLUDE_OUTPUT_PATH} ${SFCIOINC} ${SIGIOINC} ${NEMSIOINC} ${W3EMCINC} ) +else() + set( CORE_LIBRARIES ${SFCIO_LIBRARY} ${SIGIO_LIBRARY} + ${NEMSIO_LIBRARY} ${SP_LIBRARY} ${W3NCO_LIBRARY} ${BUFR_LIBRARY} + ${W3EMC_LIBRARY} CACHE INTERNAL "List of Core libs" ) + set( CORE_INCS ${INCLUDE_OUTPUT_PATH} ${SFCIOINC} ${SIGIOINC} ${NEMSIOINC} ${W3EMCINC} ) +endif() set( BUFR_LIBRARY_PATH ${BUFR_LIBRARY} CACHE STRING "BUFR Library Location" ) @@ -526,8 +280,6 @@ set( W3NCO_LIBRARY_PATH ${W3NCO_LIBRARY} CACHE STRING "W3NCO Library Location" ) set( W3EMC_LIBRARY_PATH ${W3EMC_LIBRARY} CACHE STRING "W3EMC Library Location" ) set( W3EMC_INCLUDE_PATH ${W3EMCINC} CACHE STRING "W3EMC Include Location" ) -set( BACIO_LIBRARY_PATH ${BACIO_LIBRARY} CACHE STRING "BACIO Library Location" ) - set( NEMSIO_LIBRARY_PATH ${NEMSIO_LIBRARY} CACHE STRING "NEMSIO Library Location" ) set( NEMSIO_INCLUDE_PATH ${NEMSIOINC} CACHE STRING "NEMSIO Include Location" ) diff --git a/cmake/Modules/FindCRTM.cmake b/cmake/Modules/FindCRTM.cmake new file mode 100644 index 000000000..ee982c149 --- /dev/null +++ b/cmake/Modules/FindCRTM.cmake @@ -0,0 +1,81 @@ +# This module defines +# CORE_INCS +# List of include file paths for all required modules for GSI +# CORE_LIBRARIES +# Full list of libraries required to link GSI executable +include(findHelpers) +if(DEFINED ENV{CRTM_VER}) + set(CRTM_VER $ENV{CRTM_VER}) + STRING(REGEX REPLACE "v" "" CRTM_VER ${CRTM_VER}) +endif() + +set( NO_DEFAULT_PATH ) +if(NOT BUILD_CRTM ) + if(DEFINED ENV{CRTM_LIB} ) + set(CRTM_LIBRARY $ENV{CRTM_LIB} ) + set(CRTMINC $ENV{CRTM_INC} ) + message("CRTM library ${CRTM_LIBRARY} set via Environment variable") + else() + findInc( crtm CRTM_VER CRTMINC ) + find_library( CRTM_LIBRARY + NAMES libcrtm_v${CRTM_VER}.a libcrtm.a libCRTM.a + HINTS + /usr/local/jcsda/nwprod_gdas_2014/lib + ${CRTM_BASE} + ${CRTM_BASE}/lib + ${CRTM_BASE}/${CRTM_VER} + ${CRTM_BASE}/${CRTM_VER}/lib + ${CRTM_BASE}/v${CRTM_VER}/intel + ${CRTM_BASE}/v${CRTM_VER}/ips/${COMPILER_VERSION} + ${COREPATH}/v${CRTM_VER}/ips/${COMPILER_VERSION} + ${COREPATH} + ${COREPATH}/lib + $ENV{COREPATH} + $ENV{COREPATH}/lib + $ENV{COREPATH}/include + ${CORECRTM}/crtm/${CRTM_VER} + /nwprod2/lib/crtm/v${CRTM_VER} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + set( crtm "crtm_v${CRTM_VER}") + message("Found CRTM library ${CRTM_LIBRARY}") + endif() +endif() +if( NOT CRTM_LIBRARY ) # didn't find the library, so build it from source + message("Could not find CRTM library, so building from libsrc") + if( NOT DEFINED ENV{CRTM_SRC} ) + findSrc( "crtm" CRTM_VER CRTM_DIR ) + set(CRTMINC "${CMAKE_BINARY_DIR}/include") + else() + set( CRTM_DIR "$ENV{CRTM_SRC}/libsrc" CACHE STRING "CRTM Source Location") + set(CRTMINC "${CORECRTM}/crtm/${CRTM_VER}/incmod/crtm_v${CRTM_VER}") + endif() + set( libsuffix "_v${CRTM_VER}${debug_suffix}" ) + set( CRTM_LIBRARY "${LIBRARY_OUTPUT_PATH}/libcrtm${libsuffix}.a" CACHE STRING "CRTM Library" ) + set( crtm "crtm${libsuffix}") + set( BUILD_CRTM "ON" CACHE INTERNAL "Build the CRTM library") + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/crtm) + set( CRTM_LIBRARY ${crtm} ) + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${CRTM_LIBRARY} ) + else() + set( CORE_BUILT ${CRTM_LIBRARY} ) + endif() +else( NOT CRTM_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${CRTM_LIBRARY} ) + else() + set( CORE_LIBRARIES ${CRTM_LIBRARY} ) + endif() +endif( NOT CRTM_LIBRARY ) + +if( CORE_INCS ) + list( APPEND CORE_INCS ${CRTMINC} ) +else() + set( CORE_INCS ${INCLUDE_OUTPUT_PATH} ${CRTMINC} ) +endif() + +set( CRTM_LIBRARY_PATH ${CRTM_LIBRARY} CACHE STRING "CRTM Library Location" ) +set( CRTM_INCLUDE_PATH ${CRTMINC} CACHE STRING "CRTM Include Location" ) + diff --git a/cmake/Modules/FindGSICONTROL.cmake b/cmake/Modules/FindGSICONTROL.cmake index ce3a7f282..5b2e12280 100644 --- a/cmake/Modules/FindGSICONTROL.cmake +++ b/cmake/Modules/FindGSICONTROL.cmake @@ -1,38 +1,50 @@ # - Find the Control version of GSI to use for regression testing set( NO_DEFAULT_PATH ) +message("Control path is ${CONTROLPATH}") find_file( CONTROL_EXE - NAMES gsi.x global_gsi + NAMES gsi.x global_gsi ${GSIEXEC} HINTS + ${CONTROLPATH} + ${CONTROLPATH}/bin + ${CONTROLPATH}/exec + $ENV{CONTROLPATH} + $ENV{CONTROLPATH}/bin + $ENV{CONTROLPATH}/exec + $ENV{CONTROLPATH}/src ${CMAKE_SOURCE_DIR}/../trunk/src ${CMAKE_SOURCE_DIR}/../../trunk/src ${PROJECT_BINARY_DIR}/../build-trunk/bin - $ENV{CONTROLPATH} - $ENV{CONTROLPATH}/src /da/save/Michael.Lueken/svn1/build/bin /da/save/Michael.Lueken/svn1/src - /gpfs/hps/emc/da/noscrub/Michael.Lueken/svn1/build/bin - /gpfs/hps/emc/da/noscrub/Michael.Lueken/svn1/src - /scratch4/NCEPDEV/da/save/Michael.Lueken/svn1/build/bin - /scratch4/NCEPDEV/da/save/Michael.Lueken/svn1/src + /gpfs/dell2/emc/modeling/noscrub/Michael.Lueken/svn1/build/bin + /gpfs/hps3/emc/da/noscrub/Michael.Lueken/svn1/build/bin + /gpfs/hps3/emc/da/noscrub/Michael.Lueken/svn1/src + /scratch1/NCEPDEV/da/Michael.Lueken/svn1/build/bin ${NO_DEFAULT_PATH}) set( GSICONTROL ${CONTROL_EXE} CACHE STRING "GSI control executable for regression testing" FORCE ) find_file( ENKF_CONTROL_EXE - NAMES enkf_gfs.x global_enkf + NAMES enkf_gfs.x global_enkf ${ENKFEXEC} HINTS + ${CONTROLPATH} + ${CONTROLPATH}/bin + ${CONTROLPATH}/exec + $ENV{CONTROLPATH} + $ENV{CONTROLPATH}/bin + $ENV{CONTROLPATH}/exec ${CMAKE_SOURCE_DIR}/../trunk/src/enkf ${PROJECT_BINARY_DIR}/../build-trunk/bin $ENV{CONTROLPATH}/enkf $ENV{CONTROLPATH}/src/enkf /da/save/Michael.Lueken/svn1/build/bin /da/save/Michael.Lueken/svn1/src/enkf - /gpfs/hps/emc/da/noscrub/Michael.Lueken/svn1/build/bin - /gpfs/hps/emc/da/noscrub/Michael.Lueken/svn1/src/enkf - /scratch4/NCEPDEV/da/save/Michael.Lueken/svn1/build/bin - /scratch4/NCEPDEV/da/save/Michael.Lueken/svn1/src/enkf + /gpfs/dell2/emc/modeling/noscrub/Michael.Lueken/svn1/build/bin + /gpfs/hps3/emc/da/noscrub/Michael.Lueken/svn1/build/bin + /gpfs/hps3/emc/da/noscrub/Michael.Lueken/svn1/src/enkf + /scratch1/NCEPDEV/da/Michael.Lueken/svn1/build/bin ${NO_DEFAULT_PATH}) diff --git a/cmake/Modules/FindHDF5.cmake b/cmake/Modules/FindHDF5.cmake new file mode 100644 index 000000000..9b8cffc46 --- /dev/null +++ b/cmake/Modules/FindHDF5.cmake @@ -0,0 +1,25 @@ +# This extends CMake's FindHDF5.cmake to add support to include MPI include +# paths and libraries in the HDF5 ones if HDF5_IS_PARALLEL is ON +# (BUG #0014363). + +# include the default FindHDF5.cmake. +#if(CMAKE_VERSION VERSION_LESS 3.6.1) +if(CMAKE_VERSION VERSION_GREATER 3.0 ) + include(${CMAKE_CURRENT_LIST_DIR}/NewCMake/FindHDF5.cmake) +else() + include(${CMAKE_ROOT}/Modules/FindHDF5.cmake) +endif() +#endif() + +if(HDF5_FOUND AND (HDF5_IS_PARALLEL OR HDF5_ENABLE_PARALLEL)) + include(vtkMPI) + if(MPI_C_INCLUDE_PATH) + list(APPEND HDF5_INCLUDE_DIRS ${MPI_C_INCLUDE_PATH}) + endif() + if(MPI_C_LIBRARIES) + list(APPEND HDF5_LIBRARIES ${MPI_C_LIBRARIES}) + endif() + if(MPI_CXX_LIBRARIES) + list(APPEND HDF5_LIBRARIES ${MPI_CXX_LIBRARIES}) + endif() +endif() diff --git a/cmake/Modules/FindMPI.cmake b/cmake/Modules/FindMPI.cmake new file mode 100644 index 000000000..8e0a0c95b --- /dev/null +++ b/cmake/Modules/FindMPI.cmake @@ -0,0 +1,18 @@ +# This extends CMake's FindHDF5.cmake to add support to include MPI include +# paths and libraries in the HDF5 ones if HDF5_IS_PARALLEL is ON +# (BUG #0014363). + +# include the default FindMPI.cmake. +if(CMAKE_VERSION VERSION_LESS 3.1) + include(${CMAKE_ROOT}/Modules/FindMPI.cmake) +elseif(CMAKE_VERSION VERSION_LESS 3.6) + message("Using new FindMPI") + include(${CMAKE_CURRENT_LIST_DIR}/NewCMake/FindMPI.cmake) +# set(MPI_Fortran_INCLUDE_DIRS ${MPI_Fortran_INCLUDE_PATH} CACHE INTERNAL "Deprecated Variable Name") +else() + message("Using installed FindMPI") + include(${CMAKE_ROOT}/Modules/FindMPI.cmake) +# set(MPI_Fortran_INCLUDE_DIRS ${MPI_Fortran_INCLUDE_PATH} CACHE INTERNAL "Deprecated Variable Name") + message("include dirs are ${MPI_Fortran_INCLUDE_DIRS}") + message("include PATH ${MPI_Fortran_INCLUDE_PATH}") +endif() diff --git a/cmake/Modules/FindNDATE.cmake b/cmake/Modules/FindNDATE.cmake new file mode 100644 index 000000000..44bf4f1cd --- /dev/null +++ b/cmake/Modules/FindNDATE.cmake @@ -0,0 +1,13 @@ +# - Find the NDATE utility or build it + +set( NO_DEFAULT_PATH ) +if(DEFINED ENV{NDATE}) + set(NDATE $ENV{NDATE} ) +else() + find_file( NDATE + NAMES ndate.x ndate + HINTS + /nwprod/util/exec + $ENV{NWPROD}/util/exec + ${NO_DEFAULT_PATH}) +endif() diff --git a/cmake/Modules/FindNEMSIO.cmake b/cmake/Modules/FindNEMSIO.cmake new file mode 100644 index 000000000..1263fc516 --- /dev/null +++ b/cmake/Modules/FindNEMSIO.cmake @@ -0,0 +1,72 @@ +# This module defines +# CORE_INCS +# List of include file paths for all required modules for GSI +# CORE_LIBRARIES +# Full list of libraries required to link GSI executable +include(findHelpers) +if(DEFINED ENV{NEMSIO_VER}) + set(NEMSIO_VER $ENV{NEMSIO_VER}) + STRING(REGEX REPLACE "v" "" NEMSIO_VER ${NEMSIO_VER}) +endif() + +set( NO_DEFAULT_PATH ) +if(NOT BUILD_NEMSIO ) + if(DEFINED ENV{NEMSIO_LIB} ) + set(NEMSIO_LIBRARY $ENV{NEMSIO_LIB} ) + set(NEMSIOINC $ENV{NEMSIO_INC} ) + message("NEMSIO library ${NEMSIO_LIBRARY} set via Environment variable") + else() + findInc( nemsio NEMSIO_VER NEMSIOINC ) + find_library( NEMSIO_LIBRARY + NAMES libnemsio_v${NEMSIO_VER}.a libnemsio.a libNEMSIO.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/nemsio/v${NEMSIO_VER} + ${COREPATH}/nemsio/v${NEMSIO_VER}/intel + ${COREPATH}/nemsio/v${NEMSIO_VER}//ips/${COMPILER_VERSION}/impi/${COMPILER_VERSION} + ${COREPATH}/nemsio/v${NEMSIO_VER}//ips/${COMPILER_VERSION}/smpi/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + set( nemsio "nemsio_v${NEMSIO_VER}") + message("Found NEMSIO library ${NEMSIO_LIBRARY}") + endif() +endif() +if( NOT NEMSIO_LIBRARY ) # didn't find the library, so build it from source + message("Could not find NEMSIO library, so building from libsrc") + if( NOT DEFINED ENV{NEMSIO_SRC} ) + findSrc( "nemsio" NEMSIO_VER NEMSIO_DIR ) + set(NEMSIOINC "${CMAKE_BINARY_DIR}/include") + else() + set( NEMSIO_DIR "$ENV{NEMSIO_SRC}/libsrc" CACHE STRING "NEMSIO Source Location") + set(NEMSIOINC "${CORENEMSIO}/nemsio/${NEMSIO_VER}/incmod/nemsio_v${NEMSIO_VER}") + endif() + set( libsuffix "_v${NEMSIO_VER}${debug_suffix}" ) + set( NEMSIO_LIBRARY "${LIBRARY_OUTPUT_PATH}/libnemsio${libsuffix}.a" CACHE STRING "NEMSIO Library" ) + set( nemsio "nemsio${libsuffix}") + set( BUILD_NEMSIO "ON" CACHE INTERNAL "Build the NEMSIO library") + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/nemsio) + set( NEMSIO_LIBRARY ${nemsio} ) + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${NEMSIO_LIBRARY} ) + else() + set( CORE_BUILT ${NEMSIO_LIBRARY} ) + endif() +else( NOT NEMSIO_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${NEMSIO_LIBRARY} ) + else() + set( CORE_LIBRARIES ${NEMSIO_LIBRARY} ) + endif() +endif( NOT NEMSIO_LIBRARY ) + +if( CORE_INCS ) + list( APPEND CORE_INCS ${NEMSIOINC} ) +else() + set( CORE_INCS ${INCLUDE_OUTPUT_PATH} ${NEMSIOINC} ) +endif() + +set( NEMSIO_LIBRARY_PATH ${NEMSIO_LIBRARY} CACHE STRING "NEMSIO Library Location" ) +set( NEMSIO_INCLUDE_PATH ${NEMSIOINC} CACHE STRING "NEMSIO Include Location" ) + diff --git a/cmake/Modules/FindNetCDF.cmake b/cmake/Modules/FindNetCDF.cmake index aecc63df1..f114c8df8 100644 --- a/cmake/Modules/FindNetCDF.cmake +++ b/cmake/Modules/FindNetCDF.cmake @@ -26,79 +26,35 @@ # target_link_libraries (only_uses_c_interface ${NETCDF_LIBRARIES_C}) +set(NETCDF_DIR $ENV{NETCDF}) +message("Enviroment NETCDF is ${NetCDF}") -if ( HOST-S4 ) if (NETCDF_INCLUDES AND NETCDF_LIBRARIES) # Already in cache, be silent set (NETCDF_FIND_QUIETLY TRUE) endif (NETCDF_INCLUDES AND NETCDF_LIBRARIES) -find_path (NETCDF_INCLUDES netcdf.h - HINTS NETCDF_DIR ENV NETCDF_DIR) - -find_program (NETCDF_META netcdf_meta.h - HINTS ${NETCDF_INCLUDES} ${CMAKE_INSTALL_PREFIX} - ) -if (NETCDF_META) - file (STRINGS ${NETCDF_META} NETCDF_VERSION REGEX "define NC_VERSION_MAJOR") - string (REGEX REPLACE "#define NC_VERSION_MAJOR " "" NETCDF_VERSION ${NETCDF_VERSION}) - string (REGEX REPLACE "\\/\\*\\!< netcdf-c major version. \\*\\/" "" NETCDF_VERSION ${NETCDF_VERSION}) - string (REGEX REPLACE " " "" NETCDF_VERSION ${NETCDF_VERSION} PARENT_SCOPE ) - if(${NETCDF_VERSION} GREATER "3") - set(NETCDF_F90 "YES") - endif() -endif (NETCDF_META) - -find_library (NETCDF_LIBRARIES_C NAMES libnetcdf.a) -mark_as_advanced(NETCDF_LIBRARIES_C) - -set (NetCDF_has_interfaces "YES") # will be set to NO if we're missing any interfaces -set (NetCDF_libs "${NETCDF_LIBRARIES_C}") - -get_filename_component (NetCDF_lib_dirs "${NETCDF_LIBRARIES_C}" PATH) - -macro (NetCDF_check_interface lang header libs) - if (NETCDF_${lang}) - find_path (NETCDF_INCLUDES_${lang} NAMES ${header} - HINTS "${NETCDF_INCLUDES}" NO_DEFAULT_PATH) - find_library (NETCDF_LIBRARIES_${lang} NAMES "lib${libs}.a" - HINTS "${NetCDF_lib_dirs}" NO_DEFAULT_PATH) - mark_as_advanced (NETCDF_INCLUDES_${lang} NETCDF_LIBRARIES_${lang}) - if (NETCDF_INCLUDES_${lang} AND NETCDF_LIBRARIES_${lang}) - list (INSERT NetCDF_libs 0 ${NETCDF_LIBRARIES_${lang}}) # prepend so that -lnetcdf is last - else (NETCDF_INCLUDES_${lang} AND NETCDF_LIBRARIES_${lang}) - set (NetCDF_has_interfaces "NO") - message (STATUS "Failed to find NetCDF interface for ${lang}") - endif (NETCDF_INCLUDES_${lang} AND NETCDF_LIBRARIES_${lang}) - endif (NETCDF_${lang}) -endmacro (NetCDF_check_interface) - -NetCDF_check_interface (CXX netcdfcpp.h netcdf_c++) -NetCDF_check_interface (F77 netcdf.inc netcdff) -NetCDF_check_interface (F90 netcdf.mod netcdff) -if( NETCDF_LIBRARIES_F90 ) - set( NETCDF4 "YES" ) +if(DEFINED ENV{NETCDF4}) + message("Enviroment NETCDF4 is ${NetCDF4}") + set(NETCDF_DIR $ENV{NETCDF4}) +elseif(DEFINED ENV{NETCDF_DIR}) + set(NETCDF_DIR $ENV{NETCDF_DIR}) +elseif(DEFINED ENV{NETCDF_HOME}) + set(NETCDF_DIR $ENV{NETCDF_HOME}) +elseif( DEFINED ENV{NETCDF} ) + set(NETCDF_DIR $ENV{NETCDF}) +elseif(DEFINED ENV{SSEC_NETCDF4_DIR}) + set(NETCDF_DIR $ENV{SSEC_NETCDF4_DIR}) +elseif(DEFINED ENV{SSEC_NETCDF_DIR}) + set(NETCDF_DIR $ENV{SSEC_NETCDF_DIR}) +endif() +if(DEFINED ENV{NETCDF_FORTRAN}) + set(NETCDF_FORTRAN $ENV{NETCDF_FORTRAN}) +elseif(DEFINED ENV{NETCDF_FORTRAN_DIR}) + set(NETCDF_FORTRAN $ENV{NETCDF_FORTRAN_DIR}) endif() - - -set (NETCDF_LIBRARIES "${NetCDF_libs}" CACHE STRING "All NetCDF libraries required for interface level") - -# handle the QUIETLY and REQUIRED arguments and set NETCDF_FOUND to TRUE if -# all listed variables are TRUE -include (FindPackageHandleStandardArgs) -find_package_handle_standard_args (NetCDF DEFAULT_MSG NETCDF_LIBRARIES NETCDF_INCLUDES NetCDF_has_interfaces) - -mark_as_advanced (NETCDF_LIBRARIES NETCDF_INCLUDES) - -else() -if (NETCDF_INCLUDES AND NETCDF_LIBRARIES) - # Already in cache, be silent - set (NETCDF_FIND_QUIETLY TRUE) -endif (NETCDF_INCLUDES AND NETCDF_LIBRARIES) - -set(NETCDF_DIR $ENV{NETCDF}) find_path (NETCDF_INCLUDES netcdf.h - HINTS ${NETCDF_DIR}/include ) + HINTS ${NETCDF_DIR}/include $ENV{SSEC_NETCDF_DIR}/include ) find_program (NETCDF_META netcdf_meta.h HINTS ${NETCDF_INCLUDES} ${CMAKE_INSTALL_PREFIX} @@ -117,28 +73,54 @@ find_library (NETCDF_flib names libnetcdff.a netcdff.a libnetcdff.so netcdff.so HINTS ${NETCDF_DIR}/lib + ${NETCDF_FORTRAN_DIR}/lib + ${NETCDF_FORTRAN}/lib + ${NETCDF_FORTRAN_ROOT}/lib ) if (NETCDF_flib) set(NETCDF_F90 "YES") + endif() - find_library (NETCDF_LIBRARIES_C NAMES netcdf HINTS ${NETCDF_DIR}/lib ) mark_as_advanced(NETCDF_LIBRARIES_C) -set (NetCDF_has_interfaces "YES") # will be set to NO if we're missing any interfaces -set (NetCDF_libs "${NETCDF_LIBRARIES_C}") +if("${NETCDF_DIR}" STREQUAL "") + message(FATAL_ERROR " + Cannot find NETCDF!!!! + + ") +endif() +find_file (NETCDF_NCDUMP + NAMES ncdump + HINTS ${NETCDF_DIR}/bin ) +mark_as_advanced(NETCDF_NCDUMP) +execute_process(COMMAND ${NETCDF_NCDUMP} + ERROR_VARIABLE NCDUMP_INFO) +string(FIND "${NCDUMP_INFO}" "version" VERSION_LOC REVERSE) +math(EXPR VERSION_LOC "${VERSION_LOC} + 9") +string(SUBSTRING "${NCDUMP_INFO}" ${VERSION_LOC} 1 NETCDF_MAJOR_VERSION) +if (${NETCDF_MAJOR_VERSION} LESS 4) + message(FATAL_ERROR " + Current NETCDF is ${NETCDF_DIR} + !!!! NETCDF version 4.0 and above is required !!!! + + ") +endif() +set (NetCDF_has_interfaces "YES") # will be set to NO if we're missing any interfaces +set (NetCDF_libs ${NETCDF_LIBRARIES_C} ${NETCDF_LIBRARIES_Fortran}) +message("netcdf_libs is ${NetCDF_libs}") get_filename_component (NetCDF_lib_dirs "${NETCDF_LIBRARIES_C}" PATH) macro (NetCDF_check_interface lang header libs) if (NETCDF_${lang}) find_path (NETCDF_INCLUDES_${lang} NAMES ${header} - HINTS "${NETCDF_INCLUDES}" NO_DEFAULT_PATH) + HINTS ${NETCDF_INCLUDES} ${NETCDF_FORTRAN}/include NO_DEFAULT_PATH) find_library (NETCDF_LIBRARIES_${lang} NAMES ${libs} - HINTS "${NetCDF_lib_dirs}" NO_DEFAULT_PATH) + HINTS ${NetCDF_lib_dirs} ${NETCDF_FORTRAN}/lib NO_DEFAULT_PATH) mark_as_advanced (NETCDF_INCLUDES_${lang} NETCDF_LIBRARIES_${lang}) if (NETCDF_INCLUDES_${lang} AND NETCDF_LIBRARIES_${lang}) list (INSERT NetCDF_libs 0 ${NETCDF_LIBRARIES_${lang}}) # prepend so that -lnetcdf is last @@ -157,11 +139,9 @@ if( NETCDF_LIBRARIES_F90 ) endif() set (NETCDF_LIBRARIES "${NetCDF_libs}" CACHE STRING "All NetCDF libraries required for interface level") - # handle the QUIETLY and REQUIRED arguments and set NETCDF_FOUND to TRUE if # all listed variables are TRUE include (FindPackageHandleStandardArgs) find_package_handle_standard_args (NetCDF DEFAULT_MSG NETCDF_LIBRARIES NETCDF_INCLUDES NetCDF_has_interfaces) mark_as_advanced (NETCDF_LIBRARIES NETCDF_INCLUDES) -endif() diff --git a/cmake/Modules/FindSFCIO.cmake b/cmake/Modules/FindSFCIO.cmake new file mode 100644 index 000000000..d8928bc21 --- /dev/null +++ b/cmake/Modules/FindSFCIO.cmake @@ -0,0 +1,71 @@ +# This module defines +# CORE_INCS +# List of include file paths for all required modules for GSI +# CORE_LIBRARIES +# Full list of libraries required to link GSI executable +include(findHelpers) +if(DEFINED ENV{SFCIO_VER}) + set(SFCIO_VER $ENV{SFCIO_VER}) + STRING(REGEX REPLACE "v" "" SFCIO_VER ${SFCIO_VER}) +endif() + +set( NO_DEFAULT_PATH ) +if(NOT BUILD_SFCIO ) + if(DEFINED ENV{SFCIO_LIB4} ) + set(SFCIO_LIBRARY $ENV{SFCIO_LIB4} ) + set(SFCIOINC $ENV{SFCIO_INC4} ) + message("SFCIO library ${SFCIO_LIBRARY} set via Environment variable") + else() + findInc( sfcio SFCIO_VER SFCIOINC ) + find_library( SFCIO_LIBRARY + NAMES libsfcio.a libsfcio_4.a libsfcio_i4r4.a libsfcio_v${SFCIO_VER}_4.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/sfcio/v${SFCIO_VER} + ${COREPATH}/sfcio/v${SFCIO_VER}/intel + ${COREPATH}/sfcio/v${SFCIO_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + set( sfcio "sfcio_v${SFCIO_VER}") + message("Found SFCIO library ${SFCIO_LIBRARY}") + endif() +endif() +if( NOT SFCIO_LIBRARY ) # didn't find the library, so build it from source + message("Could not find SFCIO library, so building from libsrc") + if( NOT DEFINED ENV{SFCIO_SRC} ) + findSrc( "sfcio" SFCIO_VER SFCIO_DIR ) + set(SFCIOINC "${CMAKE_BINARY_DIR}/include") + else() + set( SFCIO_DIR "$ENV{SFCIO_SRC}/libsrc" CACHE STRING "SFCIO Source Location") + set(SFCIOINC "${CORESFCIO}/sfcio/${SFCIO_VER}/incmod/sfcio_v${SFCIO_VER}") + endif() + set( libsuffix "_v${SFCIO_VER}${debug_suffix}" ) + set( SFCIO_LIBRARY "${LIBRARY_OUTPUT_PATH}/libsfcio${libsuffix}.a" CACHE STRING "SFCIO Library" ) + set( sfcio "sfcio${libsuffix}") + set( BUILD_SFCIO "ON" CACHE INTERNAL "Build the SFCIO library") + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/sfcio) + set( SFCIO_LIBRARY ${sfcio} ) + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${SFCIO_LIBRARY} ) + else() + set( CORE_BUILT ${SFCIO_LIBRARY} ) + endif() +else( NOT SFCIO_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${SFCIO_LIBRARY} ) + else() + set( CORE_LIBRARIES ${SFCIO_LIBRARY} ) + endif() +endif( NOT SFCIO_LIBRARY ) + +if( CORE_INCS ) + list( APPEND CORE_INCS ${SFCIOINC} ) +else() + set( CORE_INCS ${INCLUDE_OUTPUT_PATH} ${SFCIOINC} ) +endif() + +set( SFCIO_LIBRARY_PATH ${SFCIO_LIBRARY} CACHE STRING "SFCIO Library Location" ) +set( SFCIO_INCLUDE_PATH ${SFCIOINC} CACHE STRING "SFCIO Include Location" ) + diff --git a/cmake/Modules/FindSIGIO.cmake b/cmake/Modules/FindSIGIO.cmake new file mode 100644 index 000000000..173328c45 --- /dev/null +++ b/cmake/Modules/FindSIGIO.cmake @@ -0,0 +1,72 @@ +# This module defines +# CORE_INCS +# List of include file paths for all required modules for GSI +# CORE_LIBRARIES +# Full list of libraries required to link GSI executable +include(findHelpers) +if(DEFINED ENV{SIGIO_VER}) + set(SIGIO_VER $ENV{SIGIO_VER}) + STRING(REGEX REPLACE "v" "" SIGIO_VER ${SIGIO_VER}) +endif() + +set( NO_DEFAULT_PATH ) +if(NOT BUILD_SIGIO ) + if(DEFINED ENV{SIGIO_LIB4} ) + set(SIGIO_LIBRARY $ENV{SIGIO_LIB4} ) + set(SIGIOINC $ENV{SIGIO_INC4} ) + message("SIGIO library ${SIGIO_LIBRARY} set via Environment variable") + else() + findInc( sigio SIGIO_VER SIGIOINC ) + find_library( SIGIO_LIBRARY + NAMES libsigio.a libsigio_4.a libsigio_i4r4.a libsigio_v${SIGIO_VER}_4.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/sigio/v${SIGIO_VER} + ${COREPATH}/sigio/v${SIGIO_VER}/intel + ${COREPATH}/sigio/v${SIGIO_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + set( sigio "sigio_v${SIGIO_VER}") + message("Found SIGIO library ${SIGIO_LIBRARY}") + endif() +endif() +if( NOT SIGIO_LIBRARY ) # didn't find the library, so build it from source + message("Could not find SIGIO library, so building from libsrc") + if( NOT DEFINED ENV{SIGIO_SRC} ) + findSrc( "sigio" SIGIO_VER SIGIO_DIR ) + set(SIGIOINC "${CMAKE_BINARY_DIR}/include") + else() + set( SIGIO_DIR "$ENV{SIGIO_SRC}/libsrc" CACHE STRING "SIGIO Source Location") + set(SIGIOINC "${CORESIGIO}/sigio/${SIGIO_VER}/incmod/sigio_v${SIGIO_VER}") + endif() + set( libsuffix "_v${SIGIO_VER}${debug_suffix}" ) + set( SIGIO_LIBRARY "${LIBRARY_OUTPUT_PATH}/libsigio${libsuffix}.a" CACHE STRING "SIGIO Library" ) + set( sigio "sigio${libsuffix}") + set( BUILD_SIGIO "ON" CACHE INTERNAL "Build the SIGIO library") + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/sigio) + set( SIGIO_LIBRARY ${sigio} ) + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${SIGIO_LIBRARY} ) + else() + set( CORE_BUILT ${SIGIO_LIBRARY} ) + endif() +else( NOT SIGIO_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${SIGIO_LIBRARY} ) + else() + set( CORE_LIBRARIES ${SIGIO_LIBRARY} ) + endif() +endif( NOT SIGIO_LIBRARY ) + +if( CORE_INCS ) + list( APPEND CORE_INCS ${SIGIOINC} ) +else() + set( CORE_INCS ${INCLUDE_OUTPUT_PATH} ${SIGIOINC} ) +endif() + + +set( SIGIO_LIBRARY_PATH ${SIGIO_LIBRARY} CACHE STRING "SIGIO Library Location" ) +set( SIGIO_INCLUDE_PATH ${SIGIOINC} CACHE STRING "SIGIO Include Location" ) + diff --git a/cmake/Modules/FindSP.cmake b/cmake/Modules/FindSP.cmake new file mode 100644 index 000000000..b5fba9734 --- /dev/null +++ b/cmake/Modules/FindSP.cmake @@ -0,0 +1,83 @@ +# This module defines +# CORE_INCS +# List of include file paths for all required modules for GSI +# CORE_LIBRARIES +# Full list of libraries required to link GSI executable +include(findHelpers) +if(DEFINED ENV{SP_VER}) + set(SP_VER $ENV{SP_VER}) + STRING(REGEX REPLACE "v" "" SP_VER ${SP_VER}) +endif() + +set( NO_DEFAULT_PATH ) +if(NOT BUILD_SP ) + if(DEFINED ENV{SP_LIBd} ) + set(SP_LIBRARY $ENV{SP_LIBd} ) + message("SP library ${SP_LIBRARY} set via Environment variable") + else() + find_library( SP_LIBRARY + NAMES libsp_d.a libsp_i4r8.a libsp_v${SP_VER}_d.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/sp/v${SP_VER} + ${COREPATH}/sp/v${SP_VER}/intel + ${COREPATH}/sp/v${SP_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + set( sp "sp_v${SP_VER}_d") + message("Found SP library ${SP_LIBRARY}") + endif() + if(DEFINED ENV{SP_LIB4} ) + set(SP_4_LIBRARY $ENV{SP_LIB4} ) + message("SP library ${SP_4_LIBRARY} set via Environment variable") + else() + find_library( SP_4_LIBRARY + NAMES libsp_4.a libsp_i4r4.a libsp_v${SP_VER}_4.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/sp/v${SP_VER} + ${COREPATH}/sp/v${SP_VER}/intel + ${COREPATH}/sp/v${SP_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + set( sp "sp_v${SP_VER}_4") + message("Found SP_4 library ${SP_4_LIBRARY}") + endif() +endif() +if( NOT SP_LIBRARY ) # didn't find the library, so build it from source + message("Could not find SP library, so building from libsrc") + if( NOT DEFINED ENV{SP_SRC} ) + findSrc( "sp" SP_VER SP_DIR ) + else() + set( SP_DIR "$ENV{SP_SRC}/libsrc" CACHE STRING "SP Source Location") + endif() + set( libsuffix "_v${SP_VER}${debug_suffix}" ) + set( SP_LIBRARY "${LIBRARY_OUTPUT_PATH}/libsp${libsuffix}.a" CACHE STRING "SP Library" ) + set( SP_4_LIBRARY "${LIBRARY_OUTPUT_PATH}/libsp_4${libsuffix}.a" CACHE STRING "SP_4 Library" ) + set( sp "sp${libsuffix}") + set( sp4 "sp_4${libsuffix}") + set( BUILD_SP "ON" CACHE INTERNAL "Build the SP library") + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/sp) + set( SP_LIBRARY ${sp} ) + set( SP_4_LIBRARY ${sp4} ) + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${SP_LIBRARY} ) + else() + set( CORE_BUILT ${SP_LIBRARY} ) + endif() +else( NOT SP_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${SP_LIBRARY} ) + else() + set( CORE_LIBRARIES ${SP_LIBRARY} ) + endif() +endif( NOT SP_LIBRARY ) + + +set( SP_LIBRARY_PATH ${SP_LIBRARY} CACHE STRING "SP Library Location" ) +set( SP_4_LIBRARY_PATH ${SP_4_LIBRARY} CACHE STRING "SP_4 Library Location" ) + diff --git a/cmake/Modules/FindW3EMC.cmake b/cmake/Modules/FindW3EMC.cmake new file mode 100644 index 000000000..3cbce42a6 --- /dev/null +++ b/cmake/Modules/FindW3EMC.cmake @@ -0,0 +1,124 @@ +# This module defines +# CORE_INCS +# List of include file paths for all required modules for GSI +# CORE_LIBRARIES +# Full list of libraries required to link GSI executable +include(findHelpers) +if(DEFINED ENV{W3EMC_VER}) + set(W3EMC_VER $ENV{W3EMC_VER}) + set(W3EMCINC $ENV{W3EMC_INCd} ) + set(W3EMC4INC $ENV{W3EMC_INC4} ) + STRING(REGEX REPLACE "v" "" W3EMC_VER ${W3EMC_VER}) +endif() +if(DEFINED ENV{W3EMC_LIBd}) + set(W3EMC_LIBRARY $ENV{W3EMC_LIBd} ) + set(W3EMCINC $ENV{W3EMC_INCd} ) + set(W3EMC_4_LIBRARY $ENV{W3EMC_LIB4} ) + set(W3EMC4INC $ENV{W3EMC_INC4} ) + message("Setting W3EMC library via environment variable ${W3EMC_LIBRARY}") +endif() + +set( NO_DEFAULT_PATH ) +if((NOT BUILD_W3EMC ) AND ( NOT DEFINED W3EMC_LIBRARY )) + if(DEFINED ENV{W3EMC_LIB} ) + set(W3EMC_LIBRARY $ENV{W3EMC_LIB} ) + set(W3EMCINC $ENV{W3EMC_INC} ) + set(W3EMC_4_LIBRARY $ENV{W3EMC_LIB4} ) + set(W3EMC4INC $ENV{W3EMC_INC4} ) + message("W3EMC library ${W3EMC_LIBRARY} set via Environment variable") + message("W3EMC_4 library ${W3EMC_4_LIBRARY} set via Environment variable") + else() + find_path( W3EMCINC + NAMES mersenne_twister.mod + HINTS + $ENV{COREPATH}/lib/incmod/w3emc_d + $ENV{COREPATH}/include + /usr/local/jcsda/nwprod_gdas_2014/lib/incmod/w3emc_d + ${COREPATH}/w3emc/v${W3EMC_VER}/incmod/w3emc_v${W3EMC_VER}_d + ${COREPATH}/w3emc/v${W3EMC_VER}/intel/w3emc_v${W3EMC_VER}_d + ${COREPATH}/w3emc/v${W3EMC_VER}/ips/${COMPILER_VERSION}/impi/${COMPILER_VERSION}/include/w3emc_v${W3EMC_VER}_d + ${COREPATH}/w3emc/v${W3EMC_VER}/ips/${COMPILER_VERSION}/smpi/${COMPILER_VERSION}/include/w3emc_v${W3EMC_VER}_d + ) + find_path( W3EMC4INC + NAMES mersenne_twister.mod + HINTS + $ENV{COREPATH}/lib/incmod/w3emc_4 + $ENV{COREPATH}/include + /usr/local/jcsda/nwprod_gdas_2014/lib/incmod/w3emc_4 + ${COREPATH}/w3emc/v${W3EMC_VER}/incmod/w3emc_v${W3EMC_VER}_4 + ${COREPATH}/w3emc/v${W3EMC_VER}/intel/w3emc_v${W3EMC_VER}_4 + ${COREPATH}/w3emc/v${W3EMC_VER}/ips/${COMPILER_VERSION}/impi/${COMPILER_VERSION}/include/w3emc_v${W3EMC_VER}_4 + ${COREPATH}/w3emc/v${W3EMC_VER}/ips/${COMPILER_VERSION}/smpi/${COMPILER_VERSION}/include/w3emc_v${W3EMC_VER}_4 + ) + find_library( W3EMC_LIBRARY + NAMES libw3emc_d.a libw3emc_v${W3EMC_VER}_d.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014 + ${COREPATH}/w3emc/v${W3EMC_VER} + ${COREPATH}/w3emc/v${W3EMC_VER}/intel + ${COREPATH}/w3emc/v${W3EMC_VER}/ips/${COMPILER_VERSION}/impi/${COMPILER_VERSION} + ${COREPATH}/w3emc/v${W3EMC_VER}/ips/${COMPILER_VERSION}/smpi/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + find_library( W3EMC_4_LIBRARY + NAMES libw3emc_4.a libw3emc_i4r4.a libw3emc_v${W3EMC_VER}_4.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014 + ${COREPATH}/w3emc/v${W3EMC_VER} + ${COREPATH}/w3emc/v${W3EMC_VER}/intel + ${COREPATH}/w3emc/v${W3EMC_VER}/ips/${COMPILER_VERSION}/impi/${COMPILER_VERSION} + ${COREPATH}/w3emc/v${W3EMC_VER}/ips/${COMPILER_VERSION}/smpi/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + message("Found W3EMC_4 library ${W3EMC_4_LIBRARY}") + endif() +endif() +if( NOT W3EMC_LIBRARY ) # didn't find the library, so build it from source + message("Could not find W3EMC library, so building from libsrc") + if( NOT DEFINED ENV{W3EMC_SRC} ) + findSrc( "w3emc" W3EMC_VER W3EMC_DIR ) + set(W3EMCINC "${CMAKE_BINARY_DIR}/include" CACHE STRING "W3EMC Include Directory") + set(W3EMC4INC "${CMAKE_BINARY_DIR}/include" CACHE STRING "W3EMC4 Include Directory") + else() + set( W3EMC_DIR "$ENV{W3EMC_SRC}/libsrc" CACHE STRING "W3EMC Source Location") + endif() + set( libsuffix "_v${W3EMC_VER}${debug_suffix}" ) + set( W3EMC_LIBRARY "${LIBRARY_OUTPUT_PATH}/libw3emc${libsuffix}.a" CACHE STRING "W3EMC Library" ) + set( w3emc "w3emc${libsuffix}") + set( w3emc4 "w3emc_4${libsuffix}") + set( BUILD_W3EMC "ON" CACHE INTERNAL "Build the W3EMC library") + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/w3emc) + set( W3EMC_LIBRARY ${w3emc} ) + set( W3EMC_4_LIBRARY ${w3emc} ) + set(W3EMCINC "${CMAKE_BINARY_DIR}/include" CACHE STRING "W3EMC Include Directory") + set(W3EMC4INC ${CMAKE_INCLUDE_4_OUTPUT_DIRECTORY} CACHE STRING "W3EMC4 Include Directory") + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${W3EMC_LIBRARY} ) + list( APPEND CORE_BUILT ${W3EMC_4_LIBRARY} ) + else() + set( CORE_BUILT ${W3EMC_LIBRARY} ) + set( CORE_BUILT ${W3EMC_4_LIBRARY} ) + endif() +else( NOT W3EMC_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${W3EMC_LIBRARY} ) + else() + set( CORE_LIBRARIES ${W3EMC_LIBRARY} ) + endif() +endif( NOT W3EMC_LIBRARY ) + +if( CORE_INCS ) + list( APPEND CORE_INCS ${W3EMCINC} ) +else() + set( CORE_INCS ${INCLUDE_OUTPUT_PATH} ${W3EMCINC} ) +endif() + +set( W3EMC_LIBRARY_PATH ${W3EMC_LIBRARY} CACHE STRING "W3EMC Library Location" ) +set( W3EMC_INCLUDE_PATH ${W3EMCINC} CACHE STRING "W3EMC Include Location" ) +set( W3EMC_4_LIBRARY_PATH ${W3EMC_4_LIBRARY} CACHE STRING "W3EMC_4 Library Location" ) +set( W3EMC_INCLUDE_4_PATH ${W3EMC4INC} CACHE STRING "W3EMC_4 Include Location" ) + diff --git a/cmake/Modules/FindW3NCO.cmake b/cmake/Modules/FindW3NCO.cmake new file mode 100644 index 000000000..aef2126c8 --- /dev/null +++ b/cmake/Modules/FindW3NCO.cmake @@ -0,0 +1,81 @@ +# This module defines +# CORE_INCS +# List of include file paths for all required modules for GSI +# CORE_LIBRARIES +# Full list of libraries required to link GSI executable +include(findHelpers) +if(DEFINED ENV{W3NCO_VER}) + set(W3NCO_VER $ENV{W3NCO_VER}) + STRING(REGEX REPLACE "v" "" W3NCO_VER ${W3NCO_VER}) +endif() + +set( NO_DEFAULT_PATH ) +if(NOT BUILD_W3NCO ) + if(DEFINED ENV{W3NCO_LIBd} ) + set(W3NCO_LIBRARY $ENV{W3NCO_LIBd} ) + set(W3NCO_4_LIBRARY $ENV{W3NCO_LIB4} ) + message("W3NCO library ${W3NCO_LIBRARY} set via Environment variable") + message("W3NCO_4 library ${W3NCO_4_LIBRARY} set via Environment variable") + else() + find_library( W3NCO_LIBRARY + NAMES libw3nco_v${W3NCO_VER}_d.a libw3nco_d.a libw3nco_i4r8.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/w3nco/v${W3NCO_VER} + ${COREPATH}/w3nco/v${W3NCO_VER}/intel + ${COREPATH}/w3nco/v${W3NCO_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + message("Found W3NCO library ${W3NCO_LIBRARY}") + set( w3nco ${W3NCO_LIBRARY}) + + find_library( W3NCO_4_LIBRARY + NAMES libw3nco_v${W3NCO_VER}_4.a libw3nco_4.a + HINTS + $ENV{COREPATH}/lib + /usr/local/jcsda/nwprod_gdas_2014/lib + ${COREPATH}/w3nco/v${W3NCO_VER} + ${COREPATH}/w3nco/v${W3NCO_VER}/intel + ${COREPATH}/w3nco/v${W3NCO_VER}/ips/${COMPILER_VERSION} + PATH_SUFFIXES + lib + ${NO_DEFAULT_PATH}) + message("Found W3NCO_4 library ${W3NCO_4_LIBRARY}") + set( w3nco4 ${W3NCO_4_LIBRARY}) + endif() +endif() +if( NOT W3NCO_LIBRARY ) # didn't find the library, so build it from source + message("Could not find W3NCO library, so building from libsrc") + if( NOT DEFINED ENV{W3NCO_SRC} ) + findSrc( "w3nco" W3NCO_VER W3NCO_DIR ) + else() + set( W3NCO_DIR "$ENV{W3NCO_SRC}/libsrc" CACHE STRING "W3NCO Source Location") + endif() + set( libsuffix "_v${W3NCO_VER}${debug_suffix}" ) + set( W3NCO_LIBRARY "${LIBRARY_OUTPUT_PATH}/libw3nco${libsuffix}.a" CACHE STRING "W3NCO Library" ) + set( w3nco "w3nco${libsuffix}") + set( w3nco4 "w3nco_4${libsuffix}") + set( BUILD_W3NCO "ON" CACHE INTERNAL "Build the W3NCO library") + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/w3nco) + set( W3NCO_LIBRARY ${w3nco} ) + set( W3NCO_4_LIBRARY ${w3nco4} ) + if( CORE_BUILT ) + list( APPEND CORE_BUILT ${W3NCO_LIBRARY} ) + list( APPEND CORE_BUILT ${W3NCO_4_LIBRARY} ) + else() + set( CORE_BUILT ${W3NCO_LIBRARY} ) + set( CORE_BUILT ${W3NCO_4_LIBRARY} ) + endif() +else( NOT W3NCO_LIBRARY ) + if( CORE_LIBRARIES ) + list( APPEND CORE_LIBRARIES ${W3NCO_LIBRARY} ) + else() + set( CORE_LIBRARIES ${W3NCO_LIBRARY} ) + endif() +endif( NOT W3NCO_LIBRARY ) + +set( W3NCO_DIR ${CMAKE_SOURCE_DIR}/libsrc/w3nco CACHE STRING "W3NCO Source Location") +set( W3NCO_LIBRARY_PATH ${W3NCO_LIBRARY} CACHE STRING "W3NCO Library Location" ) + diff --git a/cmake/Modules/FindWRF.cmake b/cmake/Modules/FindWRF.cmake index c7006714a..43faf4664 100644 --- a/cmake/Modules/FindWRF.cmake +++ b/cmake/Modules/FindWRF.cmake @@ -6,29 +6,29 @@ find_library( IOINT_LIB HINTS ${WRFPATH}/external/io_int $ENV{WRFPATH}/external/io_int - /usr/local/jcsda/nwprod_gdas_2014/sorc/nam_nmm_real_fcst.fd/external/io_int + /usr/local/jcsda/nwprod_gdas_2014/lib/sorc/nam_nmm_real_fcst.fd/external/io_int /scratch3/NCEPDEV/nceplibs/ext/WRF/3.7/WRFV3/external/io_int ${NO_DEFAULT_PATH}) find_library( WRFNETCDF_LIB NAMES libwrfio_nf.a HINTS - ${WRFPATH}/external/io_netcdf /usr/local/jcsda/nwprod_gdas_2014/sorc/nam_nmm_real_fcst.fd/external/io_netcdf - $ENV{WRFPATH}/external/io_netcdf /usr/local/jcsda/nwprod_gdas_2014/sorc/nam_nmm_real_fcst.fd/external/io_netcdf + ${WRFPATH}/external/io_netcdf /usr/local/jcsda/nwprod_gdas_2014/lib/sorc/nam_nmm_real_fcst.fd/external/io_netcdf + $ENV{WRFPATH}/external/io_netcdf /usr/local/jcsda/nwprod_gdas_2014/lib/sorc/nam_nmm_real_fcst.fd/external/io_netcdf /scratch3/NCEPDEV/nceplibs/ext/WRF/3.7/WRFV3/external/io_netcdf ${NO_DEFAULT_PATH}) find_file( FRAMEPACK NAMES pack_utils.o HINTS - ${WRFPATH}/frame /usr/local/jcsda/nwprod_gdas_2014/sorc/nam_nmm_real_fcst.fd/frame - $ENV{WRFPATH}/frame /usr/local/jcsda/nwprod_gdas_2014/sorc/nam_nmm_real_fcst.fd/frame + ${WRFPATH}/frame /usr/local/jcsda/nwprod_gdas_2014/lib/sorc/nam_nmm_real_fcst.fd/frame + $ENV{WRFPATH}/frame /usr/local/jcsda/nwprod_gdas_2014/lib/sorc/nam_nmm_real_fcst.fd/frame /scratch3/NCEPDEV/nceplibs/ext/WRF/3.7/WRFV3/frame ${NO_DEFAULT_PATH}) find_file( FRAMEMODULE NAMES module_machine.o HINTS - ${WRFPATH}/frame /usr/local/jcsda/nwprod_gdas_2014/sorc/nam_nmm_real_fcst.fd/frame - $ENV{WRFPATH}/frame /usr/local/jcsda/nwprod_gdas_2014/sorc/nam_nmm_real_fcst.fd/frame + ${WRFPATH}/frame /usr/local/jcsda/nwprod_gdas_2014/lib/sorc/nam_nmm_real_fcst.fd/frame + $ENV{WRFPATH}/frame /usr/local/jcsda/nwprod_gdas_2014/lib/sorc/nam_nmm_real_fcst.fd/frame /scratch3/NCEPDEV/nceplibs/ext/WRF/3.7/WRFV3/frame ${NO_DEFAULT_PATH}) diff --git a/cmake/Modules/NewCMake/CMakeParseArguments.cmake b/cmake/Modules/NewCMake/CMakeParseArguments.cmake new file mode 100644 index 000000000..7ee2bbace --- /dev/null +++ b/cmake/Modules/NewCMake/CMakeParseArguments.cmake @@ -0,0 +1,11 @@ +# Distributed under the OSI-approved BSD 3-Clause License. See accompanying +# file Copyright.txt or https://cmake.org/licensing for details. + +#.rst: +# CMakeParseArguments +# ------------------- +# +# This module once implemented the :command:`cmake_parse_arguments` command +# that is now implemented natively by CMake. It is now an empty placeholder +# for compatibility with projects that include it to get the command from +# CMake 3.4 and lower. diff --git a/cmake/Modules/NewCMake/FindHDF5.cmake b/cmake/Modules/NewCMake/FindHDF5.cmake new file mode 100644 index 000000000..fd8891cf2 --- /dev/null +++ b/cmake/Modules/NewCMake/FindHDF5.cmake @@ -0,0 +1,934 @@ +# Distributed under the OSI-approved BSD 3-Clause License. See accompanying +# file Copyright.txt or https://cmake.org/licensing for details. + +#.rst: +# FindHDF5 +# -------- +# +# Find HDF5, a library for reading and writing self describing array data. +# +# +# +# This module invokes the HDF5 wrapper compiler that should be installed +# alongside HDF5. Depending upon the HDF5 Configuration, the wrapper +# compiler is called either h5cc or h5pcc. If this succeeds, the module +# will then call the compiler with the -show argument to see what flags +# are used when compiling an HDF5 client application. +# +# The module will optionally accept the COMPONENTS argument. If no +# COMPONENTS are specified, then the find module will default to finding +# only the HDF5 C library. If one or more COMPONENTS are specified, the +# module will attempt to find the language bindings for the specified +# components. The only valid components are C, CXX, Fortran, HL, and +# Fortran_HL. If the COMPONENTS argument is not given, the module will +# attempt to find only the C bindings. +# +# This module will read the variable +# HDF5_USE_STATIC_LIBRARIES to determine whether or not to prefer a +# static link to a dynamic link for HDF5 and all of it's dependencies. +# To use this feature, make sure that the HDF5_USE_STATIC_LIBRARIES +# variable is set before the call to find_package. +# +# To provide the module with a hint about where to find your HDF5 +# installation, you can set the environment variable HDF5_ROOT. The +# Find module will then look in this path when searching for HDF5 +# executables, paths, and libraries. +# +# Both the serial and parallel HDF5 wrappers are considered and the first +# directory to contain either one will be used. In the event that both appear +# in the same directory the serial version is preferentially selected. This +# behavior can be reversed by setting the variable HDF5_PREFER_PARALLEL to +# true. +# +# In addition to finding the includes and libraries required to compile +# an HDF5 client application, this module also makes an effort to find +# tools that come with the HDF5 distribution that may be useful for +# regression testing. +# +# This module will define the following variables: +# +# :: +# +# HDF5_FOUND - true if HDF5 was found on the system +# HDF5_VERSION - HDF5 version in format Major.Minor.Release +# HDF5_INCLUDE_DIRS - Location of the hdf5 includes +# HDF5_INCLUDE_DIR - Location of the hdf5 includes (deprecated) +# HDF5_DEFINITIONS - Required compiler definitions for HDF5 +# HDF5_LIBRARIES - Required libraries for all requested bindings +# HDF5_HL_LIBRARIES - Required libraries for the HDF5 high level API for all +# bindings, if the HL component is enabled +# +# Available components are: C CXX Fortran and HL. For each enabled language +# binding, a corresponding HDF5_${LANG}_LIBRARIES variable, and potentially +# HDF5_${LANG}_DEFINITIONS, will be defined. +# If the HL component is enabled, then an HDF5_${LANG}_HL_LIBRARIES will +# also be defined. With all components enabled, the following variables will be defined: +# +# :: +# +# HDF5_C_DEFINITIONS -- Required compiler definitions for HDF5 C bindings +# HDF5_CXX_DEFINITIONS -- Required compiler definitions for HDF5 C++ bindings +# HDF5_Fortran_DEFINITIONS -- Required compiler definitions for HDF5 Fortran bindings +# HDF5_C_INCLUDE_DIRS -- Required include directories for HDF5 C bindings +# HDF5_CXX_INCLUDE_DIRS -- Required include directories for HDF5 C++ bindings +# HDF5_Fortran_INCLUDE_DIRS -- Required include directories for HDF5 Fortran bindings +# HDF5_C_LIBRARIES - Required libraries for the HDF5 C bindings +# HDF5_CXX_LIBRARIES - Required libraries for the HDF5 C++ bindings +# HDF5_Fortran_LIBRARIES - Required libraries for the HDF5 Fortran bindings +# HDF5_C_HL_LIBRARIES - Required libraries for the high level C bindings +# HDF5_CXX_HL_LIBRARIES - Required libraries for the high level C++ bindings +# HDF5_Fortran_HL_LIBRARIES - Required libraries for the high level Fortran +# bindings. +# +# HDF5_IS_PARALLEL - Whether or not HDF5 was found with parallel IO support +# HDF5_C_COMPILER_EXECUTABLE - the path to the HDF5 C wrapper compiler +# HDF5_CXX_COMPILER_EXECUTABLE - the path to the HDF5 C++ wrapper compiler +# HDF5_Fortran_COMPILER_EXECUTABLE - the path to the HDF5 Fortran wrapper compiler +# HDF5_C_COMPILER_EXECUTABLE_NO_INTERROGATE - path to the primary C compiler +# which is also the HDF5 wrapper +# HDF5_CXX_COMPILER_EXECUTABLE_NO_INTERROGATE - path to the primary C++ +# compiler which is also +# the HDF5 wrapper +# HDF5_Fortran_COMPILER_EXECUTABLE_NO_INTERROGATE - path to the primary +# Fortran compiler which +# is also the HDF5 wrapper +# HDF5_DIFF_EXECUTABLE - the path to the HDF5 dataset comparison tool +# +# The following variable can be set to guide the search for HDF5 libraries and includes: +# +# ``HDF5_ROOT`` +# Specify the path to the HDF5 installation to use. +# +# ``HDF5_FIND_DEBUG`` +# Set to a true value to get some extra debugging output. +# +# ``HDF5_NO_FIND_PACKAGE_CONFIG_FILE`` +# Set to a true value to skip trying to find ``hdf5-config.cmake``. + +# This module is maintained by Will Dicharry . + +include(${CMAKE_CURRENT_LIST_DIR}/SelectLibraryConfigurations.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/FindPackageHandleStandardArgs.cmake) + +# List of the valid HDF5 components +set(HDF5_VALID_LANGUAGE_BINDINGS C CXX Fortran) + +# Validate the list of find components. +if(NOT HDF5_FIND_COMPONENTS) + set(HDF5_LANGUAGE_BINDINGS "C") +else() + set(HDF5_LANGUAGE_BINDINGS) + # add the extra specified components, ensuring that they are valid. + set(FIND_HL OFF) + foreach(component IN LISTS HDF5_FIND_COMPONENTS) + list(FIND HDF5_VALID_LANGUAGE_BINDINGS ${component} component_location) + if(NOT component_location EQUAL -1) + list(APPEND HDF5_LANGUAGE_BINDINGS ${component}) + elseif(component STREQUAL "HL") + set(FIND_HL ON) + elseif(component STREQUAL "Fortran_HL") # only for compatibility + list(APPEND HDF5_LANGUAGE_BINDINGS Fortran) + set(FIND_HL ON) + set(HDF5_FIND_REQUIRED_Fortran_HL False) + set(HDF5_FIND_REQUIRED_Fortran True) + set(HDF5_FIND_REQUIRED_HL True) + else() + message(FATAL_ERROR "${component} is not a valid HDF5 component.") + endif() + endforeach() + if(NOT HDF5_LANGUAGE_BINDINGS) + get_property(__langs GLOBAL PROPERTY ENABLED_LANGUAGES) + foreach(__lang IN LISTS __langs) + if(__lang MATCHES "^(C|CXX|Fortran)$") + list(APPEND HDF5_LANGUAGE_BINDINGS ${__lang}) + endif() + endforeach() + endif() + list(REMOVE_ITEM HDF5_FIND_COMPONENTS Fortran_HL) # replaced by Fortran and HL + list(REMOVE_DUPLICATES HDF5_LANGUAGE_BINDINGS) +endif() + +# Determine whether to search for serial or parallel executable first +if(HDF5_PREFER_PARALLEL) + set(HDF5_C_COMPILER_NAMES h5pcc h5cc) + set(HDF5_CXX_COMPILER_NAMES h5pc++ h5c++) + set(HDF5_Fortran_COMPILER_NAMES h5pfc h5fc) +else() + set(HDF5_C_COMPILER_NAMES h5cc h5pcc) + set(HDF5_CXX_COMPILER_NAMES h5c++ h5pc++) + set(HDF5_Fortran_COMPILER_NAMES h5fc h5pfc) +endif() + +# We may have picked up some duplicates in various lists during the above +# process for the language bindings (both the C and C++ bindings depend on +# libz for example). Remove the duplicates. It appears that the default +# CMake behavior is to remove duplicates from the end of a list. However, +# for link lines, this is incorrect since unresolved symbols are searched +# for down the link line. Therefore, we reverse the list, remove the +# duplicates, and then reverse it again to get the duplicates removed from +# the beginning. +macro(_HDF5_remove_duplicates_from_beginning _list_name) + if(${_list_name}) + list(REVERSE ${_list_name}) + list(REMOVE_DUPLICATES ${_list_name}) + list(REVERSE ${_list_name}) + endif() +endmacro() + + +# Test first if the current compilers automatically wrap HDF5 + +function(_HDF5_test_regular_compiler_C success version is_parallel) + set(scratch_directory + ${CMAKE_CURRENT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/hdf5) + if(NOT ${success} OR + NOT EXISTS ${scratch_directory}/compiler_has_h5_c) + set(test_file ${scratch_directory}/cmake_hdf5_test.c) + file(WRITE ${test_file} + "#include \n" + "#include \n" + "const char* info_ver = \"INFO\" \":\" H5_VERSION;\n" + "#ifdef H5_HAVE_PARALLEL\n" + "const char* info_parallel = \"INFO\" \":\" \"PARALLEL\";\n" + "#endif\n" + "int main(int argc, char **argv) {\n" + " int require = 0;\n" + " require += info_ver[argc];\n" + "#ifdef H5_HAVE_PARALLEL\n" + " require += info_parallel[argc];\n" + "#endif\n" + " hid_t fid;\n" + " fid = H5Fcreate(\"foo.h5\",H5F_ACC_TRUNC,H5P_DEFAULT,H5P_DEFAULT);\n" + " return 0;\n" + "}") + try_compile(${success} ${scratch_directory} ${test_file} + COPY_FILE ${scratch_directory}/compiler_has_h5_c + ) + endif() + if(${success}) + file(STRINGS ${scratch_directory}/compiler_has_h5_c INFO_STRINGS + REGEX "^INFO:" + ) + string(REGEX MATCH "^INFO:([0-9]+\\.[0-9]+\\.[0-9]+)(-patch([0-9]+))?" + INFO_VER "${INFO_STRINGS}" + ) + set(${version} ${CMAKE_MATCH_1}) + if(CMAKE_MATCH_3) + set(${version} ${HDF5_C_VERSION}.${CMAKE_MATCH_3}) + endif() + set(${version} ${${version}} PARENT_SCOPE) + + if(INFO_STRINGS MATCHES "INFO:PARALLEL") + set(${is_parallel} TRUE PARENT_SCOPE) + else() + set(${is_parallel} FALSE PARENT_SCOPE) + endif() + endif() +endfunction() + +function(_HDF5_test_regular_compiler_CXX success version is_parallel) + set(scratch_directory ${CMAKE_CURRENT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/hdf5) + if(NOT ${success} OR + NOT EXISTS ${scratch_directory}/compiler_has_h5_cxx) + set(test_file ${scratch_directory}/cmake_hdf5_test.cxx) + file(WRITE ${test_file} + "#include \n" + "#ifndef H5_NO_NAMESPACE\n" + "using namespace H5;\n" + "#endif\n" + "const char* info_ver = \"INFO\" \":\" H5_VERSION;\n" + "#ifdef H5_HAVE_PARALLEL\n" + "const char* info_parallel = \"INFO\" \":\" \"PARALLEL\";\n" + "#endif\n" + "int main(int argc, char **argv) {\n" + " int require = 0;\n" + " require += info_ver[argc];\n" + "#ifdef H5_HAVE_PARALLEL\n" + " require += info_parallel[argc];\n" + "#endif\n" + " H5File file(\"foo.h5\", H5F_ACC_TRUNC);\n" + " return 0;\n" + "}") + try_compile(${success} ${scratch_directory} ${test_file} + COPY_FILE ${scratch_directory}/compiler_has_h5_cxx + ) + endif() + if(${success}) + file(STRINGS ${scratch_directory}/compiler_has_h5_cxx INFO_STRINGS + REGEX "^INFO:" + ) + string(REGEX MATCH "^INFO:([0-9]+\\.[0-9]+\\.[0-9]+)(-patch([0-9]+))?" + INFO_VER "${INFO_STRINGS}" + ) + set(${version} ${CMAKE_MATCH_1}) + if(CMAKE_MATCH_3) + set(${version} ${HDF5_CXX_VERSION}.${CMAKE_MATCH_3}) + endif() + set(${version} ${${version}} PARENT_SCOPE) + + if(INFO_STRINGS MATCHES "INFO:PARALLEL") + set(${is_parallel} TRUE PARENT_SCOPE) + else() + set(${is_parallel} FALSE PARENT_SCOPE) + endif() + endif() +endfunction() + +function(_HDF5_test_regular_compiler_Fortran success is_parallel) + if(NOT ${success}) + set(scratch_directory + ${CMAKE_CURRENT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/hdf5) + set(test_file ${scratch_directory}/cmake_hdf5_test.f90) + file(WRITE ${test_file} + "program hdf5_hello\n" + " use hdf5\n" + " use h5lt\n" + " use h5ds\n" + " integer error\n" + " call h5open_f(error)\n" + " call h5close_f(error)\n" + "end\n") + try_compile(${success} ${scratch_directory} ${test_file}) + if(${success}) + execute_process(COMMAND ${CMAKE_Fortran_COMPILER} -showconfig + OUTPUT_VARIABLE config_output + ERROR_VARIABLE config_error + RESULT_VARIABLE config_result + ) + if(config_output MATCHES "Parallel HDF5: yes") + set(${is_parallel} TRUE PARENT_SCOPE) + else() + set(${is_parallel} FALSE PARENT_SCOPE) + endif() + endif() + endif() +endfunction() + +# Invoke the HDF5 wrapper compiler. The compiler return value is stored to the +# return_value argument, the text output is stored to the output variable. +macro( _HDF5_invoke_compiler language output return_value version is_parallel) + set(${version}) + if(HDF5_USE_STATIC_LIBRARIES) + set(lib_type_args -noshlib) + else() + set(lib_type_args -shlib) + endif() + set(scratch_dir ${CMAKE_CURRENT_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/hdf5) + if("${language}" STREQUAL "C") + set(test_file ${scratch_dir}/cmake_hdf5_test.c) + elseif("${language}" STREQUAL "CXX") + set(test_file ${scratch_dir}/cmake_hdf5_test.cxx) + elseif("${language}" STREQUAL "Fortran") + set(test_file ${scratch_dir}/cmake_hdf5_test.f90) + endif() + exec_program( ${HDF5_${language}_COMPILER_EXECUTABLE} + ARGS -show ${lib_type_args} ${test_file} + OUTPUT_VARIABLE ${output} + RETURN_VALUE ${return_value} + ) + if(NOT ${${return_value}} EQUAL 0) + message(STATUS + "Unable to determine HDF5 ${language} flags from HDF5 wrapper.") + endif() + exec_program( ${HDF5_${language}_COMPILER_EXECUTABLE} + ARGS -showconfig + OUTPUT_VARIABLE config_output + RETURN_VALUE config_return + ) + if(NOT ${return_value} EQUAL 0) + message( STATUS + "Unable to determine HDF5 ${language} version from HDF5 wrapper.") + endif() + string(REGEX MATCH "HDF5 Version: ([a-zA-Z0-9\\.\\-]*)" version_match "${config_output}") + if(version_match) + string(REPLACE "HDF5 Version: " "" ${version} "${version_match}") + string(REPLACE "-patch" "." ${version} "${${version}}") + endif() + if(config_output MATCHES "Parallel HDF5: yes") + set(${is_parallel} TRUE) + else() + set(${is_parallel} FALSE) + endif() +endmacro() + +# Parse a compile line for definitions, includes, library paths, and libraries. +macro( _HDF5_parse_compile_line + compile_line_var + include_paths + definitions + library_paths + libraries + libraries_hl) + + separate_arguments(_HDF5_COMPILE_ARGS UNIX_COMMAND "${${compile_line_var}}") + + foreach(arg IN LISTS _HDF5_COMPILE_ARGS) + if("${arg}" MATCHES "^-I(.*)$") + # include directory + list(APPEND ${include_paths} "${CMAKE_MATCH_1}") + elseif("${arg}" MATCHES "^-D(.*)$") + # compile definition + list(APPEND ${definitions} "-D${CMAKE_MATCH_1}") + elseif("${arg}" MATCHES "^-L(.*)$") + # library search path + list(APPEND ${library_paths} "${CMAKE_MATCH_1}") + elseif("${arg}" MATCHES "^-l(hdf5.*hl.*)$") + # library name (hl) + list(APPEND ${libraries_hl} "${CMAKE_MATCH_1}") + elseif("${arg}" MATCHES "^-l(.*)$") + # library name + list(APPEND ${libraries} "${CMAKE_MATCH_1}") + elseif("${arg}" MATCHES "^(.:)?[/\\].*\\.(a|so|dylib|sl|lib)$") + # library file + if(NOT EXISTS "${arg}") + continue() + endif() + get_filename_component(_HDF5_LPATH "${arg}" DIRECTORY) + get_filename_component(_HDF5_LNAME "${arg}" NAME_WE) + string(REGEX REPLACE "^lib" "" _HDF5_LNAME "${_HDF5_LNAME}") + list(APPEND ${library_paths} "${_HDF5_LPATH}") + if(_HDF5_LNAME MATCHES "hdf5.*hl") + list(APPEND ${libraries_hl} "${_HDF5_LNAME}") + else() + list(APPEND ${libraries} "${_HDF5_LNAME}") + endif() + endif() + endforeach() +endmacro() + +# Select a preferred imported configuration from a target +function(_HDF5_select_imported_config target imported_conf) + # We will first assign the value to a local variable _imported_conf, then assign + # it to the function argument at the end. + get_target_property(_imported_conf ${target} MAP_IMPORTED_CONFIG_${CMAKE_BUILD_TYPE}) + if (NOT _imported_conf) + # Get available imported configurations by examining target properties + get_target_property(_imported_conf ${target} IMPORTED_CONFIGURATIONS) + if(HDF5_FIND_DEBUG) + message(STATUS "Found imported configurations: ${_imported_conf}") + endif() + # Find the imported configuration that we prefer. + # We do this by making list of configurations in order of preference, + # starting with ${CMAKE_BUILD_TYPE} and ending with the first imported_conf + set(_preferred_confs ${CMAKE_BUILD_TYPE}) + list(GET _imported_conf 0 _fallback_conf) + list(APPEND _preferred_confs RELWITHDEBINFO RELEASE DEBUG ${_fallback_conf}) + if(HDF5_FIND_DEBUG) + message(STATUS "Start search through imported configurations in the following order: ${_preferred_confs}") + endif() + # Now find the first of these that is present in imported_conf + cmake_policy(PUSH) + cmake_policy(SET CMP0057 NEW) # support IN_LISTS + foreach (_conf IN LISTS _preferred_confs) + if (${_conf} IN_LIST _imported_conf) + set(_imported_conf ${_conf}) + break() + endif() + endforeach() + cmake_policy(POP) + endif() + if(HDF5_FIND_DEBUG) + message(STATUS "Selected imported configuration: ${_imported_conf}") + endif() + # assign value to function argument + set(${imported_conf} ${_imported_conf} PARENT_SCOPE) +endfunction() + + +if(NOT HDF5_ROOT) + set(HDF5_ROOT $ENV{HDF5_ROOT}) +endif() +if(HDF5_ROOT) + set(_HDF5_SEARCH_OPTS NO_DEFAULT_PATH) +else() + set(_HDF5_SEARCH_OPTS) +endif() + +# Try to find HDF5 using an installed hdf5-config.cmake +if(NOT HDF5_FOUND AND NOT HDF5_NO_FIND_PACKAGE_CONFIG_FILE) + find_package(HDF5 QUIET NO_MODULE + HINTS ${HDF5_ROOT} + ${_HDF5_SEARCH_OPTS} + ) + if( HDF5_FOUND) + if(HDF5_FIND_DEBUG) + message(STATUS "Found HDF5 at ${HDF5_DIR} via NO_MODULE. Now trying to extract locations etc.") + endif() + set(HDF5_IS_PARALLEL ${HDF5_ENABLE_PARALLEL}) + set(HDF5_INCLUDE_DIRS ${HDF5_INCLUDE_DIR}) + set(HDF5_LIBRARIES) + if (NOT TARGET hdf5 AND NOT TARGET hdf5-static AND NOT TARGET hdf5-shared) + # Some HDF5 versions (e.g. 1.8.18) used hdf5::hdf5 etc + set(_target_prefix "hdf5::") + endif() + set(HDF5_C_TARGET ${_target_prefix}hdf5) + set(HDF5_C_HL_TARGET ${_target_prefix}hdf5_hl) + set(HDF5_CXX_TARGET ${_target_prefix}hdf5_cpp) + set(HDF5_CXX_HL_TARGET ${_target_prefix}hdf5_hl_cpp) + set(HDF5_Fortran_TARGET ${_target_prefix}hdf5_fortran) + set(HDF5_Fortran_HL_TARGET ${_target_prefix}hdf5_hl_fortran) + set(HDF5_DEFINITIONS "") + if(HDF5_USE_STATIC_LIBRARIES) + set(_suffix "-static") + else() + set(_suffix "-shared") + endif() + foreach(_lang ${HDF5_LANGUAGE_BINDINGS}) + + #Older versions of hdf5 don't have a static/shared suffix so + #if we detect that occurrence clear the suffix + if(_suffix AND NOT TARGET ${HDF5_${_lang}_TARGET}${_suffix}) + if(NOT TARGET ${HDF5_${_lang}_TARGET}) + #cant find this component with or without the suffix + #so bail out, and let the following locate HDF5 + set(HDF5_FOUND FALSE) + break() + endif() + set(_suffix "") + endif() + + if(HDF5_FIND_DEBUG) + message(STATUS "Trying to get properties of target ${HDF5_${_lang}_TARGET}${_suffix}") + endif() + # Find library for this target. Complicated as on Windows with a DLL, we need to search for the import-lib. + _HDF5_select_imported_config(${HDF5_${_lang}_TARGET}${_suffix} _hdf5_imported_conf) + get_target_property(_hdf5_lang_location ${HDF5_${_lang}_TARGET}${_suffix} IMPORTED_IMPLIB_${_hdf5_imported_conf} ) + if (NOT _hdf5_lang_location) + # no import lib, just try LOCATION + get_target_property(_hdf5_lang_location ${HDF5_${_lang}_TARGET}${_suffix} LOCATION_${_hdf5_imported_conf}) + if (NOT _hdf5_lang_location) + get_target_property(_hdf5_lang_location ${HDF5_${_lang}_TARGET}${_suffix} LOCATION) + endif() + endif() + if( _hdf5_lang_location ) + set(HDF5_${_lang}_LIBRARY ${_hdf5_lang_location}) + list(APPEND HDF5_LIBRARIES ${HDF5_${_lang}_TARGET}${_suffix}) + set(HDF5_${_lang}_LIBRARIES ${HDF5_${_lang}_TARGET}${_suffix}) + set(HDF5_${_lang}_FOUND True) + endif() + if(FIND_HL) + get_target_property(__lang_hl_location ${HDF5_${_lang}_HL_TARGET}${_suffix} IMPORTED_IMPLIB_${_hdf5_imported_conf} ) + if (NOT _hdf5_lang_hl_location) + get_target_property(_hdf5_lang_hl_location ${HDF5_${_lang}_HL_TARGET}${_suffix} LOCATION_${_hdf5_imported_conf}) + if (NOT _hdf5_hl_lang_location) + get_target_property(_hdf5_hl_lang_location ${HDF5_${_lang}_HL_TARGET}${_suffix} LOCATION) + endif() + endif() + if( _hdf5_lang_hl_location ) + set(HDF5_${_lang}_HL_LIBRARY ${_hdf5_lang_hl_location}) + list(APPEND HDF5_HL_LIBRARIES ${HDF5_${_lang}_HL_TARGET}${_suffix}) + set(HDF5_${_lang}_HL_LIBRARIES ${HDF5_${_lang}_HL_TARGET}${_suffix}) + set(HDF5_HL_FOUND True) + endif() + unset(_hdf5_lang_hl_location) + endif() + unset(_hdf5_imported_conf) + unset(_hdf5_lang_location) + endforeach() + endif() +endif() + +if(NOT HDF5_FOUND) + set(_HDF5_NEED_TO_SEARCH False) + set(HDF5_COMPILER_NO_INTERROGATE True) + # Only search for languages we've enabled + foreach(__lang IN LISTS HDF5_LANGUAGE_BINDINGS) + # First check to see if our regular compiler is one of wrappers + if(__lang STREQUAL "C") + _HDF5_test_regular_compiler_C( + HDF5_${__lang}_COMPILER_NO_INTERROGATE + HDF5_${__lang}_VERSION + HDF5_${__lang}_IS_PARALLEL) + elseif(__lang STREQUAL "CXX") + _HDF5_test_regular_compiler_CXX( + HDF5_${__lang}_COMPILER_NO_INTERROGATE + HDF5_${__lang}_VERSION + HDF5_${__lang}_IS_PARALLEL) + elseif(__lang STREQUAL "Fortran") + _HDF5_test_regular_compiler_Fortran( + HDF5_${__lang}_COMPILER_NO_INTERROGATE + HDF5_${__lang}_IS_PARALLEL) + else() + continue() + endif() + if(HDF5_${__lang}_COMPILER_NO_INTERROGATE) + message(STATUS "HDF5: Using hdf5 compiler wrapper for all ${__lang} compiling") + set(HDF5_${__lang}_FOUND True) + set(HDF5_${__lang}_COMPILER_EXECUTABLE_NO_INTERROGATE + "${CMAKE_${__lang}_COMPILER}" + CACHE FILEPATH "HDF5 ${__lang} compiler wrapper") + set(HDF5_${__lang}_DEFINITIONS) + set(HDF5_${__lang}_INCLUDE_DIRS) + set(HDF5_${__lang}_LIBRARIES) + set(HDF5_${__lang}_HL_LIBRARIES) + + mark_as_advanced(HDF5_${__lang}_COMPILER_EXECUTABLE_NO_INTERROGATE) + + set(HDF5_${__lang}_FOUND True) + set(HDF5_HL_FOUND True) + else() + set(HDF5_COMPILER_NO_INTERROGATE False) + # If this language isn't using the wrapper, then try to seed the + # search options with the wrapper + find_program(HDF5_${__lang}_COMPILER_EXECUTABLE + NAMES ${HDF5_${__lang}_COMPILER_NAMES} NAMES_PER_DIR + HINTS ${HDF5_ROOT} + PATH_SUFFIXES bin Bin + DOC "HDF5 ${__lang} Wrapper compiler. Used only to detect HDF5 compile flags." + ${_HDF5_SEARCH_OPTS} + ) + mark_as_advanced( HDF5_${__lang}_COMPILER_EXECUTABLE ) + unset(HDF5_${__lang}_COMPILER_NAMES) + + if(HDF5_${__lang}_COMPILER_EXECUTABLE) + _HDF5_invoke_compiler(${__lang} HDF5_${__lang}_COMPILE_LINE + HDF5_${__lang}_RETURN_VALUE HDF5_${__lang}_VERSION HDF5_${__lang}_IS_PARALLEL) + if(HDF5_${__lang}_RETURN_VALUE EQUAL 0) + message(STATUS "HDF5: Using hdf5 compiler wrapper to determine ${__lang} configuration") + _HDF5_parse_compile_line( HDF5_${__lang}_COMPILE_LINE + HDF5_${__lang}_INCLUDE_DIRS + HDF5_${__lang}_DEFINITIONS + HDF5_${__lang}_LIBRARY_DIRS + HDF5_${__lang}_LIBRARY_NAMES + HDF5_${__lang}_HL_LIBRARY_NAMES + ) + set(HDF5_${__lang}_LIBRARIES) + + foreach(L IN LISTS HDF5_${__lang}_LIBRARY_NAMES) + set(_HDF5_SEARCH_NAMES_LOCAL) + if("x${L}" MATCHES "hdf5") + # hdf5 library + set(_HDF5_SEARCH_OPTS_LOCAL ${_HDF5_SEARCH_OPTS}) + if(HDF5_USE_STATIC_LIBRARIES) + if(WIN32) + set(_HDF5_SEARCH_NAMES_LOCAL lib${L}) + else() + set(_HDF5_SEARCH_NAMES_LOCAL lib${L}.a) + endif() + endif() + else() + # external library + set(_HDF5_SEARCH_OPTS_LOCAL) + endif() + find_library(HDF5_${__lang}_LIBRARY_${L} + NAMES ${_HDF5_SEARCH_NAMES_LOCAL} ${L} NAMES_PER_DIR + HINTS ${HDF5_${__lang}_LIBRARY_DIRS} + ${HDF5_ROOT} + ${_HDF5_SEARCH_OPTS_LOCAL} + ) + unset(_HDF5_SEARCH_OPTS_LOCAL) + unset(_HDF5_SEARCH_NAMES_LOCAL) + if(HDF5_${__lang}_LIBRARY_${L}) + list(APPEND HDF5_${__lang}_LIBRARIES ${HDF5_${__lang}_LIBRARY_${L}}) + else() + list(APPEND HDF5_${__lang}_LIBRARIES ${L}) + endif() + endforeach() + if(FIND_HL) + set(HDF5_${__lang}_HL_LIBRARIES) + foreach(L IN LISTS HDF5_${__lang}_HL_LIBRARY_NAMES) + set(_HDF5_SEARCH_NAMES_LOCAL) + if("x${L}" MATCHES "hdf5") + # hdf5 library + set(_HDF5_SEARCH_OPTS_LOCAL ${_HDF5_SEARCH_OPTS}) + if(HDF5_USE_STATIC_LIBRARIES) + if(WIN32) + set(_HDF5_SEARCH_NAMES_LOCAL lib${L}) + else() + set(_HDF5_SEARCH_NAMES_LOCAL lib${L}.a) + endif() + endif() + else() + # external library + set(_HDF5_SEARCH_OPTS_LOCAL) + endif() + find_library(HDF5_${__lang}_LIBRARY_${L} + NAMES ${_HDF5_SEARCH_NAMES_LOCAL} ${L} NAMES_PER_DIR + HINTS ${HDF5_${__lang}_LIBRARY_DIRS} + ${HDF5_ROOT} + ${_HDF5_SEARCH_OPTS_LOCAL} + ) + unset(_HDF5_SEARCH_OPTS_LOCAL) + unset(_HDF5_SEARCH_NAMES_LOCAL) + if(HDF5_${__lang}_LIBRARY_${L}) + list(APPEND HDF5_${__lang}_HL_LIBRARIES ${HDF5_${__lang}_LIBRARY_${L}}) + else() + list(APPEND HDF5_${__lang}_HL_LIBRARIES ${L}) + endif() + endforeach() + set(HDF5_HL_FOUND True) + endif() + + set(HDF5_${__lang}_FOUND True) + _HDF5_remove_duplicates_from_beginning(HDF5_${__lang}_DEFINITIONS) + _HDF5_remove_duplicates_from_beginning(HDF5_${__lang}_INCLUDE_DIRS) + _HDF5_remove_duplicates_from_beginning(HDF5_${__lang}_LIBRARIES) + _HDF5_remove_duplicates_from_beginning(HDF5_${__lang}_HL_LIBRARIES) + else() + set(_HDF5_NEED_TO_SEARCH True) + endif() + else() + set(_HDF5_NEED_TO_SEARCH True) + endif() + endif() + if(HDF5_${__lang}_VERSION) + if(NOT HDF5_VERSION) + set(HDF5_VERSION ${HDF5_${__lang}_VERSION}) + elseif(NOT HDF5_VERSION VERSION_EQUAL HDF5_${__lang}_VERSION) + message(WARNING "HDF5 Version found for language ${__lang}, ${HDF5_${__lang}_VERSION} is different than previously found version ${HDF5_VERSION}") + endif() + endif() + if(DEFINED HDF5_${__lang}_IS_PARALLEL) + if(NOT DEFINED HDF5_IS_PARALLEL) + set(HDF5_IS_PARALLEL ${HDF5_${__lang}_IS_PARALLEL}) + elseif(NOT HDF5_IS_PARALLEL AND HDF5_${__lang}_IS_PARALLEL) + message(WARNING "HDF5 found for language ${__lang} is parallel but previously found language is not parallel.") + elseif(HDF5_IS_PARALLEL AND NOT HDF5_${__lang}_IS_PARALLEL) + message(WARNING "HDF5 found for language ${__lang} is not parallel but previously found language is parallel.") + endif() + endif() + endforeach() +else() + set(_HDF5_NEED_TO_SEARCH True) +endif() + +if(NOT HDF5_FOUND AND HDF5_COMPILER_NO_INTERROGATE) + # No arguments necessary, all languages can use the compiler wrappers + set(HDF5_FOUND True) + set(HDF5_METHOD "Included by compiler wrappers") + set(HDF5_REQUIRED_VARS HDF5_METHOD) +elseif(NOT HDF5_FOUND AND NOT _HDF5_NEED_TO_SEARCH) + # Compiler wrappers aren't being used by the build but were found and used + # to determine necessary include and library flags + set(HDF5_INCLUDE_DIRS) + set(HDF5_LIBRARIES) + set(HDF5_HL_LIBRARIES) + foreach(__lang IN LISTS HDF5_LANGUAGE_BINDINGS) + if(HDF5_${__lang}_FOUND) + if(NOT HDF5_${__lang}_COMPILER_NO_INTERROGATE) + list(APPEND HDF5_DEFINITIONS ${HDF5_${__lang}_DEFINITIONS}) + list(APPEND HDF5_INCLUDE_DIRS ${HDF5_${__lang}_INCLUDE_DIRS}) + list(APPEND HDF5_LIBRARIES ${HDF5_${__lang}_LIBRARIES}) + if(FIND_HL) + list(APPEND HDF5_HL_LIBRARIES ${HDF5_${__lang}_HL_LIBRARIES}) + endif() + endif() + endif() + endforeach() + _HDF5_remove_duplicates_from_beginning(HDF5_DEFINITIONS) + _HDF5_remove_duplicates_from_beginning(HDF5_INCLUDE_DIRS) + _HDF5_remove_duplicates_from_beginning(HDF5_LIBRARIES) + _HDF5_remove_duplicates_from_beginning(HDF5_HL_LIBRARIES) + set(HDF5_FOUND True) + set(HDF5_REQUIRED_VARS HDF5_LIBRARIES) + if(FIND_HL) + list(APPEND HDF5_REQUIRED_VARS HDF5_HL_LIBRARIES) + endif() +endif() + +find_program( HDF5_DIFF_EXECUTABLE + NAMES h5diff + HINTS ${HDF5_ROOT} + PATH_SUFFIXES bin Bin + ${_HDF5_SEARCH_OPTS} + DOC "HDF5 file differencing tool." ) +mark_as_advanced( HDF5_DIFF_EXECUTABLE ) + +if( NOT HDF5_FOUND ) + # seed the initial lists of libraries to find with items we know we need + set(HDF5_C_LIBRARY_NAMES hdf5) + set(HDF5_C_HL_LIBRARY_NAMES hdf5_hl) + + set(HDF5_CXX_LIBRARY_NAMES hdf5_cpp ${HDF5_C_LIBRARY_NAMES}) + set(HDF5_CXX_HL_LIBRARY_NAMES hdf5_hl_cpp ${HDF5_C_HL_LIBRARY_NAMES} ${HDF5_CXX_LIBRARY_NAMES}) + + set(HDF5_Fortran_LIBRARY_NAMES hdf5_fortran ${HDF5_C_LIBRARY_NAMES}) + set(HDF5_Fortran_HL_LIBRARY_NAMES hdf5hl_fortran ${HDF5_C_HL_LIBRARY_NAMES} ${HDF5_Fortran_LIBRARY_NAMES}) + + foreach(__lang IN LISTS HDF5_LANGUAGE_BINDINGS) + # find the HDF5 include directories + if("${__lang}" STREQUAL "Fortran") + set(HDF5_INCLUDE_FILENAME hdf5.mod) + elseif("${__lang}" STREQUAL "CXX") + set(HDF5_INCLUDE_FILENAME H5Cpp.h) + else() + set(HDF5_INCLUDE_FILENAME hdf5.h) + endif() + + find_path(HDF5_${__lang}_INCLUDE_DIR ${HDF5_INCLUDE_FILENAME} + HINTS ${HDF5_ROOT} + PATHS $ENV{HOME}/.local/include + PATH_SUFFIXES include Include + ${_HDF5_SEARCH_OPTS} + ) + mark_as_advanced(HDF5_${__lang}_INCLUDE_DIR) + # set the _DIRS variable as this is what the user will normally use + set(HDF5_${__lang}_INCLUDE_DIRS ${HDF5_${__lang}_INCLUDE_DIR}) + list(APPEND HDF5_INCLUDE_DIRS ${HDF5_${__lang}_INCLUDE_DIR}) + + # find the HDF5 libraries + foreach(LIB IN LISTS HDF5_${__lang}_LIBRARY_NAMES) + if(HDF5_USE_STATIC_LIBRARIES) + # According to bug 1643 on the CMake bug tracker, this is the + # preferred method for searching for a static library. + # See https://gitlab.kitware.com/cmake/cmake/issues/1643. We search + # first for the full static library name, but fall back to a + # generic search on the name if the static search fails. + set( THIS_LIBRARY_SEARCH_DEBUG + lib${LIB}d.a lib${LIB}_debug.a lib${LIB}d lib${LIB}_D lib${LIB}_debug + lib${LIB}d-static.a lib${LIB}_debug-static.a ${LIB}d-static ${LIB}_D-static ${LIB}_debug-static ) + set( THIS_LIBRARY_SEARCH_RELEASE lib${LIB}.a lib${LIB} lib${LIB}-static.a ${LIB}-static) + else() + set( THIS_LIBRARY_SEARCH_DEBUG ${LIB}d ${LIB}_D ${LIB}_debug ${LIB}d-shared ${LIB}_D-shared ${LIB}_debug-shared) + set( THIS_LIBRARY_SEARCH_RELEASE ${LIB} ${LIB}-shared) + if(WIN32) + list(APPEND HDF5_DEFINITIONS "-DH5_BUILT_AS_DYNAMIC_LIB") + endif() + endif() + find_library(HDF5_${LIB}_LIBRARY_DEBUG + NAMES ${THIS_LIBRARY_SEARCH_DEBUG} + HINTS ${HDF5_ROOT} PATH_SUFFIXES lib Lib + ${_HDF5_SEARCH_OPTS} + ) + find_library( HDF5_${LIB}_LIBRARY_RELEASE + NAMES ${THIS_LIBRARY_SEARCH_RELEASE} + HINTS ${HDF5_ROOT} PATH_SUFFIXES lib Lib + ${_HDF5_SEARCH_OPTS} + ) + select_library_configurations( HDF5_${LIB} ) + list(APPEND HDF5_${__lang}_LIBRARIES ${HDF5_${LIB}_LIBRARY}) + endforeach() + if(HDF5_${__lang}_LIBRARIES) + set(HDF5_${__lang}_FOUND True) + endif() + + # Append the libraries for this language binding to the list of all + # required libraries. + list(APPEND HDF5_LIBRARIES ${HDF5_${__lang}_LIBRARIES}) + + if(FIND_HL) + foreach(LIB IN LISTS HDF5_${__lang}_HL_LIBRARY_NAMES) + if(HDF5_USE_STATIC_LIBRARIES) + # According to bug 1643 on the CMake bug tracker, this is the + # preferred method for searching for a static library. + # See https://gitlab.kitware.com/cmake/cmake/issues/1643. We search + # first for the full static library name, but fall back to a + # generic search on the name if the static search fails. + set( THIS_LIBRARY_SEARCH_DEBUG + lib${LIB}d.a lib${LIB}_debug.a lib${LIB}d lib${LIB}_D lib${LIB}_debug + lib${LIB}d-static.a lib${LIB}_debug-static.a lib${LIB}d-static lib${LIB}_D-static lib${LIB}_debug-static ) + set( THIS_LIBRARY_SEARCH_RELEASE lib${LIB}.a ${LIB} lib${LIB}-static.a lib${LIB}-static) + else() + set( THIS_LIBRARY_SEARCH_DEBUG ${LIB}d ${LIB}_D ${LIB}_debug ${LIB}d-shared ${LIB}_D-shared ${LIB}_debug-shared) + set( THIS_LIBRARY_SEARCH_RELEASE ${LIB} ${LIB}-shared) + endif() + find_library(HDF5_${LIB}_LIBRARY_DEBUG + NAMES ${THIS_LIBRARY_SEARCH_DEBUG} + HINTS ${HDF5_ROOT} PATH_SUFFIXES lib Lib + ${_HDF5_SEARCH_OPTS} + ) + find_library( HDF5_${LIB}_LIBRARY_RELEASE + NAMES ${THIS_LIBRARY_SEARCH_RELEASE} + HINTS ${HDF5_ROOT} PATH_SUFFIXES lib Lib + ${_HDF5_SEARCH_OPTS} + ) + select_library_configurations( HDF5_${LIB} ) + list(APPEND HDF5_${__lang}_HL_LIBRARIES ${HDF5_${LIB}_LIBRARY}) + endforeach() + + # Append the libraries for this language binding to the list of all + # required libraries. + list(APPEND HDF5_HL_LIBRARIES ${HDF5_${__lang}_HL_LIBRARIES}) + endif() + endforeach() + if(FIND_HL AND HDF5_HL_LIBRARIES) + set(HDF5_HL_FOUND True) + endif() + + _HDF5_remove_duplicates_from_beginning(HDF5_DEFINITIONS) + _HDF5_remove_duplicates_from_beginning(HDF5_INCLUDE_DIRS) + _HDF5_remove_duplicates_from_beginning(HDF5_LIBRARIES) + _HDF5_remove_duplicates_from_beginning(HDF5_HL_LIBRARIES) + + # If the HDF5 include directory was found, open H5pubconf.h to determine if + # HDF5 was compiled with parallel IO support + set( HDF5_IS_PARALLEL FALSE ) + set( HDF5_VERSION "" ) + foreach( _dir IN LISTS HDF5_INCLUDE_DIRS ) + foreach(_hdr "${_dir}/H5pubconf.h" "${_dir}/H5pubconf-64.h" "${_dir}/H5pubconf-32.h") + if( EXISTS "${_hdr}" ) + file( STRINGS "${_hdr}" + HDF5_HAVE_PARALLEL_DEFINE + REGEX "HAVE_PARALLEL 1" ) + if( HDF5_HAVE_PARALLEL_DEFINE ) + set( HDF5_IS_PARALLEL TRUE ) + endif() + unset(HDF5_HAVE_PARALLEL_DEFINE) + + file( STRINGS "${_hdr}" + HDF5_VERSION_DEFINE + REGEX "^[ \t]*#[ \t]*define[ \t]+H5_VERSION[ \t]+" ) + if( "${HDF5_VERSION_DEFINE}" MATCHES + "H5_VERSION[ \t]+\"([0-9]+\\.[0-9]+\\.[0-9]+)(-patch([0-9]+))?\"" ) + set( HDF5_VERSION "${CMAKE_MATCH_1}" ) + if( CMAKE_MATCH_3 ) + set( HDF5_VERSION ${HDF5_VERSION}.${CMAKE_MATCH_3}) + endif() + endif() + unset(HDF5_VERSION_DEFINE) + endif() + endforeach() + endforeach() + set( HDF5_IS_PARALLEL ${HDF5_IS_PARALLEL} CACHE BOOL + "HDF5 library compiled with parallel IO support" ) + mark_as_advanced( HDF5_IS_PARALLEL ) + + set(HDF5_REQUIRED_VARS HDF5_LIBRARIES HDF5_INCLUDE_DIRS) + if(FIND_HL) + list(APPEND HDF5_REQUIRED_VARS HDF5_HL_LIBRARIES) + endif() +endif() + +# For backwards compatibility we set HDF5_INCLUDE_DIR to the value of +# HDF5_INCLUDE_DIRS +if( HDF5_INCLUDE_DIRS ) + set( HDF5_INCLUDE_DIR "${HDF5_INCLUDE_DIRS}" ) +endif() + +# If HDF5_REQUIRED_VARS is empty at this point, then it's likely that +# something external is trying to explicitly pass already found +# locations +if(NOT HDF5_REQUIRED_VARS) + set(HDF5_REQUIRED_VARS HDF5_LIBRARIES HDF5_INCLUDE_DIRS) +endif() + +find_package_handle_standard_args(HDF5 + REQUIRED_VARS ${HDF5_REQUIRED_VARS} + VERSION_VAR HDF5_VERSION + HANDLE_COMPONENTS +) + +unset(_HDF5_SEARCH_OPTS) + +if( HDF5_FOUND AND NOT HDF5_DIR) + # hide HDF5_DIR for the non-advanced user to avoid confusion with + # HDF5_DIR-NOT_FOUND while HDF5 was found. + mark_as_advanced(HDF5_DIR) +endif() + +if (HDF5_FIND_DEBUG) + message(STATUS "HDF5_DIR: ${HDF5_DIR}") + message(STATUS "HDF5_DEFINITIONS: ${HDF5_DEFINITIONS}") + message(STATUS "HDF5_INCLUDE_DIRS: ${HDF5_INCLUDE_DIRS}") + message(STATUS "HDF5_LIBRARIES: ${HDF5_LIBRARIES}") + message(STATUS "HDF5_HL_LIBRARIES: ${HDF5_HL_LIBRARIES}") + foreach(__lang IN LISTS HDF5_LANGUAGE_BINDINGS) + message(STATUS "HDF5_${__lang}_DEFINITIONS: ${HDF5_${__lang}_DEFINITIONS}") + message(STATUS "HDF5_${__lang}_INCLUDE_DIR: ${HDF5_${__lang}_INCLUDE_DIR}") + message(STATUS "HDF5_${__lang}_INCLUDE_DIRS: ${HDF5_${__lang}_INCLUDE_DIRS}") + message(STATUS "HDF5_${__lang}_LIBRARY: ${HDF5_${__lang}_LIBRARY}") + message(STATUS "HDF5_${__lang}_LIBRARIES: ${HDF5_${__lang}_LIBRARIES}") + message(STATUS "HDF5_${__lang}_HL_LIBRARY: ${HDF5_${__lang}_HL_LIBRARY}") + message(STATUS "HDF5_${__lang}_HL_LIBRARIES: ${HDF5_${__lang}_HL_LIBRARIES}") + endforeach() +endif() diff --git a/cmake/Modules/NewCMake/FindMPI.cmake b/cmake/Modules/NewCMake/FindMPI.cmake new file mode 100644 index 000000000..5cd2a2afe --- /dev/null +++ b/cmake/Modules/NewCMake/FindMPI.cmake @@ -0,0 +1,1514 @@ +# Distributed under the OSI-approved BSD 3-Clause License. See accompanying +# file Copyright.txt or https://cmake.org/licensing for details. + +#.rst: +# FindMPI +# ------- +# +# Find a Message Passing Interface (MPI) implementation. +# +# The Message Passing Interface (MPI) is a library used to write +# high-performance distributed-memory parallel applications, and is +# typically deployed on a cluster. MPI is a standard interface (defined +# by the MPI forum) for which many implementations are available. +# +# Variables for using MPI +# ^^^^^^^^^^^^^^^^^^^^^^^ +# +# The module exposes the components ``C``, ``CXX``, ``MPICXX`` and ``Fortran``. +# Each of these controls the various MPI languages to search for. +# The difference between ``CXX`` and ``MPICXX`` is that ``CXX`` refers to the +# MPI C API being usable from C++, whereas ``MPICXX`` refers to the MPI-2 C++ API +# that was removed again in MPI-3. +# +# Depending on the enabled components the following variables will be set: +# +# ``MPI_FOUND`` +# Variable indicating that MPI settings for all requested languages have been found. +# If no components are specified, this is true if MPI settings for all enabled languages +# were detected. Note that the ``MPICXX`` component does not affect this variable. +# ``MPI_VERSION`` +# Minimal version of MPI detected among the requested languages, or all enabled languages +# if no components were specified. +# +# This module will set the following variables per language in your +# project, where ```` is one of C, CXX, or Fortran: +# +# ``MPI__FOUND`` +# Variable indicating the MPI settings for ```` were found and that +# simple MPI test programs compile with the provided settings. +# ``MPI__COMPILER`` +# MPI compiler for ```` if such a program exists. +# ``MPI__COMPILE_OPTIONS`` +# Compilation options for MPI programs in ````, given as a :ref:`;-list `. +# ``MPI__COMPILE_DEFINITIONS`` +# Compilation definitions for MPI programs in ````, given as a :ref:`;-list `. +# ``MPI__INCLUDE_DIRS`` +# Include path(s) for MPI header. +# ``MPI__LINK_FLAGS`` +# Linker flags for MPI programs. +# ``MPI__LIBRARIES`` +# All libraries to link MPI programs against. +# +# Additionally, the following :prop_tgt:`IMPORTED` targets are defined: +# +# ``MPI::MPI_`` +# Target for using MPI from ````. +# +# The following variables indicating which bindings are present will be defined: +# +# ``MPI_MPICXX_FOUND`` +# Variable indicating whether the MPI-2 C++ bindings are present (introduced in MPI-2, removed with MPI-3). +# ``MPI_Fortran_HAVE_F77_HEADER`` +# True if the Fortran 77 header ``mpif.h`` is available. +# ``MPI_Fortran_HAVE_F90_MODULE`` +# True if the Fortran 90 module ``mpi`` can be used for accessing MPI (MPI-2 and higher only). +# ``MPI_Fortran_HAVE_F08_MODULE`` +# True if the Fortran 2008 ``mpi_f08`` is available to MPI programs (MPI-3 and higher only). +# +# If possible, the MPI version will be determined by this module. The facilities to detect the MPI version +# were introduced with MPI-1.2, and therefore cannot be found for older MPI versions. +# +# ``MPI__VERSION_MAJOR`` +# Major version of MPI implemented for ```` by the MPI distribution. +# ``MPI__VERSION_MINOR`` +# Minor version of MPI implemented for ```` by the MPI distribution. +# ``MPI__VERSION`` +# MPI version implemented for ```` by the MPI distribution. +# +# Note that there's no variable for the C bindings being accessible through ``mpi.h``, since the MPI standards +# always have required this binding to work in both C and C++ code. +# +# For running MPI programs, the module sets the following variables +# +# ``MPIEXEC_EXECUTABLE`` +# Executable for running MPI programs, if such exists. +# ``MPIEXEC_NUMPROC_FLAG`` +# Flag to pass to ``mpiexec`` before giving it the number of processors to run on. +# ``MPIEXEC_MAX_NUMPROCS`` +# Number of MPI processors to utilize. Defaults to the number +# of processors detected on the host system. +# ``MPIEXEC_PREFLAGS`` +# Flags to pass to ``mpiexec`` directly before the executable to run. +# ``MPIEXEC_POSTFLAGS`` +# Flags to pass to ``mpiexec`` after other flags. +# +# Variables for locating MPI +# ^^^^^^^^^^^^^^^^^^^^^^^^^^ +# +# This module performs a three step search for an MPI implementation: +# +# 1. Check if the compiler has MPI support built-in. This is the case if the user passed a +# compiler wrapper as ``CMAKE__COMPILER`` or if they're on a Cray system. +# 2. Attempt to find an MPI compiler wrapper and determine the compiler information from it. +# 3. Try to find an MPI implementation that does not ship such a wrapper by guessing settings. +# Currently, only Microsoft MPI and MPICH2 on Windows are supported. +# +# For controlling the second step, the following variables may be set: +# +# ``MPI__COMPILER`` +# Search for the specified compiler wrapper and use it. +# ``MPI__COMPILER_FLAGS`` +# Flags to pass to the MPI compiler wrapper during interrogation. Some compiler wrappers +# support linking debug or tracing libraries if a specific flag is passed and this variable +# may be used to obtain them. +# ``MPI_COMPILER_FLAGS`` +# Used to initialize ``MPI__COMPILER_FLAGS`` if no language specific flag has been given. +# Empty by default. +# ``MPI_EXECUTABLE_SUFFIX`` +# A suffix which is appended to all names that are being looked for. For instance you may set this +# to ``.mpich`` or ``.openmpi`` to prefer the one or the other on Debian and its derivatives. +# +# In order to control the guessing step, the following variable may be set: +# +# ``MPI_GUESS_LIBRARY_NAME`` +# Valid values are ``MSMPI`` and ``MPICH2``. If set, only the given library will be searched for. +# By default, ``MSMPI`` will be preferred over ``MPICH2`` if both are available. +# This also sets ``MPI_SKIP_COMPILER_WRAPPER`` to ``true``, which may be overridden. +# +# Each of the search steps may be skipped with the following control variables: +# +# ``MPI_ASSUME_NO_BUILTIN_MPI`` +# If true, the module assumes that the compiler itself does not provide an MPI implementation and +# skips to step 2. +# ``MPI_SKIP_COMPILER_WRAPPER`` +# If true, no compiler wrapper will be searched for. +# ``MPI_SKIP_GUESSING`` +# If true, the guessing step will be skipped. +# +# Additionally, the following control variable is available to change search behavior: +# +# ``MPI_CXX_SKIP_MPICXX`` +# Add some definitions that will disable the MPI-2 C++ bindings. +# Currently supported are MPICH, Open MPI, Platform MPI and derivatives thereof, +# for example MVAPICH or Intel MPI. +# +# If the find procedure fails for a variable ``MPI__WORKS``, then the settings detected by or passed to +# the module did not work and even a simple MPI test program failed to compile. +# +# If all of these parameters were not sufficient to find the right MPI implementation, a user may +# disable the entire autodetection process by specifying both a list of libraries in ``MPI__LIBRARIES`` +# and a list of include directories in ``MPI__ADDITIONAL_INCLUDE_DIRS``. +# Any other variable may be set in addition to these two. The module will then validate the MPI settings and store the +# settings in the cache. +# +# Cache variables for MPI +# ^^^^^^^^^^^^^^^^^^^^^^^ +# +# The variable ``MPI__INCLUDE_DIRS`` will be assembled from the following variables. +# For C and CXX: +# +# ``MPI__HEADER_DIR`` +# Location of the ``mpi.h`` header on disk. +# +# For Fortran: +# +# ``MPI_Fortran_F77_HEADER_DIR`` +# Location of the Fortran 77 header ``mpif.h``, if it exists. +# ``MPI_Fortran_MODULE_DIR`` +# Location of the ``mpi`` or ``mpi_f08`` modules, if available. +# +# For all languages the following variables are additionally considered: +# +# ``MPI__ADDITIONAL_INCLUDE_DIRS`` +# A :ref:`;-list ` of paths needed in addition to the normal include directories. +# ``MPI__INCLUDE_DIR`` +# Path variables for include folders referred to by ````. +# ``MPI__ADDITIONAL_INCLUDE_VARS`` +# A :ref:`;-list ` of ```` that will be added to the include locations of ````. +# +# The variable ``MPI__LIBRARIES`` will be assembled from the following variables: +# +# ``MPI__LIBRARY`` +# The location of a library called ```` for use with MPI. +# ``MPI__LIB_NAMES`` +# A :ref:`;-list ` of ```` that will be added to the include locations of ````. +# +# Usage of mpiexec +# ^^^^^^^^^^^^^^^^ +# +# When using ``MPIEXEC_EXECUTABLE`` to execute MPI applications, you should typically +# use all of the ``MPIEXEC_EXECUTABLE`` flags as follows: +# +# :: +# +# ${MPIEXEC_EXECUTABLE} ${MPIEXEC_NUMPROC_FLAG} ${MPIEXEC_MAX_NUMPROCS} +# ${MPIEXEC_PREFLAGS} EXECUTABLE ${MPIEXEC_POSTFLAGS} ARGS +# +# where ``EXECUTABLE`` is the MPI program, and ``ARGS`` are the arguments to +# pass to the MPI program. +# +# Advanced variables for using MPI +# ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +# +# The module can perform some advanced feature detections upon explicit request. +# +# **Important notice:** The following checks cannot be performed without *executing* an MPI test program. +# Consider the special considerations for the behavior of :command:`try_run` during cross compilation. +# Moreover, running an MPI program can cause additional issues, like a firewall notification on some systems. +# You should only enable these detections if you absolutely need the information. +# +# If the following variables are set to true, the respective search will be performed: +# +# ``MPI_DETERMINE_Fortran_CAPABILITIES`` +# Determine for all available Fortran bindings what the values of ``MPI_SUBARRAYS_SUPPORTED`` and +# ``MPI_ASYNC_PROTECTS_NONBLOCKING`` are and make their values available as ``MPI_Fortran__SUBARRAYS`` +# and ``MPI_Fortran__ASYNCPROT``, where ```` is one of ``F77_HEADER``, ``F90_MODULE`` and +# ``F08_MODULE``. +# ``MPI_DETERMINE_LIBRARY_VERSION`` +# For each language, find the output of ``MPI_Get_library_version`` and make it available as ``MPI__LIBRARY_VERSION``. +# This information is usually tied to the runtime component of an MPI implementation and might differ depending on ````. +# Note that the return value is entirely implementation defined. This information might be used to identify +# the MPI vendor and for example pick the correct one of multiple third party binaries that matches the MPI vendor. +# +# Backward Compatibility +# ^^^^^^^^^^^^^^^^^^^^^^ +# +# For backward compatibility with older versions of FindMPI, these +# variables are set, but deprecated: +# +# :: +# +# MPI_COMPILER MPI_LIBRARY MPI_EXTRA_LIBRARY +# MPI_COMPILE_FLAGS MPI_INCLUDE_PATH MPI_LINK_FLAGS +# MPI_LIBRARIES +# +# In new projects, please use the ``MPI__XXX`` equivalents. +# Additionally, the following variables are deprecated: +# +# ``MPI__COMPILE_FLAGS`` +# Use ``MPI__COMPILE_OPTIONS`` and ``MPI__COMPILE_DEFINITIONS`` instead. +# ``MPI__INCLUDE_PATH`` +# For consumption use ``MPI__INCLUDE_DIRS`` and for specifying folders use ``MPI__ADDITIONAL_INCLUDE_DIRS`` instead. +# ``MPIEXEC`` +# Use ``MPIEXEC_EXECUTABLE`` instead. + +cmake_policy(PUSH) +cmake_policy(SET CMP0057 NEW) # if IN_LIST + +include(${CMAKE_CURRENT_LIST_DIR}/FindPackageHandleStandardArgs.cmake) + +# Generic compiler names +set(_MPI_C_GENERIC_COMPILER_NAMES mpicc mpcc mpicc_r mpcc_r) +set(_MPI_CXX_GENERIC_COMPILER_NAMES mpicxx mpiCC mpcxx mpCC mpic++ mpc++ + mpicxx_r mpiCC_r mpcxx_r mpCC_r mpic++_r mpc++_r) +set(_MPI_Fortran_GENERIC_COMPILER_NAMES mpif95 mpif95_r mpf95 mpf95_r + mpif90 mpif90_r mpf90 mpf90_r + mpif77 mpif77_r mpf77 mpf77_r + mpifc) + +# GNU compiler names +set(_MPI_GNU_C_COMPILER_NAMES mpigcc mpgcc mpigcc_r mpgcc_r) +set(_MPI_GNU_CXX_COMPILER_NAMES mpig++ mpg++ mpig++_r mpg++_r mpigxx) +set(_MPI_GNU_Fortran_COMPILER_NAMES mpigfortran mpgfortran mpigfortran_r mpgfortran_r + mpig77 mpig77_r mpg77 mpg77_r) + +# Intel MPI compiler names on Windows +if(WIN32) + list(APPEND _MPI_C_GENERIC_COMPILER_NAMES mpicc.bat) + list(APPEND _MPI_CXX_GENERIC_COMPILER_NAMES mpicxx.bat) + list(APPEND _MPI_Fortran_GENERIC_COMPILER_NAMES mpifc.bat) + + # Intel MPI compiler names + set(_MPI_Intel_C_COMPILER_NAMES mpiicc.bat) + set(_MPI_Intel_CXX_COMPILER_NAMES mpiicpc.bat) + set(_MPI_Intel_Fortran_COMPILER_NAMES mpiifort.bat mpif77.bat mpif90.bat) + + # Intel MPI compiler names for MSMPI + set(_MPI_MSVC_C_COMPILER_NAMES mpicl.bat) + set(_MPI_MSVC_CXX_COMPILER_NAMES mpicl.bat) +else() + # Intel compiler names + set(_MPI_Intel_C_COMPILER_NAMES mpiicc) + set(_MPI_Intel_CXX_COMPILER_NAMES mpiicpc mpiicxx mpiic++) + set(_MPI_Intel_Fortran_COMPILER_NAMES mpiifort mpiif95 mpiif90 mpiif77) +endif() + +# PGI compiler names +set(_MPI_PGI_C_COMPILER_NAMES mpipgcc mppgcc) +set(_MPI_PGI_CXX_COMPILER_NAMES mpipgCC mppgCC) +set(_MPI_PGI_Fortran_COMPILER_NAMES mpipgf95 mpipgf90 mppgf95 mppgf90 mpipgf77 mppgf77) + +# XLC MPI Compiler names +set(_MPI_XL_C_COMPILER_NAMES mpxlc mpxlc_r mpixlc mpixlc_r) +set(_MPI_XL_CXX_COMPILER_NAMES mpixlcxx mpixlC mpixlc++ mpxlcxx mpxlc++ mpixlc++ mpxlCC + mpixlcxx_r mpixlC_r mpixlc++_r mpxlcxx_r mpxlc++_r mpixlc++_r mpxlCC_r) +set(_MPI_XL_Fortran_COMPILER_NAMES mpixlf95 mpixlf95_r mpxlf95 mpxlf95_r + mpixlf90 mpixlf90_r mpxlf90 mpxlf90_r + mpixlf77 mpixlf77_r mpxlf77 mpxlf77_r + mpixlf mpixlf_r mpxlf mpxlf_r) + +# Prepend vendor-specific compiler wrappers to the list. If we don't know the compiler, +# attempt all of them. +# By attempting vendor-specific compiler names first, we should avoid situations where the compiler wrapper +# stems from a proprietary MPI and won't know which compiler it's being used for. For instance, Intel MPI +# controls its settings via the I_MPI_CC environment variables if the generic name is being used. +# If we know which compiler we're working with, we can use the most specialized wrapper there is in order to +# pick up the right settings for it. +foreach (LANG IN ITEMS C CXX Fortran) + set(_MPI_${LANG}_COMPILER_NAMES "") + foreach (id IN ITEMS GNU Intel MSVC PGI XL) + if (NOT CMAKE_${LANG}_COMPILER_ID OR CMAKE_${LANG}_COMPILER_ID STREQUAL id) + list(APPEND _MPI_${LANG}_COMPILER_NAMES ${_MPI_${id}_${LANG}_COMPILER_NAMES}${MPI_EXECUTABLE_SUFFIX}) + endif() + unset(_MPI_${id}_${LANG}_COMPILER_NAMES) + endforeach() + list(APPEND _MPI_${LANG}_COMPILER_NAMES ${_MPI_${LANG}_GENERIC_COMPILER_NAMES}${MPI_EXECUTABLE_SUFFIX}) + unset(_MPI_${LANG}_GENERIC_COMPILER_NAMES) +endforeach() + +# Names to try for mpiexec +# Only mpiexec commands are guaranteed to behave as described in the standard, +# mpirun commands are not covered by the standard in any way whatsoever. +# lamexec is the executable for LAM/MPI, srun is for SLURM or Open MPI with SLURM support. +# srun -n X is however a valid command, so it behaves 'like' mpiexec. +set(_MPIEXEC_NAMES_BASE mpiexec mpiexec.hydra mpiexec.mpd mpirun lamexec srun) + +unset(_MPIEXEC_NAMES) +foreach(_MPIEXEC_NAME IN LISTS _MPIEXEC_NAMES_BASE) + list(APPEND _MPIEXEC_NAMES "${_MPIEXEC_NAME}${MPI_EXECUTABLE_SUFFIX}") +endforeach() +unset(_MPIEXEC_NAMES_BASE) + +function (_MPI_check_compiler LANG QUERY_FLAG OUTPUT_VARIABLE RESULT_VARIABLE) + if(DEFINED MPI_${LANG}_COMPILER_FLAGS) +# separate_arguments(_MPI_COMPILER_WRAPPER_OPTIONS NATIVE_COMMAND "${MPI_${LANG}_COMPILER_FLAGS}") + separate_arguments(_MPI_COMPILER_WRAPPER_OPTIONS "${MPI_${LANG}_COMPILER_FLAGS}") + else() + separate_arguments(_MPI_COMPILER_WRAPPER_OPTIONS NATIVE_COMMAND "${MPI_COMPILER_FLAGS}") + endif() + execute_process( + COMMAND ${MPI_${LANG}_COMPILER} ${_MPI_COMPILER_WRAPPER_OPTIONS} ${QUERY_FLAG} + OUTPUT_VARIABLE WRAPPER_OUTPUT OUTPUT_STRIP_TRAILING_WHITESPACE + ERROR_VARIABLE WRAPPER_OUTPUT ERROR_STRIP_TRAILING_WHITESPACE + RESULT_VARIABLE WRAPPER_RETURN) + # Some compiler wrappers will yield spurious zero return values, for example + # Intel MPI tolerates unknown arguments and if the MPI wrappers loads a shared + # library that has invalid or missing version information there would be warning + # messages emitted by ld.so in the compiler output. In either case, we'll treat + # the output as invalid. + if("${WRAPPER_OUTPUT}" MATCHES "undefined reference|unrecognized|need to set|no version information available") + set(WRAPPER_RETURN 255) + endif() + # Ensure that no error output might be passed upwards. + if(NOT WRAPPER_RETURN EQUAL 0) + unset(WRAPPER_OUTPUT) + endif() + set(${OUTPUT_VARIABLE} "${WRAPPER_OUTPUT}" PARENT_SCOPE) + set(${RESULT_VARIABLE} "${WRAPPER_RETURN}" PARENT_SCOPE) +endfunction() + +function (_MPI_interrogate_compiler lang) + unset(MPI_COMPILE_CMDLINE) + unset(MPI_LINK_CMDLINE) + + unset(MPI_COMPILE_OPTIONS_WORK) + unset(MPI_COMPILE_DEFINITIONS_WORK) + unset(MPI_INCLUDE_DIRS_WORK) + unset(MPI_LINK_FLAGS_WORK) + unset(MPI_LIB_NAMES_WORK) + unset(MPI_LIB_FULLPATHS_WORK) + + # Check whether the -showme:compile option works. This indicates that we have either Open MPI + # or a newer version of LAM/MPI, and implies that -showme:link will also work. + # Open MPI also supports -show, but separates linker and compiler information + _MPI_check_compiler(${LANG} "-showme:compile" MPI_COMPILE_CMDLINE MPI_COMPILER_RETURN) + if (MPI_COMPILER_RETURN EQUAL 0) + _MPI_check_compiler(${LANG} "-showme:link" MPI_LINK_CMDLINE MPI_COMPILER_RETURN) + + if (NOT MPI_COMPILER_RETURN EQUAL 0) + unset(MPI_COMPILE_CMDLINE) + endif() + endif() + + # MPICH and MVAPICH offer -compile-info and -link-info. + # For modern versions, both do the same as -show. However, for old versions, they do differ + # when called for mpicxx and mpif90 and it's necessary to use them over -show in order to find the + # removed MPI C++ bindings. + if (NOT MPI_COMPILER_RETURN EQUAL 0) + _MPI_check_compiler(${LANG} "-compile-info" MPI_COMPILE_CMDLINE MPI_COMPILER_RETURN) + + if (MPI_COMPILER_RETURN EQUAL 0) + _MPI_check_compiler(${LANG} "-link-info" MPI_LINK_CMDLINE MPI_COMPILER_RETURN) + + if (NOT MPI_COMPILER_RETURN EQUAL 0) + unset(MPI_COMPILE_CMDLINE) + endif() + endif() + endif() + + # MPICH, MVAPICH2 and Intel MPI just use "-show". Open MPI also offers this, but the + # -showme commands are more specialized. + if (NOT MPI_COMPILER_RETURN EQUAL 0) + _MPI_check_compiler(${LANG} "-show" MPI_COMPILE_CMDLINE MPI_COMPILER_RETURN) + endif() + + # Older versions of LAM/MPI have "-showme". Open MPI also supports this. + # Unknown to MPICH, MVAPICH and Intel MPI. + if (NOT MPI_COMPILER_RETURN EQUAL 0) + _MPI_check_compiler(${LANG} "-showme" MPI_COMPILE_CMDLINE MPI_COMPILER_RETURN) + endif() + + if (NOT (MPI_COMPILER_RETURN EQUAL 0) OR NOT (DEFINED MPI_COMPILE_CMDLINE)) + # Cannot interrogate this compiler, so exit. + set(MPI_${LANG}_WRAPPER_FOUND FALSE PARENT_SCOPE) + return() + endif() + unset(MPI_COMPILER_RETURN) + + # We have our command lines, but we might need to copy MPI_COMPILE_CMDLINE + # into MPI_LINK_CMDLINE, if we didn't find the link line. + if (NOT DEFINED MPI_LINK_CMDLINE) + set(MPI_LINK_CMDLINE "${MPI_COMPILE_CMDLINE}") + endif() + + # At this point, we obtained some output from a compiler wrapper that works. + # We'll now try to parse it into variables with meaning to us. + if("${LANG}" STREQUAL "Fortran") + # Some MPICH-1 and MVAPICH-1 versions return a three command answer for Fortran, consisting + # out of a symlink command for mpif.h, the actual compiler command and a deletion of the + # created symlink. We need to detect that case, remember the include path and drop the + # symlink/deletion operation to obtain the link/compile lines we'd usually expect. + if("${MPI_COMPILE_CMDLINE}" MATCHES "^ln -s ([^\" ]+|\"[^\"]+\") mpif.h") + get_filename_component(MPI_INCLUDE_DIRS_WORK "${CMAKE_MATCH_1}" DIRECTORY) + string(REGEX REPLACE "^ln -s ([^\" ]+|\"[^\"]+\") mpif.h\n" "" MPI_COMPILE_CMDLINE "${MPI_COMPILE_CMDLINE}") + string(REGEX REPLACE "^ln -s ([^\" ]+|\"[^\"]+\") mpif.h\n" "" MPI_LINK_CMDLINE "${MPI_LINK_CMDLINE}") + string(REGEX REPLACE "\nrm -f mpif.h$" "" MPI_COMPILE_CMDLINE "${MPI_COMPILE_CMDLINE}") + string(REGEX REPLACE "\nrm -f mpif.h$" "" MPI_LINK_CMDLINE "${MPI_LINK_CMDLINE}") + endif() + endif() + + # The Intel MPI wrapper on Linux will emit some objcopy commands after its compile command + # if -static_mpi was passed to the wrapper. To avoid spurious matches, we need to drop these lines. + if(UNIX) + string(REGEX REPLACE "(^|\n)objcopy[^\n]+(\n|$)" "" MPI_COMPILE_CMDLINE "${MPI_COMPILE_CMDLINE}") + string(REGEX REPLACE "(^|\n)objcopy[^\n]+(\n|$)" "" MPI_LINK_CMDLINE "${MPI_LINK_CMDLINE}") + endif() + + # Extract compile options from the compile command line. + string(REGEX MATCHALL "(^| )-f([^\" ]+|\"[^\"]+\")" MPI_ALL_COMPILE_OPTIONS "${MPI_COMPILE_CMDLINE}") + + foreach(_MPI_COMPILE_OPTION IN LISTS MPI_ALL_COMPILE_OPTIONS) + string(REGEX REPLACE "^ " "" _MPI_COMPILE_OPTION "${_MPI_COMPILE_OPTION}") + # Ignore -fstack-protector directives: These occur on MPICH and MVAPICH when the libraries + # themselves were built with this flag. However, this flag is unrelated to using MPI, and + # we won't match the accompanying --param-ssp-size and -Wp,-D_FORTIFY_SOURCE flags and therefore + # produce inconsistent results with the regularly flags. + # Similarly, aliasing flags do not belong into our flag array. + if(NOT "${_MPI_COMPILE_OPTION}" MATCHES "^-f(stack-protector|(no-|)strict-aliasing|PI[CE]|pi[ce])") + list(APPEND MPI_COMPILE_OPTIONS_WORK "${_MPI_COMPILE_OPTION}") + endif() + endforeach() + + # Same deal, with the definitions. We also treat arguments passed to the preprocessor directly. + string(REGEX MATCHALL "(^| )(-Wp,|-Xpreprocessor |)[-/]D([^\" ]+|\"[^\"]+\")" MPI_ALL_COMPILE_DEFINITIONS "${MPI_COMPILE_CMDLINE}") + + foreach(_MPI_COMPILE_DEFINITION IN LISTS MPI_ALL_COMPILE_DEFINITIONS) + string(REGEX REPLACE "^ ?(-Wp,|-Xpreprocessor )?[-/]D" "" _MPI_COMPILE_DEFINITION "${_MPI_COMPILE_DEFINITION}") + string(REPLACE "\"" "" _MPI_COMPILE_DEFINITION "${_MPI_COMPILE_DEFINITION}") + if(NOT "${_MPI_COMPILE_DEFINITION}" MATCHES "^_FORTIFY_SOURCE.*") + list(APPEND MPI_COMPILE_DEFINITIONS_WORK "${_MPI_COMPILE_DEFINITION}") + endif() + endforeach() + + # Extract include paths from compile command line + string(REGEX MATCHALL "(^| )[-/]I([^\" ]+|\"[^\"]+\")" MPI_ALL_INCLUDE_PATHS "${MPI_COMPILE_CMDLINE}") + + # If extracting failed to work, we'll try using -showme:incdirs. + if (NOT MPI_ALL_INCLUDE_PATHS) + _MPI_check_compiler(${LANG} "-showme:incdirs" MPI_INCDIRS_CMDLINE MPI_INCDIRS_COMPILER_RETURN) + if(MPI_INCDIRS_COMPILER_RETURN) + separate_arguments(MPI_ALL_INCLUDE_PATHS NATIVE_COMMAND "${MPI_INCDIRS_CMDLINE}") + endif() + endif() + + foreach(_MPI_INCLUDE_PATH IN LISTS MPI_ALL_INCLUDE_PATHS) + string(REGEX REPLACE "^ ?[-/]I" "" _MPI_INCLUDE_PATH "${_MPI_INCLUDE_PATH}") + string(REPLACE "\"" "" _MPI_INCLUDE_PATH "${_MPI_INCLUDE_PATH}") + get_filename_component(_MPI_INCLUDE_PATH "${_MPI_INCLUDE_PATH}" REALPATH) + list(APPEND MPI_INCLUDE_DIRS_WORK "${_MPI_INCLUDE_PATH}") + endforeach() + + # Extract linker paths from the link command line + string(REGEX MATCHALL "(^| )(-Wl,|-Xlinker |)(-L|[/-]LIBPATH:|[/-]libpath:)([^\" ]+|\"[^\"]+\")" MPI_ALL_LINK_PATHS "${MPI_LINK_CMDLINE}") + + # If extracting failed to work, we'll try using -showme:libdirs. + if (NOT MPI_ALL_LINK_PATHS) + _MPI_check_compiler(${LANG} "-showme:libdirs" MPI_LIBDIRS_CMDLINE MPI_LIBDIRS_COMPILER_RETURN) + if(MPI_LIBDIRS_COMPILER_RETURN) + separate_arguments(MPI_ALL_LINK_PATHS NATIVE_COMMAND "${MPI_LIBDIRS_CMDLINE}") + endif() + endif() + + foreach(_MPI_LPATH IN LISTS MPI_ALL_LINK_PATHS) + string(REGEX REPLACE "^ ?(-Wl,|-Xlinker )?(-L|[/-]LIBPATH:|[/-]libpath:)" "" _MPI_LPATH "${_MPI_LPATH}") + string(REPLACE "\"" "" _MPI_LPATH "${_MPI_LPATH}") + get_filename_component(_MPI_LPATH "${_MPI_LPATH}" REALPATH) + list(APPEND MPI_LINK_DIRECTORIES_WORK "${_MPI_LPATH}") + endforeach() + + # Extract linker flags from the link command line + string(REGEX MATCHALL "(^| )(-Wl,|-Xlinker )([^\" ]+|\"[^\"]+\")" MPI_ALL_LINK_FLAGS "${MPI_LINK_CMDLINE}") + + foreach(_MPI_LINK_FLAG IN LISTS MPI_ALL_LINK_FLAGS) + string(STRIP "${_MPI_LINK_FLAG}" _MPI_LINK_FLAG) + # MPI might be marked to build with non-executable stacks but this should not propagate. + if (NOT "${_MPI_LINK_FLAG}" MATCHES "(-Wl,|-Xlinker )-z,noexecstack") + if (MPI_LINK_FLAGS_WORK) + string(APPEND MPI_LINK_FLAGS_WORK " ${_MPI_LINK_FLAG}") + else() + set(MPI_LINK_FLAGS_WORK "${_MPI_LINK_FLAG}") + endif() + endif() + endforeach() + + # Extract the set of libraries to link against from the link command + # line + string(REGEX MATCHALL "(^| )-l([^\" ]+|\"[^\"]+\")" MPI_LIBNAMES "${MPI_LINK_CMDLINE}") + + foreach(_MPI_LIB_NAME IN LISTS MPI_LIBNAMES) + string(REGEX REPLACE "^ ?-l" "" _MPI_LIB_NAME "${_MPI_LIB_NAME}") + string(REPLACE "\"" "" _MPI_LIB_NAME "${_MPI_LIB_NAME}") + get_filename_component(_MPI_LIB_PATH "${_MPI_LIB_NAME}" DIRECTORY) + if(NOT "${_MPI_LIB_PATH}" STREQUAL "") + list(APPEND MPI_LIB_FULLPATHS_WORK "${_MPI_LIB_NAME}") + else() + list(APPEND MPI_LIB_NAMES_WORK "${_MPI_LIB_NAME}") + endif() + endforeach() + + if(WIN32) + # A compiler wrapper on Windows will just have the name of the + # library to link on its link line, potentially with a full path + string(REGEX MATCHALL "(^| )([^\" ]+\\.lib|\"[^\"]+\\.lib\")" MPI_LIBNAMES "${MPI_LINK_CMDLINE}") + foreach(_MPI_LIB_NAME IN LISTS MPI_LIBNAMES) + string(REGEX REPLACE "^ " "" _MPI_LIB_NAME "${_MPI_LIB_NAME}") + string(REPLACE "\"" "" _MPI_LIB_NAME "${_MPI_LIB_NAME}") + get_filename_component(_MPI_LIB_PATH "${_MPI_LIB_NAME}" DIRECTORY) + if(NOT "${_MPI_LIB_PATH}" STREQUAL "") + list(APPEND MPI_LIB_FULLPATHS_WORK "${_MPI_LIB_NAME}") + else() + list(APPEND MPI_LIB_NAMES_WORK "${_MPI_LIB_NAME}") + endif() + endforeach() + else() + # On UNIX platforms, archive libraries can be given with full path. + string(REGEX MATCHALL "(^| )([^\" ]+\\.a|\"[^\"]+\\.a\")" MPI_LIBFULLPATHS "${MPI_LINK_CMDLINE}") + foreach(_MPI_LIB_NAME IN LISTS MPI_LIBFULLPATHS) + string(REGEX REPLACE "^ " "" _MPI_LIB_NAME "${_MPI_LIB_NAME}") + string(REPLACE "\"" "" _MPI_LIB_NAME "${_MPI_LIB_NAME}") + get_filename_component(_MPI_LIB_PATH "${_MPI_LIB_NAME}" DIRECTORY) + if(NOT "${_MPI_LIB_PATH}" STREQUAL "") + list(APPEND MPI_LIB_FULLPATHS_WORK "${_MPI_LIB_NAME}") + else() + list(APPEND MPI_LIB_NAMES_WORK "${_MPI_LIB_NAME}") + endif() + endforeach() + endif() + + # An MPI compiler wrapper could have its MPI libraries in the implictly + # linked directories of the compiler itself. + if(DEFINED CMAKE_${LANG}_IMPLICIT_LINK_DIRECTORIES) + list(APPEND MPI_LINK_DIRECTORIES_WORK "${CMAKE_${LANG}_IMPLICIT_LINK_DIRECTORIES}") + endif() + + # Determine full path names for all of the libraries that one needs + # to link against in an MPI program + unset(MPI_PLAIN_LIB_NAMES_WORK) + foreach(_MPI_LIB_NAME IN LISTS MPI_LIB_NAMES_WORK) + get_filename_component(_MPI_PLAIN_LIB_NAME "${_MPI_LIB_NAME}" NAME_WE) + list(APPEND MPI_PLAIN_LIB_NAMES_WORK "${_MPI_PLAIN_LIB_NAME}") + find_library(MPI_${_MPI_PLAIN_LIB_NAME}_LIBRARY + NAMES "${_MPI_LIB_NAME}" "lib${_MPI_LIB_NAME}" + HINTS ${MPI_LINK_DIRECTORIES_WORK} + DOC "Location of the ${_MPI_PLAIN_LIB_NAME} library for MPI" + ) + mark_as_advanced(MPI_${_MPI_PLAIN_LIB_NAME}_LIBRARY) + endforeach() + + # Deal with the libraries given with full path next + unset(MPI_DIRECT_LIB_NAMES_WORK) + foreach(_MPI_LIB_FULLPATH IN LISTS MPI_LIB_FULLPATHS_WORK) + get_filename_component(_MPI_PLAIN_LIB_NAME "${_MPI_LIB_FULLPATH}" NAME_WE) + get_filename_component(_MPI_LIB_NAME "${_MPI_LIB_FULLPATH}" NAME) + get_filename_component(_MPI_LIB_PATH "${_MPI_LIB_FULLPATH}" DIRECTORY) + list(APPEND MPI_DIRECT_LIB_NAMES_WORK "${_MPI_PLAIN_LIB_NAME}") + find_library(MPI_${_MPI_PLAIN_LIB_NAME}_LIBRARY + NAMES "${_MPI_LIB_NAME}" + HINTS ${_MPI_LIB_PATH} + DOC "Location of the ${_MPI_PLAIN_LIB_NAME} library for MPI" + ) + mark_as_advanced(MPI_${_MPI_PLAIN_LIB_NAME}_LIBRARY) + endforeach() + if(MPI_DIRECT_LIB_NAMES_WORK) + set(MPI_PLAIN_LIB_NAMES_WORK "${MPI_DIRECT_LIB_NAMES_WORK};${MPI_PLAIN_LIB_NAMES_WORK}") + endif() + + # MPI might require pthread to work. The above mechanism wouldn't detect it, but we need to + # link it in that case. -lpthread is covered by the normal library treatment on the other hand. + if("${MPI_COMPILE_CMDLINE}" MATCHES "-pthread") + list(APPEND MPI_COMPILE_OPTIONS_WORK "-pthread") + if(MPI_LINK_FLAGS_WORK) + string(APPEND MPI_LINK_FLAGS_WORK " -pthread") + else() + set(MPI_LINK_FLAGS_WORK "-pthread") + endif() + endif() + + if(MPI_${LANG}_EXTRA_COMPILE_DEFINITIONS) + list(APPEND MPI_COMPILE_DEFINITIONS_WORK "${MPI_${LANG}_EXTRA_COMPILE_DEFINITIONS}") + endif() + if(MPI_${LANG}_EXTRA_COMPILE_OPTIONS) + list(APPEND MPI_COMPILE_OPTIONS_WORK "${MPI_${LANG}_EXTRA_COMPILE_OPTIONS}") + endif() + if(MPI_${LANG}_EXTRA_LIB_NAMES) + list(APPEND MPI_PLAIN_LIB_NAMES_WORK "${MPI_${LANG}_EXTRA_LIB_NAMES}") + endif() + + # If we found MPI, set up all of the appropriate cache entries + if(NOT MPI_${LANG}_COMPILE_OPTIONS) + set(MPI_${LANG}_COMPILE_OPTIONS ${MPI_COMPILE_OPTIONS_WORK} CACHE STRING "MPI ${LANG} compilation options" FORCE) + endif() + if(NOT MPI_${LANG}_COMPILE_DEFINITIONS) + set(MPI_${LANG}_COMPILE_DEFINITIONS ${MPI_COMPILE_DEFINITIONS_WORK} CACHE STRING "MPI ${LANG} compilation definitions" FORCE) + endif() + if(NOT MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS) + set(MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS ${MPI_INCLUDE_DIRS_WORK} CACHE STRING "MPI ${LANG} additional include directories" FORCE) + endif() + if(NOT MPI_${LANG}_LINK_FLAGS) + set(MPI_${LANG}_LINK_FLAGS ${MPI_LINK_FLAGS_WORK} CACHE STRING "MPI ${LANG} linker flags" FORCE) + endif() + if(NOT MPI_${LANG}_LIB_NAMES) + set(MPI_${LANG}_LIB_NAMES ${MPI_PLAIN_LIB_NAMES_WORK} CACHE STRING "MPI ${LANG} libraries to link against" FORCE) + endif() + set(MPI_${LANG}_WRAPPER_FOUND TRUE PARENT_SCOPE) +endfunction() + +function(_MPI_guess_settings LANG) + set(MPI_GUESS_FOUND FALSE) + # Currently only MSMPI and MPICH2 on Windows are supported, so we can skip this search if we're not targeting that. + if(WIN32) + # MSMPI + + # The environment variables MSMPI_INC and MSMPILIB32/64 are the only ways of locating the MSMPI_SDK, + # which is installed separately from the runtime. Thus it's possible to have mpiexec but not MPI headers + # or import libraries and vice versa. + if(NOT MPI_GUESS_LIBRARY_NAME OR "${MPI_GUESS_LIBRARY_NAME}" STREQUAL "MSMPI") + # We first attempt to locate the msmpi.lib. Should be find it, we'll assume that the MPI present is indeed + # Microsoft MPI. + if("${CMAKE_SIZEOF_VOID_P}" EQUAL 8) + set(MPI_MSMPI_LIB_PATH "$ENV{MSMPI_LIB64}") + set(MPI_MSMPI_INC_PATH_EXTRA "$ENV{MSMPI_INC}/x64") + else() + set(MPI_MSMPI_LIB_PATH "$ENV{MSMPI_LIB32}") + set(MPI_MSMPI_INC_PATH_EXTRA "$ENV{MSMPI_INC}/x86") + endif() + + find_library(MPI_msmpi_LIBRARY + NAMES msmpi + HINTS ${MPI_MSMPI_LIB_PATH} + DOC "Location of the msmpi library for Microsoft MPI") + mark_as_advanced(MPI_msmpi_LIBRARY) + + if(MPI_msmpi_LIBRARY) + # Next, we attempt to locate the MPI header. Note that for Fortran we know that mpif.h is a way + # MSMPI can be used and therefore that header has to be present. + if(NOT MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS) + get_filename_component(MPI_MSMPI_INC_DIR "$ENV{MSMPI_INC}" REALPATH) + set(MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS "${MPI_MSMPI_INC_DIR}" CACHE STRING "MPI ${LANG} additional include directories" FORCE) + unset(MPI_MSMPI_INC_DIR) + endif() + + # For MSMPI, one can compile the MPI module by building the mpi.f90 shipped with the MSMPI SDK, + # thus it might be present or provided by the user. Figuring out which is supported is done later on. + # The PGI Fortran compiler for instance ships a prebuilt set of modules in its own include folder. + # Should a user be employing PGI or have built its own set and provided it via cache variables, the + # splitting routine would have located the module files. + + # For C and C++, we're done here (MSMPI does not ship the MPI-2 C++ bindings) - however, for Fortran + # we need some extra library to glue Fortran support together: + # MSMPI ships 2-4 Fortran libraries, each for different Fortran compiler behaviors. The library names + # ending with a c are using the cdecl calling convention, whereas those ending with an s are for Fortran + # implementations using stdcall. Therefore, the 64-bit MSMPI only ships those ending in 'c', whereas the 32-bit + # has both variants available. + # The second difference is the last but one letter, if it's an e(nd), the length of a string argument is + # passed by the Fortran compiler after all other arguments on the parameter list, if it's an m(ixed), + # it's passed immediately after the string address. + + # To summarize: + # - msmpifec: CHARACTER length passed after the parameter list and using cdecl calling convention + # - msmpifmc: CHARACTER length passed directly after string address and using cdecl calling convention + # - msmpifes: CHARACTER length passed after the parameter list and using stdcall calling convention + # - msmpifms: CHARACTER length passed directly after string address and using stdcall calling convention + # 32-bit MSMPI ships all four libraries, 64-bit MSMPI ships only the first two. + + # As is, Intel Fortran and PGI Fortran both use the 'ec' variant of the calling convention, whereas + # the old Compaq Visual Fortran compiler defaulted to the 'ms' version. It's possible to make Intel Fortran + # use the CVF calling convention using /iface:cvf, but we assume - and this is also assumed in FortranCInterface - + # this isn't the case. It's also possible to make CVF use the 'ec' variant, using /iface=(cref,nomixed_str_len_arg). + + # Our strategy is now to locate all libraries, but enter msmpifec into the LIB_NAMES array. + # Should this not be adequate it's a straightforward way for a user to change the LIB_NAMES array and + # have his library found. Still, this should not be necessary outside of exceptional cases, as reasoned. + if ("${LANG}" STREQUAL "Fortran") + set(MPI_MSMPI_CALLINGCONVS c) + if("${CMAKE_SIZEOF_VOID_P}" EQUAL 4) + list(APPEND MPI_MSMPI_CALLINGCONVS s) + endif() + foreach(mpistrlenpos IN ITEMS e m) + foreach(mpicallingconv IN LISTS MPI_MSMPI_CALLINGCONVS) + find_library(MPI_msmpif${mpistrlenpos}${mpicallingconv}_LIBRARY + NAMES msmpif${mpistrlenpos}${mpicallingconv} + HINTS "${MPI_MSMPI_LIB_PATH}" + DOC "Location of the msmpi${mpistrlenpos}${mpicallingconv} library for Microsoft MPI") + mark_as_advanced(MPI_msmpif${mpistrlenpos}${mpicallingconv}_LIBRARY) + endforeach() + endforeach() + if(NOT MPI_${LANG}_LIB_NAMES) + set(MPI_${LANG}_LIB_NAMES "msmpi;msmpifec" CACHE STRING "MPI ${LANG} libraries to link against" FORCE) + endif() + + # At this point we're *not* done. MSMPI requires an additional include file for Fortran giving the value + # of MPI_AINT. This file is called mpifptr.h located in the x64 and x86 subfolders, respectively. + find_path(MPI_mpifptr_INCLUDE_DIR + NAMES "mpifptr.h" + HINTS "${MPI_MSMPI_INC_PATH_EXTRA}" + DOC "Location of the mpifptr.h extra header for Microsoft MPI") + if(NOT MPI_${LANG}_ADDITIONAL_INCLUDE_VARS) + set(MPI_${LANG}_ADDITIONAL_INCLUDE_VARS "mpifptr" CACHE STRING "MPI ${LANG} additional include directory variables, given in the form MPI__INCLUDE_DIR." FORCE) + endif() + mark_as_advanced(MPI_${LANG}_ADDITIONAL_INCLUDE_VARS MPI_mpifptr_INCLUDE_DIR) + else() + if(NOT MPI_${LANG}_LIB_NAMES) + set(MPI_${LANG}_LIB_NAMES "msmpi" CACHE STRING "MPI ${LANG} libraries to link against" FORCE) + endif() + endif() + mark_as_advanced(MPI_${LANG}_LIB_NAMES) + set(MPI_GUESS_FOUND TRUE) + endif() + endif() + + # At this point there's not many MPIs that we could still consider. + # OpenMPI 1.6.x and below supported Windows, but these ship compiler wrappers that still work. + # The only other relevant MPI implementation without a wrapper is MPICH2, which had Windows support in 1.4.1p1 and older. + if(NOT MPI_GUESS_LIBRARY_NAME OR "${MPI_GUESS_LIBRARY_NAME}" STREQUAL "MPICH2") + set(MPI_MPICH_PREFIX_PATHS + "$ENV{ProgramW6432}/MPICH2/lib" + "[HKEY_LOCAL_MACHINE\\SOFTWARE\\MPICH\\SMPD;binary]/../lib" + "[HKEY_LOCAL_MACHINE\\SOFTWARE\\MPICH2;Path]/lib" + ) + + # All of C, C++ and Fortran will need mpi.lib, so we'll look for this first + find_library(MPI_mpi_LIBRARY + NAMES mpi + HINTS ${MPI_MPICH_PREFIX_PATHS}) + mark_as_advanced(MPI_mpi_LIBRARY) + # If we found mpi.lib, we detect the rest of MPICH2 + if(MPI_mpi_LIBRARY) + set(MPI_MPICH_LIB_NAMES "mpi") + # If MPI-2 C++ bindings are requested, we need to locate cxx.lib as well. + # Otherwise, MPICH_SKIP_MPICXX will be defined and these bindings aren't needed. + if("${LANG}" STREQUAL "CXX" AND NOT MPI_CXX_SKIP_MPICXX) + find_library(MPI_cxx_LIBRARY + NAMES cxx + HINTS ${MPI_MPICH_PREFIX_PATHS}) + mark_as_advanced(MPI_cxx_LIBRARY) + list(APPEND MPI_MPICH_LIB_NAMES "cxx") + # For Fortran, MPICH2 provides three different libraries: + # fmpich2.lib which uses uppercase symbols and cdecl, + # fmpich2s.lib which uses uppercase symbols and stdcall (32-bit only), + # fmpich2g.lib which uses lowercase symbols with double underscores and cdecl. + # fmpich2s.lib would be useful for Compaq Visual Fortran, fmpich2g.lib has to be used with GNU g77 and is also + # provided in the form of an .a archive for MinGW and Cygwin. From our perspective, fmpich2.lib is the only one + # we need to try, and if it doesn't work with the given Fortran compiler we'd find out later on during validation + elseif("${LANG}" STREQUAL "Fortran") + find_library(MPI_fmpich2_LIBRARY + NAMES fmpich2 + HINTS ${MPI_MPICH_PREFIX_PATHS}) + find_library(MPI_fmpich2s_LIBRARY + NAMES fmpich2s + HINTS ${MPI_MPICH_PREFIX_PATHS}) + find_library(MPI_fmpich2g_LIBRARY + NAMES fmpich2g + HINTS ${MPI_MPICH_PREFIX_PATHS}) + mark_as_advanced(MPI_fmpich2_LIBRARY MPI_fmpich2s_LIBRARY MPI_fmpich2g_LIBRARY) + list(APPEND MPI_MPICH_LIB_NAMES "fmpich2") + endif() + + if(NOT MPI_${LANG}_LIB_NAMES) + set(MPI_${LANG}_LIB_NAMES "${MPI_MPICH_LIB_NAMES}" CACHE STRING "MPI ${LANG} libraries to link against" FORCE) + endif() + unset(MPI_MPICH_LIB_NAMES) + + if(NOT MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS) + # For MPICH2, the include folder would be in ../include relative to the library folder. + get_filename_component(MPI_MPICH_ROOT_DIR "${MPI_mpi_LIBRARY}" DIRECTORY) + get_filename_component(MPI_MPICH_ROOT_DIR "${MPI_MPICH_ROOT_DIR}" DIRECTORY) + if(IS_DIRECTORY "${MPI_MPICH_ROOT_DIR}/include") + set(MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS "${MPI_MPICH_ROOT_DIR}/include" CACHE STRING "MPI ${LANG} additional include directory variables, given in the form MPI__INCLUDE_DIR." FORCE) + endif() + unset(MPI_MPICH_ROOT_DIR) + endif() + set(MPI_GUESS_FOUND TRUE) + endif() + unset(MPI_MPICH_PREFIX_PATHS) + endif() + endif() + set(MPI_${LANG}_GUESS_FOUND "${MPI_GUESS_FOUND}" PARENT_SCOPE) +endfunction() + +function(_MPI_adjust_compile_definitions LANG) + if("${LANG}" STREQUAL "CXX") + # To disable the C++ bindings, we need to pass some definitions since the mpi.h header has to deal with both C and C++ + # bindings in MPI-2. + if(MPI_CXX_SKIP_MPICXX AND NOT MPI_${LANG}_COMPILE_DEFINITIONS MATCHES "SKIP_MPICXX") + # MPICH_SKIP_MPICXX is being used in MPICH and derivatives like MVAPICH or Intel MPI + # OMPI_SKIP_MPICXX is being used in Open MPI + # _MPICC_H is being used for IBM Platform MPI + list(APPEND MPI_${LANG}_COMPILE_DEFINITIONS "MPICH_SKIP_MPICXX" "OMPI_SKIP_MPICXX" "_MPICC_H") + set(MPI_${LANG}_COMPILE_DEFINITIONS "${MPI_${LANG}_COMPILE_DEFINITIONS}" CACHE STRING "MPI ${LANG} compilation definitions" FORCE) + endif() + endif() +endfunction() + +macro(_MPI_assemble_libraries LANG) + set(MPI_${LANG}_LIBRARIES "") + # Only for libraries do we need to check whether the compiler's linking stage is separate. + if(NOT "${MPI_${LANG}_COMPILER}" STREQUAL "${CMAKE_${LANG}_COMPILER}" OR NOT MPI_${LANG}_WORKS_IMPLICIT) + foreach(mpilib IN LISTS MPI_${LANG}_LIB_NAMES) + list(APPEND MPI_${LANG}_LIBRARIES ${MPI_${mpilib}_LIBRARY}) + endforeach() + endif() +endmacro() + +macro(_MPI_assemble_include_dirs LANG) + if("${MPI_${LANG}_COMPILER}" STREQUAL "${CMAKE_${LANG}_COMPILER}") + set(MPI_${LANG}_INCLUDE_DIRS "") + else() + set(MPI_${LANG}_INCLUDE_DIRS "${MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS}") + if("${LANG}" MATCHES "(C|CXX)") + if(MPI_${LANG}_HEADER_DIR) + list(APPEND MPI_${LANG}_INCLUDE_DIRS "${MPI_${LANG}_HEADER_DIR}") + endif() + else() # Fortran + if(MPI_${LANG}_F77_HEADER_DIR) + list(APPEND MPI_${LANG}_INCLUDE_DIRS "${MPI_${LANG}_F77_HEADER_DIR}") + endif() + if(MPI_${LANG}_MODULE_DIR AND NOT "${MPI_${LANG}_MODULE_DIR}" IN_LIST MPI_${LANG}_INCLUDE_DIRS) + list(APPEND MPI_${LANG}_INCLUDE_DIRS "${MPI_${LANG}_MODULE_DIR}") + endif() + endif() + if(MPI_${LANG}_ADDITIONAL_INCLUDE_VARS) + foreach(MPI_ADDITIONAL_INC_DIR IN LISTS MPI_${LANG}_ADDITIONAL_INCLUDE_VARS) + list(APPEND MPI_${LANG}_INCLUDE_DIRS "${MPI_${MPI_ADDITIONAL_INC_DIR}_INCLUDE_DIR}") + endforeach() + endif() + endif() +endmacro() + +function(_MPI_split_include_dirs LANG) + if("${MPI_${LANG}_COMPILER}" STREQUAL "${CMAKE_${LANG}_COMPILER}") + return() + endif() + # Backwards compatibility: Search INCLUDE_PATH if given. + if(MPI_${LANG}_INCLUDE_PATH) + list(APPEND MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS "${MPI_${LANG}_INCLUDE_PATH}") + endif() + + # We try to find the headers/modules among those paths (and system paths) + # For C/C++, we just need to have a look for mpi.h. + if("${LANG}" MATCHES "(C|CXX)") + find_path(MPI_${LANG}_HEADER_DIR "mpi.h" + HINTS ${MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS} + ) + mark_as_advanced(MPI_${LANG}_HEADER_DIR) + if(MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS) + list(REMOVE_ITEM MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS "${MPI_${LANG}_HEADER_DIR}") + endif() + # Fortran is more complicated here: An implementation could provide + # any of the Fortran 77/90/2008 APIs for MPI. For example, MSMPI + # only provides Fortran 77 and - if mpi.f90 is built - potentially + # a Fortran 90 module. + elseif("${LANG}" STREQUAL "Fortran") + find_path(MPI_${LANG}_F77_HEADER_DIR "mpif.h" + HINTS ${MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS} + ) + find_path(MPI_${LANG}_MODULE_DIR + NAMES "mpi.mod" "mpi_f08.mod" + HINTS ${MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS} + ) + if(MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS) + list(REMOVE_ITEM MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS + "${MPI_${LANG}_F77_HEADER_DIR}" + "${MPI_${LANG}_MODULE_DIR}" + ) + endif() + mark_as_advanced(MPI_${LANG}_F77_HEADER_DIR MPI_${LANG}_MODULE_DIR) + endif() + # Remove duplicates and default system directories from the list. + if(MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS) + list(REMOVE_DUPLICATES MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS) + foreach(MPI_IMPLICIT_INC_DIR IN LISTS CMAKE_${LANG}_IMPLICIT_LINK_DIRECTORIES) + list(REMOVE_ITEM MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS ${MPI_IMPLICIT_INC_DIR}) + endforeach() + endif() + set(MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS ${MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS} CACHE STRING "MPI ${LANG} additional include directories" FORCE) +endfunction() + +macro(_MPI_create_imported_target LANG) + if(NOT TARGET MPI::MPI_${LANG}) + add_library(MPI::MPI_${LANG} INTERFACE IMPORTED) + endif() + + set_property(TARGET MPI::MPI_${LANG} PROPERTY INTERFACE_COMPILE_OPTIONS "${MPI_${LANG}_COMPILE_OPTIONS}") + set_property(TARGET MPI::MPI_${LANG} PROPERTY INTERFACE_COMPILE_DEFINITIONS "${MPI_${LANG}_COMPILE_DEFINITIONS}") + + set_property(TARGET MPI::MPI_${LANG} PROPERTY INTERFACE_LINK_LIBRARIES "") + if(MPI_${LANG}_LINK_FLAGS) + set_property(TARGET MPI::MPI_${LANG} APPEND PROPERTY INTERFACE_LINK_LIBRARIES "${MPI_${LANG}_LINK_FLAGS}") + endif() + # If the compiler links MPI implicitly, no libraries will be found as they're contained within + # CMAKE__IMPLICIT_LINK_LIBRARIES already. + if(MPI_${LANG}_LIBRARIES) + set_property(TARGET MPI::MPI_${LANG} APPEND PROPERTY INTERFACE_LINK_LIBRARIES "${MPI_${LANG}_LIBRARIES}") + endif() + # Given the new design of FindMPI, INCLUDE_DIRS will always be located, even under implicit linking. + set_property(TARGET MPI::MPI_${LANG} PROPERTY INTERFACE_INCLUDE_DIRECTORIES "${MPI_${LANG}_INCLUDE_DIRS}") +endmacro() + +function(_MPI_try_staged_settings LANG MPI_TEST_FILE_NAME MODE RUN_BINARY) + set(WORK_DIR "${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/FindMPI") + set(SRC_DIR "${CMAKE_CURRENT_LIST_DIR}/FindMPI") + set(BIN_FILE "${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/FindMPI/${MPI_TEST_FILE_NAME}_${LANG}.bin") + unset(MPI_TEST_COMPILE_DEFINITIONS) + if("${LANG}" STREQUAL "Fortran") + if("${MODE}" STREQUAL "F90_MODULE") + set(MPI_Fortran_INCLUDE_LINE "use mpi\n implicit none") + elseif("${MODE}" STREQUAL "F08_MODULE") + set(MPI_Fortran_INCLUDE_LINE "use mpi_f08\n implicit none") + else() # F77 header + set(MPI_Fortran_INCLUDE_LINE "implicit none\n include 'mpif.h'") + endif() + configure_file("${SRC_DIR}/${MPI_TEST_FILE_NAME}.f90.in" "${WORK_DIR}/${MPI_TEST_FILE_NAME}.f90" @ONLY) + set(MPI_TEST_SOURCE_FILE "${WORK_DIR}/${MPI_TEST_FILE_NAME}.f90") + elseif("${LANG}" STREQUAL "CXX") + configure_file("${SRC_DIR}/${MPI_TEST_FILE_NAME}.c" "${WORK_DIR}/${MPI_TEST_FILE_NAME}.cpp" COPYONLY) + set(MPI_TEST_SOURCE_FILE "${WORK_DIR}/${MPI_TEST_FILE_NAME}.cpp") + if("${MODE}" STREQUAL "TEST_MPICXX") + set(MPI_TEST_COMPILE_DEFINITIONS TEST_MPI_MPICXX) + endif() + else() # C + set(MPI_TEST_SOURCE_FILE "${SRC_DIR}/${MPI_TEST_FILE_NAME}.c") + endif() + if(RUN_BINARY) + try_run(MPI_RUN_RESULT_${LANG}_${MPI_TEST_FILE_NAME}_${MODE} MPI_RESULT_${LANG}_${MPI_TEST_FILE_NAME}_${MODE} + "${CMAKE_BINARY_DIR}" SOURCES "${MPI_TEST_SOURCE_FILE}" + COMPILE_DEFINITIONS ${MPI_TEST_COMPILE_DEFINITIONS} + LINK_LIBRARIES MPI::MPI_${LANG} + RUN_OUTPUT_VARIABLE MPI_RUN_OUTPUT_${LANG}_${MPI_TEST_FILE_NAME}_${MODE}) + set(MPI_RUN_OUTPUT_${LANG}_${MPI_TEST_FILE_NAME}_${MODE} "${MPI_RUN_OUTPUT_${LANG}_${MPI_TEST_FILE_NAME}_${MODE}}" PARENT_SCOPE) + else() + try_compile(MPI_RESULT_${LANG}_${MPI_TEST_FILE_NAME}_${MODE} + "${CMAKE_BINARY_DIR}" SOURCES "${MPI_TEST_SOURCE_FILE}" + COMPILE_DEFINITIONS ${MPI_TEST_COMPILE_DEFINITIONS} + LINK_LIBRARIES MPI::MPI_${LANG} + COPY_FILE "${BIN_FILE}") + endif() +endfunction() + +macro(_MPI_check_lang_works LANG) + # For Fortran we may have by the MPI-3 standard an implementation that provides: + # - the mpi_f08 module + # - *both*, the mpi module and 'mpif.h' + # Since older MPI standards (MPI-1) did not define anything but 'mpif.h', we need to check all three individually. + if( NOT MPI_${LANG}_WORKS ) + if("${LANG}" STREQUAL "Fortran") + set(MPI_Fortran_INTEGER_LINE "(kind=MPI_INTEGER_KIND)") + _MPI_try_staged_settings(${LANG} test_mpi F77_HEADER FALSE) + _MPI_try_staged_settings(${LANG} test_mpi F90_MODULE FALSE) + _MPI_try_staged_settings(${LANG} test_mpi F08_MODULE FALSE) + + set(MPI_${LANG}_WORKS FALSE) + + foreach(mpimethod IN ITEMS F77_HEADER F08_MODULE F90_MODULE) + if(MPI_RESULT_${LANG}_test_mpi_${mpimethod}) + set(MPI_${LANG}_WORKS TRUE) + set(MPI_${LANG}_HAVE_${mpimethod} TRUE) + else() + set(MPI_${LANG}_HAVE_${mpimethod} FALSE) + endif() + endforeach() + # MPI-1 versions had no MPI_INTGER_KIND defined, so we need to try without it. + # However, MPI-1 also did not define the Fortran 90 and 08 modules, so we only try the F77 header. + unset(MPI_Fortran_INTEGER_LINE) + if(NOT MPI_${LANG}_WORKS) + _MPI_try_staged_settings(${LANG} test_mpi F77_HEADER_NOKIND FALSE) + if(MPI_RESULT_${LANG}_test_mpi_F77_HEADER_NOKIND) + set(MPI_${LANG}_WORKS TRUE) + set(MPI_${LANG}_HAVE_F77_HEADER TRUE) + endif() + endif() + else() + _MPI_try_staged_settings(${LANG} test_mpi normal FALSE) + # If 'test_mpi' built correctly, we've found valid MPI settings. There might not be MPI-2 C++ support, but there can't + # be MPI-2 C++ support without the C bindings being present, so checking for them is sufficient. + set(MPI_${LANG}_WORKS "${MPI_RESULT_${LANG}_test_mpi_normal}") + endif() + endif() +endmacro() + +# Some systems install various MPI implementations in separate folders in some MPI prefix +# This macro enumerates all such subfolders and adds them to the list of hints that will be searched. +macro(MPI_search_mpi_prefix_folder PREFIX_FOLDER) + if(EXISTS "${PREFIX_FOLDER}") + file(GLOB _MPI_folder_children RELATIVE "${PREFIX_FOLDER}" "${PREFIX_FOLDER}/*") + foreach(_MPI_folder_child IN LISTS _MPI_folder_children) + if(IS_DIRECTORY "${PREFIX_FOLDER}/${_MPI_folder_child}") + list(APPEND MPI_HINT_DIRS "${PREFIX_FOLDER}/${_MPI_folder_child}") + endif() + endforeach() + endif() +endmacro() + +set(MPI_HINT_DIRS ${MPI_HOME} $ENV{MPI_ROOT} $ENV{MPI_HOME} $ENV{I_MPI_ROOT}) +if("${CMAKE_HOST_SYSTEM_NAME}" STREQUAL "Linux") + # SUSE Linux Enterprise Server stores its MPI implementations under /usr/lib64/mpi/gcc/ + # We enumerate the subfolders and append each as a prefix + MPI_search_mpi_prefix_folder("/usr/lib64/mpi/gcc") +elseif("${CMAKE_HOST_SYSTEM_NAME}" STREQUAL "Windows") + # MSMPI stores its runtime in a special folder, this adds the possible locations to the hints. + list(APPEND MPI_HINT_DIRS $ENV{MSMPI_BIN} "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\MPI;InstallRoot]") +elseif("${CMAKE_HOST_SYSTEM_NAME}" STREQUAL "FreeBSD") + # FreeBSD ships mpich under the normal system paths - but available openmpi implementations + # will be found in /usr/local/mpi/ + MPI_search_mpi_prefix_folder("/usr/local/mpi") +endif() + +# Most MPI distributions have some form of mpiexec or mpirun which gives us something we can look for. +# The MPI standard does not mandate the existence of either, but instead only makes requirements if a distribution +# ships an mpiexec program (mpirun executables are not regulated by the standard). +find_program(MPIEXEC_EXECUTABLE + NAMES ${_MPIEXEC_NAMES} + PATH_SUFFIXES bin sbin + HINTS ${MPI_HINT_DIRS} + DOC "Executable for running MPI programs.") + +# call get_filename_component twice to remove mpiexec and the directory it exists in (typically bin). +# This gives us a fairly reliable base directory to search for /bin /lib and /include from. +get_filename_component(_MPI_BASE_DIR "${MPIEXEC_EXECUTABLE}" PATH) +get_filename_component(_MPI_BASE_DIR "${_MPI_BASE_DIR}" PATH) + +# According to the MPI standard, section 8.8 -n is a guaranteed, and the only guaranteed way to +# launch an MPI process using mpiexec if such a program exists. +set(MPIEXEC_NUMPROC_FLAG "-n" CACHE STRING "Flag used by MPI to specify the number of processes for mpiexec; the next option will be the number of processes.") +set(MPIEXEC_PREFLAGS "" CACHE STRING "These flags will be directly before the executable that is being run by mpiexec.") +set(MPIEXEC_POSTFLAGS "" CACHE STRING "These flags will be placed after all flags passed to mpiexec.") + +# Set the number of processes to the physical processor count +cmake_host_system_information(RESULT _MPIEXEC_NUMPROCS QUERY NUMBER_OF_PHYSICAL_CORES) +set(MPIEXEC_MAX_NUMPROCS "${_MPIEXEC_NUMPROCS}" CACHE STRING "Maximum number of processors available to run MPI applications.") +unset(_MPIEXEC_NUMPROCS) +mark_as_advanced(MPIEXEC_EXECUTABLE MPIEXEC_NUMPROC_FLAG MPIEXEC_PREFLAGS MPIEXEC_POSTFLAGS MPIEXEC_MAX_NUMPROCS) + +#============================================================================= +# Backward compatibility input hacks. Propagate the FindMPI hints to C and +# CXX if the respective new versions are not defined. Translate the old +# MPI_LIBRARY and MPI_EXTRA_LIBRARY to respective MPI_${LANG}_LIBRARIES. +# +# Once we find the new variables, we translate them back into their old +# equivalents below. +if(NOT MPI_IGNORE_LEGACY_VARIABLES) + foreach (LANG IN ITEMS C CXX) + # Old input variables. + set(_MPI_OLD_INPUT_VARS COMPILER COMPILE_FLAGS INCLUDE_PATH LINK_FLAGS) + + # Set new vars based on their old equivalents, if the new versions are not already set. + foreach (var ${_MPI_OLD_INPUT_VARS}) + if (NOT MPI_${LANG}_${var} AND MPI_${var}) + set(MPI_${LANG}_${var} "${MPI_${var}}") + endif() + endforeach() + + # Chop the old compile flags into options and definitions + + unset(MPI_${LANG}_EXTRA_COMPILE_DEFINITIONS) + unset(MPI_${LANG}_EXTRA_COMPILE_OPTIONS) + if(MPI_${LANG}_COMPILE_FLAGS) + separate_arguments(MPI_SEPARATE_FLAGS NATIVE_COMMAND "${MPI_${LANG}_COMPILE_FLAGS}") + foreach(_MPI_FLAG IN LISTS MPI_SEPARATE_FLAGS) + if("${_MPI_FLAG}" MATCHES "^ *[-/D]([^ ]+)") + list(APPEND MPI_${LANG}_EXTRA_COMPILE_DEFINITIONS "${CMAKE_MATCH_1}") + else() + list(APPEND MPI_${LANG}_EXTRA_COMPILE_OPTIONS "${_MPI_FLAG}") + endif() + endforeach() + unset(MPI_SEPARATE_FLAGS) + endif() + + # If a list of libraries was given, we'll split it into new-style cache variables + unset(MPI_${LANG}_EXTRA_LIB_NAMES) + if(NOT MPI_${LANG}_LIB_NAMES) + foreach(_MPI_LIB IN LISTS MPI_${LANG}_LIBRARIES MPI_LIBRARY MPI_EXTRA_LIBRARY) + if(_MPI_LIB) + get_filename_component(_MPI_PLAIN_LIB_NAME "${_MPI_LIB}" NAME_WE) + get_filename_component(_MPI_LIB_NAME "${_MPI_LIB}" NAME) + get_filename_component(_MPI_LIB_DIR "${_MPI_LIB}" DIRECTORY) + list(APPEND MPI_${LANG}_EXTRA_LIB_NAMES "${_MPI_PLAIN_LIB_NAME}") + find_library(MPI_${_MPI_PLAIN_LIB_NAME}_LIBRARY + NAMES "${_MPI_LIB_NAME}" "lib${_MPI_LIB_NAME}" + HINTS ${_MPI_LIB_DIR} $ENV{MPI_LIB} + DOC "Location of the ${_MPI_PLAIN_LIB_NAME} library for MPI" + ) + mark_as_advanced(MPI_${_MPI_PLAIN_LIB_NAME}_LIBRARY) + endif() + endforeach() + endif() + endforeach() +endif() +#============================================================================= + +unset(MPI_VERSION) +unset(MPI_VERSION_MAJOR) +unset(MPI_VERSION_MINOR) + +unset(_MPI_MIN_VERSION) + +# If the user specified a library name we assume they prefer that library over a wrapper. If not, they can disable skipping manually. +if(NOT DEFINED MPI_SKIP_COMPILER_WRAPPER AND MPI_GUESS_LIBRARY_NAME) + set(MPI_SKIP_COMPILER_WRAPPER TRUE) +endif() + +# This loop finds the compilers and sends them off for interrogation. +foreach(LANG IN ITEMS C CXX Fortran) + if(CMAKE_${LANG}_COMPILER_LOADED) + if(NOT MPI_FIND_COMPONENTS) + set(_MPI_FIND_${LANG} TRUE) + elseif( ${LANG} IN_LIST MPI_FIND_COMPONENTS) + set(_MPI_FIND_${LANG} TRUE) + elseif( ${LANG} STREQUAL CXX AND NOT MPI_CXX_SKIP_MPICXX AND MPICXX IN_LIST MPI_FIND_COMPONENTS ) + set(_MPI_FIND_${LANG} TRUE) + else() + set(_MPI_FIND_${LANG} FALSE) + endif() + else() + set(_MPI_FIND_${LANG} FALSE) + endif() + if(_MPI_FIND_${LANG}) + if( ${LANG} STREQUAL CXX AND NOT MPICXX IN_LIST MPI_FIND_COMPONENTS ) + set(MPI_CXX_SKIP_MPICXX FALSE CACHE BOOL "If true, the MPI-2 C++ bindings are disabled using definitions.") + mark_as_advanced(MPI_CXX_SKIP_MPICXX) + endif() + if(NOT (MPI_${LANG}_LIB_NAMES AND (MPI_${LANG}_INCLUDE_PATH OR MPI_${LANG}_INCLUDE_DIRS OR MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS))) + set(MPI_${LANG}_TRIED_IMPLICIT FALSE) + set(MPI_${LANG}_WORKS_IMPLICIT FALSE) + if(NOT MPI_${LANG}_COMPILER AND NOT MPI_ASSUME_NO_BUILTIN_MPI) + # Should the imported targets be empty, we effectively try whether the compiler supports MPI on its own, which is the case on e.g. + # Cray PrgEnv. + _MPI_create_imported_target(${LANG}) + _MPI_check_lang_works(${LANG}) + + # If the compiler can build MPI code on its own, it functions as an MPI compiler and we'll set the variable to point to it. + if(MPI_${LANG}_WORKS) + set(MPI_${LANG}_COMPILER "${CMAKE_${LANG}_COMPILER}" CACHE FILEPATH "MPI compiler for ${LANG}" FORCE) + set(MPI_${LANG}_WORKS_IMPLICIT TRUE) + endif() + set(MPI_${LANG}_TRIED_IMPLICIT TRUE) + endif() + + if(NOT "${MPI_${LANG}_COMPILER}" STREQUAL "${CMAKE_${LANG}_COMPILER}" OR NOT MPI_${LANG}_WORKS) + set(MPI_${LANG}_WRAPPER_FOUND FALSE) + set(MPI_PINNED_COMPILER FALSE) + + if(NOT MPI_SKIP_COMPILER_WRAPPER) + if(MPI_${LANG}_COMPILER) + # If the user supplies a compiler *name* instead of an absolute path, assume that we need to find THAT compiler. + if (NOT IS_ABSOLUTE "${MPI_${LANG}_COMPILER}") + # Get rid of our default list of names and just search for the name the user wants. + set(_MPI_${LANG}_COMPILER_NAMES "${MPI_${LANG}_COMPILER}") + unset(MPI_${LANG}_COMPILER CACHE) + endif() + # If the user specifies a compiler, we don't want to try to search libraries either. + set(MPI_PINNED_COMPILER TRUE) + endif() + + # If we have an MPI base directory, we'll try all compiler names in that one first. + # This should prevent mixing different MPI environments + if(_MPI_BASE_DIR) + find_program(MPI_${LANG}_COMPILER + NAMES ${_MPI_${LANG}_COMPILER_NAMES} + PATH_SUFFIXES bin sbin + HINTS ${_MPI_BASE_DIR} + NO_DEFAULT_PATH + DOC "MPI compiler for ${LANG}" + ) + endif() + + # If the base directory did not help (for example because the mpiexec isn't in the same directory as the compilers), + # we shall try searching in the default paths. + find_program(MPI_${LANG}_COMPILER + NAMES ${_MPI_${LANG}_COMPILER_NAMES} + PATH_SUFFIXES bin sbin + DOC "MPI compiler for ${LANG}" + ) + + if("${MPI_${LANG}_COMPILER}" STREQUAL "${CMAKE_${LANG}_COMPILER}") + set(MPI_PINNED_COMPILER TRUE) + + # If we haven't made the implicit compiler test yet, perform it now. + if(NOT MPI_${LANG}_TRIED_IMPLICIT) + _MPI_create_imported_target(${LANG}) + _MPI_check_lang_works(${LANG}) + endif() + + # Should the MPI compiler not work implicitly for MPI, still interrogate it. + # Otherwise, MPI compilers for which CMake has separate linking stages, e.g. Intel MPI on Windows where link.exe is being used + # directly during linkage instead of CMAKE__COMPILER will not work. + if(NOT MPI_${LANG}_WORKS) + set(MPI_${LANG}_WORKS_IMPLICIT FALSE) + _MPI_interrogate_compiler(${LANG}) + else() + set(MPI_${LANG}_WORKS_IMPLICIT TRUE) + endif() + elseif(MPI_${LANG}_COMPILER) + _MPI_interrogate_compiler(${LANG}) + endif() + endif() + + if(NOT MPI_SKIP_GUESSING AND NOT MPI_${LANG}_WRAPPER_FOUND AND NOT MPI_PINNED_COMPILER) + # For C++, we may use the settings for C. Should a given compiler wrapper for C++ not exist, but one for C does, we copy over the + # settings for C. An MPI distribution that is in this situation would be IBM Platform MPI. + if("${LANG}" STREQUAL "CXX" AND MPI_C_WRAPPER_FOUND) + set(MPI_${LANG}_COMPILE_OPTIONS ${MPI_C_COMPILE_OPTIONS} CACHE STRING "MPI ${LANG} compilation options" ) + set(MPI_${LANG}_COMPILE_DEFINITIONS ${MPI_C_COMPILE_DEFINITIONS} CACHE STRING "MPI ${LANG} compilation definitions" ) + set(MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS ${MPI_C_INCLUDE_DIRS} CACHE STRING "MPI ${LANG} additional include directories") + set(MPI_${LANG}_LINK_FLAGS ${MPI_C_LINK_FLAGS} CACHE STRING "MPI ${LANG} linker flags" ) + set(MPI_${LANG}_LIB_NAMES ${MPI_C_LIB_NAMES} CACHE STRING "MPI ${LANG} libraries to link against" ) + else() + _MPI_guess_settings(${LANG}) + endif() + endif() + endif() + endif() + + _MPI_split_include_dirs(${LANG}) + _MPI_assemble_include_dirs(${LANG}) + _MPI_assemble_libraries(${LANG}) + + _MPI_adjust_compile_definitions(${LANG}) + # We always create imported targets even if they're empty + _MPI_create_imported_target(${LANG}) + + if(NOT MPI_${LANG}_WORKS) + _MPI_check_lang_works(${LANG}) + endif() + + # Next, we'll initialize the MPI variables that have not been previously set. + set(MPI_${LANG}_COMPILE_OPTIONS "" CACHE STRING "MPI ${LANG} compilation flags" ) + set(MPI_${LANG}_COMPILE_DEFINITIONS "" CACHE STRING "MPI ${LANG} compilation definitions" ) + set(MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS "" CACHE STRING "MPI ${LANG} additional include directories") + set(MPI_${LANG}_LINK_FLAGS "" CACHE STRING "MPI ${LANG} linker flags" ) + if(NOT MPI_${LANG}_COMPILER STREQUAL CMAKE_${LANG}_COMPILER) + set(MPI_${LANG}_LIB_NAMES "" CACHE STRING "MPI ${LANG} libraries to link against" ) + endif() + mark_as_advanced(MPI_${LANG}_COMPILE_OPTIONS MPI_${LANG}_COMPILE_DEFINITIONS MPI_${LANG}_LINK_FLAGS + MPI_${LANG}_LIB_NAMES MPI_${LANG}_ADDITIONAL_INCLUDE_DIRS MPI_${LANG}_COMPILER) + + # If we've found MPI, then we'll perform additional analysis: Determine the MPI version, MPI library version, supported + # MPI APIs (i.e. MPI-2 C++ bindings). For Fortran we also need to find specific parameters if we're under MPI-3. + if(MPI_${LANG}_WORKS) + if("${LANG}" STREQUAL "CXX" AND NOT DEFINED MPI_MPICXX_FOUND) + if(NOT MPI_CXX_SKIP_MPICXX AND NOT MPI_CXX_VALIDATE_SKIP_MPICXX) + _MPI_try_staged_settings(${LANG} test_mpi MPICXX FALSE) + if(MPI_RESULT_${LANG}_test_mpi_MPICXX) + set(MPI_MPICXX_FOUND TRUE) + else() + set(MPI_MPICXX_FOUND FALSE) + endif() + else() + set(MPI_MPICXX_FOUND FALSE) + endif() + endif() + + # At this point, we know the bindings present but not the MPI version or anything else. + if(NOT DEFINED MPI_${LANG}_VERSION) + unset(MPI_${LANG}_VERSION_MAJOR) + unset(MPI_${LANG}_VERSION_MINOR) + endif() + set(MPI_BIN_FOLDER ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/FindMPI) + + # For Fortran, we'll want to use the most modern MPI binding to test capabilities other than the + # Fortran parameters, since those depend on the method of consumption. + # For C++, we can always use the C bindings, and should do so, since the C++ bindings do not exist in MPI-3 + # whereas the C bindings do, and the C++ bindings never offered any feature advantage over their C counterparts. + if("${LANG}" STREQUAL "Fortran") + if(MPI_${LANG}_HAVE_F08_MODULE) + set(MPI_${LANG}_HIGHEST_METHOD F08_MODULE) + elseif(MPI_${LANG}_HAVE_F90_MODULE) + set(MPI_${LANG}_HIGHEST_METHOD F90_MODULE) + else() + set(MPI_${LANG}_HIGHEST_METHOD F77_HEADER) + endif() + + # Another difference between C and Fortran is that we can't use the preprocessor to determine whether MPI_VERSION + # and MPI_SUBVERSION are provided. These defines did not exist in MPI 1.0 and 1.1 and therefore might not + # exist. For C/C++, test_mpi.c will handle the MPI_VERSION extraction, but for Fortran, we need mpiver.f90. + if(NOT DEFINED MPI_${LANG}_VERSION) + _MPI_try_staged_settings(${LANG} mpiver ${MPI_${LANG}_HIGHEST_METHOD} FALSE) + if(MPI_RESULT_${LANG}_mpiver_${MPI_${LANG}_HIGHEST_METHOD}) + file(STRINGS ${MPI_BIN_FOLDER}/mpiver_${LANG}.bin _MPI_VERSION_STRING LIMIT_COUNT 1 REGEX "INFO:MPI-VER") + if("${_MPI_VERSION_STRING}" MATCHES ".*INFO:MPI-VER\\[([0-9]+)\\.([0-9]+)\\].*") + set(MPI_${LANG}_VERSION_MAJOR "${CMAKE_MATCH_1}") + set(MPI_${LANG}_VERSION_MINOR "${CMAKE_MATCH_2}") + set(MPI_${LANG}_VERSION "${MPI_${LANG}_VERSION_MAJOR}.${MPI_${LANG}_VERSION_MINOR}") + endif() + endif() + endif() + + # Finally, we want to find out which capabilities a given interface supports, compare the MPI-3 standard. + # This is determined by interface specific parameters MPI_SUBARRAYS_SUPPORTED and MPI_ASYNC_PROTECTS_NONBLOCKING + # and might vary between the different methods of consumption. + if(MPI_DETERMINE_Fortran_CAPABILITIES AND NOT MPI_Fortran_CAPABILITIES_DETERMINED) + foreach(mpimethod IN ITEMS F08_MODULE F90_MODULE F77_HEADER) + if(MPI_${LANG}_HAVE_${mpimethod}) + set(MPI_${LANG}_${mpimethod}_SUBARRAYS FALSE) + set(MPI_${LANG}_${mpimethod}_ASYNCPROT FALSE) + _MPI_try_staged_settings(${LANG} fortranparam_mpi ${mpimethod} TRUE) + if(MPI_RESULT_${LANG}_fortranparam_mpi_${mpimethod} AND + NOT "${MPI_RUN_RESULT_${LANG}_fortranparam_mpi_${mpimethod}}" STREQUAL "FAILED_TO_RUN") + if("${MPI_RUN_OUTPUT_${LANG}_fortranparam_mpi_${mpimethod}}" MATCHES + ".*INFO:SUBARRAYS\\[ *([TF]) *\\]-ASYNCPROT\\[ *([TF]) *\\].*") + if("${CMAKE_MATCH_1}" STREQUAL "T") + set(MPI_${LANG}_${mpimethod}_SUBARRAYS TRUE) + endif() + if("${CMAKE_MATCH_2}" STREQUAL "T") + set(MPI_${LANG}_${mpimethod}_ASYNCPROT TRUE) + endif() + endif() + endif() + endif() + endforeach() + set(MPI_Fortran_CAPABILITIES_DETERMINED TRUE) + endif() + else() + set(MPI_${LANG}_HIGHEST_METHOD normal) + + # By the MPI-2 standard, MPI_VERSION and MPI_SUBVERSION are valid for both C and C++ bindings. + if(NOT DEFINED MPI_${LANG}_VERSION) + file(STRINGS ${MPI_BIN_FOLDER}/test_mpi_${LANG}.bin _MPI_VERSION_STRING LIMIT_COUNT 1 REGEX "INFO:MPI-VER") + if("${_MPI_VERSION_STRING}" MATCHES ".*INFO:MPI-VER\\[([0-9]+)\\.([0-9]+)\\].*") + set(MPI_${LANG}_VERSION_MAJOR "${CMAKE_MATCH_1}") + set(MPI_${LANG}_VERSION_MINOR "${CMAKE_MATCH_2}") + set(MPI_${LANG}_VERSION "${MPI_${LANG}_VERSION_MAJOR}.${MPI_${LANG}_VERSION_MINOR}") + endif() + endif() + endif() + + unset(MPI_BIN_FOLDER) + + # At this point, we have dealt with determining the MPI version and parameters for each Fortran method available. + # The one remaining issue is to determine which MPI library is installed. + # Determining the version and vendor of the MPI library is only possible via MPI_Get_library_version() at runtime, + # and therefore we cannot do this while cross-compiling (a user may still define MPI__LIBRARY_VERSION_STRING + # themselves and we'll attempt splitting it, which is equivalent to provide the try_run output). + # It's also worth noting that the installed version string can depend on the language, or on the system the binary + # runs on if MPI is not statically linked. + if(MPI_DETERMINE_LIBRARY_VERSION AND NOT MPI_${LANG}_LIBRARY_VERSION_STRING) + _MPI_try_staged_settings(${LANG} libver_mpi ${MPI_${LANG}_HIGHEST_METHOD} TRUE) + if(MPI_RESULT_${LANG}_libver_mpi_${MPI_${LANG}_HIGHEST_METHOD} AND + "${MPI_RUN_RESULT_${LANG}_libver_mpi_${MPI_${LANG}_HIGHEST_METHOD}}" EQUAL "0") + string(STRIP "${MPI_RUN_OUTPUT_${LANG}_libver_mpi_${MPI_${LANG}_HIGHEST_METHOD}}" + MPI_${LANG}_LIBRARY_VERSION_STRING) + else() + set(MPI_${LANG}_LIBRARY_VERSION_STRING "NOTFOUND") + endif() + endif() + endif() + + set(MPI_${LANG}_FIND_QUIETLY ${MPI_FIND_QUIETLY}) + set(MPI_${LANG}_FIND_VERSION ${MPI_FIND_VERSION}) + set(MPI_${LANG}_FIND_VERSION_EXACT ${MPI_FIND_VERSION_EXACT}) + + unset(MPI_${LANG}_REQUIRED_VARS) + if (NOT "${MPI_${LANG}_COMPILER}" STREQUAL "${CMAKE_${LANG}_COMPILER}") + foreach(mpilibname IN LISTS MPI_${LANG}_LIB_NAMES) + list(APPEND MPI_${LANG}_REQUIRED_VARS "MPI_${mpilibname}_LIBRARY") + endforeach() + list(APPEND MPI_${LANG}_REQUIRED_VARS "MPI_${LANG}_LIB_NAMES") + if("${LANG}" STREQUAL "Fortran") + # For Fortran we only need one of the module or header directories to have *some* support for MPI. + if(NOT MPI_${LANG}_MODULE_DIR) + list(APPEND MPI_${LANG}_REQUIRED_VARS "MPI_${LANG}_F77_HEADER_DIR") + endif() + if(NOT MPI_${LANG}_F77_HEADER_DIR) + list(APPEND MPI_${LANG}_REQUIRED_VARS "MPI_${LANG}_MODULE_DIR") + endif() + else() + list(APPEND MPI_${LANG}_REQUIRED_VARS "MPI_${LANG}_HEADER_DIR") + endif() + if(MPI_${LANG}_ADDITIONAL_INCLUDE_VARS) + foreach(mpiincvar IN LISTS MPI_${LANG}_ADDITIONAL_INCLUDE_VARS) + list(APPEND MPI_${LANG}_REQUIRED_VARS "MPI_${mpiincvar}_INCLUDE_DIR") + endforeach() + endif() + # Append the works variable now. If the settings did not work, this will show up properly. + list(APPEND MPI_${LANG}_REQUIRED_VARS "MPI_${LANG}_WORKS") + else() + # If the compiler worked implicitly, use its path as output. + # Should the compiler variable be set, we also require it to work. + list(APPEND MPI_${LANG}_REQUIRED_VARS "MPI_${LANG}_COMPILER") + if(MPI_${LANG}_COMPILER) + list(APPEND MPI_${LANG}_REQUIRED_VARS "MPI_${LANG}_WORKS") + endif() + endif() + find_package_handle_standard_args(MPI_${LANG} REQUIRED_VARS ${MPI_${LANG}_REQUIRED_VARS} + VERSION_VAR MPI_${LANG}_VERSION) + + if(DEFINED MPI_${LANG}_VERSION) + if(NOT _MPI_MIN_VERSION OR _MPI_MIN_VERSION VERSION_GREATER MPI_${LANG}_VERSION) + set(_MPI_MIN_VERSION MPI_${LANG}_VERSION) + endif() + endif() + endif() +endforeach() + +unset(_MPI_REQ_VARS) +foreach(LANG IN ITEMS C CXX Fortran) + if((NOT MPI_FIND_COMPONENTS AND CMAKE_${LANG}_COMPILER_LOADED) OR LANG IN_LIST MPI_FIND_COMPONENTS) + list(APPEND _MPI_REQ_VARS "MPI_${LANG}_FOUND") + endif() +endforeach() + +if(MPICXX IN_LIST MPI_FIND_COMPONENTS) + list(APPEND _MPI_REQ_VARS "MPI_MPICXX_FOUND") +endif() + +find_package_handle_standard_args(MPI + REQUIRED_VARS ${_MPI_REQ_VARS} + VERSION_VAR ${_MPI_MIN_VERSION} + HANDLE_COMPONENTS) + +#============================================================================= +# More backward compatibility stuff + +# For compatibility reasons, we also define MPIEXEC +set(MPIEXEC "${MPIEXEC_EXECUTABLE}") + +# Copy over MPI__INCLUDE_PATH from the assembled INCLUDE_DIRS. +foreach(LANG IN ITEMS C CXX Fortran) + if(MPI_${LANG}_FOUND) + set(MPI_${LANG}_INCLUDE_PATH "${MPI_${LANG}_INCLUDE_DIRS}") + unset(MPI_${LANG}_COMPILE_FLAGS) + if(MPI_${LANG}_COMPILE_OPTIONS) + set(MPI_${LANG}_COMPILE_FLAGS "${MPI_${LANG}_COMPILE_OPTIONS}") + endif() + if(MPI_${LANG}_COMPILE_DEFINITIONS) + foreach(_MPI_DEF IN LISTS MPI_${LANG}_COMPILE_DEFINITIONS) + string(APPEND MPI_${LANG}_COMPILE_FLAGS " -D${_MPI_DEF}") + endforeach() + endif() + endif() +endforeach() + +# Bare MPI sans ${LANG} vars are set to CXX then C, depending on what was found. +# This mimics the behavior of the old language-oblivious FindMPI. +set(_MPI_OLD_VARS COMPILER INCLUDE_PATH COMPILE_FLAGS LINK_FLAGS LIBRARIES) +if (MPI_CXX_FOUND) + foreach (var ${_MPI_OLD_VARS}) + set(MPI_${var} ${MPI_CXX_${var}}) + endforeach() +elseif (MPI_C_FOUND) + foreach (var ${_MPI_OLD_VARS}) + set(MPI_${var} ${MPI_C_${var}}) + endforeach() +endif() + +# Chop MPI_LIBRARIES into the old-style MPI_LIBRARY and MPI_EXTRA_LIBRARY, and set them in cache. +if (MPI_LIBRARIES) + list(GET MPI_LIBRARIES 0 MPI_LIBRARY_WORK) + set(MPI_LIBRARY "${MPI_LIBRARY_WORK}") + unset(MPI_LIBRARY_WORK) +else() + set(MPI_LIBRARY "MPI_LIBRARY-NOTFOUND") +endif() + +list(LENGTH MPI_LIBRARIES MPI_NUMLIBS) +if (MPI_NUMLIBS GREATER 1) + set(MPI_EXTRA_LIBRARY_WORK "${MPI_LIBRARIES}") + list(REMOVE_AT MPI_EXTRA_LIBRARY_WORK 0) + set(MPI_EXTRA_LIBRARY "${MPI_EXTRA_LIBRARY_WORK}") + unset(MPI_EXTRA_LIBRARY_WORK) +else() + set(MPI_EXTRA_LIBRARY "MPI_EXTRA_LIBRARY-NOTFOUND") +endif() +set(MPI_IGNORE_LEGACY_VARIABLES TRUE) +#============================================================================= + +# unset these vars to cleanup namespace +unset(_MPI_OLD_VARS) +unset(_MPI_PREFIX_PATH) +unset(_MPI_BASE_DIR) +foreach (lang C CXX Fortran) + unset(_MPI_${LANG}_COMPILER_NAMES) +endforeach() + +cmake_policy(POP) diff --git a/cmake/Modules/NewCMake/FindMPI/fortranparam_mpi.f90.in b/cmake/Modules/NewCMake/FindMPI/fortranparam_mpi.f90.in new file mode 100644 index 000000000..30f912c62 --- /dev/null +++ b/cmake/Modules/NewCMake/FindMPI/fortranparam_mpi.f90.in @@ -0,0 +1,4 @@ + program mpi_ver + @MPI_Fortran_INCLUDE_LINE@ + print *, 'INFO:SUBARRAYS[', MPI_SUBARRAYS_SUPPORTED, ']-ASYNCPROT[', MPI_ASYNC_PROTECTS_NONBLOCKING, ']' + end program mpi_ver diff --git a/cmake/Modules/NewCMake/FindMPI/libver_mpi.c b/cmake/Modules/NewCMake/FindMPI/libver_mpi.c new file mode 100644 index 000000000..be9d19d43 --- /dev/null +++ b/cmake/Modules/NewCMake/FindMPI/libver_mpi.c @@ -0,0 +1,19 @@ +#include + +#ifdef __cplusplus +#include +#else +#include +#endif + +int main(int argc, char* argv[]) +{ + char mpilibver_str[MPI_MAX_LIBRARY_VERSION_STRING]; + int mpilibver_len; + MPI_Get_library_version(mpilibver_str, &mpilibver_len); +#ifdef __cplusplus + std::puts(mpilibver_str); +#else + puts(mpilibver_str); +#endif +} diff --git a/cmake/Modules/NewCMake/FindMPI/libver_mpi.f90.in b/cmake/Modules/NewCMake/FindMPI/libver_mpi.f90.in new file mode 100644 index 000000000..793858716 --- /dev/null +++ b/cmake/Modules/NewCMake/FindMPI/libver_mpi.f90.in @@ -0,0 +1,7 @@ + program mpi_ver + @MPI_Fortran_INCLUDE_LINE@ + character(len=MPI_MAX_LIBRARY_VERSION_STRING) :: mpilibver_str + integer(kind=MPI_INTEGER_KIND) :: ierror, reslen + call MPI_GET_LIBRARY_VERSION(mpilibver_str, reslen, ierror) + print *, mpilibver_str + end program mpi_ver diff --git a/cmake/Modules/NewCMake/FindMPI/mpiver.f90.in b/cmake/Modules/NewCMake/FindMPI/mpiver.f90.in new file mode 100644 index 000000000..a25452385 --- /dev/null +++ b/cmake/Modules/NewCMake/FindMPI/mpiver.f90.in @@ -0,0 +1,10 @@ + program mpi_ver + @MPI_Fortran_INCLUDE_LINE@ + integer(kind=kind(MPI_VERSION)), parameter :: zero = ichar('0') + character, dimension(17), parameter :: mpiver_str =& + (/ 'I', 'N', 'F', 'O', ':', 'M', 'P', 'I', '-', 'V', 'E', 'R', '[', & + char(zero + MPI_VERSION), & + '.', & + char(zero + MPI_SUBVERSION), ']' /) + print *, mpiver_str + end program mpi_ver diff --git a/cmake/Modules/NewCMake/FindMPI/test_mpi.c b/cmake/Modules/NewCMake/FindMPI/test_mpi.c new file mode 100644 index 000000000..b8a308a4b --- /dev/null +++ b/cmake/Modules/NewCMake/FindMPI/test_mpi.c @@ -0,0 +1,37 @@ +#include + +#ifdef __cplusplus +#include +#else +#include +#endif + +#if defined(MPI_VERSION) && defined(MPI_SUBVERSION) +const char mpiver_str[] = { 'I', 'N', + 'F', 'O', + ':', 'M', + 'P', 'I', + '-', 'V', + 'E', 'R', + '[', ('0' + MPI_VERSION), + '.', ('0' + MPI_SUBVERSION), + ']', '\0' }; +#endif + +int main(int argc, char* argv[]) +{ +#if defined(MPI_VERSION) && defined(MPI_SUBVERSION) +#ifdef __cplusplus + std::puts(mpiver_str); +#else + puts(mpiver_str); +#endif +#endif +#ifdef TEST_MPI_MPICXX + MPI::MPI_Init(&argc, &argv); + MPI::MPI_Finalize(); +#else + MPI_Init(&argc, &argv); + MPI_Finalize(); +#endif +} diff --git a/cmake/Modules/NewCMake/FindMPI/test_mpi.f90.in b/cmake/Modules/NewCMake/FindMPI/test_mpi.f90.in new file mode 100644 index 000000000..4d43a04d6 --- /dev/null +++ b/cmake/Modules/NewCMake/FindMPI/test_mpi.f90.in @@ -0,0 +1,6 @@ + program hello + @MPI_Fortran_INCLUDE_LINE@ + integer@MPI_Fortran_INTEGER_LINE@ ierror + call MPI_INIT(ierror) + call MPI_FINALIZE(ierror) + end program diff --git a/cmake/Modules/NewCMake/FindPackageHandleStandardArgs.cmake b/cmake/Modules/NewCMake/FindPackageHandleStandardArgs.cmake new file mode 100644 index 000000000..67f6bd6f2 --- /dev/null +++ b/cmake/Modules/NewCMake/FindPackageHandleStandardArgs.cmake @@ -0,0 +1,386 @@ +# Distributed under the OSI-approved BSD 3-Clause License. See accompanying +# file Copyright.txt or https://cmake.org/licensing for details. + +#[=======================================================================[.rst: +FindPackageHandleStandardArgs +----------------------------- + +This module provides a function intended to be used in :ref:`Find Modules` +implementing :command:`find_package()` calls. It handles the +``REQUIRED``, ``QUIET`` and version-related arguments of ``find_package``. +It also sets the ``_FOUND`` variable. The package is +considered found if all variables listed contain valid results, e.g. +valid filepaths. + +.. command:: find_package_handle_standard_args + + There are two signatures:: + + find_package_handle_standard_args( + (DEFAULT_MSG|) + ... + ) + + find_package_handle_standard_args( + [FOUND_VAR ] + [REQUIRED_VARS ...] + [VERSION_VAR ] + [HANDLE_COMPONENTS] + [CONFIG_MODE] + [FAIL_MESSAGE ] + ) + + The ``_FOUND`` variable will be set to ``TRUE`` if all + the variables ``...`` are valid and any optional + constraints are satisfied, and ``FALSE`` otherwise. A success or + failure message may be displayed based on the results and on + whether the ``REQUIRED`` and/or ``QUIET`` option was given to + the :command:`find_package` call. + + The options are: + + ``(DEFAULT_MSG|)`` + In the simple signature this specifies the failure message. + Use ``DEFAULT_MSG`` to ask for a default message to be computed + (recommended). Not valid in the full signature. + + ``FOUND_VAR `` + Obsolete. Specifies either ``_FOUND`` or + ``_FOUND`` as the result variable. This exists only + for compatibility with older versions of CMake and is now ignored. + Result variables of both names are always set for compatibility. + + ``REQUIRED_VARS ...`` + Specify the variables which are required for this package. + These may be named in the generated failure message asking the + user to set the missing variable values. Therefore these should + typically be cache entries such as ``FOO_LIBRARY`` and not output + variables like ``FOO_LIBRARIES``. + + ``VERSION_VAR `` + Specify the name of a variable that holds the version of the package + that has been found. This version will be checked against the + (potentially) specified required version given to the + :command:`find_package` call, including its ``EXACT`` option. + The default messages include information about the required + version and the version which has been actually found, both + if the version is ok or not. + + ``HANDLE_COMPONENTS`` + Enable handling of package components. In this case, the command + will report which components have been found and which are missing, + and the ``_FOUND`` variable will be set to ``FALSE`` + if any of the required components (i.e. not the ones listed after + the ``OPTIONAL_COMPONENTS`` option of :command:`find_package`) are + missing. + + ``CONFIG_MODE`` + Specify that the calling find module is a wrapper around a + call to ``find_package( NO_MODULE)``. This implies + a ``VERSION_VAR`` value of ``_VERSION``. The command + will automatically check whether the package configuration file + was found. + + ``FAIL_MESSAGE `` + Specify a custom failure message instead of using the default + generated message. Not recommended. + +Example for the simple signature: + +.. code-block:: cmake + + find_package_handle_standard_args(LibXml2 DEFAULT_MSG + LIBXML2_LIBRARY LIBXML2_INCLUDE_DIR) + +The ``LibXml2`` package is considered to be found if both +``LIBXML2_LIBRARY`` and ``LIBXML2_INCLUDE_DIR`` are valid. +Then also ``LibXml2_FOUND`` is set to ``TRUE``. If it is not found +and ``REQUIRED`` was used, it fails with a +:command:`message(FATAL_ERROR)`, independent whether ``QUIET`` was +used or not. If it is found, success will be reported, including +the content of the first ````. On repeated CMake runs, +the same message will not be printed again. + +Example for the full signature: + +.. code-block:: cmake + + find_package_handle_standard_args(LibArchive + REQUIRED_VARS LibArchive_LIBRARY LibArchive_INCLUDE_DIR + VERSION_VAR LibArchive_VERSION) + +In this case, the ``LibArchive`` package is considered to be found if +both ``LibArchive_LIBRARY`` and ``LibArchive_INCLUDE_DIR`` are valid. +Also the version of ``LibArchive`` will be checked by using the version +contained in ``LibArchive_VERSION``. Since no ``FAIL_MESSAGE`` is given, +the default messages will be printed. + +Another example for the full signature: + +.. code-block:: cmake + + find_package(Automoc4 QUIET NO_MODULE HINTS /opt/automoc4) + find_package_handle_standard_args(Automoc4 CONFIG_MODE) + +In this case, a ``FindAutmoc4.cmake`` module wraps a call to +``find_package(Automoc4 NO_MODULE)`` and adds an additional search +directory for ``automoc4``. Then the call to +``find_package_handle_standard_args`` produces a proper success/failure +message. +#]=======================================================================] + +include(${CMAKE_CURRENT_LIST_DIR}/FindPackageMessage.cmake) + +# internal helper macro +macro(_FPHSA_FAILURE_MESSAGE _msg) + if (${_NAME}_FIND_REQUIRED) + message(FATAL_ERROR "${_msg}") + else () + if (NOT ${_NAME}_FIND_QUIETLY) + message(STATUS "${_msg}") + endif () + endif () +endmacro() + + +# internal helper macro to generate the failure message when used in CONFIG_MODE: +macro(_FPHSA_HANDLE_FAILURE_CONFIG_MODE) + # _CONFIG is set, but FOUND is false, this means that some other of the REQUIRED_VARS was not found: + if(${_NAME}_CONFIG) + _FPHSA_FAILURE_MESSAGE("${FPHSA_FAIL_MESSAGE}: missing:${MISSING_VARS} (found ${${_NAME}_CONFIG} ${VERSION_MSG})") + else() + # If _CONSIDERED_CONFIGS is set, the config-file has been found, but no suitable version. + # List them all in the error message: + if(${_NAME}_CONSIDERED_CONFIGS) + set(configsText "") + list(LENGTH ${_NAME}_CONSIDERED_CONFIGS configsCount) + math(EXPR configsCount "${configsCount} - 1") + foreach(currentConfigIndex RANGE ${configsCount}) + list(GET ${_NAME}_CONSIDERED_CONFIGS ${currentConfigIndex} filename) + list(GET ${_NAME}_CONSIDERED_VERSIONS ${currentConfigIndex} version) + string(APPEND configsText " ${filename} (version ${version})\n") + endforeach() + if (${_NAME}_NOT_FOUND_MESSAGE) + string(APPEND configsText " Reason given by package: ${${_NAME}_NOT_FOUND_MESSAGE}\n") + endif() + _FPHSA_FAILURE_MESSAGE("${FPHSA_FAIL_MESSAGE} ${VERSION_MSG}, checked the following files:\n${configsText}") + + else() + # Simple case: No Config-file was found at all: + _FPHSA_FAILURE_MESSAGE("${FPHSA_FAIL_MESSAGE}: found neither ${_NAME}Config.cmake nor ${_NAME_LOWER}-config.cmake ${VERSION_MSG}") + endif() + endif() +endmacro() + + +function(FIND_PACKAGE_HANDLE_STANDARD_ARGS _NAME _FIRST_ARG) + +# Set up the arguments for `cmake_parse_arguments`. + set(options CONFIG_MODE HANDLE_COMPONENTS) + set(oneValueArgs FAIL_MESSAGE VERSION_VAR FOUND_VAR) + set(multiValueArgs REQUIRED_VARS) + +# Check whether we are in 'simple' or 'extended' mode: + set(_KEYWORDS_FOR_EXTENDED_MODE ${options} ${oneValueArgs} ${multiValueArgs} ) + list(FIND _KEYWORDS_FOR_EXTENDED_MODE "${_FIRST_ARG}" INDEX) + + if(${INDEX} EQUAL -1) + set(FPHSA_FAIL_MESSAGE ${_FIRST_ARG}) + set(FPHSA_REQUIRED_VARS ${ARGN}) + set(FPHSA_VERSION_VAR) + else() + cmake_parse_arguments(FPHSA "${options}" "${oneValueArgs}" "${multiValueArgs}" ${_FIRST_ARG} ${ARGN}) + + if(FPHSA_UNPARSED_ARGUMENTS) + message(FATAL_ERROR "Unknown keywords given to FIND_PACKAGE_HANDLE_STANDARD_ARGS(): \"${FPHSA_UNPARSED_ARGUMENTS}\"") + endif() + + if(NOT FPHSA_FAIL_MESSAGE) + set(FPHSA_FAIL_MESSAGE "DEFAULT_MSG") + endif() + + # In config-mode, we rely on the variable _CONFIG, which is set by find_package() + # when it successfully found the config-file, including version checking: + if(FPHSA_CONFIG_MODE) + list(INSERT FPHSA_REQUIRED_VARS 0 ${_NAME}_CONFIG) + list(REMOVE_DUPLICATES FPHSA_REQUIRED_VARS) + set(FPHSA_VERSION_VAR ${_NAME}_VERSION) + endif() + + if(NOT FPHSA_REQUIRED_VARS) + message(FATAL_ERROR "No REQUIRED_VARS specified for FIND_PACKAGE_HANDLE_STANDARD_ARGS()") + endif() + endif() + +# now that we collected all arguments, process them + + if("x${FPHSA_FAIL_MESSAGE}" STREQUAL "xDEFAULT_MSG") + set(FPHSA_FAIL_MESSAGE "Could NOT find ${_NAME}") + endif() + + list(GET FPHSA_REQUIRED_VARS 0 _FIRST_REQUIRED_VAR) + + string(TOUPPER ${_NAME} _NAME_UPPER) + string(TOLOWER ${_NAME} _NAME_LOWER) + + if(FPHSA_FOUND_VAR) + if(FPHSA_FOUND_VAR MATCHES "^${_NAME}_FOUND$" OR FPHSA_FOUND_VAR MATCHES "^${_NAME_UPPER}_FOUND$") + set(_FOUND_VAR ${FPHSA_FOUND_VAR}) + else() + message(FATAL_ERROR "The argument for FOUND_VAR is \"${FPHSA_FOUND_VAR}\", but only \"${_NAME}_FOUND\" and \"${_NAME_UPPER}_FOUND\" are valid names.") + endif() + else() + set(_FOUND_VAR ${_NAME_UPPER}_FOUND) + endif() + + # collect all variables which were not found, so they can be printed, so the + # user knows better what went wrong (#6375) + set(MISSING_VARS "") + set(DETAILS "") + # check if all passed variables are valid + set(FPHSA_FOUND_${_NAME} TRUE) + foreach(_CURRENT_VAR ${FPHSA_REQUIRED_VARS}) + if(NOT ${_CURRENT_VAR}) + set(FPHSA_FOUND_${_NAME} FALSE) + string(APPEND MISSING_VARS " ${_CURRENT_VAR}") + else() + string(APPEND DETAILS "[${${_CURRENT_VAR}}]") + endif() + endforeach() + if(FPHSA_FOUND_${_NAME}) + set(${_NAME}_FOUND TRUE) + set(${_NAME_UPPER}_FOUND TRUE) + else() + set(${_NAME}_FOUND FALSE) + set(${_NAME_UPPER}_FOUND FALSE) + endif() + + # component handling + unset(FOUND_COMPONENTS_MSG) + unset(MISSING_COMPONENTS_MSG) + + if(FPHSA_HANDLE_COMPONENTS) + foreach(comp ${${_NAME}_FIND_COMPONENTS}) + if(${_NAME}_${comp}_FOUND) + + if(NOT DEFINED FOUND_COMPONENTS_MSG) + set(FOUND_COMPONENTS_MSG "found components: ") + endif() + string(APPEND FOUND_COMPONENTS_MSG " ${comp}") + + else() + + if(NOT DEFINED MISSING_COMPONENTS_MSG) + set(MISSING_COMPONENTS_MSG "missing components: ") + endif() + string(APPEND MISSING_COMPONENTS_MSG " ${comp}") + + if(${_NAME}_FIND_REQUIRED_${comp}) + set(${_NAME}_FOUND FALSE) + string(APPEND MISSING_VARS " ${comp}") + endif() + + endif() + endforeach() + set(COMPONENT_MSG "${FOUND_COMPONENTS_MSG} ${MISSING_COMPONENTS_MSG}") + string(APPEND DETAILS "[c${COMPONENT_MSG}]") + endif() + + # version handling: + set(VERSION_MSG "") + set(VERSION_OK TRUE) + + # check with DEFINED here as the requested or found version may be "0" + if (DEFINED ${_NAME}_FIND_VERSION) + if(DEFINED ${FPHSA_VERSION_VAR}) + set(_FOUND_VERSION ${${FPHSA_VERSION_VAR}}) + + if(${_NAME}_FIND_VERSION_EXACT) # exact version required + # count the dots in the version string + string(REGEX REPLACE "[^.]" "" _VERSION_DOTS "${_FOUND_VERSION}") + # add one dot because there is one dot more than there are components + string(LENGTH "${_VERSION_DOTS}." _VERSION_DOTS) + if (_VERSION_DOTS GREATER ${_NAME}_FIND_VERSION_COUNT) + # Because of the C++ implementation of find_package() ${_NAME}_FIND_VERSION_COUNT + # is at most 4 here. Therefore a simple lookup table is used. + if (${_NAME}_FIND_VERSION_COUNT EQUAL 1) + set(_VERSION_REGEX "[^.]*") + elseif (${_NAME}_FIND_VERSION_COUNT EQUAL 2) + set(_VERSION_REGEX "[^.]*\\.[^.]*") + elseif (${_NAME}_FIND_VERSION_COUNT EQUAL 3) + set(_VERSION_REGEX "[^.]*\\.[^.]*\\.[^.]*") + else () + set(_VERSION_REGEX "[^.]*\\.[^.]*\\.[^.]*\\.[^.]*") + endif () + string(REGEX REPLACE "^(${_VERSION_REGEX})\\..*" "\\1" _VERSION_HEAD "${_FOUND_VERSION}") + unset(_VERSION_REGEX) + if (NOT ${_NAME}_FIND_VERSION VERSION_EQUAL _VERSION_HEAD) + set(VERSION_MSG "Found unsuitable version \"${_FOUND_VERSION}\", but required is exact version \"${${_NAME}_FIND_VERSION}\"") + set(VERSION_OK FALSE) + else () + set(VERSION_MSG "(found suitable exact version \"${_FOUND_VERSION}\")") + endif () + unset(_VERSION_HEAD) + else () + if (NOT ${_NAME}_FIND_VERSION VERSION_EQUAL _FOUND_VERSION) + set(VERSION_MSG "Found unsuitable version \"${_FOUND_VERSION}\", but required is exact version \"${${_NAME}_FIND_VERSION}\"") + set(VERSION_OK FALSE) + else () + set(VERSION_MSG "(found suitable exact version \"${_FOUND_VERSION}\")") + endif () + endif () + unset(_VERSION_DOTS) + + else() # minimum version specified: + if (${_NAME}_FIND_VERSION VERSION_GREATER _FOUND_VERSION) + set(VERSION_MSG "Found unsuitable version \"${_FOUND_VERSION}\", but required is at least \"${${_NAME}_FIND_VERSION}\"") + set(VERSION_OK FALSE) + else () + set(VERSION_MSG "(found suitable version \"${_FOUND_VERSION}\", minimum required is \"${${_NAME}_FIND_VERSION}\")") + endif () + endif() + + else() + + # if the package was not found, but a version was given, add that to the output: + if(${_NAME}_FIND_VERSION_EXACT) + set(VERSION_MSG "(Required is exact version \"${${_NAME}_FIND_VERSION}\")") + else() + set(VERSION_MSG "(Required is at least version \"${${_NAME}_FIND_VERSION}\")") + endif() + + endif() + else () + # Check with DEFINED as the found version may be 0. + if(DEFINED ${FPHSA_VERSION_VAR}) + set(VERSION_MSG "(found version \"${${FPHSA_VERSION_VAR}}\")") + endif() + endif () + + if(VERSION_OK) + string(APPEND DETAILS "[v${${FPHSA_VERSION_VAR}}(${${_NAME}_FIND_VERSION})]") + else() + set(${_NAME}_FOUND FALSE) + endif() + + + # print the result: + if (${_NAME}_FOUND) + FIND_PACKAGE_MESSAGE(${_NAME} "Found ${_NAME}: ${${_FIRST_REQUIRED_VAR}} ${VERSION_MSG} ${COMPONENT_MSG}" "${DETAILS}") + else () + + if(FPHSA_CONFIG_MODE) + _FPHSA_HANDLE_FAILURE_CONFIG_MODE() + else() + if(NOT VERSION_OK) + _FPHSA_FAILURE_MESSAGE("${FPHSA_FAIL_MESSAGE}: ${VERSION_MSG} (found ${${_FIRST_REQUIRED_VAR}})") + else() + _FPHSA_FAILURE_MESSAGE("${FPHSA_FAIL_MESSAGE} (missing:${MISSING_VARS}) ${VERSION_MSG}") + endif() + endif() + + endif () + + set(${_NAME}_FOUND ${${_NAME}_FOUND} PARENT_SCOPE) + set(${_NAME_UPPER}_FOUND ${${_NAME}_FOUND} PARENT_SCOPE) +endfunction() diff --git a/cmake/Modules/NewCMake/FindPackageMessage.cmake b/cmake/Modules/NewCMake/FindPackageMessage.cmake new file mode 100644 index 000000000..6821cee4f --- /dev/null +++ b/cmake/Modules/NewCMake/FindPackageMessage.cmake @@ -0,0 +1,47 @@ +# Distributed under the OSI-approved BSD 3-Clause License. See accompanying +# file Copyright.txt or https://cmake.org/licensing for details. + +#.rst: +# FindPackageMessage +# ------------------ +# +# +# +# FIND_PACKAGE_MESSAGE( "message for user" "find result details") +# +# This macro is intended to be used in FindXXX.cmake modules files. It +# will print a message once for each unique find result. This is useful +# for telling the user where a package was found. The first argument +# specifies the name (XXX) of the package. The second argument +# specifies the message to display. The third argument lists details +# about the find result so that if they change the message will be +# displayed again. The macro also obeys the QUIET argument to the +# find_package command. +# +# Example: +# +# :: +# +# if(X11_FOUND) +# FIND_PACKAGE_MESSAGE(X11 "Found X11: ${X11_X11_LIB}" +# "[${X11_X11_LIB}][${X11_INCLUDE_DIR}]") +# else() +# ... +# endif() + +function(FIND_PACKAGE_MESSAGE pkg msg details) + # Avoid printing a message repeatedly for the same find result. + if(NOT ${pkg}_FIND_QUIETLY) + string(REPLACE "\n" "" details "${details}") + set(DETAILS_VAR FIND_PACKAGE_MESSAGE_DETAILS_${pkg}) + if(NOT "${details}" STREQUAL "${${DETAILS_VAR}}") + # The message has not yet been printed. + message(STATUS "${msg}") + + # Save the find details in the cache to avoid printing the same + # message again. + set("${DETAILS_VAR}" "${details}" + CACHE INTERNAL "Details about finding ${pkg}") + endif() + endif() +endfunction() diff --git a/cmake/Modules/NewCMake/SelectLibraryConfigurations.cmake b/cmake/Modules/NewCMake/SelectLibraryConfigurations.cmake new file mode 100644 index 000000000..dce6f9926 --- /dev/null +++ b/cmake/Modules/NewCMake/SelectLibraryConfigurations.cmake @@ -0,0 +1,70 @@ +# Distributed under the OSI-approved BSD 3-Clause License. See accompanying +# file Copyright.txt or https://cmake.org/licensing for details. + +#.rst: +# SelectLibraryConfigurations +# --------------------------- +# +# +# +# select_library_configurations( basename ) +# +# This macro takes a library base name as an argument, and will choose +# good values for basename_LIBRARY, basename_LIBRARIES, +# basename_LIBRARY_DEBUG, and basename_LIBRARY_RELEASE depending on what +# has been found and set. If only basename_LIBRARY_RELEASE is defined, +# basename_LIBRARY will be set to the release value, and +# basename_LIBRARY_DEBUG will be set to basename_LIBRARY_DEBUG-NOTFOUND. +# If only basename_LIBRARY_DEBUG is defined, then basename_LIBRARY will +# take the debug value, and basename_LIBRARY_RELEASE will be set to +# basename_LIBRARY_RELEASE-NOTFOUND. +# +# If the generator supports configuration types, then basename_LIBRARY +# and basename_LIBRARIES will be set with debug and optimized flags +# specifying the library to be used for the given configuration. If no +# build type has been set or the generator in use does not support +# configuration types, then basename_LIBRARY and basename_LIBRARIES will +# take only the release value, or the debug value if the release one is +# not set. + +# This macro was adapted from the FindQt4 CMake module and is maintained by Will +# Dicharry . + +macro( select_library_configurations basename ) + if(NOT ${basename}_LIBRARY_RELEASE) + set(${basename}_LIBRARY_RELEASE "${basename}_LIBRARY_RELEASE-NOTFOUND" CACHE FILEPATH "Path to a library.") + endif() + if(NOT ${basename}_LIBRARY_DEBUG) + set(${basename}_LIBRARY_DEBUG "${basename}_LIBRARY_DEBUG-NOTFOUND" CACHE FILEPATH "Path to a library.") + endif() + + if( ${basename}_LIBRARY_DEBUG AND ${basename}_LIBRARY_RELEASE AND + NOT ${basename}_LIBRARY_DEBUG STREQUAL ${basename}_LIBRARY_RELEASE AND + ( CMAKE_CONFIGURATION_TYPES OR CMAKE_BUILD_TYPE ) ) + # if the generator supports configuration types or CMAKE_BUILD_TYPE + # is set, then set optimized and debug options. + set( ${basename}_LIBRARY "" ) + foreach( _libname IN LISTS ${basename}_LIBRARY_RELEASE ) + list( APPEND ${basename}_LIBRARY optimized "${_libname}" ) + endforeach() + foreach( _libname IN LISTS ${basename}_LIBRARY_DEBUG ) + list( APPEND ${basename}_LIBRARY debug "${_libname}" ) + endforeach() + elseif( ${basename}_LIBRARY_RELEASE ) + set( ${basename}_LIBRARY ${${basename}_LIBRARY_RELEASE} ) + elseif( ${basename}_LIBRARY_DEBUG ) + set( ${basename}_LIBRARY ${${basename}_LIBRARY_DEBUG} ) + else() + set( ${basename}_LIBRARY "${basename}_LIBRARY-NOTFOUND") + endif() + + set( ${basename}_LIBRARIES "${${basename}_LIBRARY}" ) + + if( ${basename}_LIBRARY ) + set( ${basename}_FOUND TRUE ) + endif() + + mark_as_advanced( ${basename}_LIBRARY_RELEASE + ${basename}_LIBRARY_DEBUG + ) +endmacro() diff --git a/cmake/Modules/findHelpers.cmake b/cmake/Modules/findHelpers.cmake new file mode 100644 index 000000000..028957a0a --- /dev/null +++ b/cmake/Modules/findHelpers.cmake @@ -0,0 +1,173 @@ +function (findSrc varName version varDir ) + if(EXISTS ${CMAKE_SOURCE_DIR}/libsrc/${varName}) + message("setting source for ${varName} to be in libsrc") + set( ${varDir} "${CMAKE_SOURCE_DIR}/libsrc/${varName}" PARENT_SCOPE) + set( ${varCacheName} "${CMAKE_SOURCE_DIR}/libsrc/${varName}" CACHE STRING "" FORCE ) + else() + set(searchName ${varName}_v${${version}}) + message("searching for source for ${searchName} in ${CRTM_BASE}") + string( TOLOWER ${varName} varNameLower ) + find_path( TMP_DIR + NAMES ${searchName} + HINTS + ${CMAKE_SOURCE_DIR}/../libs + ${CRTM_BASE}/${version} + ${CRTM_BASE}/${varName} + ${CRTM_BASE}/${varName}/${version} + ${CRTM_BASE}/${varNameLower} + ${CRTM_BASE}/${varNameLower}/${version} + ${COREPATH}/sorc + $ENV{${varDir}}/libsrc + $ENV{${varDir}}/lib/sorc + $ENV{CORPATH}/lib/sorc + ${CMAKE_SOURCE_DIR}/libsrc/${varName} + ) + if( NOT TMP_DIR ) + message("didn't find directory") + set(secondSearchName v${${version}}) + find_path( TMP2_DIR + NAMES ${secondSearchName} + HINTS + ${CRTM_BASE}/${varName} + ) + endif() + set( varCacheName "${varDir}_SRC" ) + file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/*.f*" "${TMP_DIR}/${varName}_v${${version}}/*.F*") + if( f_FILES ) + set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}" PARENT_SCOPE) + set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}" CACHE STRING "" FORCE ) + else() + file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/src/*.f*" "${TMP_DIR}/${varName}_v${${version}}/src/*.F*") + if( f_FILES ) + set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}/src" PARENT_SCOPE) + set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}/src" CACHE STRING "" FORCE ) + else() + file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/libsrc/*.f*" "${TMP_DIR}/${varName}_v${${version}}/src/*.F*") + if( f_FILES ) + set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}/libsrc" PARENT_SCOPE) + set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}/libsrc" CACHE STRING "" FORCE ) + else() + file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/sorc/*.f*" "${TMP_DIR}/${varName}_v${${version}}/sorc/*.F*") + if( f_FILES ) + set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}/sorc" PARENT_SCOPE) + set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}/sorc" CACHE STRING "" FORCE ) + else() + file(GLOB f_FILES "${TMP_DIR}/${varName}_v${${version}}/sorc/libsrc/*.f*" + "${TMP_DIR}/${varName}_v${${version}}/sorc/libsrc/*.F*") + if( f_FILES ) + set( ${varDir} "${TMP_DIR}/${varName}_v${${version}}/sorc/libsrc" PARENT_SCOPE) + set( ${varCacheName} "${TMP_DIR}/${varName}_v${${version}}/sorc/libsrc" CACHE STRING "" FORCE ) + else() + file(GLOB f_FILES "${TMP2_DIR}/v${${version}}/src/*.f*" + "${TMP_DIR}/v${${version}}/src/*.F*") + if( f_FILES ) + set( ${varDir} "${TMP2_DIR}/v${${version}}/src" PARENT_SCOPE) + set( ${varCacheName} "${TMP2_DIR}/v${${version}}/src" CACHE STRING "" FORCE ) + endif() + endif() + endif() + endif() + endif() + endif() + if( NOT f_FILES ) # look for source that is of a different version + message("WARNING: Did not find ${${version}} of ${varName}, looking for alternates") + findOtherVersion( TMP_DIR ${varName} srcPath ${version} ) + file(GLOB f_FILES "${srcPath}/*.f*" "${srcPath}/*.F*") + if( f_FILES ) + set( ${varDir} "${srcPath}" PARENT_SCOPE) + set( ${varCacheName} "${srcPath}" CACHE STRING "" FORCE ) + else() + file(GLOB f_FILES "${srcPath}/src/*.f*" "${srcPath}/src/*.F*") + if( f_FILES ) + set( ${varDir} "${srcPath}/src" PARENT_SCOPE) + set( ${varCacheName} "${srcPath}/src" CACHE STRING "" FORCE ) + else() + file(GLOB f_FILES "${srcPath}/libsrc/*.f*" "${srcPath}/src/*.F*") + if( f_FILES ) + set( ${varDir} "${srcPath}/libsrc" PARENT_SCOPE) + set( ${varCacheName} "${srcPath}/libsrc" CACHE STRING "" FORCE ) + else() + file(GLOB f_FILES "${srcPath}/sorc/*.f*" "${srcPath}/sorc/*.F*") + if( f_FILES ) + set( ${varDir} "${srcPath}/sorc" PARENT_SCOPE) + set( ${varCacheName} "${srcPath}/sorc" CACHE STRING "" FORCE ) + else() + file(GLOB f_FILES "${srcPath}/sorc/libsrc/*.f*" + "${srcPath}/sorc/libsrc/*.F*") + if( f_FILES ) + set( ${varDir} "${srcPath}/sorc/libsrc" PARENT_SCOPE) + set( ${varCacheName} "${srcPath}/sorc/libsrc" CACHE STRING "" FORCE ) + endif() + endif() + endif() + endif() + endif() + endif() + endif() +endfunction() + +function (findInc incName version incFile ) + cmake_policy(SET CMP0011 NEW) + cmake_policy(SET CMP0009 NEW) + STRING(COMPARE EQUAL ${incFile} "CRTMINC" USECRTMBASE ) + if(( USECRTMBASE ) AND ( CRTM_BASE )) + execute_process(COMMAND find ${CRTM_BASE} -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) +# file(GLOB_RECURSE INCFILES ${CRTM_BASE}/*${CRTM_VER}*/*mod ) +# file(GLOB_RECURSE INCFILES2 ${CRTM_BASE}/crtm/*${CRTM_VER}*/*/*mod ) +# list(APPEND INCFILES ${INCFILES2} ) + else() + if(crayComp) + if(CMAKE_CXX_COMPILER_ID STREQUAL "Intel") + execute_process(COMMAND find ${COREPATH}/${incName}/v${${version}}/intel -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) + else() + execute_process(COMMAND find ${COREPATH}/${incName}/v${${version}}/cray -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) + endif() + else() + execute_process(COMMAND find ${COREPATH}/${incName} -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) + endif() + if( NOT (INCFILES) ) + execute_process(COMMAND find ${COREPATH}/sorc -iname ${incName}_module.mod RESULT_VARIABLE res OUTPUT_VARIABLE INCFILES) + endif() + endif() +# message("incfiles are ${INCFILES}") + if( INCFILES ) + string(REGEX REPLACE "\n" ";" INCFILES ${INCFILES} ) + endif() + foreach( INC_FILE in ${INCFILES} ) + string(REGEX MATCH ${${version}} MATCHFOUND ${INC_FILE} ) +# message("matchfound is ${MATCHFOUND}, version is ${${version}} for ${INC_FILE}") + if( MATCHFOUND ) + message("found ${INC_FILE}") + string(REGEX REPLACE "${incName}_module.mod" "" INCPATH ${INC_FILE} ) + set( ${incFile} ${INCPATH} PARENT_SCOPE ) + return() + endif() + endforeach() + file(GLOB_RECURSE INCFILES ${COREPATH}/${incName}_module.mod ) + list(LENGTH INCFILES numFiles) + if(numFiles EQUAL 1) + get_filename_component( INCPATH ${INCFILES} DIRECTORY ) + else() + foreach( INC_FILE in ${INCFILES} ) + get_filename_component( INCPATH ${INC_FILE} DIRECTORY ) +# message("WARNING: Did not find explicit version ${${version}} of ${incName} module, using un-versioned path") +# set( ${incFile} ${INCPATH} PARENT_SCOPE ) +# return() + endforeach() + endif() + set( ${incFile} ${INCPATH} PARENT_SCOPE ) +endfunction() + +function (findOtherVersion rootPath srcName srcPath newVer ) + file(GLOB SRCDIRS ${${rootPath}}/${srcName}* ) + foreach( SRC_DIR in ${SRCDIRS} ) + string(REGEX MATCH ${srcName} MATCHFOUND ${SRC_DIR} ) + if( MATCHFOUND ) + set( ${srcPath} ${SRC_DIR} PARENT_SCOPE ) + string(REGEX MATCH "[0-9].[0-9].[0-9]" ALTVER ${SRC_DIR} ) + message("Found ${ALTVER} of ${srcName}. Proceeding with Alternative") + set( ${newVer} ${ALTVER} PARENT_SCOPE ) + return() + endif() + endforeach() +endfunction() diff --git a/cmake/Modules/platforms/Cheyenne.cmake b/cmake/Modules/platforms/Cheyenne.cmake new file mode 100644 index 000000000..764a2bffa --- /dev/null +++ b/cmake/Modules/platforms/Cheyenne.cmake @@ -0,0 +1,24 @@ +macro (setCheyenne) + message("Setting paths for Cheyenne") + option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5_HL "Try to Find HDF5 libraries" OFF) + + set(HOST_FLAG "-xHOST" CACHE INTERNAL "Host Flag") + set(MKL_FLAG "-mkl" CACHE INTERNAL "MKL Flag") + set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "GSI Fortran Flags") + set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${MPI3FLAG} ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") + + set(BUILD_CORELIBS "ON" ) + set(BUILD_UTIL "OFF" CACHE INTERNAL "" ) + set(BUILD_BUFR "ON" CACHE INTERNAL "") + set(BUILD_SFCIO "ON" CACHE INTERNAL "") + set(BUILD_SIGIO "ON" CACHE INTERNAL "") + set(BUILD_W3EMC "ON" CACHE INTERNAL "") + set(BUILD_W3NCO "ON" CACHE INTERNAL "") + set(BUILD_BACIO "ON" CACHE INTERNAL "") + set(BUILD_CRTM "ON" CACHE INTERNAL "") + set(BUILD_SP "ON" CACHE INTERNAL "") + set(BUILD_NEMSIO "ON" CACHE INTERNAL "") + set(ENV{MPI_HOME} $ENV{MPI_ROOT} ) +endmacro() + diff --git a/cmake/Modules/platforms/Discover.cmake b/cmake/Modules/platforms/Discover.cmake new file mode 100644 index 000000000..54429b1a6 --- /dev/null +++ b/cmake/Modules/platforms/Discover.cmake @@ -0,0 +1,55 @@ +macro (setDiscover) + message("Setting paths for Discover") +# option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) +# option(FIND_HDF5_HL "Try to Find HDF5 libraries" OFF) + set(HDF5_USE_STATIC_LIBRARIES "OFF") + + set(HOST_FLAG "-xHOST" CACHE INTERNAL "Host Flag") + set(MKL_FLAG "-mkl" CACHE INTERNAL "MKL Flag") + set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "GSI Fortran Flags") + set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${MPI3FLAG} ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") + set(host "Discover" CACHE INTERNAL "") + + set(COREPATH $ENV{COREPATH} ) + if( NOT DEFINED ENV{NETCDF_VER} ) + set(NETCDF_VER "3.6.3" ) + endif() + if( NOT DEFINED ENV{BACIO_VER} ) + set(BACIO_VER "2.0.1" ) + endif() + if( NOT DEFINED ENV{BUFR_VER} ) + set(BUFR_VER "10.2.5" ) + endif() + if( NOT DEFINED ENV{CRTM_VER} ) + set(CRTM_VER "2.2.3" ) + endif() + if( NOT DEFINED ENV{NEMSIO_VER} ) + set(NEMSIO_VER "2.2.1" ) + endif() + if( NOT DEFINED ENV{SFCIO_VER} ) + set(SFCIO_VER "1.1.0" ) + endif() + if( NOT DEFINED ENV{SIGIO_VER} ) + set(SIGIO_VER "2.0.1" ) + endif() + if( NOT DEFINED ENV{SP_VER} ) + set(SP_VER "2.0.2" ) + endif() + if( NOT DEFINED ENV{W3EMC_VER} ) + set(W3EMC_VER "2.2.0" ) + endif() + if( NOT DEFINED ENV{W3NCO_VER} ) + set(W3NCO_VER "2.0.6" ) + endif() + + if( ENV{BASEDIR} ) + set(BASEDIR $ENV{BASEDIR}/Linux CACHE INTERNAL "") + endif() + set(BUILD_CORELIBS "ON" CACHE INTERNAL "") + set(USE_WRF "OFF" CACHE INTERNAL "") + set(BUILD_GLOBAL "ON" CACHE INTERNAL "") + + set(ENV{MPI_HOME} $ENV{MPI_ROOT} ) + +endmacro() + diff --git a/cmake/Modules/platforms/Gaea.cmake b/cmake/Modules/platforms/Gaea.cmake new file mode 100644 index 000000000..d897400e6 --- /dev/null +++ b/cmake/Modules/platforms/Gaea.cmake @@ -0,0 +1,14 @@ +macro (setGaea) + + message("Setting flags and paths for Cray") + option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5_HL "Try to Find HDF5 libraries" ON) + set(HDF5_USE_STATIC_LIBRARIES "ON" CACHE INTERNAL "HDF5_Static" ) + + set(HOST_FLAG "-xCORE-AVX2" CACHE INTERNAL "Host Flag") # for Haswell (C4) + set(MKL_FLAG "-mkl" CACHE INTERNAL "MKL Flag" ) + set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -fp-model strict -assume byterecl -convert big_endian -implicitnone -D_REAL8_ -traceback ${HOST_FLAG} ${MKL_FLAG} ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS} -O3" CACHE INTERNAL "") + set(ENKF_Platform_FLAGS "-O3 -fp-model strict -convert big_endian -assume byterecl -implicitnone -DGFS -D_REAL8_ -traceback ${HOST_FLAG} ${MKL_FLAG} ${MPI3FLAG} ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "") + set(GSI_LDFLAGS "${MKL_FLAG} ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "") + set(BUILD_CORELIBS "OFF" ) +endmacro() diff --git a/cmake/Modules/platforms/Generic.cmake b/cmake/Modules/platforms/Generic.cmake new file mode 100644 index 000000000..9945c4bfd --- /dev/null +++ b/cmake/Modules/platforms/Generic.cmake @@ -0,0 +1,14 @@ +macro (setGeneric) + message("Setting paths for Generic System") + option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5_HL "Try to Find HDF5 libraries" OFF) + if(EXISTS /jetmon) + set(HOST_FLAG "" CACHE INTERNAL "Host Flag") ## default, no host_flag required + else() + set(HOST_FLAG "" CACHE INTERNAL "Host Flag") ## default, no host_flag required + endif() + set(MKL_FLAG "-mkl" CACHE INTERNAL "MKL Flag") + set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "GSI Fortran Flags") + set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${MPI3FLAG} ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") + +endmacro() diff --git a/cmake/Modules/platforms/Hera.cmake b/cmake/Modules/platforms/Hera.cmake new file mode 100644 index 000000000..9fce9a3a4 --- /dev/null +++ b/cmake/Modules/platforms/Hera.cmake @@ -0,0 +1,42 @@ +macro (setHERA) + message("Setting paths for HERA") + option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5_HL "Try to Find HDF5 libraries" OFF) + set(HOST_FLAG "-xHOST" CACHE INTERNAL "Host Flag") + set(MKL_FLAG "-mkl" CACHE INTERNAL "MKL Flag") + set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "GSI Fortran Flags") + set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${MPI3FLAG} ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") + set(HDF5_USE_STATIC_LIBRARIES "OFF") + + if( NOT DEFINED ENV{NETCDF_VER} ) + set(NETCDF_VER "3.6.3" ) + endif() + if( NOT DEFINED ENV{BACIO_VER} ) + set(BACIO_VER "2.0.1" ) + endif() + if( NOT DEFINED ENV{BUFR_VER} ) + set(BUFR_VER "10.2.5" ) + endif() + if( NOT DEFINED ENV{CRTM_VER} ) + set(CRTM_VER "2.2.3" ) + endif() + if( NOT DEFINED ENV{NEMSIO_VER} ) + set(NEMSIO_VER "2.2.1" ) + endif() + if( NOT DEFINED ENV{SFCIO_VER} ) + set(SFCIO_VER "1.0.0" ) + endif() + if( NOT DEFINED ENV{SIGIO_VER} ) + set(SIGIO_VER "2.0.1" ) + endif() + if( NOT DEFINED ENV{SP_VER} ) + set(SP_VER "2.0.2" ) + endif() + if( NOT DEFINED ENV{W3EMC_VER} ) + set(W3EMC_VER "2.0.5" ) + endif() + if( NOT DEFINED ENV{W3NCO_VER} ) + set(W3NCO_VER "2.0.6" ) + endif() +endmacro() + diff --git a/cmake/Modules/platforms/Jet.cmake b/cmake/Modules/platforms/Jet.cmake new file mode 100644 index 000000000..8c19dd06f --- /dev/null +++ b/cmake/Modules/platforms/Jet.cmake @@ -0,0 +1,10 @@ +macro (setJet) + message("Setting paths for Jet") + option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5_HL "Try to Find HDF5 libraries" OFF) + set(HOST_FLAG "-axSSE4.2,AVX,CORE-AVX2" CACHE INTERNAL "Host Flag") + set(MKL_FLAG "-mkl" CACHE INTERNAL "MKL Flag") + set(GSI_Intel_Platform_FLAGS "${HOST_FLAG} -DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "GSI Fortran Flags") + set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${MPI3FLAG} ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") +endmacro() + diff --git a/cmake/Modules/platforms/S4.cmake b/cmake/Modules/platforms/S4.cmake new file mode 100644 index 000000000..1a5fe7ec7 --- /dev/null +++ b/cmake/Modules/platforms/S4.cmake @@ -0,0 +1,10 @@ +macro (setS4) + message("Setting paths for S4") + option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5_HL "Try to Find HDF5 libraries" OFF) + set(HOST_FLAG "-xHOST" CACHE INTERNAL "Host Flag") + set(MKL_FLAG "-mkl" CACHE INTERNAL "MKL Flag") + set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "GSI Fortran Flags") + set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${MPI3FLAG} ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") + set(HDF5_USE_STATIC_LIBRARIES "OFF") +endmacro() diff --git a/cmake/Modules/platforms/WCOSS-C.cmake b/cmake/Modules/platforms/WCOSS-C.cmake new file mode 100644 index 000000000..1c9cf712c --- /dev/null +++ b/cmake/Modules/platforms/WCOSS-C.cmake @@ -0,0 +1,60 @@ +macro (setWCOSS_C) + + message("Setting flags and paths for Cray") + option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5_HL "Try to Find HDF5 libraries" ON) + set(HDF5_USE_STATIC_LIBRARIES "ON" CACHE INTERNAL "HDF5_Static" ) + + set(HOST_FLAG "-xHOST" CACHE INTERNAL "Host Flag") + set(MKL_FLAG "" CACHE INTERNAL "MKL flag" ) + set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -fp-model strict -assume byterecl -convert big_endian -implicitnone -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS} -O3" CACHE INTERNAL "") + set(ENKF_Platform_FLAGS "-O3 -fp-model strict -convert big_endian -assume byterecl -implicitnone -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "") + set(GSI_LDFLAGS "${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "") + if( NOT DEFINED ENV{COREPATH} ) + set(COREPATH "/gpfs/hps/nco/ops/nwprod/lib" ) + else() + set(COREPATH $ENV{COREPATH} ) + endif() + if( NOT DEFINED ENV{CRTM_INC} ) + set(CRTM_BASE "/gpfs/hps/nco/ops/nwprod/lib/crtm" ) + endif() + if( NOT DEFINED ENV{WRFPATH} ) + if(CMAKE_CXX_COMPILER_ID STREQUAL "Intel") + set(WRFPATH "/gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-intel" ) + else() + set(WRFPATH "/gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-cray" ) + endif() + else() + set(WRFPATH $ENV{WRFPATH} ) + endif() + if( NOT DEFINED ENV{NETCDF_VER} ) + set(NETCDF_VER "3.6.3" ) + endif() + if( NOT DEFINED ENV{BACIO_VER} ) + set(BACIO_VER "2.0.1" ) + endif() + if( NOT DEFINED ENV{BUFR_VER} ) + set(BUFR_VER "11.0.1" ) + endif() + if( NOT DEFINED ENV{CRTM_VER} ) + set(CRTM_VER "2.2.3" ) + endif() + if( NOT DEFINED ENV{NEMSIO_VER} ) + set(NEMSIO_VER "2.2.2" ) + endif() + if( NOT DEFINED ENV{SFCIO_VER} ) + set(SFCIO_VER "1.0.0" ) + endif() + if( NOT DEFINED ENV{SIGIO_VER} ) + set(SIGIO_VER "2.0.1" ) + endif() + if( NOT DEFINED ENV{SP_VER} ) + set(SP_VER "2.0.2" ) + endif() + if( NOT DEFINED ENV{W3EMC_VER} ) + set(W3EMC_VER "2.2.0" ) + endif() + if( NOT DEFINED ENV{W3NCO_VER} ) + set(W3NCO_VER "2.0.6" ) + endif() +endmacro() diff --git a/cmake/Modules/platforms/WCOSS-D.cmake b/cmake/Modules/platforms/WCOSS-D.cmake new file mode 100644 index 000000000..ccc2a4f9c --- /dev/null +++ b/cmake/Modules/platforms/WCOSS-D.cmake @@ -0,0 +1,51 @@ +macro (setWCOSS_D) + message("Setting paths for Dell") + option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5_HL "Try to Find HDF5 libraries" OFF) + + set(HOST_FLAG "-xHOST" CACHE INTERNAL "Host Flag") + set(MKL_FLAG "-mkl" CACHE INTERNAL "MKL Flag") + set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -fp-model strict -assume byterecl -convert big_endian -implicitnone -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS} -O3" CACHE INTERNAL "GSI Fortran Flags") + set(GSI_LDFLAGS "${OpenMP_Fortran_FLAGS} ${MKL_FLAG}" CACHE INTERNAL "") + set(ENKF_Platform_FLAGS "-O3 -fp-model strict -convert big_endian -assume byterecl -implicitnone -DGFS -D_REAL8_ ${MPI3FLAG} ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "ENKF Fortran Flags") + + set(HDF5_USE_STATIC_LIBRARIES "ON" CACHE INTERNAL "" ) + if( NOT DEFINED ENV{COREPATH} ) + set(COREPATH "/gpfs/dell1/nco/ops/nwprod/lib" ) + else() + set(COREPATH $ENV{COREPATH} ) + endif() + if( NOT DEFINED ENV{CRTM_INC} ) + set(CRTM_BASE "/gpfs/dell1/nco/ops/nwprod/lib/crtm" ) + endif() + if( NOT DEFINED ENV{NETCDF_VER} ) + set(NETCDF_VER "3.6.3" ) + endif() + if( NOT DEFINED ENV{BACIO_VER} ) + set(BACIO_VER "2.0.2" ) + endif() + if( NOT DEFINED ENV{BUFR_VER} ) + set(BUFR_VER "11.2.0" ) + endif() + if( NOT DEFINED ENV{CRTM_VER} ) + set(CRTM_VER "2.2.5" ) + endif() + if( NOT DEFINED ENV{NEMSIO_VER} ) + set(NEMSIO_VER "2.2.3" ) + endif() + if( NOT DEFINED ENV{SFCIO_VER} ) + set(SFCIO_VER "1.0.0" ) + endif() + if( NOT DEFINED ENV{SIGIO_VER} ) + set(SIGIO_VER "2.0.1" ) + endif() + if( NOT DEFINED ENV{SP_VER} ) + set(SP_VER "2.0.2" ) + endif() + if( NOT DEFINED ENV{W3EMC_VER} ) + set(W3EMC_VER "2.3.0" ) + endif() + if( NOT DEFINED ENV{W3NCO_VER} ) + set(W3NCO_VER "2.0.6" ) + endif() +endmacro() diff --git a/cmake/Modules/platforms/WCOSS.cmake b/cmake/Modules/platforms/WCOSS.cmake new file mode 100644 index 000000000..81b129739 --- /dev/null +++ b/cmake/Modules/platforms/WCOSS.cmake @@ -0,0 +1,61 @@ +macro (setWCOSS) + message("Setting paths for WCOSS") + option(FIND_HDF5 "Try to Find HDF5 libraries" OFF) + option(FIND_HDF5_HL "Try to Find HDF5 libraries" OFF) + set(HDF5_USE_STATIC_LIBRARIES "OFF") + + #if ibmpe module is not loaded last, CMake tries to use intel mpi. Force use of ibmhpc + set(HOST_FLAG "-xHOST" CACHE INTERNAL "Host Flag") + set( MKL_FLAG "-mkl" CACHE INTERNAL "MKL Flag") + set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -traceback -O3 -fp-model source -convert big_endian -assume byterecl -implicitnone -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "") + set(ENKF_Platform_FLAGS "-O3 -fp-model source -convert big_endian -assume byterecl -implicitnone -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${HOST_FLAG} " CACHE INTERNAL "") + + set(MPI_Fortran_COMPILER /opt/ibmhpc/pe13010/base/bin/mpif90 CACHE FILEPATH "Forced use of ibm wrapper" FORCE ) + set(MPI_C_COMPILER /opt/ibmhpc/pe13010/base/bin/mpicc CACHE FILEPATH "Forced use of ibm wrapper" FORCE ) + set(MPI_CXX_COMPILER /opt/ibmhpc/pe13010/base/bin/mpicxx CACHE FILEPATH "Forced use of ibm wrapper" FORCE ) + + if( NOT DEFINED ENV{COREPATH} ) + set(COREPATH "/nwprod/lib" ) + else() + set(COREPATH $ENV{COREPATH} ) + endif() + if( NOT DEFINED ENV{CRTM_INC} ) + set(CRTM_BASE "/nwprod2/lib" ) + endif() + if( NOT DEFINED ENV{WRFPATH} ) + set(WRFPATH "/nwprod/sorc/wrf_shared.fd" ) + else() + set(WRFPATH $ENV{WRFPATH} ) + endif() + if( NOT DEFINED ENV{NETCDF_VER} ) + set(NETCDF_VER "3.6.3" ) + endif() + if( NOT DEFINED ENV{BACIO_VER} ) + set(BACIO_VER "2.0.1" ) + endif() + if( NOT DEFINED ENV{BUFR_VER} ) + set(BUFR_VER "10.2.5" ) + endif() + if( NOT DEFINED ENV{CRTM_VER} ) + set(CRTM_VER "2.2.3" ) + endif() + if( NOT DEFINED ENV{NEMSIO_VER} ) + set(NEMSIO_VER "2.2.1" ) + endif() + if( NOT DEFINED ENV{SFCIO_VER} ) + set(SFCIO_VER "1.0.0" ) + endif() + if( NOT DEFINED ENV{SIGIO_VER} ) + set(SIGIO_VER "2.0.1" ) + endif() + if( NOT DEFINED ENV{SP_VER} ) + set(SP_VER "2.0.2" ) + endif() + if( NOT DEFINED ENV{W3EMC_VER} ) + set(W3EMC_VER "2.0.5" ) + endif() + if( NOT DEFINED ENV{W3NCO_VER} ) + set(W3NCO_VER "2.0.6" ) + endif() + +endmacro() diff --git a/cmake/Modules/setCompilerFlags.cmake b/cmake/Modules/setCompilerFlags.cmake deleted file mode 100644 index 01bae306b..000000000 --- a/cmake/Modules/setCompilerFlags.cmake +++ /dev/null @@ -1,129 +0,0 @@ -function (setIntel) - string(REPLACE "." ";" COMPILER_VERSION_LIST ${CMAKE_C_COMPILER_VERSION}) - list(GET COMPILER_VERSION_LIST 0 MAJOR_VERSION) - message("Compiler version is ${MAJOR_VERSION}") - if(${MAJOR_VERSION} GREATER 15 ) - set( OMPFLAG "-qopenmp" PARENT_SCOPE ) - else() - set( OMPFLAG "-openmp" PARENT_SCOPE ) - endif() - STRING(COMPARE EQUAL ${CMAKE_BUILD_TYPE} "RELEASE" BUILD_RELEASE) - set( MKL_FLAG "-mkl" ) - if( BUILD_RELEASE ) - if(( HOST-Tide ) OR ( HOST-Gyre )) -# set(GSI_Fortran_FLAGS "-traceback -fp-model source -assume byterecl -convert big_endian -implicitnone -D_REAL8_ ${OMPFLAG} ${MPI_Fortran_COMPILE_FLAGS}" PARENT_SCOPE) - set(GSI_Fortran_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -convert big_endian -assume byterecl -implicitnone -D_REAL8_ ${OMPFLAG} ${MPI_Fortran_COMPILE_FLAGS}" PARENT_SCOPE) - set(ENKF_Fortran_FLAGS "-O3 -fp-model source -convert big_endian -assume byterecl -implicitnone -DGFS -D_REAL8_ ${OMPFLAG}" PARENT_SCOPE) - set(UTIL_Fortran_FLAGS "-O3 -fp-model source -convert big_endian -assume byterecl -implicitnone -DWRF -D_REAL8_ ${OMPFLAG}" PARENT_SCOPE) - set (BACIO_Fortran_FLAGS "-O3 -free -assume nocc_omp " PARENT_SCOPE ) - set (BUFR_Fortran_FLAGS "-O2 -r8 -fp-model strict -traceback -xSSE2 -O3 -axCORE-AVX2 ${OMPFLAG} " PARENT_SCOPE ) - set (BUFR_C_FLAGS "-g -traceback -DUNDERSCORE -O3 -axCORE-AVX2 -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" PARENT_SCOPE ) - elseif( HOST-Luna OR HOST-Surge ) - set( MKL_FLAG "" ) - set(GSI_Fortran_FLAGS "-DPOUND_FOR_STRINGIFY -fp-model source -assume byterecl -convert big_endian -implicitnone -D_REAL8_ ${OMPFLAG} ${MPI_Fortran_COMPILE_FLAGS}" PARENT_SCOPE) - set(GSI_LDFLAGS "-liomp5" PARENT_SCOPE) - - set(ENKF_Fortran_FLAGS "-O3 -fp-model source -convert big_endian -assume byterecl -implicitnone -DGFS -D_REAL8_ ${OMPFLAG} " PARENT_SCOPE) - set(UTIL_Fortran_FLAGS "-O3 -fp-model source -convert big_endian -assume byterecl -implicitnone -DWRF -D_REAL8_ ${OMPFLAG} " PARENT_SCOPE) - set (BACIO_Fortran_FLAGS "-O3 -free -assume nocc_omp " PARENT_SCOPE ) - set (BUFR_Fortran_FLAGS " -c -g -traceback -O3 -axCORE-AVX2 -r8 " PARENT_SCOPE ) - set (BUFR_C_FLAGS "-DSTATIC_ALLOCATION -DUNDERSCORE -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" PARENT_SCOPE ) - else() - set(GSI_Fortran_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${OMPFLAG} ${MPI_Fortran_COMPILE_FLAGS}" PARENT_SCOPE) - set(ENKF_Fortran_FLAGS "-O3 -xHOST -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OMPFLAG}" PARENT_SCOPE) - set(UTIL_Fortran_FLAGS "-O3 -xHOST -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DWRF -D_REAL8_ ${OMPFLAG}" PARENT_SCOPE) - set (BACIO_Fortran_FLAGS "-O3 -free -assume nocc_omp " PARENT_SCOPE ) - set (BUFR_Fortran_FLAGS "-O2 -r8 -fp-model strict -traceback -xSSE2 -O3 -axCORE-AVX2 ${OMPFLAG} " PARENT_SCOPE ) - set (BUFR_C_FLAGS "-g -traceback -DUNDERSCORE -O3 -axCORE-AVX2 -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" PARENT_SCOPE ) - endif() - - set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 -Dfunder" PARENT_SCOPE ) - set (BUFR_Fortran_PP_FLAGS " -P -traditional-cpp -C " PARENT_SCOPE ) -# set (CRTM_Fortran_FLAGS " -O2 -convert big_endian -free -assume byterecl -xSSE2 -fp-model strict -traceback -g ${OMPFLAG} " PARENT_SCOPE ) - set (CRTM_Fortran_FLAGS " -O1 -convert big_endian -free -assume byterecl -fp-model source -traceback " PARENT_SCOPE ) -# set (CRTM_Fortran_FLAGS " -assume byterecl -convert big_endian -O3 -fp-model source -free -assume byterecl " PARENT_SCOPE ) - set (NEMSIO_Fortran_FLAGS " -O2 -convert big_endian -free -assume byterecl -xSSE2 -fp-model strict -traceback -g ${MKL_FLAG} ${OMPFLAG} " PARENT_SCOPE ) - set (SFCIO_Fortran_FLAGS " -O2 -convert big_endian -free -assume byterecl -xSSE2 -fp-model strict -traceback -g ${MKL_FLAG} ${OMPFLAG} " PARENT_SCOPE ) - set (SIGIO_Fortran_FLAGS " -O2 -convert big_endian -free -assume byterecl -xSSE2 -fp-model strict -traceback -g ${MKL_FLAG} ${OMPFLAG} " PARENT_SCOPE ) - set (SP_Fortran_FLAGS " -O2 -ip -fp-model strict -assume byterecl -convert big_endian -fpp -i${intsize} -r8 -convert big_endian -assume byterecl -DLINUX ${OMPFLAG} " PARENT_SCOPE ) - set (SP_F77_FLAGS " -DLINUX -O2 -ip -fp-model strict -assume byterecl -convert big_endian -fpp -i${intsize} -r8 -convert big_endian -assume byterecl -DLINUX ${OMPFLAG} " PARENT_SCOPE ) - set (W3EMC_Fortran_FLAGS " -O3 -auto -assume nocc_omp -i${intsize} -r8 -convert big_endian -assume byterecl -fp-model strict ${OMPFLAG} " PARENT_SCOPE ) - set (W3NCO_Fortran_FLAGS " -O3 -auto -assume nocc_omp -i${intsize} -r8 -convert big_endian -assume byterecl -fp-model strict ${OMPFLAG} " PARENT_SCOPE ) - set (W3NCO_C_FLAGS "-O0 -DUNDERSCORE -DLINUX -D__linux__ " PARENT_SCOPE ) - else( BUILD_RELEASE ) #DEBUG flags - message("Building DEBUG version of GSI") - set( debug_suffix "_DBG" PARENT_SCOPE ) - if(( HOST-Tide ) OR ( HOST-Gyre )) - set(GSI_Fortran_FLAGS "-DPOUND_FOR_STRINGIFY -O0 -fp-model source -convert big_endian -assume byterecl -implicitnone -mcmodel medium -shared-intel -g -traceback -debug -ftrapuv -check all,noarg_temp_created -fp-stack-check -fstack-protector -warn all,nointerfaces -convert big_endian -implicitnone -D_REAL8_ ${OMPFLAG} ${MPI_Fortran_COMPILE_FLAGS}" PARENT_SCOPE) - set(ENKF_Fortran_FLAGS "-g -O0 -fp-model source -convert big_endian -assume byterecl -implicitnone -warn all -traceback -debug all -check all,noarg_temp_created -implicitnone -DGFS -D_REAL8_ ${OMPFLAG}" PARENT_SCOPE) - set(UTIL_Fortran_FLAGS "-g -O0 -fp-model source -convert big_endian -assume byterecl -implicitnone -warn all -traceback -debug all -check all,noarg_temp_created -implicitnone -DWRF -D_REAL8_ ${OMPFLAG}" PARENT_SCOPE) - set (BACIO_Fortran_FLAGS "-g -free -assume nocc_omp " PARENT_SCOPE ) - else() - set(GSI_Fortran_FLAGS "-DPOUND_FOR_STRINGIFY -O0 -fp-model strict -convert big_endian -assume byterecl -implicitnone -g -traceback -debug -ftrapuv -check all,noarg_temp_created -fp-stack-check -fstack-protector -warn all,nointerfaces -D_REAL8_ ${OMPFLAG} ${MPI_Fortran_COMPILE_FLAGS}" PARENT_SCOPE) - set(ENKF_Fortran_FLAGS "-O0 -xHOST -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian -D_REAL8_ ${OMPFLAG}" PARENT_SCOPE) - set(UTIL_Fortran_FLAGS "-O0 -xHOST -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian -D_REAL8_ ${OMPFLAG}" PARENT_SCOPE) - set (BACIO_Fortran_FLAGS "-g -free -assume nocc_omp " PARENT_SCOPE ) - endif() - set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder" PARENT_SCOPE ) - set (BUFR_Fortran_PP_FLAGS " -P -traditional-cpp -C " PARENT_SCOPE ) - set (BUFR_Fortran_FLAGS "-g -r8 -fp-model strict -traceback -xSSE2 -axCORE-AVX2 ${OMPFLAG} " PARENT_SCOPE ) - set (BUFR_C_FLAGS "-g -traceback -DUNDERSCORE -axCORE-AVX2 -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" PARENT_SCOPE ) - set (CRTM_Fortran_FLAGS " -convert big_endian -free -assume byterecl -xSSE2 -fp-model strict -traceback -g ${OMPFLAG} " PARENT_SCOPE ) - set (NEMSIO_Fortran_FLAGS " -convert big_endian -free -assume byterecl -xSSE2 -fp-model strict -traceback -g ${MKL_FLAG} ${OMPFLAG} " PARENT_SCOPE ) - set (SFCIO_Fortran_FLAGS " -convert big_endian -free -assume byterecl -xSSE2 -fp-model strict -traceback -g ${MKL_FLAG} ${OMPFLAG} " PARENT_SCOPE ) - set (SIGIO_Fortran_FLAGS " -convert big_endian -free -assume byterecl -xSSE2 -fp-model strict -traceback -g ${MKL_FLAG} ${OMPFLAG} " PARENT_SCOPE ) - set (SP_Fortran_FLAGS " -g -ip -fp-model strict -assume byterecl -fpp -i${intsize} -r8 -convert big_endian -DLINUX ${OMPFLAG} " PARENT_SCOPE ) - set (SP_F77_FLAGS " -g -ip -fp-model strict -assume byterecl -convert big_endian -fpp -i${intsize} -r8 -DLINUX ${OMPFLAG} " PARENT_SCOPE ) - set (W3EMC_Fortran_FLAGS " -g -auto -assume nocc_omp -i${intsize} -r8 -convert big_endian -assume byterecl -fp-model strict ${OMPFLAG} " PARENT_SCOPE ) - set (W3NCO_Fortran_FLAGS " -g -auto -assume nocc_omp -i${intsize} -r8 -convert big_endian -assume byterecl -fp-model strict ${OMPFLAG} " PARENT_SCOPE ) - set (W3NCO_C_FLAGS "-O0 -g -DUNDERSCORE -DLINUX -D__linux__ " PARENT_SCOPE ) - endif() -endfunction() - -function (setGNU) - message("Setting GNU Compiler Flags") - set(GSI_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp -ffree-line-length-0" PARENT_SCOPE) - set(EXTRA_LINKER_FLAGS "-lgomp" PARENT_SCOPE) - set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder" PARENT_SCOPE ) - set(ENKF_Fortran_FLAGS " -O3 -fconvert=big-endian -ffree-line-length-0 -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -DGFS -D_REAL8_ -fopenmp" PARENT_SCOPE) - set(UTIL_Fortran_FLAGS " -O3 -fconvert=big-endian -ffree-line-length-0 -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -DWRF -D_REAL8_ -fopenmp" PARENT_SCOPE) - set(BUFR_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" PARENT_SCOPE) - set(BUFR_Fortran_PP_FLAGS " -P " PARENT_SCOPE) - set(BUFR_C_FLAGS " -O3 -g -DUNDERSCORE -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" PARENT_SCOPE ) - set(BACIO_Fortran_FLAGS " -O3 -fconvert=big-endian -ffree-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" PARENT_SCOPE) - set(CRTM_Fortran_FLAGS " -g -std=f2003 -fdollar-ok -O3 -fconvert=big-endian -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -static -Wall " PARENT_SCOPE) - set(NEMSIO_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" PARENT_SCOPE) - set(SIGIO_Fortran_FLAGS " -O3 -fconvert=big-endian -ffree-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" PARENT_SCOPE) - set(SFCIO_Fortran_FLAGS " -O3 -ffree-form -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" PARENT_SCOPE) - set(SP_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp -DLINUX" PARENT_SCOPE) - set(SP_F77_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp -DLINUX" PARENT_SCOPE) - set(W3EMC_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" PARENT_SCOPE) - set(W3NCO_Fortran_FLAGS " -O3 -fconvert=big-endian -ffixed-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ " PARENT_SCOPE) - set(W3NCO_C_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" PARENT_SCOPE) -endfunction() - -function (setPGI) - message("Setting PGI Compiler Flags") - set(CMAKE_Fortran_FLAGS_RELEASE "") - set(Fortran_FLAGS "" PARENT_SCOPE) - set(GSI_Fortran_FLAGS "-Minform=inform -O1 -byteswapio -D_REAL8_ -mp -Mfree" PARENT_SCOPE) - set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder" PARENT_SCOPE ) - set(ENKF_Fortran_FLAGS " -O3 -byteswapio -fast -DGFS -D_REAL8_ -mp" PARENT_SCOPE) - set(UTIL_Fortran_FLAGS " -O3 -byteswapio -fast -DWRF -D_REAL8_ -mp" PARENT_SCOPE) - - set(BUFR_Fortran_FLAGS "-O1 -byteswapio -D_REAL8_ -mp" PARENT_SCOPE) - set(BUFR_Fortran_PP_FLAGS " -P " PARENT_SCOPE) - set(BUFR_C_FLAGS " -g -DUNDERSCORE -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" PARENT_SCOPE ) - - set(BACIO_C_INCLUDES " -I/usr/include/malloc" PARENT_SCOPE) - set(BACIO_Fortran_FLAGS " -O3 -byteswapio -fast -D_REAL8_ -mp -Mfree" PARENT_SCOPE) - set(CRTM_Fortran_FLAGS " -O1 -byteswapio -module ../../include -Mfree " PARENT_SCOPE) - set(NEMSIO_Fortran_FLAGS " -O1 -byteswapio -D_REAL8_ -mp" PARENT_SCOPE) - set(SIGIO_Fortran_FLAGS " -O3 -Mfree -byteswapio -fast -D_REAL8_ -mp" PARENT_SCOPE) - set(SFCIO_Fortran_FLAGS " -O3 -byteswapio -Mfree -fast -D_REAL8_ -mp" PARENT_SCOPE) - set(SP_Fortran_FLAGS " -O1 -byteswapio -D_REAL8_ -mp" PARENT_SCOPE) - set(SP_F77_FLAGS "-DLINUX -O1 -byteswapio -D_REAL8_ -mp" PARENT_SCOPE) - set(W3EMC_Fortran_FLAGS " -O1 -byteswapio -D_REAL8_ " PARENT_SCOPE) - set(W3NCO_Fortran_FLAGS " -O1 -byteswapio -D_REAL8_ " PARENT_SCOPE) - set(W3NCO_C_FLAGS " -O1 -D_REAL8_ -mp" PARENT_SCOPE) -endfunction() diff --git a/cmake/Modules/setGNUFlags.cmake b/cmake/Modules/setGNUFlags.cmake new file mode 100644 index 000000000..1e1e075fa --- /dev/null +++ b/cmake/Modules/setGNUFlags.cmake @@ -0,0 +1,64 @@ +function (setGNU) + set(COMPILER_TYPE "gnu" CACHE INTERNAL "Compiler brand") + message("Setting GNU Compiler Flags") + if( (BUILD_RELEASE) OR (BUILD_PRODUCTION) ) + set(GSI_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ ${GSDCLOUDOPT} -fopenmp -ffree-line-length-0" CACHE INTERNAL "") + set(EXTRA_LINKER_FLAGS "-lgomp -lnetcdf -lnetcdff" CACHE INTERNAL "") + set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder" CACHE INTERNAL "" ) + set(ENKF_Fortran_FLAGS " -O3 -fconvert=big-endian -ffree-line-length-0 -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -DGFS -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(UTIL_Fortran_FLAGS " -O3 -fconvert=big-endian -ffree-line-length-0 -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -DWRF -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(UTIL_COM_Fortran_FLAGS " -O3 -fconvert=big-endian -ffree-line-length-0 -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check" CACHE INTERNAL "") + set(BUFR_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(BUFR_Fortran_PP_FLAGS " -P " CACHE INTERNAL "") + set(BUFR_C_FLAGS " -O3 -g -DUNDERSCORE -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" CACHE INTERNAL "" ) + set(BACIO_Fortran_FLAGS " -O3 -fconvert=big-endian -ffree-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(CRTM_Fortran_FLAGS " -g -std=f2003 -fdollar-ok -O3 -fconvert=big-endian -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -static -Wall " CACHE INTERNAL "") + set(NEMSIO_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(SIGIO_Fortran_FLAGS " -O3 -fconvert=big-endian -ffree-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(SFCIO_Fortran_FLAGS " -O3 -ffree-form -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(SP_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ -fopenmp -DLINUX" CACHE INTERNAL "") + set(SP_Fortran_4_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -fopenmp -DLINUX" CACHE INTERNAL "") + set(SP_F77_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ -fopenmp -DLINUX" CACHE INTERNAL "") + set(SP_F77_4_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -fopenmp -DLINUX" CACHE INTERNAL "") + set(W3EMC_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(W3EMC_4_Fortran_FLAGS " -O3 -fconvert=big-endian -ffixed-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check " CACHE INTERNAL "") + set(W3NCO_Fortran_FLAGS " -O3 -fconvert=big-endian -ffixed-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ " CACHE INTERNAL "") + set(W3NCO_4_Fortran_FLAGS " -O3 -fconvert=big-endian -ffixed-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check " CACHE INTERNAL "") + set(W3NCO_C_FLAGS " -DLINUX -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(WRFLIB_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp -ffree-line-length-0" CACHE INTERNAL "") + set( NCDIAG_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) + set( NDATE_Fortran_FLAGS "-fconvert=big-endian -DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -O3 -Wl,-noinhibit-exec" CACHE INTERNAL "") + set( COV_CALC_FLAGS "-c -O3 -fconvert=little-endian -ffast-math -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fopenmp" CACHE INTERNAL "") + set(GSDCLOUD_Fortran_FLAGS "-O3 -fconvert=big-endian" CACHE INTERNAL "") + else( ) #DEBUG + set(GSI_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ ${GSDCLOUDOPT} -fopenmp -ffree-line-length-0" CACHE INTERNAL "") + set(EXTRA_LINKER_FLAGS "-lgomp -lnetcdf -lnetcdff" CACHE INTERNAL "") + set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -fbacktrace -Dfunder" CACHE INTERNAL "" ) + set(ENKF_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffree-line-length-0 -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -DGFS -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(UTIL_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffree-line-length-0 -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -DWRF -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(UTIL_COM_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffree-line-length-0 -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check" CACHE INTERNAL "") + set(BUFR_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(BUFR_Fortran_PP_FLAGS " -P " CACHE INTERNAL "") + set(BUFR_C_FLAGS " -g -fbacktrace -g -fbacktrace -DUNDERSCORE -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" CACHE INTERNAL "" ) + set(BACIO_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffree-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(CRTM_Fortran_FLAGS " -g -fbacktrace -std=f2003 -fdollar-ok -g -fbacktrace -fconvert=big-endian -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -static -Wall " CACHE INTERNAL "") + set(NEMSIO_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(SIGIO_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffree-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(SFCIO_Fortran_FLAGS " -g -fbacktrace -ffree-form -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(SP_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ -fopenmp -DLINUX" CACHE INTERNAL "") + set(SP_Fortran_4_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -fopenmp -DLINUX" CACHE INTERNAL "") + set(SP_F77_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ -fopenmp -DLINUX" CACHE INTERNAL "") + set(SP_F77_4_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -fopenmp -DLINUX" CACHE INTERNAL "") + set(W3EMC_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(W3EMC_4_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffixed-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check " CACHE INTERNAL "") + set(W3NCO_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffixed-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -fdefault-real-8 -D_REAL8_ " CACHE INTERNAL "") + set(W3NCO_4_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffixed-form -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check " CACHE INTERNAL "") + set(W3NCO_C_FLAGS " -DLINUX -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") + set(WRFLIB_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp -ffree-line-length-0" CACHE INTERNAL "") + set( NCDIAG_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) + set( NDATE_Fortran_FLAGS "-fconvert=big-endian -DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -g -fbacktrace -Wl,-noinhibit-exec" CACHE INTERNAL "") + set( COV_CALC_FLAGS "-c -O3 -fconvert=little-endian -ffast-math -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fopenmp" CACHE INTERNAL "") + set(GSDCLOUD_Fortran_FLAGS "-O3 -fconvert=big-endian" CACHE INTERNAL "") + endif( (BUILD_RELEASE) OR (BUILD_PRODUCTION) ) +endfunction() + diff --git a/cmake/Modules/setHOST.cmake b/cmake/Modules/setHOST.cmake new file mode 100644 index 000000000..a4f3628b3 --- /dev/null +++ b/cmake/Modules/setHOST.cmake @@ -0,0 +1,85 @@ +macro( setHOST ) + site_name(HOSTNAME) + message("The hostname is ${HOSTNAME}" ) + string(REGEX MATCH "s4-" HOST-S4 ${HOSTNAME} ) + string(REGEX MATCH "gaea" HOST-Gaea ${HOSTNAME} ) + string(REGEX MATCH "hfe[0-9]" HOST-Hera ${HOSTNAME} ) + if(EXISTS /jetmon) + set(HOST-Jet "True" ) + endif() + string(REGEX MATCH "g[0-9][0-9]a" HOST-WCOSS ${HOSTNAME} ) + if( HOST-WCOSS ) + message("host is WCOSS") + endif() + string(REGEX MATCH "g[0-9][0-9]a" HOST-WCOSS ${HOSTNAME} ) + if( NOT HOST-WCOSS ) # don't overwrite if we are on gyre + string(REGEX MATCH "t[0-9][0-9]a" HOST-WCOSS ${HOSTNAME} ) + endif() + string(REGEX MATCH "v[0-9][0-9]a" HOST-WCOSS_D ${HOSTNAME} ) + if( NOT HOST-WCOSS_D )# don't overwrite if we are on venus + string(REGEX MATCH "m[0-9][0-9]a" HOST-WCOSS_D ${HOSTNAME} ) + endif() + string(REGEX MATCH "llogin" HOST-WCOSS_C ${HOSTNAME} ) + if( NOT HOST-WCOSS_C )# don't overwrite if we are on luna + string(REGEX MATCH "slogin" HOST-WCOSS_C ${HOSTNAME} ) + endif() + string(REGEX MATCH "discover" HOST-Discover ${HOSTNAME} ) + string(REGEX MATCH "cheyenne" HOST-Cheyenne ${HOSTNAME} ) + message("done figuring out host--${HOSTNAME}") + if ( BUILD_CORELIBS ) + MESSAGE(STATUS "BUILD_CORELIBS manually-specified as ON") + set( host "GENERIC" ) + set( HOST-Generic "TRUE" ) + setGeneric() + elseif(HOST-Jet) + option(BUILD_CORELIBS "Build the Core libraries " ON) + set( host "Jet" ) + set( HOST-Jet "TRUE" ) + setJet() + elseif( HOST-S4 ) + option(BUILD_CORELIBS "Build the Core libraries " ON) + set( host "S4" ) + set( HOST-S4 "TRUE" ) + setS4() + elseif( HOST-WCOSS ) + option(BUILD_CORELIBS "Build the Core libraries " OFF) + set( host "WCOSS" ) + set( HOST-WCOSS "TRUE" ) + setWCOSS() + elseif( HOST-Hera ) + set( host "Hera" ) + option(BUILD_CORELIBS "Build the Core libraries " OFF) + setHERA() + set( HOST-Hera "TRUE" ) + elseif( HOST-Gaea ) + set( host "Gaea" ) + option(BUILD_CORELIBS "Build the Core libraries " On) + setGaea() + set( HOST-Gaea "TRUE" ) + elseif( HOST-Cheyenne ) + option(BUILD_CORELIBS "Build the Core libraries " ON) + set( host "Cheyenne" ) + setCheyenne() + set( HOST-Cheyenne "TRUE" ) + elseif( HOST-WCOSS_C ) + set( host "WCOSS_C" ) + option(BUILD_CORELIBS "Build the Core libraries " OFF) + setWCOSS_C() + set( HOST-WCOSS_C "TRUE" ) + elseif( HOST-WCOSS_D ) + set( host "WCOSS_D" ) + option(BUILD_CORELIBS "Build the Core libraries " OFF) + setWCOSS_D() + set( HOST-WCOSS_D "TRUE" ) + elseif( HOST-Discover ) + set(host "Discover" ) + setDiscover() + set( HOST-Discover "TRUE" ) + else( ) + set( host "GENERIC" ) + option(BUILD_CORELIBS "Build the Core libraries " ON) + setGeneric() + set( HOST-Generic "TRUE" ) + endif() + message("Host is set to ${host}") +endmacro() diff --git a/cmake/Modules/setIntelFlags.cmake b/cmake/Modules/setIntelFlags.cmake new file mode 100644 index 000000000..77873550a --- /dev/null +++ b/cmake/Modules/setIntelFlags.cmake @@ -0,0 +1,92 @@ +set(intsize 4) +function(set_LIBRARY_UTIL_Intel) + set(BACIO_Fortran_FLAGS "-O3 -free -assume nocc_omp ${HOST_FLAG} " CACHE INTERNAL "" ) + set(BUFR_Fortran_FLAGS "-O2 -r8 -fp-model strict -traceback -O3 ${HOST_FLAG} ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(BUFR_C_FLAGS "-DSTATIC_ALLOCATION -DUNDERSCORE -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" CACHE INTERNAL "" ) + set(BUFR_Fortran_PP_FLAGS " -P -traditional-cpp -C " CACHE INTERNAL "" ) + set(WRFLIB_Fortran_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "") + set(WRFLIB_C_FLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 -Dfunder" CACHE INTERNAL "" ) + set (CRTM_Fortran_FLAGS " -O3 -convert big_endian -free -assume byterecl -fp-model source -traceback ${HOST_FLAG}" CACHE INTERNAL "" ) + set (NEMSIO_Fortran_FLAGS " -O2 -convert big_endian -free -assume byterecl -fp-model strict -traceback ${HOST_FLAG} -g ${MKL_FLAG} ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (SFCIO_Fortran_FLAGS " -O2 -convert big_endian -free -assume byterecl -fp-model strict -traceback ${HOST_FLAG} -g ${MKL_FLAG} ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (SIGIO_Fortran_FLAGS " -O2 -convert big_endian -free -assume byterecl -fp-model strict -traceback ${HOST_FLAG} -g ${MKL_FLAG} ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (SP_Fortran_FLAGS " -O2 -ip -fp-model strict -assume byterecl -convert big_endian -fpp -i${intsize} -r8 -convert big_endian -assume byterecl -DLINUX ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (SP_Fortran_4_FLAGS " -O2 -ip -fp-model strict -assume byterecl -convert big_endian -fpp -i${intsize} -convert big_endian -assume byterecl -DLINUX ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (SP_F77_FLAGS " -DLINUX -O2 -ip -fp-model strict -assume byterecl -convert big_endian -fpp -i${intsize} -r8 -convert big_endian -assume byterecl -DLINUX ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (W3EMC_Fortran_FLAGS " -O3 -auto -assume nocc_omp -i${intsize} -r8 -convert big_endian -assume byterecl -fp-model strict ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (W3EMC_4_Fortran_FLAGS " -O3 -auto -assume nocc_omp -i${intsize} -convert big_endian -assume byterecl -fp-model strict ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (W3NCO_Fortran_FLAGS " -O3 -auto -assume nocc_omp -i${intsize} -r8 -convert big_endian -assume byterecl -fp-model strict ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (W3NCO_4_Fortran_FLAGS " -O3 -auto -assume nocc_omp -i${intsize} -convert big_endian -assume byterecl -fp-model strict ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set (W3NCO_C_FLAGS "-O0 -DUNDERSCORE -DLINUX -D__linux__ " CACHE INTERNAL "" ) + set (NDATE_Fortran_FLAGS "${HOST_FLAG} -fp-model source -ftz -assume byterecl -convert big_endian -heap-arrays -DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -O3 -Wl,-noinhibit-exec" CACHE INTERNAL "" ) + set(NCDIAG_Fortran_FLAGS "-free -assume byterecl -convert big_endian" CACHE INTERNAL "" ) + set(UTIL_Fortran_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DWRF -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "") + set(UTIL_COM_Fortran_FLAGS "-O3 -fp-model source -convert big_endian -assume byterecl -implicitnone" CACHE INTERNAL "") +# set(COV_CALC_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert little_endian -D_REAL8_ -openmp -fpp -auto" CACHE INTERNAL "" ) + set(COV_CALC_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert little_endian ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "") +# set(COV_CALC_FLAGS ${GSI_Intel_Platform_FLAGS} CACHE INTERNAL "Full GSI Fortran FLAGS" ) +endfunction(set_LIBRARY_UTIL_Intel) + +function(set_LIBRARY_UTIL_Debug_Intel) + set (BACIO_Fortran_FLAGS "-g -free -assume nocc_omp " CACHE INTERNAL "" ) + set(BUFR_Fortran_FLAGS " -c -g -traceback -O3 -axCORE-AVX2 -r8 " CACHE INTERNAL "" ) + set(BUFR_C_FLAGS "-g -traceback -DUNDERSCORE -O3 -axCORE-AVX2 -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" CACHE INTERNAL "" ) + set(BUFR_Fortran_PP_FLAGS " -P -traditional-cpp -C " CACHE INTERNAL "" ) + set(CRTM_Fortran_FLAGS " -convert big_endian -free -assume byterecl -xHOST -fp-model strict -traceback -g ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(SFCIO_Fortran_FLAGS " -convert big_endian -free -assume byterecl -xHOST -fp-model strict -traceback -g ${MKL_FLAG} ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(SIGIO_Fortran_FLAGS " -convert big_endian -free -assume byterecl -xHOST -fp-model strict -traceback -g ${MKL_FLAG} ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(SP_Fortran_FLAGS " -g -ip -fp-model strict -assume byterecl -fpp -i${intsize} -r8 -convert big_endian -DLINUX ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(SP_Fortran_4_FLAGS " -g -ip -fp-model strict -assume byterecl -fpp -i${intsize} -convert big_endian -DLINUX ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(SP_F77_FLAGS " -g -ip -fp-model strict -assume byterecl -convert big_endian -fpp -i${intsize} -r8 -DLINUX ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(W3EMC_Fortran_FLAGS " -g -auto -assume nocc_omp -i${intsize} -r8 -convert big_endian -assume byterecl -fp-model strict ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(W3EMC_4_Fortran_FLAGS " -g -auto -assume nocc_omp -i${intsize} -convert big_endian -assume byterecl -fp-model strict ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(NEMSIO_Fortran_FLAGS " -convert big_endian -free -assume byterecl -xHOST -fp-model strict -traceback -g ${MKL_FLAG} ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(W3NCO_Fortran_FLAGS " -g -auto -assume nocc_omp -i${intsize} -r8 -convert big_endian -assume byterecl -fp-model strict ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(W3NCO_4_Fortran_FLAGS " -g -auto -assume nocc_omp -i${intsize} -convert big_endian -assume byterecl -fp-model strict ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) + set(W3NCO_C_FLAGS "-O0 -g -DUNDERSCORE -DLINUX -D__linux__ " CACHE INTERNAL "" ) + set(NCDIAG_Fortran_FLAGS "-free -assume byterecl -convert big_endian" CACHE INTERNAL "" ) + set(WRFLIB_Fortran_FLAGS "-DPOUND_FOR_STRINGIFY -O1 -g -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "") + set(NDATE_Fortran_FLAGS "${HOST_FLAG} -fp-model source -ftz -assume byterecl -convert big_endian -heap-arrays -DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -g -Wl,-noinhibit-exec" CACHE INTERNAL "" ) + set(WRFLIB_C_FLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder" CACHE INTERNAL "" ) + set(UTIL_Fortran_FLAGS "-O0 ${HOST_FLAG} -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "") + set(UTIL_COM_Fortran_FLAGS "-O0 -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian" CACHE INTERNAL "") + set(COV_CALC_FLAGS "-O3 ${HOST_FLAG} -implicitnone -traceback -fp-model strict -convert little_endian ${OpenMP_Fortran_FLAGS} " CACHE INTERNAL "" ) +endfunction(set_LIBRARY_UTIL_Debug_Intel) + +function(set_GSI_ENKF_Intel) + #Common release/production flags + set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 -Dfunder" CACHE INTERNAL "" ) + set(GSI_Fortran_FLAGS "${GSI_Intel_Platform_FLAGS} ${GSDCLOUDOPT}" CACHE INTERNAL "Full GSI Fortran FLAGS" ) + set(ENKF_Fortran_FLAGS "${ENKF_Platform_FLAGS} ${GSDCLOUDOPT}" CACHE INTERNAL "Full ENKF Fortran FLAGS" ) + set(GSDCLOUD_Fortran_FLAGS "-O3 -convert big_endian" CACHE INTERNAL "") +endfunction(set_GSI_ENKF_Intel) + +function (set_GSI_ENKF_Debug_Intel) + set(GSI_Fortran_FLAGS "-DPOUND_FOR_STRINGIFY -O0 -fp-model source -convert big_endian -assume byterecl -implicitnone -mcmodel medium -shared-intel -g -traceback -debug -ftrapuv -check all,noarg_temp_created -fp-stack-check -fstack-protector -warn all,nointerfaces -convert big_endian -implicitnone -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS} ${GSDCLOUDOPT}" CACHE INTERNAL "") + set(ENKF_Fortran_FLAGS "-O0 ${HOST_FLAG} -warn all -implicitnone -traceback -g -debug all -check all,noarg_temp_created -fp-model strict -convert big_endian -assume byterecl -D_REAL8_ ${MPI3FLAG} ${OpenMP_Fortran_FLAGS} ${GSDCLOUDOPT}" CACHE INTERNAL "") + set(GSDCLOUD_Fortran_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -convert big_endian" CACHE INTERNAL "") + #Common debug flags + set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder" CACHE INTERNAL "" ) +endfunction (set_GSI_ENKF_Debug_Intel) + +function (setIntel) + string(REPLACE "." ";" COMPILER_VERSION_LIST ${CMAKE_C_COMPILER_VERSION}) + list(GET COMPILER_VERSION_LIST 0 MAJOR_VERSION) + list(GET COMPILER_VERSION_LIST 1 MINOR_VERSION) + list(GET COMPILER_VERSION_LIST 2 PATCH_VERSION) + set(COMPILER_VERSION "${MAJOR_VERSION}.${MINOR_VERSION}.${PATCH_VERSION}" CACHE INTERNAL "Compiler Version") + set(COMPILER_TYPE "intel" CACHE INTERNAL "Compiler brand") + STRING(COMPARE EQUAL ${CMAKE_BUILD_TYPE} "RELEASE" BUILD_RELEASE) + STRING(COMPARE EQUAL ${CMAKE_BUILD_TYPE} "PRODUCTION" BUILD_PRODUCTION) + set(EXTRA_LINKER_FLAGS ${MKL_FLAG} CACHE INTERNAL "Extra Linker flags") + if( (BUILD_RELEASE) OR (BUILD_PRODUCTION) ) + set_GSI_ENKF_Intel() + set_LIBRARY_UTIL_Intel() + else( ) #DEBUG flags + message("Building DEBUG version of GSI") + set( debug_suffix "_DBG" CACHE INTERNAL "" ) + set_GSI_ENKF_Debug_Intel() + set_LIBRARY_UTIL_Debug_Intel() + endif() +endfunction() + diff --git a/cmake/Modules/setPGIFlags.cmake b/cmake/Modules/setPGIFlags.cmake new file mode 100644 index 000000000..2088a7416 --- /dev/null +++ b/cmake/Modules/setPGIFlags.cmake @@ -0,0 +1,78 @@ +function (setPGI) + message("Setting PGI Compiler Flags") + set(COMPILER_TYPE "pgi" CACHE INTERNAL "Compiler brand") + if( (BUILD_RELEASE) OR (BUILD_PRODUCTION) ) + set(CMAKE_Fortran_FLAGS_RELEASE "") + set(Fortran_FLAGS "" CACHE INTERNAL "") + set(GSI_Fortran_FLAGS "-Minform=inform -O1 -byteswapio -D_REAL8_ ${GSDCLOUDOPT} -mp -Mfree" CACHE INTERNAL "") + set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder" CACHE INTERNAL "" ) + set(ENKF_Fortran_FLAGS " -O3 -byteswapio -fast -DGFS -D_REAL8_ -mp" CACHE INTERNAL "") + set(UTIL_Fortran_FLAGS " -O3 -byteswapio -fast -DWRF -D_REAL8_ -mp" CACHE INTERNAL "") + set(UTIL_COM_Fortran_FLAGS " -O3 -byteswapio -fast" CACHE INTERNAL "") + + set(BUFR_Fortran_FLAGS "-O1 -byteswapio -D_REAL8_ -mp -r8" CACHE INTERNAL "") + set(BUFR_Fortran_PP_FLAGS " -P " CACHE INTERNAL "") + set(BUFR_C_FLAGS " -g -DUNDERSCORE -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" CACHE INTERNAL "" ) + + set(BACIO_C_INCLUDES " -I/usr/include/malloc" CACHE INTERNAL "") + set(BACIO_Fortran_FLAGS " -O3 -byteswapio -fast -D_REAL8_ -mp -Mfree" CACHE INTERNAL "") + set(CRTM_Fortran_FLAGS " -O1 -byteswapio -module ../../include -Mfree " CACHE INTERNAL "") + set(NEMSIO_Fortran_FLAGS " -O1 -byteswapio -D_REAL8_ -mp" CACHE INTERNAL "") + set(SIGIO_Fortran_FLAGS " -O3 -Mfree -byteswapio -fast -D_REAL8_ -mp" CACHE INTERNAL "") + set(SFCIO_Fortran_FLAGS " -O3 -byteswapio -Mfree -fast -D_REAL8_ -mp" CACHE INTERNAL "") + set(SP_Fortran_FLAGS " -O1 -byteswapio -DLINUX -mp -r8 " CACHE INTERNAL "") + set(SP_Fortran_4_FLAGS " -O1 -byteswapio -DLINUX -mp " CACHE INTERNAL "") + set(SP_F77_4_FLAGS "-DLINUX -O1 -byteswapio -DLINUX -mp " CACHE INTERNAL "") + set(SP_F77_FLAGS "-DLINUX -O1 -byteswapio -DLINUX -mp -r8 " CACHE INTERNAL "") + set(W3EMC_Fortran_FLAGS " -O1 -byteswapio -D_REAL8_ -r8 " CACHE INTERNAL "") + set(W3EMC_4_Fortran_FLAGS " -O1 -byteswapio " CACHE INTERNAL "") + set(W3NCO_Fortran_FLAGS " -O1 -byteswapio -D_REAL8_ -r8 " CACHE INTERNAL "") + set(W3NCO_4_Fortran_FLAGS " -DLINUX -O1 -byteswapio " CACHE INTERNAL "") + set(W3NCO_C_FLAGS " -O1 -D_REAL8_ -mp" CACHE INTERNAL "") + set(WRFLIB_Fortran_FLAGS "-Minform=inform -O1 -byteswapio -D_REAL8_ -mp -Mfree" CACHE INTERNAL "") + set(NDATE_Fortran_FLAGS "-DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -O3 " CACHE INTERNAL "") + set(COV_CALC_FLAGS "-O3 -byteswapio -mp" CACHE INTERNAL "") + set(GSDCLOUD_Fortran_FLAGS "-O3 -byteswapio" CACHE INTERNAL "") + if ( ${CMAKE_C_COMPILER_VERSION} VERSION_LESS 18.5 ) + set( NCDIAG_Fortran_FLAGS "-Mfree -DOLDPGI" CACHE INTERNAL "" ) + else() + set( NCDIAG_Fortran_FLAGS "-Mfree" CACHE INTERNAL "" ) + endif() + else() + set(Fortran_FLAGS "" CACHE INTERNAL "") + set(GSI_Fortran_FLAGS "-Minform=inform -g -traceback -byteswapio -D_REAL8_ ${GSDCLOUDOPT} -mp -Mfree" CACHE INTERNAL "") + set(GSI_CFLAGS "-I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -traceback -Dfunder" CACHE INTERNAL "" ) + set(ENKF_Fortran_FLAGS " -g -traceback -byteswapio -fast -DGFS -D_REAL8_ -mp" CACHE INTERNAL "") + set(UTIL_Fortran_FLAGS " -g -traceback -byteswapio -fast -DWRF -D_REAL8_ -mp" CACHE INTERNAL "") + set(UTIL_COM_Fortran_FLAGS " -g -traceback -byteswapio -fast" CACHE INTERNAL "") + + set(BUFR_Fortran_FLAGS "-g -traceback -byteswapio -D_REAL8_ -mp -r8" CACHE INTERNAL "") + set(BUFR_Fortran_PP_FLAGS " -P " CACHE INTERNAL "") + set(BUFR_C_FLAGS " -g -traceback -DUNDERSCORE -DDYNAMIC_ALLOCATION -DNFILES=32 -DMAXCD=250 -DMAXNC=600 -DMXNAF=3" CACHE INTERNAL "" ) + + set(BACIO_C_INCLUDES " -I/usr/include/malloc" CACHE INTERNAL "") + set(BACIO_Fortran_FLAGS " -g -traceback -byteswapio -fast -D_REAL8_ -mp -Mfree" CACHE INTERNAL "") + set(CRTM_Fortran_FLAGS " -g -traceback -byteswapio -module ../../include -Mfree " CACHE INTERNAL "") + set(NEMSIO_Fortran_FLAGS " -g -traceback -byteswapio -D_REAL8_ -mp" CACHE INTERNAL "") + set(SIGIO_Fortran_FLAGS " -g -traceback -Mfree -byteswapio -fast -D_REAL8_ -mp" CACHE INTERNAL "") + set(SFCIO_Fortran_FLAGS " -g -traceback -byteswapio -Mfree -fast -D_REAL8_ -mp" CACHE INTERNAL "") + set(SP_Fortran_FLAGS " -g -traceback -byteswapio -DLINUX -mp -r8 " CACHE INTERNAL "") + set(SP_Fortran_4_FLAGS " -g -traceback -byteswapio -DLINUX -mp " CACHE INTERNAL "") + set(SP_F77_4_FLAGS "-DLINUX -g -traceback -byteswapio -DLINUX -mp " CACHE INTERNAL "") + set(SP_F77_FLAGS "-DLINUX -g -traceback -byteswapio -DLINUX -mp -r8 " CACHE INTERNAL "") + set(W3EMC_Fortran_FLAGS " -g -traceback -byteswapio -D_REAL8_ -r8 " CACHE INTERNAL "") + set(W3EMC_4_Fortran_FLAGS " -g -traceback -byteswapio " CACHE INTERNAL "") + set(W3NCO_Fortran_FLAGS " -g -traceback -byteswapio -D_REAL8_ -r8 " CACHE INTERNAL "") + set(W3NCO_4_Fortran_FLAGS " -g -traceback -byteswapio " CACHE INTERNAL "") + set(W3NCO_C_FLAGS " -DLINUX -g -traceback -D_REAL8_ -mp" CACHE INTERNAL "") + set(WRFLIB_Fortran_FLAGS "-Minform=inform -g -traceback -byteswapio -D_REAL8_ -mp -Mfree" CACHE INTERNAL "") + set(NDATE_Fortran_FLAGS "-DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -g -traceback " CACHE INTERNAL "") + set(COV_CALC_FLAGS "-O3 -byteswapio -traceback -mp" CACHE INTERNAL "") + set(GSDCLOUD_Fortran_FLAGS "-O3 -byteswapio" CACHE INTERNAL "") + if ( ${CMAKE_C_COMPILER_VERSION} VERSION_LESS 18.5 ) + set( NCDIAG_Fortran_FLAGS "-Mfree -DOLDPGI" CACHE INTERNAL "" ) + else() + set( NCDIAG_Fortran_FLAGS "-Mfree" CACHE INTERNAL "" ) + endif() + endif( (BUILD_RELEASE) OR (BUILD_PRODUCTION) ) +endfunction() diff --git a/cmake/Modules/setPlatformVariables.cmake b/cmake/Modules/setPlatformVariables.cmake index b22b841fc..728e1a3e7 100644 --- a/cmake/Modules/setPlatformVariables.cmake +++ b/cmake/Modules/setPlatformVariables.cmake @@ -1,236 +1,10 @@ -function (setWCOSS) - message("Setting paths for WCOSS") - set(HDF5_USE_STATIC_LIBRARIES "OFF") - #if ibmpe module is not loaded last, CMake tries to use intel mpi. Force use of ibmhpc - set( MPI_Fortran_COMPILER /opt/ibmhpc/pe13010/base/bin/mpif90 CACHE FILEPATH "Forced use of ibm wrapper" FORCE ) - set( MPI_C_COMPILER /opt/ibmhpc/pe13010/base/bin/mpicc CACHE FILEPATH "Forced use of ibm wrapper" FORCE ) - set( MPI_CXX_COMPILER /opt/ibmhpc/pe13010/base/bin/mpicxx CACHE FILEPATH "Forced use of ibm wrapper" FORCE ) - if( NOT DEFINED ENV{COREPATH} ) - set(COREPATH "/nwprod/lib" PARENT_SCOPE ) - else() - set(COREPATH $ENV{COREPATH} PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{CRTM_INC} ) - set(CRTM_BASE "/nwprod2/lib" PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{WRFPATH} ) - set(WRFPATH "/nwprod/sorc/wrf_shared.fd" PARENT_SCOPE ) - else() - set(WRFPATH $ENV{WRFPATH} PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{NETCDF_VER} ) - set(NETCDF_VER "3.6.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BACIO_VER} ) - set(BACIO_VER "2.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BUFR_VER} ) - set(BUFR_VER "10.2.5" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{CRTM_VER} ) - set(CRTM_VER "2.2.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{NEMSIO_VER} ) - set(NEMSIO_VER "2.2.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SFCIO_VER} ) - set(SFCIO_VER "1.0.0" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SIGIO_VER} ) - set(SIGIO_VER "2.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SP_VER} ) - set(SP_VER "2.0.2" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3EMC_VER} ) - set(W3EMC_VER "2.0.5" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3NCO_VER} ) - set(W3NCO_VER "2.0.6" PARENT_SCOPE) - endif() -endfunction() -function (setTHEIA) - message("Setting paths for THEIA") - set(HDF5_USE_STATIC_LIBRARIES "OFF") - if( NOT DEFINED ENV{COREPATH} ) - set(COREPATH "/scratch3/NCEPDEV/nwprod/lib" PARENT_SCOPE ) - else() - set(COREPATH $ENV{COREPATH} PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{CRTM_INC} ) - set(CRTM_BASE "/scratch4/NCEPDEV/da/save/Michael.Lueken/nwprod/lib/crtm" PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{WRFPATH} ) - set(WRFPATH "/scratch3/NCEPDEV/nceplibs/ext/WRF/3.7/WRFV3" PARENT_SCOPE ) - else() - set(WRFPATH $ENV{WRFPATH} PARENT_SCOPE ) - endif() - - if( NOT DEFINED ENV{NETCDF_VER} ) - set(NETCDF_VER "3.6.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BACIO_VER} ) - set(BACIO_VER "2.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BUFR_VER} ) - set(BUFR_VER "10.2.5" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{CRTM_VER} ) - set(CRTM_VER "2.2.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{NEMSIO_VER} ) - set(NEMSIO_VER "2.2.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SFCIO_VER} ) - set(SFCIO_VER "1.0.0" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SIGIO_VER} ) - set(SIGIO_VER "2.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SP_VER} ) - set(SP_VER "2.0.2" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3EMC_VER} ) - set(W3EMC_VER "2.0.5" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3NCO_VER} ) - set(W3NCO_VER "2.0.6" PARENT_SCOPE) - endif() -endfunction() - -function (setS4) - message("Setting paths for S4") - set(HDF5_USE_STATIC_LIBRARIES "OFF") - if( NOT DEFINED ENV{COREPATH} ) - set(COREPATH "/usr/local/jcsda/nwprod_gdas_2014/lib" PARENT_SCOPE ) - else() - set(COREPATH $ENV{COREPATH} PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{CRTM_INC} ) - set(CRTM_BASE "/usr/local/jcsda/NESDIS-JCSDA/tools_R2O/nwprod_2016q1/GFS_LIBs/CRTM_REL-2.2.3/crtm_v2.2.3" PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{WRFPATH} ) - set(WRFPATH "/usr/local/jcsda/nwprod_gdas_2014/sorc/nam_nmm_real_fcst.fd" PARENT_SCOPE ) - else() - set(WRFPATH $ENV{WRFPATH} PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{NETCDF_VER} ) - set(NETCDF_VER "4.3.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BACIO_VER} ) - set(BACIO_VER "2.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BUFR_VER} ) - set(BUFR_VER "10.2.5" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{CRTM_VER} ) - set(CRTM_VER "2.2.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{NEMSIO_VER} ) - set(NEMSIO_VER "2.2.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SFCIO_VER} ) - set(SFCIO_VER "1.0.0" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SIGIO_VER} ) - set(SIGIO_VER "2.0.1_beta" PARENT_SCOPE) - set(ENV{SIGIO_LIB4} "/usr/local/jcsda/nwprod_gdas_2014/lib/sorc/sigio_v2.0.1_beta/sigio_v2.0.1_beta/libsigio_v2.0.1_beta.a") - set(ENV{SIGIO_INC4} "/usr/local/jcsda/nwprod_gdas_2014/lib/sorc/sigio_v2.0.1_beta/sigio_v2.0.1_beta/incmod/sigio_v2.0.1_beta" ) - endif() - if( NOT DEFINED ENV{SP_VER} ) - set(SP_VER "2.0.2" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3EMC_VER} ) - set(W3EMC_VER "2.0.5" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3NCO_VER} ) - set(W3NCO_VER "2.0.6" PARENT_SCOPE) - endif() -endfunction() -function (setCRAY) - message("Setting paths for Cray") - set(HDF5_USE_STATIC_LIBRARIES "ON") -# set( OMPFLAG "-openmp" PARENT_SCOPE ) - if( NOT DEFINED ENV{COREPATH} ) - set(COREPATH "/gpfs/hps/nco/ops/nwprod/lib" PARENT_SCOPE ) - else() - set(COREPATH $ENV{COREPATH} PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{CRTM_INC} ) - set(CRTM_BASE "/gpfs/hps/nco/ops/nwprod/lib/crtm" PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{WRFPATH} ) - if(CMAKE_CXX_COMPILER_ID STREQUAL "Intel") - set(WRFPATH "/gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-intel" PARENT_SCOPE ) - else() - set(WRFPATH "/gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-cray" PARENT_SCOPE ) - endif() - else() - set(WRFPATH $ENV{WRFPATH} PARENT_SCOPE ) - endif() - if( NOT DEFINED ENV{NETCDF_VER} ) - set(NETCDF_VER "3.6.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BACIO_VER} ) - set(BACIO_VER "2.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BUFR_VER} ) - set(BUFR_VER "11.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{CRTM_VER} ) - set(CRTM_VER "2.2.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{NEMSIO_VER} ) - set(NEMSIO_VER "2.2.2" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SFCIO_VER} ) - set(SFCIO_VER "1.0.0" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SIGIO_VER} ) - set(SIGIO_VER "2.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SP_VER} ) - set(SP_VER "2.0.2" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3EMC_VER} ) - set(W3EMC_VER "2.2.0" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3NCO_VER} ) - set(W3NCO_VER "2.0.6" PARENT_SCOPE) - endif() -endfunction() -function (setGeneric) - message("Setting paths for Generic System") - set(HDF5_USE_STATIC_LIBRARIES "OFF") - set(COREPATH $ENV{COREPATH} PARENT_SCOPE ) - if( NOT DEFINED ENV{NETCDF_VER} ) - set(NETCDF_VER "3.6.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BACIO_VER} ) - set(BACIO_VER "2.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{BUFR_VER} ) - set(BUFR_VER "10.2.5" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{CRTM_VER} ) - set(CRTM_VER "2.2.3" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{NEMSIO_VER} ) - set(NEMSIO_VER "2.2.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SFCIO_VER} ) - set(SFCIO_VER "1.1.0" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SIGIO_VER} ) - set(SIGIO_VER "2.0.1" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{SP_VER} ) - set(SP_VER "2.0.2" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3EMC_VER} ) - set(W3EMC_VER "2.2.0" PARENT_SCOPE) - endif() - if( NOT DEFINED ENV{W3NCO_VER} ) - set(W3NCO_VER "2.0.6" PARENT_SCOPE) - endif() -endfunction() +include(${CMAKE_CURRENT_LIST_DIR}/platforms/Jet.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/platforms/WCOSS.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/platforms/WCOSS-C.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/platforms/S4.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/platforms/Hera.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/platforms/Gaea.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/platforms/Cheyenne.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/platforms/Discover.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/platforms/WCOSS-D.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/platforms/Generic.cmake) diff --git a/compile b/compile new file mode 100755 index 000000000..b08d6fcfa --- /dev/null +++ b/compile @@ -0,0 +1,10 @@ +#!/bin/sh + +set -xe + +echo "Building ProdGSI ..." +cd ush +./build_all_cmake_hwrf.sh + +echo "Building ProdGSI done." + diff --git a/configure b/configure new file mode 100755 index 000000000..dddc6ba49 --- /dev/null +++ b/configure @@ -0,0 +1,6 @@ +#!/bin/sh + +set -x + +echo "Using CMake to build ProdGSI, do nothing with this configure step" + diff --git a/core-libs/CMakeLists.txt b/core-libs/CMakeLists.txt deleted file mode 100644 index 05d528d9a..000000000 --- a/core-libs/CMakeLists.txt +++ /dev/null @@ -1,31 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -message("in core-libs") -if(BUILD_CORELIBS) - if(BUILD_CRTM) - add_subdirectory(crtm) - endif() - if(BUILD_BACIO) - add_subdirectory(bacio) - endif() - if(BUILD_BUFR) - add_subdirectory(bufr) - endif() - if(BUILD_SFCIO) - add_subdirectory(sfcio) - endif() - if(BUILD_SIGIO) - add_subdirectory(sigio) - endif() - if(BUILD_NEMSIO) - add_subdirectory(nemsio) - endif() - if(BUILD_SP) - add_subdirectory(sp) - endif() - if(BUILD_EMC) - add_subdirectory(w3emc) - endif() - if(BUILD_NCO) - add_subdirectory(w3nco) - endif() -endif() diff --git a/core-libs/bacio/CMakeLists.txt b/core-libs/bacio/CMakeLists.txt deleted file mode 100644 index 154ad7a4e..000000000 --- a/core-libs/bacio/CMakeLists.txt +++ /dev/null @@ -1,10 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -if(BUILD_CORELIBS) - file(GLOB BACIO_SRC ${BACIO_DIR}/*.f) - set_source_files_properties( ${BACIO_SRC} PROPERTIES COMPILE_FLAGS ${BACIO_Fortran_FLAGS} ) - file(GLOB BACIO_C_SRC ${BACIO_DIR}/*.c) - set(CMAKE_C_FLAGS "${BACIO_C_INCLUDES} -DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long'") - add_library( ${bacio} STATIC ${BACIO_SRC} ${BACIO_C_SRC} ) - set_target_properties( ${bacio} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - -endif() diff --git a/core-libs/bufr/CMakeLists.txt b/core-libs/bufr/CMakeLists.txt deleted file mode 100644 index a597f6948..000000000 --- a/core-libs/bufr/CMakeLists.txt +++ /dev/null @@ -1,22 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -#message("in bufr") -if(BUILD_CORELIBS) - file(GLOB BUFR_F77_SRC ${BUFR_DIR}/*.f ${BUFR_DIR}/*.F) - file(GLOB BUFR_C_SRC ${BUFR_DIR}/*.c) - file(GLOB BUFR_PRM ${BUFR_DIR}/*.PRM) - - ADD_CUSTOM_COMMAND( OUTPUT "${CMAKE_INCLUDE_OUTPUT_DIRECTORY}/bufrlib.prm" - PRE_BUILD - COMMAND cpp -P -D_REAL8_ -DWRF -DLINUX -DPGI -traditional-cpp ${BUFR_DIR}/bufrlib.PRM -o ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}/bufrlib.prm - DEPENDS ${BUFR_DIR}/bufrlib.PRM - ) - add_custom_target(bufrlib_prm DEPENDS ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}/bufrlib.prm ) - if( BUFR_F77_SRC ) - set_source_files_properties( ${BUFR_F77_SRC} COMPILE_FLAGS ${BUFR_Fortran_FLAGS}) - endif() - set_source_files_properties( ${BUFR_C_SRC} COMPILE_FLAGS ${BUFR_C_FLAGS} ) - - add_library( ${bufr} STATIC ${BUFR_C_SRC} ${BUFR_F77_SRC} ) - add_dependencies(${bufr} bufrlib_prm) - set_target_properties( ${bufr} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) -endif() diff --git a/core-libs/crtm/CMakeLists.txt b/core-libs/crtm/CMakeLists.txt deleted file mode 100644 index b3e5141d4..000000000 --- a/core-libs/crtm/CMakeLists.txt +++ /dev/null @@ -1,26 +0,0 @@ -cmake_minimum_required(VERSION 2.6) - -if(BUILD_CORELIBS) - file(GLOB CRTM_FPP_SRC ${CRTM_DIR}/*.fpp) - set(CRTM_PP_SRC "") - FOREACH( fppfile ${CRTM_FPP_SRC} ) - get_filename_component(SRC_WITHOUT_EXT ${fppfile} NAME_WE) - set(F_SRC_FILE "${SRC_WITHOUT_EXT}.F") - ADD_CUSTOM_COMMAND( - OUTPUT ${CMAKE_CURRENT_SOURCE_DIR}/${F_SRC_FILE} - PRE_BUILD - COMMAND ${CMAKE_COMMAND} -E copy ${fppfile} ${CMAKE_CURRENT_SOURCE_DIR}/${F_SRC_FILE} - DEPENDS ${fppfile} - ) - list(APPEND CRTM_PP_SRC "${F_SRC_FILE}") - endforeach() - ADD_CUSTOM_TARGET(copy ALL DEPENDS ${CRTM_PP_SRC} ) - file(GLOB CRTM_SRC ${CRTM_DIR}/*.f90 ) - set_source_files_properties( ${CRTM_PP_SRC} COMPILE_FLAGS ${CRTM_Fortran_FLAGS} ) - set_source_files_properties( ${CRTM_SRC} COMPILE_FLAGS ${CRTM_Fortran_FLAGS} ) - - set(CMAKE_Fortran_FLAGS_RELEASE "") - add_library( ${crtm} STATIC ${CRTM_SRC} ${CRTM_PP_SRC} ) - set_target_properties( ${crtm} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - include_directories( ${CRTM_DIR} ) -endif() diff --git a/core-libs/io_int/CMakeLists.txt b/core-libs/io_int/CMakeLists.txt deleted file mode 100644 index 471444c63..000000000 --- a/core-libs/io_int/CMakeLists.txt +++ /dev/null @@ -1,7 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -if(BUILD_CORELIBS) - file(GLOB IO_INT_SRC *.f90) - add_library( io_int${libsuffix} STATIC ${IO_INT_SRC} ) - set_target_properties( io_int${libsuffix} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - -endif() diff --git a/core-libs/nemsio/CMakeLists.txt b/core-libs/nemsio/CMakeLists.txt deleted file mode 100644 index bb3d54131..000000000 --- a/core-libs/nemsio/CMakeLists.txt +++ /dev/null @@ -1,8 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -if(BUILD_CORELIBS) - file(GLOB NEMSIO_SRC ${NEMSIO_DIR}/*.f90) - set_source_files_properties( ${NEMSIO_SRC} COMPILE_FLAGS ${NEMSIO_Fortran_FLAGS} ) - add_library( ${nemsio} STATIC ${NEMSIO_SRC} ) - set_target_properties( ${nemsio} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - -endif() diff --git a/core-libs/sfcio/CMakeLists.txt b/core-libs/sfcio/CMakeLists.txt deleted file mode 100644 index 8621a1ce5..000000000 --- a/core-libs/sfcio/CMakeLists.txt +++ /dev/null @@ -1,9 +0,0 @@ -cmake_minimum_required(VERSION 2.6) - -if(BUILD_CORELIBS) - file(GLOB SFCIO_SRC ${SFCIO_DIR}/*.f90 ${SFCIO_DIR}/*.f ) - set_source_files_properties( ${SFCIO_SRC} COMPILE_FLAGS ${SFCIO_Fortran_FLAGS} ) - add_library( ${sfcio} STATIC ${SFCIO_SRC} ) - set_target_properties( ${sfcio} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - -endif() diff --git a/core-libs/sigio/CMakeLists.txt b/core-libs/sigio/CMakeLists.txt deleted file mode 100644 index d42934d5b..000000000 --- a/core-libs/sigio/CMakeLists.txt +++ /dev/null @@ -1,8 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -if(BUILD_CORELIBS) - file(GLOB SIGIO_SRC ${SIGIO_DIR}/*.f) - set_source_files_properties( ${SIGIO_SRC} COMPILE_FLAGS ${SIGIO_Fortran_FLAGS} ) - add_library( ${sigio} STATIC ${SIGIO_SRC} ) - set_target_properties( ${sigio} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - -endif() diff --git a/core-libs/sp/CMakeLists.txt b/core-libs/sp/CMakeLists.txt deleted file mode 100644 index 862e118ee..000000000 --- a/core-libs/sp/CMakeLists.txt +++ /dev/null @@ -1,11 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -if(BUILD_CORELIBS) - file(GLOB SP_SRC ${SP_DIR}/*.f ) - set_source_files_properties( ${SP_SRC} PROPERTIES COMPILE_FLAGS ${SP_Fortran_FLAGS} ) - file(GLOB SP_F77_SRC ${SP_DIR}/*.F ) - if( SP_F77_SRC ) - set_source_files_properties( ${SP_F77_SRC} PROPERTIES COMPILE_FLAGS ${SP_F77_FLAGS} ) - endif() - add_library( ${sp} STATIC ${SP_SRC} ${SP_F77_SRC} ) - set_target_properties( ${sp} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) -endif() diff --git a/core-libs/w3emc/CMakeLists.txt b/core-libs/w3emc/CMakeLists.txt deleted file mode 100644 index d22bd53c8..000000000 --- a/core-libs/w3emc/CMakeLists.txt +++ /dev/null @@ -1,13 +0,0 @@ -cmake_minimum_required(VERSION 2.8) -if(BUILD_CORELIBS) - file(GLOB W3EMC_SRC ${W3EMC_DIR}/*.F) - file(GLOB W3EMC_F77_SRC ${W3EMC_DIR}/*.f) - set_source_files_properties( ${W3EMC_F77_SRC} COMPILE_FLAGS ${W3EMC_Fortran_FLAGS}) - set_source_files_properties( ${W3EMC_SRC} COMPILE_FLAGS ${W3EMC_Fortran_FLAGS}) - include_directories(${SIGIOINC}) - add_library( ${w3emc} STATIC ${W3EMC_SRC} ${W3EMC_F77_SRC} ) - set_target_properties( ${w3emc} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - - add_dependencies(${w3emc} ${sigio} ) - -endif() diff --git a/core-libs/w3nco/CMakeLists.txt b/core-libs/w3nco/CMakeLists.txt deleted file mode 100644 index 15283a7bd..000000000 --- a/core-libs/w3nco/CMakeLists.txt +++ /dev/null @@ -1,12 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -if(BUILD_CORELIBS) - set (CMAKE_C_FLAGS "-O0 -DUNDERSCORE -DLINUX -D__linux__") - file(GLOB W3NCO_SRC ${W3NCO_DIR}/*.f) - file(GLOB W3NCO_C_SRC ${W3NCO_DIR}/*.c) - file(GLOB W3NCO_F77_SRC ${W3NCO_DIR}/*.F) - set_source_files_properties( ${W3NCO_C_SRC} COMPILE_FLAGS ${W3NCO_C_FLAGS}) - set_source_files_properties( ${W3NCO_F77_SRC} COMPILE_FLAGS ${W3NCO_Fortran_FLAGS}) - set_source_files_properties( ${W3NCO_SRC} COMPILE_FLAGS ${W3NCO_Fortran_FLAGS}) - add_library( ${w3nco} STATIC ${W3NCO_C_SRC} ${W3NCO_SRC} ${W3NCO_F77_SRC} ) - set_target_properties( ${w3nco} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) -endif() diff --git a/doc/EnKF_user_guide/.gitignore b/doc/EnKF_user_guide/.gitignore new file mode 100644 index 000000000..3b4dab087 --- /dev/null +++ b/doc/EnKF_user_guide/.gitignore @@ -0,0 +1,10 @@ +main.aux +main.bbl +main.blg +main.idx +main.log +main.out +main.pdf +main.synctex.gz +main.toc +*.pdf diff --git a/doc/EnKF_user_guide/README b/doc/EnKF_user_guide/README new file mode 100644 index 000000000..549499b80 --- /dev/null +++ b/doc/EnKF_user_guide/README @@ -0,0 +1,24 @@ +This directory contains the latex source for creating the enkf user's guide. This document requires +an instillation of latex that supports the CTAN extensions. + +1. Required flavor of LaTex. +Options for the three main platforms. + +Windows: +The most popular choice here is the MiKTEX (http://www.miktex.org) distribution, which lets you easily +manage TEX packages. Many people advise beginners to get the proTEXt bundling of MiKTEX, which lets you +install by using a .pdf file with links so you can read about your options and then click on the right +one. And it includes other components that help you work with your TEX system. + +Unix-type systems, including GNU/Linux: +The best choice here is TEX Live (http://tug.org/texlive/), which contains many packages and programs. +It is freely available over the Internet or on disc; see the web page for details. Note that most Unix +systems have TEX as an installation option so you might already have it or be able to easily get it using +your system administration package management tool: RPM, or DEB, or whatever. + +Mac­in­tosh: +Get the MacTEX (http://tug.org/mactex/) distribution, which is TEX Live with some Mac specific goodies. + +2. Building the user's guide document. +Run LaTex on the file main.tex. It imports organizes each of the individual chapter files. This creates +the document main.pdf. diff --git a/doc/EnKF_user_guide/ack.tex b/doc/EnKF_user_guide/ack.tex index 1f999b27d..7fea57260 100644 --- a/doc/EnKF_user_guide/ack.tex +++ b/doc/EnKF_user_guide/ack.tex @@ -8,7 +8,7 @@ \textcolor{darkgray}{\LARGE Acknowledgement} \vspace*{1cm}\par -We thank the National Oceanic and Atmospheric Administration (NOAA) Hurricane Forecast Improvement Program (HFIP) and Office of Oceanic and Atmospheric Research (OAR) for their support of this work. This work is also facilitated by the National Center for Atmospheric Research (NCAR). NCAR is supported by the National Science Foundation (NSF). +We thank the National Oceanic and Atmospheric Administration (NOAA) Office of Oceanic and Atmospheric Research (OAR) for their support of this work. This work is also facilitated by the National Center for Atmospheric Research (NCAR). NCAR is supported by the National Science Foundation (NSF). \end{flushleft} \end{titlepage} diff --git a/doc/EnKF_user_guide/enkf_appendix_A.tex b/doc/EnKF_user_guide/enkf_appendix_A.tex index a9b73c7c2..cf645f166 100644 --- a/doc/EnKF_user_guide/enkf_appendix_A.tex +++ b/doc/EnKF_user_guide/enkf_appendix_A.tex @@ -1,4 +1,4 @@ -\chapter{Content of Namelist} +\chapter{Content of Namelist}\label{nameless} The following are lists and explanations of the EnKF namelist variables. Users can also check file \textit{params.f90} for the details. \\ @@ -11,13 +11,18 @@ \chapter{Content of Namelist} \hline datein&Analysis date in YYYYMMDDHH&integer&0\\ datapath&path to data directory (include trailing slash)&Character (len=500) &""\\ -iassim\_order&= 0 for the order they are read in,\newline =1 for random order\newline = 2 for order of predicted posterior variance reduction (based on prior) &integer&0\\ +iassim\_order&= 0 for the order they are read in,\newline +=1 for random order\newline += 2 for order of predicted posterior variance reduction (based on prior) &integer&0\\ covinflatemax&maximum inflation&real(r\_single)&1.e30\\ covinflatemin&minimum inflation&real(r\_single)&1.0\\ deterministic&if true, use EnSRF w/o perturbed obs.\newline - if false, use perturbed obs EnKF. & logical & true\\ sortinc&if false, re-order obs to minimize regression - errors as described in Anderson (2003). &logical &true\\ corrlengthnh&length for horizontal localization (in km) in north hemisphere&real(r\_single)&2800\\ corrlengthtr&length for horizontal localization (in km) in tropic&real(r\_single)&2800\\ -corrlengthsh&length for horizontal localization (in km) in south hemisphere&real(r\_single)&2800\\ + if false, use perturbed obs EnKF. & logical & true\\ +sortinc&if false, re-order obs to minimize regression + errors as described in Anderson (2003). &logical &true\\ +corrlengthnh&length for horizontal localization (in km) in north hemisphere&real(r\_single)&2800\\ +corrlengthtr&length for horizontal localization (in km) in tropic&real(r\_single)&2800\\ +corrlengthsh&length for horizontal localization (in km) in south hemisphere&real(r\_single)&2800\\ \hline \end{tabular} \end{table} @@ -29,17 +34,22 @@ \chapter{Content of Namelist} \hline Variable Name&Description&Data Type&Default\\ \hline -varqc&Turn on varqc & logical & false \\ huber&use huber norm instead of "flat-tail" &logical & fales\\ -nlons&number of lons &integer&0\\ nlats&Number of lats & integer & 0\\ +varqc&Turn on varqc & logical & false \\ +huber&use huber norm instead of "flat-tail" &logical & fales\\ +nlons&number of lons &integer&0\\ +nlats&Number of lats & integer & 0\\ smoothparm&smoothing parameter for inflation (-1 for no smoothing) & real(r\_single) & -1\\ -readin\_localization&If true, read in localization length scales from an external file & logical & false\\ zhuberleft&Parameter for "huber norm" QC & real(r\_single) & 1.e30\\ +readin\_localization&If true, read in localization length scales from an external file & logical & false\\ +zhuberleft&Parameter for "huber norm" QC & real(r\_single) & 1.e30\\ zhuberright&Parameter for "huber norm" QC & real(r\_single) &1.e30\\ - obtimelnh&observation time localization in hours over north hemisphere & real(r\_single) &25.925\\ obtimeltr&observation time localization in hours over tropic & real(r\_single) & 25.925\\ + obtimelnh&observation time localization in hours over north hemisphere & real(r\_single) &25.925\\ +obtimeltr&observation time localization in hours over tropic & real(r\_single) & 25.925\\ obtimelsh& observation time localization in hours over south hemisphere & real(r\_single) &25.925\\ reducedgrid & Do smooth in a reduced grid with a variable number on longitudes per latitude. The number of longitudes is chosen so that the zonal grid -spacing is approximately the same as at the equator & logical & false \\ lnsigcutoffnh & length for vertical localization in ln(p) over north hemisphere for conventional observation&real(r\_single)& 2.0\\ +spacing is approximately the same as at the equator & logical & false \\ +lnsigcutoffnh & length for vertical localization in ln(p) over north hemisphere for conventional observation&real(r\_single)& 2.0\\ lnsigcutofftr &length for vertical localization in ln(p) over tropic conventional observation&real(r\_single)&2.0\\ lnsigcutoffsh &length for vertical localization in ln(p) over south hemisphere for conventional observation&real(r\_single) &2.0\\ lnsigcutoffsatnh &length for vertical localization in ln(p) over north hemisphere for satellite radiance observation&real(r\_single)& -999.0\\ @@ -54,7 +64,9 @@ \chapter{Content of Namelist} - + + + \begin{table}[htbp] \centering \begin{tabular}{p{3cm}p{7cm}p{2.5cm}p{1.5cm}} @@ -63,19 +75,28 @@ \chapter{Content of Namelist} \hline analpertwtnh&adaptive posterior inflation parameter over north hemisphere:\newline 1 means inflate all the way back to prior spread&real(r\_single)& 0.0\\ - analpertwtsh & adaptive posterior inflation parameter over tropic:\newline 1 means inflate all the way back to prior spread&real(r\_single) &0.0\\ - analpertwttr&adaptive posterior inflation parameter over south hemisphere:\newline 1 means inflate all the way back to prior spread&real(r\_single) &0.0\\ sprd\_tol&tolerance for background check: observations are not used if they are more than sqrt(S+R) from mean, - where S is ensemble variance and R is observation error variance. &real(r\_single) &9.9e31\\ nlevs &total number of levels&integer &0\\ + analpertwtsh & adaptive posterior inflation parameter over tropic:\newline +1 means inflate all the way back to prior spread&real(r\_single) &0.0\\ + analpertwttr&adaptive posterior inflation parameter over south hemisphere:\newline +1 means inflate all the way back to prior spread&real(r\_single) &0.0\\ +sprd\_tol&tolerance for background check: +observations are not used if they are more than sqrt(S+R) from mean, + where S is ensemble variance and R is observation error variance. &real(r\_single) &9.9e31\\ +nlevs &total number of levels&integer &0\\ nanals&number of ensemble members&integer & 0\\ - nvars&number of 3d variables to update. For hydrostatic models, typically 5 (u,v,T,q,ozone).&integer &5\\ saterrfact &factor to multiply sat radiance errors&real(r\_single) &1.0\\ + nvars&number of 3d variables to update. For hydrostatic models, typically 5 (u,v,T,q,ozone).&integer &5\\ +saterrfact &factor to multiply sat radiance errors&real(r\_single) &1.0\\ univaroz &If true, ozone observations only affect ozone &logical &true\\ regional &If true, analysis is for regional&logical &false\\ use\_gfs\_nemsio&If true, GFS background is in NEMS format&logical& false\\ paoverpb\_thresh &if observation space posterior variance divided by prior variance less than this value, -observation is skipped during serial processing. \newline 1.0 = don't skip any obs &(r\_single) &1.0\\ latbound &definition of tropics and mid-latitudes (for inflation). &real(r\_single) &25.0\\ +observation is skipped during serial processing. \newline +1.0 = don't skip any obs &(r\_single) &1.0\\ +latbound &definition of tropics and mid-latitudes (for inflation). &real(r\_single) &25.0\\ delat &width of transition zone &real(r\_single)& 10.0\\ pseudo\_rh &use 'pseudo-rh' analysis variable, as in GSI &logical & false\\ -numiter&number of times to iterate state/bias correction update. (only relevant when satellite radiances assimilated, i.e. nobs\_sat>0)&integer &1.0\\ \hline +numiter&number of times to iterate state/bias correction update. (only relevant when satellite radiances assimilated, i.e. nobs\_sat>0)&integer &1.0\\ +\hline \end{tabular} \end{table} @@ -87,12 +108,19 @@ \chapter{Content of Namelist} \hline Variable Name&Description&Data Type&Default\\ \hline -biasvar&background error variance for rad bias coeffs (used in radbias.f90). Default is (old) GSI value.\newline if negative, bias coeff error variace is set to - biasvar/N, where N is number of obs per instrument/channel.\newline if newpc4pred is .true., biasvar is not used - the estimated analysis error variance from the previous cycle is +biasvar&background error variance for rad bias coeffs (used in radbias.f90). Default is (old) GSI value.\newline +if negative, bias coeff error variace is set to - biasvar/N, where N is number of obs per instrument/channel.\newline +if newpc4pred is .true., biasvar is not used - the estimated analysis error variance from the previous cycle is used instead (same as in the GSI). &real(r\_single) &0.1\\ lupd\_satbiasc&if performing satellite bias correction update&logical &true\\ - cliptracers&if true, tracers are clipped to zero when read in, and just before they are written out.&logical& true\\ simple\_partition &partition obs for enkf using Graham's rule&logical &true\\ - adp\_anglebc&turn off or on the variational radiance angle bias correction&logical& false\\ angord &order of polynomial for angle bias correction&Integer& 0\\ - newpc4pred&controls preconditioning due to sat-bias correction term&logical&\\ nmmb&If true, ensemble forecast is NMMB&logical &false\\ iau&&logical &false\\ nhr\_anal&background forecast time for analysis&integer &6\\ + cliptracers&if true, tracers are clipped to zero when read in, and just before they are written out.&logical& true\\ +simple\_partition &partition obs for enkf using Graham's rule&logical &true\\ + adp\_anglebc&turn off or on the variational radiance angle bias correction&logical& false\\ +angord &order of polynomial for angle bias correction&Integer& 0\\ + newpc4pred&controls preconditioning due to sat-bias correction term&logical&\\ +nmmb&If true, ensemble forecast is NMMB&logical &false\\ +iau&&logical &false\\ +nhr\_anal&background forecast time for analysis&integer &6\\ letkf\_flag&If true, do LETKF&logical& false\\ boxsize &Observation box size for LETKF (deg)&real(r\_single) &90.0\\ massbal\_adjust&mass balance adjustment for GFS&logical &false\\ @@ -113,7 +141,8 @@ \chapter{Content of Namelist} \hline arw ®ional dynamical core ARW&logical &false\\ nmm®ional dynamical core NMM&logical& true\\ -doubly\_periodic&&logical&true\\ \hline +doubly\_periodic&&logical&true\\ +\hline \end{tabular} \end{table} @@ -127,7 +156,7 @@ \chapter{Content of Namelist} sattypes\_rad&strings describing the satellite data type (which form part of the diag* filename).& character(len=20) array (nsatmax\_rad) & '"" \\ dsis&strings corresponding to sattypes\_rad which correspond to the names in the NCEP global\_satinfo file.& -character(len=20) array (nsatmax\_rad)&""\\ +character(len=20) array (nsatmax\_rad)&""\\ \hline \end{tabular} \end{table} diff --git a/doc/EnKF_user_guide/enkf_ch1.tex b/doc/EnKF_user_guide/enkf_ch1.tex index fc7eac87d..d6ddc017a 100644 --- a/doc/EnKF_user_guide/enkf_ch1.tex +++ b/doc/EnKF_user_guide/enkf_ch1.tex @@ -1,4 +1,4 @@ -\chapter{Overview} +\chapter{Overview}\label{overview} %---------------------------------------------- \section{EnKF History and Background} @@ -55,7 +55,7 @@ \subsection{Community Code Contributions} \section{About This EnKF Release} %---------------------------------------------- -This user\textquotesingle s guide was composed for the EnKF community release version(v) 1.1. This version of EnKF is compatible with the GSI community release v3.5. Please note the major focuses of the DTC are currently on testing and evaluation of EnKF for regional numerical weather prediction (NWP) applications though the instructions and cases for EnKF global applications are available with this release. +This user\textquotesingle s guide was composed for the EnKF community release version(v) 1.2. This version of EnKF is compatible with the GSI community release v3.6. Please note the major focuses of the DTC are currently on testing and evaluation of EnKF for regional numerical weather prediction (NWP) applications though the instructions and cases for EnKF global applications are available with this release. Running this EnKF system requires running GSI a prior for its observation operators. Therefore, the GSI @@ -63,10 +63,10 @@ \section{About This EnKF Release} \subsection{What Is New in This Release Version} -Major updates to this version of EnKF are code optimization, including bug fixes and code cleanup. Added features include new capabilities to update multiple-time background ensembles and use of the NCEP I/O library \textit {nemio}. The observation types assimilated by EnKF were also updated as part of the GSI v3.5 updates. +Major updates to this version of EnKF are code optimization, including bug fixes and code cleanup. Added features include a new namelist to speed up the reading of GSI diagnostic files and added ensemble spread calculation utility for GFS sigma files . The observation types assimilated by EnKF were also updated as part of the GSI v3.6 updates. \subsection{Observations Used by This Version } -EnKF is using the GSI system as the observation operator to generate observation innovations. Therefore, the observation types assimilated by EnKF are the same as GSI. This version of EnKF has been tested to work with the community GSI release v3.5. It can assimilate, but is not limited to, the following types of observations: +EnKF is using the GSI system as the observation operator to generate observation innovations. Therefore, the observation types assimilated by EnKF are the same as GSI. This version of EnKF has been tested to work with the community GSI release v3.6. It can assimilate, but is not limited to, the following types of observations: \textbf{Conventional observations (including satellite retrievals):} \begin{itemize} @@ -88,13 +88,11 @@ \subsection{Observations Used by This Version } \item Quick Scatterometer (QuikSCAT), the Advanced Scatterometer (ASCAT) and Oceansat-2 Scatterometer (OSCAT) wind speed and direction \item RapidScat observations \item SSM/I and Tropical Rainfall Measuring Mission (TRMM) Microwave Imager (TMI) precipitation estimates -\item Doppler radial velocities \item Velocity-Azimuth Display (VAD) Next Generation Weather Radar ((NEXRAD) winds \item Global Positioning System (GPS) precipitable water estimates -\item Solar Backscatter Ultraviolet (SBUV) ozone profiles, Microwave Limb Sounder (MLS) (including NRT) ozone, and Ozone Monitoring Instrument (OMI) total ozone \item Sea surface temperature (SST) -\item Tropical Cyclone Vitals Database (TCVital) \item Doppler wind Lidar +\item Aviation routine weather report (METAR) cloud coverage \item Flight level and Stepped Frequency Microwave Radiometer (SFMR) High Density Observation (HDOB) from reconnaissance aircraft \item Tall tower wind @@ -126,4 +124,18 @@ \subsection{Observations Used by This Version } \item Himawari AHI \end{itemize} -\setlength{\parskip}{12pt} +\textbf{Others:} +\begin{itemize} +\item GPS Radio occultation (RO) refractivity and bending angle profiles +\item Solar Backscatter Ultraviolet (SBUV) ozone profiles, Microwave Limb Sounder (MLS) (including NRT) ozone, and Ozone Monitoring Instrument (OMI) total ozone +\item Doppler radar radial velocities +\item Radar reflectivity Mosaic +\item Tail Doppler Radar (TDR) radial velocity and super-observation +\item Tropical Cyclone Vitals Database (TCVital) +\item Particulate matter (PM) of 10-um diameter, 2.5-um diameter or less +\item MODIS AOD (when using GSI-chem package) +\end{itemize}\setlength{\parskip}{12pt} + + +Please note some of these above mentioned data are not yet fully tested and/or implemented for operations. Therefore, the current GSI code might not have the optimal setup for these data. + diff --git a/doc/EnKF_user_guide/enkf_ch2.tex b/doc/EnKF_user_guide/enkf_ch2.tex index 5f8f2c57c..7f6ade215 100644 --- a/doc/EnKF_user_guide/enkf_ch2.tex +++ b/doc/EnKF_user_guide/enkf_ch2.tex @@ -1,4 +1,4 @@ -\chapter{Software Installation} +\chapter{Software Installation}\label{enkf_install} \setlength{\parskip}{12pt} %---------------------------------------------- @@ -24,29 +24,29 @@ \section{Obtaining the Source Code} \label{ch2_obtain_code} %---------------------------------------------- The community EnKF code and the GSI code are released as a combined source code package. The current -EnKF release is v1.1 and is paired with the community GSI release version 3.5. +EnKF release is v1.2 and is paired with the community GSI release version 3.6. The community EnKF release is available from the DTC community EnKF users website; \url{http://www.dtcenter.org/EnKF/users/index.php} -The community GSI/EnKF release includes the source code for both the EnKF v1.1 and the GSI v3.5 models, as +The community GSI/EnKF release includes the source code for both the EnKF v1.2 and the GSI v3.6 models, as well as an integrated build system, utilities, and documentation necessary to build and run the EnKF. To download the source code from the either the GSI or the EnKF website, select the \underline{Download} tab along with the \underline{GSI/EnKF} System subtab on the vertical menu located on the left side of the main page. New users must first register before downloading the source code. Returning users only need to enter their registration email address to log in. After accessing the download page, select the link to the -\verb|comGSIv3.5_EnKFv1.1| tarball. Please only use the source code provided with the -\verb|comGSIv3.5_EnKFv1.1| tarball. Do not mix and match this tarball with other versions of the community +\verb|comGSIv3.6_EnKFv1.2| tarball. Please only use the source code provided with the +\verb|comGSIv3.6_EnKFv1.2| tarball. Do not mix and match this tarball with other versions of the community GSI code or supplemental libraries, as this will lead to unpredictable results. -The community EnKF version 1.1 comes in a tar file named \verb|comGSIv3.5_EnKFv1.1.tar|. The tar file may +The community EnKF version 1.2 comes in a tar file named \verb|comGSIv3.6_EnKFv1.2.tar|. The tar file may be unpacked by using the standard UNIX commands: \begin{verbatim} - gunzip comGSIv3.5_EnKFv1.1.tar.gz - tar -xvf comGSIv3.5-EnKFv1.1.tar + gunzip comGSIv3.6_EnKFv1.2.tar.gz + tar -xvf comGSIv3.6-EnKFv1.2.tar \end{verbatim} -This creates the top level GSI directory \verb|comGSIv3.5_EnKFv1.1/|. +This creates the top level GSI directory \verb|comGSIv3.6_EnKFv1.2/|. After downloading the source code, and prior to building, the user should check the known issues link on the download page of DTC website to determine if any bug fixes or platform specific customizations are needed. @@ -65,8 +65,8 @@ \section{Compiling EnKF} \label{ch2_compiling} \item If not already done, build and install a recent version of the WRF model. The WRF build is currently needed for the WRF I/O libraries and should use the same compiler as used for the EnKF and GSI builds. \item Build GSI (see chapter 2 of the GSI users guide for more details) \begin{description} -\item[ ]a. Set the environment variables (see chapter 2.4.2 of the GSI users guide) -\item[ ]b. Run the configure script located at the main GSI system directory. +\item[ ]a. Set the environment variables (see chapter 2 of the GSI users guide) +\item[ ]b. Run the configure script located at in the \verb|dtc/| directory. \item[ ]c. Select the EnKF configuration (the default is regional, see section \ref{ch2_versions_enkf}) \item[ ]d. Run the compile script \item[ ]e. Confirm that GSI has successfully built. @@ -103,12 +103,12 @@ \section{System Requirements and External Libraries} \label{ch2_system_requireme The basic requirements for building are: \begin{itemize} -\item FORTRAN 95+ compiler +\item FORTRAN 2003+ compiler \item MPI v1.2+ \item OpenMP \item NetCDF V3.6.3 or V4.2+ \item LAPACK and BLAS mathematics libraries, or equivalent -\item WRF V3.5+ +\item WRF V3.6+ \end{itemize} Because all but the last of these tools and libraries are typically the purview of system administrators to install and maintain, they are lumped together here as part of the basic system requirements. @@ -127,15 +127,11 @@ \section{Compilers Tested for Release} \label{ch2_compilers_tested} & Fortran compiler version & C compiler version \\ \hline \hline -Intel only & ifort 16.0.1, 15.0.1, 13.0.1, 12.1.5, 12.1.4 & icc \\ +Intel only & ifort 17.0.1, 16.0.3, 15.0.3, 14.0.2 & icc \\ \hline -Intel \& gcc & ifort 16.0.1, 15.0.1, 13.0.1, 12.1.5, 12.1.4 & gcc 4.8.2, 4.4.7 \\ +PGI only & pgf90 17.5, 16.5, 15.7 & pgcc \\ \hline -PGI only & pgf90 16.1, 15.10, 15.7, 15.1, 14.10, 14.9, 14.7, 13.9, 13.3 & pgcc \\ -\hline -PGI \& gcc & pgf90 16.1, 15.10, 15.7, 15.1, 14.10, 14.9, 14.7, 13.9, 13.3 & gcc 4.8.2 \\ -\hline -GNU only & gfortran 6.3.0, 5.3.0 & gcc 6.3.0, 5.3.0 \\ +GNU only & gfortran 5.4.0 with netcdf 4.4.0 & gcc 5.4.0 \\ \hline \end{tabular} \label{ch2_tble1} diff --git a/doc/EnKF_user_guide/enkf_ch3.tex b/doc/EnKF_user_guide/enkf_ch3.tex index dd7fcf67e..6c42c331a 100644 --- a/doc/EnKF_user_guide/enkf_ch3.tex +++ b/doc/EnKF_user_guide/enkf_ch3.tex @@ -1,4 +1,4 @@ -\chapter{Running EnKF} +\chapter{Running EnKF}\label{enkf_run} \setlength{\parskip}{12pt} %---------------------------------------------- diff --git a/doc/EnKF_user_guide/enkf_ch4.tex b/doc/EnKF_user_guide/enkf_ch4.tex index 8c8f449dd..2d0820222 100644 --- a/doc/EnKF_user_guide/enkf_ch4.tex +++ b/doc/EnKF_user_guide/enkf_ch4.tex @@ -1,4 +1,4 @@ -\chapter{EnKF Diagnostics and Tuning} +\chapter{EnKF Diagnostics and Tuning}\label{enkf_diag} \setlength{\parskip}{12pt} This chapter will discuss how to assess whether an EnKF was successful based on the contents of the standard output (stdout). Properly checking the EnKF output will also provide useful information to diagnose potential errors in the system. The chapter begins with an introduction to the content and structure of the EnKF stdout, followed by detailed discussion of tuning options in the namelist. This chapter follows the online exercise for a case at 00z on February 13th, 2014 (case 2014021300). This case uses WRF-ARW NetCDF ensemble files as the background and analyzes several observations typical for operations, including most conventional observation data and select radiance data (AMSU-A , HIRS4). The case was run on a Linux cluster supercomputer, using 32 cores. Users can follow this test to reproduce the following results by visiting: diff --git a/doc/EnKF_user_guide/enkf_ch5.tex b/doc/EnKF_user_guide/enkf_ch5.tex index 0c55952d7..b4ade8fc0 100644 --- a/doc/EnKF_user_guide/enkf_ch5.tex +++ b/doc/EnKF_user_guide/enkf_ch5.tex @@ -1,4 +1,4 @@ -\chapter{Applications for Regional and Global EnKF} +\chapter{Applications for Regional and Global EnKF}\label{application} \setlength{\parskip}{12pt} In this chaper, the elements from the previous chapters will be applied to demonstrate how to run a regional and global case using the GSI observer and EnKF. These examples are intended to give users a clear idea of how to set up the GSI observer and EnKF for a particular application and properly check the run status and analysis results in order to determine if the run was successful. Note that the regional example focuses on WRF ARW, however WRF NMM and NMMB runs are similar, but require different background ensemble and namelist options. Similarly, the global example features a single global configuration (T254), however users may wish to use a different configuration, again requiring different background ensemble and namelist options. diff --git a/doc/EnKF_user_guide/enkf_ch6.tex b/doc/EnKF_user_guide/enkf_ch6.tex index 09ba0fa80..c854bf6da 100644 --- a/doc/EnKF_user_guide/enkf_ch6.tex +++ b/doc/EnKF_user_guide/enkf_ch6.tex @@ -1,4 +1,4 @@ -\chapter{EnKF Basic Concepts and Code Structure} +\chapter{EnKF Basic Concepts and Code Structure}\label{enkf_structure} \setlength{\parskip}{12pt} This chapter briefly describes basic concepts and the main code structure used in the current implementation of the NOAA EnKF in the form of EnSRF. Please note there are also other EnKF algorithms provided in this EnKF system. We are working on documenting the other algorithms and will complete the User's Guide in the future. diff --git a/doc/EnKF_user_guide/forward.tex b/doc/EnKF_user_guide/forward.tex index 7bb163f61..7e88640c5 100644 --- a/doc/EnKF_user_guide/forward.tex +++ b/doc/EnKF_user_guide/forward.tex @@ -5,22 +5,22 @@ \noindent \begin{flushleft} -\textcolor{darkgray}{\LARGE Forward} +\textcolor{darkgray}{\LARGE Foreword} \vspace*{1cm}\par This User\textquotesingle s Guide for the community ensemble Kalman filter (EnKF) data analysis system is particularly geared for beginners. -It describes the fundamentals of using EnKF, including basic skills of installing, running, diagnosing, and tuning EnKF. EnKF version (v) 1.1 was released in July 2016. This version of code is compatible with the Gridpoint Statistical Interpolation (GSI) analysis system community release v3.5. +It describes the fundamentals of using EnKF, including basic skills of installing, running, diagnosing, and tuning EnKF. EnKF version (v) 1.2 was released in September 2017. This version of code is compatible with the Gridpoint Statistical Interpolation (GSI) analysis system community release v3.6. This User\textquotesingle s Guide includes six chapters and one appendix: \begin{description} -\item[Chapter 1] provides a background introduction of the EnKF operational and community system, EnKF review committee, and data types that can be used in this version. -\item[Chapter 2] contains basic information about how to get started with EnKF, including system requirements; required software (and how to obtain it); how to download EnKF; and information about compilers, libraries, and how to build the code. -\item[Chapter 3] focuses on the input files needed to run EnKF and how to configure and run GSI observer and EnKF through a sample run script. This chapter also provides an example of a successful EnKF run. -\item[Chapter 4] includes information about diagnostics and tuning of the EnKF system through EnKF standard output and namelist variables. -\item[Chapter 5] illustrates how to setup and run the GSI observer and EnKF for a regional configuration and a global configuration, as well as how to diagnose the results. -\item[Chapter 6] introduces EnKF theory and the main structure of the code. -\item[Appendix A] describes the contents of the EnKF namelist. +\item[Chapter \ref{overview}] provides a background introduction of the EnKF operational and community system, EnKF review committee, and data types that can be used in this version. +\item[Chapter \ref{enkf_install}] contains basic information about how to get started with EnKF, including system requirements; required software (and how to obtain it); how to download EnKF; and information about compilers, libraries, and how to build the code. +\item[Chapter \ref{enkf_run}] focuses on the input files needed to run EnKF and how to configure and run GSI observer and EnKF through a sample run script. This chapter also provides an example of a successful EnKF run. +\item[Chapter \ref{enkf_diag}] includes information about diagnostics and tuning of the EnKF system through EnKF standard output and namelist variables. +\item[Chapter \ref{application}] illustrates how to setup and run the GSI observer and EnKF for a regional configuration and a global configuration, as well as how to diagnose the results. +\item[Chapter \ref{enkf_structure}] introduces EnKF theory and the main structure of the code. +\item[Appendix \ref{nameless}] describes the contents of the EnKF namelist. \end{description} This document is updated annually. For the latest version of this document and annual released code, please visit the EnKF User\textquotesingle s Website: @@ -36,7 +36,7 @@ %need update page number \textbf{Citation:}\\ -\texttt{Liu, H., M. Hu, D. Stark, H. Shao, K. Newman, and J. Whitaker, 2016: Ensemble Kalman Filter (EnKF) User\textquotesingle s Guide Version 1.1. Developmental Testbed Center. Available at \url{http://www.dtcenter.org/EnKF/users/docs/index.php}, 80 pp.} +\texttt{Liu, H., M. Hu, D. Stark, H. Shao, G. Ge, K. Newman, and J. Whitaker, 2017: Ensemble Kalman Filter (EnKF) User\textquotesingle s Guide Version 1.2. Developmental Testbed Center. Available at \url{http://www.dtcenter.org/EnKF/users/docs/index.php}, 80 pp.} \end{flushleft} \end{titlepage} diff --git a/doc/EnKF_user_guide/images/DTClogo.png b/doc/EnKF_user_guide/images/DTClogo.png new file mode 100644 index 000000000..69c792b34 Binary files /dev/null and b/doc/EnKF_user_guide/images/DTClogo.png differ diff --git a/doc/EnKF_user_guide/images/ch5_figure1.jpg b/doc/EnKF_user_guide/images/ch5_figure1.jpg new file mode 100644 index 000000000..1e062502c Binary files /dev/null and b/doc/EnKF_user_guide/images/ch5_figure1.jpg differ diff --git a/doc/EnKF_user_guide/images/enkfbanner.jpg b/doc/EnKF_user_guide/images/enkfbanner.jpg new file mode 100644 index 000000000..1153c1c38 Binary files /dev/null and b/doc/EnKF_user_guide/images/enkfbanner.jpg differ diff --git a/doc/EnKF_user_guide/images/enkfbanner.pdf b/doc/EnKF_user_guide/images/enkfbanner.pdf new file mode 100644 index 000000000..c87f3d5f3 Binary files /dev/null and b/doc/EnKF_user_guide/images/enkfbanner.pdf differ diff --git a/doc/EnKF_user_guide/images/enkfbanner.tiff b/doc/EnKF_user_guide/images/enkfbanner.tiff new file mode 100644 index 000000000..6984e86d0 Binary files /dev/null and b/doc/EnKF_user_guide/images/enkfbanner.tiff differ diff --git a/doc/EnKF_user_guide/references.bib b/doc/EnKF_user_guide/references.bib new file mode 100644 index 000000000..17de7ed32 --- /dev/null +++ b/doc/EnKF_user_guide/references.bib @@ -0,0 +1,137 @@ +@article {Houtekamer2005, +author = {Houtekamer, P. L. and Mitchell, Herschel L.}, +title = {Ensemble Kalman filtering}, +journal = {Quarterly Journal of the Royal Meteorological Society}, +volume = {131}, +number = {613}, +publisher = {John Wiley & Sons, Ltd.}, +issn = {1477-870X}, +url = {http://dx.doi.org/10.1256/qj.05.135}, +doi = {10.1256/qj.05.135}, +pages = {3269--3289}, +keywords = {Balance, Data assimilation, Model error}, +year = {2005}, +} + + +@article{Gaspari1999, + title={Construction of correlation functions in two and three dimensions}, + author={G. Gaspari and S. E. Cohn}, + journal={Quarterly Journal of the Royal Meteorological Society}, + volume={125}, + Issue={554}, + pages={723-757}, + year={1999}, + } + +@article{Anderson2007, + title={Scalable Implementations of Ensemble Filter Algorithms for Data Assimilation}, + author={J. Anderson and N. Collins}, + journal={Journal of Atmospheric and Oceanic Technology}, + volume={24}, + pages={1452-1463}, + year={2007}, + } + +@article{Hunt2007, + title={Efficient data assimilation for a spatiotemporal has: a local ensemble transform Kalman filter}, + author={B. R. Hunt and E. J. Kostelich and I. Szunyogh}, + journal={Physica D}, + volume={230}, + pages={112-126}, + year={2007}, + } + +@article{Whitaker2002, + title={Ensemble data assimilation without perturbed observations}, + author={J.S. Whitaker and T. Hamill}, + journal={Mon. Wea. Rev.}, + volume={130}, + pages={1913-1924}, + year={2002}, + } + +@article{Whitaker2008, + title={Ensemble data assimilation with the NCEP Global Forecast System}, + author={J.S. Whitaker and T. Hamill and X. Wei and Y. Song and Z. Toth}, + journal={Mon. Wea. Rev.}, + volume={436}, + pages={463-482}, + year={2008}, + } + +@article{Whitaker2012, + title={Evaluating methods to account for system errors in ensemble data assimilation}, + author={J.S. Whitaker and T. Hamill}, + journal={Mon. Wea. Rev.}, + volume={140}, + pages={3078-3089}, + year={2012}, + } + +@article{Wu2002, + title={Three-dimensional variational analysis with spatially inhomogeneous covariances}, + author={W.-S. Wu and J. Purser and D. F. Parrish}, + journal={Mon. Wea. Rev.}, + volume={130}, + pages={2905-2916}, + year={2002}, + doi={10.1175/1520-0493(2002)130<2905:TDVAWS>2.0.CO;2.} + } + +@article{Purser2003a, + title={Numerical aspects of the application of recursive filters to variational statistical analysis. Part I: Spatially homogeneous and isotropic Gaussian covariances}, + author={J. Purser and W.-S. Wu and D. F. Parrish and N. M. Roberts}, + journal={Mon. Wea. Rev.}, + volume={131}, + pages={1524-1535}, + year={2003}, + doi={10.1175//1520-0493(2003)131<1524:NAOTAO>2.0.CO;2.} + } + +@article{Purser2003b, + title={Numerical aspects of the application of recursive filters to variational statistical analysis. Part II: Spatially inhomogeneous and anisotropic general covariances}, + author={J. Purser and W.-S. Wu and D. F. Parrish and N. M. Roberts}, + journal={Mon. Wea. Rev.}, + volume={131}, + pages={1536-1548}, + year={2003}, + doi={10.1175//2543.1.} + } + +@article{Shao2016, + title={Bridging Research to Operations Transitions: Status and Plans of Community GSI}, + author={H. Shao and J. Derber and X.-Y. Huang and M. Hu and K. Newman and D. Stark and M. Lueken and C. Zhou and L. Nance and Y.-H. Kuo and B. Brown}, + journal={Bulletin of the American Meteorological Society}, + year={2016}, + doi={10.1175/BAMS-D-13-00245.1} + } + +@article{Houtekamer1996, + title={A system simulation approach to ensemble prediction}, + author={P. L. Houtekamer and L. Lefaivre and J. Derome and H. Ritchie and H. L. Mitchell}, + journal={Mon. Wea. Rev.}, + volume={124}, + number={6}, + pages={1225--1242}, + year={1996} + } + +@article{Ziehmann2000, + title={Comparison of a single-model {EPS} with a multi-model ensemble consisting of a few operational models}, + author={Ziehmann, Christine}, + journal={Tellus}, + volume={52}, + number={3}, + pages={280--299}, + year={2000} + } + +@article{LeDuc2013, + title={Spatial-temporal fractions verification for high-resolution ensemble forecasts}, + author={Duc, Le and Saito, Kazuo and Seko, Hiromu}, + journal={Tellus}, + volume={65A}, + pages={18171}, + year={2013} + } diff --git a/doc/EnKF_user_guide/title.tex b/doc/EnKF_user_guide/title.tex index a07325594..d2e49c76a 100644 --- a/doc/EnKF_user_guide/title.tex +++ b/doc/EnKF_user_guide/title.tex @@ -7,19 +7,23 @@ \begin{center} \includegraphics[width=0.6\textwidth]{images/enkfbanner.pdf}~\\[2em] {\color{darkcerulean} - \Huge{User's Guide Version 1.1}\\[1em] - \large{- Compatible with GSI community release v3.5}\\[2em] - \normalsize{August 2016}\\[5em] + \Huge{User's Guide Version 1.2}\\[0.5em] + \large{- Compatible with GSI community release v3.6}\\[1em] + \normalsize{September 2017}\\[3em] } \normalsize{Hui Liu}\\ - \textit{\small{National Center for Atmospheric Research (NCAR)}}\\[2em] + \textit{\small{National Center for Atmospheric Research (NCAR)}}\\[1em] \normalsize{Ming Hu}\\ \textit{\small{National Oceanic and Atmospheric Administration (NOAA)/Earth System Research Laboratory}}\\ - \textit{\small{Cooperative Institute for Research in Environmental Sciences (CIRES)}}\\[2em] - \normalsize{Hui Shao, Don Stark, Kathryn Newman}\\ - \textit{\small{NCAR}}\\[2em] + \textit{\small{Cooperative Institute for Research in Environmental Sciences (CIRES)}}\\[1em] + \normalsize{Hui Shao, Don Stark}\\ + \textit{\small{NCAR}}\\[1em] + \normalsize{Guoqing Ge}\\ + \textit{\small{NOAA/CIRES}}\\[1em] + \normalsize{Kathryn Newman}\\ + \textit{\small{NCAR}}\\[1em] \normalsize{Jeff Whitaker}\\ - \textit{\small{NOAA/Earth System Research Laboratory}}\\[4em] + \textit{\small{NOAA/Earth System Research Laboratory}}\\[2em] \includegraphics[width=0.5\textwidth]{images/DTClogo.png}\\ diff --git a/doc/GSI_user_guide/.gitignore b/doc/GSI_user_guide/.gitignore new file mode 100644 index 000000000..3b4dab087 --- /dev/null +++ b/doc/GSI_user_guide/.gitignore @@ -0,0 +1,10 @@ +main.aux +main.bbl +main.blg +main.idx +main.log +main.out +main.pdf +main.synctex.gz +main.toc +*.pdf diff --git a/doc/GSI_user_guide/README b/doc/GSI_user_guide/README new file mode 100644 index 000000000..a0eb96dff --- /dev/null +++ b/doc/GSI_user_guide/README @@ -0,0 +1,24 @@ +This directory contains the latex source for creating the GSI user's guide. This document requires +an instillation of latex that supports the CTAN extensions. + +1. Required flavor of LaTex. +Options for the three main platforms. + +Windows: +The most popular choice here is the MiKTEX (http://www.miktex.org) distribution, which lets you easily +manage TEX packages. Many people advise beginners to get the proTEXt bundling of MiKTEX, which lets you +install by using a .pdf file with links so you can read about your options and then click on the right +one. And it includes other components that help you work with your TEX system. + +Unix-type systems, including GNU/Linux: +The best choice here is TEX Live (http://tug.org/texlive/), which contains many packages and programs. +It is freely available over the Internet or on disc; see the web page for details. Note that most Unix +systems have TEX as an installation option so you might already have it or be able to easily get it using +your system administration package management tool: RPM, or DEB, or whatever. + +Mac­in­tosh: +Get the MacTEX (http://tug.org/mactex/) distribution, which is TEX Live with some Mac specific goodies. + +2. Building the user's guide document. +Run LaTex on the file main.tex. It imports organizes each of the individual chapter files. This creates +the document main.pdf. diff --git a/doc/GSI_user_guide/ack.tex b/doc/GSI_user_guide/ack.tex index b737c3252..22853b80d 100644 --- a/doc/GSI_user_guide/ack.tex +++ b/doc/GSI_user_guide/ack.tex @@ -17,7 +17,7 @@ Xiang-Yu Huang, Syed Rizvi, Zhiquan Liu, and Arthur Mizzi National Oceanic and Atmospheric Administration (NOAA) Earth System Research Laboratory (ESRL): \\ -Steve Weygandt, Dezso Devenyi, Joseph Olson, and Jeff Beck +Steve Weygandt, Dezso Devenyi, and Joseph Olson The GSI community support and code management effort is sponsored by NOAA's Office of Oceanic and Atmospheric Research (OAR). This work is also facilitated by NCAR. NCAR is supported by the National Science Foundation (NSF). diff --git a/doc/GSI_user_guide/forward.tex b/doc/GSI_user_guide/forward.tex index 17540267e..f3dd07854 100644 --- a/doc/GSI_user_guide/forward.tex +++ b/doc/GSI_user_guide/forward.tex @@ -5,21 +5,21 @@ \noindent \begin{flushleft} -\textcolor{darkgray}{\LARGE Forward} +\textcolor{darkgray}{\LARGE Foreword} \vspace*{1cm}\par -This document is the 2016 Gridpoint Statistical Interpolation (GSI) User\textquotesingle s Guide geared particularly for beginners. It describes the fundamentals of using GSI version (v) 3.5 released in July 2016. Advanced features of GSI as well as details of assimilation of specific data types can be found in the Advance GSI User\textquotesingle s Guide, released together with this document and the v3.5 code release. +This document is the 2017 Gridpoint Statistical Interpolation (GSI) User\textquotesingle s Guide, geared particularly for beginners. It describes the fundamentals of using GSI version (v) 3.6 released in September 2017. Advanced features of GSI as well as details of assimilation of specific data types can be found in the Advanced GSI User\textquotesingle s Guide, released together with this document and the v3.6 code release. This User\textquotesingle s Guide includes six chapters and three appendices: \begin{description} \item[Chapter 1] provides a background introduction of GSI. -\item[Chapter 2] contains basic information about how to install and compile GSI - including system requirements; required software (and how to obtain it); how to download GSI; and information about compilers, libraries, and how to build the code. -\item[Chapter 3] focuses on the input files needed to run GSI and how to configure and run GSI through a sample run script. Also provides example of a successful GSI run and explanations of often used namelist variables. +\item[Chapter 2] contains basic information about how to install and compile GSI - including system requirements, required software (and how to obtain it), how to download GSI, and information about compilers, libraries, and how to build the code. +\item[Chapter 3] focuses on the input files needed to run GSI and how to configure and run GSI through a sample run script. It also provides an example of a successful GSI run and explanations of often-used namelist variables. \item[Chapter 4] includes information about diagnostics and tuning of the GSI system through GSI standard output, statistic fit files, and some diagnostic tools. -\item[Chapter 5] illustrates the GSI applications for regional ARW cases, including the setup of different data types such as conventional, radiance, and GPSRO data and different analysis functions available in the GSI such as hybrid analysis. -\item[Chapter 6] illustrates the GSI applications for global case and chemical cases. -\item[Appendix A] introduces the community tools available for GSI users. -\item[Appendix B] is content of the GSI namelist section OBS\_INPUT. +\item[Chapter 5] illustrates the GSI applications for regional WRF-ARW cases, including the setup of different data types such as conventional, radiance, and GPSRO data, and different analysis functions available in the GSI, such running a hybrid analysis. +\item[Chapter 6] illustrates the GSI applications for global and chemical cases. +\item[Appendix A] introduces community tools available for GSI users. +\item[Appendix B] describes the content of the GSI namelist section OBS\_INPUT. \item[Appendix C] contains a complete list of the GSI namelist with explanations and default values. \end{description} @@ -34,7 +34,7 @@ %\item[Appendix C:] GSI Namelist: Name, Default value, Explanation %\end{description} -For the latest version of GSI User's Guide and released code, please visit the GSI User\textquotesingle s Website: +For the latest version of the GSI User\textquotesingle s Guide and released code, please visit the GSI User\textquotesingle s Website: \begin{center} \url{http://www.dtcenter.org/com-GSI/users/index.php} \end{center} @@ -44,17 +44,17 @@ gsi-help@ucar.edu \end{center} -This document and the annual GSI releases are made available through a community GSI effort jointly led by the Developmental Testbed Center (DTC) and the National Centers for Environmental Prediction (NCEP) Environmental Modeling Center (EMC), in collaboration with other GSI developers. To help sustain this effort, we recommend for those who use the community released GSI, the GSI helpdesk, the GSI User's Guide, and other DTC GSI services, please refer to this community GSI effort in their work and publications. +This document and the annual GSI releases are made available through a community GSI effort jointly led by the Developmental Testbed Center (DTC) and the National Centers for Environmental Prediction (NCEP) Environmental Modeling Center (EMC), in collaboration with other GSI developers. To help sustain this effort, we request that those who use the community-released GSI, the GSI helpdesk, the GSI User\textquotesingle s Guide, or other DTC GSI services, please refer to this community GSI effort in their work and publications. -For referencing this user's guide, please use: +To reference this user's guide, please use: -\texttt{Hu, M., H. Shao, D. Stark, K. Newman, C. Zhou, and X. Zhang, 2016: Grid-point Statistical -Interpolation (GSI) User's Guide Version 3.5. Developmental Testbed Center. Available at -http://www.dtcenter.org/com-GSI/users/docs/index.php, 141 pp.} +\texttt{Hu, M., G. Ge, H. Shao, D. Stark, K. Newman, C. Zhou, J. Beck, and X. Zhang, 2017: Grid-point Statistical +Interpolation (GSI) User's Guide Version 3.6. Developmental Testbed Center. Available at +http://www.dtcenter.org/com-GSI/users/docs/index.php, 149 pp.} For referencing the general aspect of the GSI community effort, please use: -\texttt{Shao, H., J. Derber, X.-Y. Huang, M. Hu, K. Newman, D. Stark, M. Lueken, C. Zhou, L. Nance, Y.-H. Kuo, B. Brown, 2016: Bridging Research to Operations Transitions: Status and Plans of Community GSI. Bulletin of the American Meteorological Society, doi:10.1175/BAMS-D-13-00245.1, in press} +\texttt{Shao, H., J. Derber, X.-Y. Huang, M. Hu, K. Newman, D. Stark, M. Lueken, C. Zhou, L. Nance, Y.-H. Kuo, B. Brown, 2016: Bridging Research to Operations Transitions: Status and Plans of Community GSI. Bull. Amer. Meteor. Soc., 97, 1427-1440, doi: 10.1175/BAMS-D-13-00245.1.} \end{flushleft} diff --git a/doc/GSI_user_guide/gsi_appendixA.tex b/doc/GSI_user_guide/gsi_appendixA.tex index 9075dfeee..c44492b32 100644 --- a/doc/GSI_user_guide/gsi_appendixA.tex +++ b/doc/GSI_user_guide/gsi_appendixA.tex @@ -1,4 +1,4 @@ -\chapter{GSI Community Tools} +\chapter{GSI Community Tools}\label{gsi_tool} %------------------------------------------------------------------------------- \section{BUFR Format and BUFR Tools} @@ -301,6 +301,82 @@ \section{Plot Single Observation Test Result and Analysis Increment} \end{scriptsize} +%------------------------------------------------------------------------------- +\section{Generate initial regional ensembles } +%------------------------------------------------------------------------------- + +Under the \textit{./util/EnKF} directory, there are two sub-directories:\textit{ enspreproc\_regional.fd/} and \textit{initialens\_regional.fd/}. The first one is to extract ensemble pertubations from GDAS 80 member ensembles and the second one is to add the extracted ensembles to a regional WRF background field (considered as the mean filed) to generate initial regional ensembles. + +Before using these two unitilies, you should have already sucessfully compiled the GSI and gotten the "gsi.exe" file. After that, enter each of the two directory, type "make" to compile the utilities. A sucessful compilation should yield "enspreproc.exe" and "initialens.exe" respectively. + +Now, the next step is to get GDAS spectrally smoothed atmospheric ensemble forecasts. These files should be in the sigma format, which is currrenlty the only format supported by "enspreproc.exe". You need to contact NCEP or other appropriate contacts to download these kind of ensembles. These ensemble files follow the name convection of "sfg\_\$CDATE\_fhr\$FEs\_mem\$MEM". \$CDATE is the cycle date, such as 2017011518 which means 18z of Jan. 15th, 2017. \$FE is the forecast hour, for example, 06 means 6 hour of forecasts. \$MEM is the member number. Here is an example of GDAS ensmbles: \textit{sfg\_2017011518\_fhr06s\_mem001}. + +After you download the required GDAS ensembles, follow the following steps: + +1. Running "enspreproc.exe", enter the \textit{enspreproc\_regional.fd/} directory: + +(1). generate the file "fileslist01". This file lists the ensemble files to be used in the calculation of ensemble pertubations. For example, if it is determined to use 20 members to generate ensemble perturbations, the file "filelist01" will be as follows: +\begin{scriptsize} +\begin{verbatim} + sfg_2017011518_fhr06s_mem001 + sfg_2017011518_fhr06s_mem002 + sfg_2017011518_fhr06s_mem003 + ... + sfg_2017011518_fhr06s_mem018 + sfg_2017011518_fhr06s_mem019 + sfg_2017011518_fhr06s_mem020 +\end{verbatim} +\end{scriptsize} + +(2). Modify the file "namelist.input", change "n\_ens" to the total number of ensembles to be used. + +(3). Copy the "anavinfo" file used by GSI into current directory. + +(4). Copy the background WRF file, name it as "wrf\_inout". + +(5). Create a job description file, submit the job to get it run in parallel. + +After the successful running of "enspreproc.exe", you will get ensemble perturbations as follows: +\begin{scriptsize} +\begin{verbatim} + en_perts4ars.mem0001 + en_perts4ars.mem0002 + en_perts4ars.mem0003 + ... + en_perts4ars.mem0018 + en_perts4ars.mem0019 + en_perts4ars.mem0020 +\end{verbatim} +\end{scriptsize} + +2. Runnning "initialens.exe", enter the \textit{initialens\_regional.fd/} directory: + +(1). Modify the file "namelist.input", change "n\_ens" to the total number of ensembles to be used. + +(2). Copy wrf\_inout to current directry + +(3). Copy wrf\_inout to wrfinput\_d01.mem\$MEM files as follows: +\begin{scriptsize} +\begin{verbatim} + cp wrf_inout wrfinput_d01.mem0001 + cp wrf_inout wrfinput_d01.mem0002 + cp wrf_inout wrfinput_d01.mem0003 + ... + cp wrf_inout wrfinput_d01.mem0018 + cp wrf_inout wrfinput_d01.mem0019 + cp wrf_inout wrfinput_d01.mem0020 +\end{verbatim} +\end{scriptsize} + + Be sure that each member has a correspoding wrfinput\_d01 file. These files will be updated by "initialens.exe" later. + +(4). Link the ensemble perturbations generated by "enspreproc.exe" to current directory. Something like this \textit{ln -s ../enspreproc\_regional.fd/en\_perts4arw.mem*}. + +(5). Create a job description file, submit the job to get it run in parallel. Please note that only 1 processor is required to run "initialens.exe" but submitting it to run on computing node is a must. + +After the sucessful running of "initialens.exe", all the \textit{wrfinput\_d01.mem\$MEM} files are updated with ensemble perturbation added to the background or "mean" state of the original wrf\_inout. + +Now the initial regionl ensembles have been sucessfully generated. diff --git a/doc/GSI_user_guide/gsi_appendixB.tex b/doc/GSI_user_guide/gsi_appendixB.tex index 2e86f9f45..7deb1d759 100644 --- a/doc/GSI_user_guide/gsi_appendixB.tex +++ b/doc/GSI_user_guide/gsi_appendixB.tex @@ -1,4 +1,4 @@ -\chapter{Contents of Namelist Section OBS\_INPUT} +\chapter{Contents of Namelist Section OBS\_INPUT}\label{gsi_obslist} \begin{scriptsize} \begin{verbatim} diff --git a/doc/GSI_user_guide/gsi_appendixC.tex b/doc/GSI_user_guide/gsi_appendixC.tex index 92e037410..23b0a06c4 100644 --- a/doc/GSI_user_guide/gsi_appendixC.tex +++ b/doc/GSI_user_guide/gsi_appendixC.tex @@ -1,4 +1,4 @@ -\chapter{GSI Namelist: Name, Default Value, Explanation} +\chapter{GSI Namelist: Name, Default Value, Explanation}\label{gsi_namelist} The following are lists and explanations of the GSI namelist variables. You can also find them in the source code \textbf{gsimod.F90}. \begin{table}[h] diff --git a/doc/GSI_user_guide/gsi_ch1.tex b/doc/GSI_user_guide/gsi_ch1.tex index b90dbb7bc..985d36f96 100644 --- a/doc/GSI_user_guide/gsi_ch1.tex +++ b/doc/GSI_user_guide/gsi_ch1.tex @@ -1,25 +1,27 @@ -\chapter{Overview} +\chapter{Overview}\label{overview} %------------------------------------------------------------------------------- \section{GSI History and Background} %------------------------------------------------------------------------------- -The Gridpoint Statistical Interpolation (GSI) system is a unified data assimilation (DA) system for both global and regional applications. It was initially developed by the National Centers for Environmental Prediction (NCEP) Environmental Modeling Center (EMC) as a next generation analysis system based on the then operational Spectral Statistical Interpolation (SSI) analysis system (\cite{Wu2002}; \cite{Purser2003a}; \cite{Purser2003b}). Instead of being constructed in spectral space like the SSI, the GSI is constructed in physical space and is designed to be a flexible, state-of-art system that is efficient on available parallel computing platforms. Starting with a three-dimensional variational (3DVar) data assimilation technique, current GSI can be run as a data assimilation system of 2DVar (for surface data analysis), 3DVar, 3D ensemble-variational (3D EnVar), 4D EnVar, 3D/4D hybrid EnVar, or 4DVar (if coupled with an adjoint model of GSI supported forecast systems). +The Gridpoint Statistical Interpolation (GSI) system is a unified data assimilation (DA) system for both global and regional applications. It was initially developed by the National Centers for Environmental Prediction (NCEP) Environmental Modeling Center (EMC) as a next generation analysis system based on the then operational Spectral Statistical Interpolation (SSI) analysis system (\cite{Wu2002}; \cite{Purser2003a}; \cite{Purser2003b}). Instead of being constructed in spectral space like the SSI, the GSI is constructed in physical space and is designed to be a flexible, state-of-art system that is efficient on available parallel computing platforms. Starting with a three-dimensional variational (3DVar) data assimilation technique, the current GSI can be run as a data assimilation system of 2DVar (for surface data analysis), 3DVar, 3D ensemble-variational (3D EnVar), 4D EnVar, 3D/4D hybrid EnVar, or 4DVar (if coupled with an adjoint model from a GSI supported forecast system). -After initial development, the GSI analysis system became operational as the core of the North American Data Assimilation System (NDAS) for the North American Mesoscale (NAM) system in June 2006 and the Global Data Assimilation System (GDAS) for the Global Forecast System (GFS) in May 2007 at National Oceanic and Atmospheric Administration (NOAA). Since then, the GSI system has been adopted in various operational systems, including the National Aeronautics and Space Administration (NASA) Goddard Earth Observing System Model (GEOS), the Unite States Air Force (USAF) mesoscale data assimilation system, the NOAA Real-Time Mesoscale Analysis (RTMA) system, the Hurricane Weather Research and Forecasting (WRF) model (HWRF), and the Rapid Refresh (RAP) and High Resolution Rapid Refresh (HRRR) system, etc. The number of groups and institutes involved in operational GSI development has also increased throughout these years. +After initial development, the GSI analysis system became operational as the core of the North American Data Assimilation System (NDAS) for the North American Mesoscale (NAM) system in June 2006 and the Global Data Assimilation System (GDAS) for the Global Forecast System (GFS) in May 2007 at National Oceanic and Atmospheric Administration (NOAA). Since then, the GSI system has been adopted in various operational systems, including the National Aeronautics and Space Administration (NASA) Goddard Earth Observing System Model (GEOS), the United States Air Force (USAF) mesoscale data assimilation system, the NOAA Real-Time Mesoscale Analysis (RTMA) system, the Hurricane Weather Research and Forecasting (WRF) model (HWRF), and the Rapid Refresh (RAP) and High Resolution Rapid Refresh (HRRR) systems. The number of groups and institutes involved in operational GSI development has also increased throughout these years. %------------------------------------------------------------------------------- \section{GSI Becomes Community Code} %------------------------------------------------------------------------------- -In 2007, the Developmental Testbed Center (DTC) began collaborating with major GSI development groups to transform the operational GSI system into a community system and support distributed development (\cite{Shao2016}). The DTC complements the development groups in providing GSI documentation, porting GSI to multiple platforms, and testing GSI in an independent and objective environment, while still maintaining functionally equivalent to operational centers. Working with EMC, the DTC is maintaining a community GSI repository, which is equivalent to the operational developmental repository, and facilitates community users to develop GSI. Based on the repository, the DTC releases GSI code annually with updated documentation. The first community version of the GSI system was released in 2009. This user\textquotesingle s guide describes the 2016 release of GSI (v3.5) in July 2016. The DTC provides user support through the GSI Helpdesk (gsi-help@ucar.edu), and tutorials and workshops. More information about the GSI community services can be found at the DTC GSI webpage (\url{http://www.dtcenter.org/com-GSI/users/index.php}). +In 2007, the Developmental Testbed Center (DTC) began collaborating with major GSI development groups to transform the operational GSI system into a community system and support distributed development (\cite{Shao2016}). The DTC complements the development groups in providing GSI documentation, porting GSI to multiple platforms, and testing GSI in an independent and objective environment, while maintaining equivalent functionality to what used in thoperational centers. Since 2009, due to the NOAA security constraints, the DTC has been maintaining a community GSI code repository, which mirrors the EMC operational GSI code repository and facilitates community users to develop GSI. Based on this community repository, the DTC releases GSI code annually with updated documentation. Currently, the DTC and EMC are working closely to build a unified GSI code repository for both operational and community developers and users. This unified repository will facilitate direct communication among developers and help accelerate transitions between research and operations. Transition to this unified code repository is ongoing and will be completed by end of 2017. + +The first community version of the GSI system was released in 2009. This user\textquotesingle s guide describes the release of GSI (v3.6) in September 2017. The DTC provides user support through the GSI Helpdesk (gsi-help@ucar.edu), tutorials and workshops. More information about the GSI community services can be found at the DTC GSI webpage (\url{http://www.dtcenter.org/com-GSI/users/index.php}). %------------------------------------------------------------------------------- \subsection{GSI Code Management and Review Committee} %--------------------------------------------------------------------of----------- -The GSI code development and maintenance are managed by the Data Assimilation Review Committee (DARC). It was originally formed as the GSI Review Committee in 2010, with a goal of incorporating all major GSI development teams in the United States within a unified community framework. In 2014, EMC and DTC decided to merge their GSI code repository with the code repository of the NOAA ensemble Kalman filter (EnKF) data assimilation system. Such a merging enabled coordinated development of both systems and joint community support. Following the repository merging, the GSI Review Committee was transitioned to DARC, incorporating new members representing the EnKF development and applications. Currently, DARC contains members from NCEP/EMC, NASA's Goddard Global Modeling and Assimilation Office (GMAO), NOAA's Earth System Research Laboratory (ESRL), the National Center for Atmospheric Research (NCAR) Mesoscale \& Microscale Meteorology Laboratory (MMM), the National Environmental Satellite, Data, and Information Service (NESDIS), USAF, the University of Maryland, and the DTC (chair). The DTC also releases this EnKF system, along with GSI, annually. Please refer to the community EnKF user's webpage (\url{http://www.dtcenter.org/EnKF/users/index.php}) for more information. +The GSI code development and maintenance are managed by the Data Assimilation Review Committee (DARC). It was originally formed as the GSI Review Committee in 2010, with the goal of incorporating all major GSI development teams in the United States within a unified community framework. In 2014, EMC and DTC decided to merge their GSI code repository with the code repository of the NOAA ensemble Kalman filter (EnKF) data assimilation system. This merge enabled coordinated development of both systems and joint community support. Following the repository merging, the GSI Review Committee was transitioned to DARC, incorporating new members representing EnKF development and applications. Currently, DARC contains members from NCEP/EMC, NASA\textquotesingle s Goddard Global Modeling and Assimilation Office (GMAO), NOAA's Earth System Research Laboratory (ESRL), the Joint Center for Satellite Data Assimilation (JCSDA), the National Center for Atmospheric Research (NCAR) Mesoscale \& Microscale Meteorology Laboratory (MMM), the National Environmental Satellite, Data, and Information Service (NESDIS), USAF, the University of Maryland, and the DTC (chair). The DTC also releases the EnKF system annually (along with GSI). Please refer to the community EnKF user\textquotesingle s webpage (\url{http://www.dtcenter.org/EnKF/users/index.php}) for more information. -DARC primarily steers distributed GSI/EnKF development and community code management and support. The responsibilities of the committee are divided into two major aspects: coordination and code review. The purpose and guiding principles of the review committee are as follows: +DARC primarily steers distributed GSI/EnKF development, community code management, and support. The responsibilities of the committee are divided into two major aspects: coordination and code review. The purpose and guiding principles of the review committee are as follows: \begin{itemize} \item{Coordination and advisory} \begin{itemize} @@ -33,7 +35,8 @@ \subsection{GSI Code Management and Review Committee} \item Establish and manage a unified coding standard followed by all GSI/EnKF developers \item Review proposed modifications to the code trunk \item Make decisions on whether code change proposals are accepted or denied for -inclusion in the repository and manage the repository +inclusion in the repository +\item Manage the repository \item Oversee the timely testing and inclusion of code into the repository \end{itemize} @@ -43,64 +46,71 @@ \subsection{GSI Code Management and Review Committee} \subsection{Community Code Contributions} %------------------------------------------------------------------------------- -GSI is a community data assimilation system, open to contributions from scientists and software engineers from both the operational and research communities. DARC oversees the code transition from prospective contributors. This committee reviews proposals for code commits to the GSI repository and monitors that coding standards and tests are being fulfilled. Once the committee reaches approval, the contributed code will be committed to the GSI code repository and available for operational implementation and public release. +GSI is a community data assimilation system, open to contributions from scientists and software engineers from both the operational and research communities. DARC oversees the code transition from prospective contributors. This committee reviews proposals for code commits to the GSI repository and ensures that coding standards and tests are being fulfilled. Once the committee approves, the contributed code will be committed to the GSI code repository and available for operational implementation and public release. -To facilitate this process, the DTC is providing code transition assistance to the general research community. Prospective contributors of code to the GSI system should contact the DTC GSI helpdesk (gsi-help@ucar.edu) for the preparation and integration of their code. It is the contributor's responsibility to ensure that a proposed code change is correct, meets the GSI coding standards, and its expected impact is documented. The DTC will help the contributors run the regression tests and merge the code with the top of the repository trunk. Prospective contributors can also apply to the DTC visitor program for their GSI research and code transition. The visitor program is open to applications year-round. Please check the visitor program webpage (\url{www.dtcenter.org/visitors/}) for the latest announcement of opportunity and application procedures. +To facilitate this process, the DTC is providing code transition assistance to the general research community. Prospective code contributors should contact the DTC GSI helpdesk (gsi-help@ucar.edu) for the preparation and integration of their code. It is the responsibility of the contributor to ensure that a proposed code change is correct, meets GSI coding standards, and its expected impact is documented. The DTC will help the contributor run regression tests and merge the code with the top of the repository trunk. Prospective contributors can also apply to the DTC visitor program for their GSI research and code transition. The visitor program is open to applications year-round. Please check the visitor program webpage (\url{www.dtcenter.org/visitors/}) for the latest announcement of opportunity and application procedures. %------------------------------------------------------------------------------- \section{About This GSI Release} %------------------------------------------------------------------------------- -As a critical part of the GSI user support, this document is provided to assist users in applying GSI to data assimilation and analysis studies. It was composed by the DTC and reviewed by the DARC members. Please note the major focuses of the DTC are currently on testing and evaluation of GSI for regional numerical weather prediction (NWP) applications though the instructions and cases for GSI global and chemical applications are available with this release. This documentation describes the GSI v3.5 release. Active users can contact the DTC (gsi-help@ucar.edu) for developmental versions of GSI. - -The GSI v3.5 can be used either as a 3DVar system, a 3D (hybrid) EnVar system, a 4D (hybrid) EnVar system. Currently, most of NOAA applications are using 3D hybrid EnVar system. Coupled with a forecast model and its adjoint model, GSI can be turned into a 4DVar system with embedded 4DVar features (e.g., GEOS). +As a critical part of the GSI user support, this document is provided to assist users in applying GSI to data assimilation and analysis studies. It was composed by the DTC and reviewed by the DARC members. Please note that the major focuses of the DTC are currently on testing and evaluation of GSI for regional numerical weather prediction (NWP) though the instructions. GSI global and chemical applicaitons are briefly discussed in the document. The document is based on GSI v3.6 release. Active users can contact the DTC (gsi-help@ucar.edu) for developmental versions of GSI and access to the GSI code repository. %------------------------------------------------------------------------------- \subsection{What Is New in This Release Version} %------------------------------------------------------------------------------- -The following lists some of the new functions and changes included in the GSI release v3.5 versus the previous v3.4: +The following lists some of the new functions and changes included in the v3.6 release of the GSI versus v3.5: + +\textbf{Observational aspects}: +\begin{itemize} + \item Added assimilation of full spectral resolution CrIS radiance observations + \item Added near surface temperature (NSST) analysis + \item Added options to use correlated radiance observation errors +\end{itemize} -\textbf{New observation types}: +\textbf{Code optimization and refactoring}: \begin{itemize} - \item All sky data assimilation option for Advanced Microwave Sounding Unit-A (AMSU-A) - \item Assimilation of Geostationary Operational Environmental Satellite (GOES) clear air water vapor (CAWV) atmospheric motion vectors (AMV) - \item Assimilation of Special Sensor Microwave Imager/Sounder (SSMI/S) Defense Meteorological Satellite Program (DMSP) F19 - \item Initial capabilities for assimilating observations from the following instruments: - \begin{itemize} - \item Global Change Observation Mission-W1 satellite (GCOM-W1) Advanced Microwave Scanning Radiometer 2 (AMSR2) - \item Global Precipitation Measurement (GPM) Microwave Imager (GMI) - \item Megha-Tropiques Sondeur Atmospherique du Profil D'Humidite Intertropicale par Radiometrie (SAPHIR) - \item Himawari Advanced Himawari Imager (AHI) - \item International Space Station Rapid Scatterometer (ISS-RapidScat) - \end{itemize} + \item Refactored the observer modules using polymorphic code + \item Generalized all radiance assimilation across different sensors/instruments for cloud and aerosol usages in GSI + \item Removed the First-Order Time extrapolation to the Observation (FOTO) + \item Updated to netCDF v4.0 functionality + \item Removed unused modules/variables \end{itemize} -\textbf{Algorithm/application update}: +\textbf{Application specific updates}: \begin{itemize} -\item Added 4D (hybrid) EnVar option -\item Added new AMV algorithm (requires a new BUFR table) -\item Added QC for regional assimilation of GPS RO bending angle -\item Updated observation thinning algorithms -\item Added the capability of using blend global-regional coordinate with HWRF ensemble -\item Added capability to output ensemble spread -\item Updated to near surface sea temperature (NSST) capability -\item Updated to RTMA capability + \item{Non-variational cloud analysis} + \begin{itemize} + \item Added number concentration for cloud water, cloud ice, and rain to match the cloud analysis with the Thompson Microphysical scheme + \item Added functions using visibility/fog observation to improve cloud fields in the lowest two levels + \item Added capability to read BUFR format NASA LaRC cloud products + \end{itemize} + \item{RTMA} + \begin{itemize} + \item Added variational QC algorithm using a super-logistic distribution function + \item Added cloud ceiling height and scalar wind as analysis variables + \end{itemize} \end{itemize} -\textbf{Libraries update}: +\textbf{Other updates}: \begin{itemize} -\item Switched to new version of the Community Radiative Transfer Model (CRTM) (v2.2.3) -\item added capability to use the NCEP I/O library \textit {nemio} for global GSI + \item Added the Advanced Research WRF (ARW) hybrid vertical coordinate background to GSI + \item Added a vertical dependence of the hybrid background error weighting, and horizontal/vertical localization scales in GSI + \item Added a NCEP nemsio interface for GFS deterministic and ensemble forecasts + \item Utility updates such as using GFS ensemble forecast perturbations to initialize WRF ensemble forecasts. + \item Bug fixes \end{itemize} -Please note due to the version update, some diagnostic files and static information files might have been modified as well. +Besides the above-mentioned changes, the release code also includes a new cmake-based build utility. This utility is currently being tested for its portability and has been included in v3.6. In the near future, the DTC and EMC will use the same cmake build utility for all operational and research code. Transition to this new build utility will be completed by early 2018. + +Please note that due to the version update, some diagnostic and static information files might have been modified as well. %------------------------------------------------------------------------------- \subsection{Observations Used by This Version} %------------------------------------------------------------------------------- -GSI is being used by various applications on multiple scales. The types of observations GSI can assimilate vary from conventional to aerosol observations. Users should use observations with caution to fit their specific applications. The GSI v3.5 can assimilate, but is not limited to, the following types of observations: +GSI is used by various applications on multiple scales. The types of observations GSI can assimilate vary from conventional to aerosol observations. Users should use observations with caution to fit their specific applications. The GSI v3.6 can assimilate, but is not limited to, the following types of observations: \textbf{Conventional observations (including satellite retrievals):} \begin{itemize} @@ -117,14 +127,14 @@ \subsection{Observations Used by This Version} \item European Organization for the Exploitation of Meteorological Satellites (EUMETSAT) and GOES water vapor cloud top winds \item GEOS hourly IR and cloud top wind \item Surface land observations -\item Surface ship and buoy observation +\item Surface ship and buoy observations \item Special Sensor Microwave Imager (SSMI) wind speeds \item Quick Scatterometer (QuikSCAT), the Advanced Scatterometer (ASCAT) and Oceansat-2 Scatterometer (OSCAT) wind speed and direction \item RapidScat observations \item SSM/I and Tropical Rainfall Measuring Mission (TRMM) Microwave Imager (TMI) precipitation estimates \item Velocity-Azimuth Display (VAD) Next Generation Weather Radar ((NEXRAD) winds \item Global Positioning System (GPS) precipitable water estimates -\item Sea surface temperature (SST) +\item Sea surface temperatures (SSTs) \item Doppler wind Lidar \item Aviation routine weather report (METAR) cloud coverage \item Flight level and Stepped Frequency Microwave Radiometer (SFMR) High Density @@ -162,18 +172,13 @@ \subsection{Observations Used by This Version} \begin{itemize} \item GPS Radio occultation (RO) refractivity and bending angle profiles \item Solar Backscatter Ultraviolet (SBUV) ozone profiles, Microwave Limb Sounder (MLS) (including NRT) ozone, and Ozone Monitoring Instrument (OMI) total ozone -\item Doppler radar radial velocities +\item Doppler radar radial velocities \item Radar reflectivity Mosaic \item Tail Doppler Radar (TDR) radial velocity and super-observation \item Tropical Cyclone Vitals Database (TCVital) -\item Particulate matter (PM) of 2.5-um diameter or less +\item Particulate matter (PM) of 10-um diameter, 2.5-um diameter or less \item MODIS AOD (when using GSI-chem package) +\item Significant wave height observations from JASON-2, JASON-3, SARAL/ALTIKA and CRYOSAT-2 \end{itemize} -Please note some of these above mentioned data are not yet fully tested and/or implemented for operations. Therefore, the current GSI code might not have the optimal setup for these data. - - - - - - +Please note that some of these above mentioned data are not yet fully tested and/or implemented for operations. Therefore, the current GSI code might not have an optimal setup for these data. diff --git a/doc/GSI_user_guide/gsi_ch2.tex b/doc/GSI_user_guide/gsi_ch2.tex index 8cbe8c890..eca9d2887 100644 --- a/doc/GSI_user_guide/gsi_ch2.tex +++ b/doc/GSI_user_guide/gsi_ch2.tex @@ -1,31 +1,31 @@ -\chapter{Software Installation} +\chapter{Software Installation}\label{gsi_install} \setlength{\parskip}{12pt} %------------------------------------------------------------------------------- \section{Introduction} %------------------------------------------------------------------------------- -The DTC community GSI is a community distribution of NOAA\textquotesingle s operational GSI. +The DTC GSI is a community distribution of NOAA\textquotesingle s operational GSI. The community GSI expands the portability of the operational code by adding a flexible build system and providing example run scripts that allow GSI to be compiled and run on many common -platforms. The current version of GSI is 3.5. It builds and runs on most standard -Linux platforms using either Intel, PGI, and Gnu compilers. Legacy build rules are provided for +platforms. The current version of GSI is 3.6. It builds and runs on most standard +Linux platforms using Intel, PGI, and Gnu compilers. Legacy build rules are provided for two platforms, the IBM AIX computers using the xlf compiler, and Intel based Macintosh -computers using the PGI compiler. In both cases, the default build system must be modified to +computers using the PGI compiler. In both cases, the default build system must be significantly modified to build on these platforms. See the community web page user support FAQ to get started. This chapter describes how to build and install the DTC community GSI software on your local Linux computing resources. These instructions apply only to the DTC community GSI. While -the community GSI source code is identical to the tag of the NCEP\textquotesingle s GSI +the community GSI source code is identical to the NCEP\textquotesingle s GSI trunk code used for release, the community build system is different, allowing it to be more general to support a wide variety of computing platforms. -The GSI building process consists of four general steps: +The GSI build process consists of four general steps: \begin{itemize} -\item Obtain the source code for GSI and WRF. -\item Build the WRF model (see the WRF users guide). -\item Set the appropriate environment variables for the GSI build. -\item Configure and compile the GSI source code. +\item Obtaining the source code for GSI and WRF. +\item Building the WRF model (see the WRF user\textquotesingle s guide). +\item Setting the appropriate environment variables for the GSI build. +\item Configuring and compiling the GSI source code. \end{itemize} This chapter is organized as follows: Section \ref{ch2_obtainingcode} describes how to obtain @@ -33,16 +33,16 @@ \section{Introduction} supplemental NCEP libraries included with the distribution. Section \ref{ch2_compiling} starts with an outline of the build example and then goes into a more detailed discussion of setting up the build environment and the configure and compile steps. -Section \ref{ch2_buildexample} illustrates the build process for the three of the compilers (Intel, -PGI and Gnu) on the NCAR supercomputer Yellowstone. -Section \ref{ch2_externallibs} covers the system requirements and settings (tools, libraries, and environment +Section \ref{ch2_buildexample} illustrates the build process for three of the compilers (Intel, +PGI and Gnu) on the NCAR Yellowstone supercomputer. +Section \ref{ch2_externallibs} covers system requirements and settings (tools, libraries, and environment variable settings), and currently supported platforms in detail. Section \ref{ch2_gettinghelp} discusses what to do if you have problems with the build and where to get help. -For beginning users, sections \ref{ch2_obtainingcode} and \ref{ch2_compiling} provide the necessary +For beginners, sections \ref{ch2_obtainingcode} and \ref{ch2_compiling} provide the necessary steps to obtain the code and build GSI on most systems. The remainder of the chapters provide -background material for completeness. -Advanced topics, such as customizing the build, porting to new platforms, and debugging can be +background material for completeness. A final chapter \ref{ch2_cmake}, discusses the new experimental CMake build system being developed by the DTC and EMC as a common shared build method. + Advanced topics, such as customizing the build, porting to new platforms, and debugging can be found in the GSI Advanced User\textquotesingle s Guide. %------------------------------------------------------------------------------- @@ -59,15 +59,15 @@ \section{Obtaining and Setting Up the Source Code} \label{ch2_obtainingcode} \underline{GSI/EnKF System} submenu. New users must first register before downloading the source code. Returning users only need to enter their registration email address to log in. After accessing the download page, -select the link to the \verb|comGSIv3.5_EnKFv1.1.tar| tarball to download the most recent version -of the source code (July 2016). Selecting the newest release of the community GSI is critical for +select the link to the \verb|comGSIv3.6_EnKFv1.2.tar| tarball to download the most recent version +of the source code (October 2017). Selecting the newest release of the community GSI is critical for having the most recent capabilities, versions of supplemental libraries, and bug fixes. Full support is only offered for the two most recent code releases. -To analyze satellite radiance observations, GSI requires use of CRTM coefficients. It is important to -use \textbf{only} the version of CRTM coefficients provided by GSI website. Due to their large size, +To analyze satellite radiance observations, GSI requires the use of CRTM coefficients. It is important to +use \textbf{only} the version of CRTM coefficients provided on the GSI website. Due to their large size, these are available as a separate tarfile. They can be downloaded by selecting the link to the -tarball for the \verb|CRTM 2.2.3 Big Endian coefficients| from the web page. For all compilers +tarball for the \verb|CRTM 2.2.3 Big Endian coefficients| from the web page. For all compilers, use the big endian byte order coefficients found in the first CRTM link. The download page also contains links to the fixed files necessary for @@ -77,48 +77,50 @@ \section{Obtaining and Setting Up the Source Code} \label{ch2_obtainingcode} \item Global configuration (fix files to run Global GSI) \end{itemize} -The community GSI version 3.5 comes in a tar file named \verb|comGSIv3.5_EnKFv1.1.tar|. The tar +The community GSI version 3.6 comes in a tar file named \verb|comGSIv3.6_EnKFv1.2.tar|. The tar file may be unpacked by using the UNIX commands: \begin{small} \begin{verbatim} -gunzip comGSIv3.5_EnKFv1.1.tar.gz -tar -xvf comGSIv3.5_EnKFv1.1.tar +gunzip comGSIv3.6_EnKFv1.2.tar.gz +tar -xvf comGSIv3.6_EnKFv1.2.tar \end{verbatim} \end{small} -This creates the top level GSI directory \verb|comGSIv3.5_EnKFv1.1/|. +This creates the top level GSI directory \verb|comGSIv3.6_EnKFv1.2/|. After downloading the source code, and prior to building, the user should check the known issues -link on the download page of DTC website to determine if any bug fixes or platform specific customizations are needed. +link on the download page of the DTC website to determine if any bug fixes or platform specific customizations are needed. %------------------------------------------------------------------------------- \section{Directory Structure, Source Code and Supplemental Libraries} \label{ch2_directorystructure} %------------------------------------------------------------------------------- -The GSI system includes the GSI source code, the build system, supplemental libraries, fixed files, and run scripts. -The following table lists the system components found inside of the root GSI directory. +The GSI system includes the GSI source code, the build system, supplemental libraries, fixed files, and run scripts. Starting with the current version of GSI V3.6, the directory structure has be changed slightly. +The following table lists the system components found inside the root GSI directory. \begin{table}[htbp] \centering \begin{tabular}{| l | l |} \hline -Directory Name & Content \\ +Directory Name & Content\\ \hline \hline -src/main/ & GSI source code and makefiles \\ +src/ & GSI source code and makefiles \\ \hline -src/libs/ & Source code for supplemental libraries \\ +lib/ & Source code and build location for supplemental libraries \\ +\hline +core-libs/ & Build directory for supplemental libraries for CMake build \\ +\hline +libsrc/ & Source code for supplemental libraries for the CMake build \\ \hline fix/ & Fixed input files required by a GSI analysis, such as \\ & background error covariances, observation error tables; \\ - & excluding the CRTM coefficients \\ + & Excluding the CRTM coefficients \\ \hline include/ & Include files created by the build system \\ \hline -lib/ & Location for built supplemental libraries \\ -\hline -run/ & Directory for executable \verb|gsi.exe| and sample run scripts \\ +dtc/ & Directory for the DTC build system, executable \verb|gsi.exe| location, and sample run scripts \\ \hline arch/ & Build system support such as machine architecture specifics \\ & (see Advanced GSI User\textquotesingle s Guide) \\ @@ -129,8 +131,8 @@ \section{Directory Structure, Source Code and Supplemental Libraries} \label{ch \label{ch2_tble1} \end{table} -For the convenience of the user, supplemental NCEP libraries for building GSI are -included in the \verb|src/libs/| directory. These libraries are built when GSI is built. +For convenience, supplemental NCEP libraries for building GSI are +included in the \verb|src/libs/| directory. These libraries will be built when compiling GSI. These supplemental libraries are listed in the table below. \begin{table}[htbp] @@ -158,31 +160,28 @@ \section{Directory Structure, Source Code and Supplemental Libraries} \label{ch \hline sp/ & NCEP spectral - grid transforms \\ \hline -w3emc\_v2.0.5 & NCEP/EMC W3 library (date/time manipulation, GRIB) \\ +w3emc\_v2.0.5/ & NCEP/EMC W3 library (date/time manipulation, GRIB) \\ \hline -w3nco\_v2.0.6 & NCEP/NCO W3 library (date/time manipulation, GRIB) \\ +w3nco\_v2.0.6/ & NCEP/NCO W3 library (date/time manipulation, GRIB) \\ \hline \end{tabular} \label{ch2_tble2} \end{table} -The one nonstandard \textit{library} not included with the source code are the WRF IO API\textquotesingle s. These are obtained by linking to a build of the WRF code. Please note that the release version of WRF/EnKF has only been tested using the previous two release versions of WRF. Older versions of WRF may provide unpredictable results. +The one set of non-standard \textit{library} files not included with the source code are those associated with the WRF IO API. These are obtained by linking to a build of the WRF code. Please note that the release version of WRF/EnKF has only been tested using the previous two release versions of WRF. Older versions of WRF may provide unpredictable results. -The WRF code, and full WRF documentation, can be obtained from the WRF Users\textquotesingle \ Page, +Following a registration process similar to that for downloading GSI, the WRF code and full WRF documentation can be obtained from the WRF Users\textquotesingle \ Page, \url{http://www.mmm.ucar.edu/wrf/users/} -following a registration process similar to that for downloading GSI. - %------------------------------------------------------------------------------- \section{Compiling GSI} \label{ch2_compiling} %------------------------------------------------------------------------------- This section starts with a quick outline of how to build GSI (\ref{ch2_compiling_overview}), followed by a more detailed discussion of the build process (\ref{ch2_compiling_env} \& \ref{ch2_compiling_configandcompile}). Typically GSI will build \textit{straight out of the box} on any system that successfully builds the WRF model. Should the user experience any difficulties with the default build, check the build environment against the requirements described at the end of section \ref{ch2_externallibs}. -To proceed with the GSI build, it is assumed that the WRF model has already been built on the current system. GSI uses the WRF I/O API libraries to read the background file. These I/O libraries are created as part of the WRF build, and are linked into GSI during the GSI build process. In order to successfully link the WRF I/O libraries with the GSI source, it is crucial that both WRF and GSI are built using the same Fortran compilers. This means that if WRF is built with the Intel Fortran compiler, then GSI must also be built with the Intel Fortran compiler. It is also recommended that both codes be built with the same annual version number of the compiler -(.e.g. 12, 13, 14, 15, etc.). +To proceed with the GSI build, it is assumed that the WRF model has already been built on the current system. GSI uses the WRF I/O API libraries to read the background file. These I/O libraries are created as part of the WRF build, and are linked into GSI during the GSI build process. In order to successfully link the WRF I/O libraries with the GSI source, it is crucial that both WRF and GSI are built using the same Fortran compilers. This means that if WRF is built with the Intel Fortran compiler, then GSI must also be built with the Intel Fortran compiler. It is also recommended that both codes be built with the same annual version number of the compiler (e.g., 14, 15, etc.). %------------------------------------------------------------------------------- \subsection{Build Overview} \label{ch2_compiling_overview} @@ -191,13 +190,14 @@ \subsection{Build Overview} \label{ch2_compiling_overview} This section provides a quick outline of the steps necessary to build the GSI code. The following steps describe that build process. \begin{enumerate} -\item \textbf{Set the environment for the compiler:} If not already done so, set the necessary paths for using your selected compiler, such as loading the appropriate modules or modifying your path variable. -\item \textbf{Set the environment variables:} The first path on this list will always need to be set. The remaining two will depend on your choice of compiler and how your default environment is configured. +\item \textbf{Set the environment for the compiler}: If not already done, set the necessary paths for using your selected compiler, such as loading the appropriate modules or modifying your path variable. +\item \textbf{Set the environment variables}: The first path on this list will always need to be set. The remaining two will depend on your choice of compiler and how your default environment is configured. \begin{description} \item[]a. \verb|WRF_DIR| the path to the compiled WRF directory (to always be set) \item[]b. \verb|NETCDF| the path to the \verb|NETCDF| libraries \item[]c. \verb|LAPACK_PATH| the path to the \verb|LAPACK| math libraries \end{description} +\item \textbf{Change into the dtc/ directory} \item \textbf{Run the configure script} \item \textbf{Run the compile script} \end{enumerate} @@ -206,15 +206,15 @@ \subsection{Build Overview} \label{ch2_compiling_overview} \subsection{Environment Variables} \label{ch2_compiling_env} %------------------------------------------------------------------------------- -Before configuring the GSI code to be built, at least one, and no more than three environment variables must be set. +Before configuring the GSI code to be built, be sure to check the following enviroment variables: \begin{description} -\item[WRF\_DIR] defines the path to the root of the WRF build directory. Setting this is mandatory. This variable tells the GSI build system where to find the WRF I/O libraries. The process for setting the environment variables varies according to the login shell in use. To set the path variable WRF\_DIR for csh/tcsh, type; +\item[WRF\_DIR] defines the path to the root of the WRF build directory. Setting this is mandatory. This variable tells the GSI build system where to find the WRF I/O libraries. The process for setting the environment variables varies according to the login shell used. To set the path variable WRF\_DIR for csh/tcsh, type: \begin{verbatim} setenv WRF_DIR /path_to_WRF_root_directory/ for csh or tcsh export WRF_DIR=/path_to_WRF_root_directory/ for ksh or bash \end{verbatim} -\item[NETCDF] The second environment variable specifies the local path to NetCDF library. The path location for NETCDF environment variable may be checked by using the command +\item[NETCDF] The second environment variable specifies the local path to NetCDF library. The path location for the NETCDF environment variable may be checked by using the command \begin{verbatim} echo $NETCDF \end{verbatim} @@ -225,14 +225,14 @@ \subsection{Environment Variables} \label{ch2_compiling_env} it is then necessary to manually set this variable. If your system uses modules or a similar mechanism to set the environment, do this first. If a valid path is returned by the echo command, no further action is required.\\ \item[LAPACK\_PATH] defines the path to the LAPACK library. Typically, this variable will only need to be set on systems without a vendor provided version of LAPACK. -IBM systems typically come installed with the LAPACK equivalent ESSL library that links automatically. Likewise, the PGI compiler often comes with a vendor provided version of LAPACK that links automatically with the compiler. Experience has shown that the following situations make up the majority of cases where the LAPACK variable needed to be set: +IBM systems typically come installed with the LAPACK equivalent ESSL library that links automatically. Likewise, the PGI compiler often comes with a vendor provided version of LAPACK that links automatically with the compiler. Experience has shown that the following situations make up the majority of cases where the LAPACK variable needs to be set: \begin{itemize} \item Linux environments using Intel Fortran compiler. \item Building with Gfortran. \item On systems where the path variables are not properly set. -\item On stripped down versions of the IBM AIX OS that lack the ESSL libraries +\item On stripped down versions of the IBM AIX OS that lack the ESSL libraries \end{itemize} -Of the four, the first of these is the most common. The Intel compiler usually comes with a vendor provided mathematics library known as the \textit{Mathematics Kernel Libraries} or MKL for short. While most installations of the Intel compiler typically come with the MKL libraries installed, the ifort compiler does not automatically load the library. It is therefore necessary to set the LAPACK\_PATH variable to the location of the MKL libraries when using the Intel compiler. You may need to ask your system administrator for the correct path to these libraries. +Of these four, the first case is the most common. The Intel compiler usually comes with a vendor provided mathematics library known as the \textit{Mathematics Kernel Libraries} or MKL for short. While most installations of the Intel compiler typically come with the MKL libraries installed, the ifort compiler does not automatically load the library. It is therefore necessary to set the LAPACK\_PATH variable to the location of the MKL libraries when using the Intel compiler. You may need to ask your system administrator for the correct path to these libraries. \end{description} On super-computing systems with multiple compiler options, these variables may be set as part of the module settings for each compiler. On the NCAR supercomputer Yellowstone, the Intel build environment can be specified through setting the appropriate modules. When this is done, the MKL library path is available through a local environment variable, MKLROOT. The LAPACK environment may be set for csh/tcsh with the Unix commands @@ -248,7 +248,7 @@ \subsection{Environment Variables} \label{ch2_compiling_env} \end{verbatim} \end{small} -Once the environment variables have been set, the next step in the build process is to first run the configure script and then the compile script. +Once the environment variables have been set, the next step in the build process is to run the configure and compile scripts. %------------------------------------------------------------------------------- \subsection{Configure and Compile} \label{ch2_compiling_configandcompile} @@ -257,9 +257,9 @@ \subsection{Configure and Compile} \label{ch2_compiling_configandcompile} Once the environment variables have been set, building the GSI source code requires two additional steps: \begin{enumerate} \item Run the configure script and select a compiler option. -\item Run the compile script +\item Run the compile script. \end{enumerate} -Change into the \verb|comGSIv3.5_EnKFv1.1/| directory and issue the configure command: +Change into the \verb|comGSIv3.6_EnKFv1.2/dtc| directory and issue the configure command: \begin{verbatim} ./configure \end{verbatim} @@ -267,11 +267,11 @@ \subsection{Configure and Compile} \label{ch2_compiling_configandcompile} \verb|configure.gsi|. The script starts by echoing the NETCDF and WRF\_DIR paths set in the previous section. It then examines the current system and queries the user to select from multiple build options. -For 64-bit Linux the options will be the following: +For 64-bit Linux, the options will be the following: \begin{scriptsize} \begin{verbatim} -Will use NETCDF in dir: /glade/apps/opt/netcdf/4.3.0/intel/12.1.5 -Will use WRF in dir: /glade/p/work/mhu/wrf/WRFV3.5 +Will use NETCDF in dir: /glade/apps/opt/netcdf/4.3.0/intel/default +Will use WRF in dir: /glade/p/work/stark/WRF/intel/trunk_20150420_3-7_RELEASE ------------------------------------------------------------------------ Please select from among the following supported platforms. @@ -284,21 +284,23 @@ \subsection{Configure and Compile} \label{ch2_compiling_configandcompile} 7. Linux x86_64, Intel compiler (ifort & icc) (dmpar,optimize) 8. Linux x86_64, Intel compiler (ifort & icc), IBM POE (EXPERIMENTAL) (dmpar,optimize) 9. Linux x86_64, Intel compiler (ifort & icc), SGI MPT (EXPERIMENTAL) (dmpar,optimize) + +Enter selection [1-9] : \end{verbatim} \end{scriptsize} -Looking at the list, there are two things to note. First is that the GNU C-compiler (gcc) may be +Looking at the list, there are two things to note. First, the GNU C-compiler (gcc) may be paired with any of the other Fortran compilers. This allows the build to use the GNU C-compiler in place of the Intel (icc) or PGI (pgcc) C-compiler. -The second thing to notice is that there are separate build targets for vendor supplied versions +There are also separate build targets for vendor supplied versions of MPI such as IBM POE and SGI MPT. This was added due to some computing hardware vendors creating non-standard mpif90 wrappers for their vendor supplied version of MPI. If uncertain about which to choose, start by selecting the default option corresponding to the fortran compiler you wish -to use (either 1,2,5,6, or 7). If that option fails with an error referencing a bad argument for mpif90, +to use (either 1, 5, or 7). If that option fails with an error referencing a bad argument for mpif90, only then try the options listed for use with \verb|Supercomp|, \verb|IBM POE|, or \verb|SGI MPT|. -On selecting an option, the process reports a successful configuration with the banner: +On selecting an option, the script reports a successful configuration with the banner: \begin{scriptsize} \begin{verbatim} ------------------------------------------------------------------------ @@ -306,7 +308,7 @@ \subsection{Configure and Compile} \label{ch2_compiling_configandcompile} ------------------------------------------------------------------------ \end{verbatim} \end{scriptsize} -Failure to get this banner means that the configuration step failed to complete. The most typical reason for a failure is an error in one of the paths set to the environment variables. +Failure to get this banner means that the configuration step failed to complete. The most typical reason for a failure is an error in one of the environment variables paths. After selecting a build option, run the compile script: \begin{small} @@ -314,9 +316,9 @@ \subsection{Configure and Compile} \label{ch2_compiling_configandcompile} ./compile >& compile.log \end{verbatim} \end{small} -It is recommended to capture the build information to a log file by redirecting the output incase it is necessary to diagnose build issues. +Capturing the build information to a log file by redirecting the output is necessary to diagnose build issues. -To conduct a complete clean, which removes ALL built files in ALL directories, as well as the configure.gsi, type: +To remove all built files in every directory, as well as the configure.gsi, type: \begin{small} \begin{verbatim} ./clean -a @@ -325,13 +327,13 @@ \subsection{Configure and Compile} \label{ch2_compiling_configandcompile} A complete clean is necessary if the compilation failed or if the configuration file is changed. Following a successful compile, the GSI executable \verb|gsi.exe| can be found in the \verb|run/| directory. -If the executable is not found, check the compilation log file. If the build failed, search for the first instance of the word "Error" (with a capital "E") to locate the section of the log with the failure. +If the executable is not found, check the compilation log file. If the build failed, search for the first instance of the word "Error" (with a capital "E") to locate the section of the log file with the failure. %------------------------------------------------------------------------------- \section{Example of Build} \label{ch2_buildexample} %------------------------------------------------------------------------------- -To illustrate the build process, the following section describes the steps necessary to build GSI on the NCAR supercomputer Yellowstone using the Intel compiler, the PGI compiler, and the Gnu compiler. Other platforms will be similar. +To illustrate the build process, the following section describes the steps necessary to build GSI on the NCAR Yellowstone supercomputer using the Intel compiler, the PGI compiler, and the Gnu compiler. Other platforms will be similar. %------------------------------------------------------------------------------- \subsection{Intel Build} @@ -344,14 +346,14 @@ \subsection{Intel Build} module load intel module load impi mkl ncarcompilers ncarbinlibs netcdf \end{verbatim} -These module commands have specified the compiler, mpi, the version of the LAPACK library (MKL) and the netcdf library. -\item For this case two of the paths must be set. The path to the WRF directory must always be specified, and the Intel Mathematics Kernal Library (MKL) will be used in place of the LAPACK library. Note that on Yellowstone, the variable MKLROOT is set to the path to the MKL libraries by loading the mkl module. To set the paths in a C-shell environment use: +These module commands have specified the compiler, MPI, the version of the LAPACK library (MKL), and the NetCDF library. +\item For this case, two of the paths must be set. The path to the WRF directory must always be specified, and the Intel Mathematics Kernal Library (MKL) will be used in place of the LAPACK library. Note that on Yellowstone, the variable MKLROOT is set to the path to the MKL libraries by loading the MKL module. To set the paths in a C-shell environment, use: \begin{verbatim} setenv WRF_DIR /PATH TO WRF DIRECTORY/ setenv LAPACK_PATH $MKLROOT \end{verbatim} -\item To run the configure script, type \verb|./configure| inside the top of the GSI directory. If the first three steps were completed successfully, a table of compiler options should appear. Select the desired compiler combination, which in this case is either 6 or 7. The alternative options (8 and 9) are needed for certain platforms that have a vendor supplied custom version of MPI. Try the default build options for MPI first, and only if it fails should the second option be used. -\item To compile the code, enter in a C-shell: \verb|./compile >& compile.log|. If the build completes successfully, an executable named \verb|gsi.exe| will be created in the \verb|./run| directory. +\item To run the configure script, type \verb|./configure| inside the top of the GSI directory. If the first three steps were completed successfully, a table of compiler options should appear. Select the desired compiler combination option, which in this case is either 6 or 7. The alternative options (eight and nine) are needed for certain platforms that have a vendor supplied custom version of MPI. Try the default build options for MPI first, and only if it fails should the second option be used. +\item To compile the code, type the following: \verb|./compile >& compile.log|. If the build completes successfully, an executable named \verb|gsi.exe| will be created in the \verb|./run| directory. \end{enumerate} %------------------------------------------------------------------------------- @@ -365,13 +367,13 @@ \subsection{PGI Build} module load pgi module load impi ncarcompilers ncarbinlibs netcdf \end{verbatim} -These module commands have specified the compiler, mpi, and the netcdf library. -\item For this case only the path to the WRF directory must be set. The PGI compiler comes with its own version of LAPACK that it finds automatically. It is not necessary to set the LAPACK path. In a C-shell environment use: +These module commands have specified the compiler, MPI, and the NetCDF library. +\item For this case only the path to the WRF directory must be set. The PGI compiler comes with its own version of LAPACK that it finds automatically. It is not necessary to set the LAPACK path. In a C-shell environment, use: \begin{verbatim} setenv WRF_DIR /PATH TO WRF DIRECTORY/ \end{verbatim} -\item Similar to the Intel example, pick compiler options listed in a table. In this case, the desired compiler combination is either 3 or 4. -\item To compile the code, enter in a C-shell: \verb|./compile >& compile.log|. If the build completes successfully, an executable named \verb|gsi.exe| will be created in the \verb|./run directory|. +\item Similar to the Intel example, pick compiler options listed in the table. In this case, the desired compiler combination option is either 3 or 4. +\item To compile the code, type the following: \verb|./compile >& compile.log|. If the build completes successfully, an executable named \verb|gsi.exe| will be created in the \verb|./run| directory. \end{enumerate} %------------------------------------------------------------------------------- @@ -385,14 +387,14 @@ \subsection{GNU Build} module load gnu/5.3.0 module load ncarcompilers ncarbinlibs netcdf lapack/3.2.1 \end{verbatim} -These module commands have specified the compiler, mpi, and the netcdf library. -\item For this case two of the paths must be set. The path to the WRF directory must always be specified, and we will use the LAPACK library installed by the module. In a C-shell environment use: +These module commands have specified the compiler, MPI, and the NetCDF library. +\item For this case, two of the paths must be set. The path to the WRF directory must always be specified, and we will use the LAPACK library installed by the module. In a C-shell environment use: \begin{verbatim} setenv WRF_DIR /PATH TO WRF DIRECTORY/ setenv LAPACK_PATH $LIB_NCAR \end{verbatim} -\item Similar to the Intel example, pick compiler options listed in a table. In this case, the desired compiler combination is 5. -\item To compile the code, enter in a C-shell: \verb|./compile >& compile.log|. If the build completes successfully, an executable named \verb|gsi.exe| will be created in the \verb|./run directory|. +\item Similar to the Intel example, pick compiler options listed in the table. In this case, the desired compiler combination option is 5. +\item To compile the code, type the following: \verb|./compile >& compile.log|. If the build completes successfully, an executable named \verb|gsi.exe| will be created in the \verb|./run| directory. \end{enumerate} %------------------------------------------------------------------------------- @@ -403,14 +405,14 @@ \section{System Requirements and External Libraries} \label{ch2_externallibs} The basic requirements for building and running the GSI system are the following: \begin{itemize} -\item FORTRAN 95+ compiler +\item FORTRAN 2003+ compiler \item C compiler \item MPI v1.2+ \item OpenMP \item Perl -\item NetCDF V3.6.3 or V4.2+ +\item NetCDF V4.2+ \item LAPACK and BLAS mathematics libraries, or equivalent -\item WRF V3.5+ +\item WRF V3.6+ \end{itemize} Because all but the last of these tools and libraries are typically the purview of system administrators to install and maintain, they are lumped together here as part of the basic system requirements. @@ -419,9 +421,9 @@ \section{System Requirements and External Libraries} \label{ch2_externallibs} \subsection{Compilers Tested for Release} %------------------------------------------------------------------------------- -Version 3.5 of the DTC community GSI system has been successfully tested on a variety of Linux platforms with many versions of the Intel and PGI fortran compilers. +Version 3.6 of the DTC community GSI system has been successfully tested on a variety of Linux platforms with many versions of the Intel and PGI fortran compilers. -Legacy build rules are also available for IBM AIX and Mac Darwin platforms. Because the DTC does not have the ability to test on these platforms, they are no longer supported. Also, Linux GNU gfortran option is added in this version. +Legacy build rules are also available for IBM AIX and Mac Darwin platforms. Because the DTC does not have the ability to test on these platforms, they are no longer supported. Also, the Linux GNU gfortran option is available in this version. The following Linux compiler combinations have been fully tested: \begin{table}[htbp] @@ -431,35 +433,161 @@ \subsection{Compilers Tested for Release} & Fortran compiler version & C compiler version \\ \hline \hline -Intel only & ifort 16.0.1, 15.0.1, 13.0.1, 12.1.5, 12.1.4 & icc \\ -\hline -Intel \& gcc & ifort 16.0.1, 15.0.1, 13.0.1, 12.1.5, 12.1.4 & gcc 4.8.2, 4.4.7 \\ +Intel only & ifort 17.0.1, 16.0.3, 15.0.3, 14.0.2 & icc \\ \hline -PGI only & pgf90 16.1, 15.10, 15.7, 15.1, 14.10, 14.9, 14.7, 13.9, 13.3 & pgcc \\ +PGI only & pgf90 17.5, 16.5, 15.7 & pgcc \\ \hline -PGI \& gcc & pgf90 16.1, 15.10, 15.7, 15.1, 14.10, 14.9, 14.7, 13.9, 13.3 & gcc 4.8.2 \\ -\hline -GNU only & gfortran 6.3.0, 5.3.0 & gcc 6.3.0, 5.3.0 \\ +GNU only & gfortran 5.4.0 with netcdf 4.4.0 & gcc 5.4.0 \\ \hline \end{tabular} \label{ch2_tble3} \end{table} -Unforeseen build issues may occur when using older compiler and library versions. As always, the best results come from using the most recent version of compilers. +Unforeseen build issues may occur when using older compiler and library versions. As always, the best results will be achieved by using the most recent compiler versions. %------------------------------------------------------------------------------- \section{Getting Help and Reporting Problems} \label{ch2_gettinghelp} %------------------------------------------------------------------------------- -Should the user experience any difficulty building GSI on their system, please first confirm that +Should a user experience any difficulty building GSI on his/her system, please first confirm that all the required software is properly installed (section \ref{ch2_compiling}). Next check that the -external libraries exist and that their specified paths in the configure file are correct. Lastly, +external libraries exist and specified paths in the configure file are correct. Lastly, check the resource file \textit{configure.gsi} for errors in any of the paths or settings. Should all these check out, feel free to contact the community GSI Help Desk for assistance at \begin{center} {gsi-help@ucar.edu} \end{center} -At a minimum, when reporting code building problems to the helpdesk, please include with your -email a copy of the build log, and the \textit{configure.gsi} file. +At a minimum, when reporting code building problems to the helpdesk, please include a copy of the build log and the \textit{configure.gsi} file with your e-mail. +%------------------------------------------------------------------------------- +\section{CMake Build System} \label{ch2_cmake} +%------------------------------------------------------------------------------- + +A new unified build system based on CMake has been added to the GSI code. +CMake is a very powerful cross-platform open-source build system. In comGSI, the CMake build system exists in parallel +to the previous DTC build system, and either one can be used independently to build the code. +The CMake build system is still experimental, but is available as an alternative to the traditional DTC build system. + +\subsection{CMake build process with the DTC script} +The CMake build infrastructure consists of a top level directory with the name \verb|cmake/| and configuration files in each directory named ( \verb|CMakeLists.txt|). The syntax for CMake relies on a two step command line process, similar to "configure" and "compile." Command line arguments are used to specify paths and compilers. To simplify the process, the DTC provides a helper script that simplifies the choice of arguments that need to be used. + +The helper script is called \verb|dtcbuild| and is located in the directory \verb|dtc|. This script attempts to walk the user through the process of building GSI. By default CMake prefers to build the source code "out-of-place," meaning that it does not populate the GSI directory with the build. The script first creates a directory called \verb|build| inside the source code directory to house the build process. If there is already a directory called build, the script halts with a warning to either rename it or delete it. + +The script then checks that the path variable for the WRF build, either \verb|WRFPATH| or \verb|WRF_DIR|, has been set. +It then prompts the user to choose a compiler for the build. +\begin{verbatim} +Please select from among the following supported platforms. + + 1. Linux x86_64, PGI compilers (pgf90 & pgcc) + 2. Linux x86_64, PGI compilers (pgf90 & gcc) + 3. Linux x86_64, GNU compilers (gfortran & gcc) + 4. Linux x86_64, Intel/gnu compiler (ifort & gcc) + 5. Linux x86_64, Intel compiler (ifort & icc) + 6. Linux x86_64, Intel compiler w/intel mpi (mpiifort & icc) + 7. Linux x86_64, Intel compiler (mpif90 -f90=ifort & icc) + +Enter selection [1-7] : +\end{verbatim} +Once a compiler has been chosen, it generates local makefiles by invoking the cmake command with the proper arguments. One of those arguments selects that a local build of the NCEP libraries needed by GSI will be conducted prior to the source code being built. The final step of the script is to invoke a parallel build of the code. + +This points to two advantages in using CMake to build the code. CMake automatically generates code dependencies each time a build is invoked, allowing the use of a parallel make, greatly reducing the time it take to complete the build. Typically the time to complete the CMake build is a quarter of the time needed for the serial DTC "configure" and "compile" to complete. + +Once the build is complete, the two executables a \verb|gsi.x| and \verb|enkf_gfs.x| are placed in the directory \verb|build/bin|. Note that the name of the executables and their location differs from the traditional DTC build. + +Summary of CMake build steps: +\begin{enumerate} +\item Set up the build environment in the same way as with the DTC build +\begin{itemize} + \item Set up compilers/load modules + \item Set the environment path for NetCDF and LaPack/MKL + \item Set the environment path for WRF by setting either of the variables \verb|WRFPATH| or \verb|WRF_DIR| to point to a compiled copy of the WRF code. +\end{itemize} +\item Copy the helper script into the top level directory (\verb|cp ./dtc/dtcbuild .|) +\item Run the helper script (\verb|./dtcbuild|) +\item Select the compiler combination for your build. For instance, number six for Intel on Theia. +\item When the build is complets, the executables \verb|gsi.x| and \verb|enkf_gfs.x| will be located in the directory \verb|build/bin| +\end{enumerate} + + +\subsection{Build notes and additional requirements} +Requirements: +\begin{itemize} +\item The CMake build requires use of version 2.8+ of cmake +\item GSI will not build with the Intel compiler V15.0 due to an incompatibility with the CRTM library. +\end{itemize} + +Build notes: +\begin{itemize} +\item Building on the UCAR Yellowstone supercomputer requires additional flags due to how the C compiler has been installed there. The platform specific script \verb|dtcbuild_yellowstone| accounts for this need. +\item The build is not conducted within the \verb|src/| directory, as is the case with the traditional DTC build, but instead is located in \verb|build/src/CMakeFiles|. +\item On the NCEP Theia supercomputer, GSI builds best with option six, due to the way MPI is set up on that machine. +\end{itemize} + +\subsection{How the helper script works} +This sections will go through the DTC helper script, each section at a time to illustrate how the CMake build works. + +One of the first things the script does is create the build directory; However, prior to this, it checks if a directory by that name already exists. If it does, the script halts with a warning. +\begin{small} +\begin{verbatim} + # create build directory +if test -d ./build ; then + echo "directory build already exists, delete or rename the directory and dry again" + exit +else + mkdir ./build +fi +\end{verbatim} +\end{small} + +Next, the environment variables indicating the top of the source tree and the location of the NCEP library source code are set. +\begin{small} +\begin{verbatim} +# set CORE_DIR to top of source tree. +CORE_DIR=`pwd` +echo "$CORE_DIR" +export CORE_DIR +export CORELIB=$CORE_DIR/libsrc +echo "$CORELIB" +\end{verbatim} +\end{small} + +Next the path to the WRF build is set. For the traditional DTC build, the variable \verb|WRF_DIR| is used. The current CMake build uses a different variable \verb|WRFPATH| to do the same thing. So as a work around, the script accepts the path information from either variable. +\begin{small} +\begin{verbatim} +# set path to WRF and test that it exists +if test -z "$WRFPATH" ; then + if test -z $WRF_DIR; then + echo '** WARNING: No path to WRF_DIR and environment variable WRF_DIR not set.' + exit + else + export WRFPATH=$WRF_DIR + fi +fi +\end{verbatim} +\end{small} + +The next section queries the user to select a compiler combination for the build. Many of the CMake build variables, such as compiler information, can be either set as environment variables or included in the command line argument. Here we set them as environment variables, and cmake is invoked. The following shows the variable settings for the combination of the PGI FORTRAN compiler and the Gnu C compiler. +\begin{small} +\begin{verbatim} + if [ "$resp" = "2" ] ; then + echo ' 2. Linux x86_64, PGI compilers (pgf90 & gcc) ' + export CC=gcc + export CXX=g++ + export FC=pgf90 + cd build + cmake -DBUILD_CORELIBS=ON $CORE_DIR + make -j 8 + fi +\end{verbatim} +\end{small} +These are standard guesses as to what the C, C++, and MPI call for the FORTRAN compiler are called on your system. They may be wrong. In that case the environment variables \verb|CC|, \verb|CXX|, and \verb|FC| may need to be modified. + +The final part of the script is the invocation of cmake. +\begin{small} +\begin{verbatim} + cmake -DBUILD_CORELIBS=ON $CORE_DIR + make -j 8 +\end{verbatim} +\end{small} +There are two arguments used here. The first is \verb|-DBUILD_CORELIBS=ON|. This argument directs CMake to look in the \verb| core-libs/| directory for rules to build the NCEP libraries needed for GSI. The environment variable \verb| CORELIB|, defined at the top of the script, indicates where to look for the library source code. In this case, it is in \verb|$CORE_DIR/libsrc/|. Any changes to the source code would be placed in \verb|$CORE_DIR/libsrc/|, and any changes to the CMake build rules would go in \verb|core-libs/|. The second argument \verb|$CORE_DIR| indicates the location of the build directory. The final statement \verb|make -j 8| invokes a parallel call to \textit{make} using eight processors, which speeds up the build considerably. For more details on the CMake build for GSI, see the readme file \textit{README.cmake} in the top directory. diff --git a/doc/GSI_user_guide/gsi_ch3.tex b/doc/GSI_user_guide/gsi_ch3.tex index 4227e01dc..c8a03f965 100644 --- a/doc/GSI_user_guide/gsi_ch3.tex +++ b/doc/GSI_user_guide/gsi_ch3.tex @@ -1,14 +1,14 @@ -\chapter{Running GSI} +\chapter{Running GSI}\label{gsi_run} \setlength{\parskip}{12pt} -This chapter discusses the issues of running GSI. It starts with introductions to the input data required to run GSI. Then proceeds with a detailed explanation of an example GSI run script and introductions to the result files produced by a successful GSI run. It concludes with some frequently used options from the GSI namelist. +This chapter discusses the issues of running GSI. It starts with introductions to the input data required to run GSI, then proceeds with a detailed explanation of an example GSI run script and introductions to files produced by a successful GSI run. It concludes with some frequently used options from the GSI namelist. %------------------------------------------------------------------------------- \section{Input Data Required to Run GSI} \label{sec3.1} %------------------------------------------------------------------------------- -In most cases, three types of input data (background, observation, and fixed files) must be available before running GSI. In some special idealized cases, such as a pseudo single observation test, GSI can be run without any observations. If running GSI with 3D EnVAR hybrid option, global or regional ensemble forecasts are also needed. +In most cases, three types of input data (background, observations, and fixed files) must be available before running GSI. In some special idealized cases, such as a pseudo single observation test, GSI can be run without any observations. If running GSI with the 3D EnVar hybrid option, global or regional ensemble forecasts are also needed. %------------------------------------------------------------------------------- \subsection{Background or First Guess Field} @@ -18,10 +18,10 @@ \subsection{Background or First Guess Field} \begin{small} \begin{description} -\item[ ] a) WRF NMM input fields in binary format -\item[ ] b) WRF NMM input fields in NetCDF format -\item[ ] c) WRF ARW input fields in binary format -\item[ ] d) WRF ARW input fields in NetCDF format +\item[ ] a) WRF-NMM input fields in binary format +\item[ ] b) WRF-NMM input fields in NetCDF format +\item[ ] c) WRF-ARW input fields in binary format +\item[ ] d) WRF-ARW input fields in NetCDF format \item[ ] e) GFS input fields in binary format or through NEMS I/O \item[ ] f) NEMS-NMMB input fields \item[ ] g) RTMA input files (2-dimensional binary format) @@ -30,11 +30,11 @@ \subsection{Background or First Guess Field} \end{description} \end{small} -The WRF is a community model system, including two dynamical cores: the Advanced Research WRF (ARW) and the Nonhydrostatic Mesoscale Model (NMM). The GFS (Global Forecast System), NEMS (National Environmental Modeling System)-NMMB (Nonhydrostatic Mesoscale Model B-Grid), and RTMA (Real-Time Mesoscale Analysis) are operational systems of NCEP. The DTC mainly supports GSI for regional community model WRF. Therefore, most of the multiple platform tests were conducted using WRF netcdf background files (d). The DTC also supports the GSI in global and chemical applications with limited resources. The following backgrounds have been tested for the release: +The Weather Research and Forecasting (WRF) community modeling system includes two dynamical cores: the Advanced Research WRF (ARW) and the Nonhydrostatic Mesoscale Model (NMM). The GFS (Global Forecast System), NEMS (National Environmental Modeling System)-NMMB (Nonhydrostatic Mesoscale Model B-Grid), and RTMA (Real-Time Mesoscale Analysis) are operational systems at the National Center for Environmental Prediction (NCEP). The DTC mainly supports GSI for regional WRF applications. Therefore, most of the multiple platform tests were conducted using WRF netcdf background files (d). The DTC also supports the GSI in global and chemical applications with limited resources. The following backgrounds have been tested for this release: \begin{small} \begin{enumerate} -\item ARW NetCDF (d) were tested with multiple cases +\item ARW NetCDF (d) were tested with multiple cases \item GFS (e) was tested with multiple NCEP cases \item WRF-Chem NetCDF (h) was tested with a single case \item NEMS-NMMB(f) was tested with a single case @@ -46,17 +46,17 @@ \subsection{Background or First Guess Field} \subsection{Observations} %------------------------------------------------------------------------------- -GSI can analyze many types of observational data, including conventional data, satellite radiance observations, GPS Radio Occultations, and radar data et al. The default observation file names given in released GSI namelist, the corresponding observations included in each files and sample BUFR files downloadable from the NCEP website are listed in table \ref{t31} on the next page. +GSI can analyze many types of observational data, including conventional data, satellite radiance observations, GPS Radio Occultations, and radar data, among others. The default observation file names are given in the released GSI namelist, with corresponding observations included in each file. Sample BUFR files available for download from the NCEP website listed in table \ref{t31}. -The observations are complex and many observations need format converting and quality control before being used by GSI. GSI ingests observations saved in the BUFR format (with NCEP specified features). The NCEP processed PrepBUFR and BUFR files can be used directly. If users need to introduce their own data into GSI, please check the following website for User\textquotesingle s Guide and examples on BUFR/PreBUFR processing: +The observations are complex and many observations need format converting and quality control before being used by GSI. GSI ingests observations saved in BUFR format (with NCEP specified features). The NCEP processed PrepBUFR and BUFR files can be used directly. If users need to introduce their own data into GSI, please check the following website for the User\textquotesingle s Guide and examples of BUFR/PreBUFR processing: \begin{center} \url{http://www.dtcenter.org/com-GSI/BUFR/index.php} \end{center} -DTC supports BUFR/PrepBUFR data processing and quality control as part of GSI community tasks. +DTC supports BUFR/PrepBUFR data processing and quality control as part of the GSI community tasks. -GSI can analyze all of the data types in table \ref{t31}, but each GSI run (for both operation and case study) only uses a subset of the data. Some data may be outdated and not available, some are on monitoring mode, and some data may have quality issues during certain periods. Users are encouraged to check the data quality issues prior to running an analysis. The following NCEP links provide resources that include data quality history: +GSI can analyze all of the data types in table \ref{t31}, but each GSI run (for both operation and case study purposes) only uses a subset of the data. Some data may be outdated and not available, some are in monitoring mode, and some may have quality issues during certain periods. Users are encouraged to check data quality prior to running an analysis. The following NCEP links provide resources that include data quality history: \begin{center} \begin{scriptsize} @@ -68,13 +68,12 @@ \subsection{Observations} Because the current regional models do not have ozone as a prognostic variable, ozone data are not assimilated on the regional scale. -GSI can be run without any observations to see how the moisture constraint modifies the first guess (background) field. GSI can be run in a pseudo single observation mode, which does not require any BUFR observation files. In this mode, users should specify observation information in the namelist section SINGLEOB\_TEST (see Section \ref{sec4.2} for details). As more data files are used, additional information will be added through the GSI analysis. - +GSI can be run without any observations to see how the moisture constraint modifies the first guess (background) field. GSI can also be run in a pseudo single observation mode, which does not require any BUFR observation files. In this mode, users should specify observation information in the namelist section SINGLEOB\_TEST (see Section \ref{sec4.2} for details). As more data files are used, additional information will be added through the GSI analysis. \begin{table}[htbp] \centering \begin{footnotesize} -\caption{GSI observation file name, content, and examples} +\caption{GSI observation file names, content, and examples} \begin{tabular}{|l|p{7cm}|c|} \hline \hline @@ -155,17 +154,17 @@ \subsection{Fixed Files (Statistics and Control Files)} A GSI analysis also needs to read specific information from statistic files, configuration files, bias correction files, and CRTM coefficient files. We refer to these files as fixed files and they are located in a directory called \verb|fix/| in the release package, except for CRTM coefficients. -Table \ref{t32} lists fixed files required in a GSI run, the content of the files, and corresponding example files from the regional and global applications: +Table \ref{t32} lists fixed files required for a GSI run, the content of the files, and corresponding example files from the regional and global applications: -Because most of those fixed files have hardwired names inside the GSI, a GSI run script needs to copy or link those files (right column in table \ref{t32}) from \verb|./fix| directory to GSI run directory with the file name required in GSI (left column in table \ref{t32}). For example, if GSI runs with ARW background case, the following line should be in the run script: +Because most of those fixed files have hardwired names inside the GSI, a GSI run script needs to copy or link those files (right column in table \ref{t32}) from the \verb|./fix| directory to the GSI run directory with the file name required in GSI (left column in table \ref{t32}). For example, if GSI runs with an ARW background, the following line should be in the run script: \begin{small} \begin{verbatim} -cp ${path of the fix directory}/anavinfo_arw_netcdf anavinfo +cp ${path of the fix directory}/anavinfo_arw_netcdf anavinfo \end{verbatim} \end{small} -Note that in this release, there is a strict rule that the numbers of vertical levels in the file \verb|anavinfo| must match the background file (for example, \verb|wrfinput_d01|) for the 3-dimensional variables. Otherwise GSI will fail. To find out the correct numbers of vertical levels, users can dump out (use \verb|ncdump -h|) the dimensions from the NetCDF background file and find the number for \verb|bottom_top| and \verb|bottom_top_stag|. For example, if the dimensions for the background file is: +Note that in this release, there is a strict rule that the numbers of vertical levels in the file \verb|anavinfo| must match the background file (for example, \verb|wrfinput_d01|) for the 3-dimensional variables. Otherwise GSI will fail. To identify the correct numbers of vertical levels, users can dump out (use \verb|ncdump -h|) the dimensions from the NetCDF background file and find the number for \verb|bottom_top| and \verb|bottom_top_stag|. For example, if the dimensions for the background file is: \begin{small} \begin{verbatim} @@ -174,7 +173,7 @@ \subsection{Fixed Files (Statistics and Control Files)} \end{verbatim} \end{small} -Then the corresponding \verb|anavinfo| file should have 51 levels for \verb|prse| (3-dimemsional pressure field) and 50 levels for other three-dimensional variables such as u, v, tv, q, oz, cw and etc. For details, users can dump out the global attributes of the background file and find the number of vertical levels for each variable. The following shows part of \verb|anavinfo| for the above background: +Then the corresponding \verb|anavinfo| file should have 51 levels for \verb|prse| (3-dimemsional pressure field) and 50 levels for other three-dimensional variables such as u, v, tv, q, oz, cw, etc. For details, users can dump out the global attributes of the background file and find the number of vertical levels for each variable. The following shows part of the \verb|anavinfo| file for the above background: \newpage @@ -243,38 +242,9 @@ \subsection{Fixed Files (Statistics and Control Files)} \end{footnotesize} \end{table} +Each operational system, such as GFS, NAM, RAP, and RTMA, has their own set of fixed files. For your specific GSI runs, you need to get the correct set of fixed files. Fixed files for regional applications are included in this GSI/EnKF release and put under the \textit{fix/} directory. Fixed files for global applications are not included in this release in order to save space. Please download \verb|comGSIv3.6_EnKFv1.2_fix_global.tar.gz| if you need to run global cases. Note that little endian background error covariance files are no longer supported. - -Each operational system, such as GFS, NAM, RAP, and RTMA, has their own set of fixed files. Therefore, for each fixed file used in GSI, there are several corresponding fixed files in the directory \verb| fix/ | that users can choose. For example, for the background error covariance file, both \verb|nam_nmmstat_na.gcv| (from the NAM system) and \verb|nam_glb_berror.f77.gcv| (from the global forecast system) can be used. We also prepared the same background error covariance files with different byte order such as files under \verb| ./fix/Little_Endian| and \verb| ./fix/Big_Endian| directory. To help users to set up these fixed files for different GSI applications, several sample run scripts are provided with the release version. - -To make \verb|./fix| directory easy to manage, this release version created 3 sub-directories to hold special group of fix files, which are introduced in table \ref{t33}. - - -\begin{table}[htbp] -\centering -\begin{small} -\caption{List of sub-directories in fix directory} -\begin{tabular}{|p{3cm}|p{9cm}|} -\hline -\hline -Directory name & Content \\ -\hline -\hline -Little\_Endian & Little Endian Bacground Error covariance (BE) files \\ -\hline -Big\_Endian & Big Endian BE files \\ -\hline -global & Global BE files and ch4, co, co2, n2o history files \\ -\hline -\end{tabular} -\label{t33} -\end{small} -\end{table} - - -Please note released \verb|comGSIv3.5_EnKFv1.1| tar files dosen\textquotesingle t include \verb|./fix/global| and \verb|./fix/Little_Endian| for space saving. Please downloand \verb|comGSIv3.5_EnKFv1.1_fix_global.tar.gz| if you need to run global case, \verb|comGSIv3.5_EnKFv1.1_fix_Little_Endian.tar.gz| if you need Little\_endian BE files. - -Each release version GSI calls certain version of CRTM library and needs the corresponding version of CRTM coefficients to do radiance data assimilation. This version of GSI uses CRTM 2.2.3. The coefficients files are listed in table \ref{t34}. +Each release version of the GSI calls a certain version of the CRTM library and needs corresponding CRTM coefficients to do radiance data assimilation. This version of GSI uses CRTM 2.2.3. The coefficient files are listed in table \ref{t34}. \begin{table}[htbp] @@ -327,19 +297,19 @@ \section{GSI Run Script} In this release version, three sample run scripts are available for different GSI applications: \begin{itemize} -\item \verb|comGSIv3.5_EnKFv1.1/run/run_gsi_regional.ksh| for regional GSI -\item \verb|comGSIv3.5_EnKFv1.1/run/run_gsi_global.ksh| for global GSI (GFS) -\item \verb|comGSIv3.5_EnKFv1.1/run/run_gsi_chem.ksh| for chemical analysis +\item \verb|dtc/run/run_gsi_regional.ksh| for regional GSI +\item \verb|dtc/run/run_gsi_global.ksh| for global GSI (GFS) +\item \verb|dtc/run/run_gsi_chem.ksh| for chemical analysis \end{itemize} These scripts will be called to generate GSI namelists: \begin{itemize} -\item \verb|comGSIv3.5_EnKFv1.1/run/comgsi_namelist.sh| for regional GSI -\item \verb|comGSIv3.5_EnKFv1.1/run/comgsi_namelist_gfs.sh| for global GSI (GFS) -\item \verb|comGSIv3.5_EnKFv1.1/run/comgsi_namelist_chem.sh| for GSI chemical analysis +\item \verb|dtc/run/comgsi_namelist.sh| for regional GSI +\item \verb|dtc/run/comgsi_namelist_gfs.sh| for global GSI (GFS) +\item \verb|dtc/run/comgsi_namelist_chem.sh| for GSI chemical analysis \end{itemize} -We will introduce the regional run scripts (\verb|run_gsi_regional.ksh|) in detail in the following sections and introduce the global run script when we introduce the GSI global application in Advanced GSI User\textquotesingle s Guide. +We will introduce the regional run scripts (\verb|run_gsi_regional.ksh|) in detail in the following sections and introduce the global run script when we discuss the GSI global application in the Advanced GSI User\textquotesingle s Guide. Note there is also a run script for regional EnKF (\verb|run_enkf_wrf.ksh|), a run script for global EnKF (\verb|run_enkf_global.ksh|) and the EnKF namelist script (\verb|enkf_wrf_namelist.sh|) in the same directory, which will be introduced in the EnKF User\textquotesingle s Guide. @@ -347,7 +317,7 @@ \section{GSI Run Script} \subsection{Steps in the GSI Run Script} %------------------------------------------------------------------------------- -The GSI run script creates a run time environment necessary for running the GSI executable. A typical GSI run script includes the following steps: +The GSI run script creates a run time environment necessary to run the GSI executable. A typical GSI run script includes the following steps: \begin{enumerate} \item Request computer resources to run GSI. @@ -355,18 +325,18 @@ \subsection{Steps in the GSI Run Script} \item Set experimental variables (such as experiment name, analysis time, background, and observation). \item Set the script that generates the GSI namelist. \item Check the definitions of required variables. -\item Generate a run directory for GSI (sometimes called working or temporary directory). +\item Generate a run directory for GSI (sometimes called a working or temporary directory). \item Copy the GSI executable to the run directory. -\item Copy the background file to the run directory and create an index file listing the location and name of ensemble members if running the hybrid. +\item Copy the background file to the run directory and create an index file listing the location and name of ensemble members if running with a hybrid set up. \item Link observations to the run directory. \item Link fixed files (statistic, control, and coefficient files) to the run directory. \item Generate namelist for GSI. \item Run the GSI executable. -\item Post-process: save analysis results, generate diagnostic files, clean run directory. +\item Post-process: save analysis results, generate diagnostic files, and clean the run directory. \item Run GSI as observation operator for EnKF, only for \verb|if_observer=Yes|. \end{enumerate} -Typically, users only need to modify specific parts of the run script (steps 1, 2, and 3) to fit their specific computer environment and point to the correct input/output files and directories. Users may also need to modify step 4 if changes are made to the namelist and it is under a different name or at a different location. Next section (\ref{sec3.2.2}) covers each of these modifications for steps 1 to 3. Section \ref{sec3.2.3} will dissect a sample regional GSI run script and introduce each piece of this sample GSI run script. Users should start with the run script provided in the same release package with GSI executable and modify it for their own run environment and case configuration. +Typically, users only need to modify specific parts of the run script (steps 1, 2, and 3) to fit their specific computer environment and point to the correct input/output files and directories. Users may also need to modify step 4 if changes are made to the namelist and it is under a different name or at a different location. The next section (\ref{sec3.2.2}) covers each of these modifications for steps 1 to 3. Section \ref{sec3.2.3} will dissect a sample regional GSI run script and introduce each piece of this sample GSI run script. Users should start with the run script provided in the same release package with the GSI executable and modify it for their own run environment and case configuration. %------------------------------------------------------------------------------- @@ -376,7 +346,7 @@ \subsection{Customization of the GSI Run Script} \text {3.2.2.1 Setting Up the Machine Environment} -This section focuses on step 1 of the run script: modify the machine specific entries. Specifically, this consists of setting Unix/Linux environment variables and selecting the correct parallel run time environment (batch system with options). +This section focuses on step 1 of the run script: modifying the machine specific entries. Specifically, this consists of setting Unix/Linux environment variables and selecting the correct parallel run time environment (batch system with options). GSI can be run with the same parallel environments as other MPI programs, for example: @@ -385,8 +355,8 @@ \subsection{Customization of the GSI Run Script} \item IBM supercomputer using LoadLevel \item Linux clusters using PBS (Portable Batch System) \item Linux clusters using LSF -\item Linux workstation (with no batch system) -\item Intel Mac Darwin workstation with PGI complier (with no batch system) +\item Linux workstation (no batch system) +\item Intel Mac Darwin workstation with PGI complier (no batch system) \end{itemize} Two queuing systems are listed below as examples: @@ -433,9 +403,9 @@ \subsection{Customization of the GSI Run Script} \label{t35} \end{table} -In both of the examples above, environment variables are set specifying system resource management, such as the number of processors, the name/type of queue, maximum wall clock time allocated for the job, options for standard out and standard error, etc. Some platforms need additional definitions to specify Unix environmental variables that further define the run environment. +In both of the examples above, environment variables are set specifying system resource management, such as the number of processors, the name/type of queue, maximum wall clock time allocated for the job, options for standard out and standard error, etc. Some platforms need additional definitions to specify Unix environment variables that further define the run environment. -These variable settings can significantly impact the GSI run efficiency and accuracy of the GSI results. Please check with your system administrator for the optimal settings for your computer system. Note that while the GSI can be run with any number of processors, it will not scale well with the increase of processor numbers after a certain threshold based on the case configuration and GSI application types. +These variable settings can significantly impact the GSI run efficiency and accuracy of the GSI results. Please check with your system administrator for optimal settings for your computer system. Note that while the GSI can be run with any number of processors, it will not scale well with the increase of processor numbers after a certain threshold based on the case configuration and GSI application types. \text{3.2.2.2 Setting up the Running Environment} @@ -482,7 +452,7 @@ \subsection{Customization of the GSI Run Script} \text{3.2.2.3 Setting Up an Analysis Case} -This section discusses setting up variables specific to user\textquotesingle s case, such as analysis time, working directory, background and observation files, location of fixed files and CRTM coefficients, the GSI executable file and the script generating GSI namelist. +This section discusses setting up variables specific to a given case, such as analysis time, working directory, background and observation files, location of fixed files and CRTM coefficients, the GSI executable file, and the script generating GSI namelist. \begin{footnotesize} \begin{verbatim} @@ -497,26 +467,26 @@ \subsection{Customization of the GSI Run Script} # OBS_ROOT = path of observations files # FIX_ROOT = path of fix files # GSI_EXE = path and name of the gsi executable - ANAL_TIME=2014061700 + ANAL_TIME=2017051312 HH=`echo $ANAL_TIME | cut -c9-10` - WORK_ROOT=comGSIv3.5_EnKFv1.1/run/testarw - OBS_ROOT=GSI_DTC/data/20140617/${ANAL_TIME}/obs + WORK_ROOT=testarw + OBS_ROOT=data/${ANAL_TIME}/obs PREPBUFR=${OBS_ROOT}/nam.t${HH}z.prepbufr.tm00.nr - BK_ROOT=GSI_DTC/data/20140617/${ANAL_TIME}/arw + BK_ROOT=data/${ANAL_TIME}/arw BK_FILE=${BK_ROOT}/wrfinput_d01.${ANAL_TIME} - CRTM_ROOT=GSI_DTC/data/fix/CRTM_2.2.3 - GSI_ROOT=comGSIv3.5_EnKFv1.1 + CRTM_ROOT=fix/CRTM_2.2.3 + GSI_ROOT=comGSI FIX_ROOT=${GSI_ROOT}/fix - GSI_EXE=${GSI_ROOT}/run/gsi.exe - GSI_NAMELIST=${GSI_ROOT}/run/comgsi_namelist.sh + GSI_EXE=${GSI_ROOT}/dtc/run/gsi.exe + GSI_NAMELIST=${GSI_ROOT}/dtc/run/comgsi_namelist.sh \end{verbatim} \end{footnotesize} -When picking the observation BUFR files, a few cautions to be aware of are: +When picking the observation BUFR files, please be aware of the following: \begin{itemize} -\item GSI run will stop if the time in the background file cannot match the cycle time in the observation BUFR file used for the GSI run (there is a namelist option to turn this check off). -\item Even if their contents are identical, PrepBUFR/BUFR files will differ if they were created on platforms with different endian byte order specification (Linux vs. IBM). Appendix A.1 discusses the conversion tool ssrc to byte-swap observation files. Since the release version 3.2, GSI compiled with PGI and Intel can automatically handle the byte order issue in PrepBUFR and BUFR files. Users can directly link any order BUFR file if working with Intel and PGI platform. +\item GSI run will stop if the time in the background file does not match the cycle time in the observation BUFR file used for the GSI run (there is a namelist option to turn this verification step off). +\item Even if their contents are identical, PrepBUFR/BUFR files will differ if they were created on platforms with different endian byte order specification (Linux vs. IBM). Appendix A.1 discusses the conversion tool SSRC used to byte-swap observation files. Since release version 3.2, GSI compiled with PGI and Intel can automatically handle byte order issues in PrepBUFR and BUFR files. Users can directly link BUFR files of any order if working with Intel and PGI platform. \end{itemize} The next part of this block focuses on additional options that specify important aspects of the GSI configuration. @@ -528,21 +498,43 @@ \subsection{Customization of the GSI Run Script} # (GLOBAL or NAM) # if_clean = clean : delete temperal files in working directory (default) # no : leave running directory as is (this is for debug only) +# if_observer = Yes : only used as observation operater for enkf +# if_hybrid = Yes : Run GSI as 3D/4D EnVar +# if_4DEnVar = Yes : Run GSI as 4D EnVar + if_hybrid=No # Yes, or, No -- case sensitive ! + if_4DEnVar=No # Yes, or, No -- case sensitive (if_hybrid must be Yes)! + if_observer=No # Yes, or, No -- case sensitive ! + bk_core=ARW bkcv_option=NAM if_clean=clean -# if_observer = Yes : only used as observation operater for enkf +# +# setup for GSI 3D/4D EnVar hybrid + if [ ${if_hybrid} = Yes ] ; then + ENS_ROOT=data/dacase/2017051312 + ENSEMBLE_FILE_mem=${ENS_ROOT}/gfsens/sfg_2017051306_fhr06s + + if [ ${if_4DEnVar} = Yes ] ; then + BK_FILE_P1=${BK_ROOT}/wrfout_d01_2017-05-13_19:00:00 + BK_FILE_M1=${BK_ROOT}/wrfout_d01_2017-05-13_17:00:00 + + ENSEMBLE_FILE_mem_p1=${ENS_ROOT}/sfg_2017051312_fhr09s + ENSEMBLE_FILE_mem_m1=${ENS_ROOT}/sfg_2017051312_fhr03s + fi + fi + # no_member number of ensemble members # BK_FILE_mem path and base for ensemble members - if_observer=No # Yes, or, No -- case sensitive ! no_member=20 BK_FILE_mem=${BK_ROOT}/wrfarw.mem \end{verbatim} \end{footnotesize} -Option bk\_core indicates the specific dynamic core used to create the background files and is used to specify the core in the namelist. In this release, there is another bk\_core option for NMMB in addition to WRF ARW and NMM, and also an option if\_observer=Yes to run GSI as observation operator for EnKF. Option bkcv\_option specifies the background error covariance to be used in the case. Two regional background error covariance matrices are provided with the release, one from NCEP global data assimilation (GDAS), and one from NAM data assimilation system (NDAS). Please check Section \ref{sec4.8} for more details about GSI background error covariance. Option if\_clean is to tell the run script if it needs to delete temporal intermediate files in the working directory after a GSI run is completed. Option if\_observer is to tell the run script if it needs to run GSI as observation operator for EnKF. +Option if\_hybrid controls whether to run a hybrid ensemble/variational data analysis. If if\_hybrid=Yes, option if\_4DEnVar=Yes indicates a hybrid 4D-EnVar analysis will be run, while if\_4DEnVar=No indicates a hybrid 3DEnVAR analysis will be run. Option if\_observer determines whether GSI is run as an observation operator for EnKF. + +Option bk\_core indicates the specific dynamic core used to create the background files and specifies the core in the namelist. Option bk\_core can be ARW or NMMB. Option bkcv\_option specifies the background error covariance to be used in the case. Two regional background error covariance matrices are provided with the release, one from NCEP global data assimilation (GDAS), and one from the NAM data assimilation system (NDAS). Please check Section \ref{sec4.8} for more details about GSI background error covariance. Option if\_clean tells the script if it needs to delete temporary intermediate files in the working directory after a GSI run is completed. -In most of case after the following point, users should only make minor changes: +In most cases, users should only make minor changes after the following: \begin{footnotesize} \begin{verbatim} @@ -563,7 +555,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} Listed below is an annotated regional run script with explanations on each function block. -For further details on the first 3 blocks of the script that users need to change, check section 3.2.2.1, 3.2.2.2, and 3.2.2.3: +For further details on the first three blocks of the script that users need to change, see sections 3.2.2.1, 3.2.2.2, and 3.2.2.3: \begin{footnotesize} \begin{verbatim} @@ -576,7 +568,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} # # GSIPROC = processor number used for GSI analysis #------------------------------------------------ - GSIPROC=8 + GSIPROC=4 ARCH='LINUX_LSF' # Supported configurations: @@ -595,18 +587,18 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} # OBS_ROOT = path of observations files # FIX_ROOT = path of fix files # GSI_EXE = path and name of the gsi executable - ANAL_TIME=2014061700 + ANAL_TIME=2017051312 HH=`echo $ANAL_TIME | cut -c9-10` - WORK_ROOT=run/testarw - OBS_ROOT=data/20140617/obs + WORK_ROOT=testarw + OBS_ROOT=data/${ANAL_TIME}/obs PREPBUFR=${OBS_ROOT}/nam.t${HH}z.prepbufr.tm00.nr - BK_ROOT=data/20140617/2014061700/arw + BK_ROOT=data/${ANAL_TIME}/arw BK_FILE=${BK_ROOT}/wrfinput_d01.${ANAL_TIME} - CRTM_ROOT=data/CRTM_2.2.3 - GSI_ROOT=code/comGSIv3.5_EnKFv1.1 + CRTM_ROOT=fix/CRTM_2.2.3 + GSI_ROOT=comGSI FIX_ROOT=${GSI_ROOT}/fix - GSI_EXE=${GSI_ROOT}/run/gsi.exe - GSI_NAMELIST=${GSI_ROOT}/run/comgsi_namelist.sh + GSI_EXE=${GSI_ROOT}/dtc/run/gsi.exe + GSI_NAMELIST=${GSI_ROOT}/dtc/run/comgsi_namelist.sh #------------------------------------------------ # bk_core= which WRF core is used as background (NMM or ARW or NMMB) @@ -614,13 +606,33 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} # (GLOBAL or NAM) # if_clean = clean : delete temperal files in working directory (default) # no : leave running directory as is (this is for debug only) +# if_observer = Yes : only used as observation operater for enkf +# if_hybrid = Yes : Run GSI as 3D/4D EnVar +# if_4DEnVar = Yes : Run GSI as 4D EnVar + if_hybrid=No # Yes, or, No -- case sensitive ! + if_4DEnVar=No # Yes, or, No -- case sensitive (if_hybrid must be Yes)! + if_observer=No # Yes, or, No -- case sensitive ! + bk_core=ARW bkcv_option=NAM if_clean=clean -# if_observer = Yes : only used as observation operater for enkf +# +# setup for GSI 3D/4D EnVar hybrid + if [ ${if_hybrid} = Yes ] ; then + ENS_ROOT=data/dacase/2017051312 + ENSEMBLE_FILE_mem=${ENS_ROOT}/gfsens/sfg_2017051306_fhr06s + + if [ ${if_4DEnVar} = Yes ] ; then + BK_FILE_P1=${BK_ROOT}/wrfout_d01_2017-05-13_19:00:00 + BK_FILE_M1=${BK_ROOT}/wrfout_d01_2017-05-13_17:00:00 + + ENSEMBLE_FILE_mem_p1=${ENS_ROOT}/sfg_2017051312_fhr09s + ENSEMBLE_FILE_mem_m1=${ENS_ROOT}/sfg_2017051312_fhr03s + fi + fi + # no_member number of ensemble members # BK_FILE_mem path and base for ensemble members - if_observer=No # Yes, or, No -- case sensitive ! no_member=20 BK_FILE_mem=${BK_ROOT}/wrfarw.mem \end{verbatim} @@ -636,7 +648,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \end{verbatim} \end{footnotesize} -The next block sets run command to run GSI on multiple platforms. The ARCH is set in the beginning of the script. Option BYTE\_ORDER has been set as Big\_Endian because GSI compiled with Intel and PGI can read in Big\_Endian background error file, BUFR file and CRTM coefficient files. +The next block sets the run command for GSI on multiple platforms. The ARCH variable is set at the beginning of the script. Option BYTE\_ORDER has been set as Big\_Endian because GSI compiled with Intel and PGI can read a Big\_Endian background error file, BUFR files, and CRTM coefficient files. \begin{footnotesize} \begin{verbatim} @@ -682,7 +694,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \end{verbatim} \end{footnotesize} -The next block checks if all the variables needed for a GSI run are properly defined. These variables should have been defined in the first 3 parts of this script. +The next block checks if all the variables needed for a GSI run are properly defined. These variables should have been defined in the first three parts of this script. \begin{scriptsize} \begin{verbatim} @@ -759,7 +771,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \begin{scriptsize} \begin{verbatim} ################################################################################## -# Create the ram work directory and cd into it +# Create the work directory and cd into it workdir=${WORK_ROOT} echo " Create working directory:" ${workdir} @@ -780,10 +792,14 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} # Bring over background field (it's modified by GSI so we can't link to it) cp ${BK_FILE} ./wrf_inout +if [ ${if_4DEnVar} = Yes ] ; then + cp ${BK_FILE_P1} ./wrf_inou3 + cp ${BK_FILE_M1} ./wrf_inou1 +fi \end{verbatim} \end{scriptsize} -Note: You can link observation files to the working directory because GSI will not overwrite these files. The observations that can be analyzed in GSI are listed in the column dfile of the GSI namelist section OBS\_INPUT, as specified in \verb|run/comgsi_namelist.sh|. Most of the conventional observations are in one single file named prepbufr, while different radiance data are in separate files based on satellite instruments, such as AMSU-A or HIRS. All these observation files must be linked as GSI recognized file names in dfile. Please check table \ref{t31} for a detailed explanation of links and the meanings of each file name listed below. +Note: You can link observation files to the working directory because GSI will not overwrite these files. The observations that can be analyzed in GSI are listed in the column "dfile" of the GSI namelist section OBS\_INPUT, as specified in \verb|run/comgsi_namelist.sh|. Most of the conventional observations are in one single file named prepbufr, while different radiance data are in separate files based on satellite instruments, such as AMSU-A or HIRS. All these observation files must be linked as GSI recognized file names in "dfile." Please check table \ref{t31} for a detailed explanation of links and the meanings of each file name listed below. \begin{footnotesize} \begin{verbatim} @@ -792,12 +808,56 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} # ln -s ${OBS_ROOT}/gdas1.t${HH}z.sptrmm.tm00.bufr_d tmirrbufr # Link to the radiance data - ln -s ${OBS_ROOT}/gdas1.t${HH}z.1bamua.tm00.bufr_d amsuabufr - ln -s ${OBS_ROOT}/nam.t${HH}z.1bamub.tm00.bufr_d amsubbufr - ln -s ${OBS_ROOT}/nam.t${HH}z.1bhrs3.tm00.bufr_d hirs3bufr - ln -s ${OBS_ROOT}/gdas1.t${HH}z.1bhrs4.tm00.bufr_d hirs4bufr - ln -s ${OBS_ROOT}/nam.t${HH}z.1bmhs.tm00.bufr_d mhsbufr - ln -s ${OBS_ROOT}/nam.t${HH}z.gpsro.tm00.bufr_d gpsrobufr +srcobsfile[1]=${OBS_ROOT}/gdas1.t${HH}z.satwnd.tm00.bufr_d +gsiobsfile[1]=satwnd +srcobsfile[2]=${OBS_ROOT}/gdas1.t${HH}z.1bamua.tm00.bufr_d +gsiobsfile[2]=amsuabufr +srcobsfile[3]=${OBS_ROOT}/gdas1.t${HH}z.1bhrs4.tm00.bufr_d +gsiobsfile[3]=hirs4bufr +srcobsfile[4]=${OBS_ROOT}/gdas1.t${HH}z.1bmhs.tm00.bufr_d +gsiobsfile[4]=mhsbufr +srcobsfile[5]=${OBS_ROOT}/gdas1.t${HH}z.1bamub.tm00.bufr_d +gsiobsfile[5]=amsubbufr +srcobsfile[6]=${OBS_ROOT}/gdas1.t${HH}z.ssmisu.tm00.bufr_d +gsiobsfile[6]=ssmirrbufr +# srcobsfile[7]=${OBS_ROOT}/gdas1.t${HH}z.airsev.tm00.bufr_d +gsiobsfile[7]=airsbufr +srcobsfile[8]=${OBS_ROOT}/gdas1.t${HH}z.sevcsr.tm00.bufr_d +gsiobsfile[8]=seviribufr +srcobsfile[9]=${OBS_ROOT}/gdas1.t${HH}z.iasidb.tm00.bufr_d +gsiobsfile[9]=iasibufr +srcobsfile[10]=${OBS_ROOT}/gdas1.t${HH}z.gpsro.tm00.bufr_d +gsiobsfile[10]=gpsrobufr +srcobsfile[11]=${OBS_ROOT}/gdas1.t${HH}z.amsr2.tm00.bufr_d +gsiobsfile[11]=amsrebufr +srcobsfile[12]=${OBS_ROOT}/gdas1.t${HH}z.atms.tm00.bufr_d +gsiobsfile[12]=atmsbufr +srcobsfile[13]=${OBS_ROOT}/gdas1.t${HH}z.geoimr.tm00.bufr_d +gsiobsfile[13]=gimgrbufr +srcobsfile[14]=${OBS_ROOT}/gdas1.t${HH}z.gome.tm00.bufr_d +gsiobsfile[14]=gomebufr +srcobsfile[15]=${OBS_ROOT}/gdas1.t${HH}z.omi.tm00.bufr_d +gsiobsfile[15]=omibufr +srcobsfile[16]=${OBS_ROOT}/gdas1.t${HH}z.osbuv8.tm00.bufr_d +gsiobsfile[16]=sbuvbufr +srcobsfile[17]=${OBS_ROOT}/gdas1.t${HH}z.eshrs3.tm00.bufr_d +gsiobsfile[17]=hirs3bufrears +srcobsfile[18]=${OBS_ROOT}/gdas1.t${HH}z.esamua.tm00.bufr_d +gsiobsfile[18]=amsuabufrears +srcobsfile[19]=${OBS_ROOT}/gdas1.t${HH}z.esmhs.tm00.bufr_d +gsiobsfile[19]=mhsbufrears +srcobsfile[20]=${OBS_ROOT}/rap.t${HH}z.nexrad.tm00.bufr_d +gsiobsfile[20]=l2rwbufr +srcobsfile[21]=${OBS_ROOT}/rap.t${HH}z.lgycld.tm00.bufr_d +gsiobsfile[21]=larcglb +ii=1 +while [[ $ii -le 21 ]]; do + if [ -r "${srcobsfile[$ii]}" ]; then + ln -s ${srcobsfile[$ii]} ${gsiobsfile[$ii]} + echo "link source obs file ${srcobsfile[$ii]}" + fi + (( ii = $ii + 1 )) +done \end{verbatim} \end{footnotesize} @@ -827,7 +887,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \end{verbatim} \end{footnotesize} -Note: For background error covariances, observation errors, and analysis available information files, we provide two sets of fixed files here, one set is based on GFS statistics and another is based on NAM statistics. For this release there is an additional setting of the ANAVINFO file for bk\_core=NMMB for both GFS and NAM statistics. +Note: For background error covariances, observation errors, and analysis variable information, we provide two sets of fixed files. One set is based on GFS statistics and another is based on NAM statistics. For this release there is an additional setting in the ANAVINFO file for "bk\_core" for both GFS and NAM statistics. \begin{footnotesize} \begin{verbatim} @@ -909,21 +969,21 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} cp $bufrtable ./prepobs_prep.bufrtable # for satellite bias correction -cp ${FIX_ROOT}/gdas1.t00z.abias.20150617 ./satbias_in -cp ${FIX_ROOT}/gdas1.t00z.abias_pc.20150617 ./satbias_pc +cp ${OBS_ROOT}/gdas1.t12z.abias ./satbias_in +cp ${OBS_ROOT}/gdas1.t12z.abias_pc ./satbias_pc_in \end{verbatim} \end{footnotesize} -Please note that in the above sample script, two fixed files related to radiance bias correction are copied from \verb|fix/| to the work directory: +Please note that in the above sample script, two files related to radiance bias correction are copied to the work directory: \begin{small} \begin{verbatim} -cp ${FIX_ROOT}/gdas1.t00z.abias.20150617 ./satbias_in -cp ${FIX_ROOT}/gdas1.t00z.abias_pc.20150617 ./satbias_pc +cp ${OBS_ROOT}/gdas1.t12z.abias ./satbias_in +cp ${OBS_ROOT}/gdas1.t12z.abias_pc ./satbias_pc_in \end{verbatim} \end{small} -There are two options on how to perform the radiance bias correction. The first method is to do the angle dependent bias correction offline and do the mass bias correction inside the GSI analysis, therefore requiring two input files: \verb|satbias_angle| corresponding to angle dependent bias correction file and \verb|satbias_in| being the input file for mass bias correction. The second method is to combine the angle dependent and mass bias correction together and do it within the GSI analysis, requiring one combined input file \verb|satbias_in|. Note that the input bias correction coefficients file \verb|satbias_in| are different for the two options, therefore it is important to use the appropriate input file for each method. The sample input files for the first method are provided with this release \verb|global_satangbias.txt| and \verb|sample.satbias|. For using the second option - combined angle dependent and mass bias correction, a sample file \verb|gdas1.t00z.abias_pc.20150617| is also provided. Users, as a starting point, might also download a GDAS satbias coefficient file from the NOMADS ftp site as the input file (starting spring 2015, the GDAS \verb|satbias| files have adopted the new format): +There are two options on how to perform the radiance bias correction. The first method is to do the angle dependent bias correction offline and do the mass bias correction inside the GSI analysis, therefore requiring two input files: \verb|satbias_angle|, corresponding to the angle dependent bias correction file and \verb|satbias_in|, being the input file for mass bias correction. The second method is to combine the angle dependent and mass bias correction together and do it within the GSI analysis, requiring one combined input file: \verb|satbias_in|. Note that the input bias correction coefficients file, \verb|satbias_in|, is different for the two options, therefore it is important to use the appropriate input file for each method. The sample input files for the first method are provided with this release: \verb|global_satangbias.txt| and \verb|sample.satbias|. To use the second option - combined angle dependent and mass bias correction, a sample file, \verb|gdas1.t00z.abias_pc.20150617|, is also provided. As a starting point, users may also download a GDAS satbias coefficient file from the NOMADS ftp site as the input file (starting in spring 2015, the GDAS \verb|satbias| files have adopted the following format): \url{ftp://nomads.ncdc.noaa.gov/GDAS/YYYYMM/YYYYMMDD/gdas1.tHHz.abias} @@ -1003,6 +1063,21 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} Note: \verb|EOF| indicates the end of GSI namelist. +The following block modifies the anavinfo file so that its vertical levels are consistent with the wrf\_inout file for WRF ARW or NMM. Users no longer need to manually modify the anavinfo file. + +\begin{footnotesize} +\begin{verbatim} +# modify the anavinfo vertical levels based on wrf_inout for WRF ARW and NMM +if [ ${bk_core} = ARW ] || [ ${bk_core} = NMM ] ; then +bklevels=`ncdump -h wrf_inout | grep "bottom_top =" | awk '{print $3}' ` +bklevels_stag=`ncdump -h wrf_inout | grep "bottom_top_stag =" | awk '{print $3}' ` +anavlevels=`cat anavinfo | grep ' sf ' | tail -1 | awk '{print $2}' ` # levels of sf, vp, u, v, t, etc +anavlevels_stag=`cat anavinfo | grep ' prse ' | tail -1 | awk '{print $2}' ` # levels of prse +sed -i 's/ '$anavlevels'/ '$bklevels'/g' anavinfo +sed -i 's/ '$anavlevels_stag'/ '$bklevels_stag'/g' anavinfo +fi +\end{verbatim} +\end{footnotesize} The following block runs GSI and checks if GSI has successfully completed. @@ -1033,7 +1108,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \end{verbatim} \end{footnotesize} -The following block saves the analysis results with an understandable name and adds the analysis time to some output file names. Among them, stdout contains runtime output of GSI and \verb|wrf_inout| is the analysis result. +The following block saves the analysis results with an understandable name and adds the analysis time to some output file names. Among them, "stdout" contains runtime output of GSI and \verb|wrf_inout| is the resulting analysis file. \begin{footnotesize} \begin{verbatim} @@ -1054,7 +1129,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \end{verbatim} \end{footnotesize} -The following block collects the diagnostic files. The diagnostic files are merged and categorized based on outer loop and data type. Setting write\_diag to true in the namelist directs GSI to write out diagnostic information for each observation station. This information is very useful to check analysis details. Please check Appendix A.2 for the tool to read and analyze these diagnostic files. +The following block collects the diagnostic files. The diagnostic files are merged and categorized based on outer loop and data type. Setting "write\_diag" to true in the namelist directs GSI to write out diagnostic information for each observation. This information is very useful to check analysis details. Please check Appendix A.2 for the tool to read and analyze these diagnostic files. \begin{footnotesize} \begin{verbatim} @@ -1103,7 +1178,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \end{verbatim} \end{footnotesize} -The following scripts clean the temporal intermediate files +The following scripts clean the temporary intermediate files: \begin{footnotesize} \begin{verbatim} @@ -1120,7 +1195,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \end{verbatim} \end{footnotesize} -The following block of the script runs only for \verb|if_observer=Yes|, which runs GSI as observation operators for EnKF and without doing minimization. The script first renames the previous diagnostics files and GSI analysis file by appending \verb| .ensmean| to the filenames to avoid these files being overwritten by the new GSI run. +The following block of the script runs only for \verb|if_observer=Yes|, which runs GSI as an observation operator for EnKF and without doing minimization. The script first renames the previous diagnostics files and GSI analysis file by appending \verb| .ensmean| to the filenames to avoid these files being overwritten by the new GSI run. \begin{footnotesize} \begin{verbatim} @@ -1157,7 +1232,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \end{verbatim} \end{footnotesize} -The rest of the script loops through the ensemble members to get the background ready, run GSI and check the run status: +The rest of the script loops through the ensemble members to get the background ready, run GSI, and check the run status: \begin{footnotesize} \begin{verbatim} @@ -1231,7 +1306,7 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \end{verbatim} \end{small} -If this point is reached, the GSI successfully finishes and exits with 0: +If this point is reached, the GSI successfully finishes and exits with status "0": \begin{small} \begin{verbatim} @@ -1243,85 +1318,86 @@ \subsection{Description of the Sample Regional Run Script to Run GSI} \section{GSI Analysis Result Files in Run Directory}\label{sec3.3} %------------------------------------------------------------------------------- -Once the GSI run script is set up, it is ready to be submitted just as other batch jobs. When completed, GSI will create a number of files in the run directory. Below is an example of the files generated in the run directory from one of the GSI test case runs. This case was run to perform a regional GSI analysis with a WRF ARW NetCDF background using conventional (prepbufr), radiance (AMSU-A, HIRS4, and MHS), and GPSRO data. The analysis time is 00Z 17 June 2014. Four processors were used. To make the run directory more readable, we turned on the clean option in the run script, which deleted all temporary intermediate files. +Once the GSI run script is set up, it is ready to be submitted like any other batch job. When completed, GSI will create a number of files in the run directory. Below is an example of the files generated in the run directory from one of the GSI test case runs. This case was run to perform a regional GSI analysis with a WRF-ARW NetCDF background using conventional (prepbufr), radiance (AMSU-A, HIRS4, and MHS), and GPSRO data. The analysis time is 1200Z on 13 May 2017. Four processors were used. To make the run directory more readable, we turned on the clean option in the run script, which deleted all temporary intermediate files. \begin{scriptsize} \begin{verbatim} -amsuabufr diag_mhs_n19_ges.2014061700 fort.226 -amsubbufr errtable fort.227 -anavinfo fit_p1.2014061700 fort.228 -berror_stats fit_q1.2014061700 fort.229 -convinfo fit_rad1.2014061700 fort.230 -diag_amsua_metop-a_anl.2014061700 fit_t1.2014061700 gpsrobufr -diag_amsua_metop-a_ges.2014061700 fit_w1.2014061700 gsi.exe -diag_amsua_metop-b_anl.2014061700 fort.201 gsiparm.anl -diag_amsua_metop-b_ges.2014061700 fort.202 hirs4bufr -diag_amsua_n15_anl.2014061700 fort.203 l2rwbufr -diag_amsua_n15_ges.2014061700 fort.204 list_run_directory -diag_amsua_n18_anl.2014061700 fort.205 mhsbufr -diag_amsua_n18_ges.2014061700 fort.206 ozinfo -diag_amsua_n19_anl.2014061700 fort.207 pcpbias_out -diag_amsua_n19_ges.2014061700 fort.208 pcpinfo -diag_conv_anl.2014061700 fort.209 prepbufr -diag_conv_ges.2014061700 fort.210 prepobs_prep.bufrtable -diag_hirs4_metop-a_anl.2014061700 fort.211 satbias_ang.out -diag_hirs4_metop-a_ges.2014061700 fort.212 satbias_in -diag_hirs4_metop-b_anl.2014061700 fort.213 satbias_out -diag_hirs4_metop-b_ges.2014061700 fort.214 satbias_out.int -diag_hirs4_n19_anl.2014061700 fort.215 satbias_pc -diag_hirs4_n19_ges.2014061700 fort.217 satbias_pc.out -diag_mhs_metop-a_anl.2014061700 fort.218 satinfo -diag_mhs_metop-a_ges.2014061700 fort.219 stdout -diag_mhs_metop-b_anl.2014061700 fort.220 stdout.anl.2014061700 -diag_mhs_metop-b_ges.2014061700 fort.221 wrf_inout -diag_mhs_n18_anl.2014061700 fort.223 wrfanl.2014061700 -diag_mhs_n18_ges.2014061700 fort.224 -diag_mhs_n19_anl.2014061700 fort.225 +amsuabufr fort.206 hirs3bufrears +amsuabufrears fort.207 hirs4bufr +anavinfo fort.208 l2rwbufr +atmsbufr fort.209 larcglb +berror_stats fort.210 list_run_directory +convinfo fort.211 mhsbufr +diag_amsua_n15_anl.2017051312 fort.212 mhsbufrears +diag_amsua_n15_ges.2017051312 fort.213 omibufr +diag_amsua_n18_anl.2017051312 fort.214 ozinfo +diag_amsua_n18_ges.2017051312 fort.215 pcpbias_out +diag_amsua_n19_anl.2017051312 fort.217 pcpinfo +diag_amsua_n19_ges.2017051312 fort.218 prepbufr +diag_conv_anl.2017051312 fort.219 prepobs_prep.bufrtable +diag_conv_ges.2017051312 fort.220 radar_supobs_from_level2 +diag_hirs4_n19_anl.2017051312 fort.221 satbias_angle +diag_hirs4_n19_ges.2017051312 fort.223 satbias_ang.out +diag_mhs_n18_anl.2017051312 fort.224 satbias_in +diag_mhs_n18_ges.2017051312 fort.225 satbias_out +diag_mhs_n19_anl.2017051312 fort.226 satbias_out.int +diag_mhs_n19_ges.2017051312 fort.227 satbias_pc_in +errtable fort.228 satbias_pc.out +fit_p1.2017051312 fort.229 satinfo +fit_q1.2017051312 fort.230 satwnd +fit_rad1.2017051312 fort.232 sbuvbufr +fit_t1.2017051312 fort.233 seviribufr +fit_w1.2017051312 fort.234 ssmirrbufr +fort.201 gimgrbufr stdout +fort.202 gomebufr stdout.anl.2017051312 +fort.203 gpsrobufr wrfanl.2017051312 +fort.204 gsi.exe wrf_inout +fort.205 gsiparm.anl \end{verbatim} \end{scriptsize} It is important to know which files hold the GSI analysis results, standard output, and diagnostic information. We will introduce these files and their contents in detail in the following chapter. The following is a brief list of what these files contain: \begin{itemize} -\item \textit{stdout.anl.2014061700/stdout}: standard text output file, which is a link to stdout with the analysis time appended. This is the most commonly used file to check the GSI analysis processes as well as basic and important information about the analyses. We will explain the contents of stdout in Section 4.1 and users are encouraged to read this file in detail to become familiar with the order of GSI analysis processing. -\item \textit{wrfanl.2014061700/wrf\_inout}: analysis results if GSI completes successfully \- it exists only if using WRF for background. This is a link to \textit{wrf\_inout} with the analysis time appended. The format is the same as the background file. + \item \textit{stdout} or \textit{stdout.anl.(time)}: standard text output file. \textit{stdout.anl.(time)} is a link to \textit{stdout} with the analysis time appended. This is the most commonly used file to check the GSI analysis processes and contains basic and important information about the analyses. We will explain the contents of the \textit{stdout} file in Section 4.1 and users are encouraged to read this file in detail to become familiar with the order of GSI analysis processing. + \item \textit{wrf\_inout} or \textit{wrfanl.(time)}: analysis results if GSI completes successfully. It exists only if using WRF for the background. The \textit{wrfanl.(time)} file is a link to \textit{wrf\_inout} with the analysis time appended. The format is the same as the background file. \item \textit{diag\_conv\_anl.(time)}: binary diagnostic files for conventional and GPS RO observations at the final analysis step (analysis departure for each observation). -\item \textit{diag\_conv\_ges.(time)}: binary diagnostic files for conventional and GPS RO observations before initial analysis step (background departure for each observation) -\item \textit{diag\_(instrument\_satellite)\_anl}: diagnostic files for satellite radiance observations at final analysis step. -\item \textit{diag\_(instrument\_satellite)\_ges}: diagnostic files for satellite radiance observations before initial analysis step. +\item \textit{diag\_conv\_ges.(time)}: binary diagnostic files for conventional and GPS RO observations before the initial analysis step (background departure for each observation) +\item \textit{diag\_(instrument\_satellite)\_anl}: diagnostic files for satellite radiance observations at the final analysis step. +\item \textit{diag\_(instrument\_satellite)\_ges}: diagnostic files for satellite radiance observations before the initial analysis step. \item \textit{gsiparm.anl}: GSI namelist, generated by the run script. \item \textit{fit\_(variable).(time)}: links to fort.2?? with meaningful names (variable name plus analysis time). They are statistic results of observation departures from background and analysis results according to observation variables. Please see Section 4.5 for more details. -\item \textit{fort.220}: output from the inner loop minimization (in \textit{pcgsoi.f90}). Please see Section 4.6 for details. -\item \textit{anavinfo}: info file to set up control variables, state variables, and background variables. Please see Advanced GSI User\textquotesingle s Guide for details. +\item \textit{fort.220}: output from the inner loop minimization (in \textit{pcgsoi.f90}). Please see Section 4.6 for details. +\item \textit{anavinfo}: info file to set up control, state, and background variables. Please see the Advanced GSI User\textquotesingle s Guide for details. \item \textit{*info} (\textit{convinfo},\textit{satinfo}, \dots): info files that control data usage. Please see Section \ref{sec4.3} for details. \item \textit{berror\_stats} and \textit{errtable}: background error file (binary) and observation error file (text). -\item \textit{*bufr}: observation BUFR files linked to the run directory Please see Section 3.1 for details. +\item \textit{*bufr}: observation BUFR files linked to the run directoryi. Please see Section 3.1 for details. \item \textit{satbias\_in}: the input coefficients of bias correction for satellite radiance observations. \item \textit{satbias\_out}: the output coefficients of bias correction for satellite radiance observations after the GSI run. \item \textit{satbias\_pc}: the input coefficients of bias correction for passive satellite radiance observations. -\item \textit{list\_run\_directory} : the complete list of files in the run directory before cleaning the run directory. This is generated by the GSI run script. +\item \textit{list\_run\_directory} : the complete list of files in the run directory before cleaning takes place. This is generated by the GSI run script. \end{itemize} -The \verb|diag| files, such as \verb|diag_(instrument_satellite)_anl.(time)| and \verb|diag_conv_anl.(time)|, contain important information about the data used in the GSI, including observation departure from analysis results for each observation (O-A). Similarly, \verb|diag_conv_ges| and \verb|diag_(instrumen_satellite)_ges.(time)| include observation innovation for each observation (O-B). These files can be very helpful in understanding the detailed impact of data on the analysis. A tool is provided to process these files, which is introduced in Appendix A.2. +The \verb|diag| files, such as \verb|diag_(instrument_satellite)_anl.(time)| and \verb|diag_conv_anl.(time)|, contain important information about the data used in the GSI, including observation departure from analysis results for each observation (O-A). Similarly, \verb|diag_conv_ges| and \verb|diag_(instrumen_satellite)_ges.(time)| include the observation innovation for each observation (O-B). These files can be very helpful in understanding the detailed impact of data on the analysis. A tool is provided to process these files, which is introduced in Appendix A.2. -There are many intermediate files in this directory during the running stage or if the GSI run crashes; the complete list of files before cleaning is saved in a file \verb|list_run_directory|. Some knowledge about the content of these files is very helpful for debugging if the GSI run crashes. Please check the table \ref{t37} for the meaning of these files. (Note: you may not see all the files in the list because different observational data are used. Also, the fixed files prepared for a GSI run, such as CRTM coefficient files, are not included.) +There are many intermediate files in this directory while GSI is running or if the run crashes. The complete list of files in the directory (prior to cleaning) is saved in file \verb|list_run_directory|. Some knowledge about the content of these files is very helpful for debugging if the GSI run crashes. Please check table \ref{t37} for the meaning of these files. (Note: you may not see all the files in the list because different observational data are used. Also, the fixed files prepared for a GSI run, such as CRTM coefficient files, are not included.) \begin{table}[htbp] \centering -\caption{The list of GSI intermediate files} +\caption{List of GSI intermediate files} \begin{tabular}{|p{5cm}|p{10cm}|} \hline \hline File name & Content \\ \hline -sigf03 & This is a temporal file holding binary format background files (typically sigf03, sigf06 and sigf09 if FGAT used). When you see this file, at the minimum, a background file was successfully read in.\\ +sigf03 & This is a temporary file, holding binary format background files (typically sigf03, sigf06 and sigf09 if FGAT used). When you see this file, at the minimum, a background file was successfully read in.\\ \hline -siganl & Analysis results in binary format. When this file exists, the analysis part has finished.\\ +siganl & Analysis results in binary format. When this file exists, the analysis has finished.\\ \hline -pe????.(conv or instrument\_satellite)\_(outer loop) & Diagnostic files for conventional and satellite radiance observations at each outer loop and each sub-domains (????=subdomain id)\\ +pe????.(conv or instrument\_satellite)\_(outer loop) & Diagnostic files for conventional and satellite radiance observations at each outer loop and each sub-domain (????=subdomain id)i.\\ \hline -obs\_input.???? & Observation scratch files (each file contains observations for one observation type within whole analysis domain and time window. ????=observation type id in namelist)\\ +obs\_input.???? & Observation scratch files (each file contains observations for one observation type within the whole analysis domain and time window. ????=observation type id in namelist).\\ \hline -pcpbias\_out & Output precipitation bias correction file\\ +pcpbias\_out & Output precipitation bias correction file.\\ \hline \end{tabular} \label{t37} @@ -1333,31 +1409,31 @@ \section{GSI Analysis Result Files in Run Directory}\label{sec3.3} \section{Introduction to Frequently Used GSI Namelist Options} %------------------------------------------------------------------------------- -The complete namelist options and their explanations are listed in Advanced GSI User\textquotesingle s Guide Appendix A. For most GSI analysis applications, only a few namelist variables need to be changed. Here we introduce frequently used variables for regional analyses: +The complete namelist options and their explanations are listed in Appendix A of the Advanced GSI User\textquotesingle s Guide. For most GSI analysis applications, only a few namelist variables need to be changed. Here we introduce frequently used variables for regional analyses: %------------------------------------------------------------------------------- -\subsection{Set Up the Number of Outer Loop and Inner Loop} +\subsection{Set Up the Number of Outer and Inner Loops} %------------------------------------------------------------------------------- To change the number of outer loops and the number of inner iterations in each outer loop, the following three variables in the namelist need to be modified: \begin{itemize} -\item \verb|miter|: number of outer loops of analysis. -\item \verb|niter(1)|: maximum iteration number of inner loop iterations for the 1st outer loop. The inner loop will stop when it reaches this maximum number, or reaches the convergence threshold, or when it fails to converge. -\item \verb|niter(2)|: maximum iteration number of inner loop iterations for the 2nd outer loop. -\item If \verb|miter| is larger than 2, repeat \verb|niter| with larger index. +\item \verb|miter|: number of outer analysis loops. +\item \verb|niter(1)|: maximum iteration number of inner loop iterations for the 1\textsuperscript{st} outer loop. The inner loop will stop when it reaches this maximum number, when it reaches the convergence threshold, or when it fails to converge. +\item \verb|niter(2)|: maximum iteration number of inner loop iterations for the 2\textsuperscript{nd} outer loop. +\item If \verb|miter| is larger than two, repeat \verb|niter| with larger index. \end{itemize} %------------------------------------------------------------------------------- \subsection{Set Up the Analysis Variable for Moisture} %------------------------------------------------------------------------------- -There are two moisture analysis variable options. It is decided by the namelist variable: +There are two moisture analysis variable options. It is based on the following namelist variable: \verb|qoption = 1 or 2|: \begin{itemize} -\item If \verb|qoption=1|, the moisture analysis variable is pseudo-relative humidity. The saturation specific humidity, qsatg, is computed from the guess and held constant during the inner loop. Thus, the RH control variable can only change via changes in specific humidity, q. -\item If \verb|qoption=2|, the moisture analysis variable is normalized RH. This formulation allows RH to change in the inner loop via changes to surface pressure (pressure), temperature, or specific humidity. +\item If \verb|qoption=1|, the moisture analysis variable is pseudo-relative humidity. The saturation specific humidity, qsatg, is computed from the guess and held constant during the inner loop. Thus, the relative humidity control variable can only change via changes in specific humidity, q. +\item If \verb|qoption=2|, the moisture analysis variable is normalized relative humidity. This formulation allows relative humidity to change in the inner loop via changes to surface pressure, temperature, or specific humidity. \end{itemize} %------------------------------------------------------------------------------- @@ -1368,10 +1444,10 @@ \subsection{Set Up the Background File} \begin{itemize} \item \verb|regional|: if true, perform a regional GSI run using either ARW or NMM inputs as the background. If false, perform a global GSI analysis. If either \verb|wrf_nmm_regional| or \verb|wrf_mass_regional| are true, it will be set to true. -\item \verb|wrf_nmm_regional|: if true, background comes from WRF NMM. When using other background fields, set it to false. -\item \verb|wrf_mass_regional|: if true, background comes from WRF ARW. When using other background fields, set it to false. -\item \verb|nems_nmmb_regional|: if true, background comes from NMMB. When using other background fields, set it to false. -\item \verb|netcdf|: if true, WRF files are in NetCDF format, otherwise WRF files are in binary format. This option only works for performing a regional GSI analysis. +\item \verb|wrf_nmm_regional|: if true, the background comes from WRF-NMM. When using other background fields, set it to false. +\item \verb|wrf_mass_regional|: if true, the background comes from WRF-ARW. When using other background fields, set it to false. +\item \verb|nems_nmmb_regional|: if true, the background comes from NMMB. When using other background fields, set it to false. +\item \verb|netcdf|: if true, WRF files are in NetCDF format, otherwise WRF files are in binary format. This option only works for a regional GSI analysis. \end{itemize} %------------------------------------------------------------------------------- @@ -1381,9 +1457,9 @@ \subsection{Set Up the Output of Diagnostic Files} The following variables tell the GSI to write out diagnostic results in certain loops: \begin{itemize} -\item \verb|write_diag(1)|: if true, write out diagnostic data in the beginning of the analysis, so that we can have information on Observation $-$ Background (O-B) . -\item \verb|write_diag(2)|: if true, write out diagnostic data at the end of the 1st (before the 2nd outer loop starts) . -\item \verb|write_diag(3)|: if true, write out diagnostic data at the end of the 2nd outer loop (after the analysis finishes if the outer loop number is 2), so that we can have information on Observation $-$ Analysis (O-A) +\item \verb|write_diag(1)|: if true, write out diagnostic data in the beginning of the analysis, so that we can have information on observation $-$ background (O-B) differences. +\item \verb|write_diag(2)|: if true, write out diagnostic data at the end of the 1\textsuperscript{st} outer loop (before the 2\textsuperscript{nd} outer loop starts). +\item \verb|write_diag(3)|: if true, write out diagnostic data at the end of the 2\textsuperscript{nd} outer loop (after the analysis finishes if the outer loop number is two), so that we can have information on observation $-$ analysis (O-A) differences. \end{itemize} Please check appendix A.2 for the tools to read the diagnostic files. @@ -1414,10 +1490,10 @@ \subsection{Set Up the GSI Recognized Observation Files} \end{scriptsize} \begin{itemize} -\item \verb|dfile|: GSI recognized observation file name. The observation file contains observations used for a GSI analysis. This file can include several observation variables from different observation types. The file name in this parameter will be read in by GSI. This name can be changed as long as the name in the link from the BUFR/PrepBUFR file in the run scripts also changes correspondingly. -\item \verb|dtype|: analysis variable name that GSI can read in and handle. Please note this name should be consistent with that used in the GSI code. +\item \verb|dfile|: GSI recognized observation file name. The observation file contains observations used for a GSI analysis. This file can include several observation variables from different observation types. The file name listed by this parameter will be read in by GSI. This name can be changed as long as the name in the link from the BUFR/PrepBUFR file in the run scripts also changes correspondingly. +\item \verb|dtype|: analysis variable name that GSI can read in. Please note this name should be consistent with that used in the GSI code. \item \verb|dplat|: sets up the observation platform for a certain observation, which will be read in from the file \verb|dfile|. -\item \verb|dsis|: sets up data name (including both data type and platform name) used inside GSI. +\item \verb|dsis|: sets up the data name (including both data type and platform name) used inside GSI. \end{itemize} Please see Section 4.3 for examples and explanations of these variables. @@ -1426,7 +1502,7 @@ \subsection{Set Up the GSI Recognized Observation Files} \subsection{Set Up Observation Time Window} %------------------------------------------------------------------------------- -In the namelist section \verb|OBS_INPUT|, use \verb|time_window_max| to set maximum half time window (hours) for all data types. In the \verb|convinfo| file, you can use the column twindow to set the half time window for a certain data type (hours). For conventional observations, only observations within the smaller window of these two will be kept for further processing. For others, observations within \verb|time_window_max| will be kept for further processing. +In the namelist section \verb|OBS_INPUT|, use \verb|time_window_max| to set the maximum half time window (hours) for all data types. In the \verb|convinfo| file, you can use the column "twindow" to set the half time window for a certain data type (hours). For conventional observations, only observations within the smaller window of these two will be kept for further processing. For others, observations within \verb|time_window_max| will be kept for further processing. %------------------------------------------------------------------------------- \subsection{Set Up Data Thinning} @@ -1434,7 +1510,7 @@ \subsection{Set Up Data Thinning} 1) Radiance data thinning -Radiance data thinning is controlled through two GSI namelist variables in the section \verb| &OBS_INPUT|. Below is an example of the section: +Radiance data thinning is controlled through two GSI namelist variables in the section \verb| &OBS_INPUT|. Below is an example: \begin{scriptsize} \begin{verbatim} @@ -1454,14 +1530,14 @@ \subsection{Set Up Data Thinning} \end{verbatim} \end{scriptsize} -The two namelist variables that control the radiance data thinning are real array dmesh in the 1st line and the dthin values in the 6th column. The dmesh gives a set of the mesh sizes in unit km for radiance thinning grids, while the dthin defines if the data type it represents needs to be thinned and which thinning grid (mesh size) to use. If the value of \verb|dthin| is: +The two namelist variables that control the radiance data thinning are real array "dmesh" in the 1\textsuperscript{st} line and the "dthin" values in the 6\textsuperscript{th} column. The "dmesh" array sets mesh sizes for radiance thinning grids in kilometers, while "dthin" defines if the data type it represents needs to be thinned and which thinning grid (mesh size) to use. If the value of \verb|dthin| is: \begin{itemize} -\item an integer less than or equal to 0, no thinning is needed -\item an integer larger than 0, this kind of radiance data will be thinned in a thinning grid with the mesh size defined as dmesh (dthin). +\item an integer less than or equal to zero, no thinning is needed +\item an integer larger than zero, this kind of radiance data will be thinned using the mesh size defined as dmesh (dthin). \end{itemize} -The following gives several thinning examples defined by the above sample \verb| &OBS_INPUT| section: +The following section provides several thinning examples defined by the above sample \verb| &OBS_INPUT| section: \begin{itemize} \item Data type \verb|ps| from prepbufr: no thinning because \verb|dthin=0| \item Data type \verb|gps_ref| from gpsrobufr: no thinning because \verb|dthin=0| diff --git a/doc/GSI_user_guide/gsi_ch4.tex b/doc/GSI_user_guide/gsi_ch4.tex index 729829797..e763fca70 100644 --- a/doc/GSI_user_guide/gsi_ch4.tex +++ b/doc/GSI_user_guide/gsi_ch4.tex @@ -1,9 +1,9 @@ -\chapter{GSI Diagnostics and Tuning} +\chapter{GSI Diagnostics and Tuning}\label{gsi_diag} \setlength{\parskip}{12pt} -The guidance in this chapter will help users to understand how and where to check the output from GSI to determine whether a run was successful. Properly checking the GSI output will also provide useful information to diagnose potential errors in the system. The chapter starts with an introduction to the content and structure of the GSI standard output (\textbf{stdout}). It continues with the use of a single observation to check the features of the GSI analysis. Then, observation usage control, analysis domain partition, fit files, and the optimization process will all be presented from information within the GSI output files (including stdout). +The guidance in this chapter will help users understand how and where to check output from GSI to determine whether a run was successful. Properly checking the GSI output will also provide useful information to diagnose potential errors in the system. This chapter starts with an introduction to the content and structure of the GSI standard output file: (\textbf{stdout}). It continues with the use of a single observation to check the features of the GSI analysis. Then, observation usage control, analysis domain partitioning, fit files, and the optimization process will all be presented from information within the GSI output files (including \textbf{stdout}). -This chapter follows the online case example for 2014061700. This case uses a WRF-ARW NetCDF file as the background and analyzes several observations typical for operations, including most conventional observation data, several radiance data (AMSU-A, HIRS4, and MHS), and GPSRO data. The case was run on a Linux cluster supercomputer, using 4 processors. Users can follow this test to reproduce the following results by visiting: +This chapter follows the online case example for 2014061700. This case uses a WRF-ARW NetCDF file as the background and analyzes several observations typical for operations, including most conventional observation data, several radiance data sets (AMSU-A, HIRS4, and MHS), and GPSRO data. The case was run on a Linux cluster supercomputer, using four processors. Users can execute this test to reproduce the following results by visiting: \begin{center} \url{http://www.dtcenter.org/com-GSI/users/tutorial/index.php} @@ -16,25 +16,25 @@ \section{Understanding Standard Output (\textit{stdout})} In Section \ref{sec3.3}, we listed the files present in the GSI run directory following a successful GSI analysis and briefly introduced the contents of several important files. Of these, \textbf{stdout} is the most useful because critical information about the GSI analysis can be obtained from the file. From \textbf{stdout}, users can check if the GSI has successfully completed, if optimal iterations look correct, and if the background and analysis fields are reasonable. Understanding the content of this file can also be very helpful for users to find where and why the GSI failed if it crashes. -The structure of \textbf{stdout} follows the typical steps in a meteorological data analysis system: +The structure of \textbf{stdout} follows the typical steps of a meteorological data analysis system: \begin{enumerate} \item Read in all data and prepare analysis: \begin{itemize} \item Read in configuration (namelist) -\item Read in background +\item Read in the background \item Read in observations \item Partition domain and data for parallel analysis \item Read in constant fields (fixed files) \end{itemize} \item Calculate observation innovations \item Optimal iteration (analysis) -\item Save analysis result +\item Save analysis results \end{enumerate} -In this section, the detailed structure and content of \textbf{stdout} are explained using the v3.5 online example case: 2014061700. To keep the output concise and make it more readable, most repeated content was deleted (shown by the dotted line). For the same reason, the accuracy of some numbers has been reduced to avoid line breaks in \textbf{stdout}. +In this section, the detailed structure and content of \textbf{stdout} are explained using the online example case: 2014061700. To keep the output concise and make it more readable, most repeated content was deleted (shown with a dotted line). For the same reason, the precision of some numbers has been reduced to avoid line breaks in \textbf{stdout}. -The following indicates the start of the GSI analysis. It shows the beginning time of this run: +The following indicates the start of the GSI analysis. It shows the date and time that GSI started running: \begin{scriptsize} \begin{verbatim} @@ -44,7 +44,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -This part shows the content of anavinfo, a list of state and control variables. +The following shows the content of anavinfo, a list of state and control variables: \begin{scriptsize} \begin{verbatim} @@ -101,7 +101,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -Next is the content of all namelist variables used in this analysis. The 1st part shows the 4DVAR setups. Please note that while this version of the GSI includes some 4DVAR interface, it is untested in this release. The general set up for the GSI analysis (3DVAR) is located in the \verb|&SETUP| section of the GSI namelist. Please check Appendix B for definitions and default values of each namelist variable. +Next is the content of all namelist variables used in this analysis. The 1st part shows 4DVAR setup information. Please note that while this version of the GSI includes a 4DVAR option, it remains untested. The general setup for the GSI analysis (3DVAR) is located in the \verb|&SETUP| section of the GSI namelist. Please check Appendix B for definitions and default values of each namelist variable. \begin{scriptsize} \begin{verbatim} @@ -193,16 +193,16 @@ \section{Understanding Standard Output (\textit{stdout})} ... \end{verbatim} \end{scriptsize} -This version of GSI attempts to read multi-time-level backgrounds for option FGAT (First Guess at Appropriate Time), however we only have provided one in this test case. Therefore, there is error information at the beginning of the reading background portion: +This version of GSI attempts to read multiple time level backgrounds for option FGAT (First Guess at Appropriate Time), however we only have provided one time level in this test case. Therefore, there is an error while reading background information: \begin{scriptsize} \begin{verbatim} CONVERT_NETCDF_MASS: problem with flnm1 = wrf_inou1, Status = -1021 \end{verbatim} \end{scriptsize} -We can ignore these errors for missing files \textit{wrf\_inou1}, \textit{wrf\_inou2}, \ldots , \textit{wrf\_inou9} because we only ran 3DVAR with one background. +We can ignore errors for missing files \textit{wrf\_inou1}, \textit{wrf\_inou2}, \ldots, and \textit{wrf\_inou9}, because we are only running 3DVAR with one background. -Next, the background fields for the analysis are read in and the maximum, minimum and median values of the fields at each vertical level are displayed. Here, only part of the variables ZNU and T are shown, and all other variables read by the GSI are listed only as the variable name in the NetCDF file(rmse\_var = T). The maximum and minimum values are useful for a quick verification that the background fields have been read successfully. From this section, we also know the time (\verb|iy,m,d,h,m,s|) and dimension (\verb|nlon,lat,sig_regional|) of the background field. +Next, the background fields for the analysis are read in, and the maximum, minimum, and median values of the fields at each vertical level are displayed. Here, only part of the variables ZNU and T are shown, with all other variables read by the GSI listed solely as the variable name in the NetCDF file(rmse\_var = T). Maximum and minimum values are useful for a quick verification that the background fields have been read successfully. From this section, we also know the time (\verb|iy,m,d,h,m,s|) and dimension (\verb|nlon,lat,sig_regional|) of the background field. \begin{scriptsize} \begin{verbatim} @@ -326,7 +326,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -For some variables, the following NETCDF error information might show up when the variables are not in the background fields. These errors don\textquotesingle t affect the GSI run so you can ignore them. +For some variables, the following NETCDF error information might show up when they are not in the background fields. These errors don\textquotesingle t affect the GSI run so you can ignore them. \begin{scriptsize} \begin{verbatim} @@ -343,21 +343,21 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -Again, some error information on missing background files shows up. Ignore if you are not doing FGAT: +Again, some error information on missing background files shows up. Ignore if you are not doing FGAT. \begin{scriptsize} \begin{verbatim} CONVERT_NETCDF_MASS: problem with flnm1 = wrf_inou4, Status = -1021 \end{verbatim} \end{scriptsize} -Following this is information on the byte order of the binary background files. Because we used a NetCDF file, there is no need to be concerned with byte order. When using a binary format background, byte-order can be a problem. Beginning with the release version v3.2, GSI can automatically check the background byte-order and read it in right order: +Following this is information on the byte order of the binary background files. Since we used a NetCDF file, there is no need to be concerned with byte order. When using a binary format background, byte-order can be a problem. Beginning with the release version v3.2, GSI can automatically check the background byte-order and read it in the right order: \begin{scriptsize} \begin{verbatim} in convert_regional_guess, for wrf arw binary input, byte_swap= F \end{verbatim} \end{scriptsize} -Information on setting the grid related variables, and the beginning and ending indices for thread 1: +Information on setting the grid related variables, and the beginning and ending indices for thread one: \begin{scriptsize} \begin{verbatim} INIT_GRID_VARS: number of threads 1 @@ -365,7 +365,7 @@ \section{Understanding Standard Output (\textit{stdout})} 168 \end{verbatim} \end{scriptsize} -Information on the initial pointer location for each variable in the Jacobian for the use of the satellite radiance data: +Information on the initial pointer location for each variable in the Jacobian for the use of satellite radiance data: \begin{scriptsize} \begin{verbatim} Vars in Rad-Jacobian (dims) @@ -399,7 +399,7 @@ \section{Understanding Standard Output (\textit{stdout})} using restart file date = 2014 6 17 0 \end{verbatim} \end{scriptsize} -Read in radar station information and generate superobs for radar Level-II radial velocity. This case didn\textquotesingle t have radar Level-II velocity data linked. There is warning information about opening the file but this will not impact the rest of the GSI analysis. +Read in radar location information and generate superobs for radar level-II radial velocity. This case didn\textquotesingle t have radar level-II velocity data linked, therefore there is warning about when opening the file, but this will not impact the rest of the GSI analysis. \begin{scriptsize} \begin{verbatim} RADAR_BUFR_READ_ALL: analysis time is 2014 6 17 @@ -418,7 +418,7 @@ \section{Understanding Standard Output (\textit{stdout})} PCPINFO_READ: no pcpbias file. set predxp=0.0 \end{verbatim} \end{scriptsize} -Read in and show the content of the conventional observation information files (\textit{convinfo}; see Section \ref{sec4.3} for details). Here is part of the stdout shown \textit{convinfo}: +Read in and show the content of the conventional observation information file (\textit{convinfo}; see Section \ref{sec4.3} for details). Here is the part of the \textbf{stdout} file showing information from \textit{convinfo}: \begin{tiny} \begin{verbatim} @@ -443,7 +443,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{tiny} -Starting subroutine \textit{glbsoi} and information on reading in background fields from intermediate binary file \textit{sigf03} and partitioning the whole 2D field into subdomains for parallel analysis: +Starting subroutine \textit{glbsoi} with information on reading in background fields from the intermediate binary file \textit{sigf03} and partitioning the whole 2D field into subdomains for parallel analysis: \begin{scriptsize} \begin{verbatim} @@ -468,7 +468,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -Show observation observer is successfully initialized and inquire about the control vectors (space for analysis variables). +Show observation observer as successfully initialized and inquire about the control vectors (space for analysis variables). \begin{scriptsize} \begin{verbatim} @@ -488,9 +488,9 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -The following information is related to observation ingest processes, which are distributed over all the processors with each processor reading in at least one observation type. To speed up reading process, some of the large datasets will use more than one (ntasks) processor to read. +The following information is related to the observation ingest processes, which is distributed over all the processors with each processor reading in at least one observation type. To speed up the reading process, some of the large datasets will use more than one (ntasks) processor for the ingest process. -Before reading in the data from BUFR files, GSI checks the file status on whether the observation time matches the analysis time and how namelist option \textit{offtime\_data} is set (can be used to turn off the time consistent check between observation and analysis time). This step also checks for consistency between the satellite radiance data types in the BUFR files and the usage setups in the \textit{satinfo} files. The following shows stdout information from this step: +Before reading in data from BUFR files, GSI checks the file status to insure the observation time matches the analysis time and whether the namelist option \textit{offtime\_data} is set (can be used to turn off the time consistency check between observation and analysis time). This step also checks for consistency between the satellite radiance data types in the BUFR files and the usage setups in the \textit{satinfo} files. The following shows \textbf{stdout} information from this step: \begin{scriptsize} \begin{verbatim} @@ -533,7 +533,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -The list of observation types that will be read in and processors used to read them: +The list of observation types that were read in and processors used to read them: \begin{scriptsize} \begin{verbatim} @@ -559,7 +559,7 @@ \section{Understanding Standard Output (\textit{stdout})} READ_OBS: read 30 amsua amsua_metop-b using ntasks= 1 2 2 0 \end{verbatim} \end{scriptsize} -Display basic statistics for full horizontal surface fields (If radiance BUFR files are not linked, this section will not be in the stdout file): +Display basic statistics for full horizontal surface fields (If radiance BUFR files are not linked, this section will not be in the \textbf{stdout} file): \begin{scriptsize} \begin{verbatim} @@ -581,7 +581,7 @@ \section{Understanding Standard Output (\textit{stdout})} ================================================================================ \end{verbatim} \end{scriptsize} -Loop over all data files to read in observations, also reads in rejection list for surface observations and show GPS observations outside the time window: +Loop over all data files to read in observations, also read in rejection list for surface observations and show GPS observations outside the time window: \begin{tiny} \begin{verbatim} @@ -628,10 +628,9 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{tiny} -Using the above output information, many details on the observations can be obtained. For example, the last line indicates that subroutine \textit{READ\_BUFRTOVS} was called to read in NOAA-19 AMSU-A (\verb|sis=amsua_n19|) from the BUFR file \textit{amsuabufr} (\verb|file=amsuabufr|). Furthermore, this kind of data has 20370 observations in the file (\verb|nread=20370|) and 16912 in analysis domain and time-window (\verb|ndata=16912|). The data was thinned on a 60 km coarse grid (\verb|rmesh=60.000000|). +Using the above output information, many details on the observations can be obtained. For example, the last line indicates that subroutine \textit{READ\_BUFRTOVS} was called to read in NOAA-19 AMSU-A (\verb|sis=amsua_n19|) data from the BUFR file \textit{amsuabufr} (\verb|file=amsuabufr|). Furthermore, there are 20370 observations in this file (\verb|nread=20370|) and 16912 in the analysis domain and within the time window (\verb|ndata=16912|). The data was thinned on a 60 km coarse grid (\verb|rmesh=60.000000|). - -The next step partitions observations into subdomains. The observation distribution is summarized below by listing the number of observations for each observation variable in each subdomain (see Section \ref{sec4.4} for more information): +The next step partitions observations into subdomains. The observation distribution is summarized below by listing the number of observations for each variable per subdomain (see Section \ref{sec4.4} for more information): \begin{scriptsize} \begin{verbatim} @@ -669,9 +668,9 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -From this point forward in the stdout, the output shows many repeated entries. This is because the information is written from inside the outer loop. Typically the outer loop is iterated twice. +From this point forward in the \textbf{stdout} file, the output shows many repeated entries. This is because the information is written from inside the outer loop. Typically the outer loop is run twice. -For each outer loop, the work begins with the calculation of the observation innovation. This calculation is done by the subroutine setuprhsall, which sets up the right hand side (rhs) of the analysis equation. This information is contained within the stdout file, which is shown in the following sections: +For each outer loop, the work begins with the calculation of the observation innovation. This calculation is done by the subroutine \textbf{setuprhsall}, which sets up the right hand side (rhs) of the analysis equation. This information is contained within the \textbf{stdout} file, which is shown in the following sections: Start the first outer analysis loop: @@ -708,7 +707,7 @@ \section{Understanding Standard Output (\textit{stdout})} ... \end{verbatim} \end{scriptsize} -In the above section, when computing the radiance observation innovation, information on reading in CRTM coefficients follows SETUPALL information. In stdout, only information related to available radiance data are printed. The complete innovation can be found in the diagnostic files for each observation (for details see Appendix A.2): +In the above section, when computing the radiance observation innovation, information on reading in CRTM coefficients follows SETUPALL information. In the \textbf{stdout} file, only information related to available radiance data are printed. The complete innovation information can be found in the diagnostic files for each observation (for details see Appendix A.2): \begin{scriptsize} \begin{verbatim} @@ -760,7 +759,7 @@ \section{Understanding Standard Output (\textit{stdout})} update_guess: successfully complete \end{verbatim} \end{tiny} -At the end of the 1st outer loop, print some diagnostics about the guess fields after adding the analysis increment to the guess and diagnostics about the analysis increment: +At the end of the 1\textsuperscript{st} outer loop, print some diagnostics about the analysis increments as well as information on the guess fields after adding the analysis increments to the background: \begin{scriptsize} \begin{verbatim} ================================================================================ @@ -810,7 +809,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -When calculating the radiance data innovation, there is no need to read in CRTM coefficients again because they were already read in the first outer loop: +When calculating the radiance data innovation, there is no need to read in CRTM coefficients again because they were already read in during the first outer loop: \begin{scriptsize} \begin{verbatim} SETUPALL:,obstype,isis,nreal,nchanl= ps ps 20 0 @@ -874,7 +873,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{tiny} -Diagnostics of the analysis results after adding the analysis increment to the guess and diagnostics about the analysis increment: +Diagnostics of the analysis results after adding the analysis increment to the guess, as well as diagnostics about the analysis increments: \begin{scriptsize} \begin{verbatim} ================================================================================ @@ -908,7 +907,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -Because the outer loop is set to 2, the completion of the 2nd outer loop is the end of the analysis. The next step is to save the analysis results. Again, only a portion of variable T is shown and all other variables are listed according to variable name in the NetCDF file (\verb|rmse_var = T|). The maximum and minimum values are useful information for a quick check of the reasonableness of the analysis: +Because the outer loop is set to two, the completion of the 2\textsuperscript{nd} outer loop marks the end of the analysis. The next step is to save the analysis results. Again, only a portion of variable "T" is shown and all other variables are listed according to variable name in the NetCDF file (\verb|rmse_var = T|). The maximum and minimum values are useful information for a quick sanity check of the analysis: \begin{scriptsize} \begin{verbatim} @@ -974,7 +973,7 @@ \section{Understanding Standard Output (\textit{stdout})} ... \end{verbatim} \end{scriptsize} -After completion of the analysis, the subroutine setuprhsall is called again if \verb|write_diag(3)=.true.|,to calculate analysis O-A information (the third time seeing this information): +After completion of the analysis, the subroutine "setuprhsall" is called again if \verb|write_diag(3)=.true.|, to calculate analysis and O-A information (this marks the third time this information is presented): \begin{scriptsize} \begin{verbatim} @@ -1004,7 +1003,7 @@ \section{Understanding Standard Output (\textit{stdout})} [000]gsisub(): : complete. \end{verbatim} \end{scriptsize} -The end of the GSI analysis (a successful analysis must reach this end, but to reach this end is not necessarily a successful analysis), which shows the time of ending this GSI run and some additional resource statistics: +The end of the GSI analysis (reaching this point does not necessarily guarantee a successful analysis), which shows the date and time when GSI finished and some additional resource statistics: \begin{scriptsize} \begin{verbatim} ENDING DATE-TIME JUL 02,2016 20:43:40.422 184 SAT 2457572 @@ -1025,7 +1024,7 @@ \section{Understanding Standard Output (\textit{stdout})} \end{verbatim} \end{scriptsize} -Different GSI applications may write out slightly different stdout information but the major flow and information are the same. A good knowledge of the stdout file gives users a clear picture how GSI runs through each part and the key information on a GSI run like data distribution and inner iterations. +Different GSI applications may write out slightly different \textbf{stdout} file information but the major flow and information are the same. A good knowledge of the \textbf{stdout} file gives users a clear picture of how GSI runs and the key information provided during a GSI run like data distribution and inner iterations. %------------------------------------------------------------------------------- @@ -1033,7 +1032,7 @@ \section{Single Observation Test} \label{sec4.2} %------------------------------------------------------------------------------- -A single observation test is a GSI run with only one (pseudo) observation at a specific location of the analysis domain. By examining the analysis increments from a single observation test, one can visualize the important features of the analysis, such as the ratio of background error and observation error variance and the pattern of the background error covariance. Therefore, the single observation test is the first check that users should do after successfully installing the GSI. +A single observation test is a GSI where only one (pseudo) observation is assimilated from a specific time and location within the analysis domain. By examining the analysis increments from a single observation test, one can visualize the important features of the analysis, such as the ratio of background error and observation error variance and the pattern of the background error covariance. Therefore, the single observation test is the first thing that users should run after successfully installing the GSI. %------------------------------------------------------------------------------- \subsection{Setup a Single Observation Test} @@ -1067,7 +1066,7 @@ \subsection{Setup a Single Observation Test} Note: \begin{itemize} -\item Please check Appendix C in this User\textquotesingle s Guide for the explanation of each parameter. From these parameters, we can see that a useful observation in the analysis should include information like the observation type (\verb|oneob_type|), value (\verb|maginnov|), error (\verb|magoberr|), location (\verb|oblat|, \verb|oblong|, \verb|obpres|), and time (\verb|obdattim|, \verb|obhourset|). Users can dump out (use \textit{ncdump}) the global attributes from the NetCDF background file and set \verb|oblat|=\textit{CEN\_LAT}, \verb|oblong|=\textit{360-CEN\_LON} to have the observation at the center of the domain. +\item Please check Appendix C in the User\textquotesingle s Guide for the explanation of each parameter. From these parameters, we can see that a useful observation in the analysis should include information like the observation type (\verb|oneob_type|), value (\verb|maginnov|), observation error (\verb|magoberr|), location (\verb|oblat|, \verb|oblong|, \verb|obpres|), and time (\verb|obdattim|, \verb|obhourset|). Users can dump out (use \textit{ncdump}) the global attributes from the NetCDF background file and set \verb|oblat|=\textit{CEN\_LAT}, \verb|oblong|=\textit{360-CEN\_LON} to have the observation at the center of the domain. \item In the analysis, the GSI first generates a prepbufr file including only one observation based on the information given in the namelist \verb|&SINGLEOB_TEST| section. To generate this prepbufr file, the GSI needs to read in a PrepBUFR table, which is not needed when running a GSI analysis with real observations. The BUFR table is in the \textit{fix/} directory and needs to be copied to the run directory. We have put the following lines in the GSI run script for the single observation test: \begin{scriptsize} \begin{verbatim} @@ -1081,7 +1080,7 @@ \subsection{Setup a Single Observation Test} \subsection{Examples of Single Observation Tests for GSI} %------------------------------------------------------------------------------- -Figure \ref{fig:singleobs} is a single observation test that has a temperature observation (\verb|oneob_type='t'|) with a 1 degree innovation (\verb|maginnov=1.0|) and a 0.8 degree observation error (\verb|magoberr=0.8|). The background error covariance converted from global (GFS) BE was picked for better illustration. +Figure \ref{fig:singleobs} is a single observation test that has a temperature observation (\verb|oneob_type='t'|) with a one degree innovation (\verb|maginnov=1.0|) and a 0.8 degree observation error (\verb|magoberr=0.8|). The background error covariance converted from global (GFS) BE was picked to provide for better illustration. \begin{figure}[h!] \centering @@ -1090,7 +1089,7 @@ \subsection{Examples of Single Observation Tests for GSI} \label{fig:singleobs} \end{figure} -This single observation was located at the center of the domain. The results are shown with figures of the horizontal and vertical cross sections through the point of maximum analysis increment. The Figure \ref{fig:singleobs} was generated using NCL scripts, which can be found in the \textit{util/Analysis\_Utilities/plots\_ncl} directory, introduced in Section A.4 . +This single observation was located at the center of the domain. The results are shown with figures of the horizontal and vertical cross sections through the point of maximum analysis increment. The Figure \ref{fig:singleobs} was generated using NCL scripts, which can be found in the \textit{util/Analysis\_Utilities/plots\_ncl} directory, introduced in Section A.4. %------------------------------------------------------------------------------- \section{Control Data Usage} @@ -1100,30 +1099,30 @@ \section{Control Data Usage} Observation data used in the GSI analysis can be controlled through three parts of the GSI system: \begin{enumerate} -\item In GSI run script, through linking observation BUFR files to working directory -\item In GSI namelist (inside \textit{comgsi\_namelist.sh}), through section \verb|&OBS_INPUT| -\item Through parameters in info files (e.g.: convinfo, satinfo, etc) +\item In the GSI run script, by linking observation BUFR files to the working directory +\item In section \verb|&OBS_INPUT| of the GSI namelist (inside \textit{comgsi\_namelist.sh}) +\item Through parameters in info files (e.g.: convinfo, satinfo, etc.) \end{enumerate} -Each part gives different levels of control to the data usage in the GSI, which is introduced below: +Each part provides different levels of control for data usage in the GSI, which is introduced below: \begin{enumerate}[leftmargin=*] -\item Link observation BUFR files to working directory in GSI run script:\\ +\item Link observation BUFR files to the working directory in the GSI run script:\\ -All BUFR/PrepBUFR observation files need to be linked to the working directory with GSI recognized names before can be used by GSI analysis. The run script (\textit{run\_gsi\_regional.ksh}) makes these links after locating the working directory. Turning on or off these links can control the use of all the data contained in the BUFR files. Table \ref{tab41} provides a list of all default observation file names recognized by GSI and the corresponding examples of the observation BUFR files from NCEP. The following is the first 3 rows of the table as an example: +All BUFR/PrepBUFR observation files need to be linked to the working directory with GSI recognizable names before they can be used in a GSI analysis. The run script (\textit{run\_gsi\_regional.ksh}) makes these links after locating the working directory. Turning these links on or off can control the use of all the data contained in the BUFR files. Table \ref{tab41} provides a list of all default observation file names recognized by GSI and the corresponding examples of the observation BUFR files from NCEP. The following is the first three rows of the table as an example: \begin{table}[htbp] \centering -\caption{list of all default observation file names recognized by GSI} +\caption{List of all default observation file names recognized by GSI.} \begin{tabular}{|p{2cm}|p{9cm}|p{5cm}|} \hline \hline GSI Name & Content & Example file names \\ \hline -prepbufr & Conventional observations, including ps, t, q, pw, uv, spd, dw, sst, from observation platforms such as METAR, sounding, et al. & \textit{gdas1.t12z.prepbufr} \\ +prepbufr & Conventional observations, including ps, t, q, pw, uv, spd, dw, sst, from observation platforms such as METAR, soundings, etc. & \textit{gdas1.t12z.prepbufr} \\ \hline satwndbufr & satellite winds & \textit{gdas1.t12z.satwnd.tm00.bufr\_d} \\ \hline -amsuabufr & AMSU-A 1b radiance (brightness temperatures) from satellites NOAA-15, 16, 17,18, 19 and METOP-A/B & \textit{gdas1.t12z.1bamua.tm00.bufr\_d} \\ +amsuabufr & AMSU-A 1b radiance (brightness temperatures) from satellites NOAA-15, 16, 17,18, 19, and METOP-A/B & \textit{gdas1.t12z.1bamua.tm00.bufr\_d} \\ \hline \end{tabular} \label{tab41} @@ -1140,11 +1139,11 @@ \section{Control Data Usage} ln -s ${OBS_ROOT}/gdas1.t12z.1bamua.tm00.bufr_d amsuabufr \end{verbatim} \end{scriptsize} -The GSI recognized default observation filenames are set up in the namelist section \verb|&OBS_INPUT|, which certainly can be changed based on application needs (details see below). \\ +The GSI recognized default observation filenames are set up in the namelist section \verb|&OBS_INPUT|, which can be changed based on application needs (see below for details). \\ -\item In GSI namelist (inside \textit{comgsi\_namelist.sh}), section \verb|&OBS_INPUT|:\\ +\item In the GSI namelist (inside \textit{comgsi\_namelist.sh}), section \verb|&OBS_INPUT|:\\ -In this namelist section, observation files (column of dfile) are tied to the observation variables used inside the GSI code (column of dsis), for example, part of section \verb|OBS_INPUT| shows: +In this namelist section, observation files ("dfile" column) are tied to the observation variables used inside the GSI code ("dsis" column). For example, part of section \verb|OBS_INPUT| shows: \begin{scriptsize} \begin{verbatim} @@ -1173,7 +1172,7 @@ \section{Control Data Usage} \end{verbatim} \end{scriptsize} -This setup tells GSI that conventional observation variables \verb|ps|, \verb|t|, and \verb|q| should be read in from the file prepbufr and AMSU-A radiances from NOAA-15 and -18 satellites should be read in from the file amsuabufr. Deleting a particular line in \verb|&OBS_INPUT| will turn off the use of the observation variable presented by the line in the GSI analysis but other variables under the same type still can be used. For example, if we delete: +This setup tells GSI that conventional observation variables \verb|ps|, \verb|t|, and \verb|q| should be read in from the file prepbufr, while AMSU-A radiances from NOAA-15 and NOAA-18 satellites should be read in from the file \textbf{amsuabufr}. Deleting a particular line in \verb|&OBS_INPUT| will turn off the use of the observation variable presented by the line in the GSI analysis but other variables under the same type can still be used. For example, if we delete: \begin{scriptsize} \begin{verbatim} @@ -1184,7 +1183,7 @@ \section{Control Data Usage} Then, the AMSU-A observation from NOAA-15 will not be used in the analysis but the AMSU-A observations from NOAA-18 will still be used.\\ -The observation filename in dfile can be different from the sample script (\textit{comgsi\_namelist.ksh}). If the filename in dfile has been changed, the link from the BUFR files to the GSI recognized name in the run script also needs to be changed correspondingly. For example, if we change the dfile for amsuabufr file for NOAA-15 to be \verb|amsuabufr_n15| +The observation filename in "dfile" can be different from the sample script (\textit{comgsi\_namelist.ksh}). If the filename in "dfile" has been changed, the link from the BUFR files to the GSI recognized name in the run script also needs to be changed correspondingly. For example, if we change the "dfile" in \textbf{amsuabufr} for NOAA-15 to be \verb|amsuabufr_n15|, \begin{scriptsize} \begin{verbatim} @@ -1203,12 +1202,12 @@ \section{Control Data Usage} \end{verbatim} \end{scriptsize} -The GSI will read NOAA-18 AMSU-A observations from file amsuabufr and NOAA-15 AMSU-A observations from file \verb|amsuabufr_n15| based on the above changes to the run scripts and namelist. In this example, both amsuabufr and \verb|amsuabufr_15| are linked to the same BUFR file and NOAA-15 AMSU-A and NOAA-18 AMSU-A observations are still read in from the same BUFR file. If amsuabufr and \verb|amsuabufr_15| link to different BUFR files, then NOAA-15 AMSU-A and NOAA-18 AMSU-A will be read in from different BUFR files. Clearly, the changeable filename in \textit{dfile} gives GSI more capability to handle multiple data resources.\\ +The GSI will read NOAA-18 AMSU-A observations from file \textbf{amsuabufr} and NOAA-15 AMSU-A observations from file \verb|amsuabufr_n15| based on the above changes to the run scripts and namelist. In this example, both \textbf{amsuabufr} and \verb|amsuabufr_15| are linked to the same BUFR file and NOAA-15 AMSU-A and NOAA-18 AMSU-A observations are still read in from the same BUFR file. If \textbf{amsuabufr} and \verb|amsuabufr_15| link to different BUFR files, then NOAA-15 AMSU-A and NOAA-18 AMSU-A will be read in from different BUFR files. The changeable filename in \textit{dfile} gives GSI more flexibility to handle multiple data resources.\\ \item Use info files to control data usage\\ -For each variable, observations can come from multiple platforms (data types or observation instruments). For example, surface pressure (ps) can come from METAR observation stations (data type 187) and Rawinsonde (data type 120). There are several files named *info in the GSI system (located in \textit{./fix}) to control the usage of observations based on the observation platform. Table \ref{tab42} is a list of info files and their function: +For each variable, observations can come from multiple platforms (data types or observation instruments). For example, surface pressure (ps) can come from METAR observation stations (data type 187) and rawinsonde (data type 120). There are several files named *info in the GSI system (located in \textit{./fix}) to control the usage of observations based on the observation platform. Table \ref{tab42} is a list of info files and their function: \begin{table}[htbp] \centering \caption{The content of info files } @@ -1217,13 +1216,13 @@ \section{Control Data Usage} \hline File name in GSI & Function and Content \\ \hline -convinfo & Control the usage of conventional data, including tcp, ps, t, q, pw, sst, uv, spd, dw, radial wind (Level 2 \textit{rw} and 2.5 \textit{srw}), gps, \textit{pm2\_5} \\ +convinfo & Control the usage of conventional data, including tcp, ps, t, q, pw, sst, uv, spd, dw, radial wind (Level 2 \textit{rw} and 2.5 \textit{srw}), gps, and \textit{pm2\_5} \\ \hline -satinfo & Control the usage of satellite data. Instruments include AMSU-A/B, HIRS3/4, MHS, ssmi, ssmis, iasi, airs, sndr, cris, amsre, imgr, seviri, atms, avhrr3, etc. and satellites include NOAA 15, 17, 18, 19, aqua, GOES 11, 12, 13, METOP-A/B, NPP, DMSP 15,16,17,18,19,20, +satinfo & Control the usage of satellite data. Instruments include AMSU-A/B, HIRS3/4, MHS, ssmi, ssmis, iasi, airs, sndr, cris, amsre, imgr, seviri, atms, avhrr3, etc., and satellites include NOAA 15, 17, 18, 19, aqua, GOES 11, 12, 13, METOP-A/B, NPP, DMSP 15,16,17,18,19,20, M08, M09, M10, etc.\\ -ozinfo & Control the usage of ozone data, including sbuv6, 8 from NOAA 14, 16, 17, 18, 19. omi\_aura, gome\_metop-a, mls\_aura \\ +ozinfo & Control the usage of ozone data, including sbuv6, 8 from NOAA 14, 16, 17, 18, 19. omi\_aura, gome\_metop-a, and mls\_aura \\ \hline -pcpinfo & Control the usage of precipitation data, including pcp\_ssmi, pcp\_tmi \\ +pcpinfo & Control the usage of precipitation data, including pcp\_ssmi and pcp\_tmi \\ \hline aeroinfo & Control the usage of aerosol data, including modis\_aqua and modis\_terra \\ \hline @@ -1231,12 +1230,12 @@ \section{Control Data Usage} \label{tab42} \end{table} -The header of each info file includes an explanation of the content of the file. Here we discuss the most commonly used two info files: +The header of each info file includes an explanation of the content of the file. Here we discuss the two most commonly used info files: \begin{itemize}[leftmargin=*] \item convinfo\\ -The convinfo is to control the usage of conventional data. The following is the part of the content of convinfo: +The \textbf{convinfo} file controls the usage of conventional data. The following is part of the \textbf{convinfo} file: \begin{tiny} \begin{verbatim} @@ -1283,9 +1282,9 @@ \section{Control Data Usage} sub & prepbufr subtype (not yet available) \\ \hline iuse & flag if to use/not use / monitor data; \newline -=1, use data, the data type will be read and used in the analysis after quality control;\newline -=0, read in and process data, use for quality control, but do NOT assimilate;\newline -=-1, monitor data. This data type will be read in and monitored but not be used in the GSI analysis. \\ += 1, use data, the data type will be read and used in the analysis after quality control;\newline += 0, read in and process data, use for quality control, but do NOT assimilate;\newline += -1, monitor data. This data type will be read in and monitored but not be used in the GSI analysis. \\ \hline twindow & time window (+/- hours) for data used in the analysis \\ \hline @@ -1295,15 +1294,15 @@ \section{Control Data Usage} \hline nmiter & cross validation parameter - external iteration to introduce removed data \\ \hline -gross & gross error parameter - gross error \\ +gross & gross error parameter - gross error \\ \hline ermax & gross error parameter - maximum error \\ \hline ermin & gross error parameter - minimum error \\ \hline -var\_b & variational quality control parameter - b parameter \\ +var\_b & variational quality control parameter - b parameter \\ \hline -var\_pg & variational quality control parameter - pg parameter\\ +var\_pg & variational quality control parameter - pg parameter\\ \hline ithin & Flag to turn on thinning (0, no thinning, 1 - thinning) \\ \hline @@ -1313,15 +1312,15 @@ \section{Control Data Usage} \hline npred & Number of bias correction predictors \\ \hline -pmot & the option to keep thinned data as monitored, 0: not to keep, other values: to keep \\ +pmot & Option to keep thinned data as monitored, 0: do not keep, other values: keep \\ \hline -ptime & time interval for thinning, 0, no temporal thinning, other values define time interval (less than 6) \\ +ptime & time interval for thinning, 0, no temporal thinning, other values define time interval (less than six) \\ \hline \end{tabular} \label{tab43} \end{table} -From this table, we can see that parameter iuse is used to control the usage of data and parameter twindow is to control the time window of data usage. Parameters gross, ermax, and ermin are for gross quality control. Through these parameters, GSI can control how to use certain types of the data in the analysis.\\ +From this table, we can see that parameter "iuse" is used to control the usage of data and parameter "twindow" is used to control the time window of data usage. Parameters gross, ermax, and ermin are for gross quality control. Through these parameters, GSI can control how to use certain types of data in the analysis.\\ \item satinfo\\ @@ -1370,7 +1369,7 @@ \section{Control Data Usage} \hline error & Variance for each satellite channel \\ \hline -error\_cld & Variance for each satellite channel if it is cloudy \\ +error\_cld & Variance for each satellite channel if cloudy \\ \hline ermax & Error maximum for gross check to observations \\ \hline @@ -1394,7 +1393,7 @@ \section{Domain Partition for Parallelization and Observation Distribution} \label{sec4.4} %------------------------------------------------------------------------------- -The standard output file (\textit{stdout}) has an information block that shows the distribution of different kinds of observations in each sub-domain. This block follows the observation input section. The following is the observation distribution of the case shown in Section \ref{sec4.1}. From the case introduction, we know the prepbufr (conventional data), radiance BUFR files, and GPS BUFR files were used. In this list, the conventional observations (\verb|ps|, \verb|t|, \verb|q|, \verb|pw|, and \verb|uv|), GPSRO (\verb|gps_ref|), and radiance data (\verb|amusa|, \verb|hirs4|, and \verb|mhs| from \verb|Metop-a|, \verb|Metop-b|, \verb|NOAA 15| and \verb|18|) were distributed among 4 sub-domains: +The standard output file (\textit{stdout}) has an information block that shows the distribution of different kinds of observations in each sub-domain. This block follows the observation input section. The following is the observation distribution from the case shown in Section \ref{sec4.1}. From the introduction, we know the prepbufr (conventional data), radiance BUFR files, and GPS BUFR files were used. In this list, the conventional observations (\verb|ps|, \verb|t|, \verb|q|, \verb|pw|, and \verb|uv|), GPSRO (\verb|gps_ref|), and radiance data (\verb|amusa|, \verb|hirs4|, and \verb|mhs| from \verb|Metop-a|, \verb|Metop-b|, \verb|NOAA 15|, and \verb|18|) were distributed among four sub-domains: \begin{scriptsize} \begin{verbatim} @@ -1426,7 +1425,7 @@ \section{Domain Partition for Parallelization and Observation Distribution} \section{Observation Innovation Statistics} %------------------------------------------------------------------------------- -The GSI analysis gives a group of files named \textit{fort.2*} to summarize observations fitting to the current solution in each outer loop (except for \textit{fort.220}, see explanation on \textit{fort.220} in next section). The content of some of these files is listed in Table \ref{tab45}: +The GSI analysis provides a set of files named \textit{fort.2*} to summarize observations fit to the current solution in each outer loop (except for \textit{fort.220}, see explanation in the next section). The content of some of these files is listed in Table \ref{tab45}: \begin{table}[htbp] \centering @@ -1442,16 +1441,16 @@ \section{Observation Innovation Statistics} \hline \textit{fort.203 or fit\_t1.analysis\_time} & fit of temperature data & K \\ \hline -\textit{fort.204 or fit\_q1.analysis\_time} & fit of moisture data & percent of guess qsaturation \\ +\textit{fort.204 or fit\_q1.analysis\_time} & fit of moisture data & percent of qsaturation guess \\ \hline \textit{fort.205} & fit of precipitation water data & mm \\ \hline -\textit{fort.206} & fit of ozone observations from sbuv6\_n14 (, \_n16, \_n17, \_n18), sbuv8\_n16 (, \_n17, \_n18, \_n19), omi\_aura, gome\_metop-a/b, mls\_aura & \\ +\textit{fort.206} & fit of ozone observations from sbuv6\_n14 (, \_n16, \_n17, \_n18), sbuv8\_n16 (, \_n17, \_n18, \_n19), omi\_aura, gome\_metop-a/b, and mls\_aura & \\ \hline \textit{fort.207 or fit\_rad1.analysis\_time} & fit of satellite radiance data, such as: -amsua\_n15(, n16, n17, n18, metop-a, aqua, n19), amsub\_n17, hirs3\_n17, hirs4\_n19 (, metop-a), etc & \\ +amsua\_n15(, n16, n17, n18, metop-a, aqua, n19), amsub\_n17, hirs3\_n17, hirs4\_n19 (, metop-a), etc. & \\ \hline -\textit{fort.208} & fit of prepcipitation rate (pcp\_ssmi, pcp\_tmi) & \\ +\textit{fort.208} & fit of precipitation rate (pcp\_ssmi and pcp\_tmi) & \\ \hline \textit{fort.209} & fit of radar radial wind (rw) & \\ \hline @@ -1463,29 +1462,29 @@ \section{Observation Innovation Statistics} \hline \textit{fort.213} & fit of conventional sst data & C \\ \hline -\textit{fort.214} & Tropical cyclone central pressure & \\ +\textit{fort.214} & fit of tropical cyclone central pressure & \\ \hline -\textit{fort.215} & Lagrangian tracer data & \\ +\textit{fort.215} & fit of Lagrangian tracer data & \\ \hline -\textit{Fort.217} & Fit of aerosol product (aod) & \\ +\textit{fort.217} & fit of aerosol product (aod) & \\ \hline -Fort.218 & Fit of wind gust & \\ +\textit{fort.218} & fit of wind gust & \\ \hline -Fort.219 & Fit of visibility & +\textit{Fort.219} & fit of visibility & \\ \hline \end{tabular} \label{tab45} \end{table} -To help users understand the information inside these files, some examples from these files are given in the following sub-sections with corresponding explanations. +To help users understand the information inside these files, some examples are given in the following sub-sections with corresponding explanations. %------------------------------------------------------------------------------- \subsection{Conventional observations} \label{sec4.5.1} %------------------------------------------------------------------------------- -Example of files including single level data (\textit{fort.201}, \textit{fort.205}, \textit{fort.213}) +Example of files, including single level data (\textit{fort.201}, \textit{fort.205}, and \textit{fort.213}) \begin{scriptsize} \begin{verbatim} @@ -1516,7 +1515,7 @@ \subsection{Conventional observations} \end{verbatim} \end{scriptsize} -Example of files including multiple level data (\textit{fort.202}, \textit{fort.203}, \textit{fort.204}) +Example of files including multiple level data (\textit{fort.202}, \textit{fort.203}, and \textit{fort.204}) \begin{scriptsize} \begin{verbatim} @@ -1568,13 +1567,13 @@ \subsection{Conventional observations} \end{verbatim} \end{scriptsize} -Please note 5 layers from 600 to 150 hPa have been deleted to make each row fit into one line. Only observation type 220 and 223 are shown as an example. +Please note that five layers from 600 to 150 hPa have been deleted to make each row fit into one line. Only observation type 220 and 223 are shown as an example. -The table \ref{tab46} lists the meaning of each item in file \textit{fort.201-213} except file \textit{fort.207}: +Table \ref{tab46} lists the meaning of each item in file \textit{fort.201-213} except file \textit{fort.207}: \begin{table}[htbp] \centering -\caption{list of each item in file fort.201-213 (except fort.207)} +\caption{List of each item in file fort.201-213 (except fort.207).} \begin{tabular}{|p{1cm}|p{10cm}|} \hline \hline @@ -1582,29 +1581,29 @@ \subsection{Conventional observations} \hline \textit{it} & outer loop number \newline = 01: observation - background \newline -= 02: observation - analysis (after 1st outer loop) \newline -= 03: observation - analysis (after 2nd outer loop) \\ += 02: observation - analysis (after 1\textsuperscript{st} outer loop) \newline += 03: observation - analysis (after 2\textsuperscript{nd} outer loop) \\ \hline -\textit{obs} & observation variable (such as uv, ps) and usage of the type, which include: \newline +\textit{obs} & observation variable type (such as uv or ps) and usage, which includes: \newline blank: used in GSI analysis \newline -mon: monitored, (read in but not assimilated by GSI). \newline +mon: monitored (read in but not assimilated by GSI) \newline rej: rejected because of quality control in GSI \\ \hline -\textit{type} & prepbufr observation type (see BUFR User\textquotesingle s Guide for details) \\ +\textit{type} & prepbufr observation type (see the BUFR User\textquotesingle s Guide for details) \\ \hline -\textit{styp} & prepbufr observation subtype (not used now) \\ +\textit{styp} & prepbufr observation subtype (not used) \\ \hline \textit{ptop} & for multiple level data: pressure at the top of the layer \\ \hline \textit{pbot} & for multiple level data: pressure at the bottom of the layer \\ \hline -\textit{count} & The number of observations summarized under observation types and vertical layers \\ +\textit{count} & the number of observations summarized under observation types and vertical layers \\ \hline -\textit{bias} & Bias of observation departure for each outer loop (it) \\ +\textit{bias} & bias of observation departure for each outer loop (it) \\ \hline -\textit{rms} & Root Mean Square of observation departure for each outer loop (it) \\ +\textit{rms} & root mean square error of observation departure for each outer loop (it) \\ \hline -\textit{cpen} & Observation part of penalty (cost function) \\ +\textit{cpen} & observation part of penalty (cost function) \\ \hline \textit{qcpen} & nonlinear qc penalty \\ \hline @@ -1612,10 +1611,9 @@ \subsection{Conventional observations} \label{tab46} \end{table} +The contents of the fit files are calculated based on O-B or O-A for each observation. The detailed departure information about each observation is saved in the diagnostic files. For the content of the diagnostic files, please check the content of the array "rdiagbuf" in one of the setup subroutines for conventional data (for example, setupt.f90). We provide a tool in appendix A.2 to help users read in the information from the diagnostic files. -The contents of the fit files are calculated based on O-B or O-A for each observation. The detailed departure information about each observation is saved in the diagnostic files. For the content of the diagnostic files, please check the content of the array rdiagbuf in one of the setup subroutines for conventional data, for example, setupt.f90. We provide a tool in appendix A.2 to help users read in the information from the diagnostic files. - -These fit files give lots of useful information on how data are analyzed by the GSI, such as how many observations are used and rejected, what is the bias and rms for certain data types or for all observations, and how analysis results fit to the observation before and after analysis. Again, we use observation type 220 in \textit{fort.202} (\textit{fit\_w1.2014061700}) as an example to illustrate how to read this information. The fit information for observation type 220 (sounding observation) is listed below. Like the previous example, 5 layers from 600 to 150 hPa were deleted to make each row fit into one line. All fit information of observation type 220 are shown. +These fit files give lots of useful information on how data are analyzed by the GSI, such as how many observations are used and rejected, the bias and root mean squared (RMS) error for certain data types or for all observations, and how analysis results fit to the observation before and after analysis. Again, we use observation type 220 in \textit{fort.202} (\textit{fit\_w1.2014061700}) as an example to illustrate how to read this information. The fit information for observation type 220 (soundings) is listed below. Like the previous example, five layers from 600 to 150 hPa were deleted to make each row fit into one line. All fit information of observation type 220 is shown. \begin{scriptsize} \begin{verbatim} @@ -1700,9 +1698,9 @@ \subsection{Conventional observations} \end{verbatim} \end{scriptsize} -In loop section \verb|o-g 01|, from \verb|count| line, we can see there are 4231 sounding observations used in the analysis. Among them, 44 are within the 1000-1200 hPa layer. Also from the \verb|count| lines, in the rejection and monitoring section, there are 800 observations rejected and 29 observations being monitored. In the same loop section, from the \verb|bias| line and \verb|rms| lines, we can see the total bias and rms of O-B for soundings is 0.59 and 4.18. The bias and rms of each layer for sounding observation can also be found in the file. +In loop section \verb|o-g 01|, from the \verb|count| line, we can see there were 4231 sounding observations used in the analysis. Among them, 44 were within the 1000-1200 hPa layer. Also from the \verb|count| lines, in the rejection and monitoring section, there were 800 observations rejected and 29 observations monitored. In the same loop section, from the \verb|bias| line and \verb|rms| lines, we can see the total bias and RMS error of O-B for the sounding information is 0.59 and 4.18. The bias and RMS error for each vertical layer can also be found in this file. -When reading bias and rms values from different loops, as shown with the comparison in the following three lines: +Next we can see bias and RMS error values from different loops, as shown with the comparison in the following three lines: \begin{scriptsize} \begin{verbatim} @@ -1712,16 +1710,16 @@ \subsection{Conventional observations} \end{verbatim} \end{scriptsize} -These three lines show that the rms reduced from 4.18 (o-g 01, which is O-B) to 3.73 (o-g 02, which is O-A after 1st outer loop) and then to 3.60 (o-g 03, which is O-A after 2nd outer loop, the final analysis result). The reduction in the rms shows the observation type 220 (sounding) was used in the GSI analysis to modify the background fields to fit to the observations. +These three lines show that the RMS error reduced from 4.18 (o-g 01, which is O-B) to 3.73 (o-g 02, which is O-A after the 1\textsuperscript{st} outer loop) and then to 3.60 (o-g 03, which is O-A after the 2\textsuperscript{nd} outer loop, which is also the final analysis result). The reduction in the RMS error shows that observation type 220 (sounding) was used in the GSI analysis to modify the background fields to fit to the observations. %------------------------------------------------------------------------------- \subsection{Satellite Radiance} \label{sec4.5.2} %------------------------------------------------------------------------------- -The file \textit{fort.207} is the statistic fit file for radiance data. Its content includes important information about the radiance data analysis. +The file \textit{fort.207} is the fit file for radiance data. Its content includes important information about the radiance data analysis. -The first part of the file \textit{fort.207} lists the content that corresponds to those in the file satinfo, which is the info file to control the data usage for radiance data. +The first part of the file \textit{fort.207} lists the content that corresponds to those in the file \textbf{satinfo}, which is the info file to control radiance data usage. \begin{tiny} \begin{verbatim} @@ -1737,7 +1735,7 @@ \subsection{Satellite Radiance} \end{verbatim} \end{tiny} -This shows there are 2723 channels listed in the \textit{satinfo} file and the 2723 lines following this line include the detailed setups in the \textit{satinfo} file for each channel. +This shows there are 2723 channels listed in the \textit{satinfo} file and the 2723 lines following this line include the details for each channel. The second part of the file is a list of the coefficients for bias correction, after reading the \textit{satbias\_in} file: @@ -1754,9 +1752,9 @@ \subsection{Satellite Radiance} \end{verbatim} \end{tiny} -Each channel has 12 coefficients listed in a line. Therefore, there are 2723 lines of radiance bias correction coefficients for all channels though some of the coefficients are 0. +Each channel has 12 coefficients listed in a line. Therefore, there are 2723 lines of radiance bias correction coefficients for all channels, though some of the coefficients are zero. -The 3rd part of the \textit{fort.207} file is similar to other fit files with similar content repeated in 3 sections to give detailed statistic information about the data in stages before the 1st outer loop, between 1st and 2nd outer loop, and after 2nd outer loop. The results before the 1st outer loop are used here as an example to explain the content of the statistic results: +The 3\textsuperscript{rd} part of the \textit{fort.207} file is similar to other fit files with content repeated in three sections, providing detailed statistics about the data in stages before the 1\textsuperscript{st} outer loop, between the 1\textsuperscript{st} and 2\textsuperscript{nd} outer loops, and after the 2\textsuperscript{nd} outer loop. The results before the 1\textsuperscript{st} outer loop are used here as an example to explain the content of the results: \begin{itemize}[leftmargin=*] @@ -1785,11 +1783,11 @@ \subsection{Satellite Radiance} \end{verbatim} \end{scriptsize} -The Table \ref{tab47} lists the meaning of each item in the above statistics: +Table \ref{tab47} outlines the meaning of each item in the above statistics: \begin{table}[htbp] \centering -\caption{content of summarizing radiance observation process in fort.207} +\caption{Summary of the radiance observation fit file (fort.207)} \begin{tabular}{|p{2cm}|p{10cm}|} \hline \hline @@ -1812,25 +1810,25 @@ \subsection{Satellite Radiance} \hline \textit{ireduce} & number of observations that reduce qc bounds in tropics \\ \hline -\textit{ivarl} & number of observations tossed by gross check \\ +\textit{ivarl} & number of observations removed by gross check \\ \hline -\textit{nlgross} & number of observation tossed by nonlinear qc\\ +\textit{nlgross} & number of observation removed by nonlinear qc\\ \hline \textit{qcpenalty} & nonlinear qc penalty from this data type \\ \hline -\textit{qc1-7} & number of observations whose quality control criteria has been adjusted by each qc method (1-7), details see in the Radiance Chapter of the Advanced User?s Guide \\ +\textit{qc1-7} & number of observations whose quality control criteria has been adjusted by each qc method (1-7). For details, see the Radiance Chapter of the Advanced User\textquotesingle s Guide \\ \hline \textit{rad total penalty\_all} & summary of penalty for all radiance observation types \\ \hline \textit{rad total qcpenalty\_all} & summary of qcpenalty for all radiance observation types \\ \hline -\textit{rad total failed nonlinqc} & summary of observation tossed by nonlinear qc for all radiance observation types \\ +\textit{rad total failed nonlinqc} & summary of observations removed by nonlinear qc for all radiance observation types \\ \hline \end{tabular} \label{tab47} \end{table} -Note: one radiance observation may include multiple channels, not all channels are used in the analysis. +Note: One radiance observation may include multiple channels, and not all channels are necessarily used in the analysis. \item Summaries for various statistics as a function of channel @@ -1861,11 +1859,11 @@ \subsection{Satellite Radiance} \end{verbatim} \end{scriptsize} -The Table \ref{tab48} lists the meaning of each column in above statistics: +Table \ref{tab48} lists the meaning of each column in the above statistics: \begin{table}[htbp] \centering -\caption{content of fit statistic for each channel in fort.207} +\caption{Content of fit statistics for each channel in the fort.207 file.} \begin{tabular}{|p{1.5cm}|p{10cm}|} \hline \hline @@ -1890,7 +1888,7 @@ \subsection{Satellite Radiance} \hline \textit{9} & penalty contribution from this channel \\ \hline -\textit{10} & sqrt of (observation-guess with bias correction)**2\\ +\textit{10} & square root of (observation-guess with bias correction)**2\\ \hline \textit{11} & standard deviation \\ \hline @@ -1925,11 +1923,11 @@ \subsection{Satellite Radiance} \end{verbatim} \end{scriptsize} -The table \ref{tab49} lists the meaning of each column in the above statistics: +Table \ref{tab49} lists the meaning of each column in the above statistics: \begin{table}[htbp] \centering -\caption{content of final summary section in fort.207} +\caption{Content of the final summary section for the fort.207 file.} \begin{tabular}{|p{2.0cm}|p{10cm}|} \hline \hline @@ -1960,8 +1958,6 @@ \subsection{Satellite Radiance} \label{tab49} \end{table} - - Similar to other fit files, a comparison between results from different outer loops can give us very useful information on how much impact each channel and data type has in the GSI. \end{itemize} @@ -2023,28 +2019,27 @@ \section{Convergence Information} \end{verbatim} \end{tiny} -We can see clearly the number of outer loops and the inner loops (Minimization iteration). The meaning of the names (bold) used in \textit{stdout} are explained in the following: +Here, we can see the number of outer and inner loops (minimization iteration). The meaning of the names (bold) used in \textit{stdout} are explained in the following: \begin{itemize} -\item \verb|cost|: the values of cost function, (=J) +\item \verb|cost|: the cost function values, (=J) \item \verb|grad|: inner product of gradients (norm of the gradient (Y*X)) \item \verb|step|: stepsize \item \verb|b|: parameter to estimate the new search direction \end{itemize} -As a quick check, the cost function reduced from 3.915930707165839704E+04 to 2.479985164931967302E+04 in the 1st outerloop and reduced from 2.792919782749931983E+04 to 2.474335402213209454E+04 in the 2nd outer loop. +As a quick check, the cost function reduced from 3.915930707165839704E+04 to 2.479985164931967302E+04 in the 1\textsuperscript{st} outer loop and reduced from 2.792919782749931983E+04 to 2.474335402213209454E+04 in the 2\textsuperscript{nd} outer loop. \item Convergence information in file \textit{fort.220}:\\ - In file \textit{fort.220}, users can find more detailed minimization information about each iteration. A detailed description and example are provided in the Advanced User\textquotesingle s Guide. -To evaluate the convergence of the iteration, we usually make plots based on the information from \textit{fort.220}, such as the value of the cost function and the norm of the gradient. The following are example plots showing the evolution of the cost function and the norm of gradient in different outer loops: +To evaluate the iteration convergence, we usually make plots based on the information from \textit{fort.220}, such as the value of the cost function and the norm of the gradient. The following are example plots showing the evolution of the cost function and the norm of the gradient in different outer loops: \begin{figure}[h!] \centering \includegraphics[width=0.7\textwidth]{images/CostGrad} - \caption{Evolution of cost function (left column) and the norm of gradient (right column) in the first outer loop (top raw) and the second outer loop (bottom raw). The Y-axis is the iteration number} + \caption{Evolution of the cost function (left column) and the norm of the gradient (right column) in the first outer loop (top row) and the second outer loop (bottom row). The Y-axis is the iteration number.} \label{fig:costgrad} \end{figure} @@ -2062,11 +2057,11 @@ \subsection{Getting Original Observation Errors} \label{sec4.7.1} %------------------------------------------------------------------------------- -For the global GSI analysis, when \verb|oberrflg| (a namelist option in section \verb|&obsqc|) is true, observation errors are generated based on an external observation error table according to the types of observations. Otherwise, observation errors are read in from the PrepBUFR file. +For the global GSI analysis, when \verb|oberrflg| (a namelist option in section \verb|&obsqc|) is true, observation errors are generated based on an external observation error table according to the observation type. Otherwise, observation errors are read in from the PrepBUFR file. -For regional GSI runs, GSI forces the use of an external observation error table to get observation errors no matter what the \verb|oberrflg| is set to (\verb|oberrflg| is forced to be true for regional runs in \textit{gsimod.F90}). +For regional analyses, GSI forces the use of an external observation error table to get observation errors no matter what the \verb|oberrflg| is set to (\verb|oberrflg| is forced to be true for regional runs in \textit{gsimod.F90}). -The external observation error table file, \textit{errtable}, includes observation errors for all types of conventional observations. It is copied from the \textit{~/comGSIv3.5\_EnKFv1.1/fix} directory by the run script. This release package has three sample external observation error table files, \textit{nam\_errtable.r3dv}, \textit{prepobs\_errtable.global}, and \textit{rtma/new\_rtma\_nam\_errtable.r3dv} in the \textit{./fix} directory. The \textit{nam\_errtable.r3dv} is used in the sample run script as a default observation error table. The observation error file is a text file that can be easily edited to tune the error values. The following shows a portion of \textit{nam\_errtable.r3dv} for rawinsondes and its description of each column in Table \ref{tab410}: +The external observation error table file, \textit{errtable}, includes observation errors for all types of conventional observations. It is copied from the \textit{./fix} directory by the run script. This release package has three sample external observation error table files, \textit{nam\_errtable.r3dv}, \textit{prepobs\_errtable.global}, and \textit{rtma/new\_rtma\_nam\_errtable.r3dv} in the \textit{./fix} directory. The \textit{nam\_errtable.r3dv} is used in the sample run script as a default observation error table. The observation error file is a text file that can be easily edited to tune the error values. The following shows a portion of \textit{nam\_errtable.r3dv} file for rawinsondes and its description of each column in Table \ref{tab410}: \begin{scriptsize} \begin{verbatim} @@ -2107,8 +2102,7 @@ \subsection{Getting Original Observation Errors} \label{tab410} \end{table} - -For each type of observation, the error table has 6 columns and 33 rows (levels). The 1st column prescribes 33 pressure levels, which cover from 1100 hPa to 0 hPa. The columns 2-6 prescribe the observation errors for temperature (T), relative humidity (RH), horizontal wind component (UV), surface pressure (Ps), and the total column precipitable water (Pw). The missing value is 0.10000E+10. +For each observation type, the error table has six columns and 33 rows (levels). The 1\textsuperscript{st} column prescribes 33 pressure levels, covering 1100 hPa to 0 hPa. Columns 2-6 prescribe observation errors for temperature (T), relative humidity (RH), horizontal wind component (UV), surface pressure (Ps), and the total column precipitable water (Pw). The missing value is 0.10000E+10. The observation error table for each observation type starts with the observation type number defined for the PrepBUFR files, such as: @@ -2119,7 +2113,7 @@ \subsection{Getting Original Observation Errors} \end{verbatim} \end{scriptsize} -The PrepBUFR data type number 100-199 are for temperature (T), moisture (q), and surface pressure (Ps) observations, while number 200-299 are horizontal wind component (UV) observations. The detailed explanation of each data type number can be found from the following table in the EMC website: +The PrepBUFR data type numbers 100-199 are for temperature (T), moisture (q), and surface pressure (Ps) observations, while numbers 200-299 are for horizontal wind component (UV) observations. A detailed explanation of each data type number can be found in the following table on the EMC website: \begin{small} \url{http://www.emc.ncep.noaa.gov/mmb/data_processing/prepbufr.doc/table_2.htm} @@ -2132,10 +2126,10 @@ \subsection{Getting Original Observation Errors} \end{small} %------------------------------------------------------------------------------- -\subsection{Observation Rrror Gross Error Check within GSI} +\subsection{Observation Error Gross Error Check within GSI} %------------------------------------------------------------------------------- -The gross error check is an important quality check step to exclude questionable observations that degrade the analysis. Users can adjust the threshold of the gross error check for each data type within the \textit{convinfo} file to make the gross error check tighter or looser for a certain data type. For example, the following is a part of \textit{convinfo} without the last five columns: +The gross error check is an important quality control step to exclude questionable observations that degrade the analysis. Users can adjust the threshold of the gross error check for each data type within the \textit{convinfo} file to make the gross error check more or less strict for a certain data type. For example, the following is a part of the \textit{convinfo} file without the last five columns: \begin{scriptsize} \begin{verbatim} @@ -2147,47 +2141,47 @@ \subsection{Observation Rrror Gross Error Check within GSI} \end{verbatim} \end{scriptsize} -The gross check for each data type is controlled by gross, ermax, and ermin. If an observation has observation error: obserror, then a gross check ratio is calculated: +The gross check for each data type is controlled by columns "gross", "ermax", and "ermin." If an observation has observation error set to "obserror," then a gross check ratio is calculated: \textit{ratio = (Observation-Background)/max(ermin,min(ermax,obserror))} -If \textit{ratio > gross}, then this observation fails the gross check and will not be used in the analysis. The unused observation is indicated as "rejection" in the fit files. +If \textit{ratio > gross}, then this observation fails the gross check and will not be used in the analysis. The unused observation is indicated as a "rejection" in the fit files. %------------------------------------------------------------------------------- \section{Background Error Covariance} \label{sec4.8} %------------------------------------------------------------------------------- -The GSI package has several files in \textit{~/comGSIv3.5\_EnKFv1.1/fix/} to hold the pre-computed background error statistics for different GSI applications with different grid configurations. Within the ./fix directory subdirectories \textit{./fix/Big\_Endian} and \textit{./fix/Little\_Endian} contain the fix files corresponding to each endianness. Since the GSI code has a build-in mechanism to interpolate the input background error matrix to any desired analysis grid, the following two background error files can be used to specify the B matrix for any GSI regional application. +The GSI package has several files in \textit{./fix} to hold the pre-computed background error statistics for different GSI applications with different grid configurations. Within the \textit{./fix} subdirectories \textit{./fix/Big\_Endian} and \textit{./fix/Little\_Endian} contain the fix files corresponding to each endianness. Since the GSI code has a build-in mechanism to interpolate the input background error matrix to any desired analysis grid, the following two background error files can be used to specify the B matrix for any GSI regional application. \begin{itemize} -\item \textit{nam\_nmmstat\_na.gcv} : contains the regional background error statistics, computed using forecasts from the NCEP\textquotesingle s NAM model covering North America. The values of this B matrix cover the northern hemisphere with 93 latitude lines from -2.5 degree to 89.5 degree with 60 vertical sigma levels from 0.9975289 to 0.01364. -\item \textit{nam\_glb\_berror.f77.gcv} : contains the global background errors based on the NCEP\textquotesingle s GFS model, a global forecast model. The values of this B matrix covers global with 192 latitude lines from -90 degree to 90 degree and with 42 vertical sigma levels from 0.99597 to 0.013831. +\item \textit{nam\_nmmstat\_na.gcv} : contains the regional background error statistics, computed using forecasts from the NCEP\textquotesingle s NAM model covering North America. The values of this B matrix cover the northern hemisphere with 93 latitude lines, from -2.5 degrees to 89.5 degrees with 60 vertical sigma levels from 0.9975289 to 0.01364. +\item \textit{nam\_glb\_berror.f77.gcv} : contains the global background errors based on NCEP\textquotesingle s GFS model, a global forecast model. The values of this B matrix cover the globe with 192 latitude lines from -90 degrees to 90 degrees and 42 vertical sigma levels from 0.99597 to 0.013831. \end{itemize} -These background error matrix files listed above are Big Endian binary files (therefore located in the \textit{Big\_Endian} directory). In the \textit{Little\_Endian} directory, \textit{nam\_nmmstat\_na.gcv} and \textit{nam\_glb\_berror.f77.gcv} are their Little Endian versions for certain computer platforms that cannot compile GSI with the Big Endian option. In this release version, GSI can be compiled with the Big Endian option with PGI and Intel. +The background error matrix files listed above are in Big Endian binary form (therefore located in the \textit{Big\_Endian} directory). In the \textit{Little\_Endian} directory, \textit{nam\_nmmstat\_na.gcv} and \textit{nam\_glb\_berror.f77.gcv} are their Little Endian versions for certain computer platforms that cannot compile GSI with the Big Endian option. In this release version, GSI can be compiled with the Big Endian option with PGI and Intel. %------------------------------------------------------------------------------- -\subsection{Tuning Background Error Covariance through Namelist and Anavinfo} +\subsection{Tuning Background Error Covariance through the Namelist and Anavinfo File} %------------------------------------------------------------------------------- -The final background error covariance matrix used in the GSI analysis are the content from the fixed file "berror", which is a copy of \textit{nam\_nmmstat\_na.gcv} or \textit{nam\_glb\_berror.f77.gcv}, multiplied by several factors set by the namelist and the anavinfo. +The final background error covariance matrix used in the GSI analysis is the content from the fixed file "berror", which is a copy of \textit{nam\_nmmstat\_na.gcv} or \textit{nam\_glb\_berror.f77.gcv}, multiplied by several factors set by the namelist and the \textbf{anavinfo} file. In GSI namelist, three variables are used for tuning horizontal and vertical impact scales: \begin{itemize} \item \verb|vs| scale factor for vertical correlation lengths for background error -\item \verb|hzscl(3)| scale factor for three scales specified for horizontal smoothing -\item \verb|hswgt(3)| weights to apply to each horizontal scales +\item \verb|hzscl(3)| scale factor for three scales specified for horizontal smoothing +\item \verb|hswgt(3)| weights to apply to each horizontal scales \end{itemize} -In the GSI anavinfo files, the column \textbf{as/tsfc\_sdv} in the \textit{control\_vector} section are factors for tuning the variance of each analysis control variable. +In the GSI anavinfo file, the column \textbf{as/tsfc\_sdv} in the \textit{control\_vector} section are factors for tuning the variance of each analysis control variable. -These values can be used to tuning the background error covariance used in the GSI analysis. For each background error matrix file, there are recommended values for these parameters listed in table \ref{tab411}. +These values can be used to tune the background error covariance used in the GSI analysis. For each background error matrix file, there are recommended values for these parameters listed in table \ref{tab411}. \begin{table}[htbp] \centering -\caption{recommended tuning values for the provided B matrix} +\caption{Recommended tuning values for the provided B matrix.} \begin{tabular}{|p{2cm}|p{5cm}|p{5cm}|} \hline \hline @@ -2241,7 +2235,7 @@ \subsection{Tuning Background Error Covariance through Namelist and Anavinfo} \section{Analysis Increments} %------------------------------------------------------------------------------- -Analysis increments are defined as the difference of analysis results minus background. A plot of analysis increments can help users to understand how the analysis procedure modifies the background fields according to observations, background and observation error covariance, and other constraints. You can either calculate \textit{analysis-guess} and plot the difference field or use the tools introduced in Appendix A.4 to make analysis increment figures for different analysis fields. +Analysis increments are defined as the difference between analysis results and the background (A-B). A plot of analysis increments can help users understand how the analysis procedure modifies the background fields according to observations, background and observation error covariances, and other constraints. You can either calculate \textit{analysis-guess} and plot the difference field or use the tools introduced in Appendix A.4 to make analysis increment figures for different analysis fields. %------------------------------------------------------------------------------- \section{Running Time and Memory Usage} @@ -2249,7 +2243,7 @@ \section{Running Time and Memory Usage} In addition to analysis increments, run time and memory usage are other important features of an analysis system, especially for operational code like the GSI. -The GSI standard output file (\textit{stdout}) gives the GSI start time and end time at the top and the end of the file. For example: +The GSI standard output file (\textit{stdout}) gives the GSI start time and end time of the analysis at the beginning and end of the file. For example: \begin{scriptsize} \begin{verbatim} @@ -2265,7 +2259,7 @@ \section{Running Time and Memory Usage} \end{verbatim} \end{scriptsize} -This tells us this case started at 20:36:21.760 and ended at 20:43:40.422. Meaning GSI used 7 minutes and 19 seconds to finish. +This tells us the analysis started at 20:36:21.760 and ended at 20:43:40.422, which means GSI used 7 minutes and 19 seconds to finish. Following the ending date-time, there is a resource statistics section at the end of the \textit{stdout} file, which gives information about run time and memory usage for the analysis: diff --git a/doc/GSI_user_guide/gsi_ch5.tex b/doc/GSI_user_guide/gsi_ch5.tex index 6798cc319..9940f2a1a 100644 --- a/doc/GSI_user_guide/gsi_ch5.tex +++ b/doc/GSI_user_guide/gsi_ch5.tex @@ -1,7 +1,7 @@ -\chapter{GSI Applications for Regional 3DVar and 3D Hybrid EnVar} +\chapter{GSI Applications for Regional 3DVar, Hybrid 3DEnVar and Hybrid 4DEnVar}\label{gsi_reg} \setlength{\parskip}{12pt} -In this chapter, the knowledge from the previous chapters will be applied to three regional GSI cases with different data sources. These examples are to give users a clear idea on how to set up GSI with various configurations and properly check the run status and analysis results in order to determine if a particular GSI application was successful. Note the examples here only use the WRF ARW system - WRF NMM runs are similar, but require different background and namelist options. +In this chapter, information from the previous chapters will be applied to three regional GSI cases with different data sources. These examples are to give users a clear idea of how to set up GSI with various configurations and properly check the run status and analysis results in order to determine if a particular GSI application was successful. Note that the examples here only use the WRF-ARW system - WRF-NMM runs are similar, but require different background and namelist options. For illustrations of all the cases, it is assumed that the reader has successfully compiled GSI on a local machine. For regional case studies, users should have the following data available: @@ -17,7 +17,7 @@ \chapter{GSI Applications for Regional 3DVar and 3D Hybrid EnVar} \url{ftp://ftpprd.ncep.noaa.gov/pub/data/nccf/com/nam/prod} -\textit{Note: NDAS PrepBUFR file was chosen to increase the amount of data used in the analysis (comparing to NAM PrepBUFR file) } +\textit{Note: An NDAS PrepBUFR file was chosen to increase the amount of data used in the analysis (compared to a NAM PrepBUFR file) } \end{itemize} \item Radiance data and GPS RO data @@ -32,7 +32,7 @@ \chapter{GSI Applications for Regional 3DVar and 3D Hybrid EnVar} \end{enumerate} -The following cases will give users an example of a successful GSI run with various data sources. Users are welcome to download these example data from the GSI users\textquotesingle \ webpage (online case for release version 3.5) or create a new background and get the observation data from the above server. The background and observations used in this case study are as follows: +The following cases will give users an example of a successful GSI run with various data sources. Users are welcome to download these example data from the GSI users\textquotesingle \ webpage (online case) or create a new background and get the observational data from the above server. The background and observations used in this case study are as follows: \begin{enumerate} \item Background files: wrfinput\_d01\_2014-06-17\_00:00:00 @@ -47,15 +47,15 @@ \chapter{GSI Applications for Regional 3DVar and 3D Hybrid EnVar} \centering \includegraphics[width=0.7\textwidth]{images/landmask} \end{minipage} - \caption{The terrain (left) and land mask (right) of the background used in this case study} + \caption{The terrain (left) and land mask (right) of the background used in this case study.} \label{fig:terland} \end{figure} \end{itemize} -\item Conventional data: NAM PrepBUFR data from 00UTC 17 June 2014 +\item Conventional data: NAM PrepBUFR data from 0000 UTC 17 June 2014 \begin{itemize} \item File: \textit{nam.t00z.prepbufr.tm00.nr} \end{itemize} -\item Radiance and GPS RO data: GDAS PREPBUFR data from 00 UTC 17 June 2014 +\item Radiance and GPS RO data: GDAS PREPBUFR data from 0000 UTC 17 June 2014 \begin{itemize} \item Files: \textit{gdas.t00z.1bamua.tm00.bufr\_d} @@ -65,19 +65,19 @@ \chapter{GSI Applications for Regional 3DVar and 3D Hybrid EnVar} \end{itemize} \end{enumerate} -This case study was run on a Linux cluster. Starting from version 3.2, the BUFR/PrepBUFR files do not need to be byte-swapped to little endian format. BUFRLIB can automatically handle byte order issues. +This case study was run on a Linux cluster. As of version 3.2, the BUFR/PrepBUFR files do not need to be byte-swapped to little endian format. BUFRLIB can automatically handle byte order issues. Assume the background file is located at: \textit{data/2014061700/arw} -all the observations are located at: +All the observations are located at: \textit{data/2014061700/obs} -and the GSI release version 3.5 is located at +And the GSI release version 3.6 is located at: -\textit{code/comGSIv3.5\_EnKFv1.1} +\textit{code/comGSI(version\_number)\_EnKF(version\_number)} %------------------------------------------------------------------------------- \section{Assimilating Conventional Observations with Regional GSI} @@ -92,7 +92,7 @@ \subsection{Run Script} \begin{itemize} \item Set up batch queuing system. \\ -To run GSI with multi-processors, a job queuing head has to be added at the beginning of the \textit{run\_gsi\_regional.ksh} script. The set up of the job queue is dependent on the machine and the job control system. More examples of the setup are described in section \ref{sec3.2.2}. The following example is set up to run on a Linux cluster supercomputer with LSF. The job head is as follows: +To run GSI with multi-processors, a job queuing section has to be added at the beginning of the \textit{run\_gsi\_regional.ksh} script. The set up of the job queue is dependent on the machine and the job control system. More setup examples are described in section \ref{sec3.2.2}. The following example is set up to run on a Linux cluster supercomputer with LSF. The job section is as follows: \begin{scriptsize} \begin{verbatim} @@ -107,10 +107,10 @@ \subsection{Run Script} \end{verbatim} \end{scriptsize} -In order to find out how to set up the job head, a good method is to use an existing MPI job script and copy the job head over. +In order to find out how to set up the job section, a good method is to use an existing MPI job script and copy the job section over. \\ -\item Set up the number of processors and the job queue system used. For this example, LINUX\_PBS and 4 processors are used: +\item Set up the number of processors and the job queue system used. For this example, LINUX\_PBS and four processors are used: \begin{scriptsize} \begin{verbatim} @@ -155,7 +155,7 @@ \subsection{Run Script} \end{verbatim} \end{scriptsize} -Set the GSI system used for this case, including the paths of fix files and the CRTM coefficients as well as the location of the GSI executable and the namelist file: +Set up the GSI system used for this case, including the paths of fix files and the CRTM coefficients as well as the location of the GSI executable and the namelist file: \begin{scriptsize} \begin{verbatim} @@ -177,7 +177,7 @@ \subsection{Run Script} \end{verbatim} \end{scriptsize} -This example uses the ARW NetCDF background; therefore \verb|bk_core| is set to 'ARW'. The regional background error covariance file is used in this case, as set by \verb|bkcv_option=NAM|. Finally, the run scripts are set to clean the run directory to delete all temporary intermediate files. +This example uses the ARW NetCDF background; therefore \verb|bk_core| is set to 'ARW.' The regional background error covariance file is used in this case, as set by \verb|bkcv_option=NAM|. Finally, the run scripts are set to clean the run directory to delete all temporary intermediate files. \end{itemize} %------------------------------------------------------------------------------- @@ -213,19 +213,19 @@ \subsection{Run GSI and Check the Run Status} \end{verbatim} \end{scriptsize} -These files are CRTM coefficients that have been linked to this run directory through the GSI run script. Additionally, many other files are linked or copied to this run directory or generated during run, such as: +These are CRTM coefficient files that have been linked to this run directory through the GSI run script. Additionally, many other files are linked or copied to this run directory or generated during the run, such as: \begin{itemize} -\item \verb|stdout|: standard out file +\item \verb|stdout|: standard output file \item \verb|wrf_inout|: background file \item \verb|gsiparm.anl|: GSI namelist -\item \verb|prepbufr|: PrepBUFR file for conventional observation +\item \verb|prepbufr|: prepBUFR file for conventional observation \item \verb|convinfo|: data usage control for conventional data \item \verb|berror_stats|: background error file \item \verb|errtable|: observation error file \end{itemize} -The presence of these files indicates that the GSI run scripts have successfully set up a run environment for GSI and the GSI executable is running. While GSI is still running, checking the content of the standard output file (\textit{stdout}) can monitor the status of the GSI analysis: +The presence of these files indicates that the GSI run scripts have successfully set up a run environment for GSI and that the GSI executable is running. While GSI is still running, checking the content of the standard output file (\textit{stdout}) can monitor the status of the GSI analysis: \begin{tiny} \begin{verbatim} @@ -244,7 +244,7 @@ \subsection{Run GSI and Check the Run Status} \end{verbatim} \end{tiny} -The above output shows that GSI is in the inner iteration stage. It may take several minutes to finish the GSI run. Once GSI has finished running, the number of files in the directory will be greatly reduced from those during the run stage. This is because the run script was set to clean the run directory after a successful run. The important analysis result files and configuration files will remain in the run directory. Please check Section \ref{sec3.3} for more details on GSI run results. Upon successful completion of GSI, the run directory looks as follows: +The above output shows that GSI is in the inner iteration stage. It may take several minutes to finish the GSI run. Once GSI has finished running, the number of files in the directory will be greatly reduced from those during the run stage. This is because the run script was set to clean the working directory after a successful run. The important analysis result files and configuration files will remain. Please check Section \ref{sec3.3} for more details on GSI run results. Upon successful completion of GSI, the run directory will look as follows: \begin{scriptsize} \begin{verbatim} @@ -269,12 +269,12 @@ \subsection{Check for Successful GSI Completion} \label{sec5.1.3} %------------------------------------------------------------------------------- -It is important to always check for successful completion of the GSI analysis. But, completion of the GSI run without crashing does not guarantee a successful analysis. First, check the \textit{stdout} file in the run directory to make sure GSI completed each step without any obvious problems. The following are several important steps to check: +It is important to always check for a successful completion of the GSI analysis. However, completion of the GSI run without crashing does not guarantee a successful analysis. First, it is necessary to check the \textit{stdout} file in the run directory to make sure GSI completed each step without any obvious problems. The following are several important steps to check: \begin{enumerate} -\item Read in the anavinfo and namelist \\ +\item Read in the anavinfo and namelist files\\ -The following lines show GSI started normally and has read in the anavinfo and namelist: +The following lines show that GSI started normally and has read in the anavinfo and namelist files: \begin{scriptsize} \begin{verbatim} gsi_metguess_mod*init_: 2D-MET STATE VARIABLES: @@ -316,7 +316,7 @@ \subsection{Check for Successful GSI Completion} \end{scriptsize} \item Read in the background field\\ -The following lines in stdout immediately following the namelist section, indicate that GSI is reading the background fields. Checking the range of the max and min values will indicate if certain background fields are normal. +The following lines in standard output file, immediately following the namelist section, indicate that GSI is reading the background fields. Checking the range of the 'max' and 'min' values will indicate if certain background fields are normal. \begin{scriptsize} \begin{verbatim} @@ -325,7 +325,7 @@ \subsection{Check for Successful GSI Completion} iy,m,d,h,m,s= 2014 6 17 0 0 0 dh1 = 3 - rmse_var = SMOIS + RMS errore_var = SMOIS ndim1 = 3 ordering = XYZ staggering = N/A @@ -333,11 +333,11 @@ \subsection{Check for Successful GSI Completion} end_index = 332 215 4 0 WrfType = 104 ierr = 0 - rmse_var = T ndim1 = 3 dh1 = 3 + RMS errore_var = T ndim1 = 3 dh1 = 3 ............... - rmse_var = U ndim1= 3 + RMS errore_var = U ndim1= 3 WrfType = 104 WRF_REAL= 104 ierr = 0 ordering = XYZ staggering = N/A start_index = 1 1 1 0 end_index = @@ -352,7 +352,7 @@ \subsection{Check for Successful GSI Completion} \item Read in observational data\\ -Skipping through a majority of the content towards the middle of the stdout file, the following lines will appear: +Skipping through a majority of the content towards the middle of the standard output file, the following lines will appear: \begin{scriptsize} \begin{verbatim} @@ -368,7 +368,7 @@ \subsection{Check for Successful GSI Completion} \item Inner iteration\\ -The inner iteration step in the stdout file will look as follows: +The inner iteration step in the standard output file will look like this: \begin{tiny} \begin{verbatim} @@ -396,7 +396,7 @@ \subsection{Check for Successful GSI Completion} \end{verbatim} \end{tiny} -Following the namelist set up, similar information will be repeated for each inner loop. In this case, 2 outer loops with 50 inner loops in each outer loop have been set. The last iteration looks like: +Following the namelist set up, similar information will be repeated for each inner loop. In this case, two outer loops with 50 inner loops in each outer loop are shown. The last iteration looks like this: \begin{tiny} \begin{verbatim} @@ -412,7 +412,7 @@ \subsection{Check for Successful GSI Completion} \end{verbatim} \end{tiny} -Clearly, at the 45th iteration GSI met the stop threshold before getting to the maximum iteration number (50). As a quick check of the iteration: the J value should descend with each iteration. Here, J has a value of 3.249585514567150676E+04 at the beginning and a value of 2.283066393454704667E+04 at the final iteration. This means the value has reduced by about one third, which is an expected reduction.\\ +At the 45th iterationi, GSI met the stop threshold before getting to the maximum iteration number (50). As a quick check, the J value should descend with each iteration. Here, J has a value of 3.249585514567150676E+04 at the beginning and a value of 2.283066393454704667E+04 for the final iteration. Therefore, the value has reduced by about one third, which is an expected reduction.\\ \item Write out analysis results\\ @@ -424,7 +424,7 @@ \subsection{Check for Successful GSI Completion} max,min psfc= 102799.9 66793.78 max,min MU= 2799.898 -1195.195 - rmse_var=MU + RMS errore_var=MU ordering=XY WrfType,WRF_REAL= 104 104 ndim1= 2 @@ -453,7 +453,7 @@ \subsection{Check for Successful GSI Completion} \end{verbatim} \end{scriptsize} -After carefully investigating each portion of the stdout file, it can be concluded that GSI successfully ran through every step and there were no run issues. A more complete description of the stdout file can be found in Section \ref{sec4.1}. However, it cannot be concluded that GSI did a successful analysis until more diagnosis has been completed. +After carefully investigating each portion of the standard output file, it can be concluded that GSI successfully ran through every step and there were no run issues. A more complete description of the standard output file can be found in Section \ref{sec4.1}. However, it cannot be concluded that GSI successfully produced an analysis until more diagnosis has been completed. \end{enumerate} @@ -465,12 +465,12 @@ \subsection{Diagnose GSI Analysis Results} \subsubsection{Check Analysis Fit to Observations} %------------------------------------------------------------------------------- -The analysis uses observations to correct the background fields to fit the observations closer under certain constraints. The easiest way to confirm the GSI analysis results fit the observations better than the background is to check a set of files with names \textit{fort.2??}, where ?? is a number from 01 to 19 or larger than 20. In the run scripts, several fort files have also been renamed as \textit{fit\_t1} (\textit{q1}, \textit{p1}, \textit{rad1}, \textit{w1}).\textit{YYYYMMDDHH}. Please check Section \ref{sec4.5.1} for a detailed explanation of the fit files. Here illustrates how to use these fit files. +The analysis uses observations to correct the background fields to fit to the observations under certain constraints. The easiest way to confirm the GSI analysis results fit the observations better than the background is to check a set of files with names \textit{fort.2??}, where ?? is a number from 01 to 19 or larger than 20. In the run scripts, several "fort" files have also been renamed as \textit{fit\_t1} (\textit{q1}, \textit{p1}, \textit{rad1}, \textit{w1}).\textit{YYYYMMDDHH}. Please check Section \ref{sec4.5.1} for a detailed explanation of the fit files. Here, we illustrate how to use these fit files. \begin{itemize}[leftmargin=*] \item \textit{fit\_t1.2014061700} (\textit{fort.203}) -This file shows how the background and analysis fields fit to temperature observations. The contents of this file show five data types were used in the analysis: 120, 130, 132, 180 and 182. Also included are the number of observations, bias and rms of observation minus background (o-g 01) or analysis (o-g 03) on each level for the three data types. The following is a part of the file, only showing data types 120 and 180: +This file shows how the background and analysis fields fit to temperature observations. The contents of this file show five data types were used in the analysis: 120, 130, 132, 180, and 182. Also included are the number of observations, bias, and RMS error of observation minus background (o-g 01) or analysis (o-g 03) on each level for the three data types. The following is part of the file, only showing data types 120 and 180: \begin{tiny} \begin{verbatim} @@ -480,22 +480,22 @@ \subsubsection{Check Analysis Fit to Observations} ---------------------------------------------------------------------------------------------------------------------------------------------- o-g 01 t 120 0000 count 107 350 357 866 1153 719 252 450 551 884 745 7188 o-g 01 t 120 0000 bias 0.80 0.32 -0.10 -0.12 -0.15 -0.20 -0.24 -0.60 -0.22 0.15 -0.10 -0.07 - o-g 01 t 120 0000 rms 2.06 1.55 0.83 0.77 0.69 0.66 0.73 1.20 1.44 1.65 1.65 1.23 + o-g 01 t 120 0000 RMS error 2.06 1.55 0.83 0.77 0.69 0.66 0.73 1.20 1.44 1.65 1.65 1.23 o-g 01 t 120 0000 cpen 0.81 0.49 0.23 0.33 0.33 0.30 0.36 0.79 0.91 0.98 0.79 0.58 o-g 01 t 120 0000 qcpen 0.81 0.49 0.23 0.33 0.33 0.30 0.36 0.79 0.91 0.98 0.79 0.58 o-g 01 t 180 0000 count 339 35 0 0 0 0 0 0 0 0 0 374 o-g 01 t 180 0000 bias 0.17 1.12 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.26 - o-g 01 t 180 0000 rms 1.66 4.03 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 2.01 + o-g 01 t 180 0000 RMS error 1.66 4.03 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 2.01 o-g 01 t 180 0000 cpen 0.63 7.18 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 1.25 o-g 01 t 180 0000 qcpen 0.63 7.18 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 1.25 o-g 01 t 180 0001 count 1344 15 0 0 0 0 0 0 0 0 0 1359 o-g 01 t 180 0001 bias 0.82 4.17 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.86 - o-g 01 t 180 0001 rms 2.07 5.44 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 2.13 + o-g 01 t 180 0001 RMS error 2.07 5.44 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 2.13 o-g 01 t 180 0001 cpen 0.47 23.37 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.73 o-g 01 t 180 0001 qcpen 0.47 23.37 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.73 o-g 01 all count 1792 405 358 871 1172 725 325 800 651 884 745 9482 o-g 01 all bias 0.69 0.53 -0.10 -0.12 -0.15 -0.19 -0.09 -0.50 -0.04 0.15 -0.10 0.08 - o-g 01 all rms 1.99 2.14 0.83 0.77 0.69 0.67 0.84 1.32 1.58 1.65 1.65 1.45 + o-g 01 all RMS error 1.99 2.14 0.83 0.77 0.69 0.67 0.84 1.32 1.58 1.65 1.65 1.45 o-g 01 all cpen 0.52 1.91 0.23 0.33 0.36 0.31 0.44 0.97 1.18 0.98 0.79 0.68 o-g 01 all qcpen 0.52 1.91 0.23 0.33 0.36 0.31 0.44 0.97 1.18 0.98 0.79 0.68 @@ -504,35 +504,35 @@ \subsubsection{Check Analysis Fit to Observations} ---------------------------------------------------------------------------------------------------------------------------------------------- o-g 03 t 120 0000 count 107 350 357 866 1153 719 252 450 551 884 745 7188 o-g 03 t 120 0000 bias 0.58 0.29 -0.04 -0.02 -0.04 -0.02 0.01 -0.16 -0.04 0.06 0.04 0.01 - o-g 03 t 120 0000 rms 1.72 1.35 0.70 0.61 0.49 0.43 0.50 0.79 1.14 1.40 1.59 1.05 + o-g 03 t 120 0000 RMS error 1.72 1.35 0.70 0.61 0.49 0.43 0.50 0.79 1.14 1.40 1.59 1.05 o-g 03 t 120 0000 cpen 0.57 0.33 0.14 0.19 0.16 0.12 0.18 0.34 0.57 0.72 0.73 0.39 o-g 03 t 120 0000 qcpen 0.57 0.33 0.14 0.19 0.16 0.12 0.18 0.34 0.57 0.72 0.73 0.39 o-g 03 t 180 0000 count 339 35 0 0 0 0 0 0 0 0 0 374 o-g 03 t 180 0000 bias -0.24 0.21 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 -0.19 - o-g 03 t 180 0000 rms 1.55 2.83 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 1.71 + o-g 03 t 180 0000 RMS error 1.55 2.83 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 1.71 o-g 03 t 180 0000 cpen 0.34 2.57 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.55 o-g 03 t 180 0000 qcpen 0.34 2.57 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.55 o-g 03 t 180 0001 count 1344 16 0 0 0 0 0 0 0 0 0 1360 o-g 03 t 180 0001 bias 0.30 1.97 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.32 - o-g 03 t 180 0001 rms 1.75 2.88 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 1.77 + o-g 03 t 180 0001 RMS error 1.75 2.88 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 1.77 o-g 03 t 180 0001 cpen 0.27 6.05 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.34 o-g 03 t 180 0001 qcpen 0.27 6.05 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.34 o-g 03 all count 1792 406 358 871 1172 725 325 800 651 884 745 9483 o-g 03 all bias 0.21 0.34 -0.04 -0.02 -0.04 -0.02 0.04 -0.13 0.06 0.06 0.04 0.05 - o-g 03 all rms 1.71 1.61 0.69 0.61 0.49 0.43 0.61 0.94 1.26 1.40 1.59 1.22 + o-g 03 all RMS error 1.71 1.61 0.69 0.61 0.49 0.43 0.61 0.94 1.26 1.40 1.59 1.22 o-g 03 all cpen 0.30 0.75 0.14 0.19 0.18 0.14 0.24 0.49 0.76 0.72 0.73 0.42 o-g 03 all qcpen 0.30 0.75 0.14 0.19 0.18 0.14 0.24 0.49 0.76 0.72 0.73 0.42 \end{verbatim} \end{tiny} -For example: data type 120 has 1153 observations in layer 400.0-600.0 hPa, a bias of -0.15, and a rms of 0.69. The last column shows the statistics for the whole atmosphere. There are several summary lines for all data types, which is indicated by "all" in the data types column. For summary O-B (which is "o-g 01" in the file), we have 9482 observations total, a bias of 0.08, and a rms of 1.45. \\ +For example, data type 120 has 1153 observations in layer 400.0-600.0 hPa, a bias of -0.15, and a RMS error of 0.69. The last column shows the statistics for the whole atmosphere. There are several summary lines for all data types, which is indicated by "all" in the data types column. For summary O-B (which is "o-g 01" in the file), there are 9482 observations in total, for a bias of 0.08, and a RMS error of 1.45. \\ - Skipping ahead in the fort file, "o-g 03" columns (under "it") show the observation minus analysis (O-A) information. Under the summary ("all") lines, it can be seen that there were 9483 total observations, a bias of 0.05, and a rms of 1.22. This shows that from the background to the analysis, one more observation data is being used because of the recalculation of the innovation and the gross check after each outer loop, the bias reduced from 0.08 to 0.05, and the rms reduced from 1.45 to 1.22. This is about a 16\% reduction, which is a reasonable value for large-scale analysis. \\ + Skipping ahead in the "fort" file, "o-g 03" columns (under "it") show the observation minus analysis (O-A) information. Under the summary ("all") rows, it can be seen that there were 9483 total observations, a bias of 0.05, and a RMS error of 1.22. This shows that from the background to the analysis, one more observation data point is being used because of the recalculation of the innovation and the gross check after each outer loop, the bias reduced from 0.08 to 0.05, and the RMS error reduced from 1.45 to 1.22. This is about a 16\% reduction, which is a reasonable value for a large-scale analysis. \\ \item \textit{fit\_w1.2014061700} (\textit{fort.202}) -This file demonstrates how the background and analysis fields fit to wind observations. This file (as well as \textit{fit\_q1}) are formatted the same as the \textit{fort.203}. Therefore, only the summary lines will be shown for O-B and O-A to gain a quick view of the fitting: +This file demonstrates how the background and analysis fields fit to wind observations. This file (as well as \textit{fit\_q1}) is formatted the same way as \textit{fort.203}. Therefore, only the summary lines for O-B and O-A will be shown here to gain a quick view of the fit to observations: \begin{tiny} \begin{verbatim} @@ -542,19 +542,19 @@ \subsubsection{Check Analysis Fit to Observations} ---------------------------------------------------------------------------------------------------------------------------------------------- o-g 01 all count 1597 1703 1839 2930 1213 828 290 687 533 694 798 14513 o-g 01 all bias 0.27 0.84 0.68 0.61 0.56 0.45 0.67 0.91 0.48 0.83 1.21 0.64 - o-g 01 all rms 2.50 2.65 2.52 3.11 4.02 3.98 4.37 4.31 5.32 5.41 4.77 3.59 + o-g 01 all RMS error 2.50 2.65 2.52 3.11 4.02 3.98 4.37 4.31 5.32 5.41 4.77 3.59 ---------------------------------------------------------------------------------------------------------------------------------------------- o-g 03 all count 1608 1695 1843 2931 1212 828 290 687 533 694 798 14520 o-g 03 all bias 0.23 0.42 0.26 0.30 0.37 0.33 0.22 0.37 0.32 0.67 1.22 0.39 - o-g 03 all rms 2.27 2.16 1.94 2.23 2.74 2.82 3.64 3.31 4.22 4.43 4.41 2.90 + o-g 03 all RMS error 2.27 2.16 1.94 2.23 2.74 2.82 3.64 3.31 4.22 4.43 4.41 2.90 \end{verbatim} \end{tiny} - \hspace{1cm} O-B: 14513 observations in total, bias is 0.64 and rms is 3.59 + \hspace{1cm} O-B: 14513 observations in total, bias is 0.64, and RMS error is 3.59 - \hspace{1cm} O-A: 14520 observations in total, bias is 0.39 and rms is 2.90\\ -The total bias was reduced from 0.64 to 0.39 and the rms reduced from 3.59 to 2.90 (~20\% reduction).\\ + \hspace{1cm} O-A: 14520 observations in total, bias is 0.39, and RMS error is 2.90\\ +The total bias was reduced from 0.64 to 0.39 and the RMS error was reduced from 3.59 to 2.90 (~20\% reduction).\\ \item \textit{fit\_q1.2014061700} (\textit{fort.204}) @@ -569,43 +569,43 @@ \subsubsection{Check Analysis Fit to Observations} ---------------------------------------------------------------------------------------------------------------------------------------------- o-g 01 all count 543 186 182 211 146 457 406 520 621 623 0 3895 o-g 01 all bias 1.17 -3.68 -2.47 -1.30 -3.55 0.19 0.64 -1.80 -4.28 -5.55 0.00 -2.05 - o-g 01 all rms 9.09 10.63 9.03 9.34 12.73 12.30 14.53 15.27 16.45 16.01 0.00 13.66 + o-g 01 all RMS error 9.09 10.63 9.03 9.34 12.73 12.30 14.53 15.27 16.45 16.01 0.00 13.66 ---------------------------------------------------------------------------------------------------------------------------------------------- o-g 03 all count 543 186 182 211 146 457 406 520 621 623 0 3895 o-g 03 all bias -0.39 -0.88 -0.68 0.45 -0.51 0.06 0.13 -0.10 -0.70 -1.90 0.00 -0.53 - o-g 03 all rms 5.48 5.19 4.37 5.73 8.13 9.31 12.19 13.82 13.01 12.36 0.00 10.64 + o-g 03 all RMS error 5.48 5.19 4.37 5.73 8.13 9.31 12.19 13.82 13.01 12.36 0.00 10.64 \end{verbatim} \end{tiny} -\hspace{1cm} O-B: 3895 observations in total and bias is -2.05 and rms is 13.66 +\hspace{1cm} O-B: 3895 observations in total, bias is -2.05, and RMS error is 13.66 -\hspace{1cm} O-A: 3895 observations in total and bias is -0.53 and rms is 10.64\newline -The total bias and rms were reduced. \\ +\hspace{1cm} O-A: 3895 observations in total, bias is -0.53, and RMS error is 10.64\newline +The total bias and RMS error were reduced. \\ \item \textit{fit\_p1.2014061700} (\textit{fort.201}) - This file demonstrates how the background and analysis fields fit to surface pressure observations. Because the surface pressure is a two-dimensional field, the table is formatted different than the three-dimensional fields shown above. Once again, the summary lines will be shown for O-B and O-A to gain a quick view of the fitting: + This file demonstrates how the background and analysis fields fit to surface pressure observations. Because surface pressure is a two-dimensional field, the table is formatted differently than the three-dimensional fields shown above. Once again, only the summary lines will be shown for O-B and O-A to gain a quick view of the fit to observations: \begin{scriptsize} \begin{verbatim} -------------------------------------------------- pressure levels (hPa)= 0.0 2000.0 - it obs type stype count bias rms cpen qcpen + it obs type stype count bias RMS error cpen qcpen o-g 01 all 13890 0.1912 0.7931 0.4105 0.4105 -------------------------------------------------- o-g 03 all 13916 0.0403 0.6764 0.2921 0.2921 \end{verbatim} \end{scriptsize} -\hspace{1cm} O-B: 13890 observations in total and bias is 0.1912 and rms is 0.7931 +\hspace{1cm} O-B: 13890 observations in total, bias is 0.1912, and RMS error is 0.7931 -\hspace{1cm} O-A: 13916 observations in total and bias is 0.0403 and rms is 0.6764\newline +\hspace{1cm} O-A: 13916 observations in total, bias is 0.0403, and RMS error is 0.6764\newline -Both the total bias and rms were reduced. \\ +Both the total bias and RMS error were reduced. \\ -These statistics show that the analysis results fit to the observations closer than the background, which is what the analysis is supposed to do. How close the analysis fit to the observations is based on the ratio of background error variance and observation error. +These statistics show that the analysis results fit to the observations closer than the background, which is what we would expect. How close the analysis fits to the observations is based on the ratio of background error variance and observation error. \end{itemize} @@ -614,9 +614,9 @@ \subsubsection{Check the Minimization} \label{sec5.1.4.2} %------------------------------------------------------------------------------- -In addition to the minimization information in the stdout file, GSI writes more detailed information into a file called fort.220. The content of fort.220 is explained in the Advanced GSI User\textquotesingle s Guide. Below is an example of a quick check of the trend of the cost function and norm of gradient. The value should get smaller with each iteration step. +In addition to the minimization information in the standard output file, GSI writes more detailed information into a file called "fort.220." The content of "fort.220" is explained in the Advanced GSI User\textquotesingle s Guide. Below is an example of a quick check of the cost function trend and the norm of gradient. The values should get smaller with each iteration. -In the run directory, the cost function and norm of the gradient information can be dumped into an output file by using the command: +In the run directory, information on the cost function and norm of the gradient can be dumped into an output file by using the following command: \begin{scriptsize} \begin{verbatim} @@ -624,7 +624,7 @@ \subsubsection{Check the Minimization} \end{verbatim} \end{scriptsize} -The file \textit{cost\_gradient.txt} includes 6 columns, however only the first 4 columns are needed and are explained below. The first 5 and last 5 lines read are: +The file \textit{cost\_gradient.txt} includes six columns, however only the first four columns are needed and are explained below. The first five and last five lines read are: \begin{scriptsize} \begin{verbatim} @@ -643,9 +643,9 @@ \subsubsection{Check the Minimization} \end{verbatim} \end{scriptsize} -The first column is the outer loop number and the second column is the inner iteration number. The third column is the cost function, and the forth column is the norm of gradient. It can be seen that both the cost function and norm of gradient are descending. +The first column is the outer loop number and the second column is the inner iteration number. The third column is the cost function, and the forth column is the norm of the gradient. It can be seen that both the cost function and norm of the gradient are descending. -To get a complete picture of the minimization process, the cost function and norm of gradient can be plotted using a provided NCL script located under: +To get a complete picture of the minimization process, the cost function and norm of the gradient can be plotted using an included NCL script located here: \begin{scriptsize} \begin{verbatim} @@ -653,23 +653,23 @@ \subsubsection{Check the Minimization} \end{verbatim} \end{scriptsize} -the plot is shown as Fig.\ref{fig:costgrad_ch5}: +The plot is shown as Fig.\ref{fig:costgrad_ch5}: \begin{figure}[h!] \centering \includegraphics[width=0.7\textwidth]{images/CostGrad_ch5} - \caption{Cost function (y-axes) and norm of gradient(y-axes) change with iteration steps (x-axes).} + \caption{The cost function (y-axes) and norm of the gradient (y-axes) change with each iteration (x-axes).} \label{fig:costgrad_ch5} \end{figure} -The above plots demonstrate that both the cost function and norm of gradient descend very fast in the first 10 iterations in both outer loops and drop very slowly after the 10th iteration. +The above plots demonstrate that both the cost function and norm of the gradient descend very fast in the first ten iterations in both outer loops and drop very slowly afterward. %------------------------------------------------------------------------------- \subsubsection{Check the Analysis Increment} \label{sec5.1.4.3} %------------------------------------------------------------------------------- -The analysis increment gives us an idea where and how much the background fields have been modified by the observations through analysis. Another useful graphics tool that can be used to look at the analysis increment is located under: +The analysis increment gives us an idea of where and how much the background fields have been modified by the observations through the analysis. Another useful graphics tool that can be used to look at the analysis increment is located here: \begin{scriptsize} \begin{verbatim} @@ -677,7 +677,7 @@ \subsubsection{Check the Analysis Increment} \end{verbatim} \end{scriptsize} -The graphic below shows the analysis increment at the 15th sigma level in analysis grid. Notice that the scales are different for each of the plots. +The graphic below shows the analysis increment at the 15th sigma (vertical) level on the analysis grid. Notice that the scales are different for each of the plots. \begin{figure}[h!] \centering @@ -686,7 +686,7 @@ \subsubsection{Check the Analysis Increment} \label{fig:increments} \end{figure} -The analysis increment shows the fact that the conventional observations are mostly located in the U.S. CONUS domain and the data availability over the ocean is very sparse. +The analysis increment indicates that conventional observations are mostly located within the continental United States and that data availability over the ocean is very sparse. %------------------------------------------------------------------------------- \section{Assimilating Radiance Data with Regional GSI} @@ -697,12 +697,12 @@ \subsection{Run Script} \label{sec5.2.1} %------------------------------------------------------------------------------- -Adding radiance data into the GSI analysis is very straightforward after a successful run of GSI with conventional data. The same run script from the above section can be used to run GSI with radiance with or without PrepBUFR data. The key step to adding the radiance data is linking the radiance BUFR data files to the GSI run directory with the names listed in the \verb|&OBS_INPUT| section of the GSI namelist. The following example adds the two radiance BUFR files: +Adding radiance data into the GSI analysis is straightforward after having already run GSI with conventional data. The same run script from the above section can be used to run GSI with radiance data (with or without PrepBUFR data). The key step to adding the radiance data is linking the radiance BUFR files to the GSI run directory with the names listed in the \verb|&OBS_INPUT| section of the GSI namelist. The following example adds the two radiance BUFR files: AMSU-A: \textit{gdas1.t00z.1bamua.tm00.bufr\_d}\newline HIRS4: \textit{gdas1.t00z.1bhrs4.tm00.bufr\_d} -The location of these radiance BUFR files has been previously saved to the scripts variable \verb|OBS_ROOT|, therefore the following two lines can be inserted below the link to the PrepBUFR data in the script \textit{run\_gsi\_regional.ksh}: +The location of these radiance BUFR files is already included in the scripts variable \verb|OBS_ROOT|, therefore the following two lines can be inserted below the link to the prepBUFR data in the script \textit{run\_gsi\_regional.ksh}: \begin{scriptsize} \begin{verbatim} @@ -711,7 +711,7 @@ \subsection{Run Script} \end{verbatim} \end{scriptsize} -If it is desired to run radiance data in addition to the conventional PrepBUFR data, the following link to the PrepBUFR should be kept as is: +If radiance data is desired in addition to conventional prepBUFR data, the following link to the prepBUFR data should be kept as is: \begin{scriptsize} \begin{verbatim} @@ -719,7 +719,7 @@ \subsection{Run Script} \end{verbatim} \end{scriptsize} -Alternatively to analyze radiance data without conventional PrepBUFR data, this line can be commented out in the script \textit{run\_gsi\_regional.ksh}: +Alternatively, to analyze radiance data without conventional prepBUFR data, this line can be commented out in the script \textit{run\_gsi\_regional.ksh}: \begin{scriptsize} \begin{verbatim} @@ -727,9 +727,9 @@ \subsection{Run Script} \end{verbatim} \end{scriptsize} -In the following example, the case study will include both radiance and conventional observations. +In the following example, both radiance and conventional observations will be assimilated. -In order to link the correct name for the radiance BUFR file, the namelist section \verb|&OBS_INPUT| should be referenced. This section has a list of data types and BUFR file names that can be used in GSI. The 1st column \verb|"dfile"| is the file name recognized by GSI. The 2nd column \verb|"dtype"| and 3rd column \verb|"dplat"| are the data type and data platform that are included in the file listed in "dfile", respectively. For example, the following line tells us the AMSU-A observation from NOAA-15 should be read from a BUFR file named as \textit{"amsuabufr"}: +In order to link the correct name for the radiance BUFR file, the namelist section \verb|&OBS_INPUT| should be referenced. This section has a list of data types and BUFR file names that can be used in GSI. The 1\textsuperscript{st} column \verb|"dfile"| is the file name recognized by GSI. The 2\textsuperscript{nd} column \verb|"dtype"| and 3\textsuperscript{rd} column \verb|"dplat"| are the data type and data platform that are included in the file listed in "dfile," respectively. For example, the following line tells us the AMSU-A observation from NOAA-15 should be read from a BUFR file named \textit{"amsuabufr"}: \begin{scriptsize} \begin{verbatim} @@ -738,12 +738,12 @@ \subsection{Run Script} \end{verbatim} \end{scriptsize} -With radiance data assimilation, two important setups, data thinning and bias correction, need to be checked carefully. The following is a brief description of these two setups: +With radiance data assimilation, data thinning and bias correction need to be checked carefully. The following is a brief description of these two: \begin{itemize} \item Radiance data thinning -The radiance data thinning is setup in the namelist section \verb|&OBS_INPUT|. The following is a part of namelist in that section: +Radiance data thinning is found in the namelist section \verb|&OBS_INPUT|. The following is a part of namelist in that section: \begin{scriptsize} \begin{verbatim} @@ -753,11 +753,11 @@ \subsection{Run Script} \end{verbatim} \end{scriptsize} -The first line of \verb|&OBS_INPUT| lists multiple mesh grids as elements of the array \verb|dmesh| (three mesh grids in the above example). For the line specifying a data type, the 2nd last element of that line is to specify the choice of \verb|dthin|. This selects the mesh grid to be used for thinning. It can be seen that the data thinning option for NOAA-15 AMSU-A observations is 60 km because the value of \verb|dthin| is 2, corresponding to \verb|dmesh(2)|=60 km. For more information about radiance data thinning, please refer to the Advanced GSI User\textquotesingle s Guide.\\ +The first line of \verb|&OBS_INPUT| lists multiple mesh grids as elements of the array \verb|dmesh| (three mesh grids in the above example). For the line specifying data type, the 2\textsuperscript{nd} to last element of that line is used to specify the choice of \verb|dthin|. This selects the mesh grid to be used for thinning. The data thinning option for NOAA-15 AMSU-A observations is set to 60 km because the value of \verb|dthin| is two, corresponding to \verb|dmesh(2)|=60 km. For more information about radiance data thinning, please refer to the Advanced GSI User\textquotesingle s Guide.\\ \item Radiance data bias correction -The radiance data bias correction is very important for a successful radiance data analysis. In the sample run scripts, there are two files related to bias correction: +Radiance data bias correction is very important for successful radiance data assimilation. In the sample run scripts, there are two files related to bias correction: \begin{scriptsize} \begin{verbatim} @@ -767,9 +767,9 @@ \subsection{Run Script} \end{verbatim} \end{scriptsize} -For this case, the GDAS bias correction files were downloaded and saved in the fix directory as examples. For different cases, the run script should have those two lines to link the bias correction coefficient files. The first line sets the path to the bias coefficient file, and the second copies the bias correction coefficients for passive (monitored) channels into the working directory. Those two coefficient files are usually calculated from within GSI in the previous cycle. These two files are provided in ./fix as an example of the bias correction coefficients. For the best results, it will be necessary for the user to generate their own bias files. The details of the radiance data bias correction are discussed in the Advanced GSI User\textquotesingle s Guide. Please note the GSI release version before v3.5 has coefficients for mass bias correction and angle bias correction calculated separately. \\ +For this case, the GDAS bias correction files were downloaded and saved in the fix directory as examples. For other cases, the run script should link to corresponding bias correction coefficient files. The first line sets the path to the bias coefficient file, and the second copies the bias correction coefficients for passive (monitored) channels into the working directory. These two coefficient files are usually calculated from within GSI in the previous cycle. Two files are provided in ./fix as examples of the bias correction coefficients. For the best results, it is necessary for the user to generate his or her own bias files. The details of radiance data bias correction are discussed in the Advanced GSI User\textquotesingle s Guide. Please note that GSI releases prior to v3.5 have coefficients for mass bias correction and angle bias correction calculated separately. \\ -Once these links are set, we are ready to run the case. +Once these links are set, we are ready to run GSI. \end{itemize} @@ -779,7 +779,7 @@ \subsection{Run GSI and Check Run Status} \label{sec5.2.2} %------------------------------------------------------------------------------- -The process for running GSI is the same as described in section \ref{sec5.1.2}. Once \textit{run\_gsi\_regional.ksh} has been submitted, move into the run directory to check the GSI analysis results. For our current case, the run directory will look almost as it did for the conventional data case, the exception being the two links to the radiance BUFR files and new diag files for the radiance data types used. Following the same steps as in section \ref{sec5.1.2}, check the \textit{stdout} file to see if GSI has run through each part of the analysis process successfully. In addition to the information outlined for the conventional run, the radiance BUFR files should have been read in and distributed to each sub domain: +The process for running GSI is the same as described in section \ref{sec5.1.2}. Once \textit{run\_gsi\_regional.ksh} has been submitted, move into the run directory to check the GSI analysis results. For the current case, the run directory will look almost as it did for the conventional data case, the exception being the two links to the radiance BUFR files and new diag files for the radiance data types used. Following the same steps as in section \ref{sec5.1.2}, check the \textit{stdout} file to see if GSI has run through each part of the analysis process successfully. In addition to the information outlined for the conventional run, the radiance BUFR files should have been read in and distributed to each sub domain: \begin{scriptsize} \begin{verbatim} @@ -800,7 +800,7 @@ \subsection{Run GSI and Check Run Status} \end{scriptsize} -When comparing this output to the content in step 3 of section \ref{sec5.1.3}, it can be seen that there are 8 new radiance data types that have been read in: HIRS4 from METOP-A, METOP-B and NOAA-19, AMSU-A from NOAA-15, NOAA-18, NOAA-19, METOP-A and METOP-B. The table above shows that most of the radiance data read in this case are AMSU-A from NOAA satellite. +When comparing this output to the content in step three of section \ref{sec5.1.3}, it can be seen that there are eight new radiance data types that have been read in: HIRS4 from METOP-A, METOP-B and NOAA-19, AMSU-A from NOAA-15, NOAA-18, NOAA-19, METOP-A, and METOP-B. The table above shows that most of the radiance data read in for this case are AMSU-A from NOAA satellite information. %------------------------------------------------------------------------------- \subsection{Diagnose GSI Analysis Results} @@ -810,11 +810,11 @@ \subsection{Diagnose GSI Analysis Results} \subsubsection{Check File fort.207} %------------------------------------------------------------------------------- -The file \textit{fort.207} contains the statistics for the radiance data, similar to file fort.203 for temperature. This file contains important details about the radiance data analysis. Section \ref{sec4.5.2} explains this file in detail. Below are some values from the file \textit{fort.207} to give a quick look at the radiance assimilation for this case study. +The file \textit{fort.207} contains the statistics for the radiance data, similar to file \textit{fort.203} for temperature. This file contains important details about the radiance data analysis. Section \ref{sec4.5.2} explains this file in detail. Below are some values from the file \textit{fort.207} to provide a quick look at the radiance assimilation for this example. The \textit{fort.207} file contains the following lines: -\hspace{4ex} For O-B, the stage before the first outer loop: +\hspace{4ex} For O-B, before the first outer loop: \begin{scriptsize} \begin{verbatim} @@ -824,7 +824,7 @@ \subsubsection{Check File fort.207} \end{verbatim} \end{scriptsize} -\hspace{4ex} For O-A, the stage after the second outer loop: +\hspace{4ex} For O-A, after the second outer loop: \begin{scriptsize} \begin{verbatim} @@ -833,11 +833,11 @@ \subsubsection{Check File fort.207} \end{verbatim} \end{scriptsize} -From the above information, it can be seen that AMSU-A data from NOAA-15 have 83190 observations within the analysis time window and domain. After thinning, 58236 of this data type remained, and only 25226 passed quality check and were used in the analysis. The penalty for this data decreased from 10356 to 4672.4 after 2 outer loops. It is also very interesting to see that the number of AMSU-A observations assimilated in the O-A calculation increased to 30136 from 25226 because more data passed quality check in 2nd outer loop. +From the above information, it can be seen that AMSU-A data from NOAA-15 provides 83190 observations within the analysis time window and domain. After thinning, 58236 observations remained, and only 25226 passed the quality check and were used in the analysis. The penalty for this data decreased from 10356 to 4672.4 after two outer loops. It is important to note that the number of AMSU-A observations assimilated in the O-A calculation increased to 30136 from 25226 as more data passed the quality check in the 2\textsuperscript{nd} outer loop. -The statistics for each channel can be viewed in the \textit{fort.207} file as well. Below channels from AMSU-A NOAA-15 are listed as an example: +The statistics for each channel can be viewed in the \textit{fort.207} file as well. Here, channels from AMSU-A NOAA-15 are listed as an example: -\hspace{4ex} For O-B, the stage before the first outer loop: +\hspace{4ex} For O-B, before the first outer loop: \begin{scriptsize} \begin{verbatim} @@ -855,7 +855,7 @@ \subsubsection{Check File fort.207} \end{verbatim} \end{scriptsize} -\hspace{4ex} For O-A, the stage after the second outer loop: +\hspace{4ex} For O-A, after the second outer loop: \begin{scriptsize} \begin{verbatim} @@ -873,39 +873,38 @@ \subsubsection{Check File fort.207} \end{verbatim} \end{scriptsize} -The second column is channel number for AMSU-A and the last column is the standard deviation for each channel. It can be seen that most of the channels fit better to the observations after the second outer loop. +The second column is the channel number for AMSU-A and the last column is the standard deviation for each channel. It can be seen that most of the channels fit better to the observations after the second outer loop. %------------------------------------------------------------------------------- \subsubsection{Check the Analysis Increment} %------------------------------------------------------------------------------- -The same methods for checking the optimal minimization as demonstrated in section \ref{sec5.1.4.2} can be used for radiance assimilation. Similar features to the conventional assimilation should be seen with the minimization. The figures below show detailed information on how the radiance data impact the analysis results on top of the conventional data. Using the same NCL script as in section \ref{sec5.1.4.3}, analysis increment fields are plotted comparing the analysis results with radiance and conventional data to the analysis results with conventional data assimilation only. The Fig \ref{fig:increments_rad2} is for level 49 and the Fig.\ref{fig:increments_rad} is for level 6, which represent the maximum temperature increment level (49) and maximum moisture increment level (6). +The same methods for checking the optimal minimization as demonstrated in section \ref{sec5.1.4.2} can be used for radiance assimilation. Similar features to the conventional assimilation should be seen with the minimization. The figures below show detailed information on how the radiance data impact the analysis results on top of the conventional data. Using the same NCL script as in section \ref{sec5.1.4.3}, analysis increment fields are plotted comparing the analysis results with radiance and conventional data to the analysis results with conventional data assimilation only. Figure \ref{fig:increments_rad2} is for vertical level 49 and Figure \ref{fig:increments_rad} is for vertical level six, representing the maximum temperature increment level (49) and maximum moisture increment level (6), respectively. \begin{figure}[h!] \centering \includegraphics[width=0.9\textwidth]{images/increments_rad} - \caption{Analysis increment fields of PrepBUFR and Radiance data analysis comparing to the analysis with PREPBUFR only at level 6} + \caption{Analysis increment fields of the prepBUFR and radiance data analysis compared to the analysis with prepBUFR only at vertical level six} \label{fig:increments_rad} \end{figure} \begin{figure}[h!] \centering \includegraphics[width=0.9\textwidth]{images/increments_rad2} - \caption{Analysis increment fields PrepBUFR and Radiance data analysis comparing to the analysis with PREPBUFR only at level 49} + \caption{Analysis increment fields of the prepBUFR and radiance data analysis compared to the analysis with prepBUFR only at vertical level 49} \label{fig:increments_rad2} \end{figure} -In order to fully understand the analysis results, the following needs to be understood: +In order to fully understand the analysis results, the following topics should be reviewed: \begin{enumerate} -\item The weighting functions of each channel and the data coverage at this analysis time. There are several sources on the Internet to show the weighting function for the AMSU-A channels. Channel 1 is the moisture channel, while the others are mainly temperature channels (Channels 2, 3 and 15 also have large moisture signals). Because a model top of 20 mb was specified for this case study, the actual impact should come from channels with the peak of the weighting below 20hPa. +\item The weighting functions of each channel and the data coverage at the analysis time. There are several sources on the internet that show the weighting functions of the AMSU-A channels. Channel one is the moisture channel, while the others are mainly temperature channels (Channels two, there, and 15 also have large moisture signals). Because a model top of 20 mb was specified for this case study, the actual impact should come from channels with peak weighting below 20 hPa. -\item The usage of each channel is located in the file named \textit{'satinfo'} in the run directory. The first two columns show the observation type and platform of the channels and the third column tells us if this channel is used in the analysis. Because a lot of amsua\_n15 and amsua\_n18 data were used, they should be checked in detail. In this case, Channels 6, 11 and 14 from amsua\_n15 and channels 9 and 14 from amsua\_n18 were turned off. +\item The usage of each channel is located in the file named \textit{'satinfo'} in the run directory. The first two columns show the observation type and platform of the channels, and the third column indicates if the channel is used in the analysis. Because many amsua\_n15 and amsua\_n18 data were used, they should be checked in detail. In this case, Channels six, 11, and 14 from amsua\_n15 and channels nine and 14 from amsua\_n18 were turned off. -\item Thinning information: a quick look at the namelist in the run directory: gsiparm.anl shows that both amsua\_n15 and amsu\_n18 using thinning grid 2, which is 60 km. In this case, the grid spacing is 30 km, which indicates to use the satellite observations every four grid-spaces, which might be a little dense. +\item Thinning information, including a quick look at the namelist in the run directory. The file "gsiparm.anl" shows that both amsua\_n15 and amsu\_n18 use thinning grid two, which is 60 km. In this case, the grid spacing is 30 km, which indicates to use the satellite observations every four grid-spaces, which might be a little dense. - -\item Bias correction: radiance bias correction was previously discussed. It is very important for a successful radiance data analysis. The run script can only link to the GDAS bias correction coefficients that are provided as an example in \textit{./fix}: +\item Bias correction: Radiance bias correction was previously discussed. It is very important for a successful radiance data analysis. The run script can only link to the GDAS bias correction coefficients that are provided as an example in \textit{./fix}: \begin{scriptsize} \begin{verbatim} @@ -914,9 +913,9 @@ \subsubsection{Check the Analysis Increment} \end{verbatim} \end{scriptsize} -Users can download the operational bias correction coefficients during the experiment period as a starting point to calculate the coefficients suitable for their experiments. \\ +Users can download the operational bias correction coefficients during their experiment period as a starting point to calculate the coefficients suitable for their experiments. \\ -Radiance bias correction for regional analysis is a difficult issue because of the limited coverage of radiance data. This topic is out of the scope of this document, but this issue should be considered and understood when using GSI with radiance applications. +Radiance bias correction for regional analyses is a difficult issue because of the limited coverage of radiance data. This topic is out of the scope of this document, but this issue should be considered and understood when using GSI with radiance applications. \end{enumerate} %------------------------------------------------------------------------------- @@ -927,7 +926,7 @@ \section{Assimilating GPS Radio Occultation Data with Regional GSI} \subsection{Run Script} %------------------------------------------------------------------------------- -The addition of GPS Radio Occultation (RO) data into the GSI analysis is similar to that of adding radiance data. In the example below, the RO data is used as refractivity. There is also an option to use the data as bending angles. The same run scripts used in sections \ref{sec5.1.1} and \ref{sec5.2.1} can be used with the addition of the following link to the observations: +The addition of GPS Radio Occultation (RO) data into the GSI analysis is similar to that of adding radiance data. In the example below, the RO data is used as refractivity. There is also an option to use the data as bending angles. The same run scripts in sections \ref{sec5.1.1} and \ref{sec5.2.1} can be used with the addition of the following link to RO observations: \begin{scriptsize} \begin{verbatim} @@ -956,7 +955,7 @@ \subsection{Run Script} \subsection{Run GSI and Check the Run Status} %------------------------------------------------------------------------------- -The process of running GSI is the same as described in section \ref{sec5.1.2}. Once \textit{run\_gsi\_regional.ksh} has been submitted, move into the working directory, \textit{gsiprd\_2014061700\_gps\_prepbufr}, to check the GSI analysis results. The run directory will look exactly the same as with the conventional data, with the exception of the link to the GPS RO BUFR files used in this case. Following the same steps as in section \ref{sec5.1.3}, check the stdout file to see if GSI has run through each part of the analysis process successfully. In addition to the information outlined for the conventional run, the GPS RO BUFR files should have been read in and distributed to each sub domain: +The process of running GSI is the same as described in section \ref{sec5.1.2}. Once \textit{run\_gsi\_regional.ksh} has been submitted, move into the working directory, \textit{gsiprd\_2014061700\_gps\_prepbufr}, to check the GSI analysis results. The run directory will look exactly the same as with the conventional data, with the exception of the link to the GPS RO BUFR files used in this case. Following the same steps as in section \ref{sec5.1.3}, check the standard output file to see if GSI has run through each part of the analysis process successfully. In addition to the information outlined for the conventional run, the GPS RO BUFR files should have been read in and distributed to each sub domain: \begin{scriptsize} \begin{verbatim} @@ -979,7 +978,7 @@ \subsection{Diagnose GSI Analysis Results} \subsubsection{Check File \textit{fort.212}} %------------------------------------------------------------------------------- -The file \textit{fort.212} shows the fit of analysis/background to the GPS/RO data in fractional difference. It has the same structure as the fit files for conventional data. Below is a quick look to be sure the GPS RO data were used: +The file \textit{fort.212} shows the fit of the analysis/background to the GPS/RO data as fractional differences. It has the same structure as the fit files for conventional data. Below is a quick look to be sure the GPS RO data were used: \begin{tiny} \begin{verbatim} @@ -990,7 +989,7 @@ \subsubsection{Check File \textit{fort.212}} ---------------------------------------------------------------------------------------------------------------------------------------------- o-g 01 all count 0 13 58 223 355 342 232 261 326 440 729 3740 o-g 01 all bias 0.00 -0.76 -0.03 -0.06 -0.04 0.01 -0.03 0.04 -0.04 -0.16 -0.18 -0.14 - o-g 01 all rms 0.00 1.41 0.75 0.96 0.79 0.35 0.32 0.42 0.54 0.57 0.55 0.59 + o-g 01 all RMS error 0.00 1.41 0.75 0.96 0.79 0.35 0.32 0.42 0.54 0.57 0.55 0.59 Observation - Analysis (O-A) @@ -999,11 +998,11 @@ \subsubsection{Check File \textit{fort.212}} ---------------------------------------------------------------------------------------------------------------------------------------------- o-g 03 all count 1 18 65 229 355 342 231 266 330 440 731 3776 o-g 03 all bias -0.40 -0.43 0.03 0.02 -0.02 -0.01 -0.02 0.00 0.01 -0.01 -0.02 0.00 - o-g 03 all rms 0.40 1.03 0.54 0.59 0.70 0.26 0.14 0.20 0.24 0.28 0.39 0.41 + o-g 03 all RMS error 0.40 1.03 0.54 0.59 0.70 0.26 0.14 0.20 0.24 0.28 0.39 0.41 \end{verbatim} \end{tiny} -It can be seen that most of the GPS RO data are located in the upper levels, with a total of 3740 observations used in the analysis during the 1st outer loop, and 3776 used to calculate O-A. After the analysis, the data bias reduced from -0.14 to 0.00, and the rms was reduced from 0.59 to 0.41. It can be concluded that the analysis with GPS RO data looks reasonable from these statistics. +It can be seen that most of the GPS RO data are located in the upper levels, with a total of 3740 observations used in the analysis during the 1\textsuperscript{st} outer loop, and 3776 used to calculate O-A. After the analysis, the data bias reduced from -0.14 to 0.00, and the RMS error was reduced from 0.59 to 0.41. It can be concluded that the analysis with GPS RO data looks reasonable from these statistics. %------------------------------------------------------------------------------- \subsubsection{Check the Analysis Increment} @@ -1011,46 +1010,46 @@ \subsubsection{Check the Analysis Increment} The same methods for checking the minimization in section \ref{sec5.1.4.2} can be used for the GPS RO assimilation. -The following figures give detailed information of how the new data impacts the analysis result. Using the NCL script used in section \ref{sec5.1.4}, analysis increment fields are plotted comparing the analysis results with GPS RO and conventional data to the analysis results with conventional data assimilation only for level 48, which represents the maximum temperature increment. +The following figures provide detailed information about how the new data impacts the analysis. Using the NCL script from section \ref{sec5.1.4}, analysis increment fields are plotted comparing the analysis results with GPS RO and conventional data to the analysis results with conventional data assimilation only for vertical level 48, which represents the maximum temperature increment. \begin{figure}[h!] \centering \includegraphics[width=0.9\textwidth]{images/increments_bufr} - \caption{Analysis increment fields comparing the use of GPS RO and conventional observations to create the analysis to only PrepBUFR at level 48.} + \caption{Analysis increment fields comparing the use of GPS RO and conventional observations to only prepBUFR at vertical level 48.} \label{fig:increments_bufr} \end{figure} %------------------------------------------------------------------------------- -\section{Introduction to GSI 3D Hybrid EnVar Analysis} +\section{Introduction to GSI Hybrid 3DEnVar Analysis} %------------------------------------------------------------------------------- -The 3 dimensional hybrid ensemble-variational (3D hybrid EnVar) analysis is an important analysis option in the GSI system that has been used by operations. It provides the ability to bring the flow dependent background error covariance into the analysis based on ensemble forecasts. If ensemble forecasts have been generated, setting up GSI to do a hybrid analysis is straightforward and only requires two changes in the run script in addition to the current 3DVAR run script: +The three-dimensional hybrid ensemble-variational (hybrid 3DEnVar) analysis is an important option in the GSI system that has been used operationally. It provides the ability to bring the flow dependent background error covariance into the analysis based on ensemble forecasts. If ensemble forecasts have been generated, setting up GSI to do a hybrid analysis is straightforward and only requires two changes in the run script in addition to the current 3DVAR run script: \begin{itemize}[leftmargin=*] \item \textit{Change 1: Link the ensemble members to the GSI run directory}\\ -This change is to link the ensemble members to the GSI run directory and assign each ensemble member a name that GSI recognizes. The release version GSI can accept 4 kinds of ensemble forecasts, which is controlled by the namelist variable \textit{regional\_ensemble\_option}. Table \ref{tab51} gives a list of options for \textit{regional\_ensemble\_option} and the naming convention for linking the ensemble to GSI recognized names. \\ +This change is required to link the ensemble members to the GSI run directory and assign each ensemble member a name that GSI recognizes. GSI can accept four kinds of ensemble forecasts, controlled by the namelist variable \textit{regional\_ensemble\_option}. Table \ref{tab51} provides a list of options for \textit{regional\_ensemble\_option} and the naming convention for linking the ensemble files to GSI recognized names. \\ \begin{table}[htbp] \centering \begin{small} -\caption{the list of ensemble forecasts that can be read by GSI hybrid} +\caption{List of ensemble forecasts that can be read by GSI} \begin{tabular}{|p{1.7cm}|p{4cm}|p{4.6cm}|p{4cm}|} \hline \hline regional\_ ensemble\_ option & explanation & Function called & GSI recognized ensemble file names \\ \hline -1 & GFS ensemble internally interpolated to hybrid grid & get\_gefs\_for\_regional & \textit{filelist : a text file including path and name of ensemble files} \\ +1 & GFS ensemble internally interpolated to hybrid grid & get\_gefs\_for\_regional & \textit{filelist : a text file including the path and name of ensemble files} \\ \hline -2 & ensembles are WRF NMM (HWRF) format & get\_wrf\_nmm\_ensperts & +2 & Ensemble is in WRF-NMM (HWRF) format & get\_wrf\_nmm\_ensperts & \textit{d01\_en001},\newline \textit{d01\_en002},\newline ... \\ \hline -3 & ensembles are ARW netcdf format & get\_wrf\_mass\_ensperts\_netcdf & +3 & Ensemble is in ARW netcdf format & get\_wrf\_mass\_ensperts\_netcdf & \textit{wrf\_en001}, \newline \textit{wrf\_en002}, \newline ... \\ \hline -4 & ensembles are NEMS NMMB format & get\_nmmb\_ensperts & +4 & Ensemble is in NMMB format & get\_nmmb\_ensperts & \textit{nmmb\_ens\_mem001},\newline \textit{nmmb\_ens\_mem002},\newline ...\\ \hline @@ -1060,7 +1059,7 @@ \section{Introduction to GSI 3D Hybrid EnVar Analysis} \end{table} -Users have to change the GSI run script to add the links to the ensemble forecasts if they want to use the GSI hybrid function. Below is an example of using ensembles of ARW netcdf format, assuming that all the ensemble members are located in a directory defined by the parameter \textit{\${mempath}} and the ensemble members have a name such as: \textit{wrfout\_d01\_\${iiimem}}, where \textit{\${iiimem}} is an integer indicating the ensemble member ID. The following lines should be added to the run script with loop \textit{iiimem} from 1 to the total number of ensemble members: +Users have to change the GSI run script to add the links to the ensemble forecasts if they want to use the GSI hybrid function. Below is an example of using an ensemble in ARW netcdf format, assuming that all the ensemble members are located in a directory defined by the parameter \textit{\${mempath}} and the ensemble members have a name such as: \textit{wrfout\_d01\_\${iiimem}}, where \textit{\${iiimem}} is an integer indicating the ensemble member ID. The following lines should be added to the run script with loop \textit{iiimem} from one to the total number of ensemble members: \begin{scriptsize} \begin{verbatim} @@ -1074,23 +1073,23 @@ \section{Introduction to GSI 3D Hybrid EnVar Analysis} \item \textit{Change 2: Set up the namelist options in section HYBRID\_ENSEMBLE}\\ -Users need to set \verb|l_hyb_ens=.true.| to turn on hybrid ensemble analysis. Commonly used namelist options for the hybrid analysis are listed in table \ref{tab52}: +Users need to set \verb|l_hyb_ens=.true.| to turn on the hybrid ensemble analysis. Commonly used namelist options for the hybrid analysis are listed in table \ref{tab52}: \begin{table}[htbp] \centering -\caption{the list of namelist options for GSI hybrid} +\caption{The list of namelist options for GSI hybrid} \begin{tabular}{|p{3cm}|p{11cm}|} \hline -Options & explanation \\ +Options & explanation \\ \hline -l\_hyb\_ens & if true, turn on hybrid ensemble option; \\ +l\_hyb\_ens & if true, turn on hybrid ensemble option \\ \hline uv\_hyb\_ens & if true, ensemble perturbation wind variables are u and v; \newline -otherwise, ensemble perturbation wind variables are stream function and velocity potential functions. \\ +otherwise, ensemble perturbation wind variables are stream function and velocity potential \\ \hline -generate\_ens & if true, generate internal ensemble based on existing background error; recommended to be false. \\ +generate\_ens & if true, generate an internal ensemble based on the existing background error; recommended = false \\ \hline -n\_ens & number of ensemble members. \\ +n\_ens & number of ensemble members \\ \hline beta1\_inv& (1/beta1), the weight given to the static background error covariance. 0 <= beta1\_inv <= 1, should be tuned for optimal performance; beta2\_inv = 1 - beta1\_inv is the weight given to the ensemble derived covariance \newline =1, ensemble information turned off \newline @@ -1098,18 +1097,18 @@ \section{Introduction to GSI 3D Hybrid EnVar Analysis} \hline s\_ens\_h & homogeneous isotropic horizontal ensemble localization scale (km) \\ \hline -s\_ens\_v & vertical localization scale. \newline +s\_ens\_v & vertical localization scale \newline If positive, in grid units; \newline -if negative, in lnp unit. \\ +if negative, in lnp unit \\ \hline regional\_ensemble\newline -\_option & integer, used to select type of ensemble to read in for regional applications. Currently takes values from 1 to 4: \newline +\_option & integer, used to select the type of ensemble to read in for regional applications. Currently takes values from one to four: \newline =1: use GEFS internally interpolated to ensemble grid; \newline - =2: ensembles are in WRF NMM format; \newline + =2: ensembles are in WRF-NMM format; \newline =3: ensembles are in ARW netcdf format; \newline - =4: ensembles are in NEMS NMMB format. \\ + =4: ensembles are in NMMB format. \\ \hline -grid\_ratio\_ens & for regional runs, ratio of ensemble grid resolution to analysis grid resolution. If turned on and specified an appropriate value, could increase the computational efficiency. \\ +grid\_ratio\_ens & for regional runs, the ratio of ensemble to analysis grid resolution. If turned on and specified with an appropriate value, this could increase the computational efficiency. \\ \hline \end{tabular} \label{tab52} @@ -1117,14 +1116,53 @@ \section{Introduction to GSI 3D Hybrid EnVar Analysis} Please note: the parameters \verb|s_ens_h|, \verb|s_ens_v|, and \verb|beta1_inv| are tunable parameters. They should be tuned for best performance.\\ -After setup of the namelist parameters and the path and name of the ensemble members, GSI can be run following the other 3DVAR cases introduced in this chapter. And the same procedures could be followed as in the previous sections to check the run status and diagnose the GSI analysis. +After setting up the namelist parameters and the path/name of the ensemble members, GSI can be run in the same manner as the other 3DVAR cases introduced in this chapter. The same procedures could be followed as in the previous sections to check the run status and diagnose the GSI analysis. \end{itemize} +\newpage +%------------------------------------------------------------------------------- +\section{Introduction to GSI Hybrid 4DEnVar Analysis} +%------------------------------------------------------------------------------- + +The GSI hybrid 4DEnVAR analysis is similar to the hybrid 3DEnVar except that the hybrid 4DEnVar will use multiple background files and GFS ensemble forecasts. As an example, the following shows how to conduct a hybrid 4DEnVar analysis using three time levels of background files and ensembles. + +Before creating a hybrid 4DEnVar analysis, be sure to read the previous section about how to run hybrid 3DEnVar first. The following steps are additional procudures beyond hybrid 3DEnVar and assume that all hybrid 3DEnVar settings have already been set. + +(1). Set \textit{if\_4DEnVar=Yes} in \textit{run\_gsi\_regional.ksh}. + +(2). Set the correct background files and ensemble files at different time levels in \textit{run\_gsi\_regional.ksh}. See the following example: +\begin{scriptsize} +\begin{verbatim} + if [ ${if_4DEnVar} = Yes ] ; then + BK_FILE_P1=${BK_ROOT}/wrfout_d01_2017-05-13_19:00:00 + BK_FILE_M1=${BK_ROOT}/wrfout_d01_2017-05-13_17:00:00 + + ENSEMBLE_FILE_mem_p1=${ENS_ROOT}/sfg_2017051312_fhr09s + ENSEMBLE_FILE_mem_m1=${ENS_ROOT}/sfg_2017051312_fhr03s + fi +\end{verbatim} +\end{scriptsize} + + Note that the background file at the analysis time (201705131800 for the above example) is set by \textit{BK\_FILE} and the ensemble files at the analysis time are set by \textit{ENSEMBLE\_FILE\_mem} as introduced in previous sections. See the following example: + +\begin{scriptsize} +\begin{verbatim} + BK_FILE=${BK_ROOT}/wrfout_d01_2017-05-13_18:00:00 + ... + if [ ${if_hybrid} = Yes ] ; then + ... + ENSEMBLE_FILE_mem=${ENS_ROOT}/sfg_2017051312_fhr06s + ... +\end{verbatim} +\end{scriptsize} + +Now GSI can be run following the hybrid 3DEnVar case introducted in the prevous section. Similar procedures can be conducted to check the GSI run status and results. + %------------------------------------------------------------------------------- \section{Summary} %------------------------------------------------------------------------------- -This chapter applied the knowledge from the previous chapters to demonstrate how to set up, run, and analyze GSI for various regional applications. It is important to always check for successful GSI analysis, as running to completion does not always indicate a successful run. Using the tools and methods described in this chapter, a complete picture of the GSI analysis can be obtained. +This chapter applied previous information outlined in the user\textquotesingle s guide to demonstrate how to set up, run, and analyze GSI for various regional applications. It is important to always check for a successful GSI analysis, as running to completion does not always indicate a successful analysis was generated. Using the tools and methods described in this chapter, a complete picture of the GSI analysis can be obtained. -It is important to realize that GSI applications are not limited to regional analysis with WRF. Other GSI applications, including the global analysis for GFS, the chemical analysis, and others will be introduced in the next chapter . +It is important to realize that GSI applications are not limited to regional analyses with WRF. Other GSI applications, including global analyses for GFS, chemical analyses, and others will be introduced in the next chapter. diff --git a/doc/GSI_user_guide/gsi_ch6.tex b/doc/GSI_user_guide/gsi_ch6.tex index 98bab48e5..b6905ed27 100644 --- a/doc/GSI_user_guide/gsi_ch6.tex +++ b/doc/GSI_user_guide/gsi_ch6.tex @@ -1,4 +1,4 @@ -\chapter{Introduction to more GSI Applications} +\chapter{Introduction to more GSI Applications}\label{gsi_global} \setlength{\parskip}{12pt} %------------------------------------------------------------------------------- @@ -6,13 +6,13 @@ \section{Introduction to Global GSI analysis} %------------------------------------------------------------------------------- The \textit{Global Forecast System (GFS)} is a global numerical weather prediction system containing a global computer model and variational analysis -run by the U.S. National Weather Service (NWS). As of February 2015, the mathematical model is run four times a day, and produces forecasts for up -to 16 days in advance, with decreased spatial resolution after 10 days. The model is a spectral model with a resolution of T1534 from 0 to 240 hours +run by the U.S. National Weather Service (NWS). As of February 2015, the numerical model is run four times a day, and produces forecasts for up +to 16 days in advance, with decreased spatial resolution after 10 days. It is a spectral model with a resolution of T1534 from 0 to 240 hours (0-10 days) and T574 from 240 to 384 hours (10-16 days). In the vertical, the model is divided into 64 layers and temporally, it produces forecast output every hour for the first 12 hours, every 3 hours out to 10 days, and every 12 hours after that. Its data assimilation system runs 6-hourly continuous cycles using the GSI-hybrid. -GSI has many functions specially designed and tuned for GFS. Although the release version of the community GSI includes all the functions used by the +GSI has many functions specifically designed and tuned for GFS. Although the release version of the community GSI includes all the functions used by the operational systems, the DTC can only support the GSI regional applications because the DTC is not able to run GFS on community computers. Beginning with release version 3.2, the DTC began to introduce the use of GSI for global applications, assuming users can obtain the GFS background through the NCEP data hub or by running GFS themselves. @@ -22,21 +22,20 @@ \subsection{The Difference between Global and Regional GSI} %------------------------------------------------------------------------------- As mentioned above, all of the NCEP operational systems use GSI as their analysis system. The majority of the GSI code is common to these -operational systems. Very little of the source code is specific to a particular operational system. The main differences in GSI operational application +operational systems. Very little source code is specific to a particular operational system. The main differences in the GSI operational application come from the configuration the run scripts and namelist parameters. The different GSI applications need different backgrounds, observations, and fixed files. For the GFS system, GSI needs: \begin{itemize} -\item GFS Backgrounds: typically, GSI uses 6-h GFS forecasts as the background. GFS 3-h and 9-h forecasts are also needed for the FGAT function in +\item GFS Backgrounds: Typically, GSI uses 6-h GFS forecasts as the background. GFS 3-h and 9-h forecasts are also needed for the FGAT function in the GSI analysis. Both surface and atmosphere forecasts are needed. -\item Observations: NCEP has several sets of BUFR/PrepBUFR observations files with global coverage for global systems. The files that start with the +\item Observations: NCEP has several sets of BUFR/prepBUFR observation files with global coverage for global systems. The files that start with the prefix \textbf{GDAS} are for the 6-hourly global data assimilation system. These files have more data available for the analysis, but have a longer delay -for use in real-time. The files that start with \textbf{gfs} are for the 4 time daily GFS forecast. The different operational systems need different observation -data files because they require different kinds of observations with different coverage, cut-off times, and quality control processes. All these observation +for use in real-time. The files that start with \textbf{gfs} are for the GFS forecasts. Different operational systems need different observation data files because they require different kinds of observations with different coverage, cut-off times, and quality control processes. All these observation files are read in and processed in GSI by the same section of code. Therefore, there is no problem using GFS observation data files for regional GSI applications, as is described in the practice cases and the GSI User\textquotesingle s Guide. Using regional BUFR files for global applications will cause -scientific problems since the data only covers part of the analysis domain, but GSI can still read in the observations and perform the analysis. +problems since the data only cover part of the analysis domain, but GSI can still read in the observations and perform the analysis. \item Fixed files: Section 3.1 of the GSI User\textquotesingle s Guide introduced the notion that different operational systems have their own fixed files. These global fixed files can be downloaded as a separate tar ball from the GSI user\textquotesingle s website (\url{http://www.dtcenter.org/com-GSI/users/downloads/index.php}). For the GFS GSI application, the big difference is the background error covariance (BE). @@ -67,7 +66,7 @@ \subsection{Global GFS Scripts} \begin{table}[htbp] \centering -\caption{The grid dimensions for GFS} +\caption{The grid dimensions for GFS.} \begin{tabular}{|p{3cm}|p{4.5cm}|p{4.45cm}|} \hline &EULERIAN&SEMI-LAGRANGIAN\\ @@ -107,14 +106,14 @@ \subsection{Global GFS Scripts} \end{table} The first part of the global analysis run script, just as in the regional script, sets up the computer environment and case configuration. The primary -differences between the global and regional are the specification of the GFS case and the global application namelist. +differences between the global and regional scripts are the specification of the GFS case and the global application namelist. \begin{small} \begin{verbatim} GFSCASE=T126 GSI_NAMELIST=${GSI_ROOT}/run/comgsi_namelist_gfs.sh \end{verbatim} \end{small} -While the regional script simply specifies the background and BE files, the global script needs to know the background resolution setup by defining the +While the regional script simply specifies the background and BE files, the global script needs to know the background resolution by defining the following parameters: \begin{scriptsize} \begin{verbatim} @@ -144,7 +143,7 @@ \subsection{Global GFS Scripts} \end{verbatim} \end{scriptsize} -Just as with the regional analysis run script, the global script double checks the needed parameters, creates a run directory, copies the background, observations, and fixed files into the run directory. It generates the namelist, and places that in the run directory as well. +Just as with the regional analysis run script, the global script double checks the needed parameters, creates a run directory, and copies the background, observations, and fixed files into the run directory. It generates the namelist, and places it in the run directory as well. \begin{enumerate} \item Specify the values of \verb|LATA|, \verb|LONA|, \verb|DELTIME|, \verb|resol| based on the choice of \verb|JCAP|: \begin{scriptsize} @@ -257,9 +256,9 @@ \subsection{Global GFS Scripts} fi \end{verbatim} \end{scriptsize} -Both surface and atmosphere files at 03, 06, 09 hour forecasts are needed. \\ -\item More observations files are available\\ -In the sample run script, many more observations are listed for use: +Both surface and atmosphere files at 03, 06, and 09 hour forecasts are needed. \\ +\item More observations files are available\\ +In the sample run script, many more observations are listed for use: \begin{scriptsize} \begin{verbatim} # Link to the other observation data @@ -340,12 +339,10 @@ \subsection{Sample Results} \end{verbatim} \end{scriptsize} -The majority of these files were seen after running the GSI regional analysis examples in section \ref{sec3.2.3} of the Basic User\textquotesingle s +The majority of these files existed after running the GSI regional analysis examples in section \ref{sec3.2.3} of the Basic User\textquotesingle s Guide, and they provide the same information about the GSI run. Of note, the GSI global analysis run includes more radiance observations, resulting -in more radiance \verb|diag| files in this list. Instead of the single background file \verb|wrf_inout| as seen with the regional analysis, the global analysis -background is split between the two files \verb|siganl|, for atmosphere, and \verb|sfcanl.gsi| for the surface. A quick check of the standard output file -\verb|stdout| shows information similar to that generated by the regional runs for the namelist, data ingest, and minimization, but is quite different with -respect to information on the background IO. +in more radiance \verb|diag| files in this list. Instead of the single background file \verb|wrf_inout| as seen with the regional analysis, the global analysis background is split between the two files \verb|siganl|, for the atmosphere, and \verb|sfcanl.gsi| for the surface. A quick check of the standard output file +\verb|stdout| shows information similar to that generated by the regional runs for the namelist, data ingest, and minimization, but is quite different with respect to information on the background IO. Please visit our online tutorial for more details regarding how to conduct a global GSI run. @@ -353,7 +350,7 @@ \subsection{Sample Results} \section{Introduction to Chemical Analysis} %------------------------------------------------------------------------------- -The GSI has been developed to analyze chemical observations, such as MODIS AOD or PM2.5, to improve the pollution forecast with chemical models. +The GSI has also been developed to analyze chemical observations, such as MODIS AOD or PM2.5, to improve the pollution forecasts with chemical models. In this release, GSI can do the following chemical analyses: \begin{table}[htbp] @@ -375,7 +372,7 @@ \section{Introduction to Chemical Analysis} \label{tab62} \end{table} -The GSI run scripts for chemical analysis (\verb|./run/run_gsi_chem.ksh| ) and namelist (\verb|./run/comgsi_namelist_chem.sh|) are provided with this release. +The GSI run script for a chemical analysis (\verb|./run/run_gsi_chem.ksh| ) and associated namelist (\verb|./run/comgsi_namelist_chem.sh|) are provided with this release. Sample background and observation files are provided through the on-line tutorial. %------------------------------------------------------------------------------- @@ -383,10 +380,10 @@ \subsection{Setup GSI Run Scripts for Chemical Analysis} %------------------------------------------------------------------------------- The script \verb|run_gsi_chem.ksh| was built based on regional GSI run scripts and has a similar structure to the regional run script \verb|run_gsi_regional.ksh|, -but include a couple of different details. +but include a couple of differences. -The first part of the run script sets up the computer environment and case configuration. This is the similar to the regional analysis run scripts, except -for the specification of the chemical cases (\verb|bk_core| and \verb|obs_type|), and the namelist for the chemical application: +The first part of the run script sets up the computer environment and case configuration. This is similar to the regional analysis run scripts, except +for the specification of (\verb|bk_core| and \verb|obs_type|) for a given chemical case, and the namelist for the chemical application: \begin{scriptsize} \begin{verbatim} GSI_NAMELIST=${GSI_ROOT}/run/comgsi_namelist_chem.sh @@ -398,13 +395,12 @@ \subsection{Setup GSI Run Scripts for Chemical Analysis} obs_type=PM25 \end{verbatim} \end{scriptsize} -The choice of the chemical cases (\verb|bk_core| and \verb|obs_type|) need to match with the options \verb|PREPBUFR| and \verb|BK_FILE|, which -set background and observation files. Table \ref{tab63} shows how to setup these two options for each case: +The choices of (\verb|bk_core| and \verb|obs_type|) for a chemical case need to match with the options \verb|PREPBUFR| and \verb|BK_FILE|, which set background and observation files. Table \ref{tab63} shows how to set up these two options for each case: \begin{table}[htbp] \centering \begin{footnotesize} -\caption{List of GSI chemical analyses} +\caption{List of GSI chemical analyses.} \begin{tabular}{|p{0.7cm}|p{7cm}|p{7cm}|} \hline case&background (\textit{BK\_FILE} ; \textit{bk\_core} ) & Observation (\textit{PREPBUFR}; \textit{obs\_type})\\ @@ -425,10 +421,7 @@ \subsection{Setup GSI Run Scripts for Chemical Analysis} \label{tab63} \end{footnotesize} \end{table} -Similar to the regional run script, this chemical run script will also double check the needed parameters. Then it creates a run directory and generates -the namelist in the directory and copies the background, observations, and fixed files into the run directory. Users who run the cases listed in table -\ref{tab62} do not need to change the rest of the run scripts. But users who need to build new cases may need to know the differences between -chemical and regional applications, which is shown below. +Similar to the regional run script, this chemical run script will also double check the needed parameters. Then it creates a run directory, generates the namelist, and copies the background, observations, and fixed files into the run directory. Users who run the cases listed in table \ref{tab62} do not need to change the rest of the run script. But users who need to build new cases may need to know the differences between chemical and regional applications, which is shown below. \begin{enumerate} \item Specify the name of the background and observations: @@ -507,7 +500,7 @@ \subsection{Setup GSI Run Scripts for Chemical Analysis} \subsection{Sample Results} %------------------------------------------------------------------------------- -In this section, the case 1 in Table \ref{tab62} will be used as example. After a successful run of the GSI Chem analysis, the contents of the run directory, with the clean option turned on, will look something like this: +In this section, case one in Table \ref{tab62} will be used as an example. After a successful run of the GSI Chem analysis, the contents of the run directory, with the clean option turned on, will look something like this: \begin{scriptsize} \begin{verbatim} aeroinfo fit_w1.2012060318 fort.212 fort.226 pcpinfo @@ -525,10 +518,10 @@ \subsection{Sample Results} \end{verbatim} \end{scriptsize} -Following the instruction in Chapter 5, the following steps are conducted to check the results of this GSI chemical analysis: +Following instructions from Chapter 5, the following steps are conducted to check the results of this GSI chemical analysis: \begin{enumerate} -\item Check stdout file: \\ +\item Check the standard output file: \\ \begin{itemize} \item Read in chemical background fields: @@ -612,19 +605,12 @@ \subsection{Sample Results} \end{itemize} \item Analysis increments: -After successfully run through, the analysis increment should be check the see if the data impact are reasonable. +After successfully running GSI, the analysis increments should be checked to see if data impacts are reasonable. \begin{figure}[h!] \centering \includegraphics[width=0.8\textwidth]{./images/ch6_chem_inc_seas1_bc1.png} - \caption{The analysis increment in the lowest level for SEAS\_1 (left) and BC1 (right)} + \caption{Analysis increments in the lowest level for SEAS\_1 (left) and BC1 (right).} \label{fig:chem} \end{figure} - \end{enumerate} - - - - - - diff --git a/doc/GSI_user_guide/images/CostGrad.png b/doc/GSI_user_guide/images/CostGrad.png new file mode 100644 index 000000000..2e34def1f Binary files /dev/null and b/doc/GSI_user_guide/images/CostGrad.png differ diff --git a/doc/GSI_user_guide/images/CostGrad_Ch5.png b/doc/GSI_user_guide/images/CostGrad_Ch5.png new file mode 100644 index 000000000..b7c82d621 Binary files /dev/null and b/doc/GSI_user_guide/images/CostGrad_Ch5.png differ diff --git a/doc/GSI_user_guide/images/DTClogo.png b/doc/GSI_user_guide/images/DTClogo.png new file mode 100644 index 000000000..69c792b34 Binary files /dev/null and b/doc/GSI_user_guide/images/DTClogo.png differ diff --git a/doc/GSI_user_guide/images/GSIbanner.png b/doc/GSI_user_guide/images/GSIbanner.png new file mode 100644 index 000000000..b18bbbe6b Binary files /dev/null and b/doc/GSI_user_guide/images/GSIbanner.png differ diff --git a/doc/GSI_user_guide/images/SingleObs.png b/doc/GSI_user_guide/images/SingleObs.png new file mode 100644 index 000000000..67332e424 Binary files /dev/null and b/doc/GSI_user_guide/images/SingleObs.png differ diff --git a/doc/GSI_user_guide/images/ch4_fig1.pdf b/doc/GSI_user_guide/images/ch4_fig1.pdf new file mode 100644 index 000000000..d76a4f44e Binary files /dev/null and b/doc/GSI_user_guide/images/ch4_fig1.pdf differ diff --git a/doc/GSI_user_guide/images/ch4_fig2.pdf b/doc/GSI_user_guide/images/ch4_fig2.pdf new file mode 100644 index 000000000..308541082 Binary files /dev/null and b/doc/GSI_user_guide/images/ch4_fig2.pdf differ diff --git a/doc/GSI_user_guide/images/ch5_fig1.pdf b/doc/GSI_user_guide/images/ch5_fig1.pdf new file mode 100644 index 000000000..57d563c85 Binary files /dev/null and b/doc/GSI_user_guide/images/ch5_fig1.pdf differ diff --git a/doc/GSI_user_guide/images/ch5_fig_analysisincrement.pdf b/doc/GSI_user_guide/images/ch5_fig_analysisincrement.pdf new file mode 100644 index 000000000..590539d41 Binary files /dev/null and b/doc/GSI_user_guide/images/ch5_fig_analysisincrement.pdf differ diff --git a/doc/GSI_user_guide/images/ch5_fig_analysisincrement_prepbufr.pdf b/doc/GSI_user_guide/images/ch5_fig_analysisincrement_prepbufr.pdf new file mode 100644 index 000000000..72d263623 Binary files /dev/null and b/doc/GSI_user_guide/images/ch5_fig_analysisincrement_prepbufr.pdf differ diff --git a/doc/GSI_user_guide/images/ch5_fig_analysisincrement_prepbufr2.pdf b/doc/GSI_user_guide/images/ch5_fig_analysisincrement_prepbufr2.pdf new file mode 100644 index 000000000..a9da885a4 Binary files /dev/null and b/doc/GSI_user_guide/images/ch5_fig_analysisincrement_prepbufr2.pdf differ diff --git a/doc/GSI_user_guide/images/ch5_fig_analysisincrement_prepbufr_lvl48.pdf b/doc/GSI_user_guide/images/ch5_fig_analysisincrement_prepbufr_lvl48.pdf new file mode 100644 index 000000000..64c3f908b Binary files /dev/null and b/doc/GSI_user_guide/images/ch5_fig_analysisincrement_prepbufr_lvl48.pdf differ diff --git a/doc/GSI_user_guide/images/ch5_fig_costfunct.pdf b/doc/GSI_user_guide/images/ch5_fig_costfunct.pdf new file mode 100644 index 000000000..7deb5ef8d Binary files /dev/null and b/doc/GSI_user_guide/images/ch5_fig_costfunct.pdf differ diff --git a/doc/GSI_user_guide/images/ch6_chem_inc_seas1_bc1.png b/doc/GSI_user_guide/images/ch6_chem_inc_seas1_bc1.png new file mode 100644 index 000000000..dfd7805a9 Binary files /dev/null and b/doc/GSI_user_guide/images/ch6_chem_inc_seas1_bc1.png differ diff --git a/doc/GSI_user_guide/images/gsibanner.pdf b/doc/GSI_user_guide/images/gsibanner.pdf new file mode 100644 index 000000000..fa1e05493 Binary files /dev/null and b/doc/GSI_user_guide/images/gsibanner.pdf differ diff --git a/doc/GSI_user_guide/images/increments.png b/doc/GSI_user_guide/images/increments.png new file mode 100644 index 000000000..eaa652bb6 Binary files /dev/null and b/doc/GSI_user_guide/images/increments.png differ diff --git a/doc/GSI_user_guide/images/increments_bufr.png b/doc/GSI_user_guide/images/increments_bufr.png new file mode 100644 index 000000000..13da2015b Binary files /dev/null and b/doc/GSI_user_guide/images/increments_bufr.png differ diff --git a/doc/GSI_user_guide/images/increments_rad.png b/doc/GSI_user_guide/images/increments_rad.png new file mode 100644 index 000000000..c274a1c93 Binary files /dev/null and b/doc/GSI_user_guide/images/increments_rad.png differ diff --git a/doc/GSI_user_guide/images/increments_rad2.png b/doc/GSI_user_guide/images/increments_rad2.png new file mode 100644 index 000000000..047ac6b14 Binary files /dev/null and b/doc/GSI_user_guide/images/increments_rad2.png differ diff --git a/doc/GSI_user_guide/images/landmask.png b/doc/GSI_user_guide/images/landmask.png new file mode 100644 index 000000000..439fef9f0 Binary files /dev/null and b/doc/GSI_user_guide/images/landmask.png differ diff --git a/doc/GSI_user_guide/images/terrain.png b/doc/GSI_user_guide/images/terrain.png new file mode 100644 index 000000000..fa11351ee Binary files /dev/null and b/doc/GSI_user_guide/images/terrain.png differ diff --git a/doc/GSI_user_guide/references.bib b/doc/GSI_user_guide/references.bib index be2b1c7e2..17de7ed32 100644 --- a/doc/GSI_user_guide/references.bib +++ b/doc/GSI_user_guide/references.bib @@ -19,7 +19,7 @@ @article{Gaspari1999 author={G. Gaspari and S. E. Cohn}, journal={Quarterly Journal of the Royal Meteorological Society}, volume={125}, - Issue={554} + Issue={554}, pages={723-757}, year={1999}, } diff --git a/doc/GSI_user_guide/title.tex b/doc/GSI_user_guide/title.tex index f1d41cd13..7741a66dd 100644 --- a/doc/GSI_user_guide/title.tex +++ b/doc/GSI_user_guide/title.tex @@ -8,19 +8,21 @@ \includegraphics[width=0.8\textwidth]{images/GSIbanner.png}\\[2em] {\color{darkcerulean} - \Huge{User's Guide Version 3.5 }\\[1em] - \normalsize{August 2016}\\[5em] + \Huge{User's Guide Version 3.7}\\[1em] + \normalsize{September 2017}\\[5em] } % \normalsize{by}\\[1em] - \normalsize{Ming Hu}\\ + \normalsize{Ming Hu, Guoqing Ge}\\ \textit{\small{National Oceanic and Atmospheric Administration (NOAA)/Earth System Research Laboratory}}\\ \textit{\small{Cooperative Institute for Research in Environmental Sciences (CIRES)}}\\[2em] \normalsize{Hui Shao, Don Stark, Kathryn Newman, Chunhua Zhou}\\ \textit{\small{National Center for Atmospheric Research (NCAR)}}\\[2em] + \normalsize{Jeff Beck}\\ + \textit{\small{NOAA/Earth System Research Laboratory and CIRA}}\\[2em] \normalsize{Xin Zhang}\\ - \textit{\small{NOAA/Earth System Research Laboratory and CIRES}}\\[4em] - + \textit{\small{University Corporation for Atmospheric Research (UCAR)}}\\[2em] + \includegraphics[width=0.5\textwidth]{images/DTClogo.png}\\ \vspace{1em} diff --git a/doc/README.discover b/doc/README.discover new file mode 100644 index 000000000..fdd030d53 --- /dev/null +++ b/doc/README.discover @@ -0,0 +1,36 @@ +Building GSI on Discover +------------------------ + +(0) cd /path/to/ProdGSI +(1) set build environment + > module use -a modulefiles + > module load modulefile.ProdGSI.discover +(2) mkdir bld && cd bld +(3) cmake .. +(4) make -jN + + +Running GSI regression tests +---------------------------- + +(1) For running regression tests, the local of the control version of + gsi_global.x needs to be defined. This can be achieved in one two (2) + ways: + + (a) If the location of the control exe is known at build time, gsi can be + built using + > cmake -DCONTROL_EXE=/path/to/control/gsi_global.x .. + + (b) If gsi was built without specifying the location of the control exe, + i.e. via "cmake ..", location of control exe can be specified in + bld/regression_var.out by replacing the string CONTROL_EXE-NOTFOUND by + the full path to the gsi executable. + +(2) The file bld/CTestTestfile.cmake needs to be modified to exclude the test + global_nemsio_T62 as it is not supported on Discover, yet. + +(3) The regression tests can then be run, in parallel, via + > ctest -j4 + + This will run all the tests. Individual tests can be run using the -R flag + > ctest -R diff --git a/doc/Release_Notes.fv3gfs_da.v15.0.0.txt b/doc/Release_Notes.fv3gfs_da.v15.0.0.txt new file mode 100644 index 000000000..0116190ac --- /dev/null +++ b/doc/Release_Notes.fv3gfs_da.v15.0.0.txt @@ -0,0 +1,303 @@ +FV3GFS DA RELEASE NOTES (v15.0.0) + +GIT TAG + * The FV3GFS DA is in NOAA VLAB gerrit:ProdGSI. The FV3GFS DA tag is intended to be installed + as part of the entire FV3GFS package. Please see FV3GFS release notes for name and location + of FV3GFS tag in NOAA VLAB gerrit. The FV3GFS tag contains a checkout script which checks out + the appropriate FV3GFS DA tag. + + + + +DOC CHANGES + * Combine Release_Notes.gdas_da.v14.1.0.txt, Release_Notes.gfs_da.v14.1.0.txt, and + Release_Notes.global_shared_da.v14.1.0.txt into this document. Update for FV3GFS DA component of + FV3GFS package. + + + + +CODE CHANGES + * Data assimilation changes (global_gsi.x and global_enkf.x) + * Infrared Atmospheric Sounding Interferometer (IASI) moisture channels + * Advanced Technology Microwave Sounder (ATMS) all-sky radiances + * A fix for an issue with the Near Sea Surface Temperature (NSST) in the Florida Strait + * An upgrade to the use of Cross-track Infrared Sounder (CrIS) radiances + * Addition of NOAA-20 CrIS and ATMS data + * Addition of Megha-Tropiques SAPHIR data + * Addition of Advanced Scatterometer (ASCAT) data from MetOp-B + * The analysis and the ensemble will increase in horizontal resolution from 35 km to 25 km. + * The analysis nemsio file contains layer pressure (dpres) and layer height (delz), whose analysis increments + are computed hydrostatically from the temperature and surface pressure increments. + * The analysis nemsio file contains cloud liquid water (clwmr) and cloud ice (icmr), partitioned from the + total cloud condensate analysis. + * The analysis nemsio file contains vertical velocity (dzdt), rain (rwmr), snow (snmr), and graupel (grle), + which are copies of the background fields. + * New FV3GFS DA code + * calc_increment_ens.fd - compute analysis increment used to warm start FV3GFS model + + + +JOB CHANGES + * Update jobs to run within FV3GFS workflow + * JGDAS_ANALYSIS_HIGH and JGFS_ANALYSIS have been merged into a single job, JGLOBAL_ANALYSIS. + Job JGLOBAL_ANALYSIS runs in both the GFS and GDAS cycle. + * The following jobs have been renamed + * JGDAS_ENKF_SELECT_OBS --> JGLOBAL_ENKF_SELECT_OBS + * JGDAS_ENKF_INNOVATE_OBS --> JGLOBAL_ENKF_INNOVATE_OBS + * JGDAS_ENKF_UPDATE --> JGLOBAL_ENKF_UPDATE + * JGDAS_ENKF_INFLATE_RECENTER --> JGDAS_ENKF_RECENTER + * Neither the merging of GFS and GDAS analysis jobs into one nor the renaming of the GDAS EnKF jobs + changes workflow dependencies. + + + +SCRIPT CHANGES + * Update scripts to run within FV3GFS workflow. + * The string "fv3gfs" has been added to the name of FV3GFS DA scripts to distinguish them from their non-FV3GFS + counterparts. For example, exglobal_analysis.sh.ecf is renamed exglobal_analysis_fv3gfs.sh.ecf in the + FV3GFS package. Below is a mapping between current operational GFS DA scripts and their FV3GFS DA + counterparts + * exglobal_analysis.sh.ecf --> exglobal_analysis_fv3gfs.sh.ecf + * exglobal_enkf_innovate_obs.sh.ecf --> exglobal_innovate_obs_fv3gfs.sh.ecf + * exglobal_enkf_update.sh.ecf --> exglobal_enkf_update_fv3gfs.sh.ecf + * exglobal_enkf_inflate_recenter.sh.ecf --> exglobal_enkf_recenter_fv3gfs.sh.ecf + * exglobal_enkf_fcst_nems.sh.ecf --> exglobal_enkf_fcst_fv3gfs.sh.ecf + * exglobal_enkf_post.sh.ecf --> eexglobal_enkf_post_fv3gfs.sh.ecf + * Add new script: exglobal_enkf_innovate_obs_fv3gfs.sh.ecf. This script is executed from + JGLOBAL_ENKF_INNOVATE_OBS. It is a wrapper script that invokes exglobal_innovate_obs_fv3gfs.sh.ecf + for each ensemble member in the group processed by the given realization of JGLOBAL_ENKF_INNOVATE_OBS + + + +PARM CHANGES + * Update to run within FV3GFS workflow. Parm or configuration files for FV3GFS components now reside in + parm/config. Below are the parm (config) files used by each FV3GFS DA job + * JGLOBAL_ANALYSIS - config.base, config.anal + * JGLOBAL_ENKF_SELECT_OBS - config.base, config.anal, config.eobs + * JGLOBAL_ENKF_INNOVATE_OBS - config.base, config.anal, config.eobs + * JGLOBAL_ENKF_UPDATE - config.base, config.anal, config.eupd + * JGDAS_ENKF_RECENTER - config.base, config.ecen + * JGDAS_ENKF_FCST - config.base, config.fcst, config.efcs + * JGDAS_ENKF_POST - config.base, config.epos + Parameters common to all jobs are in config.base. Analysis jobs share config.anal. This avoids + duplication of identical parameters across multiple parameter files. + + +FIX CHANGES + * Updates to run FV3GFS DA + * New files / directory + * cloudy_radiance_info.txt - new file for all-sky radiance assimilation + * Big_Endian/global_berror.l64y770.f77 - add for use in JGLOBAL_ANALYSIS + * Add directory fv3_historical to contain historical global_convinfo and global_satinfo files + * Modify existing files + * global_anavinfo.l64.txt - add EnKF control vector section + * global_convinfo.txt - assimilate uv 290, monitor gps 825 + * global_ozinfo.txt - add NPP OMPSNP in monitor mode + * global_satinfo.txt + * add columns for icloud and iaerosol + * increase AMSUA channel 15 observation error + * assimilate IASI channels 2889, 2958, 2993, 3002, 3049, 3015, 3110, 5381, 5399, 5480, + * monitor Aqua AMSUA channel 6 + * add Meteosat-11 SEVIRI + * update observation errors for NPP and N20 ATMS + * remove NPP CrIS + * update N20 CrIS-FSR usage flags and observation errors + * assimilate Meghat Saphir + * global_scaninfo.txt - update atms_n20, cris_npp, cris-fsr_npp, and cris-fsr_n20 + * prepobs_errtable.global - adjust observation errors for prepbufr report types 134, 135, + 180, 181, 182, 183, 187, 234, 235, 280, 281, 282, 283, 284 285, 287 + + + +RESOURCE INFORMATION + * Frequency of run + * 6 hourly cycle (00, 06, 12, 18Z) - no change from current operations + + + * All versions of libraries, compiler, and modules used by FV3GFS DA are specified in + modulefiles/modulefile.ProdGSI.wcoss_d + + + * Data retention for files in $COMROOThps and $GESROOThps are the same as those specified for + the overall FV3GFS package + + + * Disk space. Please see disk usage estimates for entire FV3GFS package + + + * Computational resources and run times + * JGLOBAL_ANALYSIS (GFS) + * 240 nodes, 480 tasks, ptile=2, 14 threads/task + * Runtime: 26.8 minutes + + * JGLOBAL_ANALYSIS (GDAS) + * 240 nodes, 480 tasks, ptile=2, 14 threads/task + * Runtime: 30.7 minutes + + * JGLOBAL_ENKF_SELECT_OBS + * 10 nodes, 140 tasks, ptile=14, 2 threads/task + * Runtime: 3.4 minutes + + * JGLOBAL_ENKF_INNOVATE_OBS + * 10 nodes, 140 tasks, ptile=14, 2 threads/task + * Concurrently run 10 realizations of JGLOBAL_ENKF_INNOVATE_OBS. Each job processes + 8 EnKF members. Total node usage for 10 jobs x 10 nodes each = 100 nodes. + * Runtime: 15.0 minutes + + * JGLOBAL_ENKF_UPDATE + * 90 nodes, 360 tasks, ptile=4, 7 threads/task + * Runtime: 6.5 minutes + + * JGDAS_ENKF_RECENTER + * 20 nodes, 80 tasks, ptile=4, 7 threads/task + * Runtime: 4.4 minutes + + * JGDAS_ENKF_FCST + * 14 nodes, 168 tasks, ptile=12, 2 threads/task + * Concurrently run 20 realizations of JGDAS_ENKF_FCST. Each job processes 4 EnKF + members. Total node usage for 20 jobs x 14 nodes each = 280 nodes + * 20 EnKF forecast groups for FV3GFS is an increase from the 10 EnKF forecast groups + currently run in operations. + * Runtime: 19.8 minutes + + * JGDAS_ENKF_POST + * 20 nodes, 80 nodes, ptile=4, 7 threads/task + * Concurrently run 7 realizations of JGDAS_ENKF_POST. 7 forecasts processed, one + per job. Total node usage for 7 jobs x 20 nodes each = 140 nodes. + * 7 EnKF post groups is an increase from the single EnKF post job currently run in operations + * Runtime: 4.9 minutes + + + +PRE-IMPLEMENTATION TESTING REQUIREMENTS + * Which production jobs should be tested as part of this implementation? + * The FV3GFS DA package needs to tested with the entire FV3GFS suite. + + + * Does this change require a 30-day evaluation? + * Yes, the entire FV3GFS package requires a 30-day evaluation + + + * Suggested evaluators + * Same as those for entire FV3GFS package + + + +DISSEMINATION INFORMATION + * Where should this output be sent? + * same as current operations + + + * Who are the users? + * same as current operations + + + * Which output files should be transferred from PROD WCOSS to DEV WCOSS? + * Please refer to release notes for FV3GFS package + + + * Directory changes + * Add cycle to gfs and gdas paths. FV3GFS paths are $COMROOTp3/gfs/prod/gfs.$PDY/$cyc + and $COMROOTp3/gfs/prod/gdas.$PDY/$cyc. + * Add "gdas" to top level EnKF directory --> $COMROOTp3/gfs/prod/enkf.gdas.$PDY. + * Place EnKF member files in memXXX directories inside $COMROOTp3/gfs/prod/enkf.gdas.$PDY/$cyc + + + * File changes. Only FV3GFS DA file changes are listed below. + + * $COMROOTp3/gfs/prod/gfs.$PDY/$cyc + * Add + * gfs.t${cyc}z.atminc.nc - NetCDF file containing analysis increments. The FV3GFS model + uses this file to warmstart the forecast model. + * Remove + * Relocation is no longer run. Therefore, remove gdas.t${cyc}z.atm[gm2, gm1, gp1, gp2].nemsio + + * $COMROOTp3/gfs/prod/gdas.$PDY/$cyc + * Add + * gdas.t${cyc}z.atmanl.ensres.nemsio - used by JGDAS_ENKF_RECENTER + * gdas.t${cyc}z.atminc.nc - NetCDF file containing analysis increments. The FV3GFS model uses + this file to warmstart the forecast model. + * Remove + * Relocation is no longer run. Therefore, remove gdas.t${cyc}z.atm[gm2, gm1, gp1, gp2].nemsio + * gdas.t${cyc}z.nstfXXX.nemsio. NSST fields are included in FV3GFS gdas.t${cyc}z.sfcfXXX.nemsio + * gdas.t${cyc}z.sfcgcy and gdas.t${cyc}z.sfctsk. Files no longer needed given FV3GFS processing + of surface files and NSST + + * $COMROOTp3/gfs/prod/enkf.$PDY/$cyc + * Move member EnKF files into memXXX directories + * Rename + * gdas.t${cyc}z.fcsstat.grp* --> efcs.grp* + * gdas.t${cyc}z.omgstat.grp* --> eomg.grp* + * Add + * Ensemble bias correction files: gdas.t${cyc}z.[abias.air, abias, abias_int, abias_pc].ensmean + * gdas.t${cyc}z.atminc.nc - NetCDF file containing analysis increments. The FV3GFS model uses + this file to warmstart the forecast model. + * gdas.t${cyc}z.logfXXX.nemsio - FV3GFS model forecast hour log file + * Remove + * remove memXXX" from EnKF member filenames since member files are now in memXXX directories + * gdas.t${cyc}z.flxf*.nemsio - fields in this file added to FV3GFS gdas.t${cyc}z.sfcf*nemsio + * gdas.t${cyc}z.nstf*.nemsio - fields in this file file added to FV3GFS gdas.t${cyc}z.sfcf*nemsio + * gdas.t${cyc}z.gcyanl.nemsio, gdas.t${cyc}z.nstanl.nemsio, gdas.t${cyc}z.sfcanl.nemsio - + NSST processing handled differently in FV3GFS + + + + + + + + +HPSS ARCHIVE + * Retention length? + * Please refer to release notes for FV3GFS package + + + * List which output files should be archived + * Please refer to release notes for FV3GFS package + + + +IMPLEMENTATION INSTRUCTIONS + * Please note that the DA components must be installed in conjunction with the entire FV3GFS package. + Thus, the implementation instructions below extract the entire FV3GFS package. The FV3GFS package is + tagged in NOAA VLAB gerrit:fv3gfs as tag q2fy19_nco. Implementation instructions for this tag follow + below: + + 1) cd $NWROOTp3 + + 2) mkdir $NWROOTp3/gfs.v15.0.0 + + 3) cd $NWROOTp3/gfs.v15.0.0 + + 4) git clone --recursive gerrit:fv3gfs . + * Notes: + * The "." after fv3gfs is important. It tells git to clone fv3gfs into the local working directory, + $NWROOTp3/gfs.v15.0.0. + * The SPA(s) handling the FV3GFS implementation may encounter "permission denied" messages when + attempting to clone Vlab gerrit repositories. Code managers need to add the SPA(s) as project + developers. For the fv3gfs project please contact Fanglin.Yang@noaa.gov or Mark.Potts@noaa.gov. + For the FV3GFS DA project please contact Michael.Lueken@noaa.gov or Mark.Potts@noaa.gov. + + 5) git checkout q2fy19nco + + 6) cd sorc + + 7) ./checkout.sh + * This script extracts the following FV3GFS components from gerrit: FV3GFS model, FV3GFS DA, + FV3GFS UPP, FV3GFS WAFS + + 8) ./build_all.sh + * Script build_all.sh compiles all FV3GFS components. Runtime output from the build for each + package is written to log files in directory logs. Specifically, FV3GFS DA build information + is written to logs/build_gsi.log. Script build_gsi.sh invokes gsi.fd/ush/build_all_cmke.sh. + This script uses cmake to build FV3GFS DA components. Script build_all_cmake.sh accepts two + command line options: build type and directory path to package. Two build types are + supported - PRODUCTION (default) and DEBUG. + + 9) ./link_fv3gfs.sh nco dell + + + +JOB DEPENDENCIES & FLOW DIAGRAM + * No change in FV3GFS DA job dependencies with respect to current operations diff --git a/doc/Release_Notes.gdas_da.v13.0.0.txt b/doc/Release_Notes.gdas_da.v13.0.0.txt deleted file mode 100644 index cb5fcc35d..000000000 --- a/doc/Release_Notes.gdas_da.v13.0.0.txt +++ /dev/null @@ -1,233 +0,0 @@ -RELEASE NOTES: gdas_da.v6.2.3 --> gdas_da.v13.0.0 - v6.0.0 - released Jun 16, 2015 - v6.1.0 - released Oct 02, 2015 - v6.2.0 - released Oct 27, 2015 - v6.2.1 - released Nov 10, 2015 - v6.2.2 - released Dec 15, 2015 - v6.2.3 - released Jan 19, 2016 -v13.0.0 - released Feb 02, 2016 - -SVN HISTORY (see EMC GSI Trac ticket #478, EMC GFS Trac ticket #236) - * r57752 - create GLOBAL_RB.v6.0.0 as copy of r57678 trunk - * r57803 - revise build to use modulefile - * r57804 - update gdas, gfs, and global_shared directory version numbers - * r57808 - commit release notes - * r59582 - merge r59495 GSI trunk into GLOBAL_RB.v6.0.0 - * r59583 - update SVN HISTORY in release notes - * r59587 - restore r57803 Makefile.conf.wcoss - * r59595 - first attempt at refactoring JGFS_ANALYSIS to be consistent with NCO WCOSS implementation standards - * r60327 - merge r59731 and r60129 trunk into GLOBAL_RB.v6.0.0 - * r60342 - update SVN HISTORY in release notes - * r60354 - update version numbers to crtm.v2.2.3 and bufr.v11.0.0. crtm.v2.2.3 added to GSI trunk at r60393 - * r60360 - refactor JGDAS_ANALYSIS_HIGH in accord with NCO WCOSS implementation standards - * r60540 - refactor jobs and scripts in accord with NCO WCOSS implementation standards - * r60678 - update SVN HISTORY in release notes; update jobs and scripts to use nwtest2 CRTM v2.2.3 - * r60681 - turn off dissipative heating in EnKF forecast - * r60682 - update SVN HISTORY (add r60678 and r60681) - * r60807 - update SVN HISTORY; correct typo in Release_Notes.gdas_da.v6.0.0.txt - * r60831 - update SVN HISTORY; additional NCO WCOSS Implementation Standards changes made to JGDAS_ENKF_FCST - * r61501 - add satinfo files for retrospective parallels - * r61689 - add convinfo and errtable files for retrospective parallels - * r62346 - create GLOBAL_RB.v6.1.0 as copy of r62337 GSI trunk - * r62482 - update Release_Notes, convinfo, and satinfo files; copy files from GLOBAL_RB.v6.0.0 - * r63885 - create GLOBAL_RB.v6.2.0 as copy of r63842 branches/fixe2c - * r63890 - add or copy/modify various componets from GLOBAL_RB.v6.0.0 - * r63952 - copy updates from r63951 fixe2c into GLOBAL_RB.v6.2.0 - * r63964 - copy r63960 fixe2c to GLOBAL_RB.v6.2.0 - * r64593 - create GLOBAL_RB.v6.2.1 as copy of r63964 GLOBAL_RB.v6.2.0 - * r64596 - increment version number from 6.2.0 to 6.2.1 - * r64614 - place channels 101 & 102 on CrIS, 221 on AIRS and 269 on Metop-A/B IASI in monitor mode - * r64617 - update SVN HISTORY in release notes - * r64654 - update SVN HISTORY in release notes; add global_satinfo.txt.2015111012 - * r66548 - copy r64654 GLOBAL_RB.v6.2.1 to GLOBAL_RB.v6.2.2 - * r66550 - update GSI source code: limit ensemble RH perturbation; correct ATMS spatial averaging array index bug - * r66583 - increment version number of directories in GLOBAL_RB.v6.2.2 from v6.2.1 to v6.2.2 - * r66588 - increment version number in build, module, and release notes - * r66591 - correct typo in ATMS code; update SVN HISTORY in release notes - * r67496 - refactor jobs as requested by NCO; update release notes; clean build directories - * r67528 - update release notes; specify precision on numeric constant - * r67541 - update release notes, add driver scripts and config files for jobs - * r67781 - create GLOBAL_RB.v6.2.3 as copy of r67541 GLOBAL_RB.v6.2.2 - * r67787 - increment version number from v6.2.2 to v6.2.3 in release notes, build, and driver scripts - * r67788 - update berror.f90 - * r67789 - update SVN HISTORY in release notes - * r67791 - increment version number from v6.2.2 to v6.2.3 in module filename - * r67793 - update SVN HISTORY in release notes - * r68372 - move gsi/branches/GLOBAL_RB.v2.6.2/gdas.v6.2.3 into gfs/tags/gdas.v13.0.0 - - -CODE CHANGES - * refactor gsi.v5.0.3 and enkf.v2.0.2 into gdas, gfs, and global_shared vertical structure - * gdas.v13.0.0/sorc - * adderrspec_nmcmeth_spec.fd - add nemsio capability - * enkf_update.fd - add nemsio capability - * getsfcensmeanp.fd - add nemsio capability - * getsigensmeanp_smooth_ncep.fd - add nemsio capability - * recentersigp.fd - add nemsio capability - - -JOB CHANGES - * All jobs - * refactor jobs in accord with NCO implementation standards - * move application specific variables to parameter file - * JGDAS_ANALYSIS_HIGH - * update version number variables and defaults; add variables for aircraft data processing and bias correction; add variables for hourly atmospheric backgrounds; add l4densvar variable; add getges lines for aircraft bias correction and hourly backgrounds; update GSI namelists; update MP environment variables - * JGDAS_ENKF_FCST - * replace enkf_ver with gdas_ver; update file paths; change forecast output frequency to hourly; update stochastic physics namelist variables; add DOIAU_ENKF flag - * JGDAS_ENKF_INFLATE_RECENTER - * replace enkf_ver and gsi_ver with gdas_ver and global_shared_ver; update file paths; increase CHGRESTHREAD to 48 - * JGDAS_ENKF_INNOVATE_OBS - * update version number variables and defaults; update file paths; add SMOOTH_ENKF variable; add getges line for aircraft bias correction; update GSI namelists; update MP environment variables - * JGDAS_ENKF_POST - * replace enkf_ver and gsi_ver with gdas_ver; update file paths; change forecast output to hourly; add l4densvar and SMOOTH_ENKF variables - * JGDAS_ENKF_SELECT_OBS - * update version number variables and defaults; add variables for aircraft data processing and bias correction; add l4densvar variable; add getges lines for aircraft bias correction; update GSI namelists; update MP environment variables - * JGDAS_ENKF_UPDATE - * update version number variables and defaults; update file paths; update EnKF update code namelist; add SMOOTH_ENKF variable - - -SCRIPT CHANGES - * All scripts: refactor scripts in accord with NCO implementation standards - * exglobal_enkf_fcst.sh.ecf - * add IAU logic - * exglobal_enkf_inflate_recenter.sh.ecf - * add nemsio logic; change SCALEFACT default; add NSST processing - * exglobal_enkf_innovate_obs.sh.ecf - * add variables for NSST; add nemsio logic; add DOIAU variable; add _ENKF variables to toggle GSI namelist variables; add variables for hourly backgrounds and aircraft bias correction; update GSI namelist - * exglobal_enkf_post.sh.ecf - * add nemsio logic; add SMOOTH_ENKF variable; modify logic to process hourly files - * exglobal_enkf_update.sh.ecf - * add nemsio logic; update global_enkf namelist - - -RESOURCE INFORMATION - * Current operational GFS runs on WCOSS phase1 nodes. Q1FY16 GFS package should be implemented on WCOSS phase2 nodes. - * JGDAS_ANALYSIS_HIGH - * job configuration - * current operations: 90 nodes, 360 tasks, ptile=4, 4 threads - * proposed package: 240 nodes, 480 tasks, ptile=2, 12 threads - NOTE: see ../driver/test_gdas_analysis_high.sh for jobs specific module load and environment variable settings - * run time - * current operations: 32.7 - 35.9 minutes - * proposed package: 30 - 32 minutes - * JGDAS_ENKF_SELECT_OBS - * job configuration - * current operations: 7 nodes, 112 tasks, ptile=16, 1 thread - * proposed package: 12 nodes, 144 tasks, ptile=12, 2 threads - NOTE: see ../driver/test_gdas_enkf_select_obs.sh for job specific module load and environment variable settings - * run time - * current operations: 3.1 - 4.0 minutes - * proposed package: 3.0 - 4.0 minutes - * JGDAS_ENKF_INNOVATE_OBS - * job configuration - * current operations: 7 nodes, 112 tasks, ptile=16, 1 thread - * proposed package: 12 nodes, 144 tasks, ptile=12, 2 thread - NOTE: see ../driver/test_gdas_enkf_innovate_obs.sh for job specific module load and environment variable settings -` * run time - * current operations: 17.9 - 22.22 minutes - * proposed package 13.8 - 15.5 minutes - * JGDAS_ENKF_UPDATE - * job configuration - * current operations: 55 modes, 330 tasks, ptile=6, 2 threads - * proposed package: 40 nodes, 240 tasks, ptile=6, 4 threads - NOTE: see ../driver/test_gdas_enkf_update.sh for job specific module load and environment variable settings - * run time - * current operations: 11.0 - 12.4 minutes - * proposed package: 10.0 - 12.0 minutes - * JGDAS_ENKF_INFLATE_RECENTER - * job configuration - * current operations: 20 nodes, 80 tasks, ptile=4, 1 thread - * proposed package: 4 nodes, 80 tasks, ptile=24, 1 thread - NOTE: see ../driver/test_gdas_enkf_inflate_recenter.sh for job specific module load and environment variable settings - * run time - * current operations: 5.3 - 5.8 minutes - * proposed package: 2.7 - 4.0 minutes - * JGDAS_ENKF_FCST - * job configuration - * current operations: 20 nodes, 160 tasks, ptile=8, 2 threads - * proposed package: 16 nodes, 96 tasks, ptile=6, 4 threads - NOTE: see ../driver/test_gdas_enkf_fcst.sh for job specific module load and environment variable settings - * run time - * current operations: 20.4 - 21.1 minutes - * proposed package: 18.4 - 19.0 minutes - * JGDAS_ENKF_POST - * job configuration - * current operations: 7 nodes, 81 tasks, ptile=12, 1 thread - * proposed package: 4 nodes, 81 tasks, ptile=24, 1 thread - NOTE: see ../driver/test_gdas_enkf_post.sh for job specific module load and environment variable settings - * run time - * current operations: 8.2 - 9.3 minutes - * proposed package: 10.8 - 12.0 minutes - * Disk space required per day - * /com/gfs/prod/gdas.$PDY - * current operations: 320.1 Gb - * proposed package: 428.6 Gb (additional 108.5 Gb) - * /com/gfs/prod/enkf.$PDY/$cyc - * current operations: 1564.7 Gb - * proposed package: 2943.8 Gb (additional 1379.1 Gb) - *pending approval from downstream users remove 91.4 Gb of *_t254 files. If approved, this reduces the total disk usage to 2852.4 Gb. - * Frequency of run - * 6 hourly cycle (00, 06, 12, 18Z) - * Specify all versions of libs, compilers, shared code recentersigp.x - * libraries - * BACIO_VER = v2.0.1 - * BUFR_VER = v11.0.0 - * CRTM_VER = v2.2.3 - * NEMSIO_VER = v2.2.1 - * NETCDF_VER = 3.6.3 - * SFCIO_VER = v1.0.0 - * SIGIO_VER = v2.0.1 - * SP_VER = v2.0.2 - * W3EMC_VER = v2.2.0 - * W3NCO_VER = v2.0.6 - * compiler (modules loaded during GSI build / run) - * ics/15.0.3 - * ibmpe/1.3.0.10 - * lsf/9.1 - * Data retention for files in /com and /nwges under prod/para/test environments - * same as current operations - - -PRE-IMPLEMENTATION TESTING REQUIREMENTS - * Which production jobs should be tested as part of this implementation? - * gdas_da.v13.0.0 should be tested as part of the Q1FY16 GFS package - * Does this change require a 30-day evaluation? - * YES - * Suggested evaluators - * same as rest of Q1FY16 GFS package - - -DISSEMINATION INFORMATION - * Where should this output be sent? - * same as current operational GFS/GDAS GSI - * Who are the users? - * same as current operational GFS/GDAS GSI - * Which output files should be transferred from PROD WCOSS to DEV WCOSS? - * same as current operational GFS/GDAS GSI - - -HPSS ARCHIVE - * Retention length? - * same as current operational GFS/GDAS GSI - * List which output files should be archived - * same as current operational GFS/GDAS GSI - - -IMPLEMENTATION INSTRUCTIONS - * To implement gdas_da.v13.0.0, please do the following: - * cd $NWROOT - * svn checkout https://svnemc.ncep.noaa.gov/projects/gfs/tags/gdas.v13.0.0 - * cd $NWROOD/gdas.v13.0.0/sorc - * execute "/bin/sh build_enkf.sh" - This builds executables and places the following executables in $NWROOT/gdas.v13.0.0/exec/ - * adderrspec_nmcmeth_spec.x - * getsfcensmeanp.x - * getsigensmeanp_smooth.x - * global_enkf - * recentersigp.x - - -JOB DEPENDENCIES & FLOW DIAGRAM - * no change from gsi.v5.0.3 and enkf.v2.0.2 - - - diff --git a/doc/Release_Notes.gfs_da.v13.0.0.txt b/doc/Release_Notes.gfs_da.v13.0.0.txt deleted file mode 100644 index 3efa1f526..000000000 --- a/doc/Release_Notes.gfs_da.v13.0.0.txt +++ /dev/null @@ -1,135 +0,0 @@ -RELEASE NOTES: gfs_da.v6.2.3 --> gfs_da.v13.0.0 - v6.0.0 - released Jun 16, 2015 - v6.1.0 - released Oct 02, 2015 - v6.2.0 - released Oct 27, 2015 - v6.2.1 - releaese Nov 10, 2015 - v6.2.2 - released Dec 15, 2015 - v6.2.3 - released Jan 19, 2016 -v13.0.0 - released Feb 02, 2016 - -SVN HISTORY (see EMC GSI Trac ticket #478, EMC GFS Trac ticket #236) - * r57752 - create GLOBAL_RB.v6.0.0 as copy of r57678 trunk - * r57803 - revise build to use modulefile - * r57804 - update gdas, gfs, and global_shared directory version numbers - * r57808 - commit release notes - * r59582 - merge r59495 GSI trunk into GLOBAL_RB.v6.0.0 - * r59583 - update SVN HISTORY in release notes - * r59587 - restore r57803 Makefile.conf.wcoss - * r59595 - first attempt at refactoring JGFS_ANALYSIS to be consistent with NCO WCOSS implementation standards - * r60327 - merge r59731 and r60129 trunk into GLOBAL_RB.v6.0.0 - * r60342 - update SVN HISTORY in release notes - * r60354 - update version numbers to crtm.v2.2.3 and bufr.v11.0.0. crtm.v2.2.3 added to GSI trunk at r60393 - * r60360 - refactor JGDAS_ANALYSIS_HIGH in according with NCO WCOSS implementation standards - * r60540 - refactor jobs and scripts in accord with NCO WCOSS implementation standards - * r60678 - update SVN HISTORY in release notes; update jobs and scripts to use nwtest2 CRTM v2.2.3 - * r60681 - turn off dissipative heating in EnKF forecast - * r60682 - update SVN HISTORY (add r60678 and r60681) - * r60807 - update SVN HISTORY; correct typo in Release_Notes.gdas_da.v6.0.0.txt - * r60831 - update SVN HISTORY; additional NCO WCOSS Implementation Standards changes made to JGDAS_ENKF_FCST - * r61501 - add satinfo files for retrospective parallels - * r61689 - add convinfo and errtable files for retrospective parallels - * r62346 - create GLOBAL_RB.v6.1.0 as copy of r62337 GSI trunk - * r62482 - update Release_Notes, convinfo, and satinfo files; copy files from GLOBAL_RB.v6.0.0 - * r63885 - create GLOBAL_RB.v6.2.0 as copy of r63842 branches/fixe2c - * r63890 - add or copy/modify various componets from GLOBAL_RB.v6.0.0 - * r63952 - copy updates from r63951 fixe2c into GLOBAL_RB.v6.2.0 - * r63964 - copy r63960 fixe2c to GLOBAL_RB.v6.2.0 - * r64593 - create GLOBAL_RB.v6.2.1 as copy of r63964 GLOBAL_RB.v6.2.0 - * r64596 - increment version number from 6.2.0 to 6.2.1 - * r64614 - place channels 101 & 102 on CrIS, 221 on AIRS and 269 on Metop-A/B IASI in monitor mode - * r64617 - update SVN HISTORY in release notes - * r64654 - update SVN HISTORY in release notes; add global_satinfo.txt.2015111012 - * r66548 - copy r64654 GLOBAL_RB.v6.2.1 to GLOBAL_RB.v6.2.2 - * r66550 - update GSI source code: limit ensemble RH perturbation; correct ATMS spatial averaging array index bug - * r66583 - increment version number of directories in GLOBAL_RB.v6.2.2 from v6.2.1 to v6.2.2 - * r66588 - increment version number in build, module, and release notes - * r66591 - correct typo in ATMS code; update SVN HISTORY in release notes - * r67496 - refactor jobs as requested by NCO; update release notes; clean build directories - * r67528 - update release notes; specify precision on numeric constant - * r67541 - update release notes, add driver scripts and config files for jobs - * r67781 - create GLOBAL_RB.v6.2.3 as copy of r67541 GLOBAL_RB.v6.2.2 - * r67787 - increment version number from v6.2.2 to v6.2.3 in release notes, build, and driver scripts - * r67788 - update berror.f90 - * r67789 - update SVN HISTORY in release notes - * r67791 - increment version number from v6.2.2 to v6.2.3 in module filename - * r67793 - update SVN HISTORY in release notes - * r68371 - move gsi/branches/GLOBAL_RB.v6.2.3/gfs.v6.2.3 into gfs/tags/gfs.v13.0.0 - - -CODE CHANGES - * No code change - - -JOB CHANGES - * Refactor jobs in accord with NCO implementation standards - * JGFS_ANALYSIS - * update version number variables and defaults; add variables for aircraft data processing and bias correction; add variables for hourly atmospheric backgrounds; add l4densvar variable; add getges lines for aircraft bias correction and hourly backgrounds; update GSI namelists; update MP environment variables - * move application specific variables to parameter file - - -SCRIPT CHANGES - * No script change - - -RESOURCE INFORMATION - * Current operational GFS runs on WCOSS phase1 nodes. Q1FY16 GFS package should be implemented on WCOSS phase2 nodes. - * JGFS_ANALYSIS - * job configuration - * current operations: 120 nodes, 480 tasks, ptile=4, 4 threads - * proposed package: 240 nodes, 480 tasks, ptile=2, 12 threads - * run time - * current operations: 20.4 - 21.4 minutes - * proposed package: 22 - 23 minutes - NOTE1: see ../driver/test_gfs_analysis.sh for job specific module load and environment variable settings - NOTE2: Run time can be reduced to ~20 minutes by reducing number of second outer loop iterations to ~130. - Reducing the number of iterations alters the anlaysis result. As such, the EMC DA team must be - consulted before making any change to the number of iterations. - * Disk space required per day - * /com/gfs/prod/gfs.$PDY - * current operations: 2221.0 Gb - * proposed package: 2329.5 Gb (additional 108.5 Gb) - * frequency of run - * 6 hourly cycle (00, 06, 12, 18Z) - * Specify all versions of libs, compilers, shared code being used - * gfs_da.v13.0.0 only contains jobs/JGFS_ANALYSIS. No libraries or compilers are required to install gfs_da.v13.0.0 - * modules loaded during GSI run - * ics/15.0.3 - * ibmpe/1.3.0.10 - * lsf/9.1 - * Data retention for files in /com and /nwges under prod/para/test environments - * same as current operations - - -PRE-IMPLEMENTATION TESTING REQUIREMENTS - * Which production jobs should be tested as part of this implementation? - * gfs_da.v13.0.0 should be tested as part of the Q1FY16 GFS package - * Does this change require a 30-day evaluation? - * YES - * Suggested evaluators - * same as rest of Q1FY16 GFS package - - -DISSEMINATION INFORMATION - * Where should this output be sent? - * same as current operational GFS/GDAS GSI - * Who are the users? - * same as current operational GFS/GDAS GSI - * Which output files should be transferred from PROD WCOSS to DEV WCOSS? - * same as current operational GFS/GDAS GSI - - -HPSS ARCHIVE - * Retention length? - * same as current operational GFS/GDAS GSI - * List which output files should be archived - * same as current operational GFS/GDAS GSI - - -IMPLEMENTATION INSTRUCTIONS -* To implement gfs_da.v13.0.0, please do the following: - * cd $NWROOT - * svn checkout https://svnemc.ncep.noaa.gov/projects/gfs/tags/gfs.v13.0.0 - - -JOB DEPENDENCIES & FLOW DIAGRAM - * No change from gsi.v5.0.3 and enkf.v2.0.2 diff --git a/doc/Release_Notes.global_shared_da.v13.0.0.txt b/doc/Release_Notes.global_shared_da.v13.0.0.txt deleted file mode 100644 index 141ac3c5e..000000000 --- a/doc/Release_Notes.global_shared_da.v13.0.0.txt +++ /dev/null @@ -1,133 +0,0 @@ -RELEASE NOTES: global_shared_da.v6.2.3 --> global_shared.v13.0.0 - v6.0.0 - released Jun 16, 2015 - v6.1.0 - released Oct 02, 2015 - v6.2.0 - released Oct 27, 2015 - v6.2.1 - released Nov 10, 2015 - v6.2.2 - released Dec 15, 2015 - v6.2.3 - released Jan 19, 2016 -v13.0.0 - released Feb 02, 2016 - -SVN HISTORY (see EMC GSI Trac ticket #478, EMC GFS Trac ticket #236) - * r57752 - create GLOBAL_RB.v6.0.0 as copy of r57678 trunk - * r57803 - revise build to use modulefile - * r57804 - update gdas, gfs, and global_shared directory version numbers - * r57808 - commit release notes - * r59582 - merge r59495 GSI trunk into GLOBAL_RB.v6.0.0 - * r59583 - update SVN HISTORY in release notes - * r59587 - restore r57803 Makefile.conf.wcoss - * r59595 - first attempt at refactoring JGFS_ANALYSIS to be consistent with NCO WCOSS implementation standards - * r60327 - merge r59731 and r60129 trunk into GLOBAL_RB.v6.0.0 - * r60342 - update SVN HISTORY in release notes - * r60354 - update version numbers to crtm.v2.2.3 and bufr.v11.0.0. crtm.v2.2.3 added to GSI trunk at r60393 - * r60360 - refactor JGDAS_ANALYSIS_HIGH in according with NCO WCOSS implementation standards - * r60540 - refactor jobs and scripts in accord with NCO WCOSS implementation standards - * r60678 - update SVN HISTORY in release notes; update jobs and scripts to use nwtest2 CRTM v2.2.3 - * r60681 - turn off dissipative heating in EnKF forecast - * r60682 - update SVN HISTORY (add r60678 and r60681) - * r60807 - update SVN HISTORY; correct typo in Release_Notes.gdas_da.v6.0.0.txt - * r60831 - update SVN HISTORY; additional NCO WCOSS Implementation Standards changes made to JGDAS_ENKF_FCST - * r61501 - add satinfo files for retrospective parallels - * r61689 - add convinfo and errtable files for retrospective parallels - * r62346 - create GLOBAL_RB.v6.1.0 as copy of r62337 GSI trunk - * r62482 - update Release_Notes, convinfo, and satinfo files; copy files from GLOBAL_RB.v6.0.0 - * r63885 - create GLOBAL_RB.v6.2.0 as copy of r63842 branches/fixe2c - * r63890 - add or copy/modify various componets from GLOBAL_RB.v6.0.0 - * r63952 - copy updates from r63951 fixe2c into GLOBAL_RB.v6.2.0 - * r63964 - copy r63960 fixe2c to GLOBAL_RB.v6.2.0 - * r64593 - create GLOBAL_RB.v6.2.1 as copy of r63964 GLOBAL_RB.v6.2.0 - * r64596 - increment version number from 6.2.0 to 6.2.1 - * r64614 - place channels 101 & 102 on CrIS, 221 on AIRS and 269 on Metop-A/B IASI in monitor mode - * r64617 - update SVN HISTORY in release notes - * r64654 - update SVN HISTORY in release notes; add global_satinfo.txt.2015111012 - * r66548 - copy r64654 GLOBAL_RB.v6.2.1 to GLOBAL_RB.v6.2.2 - * r66550 - update GSI source code: limit ensemble RH perturbation; correct ATMS spatial averaging array index bug - * r66583 - increment version number of directories in GLOBAL_RB.v6.2.2 from v6.2.1 to v6.2.2 - * r66588 - increment version number in build, module, and release notes - * r66591 - correct typo in ATMS code; update SVN HISTORY in release notes - * r67496 - refactor jobs as requested by NCO; update release notes; clean build directories - * r67528 - update release notes; specify precision on numeric constant - * r67541 - update release notes, add driver scripts and config files for jobs - * r67781 - create GLOBAL_RB.v6.2.3 as copy of r67541 GLOBAL_RB.v6.2.2 - * r67787 - increment version number from v6.2.2 to v6.2.3 in release notes, build, and driver scripts - * r67788 - update berror.f90 - * r67789 - update SVN HISTORY in release notes - * r67791 - increment version number from v6.2.2 to v6.2.3 in module filename - * r67793 - update SVN HISTORY in release notes - * r68372 - move gsi/branches/GLOBAL_RB.v2.6.2/global_shared.v6.2.3 into gfs/tags/global_shared.v13.0.0 - - -CODE CHANGES - * Refactor gsi.v5.0.3 and enkf.v2.0.2 into gdas and global_shared vertical structure - * global_shared.v13.0.0/sorc/ - * gsi.fd - add hybrid 4d ensemble-variational component; utilize ozone cross covariances; reduce tropospheric localization length scales; increase ensemble weight; aircraft bias correction; assimilate aircraft moisture data; all-sky AMSU-A radiance assimilation; modify radiance thinning in time; monitor AVHRR radiances; process additional AVHRR atmospheric motion vectors (AMVs); monitor VIIRS AMVs; code optimization; initial nemsio capability - - -JOB CHANGES - * No job change - - -SCRIPT CHANGES - * Refactor script in accord with NCO implementation standards - * scripts/ - * exglobal_analysis.sh.ecf - add variables for aircraft processing and bias correction; add variables for NSST; add nemsio logic; add variables for AVHRR radiances; add variables for hourly backgrounds; update GSI namelist; update radiance diagnostic file satellte_sensor list - - -RESOURCE INFORMATION - * Current operational GFS runs on WCOSS phase1 nodes. Q1FY16 GFS package should be implemented on WCOSS phase2 nodes. See gdas_da.v13.0.0 and gfs_da.v13.0.0 release notes for resource information. global_shared.v13.0.0 only contains GSI fix files, scripts, source code, and executable. - * Frequency of run - * 6 hourly cycle (00, 06, 12, 18Z) - * Specify all versions of libs, compilers, shared code being used - * libraries - * BACIO_VER = v2.0.1 - * BUFR_VER = v11.0.0 - * CRTM_VER = v2.2.3 - * NEMSIO_VER = v2.2.1 - * NETCDF_VER = 3.6.3 - * SFCIO_VER = v1.0.0 - * SIGIO_VER = v2.0.1 - * SP_VER = v2.0.2 - * W3EMC_VER = v2.2.0 - * W3NCO_VER = v2.0.6 - * compiler (modules loaded during GSI build / run) - * ics/15.0.3 - * ibmpe/1.3.0.10 - * lsf/9.1 - * Data retention for files in /com and /nwges under prod/para/test environments - * same as current operations - - -PRE-IMPLEMENTATION TESTING REQUIREMENTS - * Which production jobs should be tested as part of this implementation? - * global_shared_da.v13.0.0 should be tested as part of the Q1FY16 GFS package - * Does this change require a 30-day evaluation? - * YES - * Suggested evaluators - * same as rest of Q1FY16 GFS package - - -DISSEMINATION INFORMATION - * Where should this output be sent? - * same as current operational GFS/GDAS GSI - * Who are the users? - * same as current operational GFS/GDAS GSI - * Which output files should be transferred from PROD WCOSS to DEV WCOSS? - * same as current operational GFS/GDAS GSI - - -HPSS ARCHIVE - * Retention length? - * same as current operational GFS/GDAS GSI - * List which output files should be archived - * same as current operational GFS/GDAS GSI - - -IMPLEMENTATION INSTRUCTIONS -* To implement global_shared_da.v13.0.0, please do the following: - * cd $NWROOT - * svn checkout https://svnemc.ncep.noaa.gov/projects/gfs/tags/global_shared.v13.0.0 - * cd $NWROOT/global_shared.v13.0.0/sorc - * execute ./build.sh - This builds the global_gsi executable and places it $NWROOT/global_shared.v13.0.0/exec - - -JOB DEPENDENCIES & FLOW DIAGRAM - * No change from gsi.v5.0.3 and enkf.v2.0.2 diff --git a/fix b/fix index 4d2d2b390..6c7d9f470 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 4d2d2b390eb719de9ce37a66d5ba46b9706f03c5 +Subproject commit 6c7d9f470fba03cfc77850b9a5e49295ceb2f4b7 diff --git a/jobs/JGDAS_ENKF_FCST b/jobs/JGDAS_ENKF_FCST index dbe31a56f..67bc685d7 100755 --- a/jobs/JGDAS_ENKF_FCST +++ b/jobs/JGDAS_ENKF_FCST @@ -9,6 +9,7 @@ date ############################# # Source relevant config files ############################# +export EXPDIR=${EXPDIR:-$HOMEgfs/parm/config} config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} configs="base fcst efcs" for config in $configs; do @@ -29,17 +30,9 @@ status=$? ############################################## # Obtain unique process id (pid) and make temp directory ############################################## -export job=${job:-"efcs.grp${ENSGRP}"} export pid=${pid:-$$} export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} -if [ $RUN_ENVIR = "nco" ]; then - export DATA="$DATAROOT/$jobid" -else - export DATAROOT="$RUNDIR/$CDATE/$CDUMP" - export DATA="$DATAROOT/$job.grp$ENSGRP" -fi -[[ -d $DATA ]] && rm -rf $DATA +export DATA=${DATA:-${DATAROOT}/${jobid:?}} mkdir -p $DATA cd $DATA @@ -52,12 +45,6 @@ setpdy.sh . ./PDY -############################################## -# Define the Log File directory -############################################## -export jlogfile=${jlogfile:-$COMROOT/logs/jlogfiles/jlogfile.${job}.${pid}} - - ############################################## # Determine Job Output Name on System ############################################## @@ -81,6 +68,10 @@ fi export CASE=$CASE_ENKF +# COMOUT is used in exglobal script +# TO DO: Map NCO's directory into these variables +export COMOUT="$ROTDIR/enkf$CDUMP.$PDY/$cyc" + # Forecast length for EnKF forecast export FHMIN=$FHMIN_ENKF @@ -107,7 +98,7 @@ status=$? # Double check the status of members in ENSGRP -EFCSGRP=$ROTDIR/enkf.${CDUMP}.$PDY/$cyc/efcs.grp${ENSGRP} +EFCSGRP=$COMOUT/efcs.grp${ENSGRP} npass=0 if [ -f $EFCSGRP ]; then npass=$(grep "PASS" $EFCSGRP | wc -l) @@ -120,6 +111,14 @@ if [ $npass -ne $NMEM_EFCSGRP ]; then fi +############################################## +# Send Alerts +############################################## +if [ $SENDDBN = YES ] ; then + $DBNROOT/bin/dbn_alert MODEL ENKF1_MSC_fcsstat $job $EFCSGRP +fi + + ############################################## # End JOB SPECIFIC work ############################################## @@ -127,7 +126,9 @@ fi ############################################## # Final processing ############################################## -cat $pgmout +if [ -e "$pgmout" ] ; then + cat $pgmout +fi msg="ENDED NORMALLY." diff --git a/jobs/JGDAS_ENKF_INNOVATE_OBS b/jobs/JGDAS_ENKF_INNOVATE_OBS deleted file mode 100755 index 951da3070..000000000 --- a/jobs/JGDAS_ENKF_INNOVATE_OBS +++ /dev/null @@ -1,182 +0,0 @@ -#!/bin/ksh -set -x - -export RUN_ENVIR=${RUN_ENVIR:-"nco"} -export PS4='$SECONDS + ' -date - - -############################# -# Source relevant config files -############################# -configs="base anal eobs" -config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} -for config in $configs; do - . $config_path/config.$config - status=$? - [[ $status -ne 0 ]] && exit $status -done - - -########################################## -# Source machine runtime environment -########################################## -. $HOMEgfs/env/${machine}.env eobs -status=$? -[[ $status -ne 0 ]] && exit $status - - -############################################## -# Obtain unique process id (pid) and make temp directory -############################################## -export job=${job:-"eomg.grp$ENSGRP"} -export pid=${pid:-$$} -export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} -if [ $RUN_ENVIR = "nco" ]; then - export DATA="$DATAROOT/$jobid" -else - export DATAROOT="$RUNDIR/$CDATE/$CDUMP" - export DATA="$DATAROOT/$job" -fi -[[ -d $DATA ]] && rm -rf $DATA -mkdir -p $DATA -cd $DATA - - -############################################## -# Run setpdy and initialize PDY variables -############################################## -export cycle="t${cyc}z" -setpdy.sh -. ./PDY - - -############################################## -# Define the Log File directory -############################################## -export jlogfile=${jlogfile:-$COMROOT/logs/jlogfiles/jlogfile.${job}.${pid}} - - -############################################## -# Determine Job Output Name on System -############################################## -export pgmout="OUTPUT.${pid}" -export pgmerr=errfile - - -############################################## -# Set variables used in the exglobal script -############################################## -export CDATE=${CDATE:-${PDY}${cyc}} -export CDUMP=${CDUMP:-${RUN:-"gdas"}} -if [ $RUN_ENVIR = "nco" ]; then - export ROTDIR=${COMROOT:?}/$NET/$envir -fi - - -############################################## -# Begin JOB SPECIFIC work -############################################## - -GDATE=$($NDATE -$assim_freq $CDATE) -gPDY=$(echo $GDATE | cut -c1-8) -gcyc=$(echo $GDATE | cut -c9-10) - - -export CASE=$CASE_ENKF - - -export OPREFIX="${CDUMP}.t${cyc}z." -export APREFIX="${CDUMP}.t${cyc}z." -export ASUFFIX=".nemsio" -export GPREFIX="${CDUMP}.t${gcyc}z." -export GSUFFIX=".nemsio" - - -# COMIN_GES, COMIN_GES_ENS and COMOUT are used in exglobal script -# TO DO: Map NCO's directory into these variables -export COMIN_GES="$ROTDIR/$CDUMP.$gPDY/$gcyc" -export COMIN_GES_ENS="$ROTDIR/enkf.$CDUMP.$gPDY/$gcyc" -export COMOUT="$ROTDIR/enkf.$CDUMP.$PDY/$cyc" - - -export ATMGES_ENSMEAN="$COMIN_GES_ENS/${GPREFIX}atmf006.ensmean$GSUFFIX" -if [ ! -f $ATMGES_ENSMEAN ]; then - echo "FATAL ERROR: FILE MISSING: ATMGES_ENSMEAN = $ATMGES_ENSMEAN" - exit 1 -fi - - -export LEVS=$($NEMSIOGET $ATMGES_ENSMEAN dimz | awk '{print $2}') -status=$? -[[ $status -ne 0 ]] && exit $status - - -# Guess Bias correction coefficients related to control -export GBIAS=${COMIN_GES}/${GPREFIX}abias -export GBIASPC=${COMIN_GES}/${GPREFIX}abias_pc -export GBIASAIR=${COMIN_GES}/${GPREFIX}abias_air -export GRADSTAT=${COMIN_GES}/${GPREFIX}radstat - - -# Use the selected observations from ensemble mean -export RUN_SELECT="NO" -export USE_SELECT="YES" -export SELECT_OBS="$COMOUT/${APREFIX}obsinput.ensmean" - - -# Get ENSBEG/ENSEND from ENSGRP and NMEM_EOMGGRP -export ENSEND=$((NMEM_EOMGGRP * ENSGRP)) -export ENSBEG=$((ENSEND - NMEM_EOMGGRP + 1)) - - -############################################################### -# Run relevant exglobal script -env -msg="HAS BEGUN on `hostname`" -postmsg "$jlogfile" "$msg" -$LOGSCRIPT - - -${ENKFINVOBSSH:-$SCRgsi/exglobal_enkf_innovate_obs_fv3gfs.sh.ecf} -status=$? -[[ $status -ne 0 ]] && exit $status - - -# Double check the status of members in ENSGRP -EOMGGRP=$ROTDIR/enkf.${CDUMP}.$PDY/$cyc/eomg.grp${ENSGRP} -npass=0 -if [ -f $EOMGGRP ]; then - npass=$(grep "PASS" $EOMGGRP | wc -l) -fi -echo "$npass/$NMEM_EOMGGRP members successfull in eomg.grp$ENSGRP" -if [ $npass -ne $NMEM_EOMGGRP ]; then - echo "FATAL ERROR: Failed members in $ENSGRP, ABORT!" - cat $EOMGGRP - exit 99 -fi - - -############################################## -# End JOB SPECIFIC work -############################################## - -############################################## -# Final processing -############################################## -cat $pgmout - - -msg="ENDED NORMALLY." -postmsg "$jlogfile" "$msg" - - -########################################## -# Remove the Temporary working directory -########################################## -cd $DATAROOT -[[ $KEEPDATA = "NO" ]] && rm -rf $DATA - -date -exit 0 diff --git a/jobs/JGDAS_ENKF_POST b/jobs/JGDAS_ENKF_POST index 30d1a79ba..e0bcc055f 100755 --- a/jobs/JGDAS_ENKF_POST +++ b/jobs/JGDAS_ENKF_POST @@ -9,6 +9,7 @@ date ############################# # Source relevant config files ############################# +export EXPDIR=${EXPDIR:-$HOMEgfs/parm/config} configs="base epos" config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} for config in $configs; do @@ -29,17 +30,9 @@ status=$? ############################################## # Obtain unique process id (pid) and make temp directory ############################################## -export job=${job:-"epos"} export pid=${pid:-$$} export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} -if [ $RUN_ENVIR = "nco" ]; then - export DATA="$DATAROOT/$jobid" -else - export DATAROOT="$RUNDIR/$CDATE/$CDUMP" - export DATA="$DATAROOT/$job" -fi -[[ -d $DATA ]] && rm -rf $DATA +export DATA=${DATA:-${DATAROOT}/${jobid:?}} mkdir -p $DATA cd $DATA @@ -52,12 +45,6 @@ setpdy.sh . ./PDY -############################################## -# Define the Log File directory -############################################## -export jlogfile=${jlogfile:-$COMROOT/logs/jlogfiles/jlogfile.${job}.${pid}} - - ############################################## # Determine Job Output Name on System ############################################## @@ -85,8 +72,8 @@ export SUFFIX=".nemsio" # COMIN, COMOUT are used in exglobal script # TO DO: Map NCO's directory into these variables -export COMIN="$ROTDIR/enkf.$CDUMP.$PDY/$cyc" -export COMOUT="$ROTDIR/enkf.$CDUMP.$PDY/$cyc" +export COMIN="$ROTDIR/enkf$CDUMP.$PDY/$cyc" +export COMOUT="$ROTDIR/enkf$CDUMP.$PDY/$cyc" export LEVS=$((LEVS-1)) @@ -112,7 +99,9 @@ status=$? ############################################## # Final processing ############################################## -cat $pgmout +if [ -e "$pgmout" ] ; then + cat $pgmout +fi msg="ENDED NORMALLY." diff --git a/jobs/JGDAS_ENKF_RECENTER b/jobs/JGDAS_ENKF_RECENTER index 907615226..d291be2e6 100755 --- a/jobs/JGDAS_ENKF_RECENTER +++ b/jobs/JGDAS_ENKF_RECENTER @@ -9,6 +9,7 @@ date ############################# # Source relevant config files ############################# +export EXPDIR=${EXPDIR:-$HOMEgfs/parm/config} configs="base ecen" config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} for config in $configs; do @@ -29,17 +30,9 @@ status=$? ############################################## # Obtain unique process id (pid) and make temp directory ############################################## -export job=${job:-"ecen"} export pid=${pid:-$$} export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} -if [ $RUN_ENVIR = "nco" ]; then - export DATA="$DATAROOT/$jobid" -else - export DATAROOT="$RUNDIR/$CDATE/$CDUMP" - export DATA="$DATAROOT/$job" -fi -[[ -d $DATA ]] && rm -rf $DATA +export DATA=${DATA:-${DATAROOT}/${jobid:?}} mkdir -p $DATA cd $DATA @@ -52,12 +45,6 @@ setpdy.sh . ./PDY -############################################## -# Define the Log File directory -############################################## -export jlogfile=${jlogfile:-$COMROOT/logs/jlogfiles/jlogfile.${job}.${pid}} - - ############################################## # Determine Job Output Name on System ############################################## @@ -82,23 +69,40 @@ fi GDATE=$($NDATE -$assim_freq $CDATE) gPDY=$(echo $GDATE | cut -c1-8) gcyc=$(echo $GDATE | cut -c9-10) - +GDUMP=${GDUMP:-"gdas"} export CASE=$CASE_ENKF +EUPD_CYC=$(echo ${EUPD_CYC:-"gdas"} | tr a-z A-Z) +if [ $EUPD_CYC = "GFS" ]; then + CDUMP_ENKF="gfs" +else + CDUMP_ENKF=$CDUMP +fi + + export OPREFIX="${CDUMP}.t${cyc}z." export APREFIX="${CDUMP}.t${cyc}z." +export APREFIX_ENKF="${CDUMP_ENKF}.t${cyc}z." export ASUFFIX=".nemsio" export GPREFIX="${CDUMP}.t${gcyc}z." export GSUFFIX=".nemsio" +if [ $RUN_ENVIR = "nco" -o ${ROTDIR_DUMP:-NO} = "YES" ]; then + export COMIN_OBS=${COMIN_OBS:-$ROTDIR/$RUN.$PDY/$cyc} + export COMIN_GES_OBS=${COMIN_GES_OBS:-$ROTDIR/$GDUMP.$gPDY/$gcyc} +else + export COMIN_OBS="$DMPDIR/$CDATE/$CDUMP" + export COMIN_GES_OBS="$DMPDIR/$GDATE/$GDUMP" +fi # COMIN, COMIN_ENS and COMIN_GES_ENS are used in exglobal script # TO DO: Map NCO's directory into these variables export COMIN="$ROTDIR/$CDUMP.$PDY/$cyc" -export COMIN_ENS="$ROTDIR/enkf.$CDUMP.$PDY/$cyc" -export COMIN_GES_ENS="$ROTDIR/enkf.$CDUMP.$gPDY/$gcyc" +export COMIN_ENS="$ROTDIR/enkf$CDUMP_ENKF.$PDY/$cyc" +export COMOUT_ENS="$ROTDIR/enkf$CDUMP.$PDY/$cyc" +export COMIN_GES_ENS="$ROTDIR/enkf$CDUMP.$gPDY/$gcyc" ############################################################### @@ -121,7 +125,9 @@ status=$? ############################################## # Final processing ############################################## -cat $pgmout +if [ -e "$pgmout" ] ; then + cat $pgmout +fi msg="ENDED NORMALLY." diff --git a/jobs/JGDAS_ENKF_SELECT_OBS b/jobs/JGDAS_ENKF_SELECT_OBS deleted file mode 100755 index d36f464ee..000000000 --- a/jobs/JGDAS_ENKF_SELECT_OBS +++ /dev/null @@ -1,194 +0,0 @@ -#!/bin/ksh -set -x - -export RUN_ENVIR=${RUN_ENVIR:-"nco"} -export PS4='$SECONDS + ' -date - - -############################# -# Source relevant config files -############################# -configs="base anal eobs" -config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} -for config in $configs; do - . $config_path/config.$config - status=$? - [[ $status -ne 0 ]] && exit $status -done - - -########################################## -# Source machine runtime environment -########################################## -. $HOMEgfs/env/${machine}.env eobs -status=$? -[[ $status -ne 0 ]] && exit $status - - -############################################## -# Obtain unique process id (pid) and make temp directory -############################################## -export job=${job:-"eobs"} -export pid=${pid:-$$} -export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} -if [ $RUN_ENVIR = "nco" ]; then - export DATA="$DATAROOT/$jobid" -else - export DATAROOT="$RUNDIR/$CDATE/$CDUMP" - export DATA="$DATAROOT/$job" -fi -[[ -d $DATA ]] && rm -rf $DATA -mkdir -p $DATA -cd $DATA - - -############################################## -# Run setpdy and initialize PDY variables -############################################## -export cycle="t${cyc}z" -setpdy.sh -. ./PDY - - -############################################## -# Define the Log File directory -############################################## -export jlogfile=${jlogfile:-$COMROOT/logs/jlogfiles/jlogfile.${job}.${pid}} - - -############################################## -# Determine Job Output Name on System -############################################## -export pgmout="OUTPUT.${pid}" -export pgmerr=errfile - - -############################################## -# Set variables used in the exglobal script -############################################## -export CDATE=${CDATE:-${PDY}${cyc}} -export CDUMP=${CDUMP:-${RUN:-"gdas"}} -if [ $RUN_ENVIR = "nco" ]; then - export ROTDIR=${COMROOT:?}/$NET/$envir -fi - - -############################################## -# Begin JOB SPECIFIC work -############################################## - -GDATE=$($NDATE -$assim_freq $CDATE) -gPDY=$(echo $GDATE | cut -c1-8) -gcyc=$(echo $GDATE | cut -c9-10) - - -export CASE=$CASE_ENKF - - -export OPREFIX="${CDUMP}.t${cyc}z." -export APREFIX="${CDUMP}.t${cyc}z." -export ASUFFIX=".nemsio" -export GPREFIX="${CDUMP}.t${gcyc}z." -export GSUFFIX=".ensmean.nemsio" - - -# COMIN_GES, COMIN_ANL COMIN_GES_ENS, and COMOUT are used in exglobal script -# TO DO: Map NCO's directory into these variables -COMIN_GES_CTL="$ROTDIR/$CDUMP.$gPDY/$gcyc" -export COMIN_ANL="$ROTDIR/$CDUMP.$PDY/$cyc" -export COMIN_GES_ENS="$ROTDIR/enkf.$CDUMP.$gPDY/$gcyc" -export COMIN_GES=$COMIN_GES_ENS -export COMOUT="$ROTDIR/enkf.$CDUMP.$PDY/$cyc" - - -export ATMGES_ENSMEAN="$COMIN_GES_ENS/${GPREFIX}atmf006$GSUFFIX" -if [ ! -f $ATMGES_ENSMEAN ]; then - echo "FATAL ERROR: FILE MISSING: ATMGES_ENSMEAN = $ATMGES_ENSMEAN" - exit 1 -fi - -export LEVS=$($NEMSIOGET $ATMGES_ENSMEAN dimz | awk '{print $2}') -status=$? -[[ $status -ne 0 ]] && exit $status - -# Link observational data -export PREPQC="$COMIN_ANL/${OPREFIX}prepbufr" -export PREPQCPF="$COMIN_ANL/${OPREFIX}prepbufr.acft_profiles" - -# Guess Bias correction coefficients related to control -export GBIAS=${COMIN_GES_CTL}/${GPREFIX}abias -export GBIASPC=${COMIN_GES_CTL}/${GPREFIX}abias_pc -export GBIASAIR=${COMIN_GES_CTL}/${GPREFIX}abias_air -export GRADSTAT=${COMIN_GES_CTL}/${GPREFIX}radstat - -# Bias correction coefficients related to ensemble mean -export ABIAS="$COMOUT/${APREFIX}abias.ensmean" -export ABIASPC="$COMOUT/${APREFIX}abias_pc.ensmean" -export ABIASAIR="$COMOUT/${APREFIX}abias_air.ensmean" -export ABIASe="$COMOUT/${APREFIX}abias_int.ensmean" - -# Diagnostics related to ensemble mean -export GSISTAT="$COMOUT/${APREFIX}gsistat.ensmean" -export CNVSTAT="$COMOUT/${APREFIX}cnvstat.ensmean" -export OZNSTAT="$COMOUT/${APREFIX}oznstat.ensmean" -export RADSTAT="$COMOUT/${APREFIX}radstat.ensmean" - -# Select observations based on ensemble mean -export RUN_SELECT="YES" -export USE_SELECT="NO" -export SELECT_OBS="$COMOUT/${APREFIX}obsinput.ensmean" - -export DIAG_SUFFIX="_ensmean" - -# GSI namelist options specific to eobs -export SETUP_INVOBS="passive_bc=.false." - -# Ensure clean stat tarballs for ensemble mean -for fstat in $CNVSTAT $OZNSTAT $RADSTAT; do - [[ -f $fstat ]] && rm -f $fstat -done - - -############################################################### -# Run relevant exglobal script -env -msg="HAS BEGUN on `hostname`" -postmsg "$jlogfile" "$msg" -$LOGSCRIPT - - -${INVOBSSH:-$SCRgsi/exglobal_innovate_obs_fv3gfs.sh.ecf} -status=$? -[[ $status -ne 0 ]] && exit $status - - -if [ $SENDDBN = YES ] ; then - $DBNROOT/bin/dbn_alert MODEL ENKF1_MSC_gsistat $job $COMOUT/gsistat_${PDY}${cyc}_ensmean - $DBNROOT/bin/dbn_alert MODEL GFS_ENKF $job $SFCANL -fi - - -############################################## -# End JOB SPECIFIC work -############################################## - -############################################## -# Final processing -############################################## -cat $pgmout - - -msg="ENDED NORMALLY." -postmsg "$jlogfile" "$msg" - - -########################################## -# Remove the Temporary working directory -########################################## -cd $DATAROOT -[[ $KEEPDATA = "NO" ]] && rm -rf $DATA - -date -exit 0 diff --git a/jobs/JGDAS_ENKF_UPDATE b/jobs/JGDAS_ENKF_UPDATE deleted file mode 100755 index cf461f09f..000000000 --- a/jobs/JGDAS_ENKF_UPDATE +++ /dev/null @@ -1,132 +0,0 @@ -#!/bin/ksh -set -x - -export RUN_ENVIR=${RUN_ENVIR:-"nco"} -export PS4='$SECONDS + ' -date - - -############################# -# Source relevant config files -############################# -configs="base anal eupd" -config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} -for config in $configs; do - . $config_path/config.$config - status=$? - [[ $status -ne 0 ]] && exit $status -done - - -########################################## -# Source machine runtime environment -########################################## -. $HOMEgfs/env/${machine}.env eupd -status=$? -[[ $status -ne 0 ]] && exit $status - - -############################################## -# Obtain unique process id (pid) and make temp directory -############################################## -export job=${job:-"eupd"} -export pid=${pid:-$$} -export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} -if [ $RUN_ENVIR = "nco" ]; then - export DATA="$DATAROOT/$jobid" -else - export DATAROOT="$RUNDIR/$CDATE/$CDUMP" - export DATA="$DATAROOT/$job" -fi -[[ -d $DATA ]] && rm -rf $DATA -mkdir -p $DATA -cd $DATA - - -############################################## -# Run setpdy and initialize PDY variables -############################################## -export cycle="t${cyc}z" -setpdy.sh -. ./PDY - - -############################################## -# Define the Log File directory -############################################## -export jlogfile=${jlogfile:-$COMROOT/logs/jlogfiles/jlogfile.${job}.${pid}} - - -############################################## -# Determine Job Output Name on System -############################################## -export pgmout="OUTPUT.${pid}" -export pgmerr=errfile - - -############################################## -# Set variables used in the exglobal script -############################################## -export CDATE=${CDATE:-${PDY}${cyc}} -export CDUMP=${CDUMP:-${RUN:-"gdas"}} -if [ $RUN_ENVIR = "nco" ]; then - export ROTDIR=${COMROOT:?}/$NET/$envir -fi - - -############################################## -# Begin JOB SPECIFIC work -############################################## - -GDATE=$($NDATE -$assim_freq $CDATE) -gPDY=$(echo $GDATE | cut -c1-8) -gcyc=$(echo $GDATE | cut -c9-10) - - -export APREFIX="${CDUMP}.t${cyc}z." -export ASUFFIX=".nemsio" -export GPREFIX="${CDUMP}.t${gcyc}z." -export GSUFFIX=".nemsio" - - -# COMIN_GES_ENS and COMOUT_ANL_ENS are used in exglobal script -# TO DO: Map NCO's directory into these variables -export COMIN_GES_ENS="$ROTDIR/enkf.$CDUMP.$gPDY/$gcyc" -export COMOUT_ANL_ENS="$ROTDIR/enkf.$CDUMP.$PDY/$cyc" - - -############################################################### -# Run relevant exglobal script -env -msg="HAS BEGUN on `hostname`" -postmsg "$jlogfile" "$msg" -$LOGSCRIPT - -${ENKFUPDSH:-$SCRgsi/exglobal_enkf_update_fv3gfs.sh.ecf} -status=$? -[[ $status -ne 0 ]] && exit $status - - -############################################## -# End JOB SPECIFIC work -############################################## - -############################################## -# Final processing -############################################## -cat $pgmout - - -msg="ENDED NORMALLY." -postmsg "$jlogfile" "$msg" - - -########################################## -# Remove the Temporary working directory -########################################## -cd $DATAROOT -[[ $KEEPDATA = "NO" ]] && rm -rf $DATA - -date -exit 0 diff --git a/jobs/JGLOBAL_ANALYSIS b/jobs/JGLOBAL_ANALYSIS index 97a8ce214..68883059c 100755 --- a/jobs/JGLOBAL_ANALYSIS +++ b/jobs/JGLOBAL_ANALYSIS @@ -9,6 +9,7 @@ date ############################# # Source relevant config files ############################# +export EXPDIR=${EXPDIR:-$HOMEgfs/parm/config} configs="base anal" config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} for config in $configs; do @@ -29,17 +30,10 @@ status=$? ############################################## # Obtain unique process id (pid) and make temp directory ############################################## -export job=${job:-"anal"} export pid=${pid:-$$} export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} -if [ $RUN_ENVIR = "nco" ]; then - export DATA="$DATAROOT/$jobid" -else - export DATAROOT="$RUNDIR/$CDATE/$CDUMP" - export DATA="$DATAROOT/$job" -fi -[[ -d $DATA ]] && rm -rf $DATA + +export DATA=${DATA:-${DATAROOT}/${jobid:?}} mkdir -p $DATA cd $DATA @@ -52,12 +46,6 @@ setpdy.sh . ./PDY -############################################## -# Define the Log File directory -############################################## -export jlogfile=${jlogfile:-$COMROOT/logs/jlogfiles/jlogfile.${job}.${pid}} - - ############################################## # Determine Job Output Name on System ############################################## @@ -82,26 +70,30 @@ fi GDATE=$($NDATE -$assim_freq $CDATE) gPDY=$(echo $GDATE | cut -c1-8) gcyc=$(echo $GDATE | cut -c9-10) - +GDUMP=${GDUMP:-"gdas"} export OPREFIX="${CDUMP}.t${cyc}z." -export GPREFIX="gdas.t${gcyc}z." +export GPREFIX="${GDUMP}.t${gcyc}z." export GSUFFIX=".nemsio" export APREFIX="${CDUMP}.t${cyc}z." export ASUFFIX=".nemsio" -if [ $RUN_ENVIR = "nco" ]; then +if [ $RUN_ENVIR = "nco" -o ${ROTDIR_DUMP:-NO} = "YES" ]; then export COMIN=${COMIN:-$ROTDIR/$RUN.$PDY/$cyc} export COMOUT=${COMOUT:-$ROTDIR/$RUN.$PDY/$cyc} + export COMIN_OBS=${COMIN_OBS:-$ROTDIR/$RUN.$PDY/$cyc} + export COMIN_GES_OBS=${COMIN_GES_OBS:-$ROTDIR/$GDUMP.$gPDY/$gcyc} else export COMOUT="$ROTDIR/$CDUMP.$PDY/$cyc" + export COMIN_OBS="$DMPDIR/$CDATE/$CDUMP" + export COMIN_GES_OBS="$DMPDIR/$GDATE/$GDUMP" fi mkdir -m 775 -p $COMOUT # COMIN_GES and COMIN_GES_ENS are used in exglobal script # TO DO: Map NCO's directory into these variables -export COMIN_GES="$ROTDIR/gdas.$gPDY/$gcyc" -export COMIN_GES_ENS="$ROTDIR/enkf.gdas.$gPDY/$gcyc" +export COMIN_GES="$ROTDIR/$GDUMP.$gPDY/$gcyc" +export COMIN_GES_ENS="$ROTDIR/enkfgdas.$gPDY/$gcyc" export ATMGES="$COMIN_GES/${GPREFIX}atmf006${GSUFFIX}" @@ -127,7 +119,13 @@ fi # Link observational data export PREPQC="${COMOUT}/${OPREFIX}prepbufr" +if [ ! -f $PREPQC ]; then + echo "WARNING: PREPBUFR FILE $PREPQC MISSING" + msg="WARNING : Global PREPBUFR file is missing" + postmsg "$jlogfile" "$msg" +fi export PREPQCPF="${COMOUT}/${OPREFIX}prepbufr.acft_profiles" +export TCVITL="${COMOUT}/${OPREFIX}syndata.tcvitals.tm00" [[ $DONST = "YES" ]] && export NSSTBF="${COMOUT}/${OPREFIX}nsstbufr" @@ -156,9 +154,9 @@ status=$? # Send Alerts ############################################## if [ $SENDDBN = YES -a $RUN = gdas ] ; then - $DBNROOT/bin/dbn_alert MODEL GDAS_MSC_abias $job $COMOUT/${PREINP}abias - $DBNROOT/bin/dbn_alert MODEL GDAS_MSC_abias_pc $job $COMOUT/${PREINP}abias_pc - $DBNROOT/bin/dbn_alert MODEL GDAS_MSC_abias_air $job $COMOUT/${PREINP}abias_air + $DBNROOT/bin/dbn_alert MODEL GDAS_MSC_abias $job $COMOUT/${APREFIX}abias + $DBNROOT/bin/dbn_alert MODEL GDAS_MSC_abias_pc $job $COMOUT/${APREFIX}abias_pc + $DBNROOT/bin/dbn_alert MODEL GDAS_MSC_abias_air $job $COMOUT/${APREFIX}abias_air fi @@ -169,7 +167,9 @@ fi ############################################## # Final processing ############################################## -cat $pgmout +if [ -e "$pgmout" ] ; then + cat $pgmout +fi msg="ENDED NORMALLY." diff --git a/jobs/JGLOBAL_ENKF_INNOVATE_OBS b/jobs/JGLOBAL_ENKF_INNOVATE_OBS new file mode 100755 index 000000000..b38fe48a4 --- /dev/null +++ b/jobs/JGLOBAL_ENKF_INNOVATE_OBS @@ -0,0 +1,172 @@ +#!/bin/ksh +set -x + +export RUN_ENVIR=${RUN_ENVIR:-"nco"} +export PS4='$SECONDS + ' +date + + +############################# +# Source relevant config files +############################# +export EXPDIR=${EXPDIR:-$HOMEgfs/parm/config} +configs="base anal eobs" +config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} +for config in $configs; do + . $config_path/config.$config + status=$? + [[ $status -ne 0 ]] && exit $status +done + + +########################################## +# Source machine runtime environment +########################################## +. $HOMEgfs/env/${machine}.env eobs +status=$? +[[ $status -ne 0 ]] && exit $status + + +############################################## +# Obtain unique process id (pid) and make temp directory +############################################## +export pid=${pid:-$$} +export outid=${outid:-"LL$job"} +export DATA=${DATA:-${DATAROOT}/${jobid:?}} +mkdir -p $DATA +cd $DATA + + +############################################## +# Run setpdy and initialize PDY variables +############################################## +export cycle="t${cyc}z" +setpdy.sh +. ./PDY + + +############################################## +# Determine Job Output Name on System +############################################## +export pgmout="OUTPUT.${pid}" +export pgmerr=errfile + + +############################################## +# Set variables used in the exglobal script +############################################## +export CDATE=${CDATE:-${PDY}${cyc}} +export CDUMP=${CDUMP:-${RUN:-"gdas"}} +if [ $RUN_ENVIR = "nco" ]; then + export ROTDIR=${COMROOT:?}/$NET/$envir +fi + + +############################################## +# Begin JOB SPECIFIC work +############################################## + +GDATE=$($NDATE -$assim_freq $CDATE) +gPDY=$(echo $GDATE | cut -c1-8) +gcyc=$(echo $GDATE | cut -c9-10) + + +export CASE=$CASE_ENKF + + +export OPREFIX="${CDUMP}.t${cyc}z." +export APREFIX="${CDUMP}.t${cyc}z." +export ASUFFIX=".nemsio" +export GPREFIX="gdas.t${gcyc}z." +export GSUFFIX=".nemsio" + + +# COMIN_GES, COMIN_GES_ENS and COMOUT are used in exglobal script +# TO DO: Map NCO's directory into these variables +COMIN_GES_CTL="$ROTDIR/gdas.$gPDY/$gcyc" +export COMIN_GES_ENS="$ROTDIR/enkfgdas.$gPDY/$gcyc" +export COMIN_GES=$COMIN_GES_ENS +export COMOUT="$ROTDIR/enkf$CDUMP.$PDY/$cyc" + + +export ATMGES_ENSMEAN="$COMIN_GES_ENS/${GPREFIX}atmf006.ensmean$GSUFFIX" +if [ ! -f $ATMGES_ENSMEAN ]; then + echo "FATAL ERROR: FILE MISSING: ATMGES_ENSMEAN = $ATMGES_ENSMEAN" + exit 1 +fi + + +export LEVS=$($NEMSIOGET $ATMGES_ENSMEAN dimz | awk '{print $2}') +status=$? +[[ $status -ne 0 ]] && exit $status + + +# Guess Bias correction coefficients related to control +export GBIAS=${COMIN_GES_CTL}/${GPREFIX}abias +export GBIASPC=${COMIN_GES_CTL}/${GPREFIX}abias_pc +export GBIASAIR=${COMIN_GES_CTL}/${GPREFIX}abias_air +export GRADSTAT=${COMIN_GES_CTL}/${GPREFIX}radstat + + +# Use the selected observations from ensemble mean +export RUN_SELECT="NO" +export USE_SELECT="YES" +export SELECT_OBS="$COMOUT/${APREFIX}obsinput.ensmean" + + +# Get ENSBEG/ENSEND from ENSGRP and NMEM_EOMGGRP +export ENSEND=$((NMEM_EOMGGRP * ENSGRP)) +export ENSBEG=$((ENSEND - NMEM_EOMGGRP + 1)) + + +############################################################### +# Run relevant exglobal script +env +msg="HAS BEGUN on `hostname`" +postmsg "$jlogfile" "$msg" +$LOGSCRIPT + + +${ENKFINVOBSSH:-$SCRgsi/exglobal_enkf_innovate_obs_fv3gfs.sh.ecf} +status=$? +[[ $status -ne 0 ]] && exit $status + + +# Double check the status of members in ENSGRP +EOMGGRP=$ROTDIR/enkf${CDUMP}.$PDY/$cyc/eomg.grp${ENSGRP} +npass=0 +if [ -f $EOMGGRP ]; then + npass=$(grep "PASS" $EOMGGRP | wc -l) +fi +echo "$npass/$NMEM_EOMGGRP members successfull in eomg.grp$ENSGRP" +if [ $npass -ne $NMEM_EOMGGRP ]; then + echo "FATAL ERROR: Failed members in $ENSGRP, ABORT!" + cat $EOMGGRP + exit 99 +fi + + +############################################## +# End JOB SPECIFIC work +############################################## + +############################################## +# Final processing +############################################## +if [ -e "$pgmout" ] ; then + cat $pgmout +fi + + +msg="ENDED NORMALLY." +postmsg "$jlogfile" "$msg" + + +########################################## +# Remove the Temporary working directory +########################################## +cd $DATAROOT +[[ $KEEPDATA = "NO" ]] && rm -rf $DATA + +date +exit 0 diff --git a/jobs/JGLOBAL_ENKF_SELECT_OBS b/jobs/JGLOBAL_ENKF_SELECT_OBS new file mode 100755 index 000000000..ce98032f0 --- /dev/null +++ b/jobs/JGLOBAL_ENKF_SELECT_OBS @@ -0,0 +1,200 @@ +#!/bin/ksh +set -x + +export RUN_ENVIR=${RUN_ENVIR:-"nco"} +export PS4='$SECONDS + ' +date + + +############################# +# Source relevant config files +############################# +export EXPDIR=${EXPDIR:-$HOMEgfs/parm/config} +configs="base anal eobs" +config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} +for config in $configs; do + . $config_path/config.$config + status=$? + [[ $status -ne 0 ]] && exit $status +done + + +########################################## +# Source machine runtime environment +########################################## +. $HOMEgfs/env/${machine}.env eobs +status=$? +[[ $status -ne 0 ]] && exit $status + + +############################################## +# Obtain unique process id (pid) and make temp directory +############################################## +export pid=${pid:-$$} +export outid=${outid:-"LL$job"} +export DATA=${DATA:-${DATAROOT}/${jobid:?}} +mkdir -p $DATA +cd $DATA + + +############################################## +# Run setpdy and initialize PDY variables +############################################## +export cycle="t${cyc}z" +setpdy.sh +. ./PDY + + +############################################## +# Determine Job Output Name on System +############################################## +export pgmout="OUTPUT.${pid}" +export pgmerr=errfile + + +############################################## +# Set variables used in the exglobal script +############################################## +export CDATE=${CDATE:-${PDY}${cyc}} +export CDUMP=${CDUMP:-${RUN:-"gdas"}} +if [ $RUN_ENVIR = "nco" ]; then + export ROTDIR=${COMROOT:?}/$NET/$envir +fi + + +############################################## +# Begin JOB SPECIFIC work +############################################## + +GDATE=$($NDATE -$assim_freq $CDATE) +gPDY=$(echo $GDATE | cut -c1-8) +gcyc=$(echo $GDATE | cut -c9-10) +GDUMP=${GDUMP:-"gdas"} + +export CASE=$CASE_ENKF +export CDUMP_OBS=${CDUMP_OBS:-$CDUMP} + + +export OPREFIX="${CDUMP_OBS}.t${cyc}z." +export APREFIX="${CDUMP}.t${cyc}z." +export ASUFFIX=".nemsio" +export GPREFIX="${GDUMP}.t${gcyc}z." +export GSUFFIX=".ensmean.nemsio" + +if [ $RUN_ENVIR = "nco" -o ${ROTDIR_DUMP:-NO} = "YES" ]; then + export COMIN_OBS=${COMIN_OBS:-$ROTDIR/$RUN.$PDY/$cyc} + export COMIN_GES_OBS=${COMIN_GES_OBS:-$ROTDIR/$GDUMP.$gPDY/$gcyc} +else + export COMIN_OBS="$DMPDIR/$CDATE/$CDUMP" + export COMIN_GES_OBS="$DMPDIR/$GDATE/$GDUMP" +fi + +# COMIN_GES, COMIN_ANL COMIN_GES_ENS, and COMOUT are used in exglobal script +# TO DO: Map NCO's directory into these variables +COMIN_GES_CTL="$ROTDIR/gdas.$gPDY/$gcyc" +export COMIN_ANL="$ROTDIR/$CDUMP.$PDY/$cyc" +export COMIN_GES_ENS="$ROTDIR/enkfgdas.$gPDY/$gcyc" +export COMIN_GES=$COMIN_GES_ENS +export COMOUT="$ROTDIR/enkf$CDUMP.$PDY/$cyc" + + +export ATMGES_ENSMEAN="$COMIN_GES_ENS/${GPREFIX}atmf006$GSUFFIX" +if [ ! -f $ATMGES_ENSMEAN ]; then + echo "FATAL ERROR: FILE MISSING: ATMGES_ENSMEAN = $ATMGES_ENSMEAN" + exit 1 +fi + +export LEVS=$($NEMSIOGET $ATMGES_ENSMEAN dimz | awk '{print $2}') +status=$? +[[ $status -ne 0 ]] && exit $status + +# Link observational data +export PREPQC="$COMIN_ANL/${OPREFIX}prepbufr" +if [ ! -f $PREPQC ]; then + echo "WARNING: PREPBUFR FILE $PREPQC MISSING" + msg="WARNING : Global PREPBUFR file is missing" + postmsg "$jlogfile" "$msg" +fi +export PREPQCPF="$COMIN_ANL/${OPREFIX}prepbufr.acft_profiles" +export TCVITL="$COMIN_ANL/${OPREFIX}syndata.tcvitals.tm00" +[[ $DONST = "YES" ]] && export NSSTBF="$COMIN_ANL/${OPREFIX}nsstbufr" + +# Guess Bias correction coefficients related to control +export GBIAS=${COMIN_GES_CTL}/${GPREFIX}abias +export GBIASPC=${COMIN_GES_CTL}/${GPREFIX}abias_pc +export GBIASAIR=${COMIN_GES_CTL}/${GPREFIX}abias_air +export GRADSTAT=${COMIN_GES_CTL}/${GPREFIX}radstat + +# Bias correction coefficients related to ensemble mean +export ABIAS="$COMOUT/${APREFIX}abias.ensmean" +export ABIASPC="$COMOUT/${APREFIX}abias_pc.ensmean" +export ABIASAIR="$COMOUT/${APREFIX}abias_air.ensmean" +export ABIASe="$COMOUT/${APREFIX}abias_int.ensmean" + +# Diagnostics related to ensemble mean +export GSISTAT="$COMOUT/${APREFIX}gsistat.ensmean" +export CNVSTAT="$COMOUT/${APREFIX}cnvstat.ensmean" +export OZNSTAT="$COMOUT/${APREFIX}oznstat.ensmean" +export RADSTAT="$COMOUT/${APREFIX}radstat.ensmean" + +# Select observations based on ensemble mean +export RUN_SELECT="YES" +export USE_SELECT="NO" +export SELECT_OBS="$COMOUT/${APREFIX}obsinput.ensmean" + +export DIAG_SUFFIX="_ensmean" + +# GSI namelist options specific to eobs +export SETUP_INVOBS="passive_bc=.false." + +# Ensure clean stat tarballs for ensemble mean +for fstat in $CNVSTAT $OZNSTAT $RADSTAT; do + [[ -f $fstat ]] && rm -f $fstat +done + + +############################################################### +# Run relevant exglobal script +env +msg="HAS BEGUN on `hostname`" +postmsg "$jlogfile" "$msg" +$LOGSCRIPT + + +${INVOBSSH:-$SCRgsi/exglobal_innovate_obs_fv3gfs.sh.ecf} +status=$? +[[ $status -ne 0 ]] && exit $status + + +############################################## +# Send Alerts +############################################## +if [ $SENDDBN = YES ] ; then + $DBNROOT/bin/dbn_alert MODEL ENKF1_MSC_gsistat $job $GSISTAT +fi + + +############################################## +# End JOB SPECIFIC work +############################################## + +############################################## +# Final processing +############################################## +if [ -e "$pgmout" ] ; then + cat $pgmout +fi + + +msg="ENDED NORMALLY." +postmsg "$jlogfile" "$msg" + + +########################################## +# Remove the Temporary working directory +########################################## +cd $DATAROOT +[[ $KEEPDATA = "NO" ]] && rm -rf $DATA + +date +exit 0 diff --git a/jobs/JGLOBAL_ENKF_UPDATE b/jobs/JGLOBAL_ENKF_UPDATE new file mode 100755 index 000000000..119a8c446 --- /dev/null +++ b/jobs/JGLOBAL_ENKF_UPDATE @@ -0,0 +1,129 @@ +#!/bin/ksh +set -x + +export RUN_ENVIR=${RUN_ENVIR:-"nco"} +export PS4='$SECONDS + ' +date + + +############################# +# Source relevant config files +############################# +export EXPDIR=${EXPDIR:-$HOMEgfs/parm/config} +configs="base anal eupd" +config_path=${EXPDIR:-$NWROOT/gfs.${gfs_ver}/parm/config} +for config in $configs; do + . $config_path/config.$config + status=$? + [[ $status -ne 0 ]] && exit $status +done + + +########################################## +# Source machine runtime environment +########################################## +. $HOMEgfs/env/${machine}.env eupd +status=$? +[[ $status -ne 0 ]] && exit $status + + +############################################## +# Obtain unique process id (pid) and make temp directory +############################################## +export pid=${pid:-$$} +export outid=${outid:-"LL$job"} +export DATA=${DATA:-${DATAROOT}/${jobid:?}} +mkdir -p $DATA +cd $DATA + + +############################################## +# Run setpdy and initialize PDY variables +############################################## +export cycle="t${cyc}z" +setpdy.sh +. ./PDY + + +############################################## +# Determine Job Output Name on System +############################################## +export pgmout="OUTPUT.${pid}" +export pgmerr=errfile + + +############################################## +# Set variables used in the exglobal script +############################################## +export CDATE=${CDATE:-${PDY}${cyc}} +export CDUMP=${CDUMP:-${RUN:-"gdas"}} +if [ $RUN_ENVIR = "nco" ]; then + export ROTDIR=${COMROOT:?}/$NET/$envir +fi + + +############################################## +# Begin JOB SPECIFIC work +############################################## + +GDATE=$($NDATE -$assim_freq $CDATE) +gPDY=$(echo $GDATE | cut -c1-8) +gcyc=$(echo $GDATE | cut -c9-10) + + +export APREFIX="${CDUMP}.t${cyc}z." +export ASUFFIX=".nemsio" +export GPREFIX="gdas.t${gcyc}z." +export GSUFFIX=".nemsio" + + +# COMIN_GES_ENS and COMOUT_ANL_ENS are used in exglobal script +# TO DO: Map NCO's directory into these variables +export COMIN_GES_ENS="$ROTDIR/enkfgdas.$gPDY/$gcyc" +export COMOUT_ANL_ENS="$ROTDIR/enkf$CDUMP.$PDY/$cyc" + + +############################################################### +# Run relevant exglobal script +env +msg="HAS BEGUN on `hostname`" +postmsg "$jlogfile" "$msg" +$LOGSCRIPT + +${ENKFUPDSH:-$SCRgsi/exglobal_enkf_update_fv3gfs.sh.ecf} +status=$? +[[ $status -ne 0 ]] && exit $status + + +############################################## +# Send Alerts +############################################## +if [ $SENDDBN = YES ] ; then + $DBNROOT/bin/dbn_alert MODEL ENKF1_MSC_enkfstat $job $COMOUT_ANL_ENS/${APREFIX}enkfstat +fi + + +############################################## +# End JOB SPECIFIC work +############################################## + +############################################## +# Final processing +############################################## +if [ -e "$pgmout" ] ; then + cat $pgmout +fi + + +msg="ENDED NORMALLY." +postmsg "$jlogfile" "$msg" + + +########################################## +# Remove the Temporary working directory +########################################## +cd $DATAROOT +[[ $KEEPDATA = "NO" ]] && rm -rf $DATA + +date +exit 0 diff --git a/lib/GSD/gsdcloud/ARPS_cldLib.f90 b/lib/GSD/gsdcloud/ARPS_cldLib.f90 deleted file mode 100644 index b1d6d0d1f..000000000 --- a/lib/GSD/gsdcloud/ARPS_cldLib.f90 +++ /dev/null @@ -1,1405 +0,0 @@ -! -!$$$ subprogram documentation block -! . . . . -! subprogram: ARPS_cldLib -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: -! -! ABSTRACT: -! This file include a collection of subroutines that are related to -! cloud analysis from ARPS cloud analysis -! -! PROGRAM HISTORY LOG: -! 2009-01-02 Hu Add NCO document block -! -! -! input argument list: -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! -! -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_STABILITY ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_stability (nz,t_1d,zs_1d,p_mb_1d,kbtm,ktop & - ,dte_dz_1d) -! -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! This routine returns stability at a given level given -! 1D temperature and pressure array inputs -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on LAPS cloud analysis code of 07/95 -! -! MODIFICATION HISTORY: -! -! 05/11/96 (J. Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - integer(i_kind),INTENT(IN) :: nz ! number of vertical model levels - REAL(r_single) ,INTENT(IN) :: t_1d(nz) ! temperature (degree Kelvin) profile - REAL(r_single) ,INTENT(IN) :: zs_1d(nz) ! heights (m MSL) of each level - REAL(r_single) ,INTENT(IN) :: p_mb_1d(nz)! pressure (mb) at each level - INTEGER(i_kind),INTENT(IN) :: kbtm,ktop ! indices of the bottom and top cloud layer -! -! OUTPUT: - REAL(r_single) ,INTENT(out):: dte_dz_1d(nz) ! stability array -! -! LOCAL: - REAL(r_single) :: thetae_1d(nz) ! (equivalent) potential temperature. -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind) :: k,km1,kp1,klow,khigh - REAL(r_single) :: os_fast -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Calculate Stability -! -!----------------------------------------------------------------------- -! - klow = MAX(kbtm-1,1) - khigh = MIN(ktop+1,nz-1) - - DO k = klow,khigh - thetae_1d(k) = os_fast(t_1d(k), p_mb_1d(k)) - END DO ! k - - dte_dz_1d=0._r_kind - - DO k = kbtm,ktop - km1 = MAX(k-1,1) - kp1 = MIN(k+1,nz-1) - - IF( (zs_1d(kp1) - zs_1d(km1)) <= 0._r_kind) THEN - write(6,*) 'GNRLCLD_mpi, get_stability: Error in get_stability ' - write(6,*) 'GNRLCLD_mpi, get_stability: k,kp1,km1 = ',k,kp1,km1 - write(6,*) 'GNRLCLD_mpi, get_stability: zs_1d(kp1),zs_1d(km1)= ',zs_1d(kp1),zs_1d(km1), & - (zs_1d(kp1) - zs_1d(km1)) - call STOP2(114) - ELSE - dte_dz_1d(k) = (thetae_1d(kp1) - thetae_1d(km1)) & - / (zs_1d(kp1) - zs_1d(km1)) - END IF - END DO ! k - - RETURN -END SUBROUTINE get_stability - - -! -!################################################################## -!################################################################## -!###### ###### -!###### FUNCTION OS_FAST ###### -!###### ###### -!################################################################## -!################################################################## -! - - FUNCTION os_fast(tk,p) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! THIS FUNCTION RETURNS THE EQUIVALENT POTENTIAL TEMPERATURE OS -! (K) FOR A PARCEL OF AIR SATURATED AT TEMPERATURE T (K) -! AND PRESSURE P (MILLIBARS). -! -! -!----------------------------------------------------------------------- -! -! AUTHOR: (BAKER,SCHLATTER) -! 05/17/1982 -! -! -! MODIFICATION HISTORY: -! 05/11/96 (Jian Zhang) -! Modified for ADAS grid. Add document stuff. -! -!----------------------------------------------------------------------- -! -! Variables declaration -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - REAL(r_single) ,INTENT(IN) :: tk ! temperature in kelvin - REAL(r_single) ,INTENT(IN) :: p ! pressure in mb -! -! OUTPUT: - REAL(r_single) :: os_fast ! equivalent potential temperature -! -! LOCAL: - REAL(r_kind) :: b ! empirical const. approx.= latent heat of - ! vaporiz'n for water devided by the specific - ! heat at const. pressure for dry air. - DATA b/2.6518986_r_kind/ - - REAL(r_kind) :: tc,x,w - REAL(r_kind) :: eslo -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - tc = tk - 273.15_r_kind -! -!----------------------------------------------------------------------- -! -! From W routine -! -!----------------------------------------------------------------------- -! - x= eslo(tc) - w= 622._r_kind*x/(p-x) - - os_fast= tk*((1000._r_kind/p)**.286_r_kind)*(EXP(b*w/tk)) - - RETURN - END FUNCTION os_fast - - - -! -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_CLOUDTYPE ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_cloudtype(temp_k,dte_dz,cbase_m,ctop_m & - ,itype,c2_type) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! This routine returns cloud type at a given point given -! temperature and stability inputs -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on the LAPS cloud analysis code of 05/1995 -! -! MODIFICATION HISTORY: -! -! 05/11/96 (J. Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - REAL(r_single),INTENT(IN) :: temp_k ! temperature - REAL(r_single),INTENT(IN) :: dte_dz ! stability factor - REAL(r_single),INTENT(IN) :: cbase_m ! height at cloud base level - REAL(r_single),INTENT(IN) :: ctop_m ! height at cloud top level -! -! OUTPUT: - INTEGER(i_kind),INTENT(out):: itype ! cloud type index - CHARACTER (LEN=2) :: c2_type -! -! LOCAL: - CHARACTER (LEN=2) :: c2_cldtyps(10) - - DATA c2_cldtyps /'St','Sc','Cu','Ns','Ac' & - ,'As','Cs','Ci','Cc','Cb'/ -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - REAL(r_kind) :: depth_m,temp_c -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - temp_c = temp_k - 273.15_r_kind - depth_m = ctop_m - cbase_m -! -!----------------------------------------------------------------------- -! -! Go from Stability to Cloud Type -! -!----------------------------------------------------------------------- -! - IF ( temp_c >= -10._r_kind) THEN - IF (dte_dz >= +.001_r_kind) THEN - itype = 1 ! St - ELSE IF (dte_dz < +.001_r_kind .AND. dte_dz >= -.001_r_kind) THEN - itype = 2 ! Sc - ELSE IF (dte_dz < -.001_r_kind .AND. dte_dz >= -.005_r_kind) THEN - itype = 3 ! Cu - ELSE ! dte_dz .lt. -.005 - IF(depth_m > 5000) THEN - itype = 10 ! Cb - ELSE ! depth < 5km - itype = 3 ! Cu - END IF - END IF - - ELSE IF (temp_c < -10._r_kind .AND. temp_c >= -20._r_kind) THEN - - IF (dte_dz < 0._r_kind) THEN - IF(depth_m > 5000) THEN - itype = 10 ! Cb - ELSE - itype = 5 ! Ac - END IF - ELSE - itype = 6 ! As - END IF - - ELSE ! temp_c.lt.-20. - - IF (dte_dz >= +.0005_r_kind) THEN - itype = 7 ! Cs - ELSE IF (dte_dz < +.0005_r_kind .AND. dte_dz >= -.0005_r_kind) THEN - itype = 8 ! Ci - ELSE ! dte_dz .lt. -.0005 - itype = 9 ! Cc - END IF - - IF(depth_m > 5000 .AND. dte_dz < -.0000_r_kind) THEN - itype = 10 ! Cb - END IF - - END IF - - c2_type = c2_cldtyps(itype) - - RETURN -END SUBROUTINE get_cloudtype - -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_SFM_1D ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_sfm_1d (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & - l_prt) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -!c----------------------------------------------------------------- -!c -!c This is the streamlined version of the Smith-Feddes -!c and Temperature Adjusted LWC calculation methodologies -!c produced at Purdue University under sponsorship -!c by the FAA Technical Center. -!c -!c Currently, this subroutine will only use the Smith- -!c Feddes and will only do so as if there are solely -!c stratiform clouds present, however, it is very easy -!c to switch so that only the Temperature Adjusted -!c method is used. -!c -!c Dilution by glaciation is also included, it is a -!c linear function of in cloud temperature going from -!c all liquid water at -10 C to all ice at -30 C -!c as such the amount of ice is also calculated -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on the LAPS cloud analysis code of 07/1995 -! -! MODIFICATION HISTORY: -! -! 05/16/96 (Jian Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind - IMPLICIT NONE -! -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind),intent(in) :: nz ! number of model vertical levels - REAL(r_single),intent(in) :: zs_1d(nz) ! physical height (m) at each scalar level - REAL(r_single),intent(in) :: p_mb_1d(nz)! pressure (mb) at each level - REAL(r_single),intent(in) :: t_1d(nz) ! temperature (K) at each level - - REAL(r_single),intent(in) :: zcb ! cloud base height (m) - REAL(r_single),intent(in) :: zctop ! cloud top height (m) -! -! OUTPUT: - REAL(r_single),intent(out) :: ql(nz) ! liquid water content (g/kg) - REAL(r_single),intent(out) :: qi(nz) ! ice water content (g/kg) - REAL(r_single),intent(out) :: cldt(nz) -! -! LOCAL: - REAL(r_single) :: calw(200) - REAL(r_single) :: cali(200) - REAL(r_single) :: catk(200) - REAL(r_single) :: entr(200) -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - REAL(r_single) :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso - REAL(r_single) :: c,a1,b1,c1,a2,b2,c2 - REAL(r_single) :: delz,delt,cldbtm,cldbp,cldtpt,tbar - REAL(r_single) :: arg,fraclw,tlwc - REAL(r_single) :: temp,press,zbase,alw,zht,ht,y - REAL(r_single) :: rl,es,qvs1,p,des,dtz,es2,qvs2 - INTEGER(i_kind):: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 - REAL(r_single) :: zcloud,entc,tmpk - LOGICAL :: l_prt -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Initialize 1d liquid water and ice arrays (for 100m layers) -! -!----------------------------------------------------------------------- -! - DO i=1,200 - calw(i)=0.0_r_single - cali(i)=0.0_r_single - END DO -! if(i_prt.le.20) then -! i_prt=i_prt+1 -! l_prt=.true. -! else -! l_prt=.false. -! endif -! -!----------------------------------------------------------------------- -! -! Preset some constants and coefficients. -! -!----------------------------------------------------------------------- -! - dz=100.0_r_single ! m - rv=461.5_r_single ! J/deg/kg - rair=287.04_r_single ! J/deg/kg - grav=9.81_r_single ! m/s2 - cp=1004._r_single ! J/deg/kg - rlvo=2.5003E+6_r_single ! J/kg - rlso=2.8339E+6_r_single ! J/kg - dlvdt=-2.3693E+3_r_single ! J/kg/K - eso=610.78_r_single ! pa - c=0.01_r_single - a1=8.4897_r_single - b1=-13.2191_r_single - c1=4.7295_r_single - a2=10.357_r_single - b2=-28.2416_r_single - c2=8.8846_r_single -! -!----------------------------------------------------------------------- -! -! Calculate indices of cloud top and base -! -!----------------------------------------------------------------------- -! - DO k=1,nz-1 - IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN - kcb=k - kcb1=kcb+1 - END IF - IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN - kctop=k - kctop1=kctop+1 - END IF - END DO -! -!----------------------------------------------------------------------- -! -! Obtain cloud base and top conditions -! -!----------------------------------------------------------------------- -! - delz = zs_1d(kcb+1)-zs_1d(kcb) - delt = t_1d(kcb+1)-t_1d(kcb) - cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) - tbar = (cldbtm+t_1d(kcb))/2._r_single - arg = -grav*(zcb-zs_1d(kcb))/rair/tbar - cldbp = p_mb_1d(kcb)*EXP(arg) - delz = zs_1d(kctop+1)-zs_1d(kctop) - delt = t_1d(kctop+1)-t_1d(kctop) - cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) -! -!----------------------------------------------------------------------- -! -! Calculate cloud lwc profile for cloud base/top pair -! -!----------------------------------------------------------------------- -! - temp = cldbtm - press = cldbp*100.0_r_single - zbase = zcb - nlevel = ((zctop-zcb)/100.0_r_single)+1 - IF(nlevel <= 0) nlevel=1 - alw = 0.0_r_single - calw(1)= 0.0_r_single - cali(1)= 0.0_r_single - catk(1)= temp - entr(1)= 1.0_r_single - nlm1 = nlevel-1 - IF(nlm1 < 1) nlm1=1 - zht = zbase - - DO j=1,nlm1 - rl = rlvo+(273.15_r_single-temp)*dlvdt - arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv - es = eso*EXP(arg) - qvs1 = 0.622_r_single*es/(press-es) -! rho1 = press/(rair*temp) - arg = -grav*dz/rair/temp - p = press*EXP(arg) -! -!----------------------------------------------------------------------- -! -! Calculate saturated adiabatic lapse rate -! -!----------------------------------------------------------------------- -! - des = es*rl/temp/temp/rv - dtz = -grav*((1.0_r_single+0.621_r_single*es*rl/(press*rair*temp))/ & - (cp+0.621_r_single*rl*des/press)) - zht = zht+dz - press = p - temp = temp+dtz*dz - rl = rlvo+(273.15_r_single-temp)*dlvdt - arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv - es2 = eso*EXP(arg) - qvs2 = 0.622_r_single*es2/(press-es2) - - alw = alw+(qvs1-qvs2) ! kg/kg - calw(j+1) = alw -! -!----------------------------------------------------------------------- -! -! Reduction of lwc by entrainment -! -!----------------------------------------------------------------------- -! - ht = (zht-zbase)*.001_r_single -! -!c ------------------------------------------------------------------ -!c -!c skatskii's curve(convective) -!c -!c ------------------------------------------------------------------ -!c if(ht.lt.0.3) then -!c y = -1.667*(ht-0.6) -!c elseif(ht.lt.1.0) then -!c arg1 = b1*b1-4.0*a1*(c1-ht) -!c y = (-b1-sqrt(arg1))/(2.0*a1) -!c elseif(ht.lt.2.9) then -!c arg2 = b2*b2-4.0*a2*(c2-ht) -!c y = (-b2-sqrt(arg2))/(2.0*a2) -!c else -!c y = 0.26 -!c endif -!c -!c ------------------------------------------------------------------ -!c -!c warner's curve(stratiform) -!c -!c ------------------------------------------------------------------ - IF(ht < 0.032_r_single) THEN - y = -11.0_r_single*ht+1.0_r_single ! y(ht=0.032) = 0.648 - ELSE IF(ht <= 0.177_r_single) THEN - y = -1.4_r_single*ht+0.6915_r_single ! y(ht=0.177) = 0.4437 - ELSE IF(ht <= 0.726_r_single) THEN - y = -0.356_r_single*ht+0.505_r_single ! y(ht=0.726) = 0.2445 - ELSE IF(ht <= 1.5_r_single) THEN - y = -0.0608_r_single*ht+0.2912_r_single ! y(ht=1.5) = 0.2 - ELSE - y = 0.20_r_single - END IF -! -!----------------------------------------------------------------------- -! -! Calculate reduced lwc by entrainment and dilution -! -! Note at -5 C and warmer, all liquid. ! changed from -10 KB -! at -25 C and colder, all ice ! changed from -30 KB -! Linear ramp between. -! -!----------------------------------------------------------------------- -! - IF(temp < 268.15_r_single) THEN - IF(temp > 248.15_r_single) THEN - fraclw=0.05*(temp-248.15_r_single) - ELSE - fraclw=0.0_r_single - END IF - ELSE - fraclw=1.0_r_single - END IF - - tlwc=1000._r_single*y*calw(j+1) ! g/kg - calw(j+1)=tlwc*fraclw - cali(j+1)=tlwc*(1._r_single-fraclw) - catk(j+1)=temp - entr(j+1)=y - - END DO -! -!----------------------------------------------------------------------- -! -! Obtain profile of LWCs at the given grid point -! -!----------------------------------------------------------------------- -! - DO ip=2,nz-1 - IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN - ql(ip)=0.0_r_single - qi(ip)=0.0_r_single - cldt(ip)=t_1d(ip) - ELSE - DO j=2,nlevel - zcloud = zcb+(j-1)*dz - IF(zcloud >= zs_1d(ip)) THEN - ql(ip) = (zs_1d(ip)-zcloud+100._r_single)* & - (calw(j)-calw(j-1))*0.01_r_single+calw(j-1) - qi(ip) = (zs_1d(ip)-zcloud+100._r_single)* & - (cali(j)-cali(j-1))*0.01_r_single+cali(j-1) - tmpk = (zs_1d(ip)-zcloud+100._r_single)* & - (catk(j)-catk(j-1))*0.01_r_single & - +catk(j-1) - entc = (zs_1d(ip)-zcloud+100._r_single)* & - (entr(j)-entr(j-1))*0.01_r_single & - +entr(j-1) - cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk - - EXIT - END IF - END DO - END IF - END DO -! - RETURN -END SUBROUTINE get_sfm_1d - - -! -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE PCP_TYPE_3D ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE pcp_type_3d (nx,ny,nz,temp_3d,rh_3d,p_pa_3d & - ,radar_3d,l_mask,cldpcp_type_3d,istatus) - -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! This routine returns 3D cloud and precipitation type field. -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/1996 Based on the LAPS cloud analysis code developed by -! Steve Albers. -! -! This program modifies the most significant 4 bits of the integer -! array by inserting multiples of 16. -! -! MODIFICATION HISTORY: -! -! 05/16/96 (J. Zhang) -! Modified for ADAS format. Added full documentation. -! 01/20/98 (J. Zhang) -! Fixed a bug that no precip. type was assigned for a -! grid point at the top of the radar echo with Tw -! falling in the range of 0 to 1.3 degree C. -! 01/21/98 (J. Zhang) -! Fixed a bug that does the freezing/refreezing test -! on ice precipitates. -! 02/17/98 (J. Zhang) -! Change the hail diagnose procedure. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind, r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind), intent(in) :: nx,ny,nz ! Model grid size - REAL(r_single), intent(in) :: temp_3d(nx,ny,nz) ! temperature (K) - REAL(r_single), intent(in) :: rh_3d(nx,ny,nz) ! relative humudity - REAL(r_single), intent(in) :: p_pa_3d(nx,ny,nz) ! pressure (Pascal) - REAL(r_kind), intent(in) :: radar_3d(nx,ny,nz) ! radar refl. (dBZ) -! -! OUTPUT: - INTEGER(i_kind), intent(out) :: istatus - INTEGER(i_kind), intent(out) :: cldpcp_type_3d(nx,ny,nz)! cld/precip type - LOGICAL :: l_mask(nx,ny) ! "Potential" Precip Type -! -! LOCAL functions: - REAL(r_kind) :: wb_melting_thres ! define melting temp. thresh. - REAL(r_kind) :: tw ! for wet-bulb temp calcl'n -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind) :: itype ! cld/precip type index - INTEGER(i_kind) :: i,j,k,k_upper - REAL(r_kind) :: t_c,td_c,t_wb_c,temp_lower_c,temp_upper_c,tbar_c & - ,p_mb,thickns,frac_below_zero - INTEGER(i_kind) :: iprecip_type,iprecip_type_last,iflag_melt & - ,iflag_refreez - REAL(r_kind) :: zero_c,rlayer_refreez_max,rlayer_refreez - INTEGER(i_kind) :: n_zr,n_sl,n_last - REAL(r_kind) :: tmelt_c,x -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -!----------------------------------------------------------------------- -! - return - istatus=0 - wb_melting_thres = 1.3 ! Units are C -! -!----------------------------------------------------------------------- -! -! Stuff precip type into cloud type array -! 0 - No Precip -! 1 - Rain -! 2 - Snow -! 3 - Freezing Rain -! 4 - Sleet -! 5 - Hail -! -!----------------------------------------------------------------------- -! - zero_c = 273.15_r_kind - rlayer_refreez_max = 0.0_r_kind - - n_zr = 0 - n_sl = 0 - n_last = 0 - - DO j = 1,ny-1 - DO i = 1,nx-1 - - iflag_melt = 0 - iflag_refreez = 0 - rlayer_refreez = 0.0_r_kind - - iprecip_type_last = 0 - - DO k = nz-1,1,-1 - - IF(radar_3d(i,j,k) >= 0._r_kind.OR. l_mask(i,j)) THEN -! -!----------------------------------------------------------------------- -! -! Set refreezing flag -! -!----------------------------------------------------------------------- -! - t_c = temp_3d(i,j,k) - zero_c -! compute dew point depression. -! td_c = dwpt(t_c,rh_3d(i,j,k)) - x = 1._r_kind-0.01_r_kind*rh_3d(i,j,k) - td_c =t_c-(14.55_r_kind+0.114_r_kind*t_c)*x+ & - ((2.5_r_kind+0.007_r_kind*t_c)*x)**3+ & - (15.9_r_kind+0.117_r_kind*t_c)*x**14 - - p_mb = 0.01_r_kind*p_pa_3d(i,j,k) - - tmelt_c = wb_melting_thres - t_wb_c = tw(t_c,td_c,p_mb) - - IF(t_wb_c < 0._r_kind) THEN - IF(iflag_melt == 1) THEN -! -!----------------------------------------------------------------------- -! -! Integrate below freezing temperature times column thickness -! - ONLY for portion of layer below freezing -! -!----------------------------------------------------------------------- -! - temp_lower_c = t_wb_c - k_upper = MIN(k+1,nz-1) -! -!----------------------------------------------------------------------- -! -! For simplicity and efficiency, the assumption is here made that -! the wet bulb depression is constant throughout the level. -! -!----------------------------------------------------------------------- -! - temp_upper_c = t_wb_c + ( temp_3d(i,j,k_upper) & - - temp_3d(i,j,k)) - IF(temp_upper_c <= 0._r_kind) THEN - frac_below_zero = 1.0_r_kind - tbar_c = 0.5_r_kind * (temp_lower_c + temp_upper_c) - - ELSE ! Layer straddles the freezing level - frac_below_zero = temp_lower_c & - / (temp_lower_c - temp_upper_c) - tbar_c = 0.5_r_kind * temp_lower_c - - END IF - - thickns = p_pa_3d(i,j,k_upper) - p_pa_3d(i,j,k) - rlayer_refreez = rlayer_refreez & - + ABS(tbar_c * thickns * frac_below_zero) - - IF(rlayer_refreez >= 25000._r_kind) THEN - iflag_refreez = 1 - END IF - - rlayer_refreez_max = & - MAX(rlayer_refreez_max,rlayer_refreez) - - END IF ! iflag_melt = 1 - - ELSE ! Temp > 0C - iflag_refreez = 0 - rlayer_refreez = 0.0 - - END IF ! T < 0.0c, Temp is below freezing -! -!----------------------------------------------------------------------- -! -! Set melting flag -! -!----------------------------------------------------------------------- -! - IF(t_wb_c >= tmelt_c) THEN - iflag_melt = 1 - END IF - - IF(t_wb_c >= tmelt_c) THEN ! Melted to Rain - iprecip_type = 1 - - ELSE ! Check if below zero_c (Refrozen Precip or Snow) - IF(t_wb_c < 0.0_r_kind) THEN - IF(iflag_melt == 1) THEN - IF(iprecip_type_last == 1 .OR.iprecip_type_last == 3) THEN - ! test if rain or zr freeze - IF(iflag_refreez == 0) THEN ! Freezing Rain - n_zr = n_zr + 1 - IF(n_zr < 30) THEN -! WRITE(6,5)i,j,k,t_wb_c,temp_3d(i,j,k) & -! ,rh_3d(i,j,k) - 5 FORMAT('zr',3I3,2F8.2,f8.1) - END IF - iprecip_type = 3 - - ELSE ! (iflag_refreez = 1) ! Sleet - n_sl = n_sl + 1 - iprecip_type = 4 - END IF ! iflag_refreez .eq. 0 - ELSE - iprecip_type = iprecip_type_last ! Unchanged - n_last = n_last + 1 - IF(n_last < 5) THEN -! WRITE(6,*)'Unchanged Precip',i,j,k,t_wb_c - END IF - END IF ! liquid precip. at upper level? - - ELSE ! iflag_melt =0 ! Snow - iprecip_type = 2 - - END IF ! iflag_melt = 1? - ELSE ! t_wb_c >= 0c, and t_wb_c < tmelt_c - - IF (iprecip_type_last == 0) THEN ! 1/20/98 - iprecip_type = 1 ! rain:at echo top and 0= tmelt_c - - ELSE ! radar_3d < 0dBZ; No Radar Echo - iprecip_type = 0 - iflag_melt = 0 - iflag_refreez = 0 - rlayer_refreez = 0.0_r_kind - - END IF ! radar_3d(i,j,k).ge.0. .or. l_mask(i,j); Radar Echo? -! -!----------------------------------------------------------------------- -! -! Insert most sig 4 bits into array -! -!----------------------------------------------------------------------- -! - itype = cldpcp_type_3d(i,j,k) - itype = itype - (itype/16)*16 ! Initialize the 4 bits - itype = itype + iprecip_type * 16 ! Add in the new value - cldpcp_type_3d(i,j,k) = itype - - iprecip_type_last = iprecip_type - - END DO ! k - END DO ! j - END DO ! i - - DO j = 1,ny-1 - DO i = 1,nx-1 - DO k = 1,nz-1 - IF(radar_3d(i,j,k) >= 50._r_kind) THEN - iprecip_type = 5 - itype = cldpcp_type_3d(i,j,k) - itype = itype - (itype/16)*16 ! Initialize the 4 bits - itype = itype + iprecip_type * 16 ! Add in the new value - cldpcp_type_3d(i,j,k) = itype - END IF - END DO ! k - END DO ! j - END DO ! i - - istatus=1 - - RETURN -END SUBROUTINE pcp_type_3d - -! -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_SLWC1D ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_slwc1d (nk,cbase_m,ctop_m,kbase,ktop & - ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) - -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! This routine calls a subroutine "lwc_rep" which calculates -! the adiabatic liquid water content. -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on the LAPS cloud analysis code of 07/1995 -! -! MODIFICATION HISTORY: -! -! 05/13/96 (Jian Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind),intent(in) :: iflag_slwc ! indicator for LWC scheme option - INTEGER(i_kind),intent(in) :: nk ! number of model vertical levels - REAL(r_single),intent(in) :: t_1d(nk) ! temperature (k) in one model column - REAL(r_single),intent(in) :: zs_1d(nk) ! heights (m) at grd pts in one model column - REAL(r_single),intent(in) :: p_pa_1d(nk) ! pressure (pa) in one model column - REAL(r_single),intent(in) :: cbase_m,ctop_m ! heights (m) of cloud base and top levels - INTEGER(i_kind),intent(in) :: kbase,ktop ! vertical index of cloud base and top levels -! -! OUTPUT: - REAL(r_single),intent(out) :: slwc_1d(nk) ! estimated adiabatic liquid water -! -! LOCAL: - INTEGER(i_kind) :: i_status1,i_status2 ! flag for subroutine calling -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind):: k - REAL(r_single) :: p_low,p_high,cbase_pa,cbase_k,ctop_k,frac_k & - ,grid_top_pa,grid_top_k - REAL(r_single) :: fraction,thickness,dlog_space - REAL(r_single) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Initialize -! -!----------------------------------------------------------------------- -! - DO k = 1,nk - slwc_1d(k) = 0.0_r_single - END DO - - IF(ctop_m > cbase_m) THEN -! -!----------------------------------------------------------------------- -! -! Determine Lowest and Highest Grid Points within the cloud -! -!----------------------------------------------------------------------- -! - IF(ktop >= kbase .AND. kbase >= 2) THEN -! -!----------------------------------------------------------------------- -! -! Get cloud base pressure and temperature -! -!----------------------------------------------------------------------- -! - cbase_pa = -999._r_single ! Default value is off the grid - DO k = 1,nk-2 - IF(zs_1d(k+1) > cbase_m .AND. zs_1d(k) <= cbase_m) THEN - thickness = zs_1d(k+1) - zs_1d(k) - fraction = (cbase_m - zs_1d(k))/thickness - p_low = p_pa_1d(k) - p_high = p_pa_1d(k+1) - dlog_space = LOG(p_high/p_low) - cbase_pa = p_low * EXP(dlog_space*fraction) - END IF - END DO ! k - - frac_k=(cbase_m-zs_1d(kbase-1))/(zs_1d(kbase)-zs_1d(kbase-1)) - IF(frac_k /= fraction) & - PRINT*,' **GET_SLWC1D** frac=',fraction,' frac_k=',frac_k - - cbase_k = t_1d(kbase-1)*(1.0_r_single-frac_k) + t_1d(kbase)*frac_k -! -!----------------------------------------------------------------------- -! -! Get cloud top temperature -! -!----------------------------------------------------------------------- -! - frac_k = (ctop_m-zs_1d(ktop-1)) / (zs_1d(ktop)-zs_1d(ktop-1)) - ctop_k = t_1d(ktop-1)*(1.0_r_single - frac_k) + t_1d(ktop) * frac_k -! -!----------------------------------------------------------------------- -! -! Calculate SLWC at each vertical grid point. For each level -! we use an assumed cloud extending from the actual cloud base -! to the height of the grid point in question. -! -!----------------------------------------------------------------------- -! - DO k=kbase,ktop - grid_top_pa = p_pa_1d(k) - grid_top_k = t_1d(k) - - CALL slwc_revb(cbase_pa,cbase_k & - ,grid_top_pa,grid_top_k,ctop_k & - ,adiabatic_lwc,adjusted_lwc,adjusted_slwc & - ,i_status1,i_status2) -! - IF(i_status2 == 1) THEN - IF(iflag_slwc == 1) THEN - slwc_1d(k) = adiabatic_lwc - ELSE IF(iflag_slwc == 2) THEN - slwc_1d(k) = adjusted_lwc - ELSE IF(iflag_slwc == 3) THEN - slwc_1d(k) = adjusted_slwc - END IF - ELSE - WRITE(6,*)' Error Detected in SLWC' - END IF - END DO ! k - END IF ! ktop > kbase & kbase > 2, thick enough cloud exists - END IF ! ctop_m > cbase_m, cloud exists - - RETURN -END SUBROUTINE get_slwc1d - -SUBROUTINE slwc_revb(cb_pa,cb_k,gt_pa,gt_k,ct_k, & - adiabatic_lwc,adjusted_lwc,adjusted_slwc, & - i_status1,i_status2) -! -!.......................HISTORY............................. -! -! WRITTEN: CA. 1982 BY W. A. COOPER IN HP FORTRAN 4 -! -!....... CALCULATES TEMPERATURE T AND LIQUID WATER CONTENT FROM -!.. CLOUD BASE PRESSURE P0 AND TEMPERATURE T0, FOR ADIABATIC -!.. ASCENT TO THE PRESSURE P. -!.. -> INPUT: CLOUD BASE PRESSURE P0 AND TEMPERATURE T0 -!.. PRESSURE AT OBSERVATION LEVEL P -!.. -> OUTPUT: "ADIABATIC" TEMPERATURE T AND LIQUID WATER CONTENT -! -! MODIFIED: November 1989 by Paul Lawson for LAPS/WISP. Routine -! now calculates adiabatic liquid water content -! (ADIABATIC_LWC) using cloud base pressure and grid-top -! temperature and pressure. Also calculated are ADJUSTED_LWC, -! which adjusts ADIABATIC_LWC using an empirical cloud -! water depletion algorithm, and ADJUSTED_SLWC, which is -! ADIABATIC_LWC in regions where T < 0 C adjusted -! using an empirical algorithm by Marcia Politovich. -! -! Subroutine is now hardwired for stratiform cloud only. -! Can be modified to include Cu with input from LAPS main. -! -! revb: ca 12/89 Calculate adiabatic lwc by going from cloud -! base to LAPS grid level instead to cloud top, thus -! helping to better calculate in layer clouds. -! Add TG (grid temperature) to calcualtion. -! -! revc: 2/27/90 Correct error in code. Zero-out slwc when grid -! temperature (GT) > 0. -! -! J.Z.: 4/7/97 Correct error in code -! Grid temperature should be TG, not GT. -! -! -! OUTPUTS: ADIABATIC_LWC -! ADJUSTED_LWC -! ADJUSTED_SLWC -! I_STATUS1 - 1 when -20 < cld_top_temp < 0 for Stratus -! 0 Otherwise -! I_STATUS2 - 1 when valid input data provided from main -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE - - real(r_single), intent(in) :: cb_pa,cb_k,gt_pa,gt_k,ct_k - real(r_single), intent(out) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc - INTEGER(i_kind),intent(out) :: i_status1,i_status2 - - real(r_kind) :: eps,cpd,cw,rd,alhv - DATA eps/0.622_r_kind/,cpd/1.0042E3_r_kind/,cw/4.218E3_r_kind/,rd/287.05_r_kind/,alhv/2.501E6_r_kind/ - INTEGER(i_kind) :: cty,i - real(r_kind) :: p0,p,t0,tg,ctt,tk,e,r,cpt,t1,thetaq,rv,t,tw - real(r_kind) :: vapor -! -! - i_status1=1 - i_status2=1 -! 2 Print *,'ENTER: P-BASE(mb), T-BASE(C), P-TOP, T-TOP, CLD TYPE' -! READ(5,*) P0, T0, P, CTT, CTY -! If(CTY.ne.0.and.CTY.ne.1) Go to 2 -! -! Hardwire cloud type (CTY) for stratus for now -! - cty=0 -! -!.....Convert Pa to mb and Kelvin to Celcius -! - p0 = cb_pa/100._r_kind - p = gt_pa/100._r_kind - t0 = cb_k - 273.15_r_kind - tg = gt_k - 273.15_r_kind - ctt= ct_k - 273.15_r_kind -! Print *, 'CTT in Sub = ', CTT -! -! Check for valid input data... -! - IF(p0 > 1013._r_kind.OR.p0 < 50._r_kind) THEN - i_status2=0 - RETURN - ELSE - END IF -! -! - IF(t0 > 50._r_kind.OR.t0 < -70._r_kind) THEN - i_status2=0 - RETURN - ELSE - END IF -! -! - IF(p > 1013._r_kind.OR.p < 50._r_kind) THEN - i_status2=0 - RETURN - ELSE - END IF -! -! Set I_STATUS1 = F if 0 < cld top < -20 C (for stratus). -! - IF(tg >= 0._r_kind.OR.ctt < -20._r_kind) i_status1=0 -! - tk=t0+273.15_r_kind - e=vapor(t0) - r=eps*e/(p0-e) - cpt=cpd+r*cw - thetaq=tk*(1000._r_kind/(p0-e))**(rd/cpt)*EXP(alhv*r/(cpt*tk)) -! 1ST APPROX - t1=tk - e=vapor(t1-273.15_r_kind) - rv=eps*e/(p-e) - t1=thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) -! SUCCESSIVE APPROXIMATIONS - DO i=1,10 - e=vapor(t1-273.15_r_kind) - rv=eps*e/(p-e) - t1=(thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) & - +t1)/2._r_kind - t=t1-273.15_r_kind -! Print *, P0,T0,P,T,E,RV,THETAQ - END DO -! GET LWC - e=vapor(t) - rv=eps*e/(p-e) - tw=r-rv - adiabatic_lwc=tw*p*28.9644_r_kind/(8.314E7_r_kind*t1)*1.e9_r_kind - IF(adiabatic_lwc < 0._r_kind) adiabatic_lwc=0._r_kind -! Print *, 'Adiabtic LWC = ', ADIABATIC_LWC - IF(tg >= 0._r_kind) THEN -! - adjusted_slwc=0._r_kind ! Added 2/27/90 -! - - IF(cty == 0._r_kind) THEN - IF(ctt < -20._r_kind) THEN - adjusted_lwc=0._r_kind - ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN - adjusted_lwc=adiabatic_lwc/8._r_kind - ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN - adjusted_lwc=adiabatic_lwc/4._r_kind - ELSE - adjusted_lwc=adiabatic_lwc/2._r_kind - END IF - ELSE - IF(ctt < -25._r_kind) THEN - adjusted_lwc=0._r_kind - ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN - adjusted_lwc=adiabatic_lwc/8._r_kind - ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN - adjusted_lwc=adiabatic_lwc/4._r_kind - ELSE - adjusted_lwc=adiabatic_lwc/2._r_kind - END IF - END IF - ELSE - IF(cty == 0._r_kind) THEN - IF(ctt < -20._r_kind) THEN - adjusted_lwc=0._r_kind - adjusted_slwc=0._r_kind - ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN - adjusted_lwc=adiabatic_lwc/8._r_kind - adjusted_slwc=adiabatic_lwc/8._r_kind - ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN - adjusted_lwc=adiabatic_lwc/4._r_kind - adjusted_slwc=adiabatic_lwc/4._r_kind - ELSE - adjusted_lwc=adiabatic_lwc/2._r_kind - adjusted_slwc=adiabatic_lwc/2._r_kind - END IF - ELSE - IF(ctt < -25._r_kind) THEN - adjusted_lwc=0._r_kind - adjusted_slwc=0._r_kind - ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN - adjusted_lwc=adiabatic_lwc/8._r_kind - adjusted_slwc=adiabatic_lwc/8._r_kind - ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN - adjusted_lwc=adiabatic_lwc/4._r_kind - adjusted_slwc=adiabatic_lwc/4._r_kind - ELSE - adjusted_lwc=adiabatic_lwc/2._r_kind - adjusted_slwc=adiabatic_lwc/2._r_kind - END IF - END IF - END IF -! Print *,'Adjusted LWC = ', ADJUSTED_LWC -! Print *,'Adjusted SLWC = ', ADJUSTED_SLWC -END SUBROUTINE slwc_revb - -! FUNCTION TO CALCULATE VAPOR PRESSURE: -! - - FUNCTION vapor(tfp) -! INPUT IS IN DEGREES C. IF GT 0, ASSUMED TO BE DEW POINT. IF -! LESS THAN 0, ASSUMED TO BE FROST POINT. -! ROUTINE CODES GOFF-GRATCH FORMULA - use kinds, only: i_kind,r_kind - IMPLICIT NONE - - real(r_kind), intent(in) :: tfp - real(r_kind) :: vapor - -! - real(r_kind) :: tvap, e - - tvap=273.16_r_kind+tfp - IF(tfp > 0.) GO TO 1 -! THIS IS ICE SATURATION VAPOR PRESSURE - IF(tvap <= 0) tvap=1E-20_r_kind - e=-9.09718_r_kind*(273.16_r_kind/tvap-1._r_kind)- & - 3.56654_r_kind*LOG10(273.16_r_kind/tvap) & - +0.876793_r_kind*(1.-tvap/273.16_r_kind) - vapor=6.1071_r_kind*10._r_kind**e - RETURN - 1 CONTINUE -! THIS IS WATER SATURATION VAPOR PRESSURE - IF(tvap <= 0) tvap=1E-20_r_kind - e=-7.90298_r_kind*(373.16_r_kind/tvap-1._r_kind)+ & - 5.02808_r_kind*LOG10(373.16_r_kind/tvap) & - -1.3816E-7_r_kind*(10._r_kind**(11.344_r_kind*& - (1._r_kind-tvap/373.16_r_kind))-1._r_kind) & - +8.1328E-3_r_kind*(10._r_kind**(3.49149_r_kind& - *(1-373.16_r_kind/tvap))-1) - vapor=1013.246_r_kind*10._r_kind**e - RETURN - END FUNCTION vapor diff --git a/lib/GSD/gsdcloud/BackgroundCld.f90 b/lib/GSD/gsdcloud/BackgroundCld.f90 deleted file mode 100644 index f72a1b00b..000000000 --- a/lib/GSD/gsdcloud/BackgroundCld.f90 +++ /dev/null @@ -1,315 +0,0 @@ -SUBROUTINE BackgroundCldgfs(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: BackgroundCld Ingest gfs background fields for cloud analysis -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 -! -! ABSTRACT: -! This subroutine reads in background hydrometeor fields for cloud analysis -! -! PROGRAM HISTORY LOG: -! 2009-01-02 Hu Add NCO document block -! 2010-04-26 Hu delete the module gridmod and guess_grids. -! transfer information subroutine dummy variables -! -! -! input argument list: -! mype - processor ID -! lon2 - no. of lons on subdomain (buffer points on ends) -! lat2 - no. of lats on subdomain (buffer points on ends) -! nsig - no. of vertical levels -! tbk - 3D background potential temperature (K) -! psbk - 2D background surface pressure (hPa) -! q - 3D moisture (water vapor mixing ratio kg/kg) -! pbk - 3D background pressure (hPa) -! -! output argument list: -! hbk - 3D height above the ground (not the sea level) -!!!! z_lcl - lifting condensation level -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind,r_kind - use constants, only: rd_over_cp, h1000 - use constants, only: rd, grav, half, rad2deg - - implicit none - - integer(i_kind),intent(in):: mype - integer(i_kind),intent(in):: lon2 - integer(i_kind),intent(in):: lat2 - integer(i_kind),intent(in):: nsig - -! background -! -! read in from WRF -! - real(r_single),intent(inout) :: tbk(lon2,lat2,nsig) ! temperature - real(r_single),intent(in) :: psbk(lon2,lat2) ! surface pressure - real(r_single),intent(inout) :: q(lon2,lat2,nsig) ! moisture - real(r_single),intent(in) :: pbk(lon2,lat2,nsig) ! pressure hPa -! -! derived fields -! - real(r_single),intent(out) :: hbk(lon2,lat2,nsig)! height -! -! misc. -! - INTEGER :: i,j,k - - REAL(r_single) :: rdog, h, dz - REAL(r_single) :: height(nsig+1) - -! -!================================================================ -! - do k=1,nsig - do j=1,lat2 - do i=1,lon2 - q(i,j,k) = q(i,j,k)/(1.0_r_kind-q(i,j,k)) ! water vapor mixing ratio (kg/kg) - enddo - enddo - enddo - -! -! Compute geopotential height above the ground at midpoint of each layer -! - rdog = rd/grav - do j=1,lat2 - do i=1,lon2 - k = 1 - h = rdog * tbk(i,j,k) - dz = h * log(psbk(i,j)/pbk(i,j,k)) - height(k) = dz - - do k=2,nsig - h = rdog * half * (tbk(i,j,k-1)+tbk(i,j,k)) - dz = h * log(pbk(i,j,k-1)/pbk(i,j,k)) - height(k) = height(k-1) + dz - end do - - do k=1,nsig - hbk(i,j,k)=height(k) - end do - end do - end do - - do k=1,nsig - do j=1,lat2 - do i=1,lon2 - tbk(i,j,k)=tbk(i,j,k)*(h1000/pbk(i,j,k))**rd_over_cp - enddo - enddo - enddo - -END SUBROUTINE BackgroundCldgfs - -SUBROUTINE BackgroundCld(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk, & - zh,pt_ll,eta1_ll,aeta1_ll,eta2_ll,aeta2_ll,regional,wrf_mass_regional) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: BackgroundCld Ingest background fields for cloud analysis -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 -! -! ABSTRACT: -! This subroutine reads in background hydrometeor fields for cloud analysis -! -! PROGRAM HISTORY LOG: -! 2009-01-02 Hu Add NCO document block -! 2010-04-26 Hu delete the module gridmod and guess_grids. -! transfer information subroutine dummy variables -! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS -! core -! -! -! input argument list: -! mype - processor ID -! lon2 - no. of lons on subdomain (buffer points on ends) -! lat2 - no. of lats on subdomain (buffer points on ends) -! nsig - no. of vertical levels -! tbk - 3D background potential temperature (K) -! psbk - 2D background surface pressure (hPa) -! q - 3D moisture (water vapor mixing ratio kg/kg) -! zh - terrain -! pt_ll - vertical coordinate -! eta1_ll - vertical coordinate -! aeta1_ll - vertical coordinate -! regional - if regional -! wrf_mass_regional - if mass core -! -! output argument list: -! pbk - 3D background pressure (hPa) -! hbk - 3D height above the ground (not the sea level) -!!!! z_lcl - lifting condensation level -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind,r_kind - use constants, only: rd_over_cp, h1000 - use constants, only: rd, grav, half, rad2deg - - implicit none - - integer(i_kind),intent(in):: mype - integer(i_kind),intent(in):: lon2 - integer(i_kind),intent(in):: lat2 - integer(i_kind),intent(in):: nsig - - real(r_kind), intent(in) :: pt_ll - real(r_kind), intent(in) :: eta1_ll(nsig+1) ! - real(r_kind), intent(in) :: aeta1_ll(nsig) ! - real(r_kind), intent(in) :: eta2_ll(nsig+1) ! - real(r_kind), intent(in) :: aeta2_ll(nsig) ! - logical, intent(in) :: regional ! .t. for regional background/analysis - logical, intent(in) :: wrf_mass_regional ! - - -! background -! -! read in from WRF -! - real(r_single),intent(inout) :: tbk(lon2,lat2,nsig) ! temperature - real(r_single),intent(inout) :: psbk(lon2,lat2) ! surface pressure - real(r_single),intent(in) :: zh(lon2,lat2) ! terrain elevation - real(r_single),intent(inout) :: q(lon2,lat2,nsig) ! moisture -! -! derived fields -! - real(r_single),intent(out) :: hbk(lon2,lat2,nsig)! height - real(r_single),intent(out) :: pbk(lon2,lat2,nsig)! pressure hPa -! real(r_single),intent(out) :: z_lcl(lon2,lat2) ! lifting condensation level -! -! misc. -! - INTEGER :: i,j,k - - REAL(r_single) :: rdog, h, dz - REAL(r_single) :: height(nsig+1) - real(r_single) :: q_integral(lon2,lat2),q_integralc4h(lon2,lat2) - real(r_single) :: deltasigma, deltasigmac4h,psfc_this - -! -!================================================================ -! - q_integral=1 - q_integralc4h=0.0 - do k=1,nsig - deltasigma=eta1_ll(k)-eta1_ll(k+1) - deltasigmac4h=eta2_ll(k)-eta2_ll(k+1) - do j=1,lat2 - do i=1,lon2 - q(i,j,k) = q(i,j,k)/(1.0_r_kind-q(i,j,k)) ! water vapor mixing ratio (kg/kg) - q_integral(i,j)=q_integral(i,j)+deltasigma*q(i,j,k) - q_integralc4h(i,j)=q_integralc4h(i,j)+deltasigmac4h*q(i,j,k) - enddo - enddo - enddo - do j=1,lat2 - do i=1,lon2 - psfc_this=pt_ll+(psbk(i,j)-pt_ll)/q_integral(i,j) - psbk(i,j)= psfc_this - enddo - enddo - -! -! assign CAPE as 0, this part needs more work -! -! gsfc(:,:,3)=0.0 ! CAPE, we need but not included in wrf_inout -! 1: land use; 2: sfc soil T; 3: CAPE -! -! get land use and convert latitude and longitude back to degree -! xland=gsfc(:,:,1) -! soil_tbk=gsfc(:,:,2) -! -! get virtual potential temperature (thv) -! -! thv=0.0 -! do k=1,nsig -! do j=1,nlat -! do i=1,nlon -! rl=qr(i,j,k)+qs(i,j,k)+qg(i,j,k)+qc(i,j,k)+qi(i,j,k) -! thv(i,j,k)=tbk(i,j,k)*(1.0+0.61*q(i,j,k)-rl) -! ENDDO -! ENDDO -! ENDDO -!! -! -! now get pressure (pbk) and height (hbk) at each grid point -! - if(regional .and. wrf_mass_regional ) then - - do k=1,nsig - do j=1,lat2 - do i=1,lon2 - pbk(i,j,k)=aeta1_ll(k)*(psbk(i,j)-pt_ll)+pt_ll + aeta2_ll(k) - end do - end do - end do - -! Compute geopotential height at midpoint of each layer - rdog = rd/grav - do j=1,lat2 - do i=1,lon2 - k = 1 - h = rdog * tbk(i,j,k) - dz = h * log(psbk(i,j)/pbk(i,j,k)) - height(k) = zh(i,j) + dz - - do k=2,nsig - h = rdog * half * (tbk(i,j,k-1)+tbk(i,j,k)) - dz = h * log(pbk(i,j,k-1)/pbk(i,j,k)) - height(k) = height(k-1) + dz - end do - - do k=1,nsig - hbk(i,j,k)=height(k) - zh(i,j) - end do - end do - end do - else - write(6,*) ' Only wrf mass grid is done for cloud analysis ' - write(6,*) ' You are choosing grid that is not recoginzed by cloud analysis' - call stop2(114) - endif - - do k=1,nsig - do j=1,lat2 - do i=1,lon2 - tbk(i,j,k)=tbk(i,j,k)*(h1000/pbk(i,j,k))**rd_over_cp - enddo - enddo - enddo - -END SUBROUTINE BackgroundCld diff --git a/lib/GSD/gsdcloud/BckgrndCC.f90 b/lib/GSD/gsdcloud/BckgrndCC.f90 deleted file mode 100644 index c5e8bc6d6..000000000 --- a/lib/GSD/gsdcloud/BckgrndCC.f90 +++ /dev/null @@ -1,158 +0,0 @@ -SUBROUTINE BckgrndCC(nlon,nlat,nsig,tbk,pbk,q,hbk,zh, & - cv_bk,t_k,z_lcl) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: BckgrndCC generate background field for -! fractional cloud cover based on RH -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 -! -! ABSTRACT: -! This subroutine calculate cloud field based on background fields -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! tbk - 3D background potentional temperature (K) -! pbk - 3D background pressure (hPa) -! q - 3D moisture (kg/kg) -! hbk - 3D height -! zh - terrain -! -! output argument list: -! cv_bk - 3D background cloud cover -! t_k - 3D temperature in K -! z_lcl - lifting condensation level -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use kinds, only: r_single,i_kind,r_kind - use constants, only: h1000, rd_over_cp, g_over_rd - - implicit none - - integer(i_kind),intent(in):: nlon,nlat,nsig -! background -! -! read in from WRF -! - real(r_single),intent(in) :: tbk(nlon,nlat,nsig) ! potential temperature - real(r_single),intent(in) :: zh(nlon,nlat) ! terrain elevation - real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture - real(r_single),intent(in) :: hbk(nlon,nlat,nsig) ! height - real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure - - real(r_single),intent(out) :: t_k(nlon,nlat,nsig) ! temperature in K - real(r_single),intent(out) :: z_lcl(nlon,nlat) ! lifting condensation level - real(r_single),intent(out) :: cv_bk(nlon,nlat,nsig)! cloud cover - -! CONSTANTS: - real(r_single) :: gamma_d ! dry adiabatic lapse rate (K/m) - real(r_single) :: z_ref_lcl - PARAMETER(z_ref_lcl = 180.0_r_single) - -! misc. -! - real(r_single) :: rhbk(nlon,nlat,nsig) ! rh - - INTEGER :: i,j,k - - - REAL(r_kind) :: f_qvsat - REAL(r_kind) :: qvsat - REAL(r_kind) :: rh_to_cldcv - - REAL(r_kind) :: z_ref,x - REAL(r_kind) :: arg,arg2, t_ref_c, td_ref_c - REAL(r_kind) :: frac_z, t_ref_k,rh_ref - -! -!================================================================ -! - gamma_d = g_over_rd/rd_over_cp -! -! get the RH -! - do k=1,nsig - do j=2,nlat-1 - do i=2,nlon-1 - t_k(i,j,k)=tbk(i,j,k)*(pbk(i,j,k)/h1000)**rd_over_cp - qvsat=f_qvsat(pbk(i,j,k)*100.0_r_kind,t_k(i,j,k)) - ! Saturation water vapor specific humidity - qvsat = qvsat/(1.0 - qvsat) ! convert to saturation mixing ratio (kg/kg) - rhbk(i,j,k)=100._r_kind*MIN(1._r_kind,MAX(0._r_kind,(q(i,j,k)/qvsat))) - ! q is mixing ration kg/kg - enddo - enddo - enddo -! -! Find the lifting condensation level -! - z_lcl = -99999.0_r_kind - do j=2,nlat-1 - do i=2,nlon-1 - z_ref = z_ref_lcl + zh(i,j) - IF (z_ref <= hbk(i,j,2) .OR. z_ref > hbk(i,j,nsig-1)) THEN - write(6,*) 'Error, ref.level is out of bounds at pt:' & - ,i,j,z_ref,hbk(i,j,2),hbk(i,j,nsig-1) - call STOP2(114) - END IF - - DO k = 3,nsig-1 - IF ( z_ref < hbk(i,j,k) .and. z_ref >= hbk(i,j,k-1)) THEN - frac_z = (z_ref-hbk(i,j,k-1))/(hbk(i,j,k)-hbk(i,j,k-1)) - t_ref_k = t_k(i,j,k-1)+ frac_z*(t_k(i,j,k)-t_k(i,j,k-1)) - t_ref_c = t_ref_k - 273.15_r_kind -! - rh_ref = rhbk(i,j,k-1)+ frac_z*(rhbk(i,j,k)-rhbk(i,j,k-1)) -! compute dew point depression. -! td_ref_c = dwpt(t_ref_c,rh_ref) - x = 1._r_kind-0.01_r_kind*rh_ref - td_ref_c =t_ref_c-(14.55_r_kind+0.114_r_kind*t_ref_c)*x+ & - ((2.5_r_kind+0.007_r_kind*t_ref_c)*x)**3+ & - (15.9_r_kind+0.117_r_kind*t_ref_c)*x**14 - - END IF - END DO ! k = 2,nz-1 -! - z_lcl(i,j) = z_ref + (t_ref_c - td_ref_c)/gamma_d - z_lcl(i,j) = min(hbk(i,j,nsig-1),max(z_lcl(i,j),hbk(i,j,2))) - enddo - enddo -! -! get background cloud cover -! - cv_bk=0.0_r_kind - do k=1,nsig - do j=2,nlat-1 - do i=2,nlon-1 - IF (hbk(i,j,k) >= z_lcl(i,j)) THEN - arg = hbk(i,j,k) - zh(i,j) - arg2=rhbk(i,j,k)*0.01_r_kind - cv_bk(i,j,k) = rh_to_cldcv(arg2,arg) - ENDIF - enddo - enddo - enddo -! - -END SUBROUTINE BckgrndCC diff --git a/lib/GSD/gsdcloud/CheckCld.f90 b/lib/GSD/gsdcloud/CheckCld.f90 deleted file mode 100644 index 795eaa997..000000000 --- a/lib/GSD/gsdcloud/CheckCld.f90 +++ /dev/null @@ -1,292 +0,0 @@ -SUBROUTINE check_cloud(mype,nlat,nlon,nsig,q,qr,qs,qg,qc,qi,tcld,pbk,h_bk, & - mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,cstation,& - sat_ctp,cld_cover_3d,xland) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: save_cloudResults writes out diagnostics on cloud/hydrometeor analysis -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-27 -! -! ABSTRACT: -! This subroutine writes out diagnostics on cloud analysis results -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! pbk - 3D background pressure (hPa) -! q - 3D moisture (water vapor mixing ratio) -! qr - 3D rain mixing ratio (kg/kg) -! qs - 3D snow mixing ratio (kg/kg) -! qg - 3D graupel mixing ratio (kg/kg) -! qc - 3D cloud water mixing ratio (kg/kg) -! qi - 3D cloud ice mixing ratio (kg/kg) -! tcld - 3D in-cloud temperature (K) -! -! mxst_p - maximum observation number -! NVARCLD_P - first dimension of OLCD -! numsao - observation number -! OI - observation x location -! OJ - observation y location -! OLCD - cloud amount, cloud height, visibility -! OWX - weather observation -! Oelvtn - observation elevation -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind, r_double - use guess_grids, only: ges_tv,ges_q - use guess_grids, only: ges_qc,ges_qi,ges_qr,ges_qs,ges_qg,ges_tten - use constants, only: rd_over_cp, h1000 - use gridmod, only: jlon1,ilat1,istart,jstart - - implicit none - - integer (i_kind),intent(in) :: nlat,nlon,nsig - integer (i_kind),intent(in) :: mype - -! background -! -! read in from WRF -! - real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, mixing ratio (kg/kg) - real(r_single),intent(in) :: qr(nlon,nlat,nsig) ! rain - real(r_single),intent(in) :: qs(nlon,nlat,nsig) ! snow - real(r_single),intent(in) :: qg(nlon,nlat,nsig) ! graupel - real(r_single),intent(in) :: qc(nlon,nlat,nsig) ! cloud water - real(r_single),intent(in) :: qi(nlon,nlat,nsig) ! cloud ice - real(r_single),intent(in) :: tcld(nlon,nlat,nsig) ! cloud temperature (potential temperature) - - real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure , pa - real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height -! -! cloud observation from METAR - - INTEGER(i_kind), intent(in) :: mxst_p,NVARCLD_P -! PARAMETER (LSTAID_P=9) - - INTEGER,intent(in) :: numsao - real(r_single),intent(in) :: OI(mxst_p) ! x location - real(r_single),intent(in) :: OJ(mxst_p) ! y location - INTEGER(i_kind),intent(in):: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, - ! visibility - CHARACTER*10,intent(in) :: OWX(mxst_p) ! weather - real(r_single),intent(in) :: Oelvtn(mxst_p) ! elevation - character(8),intent(in) :: cstation(mxst_p) ! station name - real(i_kind), intent(in) :: xland(nlon,nlat) ! surface -! - real(r_single),intent(in) :: sat_ctp(nlon,nlat) -! - real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) -! -! misc. -! - INTEGER :: ista,idw,ids - INTEGER :: i,j,k, iunit - character*3 :: cmype -! -!================================================================ -! - idw=jstart(mype+1)-2 - ids=istart(mype+1)-2 - iunit=68 - write(cmype,'(I3.3)') mype - open(iunit,file='checkCloud_'//trim(cmype)//'.txt') - write(iunit,*) idw,ids,jstart(mype+1),istart(mype+1),mype - - if(mype==22 ) then - DO i=54, 58 - DO j=96, 100 - write(*,*) 'radar=',i,j,k - DO k=1,nsig - write(*,*) 'radar=',ges_tten(j,i,k,1) ,pbk(i,j,k) - enddo - enddo - enddo - endif - - return -if(mype==5 ) then - DO i=100, 102 - DO j=44, 46 -! DO i=2, nlon-1 -! DO j=2, nlat-1 - -! if(sat_ctp(i,j) > 900 .and. sat_ctp(i,j) < 1014) then - write(iunit,'(a,f8.1,2i8,f8.1)') 'cloud top pressure=',sat_ctp(i,j),i,j,xland(i,j) - write(iunit,'(a10,3a10,a12,3a10)') 'level','cover','qc', 'qi', 'h_bk', 'pbk','tcld' - DO k=1,nsig - write(iunit,'(i10,f10.2,2f10.5,f12.1,3f10.1)') & - k,cld_cover_3d(i,j,k),qc(i,j,k)*1000.0,qi(i,j,k)*1000.0, & - h_bk(i,j,k),pbk(i,j,k),tcld(i,j,k) - enddo -! endif - END DO - END DO - - - if(numsao > 0 ) then - do ista = 1,numsao - if(abs(OCLD(1,ista)) <10 ) then - write(iunit,'(a10,I10,2f8.2,20I10)') cstation(ista),ista,oi(ista),oj(ista),(OCLD(k,ista),k=1,3),(OCLD(k,ista),k=7,10) - endif - enddo - endif - -endif - -! do k=1,nsig -! do j=1,nlat -! do i=1,nlon -! tcld(i,j,k)=tcld(i,j,k)*(pbk(i,j,k)/h1000/100.0)**rd_over_cp -! ENDDO -! ENDDO -! ENDDO - - if(mype == 130 ) then - - - if(numsao > 0 ) then - write(cmype,'(I3.3)') mype - open(iunit,file='checkCloud_'//trim(cmype)//'.txt') - write(iunit,*) 'mype,idw,ids',mype,idw,ids,nlon,nlat - do ista = 1,numsao - if(abs(OCLD(1,ista)) <10 ) then - write(iunit,'(a10,I10,2f8.2)') cstation(ista),ista,oi(ista),oj(ista) - write(iunit,'(20I10)') (OCLD(k,ista),k=1,6) - write(iunit,'(20I10)') (OCLD(k,ista),k=7,NVARCLD_P) - endif - enddo - - - do ista = 1,numsao - i = int(oi(ista)+0.0001) - j = int(oj(ista)+0.0001) - - write(iunit,*) - write(iunit,'(a10,I10,a10,2I10,3f8.2)') 'ista=',ista,cstation(ista),i,j,oi(ista),oj(ista),Oelvtn(ista) - write(iunit,'(20I10)') (OCLD(k,ista),k=1,6) - write(iunit,'(20I10)') (OCLD(k,ista),k=7,NVARCLD_P) - - if( i >= 2 .and. i <=nlon-1 ) then - if( j >= 2 .and. j <=nlat-1 ) then - - write(iunit,'(a,f8.1)') 'cloud top pressure=',sat_ctp(i,j) - write(iunit,'(a10,3a10,a12,3a10)') 'level','cover','qc', 'qi', 'h_bk', 'pbk','tcld' - DO k=1,nsig - write(iunit,'(i10,f10.2,2f10.5,f12.1,3f10.1)') & - k,cld_cover_3d(i,j,k),qc(i,j,k)*1000.0,qi(i,j,k)*1000.0, & - h_bk(i,j,k),pbk(i,j,k),tcld(i,j,k) - enddo - - endif - endif - ENDDO - close(iunit) - - endif - endif -! - -END SUBROUTINE check_cloud -SUBROUTINE FindCloumn(mype,ifindomain,iglobal,jglobal,ilocal,jlocal) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: CheckCloumn find local i,j from certain global i,j -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-05-02 -! -! ABSTRACT: -! This subroutine print the column information for certain i,j -! -! PROGRAM HISTORY LOG: -! 2011-05-02 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! iglobal - i grid for whole domain -! jglobal - j grid for whole domain -! -! output argument list: -! ilocal - i grid for subdomain domain -! jlocal - j grid for subdomain domain -! ifindomain - if in this sub-domain -! -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! - - use kinds, only: r_single,i_kind,r_kind,r_double - use gridmod, only: jlon1,ilat1,istart,jstart - - implicit none - - integer(i_kind), intent(in) :: mype - integer(i_kind), intent(in) :: iglobal - integer(i_kind), intent(in) :: jglobal - integer(i_kind), intent(out) :: ilocal - integer(i_kind), intent(out) :: jlocal - logical, intent(out) :: ifindomain - -! -! misc. -! - - integer(i_kind) :: ib,jb - -!==================================================================== -! Begin - - ifindomain=.false. - ib=jstart(mype+1) ! begin i point of this domain - jb=istart(mype+1) ! begin j point of this domain - -! - ilocal = iglobal - ib + 2 ! covert it to the local grid - jlocal = jglobal - jb + 2 ! covert it to the local grid - - if(ilocal > 0 .and. jlocal > 0 ) then - if(ilocal <= jlon1(mype+1) .and. jlocal <= ilat1(mype+1) ) then - ifindomain=.true. - endif - endif -! write(*,*) 'find the location',mype,ilocal,jlocal,iglobal,jglobal -! write(*,*) mype,ib,jb,jlon1(mype+1),ilat1(mype+1),ifindomain - -END SUBROUTINE FindCloumn - diff --git a/lib/GSD/gsdcloud/Makefile b/lib/GSD/gsdcloud/Makefile deleted file mode 100644 index 58495e716..000000000 --- a/lib/GSD/gsdcloud/Makefile +++ /dev/null @@ -1,115 +0,0 @@ -# -# ################################################################## -# ################################################################## -# ###### ###### -# ###### Advanced Regional Prediction System (ARPS) ###### -# ###### Version 5.0 ###### -# ###### ###### -# ###### Developed by ###### -# ###### Center for Analysis and Prediction of Storms ###### -# ###### University of Oklahoma ###### -# ###### ###### -# ################################################################## -# ################################################################## -# -#======================================================================= -# -# PURPOSE: This makefile generates the generalized cloud analysis lib -# -# AUTHOR: Ming HU -# 4/22/2006 -# -# Modification history: -# -#======================================================================= - -#----------------------------------------------------------------------- -# -# Default shell -# -#----------------------------------------------------------------------- - -# SHELL=/bin/csh - - -include Makefile.conf - -#----------------------------------------------------------------------- -# -# Dependencies -# -#----------------------------------------------------------------------- - -.SUFFIXES: $(SUFFIXES) .f90 - -.f.o: - $(FTN) $(FFLAGS) $(FIXFLAGS) -c $< -.f90.o: - $(FTN) $(FFLAGS) $(FREEFLAGS) -c $< -.c.o: - $(CC) $(CFLAGS) -c $< - -#----------------------------------------------------------------------- -# -# Executable to be generated by this make file: -# -#----------------------------------------------------------------------- - - -#----------------------------------------------------------------------- -# -# Object library to be generated for ARPS solver: -# -# LIBGNRLCLD = libgnrlcld shared library -# -#----------------------------------------------------------------------- - -LIBGNRLCLD = libgsdcloud - -#----------------------------------------------------------------------- -# -# List of machine-dependent object codes -# -#----------------------------------------------------------------------- - -GNRLCLDOBJS = kinds.o constants.o \ - ARPS_cldLib.o cloudCover_radar.o mthermo.o \ - BackgroundCld.o cloudLWC.o pcp_mxr_ARPSlib.o \ - BckgrndCC.o cloudLayers.o radar_ref2tten.o \ - PrecipMxr_radar.o cloudType.o read_Lightning_cld.o \ - PrecipType.o cloud_saturation.o read_NESDIS.o \ - TempAdjust.o read_Surface.o \ - adaslib.o convert_lghtn2ref.o read_nasalarc_cld.o \ - build_missing_REFcone.o get_sfm_1d_gnl.o read_radar_ref.o \ - cloudCover_NESDIS.o smooth.o \ - cloudCover_Surface.o map_ctp.o vinterp_radar_ref.o \ - hydro_mxr_thompson.o pbl_height.o map_ctp_lar.o - - -#----------------------------------------------------------------------- -# -# Set Default -# -#----------------------------------------------------------------------- - -default: $(LIBGNRLCLD).a - -#----------------------------------------------------------------------- -# -# Make ADAS shared library -# -#----------------------------------------------------------------------- - -$(LIBGNRLCLD).a: $(GNRLCLDOBJS) - ar $(ARFLAG) rc $@ $(GNRLCLDOBJS) -# cp $(LIBGNRLCLD).a - -#----------------------------------------------------------------------- -# -# Remove the object code for individual programs -# -#----------------------------------------------------------------------- - -clean: - -$(RM) -f $(GNRLCLDOBJS) $(LIBGNRLCLD).a *.mod - diff --git a/lib/GSD/gsdcloud/Makefile.conf.theia b/lib/GSD/gsdcloud/Makefile.conf.theia deleted file mode 100755 index 8a4fa82b9..000000000 --- a/lib/GSD/gsdcloud/Makefile.conf.theia +++ /dev/null @@ -1,41 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -# -# --------------------------- -# General targets/definitions -# --------------------------- - -FTN = mpif90 -LDR = mpif90 -CC = cc - -GNRL_LD = $(LDR) - -TAR = tar -AWK = awk -RM = rm -LN = ln - -ARFLAG = - -TOPDIR = - -INCLDIR = - -#----------------------------------------------------------------------- -# -## Compiler Flag of Options. The default is for AIX Fortran xlf. -# -##----------------------------------------------------------------------- - -FFLAGS = -O3 -xW -g -traceback -check bounds -assume byterecl # -I../../../include -CFLAGS = -LDFLAGS = - -FIXFLAGS = -FREEFLAGS = - diff --git a/lib/GSD/gsdcloud/Makefile.conf.wcoss b/lib/GSD/gsdcloud/Makefile.conf.wcoss deleted file mode 100755 index baead2eea..000000000 --- a/lib/GSD/gsdcloud/Makefile.conf.wcoss +++ /dev/null @@ -1,41 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -# -# --------------------------- -# General targets/definitions -# --------------------------- - -FTN = mpfort -LDR = mpfort -CC = cc - -GNRL_LD = $(LDR) - -TAR = tar -AWK = awk -RM = rm -LN = ln - -ARFLAG = - -TOPDIR = - -INCLDIR = - -#----------------------------------------------------------------------- -# -## Compiler Flag of Options. The default is for AIX Fortran xlf. -# -##----------------------------------------------------------------------- - -FFLAGS = -O3 -fp-model strict -convert big_endian -assume byterecl -implicitnone -traceback -CFLAGS = -LDFLAGS = - -FIXFLAGS = -FREEFLAGS = - diff --git a/lib/GSD/gsdcloud/PrecipMxr_radar.f90 b/lib/GSD/gsdcloud/PrecipMxr_radar.f90 deleted file mode 100644 index 13f3fff7d..000000000 --- a/lib/GSD/gsdcloud/PrecipMxr_radar.f90 +++ /dev/null @@ -1,213 +0,0 @@ -SUBROUTINE PrecipMxR_radar(mype,nlat,nlon,nsig, & - t_bk,p_bk,ref_mos_3d, & - cldpcp_type_3d,qr_cld,qnr_3d,qs_cld,qg_cld,cldqropt) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: PrecipMxR_radar find cloud liquid water content -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This is the driver to call subroutines that calculate liquid water content based on -! radar reflectivity and hydrometeor type diagnosed from radar -! and background 3-D temperature fields -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! ref_mos_3d - 3D reflectivity in analysis grid (dBZ) -! cldpcp_type_3d - 3D hydrometeor type -! cldqropt - scheme used to retrieve -! mixing ratios for hydrometeors related to precipitation (qr, qs, qg) -! 1=Kessler 2=Lin 3=Thompson -! -! output argument list: -! qr_cld - rain mixing ratio (g/kg) -! qnr_3d - rain number concentration -! qs_cld - snow mixing ratio (g/kg) -! qg_cld - graupel mixing ratio (g/kg) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind,r_kind - - implicit none - integer(i_kind),intent(in):: nlat,nlon,nsig - integer(i_kind),intent(in):: mype -!mhu integer(i_kind),intent(in) :: regional_time(6) -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! height -! - real(r_kind),intent(in) :: ref_mos_3d(nlon,nlat,nsig) -! -! Variables for cloud analysis -! - integer(i_kind),intent(in) :: cldpcp_type_3d(nlon,nlat,nsig) -! -! hydrometeors -! - REAL(r_single),intent(out) :: qr_cld(nlon,nlat,nsig) ! rain - REAL(r_single),intent(out) :: qnr_3d(nlon,nlat,nsig) ! rain number concentration(/kg) - REAL(r_single),intent(out) :: qs_cld(nlon,nlat,nsig) ! snow - REAL(r_single),intent(out) :: qg_cld(nlon,nlat,nsig) ! graupel - -!----------------------------------------------------------- -! -! temp. -! - - REAL(r_single) :: t_3d(nlon,nlat,nsig) - REAL(r_single) :: p_3d(nlon,nlat,nsig) -! REAL(r_kind) :: qs_max - - INTEGER(i_kind) :: cldqropt - INTEGER(i_kind) :: istatus_pcp - INTEGER(i_kind) :: i,j,k -! INTEGER(i_kind) :: k_qs_max -! REAL(r_kind) :: threshold_t_1st - -! -!==================================================================== -! Begin -! -! cldqropt = 2 - - DO j = 2,nlat-1 - DO i = 2,nlon-1 - DO k = 1,nsig - t_3d(i,j,k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp - p_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single - END DO - END DO - END DO - -!----------------------------------------------------------------------- -! -! Calculate 3D precipitation hydrometeor mixing ratios -! from radar reflectivity in g/kg. -! Note that qr_cld, qs_cld, and qg_cld are diagnosed -! qr, qs and qg in g/kg, respectively. -! -!----------------------------------------------------------------------- -! - IF (cldqropt == 1) THEN -! -! Kessler's scheme -! - if(mype==0) then - WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' - WRITE(6,'(a)') & - ' Using Kessler radar reflectivity equations...' - endif - CALL pcp_mxr (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & - cldpcp_type_3d, & - qr_cld,qs_cld,qg_cld, & - istatus_pcp) - - ELSE IF (cldqropt == 2) THEN -! -! Ferrier's scheme -! - if(mype==0) then - WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' - WRITE(6,'(a)') & - ' Using Ferrier radar reflectivity equations...' - endif - CALL pcp_mxr_ferrier (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & - cldpcp_type_3d, & - qr_cld,qs_cld,qg_cld, & - istatus_pcp,mype) - - ELSE IF (cldqropt == 3) THEN -! -! Thompson's scheme -! - if(mype==0) then - WRITE(6,'(a)') ' PrecipMxR_radar: Computing Precip mixing ratio.' - WRITE(6,'(a)') & - ' Using Thompson RUC radar reflectivity equations...' - endif -! call pcp_mxr_thompsonRUC(qr_cld,qs_cld,qg_cld, & -! p_3d,t_3d, & -! ref_mos_3d,nlon,nlat,nsig,cldpcp_type_3d) - call hydro_mxr_thompson (nlon,nlat,nsig, t_3d, p_3d, ref_mos_3d, & - qr_cld,qnr_3d,qs_cld, istatus_pcp,mype) - - END IF !cldqropt=1 or 2 or 3 -! -! -! Set qs to radar retrieved snow mixing ratio at all levels -! within 150 hPa above surface in all seasons (this condition -! should occur rarely in summer in the US lower 48 states). -! -! If there is no reflectivity at all below (for qs) -! within 150 hPa of surface in a column, but there is radar-qs > 0 -! above, then apply radar-qs to model-qs at 2 levels with -! maximum radar-qs in the column but for no other levels. -! -! move this function out of this subroutine to main driver. Feb.4 2013 -! -! If the 1st level temperature is less than 5 degree, then keep -! snow. Otherwise, keep a sinlge layer (maximum) of snow. -! -! if(l_cleanSnow_WarmTs) then -! threshold_t_1st=r_cleanSnow_WarmTs_threshold -! DO j = 2,nlat-1 -! DO i = 2,nlon-1 -! -! k_qs_max=2 -! qs_max=0.0_r_kind -! DO k = 2,nsig -! if(qs_max < qs_cld(i,j,k) ) then -! qs_max = qs_cld(i,j,k) -! k_qs_max=k -! endif -! END DO -! -! if((t_3d(i,j,1)-273.15_r_kind) < threshold_t_1st) then -!! keep snow falling -! else -! if(qs_max > 1.0e-7_r_kind) then -! DO k = 1,nsig -!! if(k==k_qs_max) then -!! do nothing to keep snow mixing ratio -! else -! qs_cld(i,j,k)=0.0_r_kind -! endif -! END DO -! endif -! endif -! END DO !i -! END DO ! j -! endif ! l_cleanSnow_WarmTs - -END SUBROUTINE PrecipMxR_radar - diff --git a/lib/GSD/gsdcloud/PrecipType.f90 b/lib/GSD/gsdcloud/PrecipType.f90 deleted file mode 100644 index beb00dcd8..000000000 --- a/lib/GSD/gsdcloud/PrecipType.f90 +++ /dev/null @@ -1,118 +0,0 @@ -SUBROUTINE PrecipType(nlat,nlon,nsig,t_bk,p_bk,q_bk,radar_3d, & - wthr_type,cldpcp_type_3d) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: PrecipType decide precipitation type -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine calculates precipitation type -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! q_bk - 3D moisture -! radar_3d - 3D radar reflectivity in analysis grid (dBZ) -! wthr_type - weather type -! -! output argument list: -! cldpcp_type_3d - 3D precipitation type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind,r_kind - - implicit none - integer(i_kind),INTENT(IN):: nlat,nlon,nsig -! -! surface observation -! -! -! background -! - real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature - real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure - real(r_single),INTENT(IN) :: q_bk(nlon,nlat,nsig) ! moisture -! -! observation -! - real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity -! -! -! Variables for cloud analysis -! - integer(i_kind),INTENT(out) :: cldpcp_type_3d(nlon,nlat,nsig) - integer(i_kind),INTENT(in) :: wthr_type(nlon,nlat) - LOGICAL :: l_mask(nlon,nlat) ! "Potential" Precip Type - -! -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind):: i,j,k - real(r_single) :: temp_3d(nlon,nlat,nsig) ! temperature (C) - real(r_single) :: rh_3d(nlon,nlat,nsig) ! relative humidity - real(r_single) :: p_pa_3d(nlon,nlat,nsig) ! - REAL(r_single) :: qvsat - REAL(r_single) :: f_qvsat - INTEGER :: istatus -! -!==================================================================== -! Begin -! -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - - DO j = 1,nlat - DO i = 1,nlon -! - DO k = 1,nsig ! Initialize - temp_3d(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to K - qvsat=f_qvsat(p_bk(i,j,k)*100.0_r_single,temp_3d(i,j,k)) - qvsat = qvsat/(1.0_r_single-qvsat) ! convert to mixing ratio (kg/kg) - rh_3d(i,j,k)=100._r_single*MIN(1.,MAX(0._r_single,(q_bk(i,j,k)/qvsat))) - p_pa_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single - END DO -!----------------------------------------------------------------------- - - ENDDO ! i - ENDDO ! j - - l_mask = .false. - - call pcp_type_3d (nlon,nlat,nsig,temp_3d,rh_3d,p_pa_3d & - ,radar_3d,l_mask,cldpcp_type_3d,istatus) - - -END SUBROUTINE precipType - diff --git a/lib/GSD/gsdcloud/TempAdjust.f90 b/lib/GSD/gsdcloud/TempAdjust.f90 deleted file mode 100644 index a7f080275..000000000 --- a/lib/GSD/gsdcloud/TempAdjust.f90 +++ /dev/null @@ -1,199 +0,0 @@ -SUBROUTINE TempAdjust(mype,nlat,nlon,nsig,cldptopt, t_bk, p_bk,w_bk,q_bk, & - qc,qi,ctmp_bk) - -! -!$$$ subprogram documentation block -! . . . . -! subprogram: TempAdjust temperature adjustment -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-26 -! -! ABSTRACT: -! This subroutine adjusts the perturbation potential temperature field to account -! for the latent heating release. -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! cldptopt - schemes of adjustment -! 3=latent heat, 4,5,6 = adiabat profile -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! w_bk - 3D background vertical velocity -! q_bk - 3D moisture (water vapor mixing ratio) -! qc - 3D cloud water mixing ratio (kg/kg) -! qi - 3D cloud ice mixing ratio (kg/kg) -! ctmp_bk - 3D cloud temperature -! -! output argument list: -! t_bk - 3D background potential temperature (K) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: cp,rd_over_cp, h1000, hvap - use kinds, only: r_single,i_kind - - implicit none - integer(i_kind),intent(in):: nlat,nlon,nsig - integer(i_kind),intent(in):: mype - -! -! background -! - real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! temperature - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure - real(r_single),intent(in) :: w_bk(nlon,nlat,nsig) ! terrain - real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture - water vapor mixing ratio -! -! real(r_single) :: t_bk_check(nlon,nlat,nsig) ! temperature -! -! -! cloud water and cloud ice mixing ratios -! - real (r_single),intent(in) :: qc(nlon,nlat,nsig) - real (r_single),intent(in) :: qi(nlon,nlat,nsig) - real (r_single),intent(in) :: ctmp_bk(nlon,nlat,nsig) -! -! constant - REAL :: p0 -! -! -! temp. -! - INTEGER :: i,j,k - INTEGER(i_kind),intent(in) :: cldptopt - REAL :: frac_qc_2_lh, max_lh_2_pt - REAL :: max_pt_adj - REAL :: p0inv,arg,ptdiff - REAL :: ppi,wratio,ptcld -! -! -!----------------------------------------------------------- -! -! t_bk_check=0.0 - - p0=h1000 -! - wratio=1.0 -! cldptopt=3 - frac_qc_2_lh =1.0 - max_lh_2_pt=20.0 -! - IF (cldptopt == 3) THEN -if(mype==0) then - WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating.' - WRITE(6,'(a,f10.4,a,f10.4)') & - 'TempAdjust: frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt -endif - p0inv=1./p0 - max_pt_adj = 0.0 - DO k=2,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - arg=max(0.0,qc(i,j,k)) + max(0.0,qi(i,j,k)) - if( arg > 0.0 ) then - ppi = (p_bk(i,j,k)*p0inv) ** rd_over_cp - arg = hvap*frac_qc_2_lh*arg*0.001/(cp*ppi) - max_pt_adj = MAX(max_pt_adj,arg) - t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) - endif - END DO - END DO - END DO - if(mype==0) PRINT*,'max_adj=',max_pt_adj - ELSE IF (cldptopt == 4) THEN -if(mype==0) then - WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating in w.' - PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt -endif - max_pt_adj = 0.0 - DO k=2,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k) > 0.0) THEN - wratio=1.0 - ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp - ptdiff=ptcld-t_bk(i,j,k) - IF(ptdiff > 0.) THEN - arg = frac_qc_2_lh*wratio*ptdiff - t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) - max_pt_adj = MAX(max_pt_adj,arg) - END IF - END IF - END DO - END DO - END DO - if(mype==0) PRINT*,'max_adj=',max_pt_adj - ELSE IF (cldptopt == 5) THEN -if(mype==0) then - WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>-0.2' - PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt -endif - max_pt_adj = 0.0 - DO k=2,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - IF( ctmp_bk(i,j,k) > 0.0) THEN - wratio=min(max(0.,(5.0*(w_bk(i,j,k)+0.2))),1.0) - ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp - ptdiff=ptcld-t_bk(i,j,k) - IF(ptdiff > 0.) THEN - arg = frac_qc_2_lh*wratio*ptdiff - t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) - max_pt_adj = MAX(max_pt_adj,arg) - END IF - ENDIF - END DO - END DO - END DO - if(mype==0) PRINT*,'max_adj=',max_pt_adj - - ELSE IF (cldptopt == 6) THEN -if(mype==0) then - WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>0.0' - PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt -endif - max_pt_adj = 0.0 - DO k=2,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k)>0.0 ) THEN - ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp - ptdiff=ptcld-t_bk(i,j,k) - IF(ptdiff > 0.) THEN - arg = frac_qc_2_lh*ptdiff - t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) -! t_bk_check(i,j,k) = MIN(arg,max_lh_2_pt) - max_pt_adj = MAX(max_pt_adj,arg) - END IF - END IF - END DO - END DO - END DO - if(mype==0) PRINT*,'max_adj=',max_pt_adj - - END IF ! cldptopt=3? - -! t_bk = t_bk_check - -END SUBROUTINE TempAdjust diff --git a/lib/GSD/gsdcloud/adaslib.f90 b/lib/GSD/gsdcloud/adaslib.f90 deleted file mode 100644 index 555e7ec6a..000000000 --- a/lib/GSD/gsdcloud/adaslib.f90 +++ /dev/null @@ -1,474 +0,0 @@ -! -!$$$ subprogram documentation block -! . . . . -! ABSTRACT: -! This file collects subroutines related to cloud analysis in ADAS (CAPS) -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! -! -!################################################################## -!################################################################## -!###### ###### -!###### FUNCTION RH_TO_CLDCV ###### -!###### ###### -!################################################################## -!################################################################## -! - - FUNCTION rh_to_cldcv(rh,hgt) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Obtain first guess cloud cover field from relative humidity. -! -! -! AUTHOR: Jian Zhang -! 07/95 -! -! MODIFICATION HISTORY -! -! 04/08/97 J. Zhang -! Added the empirical relationship between RH and -! cloud cover used by Koch et al. (1997). -! Reference: -! Reference: -! Koch, S.E., A. Aksakal, and J.T. McQueen, 1997: -! The influence of mesoscale humidity and evapotranspiration -! fields on a model forecast of a cold-frontal squall line. -! Mon. Wea. Rev., Vol.125, 384-409 -! 09/10/97 J. Zhang -! Modified the empirical relationship between cloud -! fraction and relative humidity from quadratic -! to one-fourth-power. -! -! -!----------------------------------------------------------------------- -! -! INPUT: -! rh ! relative humidity -! hgt ! height (AGL) -! -! OUTPUT: -! rh_to_cld_cv ! cloud fractional cover value -! -! LOCAL: -! rh0 ! the critical RH value that seperate clear - ! air condition and cloudy condition -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - - IMPLICIT NONE - - INTEGER(i_kind) :: rh2cform - PARAMETER (rh2cform=2) - - REAL(r_kind), intent(in) :: rh,hgt - REAL(r_kind) :: rh_to_cldcv - REAL(r_kind) :: rh0 - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! - IF(rh2cform == 1) THEN -! -!----------------------------------------------------------------------- -! -! A quadratic relationship between relative humidity and cloud -! fractional cover. -! -!----------------------------------------------------------------------- -! - IF (hgt < 600.0_r_kind) THEN - rh0 = 0.9_r_kind - ELSE IF (hgt < 1500.0_r_kind) THEN - rh0 = 0.8_r_kind - ELSE IF (hgt < 2500.0_r_kind) THEN - rh0 = 0.6_r_kind - ELSE - rh0 = 0.5_r_kind - END IF - - IF (rh < rh0) THEN - rh_to_cldcv = 0.0_r_kind - ELSE - rh_to_cldcv = (rh - rh0)/(1.0_r_kind - rh0) - rh_to_cldcv = rh_to_cldcv*rh_to_cldcv - END IF - - ELSE IF(rh2cform == 2) THEN -! -!----------------------------------------------------------------------- -! -! A quadratic relationship between relative humidity and cloud -! fractional cover with fixed rh0=0.75 -! -!----------------------------------------------------------------------- -! -! - IF (rh < 0.75_r_kind) THEN - rh_to_cldcv = 0.0_r_kind - ELSE - rh_to_cldcv = 16._r_kind*(rh - 0.75_r_kind)*(rh - 0.75_r_kind) - END IF - - ELSE -! -!-----------------------------------------------------------------------! -! A modified version of the sqrt relationship between -! relative humidity and cloud fractional cover used in Eta model. -! -!----------------------------------------------------------------------- -! - IF (hgt < 600._r_kind) THEN - rh0 = 0.8_r_kind - ELSE - rh0 = 0.75_r_kind - END IF - - IF (rh < rh0) THEN - rh_to_cldcv = 0.0_r_kind - ELSE - rh_to_cldcv = 1.0_r_kind - SQRT((1.0_r_kind - rh)/(1.0_r_kind - rh0)) - END IF - - END IF - - RETURN - END FUNCTION rh_to_cldcv -! -! -!################################################################## -!################################################################## -!###### ###### -!###### FUNCTION F_ES ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -FUNCTION f_es( p, t ) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Calculate the saturation specific humidity using enhanced Teten's -! formula. -! -!----------------------------------------------------------------------- -! -! AUTHOR: Yuhe Liu -! 01/08/1998 -! -! MODIFICATION HISTORY: -! -!----------------------------------------------------------------------- -! -! INPUT : -! -! p Pressure (Pascal) -! t Temperature (K) -! -! OUTPUT: -! -! f_es Saturation water vapor pressure (Pa) -! -!----------------------------------------------------------------------- -! - -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - - REAL :: p ! Pressure (Pascal) - REAL :: t ! Temperature (K) - REAL :: f_es ! Saturation water vapor pressure (Pa) -! -!----------------------------------------------------------------------- -! -! Function f_es and inline directive for Cray PVP -! -!----------------------------------------------------------------------- -! - REAL :: f_esl, f_esi - -!fpp$ expand (f_esl) -!fpp$ expand (f_esi) -!!dir$ inline always f_esl, f_esi -!*$* inline routine (f_esl, f_esi) - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - IF ( t >= 273.15 ) THEN ! for water - f_es = f_esl( p,t ) - ELSE ! for ice - f_es = f_esi( p,t ) - END IF - - RETURN -END FUNCTION f_es - -! -!----------------------------------------------------------------------- -! -! Calculate the saturation water vapor over liquid water using -! enhanced Teten's formula. -! -!----------------------------------------------------------------------- -! - -FUNCTION f_esl( p, t ) - - IMPLICIT NONE - -! constant - REAL :: satfwa, satfwb - PARAMETER ( satfwa = 1.0007 ) - PARAMETER ( satfwb = 3.46E-8 ) ! for p in Pa - - REAL :: satewa, satewb, satewc - PARAMETER ( satewa = 611.21 ) ! es in Pa - PARAMETER ( satewb = 17.502 ) - PARAMETER ( satewc = 32.18 ) - - REAL :: p ! Pressure (Pascal) - REAL :: t ! Temperature (K) - REAL :: f_esl ! Saturation water vapor pressure over liquid water - - REAL :: f - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - f = satfwa + satfwb * p - f_esl = f * satewa * EXP( satewb*(t-273.15)/(t-satewc) ) - - RETURN -END FUNCTION f_esl -! -!----------------------------------------------------------------------- -! -! Calculate the saturation water vapor over ice using enhanced -! Teten's formula. -! -!----------------------------------------------------------------------- -! - -FUNCTION f_esi( p, t ) - - IMPLICIT NONE - -! - REAL :: satfia, satfib - PARAMETER ( satfia = 1.0003 ) - PARAMETER ( satfib = 4.18E-8 ) ! for p in Pa - - REAL :: sateia, sateib, sateic - PARAMETER ( sateia = 611.15 ) ! es in Pa - PARAMETER ( sateib = 22.452 ) - PARAMETER ( sateic = 0.6 ) - - REAL :: p ! Pressure (Pascal) - REAL :: t ! Temperature (K) - REAL :: f_esi ! Saturation water vapor pressure over ice (Pa) - - REAL :: f - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - f = satfia + satfib * p - f_esi = f * sateia * EXP( sateib*(t-273.15)/(t-sateic) ) - - RETURN -END FUNCTION f_esi -! -! -!################################################################## -!################################################################## -!###### ###### -!###### FUNCTION F_QVSAT ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -FUNCTION f_qvsat( p, t ) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Calculate the saturation specific humidity using enhanced Teten's -! formula. -! -!----------------------------------------------------------------------- -! -! AUTHOR: Yuhe Liu -! 01/08/1998 -! -! MODIFICATION HISTORY: -! -!----------------------------------------------------------------------- -! -! INPUT : -! -! p Pressure (Pascal) -! t Temperature (K) -! -! OUTPUT: -! -! f_qvsat Saturation water vapor specific humidity (kg/kg). -! -!----------------------------------------------------------------------- -! - -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - - REAL :: p ! Pressure (Pascal) - REAL :: t ! Temperature (K) - REAL :: f_qvsat ! Saturation water vapor specific humidity (kg/kg) -! -!----------------------------------------------------------------------- -! -! Include files: -! -!----------------------------------------------------------------------- -! -! - - REAL :: rd ! Gas constant for dry air (m**2/(s**2*K)) - PARAMETER( rd = 287.0 ) - - REAL :: rv ! Gas constant for water vapor (m**2/(s**2*K)). - PARAMETER( rv = 461.0 ) - - REAL :: rddrv - PARAMETER( rddrv = rd/rv ) - -! -!----------------------------------------------------------------------- -! -! Function f_es and inline directive for Cray PVP -! -!----------------------------------------------------------------------- -! - REAL :: f_es -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - f_qvsat = rddrv * f_es(p,t) / (p-(1.0-rddrv)*f_es(p,t)) - - RETURN -END FUNCTION f_qvsat - -SUBROUTINE getdays(nday,iyear,imonth,iday) - - use kinds, only: i_kind - implicit none -! - INTEGER(i_kind), intent(in) :: iyear,imonth,iday - INTEGER(i_kind), intent(out) :: nday -! - - nday=0 - if(imonth==1) then - nday=iday - elseif(imonth==2) then - nday=31+iday - elseif(imonth==3) then - nday=59+iday - elseif(imonth==4) then - nday=90+iday - elseif(imonth==5) then - nday=120+iday - elseif(imonth==6) then - nday=151+iday - elseif(imonth==7) then - nday=181+iday - elseif(imonth==8) then - nday=212+iday - elseif(imonth==9) then - nday=243+iday - elseif(imonth==10) then - nday=273+iday - elseif(imonth==11) then - nday=304+iday - elseif(imonth==12) then - nday=334+iday - endif - if(mod(iyear,4) == 0 .and. imonth > 2 ) nday=nday+1 - -END SUBROUTINE getdays diff --git a/lib/GSD/gsdcloud/build_missing_REFcone.f90 b/lib/GSD/gsdcloud/build_missing_REFcone.f90 deleted file mode 100644 index 97b7c6863..000000000 --- a/lib/GSD/gsdcloud/build_missing_REFcone.f90 +++ /dev/null @@ -1,245 +0,0 @@ -SUBROUTINE build_missing_REFcone(mype,nlon,nlat,nsig,krad_bot_in,ref_mos_3d,h_bk,pblh) -! -! radar observation -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: build_missing_REFcone build missing reflectivity area -! below cone down to assumed cloud base -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-26 -! -! ABSTRACT: -! This subroutine sets reflectivity values at missing reflectivity volumes -! below the radar "data cone" down to an assumed cloud base -! As of March 2010, this code code not yet use the local PBL base -! as used in the RUC cloud/hydrometeor analysis since summer 2009. -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! 2011-04-08 Hu Clean the reflectivity below PBL height or level 7 -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! krad_bot - radar bottom level -! ref_mos_3d - 3D radar reflectivity -! h_bk - 3D background height -! pblh - PBL height in grid -! -! output argument list: -! ref_mos_3d - 3D radar reflectivity -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,i_kind,r_single - implicit none - - INTEGER(i_kind), intent(in) :: mype - INTEGER(i_kind), intent(in) :: nlon,nlat,nsig - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height - real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid - real(r_single), intent(in) :: pblh(nlon,nlat) ! PBL height - real(r_single), intent(in) :: krad_bot_in -! - integer(i_kind) :: krad_bot,ifmissing -! - integer(i_kind) :: maxlvl - parameter (maxlvl=31) - real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile(km) - DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & - 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & - 9, 10, 11, 12, 13, 14, 15, 16/ - - real(r_kind) :: refprofile_winter(maxlvl,6) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 20-35 dbz - DATA refprofile_winter(:,1) / & - 0.999,0.938,0.957,0.975,0.983,0.990,0.995,0.999,1.000,1.000, & - 0.994,0.985,0.957,0.926,0.892,0.854,0.819,0.791,0.770,0.747, & - 0.729,0.711,0.705,0.685,0.646,0.631,0.649,0.711,0.828,0.931, & - 0.949/ -! max reflectivity 25-30 dbz - DATA refprofile_winter(:,2) / & - 0.965,0.937,0.954,0.970,0.984,0.991,0.996,1.000,0.997,0.988, & - 0.973,0.954,0.908,0.856,0.808,0.761,0.718,0.684,0.659,0.631, & - 0.607,0.586,0.570,0.550,0.523,0.512,0.531,0.601,0.711,0.813, & - 0.870/ -! max reflectivity 30-35 dbz - DATA refprofile_winter(:,3) / & - 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & - 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & - 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & - 0.793/ -! max reflectivity 35-40 dbz - DATA refprofile_winter(:,4) / & - 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & - 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & - 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & - 0.723/ -! max reflectivity 40-45 dbz - DATA refprofile_winter(:,5) / & - 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & - 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & - 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & - 0.656/ -! max reflectivity 45-50 dbz - DATA refprofile_winter(:,6) / & - 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & - 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & - 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & - 0.548/ - - - real(r_kind) :: refprofile_summer(maxlvl,6) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 20-25 dbz - DATA refprofile_summer(:,1) / & - 0.883,0.870,0.879,0.892,0.904,0.912,0.913,0.915,0.924,0.936, & - 0.946,0.959,0.984,0.999,1.000,0.995,0.988,0.978,0.962,0.940, & - 0.916,0.893,0.865,0.839,0.778,0.708,0.666,0.686,0.712,0.771, & - 0.833/ -! max reflectivity 25-30 dbz - DATA refprofile_summer(:,2) / & - 0.836,0.874,0.898,0.915,0.927,0.938,0.945,0.951,0.960,0.970, & - 0.980,0.989,1.000,0.995,0.968,0.933,0.901,0.861,0.822,0.783, & - 0.745,0.717,0.683,0.661,0.614,0.564,0.538,0.543,0.578,0.633, & - 0.687/ -! max reflectivity 30-35 dbz - DATA refprofile_summer(:,3) / & - 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & - 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & - 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & - 0.570/ -! max reflectivity 35-40 dbz - DATA refprofile_summer(:,4) / & - 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & - 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & - 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & - 0.491/ -! max reflectivity 40-45 dbz - DATA refprofile_summer(:,5) / & - 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & - 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & - 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & - 0.440/ -! max reflectivity 45-50 dbz - DATA refprofile_summer(:,6) / & - 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & - 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & - 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & - 0.410/ - - INTEGER(i_kind) :: season ! 1= summer, 2=winter - - REAL(r_kind) :: heightGSI,upref,downref,wght - INTEGER(i_kind) :: ilvl - REAL(r_kind) :: lowest,highest,tempref(nsig), tempprofile(maxlvl) - REAL(r_kind) :: maxref - - INTEGER(i_kind) :: i,j, k2, k, mref - -! -! vertical reflectivity distribution -! - season=1 - DO k=1,maxlvl - newlvlAll(k)=newlvlAll(k)*1000.0_r_kind - ENDDO -! - DO j=2,nlat-1 - DO i=2,nlon-1 - ifmissing=0 - maxref=-9999.0_r_kind -!mhu krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height -! Here, we only use PBL height to build missing corn and clean the reflectivity lower than -! PBL height. The krad_bot_in will be used when calculate the radar tten but not the hydrometer retrieval. -! Nov 21, 2011. Ming Hu - krad_bot= int( pblh(i,j) + 0.5_r_single ) ! consider PBL height -! -! in our case, -99 is no echo -! - DO k2=int(nsig/2),krad_bot,-1 - if(ref_mos_3d(i,j,k2+1)>=20._r_kind .and. & - ref_mos_3d(i,j,k2) < -100._r_kind ) ifmissing=k2 - if(ref_mos_3d(i,j,k2)>=maxref) maxref=ref_mos_3d(i,j,k2) - ENDDO - IF(ifmissing > 1 ) then - DO k2=krad_bot,1,-1 - if(ref_mos_3d(i,j,k2) >maxref) maxref=ref_mos_3d(i,j,k2) - ENDDO - if(maxref < 19.0_r_kind) then - write(6,*) 'build_missing_REFcone:',ifmissing,i,j,ifmissing - write(6,*) (ref_mos_3d(i,j,k2),k2=1,nsig) - endif - endif - IF(ifmissing > 1 .and. maxref > 19.0_r_kind ) then - mref = min(6,(int((maxref - 20.0_r_kind)/5.0_r_kind) + 1 )) - if(season== 2 ) then - DO k=1,maxlvl - tempprofile(k)=refprofile_winter(k,mref)*maxref - enddo - lowest=newlvlAll(2) - highest=7000.0_r_kind - else if(season== 1 ) then - DO k=1,maxlvl - tempprofile(k)=refprofile_summer(k,mref)*maxref - enddo - lowest=newlvlAll(3) - highest=12000.0_r_kind - endif -! make a ref profile - tempref=-9999.9_r_kind - DO k2=1,nsig - heightGSI=h_bk(i,j,k2) - if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? - do k=1,maxlvl-1 - if( heightGSI >=newlvlAll(k) .and. & - heightGSI < newlvlAll(k+1) ) ilvl=k - enddo - upref=tempprofile(ilvl+1) - downref=tempprofile(ilvl) - wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) - tempref(k2)=(1-wght)*downref + wght*upref - endif - ENDDO -! build missing volumes down to krad_bot level -! NOTE: no use of PBL base yet, as done in RUC analysis since summer 2009 - maxref=ref_mos_3d(i,j,ifmissing+1)-tempref(ifmissing+1) - if(abs(maxref) < 10.0_r_kind ) then - DO k2=ifmissing,krad_bot,-1 - ref_mos_3d(i,j,k2) = tempref(k2) + maxref - ENDDO - else - DO k2=ifmissing,krad_bot,-1 - ref_mos_3d(i,j,k2) = ref_mos_3d(i,j,ifmissing+1) - ENDDO - endif -! - ENDIF -! clean echo less than PBL height and level 7 - DO k2=1,krad_bot - ref_mos_3d(i,j,k2) = -99999.0_r_kind - ENDDO - ENDDO - ENDDO - -END SUBROUTINE build_missing_REFcone diff --git a/lib/GSD/gsdcloud/cloudCover_NESDIS.f90 b/lib/GSD/gsdcloud/cloudCover_NESDIS.f90 deleted file mode 100644 index 68ea71b9e..000000000 --- a/lib/GSD/gsdcloud/cloudCover_NESDIS.f90 +++ /dev/null @@ -1,713 +0,0 @@ -SUBROUTINE cloudCover_NESDIS(mype,regional_time,nlat,nlon,nsig,& - xlong,xlat,t_bk,p_bk,h_bk,xland, & - soil_tbk,sat_ctp,sat_tem,w_frac,& - l_cld_bld,cld_bld_hgt,build_cloud_frac_p,clear_cloud_frac_p,nlev_cld, & - cld_cover_3d,cld_type_3d,wthr_type,Osfc_station_map) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudCover_NESDIS cloud cover analysis using NESDIS cloud products -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 -! -! ABSTRACT: -! This subroutine determines cloud_cover (fractional) field using NESDIS cloud products -! Based on RUC assimilation code - (Benjamin, Weygandt, Kim, Brown) -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! regional_time - analysis time -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! xlong - 2D longitude in each grid -! xlat - 2D latitude in each grid -! -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! h_bk - 3D background height -! xland - surface type (water, land) -! soil_tbk - background soil temperature -! sat_ctp - GOES cloud top pressure in analysis grid -! sat_tem - GOES cloud top temperature in analysis grid -! w_frac - GOES cloud coverage in analysis grid -! l_cld_bld - logical for turning on GOES cloud building -! cld_bld_hgt - Height below which cloud building is done -! build_cloud_frac_p - Threshold above which we build clouds -! clear_cloud_frac_p - Threshold below which we clear clouds -! -! output argument list: -! nlev_cld - cloud status -! cld_cover_3d- 3D cloud cover (fractional cloud) -! cld_type_3d - 3D cloud type -! wthr_type - 3D weather type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use constants, only: deg2rad, rad2deg, pi - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - integer(i_kind),intent(in) :: regional_time(6) - integer(i_kind),intent(in) :: nlat,nlon,nsig -! -! background -! - real(r_single),intent(in) :: xlong(nlon,nlat) ! longitude - real(r_single),intent(in) :: xlat(nlon,nlat) ! latitude - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potentional temperature - real(r_single),intent(inout) :: p_bk(nlon,nlat,nsig) ! pressure - real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height - real(r_single),intent(in) :: xland(nlon,nlat) ! surface - real(r_single),intent(in) :: soil_tbk(nlon,nlat) ! soil tmperature -! real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) -! -! Observation -! - real(r_single),intent(inout) :: sat_ctp(nlon,nlat) - real(r_single),intent(inout) :: sat_tem(nlon,nlat) - real(r_single),intent(inout) :: w_frac(nlon,nlat) - integer(i_kind),intent(out) :: nlev_cld(nlon,nlat) - integer(i_kind),intent(in) :: Osfc_station_map(nlon,nlat) -! -! Turn on cloud building and height limit - logical, intent(in) :: l_cld_bld - real(r_kind), intent(in) :: cld_bld_hgt - real(r_kind), intent(in) :: build_cloud_frac_p - real(r_kind), intent(in) :: clear_cloud_frac_p -! -! Variables for cloud analysis -! - real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) -! -!------------------------------------------------------------------------- -! --- Key parameters -! Min_cloud_lev_p = 3 Lowest model level to check for cloud -! Sat_cloud_pthick_p= 50. Depth (mb) of new sat-sensed cloud layer -! Cloud_up_p = 10 Pressure thickness for -! Upward extrapolation of cloud -! (if model level is within cloud_up_p -! mb of sat cloud level) -! min_cloud_p_p = 960. Max pressure at which NESDIS cloud -! info is considered reliable -! (i.e., not reliable at low levels) - -! zen_limit = 0.20 Solar zenith angle - lower limit -! at which sun is considered -! high enough to trust the -! GOES cloud data - - integer(i_kind) :: min_cloud_lev_p - real(r_kind) :: sat_cloud_pthick_p - real(r_kind) :: cloud_up_p - real(r_kind) :: min_cloud_p_p - real(r_kind) :: co2_preslim_p - real(r_kind) :: zen_limit - real(r_kind) :: dt_remap_pcld_limit_p - -! --- Key parameters - data Min_cloud_lev_p / 1_i_kind / ! w/ sfc cld assim -! data Min_cloud_lev_p / 3_i_kind / ! w/ sfc cld assim - data Sat_cloud_pthick_p / 30._r_kind/ -! data Sat_cloud_pthick_p / 50._r_kind/ - data cloud_up_p / 0._r_kind / - data min_cloud_p_p / 1080._r_kind/ ! w/ sfc cld assim - data co2_preslim_p / 620._r_kind/ -! -- change to 82 deg per Patrick Minnis - 4 Nov 09 - data zen_limit / 0.14_r_kind/ -! data zen_limit / 0.20_r_kind / - data dt_remap_pcld_limit_p / 3.5_r_kind / -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: null_p - REAL(r_kind) :: spval_p - PARAMETER ( null_p = -1 ) - PARAMETER ( spval_p = 99999.0 ) - - INTEGER(i_kind) :: i,j,k,k1,i1,j1,jp1,jm1,ip1,im1 - INTEGER(i_kind) :: gmt,nday,iyear,imonth,iday - REAL(r_kind) :: declin - real(r_kind) :: hrang,xxlat - real(r_single) :: csza(nlon,nlat) - - INTEGER(i_kind) :: ndof_tot, npts_clear, npts_build, npts_bel650 - INTEGER(i_kind) :: npts_warm_cld_flag, npts_tskin_flag, npts_stab_flag, npts_ptly_cloudy - real (r_single) :: tbk_k(nlon,nlat,nsig) - - INTEGER(i_kind) :: npts_ctp_change, npts_ctp_delete, npts_ctp_nobuddy - INTEGER(i_kind) :: npts_clr_nobuddy,npts_ctp_marine_remap - real (r_single) :: dctp, dctpabs - - real(r_single) :: tsmin - - INTEGER(i_kind) :: kisotherm, ibuddy, ktempmin - real(r_kind) :: tempmin,dth2dp2, stab, stab_threshold - - real(r_kind) :: firstcloud, pdiff,pdiffabove - - INTEGER(i_kind) :: k_closest, cld_warm_strat(nlon,nlat) - REAL(r_kind) :: tdiff - -! -!==================================================================== -! Begin -! -! calculation solar declination -! - iyear=regional_time(1) - imonth=regional_time(2) - iday=regional_time(3) - call getdays(nday,iyear,imonth,iday) - declin=deg2rad*23.45_r_kind*sin(2.0_r_kind*pi*(284+nday)/365.0_r_kind) - - cld_warm_strat=-1 -! -! from mb to Pa -! - do k = 1,nsig - do j = 1,nlat - do i = 1,nlon -! qw=q_bk(i,j,k)/(1. + q_bk(i,j,k)) ! convert to specific humidity - tbk_k(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to temperature(K) - p_bk(i,j,k) = p_bk(i,j,k)*100._r_kind - end do - end do - end do - - if( p_bk(nlon/2,nlat/2,2) < 5000.0_r_kind ) then - write(6,*) 'cloudCover_NESDIS: pressure unit check failed', p_bk(nlon/2,nlat/2,2) - call stop2(114) - endif - if( tbk_k(nlon/2,nlat/2,nsig-2) > 300._r_kind) then - write(6,*) 'cloudCover_NESDIS: temperature unit check failed', & - tbk_k(nlon/2,nlat/2,nsig-2) - call stop2(114) - endif - -! -! csza = fraction of solar constant (cos of zenith angle) - gmt = regional_time(4) ! UTC - do j=2,nlat-1 - do i=2,nlon-1 - hrang= (15._r_kind*gmt + xlong(i,j) - 180._r_kind )*deg2rad - xxlat=xlat(i,j)*deg2rad - csza(i,j)=sin(xxlat)*sin(declin) & - +cos(xxlat)*cos(declin)*cos(hrang) - end do - end do - -! -! start checking the data -! - ndof_tot = 0 !counting total number of grids of sat info - npts_clear = 0 - npts_build = 0 - npts_bel650 = 0 - npts_tskin_flag = 0 - npts_stab_flag = 0 - npts_ptly_cloudy = 0 - - do j=2,nlat-1 - do i=2,nlon-1 - jp1 = min(j+1,nlat) - jm1 = max(j-1,1 ) - ip1 = min(i+1,nlon) - im1 = max(i-1,1 ) - tsmin = soil_tbk(i,j) -! --- Determine min skin temp in 3x3 around grid point. -! This is to detect nearby presence of coastline. - do j1 = jm1,jp1 - do i1 = im1,ip1 - tsmin = min(tsmin,soil_tbk(i1,j1) ) - end do - end do - - if ( w_frac(i,j) > -1._r_kind & - .and. (sat_tem(i,j)-soil_tbk(i,j)) > 4._r_kind & - .and. soil_tbk(i,j) < 263._r_kind & - .and. sat_ctp(i,j) > co2_preslim_p & - .and. sat_ctp(i,j) < 1010._r_kind & - .and. abs(xland(i,j))>0.0001_r_single & - .and. p_bk(i,j,1)/100. >=850._r_kind ) then -! w_frac(i,j) = -99999._r_kind -! sat_tem(i,j) = 99999._r_kind -! sat_ctp(i,j) = 0._r_kind -! nlev_cld(i,j) = -999 - npts_warm_cld_flag = npts_warm_cld_flag + 1 - cld_warm_strat(i,j)=5 - end if -! PH changed condition to match RUC: Tcld-Tskin(bkg) < 4, > -2 - if ( w_frac(i,j) > -1._r_kind & - .and. (sat_tem(i,j)-tsmin) > -2._r_kind & - .and. (sat_tem(i,j)-tsmin) <= 4._r_kind & - .and. sat_ctp(i,j) > co2_preslim_p & - .and. sat_ctp(i,j) < 1010._r_kind & - .and. abs(xland(i,j)) > 0.0001_r_single & - .and. p_bk(i,j,1)/100._r_kind>= 950._r_kind ) then - w_frac(i,j) = -99999._r_kind - sat_tem(i,j) = 99999._r_kind - sat_ctp(i,j) = 0._r_kind - nlev_cld(i,j)= -999 - npts_tskin_flag = npts_tskin_flag + 1 - cld_warm_strat(i,j)=4 - end if - if (w_frac(i,j)<=clear_cloud_frac_p .and. & - w_frac(i,j)>-1._r_kind) then - sat_ctp(i,j) = 1013.0_r_kind - npts_clear = npts_clear + 1 - cld_warm_strat(i,j)=0 - end if - if (w_frac(i,j) > clear_cloud_frac_p.and. & - w_frac(i,j) < build_cloud_frac_p) then -! w_frac(i,j) = -99999._r_kind - sat_tem(i,j)= 99999._r_kind -! mhu: this can cause problem: a miss line between cloud and clean, set it to clean -! PH: for CLAVR data, just set sat_ctp = 0. - sat_ctp(i,j) = 0._r_kind - nlev_cld(i,j)= -999 - npts_ptly_cloudy = npts_ptly_cloudy + 1 - cld_warm_strat(i,j)=1 - end if - if (w_frac(i,j) >= build_cloud_frac_p.and. & - sat_ctp(i,j) < 1050) then - npts_build = npts_build + 1 - cld_warm_strat(i,j)=2 - end if - if (sat_ctp(i,j)>co2_preslim_p .and. sat_ctp(i,j)<1010._r_kind) & - npts_bel650 = npts_bel650 + 1 - -! -- nlev_cld = 1 if cloud info is present -! -- nlev_cld = 0 if no cloud info is at this grid point - - if(nlev_cld(i,j) >= 1) ndof_tot = ndof_tot + 1 - end do ! i - end do ! j -! - if(mype==0) then - write(6,*) 'cloudCover_NESDIS: TOTAL NUMBER OF GRID pts w/ GOES CLOUD data =',ndof_tot - write(6,*) 'cloudCover_NESDIS: CLEAR NUMBER OF GRID pts w/ GOES CLOUD data =',npts_clear - write(6,*) 'cloudCover_NESDIS: BUILD NUMBER OF GRID pts w/ GOES CLOUD data =',npts_build - write(6,*) 'cloudCover_NESDIS: PTCLDY NUMBER OF GRID pts w/ GOES CLOUD data =',npts_ptly_cloudy - write(6,*) 'cloudCover_NESDIS: > 650mb - no OF GRID pts w/ GOES CLOUD data =',npts_bel650 - write(6,*) 'cloudCover_NESDIS: Flag CTP - skin temp too close to TB, no=',npts_tskin_flag - write(6,*) 'cloudCover_NESDIS: Clear -> cloud frac < clear frac' - write(6,*) 'cloudCover_NESDIS: Build -> cloud frac > build frac' - endif - -! -!! -! - npts_ctp_change = 0 - npts_ctp_delete = 0 - npts_ctp_nobuddy = 0 - npts_clr_nobuddy = 0 - npts_ctp_marine_remap = 0 - dctp = 0. - dctpabs = 0. - -! - stability threshold for building cloud - 3K / 100 mb (10000 Pa) - - stab_threshold = 3._r_kind/10000._r_kind - do j=2,nlat-1 - do i=2,nlon-1 - -! -- GOES indicates clouds in the lower troposphere - if (sat_ctp(i,j) < 1010._r_kind .and. sat_ctp(i,j) > co2_preslim_p) then - - tdiff = 999. - k_closest = -1 - do k=3,nsig-1 -! Attempt remapping if within 75 hPa (arbitrary) - if ((sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind)< 75._r_kind) then - if (abs(sat_tem(i,j)-tbk_k(i,j,k)) < tdiff) then - k_closest = k - tdiff = abs(sat_tem(i,j)-tbk_k(i,j,k)) - end if - end if - end do ! k loop - - if (k_closest <= 0 .and. abs(xland(i,j)) > 0.0001_r_single) then - npts_ctp_delete = npts_ctp_delete + 1 - write (6,*) i,j,sat_tem(i,j),tdiff,k_closest,xland(i,j) - go to 111 - end if - - k = k_closest - - if( abs(xland(i,j)) >0.0001_r_single ) then -! PH: dt_limit was hardwired to 1.5K, changed it to 3.5K to match RUC - if ((tdiff < dt_remap_pcld_limit_p) .or. & - (cld_warm_strat(i,j) == 5 .and. tdiff < 4._r_kind )) then - dctpabs = dctpabs + abs(sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) - dctp = dctp+ (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) - k1 = k - -1115 continue - -! --- This stability check only for reassigining CTP using RUC bkg profile. -! There is a later general check also. - stab = (t_bk(i,j,k1+1)-t_bk(i,j,k1)) & - /(p_bk(i,j,k1)-p_bk(i,j,k1+1)) - if (stab < stab_threshold) then - k1 = k1 + 1 - if ((p_bk(i,j,k)-p_bk(i,j,k1)) > 5000._r_kind) then - w_frac(i,j) = -99999._r_kind - sat_tem(i,j) = 99999._r_kind - sat_ctp(i,j) = 99999._r_kind - nlev_cld(i,j) = -999 - npts_stab_flag= npts_stab_flag + 1 - go to 111 - end if - go to 1115 - end if - - sat_ctp(i,j) = p_bk(i,j,k)/100._r_kind - npts_ctp_change = npts_ctp_change + 1 - go to 111 - else - npts_ctp_delete = npts_ctp_delete + 1 -! write (6,*) i,j,sat_tem(i,j),tdiff - go to 111 - end if - - else ! xland==0: over water - -! --- Remap marine cloud to min temp level below 880 mb -! if no matching RUC temp already found - - if (sat_ctp(i,j)>880._r_kind)then - tempmin = -500._r_kind - -! --- Look thru lowest 15 levels for lowest temp for -! level to put marine cloud at. -! --- Start at level 3 - kisotherm = 20 - ktempmin = 20 - do k=min_cloud_lev_p+2,15 - if (p_bk(i,j,k)/100._r_kind .lt. 880._r_kind) go to 1101 - dth2dp2 = t_bk(i,j,k+1)+t_bk(i,j,k-1)-2._r_kind*t_bk(i,j,k) - if (kisotherm==0 .and. & - tbk_k(i,j,k) < tbk_k(i,j,k+1)) kisotherm = k - if (dth2dp2>tempmin) then - ktempmin = k - tempmin = max(dth2dp2,tempmin) - end if - end do -1101 continue - ktempmin = min(ktempmin,kisotherm) - sat_ctp(i,j) = p_bk(i,j,ktempmin)/100._r_kind - npts_ctp_marine_remap = npts_ctp_marine_remap + 1 - end if ! sat_ctp(i,j)>880._r_kind - endif ! xland == 0 - end if -111 continue - enddo ! i - enddo ! j - - if(mype==0) then - write(6,*) 'cloudCover_NESDIS: Flag CTP - unstable w/i 50mb of CTP, no=', npts_stab_flag - write(6,*) 'cloudCover_NESDIS: Flag CTP - can''t remap CTP, no=', npts_ctp_delete - write(6,*) 'cloudCover_NESDIS: Flag CTP -remap marine cloud, no=', npts_ctp_marine_remap - endif - - if (npts_ctp_change > 0) then - if(mype==0) write (6,1121) npts_ctp_change, dctp/float(npts_ctp_change), & - dctpabs/float(npts_ctp_change) -1121 format (/'No. of pts w/ cloud-top pres change = ',i6 & - /'Mean cloud-top pres change (old-new)= ',f8.1 & - /'Mean abs cloud-top pres change = ',f8.1/) - end if -! -! --- Make sure that any cloud point has another cloud point nearby. -! Otherwise, get rid of it. - do j=2,nlat-1 - do i=2,nlon-1 - if (sat_ctp(i,j)< 1010._r_kind .and. sat_ctp(i,j)>50._r_kind) then - ibuddy = 0 - do j1=j-1,j+1 - do i1=i-1,i+1 - if (sat_ctp(i1,j1)<1010._r_kind .and. sat_ctp(i1,j1)>50._r_kind) ibuddy = 1 - end do - end do - if (ibuddy==0) then - w_frac(i,j) = -99999._r_kind - sat_tem(i,j) = 99999._r_kind - sat_ctp(i,j) = 99999._r_kind - nlev_cld(i,j) = -999 - npts_ctp_nobuddy = npts_ctp_nobuddy + 1 - end if - end if - if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j) <1100._r_kind) then - ibuddy = 0 - do j1=j-1,j+1 - do i1=i-1,i+1 - if (sat_ctp(i1,j1) > 1010._r_kind .and. sat_ctp(i1,j1) <1100._r_kind) ibuddy = 1 - end do - end do - if (ibuddy == 0) then - w_frac(i,j) = -99999._r_kind - sat_tem(i,j) = 99999._r_kind - sat_ctp(i,j) = 99999._r_kind - nlev_cld(i,j) = -999 - npts_clr_nobuddy = npts_clr_nobuddy + 1 - end if - end if - enddo - enddo - - if(mype==0) then - write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ cloud, no=', & - npts_ctp_nobuddy - - write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ clear, no=', & - npts_clr_nobuddy - endif - -! -! ***************************************************************** -! ***************************************************************** -! Start to adjust to GOES cloud top pressure -! ***************************************************************** -! ***************************************************************** - -! --- clear where GOES shows clear down to the surface -! or down to the GOES cloud top level - -! ============================================= -! - clear down to surface in fully clear column (according to GOES) -! ============================================= -! Only trust 'clear' indication under following conditions -! - over ocean -! - or over land only if p<620 mb overnight -! - or at any level in daytime (zenith angle -! greater than zen_limit threshold) -! -! mhu Nov. 26, 2014: Add a metar station map: Osfc_station_map -! when Osfc_station_map=1, it is a grid point around a metar station -! Then the satellite clean step will skip this metar station point. -! ============================================= - do j=2,nlat-1 - do i=2,nlon-1 - if (sat_ctp(i,j) >=1010.0_r_kind .and. sat_ctp(i,j) <1050._r_kind) then !clear - do k=1,nsig - if ((csza(i,j)=zen_limit) then - if(Osfc_station_map(i,j) == 1 .and. & - cld_cover_3d(i,j,k) > 0.0001_r_kind) then - else - cld_cover_3d(i,j,k) = 0.0_r_single - wthr_type(i,j) = 0 - endif -! -!mhu Nov 15 2014: don't let metar build cloud if -! - over land -! - during night -! - lower than co2_preslim_p -! - clear from satellite - else ! mhu Dec 2016: turn off this night low cloud check - if(Osfc_station_map(i,j) == 1 .and. & - cld_cover_3d(i,j,k) >0.0001_r_kind) then - else - cld_cover_3d(i,j,k) = 0.0_r_single - wthr_type(i,j) = 0 - endif -!mhu elseif( (csza(i,j)=co2_preslim_p) .and. & -!mhu abs(xland(i,j)-0._r_single) > 0.0001_r_single .and. & -!mhu cld_cover_3d(i,j,k) >0.0001_r_kind) then -!mhu if(Osfc_station_map(i,j) == 1) then -!mhu else -!mhu cld_cover_3d(i,j,k) = - 77777.0_r_single ! set to unknown -!mhu endif - end if - end do -!mhu: use 1060hps cloud top pressure to clean above the low cloud top - elseif (abs(sat_ctp(i,j)-1060.0_r_kind) < 1.0_r_kind) then !clear since the low cloud top - do k=1,nsig - cld_cover_3d(i,j,k) = 0.0_r_single - wthr_type(i,j) = 0 -!mhu mhu Dec 2016: turn off this night low cloud check -!mhu if (csza(i,j)=zen_limit) then -!mhu if( abs(cld_cover_3d(i,j,k)) > 2.0_r_single ) then -!mhu cld_cover_3d(i,j,k) = 0.0_r_single -!mhu wthr_type(i,j) = 0 -!mhu endif -!mhu end if - end do - end if - enddo - enddo -! ============================================= -! - clearing above cloud top -! ============================================= - - do j=2,nlat-1 - do i=2,nlon-1 - do k=1,nsig-1 - if (sat_ctp(i,j)<1010._r_kind .and. & - sat_ctp(i,j)>p_bk(i,j,k)/100._r_kind) then - if(sat_ctp(i,j) >= 800.0_r_kind .and. Osfc_station_map(i,j) == 1) then - cld_cover_3d(i,j,k+1) = & - max(0.0_r_single, cld_cover_3d(i,j,k+1)) - else - cld_cover_3d(i,j,k+1) = 0.0_r_single - endif - endif - -! - return to previous (but experimental) version - 12 Oct 04 -!mhu if (csza(i,j) < zen_limit & -!mhu .and. p_bk(i,j,k)/100._r_kind=zen_limit) then -! --- since we set GOES to nearest RUC level, only clear at least -! 1 RUC level above cloud top -!mhu if (sat_ctp(i,j)<1010._r_kind .and. & -!mhu sat_ctp(i,j)>p_bk(i,j,k)/100._r_kind) then -! -! mhu, some low cloud top press (> 800 hpa) over clean the cloud that observed by METAR -! so add these check to keep cloud base correct -! -!mhu if(sat_ctp(i,j) >= 800.0_r_kind ) then -!mhu cld_cover_3d(i,j,k+1) = & -!mhu max(0.0_r_single, cld_cover_3d(i,j,k+1)) -!mhu else -!mhu cld_cover_3d(i,j,k+1) = 0.0_r_single -!mhu endif -!mhu endif -!mhu end if - end do - enddo - enddo - -! print *, 'h_bk max: ', maxval(h_bk(:,:,1)), ' min: ', minval(h_bk(:,:,1)) - -! ============================================= -! - start building where GOES indicates so -! ============================================= - do j=2,nlat-1 - do i=2,nlon-1 - - if ((w_frac(i,j)>= build_cloud_frac_p) .and. & - (w_frac(i,j)< 99999._r_kind) )then !Dongsoo added - -! --- Cloud info below MIN_CLOUD_P not reliable - firstcloud = 0 -! - pdiff (diff between sat cloud top and model sfc pres) in mb - do k=nsig-1,min_cloud_lev_p,-1 - pdiff = (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) -! --- set closest RUC level w/ cloud - if (pdiff<=0. .and. firstcloud==0) then - pdiffabove = sat_ctp(i,j)-p_bk(i,j,k+1)/100._r_kind - if (abs(pdiffabove) 800 hpa) over clean the cloud that observed by METAR -! so add these check to keep cloud base correct -! - if(sat_ctp(i,j) >= 800.0_r_kind ) then - cld_cover_3d(i,j,k+1) = max(0.0_r_single, cld_cover_3d(i,j,k+1)) - else - cld_cover_3d(i,j,k+1) = 0.0_r_single - endif - firstcloud = 1 - end if - end if - -! no cloud above cloud top - -! -! --- Add 50mb thick (at least 1 level) of cloud where GOES -! indicates cloud top - if (abs(xland(i,j)) > 0.0001_r_single) then - if (sat_ctp(i,j)< min_cloud_p_p .and. & - pdiff<=cloud_up_p ) then - if (firstcloud==0.or. firstcloud==1 & - .and.pdiff >= -1.*sat_cloud_pthick_p) then -! sgb - 2/7/2012 - remove this condition -! Allow cloud building below CO2_preslim and at night and over land -! if (p_bk(i,j,k)/100._r_kind= -1.*sat_cloud_pthick_p) then -! xland ==0 if (p_bk(i,j,k)/100..lt.co2_preslim_p) then - if (l_cld_bld .and. h_bk(i,j,k+1) < cld_bld_hgt) then - cld_cover_3d(i,j,k)=1.0_r_single - else - cld_cover_3d(i,j,k)=-99998.0_r_single - end if - firstcloud = 1 - end if - end if - end if - - end do - end if - enddo ! j - enddo - -! go from pa to mb - do k = 1,nsig - do j = 2,nlat-1 - do i = 2,nlon-1 - p_bk(i,j,k) = p_bk(i,j,k)/100._r_kind - end do - end do - end do -! -END SUBROUTINE cloudCover_NESDIS - diff --git a/lib/GSD/gsdcloud/cloudCover_Surface.f90 b/lib/GSD/gsdcloud/cloudCover_Surface.f90 deleted file mode 100644 index 0c946f33d..000000000 --- a/lib/GSD/gsdcloud/cloudCover_Surface.f90 +++ /dev/null @@ -1,427 +0,0 @@ -SUBROUTINE cloudCover_Surface(mype,nlat,nlon,nsig,r_radius,thunderRadius,& - cld_bld_hgt,t_bk,p_bk,q,h_bk,zh, & - mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,Odist,& - cld_cover_3d,cld_type_3d,wthr_type,pcp_type_3d, & - watericemax, kwatericemax,vis2qc) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudCover_Surface cloud cover analysis using surface observation -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 -! -! ABSTRACT: -! This subroutine determines 3D cloud fractional cover using surface observations -! Code based on RUC assimilation code (hybfront/hybcloud.f) -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! r_radius - influence radius of the cloud observation -! thunderRadius - -! cld_bld_hgt - Height below which cloud building is done -! -! t_bk - 3D background potentional temperature (K) -! p_bk - 3D background pressure (hPa) -! q - 3D moisture (water vapor mixing ratio) -! h_bk - 3D background height (m) -! zh - terrain (m) -! -! mxst_p - maximum observation number -! NVARCLD_P - first dimension of OLCD -! numsao - observation number -! OI - observation x location -! OJ - observation y location -! OLCD - cloud amount, cloud height, visibility -! OWX - weather observation -! Oelvtn - observation elevation -! Odist - distance from the nearest station -! -! output argument list: -! cld_cover_3d- 3D cloud cover -! cld_type_3d - 3D cloud type -! wthr_type - 3D weather type -! pcp_type_3d - 3D weather precipitation type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - REAL(r_single), intent(in) :: r_radius - integer(i_kind),intent(in) :: nlat,nlon,nsig - real(r_single), intent(in) :: thunderRadius - real(r_kind), intent(in) :: cld_bld_hgt -! -! surface observation -! - INTEGER(i_kind),intent(in) :: mxst_p,NVARCLD_P - -! PARAMETER (LSTAID_P=9) - - INTEGER(i_kind),intent(in) :: numsao - real(r_single), intent(in) :: OI(mxst_p) ! x location - real(r_single), intent(in) :: OJ(mxst_p) ! y location - INTEGER(i_kind),intent(in) :: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, - ! visibility - CHARACTER*10, intent(in) :: OWX(mxst_p) ! weather - real(r_single), intent(in) :: Oelvtn(mxst_p) ! elevation - real(r_single), intent(in) :: Odist(mxst_p) ! distance from the nearest station - -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure - real(r_single),intent(in) :: zh(nlon,nlat) ! terrain - real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) - real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height -! - REAL(r_single),intent(in) :: watericemax(mxst_p) ! max of background total liquid water in station - INTEGER(i_kind),intent(in):: kwatericemax(nlon,nlat) ! lowest level of background total liquid water in grid -! -! Variables for cloud analysis -! - real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) - integer(i_kind),intent(inout) :: pcp_type_3d(nlon,nlat,nsig) - real (r_single),intent(inout) :: vis2qc(nlon,nlat) -! -! local -! - real (r_single) :: cloud_zthick_p - data cloud_zthick_p /300._r_kind/ -! - REAL (r_kind) :: spval_p - PARAMETER ( spval_p = 99999.0_r_kind ) - - INTEGER(i_kind) :: i,j,k - INTEGER(i_kind) :: i1,j1,ic - INTEGER(i_kind) :: nx_p, ny_p, nztn_p - INTEGER(i_kind) :: ista - INTEGER(i_kind) :: ich !, iob,job - - REAL(r_kind) :: min_dist !, dist - REAL(r_kind) :: zdiff - REAL(r_kind) :: zlev_clr,cloud_dz,cl_base_ista,betav -! -! -! - real(r_single):: tbk_k(nlon,nlat,nsig) - real(r_single):: cv_bk(nlon,nlat,nsig) - real(r_single):: z_lcl(nlon,nlat) - REAL(r_kind) :: cf_model_base,t_model_base, ht_base - REAL(r_kind) :: t_dry_adiabat,t_inversion_strength - - LOGICAL :: l_cf,l_inversion - LOGICAL :: if_cloud_exist - - integer(i_kind) :: firstcloud,cl_base_broken_k - real(r_single) :: underlim - integer(i_kind) :: npts_near_clr - - -!==================================================================== -! Begin -! -! set constant names consistent with original RUC code -! - nx_p=nlon - ny_p=nlat - nztn_p=nsig - - vis2qc=-9999.0_r_kind - npts_near_clr=0 - zlev_clr = 3650. -! -! -!***************************************************************** -! analysis of surface/METAR cloud observations -! ***************************************************************** - - DO ista=1,numsao - i1 = int(oi(ista)+0.0001_r_kind) - j1 = int(oj(ista)+0.0001_r_kind) - min_dist = Odist(ista) - -!mh - grid point has the closest cloud station - -! -- find out if any precip is present - do ich=1,1 - if ( owx(ista)(ich:ich+1)=='SH' ) wthr_type(i1,j1)=16 - if ( owx(ista)(ich:ich+1)=='TH' .and. & - min_dist < thunderRadius) wthr_type(i1,j1)=1 - if ( owx(ista)(ich:ich+1)=='RA' ) wthr_type(i1,j1)=11 - if ( owx(ista)(ich:ich+1)=='SN' ) wthr_type(i1,j1)=12 - if ( owx(ista)(ich:ich+1)=='PL' ) wthr_type(i1,j1)=13 - if ( owx(ista)(ich:ich+1)=='DZ' ) wthr_type(i1,j1)=14 - if ( owx(ista)(ich:ich+1)=='UP' ) wthr_type(i1,j1)=15 - if ( owx(ista)(ich:ich+1)=='BR' ) wthr_type(i1,j1)=21 - if ( owx(ista)(ich:ich+1)=='FG' ) wthr_type(i1,j1)=22 - enddo - -! Consider clear condition case -! ----------------------------- - if (ocld(1,ista)==0) then - - do ic=1,6 - if(float(abs(ocld(6+ic,ista))) < 55555) then - write(6,*) 'cloudCover_Surface: Observed cloud above the clear level !!!' - write(6,*) 'cloudCover_Surface: some thing is wrong in surface cloud observation !' - write(6,*) 'cloudCover_Surface: check the station no.', ista, 'at process ', mype - write(6,*) ic,OI(ista),OJ(ista) - write(6,*) (ocld(k,ista),k=1,12) - call stop2(114) - endif - enddo -! clean the whole column up to ceilometer height (12 kft) if ob is CLR -! h_bk is AGL, not ASL (per Ming Hu's notes below -! -! zlev_clr = Oelvtn(ista)+3650. -! Upcoming mods commented out below for this commit - 4/3/2010 -! PH: added in column cleaning up to ceilometer height if ob is CLR -! move this check out of this if block. Because it will be used later. -! zlev_clr = 3650. - - do k=1,nztn_p - if (h_bk(i1,j1,k) < zlev_clr) then - cld_cover_3d(i1,j1,k)=0.0_r_kind - pcp_type_3d(i1,j1,k)=0 - endif - end do - - wthr_type(i1,j1)=0 - -! -- Now consider non-clear obs -! -------------------------- - else - -! increase zthick by 1.5x factor for ceiling < 900 m (~3000 ft - MVFR) - cloud_dz = cloud_zthick_p - cl_base_broken_k = -9 -! ????? check with Stan O(h_p) if (Oelvtn(ista).lt.900.) cloud_dz = cloud_zthick_p * 2 - - do ic = 1,6 - if (ocld(ic,ista)>0 .and. ocld(ic,ista)<50) then -! if ( csza(i,j)>=0.10 .and. sat_ctp(i1,j1)>1010.0 & -! .and. sat_ctp(i1,j1)<1050.) go to 1850 -! -! New tweak - 11/07/2009 -! If there was cloud in background over station but if there -! was partial cloudiness within volume and this is one of the -! clear columns within the polygonal area for this METAR, -! then leave it that way and skip. -! if (watericemax(iob,job).gt.0. .and. -! 1 kwatericemax(iob,job).gt.0 .and. -! 1 kwatericemax(iob,job).le.12) then -! npts_cld_match = npts_cld_match + 1 -! dzbase = cl_base_ista - g3(iob,job,kwatericemax(iob,job),h_p) -! sum_dzbase = sum_dzbase + dzbase -! sum_dzbase_abs = sum_dzbase_abs + abs(dzbase) -! end if - -! mhu, Aug. 28, 2013: comment out patial cloudiness. It causes the degradation -! in 3000' ceiling 1-h forecast. -! if(watericemax(ista) > 0._r_single .and. kwatericemax(i1,j1)==-1) then -! !PH 2/28/2013: ensure cloud building at 4 neighboring -! !gridpoints (Odist < 1), regardless of background -! if(Odist(ista) >= 1.0_r_kind) then -! npts_near_clr = npts_near_clr + 1 -! cycle ! skip cloud build at point (i,j) because -! ! background is clear -! endif -! endif - - if(ocld(ic,ista) == 4) then - if(wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) cloud_dz = 1000._r_kind - ! precipitation + highest level - if(wthr_type(i1,j1) == 1) cloud_dz = 10000._r_kind ! thunderstorm - endif - -! --- calculate cloud ceiling level, not exactly, FEW SCT are also considered now -! iob = int(oi(ista)-idw+0.5) -! job = int(oj(ista)-ids+0.5) -! cl_base_ista = (float(ocld(6+ic,ista))+zh(iob,job)) -! cl_base_ista = (float(ocld(6+ic,ista))+Oelvtn(ista)) -! the h_bk is AGL. So observation cloud base should be AGL too, delete Oelvtn(ista) -! cover cloud base observation from AGL to ASL - cl_base_ista = float(ocld(6+ic,ista)) + Oelvtn(ista) - zh(i1,j1) - if(zh(i1,j1) < 1.0_r_kind .and. Oelvtn(ista) > 20.0_r_kind & - .and. float(ocld(6+ic,ista)) < 250.0_r_kind) then - cycle ! limit the use of METAR station over oceas for low cloud base - endif - - firstcloud = 0 - underlim = 10._r_kind ! - - do k=1,nztn_p - zdiff = cl_base_ista - h_bk(i1,j1,k) -! Must be within cloud_dz meters (300 or 1000 currently) -! ------------------------------------------------------------------- -! -- Bring in the clouds if model level is within 10m under cloud level. - if(k==1) underlim=(h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.5_r_kind - if(k==2) underlim=10.0_r_kind ! 100 feet - if(k==3) underlim=20.0_r_kind ! 300 feet - if(k==4) underlim=15.0_r_kind ! 500 feet - if(k==5) underlim=33.0_r_kind ! 1000 feet - if (k>=6 .and. k <= 7) underlim = (h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.6_r_kind - if(k==8) underlim=95.0_r_kind ! 3000 feet - if(k>=9 .and. k= 1.0 .and. (firstcloud==0 .or. abs(zdiff) 10 .and. wthr_type(i1,j1) < 20) then -! cld_type_3d(i1,j1,k)=5 - pcp_type_3d(i1,j1,k)=1 - endif - else - write(6,*) 'cloudCover_Surface: wrong cloud coverage observation!' - call stop2(114) - endif - endif - firstcloud = firstcloud + 1 - end if ! zdiff < cloud_dz - else -! ---- Clear up to cloud base of first cloud level - if (ic==1) cld_cover_3d(i1,j1,k)=0 - if (ocld(ic,ista) == 1) pcp_type_3d(i1,j1,k)=0 - if (ocld(ic,ista) == 3 .or. ocld(ic,ista) == 4) then - if( (wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) & - .or. wthr_type(i1,j1) == 1 ) then - pcp_type_3d(i1,j1,k)=1 - endif - endif - end if ! underlim - end do ! end K loop -! ----clean cloud above stratusphere - do k=1,nztn_p - if( h_bk(i1,j1,k) > 18000 ) cld_cover_3d(i1,j1,k)=0 - enddo -! - end if ! end if ocld > 0 - end do ! end IC loop -! -! clean up to broken (3) or if cloud cover less than 2, clean to cloud top -! - if(cl_base_broken_k > 0 .and. cl_base_broken_k < nztn_p) then - do k=1, cl_base_broken_k - if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 - enddo - else - if(ocld(1,ista) == 1 .or. ocld(1,ista) == 2 ) then - do k=1, nztn_p - if (h_bk(i1,j1,k) < zlev_clr) then - if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 - endif - enddo - endif - endif - - end if ! end if cloudy ob ocld(1,ista) > 0 - -! -- Use visibility for low-level cloud whether - if (wthr_type(i1,j1) < 30 .and. wthr_type(i1,j1) > 20 .and. & - ocld(13,ista) < 5000 .and. ocld(13,ista) > 1 .and. & - min_dist < 20.0_r_single) then - cld_type_3d(i1,j1,1) = 2 - cld_type_3d(i1,j1,2) = 2 - betav = 3.912_r_kind / (float(ocld(13,ista)) / 1000._r_kind) - vis2qc(i1,j1) = ( (betav/144.7_r_kind) ** 1.14_r_kind) / 1000._r_kind - endif ! cloud or clear - - ENDDO ! ista - - -! Determine if the layer is dry or it has inversion. -! (in either case, the cloud will be cleared out) -! - IF(.false.) THEN ! Set inversion strength flag - call BckgrndCC(nlon,nlat,nsig, & - t_bk,p_bk,q,h_bk,zh, & - cv_bk,tbk_k,z_lcl) ! out - - DO j = 2,nlat-1 - DO i = 2,nlon-1 - - if_cloud_exist=.false. - do k=nsig-1,2,-1 - if(cld_cover_3d(i,j,k) > 0.01_r_kind) then - cf_model_base = cv_bk(i,j,k) - t_model_base = tbk_k(i,j,k) - ht_base=h_bk(i,j,k) - if_cloud_exist=.true. - endif - enddo -! -! note, do we need to consider cloud base from background - if(if_cloud_exist) then - do k=2, nsig-1 - if(cld_cover_3d(i,j,k) > 0.01_r_kind) then - l_cf=.false. - l_inversion=.false. - t_dry_adiabat = tbk_k(i,j,2) -.0098_r_kind * (h_bk(i,j,k) - h_bk(i,j,2)) - t_inversion_strength = tbk_k(i,j,k) - t_dry_adiabat - - IF( (tbk_k(i,j,k) > t_model_base) .and. & - (tbk_k(i,j,k) > 283.15_r_kind) .and. & ! temp check - (t_inversion_strength > 4._r_kind) ) then ! delta theta chk - l_inversion = .true. ! Inversion exists - endif - IF( (cv_bk(i,j,k) < cf_model_base - 0.3_r_kind) .and. & - (h_bk(i,j,k) - ht_base >= 500._r_kind) ) THEN - l_cf = .true. ! Dry layer exists - ENDIF - if(l_inversion) then - cld_cover_3d(i,j,k) =0.0_r_kind - endif - endif ! in cloud - enddo ! k - endif ! if_cloud_exist = true - - ENDDO ! i - ENDDO ! j - - END IF ! .true. for dry-inversion check. - -END SUBROUTINE cloudCover_Surface - diff --git a/lib/GSD/gsdcloud/cloudCover_radar.f90 b/lib/GSD/gsdcloud/cloudCover_radar.f90 deleted file mode 100644 index 97be8759c..000000000 --- a/lib/GSD/gsdcloud/cloudCover_radar.f90 +++ /dev/null @@ -1,131 +0,0 @@ -SUBROUTINE cloudCover_radar(mype,nlat,nlon,nsig,h_bk,grid_ref, & - cld_cover_3d,wthr_type) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudCover_radar cloud cover analysis using radar reflectivity -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 -! -! ABSTRACT: -! This subroutine find cloud cover using radar reflectivity -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! h_bk - 3D background height -! grid_ref - radar reflectivity in analysis grid -! -! output argument list: -! cld_cover_3d- 3D cloud cover -! wthr_type - 3D weather type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use constants, only: deg2rad, rad2deg, pi - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - integer(i_kind),intent(in) :: nlat,nlon,nsig -! -! background -! - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig+1) ! height -! -! Observation -! - real(r_kind), intent(in) :: grid_ref(nlon,nlat,nsig) -! -! Variables for cloud analysis -! - real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) -! - REAL(r_kind) :: ref_base ! "significant" radar echo at upper levels -! - REAL(r_kind) :: cloud_base -! -!----------------------------------------------------------- -! -! threshold -! - - REAL(r_kind) :: radar_cover - PARAMETER(radar_cover=1.02) - REAL(r_kind) :: thresh_cvr ! lower radar echo threshold for cloud filling - PARAMETER (thresh_cvr = 0.9) -! -! temp. -! - INTEGER(i_kind) :: i,j,k - REAL(r_kind) :: zs_1d(nsig) - -! -!==================================================================== -! Begin -! - ref_base = 10.0 -! -!----------------------------------------------------------------------- -! -! Essentially, this go downward to detect radar tops in time -! to search for a new cloud base -! -!----------------------------------------------------------------------- -! - - DO i = 2,nlon-1 - DO j = 2,nlat-1 - - DO k=1,nsig - zs_1d(k) = h_bk(i,j,k) - END DO - - cloud_base = 200000._r_kind -! - DO k = nsig-1,1,-1 - IF( (cld_cover_3d(i,j,k) < thresh_cvr) .and. & - (cld_cover_3d(i,j,k+1) >= thresh_cvr .and. & - cld_cover_3d(i,j,k+1) < 2.0_r_kind) ) THEN - cloud_base = 0.5_r_kind * (zs_1d(k) + zs_1d(k+1)) - END IF - END DO ! k - - - DO k = 2, nsig-1 - if(grid_ref(i,j,k) > ref_base ) then - if( zs_1d(k) > cloud_base .and. cld_cover_3d(i,j,k) < thresh_cvr ) then - cld_cover_3d(i,j,k)=radar_cover - endif - endif - ENDDO ! k - - ENDDO ! i - ENDDO ! j -! - -END SUBROUTINE cloudCover_radar - diff --git a/lib/GSD/gsdcloud/cloudLWC.f90 b/lib/GSD/gsdcloud/cloudLWC.f90 deleted file mode 100644 index 92c908b73..000000000 --- a/lib/GSD/gsdcloud/cloudLWC.f90 +++ /dev/null @@ -1,419 +0,0 @@ -SUBROUTINE cloudLWC_stratiform(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk, & - cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & - cldwater_3d,cldice_3d) -! -! find cloud liquid water content -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudLWC_stratiform find cloud liquid water content -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine calculate liquid water content for stratiform cloud -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! q_bk - 3D moisture -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! cld_cover_3d- 3D cloud cover -! cld_type_3d - 3D cloud type -! wthr_type - 3D weather type -! cloudlayers_i - 3D cloud layer index -! -! output argument list: -! cldwater_3d - 3D cloud water mixing ratio (g/kg) -! cldice_3d - 3D cloud ice mixing ratio (g/kg) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind, r_kind - - implicit none - - integer(i_kind),intent(in):: mype - integer(i_kind),intent(in):: nlat,nlon,nsig -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature - real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure -! -! -! Variables for cloud analysis -! - real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: wthr_type(nlon,nlat) -! -! cloud layers -! - integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers -! 1= the number of layers -! 2,4,... bottom -! 3,5,... top -! -! cloud water and cloud ice -! - real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) - real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) - real (r_single) :: cloudtmp_3d(nlon,nlat,nsig) -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k,ilvl,nlvl - INTEGER(i_kind) :: kb,kt - real(r_single) :: p_pa_1d(nsig), thv(nsig) - real(r_single) :: cloudqvis(nlon,nlat,nsig) - real(r_single) :: rh(nlon,nlat,nsig) - -! --- Key parameters -! Rh_clear_p = 0.80 RH to use when clearing cloud -! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice - - real(r_single) Cloud_q_qvis_rat_p, cloud_q_qvis_ratio - real(r_single) auto_conver - real(r_single) rh_clear_p - data Cloud_q_qvis_rat_p/ 0.05_r_single/ - data auto_conver /0.0002_r_single/ - data rh_clear_p /0.8_r_single/ - - real(r_kind) :: es0_p - parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) - real(r_kind) SVP1,SVP2,SVP3 - data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ - - real(r_kind) :: temp_qvis1, temp_qvis2 - data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ - - REAL(r_kind) stab, stab_threshold - INTEGER(i_kind) :: kp3,km3 - - REAL(r_kind) :: q, Temp, tv, evs, qvs1, eis, qvi1, watwgt, qavail -! -!==================================================================== -! Begin -! - cldwater_3d=-99999.9_r_kind - cldice_3d=-99999.9_r_kind - cloudtmp_3d=-99999.9_r_kind -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - rh=0.0 - DO j = 2,nlat-1 - DO i = 2,nlon-1 -! - DO k = 2,nsig-1 - p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single - q = q_bk(i,j,k)/(1._r_single+q_bk(i,j,k)) ! Q = water vapor specific humidity - ! q_bk = water vapor mixing ratio - tv = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp -! now, tmperature from GSI s potential temperature - Temp = tv ! temperature -! evs, eis in mb - evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) - qvs1 = 0.62198_r_kind*evs*100._r_kind/(p_pa_1d(k)-100._r_kind*evs) ! qvs1 is mixing ratio kg/kg, so no need next line -! qvs1 = qvs1/(1.0-qvs1) - eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) - qvi1 = 0.62198_r_kind*eis*100._r_kind/(p_pa_1d(k)-100._r_kind*eis) ! qvi1 is mixing ratio kg/kg, so no need next line -! qvi1 = qvi1/(1.0-qvi1) -! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) -! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 - watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& - (temp_qvis1-temp_qvis2))) - cloudtmp_3d(i,j,k)= Temp - cloudqvis(i,j,k)= (watwgt*qvs1 + (1._r_kind-watwgt)*qvi1) -! qvis(i,j,k)= (watwgt*qvs1 + (1.-watwgt)*qvi1) - rh(i,j,k) = q_bk(i,j,k)/cloudqvis(i,j,k) - enddo - enddo ! i - enddo ! j - - stab_threshold = 3._r_kind/10000._r_kind - DO j = 2,nlat-1 - DO i = 2,nlon-1 - DO k = 1,nsig - p_pa_1d(k) = p_bk(i,j,k)*100.0_r_kind - thv(k) = t_bk(i,j,k)*(1.0_r_kind + 0.6078_r_kind*q_bk(i,j,k)) - ENDDO - nlvl=cloudlayers_i(i,j,1) - if(nlvl > 0 ) then - DO ilvl = 1, nlvl ! loop through cloud layers - kb=cloudlayers_i(i,j,2*ilvl) - kt=cloudlayers_i(i,j,2*ilvl+1) - DO k = kb,kt - -! -- change these to +/- 3 vertical levels - kp3 = min(nsig,k+5) - km3 = max(1 ,k) - stab = (thv(kp3)-thv(km3))/(p_pa_1d(km3)-p_pa_1d(kp3)) - -! -- stability check. Use 2K/100 mb above 600 mb and -! 3K/100mb below (nearer sfc) - if ((stab600._r_kind) & - .or. stab<0.66_r_kind*stab_threshold ) then -! write(*,'(a,3i4,f8.3)') 'skip building cloud in stable layer',i,j,k,stab*10000.0 - cld_cover_3d(i,j,k)=-99999.0 - elseif(rh(i,j,k) < 0.40 .and. ((cloudqvis(i,j,k)-q_bk(i,j,k)) > 0.003_r_kind)) then -! write(*,'(a,3i4,2f6.2)') 'skip building cloud in too-dry layer',i,j,k,& -! rh(i,j,k),(cloudqvis(i,j,k)-q_bk(i,j,k))*1000.0 - cld_cover_3d(i,j,k)=-99999.0_r_single - else -!dk * we need to avoid adding cloud if sat_ctp is lower than 650mb -! ph - 2/7/2012 - use a temperature-dependent cloud_q_qvis_ratio -! and with 0.1 smaller condensate mixing ratio building also for temp < 263.15 - Temp = cloudtmp_3d(i,j,k) -! watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& -! (temp_qvis1-temp_qvis2))) -! sgb - 1/13/2017 - change to discrete change from building water cloud or ice -! cloud (at temp_qvis2) - if (temp >= temp_qvis2) then - watwgt = 1. - cloud_q_qvis_ratio = watwgt*cloud_q_qvis_rat_p - qavail = min(0.25_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) - else - watwgt = 0. - cloud_q_qvis_ratio = 0.1*cloud_q_qvis_rat_p - qavail = min(0.1_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) - endif -! qavail = min(0.5_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) -! change cloud water from 0.5 g/kg to 0.25 g/kg - -! ------------------------------------------------------------------- -! - set cloud water mixing ratio - no more than 0.1 g/kg, -! which is the current autoconversion mixing ratio set in exmoisg -! according to John Brown - 14 May 99 -! ------------------------------------------------------------------- - cldwater_3d(i,j,k) = watwgt*qavail*1000.0_r_kind ! g/kg -! - set ice mixing ratio - cldice_3d(i,j,k)= (1.-watwgt)*qavail*1000.0_r_kind ! g/kg -! end if - end if - enddo ! k - enddo ! ilvl - endif ! nlvl > 1 - enddo ! i - enddo ! j - -END SUBROUTINE cloudLWC_stratiform - -SUBROUTINE cloudLWC_Cumulus(nlat,nlon,nsig,h_bk,t_bk,p_bk, & - cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & - cldwater_3d,cldice_3d,cloudtmp_3d) -! -! find cloud liquid water content -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudLWC_Cumulus find cloud liquid water content for cumulus cloud -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine calculates liquid water content for cumulus cloud -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! h_bk - 3D height -! t_bk - 3D background potentional temperature (K) -! p_bk - 3D background pressure (hPa) -! cld_cover_3d- 3D cloud cover -! cld_type_3d - 3D cloud type -! wthr_type - 3D weather type -! cloudlayers_i - 3D cloud layer index -! -! output argument list: -! cldwater_3d - 3D cloud water mixing ratio (g/kg) -! cldice_3d - 3D cloud ice mixing ratio (g/kg) -! cloudtmp_3d - 3D cloud temperature -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind,r_kind - - implicit none - integer(i_kind),intent(in) :: nlat,nlon,nsig -! -! surface observation -! -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature - real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure -! -! -! Variables for cloud analysis -! - real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: wthr_type(nlon,nlat) -! -! cloud layers -! - integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers -! 1= the number of layers -! 2,4,... bottom -! 3,5,... top -! -! cloud water and cloud ice -! - real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) - real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) - real (r_single),intent(out) :: cloudtmp_3d(nlon,nlat,nsig) -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k,ilvl,nlvl - INTEGER(i_kind) :: kb,kt,k1 - real (r_single) :: zs_1d(nsig) - real (r_single) :: t_1d(nsig) - real (r_single) :: p_pa_1d(nsig) - real (r_single) :: p_mb_1d(nsig) - real (r_single) :: cld_base_m, cld_top_m - real (r_single) :: cld_base_qc_m, cld_top_qc_m - - real (r_single) :: slwc_1d(nsig) - real (r_single) :: cice_1d(nsig) - real (r_single) :: ctmp_1d(nsig) - - LOGICAL :: l_prt - INTEGER(i_kind) :: iflag_slwc -! -!==================================================================== -! Begin -! - l_prt =.false. - iflag_slwc = 11 - cldwater_3d=-99999.9_r_single - cldice_3d =-99999.9_r_single - cloudtmp_3d=-99999.9_r_single -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - DO j = 2,nlat-1 - DO i = 2,nlon-1 -! - DO k = 1,nsig ! Initialize - t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp - zs_1d(k) = h_bk(i,j,k) - p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single - p_mb_1d(k) = p_bk(i,j,k) - END DO -!----------------------------------------------------------------------- - nlvl=cloudlayers_i(i,j,1) - if(nlvl > 0 ) then - DO ilvl = 1, nlvl ! loop through cloud layers - - kb=cloudlayers_i(i,j,2*ilvl) - kt=cloudlayers_i(i,j,2*ilvl+1) - - cld_base_m = 0.5_r_single * (zs_1d(kb-1) + zs_1d(kb)) - cld_top_m = 0.5_r_single * (zs_1d(kt) + zs_1d(kt+1)) -! - IF(iflag_slwc /= 0) THEN - IF(iflag_slwc < 10) THEN ! simple adiabatc scheme - CALL get_slwc1d (nsig,cld_base_m,cld_top_m,kb,kt & - ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) - - ELSE ! iflag_slwc > 10, new Smith-Feddes scheme - DO k1 = 1,nsig ! Initialize - slwc_1d(k1) = 0.0_r_single - cice_1d(k1) = 0.0_r_single - ctmp_1d(k1) = t_bk(i,j,k1) - END DO -! -!----------------------------------------------------------------------- -! -! QC the data going into SMF -! -!----------------------------------------------------------------------- -! - IF(cld_top_m > zs_1d(nsig-1) - 110._r_single) THEN - cld_top_qc_m = zs_1d(nsig-1) - 110._r_single - cld_base_qc_m = & - MIN(cld_base_m,cld_top_qc_m - 110._r_single) - ELSE ! normal case - cld_top_qc_m = cld_top_m - cld_base_qc_m = cld_base_m - END IF -! - CALL get_sfm_1d(nsig,cld_base_qc_m,cld_top_qc_m & - ,zs_1d,p_mb_1d,t_1d & - ,slwc_1d,cice_1d,ctmp_1d,l_prt) -! - END IF ! iflag_slwc < 10 - END IF ! iflag_slwc .ne. 0 -! - DO k1 = kb,kt ! Loop through the cloud layer - IF(iflag_slwc /= 0) THEN - IF(slwc_1d(k1) > 0._r_single) cldwater_3d(i,j,k1)=slwc_1d(k1) - IF(cice_1d(k1) > 0._r_single) cldice_3d(i,j,k1)=cice_1d(k1) - cloudtmp_3d(i,j,k1)=ctmp_1d(k1) - END IF ! iflag_slwc .ne. 0 - END DO ! k1 - - enddo ! ilvl - endif ! nlvl > 0 - - ENDDO ! i - ENDDO ! j - -END SUBROUTINE cloudLWC_Cumulus diff --git a/lib/GSD/gsdcloud/cloudLayers.f90 b/lib/GSD/gsdcloud/cloudLayers.f90 deleted file mode 100644 index eb2d52396..000000000 --- a/lib/GSD/gsdcloud/cloudLayers.f90 +++ /dev/null @@ -1,167 +0,0 @@ -SUBROUTINE cloudLayers(nlat,nlon,nsig,h_bk,zh,cld_cover_3d,cld_type_3d, & - cloudlayers_i) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudLayers find cloud layers -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 -! -! ABSTRACT: -! This subroutine find cloud layer based on cloud cover -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! h_bk - 3D background height -! zh - terrain -! cld_cover_3d- 3D cloud cover -! cld_type_3d - 3D cloud type -! -! output argument list: -! cloudlayers_i - 3D cloud layer index -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind - - implicit none - - integer(i_kind),intent(in) :: nlat,nlon,nsig -! -! background -! - real(r_single), intent(in) :: zh(nlon,nlat) ! terrain - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height -! -! Variables for cloud analysis -! - real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) -! -! output -! - integer(i_kind),intent(out):: cloudlayers_i(nlon,nlat,21) ! 5 different layers -! 1= the number of layers -! 2,4,... bottom -! 3,5,... top -! -! threshold - real (r_single) :: thresh_cvr - parameter ( thresh_cvr = 0.1 ) -!----------------------------------------------------------- -! -! temp. -! - INTEGER :: i,j,k,nlvl - INTEGER :: k_top,k_base - real (r_single) :: zs_1d(nsig) - real (r_single) :: cv_1d(nsig) -! -!==================================================================== -! Begin -! - cloudlayers_i=-99999 -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - - DO j = 2,nlat-1 - DO i = 2,nlon-1 -! Initialize - DO k = 1,nsig - zs_1d(k) = h_bk(i,j,k) - cv_1d(k) = cld_cover_3d(i,j,k) - END DO -! -!----------------------------------------------------------------------- -! -! Get Base and Top -! -!----------------------------------------------------------------------- -! - k=1 - nlvl=0 - DO WHILE (k <= nsig-1) - - IF((cv_1d(k+1) >= thresh_cvr .and. cv_1d(k)= thresh_cvr) ) THEN - k_base = k + 1 - - k = k + 1 - DO WHILE (cv_1d(k) >= thresh_cvr .and. k < nsig) - k_top = k -! -!----------------------------------------------------------------------- -! -! We have now defined a cloud base and top -! -!----------------------------------------------------------------------- -! - k=k+1 - enddo - k=k-1 -!----------------------------------------------------------------------- -! -! Make sure cloud base and top stay in the model domain -! -!----------------------------------------------------------------------- -! - nlvl=nlvl+2 - if(nlvl > 20 ) then - write(6,*) 'cloudLayers: Too many cloud layers in grid point:' - write(6,*) i,j - call stop2(114) - endif - cloudlayers_i(i,j,nlvl) = MIN(k_base,nsig-1) - cloudlayers_i(i,j,nlvl+1) = MIN(k_top,nsig-1) - endif -! - k=k+1 - ENDDO ! k -! - cloudlayers_i(i,j,1) = nlvl/2 - ENDDO - ENDDO -! -! -! - DO j = 2,nlat-1 - DO i = 2,nlon-1 - if(cloudlayers_i(i,j,1) > 0 ) then - do k=1,cloudlayers_i(i,j,1) - if(cloudlayers_i(i,j,k) < 0 .or. cloudlayers_i(i,j,k) > 55555) then - write(6,*) 'cloudLayers: ckeck', i,j,k, cloudlayers_i(i,j,k) - endif - enddo - endif - enddo - enddo -! - -END SUBROUTINE cloudLayers - diff --git a/lib/GSD/gsdcloud/cloudType.f90 b/lib/GSD/gsdcloud/cloudType.f90 deleted file mode 100644 index 2b97e7250..000000000 --- a/lib/GSD/gsdcloud/cloudType.f90 +++ /dev/null @@ -1,147 +0,0 @@ -SUBROUTINE cloudType(nlat,nlon,nsig,h_bk,t_bk,p_bk,radar_3d, & - cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudType decide cloud type -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine decide cloud type -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! h_bk - 3D background height -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! radar_3d - 3D radar reflectivity in analysis grid (dBZ) -! -! cld_cover_3d- 3D cloud cover -! wthr_type - 3D weather type -! cloudlayers_i - 3D cloud layer index -! -! output argument list: -! cld_type_3d - 3D cloud type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000, half - use kinds, only: r_single,i_kind,r_kind - - implicit none - integer(i_kind),INTENT(IN) :: nlat,nlon,nsig -! -! background -! - real(r_single),INTENT(IN) :: h_bk(nlon,nlat,nsig) ! height - real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! temperature - real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure -! -! observation -! - real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity -! -! Variables for cloud analysis -! - real (r_single), INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind), INTENT(IN) :: wthr_type(nlon,nlat) - integer(i_kind),INTENT(OUT) :: cld_type_3d(nlon,nlat,nsig) -! -! cloud layers -! - integer(i_kind), INTENT(IN) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers -! 1= the number of layers -! 2,4,... bottom -! 3,5,... top -! -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k,ilvl,nlvl - INTEGER(i_kind) :: itype - INTEGER(i_kind) :: kb,kt,k1 - real(r_single) :: cld_base_m, cld_top_m - - real (r_single) :: zs_1d(nsig) - real (r_single) :: dte_dz_1d(nsig) - real (r_single) :: t_1d(nsig) - real (r_single) :: p_mb_1d(nsig) -! - CHARACTER (LEN=2) :: c2_type -! -!==================================================================== -! Begin -! -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - return - - DO j = 2,nlat-1 - DO i = 2,nlon-1 -! - DO k = 1,nsig ! Initialize - t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp !K - zs_1d(k) = h_bk(i,j,k) - p_mb_1d(k) = p_bk(i,j,k) - END DO -!----------------------------------------------------------------------- - nlvl=cloudlayers_i(i,j,1) - if(nlvl > 10 ) then - write(*,*) 'warning: too many cloud levels' - nlvl=10 - endif - if(nlvl > 0 ) then - DO ilvl = 1, nlvl ! loop through cloud layers - kb=cloudlayers_i(i,j,2*ilvl) - kt=cloudlayers_i(i,j,2*ilvl+1) - - CALL get_stability (nsig,t_1d,zs_1d,p_mb_1d & - ,kb,kt,dte_dz_1d) - - cld_base_m = half * (zs_1d(kb-1) + zs_1d(kb)) - cld_top_m = half * (zs_1d(kt) + zs_1d(kt+1)) - DO k1 = kb,kt - CALL get_cloudtype(t_1d(k1),dte_dz_1d(k1) & - ,cld_base_m,cld_top_m,itype,c2_type) -! - IF(radar_3d(i,j,k1) > 45._r_kind) THEN - itype = 10 ! CB - END IF - - cld_type_3d(i,j,k1) = itype - END DO !k1 - enddo ! ilvl - endif ! nlvl > 0 - - ENDDO ! i - ENDDO ! j - -END SUBROUTINE cloudType - diff --git a/lib/GSD/gsdcloud/cloud_saturation.f90 b/lib/GSD/gsdcloud/cloud_saturation.f90 deleted file mode 100644 index 586af171e..000000000 --- a/lib/GSD/gsdcloud/cloud_saturation.f90 +++ /dev/null @@ -1,330 +0,0 @@ -SUBROUTINE cloud_saturation(mype,l_conserve_thetaV,i_conserve_thetaV_iternum, & - nlat,nlon,nsig,q_bk,t_bk,p_bk, & - cld_cover_3d,wthr_type, & - cldwater_3d,cldice_3d,sumqci) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloud_saturation to ensure water vapor saturation at all cloudy grid points -! also to ensure sub saturation in clear point -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine calculate liquid water content for stratiform cloud -! -! PROGRAM HISTORY LOG: -! 2010-10-06 Hu check whole 3D mositure field and get rid of supersaturation -! 2009-01-20 Hu Add NCO document block -! 2017-04-13 Ladwig Add comments & theta-v conservation for missing obs case -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! q_bk - 3D moisture -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! cldwater_3d - 3D analysis cloud water mixing ratio (g/kg) -! cldice_3d - 3D analysis cloud ice mixing ratio (g/kg) -! cld_cover_3d- 3D cloud cover -! wthr_type - 3D weather type -! l_conserve_thetaV - if .true. conserving thetaV -! i_conserve_thetaV_iternum - iteration number for conserving thetaV -! -! output argument list: -! q_bk - 3D moisture -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000,one,zero,fv - use kinds, only: r_single,i_kind, r_kind - - implicit none - - integer(i_kind),intent(in):: mype - integer(i_kind),intent(in):: nlat,nlon,nsig - logical,intent(in):: l_conserve_thetaV - integer(i_kind),intent(in):: i_conserve_thetaV_iternum -! -! background -! - real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) - real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) - REAL(r_kind),intent(in) :: sumqci(nlon,nlat,nsig) ! total liquid water -! -! Variables for cloud analysis -! - real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: wthr_type(nlon,nlat) -! -! cloud water and cloud ice -! - real (r_single),intent(in) :: cldwater_3d(nlon,nlat,nsig) ! kg/kg - real (r_single),intent(in) :: cldice_3d(nlon,nlat,nsig) ! kg/kg -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k - real(r_single) :: cloudqvis,ruc_saturation - -! --- Key parameters -! Rh_clear_p = 0.80 RH to use when clearing cloud - - real(r_single) rh_cld3_p - real(r_single) rh_clear_p - data rh_cld3_p /0.98_r_single/ ! mhu, do we need to adjust this number to 0.94, WPP has PBL top set as 0.95 - data rh_clear_p /0.8_r_single/ - - real(r_kind) :: es0_p - parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) - - INTEGER(i_kind) :: miter,nnn - - REAL(r_kind) :: constantTv, Temp - real(r_single) :: qtemp -! -!==================================================================== -! Begin -! -! - miter=i_conserve_thetaV_iternum ! iteration number for conserving Tv - - DO j = 2,nlat-1 - DO i = 2,nlon-1 - DO k = 2,nsig-1 - -!mhu p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single -! qv= q_bk(i,j,k)/(one+q_bk(i,j,k)) ! qv = water vapor specific humidity -! ! q_bk = water vapor mixing ratio -! now, tmperature from GSI s potential temperature. get temperature - Temp = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp - -! now, calculate saturation -! - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) -! -! moisture adjustment based on cloud -! -! -! check each grid point to make sure no supersaturation - q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) -! now, calculate constant virtual temperature - constantTv=Temp*(one + fv*q_bk(i,j,k)) -! - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! If valid cld_cover_3d - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if(cld_cover_3d(i,j,k) > -0.0001_r_kind .and. & - cld_cover_3d(i,j,k) < 2.0_r_kind) then - !############################################# - ! if clear ob - !############################################# - if(cld_cover_3d(i,j,k) <= 0.0001_r_kind) then - ! adjust RH to be below 85 percent(50%?) if - ! 1) cloudyn = 0 - ! 2) at least 100 mb above sfc - ! 3) no precip from sfc obs - !make sure that clear volumes are no more than rh_clear_p RH. - if( (sumqci(i,j,k))>1.0e-12_r_kind .and. & - (p_bk(i,j,1) - p_bk(i,j,k))>100._r_kind .and. & - wthr_type(i,j) <=0 ) then - if( q_bk(i,j,k) > cloudqvis * rh_clear_p) then - qtemp = cloudqvis * rh_clear_p - if(l_conserve_thetaV) then - do nnn=1,miter - Temp=constantTv/(one + fv*qtemp) - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) - qtemp = cloudqvis * rh_clear_p - enddo - t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp - endif - q_bk(i,j,k) = qtemp - endif - endif - !C - moisten layers above and below cloud layer - if(cld_cover_3d(i,j,k+1) > 0.6_r_kind .or. & - cld_cover_3d(i,j,k-1) > 0.6_r_kind ) then - if( cloudqvis > q_bk(i,j,k) ) then - qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) - if(l_conserve_thetaV) then - do nnn=1,miter - Temp=constantTv/(one + fv*qtemp) - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) - qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) - enddo - t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp - endif - q_bk(i,j,k)=qtemp - endif - endif - !############################################# - ! -- If SCT/FEW present, reduce RH only down to rh_cld3_p (0.98) - ! corresponding with cloudyn=3 - !############################################# - elseif(cld_cover_3d(i,j,k) > 0.0001_r_kind .and. & - cld_cover_3d(i,j,k) < 0.6_r_kind ) then - if( q_bk(i,j,k) > cloudqvis * rh_cld3_p) then - qtemp = cloudqvis * rh_cld3_p - if(l_conserve_thetaV) then - do nnn=1,miter - Temp=constantTv/(one + fv*qtemp) - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) - qtemp = cloudqvis * rh_cld3_p - enddo - t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp - endif - q_bk(i,j,k) = qtemp - endif - !############################################# - ! else: cld_cover_3d is > 0.6: cloudy case - !############################################# - else ! set qv at 102%RH - if( q_bk(i,j,k) < cloudqvis * 1.00_r_single ) then - qtemp = cloudqvis * 1.00_r_single - if(l_conserve_thetaV) then - do nnn=1,miter - Temp=constantTv/(one + fv*qtemp) - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) - qtemp = cloudqvis * 1.00_r_single - enddo - t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp - endif - q_bk(i,j,k) = qtemp - endif - endif - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! cld_cover_3d is missing - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - else ! cloud cover is missing - ! Ensure saturation in all cloudy volumes. - ! Since saturation has already been ensured for new cloudy areas (cld_cover_3d > 0.6) - ! we now ensure saturation for all cloud 3-d points, whether cloudy from background - ! (and not changed - cld_cover_3d < 0) - ! If cloud cover is missing, (cldwater_3d(i,j,k)+cldice_3d(i,j,k) = sumqci(i,j,k), - ! which is background cloud liquid water. - if ((cldwater_3d(i,j,k)+cldice_3d(i,j,k))>1.0e-5_r_kind) then - !conserve - qtemp = cloudqvis * 1.00_r_single - if(l_conserve_thetaV) then - do nnn=1,miter - Temp=constantTv/(one + fv*qtemp) - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) - qtemp = cloudqvis * 1.00_r_single - enddo - t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp - endif - !limit increment to 5g/kg - q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+0.005_r_single) - endif - endif -! -! check each grid point to make sure no supersaturation -! - q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) -! - - enddo ! k - enddo ! i - enddo ! j - -END SUBROUTINE cloud_saturation - -function ruc_saturation(Temp,pressure) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: ruc_saturation calculate saturation -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-11-28 -! -! ABSTRACT: -! This subroutine calculate saturation -! -! PROGRAM HISTORY LOG: -! 2011-11-28 Hu Initial -! -! -! input argument list: -! pressure - background pressure (hPa) -! Temp - temperature (K) -! -! output argument list: -! ruc_saturation -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ - - use constants, only: rd_over_cp, h1000,one,zero - use kinds, only: r_single,i_kind, r_kind -! - implicit none - real(r_single) :: ruc_saturation - - REAL(r_kind), intent(in) :: Temp ! temperature in K - real(r_single),intent(in) :: pressure ! pressure (hpa) - - real(r_kind) :: es0_p - parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) - real(r_kind) SVP1,SVP2,SVP3 - data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ - - real(r_kind) :: temp_qvis1, temp_qvis2 - data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ - - REAL(r_kind) :: evs, qvs1, eis, qvi1, watwgt -! - -! -! evs, eis in mb -! For this part, must use the water/ice saturation as f(temperature) - evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) - qvs1 = 0.62198_r_kind*evs/(pressure-evs) ! qvs1 is mixing ratio kg/kg - ! so no need next line -! qvs1 = qvs1/(1.0-qvs1) -! Get ice saturation and weighted ice/water saturation ready to go -! for ensuring cloud saturation below. - eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) - qvi1 = 0.62198_r_kind*eis/(pressure-eis) ! qvi1 is mixing ratio kg/kg, - ! so no need next line -! qvi1 = qvi1/(1.0-qvi1) -! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) -! watwgt = max(zero,min(one,(Temp-251.15_r_kind)/& -! (263.15_r_kind-251.15_r_kind))) -! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 - watwgt = max(zero,min(one,(Temp-temp_qvis2)/& - (temp_qvis1-temp_qvis2))) - ruc_saturation= (watwgt*qvs1 + (one-watwgt)*qvi1) ! kg/kg -! -end function ruc_saturation diff --git a/lib/GSD/gsdcloud/configure b/lib/GSD/gsdcloud/configure deleted file mode 100755 index bb10af0ac..000000000 --- a/lib/GSD/gsdcloud/configure +++ /dev/null @@ -1,93 +0,0 @@ -#!/bin/sh -# -# Creates configuration Makefile. Before attempting to make anything -# in this directory, enter -# -# ./configure -# -# !REVISION HISTORY -# -# 09oct97 da Silva Initial code. -# 19oct97 da Silva Simplified. -# 22oct97 Jing Guo Converted to libpsas.a environment -# - special configuration for CRAY -# - fool-prove configuration -# - additional information -# 23dec99 da Silva Modified error messages. -# -#..................................................................... - -set -x - -c=`basename $0 .sh` - -type=${1:-"unknown"} -echo $type - - -# If type=clean, remove soft links and exit -# ----------------------------------------- -if [ "$type" = "clean" ]; then - if [ -r makefile ]; then - echo "$c: remove makefile" 1>&2 - rm makefile - fi - if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf - fi - exit -fi - - -# Set makeconf based on user input -# --------------------------------------- -makeconf="Makefile.conf.$type" - - -# Node specific configuration -# --------------------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" -fi - -# Machine specific -# ---------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - machine="`uname -m | awk '{print $1}'`" - machine=`echo $machine | tr "[a-z]" "[A-Z]"` - compiler=$F90 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - makeconf="${makeconf}.${machine}.${compiler}" -fi - -# Site specific configuration -# --------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" -fi - -# if the OS is UNICOS, it does not follow the convention -# ------------------------------------------------------ -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - mech="`uname -m | awk '{print $1}'`" - if [ "${mech}" = CRAY ]; then - makeconf="Makefile.conf.UNICOS" - fi -fi - -# Create soft link for Makefile.conf -# ------------------------------------------------------ -if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf -fi -ln -s ${makeconf} Makefile.conf - -echo "$c: using ${makeconf} in `pwd`" 1>&2 - -#. diff --git a/lib/GSD/gsdcloud/constants.f90 b/lib/GSD/gsdcloud/constants.f90 deleted file mode 100755 index 9d4263197..000000000 --- a/lib/GSD/gsdcloud/constants.f90 +++ /dev/null @@ -1,324 +0,0 @@ -module constants -!$$$ module documentation block -! . . . . -! module: constants -! prgmmr: treadon org: np23 date: 2003-09-25 -! -! abstract: This module contains the definition of various constants -! used in the gsi code -! -! program history log: -! 2003-09-25 treadon - original code -! 2004-03-02 treadon - allow global and regional constants to differ -! 2004-06-16 treadon - update documentation -! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind -! and tiny_single -! 2004-11-16 treadon - add huge_single, huge_r_kind parameters -! 2005-01-27 cucurull - add ione -! 2005-08-24 derber - move cg_term to constants from qcmod -! 2006-03-07 treadon - add rd_over_cp_mass -! 2006-05-18 treadon - add huge_i_kind -! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) -! 2006-07-28 derber - add r1000 -! 2007-03-20 rancic - add r3600 -! 2009-02-05 cucurull - modify refractive indexes for gpsro data -! -! Subroutines Included: -! sub init_constants_derived - compute derived constants -! sub init_constants - set regional/global constants -! -! Variable Definitions: -! see below -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - - use kinds, only: r_single,r_kind,i_kind,r_quad,i_long - implicit none - -! set default as private - private -! set subroutines as public - public :: init_constants_derived - public :: init_constants -! set passed variables to public - public :: one,two,ione,half,zero,izero,deg2rad,pi,three,quarter,one_tenth - public :: rad2deg,zero_quad,r3600,r1000,r60inv,five,four,rd_over_cp,grav - public :: rd,rozcon,rearth_equator,zero_single,tiny_r_kind,tiny_single - public :: omega,rcp,rearth,fv,h300,cp,cg_term,tpwcon,xb,ttp,psatk,xa,tmix - public :: xai,xbi,psat,eps,omeps,wgtlim,one_quad,epsq,climit,epsm1,hvap - public :: hsub,cclimit,el2orc,elocp,h1000,cpr,pcpeff0,pcpeff2,delta,pcpeff1 - public :: factor1,c0,pcpeff3,factor2,dx_inv,dx_min,rhcbot,rhctop,hfus,ke2 - public :: rrow,cmr,cws,r60,huge_i_kind,huge_r_kind,t0c,rd_over_cp_mass - public :: somigliana,grav_equator,grav_ratio,flattening,semi_major_axis - public :: n_b,n_a,eccentricity,huge_single,constoz,g_over_rd,amsua_clw_d2 - public :: amsua_clw_d1,n_c,rd_over_g,zero_ilong - -! Declare derived constants - integer(i_kind):: huge_i_kind - real(r_single):: tiny_single, huge_single - real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g - real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 - real(r_kind):: factor1, huge_r_kind, tiny_r_kind, deg2rad, pi, rad2deg, cg_term - real(r_kind):: eccentricity_linear, cv, rv, rd_over_cp_mass, cliq, rd, cp_mass - real(r_kind):: eccentricity, grav, rearth, r60inv - - -! Define constants common to global and regional applications - real(r_kind),parameter:: rearth_equator= 6.37813662e6_r_kind ! equatorial earth radius (m) - real(r_kind),parameter:: omega = 7.2921e-5_r_kind ! angular velocity of earth (1/s) - real(r_kind),parameter:: cp = 1.0046e+3_r_kind ! specific heat of air @pressure (J/kg/K) - real(r_kind),parameter:: cvap = 1.8460e+3_r_kind ! specific heat of h2o vapor (J/kg/K) - real(r_kind),parameter:: csol = 2.1060e+3_r_kind ! specific heat of solid h2o (ice)(J/kg/K) - real(r_kind),parameter:: hvap = 2.5000e+6_r_kind ! latent heat of h2o condensation (J/kg) - real(r_kind),parameter:: hfus = 3.3358e+5_r_kind ! latent heat of h2o fusion (J/kg) - real(r_kind),parameter:: psat = 6.1078e+2_r_kind ! pressure at h2o triple point (Pa) - real(r_kind),parameter:: t0c = 2.7315e+2_r_kind ! temperature at zero celsius (K) - real(r_kind),parameter:: ttp = 2.7316e+2_r_kind ! temperature at h2o triple point (K) - real(r_kind),parameter:: jcal = 4.1855e+0_r_kind ! joules per calorie () - real(r_kind),parameter:: stndrd_atmos_ps = 1013.25e2_r_kind ! 1976 US standard atmosphere ps (Pa) - -! Numeric constants - integer(i_kind),parameter:: izero = 0_i_kind - integer(i_kind),parameter:: ione = 1_i_kind - - integer(i_long),parameter:: zero_ilong = 0_i_long - - real(r_single),parameter:: zero_single= 0.0_r_single - - real(r_kind),parameter:: zero = 0.0_r_kind - real(r_kind),parameter:: one_tenth = 0.10_r_kind - real(r_kind),parameter:: quarter = 0.25_r_kind - real(r_kind),parameter:: one = 1.0_r_kind - real(r_kind),parameter:: two = 2.0_r_kind - real(r_kind),parameter:: three = 3.0_r_kind - real(r_kind),parameter:: four = 4.0_r_kind - real(r_kind),parameter:: five = 5.0_r_kind - real(r_kind),parameter:: r60 = 60._r_kind - real(r_kind),parameter:: r1000 = 1000.0_r_kind - real(r_kind),parameter:: r3600 = 3600.0_r_kind - - real(r_quad),parameter:: zero_quad = 0.0_r_quad - real(r_quad),parameter:: one_quad = 1.0_r_quad - - -! Constants for gps refractivity (Bevis et al 1994) - real(r_kind),parameter:: n_a = 77.60_r_kind ! K/mb - real(r_kind),parameter:: n_b = 3.739e+5_r_kind ! K^2/mb - real(r_kind),parameter:: n_c = 70.4_r_kind ! K/mb - -! Parameters below from WGS-84 model software inside GPS receivers. - real(r_kind),parameter:: semi_major_axis = 6378.1370e3_r_kind ! (m) - real(r_kind),parameter:: semi_minor_axis = 6356.7523142e3_r_kind ! (m) - real(r_kind),parameter:: grav_polar = 9.8321849378_r_kind ! (m/s2) - real(r_kind),parameter:: grav_equator = 9.7803253359_r_kind ! (m/s2) - real(r_kind),parameter:: earth_omega = 7.292115e-5_r_kind ! (rad/s) - real(r_kind),parameter:: grav_constant = 3.986004418e14_r_kind ! (m3/s2) - -! Derived geophysical constants - real(r_kind),parameter:: flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis - real(r_kind),parameter:: somigliana = & - (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one - real(r_kind),parameter:: grav_ratio = (earth_omega*earth_omega * & - semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant - -! Derived thermodynamic constants - real(r_kind),parameter:: dldti = cvap-csol - real(r_kind),parameter:: hsub = hvap+hfus - real(r_kind),parameter:: psatk = psat*0.001_r_kind - real(r_kind),parameter:: tmix = ttp-20._r_kind - real(r_kind),parameter:: elocp = hvap/cp - real(r_kind),parameter:: rcp = one/cp - -! Constants used in GFS moist physics - real(r_kind),parameter:: h300 = 300._r_kind - real(r_kind),parameter:: half = 0.5_r_kind - real(r_kind),parameter:: cclimit = 0.001_r_kind - real(r_kind),parameter:: climit = 1.e-20_r_kind - real(r_kind),parameter:: epsq = 2.e-12_r_kind - real(r_kind),parameter:: h1000 = r1000 - real(r_kind),parameter:: rhcbot=0.85_r_kind - real(r_kind),parameter:: rhctop=0.85_r_kind - real(r_kind),parameter:: dx_max=-8.8818363_r_kind - real(r_kind),parameter:: dx_min=-5.2574954_r_kind - real(r_kind),parameter:: dx_inv=one/(dx_max-dx_min) - real(r_kind),parameter:: c0=0.002_r_kind - real(r_kind),parameter:: delta=0.6077338_r_kind - real(r_kind),parameter:: pcpeff0=1.591_r_kind - real(r_kind),parameter:: pcpeff1=-0.639_r_kind - real(r_kind),parameter:: pcpeff2=0.0953_r_kind - real(r_kind),parameter:: pcpeff3=-0.00496_r_kind - real(r_kind),parameter:: cmr = one/0.0003_r_kind - real(r_kind),parameter:: cws = 0.025_r_kind - real(r_kind),parameter:: ke2 = 0.00002_r_kind - real(r_kind),parameter:: row = r1000 - real(r_kind),parameter:: rrow = one/row - -! Constant used to process ozone - real(r_kind),parameter:: constoz = 604229.0_r_kind - -! Constants used in cloud liquid water correction for AMSU-A -! brightness temperatures - real(r_kind),parameter:: amsua_clw_d1 = 0.754_r_kind - real(r_kind),parameter:: amsua_clw_d2 = -2.265_r_kind - -! Constants used for variational qc - real(r_kind),parameter:: wgtlim = quarter ! Cutoff weight for concluding that obs has been - ! rejected by nonlinear qc. This limit is arbitrary - ! and DOES NOT affect nonlinear qc. It only affects - ! the printout which "counts" the number of obs that - ! "fail" nonlinear qc. Observations counted as failing - ! nonlinear qc are still assimilated. Their weight - ! relative to other observations is reduced. Changing - ! wgtlim does not alter the analysis, only - ! the nonlinear qc data "count" - -contains - - subroutine init_constants_derived -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants_derived set derived constants -! prgmmr: treadon org: np23 date: 2004-12-02 -! -! abstract: This routine sets derived constants -! -! program history log: -! 2004-12-02 treadon -! 2005-03-03 treadon - add implicit none -! 2008-06-04 safford - rm unused vars -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - -! Trigonometric constants - pi = acos(-one) - deg2rad = pi/180.0_r_kind - rad2deg = one/deg2rad - cg_term = (sqrt(two*pi))/two ! constant for variational qc - tiny_r_kind = tiny(zero) - huge_r_kind = huge(zero) - tiny_single = tiny(zero_single) - huge_single = huge(zero_single) - huge_i_kind = huge(izero) - r60inv=one/r60 - -! Geophysical parameters used in conversion of geopotential to -! geometric height - eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) - eccentricity = eccentricity_linear / semi_major_axis - - return - end subroutine init_constants_derived - - subroutine init_constants(regional) -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants set regional or global constants -! prgmmr: treadon org: np23 date: 2004-03-02 -! -! abstract: This routine sets constants specific to regional or global -! applications of the gsi -! -! program history log: -! 2004-03-02 treadon -! 2004-06-16 treadon, documentation -! 2004-10-28 treadon - use intrinsic TINY function to set value -! for smallest machine representable positive -! number -! 2004-12-03 treadon - move derived constants to init_constants_derived -! 2005-03-03 treadon - add implicit none -! -! input argument list: -! regional - if .true., set regional gsi constants; -! otherwise (.false.), use global constants -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - - logical,intent(in ) :: regional - - real(r_kind) reradius,g,r_d,r_v,cliq_wrf - -! Define regional constants here - if (regional) then - -! Name given to WRF constants - reradius = one/6370.e03_r_kind - g = 9.81_r_kind - r_d = 287.04_r_kind - r_v = 461.6_r_kind - cliq_wrf = 4190.0_r_kind - cp_mass = 1004.67_r_kind - -! Transfer WRF constants into unified GSI constants - rearth = one/reradius - grav = g - rd = r_d - rv = r_v - cv = cp-r_d - cliq = cliq_wrf - rd_over_cp_mass = rd / cp_mass - -! Define global constants here - else - rearth = 6.3712e+6_r_kind - grav = 9.80665e+0_r_kind - rd = 2.8705e+2_r_kind - rv = 4.6150e+2_r_kind - cv = 7.1760e+2_r_kind - cliq = 4.1855e+3_r_kind - cp_mass= zero - rd_over_cp_mass = zero - endif - - -! Now define derived constants which depend on constants -! which differ between global and regional applications. - -! Constants related to ozone assimilation - ozcon = grav*21.4e-9_r_kind - rozcon= one/ozcon - -! Constant used in vertical integral for precipitable water - tpwcon = 100.0_r_kind/grav - -! Derived atmospheric constants - fv = rv/rd-one ! used in virtual temperature equation - dldt = cvap-cliq - xa = -(dldt/rv) - xai = -(dldti/rv) - xb = xa+hvap/(rv*ttp) - xbi = xai+hsub/(rv*ttp) - eps = rd/rv - epsm1 = rd/rv-one - omeps = one-eps - factor1 = (cvap-cliq)/rv - factor2 = hvap/rv-factor1*t0c - cpr = cp*rd - el2orc = hvap*hvap/(rv*cp) - rd_over_g = rd/grav - rd_over_cp = rd/cp - g_over_rd = grav/rd - - return - end subroutine init_constants - -end module constants diff --git a/lib/GSD/gsdcloud/convert_lghtn2ref.f90 b/lib/GSD/gsdcloud/convert_lghtn2ref.f90 deleted file mode 100644 index b4acdb89d..000000000 --- a/lib/GSD/gsdcloud/convert_lghtn2ref.f90 +++ /dev/null @@ -1,197 +0,0 @@ -SUBROUTINE convert_lghtn2ref(mype,nlon,nlat,nsig,ref_mos_3d,lightning,h_bk) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: convert_lghtn2ref convert lightning stroke rate to radar reflectivity -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-17 -! -! ABSTRACT: -! This subroutine converts lightning stroke rate to radar reflectivity -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! ref_mos_3d - 3D reflectivity in analysis grid -! lightning - 2D lightning flash rate in analysis grid -! h_bk - 3D height -! -! output argument list: -! ref_mos_3d - 3D reflectivity in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use kinds, only: r_kind,i_kind,r_single - implicit none - - INTEGER(i_kind),intent(in) :: mype - INTEGER(i_kind),intent(in) :: nlon,nlat,nsig - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height - real(r_single), intent(in) :: lightning(nlon,nlat) - real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid -! -! local -! - real(r_kind) :: dbz_lightning(nlon,nlat) - real(r_kind) :: table_lghtn2ref_winter(30) ! table content the map from lightning strakes - ! to maximum reflectivity - DATA table_lghtn2ref_winter/ & - 32.81,33.98,34.93,36.26,36.72,37.07,37.93,38.79,39.65,40.10, & - 40.42,41.42,41.90,42.04,42.19,42.45,42.90,43.20,43.50,43.80, & - 44.10,44.66,44.84,45.56,45.64,45.80,45.95,46.11,46.32,46.50/ - - real(r_kind) :: table_lghtn2ref_summer(30) ! table content the map from lightning strakes - ! to maximum reflectivity - DATA table_lghtn2ref_summer/ & - 30.13,31.61,32.78,33.86,34.68,35.34,36.13,36.15,37.02,37.04, & - 37.74,38.00,38.56,38.85,39.10,39.37,39.78,39.98,40.64,41.33, & - 41.50,41.65,41.85,42.08,42.77,43.03,43.26,43.53,43.74,43.73/ - - integer(i_kind) :: maxlvl - parameter (maxlvl=31) - real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile - DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & - 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & - 9, 10, 11, 12, 13, 14, 15, 16/ - - real(r_kind) :: refprofile_winter(maxlvl,4) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 30-35 dbz - DATA refprofile_winter(:,1) / & - 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & - 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & - 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & - 0.793/ -! max reflectivity 35-40 dbz - DATA refprofile_winter(:,2) / & - 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & - 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & - 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & - 0.723/ -! max reflectivity 40-45 dbz - DATA refprofile_winter(:,3) / & - 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & - 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & - 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & - 0.656/ -! max reflectivity 45-50 dbz - DATA refprofile_winter(:,4) / & - 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & - 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & - 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & - 0.548/ - - real(r_kind) :: refprofile_summer(maxlvl,4) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 30-35 dbz - DATA refprofile_summer(:,1) / & - 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & - 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & - 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & - 0.570/ -! max reflectivity 35-40 dbz - DATA refprofile_summer(:,2) / & - 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & - 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & - 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & - 0.491/ -! max reflectivity 40-45 dbz - DATA refprofile_summer(:,3) / & - 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & - 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & - 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & - 0.440/ -! max reflectivity 45-50 dbz - DATA refprofile_summer(:,4) / & - 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & - 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & - 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & - 0.410/ - - INTEGER(i_kind) :: season ! 1= summer, 2=winter - INTEGER(i_kind) :: num_lightning - INTEGER(i_kind) :: i,j, k2, k, mref - REAL(r_kind) :: heightGSI,upref,downref,wght - INTEGER(i_kind) :: ilvl - REAL(r_kind) :: lowest,highest,tempref, tempprofile(maxlvl) - - -! -! map lightning strokes to maximum reflectiivty -! - season=1 - dbz_lightning = -9999.0_r_kind - DO j=2,nlat-1 - DO i=2,nlon-1 - if(lightning(i,j) > 0.1_r_kind ) then - num_lightning = max(1,min(30,int(lightning(i,j)))) - if(season== 2 ) then - dbz_lightning(i,j) = table_lghtn2ref_winter(num_lightning) - else if(season== 1 ) then - dbz_lightning(i,j) = table_lghtn2ref_summer(num_lightning) - endif - endif - ENDDO - ENDDO -! -! vertical reflectivity distribution -! - DO k=1,maxlvl - newlvlAll(k)=newlvlAll(k)*1000.0_r_kind - ENDDO - -! ref_mos_3d=-9999.0 - DO j=2,nlat-1 - DO i=2,nlon-1 - if( dbz_lightning(i,j) > 30 ) then - mref = min(4,(int((dbz_lightning(i,j) - 30.0_r_kind)/5.0_r_kind) + 1 )) - if(season== 2 ) then - DO k=1,maxlvl - tempprofile(k)=refprofile_winter(k,mref)*dbz_lightning(i,j) - enddo - lowest=newlvlAll(2) - highest=7000.0_r_kind - else if(season== 1 ) then - DO k=1,maxlvl - tempprofile(k)=refprofile_summer(k,mref)*dbz_lightning(i,j) - enddo - lowest=newlvlAll(3) - highest=12000.0_r_kind - endif - DO k2=1,nsig - heightGSI=h_bk(i,j,k2) - if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? - do k=1,maxlvl-1 - if( heightGSI >=newlvlAll(k) .and. heightGSI < newlvlAll(k+1) ) ilvl=k - enddo - upref=tempprofile(ilvl+1) - downref=tempprofile(ilvl) - wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) - tempref=(1-wght)*downref + wght*upref - ref_mos_3d(i,j,k2) = max(ref_mos_3d(i,j,k2),tempref) - endif - ENDDO - endif - ENDDO - ENDDO - -END SUBROUTINE convert_lghtn2ref diff --git a/lib/GSD/gsdcloud/get_sfm_1d_gnl.f90 b/lib/GSD/gsdcloud/get_sfm_1d_gnl.f90 deleted file mode 100644 index 5b543b982..000000000 --- a/lib/GSD/gsdcloud/get_sfm_1d_gnl.f90 +++ /dev/null @@ -1,384 +0,0 @@ -! -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: get_sfm_1d_gnl -! -! PRGMMR: ORG: DATE: -! -! ABSTRACT: -! This subroutine calculate liquid water content for convection cloud -! This subroutine is from ARPS cloud analysis package -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_SFM_1D ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_sfm_1d_gnl (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & - l_prt) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -!c----------------------------------------------------------------- -!c -!c This is the streamlined version of the Smith-Feddes -!c and Temperature Adjusted LWC calculation methodologies -!c produced at Purdue University under sponsorship -!c by the FAA Technical Center. -!c -!c Currently, this subroutine will only use the Smith- -!c Feddes and will only do so as if there are solely -!c stratiform clouds present, however, it is very easy -!c to switch so that only the Temperature Adjusted -!c method is used. -!c -!c Dilution by glaciation is also included, it is a -!c linear function of in cloud temperature going from -!c all liquid water at -10 C to all ice at -30 C -!c as such the amount of ice is also calculated -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on the LAPS cloud analysis code of 07/1995 -! -! MODIFICATION HISTORY: -! -! 05/16/96 (Jian Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER :: nz ! number of model vertical levels - REAL :: zs_1d(nz) ! physical height (m) at each scalar level - REAL :: p_mb_1d(nz) ! pressure (mb) at each level - REAL :: t_1d(nz) ! temperature (K) at each level - - REAL :: zcb ! cloud base height (m) - REAL :: zctop ! cloud top height (m) -! -! OUTPUT: - REAL :: ql(nz) ! liquid water content (g/kg) - REAL :: qi(nz) ! ice water content (g/kg) - REAL :: cldt(nz) -! -! LOCAL: - REAL :: calw(200) - REAL :: cali(200) - REAL :: catk(200) - REAL :: entr(200) -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - REAL :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso - REAL :: c,a1,b1,c1,a2,b2,c2 - REAL :: delz,delt,cldbtm,cldbp,cldtpt,tbar - REAL :: arg,fraclw,tlwc - REAL :: temp,press,zbase,alw,zht,ht,y - REAL :: rl,es,qvs1,p,des,dtz,es2,qvs2 - INTEGER :: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 - REAL :: zcloud,entc,tmpk - LOGICAL :: l_prt -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Initialize 1d liquid water and ice arrays (for 100m layers) -! -!----------------------------------------------------------------------- -! - DO i=1,200 - calw(i)=0.0 - cali(i)=0.0 - END DO -! -!----------------------------------------------------------------------- -! -! Preset some constants and coefficients. -! -!----------------------------------------------------------------------- -! - dz=100.0 ! m - rv=461.5 ! J/deg/kg - rair=287.04 ! J/deg/kg - grav=9.81 ! m/s2 - cp=1004. ! J/deg/kg - rlvo=2.5003E+6 ! J/kg - rlso=2.8339E+6 ! J/kg - dlvdt=-2.3693E+3 ! J/kg/K - eso=610.78 ! pa - c=0.01 - a1=8.4897 - b1=-13.2191 - c1=4.7295 - a2=10.357 - b2=-28.2416 - c2=8.8846 -! -!----------------------------------------------------------------------- -! -! Calculate indices of cloud top and base -! -!----------------------------------------------------------------------- -! - DO k=1,nz-1 - IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN - kcb=k - kcb1=kcb+1 - END IF - IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN - kctop=k - kctop1=kctop+1 - END IF - END DO -! -!----------------------------------------------------------------------- -! -! Obtain cloud base and top conditions -! -!----------------------------------------------------------------------- -! - delz = zs_1d(kcb+1)-zs_1d(kcb) - delt = t_1d(kcb+1)-t_1d(kcb) - cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) - tbar = (cldbtm+t_1d(kcb))/2. - arg = -grav*(zcb-zs_1d(kcb))/rair/tbar - cldbp = p_mb_1d(kcb)*EXP(arg) - delz = zs_1d(kctop+1)-zs_1d(kctop) - delt = t_1d(kctop+1)-t_1d(kctop) - cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) -! -!----------------------------------------------------------------------- -! -! Calculate cloud lwc profile for cloud base/top pair -! -!----------------------------------------------------------------------- -! - temp = cldbtm - press = cldbp*100.0 - zbase = zcb - nlevel = ((zctop-zcb)/100.0)+1 - IF(nlevel <= 0) nlevel=1 - alw = 0.0 - calw(1)= 0.0 - cali(1)= 0.0 - catk(1)= temp - entr(1)= 1.0 - nlm1 = nlevel-1 - IF(nlm1 < 1) nlm1=1 - zht = zbase - - DO j=1,nlm1 - rl = rlvo+(273.15-temp)*dlvdt - arg = rl*(temp-273.15)/273.15/temp/rv - es = eso*EXP(arg) - qvs1 = 0.622*es/(press-es) -! rho1 = press/(rair*temp) - arg = -grav*dz/rair/temp - p = press*EXP(arg) - - IF(l_prt) THEN - WRITE(6,605) j,zht,temp,press,1000.0*qvs1,es,rl - 605 FORMAT('get_sfm_1d_gnl:',1X,i2,' ht=',f8.0,' T=',f6.1,' P=',f9.1,' qvs=', & - f7.3,' es=',f6.1,' Lv=',e8.3) - END IF -! -!----------------------------------------------------------------------- -! -! Calculate saturated adiabatic lapse rate -! -!----------------------------------------------------------------------- -! - des = es*rl/temp/temp/rv - dtz = -grav*((1.0+0.621*es*rl/(press*rair*temp))/ & - (cp+0.621*rl*des/press)) - zht = zht+dz - press = p - temp = temp+dtz*dz - rl = rlvo+(273.15-temp)*dlvdt - arg = rl*(temp-273.15)/273.15/temp/rv - es2 = eso*EXP(arg) - qvs2 = 0.622*es2/(press-es2) - - alw = alw+(qvs1-qvs2) ! kg/kg - calw(j+1) = alw - - IF (l_prt) THEN - WRITE(6,9015) j,1000.0*calw(j+1),zht - 9015 FORMAT('get_sfm_1d_gnl',1X,'j=',i3,' adiab.lwc =',f7.3,' alt =',f8.0) - END IF -! -!----------------------------------------------------------------------- -! -! Reduction of lwc by entrainment -! -!----------------------------------------------------------------------- -! - ht = (zht-zbase)*.001 -! -!c ------------------------------------------------------------------ -!c -!c skatskii's curve(convective) -!c -!c ------------------------------------------------------------------ -!c if(ht.lt.0.3) then -!c y = -1.667*(ht-0.6) -!c elseif(ht.lt.1.0) then -!c arg1 = b1*b1-4.0*a1*(c1-ht) -!c y = (-b1-sqrt(arg1))/(2.0*a1) -!c elseif(ht.lt.2.9) then -!c arg2 = b2*b2-4.0*a2*(c2-ht) -!c y = (-b2-sqrt(arg2))/(2.0*a2) -!c else -!c y = 0.26 -!c endif -!c -!c ------------------------------------------------------------------ -!c -!c warner's curve(stratiform) -!c -!c ------------------------------------------------------------------ - IF(ht < 0.032) THEN - y = -11.0*ht+1.0 ! y(ht=0.032) = 0.648 - ELSE IF(ht <= 0.177) THEN - y = -1.4*ht+0.6915 ! y(ht=0.177) = 0.4437 - ELSE IF(ht <= 0.726) THEN - y = -0.356*ht+0.505 ! y(ht=0.726) = 0.2445 - ELSE IF(ht <= 1.5) THEN - y = -0.0608*ht+0.2912 ! y(ht=1.5) = 0.2 - ELSE - y = 0.20 - END IF -! -!----------------------------------------------------------------------- -! -! Calculate reduced lwc by entrainment and dilution -! -! Note at -5 C and warmer, all liquid. ! changed from -10 KB -! at -25 C and colder, all ice ! changed from -30 KB -! Linear ramp between. -! -!----------------------------------------------------------------------- -! - IF(temp < 268.15) THEN - IF(temp > 248.15) THEN - fraclw=0.05*(temp-248.15) - ELSE - fraclw=0.0 - END IF - ELSE - fraclw=1.0 - END IF - - tlwc=1000.*y*calw(j+1) ! g/kg - calw(j+1)=tlwc*fraclw - cali(j+1)=tlwc*(1.-fraclw) - catk(j+1)=temp - entr(j+1)=y - - END DO -! -!----------------------------------------------------------------------- -! -! Alternative calculation procedure using the observed or -! inferred in cloud temperature profile -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Obtain profile of LWCs at the given grid point -! -!----------------------------------------------------------------------- -! - - DO ip=2,nz-1 - IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN - ql(ip)=0.0 - qi(ip)=0.0 - cldt(ip)=t_1d(ip) - ELSE - DO j=2,nlevel - zcloud = zcb+(j-1)*dz - IF(zcloud >= zs_1d(ip)) THEN - ql(ip) = (zs_1d(ip)-zcloud+100.)*(calw(j)-calw(j-1))*0.01 & - +calw(j-1) - qi(ip) = (zs_1d(ip)-zcloud+100.)*(cali(j)-cali(j-1))*0.01 & - +cali(j-1) - tmpk = (zs_1d(ip)-zcloud+100.)*(catk(j)-catk(j-1))*0.01 & - +catk(j-1) - entc = (zs_1d(ip)-zcloud+100.)*(entr(j)-entr(j-1))*0.01 & - +entr(j-1) - cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk - - EXIT - END IF - END DO - END IF - END DO -! -!----------------------------------------------------------------------- -! -! Write out file of lwc comparisons -! -!----------------------------------------------------------------------- -! - RETURN -END SUBROUTINE get_sfm_1d_gnl diff --git a/lib/GSD/gsdcloud/hydro_mxr_thompson.f90 b/lib/GSD/gsdcloud/hydro_mxr_thompson.f90 deleted file mode 100644 index af7a7a44e..000000000 --- a/lib/GSD/gsdcloud/hydro_mxr_thompson.f90 +++ /dev/null @@ -1,196 +0,0 @@ -SUBROUTINE hydro_mxr_thompson (nx, ny, nz, t_3d, p_3d, ref_3d, qr_3d, qnr_3d, qs_3d, istatus, mype ) -! -! PURPOSE: -! Calculate (1) snow mixing ratio, (2) rain mixing ratio, and (3) rain number concentration -! from reflectivity for Thompson microphysics scheme. A Marshall-Palmer drop-size distribution -! is assumed for rain. -! -! HISTORY: -! 2013-01-30: created by David Dowell, Greg Thompson, Ming Hu -! -! ACKNOWLEDGMENTS: -! Donghai Wang and Eric Kemp (code template from pcp_mxr_ferrier) -! -! input argument list: -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nz - no. of levels -! t_3d - 3D background temperature (K) -! p_3d - 3D background pressure (hPa) -! ref_3d - 3D reflectivity in analysis grid (dBZ) -! -! output argument list: -! qr_3d - rain mixing ratio (g/kg) -! qnr_3d - rain number concentration (/kg) -! qs_3d - snow mixing ratio (g/kg) -! istatus - -! - - -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single, i_kind, r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size - REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz) ! radar reflectivity (dBZ) - REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) - REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) - INTEGER(i_kind),intent(in) :: mype -! -! OUTPUT: - INTEGER(i_kind),intent(out):: istatus - REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow mixing ratio (g/kg) - REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio (g/kg) - REAL(r_single),intent(out) :: qnr_3d(nx,ny,nz) ! rain number concentration (/kg) -! -! PARAMETERS: - REAL(r_kind), PARAMETER :: min_ref = 0.0_r_kind ! minimum reflectivity (dBZ) for converting to qs and qr - REAL(r_kind), PARAMETER :: max_ref_snow = 28.0_r_kind ! maximum reflectivity (dBZ) for converting to qs - ! (values above max_ref are treated as max_ref) - REAL(r_kind), PARAMETER :: max_ref_rain = 55.0_r_kind ! maximum reflectivity (dBZ) for converting to qr - ! (values above max_ref are treated as max_ref) - REAL(r_kind), PARAMETER :: n0r_mp = 8.0e6_r_kind ! Marshall-Palmer intercept parameter for rain (m**-4) - REAL(r_kind), PARAMETER :: rd= 287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) - REAL(r_kind), PARAMETER :: am_s = 0.069_r_kind - REAL(r_kind), PARAMETER :: bm_s = 2.0_r_kind - REAL(r_kind), PARAMETER :: PI = 3.1415926536_r_kind - REAL(r_kind), PARAMETER :: rho_i = 890.0_r_kind - REAL(r_kind), PARAMETER :: rho_w = 1000.0_r_kind -! -! LOCAL VARIABLES: - INTEGER(i_kind) :: i,j,k - REAL(r_kind) :: rho ! air density (kg m**-3) - REAL(r_kind) :: zes ! reflectivity (m**6 m**-3) associated with snow - REAL(r_kind) :: zer ! reflectivity (m**6 m**-3) associated with rain - REAL(r_kind) :: tc ! temperature (Celsius) - REAL(r_kind) :: rfract ! rain fraction - REAL(r_kind) :: tc0 - REAL(r_kind) :: f - REAL(r_kind) :: loga_ - REAL(r_kind) :: a_ - REAL(r_kind), PARAMETER :: a_min = 1.0e-5_r_kind ! lower bound for a_, to avoid large mixing ratios retrieved - ! for tiny particles sizes in cold temperatures - REAL(r_kind) :: b_ - REAL(r_kind) :: sa(10) - REAL(r_kind) :: sb(10) - REAL(r_kind) :: cse(3) - REAL(r_kind) :: crg(4) - REAL(r_kind) :: am_r - REAL(r_kind) :: oams - REAL(r_kind) :: qs ! snow mixing ratio in kg / kg - REAL(r_kind) :: qr ! rain mixing ratio in kg / kg -! -! for snow moments conversions (from Field et al. 2005) - DATA sa / 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & - 0.31255, 0.000204, 0.003199, 0.0, -0.015952/ - DATA sb / 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & - 0.060366, 0.000079, 0.000594, 0.0, -0.003577/ - -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - - istatus=0 - - f = (0.176_r_kind/0.93_r_kind) * (6.0_r_kind/PI)*(6.0_r_kind/PI) * (am_s/rho_i)*(am_s/rho_i) - cse(1) = bm_s + 1.0_r_kind - cse(2) = bm_s + 2.0_r_kind - cse(3) = bm_s * 2.0_r_kind - oams = 1.0_r_kind / am_s - - crg(1) = 24.0_r_kind - crg(2) = 1.0_r_kind - crg(3) = 24.0_r_kind - crg(4) = 5040.0_r_kind - am_r = PI * rho_w / 6.0_r_kind - - DO k = 2,nz-1 - DO j = 2,ny-1 - DO i = 2,nx-1 - - IF (ref_3d(i,j,k) >= min_ref) THEN - - rho = p_3d(i,j,k) / (rd*t_3d(i,j,k)) - tc = t_3d(i,j,k) - 273.15_r_kind - - IF (tc <= 0.0_r_kind) THEN - rfract = 0.0_r_kind - ELSE IF (tc >= 5.0_r_kind) THEN - rfract = 1.0_r_kind - ELSE - rfract = 0.20_r_kind*tc - ENDIF - - zes = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_snow) ) ) & - * (1.0_r_kind-rfract) & - * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) - - zer = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_rain) ) ) & - * rfract & - * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) - - tc0 = MIN(-0.1, tc) - IF (bm_s.lt.(1.999_r_kind) .or. bm_s.gt.(2.001_r_kind)) THEN - PRINT*, 'ABORT (hydro_mxr_thompson): bm_s = ', bm_s - STOP - ENDIF - - ! Calculate bm_s*2 (th) moment. Useful for reflectivity. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & - + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & - + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & - + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(3)*cse(3)*cse(3) - a_ = max( 10.0_r_kind ** loga_, a_min ) - b_ = sb(1) + sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & - + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & - + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) - - qs = ( (zes / (f*a_)) ** (1.0_r_kind / b_) ) / (rho*oams) - qs_3d(i,j,k) = 1000.0_r_kind * qs ! convert from kg / kg to g / kg - - qr = n0r_mp * am_r * crg(3) / rho * (zer / (n0r_mp*crg(4)))**(4.0_r_kind/7.0_r_kind) - qnr_3d(i,j,k) = (n0r_mp/rho)**(3.0_r_kind/4.0_r_kind) & - * (qr / (am_r * crg(3)))**(1.0_r_kind/4.0_r_kind) - - qnr_3d(i,j,k) = max(1.0_r_kind, qnr_3d(i,j,k)) - qr_3d(i,j,k) = 1000.0_r_kind * qr ! convert from kg / kg to g / kg - - -! if(mype==51 ) then -! write(*,'(a10,3i5,2f10.5,3f8.2)') 'b=',i,j,k,qs_3d(i,j,k),qr_3d(i,j,k),ref_3d(i,j,k),& -! p_3d(i,j,k)/100.0,tc -! endif - - - ELSE - - qs_3d(i,j,k) = -999._r_kind - qr_3d(i,j,k) = -999._r_kind - qnr_3d(i,j,k) = -999._r_kind - - END IF - - END DO ! k - END DO ! i - END DO ! j -! -! PRINT*,'finish hydro_mxr_thompson...' -! -!----------------------------------------------------------------------- -! - istatus = 1 -! - RETURN -END SUBROUTINE hydro_mxr_thompson diff --git a/lib/GSD/gsdcloud/kinds.f90 b/lib/GSD/gsdcloud/kinds.f90 deleted file mode 100755 index 73fbe3b56..000000000 --- a/lib/GSD/gsdcloud/kinds.f90 +++ /dev/null @@ -1,105 +0,0 @@ -module kinds -!$$$ module documentation block -! . . . . -! module: kinds -! prgmmr: treadon org: np23 date: 2004-08-15 -! -! abstract: Module to hold specification kinds for variable declaration. -! This module is based on (copied from) Paul vanDelst's -! type_kinds module found in the community radiative transfer -! model -! -! module history log: -! 2004-08-15 treadon -! -! Subroutines Included: -! -! Functions Included: -! -! remarks: -! The numerical data types defined in this module are: -! i_byte - specification kind for byte (1-byte) integer variable -! i_short - specification kind for short (2-byte) integer variable -! i_long - specification kind for long (4-byte) integer variable -! i_llong - specification kind for double long (8-byte) integer variable -! r_single - specification kind for single precision (4-byte) real variable -! r_double - specification kind for double precision (8-byte) real variable -! r_quad - specification kind for quad precision (16-byte) real variable -! -! i_kind - generic specification kind for default integer -! r_kind - generic specification kind for default floating point -! -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - implicit none - private - -! Integer type definitions below - -! Integer types - integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer - integer, parameter, public :: i_short = selected_int_kind(4) ! short integer - integer, parameter, public :: i_long = selected_int_kind(8) ! long integer - integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer - integer, parameter, public :: i_llong = max( llong_t, i_long ) - -! Expected 8-bit byte sizes of the integer kinds - integer, parameter, public :: num_bytes_for_i_byte = 1 - integer, parameter, public :: num_bytes_for_i_short = 2 - integer, parameter, public :: num_bytes_for_i_long = 4 - integer, parameter, public :: num_bytes_for_i_llong = 8 - -! Define arrays for default definition - integer, parameter, private :: num_i_kinds = 4 - integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & - i_byte, i_short, i_long, i_llong /) - integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & - num_bytes_for_i_byte, num_bytes_for_i_short, & - num_bytes_for_i_long, num_bytes_for_i_llong /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** - integer, parameter, private :: default_integer = 3 ! 1=byte, - ! 2=short, - ! 3=long, - ! 4=llong - integer, parameter, public :: i_kind = integer_types( default_integer ) - integer, parameter, public :: num_bytes_for_i_kind = & - integer_byte_sizes( default_integer ) - - -! Real definitions below - -! Real types - integer, parameter, public :: r_single = selected_real_kind(6) ! single precision - integer, parameter, public :: r_double = selected_real_kind(15) ! double precision - integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision - integer, parameter, public :: r_quad = max( quad_t, r_double ) - -! Expected 8-bit byte sizes of the real kinds - integer, parameter, public :: num_bytes_for_r_single = 4 - integer, parameter, public :: num_bytes_for_r_double = 8 - integer, parameter, public :: num_bytes_for_r_quad = 16 - -! Define arrays for default definition - integer, parameter, private :: num_r_kinds = 3 - integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & - r_single, r_double, r_quad /) - integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & - num_bytes_for_r_single, num_bytes_for_r_double, & - num_bytes_for_r_quad /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** - integer, parameter, private :: default_real = 2 ! 1=single, - ! 2=double, - ! 3=quad - integer, parameter, public :: r_kind = real_kinds( default_real ) - integer, parameter, public :: num_bytes_for_r_kind = & - real_byte_sizes( default_real ) - -end module kinds diff --git a/lib/GSD/gsdcloud/make.dependencies b/lib/GSD/gsdcloud/make.dependencies deleted file mode 100644 index 11a2075f6..000000000 --- a/lib/GSD/gsdcloud/make.dependencies +++ /dev/null @@ -1,33 +0,0 @@ -kinds.o : kinds.f90 -constants.o : constants.f90 kinds.o - -ARPS_cldLib.o : ARPS_cldLib.f90 kinds.o constants.o -BackgroundCld.o : BackgroundCld.f90 kinds.o constants.o -BckgrndCC.o : BckgrndCC.f90 kinds.o constants.o -CheckCld.o : CheckCld.f90 kinds.o constants.o -radar_ref2tten.o : radar_ref2tten.f90 kinds.o constants.o -PrecipMxr_radar.o : PrecipMxr_radar.f90 kinds.o constants.o -PrecipType.o : PrecipType.f90 kinds.o constants.o -TempAdjust.o : TempAdjust.f90 kinds.o constants.o -adaslib.o : adaslib.f90 kinds.o constants.o -build_missing_REFcone.o : build_missing_REFcone.f90 kinds.o constants.o -cloudCover_NESDIS.o : cloudCover_NESDIS.f90 kinds.o constants.o -cloudCover_Surface.o : cloudCover_Surface.f90 kinds.o constants.o -cloudCover_radar.o : cloudCover_radar.f90 kinds.o constants.o -cloudLWC.o : cloudLWC.f90 kinds.o constants.o -cloudLayers.o : cloudLayers.f90 kinds.o constants.o -cloudType.o : cloudType.f90 kinds.o constants.o -convert_lghtn2ref.o : convert_lghtn2ref.f90 kinds.o constants.o -cloud_saturation.o : cloud_saturation.f90 kinds.o -get_sfm_1d_gnl.o : get_sfm_1d_gnl.f90 kinds.o constants.o -vinterp_radar_ref.o : vinterp_radar_ref.f90 kinds.o constants.o -map_ctp.o : map_ctp.f90 kinds.o constants.o -mthermo.o : mthermo.f90 kinds.o constants.o -pcp_mxr_ARPSlib.o : pcp_mxr_ARPSlib.f90 kinds.o constants.o -## q_adjust.o : q_adjust.f90 kinds.o constants.o -read_Lightning_cld.o : read_Lightning_cld.f90 kinds.o constants.o -read_NESDIS.o : read_NESDIS.f90 kinds.o constants.o -read_radar_ref.o : read_radar_ref.f90 kinds.o constants.o -read_Surface.o :read_Surface.f90 kinds.o constants.o -read_nasalarc_cld.o : read_nasalarc_cld.f90 kinds.o constants.o -smooth.o : smooth.f90 kinds.o constants.o diff --git a/lib/GSD/gsdcloud/make.filelist b/lib/GSD/gsdcloud/make.filelist deleted file mode 100644 index 9b943ba0b..000000000 --- a/lib/GSD/gsdcloud/make.filelist +++ /dev/null @@ -1,35 +0,0 @@ -SRC_FILES = ARPS_cldLib.f90 \ - BackgroundCld.f90 \ - BckgrndCC.f90 \ - radar_ref2tten.f90 \ - PrecipMxr_radar.f90 \ - PrecipType.f90 \ - TempAdjust.f90 \ - adaslib.f90 \ - build_missing_REFcone.f90 \ - cloudCover_NESDIS.f90 \ - cloudCover_Surface.f90 \ - cloudCover_radar.f90 \ - cloudLWC.f90 \ - cloudLayers.f90 \ - cloudType.f90 \ - cloud_saturation.f90 \ - convert_lghtn2ref.f90 \ - get_sfm_1d_gnl.f90 \ - vinterp_radar_ref.f90 \ - map_ctp.f90 \ - mthermo.f90 \ - pcp_mxr_ARPSlib.f90 \ - read_Lightning_cld.f90 \ - read_NESDIS.f90 \ - read_radar_ref.f90 \ - read_Surface.f90 \ - read_nasalarc_cld.f90 \ - smooth.f90 \ - constants.f90 \ - kinds.f90 \ - pbl_height.f90 \ - hydro_mxr_thompson.f90 \ - map_ctp_lar.f90 - -OBJ_FILES =${SRC_FILES:.f90=.o} diff --git a/lib/GSD/gsdcloud/map_ctp.f90 b/lib/GSD/gsdcloud/map_ctp.f90 deleted file mode 100644 index 4655bb6a7..000000000 --- a/lib/GSD/gsdcloud/map_ctp.f90 +++ /dev/null @@ -1,291 +0,0 @@ -subroutine map_ctp (ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,npts_rad) - -! -!$$$ subprogram documentation block -! . . . . -! subprogram: map_ctp map GOES cloud product to analysis grid -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-03_10 -! -! ABSTRACT: -! This subroutine map GOES cloud product to analysis grid -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! ib - begin i point of this domain -! jb - begin j point of this domain -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nn_obs - 1st dimension of observation arry data_s -! numsao - number of observation -! data_s - observation array for GOES cloud products -! npts_rad - impact radius -! -! output argument list: -! sat_ctp - GOES cloud top pressure in analysis grid -! sat_tem - GOES cloud top temperature in analysis grid -! w_frac - GOES cloud coverage in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! adapted according to RUC subroutine rd_cld -! * -! * This routine reads NESDIS (Madison, WI) cloud product produced -! * from GOES sounder data. The original product is reprocessed onto -! * MAPS40 grid boxes. There could be more than one cloud product -! * in a grid-box, so we use the nearest one that falls in the -! * grid. The routine combines GOES-8 and 10 products. -! -! ===== History ===== -! -! * Internal variables: -! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds -! -! * Working variables: -! -! * Working variables used for sorting max size of 10: -! Pxx, Txx, xdist,xxxdist (R4) -! Fxx, Nxx, index, jndex (I4) -! ioption (I4) = 1 if selection is nearest neighbor -! = 2 if selection is median of samples -! -! -! * Output variables on gridpoint (Nx,Ny): -! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature -! w_frac (R4) Effective fractional cloud coverage, option=1 -! fractional coverage within RUC grid, option=2 -! w_eca (R4) Effective fractional cloud regardless option -! (effective cloud amount - eca) -! nlev_cld (I4) Number of cloud levels. TO BE USED LATER -! to incorporate multi-level cloud -! -! * Calling routines -! sorting -! sortmed -! -! * -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,r_single,i_kind - use constants, only: zero,one_tenth,one,deg2rad - - implicit none - -! input-file variables: - INTEGER(i_kind),intent(in) :: Nx, Ny - INTEGER(i_kind),intent(in) :: ib, jb - INTEGER(i_kind),intent(in) :: numsao, nn_obs - INTEGER(i_kind),intent(in) :: npts_rad - real(r_kind),dimension(nn_obs,numsao):: data_s -! Output - real(r_single), intent(out) :: sat_ctp(Nx,Ny) - real(r_single), intent(out) :: sat_tem(Nx,Ny) - real(r_single), intent(out) :: w_frac(Nx,Ny) -! -! misc - integer(i_kind) :: nfov - parameter (nfov=60) - -! Working - real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) - real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) - real(r_kind) :: fr,sqrt - integer(i_kind) :: Nxx(Nx,Ny,nfov),index(Nx,Ny), jndex(nfov) - integer(i_kind) :: ioption - integer(i_kind) :: ipt,ii,jj,i,med_pt,ii1,jj1 - - real(r_kind) :: xc - real(r_kind) :: yc - - real(r_single) :: w_eca(Nx,Ny) - integer(i_kind) :: nlev_cld(Nx,Ny) - integer(i_kind) :: ios - -! -! * Initialize outputs since GOES sounder do not scan all MAPS domain -! - do jj=1,Ny - do ii=1,Nx - w_eca (ii,jj) =-99999._r_kind - index(ii,jj) = 0 - enddo - enddo - -! -- set ios as failed unless valid data points are found below - ios = 0 - -! ----------------------------------------------------------- -! ----------------------------------------------------------- -! Map each FOV onto RR grid points -! ----------------------------------------------------------- -! ----------------------------------------------------------- - do ipt=1,numsao - - xc=data_s(2,ipt) - ib + 1.0_r_kind - yc=data_s(3,ipt) - jb + 1.0_r_kind - if(data_s(8,ipt) > 50 ) cycle - -! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 - - if(XC >= 1._r_kind .and. XC < Nx .and. & - YC >= 1._r_kind .and. YC < Ny) then - ii1 = int(xc+0.5_r_kind) - jj1 = int(yc+0.5_r_kind) - - do jj = max(1,jj1-npts_rad), min(ny,jj1+npts_rad) - if (jj1-1 >= 1 .and. jj1+1 <= ny) then - do ii = max(1,ii1-npts_rad), min(nx,ii1+npts_rad) - if (ii1-1 >= 1 .and. ii1+1 <= nx) then - -! * We check multiple data within gridbox - - if (index(ii,jj) < nfov) then - index(ii,jj) = index(ii,jj) + 1 - - Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) - Txx(ii,jj,index(ii,jj)) = data_s(6,ipt) -!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) -!mhu no cloud amount available, assign to 100 - Nxx(ii,jj,index(ii,jj)) = 100 - nlev_cld(ii,jj) = 1 - xdist(ii,jj,index(ii,jj)) = sqrt( & - (XC+1-ii)**2 + (YC+1-jj)**2) - end if - endif - enddo ! ii - endif - enddo ! jj - endif ! observation is in the domain - enddo ! ipt -! -! * ioption = 1 is nearest neighrhood -! * ioption = 2 is median of cloudy fov - ioption = 2 -! - do jj = 1,Ny - do ii = 1,Nx - if ((index(ii,jj) >= 1 .and. index(ii,jj) < 3) .and. npts_rad > 1) then - sat_ctp(ii,jj) = Pxx(ii,jj,1) - sat_tem(ii,jj) = Txx(ii,jj,1) - w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. - w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. - - elseif(index(ii,jj) >= 3) then - -! * We decided to use nearest neighborhood for ECA values, -! * a kind of convective signal from GOES platform... - - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = xdist(ii,jj,i) - enddo - call sorting(xxxdist,index(ii,jj),jndex) - w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind -! * Sort to find closest distance if more than one sample - if(ioption == 1) then !nearest neighborhood - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = xdist(ii,jj,i) - enddo - call sorting(xxxdist,index(ii,jj),jndex) - sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) - sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) - w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind - endif -! * Sort to find median value - if(ioption == 2) then !pick median - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = Pxx(ii,jj,i) - enddo - call sortmed(xxxdist,index(ii,jj),jndex,fr) - med_pt = index(ii,jj)/2 + 1 - sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) - sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) - w_frac(ii,jj) = fr - endif - endif - enddo !ii - enddo !jj - - return -end subroutine map_ctp - -subroutine sorting(d,n,is) - use kinds, only: r_kind,i_kind - implicit none - - integer(i_kind), intent(in) :: n - real(r_kind) , intent(inout) :: d(n) - integer(i_kind), intent(inout) :: is(n) -! - integer(i_kind) :: nm1,ip1,iold,i,j - real(r_kind) :: temp -! -! - nm1 = n-1 - do 10 i=1,nm1 - ip1 = i+1 - do 10 j=ip1,n - if(d(i) <= d(j)) goto 10 - temp = d(i) - d(i) = d(j) - d(j) = temp - iold = is(i) - is(i) = is(j) - is(j) = iold - 10 continue - return -end subroutine sorting - -subroutine sortmed(p,n,is,f) - use kinds, only: r_kind,i_kind - implicit none - real(r_kind), intent(inout) :: p(n) - integer(i_kind), intent(in) :: n - integer(i_kind), intent(inout) :: is(n) -! * count cloudy fov - real(r_kind), intent(out) :: f - integer(i_kind) :: cfov -! - integer(i_kind) :: i,j,nm1,ip1,iold - real(r_kind) :: temp -! -! -! - cfov = 0 - do i=1,n - if(p(i) < 999._r_kind) cfov = cfov + 1 - enddo - f = float(cfov)/(max(1,n)) -! cloud-top pressure is sorted high cld to clear - nm1 = n-1 - do 10 i=1,nm1 - ip1 = i+1 - do 10 j=ip1,n - if(p(i)<=p(j)) goto 10 - temp = p(i) - p(i) = p(j) - p(j) = temp - iold = is(i) - is(i) = is(j) - is(j) = iold - 10 continue - return -end subroutine sortmed diff --git a/lib/GSD/gsdcloud/map_ctp_lar.f90 b/lib/GSD/gsdcloud/map_ctp_lar.f90 deleted file mode 100644 index e15fecbfd..000000000 --- a/lib/GSD/gsdcloud/map_ctp_lar.f90 +++ /dev/null @@ -1,258 +0,0 @@ -subroutine map_ctp_lar(mype,ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld) - -! -!$$$ subprogram documentation block -! . . . . -! subprogram: map_ctp map GOES cloud product to analysis grid -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-03_10 -! -! ABSTRACT: -! This subroutine map GOES cloud product to analysis grid -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! ib - begin i point of this domain -! jb - begin j point of this domain -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nn_obs - 1st dimension of observation arry data_s -! numsao - number of observation -! data_s - observation array for GOES cloud products -! -! output argument list: -! sat_ctp - GOES cloud top pressure in analysis grid -! sat_tem - GOES cloud top temperature in analysis grid -! w_frac - GOES cloud coverage in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! adapted according to RUC subroutine rd_cld -! * -! * This routine reads NESDIS (Madison, WI) cloud product produced -! * from GOES sounder data. The original product is reprocessed onto -! * MAPS40 grid boxes. There could be more than one cloud product -! * in a grid-box, so we use the nearest one that falls in the -! * grid. The routine combines GOES-8 and 10 products. -! -! ===== History ===== -! -! * Internal variables: -! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds -! -! * Working variables: -! -! * Working variables used for sorting max size of 10: -! Pxx, Txx, xdist,xxxdist (R4) -! Fxx, Nxx, index, jndex (I4) -! ioption (I4) = 1 if selection is nearest neighbor -! = 2 if selection is median of samples -! -! -! * Output variables on gridpoint (Nx,Ny): -! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature -! w_frac (R4) Effective fractional cloud coverage, option=1 -! fractional coverage within RUC grid, option=2 -! w_eca (R4) Effective fractional cloud regardless option -! (effective cloud amount - eca) -! nlev_cld (I4) Number of cloud levels. TO BE USED LATER -! to incorporate multi-level cloud -! -! * Calling routines -! sorting -! sortmed -! -! * -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,r_single,i_kind - use constants, only: zero,one_tenth,one,deg2rad - - implicit none - - integer(i_kind),intent(in) :: mype -! input-file variables: - INTEGER(i_kind),intent(in) :: Nx, Ny - INTEGER(i_kind),intent(in) :: ib, jb - INTEGER(i_kind),intent(in) :: numsao, nn_obs - real(r_kind),dimension(nn_obs,numsao):: data_s -! Output - real(r_single), intent(out) :: sat_ctp(Nx,Ny) - real(r_single), intent(out) :: sat_tem(Nx,Ny) - real(r_single), intent(out) :: w_lwp(Nx,Ny) - real(r_single), intent(out) :: w_frac(Nx,Ny) -! -! misc - integer(i_kind) :: nfov - parameter (nfov=650) - -! Working - real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) - real(r_kind) :: PHxx(Nx,Ny,nfov),WPxx(Nx,Ny,nfov) - real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) - real(r_kind) :: fr,sqrt -! integer(i_kind) :: Nxx(Nx,Ny,nfov) - integer(i_kind) :: index(Nx,Ny), jndex(nfov) - integer(i_kind) :: ioption - integer(i_kind) :: ipt,ii,jj,i,med_pt, & - ii1,jj1 - - real(r_kind) :: xc - real(r_kind) :: yc - -! real(r_single) :: w_eca(Nx,Ny) - integer(i_kind) :: nlev_cld(Nx,Ny) - integer(i_kind) :: ios,cfov - -! -! * Initialize outputs since GOES sounder do not scan all MAPS domain -! - do jj=1,Ny - do ii=1,Nx - sat_ctp (ii,jj) =-99999._r_kind - sat_tem (ii,jj) =-99999._r_kind - w_lwp (ii,jj) =-99999._r_kind - w_frac (ii,jj) =-99999._r_kind - nlev_cld (ii,jj) =-99999 - index(ii,jj) = 0 - enddo - enddo - -! -- set ios as failed unless valid data points are found below - ios = 0 - -! ----------------------------------------------------------- -! ----------------------------------------------------------- -! Map each FOV onto RR grid points -! ----------------------------------------------------------- -! ----------------------------------------------------------- - do ipt=1,numsao - - xc=data_s(2,ipt) - ib + 1.0_r_kind - yc=data_s(3,ipt) - jb + 1.0_r_kind - -! skip the bad observations - if(abs(data_s(6,ipt)+9.0_r_single) < 0.1_r_single) cycle - -! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 - - if(XC >= 1._r_kind .and. XC < Nx .and. & - YC >= 1._r_kind .and. YC < Ny) then - ii1 = int(xc+0.5_r_kind) - jj1 = int(yc+0.5_r_kind) - - do jj = max(1,jj1-1), min(ny,jj1+1) - if (jj1-1 >= 1 .and. jj1+1 <= ny) then - do ii = max(1,ii1-1), min(nx,ii1+1) - if (ii1-1 >= 1 .and. ii1+1 <= nx) then - -! * We check multiple data within gridbox - - if (index(ii,jj) < nfov) then - index(ii,jj) = index(ii,jj) + 1 - - Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) - Txx(ii,jj,index(ii,jj)) = data_s(5,ipt) - PHxx(ii,jj,index(ii,jj)) = data_s(6,ipt) - WPxx(ii,jj,index(ii,jj)) = data_s(7,ipt) -!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) -!mhu no cloud amount available, assign to 100 -! Nxx(ii,jj,index(ii,jj)) = 100 - nlev_cld(ii,jj) = 1 -! write(6,*)'sat_tem1::',index(ii,jj),data_s(4,ipt),data_s(5,ipt),data_s(6,ipt),data_s(7,ipt) - xdist(ii,jj,index(ii,jj)) = sqrt( & - (XC+1-ii)**2 + (YC+1-jj)**2) - end if - endif - enddo ! ii - endif - enddo ! jj - endif ! observation is in the domain - enddo ! ipt -! -! * ioption = 1 is nearest neighrhood -! * ioption = 2 is median of cloudy fov - ioption = 2 -! - do jj = 1,Ny - do ii = 1,Nx - if (index(ii,jj) < 3 ) then -! sat_ctp(ii,jj) = Pxx(ii,jj,1) -! sat_tem(ii,jj) = Txx(ii,jj,1) -! w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. -! w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. - - elseif(index(ii,jj) >= 3) then - -! * We decided to use nearest neighborhood for ECA values, -! * a kind of convective signal from GOES platform... - - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = xdist(ii,jj,i) - enddo - call sorting(xxxdist,index(ii,jj),jndex) -! w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind -! * Sort to find closest distance if more than one sample -! if(ioption == 1) then !nearest neighborhood -! do i=1,index(ii,jj) -! jndex(i) = i -! xxxdist(i) = xdist(ii,jj,i) -! enddo -! call sorting(xxxdist,index(ii,jj),jndex) -! sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) -! sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) -! w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind -! endif -! * Sort to find median value - if(ioption == 2) then !pick median - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = Pxx(ii,jj,i) - enddo - call sortmed(xxxdist,index(ii,jj),jndex,fr) - med_pt = index(ii,jj)/2 + 1 - sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) - sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) - w_lwp(ii,jj) = WPxx(ii,jj,jndex(med_pt)) - if ( abs(sat_ctp(ii,jj)+20.0_r_single) < 0.1_r_single) then - sat_ctp(ii,jj) = 1013. ! hPa - no cloud - w_frac(ii,jj)=0.0 - nlev_cld(ii,jj) = 0 - end if - -! -! cloud fraction based on phase (0 are clear), what about -9 ???? - if( sat_ctp(ii,jj) < 1012.99) then - cfov = 0 - do i=1,index(ii,jj) - if(PHxx(ii,jj,i) .gt. 0.1) cfov = cfov + 1 - enddo - w_frac(ii,jj) = float(cfov)/(max(1,index(ii,jj))) ! fraction - if( w_frac(ii,jj) > 0.01 ) nlev_cld(ii,jj) = 1 - endif - -! write(6,'(a,2I4,I5,2f10.2)')'sat_tem2::',ii,jj,index(ii,jj),sat_ctp(ii,jj),sat_tem(ii,jj) - endif - endif - enddo !ii - enddo !jj - - return -end subroutine map_ctp_lar diff --git a/lib/GSD/gsdcloud/mthermo.f90 b/lib/GSD/gsdcloud/mthermo.f90 deleted file mode 100644 index 83b5b7741..000000000 --- a/lib/GSD/gsdcloud/mthermo.f90 +++ /dev/null @@ -1,229 +0,0 @@ -! -!$$$ subprogram documentation block -! . . . . -! ABSTRACT: -! This file collects subroutines and functions related to thermodynamic calculations -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! 2010-05-03 Hu Clean the code -! -! -! input argument list: -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - function esat(t) -! -! this function returns the saturation vapor pressure over -! water (mb) given the temperature (celsius). -! the algorithm is due to nordquist, w.s.,1973: "numerical approxima- -! tions of selected meteorlolgical parameters for cloud physics prob- -! lems," ecom-5475, atmospheric sciences laboratory, u.s. army -! electronics command, white sands missile range, new mexico 88002. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind),intent(in) :: t - real(r_single) :: tk,p1,p2,c1 - real(r_kind) :: esat - - tk = t+273.15 - p1 = 11.344-0.0303998*tk - p2 = 3.49149-1302.8844/tk - c1 = 23.832241-5.02808*alog10(tk) - esat = 10.**(c1-1.3816E-7*10.**p1+8.1328E-3*10.**p2-2949.076/tk) - return - end function esat - - function eslo(t) -! -! this function returns the saturation vapor pressure over liquid -! water eslo (millibars) given the temperature t (celsius). the -! formula is due to lowe, paul r.,1977: an approximating polynomial -! for the computation of saturation vapor pressure, journal of applied -! meteorology, vol 16, no. 1 (january), pp. 100-103. -! the polynomial coefficients are a0 through a6. - use kinds, only: r_single,i_kind,r_kind - implicit none -! - real(r_kind), intent(in) :: t - real(r_kind) :: eslo - - real(r_kind) :: a0,a1,a2,a3,a4,a5,a6 - real(r_kind) :: es - - data a0,a1,a2,a3,a4,a5,a6 & - /6.107799961, 4.436518521E-01, 1.428945805E-02, & - 2.650648471E-04, 3.031240396E-06, 2.034080948E-08, & - 6.136820929E-11/ - es = a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+a6*t))))) - IF (es < 0.) es = 0. - eslo = es - return - end function eslo - - function tda(o,p) -! -! this function returns the temperature tda (celsius) on a dry adiabat -! at pressure p (millibars). the dry adiabat is given by -! potential temperature o (celsius). the computation is based on -! poisson's equation. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: o,p - real(r_kind) :: tda - - tda= (o+273.15)*((p*.001)**.286)-273.15 - return - end function tda - - function tmr(w,p) -! -! this function returns the temperature (celsius) on a mixing -! ratio line w (g/kg) at pressure p (mb). the formula is given in -! table 1 on page 7 of stipanuk (1973). -! -! initialize constants - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: w,p - real(r_kind) :: tmr - - real(r_kind) :: c1,c2,c3,c4,c5,c6 - real(r_kind) :: x,tmrk - real(r_single) :: y - - data c1/.0498646455/,c2/2.4082965/,c3/7.07475/ - data c4/38.9114/,c5/.0915/,c6/1.2035/ - - y=w*p/(622.+w) - x= alog10(y) - tmrk= 10.**(c1*x+c2)-c3+c4*((10.**(c5*x)-c6)**2.) - tmr= tmrk-273.15 - return - end function tmr - - function tsa(os,p) -! -! this function returns the temperature tsa (celsius) on a saturation -! adiabat at pressure p (millibars). os is the equivalent potential -! temperature of the parcel (celsius). sign(a,b) replaces the -! algebraic sign of a with that of b. -! b is an empirical constant approximately equal to 0.001 of the latent -! heat of vaporization for water divided by the specific heat at constant -! pressure for dry air. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: os,p - real(r_kind) :: tsa - - real(r_kind) :: a,b,d,tq,x,tqk,w - integer :: i - - data b/2.6518986/ - a= os+273.15 - -! tq is the first guess for tsa. - - tq= 253.15 - -! d is an initial value used in the iteration below. - - d= 120. - -! iterate to obtain sufficient accuracy....see table 1, p.8 -! of stipanuk (1973) for equation used in iteration. - - do i= 1,12 - tqk= tq-273.15 - d= d/2. - x= a*exp(-b*w(tqk,p)/tq)-tq*((1000./p)**.286) - IF (abs(x) < 1E-7) GOTO 2 - tq= tq+sign(d,x) - end do -2 tsa= tq-273.15 - return - end function tsa - - function tw(t,td,p) -! this function returns the wet-bulb temperature tw (celsius) -! given the temperature t (celsius), dew point td (celsius) -! and pressure p (mb). see p.13 in stipanuk (1973), referenced -! above, for a description of the technique. -! -! -! determine the mixing ratio line thru td and p. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: t,td,p - real(r_kind) :: tw - - real(r_kind) :: aw,ao,pi,tmr,tda,ti,aos,tsa,w,x - integer :: i - - aw = w(td,p) -! -! determine the dry adiabat thru t and p. - - ao = (t+273.15)*((1000./p)**.286)-273.15 - pi = p - -! iterate to locate pressure pi at the intersection of the two -! curves . pi has been set to p for the initial guess. - - do i= 1,10 - x= .02*(tmr(aw,pi)-tda(ao,pi)) - IF (abs(x) < 0.01) exit - pi= pi*(2.**(x)) - end do - -! find the temperature on the dry adiabat ao at pressure pi. - - ti= tda(ao,pi) - -! the intersection has been located...now, find a saturation -! adiabat thru this point. function os returns the equivalent -! potential temperature (c) of a parcel saturated at temperature -! ti and pressure pi. - - aos= (ti+273.15)*((1000./pi)**.286)*(exp(2.6518986*w(ti,pi)/(ti+273.15)))-273.15 - -! function tsa returns the wet-bulb temperature (c) of a parcel at -! pressure p whose equivalent potential temperature is aos. - - tw = tsa(aos,p) - return - end function tw - - function w(t,p) -! -! this function returns the mixing ratio (grams of water vapor per -! kilogram of dry air) given the dew point (celsius) and pressure -! (millibars). if the temperture is input instead of the -! dew point, then saturation mixing ratio (same units) is returned. -! the formula is found in most meteorological texts. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: t,p - real(r_kind) :: w - - real(r_kind) :: esat - - w= 622.*esat(t)/(p-esat(t)) - return - end function w diff --git a/lib/GSD/gsdcloud/pbl_height.f90 b/lib/GSD/gsdcloud/pbl_height.f90 deleted file mode 100644 index 6466899f0..000000000 --- a/lib/GSD/gsdcloud/pbl_height.f90 +++ /dev/null @@ -1,103 +0,0 @@ -SUBROUTINE calc_pbl_height(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk,pblh) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: pbl_height to calculate PBL height or level -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-04-06 -! -! ABSTRACT: -! This subroutine calculate PBL height -! -! PROGRAM HISTORY LOG: -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! q_bk - 3D moisture -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! -! output argument list: -! pblh - 2D PBL height (level number) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind, r_kind - - implicit none - - integer(i_kind),intent(in):: mype - integer(i_kind),intent(in):: nlat,nlon,nsig -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) - real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) -! -! Variables for cloud analysis -! - real (r_single),intent(out) :: pblh(nlon,nlat) -! -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k - real(r_single) :: thetav(nsig) - real(r_single) :: thsfc,qsp - -!==================================================================== -! Begin -! -! - DO j = 1,nlat - DO i = 1,nlon - - DO k = 1,nsig - qsp=q_bk(i,j,k)/(1.0+q_bk(i,j,k)) ! q_bk = water vapor mixing ratio - thetav(k) = t_bk(i,j,k)*(1.0 + 0.61 * qsp) ! qsp = spcific humidity -! if(mype==10.and.i==10.and.j==10) then -! write(*,*) 'cal PBL=',k,thetav(k),t_bk(i,j,k),q_bk(i,j,k) -! endif - ENDDO - - pblh(i,j) = 0.0_r_single - thsfc = thetav(1) - k=1 - DO while (abs(pblh(i,j)) < 0.0001_r_single) - if( thetav(k) > thsfc + 1.0_r_single ) then - pblh(i,j) = float(k) - (thetav(k) - (thsfc + 1.0_r_single))/ & - max((thetav(k)-thetav(k-1)),0.01_r_single) - endif - k=k+1 - ENDDO - if(abs(pblh(i,j)) < 0.0001) pblh(i,j)=2.0_r_single - -! if(mype==10.and.i==10.and.j==10) then -! write(*,*) 'cal PBL=',pblh(i,j),k -! endif - - - enddo ! i - enddo ! j - -END SUBROUTINE calc_pbl_height - diff --git a/lib/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 b/lib/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 deleted file mode 100644 index e25e6a848..000000000 --- a/lib/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 +++ /dev/null @@ -1,509 +0,0 @@ - -SUBROUTINE pcp_mxr (nx,ny,nz,t_3d,p_3d ,ref_3d & - ,cldpcp_type_3d & - ,qr_3d,qs_3d,qg_3d,istatus ) - -! -!$$$ subprogram documentation block -! . . . . -! subprogram: pcp_mxr calculates hydrometeor mixing ratios based on Kessler radar reflectivity equations -! -! PRGMMR: ORG: DATE: -! -! ABSTRACT: -! This subroutine calculate precipitation based on Kessler radar reflectivity equations -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nz - no. of levels -! t_3d - 3D background temperature (K) -! p_3d - 3D background pressure (hPa) -! ref_3d - 3D reflectivity in analysis grid (dBZ) -! cldpcp_type_3d - 3D precipitation type -! -! output argument list: -! qr_3d - rain mixing ratio (g/kg) -! qs_3d - snow mixing ratio (g/kg) -! qg_3d - graupel/hail mixing ratio (g/kg) -! istatus - -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! Old documents from CAPS -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Perform 3D precipitation mixing ratio (in g/kg) analysis using -! radar reflectivity data. For rain water, using Kessler (1969) -! formula: -! qr(g/kg) = a*(rho*arg)**b (1) -! -! Here arg = Z (mm**6/m**3), and dBZ = 10log10 (arg). -! Coeffcients a=17300.0, and b=7/4. -! rho represents the air density. -! -! For snow and graupel/hail, using Rogers and Yau (1989) formula: -! -! qs(g/kg) = c*(rho*arg)**d (2) -! -! where, c=38000.0, d=2.2 -! -! -!----------------------------------------------------------------------- -! -! AUTHOR: (Jian Zhang) -! 06/13/96 -! -! MODIFICATION HISTORY: -! 07/30/97 (J. Zhang) -! Added precipitation type in the argument list so that -! mixing ratios of different precip. types can be computed. -! 09/04/97 (J. Zhang) -! Changed the radar echo thresholds for inserting precip. -! from radar reflectivities. -! -!----------------------------------------------------------------------- -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind, r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - integer(i_kind),intent(in) :: nx,ny,nz ! Model grid size -! - REAL(r_kind), intent(in) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) - real(r_single),intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) - real(r_single),intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) - - integer(i_kind),intent(in):: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field -! -! OUTPUT: - INTEGER(i_kind),intent(out) :: istatus -! - REAL(r_single),intent(out) :: qr_3d(nx,ny,nz)! rain mixing ratio in (g/kg) - REAL(r_single),intent(out) :: qs_3d(nx,ny,nz)! snow/sleet/frz-rain mixing ratio - ! in (g/kg) - REAL(r_single),intent(out) :: qg_3d(nx,ny,nz)! graupel/hail mixing ratio in (g/kg) -! -! LOCAL: - REAL(r_kind) :: a,b,c,d ! Coef. for Z-qr relation. - PARAMETER (a=17300.0_r_kind, b=7.0/4.0_r_kind) - PARAMETER (c=38000.0_r_kind, d=2.2_r_kind) - REAL(r_kind) :: rair ! Gas constant (J/deg/kg) - PARAMETER (rair = 287.04_r_kind) - REAL(r_kind) :: thresh_ref - PARAMETER (thresh_ref = 0.0_r_kind) - INTEGER(i_kind) :: pcptype -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind) :: i,j,k, iarg - REAL(r_kind) :: arg,rhobar,br,dr - PARAMETER (br=1.0_r_kind/b, dr=1.0_r_kind/d) -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! - istatus=0 -! -!----------------------------------------------------------------------- -! -! Compute the precip mixing ratio in g/kg from radar reflectivity -! factor following Kessler (1969) or Rogers and Yau (1989). -! -!----------------------------------------------------------------------- -! - DO k = 1,nz-1 - DO j = 2,ny-1 - DO i = 2,nx-1 - IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. - rhobar = p_3d(i,j,k)/rair/t_3d(i,j,k) - arg = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) - iarg = cldpcp_type_3d(i,j,k) - pcptype = iarg/16 ! precip. type - - IF (pcptype == 0) THEN ! no precip - PRINT*,'+++ NOTE: radar echo though no precip. +++' - ELSE IF (pcptype == 1.OR.pcptype == 3) THEN ! rain or Z R - qr_3d(i,j,k) = (arg/a)**br/rhobar - ELSE IF (pcptype == 2) THEN ! snow - qs_3d(i,j,k) = (arg/c)**dr/rhobar - ELSE IF (pcptype == 4.OR.pcptype == 5) THEN ! hail or sleet - qg_3d(i,j,k) = (arg/c)**dr/rhobar - ELSE ! unknown - PRINT*,'+++ NOTE: unknown precip type. +++' - END IF - ELSE - qr_3d(i,j,k) = 0._r_kind - qs_3d(i,j,k) = 0._r_kind - qg_3d(i,j,k) = 0._r_kind - END IF - END DO ! k - END DO ! i - END DO ! j -! -!----------------------------------------------------------------------- -! - istatus = 1 -! - RETURN -END SUBROUTINE pcp_mxr - -! -SUBROUTINE pcp_mxr_ferrier (nx,ny,nz,t_3d,p_3d ,ref_3d & - ,cldpcp_type_3d & - ,qr_3d,qs_3d,qg_3d,istatus,mype ) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: pcp_mxr calculate hydrometeor type based on ferrier radar reflectivity equations -! -! PRGMMR: ORG: DATE: -! -! ABSTRACT: -! This subroutine calculate precipitation based on ferrier radar reflectivity equations -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nz - no. of levels -! t_3d - 3D background temperature (K) -! p_3d - 3D background pressure (hPa) -! ref_3d - 3D reflectivity in analysis grid (dBZ) -! cldpcp_type_3d - 3D precipitation type -! -! output argument list: -! qr_3d - rain mixing ratio (g/kg) -! qs_3d - snow mixing ratio (g/kg) -! qg_3d - graupel/hail mixing ratio (g/kg) -! istatus - -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! Old document from CAPS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Perform 3D precipitation mixing ratio (in g/kg) analysis using -! radar reflectivity data. For rain water, using Ferrier et al (1995) -! formulation: -! -! -! For rain water: -! -! 18 -! 10 * 720 1.75 -! Zer = --------------------------- * (rho * qr) -! 1.75 0.75 1.75 -! pi * N0r * rhor -! -! -! For dry snow (t <= 0 C): -! -! -! 18 2 0.25 -! 10 * 720 * |K| * rhos -! ice 1.75 -! Zes = ----------------------------------------- * (rho * qs) t <= 0 C -! 1.75 2 0.75 2 -! pi * |K| * N0s * rhoi -! water -! -! -! For wet snow (t >= 0 C): -! -! -! 18 -! 10 * 720 1.75 -! Zes = ---------------------------- * (rho * qs) t > 0 C -! 1.75 0.75 1.75 -! pi * N0s * rhos -! -! -! For hail water: -! -! -! / 18 \ 0.95 -! / 10 * 720 \ 1.6625 -! Zeh = | ---------------------------- | * (rho * qg) -! \ 1.75 0.75 1.75 / -! \ pi * N0h * rhoh / -! -! Here Zx (mm**6/m**3, x=r,s,h), and dBZ = 10log10 (Zx). -! rho represents the air density, rhor,rhos,rhoh are the density of -! rain, snow and hail respectively. Other variables are all constants -! for this scheme, see below. -! -! -!----------------------------------------------------------------------- -! -! AUTHOR: (Donghai Wang and Eric Kemp) -! 07/20/2000 -! -! MODIFICATION HISTORY: -! -! 11/09/2000 Keith Brewster -! Moved some parameters with real-valued exponentiation to be -! computed at runtime due to compiler complaint. -! -! 04/07/2003 Keith Brewster -! Restructured code to make more tractable.and consistent with -! the reflec_ferrier subroutine. -! -!----------------------------------------------------------------------- -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind, r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size -! - REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) - REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) - REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) - - INTEGER(i_kind),intent(in) :: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field - INTEGER(i_kind),intent(in) :: mype -! -! OUTPUT: - INTEGER(i_kind),intent(out):: istatus -! - REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio in (g/kg) - REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow/sleet/frz-rain mixing ratio - ! in (g/kg) - REAL(r_single),intent(out) :: qg_3d(nx,ny,nz) ! graupel/hail mixing ratio - ! in (g/kg) -! - - REAL(r_kind),PARAMETER :: ki2 = 0.176_r_kind ! Dielectric factor for ice if other - ! than melted drop diameters are used. - REAL(r_kind),PARAMETER :: kw2=0.93_r_kind ! Dielectric factor for water. - - REAL(r_kind),PARAMETER :: m3todBZ=1.0E+18_r_kind ! Conversion factor from m**3 to - ! mm**6 m**-3. - REAL(r_kind),PARAMETER :: Zefact=720.0_r_kind ! Multiplier for Ze components. - REAL(r_kind),PARAMETER :: lg10div=0.10_r_kind ! Log10 multiplier (1/10) - - REAL(r_kind),PARAMETER :: pi=3.1415926_r_kind! Pi. - REAL(r_kind),PARAMETER :: N0r=8.0E+06_r_kind ! Intercept parameter in 1/(m^4) for rain. - REAL(r_kind),PARAMETER :: N0s=3.0E+06_r_kind ! Intercept parameter in 1/(m^4) for snow. - REAL(r_kind),PARAMETER :: N0h=4.0E+04_r_kind ! Intercept parameter in 1/(m^4) for graupel/hail. - - REAL(r_kind),PARAMETER :: N0xpowf=3.0/7.0_r_kind ! Power to which N0r,N0s & N0h are - ! raised. - REAL(r_kind),PARAMETER :: K2powf=4.0/7.0_r_kind ! Power to which K-squared - ! of ice, water are raised - REAL(r_kind),PARAMETER :: zkpowf=4.0/7.0_r_kind ! Power to which Zk is raised - REAL(r_kind),PARAMETER :: zepowf=4.0/7.0_r_kind ! Power to which Ze is raised - REAL(r_kind),PARAMETER :: zehpowf=(4.0/7.0)*1.0526_r_kind ! Power to which Zeh is raised - - REAL(r_kind),PARAMETER :: rhoi=917._r_kind ! Density of ice (kg m**-3) - REAL(r_kind),PARAMETER :: rhor=1000._r_kind ! Density of rain (kg m**-3) - REAL(r_kind),PARAMETER :: rhos=100._r_kind ! Density of snow (kg m**-3) - REAL(r_kind),PARAMETER :: rhoh=913._r_kind ! Density of graupel/hail (kg m**-3) - - REAL(r_kind),PARAMETER :: rhoipowf=8.0/7.0_r_kind ! Power to which rhoi is raised. - REAL(r_kind),PARAMETER :: rhospowf=1.0/7.0_r_kind ! Power to which rhos is raised. - - REAL(r_kind), PARAMETER :: rd=287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) - REAL(r_kind), PARAMETER :: thresh_ref = 0.0_r_kind -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind) :: i,j,k, iarg - INTEGER(i_kind) :: pcptype - REAL(r_kind) :: zkconst,zerf,zesnegf,zesposf,zehf,rfract - REAL(r_kind) :: ze,zer,zeh,zes,rho,tc - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Intiailize constant factors in the Ze terms for rain, snow and graupel/hail, -! respectively, in Ferrier. -! -! These are the inverse of those presented in the reflec_ferrier function. -! -!----------------------------------------------------------------------- -! - istatus=0 - - zkconst = (Zefact*m3todBZ) ** zkpowf - - zerf=1000._r_kind*(pi * (N0r**N0xpowf) * rhor )/zkconst - - zesnegf=1000._r_kind*(pi*(kw2**k2powf)*(N0s**N0xpowf)*(rhoi**rhoipowf)) / & - ( zkconst * (ki2**k2powf) * (rhos**rhospowf) ) - - zesposf=1000._r_kind*( pi * (N0s**N0xpowf) * rhos) / zkconst - - zehf=1000._r_kind*( pi * (N0h**N0xpowf) * rhoh) / zkconst - -!----------------------------------------------------------------------- -! -! Compute the precip mixing ratio in g/kg from radar reflectivity -! factor following Ferrier et al (1995). -! -!----------------------------------------------------------------------- -! - - DO k = 2,nz-1 - DO j = 2,ny-1 - DO i = 2,nx-1 - IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. - rho = p_3d(i,j,k)/(rd*t_3d(i,j,k)) - ze = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) - iarg = cldpcp_type_3d(i,j,k) - pcptype = iarg/16 ! precip. type - tc = t_3d(i,j,k) - 273.15_r_kind -!mhu temporal fix - IF (tc <= 0.0_r_kind) THEN - qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho - qr_3d(i,j,k) = 0.0_r_kind - ELSE IF (tc < 5.0_r_kind) THEN !wet snow - rfract=0.20_r_kind*tc - zer=rfract*ze - zes=(1.-rfract)*ze -! qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho -! qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - qs_3d(i,j,k) = zesnegf * (zes**zepowf) / rho - qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - else - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - qs_3d(i,j,k) = 0.0_r_kind - ENDIF - cycle -!mhu - IF (pcptype == 1) THEN ! rain - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - ELSE IF (pcptype == 2) THEN ! snow - IF (tc <= 0.0_r_kind) THEN !dry snow - qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho - ELSE IF (tc < 5.0_r_kind) THEN !wet snow - rfract=0.20_r_kind*tc - zer=rfract*ze - zes=(1.-rfract)*ze - qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho - qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - ELSE - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - END IF - ELSE IF (pcptype == 3) THEN ! ZR - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - ELSE IF (pcptype == 4) THEN ! sleet - IF (tc <= 0.0_r_kind) THEN ! graupel/hail category - qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho - ELSE IF( tc < 10._r_kind ) THEN - rfract=0.10_r_kind*tc - zer=rfract*ze - zeh=(1.-rfract)*ze - qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - qg_3d(i,j,k) = zehf * (zeh**zehpowf) / rho - ELSE - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - END IF - ELSE IF (pcptype == 5) THEN ! graupel/hail - qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho - ELSE ! unknown - IF (tc <= 0.0_r_kind) THEN !dry snow - qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho - ELSE IF ( tc < 5.0_r_kind ) THEN !wet snow - rfract=0.20_r_kind*tc - zer=rfract*ze - zes=(1.-rfract)*ze - qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho - qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - ELSE ! rain - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - END IF - END IF - ELSE - qr_3d(i,j,k) = -999._r_kind - qs_3d(i,j,k) = -999._r_kind - qg_3d(i,j,k) = -999._r_kind - END IF - END DO ! k - END DO ! i - END DO ! j -! PRINT*,'Finish Ferrier ...' -! -!----------------------------------------------------------------------- -! - istatus = 1 -! - RETURN -END SUBROUTINE pcp_mxr_ferrier diff --git a/lib/GSD/gsdcloud/radar_ref2tten.f90 b/lib/GSD/gsdcloud/radar_ref2tten.f90 deleted file mode 100644 index c423d7bc6..000000000 --- a/lib/GSD/gsdcloud/radar_ref2tten.f90 +++ /dev/null @@ -1,334 +0,0 @@ -SUBROUTINE radar_ref2tten(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mos_3d, & - cld_cover_3d,p_bk,t_bk,ges_tten,dfi_rlhtp,krad_bot_in,pblh,sat_ctp) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: radar_ref2tten convert radar reflectivity to 3-d temperature tendency -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-27 -! -! ABSTRACT: -! This subroutine converts radar observation (dBZ) to temperature tendency for DFI -! -! PROGRAM HISTORY LOG: -! 2009-01-02 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! istat_radar - radar data status: 0=no radar data; 1=use radar reflectivity -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! ref_mos_3d - 3D radar reflectivity (dBZ) -! cld_cover_3d - 3D cloud cover (0-1) -! p_bk - 3D background pressure (hPa) -! t_bk - 3D background potential temperature (K) -! sat_ctp - 2D NESDIS cloud top pressure (hPa) -! ges_tten - 3D radar temperature tendency -! dfi_rlhtp - dfi radar latent heat time period. DFI forward integration window in minutes -! krad_bot_in - radar bottome height -! pblh - PBL height in grid unit -! -! output argument list: -! ges_tten - 3D radar temperature tendency -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use constants, only: rd_over_cp, h1000 - use kinds, only: r_kind,i_kind,r_single - implicit none - - INTEGER(i_kind),INTENT(IN) :: mype - INTEGER(i_kind),INTENT(IN) :: nlon,nlat,nsig - INTEGER(i_kind),INTENT(IN) :: istat_radar - INTEGER(i_kind),INTENT(IN) :: istat_lightning - real(r_kind),INTENT(IN) :: dfi_rlhtp - real(r_single),INTENT(IN) :: krad_bot_in - real(r_single),INTENT(IN) :: pblh(nlon,nlat) - - real(r_kind),INTENT(IN) :: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid - real(r_single),INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) - real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) - real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature - real(r_kind), INTENT(INOUT):: ges_tten(nlat,nlon,nsig,1) - real(r_single),INTENT(IN),OPTIONAL :: sat_ctp(nlon,nlat) - - real (r_single) :: tbk_k - - real(r_kind), allocatable :: tten_radar(:,:,:) ! - real(r_kind), allocatable :: dummy(:,:) ! - - integer krad_bot ! RUC bottom level for TTEN_RAD -! -! convection suppression -! - real(r_kind), allocatable :: radyn(:,:) - real(r_kind) :: radmax, dpint - integer(i_kind) :: nrad - real(r_kind) :: radmaxall, dpintmax - -! adopted from: METCON of RUC (/ihome/rucdev/code/13km/hybfront_code) -! CONTAINS ATMOSPHERIC/METEOROLOGICAL/PHYSICAL CONSTANTS -!** R_P R J/(MOL*K) UNIVERSAL GAS CONSTANT -!** R* = 8.31451 -!** MD_P R KG/MOL MEAN MOLECULAR WEIGHT OF DRY AIR -!** MD = 0.0289645 -!jmb--Old value MD = 0.0289644 -!** RD_P R J/(KG*K) SPECIFIC GAS CONSTANT FOR DRY AIR -!** RD = R*>/-100) then ! no echo - tten_radar(i,j,k) = 0._r_kind - else if (ref_mos_3d(i,j,k)>=0.001_r_kind) then ! echo - iskip=0 - if (PRESENT(sat_ctp) ) then - if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then - iskip=iskip+1 -! write (6,*)' Radar ref > 5 dbZ, GOES indicates clear' -! write (6,*)' i,j,k / refl / lat-lon',i,j,k,ref_mos_3d(i,j,k) -! Therefore, if GOES indicates clear, tten_radar -! will retain the zero value - endif - endif - if (tbk_k>277.15_r_kind .and. ref_mos_3d(i,j,k)<28._r_kind) then - iskip=iskip+1 -! write (6,*)' t is over 277 ',i,j,k,ref_mos_3d(i,j,k) -! ALSO, if T > 4C and refl < 28dBZ, again -! tten_radar = 0. - endif - if(iskip == 0 ) then -! tten_radar set as non-zero ONLY IF -! - not contradicted by GOES clear, and -! - ruc_refl > 28 dbZ for temp > 4K, and -! - for temp < 4K, any ruc_refl dbZ is OK. -! - cloudy and under GOES cloud top -! - dfi_rlhtp in minutes - if (k>=krad_bot) then -! can not use cld_cover_3d because we don't use reflectivity to build cld_cover_3d -! if (abs(cld_cover_3d(i,j,k))<=0.5_r_kind .and. (sat_ctp(i,j)>p_bk(i,j,k))) then - addsnow = 10**(ref_mos_3d(i,j,k)/17.8_r_kind)/264083._r_kind*1.5_r_kind - if (PRESENT(sat_ctp) ) then - if ( (sat_ctp(i,j) > 1.0_r_kind .and. sat_ctp(i,j) < 1100.0_r_kind) & - .and. sat_ctp(i,j)>p_bk(i,j,k)) then - addsnow=0.0_r_kind - endif - endif - tten = ((1000.0_r_kind/p_bk(i,j,k))**(1._r_kind/cpovr_p)) & - *(((LV_P+LF0_P)*addsnow)/ & - (dfi_rlhtp*60.0_r_kind*CPD_P)) - tten_radar(i,j,k)= min(0.01_r_kind,max(-0.01_r_kind,tten)) - end if - end if - end if ! ref_mos_3d - - ENDDO - ENDDO - ENDDO - -! DO k=1,nsig -! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) -! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) -! ENDDO - -!================================================================================ -! At this point -! 1. put tten_radar into ges_tten array -! for use as tten_radar in subsequent model DFI. -! 2. calculate convection suppression array (RADYN), by -! first smoothing further the tten_radar array -! (available since it is already copied to ges_tten) -! and with adding clear areas from GOES cloud data. - -! KEY element -- Set tten_radar to no-coverage AFTER smoothing -! where ref_mos_3d had been previously set to no-coverage (-99.0 dbZ) -!================================================================================ - - DO k=1,nsig - DO j=1,nlat - DO i=1,nlon - ges_tten(j,i,k,1)=tten_radar(i,j,k) - if(ref_mos_3d(i,j,k)<=-200.0_r_kind ) ges_tten(j,i,k,1)=-spval_p ! no obs - ENDDO - ENDDO - ENDDO -! DO k=1,nsig -! write(6,*)' k,max,min check=',mype,k,maxval(ges_tten(:,:,k,1)),minval(ges_tten(:,:,k,1)) -! enddo - -! -- Whack (smooth) the tten_radar array some more. -! for convection suppression in the radyn array. - DO k=1,nsig - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - ENDDO - - deallocate(dummy) - -! RADYN array = convection suppression array -! Definition of RADYN values -! -10 -> no information -! 0 -> no convection -! 1 -> there might be convection nearby -! NOTE: 0,1 values are only possible if -! deep radar coverage is available (i.e., > 300 hPa deep) - -! RADYN is read into RUC model as array PCPPREV, -! where it is used to set the cap_depth (cap_max) -! in the Grell-Devenyi convective scheme -! to a near-zero value, effectively suppressing convection -! during DFI and first 30 min of the forward integration. - - allocate(radyn(nlon,nlat)) - radyn = -10._r_kind - - radmaxall=-999 - dpintmax=-999 - DO j=1,nlat - DO i=1,nlon - - nrad = 0 - radmax = 0._r_kind - dpint = 0._r_kind - DO k=2,nsig-1 - if ((ref_mos_3d(i,j,k))<=-200.0_r_kind) tten_radar(i,j,k) = -spval_p - if (tten_radar(i,j,k)>-15._r_kind) then - nrad=nrad+1 - dpint = dpint + 0.5_r_kind*(p_bk(i,j,k-1)-p_bk(i,j,k+1)) - radmax = max(radmax,tten_radar(i,j,k)) - end if - ENDDO - if (dpint>=300._r_kind ) then - radyn(i,j) = 0._r_kind - if (radmax>0.00002_r_kind) radyn(i,j) = 1. - if( abs(radyn(i,j)) < 0.00001_r_kind ) then - krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height - do k=krad_bot,nsig-1 - ges_tten(j,i,k,1) = 0._r_kind - end do - endif - else -! outside radar coverage area where satellite shows clear conditions, -! then add this area to the convection suppress area. - if (PRESENT(sat_ctp) ) then - if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then - radyn(i,j) = 0._r_kind - endif - endif - endif - -! 2. Extend depth of no-echo zone from dpint zone down to PBL top, -! similarly to how lowest echo (with convection) is extended down to PBL top -! 5/27/2010 - Stan B. -! if (dpint >= 300. .and. radmax<=0.001) then -! krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height -! do k=krad_bot,nsig-1 -! ges_tten(j,i,k,1) = 0._r_kind -! end do -! end if - - if(dpintmax < dpint ) dpintmax=dpint - if(radmaxall< radmax) radmaxall=radmax - ENDDO - ENDDO - - DO j=1,nlat - DO i=1,nlon - ges_tten(j,i,nsig,1)=radyn(i,j) - ENDDO - ENDDO - - deallocate(tten_radar) - deallocate(radyn) - - else ! no radar observation i this subdomain - - ges_tten=-spval_p - ges_tten(:,:,nsig,1)=-10.0_r_kind - - DO j=1,nlat - DO i=1,nlon - -! outside radar observation domain and satellite show clean, the suppress convection - if (PRESENT(sat_ctp) ) then - if (sat_ctp(i,j)>=1010._r_kind .and. sat_ctp(i,j)<=1100._r_kind) then - ges_tten(j,i,nsig,1) = 0. - endif - endif - ENDDO - ENDDO - - endif - - DO k=1,nsig - DO j=1,nlat - DO i=1,nlon - if(ges_tten(j,i,k,1) <= -200.0_r_kind ) ges_tten(j,i,k,1)=-20.0_r_kind ! no obs - ENDDO - ENDDO - ENDDO - -END SUBROUTINE radar_ref2tten diff --git a/lib/GSD/gsdcloud/read_Lightning_cld.f90 b/lib/GSD/gsdcloud/read_Lightning_cld.f90 deleted file mode 100644 index 89097f72b..000000000 --- a/lib/GSD/gsdcloud/read_Lightning_cld.f90 +++ /dev/null @@ -1,93 +0,0 @@ -SUBROUTINE read_Lightning2cld(mype,lunin,istart,jstart, & - nlon,nlat,numlight,lightning) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_NESDIS read in lightning flash rate -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-30 -! -! ABSTRACT: -! This subroutine read in lightning flash rate -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! numlight - number of observation -! -! output argument list: -! lightning - lightning flash rate in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,i_kind, r_single - implicit none - - integer(i_kind),intent(in) :: lunin - integer(i_kind),intent(in) :: mype - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - INTEGER(i_kind),intent(in) :: numlight - - real(r_single), intent(out):: lightning(nlon,nlat) -! -! local -! - real(r_kind),allocatable :: light_in(:,:) - - character(10) :: obstype - integer(i_kind):: nreal,nchanl,ilat1s,ilon1s - character(20) :: isis - - INTEGER(i_kind) :: i,ii,jj - INTEGER(i_kind) :: ib,jb - -! - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - - ilon1s=1 - ilat1s=2 - - read(lunin) obstype,isis,nreal,nchanl - - allocate( light_in(nreal,numlight) ) - light_in=-9999.0_r_kind - - read(lunin) light_in - DO i=1,numlight - ii=int(light_in(ilon1s,i)+0.001_r_kind) - ib + 2 - jj=int(light_in(ilat1s,i)+0.001_r_kind) - jb + 2 - if( ii < 1 .or. ii > nlon ) write(6,*) 'read_Lightning_cld: ', & - 'Error in read in lightning ii:',mype,ii,jj,i,ib,jb - if( jj < 1 .or. jj > nlat ) write(6,*) 'read_Lightning_cld:', & - 'Error in read in lightning jj:',mype,ii,jj,i,ib,jb - lightning(ii,jj)=light_in(3,i) - ENDDO - deallocate(light_in) - -END SUBROUTINE read_Lightning2cld diff --git a/lib/GSD/gsdcloud/read_NESDIS.f90 b/lib/GSD/gsdcloud/read_NESDIS.f90 deleted file mode 100644 index 31b9a292d..000000000 --- a/lib/GSD/gsdcloud/read_NESDIS.f90 +++ /dev/null @@ -1,123 +0,0 @@ -SUBROUTINE read_NESDIS(mype,lunin,numobs,istart,jstart,nlon,nlat, & - sat_ctp,sat_tem,w_frac,npts_rad) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_NESDIS read in NESDIS cloud products and map them into analysis grid -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 -! -! ABSTRACT: -! This subroutine read in NESDIS cloud products and map them into analysis grid -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! numobs - number of observation -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! -! output argument list: -! sat_ctp - GOES cloud top pressure in analysis grid -! sat_tem - GOES cloud top temperature in analysis grid -! w_frac - GOES cloud coverage in analysis grid -! -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - integer(i_kind),intent(in) :: lunin - INTEGER(i_kind),intent(in) :: numobs - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - INTEGER(i_kind),intent(in) :: npts_rad - - real(r_single), intent(out):: sat_ctp(nlon,nlat) ! cloud top pressure - real(r_single), intent(out):: sat_tem(nlon,nlat) ! cloud top temperature - real(r_single), intent(out):: w_frac(nlon,nlat) ! cloud fraction -! - INTEGER(i_kind) :: nn_obs - real(r_kind),allocatable,dimension(:,:):: data_s - logical,allocatable,dimension(:):: luse -! -! misc. -! - character(10) :: obstype - integer(i_kind) :: mm1 - integer(i_kind) :: nreal,nchanl - character(20) :: isis - - INTEGER(i_kind) :: i, j - INTEGER(i_kind) :: ib, jb -! -! =============================================================== -! - - mm1=mype+1 - - read(lunin) obstype,isis,nreal,nchanl - nn_obs = nreal + nchanl - allocate(luse(numobs),data_s(nn_obs,numobs)) - read(lunin) data_s, luse -! - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - call map_ctp (ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac,npts_rad) -!! -! filling boundarys -! - DO i=2,nlon-1 - sat_ctp(i,1) =sat_ctp(i,2) - sat_tem(i,1) =sat_tem(i,2) - w_frac(i,1) =w_frac(i,2) - sat_ctp(i,nlat)=sat_ctp(i,nlat-1) - sat_tem(i,nlat)=sat_tem(i,nlat-1) - w_frac(i,nlat) =w_frac(i,nlat-1) - enddo - DO j=2,nlat-1 - sat_ctp(1,j) =sat_ctp(2,j) - sat_tem(1,j) =sat_tem(2,j) - w_frac(1,j) =w_frac(2,j) - sat_ctp(nlon,j)=sat_ctp(nlon-1,j) - sat_tem(nlon,j)=sat_tem(nlon-1,j) - w_frac(nlon,j) =w_frac(nlon-1,j) - enddo - sat_ctp(1,1) =sat_ctp(2,2) - sat_tem(1,1) =sat_tem(2,2) - w_frac(1,1) =w_frac(2,2) - sat_ctp(1,nlat) =sat_ctp(2,nlat-1) - sat_tem(1,nlat) =sat_tem(2,nlat-1) - w_frac(1,nlat) =w_frac(2,nlat-1) - sat_ctp(nlon,1) =sat_ctp(nlon-1,2) - sat_tem(nlon,1) =sat_tem(nlon-1,2) - w_frac(nlon,1) =w_frac(nlon-1,2) - sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) - sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) - w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) - -END SUBROUTINE read_NESDIS diff --git a/lib/GSD/gsdcloud/read_Surface.f90 b/lib/GSD/gsdcloud/read_Surface.f90 deleted file mode 100644 index 48a1765a4..000000000 --- a/lib/GSD/gsdcloud/read_Surface.f90 +++ /dev/null @@ -1,240 +0,0 @@ -SUBROUTINE read_Surface(mype,lunin,istart,jstart,nlon,nlat,& - numsao,NVARCLD_P,OI,OJ,OCLD,OWX,Oelvtn,Odist,cstation, & - OIstation,OJstation) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_Surface read in cloud observations in surface observation -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 -! -! ABSTRACT: -! This subroutine read in cloud observations in surface observation -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! numsao - maximum observation number (observation number) -! NVARCLD_P - first dimension of OLCD -! -! output argument list: -! -! OI - observation x location -! OJ - observation y location -! OLCD - cloud amount, cloud height, visibility -! OWX - weather observation -! Oelvtn - observation elevation -! Odist - distance from the nearest station -! cstation - station name - -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! - - use kinds, only: r_single,i_kind,r_kind,r_double - - implicit none - - integer(i_kind), intent(in) :: mype - integer(i_kind), intent(in) :: lunin - integer(i_kind), intent(in) :: istart - integer(i_kind), intent(in) :: jstart - INTEGER(i_kind), intent(in) :: nlon,nlat - INTEGER(i_kind), intent(in) :: numsao - INTEGER(i_kind), intent(in) :: NVARCLD_P - - real(r_single), intent(out) :: OI(numsao) ! x location, grid - real(r_single), intent(out) :: OJ(numsao) ! y location, grid - INTEGER(i_kind), intent(out) :: OCLD(NVARCLD_P,numsao) ! cloud amount, cloud height, - ! visibility - CHARACTER*10, intent(out) :: OWX(numsao) ! weather - real(r_single), intent(out) :: Oelvtn(numsao) ! elevation - real(r_single), intent(out) :: Odist(numsao) ! distance from the nearest station - character(8), intent(out) :: cstation(numsao) ! station name - real(r_single), intent(out) :: OIstation(numsao) ! x location, station - real(r_single), intent(out) :: OJstation(numsao) ! y location, station - -! -! temp. -! - real(r_single) :: VIS ! horizontal visibility -! -! misc. -! - real(r_kind),allocatable,dimension(:,:):: data_s - logical,allocatable,dimension(:):: luse - character(10) :: obstype - integer(i_kind):: nreal,nchanl - character(20) :: isis - - INTEGER(i_kind) :: nn_obs - real(r_kind) :: cldamt,awx,cldhgt - character*3 :: mwx - INTEGER(i_kind) :: i,j,jb,ib - integer(i_kind) :: start, end - - real(r_kind) :: spval_p - parameter (spval_p = 99999.) - - real(r_double) rstation_id - character(8) :: cstation1 - equivalence(cstation1,rstation_id) - - -!==================================================================== -! Begin - OWX='' - OCLD=-99999 - - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - -! - read(lunin) obstype,isis,nreal,nchanl - - nn_obs = nreal + nchanl - allocate(luse(numsao),data_s(nn_obs,numsao)) - read(lunin) data_s, luse -! -! read in ruface observations: -! station name, x location, y location, longitude, latitude, elevation -! visibility, cloud amount, cloud height, weather -! - DO i=1,numsao - rstation_id=data_s(1,i) - cstation(i)=cstation1 - OI(i) = data_s(2,i) - ib + 2 ! covert it to the local grid - OJ(i) = data_s(3,i) - jb + 2 ! covert it to the local grid - if( OI(i) < 1 .or. OI(i) > nlon ) write(6,*) 'read_Surface: Error in reading ii:',mype,OI(i),ib,jb - if( OJ(i) < 1 .or. OJ(i) > nlat ) write(6,*) 'read_Surface: Error in reading jj:',mype,OJ(i),ib,jb - Oelvtn(i) = data_s(4,i) - Odist(i) = data_s(23,i) - OIstation(i) = data_s(24,i) - OJstation(i) = data_s(25,i) - if(data_s(22,i) > 50 ) cycle ! do not use this data - VIS = data_s(5,i) -! cloud amonut and base height -! C 020011 -! 0 0 oktas (0/10) -! 1 1 okta or less, but not zero (1/10 or less, but not zero) -! 2 2 oktas (2/10 - 3/10) -! 3 3 oktas (4/10) -! 4 4 oktas (5/10) -! 5 5 oktas (6/10) -! 6 6 oktas (7/10 - 8/10) -! 7 7 oktas or more, but not 8 oktas (9/10 or more, but not 10/10) -! 8 8 oktas (10/10) -! 9 Sky obscured by fog and/or other meteorological phenomena -! 10 Sky partially obscured by fog and/or other meteorological phenomena -! 11 Scattered -! 12 Broken -! 13 Few -! 14 Reserved -! 15 Cloud cover is indiscernible for reasons other than -! fog or other meteorological phenomena, or observation is not made - - DO j=1,3 - cldamt = data_s(5+j,i) ! cloud amount - cldhgt = int(data_s(11+j,i)) ! cloud bottom height - if(cldamt < spval_p .and. cldhgt < spval_p) then - if(abs(cldamt-0._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=0 !msky='CLR' - cldhgt=spval_p - elseif(abs(cldamt-13._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=1 !msky='FEW' - elseif(abs(cldamt-11._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=2 !msky='SCT' - elseif(abs(cldamt-12._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=3 !msky='BKN' - elseif((abs(cldamt-8._r_kind) < 0.0001_r_kind) .or. & - (abs(cldamt-9._r_kind) < 0.0001_r_kind)) then - OCLD(j,i)=4 ! msky='OVC' msky='VV ' - elseif(abs(cldamt-1._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=1 - elseif(abs(cldamt-2._r_kind) < 0.0001_r_kind .or. & - abs(cldamt-3._r_kind) < 0.0001_r_kind ) then - OCLD(j,i)=2 - elseif(cldamt > 3.5_r_kind .and. cldamt < 6.5_r_kind ) then - OCLD(j,i)=3 - elseif(abs(cldamt-7._r_kind) < 0.0001_r_kind ) then - OCLD(j,i)=4 - else - OCLD(j,i) = spval_p ! wrong cloud observation type - cldhgt = spval_p - endif - if(cldhgt > 0.0_r_kind ) then - OCLD(6+j,i) = cldhgt - else - OCLD(j,i) = spval_p - OCLD(6+j,i) = spval_p - endif - else - OCLD(j,i) = 99 - OCLD(6+j,i) = spval_p - endif - enddo ! j -! weather - DO j=1,3 - awx = data_s(17+j,i) ! weather - mwx=' ' - if(awx>=10._r_kind .and.awx<=12._r_kind ) mwx='BR ' - if(awx>=110._r_kind.and.awx<=112._r_kind) mwx='BR ' - if(awx==5._r_kind .or. awx==105._r_kind) mwx='HZ ' - if(awx>=40._r_kind .and.awx<=49._r_kind ) mwx='FG ' - if(awx>=130._r_kind.and.awx<=135._r_kind) mwx='FG ' - if(awx>=50._r_kind .and.awx<=59._r_kind ) mwx='DZ ' - if(awx>=150._r_kind.and.awx<=159._r_kind) mwx='DZ ' - if(awx>=60._r_kind .and.awx<=69._r_kind ) mwx='RA ' - if(awx>=160._r_kind.and.awx<=169._r_kind) mwx='RA ' - if(awx>=70._r_kind .and.awx<=78._r_kind ) mwx='SN ' - if(awx>=170._r_kind.and.awx<=178._r_kind) mwx='SN ' - if(awx==79._r_kind .or. awx==179._r_kind) mwx='PE ' - - if(awx>=80._r_kind .and.awx<=90._r_kind ) mwx='SH ' - if(awx>=180._r_kind.and.awx<=187._r_kind) mwx='SH ' - if(awx>=91._r_kind .and.awx<=99._r_kind ) mwx='TH ' - if(awx>=190._r_kind.and.awx<=196._r_kind) mwx='TH ' - - if (j==1) start=1 - if (j==2) start=4 - if (j==3) start=7 - end=start+2 - OWX(i)(start:end)=mwx - enddo -! visiblity - IF(VIS > spval_P) then - OCLD(13,i)=spval_P - else - IF(VIS > 100.0_r_kind ) then - OCLD(13,i)=int(VIS) - elseif(VIS <=100.0_r_kind .and. VIS > 0.0_r_kind ) then - OCLD(13,i)=100 - write(6,*) 'read_Surface, Warning: change visibility to 100 m !!!' - ENDIF - endif - - ENDDO ! i = numsao -! - -END SUBROUTINE read_Surface - diff --git a/lib/GSD/gsdcloud/read_nasalarc_cld.f90 b/lib/GSD/gsdcloud/read_nasalarc_cld.f90 deleted file mode 100644 index cc82cb6c8..000000000 --- a/lib/GSD/gsdcloud/read_nasalarc_cld.f90 +++ /dev/null @@ -1,300 +0,0 @@ -SUBROUTINE read_NASALaRC(mype,lunin,numLaRC,istart,jstart, & - nlon,nlat,nasalarc) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_NASALaRC read in nasalarc cloud -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2009-09-21 -! -! ABSTRACT: -! This subroutine reads in nasalarc cloud products that are already mapped to -! analysis grid. -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! numLaRC - number of observation -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! -! output argument list: -! nasalarc - nasalarc cloud in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,i_kind, r_single - implicit none - - integer(i_kind),intent(in) :: lunin - integer(i_kind),intent(in) :: mype - INTEGER(i_kind),intent(in) :: numLaRC - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - - real(r_single), intent(out) :: nasalarc(nlon,nlat,5) -! -! local -! - real(r_kind),allocatable :: nasalarc_in(:,:) - - character(10) :: obstype - integer(i_kind):: nreal,nchanl,ilat1s,ilon1s - character(20) :: isis - - INTEGER(i_kind) :: i,j, ii,jj, k - INTEGER(i_kind) :: ib,jb - - REAL(r_kind) :: miss_obs_real - PARAMETER ( miss_obs_real = -99999.0_r_kind ) - -! - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - - ilon1s=1 - ilat1s=2 - - read(lunin) obstype,isis,nreal,nchanl - - allocate( nasalarc_in(nreal,numLaRC) ) - nasalarc_in=miss_obs_real - - read(lunin) nasalarc_in - DO i=1,numLaRC - ii=int(nasalarc_in(ilon1s,i)+0.001_r_kind) - ib + 2 - jj=int(nasalarc_in(ilat1s,i)+0.001_r_kind) - jb + 2 - if( ii < 1 .or. ii > nlon ) write(6,*) 'read_nasalarc_cld: ', & - 'Error in read in nasa ii:',mype,ii,jj,i,ib,jb - if( jj < 1 .or. jj > nlat ) write(6,*) 'read_nasalarc_cld: ', & - 'Error in read in nasa jj:',mype,ii,jj,i,ib,jb - DO k=1,2 - if(nasalarc_in(k+2,i) > 8888.0_r_kind ) then - nasalarc(ii,jj,k)=miss_obs_real - else - nasalarc(ii,jj,k)=nasalarc_in(k+2,i) ! k=1 w_pcld, 2=w_tcld - endif - enddo ! k - - if(nasalarc_in(5,i) > 8888.0_r_kind ) then - nasalarc(ii,jj,3)=miss_obs_real - else - nasalarc(ii,jj,3)=nasalarc_in(5,i)/100.0_r_kind ! w_frac - endif - - if(nasalarc_in(6,i) > 8888.0_r_kind) then - nasalarc(ii,jj,4)=miss_obs_real - else - nasalarc(ii,jj,4)=nasalarc_in(6,i)/1000.0_r_kind ! w_lwp - endif - - if(nasalarc_in(7,i) > 8888.0_r_kind ) then - nasalarc(ii,jj,5)=miss_obs_real - else - nasalarc(ii,jj,5)=nasalarc_in(7,i) ! nlv_cld - endif - ENDDO - deallocate(nasalarc_in) -! -! filling boundarys -! - DO k=1,5 - DO i=2,nlon-1 - nasalarc(i,1,k)=nasalarc(i,2,k) - nasalarc(i,nlat,k)=nasalarc(i,nlat-1,k) - enddo - DO j=2,nlat-1 - nasalarc(1,j,k)=nasalarc(2,j,k) - nasalarc(nlon,j,k)=nasalarc(nlon-1,j,k) - enddo - nasalarc(1,1,k)=nasalarc(2,2,k) - nasalarc(1,nlat,k)=nasalarc(2,nlat-1,k) - nasalarc(nlon,1,k)=nasalarc(nlon-1,2,k) - nasalarc(nlon,nlat,k)=nasalarc(nlon-1,nlat-1,k) - ENDDO - - -END SUBROUTINE read_NASALaRC - -SUBROUTINE read_map_nasalarc(mype,lunin,numobs,istart,jstart,nlon,nlat, & - nasalarc) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_map_nasalarc read in NASA LaRC cloud products and map them into analysis grid -! -! PRGMMR: Ming Hu & Terra Ladwig ORG: GSD/EMB DATE: 2015-04-30 -! -! ABSTRACT: -! This subroutine reads in global NASA LaRC cloud products and map them into analysis grid. -! -! PROGRAM HISTORY LOG: -! 2015-04-20 Hu This code is based on read_NESDIS -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! numobs - number of observation -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! -! output argument list: -! nasalarc - nasalarc cloud in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - integer(i_kind),intent(in) :: lunin - INTEGER(i_kind),intent(in) :: numobs - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - - real(r_single):: sat_ctp(nlon,nlat) ! cloud top pressure - real(r_single):: sat_tem(nlon,nlat) ! cloud top temperature - real(r_single):: w_frac(nlon,nlat) ! cloud fraction - real(r_single):: w_lwp(nlon,nlat) ! cloud fraction - integer(i_kind):: nlev_cld(nlon,nlat) ! cloud fraction - real(r_single):: nasalarc(nlon,nlat,5) -! - INTEGER(i_kind) :: nn_obs - real(r_kind),allocatable,dimension(:,:):: data_s - logical,allocatable,dimension(:):: luse -! -! misc. -! - character(10) :: obstype - integer(i_kind) :: mm1 - integer(i_kind) :: nreal,nchanl - character(20) :: isis - - INTEGER(i_kind) :: i, j - INTEGER(i_kind) :: ib, jb -! -! =============================================================== -! - - mm1=mype+1 - - read(lunin) obstype,isis,nreal,nchanl - nn_obs = nreal + nchanl - allocate(luse(numobs),data_s(nn_obs,numobs)) - read(lunin) data_s, luse - -! do i=1,numobs -! write(6,*)'sliu larcclddata::',mype,data_s(2,i),data_s(3,i) -! end do - -! write(6,*)'read_map_nasalarc::',mype, maxval(data_s(7,:)),numobs - - - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - call map_ctp_lar(mype,ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld) -!! -! filling boundarys -! - DO i=2,nlon-1 - sat_ctp(i,1) =sat_ctp(i,2) - sat_tem(i,1) =sat_tem(i,2) - w_frac(i,1) =w_frac(i,2) - w_lwp(i,1) =w_lwp(i,2) - nlev_cld(i,1) =nlev_cld(i,2) - sat_ctp(i,nlat)=sat_ctp(i,nlat-1) - sat_tem(i,nlat)=sat_tem(i,nlat-1) - w_frac(i,nlat) =w_frac(i,nlat-1) - w_lwp(i,nlat) =w_lwp(i,nlat-1) - nlev_cld(i,nlat) =nlev_cld(i,nlat-1) - enddo - DO j=2,nlat-1 - sat_ctp(1,j) =sat_ctp(2,j) - sat_tem(1,j) =sat_tem(2,j) - w_frac(1,j) =w_lwp(2,j) - w_lwp(1,j) =w_lwp(2,j) - nlev_cld(1,j) =nlev_cld(2,j) - sat_ctp(nlon,j)=sat_ctp(nlon-1,j) - sat_tem(nlon,j)=sat_tem(nlon-1,j) - w_frac(nlon,j) =w_frac(nlon-1,j) - w_lwp(nlon,j) =w_lwp(nlon-1,j) - nlev_cld(nlon,j) =nlev_cld(nlon-1,j) - enddo - sat_ctp(1,1) =sat_ctp(2,2) - sat_tem(1,1) =sat_tem(2,2) - w_frac(1,1) =w_frac(2,2) - w_lwp(1,1) =w_lwp(2,2) - nlev_cld(1,1) =nlev_cld(2,2) - - sat_ctp(1,nlat) =sat_ctp(2,nlat-1) - sat_tem(1,nlat) =sat_tem(2,nlat-1) - w_frac(1,nlat) =w_frac(2,nlat-1) - w_lwp(1,nlat) =w_lwp(2,nlat-1) - nlev_cld(1,nlat) =nlev_cld(2,nlat-1) - - sat_ctp(nlon,1) =sat_ctp(nlon-1,2) - sat_tem(nlon,1) =sat_tem(nlon-1,2) - w_frac(nlon,1) =w_frac(nlon-1,2) - w_lwp(nlon,1) =w_lwp(nlon-1,2) - nlev_cld(nlon,1) =nlev_cld(nlon-1,2) - - sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) - sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) - w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) - - do i=1,nlon - do j=1,nlat - nasalarc(i,j,1)=sat_ctp(i,j) - nasalarc(i,j,2)=sat_tem(i,j) - nasalarc(i,j,3)=w_frac(i,j) !/100.0 - nasalarc(i,j,4)=w_lwp(i,j) !/100.0 - nasalarc(i,j,5)=nlev_cld(i,j) -! if(abs(sat_tem(i,j))>0.and.abs(sat_tem(i,j))<400) then -! write(6,*)'sat_tem2 in read_cloud::',sat_ctp(i,j),sat_tem(i,j),nasalarc(i,j,1) -! end if - end do - end do - - -END SUBROUTINE read_map_nasalarc diff --git a/lib/GSD/gsdcloud/read_radar_ref.f90 b/lib/GSD/gsdcloud/read_radar_ref.f90 deleted file mode 100644 index 9f337a6ae..000000000 --- a/lib/GSD/gsdcloud/read_radar_ref.f90 +++ /dev/null @@ -1,106 +0,0 @@ -SUBROUTINE read_radar_ref(mype,lunin,istart,jstart, & - nlon,nlat,Nmsclvl,numref,ref_mosaic31) -! -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_NESDIS read in radar reflectivity -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-30 -! -! ABSTRACT: -! This subroutine read in radar reflectivity -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! numref - number of observation -! -! output argument list: -! Nmsclvl - vertical level of radar observation ref_mosaic31 -! ref_mosaic31- radar reflectivity horizontally in analysis grid and -! vertically in mosaic grid (height) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use kinds, only: r_kind,i_kind - implicit none - - INTEGER(i_kind),intent(in) :: mype - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: lunin - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - INTEGER(i_kind),intent(in) :: numref - - INTEGER(i_kind),intent(out):: Nmsclvl - real(r_kind), intent(out):: ref_mosaic31(nlon,nlat,31) -! -! local -! - real(r_kind),allocatable :: ref_in(:,:) - - character(10) :: obstype - integer(i_kind):: nreal,nchanl,ilat1s,ilon1s - character(20) :: isis - - INTEGER(i_kind) :: i, ii,jj, k - INTEGER(i_kind) :: ib,jb - -! - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - - read(lunin) obstype,isis,nreal,nchanl - - ilon1s=1 - ilat1s=2 - Nmsclvl = nreal - 2 - IF( Nmsclvl .ne. 21 .and. Nmsclvl .ne.31) then - write(6,*) ' read_radar_ref: ', & - 'vertical dimesion inconsistent when read in reflectivty mosaic' - write(6,*) 'read in:',Nmsclvl - write(6,*) 'need:', 21, 'or', 31 - call stop2(114) - ENDIF - allocate( ref_in(nreal,numref) ) - ref_mosaic31=-9999.0_r_kind - - read(lunin) ref_in - DO i=1,numref - ii=int(ref_in(ilon1s,i)+0.001_r_kind) - ib + 2 - jj=int(ref_in(ilat1s,i)+0.001_r_kind) - jb + 2 - if( ( ii >= 1 .and. ii <= nlon ) .and. & - ( jj >= 1 .and. jj <= nlat ) ) then - DO k=1,Nmsclvl - ref_mosaic31(ii,jj,k)=ref_in(2+k,i) - ENDDO - else - write(6,*) 'read_radar_ref: Error ii or jj:',mype,ii,jj,i,ib,jb - endif - ENDDO - deallocate(ref_in) - -END SUBROUTINE read_radar_ref diff --git a/lib/GSD/gsdcloud/smooth.f90 b/lib/GSD/gsdcloud/smooth.f90 deleted file mode 100644 index 73f620809..000000000 --- a/lib/GSD/gsdcloud/smooth.f90 +++ /dev/null @@ -1,98 +0,0 @@ - SUBROUTINE SMOOTH (FIELD,HOLD,IX,IY,SMTH) -!C$$$ SUBPROGRAM DOCUMENTATION BLOCK -!C . . . . -!C SUBPROGRAM: SMOOTH SMOOTH A METEOROLOGICAL FIELD -!C PRGMMR: STAN BENJAMIN ORG: FSL/PROFS DATE: 90-06-15 -!C -!C ABSTRACT: SHAPIRO SMOOTHER. -!C -!C PROGRAM HISTORY LOG: -!C 85-12-09 S. BENJAMIN ORIGINAL VERSION -!C -!C USAGE: CALL SMOOTH (FIELD,HOLD,IX,IY,SMTH) -!C INPUT ARGUMENT LIST: -!C FIELD - REAL ARRAY FIELD(IX,IY) -!C METEOROLOGICAL FIELD -!C HOLD - REAL ARRAY HOLD(IX,2) -!C HOLDING THE VALUE FOR FIELD -!C IX - INTEGER X COORDINATES OF FIELD -!C IY - INTEGER Y COORDINATES OF FIELD -!C SMTH - REAL -!C -!C OUTPUT ARGUMENT LIST: -!C FIELD - REAL ARRAY FIELD(IX,IY) -!C SMOOTHED METEOROLOGICAL FIELD -!C -!C REMARKS: REFERENCE: SHAPIRO, 1970: "SMOOTHING, FILTERING, AND -!C BOUNDARY EFFECTS", REV. GEOPHYS. SP. PHYS., 359-387. -!C THIS FILTER IS OF THE TYPE -!C Z(I) = (1-S)Z(I) + S(Z(I+1)+Z(I-1))/2 -!C FOR A FILTER WHICH IS SUPPOSED TO DAMP 2DX WAVES COMPLETELY -!C BUT LEAVE 4DX AND LONGER WITH LITTLE DAMPING, -!C IT SHOULD BE RUN WITH 2 PASSES USING SMTH (OR S) OF 0.5 -!C AND -0.5. -!C -!C ATTRIBUTES: -!C$$$ -!C********************************************************************** -!C********************************************************************** - - - use kinds, only: r_kind,i_kind,r_single - implicit none -!C********************************************************************** - INTEGER(i_kind),INTENT(IN) :: IX,IY - real(r_kind),intent(inout) :: FIELD(IX,IY) - real(r_kind),intent(inout) :: HOLD (IX,2) - real(r_kind),intent(in) :: SMTH -!C********************************************************************** - real(r_kind) :: SMTH1,SMTH2,SMTH3,SMTH4,SMTH5 - INTEGER(i_kind) :: I1,I2,I,J,IT - real(r_kind) :: SUM1,SUM2 - - SMTH1 = 0.25 * SMTH * SMTH - SMTH2 = 0.5 * SMTH * (1.-SMTH) - SMTH3 = (1.-SMTH) * (1.-SMTH) - SMTH4 = (1.-SMTH) - SMTH5 = 0.5 * SMTH - I1 = 2 - I2 = 1 - DO J=2,IY-1 - IT = I1 - I1 = I2 - I2 = IT - DO I = 2,IX-1 - SUM1 = FIELD (I-1,J+1) + FIELD (I-1,J-1) & - + FIELD (I+1,J+1) + FIELD (I+1,J-1) - SUM2 = FIELD (I ,J+1) + FIELD (I+1,J ) & - + FIELD (I ,J-1) + FIELD (I-1,J ) - HOLD(I,I1) = SMTH1*SUM1 + SMTH2*SUM2 + SMTH3*FIELD(I,J) - ENDDO - IF (J /= 2) THEN - DO I=2,IX-1 - FIELD(I,J-1) = HOLD(I,I2) - ENDDO - ENDIF - ENDDO - - - DO I = 2,IX-1 - FIELD (I,IY-1) = HOLD(I,I1) - ENDDO - - DO I = 2,IX-1 - FIELD(I,1) = SMTH4* FIELD(I,1) & - + SMTH5 * (FIELD(I-1,1) + FIELD(I+1,1)) - FIELD(I,IY) = SMTH4* FIELD(I,IY) & - + SMTH5 * (FIELD(I-1,IY) + FIELD(I+1,IY)) - ENDDO - - DO J = 2,IY-1 - FIELD(1,J) = SMTH4* FIELD(1,J) & - + SMTH5 * (FIELD(1,J-1) + FIELD(1,J+1)) - FIELD(IX,J) = SMTH4* FIELD(IX,J) & - + SMTH5 * (FIELD(IX,J-1) + FIELD(IX,J+1)) - ENDDO - - RETURN - END diff --git a/lib/GSD/gsdcloud/vinterp_radar_ref.f90 b/lib/GSD/gsdcloud/vinterp_radar_ref.f90 deleted file mode 100644 index 314aabd78..000000000 --- a/lib/GSD/gsdcloud/vinterp_radar_ref.f90 +++ /dev/null @@ -1,142 +0,0 @@ -SUBROUTINE vinterp_radar_ref(mype,nlon,nlat,nsig,Nmsclvl,ref_mos_3d,ref_mosaic31,h_bk,zh) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: interp_radar_ref radar observation vertical interpolation -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 -! -! ABSTRACT: -! This subroutine interpolate radar reflectivity vertically -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! Nmsclvl - vertical level of radar observation ref_mosaic31 -! ref_mosaic31- radar reflectivity horizontally in analysis grid and vertically -! in mosaic grid (height) -! h_bk - 3D background height -! zh - terrain -! -! output argument list: -! ref_mos_3d - 3D radar reflectivity in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use kinds, only: r_kind,i_kind, r_single - implicit none - - INTEGER(i_kind), intent(in) :: mype - INTEGER(i_kind), intent(in) :: nlon - INTEGER(i_kind), intent(in) :: nlat - INTEGER(i_kind), intent(in) :: nsig - INTEGER(i_kind), intent(in) :: Nmsclvl - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height - real(r_single), intent(in) :: zh(nlon,nlat) ! terrain - real(r_kind), intent(in) :: ref_mosaic31(nlon,nlat,Nmsclvl) - real(r_kind), intent(out):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid -! -! local -! - real(r_kind) :: msclvl21(21),msclvlAll(31) - DATA msclvl21/1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 6, 7, & - 8, 9, 10, 11, 12, 13, 14, 15, 16, 17/ - DATA msclvlAll/0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & - 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & - 9, 10, 11, 12, 13, 14, 15, 16, 18/ -! - REAL(r_kind) :: heightGSI,upref,downref,wght - INTEGER(i_kind) :: ilvl,numref - - real(r_kind) :: ref_mosaic - INTEGER(i_kind) :: i,j, k2, k - -! - if(Nmsclvl < -888 ) then - write(6,*) 'interp_radar_ref: No radar reflectivity data in this subdomain !' - return - endif -! - ref_mos_3d=-99999.0_r_kind - numref=0 - if (Nmsclvl == 31 ) then - DO k=1,Nmsclvl - msclvlAll(k)=msclvlAll(k)*1000.0_r_kind - ENDDO - elseif( Nmsclvl == 21 ) then - msclvlAll=0 - DO k=1,Nmsclvl - msclvlAll(k)=msclvl21(k)*1000.0_r_kind - ENDDO - else - write(6,*) 'interp_radar_ref: Wrong vertical radar mosaic levels' - write(6,*) ' the level read in is:', msclvlAll - call stop2(114) - endif - - DO k2=1,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - heightGSI=h_bk(i,j,k2)+zh(i,j) - if(heightGSI >= msclvlAll(1) .and. heightGSI < msclvlAll(Nmsclvl) ) then - do k=1,Nmsclvl-1 - if( heightGSI >=msclvlAll(k) .and. heightGSI < msclvlAll(k+1) ) ilvl=k - enddo - upref=ref_mosaic31(i,j,ilvl+1) - downref=ref_mosaic31(i,j,ilvl) - if(abs(upref) <90.0_r_kind .and. abs(downref) <90.0_r_kind ) then - wght=(heightGSI-msclvlAll(ilvl))/(msclvlAll(ilvl+1)-msclvlAll(ilvl)) - ref_mosaic=(1-wght)*downref + wght*upref - numref=numref+1 - elseif( abs(upref+99.0_r_kind) < 0.1_r_kind .or. & - abs(downref+99.0_r_kind) <0.1_r_kind ) then - ref_mosaic=-99.0_r_kind - else - ref_mosaic=-99999.0_r_kind - endif - ref_mos_3d(i,j,k2)=max(ref_mos_3d(i,j,k2),ref_mosaic) - else - ref_mos_3d(i,j,k2)=-99999.0_r_kind - endif - ENDDO - ENDDO - ENDDO - -! - DO k2=1,nsig - DO i=2,nlon-1 - ref_mos_3d(i,1,k2)=ref_mos_3d(i,2,k2) - ref_mos_3d(i,nlat,k2)=ref_mos_3d(i,nlat-1,k2) - ENDDO - DO j=2,nlat-1 - ref_mos_3d(1,j,k2)=ref_mos_3d(2,j,k2) - ref_mos_3d(nlon,j,k2)=ref_mos_3d(nlon-1,j,k2) - ENDDO - ref_mos_3d(nlon,nlat,k2)=ref_mos_3d(nlon-1,nlat-1,k2) - ref_mos_3d(nlon,1,k2)=ref_mos_3d(nlon-1,2,k2) - ref_mos_3d(1,nlat,k2)=ref_mos_3d(2,nlat-1,k2) - ref_mos_3d(1,j,k2)=ref_mos_3d(2,2,k2) - ENDDO - - -END SUBROUTINE vinterp_radar_ref diff --git a/lib/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 b/lib/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 deleted file mode 100755 index 7017e9e80..000000000 --- a/lib/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 +++ /dev/null @@ -1,1405 +0,0 @@ -! -!$$$ subprogram documentation block -! . . . . -! subprogram: ARPS_cldLib -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: -! -! ABSTRACT: -! This file include a collection of subroutines that are related to -! cloud analysis from ARPS cloud analysis -! -! PROGRAM HISTORY LOG: -! 2009-01-02 Hu Add NCO document block -! -! -! input argument list: -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! -! -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_STABILITY ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_stability (nz,t_1d,zs_1d,p_mb_1d,kbtm,ktop & - ,dte_dz_1d) -! -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! This routine returns stability at a given level given -! 1D temperature and pressure array inputs -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on LAPS cloud analysis code of 07/95 -! -! MODIFICATION HISTORY: -! -! 05/11/96 (J. Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - integer(i_kind),INTENT(IN) :: nz ! number of vertical model levels - REAL(r_single) ,INTENT(IN) :: t_1d(nz) ! temperature (degree Kelvin) profile - REAL(r_single) ,INTENT(IN) :: zs_1d(nz) ! heights (m MSL) of each level - REAL(r_single) ,INTENT(IN) :: p_mb_1d(nz)! pressure (mb) at each level - INTEGER(i_kind),INTENT(IN) :: kbtm,ktop ! indices of the bottom and top cloud layer -! -! OUTPUT: - REAL(r_single) ,INTENT(out):: dte_dz_1d(nz) ! stability array -! -! LOCAL: - REAL(r_single) :: thetae_1d(nz) ! (equivalent) potential temperature. -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind) :: k,km1,kp1,klow,khigh - REAL(r_single) :: os_fast -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Calculate Stability -! -!----------------------------------------------------------------------- -! - klow = MAX(kbtm-1,1) - khigh = MIN(ktop+1,nz-1) - - DO k = klow,khigh - thetae_1d(k) = os_fast(t_1d(k), p_mb_1d(k)) - END DO ! k - - dte_dz_1d=0._r_kind - - DO k = kbtm,ktop - km1 = MAX(k-1,1) - kp1 = MIN(k+1,nz-1) - - IF( (zs_1d(kp1) - zs_1d(km1)) <= 0._r_kind) THEN - write(6,*) 'GNRLCLD_mpi, get_stability: Error in get_stability ' - write(6,*) 'GNRLCLD_mpi, get_stability: k,kp1,km1 = ',k,kp1,km1 - write(6,*) 'GNRLCLD_mpi, get_stability: zs_1d(kp1),zs_1d(km1)= ',zs_1d(kp1),zs_1d(km1), & - (zs_1d(kp1) - zs_1d(km1)) - call STOP2(114) - ELSE - dte_dz_1d(k) = (thetae_1d(kp1) - thetae_1d(km1)) & - / (zs_1d(kp1) - zs_1d(km1)) - END IF - END DO ! k - - RETURN -END SUBROUTINE get_stability - - -! -!################################################################## -!################################################################## -!###### ###### -!###### FUNCTION OS_FAST ###### -!###### ###### -!################################################################## -!################################################################## -! - - FUNCTION os_fast(tk,p) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! THIS FUNCTION RETURNS THE EQUIVALENT POTENTIAL TEMPERATURE OS -! (K) FOR A PARCEL OF AIR SATURATED AT TEMPERATURE T (K) -! AND PRESSURE P (MILLIBARS). -! -! -!----------------------------------------------------------------------- -! -! AUTHOR: (BAKER,SCHLATTER) -! 05/17/1982 -! -! -! MODIFICATION HISTORY: -! 05/11/96 (Jian Zhang) -! Modified for ADAS grid. Add document stuff. -! -!----------------------------------------------------------------------- -! -! Variables declaration -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - REAL(r_single) ,INTENT(IN) :: tk ! temperature in kelvin - REAL(r_single) ,INTENT(IN) :: p ! pressure in mb -! -! OUTPUT: - REAL(r_single) :: os_fast ! equivalent potential temperature -! -! LOCAL: - REAL(r_kind) :: b ! empirical const. approx.= latent heat of - ! vaporiz'n for water devided by the specific - ! heat at const. pressure for dry air. - DATA b/2.6518986_r_kind/ - - REAL(r_kind) :: tc,x,w - REAL(r_kind) :: eslo -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - tc = tk - 273.15_r_kind -! -!----------------------------------------------------------------------- -! -! From W routine -! -!----------------------------------------------------------------------- -! - x= eslo(tc) - w= 622._r_kind*x/(p-x) - - os_fast= tk*((1000._r_kind/p)**.286_r_kind)*(EXP(b*w/tk)) - - RETURN - END FUNCTION os_fast - - - -! -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_CLOUDTYPE ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_cloudtype(temp_k,dte_dz,cbase_m,ctop_m & - ,itype,c2_type) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! This routine returns cloud type at a given point given -! temperature and stability inputs -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on the LAPS cloud analysis code of 05/1995 -! -! MODIFICATION HISTORY: -! -! 05/11/96 (J. Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - REAL(r_single),INTENT(IN) :: temp_k ! temperature - REAL(r_single),INTENT(IN) :: dte_dz ! stability factor - REAL(r_single),INTENT(IN) :: cbase_m ! height at cloud base level - REAL(r_single),INTENT(IN) :: ctop_m ! height at cloud top level -! -! OUTPUT: - INTEGER(i_kind),INTENT(out):: itype ! cloud type index - CHARACTER (LEN=2) :: c2_type -! -! LOCAL: - CHARACTER (LEN=2) :: c2_cldtyps(10) - - DATA c2_cldtyps /'St','Sc','Cu','Ns','Ac' & - ,'As','Cs','Ci','Cc','Cb'/ -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - REAL(r_kind) :: depth_m,temp_c -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - temp_c = temp_k - 273.15_r_kind - depth_m = ctop_m - cbase_m -! -!----------------------------------------------------------------------- -! -! Go from Stability to Cloud Type -! -!----------------------------------------------------------------------- -! - IF ( temp_c >= -10._r_kind) THEN - IF (dte_dz >= +.001_r_kind) THEN - itype = 1 ! St - ELSE IF (dte_dz < +.001_r_kind .AND. dte_dz >= -.001_r_kind) THEN - itype = 2 ! Sc - ELSE IF (dte_dz < -.001_r_kind .AND. dte_dz >= -.005_r_kind) THEN - itype = 3 ! Cu - ELSE ! dte_dz .lt. -.005 - IF(depth_m > 5000) THEN - itype = 10 ! Cb - ELSE ! depth < 5km - itype = 3 ! Cu - END IF - END IF - - ELSE IF (temp_c < -10._r_kind .AND. temp_c >= -20._r_kind) THEN - - IF (dte_dz < 0._r_kind) THEN - IF(depth_m > 5000) THEN - itype = 10 ! Cb - ELSE - itype = 5 ! Ac - END IF - ELSE - itype = 6 ! As - END IF - - ELSE ! temp_c.lt.-20. - - IF (dte_dz >= +.0005_r_kind) THEN - itype = 7 ! Cs - ELSE IF (dte_dz < +.0005_r_kind .AND. dte_dz >= -.0005_r_kind) THEN - itype = 8 ! Ci - ELSE ! dte_dz .lt. -.0005 - itype = 9 ! Cc - END IF - - IF(depth_m > 5000 .AND. dte_dz < -.0000_r_kind) THEN - itype = 10 ! Cb - END IF - - END IF - - c2_type = c2_cldtyps(itype) - - RETURN -END SUBROUTINE get_cloudtype - -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_SFM_1D ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_sfm_1d (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & - l_prt) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -!c----------------------------------------------------------------- -!c -!c This is the streamlined version of the Smith-Feddes -!c and Temperature Adjusted LWC calculation methodologies -!c produced at Purdue University under sponsorship -!c by the FAA Technical Center. -!c -!c Currently, this subroutine will only use the Smith- -!c Feddes and will only do so as if there are solely -!c stratiform clouds present, however, it is very easy -!c to switch so that only the Temperature Adjusted -!c method is used. -!c -!c Dilution by glaciation is also included, it is a -!c linear function of in cloud temperature going from -!c all liquid water at -10 C to all ice at -30 C -!c as such the amount of ice is also calculated -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on the LAPS cloud analysis code of 07/1995 -! -! MODIFICATION HISTORY: -! -! 05/16/96 (Jian Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind - IMPLICIT NONE -! -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind),intent(in) :: nz ! number of model vertical levels - REAL(r_single),intent(in) :: zs_1d(nz) ! physical height (m) at each scalar level - REAL(r_single),intent(in) :: p_mb_1d(nz)! pressure (mb) at each level - REAL(r_single),intent(in) :: t_1d(nz) ! temperature (K) at each level - - REAL(r_single),intent(in) :: zcb ! cloud base height (m) - REAL(r_single),intent(in) :: zctop ! cloud top height (m) -! -! OUTPUT: - REAL(r_single),intent(out) :: ql(nz) ! liquid water content (g/kg) - REAL(r_single),intent(out) :: qi(nz) ! ice water content (g/kg) - REAL(r_single),intent(out) :: cldt(nz) -! -! LOCAL: - REAL(r_single) :: calw(200) - REAL(r_single) :: cali(200) - REAL(r_single) :: catk(200) - REAL(r_single) :: entr(200) -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - REAL(r_single) :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso - REAL(r_single) :: c,a1,b1,c1,a2,b2,c2 - REAL(r_single) :: delz,delt,cldbtm,cldbp,cldtpt,tbar - REAL(r_single) :: arg,fraclw,tlwc - REAL(r_single) :: temp,press,zbase,alw,zht,ht,y - REAL(r_single) :: rl,es,qvs1,p,des,dtz,es2,qvs2 - INTEGER(i_kind):: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 - REAL(r_single) :: dtdz,dttdz,zcloud,entc,tmpk - LOGICAL :: l_prt -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Initialize 1d liquid water and ice arrays (for 100m layers) -! -!----------------------------------------------------------------------- -! - DO i=1,200 - calw(i)=0.0_r_single - cali(i)=0.0_r_single - END DO -! if(i_prt.le.20) then -! i_prt=i_prt+1 -! l_prt=.true. -! else -! l_prt=.false. -! endif -! -!----------------------------------------------------------------------- -! -! Preset some constants and coefficients. -! -!----------------------------------------------------------------------- -! - dz=100.0_r_single ! m - rv=461.5_r_single ! J/deg/kg - rair=287.04_r_single ! J/deg/kg - grav=9.81_r_single ! m/s2 - cp=1004._r_single ! J/deg/kg - rlvo=2.5003E+6_r_single ! J/kg - rlso=2.8339E+6_r_single ! J/kg - dlvdt=-2.3693E+3_r_single ! J/kg/K - eso=610.78_r_single ! pa - c=0.01_r_single - a1=8.4897_r_single - b1=-13.2191_r_single - c1=4.7295_r_single - a2=10.357_r_single - b2=-28.2416_r_single - c2=8.8846_r_single -! -!----------------------------------------------------------------------- -! -! Calculate indices of cloud top and base -! -!----------------------------------------------------------------------- -! - DO k=1,nz-1 - IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN - kcb=k - kcb1=kcb+1 - END IF - IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN - kctop=k - kctop1=kctop+1 - END IF - END DO -! -!----------------------------------------------------------------------- -! -! Obtain cloud base and top conditions -! -!----------------------------------------------------------------------- -! - delz = zs_1d(kcb+1)-zs_1d(kcb) - delt = t_1d(kcb+1)-t_1d(kcb) - cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) - tbar = (cldbtm+t_1d(kcb))/2._r_single - arg = -grav*(zcb-zs_1d(kcb))/rair/tbar - cldbp = p_mb_1d(kcb)*EXP(arg) - delz = zs_1d(kctop+1)-zs_1d(kctop) - delt = t_1d(kctop+1)-t_1d(kctop) - cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) -! -!----------------------------------------------------------------------- -! -! Calculate cloud lwc profile for cloud base/top pair -! -!----------------------------------------------------------------------- -! - temp = cldbtm - press = cldbp*100.0_r_single - zbase = zcb - nlevel = ((zctop-zcb)/100.0_r_single)+1 - IF(nlevel <= 0) nlevel=1 - alw = 0.0_r_single - calw(1)= 0.0_r_single - cali(1)= 0.0_r_single - catk(1)= temp - entr(1)= 1.0_r_single - nlm1 = nlevel-1 - IF(nlm1 < 1) nlm1=1 - zht = zbase - - DO j=1,nlm1 - rl = rlvo+(273.15_r_single-temp)*dlvdt - arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv - es = eso*EXP(arg) - qvs1 = 0.622_r_single*es/(press-es) -! rho1 = press/(rair*temp) - arg = -grav*dz/rair/temp - p = press*EXP(arg) -! -!----------------------------------------------------------------------- -! -! Calculate saturated adiabatic lapse rate -! -!----------------------------------------------------------------------- -! - des = es*rl/temp/temp/rv - dtz = -grav*((1.0_r_single+0.621_r_single*es*rl/(press*rair*temp))/ & - (cp+0.621_r_single*rl*des/press)) - zht = zht+dz - press = p - temp = temp+dtz*dz - rl = rlvo+(273.15_r_single-temp)*dlvdt - arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv - es2 = eso*EXP(arg) - qvs2 = 0.622_r_single*es2/(press-es2) - - alw = alw+(qvs1-qvs2) ! kg/kg - calw(j+1) = alw -! -!----------------------------------------------------------------------- -! -! Reduction of lwc by entrainment -! -!----------------------------------------------------------------------- -! - ht = (zht-zbase)*.001_r_single -! -!c ------------------------------------------------------------------ -!c -!c skatskii's curve(convective) -!c -!c ------------------------------------------------------------------ -!c if(ht.lt.0.3) then -!c y = -1.667*(ht-0.6) -!c elseif(ht.lt.1.0) then -!c arg1 = b1*b1-4.0*a1*(c1-ht) -!c y = (-b1-sqrt(arg1))/(2.0*a1) -!c elseif(ht.lt.2.9) then -!c arg2 = b2*b2-4.0*a2*(c2-ht) -!c y = (-b2-sqrt(arg2))/(2.0*a2) -!c else -!c y = 0.26 -!c endif -!c -!c ------------------------------------------------------------------ -!c -!c warner's curve(stratiform) -!c -!c ------------------------------------------------------------------ - IF(ht < 0.032_r_single) THEN - y = -11.0_r_single*ht+1.0_r_single ! y(ht=0.032) = 0.648 - ELSE IF(ht <= 0.177_r_single) THEN - y = -1.4_r_single*ht+0.6915_r_single ! y(ht=0.177) = 0.4437 - ELSE IF(ht <= 0.726_r_single) THEN - y = -0.356_r_single*ht+0.505_r_single ! y(ht=0.726) = 0.2445 - ELSE IF(ht <= 1.5_r_single) THEN - y = -0.0608_r_single*ht+0.2912_r_single ! y(ht=1.5) = 0.2 - ELSE - y = 0.20_r_single - END IF -! -!----------------------------------------------------------------------- -! -! Calculate reduced lwc by entrainment and dilution -! -! Note at -5 C and warmer, all liquid. ! changed from -10 KB -! at -25 C and colder, all ice ! changed from -30 KB -! Linear ramp between. -! -!----------------------------------------------------------------------- -! - IF(temp < 268.15_r_single) THEN - IF(temp > 248.15_r_single) THEN - fraclw=0.05*(temp-248.15_r_single) - ELSE - fraclw=0.0_r_single - END IF - ELSE - fraclw=1.0_r_single - END IF - - tlwc=1000._r_single*y*calw(j+1) ! g/kg - calw(j+1)=tlwc*fraclw - cali(j+1)=tlwc*(1._r_single-fraclw) - catk(j+1)=temp - entr(j+1)=y - - END DO -! -!----------------------------------------------------------------------- -! -! Obtain profile of LWCs at the given grid point -! -!----------------------------------------------------------------------- -! - DO ip=2,nz-1 - IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN - ql(ip)=0.0_r_single - qi(ip)=0.0_r_single - cldt(ip)=t_1d(ip) - ELSE - DO j=2,nlevel - zcloud = zcb+(j-1)*dz - IF(zcloud >= zs_1d(ip)) THEN - ql(ip) = (zs_1d(ip)-zcloud+100._r_single)* & - (calw(j)-calw(j-1))*0.01_r_single+calw(j-1) - qi(ip) = (zs_1d(ip)-zcloud+100._r_single)* & - (cali(j)-cali(j-1))*0.01_r_single+cali(j-1) - tmpk = (zs_1d(ip)-zcloud+100._r_single)* & - (catk(j)-catk(j-1))*0.01_r_single & - +catk(j-1) - entc = (zs_1d(ip)-zcloud+100._r_single)* & - (entr(j)-entr(j-1))*0.01_r_single & - +entr(j-1) - cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk - - EXIT - END IF - END DO - END IF - END DO -! - RETURN -END SUBROUTINE get_sfm_1d - - -! -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE PCP_TYPE_3D ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE pcp_type_3d (nx,ny,nz,temp_3d,rh_3d,p_pa_3d & - ,radar_3d,l_mask,cldpcp_type_3d,istatus) - -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! This routine returns 3D cloud and precipitation type field. -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/1996 Based on the LAPS cloud analysis code developed by -! Steve Albers. -! -! This program modifies the most significant 4 bits of the integer -! array by inserting multiples of 16. -! -! MODIFICATION HISTORY: -! -! 05/16/96 (J. Zhang) -! Modified for ADAS format. Added full documentation. -! 01/20/98 (J. Zhang) -! Fixed a bug that no precip. type was assigned for a -! grid point at the top of the radar echo with Tw -! falling in the range of 0 to 1.3 degree C. -! 01/21/98 (J. Zhang) -! Fixed a bug that does the freezing/refreezing test -! on ice precipitates. -! 02/17/98 (J. Zhang) -! Change the hail diagnose procedure. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind, r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind), intent(in) :: nx,ny,nz ! Model grid size - REAL(r_single), intent(in) :: temp_3d(nx,ny,nz) ! temperature (K) - REAL(r_single), intent(in) :: rh_3d(nx,ny,nz) ! relative humudity - REAL(r_single), intent(in) :: p_pa_3d(nx,ny,nz) ! pressure (Pascal) - REAL(r_kind), intent(in) :: radar_3d(nx,ny,nz) ! radar refl. (dBZ) -! -! OUTPUT: - INTEGER(i_kind), intent(out) :: istatus - INTEGER(i_kind), intent(out) :: cldpcp_type_3d(nx,ny,nz)! cld/precip type - LOGICAL :: l_mask(nx,ny) ! "Potential" Precip Type -! -! LOCAL functions: - REAL(r_kind) :: wb_melting_thres ! define melting temp. thresh. - REAL(r_kind) :: tw ! for wet-bulb temp calcl'n -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind) :: itype ! cld/precip type index - INTEGER(i_kind) :: i,j,k,k_upper - REAL(r_kind) :: t_c,td_c,t_wb_c,temp_lower_c,temp_upper_c,tbar_c & - ,p_mb,thickns,frac_below_zero - INTEGER(i_kind) :: iprecip_type,iprecip_type_last,iflag_melt & - ,iflag_refreez - REAL(r_kind) :: zero_c,rlayer_refreez_max,rlayer_refreez - INTEGER(i_kind) :: n_zr,n_sl,n_last - REAL(r_kind) :: tmelt_c,x -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -!----------------------------------------------------------------------- -! - return - istatus=0 - wb_melting_thres = 1.3 ! Units are C -! -!----------------------------------------------------------------------- -! -! Stuff precip type into cloud type array -! 0 - No Precip -! 1 - Rain -! 2 - Snow -! 3 - Freezing Rain -! 4 - Sleet -! 5 - Hail -! -!----------------------------------------------------------------------- -! - zero_c = 273.15_r_kind - rlayer_refreez_max = 0.0_r_kind - - n_zr = 0 - n_sl = 0 - n_last = 0 - - DO j = 1,ny-1 - DO i = 1,nx-1 - - iflag_melt = 0 - iflag_refreez = 0 - rlayer_refreez = 0.0_r_kind - - iprecip_type_last = 0 - - DO k = nz-1,1,-1 - - IF(radar_3d(i,j,k) >= 0._r_kind.OR. l_mask(i,j)) THEN -! -!----------------------------------------------------------------------- -! -! Set refreezing flag -! -!----------------------------------------------------------------------- -! - t_c = temp_3d(i,j,k) - zero_c -! compute dew point depression. -! td_c = dwpt(t_c,rh_3d(i,j,k)) - x = 1._r_kind-0.01_r_kind*rh_3d(i,j,k) - td_c =t_c-(14.55_r_kind+0.114_r_kind*t_c)*x+ & - ((2.5_r_kind+0.007_r_kind*t_c)*x)**3+ & - (15.9_r_kind+0.117_r_kind*t_c)*x**14 - - p_mb = 0.01_r_kind*p_pa_3d(i,j,k) - - tmelt_c = wb_melting_thres - t_wb_c = tw(t_c,td_c,p_mb) - - IF(t_wb_c < 0._r_kind) THEN - IF(iflag_melt == 1) THEN -! -!----------------------------------------------------------------------- -! -! Integrate below freezing temperature times column thickness -! - ONLY for portion of layer below freezing -! -!----------------------------------------------------------------------- -! - temp_lower_c = t_wb_c - k_upper = MIN(k+1,nz-1) -! -!----------------------------------------------------------------------- -! -! For simplicity and efficiency, the assumption is here made that -! the wet bulb depression is constant throughout the level. -! -!----------------------------------------------------------------------- -! - temp_upper_c = t_wb_c + ( temp_3d(i,j,k_upper) & - - temp_3d(i,j,k)) - IF(temp_upper_c <= 0._r_kind) THEN - frac_below_zero = 1.0_r_kind - tbar_c = 0.5_r_kind * (temp_lower_c + temp_upper_c) - - ELSE ! Layer straddles the freezing level - frac_below_zero = temp_lower_c & - / (temp_lower_c - temp_upper_c) - tbar_c = 0.5_r_kind * temp_lower_c - - END IF - - thickns = p_pa_3d(i,j,k_upper) - p_pa_3d(i,j,k) - rlayer_refreez = rlayer_refreez & - + ABS(tbar_c * thickns * frac_below_zero) - - IF(rlayer_refreez >= 25000._r_kind) THEN - iflag_refreez = 1 - END IF - - rlayer_refreez_max = & - MAX(rlayer_refreez_max,rlayer_refreez) - - END IF ! iflag_melt = 1 - - ELSE ! Temp > 0C - iflag_refreez = 0 - rlayer_refreez = 0.0 - - END IF ! T < 0.0c, Temp is below freezing -! -!----------------------------------------------------------------------- -! -! Set melting flag -! -!----------------------------------------------------------------------- -! - IF(t_wb_c >= tmelt_c) THEN - iflag_melt = 1 - END IF - - IF(t_wb_c >= tmelt_c) THEN ! Melted to Rain - iprecip_type = 1 - - ELSE ! Check if below zero_c (Refrozen Precip or Snow) - IF(t_wb_c < 0.0_r_kind) THEN - IF(iflag_melt == 1) THEN - IF(iprecip_type_last == 1 .OR.iprecip_type_last == 3) THEN - ! test if rain or zr freeze - IF(iflag_refreez == 0) THEN ! Freezing Rain - n_zr = n_zr + 1 - IF(n_zr < 30) THEN -! WRITE(6,5)i,j,k,t_wb_c,temp_3d(i,j,k) & -! ,rh_3d(i,j,k) - 5 FORMAT('zr',3I3,2F8.2,f8.1) - END IF - iprecip_type = 3 - - ELSE ! (iflag_refreez = 1) ! Sleet - n_sl = n_sl + 1 - iprecip_type = 4 - END IF ! iflag_refreez .eq. 0 - ELSE - iprecip_type = iprecip_type_last ! Unchanged - n_last = n_last + 1 - IF(n_last < 5) THEN -! WRITE(6,*)'Unchanged Precip',i,j,k,t_wb_c - END IF - END IF ! liquid precip. at upper level? - - ELSE ! iflag_melt =0 ! Snow - iprecip_type = 2 - - END IF ! iflag_melt = 1? - ELSE ! t_wb_c >= 0c, and t_wb_c < tmelt_c - - IF (iprecip_type_last == 0) THEN ! 1/20/98 - iprecip_type = 1 ! rain:at echo top and 0= tmelt_c - - ELSE ! radar_3d < 0dBZ; No Radar Echo - iprecip_type = 0 - iflag_melt = 0 - iflag_refreez = 0 - rlayer_refreez = 0.0_r_kind - - END IF ! radar_3d(i,j,k).ge.0. .or. l_mask(i,j); Radar Echo? -! -!----------------------------------------------------------------------- -! -! Insert most sig 4 bits into array -! -!----------------------------------------------------------------------- -! - itype = cldpcp_type_3d(i,j,k) - itype = itype - (itype/16)*16 ! Initialize the 4 bits - itype = itype + iprecip_type * 16 ! Add in the new value - cldpcp_type_3d(i,j,k) = itype - - iprecip_type_last = iprecip_type - - END DO ! k - END DO ! j - END DO ! i - - DO j = 1,ny-1 - DO i = 1,nx-1 - DO k = 1,nz-1 - IF(radar_3d(i,j,k) >= 50._r_kind) THEN - iprecip_type = 5 - itype = cldpcp_type_3d(i,j,k) - itype = itype - (itype/16)*16 ! Initialize the 4 bits - itype = itype + iprecip_type * 16 ! Add in the new value - cldpcp_type_3d(i,j,k) = itype - END IF - END DO ! k - END DO ! j - END DO ! i - - istatus=1 - - RETURN -END SUBROUTINE pcp_type_3d - -! -! -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_SLWC1D ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_slwc1d (nk,cbase_m,ctop_m,kbase,ktop & - ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) - -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! This routine calls a subroutine "lwc_rep" which calculates -! the adiabatic liquid water content. -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on the LAPS cloud analysis code of 07/1995 -! -! MODIFICATION HISTORY: -! -! 05/13/96 (Jian Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind),intent(in) :: iflag_slwc ! indicator for LWC scheme option - INTEGER(i_kind),intent(in) :: nk ! number of model vertical levels - REAL(r_single),intent(in) :: t_1d(nk) ! temperature (k) in one model column - REAL(r_single),intent(in) :: zs_1d(nk) ! heights (m) at grd pts in one model column - REAL(r_single),intent(in) :: p_pa_1d(nk) ! pressure (pa) in one model column - REAL(r_single),intent(in) :: cbase_m,ctop_m ! heights (m) of cloud base and top levels - INTEGER(i_kind),intent(in) :: kbase,ktop ! vertical index of cloud base and top levels -! -! OUTPUT: - REAL(r_single),intent(out) :: slwc_1d(nk) ! estimated adiabatic liquid water -! -! LOCAL: - INTEGER(i_kind) :: i_status1,i_status2 ! flag for subroutine calling -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind):: k - REAL(r_single) :: p_low,p_high,cbase_pa,cbase_k,ctop_k,frac_k & - ,grid_top_pa,grid_top_k - REAL(r_single) :: fraction,thickness,dlog_space - REAL(r_single) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Initialize -! -!----------------------------------------------------------------------- -! - DO k = 1,nk - slwc_1d(k) = 0.0_r_single - END DO - - IF(ctop_m > cbase_m) THEN -! -!----------------------------------------------------------------------- -! -! Determine Lowest and Highest Grid Points within the cloud -! -!----------------------------------------------------------------------- -! - IF(ktop >= kbase .AND. kbase >= 2) THEN -! -!----------------------------------------------------------------------- -! -! Get cloud base pressure and temperature -! -!----------------------------------------------------------------------- -! - cbase_pa = -999._r_single ! Default value is off the grid - DO k = 1,nk-2 - IF(zs_1d(k+1) > cbase_m .AND. zs_1d(k) <= cbase_m) THEN - thickness = zs_1d(k+1) - zs_1d(k) - fraction = (cbase_m - zs_1d(k))/thickness - p_low = p_pa_1d(k) - p_high = p_pa_1d(k+1) - dlog_space = LOG(p_high/p_low) - cbase_pa = p_low * EXP(dlog_space*fraction) - END IF - END DO ! k - - frac_k=(cbase_m-zs_1d(kbase-1))/(zs_1d(kbase)-zs_1d(kbase-1)) - IF(frac_k /= fraction) & - PRINT*,' **GET_SLWC1D** frac=',fraction,' frac_k=',frac_k - - cbase_k = t_1d(kbase-1)*(1.0_r_single-frac_k) + t_1d(kbase)*frac_k -! -!----------------------------------------------------------------------- -! -! Get cloud top temperature -! -!----------------------------------------------------------------------- -! - frac_k = (ctop_m-zs_1d(ktop-1)) / (zs_1d(ktop)-zs_1d(ktop-1)) - ctop_k = t_1d(ktop-1)*(1.0_r_single - frac_k) + t_1d(ktop) * frac_k -! -!----------------------------------------------------------------------- -! -! Calculate SLWC at each vertical grid point. For each level -! we use an assumed cloud extending from the actual cloud base -! to the height of the grid point in question. -! -!----------------------------------------------------------------------- -! - DO k=kbase,ktop - grid_top_pa = p_pa_1d(k) - grid_top_k = t_1d(k) - - CALL slwc_revb(cbase_pa,cbase_k & - ,grid_top_pa,grid_top_k,ctop_k & - ,adiabatic_lwc,adjusted_lwc,adjusted_slwc & - ,i_status1,i_status2) -! - IF(i_status2 == 1) THEN - IF(iflag_slwc == 1) THEN - slwc_1d(k) = adiabatic_lwc - ELSE IF(iflag_slwc == 2) THEN - slwc_1d(k) = adjusted_lwc - ELSE IF(iflag_slwc == 3) THEN - slwc_1d(k) = adjusted_slwc - END IF - ELSE - WRITE(6,*)' Error Detected in SLWC' - END IF - END DO ! k - END IF ! ktop > kbase & kbase > 2, thick enough cloud exists - END IF ! ctop_m > cbase_m, cloud exists - - RETURN -END SUBROUTINE get_slwc1d - -SUBROUTINE slwc_revb(cb_pa,cb_k,gt_pa,gt_k,ct_k, & - adiabatic_lwc,adjusted_lwc,adjusted_slwc, & - i_status1,i_status2) -! -!.......................HISTORY............................. -! -! WRITTEN: CA. 1982 BY W. A. COOPER IN HP FORTRAN 4 -! -!....... CALCULATES TEMPERATURE T AND LIQUID WATER CONTENT FROM -!.. CLOUD BASE PRESSURE P0 AND TEMPERATURE T0, FOR ADIABATIC -!.. ASCENT TO THE PRESSURE P. -!.. -> INPUT: CLOUD BASE PRESSURE P0 AND TEMPERATURE T0 -!.. PRESSURE AT OBSERVATION LEVEL P -!.. -> OUTPUT: "ADIABATIC" TEMPERATURE T AND LIQUID WATER CONTENT -! -! MODIFIED: November 1989 by Paul Lawson for LAPS/WISP. Routine -! now calculates adiabatic liquid water content -! (ADIABATIC_LWC) using cloud base pressure and grid-top -! temperature and pressure. Also calculated are ADJUSTED_LWC, -! which adjusts ADIABATIC_LWC using an empirical cloud -! water depletion algorithm, and ADJUSTED_SLWC, which is -! ADIABATIC_LWC in regions where T < 0 C adjusted -! using an empirical algorithm by Marcia Politovich. -! -! Subroutine is now hardwired for stratiform cloud only. -! Can be modified to include Cu with input from LAPS main. -! -! revb: ca 12/89 Calculate adiabatic lwc by going from cloud -! base to LAPS grid level instead to cloud top, thus -! helping to better calculate in layer clouds. -! Add TG (grid temperature) to calcualtion. -! -! revc: 2/27/90 Correct error in code. Zero-out slwc when grid -! temperature (GT) > 0. -! -! J.Z.: 4/7/97 Correct error in code -! Grid temperature should be TG, not GT. -! -! -! OUTPUTS: ADIABATIC_LWC -! ADJUSTED_LWC -! ADJUSTED_SLWC -! I_STATUS1 - 1 when -20 < cld_top_temp < 0 for Stratus -! 0 Otherwise -! I_STATUS2 - 1 when valid input data provided from main -! - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE - - real(r_single), intent(in) :: cb_pa,cb_k,gt_pa,gt_k,ct_k - real(r_single), intent(out) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc - INTEGER(i_kind),intent(out) :: i_status1,i_status2 - - real(r_kind) :: eps,cpd,cw,rd,alhv - DATA eps/0.622_r_kind/,cpd/1.0042E3_r_kind/,cw/4.218E3_r_kind/,rd/287.05_r_kind/,alhv/2.501E6_r_kind/ - INTEGER(i_kind) :: cty,i - real(r_kind) :: p0,p,t0,tg,ctt,tk,e,r,cpt,t1,thetaq,rv,t,tw - real(r_kind) :: vapor -! -! - i_status1=1 - i_status2=1 -! 2 Print *,'ENTER: P-BASE(mb), T-BASE(C), P-TOP, T-TOP, CLD TYPE' -! READ(5,*) P0, T0, P, CTT, CTY -! If(CTY.ne.0.and.CTY.ne.1) Go to 2 -! -! Hardwire cloud type (CTY) for stratus for now -! - cty=0 -! -!.....Convert Pa to mb and Kelvin to Celcius -! - p0 = cb_pa/100._r_kind - p = gt_pa/100._r_kind - t0 = cb_k - 273.15_r_kind - tg = gt_k - 273.15_r_kind - ctt= ct_k - 273.15_r_kind -! Print *, 'CTT in Sub = ', CTT -! -! Check for valid input data... -! - IF(p0 > 1013._r_kind.OR.p0 < 50._r_kind) THEN - i_status2=0 - RETURN - ELSE - END IF -! -! - IF(t0 > 50._r_kind.OR.t0 < -70._r_kind) THEN - i_status2=0 - RETURN - ELSE - END IF -! -! - IF(p > 1013._r_kind.OR.p < 50._r_kind) THEN - i_status2=0 - RETURN - ELSE - END IF -! -! Set I_STATUS1 = F if 0 < cld top < -20 C (for stratus). -! - IF(tg >= 0._r_kind.OR.ctt < -20._r_kind) i_status1=0 -! - tk=t0+273.15_r_kind - e=vapor(t0) - r=eps*e/(p0-e) - cpt=cpd+r*cw - thetaq=tk*(1000._r_kind/(p0-e))**(rd/cpt)*EXP(alhv*r/(cpt*tk)) -! 1ST APPROX - t1=tk - e=vapor(t1-273.15_r_kind) - rv=eps*e/(p-e) - t1=thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) -! SUCCESSIVE APPROXIMATIONS - DO i=1,10 - e=vapor(t1-273.15_r_kind) - rv=eps*e/(p-e) - t1=(thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) & - +t1)/2._r_kind - t=t1-273.15_r_kind -! Print *, P0,T0,P,T,E,RV,THETAQ - END DO -! GET LWC - e=vapor(t) - rv=eps*e/(p-e) - tw=r-rv - adiabatic_lwc=tw*p*28.9644_r_kind/(8.314E7_r_kind*t1)*1.e9_r_kind - IF(adiabatic_lwc < 0._r_kind) adiabatic_lwc=0._r_kind -! Print *, 'Adiabtic LWC = ', ADIABATIC_LWC - IF(tg >= 0._r_kind) THEN -! - adjusted_slwc=0._r_kind ! Added 2/27/90 -! - - IF(cty == 0._r_kind) THEN - IF(ctt < -20._r_kind) THEN - adjusted_lwc=0._r_kind - ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN - adjusted_lwc=adiabatic_lwc/8._r_kind - ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN - adjusted_lwc=adiabatic_lwc/4._r_kind - ELSE - adjusted_lwc=adiabatic_lwc/2._r_kind - END IF - ELSE - IF(ctt < -25._r_kind) THEN - adjusted_lwc=0._r_kind - ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN - adjusted_lwc=adiabatic_lwc/8._r_kind - ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN - adjusted_lwc=adiabatic_lwc/4._r_kind - ELSE - adjusted_lwc=adiabatic_lwc/2._r_kind - END IF - END IF - ELSE - IF(cty == 0._r_kind) THEN - IF(ctt < -20._r_kind) THEN - adjusted_lwc=0._r_kind - adjusted_slwc=0._r_kind - ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN - adjusted_lwc=adiabatic_lwc/8._r_kind - adjusted_slwc=adiabatic_lwc/8._r_kind - ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN - adjusted_lwc=adiabatic_lwc/4._r_kind - adjusted_slwc=adiabatic_lwc/4._r_kind - ELSE - adjusted_lwc=adiabatic_lwc/2._r_kind - adjusted_slwc=adiabatic_lwc/2._r_kind - END IF - ELSE - IF(ctt < -25._r_kind) THEN - adjusted_lwc=0._r_kind - adjusted_slwc=0._r_kind - ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN - adjusted_lwc=adiabatic_lwc/8._r_kind - adjusted_slwc=adiabatic_lwc/8._r_kind - ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN - adjusted_lwc=adiabatic_lwc/4._r_kind - adjusted_slwc=adiabatic_lwc/4._r_kind - ELSE - adjusted_lwc=adiabatic_lwc/2._r_kind - adjusted_slwc=adiabatic_lwc/2._r_kind - END IF - END IF - END IF -! Print *,'Adjusted LWC = ', ADJUSTED_LWC -! Print *,'Adjusted SLWC = ', ADJUSTED_SLWC -END SUBROUTINE slwc_revb - -! FUNCTION TO CALCULATE VAPOR PRESSURE: -! - - FUNCTION vapor(tfp) -! INPUT IS IN DEGREES C. IF GT 0, ASSUMED TO BE DEW POINT. IF -! LESS THAN 0, ASSUMED TO BE FROST POINT. -! ROUTINE CODES GOFF-GRATCH FORMULA - use kinds, only: i_kind,r_kind - IMPLICIT NONE - - real(r_kind), intent(in) :: tfp - real(r_kind) :: vapor - -! - real(r_kind) :: tvap, e - - tvap=273.16_r_kind+tfp - IF(tfp > 0.) GO TO 1 -! THIS IS ICE SATURATION VAPOR PRESSURE - IF(tvap <= 0) tvap=1E-20_r_kind - e=-9.09718_r_kind*(273.16_r_kind/tvap-1._r_kind)- & - 3.56654_r_kind*LOG10(273.16_r_kind/tvap) & - +0.876793_r_kind*(1.-tvap/273.16_r_kind) - vapor=6.1071_r_kind*10._r_kind**e - RETURN - 1 CONTINUE -! THIS IS WATER SATURATION VAPOR PRESSURE - IF(tvap <= 0) tvap=1E-20_r_kind - e=-7.90298_r_kind*(373.16_r_kind/tvap-1._r_kind)+ & - 5.02808_r_kind*LOG10(373.16_r_kind/tvap) & - -1.3816E-7_r_kind*(10._r_kind**(11.344_r_kind*& - (1._r_kind-tvap/373.16_r_kind))-1._r_kind) & - +8.1328E-3_r_kind*(10._r_kind**(3.49149_r_kind& - *(1-373.16_r_kind/tvap))-1) - vapor=1013.246_r_kind*10._r_kind**e - RETURN - END FUNCTION vapor diff --git a/lib/GSD/gsdcloud4nmmb/BackgroundCld.f90 b/lib/GSD/gsdcloud4nmmb/BackgroundCld.f90 deleted file mode 100755 index 96857711d..000000000 --- a/lib/GSD/gsdcloud4nmmb/BackgroundCld.f90 +++ /dev/null @@ -1,193 +0,0 @@ -SUBROUTINE BackgroundCld(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk, & - zh,pt_ll,eta1_ll,aeta1_ll,regional,wrf_mass_regional) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: BackgroundCld Ingest background fields for cloud analysis -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 -! -! ABSTRACT: -! This subroutine reads in background hydrometeor fields for cloud analysis -! -! PROGRAM HISTORY LOG: -! 2009-01-02 Hu Add NCO document block -! 2010-04-26 Hu delete the module gridmod and guess_grids. -! transfer information subroutine dummy variables -! -! -! input argument list: -! mype - processor ID -! lon2 - no. of lons on subdomain (buffer points on ends) -! lat2 - no. of lats on subdomain (buffer points on ends) -! nsig - no. of vertical levels -! tbk - 3D background potential temperature (K) -! psbk - 2D background surface pressure (hPa) -! q - 3D moisture (water vapor mixing ratio kg/kg) -! zh - terrain -! pt_ll - vertical coordinate -! eta1_ll - vertical coordinate -! aeta1_ll - vertical coordinate -! regional - if regional -! wrf_mass_regional - if mass core -! -! output argument list: -! pbk - 3D background pressure (hPa) -! hbk - 3D height above the ground (not the sea level) -!!!! z_lcl - lifting condensation level -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind,r_kind - use constants, only: rd_over_cp, h1000 - use constants, only: rd, grav, half, rad2deg - - implicit none - - integer(i_kind),intent(in):: mype - integer(i_kind),intent(in):: lon2 - integer(i_kind),intent(in):: lat2 - integer(i_kind),intent(in):: nsig - - real(r_kind), intent(in) :: pt_ll - real(r_kind), intent(in) :: eta1_ll(nsig+1) ! - real(r_kind), intent(in) :: aeta1_ll(nsig) ! - logical, intent(in) :: regional ! .t. for regional background/analysis - logical, intent(in) :: wrf_mass_regional ! - - -! background -! -! read in from WRF -! - real(r_single),intent(inout) :: tbk(lon2,lat2,nsig) ! temperature - real(r_single),intent(inout) :: psbk(lon2,lat2) ! surface pressure - real(r_single),intent(in) :: zh(lon2,lat2) ! terrain elevation - real(r_single),intent(inout) :: q(lon2,lat2,nsig) ! moisture -! -! derived fields -! - real(r_single),intent(out) :: hbk(lon2,lat2,nsig)! height - real(r_single),intent(out) :: pbk(lon2,lat2,nsig)! pressure hPa -! real(r_single),intent(out) :: z_lcl(lon2,lat2) ! lifting condensation level -! - real(r_single) :: cv_bk(lon2,lat2,nsig) ! cloud cover - real(r_single) :: t_k(lon2,lat2,nsig) ! temperature in C - -! -! misc. -! - INTEGER :: i,j,k - - REAL(r_single) :: rdog, h, dz, rl - REAL(r_single) :: height(nsig+1) - real(r_single) :: q_integral(lon2,lat2) - real(r_single) :: deltasigma, psfc_this - -! -!================================================================ -! - q_integral=1 - do k=1,nsig - deltasigma=eta1_ll(k)-eta1_ll(k+1) - do j=1,lat2 - do i=1,lon2 - q(i,j,k) = q(i,j,k)/(1.0_r_kind-q(i,j,k)) ! water vapor mixing ratio (kg/kg) - q_integral(i,j)=q_integral(i,j)+deltasigma*q(i,j,k) - enddo - enddo - enddo - do j=1,lat2 - do i=1,lon2 - psfc_this=pt_ll+(psbk(i,j)-pt_ll)/q_integral(i,j) - psbk(i,j)= psfc_this - enddo - enddo - -! -! assign CAPE as 0, this part needs more work -! -! gsfc(:,:,3)=0.0 ! CAPE, we need but not included in wrf_inout -! 1: land use; 2: sfc soil T; 3: CAPE -! -! get land use and convert latitude and longitude back to degree -! xland=gsfc(:,:,1) -! soil_tbk=gsfc(:,:,2) -! -! get virtual potential temperature (thv) -! -! thv=0.0 -! do k=1,nsig -! do j=1,nlat -! do i=1,nlon -! rl=qr(i,j,k)+qs(i,j,k)+qg(i,j,k)+qc(i,j,k)+qi(i,j,k) -! thv(i,j,k)=tbk(i,j,k)*(1.0+0.61*q(i,j,k)-rl) -! ENDDO -! ENDDO -! ENDDO -!! -! -! now get pressure (pbk) and height (hbk) at each grid point -! - if(regional .and. wrf_mass_regional ) then - - do k=1,nsig - do j=1,lat2 - do i=1,lon2 - pbk(i,j,k)=aeta1_ll(k)*(psbk(i,j)-pt_ll)+pt_ll - end do - end do - end do - -! Compute geopotential height at midpoint of each layer - rdog = rd/grav - do j=1,lat2 - do i=1,lon2 - k = 1 - h = rdog * tbk(i,j,k) - dz = h * log(psbk(i,j)/pbk(i,j,k)) - height(k) = zh(i,j) + dz - - do k=2,nsig - h = rdog * half * (tbk(i,j,k-1)+tbk(i,j,k)) - dz = h * log(pbk(i,j,k-1)/pbk(i,j,k)) - height(k) = height(k-1) + dz - end do - - do k=1,nsig - hbk(i,j,k)=height(k) - zh(i,j) - end do - end do - end do - else - write(6,*) ' Only wrf mass grid is done for cloud analysis ' - write(6,*) ' You are choosing grid that is not recoginzed by cloud analysis' - call stop2(114) - endif - - do k=1,nsig - do j=1,lat2 - do i=1,lon2 - tbk(i,j,k)=tbk(i,j,k)*(h1000/pbk(i,j,k))**rd_over_cp - enddo - enddo - enddo - -!mhu call BckgrndCC(lon2,lat2,nsig,tbk,pbk,q,hbk,zh, & -!mhu cv_bk,t_k,z_lcl) ! out - -END SUBROUTINE BackgroundCld diff --git a/lib/GSD/gsdcloud4nmmb/BckgrndCC.f90 b/lib/GSD/gsdcloud4nmmb/BckgrndCC.f90 deleted file mode 100755 index 0fefb28c7..000000000 --- a/lib/GSD/gsdcloud4nmmb/BckgrndCC.f90 +++ /dev/null @@ -1,159 +0,0 @@ -SUBROUTINE BckgrndCC(nlon,nlat,nsig,tbk,pbk,q,hbk,zh, & - cv_bk,t_k,z_lcl) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: BckgrndCC generate background field for -! fractional cloud cover based on RH -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 -! -! ABSTRACT: -! This subroutine calculate cloud field based on background fields -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! 2016-02-10 S.Liu Change subdomain boundary to cover full subdomain -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! tbk - 3D background potentional temperature (K) -! pbk - 3D background pressure (hPa) -! q - 3D moisture (kg/kg) -! hbk - 3D height -! zh - terrain -! -! output argument list: -! cv_bk - 3D background cloud cover -! t_k - 3D temperature in K -! z_lcl - lifting condensation level -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use kinds, only: r_single,i_kind,r_kind - use constants, only: h1000, rd_over_cp, g_over_rd - - implicit none - - integer(i_kind),intent(in):: nlon,nlat,nsig -! background -! -! read in from WRF -! - real(r_single),intent(in) :: tbk(nlon,nlat,nsig) ! potential temperature - real(r_single),intent(in) :: zh(nlon,nlat) ! terrain elevation - real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture - real(r_single),intent(in) :: hbk(nlon,nlat,nsig) ! height - real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure - - real(r_single),intent(out) :: t_k(nlon,nlat,nsig) ! temperature in K - real(r_single),intent(out) :: z_lcl(nlon,nlat) ! lifting condensation level - real(r_single),intent(out) :: cv_bk(nlon,nlat,nsig)! cloud cover - -! CONSTANTS: - real(r_single) :: gamma_d ! dry adiabatic lapse rate (K/m) - real(r_single) :: z_ref_lcl - PARAMETER(z_ref_lcl = 180.0_r_single) - -! misc. -! - real(r_single) :: rhbk(nlon,nlat,nsig) ! rh - - INTEGER :: i,j,k - - - REAL(r_kind) :: f_qvsat - REAL(r_kind) :: qvsat - REAL(r_kind) :: rh_to_cldcv - - REAL(r_kind) :: z_ref,x - REAL(r_kind) :: arg,arg2, t_ref_c, td_ref_c - REAL(r_kind) :: frac_z, t_ref_k,rh_ref - -! -!================================================================ -! - gamma_d = g_over_rd/rd_over_cp -! -! get the RH -! - do k=1,nsig - do j=1,nlat - do i=1,nlon - t_k(i,j,k)=tbk(i,j,k)*(pbk(i,j,k)/h1000)**rd_over_cp - qvsat=f_qvsat(pbk(i,j,k)*100.0_r_kind,t_k(i,j,k)) - ! Saturation water vapor specific humidity - qvsat = qvsat/(1.0 - qvsat) ! convert to saturation mixing ratio (kg/kg) - rhbk(i,j,k)=100._r_kind*MIN(1._r_kind,MAX(0._r_kind,(q(i,j,k)/qvsat))) - ! q is mixing ration kg/kg - enddo - enddo - enddo -! -! Find the lifting condensation level -! - z_lcl = -99999.0_r_kind - do j=2,nlat - do i=2,nlon - z_ref = z_ref_lcl + zh(i,j) - IF (z_ref <= hbk(i,j,2) .OR. z_ref > hbk(i,j,nsig-1)) THEN - write(6,*) 'Error, ref.level is out of bounds at pt:' & - ,i,j,z_ref,hbk(i,j,2),hbk(i,j,nsig-1) - call STOP2(114) - END IF - - DO k = 3,nsig-1 - IF ( z_ref < hbk(i,j,k) .and. z_ref >= hbk(i,j,k-1)) THEN - frac_z = (z_ref-hbk(i,j,k-1))/(hbk(i,j,k)-hbk(i,j,k-1)) - t_ref_k = t_k(i,j,k-1)+ frac_z*(t_k(i,j,k)-t_k(i,j,k-1)) - t_ref_c = t_ref_k - 273.15_r_kind -! - rh_ref = rhbk(i,j,k-1)+ frac_z*(rhbk(i,j,k)-rhbk(i,j,k-1)) -! compute dew point depression. -! td_ref_c = dwpt(t_ref_c,rh_ref) - x = 1._r_kind-0.01_r_kind*rh_ref - td_ref_c =t_ref_c-(14.55_r_kind+0.114_r_kind*t_ref_c)*x+ & - ((2.5_r_kind+0.007_r_kind*t_ref_c)*x)**3+ & - (15.9_r_kind+0.117_r_kind*t_ref_c)*x**14 - - END IF - END DO ! k = 2,nz-1 -! - z_lcl(i,j) = z_ref + (t_ref_c - td_ref_c)/gamma_d - z_lcl(i,j) = min(hbk(i,j,nsig-1),max(z_lcl(i,j),hbk(i,j,2))) - enddo - enddo -! -! get background cloud cover -! - cv_bk=0.0_r_kind - do k=1,nsig - do j=1,nlat - do i=1,nlon - IF (hbk(i,j,k) >= z_lcl(i,j)) THEN - arg = hbk(i,j,k) - zh(i,j) - arg2=rhbk(i,j,k)*0.01_r_kind - cv_bk(i,j,k) = rh_to_cldcv(arg2,arg) - ENDIF - enddo - enddo - enddo -! - -END SUBROUTINE BckgrndCC diff --git a/lib/GSD/gsdcloud4nmmb/CheckCld.f90 b/lib/GSD/gsdcloud4nmmb/CheckCld.f90 deleted file mode 100755 index 795eaa997..000000000 --- a/lib/GSD/gsdcloud4nmmb/CheckCld.f90 +++ /dev/null @@ -1,292 +0,0 @@ -SUBROUTINE check_cloud(mype,nlat,nlon,nsig,q,qr,qs,qg,qc,qi,tcld,pbk,h_bk, & - mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,cstation,& - sat_ctp,cld_cover_3d,xland) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: save_cloudResults writes out diagnostics on cloud/hydrometeor analysis -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-27 -! -! ABSTRACT: -! This subroutine writes out diagnostics on cloud analysis results -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! pbk - 3D background pressure (hPa) -! q - 3D moisture (water vapor mixing ratio) -! qr - 3D rain mixing ratio (kg/kg) -! qs - 3D snow mixing ratio (kg/kg) -! qg - 3D graupel mixing ratio (kg/kg) -! qc - 3D cloud water mixing ratio (kg/kg) -! qi - 3D cloud ice mixing ratio (kg/kg) -! tcld - 3D in-cloud temperature (K) -! -! mxst_p - maximum observation number -! NVARCLD_P - first dimension of OLCD -! numsao - observation number -! OI - observation x location -! OJ - observation y location -! OLCD - cloud amount, cloud height, visibility -! OWX - weather observation -! Oelvtn - observation elevation -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind, r_double - use guess_grids, only: ges_tv,ges_q - use guess_grids, only: ges_qc,ges_qi,ges_qr,ges_qs,ges_qg,ges_tten - use constants, only: rd_over_cp, h1000 - use gridmod, only: jlon1,ilat1,istart,jstart - - implicit none - - integer (i_kind),intent(in) :: nlat,nlon,nsig - integer (i_kind),intent(in) :: mype - -! background -! -! read in from WRF -! - real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, mixing ratio (kg/kg) - real(r_single),intent(in) :: qr(nlon,nlat,nsig) ! rain - real(r_single),intent(in) :: qs(nlon,nlat,nsig) ! snow - real(r_single),intent(in) :: qg(nlon,nlat,nsig) ! graupel - real(r_single),intent(in) :: qc(nlon,nlat,nsig) ! cloud water - real(r_single),intent(in) :: qi(nlon,nlat,nsig) ! cloud ice - real(r_single),intent(in) :: tcld(nlon,nlat,nsig) ! cloud temperature (potential temperature) - - real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure , pa - real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height -! -! cloud observation from METAR - - INTEGER(i_kind), intent(in) :: mxst_p,NVARCLD_P -! PARAMETER (LSTAID_P=9) - - INTEGER,intent(in) :: numsao - real(r_single),intent(in) :: OI(mxst_p) ! x location - real(r_single),intent(in) :: OJ(mxst_p) ! y location - INTEGER(i_kind),intent(in):: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, - ! visibility - CHARACTER*10,intent(in) :: OWX(mxst_p) ! weather - real(r_single),intent(in) :: Oelvtn(mxst_p) ! elevation - character(8),intent(in) :: cstation(mxst_p) ! station name - real(i_kind), intent(in) :: xland(nlon,nlat) ! surface -! - real(r_single),intent(in) :: sat_ctp(nlon,nlat) -! - real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) -! -! misc. -! - INTEGER :: ista,idw,ids - INTEGER :: i,j,k, iunit - character*3 :: cmype -! -!================================================================ -! - idw=jstart(mype+1)-2 - ids=istart(mype+1)-2 - iunit=68 - write(cmype,'(I3.3)') mype - open(iunit,file='checkCloud_'//trim(cmype)//'.txt') - write(iunit,*) idw,ids,jstart(mype+1),istart(mype+1),mype - - if(mype==22 ) then - DO i=54, 58 - DO j=96, 100 - write(*,*) 'radar=',i,j,k - DO k=1,nsig - write(*,*) 'radar=',ges_tten(j,i,k,1) ,pbk(i,j,k) - enddo - enddo - enddo - endif - - return -if(mype==5 ) then - DO i=100, 102 - DO j=44, 46 -! DO i=2, nlon-1 -! DO j=2, nlat-1 - -! if(sat_ctp(i,j) > 900 .and. sat_ctp(i,j) < 1014) then - write(iunit,'(a,f8.1,2i8,f8.1)') 'cloud top pressure=',sat_ctp(i,j),i,j,xland(i,j) - write(iunit,'(a10,3a10,a12,3a10)') 'level','cover','qc', 'qi', 'h_bk', 'pbk','tcld' - DO k=1,nsig - write(iunit,'(i10,f10.2,2f10.5,f12.1,3f10.1)') & - k,cld_cover_3d(i,j,k),qc(i,j,k)*1000.0,qi(i,j,k)*1000.0, & - h_bk(i,j,k),pbk(i,j,k),tcld(i,j,k) - enddo -! endif - END DO - END DO - - - if(numsao > 0 ) then - do ista = 1,numsao - if(abs(OCLD(1,ista)) <10 ) then - write(iunit,'(a10,I10,2f8.2,20I10)') cstation(ista),ista,oi(ista),oj(ista),(OCLD(k,ista),k=1,3),(OCLD(k,ista),k=7,10) - endif - enddo - endif - -endif - -! do k=1,nsig -! do j=1,nlat -! do i=1,nlon -! tcld(i,j,k)=tcld(i,j,k)*(pbk(i,j,k)/h1000/100.0)**rd_over_cp -! ENDDO -! ENDDO -! ENDDO - - if(mype == 130 ) then - - - if(numsao > 0 ) then - write(cmype,'(I3.3)') mype - open(iunit,file='checkCloud_'//trim(cmype)//'.txt') - write(iunit,*) 'mype,idw,ids',mype,idw,ids,nlon,nlat - do ista = 1,numsao - if(abs(OCLD(1,ista)) <10 ) then - write(iunit,'(a10,I10,2f8.2)') cstation(ista),ista,oi(ista),oj(ista) - write(iunit,'(20I10)') (OCLD(k,ista),k=1,6) - write(iunit,'(20I10)') (OCLD(k,ista),k=7,NVARCLD_P) - endif - enddo - - - do ista = 1,numsao - i = int(oi(ista)+0.0001) - j = int(oj(ista)+0.0001) - - write(iunit,*) - write(iunit,'(a10,I10,a10,2I10,3f8.2)') 'ista=',ista,cstation(ista),i,j,oi(ista),oj(ista),Oelvtn(ista) - write(iunit,'(20I10)') (OCLD(k,ista),k=1,6) - write(iunit,'(20I10)') (OCLD(k,ista),k=7,NVARCLD_P) - - if( i >= 2 .and. i <=nlon-1 ) then - if( j >= 2 .and. j <=nlat-1 ) then - - write(iunit,'(a,f8.1)') 'cloud top pressure=',sat_ctp(i,j) - write(iunit,'(a10,3a10,a12,3a10)') 'level','cover','qc', 'qi', 'h_bk', 'pbk','tcld' - DO k=1,nsig - write(iunit,'(i10,f10.2,2f10.5,f12.1,3f10.1)') & - k,cld_cover_3d(i,j,k),qc(i,j,k)*1000.0,qi(i,j,k)*1000.0, & - h_bk(i,j,k),pbk(i,j,k),tcld(i,j,k) - enddo - - endif - endif - ENDDO - close(iunit) - - endif - endif -! - -END SUBROUTINE check_cloud -SUBROUTINE FindCloumn(mype,ifindomain,iglobal,jglobal,ilocal,jlocal) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: CheckCloumn find local i,j from certain global i,j -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-05-02 -! -! ABSTRACT: -! This subroutine print the column information for certain i,j -! -! PROGRAM HISTORY LOG: -! 2011-05-02 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! iglobal - i grid for whole domain -! jglobal - j grid for whole domain -! -! output argument list: -! ilocal - i grid for subdomain domain -! jlocal - j grid for subdomain domain -! ifindomain - if in this sub-domain -! -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! - - use kinds, only: r_single,i_kind,r_kind,r_double - use gridmod, only: jlon1,ilat1,istart,jstart - - implicit none - - integer(i_kind), intent(in) :: mype - integer(i_kind), intent(in) :: iglobal - integer(i_kind), intent(in) :: jglobal - integer(i_kind), intent(out) :: ilocal - integer(i_kind), intent(out) :: jlocal - logical, intent(out) :: ifindomain - -! -! misc. -! - - integer(i_kind) :: ib,jb - -!==================================================================== -! Begin - - ifindomain=.false. - ib=jstart(mype+1) ! begin i point of this domain - jb=istart(mype+1) ! begin j point of this domain - -! - ilocal = iglobal - ib + 2 ! covert it to the local grid - jlocal = jglobal - jb + 2 ! covert it to the local grid - - if(ilocal > 0 .and. jlocal > 0 ) then - if(ilocal <= jlon1(mype+1) .and. jlocal <= ilat1(mype+1) ) then - ifindomain=.true. - endif - endif -! write(*,*) 'find the location',mype,ilocal,jlocal,iglobal,jglobal -! write(*,*) mype,ib,jb,jlon1(mype+1),ilat1(mype+1),ifindomain - -END SUBROUTINE FindCloumn - diff --git a/lib/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 b/lib/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 deleted file mode 100755 index e4f9cd96d..000000000 --- a/lib/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 +++ /dev/null @@ -1,167 +0,0 @@ -SUBROUTINE PrecipMxR_radar(mype,nlat,nlon,nsig, & - t_bk,p_bk,ref_mos_3d, & - cldpcp_type_3d,q_bk,qr_cld,qnr_3d,qs_cld,qg_cld,cldqropt) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: PrecipMxR_radar find cloud liquid water content -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This is the driver to call subroutines that calculate liquid water content based on -! radar reflectivity and hydrometeor type diagnosed from radar -! and background 3-D temperature fields -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! ref_mos_3d - 3D reflectivity in analysis grid (dBZ) -! cldpcp_type_3d - 3D hydrometeor type -! cldqropt - scheme used to retrieve -! mixing ratios for hydrometeors related to precipitation (qr, qs, qg) -! 1=Kessler 2=Lin 3=Thompson -! -! output argument list: -! qr_cld - rain mixing ratio (g/kg) -! qnr_3d - rain number concentration -! qs_cld - snow mixing ratio (g/kg) -! qg_cld - graupel mixing ratio (g/kg) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind,r_kind - - implicit none - integer(i_kind),intent(in):: nlat,nlon,nsig - integer(i_kind),intent(in):: mype -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! height - real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! mixing ratio -! - real(r_kind),intent(in) :: ref_mos_3d(nlon,nlat,nsig) -! -! Variables for cloud analysis -! - integer(i_kind),intent(in) :: cldpcp_type_3d(nlon,nlat,nsig) -! -! hydrometeors -! - REAL(r_single),intent(out) :: qr_cld(nlon,nlat,nsig) ! rain - REAL(r_single),intent(out) :: qnr_3d(nlon,nlat,nsig) ! rain number concentration(/kg) - REAL(r_single),intent(out) :: qs_cld(nlon,nlat,nsig) ! snow - REAL(r_single),intent(out) :: qg_cld(nlon,nlat,nsig) ! graupel - -!----------------------------------------------------------- -! -! temp. -! - - REAL(r_single) :: t_3d(nlon,nlat,nsig) - REAL(r_single) :: p_3d(nlon,nlat,nsig) - REAL(r_kind) :: qs_max - - INTEGER(i_kind) :: cldqropt - INTEGER(i_kind) :: istatus_pcp - INTEGER(i_kind) :: i,j,k - INTEGER(i_kind) :: k_qs_max - REAL(r_kind) :: threshold_t_1st - -! -!==================================================================== -! Begin -! -! cldqropt = 2 - - DO j = 2,nlat-1 - DO i = 2,nlon-1 - DO k = 1,nsig - t_3d(i,j,k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp - p_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single - END DO - END DO - END DO - -!----------------------------------------------------------------------- -! -! Calculate 3D precipitation hydrometeor mixing ratios -! from radar reflectivity in g/kg. -! Note that qr_cld, qs_cld, and qg_cld are diagnosed -! qr, qs and qg in g/kg, respectively. -! -!----------------------------------------------------------------------- -! - IF (cldqropt == 1) THEN -! -! Kessler's scheme -! - if(mype==0) then - WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' - WRITE(6,'(a)') & - ' Using Kessler radar reflectivity equations...' - endif - CALL pcp_mxr (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & - cldpcp_type_3d, & - qr_cld,qs_cld,qg_cld, & - istatus_pcp) - - ELSE IF (cldqropt == 2) THEN -! -! Ferrier's scheme -! - if(mype==0) then - WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' - WRITE(6,'(a)') & - ' Using Ferrier radar reflectivity equations...' - endif - CALL pcp_mxr_ferrier_new (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & - cldpcp_type_3d,q_bk, & - qr_cld,qs_cld,qg_cld, & - istatus_pcp) - - ELSE IF (cldqropt == 3) THEN -! -! Thompson's scheme -! - if(mype==0) then - WRITE(6,'(a)') ' PrecipMxR_radar: Computing Precip mixing ratio.' - WRITE(6,'(a)') & - ' Using Thompson RUC radar reflectivity equations...' - endif -! call pcp_mxr_thompsonRUC(qr_cld,qs_cld,qg_cld, & -! p_3d,t_3d, & -! ref_mos_3d,nlon,nlat,nsig,cldpcp_type_3d) - call hydro_mxr_thompson (nlon,nlat,nsig, t_3d, p_3d, ref_mos_3d, & - qr_cld,qnr_3d,qs_cld, istatus_pcp,mype) - - END IF !cldqropt=1 or 2 or 3 - -END SUBROUTINE PrecipMxR_radar - diff --git a/lib/GSD/gsdcloud4nmmb/PrecipType.f90 b/lib/GSD/gsdcloud4nmmb/PrecipType.f90 deleted file mode 100755 index 51f83ddb0..000000000 --- a/lib/GSD/gsdcloud4nmmb/PrecipType.f90 +++ /dev/null @@ -1,118 +0,0 @@ -SUBROUTINE PrecipType(nlat,nlon,nsig,t_bk,p_bk,q_bk,radar_3d, & - wthr_type,cldpcp_type_3d) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: PrecipType decide precipitation type -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine calculates precipitation type -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! q_bk - 3D moisture -! radar_3d - 3D radar reflectivity in analysis grid (dBZ) -! wthr_type - weather type -! -! output argument list: -! cldpcp_type_3d - 3D precipitation type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind,r_kind - - implicit none - integer(i_kind),INTENT(IN):: nlat,nlon,nsig -! -! surface observation -! -! -! background -! - real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature - real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure - real(r_single),INTENT(IN) :: q_bk(nlon,nlat,nsig) ! moisture -! -! observation -! - real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity -! -! -! Variables for cloud analysis -! - integer(i_kind),INTENT(out) :: cldpcp_type_3d(nlon,nlat,nsig) - integer(i_kind),INTENT(in) :: wthr_type(nlon,nlat) - LOGICAL :: l_mask(nlon,nlat) ! "Potential" Precip Type - -! -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind):: i,j,k,ilvl,nlvl - real(r_single) :: temp_3d(nlon,nlat,nsig) ! temperature (C) - real(r_single) :: rh_3d(nlon,nlat,nsig) ! relative humidity - real(r_single) :: p_pa_3d(nlon,nlat,nsig) ! - REAL(r_single) :: qvsat - REAL(r_single) :: f_qvsat - INTEGER :: istatus -! -!==================================================================== -! Begin -! -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - - DO j = 1,nlat - DO i = 1,nlon -! - DO k = 1,nsig ! Initialize - temp_3d(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to K - qvsat=f_qvsat(p_bk(i,j,k)*100.0_r_single,temp_3d(i,j,k)) - qvsat = qvsat/(1.0_r_single-qvsat) ! convert to mixing ratio (kg/kg) - rh_3d(i,j,k)=100._r_single*MIN(1.,MAX(0._r_single,(q_bk(i,j,k)/qvsat))) - p_pa_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single - END DO -!----------------------------------------------------------------------- - - ENDDO ! i - ENDDO ! j - - l_mask = .false. - - call pcp_type_3d (nlon,nlat,nsig,temp_3d,rh_3d,p_pa_3d & - ,radar_3d,l_mask,cldpcp_type_3d,istatus) - - -END SUBROUTINE precipType - diff --git a/lib/GSD/gsdcloud4nmmb/TempAdjust.f90 b/lib/GSD/gsdcloud4nmmb/TempAdjust.f90 deleted file mode 100755 index a7f080275..000000000 --- a/lib/GSD/gsdcloud4nmmb/TempAdjust.f90 +++ /dev/null @@ -1,199 +0,0 @@ -SUBROUTINE TempAdjust(mype,nlat,nlon,nsig,cldptopt, t_bk, p_bk,w_bk,q_bk, & - qc,qi,ctmp_bk) - -! -!$$$ subprogram documentation block -! . . . . -! subprogram: TempAdjust temperature adjustment -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-26 -! -! ABSTRACT: -! This subroutine adjusts the perturbation potential temperature field to account -! for the latent heating release. -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! cldptopt - schemes of adjustment -! 3=latent heat, 4,5,6 = adiabat profile -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! w_bk - 3D background vertical velocity -! q_bk - 3D moisture (water vapor mixing ratio) -! qc - 3D cloud water mixing ratio (kg/kg) -! qi - 3D cloud ice mixing ratio (kg/kg) -! ctmp_bk - 3D cloud temperature -! -! output argument list: -! t_bk - 3D background potential temperature (K) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: cp,rd_over_cp, h1000, hvap - use kinds, only: r_single,i_kind - - implicit none - integer(i_kind),intent(in):: nlat,nlon,nsig - integer(i_kind),intent(in):: mype - -! -! background -! - real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! temperature - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure - real(r_single),intent(in) :: w_bk(nlon,nlat,nsig) ! terrain - real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture - water vapor mixing ratio -! -! real(r_single) :: t_bk_check(nlon,nlat,nsig) ! temperature -! -! -! cloud water and cloud ice mixing ratios -! - real (r_single),intent(in) :: qc(nlon,nlat,nsig) - real (r_single),intent(in) :: qi(nlon,nlat,nsig) - real (r_single),intent(in) :: ctmp_bk(nlon,nlat,nsig) -! -! constant - REAL :: p0 -! -! -! temp. -! - INTEGER :: i,j,k - INTEGER(i_kind),intent(in) :: cldptopt - REAL :: frac_qc_2_lh, max_lh_2_pt - REAL :: max_pt_adj - REAL :: p0inv,arg,ptdiff - REAL :: ppi,wratio,ptcld -! -! -!----------------------------------------------------------- -! -! t_bk_check=0.0 - - p0=h1000 -! - wratio=1.0 -! cldptopt=3 - frac_qc_2_lh =1.0 - max_lh_2_pt=20.0 -! - IF (cldptopt == 3) THEN -if(mype==0) then - WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating.' - WRITE(6,'(a,f10.4,a,f10.4)') & - 'TempAdjust: frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt -endif - p0inv=1./p0 - max_pt_adj = 0.0 - DO k=2,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - arg=max(0.0,qc(i,j,k)) + max(0.0,qi(i,j,k)) - if( arg > 0.0 ) then - ppi = (p_bk(i,j,k)*p0inv) ** rd_over_cp - arg = hvap*frac_qc_2_lh*arg*0.001/(cp*ppi) - max_pt_adj = MAX(max_pt_adj,arg) - t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) - endif - END DO - END DO - END DO - if(mype==0) PRINT*,'max_adj=',max_pt_adj - ELSE IF (cldptopt == 4) THEN -if(mype==0) then - WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating in w.' - PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt -endif - max_pt_adj = 0.0 - DO k=2,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k) > 0.0) THEN - wratio=1.0 - ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp - ptdiff=ptcld-t_bk(i,j,k) - IF(ptdiff > 0.) THEN - arg = frac_qc_2_lh*wratio*ptdiff - t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) - max_pt_adj = MAX(max_pt_adj,arg) - END IF - END IF - END DO - END DO - END DO - if(mype==0) PRINT*,'max_adj=',max_pt_adj - ELSE IF (cldptopt == 5) THEN -if(mype==0) then - WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>-0.2' - PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt -endif - max_pt_adj = 0.0 - DO k=2,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - IF( ctmp_bk(i,j,k) > 0.0) THEN - wratio=min(max(0.,(5.0*(w_bk(i,j,k)+0.2))),1.0) - ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp - ptdiff=ptcld-t_bk(i,j,k) - IF(ptdiff > 0.) THEN - arg = frac_qc_2_lh*wratio*ptdiff - t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) - max_pt_adj = MAX(max_pt_adj,arg) - END IF - ENDIF - END DO - END DO - END DO - if(mype==0) PRINT*,'max_adj=',max_pt_adj - - ELSE IF (cldptopt == 6) THEN -if(mype==0) then - WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>0.0' - PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt -endif - max_pt_adj = 0.0 - DO k=2,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k)>0.0 ) THEN - ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp - ptdiff=ptcld-t_bk(i,j,k) - IF(ptdiff > 0.) THEN - arg = frac_qc_2_lh*ptdiff - t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) -! t_bk_check(i,j,k) = MIN(arg,max_lh_2_pt) - max_pt_adj = MAX(max_pt_adj,arg) - END IF - END IF - END DO - END DO - END DO - if(mype==0) PRINT*,'max_adj=',max_pt_adj - - END IF ! cldptopt=3? - -! t_bk = t_bk_check - -END SUBROUTINE TempAdjust diff --git a/lib/GSD/gsdcloud4nmmb/adaslib.f90 b/lib/GSD/gsdcloud4nmmb/adaslib.f90 deleted file mode 100755 index 555e7ec6a..000000000 --- a/lib/GSD/gsdcloud4nmmb/adaslib.f90 +++ /dev/null @@ -1,474 +0,0 @@ -! -!$$$ subprogram documentation block -! . . . . -! ABSTRACT: -! This file collects subroutines related to cloud analysis in ADAS (CAPS) -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! -! -!################################################################## -!################################################################## -!###### ###### -!###### FUNCTION RH_TO_CLDCV ###### -!###### ###### -!################################################################## -!################################################################## -! - - FUNCTION rh_to_cldcv(rh,hgt) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Obtain first guess cloud cover field from relative humidity. -! -! -! AUTHOR: Jian Zhang -! 07/95 -! -! MODIFICATION HISTORY -! -! 04/08/97 J. Zhang -! Added the empirical relationship between RH and -! cloud cover used by Koch et al. (1997). -! Reference: -! Reference: -! Koch, S.E., A. Aksakal, and J.T. McQueen, 1997: -! The influence of mesoscale humidity and evapotranspiration -! fields on a model forecast of a cold-frontal squall line. -! Mon. Wea. Rev., Vol.125, 384-409 -! 09/10/97 J. Zhang -! Modified the empirical relationship between cloud -! fraction and relative humidity from quadratic -! to one-fourth-power. -! -! -!----------------------------------------------------------------------- -! -! INPUT: -! rh ! relative humidity -! hgt ! height (AGL) -! -! OUTPUT: -! rh_to_cld_cv ! cloud fractional cover value -! -! LOCAL: -! rh0 ! the critical RH value that seperate clear - ! air condition and cloudy condition -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind,r_kind - - IMPLICIT NONE - - INTEGER(i_kind) :: rh2cform - PARAMETER (rh2cform=2) - - REAL(r_kind), intent(in) :: rh,hgt - REAL(r_kind) :: rh_to_cldcv - REAL(r_kind) :: rh0 - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! - IF(rh2cform == 1) THEN -! -!----------------------------------------------------------------------- -! -! A quadratic relationship between relative humidity and cloud -! fractional cover. -! -!----------------------------------------------------------------------- -! - IF (hgt < 600.0_r_kind) THEN - rh0 = 0.9_r_kind - ELSE IF (hgt < 1500.0_r_kind) THEN - rh0 = 0.8_r_kind - ELSE IF (hgt < 2500.0_r_kind) THEN - rh0 = 0.6_r_kind - ELSE - rh0 = 0.5_r_kind - END IF - - IF (rh < rh0) THEN - rh_to_cldcv = 0.0_r_kind - ELSE - rh_to_cldcv = (rh - rh0)/(1.0_r_kind - rh0) - rh_to_cldcv = rh_to_cldcv*rh_to_cldcv - END IF - - ELSE IF(rh2cform == 2) THEN -! -!----------------------------------------------------------------------- -! -! A quadratic relationship between relative humidity and cloud -! fractional cover with fixed rh0=0.75 -! -!----------------------------------------------------------------------- -! -! - IF (rh < 0.75_r_kind) THEN - rh_to_cldcv = 0.0_r_kind - ELSE - rh_to_cldcv = 16._r_kind*(rh - 0.75_r_kind)*(rh - 0.75_r_kind) - END IF - - ELSE -! -!-----------------------------------------------------------------------! -! A modified version of the sqrt relationship between -! relative humidity and cloud fractional cover used in Eta model. -! -!----------------------------------------------------------------------- -! - IF (hgt < 600._r_kind) THEN - rh0 = 0.8_r_kind - ELSE - rh0 = 0.75_r_kind - END IF - - IF (rh < rh0) THEN - rh_to_cldcv = 0.0_r_kind - ELSE - rh_to_cldcv = 1.0_r_kind - SQRT((1.0_r_kind - rh)/(1.0_r_kind - rh0)) - END IF - - END IF - - RETURN - END FUNCTION rh_to_cldcv -! -! -!################################################################## -!################################################################## -!###### ###### -!###### FUNCTION F_ES ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -FUNCTION f_es( p, t ) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Calculate the saturation specific humidity using enhanced Teten's -! formula. -! -!----------------------------------------------------------------------- -! -! AUTHOR: Yuhe Liu -! 01/08/1998 -! -! MODIFICATION HISTORY: -! -!----------------------------------------------------------------------- -! -! INPUT : -! -! p Pressure (Pascal) -! t Temperature (K) -! -! OUTPUT: -! -! f_es Saturation water vapor pressure (Pa) -! -!----------------------------------------------------------------------- -! - -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - - REAL :: p ! Pressure (Pascal) - REAL :: t ! Temperature (K) - REAL :: f_es ! Saturation water vapor pressure (Pa) -! -!----------------------------------------------------------------------- -! -! Function f_es and inline directive for Cray PVP -! -!----------------------------------------------------------------------- -! - REAL :: f_esl, f_esi - -!fpp$ expand (f_esl) -!fpp$ expand (f_esi) -!!dir$ inline always f_esl, f_esi -!*$* inline routine (f_esl, f_esi) - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - IF ( t >= 273.15 ) THEN ! for water - f_es = f_esl( p,t ) - ELSE ! for ice - f_es = f_esi( p,t ) - END IF - - RETURN -END FUNCTION f_es - -! -!----------------------------------------------------------------------- -! -! Calculate the saturation water vapor over liquid water using -! enhanced Teten's formula. -! -!----------------------------------------------------------------------- -! - -FUNCTION f_esl( p, t ) - - IMPLICIT NONE - -! constant - REAL :: satfwa, satfwb - PARAMETER ( satfwa = 1.0007 ) - PARAMETER ( satfwb = 3.46E-8 ) ! for p in Pa - - REAL :: satewa, satewb, satewc - PARAMETER ( satewa = 611.21 ) ! es in Pa - PARAMETER ( satewb = 17.502 ) - PARAMETER ( satewc = 32.18 ) - - REAL :: p ! Pressure (Pascal) - REAL :: t ! Temperature (K) - REAL :: f_esl ! Saturation water vapor pressure over liquid water - - REAL :: f - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - f = satfwa + satfwb * p - f_esl = f * satewa * EXP( satewb*(t-273.15)/(t-satewc) ) - - RETURN -END FUNCTION f_esl -! -!----------------------------------------------------------------------- -! -! Calculate the saturation water vapor over ice using enhanced -! Teten's formula. -! -!----------------------------------------------------------------------- -! - -FUNCTION f_esi( p, t ) - - IMPLICIT NONE - -! - REAL :: satfia, satfib - PARAMETER ( satfia = 1.0003 ) - PARAMETER ( satfib = 4.18E-8 ) ! for p in Pa - - REAL :: sateia, sateib, sateic - PARAMETER ( sateia = 611.15 ) ! es in Pa - PARAMETER ( sateib = 22.452 ) - PARAMETER ( sateic = 0.6 ) - - REAL :: p ! Pressure (Pascal) - REAL :: t ! Temperature (K) - REAL :: f_esi ! Saturation water vapor pressure over ice (Pa) - - REAL :: f - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - f = satfia + satfib * p - f_esi = f * sateia * EXP( sateib*(t-273.15)/(t-sateic) ) - - RETURN -END FUNCTION f_esi -! -! -!################################################################## -!################################################################## -!###### ###### -!###### FUNCTION F_QVSAT ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -FUNCTION f_qvsat( p, t ) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Calculate the saturation specific humidity using enhanced Teten's -! formula. -! -!----------------------------------------------------------------------- -! -! AUTHOR: Yuhe Liu -! 01/08/1998 -! -! MODIFICATION HISTORY: -! -!----------------------------------------------------------------------- -! -! INPUT : -! -! p Pressure (Pascal) -! t Temperature (K) -! -! OUTPUT: -! -! f_qvsat Saturation water vapor specific humidity (kg/kg). -! -!----------------------------------------------------------------------- -! - -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE - - REAL :: p ! Pressure (Pascal) - REAL :: t ! Temperature (K) - REAL :: f_qvsat ! Saturation water vapor specific humidity (kg/kg) -! -!----------------------------------------------------------------------- -! -! Include files: -! -!----------------------------------------------------------------------- -! -! - - REAL :: rd ! Gas constant for dry air (m**2/(s**2*K)) - PARAMETER( rd = 287.0 ) - - REAL :: rv ! Gas constant for water vapor (m**2/(s**2*K)). - PARAMETER( rv = 461.0 ) - - REAL :: rddrv - PARAMETER( rddrv = rd/rv ) - -! -!----------------------------------------------------------------------- -! -! Function f_es and inline directive for Cray PVP -! -!----------------------------------------------------------------------- -! - REAL :: f_es -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! - f_qvsat = rddrv * f_es(p,t) / (p-(1.0-rddrv)*f_es(p,t)) - - RETURN -END FUNCTION f_qvsat - -SUBROUTINE getdays(nday,iyear,imonth,iday) - - use kinds, only: i_kind - implicit none -! - INTEGER(i_kind), intent(in) :: iyear,imonth,iday - INTEGER(i_kind), intent(out) :: nday -! - - nday=0 - if(imonth==1) then - nday=iday - elseif(imonth==2) then - nday=31+iday - elseif(imonth==3) then - nday=59+iday - elseif(imonth==4) then - nday=90+iday - elseif(imonth==5) then - nday=120+iday - elseif(imonth==6) then - nday=151+iday - elseif(imonth==7) then - nday=181+iday - elseif(imonth==8) then - nday=212+iday - elseif(imonth==9) then - nday=243+iday - elseif(imonth==10) then - nday=273+iday - elseif(imonth==11) then - nday=304+iday - elseif(imonth==12) then - nday=334+iday - endif - if(mod(iyear,4) == 0 .and. imonth > 2 ) nday=nday+1 - -END SUBROUTINE getdays diff --git a/lib/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 b/lib/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 deleted file mode 100755 index fd153a99d..000000000 --- a/lib/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 +++ /dev/null @@ -1,245 +0,0 @@ -SUBROUTINE build_missing_REFcone(mype,nlon,nlat,nsig,krad_bot_in,ref_mos_3d,h_bk,pblh) -! -! radar observation -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: build_missing_REFcone build missing reflectivity area -! below cone down to assumed cloud base -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-26 -! -! ABSTRACT: -! This subroutine sets reflectivity values at missing reflectivity volumes -! below the radar "data cone" down to an assumed cloud base -! As of March 2010, this code code not yet use the local PBL base -! as used in the RUC cloud/hydrometeor analysis since summer 2009. -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! 2011-04-08 Hu Clean the reflectivity below PBL height or level 7 -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! krad_bot - radar bottom level -! ref_mos_3d - 3D radar reflectivity -! h_bk - 3D background height -! pblh - PBL height in grid -! -! output argument list: -! ref_mos_3d - 3D radar reflectivity -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,i_kind,r_single - implicit none - - INTEGER(i_kind), intent(in) :: mype - INTEGER(i_kind), intent(in) :: nlon,nlat,nsig - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height - real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid - real(r_single), intent(in) :: pblh(nlon,nlat) ! PBL height - real(r_single), intent(in) :: krad_bot_in -! - integer(i_kind) :: krad_bot,ifmissing -! - integer(i_kind) :: maxlvl - parameter (maxlvl=31) - real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile(km) - DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & - 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & - 9, 10, 11, 12, 13, 14, 15, 16/ - - real(r_kind) :: refprofile_winter(maxlvl,6) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 20-35 dbz - DATA refprofile_winter(:,1) / & - 0.999,0.938,0.957,0.975,0.983,0.990,0.995,0.999,1.000,1.000, & - 0.994,0.985,0.957,0.926,0.892,0.854,0.819,0.791,0.770,0.747, & - 0.729,0.711,0.705,0.685,0.646,0.631,0.649,0.711,0.828,0.931, & - 0.949/ -! max reflectivity 25-30 dbz - DATA refprofile_winter(:,2) / & - 0.965,0.937,0.954,0.970,0.984,0.991,0.996,1.000,0.997,0.988, & - 0.973,0.954,0.908,0.856,0.808,0.761,0.718,0.684,0.659,0.631, & - 0.607,0.586,0.570,0.550,0.523,0.512,0.531,0.601,0.711,0.813, & - 0.870/ -! max reflectivity 30-35 dbz - DATA refprofile_winter(:,3) / & - 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & - 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & - 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & - 0.793/ -! max reflectivity 35-40 dbz - DATA refprofile_winter(:,4) / & - 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & - 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & - 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & - 0.723/ -! max reflectivity 40-45 dbz - DATA refprofile_winter(:,5) / & - 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & - 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & - 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & - 0.656/ -! max reflectivity 45-50 dbz - DATA refprofile_winter(:,6) / & - 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & - 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & - 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & - 0.548/ - - - real(r_kind) :: refprofile_summer(maxlvl,6) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 20-25 dbz - DATA refprofile_summer(:,1) / & - 0.883,0.870,0.879,0.892,0.904,0.912,0.913,0.915,0.924,0.936, & - 0.946,0.959,0.984,0.999,1.000,0.995,0.988,0.978,0.962,0.940, & - 0.916,0.893,0.865,0.839,0.778,0.708,0.666,0.686,0.712,0.771, & - 0.833/ -! max reflectivity 25-30 dbz - DATA refprofile_summer(:,2) / & - 0.836,0.874,0.898,0.915,0.927,0.938,0.945,0.951,0.960,0.970, & - 0.980,0.989,1.000,0.995,0.968,0.933,0.901,0.861,0.822,0.783, & - 0.745,0.717,0.683,0.661,0.614,0.564,0.538,0.543,0.578,0.633, & - 0.687/ -! max reflectivity 30-35 dbz - DATA refprofile_summer(:,3) / & - 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & - 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & - 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & - 0.570/ -! max reflectivity 35-40 dbz - DATA refprofile_summer(:,4) / & - 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & - 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & - 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & - 0.491/ -! max reflectivity 40-45 dbz - DATA refprofile_summer(:,5) / & - 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & - 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & - 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & - 0.440/ -! max reflectivity 45-50 dbz - DATA refprofile_summer(:,6) / & - 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & - 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & - 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & - 0.410/ - - INTEGER(i_kind) :: season ! 1= summer, 2=winter - - REAL(r_kind) :: heightGSI,upref,downref,wght - INTEGER(i_kind) :: ilvl,numref - REAL(r_kind) :: lowest,highest,tempref(nsig), tempprofile(maxlvl) - REAL(r_kind) :: maxref - - INTEGER(i_kind) :: i,j, k2, k, mref - -! -! vertical reflectivity distribution -! - season=1 - DO k=1,maxlvl - newlvlAll(k)=newlvlAll(k)*1000.0_r_kind - ENDDO -! - DO j=2,nlat-1 - DO i=2,nlon-1 - ifmissing=0 - maxref=-9999.0_r_kind -!mhu krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height -! Here, we only use PBL height to build missing corn and clean the reflectivity lower than -! PBL height. The krad_bot_in will be used when calculate the radar tten but not the hydrometer retrieval. -! Nov 21, 2011. Ming Hu - krad_bot= int( pblh(i,j) + 0.5_r_single ) ! consider PBL height -! -! in our case, -99 is no echo -! - DO k2=int(nsig/2),krad_bot,-1 - if(ref_mos_3d(i,j,k2+1)>=20._r_kind .and. & - ref_mos_3d(i,j,k2) < -100._r_kind ) ifmissing=k2 - if(ref_mos_3d(i,j,k2)>=maxref) maxref=ref_mos_3d(i,j,k2) - ENDDO - IF(ifmissing > 1 ) then - DO k2=krad_bot,1,-1 - if(ref_mos_3d(i,j,k2) >maxref) maxref=ref_mos_3d(i,j,k2) - ENDDO -! if(maxref < 19.0_r_kind) then -! write(6,*) 'build_missing_REFcone:',ifmissing,i,j,ifmissing -! write(6,*) (ref_mos_3d(i,j,k2),k2=1,nsig) -! endif - endif - IF(ifmissing > 1 .and. maxref > 19.0_r_kind ) then - mref = min(6,(int((maxref - 20.0_r_kind)/5.0_r_kind) + 1 )) - if(season== 2 ) then - DO k=1,maxlvl - tempprofile(k)=refprofile_winter(k,mref)*maxref - enddo - lowest=newlvlAll(2) - highest=7000.0_r_kind - else if(season== 1 ) then - DO k=1,maxlvl - tempprofile(k)=refprofile_summer(k,mref)*maxref - enddo - lowest=newlvlAll(3) - highest=12000.0_r_kind - endif -! make a ref profile - tempref=-9999.9_r_kind - DO k2=1,nsig - heightGSI=h_bk(i,j,k2) - if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? - do k=1,maxlvl-1 - if( heightGSI >=newlvlAll(k) .and. & - heightGSI < newlvlAll(k+1) ) ilvl=k - enddo - upref=tempprofile(ilvl+1) - downref=tempprofile(ilvl) - wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) - tempref(k2)=(1-wght)*downref + wght*upref - endif - ENDDO -! build missing volumes down to krad_bot level -! NOTE: no use of PBL base yet, as done in RUC analysis since summer 2009 - maxref=ref_mos_3d(i,j,ifmissing+1)-tempref(ifmissing+1) - if(abs(maxref) < 10.0_r_kind ) then - DO k2=ifmissing,krad_bot,-1 - ref_mos_3d(i,j,k2) = tempref(k2) + maxref - ENDDO - else - DO k2=ifmissing,krad_bot,-1 - ref_mos_3d(i,j,k2) = ref_mos_3d(i,j,ifmissing+1) - ENDDO - endif -! - ENDIF -! clean echo less than PBL height and level 7 - DO k2=1,krad_bot - ref_mos_3d(i,j,k2) = -99999.0_r_kind - ENDDO - ENDDO - ENDDO - -END SUBROUTINE build_missing_REFcone diff --git a/lib/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 b/lib/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 deleted file mode 100755 index 24e89e011..000000000 --- a/lib/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 +++ /dev/null @@ -1,697 +0,0 @@ -SUBROUTINE cloudCover_NESDIS(mype,regional_time,nlat,nlon,nsig,& - xlong,xlat,t_bk,p_bk,h_bk,zh,xland, & - soil_tbk,sat_ctp,sat_tem,w_frac,& - l_cld_bld,cld_bld_hgt,build_cloud_frac_p,clear_cloud_frac_p,nlev_cld, & - cld_cover_3d,cld_type_3d,wthr_type) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudCover_NESDIS cloud cover analysis using NESDIS cloud products -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 -! -! ABSTRACT: -! This subroutine determines cloud_cover (fractional) field using NESDIS cloud products -! Based on RUC assimilation code - (Benjamin, Weygandt, Kim, Brown) -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! 2016-02-10 S.Liu use r_single type for xland -! -! -! input argument list: -! mype - processor ID -! regional_time - analysis time -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! xlong - 2D longitude in each grid -! xlat - 2D latitude in each grid -! -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! h_bk - 3D background height -! zh - terrain -! xland - surface type (water, land) -! soil_tbk - background soil temperature -! sat_ctp - GOES cloud top pressure in analysis grid -! sat_tem - GOES cloud top temperature in analysis grid -! w_frac - GOES cloud coverage in analysis grid -! l_cld_bld - logical for turning on GOES cloud building -! cld_bld_hgt - Height below which cloud building is done -! build_cloud_frac_p - Threshold above which we build clouds -! clear_cloud_frac_p - Threshold below which we clear clouds -! -! output argument list: -! nlev_cld - cloud status -! cld_cover_3d- 3D cloud cover (fractional cloud) -! cld_type_3d - 3D cloud type -! wthr_type - 3D weather type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use constants, only: deg2rad, rad2deg, pi - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - integer(i_kind),intent(in) :: regional_time(6) - integer(i_kind),intent(in) :: nlat,nlon,nsig -! -! background -! - real(r_single),intent(in) :: xlong(nlon,nlat) ! longitude - real(r_single),intent(in) :: xlat(nlon,nlat) ! latitude - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potentional temperature - real(r_single),intent(inout) :: p_bk(nlon,nlat,nsig) ! pressure - real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height - real(r_single),intent(in) :: zh(nlon,nlat) ! terrain - real(r_single), intent(in) :: xland(nlon,nlat) ! surface - real(r_single),intent(in) :: soil_tbk(nlon,nlat) ! soil tmperature -! real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) -! -! Observation -! - real(r_single),intent(inout) :: sat_ctp(nlon,nlat) - real(r_single),intent(inout) :: sat_tem(nlon,nlat) - real(r_single),intent(inout) :: w_frac(nlon,nlat) - integer(i_kind),intent(out) :: nlev_cld(nlon,nlat) -! -! Turn on cloud building and height limit - logical, intent(in) :: l_cld_bld - real(r_kind), intent(in) :: cld_bld_hgt - real(r_kind), intent(in) :: build_cloud_frac_p - real(r_kind), intent(in) :: clear_cloud_frac_p -! -! Variables for cloud analysis -! - real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) -! -!------------------------------------------------------------------------- -! --- Key parameters -! Cloud_def_p = 0.000001 g/g cloud top threshold for model -! Min_cloud_lev_p = 3 Lowest model level to check for cloud -! Rh_clear_p = 0.80 RH to use when clearing cloud -! Sat_cloud_pthick_p= 50. Depth (mb) of new sat-sensed cloud layer -! cloud_zthick_p = 300. Depth (m) of new cloud layer -! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice -! saturation mixing ratio for new cloud -! Max_cloud_top_p = 150. Max cloud top (mb) -! RH_makecloud_p = 0.90 RH threshold for making cloud if bkg -! rh is at least this high at -! neighboring points -! Cloud_up_p = 10 Pressure thickness for -! Upward extrapolation of cloud -! (if model level is within cloud_up_p -! mb of sat cloud level) -! min_cloud_p_p = 960. Max pressure at which NESDIS cloud -! info is considered reliable -! (i.e., not reliable at low levels) - -! zen_limit = 0.20 Solar zenith angle - lower limit -! at which sun is considered -! high enough to trust the -! GOES cloud data - - real(r_kind) :: Cloud_def_p - integer(i_kind) :: min_cloud_lev_p - real(r_kind) :: Rh_clear_p - real(r_kind) :: sat_cloud_pthick_p - real(r_kind) :: cloud_zthick_p - real(r_kind) :: Cloud_q_qvis_rat_p - real(r_kind) :: Max_cloud_top_p - real(r_kind) :: RH_makecloud_p - real(r_kind) :: cloud_up_p - real(r_kind) :: min_cloud_p_p - real(r_kind) :: co2_preslim_p - real(r_kind) :: auto_conver - real(r_kind) :: zen_limit - real(r_kind) :: dt_remap_pcld_limit_p - -! --- Key parameters - data Cloud_def_p / 0.000001_r_kind/ - data Min_cloud_lev_p / 1_i_kind / ! w/ sfc cld assim -! data Min_cloud_lev_p / 3_i_kind / ! w/ sfc cld assim - data Rh_clear_p / 0.80_r_kind/ - data Sat_cloud_pthick_p / 30._r_kind/ -! data Sat_cloud_pthick_p / 50._r_kind/ - data cloud_zthick_p / 300._r_kind/ - data Cloud_q_qvis_rat_p / 0.05_r_kind/ - data Max_cloud_top_p / 150._r_kind/ - data RH_makecloud_p / 0.90_r_kind/ - data cloud_up_p / 0._r_kind / - data min_cloud_p_p / 1080._r_kind/ ! w/ sfc cld assim - data co2_preslim_p / 620._r_kind/ - data auto_conver / 0.0002_r_kind/ -! -- change to 82 deg per Patrick Minnis - 4 Nov 09 - data zen_limit / 0.14_r_kind/ -! data zen_limit / 0.20_r_kind / - data dt_remap_pcld_limit_p / 3.5_r_kind / -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: null_p - REAL(r_kind) :: spval_p - PARAMETER ( null_p = -1 ) - PARAMETER ( spval_p = 99999.0 ) - - INTEGER(i_kind) :: i,j,k,k1,i1,j1,jp1,jm1,ip1,im1 - REAL(r_kind) :: ri, rj - INTEGER(i_kind) :: gmt,nday,iyear,imonth,iday - REAL(r_kind) :: declin - real(r_kind) :: hrang,xxlat - real(r_single) :: csza(nlon,nlat) - - INTEGER(i_kind) :: ndof_tot, npts_clear, npts_build, npts_bel650 - INTEGER(i_kind) :: npts_warm_cld_flag, npts_tskin_flag, npts_stab_flag, npts_ptly_cloudy - real (r_single) :: tbk_k(nlon,nlat,nsig) - - INTEGER(i_kind) :: npts_ctp_change, npts_ctp_delete, npts_ctp_nobuddy - INTEGER(i_kind) :: npts_clr_nobuddy,npts_ctp_marine_remap - real (r_single) :: dctp, dctpabs - - real(r_single) :: tsmin - - INTEGER(i_kind) :: kisotherm, ibuddy, ktempmin - real(r_kind) :: tempmin,dth2dp2, stab, stab_threshold - - real(r_kind) :: firstcloud, pdiff,pdiffabove - - INTEGER(i_kind) :: ista, k_closest, cld_warm_strat(nlon,nlat) - REAL(r_kind) :: dist, tdiff - -! -!==================================================================== -! Begin -! -! calculation solar declination -! - iyear=regional_time(1) - imonth=regional_time(2) - iday=regional_time(3) - call getdays(nday,iyear,imonth,iday) - declin=deg2rad*23.45_r_kind*sin(2.0_r_kind*pi*(284+nday)/365.0_r_kind) - - cld_warm_strat=-1 -! -! from mb to Pa -! - do k = 1,nsig - do j = 1,nlat - do i = 1,nlon -! qw=q_bk(i,j,k)/(1. + q_bk(i,j,k)) ! convert to specific humidity - tbk_k(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to temperature(K) - p_bk(i,j,k) = p_bk(i,j,k)*100._r_kind - end do - end do - end do - - if( p_bk(nlon/2,nlat/2,2) < 5000.0_r_kind ) then - write(6,*) 'cloudCover_NESDIS: pressure unit check failed', p_bk(nlon/2,nlat/2,2) - call stop2(114) - endif - if( tbk_k(nlon/2,nlat/2,nsig-2) > 300._r_kind) then - write(6,*) 'cloudCover_NESDIS: temperature unit check failed', & - tbk_k(nlon/2,nlat/2,nsig-2) - call stop2(114) - endif - -! -! csza = fraction of solar constant (cos of zenith angle) - gmt = regional_time(4) ! UTC - do j=2,nlat-1 - do i=2,nlon-1 - hrang= (15._r_kind*gmt + xlong(i,j) - 180._r_kind )*deg2rad - xxlat=xlat(i,j)*deg2rad - csza(i,j)=sin(xxlat)*sin(declin) & - +cos(xxlat)*cos(declin)*cos(hrang) - end do - end do - -! -! start checking the data -! - ndof_tot = 0 !counting total number of grids of sat info - npts_clear = 0 - npts_build = 0 - npts_bel650 = 0 - npts_tskin_flag = 0 - npts_stab_flag = 0 - npts_ptly_cloudy = 0 - - do j=2,nlat-1 - do i=2,nlon-1 - jp1 = min(j+1,nlat) - jm1 = max(j-1,1 ) - ip1 = min(i+1,nlon) - im1 = max(i-1,1 ) - tsmin = soil_tbk(i,j) -! --- Determine min skin temp in 3x3 around grid point. -! This is to detect nearby presence of coastline. - do j1 = jm1,jp1 - do i1 = im1,ip1 - tsmin = min(tsmin,soil_tbk(i1,j1) ) - end do - end do - - if ( w_frac(i,j) > -1._r_kind & - .and. (sat_tem(i,j)-soil_tbk(i,j)) > 4._r_kind & - .and. soil_tbk(i,j) < 263._r_kind & - .and. sat_ctp(i,j) > co2_preslim_p & - .and. sat_ctp(i,j) < 1010._r_kind & - .and. xland(i,j) /=0.0 & - .and. p_bk(i,j,1)/100. >=850._r_kind ) then -! w_frac(i,j) = -99999._r_kind -! sat_tem(i,j) = 99999._r_kind -! sat_ctp(i,j) = 0._r_kind -! nlev_cld(i,j) = -999 - npts_warm_cld_flag = npts_warm_cld_flag + 1 - cld_warm_strat(i,j)=5 - end if -! PH changed condition to match RUC: Tcld-Tskin(bkg) < 4, > -2 - if ( w_frac(i,j) > -1._r_kind & - .and. (sat_tem(i,j)-tsmin) > -2._r_kind & - .and. (sat_tem(i,j)-tsmin) <= 4._r_kind & - .and. sat_ctp(i,j) > co2_preslim_p & - .and. sat_ctp(i,j) < 1010._r_kind & - .and. xland(i,j) /=0.0 & - .and. p_bk(i,j,1)/100._r_kind>= 950._r_kind ) then - w_frac(i,j) = -99999._r_kind - sat_tem(i,j) = 99999._r_kind - sat_ctp(i,j) = 0._r_kind - nlev_cld(i,j)= -999 - npts_tskin_flag = npts_tskin_flag + 1 - cld_warm_strat(i,j)=4 - end if - if (w_frac(i,j)<=clear_cloud_frac_p .and. & - w_frac(i,j)>-1._r_kind) then - sat_ctp(i,j) = 1013.0_r_kind - npts_clear = npts_clear + 1 - cld_warm_strat(i,j)=0 - end if - if (w_frac(i,j) > clear_cloud_frac_p.and. & - w_frac(i,j) < build_cloud_frac_p) then -! w_frac(i,j) = -99999._r_kind - sat_tem(i,j)= 99999._r_kind -! mhu: this can cause problem: a miss line between cloud and clean, set it to clean -! PH: for CLAVR data, just set sat_ctp = 0. - sat_ctp(i,j) = 0._r_kind - nlev_cld(i,j)= -999 - npts_ptly_cloudy = npts_ptly_cloudy + 1 - cld_warm_strat(i,j)=1 - end if - if (w_frac(i,j) >= build_cloud_frac_p.and. & - sat_ctp(i,j) < 1050) then - npts_build = npts_build + 1 - cld_warm_strat(i,j)=2 - end if - if (sat_ctp(i,j)>co2_preslim_p .and. sat_ctp(i,j)<1010._r_kind) & - npts_bel650 = npts_bel650 + 1 - -! -- nlev_cld = 1 if cloud info is present -! -- nlev_cld = 0 if no cloud info is at this grid point - - if(nlev_cld(i,j) >= 1) ndof_tot = ndof_tot + 1 - end do ! i - end do ! j -! - if(mype==0) then - write(6,*) 'cloudCover_NESDIS: TOTAL NUMBER OF GRID pts w/ GOES CLOUD data =',ndof_tot - write(6,*) 'cloudCover_NESDIS: CLEAR NUMBER OF GRID pts w/ GOES CLOUD data =',npts_clear - write(6,*) 'cloudCover_NESDIS: BUILD NUMBER OF GRID pts w/ GOES CLOUD data =',npts_build - write(6,*) 'cloudCover_NESDIS: PTCLDY NUMBER OF GRID pts w/ GOES CLOUD data =',npts_ptly_cloudy - write(6,*) 'cloudCover_NESDIS: > 650mb - no OF GRID pts w/ GOES CLOUD data =',npts_bel650 - write(6,*) 'cloudCover_NESDIS: Flag CTP - skin temp too close to TB, no=',npts_tskin_flag - write(6,*) 'cloudCover_NESDIS: Clear -> cloud frac < clear frac' - write(6,*) 'cloudCover_NESDIS: Build -> cloud frac > build frac' - endif - -! -!! -! - npts_ctp_change = 0 - npts_ctp_delete = 0 - npts_ctp_nobuddy = 0 - npts_clr_nobuddy = 0 - npts_ctp_marine_remap = 0 - dctp = 0. - dctpabs = 0. - -! - stability threshold for building cloud - 3K / 100 mb (10000 Pa) - - stab_threshold = 3._r_kind/10000._r_kind - do j=2,nlat-1 - do i=2,nlon-1 - -! -- GOES indicates clouds in the lower troposphere - if (sat_ctp(i,j) < 1010._r_kind .and. sat_ctp(i,j) > co2_preslim_p) then - - tdiff = 999. - k_closest = -1 - do k=3,nsig-1 -! Attempt remapping if within 75 hPa (arbitrary) - if ((sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind)< 75._r_kind) then - if (abs(sat_tem(i,j)-tbk_k(i,j,k)) < tdiff) then - k_closest = k - tdiff = abs(sat_tem(i,j)-tbk_k(i,j,k)) - end if - end if - end do ! k loop - - if (k_closest <= 0 .and. xland(i,j) /= 0.0) then - npts_ctp_delete = npts_ctp_delete + 1 - write (6,*) i,j,sat_tem(i,j),tdiff,k_closest,xland(i,j) - go to 111 - end if - - k = k_closest - - if( xland(i,j) /=0.0 ) then -! PH: dt_limit was hardwired to 1.5K, changed it to 3.5K to match RUC - if ((tdiff < dt_remap_pcld_limit_p) .or. & - (cld_warm_strat(i,j) == 5 .and. tdiff < 4._r_kind )) then - dctpabs = dctpabs + abs(sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) - dctp = dctp+ (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) - k1 = k - -1115 continue - -! --- This stability check only for reassigining CTP using RUC bkg profile. -! There is a later general check also. - stab = (t_bk(i,j,k1+1)-t_bk(i,j,k1)) & - /(p_bk(i,j,k1)-p_bk(i,j,k1+1)) - if (stab < stab_threshold) then - k1 = k1 + 1 - if ((p_bk(i,j,k)-p_bk(i,j,k1)) > 5000._r_kind) then - w_frac(i,j) = -99999._r_kind - sat_tem(i,j) = 99999._r_kind - sat_ctp(i,j) = 99999._r_kind - nlev_cld(i,j) = -999 - npts_stab_flag= npts_stab_flag + 1 - go to 111 - end if - go to 1115 - end if - - sat_ctp(i,j) = p_bk(i,j,k)/100._r_kind - npts_ctp_change = npts_ctp_change + 1 - go to 111 - else - npts_ctp_delete = npts_ctp_delete + 1 -! write (6,*) i,j,sat_tem(i,j),tdiff - go to 111 - end if - - else ! xland==0: over water - -! --- Remap marine cloud to min temp level below 880 mb -! if no matching RUC temp already found - - if (sat_ctp(i,j)>880._r_kind)then - tempmin = -500._r_kind - -! --- Look thru lowest 15 levels for lowest temp for -! level to put marine cloud at. -! --- Start at level 3 - kisotherm = 20 - ktempmin = 20 - do k=min_cloud_lev_p+2,15 - if (p_bk(i,j,k)/100._r_kind .lt. 880._r_kind) go to 1101 - dth2dp2 = t_bk(i,j,k+1)+t_bk(i,j,k-1)-2._r_kind*t_bk(i,j,k) - if (kisotherm==0 .and. & - tbk_k(i,j,k) < tbk_k(i,j,k+1)) kisotherm = k - if (dth2dp2>tempmin) then - ktempmin = k - tempmin = max(dth2dp2,tempmin) - end if - end do -1101 continue - ktempmin = min(ktempmin,kisotherm) - sat_ctp(i,j) = p_bk(i,j,ktempmin)/100._r_kind - npts_ctp_marine_remap = npts_ctp_marine_remap + 1 - end if ! sat_ctp(i,j)>880._r_kind - endif ! xland == 0 - end if -111 continue - enddo ! i - enddo ! j - - if(mype==0) then - write(6,*) 'cloudCover_NESDIS: Flag CTP - unstable w/i 50mb of CTP, no=', npts_stab_flag - write(6,*) 'cloudCover_NESDIS: Flag CTP - can''t remap CTP, no=', npts_ctp_delete - write(6,*) 'cloudCover_NESDIS: Flag CTP -remap marine cloud, no=', npts_ctp_marine_remap - endif - - if (npts_ctp_change > 0) then - if(mype==0) write (6,1121) npts_ctp_change, dctp/float(npts_ctp_change), & - dctpabs/float(npts_ctp_change) -1121 format (/'No. of pts w/ cloud-top pres change = ',i6 & - /'Mean cloud-top pres change (old-new)= ',f8.1 & - /'Mean abs cloud-top pres change = ',f8.1/) - end if -! -! --- Make sure that any cloud point has another cloud point nearby. -! Otherwise, get rid of it. - do j=2,nlat-1 - do i=2,nlon-1 - if (sat_ctp(i,j)< 1010._r_kind .and. sat_ctp(i,j)>50._r_kind) then - ibuddy = 0 - do j1=j-1,j+1 - do i1=i-1,i+1 - if (sat_ctp(i1,j1)<1010._r_kind .and. sat_ctp(i1,j1)>50._r_kind) ibuddy = 1 - end do - end do - if (ibuddy==0) then - w_frac(i,j) = -99999._r_kind - sat_tem(i,j) = 99999._r_kind - sat_ctp(i,j) = 99999._r_kind - nlev_cld(i,j) = -999 - npts_ctp_nobuddy = npts_ctp_nobuddy + 1 - end if - end if - if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j) <1100._r_kind) then - ibuddy = 0 - do j1=j-1,j+1 - do i1=i-1,i+1 - if (sat_ctp(i1,j1) > 1010._r_kind .and. sat_ctp(i1,j1) <1100._r_kind) ibuddy = 1 - end do - end do - if (ibuddy == 0) then - w_frac(i,j) = -99999._r_kind - sat_tem(i,j) = 99999._r_kind - sat_ctp(i,j) = 99999._r_kind - nlev_cld(i,j) = -999 - npts_clr_nobuddy = npts_clr_nobuddy + 1 - end if - end if - enddo - enddo - - if(mype==0) then - write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ cloud, no=', & - npts_ctp_nobuddy - - write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ clear, no=', & - npts_clr_nobuddy - endif - -! -! ***************************************************************** -! ***************************************************************** -! Start to adjust to GOES cloud top pressure -! ***************************************************************** -! ***************************************************************** - -! --- clear where GOES shows clear down to the surface -! or down to the GOES cloud top level - -! ============================================= -! - clear down to surface in fully clear column (according to GOES) -! ============================================= -! Only trust 'clear' indication under following conditions -! - over ocean -! - or over land only if p<620 mb overnight -! - or at any level in daytime (zenith angle -! greater than zen_limit threshold) -! ============================================= - do j=2,nlat-1 - do i=2,nlon-1 - if (sat_ctp(i,j) >=1010.0_r_kind .and. sat_ctp(i,j) <1050._r_kind) then !clear - do k=1,nsig - if (csza(i,j)=zen_limit) then - cld_cover_3d(i,j,k) = 0 - wthr_type(i,j) = 0 - end if - end do -!mhu: use 1060hps cloud top pressure to clean above the low cloud top - elseif (abs(sat_ctp(i,j)-1060.0_r_kind) < 1.0_r_kind) then !clear since the low cloud top - do k=1,nsig - if (csza(i,j)=zen_limit) then - if( abs(cld_cover_3d(i,j,k)) > 2 ) then - cld_cover_3d(i,j,k) = 0 - wthr_type(i,j) = 0 - endif - end if - end do - end if - enddo - enddo -! ============================================= -! - clearing above cloud top -! ============================================= - - do j=2,nlat-1 - do i=2,nlon-1 - do k=1,nsig-1 -! - return to previous (but experimental) version - 12 Oct 04 - if (csza(i,j) < zen_limit & - .and. p_bk(i,j,k)/100._r_kind=zen_limit) then -! --- since we set GOES to nearest RUC level, only clear at least -! 1 RUC level above cloud top - if (sat_ctp(i,j)<1010._r_kind .and. & - sat_ctp(i,j)>p_bk(i,j,k)/100._r_kind) then -! -! mhu, some low cloud top press (> 800 hpa) over clean the cloud that observed by METAR -! so add these check to keep cloud base correct -! - if(sat_ctp(i,j) >= 800.0_r_kind ) then - cld_cover_3d(i,j,k+1) = & - max(0.0_r_single, cld_cover_3d(i,j,k+1)) - else - cld_cover_3d(i,j,k+1) = 0 - endif - endif - end if - end do - enddo - enddo - -! print *, 'h_bk max: ', maxval(h_bk(:,:,1)), ' min: ', minval(h_bk(:,:,1)) - -! ============================================= -! - start building where GOES indicates so -! ============================================= - do j=2,nlat-1 - do i=2,nlon-1 - - if ((w_frac(i,j)>= build_cloud_frac_p) .and. & - (w_frac(i,j)< 99999._r_kind) )then !Dongsoo added - -! --- Cloud info below MIN_CLOUD_P not reliable - firstcloud = 0 -! - pdiff (diff between sat cloud top and model sfc pres) in mb - do k=nsig-1,min_cloud_lev_p,-1 - pdiff = (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) -! --- set closest RUC level w/ cloud - if (pdiff<=0. .and. firstcloud==0) then - pdiffabove = sat_ctp(i,j)-p_bk(i,j,k+1)/100._r_kind - if (abs(pdiffabove) 800 hpa) over clean the cloud that observed by METAR -! so add these check to keep cloud base correct -! - if(sat_ctp(i,j) >= 800.0_r_kind ) then - cld_cover_3d(i,j,k+1) = max(0.0_r_single, cld_cover_3d(i,j,k+1)) - else - cld_cover_3d(i,j,k+1) = 0 - endif - firstcloud = 1 - end if - end if - -! no cloud above cloud top - -! -! --- Add 50mb thick (at least 1 level) of cloud where GOES -! indicates cloud top - if (xland(i,j)/=0._r_single) then - if (sat_ctp(i,j)< min_cloud_p_p .and. & - pdiff<=cloud_up_p ) then - if (firstcloud==0.or. firstcloud==1 & - .and.pdiff >= -1.*sat_cloud_pthick_p) then -! sgb - 2/7/2012 - remove this condition -! Allow cloud building below CO2_preslim and at night and over land -! if (p_bk(i,j,k)/100._r_kind= -1.*sat_cloud_pthick_p) then -! xland ==0 if (p_bk(i,j,k)/100..lt.co2_preslim_p) then - if (l_cld_bld .and. h_bk(i,j,k+1) < cld_bld_hgt) then - cld_cover_3d(i,j,k)=1 - else - cld_cover_3d(i,j,k)=-99998 - end if - firstcloud = 1 - end if - end if - end if - - end do - end if - enddo ! j - enddo - -! go from pa to mb - do k = 1,nsig - do j = 2,nlat-1 - do i = 2,nlon-1 - p_bk(i,j,k) = p_bk(i,j,k)/100._r_kind - end do - end do - end do -! -END SUBROUTINE cloudCover_NESDIS - diff --git a/lib/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 b/lib/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 deleted file mode 100755 index 2f350c271..000000000 --- a/lib/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 +++ /dev/null @@ -1,411 +0,0 @@ -SUBROUTINE cloudCover_Surface(mype,nlat,nlon,nsig,r_radius,thunderRadius,& - t_bk,p_bk,q,h_bk,zh, & - mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,Odist,& - cld_cover_3d,cld_type_3d,wthr_type,pcp_type_3d, & - watericemax, kwatericemax) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudCover_Surface cloud cover analysis using surface observation -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 -! -! ABSTRACT: -! This subroutine determines 3D cloud fractional cover using surface observations -! Code based on RUC assimilation code (hybfront/hybcloud.f) -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! r_radius - influence radius of the cloud observation -! thunderRadius - -! -! t_bk - 3D background potentional temperature (K) -! p_bk - 3D background pressure (hPa) -! q - 3D moisture (water vapor mixing ratio) -! h_bk - 3D background height (m) -! zh - terrain (m) -! -! mxst_p - maximum observation number -! NVARCLD_P - first dimension of OLCD -! numsao - observation number -! OI - observation x location -! OJ - observation y location -! OLCD - cloud amount, cloud height, visibility -! OWX - weather observation -! Oelvtn - observation elevation -! Odist - distance from the nearest station -! -! output argument list: -! cld_cover_3d- 3D cloud cover -! cld_type_3d - 3D cloud type -! wthr_type - 3D weather type -! pcp_type_3d - 3D weather precipitation type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - REAL(r_single), intent(in) :: r_radius - integer(i_kind),intent(in) :: nlat,nlon,nsig - real(r_single), intent(in) :: thunderRadius -! -! surface observation -! - INTEGER(i_kind),intent(in) :: mxst_p,NVARCLD_P - -! PARAMETER (LSTAID_P=9) - - INTEGER(i_kind),intent(in) :: numsao - real(r_single), intent(in) :: OI(mxst_p) ! x location - real(r_single), intent(in) :: OJ(mxst_p) ! y location - INTEGER(i_kind),intent(in) :: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, - ! visibility - CHARACTER*10, intent(in) :: OWX(mxst_p) ! weather - real(r_single), intent(in) :: Oelvtn(mxst_p) ! elevation - real(r_single), intent(in) :: Odist(mxst_p) ! distance from the nearest station - -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure - real(r_single),intent(in) :: zh(nlon,nlat) ! terrain - real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) - real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height -! - REAL(r_single),intent(in) :: watericemax(mxst_p) ! max of background total liquid water in station - INTEGER(i_kind),intent(in):: kwatericemax(nlon,nlat) ! lowest level of background total liquid water in grid -! -! Variables for cloud analysis -! - real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) - integer(i_kind),intent(inout) :: pcp_type_3d(nlon,nlat,nsig) -! -! local -! - real (r_single) :: vis2qc(nlon,nlat) - real (r_single) :: cloud_zthick_p - data cloud_zthick_p /300._r_kind/ -! - REAL (r_kind) :: spval_p - PARAMETER ( spval_p = 99999.0_r_kind ) - - INTEGER(i_kind) :: i,j,k,k1 - INTEGER(i_kind) :: i1,j1,ic - INTEGER(i_kind) :: nx_p, ny_p, nztn_p - INTEGER(i_kind) :: ista - INTEGER(i_kind) :: ich, iob,job - - REAL(r_kind) :: min_dist, dist - REAL(r_kind) :: zdiff - REAL(r_kind) :: zlev_clr,cloud_dz,cl_base_ista,betav -! -! -! - real(r_single):: tbk_k(nlon,nlat,nsig) - real(r_single):: cv_bk(nlon,nlat,nsig) - real(r_single):: z_lcl(nlon,nlat) - REAL(r_kind) :: cf_model_base,t_model_base, ht_base - REAL(r_kind) :: t_dry_adiabat,t_inversion_strength - - LOGICAL :: l_cf,l_inversion - LOGICAL :: if_cloud_exist - - integer(i_kind) :: firstcloud,cl_base_broken_k - real(r_single) :: underlim - integer(i_kind) :: npts_near_clr - - -!==================================================================== -! Begin -! -! set constant names consistent with original RUC code -! - nx_p=nlon - ny_p=nlat - nztn_p=nsig - - vis2qc=-9999.0_r_kind - npts_near_clr=0 -! -! -!***************************************************************** -! analysis of surface/METAR cloud observations -! ***************************************************************** - - DO ista=1,numsao - i1 = int(oi(ista)+0.0001_r_kind) - j1 = int(oj(ista)+0.0001_r_kind) - min_dist = Odist(ista) - -!mh - grid point has the closest cloud station - -! -- find out if any precip is present - do ich=1,1 - if ( owx(ista)(ich:ich+1)=='SH' ) wthr_type(i1,j1)=16 - if ( owx(ista)(ich:ich+1)=='TH' .and. & - min_dist < thunderRadius) wthr_type(i1,j1)=1 - if ( owx(ista)(ich:ich+1)=='RA' ) wthr_type(i1,j1)=11 - if ( owx(ista)(ich:ich+1)=='SN' ) wthr_type(i1,j1)=12 - if ( owx(ista)(ich:ich+1)=='PL' ) wthr_type(i1,j1)=13 - if ( owx(ista)(ich:ich+1)=='DZ' ) wthr_type(i1,j1)=14 - if ( owx(ista)(ich:ich+1)=='UP' ) wthr_type(i1,j1)=15 - if ( owx(ista)(ich:ich+1)=='BR' ) wthr_type(i1,j1)=21 - if ( owx(ista)(ich:ich+1)=='FG' ) wthr_type(i1,j1)=22 - enddo - -! Consider clear condition case -! ----------------------------- - if (ocld(1,ista)==0) then - - do ic=1,6 - if(float(abs(ocld(6+ic,ista))) < 55555) then - write(6,*) 'cloudCover_Surface: Observed cloud above the clear level !!!' - write(6,*) 'cloudCover_Surface: some thing is wrong in surface cloud observation !' - write(6,*) 'cloudCover_Surface: check the station no.', ista, 'at process ', mype - write(6,*) ic,OI(ista),OJ(ista) - write(6,*) (ocld(k,ista),k=1,12) - call stop2(114) - endif - enddo -! clean the whole column up to ceilometer height (12 kft) if ob is CLR -! h_bk is AGL, not ASL (per Ming Hu's notes below -! -! zlev_clr = Oelvtn(ista)+3650. -! Upcoming mods commented out below for this commit - 4/3/2010 -! PH: added in column cleaning up to ceilometer height if ob is CLR - zlev_clr = 3650. - - do k=1,nztn_p - if (h_bk(i1,j1,k) < zlev_clr) then - cld_cover_3d(i1,j1,k)=0.0_r_kind - pcp_type_3d(i1,j1,k)=0 - endif - end do - - wthr_type(i1,j1)=0 - -! -- Now consider non-clear obs -! -------------------------- - else - -! increase zthick by 1.5x factor for ceiling < 900 m (~3000 ft - MVFR) - cloud_dz = cloud_zthick_p - cl_base_broken_k = -9 -! ????? check with Stan O(h_p) if (Oelvtn(ista).lt.900.) cloud_dz = cloud_zthick_p * 2 - - do ic = 1,6 - if (ocld(ic,ista)>0 .and. ocld(ic,ista)<50) then -! if ( csza(i,j)>=0.10 .and. sat_ctp(i1,j1)>1010.0 & -! .and. sat_ctp(i1,j1)<1050.) go to 1850 -! -! New tweak - 11/07/2009 -! If there was cloud in background over station but if there -! was partial cloudiness within volume and this is one of the -! clear columns within the polygonal area for this METAR, -! then leave it that way and skip. -! if (watericemax(iob,job).gt.0. .and. -! 1 kwatericemax(iob,job).gt.0 .and. -! 1 kwatericemax(iob,job).le.12) then -! npts_cld_match = npts_cld_match + 1 -! dzbase = cl_base_ista - g3(iob,job,kwatericemax(iob,job),h_p) -! sum_dzbase = sum_dzbase + dzbase -! sum_dzbase_abs = sum_dzbase_abs + abs(dzbase) -! end if - -! if (watericemax(ista) > 0._r_single .and. kwatericemax(i1,j1)==-1) then -! npts_near_clr = npts_near_clr + 1 -! cycle ! skip cloud build at point (i,j) because background is clear -! end if - - if(ocld(ic,ista) == 4) then - if(wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) cloud_dz = 1000._r_kind - ! precipitation + highest level - if(wthr_type(i1,j1) == 1) cloud_dz = 10000._r_kind ! thunderstorm - endif - -! --- calculate cloud ceiling level, not exactly, FEW SCT are also considered now -! iob = int(oi(ista)-idw+0.5) -! job = int(oj(ista)-ids+0.5) -! cl_base_ista = (float(ocld(6+ic,ista))+zh(iob,job)) -! cl_base_ista = (float(ocld(6+ic,ista))+Oelvtn(ista)) -! the h_bk is AGL. So observation cloud base should be AGL too, delete Oelvtn(ista) -! cover cloud base observation from AGL to ASL - cl_base_ista = float(ocld(6+ic,ista)) + Oelvtn(ista) - zh(i1,j1) - if(zh(i1,j1) < 1.0_r_kind .and. Oelvtn(ista) > 20.0_r_kind & - .and. float(ocld(6+ic,ista)) < 250.0_r_kind) then - cycle ! limit the use of METAR station over oceas for low cloud base - endif - - firstcloud = 0 - underlim = 10._r_kind ! - - do k=1,nztn_p - zdiff = cl_base_ista - h_bk(i1,j1,k) -! Must be within cloud_dz meters (300 or 1000 currently) -! ------------------------------------------------------------------- -! -- Bring in the clouds if model level is within 10m under cloud level. - if(k==1) underlim=(h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.5_r_kind - if(k==2) underlim=10.0_r_kind ! 100 feet - if(k==3) underlim=20.0_r_kind ! 300 feet - if(k==4) underlim=15.0_r_kind ! 500 feet - if(k==5) underlim=33.0_r_kind ! 1000 feet - if (k>=6 .and. k <= 7) underlim = (h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.6_r_kind - if(k==8) underlim=95.0_r_kind ! 3000 feet - if(k>=9 .and. k= 1.0 .and. (firstcloud==0 .or. abs(zdiff) 10 .and. wthr_type(i1,j1) < 20) then -! cld_type_3d(i1,j1,k)=5 - pcp_type_3d(i1,j1,k)=1 - endif - else - write(6,*) 'cloudCover_Surface: wrong cloud coverage observation!' - call stop2(114) - endif - firstcloud = firstcloud + 1 - end if ! zdiff < cloud_dz - else -! ---- Clear up to cloud base of first cloud level - if (ic==1) cld_cover_3d(i1,j1,k)=0 - if (ocld(ic,ista) == 1) pcp_type_3d(i1,j1,k)=0 - if (ocld(ic,ista) == 3 .or. ocld(ic,ista) == 4) then - if( (wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) & - .or. wthr_type(i1,j1) == 1 ) then - pcp_type_3d(i1,j1,k)=1 - endif - endif - end if ! underlim - end do ! end K loop -! ----clean cloud above stratusphere - do k=1,nztn_p - if( h_bk(i1,j1,k) > 18000 ) cld_cover_3d(i1,j1,k)=0 - enddo -! - end if ! end if ocld > 0 - end do ! end IC loop -! -! clean up to broken (3) or if cloud cover less than 2, clean to cloud top -! - if(cl_base_broken_k > 0 .and. cl_base_broken_k < nztn_p) then - do k=1, cl_base_broken_k - if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 - enddo - else - if(ocld(1,ista) == 1 .or. ocld(1,ista) == 2 ) then - do k=1, nztn_p - if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 - enddo - endif - endif - - end if ! end if cloudy ob ocld(1,ista) > 0 - -! -- Use visibility for low-level cloud whether - if (wthr_type(i1,j1) < 30 .and. wthr_type(i1,j1) > 20 .and. & - ocld(13,ista) < 5000 .and. ocld(13,ista) > 1) then - cld_type_3d(i1,j1,1) = 2 - cld_type_3d(i1,j1,2) = 2 - betav = 3.912_r_kind / (float(ocld(13,ista)) / 1000._r_kind) - vis2qc(i1,j1) = ( (betav/144.7_r_kind) ** 1.14_r_kind) / 1000._r_kind - endif ! cloud or clear - - ENDDO ! ista - - -! Determine if the layer is dry or it has inversion. -! (in either case, the cloud will be cleared out) -! - IF(.false.) THEN ! Set inversion strength flag - call BckgrndCC(nlon,nlat,nsig, & - t_bk,p_bk,q,h_bk,zh, & - cv_bk,tbk_k,z_lcl) ! out - - DO j = 1,nlat - DO i = 1,nlon - - if_cloud_exist=.false. - do k=nsig-1,2,-1 - if(cld_cover_3d(i,j,k) > 0.01_r_kind) then - cf_model_base = cv_bk(i,j,k) - t_model_base = tbk_k(i,j,k) - ht_base=h_bk(i,j,k) - if_cloud_exist=.true. - endif - enddo -! -! note, do we need to consider cloud base from background - if(if_cloud_exist) then - do k=2, nsig-1 - if(cld_cover_3d(i,j,k) > 0.01_r_kind) then - l_cf=.false. - l_inversion=.false. - t_dry_adiabat = tbk_k(i,j,2) -.0098_r_kind * (h_bk(i,j,k) - h_bk(i,j,2)) - t_inversion_strength = tbk_k(i,j,k) - t_dry_adiabat - - IF( (tbk_k(i,j,k) > t_model_base) .and. & - (tbk_k(i,j,k) > 283.15_r_kind) .and. & ! temp check - (t_inversion_strength > 4._r_kind) ) then ! delta theta chk - l_inversion = .true. ! Inversion exists - endif - IF( (cv_bk(i,j,k) < cf_model_base - 0.3_r_kind) .and. & - (h_bk(i,j,k) - ht_base >= 500._r_kind) ) THEN - l_cf = .true. ! Dry layer exists - ENDIF - if(l_inversion) then - cld_cover_3d(i,j,k) =0.0_r_kind - endif - endif ! in cloud - enddo ! k - endif ! if_cloud_exist = true - - ENDDO ! i - ENDDO ! j - - END IF ! .true. for dry-inversion check. - -END SUBROUTINE cloudCover_Surface - diff --git a/lib/GSD/gsdcloud4nmmb/cloudCover_radar.f90 b/lib/GSD/gsdcloud4nmmb/cloudCover_radar.f90 deleted file mode 100755 index b38419e81..000000000 --- a/lib/GSD/gsdcloud4nmmb/cloudCover_radar.f90 +++ /dev/null @@ -1,137 +0,0 @@ -SUBROUTINE cloudCover_radar(mype,nlat,nlon,nsig,h_bk,zh,grid_ref, & - cld_cover_3d,cld_type_3d,wthr_type) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudCover_radar cloud cover analysis using radar reflectivity -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 -! -! ABSTRACT: -! This subroutine find cloud cover using radar reflectivity -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! 2015-02-24 S.Liu adjust cloud cover based on reflectivity observations -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! h_bk - 3D background height -! zh - terrain -! grid_ref - radar reflectivity in analysis grid -! -! output argument list: -! cld_cover_3d- 3D cloud cover -! cld_type_3d - 3D cloud type -! wthr_type - 3D weather type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use constants, only: deg2rad, rad2deg, pi - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - integer(i_kind),intent(in) :: nlat,nlon,nsig -! -! background -! - real(r_single), intent(in) :: zh(nlon,nlat) ! terrain - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig+1) ! height -! -! Observation -! - real(r_kind), intent(in) :: grid_ref(nlon,nlat,nsig) -! -! Variables for cloud analysis -! - real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) - integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) -! - REAL(r_kind) :: ref_base ! "significant" radar echo at upper levels -! - REAL(r_kind) :: cloud_base -! -!----------------------------------------------------------- -! -! threshold -! - - REAL(r_kind) :: radar_cover - PARAMETER(radar_cover=1.02) - REAL(r_kind) :: thresh_cvr ! lower radar echo threshold for cloud filling - PARAMETER (thresh_cvr = 0.9) -! -! temp. -! - INTEGER(i_kind) :: i,j,k,k1 - REAL(r_kind) :: zs_1d(nsig) - -! -!==================================================================== -! Begin -! -! ref_base = 15.0 -! set ref_base is 35.0 dbz, assuming cloud water will coexist with rain/snow -! based on discussion with Eric Aligo - ref_base = 35.0 -! -!----------------------------------------------------------------------- -! -! Essentially, this go downward to detect radar tops in time -! to search for a new cloud base -! -!----------------------------------------------------------------------- -! - - DO i = 2,nlon-1 - DO j = 2,nlat-1 - - DO k=1,nsig - zs_1d(k) = h_bk(i,j,k) - END DO - - cloud_base = 200000._r_kind -! - DO k = nsig-1,1,-1 - IF( (cld_cover_3d(i,j,k) < thresh_cvr) .and. & - (cld_cover_3d(i,j,k+1) >= thresh_cvr .and. & - cld_cover_3d(i,j,k+1) < 2.0_r_kind) ) THEN - cloud_base = 0.5_r_kind * (zs_1d(k) + zs_1d(k+1)) - END IF - END DO ! k - - - DO k = 6, nsig-1 - if(grid_ref(i,j,k) > ref_base ) then - cld_cover_3d(i,j,k)=radar_cover - endif - ENDDO ! k - - ENDDO ! i - ENDDO ! j -! - -END SUBROUTINE cloudCover_radar - diff --git a/lib/GSD/gsdcloud4nmmb/cloudLWC.f90 b/lib/GSD/gsdcloud4nmmb/cloudLWC.f90 deleted file mode 100755 index dd636206d..000000000 --- a/lib/GSD/gsdcloud4nmmb/cloudLWC.f90 +++ /dev/null @@ -1,418 +0,0 @@ -SUBROUTINE cloudLWC_stratiform(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk, & - cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & - cldwater_3d,cldice_3d) -! -! find cloud liquid water content -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudLWC_stratiform find cloud liquid water content -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine calculate liquid water content for stratiform cloud -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! q_bk - 3D moisture -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! cld_cover_3d- 3D cloud cover -! cld_type_3d - 3D cloud type -! wthr_type - 3D weather type -! cloudlayers_i - 3D cloud layer index -! -! output argument list: -! cldwater_3d - 3D cloud water mixing ratio (g/kg) -! cldice_3d - 3D cloud ice mixing ratio (g/kg) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind, r_kind - - implicit none - - integer(i_kind),intent(in):: mype - integer(i_kind),intent(in):: nlat,nlon,nsig -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature - real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure -! -! -! Variables for cloud analysis -! - real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: wthr_type(nlon,nlat) -! -! cloud layers -! - integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers -! 1= the number of layers -! 2,4,... bottom -! 3,5,... top -! -! cloud water and cloud ice -! - real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) - real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) - real (r_single) :: cloudtmp_3d(nlon,nlat,nsig) -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k,ilvl,nlvl - INTEGER(i_kind) :: kb,kt,k1 - real(r_single) :: p_pa_1d(nsig), thv(nsig) - real(r_single) :: cld_base_m, cld_top_m - real(r_single) :: cld_base_qc_m, cld_top_qc_m - real(r_single) :: cloudqvis(nlon,nlat,nsig) - real(r_single) :: rh(nlon,nlat,nsig) - -! --- Key parameters -! Rh_clear_p = 0.80 RH to use when clearing cloud -! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice - - real(r_single) Cloud_q_qvis_rat_p, cloud_q_qvis_ratio - real(r_single) auto_conver - real(r_single) cloud_def_p - real(r_single) rh_cld3_p - real(r_single) rh_clear_p - data Cloud_q_qvis_rat_p/ 0.05_r_single/ - data auto_conver /0.0002_r_single/ - data cloud_def_p /0.000001_r_single/ - data rh_cld3_p /0.98_r_single/ ! mhu, do we need to adjust this number to 0.94, WPP has PBL top set as 0.95 - data rh_clear_p /0.8_r_single/ - - real(r_kind) :: es0_p - parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) - real(r_kind) SVP1,SVP2,SVP3 - data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ - - real(r_kind) :: temp_qvis1, temp_qvis2 - data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ - - REAL(r_kind) stab, stab_threshold - LOGICAL :: l_prt - INTEGER(i_kind) :: iflag_slwc - INTEGER(i_kind) :: kp3,km3 - - REAL(r_kind) :: q, Temp, tv, evs, qvs1, eis, qvi1, watwgt, qavail -! -!==================================================================== -! Begin -! - cldwater_3d=-99999.9_r_kind - cldice_3d=-99999.9_r_kind - cloudtmp_3d=-99999.9_r_kind -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - rh=0.0 - DO j = 2,nlat-1 - DO i = 2,nlon-1 -! - DO k = 2,nsig-1 - p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single - q = q_bk(i,j,k)/(1._r_single+q_bk(i,j,k)) ! Q = water vapor specific humidity - ! q_bk = water vapor mixing ratio - tv = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp -! now, tmperature from GSI s potential temperature - Temp = tv ! temperature -! evs, eis in mb - evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) - qvs1 = 0.62198_r_kind*evs*100._r_kind/(p_pa_1d(k)-100._r_kind*evs) ! qvs1 is mixing ratio kg/kg, so no need next line -! qvs1 = qvs1/(1.0-qvs1) - eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) - qvi1 = 0.62198_r_kind*eis*100._r_kind/(p_pa_1d(k)-100._r_kind*eis) ! qvi1 is mixing ratio kg/kg, so no need next line -! qvi1 = qvi1/(1.0-qvi1) -! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) -! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 - watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& - (temp_qvis1-temp_qvis2))) - cloudtmp_3d(i,j,k)= Temp - cloudqvis(i,j,k)= (watwgt*qvs1 + (1._r_kind-watwgt)*qvi1) -! qvis(i,j,k)= (watwgt*qvs1 + (1.-watwgt)*qvi1) - rh(i,j,k) = q_bk(i,j,k)/cloudqvis(i,j,k) - enddo - enddo ! i - enddo ! j - - stab_threshold = 3._r_kind/10000._r_kind - DO j = 2,nlat-1 - DO i = 2,nlon-1 - DO k = 1,nsig - p_pa_1d(k) = p_bk(i,j,k)*100.0_r_kind - thv(k) = t_bk(i,j,k)*(1.0_r_kind + 0.6078_r_kind*q_bk(i,j,k)) - ENDDO - nlvl=cloudlayers_i(i,j,1) - if(nlvl > 0 ) then - DO ilvl = 1, nlvl ! loop through cloud layers - kb=cloudlayers_i(i,j,2*ilvl) - kt=cloudlayers_i(i,j,2*ilvl+1) - DO k = kb,kt - -! -- change these to +/- 3 vertical levels - kp3 = min(nsig,k+5) - km3 = max(1 ,k) - stab = (thv(kp3)-thv(km3))/(p_pa_1d(km3)-p_pa_1d(kp3)) - -! -- stability check. Use 2K/100 mb above 600 mb and -! 3K/100mb below (nearer sfc) - if ((stab600._r_kind) & - .or. stab<0.66_r_kind*stab_threshold ) then -! write(*,'(a,3i4,f8.3)') 'skip building cloud in stable layer',i,j,k,stab*10000.0 - cld_cover_3d(i,j,k)=-99999.0 - elseif(rh(i,j,k) < 0.40 .and. ((cloudqvis(i,j,k)-q_bk(i,j,k)) > 0.003_r_kind)) then -! write(*,'(a,3i4,2f6.2)') 'skip building cloud in too-dry layer',i,j,k,& -! rh(i,j,k),(cloudqvis(i,j,k)-q_bk(i,j,k))*1000.0 - cld_cover_3d(i,j,k)=-99999.0_r_single - else -!dk * we need to avoid adding cloud if sat_ctp is lower than 650mb -! ph - 2/7/2012 - use a temperature-dependent cloud_q_qvis_ratio -! and with 0.1 smaller condensate mixing ratio building also for temp < 263.15 - Temp = cloudtmp_3d(i,j,k) - watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& - (temp_qvis1-temp_qvis2))) - cloud_q_qvis_ratio = watwgt*cloud_q_qvis_rat_p & - + (1.0-watwgt)*0.1*cloud_q_qvis_rat_p - qavail = min(0.5_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) - -! ------------------------------------------------------------------- -! - set cloud water mixing ratio - no more than 0.1 g/kg, -! which is the current autoconversion mixing ratio set in exmoisg -! according to John Brown - 14 May 99 -! ------------------------------------------------------------------- - cldwater_3d(i,j,k) = watwgt*qavail*1000.0_r_kind ! g/kg -! - set ice mixing ratio - cldice_3d(i,j,k)= (1.-watwgt)*qavail*1000.0_r_kind ! g/kg -! end if - end if - enddo ! k - enddo ! ilvl - endif ! nlvl > 1 - enddo ! i - enddo ! j - -END SUBROUTINE cloudLWC_stratiform - -SUBROUTINE cloudLWC_Cumulus(nlat,nlon,nsig,h_bk,t_bk,p_bk, & - cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & - cldwater_3d,cldice_3d,cloudtmp_3d) -! -! find cloud liquid water content -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudLWC_Cumulus find cloud liquid water content for cumulus cloud -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine calculates liquid water content for cumulus cloud -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! h_bk - 3D height -! t_bk - 3D background potentional temperature (K) -! p_bk - 3D background pressure (hPa) -! cld_cover_3d- 3D cloud cover -! cld_type_3d - 3D cloud type -! wthr_type - 3D weather type -! cloudlayers_i - 3D cloud layer index -! -! output argument list: -! cldwater_3d - 3D cloud water mixing ratio (g/kg) -! cldice_3d - 3D cloud ice mixing ratio (g/kg) -! cloudtmp_3d - 3D cloud temperature -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind,r_kind - - implicit none - integer(i_kind),intent(in) :: nlat,nlon,nsig -! -! surface observation -! -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature - real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure -! -! -! Variables for cloud analysis -! - real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: wthr_type(nlon,nlat) -! -! cloud layers -! - integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers -! 1= the number of layers -! 2,4,... bottom -! 3,5,... top -! -! cloud water and cloud ice -! - real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) - real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) - real (r_single),intent(out) :: cloudtmp_3d(nlon,nlat,nsig) -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k,ilvl,nlvl - INTEGER(i_kind) :: kb,kt,k1 - real (r_single) :: zs_1d(nsig) - real (r_single) :: cv_1d(nsig) - real (r_single) :: t_1d(nsig) - real (r_single) :: p_pa_1d(nsig) - real (r_single) :: p_mb_1d(nsig) - real (r_single) :: cld_base_m, cld_top_m - real (r_single) :: cld_base_qc_m, cld_top_qc_m - - real (r_single) :: slwc_1d(nsig) - real (r_single) :: cice_1d(nsig) - real (r_single) :: ctmp_1d(nsig) - - LOGICAL :: l_prt - INTEGER(i_kind) :: iflag_slwc -! -!==================================================================== -! Begin -! - l_prt =.false. - iflag_slwc = 11 - cldwater_3d=-99999.9_r_single - cldice_3d =-99999.9_r_single - cloudtmp_3d=-99999.9_r_single -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - DO j = 2,nlat-1 - DO i = 2,nlon-1 -! - DO k = 1,nsig ! Initialize - t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp - zs_1d(k) = h_bk(i,j,k) - p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single - p_mb_1d(k) = p_bk(i,j,k) - END DO -!----------------------------------------------------------------------- - nlvl=cloudlayers_i(i,j,1) - if(nlvl > 0 ) then - DO ilvl = 1, nlvl ! loop through cloud layers - - kb=cloudlayers_i(i,j,2*ilvl) - kt=cloudlayers_i(i,j,2*ilvl+1) - - cld_base_m = 0.5_r_single * (zs_1d(kb-1) + zs_1d(kb)) - cld_top_m = 0.5_r_single * (zs_1d(kt) + zs_1d(kt+1)) -! - IF(iflag_slwc /= 0) THEN - IF(iflag_slwc < 10) THEN ! simple adiabatc scheme - CALL get_slwc1d (nsig,cld_base_m,cld_top_m,kb,kt & - ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) - - ELSE ! iflag_slwc > 10, new Smith-Feddes scheme - DO k1 = 1,nsig ! Initialize - slwc_1d(k1) = 0.0_r_single - cice_1d(k1) = 0.0_r_single - ctmp_1d(k1) = t_bk(i,j,k1) - END DO -! -!----------------------------------------------------------------------- -! -! QC the data going into SMF -! -!----------------------------------------------------------------------- -! - IF(cld_top_m > zs_1d(nsig-1) - 110._r_single) THEN - cld_top_qc_m = zs_1d(nsig-1) - 110._r_single - cld_base_qc_m = & - MIN(cld_base_m,cld_top_qc_m - 110._r_single) - ELSE ! normal case - cld_top_qc_m = cld_top_m - cld_base_qc_m = cld_base_m - END IF -! - CALL get_sfm_1d(nsig,cld_base_qc_m,cld_top_qc_m & - ,zs_1d,p_mb_1d,t_1d & - ,slwc_1d,cice_1d,ctmp_1d,l_prt) -! - END IF ! iflag_slwc < 10 - END IF ! iflag_slwc .ne. 0 -! - DO k1 = kb,kt ! Loop through the cloud layer - IF(iflag_slwc /= 0) THEN - IF(slwc_1d(k1) > 0._r_single) cldwater_3d(i,j,k1)=slwc_1d(k1) - IF(cice_1d(k1) > 0._r_single) cldice_3d(i,j,k1)=cice_1d(k1) - cloudtmp_3d(i,j,k1)=ctmp_1d(k1) - END IF ! iflag_slwc .ne. 0 - END DO ! k1 - - enddo ! ilvl - endif ! nlvl > 0 - - ENDDO ! i - ENDDO ! j - -END SUBROUTINE cloudLWC_Cumulus diff --git a/lib/GSD/gsdcloud4nmmb/cloudLayers.f90 b/lib/GSD/gsdcloud4nmmb/cloudLayers.f90 deleted file mode 100755 index ac63b99d9..000000000 --- a/lib/GSD/gsdcloud4nmmb/cloudLayers.f90 +++ /dev/null @@ -1,167 +0,0 @@ -SUBROUTINE cloudLayers(nlat,nlon,nsig,h_bk,zh,cld_cover_3d,cld_type_3d, & - cloudlayers_i) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudLayers find cloud layers -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 -! -! ABSTRACT: -! This subroutine find cloud layer based on cloud cover -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! h_bk - 3D background height -! zh - terrain -! cld_cover_3d- 3D cloud cover -! cld_type_3d - 3D cloud type -! -! output argument list: -! cloudlayers_i - 3D cloud layer index -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind - - implicit none - - integer(i_kind),intent(in) :: nlat,nlon,nsig -! -! background -! - real(r_single), intent(in) :: zh(nlon,nlat) ! terrain - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height -! -! Variables for cloud analysis -! - real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) -! -! output -! - integer(i_kind),intent(out):: cloudlayers_i(nlon,nlat,21) ! 5 different layers -! 1= the number of layers -! 2,4,... bottom -! 3,5,... top -! -! threshold - real (r_single) :: thresh_cvr - parameter ( thresh_cvr = 0.1 ) -!----------------------------------------------------------- -! -! temp. -! - INTEGER :: i,j,k,k1,nlvl - INTEGER :: k_top,k_base - real (r_single) :: zs_1d(nsig) - real (r_single) :: cv_1d(nsig) -! -!==================================================================== -! Begin -! - cloudlayers_i=-99999 -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - - DO j = 2,nlat-1 - DO i = 2,nlon-1 -! Initialize - DO k = 1,nsig - zs_1d(k) = h_bk(i,j,k) - cv_1d(k) = cld_cover_3d(i,j,k) - END DO -! -!----------------------------------------------------------------------- -! -! Get Base and Top -! -!----------------------------------------------------------------------- -! - k=1 - nlvl=0 - DO WHILE (k <= nsig-1) - - IF((cv_1d(k+1) >= thresh_cvr .and. cv_1d(k)= thresh_cvr) ) THEN - k_base = k + 1 - - k = k + 1 - DO WHILE (cv_1d(k) >= thresh_cvr .and. k < nsig) - k_top = k -! -!----------------------------------------------------------------------- -! -! We have now defined a cloud base and top -! -!----------------------------------------------------------------------- -! - k=k+1 - enddo - k=k-1 -!----------------------------------------------------------------------- -! -! Make sure cloud base and top stay in the model domain -! -!----------------------------------------------------------------------- -! - nlvl=nlvl+2 - if(nlvl > 20 ) then - write(6,*) 'cloudLayers: Too many cloud layers in grid point:' - write(6,*) i,j - call stop2(114) - endif - cloudlayers_i(i,j,nlvl) = MIN(k_base,nsig-1) - cloudlayers_i(i,j,nlvl+1) = MIN(k_top,nsig-1) - endif -! - k=k+1 - ENDDO ! k -! - cloudlayers_i(i,j,1) = nlvl/2 - ENDDO - ENDDO -! -! -! - DO j = 2,nlat-1 - DO i = 2,nlon-1 - if(cloudlayers_i(i,j,1) > 0 ) then - do k=1,cloudlayers_i(i,j,1) - if(cloudlayers_i(i,j,k) < 0 .or. cloudlayers_i(i,j,k) > 55555) then - write(6,*) 'cloudLayers: ckeck', i,j,k, cloudlayers_i(i,j,k) - endif - enddo - endif - enddo - enddo -! - -END SUBROUTINE cloudLayers - diff --git a/lib/GSD/gsdcloud4nmmb/cloudType.f90 b/lib/GSD/gsdcloud4nmmb/cloudType.f90 deleted file mode 100755 index 2b97e7250..000000000 --- a/lib/GSD/gsdcloud4nmmb/cloudType.f90 +++ /dev/null @@ -1,147 +0,0 @@ -SUBROUTINE cloudType(nlat,nlon,nsig,h_bk,t_bk,p_bk,radar_3d, & - cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloudType decide cloud type -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine decide cloud type -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! h_bk - 3D background height -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! radar_3d - 3D radar reflectivity in analysis grid (dBZ) -! -! cld_cover_3d- 3D cloud cover -! wthr_type - 3D weather type -! cloudlayers_i - 3D cloud layer index -! -! output argument list: -! cld_type_3d - 3D cloud type -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000, half - use kinds, only: r_single,i_kind,r_kind - - implicit none - integer(i_kind),INTENT(IN) :: nlat,nlon,nsig -! -! background -! - real(r_single),INTENT(IN) :: h_bk(nlon,nlat,nsig) ! height - real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! temperature - real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure -! -! observation -! - real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity -! -! Variables for cloud analysis -! - real (r_single), INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind), INTENT(IN) :: wthr_type(nlon,nlat) - integer(i_kind),INTENT(OUT) :: cld_type_3d(nlon,nlat,nsig) -! -! cloud layers -! - integer(i_kind), INTENT(IN) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers -! 1= the number of layers -! 2,4,... bottom -! 3,5,... top -! -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k,ilvl,nlvl - INTEGER(i_kind) :: itype - INTEGER(i_kind) :: kb,kt,k1 - real(r_single) :: cld_base_m, cld_top_m - - real (r_single) :: zs_1d(nsig) - real (r_single) :: dte_dz_1d(nsig) - real (r_single) :: t_1d(nsig) - real (r_single) :: p_mb_1d(nsig) -! - CHARACTER (LEN=2) :: c2_type -! -!==================================================================== -! Begin -! -!----------------------------------------------------------------------- -! -! Find Cloud Layers and Computing Output Field(s) -! The procedure works column by column. -! -!----------------------------------------------------------------------- -! - return - - DO j = 2,nlat-1 - DO i = 2,nlon-1 -! - DO k = 1,nsig ! Initialize - t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp !K - zs_1d(k) = h_bk(i,j,k) - p_mb_1d(k) = p_bk(i,j,k) - END DO -!----------------------------------------------------------------------- - nlvl=cloudlayers_i(i,j,1) - if(nlvl > 10 ) then - write(*,*) 'warning: too many cloud levels' - nlvl=10 - endif - if(nlvl > 0 ) then - DO ilvl = 1, nlvl ! loop through cloud layers - kb=cloudlayers_i(i,j,2*ilvl) - kt=cloudlayers_i(i,j,2*ilvl+1) - - CALL get_stability (nsig,t_1d,zs_1d,p_mb_1d & - ,kb,kt,dte_dz_1d) - - cld_base_m = half * (zs_1d(kb-1) + zs_1d(kb)) - cld_top_m = half * (zs_1d(kt) + zs_1d(kt+1)) - DO k1 = kb,kt - CALL get_cloudtype(t_1d(k1),dte_dz_1d(k1) & - ,cld_base_m,cld_top_m,itype,c2_type) -! - IF(radar_3d(i,j,k1) > 45._r_kind) THEN - itype = 10 ! CB - END IF - - cld_type_3d(i,j,k1) = itype - END DO !k1 - enddo ! ilvl - endif ! nlvl > 0 - - ENDDO ! i - ENDDO ! j - -END SUBROUTINE cloudType - diff --git a/lib/GSD/gsdcloud4nmmb/cloud_saturation.f90 b/lib/GSD/gsdcloud4nmmb/cloud_saturation.f90 deleted file mode 100755 index 17ffe8467..000000000 --- a/lib/GSD/gsdcloud4nmmb/cloud_saturation.f90 +++ /dev/null @@ -1,315 +0,0 @@ -SUBROUTINE cloud_saturation(mype,l_conserve_thetaV,i_conserve_thetaV_iternum, & - nlat,nlon,nsig,q_bk,t_bk,p_bk, & - cld_cover_3d,wthr_type, & - cldwater_3d,cldice_3d,sumqci) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: cloud_saturation to ensure water vapor saturation at all cloudy grid points -! also to ensure sub saturation in clear point -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 -! -! ABSTRACT: -! This subroutine calculate liquid water content for stratiform cloud -! -! PROGRAM HISTORY LOG: -! 2010-10-06 Hu check whole 3D mositure field and get rid of supersaturation -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! q_bk - 3D moisture -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! cldwater_3d - 3D analysis cloud water mixing ratio (g/kg) -! cldice_3d - 3D analysis cloud ice mixing ratio (g/kg) -! cld_cover_3d- 3D cloud cover -! wthr_type - 3D weather type -! l_conserve_thetaV - if .true. conserving thetaV -! i_conserve_thetaV_iternum - iteration number for conserving thetaV -! -! output argument list: -! q_bk - 3D moisture -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use constants, only: rd_over_cp, h1000,one,zero,fv - use kinds, only: r_single,i_kind, r_kind - - implicit none - - integer(i_kind),intent(in):: mype - integer(i_kind),intent(in):: nlat,nlon,nsig - logical,intent(in):: l_conserve_thetaV - integer(i_kind),intent(in):: i_conserve_thetaV_iternum -! -! background -! - real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) - real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) - REAL(r_kind),intent(in) :: sumqci(nlon,nlat,nsig) ! total liquid water -! -! Variables for cloud analysis -! - real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) - integer(i_kind),intent(in) :: wthr_type(nlon,nlat) -! -! cloud water and cloud ice -! - real (r_single),intent(in) :: cldwater_3d(nlon,nlat,nsig) ! kg/kg - real (r_single),intent(in) :: cldice_3d(nlon,nlat,nsig) ! kg/kg -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k,ilvl,nlvl - INTEGER(i_kind) :: kb,kt,k1 - real(r_single) :: thv(nsig) - real(r_single) :: cloudqvis,cloudqvis2,ruc_saturation - -! --- Key parameters -! Rh_clear_p = 0.80 RH to use when clearing cloud - - real(r_single) rh_cld3_p - real(r_single) rh_clear_p - data rh_cld3_p /0.98_r_single/ ! mhu, do we need to adjust this number to 0.94, WPP has PBL top set as 0.95 - data rh_clear_p /0.8_r_single/ - - real(r_kind) :: es0_p - parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) - real(r_kind) SVP1,SVP2,SVP3 - data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ - - INTEGER(i_kind) :: kp3,km3,miter,nnn - - REAL(r_kind) :: constantTv, Temp, evs, qvs1, eis, qvi1, watwgt,Temp1 - real(r_single) :: qtemp, qinc,qtemp1 -! -!==================================================================== -! Begin -! -! - miter=i_conserve_thetaV_iternum ! iteration number for conserving Tv - - DO j = 2,nlat-1 - DO i = 2,nlon-1 - DO k = 2,nsig-1 - -!mhu p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single -! qv= q_bk(i,j,k)/(one+q_bk(i,j,k)) ! qv = water vapor specific humidity -! ! q_bk = water vapor mixing ratio -! now, tmperature from GSI s potential temperature. get temperature - Temp = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp - Temp1=Temp - -! now, calculate saturation -! - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) -! -! moisture adjustment based on cloud -! -! -! check each grid point to make sure no supersaturation - q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) -! now, calculate constant virtual temperature - constantTv=Temp*(one + fv*q_bk(i,j,k)) -! - if(cld_cover_3d(i,j,k) > -0.0001_r_kind .and. & - cld_cover_3d(i,j,k) < 2.0_r_kind) then - if(cld_cover_3d(i,j,k) <= 0.0001_r_kind) then -! adjust RH to be below 85 percent(50%?) if -! 1) cloudyn = 0 -! 2) at least 100 mb above sfc -! 3) no precip from sfc obs -!make sure that clear volumes are no more than rh_clear_p RH. - if( (sumqci(i,j,k))>0.0_r_kind .and. & - (p_bk(i,j,1) - p_bk(i,j,k))>100._r_kind .and. & - wthr_type(i,j) <=0 ) then - if( q_bk(i,j,k) > cloudqvis * rh_clear_p) then - qtemp = cloudqvis * rh_clear_p - if(l_conserve_thetaV) then - do nnn=1,miter - Temp=constantTv/(one + fv*qtemp) - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) - qtemp = cloudqvis * rh_clear_p - enddo - t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp - endif - q_bk(i,j,k) = qtemp - endif - endif -!C - moisten layers above and below cloud layer - if(cld_cover_3d(i,j,k+1) > 0.6_r_kind .or. & - cld_cover_3d(i,j,k-1) > 0.6_r_kind ) then - if( cloudqvis > q_bk(i,j,k) ) then - qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) - if(l_conserve_thetaV) then - do nnn=1,miter - Temp=constantTv/(one + fv*qtemp) - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) - qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) - enddo - t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp - endif - q_bk(i,j,k)=qtemp - endif - endif -! -- If SCT/FEW present, reduce RH only down to rh_cld3_p (0.98) -! corresponding with cloudyn=3 - elseif(cld_cover_3d(i,j,k) > 0.0001_r_kind .and. & - cld_cover_3d(i,j,k) < 0.6_r_kind ) then - if( q_bk(i,j,k) > cloudqvis * rh_cld3_p) then - qtemp = cloudqvis * rh_cld3_p - if(l_conserve_thetaV) then - do nnn=1,miter - Temp=constantTv/(one + fv*qtemp) - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) - qtemp = cloudqvis * rh_cld3_p - enddo - t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp - endif - q_bk(i,j,k) = qtemp - endif - else ! set qv at 102%RH - if( q_bk(i,j,k) < cloudqvis * 1.02_r_single ) then - qtemp = cloudqvis * 1.02_r_single - q_bk(i,j,k) = q_bk(i,j,k)+0.5*(qtemp-q_bk(i,j,k)) -! q_bk(i,j,k) = qtemp - if(l_conserve_thetaV) then - do nnn=1,miter - Temp=constantTv/(one + fv*qtemp) - cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) - qtemp = q_bk(i,j,k)+0.5*(qtemp-q_bk(i,j,k)) -! qtemp = cloudqvis * 1.02_r_single - enddo -! t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp - t_bk(i,j,k) = t_bk(i,j,k)+ 0.5*(Temp*(h1000/p_bk(i,j,k))**rd_over_cp-t_bk(i,j,k)) - endif -! q_bk(i,j,k) = qtemp - endif - endif -! if(abs(temp1-temp)>0)then -! write(6,*)'check temp::',temp1,temp -! end if - else ! cloud cover is missing -! Ensure saturation in all cloudy volumes. -! Since saturation has already been ensured for new cloudy areas (cld_cover_3d > 0.6) -! we now ensure saturation for all cloud 3-d points, whether cloudy from background -! (and not changed - cld_cover_3d < 0) -! If cloud cover is missing, (cldwater_3d(i,j,k)+cldice_3d(i,j,k) = sumqci(i,j,k), -! which is background cloud liquid water. - cloudqvis2 = min (cloudqvis, 0.018_r_single) ! Limit new water vapor mixing ratio - ! in cloud to 18 g/kg - if ((cldwater_3d(i,j,k)+cldice_3d(i,j,k))>1.0e-5_r_kind) & - q_bk(i,j,k) = max(cloudqvis2,q_bk(i,j,k)) - endif -! -! check each grid point to make sure no supersaturation -! -! q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) -! - - enddo ! k - enddo ! i - enddo ! j - -END SUBROUTINE cloud_saturation - -function ruc_saturation(Temp,pressure) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: ruc_saturation calculate saturation -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-11-28 -! -! ABSTRACT: -! This subroutine calculate saturation -! -! PROGRAM HISTORY LOG: -! 2011-11-28 Hu Initial -! -! -! input argument list: -! pressure - background pressure (hPa) -! Temp - temperature (K) -! -! output argument list: -! ruc_saturation -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ - - use constants, only: rd_over_cp, h1000,one,zero - use kinds, only: r_single,i_kind, r_kind -! - implicit none - real(r_single) :: ruc_saturation - - REAL(r_kind), intent(in) :: Temp ! temperature in K - real(r_single),intent(in) :: pressure ! pressure (hpa) - - real(r_kind) :: es0_p - parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) - real(r_kind) SVP1,SVP2,SVP3 - data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ - - real(r_kind) :: temp_qvis1, temp_qvis2 - data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ - - REAL(r_kind) :: evs, qvs1, eis, qvi1, watwgt -! - -! -! evs, eis in mb -! For this part, must use the water/ice saturation as f(temperature) - evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) - qvs1 = 0.62198_r_kind*evs/(pressure-evs) ! qvs1 is mixing ratio kg/kg - ! so no need next line -! qvs1 = qvs1/(1.0-qvs1) -! Get ice saturation and weighted ice/water saturation ready to go -! for ensuring cloud saturation below. - eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) - qvi1 = 0.62198_r_kind*eis/(pressure-eis) ! qvi1 is mixing ratio kg/kg, - ! so no need next line -! qvi1 = qvi1/(1.0-qvi1) -! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) -! watwgt = max(zero,min(one,(Temp-251.15_r_kind)/& -! (263.15_r_kind-251.15_r_kind))) -! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 - watwgt = max(zero,min(one,(Temp-temp_qvis2)/& - (temp_qvis1-temp_qvis2))) - ruc_saturation= (watwgt*qvs1 + (one-watwgt)*qvi1) ! kg/kg -! -end function ruc_saturation diff --git a/lib/GSD/gsdcloud4nmmb/constants.f90 b/lib/GSD/gsdcloud4nmmb/constants.f90 deleted file mode 100755 index 9d4263197..000000000 --- a/lib/GSD/gsdcloud4nmmb/constants.f90 +++ /dev/null @@ -1,324 +0,0 @@ -module constants -!$$$ module documentation block -! . . . . -! module: constants -! prgmmr: treadon org: np23 date: 2003-09-25 -! -! abstract: This module contains the definition of various constants -! used in the gsi code -! -! program history log: -! 2003-09-25 treadon - original code -! 2004-03-02 treadon - allow global and regional constants to differ -! 2004-06-16 treadon - update documentation -! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind -! and tiny_single -! 2004-11-16 treadon - add huge_single, huge_r_kind parameters -! 2005-01-27 cucurull - add ione -! 2005-08-24 derber - move cg_term to constants from qcmod -! 2006-03-07 treadon - add rd_over_cp_mass -! 2006-05-18 treadon - add huge_i_kind -! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) -! 2006-07-28 derber - add r1000 -! 2007-03-20 rancic - add r3600 -! 2009-02-05 cucurull - modify refractive indexes for gpsro data -! -! Subroutines Included: -! sub init_constants_derived - compute derived constants -! sub init_constants - set regional/global constants -! -! Variable Definitions: -! see below -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - - use kinds, only: r_single,r_kind,i_kind,r_quad,i_long - implicit none - -! set default as private - private -! set subroutines as public - public :: init_constants_derived - public :: init_constants -! set passed variables to public - public :: one,two,ione,half,zero,izero,deg2rad,pi,three,quarter,one_tenth - public :: rad2deg,zero_quad,r3600,r1000,r60inv,five,four,rd_over_cp,grav - public :: rd,rozcon,rearth_equator,zero_single,tiny_r_kind,tiny_single - public :: omega,rcp,rearth,fv,h300,cp,cg_term,tpwcon,xb,ttp,psatk,xa,tmix - public :: xai,xbi,psat,eps,omeps,wgtlim,one_quad,epsq,climit,epsm1,hvap - public :: hsub,cclimit,el2orc,elocp,h1000,cpr,pcpeff0,pcpeff2,delta,pcpeff1 - public :: factor1,c0,pcpeff3,factor2,dx_inv,dx_min,rhcbot,rhctop,hfus,ke2 - public :: rrow,cmr,cws,r60,huge_i_kind,huge_r_kind,t0c,rd_over_cp_mass - public :: somigliana,grav_equator,grav_ratio,flattening,semi_major_axis - public :: n_b,n_a,eccentricity,huge_single,constoz,g_over_rd,amsua_clw_d2 - public :: amsua_clw_d1,n_c,rd_over_g,zero_ilong - -! Declare derived constants - integer(i_kind):: huge_i_kind - real(r_single):: tiny_single, huge_single - real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g - real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 - real(r_kind):: factor1, huge_r_kind, tiny_r_kind, deg2rad, pi, rad2deg, cg_term - real(r_kind):: eccentricity_linear, cv, rv, rd_over_cp_mass, cliq, rd, cp_mass - real(r_kind):: eccentricity, grav, rearth, r60inv - - -! Define constants common to global and regional applications - real(r_kind),parameter:: rearth_equator= 6.37813662e6_r_kind ! equatorial earth radius (m) - real(r_kind),parameter:: omega = 7.2921e-5_r_kind ! angular velocity of earth (1/s) - real(r_kind),parameter:: cp = 1.0046e+3_r_kind ! specific heat of air @pressure (J/kg/K) - real(r_kind),parameter:: cvap = 1.8460e+3_r_kind ! specific heat of h2o vapor (J/kg/K) - real(r_kind),parameter:: csol = 2.1060e+3_r_kind ! specific heat of solid h2o (ice)(J/kg/K) - real(r_kind),parameter:: hvap = 2.5000e+6_r_kind ! latent heat of h2o condensation (J/kg) - real(r_kind),parameter:: hfus = 3.3358e+5_r_kind ! latent heat of h2o fusion (J/kg) - real(r_kind),parameter:: psat = 6.1078e+2_r_kind ! pressure at h2o triple point (Pa) - real(r_kind),parameter:: t0c = 2.7315e+2_r_kind ! temperature at zero celsius (K) - real(r_kind),parameter:: ttp = 2.7316e+2_r_kind ! temperature at h2o triple point (K) - real(r_kind),parameter:: jcal = 4.1855e+0_r_kind ! joules per calorie () - real(r_kind),parameter:: stndrd_atmos_ps = 1013.25e2_r_kind ! 1976 US standard atmosphere ps (Pa) - -! Numeric constants - integer(i_kind),parameter:: izero = 0_i_kind - integer(i_kind),parameter:: ione = 1_i_kind - - integer(i_long),parameter:: zero_ilong = 0_i_long - - real(r_single),parameter:: zero_single= 0.0_r_single - - real(r_kind),parameter:: zero = 0.0_r_kind - real(r_kind),parameter:: one_tenth = 0.10_r_kind - real(r_kind),parameter:: quarter = 0.25_r_kind - real(r_kind),parameter:: one = 1.0_r_kind - real(r_kind),parameter:: two = 2.0_r_kind - real(r_kind),parameter:: three = 3.0_r_kind - real(r_kind),parameter:: four = 4.0_r_kind - real(r_kind),parameter:: five = 5.0_r_kind - real(r_kind),parameter:: r60 = 60._r_kind - real(r_kind),parameter:: r1000 = 1000.0_r_kind - real(r_kind),parameter:: r3600 = 3600.0_r_kind - - real(r_quad),parameter:: zero_quad = 0.0_r_quad - real(r_quad),parameter:: one_quad = 1.0_r_quad - - -! Constants for gps refractivity (Bevis et al 1994) - real(r_kind),parameter:: n_a = 77.60_r_kind ! K/mb - real(r_kind),parameter:: n_b = 3.739e+5_r_kind ! K^2/mb - real(r_kind),parameter:: n_c = 70.4_r_kind ! K/mb - -! Parameters below from WGS-84 model software inside GPS receivers. - real(r_kind),parameter:: semi_major_axis = 6378.1370e3_r_kind ! (m) - real(r_kind),parameter:: semi_minor_axis = 6356.7523142e3_r_kind ! (m) - real(r_kind),parameter:: grav_polar = 9.8321849378_r_kind ! (m/s2) - real(r_kind),parameter:: grav_equator = 9.7803253359_r_kind ! (m/s2) - real(r_kind),parameter:: earth_omega = 7.292115e-5_r_kind ! (rad/s) - real(r_kind),parameter:: grav_constant = 3.986004418e14_r_kind ! (m3/s2) - -! Derived geophysical constants - real(r_kind),parameter:: flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis - real(r_kind),parameter:: somigliana = & - (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one - real(r_kind),parameter:: grav_ratio = (earth_omega*earth_omega * & - semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant - -! Derived thermodynamic constants - real(r_kind),parameter:: dldti = cvap-csol - real(r_kind),parameter:: hsub = hvap+hfus - real(r_kind),parameter:: psatk = psat*0.001_r_kind - real(r_kind),parameter:: tmix = ttp-20._r_kind - real(r_kind),parameter:: elocp = hvap/cp - real(r_kind),parameter:: rcp = one/cp - -! Constants used in GFS moist physics - real(r_kind),parameter:: h300 = 300._r_kind - real(r_kind),parameter:: half = 0.5_r_kind - real(r_kind),parameter:: cclimit = 0.001_r_kind - real(r_kind),parameter:: climit = 1.e-20_r_kind - real(r_kind),parameter:: epsq = 2.e-12_r_kind - real(r_kind),parameter:: h1000 = r1000 - real(r_kind),parameter:: rhcbot=0.85_r_kind - real(r_kind),parameter:: rhctop=0.85_r_kind - real(r_kind),parameter:: dx_max=-8.8818363_r_kind - real(r_kind),parameter:: dx_min=-5.2574954_r_kind - real(r_kind),parameter:: dx_inv=one/(dx_max-dx_min) - real(r_kind),parameter:: c0=0.002_r_kind - real(r_kind),parameter:: delta=0.6077338_r_kind - real(r_kind),parameter:: pcpeff0=1.591_r_kind - real(r_kind),parameter:: pcpeff1=-0.639_r_kind - real(r_kind),parameter:: pcpeff2=0.0953_r_kind - real(r_kind),parameter:: pcpeff3=-0.00496_r_kind - real(r_kind),parameter:: cmr = one/0.0003_r_kind - real(r_kind),parameter:: cws = 0.025_r_kind - real(r_kind),parameter:: ke2 = 0.00002_r_kind - real(r_kind),parameter:: row = r1000 - real(r_kind),parameter:: rrow = one/row - -! Constant used to process ozone - real(r_kind),parameter:: constoz = 604229.0_r_kind - -! Constants used in cloud liquid water correction for AMSU-A -! brightness temperatures - real(r_kind),parameter:: amsua_clw_d1 = 0.754_r_kind - real(r_kind),parameter:: amsua_clw_d2 = -2.265_r_kind - -! Constants used for variational qc - real(r_kind),parameter:: wgtlim = quarter ! Cutoff weight for concluding that obs has been - ! rejected by nonlinear qc. This limit is arbitrary - ! and DOES NOT affect nonlinear qc. It only affects - ! the printout which "counts" the number of obs that - ! "fail" nonlinear qc. Observations counted as failing - ! nonlinear qc are still assimilated. Their weight - ! relative to other observations is reduced. Changing - ! wgtlim does not alter the analysis, only - ! the nonlinear qc data "count" - -contains - - subroutine init_constants_derived -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants_derived set derived constants -! prgmmr: treadon org: np23 date: 2004-12-02 -! -! abstract: This routine sets derived constants -! -! program history log: -! 2004-12-02 treadon -! 2005-03-03 treadon - add implicit none -! 2008-06-04 safford - rm unused vars -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - -! Trigonometric constants - pi = acos(-one) - deg2rad = pi/180.0_r_kind - rad2deg = one/deg2rad - cg_term = (sqrt(two*pi))/two ! constant for variational qc - tiny_r_kind = tiny(zero) - huge_r_kind = huge(zero) - tiny_single = tiny(zero_single) - huge_single = huge(zero_single) - huge_i_kind = huge(izero) - r60inv=one/r60 - -! Geophysical parameters used in conversion of geopotential to -! geometric height - eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) - eccentricity = eccentricity_linear / semi_major_axis - - return - end subroutine init_constants_derived - - subroutine init_constants(regional) -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants set regional or global constants -! prgmmr: treadon org: np23 date: 2004-03-02 -! -! abstract: This routine sets constants specific to regional or global -! applications of the gsi -! -! program history log: -! 2004-03-02 treadon -! 2004-06-16 treadon, documentation -! 2004-10-28 treadon - use intrinsic TINY function to set value -! for smallest machine representable positive -! number -! 2004-12-03 treadon - move derived constants to init_constants_derived -! 2005-03-03 treadon - add implicit none -! -! input argument list: -! regional - if .true., set regional gsi constants; -! otherwise (.false.), use global constants -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - - logical,intent(in ) :: regional - - real(r_kind) reradius,g,r_d,r_v,cliq_wrf - -! Define regional constants here - if (regional) then - -! Name given to WRF constants - reradius = one/6370.e03_r_kind - g = 9.81_r_kind - r_d = 287.04_r_kind - r_v = 461.6_r_kind - cliq_wrf = 4190.0_r_kind - cp_mass = 1004.67_r_kind - -! Transfer WRF constants into unified GSI constants - rearth = one/reradius - grav = g - rd = r_d - rv = r_v - cv = cp-r_d - cliq = cliq_wrf - rd_over_cp_mass = rd / cp_mass - -! Define global constants here - else - rearth = 6.3712e+6_r_kind - grav = 9.80665e+0_r_kind - rd = 2.8705e+2_r_kind - rv = 4.6150e+2_r_kind - cv = 7.1760e+2_r_kind - cliq = 4.1855e+3_r_kind - cp_mass= zero - rd_over_cp_mass = zero - endif - - -! Now define derived constants which depend on constants -! which differ between global and regional applications. - -! Constants related to ozone assimilation - ozcon = grav*21.4e-9_r_kind - rozcon= one/ozcon - -! Constant used in vertical integral for precipitable water - tpwcon = 100.0_r_kind/grav - -! Derived atmospheric constants - fv = rv/rd-one ! used in virtual temperature equation - dldt = cvap-cliq - xa = -(dldt/rv) - xai = -(dldti/rv) - xb = xa+hvap/(rv*ttp) - xbi = xai+hsub/(rv*ttp) - eps = rd/rv - epsm1 = rd/rv-one - omeps = one-eps - factor1 = (cvap-cliq)/rv - factor2 = hvap/rv-factor1*t0c - cpr = cp*rd - el2orc = hvap*hvap/(rv*cp) - rd_over_g = rd/grav - rd_over_cp = rd/cp - g_over_rd = grav/rd - - return - end subroutine init_constants - -end module constants diff --git a/lib/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 b/lib/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 deleted file mode 100755 index 2c1eb065d..000000000 --- a/lib/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 +++ /dev/null @@ -1,245 +0,0 @@ -SUBROUTINE convert_lghtn2ref(mype,nlon,nlat,nsig,ref_mos_3d,lightning, & - lghtn_region_mask,lghtn_ref_bias,h_bk) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: convert_lghtn2ref convert lightning stroke rate to radar reflectivity -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2012-10-16 -! -! ABSTRACT: -! This subroutine converts lightning flash density to radar reflectivity based -! on Jing's statistic analysis - -! PROGRAM HISTORY LOG: -! 2015-10-06 s.Liu Add NCO document block -! 2015-10-06 s.liu -add new algorithm from Jing Her to retrieve REF from lghtn for NMMB -! 2015-10-26 s.liu -reduce estimated reflectivity, appears the current -! algorithm overestimated ref (5dBz) -! 2016-05-05 s.liu -add region adjustment parameter. -! 2016-05-08 s.liu -add parameter to control the layers for adjustment based on region. - -! -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! ref_mos_3d - 3D reflectivity in analysis grid -! lightning - 2D lightning flash rate in analysis grid -! h_bk - 3D height -! -! output argument list: -! ref_mos_3d - 3D reflectivity in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use kinds, only: r_kind,i_kind,r_single - implicit none - - INTEGER(i_kind),intent(in) :: mype - INTEGER(i_kind),intent(in) :: nlon,nlat,nsig - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height - real(r_kind), intent(inout) :: lightning(nlon,nlat) - real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid -! -! local -! - real(r_kind) :: dbz_lightning(nlon,nlat) - real(r_kind) :: lghtn_region_mask(nlon,nlat) - real(r_kind) :: lghtn_ref_bias(nlon,nlat) - - real(r_kind) :: table_lghtn2ref_winter(30) ! table content the map from lightning strakes - ! to maximum reflectivity - DATA table_lghtn2ref_winter/ & - 32.81,33.98,34.93,36.26,36.72,37.07,37.93,38.79,39.65,40.10, & - 40.42,41.42,41.90,42.04,42.19,42.45,42.90,43.20,43.50,43.80, & - 44.10,44.66,44.84,45.56,45.64,45.80,45.95,46.11,46.32,46.50/ - - real(r_kind) :: table_lghtn2ref_summer(30) ! table content the map from lightning strakes - ! to maximum reflectivity - DATA table_lghtn2ref_summer/ & - 30.13,31.61,32.78,33.86,34.68,35.34,36.13,36.15,37.02,37.04, & - 37.74,38.00,38.56,38.85,39.10,39.37,39.78,39.98,40.64,41.33, & - 41.50,41.65,41.85,42.08,42.77,43.03,43.26,43.53,43.74,43.73/ - - integer(i_kind) :: maxlvl - parameter (maxlvl=31) - real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile - DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & - 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & - 9, 10, 11, 12, 13, 14, 15, 16/ - - real(r_kind) :: refprofile_winter(maxlvl,4) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 30-35 dbz - DATA refprofile_winter(:,1) / & - 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & - 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & - 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & - 0.793/ -! max reflectivity 35-40 dbz - DATA refprofile_winter(:,2) / & - 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & - 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & - 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & - 0.723/ -! max reflectivity 40-45 dbz - DATA refprofile_winter(:,3) / & - 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & - 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & - 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & - 0.656/ -! max reflectivity 45-50 dbz - DATA refprofile_winter(:,4) / & - 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & - 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & - 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & - 0.548/ - - real(r_kind) :: refprofile_summer(maxlvl,4) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 30-35 dbz - DATA refprofile_summer(:,1) / & - 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & - 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & - 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & - 0.570/ -! max reflectivity 35-40 dbz - DATA refprofile_summer(:,2) / & - 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & - 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & - 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & - 0.491/ -! max reflectivity 40-45 dbz - DATA refprofile_summer(:,3) / & - 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & - 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & - 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & - 0.440/ -! max reflectivity 45-50 dbz - DATA refprofile_summer(:,4) / & - 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & - 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & - 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & - 0.410/ - - INTEGER(i_kind) :: season ! 1= summer, 2=winter - INTEGER(i_kind) :: num_lightning - INTEGER(i_kind) :: i,j, k2, k, mref - REAL(r_kind) :: heightGSI,upref,downref,wght - INTEGER(i_kind) :: ilvl,numref - REAL(r_kind) :: lowest,highest,tempref, tempprofile(maxlvl) - real(r_kind) :: profile_wgt - - -! -! map lightning strokes to maximum reflectiivty -! -!* lghtn_region_mask=1.0 outside of radar coverage - Do j=2,nlat-1 - Do i=2,nlon-1 - if(lghtn_region_mask(i,j)==0.0) then - lghtn_ref_bias(i,j)=lghtn_ref_bias(i,j)+16.0 - else - lghtn_ref_bias(i,j)=lghtn_ref_bias(i,j)+8.0 - end if - End do - End do - - season=1 - dbz_lightning = -9999.0_r_kind - DO j=2,nlat-1 - DO i=2,nlon-1 - if(lightning(i,j) > 1.0_r_kind ) then - num_lightning = max(1,min(30,int(lightning(i,j)))) - if(season== 2 ) then - dbz_lightning(i,j) = & - 7.62*log10(lightning(i,j))+30.0-lghtn_ref_bias(i,j) - else if(season== 1 ) then - dbz_lightning(i,j) = & - 7.62*log10(lightning(i,j))+30.0-lghtn_ref_bias(i,j) - endif - endif - ENDDO - ENDDO - - lightning = -999.0 - DO j=2,nlat-1 - DO i=2,nlon-1 - lightning(i,j) = dbz_lightning(i,j) - ENDDO - ENDDO - -! -! vertical reflectivity distribution -! - DO k=1,maxlvl - newlvlAll(k)=newlvlAll(k)*1000.0_r_kind - ENDDO - -! ref_mos_3d=-9999.0 - DO j=2,nlat-1 - DO i=2,nlon-1 - if( dbz_lightning(i,j) > 30 ) then - mref = min(4,(int((dbz_lightning(i,j) - 30.0_r_kind)/5.0_r_kind) + 1 )) - if(season== 2 ) then - DO k=1,maxlvl - if(lghtn_region_mask(i,j)==0.0.and.refprofile_winter(k,mref)<0.995) then - profile_wgt=0.0 - else if(lghtn_region_mask(i,j)==1.0.and.refprofile_winter(k,mref)<0.993) then - profile_wgt=0.0 - else - profile_wgt=refprofile_winter(k,mref) - end if - tempprofile(k)=profile_wgt*dbz_lightning(i,j) - enddo - lowest=newlvlAll(2) - highest=7000.0_r_kind - else if(season== 1 ) then - DO k=1,maxlvl - if(lghtn_region_mask(i,j)==0.0.and.refprofile_summer(k,mref)<0.995) then - profile_wgt=0.0 - else if(lghtn_region_mask(i,j)==1.0.and.refprofile_summer(k,mref)<0.993) then - profile_wgt=0.0 - else - profile_wgt=refprofile_summer(k,mref) - end if - tempprofile(k)=profile_wgt*dbz_lightning(i,j) - enddo - lowest=newlvlAll(3) - highest=12000.0_r_kind - endif - DO k2=1,nsig - heightGSI=h_bk(i,j,k2) - if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? - do k=1,maxlvl-1 - if( heightGSI >=newlvlAll(k) .and. heightGSI < newlvlAll(k+1) ) ilvl=k - enddo - upref=tempprofile(ilvl+1) - downref=tempprofile(ilvl) - wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) - tempref=(1-wght)*downref + wght*upref - ref_mos_3d(i,j,k2) = max(ref_mos_3d(i,j,k2),tempref) - endif - ENDDO - endif - ENDDO - ENDDO - -END SUBROUTINE convert_lghtn2ref diff --git a/lib/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 b/lib/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 deleted file mode 100755 index 4d44226da..000000000 --- a/lib/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 +++ /dev/null @@ -1,211 +0,0 @@ -SUBROUTINE convert_lghtn2ref_nmmb(mype,nlon,nlat,nsig,ref_mos_3d,lightning,h_bk) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: convert_lghtn2ref convert lightning stroke rate to radar reflectivity -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2012-10-16 -! -! ABSTRACT: -! This subroutine converts lightning flash density to radar reflectivity based -! on Jing's statistic analysis - -! PROGRAM HISTORY LOG: -! 2015-10-06 S.Liu Add NCO document block -! 2015-10-06 s.liu -add new algorithm from Jing Her to retrieve REF from lghtn for NMMB -! 2015-10-26 s.liu -reduce estimated reflectivity, appears the current -! algorithm overestimated ref (5dBz) - -! -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! ref_mos_3d - 3D reflectivity in analysis grid -! lightning - 2D lightning flash rate in analysis grid -! h_bk - 3D height -! -! output argument list: -! ref_mos_3d - 3D reflectivity in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use kinds, only: r_kind,i_kind,r_single - implicit none - - INTEGER(i_kind),intent(in) :: mype - INTEGER(i_kind),intent(in) :: nlon,nlat,nsig - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height - real(r_kind), intent(inout) :: lightning(nlon,nlat) - real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid -! -! local -! - real(r_kind) :: dbz_lightning(nlon,nlat) - real(r_kind) :: table_lghtn2ref_winter(30) ! table content the map from lightning strakes - ! to maximum reflectivity - DATA table_lghtn2ref_winter/ & - 32.81,33.98,34.93,36.26,36.72,37.07,37.93,38.79,39.65,40.10, & - 40.42,41.42,41.90,42.04,42.19,42.45,42.90,43.20,43.50,43.80, & - 44.10,44.66,44.84,45.56,45.64,45.80,45.95,46.11,46.32,46.50/ - - real(r_kind) :: table_lghtn2ref_summer(30) ! table content the map from lightning strakes - ! to maximum reflectivity - DATA table_lghtn2ref_summer/ & - 30.13,31.61,32.78,33.86,34.68,35.34,36.13,36.15,37.02,37.04, & - 37.74,38.00,38.56,38.85,39.10,39.37,39.78,39.98,40.64,41.33, & - 41.50,41.65,41.85,42.08,42.77,43.03,43.26,43.53,43.74,43.73/ - - integer(i_kind) :: maxlvl - parameter (maxlvl=31) - real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile - DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & - 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & - 9, 10, 11, 12, 13, 14, 15, 16/ - - real(r_kind) :: refprofile_winter(maxlvl,4) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 30-35 dbz - DATA refprofile_winter(:,1) / & - 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & - 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & - 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & - 0.793/ -! max reflectivity 35-40 dbz - DATA refprofile_winter(:,2) / & - 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & - 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & - 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & - 0.723/ -! max reflectivity 40-45 dbz - DATA refprofile_winter(:,3) / & - 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & - 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & - 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & - 0.656/ -! max reflectivity 45-50 dbz - DATA refprofile_winter(:,4) / & - 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & - 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & - 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & - 0.548/ - - real(r_kind) :: refprofile_summer(maxlvl,4) ! statistic reflectivity profile used to - ! retrieve vertical ref based on lightning -! max reflectivity 30-35 dbz - DATA refprofile_summer(:,1) / & - 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & - 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & - 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & - 0.570/ -! max reflectivity 35-40 dbz - DATA refprofile_summer(:,2) / & - 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & - 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & - 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & - 0.491/ -! max reflectivity 40-45 dbz - DATA refprofile_summer(:,3) / & - 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & - 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & - 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & - 0.440/ -! max reflectivity 45-50 dbz - DATA refprofile_summer(:,4) / & - 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & - 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & - 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & - 0.410/ - - INTEGER(i_kind) :: season ! 1= summer, 2=winter - INTEGER(i_kind) :: num_lightning - INTEGER(i_kind) :: i,j, k2, k, mref - REAL(r_kind) :: heightGSI,upref,downref,wght - INTEGER(i_kind) :: ilvl,numref - REAL(r_kind) :: lowest,highest,tempref, tempprofile(maxlvl) - - -! -! map lightning strokes to maximum reflectiivty -! - season=1 - dbz_lightning = -9999.0_r_kind - DO j=2,nlat-1 - DO i=2,nlon-1 - if(lightning(i,j) > 1.0_r_kind ) then - num_lightning = max(1,min(30,int(lightning(i,j)))) - if(season== 2 ) then - dbz_lightning(i,j) = 7.62*log10(lightning(i,j))+30.0 - else if(season== 1 ) then - dbz_lightning(i,j) = 7.62*log10(lightning(i,j))+30.0 - endif - endif - ENDDO - ENDDO - - lightning = -999.0 - DO j=2,nlat-1 - DO i=2,nlon-1 - lightning(i,j) = dbz_lightning(i,j) - ENDDO - ENDDO - -! -! vertical reflectivity distribution -! - DO k=1,maxlvl - newlvlAll(k)=newlvlAll(k)*1000.0_r_kind - ENDDO - -! ref_mos_3d=-9999.0 - DO j=2,nlat-1 - DO i=2,nlon-1 - if( dbz_lightning(i,j) > 30 ) then - mref = min(4,(int((dbz_lightning(i,j) - 30.0_r_kind)/5.0_r_kind) + 1 )) - if(season== 2 ) then - DO k=1,maxlvl - tempprofile(k)=refprofile_winter(k,mref)*dbz_lightning(i,j) - enddo - lowest=newlvlAll(2) - highest=7000.0_r_kind - else if(season== 1 ) then - DO k=1,maxlvl - tempprofile(k)=refprofile_summer(k,mref)*dbz_lightning(i,j) - enddo - lowest=newlvlAll(3) - highest=12000.0_r_kind - endif - DO k2=1,nsig - heightGSI=h_bk(i,j,k2) - if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? - do k=1,maxlvl-1 - if( heightGSI >=newlvlAll(k) .and. heightGSI < newlvlAll(k+1) ) ilvl=k - enddo - upref=tempprofile(ilvl+1) - downref=tempprofile(ilvl) - wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) - tempref=(1-wght)*downref + wght*upref - ref_mos_3d(i,j,k2) = max(ref_mos_3d(i,j,k2),tempref) - endif - ENDDO - endif - ENDDO - ENDDO - -END SUBROUTINE convert_lghtn2ref_nmmb diff --git a/lib/GSD/gsdcloud4nmmb/diff.sh b/lib/GSD/gsdcloud4nmmb/diff.sh deleted file mode 100755 index 9cd06f644..000000000 --- a/lib/GSD/gsdcloud4nmmb/diff.sh +++ /dev/null @@ -1,11 +0,0 @@ - -set -x -rm -f ttt -flnm=`ls *90` -for iflnm in $flnm -do - echo "**********" >> ttt - echo $iflnm >> ttt - diff $iflnm ../gsdcloud_old/$iflnm >> ttt - echo >> ttt -done diff --git a/lib/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 b/lib/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 deleted file mode 100755 index 07f20ffbf..000000000 --- a/lib/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 +++ /dev/null @@ -1,384 +0,0 @@ -! -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: get_sfm_1d_gnl -! -! PRGMMR: ORG: DATE: -! -! ABSTRACT: -! This subroutine calculate liquid water content for convection cloud -! This subroutine is from ARPS cloud analysis package -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - -!################################################################## -!################################################################## -!###### ###### -!###### SUBROUTINE GET_SFM_1D ###### -!###### ###### -!###### Developed by ###### -!###### Center for Analysis and Prediction of Storms ###### -!###### University of Oklahoma ###### -!###### ###### -!################################################################## -!################################################################## -! - -SUBROUTINE get_sfm_1d_gnl (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & - l_prt) -! -!----------------------------------------------------------------------- -! -! PURPOSE: -!c----------------------------------------------------------------- -!c -!c This is the streamlined version of the Smith-Feddes -!c and Temperature Adjusted LWC calculation methodologies -!c produced at Purdue University under sponsorship -!c by the FAA Technical Center. -!c -!c Currently, this subroutine will only use the Smith- -!c Feddes and will only do so as if there are solely -!c stratiform clouds present, however, it is very easy -!c to switch so that only the Temperature Adjusted -!c method is used. -!c -!c Dilution by glaciation is also included, it is a -!c linear function of in cloud temperature going from -!c all liquid water at -10 C to all ice at -30 C -!c as such the amount of ice is also calculated -! -!----------------------------------------------------------------------- -! -! AUTHOR: Jian Zhang -! 05/96 Based on the LAPS cloud analysis code of 07/1995 -! -! MODIFICATION HISTORY: -! -! 05/16/96 (Jian Zhang) -! Modified for ADAS format. Added full documentation. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER :: nz ! number of model vertical levels - REAL :: zs_1d(nz) ! physical height (m) at each scalar level - REAL :: p_mb_1d(nz) ! pressure (mb) at each level - REAL :: t_1d(nz) ! temperature (K) at each level - - REAL :: zcb ! cloud base height (m) - REAL :: zctop ! cloud top height (m) -! -! OUTPUT: - REAL :: ql(nz) ! liquid water content (g/kg) - REAL :: qi(nz) ! ice water content (g/kg) - REAL :: cldt(nz) -! -! LOCAL: - REAL :: calw(200) - REAL :: cali(200) - REAL :: catk(200) - REAL :: entr(200) -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - REAL :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso - REAL :: c,a1,b1,c1,a2,b2,c2 - REAL :: delz,delt,cldbtm,cldbp,cldtpt,tbar - REAL :: arg,fraclw,tlwc - REAL :: temp,press,zbase,alw,zht,ht,y - REAL :: rl,es,qvs1,p,des,dtz,es2,qvs2 - INTEGER :: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 - REAL :: dtdz,dttdz,zcloud,entc,tmpk - LOGICAL :: l_prt -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Initialize 1d liquid water and ice arrays (for 100m layers) -! -!----------------------------------------------------------------------- -! - DO i=1,200 - calw(i)=0.0 - cali(i)=0.0 - END DO -! -!----------------------------------------------------------------------- -! -! Preset some constants and coefficients. -! -!----------------------------------------------------------------------- -! - dz=100.0 ! m - rv=461.5 ! J/deg/kg - rair=287.04 ! J/deg/kg - grav=9.81 ! m/s2 - cp=1004. ! J/deg/kg - rlvo=2.5003E+6 ! J/kg - rlso=2.8339E+6 ! J/kg - dlvdt=-2.3693E+3 ! J/kg/K - eso=610.78 ! pa - c=0.01 - a1=8.4897 - b1=-13.2191 - c1=4.7295 - a2=10.357 - b2=-28.2416 - c2=8.8846 -! -!----------------------------------------------------------------------- -! -! Calculate indices of cloud top and base -! -!----------------------------------------------------------------------- -! - DO k=1,nz-1 - IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN - kcb=k - kcb1=kcb+1 - END IF - IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN - kctop=k - kctop1=kctop+1 - END IF - END DO -! -!----------------------------------------------------------------------- -! -! Obtain cloud base and top conditions -! -!----------------------------------------------------------------------- -! - delz = zs_1d(kcb+1)-zs_1d(kcb) - delt = t_1d(kcb+1)-t_1d(kcb) - cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) - tbar = (cldbtm+t_1d(kcb))/2. - arg = -grav*(zcb-zs_1d(kcb))/rair/tbar - cldbp = p_mb_1d(kcb)*EXP(arg) - delz = zs_1d(kctop+1)-zs_1d(kctop) - delt = t_1d(kctop+1)-t_1d(kctop) - cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) -! -!----------------------------------------------------------------------- -! -! Calculate cloud lwc profile for cloud base/top pair -! -!----------------------------------------------------------------------- -! - temp = cldbtm - press = cldbp*100.0 - zbase = zcb - nlevel = ((zctop-zcb)/100.0)+1 - IF(nlevel <= 0) nlevel=1 - alw = 0.0 - calw(1)= 0.0 - cali(1)= 0.0 - catk(1)= temp - entr(1)= 1.0 - nlm1 = nlevel-1 - IF(nlm1 < 1) nlm1=1 - zht = zbase - - DO j=1,nlm1 - rl = rlvo+(273.15-temp)*dlvdt - arg = rl*(temp-273.15)/273.15/temp/rv - es = eso*EXP(arg) - qvs1 = 0.622*es/(press-es) -! rho1 = press/(rair*temp) - arg = -grav*dz/rair/temp - p = press*EXP(arg) - - IF(l_prt) THEN - WRITE(6,605) j,zht,temp,press,1000.0*qvs1,es,rl - 605 FORMAT('get_sfm_1d_gnl:',1X,i2,' ht=',f8.0,' T=',f6.1,' P=',f9.1,' qvs=', & - f7.3,' es=',f6.1,' Lv=',e8.3) - END IF -! -!----------------------------------------------------------------------- -! -! Calculate saturated adiabatic lapse rate -! -!----------------------------------------------------------------------- -! - des = es*rl/temp/temp/rv - dtz = -grav*((1.0+0.621*es*rl/(press*rair*temp))/ & - (cp+0.621*rl*des/press)) - zht = zht+dz - press = p - temp = temp+dtz*dz - rl = rlvo+(273.15-temp)*dlvdt - arg = rl*(temp-273.15)/273.15/temp/rv - es2 = eso*EXP(arg) - qvs2 = 0.622*es2/(press-es2) - - alw = alw+(qvs1-qvs2) ! kg/kg - calw(j+1) = alw - - IF (l_prt) THEN - WRITE(6,9015) j,1000.0*calw(j+1),zht - 9015 FORMAT('get_sfm_1d_gnl',1X,'j=',i3,' adiab.lwc =',f7.3,' alt =',f8.0) - END IF -! -!----------------------------------------------------------------------- -! -! Reduction of lwc by entrainment -! -!----------------------------------------------------------------------- -! - ht = (zht-zbase)*.001 -! -!c ------------------------------------------------------------------ -!c -!c skatskii's curve(convective) -!c -!c ------------------------------------------------------------------ -!c if(ht.lt.0.3) then -!c y = -1.667*(ht-0.6) -!c elseif(ht.lt.1.0) then -!c arg1 = b1*b1-4.0*a1*(c1-ht) -!c y = (-b1-sqrt(arg1))/(2.0*a1) -!c elseif(ht.lt.2.9) then -!c arg2 = b2*b2-4.0*a2*(c2-ht) -!c y = (-b2-sqrt(arg2))/(2.0*a2) -!c else -!c y = 0.26 -!c endif -!c -!c ------------------------------------------------------------------ -!c -!c warner's curve(stratiform) -!c -!c ------------------------------------------------------------------ - IF(ht < 0.032) THEN - y = -11.0*ht+1.0 ! y(ht=0.032) = 0.648 - ELSE IF(ht <= 0.177) THEN - y = -1.4*ht+0.6915 ! y(ht=0.177) = 0.4437 - ELSE IF(ht <= 0.726) THEN - y = -0.356*ht+0.505 ! y(ht=0.726) = 0.2445 - ELSE IF(ht <= 1.5) THEN - y = -0.0608*ht+0.2912 ! y(ht=1.5) = 0.2 - ELSE - y = 0.20 - END IF -! -!----------------------------------------------------------------------- -! -! Calculate reduced lwc by entrainment and dilution -! -! Note at -5 C and warmer, all liquid. ! changed from -10 KB -! at -25 C and colder, all ice ! changed from -30 KB -! Linear ramp between. -! -!----------------------------------------------------------------------- -! - IF(temp < 268.15) THEN - IF(temp > 248.15) THEN - fraclw=0.05*(temp-248.15) - ELSE - fraclw=0.0 - END IF - ELSE - fraclw=1.0 - END IF - - tlwc=1000.*y*calw(j+1) ! g/kg - calw(j+1)=tlwc*fraclw - cali(j+1)=tlwc*(1.-fraclw) - catk(j+1)=temp - entr(j+1)=y - - END DO -! -!----------------------------------------------------------------------- -! -! Alternative calculation procedure using the observed or -! inferred in cloud temperature profile -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Obtain profile of LWCs at the given grid point -! -!----------------------------------------------------------------------- -! - - DO ip=2,nz-1 - IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN - ql(ip)=0.0 - qi(ip)=0.0 - cldt(ip)=t_1d(ip) - ELSE - DO j=2,nlevel - zcloud = zcb+(j-1)*dz - IF(zcloud >= zs_1d(ip)) THEN - ql(ip) = (zs_1d(ip)-zcloud+100.)*(calw(j)-calw(j-1))*0.01 & - +calw(j-1) - qi(ip) = (zs_1d(ip)-zcloud+100.)*(cali(j)-cali(j-1))*0.01 & - +cali(j-1) - tmpk = (zs_1d(ip)-zcloud+100.)*(catk(j)-catk(j-1))*0.01 & - +catk(j-1) - entc = (zs_1d(ip)-zcloud+100.)*(entr(j)-entr(j-1))*0.01 & - +entr(j-1) - cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk - - EXIT - END IF - END DO - END IF - END DO -! -!----------------------------------------------------------------------- -! -! Write out file of lwc comparisons -! -!----------------------------------------------------------------------- -! - RETURN -END SUBROUTINE get_sfm_1d_gnl diff --git a/lib/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 b/lib/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 deleted file mode 100755 index bd1c8f5bd..000000000 --- a/lib/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 +++ /dev/null @@ -1,198 +0,0 @@ -SUBROUTINE hydro_mxr_thompson (nx, ny, nz, t_3d, p_3d, ref_3d, qr_3d, qnr_3d, qs_3d, istatus, mype ) -! -! PURPOSE: -! Calculate (1) snow mixing ratio, (2) rain mixing ratio, and (3) rain number concentration -! from reflectivity for Thompson microphysics scheme. A Marshall-Palmer drop-size distribution -! is assumed for rain. -! -! HISTORY: -! 2013-01-30: created by David Dowell, Greg Thompson, Ming Hu -! -! ACKNOWLEDGMENTS: -! Donghai Wang and Eric Kemp (code template from pcp_mxr_ferrier) -! -! input argument list: -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nz - no. of levels -! t_3d - 3D background temperature (K) -! p_3d - 3D background pressure (hPa) -! ref_3d - 3D reflectivity in analysis grid (dBZ) -! -! output argument list: -! qr_3d - rain mixing ratio (g/kg) -! qnr_3d - rain number concentration (/kg) -! qs_3d - snow mixing ratio (g/kg) -! istatus - -! - - -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single, i_kind, r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size - REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz) ! radar reflectivity (dBZ) - REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) - REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) - INTEGER(i_kind),intent(in) :: mype -! -! OUTPUT: - INTEGER(i_kind),intent(out):: istatus - REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow mixing ratio (g/kg) - REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio (g/kg) - REAL(r_single),intent(out) :: qnr_3d(nx,ny,nz) ! rain number concentration (/kg) -! -! PARAMETERS: - REAL(r_kind), PARAMETER :: min_ref = 0.0_r_kind ! minimum reflectivity (dBZ) for converting to qs and qr - REAL(r_kind), PARAMETER :: max_ref_snow = 28.0_r_kind ! maximum reflectivity (dBZ) for converting to qs - ! (values above max_ref are treated as max_ref) - REAL(r_kind), PARAMETER :: max_ref_rain = 55.0_r_kind ! maximum reflectivity (dBZ) for converting to qr - ! (values above max_ref are treated as max_ref) - REAL(r_kind), PARAMETER :: n0r_mp = 8.0e6_r_kind ! Marshall-Palmer intercept parameter for rain (m**-4) - REAL(r_kind), PARAMETER :: rd= 287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) - REAL(r_kind), PARAMETER :: am_s = 0.069_r_kind - REAL(r_kind), PARAMETER :: bm_s = 2.0_r_kind - REAL(r_kind), PARAMETER :: PI = 3.1415926536_r_kind - REAL(r_kind), PARAMETER :: rho_i = 890.0_r_kind - REAL(r_kind), PARAMETER :: rho_w = 1000.0_r_kind -! -! LOCAL VARIABLES: - INTEGER(i_kind) :: i,j,k - REAL(r_kind) :: rho ! air density (kg m**-3) - REAL(r_kind) :: zes ! reflectivity (m**6 m**-3) associated with snow - REAL(r_kind) :: zer ! reflectivity (m**6 m**-3) associated with rain - REAL(r_kind) :: tc ! temperature (Celsius) - REAL(r_kind) :: rfract ! rain fraction - REAL(r_kind) :: tc0 - REAL(r_kind) :: smo2 - REAL(r_kind) :: rs - REAL(r_kind) :: f - REAL(r_kind) :: loga_ - REAL(r_kind) :: a_ - REAL(r_kind), PARAMETER :: a_min = 1.0e-5_r_kind ! lower bound for a_, to avoid large mixing ratios retrieved - ! for tiny particles sizes in cold temperatures - REAL(r_kind) :: b_ - REAL(r_kind) :: sa(10) - REAL(r_kind) :: sb(10) - REAL(r_kind) :: cse(3) - REAL(r_kind) :: crg(4) - REAL(r_kind) :: am_r - REAL(r_kind) :: oams - REAL(r_kind) :: qs ! snow mixing ratio in kg / kg - REAL(r_kind) :: qr ! rain mixing ratio in kg / kg -! -! for snow moments conversions (from Field et al. 2005) - DATA sa / 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & - 0.31255, 0.000204, 0.003199, 0.0, -0.015952/ - DATA sb / 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & - 0.060366, 0.000079, 0.000594, 0.0, -0.003577/ - -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - - istatus=0 - - f = (0.176_r_kind/0.93_r_kind) * (6.0_r_kind/PI)*(6.0_r_kind/PI) * (am_s/rho_i)*(am_s/rho_i) - cse(1) = bm_s + 1.0_r_kind - cse(2) = bm_s + 2.0_r_kind - cse(3) = bm_s * 2.0_r_kind - oams = 1.0_r_kind / am_s - - crg(1) = 24.0_r_kind - crg(2) = 1.0_r_kind - crg(3) = 24.0_r_kind - crg(4) = 5040.0_r_kind - am_r = PI * rho_w / 6.0_r_kind - - DO k = 2,nz-1 - DO j = 2,ny-1 - DO i = 2,nx-1 - - IF (ref_3d(i,j,k) >= min_ref) THEN - - rho = p_3d(i,j,k) / (rd*t_3d(i,j,k)) - tc = t_3d(i,j,k) - 273.15_r_kind - - IF (tc <= 0.0_r_kind) THEN - rfract = 0.0_r_kind - ELSE IF (tc >= 5.0_r_kind) THEN - rfract = 1.0_r_kind - ELSE - rfract = 0.20_r_kind*tc - ENDIF - - zes = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_snow) ) ) & - * (1.0_r_kind-rfract) & - * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) - - zer = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_rain) ) ) & - * rfract & - * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) - - tc0 = MIN(-0.1, tc) - IF (bm_s.lt.(1.999_r_kind) .or. bm_s.gt.(2.001_r_kind)) THEN - PRINT*, 'ABORT (hydro_mxr_thompson): bm_s = ', bm_s - STOP - ENDIF - - ! Calculate bm_s*2 (th) moment. Useful for reflectivity. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & - + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & - + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & - + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(3)*cse(3)*cse(3) - a_ = max( 10.0_r_kind ** loga_, a_min ) - b_ = sb(1) + sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & - + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & - + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) - - qs = ( (zes / (f*a_)) ** (1.0_r_kind / b_) ) / (rho*oams) - qs_3d(i,j,k) = 1000.0_r_kind * qs ! convert from kg / kg to g / kg - - qr = n0r_mp * am_r * crg(3) / rho * (zer / (n0r_mp*crg(4)))**(4.0_r_kind/7.0_r_kind) - qnr_3d(i,j,k) = (n0r_mp/rho)**(3.0_r_kind/4.0_r_kind) & - * (qr / (am_r * crg(3)))**(1.0_r_kind/4.0_r_kind) - - qnr_3d(i,j,k) = max(1.0_r_kind, qnr_3d(i,j,k)) - qr_3d(i,j,k) = 1000.0_r_kind * qr ! convert from kg / kg to g / kg - - -! if(mype==51 ) then -! write(*,'(a10,3i5,2f10.5,3f8.2)') 'b=',i,j,k,qs_3d(i,j,k),qr_3d(i,j,k),ref_3d(i,j,k),& -! p_3d(i,j,k)/100.0,tc -! endif - - - ELSE - - qs_3d(i,j,k) = -999._r_kind - qr_3d(i,j,k) = -999._r_kind - qnr_3d(i,j,k) = -999._r_kind - - END IF - - END DO ! k - END DO ! i - END DO ! j -! -! PRINT*,'finish hydro_mxr_thompson...' -! -!----------------------------------------------------------------------- -! - istatus = 1 -! - RETURN -END SUBROUTINE hydro_mxr_thompson diff --git a/lib/GSD/gsdcloud4nmmb/kinds.f90 b/lib/GSD/gsdcloud4nmmb/kinds.f90 deleted file mode 100755 index 73fbe3b56..000000000 --- a/lib/GSD/gsdcloud4nmmb/kinds.f90 +++ /dev/null @@ -1,105 +0,0 @@ -module kinds -!$$$ module documentation block -! . . . . -! module: kinds -! prgmmr: treadon org: np23 date: 2004-08-15 -! -! abstract: Module to hold specification kinds for variable declaration. -! This module is based on (copied from) Paul vanDelst's -! type_kinds module found in the community radiative transfer -! model -! -! module history log: -! 2004-08-15 treadon -! -! Subroutines Included: -! -! Functions Included: -! -! remarks: -! The numerical data types defined in this module are: -! i_byte - specification kind for byte (1-byte) integer variable -! i_short - specification kind for short (2-byte) integer variable -! i_long - specification kind for long (4-byte) integer variable -! i_llong - specification kind for double long (8-byte) integer variable -! r_single - specification kind for single precision (4-byte) real variable -! r_double - specification kind for double precision (8-byte) real variable -! r_quad - specification kind for quad precision (16-byte) real variable -! -! i_kind - generic specification kind for default integer -! r_kind - generic specification kind for default floating point -! -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - implicit none - private - -! Integer type definitions below - -! Integer types - integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer - integer, parameter, public :: i_short = selected_int_kind(4) ! short integer - integer, parameter, public :: i_long = selected_int_kind(8) ! long integer - integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer - integer, parameter, public :: i_llong = max( llong_t, i_long ) - -! Expected 8-bit byte sizes of the integer kinds - integer, parameter, public :: num_bytes_for_i_byte = 1 - integer, parameter, public :: num_bytes_for_i_short = 2 - integer, parameter, public :: num_bytes_for_i_long = 4 - integer, parameter, public :: num_bytes_for_i_llong = 8 - -! Define arrays for default definition - integer, parameter, private :: num_i_kinds = 4 - integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & - i_byte, i_short, i_long, i_llong /) - integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & - num_bytes_for_i_byte, num_bytes_for_i_short, & - num_bytes_for_i_long, num_bytes_for_i_llong /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** - integer, parameter, private :: default_integer = 3 ! 1=byte, - ! 2=short, - ! 3=long, - ! 4=llong - integer, parameter, public :: i_kind = integer_types( default_integer ) - integer, parameter, public :: num_bytes_for_i_kind = & - integer_byte_sizes( default_integer ) - - -! Real definitions below - -! Real types - integer, parameter, public :: r_single = selected_real_kind(6) ! single precision - integer, parameter, public :: r_double = selected_real_kind(15) ! double precision - integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision - integer, parameter, public :: r_quad = max( quad_t, r_double ) - -! Expected 8-bit byte sizes of the real kinds - integer, parameter, public :: num_bytes_for_r_single = 4 - integer, parameter, public :: num_bytes_for_r_double = 8 - integer, parameter, public :: num_bytes_for_r_quad = 16 - -! Define arrays for default definition - integer, parameter, private :: num_r_kinds = 3 - integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & - r_single, r_double, r_quad /) - integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & - num_bytes_for_r_single, num_bytes_for_r_double, & - num_bytes_for_r_quad /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** - integer, parameter, private :: default_real = 2 ! 1=single, - ! 2=double, - ! 3=quad - integer, parameter, public :: r_kind = real_kinds( default_real ) - integer, parameter, public :: num_bytes_for_r_kind = & - real_byte_sizes( default_real ) - -end module kinds diff --git a/lib/GSD/gsdcloud4nmmb/make.dependencies b/lib/GSD/gsdcloud4nmmb/make.dependencies deleted file mode 100755 index 64f49a734..000000000 --- a/lib/GSD/gsdcloud4nmmb/make.dependencies +++ /dev/null @@ -1,35 +0,0 @@ -kinds.o : kinds.f90 -constants.o : constants.f90 kinds.o - -ARPS_cldLib.o : ARPS_cldLib.f90 kinds.o constants.o -BackgroundCld.o : BackgroundCld.f90 kinds.o constants.o -BckgrndCC.o : BckgrndCC.f90 kinds.o constants.o -CheckCld.o : CheckCld.f90 kinds.o constants.o -radar_ref2tten.o : radar_ref2tten.f90 kinds.o constants.o -PrecipMxr_radar.o : PrecipMxr_radar.f90 kinds.o constants.o -PrecipType.o : PrecipType.f90 kinds.o constants.o -TempAdjust.o : TempAdjust.f90 kinds.o constants.o -adaslib.o : adaslib.f90 kinds.o constants.o -build_missing_REFcone.o : build_missing_REFcone.f90 kinds.o constants.o -cloudCover_NESDIS.o : cloudCover_NESDIS.f90 kinds.o constants.o -cloudCover_Surface.o : cloudCover_Surface.f90 kinds.o constants.o -cloudCover_radar.o : cloudCover_radar.f90 kinds.o constants.o -cloudLWC.o : cloudLWC.f90 kinds.o constants.o -cloudLayers.o : cloudLayers.f90 kinds.o constants.o -cloudType.o : cloudType.f90 kinds.o constants.o -convert_lghtn2ref.o : convert_lghtn2ref.f90 kinds.o constants.o -cloud_saturation.o : cloud_saturation.f90 kinds.o -get_sfm_1d_gnl.o : get_sfm_1d_gnl.f90 kinds.o constants.o -vinterp_radar_ref.o : vinterp_radar_ref.f90 kinds.o constants.o -map_ctp.o : map_ctp.f90 kinds.o constants.o -map_ctp_lar.o : map_ctp_lar.f90 kinds.o constants.o -mthermo.o : mthermo.f90 kinds.o constants.o -pcp_mxr_ARPSlib.o : pcp_mxr_ARPSlib.f90 kinds.o constants.o -## q_adjust.o : q_adjust.f90 kinds.o constants.o -read_Lightning_cld.o : read_Lightning_cld.f90 kinds.o constants.o -read_Lightningbufr_cld.o : read_Lightningbufr_cld.f90 kinds.o constants.o -read_NESDIS.o : read_NESDIS.f90 kinds.o constants.o -read_radar_ref.o : read_radar_ref.f90 kinds.o constants.o -read_Surface.o :read_Surface.f90 kinds.o constants.o -read_nasalarc_cld.o : read_nasalarc_cld.f90 kinds.o constants.o -smooth.o : smooth.f90 kinds.o constants.o diff --git a/lib/GSD/gsdcloud4nmmb/make.filelist b/lib/GSD/gsdcloud4nmmb/make.filelist deleted file mode 100755 index e268baf51..000000000 --- a/lib/GSD/gsdcloud4nmmb/make.filelist +++ /dev/null @@ -1,36 +0,0 @@ -SRC_FILES = ARPS_cldLib.f90 \ - BackgroundCld.f90 \ - BckgrndCC.f90 \ - radar_ref2tten.f90 \ - PrecipMxr_radar.f90 \ - PrecipType.f90 \ - TempAdjust.f90 \ - adaslib.f90 \ - build_missing_REFcone.f90 \ - cloudCover_NESDIS.f90 \ - cloudCover_Surface.f90 \ - cloudCover_radar.f90 \ - cloudLWC.f90 \ - cloudLayers.f90 \ - cloudType.f90 \ - cloud_saturation.f90 \ - convert_lghtn2ref.f90 \ - get_sfm_1d_gnl.f90 \ - vinterp_radar_ref.f90 \ - map_ctp.f90 \ - map_ctp_lar.f90 \ - mthermo.f90 \ - pcp_mxr_ARPSlib.f90 \ - read_Lightning_cld.f90 \ - read_Lightningbufr_cld.f90 \ - read_NESDIS.f90 \ - read_radar_ref.f90 \ - read_Surface.f90 \ - read_nasalarc_cld.f90 \ - smooth.f90 \ - constants.f90 \ - kinds.f90 \ - pbl_height.f90 \ - hydro_mxr_thompson.f90 - -OBJ_FILES =${SRC_FILES:.f90=.o} diff --git a/lib/GSD/gsdcloud4nmmb/makefile b/lib/GSD/gsdcloud4nmmb/makefile deleted file mode 100755 index 7f2808fff..000000000 --- a/lib/GSD/gsdcloud4nmmb/makefile +++ /dev/null @@ -1,36 +0,0 @@ -SHELL=/bin/sh - -LIB = ./libgsdcloud.a - -include make.filelist - -FFLAGS = -O3 -g -fp-model strict -convert big_endian -assume byterecl -implicitnone -traceback # -I../../../include -.SUFFIXES: .f90 .o - -.f90.o: -## $(RM) $@ $*.mod - ifort $(FFLAGS) -c $< - - -all: $(LIB) - -$(LIB): $(OBJ_FILES) - $(AR) -ruv $(LIB) $(OBJ_FILES) - -.f90.a: - ifort -c $(FFLAGS) $< -# ar -ruv $(AFLAGS) $@ $*.o -# rm -f $*.o - -.c.a: - $(CC) -c $(CFLAGS) $< -# ar -ruv $(AFLAGS) $@ $*.o -# rm -f $*.o - -# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) - -include make.dependencies - -clean: - rm -f *.o *.mod $(LIB) - diff --git a/lib/GSD/gsdcloud4nmmb/map_ctp.f90 b/lib/GSD/gsdcloud4nmmb/map_ctp.f90 deleted file mode 100755 index 139d46153..000000000 --- a/lib/GSD/gsdcloud4nmmb/map_ctp.f90 +++ /dev/null @@ -1,291 +0,0 @@ -subroutine map_ctp (ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac) - -! -!$$$ subprogram documentation block -! . . . . -! subprogram: map_ctp map GOES cloud product to analysis grid -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-03_10 -! -! ABSTRACT: -! This subroutine map GOES cloud product to analysis grid -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! ib - begin i point of this domain -! jb - begin j point of this domain -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nn_obs - 1st dimension of observation arry data_s -! numsao - number of observation -! data_s - observation array for GOES cloud products -! -! output argument list: -! sat_ctp - GOES cloud top pressure in analysis grid -! sat_tem - GOES cloud top temperature in analysis grid -! w_frac - GOES cloud coverage in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! adapted according to RUC subroutine rd_cld -! * -! * This routine reads NESDIS (Madison, WI) cloud product produced -! * from GOES sounder data. The original product is reprocessed onto -! * MAPS40 grid boxes. There could be more than one cloud product -! * in a grid-box, so we use the nearest one that falls in the -! * grid. The routine combines GOES-8 and 10 products. -! -! ===== History ===== -! -! * Internal variables: -! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds -! -! * Working variables: -! -! * Working variables used for sorting max size of 10: -! Pxx, Txx, xdist,xxxdist (R4) -! Fxx, Nxx, index, jndex (I4) -! ioption (I4) = 1 if selection is nearest neighbor -! = 2 if selection is median of samples -! -! -! * Output variables on gridpoint (Nx,Ny): -! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature -! w_frac (R4) Effective fractional cloud coverage, option=1 -! fractional coverage within RUC grid, option=2 -! w_eca (R4) Effective fractional cloud regardless option -! (effective cloud amount - eca) -! nlev_cld (I4) Number of cloud levels. TO BE USED LATER -! to incorporate multi-level cloud -! -! * Calling routines -! sorting -! sortmed -! -! * -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,r_single,i_kind - use constants, only: zero,one_tenth,one,deg2rad - - implicit none - -! input-file variables: - INTEGER(i_kind),intent(in) :: Nx, Ny - INTEGER(i_kind),intent(in) :: ib, jb - INTEGER(i_kind),intent(in) :: numsao, nn_obs - real(r_kind),dimension(nn_obs,numsao):: data_s -! Output - real(r_single), intent(out) :: sat_ctp(Nx,Ny) - real(r_single), intent(out) :: sat_tem(Nx,Ny) - real(r_single), intent(out) :: w_frac(Nx,Ny) -! -! misc - integer(i_kind) :: nfov - parameter (nfov=60) - - character header*80 -! Working - real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) - real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) - real(r_kind) :: fr,sqrt, qc, type - integer(i_kind) :: Nxx(Nx,Ny,nfov),index(Nx,Ny), jndex(nfov) - integer(i_kind) :: ioption - integer(i_kind) :: ipt,ixx,ii,jj,i,med_pt,igrid,jgrid & - ,ncount,ncount1,ncount2,ii1,jj1,nobs,n - - real(r_kind) :: xc - real(r_kind) :: yc - - real(r_single) :: w_eca(Nx,Ny) - integer(i_kind) :: nlev_cld(Nx,Ny) - integer(i_kind) :: ios - -! -! * Initialize outputs since GOES sounder do not scan all MAPS domain -! - do jj=1,Ny - do ii=1,Nx - w_eca (ii,jj) =-99999._r_kind - index(ii,jj) = 0 - enddo - enddo - -! -- set ios as failed unless valid data points are found below - ios = 0 - -! ----------------------------------------------------------- -! ----------------------------------------------------------- -! Map each FOV onto RR grid points -! ----------------------------------------------------------- -! ----------------------------------------------------------- - do ipt=1,numsao - - xc=data_s(2,ipt) - ib + 1.0_r_kind - yc=data_s(3,ipt) - jb + 1.0_r_kind - if(data_s(8,ipt) > 50 ) cycle - -! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 - - if(XC >= 1._r_kind .and. XC < Nx .and. & - YC >= 1._r_kind .and. YC < Ny) then - ii1 = int(xc+0.5_r_kind) - jj1 = int(yc+0.5_r_kind) - - do jj = max(1,jj1-2), min(ny,jj1+2) - if (jj1-1 >= 1 .and. jj1+1 <= ny) then - do ii = max(1,ii1-2), min(nx,ii1+2) - if (ii1-1 >= 1 .and. ii1+1 <= nx) then - -! * We check multiple data within gridbox - - if (index(ii,jj) < nfov) then - index(ii,jj) = index(ii,jj) + 1 - - Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) - Txx(ii,jj,index(ii,jj)) = data_s(6,ipt) -!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) -!mhu no cloud amount available, assign to 100 - Nxx(ii,jj,index(ii,jj)) = 100 - nlev_cld(ii,jj) = 1 - xdist(ii,jj,index(ii,jj)) = sqrt( & - (XC+1-ii)**2 + (YC+1-jj)**2) - end if - endif - enddo ! ii - endif - enddo ! jj - endif ! observation is in the domain - enddo ! ipt -! -! * ioption = 1 is nearest neighrhood -! * ioption = 2 is median of cloudy fov - ioption = 2 -! - do jj = 1,Ny - do ii = 1,Nx - if (index(ii,jj) < 3 ) then -! sat_ctp(ii,jj) = Pxx(ii,jj,1) -! sat_tem(ii,jj) = Txx(ii,jj,1) -! w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. -! w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. - - elseif(index(ii,jj) >= 3) then - -! * We decided to use nearest neighborhood for ECA values, -! * a kind of convective signal from GOES platform... - - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = xdist(ii,jj,i) - enddo - call sorting(xxxdist,index(ii,jj),jndex) - w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind -! * Sort to find closest distance if more than one sample - if(ioption == 1) then !nearest neighborhood - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = xdist(ii,jj,i) - enddo - call sorting(xxxdist,index(ii,jj),jndex) - sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) - sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) - w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind - endif -! * Sort to find median value - if(ioption == 2) then !pick median - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = Pxx(ii,jj,i) - enddo - call sortmed(xxxdist,index(ii,jj),jndex,fr) - med_pt = index(ii,jj)/2 + 1 - sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) - sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) - w_frac(ii,jj) = fr - endif - endif - enddo !ii - enddo !jj - - return -end subroutine map_ctp - -subroutine sorting(d,n,is) - use kinds, only: r_kind,i_kind - implicit none - - integer(i_kind), intent(in) :: n - real(r_kind) , intent(inout) :: d(n) - integer(i_kind), intent(inout) :: is(n) -! - integer(i_kind) :: nm1,ip1,iold,i,j - real(r_kind) :: temp -! -! - nm1 = n-1 - do 10 i=1,nm1 - ip1 = i+1 - do 10 j=ip1,n - if(d(i) <= d(j)) goto 10 - temp = d(i) - d(i) = d(j) - d(j) = temp - iold = is(i) - is(i) = is(j) - is(j) = iold - 10 continue - return -end subroutine sorting - -subroutine sortmed(p,n,is,f) - use kinds, only: r_kind,i_kind - implicit none - real(r_kind), intent(inout) :: p(n) - integer(i_kind), intent(in) :: n - integer(i_kind), intent(inout) :: is(n) -! * count cloudy fov - real(r_kind), intent(out) :: f - integer(i_kind) :: cfov -! - integer(i_kind) :: i,j,nm1,ip1,iold - real(r_kind) :: temp -! -! -! - cfov = 0 - do i=1,n - if(p(i) < 999._r_kind) cfov = cfov + 1 - enddo - f = float(cfov)/(max(1,n)) -! cloud-top pressure is sorted high cld to clear - nm1 = n-1 - do 10 i=1,nm1 - ip1 = i+1 - do 10 j=ip1,n - if(p(i)<=p(j)) goto 10 - temp = p(i) - p(i) = p(j) - p(j) = temp - iold = is(i) - is(i) = is(j) - is(j) = iold - 10 continue - return -end subroutine sortmed diff --git a/lib/GSD/gsdcloud4nmmb/map_ctp_lar.f90 b/lib/GSD/gsdcloud4nmmb/map_ctp_lar.f90 deleted file mode 100644 index 329b4de0b..000000000 --- a/lib/GSD/gsdcloud4nmmb/map_ctp_lar.f90 +++ /dev/null @@ -1,256 +0,0 @@ -subroutine map_ctp_lar(ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld) - -! -!$$$ subprogram documentation block -! . . . . -! subprogram: map_ctp_lar map Langley cloud product to analysis grid -! -! PRGMMR: Shun Liu ORG: GSD/AMB DATE: 2006-03_10 -! -! ABSTRACT: -! This subroutine map Langley cloud product to analysis grid, copy from map_ctp -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! ib - begin i point of this domain -! jb - begin j point of this domain -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nn_obs - 1st dimension of observation arry data_s -! numsao - number of observation -! data_s - observation array for GOES cloud products -! -! output argument list: -! sat_ctp - GOES cloud top pressure in analysis grid -! sat_tem - GOES cloud top temperature in analysis grid -! w_frac - GOES cloud coverage in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! adapted according to RUC subroutine rd_cld -! * -! * This routine reads NESDIS (Madison, WI) cloud product produced -! * from GOES sounder data. The original product is reprocessed onto -! * MAPS40 grid boxes. There could be more than one cloud product -! * in a grid-box, so we use the nearest one that falls in the -! * grid. The routine combines GOES-8 and 10 products. -! -! ===== History ===== -! -! * Internal variables: -! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds -! -! * Working variables: -! -! * Working variables used for sorting max size of 10: -! Pxx, Txx, xdist,xxxdist (R4) -! Fxx, Nxx, index, jndex (I4) -! ioption (I4) = 1 if selection is nearest neighbor -! = 2 if selection is median of samples -! -! -! * Output variables on gridpoint (Nx,Ny): -! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature -! w_frac (R4) Effective fractional cloud coverage, option=1 -! fractional coverage within RUC grid, option=2 -! w_eca (R4) Effective fractional cloud regardless option -! (effective cloud amount - eca) -! nlev_cld (I4) Number of cloud levels. TO BE USED LATER -! to incorporate multi-level cloud -! -! * Calling routines -! sorting -! sortmed -! -! * -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,r_single,i_kind - use constants, only: zero,one_tenth,one,deg2rad - - implicit none - -! input-file variables: - INTEGER(i_kind),intent(in) :: Nx, Ny - INTEGER(i_kind),intent(in) :: ib, jb - INTEGER(i_kind),intent(in) :: numsao, nn_obs - real(r_kind),dimension(nn_obs,numsao):: data_s -! Output - real(r_single), intent(out) :: sat_ctp(Nx,Ny) - real(r_single), intent(out) :: sat_tem(Nx,Ny) - real(r_single), intent(out) :: w_lwp(Nx,Ny) - real(r_single), intent(out) :: w_frac(Nx,Ny) -! -! misc - integer(i_kind) :: nfov - parameter (nfov=650) - - character header*80 -! Working - real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) - real(r_kind) :: PHxx(Nx,Ny,nfov),WPxx(Nx,Ny,nfov) - real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) - real(r_kind) :: fr,sqrt, qc, type - integer(i_kind) :: Nxx(Nx,Ny,nfov),index(Nx,Ny), jndex(nfov) - integer(i_kind) :: ioption - integer(i_kind) :: ipt,ixx,ii,jj,i,med_pt,igrid,jgrid & - ,ncount,ncount1,ncount2,ii1,jj1,nobs,n - - real(r_kind) :: xc - real(r_kind) :: yc - - real(r_single) :: w_eca(Nx,Ny) - integer(i_kind) :: nlev_cld(Nx,Ny) - integer(i_kind) :: ios,cfov - -! -! * Initialize outputs since GOES sounder do not scan all MAPS domain -! - do jj=1,Ny - do ii=1,Nx - sat_ctp (ii,jj) =-99999._r_kind - sat_tem (ii,jj) =-99999._r_kind - w_lwp (ii,jj) =-99999._r_kind - w_frac (ii,jj) =-99999._r_kind - nlev_cld (ii,jj) =-99999 - index(ii,jj) = 0 - enddo - enddo - -! -- set ios as failed unless valid data points are found below - ios = 0 - -! ----------------------------------------------------------- -! ----------------------------------------------------------- -! Map each FOV onto RR grid points -! ----------------------------------------------------------- -! ----------------------------------------------------------- - do ipt=1,numsao - - xc=data_s(2,ipt) - ib + 1.0_r_kind - yc=data_s(3,ipt) - jb + 1.0_r_kind -! write(6,*)'sat_tem::',data_s(2,ipt),data_s(3,ipt),ib,jb - if(data_s(8,ipt) > 650 ) cycle - -! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 - - if(XC >= 1._r_kind .and. XC < Nx .and. & - YC >= 1._r_kind .and. YC < Ny) then - ii1 = int(xc+0.5_r_kind) - jj1 = int(yc+0.5_r_kind) - - do jj = max(1,jj1-2), min(ny,jj1+2) - if (jj1-1 >= 1 .and. jj1+1 <= ny) then - do ii = max(1,ii1-2), min(nx,ii1+2) - if (ii1-1 >= 1 .and. ii1+1 <= nx) then - -! * We check multiple data within gridbox - - if (index(ii,jj) < nfov) then - index(ii,jj) = index(ii,jj) + 1 - - Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) - Txx(ii,jj,index(ii,jj)) = data_s(5,ipt) - PHxx(ii,jj,index(ii,jj)) = data_s(6,ipt) - WPxx(ii,jj,index(ii,jj)) = data_s(7,ipt) -!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) -!mhu no cloud amount available, assign to 100 -! Nxx(ii,jj,index(ii,jj)) = 100 - nlev_cld(ii,jj) = 1 -! write(6,*)'sat_tem1::',index(ii,jj),data_s(4,ipt),data_s(5,ipt),data_s(6,ipt),data_s(7,ipt) - xdist(ii,jj,index(ii,jj)) = sqrt( & - (XC+1-ii)**2 + (YC+1-jj)**2) - end if - endif - enddo ! ii - endif - enddo ! jj - endif ! observation is in the domain - enddo ! ipt -! -! * ioption = 1 is nearest neighrhood -! * ioption = 2 is median of cloudy fov - ioption = 2 -! - do jj = 1,Ny - do ii = 1,Nx - if (index(ii,jj) < 3 ) then -! sat_ctp(ii,jj) = Pxx(ii,jj,1) -! sat_tem(ii,jj) = Txx(ii,jj,1) -! w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. -! w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. - - elseif(index(ii,jj) >= 3) then - -! * We decided to use nearest neighborhood for ECA values, -! * a kind of convective signal from GOES platform... - - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = xdist(ii,jj,i) - enddo - call sorting(xxxdist,index(ii,jj),jndex) -! w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind -! * Sort to find closest distance if more than one sample -! if(ioption == 1) then !nearest neighborhood -! do i=1,index(ii,jj) -! jndex(i) = i -! xxxdist(i) = xdist(ii,jj,i) -! enddo -! call sorting(xxxdist,index(ii,jj),jndex) -! sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) -! sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) -! w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind -! endif -! * Sort to find median value - if(ioption == 2) then !pick median - do i=1,index(ii,jj) - jndex(i) = i - xxxdist(i) = Pxx(ii,jj,i) - enddo - call sortmed(xxxdist,index(ii,jj),jndex,fr) - med_pt = index(ii,jj)/2 + 1 - sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) - sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) - w_lwp(ii,jj) = WPxx(ii,jj,jndex(med_pt)) - if (sat_ctp(ii,jj).eq.-20) then - sat_ctp(ii,jj) = 1013. ! hPa - no cloud - w_frac(ii,jj)=0.0 - nlev_cld(ii,jj) = 0 - end if - -! -! cloud fraction based on phase (0 are clear), what about -9 ???? - if( sat_ctp(ii,jj) < 1012.99) then - cfov = 0 - do i=1,index(ii,jj) - if(PHxx(ii,jj,i) .gt. 0.1) cfov = cfov + 1 - enddo - w_frac(ii,jj) = float(cfov)/(max(1,index(ii,jj))) ! fraction - if( w_frac(ii,jj) > 0.01 ) nlev_cld(ii,jj) = 1 - endif - -! write(6,*)'sat_tem2::',index(ii,jj),sat_ctp(ii,jj),sat_tem(ii,jj) - endif - endif - enddo !ii - enddo !jj - - return -end subroutine map_ctp_lar diff --git a/lib/GSD/gsdcloud4nmmb/mthermo.f90 b/lib/GSD/gsdcloud4nmmb/mthermo.f90 deleted file mode 100755 index 3388a5228..000000000 --- a/lib/GSD/gsdcloud4nmmb/mthermo.f90 +++ /dev/null @@ -1,229 +0,0 @@ -! -!$$$ subprogram documentation block -! . . . . -! ABSTRACT: -! This file collects subroutines and functions related to thermodynamic calculations -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! 2010-05-03 Hu Clean the code -! -! -! input argument list: -! -! output argument list: -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - FUNCTION esat(t) -! -! this function returns the saturation vapor pressure over -! water (mb) given the temperature (celsius). -! the algorithm is due to nordquist, w.s.,1973: "numerical approxima- -! tions of selected meteorlolgical parameters for cloud physics prob- -! lems," ecom-5475, atmospheric sciences laboratory, u.s. army -! electronics command, white sands missile range, new mexico 88002. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind),intent(in) :: t - real(r_single) :: tk,p1,p2,c1 - real(r_kind) :: esat - - tk = t+273.15 - p1 = 11.344-0.0303998*tk - p2 = 3.49149-1302.8844/tk - c1 = 23.832241-5.02808*ALOG10(tk) - esat = 10.**(c1-1.3816E-7*10.**p1+8.1328E-3*10.**p2-2949.076/tk) - RETURN - END FUNCTION esat - - FUNCTION eslo(t) -! -! this function returns the saturation vapor pressure over liquid -! water eslo (millibars) given the temperature t (celsius). the -! formula is due to lowe, paul r.,1977: an approximating polynomial -! for the computation of saturation vapor pressure, journal of applied -! meteorology, vol 16, no. 1 (january), pp. 100-103. -! the polynomial coefficients are a0 through a6. - use kinds, only: r_single,i_kind,r_kind - IMPLICIT NONE -! - real(r_kind), intent(in) :: t - real(r_kind) :: eslo - - real(r_kind) :: a0,a1,a2,a3,a4,a5,a6 - real(r_kind) :: es - - DATA a0,a1,a2,a3,a4,a5,a6 & - /6.107799961, 4.436518521E-01, 1.428945805E-02, & - 2.650648471E-04, 3.031240396E-06, 2.034080948E-08, & - 6.136820929E-11/ - es = a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+a6*t))))) - IF (es < 0.) es = 0. - eslo = es - RETURN - END FUNCTION eslo - - FUNCTION tda(o,p) -! -! this function returns the temperature tda (celsius) on a dry adiabat -! at pressure p (millibars). the dry adiabat is given by -! potential temperature o (celsius). the computation is based on -! poisson's equation. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: o,p - real(r_kind) :: tda - - tda= (o+273.15)*((p*.001)**.286)-273.15 - RETURN - END FUNCTION tda - - FUNCTION tmr(w,p) -! -! this function returns the temperature (celsius) on a mixing -! ratio line w (g/kg) at pressure p (mb). the formula is given in -! table 1 on page 7 of stipanuk (1973). -! -! initialize constants - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: w,p - real(r_kind) :: tmr - - real(r_kind) :: c1,c2,c3,c4,c5,c6 - real(r_kind) :: x,tmrk - real(r_single) :: y - - DATA c1/.0498646455/,c2/2.4082965/,c3/7.07475/ - DATA c4/38.9114/,c5/.0915/,c6/1.2035/ - - y=w*p/(622.+w) - x= alog10(y) - tmrk= 10.**(c1*x+c2)-c3+c4*((10.**(c5*x)-c6)**2.) - tmr= tmrk-273.15 - RETURN - END FUNCTION tmr - - FUNCTION tsa(os,p) -! -! this function returns the temperature tsa (celsius) on a saturation -! adiabat at pressure p (millibars). os is the equivalent potential -! temperature of the parcel (celsius). sign(a,b) replaces the -! algebraic sign of a with that of b. -! b is an empirical constant approximately equal to 0.001 of the latent -! heat of vaporization for water divided by the specific heat at constant -! pressure for dry air. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: os,p - real(r_kind) :: tsa - - real(r_kind) :: a,b,d,tq,x,tqk,w - integer :: i - - DATA b/2.6518986/ - a= os+273.15 - -! tq is the first guess for tsa. - - tq= 253.15 - -! d is an initial value used in the iteration below. - - d= 120. - -! iterate to obtain sufficient accuracy....see table 1, p.8 -! of stipanuk (1973) for equation used in iteration. - - DO i= 1,12 - tqk= tq-273.15 - d= d/2. - x= a*EXP(-b*w(tqk,p)/tq)-tq*((1000./p)**.286) - IF (ABS(x) < 1E-7) GOTO 2 - tq= tq+SIGN(d,x) - END DO -2 tsa= tq-273.15 - RETURN - END FUNCTION tsa - - FUNCTION tw(t,td,p) -! this function returns the wet-bulb temperature tw (celsius) -! given the temperature t (celsius), dew point td (celsius) -! and pressure p (mb). see p.13 in stipanuk (1973), referenced -! above, for a description of the technique. -! -! -! determine the mixing ratio line thru td and p. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: t,td,p - real(r_kind) :: tw - - real(r_kind) :: aw,ao,pi,tmr,tda,ti,aos,tsa,w,x - integer :: i - - aw = w(td,p) -! -! determine the dry adiabat thru t and p. - - ao = (t+273.15)*((1000./p)**.286)-273.15 - pi = p - -! iterate to locate pressure pi at the intersection of the two -! curves . pi has been set to p for the initial guess. - - DO i= 1,10 - x= .02*(tmr(aw,pi)-tda(ao,pi)) - IF (ABS(x) < 0.01) EXIT - pi= pi*(2.**(x)) - END DO - -! find the temperature on the dry adiabat ao at pressure pi. - - ti= tda(ao,pi) - -! the intersection has been located...now, find a saturation -! adiabat thru this point. function os returns the equivalent -! potential temperature (c) of a parcel saturated at temperature -! ti and pressure pi. - - aos= (ti+273.15)*((1000./pi)**.286)*(EXP(2.6518986*w(ti,pi)/(ti+273.15)))-273.15 - -! function tsa returns the wet-bulb temperature (c) of a parcel at -! pressure p whose equivalent potential temperature is aos. - - tw = tsa(aos,p) - RETURN - END FUNCTION tw - - FUNCTION w(t,p) -! -! this function returns the mixing ratio (grams of water vapor per -! kilogram of dry air) given the dew point (celsius) and pressure -! (millibars). if the temperture is input instead of the -! dew point, then saturation mixing ratio (same units) is returned. -! the formula is found in most meteorological texts. - use kinds, only: r_single,i_kind,r_kind - implicit none - real(r_kind), intent(in) :: t,p - real(r_kind) :: w - - real(r_kind) :: esat - - w= 622.*esat(t)/(p-esat(t)) - RETURN - END FUNCTION w diff --git a/lib/GSD/gsdcloud4nmmb/pbl_height.f90 b/lib/GSD/gsdcloud4nmmb/pbl_height.f90 deleted file mode 100755 index 6466899f0..000000000 --- a/lib/GSD/gsdcloud4nmmb/pbl_height.f90 +++ /dev/null @@ -1,103 +0,0 @@ -SUBROUTINE calc_pbl_height(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk,pblh) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: pbl_height to calculate PBL height or level -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-04-06 -! -! ABSTRACT: -! This subroutine calculate PBL height -! -! PROGRAM HISTORY LOG: -! -! -! input argument list: -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! q_bk - 3D moisture -! t_bk - 3D background potential temperature (K) -! p_bk - 3D background pressure (hPa) -! -! output argument list: -! pblh - 2D PBL height (level number) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind, r_kind - - implicit none - - integer(i_kind),intent(in):: mype - integer(i_kind),intent(in):: nlat,nlon,nsig -! -! background -! - real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) - real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) - real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) -! -! Variables for cloud analysis -! - real (r_single),intent(out) :: pblh(nlon,nlat) -! -!----------------------------------------------------------- -! -! temp. -! - INTEGER(i_kind) :: i,j,k - real(r_single) :: thetav(nsig) - real(r_single) :: thsfc,qsp - -!==================================================================== -! Begin -! -! - DO j = 1,nlat - DO i = 1,nlon - - DO k = 1,nsig - qsp=q_bk(i,j,k)/(1.0+q_bk(i,j,k)) ! q_bk = water vapor mixing ratio - thetav(k) = t_bk(i,j,k)*(1.0 + 0.61 * qsp) ! qsp = spcific humidity -! if(mype==10.and.i==10.and.j==10) then -! write(*,*) 'cal PBL=',k,thetav(k),t_bk(i,j,k),q_bk(i,j,k) -! endif - ENDDO - - pblh(i,j) = 0.0_r_single - thsfc = thetav(1) - k=1 - DO while (abs(pblh(i,j)) < 0.0001_r_single) - if( thetav(k) > thsfc + 1.0_r_single ) then - pblh(i,j) = float(k) - (thetav(k) - (thsfc + 1.0_r_single))/ & - max((thetav(k)-thetav(k-1)),0.01_r_single) - endif - k=k+1 - ENDDO - if(abs(pblh(i,j)) < 0.0001) pblh(i,j)=2.0_r_single - -! if(mype==10.and.i==10.and.j==10) then -! write(*,*) 'cal PBL=',pblh(i,j),k -! endif - - - enddo ! i - enddo ! j - -END SUBROUTINE calc_pbl_height - diff --git a/lib/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 b/lib/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 deleted file mode 100755 index 2548e943b..000000000 --- a/lib/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 +++ /dev/null @@ -1,757 +0,0 @@ - -SUBROUTINE pcp_mxr (nx,ny,nz,t_3d,p_3d ,ref_3d & - ,cldpcp_type_3d & - ,qr_3d,qs_3d,qg_3d,istatus ) - -! -!$$$ subprogram documentation block -! . . . . -! subprogram: pcp_mxr calculates hydrometeor mixing ratios based on Kessler radar reflectivity equations -! -! PRGMMR: ORG: DATE: -! -! ABSTRACT: -! This subroutine calculate precipitation based on Kessler radar reflectivity equations -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nz - no. of levels -! t_3d - 3D background temperature (K) -! p_3d - 3D background pressure (hPa) -! ref_3d - 3D reflectivity in analysis grid (dBZ) -! cldpcp_type_3d - 3D precipitation type -! -! output argument list: -! qr_3d - rain mixing ratio (g/kg) -! qs_3d - snow mixing ratio (g/kg) -! qg_3d - graupel/hail mixing ratio (g/kg) -! istatus - -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! Old documents from CAPS -! -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Perform 3D precipitation mixing ratio (in g/kg) analysis using -! radar reflectivity data. For rain water, using Kessler (1969) -! formula: -! qr(g/kg) = a*(rho*arg)**b (1) -! -! Here arg = Z (mm**6/m**3), and dBZ = 10log10 (arg). -! Coeffcients a=17300.0, and b=7/4. -! rho represents the air density. -! -! For snow and graupel/hail, using Rogers and Yau (1989) formula: -! -! qs(g/kg) = c*(rho*arg)**d (2) -! -! where, c=38000.0, d=2.2 -! -! -!----------------------------------------------------------------------- -! -! AUTHOR: (Jian Zhang) -! 06/13/96 -! -! MODIFICATION HISTORY: -! 07/30/97 (J. Zhang) -! Added precipitation type in the argument list so that -! mixing ratios of different precip. types can be computed. -! 09/04/97 (J. Zhang) -! Changed the radar echo thresholds for inserting precip. -! from radar reflectivities. -! -!----------------------------------------------------------------------- -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - -! -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind, r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - integer(i_kind),intent(in) :: nx,ny,nz ! Model grid size -! - REAL(r_kind), intent(in) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) - real(r_single),intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) - real(r_single),intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) - - integer(i_kind),intent(in):: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field -! -! OUTPUT: - INTEGER(i_kind),intent(out) :: istatus -! - REAL(r_single),intent(out) :: qr_3d(nx,ny,nz)! rain mixing ratio in (g/kg) - REAL(r_single),intent(out) :: qs_3d(nx,ny,nz)! snow/sleet/frz-rain mixing ratio - ! in (g/kg) - REAL(r_single),intent(out) :: qg_3d(nx,ny,nz)! graupel/hail mixing ratio in (g/kg) -! -! LOCAL: - REAL(r_kind) :: a,b,c,d ! Coef. for Z-qr relation. - PARAMETER (a=17300.0_r_kind, b=7.0/4.0_r_kind) - PARAMETER (c=38000.0_r_kind, d=2.2_r_kind) - REAL(r_kind) :: rair ! Gas constant (J/deg/kg) - PARAMETER (rair = 287.04_r_kind) - REAL(r_kind) :: thresh_ref - PARAMETER (thresh_ref = 0.0_r_kind) - INTEGER(i_kind) :: pcptype -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind) :: i,j,k, iarg - REAL(r_kind) :: arg,rhobar,br,dr - PARAMETER (br=1.0_r_kind/b, dr=1.0_r_kind/d) -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! - istatus=0 -! -!----------------------------------------------------------------------- -! -! Compute the precip mixing ratio in g/kg from radar reflectivity -! factor following Kessler (1969) or Rogers and Yau (1989). -! -!----------------------------------------------------------------------- -! - DO k = 1,nz-1 - DO j = 2,ny-1 - DO i = 2,nx-1 - IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. - rhobar = p_3d(i,j,k)/rair/t_3d(i,j,k) - arg = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) - iarg = cldpcp_type_3d(i,j,k) - pcptype = iarg/16 ! precip. type - - IF (pcptype == 0) THEN ! no precip - PRINT*,'+++ NOTE: radar echo though no precip. +++' - ELSE IF (pcptype == 1.OR.pcptype == 3) THEN ! rain or Z R - qr_3d(i,j,k) = (arg/a)**br/rhobar - ELSE IF (pcptype == 2) THEN ! snow - qs_3d(i,j,k) = (arg/c)**dr/rhobar - ELSE IF (pcptype == 4.OR.pcptype == 5) THEN ! hail or sleet - qg_3d(i,j,k) = (arg/c)**dr/rhobar - ELSE ! unknown - PRINT*,'+++ NOTE: unknown precip type. +++' - END IF - ELSE - qr_3d(i,j,k) = 0._r_kind - qs_3d(i,j,k) = 0._r_kind - qg_3d(i,j,k) = 0._r_kind - END IF - END DO ! k - END DO ! i - END DO ! j -! -!----------------------------------------------------------------------- -! - istatus = 1 -! - RETURN -END SUBROUTINE pcp_mxr - -! -SUBROUTINE pcp_mxr_ferrier_new (nx,ny,nz,t_3d,p_3d ,ref_3d & - ,cldpcp_type_3d,q_3d & - ,qr_3d,qs_3d,qg_3d,istatus ) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: pcp_mxr calculate hydrometeor type based on ferrier radar reflectivity equations -! from Carley's setup_dbz.f90 and old Hu's pcp_mxr_ferrier -! -! PRGMMR: Shun Liu ORG: EMC/NCEP DATE: -! -! ABSTRACT: -! This subroutine calculate precipitation based on ferrier radar reflectivity equations -! -! PROGRAM HISTORY LOG: -! 2014-12-01 Shun Liu create for new NMMB ferrier -! -! -! input argument list: -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nz - no. of levels -! t_3d - 3D background temperature (K) -! p_3d - 3D background pressure (hPa) -! ref_3d - 3D reflectivity in analysis grid (dBZ) -! cldpcp_type_3d - 3D precipitation type -! -! output argument list: -! qr_3d - rain mixing ratio (g/kg) -! qs_3d - snow mixing ratio (g/kg) -! istatus - -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! Old document from CAPS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Perform 3D precipitation mixing ratio (in g/kg) analysis using -! radar reflectivity data. For rain water, using Ferrier et al (1995) -! formulation: -! -! -! For rain water: -! -! 18 -! 10 * 720 1.75 -! Zer = --------------------------- * (rho * qr) -! 1.75 0.75 1.75 -! pi * N0r * rhor -! -! -! For dry snow (t <= 0 C): -! -! -! 18 -! 0.224 * 10 * 720 -! 2 -! Zes = ------------------------------------- * (rho * qs) -! 2 2 -! pi * rhol * N0s -! -! n(0)r -> intercept parameter for rain 8x10^-6 (m^-4) -! rho_l -> density of liquid water 1000 (kg/m^3) -! rho -> air density (kg/m^3) -! qr -> rain mixing ratio (kg/kg) -! qli -> precipitation ice mixing ratio (kg/kg) -! N_li -> precipitation ice number concentration 5x10^3 (m^-3) -! -! -! Plugging in the constants yields the following form: -! -! Zer = Cr * (rho*qr)^1.75 -! Zeli = Cli * (rho*qli)^2 -! -! where: -! Cr = 3.6308 * 10^9 -! Cli = 3.268 * 10^9 -! -! Which yields the forward model: -! -! Z = 10*log10(Zer+Zes) -! -! -! Here Zx (mm**6/m**3, x=r,s,h), and dBZ = 10log10 (Zx). -! rho represents the air density, rhor,rhos,rhoh are the density of -! rain, snow and hail respectively. Other variables are all constants -! for this scheme, see below. -! -! Zer = Cr * (rho*qr)^1.75 -! Zeli = Cli * (rho*qli)^2 -! -! where: -! Cr = 3.6308 * 10^9 -! Cli = 3.268 * 10^9 - -! (Zer)^(1/1.75)=(rho*qr) -! (Zer/Cr)^(1/1.75)=rho*qr -! [(Zer/Cr)^(1/1.75)]/rho=qr - -! [(Zeli/Cli)^(1/2)]/rho=qs - -! -!----------------------------------------------------------------------- -! -! AUTHOR: (Shun Liu) -! 01/20/2015 -! -! MODIFICATION HISTORY: -! -!----------------------------------------------------------------------- -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind, r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size -! - REAL(r_kind), intent(in) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) - REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) - REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) - REAL(r_single), intent(in) :: q_3d(nx,ny,nz) ! mixing ratio in (g/g) - - INTEGER(i_kind),intent(in) :: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field -! -! OUTPUT: - INTEGER(i_kind),intent(out):: istatus -! - REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio in (g/kg) - REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow/sleet/frz-rain mixing ratio - ! in (g/kg) - REAL(r_single),intent(out) :: qg_3d(nx,ny,nz) ! graupel/hail mixing ratio - ! in (g/kg) -! - - - - REAL(r_kind), PARAMETER :: rd=287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) - REAL(r_kind), PARAMETER :: thresh_ref = 0.0_r_kind - - REAL(r_kind), PARAMETER :: ze_qr_const=3.6308*1.0e9 - REAL(r_kind), PARAMETER :: ze_qs_const=3.268*1.0e9 - REAL(r_kind) :: ze_d_qrcon,ze_d_qscon - -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind) :: i,j,k, iarg - INTEGER(i_kind) :: pcptype - REAL(r_kind) :: zkconst,zerf,zesnegf,zesposf,zehf,rfract - REAL(r_kind) :: ze,zer,zeh,zes,rho,tc - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Intiailize constant factors in the Ze terms for rain, snow and graupel/hail, -! respectively, in Ferrier. -! -! These are the inverse of those presented in the reflec_ferrier function. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! Compute the precip mixing ratio in g/kg from radar reflectivity -! factor following Ferrier et al (1995). -! -!----------------------------------------------------------------------- -! - -! qr_3d = -999._r_kind -! qs_3d = -999._r_kind - qg_3d = -999._r_kind - - DO k = 2,nz-1 - DO j = 2,ny-1 - DO i = 2,nx-1 - IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. - rho = p_3d(i,j,k)/(rd*t_3d(i,j,k))*(1.0+0.608*(q_3d(i,j,k)/1.0+q_3d(i,j,k))) - ze = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) - tc = t_3d(i,j,k) - 273.15_r_kind - IF (tc >= 0.0_r_kind) THEN - ze_d_qrcon=ze/ze_qr_const - qr_3d(i,j,k) = (ze_d_qrcon)**(1/1.75) !/ rho - else - ze_d_qscon=ze/ze_qs_const - qs_3d(i,j,k) = (ze_d_qscon)**(0.5) !/ rho - ENDIF - END IF - END DO ! k - END DO ! i - END DO ! j - -! qr_3d=qr_3d*1000.0 !kg/kg to g/kg -! qs_3d=qs_3d*1000.0 !kg/kg to g/kg - -! PRINT*,'Finish Ferrier ...' -! -!----------------------------------------------------------------------- -! - istatus = 1 -! - RETURN -END SUBROUTINE pcp_mxr_ferrier_new - -! -SUBROUTINE pcp_mxr_ferrier (nx,ny,nz,t_3d,p_3d ,ref_3d & - ,cldpcp_type_3d & - ,qr_3d,qs_3d,qg_3d,istatus,mype ) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: pcp_mxr calculate hydrometeor type based on ferrier radar reflectivity equations -! -! PRGMMR: ORG: DATE: -! -! ABSTRACT: -! This subroutine calculate precipitation based on ferrier radar reflectivity equations -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! nx - no. of lons on subdomain (buffer points on ends) -! ny - no. of lats on subdomain (buffer points on ends) -! nz - no. of levels -! t_3d - 3D background temperature (K) -! p_3d - 3D background pressure (hPa) -! ref_3d - 3D reflectivity in analysis grid (dBZ) -! cldpcp_type_3d - 3D precipitation type -! -! output argument list: -! qr_3d - rain mixing ratio (g/kg) -! qs_3d - snow mixing ratio (g/kg) -! qg_3d - graupel/hail mixing ratio (g/kg) -! istatus - -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! Old document from CAPS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! PURPOSE: -! -! Perform 3D precipitation mixing ratio (in g/kg) analysis using -! radar reflectivity data. For rain water, using Ferrier et al (1995) -! formulation: -! -! -! For rain water: -! -! 18 -! 10 * 720 1.75 -! Zer = --------------------------- * (rho * qr) -! 1.75 0.75 1.75 -! pi * N0r * rhor -! -! -! For dry snow (t <= 0 C): -! -! -! 18 2 0.25 -! 10 * 720 * |K| * rhos -! ice 1.75 -! Zes = ----------------------------------------- * (rho * qs) t <= 0 C -! 1.75 2 0.75 2 -! pi * |K| * N0s * rhoi -! water -! -! -! For wet snow (t >= 0 C): -! -! -! 18 -! 10 * 720 1.75 -! Zes = ---------------------------- * (rho * qs) t > 0 C -! 1.75 0.75 1.75 -! pi * N0s * rhos -! -! -! For hail water: -! -! -! / 18 \ 0.95 -! / 10 * 720 \ 1.6625 -! Zeh = | ---------------------------- | * (rho * qg) -! \ 1.75 0.75 1.75 / -! \ pi * N0h * rhoh / -! -! Here Zx (mm**6/m**3, x=r,s,h), and dBZ = 10log10 (Zx). -! rho represents the air density, rhor,rhos,rhoh are the density of -! rain, snow and hail respectively. Other variables are all constants -! for this scheme, see below. -! -! -!----------------------------------------------------------------------- -! -! AUTHOR: (Donghai Wang and Eric Kemp) -! 07/20/2000 -! -! MODIFICATION HISTORY: -! -! 11/09/2000 Keith Brewster -! Moved some parameters with real-valued exponentiation to be -! computed at runtime due to compiler complaint. -! -! 04/07/2003 Keith Brewster -! Restructured code to make more tractable.and consistent with -! the reflec_ferrier subroutine. -! -!----------------------------------------------------------------------- -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - -!----------------------------------------------------------------------- -! -! Variable Declarations. -! -!----------------------------------------------------------------------- -! - use kinds, only: r_single,i_kind, r_kind - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -! INPUT: - INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size -! - REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) - REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) - REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) - - INTEGER(i_kind),intent(in) :: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field - INTEGER(i_kind),intent(in) :: mype -! -! OUTPUT: - INTEGER(i_kind),intent(out):: istatus -! - REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio in (g/kg) - REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow/sleet/frz-rain mixing ratio - ! in (g/kg) - REAL(r_single),intent(out) :: qg_3d(nx,ny,nz) ! graupel/hail mixing ratio - ! in (g/kg) -! - - REAL(r_kind),PARAMETER :: ki2 = 0.176_r_kind ! Dielectric factor for ice if other - ! than melted drop diameters are used. - REAL(r_kind),PARAMETER :: kw2=0.93_r_kind ! Dielectric factor for water. - - REAL(r_kind),PARAMETER :: m3todBZ=1.0E+18_r_kind ! Conversion factor from m**3 to - ! mm**6 m**-3. - REAL(r_kind),PARAMETER :: Zefact=720.0_r_kind ! Multiplier for Ze components. - REAL(r_kind),PARAMETER :: lg10div=0.10_r_kind ! Log10 multiplier (1/10) - - REAL(r_kind),PARAMETER :: pi=3.1415926_r_kind! Pi. - REAL(r_kind),PARAMETER :: N0r=8.0E+06_r_kind ! Intercept parameter in 1/(m^4) for rain. - REAL(r_kind),PARAMETER :: N0s=3.0E+06_r_kind ! Intercept parameter in 1/(m^4) for snow. - REAL(r_kind),PARAMETER :: N0h=4.0E+04_r_kind ! Intercept parameter in 1/(m^4) for graupel/hail. - - REAL(r_kind),PARAMETER :: N0xpowf=3.0/7.0_r_kind ! Power to which N0r,N0s & N0h are - ! raised. - REAL(r_kind),PARAMETER :: K2powf=4.0/7.0_r_kind ! Power to which K-squared - ! of ice, water are raised - REAL(r_kind),PARAMETER :: zkpowf=4.0/7.0_r_kind ! Power to which Zk is raised - REAL(r_kind),PARAMETER :: zepowf=4.0/7.0_r_kind ! Power to which Ze is raised - REAL(r_kind),PARAMETER :: zehpowf=(4.0/7.0)*1.0526_r_kind ! Power to which Zeh is raised - - REAL(r_kind),PARAMETER :: rhoi=917._r_kind ! Density of ice (kg m**-3) - REAL(r_kind),PARAMETER :: rhor=1000._r_kind ! Density of rain (kg m**-3) - REAL(r_kind),PARAMETER :: rhos=100._r_kind ! Density of snow (kg m**-3) - REAL(r_kind),PARAMETER :: rhoh=913._r_kind ! Density of graupel/hail (kg m**-3) - - REAL(r_kind),PARAMETER :: rhoipowf=8.0/7.0_r_kind ! Power to which rhoi is raised. - REAL(r_kind),PARAMETER :: rhospowf=1.0/7.0_r_kind ! Power to which rhos is raised. - - REAL(r_kind), PARAMETER :: rd=287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) - REAL(r_kind), PARAMETER :: thresh_ref = 0.0_r_kind -! -!----------------------------------------------------------------------- -! -! Misc local variables -! -!----------------------------------------------------------------------- -! - INTEGER(i_kind) :: i,j,k, iarg - INTEGER(i_kind) :: pcptype - REAL(r_kind) :: zkconst,zerf,zesnegf,zesposf,zehf,rfract - REAL(r_kind) :: ze,zer,zeh,zes,rho,tc - -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! Beginning of executable code... -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! -!----------------------------------------------------------------------- -! -! Intiailize constant factors in the Ze terms for rain, snow and graupel/hail, -! respectively, in Ferrier. -! -! These are the inverse of those presented in the reflec_ferrier function. -! -!----------------------------------------------------------------------- -! - istatus=0 - - zkconst = (Zefact*m3todBZ) ** zkpowf - - zerf=1000._r_kind*(pi * (N0r**N0xpowf) * rhor )/zkconst - - zesnegf=1000._r_kind*(pi*(kw2**k2powf)*(N0s**N0xpowf)*(rhoi**rhoipowf)) / & - ( zkconst * (ki2**k2powf) * (rhos**rhospowf) ) - - zesposf=1000._r_kind*( pi * (N0s**N0xpowf) * rhos) / zkconst - - zehf=1000._r_kind*( pi * (N0h**N0xpowf) * rhoh) / zkconst - -!----------------------------------------------------------------------- -! -! Compute the precip mixing ratio in g/kg from radar reflectivity -! factor following Ferrier et al (1995). -! -!----------------------------------------------------------------------- -! -!mhu if(mype==51 ) then -!mhu write(*,*) 'c=',mype,zesnegf,zepowf,rd -!mhu ref_3d(10,10,:)=10.0 -!mhu ref_3d(11,11,:)=20.0 -!mhu ref_3d(12,12,:)=30.0 -!mhu ref_3d(13,13,:)=40.0 -!mhu ref_3d(14,14,:)=50.0 -!mhu endif - - DO k = 2,nz-1 - DO j = 2,ny-1 - DO i = 2,nx-1 - IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. - rho = p_3d(i,j,k)/(rd*t_3d(i,j,k)) - ze = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) - iarg = cldpcp_type_3d(i,j,k) - pcptype = iarg/16 ! precip. type - tc = t_3d(i,j,k) - 273.15_r_kind -!mhu temporal fix - IF (tc <= 0.0_r_kind) THEN - qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho - qr_3d(i,j,k) = 0.0_r_kind - ELSE IF (tc < 5.0_r_kind) THEN !wet snow - rfract=0.20_r_kind*tc - zer=rfract*ze - zes=(1.-rfract)*ze -! qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho -! qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - qs_3d(i,j,k) = zesnegf * (zes**zepowf) / rho - qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - else - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - qs_3d(i,j,k) = 0.0_r_kind - ENDIF - cycle -!mhu - IF (pcptype == 1) THEN ! rain - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - ELSE IF (pcptype == 2) THEN ! snow - IF (tc <= 0.0_r_kind) THEN !dry snow - qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho - ELSE IF (tc < 5.0_r_kind) THEN !wet snow - rfract=0.20_r_kind*tc - zer=rfract*ze - zes=(1.-rfract)*ze - qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho - qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - ELSE - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - END IF - ELSE IF (pcptype == 3) THEN ! ZR - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - ELSE IF (pcptype == 4) THEN ! sleet - IF (tc <= 0.0_r_kind) THEN ! graupel/hail category - qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho - ELSE IF( tc < 10._r_kind ) THEN - rfract=0.10_r_kind*tc - zer=rfract*ze - zeh=(1.-rfract)*ze - qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - qg_3d(i,j,k) = zehf * (zeh**zehpowf) / rho - ELSE - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - END IF - ELSE IF (pcptype == 5) THEN ! graupel/hail - qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho - ELSE ! unknown - IF (tc <= 0.0_r_kind) THEN !dry snow - qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho - ELSE IF ( tc < 5.0_r_kind ) THEN !wet snow - rfract=0.20_r_kind*tc - zer=rfract*ze - zes=(1.-rfract)*ze - qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho - qr_3d(i,j,k) = zerf * (zer**zepowf) / rho - ELSE ! rain - qr_3d(i,j,k) = zerf * (ze**zepowf) / rho - END IF - END IF - ELSE - qr_3d(i,j,k) = -999._r_kind - qs_3d(i,j,k) = -999._r_kind - qg_3d(i,j,k) = -999._r_kind - END IF - END DO ! k - END DO ! i - END DO ! j -! PRINT*,'Finish Ferrier ...' -! -!----------------------------------------------------------------------- -! - istatus = 1 -! - RETURN -END SUBROUTINE pcp_mxr_ferrier diff --git a/lib/GSD/gsdcloud4nmmb/radar_ref2tten.f90 b/lib/GSD/gsdcloud4nmmb/radar_ref2tten.f90 deleted file mode 100755 index 70570af91..000000000 --- a/lib/GSD/gsdcloud4nmmb/radar_ref2tten.f90 +++ /dev/null @@ -1,631 +0,0 @@ -SUBROUTINE radar_ref2tten(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mos_3d, & - cld_cover_3d,p_bk,t_bk,ges_tten,dfi_rlhtp,krad_bot_in,pblh,sat_ctp) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: radar_ref2tten convert radar reflectivity to 3-d temperature tendency -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-27 -! -! ABSTRACT: -! This subroutine converts radar observation (dBZ) to temperature tendency for DFI -! -! PROGRAM HISTORY LOG: -! 2009-01-02 Hu Add NCO document block -! 2016-05-08 S.Liu tune the relation between ref and tten -! -! -! input argument list: -! mype - processor ID -! istat_radar - radar data status: 0=no radar data; 1=use radar reflectivity -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! ref_mos_3d - 3D radar reflectivity (dBZ) -! cld_cover_3d - 3D cloud cover (0-1) -! p_bk - 3D background pressure (hPa) -! t_bk - 3D background potential temperature (K) -! sat_ctp - 2D NESDIS cloud top pressure (hPa) -! ges_tten - 3D radar temperature tendency -! dfi_rlhtp - dfi radar latent heat time period. DFI forward integration window in minutes -! krad_bot_in - radar bottome height -! pblh - PBL height in grid unit -! -! output argument list: -! ges_tten - 3D radar temperature tendency -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use constants, only: rd_over_cp, h1000 - use kinds, only: r_kind,i_kind,r_single - implicit none - - INTEGER(i_kind),INTENT(IN) :: mype - INTEGER(i_kind),INTENT(IN) :: nlon,nlat,nsig - INTEGER(i_kind),INTENT(IN) :: istat_radar - INTEGER(i_kind),INTENT(IN) :: istat_lightning - real(r_kind),INTENT(IN) :: dfi_rlhtp - real(r_single),INTENT(IN) :: krad_bot_in - real(r_single),INTENT(IN) :: pblh(nlon,nlat) - - real(r_kind),INTENT(IN) :: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid - real(r_single),INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) - real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) - real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature - real(r_kind), INTENT(INOUT):: ges_tten(nlat,nlon,nsig,1) - real(r_single),INTENT(IN),OPTIONAL :: sat_ctp(nlon,nlat) - - real (r_single) :: tbk_k - - real(r_kind), allocatable :: tten_radar(:,:,:) ! - real(r_kind), allocatable :: dummy(:,:) ! - - integer krad_bot ! RUC bottom level for TTEN_RAD -! -! convection suppression -! - real(r_kind), allocatable :: radyn(:,:) - real(r_kind) :: radmax, dpint - integer(i_kind) :: nrad - real(r_kind) :: radmaxall, dpintmax - -! adopted from: METCON of RUC (/ihome/rucdev/code/13km/hybfront_code) -! CONTAINS ATMOSPHERIC/METEOROLOGICAL/PHYSICAL CONSTANTS -!** R_P R J/(MOL*K) UNIVERSAL GAS CONSTANT -!** R* = 8.31451 -!** MD_P R KG/MOL MEAN MOLECULAR WEIGHT OF DRY AIR -!** MD = 0.0289645 -!jmb--Old value MD = 0.0289644 -!** RD_P R J/(KG*K) SPECIFIC GAS CONSTANT FOR DRY AIR -!** RD = R*>/-100) then ! no echo - tten_radar(i,j,k) = 0._r_kind - else if (ref_mos_3d(i,j,k)>=0.001_r_kind) then ! echo - iskip=0 - if (PRESENT(sat_ctp) ) then - if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then - iskip=iskip+1 -! write (6,*)' Radar ref > 5 dbZ, GOES indicates clear' -! write (6,*)' i,j,k / refl / lat-lon',i,j,k,ref_mos_3d(i,j,k) -! Therefore, if GOES indicates clear, tten_radar -! will retain the zero value - endif - endif - if (tbk_k>277.15_r_kind .and. ref_mos_3d(i,j,k)<28._r_kind) then - iskip=iskip+1 -! write (6,*)' t is over 277 ',i,j,k,ref_mos_3d(i,j,k) -! ALSO, if T > 4C and refl < 28dBZ, again -! tten_radar = 0. - endif - if(iskip == 0 ) then -! tten_radar set as non-zero ONLY IF -! - not contradicted by GOES clear, and -! - ruc_refl > 28 dbZ for temp > 4K, and -! - for temp < 4K, any ruc_refl dbZ is OK. -! - cloudy and under GOES cloud top -! - dfi_rlhtp in minutes - if (k>=krad_bot) then -! can not use cld_cover_3d because we don't use reflectivity to build cld_cover_3d -! if (abs(cld_cover_3d(i,j,k))<=0.5_r_kind .and. (sat_ctp(i,j)>p_bk(i,j,k))) then - if (sat_ctp(i,j)>p_bk(i,j,k)) then - addsnow=0.0_r_kind - else - addsnow = 10**(ref_mos_3d(i,j,k)/(17.8_r_kind*2.0))/264083._r_kind*9.0_r_kind - endif - tten = ((1000.0_r_kind/p_bk(i,j,k))**(1._r_kind/cpovr_p)) & - *(((LV_P+LF0_P)*addsnow)/ & - (2.0*dfi_rlhtp*60.0_r_kind*CPD_P)) - tten_radar(i,j,k)= min(0.01_r_kind,max(-0.01_r_kind,tten)) - end if - end if - end if ! ref_mos_3d - - ENDDO - ENDDO - ENDDO - -! DO k=1,nsig -! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) -! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) -! ENDDO - -!================================================================================ -! At this point -! 1. put tten_radar into ges_tten array -! for use as tten_radar in subsequent model DFI. -! 2. calculate convection suppression array (RADYN), by -! first smoothing further the tten_radar array -! (available since it is already copied to ges_tten) -! and with adding clear areas from GOES cloud data. - -! KEY element -- Set tten_radar to no-coverage AFTER smoothing -! where ref_mos_3d had been previously set to no-coverage (-99.0 dbZ) -!================================================================================ - - DO k=1,nsig - DO j=1,nlat - DO i=1,nlon - ges_tten(j,i,k,1)=tten_radar(i,j,k) - if(ref_mos_3d(i,j,k)<=-200.0_r_kind ) ges_tten(j,i,k,1)=-spval_p ! no obs - ENDDO - ENDDO - ENDDO -! DO k=1,nsig -! write(6,*)' k,max,min check=',mype,k,maxval(ges_tten(:,:,k,1)),minval(ges_tten(:,:,k,1)) -! enddo - -! -- Whack (smooth) the tten_radar array some more. -! for convection suppression in the radyn array. - DO k=1,nsig - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - ENDDO - - deallocate(dummy) - -! RADYN array = convection suppression array -! Definition of RADYN values -! -10 -> no information -! 0 -> no convection -! 1 -> there might be convection nearby -! NOTE: 0,1 values are only possible if -! deep radar coverage is available (i.e., > 300 hPa deep) - -! RADYN is read into RUC model as array PCPPREV, -! where it is used to set the cap_depth (cap_max) -! in the Grell-Devenyi convective scheme -! to a near-zero value, effectively suppressing convection -! during DFI and first 30 min of the forward integration. - - allocate(radyn(nlon,nlat)) - radyn = -10._r_kind - - radmaxall=-999 - dpintmax=-999 - DO j=1,nlat - DO i=1,nlon - - nrad = 0 - radmax = 0._r_kind - dpint = 0._r_kind - DO k=2,nsig-1 - if ((ref_mos_3d(i,j,k))<=-200.0_r_kind) tten_radar(i,j,k) = -spval_p - if (tten_radar(i,j,k)>-15._r_kind) then - nrad=nrad+1 - dpint = dpint + 0.5_r_kind*(p_bk(i,j,k-1)-p_bk(i,j,k+1)) - radmax = max(radmax,tten_radar(i,j,k)) - end if - ENDDO - if (dpint>=300._r_kind ) then - radyn(i,j) = 0._r_kind - if (radmax>0.00002_r_kind) radyn(i,j) = 1. - if( abs(radyn(i,j)) < 0.00001_r_kind ) then - krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height - do k=krad_bot,nsig-1 - ges_tten(j,i,k,1) = 0._r_kind - end do - endif - else -! outside radar coverage area where satellite shows clear conditions, -! then add this area to the convection suppress area. - if (PRESENT(sat_ctp) ) then - if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then - radyn(i,j) = 0._r_kind - endif - endif - endif - -! 2. Extend depth of no-echo zone from dpint zone down to PBL top, -! similarly to how lowest echo (with convection) is extended down to PBL top -! 5/27/2010 - Stan B. -! if (dpint >= 300. .and. radmax<=0.001) then -! krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height -! do k=krad_bot,nsig-1 -! ges_tten(j,i,k,1) = 0._r_kind -! end do -! end if - - if(dpintmax < dpint ) dpintmax=dpint - if(radmaxall< radmax) radmaxall=radmax - ENDDO - ENDDO - - DO j=1,nlat - DO i=1,nlon -! ges_tten(j,i,nsig,1)=radyn(i,j) - ges_tten(j,i,nsig,1)=0.0 - ENDDO - ENDDO - - deallocate(tten_radar) - deallocate(radyn) - - else ! no radar observation i this subdomain - - ges_tten=-spval_p - ges_tten(:,:,nsig,1)=-10.0_r_kind - - DO j=1,nlat - DO i=1,nlon - -! outside radar observation domain and satellite show clean, the suppress convection - if (PRESENT(sat_ctp) ) then - if (sat_ctp(i,j)>=1010._r_kind .and. sat_ctp(i,j)<=1100._r_kind) then - ges_tten(j,i,nsig,1) = 0. - endif - endif - ENDDO - ENDDO - - endif - - DO k=1,nsig - DO j=1,nlat - DO i=1,nlon - if(ges_tten(j,i,k,1) <= -200.0_r_kind ) ges_tten(j,i,k,1)=-20.0_r_kind ! no obs - ENDDO - ENDDO - ENDDO - -END SUBROUTINE radar_ref2tten - -SUBROUTINE radar_ref2tten_nosat(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mos_3d,cld_cover_3d,& - p_bk,t_bk,ges_tten,dfi_rlhtp,krad_bot_in,pblh) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: radar_ref2tten convert radar observation to temperature tedency -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-27 -! -! ABSTRACT: -! This subroutine converts radar reflectivity (dBZ) to temperature tendency for DFI -! -! PROGRAM HISTORY LOG: -! 2009-01-02 Hu Add NCO document block -! 2016-05-08 S.Liu tune the relation between ref and tten -! -! -! input argument list: -! mype - processor ID -! istat_radar - radar data status: 0=no radar data; 1=use radar reflectivity -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! ref_mos_3d - 3D radar reflectivity (dBZ) -! cld_cover_3d - 3D cloud cover (0-1) -! p_bk - 3D background pressure (hPa) -! t_bk - 3D background potential temperature (K) -! ges_tten - 3D radar temperature tendency -! dfi_rlhtp - dfi radar latent heat time period -! krad_bot_in - radar bottome height -! pblh - PBL height in grid unit -! -! output argument list: -! ges_tten - 3D radar temperature tendency -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use constants, only: rd_over_cp, h1000 - use kinds, only: r_kind,i_kind,r_single - implicit none - - INTEGER(i_kind),INTENT(IN) :: mype - INTEGER(i_kind),INTENT(IN) :: nlon,nlat,nsig - INTEGER(i_kind),INTENT(IN) :: istat_radar - INTEGER(i_kind),INTENT(IN) :: istat_lightning - real(r_kind),INTENT(IN) :: dfi_rlhtp - real(r_single),INTENT(IN) :: krad_bot_in - real(r_single),INTENT(IN) :: pblh(nlon,nlat) - - real(r_kind),INTENT(IN) :: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid - real(r_single),INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) - real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) - real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) - real(r_kind), INTENT(INOUT):: ges_tten(nlat,nlon,nsig,1) - - real (r_single) :: tbk_k - - real(r_kind), allocatable :: tten_radar(:,:,:) ! - real(r_kind), allocatable :: dummy(:,:) ! - - integer(i_kind) :: krad_bot ! RUC bottom level for TTEN_RAD - ! and for filling from above -! -! convection suppression -! - real(r_kind), allocatable :: radyn(:,:) - real(r_kind) :: radmax, dpint - integer(i_kind) :: nrad - real(r_kind) :: radmaxall, dpintmax - -! adopted from: METCON of RUC (/ihome/rucdev/code/13km/hybfront_code) -! CONTAINS ATMOSPHERIC/METEOROLOGICAL/PHYSICAL CONSTANTS -!** R_P R J/(MOL*K) UNIVERSAL GAS CONSTANT -!** R* = 8.31451 -!** MD_P R KG/MOL MEAN MOLECULAR WEIGHT OF DRY AIR -!** MD = 0.0289645 -!jmb--Old value MD = 0.0289644 -!** RD_P R J/(KG*K) SPECIFIC GAS CONSTANT FOR DRY AIR -!** RD = R*>/-100) then ! no echo - tten_radar(i,j,k) = 0._r_kind - else if (ref_mos_3d(i,j,k)>=0.001_r_kind) then ! echo - iskip=0 - if (tbk_k>277.15_r_kind .and. ref_mos_3d(i,j,k)<28._r_kind) then - iskip=iskip+1 -! write (6,*)' t is over 277 ',i,j,k,ref_mos_3d(i,j,k) -! ALSO, if T > 4C and refl < 28dBZ, again -! tten_radar = 0. - endif - if(iskip == 0 ) then -! tten_radar set as non-zero ONLY IF -! - not contradicted by GOES clear, and -! - ruc_refl > 28 dbZ for temp > 4K, and -! - for temp < 4K, any ruc_refl dbZ is OK. -! - cloudy and under GOES cloud top - if (k>=krad_bot) then -! can not use cld_cover_3d because we don't use reflectivity to build cld_cover_3d -! if (abs(cld_cover_3d(i,j,k))<=0.5_r_kind) then -! addsnow=0.0_r_kind -! else - addsnow = 10**(ref_mos_3d(i,j,k)/(17.8_r_kind*2.0))/264083._r_kind*9.0_r_kind -! endif - tten = ((1000.0_r_kind/p_bk(i,j,k))**(1./cpovr_p)) & - *(((LV_P+LF0_P)*addsnow)/ & - (2.0*dfi_rlhtp*60.0_r_kind*CPD_P)) -! 60 = sec/min, and dfi_rlhtp is in minutes. -! NOTE: tten is in K/seconds - tten_radar(i,j,k)= min(0.01_r_kind,max(-0.01_r_kind,tten)) - end if - end if - end if ! ref_mos_3d - - ENDDO - ENDDO - ENDDO - - DO k=1,nsig - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - ENDDO - -! KEY element -- Set tten_radar to no-coverage AFTER smoothing -! where ref_mos_3d had been previously set to no-coverage (-99.0 dbZ) - - DO k=1,nsig - DO j=1,nlat - DO i=1,nlon - ges_tten(j,i,k,1)=tten_radar(i,j,k) - if(ref_mos_3d(i,j,k)<=-200.0_r_kind ) ges_tten(j,i,k,1)=-spval_p ! no obs - ENDDO - ENDDO - ENDDO - -! -- Whack (smooth) the tten_radar array some more. -! for convection suppression in the radyn array. - DO k=1,nsig - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) - ENDDO - - deallocate(dummy) - -! RADYN array = convection suppression array -! Definition of RADYN values -! -10 -> no information -! 0 -> no convection -! 1 -> there might be convection nearby -! NOTE: 0,1 values are only possible if -! deep radar coverage is available (i.e., > 300 hPa deep) - -! RADYN is read into RUC model as array PCPPREV, -! where it is used to set the cap_depth (cap_max) -! in the Grell-Devenyi convective scheme -! to a near-zero value, effectively suppressing convection -! during DFI and first 30 min of the forward integration. - - allocate(radyn(nlon,nlat)) - radyn = -10. - - radmaxall=-999 - dpintmax=-999 - DO j=1,nlat - DO i=1,nlon - - nrad = 0 - radmax = 0._r_kind - dpint = 0._r_kind - DO k=2,nsig-1 - if ((ref_mos_3d(i,j,k))<=-200.0_r_kind) tten_radar(i,j,k) = -spval_p - if (tten_radar(i,j,k)>-15._r_kind) then - nrad=nrad+1 - dpint = dpint + 0.5_r_kind*(p_bk(i,j,k-1)-p_bk(i,j,k+1)) - radmax = max(radmax,tten_radar(i,j,k)) - end if - ENDDO - if (dpint>=300._r_kind ) then - radyn(i,j) = 0._r_kind - if (radmax>0.00002_r_kind) radyn(i,j) = 1._r_kind - if( abs(radyn(i,j)) < 0.00001_r_kind ) then - krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height - do k=krad_bot,nsig-1 - ges_tten(j,i,k,1) = 0._r_kind - end do - endif - endif - -! 2. Extend depth of no-echo zone from dpint zone down to PBL top, -! similarly to how lowest echo (with convection) is extended down to PBL top -! 5/27/2010 - Stan B. -! if (dpint.ge.300. .and. radmax.le.0.00001) then -! krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height -! do k=krad_bot,nsig-1 -! ges_tten(j,i,k,1) = 0. -! end do -! end if - - if(dpintmax < dpint ) dpintmax=dpint - if(radmaxall< radmax) radmaxall=radmax - ENDDO - ENDDO - - DO j=1,nlat - DO i=1,nlon -! ges_tten(j,i,nsig,1)=radyn(i,j) - ges_tten(j,i,nsig,1)=0.0 - ENDDO - ENDDO - - deallocate(tten_radar) - deallocate(radyn) - - else - - ges_tten=-spval_p - ges_tten(:,:,nsig,1)=-10.0_r_kind - - endif - - DO k=1,nsig - DO j=1,nlat - DO i=1,nlon - if(ges_tten(j,i,k,1) <= -200.0_r_kind ) ges_tten(j,i,k,1)=-20.0_r_kind ! no obs - ENDDO - ENDDO - ENDDO - -END SUBROUTINE radar_ref2tten_nosat diff --git a/lib/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 b/lib/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 deleted file mode 100755 index 9cf7c1453..000000000 --- a/lib/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 +++ /dev/null @@ -1,95 +0,0 @@ -SUBROUTINE read_Lightning2cld(mype,lunin,regional_time,istart,jstart, & - nlon,nlat,numlight,lightning) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_NESDIS read in lightning flash rate -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-30 -! -! ABSTRACT: -! This subroutine read in lightning flash rate -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! regional_time - analysis time -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! numlight - number of observation -! -! output argument list: -! lightning - lightning flash rate in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,i_kind, r_single - implicit none - - integer(i_kind),intent(in) :: lunin - integer(i_kind),intent(in) :: mype - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: regional_time(6) - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - INTEGER(i_kind),intent(in) :: numlight - - real(r_single), intent(out):: lightning(nlon,nlat) -! -! local -! - real(r_kind),allocatable :: light_in(:,:) - - character(10) :: obstype - integer(i_kind):: nreal,nchanl,ilat1s,ilon1s - character(20) :: isis - - INTEGER(i_kind) :: i,j, ii,jj,k2, k - INTEGER(i_kind) :: ib,jb - -! - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - - ilon1s=1 - ilat1s=2 - - read(lunin) obstype,isis,nreal,nchanl - - allocate( light_in(nreal,numlight) ) - light_in=-9999.0_r_kind - - read(lunin) light_in - DO i=1,numlight - ii=int(light_in(ilon1s,i)+0.001_r_kind) - ib + 2 - jj=int(light_in(ilat1s,i)+0.001_r_kind) - jb + 2 - if( ii < 1 .or. ii > nlon ) write(6,*) 'read_Lightning_cld: ', & - 'Error in read in lightning ii:',mype,ii,jj,i,ib,jb - if( jj < 1 .or. jj > nlat ) write(6,*) 'read_Lightning_cld:', & - 'Error in read in lightning jj:',mype,ii,jj,i,ib,jb - lightning(ii,jj)=light_in(3,i) - ENDDO - deallocate(light_in) - -END SUBROUTINE read_Lightning2cld diff --git a/lib/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 b/lib/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 deleted file mode 100755 index 0be3482ea..000000000 --- a/lib/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 +++ /dev/null @@ -1,109 +0,0 @@ -SUBROUTINE read_Lightningbufr2cld(mype,lunin,regional_time,istart,jstart, & - nlon,nlat,numlight,lightning) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_NESDIS read in lightning flash rate -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-30 -! -! ABSTRACT: -! This subroutine read in lightning flash rate -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! 2015-10-04 S.Liu using Lightning density from bufr data -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! regional_time - analysis time -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! numlight - number of observation -! -! output argument list: -! lightning - lightning density - -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_kind,i_kind, r_single - implicit none - - integer(i_kind),intent(in) :: lunin - integer(i_kind),intent(in) :: mype - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: regional_time(6) - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - INTEGER(i_kind),intent(in) :: numlight - - real(r_kind), intent(out):: lightning(nlon,nlat) -! -! local -! - real(r_kind),allocatable :: light_in(:,:) - - character(10) :: obstype - integer(i_kind):: nreal,nchanl,ilat1s,ilon1s - character(20) :: isis - - INTEGER(i_kind) :: i,j, ii,jj,k2, k - INTEGER(i_kind) :: ib,jb - -! - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - - ilon1s=1 - ilat1s=2 - -! write(6,891)mype,ib,jb -! read(lunin) obstype,isis,nreal,nchanl - read(lunin) obstype,isis,nreal,nchanl -! write(6,*)obstype,isis,nreal,nchanl,numlight - lightning=-999.0 - - allocate( light_in(nreal,numlight) ) - light_in=-9999.0_r_kind - read(lunin) light_in - - DO i=1,numlight - ii=int(light_in(ilon1s,i)+0.001_r_kind) - ib + 2 - jj=int(light_in(ilat1s,i)+0.001_r_kind) - jb + 2 - - if( ii < 1 .or. ii > nlon ) write(6,*) 'read_Lightning_cld: ', & - 'Error in read in lightning ii:',mype,ii,jj,i,ib,jb - if( jj < 1 .or. jj > nlat ) write(6,*) 'read_Lightning_cld:', & - 'Error in read in lightning jj:',mype,ii,jj,i,ib,jb - lightning(ii,jj)=light_in(3,i) -! write(6,89)mype,light_in(ilon1s,i),light_in(ilat1s,i),light_in(3,i),light_in(ilon1s,i),ib,jb,ii,jj - ENDDO -! write(6,892)nreal,nchanl,numlight - - deallocate(light_in) -89 format('readLightningbufr0::',i8,4f12.2,4i6) -893 format('readLightningbufr0::',i8,3f9.2) -891 format('readLightningbufr0::',4i8) -892 format('readLightningbufr1::',3i8) - - -END SUBROUTINE read_Lightningbufr2cld diff --git a/lib/GSD/gsdcloud4nmmb/read_NESDIS.f90 b/lib/GSD/gsdcloud4nmmb/read_NESDIS.f90 deleted file mode 100755 index 644a725a0..000000000 --- a/lib/GSD/gsdcloud4nmmb/read_NESDIS.f90 +++ /dev/null @@ -1,125 +0,0 @@ -SUBROUTINE read_NESDIS(mype,lunin,numobs,regional_time,istart,jstart,nlon,nlat, & - sat_ctp,sat_tem,w_frac) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_NESDIS read in NESDIS cloud products and map them into analysis grid -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 -! -! ABSTRACT: -! This subroutine read in NESDIS cloud products and map them into analysis grid -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! numobs - number of observation -! regional_time - analysis time -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! -! output argument list: -! sat_ctp - GOES cloud top pressure in analysis grid -! sat_tem - GOES cloud top temperature in analysis grid -! w_frac - GOES cloud coverage in analysis grid -! -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - integer(i_kind),intent(in) :: lunin - INTEGER(i_kind),intent(in) :: numobs - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: regional_time(6) - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - - real(r_single), intent(out):: sat_ctp(nlon,nlat) ! cloud top pressure - real(r_single), intent(out):: sat_tem(nlon,nlat) ! cloud top temperature - real(r_single), intent(out):: w_frac(nlon,nlat) ! cloud fraction -! - INTEGER(i_kind) :: nn_obs - real(r_kind),allocatable,dimension(:,:):: data_s - logical,allocatable,dimension(:):: luse -! -! misc. -! - character(10) :: obstype - integer(i_kind) :: mm1 - integer(i_kind) :: nreal,nchanl - character(20) :: isis - - INTEGER(i_kind) :: i, j, itmp, jtmp - INTEGER(i_kind) :: ib, jb - character*12 :: adate -! -! =============================================================== -! - - mm1=mype+1 - - read(lunin) obstype,isis,nreal,nchanl - nn_obs = nreal + nchanl - allocate(luse(numobs),data_s(nn_obs,numobs)) - read(lunin) data_s, luse -! - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - call map_ctp (ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac) -!! -! filling boundarys -! - DO i=2,nlon-1 - sat_ctp(i,1) =sat_ctp(i,2) - sat_tem(i,1) =sat_tem(i,2) - w_frac(i,1) =w_frac(i,2) - sat_ctp(i,nlat)=sat_ctp(i,nlat-1) - sat_tem(i,nlat)=sat_tem(i,nlat-1) - w_frac(i,nlat) =w_frac(i,nlat-1) - enddo - DO j=2,nlat-1 - sat_ctp(1,j) =sat_ctp(2,j) - sat_tem(1,j) =sat_tem(2,j) - w_frac(1,j) =w_frac(2,j) - sat_ctp(nlon,j)=sat_ctp(nlon-1,j) - sat_tem(nlon,j)=sat_tem(nlon-1,j) - w_frac(nlon,j) =w_frac(nlon-1,j) - enddo - sat_ctp(1,1) =sat_ctp(2,2) - sat_tem(1,1) =sat_tem(2,2) - w_frac(1,1) =w_frac(2,2) - sat_ctp(1,nlat) =sat_ctp(2,nlat-1) - sat_tem(1,nlat) =sat_tem(2,nlat-1) - w_frac(1,nlat) =w_frac(2,nlat-1) - sat_ctp(nlon,1) =sat_ctp(nlon-1,2) - sat_tem(nlon,1) =sat_tem(nlon-1,2) - w_frac(nlon,1) =w_frac(nlon-1,2) - sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) - sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) - w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) - -END SUBROUTINE read_NESDIS diff --git a/lib/GSD/gsdcloud4nmmb/read_Surface.f90 b/lib/GSD/gsdcloud4nmmb/read_Surface.f90 deleted file mode 100755 index 0a2d02bbe..000000000 --- a/lib/GSD/gsdcloud4nmmb/read_Surface.f90 +++ /dev/null @@ -1,251 +0,0 @@ -SUBROUTINE read_Surface(mype,lunin,regional_time,istart,jstart,nlon,nlat,& - numsao,NVARCLD_P,OI,OJ,OCLD,OWX,Oelvtn,Odist,cstation, & - OIstation,OJstation) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_Surface read in cloud observations in surface observation -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 -! -! ABSTRACT: -! This subroutine read in cloud observations in surface observation -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! regional_time - analysis time -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! numsao - maximum observation number (observation number) -! NVARCLD_P - first dimension of OLCD -! -! output argument list: -! -! OI - observation x location -! OJ - observation y location -! OLCD - cloud amount, cloud height, visibility -! OWX - weather observation -! Oelvtn - observation elevation -! Odist - distance from the nearest station -! cstation - station name - -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! - - use kinds, only: r_single,i_kind,r_kind,r_double - - implicit none - - integer(i_kind), intent(in) :: mype - integer(i_kind), intent(in) :: lunin - integer(i_kind), intent(in) :: regional_time(6) - integer(i_kind), intent(in) :: istart - integer(i_kind), intent(in) :: jstart - INTEGER(i_kind), intent(in) :: nlon,nlat - INTEGER(i_kind), intent(in) :: numsao - INTEGER(i_kind), intent(in) :: NVARCLD_P - - real(r_single), intent(out) :: OI(numsao) ! x location, grid - real(r_single), intent(out) :: OJ(numsao) ! y location, grid - INTEGER(i_kind), intent(out) :: OCLD(NVARCLD_P,numsao) ! cloud amount, cloud height, - ! visibility - CHARACTER*10, intent(out) :: OWX(numsao) ! weather - real(r_single), intent(out) :: Oelvtn(numsao) ! elevation - real(r_single), intent(out) :: Odist(numsao) ! distance from the nearest station - character(8), intent(out) :: cstation(numsao) ! station name - real(r_single), intent(out) :: OIstation(numsao) ! x location, station - real(r_single), intent(out) :: OJstation(numsao) ! y location, station - -! -! temp. -! - character*12 :: adate - character*9 :: STANAM ! stattion name - real(r_single) :: LAT ! latitude - real(r_single) :: LON ! longitude - - real(r_single) :: VIS ! horizontal visibility - real(r_single) :: CLD(3) ! cloud base height - character*10 :: WX ! weather - character*8 :: sky(3) ! cloud cover or amount - -! -! misc. -! - real(r_kind),allocatable,dimension(:,:):: data_s - logical,allocatable,dimension(:):: luse - character(10) :: obstype - integer(i_kind):: nreal,nchanl - character(20) :: isis - - INTEGER(i_kind) :: nn_obs - real(r_kind) :: cldamt,awx,cldhgt - character*3 :: msky,mwx - INTEGER(i_kind) :: i,j,k,k2,ic,jb,ib - integer(i_kind) :: start, end - - real(r_kind) :: spval_p - parameter (spval_p = 99999.) - - real(r_double) rstation_id - character(8) :: cstation1,cc,ci - equivalence(cstation1,rstation_id) - - -!==================================================================== -! Begin - OWX='' - OCLD=-99999 - - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - -! - read(lunin) obstype,isis,nreal,nchanl - - nn_obs = nreal + nchanl - allocate(luse(numsao),data_s(nn_obs,numsao)) - read(lunin) data_s, luse -! -! read in ruface observations: -! station name, x location, y location, longitude, latitude, elevation -! visibility, cloud amount, cloud height, weather -! - DO i=1,numsao - rstation_id=data_s(1,i) - cstation(i)=cstation1 - OI(i) = data_s(2,i) - ib + 2 ! covert it to the local grid - OJ(i) = data_s(3,i) - jb + 2 ! covert it to the local grid - if( OI(i) < 1 .or. OI(i) > nlon ) write(6,*) 'read_Surface: Error in reading ii:',mype,OI(i),ib,jb - if( OJ(i) < 1 .or. OJ(i) > nlat ) write(6,*) 'read_Surface: Error in reading jj:',mype,OJ(i),ib,jb - Oelvtn(i) = data_s(4,i) - Odist(i) = data_s(23,i) - OIstation(i) = data_s(24,i) - OJstation(i) = data_s(25,i) - if(data_s(22,i) > 50 ) cycle ! do not use this data - VIS = data_s(5,i) -! cloud amonut and base height -! C 020011 -! 0 0 oktas (0/10) -! 1 1 okta or less, but not zero (1/10 or less, but not zero) -! 2 2 oktas (2/10 - 3/10) -! 3 3 oktas (4/10) -! 4 4 oktas (5/10) -! 5 5 oktas (6/10) -! 6 6 oktas (7/10 - 8/10) -! 7 7 oktas or more, but not 8 oktas (9/10 or more, but not 10/10) -! 8 8 oktas (10/10) -! 9 Sky obscured by fog and/or other meteorological phenomena -! 10 Sky partially obscured by fog and/or other meteorological phenomena -! 11 Scattered -! 12 Broken -! 13 Few -! 14 Reserved -! 15 Cloud cover is indiscernible for reasons other than -! fog or other meteorological phenomena, or observation is not made - - DO j=1,3 - cldamt = data_s(5+j,i) ! cloud amount - cldhgt = int(data_s(11+j,i)) ! cloud bottom height - if(cldamt < spval_p .and. cldhgt < spval_p) then - if(abs(cldamt-0._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=0 !msky='CLR' - cldhgt=spval_p - elseif(abs(cldamt-13._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=1 !msky='FEW' - elseif(abs(cldamt-11._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=2 !msky='SCT' - elseif(abs(cldamt-12._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=3 !msky='BKN' - elseif((abs(cldamt-8._r_kind) < 0.0001_r_kind) .or. & - (abs(cldamt-9._r_kind) < 0.0001_r_kind)) then - OCLD(j,i)=4 ! msky='OVC' msky='VV ' - elseif(abs(cldamt-1._r_kind) < 0.0001_r_kind) then - OCLD(j,i)=1 - elseif(abs(cldamt-2._r_kind) < 0.0001_r_kind .or. & - abs(cldamt-3._r_kind) < 0.0001_r_kind ) then - OCLD(j,i)=2 - elseif(cldamt > 3.5_r_kind .and. cldamt < 6.5_r_kind ) then - OCLD(j,i)=3 - elseif(abs(cldamt-7._r_kind) < 0.0001_r_kind ) then - OCLD(j,i)=4 - else - OCLD(j,i) = spval_p ! wrong cloud observation type - cldhgt = spval_p - endif - if(cldhgt > 0.0_r_kind ) then - OCLD(6+j,i) = cldhgt - else - OCLD(j,i) = spval_p - OCLD(6+j,i) = spval_p - endif - else - OCLD(j,i) = 99 - OCLD(6+j,i) = spval_p - endif - enddo ! j -! weather - DO j=1,3 - awx = data_s(17+j,i) ! weather - mwx=' ' - if(awx>=10._r_kind .and.awx<=12._r_kind ) mwx='BR ' - if(awx>=110._r_kind.and.awx<=112._r_kind) mwx='BR ' - if(awx==5._r_kind .or. awx==105._r_kind) mwx='HZ ' - if(awx>=40._r_kind .and.awx<=49._r_kind ) mwx='FG ' - if(awx>=130._r_kind.and.awx<=135._r_kind) mwx='FG ' - if(awx>=50._r_kind .and.awx<=59._r_kind ) mwx='DZ ' - if(awx>=150._r_kind.and.awx<=159._r_kind) mwx='DZ ' - if(awx>=60._r_kind .and.awx<=69._r_kind ) mwx='RA ' - if(awx>=160._r_kind.and.awx<=169._r_kind) mwx='RA ' - if(awx>=70._r_kind .and.awx<=78._r_kind ) mwx='SN ' - if(awx>=170._r_kind.and.awx<=178._r_kind) mwx='SN ' - if(awx==79._r_kind .or. awx==179._r_kind) mwx='PE ' - - if(awx>=80._r_kind .and.awx<=90._r_kind ) mwx='SH ' - if(awx>=180._r_kind.and.awx<=187._r_kind) mwx='SH ' - if(awx>=91._r_kind .and.awx<=99._r_kind ) mwx='TH ' - if(awx>=190._r_kind.and.awx<=196._r_kind) mwx='TH ' - - if (j==1) start=1 - if (j==2) start=4 - if (j==3) start=7 - end=start+2 - OWX(i)(start:end)=mwx - enddo -! visiblity - IF(VIS > spval_P) then - OCLD(13,i)=spval_P - else - IF(VIS > 100.0_r_kind ) then - OCLD(13,i)=int(VIS) - elseif(VIS <=100.0_r_kind .and. VIS > 0.0_r_kind ) then - OCLD(13,i)=100 -! write(6,*) 'read_Surface, Warning: change visibility to 100 m !!!' - ENDIF - endif - - ENDDO ! i = numsao -! - -END SUBROUTINE read_Surface - diff --git a/lib/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 b/lib/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 deleted file mode 100755 index 8b26f7b28..000000000 --- a/lib/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 +++ /dev/null @@ -1,167 +0,0 @@ -SUBROUTINE read_nasalarc(mype,lunin,numobs,regional_time,istart,jstart,nlon,nlat, & - nasalarc) -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_NESDIS read in NESDIS cloud products and map them into analysis grid -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 -! -! ABSTRACT: -! This subroutine read in NESDIS cloud products and map them into analysis grid -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! 2013-12-20 S.Liu modify to read bufr file and do interpolation in GSI -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! numobs - number of observation -! regional_time - analysis time -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! -! output argument list: -! sat_ctp - GOES cloud top pressure in analysis grid -! sat_tem - GOES cloud top temperature in analysis grid -! w_frac - GOES cloud coverage in analysis grid -! -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - - use kinds, only: r_single,i_kind,r_kind - - implicit none - - integer(i_kind),intent(in) :: mype - integer(i_kind),intent(in) :: lunin - INTEGER(i_kind),intent(in) :: numobs - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: regional_time(6) - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - - real(r_single):: sat_ctp(nlon,nlat) ! cloud top pressure - real(r_single):: sat_tem(nlon,nlat) ! cloud top temperature - real(r_single):: w_frac(nlon,nlat) ! cloud fraction - real(r_single):: w_lwp(nlon,nlat) ! cloud fraction - integer(i_kind):: nlev_cld(nlon,nlat) ! cloud fraction - real(r_single):: nasalarc(nlon,nlat,5) -! - INTEGER(i_kind) :: nn_obs - real(r_kind),allocatable,dimension(:,:):: data_s - logical,allocatable,dimension(:):: luse -! -! misc. -! - character(10) :: obstype - integer(i_kind) :: mm1 - integer(i_kind) :: nreal,nchanl - character(20) :: isis - - INTEGER(i_kind) :: i, j, itmp, jtmp - INTEGER(i_kind) :: ib, jb - character*12 :: adate -! -! =============================================================== -! - - mm1=mype+1 - - read(lunin) obstype,isis,nreal,nchanl - nn_obs = nreal + nchanl - allocate(luse(numobs),data_s(nn_obs,numobs)) - read(lunin) data_s, luse - -! do i=1,numobs -! write(6,*)'sliu larcclddata::',data_s(1,i),data_s(2,i),data_s(3,i) -! end do - -! write(6,*)'read_NESDIS::',mype, maxval(data_s(7,:)),numobs - - - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - call map_ctp_lar(ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld) -!! -! filling boundarys -! - DO i=2,nlon-1 - sat_ctp(i,1) =sat_ctp(i,2) - sat_tem(i,1) =sat_tem(i,2) - w_frac(i,1) =w_frac(i,2) - w_lwp(i,1) =w_lwp(i,2) - nlev_cld(i,1) =nlev_cld(i,2) - sat_ctp(i,nlat)=sat_ctp(i,nlat-1) - sat_tem(i,nlat)=sat_tem(i,nlat-1) - w_frac(i,nlat) =w_frac(i,nlat-1) - w_lwp(i,nlat) =w_lwp(i,nlat-1) - nlev_cld(i,nlat) =nlev_cld(i,nlat-1) - enddo - DO j=2,nlat-1 - sat_ctp(1,j) =sat_ctp(2,j) - sat_tem(1,j) =sat_tem(2,j) - w_frac(1,j) =w_lwp(2,j) - w_lwp(1,j) =w_lwp(2,j) - nlev_cld(1,j) =nlev_cld(2,j) - sat_ctp(nlon,j)=sat_ctp(nlon-1,j) - sat_tem(nlon,j)=sat_tem(nlon-1,j) - w_frac(nlon,j) =w_frac(nlon-1,j) - w_lwp(nlon,j) =w_lwp(nlon-1,j) - nlev_cld(nlon,j) =nlev_cld(nlon-1,j) - enddo - sat_ctp(1,1) =sat_ctp(2,2) - sat_tem(1,1) =sat_tem(2,2) - w_frac(1,1) =w_frac(2,2) - w_lwp(1,1) =w_lwp(2,2) - nlev_cld(1,1) =nlev_cld(2,2) - - sat_ctp(1,nlat) =sat_ctp(2,nlat-1) - sat_tem(1,nlat) =sat_tem(2,nlat-1) - w_frac(1,nlat) =w_frac(2,nlat-1) - w_lwp(1,nlat) =w_lwp(2,nlat-1) - nlev_cld(1,nlat) =nlev_cld(2,nlat-1) - - sat_ctp(nlon,1) =sat_ctp(nlon-1,2) - sat_tem(nlon,1) =sat_tem(nlon-1,2) - w_frac(nlon,1) =w_frac(nlon-1,2) - w_lwp(nlon,1) =w_lwp(nlon-1,2) - nlev_cld(nlon,1) =nlev_cld(nlon-1,2) - - sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) - sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) - w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) - - do i=1,nlon - do j=1,nlat - nasalarc(i,j,1)=sat_ctp(i,j) - nasalarc(i,j,2)=sat_tem(i,j) - nasalarc(i,j,3)=w_frac(i,j) !/100.0 - nasalarc(i,j,4)=w_lwp(i,j) !/100.0 - nasalarc(i,j,5)=nlev_cld(i,j) -! if(abs(sat_tem(i,j))>0.and.abs(sat_tem(i,j))<400) then -! write(6,*)'sat_tem2 in read_cloud::',sat_ctp(i,j),sat_tem(i,j),nasalarc(i,j,1) -! end if - end do - end do - - -END SUBROUTINE read_nasalarc diff --git a/lib/GSD/gsdcloud4nmmb/read_radar_ref.f90 b/lib/GSD/gsdcloud4nmmb/read_radar_ref.f90 deleted file mode 100755 index 1a7931ae6..000000000 --- a/lib/GSD/gsdcloud4nmmb/read_radar_ref.f90 +++ /dev/null @@ -1,107 +0,0 @@ -SUBROUTINE read_radar_ref(mype,lunin,regional_time,istart,jstart, & - nlon,nlat,Nmsclvl,numref,ref_mosaic31) -! -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: read_NESDIS read in radar reflectivity -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-30 -! -! ABSTRACT: -! This subroutine read in radar reflectivity -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! lunin - unit in which data are read in -! regional_time - analysis time -! jstart - start lon of the whole array on each pe -! istart - start lat of the whole array on each pe -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! numref - number of observation -! -! output argument list: -! Nmsclvl - vertical level of radar observation ref_mosaic31 -! ref_mosaic31- radar reflectivity horizontally in analysis grid and -! vertically in mosaic grid (height) -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use kinds, only: r_kind,i_kind - implicit none - - INTEGER(i_kind),intent(in) :: mype - INTEGER(i_kind),intent(in) :: nlon,nlat - integer(i_kind),intent(in) :: lunin - integer(i_kind),intent(in) :: regional_time(6) - integer(i_kind),intent(in) :: istart - integer(i_kind),intent(in) :: jstart - INTEGER(i_kind),intent(in) :: numref - - INTEGER(i_kind),intent(out):: Nmsclvl - real(r_kind), intent(out):: ref_mosaic31(nlon,nlat,31) -! -! local -! - real(r_kind),allocatable :: ref_in(:,:) - - character(10) :: obstype - integer(i_kind):: nreal,nchanl,ilat1s,ilon1s - character(20) :: isis - - INTEGER(i_kind) :: i,j, ii,jj,k2, k - INTEGER(i_kind) :: ib,jb - -! - ib=jstart ! begin i point of this domain - jb=istart ! begin j point of this domain - - read(lunin) obstype,isis,nreal,nchanl - - ilon1s=1 - ilat1s=2 - Nmsclvl = nreal - 2 - IF( Nmsclvl .ne. 21 .and. Nmsclvl .ne.31) then - write(6,*) ' read_radar_ref: ', & - 'vertical dimesion inconsistent when read in reflectivty mosaic' - write(6,*) 'read in:',Nmsclvl - write(6,*) 'need:', 21, 'or', 31 - call stop2(114) - ENDIF - allocate( ref_in(nreal,numref) ) - ref_mosaic31=-9999.0_r_kind - - read(lunin) ref_in - DO i=1,numref - ii=int(ref_in(ilon1s,i)+0.001_r_kind) - ib + 2 - jj=int(ref_in(ilat1s,i)+0.001_r_kind) - jb + 2 - if( ii < 1 .or. ii > nlon ) write(6,*) 'read_radar_ref: ', & - 'Error in read in ref ii:',mype,ii,jj,i,ib,jb - if( jj < 1 .or. jj > nlat ) write(6,*) 'read_radar_ref: ', & - 'Error in read in ref jj:',mype,ii,jj,i,ib,jb - DO k=1,Nmsclvl - ref_mosaic31(ii,jj,k)=ref_in(2+k,i) - ENDDO - ENDDO - deallocate(ref_in) - -END SUBROUTINE read_radar_ref diff --git a/lib/GSD/gsdcloud4nmmb/smooth.f90 b/lib/GSD/gsdcloud4nmmb/smooth.f90 deleted file mode 100755 index 73f620809..000000000 --- a/lib/GSD/gsdcloud4nmmb/smooth.f90 +++ /dev/null @@ -1,98 +0,0 @@ - SUBROUTINE SMOOTH (FIELD,HOLD,IX,IY,SMTH) -!C$$$ SUBPROGRAM DOCUMENTATION BLOCK -!C . . . . -!C SUBPROGRAM: SMOOTH SMOOTH A METEOROLOGICAL FIELD -!C PRGMMR: STAN BENJAMIN ORG: FSL/PROFS DATE: 90-06-15 -!C -!C ABSTRACT: SHAPIRO SMOOTHER. -!C -!C PROGRAM HISTORY LOG: -!C 85-12-09 S. BENJAMIN ORIGINAL VERSION -!C -!C USAGE: CALL SMOOTH (FIELD,HOLD,IX,IY,SMTH) -!C INPUT ARGUMENT LIST: -!C FIELD - REAL ARRAY FIELD(IX,IY) -!C METEOROLOGICAL FIELD -!C HOLD - REAL ARRAY HOLD(IX,2) -!C HOLDING THE VALUE FOR FIELD -!C IX - INTEGER X COORDINATES OF FIELD -!C IY - INTEGER Y COORDINATES OF FIELD -!C SMTH - REAL -!C -!C OUTPUT ARGUMENT LIST: -!C FIELD - REAL ARRAY FIELD(IX,IY) -!C SMOOTHED METEOROLOGICAL FIELD -!C -!C REMARKS: REFERENCE: SHAPIRO, 1970: "SMOOTHING, FILTERING, AND -!C BOUNDARY EFFECTS", REV. GEOPHYS. SP. PHYS., 359-387. -!C THIS FILTER IS OF THE TYPE -!C Z(I) = (1-S)Z(I) + S(Z(I+1)+Z(I-1))/2 -!C FOR A FILTER WHICH IS SUPPOSED TO DAMP 2DX WAVES COMPLETELY -!C BUT LEAVE 4DX AND LONGER WITH LITTLE DAMPING, -!C IT SHOULD BE RUN WITH 2 PASSES USING SMTH (OR S) OF 0.5 -!C AND -0.5. -!C -!C ATTRIBUTES: -!C$$$ -!C********************************************************************** -!C********************************************************************** - - - use kinds, only: r_kind,i_kind,r_single - implicit none -!C********************************************************************** - INTEGER(i_kind),INTENT(IN) :: IX,IY - real(r_kind),intent(inout) :: FIELD(IX,IY) - real(r_kind),intent(inout) :: HOLD (IX,2) - real(r_kind),intent(in) :: SMTH -!C********************************************************************** - real(r_kind) :: SMTH1,SMTH2,SMTH3,SMTH4,SMTH5 - INTEGER(i_kind) :: I1,I2,I,J,IT - real(r_kind) :: SUM1,SUM2 - - SMTH1 = 0.25 * SMTH * SMTH - SMTH2 = 0.5 * SMTH * (1.-SMTH) - SMTH3 = (1.-SMTH) * (1.-SMTH) - SMTH4 = (1.-SMTH) - SMTH5 = 0.5 * SMTH - I1 = 2 - I2 = 1 - DO J=2,IY-1 - IT = I1 - I1 = I2 - I2 = IT - DO I = 2,IX-1 - SUM1 = FIELD (I-1,J+1) + FIELD (I-1,J-1) & - + FIELD (I+1,J+1) + FIELD (I+1,J-1) - SUM2 = FIELD (I ,J+1) + FIELD (I+1,J ) & - + FIELD (I ,J-1) + FIELD (I-1,J ) - HOLD(I,I1) = SMTH1*SUM1 + SMTH2*SUM2 + SMTH3*FIELD(I,J) - ENDDO - IF (J /= 2) THEN - DO I=2,IX-1 - FIELD(I,J-1) = HOLD(I,I2) - ENDDO - ENDIF - ENDDO - - - DO I = 2,IX-1 - FIELD (I,IY-1) = HOLD(I,I1) - ENDDO - - DO I = 2,IX-1 - FIELD(I,1) = SMTH4* FIELD(I,1) & - + SMTH5 * (FIELD(I-1,1) + FIELD(I+1,1)) - FIELD(I,IY) = SMTH4* FIELD(I,IY) & - + SMTH5 * (FIELD(I-1,IY) + FIELD(I+1,IY)) - ENDDO - - DO J = 2,IY-1 - FIELD(1,J) = SMTH4* FIELD(1,J) & - + SMTH5 * (FIELD(1,J-1) + FIELD(1,J+1)) - FIELD(IX,J) = SMTH4* FIELD(IX,J) & - + SMTH5 * (FIELD(IX,J-1) + FIELD(IX,J+1)) - ENDDO - - RETURN - END diff --git a/lib/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 b/lib/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 deleted file mode 100755 index cdbadf387..000000000 --- a/lib/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 +++ /dev/null @@ -1,143 +0,0 @@ -SUBROUTINE vinterp_radar_ref(mype,nlon,nlat,nsig,Nmsclvl,ref_mos_3d,ref_mosaic31,h_bk,zh) -! -! -!$$$ subprogram documentation block -! . . . . -! subprogram: interp_radar_ref radar observation vertical interpolation -! -! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 -! -! ABSTRACT: -! This subroutine interpolate radar reflectivity vertically -! -! PROGRAM HISTORY LOG: -! 2009-01-20 Hu Add NCO document block -! -! -! input argument list: -! mype - processor ID -! nlon - no. of lons on subdomain (buffer points on ends) -! nlat - no. of lats on subdomain (buffer points on ends) -! nsig - no. of levels -! Nmsclvl - vertical level of radar observation ref_mosaic31 -! ref_mosaic31- radar reflectivity horizontally in analysis grid and vertically -! in mosaic grid (height) -! h_bk - 3D background height -! zh - terrain -! -! output argument list: -! ref_mos_3d - 3D radar reflectivity in analysis grid -! -! USAGE: -! INPUT FILES: -! -! OUTPUT FILES: -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: Linux cluster (WJET) -! -!$$$ -! -!_____________________________________________________________________ -! - use kinds, only: r_kind,i_kind, r_single - implicit none - - INTEGER(i_kind), intent(in) :: mype - INTEGER(i_kind), intent(in) :: nlon - INTEGER(i_kind), intent(in) :: nlat - INTEGER(i_kind), intent(in) :: nsig - INTEGER(i_kind), intent(in) :: Nmsclvl - real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height - real(r_single), intent(in) :: zh(nlon,nlat) ! terrain - real(r_kind), intent(in) :: ref_mosaic31(nlon,nlat,Nmsclvl) - real(r_kind), intent(out):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid -! -! local -! - real(r_kind) :: msclvl21(21),msclvlAll(31) - INTEGER(i_kind) :: mscX,mscY - DATA msclvl21/1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 6, 7, & - 8, 9, 10, 11, 12, 13, 14, 15, 16, 17/ - DATA msclvlAll/0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & - 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & - 9, 10, 11, 12, 13, 14, 15, 16, 18/ -! - REAL(r_kind) :: heightGSI,upref,downref,wght - INTEGER(i_kind) :: ilvl,numref - - real(r_kind) :: ref_mosaic - INTEGER(i_kind) :: i,j, k2, k - -! - if(Nmsclvl < -888 ) then - write(6,*) 'interp_radar_ref: No radar reflectivity data in this subdomain !' - return - endif -! - ref_mos_3d=-99999.0_r_kind - numref=0 - if (Nmsclvl == 31 ) then - DO k=1,Nmsclvl - msclvlAll(k)=msclvlAll(k)*1000.0_r_kind - ENDDO - elseif( Nmsclvl == 21 ) then - msclvlAll=0 - DO k=1,Nmsclvl - msclvlAll(k)=msclvl21(k)*1000.0_r_kind - ENDDO - else - write(6,*) 'interp_radar_ref: Wrong vertical radar mosaic levels' - write(6,*) ' the level read in is:', msclvlAll - call stop2(114) - endif - - DO k2=1,nsig - DO j=2,nlat-1 - DO i=2,nlon-1 - heightGSI=h_bk(i,j,k2)+zh(i,j) - if(heightGSI >= msclvlAll(1) .and. heightGSI < msclvlAll(Nmsclvl) ) then - do k=1,Nmsclvl-1 - if( heightGSI >=msclvlAll(k) .and. heightGSI < msclvlAll(k+1) ) ilvl=k - enddo - upref=ref_mosaic31(i,j,ilvl+1) - downref=ref_mosaic31(i,j,ilvl) - if(abs(upref) <90.0_r_kind .and. abs(downref) <90.0_r_kind ) then - wght=(heightGSI-msclvlAll(ilvl))/(msclvlAll(ilvl+1)-msclvlAll(ilvl)) - ref_mosaic=(1-wght)*downref + wght*upref - numref=numref+1 - elseif( abs(upref+99.0_r_kind) < 0.1_r_kind .or. & - abs(downref+99.0_r_kind) <0.1_r_kind ) then - ref_mosaic=-99.0_r_kind - else - ref_mosaic=-99999.0_r_kind - endif - ref_mos_3d(i,j,k2)=max(ref_mos_3d(i,j,k2),ref_mosaic) - else - ref_mos_3d(i,j,k2)=-99999.0_r_kind - endif - ENDDO - ENDDO - ENDDO - -! - DO k2=1,nsig - DO i=2,nlon-1 - ref_mos_3d(i,1,k2)=ref_mos_3d(i,2,k2) - ref_mos_3d(i,nlat,k2)=ref_mos_3d(i,nlat-1,k2) - ENDDO - DO j=2,nlat-1 - ref_mos_3d(1,j,k2)=ref_mos_3d(2,j,k2) - ref_mos_3d(nlon,j,k2)=ref_mos_3d(nlon-1,j,k2) - ENDDO - ref_mos_3d(nlon,nlat,k2)=ref_mos_3d(nlon-1,nlat-1,k2) - ref_mos_3d(nlon,1,k2)=ref_mos_3d(nlon-1,2,k2) - ref_mos_3d(1,nlat,k2)=ref_mos_3d(2,nlat-1,k2) - ref_mos_3d(1,j,k2)=ref_mos_3d(2,2,k2) - ENDDO - - -END SUBROUTINE vinterp_radar_ref diff --git a/libsrc b/libsrc index 8fa69e1fd..21f2383e0 160000 --- a/libsrc +++ b/libsrc @@ -1 +1 @@ -Subproject commit 8fa69e1fd011b658de6cd2e9f08cf1ad77566f4f +Subproject commit 21f2383e075a0d0bfd24df60998c061fc4de202a diff --git a/modulefiles/modulefile.ProdGSI.cheyenne b/modulefiles/modulefile.ProdGSI.cheyenne new file mode 100644 index 000000000..589ee214d --- /dev/null +++ b/modulefiles/modulefile.ProdGSI.cheyenne @@ -0,0 +1,16 @@ +#%Module###################################################################### +## Mark.Potts@noaa.gov +## NOAA/NWS/NCEP/EMC +## ProdGSI +##_____________________________________________________ + +module purge +module load ncarenv/1.2 +module load cmake/3.9.1 +module load intel/18.0.1 +module load impi/2018.1.163 +module load mkl/2018.0.1 +module load netcdf/4.5.0 +module list + +echo "done loading modules" diff --git a/modulefiles/modulefile.ProdGSI.cray b/modulefiles/modulefile.ProdGSI.cray deleted file mode 100644 index 84ab979ee..000000000 --- a/modulefiles/modulefile.ProdGSI.cray +++ /dev/null @@ -1,59 +0,0 @@ -#%Module###################################################################### -## Russ.Treadon@noaa.gov -## NOAA/NWS/NCEP/EMC -## GDAS_ENKF v6.2.3 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for GDAS_ENKF" -puts stderr "This module initializes the environment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " GDAS_ENKF whatis description" - -set ver v6.2.3 - -setenv COMP ftn -setenv COMP_MP ftn -setenv COMP_MPI ftn - -setenv C_COMP cc -setenv C_COMP_MP cc - -set COMPILER intel - -setenv FFLAGS_COM "-fp-model strict" -setenv LDFLAGS_COM " " - -set WRF_SHARED_VER v1.1.0 -set WRF_SHARED_ROOT /gpfs/hps/nco/ops/nwprod/wrf_shared -setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT}.${WRF_SHARED_VER}-${COMPILER} - -# Known conflicts - -# Loading ncep environment -module load ncep/1.0 - -# Loading Intel Compiler Suite -module load PrgEnv-intel/5.2.56 - -# Loading pe environment -module load cray-mpich/7.2.0 -module load craype-haswell - -# Loading nceplibs modules -module use /usrx/local/prod/modulefiles -module load HDF5-serial-intel-haswell/1.8.9 -module load NetCDF-intel-haswell/4.2 - -module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles -module load bufr-intel/11.0.1 -module load nemsio-intel/2.2.2 -module load sfcio-intel/1.0.0 -module load sigio-intel/2.0.1 -module load sp-intel/2.0.2 -module load w3nco-intel/2.0.6 -module load w3emc-intel/2.2.0 -module load crtm-intel/2.2.3 - -module use /usrx/local/nceplibs/modulefiles -module load bacio-intel/2.0.2 diff --git a/modulefiles/modulefile.ProdGSI.discover b/modulefiles/modulefile.ProdGSI.discover new file mode 100644 index 000000000..1d843b843 --- /dev/null +++ b/modulefiles/modulefile.ProdGSI.discover @@ -0,0 +1,15 @@ +#%Module###################################################################### +proc ModulesHelp { } { + puts stderr "Set environment veriables for GSI" + puts stderr "This module initializes the environment " + puts stderr "for building and testing GSI on NCCS Discover\n" +} +module-whatis "Initialize GSI build/test environment" + +module load comp/intel-18.0.3.222 +module load lib/mkl-18.0.3.222 +module load mpi/sgi-mpt-2.17 +module load other/comp/gcc-9.1 +module load other/cmake-3.8.2 + +setenv BASEDIR /discover/nobackup/projects/gmao/share/gmao_ops/Baselibs/v5.1.3_build1/x86_64-unknown-linux-gnu/ifort_18.0.3.222-mpt_2.17 diff --git a/modulefiles/modulefile.ProdGSI.gaea b/modulefiles/modulefile.ProdGSI.gaea new file mode 100644 index 000000000..d71bafc74 --- /dev/null +++ b/modulefiles/modulefile.ProdGSI.gaea @@ -0,0 +1,72 @@ +#%Module1.0 +###################################################################### +## Russ.Treadon@noaa.gov +## NOAA/NWS/NCEP/EMC +## GDAS_ENKF v6.2.3 +##_____________________________________________________ +proc ModulesHelp { } { +puts stderr "Set environment veriables for GDAS_ENKF" +puts stderr "This module initializes the environment " +puts stderr "for the Intel Compiler Suite $version\n" +} +module-whatis " GDAS_ENKF whatis description" + +set ver v6.2.3 + +setenv COMP ftn +setenv COMP_MP ftn +setenv COMP_MPI ftn + +setenv C_COMP cc +setenv C_COMP_MP cc + +set COMPILER intel + +setenv FFLAGS_COM "-fp-model strict" +setenv LDFLAGS_COM " " + +#set WRF_SHARED_VER v1.1.0 +#set WRF_SHARED_ROOT /gpfs/hps/nco/ops/nwprod/wrf_shared +#set WRF_SHARED_ROOT /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/EXTERNAL/wrf_shared +#setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT}.${WRF_SHARED_VER} + +# Known conflicts +setenv NCEPLIBS /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib + +# Loading ncep environment +##module load ncep/1.0 +module use /opt/cray/pe/craype/2.5.5/modulefiles + +# Loading Intel Compiler Suite +module load PrgEnv-intel + +# Loading pe environment +module load cray-mpich +module load cray-libsci +module unload craype-broadwell +module load craype-haswell + +module use /sw/gaea/modulefiles +module load cmake + +# Loading nceplibs modules +module use /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/modulefiles +#module load HDF5-serial-intel-haswell/1.8.9 +#module load NetCDF-intel-haswell/4.2 +module load cray-hdf5 +module load cray-netcdf + +#module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles +module load bufr-intel-sandybridge/11.0.1 +module load nemsio-intel-sandybridge/2.2.2 +module load sfcio-intel-sandybridge/1.0.0 +module load sigio-intel-sandybridge/2.0.1 +module load sp-intel-sandybridge/2.0.2 +module load w3nco-intel-sandybridge/2.0.6 +module load w3emc-intel-sandybridge/2.2.0 +module load crtm-intel/2.2.4 +#setenv CRTM_INC /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/crtm/v2.2.4/intel/include/crtm_v2.2.4 +#setenv CRTM_LIB /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/crtm/v2.2.4/intel/libcrtm_v2.2.4.a +module load bacio-intel-sandybridge/2.0.2 +setenv CRAYOS_VERSION $::env(CRAYPE_VERSION) +#setenv CRAYOS_VERSION ${CRAYPE_VERSION} diff --git a/modulefiles/modulefile.ProdGSI.hera b/modulefiles/modulefile.ProdGSI.hera new file mode 100644 index 000000000..8cd2cf4bd --- /dev/null +++ b/modulefiles/modulefile.ProdGSI.hera @@ -0,0 +1,40 @@ +#%Module###################################################################### +## Russ.Treadon@noaa.gov +## NOAA/NWS/NCEP/EMC +## GDAS_ENKF v6.2.3 +##_____________________________________________________ +#set ver v6.2.3 + +set COMP ifort +set COMP_MP mpfort +set COMP_MPI mpiifort + +set C_COMP icc +set C_COMP_MP mpcc + +# Known conflicts + +# Load compiler, mpi, cmake, and hdf5/netcdf +module load intel/18.0.5.274 +module load impi/2018.0.4 +module load hdf5/1.10.4 +module load netcdf/4.6.1 +module load contrib +module load cmake/3.9.0 + +# Load libraries +module use /scratch2/NCEPDEV/nwprod/NCEPLIBS/modulefiles +module load bacio/2.0.3 +module load bufr/11.3.0 +module load crtm/2.2.6 +module load nemsio/2.2.4 +module load prod_util/1.1.0 +module load sfcio/1.1.1 +module load sigio/2.1.1 +module load sp/2.0.3 +module load w3emc/2.3.1 +module load w3nco/2.0.7 + +# Set environmental variables to allow correlated error to reproduce on Hera +export MKL_NUM_THREADS=4 +export MKL_CBWR=AUTO diff --git a/modulefiles/modulefile.ProdGSI.jet b/modulefiles/modulefile.ProdGSI.jet new file mode 100644 index 000000000..7aab051ac --- /dev/null +++ b/modulefiles/modulefile.ProdGSI.jet @@ -0,0 +1,44 @@ +#%Module###################################################################### +## Russ.Treadon@noaa.gov +## NOAA/NWS/NCEP/EMC +## GDAS_ENKF v6.2.3 +##_____________________________________________________ +#proc ModulesHelp { } { +#puts stderr "Set environment veriables for GSI build with CMake" +#puts stderr "This module initializes the environment " +#puts stderr "for the Intel Compiler Suite $version\n" +#} +#module-whatis " GDAS_ENKF whatis description" +# +# + +module load intel/15.0.3.187 +module load impi +# +module load szip/2.1 +module load hdf5/1.8.9 +module load netcdf4/4.2.1.1 + +export COREPATH=/lfs3/projects/hfv3gfs/nwprod/lib +export COREPATH=/mnt/lfs3/projects/hfv3gfs/gwv/ljtjet/lib +export NCEPLIBS=$COREPATH +module use $NCEPLIBS/modulefiles + +export FFLAGS="-openmp" +export LDFLAGS="-openmp" +module load bacio-intel-sandybridge/2.0.2 +module load crtm-intel-sandybridge/2.2.5 +module load bufr-intel-sandybridge/11.1.0 +module load nemsio-intel-sandybridge/2.2.2 +module load sp-intel-sandybridge/2.0.2 +module load w3emc-intel-sandybridge/2.2.0 +module load w3nco-intel-sandybridge/2.0.6 +module load sigio-intel-sandybridge/2.0.1 +module load sfcio-intel-sandybridge/1.0.0 + +module use /home/George.Vandenberghe/t1/l1025/lib/modulefiles +#module load hdf5 +#module load netcdf + +export NETCDF=${NETCDF4} +export NETCDF_DIR=${NETCDF4} diff --git a/modulefiles/modulefile.ProdGSI.s4 b/modulefiles/modulefile.ProdGSI.s4 new file mode 100644 index 000000000..3db2ec137 --- /dev/null +++ b/modulefiles/modulefile.ProdGSI.s4 @@ -0,0 +1,43 @@ +#%Module###################################################################### +## Russ.Treadon@noaa.gov +## NOAA/NWS/NCEP/EMC +## GDAS_ENKF v6.2.3 +##_____________________________________________________ +#set ver v6.2.3 + +set COMP ifort +set COMP_MP mpfort +set COMP_MPI mpiifort + +set C_COMP icc +set C_COMP_MP mpcc + +# Known conflicts +module use -a /home/mpotts/s4-cardinal/spack/share/spack/modules/linux-centos7-x86_64 +module load license_intel/S4 +module load intel/18.0.3 +module load intel-mpi/18.0.3-intel-18.0.3 + +module load cmake/3.12.2-intel-18.0.3 + +module load hdf5/1.10.4-intel-18.0.3-impi +module load netcdf/4.6.2-intel-18.0.3-impi +module load netcdf-fortran/4.4.4-intel-18.0.3-impi +module load sp/v2.0.2-intel-18.0.3 + +module load w3emc/v2.2.0-intel-18.0.3-impi + +module load bacio/v2.1.0-intel-18.0.3 +module load sfcio/v1.1.0-intel-18.0.3 +module load w3nco/v2.0.6-intel-18.0.3-impi + +module load bufr/v11.2.0-intel-18.0.3 +module load nemsio/v2.2.3-intel-18.0.3-impi +module load sigio/v2.1.0-intel-18.0.3-impi +module load crtm/v2.3.0 +module load prod-util/1.0.18-intel-18.0.3-impi + +echo "done loading modules" + +# Loading production utilities (ndate) + diff --git a/modulefiles/modulefile.ProdGSI.theia b/modulefiles/modulefile.ProdGSI.theia deleted file mode 100644 index 60c6024b6..000000000 --- a/modulefiles/modulefile.ProdGSI.theia +++ /dev/null @@ -1,37 +0,0 @@ -#%Module###################################################################### -## Russ.Treadon@noaa.gov -## NOAA/NWS/NCEP/EMC -## GDAS_ENKF v6.2.3 -##_____________________________________________________ -#set ver v6.2.3 - -set COMP ifort -set COMP_MP mpfort -set COMP_MPI mpiifort - -set C_COMP icc -set C_COMP_MP mpcc - -# Known conflicts - -# Loading Intel Compiler Suite -module load intel/15.6.233 - -# Loading impi -module load impi/5.1.2.150 - -# Loading netcdf and hdf5 -module load hdf5/1.8.14 -module load netcdf/4.3.0 - -# Loading nceplibs modules -module use -a /scratch3/NCEPDEV/nwprod/lib/modulefiles -module load bufr/v10.2.5 -module load nemsio/v2.2.1 -module load sfcio/v1.0.0 -module load sigio/v2.0.1 -module load sp/v2.0.2 -module load w3nco/v2.0.6 -module load w3emc/v2.3.0 -module load bacio/v2.0.2 -module load crtm/v2.2.3 diff --git a/modulefiles/modulefile.ProdGSI.wcoss b/modulefiles/modulefile.ProdGSI.wcoss index eb0a2dbb5..88467187c 100644 --- a/modulefiles/modulefile.ProdGSI.wcoss +++ b/modulefiles/modulefile.ProdGSI.wcoss @@ -33,15 +33,19 @@ module load ics/15.0.3 # Loading ibmpe module load ibmpe +module load lsf # Loading nceplibs modules -module load NetCDF/3.6.3 +module load NetCDF/4.2 module load bufr/v11.0.0 module load nemsio/v2.2.1 module load sfcio/v1.0.0 -module load sigio/v2.0.1 +module load sigio/v2.1.0 module load sp/v2.0.2 module load w3nco/v2.0.6 module load w3emc/v2.2.0 module load crtm/v2.2.3 module load bacio/v2.0.2 + +module use /usrx/local/dev/modulefiles +module load cmake diff --git a/modulefiles/modulefile.ProdGSI.wcoss_c b/modulefiles/modulefile.ProdGSI.wcoss_c new file mode 100644 index 000000000..dcd475e8e --- /dev/null +++ b/modulefiles/modulefile.ProdGSI.wcoss_c @@ -0,0 +1,70 @@ +#%Module###################################################################### +## Russ.Treadon@noaa.gov +## NOAA/NWS/NCEP/EMC +## GDAS_ENKF v6.2.3 +##_____________________________________________________ +proc ModulesHelp { } { +puts stderr "Set environment veriables for GDAS_ENKF" +puts stderr "This module initializes the environment " +puts stderr "for the Intel Compiler Suite $version\n" +} +module-whatis " GDAS_ENKF whatis description" + +set ver v6.2.3 + +setenv COMP ftn +setenv COMP_MP ftn +setenv COMP_MPI ftn + +setenv C_COMP cc +setenv C_COMP_MP cc + +set COMPILER intel + +setenv FFLAGS_COM "-fp-model strict" +setenv LDFLAGS_COM " " + +set WRF_SHARED_VER v1.1.0 +set WRF_SHARED_ROOT /gpfs/hps/nco/ops/nwprod/wrf_shared +setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT}.${WRF_SHARED_VER}-${COMPILER} + +# Known conflicts + +# Loading ncep environment +module load ncep/1.0 +module load prod_util/1.0.29 + +# Loading Intel Compiler Suite +#module load PrgEnv-intel/5.2.56 +#module unload intel/15.0.3.187 +#module load intel/18.1.163 +module load PrgEnv-intel/5.2.82 +module switch intel intel/15.0.3.187 + +# Loading pe environment +module load cray-mpich/7.2.0 +module load craype-haswell + +module use /usrx/local/dev/modulefiles +module load cmake/3.6.2 +module unuse /usrx/local/dev/modulefiles + +# Loading netcdf modules +module use /usrx/local/prod/modulefiles +module load HDF5-serial-intel-haswell/1.8.9 +module load NetCDF-intel-haswell/4.2 + +# Loading nceplibs modules +module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles +module load bufr-intel/11.0.1 +module load nemsio-intel/2.2.2 +module load sfcio-intel/1.0.0 +module load sigio-intel/2.1.0 +module load sp-intel/2.0.2 +module load w3nco-intel/2.0.6 +module load w3emc-intel/2.2.0 +module load crtm-intel/2.2.6 + +module use /usrx/local/nceplibs/modulefiles +module load bacio-intel/2.0.2 + diff --git a/modulefiles/modulefile.ProdGSI.wcoss_d b/modulefiles/modulefile.ProdGSI.wcoss_d new file mode 100644 index 000000000..2bf614b4f --- /dev/null +++ b/modulefiles/modulefile.ProdGSI.wcoss_d @@ -0,0 +1,49 @@ +#%Module###################################################################### +# Russ.Treadon@noaa.gov +# NOAA/NWS/NCEP/EMC +# GDAS_ENKF v6.2.3 +#_____________________________________________________ +#proc ModulesHelp { } { +#puts stderr "Set environment veriables for GDAS_ENKF" +#puts stderr "This module initializes the environment " +#puts stderr "for the Intel Compiler Suite $version\n" +##} +#module-whatis " GDAS_ENKF whatis description" + +#set ver v6.2.3 + +set COMP ifort +set COMP_MPI mpiifort + +set C_COMP icc + +# Known conflicts + +# Loading pe environment +module load lsf/10.1 + +# Loading Intel Compiler Suite +module load ips/18.0.1.163 + +# Loading intel mpi +module load impi/18.0.1 + +# Loading production utilities (ndate) +module load prod_util/1.1.0 + +# Loading nceplibs modules +module load bufr/11.2.0 +module load nemsio/2.2.3 +module load sfcio/1.0.0 +module load sigio/2.1.0 +module load sp/2.0.2 +module load w3nco/2.0.6 +module load w3emc/2.3.0 +module load crtm/2.2.6 +module load bacio/2.0.2 + +# Loading netcdf modules +module load NetCDF/4.5.0 + +# Loading cmake +module load cmake/3.10.0 diff --git a/modulefiles/modulefile.ProdGSI_hwrf.cheyenne b/modulefiles/modulefile.ProdGSI_hwrf.cheyenne new file mode 100644 index 000000000..589ee214d --- /dev/null +++ b/modulefiles/modulefile.ProdGSI_hwrf.cheyenne @@ -0,0 +1,16 @@ +#%Module###################################################################### +## Mark.Potts@noaa.gov +## NOAA/NWS/NCEP/EMC +## ProdGSI +##_____________________________________________________ + +module purge +module load ncarenv/1.2 +module load cmake/3.9.1 +module load intel/18.0.1 +module load impi/2018.1.163 +module load mkl/2018.0.1 +module load netcdf/4.5.0 +module list + +echo "done loading modules" diff --git a/modulefiles/modulefile.ProdGSI_hwrf.hera b/modulefiles/modulefile.ProdGSI_hwrf.hera new file mode 100644 index 000000000..a12b00843 --- /dev/null +++ b/modulefiles/modulefile.ProdGSI_hwrf.hera @@ -0,0 +1,61 @@ +#%Module###################################################################### +## Russ.Treadon@noaa.gov +## NOAA/NWS/NCEP/EMC +## GDAS_ENKF v6.2.3 +##_____________________________________________________ +#set ver v6.2.3 + +set COMP ifort +set COMP_MP mpfort +set COMP_MPI mpiifort + +set C_COMP icc +set C_COMP_MP mpcc + +# Known conflicts + +# Load compiler, mpi, cmake, and hdf5/netcdf + +# Changes made for HWRF build system. +# Commented out duplicate modules already loaded, and +# defined by the HWRF build system for Hera, based on +# the modulefiles/hera/HWRF/build file. +# +# commented out for hwrf system indicated by #hwrf# +# +# Doing so makes sure gsi is being built and run with same modules that +# the HWRF system is using and we don't have to keep this module +# file in sync with changes to the HWRF module files. +# Note: Since some module loads are being commented out, any other +# scripts under ProdGSI, such as the sub_hera script, that may use +# this file will no longer work, since it depends on these commented +# modules being loaded. However, the choice was made, that +# this branch is for the HWRF system only and those scripts +# will not be used. + +#hwrf# module load intel/18.0.5.274 +#hwrf# module load impi/2018.0.4 +#hwrf# module load hdf5/1.10.4 +#hwrf# module load netcdf/4.6.1 +module load contrib +module load cmake/3.9.0 + +# Load libraries +module use /scratch2/NCEPDEV/nwprod/NCEPLIBS/modulefiles +module load bacio/2.0.3 +module load bufr/11.3.0 +module load crtm/2.2.6 +module load nemsio/2.2.4 +module load prod_util/1.1.0 +module load sfcio/1.1.1 +module load sigio/2.1.1 +module load sp/2.0.3 +module load w3emc/2.3.1 +module load w3nco/2.0.7 + + +# Set environmental variables to allow correlated error to reproduce on Hera +#setenv MKL_NUM_THREADS 4 +#setenv MKL_CBWR AUTO +export MKL_NUM_THREADS=4 +export MKL_CBWR=AUTO diff --git a/modulefiles/modulefile.ProdGSI_hwrf.jet b/modulefiles/modulefile.ProdGSI_hwrf.jet new file mode 100644 index 000000000..741d02036 --- /dev/null +++ b/modulefiles/modulefile.ProdGSI_hwrf.jet @@ -0,0 +1,72 @@ +#%Module###################################################################### +## Russ.Treadon@noaa.gov +## NOAA/NWS/NCEP/EMC +## GDAS_ENKF v6.2.3 +##_____________________________________________________ +#proc ModulesHelp { } { +#puts stderr "Set environment veriables for GSI build with CMake" +#puts stderr "This module initializes the environment " +#puts stderr "for the Intel Compiler Suite $version\n" +#} +#module-whatis " GDAS_ENKF whatis description" +# +# + +# Changes made for HWRF build system. +# Commented out duplicate modules already loaded, and +# defined by the HWRF build system for Jet, based on +# the modulefiles/jet/HWRF/build file. +# +# Commented out for hwrf system indicated by #hwrf# +# +# Doing so makes sure gsi is being built and run with same modules that +# the HWRF system is using and we don't have to keep this module +# file in sync with changes to the HWRF module files. +# Note: Since some module loads are being commented out, any other +# scripts under ProdGSI, such as the sub_hera script, that may use +# this file will no longer work, since it depends on these commented +# modules being loaded. However, the choice was made, that +# this branch is for the HWRF system only and those scripts +# will not be used. +#hwrf# module load intel/15.0.3.187 +#hwrf# module load impi +# +#hwrf# module load szip/2.1 +#hwrf# module load hdf5/1.8.9 +#hwrf# module load netcdf4/4.2.1.1 + +#hwrf# Commented out first COREPATH defintions since it is +# overwritten by second one under gwv anyway. +#export COREPATH=/lfs3/projects/hfv3gfs/nwprod/lib +export COREPATH=/mnt/lfs3/projects/hfv3gfs/gwv/ljtjet/lib +export NCEPLIBS=$COREPATH +module use $NCEPLIBS/modulefiles + +export FFLAGS="-openmp" +export LDFLAGS="-openmp" +module load ip-intel-sandybridge/3.0.0 +module load bacio-intel-sandybridge/2.0.2 +module load crtm-intel-sandybridge/2.2.5 +module load bufr-intel-sandybridge/11.1.0 +module load nemsio-intel-sandybridge/2.2.2 +module load sp-intel-sandybridge/2.0.2 +module load w3emc-intel-sandybridge/2.2.0 +module load w3nco-intel-sandybridge/2.0.6 +module load sigio-intel-sandybridge/2.0.1 +module load sfcio-intel-sandybridge/1.0.0 + +#hwrf# not sure why these were defined. +#module use /home/George.Vandenberghe/t1/l1025/lib/modulefiles +#module load hdf5 +#module load netcdf + +# These NETCDF vars should not be set when running make with the hwrf +# system, it will break the ProdGSI build since NETCDF4 is not inherited +# and defined. Cmake, FindNetCDF.cmake will properly define NETCDF when +# hwrf sorc/make is run. +# However, these are required when calling ProdGSI/compile directly +# and not using the hwrf sorc/make build system. +# +# The HWRF system is currently /apps/netcdf/4.2.1.1-intel +#hwrf# export NETCDF=${NETCDF4} +#hwrf# export NETCDF_DIR=${NETCDF4} diff --git a/modulefiles/modulefile.ProdGSI_hwrf.wcoss_c b/modulefiles/modulefile.ProdGSI_hwrf.wcoss_c new file mode 100644 index 000000000..ffe923a29 --- /dev/null +++ b/modulefiles/modulefile.ProdGSI_hwrf.wcoss_c @@ -0,0 +1,87 @@ +#%Module###################################################################### +## Russ.Treadon@noaa.gov +## NOAA/NWS/NCEP/EMC +## GDAS_ENKF v6.2.3 +##_____________________________________________________ +proc ModulesHelp { } { +puts stderr "Set environment veriables for GDAS_ENKF" +puts stderr "This module initializes the environment " +puts stderr "for the Intel Compiler Suite $version\n" +} +module-whatis " GDAS_ENKF whatis description" + +set ver v6.2.3 + +setenv COMP ftn +setenv COMP_MP ftn +setenv COMP_MPI ftn + +setenv C_COMP cc +setenv C_COMP_MP cc + +set COMPILER intel + +setenv FFLAGS_COM "-fp-model strict" +setenv LDFLAGS_COM " " + +set WRF_SHARED_VER v1.1.0 +set WRF_SHARED_ROOT /gpfs/hps/nco/ops/nwprod/wrf_shared +setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT}.${WRF_SHARED_VER}-${COMPILER} + +# Known conflicts + +# Changes made for HWRF build system. +# Commented out duplicate modules already loaded, and +# defined by the HWRF build system for WCOSS Cray, based on +# the modulefiles/wcossluna/HWRF/build file. +# +# commented out for hwrf system indicated by #hwrf# +# +# Doing so makes sure gsi is being built and run with same modules that +# the HWRF system is using and we don't have to keep this module +# file in sync with changes to the HWRF module files. +# Note: Since some module loads are being commented out, any other +# scripts under ProdGSI, such as the sub_hera script, that may use +# this file will no longer work, since it depends on these commented +# modules being loaded. However, the choice was made, that +# this branch is for the HWRF system only and those scripts +# will not be used. + +# Loading ncep environment +#hwrf# module load ncep/1.0 +module load prod_util/1.0.29 + +# Loading Intel Compiler Suite +#module load PrgEnv-intel/5.2.56 +#module unload intel/15.0.3.187 +#module load intel/18.1.163 +#hwrf# module load PrgEnv-intel/5.2.82 +#hwrf# module switch intel intel/15.0.3.187 + +# Loading pe environment +module load cray-mpich/7.2.0 +#hwrf# module load craype-haswell + +module use /usrx/local/dev/modulefiles +module load cmake/3.6.2 +module unuse /usrx/local/dev/modulefiles + +# Loading netcdf modules +#hwrf# module use /usrx/local/prod/modulefiles +#hwrf# module load HDF5-serial-intel-haswell/1.8.9 +#hwrf# module load NetCDF-intel-haswell/4.2 + +# Loading nceplibs modules +module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles +module load bufr-intel/11.0.1 +module load nemsio-intel/2.2.2 +module load sfcio-intel/1.0.0 +module load sigio-intel/2.1.0 +module load sp-intel/2.0.2 +module load w3nco-intel/2.0.6 +module load w3emc-intel/2.2.0 +module load crtm-intel/2.2.6 + +module use /usrx/local/nceplibs/modulefiles +module load bacio-intel/2.0.2 + diff --git a/modulefiles/modulefile.gdas_enkf.cray b/modulefiles/modulefile.gdas_enkf.cray deleted file mode 100644 index 361a50b1b..000000000 --- a/modulefiles/modulefile.gdas_enkf.cray +++ /dev/null @@ -1,58 +0,0 @@ -#%Module###################################################################### -## Russ.Treadon@noaa.gov -## NOAA/NWS/NCEP/EMC -## GDAS_ENKF v6.2.3 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for GDAS_ENKF" -puts stderr "This module initializes the environment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " GDAS_ENKF whatis description" - -set ver v6.2.3 - -setenv COMP ftn -setenv COMP_MP ftn -setenv COMP_MPI ftn - -setenv C_COMP cc -setenv C_COMP_MP cc - -set COMPILER intel - -setenv FFLAGS_COM "-fp-model strict" -setenv LDFLAGS_COM " " - -set WRF_SHARED_VER v1.1.0 -set WRF_SHARED_ROOT /gpfs/hps/nco/ops/nwprod/wrf_shared -setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT}.${WRF_SHARED_VER}-${COMPILER} - -# Known conflicts - -# Loading ncep environment -module load ncep/1.0 - -# Loading Intel Compiler Suite -module load PrgEnv-intel/5.2.56 - -# Loading pe environment -module load cray-mpich/7.2.0 -module load craype-haswell - -# Loading nceplibs modules -module use /usrx/local/prod/modulefiles -module load NetCDF-intel-haswell/3.6.3 - -module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles -module load bufr-intel/11.0.1 -module load nemsio-intel/2.2.2 -module load sfcio-intel/1.0.0 -module load sigio-intel/2.0.1 -module load sp-intel/2.0.2 -module load w3nco-intel/2.0.6 -module load w3emc-intel/2.2.0 -module load crtm-intel/2.2.3 - -module use /usrx/local/nceplibs/modulefiles -module load bacio-intel/2.0.2 diff --git a/modulefiles/modulefile.gdas_enkf.theia b/modulefiles/modulefile.gdas_enkf.theia deleted file mode 100644 index 9e60bda71..000000000 --- a/modulefiles/modulefile.gdas_enkf.theia +++ /dev/null @@ -1,34 +0,0 @@ -#%Module###################################################################### -## Russ.Treadon@noaa.gov -## NOAA/NWS/NCEP/EMC -## GDAS_ENKF v6.2.3 -##_____________________________________________________ -#set ver v6.2.3 - -set COMP ifort -set COMP_MP mpfort -set COMP_MPI mpiifort - -set C_COMP icc -set C_COMP_MP mpcc - -# Known conflicts - -# Loading Intel Compiler Suite -module load intel/14.0.2 - -# Loading impi -module load impi - -# Loading nceplibs modules -module use -a /scratch3/NCEPDEV/nwprod/lib/modulefiles -module load netcdf/3.6.3 -module load bufr/v10.2.5 -module load nemsio/v2.2.1 -module load sfcio/v1.0.0 -module load sigio/v2.0.1 -module load sp/v2.0.2 -module load w3nco/v2.0.6 -module load w3emc/v2.2.0 -module load crtm/v2.2.3 -module load bacio/v2.0.1 diff --git a/modulefiles/modulefile.gdas_enkf.wcoss b/modulefiles/modulefile.gdas_enkf.wcoss deleted file mode 100644 index eb0a2dbb5..000000000 --- a/modulefiles/modulefile.gdas_enkf.wcoss +++ /dev/null @@ -1,47 +0,0 @@ -#%Module###################################################################### -## Russ.Treadon@noaa.gov -## NOAA/NWS/NCEP/EMC -## GDAS_ENKF v6.2.3 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for GDAS_ENKF" -puts stderr "This module initializes the environment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " GDAS_ENKF whatis description" - -set ver v6.2.3 - -setenv COMP ifort -setenv COMP_MP mpfort -setenv COMP_MPI mpiifort - -setenv C_COMP icc -setenv C_COMP_MP mpcc - -setenv FFLAGS_COM "-fp-model source" -setenv LDFLAGS_COM "-mkl" - -set WRF_SHARED_VER v1.1.0 -set WRF_SHARED_ROOT /nwprod/sorc/wrf_shared.fd -setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT} - -# Known conflicts - -# Loading Intel Compiler Suite -module load ics/15.0.3 - -# Loading ibmpe -module load ibmpe - -# Loading nceplibs modules -module load NetCDF/3.6.3 -module load bufr/v11.0.0 -module load nemsio/v2.2.1 -module load sfcio/v1.0.0 -module load sigio/v2.0.1 -module load sp/v2.0.2 -module load w3nco/v2.0.6 -module load w3emc/v2.2.0 -module load crtm/v2.2.3 -module load bacio/v2.0.2 diff --git a/modulefiles/modulefile.global_gsi.cray b/modulefiles/modulefile.global_gsi.cray deleted file mode 100644 index ef2fd68e4..000000000 --- a/modulefiles/modulefile.global_gsi.cray +++ /dev/null @@ -1,58 +0,0 @@ -#%Module###################################################################### -## Russ.Treadon@noaa.gov -## NOAA/NWS/NCEP/EMC -## GLOBAL_GSI v6.2.3 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for GLOBAL_GSI" -puts stderr "This module initializes the environment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " GLOBAL_GSI whatis description" - -set ver v6.2.3 - -setenv COMP ftn -setenv COMP_MP ftn -setenv COMP_MPI ftn - -setenv C_COMP cc -setenv C_COMP_MP cc - -set COMPILER intel - -setenv FFLAGS_COM "-fp-model strict" -setenv LDFLAGS_COM " " - -set WRF_SHARED_VER v1.1.0 -set WRF_SHARED_ROOT /gpfs/hps/nco/ops/nwprod/wrf_shared -setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT}.${WRF_SHARED_VER}-${COMPILER} - -# Known conflicts - -# Loading ncep environment -module load ncep/1.0 - -# Loading Intel Compiler Suite -module load PrgEnv-intel/5.2.56 - -# Loading pe environment -module load cray-mpich/7.2.0 -module load craype-haswell - -# Loading nceplibs modules -module use /usrx/local/prod/modulefiles -module load NetCDF-intel-haswell/3.6.3 - -module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles -module load bufr-intel/11.0.1 -module load nemsio-intel/2.2.2 -module load sfcio-intel/1.0.0 -module load sigio-intel/2.0.1 -module load sp-intel/2.0.2 -module load w3nco-intel/2.0.6 -module load w3emc-intel/2.2.0 -module load crtm-intel/2.2.3 - -module use /usrx/local/nceplibs/modulefiles -module load bacio-intel/2.0.2 diff --git a/modulefiles/modulefile.global_gsi.theia b/modulefiles/modulefile.global_gsi.theia deleted file mode 100644 index c6c4eec8d..000000000 --- a/modulefiles/modulefile.global_gsi.theia +++ /dev/null @@ -1,35 +0,0 @@ -#%Module###################################################################### -## Russ.Treadon@noaa.gov -## NOAA/NWS/NCEP/EMC -## GLOBAL_GSI v6.2.3 -##_____________________________________________________ - -set ver v6.2.3 - -set COMP ifort -set COMP_MP mpfort -set COMP_MPI mpiifort - -set C_COMP icc -set C_COMP_MP mpcc - -# Known conflicts - -# Loading Intel Compiler Suite -module load intel/14.0.2 - -# Loading impi -module load impi - -# Loading nceplibs modules -module use -a /scratch3/NCEPDEV/nwprod/lib/modulefiles -module load netcdf/3.6.3 -module load bufr/v10.2.5 -module load nemsio/v2.2.1 -module load sfcio/v1.0.0 -module load sigio/v2.0.1 -module load sp/v2.0.2 -module load w3nco/v2.0.6 -module load w3emc/v2.2.0 -module load crtm/v2.2.3 -module load bacio/v2.0.1 diff --git a/modulefiles/modulefile.global_gsi.wcoss b/modulefiles/modulefile.global_gsi.wcoss deleted file mode 100644 index 63aedff0f..000000000 --- a/modulefiles/modulefile.global_gsi.wcoss +++ /dev/null @@ -1,47 +0,0 @@ -#%Module###################################################################### -## Russ.Treadon@noaa.gov -## NOAA/NWS/NCEP/EMC -## GLOBAL_GSI v6.2.3 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for GLOBAL_GSI" -puts stderr "This module initializes the environment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " GLOBAL_GSI whatis description" - -set ver v6.2.3 - -setenv COMP ifort -setenv COMP_MP mpfort -setenv COMP_MPI mpiifort - -setenv C_COMP icc -setenv C_COMP_MP mpcc - -setenv FFLAGS_COM "-fp-model source" -setenv LDFLAGS_COM "-mkl" - -set WRF_SHARED_VER v1.1.0 -set WRF_SHARED_ROOT /nwprod/sorc/wrf_shared.fd -setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT} - -# Known conflicts - -# Loading Intel Compiler Suite -module load ics/15.0.3 - -# Loading ibmpe -module load ibmpe - -# Loading nceplibs modules -module load NetCDF/3.6.3 -module load bufr/v11.0.0 -module load nemsio/v2.2.1 -module load sfcio/v1.0.0 -module load sigio/v2.0.1 -module load sp/v2.0.2 -module load w3nco/v2.0.6 -module load w3emc/v2.2.0 -module load crtm/v2.2.3 -module load bacio/v2.0.2 diff --git a/regression/arw_binary.sh b/regression/arw_binary.sh index 565c4057e..d2b5bf2d7 100755 --- a/regression/arw_binary.sh +++ b/regression/arw_binary.sh @@ -43,7 +43,7 @@ tmpdir=$tmpdir/tmpreg_arw_binary/${exp} savdir=$savdir/outreg/arw_binary/${exp} # Specify GSI fixed field and data directories. - +fixcrtm=${fixcrtm:-$CRTM_FIX} # Set variables used in script # CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) diff --git a/regression/arw_netcdf.sh b/regression/arw_netcdf.sh index a78e73214..5cccfab45 100755 --- a/regression/arw_netcdf.sh +++ b/regression/arw_netcdf.sh @@ -43,7 +43,7 @@ tmpdir=$tmpdir/tmpreg_arw_netcdf/${exp} savdir=$savdir/outreg/arw_netcdf/${exp} # Specify GSI fixed field and data directories. - +fixcrtm=${fixcrtm:-$CRTM_FIX} # Set variables used in script # CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) diff --git a/regression/global_4denvar_T126.sh b/regression/global_4denvar_T126.sh index 4cc855d85..f926517de 100755 --- a/regression/global_4denvar_T126.sh +++ b/regression/global_4denvar_T126.sh @@ -8,7 +8,7 @@ exp=$jobname # Set path/file for gsi executable #basedir=/scratch1/portfolios/NCEPDEV/da/save/Daryl.Kleist #gsipath=$basedir/gsi/ -#gsiexec=$gsipath/trunk/src/global_gsi +#gsiexec=$gsipath/trunk/src/global_gsi.x # Set the JCAP resolution which you want. # All resolutions use LEVS=64 @@ -22,8 +22,7 @@ tmpdir=$tmpdir/$tmpregdir/${exp} savdir=$savdir/out${JCAP}/${exp} # Specify GSI fixed field and data directories. -#fixgsi=$gsipath/trunk/fix -#fixcrtm=$gsipath/EXP-port410/lib/CRTM_REL-2.2.3/fix +#fixcrtm=${fixcrtm:-$CRTM_FIX} #datobs=/scratch1/portfolios/NCEPDEV/da/noscrub/Daryl.Kleist/CASES/$adate/obs #datges=/scratch1/portfolios/NCEPDEV/da/noscrub/Daryl.Kleist/CASES/$adate/ges @@ -302,6 +301,18 @@ for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do $ncp $fixcrtm/${file}.TauCoeff.bin ./ done +#if using correlated error, link to the covariance files +#if grep -q "Rcov" $anavinfo ; +#then +# if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; +# then +# $ncp ${fixgsi}/Rcov* . +# else +# echo "Warning: Satellite error covariance files are missing." +# echo "Check for the required Rcov files in " $anavinfo +# exit 1 +# fi +#fi # Copy observational data to $tmpdir $ncp $global_4denvar_T126_datobs/prepqc.gdas.$global_4denvar_T126_adate ./prepbufr @@ -340,6 +351,7 @@ $ncp $global_4denvar_T126_datobs/sevcsr.gdas.$global_4denvar_T126_adate $ncp $global_4denvar_T126_datobs/atms.gdas.$global_4denvar_T126_adate ./atmsbufr $ncp $global_4denvar_T126_datobs/atmsdb.gdas.$global_4denvar_T126_adate ./atmsbufr_db $ncp $global_4denvar_T126_datobs/ssmisu.gdas.$global_4denvar_T126_adate ./ssmisbufr +$ncp $global_4denvar_T126_datobs/abicsr.gdas.$global_4denvar_T126_adate ./abibufr # Copy bias correction, atmospheric and surface files diff --git a/regression/global_4dvar_T62.sh b/regression/global_4dvar_T62.sh index 34e68b5c4..5b13542b7 100755 --- a/regression/global_4dvar_T62.sh +++ b/regression/global_4dvar_T62.sh @@ -19,7 +19,7 @@ tmpdir=$tmpdir/$tmpregdir/${exp} savdir=$savdir/4dvar_out${JCAP}/sigmap/${exp} # Specify GSI fixed field and data directories. - +fixcrtm=${fixcrtm:-$CRTM_FIX} # Set variables used in script # CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) @@ -300,6 +300,19 @@ $ncp $btable_uv ./btable_uv $ncp $bufrtable ./prepobs_prep.bufrtable $ncp $bftab_sst ./bftab_sstphr +#if using correlated error, link to the covariance files +#if grep -q "Rcov" $anavinfo ; +#then +# if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; +# then +# $ncp ${fixgsi}/Rcov* . +# else +# echo "Warning: Satellite error covariance files are missing." +# echo "Check for the required Rcov files in " $anavinfo +# exit 1 +# fi +#fi + # Adjust data usage flags in convinfo file. rm new cp convinfo old diff --git a/regression/global_C96_fv3aero.sh b/regression/global_C96_fv3aero.sh new file mode 100755 index 000000000..e5468b613 --- /dev/null +++ b/regression/global_C96_fv3aero.sh @@ -0,0 +1,326 @@ + +set -x + +# Set experiment name and analysis date + +exp=$jobname + +# Set the JCAP resolution which you want. +# All resolutions use LEVS=64 +export LEVS=64 + +# Set runtime and save directories +tmpdir=$tmpdir/$tmpregdir/${exp} +savdir=$savdir/outC96_fv3aero/${exp} + +# Specify GSI fixed field and data directories. +fixcrtm=${fixcrtm:-$CRTM_FIX} + +# Set variables used in script +# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) +# ncp is cp replacement, currently keep as /bin/cp + +UNCOMPRESS=gunzip +CLEAN=NO +ncp=/bin/cp + +# Given the analysis date, compute the date from which the +# first guess comes. Extract cycle and set prefix and suffix +# for guess and observation data files +gdate=`$ndate -06 $global_C96_fv3aero_adate` +hha=`echo $global_C96_fv3aero_adate | cut -c9-10` +hhg=`echo $gdate | cut -c9-10` +prefix_obs=gfs.t${hha}z. +prefix_prep=$prefix_obs +prefix_tbc=gdas1.t${hhg}z +prefix_sfc=gfsC96.t${hhg}z +prefix_atm=gfsC96.t${hhg}z +suffix_obs=gdas.${global_C96_fv3aero_adate} +suffix_bias=gdas.${gdate} + + +# Set up $tmpdir +rm -rf $tmpdir +mkdir -p $tmpdir +cd $tmpdir +rm -rf core* + + +# CO2 namelist and file decisions +ICO2=${ICO2:-0} +if [ $ICO2 -gt 0 ] ; then + # Copy co2 files to $tmpdir + co2dir=${CO2DIR:-$fixgsi} + yyyy=$(echo ${CDATE:-$global_C96_fv3aero_adate}|cut -c1-4) + rm ./global_co2_data.txt + co2=$co2dir/global_co2.gcmscl_$yyyy.txt + while [ ! -s $co2 ] ; do + ((yyyy-=1)) + co2=$co2dir/global_co2.gcmscl_$yyyy.txt + done + if [ -s $co2 ] ; then + $ncp $co2 ./global_co2_data.txt + fi + if [ ! -s ./global_co2_data.txt ] ; then + echo "\./global_co2_data.txt" not created + exit 1 + fi +fi +#CH4 file decision +ICH4=${ICH4:-0} +if [ $ICH4 -gt 0 ] ; then +# # Copy ch4 files to $tmpdir + ch4dir=${CH4DIR:-$fixgsi} + yyyy=$(echo ${CDATE:-$global_C96_fv3aero_adate}|cut -c1-4) + rm ./ch4globaldata.txt + ch4=$ch4dir/global_ch4_esrlctm_$yyyy.txt + while [ ! -s $ch4 ] ; do + ((yyyy-=1)) + ch4=$ch4dir/global_ch4_esrlctm_$yyyy.txt + done + if [ -s $ch4 ] ; then + $ncp $ch4 ./ch4globaldata.txt + fi + if [ ! -s ./ch4globaldata.txt ] ; then + echo "\./ch4globaldata.txt" not created + exit 1 + fi +fi +IN2O=${IN2O:-0} +if [ $IN2O -gt 0 ] ; then +# # Copy ch4 files to $tmpdir + n2odir=${N2ODIR:-$fixgsi} + yyyy=$(echo ${CDATE:-$global_C96_fv3aero_adate}|cut -c1-4) + rm ./n2oglobaldata.txt + n2o=$n2odir/global_n2o_esrlctm_$yyyy.txt + while [ ! -s $n2o ] ; do + ((yyyy-=1)) + n2o=$n2odir/global_n2o_esrlctm_$yyyy.txt + done + if [ -s $n2o ] ; then + $ncp $n2o ./n2oglobaldata.txt + fi + if [ ! -s ./n2oglobaldata.txt ] ; then + echo "\./n2oglobaldata.txt" not created + exit 1 + fi +fi +ICO=${ICO:-0} +if [ $ICO -gt 0 ] ; then +# # Copy CO files to $tmpdir + codir=${CODIR:-$fixgsi} + yyyy=$(echo ${CDATE:-$global_C96_fv3aero_adate}|cut -c1-4) + rm ./coglobaldata.txt + co=$codir/global_co_esrlctm_$yyyy.txt + while [ ! -s $co ] ; do + ((yyyy-=1)) + co=$codir/global_co_esrlctm_$yyyy.txt + done + if [ -s $co ] ; then + $ncp $co ./coglobaldata.txt + fi + if [ ! -s ./coglobaldata.txt ] ; then + echo "\./coglobaldata.txt" not created + exit 1 + fi +fi + +# Make gsi namelist + +. $scripts/regression_nl_update.sh + +SETUP="$SETUP_update" +GRIDOPTS="$GRIDOPTS_update" +BKGVERR="$BKGVERR_update" +ANBKGERR="$ANBKERR_update" +JCOPTS="$JCOPTS_update" +STRONGOPTS="$STRONGOPTS_update" +OBSQC="$OBSQC_update" +OBSINPUT="$OBSINPUT_update" +SUPERRAD="$SUPERRAD_update" +SINGLEOB="$SINGLEOB_update" + +. $scripts/regression_namelists.sh global_C96_fv3aero + +##! l4dvar=.false.,nhr_assimilation=6,nhr_obsbin=6, +##! lsqrtb=.true.,lcongrad=.false.,ltlint=.true., +##! idmodel=.true.,lwrtinc=.false., + +cat << EOF > gsiparm.anl + +$gsi_namelist + +EOF + +# Set fixed files +# berror = forecast model background error statistics +# specoef = CRTM spectral coefficients +# trncoef = CRTM transmittance coefficients +# emiscoef = CRTM coefficients for IR sea surface emissivity model +# aerocoef = CRTM coefficients for aerosol effects +# cldcoef = CRTM coefficients for cloud effects +# satinfo = text file with information about assimilation of brightness temperatures +# cloudyinfo = text file with information about assimilation of cloudy radiance +# satangl = angle dependent bias correction file (fixed in time) +# pcpinfo = text file with information about assimilation of prepcipitation rates +# ozinfo = text file with information about assimilation of ozone data +# errtable = text file with obs error for conventional data (optional) +# convinfo = text file with information about assimilation of conventional data +# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.) +# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.) + +berror=$fixgsi/Big_Endian/fv3aero_berror.l64y194.f77 + +emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin +emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin +emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin +emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin +emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin +emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin +emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin +emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin +emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin +aercoef=$fixcrtm/AerosolCoeff.bin +cldcoef=$fixcrtm/CloudCoeff.bin +satangl=$fixgsi/global_satangbias.txt +scaninfo=$fixgsi/global_scaninfo.txt +satinfo=$fixgsi/global_satinfo.txt +cloudyinfo=$fixgsi/cloudy_radiance_info.txt +convinfo=$fixgsi/global_convinfo_reg_test.txt +anavinfo=$fixgsi/anavinfo_fv3aero +aeroinfo=$fixgsi/aeroinfo_fv3aero +ozinfo=$fixgsi/global_ozinfo.txt +pcpinfo=$fixgsi/global_pcpinfo.txt +hybens_info=$fixgsi/global_hybens_info.l64.txt +errtable=$fixgsi/prepobs_errtable.global +atmsbeaminfo=$fixgsi/atms_beamwidth.txt + +# Copy executable and fixed files to $tmpdir +if [[ $exp == *"updat"* ]]; then + $ncp $gsiexec_updat ./gsi.x +elif [[ $exp == *"contrl"* ]]; then + $ncp $gsiexec_contrl ./gsi.x +fi + +mkdir ./crtm_coeffs +$ncp $berror ./berror_stats +$ncp $emiscoef_IRwater ./crtm_coeffs/Nalli.IRwater.EmisCoeff.bin +$ncp $emiscoef_IRice ./crtm_coeffs/NPOESS.IRice.EmisCoeff.bin +$ncp $emiscoef_IRsnow ./crtm_coeffs/NPOESS.IRsnow.EmisCoeff.bin +$ncp $emiscoef_IRland ./crtm_coeffs/NPOESS.IRland.EmisCoeff.bin +$ncp $emiscoef_VISice ./crtm_coeffs/NPOESS.VISice.EmisCoeff.bin +$ncp $emiscoef_VISland ./crtm_coeffs/NPOESS.VISland.EmisCoeff.bin +$ncp $emiscoef_VISsnow ./crtm_coeffs/NPOESS.VISsnow.EmisCoeff.bin +$ncp $emiscoef_VISwater ./crtm_coeffs/NPOESS.VISwater.EmisCoeff.bin +$ncp $emiscoef_MWwater ./crtm_coeffs/FASTEM6.MWwater.EmisCoeff.bin +$ncp $aercoef ./crtm_coeffs/AerosolCoeff.bin +$ncp $cldcoef ./crtm_coeffs/CloudCoeff.bin +$ncp $satangl ./satbias_angle +$ncp $scaninfo ./scaninfo +$ncp $satinfo ./satinfo +$ncp $cloudyinfo ./cloudy_radiance_info.txt +$ncp $pcpinfo ./pcpinfo +$ncp $ozinfo ./ozinfo +$ncp $convinfo ./convinfo +$ncp $errtable ./errtable +$ncp $anavinfo ./anavinfo +$ncp $aeroinfo ./aeroinfo +$ncp $hybens_info ./hybens_info +$ncp $atmsbeaminfo ./atms_beamwidth.txt + +# Copy CRTM coefficient files +$ncp $fixcrtm/v.modis_aqua.SpcCoeff.bin ./crtm_coeffs/v.modis_aqua.SpcCoeff.bin +$ncp $fixcrtm/v.modis_aqua.TauCoeff.bin ./crtm_coeffs/v.modis_aqua.TauCoeff.bin +$ncp $fixcrtm/v.modis_terra.SpcCoeff.bin ./crtm_coeffs/v.modis_terra.SpcCoeff.bin +$ncp $fixcrtm/v.modis_terra.TauCoeff.bin ./crtm_coeffs/v.modis_terra.TauCoeff.bin + +# Copy observational data to $tmpdir +ln -s -f $global_C96_fv3aero_obs/${prefix_obs}modisaod.tm00.bufr ./modisaodbufr + + +# Copy bias correction, atmospheric and surface files +ln -s -f $global_C96_fv3aero_ges/gfs.t18z.abias ./satbias_in +ln -s -f $global_C96_fv3aero_ges/gfs.t18z.abias_pc ./satbias_pc +#ln -s -f $global_C96_fv3aero_ges/gfs.t18z.radstat ./radstat.gdas + +if [[ "$endianness" = "Big_Endian" ]]; then + ln -s -f $global_C96_fv3aero_ges/${prefix_sfc}.sfcf03 ./sfcf03 + ln -s -f $global_C96_fv3aero_ges/${prefix_sfc}.sfcf06 ./sfcf06 + ln -s -f $global_C96_fv3aero_ges/${prefix_sfc}.sfcf09 ./sfcf09 +elif [[ "$endianness" = "Little_Endian" ]]; then + ln -s -f $global_C96_fv3aero_ges/${prefix_sfc}.sfcf03.le ./sfcf03 + ln -s -f $global_C96_fv3aero_ges/${prefix_sfc}.sfcf06.le ./sfcf06 + ln -s -f $global_C96_fv3aero_ges/${prefix_sfc}.sfcf09.le ./sfcf09 +fi + +if [[ "$endianness" = "Big_Endian" ]]; then + ln -s -f $global_C96_fv3aero_ges/${prefix_atm}.sigf03 ./sigf03 + ln -s -f $global_C96_fv3aero_ges/${prefix_atm}.sigf06 ./sigf06 + ln -s -f $global_C96_fv3aero_ges/${prefix_atm}.sigf09 ./sigf09 +elif [[ "$endianness" = "Little_Endian" ]]; then + ln -s -f $global_C96_fv3aero_ges/${prefix_atm}.sigf03.le ./sigf03 + ln -s -f $global_C96_fv3aero_ges/${prefix_atm}.sigf06.le ./sigf06 + ln -s -f $global_C96_fv3aero_ges/${prefix_atm}.sigf09.le ./sigf09 +fi + +# Run GSI +cd $tmpdir +echo "run gsi now" +eval "$APRUN $tmpdir/gsi.x > stdout 2>&1" +rc=$? +exit $rc + + + + +# Loop over first and last outer loops to generate innovation +# diagnostic files for indicated observation types (groups) +# +# NOTE: Since we set miter=2 in GSI namelist SETUP, outer +# loop 03 will contain innovations with respect to +# the analysis. Creation of o-a innovation files +# is triggered by write_diag(3)=.true. The setting +# write_diag(1)=.true. turns on creation of o-g +# innovation files. +# + + +echo "Time before diagnostic loop is `date` " +cd $tmpdir +loops="01 03" +for loop in $loops; do + +case $loop in + 01) string=ges;; + 03) string=anl;; + *) string=$loop;; +esac + +# Collect diagnostic files for obs types (groups) below + listall="modis_aod_terra modis_aod_aqua" + for type in $listall; do + count=`ls dir.*/${type}_${loop}* | wc -l` + if [[ $count -gt 0 ]]; then + cat dir.*/${type}_${loop}* > diag_${type}_${string}.${global_T62_adate} + compress diag_${type}_${string}.${global_T62_adate} + $ncp diag_${type}_${string}.${global_T62_adate}.Z $savdir/ + fi + done +done +echo "Time after diagnostic loop is `date` " + + + +# If requested, clean up $tmpdir +if [[ "$CLEAN" = "YES" ]];then + if [[ $rc -eq 0 ]];then + rm -rf $tmpdir + cd $tmpdir + cd ../ + rmdir $tmpdir + fi +fi + + +# End of script +exit diff --git a/regression/global_T62.sh b/regression/global_T62.sh index e1cab32af..5ac99cdca 100755 --- a/regression/global_T62.sh +++ b/regression/global_T62.sh @@ -8,7 +8,7 @@ exp=$jobname # Set path/file for gsi executable #basedir=/scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken #gsiexec=$gsiexec -#gsiexec=$basedir/EXP-port/src/global_gsi +#gsiexec=$basedir/EXP-port/src/global_gsi.x # Set the JCAP resolution which you want. @@ -22,10 +22,7 @@ tmpdir=$tmpdir/$tmpregdir/${exp} savdir=$savdir/out${JCAP}/${exp} # Specify GSI fixed field and data directories. -#fixgsi=$fixgsi -#fixgsi=$basedir/EXP-port/fix -#fixcrtm=$fixcrtm -#fixcrtm=$basedir/nwprod/lib/sorc/CRTM_REL-2.2.3/Big_Endian +fixcrtm=${fixcrtm:-$CRTM_FIX} #datobs=$datobs #datobs=/scratch1/portfolios/NCEPDEV/da/noscrub/Michael.Lueken/CASES/sigmap/$adate @@ -80,7 +77,8 @@ prefix_prep=$prefix_obs prefix_tbc=gdas1.t${hhg}z prefix_sfc=gdas${resol}.t${hhg}z prefix_atm=gdas${resol}.t${hha}z -suffix=tm00.bufr_d +suffix_obs=gdas.${global_T62_adate} +suffix_bias=gdas.${gdate} # Set up $tmpdir @@ -305,6 +303,19 @@ $ncp $btable_uv ./btable_uv $ncp $bufrtable ./prepobs_prep.bufrtable $ncp $bftab_sst ./bftab_sstphr +#if using correlated error, link to the covariance files +#if grep -q "Rcov" $anavinfo ; +#then +# if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; +# then +# $ncp ${fixgsi}/Rcov* . +# else +# echo "Warning: Satellite error covariance files are missing." +# echo "Check for the required Rcov files in " $anavinfo +# exit 1 +# fi +#fi + # Copy CRTM coefficient files based on entries in satinfo file for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do $ncp $fixcrtm/${file}.SpcCoeff.bin ./ @@ -313,43 +324,42 @@ done # Copy observational data to $tmpdir -ln -s -f $global_T62_obs/${prefix_obs}prepbufr ./prepbufr -ln -s -f $global_T62_obs/${prefix_obs}satwnd.${suffix} ./satwndbufr -ln -s -f $global_T62_obs/${prefix_obs}gpsro.${suffix} ./gpsrobufr -ln -s -f $global_T62_obs/${prefix_obs}spssmi.${suffix} ./ssmirrbufr -ln -s -f $global_T62_obs/${prefix_obs}sptrmm.${suffix} ./tmirrbufr -ln -s -f $global_T62_obs/${prefix_obs}gome.${suffix} ./gomebufr -ln -s -f $global_T62_obs/${prefix_obs}omi.${suffix} ./omibufr -ln -s -f $global_T62_obs/${prefix_obs}mls.${suffix} ./mlsbufr -ln -s -f $global_T62_obs/${prefix_obs}osbuv8.${suffix} ./sbuvbufr -ln -s -f $global_T62_obs/${prefix_obs}goesfv.${suffix} ./gsnd1bufr -ln -s -f $global_T62_obs/${prefix_obs}1bamua.${suffix} ./amsuabufr -ln -s -f $global_T62_obs/${prefix_obs}1bamub.${suffix} ./amsubbufr -ln -s -f $global_T62_obs/${prefix_obs}1bhrs2.${suffix} ./hirs2bufr -ln -s -f $global_T62_obs/${prefix_obs}1bhrs3.${suffix} ./hirs3bufr -ln -s -f $global_T62_obs/${prefix_obs}1bhrs4.${suffix} ./hirs4bufr -ln -s -f $global_T62_obs/${prefix_obs}1bmhs.${suffix} ./mhsbufr -ln -s -f $global_T62_obs/${prefix_obs}1bmsu.${suffix} ./msubufr -ln -s -f $global_T62_obs/${prefix_obs}airsev.${suffix} ./airsbufr -ln -s -f $global_T62_obs/${prefix_obs}sevcsr.${suffix} ./seviribufr -ln -s -f $global_T62_obs/${prefix_obs}mtiasi.${suffix} ./iasibufr -ln -s -f $global_T62_obs/${prefix_obs}esamua.${suffix} ./amsuabufrears -ln -s -f $global_T62_obs/${prefix_obs}esamub.${suffix} ./amsubbufrears -ln -s -f $global_T62_obs/${prefix_obs}eshrs3.${suffix} ./hirs3bufrears -ln -s -f $global_T62_obs/${prefix_obs}ssmit.${suffix} ./ssmitbufr -ln -s -f $global_T62_obs/${prefix_obs}amsre.${suffix} ./amsrebufr -ln -s -f $global_T62_obs/${prefix_obs}ssmis.${suffix} ./ssmisbufr -ln -s -f $global_T62_obs/${prefix_obs}atms.${suffix} ./atmsbufr -ln -s -f $global_T62_obs/${prefix_obs}cris.${suffix} ./crisbufr -ln -s -f $global_T62_obs/${prefix_obs}crisf4.${suffix} ./crisfsbufr -ln -s -f $global_T62_obs/${prefix_obs}syndata.tcvitals.tm00 ./tcvitl +ln -s -f $global_T62_obs/prepqc.${suffix_obs} ./prepbufr +ln -s -f $global_T62_obs/satwnd.${suffix_obs} ./satwndbufr +ln -s -f $global_T62_obs/gpsro.${suffix_obs} ./gpsrobufr +ln -s -f $global_T62_obs/spssmi.${suffix_obs} ./ssmirrbufr +ln -s -f $global_T62_obs/sptrmm.${suffix_obs} ./tmirrbufr +ln -s -f $global_T62_obs/gome.${suffix_obs} ./gomebufr +ln -s -f $global_T62_obs/omi.${suffix_obs} ./omibufr +ln -s -f $global_T62_obs/mls.${suffix_obs} ./mlsbufr +ln -s -f $global_T62_obs/osbuv8.${suffix_obs} ./sbuvbufr +ln -s -f $global_T62_obs/goesfv.${suffix_obs} ./gsnd1bufr +ln -s -f $global_T62_obs/1bamua.${suffix_obs} ./amsuabufr +ln -s -f $global_T62_obs/1bamub.${suffix_obs} ./amsubbufr +ln -s -f $global_T62_obs/1bhrs2.${suffix_obs} ./hirs2bufr +ln -s -f $global_T62_obs/1bhrs3.${suffix_obs} ./hirs3bufr +ln -s -f $global_T62_obs/1bhrs4.${suffix_obs} ./hirs4bufr +ln -s -f $global_T62_obs/1bmhs.${suffix_obs} ./mhsbufr +ln -s -f $global_T62_obs/1bmsu.${suffix_obs} ./msubufr +ln -s -f $global_T62_obs/airsev.${suffix_obs} ./airsbufr +ln -s -f $global_T62_obs/sevcsr.${suffix_obs} ./seviribufr +ln -s -f $global_T62_obs/mtiasi.${suffix_obs} ./iasibufr +ln -s -f $global_T62_obs/esamua.${suffix_obs} ./amsuabufrears +ln -s -f $global_T62_obs/esamub.${suffix_obs} ./amsubbufrears +ln -s -f $global_T62_obs/eshrs3.${suffix_obs} ./hirs3bufrears +ln -s -f $global_T62_obs/ssmit.${suffix_obs} ./ssmitbufr +ln -s -f $global_T62_obs/amsre.${suffix_obs} ./amsrebufr +ln -s -f $global_T62_obs/ssmis.${suffix_obs} ./ssmisbufr +ln -s -f $global_T62_obs/atms.${suffix_obs} ./atmsbufr +ln -s -f $global_T62_obs/cris.${suffix_obs} ./crisbufr +ln -s -f $global_T62_obs/crisf4.${suffix_obs} ./crisfsbufr +ln -s -f $global_T62_obs/tcvitl.${suffix_obs} ./tcvitl # Copy bias correction, atmospheric and surface files -ln -s -f $global_T62_ges/${prefix_tbc}.abias ./satbias_in -ln -s -f $global_T62_ges/${prefix_tbc}.abias_pc ./satbias_pc -ln -s -f $global_T62_ges/${prefix_tbc}.satang ./satbias_angle -ln -s -f $global_T62_ges/${prefix_tbc}.radstat ./radstat.gdas +ln -s -f $global_T62_ges/biascr.${suffix_bias} ./satbias_in +ln -s -f $global_T62_ges/biascr_pc.${suffix_bias} ./satbias_pc +ln -s -f $global_T62_ges/radstat.${suffix_bias} ./radstat.gdas listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges` for type in $listdiag; do diff --git a/regression/global_T62_ozonly.sh b/regression/global_T62_ozonly.sh index 8fa7f77ef..8fb9e3d3d 100755 --- a/regression/global_T62_ozonly.sh +++ b/regression/global_T62_ozonly.sh @@ -8,7 +8,7 @@ exp=$jobname # Set path/file for gsi executable #basedir=/scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken #gsiexec=$gsiexec -#gsiexec=$basedir/EXP-port/src/global_gsi +#gsiexec=$basedir/EXP-port/src/global_gsi.x # Set the JCAP resolution which you want. @@ -22,10 +22,7 @@ tmpdir=$tmpdir/$tmpregdir/${exp} savdir=$savdir/out${JCAP}_ozonly/${exp} # Specify GSI fixed field and data directories. -#fixgsi=$fixgsi -#fixgsi=$basedir/EXP-port/fix -#fixcrtm=$fixcrtm -#fixcrtm=$basedir/nwprod/lib/sorc/CRTM_REL-2.2.3/Big_Endian +fixcrtm=${fixcrtm:-$CRTM_FIX} #datobs=$datobs #datobs=/scratch1/portfolios/NCEPDEV/da/noscrub/Michael.Lueken/CASES/sigmap/$adate @@ -80,7 +77,8 @@ prefix_prep=$prefix_obs prefix_tbc=gdas1.t${hhg}z prefix_sfc=gdas${resol}.t${hhg}z prefix_atm=gdas${resol}.t${hha}z -suffix=tm00.bufr_d +suffix_obs=gdas.${global_T62_adate} +suffix_bias=gdas.${gdate} # Set up $tmpdir @@ -308,15 +306,15 @@ done # Copy observational data to $tmpdir -ln -s -f $global_T62_obs/${prefix_obs}prepbufr ./prepbufr +ln -s -f $global_T62_obs/prepqc.${suffix_obs} ./prepbufr #ln -s -f $global_T62_obs/${prefix_obs}satwnd.${suffix} ./satwndbufr #ln -s -f $global_T62_obs/${prefix_obs}gpsro.${suffix} ./gpsrobufr #ln -s -f $global_T62_obs/${prefix_obs}spssmi.${suffix} ./ssmirrbufr #ln -s -f $global_T62_obs/${prefix_obs}sptrmm.${suffix} ./tmirrbufr -ln -s -f $global_T62_obs/${prefix_obs}gome.${suffix} ./gomebufr -ln -s -f $global_T62_obs/${prefix_obs}omi.${suffix} ./omibufr -ln -s -f $global_T62_obs/${prefix_obs}mls.${suffix} ./mlsbufr -ln -s -f $global_T62_obs/${prefix_obs}osbuv8.${suffix} ./sbuvbufr +ln -s -f $global_T62_obs/gome.${suffix_obs} ./gomebufr +ln -s -f $global_T62_obs/omi.${suffix_obs} ./omibufr +ln -s -f $global_T62_obs/mls.${suffix_obs} ./mlsbufr +ln -s -f $global_T62_obs/osbuv8.${suffix_obs} ./sbuvbufr #ln -s -f $global_T62_obs/${prefix_obs}goesfv.${suffix} ./gsnd1bufr #ln -s -f $global_T62_obs/${prefix_obs}1bamua.${suffix} ./amsuabufr #ln -s -f $global_T62_obs/${prefix_obs}1bamub.${suffix} ./amsubbufr @@ -338,10 +336,9 @@ ln -s -f $global_T62_obs/${prefix_obs}osbuv8.${suffix} ./sbuvbufr # Copy bias correction, atmospheric and surface files -ln -s -f $global_T62_ges/${prefix_tbc}.abias ./satbias_in -ln -s -f $global_T62_ges/${prefix_tbc}.abias_pc ./satbias_pc -ln -s -f $global_T62_ges/${prefix_tbc}.satang ./satbias_angle -ln -s -f $global_T62_ges/${prefix_tbc}.radstat ./radstat.gdas +ln -s -f $global_T62_ges/biascr.${suffix_bias} ./satbias_in +ln -s -f $global_T62_ges/biascr_pc.${suffix_bias} ./satbias_pc +ln -s -f $global_T62_ges/radstat.${suffix_bias} ./radstat.gdas listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges` for type in $listdiag; do diff --git a/regression/global_enkf_T62.sh b/regression/global_enkf_T62.sh index 04a2ec935..54c75dbab 100755 --- a/regression/global_enkf_T62.sh +++ b/regression/global_enkf_T62.sh @@ -11,7 +11,6 @@ exp=$jobname export JCAP=62 export LEVS=64 export NMEM_ENKF=20 -export NVARS=6 # Set runtime and save directories tmpdir=$tmpdir/$tmpregdir/${exp} @@ -89,6 +88,7 @@ $gsi_namelist EOF # Set fixed files +# anavinfo = text file with information about control vector # satinfo = text file with information about assimilation of brightness temperatures # satangl = angle dependent bias correction file (fixed in time) # scaninfo = text file with scan angle information @@ -102,6 +102,7 @@ satinfo=$fixgsi/global_satinfo.txt convinfo=$fixgsi/global_convinfo_reg_test.txt ozinfo=$fixgsi/global_ozinfo.txt hybens_info=$fixgsi/global_hybens_info.l64.txt +anavinfo=$fixgsi/global_anavinfo.l64.txt ### add 9 tables errtable_pw=$fixgsi/prepobs_errtable_pw.global errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf @@ -128,6 +129,8 @@ $ncp $satinfo ./satinfo $ncp $ozinfo ./ozinfo $ncp $convinfo ./convinfo $ncp $hybens_info ./hybens_info +$ncp $anavinfo ./anavinfo + #add 9 tables for new varqc $ncp $errtable_pw ./errtable_pw $ncp $errtable_ps ./errtable_ps @@ -139,10 +142,9 @@ $ncp $btable_t ./btable_t $ncp $btable_q ./btable_q $ncp $btable_uv ./btable_uv - - # Copy ensemble data to $tmpdir list="cnvstat oznstat radstat" + for type in $list; do $ncp $global_enkf_T62_datobs/${type}_${adate}_ensmean ./${type}_ensmean tar -xvf ${type}_ensmean @@ -170,6 +172,7 @@ $ncp $global_enkf_T62_datges/bfg_${gdate}_fhr06_ensmean ./bfg_${global_enkf_T62_ cd $tmpdir echo "run enkf now" -eval "$APRUN $tmpdir/enkf.x > stdout 2>&1" +\rm stdout stderr +eval "$APRUN $tmpdir/enkf.x 1>stdout 2>stderr" rc=$? exit $rc diff --git a/regression/global_fv3_4denvar_T126.sh b/regression/global_fv3_4denvar_T126.sh new file mode 100755 index 000000000..ae02aee52 --- /dev/null +++ b/regression/global_fv3_4denvar_T126.sh @@ -0,0 +1,429 @@ + +set -x + +# Set experiment name and analysis date + +exp=$jobname + +# Set path/file for gsi executable +#basedir=/scratch1/portfolios/NCEPDEV/da/save/Daryl.Kleist +#gsipath=$basedir/gsi/ +#gsiexec=$gsipath/trunk/src/global_gsi.x + +# Set the JCAP resolution which you want. +# All resolutions use LEVS=64 +export JCAP=62 +export LEVS=64 +export JCAP_B=126 +export JCAP_EN=62 + +# Set runtime and save directories +tmpdir=$tmpdir/$tmpregdir/${exp} +savdir=$savdir/out${JCAP}/${exp} + +# Specify GSI fixed field and data directories. +fixcrtm=${fixcrtm:-$CRTM_FIX} + + +# Set variables used in script +# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) +# ncp is cp replacement, currently keep as /bin/cp + +UNCOMPRESS=gunzip +CLEAN=NO +ncp=/bin/cp +ncpl="ln -fs" + + +# Given the requested resolution, set dependent resolution parameters +if [[ "$JCAP" = "670" ]]; then + export LONA=1344 + export LATA=672 + export DELTIM=100 + export resol=1 +elif [[ "$JCAP" = "574" ]]; then + export LONA=1152 + export LATA=576 + export DELTIM=120 + export resol=1 +elif [[ "$JCAP" = "382" ]]; then + export LONA=768 + export LATA=384 + export DELTIM=180 + export resol=1 +elif [[ "$JCAP" = "126" ]]; then + export LONA=384 + export LATA=190 + export DELTIM=600 + export resol=2 +elif [[ "$JCAP" = "62" ]]; then + export LONA=192 + export LATA=94 + export DELTIM=1200 + export resol=2 +else + echo "INVALID JCAP = $JCAP" + exit +fi +export NLAT=$((${LATA}+2)) + +# Size of ensemble +ENS_NUM_ANAL=20 +ENSBEG=1 +ENSEND=20 + +# Given the analysis date, compute the date from which the +# first guess comes. Extract cycle and set prefix and suffix +# for guess and observation data files +PDY=`echo $global_fv3_4denvar_T126_adate | cut -c1-8` +cyc=`echo $global_fv3_4denvar_T126_adate | cut -c9-10` +GDATE=`$ndate -06 $global_fv3_4denvar_T126_adate` +gPDY=`echo $GDATE | cut -c1-8` +gcyc=`echo $GDATE | cut -c9-10` + +dumpobs=gdas +prefix_obs=${dumpobs}.t${cyc}z +prefix_ges=gdas.t${gcyc}z +prefix_ens=gdas.t${gcyc}z +suffix=tm00.bufr_d + +datobs=$global_fv3_4denvar_T126_datobs/gdas.$PDY/$cyc +datanl=$global_fv3_4denvar_T126_datobs/gdas.$PDY/$cyc +datges=$global_fv3_4denvar_T126_datges/gdas.$gPDY/$gcyc +datens=$global_fv3_4denvar_T126_datges/enkfgdas.$gPDY/$gcyc + + +# Set up $tmpdir +rm -rf $tmpdir +mkdir -p $tmpdir +cd $tmpdir +rm -rf core* + +# CO2 namelist and file decisions +ICO2=${ICO2:-0} +if [ $ICO2 -gt 0 ] ; then + # Copy co2 files to $tmpdir + co2dir=${CO2DIR:-$fixgsi} + yyyy=$(echo ${CDATE:-$global_fv3_4denvar_T126_adate}|cut -c1-4) + rm ./global_co2_data.txt + co2=$co2dir/global_co2.gcmscl_$yyyy.txt + while [ ! -s $co2 ] ; do + ((yyyy-=1)) + co2=$co2dir/global_co2.gcmscl_$yyyy.txt + done + if [ -s $co2 ] ; then + $ncp $co2 ./global_co2_data.txt + fi + if [ ! -s ./global_co2_data.txt ] ; then + echo "\./global_co2_data.txt" not created + exit 1 + fi +fi +#CH4 file decision +ICH4=${ICH4:-0} +if [ $ICH4 -gt 0 ] ; then +# # Copy ch4 files to $tmpdir + ch4dir=${CH4DIR:-$fixgsi} + yyyy=$(echo ${CDATE:-$global_fv3_4denvar_T126_adate}|cut -c1-4) + rm ./ch4globaldata.txt + ch4=$ch4dir/global_ch4_esrlctm_$yyyy.txt + while [ ! -s $ch4 ] ; do + ((yyyy-=1)) + ch4=$ch4dir/global_ch4_esrlctm_$yyyy.txt + done + if [ -s $ch4 ] ; then + $ncp $ch4 ./ch4globaldata.txt + fi + if [ ! -s ./ch4globaldata.txt ] ; then + echo "\./ch4globaldata.txt" not created + exit 1 + fi +fi +IN2O=${IN2O:-0} +if [ $IN2O -gt 0 ] ; then +# # Copy ch4 files to $tmpdir + n2odir=${N2ODIR:-$fixgsi} + yyyy=$(echo ${CDATE:-$global_fv3_4denvar_T126_adate}|cut -c1-4) + rm ./n2oglobaldata.txt + n2o=$n2odir/global_n2o_esrlctm_$yyyy.txt + while [ ! -s $n2o ] ; do + ((yyyy-=1)) + n2o=$n2odir/global_n2o_esrlctm_$yyyy.txt + done + if [ -s $n2o ] ; then + $ncp $n2o ./n2oglobaldata.txt + fi + if [ ! -s ./n2oglobaldata.txt ] ; then + echo "\./n2oglobaldata.txt" not created + exit 1 + fi +fi +ICO=${ICO:-0} +if [ $ICO -gt 0 ] ; then +# # Copy CO files to $tmpdir + codir=${CODIR:-$fixgsi} + yyyy=$(echo ${CDATE:-$global_fv3_4denvar_T126_adate}|cut -c1-4) + rm ./coglobaldata.txt + co=$codir/global_co_esrlctm_$yyyy.txt + while [ ! -s $co ] ; do + ((yyyy-=1)) + co=$codir/global_co_esrlctm_$yyyy.txt + done + if [ -s $co ] ; then + $ncp $co ./coglobaldata.txt + fi + if [ ! -s ./coglobaldata.txt ] ; then + echo "\./coglobaldata.txt" not created + exit 1 + fi +fi + +# Make gsi namelist + +. $scripts/regression_nl_update.sh + +SETUP="$SETUP_update" +GRIDOPTS="$GRIDOPTS_update" +BKGVERR="$BKGVERR_update" +ANBKGERR="$ANBKERR_update" +JCOPTS="$JCOPTS_update" +STRONGOPTS="$STRONGOPTS_update" +OBSQC="$OBSQC_update" +OBSINPUT="$OBSINPUT_update" +SUPERRAD="$SUPERRAD_update" +SINGLEOB="$SINGLEOB_update" + +if [ "$debug" = ".false." ]; then + . $scripts/regression_namelists.sh global_fv3_4denvar_T126 +else + . $scripts/regression_namelists_db.sh global_fv3_4denvar_T126 +fi + +cat << EOF > gsiparm.anl + +$gsi_namelist + +EOF + +# Set fixed files +# berror = forecast model background error statistics +# specoef = CRTM spectral coefficients +# trncoef = CRTM transmittance coefficients +# emiscoef = CRTM coefficients for IR sea surface emissivity model +# aerocoef = CRTM coefficients for aerosol effects +# cldcoef = CRTM coefficients for cloud effects +# satinfo = text file with information about assimilation of brightness temperatures +# satangl = angle dependent bias correction file (fixed in time) +# pcpinfo = text file with information about assimilation of prepcipitation rates +# ozinfo = text file with information about assimilation of ozone data +# errtable = text file with obs error for conventional data (optional) +# convinfo = text file with information about assimilation of conventional data +# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.) +# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.) + +berror=$fixgsi/Big_Endian/global_berror.l${LEVS}y${NLAT}.f77 + +emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin +emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin +emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin +emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin +emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin +emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin +emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin +emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin +emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin +aercoef=$fixcrtm/AerosolCoeff.bin +cldcoef=$fixcrtm/CloudCoeff.bin +satangl=$fixgsi/global_satangbias.txt +scaninfo=$fixgsi/global_scaninfo.txt +satinfo=$fixgsi/global_satinfo.txt +cloudyinfo=$fixgsi/cloudy_radiance_info.txt +convinfo=$fixgsi/global_convinfo_reg_test.txt +insituinfo=$fixgsi/global_insituinfo.txt +### add 9 tables +errtable_pw=$fixgsi/prepobs_errtable_pw.global +errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf +errtable_t=$fixgsi/prepobs_errtable_t.global_nqcf +errtable_q=$fixgsi/prepobs_errtable_q.global_nqcf +errtable_uv=$fixgsi/prepobs_errtable_uv.global_nqcf +btable_ps=$fixgsi/nqc_b_ps.global_nqcf +btable_t=$fixgsi/nqc_b_t.global_nqcf +btable_q=$fixgsi/nqc_b_q.global_nqcf +btable_uv=$fixgsi/nqc_b_uv.global_nqcf + +anavinfo=$fixgsi/global_anavinfo.l64.txt +ozinfo=$fixgsi/global_ozinfo.txt +pcpinfo=$fixgsi/global_pcpinfo.txt +errtable=$fixgsi/prepobs_errtable.global +hybens_info=$fixgsi/global_hybens_info.l64.txt +atmsbeamdat=$fixgsi/atms_beamwidth.txt + +# Only need this file for single obs test +bufrtable=$fixgsi/prepobs_prep.bufrtable + +# Only need this file for sst retrieval +bftab_sst=$fixgsi/bufrtab.012 + +# Copy executable and fixed files to $tmpdir +if [[ $exp == *"updat"* ]]; then + $ncp $gsiexec_updat ./gsi.x +elif [[ $exp == *"contrl"* ]]; then + $ncp $gsiexec_contrl ./gsi.x +fi + +$ncp $berror ./berror_stats +$ncp $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin +$ncp $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin +$ncp $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin +$ncp $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin +$ncp $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin +$ncp $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin +$ncp $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin +$ncp $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin +$ncp $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin +$ncp $aercoef ./AerosolCoeff.bin +$ncp $cldcoef ./CloudCoeff.bin +$ncp $satangl ./satbias_angle +$ncp $atmsbeamdat ./atms_beamwidth.txt +$ncp $scaninfo ./scaninfo +$ncp $satinfo ./satinfo +$ncp $cloudyinfo ./cloudy_radiance_info.txt +$ncp $pcpinfo ./pcpinfo +$ncp $ozinfo ./ozinfo +$ncp $convinfo ./convinfo +$ncp $insituinfo ./insituinfo +$ncp $errtable ./errtable +$ncp $anavinfo ./anavinfo +$ncp $hybens_info ./hybens_info +#add 9 tables for new varqc +$ncp $errtable_pw ./errtable_pw +$ncp $errtable_ps ./errtable_ps +$ncp $errtable_t ./errtable_t +$ncp $errtable_q ./errtable_q +$ncp $errtable_uv ./errtable_uv +$ncp $btable_ps ./btable_ps +$ncp $btable_t ./btable_t +$ncp $btable_q ./btable_q +$ncp $btable_uv ./btable_uv + + +$ncp $bufrtable ./prepobs_prep.bufrtable +$ncp $bftab_sst ./bftab_sstphr + +#if using correlated error, link to the covariance files +if grep -q "Rcov" $anavinfo ; +then + if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; + then + $ncp ${fixgsi}/Rcov* . + else + echo "Warning: Satellite error covariance files are missing." + echo "Check for the required Rcov files in " $anavinfo + exit 1 + fi +fi + +# Copy CRTM coefficient files based on entries in satinfo file +for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do + $ncp $fixcrtm/${file}.SpcCoeff.bin ./ + $ncp $fixcrtm/${file}.TauCoeff.bin ./ +done + +# Copy observational data to $DATA +$ncpl $datanl/${prefix_obs}.prepbufr ./prepbufr +$ncpl $datanl/${prefix_obs}.prepbufr.acft_profiles ./prepbufr_profl +$ncpl $datanl/${prefix_obs}.nsstbufr ./nsstbufr +$ncpl $datobs/${prefix_obs}.gpsro.${suffix} ./gpsrobufr +$ncpl $datobs/${prefix_obs}.satwnd.${suffix} ./satwndbufr +$ncpl $datobs/${prefix_obs}.spssmi.${suffix} ./ssmirrbufr +$ncpl $datobs/${prefix_obs}.sptrmm.${suffix} ./tmirrbufr +$ncpl $datobs/${prefix_obs}.osbuv8.${suffix} ./sbuvbufr +$ncpl $datobs/${prefix_obs}.goesfv.${suffix} ./gsnd1bufr +$ncpl $datobs/${prefix_obs}.1bamua.${suffix} ./amsuabufr +$ncpl $datobs/${prefix_obs}.1bamub.${suffix} ./amsubbufr +$ncpl $datobs/${prefix_obs}.1bhrs2.${suffix} ./hirs2bufr +$ncpl $datobs/${prefix_obs}.1bhrs3.${suffix} ./hirs3bufr +$ncpl $datobs/${prefix_obs}.1bhrs4.${suffix} ./hirs4bufr +$ncpl $datobs/${prefix_obs}.1bmhs.${suffix} ./mhsbufr +$ncpl $datobs/${prefix_obs}.1bmsu.${suffix} ./msubufr +$ncpl $datobs/${prefix_obs}.airsev.${suffix} ./airsbufr +$ncpl $datobs/${prefix_obs}.sevcsr.${suffix} ./seviribufr +$ncpl $datobs/${prefix_obs}.mtiasi.${suffix} ./iasibufr +$ncpl $datobs/${prefix_obs}.ssmit.${suffix} ./ssmitbufr +$ncpl $datobs/${prefix_obs}.ssmisu.${suffix} ./ssmisbufr +$ncpl $datobs/${prefix_obs}.gome.${suffix} ./gomebufr +$ncpl $datobs/${prefix_obs}.omi.${suffix} ./omibufr +$ncpl $datobs/${prefix_obs}.mls.${suffix} ./mlsbufr +$ncpl $datobs/${prefix_obs}.eshrs3.${suffix} ./hirs3bufrears +$ncpl $datobs/${prefix_obs}.esamua.${suffix} ./amsuabufrears +$ncpl $datobs/${prefix_obs}.esamub.${suffix} ./amsubbufrears +$ncpl $datobs/${prefix_obs}.atms.${suffix} ./atmsbufr +$ncpl $datobs/${prefix_obs}.cris.${suffix} ./crisbufr +$ncpl $datobs/${prefix_obs}.crisf4.${suffix} ./crisfsbufr +$ncpl $datobs/${prefix_obs}.syndata.tcvitals.tm00 ./tcvitl +$ncpl $datobs/${prefix_obs}.avcsam.${suffix} ./avhambufr +$ncpl $datobs/${prefix_obs}.avcspm.${suffix} ./avhpmbufr +$ncpl $datobs/${prefix_obs}.saphir.${suffix} ./saphirbufr +$ncpl $datobs/${prefix_obs}.gmi1cr.${suffix} ./gmibufr +if [ "$debug" = ".false." ]; then + $ncpl $datobs/${prefix_obs}.esiasi.${suffix} ./iasibufrears +fi +$ncpl $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db +$ncpl $datobs/${prefix_obs}.amuadb.${suffix} ./amsuabufr_db +$ncpl $datobs/${prefix_obs}.amubdb.${suffix} ./amsubbufr_db +$ncpl $datobs/${prefix_obs}.iasidb.${suffix} ./iasibufr_db +$ncpl $datobs/${prefix_obs}.crisdb.${suffix} ./crisbufr_db +$ncpl $datobs/${prefix_obs}.atmsdb.${suffix} ./atmsbufr_db +$ncpl $datobs/${prefix_obs}.escris.${suffix} ./crisbufrears +$ncpl $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears + +# Copy bias correction, atmospheric and surface files +$ncpl $datges/${prefix_ges}.abias ./satbias_in +$ncpl $datges/${prefix_ges}.abias_pc ./satbias_pc +$ncpl $datges/${prefix_ges}.abias_air ./aircftbias_in + +flist="03 04 05 06 07 08 09" +for fh in $flist; do + $ncpl $datges/${prefix_ges}.sfcf0$fh.nemsio ./sfcf$fh + $ncpl $datges/${prefix_ges}.atmf0$fh.nemsio ./sigf$fh +done + + +ensemble_path="./ensemble_data/" +mkdir -p $ensemble_path +enkf_suffix="s" +flist="03 04 05 06 07 08 09" +for fh in $flist; do + sigens=${prefix_ens}.atmf0${fh}${enkf_suffix}.nemsio + + imem=$ENSBEG + imemloc=1 + while [[ $imem -le $ENSEND ]]; do + member="mem"`printf %03i $imem` + memloc="mem"`printf %03i $imemloc` + $ncpl $datens/$member/$sigens ${ensemble_path}sigf${fh}_ens_${memloc} + (( imem = $imem + 1 )) + (( imemloc = $imemloc + 1 )) + done +done + +$ncpl $datens/${prefix_ens}.sfcf006.ensmean.nemsio ./sfcf06_anlgrid + +$ncpl $datges/${prefix_ges}.radstat ./radstat.gdas +listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges` +for type in $listdiag; do + diag_file=`echo $type | cut -d',' -f1` + fname=`echo $diag_file | cut -d'.' -f1` + date=`echo $diag_file | cut -d'.' -f2` + $UNCOMPRESS $diag_file + fnameanl=$(echo $fname|sed 's/_ges//g') + mv $fname.$date $fnameanl +done + + +# Run GSI +cd $tmpdir +echo "run gsi now" +eval "$APRUN $tmpdir/gsi.x > stdout 2>&1" +rc=$? +exit $rc diff --git a/regression/global_hybrid_T126.sh b/regression/global_hybrid_T126.sh index 352436289..05486987e 100755 --- a/regression/global_hybrid_T126.sh +++ b/regression/global_hybrid_T126.sh @@ -8,7 +8,7 @@ exp=$jobname # Set path/file for gsi executable #basedir=/scratch1/portfolios/NCEPDEV/da/save/Daryl.Kleist #gsipath=$basedir/gsi/ -#gsiexec=$gsipath/trunk/src/global_gsi +#gsiexec=$gsipath/trunk/src/global_gsi.x # Set the JCAP resolution which you want. # All resolutions use LEVS=64 @@ -22,8 +22,7 @@ tmpdir=$tmpdir/$tmpregdir/${exp} savdir=$savdir/out${JCAP}/${exp} # Specify GSI fixed field and data directories. -#fixgsi=$gsipath/trunk/fix -#fixcrtm=$gsipath/EXP-port410/lib/CRTM_REL-2.2.3/fix +fixcrtm=${fixcrtm:-$CRTM_FIX} #datobs=/scratch1/portfolios/NCEPDEV/da/noscrub/Daryl.Kleist/CASES/$adate/obs #datges=/scratch1/portfolios/NCEPDEV/da/noscrub/Daryl.Kleist/CASES/$adate/ges @@ -289,6 +288,19 @@ $ncp $btable_uv ./btable_uv $ncp $bufrtable ./prepobs_prep.bufrtable $ncp $bftab_sst ./bftab_sstphr +#if using correlated error, link to the covariance files +#if grep -q "Rcov" $anavinfo ; +#then +# if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; +# then +# $ncp ${fixgsi}/Rcov* . +# else +# echo "Warning: Satellite error covariance files are missing." +# echo "Check for the required Rcov files in " $anavinfo +# exit 1 +# fi +#fi + # Copy CRTM coefficient files based on entries in satinfo file for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do $ncp $fixcrtm/${file}.SpcCoeff.bin ./ diff --git a/regression/global_lanczos_T62.sh b/regression/global_lanczos_T62.sh index d1512d00e..9a9c37694 100755 --- a/regression/global_lanczos_T62.sh +++ b/regression/global_lanczos_T62.sh @@ -15,7 +15,7 @@ tmpdir=$tmpdir/$tmpregdir/${exp} savdir=$savdir/lanczos_out${JCAP}/sigmap/${exp} # Specify GSI fixed field and data directories. - +fixcrtm=${fixcrtm:-$CRTM_FIX} # Set variables used in script # CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) @@ -276,6 +276,19 @@ $ncp $btable_uv ./btable_uv $ncp $bufrtable ./prepobs_prep.bufrtable $ncp $bftab_sst ./bftab_sstphr +#if using correlated error, link to the covariance files +#if grep -q "Rcov" $anavinfo ; +#then +# if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; +# then +# $ncp ${fixgsi}/Rcov* . +# else +# echo "Warning: Satellite error covariance files are missing." +# echo "Check for the required Rcov files in " $anavinfo +# exit 1 +# fi +#fi + # Copy CRTM coefficient files based on entries in satinfo file for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do $ncp $fixcrtm/${file}.SpcCoeff.bin ./ diff --git a/regression/global_nemsio_T62.sh b/regression/global_nemsio_T62.sh index d959cfa5c..676db8d64 100755 --- a/regression/global_nemsio_T62.sh +++ b/regression/global_nemsio_T62.sh @@ -15,7 +15,7 @@ tmpdir=$tmpdir/$tmpregdir/${exp} savdir=$savdir/nemsio_out${JCAP}/sigmap/${exp} # Specify GSI fixed field and data directories. - +fixcrtm=${fixcrtm:-$CRTM_FIX} # Set variables used in script # CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) @@ -279,6 +279,19 @@ $ncp $btable_uv ./btable_uv $ncp $bufrtable ./prepobs_prep.bufrtable $ncp $bftab_sst ./bftab_sstphr +#if using correlated error, link to the covariance files +#if grep -q "Rcov" $anavinfo ; +#then +# if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; +# then +# $ncp ${fixgsi}/Rcov* . +# else +# echo "Warning: Satellite error covariance files are missing." +# echo "Check for the required Rcov files in " $anavinfo +# exit 1 +# fi +#fi + # Copy CRTM coefficient files based on entries in satinfo file for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do $ncp $fixcrtm/${file}.SpcCoeff.bin ./ diff --git a/regression/hwrf_nmm_d2.sh b/regression/hwrf_nmm_d2.sh index 0ffd26573..26536062d 100755 --- a/regression/hwrf_nmm_d2.sh +++ b/regression/hwrf_nmm_d2.sh @@ -36,7 +36,7 @@ tmpdir=$tmpdir/tmpreg_hwrf_nmm_d2/${exp} savdir=$savdir/outreg_hwrf_nmm_d2/${exp} # Specify GSI fixed field and data directories. -#fixgsi=$fixgsi +fixcrtm=${fixcrtm:-$CRTM_FIX} #datobs=$datobs diff --git a/regression/hwrf_nmm_d3.sh b/regression/hwrf_nmm_d3.sh index 0ab388b73..2c015db0d 100755 --- a/regression/hwrf_nmm_d3.sh +++ b/regression/hwrf_nmm_d3.sh @@ -36,7 +36,7 @@ tmpdir=$tmpdir/tmpreg_hwrf_nmm_d3/${exp} savdir=$savdir/outreg_hwrf_nmm_d3/${exp} # Specify GSI fixed field and data directories. -#fixgsi=$fixgsi +fixcrtm=${fixcrtm:-$CRTM_FIX} #datobs=$datobs diff --git a/regression/multi_regression.sh b/regression/multi_regression.sh index c235e9fe9..5907ee08f 100755 --- a/regression/multi_regression.sh +++ b/regression/multi_regression.sh @@ -4,28 +4,34 @@ regtests_all="global_T62 global_T62_ozonly global_4dvar_T62 global_4denvar_T126 + global_fv3_4denvar_T126 global_lanczos_T62 arw_netcdf arw_binary nmm_binary nmm_netcdf nmmb_nems_4denvar + netcdf_fv3_regional hwrf_nmm_d2 hwrf_nmm_d3 rtma - global_enkf_T62" + global_enkf_T62 + global_C96_fv3aero" regtests_debug="global_T62 global_4dvar_T62 global_4denvar_T126 + global_fv3_4denvar_T126 global_lanczos_T62 arw_netcdf arw_binary nmm_binary nmm_netcdf nmmb_nems_4denvar + netcdf_fv3_regional hwrf_nmm_d2 - hwrf_nmm_d3" + hwrf_nmm_d3 + global_C96_fv3aero" # Choose which regression test to run; by default, run all regtests=${1:-$regtests_all} diff --git a/regression/netcdf_fv3_regional.sh b/regression/netcdf_fv3_regional.sh new file mode 100755 index 000000000..a6d18301e --- /dev/null +++ b/regression/netcdf_fv3_regional.sh @@ -0,0 +1,216 @@ + +set -x + +# Set analysis date +#adate=2015061000 + +# Set experiment name +exp=$jobname + +#TM=00 +#TM2=03 +#tmmark=tm${TM} + + +# Set path/file for gsi executable +#gsiexec=/meso/save/Wanshu.Wu/Code/trunk/trunk_40320/src/global_gsi_org +#gsiexec=/da/save/Michael.Lueken/trunk/src/global_gsi.x + +# Set runtime and save directories +tmpdir=$tmpdir/tmpreg_netcdf_fv3_regional/${exp} +savdir=$savdir/outreg_netcdf_fv3_regional/${exp} + +# Set variables used in script +# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) +# ncp is cp replacement, currently keep as /bin/cp + +UNCOMPRESS=gunzip +CLEAN=NO +ncp=/bin/cp + + +# Set up $tmpdir +rm -rf $tmpdir +mkdir -p $tmpdir +chgrp rstprod $tmpdir +chmod 750 $tmpdir +cd $tmpdir + +#FIXnam=/da/save/Michael.Lueken/trunk/fix +fixcrtm=${fixcrtm:-$CRTM_FIX} + +berror=$fixgsi/nam_nmm_berror.f77.gcv +anavinfo=$fixgsi/anavinfo_fv3 + + +# Make gsi namelist + +. $scripts/regression_nl_update.sh + +SETUP="$SETUP_update" +GRIDOPTS="$GRIDOPTS_update" +BKGVERR="$BKGVERR_update" +ANBKGERR="$ANBKERR_update" +JCOPTS="$JCOPTS_update" +STRONGOPTS="$STRONGOPTS_update" +OBSQC="$OBSQC_update" +OBSINPUT="$OBSINPUT_update" +SUPERRAD="$SUPERRAD_update" +HYBRID_ENSEMBLE='ensemble_path="",' +SINGLEOB="$SINGLEOB_update" + +if [ "$debug" = ".false." ]; then + . $scripts/regression_namelists.sh netcdf_fv3_regional +else + . $scripts/regression_namelists_db.sh netcdf_fv3_regional +fi + +# dmesh(1)=120.0,time_window_max=1.5,ext_sonde=.true., + +cat << EOF > gsiparm.anl + +$gsi_namelist + +EOF + +emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin +emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin +emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin +emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin +emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin +emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin +emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin +emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin +emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin +aercoef=$fixcrtm/AerosolCoeff.bin +cldcoef=$fixcrtm/CloudCoeff.bin +satinfo=$fixgsi/nam_regional_satinfo.txt +cloudyinfo=$fixgsi/cloudy_radiance_info.txt +scaninfo=$fixgsi/global_scaninfo.txt +pcpinfo=$fixgsi/nam_global_pcpinfo.txt +ozinfo=$fixgsi/nam_global_ozinfo.txt +errtable=$fixgsi/nam_errtable.r3dv +convinfo=$fixgsi/nam_regional_convinfo.txt +mesonetuselist=$fixgsi/nam_mesonet_uselist.txt +stnuselist=$fixgsi/nam_mesonet_stnuselist.txt +qdaylist=$fixgsi/rtma_q_day_rejectlist +qnightlist=$fixgsi/rtma_q_night_rejectlist +tdaylist=$fixgsi/rtma_t_day_rejectlist +tnightlist=$fixgsi/rtma_t_night_rejectlist +wbinuselist=$fixgsi/rtma_wbinuselist +locinfo=$fixgsi/nam_hybens_d01_locinfo +### add 9 tables +errtable_pw=$fixgsi/prepobs_errtable_pw.global +errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf +errtable_t=$fixgsi/prepobs_errtable_t.global_nqcf +errtable_q=$fixgsi/prepobs_errtable_q.global_nqcf +errtable_uv=$fixgsi/prepobs_errtable_uv.global_nqcf +btable_ps=$fixgsi/nqc_b_ps.global_nqcf +btable_t=$fixgsi/nqc_b_t.global_nqcf +btable_q=$fixgsi/nqc_b_q.global_nqcf +btable_uv=$fixgsi/nqc_b_uv.global_nqcf + +# add vertical profile of localization and beta_s,beta_e weights for hybrid ensemble runs +hybens_info=$fixgsi/nam_hybens_d01_info + + +# Copy executable and fixed files to $tmpdir +if [[ $exp == *"updat"* ]]; then + $ncp $gsiexec_updat ./gsi.x +elif [[ $exp == *"contrl"* ]]; then + $ncp $gsiexec_contrl ./gsi.x +fi + +cp $anavinfo ./anavinfo +cp $berror ./berror_stats +cp $errtable ./errtable +cp $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin +cp $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin +cp $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin +cp $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin +cp $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin +cp $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin +cp $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin +cp $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin +cp $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin +cp $aercoef ./AerosolCoeff.bin +cp $cldcoef ./CloudCoeff.bin +cp $satinfo ./satinfo +cp $cloudyinfo ./cloudy_radiance_info.txt +cp $scaninfo ./scaninfo +cp $pcpinfo ./pcpinfo +cp $ozinfo ./ozinfo +cp $convinfo ./convinfo +cp $mesonetuselist ./mesonetuselist +cp $stnuselist ./mesonet_stnuselist +cp $qdaylist ./q_day_rejectlist +cp $qnightlist ./q_night_rejectlist +cp $tdaylist ./t_day_rejectlist +cp $tnightlist ./t_night_rejectlist +cp $wbinuselist ./wbinuselist +#cp $locinfo ./hybens_info +#add 9 tables for new varqc +$ncp $errtable_pw ./errtable_pw +$ncp $errtable_ps ./errtable_ps +$ncp $errtable_t ./errtable_t +$ncp $errtable_q ./errtable_q +$ncp $errtable_uv ./errtable_uv +$ncp $btable_ps ./btable_ps +$ncp $btable_t ./btable_t +$ncp $btable_q ./btable_q +$ncp $btable_uv ./btable_uv + +$ncp $hybens_info ./hybens_info + + +###### crtm coeff's ####################### +set +x +for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do + cp $fixcrtm/${file}.SpcCoeff.bin ./ + cp $fixcrtm/${file}.TauCoeff.bin ./ +done +set -x + +PDY=`echo $adate | cut -c1-8` +CYC=`echo $adate | cut -c9-10` + +#datdir=/meso/noscrub/Wanshu.Wu/CASE/$adate + +cp $fv3_netcdf_obs/ndas.t06z.radwnd.tm06.bufr_d ./radarbufr +cp $fv3_netcdf_obs/ndas.t06z.prepbufr.tm06 ./prepbufr +cp $fv3_netcdf_obs/ndas.t06z.1bamua.tm06.bufr_d ./amsuabufr +cp $fv3_netcdf_obs/ndas.t06z.1bmhs.tm06.bufr_d ./mhsbufr +cp $fv3_netcdf_obs/ndas.t06z.1bhrs4.tm06.bufr_d ./hirs4bufr +cp $fv3_netcdf_obs/ndas.t06z.goesfv.tm06.bufr_d ./gsnd1bufr +cp $fv3_netcdf_obs/ndas.t06z.airsev.tm06.bufr_d ./airsbufr +cp $fv3_netcdf_obs/ndas.t06z.satwnd.tm06.bufr_d ./satwndbufr + +cp $fv3_netcdf_ges/coupler.res coupler.res +cp $fv3_netcdf_ges/fv_core.res.nest02.nc fv3_akbk +cp $fv3_netcdf_ges/grid_spec.nest02.nc fv3_grid_spec +cp $fv3_netcdf_ges/fv_core.res.nest02.tile7.nc fv3_dynvars +cp $fv3_netcdf_ges/fv_tracer.res.nest02.tile7.nc fv3_tracer +cp $fv3_netcdf_ges/sfc_data.nest02.tile7.nc fv3_sfcdata + + +cp $fv3_netcdf_ges/nam.t06z.satbias_pc.tm04 ./satbias_pc +cp $fv3_netcdf_ges/nam.t06z.satbias.tm04 ./satbias_in +cp $fv3_netcdf_ges/nam.t06z.radstat.tm04 ./radstat.gdas + +listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges` +for type in $listdiag; do + diag_file=`echo $type | cut -d',' -f1` + fname=`echo $diag_file | cut -d'.' -f1` + date=`echo $diag_file | cut -d'.' -f2` + $UNCOMPRESS $diag_file + fnameanl=$(echo $fname|sed 's/_ges//g') + mv $fname.$date $fnameanl +done + + +# Run GSI +cd $tmpdir +echo "run gsi now" +eval "$APRUN $tmpdir/gsi.x > stdout 2>&1" +rc=$? +exit $rc diff --git a/regression/nmm_binary.sh b/regression/nmm_binary.sh index fe51e6ece..4dcbcf5d7 100755 --- a/regression/nmm_binary.sh +++ b/regression/nmm_binary.sh @@ -42,7 +42,7 @@ tmpdir=$tmpdir/tmpreg_nmm_binary/${exp} savdir=$savdir/outreg/nmm_binary/${exp} # Specify GSI fixed field and data directories. - +fixcrtm=${fixcrtm:-$CRTM_FIX} # Set variables used in script # CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) diff --git a/regression/nmm_netcdf.sh b/regression/nmm_netcdf.sh index e06acdb0e..5d3e478cb 100755 --- a/regression/nmm_netcdf.sh +++ b/regression/nmm_netcdf.sh @@ -45,7 +45,7 @@ tmpdir=$tmpdir/tmpreg_nmm_netcdf/${exp} savdir=$savdir/outreg/nmm_netcdf/${exp} # Specify GSI fixed field and data directories. - +fixcrtm=${fixcrtm:-$CRTM_FIX} # Set variables used in script # CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) diff --git a/regression/nmmb_nems_4denvar.sh b/regression/nmmb_nems_4denvar.sh index 74b670994..0f1e4594a 100755 --- a/regression/nmmb_nems_4denvar.sh +++ b/regression/nmmb_nems_4denvar.sh @@ -14,7 +14,7 @@ exp=$jobname # Set path/file for gsi executable #gsiexec=/meso/save/Wanshu.Wu/Code/trunk/trunk_40320/src/global_gsi_org -#gsiexec=/da/save/Michael.Lueken/trunk/src/global_gsi +#gsiexec=/da/save/Michael.Lueken/trunk/src/global_gsi.x # Set runtime and save directories tmpdir=$tmpdir/tmpreg_nmmb_nems_4denvar/${exp} @@ -37,7 +37,7 @@ chmod 750 $tmpdir cd $tmpdir #FIXnam=/da/save/Michael.Lueken/trunk/fix -#FIXCRTM=/da/save/Michael.Lueken/CRTM_REL-2.2.3/crtm_v2.2.3/fix +fixcrtm=${fixcrtm:-$CRTM_FIX} berror=$fixgsi/nam_nmm_berror.f77.gcv anavinfo=$fixgsi/anavinfo_nems_nmmb diff --git a/regression/regression_driver.sh b/regression/regression_driver.sh index ec0c5464e..8b35ff67d 100755 --- a/regression/regression_driver.sh +++ b/regression/regression_driver.sh @@ -17,8 +17,15 @@ fi export scripts=${scripts_updat:-$scripts} . $scripts/regression_param.sh $regtest +# allow regression tests to be set by environment variable +if [ -z "$RSTART" ]; then + export RSTART=1 +fi +if [ -z "$REND" ]; then + export REND=4 +fi # Launch the individual control and update runs, one-after-another -for jn in `seq 1 4`; do +for jn in `seq ${RSTART} ${REND}`; do if [ $jn -le 2 ]; then export scripts=${scripts_updat:-$scripts} diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 9637f2203..e8c94992f 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -117,6 +117,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 @@ -129,6 +130,9 @@ OBS_INPUT:: crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 mlsbufr mls30 aura mls30_aura 0.0 0 0 oscatbufr uv null uv 0.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 + abibufr abi g16 abi_g16 0.0 1 0 :: &SUPEROB_RADAR $SUPERRAD @@ -223,6 +227,8 @@ OBS_INPUT:: sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 gomebufr gome metop-b gome_metop-b 0.0 2 0 mlsbufr mls30 aura mls30_aura 0.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 :: &SUPEROB_RADAR $SUPERRAD @@ -368,7 +374,11 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 7 0 seviribufr seviri m09 seviri_m09 0.0 7 0 seviribufr seviri m10 seviri_m10 0.0 7 0 + seviribufr seviri m11 seviri_m11 0.0 7 0 oscatbufr uv null uv 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0 + abibufr abi g16 abi_g16 0.0 7 0 :: &SUPEROB_RADAR $SUPERRAD @@ -512,6 +522,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 @@ -530,6 +541,8 @@ OBS_INPUT:: gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 :: &SUPEROB_RADAR $SUPERRAD @@ -681,6 +694,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 @@ -706,6 +720,9 @@ OBS_INPUT:: saphirbufr saphir meghat saphir_meghat 0.0 3 0 ahibufr ahi himawari8 ahi_himawari8 0.0 3 0 rapidscatbufr uv null uv 0.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 + abibufr abi g16 abi_g16 0.0 1 0 :: &SUPEROB_RADAR $SUPERRAD @@ -736,6 +753,189 @@ OBS_INPUT:: $NST / " +;; + + global_fv3_4denvar_T126 ) + +# Define namelist for global hybrid run + +export gsi_namelist=" + + &SETUP + miter=2,niter(1)=5,niter(2)=5, + niter_no_qc(1)=2,niter_no_qc(2)=0, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + qoption=2, + gencode=82,factqmin=0.5,factqmax=0.005,deltim=1200, + iguess=-1, + oneobtest=.false.,retrieval=.false.,l_foto=.false., + use_pbl=.false.,use_compress=.true.,nsig_ext=12,gpstop=50., + use_gfs_nemsio=.true.,lrun_subdirs=.true.,use_readin_anl_sfcmask=.true., + newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false., + diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,thin4d=.true.,cwoption=3, + verbose=.false.,imp_physics=11,lupp=.true.,binary_diag=.false.,netcdf_diag=.true., + l4densvar=.true.,ens_nstarthr=3,nhr_obsbin=1,nhr_assimilation=6,lwrite4danl=.false., tzr_qc=1,sfcnst_comb=.true., + $SETUP + / + &GRIDOPTS + JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, + regional=.false.,nlayers(63)=3,nlayers(64)=6, + $GRIDOPTS + / + &BKGERR + vs=0.7, + hzscl=1.7,0.8,0.5, + hswgt=0.45,0.3,0.25, + bw=0.0,norsp=4, + bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, + bkgv_write=.false., + cwcoveqqcov=.false., + $BKGVERR + / + &ANBKGERR + anisotropic=.false., + $ANBKGERR + / + &JCOPTS + ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=2.5e7,ljc4tlevs=.true., + $JCOPTS + / + &STRONGOPTS + tlnmc_option=3,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, + baldiag_full=.false.,baldiag_inc=.false., + $STRONGOPTS + / + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04, + use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.true., + aircraft_t_bc=.true.,biaspredt=1000.0,upd_aircraft=.true.,cleanup_tail=.true. + $OBSQC + / + &OBS_INPUT + dmesh(1)=1450.0,dmesh(2)=1500.0,dmesh(3)=1000.0,time_window_max=3.0, + $OBSINPUT + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + prepbufr ps null ps 0.0 0 0 + prepbufr t null t 0.0 0 0 + prepbufr_profl t null t 0.0 0 0 + prepbufr q null q 0.0 0 0 + prepbufr_profl q null q 0.0 0 0 + prepbufr pw null pw 0.0 0 0 + prepbufr uv null uv 0.0 0 0 + prepbufr_profl uv null uv 0.0 0 0 + satwndbufr uv null uv 0.0 0 0 + prepbufr spd null spd 0.0 0 0 + prepbufr dw null dw 0.0 0 0 + radarbufr rw null rw 0.0 0 0 + nsstbufr sst nsst sst 0.0 0 0 + gpsrobufr gps_bnd null gps 0.0 0 0 + ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 + tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 + gimgrbufr goes_img g11 imgr_g11 0.0 1 0 + gimgrbufr goes_img g12 imgr_g12 0.0 1 0 + airsbufr airs aqua airs_aqua 0.0 1 1 + amsuabufr amsua n15 amsua_n15 0.0 1 1 + amsuabufr amsua n18 amsua_n18 0.0 1 1 + amsuabufr amsua metop-a amsua_metop-a 0.0 1 1 + airsbufr amsua aqua amsua_aqua 0.0 1 1 + amsubbufr amsub n17 amsub_n17 0.0 1 1 + mhsbufr mhs n18 mhs_n18 0.0 1 1 + mhsbufr mhs metop-a mhs_metop-a 0.0 1 1 + ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 + amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 + ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 + ssmisbufr ssmis f17 ssmis_f17 0.0 1 0 + ssmisbufr ssmis f18 ssmis_f18 0.0 1 0 + ssmisbufr ssmis f19 ssmis_f19 0.0 1 0 + gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 + gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 + gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 + gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 + gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 + gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 + gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 + gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 + gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 + gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 + gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 + gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 + iasibufr iasi metop-a iasi_metop-a 0.0 1 1 + gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 + amsuabufr amsua n19 amsua_n19 0.0 1 1 + mhsbufr mhs n19 mhs_n19 0.0 1 1 + tcvitl tcp null tcp 0.0 0 0 + seviribufr seviri m08 seviri_m08 0.0 1 0 + seviribufr seviri m09 seviri_m09 0.0 1 0 + seviribufr seviri m10 seviri_m10 0.0 1 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 + amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 + mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 + iasibufr iasi metop-b iasi_metop-b 0.0 1 1 + gomebufr gome metop-b gome_metop-b 0.0 2 0 + atmsbufr atms npp atms_npp 0.0 1 1 + atmsbufr atms n20 atms_n20 0.0 1 1 + crisbufr cris npp cris_npp 0.0 1 0 + crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 + crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 + gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0 + gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0 + gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0 + gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0 + gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 + gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 + gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 + gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 + oscatbufr uv null uv 0.0 0 0 + mlsbufr mls30 aura mls30_aura 0.0 0 0 + avhambufr avhrr metop-a avhrr3_metop-a 0.0 1 0 + avhpmbufr avhrr n18 avhrr3_n18 0.0 1 0 + amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0 + gmibufr gmi gpm gmi_gpm 0.0 3 0 + saphirbufr saphir meghat saphir_meghat 0.0 3 0 + ahibufr ahi himawari8 ahi_himawari8 0.0 3 0 + rapidscatbufr uv null uv 0.0 0 0 +:: + &SUPEROB_RADAR + $SUPERRAD + / + &LAG_DATA + $LAGDATA + / + &HYBRID_ENSEMBLE + l_hyb_ens=.true.,n_ens=20,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8,generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=62, + nlat_ens=96,nlon_ens=192,ANISO_A_EN=.false.,jcap_ens_test=62,oz_univ_static=.false.,readin_localization=.true.,ensemble_path='./ensemble_data/', + ens_fast_read=.true.,write_ens_sprd=.false., + $HYBRID_ENSEMBLE + / + &RAPIDREFRESH_CLDSURF + dfi_radar_latent_heat_time_period=30.0, + / + &CHEM + + / + &SINGLEOB_TEST + maginnov=0.1,magoberr=0.1,oneob_type='t', + oblat=45.,oblon=180.,obpres=1000.,obdattim=${global_4denvar_T670_adate}, + obhourset=0., + $SINGLEOB + / + &NST + nst_gsi=3,nstinfo=4,fac_dtl=1,fac_tsl=1,zsea1=0,zsea2=0, + $NST + / +" ;; RTMA) @@ -748,7 +948,7 @@ export gsi_namelist=" miter=2,niter(1)=10,niter(2)=10, write_diag(1)=.true.,write_diag(2)=.true.,write_diag(3)=.true., gencode=78,qoption=1,tsensible=.true. - factqmin=1.0,factqmax=1.0,factv=0.1,factcldch=0.1,factw10m=1.0,deltim=$DELTIM, + factqmin=1.0,factqmax=1.0,factv=0.0,factcldch=0.0,factw10m=1.0,deltim=$DELTIM, iguess=-1, oneobtest=.false.,retrieval=.false., diag_rad=.false.,diag_pcp=.false.,diag_ozone=.false.,diag_aero=.false., @@ -943,6 +1143,8 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 1.0 6 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 oscatbufr uv null uv 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1088,6 +1290,8 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 1.0 6 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 oscatbufr uv null uv 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1233,6 +1437,8 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 1.0 6 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 oscatbufr uv null uv 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1378,6 +1584,8 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 1.0 6 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 oscatbufr uv null uv 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1415,6 +1623,139 @@ OBS_INPUT:: " ;; + netcdf_fv3_regional) + +# Define namelist for netcdf fv3 run + +export gsi_namelist=" + + &SETUP + miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + qoption=2, + factqmin=0.0,factqmax=0.0,deltim=$DELTIM, + iguess=-1, + newpc4pred=.true., adp_anglebc=.true., angord=4, + diag_precon=.true., step_start=1.e-3, + nhr_assimilation=3,l_foto=.false., + use_pbl=.false.,use_compress=.false.,gpstop=30., + lrun_subdirs=.true., + $SETUP + / + &GRIDOPTS + fv3_regional=.true.,grid_ratio_fv3_regional=3.0, + / + &BKGERR + hzscl=0.373,0.746,1.50, + vs=0.6,bw=0.,fstat=.false., + / + &ANBKGERR + anisotropic=.false., + / + &JCOPTS + / + &STRONGOPTS + / + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02, + vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., + / + &OBS_INPUT + dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,ext_sonde=.true., + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + prepbufr ps null ps 0.0 0 0 + prepbufr t null t 0.0 0 0 + prepbufr q null q 0.0 0 0 + prepbufr pw null pw 0.0 0 0 + prepbufr uv null uv 0.0 0 0 + prepbufr spd null spd 0.0 0 0 + prepbufr dw null dw 0.0 0 0 + radarbufr rw null rw 0.0 0 0 + prepbufr sst null sst 0.0 0 0 + gpsrobufr gps_bnd null gps_bnd 0.0 0 0 + ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 + tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 + gsndrbufr sndr g11 sndr_g11 0.0 1 0 + gsndrbufr sndr g12 sndr_g12 0.0 1 0 + gimgrbufr goes_img g11 imgr_g11 0.0 1 0 + gimgrbufr goes_img g12 imgr_g12 0.0 1 0 + airsbufr airs aqua airs281_aqua 0.0 1 0 + msubufr msu n14 msu_n14 0.0 1 0 + amsuabufr amsua n15 amsua_n15 0.0 1 0 + amsuabufr amsua n16 amsua_n16 0.0 1 0 + amsuabufr amsua n17 amsua_n17 0.0 1 0 + amsuabufr amsua n18 amsua_n18 0.0 1 0 + amsuabufr amsua metop-a amsua_metop-a 0.0 1 0 + amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 + airsbufr amsua aqua amsua_aqua 0.0 1 0 + amsubbufr amsub n15 amsub_n15 0.0 1 0 + amsubbufr amsub n16 amsub_n16 0.0 1 0 + amsubbufr amsub n17 amsub_n17 0.0 1 0 + mhsbufr mhs n18 mhs_n18 0.0 1 0 + mhsbufr mhs metop-a mhs_metop-a 0.0 1 0 + mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 + ssmitbufr ssmi f13 ssmi_f13 0.0 1 0 + ssmitbufr ssmi f14 ssmi_f14 0.0 1 0 + ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 + amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 + ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 + iasibufr iasi metop-a iasi_metop-a 0.0 1 0 + gomebufr gome metop-a gome_metop-a 0.0 1 0 + iasibufr iasi metop-b iasi_metop-b 0.0 1 0 + omibufr omi aura omi_aura 0.0 1 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 + amsuabufr amsua n19 amsua_n19 0.0 1 0 + mhsbufr mhs n19 mhs_n19 0.0 1 0 + tcvitl tcp null tcp 0.0 0 0 + satwndbufr uv null uv 0.0 0 0 + atmsbufr atms npp atms_npp 0.0 1 0 + crisbufr cris npp cris_npp 0.0 1 0 + crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 + seviribufr seviri m08 seviri_m08 0.0 1 0 + seviribufr seviri m09 seviri_m09 0.0 1 0 + seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 + gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 + gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 + gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 + gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 + prepbufr mta_cld null mta_cld 1.0 0 0 + prepbufr gos_ctp null gos_ctp 1.0 0 0 + lgycldbufr larccld null larccld 1.0 0 0 +:: + &SUPEROB_RADAR + del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., + l2superob_only=.false., + / + &LAG_DATA + / + &HYBRID_ENSEMBLE + / + &RAPIDREFRESH_CLDSURF + dfi_radar_latent_heat_time_period=30.0, + / + &CHEM + / + &SINGLEOB_TEST + / + &NST + / +" +;; nems_nmmb) # Define namelist for nems nmmb run @@ -1529,6 +1870,8 @@ OBS_INPUT:: tcvitl tcp null tcp 1.0 0 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 oscatbufr uv null uv 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1692,6 +2035,8 @@ OBS_INPUT:: gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 1 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1936,6 +2281,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 @@ -1954,6 +2300,8 @@ OBS_INPUT:: gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0 gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0 gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -2102,6 +2450,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 @@ -2120,6 +2469,8 @@ OBS_INPUT:: gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0 gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0 gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -2168,7 +2519,7 @@ export gsi_namelist=" obtimelnh=1.e30,obtimelsh=1.e30,obtimeltr=1.e30, saterrfact=1.0,numiter=1, sprd_tol=1.e30,paoverpb_thresh=0.98, - nlons=$LONA,nlats=$LATA,nlevs=$LEVS,nanals=$NMEM_ENKF,nvars=$NVARS, + nlons=$LONA,nlats=$LATA,nlevs=$LEVS,nanals=$NMEM_ENKF, deterministic=.true.,sortinc=.true.,lupd_satbiasc=$lupd_satbiasc, reducedgrid=.true.,readin_localization=.true., $NAM_ENKF @@ -2236,6 +2587,7 @@ export gsi_namelist=" sattypes_rad(60)= 'cris_npp', dsis(60)= 'cris_npp', sattypes_rad(61)= 'cris-fsr_npp', dsis(61)= 'cris-fsr_npp', sattypes_rad(62)= 'cris-fsr_n20', dsis(62)= 'cris-fsr_n20', + sattypes_rad(63)= 'seviri_m11', dsis(63)= 'seviri_m11', $SATOBS_ENKF / &ozobs_enkf @@ -2247,10 +2599,121 @@ export gsi_namelist=" sattypes_oz(6) = 'gome_metop-a', sattypes_oz(7) = 'gome_metop-b', sattypes_oz(8) = 'mls30_aura', + sattypes_oz(9) = 'ompsnp_npp', + sattypes_oz(10) = 'ompstc8_npp', $OZOBS_ENKF /" ;; + global_C96_fv3aero) + +# Define namelist for global run (aerosol analysis) + +export gsi_namelist=" + &SETUP + miter=3, + niter(1)=100,niter(2)=100,niter(3)=1, + niter_no_qc(1)=50,niter_no_qc(2)=0, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + qoption=2, + gencode=0,deltim=400, + factqmin=0.0,factqmax=0.0, + iguess=-1, + tzr_qc=1, + oneobtest=.false.,retrieval=.false.,l_foto=.false., + use_pbl=.false.,use_compress=.true.,nsig_ext=12,gpstop=50., + use_gfs_nemsio=.true.,sfcnst_comb=.true., + use_readin_anl_sfcmask=.false., + lrun_subdirs=.true., + crtm_coeffs_path='./crtm_coeffs/', + newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false., + diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,nhr_obsbin=3, + cwoption=3,imp_physics=11,lupp=.true., + netcdf_diag=.true.,binary_diag=.true., + lobsdiag_forenkf=.false., + diag_aero=.true., use_fv3_aero=.true.,offtime_data=.true., + diag_rad=.false.,diag_pcp=.false.,diag_conv=.false.,diag_ozone=.false., + / + + &GRIDOPTS + JCAP_B=190,JCAP=190,NLAT=194,NLON=384,nsig=64, + regional=.false.,nlayers(63)=3,nlayers(64)=6, + / + + &BKGERR + vs=0.7, + hzscl=1.7,0.8,0.5, + hswgt=0.45,0.3,0.25, + bw=0.0,norsp=4, + bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, + bkgv_write=.false., + cwcoveqqcov=.false., + / + + &ANBKGERR + anisotropic=.false., + / + + &JCOPTS + ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7, + / + + &STRONGOPTS + tlnmc_option=2,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, + / + + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.02, + use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.true., + aircraft_t_bc=.false.,biaspredt=1000.0,upd_aircraft=.true.,cleanup_tail=.true., + / + + &OBS_INPUT + dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=100.0,time_window_max=3.0, + / + +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + modisaodbufr modis_aod aqua v.modis_aqua 1.0 1 0 + modisaodbufr modis_aod terra v.modis_terra 1.0 1 0 +:: + + &SUPEROB_RADAR + / + + &LAG_DATA + / + + &HYBRID_ENSEMBLE + l_hyb_ens=.false., + generate_ens=.false., + beta_s0=0.125,readin_beta=.false., + s_ens_h=800.,s_ens_v=-0.8,readin_localization=.true., + aniso_a_en=.false.,oz_univ_static=.false.,uv_hyb_ens=.true., + ensemble_path='./ensemble_data/', + ens_fast_read=.true., + / + + &RAPIDREFRESH_CLDSURF + dfi_radar_latent_heat_time_period=30.0, + / + + &CHEM + laeroana_gocart=.true.,aod_qa_limit=1,luse_deepblue=.true., + / + + &SINGLEOB_TEST + maginnov=0.1,magoberr=0.1,oneob_type='t', + oblat=45.,oblon=180.,obpres=1000.,obdattim=2019061718, + obhourset=0., + / + + &NST + nst_gsi=3, + nstinfo=4,fac_dtl=1,fac_tsl=1,zsea1=0,zsea2=0, + /" +;; + *) # EXIT out for unresolved regression test diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index 8ff206131..bf6d62cb1 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -117,6 +117,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 @@ -127,6 +128,8 @@ OBS_INPUT:: crisbufr cris npp cris_npp 0.0 1 0 crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 :: / &SUPEROB_RADAR @@ -291,6 +294,9 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 5 0 seviribufr seviri m09 seviri_m09 0.0 5 0 seviribufr seviri m10 seviri_m10 0.0 5 0 + seviribufr seviri m11 seviri_m11 0.0 5 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 :: &SUPEROB_RADAR $SUPERRAD @@ -447,6 +453,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 @@ -465,6 +472,8 @@ OBS_INPUT:: gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 :: &SUPEROB_RADAR $SUPERRAD @@ -616,6 +625,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 @@ -641,6 +651,8 @@ OBS_INPUT:: saphirbufr saphir meghat saphir_meghat 0.0 3 0 ahibufr ahi himawari8 ahi_himawari8 0.0 3 0 rapidscatbufr uv null uv 0.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 :: &SUPEROB_RADAR $SUPERRAD @@ -671,6 +683,187 @@ OBS_INPUT:: $NST / " +;; + + global_fv3_4denvar_T126 ) + +# Define namelist for global fv3 4denvar run + +export gsi_namelist=" + + &SETUP + miter=1,niter(1)=2,niter(2)=1, + niter_no_qc(1)=1,niter_no_qc(2)=0, + use_gfs_nemsio=.true., + l4densvar=.true.,ens_nstarthr=3,nhr_obsbin=1,lwrite4danl=.true., + tzr_qc=1, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + qoption=2,cwoption=3, + gencode=82,factqmin=0.1,factqmax=0.1,deltim=$DELTIM, + iguess=-1, + oneobtest=.false.,retrieval=.false.,l_foto=.false., + use_pbl=.false.,use_prepb_satwnd=.false., + nhr_assimilation=6,lrun_subdirs=.true.,sfcnst_comb=.true., + $SETUP + / + &GRIDOPTS + JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, + regional=.false.,nlayers(63)=3,nlayers(64)=6, + $GRIDOPTS + / + &BKGERR + hzscl=1.7,0.8,0.5, + hswgt=0.45,0.3,0.25, + + bw=0.0,norsp=4, + bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, + bkgv_write=.false., + $BKGVERR + / + &ANBKGERR + anisotropic=.false., + $ANBKGERR + / + &JCOPTS + ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=2.5e7,ljc4tlevs=.true., + $JCOPTS + / + &STRONGOPTS + tlnmc_option=3,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, + baldiag_full=.true.,baldiag_inc=.true., + $STRONGOPTS + / + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.02, + use_poq7=.true.,njqc=.false.,vqc=.true.,aircraft_t_bc=.true.,biaspredt=1000.0,upd_aircraft=.true., + $OBSQC + / + &OBS_INPUT + dmesh(1)=1450.0,dmesh(2)=1500.0,dmesh(3)=1000.0,time_window_max=0.5, + $OBSINPUT + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + prepbufr ps null ps 0.0 0 0 + prepbufr t null t 0.0 0 0 + prepbufr_profl t null t 0.0 0 0 + prepbufr q null q 0.0 0 0 + prepbufr_profl q null q 0.0 0 0 + prepbufr pw null pw 0.0 0 0 + prepbufr uv null uv 0.0 0 0 + prepbufr_profl uv null uv 0.0 0 0 + satwndbufr uv null uv 0.0 0 0 + prepbufr spd null spd 0.0 0 0 + prepbufr dw null dw 0.0 0 0 + radarbufr rw null rw 0.0 0 0 + nsstbufr sst nsst sst 0.0 0 0 + gpsrobufr gps_bnd null gps 0.0 0 0 + ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 + tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr_skip hirs4 metop-a hirs4_metop-a 0.0 1 1 + gimgrbufr goes_img g11 imgr_g11 0.0 1 0 + gimgrbufr goes_img g12 imgr_g12 0.0 1 0 + airsbufr airs aqua airs_aqua 0.0 1 1 + amsuabufr_skip amsua n15 amsua_n15 0.0 1 1 + amsuabufr_skip amsua n18 amsua_n18 0.0 1 1 + amsuabufr_skip amsua metop-a amsua_metop-a 0.0 1 1 + airsbufr_skip amsua aqua amsua_aqua 0.0 1 1 + amsubbufr amsub n17 amsub_n17 0.0 1 1 + mhsbufr_skip mhs n18 mhs_n18 0.0 1 1 + mhsbufr_skip mhs metop-a mhs_metop-a 0.0 1 1 + ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 + amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 + ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 + ssmisbufr ssmis f17 ssmis_f17 0.0 1 0 + ssmisbufr ssmis f18 ssmis_f18 0.0 1 0 + ssmisbufr ssmis f19 ssmis_f19 0.0 1 0 + gsnd1bufr_skip sndrd1 g12 sndrD1_g12 0.0 1 0 + gsnd1bufr_skip sndrd2 g12 sndrD2_g12 0.0 1 0 + gsnd1bufr_skip sndrd3 g12 sndrD3_g12 0.0 1 0 + gsnd1bufr_skip sndrd4 g12 sndrD4_g12 0.0 1 0 + gsnd1bufr_skip sndrd1 g11 sndrD1_g11 0.0 1 0 + gsnd1bufr_skip sndrd2 g11 sndrD2_g11 0.0 1 0 + gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 + gsnd1bufr_skip sndrd4 g11 sndrD4_g11 0.0 1 0 + gsnd1bufr_skip sndrd1 g13 sndrD1_g13 0.0 1 0 + gsnd1bufr_skip sndrd2 g13 sndrD2_g13 0.0 1 0 + gsnd1bufr_skip sndrd3 g13 sndrD3_g13 0.0 1 0 + gsnd1bufr_skip sndrd4 g13 sndrD4_g13 0.0 1 0 + iasibufr iasi metop-a iasi_metop-a 0.0 1 1 + gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 + amsuabufr amsua n19 amsua_n19 0.0 1 1 + mhsbufr mhs n19 mhs_n19 0.0 1 1 + tcvitl tcp null tcp 0.0 0 0 + seviribufr seviri m08 seviri_m08 0.0 1 0 + seviribufr seviri m09 seviri_m09 0.0 1 0 + seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 + amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 + mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 + iasibufr iasi metop-b iasi_metop-b 0.0 1 1 + gomebufr gome metop-b gome_metop-b 0.0 2 0 + atmsbufr atms npp atms_npp 0.0 1 0 + crisbufr cris npp cris_npp 0.0 1 0 + crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 + gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0 + gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0 + gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0 + gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0 + gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 + gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 + gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 + gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 + oscatbufr uv null uv 0.0 0 0 + mlsbufr mls30 aura mls30_aura 0.0 0 0 + avhambufr avhrr metop-a avhrr3_metop-a 0.0 1 0 + avhpmbufr avhrr n18 avhrr3_n18 0.0 1 0 + amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0 + gmibufr gmi gpm gmi_gpm 0.0 3 0 + saphirbufr saphir meghat saphir_meghat 0.0 3 0 + ahibufr ahi himawari8 ahi_himawari8 0.0 3 0 + rapidscatbufr uv null uv 0.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 +:: + &SUPEROB_RADAR + $SUPERRAD + / + &LAG_DATA + $LAGDATA + / + &HYBRID_ENSEMBLE + l_hyb_ens=.true.,n_ens=10,beta_s0=0.25,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.7,generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=62, + nlat_ens=96,nlon_ens=192,ANISO_A_EN=.false.,jcap_ens_test=62,oz_univ_static=.true.,readin_localization=.true.,ensemble_path='./ensemble_data/', + write_ens_sprd=.false., + $HYBRID_ENSEMBLE + / + &RAPIDREFRESH_CLDSURF + dfi_radar_latent_heat_time_period=30.0, + / + &CHEM + + / + &SINGLEOB_TEST + maginnov=0.1,magoberr=0.1,oneob_type='t', + oblat=45.,oblon=180.,obpres=1000.,obdattim=${global_4denvar_T126_adate}, + obhourset=0., + $SINGLEOB + / + &NST + nst_gsi=3,nstinfo=4,fac_dtl=1,fac_tsl=1,zsea1=0,zsea2=5, + $NST + / +" ;; RTMA) @@ -683,7 +876,7 @@ export gsi_namelist=" miter=2,niter(1)=2,niter(2)=1, write_diag(1)=.true.,write_diag(2)=.true.,write_diag(3)=.true., gencode=78,qoption=1,tsensible=.true. - factqmin=1.0,factqmax=1.0,factv=0.1,factcldch=0.1,factw10m=1.0,deltim=$DELTIM, + factqmin=1.0,factqmax=1.0,factv=0.0,factcldch=0.0,factw10m=1.0,deltim=$DELTIM, iguess=-1, oneobtest=.false.,retrieval=.false., diag_rad=.false.,diag_pcp=.false.,diag_ozone=.false.,diag_aero=.false., @@ -715,7 +908,7 @@ export gsi_namelist=" / &OBSQC dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.02,vadfile='prepbufr', - hilbert_curve=.true.,buddycheck_t=.false.,buddydiag_save=.true.,oberrflg=.true.,njqc=.true.,vqc=.false., + hilbert_curve=.true.,buddycheck_t=.false.,buddydiag_save=.false.,oberrflg=.true.,njqc=.true.,vqc=.false., / &OBS_INPUT dmesh(1)=600.0,dmesh(2)=600.0,dmesh(3)=600.0,dmesh(4)=600.0,time_window_max=0.5, @@ -737,6 +930,7 @@ OBS_INPUT:: prepbufr pmsl null pmsl 1.0 0 0 prepbufr howv null howv 1.0 0 0 prepbufr tcamt null tcamt 1.0 0 0 + prepbufr cldch null cldch 1.0 0 0 :: &SUPEROB_RADAR / @@ -865,6 +1059,8 @@ OBS_INPUT:: iasibufr iasi metop-a iasi_metop-a 0.0 3 1 gomebufr gome metop-a gome_metop-a 0.0 4 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 4 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1008,6 +1204,8 @@ OBS_INPUT:: iasibufr iasi metop-a iasi_metop-a 0.0 3 1 gomebufr gome metop-a gome_metop-a 0.0 4 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 4 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1151,6 +1349,8 @@ OBS_INPUT:: iasibufr iasi metop-a iasi_metop-a 0.0 3 1 gomebufr gome metop-a gome_metop-a 0.0 4 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 4 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1294,6 +1494,8 @@ OBS_INPUT:: iasibufr iasi metop-a iasi_metop-a 0.0 3 1 gomebufr gome metop-a gome_metop-a 0.0 4 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 4 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1329,6 +1531,140 @@ OBS_INPUT:: &NST / " +;; + + netcdf_fv3_regional) + +# Define namelist for netcdf fv3 run + +export gsi_namelist=" + + &SETUP + miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + qoption=2, + factqmin=0.0,factqmax=0.0,deltim=$DELTIM, + iguess=-1, + newpc4pred=.true., adp_anglebc=.true., angord=4, + diag_precon=.true., step_start=1.e-3, + nhr_assimilation=3,l_foto=.false., + use_pbl=.false.,use_compress=.false.,gpstop=30., + lrun_subdirs=.true., + $SETUP + / + &GRIDOPTS + fv3_regional=.true.,grid_ratio_fv3_regional=3.0, + / + &BKGERR + hzscl=0.373,0.746,1.50, + vs=0.6,bw=0.,fstat=.false., + / + &ANBKGERR + anisotropic=.false., + / + &JCOPTS + / + &STRONGOPTS + / + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02, + vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., + / + &OBS_INPUT + dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,ext_sonde=.true., + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + prepbufr ps null ps 0.0 0 0 + prepbufr t null t 0.0 0 0 + prepbufr q null q 0.0 0 0 + prepbufr pw null pw 0.0 0 0 + prepbufr uv null uv 0.0 0 0 + prepbufr spd null spd 0.0 0 0 + prepbufr dw null dw 0.0 0 0 + radarbufr rw null rw 0.0 0 0 + prepbufr sst null sst 0.0 0 0 + gpsrobufr gps_bnd null gps_bnd 0.0 0 0 + ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 + tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 + gsndrbufr sndr g11 sndr_g11 0.0 1 0 + gsndrbufr sndr g12 sndr_g12 0.0 1 0 + gimgrbufr goes_img g11 imgr_g11 0.0 1 0 + gimgrbufr goes_img g12 imgr_g12 0.0 1 0 + airsbufr airs aqua airs281_aqua 0.0 1 0 + msubufr msu n14 msu_n14 0.0 1 0 + amsuabufr amsua n15 amsua_n15 0.0 1 0 + amsuabufr amsua n16 amsua_n16 0.0 1 0 + amsuabufr amsua n17 amsua_n17 0.0 1 0 + amsuabufr amsua n18 amsua_n18 0.0 1 0 + amsuabufr amsua metop-a amsua_metop-a 0.0 1 0 + amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 + airsbufr amsua aqua amsua_aqua 0.0 1 0 + amsubbufr amsub n15 amsub_n15 0.0 1 0 + amsubbufr amsub n16 amsub_n16 0.0 1 0 + amsubbufr amsub n17 amsub_n17 0.0 1 0 + mhsbufr mhs n18 mhs_n18 0.0 1 0 + mhsbufr mhs metop-a mhs_metop-a 0.0 1 0 + mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 + ssmitbufr ssmi f13 ssmi_f13 0.0 1 0 + ssmitbufr ssmi f14 ssmi_f14 0.0 1 0 + ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 + amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 + ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 + iasibufr iasi metop-a iasi_metop-a 0.0 1 0 + gomebufr gome metop-a gome_metop-a 0.0 1 0 + iasibufr iasi metop-b iasi_metop-b 0.0 1 0 + omibufr omi aura omi_aura 0.0 1 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 + amsuabufr amsua n19 amsua_n19 0.0 1 0 + mhsbufr mhs n19 mhs_n19 0.0 1 0 + tcvitl tcp null tcp 0.0 0 0 + satwndbufr uv null uv 0.0 0 0 + atmsbufr atms npp atms_npp 0.0 1 0 + crisbufr cris npp cris_npp 0.0 1 0 + crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 + seviribufr seviri m08 seviri_m08 0.0 1 0 + seviribufr seviri m09 seviri_m09 0.0 1 0 + seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 + gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 + gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 + gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 + gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 + prepbufr mta_cld null mta_cld 1.0 0 0 + prepbufr gos_ctp null gos_ctp 1.0 0 0 + lgycldbufr larccld null larccld 1.0 0 0 +:: + &SUPEROB_RADAR + del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., + l2superob_only=.false., + / + &LAG_DATA + / + &HYBRID_ENSEMBLE + / + &RAPIDREFRESH_CLDSURF + dfi_radar_latent_heat_time_period=30.0, + / + &CHEM + / + &SINGLEOB_TEST + / + &NST + / +" ;; nems_nmmb) @@ -1443,6 +1779,8 @@ OBS_INPUT:: mhsbufr mhs n19 mhs_n19 0.0 1 1 tcvitl tcp null tcp 0.0 0 0 mlsbufr mls30 aura mls30_aura 1.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 4 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1605,6 +1943,8 @@ OBS_INPUT:: gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 1 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1847,6 +2187,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 @@ -1865,6 +2206,8 @@ OBS_INPUT:: gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0 gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0 gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., @@ -1999,6 +2342,115 @@ OBS_INPUT:: " ;; + global_C96_fv3aero) + +# Define namelist for global run (aerosol analysis) + +export gsi_namelist=" + &SETUP + miter=3, + niter(1)=100,niter(2)=100,niter(3)=1, + niter_no_qc(1)=50,niter_no_qc(2)=0, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + qoption=2, + gencode=0,deltim=400, + factqmin=0.0,factqmax=0.0, + iguess=-1, + tzr_qc=1, + oneobtest=.false.,retrieval=.false.,l_foto=.false., + use_pbl=.false.,use_compress=.true.,nsig_ext=12,gpstop=50., + use_gfs_nemsio=.true.,sfcnst_comb=.true., + use_readin_anl_sfcmask=.false., + lrun_subdirs=.true., + crtm_coeffs_path='./crtm_coeffs/', + newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false., + diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,nhr_obsbin=3, + cwoption=3,imp_physics=11,lupp=.true., + netcdf_diag=.true.,binary_diag=.true., + lobsdiag_forenkf=.false., + diag_aero=.true., use_fv3_aero=.true.,offtime_data=.true., + diag_rad=.false.,diag_pcp=.false.,diag_conv=.false.,diag_ozone=.false., + / + + &GRIDOPTS + JCAP_B=190,JCAP=190,NLAT=194,NLON=384,nsig=64, + regional=.false.,nlayers(63)=3,nlayers(64)=6, + / + + &BKGERR + vs=0.7, + hzscl=1.7,0.8,0.5, + hswgt=0.45,0.3,0.25, + bw=0.0,norsp=4, + bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, + bkgv_write=.false., + cwcoveqqcov=.false., + / + + &ANBKGERR + anisotropic=.false., + / + + &JCOPTS + ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7, + / + + &STRONGOPTS + tlnmc_option=2,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, + / + + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.02, + use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.true., + aircraft_t_bc=.false.,biaspredt=1000.0,upd_aircraft=.true.,cleanup_tail=.true., + / + + &OBS_INPUT + dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=100.0,time_window_max=3.0, + / + +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + modisaodbufr modis_aod aqua v.modis_aqua 1.0 1 0 + modisaodbufr modis_aod terra v.modis_terra 1.0 1 0 +:: + + &SUPEROB_RADAR + / + + &LAG_DATA + / + + &HYBRID_ENSEMBLE + l_hyb_ens=.false., + generate_ens=.false., + beta_s0=0.125,readin_beta=.false., + s_ens_h=800.,s_ens_v=-0.8,readin_localization=.true., + aniso_a_en=.false.,oz_univ_static=.false.,uv_hyb_ens=.true., + ensemble_path='./ensemble_data/', + ens_fast_read=.true., + / + + &RAPIDREFRESH_CLDSURF + dfi_radar_latent_heat_time_period=30.0, + / + + &CHEM + laeroana_gocart=.true.,aod_qa_limit=-1000, + / + + &SINGLEOB_TEST + maginnov=0.1,magoberr=0.1,oneob_type='t', + oblat=45.,oblon=180.,obpres=1000.,obdattim=2019061718, + obhourset=0., + / + + &NST + nst_gsi=3, + nstinfo=4,fac_dtl=1,fac_tsl=1,zsea1=0,zsea2=0, + /" + +;; *) # EXIT out for unresolved job_name diff --git a/regression/regression_nl_update.sh b/regression/regression_nl_update.sh index 0e7074b15..81be5c244 100755 --- a/regression/regression_nl_update.sh +++ b/regression/regression_nl_update.sh @@ -18,8 +18,8 @@ if [[ `expr substr $exp 1 6` = "global" ]]; then export SETUP_enkf="univaroz=.true.,adp_anglebc=.true.,angord=4,use_edges=.false.,emiss_bc=.true.," fi fi -if [[ `expr substr $exp $((${#exp}-4)) ${#exp}` = "updat" ]]; then - export OBSQC_update="closest_obs=.false." +if [[ `expr substr $exp 1 4` = "rtma" ]]; then + export OBSQC_update="pvis=0.2,pcldch=0.1,scale_cv=1.0,estvisoe=2.61,estcldchoe=2.3716,vis_thres=16000.,cldch_thres=16000.," else export OBSQC_update="" fi diff --git a/regression/regression_param.sh b/regression/regression_param.sh index c134e3a48..ba6aeb891 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -2,17 +2,34 @@ regtest=$1 case $machine in - Theia) - sub_cmd="sub_zeus" + Hera) + sub_cmd="sub_hera" + memnode=96 + numcore=40 ;; WCOSS) sub_cmd="sub_wcoss -a GDAS-T2O -d $PWD" + memnode=64 # Phase-2 WCOSS + numcore=24 # Phase-2 WCOSS ;; WCOSS_C) sub_cmd="sub_wcoss_c -a GDAS-T2O -d $PWD" + memnode=64 + numcore=24 + ;; + WCOSS_D) + sub_cmd="sub_wcoss_d -a ibm -d $PWD" + memnode=128 + numcore=28 + ;; + Discover) + sub_cmd="sub_discover" ;; s4) sub_cmd="sub_s4" + ;; + Cheyenne) + sub_cmd="sub_ncar -a p48503002 -q economy -d $PWD" ;; *) # EXIT out for unresolved machine echo "unknown $machine" @@ -20,22 +37,43 @@ case $machine in esac +# Maximum memory per task for above machines +# wcoss_c : 64 Gb / 24 cores = 2.67 Gb / core +# wcoss_d : 128 Gb / 28 cores = 4.57 Gb / core +# theia : 64 Gb / 24 cores = 2.67 Gb / core +# discover: +# s4 : +# cheyenne: +# Select minimim memory per core for regression tests +export memnode=${memnode:-64} +export numcore=${numcore:-24} +export maxmem=$((($memnode*1024*1024)/$numcore)) # Kb / core + case $regtest in global_T62) - if [[ "$machine" = "Theia" ]]; then - topts[1]="0:30:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="12/9/" ; ropts[2]="/2" + if [[ "$machine" = "Hera" ]]; then + topts[1]="0:50:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:50:00" ; popts[2]="12/9/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:30:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="16/4/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:30:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="16/4/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="0:30:00" ; popts[1]="36/4/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="0:30:00" ; popts[2]="72/8/" ; ropts[2]="1024/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:30:00" ; popts[1]="28/2/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="28/4/" ; ropts[2]="/2" elif [[ "$machine" = "s4" ]]; then topts[1]="1:45:00" ; popts[1]="20/4" ; ropts[1]="/1" topts[2]="1:45:00" ; popts[2]="40/2" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="36/2" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="72/3" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then @@ -48,15 +86,24 @@ case $regtest in global_T62_ozonly) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:15:00" ; popts[1]="12/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/3/" ; ropts[2]="/2" + topts[2]="0:15:00" ; popts[2]="12/2/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:15:00" ; popts[1]="16/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/2/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:15:00" ; popts[1]="16/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="16/2/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="0:15:00" ; popts[1]="16/1/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="0:15:00" ; popts[2]="12/2/" ; ropts[2]="1024/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="28/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="16/1" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="16/2" ; ropts[2]="/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:25:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:25:00" ; popts[2]="16/4/" ; ropts[2]="/2" @@ -72,29 +119,41 @@ case $regtest in global_4dvar_T62) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:35:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:25:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:35:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:25:00" ; popts[2]="16/4/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="1:35:00" ; popts[1]="48/12/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="1:25:00" ; popts[2]="60/15/" ; ropts[2]="1024/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:55:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:45:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="28/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="2:00:00" ; popts[1]="48/2" ; ropts[1]="/1" + topts[2]="2:00:00" ; popts[2]="60/3" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then topts[1]="0:45:00" - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then popts[1]="12/5/" elif [[ "$machine" = "WCOSS" ]]; then popts[1]="16/4/" elif [[ "$machine" = "WCOSS_C" ]]; then popts[1]="48/12/" topts[1]="3:00:00" + elif [[ "$machine" = "WCOSS_D" ]]; then + popts[1]="56/14/" + topts[1]="3:00:00" fi fi @@ -104,18 +163,27 @@ case $regtest in global_hybrid_T126) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="0:15:00" ; popts[1]="48/8/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="0:15:00" ; popts[2]="60/10/" ; ropts[2]="1024/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:25:00" ; popts[1]="20/4/" ; ropts[1]="/1" topts[2]="0:25:00" ; popts[2]="40/4/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="28/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then @@ -128,15 +196,54 @@ case $regtest in global_4denvar_T126) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:15:00" ; popts[1]="6/8/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/10/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS" ]]; then + topts[1]="1:59:00" ; popts[1]="6/8/" ; ropts[1]="/1" + topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="1:59:00" ; popts[1]="6/8/" ; ropts[1]="/1" + topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS_C" ]]; then + topts[1]="0:35:00" ; popts[1]="48/8/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" + topts[2]="0:35:00" ; popts[2]="60/10/" ; ropts[2]="1024/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="6/8/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/10/" ; ropts[2]="/2" + fi + + if [ "$debug" = ".true." ] ; then + topts[1]="2:00:00" + fi + + scaling[1]=10; scaling[2]=8; scaling[3]=4 + + ;; + + global_fv3_4denvar_T126) + + if [[ "$machine" = "Hera" ]]; then topts[1]="0:35:00" ; popts[1]="6/8/" ; ropts[1]="/1" topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS" ]]; then + topts[1]="1:59:00" ; popts[1]="6/8/" ; ropts[1]="/1" + topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="1:59:00" ; popts[1]="6/8/" ; ropts[1]="/1" + topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="0:35:00" ; popts[1]="48/8/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="0:35:00" ; popts[2]="60/10/" ; ropts[2]="1024/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:35:00" ; popts[1]="6/8/" ; ropts[1]="/1" + topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then @@ -149,15 +256,24 @@ case $regtest in global_lanczos_T62) - if [[ "$machine" = "Theia" ]]; then - topts[1]="0:20:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="12/5/" ; ropts[2]="/2" + if [[ "$machine" = "Hera" ]]; then + topts[1]="0:30:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:20:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:20:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:20:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="16/4/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="0:20:00" ; popts[1]="48/8/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="0:20:00" ; popts[2]="60/10/" ; ropts[2]="1024/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:20:00" ; popts[1]="28/2/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="28/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:30:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="16/4/" ; ropts[2]="/2" @@ -173,18 +289,27 @@ case $regtest in global_nemsio_T62) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="0:30:00" ; popts[1]="48/8/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="0:30:00" ; popts[2]="60/10/" ; ropts[2]="1024/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:25:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:25:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="28/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then @@ -197,15 +322,51 @@ case $regtest in arw_binary | arw_netcdf) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:15:00" ; popts[1]="16/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="16/2/" ; ropts[2]="/1" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:15:00" ; popts[1]="16/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/2/" ; ropts[2]="/1" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="0:15:00" ; popts[1]="20/2/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="1024/1" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="16/1" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="20/2" ; ropts[2]="/2" + elif [[ "$machine" = "s4" ]]; then + topts[1]="0:25:00" ; popts[1]="16/1/" ; ropts[1]="/1" + topts[2]="0:25:00" ; popts[2]="16/2/" ; ropts[2]="/1" + fi + + if [ "$debug" = ".true." ] ; then + topts[1]="0:30:00" + fi + + scaling[1]=4; scaling[2]=10; scaling[3]=4 + + ;; + + netcdf_fv3_regional) + + if [[ "$machine" = "Hera" ]]; then + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + elif [[ "$machine" = "WCOSS" ]]; then + topts[1]="0:15:00" ; popts[1]="16/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/2/" ; ropts[2]="/1" + elif [[ "$machine" = "WCOSS_C" ]]; then + topts[1]="0:15:00" ; popts[1]="20/2/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" + topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="1024/1" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" elif [[ "$machine" = "s4" ]]; then topts[1]="0:25:00" ; popts[1]="16/1/" ; ropts[1]="/1" topts[2]="0:25:00" ; popts[2]="16/2/" ; ropts[2]="/1" @@ -221,18 +382,27 @@ case $regtest in nmm_binary ) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:30:00" ; popts[1]="6/6/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:30:00" ; popts[1]="7/12/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="9/12/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:30:00" ; popts[1]="7/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="9/12/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="0:30:00" ; popts[1]="48/8/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="0:30:00" ; popts[2]="60/10/" ; ropts[2]="1024/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:50:00" ; popts[1]="7/12/" ; ropts[1]="/1" topts[2]="0:50:00" ; popts[2]="9/12/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:30:00" ; popts[1]="7/24/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="9/24/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then @@ -245,18 +415,27 @@ case $regtest in nmm_netcdf) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:15:00" ; popts[1]="4/2/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="4/4/" ; ropts[2]="/1" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:15:00" ; popts[1]="8/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="16/1/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:15:00" ; popts[1]="8/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/1/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="0:15:00" ; popts[1]="8/2/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="1024/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:25:00" ; popts[1]="8/1/" ; ropts[1]="/1" topts[2]="0:25:00" ; popts[2]="16/1/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="14/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="8/1" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="16/1" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then @@ -269,18 +448,24 @@ case $regtest in nmmb_nems_4denvar) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:30:00" ; popts[1]="7/10/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="9/10/" ; ropts[2]="/1" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:30:00" ; popts[1]="7/10/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="9/10/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:30:00" ; popts[1]="7/10/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="9/10/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="1:30:00" ; popts[1]="72/9/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="1:30:00" ; popts[2]="96/12/" ; ropts[2]="1024/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:50:00" ; popts[1]="7/10/" ; ropts[1]="/1" topts[2]="0:50:00" ; popts[2]="9/10/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="7/14/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="9/14/" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then @@ -293,10 +478,13 @@ case $regtest in rtma) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "WCOSS" ]]; then + topts[1]="0:30:00" ; popts[1]="8/10/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="8/6/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="8/8/" ; ropts[2]="/1" elif [[ "$machine" = "WCOSS_C" ]]; then @@ -305,6 +493,9 @@ case $regtest in elif [[ "$machine" = "s4" ]]; then topts[1]="0:25:00" ; popts[1]="8/6/" ; ropts[1]="/1" topts[2]="0:25:00" ; popts[2]="8/8/" ; ropts[2]="/1" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then @@ -320,15 +511,21 @@ case $regtest in hwrf_nmm_d2 | hwrf_nmm_d3) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" elif [[ "$machine" = "WCOSS_C" ]]; then topts[1]="1:20:00" ; popts[1]="48/8/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" topts[2]="1:20:00" ; popts[2]="60/10/" ; ropts[2]="1024/1" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="10/10/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="14/14/" ; ropts[2]="/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:40:00" ; popts[1]="6/6/" ; ropts[1]="/1" topts[2]="0:40:00" ; popts[2]="8/8/" ; ropts[2]="/1" @@ -344,18 +541,24 @@ case $regtest in global_enkf_T62) - if [[ "$machine" = "Theia" ]]; then + if [[ "$machine" = "Hera" ]]; then topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS" ]]; then topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" elif [[ "$machine" = "WCOSS_C" ]]; then - topts[1]="0:15:00" ; popts[1]="20/4/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" - topts[2]="0:15:00" ; popts[2]="20/5/" ; ropts[2]="1024/2" + topts[1]="0:25:00" ; popts[1]="20/4/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" + topts[2]="0:25:00" ; popts[2]="20/5/" ; ropts[2]="1024/2" elif [[ "$machine" = "s4" ]]; then topts[1]="0:25:00" ; popts[1]="32/2/" ; ropts[1]="/1" topts[2]="0:25:00" ; popts[2]="32/4/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then @@ -366,6 +569,39 @@ case $regtest in ;; + global_C96_fv3aero) + + if [[ "$machine" = "Hera" ]]; then + topts[1]="0:30:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="12/9/" ; ropts[2]="/2" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS" ]]; then + topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "WCOSS_C" ]]; then + topts[1]="0:15:00" ; popts[1]="36/4/" ; ropts[1]="1024/1" # sub_wcoss_c popts are "#tasks/#nodes/" + topts[2]="0:15:00" ; popts[2]="72/8/" ; ropts[2]="1024/2" + elif [[ "$machine" = "WCOSS_D" ]]; then + topts[1]="0:15:00" ; popts[1]="28/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="20/4" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="40/2" ; ropts[2]="/2" + elif [[ "$machine" = "s4" ]]; then + topts[1]="0:25:00" ; popts[1]="36/2/" ; ropts[1]="/1" + topts[2]="0:25:00" ; popts[2]="72/3/" ; ropts[2]="/2" + fi + + if [ "$debug" = ".true." ] ; then + topts[1]="0:45:00" + fi + + scaling[1]=10; scaling[2]=8; scaling[3]=4 + + ;; + *) # EXIT out for unresolved regtest echo "unknown $regtest" @@ -395,21 +631,35 @@ export tmpregdir export result export scaling -if [[ "$machine" = "Theia" ]]; then +if [[ "$machine" = "Hera" ]]; then export OMP_STACKSIZE=1024M export MPI_BUFS_PER_PROC=256 export MPI_BUFS_PER_HOST=256 export MPI_GROUP_MAX=256 - export APRUN="mpirun -v -np \$PBS_NP" + export APRUN="srun" +elif [[ "$machine" = "Cheyenne" ]]; then + export OMP_STACKSIZE=1024M + export MPI_BUFS_PER_PROC=256 + export MPI_BUFS_PER_HOST=256 + export MPI_GROUP_MAX=256 + export APRUN="mpirun -v -np \$NCPUS" elif [[ "$machine" = "WCOSS" ]]; then export MP_USE_BULK_XFER=yes export MP_BULK_MIN_MSG_SIZE=64k export APRUN="mpirun.lsf" + if [ "$debug" = ".true." ] ; then + export MP_DEBUG_NOTIMEOUT=yes + fi elif [[ "$machine" = "WCOSS_C" ]]; then export KMP_AFFINITY=disabled export OMP_STACKSIZE=2G export FORT_BUFFERED=true - export APRUN="" + export APRUN="mpirun -v -np \$PBS_NP" +elif [[ "$machine" = "WCOSS_D" ]]; then + export KMP_AFFINITY=scatter + export KMP_STACKSIZE=2G + export FORT_BUFFERED=true + export APRUN="mpirun" elif [[ "$machine" = "s4" ]]; then export APRUN="srun" export MPI_BUFS_PER_PROC=2048 @@ -419,4 +669,6 @@ elif [[ "$machine" = "s4" ]]; then export MP_STDOUTMODE=ORDERED export KMP_STACKSIZE=512MB export KMP_AFFINITY=scatter +elif [[ "$machine" = "Discover" ]]; then + export APRUN="mpiexec_mpt -np \$SLURM_NTASKS" fi diff --git a/regression/regression_test.sh b/regression/regression_test.sh index dd2ea35f1..1fa5c2706 100755 --- a/regression/regression_test.sh +++ b/regression/regression_test.sh @@ -28,6 +28,8 @@ failed_test=0 ncp=/bin/cp # Name and create temporary directory +# pc: (1) Where is "compare" defined? +# (2) $savdir already has $input in it, why add another one? tmpdir=$savdir/$compare/$input/${exp1}_vs_${exp2} rm -rf $tmpdir mkdir -p $tmpdir @@ -35,12 +37,7 @@ cd $tmpdir # Other required constants for regression testing maxtime=1200 -# Dew/Mist=26 GB/16 tasks per node -##maxmem=$((1500000*1)) -# Vapor=110 GB/48 tasks per node -##maxmem=$((2300000*1)) -# Cirrus=110 GB/32 tasks per node -maxmem=$((3400000*1)) +maxmem=${maxmem:-3400000} # set in regression_param # Copy stdout and fort.220 files # from $savdir to $tmpdir @@ -141,7 +138,7 @@ fi timelogic=$( echo "$time1 > $maxtime" | bc ) if [[ "$timelogic" = 1 ]]; then echo 'The runtime for '$exp1' is '$(awk '{ print $8 }' runtime.$exp1.txt)' seconds. This has exceeded maximum allowable operational time of '$maxtime' seconds,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure of max-time in the regression test.' echo failed_test=1 else @@ -159,7 +156,7 @@ fi timelogic=$( echo "$time1 > $timethresh" | bc ) if [[ "$timelogic" = 1 ]]; then echo 'The runtime for '$exp1' is '$(awk '{ print $8 }' runtime.$exp1.txt)' seconds. This has exceeded maximum allowable threshold time of '$timethresh' seconds,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure time-thresh of the regression test.' echo failed_test=1 else @@ -177,7 +174,7 @@ fi timelogic=$( echo "$time_scale1 > $timethresh2" | bc ) if [[ "$timelogic" = 1 ]]; then echo 'The runtime for '$exp1_scale' is '$(awk '{ print $8 }' runtime.$exp1_scale.txt)' seconds. This has exceeded maximum allowable threshold time of '$timethresh2' seconds,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure of timethresh2 the regression test.' echo failed_test=1 else @@ -195,7 +192,7 @@ fi if [[ $(awk '{ print $8 }' memory.$exp1.txt) -gt $maxmem ]]; then echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs. This has exceeded maximum allowable hardware memory limit of '$maxmem' KBs,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure maxmem of the regression test.' echo failed_test=1 else @@ -212,7 +209,7 @@ fi if [[ $(awk '{ print $8 }' memory.$exp1.txt) -gt $memthresh ]]; then echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs. This has exceeded maximum allowable memory of '$memthresh' KBs,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure memthresh of the regression test.' echo failed_test=1 else @@ -234,14 +231,14 @@ if [[ $(grep -c 'cost,grad,step' penalty.${exp1}-${exp2}.txt) = 0 ]]; then echo else echo 'The results between the two runs are nonreproducible,' - echo 'thus the regression test has failed for '${exp1}' and '${exp2}' analyses.' + echo 'thus the regression test has Failed on cost for '${exp1}' and '${exp2}' analyses.' # echo 'thus the regression test has failed for '${exp1}' and '${exp2}' analyses with '$(grep -c 'cost,grad,step' penalty.${exp1}-${exp2}.txt)' lines different.' echo failed_test=1 fi else echo 'The results between the two runs are nonreproducible,' - echo 'thus the regression test has failed for '${exp1}' and '${exp2}' analyses.' + echo 'thus the regression test has Failed on cost for '${exp1}' and '${exp2}' analyses.' echo fi @@ -260,7 +257,7 @@ then echo else echo 'The results between the two runs ('${exp1}' and '${exp2}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed siganl the regression tests.' echo failed_test=1 fi @@ -278,7 +275,7 @@ then echo else echo 'The results between the two runs ('${exp1}' and '${exp2}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed wrf_inout the regression tests.' echo failed_test=1 fi @@ -296,7 +293,7 @@ then echo else echo 'The results between the two runs ('${exp1}' and '${exp2}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed wrf_inout06 of the regression tests.' echo failed_test=1 fi @@ -314,7 +311,7 @@ then echo else echo 'The results between the two runs ('${exp1}' and '${exp2}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed siginc of the regression tests.' echo failed_test=1 fi @@ -330,7 +327,7 @@ then echo else echo 'The results between the two runs ('${exp1}' and '${exp2}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed siganl of the regression tests.' echo failed_test=1 fi @@ -350,14 +347,14 @@ if [[ $(grep -c 'cost,grad,step' penalty.${exp1}-${exp3}.txt) = 0 ]]; then echo else echo 'The results between the two runs are nonreproducible,' - echo 'thus the regression test has failed for '${exp1}' and '${exp3}' analyses.' + echo 'thus the regression test has Failed cost for '${exp1}' and '${exp3}' analyses.' # echo 'thus the regression test has failed for '${exp1}' and '${exp3}' analyses with '$(grep -c 'cost,grad,step' penalty.${exp1}-${exp3}.txt)' lines different.' echo failed_test=1 fi else echo 'The results between the two runs are nonreproducible,' - echo 'thus the regression test has failed for '${exp1}' and '${exp3}' analyses.' + echo 'thus the regression test has Failed cost for '${exp1}' and '${exp3}' analyses.' echo fi @@ -376,7 +373,7 @@ if [[ `expr substr $exp1 1 4` = "rtma" ]]; then echo else echo 'The results between the two runs ('${exp1}' and '${exp3}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed wrf_inout of the regression tests.' echo failed_test=1 fi @@ -394,7 +391,7 @@ elif [[ -f wrf_inout.${exp1} ]]; then echo else echo 'The results between the two runs ('${exp1}' and '${exp3}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed wrf_inout of the regression tests.' echo failed_test=1 fi @@ -412,7 +409,7 @@ elif [[ -f wrf_inout06.${exp1} ]]; then echo else echo 'The results between the two runs ('${exp1}' and '${exp3}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed wrf_inout06 of the regression tests.' echo failed_test=1 fi @@ -430,7 +427,7 @@ elif [[ `expr substr $exp1 1 6` = "global" ]]; then echo else echo 'The results between the two runs ('${exp1}' and '${exp3}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed siginc of the regression tests.' echo failed_test=1 fi @@ -447,7 +444,7 @@ elif [[ `expr substr $exp1 1 6` = "global" ]]; then echo else echo 'The results between the two runs ('${exp1}' and '${exp3}') are not reproducible' - echo 'Thus, the case has failed the regression tests.' + echo 'Thus, the case has Failed siganl of the regression tests.' echo failed_test=1 fi @@ -465,7 +462,7 @@ fi echo 'The case has passed the scalability regression test.' echo 'The slope for the update ('$scale1thresh' seconds per node) is greater than or equal to that for the control ('$scale2' seconds per node).' else - echo 'The case has failed the scalability test.' + echo 'The case has Failed the scalability test.' echo 'The slope for the update ('$scale1thresh' seconds per node) is less than that for the control ('$scale2' seconds per node).' fi diff --git a/regression/regression_test_enkf.sh b/regression/regression_test_enkf.sh index a89c8f1aa..adaff2f2f 100755 --- a/regression/regression_test_enkf.sh +++ b/regression/regression_test_enkf.sh @@ -31,12 +31,7 @@ cd $tmpdir # Other required constants for regression testing maxtime=1200 -# Dew/Mist=26 GB/16 tasks per node -##maxmem=$((1500000*1)) -# Vapor=110 GB/48 tasks per node -##maxmem=$((2300000*1)) -# Cirrus=110 GB/32 tasks per node -maxmem=$((3400000*1)) +maxmem=${maxmem:-3400000} # set in regression_param # Copy stdout and sanl files # from $savdir to $tmpdir @@ -134,8 +129,9 @@ fi timelogic=$( echo "$time1 > $maxtime" | bc ) if [[ "$timelogic" = 1 ]]; then echo 'The runtime for '$exp1' is '$(awk '{ print $8 }' runtime.$exp1.txt)' seconds. This has exceeded maximum allowable operational time of '$maxtime' seconds,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure maxtime of the regression test.' echo + failed_test=1 else echo 'The runtime for '$exp1' is '$(awk '{ print $8 }' runtime.$exp1.txt)' seconds and is within the maximum allowable operational time of '$maxtime' seconds,' echo 'continuing with regression test.' @@ -151,8 +147,9 @@ fi timelogic=$( echo "$time1 > $timethresh" | bc ) if [[ "$timelogic" = 1 ]]; then echo 'The runtime for '$exp1' is '$(awk '{ print $8 }' runtime.$exp1.txt)' seconds. This has exceeded maximum allowable threshold time of '$timethresh' seconds,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure timethresh of the regression test.' echo + failed_test=1 else echo 'The runtime for '$exp1' is '$(awk '{ print $8 }' runtime.$exp1.txt)' seconds and is within the allowable threshold time of '$timethresh' seconds,' echo 'continuing with regression test.' @@ -168,8 +165,9 @@ fi timelogic=$( echo "$time_scale1 > $timethresh2" | bc ) if [[ "$timelogic" = 1 ]]; then echo 'The runtime for '$exp1_scale' is '$(awk '{ print $8 }' runtime.$exp1_scale.txt)' seconds. This has exceeded maximum allowable threshold time of '$timethresh2' seconds,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure timethresh2 of the regression test.' echo + failed_test=1 else echo 'The runtime for '$exp1_scale' is '$(awk '{ print $8 }' runtime.$exp1_scale.txt)' seconds and is within the allowable threshold time of '$timethresh2' seconds,' echo 'continuing with regression test.' @@ -185,8 +183,9 @@ fi if [[ $(awk '{ print $8 }' memory.$exp1.txt) -gt $maxmem ]]; then echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs. This has exceeded maximum allowable hardware memory limit of '$maxmem' KBs,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure maxmem of the regression test.' echo + failed_test=1 else echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs and is within the maximum allowable hardware memory limit of '$maxmem' KBs,' echo 'continuing with regression test.' @@ -201,8 +200,9 @@ fi if [[ $(awk '{ print $8 }' memory.$exp1.txt) -gt $memthresh ]]; then echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs. This has exceeded maximum allowable memory of '$memthresh' KBs,' - echo 'resulting in failure of the regression test.' + echo 'resulting in Failure memthresh of the regression test.' echo + failed_test=1 else echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs and is within the maximum allowable memory of '$memthresh' KBs,' echo 'continuing with regression test.' @@ -222,16 +222,19 @@ if [[ $(grep -c 'ens. mean anal. increment' increment.${exp1}-${exp2}.txt) = 0 ] echo else echo 'The results between the two runs are nonreproducible,' - echo 'thus the regression test has failed for '${exp1}' and '${exp2}' analyses.' -# echo 'thus the regression test has failed for '${exp1}' and '${exp2}' analyses with '$(grep -c 'ens. mean anal. increment' increment.${exp1}-${exp2}.txt)' lines different.' +# echo 'thus the regression test has failed for '${exp1}' and '${exp2}' analyses.' + echo 'thus the regression test has Failed mean anal for '${exp1}' and '${exp2}' analyses with '$(grep -c 'ens. mean anal. increment' increment.${exp1}-${exp2}.txt)' lines different.' echo - exit 1 + failed_test=1 +# exit 1 fi else echo 'The results between the two runs are nonreproducible,' - echo 'thus the regression test has failed for '${exp1}' and '${exp2}' analyses.' +# echo 'thus the regression test has failed for '${exp1}' and '${exp2}' analyses.' + echo 'thus the regression test has Failed mean anal for '${exp1}' and '${exp2}' analyses with '$(grep -c 'ens. mean anal. increment' increment.${exp1}-${exp2}.txt)' lines different.' echo - exit 1 + failed_test=1 +# exit 1 fi } >> $output @@ -281,13 +284,13 @@ nmem=20 imem=1 while [[ $imem -le $nmem ]]; do member="_mem"`printf %03i $imem` - if cmp -s sanl$member.${exp1} sanl$member.${exp2} + if ! cmp -s sanl$member.${exp1} sanl$member.${exp2} then - echo 'sanl'$member'.'${exp1}' sanl'$member'.'${exp2}' are identical' - echo + echo 'sanl'$member'.'${exp1}' sanl'$member'.'${exp2}' are NOT identical' fi (( imem = $imem + 1 )) done +echo } >> $output fi fi @@ -314,16 +317,19 @@ else echo else echo 'The results between the two runs are nonreproducible,' - echo 'thus the regression test has failed for '${exp1}' and '${exp3}' analyses.' -# echo 'thus the regression test has failed for '${exp1}' and '${exp3}' analyses with '$(grep -c 'ens. mean anal. increment' increment.${exp1}-${exp3}.txt)' lines different.' +# echo 'thus the regression test has failed for '${exp1}' and '${exp3}' analyses.' + echo 'thus the regression test has Failed mean anal for '${exp1}' and '${exp3}' analyses with '$(grep -c 'ens. mean anal. increment' increment.${exp1}-${exp3}.txt)' lines different.' echo - exit 1 + failed_test=1 +# exit 1 fi else echo 'The results between the two runs are nonreproducible,' - echo 'thus the regression test has failed for '${exp1}' and '${exp3}' analyses.' +# echo 'thus the regression test has failed for '${exp1}' and '${exp3}' analyses.' + echo 'thus the regression test has Failed mean anal for '${exp1}' and '${exp3}' analyses with '$(grep -c 'ens. mean anal. increment' increment.${exp1}-${exp3}.txt)' lines different.' echo - exit 1 + failed_test=1 +# exit 1 fi } >> $output @@ -375,14 +381,13 @@ else imem=1 while [[ $imem -le $nmem ]]; do member="_mem"`printf %03i $imem` - if cmp -s sanl$member.${exp1} sanl$member.${exp3} + if ! cmp -s sanl$member.${exp1} sanl$member.${exp3} then - echo 'sanl'$member'.'${exp1}' sanl'$member'.'${exp3}' are identical' - echo + echo 'sanl'$member'.'${exp1}' sanl'$member'.'${exp3}' are NOT identical' fi (( imem = $imem + 1 )) done - + echo } >> $output fi fi @@ -397,7 +402,7 @@ fi echo 'The case has passed the scalability regression test.' echo 'The slope for the update ('$scale1thresh' seconds per node) is greater than or equal to that for the control ('$scale2' seconds per node).' else - echo 'The case has failed the scalability test.' + echo 'The case has Failed the scalability test.' echo 'The slope for the update ('$scale1thresh' seconds per node) is less than that for the control ('$scale2' seconds per node).' fi @@ -418,4 +423,4 @@ if [[ "$clean" = ".true." ]]; then rm -rf $savdir fi -exit +exit $failed_test diff --git a/regression/regression_var.sh b/regression/regression_var.sh index afcce5e34..7d864ec42 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -21,71 +21,64 @@ if [ "$#" = 8 ] ; then export ptmpName=`echo $builddir | sed -e "s/\//_/g"` echo $ptmpName else -# Name of the branch being tested + # Name of the branch being tested updat="XXXXXXXX" contrl="XXXXXXXX" export cmaketest="false" export clean="false" export ptmpName="" fi - -# First determine what machine are we on: -if [ -d /da ]; then # WCOSS - export machine="WCOSS" - if [ -d /da/noscrub/$LOGNAME ]; then - export noscrub=/da/noscrub/$LOGNAME - elif [ -d /global/noscrub/$LOGNAME ]; then - export noscrub=/global/noscrub/$LOGNAME - fi -elif [ -d /scratch4/NCEPDEV/da ]; then # Theia - export machine="Theia" - if [ -d /scratch4/NCEPDEV/da/noscrub/$LOGNAME ]; then - export noscrub="/scratch4/NCEPDEV/da/noscrub/$LOGNAME" - elif [ -d /scratch4/NCEPDEV/global/noscrub/$LOGNAME ]; then - export noscrub="/scratch4/NCEPDEV/global/noscrub/$LOGNAME" - fi -elif [ -d /gpfs/hps/ptmp ]; then # LUNA or SURGE +echo "beginning regression_var.sh, machine is $machine" +# If we don't know already determine what machine are we on: +if [ -z ${machine+x} ]; then + echo "machine is unset"; + if [ -d /da ]; then # WCOSS + export machine="WCOSS" + elif [ -d /glade/scratch ]; then # Cheyenne + export machine="Cheyenne" + elif [ -d /scratch1/NCEPDEV/da ]; then # Hera + export machine="Hera" + elif [ -d /gpfs/hps/ptmp ]; then # LUNA or SURGE export machine="WCOSS_C" - if [ -d /gpfs/hps/emc/global/noscrub/$LOGNAME ]; then - export noscrub="/gpfs/hps/emc/global/noscrub/$LOGNAME" - elif [ -d /gpfs/hps/emc/da/noscrub/$LOGNAME ]; then - export noscrub="/gpfs/hps/emc/da/noscrub/$LOGNAME" - fi -elif [ -d /data/users ]; then # S4 + elif [ -d /gpfs/dell1/ptmp ]; then # venus or mars + export machine="WCOSS_D" + elif [ -d /data/users ]; then # S4 export machine="s4" - export noscrub="/data/users/$LOGNAME" +elif [ -d /discover/nobackup ]; then # NCCS Discover + export machine="Discover" + fi +else echo "machine is set to '$machine'"; fi -# Handle machine specific paths for: -# experiment and control executables, fix, ptmp, and CRTM coefficient files. -# Location of ndate utility, noscrub directory, and account name (accnt = ada by default). -if [[ "$machine" = "Theia" ]]; then - - export group="global" - export queue="batch" - if [[ "$cmaketest" = "false" ]]; then - export basedir="/scratch4/NCEPDEV/da/save/$LOGNAME/git/gsi" - fi - - export ptmp="/scratch4/NCEPDEV/stmp3/$LOGNAME/$ptmpName" - - export fixcrtm="/scratch4/NCEPDEV/da/save/Michael.Lueken/nwprod/lib/crtm/2.2.3/fix_update" - export casesdir="/scratch4/NCEPDEV/da/noscrub/Michael.Lueken/CASES" - export ndate="/scratch4/NCEPDEV/da/save/Michael.Lueken/nwprod/util/exec/ndate" - - export check_resource="no" +case $machine in + WCOSS_D) + export noscrub=/gpfs/dell2/emc/modeling/noscrub/$LOGNAME + export group="dev" + export queue="dev" - export accnt="da-cpu" + export ptmp="/gpfs/dell2/ptmp/$LOGNAME/$ptmpName" - # On Theia, there are no scrubbers to remove old contents from stmp* directories. - # After completion of regression tests, will remove the regression test subdirecories - export clean=".true." + export fixcrtm="/gpfs/dell2/emc/modeling/noscrub/Michael.Lueken/fix_update" + if [ -d /gpfs/td2 ]; then + export casesdir="/gpfs/td2/emc/da/noscrub/Michael.Lueken/CASES" + elif [ -d /gpfs/gd2 ]; then + export casesdir="/gpfs/gd2/emc/da/noscrub/Michael.Lueken/CASES" + fi + export ndate=${NDATE:-"$builddir/bin/ndate.x"} -elif [[ "$machine" = "WCOSS" ]]; then + export check_resource="yes" + export accnt="" + ;; + WCOSS) + if [ -d /da/noscrub/$LOGNAME ]; then + export noscrub=/da/noscrub/$LOGNAME + elif [ -d /global/noscrub/$LOGNAME ]; then + export noscrub=/global/noscrub/$LOGNAME + fi if [[ "$cmaketest" = "false" ]]; then export basedir="/global/save/$LOGNAME/gsi" - fi + fi export group="dev" export queue="dev" @@ -98,73 +91,139 @@ elif [[ "$machine" = "WCOSS" ]]; then export check_resource="yes" export accnt="" + ;; + Cheyenne) + export queue="economy" + export noscrub="/glade/scratch/$LOGNAME" + export group="global" + if [[ "$cmaketest" = "false" ]]; then + export basedir="/glade/scratch/$LOGNAME/gsi" + fi + export ptmp="/glade/scratch/$LOGNAME/$ptmpName" -elif [[ "$machine" = "WCOSS_C" ]]; then + export fixcrtm="/glade/p/ral/jntp/tools/crtm/2.2.3/fix_update" + export casesdir="/glade/p/ral/jntp/tools/CASES" + export ndate="$builddir/bin/ndate.x" + export check_resource="no" + export accnt="p48503002" + ;; + Hera) + if [ -d /scratch1/NCEPDEV/da/$LOGNAME ]; then + export noscrub="/scratch1/NCEPDEV/da/$LOGNAME/noscrub" + elif [ -d /scratch1/NCEPDEV/global/$LOGNAME ]; then + export noscrub="/scratch1/NCEPDEV/global/$LOGNAME/noscrub" + elif [ -d /scratch2/BMC/gsienkf/$LOGNAME ]; then + export noscrub="/scratch2/BMC/gsienkf/$LOGNAME" + fi + export group="global" + export queue="batch" if [[ "$cmaketest" = "false" ]]; then - export basedir="/gpfs/hps/emc/global/noscrub/$LOGNAME/svn/gsi" + export basedir="/scratch1/NCEPDEV/da/$LOGNAME/git/gsi" fi + + export ptmp="/scratch1/NCEPDEV/stmp2/$LOGNAME/$ptmpName" + + export fixcrtm="/scratch1/NCEPDEV/da/Michael.Lueken/CRTM_REL-2.2.3/crtm_v2.2.3/fix_update" + export casesdir="/scratch1/NCEPDEV/da/Michael.Lueken/noscrub/CASES" + export ndate=$NDATE + + export check_resource="no" + + export accnt="da-cpu" + + # On Hera, there are no scrubbers to remove old contents from stmp* directories. + # After completion of regression tests, will remove the regression test subdirecories + export clean=".true." + ;; + WCOSS_C) + if [ -d /gpfs/hps3/emc/global/noscrub/$LOGNAME ]; then + export noscrub="/gpfs/hps3/emc/global/noscrub/$LOGNAME" + elif [ -d /gpfs/hps3/emc/da/noscrub/$LOGNAME ]; then + export noscrub="/gpfs/hps3/emc/da/noscrub/$LOGNAME" + fi + if [[ "$cmaketest" = "false" ]]; then + export basedir="/gpfs/hps3/emc/global/noscrub/$LOGNAME/svn/gsi" + fi export group="dev" export queue="dev" export ptmp="/gpfs/hps/ptmp/$LOGNAME/$ptmpName" - export fixcrtm="/gpfs/hps/nco/ops/nwprod/lib/crtm/v2.2.4/fix" - export casesdir="/gpfs/hps/emc/da/noscrub/Michael.Lueken/CASES" + export fixcrtm="/gpfs/hps3/emc/da/noscrub/Michael.Lueken/CRTM_REL-2.2.3/fix_update" + export casesdir="/gpfs/hps3/emc/da/noscrub/Michael.Lueken/CASES" export ndate=$NDATE export check_resource="no" export accnt="" -elif [[ "$machine" = "s4" ]]; then + ;; + s4) + export noscrub="/data/users/$LOGNAME" if [[ "$cmaketest" = "false" ]]; then export basedir="/home/$LOGNAME/gsi" - fi + fi export group="dev" export queue="dev" export NWPROD="/usr/local/jcsda/nwprod_gdas_2014" export ptmp="/scratch/short/$LOGNAME/$ptmpName" export fixcrtm="/home/mpotts/gsi/trunk/lib/CRTM_REL-2.2.3/fix_update" -# export fixcrtm="/usr/local/jcsda/nwprod_gdas_2014/lib/sorc/crtm_v2.1.3/fix/" export casesdir="/data/users/mpotts/CASES" -# export casesdir="/scratch/mpotts/CASES" export ndate="$NWPROD/util/exec/ndate" export check_resource="no" export accnt="star" - -fi + ;; + Discover) + if [[ "$cmaketest" = "false" ]]; then + echo "Regression tests on Discover need to be run via ctest" + exit 1 + fi + export ptmp=$basedir + export ptmp=$basedir + export noscrub=$basedir + export fixcrtm="/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/gsi/etc/fix_ncep20170329/REL-2.2.3-r60152_local-rev_1/CRTM_Coeffs/$endianness" + export casesdir="/discover/nobackup/projects/gmao/obsdev/wrmccart/NCEP_regression/CASES" + export ndate="/home/pchakrab/.local/bin/ndate" + export check_resource="no" + export accnt="g0613" + export queue="compute" + export clean=".false." + ;; +esac if [[ "$cmaketest" = "false" ]]; then export builddir=$noscrub/build export gsisrc="$basedir/$updat/src" - export gsiexec_updat="$gsisrc/global_gsi" - export gsiexec_contrl="$basedir/$contrl/src/global_gsi" - export enkfexec_updat="$gsisrc/enkf/global_enkf" - export enkfexec_contrl="$basedir/$contrl/src/enkf/global_enkf" + export gsiexec_updat="$gsisrc/global_gsi.x" + export gsiexec_contrl="$basedir/$contrl/src/global_gsi.x" + export enkfexec_updat="$gsisrc/enkf/global_enkf.x" + export enkfexec_contrl="$basedir/$contrl/src/enkf/global_enkf.x" export fixgsi="$basedir/$updat/fix" export scripts="$basedir/$updat/regression" export ush="$basedir/$updat/ush" fi -# Paths to tmpdir and savedir base on ptmp -export tmpdir="$ptmp" -export savdir="$ptmp" # We are dealing with *which* endian files export endianness="Big_Endian" +# Paths to tmpdir and savedir base on ptmp +export tmpdir="$ptmp" +export savdir="$ptmp" + # Variables with the same values are defined below. # Default resolution export JCAP="62" # Case Study analysis dates -export global_T62_adate="2014080400" +export global_T62_adate="2016120300" export global_4dvar_T62_adate="2014080400" export global_hybrid_T126_adate="2014092912" -export global_4denvar_T126_adate="2016120300" +export global_4denvar_T126_adate="2019041500" +export global_fv3_4denvar_T126_adate="2018110500" export global_enkf_T62_adate="2014092912" export global_lanczos_T62_adate="2014080400" export global_nemsio_T62_adate="2013011400" @@ -175,6 +234,8 @@ export nmm_binary_adate="2010021600" export nmm_netcdf_adate="2007122000" export rtma_adate="2017031218" export hwrf_nmm_adate="2012102812" +export fv3_netcdf_adate="2017030100" +export global_C96_fv3aero_adate="2019062200" # Paths for canned case data. export global_T62_obs="$casesdir/global/sigmap/$global_T62_adate" @@ -184,8 +245,10 @@ export global_4dvar_T62_ges="$casesdir/global/sigmap/$global_4dvar_T62_adate" export global_hybrid_T126_datobs="$casesdir/global/sigmap/$global_hybrid_T126_adate/obs" export global_4denvar_T126_datges="$casesdir/global/sigmap/$global_4denvar_T126_adate" export global_4denvar_T126_datobs="$casesdir/global/sigmap/$global_4denvar_T126_adate" +export global_fv3_4denvar_T126_datges="$casesdir/global/fv3/$global_fv3_4denvar_T126_adate" +export global_fv3_4denvar_T126_datobs=$global_fv3_4denvar_T126_datges export global_hybrid_T126_datges="$casesdir/global/sigmap/$global_hybrid_T126_adate/ges" -export global_enkf_T62_datobs="$casesdir/global/sigmap/$global_enkf_T62_adate/obs" +export global_enkf_T62_datobs="$casesdir/global/sigmap/$global_enkf_T62_adate/new_obs" export global_enkf_T62_datges="$casesdir/global/sigmap/$global_enkf_T62_adate/ges" export global_lanczos_T62_obs="$casesdir/global/sigmap/$global_lanczos_T62_adate" export global_lanczos_T62_ges="$casesdir/global/sigmap/$global_lanczos_T62_adate" @@ -205,6 +268,10 @@ export rtma_obs="$casesdir/regional/rtma_binary/$rtma_adate" export rtma_ges="$casesdir/regional/rtma_binary/$rtma_adate" export hwrf_nmm_obs="$casesdir/regional/hwrf_nmm/$hwrf_nmm_adate" export hwrf_nmm_ges="$casesdir/regional/hwrf_nmm/$hwrf_nmm_adate" +export fv3_netcdf_obs="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate" +export fv3_netcdf_ges="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate" +export global_C96_fv3aero_obs="$casesdir/global/fv3/$global_C96_fv3aero_adate" +export global_C96_fv3aero_ges="$casesdir/global/fv3/$global_C96_fv3aero_adate" # Define type of GPSRO data to be assimilated (refractivity or bending angle) export gps_dtype="gps_bnd" diff --git a/regression/rtma.sh b/regression/rtma.sh index 8f2cf4383..0080da3a4 100755 --- a/regression/rtma.sh +++ b/regression/rtma.sh @@ -22,6 +22,7 @@ tmpdir=$tmpdir/tmpreg_rtma/${exp} savdir=$savdir/outreg/rtma/${exp} # Specify GSI fixed field and data directories. +#fixcrtm=${fixcrtm:-$CRTM_FIX} # possible future use #datobs=$datobs_rtma/$adate #datges=$datobs @@ -117,6 +118,7 @@ errtable=$fixgsi/rtma_errtable.r3dv convinfo=$fixgsi/rtma_convinfo.txt mesonetuselist=$fixgsi/rtma_mesonet_uselist.txt mesonet_stnuselist=$fixgsi/rtma_ruc2_wind-uselist-noMETAR.dat +mesonet_stnuselist_for_vis=$fixgsi/rtma_mesonet_vis_uselist.txt wbinuselist=$fixgsi/rtma_wbinuselist slmask=$fixgsi/$endianness/rtma_conus_slmask.dat terrain=$fixgsi/$endianness/rtma_conus_terrain.dat @@ -131,7 +133,6 @@ btable_ps=$fixgsi/urma2p5.nlqc_b_ps.njqc btable_t=$fixgsi/urma2p5.nlqc_b_t.njqc btable_q=$fixgsi/urma2p5.nlqc_b_q.njqc btable_uv=$fixgsi/urma2p5.nlqc_b_uv.njqc - t_rejectlist=$fixgsi/rtma_t_rejectlist p_rejectlist=$fixgsi/rtma_p_rejectlist q_rejectlist=$fixgsi/rtma_q_rejectlist @@ -192,6 +193,7 @@ $ncp $convinfo ./convinfo $ncp $errtable ./errtable $ncp $mesonetuselist ./mesonetuselist $ncp $mesonet_stnuselist ./mesonet_stnuselist +$ncp $mesonet_stnuselist_for_vis ./mesonet_stnuselist_for_vis $ncp $wbinuselist ./wbinuselist $ncp $slmask ./rtma_slmask.dat $ncp $terrain ./rtma_terrain.dat diff --git a/scripts/exglobal_analysis.sh.ecf b/scripts/exglobal_analysis.sh.ecf index e989a6e4a..97566ebbc 100755 --- a/scripts/exglobal_analysis.sh.ecf +++ b/scripts/exglobal_analysis.sh.ecf @@ -41,6 +41,7 @@ # 2016-05-01 Yanqiu Zhu Add RADCLOUDINFO and use satinfo with icloud & iaerosol # 2016-05-10 J. Jung Added RARS and direct broadcast data # 2016-08-28 X. Li Introduce USE_READIN_ANL_SFCMASK for surface mask consistency between analysis and ensemble grids +# 2018-10-24 Karina Apodaca add processing of GOES-GLM light # # Usage: global_analysis.sh SFCGES SIGGES NSTGES GBIAS GBIASPC GRADSTAT GBIASAIR # SFCANL SIGANL NSTANL ABIAS ABIASPC ABIASAIR IGEN @@ -164,6 +165,8 @@ # defaults to ${COMIN}/${PREINP}cnvstat # OZNSTAT Output ozone observation assimilation statistics # defaults to ${COMIN}/${PREINP}oznstat +# LIGSTAT Output lightning observation assimilation statistics +# defaults to ${COMIN}/${PREINP}ligstat # GINCOUT Output increment to guess # defaults to ${COMIN}/${PREINP}gesfile_out # BIASOUT Output bias correction to guess @@ -240,6 +243,8 @@ # defaults to ${FIXgsm}/global_scaninfo.txt # HYBENSINFO Input hybrid ensemble localization information file # defaults to ${FIXgsm}/global_hybens_locinfo.l${LEVS}.txt +# LIGHTINFO Input lightning information file +# defaults to ${FIXgsm}/global_lightinfo.txt # PREPQC Input QC-ed observation BUFR file # defaults to ${COMIN}/${PREINP}prepbufr${SUFINP} # PREPQCPF Input QC-ed observation profile BUFR file @@ -254,6 +259,8 @@ # defaults to ${COMIN}/${PREINP}goesnd.tm00.bufr_d${SUFINP} # GSNDBF1 Input GOES 1x1 sounder radiance file (bufr format) # defaults to ${COMIN}/${PREINP}goesfv.tm00.bufr_d${SUFINP} +# GLMBF Input GOES-16/GLM lightning flash rate file +# defaults to ${COMIN}/${PREINP}glm.tm00.bufr_d${SUFINP} # B1HRS2 Input HIRS/2 radiance file (bufr format) # defaults to ${COMIN}/${PREINP}1bhrs2.tm00.bufr_d${SUFINP} # B1MSU Input MSU radiance file (bufr format) @@ -506,6 +513,7 @@ # $SMIPCP # $TMIPCP # $GPSROBF +# $G16GLMBF # $TCVITL # $NSSTBF # $B1AVHAM @@ -522,6 +530,7 @@ # $PCPSTAT # $CNVSTAT # $OZNSTAT +# $LIGSTAT # $GINCOUT # $BIASOUT # $PGMOUT @@ -636,6 +645,7 @@ export PCPINFO=${PCPINFO:-${FIXgsi}/global_pcpinfo.txt} export AEROINFO=${AEROINFO:-${FIXgsi}/global_aeroinfo.txt} export SCANINFO=${SCANINFO:-${FIXgsi}/global_scaninfo.txt} export HYBENSINFO=${HYBENSINFO:-${FIXgsi}/global_hybens_locinfo.l${LEVS}.txt} +export LIGHTINFO=${LIGHTINFO:-${FIXgsi}/global_lightinfo.txt} export OBERROR=${OBERROR:-${FIXgsi}/prepobs_errtable.global} export PREPQC=${PREPQC:-${COMIN}/${PREINP}prepbufr${SUFINP}} export PREPQCPF=${PREPQCPF:-${COMIN}/${PREINP}prepbufr.acft_profiles${SUFINP}} @@ -740,6 +750,7 @@ export GSISTAT=${GSISTAT:-${COMOUT}/${PREINP}gsistat} export PCPSTAT=${PCPSTAT:-${COMOUT}/${PREINP}pcpstat} export CNVSTAT=${CNVSTAT:-${COMOUT}/${PREINP}cnvstat} export OZNSTAT=${OZNSTAT:-${COMOUT}/${PREINP}oznstat} +export LIGSTAT=${LIGSTAT:-${COMOUT}/${PREINP}ligstat} export RUN_SELECT=${RUN_SELECT:-"NO"} export USE_SELECT=${USE_SELECT:-"NO"} export SELECT_OBS=${SELECT_OBS:-${COMOUT}/${PREINP}obsinput} @@ -838,10 +849,6 @@ else mkdir -p $DATA mkdata=YES fi -if ls ${FIXgsi}/Rcov* 1> /dev/null 2>&1; -then - $NCP ${FIXgsi}/Rcov* $DATA -fi cd $DATA||exit 99 ################################################################################ @@ -922,8 +929,23 @@ $FCPLN $PCPINFO pcpinfo $FCPLN $AEROINFO aeroinfo $FCPLN $SCANINFO scaninfo $FCPLN $HYBENSINFO hybens_info +$FCPLN $LIGHTINFO lightinfo $FCPLN $OBERROR errtable +#If using correlated error, link to the covariance files +if grep -q "Rcov" $ANAVINFO ; +then + if ls ${FIXgsi}/Rcov* 1> /dev/null 2>&1; + then + $NLN ${FIXgsi}/Rcov* $DATA + else + echo "Warning: Satellite error covariance files are missing." + echo "Check for the required files in " $ANAVINFO + exit 1 + fi +fi + + # CRTM Spectral and Transmittance coefficients mkdir -p crtm_coeffs for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do @@ -993,6 +1015,7 @@ $FCPLN $ATMSDB atmsbufr_db $FCPLN $SSMITBF ssmitbufr $FCPLN $SSMISBF ssmisbufr $FCPLN $GPSROBF gpsrobufr +$FCPLN $GLMBF glmbufr $FCPLN $TCVITL tcvitl $FCPLN $NSSTBF nsstbufr $FCPLN $B1AVHAM avhambufr @@ -1264,7 +1287,7 @@ cat < gsiparm.anl &OBSQC dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04, use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.true., - aircraft_t_bc=.true.,biaspredt=1000.0,upd_aircraft=.true., + aircraft_t_bc=.true.,biaspredt=1000.0,upd_aircraft=.true.,cleanup_tail=.true., $OBSQC / &OBS_INPUT @@ -1362,6 +1385,7 @@ OBS_INPUT:: saphirbufr saphir meghat saphir_meghat 0.0 3 0 ahibufr ahi himawari8 ahi_himawari8 0.0 3 0 rapidscatbufr uv null uv 0.0 0 0 + glmbufr light g16 light 0.0 0 0 :: &SUPEROB_RADAR $SUPERRAD @@ -1512,17 +1536,20 @@ ntype=3 diagtype[0]="conv" diagtype[1]="pcp_ssmi_dmsp pcp_tmi_trmm" diagtype[2]="sbuv2_n16 sbuv2_n17 sbuv2_n18 sbuv2_n19 gome_metop-a gome_metop-b omi_aura mls30_aura" -diagtype[3]="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 sndrd1_g14 sndrd2_g14 sndrd3_g14 sndrd4_g14 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 imgr_g14 imgr_g15 ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_f16 ssmis_f17 ssmis_f18 ssmis_f19 ssmis_f20 iasi_metop-a hirs4_n19 amsua_n19 mhs_n19 seviri_m08 seviri_m09 seviri_m10 cris_npp cris-fsr_npp cris-fsr_n20 atms_npp atms_n20 hirs4_metop-b amsua_metop-b mhs_metop-b iasi_metop-b avhrr_n18 avhrr_metop-a amsr2_gcom-w1 gmi_gpm saphir_meghat ahi_himawari8" +diagtype[3]="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 sndrd1_g14 sndrd2_g14 sndrd3_g14 sndrd4_g14 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 imgr_g14 imgr_g15 ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_f16 ssmis_f17 ssmis_f18 ssmis_f19 ssmis_f20 iasi_metop-a hirs4_n19 amsua_n19 mhs_n19 seviri_m08 seviri_m09 seviri_m10 seviri_m11 cris_npp cris-fsr_npp cris-fsr_n20 atms_npp atms_n20 hirs4_metop-b amsua_metop-b mhs_metop-b iasi_metop-b avhrr_n18 avhrr_metop-a amsr2_gcom-w1 gmi_gpm saphir_meghat ahi_himawari8" +diagtype[4]="light" diaglist[0]=listcnv diaglist[1]=listpcp diaglist[2]=listozn diaglist[3]=listrad +diaglist[4]=listlig diagfile[0]=$CNVSTAT diagfile[1]=$PCPSTAT diagfile[2]=$OZNSTAT diagfile[3]=$RADSTAT +diagfile[4]=$LIGSTAT numfile[0]=0 numfile[1]=0 diff --git a/scripts/exglobal_analysis_fv3gfs.sh.ecf b/scripts/exglobal_analysis_fv3gfs.sh.ecf index f5b7d7d88..97ee8e915 100755 --- a/scripts/exglobal_analysis_fv3gfs.sh.ecf +++ b/scripts/exglobal_analysis_fv3gfs.sh.ecf @@ -30,12 +30,13 @@ export NWPROD=${NWPROD:-$pwd} export HOMEgfs=${HOMEgfs:-$NWPROD} export HOMEgsi=${HOMEgsi:-$NWPROD} FIXgsi=${FIXgsi:-$HOMEgsi/fix} -GSIEXEC=${GSIEXEC:-$HOMEgsi/exec/global_gsi} +GSIEXEC=${GSIEXEC:-$HOMEgsi/exec/global_gsi.x} export DATA=${DATA:-$pwd/analysis.$$} -DMPDIR=${DMPDIR:-$NWPROD} export COMIN=${COMIN:-$pwd} +export COMIN_OBS=${COMIN_OBS:-$COMIN} export COMIN_GES=${COMIN_GES:-$COMIN} -export COMIN_GES_ENS=${COMIN_GES_ENS:-$COMIN} +export COMIN_GES_ENS=${COMIN_GES_ENS:-$COMIN_GES} +export COMIN_GES_OBS=${COMIN_GES_OBS:-$COMIN_GES} export COMOUT=${COMOUT:-$COMIN} # Base variables @@ -43,12 +44,21 @@ CDATE=${CDATE:-"2001010100"} CDUMP=${CDUMP:-"gdas"} GDUMP=${GDUMP:-"gdas"} +# Derived base variables +GDATE=$($NDATE -$assim_freq $CDATE) +BDATE=$($NDATE -3 $CDATE) +PDY=$(echo $CDATE | cut -c1-8) +cyc=$(echo $CDATE | cut -c9-10) +bPDY=$(echo $BDATE | cut -c1-8) +bcyc=$(echo $BDATE | cut -c9-10) + # Utilities export NCP=${NCP:-"/bin/cp"} export NMV=${NMV:-"/bin/mv"} export NLN=${NLN:-"/bin/ln -sf"} export CHGRP_CMD=${CHGRP_CMD:-"chgrp ${group_name:-rstprod}"} export NEMSIOGET=${NEMSIOGET:-${NWPROD}/exec/nemsio_get} +export CATEXEC=${CATEXEC:-$HOMEgsi/exec/nc_diag_cat_serial.x} export ERRSCRIPT=${ERRSCRIPT:-'eval [[ $err = 0 ]]'} COMPRESS=${COMPRESS:-gzip} UNCOMPRESS=${UNCOMPRESS:-gunzip} @@ -79,13 +89,18 @@ APRUN_GAUSFCANL=${APRUN_GAUSFCANL:-${APRUN:-""}} export CASE=${CASE:-"C384"} ntiles=${ntiles:-6} -# Write component specific -QUILTING=${QUILTING:-".true."} - # Microphysics in the model; 99:ZC, 11:GFDLMP imp_physics=${imp_physics:-99} lupp=${lupp:-".true."} +# Diagnostic files options +lobsdiag_forenkf=${lobsdiag_forenkf:-".false."} +netcdf_diag=${netcdf_diag:-".false."} +binary_diag=${binary_diag:-".true."} + +# IAU +DOIAU=${DOIAU:-"NO"} + # Dependent Scripts and Executables NTHREADS_CALCINC=${NTHREADS_CALCINC:-1} APRUN_CALCINC=${APRUN_CALCINC:-${APRUN:-""}} @@ -102,7 +117,6 @@ export gesenvir=${gesenvir:-$envir} # Observations OPREFIX=${OPREFIX:-""} OSUFFIX=${OSUFFIX:-""} -COMIN_OBS=${COMIN_OBS:-"$DMPDIR/$CDATE/$CDUMP"} PREPQC=${PREPQC:-${COMIN_OBS}/${OPREFIX}prepbufr${OSUFFIX}} PREPQCPF=${PREPQCPF:-${COMIN_OBS}/${OPREFIX}prepbufr.acft_profiles${OSUFFIX}} NSSTBF=${NSSTBF:-${COMIN_OBS}/${OPREFIX}nsstbufr${OSUFFIX}} @@ -148,9 +162,12 @@ ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}} SSMITBF=${SSMITBF:-${COMIN_OBS}/${OPREFIX}ssmit.tm00.bufr_d${OSUFFIX}} SSMISBF=${SSMISBF:-${COMIN_OBS}/${OPREFIX}ssmisu.tm00.bufr_d${OSUFFIX}} SBUVBF=${SBUVBF:-${COMIN_OBS}/${OPREFIX}osbuv8.tm00.bufr_d${OSUFFIX}} +OMPSNPBF=${OMPSNPBF:-${COMIN_OBS}/${OPREFIX}ompsn8.tm00.bufr_d${OSUFFIX}} +OMPSTCBF=${OMPSTCBF:-${COMIN_OBS}/${OPREFIX}ompst8.tm00.bufr_d${OSUFFIX}} GOMEBF=${GOMEBF:-${COMIN_OBS}/${OPREFIX}gome.tm00.bufr_d${OSUFFIX}} OMIBF=${OMIBF:-${COMIN_OBS}/${OPREFIX}omi.tm00.bufr_d${OSUFFIX}} MLSBF=${MLSBF:-${COMIN_OBS}/${OPREFIX}mls.tm00.bufr_d${OSUFFIX}} +OMPSLPBF=${OMPSLPBF:-${COMIN_OBS}/${OPREFIX}ompslp.tm00.bufr_d${OSUFFIX}} SMIPCP=${SMIPCP:-${COMIN_OBS}/${OPREFIX}spssmi.tm00.bufr_d${OSUFFIX}} TMIPCP=${TMIPCP:-${COMIN_OBS}/${OPREFIX}sptrmm.tm00.bufr_d${OSUFFIX}} GPSROBF=${GPSROBF:-${COMIN_OBS}/${OPREFIX}gpsro.tm00.bufr_d${OSUFFIX}} @@ -203,6 +220,9 @@ USE_RADSTAT=${USE_RADSTAT:-"YES"} SELECT_OBS=${SELECT_OBS:-${COMOUT}/${APREFIX}obsinput} GENDIAG=${GENDIAG:-"YES"} DIAG_SUFFIX=${DIAG_SUFFIX:-""} +if [ $netcdf_diag = ".true." ] ; then + DIAG_SUFFIX="${DIAG_SUFFIX}.nc4" +fi DIAG_COMPRESS=${DIAG_COMPRESS:-"YES"} DIAG_TARBALL=${DIAG_TARBALL:-"YES"} USE_CFP=${USE_CFP:-"NO"} @@ -210,7 +230,7 @@ USE_CFP=${USE_CFP:-"NO"} # Set script / GSI control parameters DOHYBVAR=${DOHYBVAR:-"NO"} NMEM_ENKF=${NMEM_ENKF:-0} -DONST=${DONST:-"NO"} +export DONST=${DONST:-"NO"} NST_GSI=${NST_GSI:-0} NSTINFO=${NSTINFO:-0} ZSEA1=${ZSEA1:-0} @@ -223,53 +243,27 @@ SMOOTH_ENKF=${SMOOTH_ENKF:-"YES"} DOIAU=${DOIAU:-"NO"} DO_CALC_INCREMENT=${DO_CALC_INCREMENT:-"YES"} INCREMENTS_TO_ZERO=${INCREMENTS_TO_ZERO:-"'NONE'"} +USE_CORRELATED_OBERRS=${USE_CORRELATED_OBERRS:-"YES"} # Get header information from Guess files -LONB=${LONB:-$($NEMSIOGET $ATMGES dimx | grep -i "dimx" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} -status=$? -[[ $status -ne 0 ]] && exit $status -LATB=${LATB:-$($NEMSIOGET $ATMGES dimy | grep -i "dimy" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} -status=$? -[[ $status -ne 0 ]] && exit $status -LEVS=${LEVS:-$($NEMSIOGET $ATMGES dimz | grep -i "dimz" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} -status=$? -[[ $status -ne 0 ]] && exit $status -if [ $QUILTING = ".false." ]; then - JCAP=${JCAP:-$($NEMSIOGET $ATMGES jcap | grep -i "jcap" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} - status=$? - [[ $status -ne 0 ]] && exit $status -else - # using write component - JCAP=${JCAP:-$((LATB-2))} -fi - -#CDATE=${CDATE:-$($NEMSIOGET $ATMGES fcstdate | grep -i "fcstdate_ymdh" | awk -F= '{print $2}')} -PDY=$(echo $CDATE | cut -c1-8) -cyc=$(echo $CDATE | cut -c9-10) -GDATE=$($NDATE -$assim_freq $CDATE) -gPDY=$(echo $GDATE | cut -c1-8) -gcyc=$(echo $GDATE | cut -c9-10) +LONB=${LONB:-$($NEMSIOGET $ATMGES dimx | grep -i "dimx" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} # 'get LONB +LATB=${LATB:-$($NEMSIOGET $ATMGES dimy | grep -i "dimy" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} # 'get LATB +LEVS=${LEVS:-$($NEMSIOGET $ATMGES dimz | grep -i "dimz" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} # 'get LEVS +JCAP=${JCAP:-$($NEMSIOGET $ATMGES jcap | grep -i "jcap" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} # 'get JCAP +[ $JCAP -eq -9999 -a $LATB -ne -9999 ] && JCAP=$((LATB-2)) +[ $LONB -eq -9999 -o $LATB -eq -9999 -o $LEVS -eq -9999 -o $JCAP -eq -9999 ] && exit -9999 # Get header information from Ensemble Guess files if [ $DOHYBVAR = "YES" ]; then SFCGES_ENSMEAN=${SFCGES_ENSMEAN:-${COMIN_GES_ENS}/${GPREFIX}sfcf006.ensmean${GSUFFIX}} ATMGES_ENSMEAN=${ATMGES_ENSMEAN:-${COMIN_GES_ENS}/${GPREFIX}atmf006.ensmean${GSUFFIX}} - LONB_ENKF=${LONB_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimx | grep -i "dimx" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} - status=$? - [[ $status -ne 0 ]] && exit $status - LATB_ENKF=${LATB_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimy | grep -i "dimy" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} - status=$? - [[ $status -ne 0 ]] && exit $status + LONB_ENKF=${LONB_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimx | grep -i "dimx" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} # 'get LONB_ENKF + LATB_ENKF=${LATB_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN dimy | grep -i "dimy" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} # 'get LATB_ENKF NLON_ENKF=${NLON_ENKF:-$LONB_ENKF} NLAT_ENKF=${NLAT_ENKF:-$(($LATB_ENKF+2))} - if [ $QUILTING = ".false." ]; then - JCAP_ENKF=${JCAP_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN jcap | grep -i "jcap" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} - status=$? - [[ $status -ne 0 ]] && exit $status - else - # using write component - JCAP_ENKF=${JCAP_ENKF:-$((LATB_ENKF-2))} - fi + JCAP_ENKF=${JCAP_ENKF:-$($NEMSIOGET $ATMGES_ENSMEAN jcap | grep -i "jcap" | awk -F"= " '{print $2}' | awk -F" " '{print $1}')} # 'get JCAP_ENKF + [ $JCAP_ENKF -eq -9999 -a $LATB_ENKF -ne -9999 ] && JCAP_ENKF=$((LATB_ENKF-2)) + [ $LONB_ENKF -eq -9999 -o $LATB_ENKF -eq -9999 -o $LEVS_ENKF -eq -9999 -o $JCAP_ENKF -eq -9999 ] && exit -9999 fi # Get dimension information based on CASE @@ -294,7 +288,7 @@ NLAT_A=${NLAT_A:-$(($LATA+2))} DELTIM=${DELTIM:-$((3600/($JCAP_A/20)))} # GSI Fix files -RTMFIX=${RTMFIX:-$NWROOT/lib/crtm/${crtm_ver}/fix} +RTMFIX=${RTMFIX:-${CRTM_FIX}} BERROR=${BERROR:-${FIXgsi}/Big_Endian/global_berror.l${LEVS}y${NLAT_A}.f77} SATANGL=${SATANGL:-${FIXgsi}/global_satangbias.txt} SATINFO=${SATINFO:-${FIXgsi}/global_satinfo.txt} @@ -351,7 +345,12 @@ fi ################################################################################ # Preprocessing -if [ ! -d $DATA ]; then mkdir -p $DATA; fi +mkdata=NO +if [ ! -d $DATA ]; then + mkdata=YES + mkdir -p $DATA +fi + cd $DATA || exit 99 ################################################################################ @@ -367,7 +366,7 @@ rm gpsrobufr rm tcvitl rm gsndrbufr gsnd1bufr rm ssmisbufr ssmitbufr ssmirrbufr tmirrbufr -rm sbuvbufr gomebufr omibufr mlsbufr msubufr +rm sbuvbufr gomebufr omibufr mlsbufr msubufr ompsnpbufr ompstcbufr rm airsbufr rm iasibufr iasibufrears iasibufr_db rm amsrebufr amsr2bufr @@ -409,6 +408,21 @@ $NLN $SCANINFO scaninfo $NLN $HYBENSINFO hybens_info $NLN $OBERROR errtable +#If using correlated error, link to the covariance files +if [ $USE_CORRELATED_OBERRS = "YES" ]; then + if grep -q "Rcov" $ANAVINFO ; + then + if ls ${FIXgsi}/Rcov* 1> /dev/null 2>&1; + then + $NLN ${FIXgsi}/Rcov* $DATA + else + echo "Warning: Satellite error covariance files are missing." + echo "Check for the required Rcov files in " $ANAVINFO + exit 1 + fi + fi +fi + ############################################################## # CRTM Spectral and Transmittance coefficients mkdir -p crtm_coeffs @@ -454,6 +468,8 @@ $NLN $AMUADB amsuabufr_db $NLN $AMUBDB amsubbufr_db #$NLN $MHSDB mhsbufr_db $NLN $SBUVBF sbuvbufr +$NLN $OMPSNPBF ompsnpbufr +$NLN $OMPSTCBF ompstcbufr $NLN $GOMEBF gomebufr $NLN $OMIBF omibufr $NLN $MLSBF mlsbufr @@ -602,11 +618,12 @@ if [ $USE_RADSTAT = "YES" ]; then cat > $DATA/unzip.sh << EOFunzip #!/bin/sh diag_file=\$1 + diag_suffix=\$2 fname=\$(echo \$diag_file | cut -d'.' -f1) fdate=\$(echo \$diag_file | cut -d'.' -f2) $UNCOMPRESS \$diag_file fnameges=\$(echo \$fname | sed 's/_ges//g') - $NMV \$fname.\$fdate \$fnameges + $NMV \$fname.\$fdate\$diag_suffix \$fnameges EOFunzip chmod 755 $DATA/unzip.sh fi @@ -615,13 +632,13 @@ EOFunzip for type in $listdiag; do diag_file=$(echo $type | cut -d',' -f1) if [ $USE_CFP = "YES" ] ; then - echo "$DATA/unzip.sh $diag_file" | tee -a $DATA/mp_unzip.sh + echo "$DATA/unzip.sh $diag_file $DIAG_SUFFIX" | tee -a $DATA/mp_unzip.sh else fname=$(echo $diag_file | cut -d'.' -f1) date=$(echo $diag_file | cut -d'.' -f2) $UNCOMPRESS $diag_file fnameges=$(echo $fname|sed 's/_ges//g') - $NMV $fname.$date $fnameges + $NMV $fname.$date$DIAG_SUFFIX $fnameges fi done @@ -662,7 +679,7 @@ cat > gsiparm.anl << EOF write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., qoption=2, gencode=${IGEN:-0},deltim=$DELTIM, - factqmin=5.0,factqmax=0.005, + factqmin=0.5,factqmax=0.0002, iguess=-1, tzr_qc=$TZR_QC, oneobtest=.false.,retrieval=.false.,l_foto=.false., @@ -674,6 +691,8 @@ cat > gsiparm.anl << EOF newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false., diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,nhr_obsbin=${nhr_obsbin:-3}, cwoption=3,imp_physics=$imp_physics,lupp=$lupp, + netcdf_diag=$netcdf_diag,binary_diag=$binary_diag, + lobsdiag_forenkf=$lobsdiag_forenkf, $SETUP / &GRIDOPTS @@ -706,7 +725,7 @@ cat > gsiparm.anl << EOF &OBSQC dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.02, use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.true., - aircraft_t_bc=.true.,biaspredt=1000.0,upd_aircraft=.true., + aircraft_t_bc=.true.,biaspredt=1000.0,upd_aircraft=.true.,cleanup_tail=.true., $OBSQC / &OBS_INPUT @@ -753,7 +772,6 @@ OBS_INPUT:: ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 ssmisbufr ssmis f17 ssmis_f17 0.0 1 0 ssmisbufr ssmis f18 ssmis_f18 0.0 1 0 - ssmisbufr ssmis f19 ssmis_f19 0.0 1 0 gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 @@ -777,6 +795,7 @@ OBS_INPUT:: seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 @@ -804,6 +823,10 @@ OBS_INPUT:: saphirbufr saphir meghat saphir_meghat 0.0 3 0 ahibufr ahi himawari8 ahi_himawari8 0.0 3 0 rapidscatbufr uv null uv 0.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 + amsuabufr amsua metop-c amsua_metop-c 0.0 1 1 + mhsbufr mhs metop-c mhs_metop-c 0.0 1 1 :: &SUPEROB_RADAR $SUPERRAD @@ -907,8 +930,8 @@ if [ $DOGCYCLE = "YES" ]; then export FNACNA=${FNACNA:-$COMIN_OBS/${OPREFIX}seaice.5min.blend.grb} export FNSNOA=${FNSNOA:-$COMIN_OBS/${OPREFIX}snogrb_t${JCAP_CASE}.${LONB_CASE}.${LATB_CASE}} [[ ! -f $FNSNOA ]] && export FNSNOA="$COMIN_OBS/${OPREFIX}snogrb_t1534.3072.1536" - FNSNOG=${FNSNOG:-$DMPDIR/$GDATE/$GDUMP/${GDUMP}.t${gcyc}z.snogrb_t${JCAP_CASE}.${LONB_CASE}.${LATB_CASE}} - [[ ! -f $FNSNOG ]] && FNSNOG="$DMPDIR/$GDATE/$GDUMP/${GDUMP}.t${gcyc}z.snogrb_t1534.3072.1536" + FNSNOG=${FNSNOG:-$COMIN_GES_OBS/${GPREFIX}snogrb_t${JCAP_CASE}.${LONB_CASE}.${LATB_CASE}} + [[ ! -f $FNSNOG ]] && FNSNOG="$COMIN_GES_OBS/${GPREFIX}snogrb_t1534.3072.1536" # Set CYCLVARS by checking grib date of current snogrb vs that of prev cycle if [ $RUN_GETGES = "YES" ]; then @@ -934,6 +957,27 @@ if [ $DOGCYCLE = "YES" ]; then export GSI_FILE="NULL" fi + if [ $DOIAU = "YES" ]; then + # update surface restarts at the beginning of the window, if IAU + # For now assume/hold dtfanl.nc valid at beginning of window + for n in $(seq 1 $ntiles); do + $NLN $COMIN_GES/RESTART/$bPDY.${bcyc}0000.sfc_data.tile${n}.nc $DATA/fnbgsi.00$n + $NLN $COMOUT/RESTART/$bPDY.${bcyc}0000.sfcanl_data.tile${n}.nc $DATA/fnbgso.00$n + $NLN $FIXfv3/$CASE/${CASE}_grid.tile${n}.nc $DATA/fngrid.00$n + $NLN $FIXfv3/$CASE/${CASE}_oro_data.tile${n}.nc $DATA/fnorog.00$n + done + + export APRUNCY=$APRUN_CYCLE + export OMP_NUM_THREADS_CY=$NTHREADS_CYCLE + export MAX_TASKS_CY=$ntiles + + $CYCLESH + rc=$? + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 11 + fi + # update surface restarts at middle of window for n in $(seq 1 $ntiles); do $NLN $COMIN_GES/RESTART/$PDY.${cyc}0000.sfc_data.tile${n}.nc $DATA/fnbgsi.00$n $NLN $COMOUT/RESTART/$PDY.${cyc}0000.sfcanl_data.tile${n}.nc $DATA/fnbgso.00$n @@ -951,7 +995,7 @@ if [ $DOGCYCLE = "YES" ]; then export err=$ERR $ERRSCRIPT || exit 11 - # Create gaussian grid surface analysis file + # Create gaussian grid surface analysis file at middle of window if [ $DOGAUSFCANL = "YES" ]; then export APRUNSFC=$APRUN_GAUSFCANL export OMP_NUM_THREADS_SFC=$NTHREADS_GAUSFCANL @@ -1005,10 +1049,10 @@ if [ $GENDIAG = "YES" ] ; then # Set up lists and variables for various types of diagnostic files. ntype=3 - diagtype[0]="conv" + diagtype[0]="conv conv_gps conv_ps conv_q conv_sst conv_t conv_uv" diagtype[1]="pcp_ssmi_dmsp pcp_tmi_trmm" - diagtype[2]="sbuv2_n16 sbuv2_n17 sbuv2_n18 sbuv2_n19 gome_metop-a gome_metop-b omi_aura mls30_aura" - diagtype[3]="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 sndrd1_g14 sndrd2_g14 sndrd3_g14 sndrd4_g14 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 imgr_g14 imgr_g15 ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_f16 ssmis_f17 ssmis_f18 ssmis_f19 ssmis_f20 iasi_metop-a hirs4_n19 amsua_n19 mhs_n19 seviri_m08 seviri_m09 seviri_m10 cris_npp cris-fsr_npp cris-fsr_n20 atms_npp atms_n20 hirs4_metop-b amsua_metop-b mhs_metop-b iasi_metop-b avhrr_n18 avhrr_metop-a amsr2_gcom-w1 gmi_gpm saphir_meghat ahi_himawari8" + diagtype[2]="sbuv2_n16 sbuv2_n17 sbuv2_n18 sbuv2_n19 gome_metop-a gome_metop-b omi_aura mls30_aura ompsnp_npp ompstc8_npp gome_metop-c" + diagtype[3]="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 sndrd1_g14 sndrd2_g14 sndrd3_g14 sndrd4_g14 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 imgr_g14 imgr_g15 ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_f16 ssmis_f17 ssmis_f18 ssmis_f19 ssmis_f20 iasi_metop-a hirs4_n19 amsua_n19 mhs_n19 seviri_m08 seviri_m09 seviri_m10 seviri_m11 cris_npp cris-fsr_npp cris-fsr_n20 atms_npp atms_n20 hirs4_metop-b amsua_metop-b mhs_metop-b iasi_metop-b avhrr_metop-b avhrr_n18 avhrr_metop-a amsr2_gcom-w1 gmi_gpm saphir_meghat ahi_himawari8 amsua_metop-c mhs_metop-c iasi_metop-c avhrr_metop-c" diaglist[0]=listcnv diaglist[1]=listpcp @@ -1037,19 +1081,24 @@ if [ $GENDIAG = "YES" ] ; then cat > $DATA/diag.sh << EOFdiag #!/bin/sh lrun_subdirs=\$1 -type=\$2 -loop=\$3 -string=\$4 -CDATE=\$5 -DIAG_COMPRESS=\$6 -DIAG_SUFFIX=\$7 +binary_diag=\$2 +type=\$3 +loop=\$4 +string=\$5 +CDATE=\$6 +DIAG_COMPRESS=\$7 +DIAG_SUFFIX=\$8 if [ \$lrun_subdirs = ".true." ]; then prefix=" dir.*/" else prefix="pe*" fi file=diag_\${type}_\${string}.\${CDATE}\${DIAG_SUFFIX} -cat \${prefix}\${type}_\${loop}* > \$file +if [ \$binary_diag = ".true." ]; then + cat \${prefix}\${type}_\${loop}* > \$file +else + $CATEXEC -o \$file \${prefix}\${type}_\${loop}* +fi if [ \$DIAG_COMPRESS = "YES" ]; then $COMPRESS \$file fi @@ -1082,9 +1131,13 @@ EOFdiag count=$(ls ${prefix}${type}_${loop}* | wc -l) if [ $count -gt 0 ]; then if [ $USE_CFP = "YES" ]; then - echo "$DATA/diag.sh $lrun_subdirs $type $loop $string $CDATE $DIAG_COMPRESS $DIAG_SUFFIX" | tee -a $DATA/mp_diag.sh + echo "$DATA/diag.sh $lrun_subdirs $binary_diag $type $loop $string $CDATE $DIAG_COMPRESS $DIAG_SUFFIX" | tee -a $DATA/mp_diag.sh else - cat ${prefix}${type}_${loop}* > diag_${type}_${string}.${CDATE}${DIAG_SUFFIX} + if [ $binary_diag = ".true." ]; then + cat ${prefix}${type}_${loop}* > diag_${type}_${string}.${CDATE}${DIAG_SUFFIX} + else + $CATEXEC -o diag_${type}_${string}.${CDATE}${DIAG_SUFFIX} ${prefix}${type}_${loop}* + fi fi echo "diag_${type}_${string}.${CDATE}*" >> ${diaglist[n]} numfile[n]=$(expr ${numfile[n]} + 1) @@ -1148,17 +1201,17 @@ fi # End diagnostic file generation block - if [ $GENDIAG = "YES" ] # Send alerts if [ $SENDDBN = "YES" ]; then if [ $RUN = "gdas" ]; then - $DBNROOT/bin/dbn_alert MODEL GDAS1RADSTAT $job $RADSTAT + $DBNROOT/bin/dbn_alert MODEL GDASRADSTAT $job $RADSTAT fi if [ $RUN = "gfs" ]; then - $DBNROOT/bin/dbn_alert MODEL GFS_abias $job $COMOUT/${APREFIX}abias + $DBNROOT/bin/dbn_alert MODEL GFS_abias $job $ABIAS fi fi ################################################################################ # Postprocessing cd $pwd -[[ ${KEEPDATA:-"NO"} = "NO" ]] && rm -rf $DATA +[[ $mkdata = "YES" ]] && rm -rf $DATA set +x if [ $VERBOSE = "YES" ]; then diff --git a/scripts/exglobal_enkf_fcst_fv3gfs.sh.ecf b/scripts/exglobal_enkf_fcst_fv3gfs.sh.ecf index badcb7cb8..7ed6cbdb6 100755 --- a/scripts/exglobal_enkf_fcst_fv3gfs.sh.ecf +++ b/scripts/exglobal_enkf_fcst_fv3gfs.sh.ecf @@ -32,7 +32,8 @@ export HOMEgfs=${HOMEgfs:-$NWPROD} export FIX_DIR=${FIX_DIR:-$HOMEgfs/fix} export FIX_AM=${FIX_AM:-$FIX_DIR/fix_am} export DATA=${DATA:-$pwd/enkf_fcst.$$} -export ROTDIR=${ROTDIR:-$pwd} +export COMIN=${COMIN:-$pwd} +export COMOUT=${COMOUT:-$COMIN} # Utilities export NCP=${NCP:-"/bin/cp -p"} @@ -66,10 +67,15 @@ RERUN_EFCSGRP=${RERUN_EFCSGRP:-"YES"} # Ops related stuff SENDECF=${SENDECF:-"NO"} +SENDDBN=${SENDDBN:-"NO"} ################################################################################ # Preprocessing -if [ ! -d $DATA ]; then mkdir -p $DATA; fi +mkdata=NO +if [ ! -d $DATA ]; then + mkdata=YES + mkdir -p $DATA +fi cd $DATA || exit 99 DATATOP=$DATA @@ -77,7 +83,7 @@ DATATOP=$DATA # Set output data cymd=$(echo $CDATE | cut -c1-8) chh=$(echo $CDATE | cut -c9-10) -EFCSGRP=$ROTDIR/enkf.${CDUMP}.${cymd}/$chh/efcs.grp${ENSGRP} +EFCSGRP=$COMOUT/efcs.grp${ENSGRP} if [ -f $EFCSGRP ]; then if [ $RERUN_EFCSGRP = "YES" ]; then rm -f $EFCSGRP @@ -124,7 +130,7 @@ export IAER=${IAER_ENKF:-${IAER:-111}} export ICO2=${ICO2_ENKF:-${ICO2:-2}} export cdmbgwd=${cdmbgwd_ENKF:-${cdmbgwd:-"3.5,0.25"}} export dspheat=${dspheat_ENKF:-${dspheat:-".true."}} -export shal_cnv=${shal_cnv_ENKF:-${shal_cnv:-".false."}} +export shal_cnv=${shal_cnv_ENKF:-${shal_cnv:-".true."}} export FHZER=${FHZER_ENKF:-${FHZER:-6}} export FHCYC=${FHCYC_ENKF:-${FHCYC:-6}} @@ -173,6 +179,17 @@ for imem in $(seq $ENSBEG $ENSEND); do fi + if [ $SENDDBN = YES ]; then + fhr=$FHOUT + while [ $fhr -le $FHMAX ]; do + FH3=$(printf %03i $fhr) + if [ $(expr $fhr % 3) -eq 0 ]; then + $DBNROOT/bin/dbn_alert MODEL GFS_ENKF $job $COMOUT/$memchar/${CDUMP}.t${cyc}z.sfcf${FH3}.nemsio + fi + fhr=$((fhr+FHOUT)) + done + fi + cd $DATATOP $NCP $EFCSGRP log_old @@ -203,7 +220,7 @@ $ERRSCRIPT || exit 2 ################################################################################ # Postprocessing cd $pwd -[[ ${KEEPDATA:-"NO"} = "NO" ]] && rm -rf $DATATOP +[[ $mkdata = "YES" ]] && rm -rf $DATATOP set +x if [ $VERBOSE = "YES" ] ; then echo $(date) EXITING $0 with return code $err >&2 diff --git a/scripts/exglobal_enkf_innovate_obs_fv3gfs.sh.ecf b/scripts/exglobal_enkf_innovate_obs_fv3gfs.sh.ecf index e864b0de0..bd8781154 100755 --- a/scripts/exglobal_enkf_innovate_obs_fv3gfs.sh.ecf +++ b/scripts/exglobal_enkf_innovate_obs_fv3gfs.sh.ecf @@ -64,7 +64,11 @@ export SELECT_OBS=${SELECT_OBS:-${COMOUT}/${APREFIX}obsinput} ################################################################################ # Preprocessing -if [ ! -d $DATA ]; then mkdir -p $DATA; fi +mkdata=NO +if [ ! -d $DATA ]; then + mkdata=YES + mkdir -p $DATA +fi cd $DATA || exit 99 DATATOP=$DATA @@ -185,7 +189,7 @@ $ERRSCRIPT || exit 2 ################################################################################ # Postprocessing cd $pwd -[[ ${KEEPDATA:-"NO"} = "NO" ]]&& rm -rf $DATA +[[ $mkdata = "YES" ]]&& rm -rf $DATATOP set +x if [ $VERBOSE = "YES" ] ; then echo $(date) EXITING $0 with return code $err >&2 diff --git a/scripts/exglobal_enkf_post_fv3gfs.sh.ecf b/scripts/exglobal_enkf_post_fv3gfs.sh.ecf index 899b33991..62c45149c 100755 --- a/scripts/exglobal_enkf_post_fv3gfs.sh.ecf +++ b/scripts/exglobal_enkf_post_fv3gfs.sh.ecf @@ -56,15 +56,19 @@ GETATMENSSTATEXEC=${GETATMENSSTATEXEC:-$HOMEgsi/exec/getsigensstatp.x} # Other variables. PREFIX=${PREFIX:-""} SUFFIX=${SUFFIX:-""} -FHMIN=${FHMIN_ENKF:-3} -FHMAX=${FHMAX_ENKF:-9} -FHOUT=${FHOUT_ENKF:-3} +FHMIN=${FHMIN_EPOS:-3} +FHMAX=${FHMAX_EPOS:-9} +FHOUT=${FHOUT_EPOS:-3} NMEM_ENKF=${NMEM_ENKF:-80} SMOOTH_ENKF=${SMOOTH_ENKF:-"YES"} ################################################################################ # Preprocessing -if [ ! -d $DATA ]; then mkdir -p $DATA; fi +mkdata=NO +if [ ! -d $DATA ]; then + mkdata=YES + mkdir -p $DATA +fi cd $DATA || exit 99 ENKF_SUFFIX="s" @@ -156,22 +160,21 @@ if [ $SENDDBN = "YES" ]; then fi done - for imem in $(seq 1 $NMEM_ENKF); do - memchar="mem"$(printf %03i $imem) - for fhr in $(seq 6 $FHOUT $FHMAX); do - fhrchar=$(printf %03i $fhr) - if [ $(expr $fhr % 3) -eq 0 ]; then - $DBNROOT/bin/dbn_alert MODEL GFS_ENKF $job $COMOUT/$memchar/${PREFIX}atmf${fhrchar}${ENKF_SUFFIX}${SUFFIX} - fi - done - done +# Maintain gfs.v14 dbn_alerts of 6 and 9 hour EnKF forecasts + if [ $FHMIN -eq 6 -o $FHMIN -eq 9 ]; then + fhrchar=$(printf %03i $FHMIN) + for imem in $(seq 1 $NMEM_ENKF); do + memchar="mem"$(printf %03i $imem) + $DBNROOT/bin/dbn_alert MODEL GFS_ENKF $job $COMOUT/$memchar/${PREFIX}atmf${fhrchar}${ENKF_SUFFIX}${SUFFIX} + done + fi fi ################################################################################ # Postprocessing cd $pwd -[[ ${KEEPDATA:-"NO"} = "NO" ]] && rm -rf $DATA +[[ $mkdata = "YES" ]] && rm -rf $DATA set +x if [ $VERBOSE = "YES" ]; then echo $(date) EXITING $0 with return code $err >&2 diff --git a/scripts/exglobal_enkf_recenter_fv3gfs.sh.ecf b/scripts/exglobal_enkf_recenter_fv3gfs.sh.ecf index 202ebe19a..bbf5279a5 100755 --- a/scripts/exglobal_enkf_recenter_fv3gfs.sh.ecf +++ b/scripts/exglobal_enkf_recenter_fv3gfs.sh.ecf @@ -31,10 +31,13 @@ export HOMEgfs=${HOMEgfs:-$NWPROD} HOMEgsi=${HOMEgsi:-$NWPROD} export DATA=${DATA:-$pwd} COMIN=${COMIN:-$pwd} -COMIN_ENS=${COMIN_ENS:-$pwd} -COMIN_GES_ENS=${COMIN_GES_ENS:-${COMIN_ENS:-$pwd}} +COMIN_ENS=${COMIN_ENS:-$COMIN} +COMIN_OBS=${COMIN_OBS:-$COMIN} +COMIN_GES=${COMIN_GES:-$COMIN} +COMIN_GES_ENS=${COMIN_GES_ENS:-$COMIN_ENS} +COMIN_GES_OBS=${COMIN_GES_OBS:-$COMIN_GES} COMOUT=${COMOUT:-$COMIN} -DMPDIR=${DMPDIR:-$NWPROD} +COMOUT_ENS=${COMOUT_ENS:-$COMIN_ENS} CDATE=${CDATE:-"2010010100"} DONST=${DONST:-"NO"} @@ -60,6 +63,7 @@ CALCINCEXEC=${CALCINCEXEC:-$HOMEgsi/exec/calc_increment_ens.x} OPREFIX=${OPREFIX:-""} OSUFFIX=${OSUFFIX:-""} APREFIX=${APREFIX:-""} +APREFIX_ENKF=${APREFIX_ENKF:-$APREFIX} ASUFFIX=${ASUFFIX:-""} GPREFIX=${GPREFIX:-""} GSUFFIX=${GSUFFIX:-""} @@ -68,6 +72,8 @@ GSUFFIX=${GSUFFIX:-""} NMEM_ENKF=${NMEM_ENKF:-80} imp_physics=${imp_physics:-99} INCREMENTS_TO_ZERO=${INCREMENTS_TO_ZERO:-"'NONE'"} +DOIAU=${DOIAU_ENKF:-"NO"} +IAUFHRS_ENKF=${IAUFHRS_ENKF:-6} # global_chgres stuff CHGRESEXEC=${CHGRESEXEC:-$HOMEgfs/exec/chgres_recenter.exe} @@ -77,6 +83,8 @@ APRUN_CHGRES=${APRUN_CHGRES:-""} # global_cycle stuff CYCLESH=${CYCLESH:-$HOMEgfs/ush/global_cycle.sh} export CYCLEXEC=${CYCLEXEC:-$HOMEgfs/exec/global_cycle} +APRUN_CYCLE=${APRUN_CYCLE:-${APRUN:-""}} +NTHREADS_CYCLE=${NTHREADS_CYCLE:-${NTHREADS:-1}} export FIXfv3=${FIXfv3:-$HOMEgfs/fix/fix_fv3_gmted2010} export FIXgsm=${FIXgsm:-$HOMEgfs/fix/fix_am} export CYCLVARS=${CYCLVARS:-"FSNOL=-2.,FSNOS=99999.,"} @@ -88,10 +96,16 @@ SMOOTH_ENKF=${SMOOTH_ENKF:-"YES"} APRUN_ECEN=${APRUN_ECEN:-${APRUN:-""}} NTHREADS_ECEN=${NTHREADS_ECEN:-${NTHREADS:-1}} +APRUN_CALCINC=${APRUN_CALCINC:-${APRUN:-""}} +NTHREADS_CALCINC=${NTHREADS_CALCINC:-${NTHREADS:-1}} ################################################################################ # Preprocessing -if [ ! -d $DATA ]; then mkdir -p $DATA; fi +mkdata=NO +if [ ! -d $DATA ]; then + mkdata=YES + mkdir -p $DATA +fi cd $DATA || exit 99 ENKF_SUFFIX="s" @@ -99,16 +113,38 @@ ENKF_SUFFIX="s" ################################################################################ # Link ensemble member guess, analysis and increment files +nfhrs=`echo $IAUFHRS_ENKF | sed 's/,/ /g'` +for FHR in $nfhrs; do # loop over analysis times in window + for imem in $(seq 1 $NMEM_ENKF); do memchar="mem"$(printf %03i $imem) - $NLN $COMIN_GES_ENS/$memchar/${GPREFIX}atmf006${ENKF_SUFFIX}$GSUFFIX ./atmges_$memchar - $NLN $COMIN_ENS/$memchar/${APREFIX}atmanl$ASUFFIX ./atmanl_$memchar - $NLN $COMIN_ENS/$memchar/${APREFIX}atminc.nc ./atminc_$memchar - [[ $RECENTER_ENKF = "YES" ]] && $NLN $COMIN_ENS/$memchar/${APREFIX}ratmanl$ASUFFIX ./ratmanl_$memchar + $NLN $COMIN_GES_ENS/$memchar/${GPREFIX}atmf00${FHR}${ENKF_SUFFIX}$GSUFFIX ./atmges_$memchar + if [ $FHR -eq 6 ]; then + $NLN $COMIN_ENS/$memchar/${APREFIX_ENKF}atmanl$ASUFFIX ./atmanl_$memchar + else + $NLN $COMIN_ENS/$memchar/${APREFIX_ENKF}atmanl00${FHR}$ASUFFIX ./atmanl_$memchar + fi + mkdir -p $COMOUT_ENS/$memchar + if [ $FHR -eq 6 ]; then + $NLN $COMOUT_ENS/$memchar/${APREFIX}atminc.nc ./atminc_$memchar + else + $NLN $COMOUT_ENS/$memchar/${APREFIX}atmi00${FHR}.nc ./atminc_$memchar + fi + if [[ $RECENTER_ENKF = "YES" ]]; then + if [ $FHR -eq 6 ]; then + $NLN $COMOUT_ENS/$memchar/${APREFIX}ratmanl$ASUFFIX ./ratmanl_$memchar + else + $NLN $COMOUT_ENS/$memchar/${APREFIX}ratmanl00${FHR}$ASUFFIX ./ratmanl_$memchar + fi + fi done # Link ensemble mean analysis -$NLN $COMIN_ENS/${APREFIX}atmanl.ensmean$ASUFFIX ./atmanl_ensmean +if [ $FHR -eq 6 ]; then + $NLN $COMIN_ENS/${APREFIX_ENKF}atmanl.ensmean$ASUFFIX ./atmanl_ensmean +else + $NLN $COMIN_ENS/${APREFIX_ENKF}atmanl00${FHR}.ensmean$ASUFFIX ./atmanl_ensmean +fi # Compute ensemble mean analysis DATAPATH="./" @@ -128,11 +164,9 @@ $ERRSCRIPT || exit 2 LONB_ENKF=${LONB_ENKF:-$($NEMSIOGET atmanl_ensmean dimx | awk '{print $2}')} LATB_ENKF=${LATB_ENKF:-$($NEMSIOGET atmanl_ensmean dimy | awk '{print $2}')} LEVS_ENKF=${LEVS_ENKF:-$($NEMSIOGET atmanl_ensmean dimz | awk '{print $2}')} -if [ $QUILTING = ".false." -o $OUTPUT_GRID = "cubed_sphere_grid" ]; then - JCAP_ENKF=${JCAP_ENKF:-$($NEMSIOGET atmanl_ensmean jcap | awk '{print $2}')} -else - JCAP_ENKF=$((LATB_ENKF-2)) -fi +JCAP_ENKF=${JCAP_ENKF:-$($NEMSIOGET atmanl_ensmean jcap | awk '{print $2}')} +[ $JCAP_ENKF -eq -9999 -a $LATB_ENKF -ne -9999 ] && JCAP_ENKF=$((LATB_ENKF-2)) +[ $LONB_ENKF -eq -9999 -o $LATB_ENKF -eq -9999 -o $LEVS_ENKF -eq -9999 -o $JCAP_ENKF -eq -9999 ] && exit -9999 ################################################################################ # This is to give the user the option to recenter, default is YES @@ -144,11 +178,8 @@ if [ $RECENTER_ENKF = "YES" ]; then LONB=${LONB:-$($NEMSIOGET $ATMANL_GSI dimx | awk '{print $2}')} LATB=${LATB:-$($NEMSIOGET $ATMANL_GSI dimy | awk '{print $2}')} - if [ $QUILTING = ".false." -o $OUTPUT_GRID = "cubed_sphere_grid" ]; then - JCAP=${JCAP:-$($NEMSIOGET $ATMANL_GSI jcap | awk '{print $2}')} - else - JCAP=$((LATB-2)) - fi + JCAP=${JCAP:-$($NEMSIOGET $ATMANL_GSI jcap | awk '{print $2}')} + [ $JCAP -eq -9999 -a $LATB -ne -9999 ] && JCAP=$((LATB-2)) # If GSI EnVar analysis is at ensemble resolution, no chgres is required if [ $JCAP = $JCAP_ENKF -a $LATB = $LATB_ENKF -a $LONB = $LONB_ENKF ]; then @@ -207,7 +238,7 @@ EOF if [ ${SENDDBN:-"NO"} = "YES" ]; then for imem in $(seq 1 $NMEM_ENKF); do memchar="mem"$(printf %03i $imem) - $DBNROOT/bin/dbn_alert MODEL GFS_ENKF $job $COMIN_ENS/$memchar/${APREFIX}ratmanl$ASUFFIX + $DBNROOT/bin/dbn_alert MODEL GFS_ENKF $job $COMOUT_ENS/$memchar/${APREFIX}ratmanl$ASUFFIX done fi @@ -222,7 +253,7 @@ else ATMANLNAME='atmanl' fi -export OMP_NUM_THREADS=1 +export OMP_NUM_THREADS=$NTHREADS_CALCINC $NCP $CALCINCEXEC $DATA rm calc_increment.nml @@ -242,13 +273,15 @@ cat > calc_increment.nml << EOF EOF cat calc_increment.nml -$APRUN_ECEN ${DATA}/$(basename $CALCINCEXEC) +$APRUN_CALCINC ${DATA}/$(basename $CALCINCEXEC) rc=$? export ERR=$rc export err=$rc $ERRSCRIPT || exit 4 +done # loop over analysis times in window + ################################################################################ # Update surface fields in the FV3 restart's using global_cycle @@ -260,6 +293,10 @@ gPDY=$(echo $GDATE | cut -c1-8) gcyc=$(echo $GDATE | cut -c9-10) GDUMP=${GDUMP:-"gdas"} +BDATE=$($NDATE -3 $CDATE) +bPDY=$(echo $BDATE | cut -c1-8) +bcyc=$(echo $BDATE | cut -c9-10) + # Get dimension information based on CASE res=$(echo $CASE | cut -c2-) JCAP_CASE=$((res*2-2)) @@ -267,12 +304,12 @@ LATB_CASE=$((res*2)) LONB_CASE=$((res*4)) # Global cycle requires these files -export FNTSFA=${FNTSFA:-$DMPDIR/$CDATE/$CDUMP/${OPREFIX}rtgssthr.grb} -export FNACNA=${FNACNA:-$DMPDIR/$CDATE/$CDUMP/${OPREFIX}seaice.5min.blend.grb} -export FNSNOA=${FNSNOA:-$DMPDIR/$CDATE/$CDUMP/${OPREFIX}snogrb_t${JCAP_CASE}.${LONB_CASE}.${LATB_CASE}} -[[ ! -f $FNSNOA ]] && export FNSNOA="$DMPDIR/$CDATE/$CDUMP/${OPREFIX}snogrb_t1534.3072.1536" -FNSNOG=${FNSNOG:-$DMPDIR/$GDATE/$GDUMP/${GDUMP}.t${gcyc}z.snogrb_t${JCAP_CASE}.${LONB_CASE}.${LATB_CASE}} -[[ ! -f $FNSNOG ]] && FNSNOG="$DMPDIR/$GDATE/$GDUMP/${GDUMP}.t${gcyc}z.snogrb_t1534.3072.1536" +export FNTSFA=${FNTSFA:-' '} +export FNACNA=${FNACNA:-$COMIN_OBS/${OPREFIX}seaice.5min.blend.grb} +export FNSNOA=${FNSNOA:-$COMIN_OBS/${OPREFIX}snogrb_t${JCAP_CASE}.${LONB_CASE}.${LATB_CASE}} +[[ ! -f $FNSNOA ]] && export FNSNOA="$COMIN_OBS/${OPREFIX}snogrb_t1534.3072.1536" +FNSNOG=${FNSNOG:-$COMIN_GES_OBS/${GPREFIX}snogrb_t${JCAP_CASE}.${LONB_CASE}.${LATB_CASE}} +[[ ! -f $FNSNOG ]] && FNSNOG="$COMIN_GES_OBS/${GPREFIX}snogrb_t1534.3072.1536" # Set CYCLVARS by checking grib date of current snogrb vs that of prev cycle if [ ${RUN_GETGES:-"NO"} = "YES" ]; then @@ -298,10 +335,42 @@ else export GSI_FILE="NULL" fi -export APRUNCY=$APRUN_ECEN -export OMP_NUM_THREADS_CY=$NTHREADS_ECEN +export APRUNCY=${APRUN_CYCLE:-$APRUN_ECEN} +export OMP_NUM_THREADS_CY=${NTHREADS_CYCLE:-$NTHREADS_ECEN} export MAX_TASKS_CY=$NMEM_ENKF +if [ $DOIAU = "YES" ]; then + # Update surface restarts at beginning of window when IAU is ON + # For now assume/hold dtfanl.nc is valid at beginning of window. + + for n in $(seq 1 $ntiles); do + + export TILE_NUM=$n + + for imem in $(seq 1 $NMEM_ENKF); do + + cmem=$(printf %03i $imem) + memchar="mem$cmem" + + [[ $TILE_NUM -eq 1 ]] && mkdir -p $COMOUT_ENS/$memchar/RESTART + + $NLN $COMIN_GES_ENS/$memchar/RESTART/$bPDY.${bcyc}0000.sfc_data.tile${n}.nc $DATA/fnbgsi.$cmem + $NLN $COMOUT_ENS/$memchar/RESTART/$bPDY.${bcyc}0000.sfcanl_data.tile${n}.nc $DATA/fnbgso.$cmem + $NLN $FIXfv3/$CASE/${CASE}_grid.tile${n}.nc $DATA/fngrid.$cmem + $NLN $FIXfv3/$CASE/${CASE}_oro_data.tile${n}.nc $DATA/fnorog.$cmem + + done + + $CYCLESH + rc=$? + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 11 + + done + +fi + for n in $(seq 1 $ntiles); do export TILE_NUM=$n @@ -311,10 +380,10 @@ for n in $(seq 1 $ntiles); do cmem=$(printf %03i $imem) memchar="mem$cmem" - [[ $TILE_NUM -eq 1 ]] && mkdir -p $COMIN_ENS/$memchar/RESTART + [[ $TILE_NUM -eq 1 ]] && mkdir -p $COMOUT_ENS/$memchar/RESTART $NLN $COMIN_GES_ENS/$memchar/RESTART/$PDY.${cyc}0000.sfc_data.tile${n}.nc $DATA/fnbgsi.$cmem - $NLN $COMIN_ENS/$memchar/RESTART/$PDY.${cyc}0000.sfcanl_data.tile${n}.nc $DATA/fnbgso.$cmem + $NLN $COMOUT_ENS/$memchar/RESTART/$PDY.${cyc}0000.sfcanl_data.tile${n}.nc $DATA/fnbgso.$cmem $NLN $FIXfv3/$CASE/${CASE}_grid.tile${n}.nc $DATA/fngrid.$cmem $NLN $FIXfv3/$CASE/${CASE}_oro_data.tile${n}.nc $DATA/fnorog.$cmem @@ -327,12 +396,13 @@ for n in $(seq 1 $ntiles); do $ERRSCRIPT || exit 11 done + ################################################################################ ################################################################################ # Postprocessing cd $pwd -[[ ${KEEPDATA:-"NO"} = "NO" ]] && rm -rf $DATA +[[ $mkdata = "YES" ]] && rm -rf $DATA set +x if [ $VERBOSE = "YES" ]; then echo $(date) EXITING $0 with return code $err >&2 diff --git a/scripts/exglobal_enkf_update.sh.ecf b/scripts/exglobal_enkf_update.sh.ecf index 43d03d653..0e98b8c6d 100755 --- a/scripts/exglobal_enkf_update.sh.ecf +++ b/scripts/exglobal_enkf_update.sh.ecf @@ -71,6 +71,8 @@ # defaults to ${FIXgsi}/global_scaninfo.txt # HYBENSINFO Input hybrid ensemble localization information file # defaults to ${FIXgsi}/global_hybens_locinfo.l${LEVS}.txt +# ANAVINFO Input control vector information file +# defaults to ${FIXgsi}/global_anavinfo.l64.txt # TCVITL Input tcvitals file # defaults to ${COMIN}/${PREINP}syndata.tcvitals.tm00 # INISCRIPT Preprocessing script @@ -139,13 +141,13 @@ # $RTMEMIS # $RTMAERO # $RTMCLDS -# $ANAVINFO # $CONVINFO # $OZINFO # $PCPINFO # $AEROINFO # $SCANINFO # $HYBENSINFO +# $ANAVINFO # # input data : $SFCGES # $SIGGES @@ -239,6 +241,7 @@ export CONVINFO=${CONVINFO:-${FIXgsi}/global_convinfo.txt} export OZINFO=${OZINFO:-${FIXgsi}/global_ozinfo.txt} export SCANINFO=${SCANINFO:-${FIXgsi}/global_scaninfo.txt} export HYBENSINFO=${HYBENSINFO:-${FIXgsi}/global_hybens_locinfo.l${LEVS}.txt} +export ANAVINFO=${ANAVINFO:-${FIXgsi}/global_anavinfo.l${LEVS}.txt} export SIGGESENS=${SIGGESENS:-${COMIN}/sigf06_ens} if [ $fso_cycling = .true. ]; then export OSENSE=${OSENSE:-${COMOUT}/osense_} @@ -260,7 +263,6 @@ export GDATE=${GDATE:-($NDATE -06 $CDATE)} export NANALS=${NANALS:-80} export SMOOTHINF=${SMOOTHINF:-24} export NTRAC=${NTRAC:-3} -export NVARS=${NVARS:-5} export NAM_ENKF=${NAM_ENKF:-""} export SATOBS_ENKF=${SATOBS_ENKF:-""} export OZOBS_ENKF=${OZOBS_ENKF:-""} @@ -349,6 +351,7 @@ then $NCP $CONVINFO convinfo $NCP $OZINFO ozinfo $NCP $HYBENSINFO hybens_info + $NCP $ANAVINFO anavinfo # Ensemble observational and guess data if [[ $USE_CFP = YES ]]; then @@ -395,6 +398,7 @@ else ln -fs $CONVINFO convinfo ln -fs $OZINFO ozinfo ln -fs $HYBENSINFO hybens_info + ln -fs $ANAVINFO anavinfo # Ensemble observational and guess data if [[ $USE_CFP = YES ]]; then @@ -471,7 +475,7 @@ cat < enkf.nml obtimelnh=1.e30,obtimelsh=1.e30,obtimeltr=1.e30, saterrfact=1.0,numiter=1, sprd_tol=1.e30,paoverpb_thresh=0.98, - nlons=$LONA,nlats=$LATA,nlevs=$LEVS,nanals=$NMEM_ENKF,nvars=$NVARS, + nlons=$LONA,nlats=$LATA,nlevs=$LEVS,nanals=$NMEM_ENKF, deterministic=.true.,sortinc=.true.,lupd_satbiasc=.false., reducedgrid=.true.,readin_localization=.true., use_gfs_nemsio=${use_gfs_nemsio}, diff --git a/scripts/exglobal_enkf_update_fv3gfs.sh.ecf b/scripts/exglobal_enkf_update_fv3gfs.sh.ecf index bf53922ee..1e53ce7c9 100755 --- a/scripts/exglobal_enkf_update_fv3gfs.sh.ecf +++ b/scripts/exglobal_enkf_update_fv3gfs.sh.ecf @@ -46,7 +46,7 @@ APRUN_ENKF=${APRUN_ENKF:-${APRUN:-""}} NTHREADS_ENKF=${NTHREADS_ENKF:-${NTHREADS:-1}} # Executables -ENKFEXEC=${ENKFEXEC:-$HOMEgsi/exec/global_enkf} +ENKFEXEC=${ENKFEXEC:-$HOMEgsi/exec/global_enkf.x} # Cycling and forecast hour specific parameters CDATE=${CDATE:-"2001010100"} @@ -67,12 +67,25 @@ ENKFSTAT=${ENKFSTAT:-${APREFIX}enkfstat} # Namelist parameters NMEM_ENKF=${NMEM_ENKF:-80} -NVARS_ENKF=${NVARS_ENKF:-5} NAM_ENKF=${NAM_ENKF:-""} SATOBS_ENKF=${SATOBS_ENKF:-""} OZOBS_ENKF=${OZOBS_ENKF:-""} imp_physics=${imp_physics:-"99"} lupp=${lupp:-".true."} +corrlength=${corrlength:-1250} +lnsigcutoff=${lnsigcutoff:-2.5} +analpertwt=${analpertwt:-0.85} +readin_localization_enkf=${readin_localization_enkf:-".true."} +reducedgrid=${reducedgrid:-".true"} +letkf_flag=${letkf_flag:-".false"} +getkf=${getkf:-".false"} +denkf=${denkf:-".false"} +nobsl_max=${nobsl_max:-10000} +lobsdiag_forenkf=${lobsdiag_forenkf:-".false"} +write_spread_diag=${write_spread_diag:-".false"} +netcdf_diag=${netcdf_diag:-".false."} +modelspace_vloc=${modelspace_vloc:-".false."} # if true, 'vlocal_eig.dat' is needed +IAUFHRS_ENKF=${IAUFHRS_ENKF:-6} ################################################################################ ATMGES_ENSMEAN=$COMIN_GES_ENS/${GPREFIX}atmf006.ensmean${GSUFFIX} @@ -88,18 +101,24 @@ CONVINFO=${CONVINFO:-${FIXgsi}/global_convinfo.txt} OZINFO=${OZINFO:-${FIXgsi}/global_ozinfo.txt} SCANINFO=${SCANINFO:-${FIXgsi}/global_scaninfo.txt} HYBENSINFO=${HYBENSINFO:-${FIXgsi}/global_hybens_info.l${LEVS_ENKF}.txt} +ANAVINFO=${ANAVINFO:-${FIXgsi}/global_anavinfo.l${LEVS_ENKF}.txt} +VLOCALEIG=${VLOCALEIG:-${FIXgsi}/vlocal_eig_l${LEVS_ENKF}.dat} ENKF_SUFFIX="s" [[ $SMOOTH_ENKF = "NO" ]] && ENKF_SUFFIX="" ################################################################################ # Preprocessing -if [ ! -d $DATA ]; then mkdir -p $DATA; fi +mkdata=NO +if [ ! -d $DATA ]; then + mkdata=YES + mkdir -p $DATA +fi cd $DATA || exit 99 ################################################################################ # Clean up the run directory -rm convinfo satinfo ozinfo hybens_info +rm convinfo satinfo ozinfo hybens_info anavinfo rm satbias_angle satbias_in rm enkf.nml rm sanl* @@ -112,6 +131,8 @@ $NLN $SCANINFO scaninfo $NLN $CONVINFO convinfo $NLN $OZINFO ozinfo $NLN $HYBENSINFO hybens_info +$NLN $ANAVINFO anavinfo +$NLN $VLOCALEIG vlocal_eig.dat # Bias correction coefficients based on the ensemble mean $NLN $COMOUT_ANL_ENS/$GBIASe satbias_in @@ -150,6 +171,7 @@ else tar -xvf $fname done fi +nfhrs=`echo $IAUFHRS_ENKF | sed 's/,/ /g'` for imem in $(seq 1 $NMEM_ENKF); do memchar="mem"$(printf %03i $imem) if [ $USE_CFP = "YES" ]; then @@ -160,12 +182,21 @@ for imem in $(seq 1 $NMEM_ENKF); do tar -xvf $fname done fi - $NLN $COMIN_GES_ENS/$memchar/${GPREFIX}atmf006${ENKF_SUFFIX}${GSUFFIX} sfg_${CDATE}_fhr06_${memchar} - $NLN $COMOUT_ANL_ENS/$memchar/${APREFIX}atmanl${ASUFFIX} sanl_${CDATE}_fhr06_${memchar} + mkdir -p $COMOUT_ANL_ENS/$memchar + for FHR in $nfhrs; do + $NLN $COMIN_GES_ENS/$memchar/${GPREFIX}atmf00${FHR}${ENKF_SUFFIX}${GSUFFIX} sfg_${CDATE}_fhr0${FHR}_${memchar} + if [ $FHR -eq 6 ]; then + $NLN $COMOUT_ANL_ENS/$memchar/${APREFIX}atmanl${ASUFFIX} sanl_${CDATE}_fhr0${FHR}_${memchar} + else + $NLN $COMOUT_ANL_ENS/$memchar/${APREFIX}atmanl00${FHR}${ASUFFIX} sanl_${CDATE}_fhr0${FHR}_${memchar} + fi + done done # Ensemble mean guess -$NLN $COMIN_GES_ENS/${GPREFIX}atmf006.ensmean${GSUFFIX} sfg_${CDATE}_fhr06_ensmean +for FHR in $nfhrs; do + $NLN $COMIN_GES_ENS/${GPREFIX}atmf00${FHR}.ensmean${GSUFFIX} sfg_${CDATE}_fhr0${FHR}_ensmean +done if [ $USE_CFP = "YES" ]; then chmod 755 $DATA/mp_untar.sh @@ -174,6 +205,10 @@ if [ $USE_CFP = "YES" ]; then ncmd_max=$((ncmd < npe_node_max ? ncmd : npe_node_max)) APRUNCFP=$(eval echo $APRUNCFP) $APRUNCFP $DATA/mp_untar.sh + rc=$? + export ERR=$rc + export err=$ERR + $ERRSCRIPT || exit 2 fi fi @@ -182,20 +217,26 @@ fi cat > enkf.nml << EOFnml &nam_enkf datestring="$CDATE",datapath="$DATA/", - analpertwtnh=0.85,analpertwtsh=0.85,analpertwttr=0.85, + analpertwtnh=${analpertwt},analpertwtsh=${analpertwt},analpertwttr=${analpertwt}, covinflatemax=1.e2,covinflatemin=1,pseudo_rh=.true.,iassim_order=0, - corrlengthnh=2000,corrlengthsh=2000,corrlengthtr=2000, - lnsigcutoffnh=2.0,lnsigcutoffsh=2.0,lnsigcutofftr=2.0, - lnsigcutoffpsnh=2.0,lnsigcutoffpssh=2.0,lnsigcutoffpstr=2.0, - lnsigcutoffsatnh=2.0,lnsigcutoffsatsh=2.0,lnsigcutoffsattr=2.0, + corrlengthnh=${corrlength},corrlengthsh=${corrlength},corrlengthtr=${corrlength}, + lnsigcutoffnh=${lnsigcutoff},lnsigcutoffsh=${lnsigcutoff},lnsigcutofftr=${lnsigcutoff}, + lnsigcutoffpsnh=${lnsigcutoff},lnsigcutoffpssh=${lnsigcutoff},lnsigcutoffpstr=${lnsigcutoff}, + lnsigcutoffsatnh=${lnsigcutoff},lnsigcutoffsatsh=${lnsigcutoff},lnsigcutoffsattr=${lnsigcutoff}, obtimelnh=1.e30,obtimelsh=1.e30,obtimeltr=1.e30, - saterrfact=1.0,numiter=1, + saterrfact=1.0,numiter=0, sprd_tol=1.e30,paoverpb_thresh=0.98, - nlons=$LONA_ENKF,nlats=$LATA_ENKF,nlevs=$LEVS_ENKF,nanals=$NMEM_ENKF,nvars=$NVARS_ENKF, + nlons=$LONA_ENKF,nlats=$LATA_ENKF,nlevs=$LEVS_ENKF,nanals=$NMEM_ENKF, deterministic=.true.,sortinc=.true.,lupd_satbiasc=.false., - reducedgrid=.true.,readin_localization=.true., + reducedgrid=${reducedgrid},readin_localization=${readin_localization_enkf}., use_gfs_nemsio=.true.,imp_physics=$imp_physics,lupp=$lupp, univaroz=.false.,adp_anglebc=.true.,angord=4,use_edges=.false.,emiss_bc=.true., + letkf_flag=${letkf_flag},nobsl_max=${nobsl_max},denkf=${denkf},getkf=${getkf}., + nhr_anal=${IAUFHRS_ENKF},nhr_state=${IAUFHRS_ENKF},use_qsatensmean=.true., + lobsdiag_forenkf=$lobsdiag_forenkf, + write_spread_diag=$write_spread_diag, + modelspace_vloc=$modelspace_vloc, + netcdf_diag=$netcdf_diag, $NAM_ENKF / &satobs_enkf @@ -251,18 +292,21 @@ cat > enkf.nml << EOFnml sattypes_rad(50)= 'seviri_m08', dsis(50)= 'seviri_m08', sattypes_rad(51)= 'seviri_m09', dsis(51)= 'seviri_m09', sattypes_rad(52)= 'seviri_m10', dsis(52)= 'seviri_m10', - sattypes_rad(53)= 'amsua_metop-b', dsis(53)= 'amsua_metop-b', - sattypes_rad(54)= 'hirs4_metop-b', dsis(54)= 'hirs4_metop-b', - sattypes_rad(55)= 'mhs_metop-b', dsis(55)= 'mhs_metop-b', - sattypes_rad(56)= 'iasi_metop-b', dsis(56)= 'iasi_metop-b', - sattypes_rad(57)= 'avhrr_metop-b', dsis(57)= 'avhrr3_metop-b', - sattypes_rad(58)= 'atms_npp', dsis(58)= 'atms_npp', - sattypes_rad(59)= 'atms_n20', dsis(59)= 'atms_n20', - sattypes_rad(60)= 'cris_npp', dsis(60)= 'cris_npp', - sattypes_rad(61)= 'cris-fsr_npp', dsis(61)= 'cris-fsr_npp', - sattypes_rad(62)= 'cris-fsr_n20', dsis(62)= 'cris-fsr_n20', - sattypes_rad(63)= 'gmi_gpm', dsis(63)= 'gmi_gpm', - sattypes_rad(64)= 'saphir_meghat', dsis(64)= 'saphir_meghat', + sattypes_rad(53)= 'seviri_m11', dsis(53)= 'seviri_m11', + sattypes_rad(54)= 'amsua_metop-b', dsis(54)= 'amsua_metop-b', + sattypes_rad(55)= 'hirs4_metop-b', dsis(55)= 'hirs4_metop-b', + sattypes_rad(56)= 'mhs_metop-b', dsis(56)= 'mhs_metop-b', + sattypes_rad(57)= 'iasi_metop-b', dsis(57)= 'iasi_metop-b', + sattypes_rad(58)= 'avhrr_metop-b', dsis(58)= 'avhrr3_metop-b', + sattypes_rad(59)= 'atms_npp', dsis(59)= 'atms_npp', + sattypes_rad(60)= 'atms_n20', dsis(60)= 'atms_n20', + sattypes_rad(61)= 'cris_npp', dsis(61)= 'cris_npp', + sattypes_rad(62)= 'cris-fsr_npp', dsis(62)= 'cris-fsr_npp', + sattypes_rad(63)= 'cris-fsr_n20', dsis(63)= 'cris-fsr_n20', + sattypes_rad(64)= 'gmi_gpm', dsis(64)= 'gmi_gpm', + sattypes_rad(65)= 'saphir_meghat', dsis(65)= 'saphir_meghat', + sattypes_rad(66)= 'amsua_metop-c', dsis(66)= 'amsua_metop-c', + sattypes_rad(67)= 'mhs_metop-c', dsis(67)= 'mhs_metop-c', $SATOBS_ENKF / &ozobs_enkf @@ -274,6 +318,8 @@ cat > enkf.nml << EOFnml sattypes_oz(6) = 'gome_metop-a', sattypes_oz(7) = 'gome_metop-b', sattypes_oz(8) = 'mls30_aura', + sattypes_oz(9) = 'ompsnp_npp', + sattypes_oz(10) = 'ompstc8_npp', $OZOBS_ENKF / EOFnml @@ -281,9 +327,61 @@ EOFnml ################################################################################ # Run enkf update export OMP_NUM_THREADS=$NTHREADS_ENKF -$NCP $ENKFEXEC $DATA/enkf.x -$APRUN_ENKF $DATA/enkf.x < enkf.nml 1>stdout 2>stderr -rc=$? + +PGM=$DATA/enkf.x +$NCP $ENKFEXEC $PGM + +# Execute EnKF using same number of mpi tasks on all nodes +#$APRUN_ENKF $PGM 1>stdout 2>stderr +#rc=$? + +# Execute EnKF using only one mpi task on root node. +# (root node has to hold two copies of full ob space ensemble for LETKF) +mpi_launcher=`echo $APRUN_ENKF | cut -f1 -d " "` +totproc=`expr $npe_enkf \* $OMP_NUM_THREADS` +mpitaskspernode=`expr $npe_node_max \/ $OMP_NUM_THREADS` +HOSTFILE=machinefile_enkf +rm -f $HOSTFILE +if [ "$mpi_launcher" = "mpirun" ]; then + # PBS with mpirun + /bin/cp -f $LSB_DJOB_HOSTFILE $HOSTFILE + if [ $mpitaskspernode -gt 1 ]; then + sed -i "2,${mpitaskspernode}d" $HOSTFILE + nprocs=`wc -l $HOSTFILE | cut -f1 -d" "` + fi + mpirun -np $nprocs -machinefile $HOSTFILE $PGM 1>stdout 2>stderr + rc=$? + rm -f $HOSTFILE +elif [ "$mpi_launcher" = "srun" ]; then + # slurm with srun + nnode=0 + for node in `scontrol show hostnames $SLURM_JOB_NODELIST`; do + let nnode+=1 + if [ $nnode -eq 1 ]; then + echo $node > $HOSTFILE + else + count=0 + while [ $count -lt "$mpitaskspernode" ]; do + echo $node >> $HOSTFILE + let count+=1 + done + fi + done + nprocs=`wc -l $HOSTFILE | cut -f1 -d" "` + export SLURM_HOSTFILE=$HOSTFILE + srun --verbose --export=ALL -c ${OMP_NUM_THREADS} --distribution=arbitrary --cpu-bind=cores $PGM 1>stdout 2>stderr + rc=$? + rm -f $HOSTFILE +elif [ "$mpi_launcher" = "aprun" ]; then + # aprun (independent of scheduler) + totproc2=`expr $totproc - $npe_node_max` + nprocs=`expr $totproc2 \/ $OMP_NUM_THREADS` + aprun -n 1 -N 1 -d ${OMP_NUM_THREADS} --cc depth $PGM : -n $nprocs -N $mpitaskspernode -d ${OMP_NUM_THREADS} --cc depth $PGM 1>stdout 2>stderr + rc=$? +else + echo "unknown mpi launcher" + rc=99 +fi export ERR=$rc export err=$ERR @@ -295,7 +393,7 @@ cat stdout stderr > $COMOUT_ANL_ENS/$ENKFSTAT ################################################################################ # Postprocessing cd $pwd -[[ ${KEEPDATA:-"NO"} = "NO" ]]&& rm -rf $DATA +[[ $mkdata = "YES" ]] && rm -rf $DATA set +x if [ $VERBOSE = "YES" ]; then echo $(date) EXITING $0 with return code $err >&2 diff --git a/scripts/exglobal_innovate_obs_fv3gfs.sh.ecf b/scripts/exglobal_innovate_obs_fv3gfs.sh.ecf index e334c5c6d..942f4ea75 100755 --- a/scripts/exglobal_innovate_obs_fv3gfs.sh.ecf +++ b/scripts/exglobal_innovate_obs_fv3gfs.sh.ecf @@ -67,7 +67,11 @@ CHEM_INVOBS=${CHEM_INVOBS:-""} ################################################################################ # Preprocessing -if [ ! -d $DATA ]; then mkdir -p $DATA; fi +mkdata=NO +if [ ! -d $DATA ]; then + mkdata=YES + mkdir -p $DATA +fi cd $DATA || exit 8 [[ ! -d $COMOUT ]] && mkdir -p $COMOUT @@ -93,6 +97,7 @@ export DIAG_COMPRESS=${DIAG_COMPRESS:-"NO"} export DIAG_TARBALL=${DIAG_TARBALL:-"YES"} export DOHYBVAR="NO" export DO_CALC_INCREMENT="NO" +export USE_CORRELATED_OBERRS="NO" # GSI Namelist options for observation operator only export SETUP="miter=0,niter=1,lread_obs_save=$lread_obs_save,lread_obs_skip=$lread_obs_skip,lwrite_predterms=.true.,lwrite_peakwt=.true.,reduce_diag=.true.,$SETUP_INVOBS" @@ -122,7 +127,7 @@ $ERRSCRIPT || exit 2 ################################################################################ # Postprocessing cd $pwd -[[ ${KEEPDATA:-"NO"} = "NO" ]]&& rm -rf $DATA +[[ $mkdata = "YES" ]] && rm -rf $DATA set +x if [ $VERBOSE = "YES" ]; then echo $(date) EXITING $0 with return code $err >&2 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt deleted file mode 100644 index f547a5e59..000000000 --- a/src/CMakeLists.txt +++ /dev/null @@ -1,164 +0,0 @@ -cmake_minimum_required(VERSION 2.8) -# need to set CMP0046 when using add_dependencies with cmake version 3.6.2 - if(crayComp) - cmake_policy(SET CMP0046 NEW) - endif() - set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/cmake/Modules/") -# get a list of all the fortran source files - file(GLOB GSI_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90 ) -# get a list of all cplr files - file(GLOB CLASS_SRC ${CMAKE_CURRENT_SOURCE_DIR}/class*90 ) -# create a list of all corresponding stub files - string(REGEX REPLACE "class" "stub" STUB_SRC "${CLASS_SRC}") -# create a list of all corresponding class files - string(REGEX REPLACE "class" "cplr" CPLR_SRC "${CLASS_SRC}") - -# these files use the cplr or stub modules, so they need to be compiled for all versions of GSI (WRF, no-WRF, etc) - set(LINKED_SRC "${CMAKE_CURRENT_SOURCE_DIR}/gesinfo.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/get_gefs_ensperts_dualres.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/get_gefs_for_regional.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/read_guess.F90" - "${CMAKE_CURRENT_SOURCE_DIR}/bkgcov.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/bicglanczos.F90" - "${CMAKE_CURRENT_SOURCE_DIR}/bicg.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/set_crtm_cloudmod.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/crtm_interface.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/gsi_nemsio_mod.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/ensctl2model_ad.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/ensctl2model.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/ensctl2state.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/ensctl2state_ad.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/lanczos.F90" - "${CMAKE_CURRENT_SOURCE_DIR}/getsiga.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/test_obsens.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/sqrtmin.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/evaljgrad.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/pcgsoi.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/en_perts_io.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/bkerror.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/hybrid_ensemble_isotropic.F90" - "${CMAKE_CURRENT_SOURCE_DIR}/write_all.F90" - "${CMAKE_CURRENT_SOURCE_DIR}/glbsoi.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/setupaod.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/setuprad.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/general_read_nmmb.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/get_nmmb_ensperts.f90" - "${CMAKE_CURRENT_SOURCE_DIR}/gsimod.F90" - "${CMAKE_CURRENT_SOURCE_DIR}/gsimain.f90") - -# remove all stub, cplr and linked files from the rest of the source files - list( REMOVE_ITEM GSI_SRC ${LINKED_SRC} ) - list( REMOVE_ITEM GSI_SRC ${STUB_SRC} ) - list( REMOVE_ITEM GSI_SRC ${CPLR_SRC} ) - -# remove stub_nstmod from the rest of the source files - list( REMOVE_ITEM GSI_SRC "${CMAKE_CURRENT_SOURCE_DIR}/stub_nstmod.f90" ) - -# The specific regional/WRF source files - if(USE_WRF) - set( REGIONAL_SRC ${CPLR_SRC} ) - list( APPEND REGIONAL_SRC ${LINKED_SRC} ) - set_source_files_properties( ${REGIONAL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) - endif() - -# The non-WRF specific src files - set( GLOBAL_SRC ${CPLR_SRC} ) - set( GLOBAL_SRC ${STUB_SRC} ) - list( APPEND GLOBAL_SRC ${LINKED_SRC} ) - list( APPEND GSI_SRC "${CMAKE_CURRENT_SOURCE_DIR}/blockIO.c") - - set_source_files_properties( ${GSI_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) - set_source_files_properties( ${GLOBAL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) - - set_source_files_properties( ${CMAKE_CURRENT_SOURCE_DIR}/blockIO.c PROPERTIES COMPILE_FLAGS ${GSI_CFLAGS} ) - - include_directories( ${CORE_INCS} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} "./" ) - add_library(gsilib_shrd${debug_suffix} STATIC ${GSI_SRC} ) - - if(USE_WRF) - add_library(gsilib_wrf${debug_suffix} STATIC ${REGIONAL_SRC} ) - endif() - if(BUILD_GLOBAL) - add_library(gsilib_global${debug_suffix} STATIC ${GLOBAL_SRC} ) - target_link_libraries( gsilib_shrd${debug_suffix} gsilib_global${debug_suffix} ${CORE_LIBRARIES}) - target_link_libraries( gsilib_global${debug_suffix} ${CORE_LIBRARIES}) - set_target_properties(gsilib_global PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") - target_include_directories(gsilib_global PUBLIC "${PROJECT_BINARY_DIR}/include") - add_dependencies(gsilib_global${debug_suffix} gsilib_shrd${debug_suffix} ) - endif() - - - - if(USE_WRF) - set_target_properties(gsilib_wrf${debug_suffix} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/wrf") - endif() - set_target_properties(gsilib_shrd${debug_suffix} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") - if(USE_WRF) - target_include_directories(gsilib_wrf${debug_suffix} PUBLIC "${PROJECT_BINARY_DIR}/include/wrf") - endif() - target_include_directories(gsilib_shrd${debug_suffix} PUBLIC "${PROJECT_BINARY_DIR}/include") -# add_library(clib${debug_suffix} STATIC ${CMAKE_CURRENT_SOURCE_DIR}/blockIO.c ) - - - if(BUILD_CORELIBS ) - if(USE_WRF) - add_dependencies(gsilib_wrf${debug_suffix} gsilib_shrd${debug_suffix} ${bacio} ${crtm} ${bufr} ${nemsio} ${sigio} ${sfcio} ${sp} ${w3emc} ${w3nco} ) - endif() - if(BUILD_GLOBAL) -# add_library(gsilib_global${debug_suffix} STATIC ${GLOBAL_SRC} ) - add_dependencies(gsilib_global${debug_suffix} gsilib_shrd${debug_suffix} ${bacio} ${crtm} ${bufr} ${nemsio} ${sigio} ${sfcio} ${sp} ${w3emc} ${w3nco} ) - endif() - add_dependencies(gsilib_shrd${debug_suffix} ${bacio} ${crtm} ${bufr} ${nemsio} ${sigio} ${sfcio} ${sp} ${w3emc} ${w3nco} ) - endif() - -# add_custom_target(RMIFCORE COMMAND "sed 's/-lifcore//g' " WORKING_DIRECTORY "/gpfs/gd1/emc/global/noscrub/Mark.Potts/ProdGSI/build/src/CMakeFiles/gsi.x.dir" INPUT_FILE "link.txt" ) -# execute_process(COMMAND "sed_cmd" WORKING_DIRECTORY "/gpfs/gd1/emc/global/noscrub/Mark.Potts/ProdGSI/build" ERROR_FILE "sed_err" OUTPUT_FILE "sed_out" ) - if(USE_WRF) - add_dependencies(gsilib_wrf${debug_suffix} gsilib_shrd${debug_suffix} ) - add_executable(gsi.x${debug_suffix} ${CMAKE_CURRENT_SOURCE_DIR}/gsimain.f90 ${CMAKE_CURRENT_SOURCE_DIR}/gsimod.F90 ) -# add_executable(gsi.x${debug_suffix} ${CMAKE_CURRENT_SOURCE_DIR}/gsimain.f90 ) - endif() - - if(BUILD_GLOBAL) - add_executable(gsi_global.x${debug_suffix} ${CMAKE_CURRENT_SOURCE_DIR}/gsimain.f90 ${CMAKE_CURRENT_SOURCE_DIR}/gsimod.F90 ) -# add_executable(gsi_global.x${debug_suffix} ${CMAKE_CURRENT_SOURCE_DIR}/gsimain.f90 ) - endif() - - if(USE_WRF) - set_target_properties(gsi.x${debug_suffix} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") - set_target_properties(gsi.x${debug_suffix} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/wrf") - endif() - - if(BUILD_GLOBAL) - set_target_properties(gsi_global.x${debug_suffix} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") - endif() - - if(BUILD_CORELIBS ) - if(BUILD_GLOBAL) - add_dependencies(gsi_global.x${debug_suffix} gsilib_shrd${debug_suffix} gsilib_global${debug_suffix} ${w3nco} ${bacio} ${crtm} ${bufr} ${nemsio} ${sigio} ${sfcio} ${sp} ${w3emc} ) - endif() - if(USE_WRF) - add_dependencies(gsi.x${debug_suffix} gsilib_shrd${debug_suffix} gsilib_wrf${debug_suffix} ${bacio} ${crtm} ${bufr} ${nemsio} ${sigio} ${sfcio} ${sp} ${w3emc} ${w3nco} ) - endif() - else() - if(BUILD_GLOBAL) - add_dependencies(gsi_global.x${debug_suffix} gsilib_shrd${debug_suffix} gsilib_global${debug_suffix} ) - endif() - if(USE_WRF) - add_dependencies(gsi.x${debug_suffix} gsilib_shrd${debug_suffix} gsilib_wrf${debug_suffix} ) - endif() - endif() - - if( NOT HOST-Luna AND NOT HOST-Surge ) - list( REMOVE_ITEM LAPACK_LIBRARIES "-lm" ) - endif() - if(USE_WRF) - target_link_libraries(gsi.x${debug_suffix} gsilib_shrd${debug_suffix} gsilib_wrf${debug_suffix} gsilib_shrd${debug_suffix} ${WRF_LIBRARIES} ${CORE_LIBRARIES} - ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_LIBRARIES} - ${LAPACK_LIBRARIES} -L./ ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${GSI_LDFLAGS}) - endif() - if(BUILD_GLOBAL) - target_link_libraries(gsi_global.x${debug_suffix} gsilib_shrd${debug_suffix} gsilib_global${debug_suffix} gsilib_shrd${debug_suffix} - ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_LIBRARIES} - ${LAPACK_LIBRARIES} -L./ ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${CORE_LIBRARIES} ) - endif() diff --git a/src/Makefile b/src/Makefile deleted file mode 100644 index 31fdb0042..000000000 --- a/src/Makefile +++ /dev/null @@ -1,918 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# GSI Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a GSI executable file, type -# > make or > make all -# -# 2) To make a GSI executable file with debug options, type -# > make debug -# -# 3) To copy the GSI load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# 5) To create a library, libgsi.a, in the lib directory, type -# > make library -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBcrtm = -L$(CORELIB) -lcrtm_2.1.3 -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - EXE_FILE = global_gsi - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../bin - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x *__genmod* - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = \ - gfs_stratosphere.f90 \ - adjtest.f90 \ - adjtest_obs.f90 \ - adjust_cloudobs_mod.f90 \ - aeroinfo.f90 \ - aircraftinfo.f90 \ - aircraftobsqc.f90 \ - anberror.f90 \ - anbkerror.f90 \ - aniso_ens_util.f90 \ - anisofilter.f90 \ - anisofilter_glb.f90 \ - antcorr_application.f90 \ - antest_maps0.f90 \ - antest_maps0_glb.f90 \ - atms_spatial_average_mod.f90 \ - balmod.f90 \ - berror.f90 \ - bias_predictors.f90 \ - bicg.f90 \ - bicglanczos.F90 \ - bkerror.f90 \ - bkgcov.f90 \ - bkgvar.f90 \ - bkgvar_rewgt.f90 \ - blacklist.f90 \ - blendmod.f90 \ - calc_fov_conical.f90 \ - calc_fov_crosstrk.f90 \ - calctends.f90 \ - calctends_ad.f90 \ - calctends_tl.f90 \ - calctends_no_ad.f90 \ - calctends_no_tl.f90 \ - chemmod.f90 \ - clw_mod.f90 \ - cloud_efr_mod.f90 \ - class_get_pseudo_ensperts.f90 \ - class_get_wrf_mass_ensperts.f90 \ - class_get_wrf_nmm_ensperts.f90 \ - class_gfs_ensmod.f90 \ - class_read_wrf_mass_files.f90 \ - class_read_wrf_mass_guess.f90 \ - class_read_wrf_nmm_files.f90 \ - class_read_wrf_nmm_guess.f90 \ - class_regional_io.f90 \ - class_wrf_binary_interface.f90 \ - class_wrf_netcdf_interface.f90 \ - class_wrwrfmassa.f90 \ - class_wrwrfnmma.f90 \ - cmaq_routines.f90 \ - co_mop_ak.f90 \ - coinfo.f90 \ - combine_radobs.f90 \ - compact_diffs.f90 \ - compute_derived.f90 \ - compute_fact10.f90 \ - compute_qvar3d.f90 \ - constants.f90 \ - control2model.f90 \ - control2state.f90 \ - control_vectors.f90 \ - converr.f90 \ - converr_ps.f90 \ - converr_q.f90 \ - converr_t.f90 \ - converr_uv.f90 \ - converr_pw.f90 \ - convb_ps.f90 \ - convb_q.f90 \ - convb_t.f90 \ - convb_uv.f90 \ - convinfo.f90 \ - convthin.f90 \ - convthin_time.f90 \ - correlated_obsmod.F90 \ - cplr_get_pseudo_ensperts.f90 \ - cplr_get_wrf_mass_ensperts.f90 \ - cplr_get_wrf_nmm_ensperts.f90 \ - cplr_read_wrf_mass_files.f90 \ - cplr_read_wrf_mass_guess.f90 \ - cplr_gfs_ensmod.f90 \ - cplr_read_wrf_nmm_files.f90 \ - cplr_read_wrf_nmm_guess.f90 \ - cplr_regional_io.f90 \ - cplr_wrf_binary_interface.f90 \ - cplr_wrf_netcdf_interface.f90 \ - cplr_wrwrfmassa.f90 \ - cplr_wrwrfnmma.f90 \ - crtm_interface.f90 \ - cvsection.f90 \ - cwhydromod.f90 \ - dtast.f90 \ - deter_sfc_mod.f90 \ - derivsmod.f90 \ - egrid2agrid_mod.f90 \ - enorm_state.f90 \ - ensctl2state.f90 \ - ensctl2model.f90 \ - ens_spread_mod.f90 \ - en_perts_io.f90 \ - evaljgrad.f90 \ - evaljo.f90 \ - evalqlim.f90 \ - fgrid2agrid_mod.f90 \ - fill_mass_grid2.f90 \ - fill_nmm_grid2.f90 \ - fpvsx_ad.f90 \ - general_commvars_mod.f90 \ - general_read_gfsatm.f90 \ - general_read_nmmb.f90 \ - general_specmod.f90 \ - general_spectral_transforms.f90 \ - general_sub2grid_mod.f90 \ - general_transform.f90 \ - general_tll2xy_mod.f90 \ - general_write_gfsatm.f90 \ - genex_mod.f90 \ - gengrid_vars.f90 \ - genqsat.f90 \ - genstats_gps.f90 \ - gesinfo.f90 \ - getcount_bufr.f90 \ - get_derivatives.f90 \ - get_derivatives2.f90 \ - get_gefs_for_regional.f90 \ - get_nmmb_ensperts.f90 \ - get_semimp_mats.f90 \ - getprs.f90 \ - getsiga.f90 \ - getuv.f90 \ - getvvel.f90 \ - glbsoi.f90 \ - grtest.f90 \ - grdcrd.f90 \ - gridmod.F90 \ - gscond_ad.f90 \ - gsd_terrain_match_surfTobs.f90 \ - gsdcloudanalysis.F90 \ - gsdcloudanalysis4NMMB.F90 \ - gsdcloudanalysis4gfs.F90 \ - gsd_update_mod.f90 \ - gsi_4dvar.f90 \ - gsi_4dcouplermod.f90 \ - gsi_bias.f90 \ - gsi_bundlemod.F90 \ - gsi_chemguess_mod.F90 \ - gsi_enscouplermod.f90 \ - gsi_nstcouplermod.f90 \ - gsi_io.f90 \ - gsi_metguess_mod.F90 \ - gsi_nemsio_mod.f90 \ - gsimain.f90 \ - gsimod.F90 \ - gsisub.F90 \ - guess_grids.F90 \ - half_nmm_grid2.f90 \ - hilbert_curve.f90 \ - hybrid_ensemble_isotropic.F90 \ - hybrid_ensemble_parameters.f90 \ - inc2guess.f90 \ - init_jcdfi.f90 \ - insitu_info.f90 \ - intall.f90 \ - intaod.f90 \ - intco.f90 \ - intdw.f90 \ - intgps.f90 \ - intgust.f90 \ - inthowv.f90 \ - intcldch.f90 \ - intjcmod.f90 \ - intjo.f90 \ - intlag.f90 \ - intlcbas.f90 \ - intmitm.f90 \ - intmxtm.f90 \ - intoz.f90 \ - intpblh.f90 \ - intpcp.f90 \ - intpm2_5.f90 \ - intpm10.f90 \ - intpmsl.f90 \ - intps.f90 \ - intpw.f90 \ - intq.f90 \ - intrad.f90 \ - intrp_msk.f90 \ - intrp2a.f90 \ - intrp3oz.f90 \ - intrw.f90 \ - intspd.f90 \ - intsst.f90 \ - intt.f90 \ - inttcamt.f90 \ - inttcp.f90 \ - inttd2m.f90 \ - intvis.f90 \ - intw.f90 \ - intwspd10m.f90 \ - intuwnd10m.f90 \ - intvwnd10m.f90 \ - jcmod.f90 \ - jfunc.f90 \ - jgrad.f90 \ - kinds.F90 \ - lag_fields.f90 \ - lag_interp.f90 \ - lag_traj.f90 \ - lagmod.f90 \ - lanczos.F90 \ - logcldch_to_cldch.f90 \ - loglcbas_to_lcbas.f90 \ - logvis_to_vis.f90 \ - looplimits.f90 \ - m_berror_stats.f90 \ - m_berror_stats_reg.f90 \ - m_dgeevx.F90 \ - m_distance.f90 \ - m_dtime.F90 \ - m_find.f90 \ - m_gpsrhs.F90 \ - m_gsiBiases.f90 \ - m_rerank.f90 \ - m_rhs.F90 \ - m_sortind.f90 \ - m_stats.f90 \ - m_tick.F90 \ - m_uniq.f90 \ - mpeu_mpif.F90 \ - mpeu_util.F90 \ - mod_nmmb_to_a.f90 \ - mod_strong.f90 \ - mod_vtrans.f90 \ - mod_wrfmass_to_a.f90 \ - model_ad.F90 \ - model_tl.F90 \ - control2model_ad.f90 \ - ensctl2model_ad.f90 \ - m_aeroNode.F90 \ - m_aerolNode.F90 \ - m_cldchNode.F90 \ - m_colvkNode.F90 \ - m_cvgridLookup.F90 \ - m_dwNode.F90 \ - m_gpsNode.F90 \ - m_gustNode.F90 \ - m_howvNode.F90 \ - m_lagNode.F90 \ - m_latlonRange.F90 \ - m_lcbasNode.F90 \ - m_mitmNode.F90 \ - m_mxtmNode.F90 \ - m_o3lNode.F90 \ - m_obsHeadBundle.F90 \ - m_obsLList.F90 \ - m_obsNode.F90 \ - m_obsNodeTypeManager.F90 \ - m_obsdiagNode.F90 \ - m_obsdiags.F90 \ - m_ozNode.F90 \ - m_pblhNode.F90 \ - m_pcpNode.F90 \ - m_pm10Node.F90 \ - m_pm2_5Node.F90 \ - m_pmslNode.F90 \ - m_psNode.F90 \ - m_pwNode.F90 \ - m_qNode.F90 \ - m_radNode.F90 \ - m_rwNode.F90 \ - m_spdNode.F90 \ - m_sstNode.F90 \ - m_tNode.F90 \ - m_tcamtNode.F90 \ - m_tcpNode.F90 \ - m_td2mNode.F90 \ - m_visNode.F90 \ - m_wNode.F90 \ - m_wspd10mNode.F90 \ - m_uwnd10mNode.F90 \ - m_vwnd10mNode.F90 \ - mp_compact_diffs_mod1.f90 \ - mp_compact_diffs_support.f90 \ - mpimod.F90 \ - mpl_allreduce.F90 \ - mpl_bcast.f90 \ - native_endianness.f90 \ - netcdf_mod.f90 \ - ncepgfs_ghg.f90 \ - ncepgfs_io.f90 \ - ncepnems_io.f90 \ - nlmsas_ad.f90 \ - normal_rh_to_q.f90 \ - nstio_module.f90 \ - Nst_Var_ESMFMod.f90 \ - obserr_allsky_mw.f90 \ - obs_ferrscale.F90 \ - obs_sensitivity.f90 \ - obsmod.F90 \ - omegas_ad.f90 \ - ozinfo.f90 \ - patch2grid_mod.f90 \ - pcgsoi.f90 \ - pcgsqrt.f90 \ - pcp_k.f90 \ - pcpinfo.f90 \ - penal.f90 \ - phil.f90 \ - phil1.f90 \ - plib8.f90 \ - polcarf.f90 \ - prad_bias.f90 \ - precond.f90 \ - precpd_ad.f90 \ - prewgt.f90 \ - prewgt_reg.f90 \ - projmethod_support.f90 \ - prt_guess.f90 \ - psichi2uv_reg.f90 \ - psichi2uvt_reg.f90 \ - q_diag.f90 \ - qcmod.f90 \ - qnewton3.f90 \ - raflib.f90 \ - rapidrefresh_cldsurf_mod.f90 \ - rdgrbsst.f90 \ - read_files.f90 \ - read_gfs_ozone_for_regional.f90 \ - read_guess.F90 \ - read_mitm_mxtm.f90 \ - reorg_metar_cloud.f90 \ - rfdpar.f90 \ - rsearch.F90 \ - rtlnmc_version3.f90 \ - satthin.F90 \ - set_crtm_aerosolmod.f90 \ - set_crtm_cloudmod.f90 \ - setupaod.f90 \ - setuppm10.f90 \ - sfc_model.f90 \ - sfcobsqc.f90 \ - simpin1.f90 \ - simpin1_init.f90 \ - smooth_polcarf.f90 \ - smoothrf.f90 \ - smoothwwrf.f90 \ - smoothzrf.f90 \ - sqrtmin.f90 \ - ssmis_spatial_average_mod.f90 \ - control2state_ad.f90 \ - ensctl2state_ad.f90 \ - state_vectors.f90 \ - statsco.f90 \ - statsconv.f90 \ - statsoz.f90 \ - statspcp.f90 \ - statsrad.f90 \ - stop1.f90 \ - stpaod.f90 \ - stpcalc.f90 \ - stpco.f90 \ - stpdw.f90 \ - stpgps.f90 \ - stpgust.f90 \ - stphowv.f90 \ - stpcldch.f90 \ - stpjo.f90 \ - stpjcmod.f90 \ - stplcbas.f90 \ - stpoz.f90 \ - stppblh.f90 \ - stppcp.f90 \ - stppm2_5.f90 \ - stppm10.f90 \ - stppmsl.f90 \ - stpmitm.f90 \ - stpmxtm.f90 \ - stpps.f90 \ - stppw.f90 \ - stpq.f90 \ - stprad.f90 \ - stprw.f90 \ - stpspd.f90 \ - stpsst.f90 \ - stpt.f90 \ - stptcamt.f90 \ - stptcp.f90 \ - stptd2m.f90 \ - stpvis.f90 \ - stpw.f90 \ - stpwspd10m.f90 \ - stpuwnd10m.f90 \ - stpvwnd10m.f90 \ - strong_bal_correction.f90 \ - strong_baldiag_inc.f90 \ - strong_fast_global_mod.f90 \ - sub2fslab_mod.f90 \ - support_2dvar.f90 \ - cplr_gfs_nstmod.f90 \ - stub_pertmod.F90 \ - stub_ensmod.f90 \ - stub_set_crtm_aerosol.f90 \ - stub_timermod.f90 \ - tendsmod.f90 \ - test_obsens.f90 \ - tcv_mod.f90 \ - timermod.f90 \ - tintrp2a.f90 \ - tintrp3.f90 \ - tpause.f90 \ - tpause_t.F90 \ - tune_pbl_height.f90 \ - turbl.f90 \ - turbl_ad.f90 \ - turbl_tl.f90 \ - turblmod.f90 \ - tv_to_tsen.f90 \ - unfill_mass_grid2.f90 \ - unfill_nmm_grid2.f90 \ - unhalf_nmm_grid2.f90 \ - update_guess.f90 \ - wind_fft.f90 \ - wrf_mass_guess_mod.f90 \ - wrf_params_mod.f90 \ - write_all.F90 \ - write_bkgvars_grid.f90 \ - xhat_vordivmod.f90 \ - zrnmi_mod.f90 - - SRCSF90C_NOSWAP = \ - buddycheck_mod.f90 \ - get_gefs_ensperts_dualres.f90 \ - gsi_unformatted.F90 \ - m_extOzone.F90 \ - obs_para.f90 \ - observer.F90 \ - oneobmod.F90 \ - radiance_mod.f90 \ - radinfo.f90 \ - read_Lightning.f90 \ - read_nasa_larc.f90 \ - read_radarref_mosaic.f90 \ - read_aerosol.f90 \ - read_airs.f90 \ - read_amsr2.f90 \ - read_amsre.f90 \ - read_anowbufr.f90 \ - read_avhrr.f90 \ - read_avhrr_navy.f90 \ - read_atms.f90 \ - read_bufrtovs.f90 \ - read_co.f90 \ - read_cris.f90 \ - read_diag.f90 \ - read_fl_hdob.f90 \ - read_gmi.f90 \ - read_goesimg.f90 \ - read_ahi.f90 \ - read_goesimgr_skycover.f90 \ - read_goesndr.f90 \ - read_gps.f90 \ - read_lag.f90 \ - read_iasi.f90 \ - read_l2bufr_mod.f90 \ - read_lidar.f90 \ - read_modsbufr.f90 \ - read_nsstbufr.f90 \ - read_obs.F90 \ - read_ozone.f90 \ - read_pblh.f90 \ - read_pcp.f90 \ - read_prepbufr.f90 \ - read_radar.f90 \ - read_saphir.f90 \ - read_satwnd.f90 \ - read_satmar.f90 \ - read_sfcwnd.f90 \ - read_rapidscat.f90 \ - read_seviri.f90 \ - read_ssmi.f90 \ - read_ssmis.f90 \ - read_tcps.f90 \ - setupbend.f90 \ - setupco.f90 \ - setupdw.f90 \ - setupgust.f90 \ - setuphowv.f90 \ - setupcldch.f90 \ - setuplag.f90 \ - setuplcbas.f90 \ - setupmitm.f90 \ - setupmxtm.f90 \ - setupoz.f90 \ - setuppblh.f90 \ - setuppcp.f90 \ - setuppmsl.f90 \ - setuppm2_5.f90 \ - setupps.f90 \ - setuppw.f90 \ - setupq.f90 \ - setuprad.f90 \ - setupref.f90 \ - setuprhsall.f90 \ - setuprw.f90 \ - setupspd.f90 \ - setupsst.f90 \ - setupt.f90 \ - setuptcamt.f90 \ - setuptcp.f90 \ - setuptd2m.f90 \ - setupvis.f90 \ - setupw.f90 \ - setupwspd10m.f90 \ - setupuwnd10m.f90 \ - setupvwnd10m.f90 \ - sst_retrieval.f90 \ - read_NASA_LaRC_cloud.f90 - - GSIGC_SRCS = - - SRCSF77 = - - SRCSC = blockIO.c - - SRCSNOC = $(SRCSF90C_NOSWAP) $(SRCSF90C) $(GSIGC_SRCS) $(SRCSF77) - - SRCS = $(SRCSNOC) $(SRCSC) $(XSRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - SRCSF90_NOSWAP= ${SRCSF90C_NOSWAP:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - OBJS_NOSWAP = ${SRCSF90_NOSWAP:.f90=.o} - - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -$(OBJS_NOSWAP) : - @echo '---> Special handling of Fortran "native" BUFR-OPEN $<' - $(CF) -c $(FFLAGS_NOSWAP) $< - - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) $(OBJS_NOSWAP) - $(LD) $(LDFLAGS) -o $@ $(OBJS) $(OBJS_NOSWAP) $(LIBS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "FFLAGS_NOSWAP=$(FFLAGS_NOSWAP_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) $(OBJS_NOSWAP) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -library : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "FFLAGS_NOSWAP=$(FFLAGS_NOSWAP_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) $(OBJS_NOSWAP) - @echo - @echo '==== CREATING LIBRARY ========================================' - $(MAKE) lib - mv $(LIB) ../lib - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "FFLAGS_NOSWAP=$(FFLAGS_NOSWAP_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) $(OBJS_NOSWAP) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -make_dep: - /bin/rm -f Makefile.dependency - sorted_SRCS=$$(for e in $(SRCSNOC); do echo $$e; done | env LC_ALL=C sort -u);\ - bash make_depend.bash $$sorted_SRCS > Makefile.dependency - sorted_SRCS=$$(for e in $(SRCSC) $(XSRCSC); do echo $$e; done | env LC_ALL=C sort -u);\ - bash make_depend.bash $$sorted_SRCS >> Makefile.dependency - -# ------------------------- -# GMAO Nomenclature/targets -# ------------------------- -LIB = libgsi.a - -lib: $(LIB) - -gsi.x: $(OBJS) $(OBJS_NOSWAP) $(LIB) - $(FC) $(LDFLAGS) -o gsi.x gsimain.o libgsi.a $(LIBcrtm) $(LIBsfcio) $(LIBsigio) $(LIBw3) $(LIBbacio) $(LIBbfr) $(LIBsp) $(LIBtransf) $(LIBhermes) $(LIBmpeu) $(LIBgfio) $(LIBhdf) $(LIBmpi) $(LIBsys) - -ut_gsibundle.x: $(OBJS) $(OBJS_NOSWAP) $(LIB) ut_gsibundle.o - $(FC) $(LDFLAGS) -o ut_gsibundle.x ut_gsibundle.o libgsi.a $(LIBcrtm) $(LIBsfcio) $(LIBsigio) $(LIBw3) $(LIBbacio) $(LIBbfr) $(LIBsp) $(LIBtransf) $(LIBhermes) $(LIBmpeu) $(LIBgfio) $(LIBhdf) $(LIBmpi) $(LIBsys) - -prepbykx.x: prepbykx.o - $(FC) $(LDFLAGS) -o prepbykx.x prepbykx.o $(LIBbfr) - -$(LIB): $(OBJS) $(OBJS_NOSWAP) - $(RM) $(LIB) - $(AR) $@ $(OBJS) $(OBJS_NOSWAP) - -# Targets for maintenance purposes -# -MAIN_OBJS = gsimain.o -LIBS_OBJS = $(OBJS) $(OBJS_NOSWAP) - -list-main_objs: - @ for f in $(MAIN_OBJS); do echo $$f; done | env LC_ALL=C sort -u - -list-libs_objs: - @ for f in $(LIBS_OBJS); do echo $$f; done | grep -v `for p in $(MAIN_OBJS); do echo "-e $$p"; done` | env LC_ALL=C sort -u - -list-libs_srcs: - @ for f in $(LIBS_OBJS); do echo $$(basename $$f .o).[Ff]90; done | grep -v $$(for p in $(MAIN_OBJS); do echo "-e $$(basename $$p .o)."; done) | env LC_ALL=C sort -u - -list-compare: - @ make --no-print-directory -f Makefile list-libs_srcs | grep -v -e blockIO. > $@.__ - @ ls -1 *.[Ff]90 | env LC_ALL=C sort -u | (diff $@.__ -||true) - @ rm -f $@.__ -#---------- - -export: libgsi.a gsi.x prepbykx.x - $(MKDIR) $(COREBIN) - $(CP) $(LIB) $(CORELIB) - $(CP) gsi.x $(COREBIN) - $(CP) gsi.rc.sample $(COREETC)/gsi.rc - $(CP) tlmadj_parameter.rc.sample $(COREETC)/tlmadj_parameter.rc - $(CP) gmao_airs_bufr.tbl $(COREETC)/gmao_airs_bufr.tbl - $(CP) gmao_global_pcpinfo.txt $(COREETC)/gmao_global_pcpinfo.rc - $(CP) gmao_global_satinfo.txt $(COREETC)/gmao_global_satinfo.rc - $(CP) gmao_global_ozinfo.txt $(COREETC)/gmao_global_ozinfo.rc - $(CP) gmao_global_convinfo.txt $(COREETC)/gmao_global_convinfo.rc - $(SED) -e "s^@DASPERL^$(DASPERL)^" < analyzer > $(COREBIN)/analyzer - chmod 755 $(COREBIN)/analyzer - -doc: AnIntro $(DOCSRC) - $(PROTEX) AnIntro *.f90 *.F90 > gsi.tex - $(LATEX) gsi.tex - $(LATEX) gsi.tex - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - -help: - @ echo "Available targets:" - @ echo "NCEP: make creates gsi executable " - @ echo "NPEP: make debug created gsi exec for debugging purposes" - @ echo "NCEP: make install creates gsi exec & places it in bin" - @ echo "GMAO: make lib creates gsi library" - @ echo "GMAO: make export creates lib, exec, & copies all to bin/inc/etc" - @ echo " make clean cleans objects, exec, and alien files" - @ echo " make doc creates documentation" - @ echo " make doclean clean doc-related temporary files" - diff --git a/src/Makefile.conf.AIX b/src/Makefile.conf.AIX deleted file mode 100644 index d9bacc191..000000000 --- a/src/Makefile.conf.AIX +++ /dev/null @@ -1,129 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -COREINC = /nwprod/lib/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 -INCnemsio = $(COREINC)/nemsio -#INCcrtm = $(COREINC)/crtm_2.1.3 -INCw3 = $(COREINC)/w3_d - -INCcrtm = /global/save/wx20ml/CRTM_REL-2.1.3/include -LIBcrtm = /global/save/wx20ml/CRTM_REL-2.1.3/lib/libCRTM.a - -WRFPATH=/nwprod/sorc/nam_nmm_real_fcst.fd -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -INCnetcdf = /nwprod/lib/sorc/netcdf/netcdf-3.5.0/include -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpxlf95_r - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -qsmp=noauto - - FFLAGS_F90 = -qfree=f90 -qsuffix=f=f90:cpp=F90 -WF,-Dibm_sp,,-D_REAL8_ - - FFLAGS_COM_N = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnetcdf) -I ${INCnemsio} -I $(INCw3) -qarch=auto -O3 \ - -qmaxmem=-1 -qfullpath -qdbg -qstrict -q64 $(OMP) - - FFLAGS_COM_N_NOSWAP = $(FFLAGS_COM_N) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = -qfixed $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - - -#--- Debug mode options -# -qflttrap=overflow:zero:enable \ is ok -# -qflttrap=overflow:zero:underflow:enable \ fails -# -qsave=all \ fails, so removing from option list - FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnetcdf) -I ${INCnemsio} -I $(INCw3) -qarch=auto \ - -qmaxmem=-1 -qfullpath -qdbg -qstrict -q64 \ - -O0 \ - -qinitauto=7FF7FFFF \ - -qcheck \ - -qwarn64 \ - -qflag=i:u \ - -qlistopt \ - -qsource - - FFLAGS_COM_NOSWAP_D = $(FFLAGS_COM_D) - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = /usr/vac/bin/cc_r - -#--- Normal mode options - - CFLAGS_N = -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -DIBM4 -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -DIBM4 -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = -L/nwprod/lib -lnemsio -lw3_d -lsp_d -lbufr_v10.1.0_d_64 -lbacio_4 -lmpitrace \ - -lsigio_4 -lsfcio_4 -lnetcdf_64 \ - $(LIBcrtm) $(WRFLIB) - - LDFLAGS_N = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) $(PROF) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) -lhmd - - LDFLAGS_D = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.IRIX b/src/Makefile.conf.IRIX deleted file mode 100644 index 3de9285aa..000000000 --- a/src/Makefile.conf.IRIX +++ /dev/null @@ -1,107 +0,0 @@ -#!/bin/make -#----------------------------------------------------------------------- -# NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -#----------------------------------------------------------------------- -# !IROUTINE: Makefile.conf.IRIX -# -# !DESCRIPTION: -# An included local make configuration. See file Makefile for -# detailed `make' procedure. This shell has been built to override -# the default environments (including commands) defined in file -# Makefile. -# -# + `uname -a` = "OSF1 molotov V3.2 17 alpha" -# -# !CALLING SEQUENCE: -# % ln -s Makefile.OSF1 Makefile.conf -# % make ... -# -# !SEE ALSO: Makefile -# -# !REVISION HISTORY: (`cvs log <>' for more) -# 22Apr2004 - Kokron/RT - default to scsl lib; to use -lcomplib.sgimath also -# need -D_OLDSGIFFT_ -# 01Mar2006 - Treadon - remove reference to irsse, add sigio -# -#----------------------------------------------------------------------- - -# Environments -# ============ - -SHELL = /bin/sh -F77 = f90 -F90 = f90 -FC = $(F90) -CF = $(F90) - -# Turn all debugging code on for this module. -_DDEBUG = -DDEBUG_TRACE \ - -DDEBUG_CHECKSUMS - -# Turn assertions off. -_DDEBUG = -NDEBUG - -# No debugging. Only assertions -_DDEBUG = - -_D = -D_GMAO_FVGSI_ -D_IGNORE_GRIDVERIFY_ $(_DDEBUG) $(_Dsys) - -_R = -r8 -_I = -I ./ -I/ford1/local/irix6.2/mpi/include -_I = -I ./ -I$(COREINC)/mpeu -I$(COREINC)/sfcio -I$(COREINC)/sigio - -FFLAGR = $(_I) $(_D) ./ -extend_source -r8 -i4 -O2 -n32 \ - -OPT:Olimit=0:roundoff=3:reorg_common=OFF -LNO:prefetch=2 -bytereclen - -LIBbacio = -L$(CORELIB) -lbacio_r4i4 -LIBsp = -LIBmpi = -L/ford1/local/irix6.2/mpi/lib/IRIXN32/ch_p4 -lmpi -LIBsys = -lscs - -#--- Normal mode options - -FFLAGS_F90 = -cpp -extend_source -FFLAGS_F90 = -cpp -extend_source -D_OLDSGIFFT_ -FFLAGS_COM_N = $(_I) -n32 -r8 -i4 -OPT:Olimit=0:roundoff=3:reorg_common=OFF -LNO:prefetch=2 -FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) -FFLAGS_f = $(FFLAGS_N) - -CFLAGS_N = $(_I) -O3 - -LIBS_N = $(LIBmpeu) $(LIBmpi) $(LIBbfr) $(LIBw3) $(LIBsys) - -LDFLAGS_N = -n32 - -FFLAGS = $(FFLAGS_N) - -#--- Debug mode options - -FFLAGS_COM_D = $(FFLAGS_COM_N) \ - -O0 -g -check_bounds \ - -DEBUG:subscript_check=ON:div_check=3:trap_uninitialized=ON:verbose_runtime=ON \ - -fullwarn -FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) -CFLAGS_D = -I ./ -g - -LIBS_D = $(LIBS_N) - -LDFLAGS_D = $(LDFLAGS_N) - -ZIP = /usr/bin/compress -ZCAT = /usr/bin/zcat -TAR = /usr/bin/tar - -LD = $(FC) -LDFLAGS = $(FFLAGS) $(LIBdxml_DIR) -AR = ar cqs -RM = rm -f - -CPPFLAGS = -cpp -FPPFLAGS = $(CPPFLAGS) - -FDP = fdp # Fortran make depency script - -#.---------------------------------------------------------------------- -# Extra source code on IRIX only -#.---------------------------------------------------------------------- -XSRCSC = diff --git a/src/Makefile.conf.IRIX64 b/src/Makefile.conf.IRIX64 deleted file mode 100644 index 1431eb65f..000000000 --- a/src/Makefile.conf.IRIX64 +++ /dev/null @@ -1,116 +0,0 @@ -#!/bin/make -#----------------------------------------------------------------------- -# NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -#----------------------------------------------------------------------- -# !IROUTINE: Makefile.conf.Linux -# -# !DESCRIPTION: -# An included local make configuration. See file Makefile for -# detailed `make' procedure. This shell has been built to override -# the default environments (including commands) defined in file -# Makefile. -# -# + `uname -a` = "OSF1 molotov V3.2 17 alpha" -# -# !CALLING SEQUENCE: -# % ln -s Makefile.OSF1 Makefile.conf -# % make ... -# -# !SEE ALSO: Makefile -# -# !REVISION HISTORY: (`cvs log <>' for more) -# 22Apr2004 - Kokron/RT - default to scsl lib; to use -lcomplib.sgimath also -# need -D_OLDSGIFFT_ -# 22Sep2004 - Todling - removed -r8; added ref to crtm -# 16Dec2004 - Treadon - added ref to irsse -# 02Feb2005 - Treadon - add reference to bacio and sfcio -# 16Feb2005 - Todling - removed ref to bacio (all in w3 lib) -# 01Mar2006 - Treadon - remove reference to irsse, add sigio -# -#----------------------------------------------------------------------- - -# Environments -# ============ - -SHELL = /bin/sh -F77 = f90 -F90 = f90 -FC = $(F90) -CF = $(F90) - -#________________________________________ -# Preprocessor flags, "-D" - -# Turn all debugging code on for this module. -_DDEBUG = -DDEBUG_TRACE \ - -DDEBUG_CHECKSUMS - -# Turn assertions off. -_DDEBUG = -NDEBUG - -# No debugging. Only assertions -_DDEBUG = - -_D = -D_GMAO_FVGSI_ -D_IGNORE_GRIDVERIFY_ $(_DDEBUG) $(_Dsys) - -_R = -_I = -I ./ -I$(COREINC)/mpeu -I$(COREINC)/crtm \ - -I$(COREINC)/sfcio -I$(COREINC)/sigio -I$(COREINC)/hermes -I$(COREINC)/transf - -FFLAGR = $(_I) $(_D) -I ./ -extend_source $(_R) -i4 -O2 -64 \ - -OPT:Olimit=0:roundoff=3:reorg_common=OFF -LNO:prefetch=2 -bytereclen - -#________________________________________ - -LIBbacio = -L$(CORELIB) -lbacio_r4i4 -LIBsys = -lscs - -#--- Normal mode options - -FFLAGS_F90 = -cpp -extend_source -D_OLDSGIFFT_ -FFLAGS_F90 = -cpp -extend_source -FFLAGS_COM_N = $(_I) -I ./ -64 $(_R) -i4 -OPT:Olimit=0:roundoff=3:reorg_common=OFF -LNO:prefetch=2 -FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) -FFLAGS_f = $(FFLAGS_N) - -CFLAGS_N = $(_I) -I ./ -O3 - -LIBS_N = $(LIBhermes) $(LIBgfio) $(LIBmpeu) $(LIBmpi) $(LIBbfr) $(LIBw3) $(LIBhdf) $(LIBsys) - -LDFLAGS_N = -64 - -FFLAGS = $(FFLAGS_N) - -#--- Debug mode options - -FFLAGS_COM_D = $(FFLAGS_COM_N) \ - -O0 -g -check_bounds \ - -DEBUG:subscript_check=ON:div_check=3:trap_uninitialized=ON:verbose_runtime=ON \ - -fullwarn -FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) -CFLAGS_D = -I ./ -g - -LIBS_D = $(LIBS_N) - -LDFLAGS_D = $(LDFLAGS_N) - -ZIP = /usr/bin/compress -ZCAT = /usr/bin/zcat -TAR = /usr/bin/tar - -LD = $(FC) -LDFLAGS = $(FFLAGS) $(LIBdxml_DIR) -AR = ar cqs -RM = rm -f - -CPPFLAGS = -cpp -FPPFLAGS = $(CPPFLAGS) -F77PPFLAGS = $(FPPFLAGS) -DLANGUAGE_FORTRAN -D__LANGUAGE_FORTRAN__ -F90PPFLAGS = $(FPPFLAGS) -DLANGUAGE_FORTRAN_90 -D__LANGUAGE_FORTRAN_90__ - -FDP = fdp # Fortran make depency script - -#.---------------------------------------------------------------------- -# Extra source code on IRIX64 only -#.---------------------------------------------------------------------- -XSRCSC = diff --git a/src/Makefile.conf.Linux b/src/Makefile.conf.Linux deleted file mode 100644 index f7f5e79aa..000000000 --- a/src/Makefile.conf.Linux +++ /dev/null @@ -1,114 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /misc/whome/Michael.Lueken/nceplibs/incmod -CORELIB = /misc/whome/Michael.Lueken/nceplibs/lib -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 -INCnemsio= $(COREINC)/nemsio -INCw3 = $(COREINC)/w3emc_d -INCcrtm=$(COREINC)/CRTM - -WRFPATH = /mnt/pan2/projects/hwrf-vd/Mingjing.Tong/hwrf-trunk/sorc/WRFV3 -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -INCnetcdf = ${NETCDF}/include -LIBnetcdf = -L$(NETCDF)/lib -lnetcdf -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -D_REAL8_ - - FFLAGS_COM_N = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) -O3 -xHOST -traceback -assume byterecl -convert big_endian $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) -O3 -xHOST -traceback $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) -O0 -xHOST -traceback -assume byterecl -convert big_endian - FFLAGS_COM_NOSWAP_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) -O0 -xHOST -traceback - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -mkl - -#--- Normal mode options - - LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ - -lsfcio_4 -lbufr_d_64 -lw3nco_d -lw3emc_d -lCRTM $(WRFLIB) $(LIBnetcdf) - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.Linux.IA64.efc b/src/Makefile.conf.Linux.IA64.efc deleted file mode 100644 index 882c08049..000000000 --- a/src/Makefile.conf.Linux.IA64.efc +++ /dev/null @@ -1,143 +0,0 @@ -#!/bin/make -#----------------------------------------------------------------------- -# NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -#----------------------------------------------------------------------- -# !IROUTINE: Makefile.conf.Linux -# -# !DESCRIPTION: -# An included local make configuration. See file Makefile for -# detailed `make' procedure. This shell has been built to override -# the default environments (including commands) defined in file -# Makefile. -# -# + `uname -a` = "OSF1 molotov V3.2 17 alpha" -# -# !CALLING SEQUENCE: -# % ln -s Makefile.OSF1 Makefile.conf -# % make ... -# -# !SEE ALSO: Makefile -# -# !REVISION HISTORY: (`cvs log <>' for more) -# 01Jan04 - GMAO Staff - created based on general procedures -# 19May04 - Todling - added ref to libmpeu -# 15Feb05 - Todling - added ref to irsse, bacio and sfcio -# 16Feb05 - Todling - removed ref to bacio (all in w3 lib) -# 01Mar06 - Treadon - remove reference to irsse, add sigio -# -#----------------------------------------------------------------------- - -# Environments -# ============ - - -SHELL = /bin/sh -F90 = efc -FC = $(F90) -CF = $(F90) - - ifndef BASEDIR -BASEDIR = /usr/local/baselibs/latest - endif - -LIBbacio = -L$(CORELIB) -lbacio_r4i4 -LIBmpi = -L$(BASEDIR)/$(ARCH)/lib -lmpi - -# Turn all debugging code on for this module. -_DDEBUG = -DDEBUG_TRACE \ - -DDEBUG_CHECKSUMS - -# Turn assertions off. -_DDEBUG = -NDEBUG - -# No debugging. Only assertions -_DDEBUG = - -_D = -D_GMAO_FVGSI_ -D_IGNORE_GRIDVERIFY_ $(_DDEBUG) $(_Dsys) - -_I = -I$(COREINC)/mpeu -I$(COREINC)/hermes -I$(COREINC)/crtm \ - -I$(COREINC)/sfcio -I$(COREINC)/sigio -I$(COREINC)/transf - -FOPT_normal = -O3 -stack_temps -r8 $(_I) $(_D) -#FOPT_normal = -O -cm -r8 -check bounds $(_I) $(_D) -FOPT_nobig = -O3 -stack_temps -r8 $(_I) $(_D) -FOPT_syntax = -syntax_only $(_I) $(_D) - -CPPFLAGS = -cpp -FFLAGS_F90 = $(CPPFLAGS) -CFLAGS_N = - -FFLAGS_COM_N = $(FOPT_normal) -FFLAGS_nobig = $(FFLAGS_F90) $(FOPT_nobig) -FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) -FFLAGS = $(FFLAGS_N) -FFLAGS_f = $(FFLAGS_N) - -LD = $(FC) -LDFLAGS = $(FFLAGS) -lPEPCF90 -AR = ar rv -RM = rm -f - -LIBsp = $(CORELIB)/libsp.a -LIBbfr = $(CORELIB)/libbfr.a -LIBsys = -lscs -LIBS_N = $(LIBmpeu) $(LIBbfr) $(LIBw3) $(LIBmpi) $(LIBsys) - -FDP = fdp # Fortran make depency script - -read_airs.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_avhrr_navy.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_atms.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_bufrtovs.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_goesimg.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_goesndr.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_gps_ref.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_lidar.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_pcp.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_prepbufr.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_radar.o: - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_ssmi.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -read_superwinds.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -#.---------------------------------------------------------------------- -# Extra source code on IRIX64 only -#.---------------------------------------------------------------------- -XSRCSC = diff --git a/src/Makefile.conf.Linux.IA64.ifort b/src/Makefile.conf.Linux.IA64.ifort deleted file mode 100644 index b182d168d..000000000 --- a/src/Makefile.conf.Linux.IA64.ifort +++ /dev/null @@ -1,132 +0,0 @@ -#!/bin/make -#----------------------------------------------------------------------- -# NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -#----------------------------------------------------------------------- -# !IROUTINE: Makefile.conf.Linux -# -# !DESCRIPTION: -# An included local make configuration. See file Makefile for -# detailed `make' procedure. This shell has been built to override -# the default environments (including commands) defined in file -# Makefile. -# -# + `uname -a` = "OSF1 molotov V3.2 17 alpha" -# -# !CALLING SEQUENCE: -# % ln -s Makefile.OSF1 Makefile.conf -# % make ... -# -# !SEE ALSO: Makefile -# -# !REVISION HISTORY: (`cvs log <>' for more) -# 01Jan04 - GMAO Staff - created based on general procedures -# 19May04 - Todling - added ref to libmpeu -# 16Dec2004 - Treadon - added ref to irsse -# 02Feb2005 - Treadon - add reference to bacio and sfcio -# 16Feb2005 - Todling - removed ref to bacio (all in w3 lib) -# 01Mar2006 - Treadon - remove reference to irsse, add reference to sigio -# -#----------------------------------------------------------------------- - -# Environments -# ============ - - -SHELL = /bin/sh -F90 = ifort -FC = $(F90) -CF = $(F90) - - ifndef BASEDIR -BASEDIR = /usr/local/baselibs/latest - endif - -LIBbacio = -L$(CORELIB) -lbacio_r4i4 -LIBmpi = -L$(BASEDIR)/$(ARCH)/lib -lmpi - -# Turn all debugging code on for this module. -_DDEBUG = -DDEBUG_TRACE \ - -DDEBUG_CHECKSUMS - -# Turn assertions off. -_DDEBUG = -NDEBUG - -# No debugging. Only assertions -_DDEBUG = - -_D = -D_GMAO_FVGSI_ -D_IGNORE_GRIDVERIFY_ $(_DDEBUG) $(_Dsys) - -_I = -I$(COREINC)/mpeu -I$(COREINC)/hermes -I$(COREINC)/crtm \ - -I$(COREINC)/sfcio -I$(COREINC)/sigio -I$(COREINC)/transf - -FOPT_normal = -O3 -IPF_fma -IPF_fp_relaxed -override_limits -r8 -convert big_endian -assume byterecl $(_I) $(_D) -FOPT_normal = -O3 -override_limits -convert big_endian -assume byterecl $(_I) $(_D) -FOPT_nobig = -O3 -override_limits -assume byterecl $(_I) $(_D) -FOPT_syntax = -syntax_only $(_I) $(_D) - -CPPFLAGS = -cpp -FFLAGS_F90 = $(CPPFLAGS) -CFLAGS_N = - -FFLAGS_COM_N = $(FOPT_normal) -FFLAGS_nobig = $(FFLAGS_F90) $(FOPT_nobig) -FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) -FFLAGS = $(FFLAGS_N) -FFLAGS_f = $(FFLAGS_N) - -LD = $(FC) -LDFLAGS = $(FFLAGS) -AR = ar rv -RM = rm -f - -LIBsp = $(CORELIB)/libsp.a -LIBbfr = $(CORELIB)/libbfr.a -LIBsys = -lscs -LIBS_N = $(LIBmpeu) $(LIBbfr) $(LIBw3) $(LIBmpi) $(LIBsys) - -FDP = fdp # Fortran make depency script - -read_airs.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_avhrr_navy.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_atms.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_bufrtovs.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_goesimg.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_goesndr.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_gps_ref.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_lidar.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_pcp.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_prepbufr.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_radar.o: - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_ssmi.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< -read_superwinds.o : - @echo '---> Compiling $<' - $(CF) $(FFLAGS_nobig) -c $< - -#.---------------------------------------------------------------------- -# Extra source code on IRIX64 only -#.---------------------------------------------------------------------- -XSRCSC = diff --git a/src/Makefile.conf.Linux.jet b/src/Makefile.conf.Linux.jet deleted file mode 100644 index 18232df35..000000000 --- a/src/Makefile.conf.Linux.jet +++ /dev/null @@ -1,83 +0,0 @@ -#!/bin/make -#----------------------------------------------------------------------- -# NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -#----------------------------------------------------------------------- -# !IROUTINE: Makefile.conf.Linux -# -# !DESCRIPTION: -# An included local make configuration. See file Makefile for -# detailed `make' procedure. This shell has been built to override -# the default environments (including commands) defined in file -# Makefile. -# -# + `uname -a` = "OSF1 molotov V3.2 17 alpha" -# -# !CALLING SEQUENCE: -# % ln -s Makefile.OSF1 Makefile.conf -# % make ... -# -# !SEE ALSO: Makefile -# -# !REVISION HISTORY: (`cvs log <>' for more) -# 01Jan04 - GMAO Staff - created based on general procedures -# 19May04 - Todling - added ref to libmpeu -# 22Sep04 - Todling - added ref to crtm -# 16Dec04 - Treadon - added ref to irsse -# 02Feb05 - Treadon - add reference to bacio and sfcio -# 16Feb05 - Todling - removed ref to bacio (all in w3 lib) -# 01Mar06 - Treadon - remove reference to irsse, add sigio -# -#----------------------------------------------------------------------- - -# Environments -# ============ - - -SHELL = /bin/sh -F90 = mpif90 -FC = $(F90) -CF = $(F90) - - ifndef BASEDIR -BASEDIR = /usr/local/baselibs/latest - endif - -#LIBmpi = -L$(BASEDIR)/$(ARCH)/lib -lmpich -lpmpich - -_I = -I$(COREINC)/mpeu -I$(COREINC)/crtm -I$(COREINC)/sfcio -I$(COREINC)/sigio - -#FOPT_normal = -O0 -assume byterecl -g -traceback -CA -CB -CU $(_I) -#FOPT_normal = -O3 -xW -assume byterecl $(_I) -DNOMPI2 -#FOPT_nobig = -O3 -xW -assume byterecl $(_I) -DNOMPI2 -FOPT_normal = -O3 -xW -assume byterecl $(_I) -FOPT_nobig = -O3 -xW -assume byterecl $(_I) -FOPT_syntax = -syntax_only $(_I) - -CPPFLAGS = -FFLAGS_F90 = $(CPPFLAGS) -CFLAGS_N = -D__osf__ -Dfunder -DFortranByte=char -DFortranInt=int - -FFLAGS_COM_N = $(FOPT_normal) -FFLAGS_nobig = $(FOPT_nobig) -FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) -FFLAGS = $(FFLAGS_N) -FFLAGS_f = $(FFLAGS_N) - -LD = $(FC) -#LDFLAGS = -O3 -xW $(_I) -LDFLAGS = -xW -AR = ar rv -RM = rm -f - -#LIBsys = -llapackmt -lblasmt -LIBS_N = $(LIBmpeu) $(LIBbfr) $(LIBw3) $(LIBsp) $(LIBbacio) \ - $(LIBcrtm) $(LIBmpi) $(LIBsys) $(LIBwrf) $(LIBsfcio) $(LIBsigio) \ - $(LIBwrfio_int) $(LIBwrfio_netcdf) $(LIBwrfrsl) \ - $(LIBwrfesmftime) $(LOADWRF) $(LIBnetcdf) - -FDP = fdp # Fortran make depency script - -#.---------------------------------------------------------------------- -# Extra source code on IRIX64 only -#.---------------------------------------------------------------------- -XSRCSC = diff --git a/src/Makefile.conf.Linux.lf95 b/src/Makefile.conf.Linux.lf95 deleted file mode 100644 index 9bdf55e48..000000000 --- a/src/Makefile.conf.Linux.lf95 +++ /dev/null @@ -1,92 +0,0 @@ -#!/bin/make -#----------------------------------------------------------------------- -# NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -#----------------------------------------------------------------------- -# !IROUTINE: Makefile.conf.Linux -# -# !DESCRIPTION: -# An included local make configuration. See file Makefile for -# detailed `make' procedure. This shell has been built to override -# the default environments (including commands) defined in file -# Makefile. -# -# + `uname -a` = "OSF1 molotov V3.2 17 alpha" -# -# !CALLING SEQUENCE: -# % ln -s Makefile.OSF1 Makefile.conf -# % make ... -# -# !SEE ALSO: Makefile -# -# !REVISION HISTORY: (`cvs log <>' for more) -# 01Jan04 - GMAO Staff - created based on general procedures -# 19May04 - Todling - added ref to libmpeu -# 22Sep04 - Todling - added ref to crtm -# 16Dec04 - Treadon - added ref to irsse -# 02Feb05 - Treadon - add reference to bacio and sfcio -# 16Feb05 - Todling - removed ref to bacio (all in w3 lib) -# 01Mar06 - Treadon - remove reference to irsse, add sigio -# -#----------------------------------------------------------------------- - -# Environments -# ============ - - -SHELL = /bin/sh -F90 = lf95 -FC = $(F90) -CF = $(F90) -ARCH = Linux - - ifndef BASEDIR -BASEDIR = /usr/local/baselibs/latest - endif - -# Turn all debugging code on for this module. -_DDEBUG = -DDEBUG_TRACE \ - -DDEBUG_CHECKSUMS - -# Turn assertions off. -_DDEBUG = -NDEBUG - -# No debugging. Only assertions -_DDEBUG = - -_D = -D_GMAO_FVGSI_ -D_IGNORE_GRIDVERIFY_ $(_DDEBUG) $(_Dsys) - -_I = -I$(COREINC)/mpeu -I$(COREINC)/crtm \ - -I$(COREINC)/sfcio -I$(COREINC)/sigio -I$(COREINC)/transf - -LIBbacio = -L$(CORELIB) -lbacio -LIBmpi = -L$(BASEDIR)/$(ARCH)/lib -lmpich -lpmpich -_Lnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lz -lsz -ljpeg -_Lmpi = -L$(BASEDIR)/$(ARCH)/lib -lmpich -lpmpich -_Lmath = -L/usr/lib -llapack -lblas \ - -L/usr/lib/gcc-lib/i386-redhat-linux/3.2.2 -lg2c - -FOPT_normal = -O -fw -Am -X9 -w -CcdRR8 -Kfast,eval,fastlib,auto $(_I) $(_D) -FOPT_nobig = -O -fw -Am -X9 -w -CcdRR8 -Kfast,eval,fastlib,auto $(_I) $(_D) -FOPT_syntax = -syntax_only $(_I) $(_D) - -CPPFLAGS = -FFLAGS_F90 = $(CPPFLAGS) -CFLAGS_N = -D__osf__ - -FFLAGS_COM_N = $(FOPT_normal) -FFLAGS_nobig = $(FOPT_nobig) -FFLAGS_N = -O $(FFLAGS_F90) $(FFLAGS_COM_N) -FFLAGS = $(FFLAGS_N) -FFLAGS_f = $(FFLAGS_N) - -LD = $(FC) -LDFLAGS = $(FFLAGS) -AR = ar rv -RM = rm -f - -FDP = fdp # Fortran make depency script - -#.---------------------------------------------------------------------- -# Extra source code -#.---------------------------------------------------------------------- -XSRCSC = diff --git a/src/Makefile.conf.OSF1 b/src/Makefile.conf.OSF1 deleted file mode 100644 index 3156fbcf0..000000000 --- a/src/Makefile.conf.OSF1 +++ /dev/null @@ -1,120 +0,0 @@ -#!/bin/make -#----------------------------------------------------------------------- -# NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -#----------------------------------------------------------------------- -# !IROUTINE: Makefile.conf.Linux -# -# !DESCRIPTION: -# An included local make configuration. See file Makefile for -# detailed `make' procedure. This shell has been built to override -# the default environments (including commands) defined in file -# Makefile. -# -# + `uname -a` = "OSF1 molotov V3.2 17 alpha" -# -# !CALLING SEQUENCE: -# % ln -s Makefile.OSF1 Makefile.conf -# % make ... -# -# !SEE ALSO: Makefile -# -# !REVISION HISTORY: (`cvs log <>' for more) -# 01Jan04 - GMAO Staff - created based on general procedures -# 19May04 - Todling - added ref to libmpeu -# 22Sep04 - Todling - removed -r8; added ref to crtm -# 16Dec04 - Treadon - added ref to irsse -# 02Feb05 - Treadon - add reference to bacio and sfcio -# 01Mar06 - Treadon - remove reference to irsse, add reference to sigio -# -#----------------------------------------------------------------------- - -# Environments -# ============ - - -SHELL = /bin/sh -F90 = f90 -FC = $(F90) -CF = $(F90) - -_I = -I$(COREINC)/mpeu -I$(COREINC)/hermes -I$(COREINC)/crtm \ - -I$(COREINC)/sfcio -I$(COREINC)/sigio -I$(COREINC)/transf - -#________________________________________ -# Preprocessor flags, "-D" - -# Turn all debugging code on for this module. -_DDEBUG = -DDEBUG_TRACE \ - -DDEBUG_CHECKSUMS - -# Turn assertions off. -_DDEBUG = -NDEBUG - -# No debugging. Only assertions -_DDEBUG = - -_D = -D_GMAO_FVGSI_ -D_IGNORE_GRIDVERIFY_ $(_DDEBUG) $(_Dsys) -#________________________________________ - -FOPT_debug = -O -i4 -r8 -convert big_endian -assume byterecl -check_bounds -fast -arch ev67 -tune ev67 $(_I) $(_D) -FOPT_normal = -O -i4 -convert big_endian -assume byterecl -fast -arch ev67 -tune ev67 $(_I) $(_D) -FOPT_nobig = -O -assume byterecl -fast -arch ev67 -tune ev67 $(_I) $(_D) - -CPPFLAGS = -cpp -FFLAGS_F90 = $(CPPFLAGS) - -FFLAGS_COM_N = $(FOPT_normal) -FFLAGS_nobig = $(FOPT_nobig) -FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) -FFLAGS = $(FFLAGS_N) -FFLAGS_f = $(FFLAGS_N) - -LD = $(FC) -LDFLAGS = $(FFLAGS) -AR = ar rv -RM = rm -f - -LIBbacio = -L$(CORELIB) -lbacio_r4i4 -LIBmpi = -lmpi -lmpio -LIBsys = -ldxml - -FDP = fdp # Fortran make depency script - -.f.o: - $(FC) -c -extend_source $(XFLAGS) $(FFLAGS) $(_I) $*.f - -.F.o: - $(FC) -c -extend_source $(XFLAGS) $(FPPFLAGS) $(_DF) $(FFLAGS) $(_I) $*.F - - -#.---------------------------------------------------------------------- -read_airs.o: read_airs.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_airs.f90 -read_avhrr_navy.o: read_avhrr_navy.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_avhrr_navy.f90 -read_atms.o: read_atms.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_atms.f90 -read_bufrtovs.o: read_bufrtovs.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_bufrtovs.f90 -read_goesimg.o: read_goesimg.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_goesimg.f90 -read_goesndr.o: read_goesndr.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_goesndr.f90 -read_gps_ref.o: read_gps_ref.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_gps_ref.f90 -read_lidar.o: read_lidar.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_lidar.f90 -read_pcp.o: read_pcp.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_pcp.f90 -read_prepbufr.o: read_prepbufr.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_prepbufr.f90 -read_radar.o: read_radar.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_radar.f90 -read_ssmi.o: read_ssmi.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_ssmi.f90 -read_superwinds.o: read_superwinds.f90 - $(FC) -c $(FFLAGS_nobig) $(_I) read_superwinds.f90 -#.---------------------------------------------------------------------- -# Extra source code on OSF1 only -#.---------------------------------------------------------------------- -XSRCSC = diff --git a/src/Makefile.conf.cray b/src/Makefile.conf.cray deleted file mode 100644 index d6cf6e49f..000000000 --- a/src/Makefile.conf.cray +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Redefine variables for Cray on WCOSS -# ------------------------------------ - -# Set library versions -BACIO_VER = v2.0.1 -BUFR_VER = v11.0.1 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.2 -NETCDF_VER = 3.6.3 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.2.0 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/include/crtm_$(CRTM_VER) -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/include/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/$(COMPILER)/libbufr_$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/libcrtm_$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDFPATH = /usrx/local/prod/NetCDF/$(NETCDF_VER)/$(COMPILER)/haswell -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -WRFPATH = /gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-$(COMPILER) -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all,noarg_temp_created -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all,noarg_temp_created -fp-stack-check -fstack-protector -warn - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.jet b/src/Makefile.conf.jet deleted file mode 100644 index 0298d2b9c..000000000 --- a/src/Makefile.conf.jet +++ /dev/null @@ -1,118 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /misc/whome/Michael.Lueken/nceplibs/incmod -CORELIB = /misc/whome/Michael.Lueken/nceplibs/lib -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 -INCnemsio= $(COREINC)/nemsio -INCw3 = $(COREINC)/w3emc_d -INCcrtm=$(COREINC)/CRTM - -WRFPATH = /misc/whome/Mingjing.Tong/WRFV3 -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -INCnetcdf = ${NETCDF}/include -LIBnetcdf = -L$(NETCDF)/lib -lnetcdf -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -D_REAL8_ - - FFLAGS_COM_N = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) -O3 $(ARCHINTELOPT) -traceback \ - -mcmodel medium -shared-intel -assume byterecl -convert big_endian $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) -O3 $(ARCHINTELOPT) -traceback \ - -mcmodel medium -shared-intel -assume byterecl -convert big_endian $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) -O0 -traceback \ - -mcmodel medium -shared-intel -assume byterecl -convert big_endian - FFLAGS_COM_NOSWAP_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) -O0 -traceback \ - -mcmodel medium -shared-intel -assume byterecl -convert big_endian - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = icc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(ARCHINTELOPT) $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -mkl - -#--- Normal mode options - - LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ - -lsfcio_4 -lbufr_d_64 -lw3nco_d -lw3emc_d -lCRTM $(WRFLIB) $(LIBnetcdf) - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.jibb b/src/Makefile.conf.jibb deleted file mode 100644 index 8a9bfe412..000000000 --- a/src/Makefile.conf.jibb +++ /dev/null @@ -1,129 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -CORE = /usr/local/jcsda/nwprod_gdas_2014 -CORELIB = /usr/local/jcsda/nwprod_gdas_2014/lib -COREINC = $(CORELIB)/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 -INCgfsio = $(COREINC)/gfsio_4 -INCnemsio = $(COREINC)/nemsio -INCw3emc = $(COREINC)/w3emc_d -INCw3nco = $(COREINC)/w3nco_d -#INCw3lib = $(COREINC)/w3lib-2.0_d -CRTMpath = /jcsda/nobackup/jajung/jung_cris_hsr/lib/CRTM_REL-2.2.3 - -INCcrtm = $(CRTMpath)/crtm_v2.2.3/incmod/crtm_v2.2.3 -LIBcrtm = $(CRTMpath)/crtm_v2.2.3/libcrtm_v2.2.3.a - -WRFPATH=$(CORE)/sorc/nam_nmm_real_fcst.fd - -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -#INCnetcdf = $(COREINC)/netcdf -INCnetcdf = /usr/local/unsupported/SLES11.1/netcdf4/4.1.3/intel-13.1.3.192/include -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 - FC = $(CF) - -#--- Normal mode options - - PROF= #-g -pg -qfullpath - - FFLAGS_F90 = -fp-model strict -assume byterecl -free -traceback -D_REAL8_ -openmp -axavx -xsse4.2 -# FFLAGS_F90 = -O2 -fp-model strict -assume byterecl -convert big_endian -free -xHOST -traceback \ - -openmp - - FFLAGS_COM_N = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCgfsio) -I $(INCnetcdf) \ - -I $(INCnemsio) -I $(INCw3emc) -O2 -convert big_endian\ - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCgfsio) -I $(INCnetcdf) \ - -I $(INCnemsio) -I $(INCw3emc) -O2 -convert big_endian - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - -#--- Debug mode options -# -qflttrap=overflow:zero:enable \ is ok -# -qflttrap=overflow:zero:underflow:enable \ fails - FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCgfsio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3emc) -O0 -convert big_endian \ - -implicitnone -g -debug -ftrapuv -check all -fp-stack-check -fstack-protector - FFLAGS_COM_NOSWAP_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCGFSIO) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3emc) -O0 -convert big_endian -implicitnone -g -debug -ftrapuv -check all \ - -fp-stack-check -fstack-protector - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - # CC = gcc - CC = icc -#--- Normal mode options - - CFLAGS_N = -I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 -Dfunder - -#--- Debug mode options - - CFLAGS_D = -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = -L$(CORELIB) -lnemsio -lsp_d -lsigio_4 -lsfcio_4 -lbufr_d_64 -lw3emc_d -lw3nco_d $(LIBcrtm) \ - $(WRFLIB) -lbacio_4 \ - -L/usr/local/unsupported/SLES11.1/netcdf4/4.1.3/intel-13.1.3.192/lib -lnetcdff \ - -L/usr/local/unsupported/SLES11.1/zlib/1.2.8/intel-13.1.3.192/lib \ - -L/usr/local/unsupported/SLES11.1/szip/2.1/intel-13.1.3.192/lib \ - -L/usr/local/unsupported/SLES11.1/hdf5/1.8.12/intel-13.1.3.192/lib \ - -lnetcdf -lm -lcurl -lhdf5_hl -lhdf5 -mkl -lsz -lz -lm -lcurl - - LDFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.nco b/src/Makefile.conf.nco deleted file mode 100644 index c8d7cffcb..000000000 --- a/src/Makefile.conf.nco +++ /dev/null @@ -1,122 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Define derived variables -# ------------------------------------ - -NETCDFPATH = $(NETCDF) -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -LIBwrfio_int = $(WRF_SHARED_PATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRF_SHARED_PATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRF_SHARED_PATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRF_SHARED_PATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -convert big_endian -assume byterecl \ - -implicitnone $(OMP) $(FFLAGS_COM) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -convert big_endian -assume byterecl \ - -implicitnone $(OMP) $(FFLAGS_COM) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn \ - $(FFLAGS_COM) - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn \ - $(FFLAGS_COM) - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) $(LDFLAGS_COM) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -Wl,-Map,loadmap.txt $(LDFLAGS_COM) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.s4 b/src/Makefile.conf.s4 deleted file mode 100644 index 32fe3927f..000000000 --- a/src/Makefile.conf.s4 +++ /dev/null @@ -1,120 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -CORE = /usr/local/jcsda/nwprod_v2012 -CORELIB = /usr/local/jcsda/nwprod_v2012/lib -COREINC = $(CORELIB)/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 -INCgfsio = $(COREINC)/gfsio_4 -INCnemsio = $(COREINC)/nemsio -INCw3lib = $(COREINC)/w3lib-2.0_d -CRTMpath = ../lib/CRTM_REL-2.1.3 -##INCcrtm = $(COREINC)/crtm_gfsgsi - -INCcrtm = $(CRTMpath)/include -LIBcrtm = $(CRTMpath)/lib/libCRTM.a - -WRFPATH=$(CORE)/sorc/nam_nmm_real_fcst.fd - -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -LIBhdf5 = /opt/hdf5/1.8.9-intel-12.1/lib -NETCDFPATH = /opt/netcdf4/4.2.1-intel-12.1 -LIBnetcdf = -L$(NETCDFPATH)/lib -lnetcdf -lnetcdff -INCnetcdf = $(NETCDFPATH)/include -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio - AR = ar -v -q -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 - FC = $(CF) - -#--- Normal mode options - - PROF= #-g -pg -qfullpath - #OMP = -openmp - - FFLAGS_F90 = -fp-model strict -xHOST -assume byterecl -free -traceback -D_REAL8_ -openmp - - FFLAGS_COM_N = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCgfsio) -I $(INCnetcdf) \ - -I $(INCnemsio) -I $(INCw3lib) -O2 -convert big_endian - FFLAGS_COM_N_NOSWAP = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCgfsio) -I $(INCnetcdf) \ - -I $(INCnemsio) -I $(INCw3lib) -O2 - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - -#--- Debug mode options -# -qflttrap=overflow:zero:enable \ is ok -# -qflttrap=overflow:zero:underflow:enable \ fails - FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCgfsio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3lib) -O0 -convert big_endian \ - -implicitnone -g -debug -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCgfsio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3lib) -O0 \ - -implicitnone -g -debug -ftrapuv -check all -fp-stack-check -fstack-protector -warn - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 -Dfunder - -#--- Debug mode options - - CFLAGS_D = -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(WRFLIB) -L$(CORELIB) -lnemsio -lsp_d -lw3lib-2.0_d -lbufr_d_64 -lgfsio_4 -lsigio_4 -lsfcio_4 $(LIBcrtm) \ - -lgfsio_4 -lbacio_4 $(LIBnetcdf) -L$(LIBhdf5) -lhdf5 -mkl -limf - - LDFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.theia b/src/Makefile.conf.theia deleted file mode 100644 index 029f270bd..000000000 --- a/src/Makefile.conf.theia +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -# - -BACIO_VER = 2.0.1 -BUFR_VER = 10.2.5 -CRTM_VER = 2.2.3 -NEMSIO_VER = 2.2.1 -SFCIO_VER = 1.0.0 -SIGIO_VER = 2.0.1 -SP_VER = 2.0.2 -W3EMC_VER = 2.0.5 -W3NCO_VER = 2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib -CORECRTM = /scratch4/NCEPDEV/da/save/Michael.Lueken/nwprod/lib - -INCsfcio = $(CORELIB)/sfcio/v$(SFCIO_VER)/incmod/sfcio_v$(SFCIO_VER)_4 -INCsigio = $(CORELIB)/sigio/v$(SIGIO_VER)/incmod/sigio_v$(SIGIO_VER)_4 -INCnemsio= $(CORELIB)/nemsio/v$(NEMSIO_VER)/incmod/nemsio_v$(NEMSIO_VER) -INCw3 = $(CORELIB)/w3emc/v$(W3EMC_VER)/incmod/w3emc_v$(W3EMC_VER)_d -INCcrtm = $(CORECRTM)/crtm/$(CRTM_VER)/incmod/crtm_v$(CRTM_VER) - -BACIO_LIB4=$(CORELIB)/bacio/v$(BACIO_VER)/libbacio_v$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/v$(BUFR_VER)/libbufr_v$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORECRTM)/crtm/$(CRTM_VER)/libcrtm_v$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/v$(NEMSIO_VER)/libnemsio_v$(NEMSIO_VER).a -SFCIO_LIB=$(CORELIB)/sfcio/v$(SFCIO_VER)/libsfcio_v$(SFCIO_VER)_4.a -SIGIO_LIB=$(CORELIB)/sigio/v$(SIGIO_VER)/libsigio_v$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/v$(SP_VER)/libsp_v$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/v$(W3EMC_VER)/libw3emc_v$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_d.a - -WRFPATH = /scratch3/NCEPDEV/nceplibs/ext/WRF/3.7/WRFV3 -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - -INCnetcdf = ${NETCDF}/include -LIBnetcdf = -L${NETCDF}/lib -lnetcdf - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -D_REAL8_ -openmp - - FFLAGS_COM_N = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) -O3 -traceback -convert big_endian -assume byterecl \ - -g -fp-model source - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) \ - -O3 -traceback -g -fp-model source \ - -convert big_endian -assume byterecl - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -mkl -Wl,-Map,loadmap.txt - -#--- Normal mode options -# LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ -# -lsfcio_4 -lbufr_d_64 -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBnetcdf) -# LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ -# -lsfcio -lbufr_d_64 -lw3nco_d -lw3emc_d -lcrtm_v2.1.3 $(WRFLIB) $(LIBnetcdf) - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB) \ - $(SFCIO_LIB) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(LIBnetcdf) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud -# LIBS_N = $(LIBnemsio) -L$(CORELIB) -lsp_d -lsigio_4 \ -# -lsfcio_4 -lbufr_dc -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBbacio) $(LIBnetcdf) - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.wcoss b/src/Makefile.conf.wcoss deleted file mode 100644 index 574bd02e4..000000000 --- a/src/Makefile.conf.wcoss +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for WCOSS -# ---------------------------------- - -# Set library versions -BACIO_VER = v2.0.1 -BUFR_VER = v10.2.5 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.1 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.0.5 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -#CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/incmod/crtm_$(CRTM_VER) -CRTM_INC=/da/save/Michael.Lueken/CRTM_REL-2.2.3/crtm_${CRTM_VER}/include -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/incmod/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/incmod/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/incmod/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/libbufr_$(BUFR_VER)_d_64.a -#CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/libcrtm_$(CRTM_VER).a -CRTM_LIB=/da/save/Michael.Lueken/CRTM_REL-2.2.3/crtm_${CRTM_VER}/lib/libcrtm.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDF_INCLUDE = ${NETCDF}/include -NETCDF_LDFLAGS_F = -L${NETCDF}/lib -lnetcdf - - - -# WRF locations -WRFPATH = /nwprod/sorc/wrf_shared.fd -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ #-DNMMB_CLOUDANALYSIS - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -mcmodel medium -shared-intel -g -traceback -debug \ - -ftrapuv -check all,noarg_temp_created -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -mcmodel medium -shared-intel -g -traceback -debug \ - -ftrapuv -check all,noarg_temp_created -fp-stack-check -fstack-protector -warn - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.zeus b/src/Makefile.conf.zeus deleted file mode 100644 index a2bac4a2b..000000000 --- a/src/Makefile.conf.zeus +++ /dev/null @@ -1,129 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /contrib/nceplibs/nwprod/lib/incmod -CORELIB = /contrib/nceplibs/nwprod/lib -INCsfcio = $(COREINC)/sfcio_v1.1.0 -INCsigio = $(COREINC)/sigio_4 -INCnemsio= $(COREINC)/nemsio -INCw3 = $(COREINC)/w3emc_d -#INCcrtm=$(COREINC)/crtm_v2.1.3 -INCcrtm=/scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/CRTM_REL-2.2.3/crtm_v2.2.3/include - -WRFPATH = /contrib/nceplibs_ext/WRF/WRFV3 -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - -LIBcrtm = /scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/CRTM_REL-2.2.3/crtm_v2.2.3/lib/libcrtm.a - -INCnetcdf = ${NETCDF}/include -LIBnetcdf = -L$(NETCDF)/lib -lnetcdf - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -D_REAL8_ -openmp - - FFLAGS_COM_N = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) -O3 -traceback -convert big_endian -assume byterecl \ - -g -fp-model source - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) \ - -O3 -traceback -g -fp-model source \ - -convert big_endian -assume byterecl - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -mkl -lmpi -Wl,-Map,loadmap.txt - -#--- Normal mode options -# LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ -# -lsfcio_4 -lbufr_d_64 -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBnetcdf) - LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ - -lsfcio -lbufr_d_64 -lw3nco_d -lw3emc_d $(LIBcrtm) $(WRFLIB) $(LIBnetcdf) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud -# LIBS_N = $(LIBnemsio) -L$(CORELIB) -lsp_d -lsigio_4 \ -# -lsfcio_4 -lbufr_dc -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBbacio) $(LIBnetcdf) - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.zeus.gsdcloud4arw b/src/Makefile.conf.zeus.gsdcloud4arw deleted file mode 100644 index fddc09d04..000000000 --- a/src/Makefile.conf.zeus.gsdcloud4arw +++ /dev/null @@ -1,132 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /contrib/nceplibs/nwprod/lib/incmod -CORELIB = /contrib/nceplibs/nwprod/lib -INCsfcio = $(COREINC)/sfcio_v1.1.0 -INCsigio = $(COREINC)/sigio_4 -INCnemsio= $(COREINC)/nemsio -INCw3 = $(COREINC)/w3emc_d -INCcrtm=$(COREINC)/crtm_v2.1.3 - -WRFPATH = /contrib/nceplibs_ext/WRF/WRFV3 -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - -INCnetcdf = ${NETCDF}/include -LIBnetcdf = -L$(NETCDF)/lib -lnetcdf -#WRFPATH = -#LIBwrfio_int = -#LIBwrfio_netcdf = -#OBJwrf_frame_pk = -#OBJwrf_sizeof_int = -#WRFLIB = - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -D_REAL8_ -openmp -DRR_CLOUDANALYSIS -g -traceback - - FFLAGS_COM_N = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) -O3 -traceback -convert big_endian -assume byterecl \ - -g -fp-model strict - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) \ - -O3 -traceback -g -fp-model strict \ - -convert big_endian -assume byterecl - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -mkl -lmpi -Wl,-Map,loadmap.txt - -#--- Normal mode options -# LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ -# -lsfcio_4 -lbufr_d_64 -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBnetcdf) - LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ - -lsfcio -lbufr_d_64 -lw3nco_d -lw3emc_d -lcrtm_v2.1.3 $(WRFLIB) $(LIBnetcdf) \ - -L../lib/GSD/gsdcloud -lgsdcloud -# LIBS_N = $(LIBnemsio) -L$(CORELIB) -lsp_d -lsigio_4 \ -# -lsfcio_4 -lbufr_dc -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBbacio) $(LIBnetcdf) - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.conf.zeus.gsdcloud4nmmb b/src/Makefile.conf.zeus.gsdcloud4nmmb deleted file mode 100644 index 823f69ce3..000000000 --- a/src/Makefile.conf.zeus.gsdcloud4nmmb +++ /dev/null @@ -1,132 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /contrib/nceplibs/nwprod/lib/incmod -CORELIB = /contrib/nceplibs/nwprod/lib -INCsfcio = $(COREINC)/sfcio_v1.1.0 -INCsigio = $(COREINC)/sigio_4 -INCnemsio= $(COREINC)/nemsio -INCw3 = $(COREINC)/w3emc_d -INCcrtm=$(COREINC)/crtm_v2.1.3 - -WRFPATH = /contrib/nceplibs_ext/WRF/WRFV3 -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - -INCnetcdf = ${NETCDF}/include -LIBnetcdf = -L$(NETCDF)/lib -lnetcdf -#WRFPATH = -#LIBwrfio_int = -#LIBwrfio_netcdf = -#OBJwrf_frame_pk = -#OBJwrf_sizeof_int = -#WRFLIB = - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -DNMMB_CLOUDANALYSIS -D_REAL8_ -openmp - - FFLAGS_COM_N = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) -O3 -traceback -convert big_endian -assume byterecl \ - -g -fp-model strict - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) \ - -O3 -traceback -g -fp-model strict \ - -convert big_endian -assume byterecl - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -I $(INCw3) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -I $(INCw3) \ - -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -mkl -lmpi -Wl,-Map,loadmap.txt - -#--- Normal mode options -# LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ -# -lsfcio_4 -lbufr_d_64 -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBnetcdf) - LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ - -lsfcio -lbufr_d_64 -lw3nco_d -lw3emc_d -lcrtm_v2.1.3 $(WRFLIB) $(LIBnetcdf) \ - -L../lib/GSD/gsdcloud4nmmb -lgsdcloud -# LIBS_N = $(LIBnemsio) -L$(CORELIB) -lsp_d -lsigio_4 \ -# -lsfcio_4 -lbufr_dc -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBbacio) $(LIBnetcdf) - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/Makefile.dependency b/src/Makefile.dependency deleted file mode 100644 index 6c8f12b01..000000000 --- a/src/Makefile.dependency +++ /dev/null @@ -1,517 +0,0 @@ -adjtest.o : adjtest.f90 bias_predictors.o gsi_bundlemod.o state_vectors.o control_vectors.o mpimod.o jfunc.o constants.o gsi_4dvar.o kinds.o -adjtest_obs.o : adjtest_obs.f90 m_obsLList.o m_obsdiags.o intall.o bias_predictors.o gsi_bundlemod.o state_vectors.o control_vectors.o mpimod.o constants.o jfunc.o gsi_4dvar.o kinds.o -adjust_cloudobs_mod.o : adjust_cloudobs_mod.f90 obsmod.o constants.o kinds.o -aeroinfo.o : aeroinfo.f90 obsmod.o gridmod.o gsi_chemguess_mod.o mpimod.o kinds.o -aircraftinfo.o : aircraftinfo.f90 gsi_io.o obsmod.o mpimod.o constants.o kinds.o -aircraftobsqc.o : aircraftobsqc.f90 kinds.o -anberror.o : anberror.f90 gsi_io.o mpeu_util.o mpimod.o general_commvars_mod.o jfunc.o general_sub2grid_mod.o control_vectors.o fgrid2agrid_mod.o gridmod.o berror.o raflib.o constants.o kinds.o -anbkerror.o : anbkerror.f90 raflib.o fgrid2agrid_mod.o general_commvars_mod.o patch2grid_mod.o mpimod.o guess_grids.o general_sub2grid_mod.o anberror.o gsi_bundlemod.o timermod.o gsi_4dvar.o control_vectors.o constants.o berror.o balmod.o jfunc.o gridmod.o kinds.o -aniso_ens_util.o : aniso_ens_util.f90 guess_grids.o anberror.o mpimod.o wind_fft.o gridmod.o constants.o kinds.o -anisofilter.o : anisofilter.f90 general_sub2grid_mod.o sub2fslab_mod.o m_berror_stats_reg.o gsi_io.o mpeu_util.o aniso_ens_util.o gsi_bundlemod.o gsi_metguess_mod.o mpimod.o guess_grids.o control_vectors.o jfunc.o raflib.o balmod.o constants.o general_commvars_mod.o gridmod.o fgrid2agrid_mod.o anberror.o kinds.o -anisofilter_glb.o : anisofilter_glb.f90 compact_diffs.o balmod.o sub2fslab_mod.o m_berror_stats.o patch2grid_mod.o smooth_polcarf.o mpeu_util.o berror.o aniso_ens_util.o anisofilter.o gsi_bundlemod.o gsi_metguess_mod.o mpimod.o guess_grids.o control_vectors.o jfunc.o raflib.o constants.o general_commvars_mod.o gridmod.o anberror.o kinds.o -antcorr_application.o : antcorr_application.f90 -antest_maps0.o : antest_maps0.f90 mpeu_util.o gsi_metguess_mod.o gsi_bundlemod.o control_vectors.o fgrid2agrid_mod.o guess_grids.o mpimod.o constants.o gridmod.o anberror.o kinds.o -antest_maps0_glb.o : antest_maps0_glb.f90 mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o control_vectors.o patch2grid_mod.o guess_grids.o mpimod.o constants.o gridmod.o anberror.o kinds.o -atms_spatial_average_mod.o : atms_spatial_average_mod.f90 kinds.o -balmod.o : balmod.f90 mod_vtrans.o mod_strong.o gsi_4dvar.o m_berror_stats_reg.o guess_grids.o m_berror_stats.o constants.o mpimod.o gridmod.o kinds.o -berror.o : berror.f90 aircraftinfo.o radinfo.o jfunc.o gridmod.o balmod.o constants.o control_vectors.o kinds.o -bias_predictors.o : bias_predictors.f90 pcpinfo.o radinfo.o aircraftinfo.o constants.o kinds.o -bicg.o : bicg.f90 bicglanczos.o timermod.o hybrid_ensemble_isotropic.o hybrid_ensemble_parameters.o obs_ferrscale.o control_vectors.o grtest.o adjtest.o obsmod.o obs_sensitivity.o mpimod.o constants.o jfunc.o gsi_4dvar.o kinds.o -bicglanczos.o : bicglanczos.F90 hybrid_ensemble_isotropic.o hybrid_ensemble_parameters.o jfunc.o mpimod.o gsi_bundlemod.o control_vectors.o gsi_4dvar.o lanczos.o timermod.o constants.o kinds.o -bkerror.o : bkerror.f90 hybrid_ensemble_parameters.o hybrid_ensemble_isotropic.o general_commvars_mod.o general_sub2grid_mod.o gsi_bundlemod.o timermod.o control_vectors.o constants.o jfunc.o gridmod.o gsi_4dvar.o balmod.o berror.o kinds.o -bkgcov.o : bkgcov.f90 hybrid_ensemble_isotropic.o hybrid_ensemble_parameters.o general_commvars_mod.o general_sub2grid_mod.o gsi_bundlemod.o gridmod.o constants.o kinds.o -bkgvar.o : bkgvar.f90 mpimod.o gsi_bundlemod.o guess_grids.o gridmod.o berror.o constants.o kinds.o -bkgvar_rewgt.o : bkgvar_rewgt.f90 general_sub2grid_mod.o general_commvars_mod.o mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o berror.o balmod.o mpimod.o guess_grids.o gridmod.o constants.o kinds.o -blacklist.o : blacklist.f90 kinds.o -blendmod.o : blendmod.f90 constants.o kinds.o -buddycheck_mod.o : buddycheck_mod.f90 qcmod.o mpimod.o jfunc.o convinfo.o aircraftinfo.o gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o obsmod.o constants.o guess_grids.o gridmod.o kinds.o -calc_fov_conical.o : calc_fov_conical.f90 constants.o calc_fov_crosstrk.o kinds.o -calc_fov_crosstrk.o : calc_fov_crosstrk.f90 constants.o kinds.o -calctends_ad.o : calctends_ad.f90 mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o guess_grids.o tendsmod.o derivsmod.o constants.o gridmod.o kinds.o -calctends.o : calctends.f90 gsi_bundlemod.o mpeu_util.o control_vectors.o tendsmod.o constants.o gridmod.o kinds.o -calctends_no_ad.o : calctends_no_ad.f90 derivsmod.o gsi_bundlemod.o gsi_metguess_mod.o guess_grids.o tendsmod.o constants.o gridmod.o kinds.o -calctends_no_tl.o : calctends_no_tl.f90 derivsmod.o gsi_bundlemod.o gsi_metguess_mod.o guess_grids.o tendsmod.o constants.o gridmod.o kinds.o -calctends_tl.o : calctends_tl.f90 mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o guess_grids.o tendsmod.o derivsmod.o constants.o gridmod.o kinds.o -chemmod.o : chemmod.f90 mpimod.o convinfo.o constants.o gridmod.o kinds.o -class_get_pseudo_ensperts.o : class_get_pseudo_ensperts.f90 kinds.o gsi_bundlemod.o -class_get_wrf_mass_ensperts.o : class_get_wrf_mass_ensperts.f90 kinds.o gsi_bundlemod.o -class_get_wrf_nmm_ensperts.o : class_get_wrf_nmm_ensperts.f90 kinds.o gsi_bundlemod.o -class_gfs_ensmod.o : class_gfs_ensmod.f90 hybrid_ensemble_parameters.o gsi_bundlemod.o general_sub2grid_mod.o kinds.o -class_read_wrf_mass_files.o : class_read_wrf_mass_files.f90 kinds.o -class_read_wrf_mass_guess.o : class_read_wrf_mass_guess.f90 kinds.o -class_read_wrf_nmm_files.o : class_read_wrf_nmm_files.f90 kinds.o -class_read_wrf_nmm_guess.o : class_read_wrf_nmm_guess.f90 kinds.o -class_regional_io.o : class_regional_io.f90 kinds.o -class_wrf_binary_interface.o : class_wrf_binary_interface.f90 kinds.o -class_wrf_netcdf_interface.o : class_wrf_netcdf_interface.f90 kinds.o -class_wrwrfmassa.o : class_wrwrfmassa.f90 kinds.o -class_wrwrfnmma.o : class_wrwrfnmma.f90 kinds.o -cloud_efr_mod.o : cloud_efr_mod.f90 guess_grids.o gridmod.o constants.o kinds.o -clw_mod.o : clw_mod.f90 constants.o radinfo.o kinds.o -cmaq_routines.o : cmaq_routines.f90 mpeu_util.o chemmod.o gsi_chemguess_mod.o gsi_metguess_mod.o gsi_bundlemod.o gsi_io.o obsmod.o constants.o gridmod.o gsi_4dvar.o guess_grids.o mpimod.o kinds.o -coinfo.o : coinfo.f90 obsmod.o gsi_chemguess_mod.o mpimod.o kinds.o -combine_radobs.o : combine_radobs.f90 mpimod.o constants.o kinds.o -co_mop_ak.o : co_mop_ak.f90 constants.o kinds.o -compact_diffs.o : compact_diffs.f90 constants.o gridmod.o mpeu_util.o kinds.o -compute_derived.o : compute_derived.f90 gsi_io.o mpeu_util.o gsi_4dcouplermod.o anisofilter_glb.o anisofilter.o anberror.o sub2fslab_mod.o constants.o gsi_bundlemod.o gsi_metguess_mod.o gsi_4dvar.o obsmod.o mod_strong.o berror.o gridmod.o tendsmod.o derivsmod.o cloud_efr_mod.o guess_grids.o mpimod.o control_vectors.o jfunc.o kinds.o -compute_fact10.o : compute_fact10.f90 constants.o kinds.o -compute_qvar3d.o : compute_qvar3d.f90 radiance_mod.o general_sub2grid_mod.o gsi_bundlemod.o gsi_metguess_mod.o mpeu_util.o guess_grids.o constants.o gridmod.o control_vectors.o derivsmod.o jfunc.o berror.o kinds.o -constants.o : constants.f90 kinds.o -control2model_ad.o : control2model_ad.f90 mpeu_util.o gsi_metguess_mod.o gsi_chemguess_mod.o gsi_bundlemod.o cwhydromod.o jfunc.o balmod.o berror.o gridmod.o gsi_4dvar.o bias_predictors.o control_vectors.o constants.o kinds.o -control2model.o : control2model.f90 constants.o mpeu_util.o gsi_metguess_mod.o gsi_chemguess_mod.o gsi_bundlemod.o cwhydromod.o balmod.o berror.o jfunc.o gridmod.o gsi_4dvar.o bias_predictors.o control_vectors.o kinds.o -control2state_ad.o : control2state_ad.f90 constants.o mpeu_util.o gsi_metguess_mod.o gsi_chemguess_mod.o gsi_bundlemod.o cwhydromod.o jfunc.o gridmod.o gsi_4dvar.o bias_predictors.o control_vectors.o kinds.o -control2state.o : control2state.f90 general_commvars_mod.o general_sub2grid_mod.o constants.o mpeu_util.o gsi_metguess_mod.o gsi_chemguess_mod.o gsi_bundlemod.o cwhydromod.o jfunc.o gridmod.o gsi_4dvar.o bias_predictors.o control_vectors.o kinds.o -control_vectors.o : control_vectors.f90 m_stats.o mpeu_util.o gsi_bundlemod.o m_rerank.o hybrid_ensemble_parameters.o mpl_allreduce.o gsi_4dvar.o constants.o mpimod.o kinds.o -convb_ps.o : convb_ps.f90 obsmod.o constants.o kinds.o -convb_q.o : convb_q.f90 obsmod.o constants.o kinds.o -convb_t.o : convb_t.f90 obsmod.o constants.o kinds.o -convb_uv.o : convb_uv.f90 obsmod.o constants.o kinds.o -converr.o : converr.f90 obsmod.o constants.o kinds.o -converr_ps.o : converr_ps.f90 obsmod.o constants.o kinds.o -converr_pw.o : converr_pw.f90 obsmod.o constants.o kinds.o -converr_q.o : converr_q.f90 obsmod.o constants.o kinds.o -converr_t.o : converr_t.f90 obsmod.o constants.o kinds.o -converr_uv.o : converr_uv.f90 obsmod.o constants.o kinds.o -convinfo.o : convinfo.f90 gsi_chemguess_mod.o gsi_io.o mpimod.o obsmod.o constants.o kinds.o -convthin.o : convthin.f90 satthin.o constants.o kinds.o -convthin_time.o : convthin_time.f90 satthin.o constants.o kinds.o -correlated_obsmod.o : correlated_obsmod.F90 gsi_io.o mpeu_util.o timermod.o mpimod.o constants.o kinds.o -cplr_get_pseudo_ensperts.o : cplr_get_pseudo_ensperts.f90 blendmod.o cplr_get_wrf_mass_ensperts.o cplr_get_wrf_nmm_ensperts.o gsi_bundlemod.o control_vectors.o gsi_io.o general_sub2grid_mod.o hybrid_ensemble_parameters.o gsi_4dvar.o kinds.o mpimod.o constants.o gridmod.o class_get_pseudo_ensperts.o -cplr_get_wrf_mass_ensperts.o : cplr_get_wrf_mass_ensperts.f90 general_sub2grid_mod.o netcdf_mod.o gridmod.o gsi_bundlemod.o control_vectors.o hybrid_ensemble_parameters.o mpimod.o constants.o kinds.o class_get_wrf_mass_ensperts.o guess_grids.o -cplr_get_wrf_nmm_ensperts.o : cplr_get_wrf_nmm_ensperts.f90 blendmod.o cplr_read_wrf_mass_guess.o cplr_wrf_binary_interface.o cplr_get_wrf_mass_ensperts.o aniso_ens_util.o gfs_stratosphere.o gsi_4dvar.o gsi_bundlemod.o egrid2agrid_mod.o general_tll2xy_mod.o general_sub2grid_mod.o gsi_io.o mpeu_util.o control_vectors.o hybrid_ensemble_parameters.o mpimod.o constants.o gridmod.o kinds.o class_get_wrf_nmm_ensperts.o -cplr_gfs_ensmod.o : cplr_gfs_ensmod.f90 gsi_bundlemod.o hybrid_ensemble_parameters.o genex_mod.o ncepnems_io.o gsi_4dvar.o general_sub2grid_mod.o gridmod.o kinds.o mpeu_util.o mpimod.o class_gfs_ensmod.o -cplr_gfs_nstmod.o : cplr_gfs_nstmod.f90 satthin.o constants.o ncepnems_io.o ncepgfs_io.o kinds.o mpeu_util.o gsi_nstcouplermod.o guess_grids.o gridmod.o mpimod.o -cplr_read_wrf_mass_files.o : cplr_read_wrf_mass_files.f90 obsmod.o constants.o gsi_4dvar.o guess_grids.o mpimod.o kinds.o class_read_wrf_mass_files.o -cplr_read_wrf_mass_guess.o : cplr_read_wrf_mass_guess.f90 gsi_chemguess_mod.o chemmod.o mpeu_util.o native_endianness.o gsi_metguess_mod.o gsi_bundlemod.o wrf_mass_guess_mod.o rapidrefresh_cldsurf_mod.o gsi_io.o constants.o gridmod.o guess_grids.o mpimod.o kinds.o class_read_wrf_mass_guess.o -cplr_read_wrf_nmm_files.o : cplr_read_wrf_nmm_files.f90 obsmod.o constants.o gsi_4dvar.o guess_grids.o mpimod.o kinds.o class_read_wrf_nmm_files.o -cplr_read_wrf_nmm_guess.o : cplr_read_wrf_nmm_guess.f90 gsi_nemsio_mod.o rapidrefresh_cldsurf_mod.o cplr_read_wrf_mass_guess.o gfs_stratosphere.o native_endianness.o control_vectors.o mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o gsi_io.o wrf_params_mod.o constants.o general_commvars_mod.o gridmod.o cloud_efr_mod.o guess_grids.o mpimod.o kinds.o class_read_wrf_nmm_guess.o -cplr_regional_io.o : cplr_regional_io.f90 rapidrefresh_cldsurf_mod.o cplr_wrwrfnmma.o cplr_wrwrfmassa.o gsi_io.o cplr_get_wrf_nmm_ensperts.o cplr_wrf_binary_interface.o cplr_wrf_netcdf_interface.o native_endianness.o hybrid_ensemble_parameters.o gridmod.o mpimod.o kinds.o wrf_params_mod.o class_regional_io.o -cplr_wrf_binary_interface.o : cplr_wrf_binary_interface.f90 native_endianness.o gfs_stratosphere.o constants.o gridmod.o gsi_metguess_mod.o rapidrefresh_cldsurf_mod.o gsi_io.o gsi_4dvar.o kinds.o class_wrf_binary_interface.o -cplr_wrf_netcdf_interface.o : cplr_wrf_netcdf_interface.f90 control_vectors.o mpeu_util.o wrf_params_mod.o guess_grids.o gsi_bundlemod.o hybrid_ensemble_parameters.o gfs_stratosphere.o gsi_io.o netcdf_mod.o gridmod.o gsi_chemguess_mod.o chemmod.o gsi_metguess_mod.o rapidrefresh_cldsurf_mod.o gsi_4dvar.o constants.o kinds.o class_wrf_netcdf_interface.o -cplr_wrwrfmassa.o : cplr_wrwrfmassa.f90 gsi_chemguess_mod.o chemmod.o cplr_read_wrf_mass_guess.o mpeu_util.o native_endianness.o gsi_metguess_mod.o gsi_bundlemod.o rapidrefresh_cldsurf_mod.o gsi_io.o constants.o gridmod.o wrf_mass_guess_mod.o guess_grids.o mpimod.o kinds.o class_wrwrfmassa.o -cplr_wrwrfnmma.o : cplr_wrwrfnmma.f90 gsi_4dvar.o gsi_nemsio_mod.o rapidrefresh_cldsurf_mod.o cplr_read_wrf_mass_guess.o cplr_wrwrfmassa.o gfs_stratosphere.o native_endianness.o control_vectors.o mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o gsi_io.o constants.o gridmod.o mpimod.o guess_grids.o wrf_params_mod.o kinds.o class_wrwrfnmma.o -crtm_interface.o : crtm_interface.f90 set_crtm_cloudmod.o set_crtm_aerosolmod.o wrf_params_mod.o ncepgfs_ghg.o cloud_efr_mod.o gsi_nstcouplermod.o mpimod.o gsi_io.o obsmod.o constants.o guess_grids.o aeroinfo.o radinfo.o gsi_metguess_mod.o gsi_chemguess_mod.o gsi_bundlemod.o radiance_mod.o mpeu_util.o gridmod.o kinds.o -cvsection.o : cvsection.f90 control_vectors.o jfunc.o gridmod.o mpimod.o kinds.o -cwhydromod.o : cwhydromod.f90 gsi_bundlemod.o derivsmod.o guess_grids.o gridmod.o constants.o kinds.o -derivsmod.o : derivsmod.f90 mpeu_util.o gsi_chemguess_mod.o gsi_metguess_mod.o gsi_bundlemod.o state_vectors.o constants.o gridmod.o mpimod.o kinds.o -deter_sfc_mod.o : deter_sfc_mod.f90 calc_fov_conical.o calc_fov_crosstrk.o guess_grids.o gridmod.o constants.o satthin.o kinds.o -dtast.o : dtast.f90 qcmod.o convinfo.o constants.o kinds.o -egrid2agrid_mod.o : egrid2agrid_mod.f90 blendmod.o constants.o kinds.o -enorm_state.o : enorm_state.f90 gsi_metguess_mod.o gsi_bundlemod.o state_vectors.o guess_grids.o mpimod.o gridmod.o jcmod.o constants.o kinds.o -en_perts_io.o : en_perts_io.f90 constants.o general_sub2grid_mod.o mpeu_util.o kinds.o mpimod.o gsi_bundlemod.o control_vectors.o hybrid_ensemble_parameters.o gridmod.o -ensctl2model_ad.o : ensctl2model_ad.f90 timermod.o mod_strong.o gsi_metguess_mod.o mpeu_util.o constants.o gsi_bundlemod.o balmod.o hybrid_ensemble_isotropic.o hybrid_ensemble_parameters.o gsi_4dvar.o control_vectors.o kinds.o -ensctl2model.o : ensctl2model.f90 timermod.o mod_strong.o gsi_metguess_mod.o mpeu_util.o gsi_bundlemod.o balmod.o hybrid_ensemble_isotropic.o hybrid_ensemble_parameters.o gsi_4dvar.o control_vectors.o kinds.o constants.o -ensctl2state_ad.o : ensctl2state_ad.f90 timermod.o cwhydromod.o mod_strong.o gsi_metguess_mod.o mpeu_util.o constants.o gsi_bundlemod.o balmod.o hybrid_ensemble_isotropic.o hybrid_ensemble_parameters.o gsi_4dvar.o control_vectors.o kinds.o -ensctl2state.o : ensctl2state.f90 timermod.o cwhydromod.o mod_strong.o gsi_metguess_mod.o mpeu_util.o gsi_bundlemod.o balmod.o hybrid_ensemble_isotropic.o hybrid_ensemble_parameters.o gsi_4dvar.o control_vectors.o kinds.o constants.o -ens_spread_mod.o : ens_spread_mod.f90 gsi_bundlemod.o control_vectors.o constants.o general_sub2grid_mod.o hybrid_ensemble_parameters.o kinds.o -evaljgrad.o : evaljgrad.f90 m_obsHeadBundle.o mpl_allreduce.o mpeu_util.o xhat_vordivmod.o gsi_bundlemod.o gsi_4dcouplermod.o intjcmod.o intrad.o intjo.o bias_predictors.o state_vectors.o control_vectors.o mod_strong.o obs_sensitivity.o obsmod.o hybrid_ensemble_parameters.o gridmod.o jcmod.o jfunc.o mpimod.o constants.o gsi_4dvar.o kinds.o -evaljo.o : evaljo.f90 mpl_allreduce.o jfunc.o mpimod.o constants.o gsi_4dvar.o obsmod.o kinds.o -evalqlim.o : evalqlim.f90 gsi_bundlemod.o mpl_allreduce.o derivsmod.o jfunc.o gridmod.o constants.o kinds.o -fgrid2agrid_mod.o : fgrid2agrid_mod.f90 constants.o kinds.o -fill_mass_grid2.o : fill_mass_grid2.f90 mod_wrfmass_to_a.o general_commvars_mod.o gridmod.o constants.o kinds.o -fill_nmm_grid2.o : fill_nmm_grid2.f90 general_commvars_mod.o gridmod.o constants.o kinds.o -fpvsx_ad.o : fpvsx_ad.f90 constants.o kinds.o -general_commvars_mod.o : general_commvars_mod.f90 constants.o mpeu_util.o control_vectors.o mpimod.o gridmod.o general_sub2grid_mod.o kinds.o -general_read_gfsatm.o : general_read_gfsatm.f90 general_commvars_mod.o egrid2agrid_mod.o ncepnems_io.o gsi_bundlemod.o ncepgfs_io.o constants.o general_specmod.o general_sub2grid_mod.o gridmod.o mpimod.o kinds.o -general_read_nmmb.o : general_read_nmmb.f90 general_sub2grid_mod.o gsi_nemsio_mod.o constants.o gridmod.o kinds.o -general_specmod.o : general_specmod.f90 constants.o kinds.o -general_spectral_transforms.o : general_spectral_transforms.f90 mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o guess_grids.o constants.o kinds.o general_sub2grid_mod.o general_specmod.o -general_sub2grid_mod.o : general_sub2grid_mod.f90 egrid2agrid_mod.o m_rerank.o mpeu_util.o constants.o mpimod.o kinds.o -general_tll2xy_mod.o : general_tll2xy_mod.f90 mpimod.o gridmod.o egrid2agrid_mod.o constants.o kinds.o -general_transform.o : general_transform.f90 general_specmod.o constants.o kinds.o -general_write_gfsatm.o : general_write_gfsatm.f90 gsi_bundlemod.o gsi_4dvar.o constants.o ncepgfs_io.o general_commvars_mod.o gridmod.o general_specmod.o mpimod.o obsmod.o guess_grids.o general_sub2grid_mod.o kinds.o -genex_mod.o : genex_mod.f90 mpimod.o kinds.o -gengrid_vars.o : gengrid_vars.f90 constants.o gridmod.o kinds.o -genqsat.o : genqsat.f90 guess_grids.o gridmod.o jfunc.o derivsmod.o constants.o kinds.o -genstats_gps.o : genstats_gps.f90 convinfo.o jfunc.o mpimod.o qcmod.o constants.o gridmod.o obsmod.o gsi_4dvar.o kinds.o m_gpsNode.o -gesinfo.o : gesinfo.f90 gsi_io.o cplr_read_wrf_nmm_files.o cplr_read_wrf_mass_files.o constants.o gridmod.o mpimod.o gsi_4dvar.o obsmod.o kinds.o -getcount_bufr.o : getcount_bufr.f90 kinds.o -get_derivatives2.o : get_derivatives2.f90 general_commvars_mod.o general_sub2grid_mod.o compact_diffs.o gridmod.o constants.o kinds.o -get_derivatives.o : get_derivatives.f90 mpeu_util.o general_commvars_mod.o general_sub2grid_mod.o gsi_bundlemod.o compact_diffs.o gridmod.o constants.o kinds.o -get_gefs_ensperts_dualres.o : get_gefs_ensperts_dualres.f90 general_sub2grid_mod.o cplr_gfs_ensmod.o gsi_bundlemod.o control_vectors.o kinds.o mpeu_util.o mpimod.o constants.o hybrid_ensemble_parameters.o gridmod.o -get_gefs_for_regional.o : get_gefs_for_regional.f90 general_commvars_mod.o gsi_io.o cplr_get_wrf_mass_ensperts.o ncepnems_io.o gsi_4dvar.o mpeu_util.o gsi_metguess_mod.o obsmod.o aniso_ens_util.o guess_grids.o egrid2agrid_mod.o general_specmod.o general_sub2grid_mod.o kinds.o mpimod.o constants.o gsi_bundlemod.o control_vectors.o hybrid_ensemble_parameters.o gridmod.o -get_nmmb_ensperts.o : get_nmmb_ensperts.f90 gsi_bundlemod.o control_vectors.o mpimod.o constants.o hybrid_ensemble_parameters.o gridmod.o kinds.o -getprs.o : getprs.f90 general_commvars_mod.o general_sub2grid_mod.o compact_diffs.o gsi_bundlemod.o gsi_metguess_mod.o guess_grids.o gridmod.o constants.o kinds.o -get_semimp_mats.o : get_semimp_mats.f90 gridmod.o constants.o kinds.o -getsiga.o : getsiga.f90 bias_predictors.o control_vectors.o gsi_bundlemod.o gsi_4dcouplermod.o state_vectors.o lanczos.o jfunc.o gsi_4dvar.o constants.o mpimod.o kinds.o -getuv.o : getuv.f90 general_commvars_mod.o general_sub2grid_mod.o compact_diffs.o gridmod.o constants.o kinds.o -getvvel.o : getvvel.f90 mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o guess_grids.o tendsmod.o gridmod.o constants.o kinds.o -gfs_stratosphere.o : gfs_stratosphere.f90 control_vectors.o obsmod.o aniso_ens_util.o guess_grids.o egrid2agrid_mod.o general_specmod.o general_sub2grid_mod.o gsi_metguess_mod.o gsi_bundlemod.o mpimod.o ncepnems_io.o gridmod.o blendmod.o constants.o gsi_io.o mpeu_util.o kinds.o -glbsoi.o : glbsoi.f90 gsi_io.o m_obsdiags.o prad_bias.o aircraftinfo.o gfs_stratosphere.o hybrid_ensemble_isotropic.o hybrid_ensemble_parameters.o timermod.o observer.o zrnmi_mod.o convb_uv.o convb_t.o convb_q.o convb_ps.o converr_pw.o converr_uv.o converr_t.o converr_q.o converr_ps.o converr.o pcpinfo.o radinfo.o control_vectors.o pcgsoi.o gsi_4dvar.o jcmod.o smooth_polcarf.o obs_sensitivity.o turblmod.o qcmod.o obsmod.o guess_grids.o gridmod.o compact_diffs.o balmod.o berror.o anisofilter_glb.o anisofilter.o anberror.o jfunc.o adjtest_obs.o mpimod.o kinds.o -grdcrd.o : grdcrd.f90 constants.o kinds.o -gridmod.o : gridmod.F90 mpimod.o mod_wrfmass_to_a.o mod_nmmb_to_a.o gsi_io.o constants.o mpeu_util.o general_sub2grid_mod.o general_specmod.o kinds.o -grtest.o : grtest.f90 control_vectors.o mpimod.o constants.o kinds.o -gscond_ad.o : gscond_ad.f90 constants.o kinds.o -gsdcloudanalysis4gfs.o : gsdcloudanalysis4gfs.F90 kinds.o -gsdcloudanalysis4NMMB.o : gsdcloudanalysis4NMMB.F90 kinds.o -gsdcloudanalysis.o : gsdcloudanalysis.F90 kinds.o -gsd_terrain_match_surfTobs.o : gsd_terrain_match_surfTobs.f90 mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o convinfo.o guess_grids.o constants.o kinds.o -gsd_update_mod.o : gsd_update_mod.f90 general_commvars_mod.o general_sub2grid_mod.o mpimod.o rapidrefresh_cldsurf_mod.o wrf_mass_guess_mod.o guess_grids.o gridmod.o constants.o derivsmod.o jfunc.o kinds.o mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o -gsi_4dcouplermod.o : gsi_4dcouplermod.f90 constants.o kinds.o gsi_bundlemod.o -gsi_4dvar.o : gsi_4dvar.f90 jcmod.o hybrid_ensemble_parameters.o constants.o kinds.o -gsi_bias.o : gsi_bias.f90 general_commvars_mod.o obsmod.o gsi_4dcouplermod.o mpeu_util.o m_gsiBiases.o gsi_bundlemod.o mpimod.o constants.o gridmod.o kinds.o -gsi_bundlemod.o : gsi_bundlemod.F90 gsi_io.o mpeu_util.o m_rerank.o constants.o kinds.o -gsi_chemguess_mod.o : gsi_chemguess_mod.F90 gsi_bundlemod.o mpeu_util.o mpimod.o constants.o kinds.o -gsi_enscouplermod.o : gsi_enscouplermod.f90 general_sub2grid_mod.o gridmod.o kinds.o gsi_bundlemod.o -gsi_io.o : gsi_io.f90 kinds.o -gsimain.o : gsimain.f90 mpeu_util.o kinds.o timermod.o gsi_4dcouplermod.o gsi_4dvar.o gsimod.o -gsi_metguess_mod.o : gsi_metguess_mod.F90 gsi_bundlemod.o mpeu_util.o mpimod.o constants.o kinds.o -gsimod.o : gsimod.F90 gsi_4dcouplermod.o mpeu_util.o prad_bias.o genstats_gps.o gsi_nstcouplermod.o radiance_mod.o general_commvars_mod.o gfs_stratosphere.o chemmod.o tcv_mod.o gsi_chemguess_mod.o gsi_metguess_mod.o rapidrefresh_cldsurf_mod.o hybrid_ensemble_parameters.o lag_traj.o lag_interp.o lag_fields.o m_berror_stats.o read_l2bufr_mod.o smooth_polcarf.o fgrid2agrid_mod.o constants.o wrf_params_mod.o cplr_regional_io.o gsi_io.o guess_grids.o gridmod.o mod_strong.o mod_vtrans.o tendsmod.o jcmod.o compact_diffs.o anberror.o berror.o control_vectors.o state_vectors.o jfunc.o pcpinfo.o qcmod.o turblmod.o balmod.o oneobmod.o convinfo.o coinfo.o aeroinfo.o ozinfo.o radinfo.o mpimod.o obs_ferrscale.o m_obsdiags.o gsi_4dvar.o obs_sensitivity.o aircraftinfo.o obsmod.o kinds.o -gsi_nemsio_mod.o : gsi_nemsio_mod.f90 mod_nmmb_to_a.o general_commvars_mod.o mpimod.o wrf_params_mod.o constants.o gridmod.o kinds.o -gsi_nstcouplermod.o : gsi_nstcouplermod.f90 mpimod.o kinds.o -gsisub.o : gsisub.F90 mpeu_util.o guess_grids.o gsi_io.o radiance_mod.o aircraftinfo.o oneobmod.o read_l2bufr_mod.o coinfo.o ozinfo.o convinfo.o aeroinfo.o pcpinfo.o radinfo.o mpimod.o gridmod.o observer.o obsmod.o kinds.o -gsi_unformatted.o : gsi_unformatted.F90 mpeu_util.o kinds.o -guess_grids.o : guess_grids.F90 mpimod.o gsi_nstcouplermod.o mpeu_util.o tendsmod.o derivsmod.o gsi_chemguess_mod.o gsi_metguess_mod.o gsi_bundlemod.o gridmod.o constants.o kinds.o -half_nmm_grid2.o : half_nmm_grid2.f90 general_commvars_mod.o gridmod.o constants.o kinds.o -hilbert_curve.o : hilbert_curve.f90 kinds.o phil1.o phil.o -hybrid_ensemble_isotropic.o : hybrid_ensemble_isotropic.F90 balmod.o general_commvars_mod.o gfs_stratosphere.o raflib.o gsi_io.o egrid2agrid_mod.o general_specmod.o timermod.o gsi_4dvar.o berror.o jfunc.o general_sub2grid_mod.o cplr_get_wrf_nmm_ensperts.o cplr_get_wrf_mass_ensperts.o cplr_get_pseudo_ensperts.o gsi_enscouplermod.o hybrid_ensemble_parameters.o constants.o gridmod.o control_vectors.o gsi_bundlemod.o mpimod.o kinds.o -hybrid_ensemble_parameters.o : hybrid_ensemble_parameters.f90 constants.o gsi_bundlemod.o egrid2agrid_mod.o general_specmod.o general_sub2grid_mod.o kinds.o -inc2guess.o : inc2guess.f90 mpeu_util.o gsi_chemguess_mod.o gsi_metguess_mod.o gsi_bundlemod.o xhat_vordivmod.o gsi_4dvar.o state_vectors.o guess_grids.o gridmod.o mpimod.o kinds.o -init_jcdfi.o : init_jcdfi.f90 jcmod.o mpimod.o constants.o gsi_4dvar.o kinds.o -insitu_info.o : insitu_info.f90 kinds.o -intall.o : intall.f90 m_obsHeadBundle.o mpl_allreduce.o guess_grids.o mpeu_util.o gsi_bundlemod.o timermod.o intjcmod.o state_vectors.o bias_predictors.o intjo.o intrad.o jfunc.o jcmod.o constants.o gsi_4dvar.o kinds.o -intaod.o : intaod.f90 mpeu_util.o gsi_chemguess_mod.o gsi_bundlemod.o constants.o gridmod.o jfunc.o obsmod.o aeroinfo.o kinds.o m_aeroNode.o m_obsNode.o -intcldch.o : intcldch.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_cldchNode.o m_obsNode.o -intco.o : intco.f90 gsi_4dvar.o constants.o jfunc.o gridmod.o obsmod.o kinds.o gsi_bundlemod.o m_colvkNode.o m_obsNode.o -intdw.o : intdw.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_dwNode.o m_obsNode.o -intgps.o : intgps.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o constants.o gridmod.o qcmod.o obsmod.o kinds.o m_gpsNode.o m_obsNode.o -intgust.o : intgust.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_gustNode.o m_obsNode.o -inthowv.o : inthowv.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_howvNode.o m_obsNode.o -intjcmod.o : intjcmod.f90 state_vectors.o gsi_4dvar.o jcmod.o mpl_allreduce.o mpimod.o derivsmod.o guess_grids.o gsi_metguess_mod.o jfunc.o gridmod.o gsi_bundlemod.o constants.o kinds.o -intjo.o : intjo.f90 m_obsHeadBundle.o gsi_bundlemod.o intvwnd10m.o intuwnd10m.o intcldch.o intlcbas.o inttcamt.o inthowv.o intpmsl.o intmitm.o intmxtm.o inttd2m.o intwspd10m.o intpblh.o intvis.o intgust.o intlag.o intpm10.o intpm2_5.o intco.o intoz.o intpcp.o intdw.o intsst.o intspd.o intrw.o intgps.o inttcp.o intrad.o intq.o intpw.o intps.o intw.o intt.o intaod.o bias_predictors.o jfunc.o kinds.o -intlag.o : intlag.f90 mpimod.o lag_traj.o lag_fields.o gsi_bundlemod.o jfunc.o gridmod.o qcmod.o obsmod.o constants.o kinds.o m_lagNode.o m_obsNode.o -intlcbas.o : intlcbas.f90 gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_lcbasNode.o m_obsNode.o -intmitm.o : intmitm.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_mitmNode.o m_obsNode.o -intmxtm.o : intmxtm.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_mxtmNode.o m_obsNode.o -intoz.o : intoz.f90 m_o3lNode.o m_ozNode.o gsi_4dvar.o constants.o jfunc.o gridmod.o obsmod.o kinds.o gsi_bundlemod.o m_obsNode.o -intpblh.o : intpblh.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_pblhNode.o m_obsNode.o -intpcp.o : intpcp.f90 gsi_bundlemod.o jfunc.o gsi_4dvar.o gridmod.o constants.o pcpinfo.o qcmod.o obsmod.o kinds.o m_pcpNode.o m_obsNode.o -intpm10.o : intpm10.f90 chemmod.o gridmod.o gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_pm10Node.o m_obsNode.o -intpm2_5.o : intpm2_5.f90 chemmod.o gridmod.o gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_pm2_5Node.o m_obsNode.o -intpmsl.o : intpmsl.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_pmslNode.o m_obsNode.o -intps.o : intps.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_psNode.o m_obsNode.o -intpw.o : intpw.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o constants.o qcmod.o gridmod.o obsmod.o kinds.o m_pwNode.o m_obsNode.o -intq.o : intq.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_qNode.o m_obsNode.o -intrad.o : intrad.f90 timermod.o gsi_4dvar.o constants.o qcmod.o gridmod.o jfunc.o obsmod.o mpeu_util.o gsi_metguess_mod.o gsi_bundlemod.o radinfo.o m_radNode.o m_obsNode.o kinds.o -intrp2a.o : intrp2a.f90 constants.o gridmod.o kinds.o -intrp3oz.o : intrp3oz.f90 constants.o gridmod.o guess_grids.o kinds.o -intrp_msk.o : intrp_msk.f90 gridmod.o constants.o kinds.o -intrw.o : intrw.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_rwNode.o m_obsNode.o -intspd.o : intspd.f90 gsi_bundlemod.o jfunc.o gsi_4dvar.o constants.o qcmod.o obsmod.o kinds.o m_spdNode.o m_obsNode.o -intsst.o : intsst.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o gsi_nstcouplermod.o qcmod.o obsmod.o constants.o kinds.o m_sstNode.o m_obsNode.o -inttcamt.o : inttcamt.f90 gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_tcamtNode.o m_obsNode.o -inttcp.o : inttcp.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_tcpNode.o m_obsNode.o -inttd2m.o : inttd2m.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_td2mNode.o m_obsNode.o -intt.o : intt.f90 aircraftinfo.o gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_tNode.o m_obsNode.o -intuwnd10m.o : intuwnd10m.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_uwnd10mNode.o m_obsNode.o -intvis.o : intvis.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_visNode.o m_obsNode.o -intvwnd10m.o : intvwnd10m.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_vwnd10mNode.o m_obsNode.o -intw.o : intw.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_wNode.o m_obsNode.o -intwspd10m.o : intwspd10m.f90 gsi_4dvar.o gsi_bundlemod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o m_wspd10mNode.o m_obsNode.o -jcmod.o : jcmod.f90 constants.o kinds.o -jfunc.o : jfunc.f90 hybrid_ensemble_parameters.o bias_predictors.o gsi_4dvar.o aircraftinfo.o pcpinfo.o radinfo.o obsmod.o general_commvars_mod.o mpimod.o m_berror_stats_reg.o m_berror_stats.o gridmod.o mpeu_util.o gsi_bundlemod.o state_vectors.o control_vectors.o constants.o kinds.o -jgrad.o : jgrad.f90 m_obsHeadBundle.o mpl_allreduce.o hybrid_ensemble_parameters.o xhat_vordivmod.o gsi_4dcouplermod.o intrad.o intjo.o bias_predictors.o gsi_bundlemod.o state_vectors.o control_vectors.o mod_strong.o obs_sensitivity.o obsmod.o gridmod.o intjcmod.o jcmod.o jfunc.o mpimod.o constants.o gsi_4dvar.o kinds.o -kinds.o : kinds.F90 -lag_fields.o : lag_fields.f90 gsi_metguess_mod.o gsi_bundlemod.o mpimod.o mpeu_util.o lag_interp.o lag_traj.o gsi_4dvar.o constants.o guess_grids.o general_commvars_mod.o gridmod.o kinds.o -lag_interp.o : lag_interp.f90 constants.o gridmod.o kinds.o -lagmod.o : lagmod.f90 constants.o kinds.o -lag_traj.o : lag_traj.f90 lag_interp.o constants.o kinds.o -lanczos.o : lanczos.F90 gsi_bundlemod.o state_vectors.o bias_predictors.o gsi_4dvar.o timermod.o control_vectors.o jfunc.o constants.o kinds.o -logcldch_to_cldch.o : logcldch_to_cldch.f90 constants.o derivsmod.o gridmod.o kinds.o -loglcbas_to_lcbas.o : loglcbas_to_lcbas.f90 constants.o derivsmod.o gridmod.o kinds.o -logvis_to_vis.o : logvis_to_vis.f90 constants.o derivsmod.o gridmod.o kinds.o -looplimits.o : looplimits.f90 kinds.o -m_aerolNode.o : m_aerolNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_aeroNode.o : m_aeroNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o aeroinfo.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_berror_stats.o : m_berror_stats.f90 gsi_chemguess_mod.o gsi_metguess_mod.o gsi_bundlemod.o guess_grids.o mpimod.o radiance_mod.o gridmod.o mpeu_util.o control_vectors.o constants.o kinds.o -m_berror_stats_reg.o : m_berror_stats_reg.f90 radiance_mod.o mpeu_util.o control_vectors.o gsi_io.o guess_grids.o m_berror_stats.o chemmod.o gridmod.o constants.o kinds.o -m_cldchNode.o : m_cldchNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_colvkNode.o : m_colvkNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o gridmod.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_cvgridLookup.o : m_cvgridLookup.F90 myassert.H mytrace.H constants.o mpimod.o gridmod.o mpeu_util.o kinds.o -m_dgeevx.o : m_dgeevx.F90 constants.o kinds.o -m_distance.o : m_distance.f90 kinds.o constants.o -m_dtime.o : m_dtime.F90 gsi_io.o mpeu_util.o guess_grids.o kinds.o -m_dwNode.o : m_dwNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_extOzone.o : m_extOzone.F90 radinfo.o ozinfo.o obsmod.o gsi_4dvar.o gridmod.o satthin.o mpimod.o constants.o mpeu_util.o kinds.o -m_find.o : m_find.f90 kinds.o -m_gpsNode.o : m_gpsNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o gridmod.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_gpsrhs.o : m_gpsrhs.F90 mytrace.H obsmod.o constants.o mpeu_util.o kinds.o -m_gsiBiases.o : m_gsiBiases.f90 guess_grids.o constants.o mpeu_util.o gsi_chemguess_mod.o gsi_metguess_mod.o gsi_bundlemod.o gsi_4dvar.o gridmod.o jfunc.o mpimod.o kinds.o -m_gustNode.o : m_gustNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_howvNode.o : m_howvNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_lagNode.o : m_lagNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o lag_traj.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_latlonRange.o : m_latlonRange.F90 myassert.H mpimod.o gsi_unformatted.o m_cvgridLookup.o mpeu_util.o mpeu_mpif.o kinds.o -m_lcbasNode.o : m_lcbasNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_mitmNode.o : m_mitmNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_mxtmNode.o : m_mxtmNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_o3lNode.o : m_o3lNode.F90 mytrace.H myassert.H m_cvgridLookup.o constants.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_obsdiagNode.o : m_obsdiagNode.F90 mytrace.H myassert.H m_cvgridLookup.o mpimod.o timermod.o jfunc.o obs_sensitivity.o m_latlonRange.o mpeu_util.o obsmod.o kinds.o -m_obsdiags.o : m_obsdiags.F90 myassert.H mytrace.H jfunc.o gsi_unformatted.o m_obsNode.o m_obsdiagNode.o m_latlonRange.o mpimod.o obsmod.o gsi_4dvar.o m_obsNodeTypeManager.o m_cldchNode.o m_pm10Node.o m_vwnd10mNode.o m_uwnd10mNode.o m_lcbasNode.o m_tcamtNode.o m_howvNode.o m_pmslNode.o m_mitmNode.o m_mxtmNode.o m_td2mNode.o m_wspd10mNode.o m_pblhNode.o m_visNode.o m_gustNode.o m_pm2_5Node.o m_aerolNode.o m_aeroNode.o m_colvkNode.o m_lagNode.o m_tcpNode.o m_radNode.o m_gpsNode.o m_o3lNode.o m_ozNode.o m_pcpNode.o m_pwNode.o m_sstNode.o m_dwNode.o m_rwNode.o m_spdNode.o m_qNode.o m_wNode.o m_tNode.o m_psNode.o m_obsLList.o mpeu_mpif.o mpeu_util.o kinds.o -m_obsHeadBundle.o : m_obsHeadBundle.F90 myassert.H mpeu_util.o m_obsdiags.o kinds.o m_obsLList.o m_vwnd10mNode.o m_uwnd10mNode.o m_cldchNode.o m_pm10Node.o m_lcbasNode.o m_tcamtNode.o m_howvNode.o m_pmslNode.o m_mitmNode.o m_mxtmNode.o m_td2mNode.o m_wspd10mNode.o m_pblhNode.o m_visNode.o m_gustNode.o m_pm2_5Node.o m_aerolNode.o m_aeroNode.o m_colvkNode.o m_lagNode.o m_tcpNode.o m_radNode.o m_gpsNode.o m_o3lNode.o m_ozNode.o m_pcpNode.o m_pwNode.o m_sstNode.o m_dwNode.o m_rwNode.o m_spdNode.o m_qNode.o m_wNode.o m_tNode.o m_psNode.o m_obsNode.o -m_obsLList.o : m_obsLList.F90 mytrace.H myassert.H m_latlonRange.o obsmod.o m_obsNode.o mpeu_util.o kinds.o -m_obsNode.o : m_obsNode.F90 myassert.H mytrace.H m_obsdiagNode.o m_cvgridLookup.o mpimod.o obsmod.o mpeu_util.o kinds.o -m_obsNodeTypeManager.o : m_obsNodeTypeManager.F90 mpeu_util.o m_obsNode.o kinds.o m_cldchNode.o m_pm10Node.o m_lcbasNode.o m_tcamtNode.o m_howvNode.o m_pmslNode.o m_mitmNode.o m_mxtmNode.o m_td2mNode.o m_vwnd10mNode.o m_uwnd10mNode.o m_wspd10mNode.o m_pblhNode.o m_visNode.o m_gustNode.o m_pm2_5Node.o m_aerolNode.o m_aeroNode.o m_colvkNode.o m_lagNode.o m_tcpNode.o m_radNode.o m_gpsNode.o m_o3lNode.o m_ozNode.o m_pcpNode.o m_pwNode.o m_sstNode.o m_dwNode.o m_rwNode.o m_spdNode.o m_qNode.o m_wNode.o m_tNode.o m_psNode.o obsmod.o -model_ad.o : model_ad.F90 lag_traj.o lag_fields.o mpimod.o mpeu_util.o timermod.o m_tick.o gsi_4dcouplermod.o gsi_bundlemod.o state_vectors.o constants.o gsi_4dvar.o kinds.o -model_tl.o : model_tl.F90 lag_traj.o lag_fields.o mpeu_util.o timermod.o m_tick.o gsi_4dcouplermod.o gsi_bundlemod.o state_vectors.o constants.o gsi_4dvar.o kinds.o -mod_nmmb_to_a.o : mod_nmmb_to_a.f90 constants.o kinds.o -mod_strong.o : mod_strong.f90 constants.o kinds.o -mod_vtrans.o : mod_vtrans.f90 gsi_io.o mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o general_commvars_mod.o general_sub2grid_mod.o guess_grids.o mpimod.o gridmod.o constants.o kinds.o -mod_wrfmass_to_a.o : mod_wrfmass_to_a.f90 constants.o mpimod.o kinds.o -m_ozNode.o : m_ozNode.F90 mytrace.H myassert.H m_cvgridLookup.o gridmod.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_pblhNode.o : m_pblhNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -mp_compact_diffs_mod1.o : mp_compact_diffs_mod1.f90 compact_diffs.o constants.o mpimod.o gridmod.o kinds.o -mp_compact_diffs_support.o : mp_compact_diffs_support.f90 constants.o kinds.o -m_pcpNode.o : m_pcpNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o pcpinfo.o gridmod.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -mpeu_mpif.o : mpeu_mpif.F90 -mpeu_util.o : mpeu_util.F90 mpimod.o mpeu_mpif.o kinds.o -mpimod.o : mpimod.F90 mpeu_mpif.o kinds.o -mpl_allreduce.o : mpl_allreduce.F90 mpimod.o kinds.o -mpl_bcast.o : mpl_bcast.f90 mpimod.o kinds.o -m_pm10Node.o : m_pm10Node.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_pm2_5Node.o : m_pm2_5Node.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_pmslNode.o : m_pmslNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_psNode.o : m_psNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o obsmod.o mpeu_util.o kinds.o -m_pwNode.o : m_pwNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o gridmod.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_qNode.o : m_qNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_radNode.o : m_radNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o radinfo.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_rerank.o : m_rerank.f90 kinds.o -m_rhs.o : m_rhs.F90 mytrace.H gsi_io.o convinfo.o gridmod.o qcmod.o coinfo.o ozinfo.o radinfo.o obsmod.o constants.o mpeu_util.o kinds.o -m_rwNode.o : m_rwNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_sortind.o : m_sortind.f90 kinds.o -m_spdNode.o : m_spdNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_sstNode.o : m_sstNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_stats.o : m_stats.f90 mpimod.o constants.o kinds.o -m_tcamtNode.o : m_tcamtNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_tcpNode.o : m_tcpNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_td2mNode.o : m_td2mNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_tick.o : m_tick.F90 kinds.o -m_tNode.o : m_tNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o aircraftinfo.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_uniq.o : m_uniq.f90 m_find.o kinds.o -m_uwnd10mNode.o : m_uwnd10mNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_visNode.o : m_visNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_vwnd10mNode.o : m_vwnd10mNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_wNode.o : m_wNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -m_wspd10mNode.o : m_wspd10mNode.F90 mytrace.H myassert.H m_cvgridLookup.o m_obsdiagNode.o m_obsNode.o mpeu_util.o kinds.o obsmod.o -native_endianness.o : native_endianness.f90 kinds.o -ncepgfs_ghg.o : ncepgfs_ghg.f90 constants.o kinds.o -ncepgfs_io.o : ncepgfs_io.f90 mpl_allreduce.o hybrid_ensemble_parameters.o obsmod.o general_commvars_mod.o gsi_4dvar.o gsi_nstcouplermod.o nstio_module.o constants.o gsi_chemguess_mod.o ncepgfs_ghg.o general_specmod.o cloud_efr_mod.o mpeu_util.o mpimod.o general_sub2grid_mod.o gsi_bundlemod.o gsi_metguess_mod.o guess_grids.o gridmod.o kinds.o ncepnems_io.o -ncepnems_io.o : ncepnems_io.f90 gsi_nstcouplermod.o gsi_4dvar.o obsmod.o egrid2agrid_mod.o general_specmod.o general_commvars_mod.o gsi_chemguess_mod.o ncepgfs_ghg.o cloud_efr_mod.o mpimod.o general_sub2grid_mod.o gsi_bundlemod.o gsi_metguess_mod.o guess_grids.o gridmod.o kinds.o constants.o -netcdf_mod.o : netcdf_mod.f90 mpeu_util.o -nlmsas_ad.o : nlmsas_ad.f90 constants.o kinds.o -normal_rh_to_q.o : normal_rh_to_q.f90 constants.o gridmod.o jfunc.o derivsmod.o kinds.o -nstio_module.o : nstio_module.f90 -Nst_Var_ESMFMod.o : Nst_Var_ESMFMod.f90 kinds.o -obserr_allsky_mw.o : obserr_allsky_mw.f90 constants.o kinds.o -observer.o : observer.F90 mytrace.H m_obsdiags.o gsi_io.o mpeu_util.o mp_compact_diffs_mod1.o compact_diffs.o turblmod.o zrnmi_mod.o strong_fast_global_mod.o mod_vtrans.o mod_strong.o lag_fields.o read_obs.o timermod.o m_berror_stats_reg.o m_berror_stats.o m_gsiBiases.o convinfo.o gsi_4dvar.o satthin.o obsmod.o cloud_efr_mod.o guess_grids.o gridmod.o jfunc.o mpimod.o constants.o kinds.o -obs_ferrscale.o : obs_ferrscale.F90 m_obsHeadBundle.o jfunc.o mpl_allreduce.o intrad.o intjo.o obsmod.o bias_predictors.o gsi_4dcouplermod.o gsi_bundlemod.o state_vectors.o mpimod.o gsi_4dvar.o constants.o kinds.o -obsmod.o : obsmod.F90 mpeu_util.o gridmod.o mpimod.o constants.o gsi_4dvar.o kinds.o -obs_para.o : obs_para.f90 lag_fields.o gsi_io.o qcmod.o gridmod.o obsmod.o mpimod.o jfunc.o constants.o kinds.o -obs_sensitivity.o : obs_sensitivity.f90 hybrid_ensemble_parameters.o gsi_4dcouplermod.o mpl_allreduce.o bias_predictors.o gsi_bundlemod.o state_vectors.o control_vectors.o mpimod.o obsmod.o jfunc.o gsi_4dvar.o constants.o kinds.o -omegas_ad.o : omegas_ad.f90 constants.o kinds.o -oneobmod.o : oneobmod.F90 obsmod.o gsi_io.o constants.o kinds.o -ozinfo.o : ozinfo.f90 obsmod.o mpeu_util.o state_vectors.o mpimod.o kinds.o -patch2grid_mod.o : patch2grid_mod.f90 fgrid2agrid_mod.o smooth_polcarf.o blendmod.o gridmod.o anberror.o constants.o kinds.o -pcgsoi.o : pcgsoi.f90 m_obsdiags.o m_obsHeadBundle.o stpjo.o gsi_io.o rapidrefresh_cldsurf_mod.o gsi_4dcouplermod.o gsi_bundlemod.o hybrid_ensemble_isotropic.o hybrid_ensemble_parameters.o projmethod_support.o timermod.o xhat_vordivmod.o bias_predictors.o state_vectors.o control_vectors.o adjtest.o mod_strong.o stpcalc.o intall.o mpl_allreduce.o mpimod.o anberror.o constants.o gridmod.o gsi_4dvar.o jfunc.o obsmod.o qcmod.o kinds.o -pcgsqrt.o : pcgsqrt.f90 timermod.o control_vectors.o mpimod.o constants.o gsi_4dvar.o jfunc.o kinds.o -pcpinfo.o : pcpinfo.f90 general_commvars_mod.o gridmod.o obsmod.o mpimod.o constants.o kinds.o -pcp_k.o : pcp_k.f90 omegas_ad.o nlmsas_ad.o gscond_ad.o gridmod.o pcpinfo.o constants.o kinds.o -penal.o : penal.f90 gsi_bundlemod.o convinfo.o jfunc.o m_obsdiags.o m_obsLList.o m_psNode.o m_wNode.o m_tNode.o m_qNode.o m_obsNode.o gsi_4dvar.o constants.o mpimod.o kinds.o -phil1.o : phil1.f90 kinds.o -phil.o : phil.f90 constants.o kinds.o -plib8.o : plib8.f90 constants.o kinds.o -polcarf.o : polcarf.f90 constants.o gridmod.o kinds.o -prad_bias.o : prad_bias.f90 constants.o timermod.o mpl_allreduce.o berror.o radinfo.o mpimod.o kinds.o gsi_4dvar.o m_obsLList.o m_radNode.o -precond.o : precond.f90 timermod.o control_vectors.o gsi_4dvar.o berror.o kinds.o -precpd_ad.o : precpd_ad.f90 constants.o kinds.o -prewgt.o : prewgt.f90 obsmod.o gsi_metguess_mod.o gsi_bundlemod.o blendmod.o mpeu_util.o smooth_polcarf.o guess_grids.o constants.o general_commvars_mod.o gridmod.o control_vectors.o jfunc.o mpimod.o m_berror_stats.o berror.o kinds.o -prewgt_reg.o : prewgt_reg.f90 gsi_metguess_mod.o gsi_bundlemod.o mpl_allreduce.o mpeu_util.o m_berror_stats_reg.o guess_grids.o constants.o gridmod.o control_vectors.o jfunc.o mpimod.o berror.o balmod.o kinds.o -projmethod_support.o : projmethod_support.f90 mpeu_util.o gsi_bundlemod.o pcpinfo.o radinfo.o general_commvars_mod.o gridmod.o mpimod.o constants.o jfunc.o control_vectors.o kinds.o -prt_guess.o : prt_guess.f90 gsi_chemguess_mod.o satthin.o mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o jfunc.o derivsmod.o aircraftinfo.o pcpinfo.o radinfo.o guess_grids.o gridmod.o constants.o mpimod.o kinds.o -psichi2uv_reg.o : psichi2uv_reg.f90 gridmod.o constants.o kinds.o -psichi2uvt_reg.o : psichi2uvt_reg.f90 gridmod.o constants.o kinds.o -qcmod.o : qcmod.f90 gsi_metguess_mod.o mpeu_util.o aircraftinfo.o radiance_mod.o radinfo.o obsmod.o constants.o kinds.o -q_diag.o : q_diag.f90 mpeu_util.o gsi_bundlemod.o gsi_metguess_mod.o general_commvars_mod.o derivsmod.o gridmod.o constants.o mpimod.o jfunc.o guess_grids.o kinds.o -qnewton3.o : qnewton3.f90 timermod.o jfunc.o qcmod.o control_vectors.o mpimod.o constants.o kinds.o -radiance_mod.o : radiance_mod.f90 clw_mod.o gsi_io.o obsmod.o radinfo.o control_vectors.o mpeu_util.o gsi_chemguess_mod.o gsi_metguess_mod.o mpimod.o constants.o kinds.o -radinfo.o : radinfo.f90 mpeu_util.o obsmod.o correlated_obsmod.o gsi_io.o gridmod.o gsi_chemguess_mod.o gsi_metguess_mod.o mpimod.o constants.o read_diag.o kinds.o -raflib.o : raflib.f90 plib8.o gsi_io.o constants.o mpimod.o kinds.o -rapidrefresh_cldsurf_mod.o : rapidrefresh_cldsurf_mod.f90 gsi_metguess_mod.o kinds.o -rdgrbsst.o : rdgrbsst.f90 constants.o kinds.o -read_aerosol.o : read_aerosol.f90 mpimod.o satthin.o gsi_4dvar.o obsmod.o constants.o chemmod.o gridmod.o kinds.o -read_ahi.o : read_ahi.f90 mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o gsi_4dvar.o radinfo.o constants.o gridmod.o satthin.o kinds.o -read_airs.o : read_airs.f90 gsi_io.o mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o calc_fov_crosstrk.o gsi_4dvar.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_amsr2.o : read_amsr2.f90 mpimod.o m_sortind.o ssmis_spatial_average_mod.o gsi_nstcouplermod.o deter_sfc_mod.o calc_fov_conical.o gsi_4dvar.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_amsre.o : read_amsre.f90 mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o calc_fov_conical.o gsi_4dvar.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_anowbufr.o : read_anowbufr.f90 mpimod.o chemmod.o gsi_4dvar.o convinfo.o gridmod.o constants.o kinds.o -read_atms.o : read_atms.f90 radiance_mod.o mpimod.o gsi_nstcouplermod.o atms_spatial_average_mod.o deter_sfc_mod.o gsi_4dvar.o calc_fov_crosstrk.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_avhrr.o : read_avhrr.f90 mpimod.o gsi_nstcouplermod.o obsmod.o deter_sfc_mod.o gsi_4dvar.o radinfo.o constants.o gridmod.o satthin.o kinds.o -read_avhrr_navy.o : read_avhrr_navy.f90 mpimod.o gsi_nstcouplermod.o obsmod.o deter_sfc_mod.o gsi_4dvar.o radinfo.o constants.o gridmod.o satthin.o kinds.o -read_bufrtovs.o : read_bufrtovs.f90 gsi_io.o radiance_mod.o mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o mpeu_util.o antcorr_application.o gsi_4dvar.o calc_fov_crosstrk.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_co.o : read_co.f90 mpimod.o gsi_4dvar.o obsmod.o constants.o gridmod.o satthin.o kinds.o -read_cris.o : read_cris.f90 gsi_io.o mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o calc_fov_crosstrk.o gsi_4dvar.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_diag.o : read_diag.f90 kinds.o -read_files.o : read_files.f90 gsi_io.o read_obs.o nstio_module.o gsi_nstcouplermod.o obsmod.o constants.o gridmod.o hybrid_ensemble_parameters.o gsi_4dvar.o guess_grids.o mpimod.o kinds.o -read_fl_hdob.o : read_fl_hdob.f90 mpimod.o deter_sfc_mod.o support_2dvar.o convthin.o qcmod.o gsi_4dvar.o convb_uv.o convb_t.o convb_q.o convb_ps.o converr_uv.o converr_t.o converr_q.o converr_ps.o converr.o obsmod.o convinfo.o gridmod.o constants.o kinds.o -read_gfs_ozone_for_regional.o : read_gfs_ozone_for_regional.f90 ncepnems_io.o gsi_4dvar.o gsi_metguess_mod.o gsi_bundlemod.o obsmod.o aniso_ens_util.o guess_grids.o egrid2agrid_mod.o general_specmod.o general_sub2grid_mod.o kinds.o mpeu_util.o mpimod.o constants.o gridmod.o -read_gmi.o : read_gmi.f90 mpimod.o m_sortind.o ssmis_spatial_average_mod.o gsi_nstcouplermod.o deter_sfc_mod.o gsi_4dvar.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_goesimg.o : read_goesimg.f90 mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o gsi_4dvar.o radinfo.o constants.o gridmod.o satthin.o kinds.o -read_goesimgr_skycover.o : read_goesimgr_skycover.f90 mpimod.o adjust_cloudobs_mod.o gsi_4dvar.o obsmod.o deter_sfc_mod.o gridmod.o convthin.o convinfo.o constants.o kinds.o -read_goesndr.o : read_goesndr.f90 mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o gsi_4dvar.o constants.o gridmod.o radinfo.o obsmod.o satthin.o kinds.o -read_gps.o : read_gps.f90 mpimod.o gridmod.o convinfo.o gsi_4dvar.o obsmod.o constants.o kinds.o -read_guess.o : read_guess.F90 cplr_read_wrf_nmm_guess.o cplr_read_wrf_mass_guess.o gsd_update_mod.o gsi_bundlemod.o gsi_metguess_mod.o ncepnems_io.o ncepgfs_io.o constants.o gfs_stratosphere.o gridmod.o gsi_bias.o m_gsiBiases.o guess_grids.o jfunc.o kinds.o -read_iasi.o : read_iasi.f90 gsi_io.o mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o calc_fov_crosstrk.o gsi_4dvar.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_l2bufr_mod.o : read_l2bufr_mod.f90 gsi_io.o mpeu_util.o qcmod.o oneobmod.o obsmod.o mpimod.o constants.o kinds.o -read_lag.o : read_lag.f90 lag_fields.o gsi_4dvar.o convinfo.o constants.o gridmod.o kinds.o -read_lidar.o : read_lidar.f90 mpimod.o deter_sfc_mod.o gsi_4dvar.o obsmod.o constants.o convinfo.o gridmod.o kinds.o -read_Lightning.o : read_Lightning.f90 mpimod.o mod_wrfmass_to_a.o obsmod.o gridmod.o gsi_4dvar.o convinfo.o constants.o kinds.o -read_mitm_mxtm.o : read_mitm_mxtm.f90 gsi_io.o mpimod.o support_2dvar.o sfcobsqc.o gsi_4dvar.o obsmod.o deter_sfc_mod.o gridmod.o convinfo.o constants.o kinds.o -read_modsbufr.o : read_modsbufr.f90 gsi_nstcouplermod.o deter_sfc_mod.o gsi_4dvar.o insitu_info.o obsmod.o convinfo.o gridmod.o constants.o mpimod.o kinds.o -read_NASA_LaRC_cloud.o : read_NASA_LaRC_cloud.f90 mpimod.o gridmod.o constants.o kinds.o -read_nasa_larc.o : read_nasa_larc.f90 mpimod.o mod_wrfmass_to_a.o gridmod.o gsi_4dvar.o convinfo.o constants.o kinds.o -read_nsstbufr.o : read_nsstbufr.f90 mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o gsi_4dvar.o insitu_info.o obsmod.o convinfo.o gridmod.o constants.o kinds.o -read_obs.o : read_obs.F90 gsi_unformatted.o mpeu_util.o m_extOzone.o read_l2bufr_mod.o radiance_mod.o rapidrefresh_cldsurf_mod.o gsi_io.o gsi_nstcouplermod.o aircraftinfo.o pcpinfo.o ozinfo.o aeroinfo.o insitu_info.o radinfo.o guess_grids.o convb_uv.o convb_t.o convb_q.o convb_ps.o converr_pw.o converr_uv.o converr_t.o converr_q.o converr_ps.o converr.o constants.o mpimod.o satthin.o qcmod.o general_commvars_mod.o gridmod.o chemmod.o convinfo.o obsmod.o gsi_4dvar.o kinds.o -read_ozone.o : read_ozone.f90 mpimod.o ozinfo.o qcmod.o radinfo.o gsi_4dvar.o obsmod.o constants.o gridmod.o satthin.o kinds.o -read_pblh.o : read_pblh.f90 mpimod.o deter_sfc_mod.o obsmod.o gsi_4dvar.o convinfo.o gridmod.o constants.o kinds.o -read_pcp.o : read_pcp.f90 mpimod.o obsmod.o deter_sfc_mod.o gsi_4dvar.o constants.o gridmod.o kinds.o -read_prepbufr.o : read_prepbufr.f90 guess_grids.o gsi_io.o rapidrefresh_cldsurf_mod.o mpimod.o adjust_cloudobs_mod.o aircraftobsqc.o gsi_nstcouplermod.o deter_sfc_mod.o jfunc.o support_2dvar.o sfcobsqc.o blacklist.o convthin.o qcmod.o gsi_4dvar.o convb_uv.o convb_t.o convb_q.o convb_ps.o converr_pw.o converr_uv.o converr_t.o converr_q.o converr_ps.o converr.o aircraftinfo.o obsmod.o convinfo.o gridmod.o constants.o kinds.o -read_radar.o : read_radar.f90 gsi_io.o mpimod.o deter_sfc_mod.o convthin.o convinfo.o gridmod.o gsi_4dvar.o obsmod.o qcmod.o constants.o kinds.o -read_radarref_mosaic.o : read_radarref_mosaic.f90 mpimod.o mod_wrfmass_to_a.o gridmod.o gsi_4dvar.o convinfo.o constants.o kinds.o -read_rapidscat.o : read_rapidscat.f90 mpimod.o deter_sfc_mod.o gsi_4dvar.o convinfo.o obsmod.o constants.o convthin.o qcmod.o gridmod.o kinds.o -read_saphir.o : read_saphir.f90 radiance_mod.o mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o gsi_4dvar.o calc_fov_crosstrk.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_satmar.o : read_satmar.f90 mpimod.o obsmod.o convthin.o convinfo.o satthin.o gridmod.o constants.o gsi_4dvar.o kinds.o -read_satwnd.o : read_satwnd.f90 mpimod.o deter_sfc_mod.o gsi_4dvar.o convinfo.o obsmod.o convb_uv.o converr_uv.o converr.o constants.o convthin_time.o convthin.o qcmod.o gridmod.o kinds.o -read_seviri.o : read_seviri.f90 mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o gsi_4dvar.o radinfo.o obsmod.o constants.o gridmod.o satthin.o kinds.o -read_sfcwnd.o : read_sfcwnd.f90 mpimod.o deter_sfc_mod.o gsi_4dvar.o convinfo.o obsmod.o convb_uv.o converr_uv.o converr.o constants.o convthin.o qcmod.o gridmod.o kinds.o -read_ssmi.o : read_ssmi.f90 mpimod.o gsi_nstcouplermod.o deter_sfc_mod.o gsi_4dvar.o constants.o gridmod.o radinfo.o obsmod.o satthin.o kinds.o -read_ssmis.o : read_ssmis.f90 mpimod.o m_sortind.o ssmis_spatial_average_mod.o gsi_nstcouplermod.o deter_sfc_mod.o calc_fov_conical.o gsi_4dvar.o constants.o gridmod.o radinfo.o satthin.o kinds.o -read_tcps.o : read_tcps.f90 mpimod.o gsi_4dvar.o tcv_mod.o obsmod.o convinfo.o constants.o gridmod.o kinds.o -reorg_metar_cloud.o : reorg_metar_cloud.f90 rapidrefresh_cldsurf_mod.o constants.o gridmod.o kinds.o -rfdpar.o : rfdpar.f90 constants.o kinds.o -rsearch.o : rsearch.F90 constants.o kinds.o -rtlnmc_version3.o : rtlnmc_version3.f90 general_commvars_mod.o hybrid_ensemble_parameters.o jfunc.o mpimod.o zrnmi_mod.o mod_vtrans.o gridmod.o constants.o kinds.o -satthin.o : satthin.F90 gsi_bundlemod.o gsi_metguess_mod.o ncepnems_io.o ncepgfs_io.o mpimod.o jfunc.o m_gsiBiases.o guess_grids.o general_commvars_mod.o gridmod.o obsmod.o constants.o mpeu_util.o kinds.o -set_crtm_aerosolmod.o : set_crtm_aerosolmod.f90 mpeu_util.o mpimod.o constants.o kinds.o -set_crtm_cloudmod.o : set_crtm_cloudmod.f90 wrf_params_mod.o gridmod.o mpeu_util.o constants.o kinds.o -setupaod.o : setupaod.f90 radiance_mod.o qcmod.o m_obsLList.o m_aeroNode.o m_obsNode.o m_obsdiags.o chemmod.o m_dtime.o jfunc.o constants.o gridmod.o gsi_4dvar.o obsmod.o kinds.o mpeu_util.o crtm_interface.o aeroinfo.o radinfo.o -setupbend.o : setupbend.f90 gsi_metguess_mod.o gsi_bundlemod.o m_gpsrhs.o m_dtime.o convinfo.o jfunc.o lagmod.o constants.o gridmod.o guess_grids.o gsi_4dvar.o m_obsLList.o m_gpsNode.o m_obsNode.o obsmod.o m_obsdiags.o genstats_gps.o kinds.o mpeu_util.o -setupcldch.o : setupcldch.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o obsmod.o guess_grids.o m_obsLList.o m_obsdiags.o m_cldchNode.o m_obsNode.o kinds.o mpeu_util.o -setupco.o : setupco.f90 m_dtime.o jfunc.o coinfo.o gsi_chemguess_mod.o gsi_bundlemod.o guess_grids.o gridmod.o gsi_4dvar.o m_obsLList.o m_colvkNode.o m_obsNode.o obsmod.o m_obsdiags.o constants.o kinds.o mpeu_util.o -setupdw.o : setupdw.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o jfunc.o gsi_4dvar.o m_obsLList.o m_dwNode.o m_obsNode.o m_obsdiags.o obsmod.o constants.o guess_grids.o gridmod.o qcmod.o kinds.o mpeu_util.o -setupgust.o : setupgust.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_gustNode.o m_obsNode.o obsmod.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setuphowv.o : setuphowv.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o obsmod.o m_obsLList.o m_howvNode.o m_obsNode.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setuplag.o : setuplag.f90 lag_interp.o lag_traj.o lag_fields.o m_dtime.o convinfo.o jfunc.o constants.o qcmod.o gridmod.o guess_grids.o gsi_4dvar.o m_obsLList.o m_lagNode.o m_obsNode.o obsmod.o m_obsdiags.o kinds.o mpeu_util.o -setuplcbas.o : setuplcbas.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_lcbasNode.o m_obsNode.o obsmod.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setupmitm.o : setupmitm.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o obsmod.o m_obsLList.o m_mitmNode.o m_obsNode.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setupmxtm.o : setupmxtm.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o obsmod.o m_obsLList.o m_mxtmNode.o m_obsNode.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setupoz.o : setupoz.f90 m_o3lNode.o gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o jfunc.o ozinfo.o guess_grids.o gridmod.o gsi_4dvar.o m_obsLList.o m_ozNode.o m_obsNode.o obsmod.o m_obsdiags.o constants.o kinds.o mpeu_util.o -setuppblh.o : setuppblh.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_pblhNode.o m_obsNode.o obsmod.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setuppcp.o : setuppcp.f90 m_dtime.o jfunc.o constants.o gsi_bundlemod.o gsi_metguess_mod.o gsi_4dvar.o m_obsLList.o m_pcpNode.o m_obsNode.o m_obsdiags.o obsmod.o tendsmod.o derivsmod.o guess_grids.o gridmod.o pcpinfo.o kinds.o mpeu_util.o -setuppm10.o : setuppm10.f90 chemmod.o m_dtime.o jfunc.o convinfo.o gsi_metguess_mod.o gsi_chemguess_mod.o gsi_bundlemod.o guess_grids.o gridmod.o gsi_4dvar.o qcmod.o obsmod.o m_obsLList.o m_pm10Node.o m_obsNode.o m_obsdiags.o constants.o kinds.o mpeu_util.o -setuppm2_5.o : setuppm2_5.f90 chemmod.o m_dtime.o jfunc.o convinfo.o gsi_metguess_mod.o gsi_chemguess_mod.o gsi_bundlemod.o guess_grids.o gridmod.o gsi_4dvar.o qcmod.o obsmod.o m_obsLList.o m_pm2_5Node.o m_obsNode.o m_obsdiags.o constants.o kinds.o mpeu_util.o -setuppmsl.o : setuppmsl.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o obsmod.o m_obsLList.o m_pmslNode.o m_obsNode.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setupps.o : setupps.f90 rapidrefresh_cldsurf_mod.o gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o guess_grids.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_psNode.o m_obsNode.o obsmod.o m_obsdiags.o kinds.o mpeu_util.o -setuppw.o : setuppw.f90 gsi_metguess_mod.o gsi_bundlemod.o rapidrefresh_cldsurf_mod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gsi_4dvar.o m_obsLList.o m_pwNode.o m_obsNode.o obsmod.o m_obsdiags.o gridmod.o guess_grids.o kinds.o mpeu_util.o -setupq.o : setupq.f90 gsi_metguess_mod.o gsi_bundlemod.o rapidrefresh_cldsurf_mod.o m_dtime.o converr.o converr_q.o convinfo.o jfunc.o qcmod.o constants.o gridmod.o guess_grids.o oneobmod.o gsi_4dvar.o m_obsLList.o m_qNode.o m_obsNode.o obsmod.o m_obsdiags.o kinds.o mpeu_util.o -setuprad.o : setuprad.f90 radiance_mod.o oneobmod.o qcmod.o clw_mod.o crtm_interface.o m_dtime.o sst_retrieval.o jfunc.o constants.o satthin.o gridmod.o gsi_4dvar.o m_obsLList.o m_radNode.o m_obsNode.o obsmod.o m_obsdiags.o prad_bias.o guess_grids.o read_diag.o gsi_nstcouplermod.o radinfo.o kinds.o mpeu_util.o -setupref.o : setupref.f90 gsi_metguess_mod.o gsi_bundlemod.o m_gpsrhs.o m_dtime.o convinfo.o jfunc.o constants.o gridmod.o guess_grids.o gsi_4dvar.o m_obsLList.o m_gpsNode.o m_obsNode.o obsmod.o m_obsdiags.o genstats_gps.o kinds.o mpeu_util.o -setuprhsall.o : setuprhsall.f90 m_obsdiags.o gsi_metguess_mod.o gsi_bundlemod.o genstats_gps.o m_rhs.o rapidrefresh_cldsurf_mod.o berror.o aeroinfo.o mpl_allreduce.o mpeu_util.o state_vectors.o lag_fields.o timermod.o convinfo.o qcmod.o jfunc.o gsi_4dvar.o gridmod.o mpimod.o coinfo.o ozinfo.o pcpinfo.o aircraftinfo.o radinfo.o obs_sensitivity.o obsmod.o guess_grids.o constants.o kinds.o -setuprw.o : setuprw.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o jfunc.o constants.o gridmod.o guess_grids.o qcmod.o gsi_4dvar.o oneobmod.o m_obsLList.o m_rwNode.o m_obsNode.o obsmod.o m_obsdiags.o kinds.o mpeu_util.o -setupspd.o : setupspd.f90 m_dtime.o gsi_metguess_mod.o gsi_bundlemod.o convinfo.o jfunc.o constants.o qcmod.o gridmod.o guess_grids.o gsi_4dvar.o m_obsLList.o m_spdNode.o m_obsNode.o obsmod.o m_obsdiags.o kinds.o mpeu_util.o -setupsst.o : setupsst.f90 m_dtime.o gsi_nstcouplermod.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_sstNode.o m_obsNode.o obsmod.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setuptcamt.o : setuptcamt.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_tcamtNode.o m_obsNode.o obsmod.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setuptcp.o : setuptcp.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o jfunc.o convinfo.o constants.o gridmod.o guess_grids.o qcmod.o gsi_4dvar.o m_obsLList.o m_tcpNode.o m_obsNode.o obsmod.o m_obsdiags.o kinds.o mpeu_util.o -setuptd2m.o : setuptd2m.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o obsmod.o m_obsLList.o m_td2mNode.o m_obsNode.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setupt.o : setupt.f90 buddycheck_mod.o gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o aircraftinfo.o rapidrefresh_cldsurf_mod.o converr.o converr_t.o convinfo.o constants.o guess_grids.o jfunc.o gridmod.o oneobmod.o qcmod.o gsi_4dvar.o m_obsLList.o m_tNode.o m_obsNode.o obsmod.o m_obsdiags.o kinds.o mpeu_util.o -setupuwnd10m.o : setupuwnd10m.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_uwnd10mNode.o m_obsNode.o obsmod.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setupvis.o : setupvis.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_visNode.o m_obsNode.o obsmod.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setupvwnd10m.o : setupvwnd10m.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_vwnd10mNode.o m_obsNode.o obsmod.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -setupw.o : setupw.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o rapidrefresh_cldsurf_mod.o converr.o converr_uv.o convinfo.o jfunc.o constants.o guess_grids.o gridmod.o oneobmod.o qcmod.o gsi_4dvar.o m_obsLList.o m_wNode.o m_obsNode.o obsmod.o m_obsdiags.o kinds.o mpeu_util.o -setupwspd10m.o : setupwspd10m.f90 gsi_metguess_mod.o gsi_bundlemod.o m_dtime.o convinfo.o qcmod.o jfunc.o constants.o gridmod.o oneobmod.o gsi_4dvar.o m_obsLList.o m_wspd10mNode.o m_obsNode.o obsmod.o m_obsdiags.o guess_grids.o kinds.o mpeu_util.o -sfc_model.o : sfc_model.f90 constants.o kinds.o -sfcobsqc.o : sfcobsqc.f90 support_2dvar.o gridmod.o constants.o mpimod.o kinds.o -simpin1.o : simpin1.f90 constants.o kinds.o -simpin1_init.o : simpin1_init.f90 constants.o kinds.o -smooth_polcarf.o : smooth_polcarf.f90 berror.o constants.o gridmod.o kinds.o -smoothrf.o : smoothrf.f90 jfunc.o smooth_polcarf.o mpimod.o control_vectors.o berror.o constants.o gridmod.o kinds.o -smoothwwrf.o : smoothwwrf.f90 constants.o kinds.o -smoothzrf.o : smoothzrf.f90 berror.o balmod.o gridmod.o constants.o kinds.o -sqrtmin.o : sqrtmin.f90 timermod.o obs_ferrscale.o control_vectors.o grtest.o adjtest.o lanczos.o qnewton3.o obsmod.o obs_sensitivity.o mpimod.o constants.o jfunc.o gsi_4dvar.o kinds.o -ssmis_spatial_average_mod.o : ssmis_spatial_average_mod.f90 m_distance.o m_uniq.o kinds.o -sst_retrieval.o : sst_retrieval.f90 obsmod.o gridmod.o gsi_io.o constants.o radinfo.o kinds.o -state_vectors.o : state_vectors.f90 mpeu_util.o gsi_bundlemod.o mpl_allreduce.o mpimod.o constants.o kinds.o -statsco.o : statsco.f90 gridmod.o convinfo.o qcmod.o jfunc.o coinfo.o obsmod.o constants.o kinds.o -statsconv.o : statsconv.f90 convinfo.o gridmod.o jfunc.o qcmod.o obsmod.o constants.o kinds.o -statsoz.o : statsoz.f90 jfunc.o ozinfo.o obsmod.o constants.o kinds.o -statspcp.o : statspcp.f90 constants.o jfunc.o obsmod.o pcpinfo.o kinds.o -statsrad.o : statsrad.f90 jfunc.o radinfo.o obsmod.o constants.o kinds.o -stop1.o : stop1.f90 mpimod.o kinds.o -stpaod.o : stpaod.f90 gridmod.o gsi_bundlemod.o constants.o qcmod.o aeroinfo.o kinds.o m_aeroNode.o m_obsNode.o -stpcalc.o : stpcalc.f90 gsi_io.o m_obsHeadBundle.o stpjo.o timermod.o intrad.o mpeu_util.o mpl_allreduce.o guess_grids.o gsi_bundlemod.o state_vectors.o control_vectors.o bias_predictors.o stpjcmod.o obsmod.o jcmod.o jfunc.o gsi_4dvar.o constants.o mpimod.o kinds.o -stpcldch.o : stpcldch.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_cldchNode.o m_obsNode.o -stpco.o : stpco.f90 m_obsNode.o gsi_bundlemod.o constants.o kinds.o -stpdw.o : stpdw.f90 m_dwNode.o m_obsNode.o gsi_bundlemod.o constants.o qcmod.o kinds.o -stpgps.o : stpgps.f90 m_gpsNode.o m_obsNode.o gsi_bundlemod.o gridmod.o constants.o qcmod.o kinds.o -stpgust.o : stpgust.f90 m_gustNode.o m_obsNode.o gsi_bundlemod.o constants.o qcmod.o kinds.o -stphowv.o : stphowv.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_howvNode.o m_obsNode.o -stpjcmod.o : stpjcmod.f90 state_vectors.o gsi_4dvar.o jcmod.o mpl_allreduce.o mpimod.o derivsmod.o guess_grids.o jfunc.o gridmod.o gsi_metguess_mod.o gsi_bundlemod.o constants.o kinds.o -stpjo.o : stpjo.f90 m_obsHeadBundle.o mpeu_util.o control_vectors.o gsi_bundlemod.o aircraftinfo.o bias_predictors.o stpvwnd10m.o stpuwnd10m.o stpcldch.o stplcbas.o stptcamt.o stphowv.o stppmsl.o stpmitm.o stpmxtm.o stptd2m.o stpwspd10m.o stppblh.o stpvis.o stpgust.o stpaod.o stppm10.o stppm2_5.o stpco.o stpoz.o stppcp.o stpdw.o stptcp.o stpsst.o stpspd.o stprw.o stpgps.o stprad.o stpq.o stppw.o stpps.o stpw.o stpt.o obsmod.o kinds.o -stplcbas.o : stplcbas.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_lcbasNode.o m_obsNode.o -stpmitm.o : stpmitm.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_mitmNode.o m_obsNode.o -stpmxtm.o : stpmxtm.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_mxtmNode.o m_obsNode.o -stpoz.o : stpoz.f90 m_o3lNode.o m_ozNode.o gridmod.o obsmod.o gsi_bundlemod.o constants.o m_obsNode.o kinds.o -stppblh.o : stppblh.f90 m_pblhNode.o m_obsNode.o gsi_bundlemod.o constants.o qcmod.o kinds.o -stppcp.o : stppcp.f90 m_pcpNode.o m_obsNode.o gsi_bundlemod.o gsi_4dvar.o gridmod.o qcmod.o constants.o pcpinfo.o kinds.o -stppm10.o : stppm10.f90 chemmod.o gridmod.o gsi_bundlemod.o constants.o qcmod.o kinds.o m_pm10Node.o m_obsNode.o -stppm2_5.o : stppm2_5.f90 chemmod.o gridmod.o gsi_bundlemod.o constants.o qcmod.o kinds.o m_pm2_5Node.o m_obsNode.o -stppmsl.o : stppmsl.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_pmslNode.o m_obsNode.o -stpps.o : stpps.f90 m_psNode.o m_obsNode.o gsi_bundlemod.o constants.o qcmod.o kinds.o -stppw.o : stppw.f90 m_pwNode.o m_obsNode.o gsi_bundlemod.o gridmod.o constants.o qcmod.o kinds.o -stpq.o : stpq.f90 m_qNode.o m_obsNode.o gsi_bundlemod.o constants.o qcmod.o kinds.o -stprad.o : stprad.f90 m_radNode.o m_obsNode.o intrad.o mpeu_util.o gsi_metguess_mod.o gsi_bundlemod.o gridmod.o constants.o qcmod.o radinfo.o kinds.o -stprw.o : stprw.f90 m_rwNode.o m_obsNode.o gsi_bundlemod.o constants.o qcmod.o kinds.o -stpspd.o : stpspd.f90 m_spdNode.o m_obsNode.o gsi_bundlemod.o gsi_4dvar.o constants.o qcmod.o kinds.o -stpsst.o : stpsst.f90 m_sstNode.o m_obsNode.o gsi_bundlemod.o gsi_nstcouplermod.o constants.o qcmod.o kinds.o -stptcamt.o : stptcamt.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_tcamtNode.o m_obsNode.o -stptcp.o : stptcp.f90 m_tcpNode.o m_obsNode.o gsi_bundlemod.o constants.o qcmod.o kinds.o -stptd2m.o : stptd2m.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_td2mNode.o m_obsNode.o -stpt.o : stpt.f90 m_tNode.o m_obsNode.o gsi_bundlemod.o aircraftinfo.o constants.o qcmod.o kinds.o -stpuwnd10m.o : stpuwnd10m.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_uwnd10mNode.o m_obsNode.o -stpvis.o : stpvis.f90 m_visNode.o m_obsNode.o gsi_bundlemod.o constants.o qcmod.o kinds.o -stpvwnd10m.o : stpvwnd10m.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_vwnd10mNode.o m_obsNode.o -stpw.o : stpw.f90 m_wNode.o m_obsNode.o gsi_bundlemod.o constants.o qcmod.o kinds.o -stpwspd10m.o : stpwspd10m.f90 gsi_bundlemod.o constants.o qcmod.o kinds.o m_wspd10mNode.o m_obsNode.o -strong_bal_correction.o : strong_bal_correction.f90 gridmod.o strong_fast_global_mod.o zrnmi_mod.o mod_strong.o kinds.o -strong_baldiag_inc.o : strong_baldiag_inc.f90 constants.o gsi_metguess_mod.o gsi_bundlemod.o state_vectors.o mod_vtrans.o mpimod.o kinds.o -strong_fast_global_mod.o : strong_fast_global_mod.f90 mod_strong.o mod_vtrans.o mpimod.o constants.o gridmod.o kinds.o -stub_ensmod.o : stub_ensmod.f90 gsi_bundlemod.o general_sub2grid_mod.o hybrid_ensemble_parameters.o kinds.o -stub_pertmod.o : stub_pertmod.F90 mytrace.H gsi_io.o constants.o gsi_bundlemod.o gsi_4dcouplermod.o mpeu_util.o kinds.o -stub_set_crtm_aerosol.o : stub_set_crtm_aerosol.f90 mpeu_util.o constants.o kinds.o -stub_timermod.o : stub_timermod.f90 kinds.o -sub2fslab_mod.o : sub2fslab_mod.f90 constants.o patch2grid_mod.o fgrid2agrid_mod.o general_commvars_mod.o general_sub2grid_mod.o control_vectors.o gsi_bundlemod.o anberror.o gridmod.o kinds.o -support_2dvar.o : support_2dvar.f90 convinfo.o anisofilter.o jfunc.o derivsmod.o gsi_bundlemod.o gsi_metguess_mod.o gridmod.o obsmod.o constants.o guess_grids.o mpimod.o mpeu_util.o gsi_io.o gsi_4dvar.o kinds.o -tcv_mod.o : tcv_mod.f90 constants.o kinds.o -tendsmod.o : tendsmod.f90 mpeu_util.o gsi_chemguess_mod.o gsi_metguess_mod.o gsi_bundlemod.o mpimod.o gridmod.o constants.o kinds.o -test_obsens.o : test_obsens.f90 control_vectors.o obs_sensitivity.o mpimod.o obsmod.o jfunc.o constants.o kinds.o -timermod.o : timermod.f90 kinds.o -tintrp2a.o : tintrp2a.f90 guess_grids.o constants.o gridmod.o kinds.o -tintrp3.o : tintrp3.f90 constants.o gridmod.o kinds.o -tpause.o : tpause.f90 gsi_metguess_mod.o gsi_bundlemod.o gridmod.o guess_grids.o constants.o kinds.o -tpause_t.o : tpause_t.F90 constants.o kinds.o -tune_pbl_height.o : tune_pbl_height.f90 mpeu_util.o gsi_metguess_mod.o gsi_bundlemod.o guess_grids.o constants.o gridmod.o kinds.o -turbl_ad.o : turbl_ad.f90 turblmod.o gridmod.o kinds.o constants.o -turbl.o : turbl.f90 turblmod.o gridmod.o constants.o kinds.o -turblmod.o : turblmod.f90 constants.o gridmod.o kinds.o -turbl_tl.o : turbl_tl.f90 turblmod.o gridmod.o kinds.o constants.o -tv_to_tsen.o : tv_to_tsen.f90 jfunc.o guess_grids.o constants.o gridmod.o kinds.o -unfill_mass_grid2.o : unfill_mass_grid2.f90 constants.o mod_wrfmass_to_a.o general_commvars_mod.o gridmod.o kinds.o -unfill_nmm_grid2.o : unfill_nmm_grid2.f90 general_commvars_mod.o gridmod.o kinds.o -unhalf_nmm_grid2.o : unhalf_nmm_grid2.f90 general_commvars_mod.o gridmod.o kinds.o -update_guess.o : update_guess.f90 gsd_update_mod.o rapidrefresh_cldsurf_mod.o mpeu_util.o gsi_chemguess_mod.o gsi_metguess_mod.o gsi_bundlemod.o bias_predictors.o m_gsiBiases.o gsi_4dvar.o xhat_vordivmod.o state_vectors.o guess_grids.o gridmod.o jfunc.o constants.o mpimod.o kinds.o -ut_gsibundle.o : ut_gsibundle.F90 m_rerank.o gsi_bundlemod.o constants.o kinds.o -wind_fft.o : wind_fft.f90 constants.o kinds.o -wrf_mass_guess_mod.o : wrf_mass_guess_mod.f90 guess_grids.o gridmod.o constants.o kinds.o -wrf_params_mod.o : wrf_params_mod.f90 -write_all.o : write_all.F90 mpeu_util.o gsi_metguess_mod.o gsi_bundlemod.o ncepgfs_io.o cplr_regional_io.o gsi_bias.o m_gsiBiases.o guess_grids.o gridmod.o jfunc.o constants.o mpimod.o kinds.o -write_bkgvars_grid.o : write_bkgvars_grid.f90 berror.o control_vectors.o constants.o mpimod.o gridmod.o kinds.o -xhat_vordivmod.o : xhat_vordivmod.f90 general_sub2grid_mod.o general_commvars_mod.o gsi_bundlemod.o gsi_4dvar.o compact_diffs.o gridmod.o constants.o kinds.o -zrnmi_mod.o : zrnmi_mod.f90 hybrid_ensemble_parameters.o jfunc.o mpimod.o gridmod.o mod_vtrans.o mod_strong.o constants.o kinds.o diff --git a/src/Makefile.src b/src/Makefile.src deleted file mode 100644 index d456b2549..000000000 --- a/src/Makefile.src +++ /dev/null @@ -1,530 +0,0 @@ -# ------------ -# Source files -# ------------ - - OBJS = \ - adjtest.o \ - adjtest_obs.o \ - adjust_cloudobs_mod.o \ - aeroinfo.o \ - aircraftinfo.o \ - aircraftobsqc.o \ - anberror.o \ - anbkerror.o \ - aniso_ens_util.o \ - anisofilter.o \ - anisofilter_glb.o \ - antcorr_application.o \ - antest_maps0.o \ - antest_maps0_glb.o \ - atms_spatial_average_mod.o \ - balmod.o \ - berror.o \ - bias_predictors.o \ - bicg.o \ - bicglanczos.o \ - bkerror.o \ - bkgcov.o \ - bkgvar.o \ - bkgvar_rewgt.o \ - blacklist.o \ - blendmod.o \ - blockIO.o \ - buddycheck_mod.o \ - calc_fov_conical.o \ - calc_fov_crosstrk.o \ - calctends.o \ - calctends_ad.o \ - calctends_tl.o \ - calctends_no_ad.o \ - calctends_no_tl.o \ - chemmod.o \ - class_get_pseudo_ensperts.o \ - class_get_wrf_mass_ensperts.o \ - class_get_wrf_nmm_ensperts.o \ - class_gfs_ensmod.o \ - class_read_wrf_mass_files.o \ - class_read_wrf_mass_guess.o \ - class_read_wrf_nmm_files.o \ - class_read_wrf_nmm_guess.o \ - class_regional_io.o \ - class_wrf_binary_interface.o \ - class_wrf_netcdf_interface.o \ - class_wrwrfmassa.o \ - class_wrwrfnmma.o \ - clw_mod.o \ - cloud_efr_mod.o \ - cmaq_routines.o \ - co_mop_ak.o \ - coinfo.o \ - combine_radobs.o \ - compact_diffs.o \ - compute_derived.o \ - compute_fact10.o \ - compute_qvar3d.o \ - constants.o \ - control2model.o \ - control2state.o \ - control2model_ad.o \ - control2state_ad.o \ - control_vectors.o \ - convb_ps.o \ - convb_q.o \ - convb_t.o \ - convb_uv.o \ - converr.o \ - converr_ps.o \ - converr_pw.o \ - converr_q.o \ - converr_t.o \ - converr_uv.o \ - convinfo.o \ - convthin.o \ - convthin_time.o \ - correlated_obsmod.o \ - cplr_get_pseudo_ensperts.o \ - cplr_get_wrf_mass_ensperts.o \ - cplr_get_wrf_nmm_ensperts.o \ - cplr_gfs_ensmod.o \ - cplr_gfs_nstmod.o \ - cplr_read_wrf_mass_files.o \ - cplr_read_wrf_mass_guess.o \ - cplr_read_wrf_nmm_files.o \ - cplr_read_wrf_nmm_guess.o \ - cplr_regional_io.o \ - cplr_wrf_binary_interface.o \ - cplr_wrf_netcdf_interface.o \ - cplr_wrwrfmassa.o \ - cplr_wrwrfnmma.o \ - crtm_interface.o \ - cwhydromod.o \ - cvsection.o \ - derivsmod.o \ - deter_sfc_mod.o \ - dtast.o \ - egrid2agrid_mod.o \ - en_perts_io.o \ - enorm_state.o \ - ensctl2model.o \ - ensctl2state.o \ - ensctl2model_ad.o \ - ensctl2state_ad.o \ - ens_spread_mod.o \ - evaljgrad.o \ - evaljo.o \ - evalqlim.o \ - fgrid2agrid_mod.o \ - fill_mass_grid2.o \ - fill_nmm_grid2.o \ - fpvsx_ad.o \ - general_commvars_mod.o \ - general_read_gfsatm.o \ - general_read_nmmb.o \ - general_specmod.o \ - general_spectral_transforms.o \ - general_sub2grid_mod.o \ - general_tll2xy_mod.o \ - general_transform.o \ - general_write_gfsatm.o \ - gengrid_vars.o \ - genqsat.o \ - genstats_gps.o \ - gesinfo.o \ - get_derivatives.o \ - get_derivatives2.o \ - get_gefs_ensperts_dualres.o \ - get_gefs_for_regional.o \ - get_nmmb_ensperts.o \ - get_semimp_mats.o \ - getcount_bufr.o \ - getprs.o \ - getsiga.o \ - getuv.o \ - getvvel.o \ - gfs_stratosphere.o \ - glbsoi.o \ - grtest.o \ - grdcrd.o \ - gridmod.o \ - gscond_ad.o \ - gsd_terrain_match_surfTobs.o \ - gsdcloudanalysis.o \ - gsdcloudanalysis4gfs.o \ - gsdcloudanalysis4NMMB.o \ - gsd_update_mod.o \ - gsi_4dvar.o \ - gsi_4dcouplermod.o \ - gsi_bundlemod.o \ - gsi_chemguess_mod.o \ - gsi_enscouplermod.o \ - gsi_io.o \ - gsi_metguess_mod.o \ - gsi_nemsio_mod.o \ - gsi_nstcouplermod.o \ - gsi_unformatted.o \ - gsimain.o \ - gsimod.o \ - gsisub.o \ - guess_grids.o \ - half_nmm_grid2.o \ - hilbert_curve.o \ - hybrid_ensemble_isotropic.o \ - hybrid_ensemble_parameters.o \ - inc2guess.o \ - init_jcdfi.o \ - insitu_info.o \ - intall.o \ - intaod.o \ - intcldch.o \ - intco.o \ - intdw.o \ - intgps.o \ - intgust.o \ - inthowv.o \ - intjcmod.o \ - intjo.o \ - intlag.o \ - intlcbas.o \ - intmitm.o \ - intmxtm.o \ - intoz.o \ - intpblh.o \ - intpcp.o \ - intpm2_5.o \ - intpm10.o \ - intpmsl.o \ - intps.o \ - intpw.o \ - intq.o \ - intrad.o \ - intrp_msk.o \ - intrp2a.o \ - intrp3oz.o \ - intrw.o \ - intspd.o \ - intsrw.o \ - intsst.o \ - intt.o \ - inttcamt.o \ - inttcp.o \ - inttd2m.o \ - intuwnd10m.o \ - intvwnd10m.o \ - intvis.o \ - intw.o \ - intwspd10m.o \ - jcmod.o \ - jfunc.o \ - jgrad.o \ - kinds.o \ - lag_fields.o \ - lag_interp.o \ - lag_traj.o \ - lagmod.o \ - lanczos.o \ - logcldch_to_cldch.o \ - loglcbas_to_lcbas.o \ - logvis_to_vis.o \ - looplimits.o \ - m_aeroNode.o \ - m_aerolNode.o \ - m_berror_stats.o \ - m_berror_stats_reg.o \ - m_cldchNode.o \ - m_colvkNode.o \ - m_cvgridLookup.o \ - m_dgeevx.o \ - m_distance.o \ - m_dtime.o \ - m_dwNode.o \ - m_extOzone.o \ - m_find.o \ - m_gpsNode.o \ - m_gpsrhs.o \ - m_gsiBiases.o \ - m_gustNode.o \ - m_howvNode.o \ - m_lagNode.o \ - m_latlonRange.o \ - m_lcbasNode.o \ - m_mitmNode.o \ - m_mxtmNode.o \ - m_o3lNode.o \ - m_obsHeadBundle.o \ - m_obsLList.o \ - m_obsNode.o \ - m_obsNodeTypeManager.o \ - m_obsdiagNode.o \ - m_obsdiags.o \ - m_ozNode.o \ - m_pblhNode.o \ - m_pcpNode.o \ - m_pm10Node.o \ - m_pm2_5Node.o \ - m_pmslNode.o \ - m_psNode.o \ - m_pwNode.o \ - m_qNode.o \ - m_radNode.o \ - m_rerank.o \ - m_rhs.o \ - m_rwNode.o \ - m_sortind.o \ - m_spdNode.o \ - m_srwNode.o \ - m_sstNode.o \ - m_stats.o \ - m_tNode.o \ - m_tcamtNode.o \ - m_tcpNode.o \ - m_td2mNode.o \ - m_tick.o \ - m_uniq.o \ - m_uwnd10mNode.o \ - m_vwnd10mNode.o \ - m_visNode.o \ - m_wNode.o \ - m_wspd10mNode.o \ - mpeu_mpif.o \ - mpeu_util.o \ - mod_nmmb_to_a.o \ - mod_strong.o \ - mod_vtrans.o \ - mod_wrfmass_to_a.o \ - model_ad.o \ - model_tl.o \ - mp_compact_diffs_mod1.o \ - mp_compact_diffs_support.o \ - mpimod.o \ - mpl_allreduce.o \ - mpl_bcast.o \ - native_endianness.o \ - ncepgfs_ghg.o \ - ncepgfs_io.o \ - ncepnems_io.o \ - netcdf_mod.o \ - nlmsas_ad.o \ - normal_rh_to_q.o \ - nstio_module.o \ - Nst_Var_ESMFMod.o \ - obs_ferrscale.o \ - obs_para.o \ - obs_sensitivity.o \ - obserr_allsky_mw.o \ - observer.o \ - obsmod.o \ - omegas_ad.o \ - oneobmod.o \ - ozinfo.o \ - patch2grid_mod.o \ - pcgsoi.o \ - pcgsqrt.o \ - pcp_k.o \ - pcpinfo.o \ - penal.o \ - phil.o \ - phil1.o \ - plib8.o \ - polcarf.o \ - prad_bias.o \ - precond.o \ - precpd_ad.o \ - prewgt.o \ - prewgt_reg.o \ - projmethod_support.o \ - prt_guess.o \ - psichi2uv_reg.o \ - psichi2uvt_reg.o \ - q_diag.o \ - qcmod.o \ - qnewton3.o \ - radiance_mod.o \ - radinfo.o \ - raflib.o \ - rapidrefresh_cldsurf_mod.o \ - rdgrbsst.o \ - read_aerosol.o \ - read_ahi.o \ - read_airs.o \ - read_amsr2.o \ - read_amsre.o \ - read_anowbufr.o \ - read_atms.o \ - read_avhrr.o \ - read_avhrr_navy.o \ - read_bufrtovs.o \ - read_co.o \ - read_cris.o \ - read_diag.o \ - read_files.o \ - read_fl_hdob.o \ - read_gfs_ozone_for_regional.o \ - read_gmi.o \ - read_goesimg.o \ - read_goesimgr_skycover.o \ - read_goesndr.o \ - read_gps.o \ - read_guess.o \ - read_iasi.o \ - read_l2bufr_mod.o \ - read_lag.o \ - read_lidar.o \ - read_Lightning.o \ - read_mitm_mxtm.o \ - read_modsbufr.o \ - read_nasa_larc.o \ - read_nsstbufr.o \ - read_NASA_LaRC_cloud.o \ - read_obs.o \ - read_ozone.o \ - read_pblh.o \ - read_pcp.o \ - read_prepbufr.o \ - read_radar.o \ - read_radarref_mosaic.o \ - read_rapidscat.o \ - read_saphir.o \ - read_satmar.o \ - read_satwnd.o \ - read_seviri.o \ - read_sfcwnd.o \ - read_ssmi.o \ - read_ssmis.o \ - read_superwinds.o \ - read_tcps.o \ - reorg_metar_cloud.o \ - rfdpar.o \ - rsearch.o \ - rtlnmc_version3.o \ - satthin.o \ - set_crtm_aerosolmod.o \ - set_crtm_cloudmod.o \ - setupaod.o \ - setupbend.o \ - setupcldch.o \ - setupco.o \ - setupdw.o \ - setupgust.o \ - setuphowv.o \ - setuplag.o \ - setuplcbas.o \ - setupmitm.o \ - setupmxtm.o \ - setupoz.o \ - setuppblh.o \ - setuppcp.o \ - setuppm2_5.o \ - setuppm10.o \ - setuppmsl.o \ - setupps.o \ - setuppw.o \ - setupq.o \ - setuprad.o \ - setupref.o \ - setuprhsall.o \ - setuprw.o \ - setupspd.o \ - setupsrw.o \ - setupsst.o \ - setupt.o \ - setuptcamt.o \ - setuptcp.o \ - setuptd2m.o \ - setupuwnd10m.o \ - setupvwnd10m.o \ - setupvis.o \ - setupw.o \ - setupwspd10m.o \ - sfc_model.o \ - sfcobsqc.o \ - simpin1.o \ - simpin1_init.o \ - smooth_polcarf.o \ - smoothrf.o \ - smoothwwrf.o \ - smoothzrf.o \ - sqrtmin.o \ - ssmis_spatial_average_mod.o \ - sst_retrieval.o \ - control2model_ad.o \ - ensctl2state_ad.o \ - state_vectors.o \ - statsco.o \ - statsconv.o \ - statsoz.o \ - statspcp.o \ - statsrad.o \ - stop1.o \ - stpaod.o \ - stpcalc.o \ - stpcldch.o \ - stpco.o \ - stpdw.o \ - stpgps.o \ - stpgust.o \ - stpjcmod.o \ - stpjo.o \ - stphowv.o \ - stplcbas.o \ - stpmitm.o \ - stpmxtm.o \ - stpoz.o \ - stppblh.o \ - stppcp.o \ - stppm2_5.o \ - stppm10.o \ - stppmsl.o \ - stpps.o \ - stppw.o \ - stpq.o \ - stprad.o \ - stprw.o \ - stpspd.o \ - stpsrw.o \ - stpsst.o \ - stpt.o \ - stptcamt.o \ - stptcp.o \ - stptd2m.o \ - stpuwnd10m.o \ - stpvwnd10m.o \ - stpvis.o \ - stpw.o \ - stpwspd10m.o \ - strong_bal_correction.o \ - strong_baldiag_inc.o \ - strong_fast_global_mod.o \ - stub_ensmod.o \ - stub_pertmod.o \ - stub_set_crtm_aerosol.o \ - stub_timermod.o \ - sub2fslab_mod.o \ - support_2dvar.o \ - tendsmod.o \ - test_obsens.o \ - tcv_mod.o \ - timermod.o \ - tintrp2a.o \ - tintrp3.o \ - tpause.o \ - tpause_t.o \ - tune_pbl_height.o \ - turbl.o \ - turbl_ad.o \ - turbl_tl.o \ - turblmod.o \ - tv_to_tsen.o \ - unfill_mass_grid2.o \ - unfill_nmm_grid2.o \ - unhalf_nmm_grid2.o \ - update_guess.o \ - wind_fft.o \ - wrf_mass_guess_mod.o \ - wrf_params_mod.o \ - write_all.o \ - write_bkgvars_grid.o \ - xhat_vordivmod.o \ - zrnmi_mod.o - -# list-libs_srcs: -# @ for f in $(OBJS); do echo $$(basename $$f .o).[Ff]90; done diff --git a/src/class_gfs_ensmod.f90 b/src/class_gfs_ensmod.f90 deleted file mode 100644 index a62ae3bd9..000000000 --- a/src/class_gfs_ensmod.f90 +++ /dev/null @@ -1,52 +0,0 @@ -module abstract_get_gfs_ensmod_mod - type, abstract :: abstract_get_gfs_ensmod_class - contains - procedure(get_user_ens_), deferred, pass(this) :: get_user_ens_ - procedure(put_gsi_ens_), deferred, pass(this) :: put_gsi_ens_ - procedure(non_gaussian_ens_grid_), deferred, pass(this) :: non_gaussian_ens_grid_ - end type abstract_get_gfs_ensmod_class - - abstract interface - subroutine get_user_ens_(this,grd,ntindex,atm_bundle,iret) - use kinds, only: i_kind - use general_sub2grid_mod, only: sub2grid_info - use gsi_bundlemod, only: gsi_bundle - import abstract_get_gfs_ensmod_class - implicit none - class(abstract_get_gfs_ensmod_class), intent(inout) :: this - type(sub2grid_info), intent(in ) :: grd - integer(i_kind), intent(in ) :: ntindex - type(gsi_bundle), intent(inout) :: atm_bundle(:) - integer(i_kind), intent( out) :: iret - end subroutine get_user_ens_ - end interface - - abstract interface - subroutine put_gsi_ens_(this,grd,member,ntindex,atm_bundle,iret) - use kinds, only: i_kind - use gsi_bundlemod, only: gsi_bundle - use general_sub2grid_mod, only: sub2grid_info - import abstract_get_gfs_ensmod_class - implicit none - class(abstract_get_gfs_ensmod_class), intent(inout) :: this - type(sub2grid_info), intent(in ) :: grd - integer(i_kind), intent(in ) :: member - integer(i_kind), intent(in ) :: ntindex - type(gsi_bundle), intent(inout) :: atm_bundle - integer(i_kind), intent( out) :: iret - - end subroutine put_gsi_ens_ - end interface - - abstract interface - subroutine non_gaussian_ens_grid_(this,elats,elons) - use kinds, only: r_kind - use hybrid_ensemble_parameters, only: sp_ens - import abstract_get_gfs_ensmod_class - implicit none - class(abstract_get_gfs_ensmod_class), intent(inout) :: this - real(r_kind), intent(out) :: elats(size(sp_ens%rlats)),elons(size(sp_ens%rlons)) - end subroutine non_gaussian_ens_grid_ - end interface - -end module abstract_get_gfs_ensmod_mod diff --git a/src/constants.f90 b/src/constants.f90 deleted file mode 100644 index a8df756ae..000000000 --- a/src/constants.f90 +++ /dev/null @@ -1,429 +0,0 @@ -module constants -!$$$ module documentation block -! . . . . -! module: constants -! prgmmr: treadon org: np23 date: 2003-09-25 -! -! abstract: This module contains the definition of various constants -! used in the gsi code -! -! program history log: -! 2003-09-25 treadon - original code -! 2004-03-02 treadon - allow global and regional constants to differ -! 2004-06-16 treadon - update documentation -! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind -! and tiny_single -! 2004-11-16 treadon - add huge_single, huge_r_kind parameters -! 2005-08-24 derber - move cg_term to constants from qcmod -! 2006-03-07 treadon - add rd_over_cp_mass -! 2006-05-18 treadon - add huge_i_kind -! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) -! 2006-07-28 derber - add r1000 -! 2007-03-20 rancic - add r3600 -! 2009-02-05 cucurull - modify refractive indexes for gpsro data -! 2010-08-25 cucurull - add constants to compute compressibility factor -! - add option to use Rueger/Bevis refractive index coeffs -! 2010-12-20 pagowski - add max_varname_length=12 -! 2010-04-01 li - add maximum diurnal thermocline thickness -! 2011-10-27 Huang - add i_missing and r_missing to detect missing values -! 2011-11-01 eliu - add minimum value for cloud water mixing ratio -! 2012-03-07 todling - define lower bound for trace-gases (arbitrary unit as long as small) -! -! Subroutines Included: -! sub init_constants_derived - compute derived constants -! sub init_constants - set regional/global constants -! sub gps_constants - set Rueger/Bevis refractive index coefficients -! -! Variable Definitions: -! see below -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - - use kinds, only: r_single,r_kind,i_kind,r_quad,i_long - implicit none - -! set default as private - private -! set subroutines as public - public :: init_constants_derived - public :: init_constants - public :: gps_constants -! set passed variables to public - public :: one,two,half,zero,deg2rad,pi,three,quarter,one_tenth - public :: rad2deg,zero_quad,r3600,r1000,r60inv,five,four,rd_over_cp,grav - public :: rd,rv,rozcon,rearth_equator,zero_single,tiny_r_kind,tiny_single,ten - public :: omega,rcp,rearth,fv,h300,cp,cg_term,tpwcon,xb,ttp,psatk,xa,tmix - public :: xai,xbi,psat,eps,omeps,wgtlim,one_quad,two_quad,epsq,climit,epsm1,hvap - public :: hsub,cclimit,el2orc,elocp,h1000,cpr,pcpeff0,pcpeff2,delta,pcpeff1 - public :: factor1,c0,pcpeff3,factor2,dx_inv,dx_min,rhcbot,rhctop,hfus,ke2 - public :: rrow,cmr,cws,r60,huge_i_kind,huge_r_kind,t0c,rd_over_cp_mass - public :: somigliana,grav_equator,grav_ratio,flattening,semi_major_axis - public :: n_b,n_a,eccentricity,huge_single,constoz,g_over_rd,amsua_clw_d2 - public :: amsua_clw_d1,n_c,rd_over_g,zero_ilong - public :: r10,r100,sqrt_tiny_r_kind,r2000,r4000 - public :: r0_01,r0_02,r0_03,r0_04,r0_05,r400,r2400 - public :: cpf_a0, cpf_a1, cpf_a2, cpf_b0, cpf_b1, cpf_c0, cpf_c1, cpf_d, cpf_e - public :: psv_a, psv_b, psv_c, psv_d - public :: ef_alpha, ef_beta, ef_gamma - public :: max_varname_length - public :: z_w_max,tfrozen - public :: qmin,qcmin,tgmin - public :: i_missing, r_missing - -! Declare derived constants - integer(i_kind):: huge_i_kind - integer(i_kind), parameter :: max_varname_length=32 - real(r_single):: tiny_single, huge_single - real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g - real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 - real(r_kind):: factor1, huge_r_kind, tiny_r_kind, deg2rad, pi, rad2deg, cg_term - real(r_kind):: eccentricity_linear, cv, rv, rd_over_cp_mass, cliq, rd, cp_mass - real(r_kind):: eccentricity, grav, rearth, r60inv - real(r_kind):: sqrt_tiny_r_kind - real(r_kind):: n_a, n_b, n_c - -! Define constants common to global and regional applications - real(r_kind),parameter:: rearth_equator= 6.37813662e6_r_kind ! equatorial earth radius (m) - real(r_kind),parameter:: omega = 7.2921e-5_r_kind ! angular velocity of earth (1/s) - real(r_kind),parameter:: cp = 1.0046e+3_r_kind ! specific heat of air @pressure (J/kg/K) - real(r_kind),parameter:: cvap = 1.8460e+3_r_kind ! specific heat of h2o vapor (J/kg/K) - real(r_kind),parameter:: csol = 2.1060e+3_r_kind ! specific heat of solid h2o (ice)(J/kg/K) - real(r_kind),parameter:: hvap = 2.5000e+6_r_kind ! latent heat of h2o condensation (J/kg) - real(r_kind),parameter:: hfus = 3.3358e+5_r_kind ! latent heat of h2o fusion (J/kg) - real(r_kind),parameter:: psat = 6.1078e+2_r_kind ! pressure at h2o triple point (Pa) - real(r_kind),parameter:: t0c = 2.7315e+2_r_kind ! temperature at zero celsius (K) - real(r_kind),parameter:: ttp = 2.7316e+2_r_kind ! temperature at h2o triple point (K) - real(r_kind),parameter:: jcal = 4.1855e+0_r_kind ! joules per calorie () - real(r_kind),parameter:: stndrd_atmos_ps = 1013.25e2_r_kind ! 1976 US standard atmosphere ps (Pa) - -! Numeric constants - - integer(i_long),parameter:: zero_ilong = 0_i_long - - real(r_single),parameter:: zero_single= 0.0_r_single - - real(r_kind),parameter:: zero = 0.0_r_kind - real(r_kind),parameter:: r0_01 = 0.01_r_kind - real(r_kind),parameter:: r0_02 = 0.02_r_kind - real(r_kind),parameter:: r0_03 = 0.03_r_kind - real(r_kind),parameter:: r0_04 = 0.04_r_kind - real(r_kind),parameter:: r0_05 = 0.05_r_kind - real(r_kind),parameter:: one_tenth = 0.10_r_kind - real(r_kind),parameter:: quarter = 0.25_r_kind - real(r_kind),parameter:: one = 1.0_r_kind - real(r_kind),parameter:: two = 2.0_r_kind - real(r_kind),parameter:: three = 3.0_r_kind - real(r_kind),parameter:: four = 4.0_r_kind - real(r_kind),parameter:: five = 5.0_r_kind - real(r_kind),parameter:: ten = 10.0_r_kind - real(r_kind),parameter:: r10 = 10.0_r_kind - real(r_kind),parameter:: r60 = 60._r_kind - real(r_kind),parameter:: r100 = 100.0_r_kind - real(r_kind),parameter:: r400 = 400.0_r_kind - real(r_kind),parameter:: r1000 = 1000.0_r_kind - real(r_kind),parameter:: r2000 = 2000.0_r_kind - real(r_kind),parameter:: r2400 = 2400.0_r_kind - real(r_kind),parameter:: r4000 = 4000.0_r_kind - real(r_kind),parameter:: r3600 = 3600.0_r_kind - - real(r_kind),parameter:: z_w_max = 30.0_r_kind ! maximum diurnal thermocline thickness - real(r_kind),parameter:: tfrozen = 271.2_r_kind ! sea water frozen point temperature - - real(r_quad),parameter:: zero_quad = 0.0_r_quad - real(r_quad),parameter:: one_quad = 1.0_r_quad - real(r_quad),parameter:: two_quad = 2.0_r_quad - -! Constants for compressibility factor (Davis et al 1992) - real(r_kind),parameter:: cpf_a0 = 1.58123e-6_r_kind ! K/Pa - real(r_kind),parameter:: cpf_a1 = -2.9331e-8_r_kind ! 1/Pa - real(r_kind),parameter:: cpf_a2 = 1.1043e-10_r_kind ! 1/K 1/Pa - real(r_kind),parameter:: cpf_b0 = 5.707e-6_r_kind ! K/Pa - real(r_kind),parameter:: cpf_b1 = -2.051e-8_r_kind ! 1/Pa - real(r_kind),parameter:: cpf_c0 = 1.9898e-4_r_kind ! K/Pa - real(r_kind),parameter:: cpf_c1 = -2.376e-6_r_kind ! 1/Pa - real(r_kind),parameter:: cpf_d = 1.83e-11_r_kind ! K2/Pa2 - real(r_kind),parameter:: cpf_e = -0.765e-8_r_kind ! K2/Pa2 - -! Constants for vapor pressure at saturation - real(r_kind),parameter:: psv_a = 1.2378847e-5_r_kind ! (1/K2) - real(r_kind),parameter:: psv_b = -1.9121316e-2_r_kind ! (1/K) - real(r_kind),parameter:: psv_c = 33.93711047_r_kind ! - real(r_kind),parameter:: psv_d = -6.3431645e+3_r_kind ! (K) - -! Constants for enhancement factor to calculating the mole fraction of water vapor - real(r_kind),parameter:: ef_alpha = 1.00062_r_kind ! - real(r_kind),parameter:: ef_beta = 3.14e-8_r_kind ! (1/Pa) - real(r_kind),parameter:: ef_gamma = 5.6e-7_r_kind ! (1/K2) - -! Parameters below from WGS-84 model software inside GPS receivers. - real(r_kind),parameter:: semi_major_axis = 6378.1370e3_r_kind ! (m) - real(r_kind),parameter:: semi_minor_axis = 6356.7523142e3_r_kind ! (m) - real(r_kind),parameter:: grav_polar = 9.8321849378_r_kind ! (m/s2) - real(r_kind),parameter:: grav_equator = 9.7803253359_r_kind ! (m/s2) - real(r_kind),parameter:: earth_omega = 7.292115e-5_r_kind ! (rad/s) - real(r_kind),parameter:: grav_constant = 3.986004418e14_r_kind ! (m3/s2) - -! Derived geophysical constants - real(r_kind),parameter:: flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis - real(r_kind),parameter:: somigliana = & - (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one - real(r_kind),parameter:: grav_ratio = (earth_omega*earth_omega * & - semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant - -! Derived thermodynamic constants - real(r_kind),parameter:: dldti = cvap-csol - real(r_kind),parameter:: hsub = hvap+hfus - real(r_kind),parameter:: psatk = psat*0.001_r_kind - real(r_kind),parameter:: tmix = ttp-20._r_kind - real(r_kind),parameter:: elocp = hvap/cp - real(r_kind),parameter:: rcp = one/cp - -! Constants used in GFS moist physics - real(r_kind),parameter:: h300 = 300._r_kind - real(r_kind),parameter:: half = 0.5_r_kind - real(r_kind),parameter:: cclimit = 0.001_r_kind - real(r_kind),parameter:: climit = 1.e-20_r_kind - real(r_kind),parameter:: epsq = 2.e-12_r_kind - real(r_kind),parameter:: h1000 = r1000 - real(r_kind),parameter:: rhcbot=0.85_r_kind - real(r_kind),parameter:: rhctop=0.85_r_kind - real(r_kind),parameter:: dx_max=-8.8818363_r_kind - real(r_kind),parameter:: dx_min=-5.2574954_r_kind - real(r_kind),parameter:: dx_inv=one/(dx_max-dx_min) - real(r_kind),parameter:: c0=0.002_r_kind - real(r_kind),parameter:: delta=0.6077338_r_kind - real(r_kind),parameter:: pcpeff0=1.591_r_kind - real(r_kind),parameter:: pcpeff1=-0.639_r_kind - real(r_kind),parameter:: pcpeff2=0.0953_r_kind - real(r_kind),parameter:: pcpeff3=-0.00496_r_kind - real(r_kind),parameter:: cmr = one/0.0003_r_kind - real(r_kind),parameter:: cws = 0.025_r_kind - real(r_kind),parameter:: ke2 = 0.00002_r_kind - real(r_kind),parameter:: row = r1000 - real(r_kind),parameter:: rrow = one/row -! real(r_kind),parameter:: qmin = 1.e-7_r_kind !lower bound on ges_q - -! Constant used to process ozone - real(r_kind),parameter:: constoz = 604229.0_r_kind - -! Constants used in cloud liquid water correction for AMSU-A -! brightness temperatures - real(r_kind),parameter:: amsua_clw_d1 = 0.754_r_kind - real(r_kind),parameter:: amsua_clw_d2 = -2.265_r_kind - -! Constants used for variational qc - real(r_kind),parameter:: wgtlim = quarter ! Cutoff weight for concluding that obs has been - ! rejected by nonlinear qc. This limit is arbitrary - ! and DOES NOT affect nonlinear qc. It only affects - ! the printout which "counts" the number of obs that - ! "fail" nonlinear qc. Observations counted as failing - ! nonlinear qc are still assimilated. Their weight - ! relative to other observations is reduced. Changing - ! wgtlim does not alter the analysis, only - ! the nonlinear qc data "count" - -! Minimum values for water vapor, cloud water mixing ratio, and trace gases - real(r_kind),parameter:: qmin = 1.e-07_r_kind ! lower bound on ges_q - real(r_kind),parameter:: qcmin = 0.0_r_kind ! lower bound on ges_cw - real(r_kind),parameter:: tgmin = 1.e-15_r_kind ! lower bound on trace gases - -! Constant used to detect missing input value - integer(i_kind),parameter:: i_missing=-9999 - integer(r_kind),parameter:: r_missing=-9999._r_kind - -contains - - subroutine init_constants_derived -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants_derived set derived constants -! prgmmr: treadon org: np23 date: 2004-12-02 -! ! abstract: This routine sets derived constants -! -! program history log: -! 2004-12-02 treadon -! 2005-03-03 treadon - add implicit none -! 2008-06-04 safford - rm unused vars -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - -! Trigonometric constants - pi = acos(-one) - deg2rad = pi/180.0_r_kind - rad2deg = one/deg2rad - cg_term = (sqrt(two*pi))/two ! constant for variational qc - tiny_r_kind = tiny(zero) - sqrt_tiny_r_kind = r10*sqrt(tiny_r_kind) - huge_r_kind = huge(zero) - tiny_single = tiny(zero_single) - huge_single = huge(zero_single) - huge_i_kind = huge(0) - r60inv=one/r60 - -! Geophysical parameters used in conversion of geopotential to -! geometric height - eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) - eccentricity = eccentricity_linear / semi_major_axis - - return - end subroutine init_constants_derived - - subroutine init_constants(regional) -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants set regional or global constants -! prgmmr: treadon org: np23 date: 2004-03-02 -! -! abstract: This routine sets constants specific to regional or global -! applications of the gsi -! -! program history log: -! 2004-03-02 treadon -! 2004-06-16 treadon, documentation -! 2004-10-28 treadon - use intrinsic TINY function to set value -! for smallest machine representable positive -! number -! 2004-12-03 treadon - move derived constants to init_constants_derived -! 2005-03-03 treadon - add implicit none -! -! input argument list: -! regional - if .true., set regional gsi constants; -! otherwise (.false.), use global constants -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - - logical,intent(in ) :: regional - - real(r_kind) reradius,g,r_d,r_v,cliq_wrf - -! Define regional constants here - if (regional) then - -! Name given to WRF constants - reradius = one/6370.e03_r_kind - g = 9.81_r_kind - r_d = 287.04_r_kind - r_v = 461.6_r_kind - cliq_wrf = 4190.0_r_kind - cp_mass = 1004.67_r_kind - -! Transfer WRF constants into unified GSI constants - rearth = one/reradius - grav = g - rd = r_d - rv = r_v - cv = cp-r_d - cliq = cliq_wrf - rd_over_cp_mass = rd / cp_mass - -! Define global constants here - else - rearth = 6.3712e+6_r_kind - grav = 9.80665e+0_r_kind - rd = 2.8705e+2_r_kind - rv = 4.6150e+2_r_kind - cv = 7.1760e+2_r_kind - cliq = 4.1855e+3_r_kind - cp_mass= zero - rd_over_cp_mass = zero - endif - - -! Now define derived constants which depend on constants -! which differ between global and regional applications. - -! Constants related to ozone assimilation - ozcon = grav*21.4e-9_r_kind - rozcon= one/ozcon - -! Constant used in vertical integral for precipitable water - tpwcon = 100.0_r_kind/grav - -! Derived atmospheric constants - fv = rv/rd-one ! used in virtual temperature equation - dldt = cvap-cliq - xa = -(dldt/rv) - xai = -(dldti/rv) - xb = xa+hvap/(rv*ttp) - xbi = xai+hsub/(rv*ttp) - eps = rd/rv - epsm1 = rd/rv-one - omeps = one-eps - factor1 = (cvap-cliq)/rv - factor2 = hvap/rv-factor1*t0c - cpr = cp*rd - el2orc = hvap*hvap/(rv*cp) - rd_over_g = rd/grav - rd_over_cp = rd/cp - g_over_rd = grav/rd - - return - end subroutine init_constants - - subroutine gps_constants(use_compress) -!$$$ subprogram documentation block -! . . . . -! subprogram: gps_constants set Bevis or Rueger refractive index coeff -! prgmmr: cucurull org: np23 date: 2010-08-25 -! -! abstract: This routine sets constants for the refractivity equation. GSI uses Bevis -! coefficients when the compressibility factors option is turned off -! and uses Rueger coefficients otherwise. -! -! program history log: -! 2010-08-25 cucurull -! 2010-08-25 cucurull, documentation -! -! input argument list: -! compress - if .true., set Rueger coefficients; -! otherwise (.false.), use Bevis coefficients -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - - logical,intent(in ) :: use_compress - -! Define refractive index coefficients here - if (use_compress) then - - ! Constants for gpsro data (Rueger 2002) - n_a = 77.6890_r_kind ! K/mb - n_b = 3.75463e+5_r_kind ! K^2/mb - n_c = 71.2952_r_kind ! K/mb - else - ! Constants for gpsro data (Bevis et al 1994) - n_a = 77.60_r_kind ! K/mb - n_b = 3.739e+5_r_kind ! K^2/mb - n_c = 70.4_r_kind ! K/mb - endif - - return - end subroutine gps_constants - -end module constants diff --git a/src/correlated_obsmod.F90 b/src/correlated_obsmod.F90 deleted file mode 100644 index 79b48cfdc..000000000 --- a/src/correlated_obsmod.F90 +++ /dev/null @@ -1,1451 +0,0 @@ -!BOI - -! !TITLE: Correlated\_ObsMod: Inter-channel Observation Correlation Module - -! !AUTHORS: Ricardo Todling - -! !AFFILIATION: Global Modeling and Assimilation Office, NASA/GSFC, Greenbelt, MD 20771 - -! !DATE: 13 April 2014 - -! !INTRODUCTION: Overview -#ifdef __PROTEX__ - -This module introduces the ability for GSI to account for inter-channel -correlated errors for radiance observations. It assumes an offline estimate of -an observation error covariance for a given instrument is available. - -At GMAO, the offline estimation of the error covariances required by this module -is performed by a FORTRAN program that reads the GSI-diag files and performs -statistics on the observation-minus-background and observation-minus-analysis -residuals, following the so-called Desroziers approach (e.g., Desroziers et al. -2005; Q. J. R. Meteorol. Soc., 131, 3385-3396). - -At NCEP, the offline estimation of the error covariances can be computed -by the cov_calc module, located in util/Correlated_Obs. This module is also -based on the Desroziers method. - -This module defines the so-called Obs\_Error\_Cov. - -As Met\_Guess and other like-modules, the idea is for this module to define nearly -opaque object. However, so far, we have had no need to add inquire-like functions - that -is, no code outside this code needs to what what is inside GSI\_Obs\_Error\_Cov. -So far, only very general `methods'' are made public from this module, these -being, - -\begin{verbatim} -public :: corr_ob_initialize -public :: corr_ob_amiset -public :: corr_ob_scale_jac -public :: corr_ob_finalize -\end{verbatim} - -and never the variables themselves; the only exception being the GSI\_MetGuess\_Bundle itself -(until it is no longer treated as a common-block). Some of the public methods above are -overloaded and all have internal interfaces (name of which appears in the index of this protex -document. It should be a rule here that any new routine to be made public should -have a declared interface procedure. - -\begin{center} -\fbox{Obs\_Error\_Cov is defined via the {\it correlated\_observations} table in a resource file} -\end{center} - -\underline{Defining Observation Error Covariance Models} is done via the table {\it correlated\_observations}, -usually embedded in the {\it anavinfo} file. An example of such table follows: -\begin{verbatim} -correlated_observations:: -! isis method kreq type cov_file - airs281_aqua 1 60. ice airs_rcov.bin - airs281_aqua 1 60. land airs_rcov.bin - airs281_aqua 1 60. sea airs_rcov.bin - airs281_aqua 1 60. snow airs_rcov.bin - airs281_aqua 1 60. mixed airs_rcov.bin -# cris_npp 1 -99. snow cris_rcov.bin -# cris_npp 1 -99. land cris_rcov.bin -# cris_npp 1 -99. sea cris_rcov.bin - iasi_metop-a 2 0.12 snow iasi_sea_rcov.bin - iasi_metop-a 2 0.22 land iasi_land_rcov.bin - iasi_metop-a 2 0.05 sea iasi_sea_rcov.bin - iasi_metop-a 2 0.12 ice iasi_sea_rcov.bin - iasi_metop-a 2 0.12 mixed iasi_sea_rcov.bin -# ssmis_f17 1 -99. mixed ssmis_rcov.bin -# ssmis_f17 1 -99. land ssmis_rcov.bin -# ssmis_f17 1 -99. sea ssmis_rcov.bin - -:: -\end{verbatim} -Notice that the covariance can be supplied for all five surface types, -namely, ice, snow, mixed, land, and sea. However, they can be made the same, by simply -pointing the different types to the same file. In the example above, only AIRS and -IASI from Metop-A are being specially handled by this module. In the case of -AIRS, no distinction is made among the different types of surfaces, whereas -in the case of IASI, a distinction is made between land and sea, with everything -else being treated as sea. It is not necessary to specify a covariance file for -each surface type. - -The instrument name is the same as it would be in the satinfo file. - -As usual, this table follows INPAK/ESMF convention, begining with a name -(correlated\_observations), followed by double colons (::) to open the table and -ending with double colons. Any line starting with an exclamation mark or a pound sign -is taken as a comment. - -The current {\it correlated\_observations} table has four columns defined as follows: - -\begin{verbatim} -Column 1: isis - refers to instrument/platform type (follows, typical GSI nomenclature) -Column 2: method - specify different possibilities for handling the corresponding - cov(R) at present: - <0 - reproduces GSI to within roundoff (for testing only) - 0 - diag of estimated R only - 1 - correlations from estimated R with variances as established by GSI - 2 - as (1), but for full R covariance - 3 - diag of estimate R used as scaling factor to internally-defined errors -Column 3: kreq - level of required condition for the corresponding cov(R) - at present: - if<0 and method=0, 1 or 3 does not recondition matrix - if>0 and method=1 recondition the (correlation) matrix following - the 2nd method in Weston et al. (2014; - Q. J. R. Meteorol. Soc., DOI: 10.1002/qj.2306) - Note that the resulting correlation matrix has - condition number equal to approximatetly twice kreq. - if>0 and method=0 or 3 recondition the (covariance) matrix using Westons 2nd method - if method=2 recondition the covariance matrix by inflating the - diagional so that R_{r,r}=(sqrt{R_{r,r}+kreq)^2 - Note that kreq should be specified as 0NULL() ! indexes of active channels - real(r_kind), pointer :: R(:,:) =>NULL() ! nch_active x nch_active - real(r_kind), pointer :: Revals(:) =>NULL() ! eigenvalues of R - real(r_kind), pointer :: Revecs(:,:)=>NULL() ! eigenvectors of R -end type - -! !PUBLIC TYPES: - -type(ObsErrorCov),pointer :: GSI_BundleErrorCov(:) - -! strictly internal quantities -character(len=*),parameter :: myname='correlated_obsmod' -logical :: initialized_=.false. -integer(i_kind),parameter :: methods_avail(5)=(/-1, & ! do nothing - 0, & ! use dianonal of estimate(R) - 1, & ! use full est(R), but decompose once for all - 2, & ! use full est(R), but re-decomp at each profile - 3/) ! use diag est(R), as scaling factor to GSI(R) -contains - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ini_ --- Initialize info about correlated obs (read resource table) -! -! !INTERFACE: -! -subroutine ini_ (iamroot) -! !USES: -use mpeu_util, only: die -implicit none -! !INPUT PARAMETERS: - logical,optional,intent(in) :: iamroot -! !DESCRIPTION: Define parameters and setting for handling correlated -! observation errors via resouce file reading. -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC -character(len=*),parameter:: rcname='anavinfo' ! filename should have extension -character(len=*),parameter:: tbname='correlated_observations::' -integer(i_kind) luin,ii,ntot,nrows,method -character(len=MAXSTR),allocatable,dimension(:):: utable -character(len=20) instrument, mask -character(len=30) filename -real(r_single) kreq4 -real(r_kind) kreq -character(len=*),parameter::myname_=myname//'*ini_' - -if(initialized_) return - -iamroot_=mype==0 -if(present(iamroot)) iamroot_=iamroot - -! load file -luin=luavail() -open(luin,file=rcname,form='formatted') - -! Scan file for desired table first -! and get size of table -call gettablesize(tbname,luin,ntot,nrows) -if(nrows==0) then - close(luin) - return -endif -ninstr=nrows - -! Get contents of table -allocate(utable(ninstr),instruments(ninstr),idnames(ninstr)) -call gettable(tbname,luin,ntot,ninstr,utable) - -! release file unit -close(luin) - -allocate(GSI_BundleErrorCov(ninstr)) - -! Retrieve each token of interest from table and define -! variables participating in state vector - -! Count variables first -if(iamroot_) write(6,*) myname_,': Correlated-Obs for the following instruments' -do ii=1,ninstr - read(utable(ii),*) instrument, method, kreq4, mask, filename ! if adding col to table leave fname as last - instruments(ii) = trim(instrument) - idnames(ii) = trim(instrument)//':'//trim(mask) - kreq=kreq4 - if(iamroot_) then - write(6,'(1x,2(a,1x),i4,1x,f7.2,1x,a)') trim(instrument), trim(mask), method, kreq4, trim(filename) - endif -! check method validity - if(ALL(methods_avail/=method)) then - call die(myname_,' invalid choice of method, aborting') - endif - call set_(trim(instrument),trim(filename),mask,method,kreq,GSI_BundleErrorCov(ii)) -enddo - -! release table -deallocate(utable) - -end subroutine ini_ -!EOC - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: set_ --- set error covariances for different instruments -! -! !INTERFACE: -! -subroutine set_(instrument,fname,mask,method,kreq,ErrorCov) -implicit none - -! !INPUT PARAMETERS: - -character(len=*),intent(in) :: instrument ! name of instrument -character(len=*),intent(in) :: fname ! filename holding cov(R) -character(len=*),intent(in) :: mask ! land/sea/etc mask -integer,intent(in):: method ! method to apply when using this cov(R) -real(r_kind),intent(in) :: kreq ! conditioning factor for cov(R) -type(ObsErrorCov) :: ErrorCov ! cov(R) for this instrument - -! !DESCRIPTION: Given basic information on the instrument type -! this routine reads an available estimate -! of the corresponding fully-correlated error -! covariance and fills the FORTRAN type defined -! as ObsErrorCov. -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! 2014-08-06 todling platform-specific correlated obs handle -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC - -character(len=*),parameter :: myname_=myname//'*set' -integer(i_kind) nch_active,lu,ii,ioflag,iprec,nctot - -real(r_single),allocatable, dimension(:,:) :: readR4 ! nch_active x nch_active x ninstruments -real(r_double),allocatable, dimension(:,:) :: readR8 ! nch_active x nch_active x ninstruments -real(r_kind),allocatable, dimension(:) :: diag - logical print_verbose - - print_verbose=.false. - if(verbose .and. iamroot_)print_verbose=.true. - ErrorCov%instrument = trim(instrument) - ErrorCov%mask = trim(mask) - ErrorCov%name = trim(instrument)//':'//trim(mask) - ErrorCov%method = method - ErrorCov%kreq = kreq - - lu = luavail() - open(lu,file=trim(fname),convert='little_endian',form='unformatted') - read(lu,IOSTAT=ioflag) nch_active, nctot, iprec - if(ioflag/=0) call die(myname_,' failed to read nch from '//trim(fname)) - ErrorCov%nch_active = nch_active - ErrorCov%nctot = nctot - - call create_(nch_active,ErrorCov) - -! Read GSI-like channel numbers used in estimating R for this instrument - read(lu,IOSTAT=ioflag) ErrorCov%indxR - if(ioflag/=0) call die(myname_,' failed to read indx from '//trim(fname)) - -! Read estimate of observation error covariance - if(iprec==4) then - allocate(readR4(nch_active,nch_active)) - read(lu,IOSTAT=ioflag) readR4 - if(ioflag/=0) call die(myname_,' failed to read R from '//trim(fname)) - ErrorCov%R = readR4 - deallocate(readR4) - endif - if(iprec==8) then - allocate(readR8(nch_active,nch_active)) - read(lu,IOSTAT=ioflag) readR8 - if(ioflag/=0) call die(myname_,' failed to read R from '//trim(fname)) - ErrorCov%R = readR8 - deallocate(readR8) - endif - -! Done reading file - close(lu) - -! If method<0 there is really nothing else to do -! ---------------------------------------------- - if (method<0) then - initialized_=.true. - return - endif - if (print_verbose) then - allocate(diag(nch_active)) - do ii=1,nch_active - diag(ii)=ErrorCov%R(ii,ii) - enddo - write(6,'(2a)') 'Rcov(stdev) for instrument: ', trim(ErrorCov%name) - write(6,'(9(1x,es10.3))') sqrt(diag) - write(6,'(3a)') 'Channels used in estimating Rcov(', trim(ErrorCov%name), ')' - write(6,'(12(1x,i5))') ErrorCov%indxR - deallocate(diag) - endif - -! Now decompose R - call solver_(ErrorCov) - - if (print_verbose .and. ErrorCov%method>=0) then - allocate(diag(nch_active)) - do ii=1,nch_active - diag(ii)=ErrorCov%R(ii,ii) - enddo - write(6,'(3a)') 'Rcov(stdev) for instrument: ', trim(ErrorCov%name), ' recond' - write(6,'(9(1x,es10.3))') sqrt(diag) - deallocate(diag) - endif - - initialized_=.true. -end subroutine set_ -!EOC - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: create_ --- creates type to hold observation error covariance -! -! !INTERFACE: -! -subroutine create_ (nch,ErrorCov) -implicit none -! !INPUT PARAMETERS: -integer(i_kind),intent(in) :: nch -! !INPUT/OUTPUT PARAMETERS: -type(ObsErrorCov) :: ErrorCov -! !DESCRIPTION: Allocates space for FORTRAN type hold observation error -! covariance and required information. -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC - allocate(ErrorCov%R(nch,nch)) - allocate(ErrorCov%indxR(nch)) - allocate(ErrorCov%Revals(nch),ErrorCov%Revecs(nch,nch)) -end subroutine create_ -!EOC - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: destroy_ --- destroy type holding observation error covariance -! -! !INTERFACE: -! -subroutine destroy_ (ErrorCov) -implicit none -! !INPUT/OUTPUT PARAMETERS: -type(ObsErrorCov) :: ErrorCov -! !DESCRIPTION: Deallocates space held for observation error covariance. -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC - deallocate(ErrorCov%Revals,ErrorCov%Revecs) - deallocate(ErrorCov%indxR) - deallocate(ErrorCov%R) -end subroutine destroy_ -!EOC - - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: solver_ --- entry-point to the decomposition of cov(R) -! -! !INTERFACE: -! - -subroutine solver_(ErrorCov) -implicit none -! !INPUT/OUTPUT PARAMETERS: -type(ObsErrorCov) :: ErrorCov - -! !DESCRIPTION: This routine is the entry point to the eigen-decomposition -! of the obs error covariance. Depending on the method chosen -! by the user, it might call the proper routines to recondition -! the offline estimate of cov(R). -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! 2015-08-18 W. Gu, Switich the reconditioning method from adding a constant value -! to each eigenvalue to adding a constant value in standard deviation to -! each diagnoal element. -! 2015-08-18 W. Gu Bring the modifications of obs errors done in QC to correlated obs errors -! -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC -character(len=*), parameter :: myname_=myname//'*solver_' -real(r_kind) lambda_max,lambda_min,lambda_inc -integer(i_kind) ii,jj,ndim -logical adjspec -real(r_kind),allocatable,dimension(:):: invstd - -ndim = size(ErrorCov%R,1) - -! This extracts the diagonal of R (error variances), setting the -! eigenvalues as such and the eigenvectors as the unit vectors -! This is to allow using the estimated error variances, but -! but still pretend the covariance is diagnoal - no correlations. -! This is largely for testing consistency of the implementation. -if ( ErrorCov%method==0 .or. ErrorCov%method==3 ) then - ErrorCov%Revecs = zero - do ii=1,ndim - ErrorCov%Revals(ii) = ErrorCov%R(ii,ii) - ErrorCov%Revecs(ii,ii) = one - enddo - call westonEtAl_spectrum_boost_(adjspec) - if (adjspec) then - call rebuild_rcov_ - endif -endif ! method=0 - -! This takes only corr(Re) and -! any reconditioning is of correlation matrix -if ( ErrorCov%method==1 ) then - ! reduce R to correlation matrix - allocate(invstd(ndim)) - do jj=1,ndim - invstd(jj) = one/sqrt(ErrorCov%R(jj,jj)) - enddo - do jj=1,ndim - do ii=1,ndim - ErrorCov%R(ii,jj) = invstd(ii)*ErrorCov%R(ii,jj)*invstd(jj) - enddo - enddo - deallocate(invstd) - ErrorCov%Revecs=ErrorCov%R - call decompose_(trim(ErrorCov%name),ErrorCov%Revals,ErrorCov%Revecs,ndim,.true.) - call westonEtAl_spectrum_boost_(adjspec) - if (adjspec) then - call rebuild_rcov_ - allocate(invstd(ndim)) - do jj=1,ndim - invstd(jj) = one/sqrt(ErrorCov%R(jj,jj)) - enddo - do jj=1,ndim - do ii=1,ndim - ErrorCov%R(ii,jj) = invstd(ii)*ErrorCov%R(ii,jj)*invstd(jj) - enddo - enddo - deallocate(invstd) - endif -endif ! method=1 - -! This does the actual full eigendecomposition of the R matrix -! Here, recondioning is of covariance matrix -if ( ErrorCov%method==2 ) then - ErrorCov%Revecs=ErrorCov%R - call decompose_(trim(ErrorCov%name),ErrorCov%Revals,ErrorCov%Revecs,ndim,.true.) -!wgu - do jj=1,ndim - ErrorCov%R(jj,jj)=ErrorCov%R(jj,jj)+2*sqrt(ErrorCov%R(jj,jj))*ErrorCov%kreq+ErrorCov%kreq*ErrorCov%kreq - enddo -!wgu - ErrorCov%Revecs=ErrorCov%R - call decompose_(trim(ErrorCov%name),ErrorCov%Revals,ErrorCov%Revecs,ndim,.true.) -!wgu -! call westonEtAl_spectrum_boost_(adjspec) -! if (adjspec) then -! call rebuild_rcov_ -! endif -!wgu - ! In this case, we can wipe out the eigen-decomp since it will be redone for - ! each profile at each location at setup time. - ErrorCov%Revals=zero - ErrorCov%Revecs=zero -endif ! method=2 - - contains - subroutine westonEtAl_spectrum_boost_(adjspec) - implicit none - logical,intent(out) :: adjspec - adjspec=.false. - if(ErrorCov%kreq < zero) return - lambda_max=maxval(ErrorCov%Revals) - lambda_min=minval(ErrorCov%Revals) - lambda_inc=(lambda_max - (lambda_min * ErrorCov%kreq))/(ErrorCov%kreq-1) - if(lambda_inc>zero) then - ErrorCov%Revals = ErrorCov%Revals + lambda_inc - else - if (iamroot_) then - write(6,'(2a,1x,es10.3)') myname_, ' Spectrum of cov(R) not changed, poor choice of kreq = ', & - ErrorCov%kreq - endif - endif - adjspec=.true. - end subroutine westonEtAl_spectrum_boost_ - subroutine rebuild_rcov_ - integer(i_kind) ii,jj,kk - real(r_kind), allocatable, dimension(:,:) :: tmp - allocate(tmp(ndim,ndim)) - ! D*U^T - do jj=1,ndim - tmp(:,jj) = ErrorCov%Revals(:) * ErrorCov%Revecs(jj,:) - enddo - ! U*(D*U^T) - ErrorCov%R = matmul(ErrorCov%Revecs,tmp) - ErrorCov%Revecs =ErrorCov%R - call decompose_(trim(ErrorCov%name),ErrorCov%Revals,ErrorCov%Revecs,ndim,.true.) - ! clean up - deallocate(tmp) - end subroutine rebuild_rcov_ -end subroutine solver_ -!EOC - - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: decompose_ --- calculates eigen-decomposition of cov(R) -! -! !INTERFACE: -! -subroutine decompose_(instrument,Evals,Evecs,ndim,lprt) -! !USES: -use constants, only: tiny_r_kind - implicit none -! !INPUT PARAMETERS: - character(len=*),intent(in):: instrument - integer(i_kind),intent(in) :: ndim - logical,intent(in) :: lprt -! !INPUT/OUTPUT PARAMETERS: - real(r_kind),intent(inout) :: Evals(:) - real(r_kind),intent(inout) :: Evecs(:,:) ! on entry: matrix to decompose - ! on exit: eigenvectors - -! !DESCRIPTION: This routine makes a LAPACK call to eigen-decompose cov(R). -! Its initial implementation is the crudest possible; it does -! not make use of the fact that only the upper or lower triangles -! of the matrix are needed; the problems solver are so small that -! at present this does not seem to be an issue; this could be -! easily revisited in the future. -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC - character(len=*),parameter :: myname_=myname//'decompose_' - character*1 jobz - integer(i_kind) lwork,info - real(r_kind) lambda_max,lambda_min,cond - real(r_kind),allocatable, dimension(:) :: work - jobz = 'V' ! evals & evecs - lwork = max(1,3*ndim-1) - allocate(work(lwork)) - if(r_kind==r_single) then ! this trick only works because this uses the f77 lapack interfaces - call SSYEV( jobz, 'U', ndim, Evecs, ndim, Evals, WORK, lwork, info ) - else if(r_kind==r_double) then - call DSYEV( jobz, 'U', ndim, Evecs, ndim, Evals, WORK, lwork, info ) - else - call die(myname_,'no corresponding LAPACK call for solving eigenproblem') - endif - if (info==0) then - if (lprt) then - cond=-999._r_kind - lambda_max=maxval(Evals) - lambda_min=minval(abs(Evals)) - if(lambda_min>tiny_r_kind) cond=abs(lambda_max/lambda_min) ! formal definition (lambda>0 for SPD matrix) - if (iamroot_) then - write(6,'(2a,1x,a,1x,es10.3)') 'Rcov(Evals) for Instrument: ', trim(instrument), ' cond= ', cond - write(6,'(9(1x,es10.3))') Evals - endif - endif - else - call die(myname_,'trouble solving eigenproblem') - endif - deallocate(work) -end subroutine decompose_ -!EOC - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: scale_jac_ --- scale Jacbian, residuals, and related errors -! -! !INTERFACE: -! -logical function scale_jac_(depart,obvarinv,adaptinf,jacobian, & - nchanl,jpch_rad,varinv,wgtjo,iuse,ich,ErrorCov) -! !USES: -use constants, only: tiny_r_kind -use mpeu_util, only: die -implicit none -! !INPUT PARAMETERS: -integer(i_kind),intent(in) :: nchanl ! total number of channels in instrument -integer(i_kind),intent(in) :: jpch_rad ! total number of channels in GSI -integer(i_kind),intent(in) :: ich(:) ! true channel numeber -integer(i_kind),intent(in) :: iuse(0:jpch_rad) ! flag indicating whether channel used or not -real(r_kind), intent(in) :: varinv(:) ! inverse of specified ob-error-variance -! !INPUT/OUTPUT PARAMETERS: -real(r_kind),intent(inout) :: depart(:) ! observation-minus-guess departure -real(r_kind),intent(inout) :: obvarinv(:) ! inverse of eval(diag(R)) -real(r_kind),intent(inout) :: adaptinf(:) ! stdev error -real(r_kind),intent(inout) :: wgtjo(:) ! weight in Jo-term -real(r_kind),intent(inout) :: jacobian(:,:)! Jacobian matrix -type(ObsErrorCov) :: ErrorCov ! ob error covariance for given instrument - -! !DESCRIPTION: This routine is the main entry-point to the outside world. -! It redefines the Jacobian matrix so it embeds the inverse of the square root -! observation error covariance matrix. Only the sub-matrix related -! to the active and accepted channels in the given profile is -! taken into account. -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! 2014-11-15 W. Gu bug fix in R-inverse indexation -! 2014-12-19 W. Gu use the eigenvalue decomposition to form a square root decomposition, and then -! apply to correlated R-covariance matrix(R= QD^(1/2)Q^T QD^(1/2)Q^T). -! 2015-04-01 W. Gu clean the code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC - -character(len=*),parameter :: myname_=myname//'*scale_jac' -integer(i_kind) :: nch_active,ii,jj,iii,jjj,mm,nn,ncp,ifound,nsigjac,indR -integer(i_kind),allocatable,dimension(:) :: ircv -integer(i_kind),allocatable,dimension(:) :: ijac -integer(i_kind),allocatable,dimension(:) :: IRsubset -integer(i_kind),allocatable,dimension(:) :: IJsubset -real(r_kind), allocatable,dimension(:) :: col,col0 -real(r_kind), allocatable,dimension(:,:) :: row,row0 -real(r_kind) coeff,qcadjusted -logical subset -scale_jac_=.false. -nch_active=ErrorCov%nch_active -if(nch_active<0) return -call timer_ini('scljac') - -! get indexes for the internal channels matching those -! used in estimating the observation error covariance -allocate(ircv(nchanl)) -allocate(ijac(nchanl)) -ircv = -1 -ijac = -1 -coeff=one -if(ErrorCov%method==1.and.ErrorCov%kreq>zero) then - coeff=100._r_kind/ErrorCov%kreq -endif -do jj=1,nchanl - mm=ich(jj) ! true channel number (has no bearing here except in iuse) - if (varinv(jj)>tiny_r_kind .and. iuse(mm)>=1) then - ifound=-1 - do ii=1,nch_active - if (ErrorCov%nctot>nchanl) then - indR=ii - else - indR=ErrorCov%indxR(ii) - end if - if(jj==indR) then - ifound=ii - exit - endif - enddo - if(ifound/=-1) then - ijac(jj)=jj ! index value applies to the jacobian and departure - ircv(jj)=ifound ! index value applies to ErrorCov - endif - endif -enddo -ncp=count(ircv>0) ! number of active channels in profile -! following should never happen, but just in case ... -if(ncp==0 .or. ncp>ErrorCov%nch_active) then - call die(myname_,'serious inconsistency in handling correlated obs') -endif -! Get subset indexes; without QC and other on-the-fly analysis choices these -! two indexes would be the same, but because the analysis -! remove data here and there, most often there will be less -! channels being processed for a given profile than the set -! of active channels used to get an offline estimate of R. -allocate(IRsubset(ncp)) ! these indexes apply to the matrices/vec in ErrorCov -allocate(IJsubset(ncp)) ! these indexes apply to the Jacobian/departure -iii=0;jjj=0 -do ii=1,nchanl - if(ircv(ii)>0) then - iii=iii+1 - IRsubset(iii)=ircv(ii) ! subset indexes in R presently in use - endif - if(ijac(ii)>0) then - jjj=jjj+1 - IJsubset(iii)=ijac(ii) ! subset indexes in Jac/dep presently in use - endif -enddo -if (iii/=ncp) then - if (iamroot_) then - write(6,*) myname, ' iii,ncp= ',iii,ncp - endif - call die(myname_,' serious dimensions insconsistency (R), aborting') -endif -if (jjj/=ncp) then - if (iamroot_) then - write(6,*) myname, ' jjj,ncp= ',jjj,ncp - endif - call die(myname_,' serious dimensions insconsistency (J), aborting') -endif - -! decompose the sub-matrix - returning the result in the -! structure holding the full covariance -if( ErrorCov%method==1 .or. ErrorCov%method==2 ) then -!wgu - if( ErrorCov%method==2 ) then - do jj=1,ncp - mm=IJsubset(jj) - qcadjusted = obvarinv(mm)**2*adaptinf(mm) -!wgu ErrorCov%R(IRsubset(jj),IRsubset(jj)) = ErrorCov%R(IRsubset(jj),IRsubset(jj))/qcadjusted - ErrorCov%R(IRsubset(jj),IRsubset(jj)) = ErrorCov%R(IRsubset(jj),IRsubset(jj)) - enddo - endif -!wgu - subset = decompose_subset_ (IRsubset,ErrorCov) - if(.not.subset) then - call die(myname_,' failed to decompose correlated R') - endif -endif - -if( ErrorCov%method<0 ) then -! Keep departures and Jacobian unchanged -! Do as GSI would do otherwise - do jj=1,ncp - mm=IJsubset(jj) - adaptinf(mm) = obvarinv(mm)**2*varinv(mm) - obvarinv(mm) = one/obvarinv(mm)**2 - wgtjo(mm) = varinv(mm) - enddo -else - nsigjac=size(jacobian,1) -! Multiply Jacobian with matrix of eigenvectors -! Multiply departure with "right" eigenvectors - allocate(row(nsigjac,ncp),row0(nsigjac,ncp)) - allocate(col(ncp),col0(ncp)) - row=zero;row0=zero - col=zero;col0=zero - - select case ( ErrorCov%method ) ! Re: estimated ob error cov - ! De=diag(Re); Ce=corr(Re) - ! Rg: ultimate matrix seen by GSI Jo-term - ! D0: original (diag) ob-error variances - ! i.e., inv(D0)=varinv - - case(0) ! use diag(Re) replaces GSI specified errors - ! inv(Rg) = inv(De) - - do jj=1,ncp - mm=IJsubset(jj) - qcadjusted = obvarinv(mm)**2*adaptinf(mm) - obvarinv(mm) = one/ErrorCov%R(IRsubset(jj),IRsubset(jj)) - adaptinf(mm) = qcadjusted - wgtjo(mm) = qcadjusted/ErrorCov%R(IRsubset(jj),IRsubset(jj)) - enddo - - case (2) ! case=2: uses full Re; - ! Re = U De U^T (Evals/Evecs eigen-pairs of full Re) - ! inv(Rg) = U De^(-1/2) U^T U De^(-1/2) U^T - - do ii=1,ncp - do jj=1,ncp - nn=IJsubset(jj) - col0(ii) = col0(ii) + ErrorCov%Revecs(IRsubset(jj),IRsubset(ii)) * depart(nn) - row0(:,ii) = row0(:,ii) + ErrorCov%Revecs(IRsubset(jj),IRsubset(ii)) * jacobian(:,nn) - enddo - coeff = sqrt(one/ErrorCov%Revals(IRsubset(ii))) - col0(ii) = coeff * col0(ii) - row0(:,ii) = coeff * row0(:,ii) - enddo - do ii=1,ncp - do jj=1,ncp - col(ii) = col(ii) + ErrorCov%Revecs(IRsubset(ii),IRsubset(jj)) * col0(jj) - row(:,ii) = row(:,ii) + ErrorCov%Revecs(IRsubset(ii),IRsubset(jj)) * row0(:,jj) - enddo - enddo - -! Place Jacobian and departure in output arrays - do jj=1,ncp - mm=IJsubset(jj) - depart(mm)=col(jj) - jacobian(:,mm)=row(:,jj) - adaptinf(mm) = obvarinv(mm)**2*adaptinf(mm) - obvarinv(mm) = one/adaptinf(mm) - wgtjo(mm) = one - enddo - - - case(3) ! use diag(Re) scales GSI specified errors - ! inv(Rg) = inv(De*Dg) - - do jj=1,ncp - mm=IJsubset(jj) - adaptinf(mm) = obvarinv(mm)**2*varinv(mm)/ErrorCov%Revals(IRsubset(jj)) - obvarinv(mm) = one/obvarinv(mm)**2 - wgtjo(mm) = varinv(mm)/ErrorCov%Revals(IRsubset(jj)) - enddo - - case default ! case=1 is default; uses corr(Re) only - ! Ce = U E U^T (U=Evecs; E=Evals hold eigen-pairs of corr(R)) - ! inv(Rg) = D0^(-1/2) U inv(E) U^T D0^(-1/2) - - do ii=1,ncp - do jj=1,ncp - nn=IJsubset(jj) - coeff = sqrt(varinv(nn)/ErrorCov%Revals(IRsubset(ii))) - col0(ii) = col0(ii) + ErrorCov%Revecs(IRsubset(jj),IRsubset(ii)) *coeff*depart(nn) - row0(:,ii) = row0(:,ii) + ErrorCov%Revecs(IRsubset(jj),IRsubset(ii)) *coeff*jacobian(:,nn) - enddo - enddo - do ii=1,ncp - do jj=1,ncp - col(ii) = col(ii) + ErrorCov%Revecs(IRsubset(ii),IRsubset(jj)) * col0(jj) - row(:,ii) = row(:,ii) + ErrorCov%Revecs(IRsubset(ii),IRsubset(jj)) * row0(:,jj) - enddo - enddo - -! Place Jacobian and departure in output arrays - do jj=1,ncp - mm=IJsubset(jj) - depart(mm)=col(jj) - jacobian(:,mm)=row(:,jj) - adaptinf(mm) = varinv(mm) - obvarinv(mm) = one/adaptinf(mm) - wgtjo(mm) = one - enddo - - end select - deallocate(col,col0) - deallocate(row,row0) -endif -! clean up -deallocate(IJsubset) -deallocate(IRsubset) -deallocate(ijac) -deallocate(ircv) -scale_jac_=.true. -call timer_fnl('scljac') -end function scale_jac_ -!EOC - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: rsqrtinv_ --- Inverse of R square-root -! -! !INTERFACE: -! -subroutine rsqrtinv_(nchanl,jpch_rad,iuse,nchasm,ich,ichasm,varinv,rsqrtinv,ErrorCov) -! !USES: -use mpeu_util, only: die -implicit none -! !INPUT PARAMETERS: -integer(i_kind),intent(in) :: nchasm ! total number of channels in instrument -integer(i_kind),intent(in) :: nchanl !number of passive+active channels -integer(i_kind),intent(in) :: jpch_rad ! total number of channels in GSI -integer(i_kind),intent(in) :: ich(nchasm) ! index in from 1 to jpch_rad -integer(i_kind),intent(in) :: ichasm(nchasm) ! index in from 1 to nchanl -integer(i_kind),intent(in) :: iuse(0:jpch_rad) ! flag indicating whether channel used or not -real(r_kind), intent(in) :: varinv(nchasm) ! inverse of specified ob-error-variance -type(ObsErrorCov) :: ErrorCov ! ob error covariance for given instrument -! !INPUT/OUTPUT PARAMETERS: -real(r_kind),intent(inout) :: rsqrtinv(nchasm,nchasm)! inv of square-root of ob error covariance matrix - -! !DESCRIPTION: This routine gives the inverse of the square root of the observation error covariance matrix. -! Only the sub-matrix related to the active and accepted channels in the given profile is -! taken into account. -! -! !REVISION HISTORY: -! 2015-03-11 W.Gu initial code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Wei Gu org: gmao date: 2015-03-11 -! -!EOP -!------------------------------------------------------------------------- -!BOC - -character(len=*),parameter :: myname_=myname//'*inv_rsqrt' -integer(i_kind) :: nch_active,ii,jj,mm,nn,ncp,ifound,kk,indR -integer(i_kind),allocatable,dimension(:) :: ircv -real(r_kind), allocatable,dimension(:,:) :: row -real(r_kind) coeff,qcadjusted -logical subset -nch_active=ErrorCov%nch_active -!wgu if(nch_active<0) return -call timer_ini('inv_rsqrt') - -! get indexes for the internal channels matching those -! used in estimating the observation error covariance -allocate(ircv(nchasm)) -ircv = -1 -do jj=1,nchasm - nn=ichasm(jj) ! index in from 1 to nchanl - mm=ich(jj) ! true channel number (has no bearing here except in iuse) - if (iuse(mm)>=1) then - ifound=-1 - do ii=1,nch_active - if (nchanl0) ! number of active channels in profile -! following should never happen, but just in case ... -if(ncp==0 .or. ncp>ErrorCov%nch_active .or. ncp .ne. nchasm) then - call die(myname_,'serious inconsistency in handling correlated obs') -endif - -!wgu - if(ErrorCov%method==2)then - do jj=1,ncp - qcadjusted = varinv(jj) -!wgu ErrorCov%R(ircv(jj),ircv(jj)) = ErrorCov%R(ircv(jj),ircv(jj))/qcadjusted - ErrorCov%R(ircv(jj),ircv(jj)) = ErrorCov%R(ircv(jj),ircv(jj)) - enddo - endif -!wgu - - subset = decompose_subset_ (ircv,ErrorCov) - if(.not.subset) then - call die(myname_,' failed to decompose correlated R') - endif - - allocate(row(ncp,ncp)) - row=zero - - if(ErrorCov%method==1) then - do ii=1,ncp - do jj=1,ncp - coeff = sqrt(varinv(jj)/ErrorCov%Revals(ircv(ii))) - row(ii,jj) = coeff*ErrorCov%Revecs(ircv(jj),ircv(ii)) - enddo - enddo - else if(ErrorCov%method==2)then - do ii=1,ncp - coeff = sqrt(one/ErrorCov%Revals(ircv(ii))) - do jj=1,ncp - row(ii,jj) = coeff*ErrorCov%Revecs(ircv(jj),ircv(ii)) - enddo - enddo - endif - rsqrtinv=zero - do ii=1,ncp - do jj=1,ncp - do kk=1,ncp - rsqrtinv(ii,jj) = rsqrtinv(ii,jj) + ErrorCov%Revecs(ircv(ii),ircv(kk)) * row(kk,jj) - enddo - enddo - enddo - - deallocate(row) -! clean up -deallocate(ircv) - -call timer_fnl('inv_rsqrt') -end subroutine rsqrtinv_ -!EOC - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: upd_varqc_ --- replace the obs error prescribed in satinfo for instrument accounted for inter-channel covariance. -! -! !INTERFACE: -! -subroutine upd_varqc_(jpch_rad,iuse_rad,nusis,varch) -! !USES: - use mpeu_util, only: die - use mpeu_util, only: getindex -implicit none -! !INPUT PARAMETERS: - integer(i_kind),intent(in) :: jpch_rad - integer(i_kind),dimension(0:jpch_rad),intent(in) :: iuse_rad - character(len=*),dimension(jpch_rad),intent(in) :: nusis -! !INPUT/OUTPUT PARAMETERS: - real(r_kind),dimension(jpch_rad),intent(inout) :: varch -! !DESCRIPTION: This routine will replace the prescribed obs errors in satinfo for instruments we account -! for inter-channel covariances. -! -! !REVISION HISTORY: -! 2014-11-26 W. Gu initial code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Wei Gu org: gmao date: 2014-11-26 -! -!EOP -!------------------------------------------------------------------------- -!BOC - - character(len=*),parameter :: myname_=myname//'*upd_varqc' - character(len=80) covtype - integer(i_kind) :: nch_active,ii,jj,iii,jjj,mm,nn,ncp,ifound,jj0,itbl,nsatype,ntrow - integer(i_kind),allocatable,dimension(:) :: ircv - integer(i_kind),allocatable,dimension(:) :: ijac - integer(i_kind),allocatable,dimension(:) :: IRsubset - integer(i_kind),allocatable,dimension(:) :: IJsubset - integer(i_kind) iinstr,indR - integer(i_kind),allocatable,dimension(:) :: ich1,tblidx ! true channel numeber - integer(i_kind) :: nchanl1,jc ! total number of channels in instrument - if(.not.allocated(idnames)) then - return - endif - ntrow = size(idnames) - allocate(ich1(jpch_rad),tblidx(ntrow)) - - nsatype=0 - do jj0=1,ntrow - covtype=trim(idnames(jj0)) - iinstr=len_trim(covtype) - if(covtype(iinstr-6:iinstr)==':global')then - nsatype=nsatype+1 - tblidx(nsatype)=jj0 - endif - enddo - if(nsatype==0) return - - do jj0=1,nsatype - - itbl=tblidx(jj0) - jc=0 - do ii=1,jpch_rad - covtype = trim(nusis(ii))//':global' - if(trim(idnames(itbl))==trim(covtype)) then - jc=jc+1 - ich1(jc)=ii - endif - enddo - nchanl1=jc - if(nchanl1==0)then - call die(myname_,' improperly set GSI_BundleErrorCov') - endif - - if(.not.amiset_(GSI_BundleErrorCov(itbl))) then - call die(myname_,' improperly set GSI_BundleErrorCov') - endif - - nch_active=GSI_BundleErrorCov(itbl)%nch_active - if(nch_active<0) return - -! get indexes for the internal channels matching those -! used in estimating the observation error covariance - allocate(ircv(nchanl1)) - allocate(ijac(nchanl1)) - ircv = -1 - ijac = -1 - do jj=1,nchanl1 - mm=ich1(jj) ! true channel number (has no bearing here except in iuse) - if (iuse_rad(mm)>=1) then - ifound=-1 - do ii=1,nch_active - if (GSI_BundleErrorCov(itbl)%nctot>nchanl1) then - indR=ii - else - indR=GSI_BundleErrorCov(itbl)%indxR(ii) - end if - if(jj==indR) then - ifound=ii - exit - endif - enddo - if(ifound/=-1) then - ijac(jj)=jj ! index value in 1 to nchanl - ircv(jj)=ifound ! index value in 1 to nch_active - endif - endif - enddo - ncp=count(ircv>0) ! number of active channels in profile - if(ncp/=nch_active) then - call die(myname_,'serious inconsistency in handling correlated obs') - endif - allocate(IRsubset(ncp)) ! these indexes apply to the matrices/vec in ErrorCov - allocate(IJsubset(ncp)) ! these indexes in 1 to nchanl - iii=0;jjj=0 - do ii=1,nchanl1 - if(ircv(ii)>0) then - iii=iii+1 - IRsubset(iii)=ircv(ii) ! subset indexes in R presently in use - endif - if(ijac(ii)>0) then - jjj=jjj+1 - IJsubset(iii)=ijac(ii) ! subset indexes in channels presently in use - endif - enddo - if (iii/=ncp) then - if (iamroot_) then - write(6,*) myname, ' iii,ncp= ',iii,ncp - endif - call die(myname_,' serious dimensions insconsistency, aborting') - endif - if (jjj/=ncp) then - if (iamroot_) then - write(6,*) myname, ' jjj,ncp= ',jjj,ncp - endif - call die(myname_,' serious dimensions insconsistency, aborting') - endif - - if( GSI_BundleErrorCov(itbl)%method==2 ) then - do ii=1,ncp - nn=IJsubset(ii) - mm=ich1(nn) - if(iamroot_)write(6,'(1x,a20,2i6,2f15.5)')idnames(itbl),ii,nn,varch(mm),sqrt(GSI_BundleErrorCov(itbl)%R(IRsubset(ii),IRsubset(ii))) - varch(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(IRsubset(ii),IRsubset(ii))) - enddo - endif - -! clean up - deallocate(IJsubset) - deallocate(IRsubset) - deallocate(ijac) - deallocate(ircv) - - enddo - - deallocate(ich1,tblidx) -end subroutine upd_varqc_ -!EOC - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: decompose_subset_ --- extract subset cov(R) and decompose it -! -! !INTERFACE: -! - -! !DESCRIPTION: Given an index-set of channels really operative in a given -! profile, this routine extracts those rows and columns from -! the offline estimate of cov(R), creating a subset(cov(R)) -! that is eigen-decomposed. The resulting partial eigen- -! decomposition is stored back in the corresponding -! rows and columns of the temporary space in ObErroCov -! responsible for holding the eigen-values/vectors. -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC -logical function decompose_subset_ (Isubset,ErrorCov) -implicit none -! in this approach, we take only the rows and columns of R related -! to the channels used, and eigendecompose them ... instead of -! eigendecomposing once, which I think ends up leading to the wrong -! mixt of eigenvalues and eigenvectors. -integer(i_kind),intent(in) :: Isubset(:) -type(ObsErrorCov) :: ErrorCov - -character(len=*), parameter :: myname_=myname//'*subset_' -real(r_kind),allocatable,dimension(:) :: Evals -real(r_kind),allocatable,dimension(:,:) :: Evecs -integer(i_kind) ii,jj,ncp - -decompose_subset_=.false. -ncp=size(Isubset) ! number of channels actually used in this profile -allocate(Evals(ncp),Evecs(ncp,ncp)) - -! extract subcomponent of R -!Evecs = ErrorCov%R(Isubset,Isubset) -do jj=1,ncp - do ii=1,ncp - Evecs(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj)) - enddo -enddo -! decompose subset matrix -call decompose_(ErrorCov%instrument,Evals,Evecs,ncp,.false.) -! copy decomposition onto ErrorCov -do jj=1,ncp - do ii=1,ncp - ErrorCov%Revecs(Isubset(ii),Isubset(jj)) = Evecs(ii,jj) - enddo - ErrorCov%Revals(Isubset(jj)) = Evals(jj) -enddo -! clean up -deallocate(Evals,Evecs) - -decompose_subset_=.true. -end function decompose_subset_ -!EOC - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: amIset_ --- checks whether a particular cov(R) has been set or not -! -! !INTERFACE: -! - -logical function amIset_ (ErrorCov) -implicit none -! !INPUT/OUTPUT PARAMETERS: -type(ObsErrorCov) :: ErrorCov - -! !DESCRIPTION: This routine returns the status of a particular instance of -! the FORTRAN typing holding the observation error covariance. -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC -logical failed -failed=.false. -amIset_=.false. -if(ErrorCov%nch_active<0) failed=.true. -if(.not.associated(ErrorCov%indxR)) failed=.true. -if(.not.associated(ErrorCov%R)) failed=.true. -if(.not.associated(ErrorCov%REvals)) failed=.true. -if(.not.associated(ErrorCov%REvecs)) failed=.true. -if(.not.failed) amIset_=.true. -end function amIset_ -!EOC - -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: fnl_ --- destroy all instances of cov(R) -! -! !INTERFACE: -! -subroutine fnl_ -implicit none - -! !DESCRIPTION: Deallocates space held for observation error covariance. -! -! !REVISION HISTORY: -! 2014-04-13 todling initial code -! -! !REMARKS: -! language: f90 -! machine: discover -! -! !AUTHOR: -! Ricardo Todling org: gmao date: 2014-04-13 -! -!EOP -!------------------------------------------------------------------------- -!BOC -integer(i_kind) ii,ndim -if(.not.initialized_) return -ndim=size(GSI_BundleErrorCov) -do ii=1,ndim - call destroy_(GSI_BundleErrorCov(ii)) -enddo -deallocate(GSI_BundleErrorCov) -if(allocated(idnames)) deallocate(idnames) -if(allocated(instruments)) deallocate(instruments) -end subroutine fnl_ -!EOC - -end module correlated_obsmod diff --git a/src/cplr_get_wrf_mass_ensperts.f90 b/src/cplr_get_wrf_mass_ensperts.f90 deleted file mode 100644 index 93f547752..000000000 --- a/src/cplr_get_wrf_mass_ensperts.f90 +++ /dev/null @@ -1,953 +0,0 @@ -module get_wrf_mass_ensperts_mod -use abstract_get_wrf_mass_ensperts_mod - use kinds, only : i_kind - type, extends(abstract_get_wrf_mass_ensperts_class) :: get_wrf_mass_ensperts_class - contains - procedure, pass(this) :: get_wrf_mass_ensperts => get_wrf_mass_ensperts_wrf - procedure, pass(this) :: ens_spread_dualres_regional => ens_spread_dualres_regional_wrf - procedure, pass(this) :: general_read_wrf_mass - procedure, nopass :: fill_regional_2d - end type get_wrf_mass_ensperts_class -contains - subroutine get_wrf_mass_ensperts_wrf(this,en_perts,nelen,ps_bar) - !$$$ subprogram documentation block - ! . . . . - ! subprogram: get_wrf_mass_ensperts read arw model ensemble members - ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 - ! - ! abstract: read ensemble members from the arw model in netcdf format, for use - ! with hybrid ensemble option. ensemble spread is also written out as - ! a byproduct for diagnostic purposes. - ! - ! - ! program history log: - ! 2010-08-11 parrish, initial documentation - ! 2011-08-31 todling - revisit en_perts (single-prec) in light of extended bundle - ! 2012-02-08 kleist - add extra dimension to en_perts for 4d application - ! (currently use placeholder of value 1, since regional 4d application not - ! 2017-07-30 Hu - added code to read in multiple-time level ensemble forecast to - ! get 4D peerturbations - ! - ! input argument list: - ! - ! output argument list: - ! - ! attributes: - ! language: f90 - ! machine: ibm RS/6000 SP - ! - !$$$ end documentation block - - use kinds, only: r_kind,i_kind,r_single - use constants, only: zero,one,half,zero_single,rd_over_cp,one_tenth - use mpimod, only: mpi_comm_world,ierror,mype - use hybrid_ensemble_parameters, only: n_ens,grd_ens - use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path - use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d - use gsi_bundlemod, only: gsi_bundlecreate - use gsi_bundlemod, only: gsi_grid - use gsi_bundlemod, only: gsi_bundle - use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_bundlemod, only: gsi_bundledestroy - use gsi_bundlemod, only: gsi_gridcreate - use guess_grids, only: ntguessig,ifilesig - use gsi_4dvar, only: nhr_assimilation - - implicit none - class(get_wrf_mass_ensperts_class), intent(inout) :: this - type(gsi_bundle),allocatable, intent(inout) :: en_perts(:,:) - integer(i_kind), intent(in ):: nelen - real(r_single),dimension(:,:,:),allocatable:: ps_bar - - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig):: u,v,tv,cwmr,oz,rh - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2):: ps - - real(r_single),pointer,dimension(:,:,:):: w3 - real(r_single),pointer,dimension(:,:):: w2 - real(r_kind),pointer,dimension(:,:,:):: x3 - real(r_kind),pointer,dimension(:,:):: x2 - type(gsi_bundle):: en_bar - type(gsi_grid):: grid_ens - real(r_kind):: bar_norm,sig_norm,kapr,kap1 - - integer(i_kind):: i,j,k,n,mm1,istatus - integer(i_kind):: ic2,ic3 - integer(i_kind):: its,ite, it - - character(255) filelists(ntlevs_ens) - character(255) filename - - call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) - call gsi_bundlecreate(en_bar,grid_ens,'ensemble',istatus,names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)' get_wrf_mass_ensperts_netcdf: trouble creating en_bar bundle' - call stop2(999) - endif - - if(ntlevs_ens > 1) then - do i=1,ntlevs_ens - write(filelists(i),'("filelist",i2.2)')ifilesig(i) - enddo - its=1 - ite=ntlevs_ens - else - write(filelists(1),'("filelist",i2.2)')nhr_assimilation - its=ntguessig - ite=ntguessig - endif - - do it=its,ite - if (mype == 0) write(*,*) 'ensemble file==',it,its,ite,ntlevs_ens,n_ens - if(ntlevs_ens > 1) then - open(10,file=trim(filelists(it)),form='formatted',err=30) - else - open(10,file=trim(filelists(1)),form='formatted',err=30) - endif - - - ! - ! INITIALIZE ENSEMBLE MEAN ACCUMULATORS - en_bar%values=zero - - do n=1,n_ens - en_perts(n,it)%valuesr4 = zero - enddo - - mm1=mype+1 - kap1=rd_over_cp+one - kapr=one/rd_over_cp - ! - ! LOOP OVER ENSEMBLE MEMBERS - do n=1,n_ens - ! - ! DEFINE INPUT FILE NAME - read(10,'(a)',err=20,end=20)filename - filename=trim(ensemble_path) // trim(filename) - ! - ! READ ENEMBLE MEMBERS DATA - if (mype == 0) write(6,'(a,a)') 'CALL READ_WRF_MASS_ENSPERTS FOR ENS DATA : ',trim(filename) - call this%general_read_wrf_mass(filename,ps,u,v,tv,rh,cwmr,oz,mype) - - ! SAVE ENSEMBLE MEMBER DATA IN COLUMN VECTOR - do ic3=1,nc3d - - call gsi_bundlegetpointer(en_perts(n,it),trim(cvars3d(ic3)),w3,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for ensemble member ',n - call stop2(999) - end if - call gsi_bundlegetpointer(en_bar,trim(cvars3d(ic3)),x3,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for en_bar' - call stop2(999) - end if - - select case (trim(cvars3d(ic3))) - - case('sf','SF') - - do k=1,grd_ens%nsig - do i=1,grd_ens%lon2 - do j=1,grd_ens%lat2 - w3(j,i,k) = u(j,i,k) - x3(j,i,k)=x3(j,i,k)+u(j,i,k) - end do - end do - end do - - case('vp','VP') - - do k=1,grd_ens%nsig - do i=1,grd_ens%lon2 - do j=1,grd_ens%lat2 - w3(j,i,k) = v(j,i,k) - x3(j,i,k)=x3(j,i,k)+v(j,i,k) - end do - end do - end do - - case('t','T') - - do k=1,grd_ens%nsig - do i=1,grd_ens%lon2 - do j=1,grd_ens%lat2 - w3(j,i,k) = tv(j,i,k) - x3(j,i,k)=x3(j,i,k)+tv(j,i,k) - end do - end do - end do - - case('q','Q') - - do k=1,grd_ens%nsig - do i=1,grd_ens%lon2 - do j=1,grd_ens%lat2 - w3(j,i,k) = rh(j,i,k) - x3(j,i,k)=x3(j,i,k)+rh(j,i,k) - end do - end do - end do - - case('oz','OZ') - - do k=1,grd_ens%nsig - do i=1,grd_ens%lon2 - do j=1,grd_ens%lat2 - w3(j,i,k) = oz(j,i,k) - x3(j,i,k)=x3(j,i,k)+oz(j,i,k) - end do - end do - end do - - case('cw','CW') - - do k=1,grd_ens%nsig - do i=1,grd_ens%lon2 - do j=1,grd_ens%lat2 - w3(j,i,k) = cwmr(j,i,k) - x3(j,i,k)=x3(j,i,k)+cwmr(j,i,k) - end do - end do - end do - - end select - end do - - do ic2=1,nc2d - - call gsi_bundlegetpointer(en_perts(n,it),trim(cvars2d(ic2)),w2,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for ensemble member ',n - call stop2(999) - end if - call gsi_bundlegetpointer(en_bar,trim(cvars2d(ic2)),x2,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar' - call stop2(999) - end if - - select case (trim(cvars2d(ic2))) - - case('ps','PS') - - do i=1,grd_ens%lon2 - do j=1,grd_ens%lat2 - w2(j,i) = ps(j,i) - x2(j,i)=x2(j,i)+ps(j,i) - end do - end do - - case('sst','SST') - ! IGNORE SST IN HYBRID for now - - do i=1,grd_ens%lon2 - do j=1,grd_ens%lat2 - w2(j,i) = zero - x2(j,i)=zero - end do - end do - - end select - end do - enddo - ! - ! CALCULATE ENSEMBLE MEAN - bar_norm = one/float(n_ens) - en_bar%values=en_bar%values*bar_norm - - ! Copy pbar to module array. ps_bar may be needed for vertical localization - ! in terms of scale heights/normalized p/p - do ic2=1,nc2d - - if(trim(cvars2d(ic2)) == 'ps'.or.trim(cvars2d(ic2)) == 'PS') then - - call gsi_bundlegetpointer(en_bar,trim(cvars2d(ic2)),x2,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar to get ps_bar' - call stop2(999) - end if - - do i=1,grd_ens%lon2 - do j=1,grd_ens%lat2 - ps_bar(j,i,1)=x2(j,i) - end do - end do - exit - end if - end do - - call mpi_barrier(mpi_comm_world,ierror) - ! - ! CALCULATE ENSEMBLE SPREAD - call this%ens_spread_dualres_regional(mype,en_perts,nelen,en_bar) - call mpi_barrier(mpi_comm_world,ierror) - ! - ! CONVERT ENSEMBLE MEMBERS TO ENSEMBLE PERTURBATIONS - sig_norm=sqrt(one/max(one,n_ens-one)) - - do n=1,n_ens - do i=1,nelen - en_perts(n,it)%valuesr4(i)=(en_perts(n,it)%valuesr4(i)-en_bar%values(i))*sig_norm - end do - end do - - enddo ! it 4d loop - ! - call gsi_bundledestroy(en_bar,istatus) - if(istatus/=0) then - write(6,*)' in get_wrf_mass_ensperts_netcdf: trouble destroying en_bar bundle' - call stop2(999) - endif - - return - -30 write(6,*) 'get_wrf_mass_ensperts_netcdf: open filelist failed ' - call stop2(555) -20 write(6,*) 'get_wrf_mass_ensperts_netcdf: read WRF-ARW ens failed ',n - call stop2(555) - - end subroutine get_wrf_mass_ensperts_wrf - - subroutine general_read_wrf_mass(this,filename,g_ps,g_u,g_v,g_tv,g_rh,g_cwmr,g_oz,mype) - !$$$ subprogram documentation block - ! . . . . - ! subprogram: general_read_wrf_mass read arw model ensemble members - ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 - ! - ! abstract: read ensemble members from the arw model in "wrfout" netcdf format - ! for use with hybrid ensemble option. - ! - ! program history log: - ! 2010-08-11 parrish, initial documentation - ! 2010-09-10 parrish, modify so ensemble variables are read in the same way as in - ! subroutines convert_netcdf_mass and read_wrf_mass_binary_guess. - ! There were substantial differences due to different opinion about what - ! to use for surface pressure. This issue should be resolved by coordinating - ! with Ming Hu (ming.hu@noaa.gov). At the moment, these changes result in - ! agreement to single precision between this input method and the guess input - ! procedure when the same file is read by both methods. - ! 2012-03-12 whitaker: read data on root, distribute with scatterv. - ! remove call to general_reload. - ! simplify, fix memory leaks, reduce memory footprint. - ! use genqsat, remove genqsat2_regional. - ! replace bare 'stop' statements with call stop2(999). - ! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS core - ! - ! input argument list: - ! - ! output argument list: - ! - ! attributes: - ! language: f90 - ! machine: ibm RS/6000 SP - ! - !$$$ end documentation block - - use netcdf, only: nf90_nowrite - use netcdf, only: nf90_open,nf90_close - use netcdf, only: nf90_inq_dimid,nf90_inquire_dimension - use netcdf, only: nf90_inq_varid,nf90_inquire_variable,nf90_get_var - use kinds, only: r_kind,r_single,i_kind - use gridmod, only: nsig,eta1_ll,pt_ll,aeta1_ll,eta2_ll,aeta2_ll - use constants, only: zero,one,fv,zero_single,rd_over_cp_mass,one_tenth,h300 - use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens - use mpimod, only: mpi_comm_world,ierror,mpi_rtype - use netcdf_mod, only: nc_check - - implicit none - ! - ! Declare passed variables - class(get_wrf_mass_ensperts_class), intent(inout) :: this - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out):: & - g_u,g_v,g_tv,g_rh,g_cwmr,g_oz - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps - character(255),intent(in):: filename - ! - ! Declare local parameters - real(r_kind),parameter:: r0_01 = 0.01_r_kind - real(r_kind),parameter:: r10 = 10.0_r_kind - real(r_kind),parameter:: r100 = 100.0_r_kind - ! - ! Declare local variables - real(r_single),allocatable,dimension(:):: temp_1d - real(r_single),allocatable,dimension(:,:):: temp_2d,temp_2d2 - real(r_single),allocatable,dimension(:,:,:):: temp_3d - real(r_kind),allocatable,dimension(:):: p_top - real(r_kind),allocatable,dimension(:,:):: q_integral,gg_ps,q_integralc4h - real(r_kind),allocatable,dimension(:,:,:):: tsn,qst,prsl,& - gg_u,gg_v,gg_tv,gg_rh - real(r_kind),allocatable,dimension(:):: wrk_fill_2d - integer(i_kind),allocatable,dimension(:):: dim,dim_id - - integer(i_kind):: nx,ny,nz,i,j,k,d_max,file_id,var_id,ndim,mype - integer(i_kind):: Time_id,s_n_id,w_e_id,b_t_id,s_n_stag_id,w_e_stag_id,b_t_stag_id - integer(i_kind):: Time_len,s_n_len,w_e_len,b_t_len,s_n_stag_len,w_e_stag_len,b_t_stag_len - integer(i_kind) iderivative - - real(r_kind):: deltasigma - real(r_kind) psfc_this_dry,psfc_this - real(r_kind) work_prslk,work_prsl - - logical ice - - character(len=24),parameter :: myname_ = 'general_read_wrf_mass' - - - ! - ! OPEN ENSEMBLE MEMBER DATA FILE - if (mype==0) then ! only read data on root proc - allocate(gg_u(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) - allocate(gg_v(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) - allocate(gg_tv(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) - allocate(gg_rh(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) - allocate(gg_ps(grd_ens%nlat,grd_ens%nlon)) - call nc_check( nf90_open(trim(filename),nf90_nowrite,file_id),& - myname_,'open '//trim(filename) ) - ! - ! WRF FILE DIMENSIONS - call nc_check( nf90_inq_dimid(file_id,'Time',Time_id),& - myname_,'inq_dimid Time '//trim(filename) ) - call nc_check( nf90_inq_dimid(file_id,'south_north',s_n_id),& - myname_,'inq_dimid south_north '//trim(filename) ) - call nc_check( nf90_inq_dimid(file_id,'west_east',w_e_id),& - myname_,'inq_dimid west_east '//trim(filename) ) - call nc_check( nf90_inq_dimid(file_id,'bottom_top',b_t_id),& - myname_,'inq_dimid bottom_top '//trim(filename) ) - call nc_check( nf90_inq_dimid(file_id,'south_north_stag',s_n_stag_id),& - myname_,'inq_dimid south_north_stag '//trim(filename) ) - call nc_check( nf90_inq_dimid(file_id,'west_east_stag',w_e_stag_id),& - myname_,'inq_dimid west_east_stag '//trim(filename) ) - call nc_check( nf90_inq_dimid(file_id,'bottom_top_stag',b_t_stag_id),& - myname_,'inq_dimid bottom_top_stag '//trim(filename) ) - - d_max=max(Time_id, s_n_id, w_e_id, b_t_id, s_n_stag_id, w_e_stag_id, b_t_stag_id) - allocate(dim(d_max)) - dim(:)=-999 - - call nc_check( nf90_inquire_dimension(file_id,Time_id,len=Time_len),& - myname_,'inquire_dimension Time '//trim(filename) ) - call nc_check( nf90_inquire_dimension(file_id,s_n_id,len=s_n_len),& - myname_,'inquire_dimension south_north '//trim(filename) ) - call nc_check( nf90_inquire_dimension(file_id,w_e_id,len=w_e_len),& - myname_,'inquire_dimension west_east '//trim(filename) ) - call nc_check( nf90_inquire_dimension(file_id,b_t_id,len=b_t_len),& - myname_,'inquire_dimension bottom_top '//trim(filename) ) - call nc_check( nf90_inquire_dimension(file_id,s_n_stag_id,len=s_n_stag_len),& - myname_,'inquire_dimension south_north_stag '//trim(filename) ) - call nc_check( nf90_inquire_dimension(file_id,w_e_stag_id,len=w_e_stag_len),& - myname_,'inquire_dimension west_east_stag '//trim(filename) ) - call nc_check( nf90_inquire_dimension(file_id,b_t_stag_id,len=b_t_stag_len),& - myname_,'inquire_dimension bottom_top_stag '//trim(filename) ) - - nx=w_e_len - ny=s_n_len - nz=b_t_len - if (nx /= grd_ens%nlon .or. ny /= grd_ens%nlat .or. nz /= grd_ens%nsig) then - print *,'incorrect grid size in netcdf file' - print *,'nx,ny,nz,nlon,nlat,nsig',nx,ny,nz,grd_ens%nlon,grd_ens%nlat,grd_ens%nsig - call stop2(999) - endif - - dim(Time_id)=Time_len - dim(s_n_id)=s_n_len - dim(w_e_id)=w_e_len - dim(b_t_id)=b_t_len - dim(s_n_stag_id)=s_n_stag_len - dim(w_e_stag_id)=w_e_stag_len - dim(b_t_stag_id)=b_t_stag_len - ! - ! READ PERTURBATION POTENTIAL TEMPERATURE (K) - ! print *, 'read T ',filename - call nc_check( nf90_inq_varid(file_id,'T',var_id),& - myname_,'inq_varid T '//trim(filename) ) - - call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& - myname_,'inquire_variable T '//trim(filename) ) - allocate(dim_id(ndim)) - - call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& - myname_,'inquire_variable T '//trim(filename) ) - allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) - - call nc_check( nf90_get_var(file_id,var_id,temp_3d),& - myname_,'get_var T '//trim(filename) ) - allocate(tsn(dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3)))) - tsn = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) - deallocate(temp_3d) - deallocate(dim_id) - - ! READ MU, MUB, P_TOP (construct psfc as done in gsi--gives different result compared to PSFC) - - call nc_check( nf90_inq_varid(file_id,'P_TOP',var_id),& - myname_,'inq_varid P_TOP '//trim(filename) ) - - call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& - myname_,'inquire_variable P_TOP '//trim(filename) ) - allocate(dim_id(ndim)) - - call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& - myname_,'inquire_variable P_TOP '//trim(filename) ) - allocate(temp_1d(dim(dim_id(1)))) - - call nc_check( nf90_get_var(file_id,var_id,temp_1d),& - myname_,'get_var P_TOP '//trim(filename) ) - allocate(p_top(dim(dim_id(1)))) - do i=1,dim(dim_id(1)) - p_top(i)=temp_1d(i) - enddo - deallocate(dim_id) - - call nc_check( nf90_inq_varid(file_id,'MUB',var_id),& - myname_,'inq_varid MUB '//trim(filename) ) - - call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& - myname_,'inquire_variable MUB '//trim(filename) ) - allocate(dim_id(ndim)) - - call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& - myname_,'inquire_variable MUB '//trim(filename) ) - allocate(temp_2d(dim(dim_id(1)),dim(dim_id(2)))) - - call nc_check( nf90_get_var(file_id,var_id,temp_2d),& - myname_,'get_var MUB '//trim(filename) ) - deallocate(dim_id) - - call nc_check( nf90_inq_varid(file_id,'MU',var_id),& - myname_,'inq_varid MU '//trim(filename) ) - - call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& - myname_,'inquire_variable MU '//trim(filename) ) - allocate(dim_id(ndim)) - - call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& - myname_,'inquire_variable MU '//trim(filename) ) - allocate(temp_2d2(dim(dim_id(1)),dim(dim_id(2)))) - - call nc_check( nf90_get_var(file_id,var_id,temp_2d2),& - myname_,'get_var MU '//trim(filename) ) - - do j=1,dim(dim_id(2)) - do i=1,dim(dim_id(1)) - temp_2d2(i,j)=temp_2d(i,j)+temp_2d2(i,j)+temp_1d(1) - gg_ps(j,i)=temp_2d2(i,j) - enddo - enddo - print *,'min/max ps',minval(gg_ps),maxval(gg_ps) - deallocate(temp_2d,temp_2d2,temp_1d,dim_id) - - ! - ! READ U (m/s) - !print *, 'read U ',filename - call nc_check( nf90_inq_varid(file_id,'U',var_id),& - myname_,'inq_varid U '//trim(filename) ) - - call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& - myname_,'inquire_variable U '//trim(filename) ) - allocate(dim_id(ndim)) - - call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& - myname_,'inquire_variable U '//trim(filename) ) - allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) - - call nc_check( nf90_get_var(file_id,var_id,temp_3d),& - myname_,'get_var U '//trim(filename) ) - ! - ! INTERPOLATE TO MASS GRID - do k=1,dim(dim_id(3)) - do j=1,dim(dim_id(2)) - do i=1,dim(dim_id(1))-1 - gg_u(j,i,k)=.5*(temp_3d(i,j,k)+temp_3d(i+1,j,k)) - enddo - enddo - enddo - deallocate(temp_3d) - deallocate(dim_id) - ! - ! READ V (m/s) - !print *, 'read V ',filename - call nc_check( nf90_inq_varid(file_id,'V',var_id),& - myname_,'inq_varid V '//trim(filename) ) - - call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& - myname_,'inquire_variable V '//trim(filename) ) - allocate(dim_id(ndim)) - - call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& - myname_,'inquire_variable V '//trim(filename) ) - allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) - - call nc_check( nf90_get_var(file_id,var_id,temp_3d),& - myname_,'get_var V '//trim(filename) ) - ! - ! INTERPOLATE TO MASS GRID - do k=1,dim(dim_id(3)) - do j=1,dim(dim_id(2))-1 - do i=1,dim(dim_id(1)) - gg_v(j,i,k)=.5*(temp_3d(i,j,k)+temp_3d(i,j+1,k)) - enddo - enddo - enddo - deallocate(temp_3d) - deallocate(dim_id) - print *,'min/max u',minval(gg_u),maxval(gg_u) - print *,'min/max v',minval(gg_v),maxval(gg_v) - ! - ! READ QVAPOR (kg/kg) - !print *, 'read QVAPOR ',filename - call nc_check( nf90_inq_varid(file_id,'QVAPOR',var_id),& - myname_,'inq_varid QVAPOR '//trim(filename) ) - - call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& - myname_,'inquire_variable QVAPOR '//trim(filename) ) - allocate(dim_id(ndim)) - - call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& - myname_,'inquire_variable QVAPOR '//trim(filename) ) - allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) - - call nc_check( nf90_get_var(file_id,var_id,temp_3d),& - myname_,'get_var QVAPOR '//trim(filename) ) - gg_rh = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) - deallocate(temp_3d) - deallocate(dim_id,dim) - - call nc_check( nf90_close(file_id),& - myname_,'close '//trim(filename) ) - ! - ! CALCULATE TOTAL POTENTIAL TEMPERATURE (K) - !print *, 'calculate total temperature ',filename - do i=1,nx - do j=1,ny - do k=1,nz - tsn(j,i,k)=tsn(j,i,k)+h300 - enddo - enddo - enddo - ! - ! INTEGRATE {1 + WATER VAPOR} TO CONVERT DRY AIR PRESSURE - !print *, 'integrate 1 + q vertically ',filename - allocate(q_integral(ny,nx)) - allocate(q_integralc4h(ny,nx)) - q_integral(:,:)=one - q_integralc4h=0.0_r_single - do i=1,nx - do j=1,ny - do k=1,nz - deltasigma=eta1_ll(k)-eta1_ll(k+1) - q_integral(j,i)=q_integral(j,i)+deltasigma*gg_rh(j,i,k) - q_integralc4h(j,i)=q_integralc4h(j,i)+(eta2_ll(k)-eta2_ll(k+1))*gg_rh(j,i,k) - enddo - enddo - enddo - ! - ! CONVERT WATER VAPOR MIXING RATIO TO SPECIFIC HUMIDITY - do i=1,nx - do j=1,ny - do k=1,nz - gg_rh(j,i,k)=gg_rh(j,i,k)/(one+gg_rh(j,i,k)) - enddo - enddo - enddo - - ! obtaining psfc as done in subroutine read_wrf_mass_netcdf_guess - do i=1,nx - do j=1,ny - psfc_this_dry=r0_01*gg_ps(j,i) - psfc_this=(psfc_this_dry-pt_ll)*q_integral(j,i)+pt_ll+q_integralc4h(j,i) - gg_ps(j,i)=one_tenth*psfc_this ! convert from mb to cb - end do - end do - ! - ! CONVERT POTENTIAL TEMPERATURE TO VIRTUAL TEMPERATURE - !print *, 'convert potential temp to virtual temp ',filename - allocate(prsl(ny,nx,nz)) - do k=1,nz - do i=1,nx - do j=1,ny - work_prsl = one_tenth*(aeta1_ll(k)*(r10*gg_ps(j,i)-pt_ll)+& - aeta2_ll(k) + pt_ll) - prsl(j,i,k)=work_prsl - work_prslk = (work_prsl/r100)**rd_over_cp_mass - ! sensible temp from pot temp - tsn(j,i,k) = tsn(j,i,k)*work_prslk - ! virtual temp from sensible temp - gg_tv(j,i,k) = tsn(j,i,k) * (one+fv*gg_rh(j,i,k)) - ! recompute sensible temp from virtual temp - tsn(j,i,k)= gg_tv(j,i,k)/(one+fv*max(zero,gg_rh(j,i,k))) - end do - end do - end do - print *,'min/max tv',minval(gg_tv),maxval(gg_tv) - - ! - ! CALCULATE PSEUDO RELATIVE HUMIDITY IF USING RH VARIABLE - if (.not.q_hyb_ens) then - allocate(qst(ny,nx,nz)) - ice=.true. - iderivative=0 - call genqsat(qst,tsn,prsl,ny,nx,nsig,ice,iderivative) - do k=1,nz - do i=1,nx - do j=1,ny - gg_rh(j,i,k)=gg_rh(j,i,k)/qst(j,i,k) - enddo - enddo - enddo - print *,'min/max rh',minval(gg_rh),maxval(gg_rh) - deallocate(qst) - else - print *,'min/max q',minval(gg_rh),maxval(gg_rh) - end if - - ! DEALLOCATE REMAINING TEMPORARY STORAGE - deallocate(tsn,prsl,q_integral,p_top) - endif ! done netcdf read on root - - ! transfer data from root to subdomains on each task - ! scatterv used, since full grids exist only on root task. - allocate(wrk_fill_2d(grd_ens%itotsub)) - ! first PS (output from fill_regional_2d is a column vector with a halo) - if(mype==0) call this%fill_regional_2d(gg_ps,wrk_fill_2d) - call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & - g_ps,grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) - ! then TV,U,V,RH - do k=1,grd_ens%nsig - if (mype==0) call this%fill_regional_2d(gg_tv(1,1,k),wrk_fill_2d) - call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & - g_tv(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) - if (mype==0) call this%fill_regional_2d(gg_u(1,1,k),wrk_fill_2d) - call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & - g_u(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) - if (mype==0) call this%fill_regional_2d(gg_v(1,1,k),wrk_fill_2d) - call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & - g_v(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) - if (mype==0) call this%fill_regional_2d(gg_rh(1,1,k),wrk_fill_2d) - call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & - g_rh(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) - enddo - ! for now, don't do anything with oz, cwmr - g_oz = 0.; g_cwmr = 0. - deallocate(wrk_fill_2d) - if (mype==0) deallocate(gg_u,gg_v,gg_tv,gg_rh,gg_ps) - - return - end subroutine general_read_wrf_mass - - subroutine fill_regional_2d(fld_in,fld_out) - !$$$ subprogram documentation block - ! . . . . - ! subprogram: fill_regional_2d - ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 - ! - ! abstract: create a column vector for the subdomain (including halo) - ! from global 2d grid. - ! - ! - ! program history log: - ! 2010-08-11 parrish, initial documentation - ! 2012-03-12 whitaker, remove nx,ny,itotsub from argument list. - ! - ! input argument list: - ! - ! output argument list: - ! - ! attributes: - ! language: f90 - ! machine: ibm RS/6000 SP - ! - !$$$ end documentation block - use kinds, only: r_kind,i_kind - use hybrid_ensemble_parameters, only: grd_ens - implicit none - real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon)::fld_in - real(r_kind),dimension(grd_ens%itotsub)::fld_out - integer(i_kind):: i,j,k - do k=1,grd_ens%itotsub - i=grd_ens%ltosj_s(k) - j=grd_ens%ltosi_s(k) - fld_out(k)=fld_in(j,i) - enddo - return - end subroutine fill_regional_2d - subroutine ens_spread_dualres_regional_wrf(this,mype,en_perts,nelen,en_bar) - !$$$ subprogram documentation block - ! . . . . - ! subprogram: ens_spread_dualres_regional - ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 - ! - ! abstract: - ! - ! - ! program history log: - ! 2010-08-11 parrish, initial documentation - ! 2011-04-05 parrish - add pseudo-bundle capability - ! 2011-08-31 todling - revisit en_perts (single-prec) in light of extended bundle - ! - ! input argument list: - ! en_bar - ensemble mean - ! mype - current processor number - ! - ! output argument list: - ! - ! attributes: - ! language: f90 - ! machine: ibm RS/6000 SP - ! - !$$$ end documentation block - ! - use kinds, only: r_single,r_kind,i_kind - use hybrid_ensemble_parameters, only: n_ens,grd_ens,grd_anl,p_e2a,uv_hyb_ens, & - regional_ensemble_option - use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sube2suba - use constants, only: zero,two,half,one - use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d - use gsi_bundlemod, only: gsi_bundlecreate - use gsi_bundlemod, only: gsi_grid - use gsi_bundlemod, only: gsi_bundle - use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_bundlemod, only: gsi_bundledestroy - use gsi_bundlemod, only: gsi_gridcreate - implicit none - - class(get_wrf_mass_ensperts_class), intent(inout) :: this - type(gsi_bundle),OPTIONAL,intent(in):: en_bar - integer(i_kind),intent(in):: mype - type(gsi_bundle),allocatable, intent(in ) :: en_perts(:,:) - integer(i_kind), intent(in ):: nelen - - type(gsi_bundle):: sube,suba - type(gsi_grid):: grid_ens,grid_anl - real(r_kind) sp_norm,sig_norm_sq_inv - type(sub2grid_info)::se,sa - integer(i_kind) k - - integer(i_kind) i,n,ic3 - logical regional - integer(i_kind) num_fields,inner_vars,istat,istatus - logical,allocatable::vector(:) - real(r_kind),pointer,dimension(:,:,:):: st,vp,tv,rh,oz,cw - real(r_kind),pointer,dimension(:,:):: ps - real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig),target::dum3 - real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2),target::dum2 - - associate( this => this ) ! eliminates warning for unused dummy argument needed for binding - end associate - - ! create simple regular grid - call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) - call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) - - ! create two internal bundles, one on analysis grid and one on ensemble grid - - call gsi_bundlecreate (suba,grid_anl,'ensemble work',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)' in ens_spread_dualres_regional: trouble creating bundle_anl bundle' - call stop2(999) - endif - call gsi_bundlecreate (sube,grid_ens,'ensemble work ens',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)' ens_spread_dualres_regional: trouble creating bundle_ens bundle' - call stop2(999) - endif - - sp_norm=(one/float(n_ens)) - - sube%values=zero - ! - - if(regional_ensemble_option == 1)then - print *,'global ensemble' - sig_norm_sq_inv=n_ens-one - - do n=1,n_ens - do i=1,nelen - sube%values(i)=sube%values(i) & - +en_perts(n,1)%valuesr4(i)*en_perts(n,1)%valuesr4(i) - end do - end do - - do i=1,nelen - sube%values(i) = sqrt(sp_norm*sig_norm_sq_inv*sube%values(i)) - end do - else - do n=1,n_ens - do i=1,nelen - sube%values(i)=sube%values(i) & - +(en_perts(n,1)%valuesr4(i)-en_bar%values(i))*(en_perts(n,1)%valuesr4(i)-en_bar%values(i)) - end do - end do - - do i=1,nelen - sube%values(i) = sqrt(sp_norm*sube%values(i)) - end do - end if - - if(grd_ens%latlon1n == grd_anl%latlon1n) then - do i=1,nelen - suba%values(i)=sube%values(i) - end do - else - inner_vars=1 - num_fields=max(0,nc3d)*grd_ens%nsig+max(0,nc2d) - allocate(vector(num_fields)) - vector=.false. - do ic3=1,nc3d - if(trim(cvars3d(ic3))=='sf'.or.trim(cvars3d(ic3))=='vp') then - do k=1,grd_ens%nsig - vector((ic3-1)*grd_ens%nsig+k)=uv_hyb_ens - end do - end if - end do - call general_sub2grid_create_info(se,inner_vars,grd_ens%nlat,grd_ens%nlon,grd_ens%nsig,num_fields, & - regional,vector) - call general_sub2grid_create_info(sa,inner_vars,grd_anl%nlat,grd_anl%nlon,grd_anl%nsig,num_fields, & - regional,vector) - deallocate(vector) - call general_sube2suba(se,sa,p_e2a,sube%values,suba%values,regional) - end if - - dum2=zero - dum3=zero - call gsi_bundlegetpointer(suba,'sf',st,istat) - if(istat/=0) then - write(6,*)' no sf pointer in ens_spread_dualres, point st at dum3 array' - st => dum3 - end if - call gsi_bundlegetpointer(suba,'vp',vp,istat) - if(istat/=0) then - write(6,*)' no vp pointer in ens_spread_dualres, point vp at dum3 array' - vp => dum3 - end if - call gsi_bundlegetpointer(suba,'t',tv,istat) - if(istat/=0) then - write(6,*)' no t pointer in ens_spread_dualres, point tv at dum3 array' - tv => dum3 - end if - call gsi_bundlegetpointer(suba,'q',rh,istat) - if(istat/=0) then - write(6,*)' no q pointer in ens_spread_dualres, point rh at dum3 array' - rh => dum3 - end if - call gsi_bundlegetpointer(suba,'oz',oz,istat) - if(istat/=0) then - write(6,*)' no oz pointer in ens_spread_dualres, point oz at dum3 array' - oz => dum3 - end if - call gsi_bundlegetpointer(suba,'cw',cw,istat) - if(istat/=0) then - write(6,*)' no cw pointer in ens_spread_dualres, point cw at dum3 array' - cw => dum3 - end if - call gsi_bundlegetpointer(suba,'ps',ps,istat) - if(istat/=0) then - write(6,*)' no ps pointer in ens_spread_dualres, point ps at dum2 array' - ps => dum2 - end if - - call write_spread_dualres(st,vp,tv,rh,oz,cw,ps,mype) - - return - end subroutine ens_spread_dualres_regional_wrf -end module get_wrf_mass_ensperts_mod diff --git a/src/crtm_interface.f90 b/src/crtm_interface.f90 deleted file mode 100644 index 5b9427299..000000000 --- a/src/crtm_interface.f90 +++ /dev/null @@ -1,2195 +0,0 @@ -module crtm_interface -!$$$ module documentation block -! . . . -! module: crtm_interface module for setuprad. Calculates profile and calls crtm -! prgmmr: -! -! abstract: crtm_interface module for setuprad. Initializes CRTM, Calculates profile and -! calls CRTM and destroys initialization -! -! program history log: -! 2010-08-17 Derber - initial creation from intrppx -! 2011-05-06 merkova/todling - add use of q-clear calculation for AIRS -! 2011-04-08 li - (1) Add nst_gsi, itref,idtw, idtc, itz_tr to apply NSST. -! - (2) Use Tz instead of Ts as water surface temperature when nst_gsi > 1 -! - (3) add tzbgr as one of the out dummy variable -! - (4) Include tz_tr in ts calculation over water -! - (5) Change minmum temperature of water surface from 270.0 to 271.0 -! 2011-07-04 todling - fixes to run either single or double precision -! 2011-09-20 hclin - modified for modis_aod -! (1) The jacobian of wrfchem/gocart p25 species (not calculated in CRTM) -! is derived from dust1 and dust2 -! (2) skip loading geometry and surface structures for modis_aod -! (3) separate jacobian calculation for modis_aod -! 2012-01-17 sienkiewicz - pass date to crtm for SSU cell pressure -! 2013-02-25 zhu - add cold_start option for regional applications -! 2013-10-19 todling - metguess now holds background -! 2013-11-16 todling - merge in latest DTC AOD development; -! revisit handling of green-house-gases -! 2014-01-01 li - change the protection of data_s(itz_tr) -! 2014-02-26 zhu - add non zero jacobian -! 2014-04-27 eliu - add call crtm_forward to calculate clear-sky Tb under all-sky condition -! 2015-09-10 zhu - generalize enabling all-sky and using aerosol (radiance_mod & radmod) in radiance -! assimilation. use n_clouds_jac,cloud_names_jac,n_aerosols_jac,aerosol_names_jac, -! n_clouds_fwd,cloud_names_fwd, etc for difference sensors and channels -! - add handling of mixed_use of channels in a sensor (some are clear-sky, others all-sky) -! 2016-06-03 Collard - Added changes to allow for historical naming conventions -! 2017-02-24 zhu/todling - remove gmao cloud fraction treatment -! -! subroutines included: -! sub init_crtm -! sub call_crtm -! sub destroy_crtm -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -use kinds,only: r_kind,i_kind,r_single -use crtm_module, only: crtm_atmosphere_type,crtm_surface_type,crtm_geometry_type, & - crtm_options_type,crtm_rtsolution_type,crtm_destroy,crtm_options_destroy, & - crtm_options_create,crtm_options_associated,success,crtm_atmosphere_create, & - crtm_surface_create,crtm_k_matrix,crtm_forward, & - ssu_input_setvalue, & - crtm_channelinfo_type, & - crtm_surface_destroy, crtm_surface_associated, crtm_surface_zero, & - crtm_atmosphere_associated, & - crtm_atmosphere_destroy,crtm_atmosphere_zero, & - crtm_rtsolution_type, crtm_rtsolution_create, & - crtm_rtsolution_destroy, crtm_rtsolution_associated, & - crtm_irlandcoeff_classification, & - crtm_kind => fp, & - crtm_microwave_sensor => microwave_sensor -use gridmod, only: lat2,lon2,nsig,msig,nvege_type,regional,wrf_mass_regional,netcdf,use_gfs_ozone -use mpeu_util, only: die -use crtm_aod_module, only: crtm_aod_k -use radiance_mod, only: n_actual_clouds,cloud_names,n_clouds_fwd,cloud_names_fwd, & - n_clouds_jac,cloud_names_jac,n_actual_aerosols,aerosol_names,n_aerosols_fwd,aerosol_names_fwd, & - n_aerosols_jac,aerosol_names_jac,rad_obs_type,cw_cv - -implicit none - -private -public init_crtm ! Subroutine initializes crtm for specified instrument -public call_crtm ! Subroutine creates profile for crtm, calls crtm, then adjoint of create -public destroy_crtm ! Subroutine destroys initialization for crtm -public sensorindex -public surface -public isatid ! = 1 index of satellite id -public itime ! = 2 index of analysis relative obs time -public ilon ! = 3 index of grid relative obs location (x) -public ilat ! = 4 index of grid relative obs location (y) -public ilzen_ang ! = 5 index of local (satellite) zenith angle (radians) -public ilazi_ang ! = 6 index of local (satellite) azimuth angle (radians) -public iscan_ang ! = 7 index of scan (look) angle (radians) -public iscan_pos ! = 8 index of integer scan position -public iszen_ang ! = 9 index of solar zenith angle (degrees) -public isazi_ang ! = 10 index of solar azimuth angle (degrees) -public ifrac_sea ! = 11 index of ocean percentage -public ifrac_lnd ! = 12 index of land percentage -public ifrac_ice ! = 13 index of ice percentage -public ifrac_sno ! = 14 index of snow percentage -public its_sea ! = 15 index of ocean temperature -public its_lnd ! = 16 index of land temperature -public its_ice ! = 17 index of ice temperature -public its_sno ! = 18 index of snow temperature -public itsavg ! = 19 index of average temperature -public ivty ! = 20 index of vegetation type -public ivfr ! = 21 index of vegetation fraction -public isty ! = 22 index of soil type -public istp ! = 23 index of soil temperature -public ism ! = 24 index of soil moisture -public isn ! = 25 index of snow depth -public izz ! = 26 index of surface height -public idomsfc ! = 27 index of dominate surface type -public isfcr ! = 28 index of surface roughness -public iff10 ! = 29 index of ten meter wind factor -public ilone ! = 30 index of earth relative longitude (degrees) -public ilate ! = 31 index of earth relative latitude (degrees) -public iclr_sky ! = 7 index of clear sky amount (goes_img, seviri) -public isst_navy ! = 7 index of navy sst retrieval (K) (avhrr_navy) -public idata_type ! = 32 index of data type (151=day, 152=night, avhrr_navy) -public iclavr ! = 32 index of clavr cloud flag (avhrr) -public isst_hires ! = 33 index of interpolated hires sst -public itref ! = 34/36 index of Tr -public idtw ! = 35/37 index of d(Tw) -public idtc ! = 36/38 index of d(Tc) -public itz_tr ! = 37/39 index of d(Tz)/d(Tr) - -! Note other module variables are only used within this routine - - character(len=*), parameter :: myname='crtm_interface' - - ! Indices for the CRTM NPOESS EmisCoeff file - integer(i_kind), parameter :: INVALID_LAND = 0 - integer(i_kind), parameter :: COMPACTED_SOIL = 1 - integer(i_kind), parameter :: TILLED_SOIL = 2 - integer(i_kind), parameter :: IRRIGATED_LOW_VEGETATION = 5 - integer(i_kind), parameter :: MEADOW_GRASS = 6 - integer(i_kind), parameter :: SCRUB = 7 - integer(i_kind), parameter :: BROADLEAF_FOREST = 8 - integer(i_kind), parameter :: PINE_FOREST = 9 - integer(i_kind), parameter :: TUNDRA = 10 - integer(i_kind), parameter :: GRASS_SOIL = 11 - integer(i_kind), parameter :: BROADLEAF_PINE_FOREST = 12 - integer(i_kind), parameter :: GRASS_SCRUB = 13 - integer(i_kind), parameter :: URBAN_CONCRETE = 15 - integer(i_kind), parameter :: BROADLEAF_BRUSH = 17 - integer(i_kind), parameter :: WET_SOIL = 18 - integer(i_kind), parameter :: SCRUB_SOIL = 19 - - real(r_kind) , save ,allocatable,dimension(:,:) :: aero ! aerosol (guess) profiles at obs location - real(r_kind) , save ,allocatable,dimension(:,:) :: aero_conc ! aerosol (guess) concentrations at obs location - real(r_kind) , save ,allocatable,dimension(:) :: auxrh ! temporary array for rh profile as seen by CRTM - - character(len=20),save,allocatable,dimension(:) :: ghg_names ! names of green-house gases - - integer(i_kind), save ,allocatable,dimension(:) :: icloud ! cloud index for those considered here - integer(i_kind), save ,allocatable,dimension(:) :: jcloud ! cloud index for those fed to CRTM - real(r_kind) , save ,allocatable,dimension(:,:) :: cloud ! cloud considered here - real(r_kind) , save ,allocatable,dimension(:,:) :: cloudefr ! effective radius of cloud type in CRTM - real(r_kind) , save ,allocatable,dimension(:,:) :: cloud_cont ! cloud content fed into CRTM - real(r_kind) , save ,allocatable,dimension(:,:) :: cloud_efr ! effective radius of cloud type in CRTM - - real(r_kind) , save ,allocatable,dimension(:,:,:,:) :: gesqsat ! qsat to calc rh for aero particle size estimate - real(r_kind) , save ,allocatable,dimension(:) :: lcloud4crtm_wk ! cloud info usage index for each channel - - integer(i_kind),save, allocatable,dimension(:) :: map_to_crtm_ir - integer(i_kind),save, allocatable,dimension(:) :: map_to_crtm_mwave - integer(i_kind),save, allocatable,dimension(:) :: icw - integer(i_kind),save, allocatable,dimension(:) :: iaero_jac - integer(i_kind),save :: isatid,itime,ilon,ilat,ilzen_ang,ilazi_ang,iscan_ang - integer(i_kind),save :: iscan_pos,iszen_ang,isazi_ang,ifrac_sea,ifrac_lnd,ifrac_ice - integer(i_kind),save :: ifrac_sno,its_sea,its_lnd,its_ice,its_sno,itsavg - integer(i_kind),save :: ivty,ivfr,isty,istp,ism,isn,izz,idomsfc,isfcr,iff10,ilone,ilate - integer(i_kind),save :: iclr_sky,isst_navy,idata_type,isst_hires,iclavr - integer(i_kind),save :: itref,idtw,idtc,itz_tr,istype - integer(i_kind),save :: sensorindex - integer(i_kind),save :: ico2,ico24crtm - integer(i_kind),save :: n_actual_aerosols_wk ! number of aerosols considered - integer(i_kind),save :: n_aerosols_fwd_wk ! number of aerosols considered - integer(i_kind),save :: n_aerosols_jac_wk ! number of aerosols considered - integer(i_kind),save :: n_actual_clouds_wk ! number of clouds considered - integer(i_kind),save :: n_clouds_fwd_wk ! number of clouds considered - integer(i_kind),save :: n_clouds_jac_wk ! number of clouds considered - integer(i_kind),save :: n_ghg ! number of green-house gases - integer(i_kind),save :: itv,iqv,ioz,ius,ivs,isst - integer(i_kind),save :: indx_p25, indx_dust1, indx_dust2 - logical ,save :: lwind - logical ,save :: cld_sea_only_wk - logical ,save :: mixed_use - integer(i_kind), parameter :: min_n_absorbers = 2 - - type(crtm_atmosphere_type),save,dimension(1) :: atmosphere - type(crtm_surface_type),save,dimension(1) :: surface - type(crtm_geometry_type),save,dimension(1) :: geometryinfo - type(crtm_options_type),save,dimension(1) :: options - type(crtm_channelinfo_type),save,dimension(1) :: channelinfo - - - type(crtm_atmosphere_type),save,allocatable,dimension(:,:):: atmosphere_k - type(crtm_atmosphere_type),save,allocatable,dimension(:,:):: atmosphere_k_clr - type(crtm_surface_type),save,allocatable,dimension(:,:):: surface_k - type(crtm_surface_type),save,allocatable,dimension(:,:):: surface_k_clr - type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution - type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution0 - type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution_clr - type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution_k - type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution_k_clr - -! Mapping land surface type of GFS to CRTM -! Notes: index 0 is water, and index 13 is ice. The two indices are not -! used and just assigned to COMPACTED_SOIL. Also, since there -! is currently one relevant mapping for the global we apply -! 'crtm' in the naming convention. - integer(i_kind), parameter, dimension(0:13) :: gfs_to_crtm=(/COMPACTED_SOIL, & - BROADLEAF_FOREST, BROADLEAF_FOREST, BROADLEAF_PINE_FOREST, PINE_FOREST, & - PINE_FOREST, BROADLEAF_BRUSH, SCRUB, SCRUB, SCRUB_SOIL, TUNDRA, & - COMPACTED_SOIL, TILLED_SOIL, COMPACTED_SOIL/) -! Mapping surface classification to CRTM - integer(i_kind), parameter :: USGS_N_TYPES = 24 - integer(i_kind), parameter :: IGBP_N_TYPES = 20 - integer(i_kind), parameter :: GFS_N_TYPES = 13 - integer(i_kind), parameter :: SOIL_N_TYPES = 16 - integer(i_kind), parameter :: GFS_SOIL_N_TYPES = 9 - integer(i_kind), parameter :: GFS_VEGETATION_N_TYPES = 13 - integer(i_kind), parameter, dimension(1:USGS_N_TYPES) :: usgs_to_npoess=(/URBAN_CONCRETE, & - COMPACTED_SOIL, IRRIGATED_LOW_VEGETATION, GRASS_SOIL, MEADOW_GRASS, & - MEADOW_GRASS, MEADOW_GRASS, SCRUB, GRASS_SCRUB, MEADOW_GRASS, & - BROADLEAF_FOREST, PINE_FOREST, BROADLEAF_FOREST, PINE_FOREST, & - BROADLEAF_PINE_FOREST, INVALID_LAND, WET_SOIL, WET_SOIL, & - IRRIGATED_LOW_VEGETATION, TUNDRA, TUNDRA, TUNDRA, TUNDRA, & - INVALID_LAND/) - integer(i_kind), parameter, dimension(1:IGBP_N_TYPES) :: igbp_to_npoess=(/PINE_FOREST, & - BROADLEAF_FOREST, PINE_FOREST, BROADLEAF_FOREST, BROADLEAF_PINE_FOREST, & - SCRUB, SCRUB_SOIL, BROADLEAF_BRUSH, BROADLEAF_BRUSH, SCRUB, BROADLEAF_BRUSH, & - TILLED_SOIL, URBAN_CONCRETE, TILLED_SOIL, INVALID_LAND, COMPACTED_SOIL, & - INVALID_LAND, TUNDRA, TUNDRA, TUNDRA/) - integer(i_kind), parameter, dimension(1:USGS_N_TYPES) :: usgs_to_usgs=(/1, & - 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, & - 20, 21, 22, 23, 24/) - integer(i_kind), parameter, dimension(1:IGBP_N_TYPES) :: igbp_to_igbp=(/1, & - 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, & - 20/) - integer(i_kind), parameter, dimension(1:IGBP_N_TYPES) :: igbp_to_gfs=(/4, & - 1, 5, 2, 3, 8, 9, 6, 6, 7, 8, 12, 7, 12, 13, 11, 0, 10, 10, 11/) - integer(i_kind), parameter, dimension(1:USGS_N_TYPES) :: usgs_to_gfs=(/7, & - 12, 12, 12, 12, 12, 7, 9, 8, 6, 2, 5, 1, 4, 3, 0, 8, 8, 11, 10, 10, & - 10, 11, 13/) - ! Mapping soil types to CRTM - ! The CRTM soil types for microwave calculations are based on the - ! GFS use of the 9 category Zobler dataset. The regional soil types - ! are based on a 16 category representation of FAO/STATSGO. - integer(i_kind), parameter, dimension(1:SOIL_N_TYPES) :: map_soil_to_crtm=(/1, & - 1, 4, 2, 2, 8, 7, 2, 6, 5, 2, 3, 8, 1, 6, 9/) - -contains -subroutine init_crtm(init_pass,mype_diaghdr,mype,nchanl,isis,obstype,radmod) -!$$$ subprogram documentation block -! . . . . -! subprogram: init_crtm initializes things for use with call to crtm from setuprad -! -! prgmmr: derber org: np2 date: 2010-08-17 -! -! abstract: initialize things for use with call to crtm from setuprad. -! -! program history log: -! 2010-08-17 derber -! 2011-02-16 todling - add calculation of rh when aerosols are available -! 2011-05-03 todling - merge with Min-Jeong's MW cloudy radiance; combine w/ metguess -! 2011-05-20 mccarty - add atms wmo_sat_id hack (currently commented out) -! 2011-07-20 zhu - modified codes for lcw4crtm -! 2012-03-12 yang - modify to use ch4,n2o,and co -! 2012-12-03 eliu - add logic for RH total -! 2014-01-31 mkim - add flexibility in the variable lcw4crtm for the case when ql and -! qi are separate control variables for all-sky MW radiance DA -! 2014-04-27 eliu - add capability to call CRTM forward model to calculate -! clear-sky Tb under all-sky condition -! 2015-09-20 zhu - use centralized radiance info from radiance_mod: rad_obs_type, -! n_clouds_jac,cloud_names_jac,n_aerosols_jac,aerosol_names_jac,etc -! 2015-09-04 J.Jung - Added mods for CrIS full spectral resolution (FSR) and -! CRTM subset code for CrIS. -! -! input argument list: -! init_pass - state of "setup" processing -! mype_diaghdr - processor to produce output from crtm -! mype - current processor -! nchanl - number of channels -! isis - instrument/sensor character string -! obstype - observation type -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - - use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_chemguess_mod, only: gsi_chemguess_bundle ! for now, a common block - use gsi_chemguess_mod, only: gsi_chemguess_get - use gsi_metguess_mod, only: gsi_metguess_bundle ! for now, a common block - use gsi_metguess_mod, only: gsi_metguess_get - use crtm_module, only: mass_mixing_ratio_units,co2_id,o3_id,crtm_init, & - crtm_channelinfo_subset, crtm_channelinfo_n_channels, toa_pressure,max_n_layers, & - volume_mixing_ratio_units,h2o_id,ch4_id,n2o_id,co_id - use radinfo, only: crtm_coeffs_path - use radinfo, only: radjacindxs,radjacnames,jpch_rad,nusis,nuchan - use aeroinfo, only: aerojacindxs - use guess_grids, only: ges_tsen,ges_prsl,nfldsig - use mpeu_util, only: getindex - use constants, only: zero,max_varname_length - use obsmod, only: dval_use - use gsi_io, only: verbose - - implicit none - -! argument - logical ,intent(in) :: init_pass - integer(i_kind),intent(in) :: nchanl,mype_diaghdr,mype - character(20) ,intent(in) :: isis - character(10) ,intent(in) :: obstype - type(rad_obs_type),intent(in) :: radmod - -! local parameters - character(len=*), parameter :: myname_=myname//'*init_crtm' - -! local variables - integer(i_kind) :: ier,ii,error_status,iderivative - integer(i_kind) :: k, subset_start, subset_end - logical :: ice,Load_AerosolCoeff,Load_CloudCoeff - character(len=20),dimension(1) :: sensorlist - integer(i_kind) :: indx,iii,icloud4crtm -! ...all "additional absorber" variables - integer(i_kind) :: j,icount - integer(i_kind) :: ig - integer(i_kind) :: n_absorbers - logical quiet - logical print_verbose - - - print_verbose=.false. - if(verbose)print_verbose=.true. - isst=-1 - ivs=-1 - ius=-1 - ioz=-1 - iqv=-1 - itv=-1 -! Get indexes of variables composing the jacobian - indx =getindex(radjacnames,'tv') - if(indx>0) itv=radjacindxs(indx) - indx =getindex(radjacnames,'q' ) - if(indx>0) iqv=radjacindxs(indx) - indx =getindex(radjacnames,'oz') - if(indx>0) ioz=radjacindxs(indx) - indx =getindex(radjacnames,'u') - if(indx>0) ius=radjacindxs(indx) - indx =getindex(radjacnames,'v') - if(indx>0) ivs=radjacindxs(indx) - lwind=ius>0.and.ivs>0 - indx=getindex(radjacnames,'sst') - if(indx>0) isst=radjacindxs(indx) - -! Get indexes of variables for cloud jacobians - if (n_clouds_jac>0) then - allocate(icw(max(n_clouds_jac,1))) - icw=-1 - icount=0 - do ii=1,n_clouds_jac - indx=getindex(radjacnames,trim(cloud_names_jac(ii))) - if (indx>0) then - icount=icount+1 - icw(icount)=radjacindxs(indx) - end if - end do - end if - -! Get indexes of variables composing the jacobian_aero - if (n_actual_aerosols > 0) then - indx_p25 = getindex(aerosol_names,'p25') - indx_dust1 = getindex(aerosol_names,'dust1') - indx_dust2 = getindex(aerosol_names,'dust2') - if (n_aerosols_jac >0) then - allocate(iaero_jac(n_aerosols_jac)) - iaero_jac=-1 - icount=0 - do ii=1,n_actual_aerosols - indx=getindex(aerosol_names_jac,trim(aerosol_names(ii))) - if(indx>0) then - icount=icount+1 - iaero_jac(icount)=aerojacindxs(indx) - endif - end do - endif - endif - -! When Cloud is available in MetGuess, defined Cloudy Radiance - mixed_use=.false. - if (radmod%lcloud_fwd) then - allocate(lcloud4crtm_wk(radmod%nchannel)) - lcloud4crtm_wk(:) = radmod%lcloud4crtm(:) - do ii=1,radmod%nchannel - if (lcloud4crtm_wk(ii)<0) then - mixed_use=.true. - exit - end if - end do - - allocate(cloud_cont(msig,n_clouds_fwd)) - allocate(cloud_efr(msig,n_clouds_fwd)) - allocate(jcloud(n_clouds_fwd)) - allocate(cloud(nsig,n_clouds_fwd)) - allocate(cloudefr(nsig,n_clouds_fwd)) - allocate(icloud(n_actual_clouds)) - cloud_cont=zero - cloud_efr =zero - cloud =zero - cloudefr =zero - - call gsi_bundlegetpointer(gsi_metguess_bundle(1),cloud_names,icloud,ier) - - iii=0 - do ii=1,n_actual_clouds - call gsi_metguess_get ( 'i4crtm::'//trim(cloud_names(ii)), icloud4crtm, ier ) - if (icloud4crtm>10) then - iii=iii+1 - jcloud(iii)=ii - endif - end do - if(iii/=n_clouds_fwd) call die(myname_,'inconsistent cloud count',1) - - n_actual_clouds_wk = n_actual_clouds - n_clouds_fwd_wk = n_clouds_fwd - n_clouds_jac_wk = n_clouds_jac - cld_sea_only_wk = radmod%cld_sea_only - Load_CloudCoeff = .true. - else - n_actual_clouds_wk = 0 - n_clouds_fwd_wk = 0 - n_clouds_jac_wk = 0 - cld_sea_only_wk = .false. - Load_CloudCoeff = .false. - endif - -! Set up index for input satellite data array - - isatid = 1 ! index of satellite id - itime = 2 ! index of analysis relative obs time - ilon = 3 ! index of grid relative obs location (x) - ilat = 4 ! index of grid relative obs location (y) - ilzen_ang = 5 ! index of local (satellite) zenith angle (radians) - ilazi_ang = 6 ! index of local (satellite) azimuth angle (radians) - iscan_ang = 7 ! index of scan (look) angle (radians) - iscan_pos = 8 ! index of integer scan position - iszen_ang = 9 ! index of solar zenith angle (degrees) - isazi_ang = 10 ! index of solar azimuth angle (degrees) - ifrac_sea = 11 ! index of ocean percentage - ifrac_lnd = 12 ! index of land percentage - ifrac_ice = 13 ! index of ice percentage - ifrac_sno = 14 ! index of snow percentage - its_sea = 15 ! index of ocean temperature - its_lnd = 16 ! index of land temperature - its_ice = 17 ! index of ice temperature - its_sno = 18 ! index of snow temperature - itsavg = 19 ! index of average temperature - ivty = 20 ! index of vegetation type - ivfr = 21 ! index of vegetation fraction - isty = 22 ! index of soil type - istp = 23 ! index of soil temperature - ism = 24 ! index of soil moisture - isn = 25 ! index of snow depth - izz = 26 ! index of surface height - idomsfc = 27 ! index of dominate surface type - isfcr = 28 ! index of surface roughness - iff10 = 29 ! index of ten meter wind factor - ilone = 30 ! index of earth relative longitude (degrees) - ilate = 31 ! index of earth relative latitude (degrees) - icount=ilate - if(dval_use) icount=icount+2 - if ( obstype == 'avhrr_navy' .or. obstype == 'avhrr' ) icount=icount+2 ! when an independent SST analysis is read in - itref = icount+1 ! index of foundation temperature: Tr - idtw = icount+2 ! index of diurnal warming: d(Tw) at depth zob - idtc = icount+3 ! index of sub-layer cooling: d(Tc) at depth zob - itz_tr = icount+4 ! index of d(Tz)/d(Tr) - - if (obstype == 'goes_img') then - iclr_sky = 7 ! index of clear sky amount - elseif (obstype == 'avhrr_navy') then - isst_navy = 7 ! index of navy sst (K) retrieval - idata_type = 32 ! index of data type (151=day, 152=night) - isst_hires = 33 ! index of interpolated hires sst (K) - elseif (obstype == 'avhrr') then - iclavr = 32 ! index CLAVR cloud flag with AVHRR data - isst_hires = 33 ! index of interpolated hires sst (K) - elseif (obstype == 'seviri') then - iclr_sky = 7 ! index of clear sky amount - endif - - -! get the number of trace gases present in the chemguess bundle - n_ghg=0 - if(size(gsi_chemguess_bundle)>0) then - call gsi_chemguess_get('ghg',n_ghg,ier) - if (n_ghg>0) then - allocate(ghg_names(n_ghg)) - call gsi_chemguess_get('ghg',ghg_names,ier) - endif - endif - n_absorbers = min_n_absorbers + n_ghg - - -! Are there aerosols to affect CRTM? - if (radmod%laerosol_fwd) then - allocate(aero(nsig,n_actual_aerosols),aero_conc(msig,n_actual_aerosols),auxrh(msig)) - n_actual_aerosols_wk=n_actual_aerosols - n_aerosols_fwd_wk=n_aerosols_fwd - n_aerosols_jac_wk=n_aerosols_jac - Load_AerosolCoeff=.true. - else - n_actual_aerosols_wk=0 - n_aerosols_fwd_wk=0 - n_aerosols_jac_wk=0 - Load_AerosolCoeff=.false. - endif - - -! Initialize radiative transfer - - sensorlist(1)=isis - quiet=.not. print_verbose - if( crtm_coeffs_path /= "" ) then - if(init_pass .and. mype==mype_diaghdr .and. print_verbose) & - write(6,*)myname_,': crtm_init() on path "'//trim(crtm_coeffs_path)//'"' - error_status = crtm_init(sensorlist,channelinfo,& - Process_ID=mype,Output_Process_ID=mype_diaghdr, & - Load_CloudCoeff=Load_CloudCoeff,Load_AerosolCoeff=Load_AerosolCoeff, & - File_Path = crtm_coeffs_path,quiet=quiet ) - else - error_status = crtm_init(sensorlist,channelinfo,& - Process_ID=mype,Output_Process_ID=mype_diaghdr, & - Load_CloudCoeff=Load_CloudCoeff,Load_AerosolCoeff=Load_AerosolCoeff,& - quiet=quiet) - endif - if (error_status /= success) then - write(6,*)myname_,': ***ERROR*** crtm_init error_status=',error_status,& - ' TERMINATE PROGRAM EXECUTION' - call stop2(71) - endif - - sensorindex = 0 - if (channelinfo(1)%sensor_id == isis) then - sensorindex = 1 - - if (isis(1:4) == 'iasi' .or. & - trim(isis) == 'amsua_aqua' .or. & - isis(1:4) == 'airs' .or. & - isis(1:4) == 'cris' ) then - subset_start = 0 - subset_end = 0 - do k=1, jpch_rad - if (isis == nusis(k)) then - if (subset_start == 0) subset_start = k - subset_end = k - endif - end do - - error_status = crtm_channelinfo_subset(channelinfo(1), & - channel_subset = nuchan(subset_start:subset_end)) - - endif - -! This is to try to keep the CrIS naming conventions more flexible. -! The consistency of CRTM and BUFR files is checked in read_cris: -else if (channelinfo(1)%sensor_id(1:8) == 'cris-fsr' .AND. isis(1:8) == 'cris-fsr') then - sensorindex = 1 - subset_start = 0 - subset_end = 0 - do k=1, jpch_rad - if (isis == nusis(k)) then - if (subset_start == 0) subset_start = k - subset_end = k - endif - end do - - error_status = crtm_channelinfo_subset(channelinfo(1), & - channel_subset = nuchan(subset_start:subset_end)) - -else if (channelinfo(1)%sensor_id(1:4) == 'cris' .AND. isis(1:4) == 'cris') then - sensorindex = 1 - subset_start = 0 - subset_end = 0 - do k=1, jpch_rad - if (isis == nusis(k)) then - if (subset_start == 0) subset_start = k - subset_end = k - endif - end do - - error_status = crtm_channelinfo_subset(channelinfo(1), & - channel_subset = nuchan(subset_start:subset_end)) - -else if (channelinfo(1)%sensor_id(1:4) == 'iasi' .AND. isis(1:4) == 'iasi') then - sensorindex = 1 - subset_start = 0 - subset_end = 0 - do k=1, jpch_rad - if (isis == nusis(k)) then - if (subset_start == 0) subset_start = k - subset_end = k - endif - end do - - error_status = crtm_channelinfo_subset(channelinfo(1), & - channel_subset = nuchan(subset_start:subset_end)) - -else if (channelinfo(1)%sensor_id(1:4) == 'airs' .AND. isis(1:4) == 'airs') then - sensorindex = 1 - subset_start = 0 - subset_end = 0 - do k=1, jpch_rad - if (isis == nusis(k)) then - if (subset_start == 0) subset_start = k - subset_end = k - endif - end do - - error_status = crtm_channelinfo_subset(channelinfo(1), & - channel_subset = nuchan(subset_start:subset_end)) - -endif - - if (sensorindex == 0 ) then - write(6,*)myname_,': ***WARNING*** problem with sensorindex=',isis,& - ' --> CAN NOT PROCESS isis=',isis,' TERMINATE PROGRAM EXECUTION found ',& - channelinfo(1)%sensor_id - call stop2(71) - endif - -! Check for consistency between user specified number of channels (nchanl) -! and those defined by CRTM channelinfo structure. Return to calling -! routine if there is a mismatch. - - if (nchanl /= crtm_channelinfo_n_channels(channelinfo(sensorindex))) then - write(6,*)myname_,': ***WARNING*** mismatch between nchanl=',& - nchanl,' and n_channels=',crtm_channelinfo_n_channels(channelinfo(sensorindex)),& - ' --> CAN NOT PROCESS isis=',isis,' TERMINATE PROGRAM EXECUTION' - call stop2(71) - endif - -! Allocate structures for radiative transfer - - if (radmod%lcloud_fwd .and. (.not. mixed_use)) & - allocate(rtsolution0(channelinfo(sensorindex)%n_channels,1)) - - allocate(& - rtsolution (channelinfo(sensorindex)%n_channels,1),& - rtsolution_k(channelinfo(sensorindex)%n_channels,1),& - atmosphere_k(channelinfo(sensorindex)%n_channels,1),& - surface_k (channelinfo(sensorindex)%n_channels,1)) - if (mixed_use) allocate(& - rtsolution_clr (channelinfo(sensorindex)%n_channels,1),& - rtsolution_k_clr(channelinfo(sensorindex)%n_channels,1),& - atmosphere_k_clr(channelinfo(sensorindex)%n_channels,1),& - surface_k_clr (channelinfo(sensorindex)%n_channels,1)) - -! Check to ensure that number of levels requested does not exceed crtm max - - if(msig > max_n_layers)then - write(6,*) myname_,': msig > max_n_layers - increase crtm max_n_layers ',& - msig,max_n_layers - call stop2(36) - end if - -! Create structures for radiative transfer - - call crtm_atmosphere_create(atmosphere(1),msig,n_absorbers,n_clouds_fwd_wk,n_aerosols_fwd_wk) -!_RTod-NOTE if(r_kind==r_single .and. crtm_kind/=r_kind) then ! take care of case: GSI(single); CRTM(double) -!_RTod-NOTE call crtm_surface_create(surface(1),channelinfo(sensorindex)%n_channels,tolerance=1.0e-5_crtm_kind) -!_RTod-NOTE else -!_RTod-NOTE: the following will work in single precision but issue lots of msg and remove more obs than needed - if ( channelinfo(sensorindex)%sensor_type == crtm_microwave_sensor ) then - call crtm_surface_create(surface(1),channelinfo(sensorindex)%n_channels) - if (.NOT.(crtm_surface_associated(surface(1)))) then - write(6,*)myname_,' ***ERROR** creating surface.' - else - surface(1)%sensordata%sensor_id = channelinfo(sensorindex)%sensor_id - surface(1)%sensordata%wmo_sensor_id = channelinfo(sensorindex)%wmo_sensor_id - surface(1)%sensordata%wmo_satellite_id = channelinfo(sensorindex)%wmo_satellite_id - surface(1)%sensordata%sensor_channel = channelinfo(sensorindex)%sensor_channel - end if - end if -!_RTod-NOTE endif - if (radmod%lcloud_fwd .and. (.not. mixed_use)) & - call crtm_rtsolution_create(rtsolution0,msig) - call crtm_rtsolution_create(rtsolution,msig) - call crtm_rtsolution_create(rtsolution_k,msig) - call crtm_options_create(options,nchanl) - - if (mixed_use) then - call crtm_rtsolution_create(rtsolution_clr,msig) - call crtm_rtsolution_create(rtsolution_k_clr,msig) - end if - - if (.NOT.(crtm_atmosphere_associated(atmosphere(1)))) & - write(6,*)myname_,' ***ERROR** creating atmosphere.' - if (.NOT.(ANY(crtm_rtsolution_associated(rtsolution)))) & - write(6,*)myname_,' ***ERROR** creating rtsolution.' - if (radmod%lcloud_fwd .and. (.not. mixed_use)) then - if (.NOT.(ANY(crtm_rtsolution_associated(rtsolution0)))) & - write(6,*)' ***ERROR** creating rtsolution0.' - endif - if (.NOT.(ANY(crtm_rtsolution_associated(rtsolution_k)))) & - write(6,*)myname_,' ***ERROR** creating rtsolution_k.' - if (.NOT.(ANY(crtm_options_associated(options)))) & - write(6,*)myname_,' ***ERROR** creating options.' - -! Turn off antenna correction - - options(1)%use_antenna_correction = .false. - -! Load surface sensor data structure - - surface(1)%sensordata%n_channels = channelinfo(sensorindex)%n_channels - -!! REL-1.2 CRTM -!! surface(1)%sensordata%select_wmo_sensor_id = channelinfo(1)%wmo_sensor_id -!! RB-1.1.rev1855 CRTM - - atmosphere(1)%n_layers = msig - atmosphere(1)%absorber_id(1) = H2O_ID - atmosphere(1)%absorber_id(2) = O3_ID - atmosphere(1)%absorber_units(1) = MASS_MIXING_RATIO_UNITS - atmosphere(1)%absorber_units(2) = VOLUME_MIXING_RATIO_UNITS - atmosphere(1)%level_pressure(0) = TOA_PRESSURE - -! Currently all considered trace gases affect CRTM. Load trace gases into CRTM atmosphere - ico2=-1 - if (n_ghg>0) then - do ig=1,n_ghg - j = min_n_absorbers + ig - select case(trim(ghg_names(ig))) - case('co2'); atmosphere(1)%absorber_id(j) = CO2_ID - case('ch4'); atmosphere(1)%absorber_id(j) = CH4_ID - case('n2o'); atmosphere(1)%absorber_id(j) = N2O_ID - case('co') ; atmosphere(1)%absorber_id(j) = CO_ID - case default - call die(myname_,': invalid absorber TERMINATE PROGRAM'//trim(ghg_names(ig)),71) - end select - atmosphere(1)%absorber_units(j) = VOLUME_MIXING_RATIO_UNITS - if (trim(ghg_names(ig))=='co2') ico2=j - enddo - endif - ico24crtm=-1 - if (ico2>0) call gsi_chemguess_get ( 'i4crtm::co2', ico24crtm, ier ) - -! Allocate structure for _k arrays (jacobians) - - do ii=1,nchanl - atmosphere_k(ii,1) = atmosphere(1) - surface_k(ii,1) = surface(1) - end do - - if (mixed_use) then - do ii=1,nchanl - atmosphere_k_clr(ii,1) = atmosphere(1) - surface_k_clr(ii,1) = surface(1) - end do - end if - -! Mapping land surface type to CRTM surface fields - if (regional .or. nvege_type==IGBP_N_TYPES) then - allocate(map_to_crtm_ir(nvege_type)) - allocate(map_to_crtm_mwave(nvege_type)) - if(nvege_type==USGS_N_TYPES)then - ! Assign mapping for CRTM microwave calculations - map_to_crtm_mwave=usgs_to_gfs - ! map usgs to CRTM - select case ( TRIM(CRTM_IRlandCoeff_Classification()) ) - case('NPOESS'); map_to_crtm_ir=usgs_to_npoess - case('USGS') ; map_to_crtm_ir=usgs_to_usgs - end select - else if(nvege_type==IGBP_N_TYPES)then - ! Assign mapping for CRTM microwave calculations - map_to_crtm_mwave=igbp_to_gfs - ! nmm igbp to CRTM - select case ( TRIM(CRTM_IRlandCoeff_Classification()) ) - case('NPOESS'); map_to_crtm_ir=igbp_to_npoess - case('IGBP') ; map_to_crtm_ir=igbp_to_igbp - end select - else - write(6,*)myname_,': ***ERROR*** invalid vegetation types' & - //' for the CRTM IRland EmisCoeff file used.', & - ' (only 20 and 24 are setup) nvege_type=',nvege_type, & - ' ***STOP IN SETUPRAD***' - call stop2(71) - endif ! nvege_type - endif ! regional or IGBP - -! Calculate RH when aerosols are present and/or cloud-fraction used - if (n_actual_aerosols_wk>0) then - allocate(gesqsat(lat2,lon2,nsig,nfldsig)) - ice=.true. - iderivative=0 - do ii=1,nfldsig - call genqsat(gesqsat(1,1,1,ii),ges_tsen(1,1,1,ii),ges_prsl(1,1,1,ii),lat2,lon2,nsig,ice,iderivative) - end do - endif - - return -end subroutine init_crtm -subroutine destroy_crtm -!$$$ subprogram documentation block -! . . . . -! subprogram: destroy_crtm deallocates crtm arrays -! prgmmr: parrish org: np22 date: 2005-01-22 -! -! abstract: deallocates crtm arrays -! -! program history log: -! 2010-08-17 derber -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - implicit none - - character(len=*),parameter::myname_ = myname//'*destroy_crtm' - integer(i_kind) error_status - - error_status = crtm_destroy(channelinfo) - if (error_status /= success) & - write(6,*)myname_,': ***ERROR*** error_status=',error_status - if (n_actual_aerosols_wk>0) then - deallocate(gesqsat) - endif - call crtm_atmosphere_destroy(atmosphere(1)) - call crtm_surface_destroy(surface(1)) - if (n_clouds_fwd_wk>0 .and. (.not. mixed_use)) & - call crtm_rtsolution_destroy(rtsolution0) - call crtm_rtsolution_destroy(rtsolution) - call crtm_rtsolution_destroy(rtsolution_k) - if (mixed_use) then - call crtm_rtsolution_destroy(rtsolution_clr) - call crtm_rtsolution_destroy(rtsolution_k_clr) - end if - call crtm_options_destroy(options) - if (crtm_atmosphere_associated(atmosphere(1))) & - write(6,*)myname_,' ***ERROR** destroying atmosphere.' - if (crtm_surface_associated(surface(1))) & - write(6,*)myname_,' ***ERROR** destroying surface.' - if (ANY(crtm_rtsolution_associated(rtsolution))) & - write(6,*)myname_,' ***ERROR** destroying rtsolution.' - if (n_clouds_fwd_wk>0 .and. (.not. mixed_use)) then - if (ANY(crtm_rtsolution_associated(rtsolution0))) & - write(6,*)' ***ERROR** destroying rtsolution0.' - endif - if (ANY(crtm_rtsolution_associated(rtsolution_k))) & - write(6,*)myname_,' ***ERROR** destroying rtsolution_k.' - if (ANY(crtm_options_associated(options))) & - write(6,*)myname_,' ***ERROR** destroying options.' - deallocate(rtsolution,atmosphere_k,surface_k,rtsolution_k) - if (mixed_use) deallocate(rtsolution_clr,atmosphere_k_clr, & - surface_k_clr,rtsolution_k_clr) - if (n_clouds_fwd_wk>0 .and. (.not. mixed_use)) & - deallocate(rtsolution0) - if(n_actual_aerosols_wk>0)then - deallocate(aero,aero_conc,auxrh) - if(n_aerosols_jac_wk>0) deallocate(iaero_jac) - endif - if (n_ghg>0) then - deallocate(ghg_names) - endif - if(allocated(icloud)) deallocate(icloud) - if(allocated(cloud)) deallocate(cloud) - if(allocated(cloudefr)) deallocate(cloudefr) - if(allocated(jcloud)) deallocate(jcloud) - if(allocated(cloud_cont)) deallocate(cloud_cont) - if(allocated(cloud_efr)) deallocate(cloud_efr) - if(allocated(icw)) deallocate(icw) - if(allocated(lcloud4crtm_wk)) deallocate(lcloud4crtm_wk) - if(regional .or. nvege_type==IGBP_N_TYPES)deallocate(map_to_crtm_ir) - if(regional .or. nvege_type==IGBP_N_TYPES)deallocate(map_to_crtm_mwave) - - return -end subroutine destroy_crtm -subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & - h,q,clw_guess,prsl,prsi, & - trop5,tzbgr,dtsavg,sfc_speed,& - tsim,emissivity,ptau5,ts, & - emissivity_k,temp,wmix,jacobian,error_status,tsim_clr, & - layer_od,jacobian_aero) -!$$$ subprogram documentation block -! . . . . -! subprogram: call_crtm creates vertical profile of t,q,oz,p,zs,etc., -! calls crtm, and does adjoint of creation (where necessary) for setuprad -! prgmmr: parrish org: np22 date: 1990-10-11 -! -! abstract: creates vertical profile of t,q,oz,p,zs,etc., -! calls crtm, and does adjoint of creation (where necessary) for setuprad -! -! program history log: -! 2010-08-17 derber - modify from intrppx and add threading -! 2011-02-23 todling/da silva - revisit interface to fill in aerosols -! 2011-03-25 yang - turn off the drop-off of co2 amount when using climatological CO2 -! 2011-05-03 todling - merge with Min-Jeong's MW cloudy radiance; combine w/ metguess -! (did not include tendencies since they were calc but not used) -! 2011-05-17 auligne/todling - add handling for hydrometeors -! 2011-06-29 todling - no explict reference to internal bundle arrays -! 2011-07-05 zhu - add cloud_efr & cloudefr; add cloud_efr & jcloud in the interface of Set_CRTM_Cloud -! 2011-07-05 zhu - rewrite cloud_cont & cwj for cloud control variables (lcw4crtm) -! 2012-03-12 veldelst-- add a internal interpolation function (option) -! 2012-04-25 yang - modify to use trace gas chem_bundle. Trace gas variables are -! invoked by the global_anavinfo.ghg.l64.txt -! 2013-02-25 zhu - add cold_start option for regional applications -! 2014-01-31 mkim-- remove 60.0degree boundary for icmask for all-sky MW radiance DA -! 2014-02-26 zhu - add non zero jacobian so jacobian will be produced for -! clear-sky background or background with small amount of cloud -! 2014-04-27 eliu - add option to calculate clear-sky Tb under all-sky condition -! 2015-02-27 eliu-- wind direction fix for using CRTM FASTEM model -! 2015-03-23 zaizhong ma - add Himawari-8 ahi -! 2015-09-10 zhu - generalize enabling all-sky and aerosol usage in radiance assimilation, -! use n_clouds_fwd_wk,n_aerosols_fwd_wk,cld_sea_only_wk, cld_sea_only_wk,cw_cv,etc -! -! input argument list: -! obstype - type of observations for which to get profile -! obstime - time of observations for which to get profile -! data_s - array containing input data information -! nchanl - number of channels -! nreal - number of descriptor information in data_s -! ich - channel number array -! -! output argument list: -! h - interpolated temperature -! q - interpolated specific humidity (max(qsmall,q)) -! prsl - interpolated layer pressure (nsig) -! prsi - interpolated level pressure (nsig+1) -! trop5 - interpolated tropopause pressure -! tzbgr - water surface temperature used in Tz retrieval -! dtsavg - delta average skin temperature over surface types -! uu5 - interpolated bottom sigma level zonal wind -! vv5 - interpolated bottom sigma level meridional wind -! tsim - simulated brightness temperatures -! emissivity - surface emissivities -! ptau5 - level transmittances -! ts - skin temperature sensitivities -! emissivity_k - surface emissivity sensitivities -! temp - temperature sensitivities -! wmix - humidity sensitivities -! jacobian - nsigradjac level jacobians for use in intrad and stprad -! error_status - error status from crtm -! layer_od - layer optical depth -! jacobian_aero- nsigaerojac level jacobians for use in intaod -! tsim_clr - option to output simulated brightness temperatures for clear sky -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ -!-------- - use kinds, only: r_kind,i_kind - use mpimod, only: mype - use radinfo, only: ifactq - use radinfo, only: nsigradjac - use gsi_nstcouplermod, only: nst_gsi - use guess_grids, only: ges_tsen,& - ges_prsl,ges_prsi,tropprs,dsfct,add_rtm_layers, & - hrdifsig,nfldsig,hrdifsfc,nfldsfc,ntguessfc,isli2,sno2 - use cloud_efr_mod, only: efr_ql,efr_qi,efr_qr,efr_qs,efr_qg,efr_qh - use ncepgfs_ghg, only: co2vmr_def,ch4vmr_def,n2ovmr_def,covmr_def - use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_chemguess_mod, only: gsi_chemguess_bundle ! for now, a common block - use gsi_chemguess_mod, only: gsi_chemguess_get - use gsi_metguess_mod, only: gsi_metguess_bundle ! for now, a common block - use gsi_metguess_mod, only: gsi_metguess_get - use gridmod, only: istart,jstart,nlon,nlat,lon1 - use wrf_params_mod, only: cold_start - use constants, only: zero,half,one,one_tenth,fv,r0_05,r10,r100,r1000,constoz,grav,rad2deg, & - sqrt_tiny_r_kind,constoz,two, three, four,five,t0c - use constants, only: max_varname_length,pi - use set_crtm_aerosolmod, only: set_crtm_aerosol - use set_crtm_cloudmod, only: set_crtm_cloud - use crtm_module, only: limit_exp,o3_id - use obsmod, only: iadate - use aeroinfo, only: nsigaerojac - - implicit none - -! Declare passed variables - real(r_kind) ,intent(in ) :: obstime - integer(i_kind) ,intent(in ) :: nchanl,nreal - integer(i_kind),dimension(nchanl) ,intent(in ) :: ich - real(r_kind) ,intent( out) :: trop5,tzbgr - real(r_kind),dimension(nsig) ,intent( out) :: h,q,prsl - real(r_kind),dimension(nsig+1) ,intent( out) :: prsi - real(r_kind) ,intent( out) :: sfc_speed,dtsavg - real(r_kind),dimension(nchanl+nreal) ,intent(in ) :: data_s - real(r_kind),dimension(nchanl) ,intent( out) :: tsim,emissivity,ts,emissivity_k - character(10) ,intent(in ) :: obstype - integer(i_kind) ,intent( out) :: error_status - real(r_kind),dimension(nsig,nchanl) ,intent( out) :: temp,ptau5,wmix - real(r_kind),dimension(nsigradjac,nchanl),intent(out):: jacobian - real(r_kind) ,intent( out) :: clw_guess - real(r_kind),dimension(nchanl) ,intent( out), optional :: tsim_clr - real(r_kind),dimension(nsigaerojac,nchanl),intent(out),optional :: jacobian_aero - real(r_kind),dimension(nsig,nchanl) ,intent( out) ,optional :: layer_od - -! Declare local parameters - character(len=*),parameter::myname_=myname//'*call_crtm' - real(r_kind),parameter:: minsnow=one_tenth - real(r_kind),parameter:: qsmall = 1.e-6_r_kind - real(r_kind),parameter:: ozsmall = 1.e-10_r_kind - real(r_kind),parameter:: small_wind = 1.e-3_r_kind - real(r_kind),parameter:: windscale = 999999.0_r_kind - real(r_kind),parameter:: windlimit = 0.0001_r_kind - real(r_kind),parameter:: quadcof (4, 2 ) = & - reshape((/0.0_r_kind, 1.0_r_kind, 1.0_r_kind, 2.0_r_kind, 1.0_r_kind, & - -1.0_r_kind, 1.0_r_kind, -1.0_r_kind/), (/4, 2/)) - -! Declare local variables - integer(i_kind):: iquadrant - integer(i_kind):: ier,ii,kk,kk2,i,itype,leap_day,day_of_year - integer(i_kind):: ig,istatus - integer(i_kind):: j,k,m1,ix,ix1,ixp,iy,iy1,iyp,m,iii - integer(i_kind):: itsig,itsigp,itsfc,itsfcp - integer(i_kind):: istyp00,istyp01,istyp10,istyp11 - integer(i_kind):: iqs,iozs - integer(i_kind):: error_status_clr - integer(i_kind),dimension(8)::obs_time,anal_time - integer(i_kind),dimension(msig) :: klevel - -! ****************************** -! Constrained indexing for lai -! CRTM 2.1 implementation change -! ****************************** - integer(i_kind):: lai_type - - real(r_kind):: wind10,wind10_direction,windratio,windangle - real(r_kind):: w00,w01,w10,w11,kgkg_kgm2,f10,panglr,dx,dy -! real(r_kind):: w_weights(4) - real(r_kind):: delx,dely,delx1,dely1,dtsig,dtsigp,dtsfc,dtsfcp - real(r_kind):: sst00,sst01,sst10,sst11,total_od,term,uu5,vv5, ps - real(r_kind):: sno00,sno01,sno10,sno11,secant_term - real(r_kind),dimension(0:3):: wgtavg - real(r_kind),dimension(nsig,nchanl):: omix - real(r_kind),dimension(nsig,nchanl,n_aerosols_jac):: jaero - real(r_kind),dimension(nchanl) :: uwind_k,vwind_k - real(r_kind),dimension(msig+1) :: prsi_rtm - real(r_kind),dimension(msig) :: prsl_rtm - real(r_kind),dimension(msig) :: auxq,auxdp - real(r_kind),dimension(nsig) :: poz - real(r_kind),dimension(nsig) :: rh,qs - real(r_kind),dimension(5) :: tmp_time - real(r_kind),dimension(0:3) :: dtskin - real(r_kind),dimension(msig) :: c6 - real(r_kind),dimension(nsig) :: c2,c3,c4,c5 - real(r_kind),dimension(nsig) :: ugkg_kgm2,cwj - real(r_kind),allocatable,dimension(:,:) :: tgas1d - real(r_kind),pointer,dimension(:,: )::psges_itsig =>NULL() - real(r_kind),pointer,dimension(:,: )::psges_itsigp=>NULL() - real(r_kind),pointer,dimension(:,:,:)::uges_itsig =>NULL() - real(r_kind),pointer,dimension(:,:,:)::uges_itsigp=>NULL() - real(r_kind),pointer,dimension(:,:,:)::vges_itsig =>NULL() - real(r_kind),pointer,dimension(:,:,:)::vges_itsigp=>NULL() - real(r_kind),pointer,dimension(:,:,:)::qges_itsig =>NULL() - real(r_kind),pointer,dimension(:,:,:)::qges_itsigp=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ozges_itsig =>NULL() - real(r_kind),pointer,dimension(:,:,:)::ozges_itsigp=>NULL() - real(r_kind),pointer,dimension(:,:,:)::tgasges_itsig =>NULL() - real(r_kind),pointer,dimension(:,:,:)::tgasges_itsigp=>NULL() - real(r_kind),pointer,dimension(:,:,:)::aeroges_itsig =>NULL() - real(r_kind),pointer,dimension(:,:,:)::aeroges_itsigp=>NULL() - - logical :: sea,icmask - - integer(i_kind),parameter,dimension(12):: mday=(/0,31,59,90,& - 120,151,181,212,243,273,304,334/) - real(r_kind) :: lai - - m1=mype+1 - - dx = data_s(ilat) ! grid relative latitude - dy = data_s(ilon) ! grid relative longitude - -! Set spatial interpolation indices and weights - ix1=dx - ix1=max(1,min(ix1,nlat)) - delx=dx-ix1 - delx=max(zero,min(delx,one)) - ix=ix1-istart(m1)+2 - ixp=ix+1 - if(ix1==nlat) then - ixp=ix - end if - delx1=one-delx - - iy1=dy - dely=dy-iy1 - iy=iy1-jstart(m1)+2 - if(iy<1) then - iy1=iy1+nlon - iy=iy1-jstart(m1)+2 - end if - if(iy>lon1+1) then - iy1=iy1-nlon - iy=iy1-jstart(m1)+2 - end if - iyp=iy+1 - dely1=one-dely - - w00=delx1*dely1; w10=delx*dely1; w01=delx1*dely; w11=delx*dely -! w_weights = (/w00,w10,w01,w11/) - - -! Get time interpolation factors for sigma files - if(obstime > hrdifsig(1) .and. obstime < hrdifsig(nfldsig))then - do j=1,nfldsig-1 - if(obstime > hrdifsig(j) .and. obstime <= hrdifsig(j+1))then - itsig=j - itsigp=j+1 - dtsig=((hrdifsig(j+1)-obstime)/(hrdifsig(j+1)-hrdifsig(j))) - end if - end do - else if(obstime <=hrdifsig(1))then - itsig=1 - itsigp=1 - dtsig=one - else - itsig=nfldsig - itsigp=nfldsig - dtsig=one - end if - dtsigp=one-dtsig - -! Get time interpolation factors for surface files - if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then - do j=1,nfldsfc-1 - if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then - itsfc=j - itsfcp=j+1 - dtsfc=((hrdifsfc(j+1)-obstime)/(hrdifsfc(j+1)-hrdifsfc(j))) - end if - end do - else if(obstime <=hrdifsfc(1))then - itsfc=1 - itsfcp=1 - dtsfc=one - else - itsfc=nfldsfc - itsfcp=nfldsfc - dtsfc=one - end if - dtsfcp=one-dtsfc - - ier=0 - call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'ps',psges_itsig ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'ps',psges_itsigp,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'u' ,uges_itsig ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'u' ,uges_itsigp ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'v' ,vges_itsig ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'v' ,vges_itsigp ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'oz',ozges_itsig ,iozs) - iozs=istatus - call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'oz',ozges_itsigp,iozs) - iozs=iozs+istatus - - call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'q',qges_itsig ,istatus) - iqs=istatus - call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'q',qges_itsigp,istatus) - iqs=iqs+istatus - -! Space-time interpolation of temperature (h) and q fields from sigma files -!$omp parallel do schedule(dynamic,1) private(k,ii,iii) - do k=1,nsig - if(k == 1)then - jacobian=zero -! Set surface type flag. (Same logic as in subroutine deter_sfc) - - istyp00 = isli2(ix ,iy ) - istyp10 = isli2(ixp,iy ) - istyp01 = isli2(ix ,iyp) - istyp11 = isli2(ixp,iyp) - sno00= sno2(ix ,iy ,itsfc)*dtsfc+sno2(ix ,iy ,itsfcp)*dtsfcp - sno01= sno2(ix ,iyp,itsfc)*dtsfc+sno2(ix ,iyp,itsfcp)*dtsfcp - sno10= sno2(ixp,iy ,itsfc)*dtsfc+sno2(ixp,iy ,itsfcp)*dtsfcp - sno11= sno2(ixp,iyp,itsfc)*dtsfc+sno2(ixp,iyp,itsfcp)*dtsfcp - if(istyp00 >= 1 .and. sno00 > minsnow)istyp00 = 3 - if(istyp01 >= 1 .and. sno01 > minsnow)istyp01 = 3 - if(istyp10 >= 1 .and. sno10 > minsnow)istyp10 = 3 - if(istyp11 >= 1 .and. sno11 > minsnow)istyp11 = 3 - -! Find delta Surface temperatures for all surface types - - sst00= dsfct(ix ,iy,ntguessfc) ; sst01= dsfct(ix ,iyp,ntguessfc) - sst10= dsfct(ixp,iy,ntguessfc) ; sst11= dsfct(ixp,iyp,ntguessfc) - dtsavg=sst00*w00+sst10*w10+sst01*w01+sst11*w11 - - dtskin(0:3)=zero - wgtavg(0:3)=zero - - if(istyp00 == 1)then - wgtavg(1) = wgtavg(1) + w00 - dtskin(1)=dtskin(1)+w00*sst00 - else if(istyp00 == 2)then - wgtavg(2) = wgtavg(2) + w00 - dtskin(2)=dtskin(2)+w00*sst00 - else if(istyp00 == 3)then - wgtavg(3) = wgtavg(3) + w00 - dtskin(3)=dtskin(3)+w00*sst00 - else - wgtavg(0) = wgtavg(0) + w00 - dtskin(0)=dtskin(0)+w00*sst00 - end if - - if(istyp01 == 1)then - wgtavg(1) = wgtavg(1) + w01 - dtskin(1)=dtskin(1)+w01*sst01 - else if(istyp01 == 2)then - wgtavg(2) = wgtavg(2) + w01 - dtskin(2)=dtskin(2)+w01*sst01 - else if(istyp01 == 3)then - wgtavg(3) = wgtavg(3) + w01 - dtskin(3)=dtskin(3)+w01*sst01 - else - wgtavg(0) = wgtavg(0) + w01 - dtskin(0)=dtskin(0)+w01*sst01 - end if - - if(istyp10 == 1)then - wgtavg(1) = wgtavg(1) + w10 - dtskin(1)=dtskin(1)+w10*sst10 - else if(istyp10 == 2)then - wgtavg(2) = wgtavg(2) + w10 - dtskin(2)=dtskin(2)+w10*sst10 - else if(istyp10 == 3)then - wgtavg(3) = wgtavg(3) + w10 - dtskin(3)=dtskin(3)+w10*sst10 - else - wgtavg(0) = wgtavg(0) + w10 - dtskin(0)=dtskin(0)+w10*sst10 - end if - - if(istyp11 == 1)then - wgtavg(1) = wgtavg(1) + w11 - dtskin(1)=dtskin(1)+w11*sst11 - else if(istyp11 == 2)then - wgtavg(2) = wgtavg(2) + w11 - dtskin(2)=dtskin(2)+w11*sst11 - else if(istyp11 == 3)then - wgtavg(3) = wgtavg(3) + w11 - dtskin(3)=dtskin(3)+w11*sst11 - else - wgtavg(0) = wgtavg(0) + w11 - dtskin(0)=dtskin(0)+w11*sst11 - end if - - if(wgtavg(0) > zero)then - dtskin(0) = dtskin(0)/wgtavg(0) - else - dtskin(0) = dtsavg - end if - if(wgtavg(1) > zero)then - dtskin(1) = dtskin(1)/wgtavg(1) - else - dtskin(1) = dtsavg - end if - if(wgtavg(2) > zero)then - dtskin(2) = dtskin(2)/wgtavg(2) - else - dtskin(2) = dtsavg - end if - if(wgtavg(3) > zero)then - dtskin(3) = dtskin(3)/wgtavg(3) - else - dtskin(3) = dtsavg - end if - - if (n_clouds_fwd_wk>0) then - ps=(psges_itsig (ix,iy )*w00+psges_itsig (ixp,iy )*w10+ & - psges_itsig (ix,iyp)*w01+psges_itsig (ixp,iyp)*w11)*dtsig + & - (psges_itsigp(ix,iy )*w00+psges_itsigp(ixp,iy )*w10+ & - psges_itsigp(ix,iyp)*w01+psges_itsigp(ixp,iyp)*w11)*dtsigp - endif - -! skip loading surface structure if obstype is modis_aod - if (trim(obstype) /= 'modis_aod') then - -! Load surface structure - -! **NOTE: The model surface type --> CRTM surface type -! mapping below is specific to the versions NCEP -! GFS and NNM as of Summer 2016 - - itype = nint(data_s(ivty)) - istype = nint(data_s(isty)) - if (regional .or. nvege_type==IGBP_N_TYPES) then - itype = min(max(1,itype),nvege_type) - istype = min(max(1,istype),SOIL_N_TYPES) - if (ChannelInfo(sensorindex)%sensor_type == crtm_microwave_sensor)then - surface(1)%land_type = max(1,map_to_crtm_mwave(itype)) - else - surface(1)%land_type = max(1,map_to_crtm_ir(itype)) - end if - surface(1)%Vegetation_Type = max(1,map_to_crtm_mwave(itype)) - surface(1)%Soil_Type = map_soil_to_crtm(istype) - lai_type = map_to_crtm_mwave(itype) - elseif (nvege_type==GFS_N_TYPES) then - itype = min(max(0,itype),GFS_VEGETATION_N_TYPES) - istype = min(max(1,istype),GFS_SOIL_N_TYPES) - surface(1)%land_type = gfs_to_crtm(itype) - surface(1)%Vegetation_Type = max(1,itype) - surface(1)%Soil_Type = istype - lai_type = itype - else - write(6,*)myname_,': ***ERROR*** invalid vegetation types' & - //' the information does not match any currenctly.', & - ' supported surface type maps to the CRTM,', & - ' ***STOP IN SETUPRAD***' - call stop2(71) - end if - - if (lwind) then -! Interpolate lowest level winds to observation location - - uu5=(uges_itsig (ix,iy ,1)*w00+uges_itsig (ixp,iy ,1)*w10+ & - uges_itsig (ix,iyp,1)*w01+uges_itsig (ixp,iyp,1)*w11)*dtsig + & - (uges_itsigp(ix,iy ,1)*w00+uges_itsigp(ixp,iy ,1)*w10+ & - uges_itsigp(ix,iyp,1)*w01+uges_itsigp(ixp,iyp,1)*w11)*dtsigp - vv5=(vges_itsig (ix,iy ,1)*w00+vges_itsig (ixp,iy ,1)*w10+ & - vges_itsig (ix,iyp,1)*w01+vges_itsig (ixp,iyp,1)*w11)*dtsig + & - (vges_itsigp(ix,iy ,1)*w00+vges_itsigp(ixp,iy ,1)*w10+ & - vges_itsigp(ix,iyp,1)*w01+vges_itsigp(ixp,iyp,1)*w11)*dtsigp - f10=data_s(iff10) - sfc_speed = f10*sqrt(uu5*uu5+vv5*vv5) - wind10 = sfc_speed - if (uu5*f10 >= 0.0_r_kind .and. vv5*f10 >= 0.0_r_kind) iquadrant = 1 - if (uu5*f10 >= 0.0_r_kind .and. vv5*f10 < 0.0_r_kind) iquadrant = 2 - if (uu5*f10 < 0.0_r_kind .and. vv5*f10 >= 0.0_r_kind) iquadrant = 4 - if (uu5*f10 < 0.0_r_kind .and. vv5*f10 < 0.0_r_kind) iquadrant = 3 - if (abs(vv5*f10) >= windlimit) then - windratio = (uu5*f10) / (vv5*f10) - else - windratio = 0.0_r_kind - if (abs(uu5*f10) > windlimit) then - windratio = windscale * uu5*f10 - endif - endif - windangle = atan(abs(windratio)) ! wind azimuth is in radians - wind10_direction = quadcof(iquadrant, 1) * pi + windangle * quadcof(iquadrant, 2) - surface(1)%wind_speed = sfc_speed - surface(1)%wind_direction = rad2deg*wind10_direction - else !RTodling: not sure the following option makes any sense - surface(1)%wind_speed = zero - surface(1)%wind_direction = zero - endif - -! CRTM will reject surface coverages if greater than one and it is possible for -! these values to be larger due to round off. - - surface(1)%water_coverage = min(max(zero,data_s(ifrac_sea)),one) - surface(1)%land_coverage = min(max(zero,data_s(ifrac_lnd)),one) - surface(1)%ice_coverage = min(max(zero,data_s(ifrac_ice)),one) - surface(1)%snow_coverage = min(max(zero,data_s(ifrac_sno)),one) - -! -! get vegetation lai from summer and winter values. -! - - surface(1)%Lai = zero - if (surface(1)%land_coverage>zero) then - if(lai_type>0)then - call get_lai(data_s,nchanl,nreal,itime,ilate,lai_type,lai) - surface(1)%Lai = lai ! LAI - endif - - ! for Glacial land ice soil type and vegetation type - if(surface(1)%Soil_Type == 9 .OR. surface(1)%Vegetation_Type == 13) then - surface(1)%ice_coverage = min(surface(1)%ice_coverage + surface(1)%land_coverage, one) - surface(1)%land_coverage = zero - endif - endif - - surface(1)%water_temperature = max(data_s(its_sea)+dtskin(0),270._r_kind) - if(nst_gsi>1 .and. surface(1)%water_coverage>zero) then - surface(1)%water_temperature = max(data_s(itref)+data_s(idtw)-data_s(idtc)+dtskin(0),271._r_kind) - endif - surface(1)%land_temperature = data_s(its_lnd)+dtskin(1) - surface(1)%ice_temperature = min(data_s(its_ice)+dtskin(2),280._r_kind) - surface(1)%snow_temperature = min(data_s(its_sno)+dtskin(3),280._r_kind) - surface(1)%soil_moisture_content = data_s(ism) - surface(1)%vegetation_fraction = data_s(ivfr) - surface(1)%soil_temperature = data_s(istp) - surface(1)%snow_depth = data_s(isn) - - sea = min(max(zero,data_s(ifrac_sea)),one) >= 0.99_r_kind - icmask = (sea .and. cld_sea_only_wk) .or. (.not. cld_sea_only_wk) - -! assign tzbgr for Tz retrieval when necessary - tzbgr = surface(1)%water_temperature - - endif ! end of loading surface structure - -! Load geometry structure - -! skip loading geometry structure if obstype is modis_aod -! iscan_ang,ilzen_ang,ilazi_ang are not available in the modis aod bufr file -! also, geometryinfo is not needed in crtm aod calculation - if ( trim(obstype) /= 'modis_aod' ) then - panglr = data_s(iscan_ang) - if(obstype == 'goes_img' .or. obstype == 'seviri')panglr = zero - geometryinfo(1)%sensor_zenith_angle = data_s(ilzen_ang)*rad2deg ! local zenith angle - geometryinfo(1)%source_zenith_angle = data_s(iszen_ang) ! solar zenith angle - geometryinfo(1)%sensor_azimuth_angle = data_s(ilazi_ang) ! local zenith angle - geometryinfo(1)%source_azimuth_angle = data_s(isazi_ang) ! solar zenith angle - geometryinfo(1)%sensor_scan_angle = panglr*rad2deg ! scan angle - geometryinfo(1)%ifov = nint(data_s(iscan_pos)) ! field of view position - -! For some microwave instruments the solar and sensor azimuth angles can be -! missing (given a value of 10^11). Set these to zero to get past CRTM QC. - - if (geometryinfo(1)%source_azimuth_angle > 360.0_r_kind .OR. & - geometryinfo(1)%source_azimuth_angle < zero ) & - geometryinfo(1)%source_azimuth_angle = zero - if (geometryinfo(1)%sensor_azimuth_angle > 360.0_r_kind .OR. & - geometryinfo(1)%sensor_azimuth_angle < zero ) & - geometryinfo(1)%sensor_azimuth_angle = zero - - endif ! end of loading geometry structure - -! Special block for SSU cell pressure leakage correction. Need to compute -! observation time and load into Time component of geometryinfo structure. -! geometryinfo%time is only defined in CFSRR CRTM. - if (obstype == 'ssu') then - -! Compute absolute observation time - - anal_time=0 - obs_time=0 - tmp_time=zero - tmp_time(2)=obstime - anal_time(1)=iadate(1) - anal_time(2)=iadate(2) - anal_time(3)=iadate(3) - anal_time(5)=iadate(4) - -!external-subroutine w3movdat() - - call w3movdat(tmp_time,anal_time,obs_time) - -! Compute decimal year, for example 1/10/1983 -! d_year = 1983.0 + 10.0/365.0 - - leap_day = 0 - if( mod(obs_time(1),4)==0 ) then - if( (mod(obs_time(1),100)/=0).or.(mod(obs_time(1),400)==0) ) leap_day = 1 - endif - day_of_year = mday(obs_time(2)) + obs_time(3) - if(obs_time(2) > 2) day_of_year = day_of_year + leap_day - - call ssu_input_setvalue( options%SSU, & - Time=float(obs_time(1)) + float(day_of_year)/(365.0_r_kind+leap_day)) - - endif - -! Load surface sensor data structure - - do i=1,nchanl - - -! Set-up to return Tb jacobians. - - rtsolution_k(i,1)%radiance = zero - rtsolution_k(i,1)%brightness_temperature = one - if (mixed_use) then - rtsolution_k_clr(i,1)%radiance = zero - rtsolution_k_clr(i,1)%brightness_temperature = one - end if - - if (trim(obstype) /= 'modis_aod')then - -! Pass CRTM array of tb for surface emissiviy calculations - if ( channelinfo(1)%sensor_type == crtm_microwave_sensor .and. & - crtm_surface_associated(surface(1)) ) & - surface(1)%sensordata%tb(i) = data_s(nreal+i) - -! set up to return layer_optical_depth jacobians - rtsolution_k(i,1)%layer_optical_depth = one - if (mixed_use) rtsolution_k_clr(i,1)%layer_optical_depth = one - endif - - end do - - end if - - h(k) =(ges_tsen(ix ,iy ,k,itsig )*w00+ & - ges_tsen(ixp,iy ,k,itsig )*w10+ & - ges_tsen(ix ,iyp,k,itsig )*w01+ & - ges_tsen(ixp,iyp,k,itsig )*w11)*dtsig + & - (ges_tsen(ix ,iy ,k,itsigp)*w00+ & - ges_tsen(ixp,iy ,k,itsigp)*w10+ & - ges_tsen(ix ,iyp,k,itsigp)*w01+ & - ges_tsen(ixp,iyp,k,itsigp)*w11)*dtsigp -! Interpolate layer pressure to observation point - prsl(k)=(ges_prsl(ix ,iy ,k,itsig )*w00+ & - ges_prsl(ixp,iy ,k,itsig )*w10+ & - ges_prsl(ix ,iyp,k,itsig )*w01+ & - ges_prsl(ixp,iyp,k,itsig )*w11)*dtsig + & - (ges_prsl(ix ,iy ,k,itsigp)*w00+ & - ges_prsl(ixp,iy ,k,itsigp)*w10+ & - ges_prsl(ix ,iyp,k,itsigp)*w01+ & - ges_prsl(ixp,iyp,k,itsigp)*w11)*dtsigp -! Interpolate level pressure to observation point - prsi(k)=(ges_prsi(ix ,iy ,k,itsig )*w00+ & - ges_prsi(ixp,iy ,k,itsig )*w10+ & - ges_prsi(ix ,iyp,k,itsig )*w01+ & - ges_prsi(ixp,iyp,k,itsig )*w11)*dtsig + & - (ges_prsi(ix ,iy ,k,itsigp)*w00+ & - ges_prsi(ixp,iy ,k,itsigp)*w10+ & - ges_prsi(ix ,iyp,k,itsigp)*w01+ & - ges_prsi(ixp,iyp,k,itsigp)*w11)*dtsigp - if (iqs==0) then - q(k) =(qges_itsig (ix ,iy ,k)*w00+ & - qges_itsig (ixp,iy ,k)*w10+ & - qges_itsig (ix ,iyp,k)*w01+ & - qges_itsig (ixp,iyp,k)*w11)*dtsig + & - (qges_itsigp(ix ,iy ,k)*w00+ & - qges_itsigp(ixp,iy ,k)*w10+ & - qges_itsigp(ix ,iyp,k)*w01+ & - qges_itsigp(ixp,iyp,k)*w11)*dtsigp -! Ensure q is greater than or equal to qsmall - q(k)=max(qsmall,q(k)) - else - q(k) = qsmall - endif - c2(k)=one/(one+fv*q(k)) - c3(k)=one/(one-q(k)) - c4(k)=fv*h(k)*c2(k) - c5(k)=r1000*c3(k)*c3(k) -! Space-time interpolation of ozone(poz) - if (iozs==0) then - poz(k)=((ozges_itsig (ix ,iy ,k)*w00+ & - ozges_itsig (ixp,iy ,k)*w10+ & - ozges_itsig (ix ,iyp,k)*w01+ & - ozges_itsig (ixp,iyp,k)*w11)*dtsig + & - (ozges_itsigp(ix ,iy ,k)*w00+ & - ozges_itsigp(ixp,iy ,k)*w10+ & - ozges_itsigp(ix ,iyp,k)*w01+ & - ozges_itsigp(ixp,iyp,k)*w11)*dtsigp)*constoz - -! Ensure ozone is greater than ozsmall - - poz(k)=max(ozsmall,poz(k)) - endif ! oz -! Quantities required for MW cloudy radiance calculations - - if (n_clouds_fwd_wk>0) then - do ii=1,n_clouds_fwd_wk - iii=jcloud(ii) - cloud(k,ii) =(gsi_metguess_bundle(itsig )%r3(icloud(iii))%q(ix ,iy ,k)*w00+ & ! kg/kg - gsi_metguess_bundle(itsig )%r3(icloud(iii))%q(ixp,iy ,k)*w10+ & - gsi_metguess_bundle(itsig )%r3(icloud(iii))%q(ix ,iyp,k)*w01+ & - gsi_metguess_bundle(itsig )%r3(icloud(iii))%q(ixp,iyp,k)*w11)*dtsig + & - (gsi_metguess_bundle(itsigp)%r3(icloud(iii))%q(ix ,iy ,k)*w00+ & - gsi_metguess_bundle(itsigp)%r3(icloud(iii))%q(ixp,iy ,k)*w10+ & - gsi_metguess_bundle(itsigp)%r3(icloud(iii))%q(ix ,iyp,k)*w01+ & - gsi_metguess_bundle(itsigp)%r3(icloud(iii))%q(ixp,iyp,k)*w11)*dtsigp - cloud(k,ii)=max(cloud(k,ii),zero) - - if (regional .and. (.not. wrf_mass_regional)) then - if (trim(cloud_names(iii))== 'ql' ) then - cloudefr(k,ii)=(efr_ql(ix ,iy ,k,itsig)*w00+efr_ql(ixp,iy ,k,itsig)*w10+ & - efr_ql(ix ,iyp,k,itsig)*w01+efr_ql(ixp,iyp,k,itsig)*w11)*dtsig + & - (efr_ql(ix ,iy ,k,itsigp)*w00+efr_ql(ixp,iy ,k,itsigp)*w10+ & - efr_ql(ix ,iyp,k,itsigp)*w01+efr_ql(ixp,iyp,k,itsigp)*w11)*dtsigp - else if (trim(cloud_names(iii))== 'qi' ) then - cloudefr(k,ii)=(efr_qi(ix ,iy ,k,itsig)*w00+efr_qi(ixp,iy ,k,itsig)*w10+ & - efr_qi(ix ,iyp,k,itsig)*w01+efr_qi(ixp,iyp,k,itsig)*w11)*dtsig + & - (efr_qi(ix ,iy ,k,itsigp)*w00+efr_qi(ixp,iy ,k,itsigp)*w10+ & - efr_qi(ix ,iyp,k,itsigp)*w01+efr_qi(ixp,iyp,k,itsigp)*w11)*dtsigp - else if (trim(cloud_names(iii))== 'qs' ) then - cloudefr(k,ii)=(efr_qs(ix ,iy ,k,itsig)*w00+efr_qs(ixp,iy ,k,itsig)*w10+ & - efr_qs(ix ,iyp,k,itsig)*w01+efr_qs(ixp,iyp,k,itsig)*w11)*dtsig + & - (efr_qs(ix ,iy ,k,itsigp)*w00+efr_qs(ixp,iy ,k,itsigp)*w10+ & - efr_qs(ix ,iyp,k,itsigp)*w01+efr_qs(ixp,iyp,k,itsigp)*w11)*dtsigp - else if (trim(cloud_names(iii))== 'qg' ) then - cloudefr(k,ii)=(efr_qg(ix ,iy ,k,itsig)*w00+efr_qg(ixp,iy ,k,itsig)*w10+ & - efr_qg(ix ,iyp,k,itsig)*w01+efr_qg(ixp,iyp,k,itsig)*w11)*dtsig + & - (efr_qg(ix ,iy ,k,itsigp)*w00+efr_qg(ixp,iy ,k,itsigp)*w10+ & - efr_qg(ix ,iyp,k,itsigp)*w01+efr_qg(ixp,iyp,k,itsigp)*w11)*dtsigp - else if (trim(cloud_names(iii))== 'qh' ) then - cloudefr(k,ii)=(efr_qh(ix ,iy ,k,itsig)*w00+efr_qh(ixp,iy ,k,itsig)*w10+ & - efr_qh(ix ,iyp,k,itsig)*w01+efr_qh(ixp,iyp,k,itsig)*w11)*dtsig + & - (efr_qh(ix ,iy ,k,itsigp)*w00+efr_qh(ixp,iy ,k,itsigp)*w10+ & - efr_qh(ix ,iyp,k,itsigp)*w01+efr_qh(ixp,iyp,k,itsigp)*w11)*dtsigp - else if (trim(cloud_names(iii))== 'qr' ) then - cloudefr(k,ii)=(efr_qr(ix ,iy ,k,itsig)*w00+efr_qr(ixp,iy ,k,itsig)*w10+ & - efr_qr(ix ,iyp,k,itsig)*w01+efr_qr(ixp,iyp,k,itsig)*w11)*dtsig + & - (efr_qr(ix ,iy ,k,itsigp)*w00+efr_qr(ixp,iy ,k,itsigp)*w10+ & - efr_qr(ix ,iyp,k,itsigp)*w01+efr_qr(ixp,iyp,k,itsigp)*w11)*dtsigp - end if - end if - - end do - endif ! - end do -! Interpolate level pressure to observation point for top interface - prsi(nsig+1)=(ges_prsi(ix ,iy ,nsig+1,itsig )*w00+ & - ges_prsi(ixp,iy ,nsig+1,itsig )*w10+ & - ges_prsi(ix ,iyp,nsig+1,itsig )*w01+ & - ges_prsi(ixp,iyp,nsig+1,itsig )*w11)*dtsig + & - (ges_prsi(ix ,iy ,nsig+1,itsigp)*w00+ & - ges_prsi(ixp,iy ,nsig+1,itsigp)*w10+ & - ges_prsi(ix ,iyp,nsig+1,itsigp)*w01+ & - ges_prsi(ixp,iyp,nsig+1,itsigp)*w11)*dtsigp - -! if(any(prsl0) then - allocate (tgas1d(nsig,n_ghg)) - do ig=1,n_ghg - if(size(gsi_chemguess_bundle)==1) then - call gsi_bundlegetpointer(gsi_chemguess_bundle(1), ghg_names(ig),tgasges_itsig ,ier) - do k=1,nsig -! choice: use the internal interpolation function -! or just explicitly code, not sure which one is efficient -! tgas1d(k,ig) = crtm_interface_interp(tgasges_itsig(ix:ixp,iy:iyp,:),& -! w_weights, & -! 1.0_r_kind) - tgas1d(k,ig) =(tgasges_itsig(ix ,iy ,k)*w00+ & - tgasges_itsig(ixp,iy ,k)*w10+ & - tgasges_itsig(ix ,iyp,k)*w01+ & - tgasges_itsig(ixp,iyp,k)*w11) - enddo - else - call gsi_bundlegetpointer(gsi_chemguess_bundle(itsig ),ghg_names(ig),tgasges_itsig ,ier) - call gsi_bundlegetpointer(gsi_chemguess_bundle(itsigp),ghg_names(ig),tgasges_itsigp,ier) - do k=1,nsig -! tgas1d(k,ig) = crtm_interface_interp(tgasges_itsig(ix:ixp,iy:iyp,k),& -! w_weights, & -! dtsig) + & -! crtm_interface_interp(tgasges_itsigp(ix:ixp,iy:iyp,k),& -! w_weights, & -! dtsigp) - - - tgas1d(k,ig) =(tgasges_itsig (ix ,iy ,k)*w00+ & - tgasges_itsig (ixp,iy ,k)*w10+ & - tgasges_itsig (ix ,iyp,k)*w01+ & - tgasges_itsig (ixp,iyp,k)*w11)*dtsig + & - (tgasges_itsigp(ix ,iy ,k)*w00+ & - tgasges_itsigp(ixp,iy ,k)*w10+ & - tgasges_itsigp(ix ,iyp,k)*w01+ & - tgasges_itsigp(ixp,iyp,k)*w11)*dtsigp - enddo - endif - enddo - endif - - -! Space-time interpolation of aerosol fields from sigma files - - if(n_actual_aerosols_wk>0)then - if(size(gsi_chemguess_bundle)==1) then - do ii=1,n_actual_aerosols_wk - call gsi_bundlegetpointer(gsi_chemguess_bundle(1),aerosol_names(ii),aeroges_itsig ,ier) - do k=1,nsig - aero(k,ii) =(aeroges_itsig(ix ,iy ,k)*w00+ & - aeroges_itsig(ixp,iy ,k)*w10+ & - aeroges_itsig(ix ,iyp,k)*w01+ & - aeroges_itsig(ixp,iyp,k)*w11) - end do - enddo - else - do ii=1,n_actual_aerosols_wk - call gsi_bundlegetpointer(gsi_chemguess_bundle(itsig ),aerosol_names(ii),aeroges_itsig ,ier) - call gsi_bundlegetpointer(gsi_chemguess_bundle(itsigp),aerosol_names(ii),aeroges_itsigp,ier) - do k=1,nsig - aero(k,ii) =(aeroges_itsig (ix ,iy ,k)*w00+ & - aeroges_itsig (ixp,iy ,k)*w10+ & - aeroges_itsig (ix ,iyp,k)*w01+ & - aeroges_itsig (ixp,iyp,k)*w11)*dtsig + & - (aeroges_itsigp(ix ,iy ,k)*w00+ & - aeroges_itsigp(ixp,iy ,k)*w10+ & - aeroges_itsigp(ix ,iyp,k)*w01+ & - aeroges_itsigp(ixp,iyp,k)*w11)*dtsigp - end do - enddo - endif - do k=1,nsig - rh(k) = q(k)/qs(k) - end do - endif - - -! Find tropopause height at observation - - trop5= one_tenth*(tropprs(ix,iy )*w00+tropprs(ixp,iy )*w10+ & - tropprs(ix,iyp)*w01+tropprs(ixp,iyp)*w11) - -! Zero atmosphere jacobian structures - - call crtm_atmosphere_zero(atmosphere_k(:,:)) - call crtm_surface_zero(surface_k(:,:)) - if (mixed_use) then - call crtm_atmosphere_zero(atmosphere_k_clr(:,:)) - call crtm_surface_zero(surface_k_clr(:,:)) - end if - - clw_guess = zero - - if (n_actual_aerosols_wk>0) then - do k = 1, nsig -! Convert mixing-ratio to concentration - ugkg_kgm2(k)=1.0e-9_r_kind*(prsi(k)-prsi(k+1))*r1000/grav - aero(k,:)=aero(k,:)*ugkg_kgm2(k) - enddo - endif - - sea = min(max(zero,data_s(ifrac_sea)),one) >= 0.99_r_kind - icmask = (sea .and. cld_sea_only_wk) .or. (.not. cld_sea_only_wk) - - do k = 1,msig - -! Load profiles into extended RTM model layers - - kk = msig - k + 1 - atmosphere(1)%level_pressure(k) = r10*prsi_rtm(kk) - atmosphere(1)%pressure(k) = r10*prsl_rtm(kk) - - kk2 = klevel(kk) - atmosphere(1)%temperature(k) = h(kk2) - atmosphere(1)%absorber(k,1) = r1000*q(kk2)*c3(kk2) - if(iozs==0) then - atmosphere(1)%absorber(k,2) = poz(kk2) - else - atmosphere(1)%absorber(k,2) = O3_ID - endif - if (n_ghg > 0) then - do ig=1,n_ghg - j=min_n_absorbers+ ig - atmosphere(1)%absorber(k,j) = tgas1d(kk2,ig) - enddo - endif - - if (n_actual_aerosols_wk>0) then - aero_conc(k,:)=aero(kk2,:) - auxrh(k) =rh(kk2) - endif - -! Include cloud guess profiles in mw radiance computation - - if (n_clouds_fwd_wk>0) then - kgkg_kgm2=(atmosphere(1)%level_pressure(k)-atmosphere(1)%level_pressure(k-1))*r100/grav - if (cw_cv) then - if (icmask) then - c6(k) = kgkg_kgm2 - auxdp(k)=abs(prsi_rtm(kk+1)-prsi_rtm(kk))*r10 - auxq (k)=q(kk2) - - if (regional .and. (.not. wrf_mass_regional) .and. (.not. cold_start)) then - do ii=1,n_clouds_fwd_wk - cloud_cont(k,ii)=cloud(kk2,ii)*c6(k) - cloud_efr (k,ii)=cloudefr(kk2,ii) - end do - else - do ii=1,n_clouds_fwd_wk - cloud_cont(k,ii)=cloud(kk2,ii)*c6(k) - end do - end if - - clw_guess = clw_guess + cloud_cont(k,1) - do ii=1,n_clouds_fwd_wk - if (ii==1 .and. atmosphere(1)%temperature(k)-t0c>-20.0_r_kind) & - cloud_cont(k,1)=max(1.001_r_kind*1.0E-6_r_kind, cloud_cont(k,1)) - if (ii==2 .and. atmosphere(1)%temperature(k)-20.0_r_kind) & - cloud_cont(k,ii)=max(1.001_r_kind*1.0E-6_r_kind, cloud_cont(k,ii)) - if (trim(cloud_names_fwd(ii))=='qi' .and. atmosphere(1)%temperature(k)0) then - atmosphere(1)%n_clouds = n_clouds_fwd_wk - call Set_CRTM_Cloud (msig,n_actual_clouds_wk,cloud_names,icmask,n_clouds_fwd_wk,cloud_cont,cloud_efr,jcloud,auxdp, & - atmosphere(1)%temperature,atmosphere(1)%pressure,auxq,atmosphere(1)%cloud) - endif - -! Set aerosols for CRTM - if(n_actual_aerosols_wk>0) then - call Set_CRTM_Aerosol ( msig, n_actual_aerosols_wk, n_aerosols_fwd_wk, aerosol_names, aero_conc, auxrh, & - atmosphere(1)%aerosol ) - endif - -! Call CRTM K Matrix model - - - error_status = 0 - if ( trim(obstype) /= 'modis_aod' ) then - error_status = crtm_k_matrix(atmosphere,surface,rtsolution_k,& - geometryinfo,channelinfo(sensorindex:sensorindex),atmosphere_k,& - surface_k,rtsolution,options=options) - - if (mixed_use) then - ! Zero out data array in cloud structure - atmosphere(1)%n_clouds = 0 - error_status_clr = crtm_k_matrix(atmosphere,surface,rtsolution_k_clr,& - geometryinfo,channelinfo(sensorindex:sensorindex),atmosphere_k_clr,& - surface_k_clr,rtsolution_clr,options=options) - end if - else - error_status = crtm_aod_k(atmosphere,rtsolution_k,& - channelinfo(sensorindex:sensorindex),rtsolution,atmosphere_k) - end if - -! If the CRTM returns an error flag, do not assimilate any channels for this ob -! and set the QC flag to 10 (done in setuprad). - - if (error_status /=0) then - write(6,*)myname_,': ***ERROR*** during crtm_k_matrix call ',& - error_status - end if - -! Calculate clear-sky Tb for AMSU-A over sea when allsky condition is on - if (n_clouds_fwd_wk>0 .and. present(tsim_clr) .and. (.not. mixed_use)) then - ! Zero out data array in cloud structure: water content, effective - ! radius and variance - - atmosphere(1)%n_clouds = 0 -! call crtm_cloud_zero(atmosphere(1)%cloud) - - ! call crtm forward model for clear-sky calculation - error_status = crtm_forward(atmosphere,surface,& - geometryinfo,channelinfo(sensorindex:sensorindex),& - rtsolution0,options=options) - ! If the CRTM returns an error flag, do not assimilate any channels for this ob - ! and set the QC flag to 10 (done in setuprad). - if (error_status /=0) then - write(6,*)'CRTM_FORWARD ***ERROR*** during crtm_forward call ',& - error_status - end if - endif - - if (trim(obstype) /= 'modis_aod' ) then -! Secant of satellite zenith angle - - secant_term = one/cos(data_s(ilzen_ang)) - - if (mixed_use) then - do i=1,nchanl - if (lcloud4crtm_wk(i)<0) then - rtsolution(i,1) = rtsolution_clr(i,1) - rtsolution_k(i,1) = rtsolution_k_clr(i,1) - atmosphere_k(i,1) = atmosphere_k_clr(i,1) - surface_k(i,1) = surface_k_clr(i,1) - end if - end do - end if - -!$omp parallel do schedule(dynamic,1) private(i) & -!$omp private(total_od,k,kk,m,term,ii,cwj) - do i=1,nchanl -! Zero jacobian and transmittance arrays - do k=1,nsig - omix(k,i)=zero - temp(k,i)=zero - ptau5(k,i)=zero - wmix(k,i)=zero - end do - -! Simulated brightness temperatures - tsim(i)=rtsolution(i,1)%brightness_temperature - - if (n_clouds_fwd_wk>0 .and. present(tsim_clr)) then - if (mixed_use) then - tsim_clr(i)=rtsolution_clr(i,1)%brightness_temperature - else - tsim_clr(i)=rtsolution0(i,1)%brightness_temperature - end if - end if - -! Estimated emissivity - emissivity(i) = rtsolution(i,1)%surface_emissivity - -! Emissivity sensitivities - emissivity_k(i) = rtsolution_k(i,1)%surface_emissivity - -! Surface temperature sensitivity - if(nst_gsi > 1 .and. (data_s(itz_tr) > half .and. data_s(itz_tr) <= one) ) then - ts(i) = surface_k(i,1)%water_temperature*data_s(itz_tr) + & - surface_k(i,1)%land_temperature + & - surface_k(i,1)%ice_temperature + & - surface_k(i,1)%snow_temperature - else - ts(i) = surface_k(i,1)%water_temperature + & - surface_k(i,1)%land_temperature + & - surface_k(i,1)%ice_temperature + & - surface_k(i,1)%snow_temperature - endif - - - if (abs(ts(i))small_wind) then - term = surface_k(i,1)%wind_speed * f10*f10 / surface(1)%wind_speed - uwind_k(i) = term * uu5 - vwind_k(i) = term * vv5 - else - uwind_k(i) = zero - vwind_k(i) = zero - endif - - - total_od = zero - -! Accumulate values from extended into model layers -! temp - temperature sensitivity -! wmix - moisture sensitivity -! omix - ozone sensitivity -! ptau5 - layer transmittance - do k=1,msig - kk = klevel(msig-k+1) - temp(kk,i) = temp(kk,i) + atmosphere_k(i,1)%temperature(k) - wmix(kk,i) = wmix(kk,i) + atmosphere_k(i,1)%absorber(k,1) - omix(kk,i) = omix(kk,i) + atmosphere_k(i,1)%absorber(k,2) - total_od = total_od + rtsolution(i,1)%layer_optical_depth(k) - ptau5(kk,i) = exp(-min(limit_exp,total_od*secant_term)) - end do - -! Load jacobian array - do k=1,nsig - -! Small sensitivities for temp - if (abs(temp(k,i)) - -! Deflate moisture jacobian above the tropopause. - if (itv>=0) then - do k=1,nsig - jacobian(itv+k,i)=temp(k,i)*c2(k) ! virtual temperature sensitivity - end do ! - endif - if (iqv>=0) then - m=ich(i) - do k=1,nsig - jacobian(iqv+k,i)=c5(k)*wmix(k,i)-c4(k)*temp(k,i) ! moisture sensitivity - if (prsi(k) < trop5) then - term = (prsi(k)-trop5)/(trop5-prsi(nsig)) - jacobian(iqv+k,i) = exp(ifactq(m)*term)*jacobian(iqv+k,i) - endif - end do ! - endif - if (ioz>=0) then -! if (.not. regional .or. use_gfs_ozone)then - do k=1,nsig - jacobian(ioz+k,i)=omix(k,i)*constoz ! ozone sensitivity - end do ! -! end if - endif - - if (n_clouds_fwd_wk>0 .and. n_clouds_jac_wk>0) then - if (lcloud4crtm_wk(i)<=0) then - do ii=1,n_clouds_jac_wk - do k=1,nsig - jacobian(icw(ii)+k,i) = zero - end do - end do - else - if (icmask) then - do ii=1,n_clouds_jac_wk - do k=1,nsig - cwj(k)=zero - end do - do k=1,msig - kk = klevel(msig-k+1) - cwj(kk) = cwj(kk) + atmosphere_k(i,1)%cloud(ii)%water_content(k)*c6(k) - end do - do k=1,nsig - jacobian(icw(ii)+k,i) = cwj(k) - end do ! - end do - else - do ii=1,n_clouds_jac_wk - do k=1,nsig - jacobian(icw(ii)+k,i) = zero - end do ! - end do - endif - endif - endif - - if (ius>=0) then - jacobian(ius+1,i)=uwind_k(i) ! surface u wind sensitivity - endif - if (ivs>=0) then - jacobian(ivs+1,i)=vwind_k(i) ! surface v wind sensitivity - endif - if (isst>=0) then - jacobian(isst+1,i)=ts(i) ! surface skin temperature sensitivity - endif - end do - - else ! obstype == 'modis_aod' - ! initialize intent(out) variables that are not available with modis_aod - tzbgr = zero - sfc_speed = zero - tsim = zero - emissivity = zero - ts = zero - emissivity_k = zero - ptau5 = zero - temp = zero - wmix = zero - jaero = zero - if(present(layer_od)) layer_od = zero - if(present(jacobian_aero)) jacobian_aero = zero - do i=1,nchanl - do k=1,msig - kk = klevel(msig-k+1) - if(present(layer_od)) then - layer_od(kk,i) = layer_od(kk,i) + rtsolution(i,1)%layer_optical_depth(k) - endif - do ii=1,n_aerosols_jac_wk - if ( n_aerosols_jac_wk > n_aerosols_fwd_wk .and. ii == indx_p25 ) then - jaero(kk,i,ii) = jaero(kk,i,ii) + & - (0.5_r_kind*(0.78_r_kind*atmosphere_k(i,1)%aerosol(indx_dust1)%concentration(k) + & - 0.22_r_kind*atmosphere_k(i,1)%aerosol(indx_dust2)%concentration(k)) ) - else - jaero(kk,i,ii) = jaero(kk,i,ii) + atmosphere_k(i,1)%aerosol(ii)%concentration(k) - endif - enddo - enddo - if (present(jacobian_aero)) then - do k=1,nsig - do ii=1,n_aerosols_jac_wk - jacobian_aero(iaero_jac(ii)+k,i) = jaero(k,i,ii)*ugkg_kgm2(k) - end do - enddo - endif - enddo - endif - if (n_ghg >0) deallocate (tgas1d) -! contains - -! pure function crtm_interface_interp(a,w,dtsig) result(intresult) -! real(r_kind), intent(in) :: a(:,:) -! real(r_kind), intent(in) :: w(:,:) -! real(r_kind), intent(in) :: dtsig -! real(r_kind) :: intresult -! integer :: i, j, n -! n = size(a,dim=1) -! intresult = 0.0_r_kind -! do j = 1, n -! do i = 1, n -! intresult = intresult + a(i,j)*w(i,j) -! enddo -! enddo -! intresult = intresult * dtsig -! end function crtm_interface_interp - end subroutine call_crtm -subroutine get_lai(data_s,nchanl,nreal,itime,ilate,lai_type,lai) -!$$$ subprogram documentation block -! . . . . -! subprogram: get_lai interpolate vegetation LAI data for call_crtm -! -! prgmmr: -! -! abstract: -! -! program history log: -! -! input argument list: -! data_s - array containing input data information -! nchanl - number of channels -! nreal - number of descriptor information in data_s -! itime - index of analysis relative obs time -! ilate - index of earth relative latitude (degrees) -! -! output argument list: -! lai - interpolated vegetation leaf-area-index for various types (13) -! -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ -!-------- - use kinds, only: r_kind,i_kind - use constants, only: zero - use obsmod, only: iadate - implicit none - -! Declare passed variables - integer(i_kind) ,intent(in ) :: nchanl,nreal - real(r_kind),dimension(nchanl+nreal) ,intent(in ) :: data_s - integer(i_kind) ,intent(in ) :: itime, ilate,lai_type - real(r_kind) ,intent( out) :: lai - -! Declare local variables - integer(i_kind),dimension(8)::obs_time,anal_time - real(r_kind),dimension(5) :: tmp_time - - integer(i_kind) jdow, jdoy, jday - real(r_kind) rjday - real(r_kind),dimension(3):: dayhf - data dayhf/15.5_r_kind, 196.5_r_kind, 380.5_r_kind/ - real(r_kind),dimension(13):: lai_min, lai_max - data lai_min/3.08_r_kind, 1.85_r_kind, 2.80_r_kind, 5.00_r_kind, 1.00_r_kind, & - 0.50_r_kind, 0.52_r_kind, 0.60_r_kind, 0.50_r_kind, 0.60_r_kind, & - 0.10_r_kind, 1.56_r_kind, 0.01_r_kind / - data lai_max/6.48_r_kind, 3.31_r_kind, 5.50_r_kind, 6.40_r_kind, 5.16_r_kind, & - 3.66_r_kind, 2.90_r_kind, 2.60_r_kind, 3.66_r_kind, 2.60_r_kind, & - 0.75_r_kind, 5.68_r_kind, 0.01_r_kind / - real(r_kind),dimension(2):: lai_season - real(r_kind) wei1s, wei2s - integer(i_kind) n1, n2, mm, mmm, mmp -! - anal_time=0 - obs_time=0 - tmp_time=zero - tmp_time(2)=data_s(itime) - anal_time(1)=iadate(1) - anal_time(2)=iadate(2) - anal_time(3)=iadate(3) - anal_time(5)=iadate(4) - call w3movdat(tmp_time,anal_time,obs_time) - - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(obs_time,jdow,jdoy,jday) - rjday=jdoy+obs_time(5)/24.0_r_kind - if(rjday.lt.dayhf(1)) rjday=rjday+365.0 - - DO MM=1,2 - MMM=MM - MMP=MM+1 - IF(RJDAY.GE.DAYHF(MMM).AND.RJDAY.LT.DAYHF(MMP)) THEN - N1=MMM - N2=MMP - GO TO 10 - ENDIF - ENDDO - PRINT *,'WRONG RJDAY',RJDAY - 10 CONTINUE - WEI1S = (DAYHF(N2)-RJDAY)/(DAYHF(N2)-DAYHF(N1)) - WEI2S = (RJDAY-DAYHF(N1))/(DAYHF(N2)-DAYHF(N1)) - IF(N2.EQ.3) N2=1 - - lai_season(1) = lai_min(lai_type) - lai_season(2) = lai_max(lai_type) - if(data_s(ilate) < 0.0_r_kind) then - lai = wei1s * lai_season(n2) + wei2s * lai_season(n1) - else - lai = wei1s * lai_season(n1) + wei2s * lai_season(n2) - endif - - return - end subroutine get_lai - - end module crtm_interface diff --git a/src/cwhydromod.f90 b/src/cwhydromod.f90 deleted file mode 100644 index 275058b10..000000000 --- a/src/cwhydromod.f90 +++ /dev/null @@ -1,255 +0,0 @@ -module cwhydromod - -!$$$ module documentation block -! . . . . -! module: cwhydromod module for cw2hydro and its adjoint cw2hydro_ad -! prgmmr: yanqiu zhu -! -! abstract: module for cw2hydro and its adjoint cw2hydro_ad for cloudy radiance assimilation -! -! program history log: -! 2011-07-12 zhu - initial code -! -! -! subroutines included: -! sub init_cw2hydro -! sub destroy_cw2hydro -! sub cw2hydro -! sub cw2hydro_ad -! -! variable definitions: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -use kinds, only: r_kind,i_kind -use constants, only: zero,one,r0_05,t0c,fv,max_varname_length -use gridmod, only: lat2,lon2,nsig -use guess_grids, only: ges_tsen,ntguessig -use derivsmod, only: cwgues -use gsi_bundlemod, only: gsi_bundle -use gsi_bundlemod, only: gsi_bundlegetpointer -implicit none - -PRIVATE -PUBLIC cw2hydro_tl -PUBLIC cw2hydro_ad - - -contains - -subroutine cw2hydro(sval,clouds,nclouds) -!$$$ subprogram documentation block -! . . . . -! subprogram: cw2hydro -! prgmmr: yanqiu zhu -! -! abstract: Converts control variable cw to hydrometers -! -! program history log: -! 2011-07-12 zhu - initial code -! -! input argument list: -! sval - State variable -! wbundle - bundle for control variable -! clouds - cloud names -! -! output argument list: -! sval - State variable -! -!$$$ end documentation block - -implicit none - -! Declare passed variables -type(gsi_bundle),intent(inout):: sval -integer(i_kind),intent(in) :: nclouds -character(len=max_varname_length),intent(in):: clouds(nclouds) - -! Declare local variables -integer(i_kind) i,j,k,ic,istatus -real(r_kind),dimension(lat2,lon2,nsig) :: work -real(r_kind),pointer,dimension(:,:,:) :: sv_rank3 - -do k=1,nsig - do j=1,lon2 - do i=1,lat2 - work(i,j,k)=-r0_05*(ges_tsen(i,j,k,ntguessig)-t0c) - work(i,j,k)=max(zero,work(i,j,k)) - work(i,j,k)=min(one,work(i,j,k)) - end do - end do -end do - -! Split cw into cloud_lqw and cloud_ice, very simple for now -do ic=1,nclouds - call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) - if (istatus/=0) cycle - sv_rank3=zero - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - if (clouds(ic)=='ql') sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k)) - if (clouds(ic)=='qi') sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k) - end do - end do - end do -end do - -return -end subroutine cw2hydro - - -subroutine cw2hydro_tl(sval,wbundle,clouds,nclouds) -!$$$ subprogram documentation block -! . . . . -! subprogram: cw2hydro_tl -! prgmmr: yanqiu zhu -! -! abstract: Tangent linear of converting control variable cw to hydrometers -! -! program history log: -! 2011-07-12 zhu - initial code -! 2014-04-24 zhu - comment out temperature increment impact on cloud for now -! -! input argument list: -! sval - State variable -! wbundle - bundle for control variable -! clouds - cloud names -! -! output argument list: -! sval - State variable -! -!$$$ end documentation block - -implicit none - -! Declare passed variables -type(gsi_bundle),intent(inout):: sval -type(gsi_bundle),intent(in):: wbundle -integer(i_kind),intent(in) :: nclouds -!real(r_kind),intent(in) :: sv_tsen(lat2,lon2,nsig) -character(len=max_varname_length),intent(in):: clouds(nclouds) - -! Declare local variables -integer(i_kind) i,j,k,ic,istatus -real(r_kind),dimension(lat2,lon2,nsig) :: work0 -! real(r_kind),dimension(lat2,lon2,nsig) :: work -real(r_kind),pointer,dimension(:,:,:) :: cv_cw -real(r_kind),pointer,dimension(:,:,:) :: sv_rank3 - -! Get pointer to required control variable -call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) - -do k=1,nsig - do j=1,lon2 - do i=1,lat2 - work0(i,j,k)=-r0_05*(ges_tsen(i,j,k,ntguessig)-t0c) - work0(i,j,k)=max(zero,work0(i,j,k)) - work0(i,j,k)=min(one,work0(i,j,k)) - -! work(i,j,k)=-r0_05*sv_tsen(i,j,k) -! if (work0(i,j,k)<=zero) work(i,j,k)=zero -! if (work0(i,j,k)>=one) work(i,j,k)=zero - end do - end do -end do - -! Split cv_cw into cloud_lqw and cloud_ice, very simple for now -do ic=1,nclouds - call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) - if (istatus/=0) cycle - sv_rank3=zero - do k=1,nsig - do j=1,lon2 - do i=1,lat2 -! if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k) -! if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k) - if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k)) - if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k) - end do - end do - end do -end do - -return -end subroutine cw2hydro_tl - -subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds) -!$$$ subprogram documentation block -! . . . . -! subprogram: cw2hydro_ad -! prgmmr: yanqiu zhu -! -! abstract: adjoint of cw2hydro -! -! program history log: -! 2011-07-12 zhu - initial code -! 2014-04-24 zhu - comment out temperature increment impact on cloud for now -! -! input argument list: -! rval - State variable -! wbundle - work bundle -! clouds - cloud names -! -! output argument list: -! wbundle -! -!$$$ end documentation block - -implicit none - -! Declare passed variables -type(gsi_bundle),intent(in):: rval -type(gsi_bundle),intent(inout):: wbundle -integer(i_kind),intent(in) :: nclouds -character(len=max_varname_length),intent(in):: clouds(nclouds) - -! Declare local variables -integer(i_kind) i,j,k,ic,istatus -real(r_kind),dimension(lat2,lon2,nsig) :: work0 -real(r_kind),pointer,dimension(:,:,:) :: rv_rank3 -real(r_kind),pointer,dimension(:,:,:) :: cv_cw - -! Get pointer to required control variable -call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) -cv_cw=zero - -do k=1,nsig - do j=1,lon2 - do i=1,lat2 - work0(i,j,k)=-r0_05*(ges_tsen(i,j,k,ntguessig)-t0c) - work0(i,j,k)=max(zero,work0(i,j,k)) - work0(i,j,k)=min(one,work0(i,j,k)) - end do - end do -end do - -do ic=1,nclouds - call gsi_bundlegetpointer (rval,clouds(ic),rv_rank3,istatus) - if (istatus/=0) cycle - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - if (clouds(ic)=='ql') then - cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*(one-work0(i,j,k)) - rv_rank3(i,j,k)=zero - end if - - if (clouds(ic)=='qi') then - cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*work0(i,j,k) - rv_rank3(i,j,k)=zero - end if - - end do - end do - end do -end do - -return -end subroutine cw2hydro_ad - -end module cwhydromod diff --git a/src/enkf/CMakeLists.txt b/src/enkf/CMakeLists.txt index c6c8bd9ed..a11abac21 100644 --- a/src/enkf/CMakeLists.txt +++ b/src/enkf/CMakeLists.txt @@ -1,31 +1,45 @@ cmake_minimum_required(VERSION 2.6) -message("in enkf") if(BUILD_ENKF) enable_language (Fortran) set(Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") set(CMAKE_Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/cmake/Modules/") - if(BUILD_GFS) + if(BUILD_PRODUCTION) + set(ENKF_SUFFIX "wrf") + set(ENKF_BASE "wrf_enkf.x") + elseif(BUILD_WRF) + set(ENKF_SUFFIX "wrf") + set(ENKF_BASE "enkf_wrf") + elseif(BUILD_GFS) set(ENKF_SUFFIX "gfs") + set(ENKF_BASE "enkf_gfs") elseif(BUILD_NMMB) set(ENKF_SUFFIX "nmmb") + set(ENKF_BASE "enkf_nmmb") + elseif(BUILD_FV3reg) + set(ENKF_SUFFIX "fv3reg") + set(ENKF_BASE "enkf_fv3reg") + set(ENKF_extra_src1 read_fv3reg_restarts.f90 write_fv3reg_restarts.f90) else() set(ENKF_SUFFIX "wrf") + set(ENKF_BASE "enkf_wrf") endif() - if(USE_WRF) - set(GSILIB gsilib_wrf${debug_suffix}) - else() - set(GSILIB gsilib_global${debug_suffix}) - endif() - set(ENKF_EXTRA_SRCS gridio_${ENKF_SUFFIX}.f90 ) +# if(USE_WRF) +# set(GSILIB "gsilib_${debug_suffix}") +# else() +# set(GSILIB "gsilib_global${debug_suffix}") +# endif() + set(ENKF_EXTRA_SRCS ${ENKF_extra_src1} gridio_${ENKF_SUFFIX}.f90 ) add_library( MODS1 OBJECT gridinfo_${ENKF_SUFFIX}.f90 ) add_library( MODS2 OBJECT ${ENKF_EXTRA_SRCS} ) set(ENKFMOD_SRCS - netcdf_io_wrf.f90 params.f90 covlocal.f90 fftpack.f90 genqsat1.f90 mpisetup.F90 rnorm.f90 + netcdf_io_wrf.f90 params.f90 covlocal.f90 fftpack.f90 genqsat1.f90 mpisetup.F90 rnorm.f90 sorting.f90 specmod.f90 reducedgrid.f90 readozobs.f90 readsatobs.f90 readconvobs.f90 - write_logfile.f90 kdtree2.f90 mpi_readobs.f90 enkf_obsmod.f90 + write_logfile.f90 kdtree2.f90 mpi_readobs.f90 enkf_obsmod.f90 statevec.f90 controlvec.f90 + observer_${ENKF_SUFFIX}.f90 gridio_${ENKF_SUFFIX}.f90 gridinfo_${ENKF_SUFFIX}.f90 expand_ens.f90 + ${ENKF_extra_src1} ) set(ENKF_SRCS innovstats.f90 @@ -36,35 +50,38 @@ if(BUILD_ENKF) letkf.F90 quicksort.f90 radbias.f90 - statevec.f90 loadbal.f90 smooth_${ENKF_SUFFIX}.f90 gridio_${ENKF_SUFFIX}.f90 gridinfo_${ENKF_SUFFIX}.f90 enkf_obs_sensitivity.f90 ) - if( NOT crayComp ) - find_package( LAPACK REQUIRED ) - endif() +# if( (NOT HOST-WCOSS_C) AND (NOT HOST-WCOSS_D) ) +# find_package( LAPACK REQUIRED ) +# endif() add_definitions(${MPI_Fortran_FLAGS}) - include_directories(${CMAKE_CURRENT_BINARY_DIR} "${PROJECT_BINARY_DIR}/include/wrf" "${PROJECT_BINARY_DIR}/include/global" ${CMAKE_CURRENT_BINARY_DIR}/.. - ${MPI_Fortran_INCLUDE_DIRS} ${MPI_INCLUDE_PATH} ${CORE_INCS} - ${NETCDF_INCLUDES} ) + include_directories(${CMAKE_CURRENT_BINARY_DIR} "${PROJECT_BINARY_DIR}/include/wrf" "${PROJECT_BINARY_DIR}/include/global" ${CMAKE_CURRENT_BINARY_DIR}/.. ${MPI_Fortran_INCLUDE_DIRS} ${MPI_Fortran_INCLUDE_PATH} ${CORE_INCS} ${NETCDF_INCLUDES} ${NCDIAG_INCS} ) link_directories(${MPI_Fortran_LIBRARIES}) - + set_source_files_properties( ${ENKF_SRCS} PROPERTIES COMPILE_FLAGS ${ENKF_Fortran_FLAGS} ) set_source_files_properties( ${ENKFMOD_SRCS} PROPERTIES COMPILE_FLAGS ${ENKF_Fortran_FLAGS} ) + set_source_files_properties( ${ENKF_EXTRA_SRCS} PROPERTIES COMPILE_FLAGS ${ENKF_Fortran_FLAGS} ) add_library(enkfdeplib STATIC ${ENKFMOD_SRCS} ) add_library(enkflib STATIC ${ENKF_SRCS} $ $ ) - add_dependencies(enkfdeplib ${GSILIB} ) - add_dependencies(MODS1 enkfdeplib gsilib_shrd${debug_suffix} ${GSILIB} ) - add_dependencies(MODS2 MODS1 enkfdeplib gsilib_shrd${debug_suffix} ${GSILIB} ) - add_dependencies(enkflib enkfdeplib gsilib_shrd${debug_suffix} ${GSILIB} ) - add_executable(enkf_${ENKF_SUFFIX}.x${debug_suffix} enkf_main.f90) - add_dependencies(enkf_${ENKF_SUFFIX}.x${debug_suffix} enkflib enkfdeplib ${GSI_LIB} ) - target_link_libraries(enkf_${ENKF_SUFFIX}.x${debug_suffix} enkflib enkfdeplib gsilib_shrd${debug_suffix} ${GSILIB} ${CORE_LIBRARIES} - ${MPI_Fortran_LIBRARIES} ${LAPACK_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${GSI_LDFLAGS} ) + add_dependencies(enkfdeplib ${GSILIB} ${GSISHAREDLIB} ) + add_dependencies(MODS1 enkfdeplib ${GSILIB} ${GSISHAREDLIB} ) + add_dependencies(MODS2 MODS1 enkfdeplib ${GSILIB} ${GSISHAREDLIB} ) + add_dependencies(enkflib enkfdeplib ${GSILIB} ${GSISHAREDLIB} ) + set(ENKFEXEC "${ENKF_BASE}${debug_suffix}${GSISUFFIX}" CACHE INTERNAL "ENKF Executable name") + add_executable(${ENKFEXEC} enkf_main.f90) + target_link_libraries(${ENKFEXEC} enkflib enkfdeplib ${GSILIB} ${GSISHAREDLIB} ${CORE_LIBRARIES} + ${MPI_Fortran_LIBRARIES} ${LAPACK_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} + ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${GSI_LDFLAGS} ${CORE_BUILT} ${CORE_LIBRARIES} ${CORE_BUILT} ${NCDIAG_LIBRARIES} ${EXTRA_LINKER_FLAGS}) + install(TARGETS ${ENKFEXEC} enkfdeplib enkflib + RUNTIME DESTINATION ${CMAKE_INSTALL_PREFIX}/bin + LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib + ARCHIVE DESTINATION ${CMAKE_INSTALL_PREFIX}/lib/static) endif() diff --git a/src/enkf/Makefile b/src/enkf/Makefile deleted file mode 100644 index 628e0dc9a..000000000 --- a/src/enkf/Makefile +++ /dev/null @@ -1,381 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# EnKF Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a EnKF executable file, type -# > make or > make all -# -# 2) To make a EnKF executable file with debug options, type -# > make debug -# -# 3) To copy the EnKF load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -lnetcdff -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - #EXE_FILE = global_enkf - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../bin - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x *__genmod* - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = \ - covlocal.f90 \ - enkf.f90 \ - enkf_obs_sensitivity.f90 \ - enkf_main.f90 \ - fftpack.f90 \ - genqsat1.f90 \ - gridinfo_wrf.f90 \ - gridio_wrf.f90 \ - inflation.f90 \ - innovstats.f90 \ - kdtree2.f90 \ - letkf.F90 \ - loadbal.f90 \ - mpi_readobs.f90 \ - mpisetup.F90 \ - netcdf_io_wrf.f90 \ - enkf_obsmod.f90 \ - params.f90 \ - sorting.f90 \ - radbias.f90 \ - read_locinfo.f90 \ - readconvobs.f90 \ - readozobs.f90 \ - readsatobs.f90 \ - reducedgrid.f90 \ - rnorm.f90 \ - smooth_wrf.f90 \ - specmod.f90 \ - statevec.f90 \ - write_logfile.f90 - - SRCSF90C_NOSWAP = - - ENKFGC_SRCS = - - SRCSF77 = - - SRCSC = - - SRCS = $(SRCSF90C) $(ENKFGC_SRCS) $(SRCSF77) $(SRCSC) $(XSRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - SRCSF90_NOSWAP= ${SRCSF90C_NOSWAP:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - OBJS_NOSWAP = ${SRCSF90_NOSWAP:.f90=.o} - - GSIOBJS = $(shell find ../ -maxdepth 1 -name "*.o" -print | grep -v gsimain) - - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -$(OBJS_NOSWAP) : - @echo '---> Special handling of Fortran "native" BUFR-OPEN $<' - $(CF) -c $(FFLAGS_NOSWAP) $< - - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) $(OBJS_NOSWAP) $(GSIOBJS) - $(LD) -o $@ $(OBJS) $(OBJS_NOSWAP) $(GSIOBJS) $(LIBS) $(LDFLAGS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "FFLAGS_NOSWAP=$(FFLAGS_NOSWAP_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) $(OBJS_NOSWAP) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "FFLAGS_NOSWAP=$(FFLAGS_NOSWAP_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) $(OBJS_NOSWAP) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -# ------------------------- -# GMAO Nomenclature/targets -# ------------------------- -LIB = libenkf.a - -lib: $(LIB) - -enkf.x: $(OBJS) $(OBJS_NOSWAP) $(LIB) - $(FC) $(LDFLAGS) -o enkf.x enkf_main.o libenkf.a $(LIBsfcio) $(LIBsigio) $(LIBw3) $(LIBbacio) $(LIBbfr) $(LIBsp) $(LIBtransf) $(LIBhermes) $(LIBmpeu) $(LIBgfio) $(LIBhdf) $(LIBmpi) $(LIBsys) - -$(LIB): $(OBJS) $(OBJS_NOSWAP) - $(RM) $(LIB) - $(AR) $@ $(OBJS) $(OBJS_NOSWAP) - -export: libenkf.a enkf.x prepbykx.x - $(MKDIR) $(COREBIN) - $(CP) $(LIB) $(CORELIB) - $(CP) enkf.x $(COREBIN) - $(CP) enkf.rc.sample $(COREETC)/enkf.rc - $(CP) tlmadj_parameter.rc.sample $(COREETC)/tlmadj_parameter.rc - $(CP) gmao_airs_bufr.tbl $(COREETC)/gmao_airs_bufr.tbl - $(CP) gmao_global_pcpinfo.txt $(COREETC)/gmao_global_pcpinfo.rc - $(CP) gmao_global_satinfo.txt $(COREETC)/gmao_global_satinfo.rc - $(CP) gmao_global_ozinfo.txt $(COREETC)/gmao_global_ozinfo.rc - $(CP) gmao_global_convinfo.txt $(COREETC)/gmao_global_convinfo.rc - $(SED) -e "s^@DASPERL^$(DASPERL)^" < analyzer > $(COREBIN)/analyzer - chmod 755 $(COREBIN)/analyzer - -doc: AnIntro $(DOCSRC) - $(PROTEX) AnIntro *.f90 *.F90 > enkf.tex - $(LATEX) enkf.tex - $(LATEX) enkf.tex - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - -help: - @ echo "Available targets:" - @ echo "NCEP: make creates enkf executable " - @ echo "NPEP: make debug created enkf exec for debugging purposes" - @ echo "NCEP: make install creates enkf exec & places it in bin" - @ echo "GMAO: make lib creates enkf library" - @ echo "GMAO: make export creates lib, exec, & copies all to bin/inc/etc" - @ echo " make clean cleans objects, exec, and alien files" - @ echo " make doc creates documentation" - @ echo " make doclean clean doc-related temporary files" - diff --git a/src/enkf/Makefile.conf.cray b/src/enkf/Makefile.conf.cray deleted file mode 100644 index 719f5a521..000000000 --- a/src/enkf/Makefile.conf.cray +++ /dev/null @@ -1,151 +0,0 @@ -# This config file contains the compile options for compilation -# of the EnKF code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- -BACIO_VER = v2.0.1 -BUFR_VER = v11.0.1 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.2 -NETCDF_VER = 3.6.3 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.2.0 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/include/crtm_$(CRTM_VER) -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/include/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/$(COMPILER)/libbufr_$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/libcrtm_$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDFPATH = /usrx/local/prod/NetCDF/$(NETCDF_VER)/$(COMPILER)/haswell -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - -# WRF locations -WRFPATH = /gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-$(COMPILER) -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO EnKF building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -DGFS - #FFLAGS_F90 = -DGFS -DMPI3 # use this if MPI-3 is available (saves memory for LETKF) - EXE_FILE = global_enkf - #FFLAGS_F90 = -DWRF - #EXE_FILE = wrf_enkf - #FFLAGS_F90 = -DNMMB - #EXE_FILE = nmmb_enkf - - FFLAGS_COM_N = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC) \ - -I $(NETCDF_INCLUDE) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC)-I \ - $(NETCDF_INCLUDE) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC) \ - -I $(NETCDF_INCLUDE) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -warn all -g -traceback -debug all -check all,noarg_temp_created - FFLAGS_COM_NOSWAP_D = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC) \ - -I $(NETCDF_INCLUDE) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -warn all -g -traceback -debug all -check all,noarg_temp_created - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIBd) \ - $(W3EMC_LIBd) $(SIGIO_LIB4) $(SFCIO_LIB4) $(CRTM_LIB) \ - $(BUFR_LIBd) $(WRFLIB) $(NETCDF_LDFLAGS_F) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/enkf/Makefile.conf.jet b/src/enkf/Makefile.conf.jet deleted file mode 100644 index 8ab80257f..000000000 --- a/src/enkf/Makefile.conf.jet +++ /dev/null @@ -1,123 +0,0 @@ -# This config file contains the compile options for compilation -# of the EnKF code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -#COREINC = /contrib/nceplibs/nwprod/lib/incmod -#CORELIB = /contrib/nceplibs/nwprod/lib -#SHTNSLIB = /contrib/pythonextras/Anaconda-1.8.0/lib -COREINC = /misc/whome/Michael.Lueken/nceplibs/incmod -CORELIB = /misc/whome/Michael.Lueken/nceplibs/lib -SHTNSLIB = /pan2/projects/gfsenkf/whitaker/lib/ -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 -INCnetcdf = ${NETCDF}/include -INCnemsio = $(COREINC)/nemsio - -#WRFPATH = /contrib/nceplibs_ext/WRF/WRFV3 -WRFPATH = /misc/whome/Mingjing.Tong/WRFV3 -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) -GSILIBS = -L$(CORELIB) -lw3emc_d -lbufr_d_64 -lCRTM $(WRFLIB) -LIBnetcdf = -L$(NETCDF)/lib -lnetcdf - -# Empty out definition of libs use by GMAO EnKF building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -DGFS - #FFLAGS_F90 = -DGFS -DMPI3 # use this if MPI-3 is available (saves memory for LETKF) - EXE_FILE = global_enkf - #FFLAGS_F90 = -DWRF - #EXE_FILE = wrf_enkf - #FFLAGS_F90 = -DNMMB - #EXE_FILE = nmmb_enkf - - FFLAGS_COM_N = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -I $(INCnemsio)\ - -O3 $(ARCHINTELOPT) -warn all -implicitnone -traceback -fp-model strict -convert big_endian $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -I $(INCnemsio)\ - -O3 $(ARCHINTELOPT) -warn all -implicitnone -traceback -fp-model strict -convert big_endian $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -I $(INCnemsio)\ - -O0 -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian - FFLAGS_COM_NOSWAP_D = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -I $(INCnemsio)\ - -O0 -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(ARCHINTELOPT) $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lsp_d -lsigio_4 -lsfcio_4 -lnemsio -lbacio_4 -lw3nco_d $(GSILIBS)\ - $(LIBnetcdf) - # use this one if linking shtns lib intead of splib for spectral transforms. - #LIBS_N = -L$(CORELIB) -lsp_d -lsigio_4 -lsfcio_4 -lnemsio -lbacio_4 -lw3nco_d\ - # $(GSILIBS) $(LIBnetcdf) -L$(SHTNSLIB) -lshtns -lfftw3 - - LDFLAGS_N = -mkl=sequential $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/enkf/Makefile.conf.nco b/src/enkf/Makefile.conf.nco deleted file mode 100644 index affc34015..000000000 --- a/src/enkf/Makefile.conf.nco +++ /dev/null @@ -1,121 +0,0 @@ -# This config file contains the compile options for compilation -# of the EnKF code on the NOAA HPCS. - -# ---------------------------------- -# Define derived variables -# ---------------------------------- - -NETCDFPATH = $(NETCDF) -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -LIBwrfio_int = $(WRF_SHARED_PATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRF_SHARED_PATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRF_SHARED_PATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRF_SHARED_PATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO EnKF building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -DGFS - EXE_FILE = global_enkf - #FFLAGS_F90 = -DWRF - #EXE_FILE = wrf_enkf - #FFLAGS_F90 = -DNMMB - #EXE_FILE = nmmb_enkf - - FFLAGS_COM_N = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC) \ - -I $(NETCDF_INCLUDE) \ - -O3 -convert big_endian -assume byterecl \ - -implicitnone $(OMP) $(FFLAGS_COM) - - FFLAGS_COM_N_NOSWAP = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC)-I \ - $(NETCDF_INCLUDE) \ - -O3 -convert big_endian -assume byterecl \ - -implicitnone $(OMP) $(FFLAGS_COM) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC) \ - -I $(NETCDF_INCLUDE) \ - -O0 -convert big_endian -assume byterecl \ - -implicitnone -warn all -g -traceback -debug all -check all $(FFLAGS_COM) - FFLAGS_COM_NOSWAP_D = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC) \ - -I $(NETCDF_INCLUDE) \ - -O0 strict -convert big_endian -assume byterecl \ - -implicitnone -warn all -g -traceback -debug all -check all $(FFLAGS_COM) - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIBd) \ - $(W3EMC_LIBd) $(SIGIO_LIB4) $(SFCIO_LIB4) $(CRTM_LIB) \ - $(BUFR_LIBd) $(WRFLIB) $(NETCDF_LDFLAGS_F) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) $(LDFLAGS_COM) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -Wl,-Map,loadmap.txt $(LDFLAGS_COM) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/enkf/Makefile.conf.theia b/src/enkf/Makefile.conf.theia deleted file mode 100644 index 567c3518c..000000000 --- a/src/enkf/Makefile.conf.theia +++ /dev/null @@ -1,143 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -# - -BACIO_VER = 2.0.1 -BUFR_VER = 10.2.5 -CRTM_VER = 2.2.3 -NEMSIO_VER = 2.2.1 -SFCIO_VER = 1.0.0 -SIGIO_VER = 2.0.1 -SP_VER = 2.0.2 -W3EMC_VER = 2.0.5 -W3NCO_VER = 2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib -CORECRTM = /scratch4/NCEPDEV/da/save/Michael.Lueken/nwprod/lib - -INCsfcio = $(CORELIB)/sfcio/v$(SFCIO_VER)/incmod/sfcio_v$(SFCIO_VER)_4 -INCsigio = $(CORELIB)/sigio/v$(SIGIO_VER)/incmod/sigio_v$(SIGIO_VER)_4 -INCnemsio= $(CORELIB)/nemsio/v$(NEMSIO_VER)/incmod/nemsio_v$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/v$(BACIO_VER)/libbacio_v$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/v$(BUFR_VER)/libbufr_v$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORECRTM)/crtm/$(CRTM_VER)/libcrtm_v$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/v$(NEMSIO_VER)/libnemsio_v$(NEMSIO_VER).a -SFCIO_LIB=$(CORELIB)/sfcio/v$(SFCIO_VER)/libsfcio_v$(SFCIO_VER)_4.a -SIGIO_LIB=$(CORELIB)/sigio/v$(SIGIO_VER)/libsigio_v$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/v$(SP_VER)/libsp_v$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/v$(W3EMC_VER)/libw3emc_v$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_d.a - -WRFPATH = /scratch3/NCEPDEV/nceplibs/ext/WRF/3.7/WRFV3 -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - -INCnetcdf = ${NETCDF}/include -LIBnetcdf = -L${NETCDF}/lib -lnetcdf - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -DGFS - #FFLAGS_F90 = -DGFS -DMPI3 # use this if MPI-3 is available (saves memory for LETKF) - EXE_FILE = global_enkf - - FFLAGS_COM_N = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -O3 -xHOST -warn all -implicitnone -traceback -fp-model strict -convert big_endian $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -O3 -xHOST -warn all -implicitnone -traceback -fp-model strict -convert big_endian $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnemsio) \ - -I $(INCnetcdf) -O0 -xHOST -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian - FFLAGS_COM_NOSWAP_D = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) \ - -I $(INCnemsio) -I $(INCnetcdf) -O0 -xHOST -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options -# LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ -# -lsfcio_4 -lbufr_d_64 -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBnetcdf) -# LIBS_N = -L$(CORELIB) -lsp_d -lnemsio -lbacio_4 -lsigio_4 \ -# -lsfcio -lbufr_d_64 -lw3nco_d -lw3emc_d -lcrtm_v2.1.3 $(WRFLIB) $(LIBnetcdf) - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB) \ - $(SFCIO_LIB) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(LIBnetcdf) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud -# LIBS_N = $(LIBnemsio) -L$(CORELIB) -lsp_d -lsigio_4 \ -# -lsfcio_4 -lbufr_dc -lw3lib-2.0_d $(LIBcrtm) $(WRFLIB) $(LIBbacio) $(LIBnetcdf) - - LDFLAGS_N = -mkl -openmp - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/enkf/Makefile.conf.wcoss b/src/enkf/Makefile.conf.wcoss deleted file mode 100644 index c5d3337d8..000000000 --- a/src/enkf/Makefile.conf.wcoss +++ /dev/null @@ -1,150 +0,0 @@ -# This config file contains the compile options for compilation -# of the EnKF code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - -BACIO_VER = v2.0.1 -BUFR_VER = v10.2.5 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.1 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.0.5 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/incmod/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/incmod/sigio_$(SIGIO_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/libbufr_$(BUFR_VER)_d_64.a -#CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/libcrtm_$(CRTM_VER).a -CRTM_LIB=/da/save/Michael.Lueken/CRTM_REL-2.2.3/crtm_${CRTM_VER}/lib/libcrtm.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDF_INCLUDE = ${NETCDF}/include -NETCDF_LDFLAGS_F = -L${NETCDF}/lib -lnetcdf - - -# WRF locations -WRFPATH = /nwprod/sorc/wrf_shared.fd -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO EnKF building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -DGFS - #FFLAGS_F90 = -DGFS -DMPI3 # use this if MPI-3 is available (saves memory for LETKF) - EXE_FILE = global_enkf - #FFLAGS_F90 = -DWRF - #EXE_FILE = wrf_enkf - #FFLAGS_F90 = -DNMMB - #EXE_FILE = nmmb_enkf - - FFLAGS_COM_N = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC) \ - -I $(NETCDF_INCLUDE) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC)-I \ - $(NETCDF_INCLUDE) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC) \ - -I $(NETCDF_INCLUDE) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -warn all -g -traceback -debug all -check all - FFLAGS_COM_NOSWAP_D = -I ./ -I ../ -I $(SFCIO_INC4) -I $(SIGIO_INC4) -I $(NEMSIO_INC) \ - -I $(NETCDF_INCLUDE) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -warn all -g -traceback -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIBd) \ - $(W3EMC_LIBd) $(SIGIO_LIB4) $(SFCIO_LIB4) $(CRTM_LIB) \ - $(BUFR_LIBd) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/enkf/Makefile.conf.zeus b/src/enkf/Makefile.conf.zeus deleted file mode 100644 index d629a16ea..000000000 --- a/src/enkf/Makefile.conf.zeus +++ /dev/null @@ -1,119 +0,0 @@ -# This config file contains the compile options for compilation -# of the EnKF code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /contrib/nceplibs/nwprod/lib/incmod -CORELIB = /contrib/nceplibs/nwprod/lib -SHTNSLIB = /contrib/pythonextras/Anaconda-1.8.0/lib -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 -INCnetcdf = ${NETCDF}/include -INCnemsio = $(COREINC)/nemsio - -WRFPATH = /contrib/nceplibs_ext/WRF/WRFV3 -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) -CRTMLIB = /scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/CRTM_REL-2.2.3/crtm_v2.2.3/lib/libcrtm.a -GSILIBS = -L$(CORELIB) -lw3emc_d -lbufr_d_64 $(CRTMLIB) $(WRFLIB) - -# Empty out definition of libs use by GMAO EnKF building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -DGFS - #FFLAGS_F90 = -DGFS -DMPI3 # use this if MPI-3 is available (saves memory for LETKF) - EXE_FILE = global_enkf - #FFLAGS_F90 = -DWRF - #EXE_FILE = wrf_enkf - #FFLAGS_F90 = -DNMMB - #EXE_FILE = nmmb_enkf - - FFLAGS_COM_N = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -I $(INCnemsio)\ - -O3 -xHOST -warn all -implicitnone -traceback -fp-model strict -convert big_endian $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -I $(INCnemsio)\ - -O3 -xHOST -warn all -implicitnone -traceback -fp-model strict -convert big_endian $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -I $(INCnemsio)\ - -O0 -xHOST -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian - FFLAGS_COM_NOSWAP_D = -I ./ -I ../ -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -I $(INCnemsio)\ - -O0 -xHOST -warn all -implicitnone -traceback -g -debug full -fp-model strict -convert big_endian - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lsp_v2.0.1_d -lsigio_4 -lsfcio_4 -lnemsio -lbacio_4 -lw3nco_d $(GSILIBS)\ - -L$(NETCDF)/lib -lnetcdf - # use this one if linking shtns lib intead of splib for spectral transforms. - #LIBS_N = -L$(CORELIB) -lsp_v2.0.1_d -lsigio_4 -lsfcio_4 -lnemsio -lbacio_4 -lw3nco_d\ - # $(GSILIBS) -L$(NETCDF)/lib -lnetcdf -L$(SHTNSLIB) -lshtns -lfftw3 - - LDFLAGS_N = -mkl=sequential $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/src/enkf/Makefile.dependency b/src/enkf/Makefile.dependency deleted file mode 100644 index 99273980f..000000000 --- a/src/enkf/Makefile.dependency +++ /dev/null @@ -1,36 +0,0 @@ -covlocal.o : covlocal.f90 params.o -enkf.o : enkf.f90 rnorm.o sorting.o gridinfo_wrf.o radbias.o params.o enkf_obsmod.o statevec.o loadbal.o kdtree2.o covlocal.o mpisetup.o -enkf_main.o : enkf_main.f90 enkf_obs_sensitivity.o inflation.o letkf.o enkf.o loadbal.o statevec.o gridinfo_wrf.o innovstats.o enkf_obsmod.o mpisetup.o params.o -enkf_obsmod.o : enkf_obsmod.f90 covlocal.o mpi_readobs.o params.o mpisetup.o -enkf_obs_sensitivity.o : enkf_obs_sensitivity.f90 kdtree2.o covlocal.o loadbal.o gridinfo_wrf.o enkf_obsmod.o params.o mpisetup.o -fftpack.o : fftpack.f90 -genqsat1.o : genqsat1.f90 -gridinfo_gfs.o : gridinfo_gfs.f90 reducedgrid.o specmod_splib.o params.o mpisetup.o -gridinfo_wrf.o : gridinfo_wrf.f90 netcdf_io_wrf.o params.o mpisetup.o enkf_obsmod.o -gridio_gfs.o : gridio_gfs.f90 mpisetup.o reducedgrid.o specmod_splib.o gridinfo_gfs.o params.o -gridio_wrf.o : gridio_wrf.f90 mpisetup.o netcdf_io_wrf.o gridinfo_wrf.o params.o -inflation.o : inflation.f90 smooth_wrf.o loadbal.o gridinfo_wrf.o statevec.o covlocal.o params.o mpisetup.o -innovstats.o : innovstats.f90 params.o enkf_obsmod.o -kdtree2.o : kdtree2.f90 -letkf.o : letkf.F90 kdtree2.o gridinfo_wrf.o radbias.o params.o enkf_obsmod.o statevec.o loadbal.o covlocal.o rnorm.o mpisetup.o -loadbal.o : loadbal.f90 covlocal.o gridinfo_wrf.o kdtree2.o enkf_obsmod.o params.o mpisetup.o -mpi_readobs.o : mpi_readobs.f90 mpisetup.o readozobs.o readsatobs.o readconvobs.o -mpisetup.o : mpisetup.F90 -netcdf_io_wrf.o : netcdf_io_wrf.f90 -params.o : params.f90 mpisetup.o -quicksort.o : quicksort.f90 -radbias.o : radbias.f90 loadbal.o params.o enkf_obsmod.o mpisetup.o -readconvobs.o : readconvobs.f90 params.o -read_locinfo.o : read_locinfo.f90 mpisetup.o gridinfo_wrf.o kdtree2.o enkf_obsmod.o params.o -readozobs.o : readozobs.f90 params.o -readsatobs.o : readsatobs.f90 params.o -reducedgrid.o : reducedgrid.f90 -rnorm.o : rnorm.f90 -smooth_gfs.o : smooth_gfs.f90 specmod_splib.o reducedgrid.o gridinfo_gfs.o params.o mpisetup.o -smooth_wrf.o : smooth_wrf.f90 gridinfo_wrf.o params.o mpisetup.o -sorting.o : sorting.f90 -specmod.o : specmod.f90 -specmod_shtns.o : specmod_shtns.f90 -specmod_splib.o : specmod_splib.f90 -statevec.o : statevec.f90 enkf_obsmod.o loadbal.o params.o gridinfo_wrf.o mpisetup.o gridio_wrf.o -write_logfile.o : write_logfile.f90 params.o diff --git a/src/enkf/README b/src/enkf/README index 5c1ed5029..9f18f7fe5 100644 --- a/src/enkf/README +++ b/src/enkf/README @@ -1,51 +1,18 @@ To compile: -1) create symlink to Makefile.conf for your platform (zeus, jet or wcoss). For example, on zeus - ln -fs Makefile.conf.zeus Makefile.conf +1) create symlink to Makefile.conf for your platform (zeus, jet or wcoss). For + example, on theia -2) make sure the relevant modules are loaded on zeus, i.e. + ln -fs Makefile.conf.theia Makefile.conf + +2) make sure the relevant modules are loaded on theia, i.e. module load intel module load netcdf - module load mpt - -3) To compile global_enkf (for GFS model), edit Makefile.conf and make sure the lines - - FFLAGS_F90 = -DGFS - EXE_FILE = global_enkf - - are uncommented, and - - #FFLAGS_F90 = -DWRF - #EXE_FILE = regional_enkf - - are commented out. - -4) To compile regional enkf (for WRF model), edit Makefile.conf and make sure the lines - - FFLAGS_F90 = -DWRF - EXE_FILE = wrf_enkf - - are uncommented, and - #FFLAGS_F90 = -DGFS - #EXE_FILE = global_enkf - - are commented out. - -5) To compile enkf for NMMB model, edit Makefile.conf and make sure the lines - - FFLAGS_F90 = -DNMMB - EXE_FILE = nmmb_enkf - - are uncommented, and - - #FFLAGS_F90 = -DGFS - #EXE_FILE = global_enkf - - are commented out. - -6) make clean; make +3) To compile global_enkf (for GFS model) run 'make -f Makefile_gfs' + To compile wrf_enkf (for WRF ARW/NMM or HWRF) run 'make -f Makefile_wrf' + To compile wrf_nmmb (for NAM/NMMB) run 'make -f Makefile_nmmb' Some import namelist variables: @@ -55,4 +22,7 @@ nmmb (logical): Use nmmb model (either global or regional). Default .false. arw (logical): Use wrf-arw model if regional=.true. Default .false. nmm (logibal): Use nmm core (HWRF) if regional=.true. Default .true. +Analysis variables are determined by reading the 'anavinfo' file (same as that +used by GSI). The EnKF uses the 'control_vector_enkf:' table. + See the comments in params.f90 for other namelist variable definitions. diff --git a/src/README.EnKF b/src/enkf/README.EnKF similarity index 100% rename from src/README.EnKF rename to src/enkf/README.EnKF diff --git a/src/enkf/controlvec.f90 b/src/enkf/controlvec.f90 new file mode 100644 index 000000000..90eb5483e --- /dev/null +++ b/src/enkf/controlvec.f90 @@ -0,0 +1,366 @@ +module controlvec +!$$$ module documentation block +! +! module: controlvec read ensemble members, write out +! +! prgmmr: whitaker org: esrl/psd date: 2009-02-23 +! +! abstract: ensemble IO. +! +! Public Subroutines: +! init_controlvec: read anavinfo table for EnKF control vector +! read_control: read ensemble members for control variables on root +! write_control: write out ensemble members. Optionally save ensemble mean analysis increment. (!!!!!) +! controlvec_cleanup: deallocate allocatable arrays. +! +! Public Variables: +! nanals: (integer scalar) number of ensemble members (from module params) +! nlevs: number of analysis vertical levels (from module params). +! nbackgrounds: number of time levels in background +! +! nc3d: number of 3D control variables +! nc2d: number of 2D control variables +! cvars3d: names of 3D control variables +! cvars2d: names of 2D control variables +! ncdim: total number of 2D fields to update (nc3d*nlevs+nc2d) +! index_pres: an index array with pressure value for given state variable +! +! Modules Used: mpisetup, params, kinds, gridio, gridinfo, mpeu_util, constants +! +! program history log: +! 2009-02-23 Initial version (as statevec). +! 2009-11-28 revamped to improve IO speed +! 2015-06-29 add multiple time levels to background +! 2016-05-02 shlyaeva: Modification for reading state vector from table +! 2016-09-07 shlyaeva: moved distribution of ens members to loadbal +! 2016-11-29 shlyaeva: module renamed to controlvec (from statevec); gridinfo +! init and cleanup are called from here now + +! +! attributes: +! language: f95 +! +!$$$ + +use mpisetup +use gridio, only: readgriddata, writegriddata +use gridinfo, only: getgridinfo, gridinfo_cleanup, & + npts, vars3d_supported, vars2d_supported +use params, only: nlevs, nbackgrounds, fgfileprefixes, reducedgrid, & + nanals, pseudo_rh, use_qsatensmean, nlons, nlats,& + nanals_per_iotask, ntasks_io, nanal1, nanal2 +use kinds, only: r_kind, i_kind, r_double, r_single +use mpeu_util, only: gettablesize, gettable, getindex +use constants, only: max_varname_length +implicit none + +private + +public :: read_control, write_control, controlvec_cleanup, init_controlvec +real(r_single), public, allocatable, dimension(:,:,:,:) :: grdin +real(r_double), public, allocatable, dimension(:,:,:,:) :: qsat +real(r_double), public, allocatable, dimension(:,:,:) :: qsatmean + +integer(i_kind), public :: nc2d, nc3d, ncdim +character(len=max_varname_length), allocatable, dimension(:), public :: cvars3d +character(len=max_varname_length), allocatable, dimension(:), public :: cvars2d +integer(i_kind), public, allocatable, dimension(:) :: index_pres +integer(i_kind), public, allocatable, dimension(:) :: clevels + +contains + +subroutine init_controlvec() +! read table with control vector variables +! (code adapted from GSI state_vectors.f90 init_anasv routine +implicit none +character(len=*),parameter:: rcname='anavinfo' +character(len=*),parameter:: tbname='control_vector_enkf::' +character(len=256),allocatable,dimension(:):: utable +character(len=20) var,source,funcof +integer(i_kind) luin,ii,i,ntot, k, nvars +integer(i_kind) ilev, itracer + +! load file +luin=914 +open(luin,file=rcname,form='formatted') + +! Scan file for desired table first +! and get size of table +call gettablesize(tbname,luin,ntot,nvars) + +! Get contents of table +allocate(utable(nvars)) +call gettable(tbname,luin,ntot,nvars,utable) + +! release file unit +close(luin) + +! Retrieve each token of interest from table and define +! variables participating in control vector + +! Count variables first +nc2d=0; nc3d=0; ncdim=0; +do ii=1,nvars + read(utable(ii),*) var, ilev, itracer, source, funcof + if(ilev==1) then + nc2d=nc2d+1 + ncdim=ncdim+1 + else + nc3d=nc3d+1 + ncdim=ncdim+ilev + endif +enddo + +allocate(cvars3d(nc3d),cvars2d(nc2d),clevels(0:nc3d)) + +! Now load information from table +nc2d=0;nc3d=0 +clevels = 0 +do ii=1,nvars + read(utable(ii),*) var, ilev, itracer, source, funcof + if(ilev==1) then + nc2d=nc2d+1 + cvars2d(nc2d)=trim(adjustl(var)) + else if (ilev==nlevs .or. ilev==nlevs+1) then + nc3d=nc3d+1 + cvars3d(nc3d) = trim(adjustl(var)) + clevels(nc3d) = ilev + clevels(nc3d-1) + else + if (nproc .eq. 0) print *,'Error: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev + call stop2(503) + endif +enddo + +deallocate(utable) + +allocate(index_pres(ncdim)) +ii=0 +do i=1,nc3d + do k=1,clevels(i)-clevels(i-1) + ii = ii + 1 + index_pres(ii)=k + end do +end do +do i = 1,nc2d + ii = ii + 1 + index_pres(ii) = nlevs+1 +enddo + +! sanity checks +if (ncdim == 0) then + if (nproc == 0) print *, 'Error: there are no variables to update.' + call stop2(501) +endif + +do i = 1, nc2d + if (getindex(vars2d_supported, cvars2d(i))<0) then + if (nproc .eq. 0) then + print *,'Error: 2D variable ', cvars2d(i), ' is not supported in current version.' + print *,'Supported variables: ', vars2d_supported + endif + call stop2(502) + endif +enddo +do i = 1, nc3d + if (getindex(vars3d_supported, cvars3d(i))<0) then + if (nproc .eq. 0) then + print *,'Error: 3D variable ', cvars3d(i), ' is not supported in current version.' + print *,'Supported variables: ', vars3d_supported + endif + call stop2(502) + endif +enddo + +if (nproc == 0) then + print *, '2D control variables: ', cvars2d + print *, '3D control variables: ', cvars3d + print *, 'Control levels: ', clevels + print *, 'nc2d: ', nc2d, ', nc3d: ', nc3d, ', ncdim: ', ncdim +endif + +call getgridinfo(fgfileprefixes(nbackgrounds/2+1), reducedgrid) + +end subroutine init_controlvec + + +subroutine read_control() +! read ensemble members on IO tasks +implicit none +real(r_double) :: t1,t2 +real(r_double), allocatable, dimension(:) :: qsat_tmp +integer(i_kind) :: nb,nlev,ne +integer(i_kind) :: q_ind +integer(i_kind) :: ierr + +! must at least nanals tasks allocated. +if (numproc < ntasks_io) then + print *,'need at least ntasks =',ntasks_io,'MPI tasks, exiting ...' + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) +end if +if (npts < numproc) then + print *,'cannot allocate more than npts =',npts,'MPI tasks, exiting ...' + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) +end if + +! read in whole control vector on i/o procs - keep in memory +! (needed in write_ensemble) +if (nproc <= ntasks_io-1) then + allocate(grdin(npts,ncdim,nbackgrounds,nanals_per_iotask)) + allocate(qsat(npts,nlevs,nbackgrounds,nanals_per_iotask)) + if (nproc == 0) t1 = mpi_wtime() + call readgriddata(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds,fgfileprefixes,reducedgrid,grdin,qsat) + !print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat) + if (use_qsatensmean) then + allocate(qsatmean(npts,nlevs,nbackgrounds)) + allocate(qsat_tmp(npts)) + ! compute ensemble mean qsat + qsatmean = 0_r_double + do ne=1,nanals_per_iotask + do nb=1,nbackgrounds + do nlev=1,nlevs + call mpi_allreduce(qsat(:,nlev,nb,ne),qsat_tmp,npts,mpi_real8,mpi_sum,mpi_comm_io,ierr) + qsatmean(:,nlev,nb) = qsatmean(:,nlev,nb) + qsat_tmp + enddo + enddo + enddo + deallocate(qsat_tmp) + qsatmean = qsatmean/real(nanals) + !print *,'min/max qsat ensmean',nanal,'=',minval(qsat),maxval(qsat) + endif + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in readgridata on root',t2-t1,'secs' + end if + !do ne=1,nanals_per_iotask + ! nanal = ne + (nproc-1)*nanals_per_iotask + ! print *,'min/max ps ens mem',nanal,'=',& + ! minval(grdin(:,ncdim,nbackgrounds/2+1,ne)),maxval(grdin(:,ncdim,nbackgrounds/2+1,ne)) + ! print *,'min/max qsat',nanal,'=',& + ! minval(qsat(:,:,nbackgrounds/2+1,ne)),maxval(qsat(:,:,nbackgrounds/2+1,ne)) + !enddo + !if (use_qsatensmean) then + ! print *,'min/max qsatmean proc',nproc,'=',& + ! minval(qsatmean(:,:,nbackgrounds/2+1)),maxval(qsatmean(:,:,nbackgrounds/2+1)) + !endif + q_ind = getindex(cvars3d, 'q') + if (pseudo_rh .and. q_ind > 0) then + if (use_qsatensmean) then + do ne=1,nanals_per_iotask + do nb=1,nbackgrounds + ! create normalized humidity analysis variable. + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)/qsatmean(:,:,nb) + enddo + enddo + else + do ne=1,nanals_per_iotask + do nb=1,nbackgrounds + ! create normalized humidity analysis variable. + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)/qsat(:,:,nb,ne) + enddo + enddo + endif + end if + +endif + +end subroutine read_control + +subroutine write_control(no_inflate_flag) +! write out each ensemble member to a separate file. +! for now, first nanals tasks are IO tasks. +implicit none +logical, intent(in) :: no_inflate_flag + +real(r_double) :: t1,t2 +integer(i_kind) :: nb, nvar, ne +integer(i_kind) :: q_ind, ierr +real(r_single), allocatable, dimension(:,:) :: grdin_mean, grdin_mean_tmp + +if (nproc <= ntasks_io-1) then + + allocate(grdin_mean_tmp(npts,ncdim)) + if (nproc == 0) then + allocate(grdin_mean(npts,ncdim)) + grdin_mean = 0_r_single + t1 = mpi_wtime() + endif + + do nb=1,nbackgrounds + if (nproc == 0) then + print *,'time level ',nb + print *,'--------------' + endif + ! gather ensmean increment on root. + do ne=1,nanals_per_iotask + call mpi_reduce(grdin(:,:,nb,ne), grdin_mean_tmp, npts*ncdim, mpi_real4,& + mpi_sum,0,mpi_comm_io,ierr) + if (nproc == 0) grdin_mean = grdin_mean + grdin_mean_tmp + enddo + ! print out ens mean increment info + if (nproc == 0) then + grdin_mean = grdin_mean/real(nanals) + do nvar=1,nc3d + write(6,100) trim(cvars3d(nvar)), & + minval(grdin_mean(:,clevels(nvar-1)+1:clevels(nvar))), & + maxval(grdin_mean(:,clevels(nvar-1)+1:clevels(nvar))) + enddo + do nvar=1,nc2d + write(6,100) trim(cvars2d(nvar)), & + minval(grdin_mean(:,clevels(nc3d) + nvar)), & + maxval(grdin_mean(:,clevels(nc3d) + nvar)) + enddo + endif + enddo +100 format('ens. mean anal. increment min/max ',a,2x,g19.12,2x,g19.12) + if (nproc == 0) then + deallocate(grdin_mean) + endif + deallocate(grdin_mean_tmp) + + q_ind = getindex(cvars3d, 'q') + if (pseudo_rh .and. q_ind > 0) then + if (use_qsatensmean) then + do ne=1,nanals_per_iotask + do nb=1,nbackgrounds + ! re-scale normalized spfh with sat. sphf of ensmean first guess + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)*qsatmean(:,:,nb) + enddo + enddo + else + do ne=1,nanals_per_iotask + do nb=1,nbackgrounds + ! re-scale normalized spfh with sat. sphf of first guess + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)*qsat(:,:,nb,ne) + enddo + enddo + endif + end if + call writegriddata(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,grdin,no_inflate_flag) + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in write_control on root',t2-t1,'secs' + endif + +end if ! io task + +end subroutine write_control + +subroutine controlvec_cleanup() +! deallocate module-level allocatable arrays. +if (allocated(cvars3d)) deallocate(cvars3d) +if (allocated(cvars2d)) deallocate(cvars2d) +if (allocated(clevels)) deallocate(clevels) +if (allocated(index_pres)) deallocate(index_pres) +if (nproc <= ntasks_io-1 .and. allocated(grdin)) deallocate(grdin) +if (nproc <= ntasks_io-1 .and. allocated(qsat)) deallocate(qsat) +if (nproc <= ntasks_io-1 .and. allocated(qsatmean)) deallocate(qsatmean) +call gridinfo_cleanup() +end subroutine controlvec_cleanup + +end module controlvec diff --git a/src/enkf/enkf.f90 b/src/enkf/enkf.f90 index 03b6c796a..7ddba3207 100644 --- a/src/enkf/enkf.f90 +++ b/src/enkf/enkf.f90 @@ -39,7 +39,7 @@ module enkf ! coefficient update using the latest estimate of the observation increment ! (observation minus ensemble mean observation variable). The model state ! variables are only updated during the last iteration. After the update is -! complete, the variables anal_chunk and ensmean_chunk (from module statevec) +! complete, the variables anal_chunk and ensmean_chunk (from module controlvec) ! contain the updated model state ensemble perturbations and ensemble mean, ! and predx (from module radinfo) contains the updated bias coefficients. ! obfit_post and obsprd_post contain the observation increments and observation @@ -65,12 +65,19 @@ module enkf ! members often cannot fit in memory, they are saved in a temp file by ! module readobs, and only those needed on this task are read in by ! subroutine enkf_update. +! +! If the namelist paramater modelspac_vloc is set to .true., the parameter +! neigv will be greater than zero, and model space vertical localization +! via modulated ensembles will be used. In this case, the vertical +! location of an observation is not used (this generally improves the +! assimilation of radiance observations but increases the cost). + ! ! Adaptive observation thinning can be done via the parameter paoverpb_thresh. ! If this parameter >= 1 (1 is the default) no thinning is done. If < 1, an ! observation is not assimilated unless it will reduce the observation -! variable ensemble variance by paoverpb_thresh (e.g. if paoverpb_thresh = 0.9, -! only obs that will reduce the variance by 10% will be assimilated). +! variable ensemble variance by paoverpb_thresh (e.g. if paoverpb_thresh = 0.99, +! only obs that will reduce the variance by 1% will be assimilated). ! ! Public Subroutines: ! enkf_update: performs the EnKF update (calls update_biascorr to perform @@ -79,12 +86,17 @@ module enkf ! ! Public Variables: None ! -! Modules Used: kinds, constants, params, covlocal, mpisetup, loadbal, statevec, +! Modules Used: kinds, constants, params, covlocal, mpisetup, loadbal, controlvec, ! kdtree2_module, enkf_obsmod, radinfo, radbias, gridinfo ! ! program history log: ! 2009-02-23: Initial version. ! 2016-02-01: Ensure posterior perturbation mean remains zero. +! 2016-05-02: shlyaeva: Modification for reading state vector from table +! 2016-11-29: shlyaeva: Modification for using control vector (control and state +! used to be the same) and the "chunks" come from loadbal +! 2018-05-31: whitaker: add modulated ensemble model-space vertical +! localization (neigv>0) and denkf option. ! ! attributes: ! language: f95 @@ -99,25 +111,29 @@ module enkf indxproc, lnp_chunk, kdtree_obs, kdtree_grid, & ensmean_obchunk, indxob_chunk, oblnp_chunk, nobs_max, & obtime_chunk, grdloc_chunk, obloc_chunk, & - npts_max, anal_obchunk_prior -use statevec, only: ensmean_chunk, anal_chunk, ensmean_chunk_prior + npts_max, anal_obchunk_prior, ensmean_chunk, anal_chunk, & + anal_obchunk_modens_prior, ensmean_chunk_prior +use controlvec, only: cvars3d, ncdim, index_pres use enkf_obsmod, only: oberrvar, ob, ensmean_ob, obloc, oblnp, & nobstot, nobs_conv, nobs_oz, nobs_sat,& obfit_prior, obfit_post, obsprd_prior, obsprd_post, obtime,& obtype, oberrvarmean, numobspersat, deltapredx, biaspreds,& - biasprednorm, oberrvar_orig, probgrosserr, prpgerr,& + oberrvar_orig, probgrosserr, prpgerr,& corrlengthsq,lnsigl,obtimel,obloclat,obloclon,obpress,stattype,& anal_ob use constants, only: pi, one, zero -use params, only: sprd_tol, paoverpb_thresh, ndim, datapath, nanals,& - iassim_order,sortinc,deterministic,numiter,nlevs,nvars,& +use params, only: sprd_tol, paoverpb_thresh, datapath, nanals,& + iassim_order,sortinc,deterministic,numiter,nlevs,& zhuberleft,zhuberright,varqc,lupd_satbiasc,huber,univaroz,& covl_minfact,covl_efold,nbackgrounds,nhr_anal,fhr_assim,& - iseed_perturbed_obs,lupd_obspace_serial,fso_cycling + iseed_perturbed_obs,lupd_obspace_serial,fso_cycling,& + neigv,vlocal_evecs,denkf use radinfo, only: npred,nusis,nuchan,jpch_rad,predx use radbias, only: apply_biascorr, update_biascorr -use gridinfo, only: nlevs_pres,index_pres,nvarozone +use gridinfo, only: nlevs_pres use sorting, only: quicksort, isort +use mpeu_util, only: getindex +use mpeu_util, only: getindex !use innovstats, only: print_innovstats implicit none @@ -133,21 +149,26 @@ subroutine enkf_update() ! local variables. integer(i_kind) nob,nob1,nob2,nob3,npob,nf,nf2,ii,nobx,nskip,& - niter,i,nrej,npt,nuse,ncount,nb,np + niter,i,nrej,npt,nuse,ncount,ncount_check,nb,np integer(i_kind) indxens1(nanals),indxens2(nanals) +integer(i_kind) indxens1_modens(nanals*neigv),indxens2_modens(nanals*neigv) real(r_single) hxpost(nanals),hxprior(nanals),hxinc(nanals),& - dist,lnsig,obt,& + hxpost_modens(nanals*neigv),hxprior_modens(nanals*neigv),& + hxinc_modens(nanals*neigv),dist,lnsig,obt,& sqrtoberr,corrlengthinv,lnsiglinv,obtimelinv real(r_single) corrsqr,covl_fact real(r_double) :: t1,t2,t3,t4,t5,t6,tbegin,tend real(r_single) kfgain,hpfht,hpfhtoberrinv,r_nanals,r_nanalsm1,hpfhtcon -real(r_single) anal_obtmp(nanals),obinc_tmp,obens(nanals),obganl(nanals) +real(r_single) anal_obtmp(nanals),obinc_tmp,obens(nanals),obganl(nanals),& + obganl_modens(nanals*neigv) +real(r_single) anal_obtmp_modens(nanals*neigv) real(r_single) normdepart, pnge, width -real(r_single) buffer(nanals+2) -real(r_single),allocatable, dimension(:,:) :: anal_obchunk, buffertmp3 +real(r_single) buffer(nanals+2),ens_tmp(nanals*neigv) +real(r_single),allocatable, dimension(:,:) :: anal_obchunk, buffertmp3,& + anal_obchunk_modens real(r_single),dimension(nobstot):: oberrvaruse real(r_single) r,paoverpb -real(r_single) taper1,taper3 +real(r_single) taper1,taper3,taper_thresh real(r_single),allocatable, dimension(:) :: rannum,corrlengthsq_orig,lnsigl_orig integer(i_kind), allocatable, dimension(:) :: indxassim,iskip,indxassim2,indxassim3 real(r_single), allocatable, dimension(:) :: buffertmp,taper_disob,taper_disgrd @@ -156,12 +177,13 @@ subroutine enkf_update() integer(i_kind) ierr ! kd-tree search results type(kdtree2_result),dimension(:),allocatable :: sresults1,sresults2 -integer(i_kind) nanal,nn,nnn,nobm,nsame,nn1,nn2 +integer(i_kind) nanal,nn,nnn,nobm,nsame,nn1,nn2,oz_ind,nlev real(r_single),dimension(nlevs_pres):: taperv logical lastiter, kdgrid, kdobs ! allocate temporary arrays. allocate(anal_obchunk(nanals,nobs_max)) +if (neigv > 0) allocate(anal_obchunk_modens(nanals*neigv,nobs_max)) allocate(sresults1(numptsperproc(nproc+1)),taper_disgrd(numptsperproc(nproc+1))) allocate(sresults2(numobsperproc(nproc+1)),taper_disob(numobsperproc(nproc+1))) allocate(buffertmp(nobstot)) @@ -173,6 +195,7 @@ subroutine enkf_update() ! define a few frequently used parameters r_nanals=one/float(nanals) r_nanalsm1=one/float(nanals-1) +taper_thresh = epsilon(taper1) ! default is to assimilate in order they are read in. @@ -232,6 +255,7 @@ subroutine enkf_update() obfit_post(1:nobstot) = obfit_prior(1:nobstot) obsprd_post(1:nobstot) = obsprd_prior(1:nobstot) anal_obchunk = anal_obchunk_prior +if (neigv > 0) anal_obchunk_modens = anal_obchunk_modens_prior corrlengthsq_orig = corrlengthsq lnsigl_orig = lnsigl @@ -244,7 +268,7 @@ subroutine enkf_update() lastiter = niter == numiter ! apply bias correction with latest estimate of bias coeffs. ! (already done for first iteration) - if (nobs_sat > 0 .and. niter > 1 ) call apply_biascorr() + if (nobs_sat > 0 .and. lupd_satbiasc .and. niter > 1 ) call apply_biascorr() ! reset first guess perturbations at start of each iteration. nrej=0 @@ -347,7 +371,7 @@ subroutine enkf_update() indxassim(nobx:nobstot) = pack(indxassim2,indxassim2 /= 0) do nob=nobx,nobstot nob1 = indxassim(nob) - paoverpb_save(nob1) = paoverpb_thresh + tiny(paoverpb_thresh) + paoverpb_save(nob1) = paoverpb_thresh + taper_thresh iskip(nob1) = 1 enddo ! check to see that all obs accounted for. @@ -392,12 +416,20 @@ subroutine enkf_update() ! send to other processors. if (nproc == npob) then nob1 = indxob_chunk(nob); - hpfht = sum(anal_obchunk(:,nob1)**2)*r_nanalsm1 + if (neigv > 0) then + hpfht = sum(anal_obchunk_modens(:,nob1)**2)*r_nanalsm1 + anal_obtmp_modens(:) = anal_obchunk_modens(:,nob1) + else + hpfht = sum(anal_obchunk(:,nob1)**2)*r_nanalsm1 + endif buffer(1:nanals) = anal_obchunk(:,nob1) buffer(nanals+1) = ob(nob)-ensmean_obchunk(nob1) buffer(nanals+2) = hpfht end if call mpi_bcast(buffer,nanals+2,mpi_real4,npob,mpi_comm_world,ierr) + if (neigv > 0) then + call mpi_bcast(anal_obtmp_modens,nanals*neigv,mpi_real4,npob,mpi_comm_world,ierr) + endif t2 = t2 + mpi_wtime() - t1 t1 = mpi_wtime() @@ -426,7 +458,13 @@ subroutine enkf_update() if (deterministic) then ! EnSRF. - obganl = -anal_obtmp/(one+sqrt(oberrvaruse(nob)*hpfhtoberrinv)) + if (denkf) then + obganl = -0.5*anal_obtmp + if (neigv > 0) obganl_modens = -0.5*anal_obtmp_modens + else + obganl = -anal_obtmp/(one+sqrt(oberrvaruse(nob)*hpfhtoberrinv)) + if (neigv > 0) obganl_modens = -anal_obtmp_modens/(one+sqrt(oberrvaruse(nob)*hpfhtoberrinv)) + endif else ! perturbed obs EnKF. sqrtoberr=sqrt(oberrvaruse(nob)) @@ -435,6 +473,13 @@ subroutine enkf_update() enddo ! make sure mean is zero obens = obens - sum(obens)*r_nanals + if (neigv > 0) then + do nanal=1,nanals*neigv + ens_tmp(nanal) = sqrtoberr*rnorm() + enddo + ! make sure mean is zero + ens_tmp = ens_tmp - sum(ens_tmp)*r_nanals + endif if (sortinc) then ! To minimize regression errors, sort to minimize increments. ! ref - Anderson (2003) "A Least-Squares Framework for Ensemble Filtering" @@ -449,8 +494,20 @@ subroutine enkf_update() end do ! re-order ob perturbations to minimize increments. obens = hxinc/kfgain + hxprior + if (neigv > 0) then + hxprior_modens = anal_obtmp_modens + hxpost_modens = hxprior_modens+kfgain*(ens_tmp-hxprior_modens) + call quicksort(nanals*neigv, hxprior_modens, indxens1_modens) + call quicksort(nanals*neigv, hxpost_modens, indxens2_modens) + do nanal=1,nanals*neigv + hxinc_modens(indxens1_modens(nanal)) = hxpost_modens(indxens2_modens(nanal)) - hxprior_modens(indxens1_modens(nanal)) + end do + ! re-order ob perturbations to minimize increments. + ens_tmp = hxinc_modens/kfgain + hxprior_modens + endif end if obganl = obens - anal_obtmp + if (neigv > 0) obganl_modens = ens_tmp - anal_obtmp_modens end if t3 = t3 + mpi_wtime() - t1 @@ -473,9 +530,9 @@ subroutine enkf_update() ! Only need to recalculate nearest points when lat/lon is different if(nobx == 1 .or. & - abs(obloclat(nob)-obloclat(nobm)) .gt. tiny(obloclat(nob)) .or. & - abs(obloclon(nob)-obloclon(nobm)) .gt. tiny(obloclon(nob)) .or. & - abs(corrlengthsq(nob)-corrlengthsq(nobm)) .gt. tiny(corrlengthsq(nob))) then + abs(obloclat(nob)-obloclat(nobm)) .gt. taper_thresh .or. & + abs(obloclon(nob)-obloclon(nobm)) .gt. taper_thresh .or. & + abs(corrlengthsq(nob)-corrlengthsq(nobm)) .gt. taper_thresh) then nobm=nob ! determine localization length scales based on latitude of ob. nf2=0 @@ -538,41 +595,64 @@ subroutine enkf_update() t1 = mpi_wtime() ! only need to update state variables on last iteration. - if (univaroz .and. obtype(nob)(1:3) .eq. ' oz' .and. nvars .ge. nvarozone) then ! ozone obs only affect ozone - nn1 = (nvarozone-1)*nlevs+1 - nn2 = nvarozone*nlevs + oz_ind = getindex(cvars3d, 'oz') + if (univaroz .and. obtype(nob)(1:3) .eq. ' oz' .and. oz_ind > 0) then ! ozone obs only affect ozone + nn1 = (oz_ind-1)*nlevs+1 + nn2 = oz_ind*nlevs else nn1 = 1 - nn2 = ndim + nn2 = ncdim end if if (nf2 > 0) then -!$omp parallel do schedule(dynamic,1) private(ii,i,nb,obt,nn,nnn,lnsig,kfgain,taper1,taperv) +!$omp parallel do schedule(dynamic,1) private(ii,i,nb,obt,nn,nnn,nlev,lnsig,kfgain,ens_tmp,taper1,taper3,taperv) do ii=1,nf2 ! loop over nearby horiz grid points do nb=1,nbackgrounds ! loop over background time levels obt = abs(obtime(nob)-(nhr_anal(nb)-fhr_assim)) taper3=taper(obt*obtimelinv)*hpfhtcon taper1=taper_disgrd(ii)*taper3 i = sresults1(ii)%idx - do nn=1,nlevs_pres - lnsig = abs(lnp_chunk(i,nn)-oblnp(nob)) - if(lnsig < lnsigl(nob))then - taperv(nn)=taper1*taper(lnsig*lnsiglinv) - else - taperv(nn)=-2._r_single ! negative number is a flag to not use - end if - end do - do nn=nn1,nn2 - nnn=index_pres(nn) - if (taperv(nnn) > zero) then - ! gain includes covariance localization. - ! update all time levels - kfgain=taperv(nnn)*sum(anal_chunk(:,i,nn,nb)*anal_obtmp) - ! update mean. - ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp - ! update perturbations. - anal_chunk(:,i,nn,nb) = anal_chunk(:,i,nn,nb) + kfgain*obganl(:) - end if - end do + if (neigv > 0) then ! modulated ensemble, no explicit vertical localizatoin + if (taper1 > taper_thresh) then + do nn=nn1,nn2 + nlev = index_pres(nn) ! vertical index for nn'th control variable + if (nlev .eq. nlevs+1) nlev=1 ! 2d fields, assume surface + call expand_ens(neigv,nanals, & + anal_chunk(:,i,nn,nb), & + ens_tmp(:),vlocal_evecs(:,nlev)) + ! note: factor of 1/(nanals-1) included in taper1 + ! (through hpfhtcon) + kfgain=taper1*sum(ens_tmp*anal_obtmp_modens) + ! update mean. + ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + & + kfgain*obinc_tmp + ! update perturbations. + anal_chunk(:,i,nn,nb) = anal_chunk(:,i,nn,nb) + & + kfgain*obganl(:) + enddo + endif + else + taperv = zero + do nn=1,nlevs_pres + lnsig = abs(lnp_chunk(i,nn)-oblnp(nob)) + if(lnsig < lnsigl(nob))then + taperv(nn)=taper1*taper(lnsig*lnsiglinv) + end if + end do + do nn=nn1,nn2 + nnn=index_pres(nn) + if (taperv(nnn) > taper_thresh) then + ! gain includes covariance localization. + ! update all time levels + ! factor of 1/(nanals-1) included in taperv + ! (through hpfhtcon) + kfgain=taperv(nnn)*sum(anal_chunk(:,i,nn,nb)*anal_obtmp) + ! update mean. + ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp + ! update perturbations. + anal_chunk(:,i,nn,nb) = anal_chunk(:,i,nn,nb) + kfgain*obganl(:) + end if + end do + endif end do ! end loop over background time levels. end do ! end loop over nearby horiz grid points !$omp end parallel do @@ -588,30 +668,56 @@ subroutine enkf_update() ! Note: only really need to do obs that have not yet been processed unless sat data ! for bias correction update. nob2 = sresults2(nob1)%idx - lnsig = abs(oblnp(nob)-oblnp_chunk(nob2)) - if (lnsig < lnsigl(nob) .and. taper_disob(nob1) > zero) then - obt = abs(obtime(nob)-obtime_chunk(nob2)) - if (obt < obtimel(nob)) then - ! gain includes covariance localization. - kfgain = taper_disob(nob1)* & - taper(lnsig*lnsiglinv)*taper(obt*obtimelinv)* & - sum(anal_obchunk(:,nob2)*anal_obtmp)*hpfhtcon - ! update mean. - ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp - ! update perturbations. - anal_obchunk(:,nob2) = anal_obchunk(:,nob2) + kfgain*obganl - nob3 = indxproc_obs(nproc+1,nob2) ! index in 1,....,nobstot - ! recompute ob space spread ratio for unassimlated obs - if (iassim_order == 2 .and. niter == 1) then - if (indxassim2(nob3) /= 0) then - paoverpb_chunk(nob2) = & - oberrvar(nob3)/(oberrvar(nob3)+& - sum(anal_obchunk(:,nob2)**2)*r_nanalsm1) - else - paoverpb_chunk(nob2) = 1.e10 + if (neigv > 0) then ! modulated ensemble, no vertical localizatoin + obt = abs(obtime(nob)-obtime_chunk(nob2)) + if (obt < obtimel(nob)) then + ! gain includes covariance localization. + kfgain = taper_disob(nob1)* & + taper(obt*obtimelinv)* & + sum(anal_obchunk_modens(:,nob2)*anal_obtmp_modens)*hpfhtcon + ! update mean. + ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + ! update perturbations. + anal_obchunk(:,nob2) = anal_obchunk(:,nob2) + kfgain*obganl + anal_obchunk_modens(:,nob2) = anal_obchunk_modens(:,nob2) + kfgain*obganl_modens + ! recompute ob space spread ratio for unassimlated obs + if (iassim_order == 2 .and. niter == 1) then + nob3 = indxproc_obs(nproc+1,nob2) ! index in 1,....,nobstot + if (indxassim2(nob3) /= 0) then + paoverpb_chunk(nob2) = & + oberrvar(nob3)/(oberrvar(nob3)+& + sum(anal_obchunk_modens(:,nob2)**2)*r_nanalsm1) + else + paoverpb_chunk(nob2) = 1.e10 + endif endif - endif - end if + end if + else + lnsig = abs(oblnp(nob)-oblnp_chunk(nob2)) + if (lnsig < lnsigl(nob) .and. taper_disob(nob1) > zero) then + obt = abs(obtime(nob)-obtime_chunk(nob2)) + if (obt < obtimel(nob)) then + ! gain includes covariance localization. + kfgain = taper_disob(nob1)* & + taper(lnsig*lnsiglinv)*taper(obt*obtimelinv)* & + sum(anal_obchunk(:,nob2)*anal_obtmp)*hpfhtcon + ! update mean. + ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + ! update perturbations. + anal_obchunk(:,nob2) = anal_obchunk(:,nob2) + kfgain*obganl + ! recompute ob space spread ratio for unassimlated obs + if (iassim_order == 2 .and. niter == 1) then + nob3 = indxproc_obs(nproc+1,nob2) ! index in 1,....,nobstot + if (indxassim2(nob3) /= 0) then + paoverpb_chunk(nob2) = & + oberrvar(nob3)/(oberrvar(nob3)+& + sum(anal_obchunk(:,nob2)**2)*r_nanalsm1) + else + paoverpb_chunk(nob2) = 1.e10 + endif + endif + end if + end if end if end do !$omp end parallel do @@ -629,7 +735,7 @@ subroutine enkf_update() !$omp parallel do schedule(dynamic) private(npt,nb,i) do npt=1,npts_max do nb=1,nbackgrounds - do i=1,ndim + do i=1,ncdim anal_chunk(1:nanals,npt,i,nb) = anal_chunk(1:nanals,npt,i,nb)-& sum(anal_chunk(1:nanals,npt,i,nb),1)*r_nanals end do @@ -647,9 +753,13 @@ subroutine enkf_update() tend = mpi_wtime() if (nproc .eq. 0) then write(6,8003) niter,'timing on proc',nproc,' = ',tend-tbegin,t2,t3,t4,t5,t6,nrej - + if (iassim_order == 2) then + ncount_check = ncount + else + ncount_check = nobstot + endif nuse = 0; covl_fact = 0. - do nob1=1,ncount + do nob1=1,ncount_check nob = indxassim(nob1) if (iskip(nob) .ne. 1) then covl_fact = covl_fact + sqrt(corrlengthsq(nob)/corrlengthsq_orig(nob)) @@ -698,7 +808,11 @@ subroutine enkf_update() buffertmp=zero do nob1=1,numobsperproc(nproc+1) nob2=indxproc_obs(nproc+1,nob1) - buffertmp(nob2) = sum(anal_obchunk(:,nob1)**2)*r_nanalsm1 + if (neigv > 0) then + buffertmp(nob2) = sum(anal_obchunk_modens(:,nob1)**2)*r_nanalsm1 + else + buffertmp(nob2) = sum(anal_obchunk(:,nob1)**2)*r_nanalsm1 + endif end do call mpi_allreduce(buffertmp,obsprd_post,nobstot,mpi_real4,mpi_sum,mpi_comm_world,ierr) if (nproc == 0) print *,'time to broadcast obsprd_post = ',mpi_wtime()-t1 diff --git a/src/enkf/enkf_main.f90 b/src/enkf/enkf_main.f90 index adc710322..950014793 100644 --- a/src/enkf/enkf_main.f90 +++ b/src/enkf/enkf_main.f90 @@ -33,6 +33,10 @@ program enkf_main ! 2009-02-23 Initial version. ! 2011-06-03 Added the option for LETKF. ! 2016-02-01 Initialize mpi communicator for IO tasks (1st nanals tasks). +! 2016-05-02 shlyaeva: Modification for reading state vector from table +! 2016-11-29 shlyaeva: Initialize state vector separately from control; +! separate routines for scatter and gather chunks; write out diag files +! with spread ! ! usage: ! input files: @@ -49,6 +53,7 @@ program enkf_main ! vertical profile of horizontal and vertical localization ! length scales (along with static and ensemble weights ! used in hybrid). +! anavinfo - state/control variables table ! ! output files: ! sanl_YYYYMMDDHH_mem* - analysis ensemble members. A separate program @@ -58,8 +63,8 @@ program enkf_main ! ! comments: ! -! This program is run after the forward operator code is run on each ensemble -! member to create the diag*mem* input files. +! This program is run after the forward operator code (with saving linearized H) +! is run on the ensemble mean to create the diag*ensmean input file. ! ! attributes: ! language: f95 @@ -68,39 +73,43 @@ program enkf_main use kinds, only: r_kind,r_double,i_kind ! reads namelist parameters. - use params, only : read_namelist,letkf_flag,readin_localization,lupd_satbiasc,& - numiter, nanals, lupd_obspace_serial, fso_cycling + use params, only : read_namelist,cleanup_namelist,letkf_flag,readin_localization,lupd_satbiasc,& + numiter, nanals, lupd_obspace_serial, write_spread_diag, & + lobsdiag_forenkf, netcdf_diag, fso_cycling, ntasks_io ! mpi functions and variables. use mpisetup, only: mpi_initialize, mpi_initialize_io, mpi_cleanup, nproc, & - numproc, mpi_wtime + mpi_wtime, mpi_comm_world ! obs and ob priors, associated metadata. - use enkf_obsmod, only : readobs, obfit_prior, obsprd_prior, & - deltapredx, nobs_sat, obfit_post, obsprd_post, & - obsmod_cleanup, biasprednorminv + use enkf_obsmod, only : readobs, write_obsstats, obfit_prior, obsprd_prior, & + nobs_sat, obfit_post, obsprd_post, obsmod_cleanup ! innovation statistics. use innovstats, only: print_innovstats - ! grid information - use gridinfo, only: getgridinfo, gridinfo_cleanup, npts,lonsgrd,latsgrd - ! model state vector - use statevec, only: read_ensemble, write_ensemble, statevec_cleanup + ! model control vector + use controlvec, only: read_control, write_control, controlvec_cleanup, & + init_controlvec + ! model state vector + use statevec, only: read_state, statevec_cleanup, init_statevec + ! EnKF linhx observer + use observer_enkf, only: init_observer_enkf, destroy_observer_enkf ! load balancing - use loadbal, only: load_balance, loadbal_cleanup + use loadbal, only: load_balance, loadbal_cleanup, scatter_chunks, gather_chunks ! enkf update use enkf, only: enkf_update ! letkf update use letkf, only: letkf_update ! radiance bias correction coefficients. - use radinfo, only: radinfo_write, predx, jpch_rad, npred + use radinfo, only: radinfo_write ! posterior ensemble inflation. use inflation, only: inflate_ens ! initialize radinfo variables use radinfo, only: init_rad, init_rad_vars use omp_lib, only: omp_get_max_threads + use read_diag, only: set_netcdf_read ! Observation sensitivity usage use enkf_obs_sensitivity, only: init_ob_sens, print_ob_sens, destroy_ob_sens implicit none - integer(i_kind) j,n,nth + integer(i_kind) nth,ierr real(r_double) t1,t2 logical no_inflate_flag @@ -115,17 +124,32 @@ program enkf_main call read_namelist() ! initialize MPI communicator for IO tasks. - call mpi_initialize_io(nanals) + call mpi_initialize_io(ntasks_io) ! Initialize derived radinfo variables call init_rad_vars() + ! Initialize read_diag + call set_netcdf_read(netcdf_diag) + + nth= omp_get_max_threads() if(nproc== 0)write(6,*) 'enkf_main: number of threads ',nth - ! read horizontal grid information and pressure fields from - ! 6-h forecast ensemble mean file. - call getgridinfo() + ! Init and read state vector only if needed for linearized Hx + if (lobsdiag_forenkf) then + ! read state/control vector info from anavinfo + call init_statevec() + + ! initialize observer + call init_observer_enkf() + + ! read in ensemble members + t1 = mpi_wtime() + call read_state() + t2 = mpi_wtime() + if (nproc == 0) print *,'time in read_state =',t2-t1,'on proc',nproc + endif ! read obs, initial screening. t1 = mpi_wtime() @@ -133,12 +157,29 @@ program enkf_main t2 = mpi_wtime() if (nproc == 0) print *,'time in read_obs =',t2-t1,'on proc',nproc + call mpi_barrier(mpi_comm_world, ierr) + + ! cleanup state vectors after observation operator is done if lin Hx + if (lobsdiag_forenkf) then + call statevec_cleanup() + call destroy_observer_enkf() + endif + ! print innovation statistics for prior on root task. if (nproc == 0) then print *,'innovation statistics for prior:' call print_innovstats(obfit_prior, obsprd_prior) end if + ! read state/control vector info from anavinfo + call init_controlvec() + + ! read in ensemble members + t1 = mpi_wtime() + call read_control() + t2 = mpi_wtime() + if (nproc == 0) print *,'time in read_control =',t2-t1,'on proc',nproc + ! Initialization for writing ! observation sensitivity files if(fso_cycling) call init_ob_sens() @@ -154,11 +195,11 @@ program enkf_main t2 = mpi_wtime() if (nproc == 0) print *,'time in load_balance =',t2-t1,'on proc',nproc - ! read in ensemble members, distribute pieces to each task. + ! distribute pieces to each task. t1 = mpi_wtime() - call read_ensemble() + call scatter_chunks() t2 = mpi_wtime() - if (nproc == 0) print *,'time in read_ensemble =',t2-t1,'on proc',nproc + if (nproc == 0) print *,'time in scatter_chunks = ',t2-t1,'on proc',nproc t1 = mpi_wtime() ! state and bias correction coefficient update iteration. @@ -177,7 +218,8 @@ program enkf_main if(fso_cycling) then no_inflate_flag=.true. t1 = mpi_wtime() - call write_ensemble(no_inflate_flag) + call gather_chunks() + call write_control(no_inflate_flag) t2 = mpi_wtime() if (nproc == 0) print *,'time in write_ensemble wo/inflation =',t2-t1,'on proc',nproc end if @@ -189,6 +231,13 @@ program enkf_main t2 = mpi_wtime() if (nproc == 0) print *,'time in inflate_ens =',t2-t1,'on proc',nproc + if (write_spread_diag) then + t1 = mpi_wtime() + call write_obsstats() + t2 = mpi_wtime() + if (nproc == 0) print *,'time in write_obsstats =',t2-t1,'on proc',nproc + endif + ! print EFSO sensitivity i/o on root task. if(fso_cycling) call print_ob_sens() @@ -198,12 +247,6 @@ program enkf_main call print_innovstats(obfit_post, obsprd_post) ! write out bias coeffs on root. if (nobs_sat > 0 .and. lupd_satbiasc) then - ! re-scale bias coefficients. - do j=1,jpch_rad - do n=1,npred - predx(n,j) = predx(n,j)*biasprednorminv(n) - enddo - enddo call radinfo_write() end if end if @@ -213,14 +256,19 @@ program enkf_main call obsmod_cleanup() t1 = mpi_wtime() - call write_ensemble(no_inflate_flag) + call gather_chunks() + t2 = mpi_wtime() + if (nproc == 0) print *,'time in gather_chunks =',t2-t1,'on proc',nproc + + t1 = mpi_wtime() + call write_control(no_inflate_flag) t2 = mpi_wtime() - if (nproc == 0) print *,'time in write_ensemble =',t2-t1,'on proc',nproc + if (nproc == 0) print *,'time in write_control =',t2-t1,'on proc',nproc - call gridinfo_cleanup() - call statevec_cleanup() + call controlvec_cleanup() call loadbal_cleanup() if(fso_cycling) call destroy_ob_sens() + call cleanup_namelist() ! write log file (which script can check to verify completion). if (nproc .eq. 0) then diff --git a/src/enkf/enkf_obsmod.f90 b/src/enkf/enkf_obsmod.f90 index ce14cb880..310f142e6 100644 --- a/src/enkf/enkf_obsmod.f90 +++ b/src/enkf/enkf_obsmod.f90 @@ -70,6 +70,7 @@ module enkf_obsmod ! biaspreds(npred+1, nobs_sat): real array of bias predictors for ! each satellite radiance ob (includes non-adaptive scan angle ! bias correction term in biaspreds(1,1:nobs_sat)). +! npred from radinfo module ! deltapredx(npred,jpch_rad): real array of bias coefficient increments ! (initialized to zero, updated by analysis). ! obloc(3,nobstot): real array of spherical cartesian coordinates @@ -90,6 +91,7 @@ module enkf_obsmod ! otherwise svars3d is not defined such that EnKF does not work right ! for oz and it crashes EnKF compiled by GNU Fortran ! NOTE: this requires anavinfo file to be present at running directory +! 2016-11-29 shlyaeva: Added the option of writing out ensemble spread in diag files ! ! attributes: ! language: f95 @@ -105,14 +107,14 @@ module enkf_obsmod corrlengthtr, corrlengthsh, obtimelnh, obtimeltr, obtimelsh,& lnsigcutoffsatnh, lnsigcutoffsatsh, lnsigcutoffsattr,& varqc, huber, zhuberleft, zhuberright,& - lnsigcutoffpsnh, lnsigcutoffpssh, lnsigcutoffpstr + lnsigcutoffpsnh, lnsigcutoffpssh, lnsigcutoffpstr, neigv use state_vectors, only: init_anasv use mpi_readobs, only: mpi_getobs implicit none private -public :: readobs, obsmod_cleanup +public :: readobs, obsmod_cleanup, write_obsstats real(r_single), public, allocatable, dimension(:) :: obsprd_prior, ensmean_obnobc,& ensmean_ob, ob, oberrvar, obloclon, obloclat, & @@ -120,6 +122,7 @@ module enkf_obsmod oblnp, obfit_prior, prpgerr, oberrvarmean, probgrosserr, & lnsigl,corrlengthsq,obtimel integer(i_kind), public, allocatable, dimension(:) :: numobspersat +integer(i_kind), allocatable, dimension(:) :: diagused ! posterior stats computed in enkf_update real(r_single), public, allocatable, dimension(:) :: obfit_post, obsprd_post real(r_single), public, allocatable, dimension(:,:) :: biaspreds @@ -127,14 +130,15 @@ module enkf_obsmod ! arrays passed to kdtree2 routines must be single. real(r_single), public, allocatable, dimension(:,:) :: obloc integer(i_kind), public, allocatable, dimension(:) :: stattype, indxsat -real(r_single), public, allocatable, dimension(:) :: biasprednorm,biasprednorminv character(len=20), public, allocatable, dimension(:) :: obtype integer(i_kind), public :: nobs_sat, nobs_oz, nobs_conv, nobstot +integer(i_kind) :: nobs_convdiag, nobs_ozdiag, nobs_satdiag, nobstotdiag ! for serial enkf, anal_ob is only used here and in loadbal. It is deallocated in loadbal. ! for letkf, anal_ob used on all tasks in letkf_update (bcast from root in loadbal), deallocated ! in letkf_update. -real(r_single), public, allocatable, dimension(:,:) :: anal_ob +! same goes for anal_ob_modens when modelspace_vloc=T. +real(r_single), public, allocatable, dimension(:,:) :: anal_ob, anal_ob_modens contains @@ -144,12 +148,12 @@ subroutine readobs() ! all tasks. Ob prior perturbations for each ensemble member ! are written to a temp file, since the entire array can be ! very large. -use radinfo, only: npred,nusis,nuchan,jpch_rad,iuse_rad,radinfo_read,predx,pg_rad +use radinfo, only: npred,jpch_rad,radinfo_read,pg_rad use convinfo, only: convinfo_read, init_convinfo, cvar_pg, nconvtype, ictype,& ioctype use ozinfo, only: init_oz, ozinfo_read, pg_oz, jpch_oz, nusis_oz, nulev use covlocal, only: latval -integer nob,n,j,ierr +integer nob,j,ierr real(r_double) t1 real(r_single) tdiff,tdiffmax,deglat,radlat,radlon ! read in conv data info @@ -170,35 +174,17 @@ subroutine readobs() ! so bias coefficents have same units as radiance obs. ! (by computing RMS values over many analyses) if (nproc == 0) print*, 'npred = ', npred -allocate(biasprednorm(npred),biasprednorminv(npred)) -!biasprednorm(1) = 0.01_r_single ! constant term -!biasprednorm(2) = 2.6e-2_r_single ! scan angle path -!biasprednorm(3) = 1.6e-2_r_single ! total column water -!biasprednorm(5) = 1.9e-2_r_single ! integrated weighted (by weighting fns) lapse rate -!biasprednorm(4) = zero ! IWLR**2, don't use this predictor (too co-linear)? -!biasprednorm(4) = 1.1e-3_r_single -!biasprednorm(4) = zero ! don't use this predictor (too co-linear)? -! what the heck, just scale them all by 0.01! -!biasprednorm = 0.01_r_single -biasprednorm=one -biasprednorminv=zero -do n=1,npred - if (nproc == 0) print *,n,'biasprednorm = ',biasprednorm(n) - if (biasprednorm(n) > 1.e-7_r_single) biasprednorminv(n)=one/biasprednorm(n) -enddo -! scale bias coefficients. -do j=1,jpch_rad - predx(:,j) = biasprednorm(:)*predx(:,j) -enddo ! allocate array for bias correction increments, initialize to zero. allocate(deltapredx(npred,jpch_rad)) deltapredx = zero t1 = mpi_wtime() -call mpi_getobs(datapath, datestring, nobs_conv, nobs_oz, nobs_sat, nobstot, & - obsprd_prior, ensmean_obnobc, ensmean_ob, ob, & - oberrvar, obloclon, obloclat, obpress, & - obtime, oberrvar_orig, stattype, obtype, biaspreds,& - anal_ob,indxsat,nanals) +call mpi_getobs(datapath, datestring, nobs_conv, nobs_oz, nobs_sat, nobstot, & + nobs_convdiag,nobs_ozdiag, nobs_satdiag, nobstotdiag, & + obsprd_prior, ensmean_obnobc, ensmean_ob, ob, & + oberrvar, obloclon, obloclat, obpress, & + obtime, oberrvar_orig, stattype, obtype, biaspreds, diagused, & + anal_ob,anal_ob_modens,indxsat,nanals,neigv) + tdiff = mpi_wtime()-t1 call mpi_reduce(tdiff,tdiffmax,1,mpi_real4,mpi_max,0,mpi_comm_world,ierr) if (nproc == 0) then @@ -243,11 +229,6 @@ subroutine readobs() endif ! compute number of usuable obs, average ob error for each satellite sensor/channel. if (nobs_sat > 0) then - do nob=1,nobs_sat - do n=2,npred+1 - biaspreds(n,nob)=biaspreds(n,nob)* biasprednorminv(n-1) - end do - end do call channelstats() end if @@ -285,11 +266,70 @@ subroutine readobs() obsprd_post = zero end subroutine readobs +subroutine write_obsstats() +use readconvobs, only: write_convobs_data +use readozobs, only: write_ozobs_data +use readsatobs, only: write_satobs_data +character(len=10) :: id,id2,gesid2 + + id = 'ensmean' + id2 = 'enssprd' + if (nproc==0) then + if (nobs_conv > 0) then + print *, 'obsprd, conv: ', minval(obsprd_prior(1:nobs_conv)), & + maxval(obsprd_prior(1:nobs_conv)) + gesid2 = 'ges' + call write_convobs_data(datapath, datestring, nobs_conv, nobs_convdiag, & + obfit_prior(1:nobs_conv), obsprd_prior(1:nobs_conv), & + diagused(1:nobs_convdiag), & + id, id2, gesid2) + gesid2 = 'anl' + call write_convobs_data(datapath, datestring, nobs_conv, nobs_convdiag, & + obfit_post(1:nobs_conv), obsprd_post(1:nobs_conv), & + diagused(1:nobs_convdiag), & + id, id2, gesid2) + end if + if (nobs_oz > 0) then + print *, 'obsprd, oz: ', minval(obsprd_prior(nobs_conv+1:nobs_conv+nobs_oz)), & + maxval(obsprd_prior(nobs_conv+1:nobs_conv+nobs_oz)) + gesid2 = 'ges' + call write_ozobs_data(datapath, datestring, nobs_oz, nobs_ozdiag, & + obfit_prior(nobs_conv+1:nobs_conv+nobs_oz), & + obsprd_prior(nobs_conv+1:nobs_conv+nobs_oz), & + diagused(nobs_convdiag+1:nobs_convdiag+nobs_ozdiag), & + id, id2, gesid2) + gesid2 = 'anl' + call write_ozobs_data(datapath, datestring, nobs_oz, nobs_ozdiag, & + obfit_post(nobs_conv+1:nobs_conv+nobs_oz), & + obsprd_post(nobs_conv+1:nobs_conv+nobs_oz), & + diagused(nobs_convdiag+1:nobs_convdiag+nobs_ozdiag), & + id, id2, gesid2) + end if + if (nobs_sat > 0) then + print *, 'obsprd, sat: ', minval(obsprd_prior(nobs_conv+nobs_oz+1:nobstot)), & + maxval(obsprd_prior(nobs_conv+nobs_oz+1:nobstot)) + gesid2 = 'ges' + call write_satobs_data(datapath, datestring, nobs_sat, nobs_satdiag, & + obfit_prior(nobs_conv+nobs_oz+1:nobstot), & + obsprd_prior(nobs_conv+nobs_oz+1:nobstot), & + diagused(nobs_convdiag+nobs_ozdiag+1:nobstotdiag), & + id, id2, gesid2) + gesid2 = 'anl' + call write_satobs_data(datapath, datestring, nobs_sat, nobs_satdiag, & + obfit_post(nobs_conv+nobs_oz+1:nobstot), & + obsprd_post(nobs_conv+nobs_oz+1:nobstot), & + diagused(nobs_convdiag+nobs_ozdiag+1:nobstotdiag), & + id, id2, gesid2) + end if + endif + + +end subroutine write_obsstats + subroutine screenobs() ! screen out obs with large observation errors or ! that fail background check. For screened obs oberrvar is set to 1.e31_r_single !use radbias, only: apply_biascorr -use radinfo, only: iuse_rad,nuchan,nusis,jpch_rad real(r_single) fail,failm integer nn,nob fail=1.e31_r_single @@ -348,7 +388,7 @@ subroutine screenobs() end subroutine screenobs subroutine channelstats -use radinfo, only: npred,nusis,nuchan,jpch_rad +use radinfo, only: jpch_rad implicit none integer(i_kind) nob,nob2,i ! count number of obs per channel/sensor. @@ -402,9 +442,9 @@ subroutine obsmod_cleanup() if (allocated(obtype)) deallocate(obtype) if (allocated(probgrosserr)) deallocate(probgrosserr) if (allocated(prpgerr)) deallocate(prpgerr) -if (allocated(biasprednorm)) deallocate(biasprednorm) -if (allocated(biasprednorminv)) deallocate(biasprednorminv) if (allocated(anal_ob)) deallocate(anal_ob) +if (allocated(anal_ob_modens)) deallocate(anal_ob_modens) +if (allocated(diagused)) deallocate(diagused) end subroutine obsmod_cleanup diff --git a/src/enkf/expand_ens.f90 b/src/enkf/expand_ens.f90 new file mode 100644 index 000000000..a68c553b8 --- /dev/null +++ b/src/enkf/expand_ens.f90 @@ -0,0 +1,25 @@ +subroutine expand_ens(neig,nanals,ens_orig,ens_expanded,evectors) + ! create modulated ensemble in model space with vertical + ! localization 'baked in'. + ! input: + ! neig - number of localization eigenvectors + ! nanals - number of original ensemble members + ! ens_orig - original ensemble perturbations (dimension nanals) + ! evectors - localization eigenvectors (dimension neig) + ! output: + ! ens_expanded - expanded modulated ensemble (dimension nanals*neig) + ! Note: evectors should be normalized so variance of modulated ensemble + ! can be computed via sum(ens_expanded**2)/(nanals-1). + use kinds, only: r_single,r_kind, r_double + integer, intent(in) :: neig,nanals + real(r_single), intent(in) :: ens_orig(nanals) + real(r_single), intent(out) :: ens_expanded(neig*nanals) + real(r_double), intent(in) :: evectors(neig) + integer nanalo,nanal,ne + do nanal=1,nanals + do ne = 1, neig + nanalo = neig*(nanal-1) + ne + ens_expanded(nanalo) = ens_orig(nanal)*evectors(ne) + enddo + enddo +end subroutine expand_ens diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90 new file mode 100644 index 000000000..60b946170 --- /dev/null +++ b/src/enkf/gridinfo_fv3reg.f90 @@ -0,0 +1,303 @@ +module gridinfo +!$$$ module documentation block +! +! module: gridinfo read horizontal (lons, lats) and +! vertical (pressure) information from +! ensemble mean first guess file. +! +! prgmmr: whitaker org: esrl/psd date: 2009-02-23 +! +! abstract: This module reads the ensemble mean background file and +! extracts information about the analysis grid, including the +! longitudes and latitudes of the analysis grid points and +! the pressure on each grid point/vertical level. +! +! Public Subroutines: +! getgridinfo: read latitudes, longitudes, pressures and orography for analysis grid, +! broadcast to each task. Compute spherical cartesian coordinate values +! for each analysis horizontal grid point. +! gridinfo_cleanup: deallocate allocated module variables. +! +! Public Variables: +! npts: number of analysis grid points in the horizontal (from module params). +! nlevs: number of analysis vertical levels (from module params). +! specific humidity, ozone and cloud condensate). +! ptop: (real scalar) pressure (hPa) at top model layer interface. +! lonsgrd(npts): real array of analysis grid longitudes (radians). +! latsgrd(npts): real array of analysis grid latitudes (radians). +! logp(npts,ndim): -log(press) for all 2d analysis grids. Assumed invariant +! in assimilation window, computed fro ensemble mean at middle of window. +! gridloc(3,npts): spherical cartesian coordinates (x,y,z) for analysis grid. +! +! Modules Used: mpisetup, params, kinds +! +! program history log: +! 2009-02-23 Initial version. +! 2016-05-02: shlyaeva: Modification for reading state vector from table +! 2016-04-20 Modify to handle the updated nemsio sig file (P, DP & DPDT removed) +! +! attributes: +! language: f95 +! +!$$$ + +use mpisetup, only: nproc, mpi_integer, mpi_real4, mpi_comm_world +use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio, fgfileprefixes, & + fv3fixpath, nx_res,ny_res, ntiles +use kinds, only: r_kind, i_kind, r_double, r_single +use constants, only: one,zero,pi,cp,rd,grav,rearth,max_varname_length +use constants, only: half +use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr +use netcdf, only: nf90_inq_dimid,nf90_inq_varid +use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension +use netcdf_mod, only: nc_check +use read_fv3regional_restarts,only:read_fv3_restart_data1d,read_fv3_restart_data2d +use read_fv3regional_restarts,only:read_fv3_restart_data3d,read_fv3_restart_data4d + +implicit none +private +public :: getgridinfo, gridinfo_cleanup +public :: ak,bk,eta1_ll,eta2_ll +real(r_single),public :: ptop +real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd +! arrays passed to kdtree2 routines must be single +real(r_single),public, allocatable, dimension(:,:) :: gridloc +real(r_single),public, allocatable, dimension(:,:) :: logp +integer(i_kind), public :: nlevs_pres +integer,public :: npts +integer,public :: ntrunc +! supported variable names in anavinfo +character(len=max_varname_length),public, dimension(8) :: vars3d_supported = (/'u ', 'v ', 't ', 'q ', 'oz ', 'cw ', 'tsen', 'prse' /) +character(len=max_varname_length),public, dimension(3) :: vars2d_supported = (/'ps ', 'pst', 'sst' /) +! supported variable names in anavinfo +real(r_single), allocatable, dimension(:) :: ak,bk,eta1_ll,eta2_ll +contains + +subroutine getgridinfo(fileprefix, reducedgrid) +! read latitudes, longitudes and pressures for analysis grid, +! broadcast to each task. +use read_fv3regional_restarts, only: read_fv3_restart_data2d +implicit none + +character(len=120), intent(in) :: fileprefix +logical, intent(in) :: reducedgrid + +integer(i_kind) ierr, k, nn +character(len=500) filename +integer(i_kind) i,j +real(r_kind), allocatable, dimension(:) :: spressmn +real(r_kind), allocatable, dimension(:,:) :: pressimn,presslmn +real(r_kind) kap,kapr,kap1 + +integer(i_kind) file_id,var_id,dim_id,nlevsp1,nx_tile,ny_tile,ntile +integer (i_kind):: nn_tile0 +integer(i_kind) :: nlevsp1n +real(r_single), allocatable, dimension(:,:) :: lat_tile,lon_tile,ps +real(r_single), allocatable, dimension(:,:,:) :: delp,g_prsi +real(r_single) ptop +character(len=4) char_nxres +character(len=4) char_nyres +character(len=1) char_tile +character(len=24),parameter :: myname_ = 'fv3: getgridinfo' +write (6,*)"The input fileprefix, reducedgrid are not used in the current implementation", & + fileprefix, reducedgrid +nlevsp1 = nlevs + 1 +nlevs_pres = nlevsp1 +npts = ntiles*nx_res*ny_res +kap = rd/cp +kapr = cp/rd +kap1 = kap + one + +! read data on root task +if (nproc .eq. 0) then + + ! read ak,bk from ensmean fv_core.res.nc + ! read nx,ny and nz from fv_core.res.nc + filename = 'fv3sar_tile1_akbk.nc' + call nc_check( nf90_open(trim(adjustl(filename)),nf90_nowrite,file_id),& + myname_,'open: '//trim(adjustl(filename)) ) + call nc_check( nf90_inq_dimid(file_id,'xaxis_1',dim_id),& + myname_,'inq_dimid xaxis_1 '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,dim_id,len=nlevsp1n),& + myname_,'inquire_dimension xaxis_1 '//trim(filename) ) + if(nlevsp1n.ne.nlevsp1) then + write(6,*)'the configure nlevsp1 is not consistent with the parameter & + read from the data files, stop' + call stop2(25) + endif + + + + allocate(ak(nlevsp1),bk(nlevsp1)) + allocate(eta1_ll(nlevsp1),eta2_ll(nlevsp1)) + call read_fv3_restart_data1d('ak',filename,file_id,ak) + call read_fv3_restart_data1d('bk',filename,file_id,bk) + +!!!!! change unit of ak,also reverse the + + do i=1,nlevsp1 + eta1_ll(i)=ak(i)*0.01_r_kind + eta2_ll(i)=bk(i) + enddo + + + + + ptop = eta1_ll(nlevsp1) + call nc_check( nf90_close(file_id),& + myname_,'close '//trim(filename) ) + filename = 'fv3sar_tile1_grid_spec.nc' + call nc_check( nf90_open(trim(adjustl(filename)),nf90_nowrite,file_id),& + myname_,'open: '//trim(adjustl(filename)) ) + + call nc_check( nf90_inq_dimid(file_id,'grid_xt',dim_id),& + myname_,'inq_dimid grid_xt '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,dim_id,len=nx_tile),& + myname_,'inquire_dimension grid_xt '//trim(filename) ) + if(nx_res.ne.nx_tile) then + write(6,*)"nx_tile and nx_res are ",nx_tile,nx_res + write(6,*)'the readin nx_tile does not equal to nx_res as expected, stop' + call stop2(25) + endif + + call nc_check( nf90_inq_dimid(file_id,'grid_yt',dim_id),& + myname_,'inq_dimid grid_yt '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,dim_id,len=ny_tile),& + myname_,'inquire_dimension grid_yt '//trim(filename) ) + if(ny_res.ne.ny_tile) then + write(6,*)'the readin ny_tile does not equal to ny_res as expected, stop' + call stop2(25) + endif + + + + ! read lats/lons from C###_oro_data.tile#.nc + ! (this requires path to FV3 fix dir) + write(char_nxres, '(i4)') nx_res + write(char_nyres, '(i4)') ny_res + allocate(lat_tile(nx_res,ny_res),lon_tile(nx_res,ny_res)) + nn = 0 + allocate(latsgrd(npts),lonsgrd(npts)) + do ntile=1,ntiles + nn_tile0=(ntile-1)*nx_res*ny_res + write(char_tile, '(i1)') ntile + filename='fv3sar_tile'//char_tile//'_grid_spec.nc' + call nc_check( nf90_open(trim(adjustl(filename)),nf90_nowrite,file_id),& + myname_,'open: '//trim(adjustl(filename)) ) + call read_fv3_restart_data2d('grid_lont',filename,file_id,lon_tile) + !print *,'min/max lon_tile',ntile,minval(lon_tile),maxval(lon_tile) + call read_fv3_restart_data2d('grid_latt',filename,file_id,lat_tile) + !print *,'min/max lat_tile',ntile,minval(lat_tile),maxval(lat_tile) + call nc_check( nf90_close(file_id),& + myname_,'close '//trim(filename) ) + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + latsgrd(nn) = lat_tile(i,j) + lonsgrd(nn) = lon_tile(i,j) + enddo + enddo + enddo !loop for ntilet + latsgrd = pi*latsgrd/180._r_single + lonsgrd = pi*lonsgrd/180._r_single + allocate(delp(nx_res,ny_res,nlevs),ps(nx_res,ny_res)) + allocate(g_prsi(nx_res,ny_res,nlevsp1)) + allocate(pressimn(npts,nlevsp1),presslmn(npts,nlevs)) + allocate(spressmn(npts)) + nn = 0 + do ntile=1,ntiles + nn_tile0=(ntile-1)*nx_res*ny_res + nn=nn_tile0 + write(char_tile, '(i1)') ntile + filename = 'fv3sar_tile'//char_tile//"_ensmean_dynvartracer" + !print *,trim(adjustl(filename)) + call nc_check( nf90_open(trim(adjustl(filename)),nf90_nowrite,file_id),& + myname_,'open: '//trim(adjustl(filename)) ) + call read_fv3_restart_data3d('delp',filename,file_id,delp) + !print *,'min/max delp',ntile,minval(delp),maxval(delp) + call nc_check( nf90_close(file_id),& + myname_,'close '//trim(filename) ) + g_prsi(:,:,nlevsp1)=eta1_ll(nlevsp1) !etal_ll is needed + do i=nlevs,1,-1 + g_prsi(:,:,i)=delp(:,:,i)*0.01_r_kind+g_prsi(:,:,i+1) + enddo + + ps = g_prsi(:,:,1) + !print *,'min/max ps',ntile,minval(ps),maxval(ps) + nn=nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + spressmn(nn) = ps(i,j) + enddo + enddo + enddo + ! pressure at interfaces + do k=1,nlevsp1 + nn=nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + pressimn(nn,k) = g_prsi(i,j,k) + enddo + enddo + enddo + do k=1,nlevs + nn=nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + presslmn(nn,k) = (pressimn(nn,k)+pressimn(nn,k+1)) *half + enddo + enddo + end do + print *,'ensemble mean first guess surface pressure:' + print *,minval(spressmn),maxval(spressmn) + ! logp holds log(pressure) or pseudo-height on grid, for each level/variable. + allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers + do k=1,nlevs + ! all variables to be updated are on mid-layers, not layer interfaces. + logp(:,k) = -log(presslmn(:,k)) + !print *,'min/max presslmn',k,minval(presslmn(:,k)),maxval(presslmn(:,k)),minval(logp(:,k)),maxval(logp(:,k)) + end do + logp(:,nlevs_pres) = -log(spressmn(:)) + deallocate(spressmn,presslmn,pressimn) + deallocate(ak,bk,ps) + deallocate(g_prsi,delp) + deallocate(lat_tile,lon_tile) +endif ! root task + + allocate(gridloc(3,npts)) +if (nproc .ne. 0) then + ! allocate arrays on other (non-root) tasks + allocate(latsgrd(npts),lonsgrd(npts)) + allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers + allocate(eta1_ll(nlevsp1),eta2_ll(nlevsp1)) +endif +!call mpi_bcast(logp,npts*nlevs_pres,mpi_real4,0,MPI_COMM_WORLD,ierr) +do k=1,nlevs_pres + call mpi_bcast(logp(1,k),npts,mpi_real4,0,MPI_COMM_WORLD,ierr) +enddo +call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(eta1_ll,nlevsp1,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(eta2_ll,nlevsp1,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr) + +!==> precompute cartesian coords of analysis grid points. +do nn=1,npts + gridloc(1,nn) = cos(latsgrd(nn))*cos(lonsgrd(nn)) + gridloc(2,nn) = cos(latsgrd(nn))*sin(lonsgrd(nn)) + gridloc(3,nn) = sin(latsgrd(nn)) +end do +end subroutine getgridinfo + +subroutine gridinfo_cleanup() +if (allocated(lonsgrd)) deallocate(lonsgrd) +if (allocated(latsgrd)) deallocate(latsgrd) +if (allocated(logp)) deallocate(logp) +if (allocated(gridloc)) deallocate(gridloc) +end subroutine gridinfo_cleanup + +end module gridinfo diff --git a/src/enkf/gridinfo_gfs.f90 b/src/enkf/gridinfo_gfs.f90 index 23ce6d717..cccf828cc 100644 --- a/src/enkf/gridinfo_gfs.f90 +++ b/src/enkf/gridinfo_gfs.f90 @@ -23,9 +23,6 @@ module gridinfo ! nlevs: number of analysis vertical levels (from module params). ! ntrac: number of 'tracer' model state variables (3 for GFS, ! specific humidity, ozone and cloud condensate). -! nvars: number of 'non-tracer' model state variables (usually 4 -! for hydrostatic models). See grdinfo in gridio for a description -! of how these variables must be laid out in input/output files. ! ptop: (real scalar) pressure (hPa) at top model layer interface. ! lonsgrd(npts): real array of analysis grid longitudes (radians). ! latsgrd(npts): real array of analysis grid latitudes (radians). @@ -37,7 +34,9 @@ module gridinfo ! ! program history log: ! 2009-02-23 Initial version. +! 2016-05-02: shlyaeva: Modification for reading state vector from table ! 2016-04-20 Modify to handle the updated nemsio sig file (P, DP & DPDT removed) +! 2019-03-13 Add precipitation components ! ! attributes: ! language: f95 @@ -45,11 +44,9 @@ module gridinfo !$$$ use mpisetup, only: nproc, mpi_integer, mpi_real4, mpi_comm_world -use params, only: datapath,nlevs,nvars,ndim,datestring,charfhr_anal,& - nlons,nlats,nbackgrounds,reducedgrid,massbal_adjust,use_gfs_nemsio,& - fgfileprefixes +use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio, fgfileprefixes use kinds, only: r_kind, i_kind, r_double, r_single -use constants, only: one,zero,pi,cp,rd,grav,rearth +use constants, only: one,zero,pi,cp,rd,grav,rearth,max_varname_length use specmod, only: sptezv_s, sptez_s, init_spec_vars, isinitialized, asin_gaulats, & ndimspec => nc use reducedgrid_mod, only: reducedgrid_init, regtoreduced, reducedtoreg,& @@ -57,8 +54,7 @@ module gridinfo implicit none private public :: getgridinfo, gridinfo_cleanup -integer(i_kind),public :: nlevs_pres,idvc -integer(i_kind),public, allocatable,dimension(:):: index_pres +integer(i_kind),public :: nlevs_pres, idvc real(r_single),public :: ptop real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd ! arrays passed to kdtree2 routines must be single @@ -66,11 +62,14 @@ module gridinfo real(r_single),public, allocatable, dimension(:,:) :: logp integer,public :: npts integer,public :: ntrunc -integer,public :: nvarhumid ! spec hum is the nvarhumid'th var -integer,public :: nvarozone ! ozone is the nvarozone'th var +! supported variable names in anavinfo +character(len=max_varname_length),public, dimension(13) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'oz ', 'cw ', 'tsen', 'prse', & + 'ql ', 'qi ', 'qr ', 'qs ', 'qg '/) +character(len=max_varname_length),public, dimension(3) :: vars2d_supported = (/'ps ', 'pst', 'sst' /) +! supported variable names in anavinfo contains -subroutine getgridinfo() +subroutine getgridinfo(fileprefix, reducedgrid) ! read latitudes, longitudes and pressures for analysis grid, ! broadcast to each task. use sigio_module, only: sigio_head, sigio_data, sigio_sclose, sigio_sropen, & @@ -80,7 +79,10 @@ subroutine getgridinfo() nemsio_readrecv,nemsio_init, nemsio_realkind implicit none -integer(i_kind) nlevsin, ierr, iunit, nvar, k, nn, idvc +character(len=120), intent(in) :: fileprefix +logical, intent(in) :: reducedgrid + +integer(i_kind) nlevsin, ierr, iunit, k, nn, idvc character(len=500) filename integer(i_kind) iret,i,j,nlonsin,nlatsin real(r_kind), allocatable, dimension(:) :: ak,bk,spressmn,tmpspec @@ -97,19 +99,17 @@ subroutine getgridinfo() kapr = cp/rd kap1 = kap + one nlevs_pres=nlevs+1 -nvarhumid = 4 -nvarozone = 5 if (nproc .eq. 0) then if (use_gfs_nemsio) then - filename = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nbackgrounds/2+1)))//"ensmean" + filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean" call nemsio_init(iret=iret) if(iret/=0) then - write(6,*)'grdinfo: gfs model: problem with nemsio_init, iret=',iret + write(6,*)'grdinfo: gfs model: problem with nemsio_init, iret=',iret, ', file: ', trim(filename) call stop2(23) end if call nemsio_open(gfile,filename,'READ',iret=iret) if (iret/=0) then - write(6,*)'grdinfo: gfs model: problem with nemsio_open, iret=',iret + write(6,*)'grdinfo: gfs model: problem with nemsio_open, iret=',iret, ', file: ', trim(filename) call stop2(23) endif call nemsio_getfilehead(gfile,iret=iret, dimx=nlonsin, dimy=nlatsin,& @@ -119,7 +119,7 @@ subroutine getgridinfo() ! FV3GFS write component does not include JCAP, infer from nlatsin if (ntrunc < 0) ntrunc = nlatsin-2 if (iret/=0) then - write(6,*)'grdinfo: gfs model: problem with nemsio_getfilehead, iret=',iret + write(6,*)'grdinfo: gfs model: problem with nemsio_getfilehead, iret=',iret, ', file: ', trim(filename) call stop2(23) endif print *,'ntrunc = ',ntrunc @@ -130,16 +130,16 @@ subroutine getgridinfo() call stop2(23) end if else - filename = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nbackgrounds/2+1)))//"ensmean" + filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean" ! define sighead on all tasks. call sigio_sropen(iunit,trim(filename),iret) if (iret /= 0) then - print *,'error reading file in gridinfo',trim(filename),' on task',nproc + print *,'error reading file in gridinfo ',trim(filename),' on task',nproc call stop2(24) end if call sigio_srhead(iunit,sighead,iret) if (iret /= 0) then - print *,'error reading file in gridinfo',trim(filename),' on task',nproc + print *,'error reading file in gridinfo ',trim(filename),' on task',nproc call stop2(24) end if call sigio_sclose(iunit,iret) @@ -163,21 +163,21 @@ subroutine getgridinfo() call stop2(23) endif -! Extract vertical coordinate descriptions nems_vcoord. -! nems_vcoord(gfshead%levs+1,3,2) dimension is hardwired here. -! Present NEMSIO modules do not allow flexibility of 2nd and 3rd -! array dimension for nems_vcoord, for now, it is hardwired as -! (levs,3,2) If NEMS changes the setting of vcoord dimension, -! GSI needs to update its setting of nems_vcoord accordingly. +! Extract vertical coordinate descriptions nems_vcoord. +! nems_vcoord(gfshead%levs+1,3,2) dimension is hardwired here. +! Present NEMSIO modules do not allow flexibility of 2nd and 3rd +! array dimension for nems_vcoord, for now, it is hardwired as +! (levs,3,2) If NEMS changes the setting of vcoord dimension, +! GSI needs to update its setting of nems_vcoord accordingly. - if (allocated(nems_vcoord)) deallocate(nems_vcoord) - allocate(nems_vcoord(nlevs_pres,3,2)) - call nemsio_getfilehead(gfile,iret=iret,vcoord=nems_vcoord) - if ( iret /= 0 ) then - write(6,*)' gridinfo: ***ERROR*** problem reading header ', & - 'vcoord, Status = ',iret - call stop2(99) - endif + if (allocated(nems_vcoord)) deallocate(nems_vcoord) + allocate(nems_vcoord(nlevs_pres,3,2)) + call nemsio_getfilehead(gfile,iret=iret,vcoord=nems_vcoord) + if ( iret /= 0 ) then + write(6,*)' gridinfo: ***ERROR*** problem reading header ', & + 'vcoord, Status = ',iret + call stop2(99) + endif spressmn = 0.01_r_kind*nems_wrk ! convert ps to millibars. !print *,'min/max spressmn = ',minval(spressmn),maxval(spressmn) @@ -220,13 +220,13 @@ subroutine getgridinfo() call stop2(24) end if allocate(ak(nlevs+1),bk(nlevs+1)) - if (sighead%idvc == 0) then ! sigma coordinate, old file format. + if (sighead%idvc == 0) then ! sigma coordinate, old file format. ak = zero bk = sighead%si(1:nlevs+1) - else if (sighead%idvc == 1) then ! sigma coordinate + else if (sighead%idvc == 1) then ! sigma coordinate ak = zero bk = sighead%vcoord(1:nlevs+1,2) - else if (sighead%idvc == 2 .or. sighead%idvc == 3) then ! hybrid coordinate + else if (sighead%idvc == 2 .or. sighead%idvc == 3) then ! hybrid coordinate ak = 0.01_r_kind*sighead%vcoord(1:nlevs+1,1) ! convert to mb bk = sighead%vcoord(1:nlevs+1,2) else @@ -262,11 +262,11 @@ subroutine getgridinfo() else nn = 0 do j=1,nlats - do i=1,nlons - nn = nn + 1 - lonsgrd(nn) = 2._r_single*pi*float(i-1)/nlons - latsgrd(nn) = asin_gaulats(j) - enddo + do i=1,nlons + nn = nn + 1 + lonsgrd(nn) = 2._r_single*pi*float(i-1)/nlons + latsgrd(nn) = asin_gaulats(j) + enddo enddo endif do k=1,nlevs @@ -319,20 +319,6 @@ subroutine getgridinfo() call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr) - -allocate(index_pres(ndim)) - -nn=0 -do nvar=1,nvars - do k=1,nlevs - nn = nn + 1 - index_pres(nn)=k - end do -end do - -if (massbal_adjust) index_pres(ndim-1)=nlevs+1 ! ps tend -index_pres(ndim)=nlevs+1 ! ps - !==> precompute cartesian coords of analysis grid points. do nn=1,npts gridloc(1,nn) = cos(latsgrd(nn))*cos(lonsgrd(nn)) @@ -347,7 +333,6 @@ subroutine gridinfo_cleanup() if (allocated(latsgrd)) deallocate(latsgrd) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) -if (allocated(index_pres)) deallocate(index_pres) end subroutine gridinfo_cleanup end module gridinfo diff --git a/src/enkf/gridinfo_nmmb.f90 b/src/enkf/gridinfo_nmmb.f90 index 05140d404..d60b077f3 100644 --- a/src/enkf/gridinfo_nmmb.f90 +++ b/src/enkf/gridinfo_nmmb.f90 @@ -1,36 +1,45 @@ module gridinfo use mpisetup -use params, only: datapath,nlevs,nvars,ndim,datestring,& +use params, only: datapath,nlevs,datestring,& nmmb,regional,nlons,nlats,nbackgrounds,fgfileprefixes use kinds, only: r_kind, i_kind, r_double, r_single -use constants, only: one,zero,pi,cp,rd,grav,rearth +use constants, only: one,zero,pi,cp,rd,grav,rearth,max_varname_length + +! history +! 2017-05-12 Y. Wang and X. Wang - add more state variables in cvars3d_supported +! for radar DA, POC: xuguang.wang@ou.edu implicit none private public :: getgridinfo, gridinfo_cleanup, wind2mass, mass2wind integer(i_kind),public :: nlevs_pres -integer(i_kind),public, allocatable,dimension(:):: index_pres real(r_single),public :: ptop real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd ! arrays passed to kdtree2 routines must be single real(r_single),public, allocatable, dimension(:,:) :: gridloc real(r_single),public, allocatable, dimension(:,:) :: logp integer,public :: npts -integer,public :: nvarhumid ! spec hum is the nvarhumid'th var -integer,public :: nvarozone ! ozone is the nvarozone'th var +! supported variable names in anavinfo +character(len=max_varname_length),public, dimension(14) :: vars3d_supported = (/ 'u', 'v', 'tv', 'tsen', 'q', 'oz', & + 'cw', 'prse', 'ql', 'qr', 'qi', & + 'qli', 'dbz', 'w'/) +character(len=max_varname_length),public, dimension(2) :: vars2d_supported = (/ 'ps', 'sst' /) contains -subroutine getgridinfo() +subroutine getgridinfo(fileprefix, reducedgrid) ! read latitudes, longitudes and pressures for analysis grid, ! broadcast to each task. use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_close,& nemsio_getfilehead,nemsio_getheadvar,& nemsio_readrecv,nemsio_init,nemsio_realkind implicit none -character(len=500) filename +character(len=120), intent(in) :: fileprefix +logical, intent(in) :: reducedgrid + integer(i_kind) iret,nlatsin,nlonsin,nlevsin,nlon_test,& - ierr,nlon_test_with_halo,nlat_test_with_halo,nlat_test,nvar,k,nn + ierr,nlon_test_with_halo,nlat_test_with_halo,nlat_test,k,nn +character(len=500) filename real(nemsio_realkind) pt,pdtop real(r_kind), allocatable, dimension(:) :: spressmn real(r_kind), allocatable, dimension(:,:) :: presslmn @@ -40,8 +49,6 @@ subroutine getgridinfo() type(nemsio_gfile) :: gfile nlevs_pres=nlevs+1 -nvarhumid = 4 -nvarozone = 5 ! nmmb does not have ozone? if (nproc .eq. 0) then @@ -52,7 +59,7 @@ subroutine getgridinfo() ! Build the ensemble mean filename expected by routine - filename = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nbackgrounds/2+1)))//"_ensmean" + filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean" call nemsio_init(iret=iret) if(iret/=0) then @@ -61,11 +68,11 @@ subroutine getgridinfo() end if call nemsio_open(gfile,filename,'READ',iret=iret) if (iret/=0) then - write(6,*)'gridinfo: nmmb model: problem with nemsio_open, iret=',iret + write(6,*)'gridinfo: nmmb model: problem with nemsio_open,iret=',iret,trim(filename) call stop2(24) end if call nemsio_getfilehead(gfile,iret=iret,dimx=nlonsin,dimy=nlatsin, & - dimz=nlevsin,lat=lats,lon=lons) + dimz=nlevsin,lat=lats,lon=lons) if (iret/=0) then write(6,*)'gridinfo: nmmb model: problem with nemsio_getfilehead, iret=',iret call stop2(24) @@ -118,7 +125,7 @@ subroutine getgridinfo() lonsgrd = lons; latsgrd = lats print *,'min/max lonsgrd',minval(lonsgrd),maxval(lonsgrd) print *,'min/max latsgrd',minval(latsgrd),maxval(latsgrd) - + call nemsio_getheadvar(gfile,'PT',pt,iret) pt = 0.01*pt ptop = pt @@ -167,18 +174,6 @@ subroutine getgridinfo() call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr) -allocate(index_pres(ndim)) - -nn=0 -do nvar=1,nvars - do k=1,nlevs - nn = nn + 1 - index_pres(nn)=k - end do -end do - -index_pres(ndim)=nlevs+1 ! ps - !==> precompute cartesian coords of analysis grid points. do nn=1,npts gridloc(1,nn) = cos(latsgrd(nn))*cos(lonsgrd(nn)) @@ -193,7 +188,6 @@ subroutine gridinfo_cleanup() if (allocated(latsgrd)) deallocate(latsgrd) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) -if (allocated(index_pres)) deallocate(index_pres) end subroutine gridinfo_cleanup subroutine wind2mass(dat,nlons,nlats) @@ -251,3 +245,4 @@ subroutine mass2wind(dat,nlons,nlats) end subroutine mass2wind end module gridinfo + diff --git a/src/enkf/gridinfo_wrf.f90 b/src/enkf/gridinfo_wrf.f90 index 1d807c2ca..f4f68a64c 100644 --- a/src/enkf/gridinfo_wrf.f90 +++ b/src/enkf/gridinfo_wrf.f90 @@ -20,6 +20,8 @@ module gridinfo ! pressure profile (i.e., presslmn) is computed as it is in ! within the GSI subroutine get_wrf_nmm_ensperts.F90. ! Henry R. Winterbottom + ! 2017-05-12 Y. Wang and X. Wang - add more state variables in + ! cvars3d_supported for radar DA, POC: xuguang.wang@ou.edu ! ! attributes: ! language: f95 @@ -31,11 +33,10 @@ module gridinfo ! Define associated modules use constants, only: rearth_equator, omega, pi, deg2rad, zero, rad2deg, & - rearth + rearth,max_varname_length use kinds, only: i_kind, r_kind, r_single, i_long, r_double - use enkf_obsmod, only: obloc, obloclat, obloclon, nobstot - use params, only: datapath, nlevs, nvars, ndim, nlons, nlats, & - arw, nmm, nbackgrounds, fgfileprefixes + use params, only: datapath, nlevs, nlons, nlats, & + arw, nmm use mpisetup use netcdf_io @@ -63,298 +64,35 @@ module gridinfo real(r_single), dimension(:), allocatable, public :: lonsgrd real(r_single), dimension(:), allocatable, public :: latsgrd real(r_single), public :: ptop - integer(i_kind), dimension(:), allocatable, public :: index_pres integer(i_long), public :: npts - integer(i_kind), public :: nvarhumid ! specific hum is the nvarhumid'th var - integer(i_kind), public :: nvarozone=0 ! ozone is the nvarhumid'th var integer(i_kind), public :: nlevs_pres - ! Define variables indicating analysis variables to be updated - ! during EnKF experiments (eventually the logical variables will be - ! collected from the namelist (i.e., params module) - - character(len=12), dimension(:), allocatable, public :: gridvarstring - - !------------------------------------------------------------------------- - ! Define all public subroutines within this module private - public :: definegridvariables public :: getgridinfo public :: gridinfo_cleanup public :: cross2dot public :: dot2cross + ! supported variable names in anavinfo + character(len=max_varname_length),public, dimension(19) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'w ', 'cw ', 'ph ', 'ql ', 'qr ', 'qs ', 'qg ', 'qi ', 'qni ', 'qnr ', 'qnc ', 'dbz ', 'oz ', 'tsen', 'prse' /) + character(len=max_varname_length),public, dimension(2) :: vars2d_supported = (/ 'ps ', 'sst' /) contains - subroutine getgridinfo() + subroutine getgridinfo(fileprefix, reducedgrid) + character(len=120), intent(in) :: fileprefix + logical, intent(in) :: reducedgrid + if (arw) then - call getgridinfo_arw() + call getgridinfo_arw(fileprefix) else - call getgridinfo_nmm() + call getgridinfo_nmm(fileprefix) end if end subroutine getgridinfo !========================================================================= - ! definegridvariables.f90: This subroutine will define all analysis - ! variables to be updated for the respective EnKF experiments; this - ! subroutine can handle either ARW or NMM dynamical core input - ! files; the respective dynamical core is the determined by the - ! logical variables defined above - - !------------------------------------------------------------------------- - - ! *USER*: Edit the following subroutines to correspond to the - ! 3-dimensional variables to be updated during the data assimilation - - ! *NOTE (for ARW)*: the dry surface pressure prognostic variable - ! (MU) **MUST** be the last variable; the total number of variables - ! is nvars+1 - - ! *NOTE (for NMM)*: the dry surface pressure prognostic variable - ! (PD) **MUST** be the last variable; the total number of variables - ! is nvars+1 - - !------------------------------------------------------------------------- - - subroutine definegridvariables() - - !----------------------------------------------------------------------- - - ! Define the total number of analysis variables to be updated for - ! the respective EnKF experiments - - if(.not. allocated(gridvarstring)) allocate(gridvarstring(nvars+1)) - - !----------------------------------------------------------------------- - - ! Define netcdf variable strings corresponding to variables to be - ! updated for the WRF ARW dynamical core - - if(arw) then - - if (nvars .eq. 3) then - - if (nproc .eq. 0) then - - ! Print message to user - - write(6,*) 'Updating U, V, T, and MU for WRF-ARW...' - - endif ! if (nproc .eq. 0) then - - ! *USER*: The following variables will be updated using the - ! innovations and increments produced by the data - ! assimilation - - gridvarstring(1) = "U" - gridvarstring(2) = "V" - gridvarstring(3) = "T" - gridvarstring(4) = "MU" - nvarhumid = 0 - - else if (nvars .eq. 4) then - - if (nproc .eq. 0) then - - ! Print message to user - - write(6,*) 'Updating U, V, T, QVAPOR, and MU for WRF-ARW...' - - endif ! if (nproc .eq. 0) then - - ! *USER*: The following variables will be updated using the - ! innovations and increments produced by the data - ! assimilation - - gridvarstring(1) = "U" - gridvarstring(2) = "V" - gridvarstring(3) = "T" - gridvarstring(4) = "QVAPOR" - gridvarstring(5) = "MU" - nvarhumid = 4 - - else if (nvars .eq. 5) then - - if (nproc .eq. 0) then - - ! Print message to user - - print *,'Updating U, V, T, QVAPOR, PH, and MU for WRF-ARW...' - - endif ! if (nproc .eq. 0) then - - ! *USER*: The following variables will be updated using the - ! innovations and increments produced by the data - ! assimilation - - gridvarstring(1) = "U" - gridvarstring(2) = "V" - gridvarstring(3) = "T" - gridvarstring(4) = "QVAPOR" - gridvarstring(5) = "PH" - gridvarstring(6) = "MU" - nvarhumid = 4 - - else if (nvars .eq. 6) then - - if (nproc .eq. 0) then - - ! Print message to user - - write(6,*) 'Updating U, V, T, QVAPOR, W, PH, and MU for WRF-ARW...' - - endif ! if (nproc .eq. 0) then - - ! *USER*: The following variables will be updated using the - ! innovations and increments produced by the data - ! assimilation - - gridvarstring(1) = "U" - gridvarstring(2) = "V" - gridvarstring(3) = "T" - gridvarstring(4) = "QVAPOR" - gridvarstring(5) = "W" - gridvarstring(6) = "PH" - gridvarstring(7) = "MU" - nvarhumid = 4 - - else - - if (nproc .eq. 0) then - - ! Print message to user - - write(6,*) '!!! USER !!! You need to specify ',nvars,' 3d variables to update, plus MU!' - write(6,*) '!!! USER !!! Edit subroutine definegridvariables in gridinfo.F90 and recompile' - - endif ! if (nproc .eq. 0) then - - ! Exit routine - - call stop2(22) - - endif ! if (nvars .eq. 3) then - - end if ! if(arw) then - - !----------------------------------------------------------------------- - - ! Define netcdf variable strings corresponding to variables to be - ! updated for the WRF NMM dynamical core - - if(nmm) then - - if (nvars .eq. 3) then - - if (nproc .eq. 0) then - - ! Print message to user - - write(6,*) 'Updating U, V, T, and PD for WRF-NMM...' - - endif ! if (nproc .eq. 0) then - - ! *USER*: The following variables will be updated using the - ! innovations and increments produced by the data - ! assimilation - - gridvarstring(1) = "U" - gridvarstring(2) = "V" - gridvarstring(3) = "T" - gridvarstring(4) = "PD" - nvarhumid = 0 - - else if (nvars .eq. 4) then - - if (nproc .eq. 0) then - - ! Print message to user - - write(6,*) 'Updating U, V, T, Q, and PD for WRF-NMM...' - - endif ! if (nproc .eq. 0) then - - ! *USER*: The following variables will be updated using the - ! innovations and increments produced by the data - ! assimilation - - gridvarstring(1) = "U" - gridvarstring(2) = "V" - gridvarstring(3) = "T" - gridvarstring(4) = "Q" - gridvarstring(5) = "PD" - nvarhumid = 4 - - else if (nvars .eq. 5) then - - if (nproc .eq. 0) then - - ! Print message to user - - write(6,*) 'Updating U, V, T, Q, CWM, and PD for WRF-NMM...' - - endif ! if (nproc .eq. 0) then - - ! *USER*: The following variables will be updated using the - ! innovations and increments produced by the data - ! assimilation - - gridvarstring(1) = "U" - gridvarstring(2) = "V" - gridvarstring(3) = "T" - gridvarstring(4) = "Q" - gridvarstring(5) = "CWM" - gridvarstring(6) = "PD" - nvarhumid = 4 - - else - - if (nproc .eq. 0) then - - ! Print message to user - - write(6,*) '!!! USER !!! You need to specify ',nvars,' 3d variables to update, plus MU!' - write(6,*) '!!! USER !!! Edit subroutine definegridvariables in gridinfo.F90 and recompile' - - endif ! if (nproc .eq. 0) then - - ! Exit routine - - call stop2(22) - - endif ! if (nvars .eq. 3) then - - end if ! if(nmm) then - - !------------------------------------------------------------------------- - - ! Provide error checking to make sure that the user has choosen - ! one of the available dynamical core options via the namelist - ! variables - - if(.not. arw .and. .not. nmm) then - - ! Print message to user - - write(6,*) '!!! USER !!! You have not defined the logical variables appropriately which ' - write(6,*) ' state that you are using the WRF ARW or NMM dynamical cores ' - write(6,*) ' within the namelist. Aborting routine.' - - ! Exit routine - - call stop2(22) - - end if ! if(.not. arw .and. .not. nmm) - - !------------------------------------------------------------------------- - - end subroutine definegridvariables - - !========================================================================= - ! getgridinfo_arw.f90: This subroutine will define, compute, and ! return all attributes required from WRF ARW model grid, provided ! the file name string; typically this subroutine will operate on @@ -368,422 +106,270 @@ end subroutine definegridvariables !------------------------------------------------------------------------- - subroutine getgridinfo_arw() + subroutine getgridinfo_arw(fileprefix) + character(len=120), intent(in) :: fileprefix ! Define variables ingested from external file - real, dimension(:,:,:), allocatable :: wrfarw_mu real, dimension(:,:,:), allocatable :: wrfarw_mub real, dimension(:,:,:), allocatable :: wrfarw_znu ! Define variables returned by subroutine - real(r_kind), dimension(:,:), allocatable :: presslmn real(r_kind), dimension(:), allocatable :: spressmn ! Define variables computed within subroutine - character(len=500) :: filename real, dimension(:,:,:), allocatable :: workgrid - real(r_kind) :: radlon - real(r_kind) :: radlat - real(r_kind) :: dlon - real(r_kind) :: dlat - real(r_kind) :: recenter_xlat - real :: recenter_dx - real(r_kind) :: lonsgrdmin - real(r_kind) :: lonsgrdmax - real(r_kind) :: latsgrdmin - real(r_kind) :: latsgrdmax integer :: nlevsin integer :: nlonsin integer :: nlatsin integer :: nn integer :: ierr - integer :: nvar ! Define variables required for netcdf I/O - character(len=12) :: varstringname - character(len=50) :: attstringname character(len=20), dimension(3) :: dimstring integer, dimension(3) :: dims ! Define counting variables - integer :: i, j, k - integer :: count, nob + integer :: count !====================================================================== + if(.not. arw .and. .not. nmm) then + ! Print message to user + write(6,*) '!!! USER !!! You have not defined the logical variables appropriately which ' + write(6,*) ' state that you are using the WRF ARW or NMM dynamical cores ' + write(6,*) ' within the namelist. Aborting routine.' - ! Define prognostic model variable structure type - - call definegridvariables() - + ! Exit routine + call stop2(22) + + end if ! if(.not. arw .and. .not. nmm) ! Define local values and prepare for array dimension definitions - dimstring(1) = "west_east" dimstring(2) = "south_north" dimstring(3) = "bottom_top" ! Build the ensemble mean filename expected by routine - - filename = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nbackgrounds/2+1)))//"ensmean" + filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean" ! Obtain unstaggered grid dimensions from ingested variable file - call netcdfdimension(filename,3,dimstring,dims) ! Define array dimension structure type - dimensions = griddimensions(dims(1),dims(2),dims(3)) ! Compute all variables required by subsequent routines - npts = dimensions%xdim*dimensions%ydim nlevsin = dimensions%zdim nlonsin = dimensions%xdim nlatsin = dimensions%ydim !---------------------------------------------------------------------- - ! Perform sanity and error checks for variable dimensions; proceed ! accordingly - if (nlons .ne. nlonsin) then - - ! Print message to user - write(6,*) 'Error reading input file in gridinfo...' write(6,*) ' nlons ingested from file = ', nlonsin write(6,*) ' nlons specified in namelist = ', nlons write(6,*) 'Failed in subroutine getgridinfo_arw; Aborting!' ! Exit routine - call stop2(22) - end if ! if (nlons .ne. nlonsin) - ! Perform sanity and error checks for variable dimensions; proceed - ! accordingly - if (nlats .ne. nlatsin) then - - ! Print message to user - write(6,*) 'Error reading input file in gridinfo...' write(6,*) ' nlats ingested from file = ', nlatsin write(6,*) ' nlats specified in namelist = ', nlats write(6,*) 'Failed in subroutine getgridinfo_arw; Aborting!' ! Exit routine - call stop2(22) - end if ! if (nlats .ne. nlatsin) - ! Perform sanity and error checks for variable dimensions; proceed - ! accordingly - if (nlevs .ne. nlevsin) then - - ! Print message to user - write(6,*) 'Error reading input file in gridinfo...' write(6,*) ' nlevs ingested from file = ', nlevsin write(6,*) ' nlevs specified in namelist = ', nlevs write(6,*) 'Failed in subroutine getgridinfo_arw; Aborting!' ! Exit routine - call stop2(22) - end if ! if (nlevs .ne. nlevsin) !---------------------------------------------------------------------- - ! Compute local variable; number of model levels plus surface ! (levels at which ens. mean log pressure defined for localization ! via array logp) - nlevs_pres=dimensions%zdim+1 ! Allocate memory for global arrays - if(.not. allocated(lonsgrd)) allocate(lonsgrd(npts)) if(.not. allocated(latsgrd)) allocate(latsgrd(npts)) if(.not. allocated(logp)) allocate(logp(npts,nlevs_pres)) !====================================================================== - ! Begin: Ingest all grid variables required for EnKF routines and ! perform necessary conversions; the data is only ingested on the ! master node and then subsequently passed to the slave nodes - !---------------------------------------------------------------------- - if (nproc .eq. 0) then ! only read data on root. - ! Allocate memory for all global arrays - if(.not. allocated(presslmn)) allocate(presslmn(npts,nlevs)) if(.not. allocated(spressmn)) allocate(spressmn(npts)) - ! Allocate memory for all local arrays - if(.not. allocated(wrfarw_mu)) & & allocate(wrfarw_mu(dimensions%xdim,dimensions%ydim,1)) if(.not. allocated(wrfarw_mub)) & & allocate(wrfarw_mub(dimensions%xdim,dimensions%ydim,1)) if(.not. allocated(wrfarw_znu)) & & allocate(wrfarw_znu(1,1,dimensions%zdim)) - - !---------------------------------------------------------------------- - - ! Allocate memory for local variable grid - if(.not. allocated(workgrid)) allocate(workgrid(dimensions%xdim, & & dimensions%ydim,1)) ! Ingest variable from external file - varstringname = 'XLONG' call readnetcdfdata(filename,workgrid,varstringname, & & dimensions%xdim,dimensions%ydim,1) ! Initialize counting variable - count = 1 ! Loop through meridional horizontal coordinate - do j = 1, dimensions%ydim - ! Loop through zonal horizontal coordinate - do i = 1, dimensions%xdim - ! Convert from degrees to radians and update the ! global longitude array - lonsgrd(count) = workgrid(i,j,1)*deg2rad - ! Update counting variable - count = count + 1 - end do ! do i = 1, dimensions%xdim - end do ! do j = 1, dimensions%ydim ! Deallocate memory for local variable grid - if(allocated(workgrid)) deallocate(workgrid) ! Allocate memory for local variable grid - if(.not. allocated(workgrid)) allocate(workgrid(dimensions%xdim, & & dimensions%ydim,1)) ! Ingest variable from external file - varstringname = 'XLAT' call readnetcdfdata(filename,workgrid,varstringname, & & dimensions%xdim,dimensions%ydim,1) ! Initialize counting variable - count = 1 ! Loop through meridional horizontal coordinate - do j = 1, dimensions%ydim - ! Loop through zonal horizontal coordinate - do i = 1, dimensions%xdim - ! Convert from degrees to radians and update the ! global latitude array - latsgrd(count) = workgrid(i,j,1)*deg2rad - ! Update counting variable - count = count + 1 - end do ! do i = 1, dimensions%xdim - end do ! do j = 1, dimensions%ydim ! Deallocate memory for local variable grid - if(allocated(workgrid)) deallocate(workgrid) - !---------------------------------------------------------------------- - - - ! Ingest surface pressure grid from external file - - varstringname = gridvarstring(nvars+1) - - ! Check that the last variable element in array is (at least - ! analogous) to surface pressure - - if(trim(varstringname) .ne. 'MU' .and. trim(varstringname) .ne. & - & 'PSFC') then - - ! Print message to user - - write(6,*) 'The last variable must be MU or PSFC. However, the ', & - & 'character string is ', trim(varstringname), '. ', & - & 'Aborting!' - - ! Exit routine - - call stop2(22) - - endif ! if(trim(varstringname) .ne. 'MU' .and. trim(varstringname) & - ! .ne. 'PSFC') - !---------------------------------------------------------------------- ! Ingest the model vertical (eta) levels from the external file - varstringname = 'ZNU' call readnetcdfdata(filename,wrfarw_znu,varstringname,1,1, & & dimensions%zdim) ! Ingest the model perturbation dry air mass from the external ! file - varstringname = 'MU' call readnetcdfdata(filename,wrfarw_mu,varstringname, & & dimensions%xdim,dimensions%ydim,1) ! Ingest the model base state dry air mass from the external ! file - varstringname = 'MUB' call readnetcdfdata(filename,wrfarw_mub,varstringname, & & dimensions%xdim,dimensions%ydim,1) ! Allocate memory for local variable grid - if(.not. allocated(workgrid)) allocate(workgrid(1,1,1)) ! Ingest variable from external file - varstringname = 'P_TOP' call readnetcdfdata(filename,workgrid,varstringname,1,1,1) ! Define local variable - ptop = workgrid(1,1,1) ! Rescale pressure from Pa to hPa - ptop = ptop/100.0 ! Deallocate memory for local variable grid - if(allocated(workgrid)) deallocate(workgrid) !---------------------------------------------------------------------- ! Initialize counting variable - count = 1 ! Loop through meridional horizontal coordinate - do j = 1, dimensions%ydim - ! Loop through zonal horizontal coordinate - do i = 1, dimensions%xdim - ! Convert from Pa to hPa and update the global surface ! pressure array - spressmn(count) = (wrfarw_mu(i,j,1) + & wrfarw_mub(i,j,1) + ptop*100.0)/100.0 - ! Update counting variable - count = count + 1 - end do ! do i = 1, dimensions%xdim - end do ! do j = 1, dimensions%ydim !---------------------------------------------------------------------- - - ! Initialize counting variable - - nn = 0 - ! Loop through vertical coordinate - do k = 1, dimensions%zdim - - ! Update counting variable - - nn = nn + 1 - ! Initialize counting variable - count = 1 - ! Loop through meridional horizontal coordinate - do j = 1, dimensions%ydim - ! Loop through zonal horizontal coordinate - do i = 1, dimensions%xdim - ! Compute the pressure within the respective layer ! (dry hydrostatic pressure) - presslmn(count,k) = wrfarw_znu(1,1,k)*(wrfarw_mu(i,j,1) + & & wrfarw_mub(i,j,1)) + ptop*100.0 ! Rescale pressure from Pa to hPa - presslmn(count,k) = presslmn(count,k)/100.0 ! Compute the log of the pressure within the ! respective layer - logp(count,k) = -log(presslmn(count,k)) - ! Update counting variable - count = count + 1 - end do ! do i = 1, dimensions%xdim - end do ! do j = 1, dimensions%ydim - end do ! do k = 1, dimensions%zdim ! Compute local variable - logp(:,nlevs_pres) = -log(spressmn(:)) - ! Print message to user - write(6,*) 'Surface pressure (spressmn) min/max range:', & & minval(spressmn),maxval(spressmn) !---------------------------------------------------------------------- ! Deallocate memory for all local arrays - if(allocated(wrfarw_mu)) deallocate(wrfarw_mu) if(allocated(wrfarw_mub)) deallocate(wrfarw_mub) if(allocated(wrfarw_znu)) deallocate(wrfarw_znu) @@ -796,41 +382,6 @@ subroutine getgridinfo_arw() !---------------------------------------------------------------------- - ! Define index_pres which is an index array to determine pressure - ! value for given analysis variable - - if(.not. allocated(index_pres)) allocate(index_pres(ndim)) - - ! Initialize counting variable - - nn = 0 - - ! Loop through total number of analysis variables - - do nvar = 1, nvars - - ! Loop through vertical levels - - do k = 1, dimensions%zdim - - ! Update counting variable - - nn = nn + 1 - - ! Update global variable array - - index_pres(nn) = k - - end do ! do k = 1, dimensions%zdim - - end do ! do nvar = 1, nvars - - ! Update global variable array - - index_pres(ndim) = nlevs+1 - - !---------------------------------------------------------------------- - ! End: Ingest all grid variables required for EnKF routines and ! perform necessary conversions; the data is only ingested on the ! master node and then subsequently passed to the slave nodes @@ -838,7 +389,6 @@ subroutine getgridinfo_arw() !====================================================================== ! Broadcast all common variables these out to all nodes - call MPI_Bcast(logp,npts*nlevs_pres,mpi_real4,0,MPI_COMM_WORLD,ierr) call MPI_Bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call MPI_Bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) @@ -846,28 +396,17 @@ subroutine getgridinfo_arw() !---------------------------------------------------------------------- - ! Allocate memory for local variable - if(.not. allocated(gridloc)) allocate(gridloc(3,npts)) ! Loop through each grid coordinate and perform the coordinate ! transform for regular simulation domains do nn = 1, npts - - ! Compute local variable - + ! Compute local variables gridloc(1,nn) = cos(latsgrd(nn))*cos(lonsgrd(nn)) - - ! Compute local variable - gridloc(2,nn) = cos(latsgrd(nn))*sin(lonsgrd(nn)) - - ! Compute local variable - gridloc(3,nn) = sin(latsgrd(nn)) - end do ! do nn = 1, npts end subroutine getgridinfo_arw @@ -883,10 +422,10 @@ end subroutine getgridinfo_arw !------------------------------------------------------------------------- - subroutine getgridinfo_nmm() + subroutine getgridinfo_nmm(fileprefix) + character(len=120), intent(in) :: fileprefix ! Define variables ingested from external file - real, dimension(:,:,:), allocatable :: wrfnmm_eta real, dimension(:,:,:), allocatable :: wrfnmm_pd real, dimension(:,:,:), allocatable :: wrfnmm_pdtop @@ -894,59 +433,53 @@ subroutine getgridinfo_nmm() real, dimension(:,:,:), allocatable :: wrfnmm_aeta1 real, dimension(:,:,:), allocatable :: wrfnmm_aeta2 - ! Define variables returned by subroutine - + ! Define variables returned by subroutine real(r_kind), dimension(:,:), allocatable :: presslmn real(r_kind), dimension(:), allocatable :: spressmn ! Define variables computed within subroutine - character(len=500) :: filename - real, dimension(:,:,:), allocatable :: workgrid + real, dimension(:,:,:), allocatable :: workgrid integer :: nlevsin integer :: nlonsin integer :: nlatsin integer :: nn integer :: ierr - integer :: nvar ! Define variables required for netcdf I/O - character(len=12) :: varstringname character(len=20), dimension(3) :: dimstring integer, dimension(3) :: dims ! Define counting variables - integer :: i, j, k integer :: count !====================================================================== - ! Define prognostic model variable structure type - - call definegridvariables() + if(.not. arw .and. .not. nmm) then + write(6,*) '!!! USER !!! You have not defined the logical variables appropriately which ' + write(6,*) ' state that you are using the WRF ARW or NMM dynamical cores ' + write(6,*) ' within the namelist. Aborting routine.' + ! Exit routine + call stop2(22) + end if ! if(.not. arw .and. .not. nmm) ! Define local values and prepare for array dimension definitions - dimstring(1) = "west_east" dimstring(2) = "south_north" dimstring(3) = "bottom_top" ! Build the ensemble mean filename expected by routine - - filename = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nbackgrounds/2+1)))//"ensmean" + filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean" ! Obtain unstaggered grid dimensions from ingested variable file - call netcdfdimension(filename,3,dimstring,dims) ! Define array dimension structure type - dimensions = griddimensions(dims(1),dims(2),dims(3)) ! Compute all variables required by subsequent routines - npts = dimensions%xdim*dimensions%ydim nlevsin = dimensions%zdim nlonsin = dimensions%xdim @@ -956,56 +489,34 @@ subroutine getgridinfo_nmm() ! Perform sanity and error checks for variable dimensions; proceed ! accordingly - if (nlons .ne. nlonsin) then - - ! Print message to user - write(6,*) 'Error reading input file in gridinfo...' write(6,*) ' nlons ingested from file = ', nlonsin write(6,*) ' nlons specified in namelist = ', nlons write(6,*) 'Failed in subroutine getgridinfo_nmm; Aborting!' ! Exit routine - call stop2(22) - end if ! if (nlons .ne. nlonsin) - ! Perform sanity and error checks for variable dimensions; proceed - ! accordingly - if (nlats .ne. nlatsin) then - - ! Print message to user - write(6,*) 'Error reading input file in gridinfo...' write(6,*) ' nlats ingested from file = ', nlatsin write(6,*) ' nlats specified in namelist = ', nlats write(6,*) 'Failed in subroutine getgridinfo_nmm; Aborting!' ! Exit routine - call stop2(22) - end if ! if (nlats .ne. nlatsin) - ! Perform sanity and error checks for variable dimensions; proceed - ! accordingly - if (nlevs .ne. nlevsin) then - - ! Print message to user - write(6,*) 'Error reading input file in gridinfo...' write(6,*) ' nlevs ingested from file = ', nlevsin write(6,*) ' nlevs specified in namelist = ', nlevs write(6,*) 'Failed in subroutine getgridinfo_nmm; Aborting!' ! Exit routine - call stop2(22) - end if ! if (nlevs .ne. nlevsin) !---------------------------------------------------------------------- @@ -1013,11 +524,9 @@ subroutine getgridinfo_nmm() ! Compute local variable; number of model levels plus surface ! (levels at which ens. mean log pressure defined for localization ! via array logp) - nlevs_pres=dimensions%zdim+1 ! Allocate memory for global arrays - if(.not. allocated(lonsgrd)) allocate(lonsgrd(npts)) if(.not. allocated(latsgrd)) allocate(latsgrd(npts)) if(.not. allocated(logp)) allocate(logp(npts,nlevs_pres)) @@ -1031,14 +540,11 @@ subroutine getgridinfo_nmm() !---------------------------------------------------------------------- if (nproc .eq. 0) then ! only read data on root. - ! Allocate memory for all global arrays - if(.not. allocated(presslmn)) allocate(presslmn(npts,nlevs)) if(.not. allocated(spressmn)) allocate(spressmn(npts)) ! Allocate memory for all local arrays - if(.not. allocated(wrfnmm_eta)) & & allocate(wrfnmm_eta(1,1,dimensions%zdim)) if(.not. allocated(wrfnmm_pd)) & @@ -1055,225 +561,129 @@ subroutine getgridinfo_nmm() !---------------------------------------------------------------------- ! Allocate memory for local variable grid - if(.not. allocated(workgrid)) allocate(workgrid(dimensions%xdim, & & dimensions%ydim,1)) ! Ingest variable from external file - varstringname = 'GLON' call readnetcdfdata(filename,workgrid,varstringname,dimensions%xdim, & & dimensions%ydim,1) ! Initialize counting variable - count = 1 ! Loop through meridional horizontal coordinate - do j = 1, dimensions%ydim - ! Loop through zonal horizontal coordinate - do i = 1, dimensions%xdim - ! Convert from degrees to radians and update the global ! longitude array - lonsgrd(count) = workgrid(i,j,1) - ! Update counting variable - count = count + 1 - end do ! do i = 1, dimensions%xdim - end do ! do j = 1, dimensions%ydim ! Deallocate memory for local variable grid - if(allocated(workgrid)) deallocate(workgrid) ! Allocate memory for local variable grid - if(.not. allocated(workgrid)) allocate(workgrid(dimensions%xdim, & & dimensions%ydim,1)) ! Ingest variable from external file - varstringname = 'GLAT' call readnetcdfdata(filename,workgrid,varstringname, & & dimensions%xdim,dimensions%ydim,1) ! Initialize counting variable - count = 1 ! Loop through meridional horizontal coordinate - do j = 1, dimensions%ydim - ! Loop through zonal horizontal coordinate - do i = 1, dimensions%xdim - ! Convert from degrees to radians and update the global ! latitude array - latsgrd(count) = workgrid(i,j,1) - ! Update counting variable - count = count + 1 - end do ! do i = 1, dimensions%xdim - end do ! do j = 1, dimensions%ydim ! Deallocate memory for local variable grid - if(allocated(workgrid)) deallocate(workgrid) !---------------------------------------------------------------------- - ! Ingest surface pressure grid from external file - - varstringname = gridvarstring(nvars+1) - - ! Check that the last variable element in array is (at least - ! analogous) to surface pressure - - if(trim(varstringname) .ne. 'PD' .and. trim(varstringname) .ne. & - & 'PSFC') then - - ! Print message to user - - write(6,*) 'The last variable must be PD or PSFC. However, the ', & - & 'character string is ', trim(varstringname), '. ', & - & 'Aborting!' - - ! Exit routine - - call stop2(22) - - endif ! if(trim(varstringname) .ne. 'PD' .and. trim(varstringname) & - ! .ne. 'PSFC') - - ! Ingest variable from external file - + ! Ingest variables from external file varstringname = 'PD' call readnetcdfdata(filename,wrfnmm_pd,varstringname, & & dimensions%xdim,dimensions%ydim,1) - ! Ingest variable from external file - varstringname = 'PDTOP' call readnetcdfdata(filename,wrfnmm_pdtop,varstringname,1,1,1) - ! Ingest variable from external file - varstringname = 'PT' call readnetcdfdata(filename,wrfnmm_pt,varstringname,1,1,1) - ! Ingest variable from external file - varstringname = 'AETA1' call readnetcdfdata(filename,wrfnmm_aeta1,varstringname,1,1,dimensions%zdim) - ! Ingest variable from external file - varstringname = 'AETA2' call readnetcdfdata(filename,wrfnmm_aeta2,varstringname,1,1,dimensions%zdim) ! Initialize counting variable - count = 1 ! Loop through meridional horizontal coordinate - do j = 1, dimensions%ydim - ! Loop through zonal horizontal coordinate - do i = 1, dimensions%xdim - ! Convert from Pa to hPa and update the global surface ! pressure array - spressmn(count) = (wrfnmm_pd(i,j,1) + wrfnmm_pdtop(1,1,1) + & & wrfnmm_pt(1,1,1))/100.0 - ! Update counting variable - count = count + 1 - end do ! do i = 1, dimensions%xdim - end do ! do j = 1, dimensions%ydim ! Define local variable and rescale pressure from Pa to hPa - ptop = wrfnmm_pt(1,1,1)/100.0 !---------------------------------------------------------------------- - ! Initialize counting variable - - nn = 0 - ! Loop through vertical coordinate - do k = 1, dimensions%zdim - - ! Update counting variable - - nn = nn + 1 - ! Initialize counting variable - count = 1 - ! Loop through meridional horizontal coordinate - do j = 1, dimensions%ydim - ! Loop through zonal horizontal coordinate - do i = 1, dimensions%xdim - ! Compute the pressure within the respective layer ! (dry hydrostatic pressure) - presslmn(count,k) = (wrfnmm_aeta1(1,1,k)* & & wrfnmm_pdtop(1,1,1)) + wrfnmm_aeta2(1,1,k)*( & & spressmn(count)*100.0 - wrfnmm_pdtop(1,1,1) - & & wrfnmm_pt(1,1,1)) + wrfnmm_pt(1,1,1) ! Rescale pressure from Pa to hPa - presslmn(count,k) = presslmn(count,k)/100.0 ! Compute the log of the pressure within the ! respective layer - logp(count,k) = -log(presslmn(count,k)) - ! Update counting variable - count = count + 1 - end do ! do i = 1, dimensions%xdim - end do ! do j = 1, dimensions%ydim - end do ! do k = 1, dimensions%zdim ! Compute local variable - logp(:,nlevs_pres) = -log(spressmn(:)) - ! Print message to user - write(6,*) 'Surface pressure (spressmn) min/max range:', & & minval(spressmn),maxval(spressmn) write(6,*) 'Longitude range (min/max): ', minval(lonsgrd*rad2deg), & @@ -1284,7 +694,6 @@ subroutine getgridinfo_nmm() !---------------------------------------------------------------------- ! Deallocate memory for all local arrays - if(allocated(wrfnmm_pd)) deallocate(wrfnmm_pd) if(allocated(wrfnmm_pdtop)) deallocate(wrfnmm_pdtop) if(allocated(wrfnmm_pt)) deallocate(wrfnmm_pt) @@ -1299,41 +708,6 @@ subroutine getgridinfo_nmm() !---------------------------------------------------------------------- - ! Define index_pres which is an index array to determine pressure - ! value for given analysis variable - - if(.not. allocated(index_pres)) allocate(index_pres(ndim)) - - ! Initialize counting variable - - nn = 0 - - ! Loop through total number of analysis variables - - do nvar = 1, nvars - - ! Loop through vertical levels - - do k = 1, dimensions%zdim - - ! Update counting variable - - nn = nn + 1 - - ! Update global variable array - - index_pres(nn) = k - - end do ! do k = 1, dimensions%zdim - - end do ! do nvar = 1, nvars - - ! Update global variable array - - index_pres(ndim) = nlevs+1 - - !---------------------------------------------------------------------- - ! End: Ingest all grid variables required for EnKF routines and ! perform necessary conversions; the data is only ingested on the ! master node and then subsequently passed to the slave nodes @@ -1341,7 +715,6 @@ subroutine getgridinfo_nmm() !====================================================================== ! Broadcast all common variables these out to all nodes - call MPI_Bcast(logp,npts*nlevs_pres,mpi_real4,0,MPI_COMM_WORLD,ierr) call MPI_Bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call MPI_Bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) @@ -1350,26 +723,16 @@ subroutine getgridinfo_nmm() !---------------------------------------------------------------------- ! Allocate memory for local variable - if(.not. allocated(gridloc)) allocate(gridloc(3,npts)) ! Loop through each grid coordinate and perform the coordinate ! transform for regular simulation domains do nn = 1, npts - - ! Compute local variable - + ! Compute local variables gridloc(1,nn) = cos(latsgrd(nn))*cos(lonsgrd(nn)) - - ! Compute local variable - gridloc(2,nn) = cos(latsgrd(nn))*sin(lonsgrd(nn)) - - ! Compute local variable - gridloc(3,nn) = sin(latsgrd(nn)) - end do ! do nn = 1, npts end subroutine getgridinfo_nmm @@ -1385,16 +748,13 @@ end subroutine getgridinfo_nmm subroutine cross2dot(varin,sxdim,sydim,szdim,xdim,ydim,zdim,varout) ! Define array dimension variables - integer, intent(in) :: sxdim, sydim, szdim integer, intent(in) :: xdim, ydim, zdim ! Define variables passed to subroutine - real, dimension(sxdim,sydim,szdim), intent(in) :: varin ! Define variables returned by subroutine - real, dimension(xdim,ydim,zdim), intent(out) :: varout !====================================================================== @@ -1403,21 +763,13 @@ subroutine cross2dot(varin,sxdim,sydim,szdim,xdim,ydim,zdim,varout) ! interpolate from staggered grid to unstaggered grid if (sxdim .gt. xdim) then - varout = 0.5*(varin(1:xdim,:,:)+varin(2:xdim+1,:,:)) - else if (sydim .gt. ydim) then - varout = 0.5*(varin(:,1:ydim,:)+varin(:,2:ydim+1,:)) - else if (szdim .gt. zdim) then - varout = 0.5*(varin(:,:,1:zdim)+varin(:,:,2:zdim+1)) - else - varout = varin - end if !====================================================================== @@ -1463,26 +815,20 @@ subroutine dot2cross(xdim,ydim,zdim,sxdim,sydim,szdim,varin, & varout(1,:,:) = 1.5*varin(1,:,:) - 0.5*varin(2,:,:) ! linear extrapolation to outer points (outside of mass grid) varout(sxdim,:,:) = 1.5*varin(xdim,:,:) - 0.5*varin(xdim-1,:,:) - else if(sydim .gt. ydim) then ! inverse of: ! varout = 0.5*(varin(:,1:ydim,:)+varin(:,2:ydim+1,:)) varout(:,2:sydim-1,:) = 0.5*(varin(:,1:ydim-1,:) + varin(:,2:ydim,:)) varout(:,1,:) = 1.5*varin(:,1,:) - 0.5*varin(:,2,:) varout(:,sydim,:) = 1.5*varin(:,ydim,:) - 0.5*varin(:,ydim-1,:) - else if(szdim .gt. zdim) then - ! inverse of: ! varout = 0.5*(varin(:,:,1:zdim)+varin(:,:,2:zdim+1)) varout(:,:,2:szdim-1) = 0.5*(varin(:,:,1:zdim-1) + varin(:,:,2:zdim)) varout(:,:,1) = 1.5*varin(:,:,1) - 0.5*varin(:,:,2) varout(:,:,szdim) = 1.5*varin(:,:,zdim) - 0.5*varin(:,:,zdim-1) - else - varout = varin - end if ! if(sxdim .gt. xdim) !======================================================================= @@ -1498,12 +844,10 @@ end subroutine dot2cross !========================================================================= subroutine gridinfo_cleanup() - if (allocated(index_pres)) deallocate(index_pres) if (allocated(lonsgrd)) deallocate(lonsgrd) if (allocated(latsgrd)) deallocate(latsgrd) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) - if (allocated(gridvarstring)) deallocate(gridvarstring) end subroutine gridinfo_cleanup !========================================================================= diff --git a/src/enkf/gridio_fv3reg.f90 b/src/enkf/gridio_fv3reg.f90 new file mode 100644 index 000000000..9b81d349b --- /dev/null +++ b/src/enkf/gridio_fv3reg.f90 @@ -0,0 +1,685 @@ +module gridio + + !======================================================================== + + !$$$ Module documentation block + ! + ! This module contains various routines to ingest and update + ! variables from Weather Research and Forecasting (WRF) model Advanced + ! Research WRF (ARW) and Non-hydrostatic Mesoscale Model (NMM) dynamical + ! cores which are required by the Ensemble Kalman Filter (ENKF) currently + ! designed for operations within the National Centers for Environmental + ! Prediction (NCEP) Global Forecasting System (GFS) + ! + ! prgmmr: Winterbottom org: ESRL/PSD1 date: 2011-11-30 + ! + ! program history log: + ! + ! 2011-11-30 Winterbottom - Initial version. + ! + ! 2019-01- Ting -- modified for fv3sar + ! attributes: + ! language: f95 + ! + !$$$ + + !========================================================================= + ! Define associated modules + use gridinfo, only: npts + use kinds, only: r_double, r_kind, r_single, i_kind + use mpisetup, only: nproc + use netcdf_io + use params, only: nlevs, cliptracers, datapath, arw, nmm, datestring + use params, only: nx_res,ny_res,nlevs,ntiles + use params, only: pseudo_rh + use mpeu_util, only: getindex + use read_fv3regional_restarts,only:read_fv3_restart_data1d,read_fv3_restart_data2d + use read_fv3regional_restarts,only:read_fv3_restart_data3d,read_fv3_restart_data4d + use netcdf_mod,only: nc_check + + implicit none + + !------------------------------------------------------------------------- + ! Define all public subroutines within this module + private + public :: readgriddata + public :: writegriddata + + !------------------------------------------------------------------------- + +contains + ! Generic WRF read routine, calls ARW-WRF or NMM-WRF + subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,reducedgrid,vargrid,qsat) + use constants, only:zero,one,half,fv, max_varname_length + use gridinfo,only: eta1_ll + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_inq_dimid,nf90_inq_varid + use netcdf, only: nf90_nowrite,nf90_write,nf90_inquire,nf90_inquire_dimension + implicit none + integer, intent(in) :: nanal1,nanal2, n2d, n3d, ndim, ntimes + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, dimension(0:n3d), intent(in) :: levels + character(len=120), dimension(7), intent(in) :: fileprefixes + logical, intent(in) :: reducedgrid + + real(r_single), dimension(npts,ndim,ntimes,nanal2-nanal1+1), intent(out) :: vargrid + real(r_double), dimension(npts,nlevs,ntimes,nanal2-nanal1+1), intent(out) :: qsat + + + + ! Define local variables + character(len=500) :: filename + character(len=:),allocatable :: fv3filename + character(len=7) :: charnanal + integer(i_kind) file_id + real(r_single), dimension(:,:,:), allocatable ::workvar3d,uworkvar3d,& + vworkvar3d,tvworkvar3d,tsenworkvar3d,& + workprsi,qworkvar3d + real(r_double),dimension(:,:,:),allocatable:: qsatworkvar3d + real(r_single), dimension(:,:), allocatable ::pswork + + ! Define variables required for netcdf variable I/O + character(len=12) :: varstrname + + + character(len=1) char_tile + character(len=24),parameter :: myname_ = 'fv3: getgriddata' + + ! Define counting variables + integer :: nlevsp1 + integer :: i,j, k,nn,ntile,nn_tile0, nb,nanal,ne + integer :: u_ind, v_ind, tv_ind,tsen_ind, q_ind, oz_ind + integer :: ps_ind, sst_ind + integer :: tmp_ind + logical :: ice + + !====================================================================== + write (6,*)"The input fileprefix, reducedgrid are not used in the current implementation", & + fileprefixes, reducedgrid + nlevsp1=nlevs+1 + u_ind = getindex(vars3d, 'u') !< indices in the state var arrays + v_ind = getindex(vars3d, 'v') ! U and V (3D) + tv_ind = getindex(vars3d, 't') ! Tv (3D) + q_ind = getindex(vars3d, 'q') ! Q (3D) + oz_ind = getindex(vars3d, 'oz') ! Oz (3D) + tsen_ind = getindex(vars3d, 'tsen') !sensible T (3D) +! prse_ind = getindex(vars3d, 'prse') ! pressure + + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + sst_ind = getindex(vars2d, 'sst') ! SST (2D) + + ! Initialize all constants required by routine + allocate(workvar3d(nx_res,ny_res,nlevs)) + allocate(qworkvar3d(nx_res,ny_res,nlevs)) + allocate(qsatworkvar3d(nx_res,ny_res,nlevs)) + allocate(tvworkvar3d(nx_res,ny_res,nlevs)) + + if (ntimes > 1) then + write(6,*)'gridio/readgriddata: reading multiple backgrounds not yet supported' + call stop2(23) + endif + ne = 0 + ensmemloop: do nanal=nanal1,nanal2 + ne = ne + 1 + + backgroundloop: do nb=1,ntimes + + ! Define character string for ensemble member file + if (nanal > 0) then + write(charnanal,'(a3, i3.3)') 'mem', nanal + else + charnanal = 'ensmean' + endif + + do ntile=1,ntiles + nn_tile0=(ntile-1)*nx_res*ny_res + write(char_tile, '(i1)') ntile + + filename = "fv3sar_tile"//char_tile//"_"//trim(charnanal) + fv3filename=trim(adjustl(filename))//"_dynvartracer" + + !---------------------------------------------------------------------- + ! read u-component + call nc_check( nf90_open(trim(adjustl(fv3filename)),nf90_nowrite,file_id),& + myname_,'open: '//trim(adjustl(fv3filename)) ) + + !---------------------------------------------------------------------- + ! Update u and v variables (same for NMM and ARW) + + if (u_ind > 0) then + allocate(uworkvar3d(nx_res,ny_res+1,nlevs)) + varstrname = 'u' + + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,uworkvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + vargrid(nn,levels(u_ind-1)+k,nb,ne)=uworkvar3d(i,j,k) + enddo + enddo + enddo + do k = levels(u_ind-1)+1, levels(u_ind) + if (nproc .eq. 0) & + write(6,*) 'READFVregional : u ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + + deallocate(uworkvar3d) + endif + if (v_ind > 0) then + allocate(vworkvar3d(nx_res+1,ny_res,nlevs)) + varstrname = 'v' + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,vworkvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + vargrid(nn,levels(v_ind-1)+k,nb,ne)=vworkvar3d(i,j,k) + enddo + enddo + enddo + do k = levels(v_ind-1)+1, levels(v_ind) + if (nproc .eq. 0) & + write(6,*) 'READFVregional : v ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + deallocate(vworkvar3d) + + endif + + if (tv_ind > 0.or.tsen_ind) then + allocate(tsenworkvar3d(nx_res,ny_res,nlevs)) + varstrname = 'T' + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,tsenworkvar3d) + varstrname = 'sphum' + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,qworkvar3d) + + + if (q_ind > 0) then + varstrname = 'sphum' + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + vargrid(nn,levels(q_ind-1)+k,nb,ne)=qworkvar3d(i,j,k) + enddo + enddo + enddo + do k = levels(q_ind-1)+1, levels(q_ind) + if (nproc .eq. 0) & + write(6,*) 'READFVregional : q ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + + endif + if(tv_ind > 0) then + do k=1,nlevs + do j=1,ny_res + do i=1,nx_res + workvar3d(i,j,k)=tsenworkvar3d(i,j,k)*(one+fv*qworkvar3d(i,j,k)) + enddo + enddo + enddo + tvworkvar3d=workvar3d + else! tsen_id >0 + workvar3d=tsenworkvar3d + endif + tmp_ind=max(tv_ind,tsen_ind) !then can't be both >0 + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + vargrid(nn,levels(tmp_ind-1)+k,nb,ne)=workvar3d(i,j,k) + enddo + enddo + enddo + do k = levels(tmp_ind-1)+1, levels(tmp_ind) + if (nproc .eq. 0) then + write(6,*) 'READFVregional : t ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + endif + enddo + + endif + if(allocated(tsenworkvar3d)) deallocate(tsenworkvar3d) + + + + if (oz_ind > 0) then + varstrname = 'o3mr' + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + vargrid(nn,levels(oz_ind-1)+k,nb,ne)=workvar3d(i,j,k) + enddo + enddo + enddo + do k = levels(oz_ind-1)+1, levels(oz_ind) + if (nproc .eq. 0) & + write(6,*) 'READFVregional : oz ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + + endif + + call nc_check( nf90_close(file_id),& + myname_,'close '//trim(fv3filename) ) + ! set SST to zero for now + if (sst_ind > 0) then + vargrid(:,levels(n3d)+sst_ind,nb,ne) = zero + endif + + + !---------------------------------------------------------------------- + ! Allocate memory for variables computed within routine + + if (ps_ind > 0) then + allocate(workprsi(nx_res,ny_res,nlevsp1)) + allocate(pswork(nx_res,ny_res)) + fv3filename=trim(adjustl(filename))//"_dynvartracer" + call nc_check( nf90_open(trim(adjustl(fv3filename)),nf90_nowrite,file_id),& + myname_,'open: '//trim(adjustl(fv3filename)) ) + call read_fv3_restart_data3d('delp',fv3filename,file_id,workvar3d) + !print *,'min/max delp',ntile,minval(delp),maxval(delp) + call nc_check( nf90_close(file_id),& + myname_,'close '//trim(fv3filename) ) + workprsi(:,:,nlevsp1)=eta1_ll(nlevsp1) !etal_ll is needed + do i=nlevs,1,-1 + workprsi(:,:,i)=workvar3d(:,:,i)*0.01_r_kind+workprsi(:,:,i+1) + enddo + + pswork(:,:)=workprsi(:,:,1) + + + + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + vargrid(nn,levels(n3d)+ps_ind, nb,ne) =pswork(i,j) + enddo + enddo + + + + + + do k=1,nlevs + do j=1,ny_res + do i=1,nx_res + workvar3d(i,j,k)=(workprsi(i,j,k)+workprsi(i,j,k+1))*half + enddo + enddo + enddo + ice=.true. !tothink + if (pseudo_rh) then + call genqsat1(qworkvar3d,qsatworkvar3d,workvar3d,tvworkvar3d,ice, & + nx_res*ny_res,nlevs) + else + qsatworkvar3d(:,:,:) = 1._r_double + endif + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + qsat(nn,k,nb,ne)=qsatworkvar3d(i,j,k) + enddo + enddo + enddo + + + + + + if(allocated(workprsi)) deallocate(workprsi) + if(allocated(pswork)) deallocate(pswork) + if(allocated(tvworkvar3d)) deallocate(tvworkvar3d) + if(allocated(qworkvar3d)) deallocate(qworkvar3d) + if(allocated(qsatworkvar3d)) deallocate(qsatworkvar3d) + endif + !====================================================================== + ! Deallocate memory + if(allocated(workvar3d)) deallocate(workvar3d) + end do ! ntile loop + + end do backgroundloop ! loop over backgrounds to read in + end do ensmemloop ! loop over ens members to read in + + return + +end subroutine readgriddata + + !======================================================================== + ! readgriddata_nmm.f90: read WRF-NMM state or control vector + !------------------------------------------------------------------------- + + + !======================================================================== + ! writegriddata.f90: write WRF-ARW or WRF-NMM analysis + !------------------------------------------------------------------------- + +subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflate_flag) + use constants, only: zero, one,fv,half + use gridinfo,only: eta1_ll,eta2_ll + use params, only: nbackgrounds, anlfileprefixes, fgfileprefixes + use params, only: nx_res,ny_res,nlevs,ntiles,l_pres_add_saved + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_inq_dimid,nf90_inq_varid + use netcdf, only: nf90_write,nf90_write,nf90_inquire,nf90_inquire_dimension + use write_fv3regional_restarts,only:write_fv3_restart_data1d,write_fv3_restart_data2d + use write_fv3regional_restarts,only:write_fv3_restart_data3d,write_fv3_restart_data4d + include 'netcdf.inc' + + !---------------------------------------------------------------------- + ! Define variables passed to subroutine + integer, intent(in) :: nanal1,nanal2, n2d, n3d, ndim + character(len=*), dimension(n2d), intent(in) :: vars2d + character(len=*), dimension(n3d), intent(in) :: vars3d + integer, dimension(0:n3d), intent(in) :: levels + real(r_single), dimension(npts,ndim,nbackgrounds,nanal2-nanal1+1), intent(in) :: vargrid + logical, intent(in) :: no_inflate_flag + + !---------------------------------------------------------------------- + ! Define variables computed within subroutine + character(len=500) :: filename + character(len=:),allocatable :: fv3filename + character(len=7) :: charnanal + + !---------------------------------------------------------------------- + integer(i_kind) :: u_ind, v_ind, tv_ind, tsen_ind,q_ind, ps_ind,oz_ind + integer(i_kind) :: w_ind, cw_ind, ph_ind + + integer(i_kind) file_id + real(r_single), dimension(:,:), allocatable ::pswork + real(r_single), dimension(:,:,:), allocatable ::workvar3d,workinc3d,workinc3d2,uworkvar3d,& + vworkvar3d,tvworkvar3d,tsenworkvar3d,& + workprsi,qworkvar3d + + !---------------------------------------------------------------------- + ! Define variables required by for extracting netcdf variable + ! fields + integer :: nlevsp1 + ! Define variables required for netcdf variable I/O + character(len=12) :: varstrname + character(len=1) char_tile + character(len=24),parameter :: myname_ = 'fv3: writegriddata' + + !---------------------------------------------------------------------- + ! Define counting variables + integer :: i,j,k,nn,ntile,nn_tile0, nb,ne,nanal + + + + write(6,*)"anlfileprefixes, fgfileprefixes are not used in the current implementation", & + anlfileprefixes, fgfileprefixes + write(6,*)"the no_inflate_flag is not used in the currrent implementation ",no_inflate_flag + !---------------------------------------------------------------------- + nlevsp1=nlevs+1 + + u_ind = getindex(vars3d, 'u') !< indices in the state var arrays + v_ind = getindex(vars3d, 'v') ! U and V (3D) + tv_ind = getindex(vars3d, 't') ! Tv (3D) + tsen_ind = getindex(vars3d, 'tsen') ! Tv (3D) + q_ind = getindex(vars3d, 'q') ! Q (3D) + cw_ind = getindex(vars3d, 'cw') ! CWM for WRF-NMM + w_ind = getindex(vars3d, 'w') ! W for WRF-ARW + ph_ind = getindex(vars3d, 'ph') ! PH for WRF-ARW + + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + + + !---------------------------------------------------------------------- + if (nbackgrounds > 1) then + write(6,*)'gridio/writegriddata: writing multiple backgrounds not yet supported' + call stop2(23) + endif + ne = 0 + ensmemloop: do nanal=nanal1,nanal2 + ne = ne + 1 + + backgroundloop: do nb=1,nbackgrounds + allocate(workinc3d(nx_res,ny_res,nlevs),workinc3d2(nx_res,ny_res,nlevsp1)) + allocate(workvar3d(nx_res,ny_res,nlevs)) + allocate(qworkvar3d(nx_res,ny_res,nlevs)) + allocate(tvworkvar3d(nx_res,ny_res,nlevs)) + + + + !---------------------------------------------------------------------- + ! First guess file should be copied to analysis file at scripting + ! level; only variables updated by EnKF are changed + write(charnanal,'(a3, i3.3)') 'mem', nanal + + !---------------------------------------------------------------------- + ! Update u and v variables (same for NMM and ARW) + do ntile=1,ntiles + nn_tile0=(ntile-1)*nx_res*ny_res + write(char_tile, '(i1)') ntile + filename = "fv3sar_tile"//char_tile//"_"//trim(charnanal) + fv3filename=trim(adjustl(filename))//"_dynvartracer" + + + !---------------------------------------------------------------------- + ! read u-component + call nc_check( nf90_open(trim(adjustl(fv3filename)),nf90_write,file_id),& + myname_,'open: '//trim(adjustl(fv3filename)) ) + + + ! update CWM for WRF-NMM + if (u_ind > 0) then + varstrname = 'u' + allocate(uworkvar3d(nx_res,ny_res+1,nlevs)) + + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,uworkvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + workinc3d(i,j,k)=vargrid(nn,levels(u_ind-1)+k,nb,ne) + enddo + enddo + enddo + uworkvar3d(:,1:ny_res,:)=uworkvar3d(:,1:ny_res,:)+workinc3d + uworkvar3d(:,ny_res+1,:)=uworkvar3d(:,ny_res,:) + call write_fv3_restart_data3d(varstrname,fv3filename,file_id,uworkvar3d) + deallocate(uworkvar3d) + + endif + + if (v_ind > 0) then + varstrname = 'v' + allocate(vworkvar3d(nx_res+1,ny_res,nlevs)) + + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,vworkvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + workinc3d(i,j,k)=vargrid(nn,levels(v_ind-1)+k,nb,ne) + enddo + enddo + enddo + vworkvar3d(1:nx_res,:,:)=vworkvar3d(1:nx_res,:,:)+workinc3d + vworkvar3d(nx_res+1,:,:)=vworkvar3d(nx_res,:,:) + call write_fv3_restart_data3d(varstrname,fv3filename,file_id,vworkvar3d) + + deallocate(vworkvar3d) + endif + if (tv_ind > 0.or.tsen_ind>0 ) then + + varstrname = 'T' + if(tsen_ind>0) then + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + workinc3d(i,j,k)=vargrid(nn,levels(tsen_ind-1)+k,nb,ne) + enddo + enddo + enddo + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + workvar3d=workvar3d+workinc3d + call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + else ! tv_ind >0 + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + workinc3d(i,j,k)=vargrid(nn,levels(tv_ind-1)+k,nb,ne) + enddo + enddo + enddo + + varstrname = 'T' + allocate(tsenworkvar3d(nx_res,ny_res,nlevs)) + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,tsenworkvar3d) + varstrname = 'sphum' + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,qworkvar3d) + tvworkvar3d=tsenworkvar3d*(one+fv*qworkvar3d) + tvworkvar3d=tvworkvar3d+workinc3d + if(q_ind > 0) then + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + workinc3d(i,j,k)=vargrid(nn,levels(q_ind-1)+k,nb,ne) + enddo + enddo + enddo + qworkvar3d=qworkvar3d+workinc3d + endif + tsenworkvar3d=tvworkvar3d/(one+fv*qworkvar3d) + varstrname = 'T' + call write_fv3_restart_data3d(varstrname,fv3filename,file_id,tsenworkvar3d) + do k=1,nlevs + if (nproc .eq. 0) & + write(6,*) 'WRITEregional : T ', & + & k, minval(tsenworkvar3d(:,:,k)), maxval(tsenworkvar3d(:,:,k)) + enddo + + + + + if(q_ind>0) then + varstrname='sphum' + + call write_fv3_restart_data3d(varstrname,fv3filename,file_id,qworkvar3d) + do k=1,nlevs + if (nproc .eq. 0) & + write(6,*) 'WRITEregional : sphum ', & + & k, minval(qworkvar3d(:,:,k)), maxval(qworkvar3d(:,:,k)) + enddo + endif + + + + deallocate(tsenworkvar3d) + endif + + endif + if (oz_ind > 0) then + varstrname = 'o3mr' + + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + workinc3d(i,j,k)=vargrid(nn,levels(oz_ind-1)+k,nb,ne) + enddo + enddo + enddo + workvar3d=workvar3d+workinc3d + call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + + endif + if (ps_ind > 0) then + allocate(workprsi(nx_res,ny_res,nlevsp1)) + allocate(pswork(nx_res,ny_res)) + varstrname = 'delp' + call read_fv3_restart_data3d(varstrname,filename,file_id,workvar3d) + !print *,'min/max delp',ntile,minval(delp),maxval(delp) + workprsi(:,:,nlevsp1)=eta1_ll(nlevsp1) !etal_ll is needed + do i=nlevs,1,-1 + workprsi(:,:,i)=workvar3d(:,:,i)*0.01_r_kind+workprsi(:,:,i+1) + enddo + + + + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + pswork(i,j)=vargrid(nn,levels(n3d)+ps_ind,nb,ne) + enddo + enddo + if(l_pres_add_saved) then + do k=1,nlevs+1 + do j=1,ny_res + do i=1,nx_res + workinc3d2(i,j,k)=eta2_ll(k)*pswork(i,j) + enddo + enddo + enddo + workprsi=workprsi+workinc3d2 + else + workprsi(:,:,1)=workprsi(:,:,1)+pswork + do k=2,nlevsp1 + workprsi(:,:,k)=eta1_ll(k)+eta2_ll(k)*workprsi(:,:,1) + enddo + endif + do k=1,nlevs + workvar3d(:,:,k)=(workprsi(:,:,k)-workprsi(:,:,k+1))*100.0 + enddo + + + call write_fv3_restart_data3d(varstrname,filename,file_id,workvar3d) + endif + + call nc_check( nf90_close(file_id),& + myname_,'close '//trim(filename) ) + + + !---------------------------------------------------------------------- + ! update time stamp is to be considered NSTART_HOUR in NMM (HWRF) restart file. + !====================================================================== + end do ! tiles + if(allocated(workinc3d)) deallocate(workinc3d) + if(allocated(workinc3d2)) deallocate(workinc3d2) + if(allocated(workprsi)) deallocate(workprsi) + if(allocated(pswork)) deallocate(pswork) + if(allocated(tvworkvar3d)) deallocate(tvworkvar3d) + if(allocated(qworkvar3d)) deallocate(qworkvar3d) + + + + + end do backgroundloop ! loop over backgrounds to read in + end do ensmemloop ! loop over ens members to read in + + + ! Return calculated values + return + + !====================================================================== + + end subroutine writegriddata + + +end module gridio diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index a3a0e648f..ff4987a5b 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -24,66 +24,96 @@ module gridio ! program history log: ! 2009-02-23 Initial version. ! 2015-06-29 Add ability to read/write multiple time levels -! 2016-04-20 Modify to handle the updated nemsio sig file (P, DP, DPDT removed) -! For GFS and NMMB +! 2016-05-02 shlyaeva: Modification for reading state vector from table +! 2016-04-20 Modify to handle the updated nemsio sig file (P, DP, DPDT +! removed) +! 2016-11-29 shlyaeva: Add reading/calculating tsen, qi, ql. Pass filenames and +! hours to read routine to read separately state and control files. +! Pass levels and dimenstions to read/write routines (dealing with +! prse: nlevs + 1 levels). Pass "reducedgrid" parameter. ! 2017-06-14 Adding functionality to optionally write non-inflated ensembles, ! a required input for EFSO calculations +! 2019-03-13 Add precipitation components ! ! attributes: ! language: f95 ! !$$$ - use constants, only: zero,one,cp,fv,rd,grav,tiny_r_kind - use params, only: nlons,nlats,ndim,reducedgrid,nvars,nlevs,use_gfs_nemsio,pseudo_rh, & - cliptracers,nlons,nlats,datestring,datapath,massbal_adjust,& - nbackgrounds,fgfileprefixes,anlfileprefixes,imp_physics + use constants, only: zero,one,cp,fv,rd,tiny_r_kind,max_varname_length,t0c,r0_05 + use params, only: nlons,nlats,nlevs,use_gfs_nemsio,pseudo_rh, & + cliptracers,datapath,imp_physics use kinds, only: i_kind,r_double,r_kind,r_single - use gridinfo, only: ntrunc,npts,ptop ! gridinfo must be called first! + use gridinfo, only: ntrunc,npts ! gridinfo must be called first! use specmod, only: sptezv_s, sptez_s, init_spec_vars, ndimspec => nc, & isinitialized use reducedgrid_mod, only: regtoreduced, reducedtoreg use mpisetup, only: nproc + use mpeu_util, only: getindex implicit none private public :: readgriddata, writegriddata contains - subroutine readgriddata(nanal,grdin,qsat) + subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,reducedgrid,grdin,qsat) use sigio_module, only: sigio_head, sigio_data, sigio_sclose, sigio_sropen, & sigio_srohdc, sigio_sclose, sigio_aldata, sigio_axdata use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_close,& - nemsio_getfilehead,nemsio_getheadvar,nemsio_realkind,& + nemsio_getfilehead,nemsio_getheadvar,nemsio_realkind,nemsio_charkind,& nemsio_readrecv,nemsio_init,nemsio_setheadvar,nemsio_writerecv implicit none - character(len=500) :: filename - character(len=3) charnanal - integer, intent(in) :: nanal - real(r_double), dimension(npts,nlevs,nbackgrounds), intent(out) :: qsat - real(r_single), dimension(npts,ndim,nbackgrounds), intent(out) :: grdin + integer, intent(in) :: nanal1,nanal2 + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d, n3d + integer, dimension(0:n3d), intent(in) :: levels + integer, intent(in) :: ndim, ntimes + character(len=120), dimension(7), intent(in) :: fileprefixes + logical, intent(in) :: reducedgrid + real(r_single), dimension(npts,ndim,ntimes,nanal2-nanal1+1), intent(out) :: grdin + real(r_double), dimension(npts,nlevs,ntimes,nanal2-nanal1+1), intent(out) :: qsat - real(r_kind) kap,kapr,kap1,clip - - real(r_kind), allocatable, dimension(:,:) :: vmassdiv - real(r_single), allocatable, dimension(:,:) :: pressi,pslg - real(r_kind), dimension(nlons*nlats) :: ug,vg - real(r_kind), dimension(ndimspec) :: vrtspec,divspec - real(r_kind), allocatable, dimension(:) :: psg,pstend,ak,bk - real(r_single),allocatable,dimension(:,:,:) :: nems_vcoord + character(len=500) :: filename + character(len=7) charnanal + + real(r_kind) :: kap,kapr,kap1,clip,qi_coef + + real(r_kind), allocatable, dimension(:,:) :: vmassdiv + real(r_single), allocatable, dimension(:,:) :: pressi,pslg + real(r_kind), dimension(nlons*nlats) :: ug,vg + real(r_single), dimension(npts,nlevs) :: tv, q, cw + real(r_single), dimension(npts,nlevs) :: ql, qi, qr, qs, qg + real(r_kind), dimension(ndimspec) :: vrtspec,divspec + real(r_kind), allocatable, dimension(:) :: psg,pstend,ak,bk + real(r_single),allocatable,dimension(:,:,:) :: nems_vcoord real(nemsio_realkind), dimension(nlons*nlats) :: nems_wrk,nems_wrk2 - type(sigio_head) sighead - type(sigio_data) sigdata + type(sigio_head) :: sighead + type(sigio_data) :: sigdata type(nemsio_gfile) :: gfile + integer(i_kind) :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind + integer(i_kind) :: qr_ind, qs_ind, qg_ind + integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind + integer(i_kind) :: ps_ind, pst_ind, sst_ind - integer(i_kind) k,nt,iunitsig,iret,nb,idvc,nlonsin,nlatsin,nlevsin + integer(i_kind) :: k,iunitsig,iret,nb,i,idvc,nlonsin,nlatsin,nlevsin,ne,nanal logical ice + logical use_full_hydro - backgroundloop: do nb=1,nbackgrounds + use_full_hydro = .false. - write(charnanal,'(i3.3)') nanal + ne = 0 + ensmemloop: do nanal=nanal1,nanal2 + ne = ne + 1 + backgroundloop: do nb=1,ntimes + + if (nanal > 0) then + write(charnanal,'(a3, i3.3)') 'mem', nanal + else + charnanal = 'ensmean' + endif iunitsig = 77 - filename = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nb)))//"mem"//charnanal + filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) if (use_gfs_nemsio) then call nemsio_init(iret=iret) if(iret/=0) then @@ -103,7 +133,6 @@ subroutine readgriddata(nanal,grdin,qsat) print *,'got',nlonsin,nlatsin,nlevsin call stop2(23) end if - else call sigio_srohdc(iunitsig,trim(filename), & sighead,sigdata,iret) @@ -117,12 +146,40 @@ subroutine readgriddata(nanal,grdin,qsat) kapr = cp/rd kap1 = kap+one + u_ind = getindex(vars3d, 'u') !< indices in the state var arrays + v_ind = getindex(vars3d, 'v') ! U and V (3D) + tv_ind = getindex(vars3d, 'tv') ! Tv (3D) + q_ind = getindex(vars3d, 'q') ! Q (3D) + oz_ind = getindex(vars3d, 'oz') ! Oz (3D) + cw_ind = getindex(vars3d, 'cw') ! CW (3D) + tsen_ind = getindex(vars3d, 'tsen') !sensible T (3D) + ql_ind = getindex(vars3d, 'ql') ! QL (3D) + qi_ind = getindex(vars3d, 'qi') ! QI (3D) + prse_ind = getindex(vars3d, 'prse') + qr_ind = getindex(vars3d, 'qr') ! QR (3D) + qs_ind = getindex(vars3d, 'qs') ! QS (3D) + qg_ind = getindex(vars3d, 'qg') ! QG (3D) + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + pst_ind = getindex(vars2d, 'pst') ! Ps tendency (2D) // equivalent of + ! old logical massbal_adjust, if non-zero + sst_ind = getindex(vars2d, 'sst') + use_full_hydro = ( ql_ind > 0 .and. qi_ind > 0 .and. & + qr_ind > 0 .and. qs_ind > 0 .and. qg_ind > 0 ) + +! if (nproc == 0) then +! print *, 'indices: ' +! print *, 'u: ', u_ind, ', v: ', v_ind, ', tv: ', tv_ind, ', tsen: ', tsen_ind +! print *, 'q: ', q_ind, ', oz: ', oz_ind, ', cw: ', cw_ind, ', qi: ', qi_ind +! print *, 'ql: ', ql_ind, ', prse: ', prse_ind +! print *, 'ps: ', ps_ind, ', pst: ', pst_ind, ', sst: ', sst_ind +! endif + if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4) allocate(pressi(nlons*nlats,nlevs+1)) allocate(pslg(npts,nlevs)) - allocate(psg(nlons*nlats),pstend(nlons*nlats)) - if (massbal_adjust) allocate(vmassdiv(nlons*nlats,nlevs)) + allocate(psg(nlons*nlats)) + if (pst_ind > 0) allocate(vmassdiv(nlons*nlats,nlevs),pstend(nlons*nlats)) if (use_gfs_nemsio) then call nemsio_readrecv(gfile,'pres','sfc',1,nems_wrk,iret=iret) @@ -214,16 +271,11 @@ subroutine readgriddata(nanal,grdin,qsat) call stop2(23) endif vg = nems_wrk - if (reducedgrid) then - call regtoreduced(ug,grdin(:,k,nb)) - call regtoreduced(vg,grdin(:,nlevs+k,nb)) - else - grdin(:,k,nb) = ug - grdin(:,nlevs+k,nb) = vg - endif + if (u_ind > 0) call copytogrdin(ug,grdin(:,levels(u_ind-1) + k,nb,ne)) + if (v_ind > 0) call copytogrdin(vg,grdin(:,levels(v_ind-1) + k,nb,ne)) ! calculate vertical integral of mass flux div (ps tendency) ! this variable is analyzed in order to enforce mass balance in the analysis - if (massbal_adjust) then + if (pst_ind > 0) then ug = ug*(pressi(:,k)-pressi(:,k+1)) vg = vg*(pressi(:,k)-pressi(:,k+1)) call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt @@ -240,17 +292,16 @@ subroutine readgriddata(nanal,grdin,qsat) call stop2(23) endif if (cliptracers) where (nems_wrk2 < clip) nems_wrk2 = clip + ug = nems_wrk + if (tsen_ind > 0) call copytogrdin(ug,grdin(:,levels(tsen_ind-1)+k,nb,ne)) nems_wrk = nems_wrk * ( 1.0 + fv*nems_wrk2 ) ! convert T to Tv ug = nems_wrk vg = nems_wrk2 - if (reducedgrid) then - call regtoreduced(ug,grdin(:,2*nlevs+k,nb)) - call regtoreduced(vg,grdin(:,3*nlevs+k,nb)) - else - grdin(:,2*nlevs+k,nb) = ug - grdin(:,3*nlevs+k,nb) = vg - endif - if (nvars .ge. 5) then + call copytogrdin(ug,tv(:,k)) + call copytogrdin(vg, q(:,k)) + if (tv_ind > 0) grdin(:,levels(tv_ind-1)+k,nb,ne) = tv(:,k) + if (q_ind > 0) grdin(:,levels( q_ind-1)+k,nb,ne) = q(:,k) + if (oz_ind > 0) then call nemsio_readrecv(gfile,'o3mr','mid layer',k,nems_wrk2,iret=iret) if (iret/=0) then write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(o3mr), iret=',iret @@ -258,52 +309,103 @@ subroutine readgriddata(nanal,grdin,qsat) endif if (cliptracers) where (nems_wrk2 < clip) nems_wrk2 = clip ug = nems_wrk2 - if (reducedgrid) then - call regtoreduced(ug,grdin(:,4*nlevs+k,nb)) - else - grdin(:,4*nlevs+k,nb) = ug - endif + call copytogrdin(ug,grdin(:,levels(oz_ind-1)+k,nb,ne)) endif - if (nvars .ge. 6) then - call nemsio_readrecv(gfile,'clwmr','mid layer',k,nems_wrk2,iret=iret) - if (iret/=0) then - write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(clwmr), iret=',iret - call stop2(23) + if (.not. use_full_hydro) then + if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then + call nemsio_readrecv(gfile,'clwmr','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(clwmr), iret=',iret + call stop2(23) + endif + if (imp_physics == 11) then + call nemsio_readrecv(gfile,'icmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(icmr), iret=',iret + call stop2(23) + else + nems_wrk2 = nems_wrk2 + nems_wrk + endif + endif + if (cliptracers) where (nems_wrk2 < clip) nems_wrk2 = clip + ug = nems_wrk2 + call copytogrdin(ug,cw(:,k)) + if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k) endif - if (imp_physics == 11) then + else + if (ql_ind > 0) then + call nemsio_readrecv(gfile,'clwmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(clwmr), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + ug = nems_wrk + call copytogrdin(ug,ql(:,k)) + grdin(:,levels(ql_ind-1)+k,nb,ne) = ql(:,k) + endif + if (qi_ind > 0) then call nemsio_readrecv(gfile,'icmr','mid layer',k,nems_wrk,iret=iret) if (iret/=0) then write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(icmr), iret=',iret call stop2(23) - else - nems_wrk2 = nems_wrk2 + nems_wrk endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + ug = nems_wrk + call copytogrdin(ug,qi(:,k)) + grdin(:,levels(qi_ind-1)+k,nb,ne) = qi(:,k) endif - if (cliptracers) where (nems_wrk2 < clip) nems_wrk2 = clip - ug = nems_wrk2 - if (reducedgrid) then - call regtoreduced(ug,grdin(:,5*nlevs+k,nb)) - else - grdin(:,5*nlevs+k,nb) = ug + if (qr_ind > 0) then + call nemsio_readrecv(gfile,'rwmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(rwmr), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + ug = nems_wrk + call copytogrdin(ug,qr(:,k)) + grdin(:,levels(qr_ind-1)+k,nb,ne) = qr(:,k) endif - endif + if (qs_ind > 0) then + call nemsio_readrecv(gfile,'snmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(snmr), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + ug = nems_wrk + call copytogrdin(ug,qs(:,k)) + grdin(:,levels(qs_ind-1)+k,nb,ne) = qs(:,k) + endif + if (qg_ind > 0) then + call nemsio_readrecv(gfile,'grle','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: gfs model: problem with nemsio_readrecv(grle), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + ug = nems_wrk + call copytogrdin(ug,qg(:,k)) + grdin(:,levels(qg_ind-1)+k,nb,ne) = qg(:,k) + endif + endif ! use_full_hydro enddo else -!$omp parallel do private(k,nt,ug,vg,divspec,vrtspec) shared(sigdata,pressi,vmassdiv,grdin) +!$omp parallel do private(k,ug,vg,divspec,vrtspec) shared(sigdata,pressi,vmassdiv,grdin,tv,q,cw,u_ind,v_ind,pst_ind,q_ind,tsen_ind,cw_ind,qi_ind,ql_ind) do k=1,nlevs vrtspec = sigdata%z(:,k); divspec = sigdata%d(:,k) call sptezv_s(divspec,vrtspec,ug,vg,1) - if (reducedgrid) then - call regtoreduced(ug,grdin(:,k,nb)) - call regtoreduced(vg,grdin(:,nlevs+k,nb)) - else - grdin(:,k,nb) = ug; grdin(:,nlevs+k,nb) = vg + if (u_ind > 0) then + call copytogrdin(ug,grdin(:,levels(u_ind-1)+k,nb,ne)) + endif + if (v_ind > 0) then + call copytogrdin(vg,grdin(:,levels(v_ind-1)+k,nb,ne)) endif ! calculate vertical integral of mass flux div (ps tendency) ! this variable is analyzed in order to enforce mass balance in the analysis - if (massbal_adjust) then + if (pst_ind > 0) then ug = ug*(pressi(:,k)-pressi(:,k+1)) vg = vg*(pressi(:,k)-pressi(:,k+1)) call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt @@ -312,44 +414,45 @@ subroutine readgriddata(nanal,grdin,qsat) divspec = sigdata%t(:,k) call sptez_s(divspec,ug,1) - if (reducedgrid) then - call regtoreduced(ug,grdin(:,2*nlevs+k,nb)) - else - grdin(:,2*nlevs+k,nb) = ug + call copytogrdin(ug,tv(:,k)) + if (tv_ind > 0) grdin(:,levels(tv_ind-1)+k,nb,ne) = tv(:,k) + + divspec = sigdata%q(:,k,1) + call sptez_s(divspec,vg,1) + call copytogrdin(vg,q(:,k)) + if (q_ind > 0) grdin(:,levels( q_ind-1)+k,nb,ne) = q(:,k) + + if (tsen_ind > 0) grdin(:,levels(tsen_ind-1)+k,nb,ne) = tv(:,k) / (one + fv*max(0._r_kind,q(:,k))) + + if (oz_ind > 0) then + divspec = sigdata%q(:,k,2) + call sptez_s(divspec,ug,1) + call copytogrdin(ug,grdin(:,levels(oz_ind-1)+k,nb,ne)) endif - do nt=1,nvars-3 - divspec = sigdata%q(:,k,nt) + if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then + divspec = sigdata%q(:,k,3) call sptez_s(divspec,ug,1) - if (reducedgrid) then - call regtoreduced(ug,grdin(:,(3+nt-1)*nlevs+k,nb)) - else - grdin(:,(3+nt-1)*nlevs+k,nb) = ug - endif - enddo + call copytogrdin(ug,cw(:,k)) + if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k) + endif enddo !$omp end parallel do endif - ! surface pressure is last grid. - if (reducedgrid) then - call regtoreduced(psg,grdin(:,ndim,nb)) - else - grdin(:,ndim,nb) = psg + ! surface pressure + if (ps_ind > 0) then + call copytogrdin(psg,grdin(:,levels(n3d) + ps_ind,nb,ne)) endif if (.not. use_gfs_nemsio) call sigio_axdata(sigdata,iret) - ! surface pressure tendency is next to last grid. - if (massbal_adjust) then + ! surface pressure tendency + if (pst_ind > 0) then pstend = sum(vmassdiv,2) if (nanal .eq. 1) & print *,nanal,'min/max first-guess ps tend',minval(pstend),maxval(pstend) - if (reducedgrid) then - call regtoreduced(pstend,grdin(:,ndim-1,nb)) - else - grdin(:,ndim-1,nb) = pstend - endif + call copytogrdin(pstend,grdin(:,levels(n3d) + pst_ind,nb,ne)) endif ! compute saturation q. @@ -357,49 +460,97 @@ subroutine readgriddata(nanal,grdin,qsat) ! layer pressure from phillips vertical interolation ug(:) = ((pressi(:,k)**kap1-pressi(:,k+1)**kap1)/& (kap1*(pressi(:,k)-pressi(:,k+1))))**kapr - if (reducedgrid) then - call regtoreduced(ug,pslg(:,k)) - else - pslg(:,k) = ug - endif + + call copytogrdin(ug,pslg(:,k)) + ! Jacobian for gps in pressure is saved in different units in GSI; need to + ! multiply pressure by 0.1 + if (prse_ind > 0) grdin(:,levels(prse_ind-1)+k,nb,ne) = 0.1*pslg(:,k) + end do if (pseudo_rh) then - call genqsat1(grdin(:,3*nlevs+1:4*nlevs,nb),qsat(:,:,nb),pslg,grdin(:,2*nlevs+1:3*nlevs,nb),ice,npts,nlevs) + call genqsat1(q,qsat(:,:,nb,ne),pslg,tv,ice,npts,nlevs) else - qsat(:,:,nb) = 1._r_double + qsat(:,:,nb,ne) = 1._r_double end if - + + ! cloud derivatives + if (.not. use_full_hydro) then + if (ql_ind > 0 .or. qi_ind > 0) then + do k = 1, nlevs + do i = 1, npts + qi_coef = -r0_05*(tv(i,k)/(one+fv*q(i,k))-t0c) + qi_coef = max(zero,qi_coef) + qi_coef = min(one,qi_coef) ! 0<=qi_coef<=1 + if (ql_ind > 0) then + grdin(i,levels(ql_ind-1)+k,nb,ne) = cw(i,k)*(one-qi_coef) + endif + if (qi_ind > 0) then + grdin(i,levels(qi_ind-1)+k,nb,ne) = cw(i,k)*qi_coef + endif + enddo + enddo + endif + endif + + if (sst_ind > 0) then + grdin(:,levels(n3d)+sst_ind, nb,ne) = zero + endif + deallocate(pressi,pslg) - deallocate(psg,pstend) - if (massbal_adjust) deallocate(vmassdiv) + deallocate(psg) + if (pst_ind > 0) deallocate(vmassdiv,pstend) if (use_gfs_nemsio) call nemsio_close(gfile,iret=iret) end do backgroundloop ! loop over backgrounds to read in + end do ensmemloop ! loop over ens members to read in + + return + + contains + ! copying to grdin (calling regtoreduced if reduced grid) + subroutine copytogrdin(field, grdin) + implicit none + + real(r_kind), dimension(:), intent(in) :: field + real(r_single), dimension(:), intent(inout) :: grdin + + if (reducedgrid) then + call regtoreduced(field, grdin) + else + grdin = field + endif + + end subroutine copytogrdin end subroutine readgriddata - subroutine writegriddata(nanal,grdin,no_inflate_flag) + subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) use sigio_module, only: sigio_head, sigio_data, sigio_sclose, sigio_sropen, & sigio_srohdc, sigio_sclose, sigio_axdata, & sigio_aldata, sigio_swohdc use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_close,& - nemsio_readrec,nemsio_writerec,nemsio_intkind,& + nemsio_readrec,nemsio_writerec,nemsio_intkind,nemsio_charkind,& nemsio_getheadvar,nemsio_realkind,nemsio_getfilehead,& nemsio_readrecv,nemsio_init,nemsio_setheadvar,nemsio_writerecv - use constants, only: t0c, r0_05, rd, grav - use params, only: lupp + use constants, only: grav + use params, only: nbackgrounds,anlfileprefixes,fgfileprefixes,reducedgrid implicit none - character(len=500):: filenamein, filenameout - integer, intent(in) :: nanal - real(r_single), dimension(npts,ndim,nbackgrounds), intent(inout) :: grdin + integer, intent(in) :: nanal1,nanal2 + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d,n3d,ndim + integer, dimension(0:n3d), intent(in) :: levels + real(r_single), dimension(npts,ndim,nbackgrounds,nanal2-nanal1+1), intent(inout) :: grdin logical, intent(in) :: no_inflate_flag + logical:: use_full_hydro + character(len=500):: filenamein, filenameout real(r_kind), allocatable, dimension(:,:) :: vmassdiv,dpanl,dpfg,pressi real(r_kind), allocatable, dimension(:,:) :: vmassdivinc real(r_kind), allocatable, dimension(:,:) :: ugtmp,vgtmp - real(r_kind), allocatable,dimension(:) :: psg,pstend1,pstend2,pstendfg,vmass - real(r_kind), dimension(nlons*nlats) :: ug,vg,uginc,vginc,psfg,work - real(r_kind), allocatable, dimension(:) :: delzb + real(r_kind), allocatable,dimension(:) :: pstend1,pstend2,pstendfg,vmass + real(r_kind), dimension(nlons*nlats) :: ug,vg,uginc,vginc,psfg,psg + real(r_kind), allocatable, dimension(:) :: delzb,work real(r_kind), dimension(ndimspec) :: vrtspec,divspec integer iadate(4),idate(4),nfhour,idat(7),iret,nrecs,jdate(7) integer:: nfminute, nfsecondn, nfsecondd @@ -409,6 +560,9 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) type(sigio_head) sighead type(sigio_data) sigdata_inc character(len=3) charnanal + character(nemsio_charkind),allocatable:: recname(:) + character(nemsio_charkind) :: field + logical :: hasfield real(r_kind) kap,kapr,kap1,clip real(nemsio_realkind), dimension(nlons*nlats) :: nems_wrk,nems_wrk2 @@ -418,16 +572,23 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) type(sigio_data) sigdata type(nemsio_gfile) :: gfilein,gfileout - integer k,nt,ierr,iunitsig,nb,i + integer :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind + integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind + integer :: ps_ind, pst_ind + integer k,nt,ierr,iunitsig,nb,i,ne,nanal + + use_full_hydro = .false. iunitsig = 78 kapr = cp/rd kap = rd/cp kap1 = kap+one clip = tiny_r_kind + ne = 0 + ensmemloop: do nanal=nanal1,nanal2 + ne = ne + 1 write(charnanal,'(i3.3)') nanal - backgroundloop: do nb=1,nbackgrounds if(no_inflate_flag) then @@ -440,6 +601,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) ! level. This file is read in and modified. if (use_gfs_nemsio) then + clip = tiny(vg(1)) call nemsio_init(iret=iret) if(iret/=0) then write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_init, iret=',iret @@ -454,13 +616,21 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd,& nrec=nrecs,& vcoord=nems_vcoord,idvc=nems_idvc) - write(6,111) trim(filenamein),idat,nfhour,nfminute,nfsecondn,nfsecondd -111 format(a32,1x,'idat=',7(i4,1x),' nfh=',i5,' nfm=',i5,' nfsn=',i5,' nfsd=',i5) +! write(6,111) trim(filenamein),idat,nfhour,nfminute,nfsecondn,nfsecondd +!111 format(a32,1x,'idat=',7(i4,1x),' nfh=',i5,' nfm=',i5,' nfsn=',i5,' nfsd=',i5) if (iret/=0) then write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_getfilehead, iret=',iret call stop2(23) endif + + allocate(recname(nrecs)) + call nemsio_getfilehead(gfilein,iret=iret,recname=recname) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_getfilehead, iret=',iret + call stop2(23) + endif + if (nems_idvc == 1) then ! sigma coordinate ak = zero bk = nems_vcoord(1:nlevs+1,2,1) @@ -475,19 +645,58 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) ! read in first-guess data. call sigio_srohdc(iunitsig,trim(filenamein), & sighead,sigdata,ierr) + if (sighead%idvc .eq. 0) then ! sigma coordinate, old file format. + ak = zero + bk = sighead%si(1:nlevs+1) + else if (sighead%idvc == 1) then ! sigma coordinate + ak = zero + bk = sighead%vcoord(1:nlevs+1,2) + else if (sighead%idvc == 2 .or. sighead%idvc == 3) then ! hybrid coordinate + bk = sighead%vcoord(1:nlevs+1,2) + ak = 0.01_r_kind*sighead%vcoord(1:nlevs+1,1) ! convert to mb + else + print *,'unknown vertical coordinate type',sighead%idvc + call stop2(23) + end if endif - if (massbal_adjust) then + u_ind = getindex(vars3d, 'u') !< indices in the state var arrays + v_ind = getindex(vars3d, 'v') ! U and V (3D) + tv_ind = getindex(vars3d, 'tv') ! Tv (3D) + q_ind = getindex(vars3d, 'q') ! Q (3D) + oz_ind = getindex(vars3d, 'oz') ! Oz (3D) + cw_ind = getindex(vars3d, 'cw') ! CW (3D) + ql_ind = getindex(vars3d, 'ql') ! QL (3D) + qi_ind = getindex(vars3d, 'qi') ! QI (3D) + qr_ind = getindex(vars3d, 'qr') ! QR (3D) + qs_ind = getindex(vars3d, 'qs') ! QS (3D) + qg_ind = getindex(vars3d, 'qg') ! QG (3D) + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + pst_ind = getindex(vars2d, 'pst') ! Ps tendency (2D) // equivalent of + ! old logical massbal_adjust, if non-zero + use_full_hydro = ( ql_ind > 0 .and. qi_ind > 0 .and. & + qr_ind > 0 .and. qs_ind > 0 .and. qg_ind > 0 ) + + +! if (nproc == 0) then +! print *, 'indices: ' +! print *, 'u: ', u_ind, ', v: ', v_ind, ', tv: ', tv_ind +! print *, 'q: ', q_ind, ', oz: ', oz_ind, ', cw: ', cw_ind +! print *, 'ps: ', ps_ind, ', pst: ', pst_ind +! endif + + if (pst_ind > 0) then allocate(vmassdiv(nlons*nlats,nlevs)) allocate(vmassdivinc(nlons*nlats,nlevs)) + allocate(dpfg(nlons*nlats,nlevs)) + allocate(dpanl(nlons*nlats,nlevs)) + allocate(pressi(nlons*nlats,nlevs+1)) + allocate(pstendfg(nlons*nlats)) + allocate(pstend1(nlons*nlats)) + allocate(pstend2(nlons*nlats),vmass(nlons*nlats)) endif - allocate(psg(nlons*nlats),pstend1(nlons*nlats)) - allocate(pstend2(nlons*nlats),vmass(nlons*nlats)) - allocate(dpfg(nlons*nlats,nlevs)) - allocate(dpanl(nlons*nlats,nlevs)) - allocate(pressi(nlons*nlats,nlevs+1)) - allocate(pstendfg(nlons*nlats)) - if (lupp) allocate(delzb(nlons*nlats)) +! if (imp_physics == 11) allocate(work(nlons*nlats)) !orig + if (imp_physics == 11 .and. (.not. use_full_hydro) ) allocate(work(nlons*nlats)) ! Compute analysis time from guess date and forecast length. if (.not. use_gfs_nemsio) then @@ -530,7 +739,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) print *,'iadate = ',iadate end if - if (.not. use_gfs_nemsio) then + if (.not. use_gfs_nemsio) then ! spectral sigio sighead%idate = iadate sighead%fhour = zero ! ensemble info @@ -544,40 +753,55 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) ! convert to increment to spectral coefficients. !$omp parallel do private(k,nt,ug,vg,divspec,vrtspec) shared(grdin,sigdata_inc) do k=1,nlevs - if (reducedgrid) then - call reducedtoreg(grdin(:,k,nb),ug) - call reducedtoreg(grdin(:,nlevs+k,nb),vg) - else - ug = grdin(:,k,nb); vg = grdin(:,nlevs+k,nb) + ug = 0_r_kind + if (u_ind > 0 ) then + call copyfromgrdin(grdin(:,levels(u_ind-1) + k,nb,ne),ug) + endif + vg = 0_r_kind + if (v_ind > 0) then + call copyfromgrdin(grdin(:,levels(v_ind-1) + k,nb,ne),vg) endif call sptezv_s(divspec,vrtspec,ug,vg,-1) - sigdata_inc%d(:,k) = divspec; sigdata_inc%z(:,k) = vrtspec - if (reducedgrid) then - call reducedtoreg(grdin(:,2*nlevs+k,nb),ug) - else - ug = grdin(:,2*nlevs+k,nb) + sigdata_inc%d(:,k) = divspec + sigdata_inc%z(:,k) = vrtspec + + ug = 0_r_kind + if (tv_ind > 0) then + call copyfromgrdin(grdin(:,levels(tv_ind-1)+k,nb,ne),ug) endif call sptez_s(divspec,ug,-1) sigdata_inc%t(:,k) = divspec - do nt=1,nvars-3 - if (reducedgrid) then - call reducedtoreg(grdin(:,(3+nt-1)*nlevs+k,nb),ug) - else - ug = grdin(:,(3+nt-1)*nlevs+k,nb) - endif - call sptez_s(divspec,ug,-1) - sigdata_inc%q(:,k,nt) = divspec - enddo + + ug = 0_r_kind + if (q_ind > 0) then + call copyfromgrdin(grdin(:,levels(q_ind-1)+k,nb,ne),ug) + endif + call sptez_s(divspec,ug,-1) + sigdata_inc%q(:,k,1) = divspec + + ug = 0_r_kind + if (oz_ind > 0) then + call copyfromgrdin(grdin(:,levels(oz_ind-1)+k,nb,ne),ug) + endif + call sptez_s(divspec,ug,-1) + sigdata_inc%q(:,k,2) = divspec + + ug = 0_r_kind + if (cw_ind > 0) then + call copyfromgrdin(grdin(:,levels(cw_ind-1)+k,nb,ne),ug) + endif + call sptez_s(divspec,ug,-1) + sigdata_inc%q(:,k,3) = divspec + enddo !$omp end parallel do divspec = sigdata%ps call sptez_s(divspec,vg,1) ! increment (in hPa) to reg grid. - if (reducedgrid) then - call reducedtoreg(grdin(:,ndim,nb),ug) - else - ug = grdin(:,ndim,nb) + ug = 0_r_kind + if (ps_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + ps_ind,nb,ne),ug) endif psfg = 10._r_kind*exp(vg) vg = psfg + ug ! first guess + increment @@ -586,37 +810,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) call sptez_s(divspec,vg,-1) sigdata%ps = divspec - if (sighead%idvc .eq. 0) then ! sigma coordinate, old file format. - ak = zero - bk = sighead%si(1:nlevs+1) - else if (sighead%idvc == 1) then ! sigma coordinate - ak = zero - bk = sighead%vcoord(1:nlevs+1,2) - else if (sighead%idvc == 2 .or. sighead%idvc == 3) then ! hybrid coordinate - bk = sighead%vcoord(1:nlevs+1,2) - ak = 0.01_r_kind*sighead%vcoord(1:nlevs+1,1) ! convert to mb - else - print *,'unknown vertical coordinate type',sighead%idvc - call stop2(23) - end if - !==> first guess pressure at interfaces. - do k=1,nlevs+1 - pressi(:,k)=ak(k)+bk(k)*psfg - enddo - do k=1,nlevs - dpfg(:,k) = pressi(:,k)-pressi(:,k+1) - enddo - !==> analysis pressure at interfaces. - do k=1,nlevs+1 - pressi(:,k)=ak(k)+bk(k)*psg - enddo - do k=1,nlevs - dpanl(:,k) = pressi(:,k)-pressi(:,k+1) - !if (nanal .eq. 1) print *,'k,dpanl,dpfg',minval(dpanl(:,k)),& - !maxval(dpanl(:,k)),minval(dpfg(:,k)),maxval(dpfg(:,k)) - enddo - - else + else ! nemsio gfileout = gfilein nfhour = 0 ! new forecast hour, zero at analysis time @@ -639,8 +833,8 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) idate=jdate, nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, & nfsecondd=nfsecondd) - write(6,112) trim(filenameout),jdate,nfhour,nfminute,nfsecondn,nfsecondd -112 format(a32,1x,'jdate=',7(i4,1x),' nfh=',i5,' nfm=',i5,' nfsn=',i5,' nfsd=',i5) +! write(6,112) trim(filenameout),jdate,nfhour,nfminute,nfsecondn,nfsecondd +!112 format(a32,1x,'jdate=',7(i4,1x),' nfh=',i5,' nfm=',i5,' nfsn=',i5,' nfsd=',i5) if (iret/=0) then write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_open for output, iret=',iret @@ -654,13 +848,13 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) call nemsio_readrecv(gfilein,'pres','sfc',1,nems_wrk,iret=iret) psfg = 0.01*nems_wrk ! convert ps to millibars. ! increment (in hPa) to reg grid. - if (reducedgrid) then - call reducedtoreg(grdin(:,ndim,nb),ug) - else - ug = grdin(:,ndim,nb) + ug = 0_r_kind + if (ps_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + ps_ind,nb,ne),ug) endif !print *,'nanal,min/max psfg,min/max inc',nanal,minval(psfg),maxval(psfg),minval(ug),maxval(ug) - if (lupp) then + field = 'dpres'; hasfield = checkfield(field,recname,nrecs) + if (hasfield) then do k=1,nlevs psg = ug*(bk(k)-bk(k+1)) call nemsio_readrecv(gfilein,'dpres','mid layer',k,nems_wrk,iret=iret) @@ -678,6 +872,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) endif psg = psfg + ug ! first guess + increment nems_wrk = 100.*psg + ! write out updated surface pressure. call nemsio_writerecv(gfileout,'pres','sfc',1,nems_wrk,iret=iret) if (iret/=0) then write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(pres), iret=',iret @@ -685,9 +880,23 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) endif endif - if (massbal_adjust) then - -!$omp parallel do private(k,nt,ug,vg,vrtspec,divspec) shared(sigdata,dpfg,vmassdiv) + if (pst_ind > 0) then + !==> first guess pressure at interfaces. + do k=1,nlevs+1 + pressi(:,k)=ak(k)+bk(k)*psfg + enddo + do k=1,nlevs + dpfg(:,k) = pressi(:,k)-pressi(:,k+1) + enddo + !==> analysis pressure at interfaces. + do k=1,nlevs+1 + pressi(:,k)=ak(k)+bk(k)*psg + enddo + do k=1,nlevs + dpanl(:,k) = pressi(:,k)-pressi(:,k+1) + !if (nanal .eq. 1) print *,'k,dpanl,dpfg',minval(dpanl(:,k)),& + !maxval(dpanl(:,k)),minval(dpfg(:,k)),maxval(dpfg(:,k)) + enddo do k=1,nlevs ! re-calculate vertical integral of mass flux div for first-guess if (use_gfs_nemsio) then @@ -712,14 +921,9 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt call sptez_s(divspec,vmassdiv(:,k),1) ! divspec to divgrd enddo -!$omp end parallel do ! analyzed ps tend increment - if (reducedgrid) then - call reducedtoreg(grdin(:,ndim-1,nb),pstend2) - else - pstend2 = grdin(:,ndim-1,nb) - endif + call copyfromgrdin(grdin(:,levels(n3d) + pst_ind,nb,ne),pstend2) pstendfg = sum(vmassdiv,2) vmassdivinc = vmassdiv if (nanal .eq. 1) then @@ -730,7 +934,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) endif pstend2 = pstend2 + pstendfg ! add to background ps tend - endif ! if (massbal_adjust) + endif ! if pst_ind > 0 if (.not. use_gfs_nemsio) then ! add increment to first guess in spectral space. @@ -741,11 +945,11 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) sigdata%z(:,k) = sigdata%z(:,k) + sigdata_inc%z(:,k) sigdata%d(:,k) = sigdata%d(:,k) + sigdata_inc%d(:,k) sigdata%t(:,k) = sigdata%t(:,k) + sigdata_inc%t(:,k) - do nt=1,nvars-3 + do nt=1,sighead%ntrac sigdata%q(:,k,nt) = sigdata%q(:,k,nt) + sigdata_inc%q(:,k,nt) enddo - if (massbal_adjust) then + if (pst_ind > 0) then ! calculate vertical integral of mass flux div for updated state divspec = sigdata%d(:,k); vrtspec = sigdata%z(:,k) call sptezv_s(divspec,vrtspec,ug,vg,1) @@ -761,9 +965,11 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) ! don't need sigdata_inc anymore. call sigio_axdata(sigdata_inc,ierr) else - if (massbal_adjust) then + if (pst_ind > 0) then allocate(ugtmp(nlons*nlats,nlevs),vgtmp(nlons*nlats,nlevs)) endif + field = 'delz'; hasfield = checkfield(field,recname,nrecs) + if (hasfield) allocate(delzb(nlons*nlats)) ! update u,v,Tv,q,oz,clwmr do k=1,nlevs call nemsio_readrecv(gfilein,'ugrd','mid layer',k,nems_wrk,iret=iret) @@ -771,13 +977,12 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(ugrd), iret=',iret call stop2(23) endif - if (reducedgrid) then - call reducedtoreg(grdin(:,k,nb),ug) - else - ug = grdin(:,k,nb) + ug = 0_r_kind + if (u_ind > 0) then + call copyfromgrdin(grdin(:,levels(u_ind-1) + k,nb,ne),ug) endif ug = nems_wrk + ug - if (.not. massbal_adjust) then + if (pst_ind < 0) then nems_wrk = ug call nemsio_writerecv(gfileout,'ugrd','mid layer',k,nems_wrk,iret=iret) if (iret/=0) then @@ -793,13 +998,12 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(vgrd), iret=',iret call stop2(23) endif - if (reducedgrid) then - call reducedtoreg(grdin(:,nlevs+k,nb),vg) - else - vg = grdin(:,nlevs+k,nb) + vg = 0_r_kind + if (v_ind > 0) then + call copyfromgrdin(grdin(:,levels(v_ind-1) + k,nb,ne),vg) endif vg = nems_wrk + vg - if (.not. massbal_adjust) then + if (pst_ind < 0) then nems_wrk = vg call nemsio_writerecv(gfileout,'vgrd','mid layer',k,nems_wrk,iret=iret) if (iret/=0) then @@ -810,7 +1014,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) vgtmp(:,k) = vg endif - if (massbal_adjust) then + if (pst_ind > 0) then ug = ug*dpanl(:,k) vg = vg*dpanl(:,k) call sptezv_s(divspec,vrtspec,ug,vg,-1) ! u,v to div,vrt @@ -828,25 +1032,28 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) call stop2(23) endif nems_wrk = nems_wrk * ( 1.0 + fv*nems_wrk2 ) !Convert T to Tv - if (reducedgrid) then - call reducedtoreg(grdin(:,2*nlevs+k,nb),ug) - call reducedtoreg(grdin(:,3*nlevs+k,nb),vg) - else - ug = grdin(:,2*nlevs+k,nb) - vg = grdin(:,3*nlevs+k,nb) + ug = 0_r_kind + if (tv_ind > 0) then + call copyfromgrdin(grdin(:,levels(tv_ind-1)+k,nb,ne),ug) + endif + vg = 0_r_kind + if (q_ind > 0) then + call copyfromgrdin(grdin(:,levels(q_ind-1)+k,nb,ne),vg) endif ! ug is Tv increment, nems_wrk is background Tv, nems_wrk2 is background spfh ug = ug + nems_wrk vg = vg + nems_wrk2 if (cliptracers) where (vg < clip) vg = clip - if (lupp) then + field = 'delz'; hasfield = checkfield(field,recname,nrecs) + if (hasfield) then call nemsio_readrecv(gfilein,'pres','sfc',1,nems_wrk2,iret=iret) delzb=(rd/grav)*nems_wrk delzb=delzb*log((ak(k)+bk(k)*nems_wrk2)/(ak(k+1)+bk(k+1)*nems_wrk2)) endif ! convert Tv back to T nems_wrk = ug/(1. + fv*vg) - if (imp_physics == 11) then + ! if (imp_physics == 11) then !orig + if (imp_physics == 11 .and. (.not. use_full_hydro) ) then do i=1,nlons*nlats ! compute work for cloud water partitioning work(i) = -r0_05 * (nems_wrk(i) - t0c) work(i) = max(zero,work(i)) @@ -864,11 +1071,11 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(spfh), iret=',iret call stop2(23) endif - if (lupp) then - if (reducedgrid) then - call reducedtoreg(grdin(:,ndim,nb),vg) - else - vg = grdin(:,ndim,nb) + field = 'delz'; hasfield = checkfield(field,recname,nrecs) + if (hasfield) then + vg = 0_r_kind + if (ps_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + ps_ind,nb,ne),vg) endif vg = nems_wrk2 + vg ug=(rd/grav)*ug @@ -879,6 +1086,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(delz), iret=',iret call stop2(23) endif + if (sum(nems_wrk) < 0.0_r_kind) ug = ug * -1.0_r_kind nems_wrk = nems_wrk + ug call nemsio_writerecv(gfileout,'delz','mid layer',k,nems_wrk,iret=iret) if (iret/=0) then @@ -892,14 +1100,9 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(o3mr), iret=',iret call stop2(23) endif - if (nvars .ge. 5) then - if (reducedgrid) then - call reducedtoreg(grdin(:,4*nlevs+k,nb),ug) - else - ug = grdin(:,4*nlevs+k,nb) - endif - else - ug = 0. + ug = 0_r_kind + if (oz_ind > 0) then + call copyfromgrdin(grdin(:,levels(oz_ind-1)+k,nb,ne),ug) endif nems_wrk = nems_wrk + ug if (cliptracers) where (nems_wrk < clip) nems_wrk = clip @@ -909,83 +1112,184 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) call stop2(23) endif - call nemsio_readrecv(gfilein,'clwmr','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(clwmr), iret=',iret - call stop2(23) - endif - if (nvars .ge. 6) then - if (reducedgrid) then - call reducedtoreg(grdin(:,5*nlevs+k,nb),ug) - else - ug = grdin(:,5*nlevs+k,nb) - endif - else - ug = 0. - endif - if (imp_physics == 11) then - call nemsio_readrecv(gfilein,'icmr','mid layer',k,nems_wrk2,iret=iret) + if ( .not. use_full_hydro) then + call nemsio_readrecv(gfilein,'clwmr','mid layer',k,nems_wrk,iret=iret) if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(icmr), iret=',iret + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(clwmr), iret=',iret call stop2(23) endif - vg = ug * work !cloud ice - ug = ug * (one - work) !cloud water - nems_wrk2 = nems_wrk2 + vg - endif - nems_wrk = nems_wrk + ug - if (cliptracers) where (nems_wrk < clip) nems_wrk = clip - if (cliptracers.and.imp_physics==11) where (nems_wrk2 < clip) nems_wrk2 = clip - call nemsio_writerecv(gfileout,'clwmr','mid layer',k,nems_wrk,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(clwmr), iret=',iret - call stop2(23) - endif - if (imp_physics == 11) then - call nemsio_writerecv(gfileout,'icmr','mid layer',k,nems_wrk2,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(icmr), iret=',iret - call stop2(23) + ug = 0_r_kind + if (cw_ind > 0) then + call copyfromgrdin(grdin(:,levels(cw_ind-1)+k,nb,ne),ug) endif - - if (lupp) then - call nemsio_readrecv(gfilein,'rwmr','mid layer',k,nems_wrk2,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(rwmr), iret=',iret - call stop2(23) - endif - call nemsio_writerecv(gfileout,'rwmr','mid layer',k,nems_wrk2,iret=iret) + if (imp_physics == 11) then + call nemsio_readrecv(gfilein,'icmr','mid layer',k,nems_wrk2,iret=iret) if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(rwmr), iret=',iret + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(icmr), iret=',iret call stop2(23) endif - - call nemsio_readrecv(gfilein,'snmr','mid layer',k,nems_wrk2,iret=iret) + vg = ug * work !cloud ice + ug = ug * (one - work) !cloud water + nems_wrk2 = nems_wrk2 + vg + endif + nems_wrk = nems_wrk + ug + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + if (cliptracers.and.imp_physics==11) where (nems_wrk2 < clip) nems_wrk2 = clip + call nemsio_writerecv(gfileout,'clwmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(clwmr), iret=',iret + call stop2(23) + endif + if (imp_physics == 11) then + call nemsio_writerecv(gfileout,'icmr','mid layer',k,nems_wrk2,iret=iret) if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(snmr), iret=',iret + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(icmr), iret=',iret call stop2(23) endif - call nemsio_writerecv(gfileout,'snmr','mid layer',k,nems_wrk2,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(snmr), iret=',iret - call stop2(23) + + field = 'rwmr'; hasfield = checkfield(field,recname,nrecs) + if (hasfield) then + call nemsio_readrecv(gfilein,'rwmr','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(rwmr), iret=',iret + call stop2(23) + endif + call nemsio_writerecv(gfileout,'rwmr','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(rwmr), iret=',iret + call stop2(23) + endif + + call nemsio_readrecv(gfilein,'snmr','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(snmr), iret=',iret + call stop2(23) + endif + call nemsio_writerecv(gfileout,'snmr','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(snmr), iret=',iret + call stop2(23) + endif + + call nemsio_readrecv(gfilein,'grle','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(grle), iret=',iret + call stop2(23) + endif + call nemsio_writerecv(gfileout,'grle','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(grle), iret=',iret + call stop2(23) + endif endif - - call nemsio_readrecv(gfilein,'grle','mid layer',k,nems_wrk2,iret=iret) - if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(grle), iret=',iret - call stop2(23) + call nemsio_readrecv(gfilein,'cld_amt','mid layer',k,nems_wrk2,iret=iret) + if (iret == 0 ) then + call nemsio_writerecv(gfileout,'cld_amt','mid layer',k,nems_wrk2,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(cld_amt), iret=',iret + call stop2(23) + endif endif - call nemsio_writerecv(gfileout,'grle','mid layer',k,nems_wrk2,iret=iret) + endif + else + ! Update clwmr + call nemsio_readrecv(gfilein,'clwmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(clwmr), iret=',iret + call stop2(23) + endif + ug = 0. + if (ql_ind > 0) then + call copyfromgrdin(grdin(:,levels(ql_ind-1)+k,nb,ne),ug) + endif + nems_wrk = nems_wrk + ug + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + call nemsio_writerecv(gfileout,'clwmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(clwmr), iret=',iret + call stop2(23) + endif + ! Update icmr + call nemsio_readrecv(gfilein,'icmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(icrm), iret=',iret + call stop2(23) + endif + ug = 0. + if (qi_ind > 0) then + call copyfromgrdin(grdin(:,levels(qi_ind-1)+k,nb,ne),ug) + endif + nems_wrk = nems_wrk + ug + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + call nemsio_writerecv(gfileout,'icmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(icmr), iret=',iret + call stop2(23) + endif + ! Update rwmr + call nemsio_readrecv(gfilein,'rwmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(rwmr), iret=',iret + call stop2(23) + endif + ug = 0. + if (qr_ind > 0) then + call copyfromgrdin(grdin(:,levels(qr_ind-1)+k,nb,ne),ug) + endif + nems_wrk = nems_wrk + ug + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + call nemsio_writerecv(gfileout,'rwmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(rwmr), iret=',iret + call stop2(23) + endif + ! Update snmr + call nemsio_readrecv(gfilein,'snmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(snmr), iret=',iret + call stop2(23) + endif + ug = 0. + if (qs_ind > 0) then + call copyfromgrdin(grdin(:,levels(qs_ind-1)+k,nb,ne),ug) + endif + nems_wrk = nems_wrk + ug + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + call nemsio_writerecv(gfileout,'snmr','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(snmr), iret=',iret + call stop2(23) + endif + ! Update grle + call nemsio_readrecv(gfilein,'grle','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(grle), iret=',iret + call stop2(23) + endif + ug = 0. + if (qg_ind > 0) then + call copyfromgrdin(grdin(:,levels(qg_ind-1)+k,nb,ne),ug) + endif + nems_wrk = nems_wrk + ug + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + call nemsio_writerecv(gfileout,'grle','mid layer',k,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(grle), iret=',iret + call stop2(23) + endif + ! No enkf update for cld_amt, just copy the background into analysis + call nemsio_readrecv(gfilein,'cld_amt','mid layer',k,nems_wrk2,iret=iret) + if (iret == 0 ) then + call nemsio_writerecv(gfileout,'cld_amt','mid layer',k,nems_wrk2,iret=iret) if (iret/=0) then - write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(grle), iret=',iret + write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_writerecv(cld_amt), iret=',iret call stop2(23) endif endif - endif - + endif ! use_full_hydro !Additional variables needed for Unified Post Processor - if (lupp) then + field = 'dzdt'; hasfield = checkfield(field,recname,nrecs) + if (hasfield) then call nemsio_readrecv(gfilein,'dzdt','mid layer',k,nems_wrk2,iret=iret) if (iret/=0) then write(6,*)'gridio/writegriddata: gfs model: problem with nemsio_readrecv(dzdt), iret=',iret @@ -1000,9 +1304,11 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) enddo endif !if (.not. use_gfs_nemsio) - if (lupp) deallocate(delzb) + if (allocated(delzb)) deallocate(delzb) + if (allocated(recname)) deallocate(recname) + if (imp_physics == 11 .and. (.not. use_full_hydro)) deallocate(work) - if (massbal_adjust) then + if (pst_ind > 0) then vmassdivinc = vmassdiv - vmassdivinc ! analyis - first guess VIMFD ! (VIMFD = vertically integrated mass flux divergence) @@ -1012,7 +1318,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) print *,nanal,'min/max analyzed ps tend',minval(pstend2),maxval(pstend2) endif ! vmass is vertical integral of dp**2 - vmass = 0. + vmass = 0_r_kind do k=1,nlevs ! case 2 (4.3.1.2) in GEOS DAS document. ! (adjustment proportional to mass in layer) @@ -1030,7 +1336,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) ! case 3 !ug = (pstend2 - pstend1)*vmassdivinc(:,k)**2/vmass call sptez_s(divspec,ug,-1) ! divgrd to divspec - vrtspec = 0. + vrtspec = 0_r_kind call sptezv_s(divspec,vrtspec,uginc,vginc,1) ! div,vrt to u,v if (nanal .eq. 1) then print *,k,'min/max u inc (member 1)',& @@ -1077,21 +1383,35 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) minval(pstend2-psfg),maxval(pstend2-psfg) endif - endif ! if (massbal_adjust) + endif ! if pst_ind > 0 if (.not. use_gfs_nemsio) then ! clip tracers. - if (cliptracers .and. nvars .gt. 3) then + if (cliptracers) then clip = tiny_r_kind !$omp parallel do private(k,nt,vg,divspec) shared(sigdata,clip) do k=1,nlevs - do nt=1,nvars-3 - divspec = sigdata%q(:,k,nt) - call sptez_s(divspec,vg,1) - where (vg < clip) vg = clip - call sptez_s(divspec,vg,-1) - sigdata%q(:,k,nt) = divspec - enddo + if (q_ind > 0) then + divspec = sigdata%q(:,k,1) + call sptez_s(divspec,vg,1) + where (vg < clip) vg = clip + call sptez_s(divspec,vg,-1) + sigdata%q(:,k,1) = divspec + endif + if (oz_ind > 0) then + divspec = sigdata%q(:,k,2) + call sptez_s(divspec,vg,1) + where (vg < clip) vg = clip + call sptez_s(divspec,vg,-1) + sigdata%q(:,k,2) = divspec + endif + if (cw_ind > 0) then + divspec = sigdata%q(:,k,3) + call sptez_s(divspec,vg,1) + where (vg < clip) vg = clip + call sptez_s(divspec,vg,-1) + sigdata%q(:,k,3) = divspec + endif enddo !$omp end parallel do end if @@ -1101,7 +1421,7 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) ! deallocate sigdata structure. call sigio_axdata(sigdata,ierr) else - if (massbal_adjust) then + if (pst_ind > 0) then ! update u,v do k=1,nlevs nems_wrk = ugtmp(:,k) @@ -1126,15 +1446,43 @@ subroutine writegriddata(nanal,grdin,no_inflate_flag) call nemsio_close(gfileout,iret=iret) endif - deallocate(pressi,dpanl,dpfg) - deallocate(psg,pstend1,pstend2,pstendfg,vmass) - if (massbal_adjust) then + if (pst_ind > 0) then + deallocate(pressi,dpanl,dpfg) + deallocate(pstend1,pstend2,pstendfg,vmass) deallocate(vmassdiv) deallocate(vmassdivinc) endif end do backgroundloop ! loop over backgrounds to write out + end do ensmemloop ! loop over ens members to write out + + contains +! copying to grdin (calling regtoreduced if reduced grid) + subroutine copyfromgrdin(grdin, field) + implicit none + + real(r_single), dimension(:), intent(in) :: grdin + real(r_kind), dimension(:), intent(inout) :: field + + if (reducedgrid) then + call reducedtoreg(grdin, field) + else + field = grdin + endif + + end subroutine copyfromgrdin end subroutine writegriddata - end module gridio + logical function checkfield(field,fields,nrec) result(hasfield) + use nemsio_module, only: nemsio_charkind + integer, intent(in) :: nrec + character(nemsio_charkind), intent(in) :: fields(nrec),field + integer n + hasfield = .false. + do n=1,nrec + if (field == fields(n)) hasfield=.true. + enddo + end function checkfield + +end module gridio diff --git a/src/enkf/gridio_nmmb.f90 b/src/enkf/gridio_nmmb.f90 index 49e87f601..2dbd094c2 100644 --- a/src/enkf/gridio_nmmb.f90 +++ b/src/enkf/gridio_nmmb.f90 @@ -1,43 +1,86 @@ module gridio -use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_close,& +use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_close,nemsio_getfilehead,& nemsio_getheadvar,nemsio_realkind,nemsio_intkind,& nemsio_readrecv,nemsio_init,nemsio_setheadvar,nemsio_writerecv -use params, only: nlons,nlats,ndim,reducedgrid,nvars,nlevs,pseudo_rh, & - cliptracers,nlons,nlats,datestring,datapath,massbal_adjust, & - nbackgrounds,fgfileprefixes,anlfileprefixes +use params, only: nlons,nlats,nlevs,pseudo_rh,cliptracers,datapath use kinds, only: i_kind,r_double,r_kind,r_single -use constants, only: zero,one,cp,fv,rd,grav,zero -use gridinfo, only: nvarozone,npts,wind2mass,mass2wind - +use constants, only: zero,one,cp,fv,rd,grav,zero,max_varname_length +use gridinfo, only: npts,wind2mass,mass2wind use mpisetup, only: nproc +use mpeu_util, only: getindex + +! 2017-05-12 Y. Wang and X. Wang - add more state variables for radar DA, +! xuguang.wang@ou.edu + implicit none private public :: readgriddata, writegriddata contains -subroutine readgriddata(nanal,grdin,qsat) +subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,reducedgrid,grdin,qsat) implicit none +integer, intent(in) :: nanal1,nanal2 +character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d +character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d +integer, intent(in) :: n2d,n3d +integer, dimension(0:n3d), intent(in) :: levels +integer, intent(in) :: ndim, ntimes +character(len=120), dimension(7), intent(in) :: fileprefixes +logical, intent(in) :: reducedgrid +real(r_single), dimension(npts,ndim,ntimes,nanal2-nanal1+1), intent(out) :: grdin +real(r_double), dimension(npts,nlevs,ntimes,nanal2-nanal1+1), intent(out) :: qsat +real(nemsio_realkind) nems_wrk(nlons*nlats), nems_wrk2(nlons*nlats), field1(nlevs) +real(nemsio_realkind) f_ice(nlons*nlats),f_rain(nlons*nlats),clwmr(nlons*nlats), & + f_rimef(nlons*nlats) +real(r_single) aeta1(nlevs),aeta2(nlevs),pt,pdtop + character(len=500) :: filename -character(len=3) charnanal -integer, intent(in) :: nanal -real(r_double), dimension(npts,nlevs,nbackgrounds), intent(out) :: qsat -real(r_single), dimension(npts,ndim,nbackgrounds), intent(out) :: grdin -real(r_single), dimension(nlons*nlats,nlevs) :: pslg -real(r_kind) clip +character(len=7) charnanal -real(nemsio_realkind) nems_wrk(nlons*nlats), nems_wrk2(nlons*nlats) -real(r_single) :: ak(nlevs),bk(nlevs) -real(r_single),allocatable,dimension(nlevs+1,3,2) :: nems_vcoord -real(r_single), dimension(nlons*nlats) :: nems_wrk,psg +real(r_single), allocatable, dimension(:,:) :: pslg +real(r_kind) clip +!real(r_single) :: ak(nlevs),bk(nlevs) +real(r_single), dimension(nlons*nlats) :: psg type(nemsio_gfile) :: gfile logical ice -integer(i_kind) iret,k,kk,nb +real(r_single) f_i,f_r,f_rif,clmr,qi,qli,qr,ql +integer(i_kind) iret,k,kk,nb,ii,ne,nanal +integer :: u_ind, v_ind, t_ind, tsen_ind, q_ind, oz_ind, cw_ind, prse_ind,& + ql_ind, qr_ind, qi_ind, qli_ind, dbz_ind, w_ind +integer :: ps_ind, sst_ind +!integer(nemsio_intkind) :: idvc -backgroundloop: do nb=1,nbackgrounds +u_ind = getindex(vars3d, 'u') !< indices in the state var arrays +v_ind = getindex(vars3d, 'v') ! U and V (3D) +t_ind = getindex(vars3d, 'tv') ! Tv (3D) +tsen_ind = getindex(vars3d, 'tsen') ! T sensible (3D) +q_ind = getindex(vars3d, 'q') ! Q (3D) +oz_ind = getindex(vars3d, 'oz') ! Oz (3D) +cw_ind = getindex(vars3d, 'cw') ! CW (3D) +ql_ind = getindex(vars3d, 'ql') ! QL (3D) +qr_ind = getindex(vars3d, 'qr') ! QR (3D) +qi_ind = getindex(vars3d, 'qi') ! QI (3D) +qli_ind = getindex(vars3d, 'qli') ! QLI (3D) +dbz_ind = getindex(vars3d, 'dbz') ! dBZ (3D) +w_ind = getindex(vars3d, 'w') ! W (3D) +prse_ind = getindex(vars3d, 'prse') -write(charnanal,'(i3.3)') nanal -filename = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nb)))//"mem"//charnanal +ps_ind = getindex(vars2d, 'ps') ! Ps (2D) +sst_ind = getindex(vars2d, 'sst') + +ne = 0 +ensmemloop : do nanal=nanal1,nanal2 +ne = ne + 1 +backgroundloop: do nb=1,ntimes + +if (nanal > 0) then + write(charnanal,'(a3, i3.3)') 'mem', nanal +else + charnanal = 'ensmean' +endif + +filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) call nemsio_init(iret=iret) if(iret/=0) then @@ -46,52 +89,82 @@ subroutine readgriddata(nanal,grdin,qsat) end if call nemsio_open(gfile,filename,'READ',iret=iret) if (iret/=0) then - write(6,*)'NMMB gridio/readgriddata: nmmb model: problem with nemsio_open, iret=',iret + write(6,*)'NMMB gridio/readgriddata: nmmb model: problem with nemsio_open, iret=',iret, trim(filename) call stop2(23) end if -! get surface pressure and pressure on model levels -call nemsio_readrecv(gfile,'pres','sfc',1,nems_wrk,iret=iret) + +call nemsio_getheadvar(gfile,'PT',pt,iret) +pt = 0.01*pt +call nemsio_getheadvar(gfile,'PDTOP',pdtop,iret) +pdtop = 0.01*pdtop +call nemsio_getheadvar(gfile,'SGML1',field1,iret) +do k=1,nlevs + aeta1(k)=field1(nlevs+1-k) +enddo +call nemsio_getheadvar(gfile,'SGML2',field1,iret) +do k=1,nlevs + aeta2(k)=field1(nlevs+1-k) + aeta1(k) = aeta1(k) + aeta2(k) +enddo +call nemsio_readrecv(gfile,'dpres','hybrid sig lev',1,nems_wrk,iret=iret) if (iret/=0) then - write(6,*)'NMMB gridio/readgriddata: NMMB model: problem with nemsio_readrecv(ps), iret=',iret - call stop2(23) + write(6,*)'gridio/readgriddata: nmmb model: problem with nemsio_readrecv(dpres), iret=',iret + call stop2(23) endif -psg = 0.01_r_kind*nems_wrk ! convert ps to millibars. +psg = 0.01*nems_wrk + pt ! surface pressure, units of hPa +! pressure on model levels +allocate(pslg(nlons*nlats,nlevs)) +do k=1,nlevs + pslg(:,k) = aeta1(k)*pdtop + aeta2(k)*(psg - pdtop - pt) + pt + if (nanal .eq. 1) print *,'nemsio, min/max pressi',k,minval(pslg(:,k)),maxval(pslg(:,k)) + if (prse_ind > 0) grdin(:,levels(prse_ind-1)+k,nb,ne) = pslg(:,k) +enddo -call nemsio_getfilehead(gfile,iret=iret,vcoord=nems_vcoord) -if ( iret /= 0 ) then - write(6,*)' NMMB gridio: ***ERROR*** problem reading header ', & - 'vcoord, Status = ',iret - call stop2(99) -endif -allocate(ak(nlevs),bk(nlevs)) - -if ( idvc == 0 ) then ! sigma coordinate, old file format. - ak = zero - bk = nems_vcoord(1:nlevs,1,1) -elseif ( idvc == 1 ) then ! sigma coordinate - ak = zero - bk = nems_vcoord(1:nlevs,2,1) -elseif ( idvc == 2 .or. idvc == 3 ) then ! hybrid coordinate - ak = 0.01_r_kind*nems_vcoord(1:nlevs,1,1) ! convert to mb - bk = nems_vcoord(1:nlevs,2,1) -else - write(6,*)'gridio: ***ERROR*** INVALID value for idvc=',idvc - call stop2(85) -endif +! get surface pressure and pressure on model levels +!call nemsio_readrecv(gfile,'pres','sfc',1,nems_wrk,iret=iret) +!if (iret/=0) then +! write(6,*)'NMMB gridio/readgriddata: NMMB model: problem with nemsio_readrecv(ps), iret=',iret +! call stop2(23) +!endif +!psg = 0.01_r_kind*nems_wrk ! convert ps to millibars. +!print *, 'read pres sfc: ', minval(psg), maxval(psg) + +!call nemsio_getfilehead(gfile,iret=iret,vcoord=nems_vcoord,idvc=idvc) +!if ( iret /= 0 ) then +! write(6,*)' NMMB gridio: ***ERROR*** problem reading header ', & +! 'vcoord, Status = ',iret +! call stop2(99) +!endif +!print *, 'idvc: ', idvc +!if ( idvc == 0 ) then ! sigma coordinate, old file format. +! ak = zero +! bk = nems_vcoord(1:nlevs,1,1) +!elseif ( idvc == 1 ) then ! sigma coordinate +! ak = zero +! bk = nems_vcoord(1:nlevs,2,1) +!elseif ( idvc == 2 .or. idvc == 3 ) then ! hybrid coordinate +! ak = 0.01_r_kind*nems_vcoord(1:nlevs,1,1) ! convert to mb +! bk = nems_vcoord(1:nlevs,2,1) +!else +! write(6,*)'gridio: ***ERROR*** INVALID value for idvc=',idvc +! call stop2(85) +!endif if (nanal .eq. 1) then print *,'time level ',nb print *,'---------------' endif -! pressure on model levels -do k=1,nlevs - pslg(:,k)=ak(k)+bk(k)*psg - if (nanal .eq. 1) print *,'nemsio, min/max pressi',k,minval(pslg(:,k)),maxval(pslg(:,k)) -enddo -deallocate(ak,bk) -grdin(:,ndim,nb) = psg +if (ps_ind > 0) then + grdin(:,levels(n3d)+ps_ind,nb,ne) = psg +endif +! pressure on model levels +!allocate(pslg(nlons*nlats,nlevs)) +!do k=1,nlevs +! pslg(:,k)=ak(k)+bk(k)*psg +! if (nanal .eq. 1) print *,'nemsio, min/max pressi',k,minval(pslg(:,k)),maxval(pslg(:,k)) +!enddo ! get u,v do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB @@ -101,17 +174,21 @@ subroutine readgriddata(nanal,grdin,qsat) write(6,*)'gridio/readgriddata: nmmb model: problem with nemsio_readrecv(ugrd), iret=',iret call stop2(23) endif - grdin(:,k,nb) = nems_wrk + if (u_ind > 0) then + grdin(:,levels(u_ind-1)+k,nb,ne) = nems_wrk + endif call nemsio_readrecv(gfile,'vgrd','mid layer',kk,nems_wrk,iret=iret) call wind2mass(nems_wrk,nlons,nlats) if (iret/=0) then write(6,*)'gridio/readgriddata: nmmb model: problem with nemsio_readrecv(vgrd), iret=',iret call stop2(23) endif - grdin(:,k+nlevs,nb) = nems_wrk + if (v_ind > 0) then + grdin(:,levels(v_ind-1)+k,nb,ne) = nems_wrk + endif enddo ice = .false. ! calculate qsat w/resp to ice? -clip = tiny(grdin(1,1,1)) +clip = tiny(grdin(1,1,1,1)) ! get sensible temperature and humidity do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB @@ -126,18 +203,25 @@ subroutine readgriddata(nanal,grdin,qsat) call stop2(23) endif if (cliptracers) where (nems_wrk2 < clip) nems_wrk2 = clip - grdin(:,k+2*nlevs,nb) = nems_wrk*(1. + fv*nems_wrk2) - if (nvars .gt. 3) grdin(:,k+3*nlevs,nb) = nems_wrk2 + if (tsen_ind > 0) then + grdin(:,levels(tsen_ind-1)+k,nb,ne) = nems_wrk + endif + if (t_ind > 0) then + grdin(:,levels(t_ind-1)+k,nb,ne) = nems_wrk*(1. + fv*nems_wrk2) + endif + if (q_ind > 0) then + grdin(:,levels(q_ind-1)+k,nb,ne) = nems_wrk2 + endif enddo ! compute qsat if (pseudo_rh) then - call genqsat1(grdin(:,3*nlevs+1:4*nlevs,nb),qsat(:,:,nb),pslg,grdin(:,2*nlevs+1:3*nlevs,nb),ice,npts,nlevs) + call genqsat1(grdin(:,levels(q_ind-1)+1:levels(q_ind-1)+nlevs,nb,ne),qsat(:,:,nb,ne),pslg,& + grdin(:,levels(t_ind-1)+1:levels(t_ind-1)+nlevs,nb,ne),ice,npts,nlevs) else - qsat(:,:,nb) = 1._r_double + qsat(:,:,nb,ne) = 1._r_double end if ! other tracers -!if nvars == 5 and nvarozone == 5, o3mr is nvar 5 -if (nvars == 5 .and. nvarozone == 5) then +if (oz_ind > 0) then do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB call nemsio_readrecv(gfile,'o3mr','mid layer',kk,nems_wrk,iret=iret) @@ -146,11 +230,10 @@ subroutine readgriddata(nanal,grdin,qsat) call stop2(23) endif if (cliptracers) where (nems_wrk < clip) nems_wrk = clip - grdin(:,k+4*nlevs,nb) = nems_wrk + grdin(:,levels(oz_ind-1)+k,nb,ne) = nems_wrk enddo endif -!if nvars == 5 and nvarozone == 0; clwmr is nvar 5 -if (nvars == 5 .and. nvarozone == 0) then +if (cw_ind > 0) then do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB call nemsio_readrecv(gfile,'clwmr','mid layer',kk,nems_wrk,iret=iret) @@ -159,11 +242,10 @@ subroutine readgriddata(nanal,grdin,qsat) call stop2(23) endif if (cliptracers) where (nems_wrk < clip) nems_wrk = clip - grdin(:,k+4*nlevs,nb) = nems_wrk - enddo -endif -!if nvars == 6 and nvarozone == 5, clwmr is nvar=6 -if (nvars == 6 .and. nvarozone == 5) then + grdin(:,levels(cw_ind-1)+k,nb,ne) = nems_wrk + end do +end if +if (ql_ind > 0 .and. qr_ind > 0 .and. qi_ind > 0 .and. qli_ind > 0 ) then do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB call nemsio_readrecv(gfile,'clwmr','mid layer',kk,nems_wrk,iret=iret) @@ -172,36 +254,140 @@ subroutine readgriddata(nanal,grdin,qsat) call stop2(23) endif if (cliptracers) where (nems_wrk < clip) nems_wrk = clip - grdin(:,k+5*nlevs,nb) = nems_wrk + clwmr = nems_wrk + + where( clwmr < 1.e-12_r_kind ) + clwmr = 0.0_r_kind + end where + + call nemsio_readrecv(gfile,'f_rain','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: nmmb model: problem with nemsio_readrecv(clwmr), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + f_rain = nems_wrk + + call nemsio_readrecv(gfile,'f_ice','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: nmmb model: problem with nemsio_readrecv(clwmr), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + f_ice = nems_wrk + + call nemsio_readrecv(gfile,'f_rimef','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: nmmb model: problem with nemsio_readrecv(clwmr), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + f_rimef = nems_wrk + + ! ==== convert to hydrometeors + do ii = 1, nlons*nlats + f_i = f_ice(ii) + f_r = f_rain(ii) + f_rif = f_rimef(ii) + clmr = clwmr(ii) + call fraction2variablenew(f_i,f_r,f_rif,clmr,qi,qli,qr,ql) + grdin(ii,k+(qli_ind-1)*nlevs,nb,ne) = qli + grdin(ii,k+(qr_ind-1)*nlevs,nb,ne) = qr + grdin(ii,k+(ql_ind-1)*nlevs,nb,ne) = ql + grdin(ii,k+(qi_ind-1)*nlevs,nb,ne) = qi + end do + + enddo +endif + +if ( dbz_ind > 0 )then + do k=1,nlevs + kk = nlevs+1-k ! grids ordered from top to bottom in NMMB + call nemsio_readrecv(gfile,'refl_10cm','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: nmmb model: problem with nemsio_readrecv(refl_10cm), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + grdin(:,(dbz_ind-1)*nlevs+k,nb,ne) = nems_wrk + enddo +endif + +if ( w_ind > 0 )then + do k=1,nlevs + kk = nlevs+1-k ! grids ordered from top to bottom in NMMB + call nemsio_readrecv(gfile,'dwdt','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: nmmb model: problem with nemsio_readrecv(refl_10cm), iret=',iret + call stop2(23) + endif + grdin(:,(w_ind-1)*nlevs+k,nb,ne) = nems_wrk enddo endif - -deallocate(psg,pslg) + +if (sst_ind > 0) then + grdin(:,levels(n3d)+sst_ind, nb, ne) = zero +endif + +deallocate(pslg) call nemsio_close(gfile, iret=iret) end do backgroundloop ! loop over backgrounds to read in +end do ensmemloop ! loop over ens members read by this task end subroutine readgriddata -subroutine writegriddata(nanal,grdin) +subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) +use params, only: nbackgrounds, anlfileprefixes,fgfileprefixes implicit none +integer, intent(in) :: nanal1,nanal2 +character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d +character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d +integer, intent(in) :: n2d,n3d,ndim +integer, dimension(0:n3d), intent(in) :: levels +real(r_single), dimension(npts,ndim,nbackgrounds,nanal2-nanal1+1), intent(inout) :: grdin +logical, intent(in) :: no_inflate_flag + !Not used here, but added to make writegriddata(...) consistent with gridio_gfs.f90 + character(len=500):: filename -integer, intent(in) :: nanal -real(r_single), dimension(npts,ndim,nbackgrounds), intent(inout) :: grdin + character(len=3) charnanal integer(nemsio_intkind) iret,nfhour,jdate(7),idat(3),ihrst,nfminute,ntimestep,nfsecond -integer iadate(4),idate(4),k,kk,nb +integer iadate(4),idate(4),k,kk,nb,ne,nanal integer,dimension(8):: ida,jda +integer :: u_ind, v_ind, t_ind, q_ind, oz_ind, cw_ind, ql_ind, qr_ind, qi_ind, qli_ind, dbz_ind, w_ind +integer :: ps_ind, ii +real(r_single) f_i,f_r,f_rif,clmr,qi,qli,qr,ql real(r_double),dimension(5):: fha -real(nemsio_realkind), dimension(nlons*nlats) :: nems_wrk,nems_wrk2,psg -real(r_single) pdtop,pt +real(nemsio_realkind), dimension(nlons*nlats) :: nems_wrk,nems_wrk2 +real(nemsio_realkind) f_ice(nlons*nlats),f_rain(nlons*nlats),clwmr(nlons*nlats),& + f_rimef(nlons*nlats) real(r_kind) clip type(nemsio_gfile) :: gfile -clip = tiny(grdin(1,1,1)) +u_ind = getindex(vars3d, 'u') !< indices in the state var arrays +v_ind = getindex(vars3d, 'v') ! U and V (3D) +t_ind = getindex(vars3d, 'tv') ! Tv (3D) +q_ind = getindex(vars3d, 'q') ! Q (3D) +oz_ind = getindex(vars3d, 'oz') ! Oz (3D) +cw_ind = getindex(vars3d, 'cw') ! CW (3D) +ql_ind = getindex(vars3d, 'ql') ! QL (3D) +qr_ind = getindex(vars3d, 'qr') ! QR (3D) +qi_ind = getindex(vars3d, 'qi') ! QI (3D) +qli_ind = getindex(vars3d, 'qli') ! QLI (3D) +dbz_ind = getindex(vars3d, 'dbz') ! dBZ (3D) +w_ind = getindex(vars3d, 'w') ! W (3D) + +ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + +clip = tiny(grdin(1,1,1,1)) + +ne = 0 +ensmemloop: do nanal=nanal1,nanal2 +ne = ne + 1 ! First guess file should be copied to analysis file at scripting ! level; only variables updated by EnKF are changed backgroundloop: do nb=1,nbackgrounds @@ -239,6 +425,7 @@ subroutine writegriddata(nanal,grdin) ida(3)=idate(3) ! day ida(4)=0 ! time zone ida(5)=idate(1) ! hour +ida(6)=idate(5) ! minute call w3movdat(fha,ida,jda) ! JDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME ! (YEAR, MONTH, DAY, TIME ZONE, @@ -247,6 +434,7 @@ subroutine writegriddata(nanal,grdin) iadate(2)=jda(2) ! mon iadate(3)=jda(3) ! day iadate(4)=jda(1) ! year +iadate(5)=jda(6) ! minute if (nproc .eq. 0) then print *,'nfhour = ',nfhour print *,'idate = ',idate @@ -258,6 +446,7 @@ subroutine writegriddata(nanal,grdin) jdate(2)=jda(2) ! new month jdate(3)=jda(3) ! new day jdate(4)=jda(5) ! new hour +jdate(5)=jda(6) ! new minute idat(3)=jdate(1) ! forecast starting year idat(2)=jdate(2) ! forecast starting month idat(1)=jdate(3) ! forecast starting day @@ -295,10 +484,12 @@ subroutine writegriddata(nanal,grdin) end if call nemsio_setheadvar(gfile,'ntimestep',ntimestep,iret) if (iret/=0) then - write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_setheadvar(ntimestep), iret=',iret - call stop2(23) + !write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_setheadvar(ntimestep), iret=',iret + !call stop2(23) + write(6,*)'warning - gridio/writegriddata: nmmb model: problem with nemsio_setheadvar(ntimestep), iret=',iret end if + ! update u,v do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB @@ -307,9 +498,11 @@ subroutine writegriddata(nanal,grdin) write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(ugrd), iret=',iret call stop2(23) endif - nems_wrk2 = grdin(:,k,nb) - call mass2wind(nems_wrk2,nlons,nlats) - nems_wrk = nems_wrk + nems_wrk2 + if (u_ind > 0) then + nems_wrk2 = grdin(:,levels(u_ind-1) + k,nb,ne) + call mass2wind(nems_wrk2,nlons,nlats) + nems_wrk = nems_wrk + nems_wrk2 + endif call nemsio_writerecv(gfile,'ugrd','mid layer',kk,nems_wrk,iret=iret) if (iret/=0) then write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(ugrd), iret=',iret @@ -321,9 +514,11 @@ subroutine writegriddata(nanal,grdin) write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(vgrd), iret=',iret call stop2(23) endif - nems_wrk2 = grdin(:,k+nlevs,nb) - call mass2wind(nems_wrk2,nlons,nlats) - nems_wrk = nems_wrk + nems_wrk2 + if (v_ind > 0) then + nems_wrk2 = grdin(:,levels(v_ind-1) + k,nb,ne) + call mass2wind(nems_wrk2,nlons,nlats) + nems_wrk = nems_wrk + nems_wrk2 + endif call nemsio_writerecv(gfile,'vgrd','mid layer',kk,nems_wrk,iret=iret) if (iret/=0) then write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(vgrd), iret=',iret @@ -331,7 +526,7 @@ subroutine writegriddata(nanal,grdin) endif enddo -clip = tiny(grdin(1,1,1)) +clip = tiny(grdin(1,1,1,1)) ! update sensible temperature and humidity do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB @@ -345,8 +540,13 @@ subroutine writegriddata(nanal,grdin) write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(spfh), iret=',iret call stop2(23) endif - nems_wrk = nems_wrk*(1. + fv*nems_wrk2) + grdin(:,k+2*nlevs,nb) - nems_wrk2 = nems_wrk2 + grdin(:,k+3*nlevs,nb) + nems_wrk = nems_wrk*(1. + fv*nems_wrk2) + if (t_ind > 0) then + nems_wrk = nems_wrk + grdin(:,levels(t_ind-1)+k,nb,ne) + endif + if (q_ind > 0) then + nems_wrk2 = nems_wrk2 + grdin(:,levels(q_ind-1)+k,nb,ne) + endif if (cliptracers) where (nems_wrk2 < clip) nems_wrk2 = clip ! nems_wrk is now updated Tv, convert back to T nems_wrk = nems_wrk/(1. + fv*nems_wrk2) @@ -362,8 +562,7 @@ subroutine writegriddata(nanal,grdin) endif enddo ! update other tracers -!if nvars == 5 and nvarozone == 5, o3mr is nvar 5 -if (nvars == 5 .and. nvarozone == 5) then +if (oz_ind > 0) then do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB call nemsio_readrecv(gfile,'o3mr','mid layer',kk,nems_wrk,iret=iret) @@ -371,7 +570,7 @@ subroutine writegriddata(nanal,grdin) write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(o3mr), iret=',iret call stop2(23) endif - nems_wrk = nems_wrk + grdin(:,k+4*nlevs,nb) + nems_wrk = nems_wrk + grdin(:,levels(oz_ind-1)+k,nb,ne) if (cliptracers) where (nems_wrk < clip) nems_wrk = clip call nemsio_writerecv(gfile,'o3mr','mid layer',kk,nems_wrk,iret=iret) if (iret/=0) then @@ -380,26 +579,24 @@ subroutine writegriddata(nanal,grdin) endif enddo endif -!if nvars == 5 and nvarozone == 0; clwmr is nvar 5 -if (nvars == 5 .and. nvarozone == 0) then +if (cw_ind > 0) then do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB call nemsio_readrecv(gfile,'clwmr','mid layer',kk,nems_wrk,iret=iret) if (iret/=0) then - write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(clwmr), iret=',iret + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(o3mr), iret=',iret call stop2(23) endif - nems_wrk = nems_wrk + grdin(:,k+4*nlevs,nb) + nems_wrk = nems_wrk + grdin(:,levels(cw_ind-1)+k,nb,ne) if (cliptracers) where (nems_wrk < clip) nems_wrk = clip call nemsio_writerecv(gfile,'clwmr','mid layer',kk,nems_wrk,iret=iret) if (iret/=0) then - write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(clwmr), iret=',iret + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(o3mr), iret=',iret call stop2(23) endif enddo -endif -!if nvars == 6 and nvarozone == 5, clwmr is nvar=6 -if (nvars == 6 .and. nvarozone == 5) then +end if +if( ql_ind > 0 .and. qr_ind > 0 .and. qi_ind > 0 .and. qli_ind > 0 ) then do k=1,nlevs kk = nlevs+1-k ! grids ordered from top to bottom in NMMB call nemsio_readrecv(gfile,'clwmr','mid layer',kk,nems_wrk,iret=iret) @@ -407,20 +604,306 @@ subroutine writegriddata(nanal,grdin) write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(clwmr), iret=',iret call stop2(23) endif - nems_wrk = nems_wrk + grdin(:,k+5*nlevs,nb) + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + + clwmr = nems_wrk + + where( clwmr < 1.e-12_r_kind ) + clwmr = 0.0_r_kind + end where + + call nemsio_readrecv(gfile,'f_rain','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(f_rain), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + + f_rain = nems_wrk + + call nemsio_readrecv(gfile,'f_ice','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(f_ice), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + + f_ice = nems_wrk + + call nemsio_readrecv(gfile,'f_rimef','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/readgriddata: nmmb model: problem with nemsio_readrecv(clwmr), iret=',iret + call stop2(23) + endif + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + f_rimef = nems_wrk + + ! ==== convert to hydrometeors + do ii = 1, nlons*nlats + f_i = f_ice(ii) + f_r = f_rain(ii) + f_rif = f_rimef(ii) + clmr = clwmr(ii) + call fraction2variablenew(f_i,f_r,f_rif,clmr,qi,qli,qr,ql) + grdin(ii,k+(qli_ind-1)*nlevs,nb,ne) = qli + grdin(ii,k+(qli_ind-1)*nlevs,nb,ne) + grdin(ii,k+(qr_ind-1)*nlevs,nb,ne) = qr + grdin(ii,k+(qr_ind-1)*nlevs,nb,ne) + grdin(ii,k+(ql_ind-1)*nlevs,nb,ne) = ql + grdin(ii,k+(ql_ind-1)*nlevs,nb,ne) + grdin(ii,k+(qi_ind-1)*nlevs,nb,ne) = qi + grdin(ii,k+(qi_ind-1)*nlevs,nb,ne) + + qli = grdin(ii,k+(qli_ind-1)*nlevs,nb,ne) + qr = grdin(ii,k+(qr_ind-1)*nlevs,nb,ne) + ql = grdin(ii,k+(ql_ind-1)*nlevs,nb,ne) + qi = grdin(ii,k+(qi_ind-1)*nlevs,nb,ne) + call variable2fractionnew(qli, qi, qr, ql, f_i, f_r,f_rif) + f_ice(ii) = f_i + f_rain(ii) = f_r + f_rimef(ii)=f_rif + end do + + clwmr = grdin(:,k+(ql_ind-1)*nlevs,nb,ne) + grdin(:,k+(qr_ind-1)*nlevs,nb,ne) + & + grdin(:,k+(qli_ind-1)*nlevs,nb,ne) + nems_wrk = clwmr + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip call nemsio_writerecv(gfile,'clwmr','mid layer',kk,nems_wrk,iret=iret) if (iret/=0) then write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(clwmr), iret=',iret call stop2(23) endif + + nems_wrk = f_ice + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + call nemsio_writerecv(gfile,'f_ice','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(f_rain), iret=',iret + call stop2(23) + endif + + nems_wrk = f_rain + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + call nemsio_writerecv(gfile,'f_rain','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(f_ice), iret=',iret + call stop2(23) + endif + + nems_wrk = f_rimef + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + call nemsio_writerecv(gfile,'f_rimef','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(f_rimef), iret=',iret + call stop2(23) + endif + + enddo +endif + +if (dbz_ind > 0) then + do k=1,nlevs + kk = nlevs+1-k ! grids ordered from top to bottom in NMMB + call nemsio_readrecv(gfile,'refl_10cm','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(clwmr), iret=',iret + call stop2(23) + endif + where (nems_wrk < 0.0 ) nems_wrk = 0.0 + nems_wrk = nems_wrk + grdin(:,(dbz_ind-1)*nlevs+k,nb,ne) + if (cliptracers) where (nems_wrk < clip) nems_wrk = clip + call nemsio_writerecv(gfile,'refl_10cm','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(clwmr), iret=',iret + call stop2(23) + endif + enddo +endif + +if (w_ind > 0) then + do k=1,nlevs + kk = nlevs+1-k ! grids ordered from top to bottom in NMMB + call nemsio_readrecv(gfile,'dwdt','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_readrecv(clwmr), iret=',iret + call stop2(23) + endif + nems_wrk = nems_wrk + grdin(:,(w_ind-1)*nlevs+k,nb,ne) + call nemsio_writerecv(gfile,'dwdt','mid layer',kk,nems_wrk,iret=iret) + if (iret/=0) then + write(6,*)'gridio/writegriddata: nmmb model: problem with nemsio_writerecv(clwmr), iret=',iret + call stop2(23) + endif enddo endif + call nemsio_close(gfile, iret=iret) end do backgroundloop ! loop over backgrounds to read in +end do ensmemloop ! loop over ens members to write on this task end subroutine writegriddata -end module gridio + Subroutine fraction2variablenew(f_ice,f_rain,f_rimef, wc, qi,qs,qr,qw) + +!$$$ subprogram documentation block +! . . . . +! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor +! analysis +! +! PRGMMR: Ting Lei ORG: EMC/NCEP DATE: 2016 +! +! ABSTRACT: +! This subroutine convert fraction to qi, qs, qr, qw exactly +! following their theorectical formula in NMMB ferrier-Algo scheme +! and, the exact physical meaning of qi, qs, qr, qw are not considerred +! and are only used as the intermidiate variables +! +! PROGRAM HISTORY LOG: +! input argument list: +! mype - processor ID that does this IO +! +! output argument list: +! +! USAGE: +! INTPUT: +! wc: summation of qi, qr and qw +! f_ice - fraction of condensate in form of ice +! f_rain - fraction of liquid water in form of rain +! f_rimef - ratio of total ice growth to deposition groth +! OUTPUT +! qi - +! qs - +! qr - +! qw - +!clt CW=QC+QR+QS +! QS=F_ICE*CW +! QR=F_RAIN*(1-F_ICE)*CW +! QC=(1-F_RAIN)*(1-F_ICE)*CW +! QG(qi in the above)=QS*F_RIMEF +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: WCOSS at NOAA/ESRL - college park, DC +! +!$$$ + + use kinds, only: r_kind,r_single + + real(r_single) qi,qs, qr, qw, wc + real(r_single) f_ice, f_rain,f_rimef + real(r_single) onemf_ice, onemf_rain + + onemf_ice=1-f_ice + onemf_rain=1-f_rain + + if(wc > 0.0_r_single) then + if(f_ice>1.0_r_single) f_ice=1.0_r_single + if(f_ice<0.0_r_single) f_ice=0.0_r_single + if(f_rain>1.0_r_single) f_rain=1.0_r_single + if(f_rain<0.0_r_single) f_rain=0.0_r_single + qs=f_ice*wc + qr=f_rain*onemf_ice*wc + qw=onemf_rain*onemf_ice*wc + qi=qs*f_rimef +else + qi=0.0_r_single; qs=0.0_r_single; qr=0.0_r_single; qw=0.0_r_single + end if + + end subroutine fraction2variablenew + + subroutine variable2fractionnew( qs,qi, qr, qw, f_ice, f_rain,f_rimef) +!clt modified from variable2fraction, see explanation in fration2variablenew + +!$$$ subprogram documentation block +! . . . . +! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor +! analysis +! +! PRGMMR: Ting Lei ORG: EMC/NCEP DATE: 2016 +! +! ABSTRACT: +! This subroutine qi qr qw and qs to fraction +! following their theorectical formula in NMMB ferrier-Algo scheme +! and, the exact physical meaning of qi, qs, qr, qw are not considerred +! and are only used as the intermidiate variables +! +! PROGRAM HISTORY LOG: +! +! +! input argument list: +! mype - processor ID that does this IO +! +! output argument list: +! +! USAGE: +! INPUT +! qi - +! qi - +! qr - +! qw - +! OUTPUT: +! f_ice - fraction of condensate in form of ice +! f_rain - fraction of liquid water in form of rain +! f_rimef - ratio of total ice growth to deposition groth +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: WCOSS at NOAA/ESRL - college park, DC +! +!$$$ + use kinds, only: r_kind,r_single + + real(r_single) qi, qr, qw, wc, dum + real(r_single) qs + real(r_single) f_ice, f_rain,f_rimef + real(r_single),parameter:: epsq=1.e-12_r_single + real(r_single) onemf_ice + + wc=qs+qr+qw + if(wc > 0.0_r_single) then + if(qsepsq) then + f_rimef=min(qi/qs,50.0) + else + f_rimef=1.0_r_single !cltthinkdeb + endif + + endif + + else + f_rain=0.0_r_single + f_ice=0.0_r_single + f_rimef=1.0_r_single + end if + + end subroutine variable2fractionnew + +end module gridio diff --git a/src/enkf/gridio_wrf.f90 b/src/enkf/gridio_wrf.f90 index 1e3653532..91ac8ba27 100644 --- a/src/enkf/gridio_wrf.f90 +++ b/src/enkf/gridio_wrf.f90 @@ -15,7 +15,15 @@ module gridio ! ! program history log: ! - ! 2011-11-30 Initial version. + ! 2011-11-30 Winterbottom - Initial version. + ! 2016-02-09 shlyaeva - update to read state and control variables; + ! arw control now has Tv, specific humidity and + ! surface pressure instead of Tp, mix ratio and + ! dry surf pressure. nmm control now has Tv + ! instead of Tsens. + ! 2017-05-12 Y. Wang and X. Wang - add more state variables for radar DA, + ! (Johnson et al. 2015 MWR; Wang and Wang + ! 2017 MWR) POC: xuguang.wang@ou.edu ! ! attributes: ! language: f95 @@ -23,1444 +31,1313 @@ module gridio !$$$ !========================================================================= - ! Define associated modules - - use gridinfo, only: dimensions, gridvarstring, npts, cross2dot, dot2cross - use kinds, only: r_double, r_kind, r_single + use gridinfo, only: dimensions, npts, cross2dot, dot2cross + use kinds, only: r_double, r_kind, r_single, i_kind use mpisetup, only: nproc use netcdf_io - use params, only: nlevs, nvars, nlons, nlats, cliptracers, datapath, & - arw, nmm, nmm_restart, datestring, pseudo_rh, & - nbackgrounds,fgfileprefixes,anlfileprefixes - use constants, only: zero,one,cp,fv,rd,grav,zero + use params, only: nlevs, cliptracers, datapath, arw, nmm, datestring, & + pseudo_rh, nmm_restart + use mpeu_util, only: getindex implicit none !------------------------------------------------------------------------- - ! Define all public subroutines within this module - private public :: readgriddata - public :: writegriddata_wrf + public :: writegriddata !------------------------------------------------------------------------- contains + ! Generic WRF read routine, calls ARW-WRF or NMM-WRF + subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,reducedgrid,vargrid,qsat) + use constants, only: max_varname_length + implicit none + integer, intent(in) :: nanal1,nanal2, n2d, n3d, ndim, ntimes + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, dimension(0:n3d), intent(in) :: levels + character(len=120), dimension(7), intent(in) :: fileprefixes + logical, intent(in) :: reducedgrid + + real(r_single), dimension(npts,ndim,ntimes), intent(out) :: vargrid + real(r_double), dimension(npts,nlevs,ntimes), intent(out) :: qsat - subroutine readgriddata(nanal,vargrid,qsat) - integer, intent(in) :: nanal - real(r_single), dimension(npts,nvars*nlevs+1,nbackgrounds), intent(out) :: vargrid - real(r_double), dimension(npts,nlevs,nbackgrounds), intent(out) :: qsat if (arw) then - call readgriddata_arw(nanal,vargrid,qsat) - else - call readgriddata_nmm(nanal,vargrid,qsat) + call readgriddata_arw(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,vargrid,qsat) + else if (nmm) then + call readgriddata_nmm(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,vargrid,qsat) endif + end subroutine readgriddata !======================================================================== - - ! readgriddata_arw.f90: This subroutine will receive a WRF-ARW - ! netcdf file name and variable string and will subsequently return - ! the respective variable interpolated to an unstaggered grid; all - ! checks for grid staggering are contained within this subroutine - + ! readgriddata_arw.f90: read WRF-ARW state or control vector !------------------------------------------------------------------------- - - subroutine readgriddata_arw(nanal,vargrid,qsat) - + subroutine readgriddata_arw(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,vargrid,qsat) use constants !====================================================================== - - ! Define array dimension variables - - integer :: xdim, ydim, zdim - ! Define variables passed to subroutine - - character(len=500) :: filename - character(len=3) :: charnanal - integer, intent(in) :: nanal + integer, intent(in) :: nanal1, nanal2, n2d, n3d,ndim, ntimes + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, dimension(0:n3d), intent(in) :: levels + character(len=120), dimension(7), intent(in) :: fileprefixes ! Define variables returned by subroutine - - real(r_single), dimension(npts,nvars*nlevs+1,nbackgrounds), intent(out) :: vargrid - real(r_double), dimension(npts,nlevs,nbackgrounds), intent(out) :: qsat - - ! Define variables computed within subroutine - - logical :: ice - real, dimension(:,:,:), allocatable :: wrfarw_pert_pottemp - real, dimension(:,:,:), allocatable :: wrfarw_znu - real, dimension(:,:,:), allocatable :: wrfarw_psfc - real, dimension(:,:,:), allocatable :: wrfarw_mu - real, dimension(:,:,:), allocatable :: wrfarw_mub - real, dimension(:,:,:), allocatable :: wrfarw_mixratio - real, dimension(:,:,:), allocatable :: wrfarw_ptop - real, dimension(:,:,:), allocatable :: workgrid - real, dimension(:,:,:), allocatable :: vargrid_native - real(r_single), dimension(:,:), allocatable :: enkf_virttemp - real(r_single), dimension(:,:), allocatable :: enkf_pressure - real(r_single), dimension(:,:), allocatable :: enkf_spechumd - real(r_single) :: kap - real(r_single) :: kap1 - real(r_single) :: kapr - integer :: xdim_native - integer :: ydim_native - integer :: zdim_native - integer :: xdim_local - integer :: ydim_local - integer :: zdim_local - - ! Define variables requiredfor netcdf variable I/O - - character(len=12) :: varstrname - character(len=50) :: attstr - character(len=12) :: varstagger - character(len=12) :: varmemoryorder + real(r_single), dimension(npts,ndim,ntimes,nanal2-nanal1+1), intent(out) :: vargrid + real(r_double), dimension(npts,nlevs,ntimes,nanal2-nanal1+1), intent(out) :: qsat + + ! Define local variables + character(len=500) :: filename + character(len=7) :: charnanal + + logical :: ice + real(r_single), dimension(:), allocatable :: znu, znw ! aeta1 and eta1 + real(r_single), dimension(:), allocatable :: enkf_mu, enkf_mub + real(r_single), dimension(:,:), allocatable :: enkf_temp, enkf_virttemp + real(r_single), dimension(:,:), allocatable :: enkf_pressure + real(r_single), dimension(:), allocatable :: enkf_psfc + real(r_single), dimension(:,:), allocatable :: enkf_mixratio, enkf_spechumd + real(r_single), dimension(:), allocatable :: enkf_qintegral + real(r_single) :: ptop + + ! Define variables required for netcdf variable I/O + character(len=12) :: varstrname ! Define counting variables - - integer :: i, j, k, l, nb - integer :: counth, countv - integer :: count + integer :: i, k, nb, ne, nanal + integer :: u_ind, v_ind, tv_ind, q_ind, oz_ind, ql_ind, qr_ind, qi_ind, qg_ind, & + qs_ind, qnc_ind, qnr_ind, qni_ind, dbz_ind, w_ind + integer :: tsen_ind, prse_ind + integer :: ps_ind, sst_ind !====================================================================== + u_ind = getindex(vars3d, 'u') !< indices in the state var arrays + v_ind = getindex(vars3d, 'v') ! U and V (3D) + tv_ind = getindex(vars3d, 'tv') ! Tv (3D) + q_ind = getindex(vars3d, 'q') ! Q (3D) + oz_ind = getindex(vars3d, 'oz') ! Oz (3D) + tsen_ind = getindex(vars3d, 'tsen') !sensible T (3D) + prse_ind = getindex(vars3d, 'prse') ! pressure + ql_ind = getindex(vars3d, 'ql') ! QL (3D) + qr_ind = getindex(vars3d, 'qr') ! QR (3D) + qi_ind = getindex(vars3d, 'qi') ! QI (3D) + qg_ind = getindex(vars3d, 'qg') ! QG (3D) + qs_ind = getindex(vars3d, 'qs') ! QS (3D) + qnc_ind = getindex(vars3d, 'qnc') ! QNC (3D) + qnr_ind = getindex(vars3d, 'qnr') ! QNR (3D) + qni_ind = getindex(vars3d, 'qni') ! QNI (3D) + dbz_ind = getindex(vars3d, 'dbz') ! DBZ (3D) + w_ind = getindex(vars3d, 'w') ! W (3D) + + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + sst_ind = getindex(vars2d, 'sst') ! SST (2D) ! Initialize all constants required by routine - call init_constants(.true.) - ! Define all local variables - - xdim = dimensions%xdim - ydim = dimensions%ydim - zdim = dimensions%zdim - - !====================================================================== - - ! Begin: Loop through each (prognostic) variable (defined in - ! gridio.F90), determine and define the spatial array - ! dimensions, and allocate memory for ARW dynamical core - - !---------------------------------------------------------------------- - - if (nbackgrounds > 1) then + if (ntimes > 1) then write(6,*)'gridio/readgriddata: reading multiple backgrounds not yet supported' call stop2(23) endif - backgroundloop: do nb=1,nbackgrounds - - ! Initialize counting variable - countv = 1 + ne = 0 + ensmemloop: do nanal=nanal1,nanal2 + ne = ne + 1 + backgroundloop: do nb=1,ntimes ! Define character string for ensemble member file - - write(charnanal,'(i3.3)') nanal - filename = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nb)))//"mem"//charnanal - - !---------------------------------------------------------------------- - - ! Loop through all variables to be update via the EnKF - - do l = 1, nvars + 1 - - !---------------------------------------------------------------------- - - ! Define staggering attributes for variable grid - - attstr = 'stagger' - call variableattribute_char(filename,gridvarstring(l),attstr, & - & varstagger) - - ! If variable grid is staggered in X-direction, assign array - ! dimensions appropriately - - if(varstagger(1:1) .eq. 'X') then - - ! Assign array dimensions appropriately - - xdim_native = xdim + 1 - ydim_native = ydim - zdim_native = zdim - - ! If variable grid is staggered in Y-direction, assign array - ! dimensions appropriately - - else if(varstagger(1:1) .eq. 'Y') then ! if(varstagger(1:1) .eq. ' - ! X') - - ! Assign array dimensions appropriately - - xdim_native = xdim - ydim_native = ydim + 1 - zdim_native = zdim - - ! If variable grid is staggered in Z-direction, assign array - ! dimensions appropriately - - else if(varstagger(1:1) .eq. 'Z') then ! if(varstagger(1:1) .eq. ' - ! X') - - ! Assign array dimensions appropriately - - xdim_native = xdim - ydim_native = ydim - zdim_native = zdim + 1 - - ! If variable grid is not staggered, assign array dimensions - ! appropriately - - else ! if(varstagger(1:1) .eq. 'X') - - ! Assign array dimensions appropriately - - xdim_native = xdim - ydim_native = ydim - zdim_native = zdim - - end if ! if(varstagger(1:1) .eq. 'X') - - !---------------------------------------------------------------------- - - ! Define memory attributes for variable grid - - attstr = 'MemoryOrder' - call variableattribute_char(filename,gridvarstring(l),attstr, & - & varmemoryorder) - - ! If variable is a 2-dimensional field, rescale variables - ! appropriately - - if(varmemoryorder(1:3) .eq. 'XY ') then - - ! Rescale grid dimension variables appropriately - - zdim_local = 1 - zdim_native = 1 - - else - - ! Define local array dimension - - zdim_local = zdim - - end if ! if(varmemoryorder(1:3) .eq. 'XY ') - - ! Define local variable dimensions - - xdim_local = xdim - ydim_local = ydim - - ! Allocate memory for local variable arrays - - if(.not. allocated(workgrid)) & - & allocate(workgrid(xdim_local,ydim_local,zdim_local)) - if(.not. allocated(vargrid_native)) & - & allocate(vargrid_native(xdim_native,ydim_native, & - & zdim_native)) - - ! Ingest variable from external netcdf formatted file - - call readnetcdfdata(filename,vargrid_native,gridvarstring(l), & - & xdim_native,ydim_native,zdim_native) - - ! Interpolate variable from staggered (i.e., C-) grid to - ! unstaggered (i.e., A-) grid. If variable is staggered in - ! vertical, intepolate from model layer interfaces - ! (including surface and top) to model layer midpoints. - - call cross2dot(vargrid_native,xdim_native,ydim_native, & - & zdim_native,xdim_local,ydim_local,zdim_local,workgrid) - - !---------------------------------------------------------------------- - - ! Loop through vertical coordinate - - do k = 1, zdim_local - - ! Initialize counting variable - - counth = 1 - - ! Loop through meridional horizontal coordinate - - do j = 1, ydim_local - - ! Loop through zonal horizontal coordinate - - do i = 1, xdim_local - - ! Assign values to output variable array - - vargrid(counth,countv,nb) = workgrid(i,j,k) - - ! Update counting variable - - counth = counth + 1 - - end do ! do i = 1, xdim_local - - end do ! do j = 1, ydim_local - - ! Print message to user - - if (nproc .eq. 0) & - write(6,*) 'READGRIDDATA_ARW: ', trim(gridvarstring(l)), & - & countv, minval(vargrid(:,countv,nb)), & - & maxval(vargrid(:,countv,nb)) - - ! Update counting variable - - countv = countv + 1 - - end do ! do k = 1, zdim_local - - !---------------------------------------------------------------------- - - ! Deallocate memory for local variables - - if(allocated(vargrid_native)) deallocate(vargrid_native) - if(allocated(workgrid)) deallocate(workgrid) - - !---------------------------------------------------------------------- - - end do ! do l = 1, nvars + 1 - - !---------------------------------------------------------------------- - - ! End: Loop through each (prognostic) variable (defined in - ! gridio.F90), determine and define the spatial array - ! dimensions, and allocate memory for ARW dynamical core - - !====================================================================== - - ! Begin: Ingest the necessary variables and compute the saturated - ! specific humidity along the WRF-ARW grid; this routine assumes - ! that all mass variables are defined along the unstaggered grid - - !---------------------------------------------------------------------- - - ! Define all constants required by routine + if (nanal > 0) then + write(charnanal,'(a3, i3.3)') 'mem', nanal + else + charnanal = 'ensmean' + endif + filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) + + !---------------------------------------------------------------------- + ! read u-component + if (u_ind > 0) then + varstrname = 'U' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(u_ind-1)+1:levels(u_ind),nb,ne),nlevs) + do k = levels(u_ind-1)+1, levels(u_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: u ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read v-component + if (v_ind > 0) then + varstrname = 'V' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(v_ind-1)+1:levels(v_ind),nb,ne),nlevs) + do k = levels(v_ind-1)+1, levels(v_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: v ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read qcloud + if ( ql_ind > 0 ) then + varstrname = 'QCLOUD' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(ql_ind-1)+1:levels(ql_ind),nb,ne),nlevs) + do k = levels(ql_ind-1)+1, levels(ql_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: ql ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read qrain + if ( qr_ind > 0 ) then + varstrname = 'QRAIN' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(qr_ind-1)+1:levels(qr_ind),nb,ne),nlevs) + do k = levels(qr_ind-1)+1, levels(qr_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: qr ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read qice + if ( qi_ind > 0 ) then + varstrname = 'QICE' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(qi_ind-1)+1:levels(qi_ind),nb,ne),nlevs) + do k = levels(qi_ind-1)+1, levels(qi_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: qi ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read qsnow + if ( qs_ind > 0 ) then + varstrname = 'QSNOW' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(qs_ind-1)+1:levels(qs_ind),nb,ne),nlevs) + do k = levels(qs_ind-1)+1, levels(qs_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: qs ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read qgraup + if ( qg_ind > 0 ) then + varstrname = 'QGRAUP' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(qg_ind-1)+1:levels(qg_ind),nb,ne),nlevs) + do k = levels(qg_ind-1)+1, levels(qg_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: qg ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read qncloud + if ( qnc_ind > 0 ) then + varstrname = 'QNCLOUD' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(qnc_ind-1)+1:levels(qnc_ind),nb,ne),nlevs) + do k = levels(qnc_ind-1)+1, levels(qnc_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: qnc ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read qnice + if ( qi_ind > 0 ) then + varstrname = 'QNICE' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(qni_ind-1)+1:levels(qni_ind),nb,ne),nlevs) + do k = levels(qni_ind-1)+1, levels(qni_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: qni ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read qnrain + if ( qnr_ind > 0 ) then + varstrname = 'QNRAIN' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(qnr_ind-1)+1:levels(qnr_ind),nb,ne),nlevs) + do k = levels(qnr_ind-1)+1, levels(qnr_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: qnr ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read reflectivity + if ( dbz_ind > 0 ) then + varstrname = 'REFL_10CM' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(dbz_ind-1)+1:levels(dbz_ind),nb,ne),nlevs) + do k = levels(dbz_ind-1)+1, levels(dbz_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: dbz ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read w + if ( w_ind > 0 ) then + varstrname = 'W' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(w_ind-1)+1:levels(w_ind),nb,ne),nlevs) + do k = levels(w_ind-1)+1, levels(w_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: w ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! set ozone to zero for now (like in GSI?) + if (oz_ind > 0) then + vargrid(:,levels(oz_ind-1)+1:levels(oz_ind),nb,ne) = zero + endif + ! set SST to zero for now + if (sst_ind > 0) then + vargrid(:,levels(n3d)+sst_ind,nb,ne) = zero + endif ice = .false. - kap = rd/cp - kapr = cp/rd - kap1 = kap + 1 !---------------------------------------------------------------------- - - ! Allocate memory for all variables ingested by routine - - if(.not. allocated(wrfarw_pert_pottemp)) & - & allocate(wrfarw_pert_pottemp(xdim,ydim,zdim)) - if(.not. allocated(wrfarw_mixratio)) & - & allocate(wrfarw_mixratio(xdim,ydim,zdim)) - if(.not. allocated(wrfarw_mu)) & - & allocate(wrfarw_mu(xdim,ydim,1)) - if(.not. allocated(wrfarw_mub)) & - & allocate(wrfarw_mub(xdim,ydim,1)) - if(.not. allocated(wrfarw_psfc)) & - & allocate(wrfarw_psfc(xdim,ydim,1)) - if(.not. allocated(wrfarw_znu)) & - & allocate(wrfarw_znu(1,1,zdim)) - if(.not. allocated(wrfarw_ptop)) & - & allocate(wrfarw_ptop(1,1,1)) - ! Allocate memory for variables computed within routine - - if(.not. allocated(enkf_virttemp)) allocate(enkf_virttemp(npts,nlevs)) - if(.not. allocated(enkf_pressure)) allocate(enkf_pressure(npts,nlevs)) - if(.not. allocated(enkf_spechumd)) allocate(enkf_spechumd(npts,nlevs)) + if(.not. allocated(enkf_temp)) allocate(enkf_temp(npts,nlevs)) + if(.not. allocated(enkf_virttemp)) allocate(enkf_virttemp(npts,nlevs)) + if(.not. allocated(enkf_psfc)) allocate(enkf_psfc(npts)) + if(.not. allocated(enkf_qintegral)) allocate(enkf_qintegral(npts)) + if(.not. allocated(enkf_pressure)) allocate(enkf_pressure(npts,nlevs)) + if(.not. allocated(enkf_mixratio)) allocate(enkf_mixratio(npts,nlevs)) + if(.not. allocated(enkf_spechumd)) allocate(enkf_spechumd(npts,nlevs)) !---------------------------------------------------------------------- - - ! Ingest the perturbation potential temperature from the external - ! file - + ! Ingest the perturbation potential temperature from the external file varstrname= 'T' - call readnetcdfdata(filename,wrfarw_pert_pottemp,varstrname,xdim, & - & ydim,zdim) + call readwrfvar(filename, varstrname, enkf_temp, nlevs) ! Ingest the water vapor mixing ratio from the external file - varstrname = 'QVAPOR' - call readnetcdfdata(filename,wrfarw_mixratio,varstrname,xdim,ydim, & - & zdim) - - ! Ingest the model vertical (eta) levels from the external file - - varstrname = 'ZNU' - call readnetcdfdata(filename,wrfarw_znu,varstrname,1,1,zdim) - - ! Ingest the model perturbation dry air mass from the external - ! file - - varstrname = 'MU' - call readnetcdfdata(filename,wrfarw_mu,varstrname,xdim,ydim,1) - - ! Ingest the model base state dry air mass from the external file - - varstrname = 'MUB' - call readnetcdfdata(filename,wrfarw_mub,varstrname,xdim,ydim,1) - - ! Ingest the model top pressure level from the external file - - varstrname = 'P_TOP' - call readnetcdfdata(filename,wrfarw_ptop,varstrname,1,1,1) - - !---------------------------------------------------------------------- - - ! Loop through vertical coordinate; compute the hydrostatic - ! pressure level and subsequently the temperature at the - ! respective level - - do k = 1, zdim - - ! Initialize counting variable - - count = 1 - - ! Loop through meridional horizontal coordinate - - do j = 1, ydim - - ! Loop through zonal horizontal coordinate - - do i = 1, xdim - - ! Compute the dry hydrostatic pressure at the respective - ! grid coordinate; This is dry pressure not full - ! pressure, ignore this difference, since we are only - ! using this to compute qsat, which in turn is only used - ! to compute normalized humidity analysis variable - - enkf_pressure(count,k) = wrfarw_znu(1,1,k)*(wrfarw_mu(i,j,1) & - & + wrfarw_mub(i,j,1)) + wrfarw_ptop(1,1,1) - - ! Compute mixing ratio from specific humidity. - - enkf_spechumd(count,k) = (wrfarw_mixratio(i,j,k))/(1.0 + & - & wrfarw_mixratio(i,j,k)) - - ! Compute virtual temp (this is only used to compute - ! saturation specific humidity (call genqsat1) - - enkf_virttemp(count,k) = ((wrfarw_pert_pottemp(i,j,k) + & - & 300.0)/((1000.0/(enkf_pressure(count,k)/100.0)) & - & **(rd/cp))) * (1. + fv*enkf_spechumd(count,k)) - - ! Update counting variable - - count = count + 1 + call readwrfvar(filename, varstrname, enkf_mixratio, nlevs) + + ! read pressure information + call readpressure_arw(filename, znu, znw, enkf_mu, enkf_mub, ptop) + + ! compute surface pressure + enkf_qintegral = one + do i = 1, npts + do k = 1, nlevs + enkf_qintegral(i) = enkf_qintegral(i) + & + (znw(k) - znw(k+1))*enkf_mixratio(i,k) + enddo + enddo + + ! compute dry surface pressure + enkf_psfc = r0_01 * (enkf_mu + enkf_mub + ptop) + ! compute full surface pressure + enkf_psfc = (enkf_psfc - ptop) * enkf_qintegral + ptop + + ! compute specific humidity + enkf_spechumd = enkf_mixratio / (one + enkf_mixratio) + + ! compute pressure + do k = 1, nlevs + enkf_pressure(:,k) = r0_01 * (znu(k) * (100 * enkf_psfc - ptop) + ptop) + enddo + + ! compute sensible temperature + enkf_temp = (enkf_temp + 300.0) * (0.001 * enkf_pressure)**rd_over_cp_mass + + ! compute virtual temperature + enkf_virttemp = enkf_temp * (1. + fv*enkf_spechumd) + + if (tsen_ind > 0) then + vargrid(:,levels(tsen_ind-1)+1:levels(tsen_ind),nb,ne) = enkf_temp + do k = levels(tsen_ind-1)+1, levels(tsen_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: tsen ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif - end do ! do i = 1, xdim + if (q_ind > 0) then + vargrid(:,levels(q_ind-1)+1:levels(q_ind),nb,ne) = enkf_spechumd + do k = levels(q_ind-1)+1, levels(q_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: q ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif - end do ! do j = 1, ydim + if (tv_ind > 0) then + vargrid(:,levels(tv_ind-1)+1:levels(tv_ind),nb,ne) = enkf_virttemp + do k = levels(tv_ind-1)+1, levels(tv_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: tv ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + + if (ps_ind > 0) then + vargrid(:,levels(n3d)+ps_ind,nb,ne) = enkf_psfc + k = levels(n3d) + ps_ind + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: ps ', & + & minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + endif - end do ! do k = 1, zdim + if (prse_ind > 0) then + vargrid(:,levels(prse_ind-1)+1:levels(prse_ind)-1, nb,ne) = enkf_pressure + do k = levels(prse_ind-1)+1, levels(prse_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_ARW: prse ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif !---------------------------------------------------------------------- - ! Compute the saturation specific humidity if (pseudo_rh) then - call genqsat1(enkf_spechumd,qsat(:,:,nb),enkf_pressure/100.0,enkf_virttemp,ice, & + call genqsat1(enkf_spechumd,qsat(:,:,nb,ne),enkf_pressure,enkf_virttemp,ice, & npts,nlevs) else - qsat(:,:,nb) = 1._r_double + qsat(:,:,nb,ne) = 1._r_double endif - - !--------------------------------------------------------------------- - - ! End: Ingest the necessary variables and compute the saturated - ! specific humidity along the WRF-ARW grid; this routine assumes - ! that all mass variables are defined along the unstaggered grid - !====================================================================== - - ! Deallocate memory for variables ingested by routine - - if(allocated(wrfarw_pert_pottemp)) deallocate(wrfarw_pert_pottemp) - if(allocated(wrfarw_mixratio)) deallocate(wrfarw_mixratio) - if(allocated(wrfarw_mu)) deallocate(wrfarw_mu) - if(allocated(wrfarw_mub)) deallocate(wrfarw_mub) - if(allocated(wrfarw_znu)) deallocate(wrfarw_znu) - if(allocated(wrfarw_ptop)) deallocate(wrfarw_ptop) - - ! Deallocate memory for variables computed within routine - + ! Deallocate memory + if(allocated(enkf_mu)) deallocate(enkf_mu) + if(allocated(enkf_mub)) deallocate(enkf_mub) + if(allocated(enkf_temp)) deallocate(enkf_temp) + if(allocated(enkf_psfc)) deallocate(enkf_psfc) + if(allocated(enkf_qintegral)) deallocate(enkf_qintegral) if(allocated(enkf_virttemp)) deallocate(enkf_virttemp) if(allocated(enkf_pressure)) deallocate(enkf_pressure) + if(allocated(enkf_mixratio)) deallocate(enkf_mixratio) if(allocated(enkf_spechumd)) deallocate(enkf_spechumd) end do backgroundloop ! loop over backgrounds to read in - - !====================================================================== - - ! Return calculated values + end do ensmemloop ! loop over ens members to read in return - !====================================================================== - end subroutine readgriddata_arw !======================================================================== - - ! readgriddata_nmm.f90: This subroutine will receive a WRF-NMM - ! netcdf file name and variable string and will subsequently return - ! the respective variable interpolated to an unstaggered grid; all - ! checks for grid staggering are contained within this subroutine - + ! readgriddata_nmm.f90: read WRF-NMM state or control vector !------------------------------------------------------------------------- - subroutine readgriddata_nmm(nanal,vargrid,qsat) - + subroutine readgriddata_nmm(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,fileprefixes,vargrid,qsat) use constants !====================================================================== - - ! Define array dimension variables - - integer :: xdim, ydim, zdim - ! Define variables passed to subroutine - - character(len=500) :: filename - character(len=3) :: charnanal - integer, intent(in) :: nanal + integer, intent(in) :: nanal1, nanal2, n2d, n3d, ndim, ntimes + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, dimension(0:n3d), intent(in) :: levels + character(len=120), dimension(7), intent(in) :: fileprefixes ! Define variables returned by subroutine - - real(r_single), dimension(npts,nvars*nlevs+1,nbackgrounds), intent(out) :: vargrid - real(r_double), dimension(npts,nlevs,nbackgrounds), intent(out) :: qsat + real(r_single), dimension(npts,ndim,ntimes,nanal2-nanal1+1), intent(out) :: vargrid + real(r_double), dimension(npts,nlevs,ntimes,nanal2-nanal1+1), intent(out) :: qsat ! Define variables computed within subroutine - - logical :: ice - real, dimension(:,:,:), allocatable :: wrfnmm_temp - real, dimension(:,:,:), allocatable :: wrfnmm_pres - real, dimension(:,:,:), allocatable :: wrfnmm_mixratio - real, dimension(:,:,:), allocatable :: wrfnmm_pd - real, dimension(:,:,:), allocatable :: wrfnmm_psfc - real, dimension(:,:,:), allocatable :: wrfnmm_eta1 - real, dimension(:,:,:), allocatable :: wrfnmm_eta2 - real, dimension(:,:,:), allocatable :: wrfnmm_pdtop - real, dimension(:,:,:), allocatable :: wrfnmm_pt - real, dimension(:,:,:), allocatable :: workgrid - real, dimension(:,:,:), allocatable :: vargrid_native - real(r_single), dimension(:,:), allocatable :: enkf_virttemp - real(r_single), dimension(:,:), allocatable :: enkf_pressure - real(r_single), dimension(:,:), allocatable :: enkf_spechumd - real(r_kind) :: kap - real(r_kind) :: kap1 - real(r_kind) :: kapr - integer :: xdim_native - integer :: ydim_native - integer :: zdim_native - integer :: xdim_local - integer :: ydim_local - integer :: zdim_local - - ! Define variables requiredfor netcdf variable I/O - - character(len=12) :: varstrname - character(len=50) :: attstr - character(len=12) :: varstagger - character(len=12) :: varmemoryorder + logical :: ice + real :: pdtop, pt + real, dimension(:), allocatable :: aeta1, aeta2 + real(r_single), dimension(:), allocatable :: enkf_psfc, enkf_pd + real(r_single), dimension(:,:), allocatable :: enkf_temp + real(r_single), dimension(:,:), allocatable :: enkf_pressure + real(r_single), dimension(:,:), allocatable :: enkf_spechumd + + character(len=12) :: varstrname + character(len=500) :: filename + character(len=7) :: charnanal ! Define counting variables - - integer :: i, j, k, l, nb - integer :: counth, countv - integer :: count + integer(i_kind) :: nb, k, nanal, ne + integer(i_kind) :: u_ind, v_ind, tv_ind, q_ind, oz_ind + integer(i_kind) :: cw_ind, tsen_ind, prse_ind + integer(i_kind) :: ps_ind, sst_ind !====================================================================== + u_ind = getindex(vars3d, 'u') !< indices in the state var arrays + v_ind = getindex(vars3d, 'v') ! U and V (3D) + tv_ind = getindex(vars3d, 'tv') ! Tv (3D) + q_ind = getindex(vars3d, 'q') ! Q (3D) + oz_ind = getindex(vars3d, 'oz') ! Oz (3D) + cw_ind = getindex(vars3d, 'cw') ! CW (3D) + tsen_ind = getindex(vars3d, 'tsen') !sensible T (3D) + prse_ind = getindex(vars3d, 'prse') + + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + sst_ind = getindex(vars2d, 'sst') ! Initialize all constants required by routine - call init_constants(.true.) - - ! Define all local variables - - xdim = dimensions%xdim - ydim = dimensions%ydim - zdim = dimensions%zdim - - !====================================================================== - - ! Begin: Loop through each (prognostic) variable (defined in - ! gridio.F90), determine and define the spatial array - ! dimensions, and allocate memory for NMM dynamical core - - !---------------------------------------------------------------------- - if (nbackgrounds > 1) then - write(6,*)'gridio/readgriddata: reading multiple backgrounds not yet supported' - call stop2(23) - endif - backgroundloop: do nb=1,nbackgrounds - - ! Initialize counting variable - - countv = 1 - - ! Define character string for ensemble member file - - write(charnanal,'(i3.3)') nanal - filename = trim(adjustl(datapath))//trim(adjustl(fgfileprefixes(nb)))//"mem"//charnanal - - !---------------------------------------------------------------------- - - ! Loop through all variables to be update via the EnKF - - do l = 1, nvars + 1 - - !---------------------------------------------------------------------- - - ! Define staggering attributes for variable grid - - attstr = 'stagger' - call variableattribute_char(filename,gridvarstring(l),attstr, & - & varstagger) - - ! If variable grid is staggered in X-direction, assign array - ! dimensions appropriately - - if(varstagger(1:1) .eq. 'X') then - - ! Assign array dimensions appropriately - - xdim_native = xdim + 1 - ydim_native = ydim - zdim_native = zdim - - ! If variable grid is staggered in Y-direction, assign array - ! dimensions appropriately - - else if(varstagger(1:1) .eq. 'Y') then ! if(varstagger(1:1) .eq. ' - ! X') - - ! Assign array dimensions appropriately - - xdim_native = xdim - ydim_native = ydim + 1 - zdim_native = zdim - - ! If variable grid is staggered in Z-direction, assign array - ! dimensions appropriately - - else if(varstagger(1:1) .eq. 'Z') then ! if(varstagger(1:1) .eq. ' - ! X') - - ! Assign array dimensions appropriately - - xdim_native = xdim - ydim_native = ydim - zdim_native = zdim + 1 - - ! If variable grid is not staggered, assign array dimensions - ! appropriately - - else ! if(varstagger(1:1) .eq. 'X') - - ! Assign array dimensions appropriately - - xdim_native = xdim - ydim_native = ydim - zdim_native = zdim - - end if ! if(varstagger(1:1) .eq. 'X') - - !---------------------------------------------------------------------- - - ! Define memory attributes for variable grid - - attstr = 'MemoryOrder' - call variableattribute_char(filename,gridvarstring(l),attstr, & - & varmemoryorder) - - ! If variable is a 2-dimensional field, rescale variables - ! appropriately - - if(varmemoryorder(1:3) .eq. 'XY ') then - - ! Rescale grid dimension variables appropriately - - zdim_local = 1 - zdim_native = 1 - - else - - ! Define local array dimension - - zdim_local = zdim - - end if ! if(varmemoryorder(1:3) .eq. 'XY ') - - ! Define local variable dimensions - - xdim_local = xdim - ydim_local = ydim - - ! Allocate memory for local variable arrays - - if(.not. allocated(workgrid)) & - & allocate(workgrid(xdim_local,ydim_local,zdim_local)) - if(.not. allocated(vargrid_native)) & - & allocate(vargrid_native(xdim_native,ydim_native, & - & zdim_native)) - - ! Ingest variable from external netcdf formatted file - - call readnetcdfdata(filename,vargrid_native,gridvarstring(l), & - & xdim_native,ydim_native,zdim_native) - - ! Interpolate variable from staggered (i.e., E-) grid to - ! unstaggered (i.e., A-) grid. If variable is staggered in - ! vertical, intepolate from model layer interfaces - ! (including surface and top) to model layer midpoints. - - call cross2dot(vargrid_native,xdim_native,ydim_native, & - & zdim_native,xdim_local,ydim_local,zdim_local,workgrid) - - !---------------------------------------------------------------------- - - ! Loop through vertical coordinate - - do k = 1, zdim_local - - ! Initialize counting variable - - counth = 1 - - ! Loop through meridional horizontal coordinate - - do j = 1, ydim_local - - ! Loop through zonal horizontal coordinate - - do i = 1, xdim_local - - ! Assign values to output variable array - - vargrid(counth,countv,nb) = workgrid(i,j,k) - - ! Update counting variable - - counth = counth + 1 - - end do ! do i = 1, xdim_local - - end do ! do j = 1, ydim_local - - ! Print message to user - - if (nproc .eq. 0) & - write(6,*) 'READGRIDDATA_NMM: ', trim(gridvarstring(l)), & - & countv, minval(vargrid(:,countv,nb)), & - & maxval(vargrid(:,countv,nb)) - - ! Update counting variable - - countv = countv + 1 - - end do ! do k = 1, zdim_local - - !---------------------------------------------------------------------- - - ! Deallocate memory for local variables - - if(allocated(vargrid_native)) deallocate(vargrid_native) - if(allocated(workgrid)) deallocate(workgrid) - - !---------------------------------------------------------------------- - - end do ! do l = 1, nvars + 1 - - !---------------------------------------------------------------------- - - ! End: Loop through each (prognostic) variable (defined in - ! gridio.F90), determine and define the spatial array - ! dimensions, and allocate memory for NMM dynamical core - - !====================================================================== - - ! Begin: Ingest the necessary variables and compute the saturated - ! specific humidity along the WRF-NMM grid; this routine assumes - ! that all mass variables are defined along the unstaggered grid - - !---------------------------------------------------------------------- - - ! Define all constants required by routine - - ice = .false. - kap = rd/cp - kapr = cp/rd - kap1 = kap + 1 - - !---------------------------------------------------------------------- - - ! Allocate memory for all variables ingested by routine - - if(.not. allocated(wrfnmm_temp)) & - & allocate(wrfnmm_temp(xdim,ydim,zdim)) - if(.not. allocated(wrfnmm_pres)) & - & allocate(wrfnmm_pres(xdim,ydim,zdim)) - if(.not. allocated(wrfnmm_mixratio)) & - & allocate(wrfnmm_mixratio(xdim,ydim,zdim)) - if(.not. allocated(wrfnmm_psfc)) & - & allocate(wrfnmm_psfc(xdim,ydim,1)) - if(.not. allocated(wrfnmm_pd)) & - & allocate(wrfnmm_pd(xdim,ydim,1)) - if(.not. allocated(wrfnmm_eta1)) & - & allocate(wrfnmm_eta1(1,1,zdim)) - if(.not. allocated(wrfnmm_eta2)) & - & allocate(wrfnmm_eta2(1,1,zdim)) - if(.not. allocated(wrfnmm_pdtop)) & - & allocate(wrfnmm_pdtop(1,1,1)) - if(.not. allocated(wrfnmm_pt)) & - & allocate(wrfnmm_pt(1,1,1)) - - ! Allocate memory for variables computed within routine - - if(.not. allocated(enkf_virttemp)) allocate(enkf_virttemp(npts,nlevs)) - if(.not. allocated(enkf_pressure)) allocate(enkf_pressure(npts,nlevs)) - if(.not. allocated(enkf_spechumd)) allocate(enkf_spechumd(npts,nlevs)) - - !---------------------------------------------------------------------- - - ! Ingest the (sensible) temperature from the external file - - varstrname= 'T' - call readnetcdfdata(filename,wrfnmm_temp,varstrname,xdim,ydim,zdim) - - ! Ingest the water vapor mixing ratio from the external file - - varstrname = 'Q' - call readnetcdfdata(filename,wrfnmm_mixratio,varstrname,xdim,ydim, & - & zdim) - - ! Ingest surface pressure from the external file - - varstrname = 'PD' - call readnetcdfdata(filename,wrfnmm_pd,varstrname,xdim,ydim,1) - - ! Ingest hybrid vertical coordinate from the external file - - varstrname = 'AETA1' - call readnetcdfdata(filename,wrfnmm_eta1,varstrname,1,1,zdim) - - ! Ingest hybrid vertical coordinate from the external file - - varstrname = 'AETA2' - call readnetcdfdata(filename,wrfnmm_eta2,varstrname,1,1,zdim) - - ! Ingest pressure at top of domain from the external file - - varstrname = 'PT' - call readnetcdfdata(filename,wrfnmm_pt,varstrname,1,1,1) - - ! Ingest mass within pressure domain from the external file - - varstrname = 'PDTOP' - call readnetcdfdata(filename,wrfnmm_pdtop,varstrname,1,1,1) - - !---------------------------------------------------------------------- - - ! Loop through meridional horizontal coordinate - - do j = 1, ydim - - ! Loop through zonal horizontal coordinate - do i = 1, xdim - - ! Compute the surface pressure profile - - wrfnmm_psfc(i,j,1) = (wrfnmm_pd(i,j,1) + wrfnmm_pdtop(1,1,1) + & - & wrfnmm_pt(1,1,1)) - - end do ! do i = 1, xdim - - end do ! do j = 1, ydim - - ! Loop through vertical horizontal coordinate - - do k = 1, zdim - - ! Loop through meridional horizontal coordinate - - do j = 1, ydim - - ! Loop through zonal horizontal coordinate - - do i = 1, xdim - - ! Compute the pressure profile; the following formulation - ! (should be) is identical to that in the Gridpoint - ! Statistical Interpolation (GSI) routines for the - ! WRF-NMM dynamical core - - wrfnmm_pres(i,j,k) = wrfnmm_eta1(1,1,k)*wrfnmm_pdtop(1,1,1) + & - & wrfnmm_eta2(1,1,k)*(wrfnmm_psfc(i,j,1) - & - & wrfnmm_pdtop(1,1,1) - wrfnmm_pt(1,1,1)) + & - & wrfnmm_pt(1,1,1) - - end do ! do i = 1, xdim - - end do ! do j = 1, ydim - - end do ! do k = 1, zdim - - !---------------------------------------------------------------------- - - ! Loop through vertical coordinate; compute the hydrostatic - ! pressure level and subsequently the temperature at the - ! respective level - - do k = 1, zdim - - ! Initialize counting variable - - count = 1 - - ! Loop through meridional horizontal coordinate - - do j = 1, ydim + !---------------------------------------------------------------------- + if (ntimes > 1) then + write(6,*)'gridio/readgriddata: reading multiple backgrounds not yet supported' + call stop2(23) + endif - ! Loop through zonal horizontal coordinate + ne = 0 + ensmemloop: do nanal=nanal1,nanal2 + ne = ne + 1 + backgroundloop: do nb=1,ntimes - do i = 1, xdim - - ! Define the full pressure within model layers + ! Define character string for ensemble member file + if (nanal > 0) then + write(charnanal,'(a3, i3.3)') 'mem', nanal + else + charnanal = 'ensmean' + endif + filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) + + !---------------------------------------------------------------------- + ! read u-component + if (u_ind > 0) then + varstrname = 'U' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(u_ind-1)+1:levels(u_ind),nb,ne), nlevs) + do k = levels(u_ind-1)+1, levels(u_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_NMM: u ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read v-component + if (v_ind > 0) then + varstrname = 'V' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(v_ind-1)+1:levels(v_ind),nb,ne), nlevs) + do k = levels(v_ind-1)+1, levels(v_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_NMM: v ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! read cwm + if (cw_ind > 0) then + varstrname = 'CWM' + call readwrfvar(filename, varstrname, & + vargrid(:,levels(cw_ind-1)+1:levels(cw_ind),nb,ne), nlevs) + do k = levels(cw_ind-1)+1, levels(cw_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_NMM: cw', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif + ! set ozone to zero for now (like in GSI?) + if (oz_ind > 0) then + vargrid(:,levels(oz_ind-1)+1:levels(oz_ind),nb,ne) = zero + endif + ! set SST to zero for now + if (sst_ind > 0) then + vargrid(:,levels(n3d)+sst_ind,nb,ne) = zero + endif - enkf_pressure(count,k) = wrfnmm_pres(i,j,k) + ! Define all constants required by routine + ice = .false. - ! Define the specific humidity with model layers - - enkf_spechumd(count,k) = wrfnmm_mixratio(i,j,k) + !---------------------------------------------------------------------- - ! Compute virtual temp (this is only used to compute - ! saturation specific humidity (call genqsat1) + ! Allocate memory for variables computed within routine + if(.not. allocated(enkf_psfc)) allocate(enkf_psfc(npts)) + if(.not. allocated(enkf_temp)) allocate(enkf_temp(npts,nlevs)) + if(.not. allocated(enkf_pressure)) allocate(enkf_pressure(npts,nlevs)) + if(.not. allocated(enkf_spechumd)) allocate(enkf_spechumd(npts,nlevs)) - enkf_virttemp(count,k) = & - wrfnmm_temp(i,j,k)* (1. + fv*enkf_spechumd(count,k)) - - ! Update counting variable + !---------------------------------------------------------------------- - count = count + 1 + ! Ingest the (sensible) temperature from the external file + varstrname= 'T' + call readwrfvar(filename, varstrname, enkf_temp, nlevs) + if (tsen_ind > 0) then + vargrid(:,levels(tsen_ind-1)+1:levels(tsen_ind),nb,ne) = enkf_temp + do k = levels(tsen_ind-1)+1, levels(tsen_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_NMM: tsen ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif - end do ! do i = 1, xdim + ! Ingest the specific humidity from the external file + varstrname = 'Q' + call readwrfvar(filename, varstrname, enkf_spechumd, nlevs) + if (q_ind > 0) then + vargrid(:,levels(q_ind-1)+1:levels(q_ind),nb,ne) = enkf_spechumd + do k = levels(q_ind-1)+1, levels(q_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_NMM: q ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif - end do ! do j = 1, ydim + ! calculate virtual temperature + enkf_temp = enkf_temp * (one + fv*enkf_spechumd) + if (tv_ind > 0) then + vargrid(:,levels(tv_ind-1)+1:levels(tv_ind),nb,ne) = enkf_temp + do k = levels(tv_ind-1)+1, levels(tv_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_NMM: tv ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif - ! Print message to user + ! Ingest pressure info from the external file + call readpressure_nmm(filename, enkf_pd, aeta1, aeta2, pt, pdtop) - if(nproc .eq. 0) then + !---------------------------------------------------------------------- - ! Print message to user + ! calculate surface pressure + enkf_psfc = r0_01 * (enkf_pd + pdtop + pt) - write(6,*) 'level, min(pres), max(pres): ', k, & - & minval(enkf_pressure(1:(count - 1),k)), & - & maxval(enkf_pressure(1:(count - 1),k)) - write(6,*) 'level, min(virttemp), max(virttemp): ', k, & - & minval(enkf_virttemp(1:(count - 1),k)), & - & maxval(enkf_virttemp(1:(count - 1),k)) - write(6,*) 'level, min(sh), max(sh): ', k, & - & minval(enkf_spechumd(1:(count - 1),k)), & - & maxval(enkf_spechumd(1:(count - 1),k)) + if (ps_ind > 0) then + vargrid(:,levels(n3d)+ps_ind,nb,ne) = enkf_psfc + k = levels(n3d) + ps_ind + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_NMM: ps ', & + & minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + endif - end if ! if(nproc .eq. 0) + ! compute the pressure profile + do k = 1, nlevs + enkf_pressure(:,k) = r0_01 * (aeta1(k)*pdtop + aeta2(k)*enkf_pd + pt) + end do + + if (prse_ind > 0) then + vargrid(:,levels(prse_ind-1)+1:levels(prse_ind)-1, nb,ne) = enkf_pressure + do k = levels(prse_ind-1)+1, levels(prse_ind) + if (nproc .eq. 0) & + write(6,*) 'READGRIDDATA_NMM: prse ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + endif - end do ! do k = 1, zdim !---------------------------------------------------------------------- - ! Compute the saturation specific humidity - if (pseudo_rh) then - call genqsat1(enkf_spechumd,qsat(:,:,nb),enkf_pressure/100.0,enkf_virttemp,ice, & + call genqsat1(enkf_spechumd,qsat(:,:,nb,ne),enkf_pressure,enkf_temp,ice, & npts,nlevs) else - qsat(:,:,nb) = 1._r_double + qsat(:,:,nb,ne) = 1._r_double endif - !---------------------------------------------------------------------- - - ! End: Ingest the necessary variables and compute the saturated - ! specific humidity along the WRF-NMM grid; this routine assumes - ! that all mass variables are defined along the unstaggered grid - - !====================================================================== - - ! Deallocate memory for variables ingested by routine - - if(allocated(wrfnmm_temp)) deallocate(wrfnmm_temp) - if(allocated(wrfnmm_pres)) deallocate(wrfnmm_pres) - if(allocated(wrfnmm_mixratio)) deallocate(wrfnmm_mixratio) - if(allocated(wrfnmm_psfc)) deallocate(wrfnmm_psfc) - if(allocated(wrfnmm_pd)) deallocate(wrfnmm_pd) - if(allocated(wrfnmm_eta1)) deallocate(wrfnmm_eta1) - if(allocated(wrfnmm_eta2)) deallocate(wrfnmm_eta2) - if(allocated(wrfnmm_pdtop)) deallocate(wrfnmm_pdtop) - if(allocated(wrfnmm_pt)) deallocate(wrfnmm_pt) - ! Deallocate memory for variables computed within routine - - if(allocated(enkf_virttemp)) deallocate(enkf_virttemp) + if(allocated(enkf_temp)) deallocate(enkf_temp) + if(allocated(enkf_psfc)) deallocate(enkf_psfc) if(allocated(enkf_pressure)) deallocate(enkf_pressure) if(allocated(enkf_spechumd)) deallocate(enkf_spechumd) !====================================================================== end do backgroundloop ! loop over backgrounds to read in + end do ensmemloop ! loop over ens members to read in ! Return calculated values return - !====================================================================== - end subroutine readgriddata_nmm - !======================================================================== - - ! writegriddata.f90: This subroutine will receive a netcdf file name - ! and variable string and will subsequently return the respective - ! variable interpolated to the native variable grid; all checks for - ! grid staggering are contained within this subroutine + !======================================================================== + ! writegriddata.f90: write WRF-ARW or WRF-NMM analysis !------------------------------------------------------------------------- - subroutine writegriddata_wrf(nanal,vargrid) - - use netcdf, only: nf90_open,nf90_close - use netcdf, only: nf90_write - use netcdf, only: nf90_put_att - use netcdf, only: nf90_global + subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflate_flag) use constants - use netcdf_mod, only: nc_check + use params, only: nbackgrounds, anlfileprefixes, fgfileprefixes + include 'netcdf.inc' !---------------------------------------------------------------------- - ! Define variables passed to subroutine - - real(r_single), dimension(npts,nvars*nlevs+1,nbackgrounds), intent(in) :: vargrid - integer, intent(in) :: nanal + integer, intent(in) :: nanal1,nanal2, n2d, n3d, ndim + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, dimension(0:n3d), intent(in) :: levels + real(r_single), dimension(npts,ndim,nbackgrounds,nanal2-nanal1+1), intent(in) :: vargrid + logical, intent(in) :: no_inflate_flag + !Not used here, but added to make writegriddata(...) consistent with gridio_gfs.f90 !---------------------------------------------------------------------- - ! Define variables computed within subroutine - - character(len=500) :: filename - character(len=3) :: charnanal - real, dimension(:,:,:), allocatable :: vargrid_native - real, dimension(:,:,:), allocatable :: vargridin_native - real, dimension(:,:,:), allocatable :: workgrid - real :: clip - integer iyear,imonth,iday,ihour,dh1,ierr,iw3jdn - integer :: xdim_native - integer :: ydim_native - integer :: zdim_native - integer :: xdim_local - integer :: ydim_local - integer :: zdim_local + character(len=500) :: filename + character(len=3) :: charnanal + real :: clip + integer :: iyear,imonth,iday,ihour,dh1,ierr,iw3jdn !---------------------------------------------------------------------- - - ! Define array dimension variables - - integer :: xdim - integer :: ydim - integer :: zdim + integer(i_kind) :: u_ind, v_ind, tv_ind, q_ind, ps_ind, ql_ind, qr_ind, qi_ind, qg_ind, & + qs_ind, qnc_ind, qnr_ind, qni_ind, dbz_ind + integer(i_kind) :: w_ind, cw_ind, ph_ind !---------------------------------------------------------------------- - ! Define variables required by for extracting netcdf variable ! fields - - character(len=50) :: attstr - character(len=12) :: varstagger,varstrname - character(len=12) :: varmemoryorder - character(len=19) :: DateStr - character(len=24),parameter :: myname_ = 'gridio' + character(len=19) :: DateStr + ! Define variables required for netcdf variable I/O + character(len=12) :: varstrname + real, dimension(:,:,:), allocatable :: vargrid_native !---------------------------------------------------------------------- - ! Define counting variables + integer :: k, nb, nanal, ne - integer :: i, j, k, l, nb - integer :: counth, countv + real(r_single), dimension(:,:), allocatable :: enkf_t, enkf_q, enkf_field + real(r_single), dimension(:), allocatable :: enkf_psfc, pressure + real(r_single), dimension(:), allocatable :: enkf_mu, enkf_mub + real(r_single), dimension(:), allocatable :: znu, znw + real(r_single), dimension(:), allocatable :: qintegral - !---------------------------------------------------------------------- + real(r_single) :: ptop - ! Initialize constants required by routine + !---------------------------------------------------------------------- - call init_constants(.true.) + u_ind = getindex(vars3d, 'u') !< indices in the state var arrays + v_ind = getindex(vars3d, 'v') ! U and V (3D) + tv_ind = getindex(vars3d, 'tv') ! Tv (3D) + q_ind = getindex(vars3d, 'q') ! Q (3D) + cw_ind = getindex(vars3d, 'cw') ! CWM for WRF-NMM + w_ind = getindex(vars3d, 'w') ! W for WRF-ARW + ph_ind = getindex(vars3d, 'ph') ! PH for WRF-ARW - !---------------------------------------------------------------------- + ql_ind = getindex(vars3d, 'ql') ! QL (3D) for WRF-ARW + qr_ind = getindex(vars3d, 'qr') ! QR (3D) for WRF-ARW + qi_ind = getindex(vars3d, 'qi') ! QI (3D) for WRF-ARW + qg_ind = getindex(vars3d, 'qg') ! QG (3D) for WRF-ARW + qs_ind = getindex(vars3d, 'qs') ! QS (3D) for WRF-ARW + qnc_ind = getindex(vars3d, 'qnc') ! QNC (3D) for WRF-ARW + qnr_ind = getindex(vars3d, 'qnr') ! QNR (3D) for WRF-ARW + qni_ind = getindex(vars3d, 'qni') ! QNI (3D) for WRF-ARW + dbz_ind = getindex(vars3d, 'dbz') ! DBZ (3D) for WRF-ARW - ! Define all array dimensions + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) - xdim = dimensions%xdim - ydim = dimensions%ydim - zdim = dimensions%zdim + ! Initialize constants required by routine + call init_constants(.true.) + !---------------------------------------------------------------------- if (nbackgrounds > 1) then write(6,*)'gridio/writegriddata_wrf: writing multiple backgrounds not yet supported' call stop2(23) endif + ne = 0 + ensmemloop: do nanal=nanal1,nanal2 + ne = ne + 1 backgroundloop: do nb=1,nbackgrounds - ! Allocate memory for local variable - - allocate(workgrid(xdim,ydim,zdim)) - - !---------------------------------------------------------------------- - - ! End: Define all local variables required by routine - - !====================================================================== - - ! Begin: Loop through each prognostic variable and determine the - ! spatial array dimensions for each variable contained within - ! file, define appropriate array dimensions, and allocate memory; - ! update respective analysis (e.g., prognostic model) variables - !---------------------------------------------------------------------- - - ! Initialize counting variable - - countv = 1 - - !---------------------------------------------------------------------- - ! First guess file should be copied to analysis file at scripting ! level; only variables updated by EnKF are changed - write(charnanal,'(i3.3)') nanal filename = trim(adjustl(datapath))//trim(adjustl(anlfileprefixes(nb)))//"mem"//charnanal !---------------------------------------------------------------------- + ! Update u and v variables (same for NMM and ARW) + allocate(enkf_field(npts, nlevs)) + if (u_ind > 0) then + varstrname = 'U' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(u_ind-1)+1:levels(u_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif + if (v_ind > 0) then + varstrname = 'V' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(v_ind-1)+1:levels(v_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - ! Loop through all analysis variables to be updated - - do l = 1, nvars + 1 - - !---------------------------------------------------------------------- - - ! For WRF-ARW; analysis variables are defined on C-grid; the - ! check for interpolation between mass and velocity points is - ! done here - - if(arw) then - - !---------------------------------------------------------------------- - - ! Define staggering attributes for variable grid - - attstr = 'stagger' - call variableattribute_char(filename,gridvarstring(l),attstr, & - & varstagger) - - !---------------------------------------------------------------------- - - ! If variable grid is staggered in X-direction, assign array - ! dimensions appropriately - - if(varstagger(1:1) .eq. 'X') then - - ! Assign array dimensions appropriately - - xdim_native = xdim + 1 - ydim_native = ydim - zdim_native = zdim - - !---------------------------------------------------------------------- - - ! If variable grid is staggered in Y-direction, assign - ! array dimensions appropriately - - else if(varstagger(1:1) .eq. 'Y') then - - ! Assign array dimensions appropriately - - xdim_native = xdim - ydim_native = ydim + 1 - zdim_native = zdim - - !---------------------------------------------------------------------- - - ! If variable grid is staggered in Z-direction, assign - ! array dimensions appropriately - - else if(varstagger(1:1) .eq. 'Z') then - - ! Assign array dimensions appropriately - - xdim_native = xdim - ydim_native = ydim - zdim_native = zdim + 1 - - !---------------------------------------------------------------------- - - ! If variable grid is not staggered, assign array - ! dimensions appropriately - - else - - ! Assign array dimensions appropriately - - xdim_native = xdim - ydim_native = ydim - zdim_native = zdim - - !---------------------------------------------------------------------- - - end if ! if(varstagger(1:1) .eq. 'X') + ! update CWM for WRF-NMM + if (nmm .and. cw_ind > 0) then + varstrname = 'CWM' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(cw_ind-1)+1:levels(cw_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - !---------------------------------------------------------------------- + ! update reflectivity and hydrometeor mixing ratios for WRF-ARW + if (arw .and. dbz_ind > 0) then + varstrname = 'REFL_10CM' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(dbz_ind-1)+1:levels(dbz_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - endif ! if(arw) + if (arw .and. ql_ind > 0) then + varstrname = 'QCLOUD' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(ql_ind-1)+1:levels(ql_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - !---------------------------------------------------------------------- + if (arw .and. qr_ind > 0) then + varstrname = 'QRAIN' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(qr_ind-1)+1:levels(qr_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - ! For WRF-NMM; analysis variables are defined on E-grid; - ! although th grid may still be staggered, the array dimensions - ! (along the horizontal planes) remain the same dimension, - ! however just offset + if (arw .and. qi_ind > 0) then + varstrname = 'QICE' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(qi_ind-1)+1:levels(qi_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - if(nmm) then + if (arw .and. qs_ind > 0) then + varstrname = 'QSNOW' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(qs_ind-1)+1:levels(qs_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - ! Assign array dimensions appropriately + if (arw .and. qg_ind > 0) then + varstrname = 'QGRAUP' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(qg_ind-1)+1:levels(qg_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - xdim_native = xdim - ydim_native = ydim - zdim_native = zdim + if (arw .and. qnc_ind > 0) then + varstrname = 'QNCLOUD' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(qnc_ind-1)+1:levels(qnc_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - end if ! if(nmm) + if (arw .and. qni_ind > 0) then + varstrname = 'QNICE' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(qni_ind-1)+1:levels(qni_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - !---------------------------------------------------------------------- + if (arw .and. qnr_ind > 0) then + varstrname = 'QNRAIN' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(qnr_ind-1)+1:levels(qnr_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif - ! Define memory attributes for variable grid; this is done for - ! ARW only + ! update W and PH for WRF-ARW + if (arw .and. w_ind > 0) then + varstrname = 'W' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(w_ind-1)+1:levels(w_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif + if (arw .and. ph_ind > 0) then + varstrname = 'PH' + call readwrfvar(filename, varstrname, enkf_field, nlevs) + enkf_field = enkf_field + vargrid(:,levels(ph_ind-1)+1:levels(ph_ind),nb,ne) + call writewrfvar(filename, varstrname, enkf_field, nlevs) + endif + deallocate(enkf_field) - if(arw) then - attstr = 'MemoryOrder' - call variableattribute_char(filename,gridvarstring(l),attstr, & - & varmemoryorder) + allocate(enkf_t(npts, nlevs), enkf_q(npts,nlevs), enkf_psfc(npts)) + if (nmm) then + ! Update Tv and Q for NMM files (write out Tsen and Q) + if (tv_ind > 0 .or. q_ind > 0) then + ! read background specific humidity and sensible temperature + varstrname = 'Q' + call readwrfvar(filename, varstrname, enkf_q, nlevs) + varstrname = 'T' + call readwrfvar(filename, varstrname, enkf_t, nlevs) - end if ! if(arw) + ! compute background virtual temperature + enkf_t = enkf_t * (one + fv*enkf_q) + + ! add analysis increment to virtual temperature and specific humidity + if (tv_ind > 0) then + enkf_t = enkf_t + vargrid(:,levels(tv_ind-1)+1:levels(tv_ind),nb,ne) + endif + if (q_ind > 0) then + enkf_q = enkf_q + vargrid(:,levels(q_ind-1)+1:levels(q_ind),nb,ne) + endif + + ! clip Q if needed + if (cliptracers) then + clip = tiny(enkf_q(1,1)) + where (enkf_q < clip) enkf_q = clip + end if + + ! compute analysis sensible temperature + enkf_t = enkf_t / (one + fv*enkf_q) + + ! write out analysis sensible temperature and specific humidity + if (tv_ind > 0) then + varstrname = 'T' + call writewrfvar(filename, varstrname, enkf_t, nlevs) + endif + if (q_ind > 0) then + varstrname = 'Q' + call writewrfvar(filename, varstrname, enkf_q, nlevs) + endif + endif + ! update surface pressure for NMM + if (ps_ind > 0) then + varstrname = 'PD' + call readwrfvar(filename, varstrname, enkf_psfc, 1) + + ! add ps increment (mulitply by 100 since we're updating PD + enkf_psfc = enkf_psfc + 100.*vargrid(:,levels(n3d)+ps_ind,nb,ne) + call writewrfvar(filename, varstrname, enkf_psfc, 1) + endif + ! for ARW, update Tv and Q, but write out Tp and mix ratio + elseif (arw) then + if (tv_ind > 0 .or. q_ind > 0 .or. ps_ind > 0) then + allocate(qintegral(npts), pressure(npts)) + + ! read background potential temperature, mixing ratio + ! and pressure information + varstrname = 'QVAPOR' + call readwrfvar(filename, varstrname, enkf_q, nlevs) + varstrname = 'T' + call readwrfvar(filename, varstrname, enkf_t, nlevs) + + call readpressure_arw(filename, znu, znw, enkf_mu, enkf_mub, ptop) + + ! compute background dry surface pressure + enkf_psfc = r0_01*(enkf_mu + enkf_mub + ptop) + ! compute background full surface pressure + qintegral = one + do k = 1, nlevs + qintegral(:) = qintegral(:) + (znw(k) - znw(k+1))*enkf_q(:,k) + enddo + enkf_psfc = (enkf_psfc - ptop) * qintegral + ptop + + ! compute background specific humidity + enkf_q = enkf_q / (one + enkf_q) + + ! compute background sensible temperature + do k = 1, nlevs + pressure = r0_01 * (znu(k)*(100*enkf_psfc-ptop)+ptop) + enkf_t(:,k) = (enkf_t(:,k) + 300.0) * & + (0.001 * pressure)**rd_over_cp_mass + enddo + + ! compute background virtual temperature + enkf_t = enkf_t * (one + fv*enkf_q) + + ! add analysis increment to virtual temperature, specific humidity + ! and surface pressure + if (tv_ind > 0) then + enkf_t = enkf_t + vargrid(:,levels(tv_ind-1)+1:levels(tv_ind),nb,ne) + endif + if (q_ind > 0) then + enkf_q = enkf_q + vargrid(:,levels(q_ind-1)+1:levels(q_ind),nb,ne) + endif + if (ps_ind > 0) then + enkf_psfc = enkf_psfc + vargrid(:,levels(n3d)+ps_ind,nb,ne) + endif + + ! clip Q if needed + if (cliptracers) then + clip = tiny(enkf_q(1,1)) + where (enkf_q < clip) enkf_q = clip + end if + + ! compute analysis sensible temperature + enkf_t = enkf_t / (one + fv*enkf_q) + + ! compute analysis mixing ratio + enkf_q = enkf_q / (one - enkf_q) + + ! compute analysis potential temperature + do k = 1, nlevs + pressure = r0_01 * (znu(k)*(100*enkf_psfc-ptop)+ptop) + enkf_t(:,k) = enkf_t(:,k) / & + (0.001 * pressure)**rd_over_cp_mass - 300.0 + enddo + + ! compute analysis dry surface pressure + qintegral = one + do k = 1, nlevs + qintegral(:) = qintegral(:) + & + (znw(k) - znw(k+1))*enkf_q(:,k) + enddo + enkf_psfc = (enkf_psfc - ptop) / qintegral + ptop + + ! compute analysis mu + enkf_psfc = 100.*enkf_psfc - enkf_mub - ptop + + ! write out analysis virtual temperature, specific humidity + ! and surface pressure + if (tv_ind > 0) then + varstrname = 'T' + call writewrfvar(filename, varstrname, enkf_t, nlevs) + endif + if (q_ind > 0) then + varstrname = 'QVAPOR' + call writewrfvar(filename, varstrname, enkf_q, nlevs) + endif + if (ps_ind > 0) then + varstrname = 'MU' + call writewrfvar(filename, varstrname, enkf_psfc, 1) + endif + endif + endif !---------------------------------------------------------------------- + ! update NSTART_HOUR in NMM (HWRF) restart file. + read(datestring(1:4),'(i4)') iyear + read(datestring(5:6),'(i2)') imonth + read(datestring(7:8),'(i2)') iday + read(datestring(9:10),'(i2)') ihour + if (nmm .and. nmm_restart) then + varstrname = 'NSTART_HOUR' + if(.not. allocated(vargrid_native)) allocate(vargrid_native(1,1,1)) + vargrid_native(1,1,1) = ihour + call writenetcdfdata(filename,vargrid_native,varstrname,1,1,1) + end if + ! + ! update START_DATE, SIMULATION_START_DATE, GMT, JULYR, JULDAY + ! global attributes. + ! + write(DateStr,'(i4,"-",i2.2,"-",i2.2,"-",i2.2,"_",i2.2,":",i2.2)') iyear,imonth,iday,ihour,0,0 + ierr = NF_OPEN(trim(filename), NF_WRITE, dh1) + IF (ierr .NE. NF_NOERR) print *, 'OPEN ',NF_STRERROR(ierr) + ierr = NF_PUT_ATT_TEXT(dh1,NF_GLOBAL,'START_DATE',len(trim(DateStr)),DateStr) + IF (ierr .NE. NF_NOERR) print *,'PUT START_DATE', NF_STRERROR(ierr) + ierr = NF_PUT_ATT_TEXT(dh1,NF_GLOBAL,'SIMULATION_START_DATE',len(trim(DateStr)),DateStr) + IF (ierr .NE. NF_NOERR) print *,'PUT SIMULATION_START_DATE', NF_STRERROR(ierr) + ierr = NF_PUT_ATT_REAL(dh1,NF_GLOBAL,'GMT',NF_FLOAT,1,float(ihour)) + IF (ierr .NE. NF_NOERR) print *,'PUT GMT', NF_STRERROR(ierr) + ierr = NF_PUT_ATT_INT(dh1,NF_GLOBAL,'JULYR',NF_INT,1,iyear) + IF (ierr .NE. NF_NOERR) print *,'PUT JULYR', NF_STRERROR(ierr) + ierr=NF_PUT_ATT_INT(dh1,NF_GLOBAL,'JULDAY',NF_INT,1,iw3jdn(iyear,imonth,iday)-iw3jdn(iyear,1,1)+1) + IF (ierr .NE. NF_NOERR) print *,'PUT JULDAY', NF_STRERROR(ierr) + ierr = NF_CLOSE(dh1) + IF (ierr .NE. NF_NOERR) print *, 'CLOSE ',NF_STRERROR(ierr) - ! If variable is a 2-dimensional field, rescale variables - ! appropriately - - if(gridvarstring(l) .eq. 'MU' .or. gridvarstring(l) .eq. 'PD') then - - ! Rescale grid dimension variables appropriately - - zdim_local = 1 - zdim_native = 1 - - else + !====================================================================== + end do backgroundloop ! loop over backgrounds to read in + end do ensmemloop ! loop over ens members to read in - ! Define local array dimension + ! Return calculated values + return - zdim_local = zdim + !====================================================================== - end if ! if(gridvarstring(l) .eq. 'MU' .or. gridvarstring(l) .eq. - ! 'PD') + end subroutine writegriddata - !---------------------------------------------------------------------- + !====================================================================== + ! readwrfvar.f90: This subroutine reads a varname variable from WRF + ! ARW or NMM netcdf file and returns the variable interpolated to + ! unstaggered grid, in EnKF style (1D array for 2D field); all + ! checks for grid staggering are contained within this subroutine + subroutine readwrfvar(filename, varname, grid, nlevs) + implicit none + character(len=500), intent(in) :: filename + character(len=12), intent(in) :: varname + integer(i_kind), intent(in) :: nlevs + real(r_single), dimension(npts,nlevs), intent(out) :: grid - ! Define local variable dimensions + ! Define variables computed within subroutine + real, dimension(:,:,:), allocatable :: workgrid + real, dimension(:,:,:), allocatable :: vargrid_native + integer :: xdim, ydim, zdim + integer :: xdim_native, ydim_native, zdim_native + integer :: xdim_local, ydim_local, zdim_local - xdim_local = xdim - ydim_local = ydim + ! Define variables requiredfor netcdf variable I/O + character(len=50) :: attstr + character(len=12) :: varstagger + character(len=12) :: varmemoryorder - !---------------------------------------------------------------------- + ! Define counting variables + integer :: i, j, k + integer :: counth - ! Allocate memory local arrays (first check whether they are - ! already allocated) + xdim = dimensions%xdim + ydim = dimensions%ydim + zdim = dimensions%zdim - if (allocated(vargrid_native)) deallocate(vargrid_native) - allocate(vargrid_native(xdim_native,ydim_native,zdim_native)) - if (allocated(vargridin_native)) deallocate(vargridin_native) - allocate(vargridin_native(xdim_native,ydim_native,zdim_native)) + ! Define staggering attributes for variable grid + attstr = 'stagger' + call variableattribute_char(filename,varname,attstr, & + & varstagger) - !---------------------------------------------------------------------- - - ! Read in first-guess (i.e., analysis without current - ! increments) and store in local array + xdim_native = xdim + ydim_native = ydim + zdim_native = zdim + ! If variable grid is staggered assign array dimensions appropriately + if(varstagger(1:1) .eq. 'X') then + xdim_native = xdim + 1 + else if(varstagger(1:1) .eq. 'Y') then + ydim_native = ydim + 1 + else if(varstagger(1:1) .eq. 'Z') then + zdim_native = zdim + 1 + end if ! if(varstagger(1:1) .eq. 'X') + + ! Define memory attributes for variable grid + attstr = 'MemoryOrder' + call variableattribute_char(filename,varname,attstr, & + & varmemoryorder) - call readnetcdfdata(filename,vargridin_native,gridvarstring(l), & + ! If variable is a 2-dimensional field, rescale variables appropriately + if(varmemoryorder(1:3) .eq. 'XY ') then + zdim_local = 1 + zdim_native = 1 + else + zdim_local = zdim + end if ! if(varmemoryorder(1:3) .eq. 'XY ') + + ! Define local variable dimensions + xdim_local = xdim + ydim_local = ydim + ! Allocate memory for local variable arrays + if(.not. allocated(workgrid)) & + & allocate(workgrid(xdim_local,ydim_local,zdim_local)) + if(.not. allocated(vargrid_native)) & + & allocate(vargrid_native(xdim_native,ydim_native,zdim_native)) + + ! Ingest variable from external netcdf formatted file + call readnetcdfdata(filename,vargrid_native,varname, & & xdim_native,ydim_native,zdim_native) - !---------------------------------------------------------------------- - - ! Loop through vertical coordinate - - do k = 1, zdim_local + ! Interpolate variable from staggered (i.e., E-) grid to + ! unstaggered (i.e., A-) grid. If variable is staggered in + ! vertical, intepolate from model layer interfaces + ! (including surface and top) to model layer midpoints. + call cross2dot(vargrid_native,xdim_native,ydim_native, & + & zdim_native,xdim_local,ydim_local,zdim_local,workgrid) !---------------------------------------------------------------------- + ! Loop through vertical coordinate + do k = 1, zdim_local + ! Initialize counting variable + counth = 1 + ! Loop through meridional horizontal coordinate + do j = 1, ydim_local + ! Loop through zonal horizontal coordinate + do i = 1, xdim_local + ! Assign values to output variable array + grid(counth,k) = workgrid(i,j,k) - ! Initialize counting variable - - counth = 1 + counth = counth + 1 + end do ! do i = 1, xdim_local + end do ! do j = 1, ydim_local + end do ! do k = 1, zdim_local !---------------------------------------------------------------------- + ! Deallocate memory for local variables + if(allocated(vargrid_native)) deallocate(vargrid_native) + if(allocated(workgrid)) deallocate(workgrid) - ! Loop through meridional horizontal coordinate - - do j = 1, ydim - - ! Loop through zonal horizontal coordinate + end subroutine readwrfvar - do i = 1, xdim - !---------------------------------------------------------------------- + !====================================================================== + ! writewrfvar: write EnKF-style field in WRF netcdf file; variable is + ! interpolated to the native variable grid; all checks for + ! grid staggering are contained within this subroutine + subroutine writewrfvar(filename, varname, grid, nlevs) + implicit none + character(len=500), intent(in) :: filename + character(len=12), intent(in) :: varname + integer(i_kind), intent(in) :: nlevs + real(r_single), dimension(npts,nlevs), intent(in) :: grid - ! Assign values to local array + ! Define variables computed within subroutine + real, dimension(:,:,:), allocatable :: workgrid + real, dimension(:,:,:), allocatable :: vargrid_native + integer :: xdim, ydim, zdim + integer :: xdim_native, ydim_native, zdim_native + integer :: xdim_local, ydim_local, zdim_local - workgrid(i,j,k) = vargrid(counth,countv,nb) + ! Define variables requiredfor netcdf variable I/O + character(len=50) :: attstr + character(len=12) :: varstagger - ! Update counting variable + ! Define counting variables + integer :: i, j, k + integer :: counth - counth = counth + 1 - !---------------------------------------------------------------------- + xdim = dimensions%xdim + ydim = dimensions%ydim + zdim = dimensions%zdim - end do ! do i = 1, xdim + ! Allocate memory for local variable + allocate(workgrid(xdim,ydim,zdim)) - end do ! do j = 1, ydim + xdim_native = xdim + ydim_native = ydim + zdim_native = zdim - !---------------------------------------------------------------------- + if (arw) then + attstr = 'stagger' + call variableattribute_char(filename,varname,attstr, & + & varstagger) + !---------------------------------------------------------------------- + ! If variable grid is staggered, assign array dimensions appropriately + if(varstagger(1:1) .eq. 'X') then + xdim_native = xdim + 1 + else if(varstagger(1:1) .eq. 'Y') then + ydim_native = ydim + 1 + else if(varstagger(1:1) .eq. 'Z') then + zdim_native = zdim + 1 + end if ! if(varstagger(1:1) .eq. 'X') + endif - ! Update counting variable + zdim_local = nlevs + if(nlevs == 1) then + zdim_native = 1 + end if - countv = countv + 1 + ! Define local variable dimensions + xdim_local = xdim + ydim_local = ydim !---------------------------------------------------------------------- - - end do ! k = 1, zdim_local + ! Allocate memory local arrays (first check whether they are + ! already allocated) + if (allocated(vargrid_native)) deallocate(vargrid_native) + allocate(vargrid_native(xdim_native,ydim_native,zdim_native)) !---------------------------------------------------------------------- + ! Loop through vertical coordinate + do k = 1, zdim_local + ! Initialize counting variable + counth = 1 - ! Interpolate increments to native grid (i.e., from A-grid to - ! C-grid; if necessary); on input, workgrid is increments on - ! unstaggered grid; on output vargrid_native is increments on - ! model-native (i.e., staggered grid); vargridin_native is - ! unmodified first guess on native staggered grid + ! Loop through meridional horizontal coordinate + do j = 1, ydim + ! Loop through zonal horizontal coordinate + do i = 1, xdim + ! Assign values to local array + workgrid(i,j,k) = grid(counth,k) - call dot2cross(xdim_local,ydim_local,zdim_local,xdim_native, & + counth = counth + 1 + end do ! do i = 1, xdim + end do ! do j = 1, ydim + end do ! k = 1, zdim_local + + ! Interpolate increments to native grid (i.e., from A-grid to + ! C-grid; if necessary); on input, workgrid is increments on + ! unstaggered grid; on output vargrid_native is increments on + ! model-native (i.e., staggered grid); vargridin_native is + ! unmodified first guess on native staggered grid + call dot2cross(xdim_local,ydim_local,zdim_local,xdim_native, & ydim_native,zdim_native,workgrid,vargrid_native) - ! Add first guess to increment to get analysis on native grid; - ! this currently done only for ARW grids - - if(arw) then - - if (varstagger(1:1) .eq. 'Z') then ! if 'W' or 'PH' don't update surface - - vargridin_native(:,:,2:zdim_native) = & - & vargrid_native(:,:,2:zdim_native) + & - & vargridin_native(:,:,2:zdim_native) - - else - - vargridin_native = vargrid_native + vargridin_native - - endif ! if (varstagger(1:1) .eq. 'Z') - - endif ! if(arw) - - ! Clip all tracers (assume names start with 'Q') - - if (cliptracers .and. gridvarstring(l)(1:1) .eq. 'Q') then - - clip = tiny(vargridin_native(1,1,1)) - where (vargridin_native < clip) vargridin_native = clip - - end if ! if (cliptracers .and. gridvarstring(l)(1:1) .eq. 'Q') - !---------------------------------------------------------------------- - - if(nmm) then - - vargridin_native = vargrid_native + vargridin_native - - end if - - ! Write analysis variable. - - call writenetcdfdata(filename,vargridin_native,gridvarstring(l), & + ! Write analysis variable. + call writenetcdfdata(filename,vargrid_native,varname, & xdim_native,ydim_native,zdim_native) - end do ! do l = 1, nvars+1 + ! Deallocate memory for local variables + if(allocated(vargrid_native)) deallocate(vargrid_native) + if(allocated(workgrid)) deallocate(workgrid) - !---------------------------------------------------------------------- + end subroutine writewrfvar - ! Deallocate memory for local variable + !======================================================================== + ! read pressure information (pd, aeta1, aeta2, pl, pdtop from WRF-NMM file + ! subroutine allocates space for pd, aeta1 and aeta2 + subroutine readpressure_nmm(filename, pd, aeta1, aeta2, pt, pdtop) + implicit none + character(len=500), intent(in) :: filename + real(r_single), dimension(:), allocatable :: aeta1, aeta2 + real(r_single), dimension(:), allocatable :: pd + real(r_single) :: pt, pdtop - deallocate(workgrid) + real, dimension(:,:,:), allocatable :: wrfnmm + character(len=12) :: varstrname - ! update NSTART_HOUR in NMM (HWRF) restart file. - read(datestring(1:4),'(i4)') iyear - read(datestring(5:6),'(i2)') imonth - read(datestring(7:8),'(i2)') iday - read(datestring(9:10),'(i2)') ihour - if (nmm .and. nmm_restart) then - varstrname = 'NSTART_HOUR' - vargrid_native(1,1,1) = ihour - call writenetcdfdata(filename,vargrid_native,varstrname,1,1,1) - end if - ! - ! update START_DATE, SIMULATION_START_DATE, GMT, JULYR, JULDAY - ! global attributes. - ! - write(DateStr,'(i4,"-",i2.2,"-",i2.2,"-",i2.2,"_",i2.2,":",i2.2)') iyear,imonth,iday,ihour,0,0 + integer :: zdim - call nc_check( nf90_open(trim(filename),nf90_write,dh1),& - myname_,'open '//trim(filename) ) - call nc_check( nf90_put_att(dh1,nf90_global,'START_DATE',trim(DateStr)),& - myname_,'put_att: START_DATE '//trim(filename) ) - call nc_check( nf90_put_att(dh1,nf90_global,'SIMULATION_START_DATE',trim(DateStr)),& - myname_,'put_att: SIMULATION_START_DATE '//trim(filename) ) - call nc_check( nf90_put_att(dh1,nf90_global,'GMT',float(ihour)),& - myname_,'put_att: GMT '//trim(filename) ) - call nc_check( nf90_put_att(dh1,nf90_global,'JULYR',iyear),& - myname_,'put_att: JULYR'//trim(filename) ) - call nc_check( nf90_put_att(dh1,nf90_global,'JULDAY',iw3jdn(iyear,imonth,iday)-iw3jdn(iyear,1,1)+1),& - myname_,'put_att: JULDAY'//trim(filename) ) - call nc_check( nf90_close(dh1),& - myname_,'close: '//trim(filename) ) + zdim = dimensions%zdim - !---------------------------------------------------------------------- + allocate(aeta1(zdim), aeta2(zdim), pd(npts)) - ! End: Loop through each prognostic variable and determine the - ! spatial array dimensions for each variable contained within - ! file, define appropriate array dimensions, and allocate memory; - ! update respective analysis (e.g., prognostic model) variables + ! Ingest surface pressure from the external file + varstrname = 'PD' + call readwrfvar(filename,varstrname,pd,1) - !====================================================================== - end do backgroundloop ! loop over backgrounds to read in + ! Ingest hybrid vertical coordinate from the external file + varstrname = 'AETA1' + allocate(wrfnmm(1,1,zdim)) + call readnetcdfdata(filename,wrfnmm,varstrname,1,1,zdim) + aeta1 = wrfnmm(1,1,:) - ! Return calculated values + varstrname = 'AETA2' + call readnetcdfdata(filename,wrfnmm,varstrname,1,1,zdim) + aeta2 = wrfnmm(1,1,:) + deallocate(wrfnmm) - return + allocate(wrfnmm(1,1,1)) + ! Ingest pressure at top of domain from the external file + varstrname = 'PT' + call readnetcdfdata(filename,wrfnmm,varstrname,1,1,1) + pt = wrfnmm(1,1,1) - !====================================================================== + ! Ingest mass within pressure domain from the external file + varstrname = 'PDTOP' + call readnetcdfdata(filename,wrfnmm,varstrname,1,1,1) + pdtop = wrfnmm(1,1,1) + deallocate(wrfnmm) - end subroutine writegriddata_wrf + end subroutine readpressure_nmm !======================================================================== + ! read pressure information (aeta1, eta1, mu, mub, ptop from WRF-ARW file + ! subroutine allocates space for znu, znw, mu, mub + subroutine readpressure_arw(filename, znu, znw, mu, mub, ptop) + implicit none + character(len=500), intent(in) :: filename + real(r_single), dimension(:), allocatable :: znu, znw ! aeta1 and eta1 + real(r_single), dimension(:), allocatable :: mu, mub + real(r_single) :: ptop + + real, dimension(:,:,:), allocatable :: wrfarw + character(len=12) :: varstrname + + integer :: zdim + + zdim = dimensions%zdim + + allocate(znu(zdim), znw(zdim + 1), mu(npts), mub(npts)) + + ! Ingest the model vertical (eta) levels from the external file + varstrname = 'ZNU' + allocate(wrfarw(1,1,zdim)) + call readnetcdfdata(filename,wrfarw,varstrname,1,1,zdim) + znu = wrfarw(1,1,:) + deallocate(wrfarw) + + ! Ingest the model vertical (aeta) levels from the external file + varstrname = 'ZNW' + allocate(wrfarw(1,1,zdim+1)) + call readnetcdfdata(filename,wrfarw,varstrname,1,1,zdim+1) + znw = wrfarw(1,1,:) + deallocate(wrfarw) + + ! Ingest the model top pressure level from the external file + varstrname = 'P_TOP' + allocate(wrfarw(1,1,1)) + call readnetcdfdata(filename,wrfarw,varstrname,1,1,1) + ptop = wrfarw(1,1,1) + deallocate(wrfarw) + + ! Ingest the model perturbation dry air mass from the external + ! file + varstrname = 'MU' + call readwrfvar(filename,varstrname,mu,1) + + ! Ingest the model base state dry air mass from the external file + varstrname = 'MUB' + call readwrfvar(filename,varstrname,mub,1) + + end subroutine readpressure_arw end module gridio diff --git a/src/enkf/inflation.f90 b/src/enkf/inflation.f90 index 947af7f6a..119aa4446 100644 --- a/src/enkf/inflation.f90 +++ b/src/enkf/inflation.f90 @@ -8,8 +8,10 @@ module inflation ! ! prgmmr: whitaker org: esrl/psd date: 2009-02-23 ! -! abstract: posterior ensemble multiplicative inflation. The amount of -! inflation is given at each analysis grid point by: +! abstract: posterior ensemble inflation. Contains two components. +! +! 1) relaxation-to-prior spread (RTPS) posterior ensemble multiplicative inflation. +! The amount of inflation is given at each analysis grid point by: ! ! r = analpertwt*((stdev_prior-stdev_posterior)/stdev_posterior) + 1 ! @@ -30,31 +32,49 @@ module inflation ! The minimum and maximum values allowed can be controlled by the ! namelist parameters covinflatemin and covinflatemax. ! +! 2) relaxation-to-prior perturbation inflation (RTPP) +! +! xa_pert = (1-analpertwt_rtpp)*xa_pert + analpertwt_rtpp*xb_pert +! +! analpertwt_rtpp is a namelist parameter defined in module params. +! if =1, then analysis perturbations are re-set to background perturbations +! if between 0 and 1, analysis perts are linear combination of analysis +! and background perts. +! +! ! Public Subroutines: ! inflate_ens: apply inflation to the ensemble perturbations after ! the EnKF analysis step. ! ! Public Variables: None ! -! Modules Used: mpisetup, params, kinds, covlocal, statevec, gridinfo, loadal +! Modules Used: mpisetup, params, kinds, covlocal, controlvec, gridinfo, loadal ! ! program history log: -! 2009-02-23 Initial version. +! 2009-02-23: Initial version. +! 2016-05-02: shlyaeva: Modification for reading state vector from table +! 2016-11-29: shlyaeva: Modification for using control vector (control and state +! used to be the same) and the "chunks" come from loadbal +! 2017-05-12: Johnson, Y. Wang and X. Wang - Add height-dependent inflation, +! POC:xuguang.wang@ou.edu ! attributes: ! language: f95 ! !$$$ use mpisetup -use params, only: analpertwtnh,analpertwtsh,analpertwttr,ndim,nanals,nlevs,ndim,& +use params, only: analpertwtnh,analpertwtsh,analpertwttr,nanals,nlevs,& + analpertwtnh_rtpp,analpertwtsh_rtpp,analpertwttr_rtpp,& latbound, delat, datapath, covinflatemax, save_inflation, & - covinflatemin, nlons, nlats, smoothparm, nbackgrounds + covinflatemin, nlons, nlats, smoothparm, nbackgrounds,& + covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff use kinds, only: r_single, i_kind +use mpeu_util, only: getindex use constants, only: one, zero, rad2deg, deg2rad -use covlocal, only: latval -use statevec, only: anal_chunk, anal_chunk_prior -use gridinfo, only: latsgrd, logp, npts, nvarhumid -use loadbal, only: indxproc, numptsperproc, npts_max +use covlocal, only: latval, taper +use controlvec, only: ncdim, cvars3d, cvars2d, nc3d, nc2d, clevels +use gridinfo, only: latsgrd, logp, npts, nlevs_pres +use loadbal, only: indxproc, numptsperproc, npts_max, anal_chunk, anal_chunk_prior use smooth_mod, only: smooth implicit none @@ -73,45 +93,53 @@ subroutine inflate_ens() ! Area 3 tropics real(r_single) sprdmin, sprdmax, sprdmaxall, & - sprdminall, deglat,analpertwt, fsprd, asprd + sprdminall, deglat,analpertwt,analpertwt_rtpp, fsprd, asprd real(r_single),dimension(ndiag) :: sumcoslat,suma,suma2,sumi,sumf,sumitot,sumatot, & sumcoslattot,suma2tot,sumftot real(r_single) fnanalsml,coslat -integer(i_kind) i,nn,iunit,ierr,nb +integer(i_kind) i,nn,iunit,ierr,nb,nnlvl,ps_ind character(len=500) filename real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal - -! if no inflation called for, do nothing. -if (abs(analpertwtnh) < 1.e-5_r_single .and. & - abs(analpertwttr) < 1.e-5_r_single .and. & - abs(analpertwtsh) < 1.e-5_r_single) return +real(r_single) r fnanalsml = one/(real(nanals-1,r_single)) +if (analpertwtnh_rtpp > 1.e-5_r_single .and. & + analpertwtnh_rtpp > 1.e-5_r_single .and. & + analpertwttr_rtpp > 1.e-5_r_single) then +if (nproc .eq. 0) print *,'performing RTPP inflation...' nbloop: do nb=1,nbackgrounds ! loop over time levels in background - -! if analpertwtnh<0 use 'relaxation-to-prior' ensemble inflation, +! First perform RTPP ensemble inflation, ! as first described in: ! Zhang, F., C. Snyder, and J. Sun, 2004: Tests of an ensemble ! Kalman Filter for convective-scale data assim-imilation: ! Impact of initial estimate and observations. ! Mon. Wea. Rev., 132, 1238-1253. -if (analpertwtnh < 0) then - do nn=1,ndim - do i=1,numptsperproc(nproc+1) - deglat = rad2deg*latsgrd(indxproc(nproc+1,i)) - ! coefficent can be different in NH, TR, SH. - analpertwt = & - latval(deglat,abs(analpertwtnh),abs(analpertwttr),abs(analpertwtsh)) - anal_chunk(:,i,nn,nb) = analpertwt*anal_chunk_prior(:,i,nn,nb) +& - (one-analpertwt)*anal_chunk(:,i,nn,nb) - end do - end do - cycle nbloop -end if +do nn=1,ncdim + do i=1,numptsperproc(nproc+1) + deglat = rad2deg*latsgrd(indxproc(nproc+1,i)) + ! coefficent can be different in NH, TR, SH. + analpertwt_rtpp = & + latval(deglat,analpertwtnh_rtpp,analpertwttr_rtpp,analpertwtsh_rtpp) + anal_chunk(:,i,nn,nb) = analpertwt_rtpp*anal_chunk_prior(:,i,nn,nb) +& + (one-analpertwt_rtpp)*anal_chunk(:,i,nn,nb) + end do +end do +end do nbloop ! end loop over time levels in background +endif + +! if no RTPS inflation desired, return +if (abs(analpertwtnh) < 1.e-5_r_single .and. & + abs(analpertwttr) < 1.e-5_r_single .and. & + abs(analpertwtsh) < 1.e-5_r_single) return + +if (nproc .eq. 0) print *,'performing RTPS inflation...' + +! now perform RTPS inflation +nbloop2: do nb=1,nbackgrounds ! loop over time levels in background ! adaptive posterior inflation based upon ratio of posterior to prior spread. -allocate(tmp_chunk2(npts_max,ndim)) +allocate(tmp_chunk2(npts_max,ncdim)) tmp_chunk2 = covinflatemin ! compute inflation. @@ -120,8 +148,9 @@ subroutine inflate_ens() sumcoslat = zero sprdmax = -9.9e31_r_single sprdmin = 9.9e31_r_single +ps_ind = getindex(cvars2d, 'ps') ! Ps (2D) -do nn=1,ndim +do nn=1,ncdim do i=1,numptsperproc(nproc+1) deglat = rad2deg*latsgrd(indxproc(nproc+1,i)) @@ -139,7 +168,7 @@ subroutine inflate_ens() ! area mean surface pressure posterior and prior spread. ! (this diagnostic only makes sense for grids that are regular in longitude) - if (nn == ndim) then + if (ps_ind > 0 .and. nn == clevels(nc3d) + ps_ind) then coslat=cos(latsgrd(indxproc(nproc+1,i))) if (fsprd > sprdmax) sprdmax = fsprd if (fsprd < sprdmin) sprdmin = fsprd @@ -164,6 +193,20 @@ subroutine inflate_ens() fsprd = max(fsprd,tiny(fsprd)) tmp_chunk2(i,nn) = analpertwt*((fsprd-asprd)/asprd) + 1.0 + if ( nn == ncdim ) then + nnlvl=nlevs_pres + else + nnlvl=nn - nn/nlevs*nlevs + end if + if( nnlvl == 0 ) nnlvl = nlevs + + r=abs((logp(indxproc(nproc+1,i),nnlvl)-logp(indxproc(nproc+1,i),nlevs_pres))/lnsigcovinfcutoff) + if ( r > 0.75_r_single ) then + r=1.0_r_single + endif + + tmp_chunk2(i,nn) = tmp_chunk2(i,nn) + & + taper(r)*latval(deglat,covinflatenh,covinflatetr,covinflatesh) ! min/max inflation set by covinflatemin/covinflatemax. tmp_chunk2(i,nn) = max(covinflatemin,min(tmp_chunk2(i,nn),covinflatemax)) @@ -175,13 +218,13 @@ subroutine inflate_ens() if (smoothparm .gt. zero) then ! inflation smoothing. ! (warning: this requires a lot of memory) - allocate(covinfglobal(npts,ndim)) + allocate(covinfglobal(npts,ncdim)) covinfglobal=zero do i=1,numptsperproc(nproc+1) covinfglobal(indxproc(nproc+1,i),:) = tmp_chunk2(i,:) end do - !call mpi_allreduce(mpi_in_place,covinfglobal,npts*ndim,mpi_real4,mpi_sum,mpi_comm_world,ierr) - do nn=1,ndim + !call mpi_allreduce(mpi_in_place,covinfglobal,npts*ncdim,mpi_real4,mpi_sum,mpi_comm_world,ierr) + do nn=1,ncdim call mpi_allreduce(mpi_in_place,covinfglobal(1,nn),npts,mpi_real4,mpi_sum,mpi_comm_world,ierr) enddo call smooth(covinfglobal) @@ -191,33 +234,31 @@ subroutine inflate_ens() tmp_chunk2(i,:) = covinfglobal(indxproc(nproc+1,i),:) end do if(nproc == 0)then - print *,'min/max var 1 inflation = ',minval(covinfglobal(:,1:nlevs)),maxval(covinfglobal(:,1:nlevs)) - print *,'min/max var 2 inflation = ',minval(covinfglobal(:,nlevs+1:2*nlevs)),maxval(covinfglobal(:,nlevs+1:2*nlevs)) - print *,'min/max var 3 inflation = ',minval(covinfglobal(:,2*nlevs+1:3*nlevs)),maxval(covinfglobal(:,2*nlevs+1:3*nlevs)) - if (nvarhumid .gt. 0) then - print *,'min/max spfh inflation = ',minval(covinfglobal(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs)),& - maxval(covinfglobal(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs)) - endif - print *,'min/max ps inflation = ',minval(covinfglobal(:,ndim)),maxval(covinfglobal(:,ndim)) + do i=1,nc3d + print *,'min/max ',cvars3d(i),' inflation = ',minval(covinfglobal(:,(i-1)*nlevs+1:i*nlevs)),maxval(covinfglobal(:,(i-1)*nlevs+1:i*nlevs)) + enddo + do i=1,nc2d + print *,'min/max ',cvars2d(i),' inflation = ',minval(covinfglobal(:,nc3d*nlevs+i)),maxval(covinfglobal(:,nc3d*nlevs+i)) + enddo ! write out inflation. if (save_inflation) then - open(iunit,form='unformatted',file=filename,access='direct',recl=npts*ndim*4) + open(iunit,form='unformatted',file=filename,access='direct',recl=npts*ncdim*4) write(iunit,rec=1) covinfglobal close(iunit) endif end if deallocate(covinfglobal) else if (save_inflation) then - allocate(covinfglobal(npts,ndim)) + allocate(covinfglobal(npts,ncdim)) covinfglobal=zero do i=1,numptsperproc(nproc+1) covinfglobal(indxproc(nproc+1,i),:) = tmp_chunk2(i,:) end do - do nn=1,ndim + do nn=1,ncdim call mpi_allreduce(mpi_in_place,covinfglobal(1,nn),npts,mpi_real4,mpi_sum,mpi_comm_world,ierr) enddo if (nproc == 0) then - open(iunit,form='unformatted',file=filename,access='direct',recl=npts*ndim*4) + open(iunit,form='unformatted',file=filename,access='direct',recl=npts*ncdim*4) write(iunit,rec=1) covinfglobal close(iunit) deallocate(covinfglobal) @@ -228,7 +269,7 @@ subroutine inflate_ens() sumi = zero ! apply inflation. -do nn=1,ndim +do nn=1,ncdim do i=1,numptsperproc(nproc+1) ! inflate posterior perturbations. @@ -236,7 +277,7 @@ subroutine inflate_ens() ! area mean surface pressure posterior spread, inflation. ! (this diagnostic only makes sense for grids that are regular in longitude) - if (nn == ndim) then + if (ps_ind > 0 .and. nn == clevels(nc3d) + ps_ind) then coslat=cos(latsgrd(indxproc(nproc+1,i))) deglat = rad2deg*latsgrd(indxproc(nproc+1,i)) if (deglat > latbound) then @@ -267,29 +308,13 @@ subroutine inflate_ens() call mpi_reduce(suma,sumatot,ndiag,mpi_real4,mpi_sum,0,mpi_comm_world,ierr) call mpi_reduce(suma2,suma2tot,ndiag,mpi_real4,mpi_sum,0,mpi_comm_world,ierr) call mpi_reduce(sumcoslat,sumcoslattot,ndiag,mpi_real4,mpi_sum,0,mpi_comm_world,ierr) -if (nproc == 0) then - do i=1,ndiag - if (sumcoslattot(i) .gt. 1.E-6 .and. sumftot(i) .gt. 1.E-6) then - sumftot(i) = sqrt(sumftot(i)/sumcoslattot(i)) - else - sumftot(i)=-99.0 - endif - if (sumcoslattot(i) .gt. 1.E-6 .and. sumatot(i) .gt. 1.E-6) then - sumatot(i) = sqrt(sumatot(i)/sumcoslattot(i)) - else - sumatot(i)=-99.0 - endif - if (sumcoslattot(i) .gt. 1.E-6 .and. suma2tot(i) .gt. 1.E-6) then - suma2tot(i) = sqrt(suma2tot(i)/sumcoslattot(i)) - else - suma2tot(i)=-99.0 - endif - if (sumcoslattot(i) .gt. 1.E-6 .and. sumitot(i) .gt. 1.E-6) then - sumitot(i) = sumitot(i)/sumcoslattot(i) - else - sumitot(i)=-99.0 - endif - end do +if (nproc == 0 .and. ps_ind > 0) then + print *,'inflation stats, time level: ',nb + print *,'---------------------------------' + sumftot = sqrt(sumftot/sumcoslattot) + sumatot = sqrt(sumatot/sumcoslattot) + suma2tot = sqrt(suma2tot/sumcoslattot) + sumitot = sumitot/sumcoslattot print *,'global ps prior std. dev min/max = ',sqrt(sprdminall),sqrt(sprdmaxall) ! NH first. if (sumcoslattot(1) .gt. tiny(sumcoslattot(1))) then @@ -315,7 +340,7 @@ subroutine inflate_ens() endif end if -end do nbloop ! end loop over time levels in background +end do nbloop2 ! end loop over time levels in background end subroutine inflate_ens diff --git a/src/enkf/innovstats.f90 b/src/enkf/innovstats.f90 index 8b4ce19f2..e865484b6 100644 --- a/src/enkf/innovstats.f90 +++ b/src/enkf/innovstats.f90 @@ -44,6 +44,8 @@ subroutine print_innovstats(obfit,obsprd) nobspw_nh,nobspw_sh,nobspw_tr,& nobsspd_nh,nobsspd_sh,nobsspd_tr,& nobsgps_nh,nobsgps_sh,nobsgps_tr,& + nobsdbz_nh,nobsdbz_sh,nobsdbz_tr,& + nobsrw_nh,nobsrw_sh,nobsrw_tr,& nobsq_nh,nobsq_sh,nobsq_tr,nobswnd_nh,nobswnd_sh,nobswnd_tr,& nobsoz_nh,nobsoz_sh,nobsoz_tr,nobsps_sh,nobsps_nh,nobsps_tr,nob real(r_single) sumps_nh,biasps_nh,sumps_sh,biasps_sh,& @@ -62,6 +64,12 @@ subroutine print_innovstats(obfit,obsprd) sumgps_nh,biasgps_nh,sumgps_spread_nh,sumgps_oberr_nh,& sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,& sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,& + sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,& + sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,& + sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,& + sumrw_nh,biasrw_nh,sumrw_spread_nh,sumrw_oberr_nh,& + sumrw_sh,biasrw_sh,sumrw_spread_sh,sumrw_oberr_sh,& + sumrw_tr,biasrw_tr,sumrw_spread_tr,sumrw_oberr_tr,& sumpw_nh,biaspw_nh,sumpw_spread_nh,sumpw_oberr_nh,& sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,& sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,& @@ -101,6 +109,12 @@ subroutine print_innovstats(obfit,obsprd) nobsgps_nh = 0 nobsgps_sh = 0 nobsgps_tr = 0 + nobsdbz_nh = 0 + nobsdbz_sh = 0 + nobsdbz_tr = 0 + nobsrw_nh = 0 + nobsrw_sh = 0 + nobsrw_tr = 0 nobsspd_nh = 0 nobsspd_sh = 0 nobsspd_tr = 0 @@ -148,6 +162,18 @@ subroutine print_innovstats(obfit,obsprd) sumgps_nh,biasgps_nh,sumgps_spread_nh,sumgps_oberr_nh,nobsgps_nh,& sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,nobsgps_sh,& sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,nobsgps_tr) + else if (obtype(nob)(1:3) == 'dbz') then + call obstats(obfit(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,& + sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,nobsdbz_sh,& + sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,nobsdbz_tr) + else if (obtype(nob)(1:3) == ' rw') then + call obstats(obfit(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumrw_nh,biasrw_nh,sumrw_spread_nh,sumrw_oberr_nh,nobsrw_nh,& + sumrw_sh,biasrw_sh,sumrw_spread_sh,sumrw_oberr_sh,nobsrw_sh,& + sumrw_tr,biasrw_tr,sumrw_spread_tr,sumrw_oberr_tr,nobsrw_tr) else if (obtype(nob)(1:3) == ' pw') then call obstats(obfit(nob),oberrvar_orig(nob),& obsprd(nob),obloclat(nob),& @@ -187,6 +213,12 @@ subroutine print_innovstats(obfit,obsprd) call printstats(' all gps',sumgps_nh,biasq_nh,sumgps_spread_nh,sumgps_oberr_nh,nobsgps_nh,& sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,nobsgps_sh,& sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,nobsgps_tr) + call printstats(' all dbz',sumdbz_nh,biasq_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,& + sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,nobsdbz_sh,& + sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,nobsdbz_tr) + call printstats(' all rw',sumrw_nh,biasq_nh,sumrw_spread_nh,sumrw_oberr_nh,nobsrw_nh,& + sumrw_sh,biasrw_sh,sumrw_spread_sh,sumrw_oberr_sh,nobsrw_sh,& + sumrw_tr,biasrw_tr,sumrw_spread_tr,sumrw_oberr_tr,nobsrw_tr) call printstats(' sbuv2 oz',sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,nobsoz_nh,& sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,nobsoz_sh,& sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,nobsoz_tr) diff --git a/src/enkf/letkf.F90 b/src/enkf/letkf.F90 index 1b4c2170c..0689409d3 100644 --- a/src/enkf/letkf.F90 +++ b/src/enkf/letkf.F90 @@ -8,22 +8,8 @@ module letkf ! updates, optimizations by whitaker ! ! abstract: Updates the model state using the LETKF (Hunt et al 2007, -! Physica D, 112-126). -! -! After the observation variables are updated, the bias coefficients update is done -! using update_biascorr from module radbias. This update is done via a -! matrix inversion using all the observations at once, and a static (diagonal) -! background error covariance matrix. If the namelist parameter numiter is > -! 1, this process is repeated numiter times, with each observation variable update using -! the latest estimate of the bias correction coefficients and each bias -! coefficient update using the latest estimate of the observation increment -! (observation minus ensemble mean observation variable). The model state -! variables are only updated after the last iteration. After the update is -! complete, the variables anal_chunk and ensmean_chunk (from module statevec) -! contain the updated model state ensemble perturbations and ensemble mean, -! and predx (from module radinfo) contains the updated bias coefficients. -! obfit_post and obsprd_post contain the observation increments and observation -! variable variance. +! Physica D, 112-126). Uses 'gain form' of LETKF algorithm described +! Bishop et al 2017 (https://doi.org/10.1175/MWR-D-17-0102.1). ! ! Covariance localization is used in the state update to limit the impact ! of observations to a specified distance from the observation in the @@ -44,15 +30,29 @@ module letkf ! operator calcuation, is performed by a separate program using the GSI ! forward operator code). Although all the observation variable ensemble ! members sometimes cannot fit in memory, they are necessary before LETKF core -! process. So they are saved in all processors. +! process. So they are saved in all processors. If the code is compiled with +! -DMPI3, a single copy of the observation space ensemble is stored on each +! compute node and shared among processors. +! +! The parameter nobsl_max controls +! the maximum number of obs that will be assimilated in each local patch. +! (the nobsl_max closest are chosen by default, if dfs_sort=T then they +! are ranked by decreasing DFS) +! nobsl_max=-1 (default) means all obs used. ! -! Adaptive observation thinning implemented in the serial EnSRF is not -! implemented here in the current version. +! Vertical covariance localization can be turned off with letkf_novlocal. +! (this is done automatically when model space vertical localization +! with modulated ensembles is enabled via neigv>0) +! If neigv > 0 the eigenvectors of the localization +! matrix are read from a file called 'vlocal_eig.dat' (created by an external +! python utility). +! +! Updating the state in observation space is not supported in the LETKF - +! use lupd_obspace_serial=.true. to perform the observation space update +! using the serial EnSRF. ! ! Public Subroutines: -! letkf_update: performs the LETKF update (calls update_biascorr to perform -! the bias coefficient update). The EnKF/bias coefficient update is -! iterated numiter times (parameter numiter from module params). +! letkf_update: performs the LETKF update ! ! Public Variables: None ! @@ -62,15 +62,24 @@ module letkf ! program history log: ! 2011-06-01 ota: Created from Whitaker's serial EnSRF core module. ! 2015-07-25 whitaker: Optimization for case when no vertical localization -! is used. Allow for numiter=0 (skip ob space update). Fixed -! missing openmp private declarations in obsloop and grdloop. +! is used. Fixed missing openmp private declarations in obsloop and grdloop. ! Use openmp reductions for profiling openmp loops. Use kdtree ! for range search instead of original box routine. Modify ! ob space update to use weights computed at nearest grid point. ! 2016-02-01 whitaker: Use MPI-3 shared memory pointers to reduce memory -! footprint by only allocated observation prior ensemble +! footprint by only allocating observation prior ensemble ! array on one MPI task per node. Also ensure posterior ! perturbation mean is zero. +! 2016-05-02 shlyaeva: Modification for reading state vector from table. +! 2016-07-05 whitaker: remove buggy code for observation space update. +! Rely on serial EnSRF to perform observation space update +! using logical lupd_obspace_serial. +! 2016-11-29 shlyaeva: Modification for using control vector (control and +! state used to be the same) and the "chunks" come from loadbal +! 2018-05-31 whitaker: add modulated ensemble model-space vertical +! localization (when neigv>0) and ob selection using DFS +! (when dfs_sort=T). Add options for DEnKF and gain form of LETKF. + ! ! attributes: ! language: f95 @@ -78,32 +87,33 @@ module letkf !$$$ use mpisetup -use random_normal, only : rnorm, set_random_seed use, intrinsic :: iso_c_binding -use omp_lib, only: omp_get_num_threads +use omp_lib, only: omp_get_num_threads,omp_get_thread_num use covlocal, only: taper, latval use kinds, only: r_double,i_kind,r_kind,r_single,num_bytes_for_r_single use loadbal, only: numptsperproc, npts_max, & indxproc, lnp_chunk, & - grdloc_chunk, kdtree_obs2 -use statevec, only: ensmean_chunk, anal_chunk + grdloc_chunk, kdtree_obs2, & + ensmean_chunk, anal_chunk +use controlvec, only: ncdim, index_pres use enkf_obsmod, only: oberrvar, ob, ensmean_ob, obloc, oblnp, & nobstot, nobs_conv, nobs_oz, nobs_sat,& obfit_prior, obfit_post, obsprd_prior, obsprd_post,& - numobspersat, deltapredx, biaspreds, corrlengthsq,& - biasprednorm, probgrosserr, prpgerr, obtype, obpress,& - lnsigl, anal_ob, obloclat, obloclon, stattype + numobspersat, biaspreds, corrlengthsq,& + probgrosserr, prpgerr, obtype, obpress,& + lnsigl, anal_ob, anal_ob_modens, obloclat, obloclon, stattype use constants, only: pi, one, zero, rad2deg, deg2rad -use params, only: sprd_tol, ndim, datapath, nanals, iseed_perturbed_obs,& - iassim_order,sortinc,deterministic,numiter,nlevs,nvars,& +use params, only: sprd_tol, datapath, nanals, iseed_perturbed_obs,& + iassim_order,sortinc,deterministic,nlevs,& zhuberleft,zhuberright,varqc,lupd_satbiasc,huber,letkf_novlocal,& lupd_obspace_serial,corrlengthnh,corrlengthtr,corrlengthsh,& - nbackgrounds,nobsl_max -use radinfo, only: npred,nusis,nuchan,jpch_rad,predx -use radbias, only: apply_biascorr, update_biascorr -use gridinfo, only: nlevs_pres,index_pres,lonsgrd,latsgrd,logp,npts,gridloc + getkf,getkf_inflation,denkf,nbackgrounds,nobsl_max,& + neigv,vlocal_evecs,dfs_sort +use gridinfo, only: nlevs_pres,lonsgrd,latsgrd,logp,npts,gridloc use kdtree2_module, only: kdtree2, kdtree2_create, kdtree2_destroy, & kdtree2_result, kdtree2_n_nearest, kdtree2_r_nearest +use sorting, only: quicksort +use radbias, only: apply_biascorr implicit none @@ -117,73 +127,69 @@ subroutine letkf_update() ! LETKF update. ! local variables. -integer(i_kind) nob,nf,n1,n2,ideln,nanal,& - niter,i,j,n,nrej,npt,nn,nnmax,ierr +integer(i_kind) nob,nf,nanal,nens,& + i,nlev,nrej,npt,nn,nnmax,ierr integer(i_kind) nobsl, ngrd1, nobsl2, nthreads, nb, & nobslocal_min,nobslocal_max, & nobslocal_minall,nobslocal_maxall -integer(i_kind),allocatable,dimension(:) :: oindex,numobsperpt,oblev -integer(i_kind),allocatable,dimension(:,:) :: indxob_pt -real(r_single) :: deglat, dist, corrsq +integer(i_kind),allocatable,dimension(:) :: oindex +real(r_single) :: deglat, dist, corrsq, oberrfact, trpa, trpa_raw real(r_double) :: t1,t2,t3,t4,t5,tbegin,tend,tmin,tmax,tmean -real(r_kind) r_nanals,r_nanalsm1,r_scalefact +real(r_kind) r_nanals,r_nanalsm1 real(r_kind) normdepart, pnge, width real(r_kind),dimension(nobstot):: oberrvaruse -real(r_kind) oblnp_indx(1) -real(r_kind) logp_tmp(nlevs) real(r_kind) vdist real(r_kind) corrlength -real(r_kind) sqrtoberr -logical lastiter, vlocal, update_obspace +logical vlocal, kdobs ! For LETKF core processes real(r_kind),allocatable,dimension(:,:) :: hxens -real(r_single),allocatable,dimension(:,:) :: obperts,obens -real(r_single),allocatable,dimension(:) :: kfgain -real(r_kind),allocatable,dimension(:) :: rdiag,dep,rloc -real(r_kind),dimension(nanals,nanals) :: trans -real(r_kind),dimension(nanals) :: work,work2 +real(r_single),allocatable,dimension(:,:) :: obens +real(r_single),allocatable,dimension(:,:,:) :: ens_tmp +real(r_single),allocatable,dimension(:,:) :: wts_ensperts,pa +real(r_single),allocatable,dimension(:) :: dfs,wts_ensmean +real(r_kind),allocatable,dimension(:) :: rdiag,rloc +real(r_single),allocatable,dimension(:) :: dep ! kdtree stuff type(kdtree2_result),dimension(:),allocatable :: sresults -type(kdtree2), pointer :: kdtree_grid +integer(i_kind), dimension(:), allocatable :: indxassim, indxob #ifdef MPI3 ! pointers used for MPI-3 shared memory manipulations. real(r_single), pointer, dimension(:,:) :: anal_ob_fp ! Fortran pointer type(c_ptr) :: anal_ob_cp ! C pointer -real(r_single), pointer, dimension(:,:) :: obperts_fp ! Fortran pointer -type(c_ptr) :: obperts_cp ! C pointer +real(r_single), pointer, dimension(:,:) :: anal_ob_modens_fp ! Fortran pointer +type(c_ptr) :: anal_ob_modens_cp ! C pointer integer disp_unit, shm_win, shm_win2 -integer(MPI_ADDRESS_KIND) :: win_size, nsize +integer(MPI_ADDRESS_KIND) :: win_size, nsize, nsize2, win_size2 integer(MPI_ADDRESS_KIND) :: segment_size #endif real(r_single), allocatable, dimension(:) :: buffer +real(r_kind) eps + +eps = epsilon(0.0_r_single) ! real(4) machine precision !$omp parallel nthreads = omp_get_num_threads() !$omp end parallel + if (nproc == 0) print *,'using',nthreads,' openmp threads' ! define a few frequently used parameters r_nanals=one/float(nanals) r_nanalsm1=one/float(nanals-1) -r_scalefact = sqrt(float(nanals)/float(nanals-1)) - -! create random numbers for perturbed obs on root task. -if (.not. deterministic .and. nproc .eq. 0) then - call set_random_seed(iseed_perturbed_obs,nproc) - allocate(obperts(nanals, nobstot)) - do nob=1,nobstot - sqrtoberr=sqrt(oberrvar(nob)) - do nanal=1,nanals - obperts(nanal,nob) = sqrtoberr*rnorm() - enddo - ! make mean/variance are exact. - obperts(1:nanals,nob) = obperts(1:nanals,nob) - & - sum(obperts(:,nob))*r_nanals - obperts(1:nanals,nob) = obperts(1:nanals,nob)*sqrtoberr/(sqrt(sum(obperts(:,nob)**2)*r_nanalsm1)) - enddo + +kdobs=associated(kdtree_obs2) +if (.not. kdobs .and. nproc .eq. 0) then + print *,'using brute-force search instead of kdtree in LETKF' endif t1 = mpi_wtime() + +if (neigv > 0) then + nens = nanals*neigv ! modulated ensemble size +else + nens = nanals +endif + #ifdef MPI3 ! setup shared memory segment on each node that points to ! observation prior ensemble. @@ -191,16 +197,19 @@ subroutine letkf_update() ! shared memory group on each node. disp_unit = num_bytes_for_r_single ! anal_ob is r_single nsize = nobstot*nanals +nsize2 = nobstot*nanals*neigv if (nproc_shm == 0) then win_size = nsize*disp_unit + win_size2 = nsize2*disp_unit else win_size = 0 + win_size2 = 0 endif call MPI_Win_allocate_shared(win_size, disp_unit, MPI_INFO_NULL,& mpi_comm_shmem, anal_ob_cp, shm_win, ierr) -if (.not. deterministic) then - call MPI_Win_allocate_shared(win_size, disp_unit, MPI_INFO_NULL,& - mpi_comm_shmem, obperts_cp, shm_win2, ierr) +if (neigv > 0) then + call MPI_Win_allocate_shared(win_size2, disp_unit, MPI_INFO_NULL,& + mpi_comm_shmem, anal_ob_modens_cp, shm_win2, ierr) endif if (nproc_shm == 0) then ! create shared memory segment on each shared mem comm @@ -217,28 +226,25 @@ subroutine letkf_update() anal_ob_fp(nanal,1:nobstot) = buffer(1:nobstot) end if end do - if (.not. deterministic) then + if (neigv > 0) then call MPI_Win_lock(MPI_LOCK_EXCLUSIVE,0,MPI_MODE_NOCHECK,shm_win2,ierr) - call c_f_pointer(obperts_cp, obperts_fp, [nanals, nobstot]) - do nanal=1,nanals - if (nproc == 0) buffer(1:nobstot) = obperts(nanal,1:nobstot) + call c_f_pointer(anal_ob_modens_cp, anal_ob_modens_fp, [nens, nobstot]) + do nanal=1,nens + if (nproc == 0) buffer(1:nobstot) = anal_ob_modens(nanal,1:nobstot) if (nproc_shm == 0) then call mpi_bcast(buffer,nobstot,mpi_real4,0,mpi_comm_shmemroot,ierr) - obperts_fp(nanal,1:nobstot) = buffer(1:nobstot) + anal_ob_modens_fp(nanal,1:nobstot) = buffer(1:nobstot) end if end do endif deallocate(buffer) call MPI_Win_unlock(0, shm_win, ierr) + if (neigv > 0) call MPI_Win_unlock(0, shm_win2, ierr) nullify(anal_ob_fp) + if (neigv > 0) nullify(anal_ob_modens_fp) ! don't need anal_ob anymore if (allocated(anal_ob)) deallocate(anal_ob) - if (.not. deterministic) then - ! don't need obperts anymore - call MPI_Win_unlock(0, shm_win2, ierr) - nullify(obperts_fp) - if (allocated(obperts)) deallocate(obperts) - endif + if (allocated(anal_ob_modens)) deallocate(anal_ob_modens) endif ! barrier here to make sure no tasks try to access shared ! memory segment before it is created. @@ -247,9 +253,9 @@ subroutine letkf_update() ! segment (containing observation prior ensemble) on each task. call MPI_Win_shared_query(shm_win, 0, segment_size, disp_unit, anal_ob_cp, ierr) call c_f_pointer(anal_ob_cp, anal_ob_fp, [nanals, nobstot]) -if (.not. deterministic) then - call MPI_Win_shared_query(shm_win2, 0, segment_size, disp_unit, obperts_cp, ierr) - call c_f_pointer(obperts_cp, obperts_fp, [nanals, nobstot]) +if (neigv > 0) then + call MPI_Win_shared_query(shm_win2, 0, segment_size, disp_unit, anal_ob_modens_cp, ierr) + call c_f_pointer(anal_ob_modens_cp, anal_ob_modens_fp, [nens, nobstot]) endif #else ! if MPI3 not available, need anal_ob on every MPI task @@ -257,18 +263,18 @@ subroutine letkf_update() allocate(buffer(nobstot)) ! allocate anal_ob on non-root tasks if (nproc .ne. 0) allocate(anal_ob(nanals,nobstot)) +if (neigv > 0 .and. nproc .ne. 0) allocate(anal_ob_modens(nens,nobstot)) ! bcast anal_ob from root one member at a time. do nanal=1,nanals buffer(1:nobstot) = anal_ob(nanal,1:nobstot) call mpi_bcast(buffer,nobstot,mpi_real4,0,mpi_comm_world,ierr) if (nproc .ne. 0) anal_ob(nanal,1:nobstot) = buffer(1:nobstot) end do -if (.not. deterministic) then - if (nproc .ne. 0) allocate(obperts(nanals,nobstot)) - do nanal=1,nanals - buffer(1:nobstot) = obperts(nanal,1:nobstot) +if (neigv > 0) then + do nanal=1,nens + buffer(1:nobstot) = anal_ob_modens(nanal,1:nobstot) call mpi_bcast(buffer,nobstot,mpi_real4,0,mpi_comm_world,ierr) - if (nproc .ne. 0) obperts(nanal,1:nobstot) = buffer(1:nobstot) + if (nproc .ne. 0) anal_ob_modens(nanal,1:nobstot) = buffer(1:nobstot) end do endif deallocate(buffer) @@ -291,114 +297,21 @@ subroutine letkf_update() ! need to be computed for every vertical level. nnmax = nlevs_pres endif -! is observation space update requested (yes if numiter !=0 and not lupd_obspace_serial) -! if so, each ob needs to be assigned to a horizontal grid point index -! and a vertical level index. Analysis weights computed at that grid -! point and level will be used to update for the model state and the -! observation priors. -if (numiter == 0 .or. lupd_obspace_serial) then - update_obspace = .false. - if (nproc == 0) print *,'no observation space update will be done' - numiter = 1 -else - update_obspace = .true. - ! for each ob, find horiz grid point and level it is closest to - !t1 = mpi_wtime() - allocate(sresults(1)) - allocate(oindex(nobstot)) - allocate(oblev(nobstot)) - oindex = 0; oblev = 0 - allocate(numobsperpt(numptsperproc(nproc+1))) - kdtree_grid => kdtree2_create(gridloc,sort=.false.,rearrange=.true.) - if (nobstot > numproc) then - ideln = int(real(nobstot)/real(numproc)) - n1 = 1 + nproc*ideln - n2 = (nproc+1)*ideln - if (nproc == numproc-1) n2 = nobstot - else - if(nproc < nobstot)then - n1 = nproc+1 - n2 = n1 - else - n1=1 - n2=0 - end if - end if - do nob=n1,n2 - call kdtree2_n_nearest(tp=kdtree_grid,qv=obloc(:,nob),nn=1,results=sresults) - oindex(nob) = sresults(1)%idx - if (vlocal) then - ! identify ps and surface obs, assign to level nlevs+1 (for ps) or 1. - if (obtype(nob)(1:3) == ' ps') then - oblev(nob) = nlevs+1 - cycle - else if ((stattype(nob) >= 180 .and. stattype(nob) < 190) .or. & - (stattype(nob) >= 280 .and. stattype(nob) < 290)) then - oblev(nob) = 1 - cycle - endif - ! find vertical level closest to ob pressure at that grid point. - oblnp_indx(1) = oblnp(nob) - if (oblnp_indx(1) <= logp(oindex(nob),1)) then - oblnp_indx(1) = 1 - else if (oblnp_indx(1) >= logp(oindex(nob),nlevs_pres-1)) then - oblnp_indx(1) = nlevs_pres-1 - else - logp_tmp = logp(oindex(nob),1:nlevs_pres-1) - call grdcrd(oblnp_indx,1,logp_tmp,nlevs_pres-1,1) - end if - oblev(nob) = nint(oblnp_indx(1)) - !if (nproc .eq. 0) print *,trim(obtype(nob)),obpress(nob),oblnp_indx(1),oblev(nob),oblnp(nob),logp_tmp(oblev(nob)) - else - oblev(nob) = 1 - endif - enddo - deallocate(sresults) - call mpi_allreduce(mpi_in_place,oindex,nobstot,mpi_integer,mpi_sum,mpi_comm_world,ierr) - call mpi_allreduce(mpi_in_place,oblev,nobstot,mpi_integer,mpi_sum,mpi_comm_world,ierr) - do n=1,numptsperproc(nproc+1) - i = 0 - do j=1,nobstot - if (oindex(j) .eq. indxproc(nproc+1,n)) i=i+1 - enddo - numobsperpt(n) = i - enddo - allocate(indxob_pt(numptsperproc(nproc+1),maxval(numobsperpt))) - do n=1,numptsperproc(nproc+1) - i = 0 - do j=1,nobstot - if (oindex(j) .eq. indxproc(nproc+1,n)) then - i = i + 1 - indxob_pt(n,i) = j - endif - enddo - enddo - deallocate(oindex) - call kdtree2_destroy(kdtree_grid) - !t2 = mpi_wtime() - !if (nproc == 0) print *,'time to set indxob_pt',t2-t1 -endif - -! initialize obfit_post, obsprd_post -if (update_obspace) then - obfit_post(1:nobstot) = obfit_prior(1:nobstot) - obsprd_post(1:nobstot) = obsprd_prior(1:nobstot) +if (nproc == 0 .and. .not. deterministic) then + print *,'warning - perturbed obs not used in LETKF (deterministic=F ignored)' endif -do niter=1,numiter +! apply bias correction with latest estimate of bias coeffs +! (if bias correction update in ob space turned on). +if (nobs_sat > 0 .and. lupd_satbiasc .and. lupd_obspace_serial) call apply_biascorr() - ! update done only in ob space except if niter == lastiter - lastiter = niter == numiter - ! apply bias correction with latest estimate of bias coeffs. - ! (already done for first iteration) - if (nobs_sat > 0 .and. niter > 1) call apply_biascorr() - - ! reset first guess perturbations at start of each iteration. - nrej=0 +nrej=0 ! reset ob error to account for gross errors - if (niter > 1 .and. varqc) then +if (varqc .and. lupd_obspace_serial) then if (huber) then ! "huber norm" QC do nob=1,nobstot + ! observation space update performed in serial filter + ! using lupd_obspace_serial normdepart = obfit_post(nob)/sqrt(oberrvar(nob)) ! depends of 2 parameters: zhuberright, zhuberleft. if (normdepart < -zhuberleft) then @@ -438,478 +351,680 @@ subroutine letkf_update() endif end do endif - else +else oberrvaruse(1:nobstot) = oberrvar(1:nobstot) - end if - - ! initialize obfit_post (zeros except for obs closest - ! to grid points on this task). - if (update_obspace) then - obfit_post = 0.0 - obsprd_post = 0.0 - do npt=1,numptsperproc(nproc+1) - do n=1,numobsperpt(npt) - nob = indxob_pt(npt,n) - obfit_post(nob) = obfit_prior(nob) - obsprd_post(nob) = obsprd_prior(nob) - enddo - enddo - endif - - tbegin = mpi_wtime() - - t2 = zero - t3 = zero - t4 = zero - t5 = zero - tbegin = mpi_wtime() - nobslocal_max = -999 - nobslocal_min = nobstot - - ! Update ensemble on model grid. - ! Loop for each horizontal grid points on this task. - !$omp parallel do schedule(dynamic) private(npt,nob,nobsl, & - !$omp nobsl2,ngrd1,corrlength, & - !$omp nf,vdist,kfgain,obens, & - !$omp nn,hxens,rdiag,dep,rloc,i,work,work2,trans, & - !$omp oindex,deglat,dist,corrsq,nb,sresults) & - !$omp reduction(+:t1,t2,t3,t4,t5) & - !$omp reduction(max:nobslocal_max) & - !$omp reduction(min:nobslocal_min) - grdloop: do npt=1,numptsperproc(nproc+1) - - t1 = mpi_wtime() - - ! find obs close to this grid point (using kdtree) - ngrd1=indxproc(nproc+1,npt) - deglat = latsgrd(ngrd1)*rad2deg - corrlength=latval(deglat,corrlengthnh,corrlengthtr,corrlengthsh) - corrsq = corrlength**2 - ! kd-tree fixed range search - if (nobsl_max > 0) then ! only use nobsl_max nearest obs (sorted by distance). - allocate(sresults(nobsl_max)) - call kdtree2_n_nearest(tp=kdtree_obs2,qv=grdloc_chunk(:,npt),nn=nobsl_max,& - results=sresults) - nobsl = nobsl_max - else ! find all obs within localization radius (sorted by distance). - allocate(sresults(nobstot)) +end if + +tbegin = mpi_wtime() + +t2 = zero +t3 = zero +t4 = zero +t5 = zero +tbegin = mpi_wtime() +nobslocal_max = -999 +nobslocal_min = nobstot + +! Update ensemble on model grid. +! Loop for each horizontal grid points on this task. +!$omp parallel do schedule(dynamic) private(npt,nob,nobsl, & +!$omp nobsl2,oberrfact,ngrd1,corrlength,ens_tmp, & +!$omp nf,vdist,obens,indxassim,indxob, & +!$omp nn,hxens,wts_ensmean,dfs,rdiag,dep,rloc,i, & +!$omp oindex,deglat,dist,corrsq,nb,sresults, & +!$omp wts_ensperts,pa,trpa,trpa_raw) & +!$omp reduction(+:t1,t2,t3,t4,t5) & +!$omp reduction(max:nobslocal_max) & +!$omp reduction(min:nobslocal_min) +grdloop: do npt=1,numptsperproc(nproc+1) + + t1 = mpi_wtime() + if (.not. allocated(ens_tmp)) allocate(ens_tmp(nens,ncdim,nbackgrounds)) + ! find obs close to this grid point (using kdtree) + ngrd1=indxproc(nproc+1,npt) + deglat = latsgrd(ngrd1)*rad2deg + corrlength=latval(deglat,corrlengthnh,corrlengthtr,corrlengthsh) + corrsq = corrlength**2 + allocate(sresults(nobstot)) + do nb=1,nbackgrounds + do i=1,ncdim ! state space ensemble spread for column being updated + nlev = index_pres(i) ! vertical index for i'th control variable + if (nlev .eq. nlevs+1) nlev=1 ! 2d fields, assume surface + if (neigv > 0 ) then + call expand_ens(neigv,nanals, & + anal_chunk(1:nanals,npt,i,nb), & + ens_tmp(:,i,nb),vlocal_evecs(:,nlev)) + else + ens_tmp(:,i,nb) = anal_chunk(:,npt,i,nb) + endif + enddo + enddo + ! kd-tree fixed range search + !if (allocated(sresults)) deallocate(sresults) + if (nobsl_max > 0) then ! only use nobsl_max nearest obs (sorted by distance). + if (dfs_sort) then ! sort by 1-DFS in ob-space instead of distance. + allocate(dfs(nobstot)) + allocate(rloc(nobstot)) + allocate(indxob(nobstot)) + ! calculate integrated 1-DFS for each ob in local volume + nobsl = 0 + do nob=1,nobstot + rloc(nob) = sum((obloc(:,nob)-grdloc_chunk(:,npt))**2,1) + dist = sqrt(rloc(nob)/corrlengthsq(nob)) + if (dist < 1.0 - eps .and. & + oberrvaruse(nob) < 1.e10_r_single) then + nobsl = nobsl + 1 + indxob(nobsl) = nob + oberrfact = taper(dist) + if (lupd_obspace_serial) then + ! use updated ensemble in ob space to estimate DFS + !dfs(nobsl) = obsprd_post(nob)/obsprd_prior(nob) + ! weight by distance to analysis point + dfs(nobsl) = oberrfact*obsprd_post(nob)/obsprd_prior(nob) + else + ! estimate DFS assuming each ob assimilated independently, one + ! at a time. + ! 1-DFS = HP_aH^T/HP_bH^T = R/(HP_bH^T + R) + dfs(nobsl) = (oberrvaruse(nob)/oberrfact)/((oberrvar(nob)/oberrfact)+obsprd_prior(nob)) + endif + endif + enddo + ! sort on 1-DFS + allocate(indxassim(nobsl)) + call quicksort(nobsl,dfs(1:nobsl),indxassim) + nobsl2 = min(nobsl_max,nobsl) + do nob=1,nobsl2 + sresults(nob)%dis = rloc(indxob(indxassim(nob))) + sresults(nob)%idx = indxob(indxassim(nob)) + !if (nproc == 0 .and. npt == 1) & + !print *,nob,sresults(nob)%idx,dfs(indxassim(nob)),sqrt(sresults(nob)%dis/corrlengthsq(sresults(nob)%idx)),obtype(sresults(nob)%idx) + enddo + deallocate(rloc,dfs,indxassim,indxob) + nobsl = nobsl2 + else + if (kdobs) then + call kdtree2_n_nearest(tp=kdtree_obs2,qv=grdloc_chunk(:,npt),nn=nobsl_max,& + results=sresults) + nobsl = nobsl_max + else + ! brute force search + call find_localobs(grdloc_chunk(:,npt),obloc,corrsq,nobstot,nobsl_max,sresults,nobsl) + nobsl_max = nobsl + endif + !if (nproc == 0 .and. npt == 1) then + ! do nob=1,nobsl + ! print *,nob,sresults(nob)%idx,sqrt(sresults(nob)%dis/corrlengthsq(sresults(nob)%idx)),obtype(sresults(nob)%idx) + ! enddo + !endif + endif + else ! find all obs within localization radius (sorted by distance). + if (kdobs) then call kdtree2_r_nearest(tp=kdtree_obs2,qv=grdloc_chunk(:,npt),r2=corrsq,& nfound=nobsl,nalloc=nobstot,results=sresults) - endif - - t2 = t2 + mpi_wtime() - t1 - t1 = mpi_wtime() - - ! Skip when no observations in local area - if(nobsl == 0) cycle grdloop - - ! Loop through vertical levels (nnmax=1 if no vertical localization) - verloop: do nn=1,nnmax - - ! Pick up variables passed to LETKF core process - allocate(rloc(nobsl)) - allocate(oindex(nobsl)) - nobsl2=1 - do nob=1,nobsl - nf = sresults(nob)%idx - ! skip 'screened' obs. - if (oberrvaruse(nf) > 1.e10_r_single) cycle - if (vlocal) then - vdist=(lnp_chunk(npt,nn)-oblnp(nf))/lnsigl(nf) - if(abs(vdist) >= one) cycle - else - vdist = zero - endif - dist = sqrt(sresults(nob)%dis/corrlengthsq(sresults(nob)%idx)+vdist*vdist) - if (dist >= one) cycle - rloc(nobsl2)=taper(dist) - oindex(nobsl2)=nf - if(rloc(nobsl2) > tiny(rloc(nobsl2))) nobsl2=nobsl2+1 - end do - nobsl2=nobsl2-1 - if (nobsl2 > nobslocal_max) nobslocal_max=nobsl2 - if (nobsl2 < nobslocal_min) nobslocal_min=nobsl2 - if(nobsl2 == 0) then - deallocate(rloc,oindex) - cycle verloop - end if - allocate(hxens(nanals,nobsl2)) - allocate(rdiag(nobsl2)) - allocate(dep(nobsl2)) - do nob=1,nobsl2 - nf=oindex(nob) + else + ! brute force search + call find_localobs(grdloc_chunk(:,npt),obloc,corrsq,nobstot,-1,sresults,nobsl) + endif + endif + + t2 = t2 + mpi_wtime() - t1 + t1 = mpi_wtime() + + ! Skip when no observations in local area + if(nobsl == 0) then + if (allocated(sresults)) deallocate(sresults) + if (allocated(ens_tmp)) deallocate(ens_tmp) + cycle grdloop + endif + + ! Loop through vertical levels (nnmax=1 if no vertical localization) + verloop: do nn=1,nnmax + + ! Pick up variables passed to LETKF core process + allocate(rloc(nobsl)) + allocate(oindex(nobsl)) + nobsl2=1 + do nob=1,nobsl + nf = sresults(nob)%idx + ! skip 'screened' obs. + if (oberrvaruse(nf) > 1.e10_r_single) cycle + if (vlocal) then + vdist=(lnp_chunk(npt,nn)-oblnp(nf))/lnsigl(nf) + if(abs(vdist) >= one) cycle + else + vdist = zero + endif + dist = sqrt(sresults(nob)%dis/corrlengthsq(nf)+vdist*vdist) + if (dist >= one) cycle + rloc(nobsl2)=taper(dist) + oindex(nobsl2)=nf + if(rloc(nobsl2) > eps) nobsl2=nobsl2+1 + end do + nobsl2=nobsl2-1 + if (nobsl2 > nobslocal_max) nobslocal_max=nobsl2 + if (nobsl2 < nobslocal_min) nobslocal_min=nobsl2 + if(nobsl2 == 0) then + deallocate(rloc,oindex) + cycle verloop + end if + allocate(hxens(nens,nobsl2)) + allocate(obens(nanals,nobsl2)) + allocate(rdiag(nobsl2)) + allocate(dep(nobsl2)) + do nob=1,nobsl2 + nf=oindex(nob) + if (neigv > 0) then #ifdef MPI3 - hxens(1:nanals,nob)=anal_ob_fp(1:nanals,nf) + hxens(1:nens,nob)=anal_ob_modens_fp(1:nens,nf) #else - hxens(1:nanals,nob)=anal_ob(1:nanals,nf) + hxens(1:nens,nob)=anal_ob_modens(1:nens,nf) #endif - rdiag(nob)=one/oberrvaruse(nf) - dep(nob)=ob(nf)-ensmean_ob(nf) - end do - - t3 = t3 + mpi_wtime() - t1 - t1 = mpi_wtime() - - if (.not. deterministic) then - allocate(kfgain(nobsl2),obens(nobsl2,nanals)) - ! add ob perts to observation priors - do nob=1,nobsl2 - nf = oindex(nob) - obens(nob,1:nanals) = & + else #ifdef MPI3 - obperts_fp(1:nanals,nf) + anal_ob_fp(1:nanals,nf) + hxens(1:nens,nob)=anal_ob_fp(1:nens,nf) #else - obperts(1:nanals,nf) + anal_ob(1:nanals,nf) + hxens(1:nens,nob)=anal_ob(1:nens,nf) #endif - enddo - endif - deallocate(oindex) - - ! Compute transformation matrix of LETKF - call letkf_core(nobsl2,hxens,rdiag,dep,rloc(1:nobsl2),trans) - deallocate(rloc,rdiag) - ! if perturbed obs not used, these arrays no longer needed. - if (deterministic) then - deallocate(hxens,dep) - endif - - - t4 = t4 + mpi_wtime() - t1 - t1 = mpi_wtime() - - ! Update analysis ensembles (all time levels) - if (lastiter) then - do nb=1,nbackgrounds - do i=1,ndim - ! if not vlocal, update all state variables in column. - if(vlocal .and. index_pres(i) /= nn) cycle - if (deterministic) then - work(1:nanals) = anal_chunk(1:nanals,npt,i,nb) - work2(1:nanals) = ensmean_chunk(npt,i,nb) - if(r_kind == kind(1.d0)) then - call dgemv('t',nanals,nanals,1.d0,trans,nanals,work,1,1.d0, & - & work2,1) - else - call sgemv('t',nanals,nanals,1.e0,trans,nanals,work,1,1.e0, & - & work2,1) - end if - ensmean_chunk(npt,i,nb) = sum(work2(1:nanals)) * r_nanals - anal_chunk(1:nanals,npt,i,nb) = work2(1:nanals)-ensmean_chunk(npt,i,nb) - else ! perturbed obs using LETKF gain. - do nob=1,nobsl2 - kfgain(nob) = sum(hxens(:,nob)*anal_chunk(:,npt,i,nb)) - enddo - ensmean_chunk(npt,i,nb) = ensmean_chunk(npt,i,nb) + sum(kfgain*dep) - do nanal=1,nanals - anal_chunk(nanal,npt,i,nb) = anal_chunk(nanal,npt,i,nb) - & - sum(kfgain*obens(:,nanal)) - enddo - endif - enddo - enddo - endif - ! deallocate arrays needed for perturbed obs LETKF - if (.not. deterministic) then - deallocate(hxens,kfgain,dep,obens) - endif - ! Update ob space innov stats (mean and spread) - ! (see eqn 18 in Hunt et al (2007)). - ! numobsperpt(npt=1,npts): number of nearest-neighbor obs for this model - ! grid point (and level). - ! indxob_pt(n=1,numobsperpt(npt)): ob indices associated with this model - ! grid point (and level). - ! obfit_post is what update_biascorr needs (ob - ensmean_ob). - ! also used to modify ob error in nonlinear quality control - if (update_obspace) then - ! Note: perturbed obs LETKF not implemented in ob space - do n=1,numobsperpt(npt) - nob = indxob_pt(npt,n) - ! if not vlocal,nn=oblev==1 - if (oblev(nob) == nn .and. oberrvaruse(nob) <= 1.e10_r_single) then + endif + obens(1:nanals,nob) = & #ifdef MPI3 - work(1:nanals) = anal_ob_fp(1:nanals,nob) + anal_ob_fp(1:nanals,nf) #else - work(1:nanals) = anal_ob(1:nanals,nob) + anal_ob(1:nanals,nf) #endif - work2(1:nanals) = ob(nob) - obfit_post(nob) ! ensmean_ob(nob) - if(r_kind == kind(1.d0)) then - call dgemv('t',nanals,nanals,1.d0,trans,nanals,work,1,1.d0,work2,1) - else - call sgemv('t',nanals,nanals,1.e0,trans,nanals,work,1,1.e0,work2,1) - end if - obfit_post(nob) = ob(nob) - sum(work2(1:nanals)) * r_nanals - ! updated observation prior ensemble, need to remove ens - ! mean - obsprd_post(nob) = sum( (work2(1:nanals) + obfit_post(nob) - ob(nob))**2 )*r_nanalsm1 - endif - enddo - endif - - t5 = t5 + mpi_wtime() - t1 - t1 = mpi_wtime() - - end do verloop - if (allocated(sresults)) deallocate(sresults) - end do grdloop - !$omp end parallel do - - ! make sure posterior perturbations still have zero mean. - ! (roundoff errors can accumulate) - !$omp parallel do schedule(dynamic) private(npt,nb,i) - do npt=1,npts_max - do nb=1,nbackgrounds - do i=1,ndim - anal_chunk(1:nanals,npt,i,nb) = anal_chunk(1:nanals,npt,i,nb)-& - sum(anal_chunk(1:nanals,npt,i,nb),1)*r_nanals - end do - end do - enddo - !$omp end parallel do - - tend = mpi_wtime() - call mpi_reduce(tend-tbegin,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) - tmean = tmean/numproc - call mpi_reduce(tend-tbegin,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) - call mpi_reduce(tend-tbegin,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) - if (nproc .eq. 0) print *,'min/max/mean time to do letkf update ',tmin,tmax,tmean - t2 = t2/nthreads; t3 = t3/nthreads; t4 = t4/nthreads; t5 = t5/nthreads - if (nproc == 0) print *,'time to process analysis on gridpoint = ',t2,t3,t4,t5,' secs on task',nproc - call mpi_reduce(t2,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) - tmean = tmean/numproc - call mpi_reduce(t2,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) - call mpi_reduce(t2,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) - if (nproc .eq. 0) print *,',min/max/mean t2 = ',tmin,tmax,tmean - call mpi_reduce(t3,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) - tmean = tmean/numproc - call mpi_reduce(t3,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) - call mpi_reduce(t3,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) - if (nproc .eq. 0) print *,',min/max/mean t3 = ',tmin,tmax,tmean - call mpi_reduce(t4,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) - tmean = tmean/numproc - call mpi_reduce(t4,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) - call mpi_reduce(t4,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) - if (nproc .eq. 0) print *,',min/max/mean t4 = ',tmin,tmax,tmean - call mpi_reduce(t5,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) - tmean = tmean/numproc - call mpi_reduce(t5,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) - call mpi_reduce(t5,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) - if (nproc .eq. 0) print *,',min/max/mean t5 = ',tmin,tmax,tmean - call mpi_reduce(nobslocal_max,nobslocal_maxall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr) - call mpi_reduce(nobslocal_min,nobslocal_minall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr) - if (nproc == 0) print *,'min/max number of obs in local volume',nobslocal_minall,nobslocal_maxall - if (nrej > 0 .and. nproc == 0) print *, nrej,' obs rejected by varqc' - - ! distribute the O-A stats to all processors. - if (update_obspace) then - call mpi_allreduce(mpi_in_place,obfit_post,nobstot,mpi_real4,mpi_sum,mpi_comm_world,ierr) - call mpi_allreduce(mpi_in_place,obsprd_post,nobstot,mpi_real4,mpi_sum,mpi_comm_world,ierr) - endif + rdiag(nob)=one/oberrvaruse(nf) + dep(nob)=ob(nf)-ensmean_ob(nf) + end do + deallocate(oindex) + t3 = t3 + mpi_wtime() - t1 + t1 = mpi_wtime() - ! satellite bias correction update. - if (update_obspace .and. nobs_sat > 0 .and. lupd_satbiasc) call update_biascorr(niter) + ! use gain form of LETKF (to make modulated ensemble vertical localization + ! possible) + allocate(wts_ensperts(nens,nanals),wts_ensmean(nens)) + ! compute analysis weights for mean and ensemble perturbations given + ! ensemble in observation space, ob departures and ob errors. + ! note: if modelspace_vloc=F, hxens and obens are identical (but hxens is + ! is used as workspace and is modified on output), and analysis + ! weights for ensemble perturbations represent posterior ens perturbations, not + ! analysis increments for ensemble perturbations. + call letkf_core(nobsl2,hxens,obens,dep,& + wts_ensmean,wts_ensperts,pa,& + rdiag,rloc(1:nobsl2),nens,nens/nanals,getkf_inflation,denkf,getkf) -end do ! niter loop + t4 = t4 + mpi_wtime() - t1 + t1 = mpi_wtime() + + ! Update analysis ensembles (all time levels) + ! analysis increments represented as a linear combination + ! of (modulated) prior ensemble perturbations. + do nb=1,nbackgrounds + do i=1,ncdim + ! if not vlocal, update all state variables in column. + if(vlocal .and. index_pres(i) /= nn) cycle + ensmean_chunk(npt,i,nb) = ensmean_chunk(npt,i,nb) + & + sum(wts_ensmean*ens_tmp(:,i,nb)) + if (getkf) then ! gain formulation + do nanal=1,nanals + anal_chunk(nanal,npt,i,nb) = anal_chunk(nanal,npt,i,nb) + & + sum(wts_ensperts(:,nanal)*ens_tmp(:,i,nb)) + enddo + if (.not. denkf .and. getkf_inflation) then + ! inflate posterior perturbations so analysis variance + ! in original low-rank ensemble is the same as modulated ensemble + ! (eqn 30 in https://doi.org/10.1175/MWR-D-17-0102.1) + trpa = 0.0_r_single + do nanal=1,nens + trpa = trpa + & + sum(pa(:,nanal)*ens_tmp(:,i,nb))*ens_tmp(nanal,i,nb) + enddo + trpa = max(eps,trpa) + trpa_raw = max(eps,r_nanalsm1*sum(anal_chunk(:,npt,i,nb)**2)) + anal_chunk(:,npt,i,nb) = sqrt(trpa/trpa_raw)*anal_chunk(:,npt,i,nb) + !if (nproc == 0 .and. omp_get_thread_num() == 0 .and. i .eq. ncdim) print *,'i,trpa,trpa_raw,inflation = ',i,trpa,trpa_raw,sqrt(trpa/trpa_raw) + endif + else ! original LETKF formulation + do nanal=1,nanals + anal_chunk(nanal,npt,i,nb) = & + sum(wts_ensperts(:,nanal)*ens_tmp(:,i,nb)) + enddo + endif + enddo + enddo + deallocate(wts_ensperts,wts_ensmean,dep,obens,rloc,rdiag,hxens) + if (allocated(pa)) deallocate(pa) -if (update_obspace) deallocate(oblev,indxob_pt,numobsperpt) + t5 = t5 + mpi_wtime() - t1 + t1 = mpi_wtime() + end do verloop + + if (allocated(sresults)) deallocate(sresults) + if (allocated(ens_tmp)) deallocate(ens_tmp) +end do grdloop +!$omp end parallel do + +! make sure posterior perturbations still have zero mean. +! (roundoff errors can accumulate) +!$omp parallel do schedule(dynamic) private(npt,nb,i) +do npt=1,npts_max + do nb=1,nbackgrounds + do i=1,ncdim + anal_chunk(1:nanals,npt,i,nb) = anal_chunk(1:nanals,npt,i,nb)-& + sum(anal_chunk(1:nanals,npt,i,nb),1)*r_nanals + end do + end do +enddo +!$omp end parallel do + +tend = mpi_wtime() +call mpi_reduce(tend-tbegin,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) +tmean = tmean/numproc +call mpi_reduce(tend-tbegin,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) +call mpi_reduce(tend-tbegin,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) +if (nproc .eq. 0) print *,'min/max/mean time to do letkf update ',tmin,tmax,tmean +t2 = t2/nthreads; t3 = t3/nthreads; t4 = t4/nthreads; t5 = t5/nthreads +if (nproc == 0) print *,'time to process analysis on gridpoint = ',t2,t3,t4,t5,' secs on task',nproc +call mpi_reduce(t2,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) +tmean = tmean/numproc +call mpi_reduce(t2,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) +call mpi_reduce(t2,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) +if (nproc .eq. 0) print *,',min/max/mean t2 = ',tmin,tmax,tmean +call mpi_reduce(t3,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) +tmean = tmean/numproc +call mpi_reduce(t3,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) +call mpi_reduce(t3,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) +if (nproc .eq. 0) print *,',min/max/mean t3 = ',tmin,tmax,tmean +call mpi_reduce(t4,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) +tmean = tmean/numproc +call mpi_reduce(t4,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) +call mpi_reduce(t4,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) +if (nproc .eq. 0) print *,',min/max/mean t4 = ',tmin,tmax,tmean +call mpi_reduce(t5,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr) +tmean = tmean/numproc +call mpi_reduce(t5,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr) +call mpi_reduce(t5,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr) +if (nproc .eq. 0) print *,',min/max/mean t5 = ',tmin,tmax,tmean +call mpi_reduce(nobslocal_max,nobslocal_maxall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr) +call mpi_reduce(nobslocal_min,nobslocal_minall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr) +if (nproc == 0) print *,'min/max number of obs in local volume',nobslocal_minall,nobslocal_maxall +if (nrej > 0 .and. nproc == 0) print *, nrej,' obs rejected by varqc' + ! free shared memory segement, fortran pointer to that memory. #ifdef MPI3 nullify(anal_ob_fp) call MPI_Win_free(shm_win, ierr) -if (.not. deterministic) then - nullify(obperts_fp) +if (neigv > 0) then + nullify(anal_ob_modens_fp) call MPI_Win_free(shm_win2, ierr) endif #endif ! deallocate anal_ob on non-root tasks. if (nproc .ne. 0 .and. allocated(anal_ob)) deallocate(anal_ob) -if (allocated(obperts)) deallocate(obperts) +if (nproc .ne. 0 .and. allocated(anal_ob_modens)) deallocate(anal_ob_modens) +if (allocated(ens_tmp)) deallocate(ens_tmp) return end subroutine letkf_update -subroutine letkf_core(nobsl,hxens,rdiaginv,dep,rloc,trans) +subroutine letkf_core(nobsl,hxens,hxens_orig,dep,& + wts_ensmean,wts_ensperts,paens,& + rdiaginv,rloc,nanals,neigv,getkf_inflation,denkf,getkf) !$$$ subprogram documentation block ! . . . ! subprogram: letkf_core ! -! prgmmr: ota +! prgmmr: whitaker ! -! abstract: LETKF core subroutine computing transform matrix. BLAS subroutines -! are used for the computational efficiency. +! abstract: LETKF core subroutine. Returns analysis weights +! for ensemble mean update and ensemble perturbation update (increments +! represented as a linear combination of prior ensemble perturbations). +! Uses 'gain form' LETKF, which works when ensemble used to estimate +! covariances not the same as ensemble being updated. If neigv=1 +! (no modulated ensemble model-space localization), then the +! traditional form of the LETKF analysis weights for ensemble +! perturbations are returned (which represents posterior +! ensemble perturbations, not analysis increments, as a linear +! combination of prior ensemble perturbations). ! ! program history log: ! 2011-06-03 ota: created from miyoshi's LETKF core subroutine -! 2014-06-20 whitaker: optimization for case when no vertical localization -! is used. Allow for numiter=0 (skip ob space update). Fixed -! missing openmp private declarations in obsloop and grdloop. -! Use openmp reductions for profiling openmp loops. Use LAPACK -! routine dsyev for eigenanalysis. +! 2014-06-20 whitaker: Use LAPACK routine dsyev for eigenanalysis. ! 2016-02-01 whitaker: Use LAPACK dsyevr for eigenanalysis (faster -! than dsyev in most cases). +! than dsyev in most cases). +! 2018-07-01 whitaker: implement gain form of LETKF from Bishop et al 2017 +! (https://doi.org/10.1175/MWR-D-17-0102.1), allow for use of modulated +! ensemble vert localization (ensemble used to estimate posterior covariance +! in ensemble space different than ensemble being updated). Add denkf, +! getkf,getkf_inflation options. ! ! input argument list: ! nobsl - number of observations in the local patch -! hxens - first-guess ensembles on observation space +! hxens - on input: first-guess modulated ensemble in observation space (Yb) +! on output: overwritten with Yb * R**-1. +! hxens_orig - first-guess original ensembles in observation space. +! not used if neigv=1. +! dep - nobsl observation departures (y-Hxmean) ! rdiaginv - inverse of diagonal element of observation error covariance -! dep - observation departure from first guess mean -! rloc - localization function to each observations +! rloc - localization function for each ob (based on distance to +! analysis point) +! nanals - number of ensemble members (1st dimension of hxens) +! neigv - for modulated ensemble model-space localization, number +! of eigenvectors of vertical localization (1 if not using +! model space localization). 1st dimension of hxens_orig is +! nanals/neigv. +! getkf_inflation - if true (and getkf=T,denkf=F), +! return posterior covariance matrix in +! needed to compute getkf inflation (eqn 30 in Bishop et al +! 2017). +! denkf - if true, use DEnKF approximation (implies getkf=T) +! See Sakov and Oke 2008 https://doi.org/10.1111/j.1600-0870.2007.00299.x +! getkf - if true, use gain formulation ! ! output argument list: -! trans - transform matrix for this point. -! On output, hxens is over-written -! with matrix that can be used to compute Kalman Gain. +! +! wts_ensmean - Factor used to compute ens mean analysis increment +! by pre-multiplying with +! model space ensemble perts. In notation from Bishop et al 2017, +! wts_ensmean = C (Gamma + I)**-1 C^T (HZ)^ T R**-1/2 (y - Hxmean) +! where HZ^T = Yb*R**-1/2 (YbRinvsqrt), +! C are eigenvectors of (HZ)^T HZ and Gamma are eigenvalues +! Has dimension (nanals) - increment is weighted average of ens +! perts, wts_ensmean are weights. +! +! wts_ensperts - if getkf=T same as above, but for computing increments to +! ensemble perturbations. From Bishop et al 2017 eqn 29 +! wts_ensperts = -C [ (I - (Gamma+I)**-1/2)*Gamma**-1 ] C^T (HZ)^T R**-1/2 Hxprime +! Has dimension (nanals,nanals/neigv), analysis weights for each +! member. Hxprime (hxens_orig) is the original, unmodulated +! ensemble in observation space, HZ is the modulated ensemble in +! ob space times R**-1/2. If denkf=T, wts_ensperts is approximated +! as wts_ensperts = -0.5*C (Gamma + I)**-1 C^T (HZ)^ T R**-1/2 Hxprime +! If getkf=F and denkf=F, then the original LETKF formulation is used with +! wts_ensperts = +! C (Gamma + I)**-1/2 C^T (square root of analysis error cov in ensemble space) +! and these weights are applied to transform the background ensemble into an +! analysis ensemble. Note that modulated ensemble vertical localization +! requires the gain form (getkf=T and/or denkf=T) since this form of the weights +! requires that the background ensemble used to compute covariances is +! the same ensemble being updated. +! +! paens - only allocated and returned +! if getkf_inflation=T (and denkf=F). In this case +! paens is allocated dimension (nanals,nanals) and contains posterior +! covariance matrix in (modulated) ensemble space. ! ! attributes: ! language: f95 ! machine: ! !$$$ end documentation block + implicit none -integer(i_kind) ,intent(in ) :: nobsl -real(r_kind),dimension(nanals,nobsl ),intent(inout) :: hxens -real(r_kind),dimension(nobsl ),intent(in ) :: rdiaginv -real(r_kind),dimension(nobsl ),intent(in ) :: dep -real(r_kind),dimension(nobsl ),intent(in ) :: rloc -real(r_kind),dimension(nanals,nanals),intent(out) :: trans -real(r_kind), allocatable, dimension(:,:) :: work1,work2,eivec,pa -real(r_kind), allocatable, dimension(:) :: rrloc,eival,work3 -real(r_kind) :: rho -integer(i_kind) :: i,j,nob,nanal,ierr -!integer(i_kind) :: lwork -!for dsyevr -integer(i_kind) iwork(10*nanals),isuppz(2*nanals) -real(r_kind) vl,vu,work(70*nanals) -!for dsyevd -!integer(i_kind) iwork(5*nanals+3) -!real(r_kind) work(2*nanals*nanals+6*nanals+1) -allocate(work3(nanals),work2(nanals,nobsl)) -allocate(eivec(nanals,nanals),pa(nanals,nanals)) -allocate(work1(nanals,nanals),eival(nanals),rrloc(nobsl)) -! hxens sqrt(Rinv) -rrloc(1:nobsl) = rdiaginv(1:nobsl) * rloc(1:nobsl) -rho = tiny(rrloc) -where (rrloc < rho) rrloc = rho +integer(i_kind), intent(in) :: nobsl,nanals,neigv +real(r_kind),dimension(nobsl),intent(in ) :: rdiaginv,rloc +real(r_kind),dimension(nanals,nobsl),intent(inout) :: hxens +real(r_single),dimension(nanals/neigv,nobsl),intent(in) :: hxens_orig +real(r_single),dimension(nobsl),intent(in) :: dep +real(r_single),dimension(nanals),intent(out) :: wts_ensmean +real(r_single),dimension(nanals,nanals/neigv),intent(out) :: wts_ensperts +real(r_single),dimension(:,:),allocatable, intent(inout) :: paens +! local variables. +real(r_kind),allocatable,dimension(:,:) :: work3,evecs +real(r_single),allocatable,dimension(:,:) :: swork2,pa,swork3,shxens +real(r_single),allocatable,dimension(:) :: swork1 +real(r_kind),allocatable,dimension(:) :: rrloc,evals,gammapI,gamma_inv +real(r_kind) eps +integer(i_kind) :: nanal,ierr,lwork,liwork +!for LAPACK dsyevr +integer(i_kind) isuppz(2*nanals) +real(r_kind) vl,vu,normfact +integer(i_kind), allocatable, dimension(:) :: iwork +real(r_kind), dimension(:), allocatable :: work1 +logical, intent(in) :: getkf_inflation,denkf,getkf + +if (neigv < 1) then + print *,'neigv must be >=1 in letkf_core' + call stop2(992) +endif + +allocate(work3(nanals,nanals),evecs(nanals,nanals)) +allocate(rrloc(nobsl),gammapI(nanals),evals(nanals),gamma_inv(nanals)) +! for dsyevr +allocate(iwork(10*nanals),work1(70*nanals)) +! for dsyevd +!allocate(iwork(3+5*nanals),work1(1+6*nanals+2*nanals*nanals)) + +! HZ^T = hxens sqrt(Rinv) +rrloc = rdiaginv * rloc +eps = epsilon(0.0_r_single) +where (rrloc < eps) rrloc = eps rrloc = sqrt(rrloc) +normfact = sqrt(real((nanals/neigv)-1,r_kind)) +! normalize so dot product is covariance do nanal=1,nanals - hxens(nanal,1:nobsl) = hxens(nanal,1:nobsl) * rrloc(1:nobsl) + hxens(nanal,1:nobsl) = hxens(nanal,1:nobsl) * & + rrloc(1:nobsl)/normfact end do -! hxens^T Rinv hxens -!do j=1,nanals -! do i=1,nanals -! work1(i,j) = hxens(i,1) * hxens(j,1) -! do nob=2,nobsl -! work1(i,j) = work1(i,j) + hxens(i,nob) * hxens(j,nob) -! end do -! end do -!end do -if(r_kind == kind(1.d0)) then + +! compute eigenvectors/eigenvalues of HZ^T HZ (left SV) +! (in Bishop paper HZ is nobsl, nanals, here is it nanals, nobsl) +lwork = size(work1); liwork = size(iwork) +if(r_kind == kind(1.d0)) then ! double precision + !work3 = matmul(hxens,transpose(hxens)) call dgemm('n','t',nanals,nanals,nobsl,1.d0,hxens,nanals, & - hxens,nanals,0.d0,work1,nanals) -else + hxens,nanals,0.d0,work3,nanals) + ! evecs contains eigenvectors of HZ^T HZ, or left singular vectors of HZ + ! evals contains eigenvalues (singular values squared) + call dsyevr('V','A','L',nanals,work3,nanals,vl,vu,1,nanals,-1.d0,nanals,evals,evecs, & + nanals,isuppz,work1,lwork,iwork,liwork,ierr) +! use LAPACK dsyevd instead of dsyevr + !evecs = work3 + !call dsyevd('V','L',nanals,evecs,nanals,evals,work1,lwork,iwork,liwork,ierr) +else ! single precision call sgemm('n','t',nanals,nanals,nobsl,1.e0,hxens,nanals, & - hxens,nanals,0.e0,work1,nanals) + hxens,nanals,0.e0,work3,nanals) + call ssyevr('V','A','L',nanals,work3,nanals,vl,vu,1,nanals,-1.e0,nanals,evals,evecs, & + nanals,isuppz,work1,lwork,iwork,liwork,ierr) +! use LAPACK dsyevd instead of dsyevr + !evecs = work3 + !call ssyevd('V','L',nanals,evecs,nanals,evals,work1,lwork,iwork,liwork,ierr) end if -! hdxb^T Rinv hdxb + (m-1) I -do nanal=1,nanals - work1(nanal,nanal) = work1(nanal,nanal) + real(nanals-1,r_kind) -end do -! eigenvalues and eigenvectors of [ hdxb^T Rinv hdxb + (m-1) I ] -! use LAPACK dsyev -!eivec(:,:) = work1(:,:); lwork = -1 -!call dsyev('V','L',nanals,eivec,nanals,eival,work1(1,1),lwork,ierr) -!lwork = min(nanals*nanals, int(work1(1,1))) -!call dsyev('V','L',nanals,eivec,nanals,eival,work1(1,1),lwork,ierr) -! use LAPACK dsyevd -!call dsyevd('V','L',nanals,eivec,nanals,eival,work,size(work),iwork,size(iwork),ierr) -! use LAPACK dsyevr -call dsyevr('V','A','L',nanals,work1,nanals,vl,vu,1,nanals,-1.d0,nanals,eival,eivec, & - nanals,isuppz,work,size(work),iwork,size(iwork),ierr) if (ierr .ne. 0) print *,'warning: dsyev* failed, ierr=',ierr -! Pa = [ hdxb^T Rinv hdxb + (m-1) I ]inv -do j=1,nanals - do i=1,nanals - work1(i,j) = eivec(i,j) / eival(j) - end do -end do -!do j=1,nanals -! do i=1,nanals -! pa(i,j) = work1(i,1) * eivec(j,1) -! do k=2,nanals -! pa(i,j) = pa(i,j) + work1(i,k) * eivec(j,k) -! end do -! end do -!end do -if(r_kind == kind(1.d0)) then - call dgemm('n','t',nanals,nanals,nanals,1.d0,work1,nanals,eivec,& - nanals,0.d0,pa,nanals) -else - call sgemm('n','t',nanals,nanals,nanals,1.e0,work1,nanals,eivec,& - nanals,0.e0,pa,nanals) -end if -! convert hxens * Rinv^T from hxens * sqrt(Rinv)^T +deallocate(work1,iwork,work3) ! no longer needed +gamma_inv = 0.0_r_kind do nanal=1,nanals - hxens(nanal,1:nobsl) = hxens(nanal,1:nobsl) * rrloc(1:nobsl) + if (evals(nanal) > eps) then + gamma_inv(nanal) = 1./evals(nanal) + else + evals(nanal) = 0.0_r_kind + endif +enddo +! gammapI used in calculation of posterior cov in ensemble space +gammapI = evals+1.0 +deallocate(evals) + +! create HZ^T R**-1/2 +allocate(shxens(nanals,nobsl)) +do nanal=1,nanals + shxens(nanal,1:nobsl) = hxens(nanal,1:nobsl) * rrloc(1:nobsl) end do -! Pa hdxb_rinv^T -!do nob=1,nobsl -! do nanal=1,nanals -! work2(nanal,nob) = pa(nanal,1) * hxens(1,nob) -! do k=2,nanals -! work2(nanal,nob) = work2(nanal,nob) + pa(nanal,k) * hxens(k,nob) -! end do -! end do -!end do -if(r_kind == kind(1.d0)) then - call dgemm('n','n',nanals,nobsl,nanals,1.d0,pa,nanals,hxens,& - nanals,0.d0,work2,nanals) -else - call sgemm('n','n',nanals,nobsl,nanals,1.e0,pa,nanals,hxens,& - nanals,0.e0,work2,nanals) -end if -! over-write hxens with Pa hdxb_rinv -! (pre-multiply with ensemble perts to compute Kalman gain - -! eqns 20-23 in Hunt et al 2007 paper) -hxens = work2 -! work3 = Pa hdxb_rinv^T dep +deallocate(rrloc) + +! compute factor to multiply with model space ensemble perturbations +! to compute analysis increment (for mean update), save in single precision. +! This is the factor C (Gamma + I)**-1 C^T (HZ)^ T R**-1/2 (y - HXmean) +! in Bishop paper (eqs 10-12). + +allocate(swork3(nanals,nanals),swork2(nanals,nanals),pa(nanals,nanals)) do nanal=1,nanals - work3(nanal) = work2(nanal,1) * dep(1) - do nob=2,nobsl - work3(nanal) = work3(nanal) + work2(nanal,nob) * dep(nob) - end do + swork3(nanal,:) = evecs(nanal,:)/gammapI + swork2(nanal,:) = evecs(nanal,:) +enddo + +! pa = C (Gamma + I)**-1 C^T (analysis error cov in ensemble space) +!pa = matmul(swork3,transpose(swork2)) +call sgemm('n','t',nanals,nanals,nanals,1.e0,swork3,nanals,swork2,& + nanals,0.e0,pa,nanals) +! work1 = (HZ)^ T R**-1/2 (y - HXmean) +! (nanals, nobsl) x (nobsl,) = (nanals,) +! in Bishop paper HZ is nobsl, nanals, here is it nanals, nobsl +allocate(swork1(nanals)) +do nanal=1,nanals + swork1(nanal) = sum(shxens(nanal,:)*dep(:)) end do -! T = sqrt[(m-1)Pa] -do j=1,nanals - rho = sqrt( real(nanals-1,r_kind) / eival(j) ) - do i=1,nanals - work1(i,j) = eivec(i,j) * rho - end do +! wts_ensmean = C (Gamma + I)**-1 C^T (HZ)^ T R**-1/2 (y - HXmean) +! (nanals, nanals) x (nanals,) = (nanals,) +do nanal=1,nanals + wts_ensmean(nanal) = sum(pa(nanal,:)*swork1(:))/normfact end do -if(r_kind == kind(1.d0)) then - call dgemm('n','t',nanals,nanals,nanals,1.d0,work1,nanals,eivec,& - & nanals,0.d0,trans,nanals) + +if (.not. denkf .and. getkf_inflation) then + allocate(paens(nanals,nanals)) + paens = pa/normfact**2 +endif +deallocate(swork1) + +! compute factor to multiply with model space ensemble perturbations +! to compute analysis increment (for perturbation update), save in single precision. +! This is -C [ (I - (Gamma+I)**-1/2)*Gamma**-1 ] C^T (HZ)^T R**-1/2 HXprime +! in Bishop paper (eqn 29). +! For DEnKF factor is -0.5*C (Gamma + I)**-1 C^T (HZ)^ T R**-1/2 HXprime +! = -0.5 Pa (HZ)^ T R**-1/2 HXprime (Pa already computed) + +if (getkf .or. denkf) then ! use Gain formulation for LETKF weights + +if (denkf) then + ! use Pa = C (Gamma + I)**-1 C^T (already computed) + ! wts_ensperts = -0.5 Pa (HZ)^ T R**-1/2 HXprime + pa = 0.5*pa else - call sgemm('n','t',nanals,nanals,nanals,1.e0,work1,nanals,eivec,& - & nanals,0.e0,trans,nanals) -end if -!do j=1,nanals -! do i=1,nanals -! trans(i,j) = work1(i,1) * eivec(j,1) -! do k=2,nanals -! trans(i,j) = trans(i,j) + work1(i,k) * eivec(j,k) -! end do -! end do -!end do -! T + Pa hdxb_rinv^T dep -do j=1,nanals - do i=1,nanals - trans(i,j) = trans(i,j) + work3(i) - end do -end do -deallocate(work2,eivec,pa,work1,rrloc,eival,work3) + gammapI = sqrt(1.0/gammapI) + do nanal=1,nanals + swork3(nanal,:) = & + evecs(nanal,:)*(1.-gammapI(:))*gamma_inv(:) + enddo + ! swork2 still contains eigenvectors, over-write pa + ! pa = C [ (I - (Gamma+I)**-1/2)*Gamma**-1 ] C^T + !pa = matmul(swork3,transpose(swork2)) + call sgemm('n','t',nanals,nanals,nanals,1.e0,swork3,nanals,swork2,& + nanals,0.e0,pa,nanals) +endif +deallocate(swork2,swork3) + +! work2 = (HZ)^ T R**-1/2 HXprime +! (nanals, nobsl) x (nobsl, nanals/neigv) = (nanals, nanals/neigv) +! in Bishop paper HZ is nobsl, nanals, here is it nanals, nobsl +! HXprime in paper is nobsl, nanals/neigv here it is nanals/neigv, nobsl +allocate(swork2(nanals,nanals/neigv)) +!swork2 = matmul(shxens,transpose(hxens_orig)) +call sgemm('n','t',nanals,nanals/neigv,nobsl,1.e0,& + shxens,nanals,hxens_orig,nanals/neigv,0.e0,swork2,nanals) +! wts_ensperts = -C [ (I - (Gamma+I)**-1/2)*Gamma**-1 ] C^T (HZ)^T R**-1/2 HXprime +! (nanals, nanals) x (nanals, nanals/eigv) = (nanals, nanals/neigv) +! if denkf, wts_ensperts = -0.5 C (Gamma + I)**-1 C^T (HZ)^T R**-1/2 HXprime +!wts_ensperts = -matmul(pa, swork2)/normfact +call sgemm('n','n',nanals,nanals/neigv,nanals,-1.e0,& + pa,nanals,swork2,nanals,0.e0,wts_ensperts,nanals) +wts_ensperts = wts_ensperts/normfact + +! clean up +deallocate(shxens,swork2,pa) + +else ! use original LETKF formulation (won't work if neigv != 1) + +if (neigv > 1) then + print *,'neigv must be 1 in letkf_core if getkf=F' + call stop2(993) +endif +! compute sqrt(Pa) - analysis weights +! (apply to prior ensemble to determine posterior ensemble, +! not analysis increments as in Gain formulation) +! hxens_orig not used +! saves two matrix multiplications (nanals, nobsl) x (nobsl, nanals) and +! (nanals, nanals) x (nanals, nanals) +deallocate(shxens,pa) +gammapI = sqrt(1.0/gammapI) +do nanal=1,nanals + swork3(nanal,:) = evecs(nanal,:)*gammapI +enddo +! swork2 already contains evecs +! wts_ensperts = +! C (Gamma + I)**-1/2 C^T (square root of analysis error cov in ensemble space) +!wts_ensperts = matmul(swork3,transpose(swork2)) +call sgemm('n','t',nanals,nanals,nanals,1.0,swork3,nanals,swork2,& + nanals,0.e0,wts_ensperts,nanals) +deallocate(swork3,swork2) + +endif + +deallocate(evecs,gammapI,gamma_inv) return end subroutine letkf_core +subroutine find_localobs(grdloc,obloc,rsqmax,nobstot,nobsl_max,sresults,nobsl) + ! brute force nearest neighbor search + ! if nobsl_max == -1, a r_nearest search is performed, finding + ! all neighbors with squared distance rsq. + ! if nobsl_max > 0, a n_nearest search is performed, finding + ! the nobsl_max nearest neighbors (rsq is ignored). + ! inputs: + ! grdloc = x,y,z (spherical cartesian coordinate) location + ! for the search. Chordal (not great circle) distance is used. + ! obloc(3,nobstot) = x,y,z locations of nobstot obs to be + ! searched. + ! rsqmax = r=x**2+y**2+z**2 search radius (ignored if nobsl_max > 0) + ! nobsl_max = number of neighbors to find (if -1 find all). + ! nobstot = total number of obs to search. + ! outputs: + ! nobsl = number of neighbors found. + ! sresults = search result structure (same as used by kdtree). Results + ! are sorted by distance (closest neighbors first). + integer, intent(in) :: nobsl_max, nobstot + real(r_single), intent(in) :: rsqmax + real(r_single), intent(in) :: grdloc(3) + real(r_single), intent(in) :: obloc(3,nobstot) + type(kdtree2_result),intent(inout) :: sresults(nobstot) + integer, intent(out) :: nobsl + ! local variables. + real(r_single) rsq(nobstot) + integer(i_kind) indxob(nobstot) + integer nob + + ! compute squared distances. + do nob = 1, nobstot + rsq(nob) = sum( (grdloc(:)-obloc(:,nob))**2, 1) + enddo + ! create index of sorted distances. + call quicksort(nobstot,rsq,indxob) + ! return all neigbhors closer than rsqmax + if (nobsl_max == -1) then + nobsl = 0 + do nob=1,nobstot + if (rsq(indxob(nob)) > rsqmax) then + nobsl=nob + exit + end if + enddo + ! return nobls_max nearest neighbors + else + if (nobsl_max > nobstot) then + print *,'nobsl_max must be <= nobstot in find_localobs' + call stop2(992) + else if (nobsl_max < 1) then + print *,'nobsl_max must be -1 or >= 1 in find_localobs' + call stop2(992) + endif + nobsl = nobsl_max + endif + ! fill search results up to nobsl in order of increasing distance + do nob=1,nobsl + sresults(nob)%idx = indxob(nob) + sresults(nob)%dis = rsq(indxob(nob)) + enddo + +end subroutine find_localobs + end module letkf diff --git a/src/enkf/loadbal.f90 b/src/enkf/loadbal.f90 index f57ee8fee..e146c7a21 100644 --- a/src/enkf/loadbal.f90 +++ b/src/enkf/loadbal.f90 @@ -15,6 +15,8 @@ module loadbal ! The decomposition uses "Graham's rule", which simply ! stated, assigns each new work item to the task that currently has the ! smallest load. +! scatter_chunks: distribute ensemble members according to decomposition +! gather_chunks: gather ensemble members from decomposed chunks ! loadbal_cleanup: deallocate allocated arrays. ! ! Private Subroutines: @@ -52,30 +54,45 @@ module loadbal ! of ob priors being updated on this task. ! grdloc_chunk(3,npts_max): real array of spherical cartesian coordinates ! of analysis grid points being updated on this task. -! lnp_chunk(npts_max,ndim): real array of log(pressures) of state variables +! lnp_chunk(npts_max,ncdim): real array of log(pressures) of control variables ! being updated on this task. -! oblnp_chunk(nobs_max,ndim): (serial enkf only) real array of log(pressures) of ob priors +! oblnp_chunk(nobs_max,ncdim): (serial enkf only) real array of log(pressures) of ob priors ! being updated on this task. ! obtime_chunk(nobs_max): (serial enkf only) real array of ob times of ob priors ! being updated on this task (expressed as an offset from the analysis time in ! hours). ! anal_obchunk_prior(nanals,nobs_max): (serial enkf only) real array of observation prior ! ensemble perturbations to be updated on this task (not used in LETKF). +! anal_obchunk_modens_prior(nanals*neigv,nobs_max): (serial enkf only) real array of observation prior +! modulate ensemble perturbations to be updated on this task when model space localization +! is enabled (modelspace_vloc=T, neigv > 0, not used in LETKF). ! kdtree_grid: pointer to kd-tree structure used for nearest neighbor searches ! for model grid points (only searches grid points assigned to this task). ! kdtree_obs: pointer to kd-tree structure used for nearest neighbor searches ! for observations (only searches ob locations assigned to this task). ! kdtree_obs2: (LETKF only) pointer to kd-tree structure used for nearest neighbor searches ! for observations (searches all observations) +! anal_chunk(nanals,npts_max,ncdim,nbackgrounds): real array of ensemble perturbations +! updated on each task. +! anal_chunk_prior(nanals,npts_max,ncdim,nbackgrounds): real array of prior ensemble +! perturbations. Before analysis anal_chunk=anal_chunk_prior, after +! analysis anal_chunk contains posterior perturbations. +! ensmean_chunk(npts_max,ncdim,nbackgrounds): real array containing pieces of ensemble +! mean to be updated on each task. +! ensmean_chunk_prior(npts_max,ncdim,nbackgrounds): as above, for ensemble mean prior. +! Before analysis ensmean_chunk=ensmean_chunk_prior, after analysis +! ensmean_chunk contains posterior ensemble mean. ! ! ! Modules Used: mpisetup, params, kinds, constants, enkf_obsmod, gridinfo, -! kdtree_module, covlocal +! kdtree_module, covlocal, controlvec ! ! program history log: ! 2009-02-23 Initial version. ! 2011-06-21 Added the option of observation box selection for LETKF. ! 2015-07-25 Remove observation box selection (use kdtree instead). +! 2016-05-02 shlyaeva: modification for reading state vector from table +! 2016-09-07 shlyaeva: moved distribution of chunks here from controlvec ! ! attributes: ! language: f95 @@ -83,9 +100,9 @@ module loadbal !$$$ use mpisetup -use params, only: ndim, datapath, nanals, simple_partition, letkf_flag,& - corrlengthnh, corrlengthsh, corrlengthtr, lupd_obspace_serial -use enkf_obsmod, only: nobstot, obloc, oblnp, ensmean_ob, obtime, anal_ob, corrlengthsq +use params, only: datapath, nanals, simple_partition, letkf_flag, nobsl_max,& + neigv, corrlengthnh, corrlengthsh, corrlengthtr, lupd_obspace_serial +use enkf_obsmod, only: nobstot, obloc, oblnp, ensmean_ob, obtime, anal_ob, anal_ob_modens, corrlengthsq use kinds, only: r_kind, i_kind, r_double, r_single use kdtree2_module, only: kdtree2, kdtree2_create, kdtree2_destroy, & kdtree2_result, kdtree2_r_nearest @@ -94,10 +111,14 @@ module loadbal implicit none private -public :: load_balance, loadbal_cleanup +public :: load_balance, loadbal_cleanup, gather_chunks, scatter_chunks real(r_single),public, allocatable, dimension(:,:) :: lnp_chunk, & - anal_obchunk_prior + anal_obchunk_prior, & + anal_obchunk_modens_prior +real(r_single),public, allocatable, dimension(:,:,:,:) :: anal_chunk, anal_chunk_prior +real(r_single),public, allocatable, dimension(:,:,:) :: ensmean_chunk, ensmean_chunk_prior + ! arrays passed to kdtree2 routines need to be single real(r_single),public, allocatable, dimension(:,:) :: obloc_chunk, grdloc_chunk real(r_single),public, allocatable, dimension(:) :: oblnp_chunk, & @@ -129,7 +150,9 @@ subroutine load_balance() if (letkf_flag) then ! used for finding nearest obs to grid point in LETKF. ! results are sorted by distance. - kdtree_obs2 => kdtree2_create(obloc,sort=.true.,rearrange=.true.) + if (nobstot >= 3) then + kdtree_obs2 => kdtree2_create(obloc,sort=.true.,rearrange=.true.) + endif endif ! partition state vector for using Grahams rule.. @@ -143,6 +166,9 @@ subroutine load_balance() call estimate_work_enkf1(numobs) ! fill numobs array with number of obs per horiz point ! distribute the results of estimate_work to all processors. call mpi_allreduce(mpi_in_place,numobs,npts,mpi_integer,mpi_sum,mpi_comm_world,ierr) +if (letkf_flag .and. nobsl_max > 0) then + where(numobs > nobsl_max) numobs = nobsl_max +endif if (nproc == 0) print *,'time in estimate_work_enkf1 = ',mpi_wtime()-t1,' secs' if (nproc == 0) print *,'min/max numobs',minval(numobs),maxval(numobs) ! loop over horizontal grid points on analysis grid. @@ -275,9 +301,6 @@ subroutine load_balance() totsize = nobstot totsize = totsize*nanals print *,'nobstot*nanals',totsize - totsize = npts - totsize = totsize*ndim - print *,'npts*ndim',totsize t1 = mpi_wtime() ! send one big message to each task. do np=1,numproc-1 @@ -300,6 +323,38 @@ subroutine load_balance() call mpi_recv(anal_obchunk_prior,nobs_max*nanals,mpi_real4,0, & 1,mpi_comm_world,mpi_status,ierr) end if + if (neigv > 0) then + ! if model space vertical localization is enabled, + ! distribute ensemble perturbations in ob space for serial filter. + allocate(anal_obchunk_modens_prior(nanals*neigv,nobs_max)) + if(nproc == 0) then + print *,'sending out modens observation prior ensemble perts from root ...' + totsize = nobstot + totsize = totsize*nanals*neigv + print *,'nobstot*nanals*neigv',totsize + t1 = mpi_wtime() + ! send one big message to each task. + do np=1,numproc-1 + do nob1=1,numobsperproc(np+1) + nob2 = indxproc_obs(np+1,nob1) + anal_obchunk_modens_prior(1:nanals*neigv,nob1) = anal_ob_modens(1:nanals*neigv,nob2) + end do + call mpi_send(anal_obchunk_modens_prior,nobs_max*nanals*neigv,mpi_real4,np, & + 1,mpi_comm_world,ierr) + end do + ! anal_obchunk_prior on root (no send necessary) + do nob1=1,numobsperproc(1) + nob2 = indxproc_obs(1,nob1) + anal_obchunk_modens_prior(1:nanals*neigv,nob1) = anal_ob_modens(1:nanals*neigv,nob2) + end do + ! now we don't need anal_ob_modens anymore for serial EnKF. + if (.not. lupd_obspace_serial) deallocate(anal_ob_modens) + else + ! recv one large message on each task. + call mpi_recv(anal_obchunk_modens_prior,nobs_max*nanals*neigv,mpi_real4,0, & + 1,mpi_comm_world,mpi_status,ierr) + end if + endif call mpi_barrier(mpi_comm_world, ierr) if(nproc == 0) print *,'... took ',mpi_wtime()-t1,' secs' ! these arrays only needed for serial filter @@ -331,6 +386,179 @@ subroutine load_balance() end subroutine load_balance + + +subroutine scatter_chunks +! distribute chunks from grdin (read in controlvec) according to +! decomposition from load_balance +use controlvec, only: ncdim, grdin +use params, only: nbackgrounds, ntasks_io, nanals_per_iotask +implicit none + +integer(i_kind), allocatable, dimension(:) :: scounts, displs, rcounts +real(r_single), allocatable, dimension(:) :: sendbuf,recvbuf +integer(i_kind) :: np, nb, nn, n, nanal, i, ierr, ne + +allocate(scounts(0:numproc-1)) +allocate(displs(0:numproc-1)) +allocate(rcounts(0:numproc-1)) +! only IO tasks send any data. +! scounts is number of data elements to send to processor np. +! rcounts is number of data elements to recv from processor np. +! displs is displacement into send array for data to go to proc np +do np=0,numproc-1 + displs(np) = np*nanals_per_iotask*npts_max*ncdim +enddo +if (nproc <= ntasks_io-1) then + scounts = nanals_per_iotask*npts_max*ncdim +else + scounts = 0 +endif +! displs is also the displacement into recv array for data to go into anal_chunk +! on +! task np. +do np=0,numproc-1 + if (np <= ntasks_io-1) then + rcounts(np) = nanals_per_iotask*npts_max*ncdim + else + rcounts(np) = 0 + end if +enddo +allocate(sendbuf(numproc*nanals_per_iotask*npts_max*ncdim)) +allocate(recvbuf(numproc*nanals_per_iotask*npts_max*ncdim)) + +! allocate array to hold pieces of state vector on each proc. +allocate(anal_chunk(nanals,npts_max,ncdim,nbackgrounds)) +if (nproc == 0) print *,'anal_chunk size = ',size(anal_chunk) + +allocate(anal_chunk_prior(nanals,npts_max,ncdim,nbackgrounds)) +allocate(ensmean_chunk(npts_max,ncdim,nbackgrounds)) +allocate(ensmean_chunk_prior(npts_max,ncdim,nbackgrounds)) +ensmean_chunk = 0_r_single + +! send and receive buffers. +do nb=1,nbackgrounds ! loop over time levels in background + + if (nproc <= ntasks_io-1) then + ! fill up send buffer. + do np=1,numproc + do ne=1,nanals_per_iotask + do nn=1,ncdim + do i=1,numptsperproc(np) + n = ((np-1)*ncdim*nanals_per_iotask + (ne-1)*ncdim + (nn-1))*npts_max + i + sendbuf(n) = grdin(indxproc(np,i),nn,nb,ne) + enddo + enddo + enddo + enddo + end if + call mpi_alltoallv(sendbuf, scounts, displs, mpi_real4, recvbuf, rcounts, displs,& + mpi_real4, mpi_comm_world, ierr) + + !==> compute ensemble of first guesses on each task, remove mean from anal. + !$omp parallel do schedule(dynamic,1) private(nn,i,nanal,n) + do nn=1,ncdim + do i=1,numptsperproc(nproc+1) + do nanal=1,nanals + n = ((nanal-1)*ncdim + (nn-1))*npts_max + i + anal_chunk(nanal,i,nn,nb) = recvbuf(n) + enddo + end do + end do + !$omp end parallel do + +enddo ! loop over nbackgrounds + +!==> compute mean, remove it from anal_chunk +!$omp parallel do schedule(dynamic,1) private(nn,i,n,nb) +do nb=1,nbackgrounds + do nn=1,ncdim + do i=1,numptsperproc(nproc+1) + ensmean_chunk(i,nn,nb) = sum(anal_chunk(:,i,nn,nb))/float(nanals) + ensmean_chunk_prior(i,nn,nb) = ensmean_chunk(i,nn,nb) + ! remove mean from ensemble. + do nanal=1,nanals + anal_chunk(nanal,i,nn,nb) = anal_chunk(nanal,i,nn,nb)-ensmean_chunk(i,nn,nb) + anal_chunk_prior(nanal,i,nn,nb)=anal_chunk(nanal,i,nn,nb) + end do + end do + end do +end do +!$omp end parallel do + +deallocate(sendbuf, recvbuf) + +end subroutine scatter_chunks + + + +subroutine gather_chunks +! gather chunks into grdin to write out the ensemble members +use controlvec, only: ncdim, grdin +use params, only: nbackgrounds, ntasks_io, nanals_per_iotask +implicit none +integer(i_kind), allocatable, dimension(:) :: scounts, displs, rcounts +real(r_single), allocatable, dimension(:) :: sendbuf,recvbuf +integer(i_kind) :: np, nb, nn, nanal, n, i, ierr, ne + +allocate(scounts(0:numproc-1)) +allocate(displs(0:numproc-1)) +allocate(rcounts(0:numproc-1)) +! all tasks send data, but only IO tasks receive any data. +! scounts is number of data elements to send to processor np. +! rcounts is number of data elements to recv from processor np. +! displs is displacement into send array for data to go to proc np +if (nproc <= ntasks_io-1) then + rcounts = nanals_per_iotask*npts_max*ncdim +else + rcounts = 0 +endif +do np=0,numproc-1 + displs(np) = np*nanals_per_iotask*npts_max*ncdim + if (np <= ntasks_io-1) then + scounts(np) = nanals_per_iotask*npts_max*ncdim + else + scounts(np) = 0 + end if +enddo +allocate(recvbuf(numproc*nanals_per_iotask*npts_max*ncdim)) +allocate(sendbuf(numproc*nanals_per_iotask*npts_max*ncdim)) + + +do nb=1,nbackgrounds ! loop over time levels in background + do nn=1,ncdim + do i=1,numptsperproc(nproc+1) + do nanal=1,nanals + n = ((nanal-1)*ncdim + (nn-1))*npts_max + i + ! add ensemble mean back in. + sendbuf(n) = anal_chunk(nanal,i,nn,nb)+ensmean_chunk(i,nn,nb) + ! convert to increment (A-F). + sendbuf(n) = sendbuf(n)-(anal_chunk_prior(nanal,i,nn,nb)+ensmean_chunk_prior(i,nn,nb)) + enddo + enddo + enddo + call mpi_alltoallv(sendbuf, scounts, displs, mpi_real4, recvbuf, rcounts, displs,& + mpi_real4, mpi_comm_world, ierr) + if (nproc <= ntasks_io-1) then + do np=1,numproc + do ne=1,nanals_per_iotask + do nn=1,ncdim + do i=1,numptsperproc(np) + n = ((np-1)*ncdim*nanals_per_iotask + (ne-1)*ncdim + (nn-1))*npts_max + i + grdin(indxproc(np,i),nn,nb,ne) = recvbuf(n) + enddo + enddo + enddo + enddo + !print *,nproc,'min/max ps',minval(grdin(:,ncdim)),maxval(grdin(:,ncdim)) + end if +enddo ! end loop over background time levels + +deallocate(sendbuf, recvbuf) + +end subroutine gather_chunks + + subroutine estimate_work_enkf1(numobs) ! estimate work needed to update each analysis grid ! point (considering all the observations within the localization radius). @@ -338,7 +566,7 @@ subroutine estimate_work_enkf1(numobs) implicit none integer(i_kind), dimension(:), intent(inout) :: numobs -real(r_single) :: deglat,corrlength,corrsq +real(r_single) :: deglat,corrlength,corrsq,r type(kdtree2_result),dimension(:),allocatable :: sresults integer nob,n1,n2,i,ideln @@ -357,8 +585,18 @@ subroutine estimate_work_enkf1(numobs) deglat = latsgrd(i)*rad2deg corrlength=latval(deglat,corrlengthnh,corrlengthtr,corrlengthsh) corrsq = corrlength**2 - call kdtree2_r_nearest(tp=kdtree_obs2,qv=gridloc(:,i),r2=corrsq,& - nfound=numobs(i),nalloc=nobstot,results=sresults) + + if (associated(kdtree_obs2)) then + call kdtree2_r_nearest(tp=kdtree_obs2,qv=gridloc(:,i),r2=corrsq,& + nfound=numobs(i),nalloc=nobstot,results=sresults) + else + do nob = 1, nobstot + r = sum( (gridloc(:,i)-obloc(:,nob))**2, 1) + if (r < corrsq) then + numobs(i) = numobs(i) + 1 + endif + enddo + endif else do nob=1,nobstot if (sum((obloc(1:3,nob)-gridloc(1:3,i))**2,1) < corrlengthsq(nob)) & @@ -411,6 +649,10 @@ end subroutine estimate_work_enkf2 subroutine loadbal_cleanup() ! deallocate module-level allocatable arrays +if (allocated(anal_chunk)) deallocate(anal_chunk) +if (allocated(anal_chunk_prior)) deallocate(anal_chunk_prior) +if (allocated(ensmean_chunk)) deallocate(ensmean_chunk) +if (allocated(ensmean_chunk_prior)) deallocate(ensmean_chunk_prior) if (allocated(obloc_chunk)) deallocate(obloc_chunk) if (allocated(grdloc_chunk)) deallocate(grdloc_chunk) if (allocated(lnp_chunk)) deallocate(lnp_chunk) diff --git a/src/enkf/mpi_readobs.f90 b/src/enkf/mpi_readobs.f90 index 89b047e75..a18cc0e1d 100644 --- a/src/enkf/mpi_readobs.f90 +++ b/src/enkf/mpi_readobs.f90 @@ -24,6 +24,8 @@ module mpi_readobs ! ! program history log: ! 2009-02-23 Initial version. +! 2016-11-29 shlyaeva: Added the option of writing out ensemble spread in +! diag files ! ! attributes: ! language: f95 @@ -31,6 +33,7 @@ module mpi_readobs !$$$ use kinds, only: r_kind, r_single, i_kind +use params, only: ntasks_io, nanals_per_iotask, nanal1, nanal2 use radinfo, only: npred use readconvobs use readsatobs @@ -45,49 +48,61 @@ module mpi_readobs contains subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_tot, & + nobs_convdiag, nobs_ozdiag, nobs_satdiag, nobs_totdiag, & sprd_ob, ensmean_ob, ensmean_obbc, ob, & oberr, oblon, oblat, obpress, & obtime, oberrorig, obcode, obtype, & - biaspreds, anal_ob, indxsat, nanals) + biaspreds, diagused, anal_ob, anal_ob_modens, indxsat, nanals, neigv) character*500, intent(in) :: obspath character*10, intent(in) :: datestring character(len=10) :: id,id2 - real(r_single), allocatable, dimension(:) :: ensmean_ob,ob,oberr,oblon,oblat,obpress,obtime,oberrorig,ensmean_obbc,sprd_ob - integer(i_kind), allocatable, dimension(:) :: obcode,indxsat + real(r_single), allocatable, dimension(:) :: ensmean_ob,ob,oberr,oblon,oblat + real(r_single), allocatable, dimension(:) :: obpress,obtime,oberrorig,ensmean_obbc,sprd_ob + integer(i_kind), allocatable, dimension(:) :: obcode,indxsat + integer(i_kind), allocatable, dimension(:) :: diagused real(r_single), allocatable, dimension(:,:) :: biaspreds - real(r_single), allocatable, dimension(:,:) :: anal_ob -! real(r_single), allocatable, dimension(:,:) :: anal_obtmp - real(r_single), allocatable, dimension(:) :: h_xnobc + real(r_single), allocatable, dimension(:,:) :: anal_ob, anal_ob_modens + real(r_single), allocatable, dimension(:) :: mem_ob + real(r_single), allocatable, dimension(:,:) :: mem_ob_modens real(r_single) :: analsi,analsim1 real(r_double) t1,t2 character(len=20), allocatable, dimension(:) :: obtype - integer(i_kind) nob, ierr, iozproc, isatproc, & - nobs_conv, nobs_oz, nobs_sat, nobs_tot, nanal - integer(i_kind), intent(in) :: nanals + integer(i_kind) nob, ierr, iozproc, isatproc, neig, nens1, nens2, na, nmem,& + np, nobs_conv, nobs_oz, nobs_sat, nobs_tot, nanal, nanalo + integer(i_kind) :: nobs_convdiag, nobs_ozdiag, nobs_satdiag, nobs_totdiag + integer(i_kind), intent(in) :: nanals, neigv iozproc=max(0,min(1,numproc-1)) isatproc=max(0,min(2,numproc-2)) ! get total number of conventional and sat obs for ensmean. id = 'ensmean' - if(nproc == 0)call get_num_convobs(obspath,datestring,nobs_conv,id) - if(nproc == iozproc)call get_num_ozobs(obspath,datestring,nobs_oz,id) - if(nproc == isatproc)call get_num_satobs(obspath,datestring,nobs_sat,id) + if(nproc == 0)call get_num_convobs(obspath,datestring,nobs_conv,nobs_convdiag,id) + if(nproc == iozproc)call get_num_ozobs(obspath,datestring,nobs_oz,nobs_ozdiag,id) + if(nproc == isatproc)call get_num_satobs(obspath,datestring,nobs_sat,nobs_satdiag,id) call mpi_bcast(nobs_conv,1,mpi_integer,0,mpi_comm_world,ierr) + call mpi_bcast(nobs_convdiag,1,mpi_integer,0,mpi_comm_world,ierr) call mpi_bcast(nobs_oz,1,mpi_integer,iozproc,mpi_comm_world,ierr) + call mpi_bcast(nobs_ozdiag,1,mpi_integer,iozproc,mpi_comm_world,ierr) call mpi_bcast(nobs_sat,1,mpi_integer,isatproc,mpi_comm_world,ierr) + call mpi_bcast(nobs_satdiag,1,mpi_integer,isatproc,mpi_comm_world,ierr) if(nproc == 0)print *,'nobs_conv, nobs_oz, nobs_sat = ',nobs_conv,nobs_oz,nobs_sat + if(nproc == 0)print *,'total diag nobs_conv, nobs_oz, nobs_sat = ', nobs_convdiag, nobs_ozdiag, nobs_satdiag nobs_tot = nobs_conv + nobs_oz + nobs_sat + nobs_totdiag = nobs_convdiag + nobs_ozdiag + nobs_satdiag ! if nobs_tot != 0 (there were some obs to read) if (nobs_tot > 0) then if (nproc == 0) then ! this array only needed on root. allocate(anal_ob(nanals,nobs_tot)) + ! note: if neigv=0 (ob space localization), this array is size zero. + allocate(anal_ob_modens(nanals*neigv,nobs_tot)) end if ! these arrays needed on all processors. - allocate(h_xnobc(nobs_tot)) + allocate(mem_ob(nobs_tot)) + allocate(mem_ob_modens(neigv,nobs_tot)) ! zero size if neigv=0 allocate(sprd_ob(nobs_tot),ob(nobs_tot),oberr(nobs_tot),oblon(nobs_tot),& oblat(nobs_tot),obpress(nobs_tot),obtime(nobs_tot),oberrorig(nobs_tot),obcode(nobs_tot),& obtype(nobs_tot),ensmean_ob(nobs_tot),ensmean_obbc(nobs_tot),& - biaspreds(npred+1, nobs_sat),indxsat(nobs_sat)) + biaspreds(npred+1, nobs_sat),indxsat(nobs_sat), diagused(nobs_totdiag)) else ! stop if no obs found (must be an error somewhere). print *,'no obs found!' @@ -95,29 +110,43 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to end if ! read ensemble mean and every ensemble member - nanal = nproc+1 + if (nproc <= ntasks_io-1) then + nens1 = nanal1(nproc); nens2 = nanal2(nproc) + else + nens1 = nanals+1; nens2 = nanals+1 + endif + + nmem = 0 + do nanal=nens1,nens2 ! loop over ens members on this task + nmem = nmem + 1 ! nmem only used if lobsdiag_forenkf=T id = 'ensmean' id2 = id + ! if nanal>nanals, ens member data not read (only ens mean) if (nanal <= nanals) then write(id2,'(a3,(i3.3))') 'mem',nanal endif ! read obs. -! only thing that is different on each task is h_xnobc. All other +! only thing that is different on each task is mem_ob. All other ! fields are defined from ensemble mean. ! individual members read on 1st nanals tasks, ens mean read on all tasks. if (nobs_conv > 0) then ! first nobs_conv are conventional obs. - call get_convobs_data(obspath, datestring, nobs_conv, & - ensmean_obbc(1:nobs_conv), h_xnobc(1:nobs_conv), ob(1:nobs_conv), & - oberr(1:nobs_conv), oblon(1:nobs_conv), oblat(1:nobs_conv), & - obpress(1:nobs_conv), obtime(1:nobs_conv), obcode(1:nobs_conv), & - oberrorig(1:nobs_conv), obtype(1:nobs_conv), id,id2) + call get_convobs_data(obspath, datestring, nobs_conv, nobs_convdiag, & + ensmean_obbc(1:nobs_conv), ensmean_ob(1:nobs_conv), & + mem_ob(1:nobs_conv), mem_ob_modens(1:neigv,1:nobs_conv), & + ob(1:nobs_conv), & + oberr(1:nobs_conv), oblon(1:nobs_conv), oblat(1:nobs_conv), & + obpress(1:nobs_conv), obtime(1:nobs_conv), obcode(1:nobs_conv), & + oberrorig(1:nobs_conv), obtype(1:nobs_conv), & + diagused(1:nobs_convdiag), id, nanal, nmem) end if if (nobs_oz > 0) then ! second nobs_oz are conventional obs. - call get_ozobs_data(obspath, datestring, nobs_oz, & - ensmean_obbc(nobs_conv+1:nobs_conv+nobs_oz), & - h_xnobc(nobs_conv+1:nobs_conv+nobs_oz), & + call get_ozobs_data(obspath, datestring, nobs_oz, nobs_ozdiag, & + ensmean_obbc(nobs_conv+1:nobs_conv+nobs_oz), & + ensmean_ob(nobs_conv+1:nobs_conv+nobs_oz), & + mem_ob(nobs_conv+1:nobs_conv+nobs_oz), & + mem_ob_modens(1:neigv,nobs_conv+1:nobs_conv+nobs_oz), & ob(nobs_conv+1:nobs_conv+nobs_oz), & oberr(nobs_conv+1:nobs_conv+nobs_oz), & oblon(nobs_conv+1:nobs_conv+nobs_oz), & @@ -126,15 +155,18 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to obtime(nobs_conv+1:nobs_conv+nobs_oz), & obcode(nobs_conv+1:nobs_conv+nobs_oz), & oberrorig(nobs_conv+1:nobs_conv+nobs_oz), & - obtype(nobs_conv+1:nobs_conv+nobs_oz), id,id2) + obtype(nobs_conv+1:nobs_conv+nobs_oz), & + diagused(nobs_convdiag+1:nobs_convdiag+nobs_ozdiag),& + id,nanal,nmem) end if if (nobs_sat > 0) then biaspreds = 0. ! initialize bias predictor array to zero. ! last nobs_sat are satellite radiance obs. - !print *,nproc,id,id2,'read sat obs' - call get_satobs_data(obspath, datestring, nobs_sat, & + call get_satobs_data(obspath, datestring, nobs_sat, nobs_satdiag, & ensmean_obbc(nobs_conv+nobs_oz+1:nobs_tot), & - h_xnobc(nobs_conv+nobs_oz+1:nobs_tot), & + ensmean_ob(nobs_conv+nobs_oz+1:nobs_tot), & + mem_ob(nobs_conv+nobs_oz+1:nobs_tot), & + mem_ob_modens(1:neigv,nobs_conv+nobs_oz+1:nobs_tot), & ob(nobs_conv+nobs_oz+1:nobs_tot), & oberr(nobs_conv+nobs_oz+1:nobs_tot), & oblon(nobs_conv+nobs_oz+1:nobs_tot), & @@ -143,10 +175,13 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to obtime(nobs_conv+nobs_oz+1:nobs_tot), & obcode(nobs_conv+nobs_oz+1:nobs_tot), & oberrorig(nobs_conv+nobs_oz+1:nobs_tot), & - obtype(nobs_conv+nobs_oz+1:nobs_tot), biaspreds,indxsat,id,id2) + obtype(nobs_conv+nobs_oz+1:nobs_tot), & + biaspreds,indxsat, & + diagused(nobs_convdiag+nobs_ozdiag+1:nobs_totdiag),& + id,nanal,nmem) end if ! read obs. - call mpi_barrier(mpi_comm_world,ierr) ! synch tasks. +! call mpi_barrier(mpi_comm_world,ierr) ! synch tasks. ! use mpi_gather to gather ob prior ensemble on root. ! requires allocation of nobs_tot x nanals temporory array. @@ -154,7 +189,7 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to ! t1 = mpi_wtime() ! allocate(anal_obtmp(nobs_tot,nanals)) ! endif -! if (nproc <= nanals-1) then +! if (nproc <= ntasks_io-1) then ! call mpi_gather(h_xnobc,nobs_tot,mpi_real4,& ! anal_obtmp,nobs_tot,mpi_real4,0,mpi_comm_io,ierr) ! if (nproc .eq. 0) then @@ -166,40 +201,84 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to ! use mpi_send/mpi_recv to gather ob prior ensemble on root. ! a bit slower, but does not require large temporary array like mpi_gather. - if (nproc <= nanals-1) then + if (nproc <= ntasks_io-1) then if (nproc == 0) then t1 = mpi_wtime() - anal_ob(1,:) = h_xnobc(:) - do nanal=2,nanals - call mpi_recv(h_xnobc,nobs_tot,mpi_real4,nanal-1, & + anal_ob(nmem,:) = mem_ob(:) + ! if nproc <= ntasks_io-1, then + ! nanal = nmem+nproc*nanals_per_iotask + do np=2,ntasks_io + call mpi_recv(mem_ob,nobs_tot,mpi_real4,np-1, & 1,mpi_comm_io,mpi_status,ierr) - anal_ob(nanal,:) = h_xnobc(:) + anal_ob(nmem+(np-1)*nanals_per_iotask,:) = mem_ob(:) enddo + ! mem_ob_modens and anal_ob_modens not referenced unless neigv>0 + if (neigv > 0) then + do neig=1,neigv + nanalo = neigv*(nmem-1) + neig + anal_ob_modens(nanalo,:) = mem_ob_modens(neig,:) + enddo + do np=2,ntasks_io + call mpi_recv(mem_ob_modens,neigv*nobs_tot,mpi_real4,np-1, & + 2,mpi_comm_io,mpi_status,ierr) + do neig=1,neigv + na = nmem+(np-1)*nanals_per_iotask + nanalo = neigv*(na-1) + neig + anal_ob_modens(nanalo,:) = mem_ob_modens(neig,:) + enddo + enddo + endif t2 = mpi_wtime() print *,'time to gather ob prior ensemble on root = ',t2-t1 + else ! nproc != 0 ! send to root. - call mpi_send(h_xnobc,nobs_tot,mpi_real4,0,1,mpi_comm_io,ierr) + call mpi_send(mem_ob,nobs_tot,mpi_real4,0,1,mpi_comm_io,ierr) + if (neigv > 0) then + call mpi_send(mem_ob_modens,neigv*nobs_tot,mpi_real4,0,2,mpi_comm_io,ierr) + endif end if - end if ! nanal <= nanals + end if ! io task + + enddo ! nanal loop (loop over ens members on each task) ! make anal_ob contain ob prior ensemble *perturbations* if (nproc == 0) then analsi=1._r_single/float(nanals) analsim1=1._r_single/float(nanals-1) -!$omp parallel do private(nob,nanal) +!$omp parallel do private(nob) do nob=1,nobs_tot -! remove ensemble mean from each member. ensmean_ob(nob) = sum(anal_ob(:,nob))*analsi -! ensmean_ob is unbiascorrected ensemble mean (anal_ob +! remove ensemble mean from each member. +! ensmean_ob is unbiascorrected ensemble mean (anal_ob is ens pert) anal_ob(:,nob) = anal_ob(:,nob)-ensmean_ob(nob) ! compute sprd sprd_ob(nob) = sum(anal_ob(:,nob)**2)*analsim1 +! modulated ensemble. + if (neigv > 0) then + anal_ob_modens(:,nob) = anal_ob_modens(:,nob)-ensmean_ob(nob) + sprd_ob(nob) = sum(anal_ob_modens(:,nob)**2)*analsim1 + endif enddo !$omp end parallel do + print *, 'prior spread conv: ', minval(sprd_ob(1:nobs_conv)), maxval(sprd_ob(1:nobs_conv)) + print *, 'prior spread oz: ', minval(sprd_ob(nobs_conv+1:nobs_conv+nobs_oz)), & + maxval(sprd_ob(nobs_conv+1:nobs_conv+nobs_oz)) + print *, 'prior spread sat: ',minval(sprd_ob(nobs_conv+nobs_oz+1:nobs_tot)), & + maxval(sprd_ob(nobs_conv+nobs_oz+1:nobs_tot)) + do nob =nobs_conv+nobs_oz+1 , nobs_tot + if (sprd_ob(nob) > 1000.) then + print *, nob, ' sat spread: ', sprd_ob(nob), ', ensmean_ob: ', ensmean_ob(nob), & + ', anal_ob: ', anal_ob(:,nob), ', mem_ob: ', mem_ob(nob) + endif + enddo endif ! broadcast ob prior ensemble mean and spread to every task. + + if (allocated(mem_ob)) deallocate(mem_ob) + if (allocated(mem_ob_modens)) deallocate(mem_ob_modens) + if (nproc == 0) t1 = mpi_wtime() call mpi_bcast(ensmean_ob,nobs_tot,mpi_real4,0,mpi_comm_world,ierr) call mpi_bcast(sprd_ob,nobs_tot,mpi_real4,0,mpi_comm_world,ierr) @@ -207,7 +286,7 @@ subroutine mpi_getobs(obspath, datestring, nobs_conv, nobs_oz, nobs_sat, nobs_to t2 = mpi_wtime() print *,'time to broadcast ob prior ensemble mean and spread = ',t2-t1 endif - deallocate(h_xnobc) + end subroutine mpi_getobs diff --git a/src/enkf/mpisetup.F90 b/src/enkf/mpisetup.F90 index ddaf23841..2d632d72e 100644 --- a/src/enkf/mpisetup.F90 +++ b/src/enkf/mpisetup.F90 @@ -42,7 +42,7 @@ subroutine mpi_initialize() use mpimod, only : mpi_comm_world,npe,mype integer ierr #ifdef MPI3 -integer nuse,new_group,old_group,nshmemroot +integer nuse,new_group,old_group,nshmemroot,np integer, dimension(:), allocatable :: useprocs, itasks #endif call mpi_init(ierr) @@ -99,7 +99,7 @@ subroutine mpi_initialize() end subroutine mpi_initialize subroutine mpi_initialize_io(nanals) -use mpimod, only : mpi_comm_world,npe,mype +use mpimod, only : mpi_comm_world integer ierr,np,nuse,new_group,old_group integer, intent(in) :: nanals integer, dimension(:), allocatable :: useprocs, itasks diff --git a/src/enkf/observer_fv3reg.f90 b/src/enkf/observer_fv3reg.f90 new file mode 100644 index 000000000..428196c44 --- /dev/null +++ b/src/enkf/observer_fv3reg.f90 @@ -0,0 +1,156 @@ +module observer_enkf +! a dummy module ,modified from observer_gfs.f90 +use statevec, only: nsdim, ns3d, ns2d, slevels +use params, only: nlevs, neigv + +private +public init_observer_enkf, setup_linhx, calc_linhx, calc_linhx_modens,& + destroy_observer_enkf +integer, allocatable, dimension(:) :: kindx + +contains + +subroutine init_observer_enkf + write(6,*)'this is a dummy subroutine, running this means something wrong ,stop' + call stop2(555) + return +end subroutine init_observer_enkf + +subroutine destroy_observer_enkf + write(6,*)'this is a dummy subroutine, running this means something wrong ,stop' + call stop2(555) +end subroutine destroy_observer_enkf + +subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_linhx +! prgmmr: shlyaeva org: esrl/psd date: 2016-11-29 +! +! abstract: +! +! program history log: +! 2016-11-29 shlyaeva +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f95 +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use params, only: nstatefields, nlons, nlats, nlevs, nhr_state, fhr_assim + use gridinfo, only: npts, latsgrd, lonsgrd + use statevec, only: nsdim + use constants, only: zero,one,pi + use mpisetup + implicit none + +! Declare passed variables + real(r_single) ,intent(in ) :: rlat, rlon ! observation lat and lon in radians + real(r_single) ,intent(in ) :: time ! observation time relative to middle of window + integer(i_kind), intent(out) :: ix, iy, it, ixp, iyp, itp + real(r_kind), intent(out) :: delx, dely, delxp, delyp, delt, deltp + write(6,*)'this is a dummy subroutine, running this means something wrong ,stop' + call stop2(555) + + + ! find interplation indices and deltas + +end subroutine setup_linhx + +subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & + ix, delx, ixp, delxp, iy, dely, iyp, delyp, & + it, delt, itp, deltp) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_linhx +! prgmmr: shlyaeva org: esrl/psd date: 2016-11-29 +! +! abstract: +! +! program history log: +! 2016-11-29 shlyaeva +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f95 +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use params, only: nstatefields, nlons, nlats, nlevs, nhr_state, fhr_assim + use gridinfo, only: npts, latsgrd, lonsgrd + use statevec, only: nsdim + use constants, only: zero,one,pi + use sparsearr, only: sparr + use mpisetup + implicit none + +! Declare passed variables + real(r_single) ,intent(in ) :: hx ! H(x_mean) + real(r_single),dimension(npts,nsdim,nstatefields),intent(in ) :: dens ! x_ens - x_mean, state vector space + integer(i_kind), intent(in) :: ix, iy, it, ixp, iyp, itp + real(r_kind), intent(in) :: delx, dely, delxp, delyp, delt, deltp + type(sparr) ,intent(in ) :: dhx_dx ! dH(x)/dx |x_mean profiles + real(r_single) ,intent( out) :: hx_ens ! H (x_ens) + integer(i_kind) i,j,k + + write(6,*)'this is a dummy subroutine, running this means something wrong ,stop' + call stop2(555) + + return +end subroutine calc_linhx + +subroutine calc_linhx_modens(hx, dens, dhx_dx, hx_ens, & + ix, delx, ixp, delxp, iy, dely, iyp, delyp, & + it, delt, itp, deltp, vscale) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_linhx +! prgmmr: shlyaeva org: esrl/psd date: 2016-11-29 +! +! abstract: +! +! program history log: +! 2016-11-29 shlyaeva +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f95 +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use params, only: nstatefields, nlons, nlats, nlevs, nhr_state, fhr_assim + use gridinfo, only: npts, latsgrd, lonsgrd + use statevec, only: nsdim + use constants, only: zero,one,pi + use sparsearr, only: sparr + use mpisetup + implicit none + +! Declare passed variables + real(r_single) ,intent(in ) :: hx ! H(x_mean) + real(r_single),dimension(npts,nsdim,nstatefields),intent(in ) :: dens ! x_ens - x_mean, state vector space + integer(i_kind), intent(in) :: ix, iy, it, ixp, iyp, itp + real(r_kind), intent(in) :: delx, dely, delxp, delyp, delt, deltp + type(sparr) ,intent(in ) :: dhx_dx ! dH(x)/dx |x_mean profiles + real(r_single) ,intent( out) :: hx_ens(neigv)! H (x_ens) + real(r_double),dimension(neigv,nlevs+1) ,intent(in ) :: vscale ! vertical scaling (for modulated ens) + integer(i_kind) i,j,k + write(6,*)'this is a dummy subroutine, running this means something wrong ,stop' + call stop2(555) + + + return +end subroutine calc_linhx_modens + +end module observer_enkf diff --git a/src/enkf/observer_gfs.f90 b/src/enkf/observer_gfs.f90 new file mode 100644 index 000000000..8d219f2e8 --- /dev/null +++ b/src/enkf/observer_gfs.f90 @@ -0,0 +1,264 @@ +module observer_enkf +use statevec, only: nsdim, ns3d, ns2d, slevels +use params, only: nlevs, neigv + +private +public init_observer_enkf, setup_linhx, calc_linhx, calc_linhx_modens,& + destroy_observer_enkf +integer, allocatable, dimension(:) :: kindx + +contains + +subroutine init_observer_enkf + integer nn,n,k,nl + allocate(kindx(nsdim)) + nn = 0 + do n=1,ns3d + if (n .eq. 1) then + nl = slevels(n) + else + nl = slevels(n)-slevels(n-1) + endif + !print *,'ns3d,levs',n,nl + do k=1,nl + nn = nn + 1 + kindx(nn) = k + ! FIXME - deal with state variables with nlevs+1 levels (like prse) + if (kindx(nn) > nlevs) kindx(nn)=nlevs + enddo + enddo + do n=1,ns2d ! 2d fields are treated as surface fields. + nn = nn + 1 + kindx(nn) = 1 + enddo + return +end subroutine init_observer_enkf + +subroutine destroy_observer_enkf + if (allocated(kindx)) deallocate(kindx) +end subroutine destroy_observer_enkf + +subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_linhx +! prgmmr: shlyaeva org: esrl/psd date: 2016-11-29 +! +! abstract: +! +! program history log: +! 2016-11-29 shlyaeva +! +! input argument list: +! rlat: latitude of ob +! rlon: longitude of ob +! time: time offset for ob +! +! output argument list: +! ix,delx,ixp,delxp,iy,dely,iyp,delyp,it,delt,itp,deltp: horizontal +! and temporal linear interpolation indices and weights. +! +! +! attributes: +! language: f95 +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use params, only: nstatefields, nlons, nlats, nhr_state, fhr_assim + use gridinfo, only: latsgrd, lonsgrd + use constants, only: zero,one,pi + use mpisetup + implicit none + +! Declare passed variables + real(r_single) ,intent(in ) :: rlat, rlon ! observation lat and lon in radians + real(r_single) ,intent(in ) :: time ! observation time relative to middle of window + integer(i_kind), intent(out) :: ix, iy, it, ixp, iyp, itp + real(r_kind), intent(out) :: delx, dely, delxp, delyp, delt, deltp + + + ! find interplation indices and deltas + ix = 0 + do while (latsgrd(ix*nlons+1) >= rlat) + ix = ix + 1 + if (ix == nlats-1) exit + enddo + ix = min(ix, nlats-1) + ixp = max(ix-1, 0) + + if (ixp /= ix) then + delx = (rlat - latsgrd(ix*nlons+1)) / (latsgrd(ixp*nlons + 1) - latsgrd(ix*nlons+1)) + else + delx = one + endif + delx = max(zero,min(delx,one)) + + iyp = 1 + do while (iyp <= nlons .and. lonsgrd(ix*nlons + iyp) <= rlon) + iyp = iyp + 1 + enddo + iy = iyp - 1 + if(iy < 1) iy = iy + nlons + if(iyp > nlons) iyp = iyp - nlons + if(iy > nlons) iy = iy - nlons + + if (iy /= nlons) then + dely = (rlon - lonsgrd(ix*nlons + iy)) / (lonsgrd(ix*nlons + iyp) - lonsgrd(ix*nlons + iy)) + else + dely = (rlon - lonsgrd(ix*nlons + iy)) / (lonsgrd(ix*nlons + iyp) + 2*pi - lonsgrd(ix*nlons + iy)) + endif + + it = 1 + do while (time + fhr_assim > nhr_state(it) .and. it < nstatefields) + it = it + 1 + enddo + itp = it + it = max(1,itp-1) + if (it /= itp) then + delt = (time + fhr_assim - nhr_state(it)) / (nhr_state(itp) - nhr_state(it)) + else + delt = one + endif + + deltp = one - delt + delxp = one - delx + delyp = one - dely + +end subroutine setup_linhx + +subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & + ix, delx, ixp, delxp, iy, dely, iyp, delyp, & + it, delt, itp, deltp) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_linhx +! prgmmr: shlyaeva org: esrl/psd date: 2016-11-29 +! +! abstract: +! +! program history log: +! 2016-11-29 shlyaeva +! +! input argument list: +! hx: observation prior ensemble mean +! dens: state space ensemble perturbations +! dhx_dx: Jacobian +! ix,delx,ixp,delxp,iy,dely,iyp,delyp,it,delt,itp,deltp: horizontal +! and temporal linear interpolation indices and weights. +! +! output argument list: +! hx_ens: observation prior ensemble perturbation +! +! attributes: +! language: f95 +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use params, only: nstatefields, nlons + use gridinfo, only: npts + use statevec, only: nsdim + use constants, only: zero,one + use sparsearr, only: sparr + use mpisetup + implicit none + +! Declare passed variables + real(r_single) ,intent(in ) :: hx ! H(x_mean) + real(r_single),dimension(npts,nsdim,nstatefields),intent(in ) :: dens ! x_ens - x_mean, state vector space + integer(i_kind), intent(in) :: ix, iy, it, ixp, iyp, itp + real(r_kind), intent(in) :: delx, dely, delxp, delyp, delt, deltp + type(sparr) ,intent(in ) :: dhx_dx ! dH(x)/dx |x_mean profiles + real(r_single) ,intent( out) :: hx_ens ! H (x_ens) + integer(i_kind) i,j,k + + ! interpolate state horizontally and in time and do dot product with dHx/dx profile + ! saves from calculating interpolated x_ens for each state variable + hx_ens = hx + do i = 1, dhx_dx%nnz + j = dhx_dx%ind(i) + k = kindx(j) + hx_ens = hx_ens + dhx_dx%val(i) * & + (( dens( ix*nlons + iy , j, it) *delxp*delyp & + + dens( ixp*nlons + iy , j, it) *delx *delyp & + + dens( ix*nlons + iyp, j, it) *delxp*dely & + + dens( ixp*nlons + iyp, j, it) *delx *dely )*deltp & + + ( dens( ix*nlons + iy , j, itp)*delxp*delyp & + + dens( ixp*nlons + iy , j, itp)*delx *delyp & + + dens( ix*nlons + iyp, j, itp)*delxp*dely & + + dens( ixp*nlons + iyp, j, itp)*delx *dely )*delt) + enddo + + return +end subroutine calc_linhx + +subroutine calc_linhx_modens(hx, dens, dhx_dx, hx_ens, & + ix, delx, ixp, delxp, iy, dely, iyp, delyp, & + it, delt, itp, deltp, vscale) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_linhx +! prgmmr: shlyaeva org: esrl/psd date: 2016-11-29 +! +! abstract: +! +! program history log: +! 2016-11-29 shlyaeva +! +! input argument list: +! hx: observation prior ensemble mean +! dens: state space ensemble perturbations +! dhx_dx: Jacobian +! ix,delx,ixp,delxp,iy,dely,iyp,delyp,it,delt,itp,deltp: horizontal +! and temporal linear interpolation indices and weights. +! +! output argument list: +! hx_ens: observation prior ensemble perturbation for each verticali +! localization eigenvector +! vscale: vertical scaling from vertical localization eigenvectors used +! to generate modulated ensemble. +! +! attributes: +! language: f95 +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use params, only: nstatefields, nlons, nlevs + use gridinfo, only: npts + use statevec, only: nsdim + use constants, only: zero,one + use sparsearr, only: sparr + use mpisetup + implicit none + +! Declare passed variables + real(r_single) ,intent(in ) :: hx ! H(x_mean) + real(r_single),dimension(npts,nsdim,nstatefields),intent(in ) :: dens ! x_ens - x_mean, state vector space + integer(i_kind), intent(in) :: ix, iy, it, ixp, iyp, itp + real(r_kind), intent(in) :: delx, dely, delxp, delyp, delt, deltp + type(sparr) ,intent(in ) :: dhx_dx ! dH(x)/dx |x_mean profiles + real(r_single) ,intent( out) :: hx_ens(neigv)! H (x_ens) + real(r_double),dimension(neigv,nlevs+1) ,intent(in ) :: vscale ! vertical scaling (for modulated ens) + integer(i_kind) i,j,k + + ! interpolate state horizontally and in time and do dot product with dHx/dx profile + ! saves from calculating interpolated x_ens for each state variable + hx_ens = hx + do i = 1, dhx_dx%nnz + j = dhx_dx%ind(i) + k = kindx(j) + hx_ens(:) = hx_ens(:) + dhx_dx%val(i) * & + (( dens( ix*nlons + iy , j, it) *vscale(:,k)*delxp*delyp & + + dens( ixp*nlons + iy , j, it) *vscale(:,k)*delx *delyp & + + dens( ix*nlons + iyp, j, it) *vscale(:,k)*delxp*dely & + + dens( ixp*nlons + iyp, j, it) *vscale(:,k)*delx *dely )*deltp & + + ( dens( ix*nlons + iy , j, itp)*vscale(:,k)*delxp*delyp & + + dens( ixp*nlons + iy , j, itp)*vscale(:,k)*delx *delyp & + + dens( ix*nlons + iyp, j, itp)*vscale(:,k)*delxp*dely & + + dens( ixp*nlons + iyp, j, itp)*vscale(:,k)*delx *dely )*delt) + enddo + + return +end subroutine calc_linhx_modens + +end module observer_enkf diff --git a/src/enkf/observer_nmmb.f90 b/src/enkf/observer_nmmb.f90 new file mode 120000 index 000000000..faa9da004 --- /dev/null +++ b/src/enkf/observer_nmmb.f90 @@ -0,0 +1 @@ +observer_reg.f90 \ No newline at end of file diff --git a/src/enkf/observer_reg.f90 b/src/enkf/observer_reg.f90 new file mode 100644 index 000000000..687b8b9ea --- /dev/null +++ b/src/enkf/observer_reg.f90 @@ -0,0 +1,270 @@ +module observer_enkf +use general_tll2xy_mod, only: llxy_cons +use statevec, only: nsdim, ns3d, ns2d, slevels +use params, only: nlevs, neigv + +private +public init_observer_enkf, setup_linhx, calc_linhx, calc_linhx_modens,& + destroy_observer_enkf +integer, allocatable, dimension(:) :: kindx + +type(llxy_cons) :: gt_data + + +contains + +subroutine init_observer_enkf + use kinds, only: r_kind, i_kind + use params, only: nlons, nlats + use gridinfo, only: latsgrd, lonsgrd + use general_tll2xy_mod, only: general_create_llxy_transform + implicit none + + integer(i_kind) :: i, j + integer(i_kind) :: nn,n,k,nl + real(r_kind), dimension(nlats, nlons) :: lats, lons + + + do i = 1,nlons + do j = 1,nlats + lats(j,i) = latsgrd((j-1)*nlons+i) + lons(j,i) = lonsgrd((j-1)*nlons+i) + enddo + enddo + call general_create_llxy_transform(lats, lons, nlats, nlons, gt_data) + + nn = 0 + do n=1,ns3d + if (n .eq. 1) then + nl = slevels(n) + else + nl = slevels(n)-slevels(n-1) + endif + !print *,'ns3d,levs',n,nl + do k=1,nl + nn = nn + 1 + kindx(nn) = k + ! FIXME - deal with state variables with nlevs+1 levels (like prse) + if (kindx(nn) > nlevs) kindx(nn)=nlevs + enddo + enddo + do n=1,ns2d ! 2d fields are treated as surface fields. + nn = nn + 1 + kindx(nn) = 1 + enddo + +end subroutine init_observer_enkf + +subroutine destroy_observer_enkf + if (allocated(kindx)) deallocate(kindx) +end subroutine destroy_observer_enkf + +subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_linhx +! prgmmr: shlyaeva org: esrl/psd date: 2016-11-29 +! +! abstract: +! +! program history log: +! 2018-09-05 Guoqing Ge -Added this fuction in observer_wrf to be +! consistent with observer_gfs.f90 +! +! input argument list: +! rlat: latitude of ob +! rlon: longitude of ob +! time: time offset for ob +! +! output argument list: +! ix,delx,ixp,delxp,iy,dely,iyp,delyp,it,delt,itp,deltp: horizontal +! and temporal linear interpolation indices and weights. +! +! attributes: +! language: f95 +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use params, only: nstatefields, nlons, nlats, nlevs, nhr_state, fhr_assim + use gridinfo, only: npts, latsgrd, lonsgrd + use statevec, only: nsdim + use constants, only: zero,one,pi + use general_tll2xy_mod, only: general_tll2xy + use mpisetup + implicit none + +! Declare passed variables + real(r_single) ,intent(in ) :: rlat, rlon ! observation lat and lon in radians + real(r_single) ,intent(in ) :: time ! observation time relative to middle of window + integer(i_kind), intent(out) :: ix, iy, it, ixp, iyp, itp + real(r_kind), intent(out) :: delx, dely, delxp, delyp, delt, deltp + real(r_kind) :: dx, dy + logical :: outside + + call general_tll2xy(gt_data, real(rlon,r_kind), real(rlat,r_kind), dx, dy, outside) + + ix = max(1,min(int(dx),nlons)) + iy = max(1,min(int(dy),nlats)) + + delx = max(zero, min(dx - float(ix), one)) + dely = max(zero, min(dy - float(iy), one)) + + ixp = min(ix + 1, nlons) + iyp = min(iy + 1, nlats) + + iy = iy - 1; iyp = iyp - 1 + + it = 1 + do while (time + fhr_assim > nhr_state(it) .and. it < nstatefields) + it = it + 1 + enddo + itp = it + it = max(1,itp-1) + if (it /= itp) then + delt = (time + fhr_assim - nhr_state(it)) / (nhr_state(itp) - nhr_state(it)) + else + delt = one + endif + + deltp = one - delt + delxp = one - delx + delyp = one - dely + +end subroutine setup_linhx + +subroutine calc_linhx(hx, dens, dhx_dx, hx_ens, & + ix, delx, ixp, delxp, iy, dely, iyp, delyp, & + it, delt, itp, deltp) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_linhx +! prgmmr: shlyaeva org: esrl/psd date: 2016-11-29 +! +! abstract: +! +! program history log: +! 2016-11-29 shlyaeva +! +! input argument list: +! hx: observation prior ensemble mean +! dens: state space ensemble perturbations +! dhx_dx: Jacobian +! ix,delx,ixp,delxp,iy,dely,iyp,delyp,it,delt,itp,deltp: horizontal +! and temporal linear interpolation indices and weights. +! +! output argument list: +! hx_ens: observation prior ensemble perturbation +! +! attributes: +! language: f95 +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use params, only: nstatefields, nlons, nlats, nlevs, nhr_state, fhr_assim + use gridinfo, only: npts, latsgrd, lonsgrd + use statevec, only: nsdim + use constants, only: zero,one,pi + use sparsearr, only: sparr + use mpisetup + implicit none + +! Declare passed variables + real(r_single) ,intent(in ) :: hx ! H(x_mean) + real(r_single),dimension(npts,nsdim,nstatefields),intent(in ) :: dens ! x_ens - x_mean, state vector space + integer(i_kind), intent(in) :: ix, iy, it, ixp, iyp, itp + real(r_kind), intent(in) :: delx, dely, delxp, delyp, delt, deltp + type(sparr) ,intent(in ) :: dhx_dx ! dH(x)/dx |x_mean profiles + real(r_single) ,intent( out) :: hx_ens ! H (x_ens) + integer(i_kind) i,j,k + + ! interpolate state horizontally and in time and do dot product with dHx/dx profile + ! saves from calculating interpolated x_ens for each state variable + hx_ens = hx + do i = 1, dhx_dx%nnz + j = dhx_dx%ind(i) + k = kindx(j) + hx_ens = hx_ens + dhx_dx%val(i) * & + (( dens( ix*nlons + iy , j, it) *delxp*delyp & + + dens( ixp*nlons + iy , j, it) *delx *delyp & + + dens( ix*nlons + iyp, j, it) *delxp*dely & + + dens( ixp*nlons + iyp, j, it) *delx *dely )*deltp & + + ( dens( ix*nlons + iy , j, itp)*delxp*delyp & + + dens( ixp*nlons + iy , j, itp)*delx *delyp & + + dens( ix*nlons + iyp, j, itp)*delxp*dely & + + dens( ixp*nlons + iyp, j, itp)*delx *dely )*delt) + enddo + + return +end subroutine calc_linhx + +subroutine calc_linhx_modens(hx, dens, dhx_dx, hx_ens, & + ix, delx, ixp, delxp, iy, dely, iyp, delyp, & + it, delt, itp, deltp, vscale) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_linhx +! prgmmr: shlyaeva org: esrl/psd date: 2016-11-29 +! +! abstract: +! +! program history log: +! 2016-11-29 shlyaeva +! +! input argument list: +! hx: observation prior ensemble mean +! dens: state space ensemble perturbations +! dhx_dx: Jacobian +! ix,delx,ixp,delxp,iy,dely,iyp,delyp,it,delt,itp,deltp: horizontal +! and temporal linear interpolation indices and weights. +! +! output argument list: +! hx_ens: observation prior ensemble perturbation for each verticali +! localization eigenvector +! vscale: vertical scaling from vertical localization eigenvectors used +! to generate modulated ensemble. +! +! attributes: +! language: f95 +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use params, only: nstatefields, nlons, nlats, nlevs, nhr_state, fhr_assim + use gridinfo, only: npts, latsgrd, lonsgrd + use statevec, only: nsdim + use constants, only: zero,one,pi + use sparsearr, only: sparr + use mpisetup + implicit none + +! Declare passed variables + real(r_single) ,intent(in ) :: hx ! H(x_mean) + real(r_single),dimension(npts,nsdim,nstatefields),intent(in ) :: dens ! x_ens - x_mean, state vector space + integer(i_kind), intent(in) :: ix, iy, it, ixp, iyp, itp + real(r_kind), intent(in) :: delx, dely, delxp, delyp, delt, deltp + type(sparr) ,intent(in ) :: dhx_dx ! dH(x)/dx |x_mean profiles + real(r_single) ,intent( out) :: hx_ens(neigv)! H (x_ens) + real(r_double),dimension(neigv,nlevs+1) ,intent(in ) :: vscale ! vertical scaling (for modulated ens) + integer(i_kind) i,j,k + + ! interpolate state horizontally and in time and do dot product with dHx/dx profile + ! saves from calculating interpolated x_ens for each state variable + hx_ens = hx + do i = 1, dhx_dx%nnz + j = dhx_dx%ind(i) + k = kindx(j) + hx_ens(:) = hx_ens(:) + dhx_dx%val(i) * & + (( dens( ix*nlons + iy , j, it) *vscale(:,k)*delxp*delyp & + + dens( ixp*nlons + iy , j, it) *vscale(:,k)*delx *delyp & + + dens( ix*nlons + iyp, j, it) *vscale(:,k)*delxp*dely & + + dens( ixp*nlons + iyp, j, it) *vscale(:,k)*delx *dely )*deltp & + + ( dens( ix*nlons + iy , j, itp)*vscale(:,k)*delxp*delyp & + + dens( ixp*nlons + iy , j, itp)*vscale(:,k)*delx *delyp & + + dens( ix*nlons + iyp, j, itp)*vscale(:,k)*delxp*dely & + + dens( ixp*nlons + iyp, j, itp)*vscale(:,k)*delx *dely )*delt) + enddo + + return +end subroutine calc_linhx_modens + +end module observer_enkf diff --git a/src/enkf/observer_wrf.f90 b/src/enkf/observer_wrf.f90 new file mode 120000 index 000000000..faa9da004 --- /dev/null +++ b/src/enkf/observer_wrf.f90 @@ -0,0 +1 @@ +observer_reg.f90 \ No newline at end of file diff --git a/src/enkf/params.f90 b/src/enkf/params.f90 index 638b5be92..9757a58a7 100644 --- a/src/enkf/params.f90 +++ b/src/enkf/params.f90 @@ -15,6 +15,7 @@ module params ! (over-riding defaults for parameters supplied in namelist), compute ! some derived parameters. Sets logical variable params_initialized ! to .true. +! cleanup_namelist: deallocate memory allocated in read_namelist ! ! Public Variables: (see comments in subroutine read_namelist) ! @@ -22,6 +23,13 @@ module params ! ! program history log: ! 2009-02-23 Initial version. +! 2016-05-02 shlyaeva - Modification for reading state vector from table +! 2016-11-29 shlyaeva - added nhr_state (hours for state fields to +! calculate Hx; nhr_anal is for IAU) +! 2018-05-31 whitaker - added modelspace_vloc (for model-space localization using +! modulated ensembles), nobsl_max (for ob selection +! in LETKF and dfs_sort +! (for using DFS in LETKF ob selection). ! ! attributes: ! language: f95 @@ -35,7 +43,7 @@ module params implicit none private -public :: read_namelist +public :: read_namelist,cleanup_namelist ! nsats_rad: the total number of satellite data types to read. ! sattypes_rad: strings describing the satellite data type (which form part ! of the diag* filename). @@ -48,11 +56,13 @@ module params character(len=20), public, dimension(nsatmax_rad) ::sattypes_rad, dsis character(len=20), public, dimension(nsatmax_oz) ::sattypes_oz ! forecast times for first-guess forecasts to be updated (in hours) -integer,dimension(7),public :: nhr_anal = (/6,-1,-1,-1,-1,-1,-1/) +integer,dimension(7),public :: nhr_anal = (/6,-1,-1,-1,-1,-1,-1/) +integer,dimension(7),public :: nhr_state = (/6,-1,-1,-1,-1,-1,-1/) ! forecast hour at middle of assimilation window real(r_single),public :: fhr_assim=6.0 ! character string version of nhr_anal with leading zeros. character(len=2),dimension(7),public :: charfhr_anal +character(len=2),dimension(7),public :: charfhr_state ! prefix for background and analysis file names (mem### appended) ! For global, default is "sfg_"//datestring//"_fhr##_" and ! "sanl_"//datestring//"_fhr##_". If only one time level @@ -61,6 +71,7 @@ module params ! "analysis_fhr##." If only one time level ! in background, default is "firstguess." and "analysis.". character(len=120),dimension(7),public :: fgfileprefixes +character(len=120),dimension(7),public :: statefileprefixes character(len=120),dimension(7),public :: anlfileprefixes ! analysis date string (YYYYMMDDHH) character(len=10), public :: datestring @@ -70,10 +81,12 @@ module params ! update is used. If .false, a perturbed obs (stochastic) update ! is used. logical, public :: deterministic, sortinc, pseudo_rh, & - varqc, huber, cliptracers, readin_localization,& - lupp -integer(i_kind),public :: iassim_order,nlevs,nanals,nvars,numiter,& - nlons,nlats,ndim,nbackgrounds + varqc, huber, cliptracers, readin_localization +logical, public :: lupp +integer(i_kind),public :: iassim_order,nlevs,nanals,numiter,& + nlons,nlats,nbackgrounds,nstatefields,& + nanals_per_iotask, ntasks_io +integer(i_kind),public, allocatable, dimension(:) :: nanal1,nanal2 integer(i_kind),public :: nsats_rad,nsats_oz,imp_physics ! random seed for perturbed obs (deterministic=.false.) ! if zero, system clock is used. Also used when @@ -87,9 +100,12 @@ module params lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,& lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh real(r_single),public :: analpertwtnh,analpertwtsh,analpertwttr,sprd_tol,saterrfact +real(r_single),public :: analpertwtnh_rtpp,analpertwtsh_rtpp,analpertwttr_rtpp real(r_single),public :: paoverpb_thresh,latbound,delat,p5delat,delatinv real(r_single),public :: latboundpp,latboundpm,latboundmp,latboundmm real(r_single),public :: covl_minfact, covl_efold + +real(r_single),public :: covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff ! if npefiles=0, diag files are read (concatenated pe* files written by gsi) ! if npefiles>0, npefiles+1 pe* files read directly ! the pe* files are assumed to be located in /gsitmp_mem### @@ -99,11 +115,34 @@ module params ! default is -1, which means take all obs within ! specified localization radius. if nobsl_max > 0, ! only the first nobsl_max closest obs within the -! localization radius will be used. Ignored -! if letkf_flag = .false. +! localization radius will be used. +! Ignored if letkf_flag = .false. +! If dfs_sort=T, DFS is used instead of distance +! for ob selection. integer,public :: nobsl_max = -1 +! do model-space vertical localization +! if .true., eigenvectors of the localization +! matrix are read from a file called 'vlocal_eig.dat' +! (created by an external python utility). +logical,public :: modelspace_vloc=.false. +! number of eigenvectors of vertical localization +! used. Zero if modelspace_vloc=.false., read from +! file 'vlocal_eig.dat' if modelspace_vloc=.true. +integer,public :: neigv = 0 +real(r_double) :: vlocal_eval +real(r_double),public,dimension(:,:), allocatable :: vlocal_evecs logical,public :: params_initialized = .true. logical,public :: save_inflation = .false. +! use gain form of LETKF (reset to true if modelspace_vloc=T) +logical,public :: getkf = .false. +! turn on getkf inflation (when modelspace_vloc=T and +! letkf_flag=T, posterior variance inflated to match +! variance of modulated ensemble). +logical, public :: getkf_inflation=.false. +! use DEnKF approx to EnKF perturbation update. +! Implies getkf=T if letkf_flag=T +! See Sakov and Oke 2008 https://doi.org/10.1111/j.1600-0870.2007.00299.x +logical, public :: denkf=.false. ! do sat bias correction update. logical,public :: lupd_satbiasc = .false. ! do ob space update with serial filter (only used if letkf_flag=.true.) @@ -122,7 +161,13 @@ module params logical,public :: nmm_restart = .true. logical,public :: nmmb = .false. logical,public :: letkf_flag = .false. -logical,public :: massbal_adjust = .false. + +! next two are no longer used, instead they are inferred from anavinfo +logical,public :: massbal_adjust = .false. +integer(i_kind),public :: nvars = -1 + +! sort obs in LETKF in order of decreasing DFS +logical,public :: dfs_sort = .false. ! if true generate additional input files ! required for EFSO calculations @@ -137,8 +182,21 @@ module params ! when pseudo_rh=.true. If pseudo_rh=.false, use_qsatensmean ! is ignored. logical,public :: use_qsatensmean = .false. - -namelist /nam_enkf/datestring,datapath,iassim_order,& +logical,public :: write_spread_diag = .false. +! if true, use jacobian from GSI stored in diag file to compute +! ensemble perturbations in observation space. +logical,public :: lobsdiag_forenkf = .false. +! if true, use netcdf diag files, otherwise use binary diags +logical,public :: netcdf_diag = .false. + +! use fv3 cubed-sphere tiled restart files +logical,public :: fv3_native = .false. +character(len=500),public :: fv3fixpath = ' ' +integer(i_kind),public :: ntiles=6 +integer(i_kind),public :: nx_res=0,ny_res=0 +logical,public ::l_pres_add_saved + +namelist /nam_enkf/datestring,datapath,iassim_order,nvars,& covinflatemax,covinflatemin,deterministic,sortinc,& corrlengthnh,corrlengthtr,corrlengthsh,& varqc,huber,nlons,nlats,smoothparm,use_qsatensmean,& @@ -147,39 +205,56 @@ module params lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh,& lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,& lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh,& - fgfileprefixes,anlfileprefixes,covl_minfact,covl_efold,& + fgfileprefixes,anlfileprefixes,statefileprefixes,& + covl_minfact,covl_efold,lupd_obspace_serial,letkf_novlocal,& analpertwtnh,analpertwtsh,analpertwttr,sprd_tol,& - fgfileprefixes,anlfileprefixes,lupd_obspace_serial,letkf_novlocal,& - nlevs,nanals,nvars,saterrfact,univaroz,regional,use_gfs_nemsio,& + analpertwtnh_rtpp,analpertwtsh_rtpp,analpertwttr_rtpp,& + nlevs,nanals,saterrfact,univaroz,regional,use_gfs_nemsio,& paoverpb_thresh,latbound,delat,pseudo_rh,numiter,biasvar,& lupd_satbiasc,cliptracers,simple_partition,adp_anglebc,angord,& - newpc4pred,nmmb,nhr_anal,fhr_assim,nbackgrounds,save_inflation,nobsl_max,& + newpc4pred,nmmb,nhr_anal,nhr_state, fhr_assim,nbackgrounds,nstatefields, & + save_inflation,nobsl_max,lobsdiag_forenkf,netcdf_diag,& letkf_flag,massbal_adjust,use_edges,emiss_bc,iseed_perturbed_obs,npefiles,& - fso_cycling,fso_calculate,imp_physics,lupp + getkf,getkf_inflation,denkf,modelspace_vloc,dfs_sort,write_spread_diag,& + covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff,& + fso_cycling,fso_calculate,imp_physics,lupp,fv3_native namelist /nam_wrf/arw,nmm,nmm_restart +namelist /nam_fv3/fv3fixpath,nx_res,ny_res,ntiles,l_pres_add_saved namelist /satobs_enkf/sattypes_rad,dsis namelist /ozobs_enkf/sattypes_oz - contains subroutine read_namelist() -integer i,nb +integer i,j,nb,np +logical fexist +real(r_single) modelspace_vloc_cutoff, modelspace_vloc_thresh ! have all processes read namelist from file enkf.nml ! defaults ! time (analysis time YYYYMMDDHH) datestring = "0000000000" ! if 0000000000 will not be used. ! corrlength (length for horizontal localization in km) -corrlengthnh = 2800 -corrlengthtr = 2800 -corrlengthsh = 2800 +! this corresponding GSI parameter is s_ens_h. +! corrlength is the distance at which the Gaspari-Cohn +! polynomial goes to zero. s_ens_h is the scale of a +! Gaussian exp(-0.5*(r/L)**2) so +! corrlength ~ sqrt(2/0.15)*s_ens_h +corrlengthnh = 2800_r_single +corrlengthtr = 2800_r_single +corrlengthsh = 2800_r_single ! read in localization length scales from an external file. readin_localization = .false. ! min and max inflation. covinflatemin = 1.0_r_single covinflatemax = 1.e30_r_single ! lnsigcutoff (length for vertical localization in ln(p)) +! **these are ignored if modelspace_vloc=.true.** +! this corresponding GSI parameter is -s_ens_v (if s_ens_v<0) +! lnsigcutoff is the distance at which the Gaspari-Cohn +! polynomial goes to zero. s_ens_v is the scale of a +! Gaussian exp(-(r/L)**2) so +! lnsigcutoff ~ s_ens_v/sqrt(0.15) lnsigcutoffnh = 2._r_single lnsigcutofftr = 2._r_single lnsigcutoffsh = 2._r_single @@ -190,20 +265,20 @@ subroutine read_namelist() lnsigcutoffpstr = -999._r_single ! value for surface pressure lnsigcutoffpssh = -999._r_single ! value for surface pressure ! ob time localization -obtimelnh = 1.e10 -obtimeltr = 1.e10 -obtimelsh = 1.e10 +obtimelnh = 1.e10_r_single +obtimeltr = 1.e10_r_single +obtimelsh = 1.e10_r_single ! min localization reduction factor for adaptive localization ! based on HPaHt/HPbHT. Default (1.0) means no adaptive localization. ! 0.25 means minimum localization is 0.25*corrlength(nh,tr,sh). -covl_minfact = 1.0 +covl_minfact = 1.0_r_single ! efolding distance for adapative localization. ! Localization reduction factor is 1. - exp( -((1.-paoverpb)/covl_efold) ) ! When 1-pavoerpb=1-HPaHt/HPbHt=cov_efold localization scales reduced by ! factor of 1-1/e ~ 0.632. When paoverpb==>1, localization scales go to zero. ! When paoverpb==>1, localization scales not reduced. -covl_efold = 1.e-10 -! path to data directory (include trailing slash) +covl_efold = 1.e-10_r_single +! path to data directory datapath = " " ! mandatory ! tolerance for background check. ! obs are not used if they are more than sqrt(S+R) from mean, @@ -212,10 +287,16 @@ subroutine read_namelist() ! definition of tropics and mid-latitudes (for inflation). latbound = 25._r_single ! this is where the tropics start delat = 10._r_single ! width of transition zone. -! adaptive posterior inflation parameter. +! RTPS inflation coefficients. analpertwtnh = 0.0_r_single ! no inflation (1 means inflate all the way back to prior spread) analpertwtsh = 0.0_r_single analpertwttr = 0.0_r_single +! RTPP inflation coefficients. +analpertwtnh_rtpp = 0.0_r_single ! no inflation (1 means inflate all the way back to prior perturbation) +analpertwtsh_rtpp = 0.0_r_single +analpertwttr_rtpp = 0.0_r_single +! lnsigcovinfcutoff (length for vertical taper in inflation in ln(sigma)) +lnsigcovinfcutoff = 1.0e30_r_single ! if ob space posterior variance divided by prior variance ! less than this value, ob is skipped during serial processing. paoverpb_thresh = 1.0_r_single! don't skip any obs @@ -233,7 +314,7 @@ subroutine read_namelist() ! type of GFS microphyics. ! 99: Zhao-Carr, 11: GFDL imp_physics = 99 -! lupp, if true output extra variables +! lupp, if true output extra variables (deprecated, does not do anything) lupp = .false. ! these are all mandatory. ! nlons and nlats are # of lons and lats @@ -243,9 +324,6 @@ subroutine read_namelist() nlevs = 0 ! number of ensemble members nanals = 0 -! nvars is number of 3d variables to update. -! for hydrostatic models, typically 5 (u,v,T,q,ozone). -nvars = 5 ! background error variance for rad bias coeffs (used in radbias.f90) ! default is (old) GSI value. ! if negative, bias coeff error variace is set to -biasvar/N, where @@ -281,8 +359,8 @@ subroutine read_namelist() ! Initialize first-guess and analysis file name prefixes. ! (blank means use default names) -fgfileprefixes = ''; anlfileprefixes='' - +fgfileprefixes = ''; anlfileprefixes=''; statefileprefixes='' +l_pres_add_saved=.true. ! read from namelist file, doesn't seem to work from stdin with mpich open(912,file='enkf.nml',form="formatted") read(912,nam_enkf) @@ -291,6 +369,10 @@ subroutine read_namelist() if (regional) then read(912,nam_wrf) endif +if (fv3_native) then + read(912,nam_fv3) + nlons = nx_res; nlats = ny_res ! (total number of pts = ntiles*res*res) +endif close(912) ! find number of satellite files @@ -325,14 +407,105 @@ subroutine read_namelist() latboundmm=-latbound-p5delat delatinv=1.0_r_single/delat +! if modelspace_vloc, use modulated ensemble to compute Kalman gain (but use +! this gain to update only original ensemble). +if (modelspace_vloc) then + ! read in eigenvalues/vectors of vertical localization matrix on all tasks + ! (text file vlocal_eig.dat must exist) + inquire(file='vlocal_eig.dat',exist=fexist) + if ( fexist ) then + open(7,file='vlocal_eig.dat',status="old",action="read") + else + if (nproc .eq. 0) print *, 'error: vlocal_eig.dat does not exist' + call stop2(19) + endif + read(7,*) neigv,modelspace_vloc_thresh,modelspace_vloc_cutoff + if (neigv < 1) then + if (nproc .eq. 0) print *, 'error: neigv must be greater than zero' + call stop2(19) + endif + allocate(vlocal_evecs(neigv,nlevs+1)) + if (nproc .eq. 0) then + print *,'model-space vertical localization enabled' + print *,'lnsigcutoff* values read from namelist ignored!' + print *,'neigv = ',neigv + print *,'vertical localization cutoff distance (lnp units) =',& + modelspace_vloc_cutoff + print *,'eigenvector truncation threshold = ',modelspace_vloc_thresh + print *,'vertical localization eigenvalues' + endif + do i = 1,neigv + read(7,*) vlocal_eval + if (nproc .eq. 0) print *,i,vlocal_eval + do j = 1,nlevs + read(7,*) vlocal_evecs(i,j) + enddo + ! nlevs+1 same as level 1 (2d variables treated as surface) + vlocal_evecs(i,nlevs+1) = vlocal_evecs(i,1) + enddo + close(7) + if (.not. lobsdiag_forenkf) then + if (nproc .eq. 0) then + print *,'lobsdiag_forenkf must be true if modelspace_vloc==.true.' + endif + call stop2(19) + endif + if (letkf_flag .and. .not. letkf_novlocal) then + if (nproc .eq. 0) print *,"modelspace_vloc=T and letkf_flag=T, re-setting letkf_novlocal to T" + letkf_novlocal = .true. + endif + if (letkf_flag .and. .not. getkf) then + if (nproc .eq. 0) print *,"modelspace_vloc=T and getkf=F, re-setting getkf to T" + getkf = .true. + endif + ! set vertical localization parameters to very large values + ! (turns vertical localization off for serial filter) + lnsigcutoffnh = 1.e30_r_single + lnsigcutoffsh = 1.e30_r_single + lnsigcutofftr = 1.e30_r_single + lnsigcutoffsatnh = 1.e30_r_single + lnsigcutoffsatsh = 1.e30_r_single + lnsigcutoffsattr = 1.e30_r_single + lnsigcutoffpsnh = 1.e30_r_single + lnsigcutoffpssh = 1.e30_r_single + lnsigcutoffpstr = 1.e30_r_single +endif + +if (nanals <= numproc) then + ! one ensemble member read in on each of first nanals tasks. + ntasks_io = nanals + nanals_per_iotask = 1 + allocate(nanal1(0:ntasks_io-1),nanal2(0:ntasks_io-1)) + do np=0,ntasks_io-1 + nanal1(np) = np+1 + nanal2(np) = np+1 + enddo +else + nanals_per_iotask = 1 + do + ntasks_io = nanals/nanals_per_iotask + if (ntasks_io <= numproc .and. mod(nanals,nanals_per_iotask) .eq. 0) then + exit + else + nanals_per_iotask = nanals_per_iotask + 1 + end if + end do + allocate(nanal1(0:ntasks_io-1),nanal2(0:ntasks_io-1)) + do np=0,ntasks_io-1 + nanal1(np) = 1 + np*nanals_per_iotask + nanal2(np) = (np+1)*nanals_per_iotask + enddo +endif + ! have to do ob space update for serial filter (not for LETKF). -if (.not. letkf_flag .and. numiter < 1) numiter = 1 +if ((.not. letkf_flag .or. lupd_obspace_serial) .and. numiter < 1) numiter = 1 if (nproc == 0) then print *,'namelist parameters:' print *,'--------------------' write(6,nam_enkf) + write(6,nam_fv3) print *,'--------------------' ! check for mandatory namelist variables @@ -342,12 +515,17 @@ subroutine read_namelist() print *,nlons,nlats,nlevs,nanals call stop2(19) end if - if (numproc .lt. nanals) then - print *,'total number of mpi tasks must be >= nanals' - print *,'tasks, nanals = ',numproc,nanals + if (numproc .lt. ntasks_io) then + print *,'total number of mpi tasks must be >= ntasks_io' + print *,'tasks, nanals, ntasks_io = ',numproc,nanals,ntasks_io call stop2(19) endif - if (datapath == ' ') then + print *,'ntasks_io = ',ntasks_io + print *,'nanals_per_iotask = ',nanals_per_iotask + !do np=0,ntasks_io-1 + ! print *,'task,nanal1,nanal2',np+1,nanal1(np),nanal2(np) + !enddo + if (trim(datapath) == '') then print *,'need to specify datapath in namelist!' call stop2(19) end if @@ -355,6 +533,10 @@ subroutine read_namelist() print *, 'must select either arw, nmm or nmmb regional dynamical core' call stop2(19) endif + if (fv3_native .and. (trim(fv3fixpath) == '' .or. nx_res == 0 .or. ny_res == 0 )) then + print *, 'must specify nx_res,ny_res and fv3fixpath when fv3_native is true' + call stop2(19) + endif if (letkf_flag .and. univaroz) then print *,'univaroz is not supported in LETKF!' call stop2(19) @@ -364,10 +546,23 @@ subroutine read_namelist() print *,'warning: no time localization in LETKF!' endif + print *, trim(adjustl(datapath)) if (datestring .ne. '0000000000') print *, 'analysis time ',datestring - print *, nanals,' members' + if (neigv > 0) then + print *,nanals,' (unmodulated) members' + print *,neigv,' eigenvectors for vertical localization' + print *,nanals*neigv,' modulated ensemble members' + else + print *,nanals,' members' + endif +! check for deprecated namelist variables + if (nvars > 0 .or. massbal_adjust) then + print *,'WARNING: nvars and massbal_adjust are no longer used!' + print *,'They are inferred from the anavinfo file instead.' + endif + end if ! background forecast time for analysis @@ -388,6 +583,26 @@ subroutine read_namelist() endif nbackgrounds = nbackgrounds+1 end do + +! state fields +nstatefields=0 +do while (nhr_state(nstatefields+1) > 0) + write(charfhr_state(nstatefields+1),'(i2.2)') nhr_state(nstatefields+1) + if (trim(statefileprefixes(nstatefields+1)) .eq. "") then + ! default first-guess file prefix + if (regional) then + if (nstatefields > 1) then + statefileprefixes(nstatefields+1)="firstguess_fhr"//charfhr_state(nstatefields+1)//"." + else + statefileprefixes(nstatefields+1)="firstguess." + endif + else ! global + statefileprefixes(nstatefields+1)="sfg_"//datestring//"_fhr"//charfhr_state(nstatefields+1)//"_" + endif + endif + nstatefields = nstatefields+1 +end do + do nb=1,nbackgrounds if (trim(anlfileprefixes(nb)) .eq. "") then ! default analysis file prefix @@ -406,36 +621,23 @@ subroutine read_namelist() endif endif enddo + +if (nproc .eq. 0) then + print *,'number of background forecast times to be used for H(x) = ',nstatefields + print *,'first-guess forecast hours for observation operator = ',& + charfhr_state(1:nstatefields) +endif + if (nproc .eq. 0) then print *,'number of background forecast times to be updated = ',nbackgrounds print *,'first-guess forecast hours for analysis = ',& charfhr_anal(1:nbackgrounds) endif -! total number of 2d grids to update. -if (massbal_adjust) then - if (regional .or. nmmb) then - if (nproc .eq. 0) print *,'mass balance adjustment only implemented for GFS' - massbal_adjust = .false. - ndim = nlevs*nvars+1 - else - if (nproc .eq. 0) print *,'add ps tend as analysis var, so mass balance adjustment can be done' - ndim = nlevs*nvars+2 ! including surface pressure and ps tendency. - endif -else - ndim = nlevs*nvars+1 ! including surface pressure and ps tendency. -endif - call init_constants(.false.) ! initialize constants. call init_constants_derived() if (nproc == 0) then - print *,nvars,'3d vars to update' - if (massbal_adjust) then - print *,'total of',ndim,' 2d grids will be updated (including ps and ps tend)' - else - print *,'total of',ndim,' 2d grids will be updated (including ps)' - endif if (analpertwtnh > 0) then print *,'using multiplicative inflation based on Pa/Pb' else if (analpertwtnh < 0) then @@ -460,6 +662,28 @@ subroutine read_namelist() print *,'setting lupd_obspace_serial to .false., since letkf_flag is .false.' endif endif + +! set lupd_obspace_serial to .true. if letkf_flag is true +! and numiter > 0. +if (letkf_flag .and. .not. lupd_obspace_serial .and. numiter > 0) then + lupd_obspace_serial = .true. + if (nproc == 0) then + print *,'setting lupd_obspace_serial to .true., since letkf_flag is .true. and numiter > 0' + endif +endif + +if (datapath(len_trim(datapath):len_trim(datapath)) .ne. '/') then + ! add trailing slash if needed + if (nproc .eq. 0) print *,'adding trailing slash to datapath..' + datapath = trim(datapath)//'/' +endif + end subroutine read_namelist +subroutine cleanup_namelist + if (allocated(nanal1)) deallocate(nanal1) + if (allocated(nanal2)) deallocate(nanal2) + if (allocated(vlocal_evecs)) deallocate(vlocal_evecs) +end subroutine cleanup_namelist + end module params diff --git a/src/enkf/radbias.f90 b/src/enkf/radbias.f90 index 585808f72..efa62941a 100644 --- a/src/enkf/radbias.f90 +++ b/src/enkf/radbias.f90 @@ -67,8 +67,8 @@ subroutine apply_biascorr() nn = nn + 1 if (indxsat(nn) == 0) cycle if (.not. adp_anglebc) then - ! angle-dependent, non-adaptive correction. - ensmean_ob(nob) = ensmean_obnobc(nob) + biaspreds(1,nn) + ! total angle-dependent bias correction + ensmean_ob(nob) = ensmean_obnobc(nob) + biaspreds(npred+1,nn) else ! angle dependent correction is included in adaptive part. ensmean_ob(nob) = ensmean_obnobc(nob) @@ -76,7 +76,7 @@ subroutine apply_biascorr() ! adaptive (air-mass) corrections. do np=1,npred ensmean_ob(nob) = ensmean_ob(nob) + & - biaspreds(np+1,nn)*(predx(np,indxsat(nn))+deltapredx(np,indxsat(nn))) + biaspreds(np,nn)*(predx(np,indxsat(nn))+deltapredx(np,indxsat(nn))) enddo enddo end subroutine apply_biascorr @@ -153,7 +153,7 @@ subroutine update_biascorr(niter) ! only use the numobspersat(i) obs associated with this channel/instrument if (indxsat(m) == i) then nn = nn + 1 - biaspredtmp(n,nn) = biaspreds(n+1,m)/sqrt(oberrvar(nobs_conv+nobs_oz+m)) + biaspredtmp(n,nn) = biaspreds(n,m)/sqrt(oberrvar(nobs_conv+nobs_oz+m)) end if enddo a(n,n) = 1._r_kind/biaserrvar @@ -181,7 +181,7 @@ subroutine update_biascorr(niter) do m=1,nobs_sat if (indxsat(m) == i) then nn = nn + 1 - biaspredtmp(n,nn) = biaspreds(n+1,m)/oberrvar(nobs_conv+nobs_oz+m) + biaspredtmp(n,nn) = biaspreds(n,m)/oberrvar(nobs_conv+nobs_oz+m) end if enddo enddo diff --git a/src/enkf/read_fv3reg_restarts.f90 b/src/enkf/read_fv3reg_restarts.f90 new file mode 100644 index 000000000..8c9e31767 --- /dev/null +++ b/src/enkf/read_fv3reg_restarts.f90 @@ -0,0 +1,78 @@ + module read_fv3regional_restarts +! modified from read_fv3_restarts.f90 + +! ifort -I${NETCDF}/include -O2 -traceback read_fv3_restarts.f90 kinds.o +! netcdf_mod.o -L/${NETCDF}/lib -lnetcdf -lnetcdff + +! read data from FV3 restart files. + + + use kinds, only: i_kind,r_single,r_kind + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_inq_dimid,nf90_inq_varid + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf_mod, only: nc_check + public read_fv3_restart_data1d,read_fv3_restart_data2d + public read_fv3_restart_data3d,read_fv3_restart_data4d + + contains + + subroutine read_fv3_restart_data1d(varname,filename,file_id,data_arr) + real(r_single), intent(inout), dimension(:) :: data_arr + character(len=24),parameter :: myname_ = 'read_fv3_restart_data1d' + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + integer(i_kind), intent(in) :: file_id + integer(i_kind) :: var_id + call nc_check( nf90_inq_varid(file_id,trim(adjustl(varname)),var_id),& + myname_,'inq_varid '//trim(adjustl(varname))//' '//trim(filename) ) + call nc_check( nf90_get_var(file_id,var_id,data_arr),& + myname_,'get_var '//trim(adjustl(varname))//' '//trim(filename) ) + data_arr=data_arr(ubound(data_arr,1):lbound(data_arr,1):-1) + end subroutine read_fv3_restart_data1d + + subroutine read_fv3_restart_data2d(varname,filename,file_id,data_arr) + real(r_single), intent(inout), dimension(:,:) :: data_arr + character(len=24),parameter :: myname_ = 'read_fv3_restart_data2d' + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + integer(i_kind), intent(in) :: file_id + integer(i_kind) :: var_id + call nc_check( nf90_inq_varid(file_id,trim(adjustl(varname)),var_id),& + myname_,'inq_varid '//trim(adjustl(varname))//' '//trim(filename) ) + call nc_check( nf90_get_var(file_id,var_id,data_arr),& + myname_,'get_var '//trim(adjustl(varname))//' '//trim(filename) ) + data_arr=data_arr(ubound(data_arr,1):lbound(data_arr,1):-1,ubound(data_arr,2):lbound(data_arr,2):-1) + end subroutine read_fv3_restart_data2d + + subroutine read_fv3_restart_data3d(varname,filename,file_id,data_arr) + real(r_single), intent(inout), dimension(:,:,:) :: data_arr + character(len=24),parameter :: myname_ = 'read_fv3_restart_data3d' + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + integer(i_kind), intent(in) :: file_id + integer(i_kind) :: var_id + call nc_check( nf90_inq_varid(file_id,trim(adjustl(varname)),var_id),& + myname_,'inq_varid '//trim(adjustl(varname))//' '//trim(filename) ) + call nc_check( nf90_get_var(file_id,var_id,data_arr),& + myname_,'get_var '//trim(adjustl(varname))//' '//trim(filename) ) + data_arr=data_arr(ubound(data_arr,1):lbound(data_arr,1):-1,ubound(data_arr,2):lbound(data_arr,2):-1, & + ubound(data_arr,3):lbound(data_arr,3):-1) + end subroutine read_fv3_restart_data3d + + subroutine read_fv3_restart_data4d(varname,filename,file_id,data_arr) + real(r_single), intent(inout), dimension(:,:,:,:) :: data_arr + character(len=24),parameter :: myname_ = 'read_fv3_restart_data4d' + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + integer(i_kind), intent(in) :: file_id + integer(i_kind) :: var_id + call nc_check( nf90_inq_varid(file_id,trim(adjustl(varname)),var_id),& + myname_,'inq_varid '//trim(adjustl(varname))//' '//trim(filename) ) + call nc_check( nf90_get_var(file_id,var_id,data_arr),& + myname_,'get_var '//trim(adjustl(varname))//' '//trim(filename) ) + data_arr=data_arr(ubound(data_arr,1):lbound(data_arr,1):-1,ubound(data_arr,2):lbound(data_arr,2):-1, & + ubound(data_arr,3):lbound(data_arr,3):-1,ubound(data_arr,4):lbound(data_arr,4):-1) + end subroutine read_fv3_restart_data4d + + end module read_fv3regional_restarts diff --git a/src/enkf/read_locinfo.f90 b/src/enkf/read_locinfo.f90 index 8a058fd44..415cd0fb4 100644 --- a/src/enkf/read_locinfo.f90 +++ b/src/enkf/read_locinfo.f90 @@ -3,7 +3,7 @@ subroutine read_locinfo() use kinds, only : r_kind,i_kind,r_single use params, only : nlevs,corrlengthnh,corrlengthtr,corrlengthsh,letkf_flag use enkf_obsmod, only: obloc, oblnp, corrlengthsq, lnsigl, nobstot, & - obpress, obtype, nobs_conv, nobs_oz, oberrvar + oberrvar use kdtree2_module, only: kdtree2, kdtree2_create, kdtree2_destroy, & kdtree2_result, kdtree2_n_nearest use constants, only: zero, rearth @@ -38,10 +38,19 @@ subroutine read_locinfo() endif do k=1,nlevs read(iunit,101) hlength(k),vlength(k),tmp,tmp - hlength(k) = hlength(k)/0.388 - vlength(k) = abs(vlength(k))/0.388 - ! factor of 0.388 to convert from e-folding scale + ! factor of sqrt(2/0.15) to convert from scale that GSI uses ! to distance Gaspari-Cohn function goes to zero. + hlength(k) = sqrt(2._r_single/0.15_r_single)*hlength(k) + ! although the comments in hybrid_ensemble_isotropic.F90 suggest + ! the vertical localization is scaled the same way, in fact + ! the sqrt(2) factor is missing, so use sqrt(1./0.15) instead. + ! This was validated by comparing spectra of analysis increments + ! from GSI EnVar and the LETKF with model space localization. + ! *NOTE* if model space localization is used (modelspace_vloc=.true) + ! the vlength values read in here are ignored and the localization is + ! constant with height specified using the eigenvectors read in from the + ! file vlocal_eig.dat + vlength(k) = sqrt(1._r_single/0.15_r_single)*abs(vlength(k)) if (nproc .eq. 0) print *,'level=',k,'localization scales (horiz,vert)=',hlength(k),vlength(k) end do close(iunit) diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index 056f10634..376be6a7b 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -5,55 +5,91 @@ module readconvobs ! ! prgmmr: whitaker org: esrl/psd date: 2009-02-23 ! -! abstract: read data from diag_conv* files (containing prepbufr data) written out +! abstract: read data from diag_conv* files (containing prepbufr data) written +! out ! by GSI forward operator code. ! ! Public Subroutines: ! get_num_convobs: determine the number of observations to read. -! get_convobs_data: read the data. -! +! get_convobs_data: read the data and calculate H(x) for ensemble members. +! write_convobs_data: output diag file with spread +! ! Public Variables: None ! ! program history log: ! 2009-02-23 Initial version. +! 2016-11-29 shlyaeva - updated read routine to calculate linearized H(x) +! added write_convobs_data to output ensemble spread +! 2017-05-12 Y. Wang and X. Wang - add to read dbz and rw for radar +! reflectivity and radial velocity assimilation. POC: xuguang.wang@ou.edu +! 2017-12-13 shlyaeva - added netcdf diag read/write capability ! ! attributes: ! language: f95 ! !$$$ -use kinds, only: r_kind,i_kind,r_single -use constants, only: one,zero -use params, only: npefiles + +use kinds, only: r_kind,i_kind,r_single,r_double +use constants, only: one,zero,deg2rad +use params, only: npefiles, netcdf_diag implicit none private -public :: get_num_convobs, get_convobs_data +public :: get_num_convobs, get_convobs_data, write_convobs_data + + +!> observation types to read from netcdf files +integer(i_kind), parameter :: nobtype = 11 +character(len=3), dimension(nobtype), parameter :: obtypes = (/' t', ' q', ' ps', ' uv', 'tcp', & + 'gps', 'spd', ' pw', ' dw', ' rw', 'dbz' /) contains -subroutine get_num_convobs(obspath,datestring,num_obs_tot,id) - character (len=500), intent(in) :: obspath - character (len=10), intent(in) :: datestring - character(len=500) obsfile - character(len=10), intent(in) :: id - character(len=4) pe_name +! get number of conventional observations +subroutine get_num_convobs(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + implicit none + + character(len=500), intent(in) :: obspath + character(len=10), intent(in) :: datestring + character(len=10), intent(in) :: id + integer(i_kind), intent(out) :: num_obs_tot, num_obs_totdiag + + if (netcdf_diag) then + call get_num_convobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + else + call get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + endif + +end subroutine get_num_convobs + +! get number of conventional observations from binary file +subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + implicit none + character(len=500), intent(in) :: obspath + character(len=10), intent(in) :: datestring + character(len=10), intent(in) :: id + integer(i_kind), intent(out) :: num_obs_tot, num_obs_totdiag + + character(len=500) :: obsfile + character(len=4) :: pe_name character(len=3) :: obtype - integer(i_kind) iunit, nchar, nreal, ii, mype,ios, idate, i, ipe - integer(i_kind), intent(out) :: num_obs_tot - integer(i_kind),dimension(2):: nn,nobst, nobsps, nobsq, nobsuv, nobsgps, & - nobstcp,nobstcx,nobstcy,nobstcz,nobssst, nobsspd, nobsdw, nobsrw, nobspw, nobssrw + integer(i_kind) :: iunit, nchar, nreal, ii, mype, ios, idate, i, ipe, ioff0 + integer(i_kind),dimension(2) :: nn,nobst, nobsps, nobsq, nobsuv, nobsgps, & + nobstcp,nobstcx,nobstcy,nobstcz,nobssst, nobsspd, nobsdw, nobsrw, nobspw, & + nobsdbz character(8),allocatable,dimension(:):: cdiagbuf real(r_single),allocatable,dimension(:,:)::rdiagbuf real(r_kind) :: errorlimit,errorlimit2,error,pres,obmax real(r_kind) :: errorlimit2_obs,errorlimit2_bnd logical :: fexist, init_pass - !print *,obspath + iunit = 7 ! If ob error > errorlimit or < errorlimit2, skip it. errorlimit = 1._r_kind/sqrt(1.e9_r_kind) errorlimit2_obs = 1._r_kind/sqrt(1.e-6_r_kind) errorlimit2_bnd = 1.e3_r_kind*errorlimit2_obs num_obs_tot = 0 + num_obs_totdiag = 0 nobst = 0 nobsq = 0 nobsps = 0 @@ -61,10 +97,10 @@ subroutine get_num_convobs(obspath,datestring,num_obs_tot,id) nobssst = 0 nobsspd = 0 nobsdw = 0 - nobsrw = 0 + nobsrw = 0 nobspw = 0 nobsgps = 0 - nobssrw = 0 + nobsdbz = 0 nobstcp = 0; nobstcx = 0; nobstcy = 0; nobstcz = 0 init_pass = .true. peloop: do ipe=0,npefiles @@ -74,26 +110,23 @@ subroutine get_num_convobs(obspath,datestring,num_obs_tot,id) obsfile = trim(adjustl(obspath))//"diag_conv_ges."//datestring//'_'//trim(adjustl(id)) inquire(file=obsfile,exist=fexist) if (.not. fexist .or. datestring .eq. '0000000000') & - obsfile = trim(adjustl(obspath))//"diag_conv_ges."//trim(adjustl(id)) + obsfile = trim(adjustl(obspath))//"diag_conv_ges."//trim(adjustl(id)) else ! read raw, unconcatenated pe* files. obsfile =& - trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.conv_01' + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.conv_01' endif inquire(file=obsfile,exist=fexist) if (.not. fexist) cycle peloop - !print *,'obsfile=',obsfile open(iunit,form="unformatted",file=obsfile,iostat=ios) if (init_pass) then read(iunit) idate init_pass = .false. endif - !print *,idate 10 continue - read(iunit,err=20,end=30) obtype,nchar,nreal,ii,mype + read(iunit,err=20,end=30) obtype,nchar,nreal,ii,mype,ioff0 errorlimit2=errorlimit2_obs allocate(cdiagbuf(ii),rdiagbuf(nreal,ii)) read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - !print *,obtype,nchar,nreal,ii,mype if (obtype=='gps') then if (rdiagbuf(20,1)==1) errorlimit2=errorlimit2_bnd end if @@ -143,14 +176,14 @@ subroutine get_num_convobs(obspath,datestring,num_obs_tot,id) num_obs_tot = num_obs_tot + nn(2) else if (obtype == 'sst') then ! skip sst nobssst = nobssst + nn -! Not currently used so do not add to num_obs_tot -! num_obs_tot = num_obs_tot + nn(2) - else if (obtype == 'srw') then - nobssrw = nobssrw + nn - num_obs_tot = num_obs_tot + nn(2) + ! skipping sst obs since ENKF does not how how to handle them yet. + !num_obs_tot = num_obs_tot + nn(2) else if (obtype == ' rw') then nobsrw = nobsrw + nn num_obs_tot = num_obs_tot + nn(2) + else if (obtype == 'dbz') then + nobsdbz = nobsdbz + nn + num_obs_tot = num_obs_tot + nn(2) else if (obtype == 'gps') then nobsgps = nobsgps + nn num_obs_tot = num_obs_tot + nn(2) @@ -175,13 +208,14 @@ subroutine get_num_convobs(obspath,datestring,num_obs_tot,id) else print *,'unknown obtype ',trim(obtype) end if + num_obs_totdiag = num_obs_totdiag + ii deallocate(cdiagbuf,rdiagbuf) go to 10 20 continue print *,'error reading diag_conv file',obtype 30 continue if (ipe .eq. npefiles) then - print *,num_obs_tot,' obs in diag_conv_ges file' + print *,num_obs_tot,' obs in diag_conv_ges file, ', num_obs_totdiag, ' total obs in diag_conv_ges file' write(6,*)'columns below obtype,nread, nkeep' write(6,100) 't',nobst(1),nobst(2) write(6,100) 'q',nobsq(1),nobsq(2) @@ -189,10 +223,11 @@ subroutine get_num_convobs(obspath,datestring,num_obs_tot,id) write(6,100) 'uv',nobsuv(1),nobsuv(2) write(6,100) 'sst',nobssst(1),nobssst(2) write(6,100) 'gps',nobsgps(1),nobsgps(2) + write(6,100) 'spd',nobsspd(1),nobsspd(2) write(6,100) 'pw',nobspw(1),nobspw(2) write(6,100) 'dw',nobsdw(1),nobsdw(2) - write(6,100) 'srw',nobsrw(1),nobssrw(2) - write(6,100) 'rw',nobssrw(1),nobsrw(2) + write(6,100) 'rw',nobsrw(1),nobsrw(2) + write(6,100) 'dbz',nobsdbz(1),nobsdbz(2) write(6,100) 'tcp',nobstcp(1),nobstcp(2) if (nobstcx(2) .gt. 0) then write(6,100) 'tcx',nobstcx(1),nobstcx(2) @@ -203,1099 +238,1506 @@ subroutine get_num_convobs(obspath,datestring,num_obs_tot,id) endif close(iunit) enddo peloop ! ipe loop -end subroutine get_num_convobs +end subroutine get_num_convobs_bin -subroutine get_convobs_data(obspath, datestring, nobs_max, h_x_ensmean, h_xnobc, x_obs, x_err, & - x_lon, x_lat, x_press, x_time, x_code, x_errorig, x_type, id, id2) +! get number of conventional observations from netcdf file +subroutine get_num_convobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + use nc_diag_read_mod, only: nc_diag_read_get_var + use nc_diag_read_mod, only: nc_diag_read_get_dim + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + implicit none - character*500, intent(in) :: obspath - character*500 obsfile,obsfile2 - character*10, intent(in) :: datestring - character(len=10), intent(in) :: id,id2 + character(len=500), intent(in) :: obspath + character(len=10), intent(in) :: datestring + character(len=10), intent(in) :: id + integer(i_kind), intent(out) :: num_obs_tot, num_obs_totdiag + + character(len=500) :: obsfile + character(len=4) :: pe_name + character(len=3) :: obtype + integer(i_kind) :: iunit, itype, ipe, i, nobs_curr + integer(i_kind),dimension(nobtype,2) :: nobs + real(r_kind) :: errorlimit,errorlimit2,error,pres,obmax + real(r_kind) :: errorlimit2_obs,errorlimit2_bnd + logical :: fexist + + real(r_single), allocatable, dimension (:) :: Pressure + real(r_single), allocatable, dimension (:) :: Analysis_Use_Flag + real(r_single), allocatable, dimension (:) :: Errinv_Final, GPS_Type + real(r_single), allocatable, dimension (:) :: Observation, v_Observation + real(r_single), allocatable, dimension (:) :: Forecast_Saturation_Spec_Hum + + ! If ob error > errorlimit or < errorlimit2, skip it. + errorlimit = 1._r_kind/sqrt(1.e9_r_kind) + errorlimit2_obs = 1._r_kind/sqrt(1.e-6_r_kind) + errorlimit2_bnd = 1.e3_r_kind*errorlimit2_obs + num_obs_tot = 0 + num_obs_totdiag = 0 + nobs = 0 + + obtypeloop: do itype=1, nobtype + + obtype = obtypes(itype) + peloop: do ipe=0,npefiles + + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//datestring//'_'//trim(adjustl(id))//'.nc4' + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') & + obsfile = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//trim(adjustl(id))//'.nc4' + else ! read raw, unconcatenated pe* files. + obsfile = & + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.conv_'//trim(adjustl(obtype))//'_01.nc4' + endif + + inquire(file=obsfile,exist=fexist) + if (.not. fexist) cycle peloop + + call nc_diag_read_init(obsfile, iunit) + + nobs_curr = nc_diag_read_get_dim(iunit,'nobs') + + if (nobs_curr <= 0) then + call nc_diag_read_close(obsfile) + cycle peloop + endif + + allocate(Pressure(nobs_curr), Analysis_Use_Flag(nobs_curr), & + Errinv_Final(nobs_curr), Observation(nobs_curr)) + call nc_diag_read_get_var(iunit, 'Pressure', Pressure) + call nc_diag_read_get_var(iunit, 'Analysis_Use_Flag', Analysis_Use_Flag) + call nc_diag_read_get_var(iunit, 'Errinv_Final', Errinv_Final) + + if (obtype == ' uv') then + call nc_diag_read_get_var(iunit, 'u_Observation', Observation) + allocate(v_Observation(nobs_curr)) + call nc_diag_read_get_var(iunit, 'v_Observation', v_Observation) + else + call nc_diag_read_get_var(iunit, 'Observation', Observation) + endif + if (obtype == 'gps') then + allocate(GPS_Type(nobs_curr)) + call nc_diag_read_get_var(iunit, 'GPS_Type', GPS_Type) + endif + if (obtype == ' q') then + allocate(Forecast_Saturation_Spec_Hum(nobs_curr)) + call nc_diag_read_get_var(iunit, 'Forecast_Saturation_Spec_Hum', Forecast_Saturation_Spec_Hum) + endif + + call nc_diag_read_close(obsfile) + + + num_obs_totdiag = num_obs_totdiag + nobs_curr + do i = 1, nobs_curr + + errorlimit2=errorlimit2_obs + + if (obtype == 'gps' .and. GPS_Type(i)==1) errorlimit2=errorlimit2_bnd + + ! for q, normalize by qsatges + if (obtype == ' q') then + obmax = abs(Observation(i) / Forecast_Saturation_Spec_Hum(i)) + error = Errinv_Final(i) * Forecast_Saturation_Spec_Hum(i) + else + obmax = abs(Observation(i)) + error = Errinv_Final(i) + endif + if (obtype == ' uv') then + obmax = max(abs(Observation(i)), abs(v_Observation(i))) + endif + if (obtype == ' ps' .or. obtype == 'tcp') then + pres = Observation(i) + else + pres = Pressure(i) + endif + if (Analysis_Use_Flag(i) < zero) cycle + + + nobs(itype,1) = nobs(itype,1) + 1 + if (obtype == ' uv') then + nobs(itype,1) = nobs(itype,1) + 1 + endif + if (error < errorlimit .or. error > errorlimit2 .or. & + abs(obmax) > 1.e9_r_kind .or. & + pres < 0.001_r_kind .or. pres > 1200._r_kind) cycle + ! skipping sst obs since ENKF does not how how to handle them yet. + nobs(itype,2) = nobs(itype,2) + 1 + if (obtype == ' uv') then + nobs(itype,2) = nobs(itype,2) + 1 + endif + if (obtype == 'sst') cycle + + num_obs_tot = num_obs_tot + 1 + if (obtype == ' uv') then + num_obs_tot = num_obs_tot + 1 + endif + end do + + deallocate(Pressure, Analysis_Use_Flag, Errinv_Final, Observation) + + if (obtype == ' uv') then + deallocate(v_Observation) + endif + if (obtype == 'gps') then + deallocate(GPS_Type) + endif + if (obtype == ' q') then + deallocate(Forecast_Saturation_Spec_Hum) + endif + + enddo peloop + enddo obtypeloop + + print *,num_obs_tot,' obs in diag_conv_ges file, ', num_obs_totdiag, ' total obs in diag_conv_ges file' + write(6,*)'columns below obtype,nread, nkeep' + do i = 1, nobtype + write(6,100) obtypes(i), nobs(i,1), nobs(i,2) + enddo +100 format(2x,a3,2x,i9,2x,i9) + + +end subroutine get_num_convobs_nc + +! read conventional observations +subroutine get_convobs_data(obspath, datestring, nobs_max, nobs_maxdiag, & + hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, & + x_errorig, x_type, x_used, id, nanal, nmem) + use params, only: neigv + implicit none + + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + + real(r_single), dimension(nobs_max), intent(out) :: hx_mean + real(r_single), dimension(nobs_max), intent(out) :: hx_mean_nobc + real(r_single), dimension(nobs_max), intent(out) :: hx + ! hx_modens holds modulated ensemble in ob space (zero size and not referenced if neigv=0) + real(r_single), dimension(neigv,nobs_max), intent(out) :: hx_modens + real(r_single), dimension(nobs_max), intent(out) :: x_obs + real(r_single), dimension(nobs_max), intent(out) :: x_err, x_errorig + real(r_single), dimension(nobs_max), intent(out) :: x_lon, x_lat + real(r_single), dimension(nobs_max), intent(out) :: x_press, x_time + integer(i_kind), dimension(nobs_max), intent(out) :: x_code + character(len=20), dimension(nobs_max), intent(out) :: x_type + integer(i_kind), dimension(nobs_maxdiag), intent(out) :: x_used + + character(len=10), intent(in) :: id + integer, intent(in) :: nanal, nmem + + if (netcdf_diag) then + call get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & + hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, & + x_errorig, x_type, x_used, id, nanal, nmem) + else + call get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & + hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, & + x_errorig, x_type, x_used, id, nanal, nmem) + endif +end subroutine get_convobs_data + +! read conventional observations from netcdf file +subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & + hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, & + x_errorig, x_type, x_used, id, nanal, nmem) + use sparsearr, only: sparr, delete, assignment(=) + use params, only: nanals, lobsdiag_forenkf, neigv, vlocal_evecs + use statevec, only: state_d + use mpisetup, only: nproc, mpi_wtime + use observer_enkf, only: calc_linhx,calc_linhx_modens,setup_linhx + use nc_diag_read_mod, only: nc_diag_read_get_var + use nc_diag_read_mod, only: nc_diag_read_get_dim, nc_diag_read_get_global_attr + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + + implicit none + + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + + real(r_single), dimension(nobs_max), intent(out) :: hx_mean + real(r_single), dimension(nobs_max), intent(out) :: hx_mean_nobc + real(r_single), dimension(nobs_max), intent(out) :: hx + ! hx_modens holds modulated ensemble in ob space (zero size and not referenced if neigv=0) + real(r_single), dimension(neigv,nobs_max), intent(out) :: hx_modens + + real(r_single), dimension(nobs_max), intent(out) :: x_obs + real(r_single), dimension(nobs_max), intent(out) :: x_err, x_errorig + real(r_single), dimension(nobs_max), intent(out) :: x_lon, x_lat + real(r_single), dimension(nobs_max), intent(out) :: x_press, x_time + integer(i_kind), dimension(nobs_max), intent(out) :: x_code + character(len=20), dimension(nobs_max), intent(out) :: x_type + integer(i_kind), dimension(nobs_maxdiag), intent(out) :: x_used + + character(len=10), intent(in) :: id + integer, intent(in) :: nanal, nmem + + real(r_double) t1,t2,tsum character(len=4) pe_name + character*500 obsfile, obsfile2 + character(len=10) :: id2 + type(sparr) :: dhx_dx - real(r_single), dimension(nobs_max) :: h_x_ensmean,h_xnobc,x_obs,x_err,x_lon,& - x_lat,x_press,x_time,x_errorig - integer(i_kind), dimension(nobs_max) :: x_code - character(len=20), dimension(nobs_max) :: x_type - - character(len=3) :: obtype,obtype2 - integer(i_kind) iunit, iunit2,nobs_max, nob, n, nchar,nchar2, nreal, ii, ipe, ios, idate - integer(i_kind) nreal2,ii2,mype2,i,iqc,mype - character(8),allocatable,dimension(:):: cdiagbuf,cdiagbuf2 - real(r_single),allocatable,dimension(:,:)::rdiagbuf,rdiagbuf2 - real(r_kind) :: errorlimit,errorlimit2,error + character(len=3) :: obtype + + integer(i_kind) :: iunit, iunit2, ipe, itype + integer(i_kind) :: nobs, nobdiag, i, nob, nsdim + real(r_kind) :: errorlimit,errorlimit2,error,errororig + real(r_kind) :: obmax, pres real(r_kind) :: errorlimit2_obs,errorlimit2_bnd - logical twofiles, fexist, fexist2, init_pass, init_pass2 + logical fexist + logical twofiles, fexist2 + real(r_single), allocatable, dimension (:) :: Latitude, Longitude, Pressure, Time + integer(i_kind), allocatable, dimension (:) :: Observation_Type + real(r_single), allocatable, dimension (:) :: Errinv_Input, Errinv_Final, Analysis_Use_Flag, GPS_Type + real(r_single), allocatable, dimension (:) :: Observation, v_Observation + real(r_single), allocatable, dimension (:) :: Obs_Minus_Forecast_adjusted, v_Obs_Minus_Forecast_adjusted + real(r_single), allocatable, dimension (:) :: Obs_Minus_Forecast_unadjusted, v_Obs_Minus_Forecast_unadjusted + real(r_single), allocatable, dimension (:) :: Obs_Minus_Forecast_adjusted2, v_Obs_Minus_Forecast_adjusted2 + real(r_single), allocatable, dimension (:) :: Obs_Minus_Forecast_unadjusted2, v_Obs_Minus_Forecast_unadjusted2 + real(r_single), allocatable, dimension (:) :: Forecast_Saturation_Spec_Hum + real(r_single), allocatable, dimension (:,:) :: Observation_Operator_Jacobian, v_Observation_Operator_Jacobian + integer(i_kind) :: ix, iy, it, ixp, iyp, itp + real(r_kind) :: delx, dely, delxp, delyp, delt, deltp + real(r_single) :: rlat,rlon,rtim,rlat_prev,rlon_prev,rtim_prev,eps +! Error limit is made consistent with screenobs routine + errorlimit = 1._r_kind/sqrt(1.e9_r_kind) + errorlimit2_obs = 1._r_kind/sqrt(1.e-6_r_kind) + errorlimit2_bnd = 1.e3_r_kind*errorlimit2_obs + eps = 1.e-3 + + twofiles = (.not. lobsdiag_forenkf) .and. (nanal <= nanals) + id2 = 'ensmean' + if (nanal <= nanals) then + write(id2,'(a3,(i3.3))') 'mem',nanal + endif + + tsum = 0 + + nob = 0 + rlat_prev = -1.e30; rlon_prev=-1.e30; rtim_prev = -1.e30 + nobdiag = 0 + x_used = 0 + + hx = zero + + obtypeloop: do itype=1, nobtype + + obtype = obtypes(itype) + peloop: do ipe=0,npefiles + + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//datestring//'_'//trim(adjustl(id))//'.nc4' + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') & + obsfile = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//trim(adjustl(id))//'.nc4' + else ! read raw, unconcatenated pe* files. + obsfile = & + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.conv_'//trim(adjustl(obtype))//'_01.nc4' + endif + + inquire(file=obsfile,exist=fexist) + if (.not. fexist) cycle peloop + + call nc_diag_read_init(obsfile, iunit) + + nobs = nc_diag_read_get_dim(iunit,'nobs') + + if (nobs <= 0) then + call nc_diag_read_close(obsfile) + cycle peloop + endif + + allocate(Latitude(nobs), Longitude(nobs), Pressure(nobs), Time(nobs), & + Analysis_Use_Flag(nobs), Errinv_Input(nobs), Errinv_Final(nobs), & + Observation_Type(nobs), Observation(nobs), & + Obs_Minus_Forecast_adjusted(nobs), Obs_Minus_Forecast_unadjusted(nobs)) + call nc_diag_read_get_var(iunit, 'Latitude', Latitude) + call nc_diag_read_get_var(iunit, 'Longitude', Longitude) + call nc_diag_read_get_var(iunit, 'Pressure', Pressure) + call nc_diag_read_get_var(iunit, 'Time', Time) + call nc_diag_read_get_var(iunit, 'Analysis_Use_Flag', Analysis_Use_Flag) + call nc_diag_read_get_var(iunit, 'Errinv_Input', Errinv_Input) + call nc_diag_read_get_var(iunit, 'Errinv_Final', Errinv_Final) + call nc_diag_read_get_var(iunit, 'Observation_Type', Observation_Type) + + if (obtype == ' uv') then + call nc_diag_read_get_var(iunit, 'u_Observation', Observation) + call nc_diag_read_get_var(iunit, 'u_Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted) + call nc_diag_read_get_var(iunit, 'u_Obs_Minus_Forecast_unadjusted', Obs_Minus_Forecast_unadjusted) + allocate(v_Observation(nobs), v_Obs_Minus_Forecast_adjusted(nobs), & + v_Obs_Minus_Forecast_unadjusted(nobs)) + call nc_diag_read_get_var(iunit, 'v_Observation', v_Observation) + call nc_diag_read_get_var(iunit, 'v_Obs_Minus_Forecast_adjusted', v_Obs_Minus_Forecast_adjusted) + call nc_diag_read_get_var(iunit, 'v_Obs_Minus_Forecast_unadjusted', v_Obs_Minus_Forecast_unadjusted) + else + call nc_diag_read_get_var(iunit, 'Observation', Observation) + call nc_diag_read_get_var(iunit, 'Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted) + call nc_diag_read_get_var(iunit, 'Obs_Minus_Forecast_unadjusted', Obs_Minus_Forecast_unadjusted) + endif + if (obtype == 'gps') then + allocate(GPS_Type(nobs)) + call nc_diag_read_get_var(iunit, 'GPS_Type', GPS_Type) + endif + if (obtype == ' q') then + allocate(Forecast_Saturation_Spec_Hum(nobs)) + call nc_diag_read_get_var(iunit, 'Forecast_Saturation_Spec_Hum', Forecast_Saturation_Spec_Hum) + endif + if (lobsdiag_forenkf) then + call nc_diag_read_get_global_attr(iunit, "Number_of_state_vars", nsdim) + allocate(Observation_Operator_Jacobian(nsdim, nobs)) + if (obtype == ' uv') then + call nc_diag_read_get_var(iunit, 'u_Observation_Operator_Jacobian', Observation_Operator_Jacobian) + allocate(v_Observation_Operator_Jacobian(nsdim, nobs)) + call nc_diag_read_get_var(iunit, 'v_Observation_Operator_Jacobian', v_Observation_Operator_Jacobian) + else + call nc_diag_read_get_var(iunit, 'Observation_Operator_Jacobian', Observation_Operator_Jacobian) + endif + endif + + + call nc_diag_read_close(obsfile) + + if(twofiles) then + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile2 = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//datestring//'_'//trim(adjustl(id2))//'.nc4' + inquire(file=obsfile2,exist=fexist2) + if (.not. fexist2 .or. datestring .eq. '0000000000') & + obsfile2 = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//trim(adjustl(id2))//'.nc4' + else ! read raw, unconcatenated pe* files. + obsfile2 =& + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id2))//'/pe'//pe_name//'.conv_'//trim(adjustl(obtype))//'_01.nc4' + endif + + call nc_diag_read_init(obsfile2, iunit2) + + allocate(Obs_Minus_Forecast_adjusted2(nobs), & + Obs_Minus_Forecast_unadjusted2(nobs)) + + if (obtype == ' uv') then + call nc_diag_read_get_var(iunit2, 'u_Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted2) + call nc_diag_read_get_var(iunit2, 'u_Obs_Minus_Forecast_unadjusted', Obs_Minus_Forecast_unadjusted2) + allocate(v_Obs_Minus_Forecast_adjusted2(nobs), & + v_Obs_Minus_Forecast_unadjusted2(nobs)) + call nc_diag_read_get_var(iunit2, 'v_Obs_Minus_Forecast_adjusted', v_Obs_Minus_Forecast_adjusted2) + call nc_diag_read_get_var(iunit2, 'v_Obs_Minus_Forecast_unadjusted', v_Obs_Minus_Forecast_unadjusted2) + else + call nc_diag_read_get_var(iunit2, 'Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted2) + call nc_diag_read_get_var(iunit2, 'Obs_Minus_Forecast_unadjusted', Obs_Minus_Forecast_unadjusted2) + endif + call nc_diag_read_close(obsfile2) + endif + + errorlimit2=errorlimit2_obs + + do i = 1, nobs + nobdiag = nobdiag + 1 + ! special handling for error limits for GPS bend angle + if (obtype == 'gps' .and. GPS_Type(i)==1) errorlimit2=errorlimit2_bnd + + ! for q, normalize by qsatges + if (obtype == ' q') then + obmax = abs(real(Observation(i),r_single) / real(Forecast_Saturation_Spec_Hum(i),r_single)) + errororig = real(Errinv_Input(i),r_single) * real(Forecast_Saturation_Spec_Hum(i),r_single) + error = real(Errinv_Final(i),r_single) * real(Forecast_Saturation_Spec_Hum(i),r_single) + else + obmax = abs(Observation(i)) + errororig = Errinv_Input(i) + error = Errinv_Final(i) + endif + if (obtype == ' uv') then + obmax = max(abs(Observation(i)), abs(v_Observation(i))) + endif + if (obtype == ' ps' .or. obtype == 'tcp') then + pres = Observation(i) + else + pres = Pressure(i) + endif + if (Analysis_Use_Flag(i) < zero .or. & + error < errorlimit .or. error > errorlimit2 .or. & + abs(obmax) > 1.e9_r_kind .or. & + pres < 0.001_r_kind .or. pres > 1200._r_kind) cycle + ! skipping sst obs since ENKF does not how how to handle them yet. + if (obtype == 'sst') cycle + + x_used(nobdiag) = 1 + nob = nob + 1 + x_code(nob) = Observation_Type(i) + + ! observation location and time + x_lat(nob) = Latitude(i) + x_lon(nob) = Longitude(i) + x_press(nob) = pres + x_time(nob) = Time(i) + + ! observation errors + if (errororig > 1.e-5_r_kind) then + x_errorig(nob) = (one/errororig)**2 + else + x_errorig(nob) = 1.e10_r_kind + endif + x_err(nob) = (one/error)**2 + ! special handling of gps error + if (obtype == 'gps' .and. x_errorig(nob) .gt. 1.e9) x_errorig(nob)=x_err(nob) + + ! observation + x_obs(nob) = Observation(i) + + ! hx and hxnobc + hx_mean(nob) = Observation(i) - Obs_Minus_Forecast_adjusted(i) + hx_mean_nobc(nob) = Observation(i) - Obs_Minus_Forecast_unadjusted(i) + ! whether that's reasonable + if (obtype == ' q' .or. obtype == 'spd' .or. obtype == ' dw' .or. & + obtype == ' pw') then + hx_mean_nobc(nob) = hx_mean(nob) + endif + + ! observation type + x_type(nob) = obtype + if (x_type(nob) == ' uv') x_type(nob) = ' u' + if (x_type(nob) == 'tcp') x_type(nob) = ' ps' + if (x_type(nob) == ' rw') x_type(nob) = ' rw' + if (x_type(nob) == 'dbz') x_type(nob) = 'dbz' + + ! get Hx + if (nanal <= nanals) then + ! read full Hx from file + if (.not. lobsdiag_forenkf) then + hx(nob) = Observation(i) - Obs_Minus_Forecast_unadjusted2(i) + if (obtype == ' q' .or. obtype == 'spd' .or. obtype == ' dw' .or. & + obtype == ' pw') then + hx(nob) = Observation(i) - Obs_Minus_Forecast_adjusted2(i) + endif + + ! run the linearized Hx + else + dhx_dx = Observation_Operator_Jacobian(1:nsdim,i) + + t1 = mpi_wtime() + rlat = x_lat(nob)*deg2rad + rlon = x_lon(nob)*deg2rad + rtim = x_time(nob) + if (nob > 1) then + rlat_prev = x_lat(nob-1)*deg2rad + rlon_prev = x_lon(nob-1)*deg2rad + rtim_prev = x_time(nob-1) + endif + if (abs(rlat-rlat_prev) > eps .or. & + abs(rlon-rlon_prev) > eps .or. & + abs(rtim-rtim_prev) > eps) then + call setup_linhx(rlat,rlon,rtim, & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + endif + call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem),& + dhx_dx, hx(nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + ! compute modulated ensemble in obs space + if (neigv > 0) then + call calc_linhx_modens(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx_modens(:,nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, delxp, & + vlocal_evecs) + endif + + t2 = mpi_wtime() + tsum = tsum + t2-t1 + + call delete(dhx_dx) + endif + + ! normalize q by qsatges + if (obtype == ' q') then + hx(nob) = hx(nob) / Forecast_Saturation_Spec_Hum(i) + endif + endif + + ! normalize q by qsatges + if (obtype == ' q') then + x_obs(nob) = x_obs(nob) /Forecast_Saturation_Spec_Hum(i) + hx_mean(nob) = hx_mean(nob) /Forecast_Saturation_Spec_Hum(i) + hx_mean_nobc(nob) = hx_mean_nobc(nob) /Forecast_Saturation_Spec_Hum(i) + endif + + ! for wind, also read v-component + if (obtype == ' uv') then + nob = nob + 1 + x_code(nob) = Observation_Type(i) + + ! observation location and time + x_lat(nob) = Latitude(i) + x_lon(nob) = Longitude(i) + x_press(nob) = pres + x_time(nob) = Time(i) + + ! observation errors + if (errororig > 1.e-5_r_kind) then + x_errorig(nob) = (one/errororig)**2 + else + x_errorig(nob) = 1.e10_r_kind + endif + x_err(nob) = (one/error)**2 + + ! observation + x_obs(nob) = v_Observation(i) + + ! hx and hxnobc + hx_mean(nob) = v_Observation(i) - v_Obs_Minus_Forecast_adjusted(i) + hx_mean_nobc(nob) = v_Observation(i) - v_Obs_Minus_Forecast_unadjusted(i) + + ! observation type + x_type(nob) = ' v' + + ! run linearized hx + if (nanal <= nanals) then + ! read full Hx + if (.not. lobsdiag_forenkf) then + hx(nob) = v_Observation(i) - v_Obs_Minus_Forecast_unadjusted2(i) + + ! run linearized Hx + else + t1 = mpi_wtime() + dhx_dx = v_Observation_Operator_Jacobian(1:nsdim,i) + ! don't need this since we know ob location is the same? + rlat = x_lat(nob)*deg2rad + rlon = x_lon(nob)*deg2rad + rtim = x_time(nob) + if (nob > 1) then + rlat_prev = x_lat(nob-1)*deg2rad + rlon_prev = x_lon(nob-1)*deg2rad + rtim_prev = x_time(nob-1) + endif + if (abs(rlat-rlat_prev) > eps .or. & + abs(rlon-rlon_prev) > eps .or. & + abs(rtim-rtim_prev) > eps) then + call setup_linhx(rlat,rlon,rtim, & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + endif + call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx(nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + ! compute modulated ensemble in obs space + if (neigv > 0) then + call calc_linhx_modens(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx_modens(:,nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, delxp, & + vlocal_evecs) + endif + t2 = mpi_wtime() + tsum = tsum + t2-t1 + call delete(dhx_dx) + endif + endif + endif + enddo + + deallocate(Latitude, Longitude, Pressure, Time, Analysis_Use_Flag, & + Errinv_Input, Errinv_Final, Observation_Type, & + Observation, Obs_Minus_Forecast_adjusted, Obs_Minus_Forecast_unadjusted) + + if (obtype == ' uv') then + deallocate(v_Observation, v_Obs_Minus_Forecast_adjusted, & + v_Obs_Minus_Forecast_unadjusted) + endif + + if (obtype == 'gps') then + deallocate(GPS_Type) + endif + + if (obtype == ' q') then + deallocate(Forecast_Saturation_Spec_Hum) + endif + + if (lobsdiag_forenkf) then + deallocate(Observation_Operator_Jacobian) + if (obtype == ' uv') then + deallocate(v_Observation_Operator_Jacobian) + endif + endif + + if(twofiles) then + deallocate(Obs_Minus_Forecast_adjusted2, & + Obs_Minus_Forecast_unadjusted2) + if (obtype == ' uv') then + deallocate(v_Obs_Minus_Forecast_adjusted2, & + v_Obs_Minus_Forecast_unadjusted2) + endif + endif + + enddo peloop ! ipe loop + enddo obtypeloop + + if (nanal == nanals .and. lobsdiag_forenkf) print *,'time in calc_linhx for conv obs on proc',nproc,' =',tsum + if (nob .ne. nobs_max) then + print *,'nc: number of obs not what expected in get_convobs_data',nob,nobs_max + call stop2(94) + end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total obs in diag not what expected in get_convobs_data',nobdiag, nobs_maxdiag + call stop2(94) + endif + +end subroutine get_convobs_data_nc + +! read conventional observation from binary files +subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & + hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, & + x_errorig, x_type, x_used, id, nanal, nmem) + use sparsearr, only: sparr2, sparr, readarray, delete, assignment(=), size + use params, only: nanals, lobsdiag_forenkf, neigv, vlocal_evecs + use statevec, only: state_d + use mpisetup, only: nproc, mpi_wtime + use observer_enkf, only: calc_linhx,calc_linhx_modens,setup_linhx + implicit none + + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + + real(r_single), dimension(nobs_max), intent(out) :: hx_mean + real(r_single), dimension(nobs_max), intent(out) :: hx_mean_nobc + real(r_single), dimension(nobs_max), intent(out) :: hx + ! hx_modens holds modulated ensemble in ob space (zero size and not referenced if neigv=0) + real(r_single), dimension(neigv,nobs_max), intent(out) :: hx_modens + real(r_single), dimension(nobs_max), intent(out) :: x_obs + real(r_single), dimension(nobs_max), intent(out) :: x_err, x_errorig + real(r_single), dimension(nobs_max), intent(out) :: x_lon, x_lat + real(r_single), dimension(nobs_max), intent(out) :: x_press, x_time + integer(i_kind), dimension(nobs_max), intent(out) :: x_code + character(len=20), dimension(nobs_max), intent(out) :: x_type + integer(i_kind), dimension(nobs_maxdiag), intent(out) :: x_used + + character(len=10), intent(in) :: id + integer, intent(in) :: nanal, nmem + + real(r_double) t1,t2,tsum + character(len=4) pe_name + character*500 obsfile, obsfile2 + character(len=10) :: id2 + + type(sparr2) :: dhx_dx_read + type(sparr) :: dhx_dx + + character(len=3) :: obtype, obtype2 + integer(i_kind) :: iunit, iunit2 + integer(i_kind) :: nob, nobdiag, n, i + integer(i_kind) :: nchar, nreal, ii, mype, ioff0 + integer(i_kind) :: nchar2, nreal2, ii2, mype2, ioff02, idate2 + integer(i_kind) :: ipe, ios, idate + integer(i_kind) :: ind + character(8),allocatable,dimension(:) :: cdiagbuf, cdiagbuf2 + real(r_single),allocatable,dimension(:,:) :: rdiagbuf, rdiagbuf2 + real(r_kind) :: errorlimit,errorlimit2,error,errororig + real(r_kind) :: obmax, pres + real(r_kind) :: errorlimit2_obs,errorlimit2_bnd + logical fexist, init_pass + logical twofiles, fexist2, init_pass2 + integer(i_kind) :: ix, iy, it, ixp, iyp, itp + real(r_kind) :: delx, dely, delxp, delyp, delt, deltp + real(r_single) :: rlat,rlon,rtim,rlat_prev,rlon_prev,rtim_prev,eps ! Error limit is made consistent with screenobs routine errorlimit = 1._r_kind/sqrt(1.e9_r_kind) errorlimit2_obs = 1._r_kind/sqrt(1.e-6_r_kind) errorlimit2_bnd = 1.e3_r_kind*errorlimit2_obs + eps = 1.e-3 iunit = 7 iunit2 = 17 - twofiles = id2 /= id - iqc=1 + + twofiles = (.not. lobsdiag_forenkf) .and. (nanal <= nanals) + id2 = 'ensmean' + if (nanal <= nanals) then + write(id2,'(a3,(i3.3))') 'mem',nanal + endif + + tsum = 0 nob = 0 - init_pass = .true. - init_pass2 = .true. + rlat_prev = -1.e30; rlon_prev=-1.e30; rtim_prev = -1.e30 + nobdiag = 0 + x_used = 0 - peloop: do ipe=0,npefiles + hx = zero - write(pe_name,'(i4.4)') ipe - if (npefiles .eq. 0) then - ! read diag file (concatenated pe* files) - obsfile = trim(adjustl(obspath))//"diag_conv_ges."//datestring//'_'//trim(adjustl(id)) - inquire(file=obsfile,exist=fexist) - if (.not. fexist .or. datestring .eq. '0000000000') & - obsfile = trim(adjustl(obspath))//"diag_conv_ges."//trim(adjustl(id)) - else ! read raw, unconcatenated pe* files. - obsfile =& - trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.conv_01' - endif + init_pass = .true.; init_pass2 = .true. + + peloop: do ipe=0,npefiles - inquire(file=obsfile,exist=fexist) - if (.not. fexist) cycle peloop + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_conv_ges."//datestring//'_'//trim(adjustl(id)) + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') & + obsfile = trim(adjustl(obspath))//"diag_conv_ges."//trim(adjustl(id)) + else ! read raw, unconcatenated pe* files. + obsfile = & + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.conv_01' + endif - !print *,obsfile + inquire(file=obsfile,exist=fexist) + if (.not. fexist) cycle peloop - open(iunit,form="unformatted",file=obsfile,iostat=ios) - rewind(iunit) - if (init_pass) then + open(iunit,form="unformatted",file=obsfile,iostat=ios) + rewind(iunit) + if (init_pass) then read(iunit) idate init_pass = .false. - endif - !print *,idate - if(twofiles) then - if (npefiles .eq. 0) then + endif + + if(twofiles) then + if (npefiles .eq. 0) then ! read diag file (concatenated pe* files) obsfile2 = trim(adjustl(obspath))//"diag_conv_ges."//datestring//'_'//trim(adjustl(id2)) inquire(file=obsfile2,exist=fexist2) if (.not. fexist2 .or. datestring .eq. '0000000000') & obsfile2 = trim(adjustl(obspath))//"diag_conv_ges."//trim(adjustl(id2)) - else ! read raw, unconcatenated pe* files. + else ! read raw, unconcatenated pe* files. obsfile2 =& trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id2))//'/pe'//pe_name//'.conv_01' - endif - open(iunit2,form="unformatted",file=obsfile2,iostat=ios) - rewind(iunit2) - if (init_pass2) then - read(iunit2) idate + endif + + inquire(file=obsfile2,exist=fexist2) + open(iunit2,form="unformatted",file=obsfile2,iostat=ios) + rewind(iunit2) + if (init_pass2) then + read(iunit2) idate2 init_pass2 = .false. - endif - end if -10 continue - read(iunit,err=20,end=30) obtype,nchar,nreal,ii,mype - errorlimit2=errorlimit2_obs - if(twofiles) then - read(iunit2,err=20,end=30) obtype2,nchar2,nreal2,ii2,mype2 - if(obtype /= obtype2 .or. nchar /= nchar2 .or. nreal /= nreal2 .or. ii /= ii2)then - write(6,*) ' conv obs mismatch ' - write(6,*) ' obtype ',obtype,obtype2 - write(6,*) ' nchar ',nchar,nchar2 - write(6,*) ' nreal ',nreal,nreal2 - write(6,*) ' ii ',ii,ii2 - go to 10 + endif end if - end if - - !print *,obtype,nchar,nreal,ii,mype - if (obtype == ' t') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) + +10 continue + + read(iunit,err=20,end=30) obtype,nchar,nreal,ii,mype,ioff0 + errorlimit2=errorlimit2_obs + + if(twofiles) then + read(iunit2,err=20,end=30) obtype2,nchar2,nreal2,ii2,mype2,ioff02 +! if(obtype /= obtype2 .or. nchar /= nchar2 .or. nreal /= nreal2 .or. ii /= ii2)then +! write(6,*) ' conv obs mismatch ' + +! write(6,*) ' obtype ',obtype,obtype2 +! write(6,*) ' nchar ',nchar,nchar2 +! write(6,*) ' nreal ',nreal,nreal2 +! write(6,*) ' ii ',ii,ii2 +! go to 10 +! end if + end if + + + if (obtype == ' t' .or. obtype == ' uv' .or. obtype == ' ps' .or. & + obtype == 'tcp' .or. obtype == ' q' .or. obtype == 'spd' .or. & + obtype == 'sst' .or. obtype == ' rw' .or. obtype == 'dbz' .or. & + obtype == 'gps' .or. obtype == ' dw' .or. obtype == ' pw') then + + allocate(cdiagbuf(ii),rdiagbuf(nreal,ii)) read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if + + if (twofiles) then + allocate(cdiagbuf2(ii2), rdiagbuf2(nreal2,ii2)) + read(iunit2) cdiagbuf2(1:ii2),rdiagbuf2(:,1:ii2) + endif + + ! special handling for error limits for GPS bend angle + if (obtype == 'gps') then + if (rdiagbuf(20,1)==1) errorlimit2=errorlimit2_bnd + endif do n=1,ii - if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - rdiagbuf(16,n) > errorlimit2)cycle - if(abs(rdiagbuf(17,n)) > 1.e9_r_kind .or. & - rdiagbuf(6,n) < 0.001_r_kind .or. & - rdiagbuf(6,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' t conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8) - write (6,*) (rdiagbuf2(i,n),i=1,8) - call stop2(-98) - end if + nobdiag = nobdiag + 1 + ! for q, normalize by qsatges + if (obtype == ' q') then + obmax = abs(rdiagbuf(17,n)/rdiagbuf(20,n)) + errororig = rdiagbuf(14,n)*rdiagbuf(20,n) + error = rdiagbuf(16,n)*rdiagbuf(20,n) else - rdiagbuf2(18,n) = rdiagbuf(18,n) - rdiagbuf2(19,n) = rdiagbuf(19,n) - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(6,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 - else - x_errorig(nob) = 1.e10_r_kind + obmax = abs(rdiagbuf(17,n)) + errororig = rdiagbuf(14,n) + error = rdiagbuf(16,n) endif - x_err(nob) = (one/rdiagbuf(16,n))**2 - x_obs(nob) = rdiagbuf(17,n) - h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf(18,n) - h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(18,n) - x_type(nob) = obtype - enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) -! rdiagbuf(6,ii) = prest ! observation pressure (hPa) -! rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = data(iqt,i) ! setup qc or event mark (currently qtflg only) -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) -! rdiagbuf(17,ii) = data(itob,i) ! temperature observation (K) -! rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) -! rdiagbuf(19,ii) = tob-tges ! obs-ges w/o bias correction (K) (future slot) - else if (obtype == ' uv') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - do n=1,ii - if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - rdiagbuf(16,n) > errorlimit2)cycle - if(abs(rdiagbuf(17,n)) > 1.e9_r_kind .or. & - rdiagbuf(6,n) < 0.001_r_kind .or. & - rdiagbuf(6,n) > 1200._r_kind .or. & - abs(rdiagbuf(20,n)) > 1.e9_r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' uv conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8) - write (6,*) (rdiagbuf2(i,n),i=1,8) - call stop2(-98) - end if - else - rdiagbuf2(18,n) = rdiagbuf(18,n) - rdiagbuf2(19,n) = rdiagbuf(19,n) - rdiagbuf2(21,n) = rdiagbuf(21,n) - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(6,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 - else - x_errorig(nob) = 1.e10_r_kind + if (obtype == ' uv') then + obmax = max(obmax,abs(rdiagbuf(20,n))) endif - x_err(nob) = (one/rdiagbuf(16,n))**2 - x_obs(nob) = rdiagbuf(17,n) - h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf(18,n) - h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(18,n) - x_type(nob) = ' u' - nob = nob + 1 - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(6,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 + if (obtype == ' ps' .or. obtype == 'tcp') then + pres = rdiagbuf(17,n) else - x_errorig(nob) = 1.e10_r_kind + pres = rdiagbuf(6,n) endif - x_err(nob) = (one/rdiagbuf(16,n))**2 - x_obs(nob) = rdiagbuf(20,n) - h_x_ensmean(nob) = rdiagbuf(20,n)-rdiagbuf(21,n) - h_xnobc(nob) = rdiagbuf(20,n)-rdiagbuf2(21,n) - !h_xnobc(nob) = rdiagbuf(20,n)-rdiagbuf(22,n) - x_type(nob) = ' v' - enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) -! rdiagbuf(6,ii) = presw ! observation pressure (hPa) -! rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m/s)**-1 -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m/s)**-1 -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m/s)**-1 -! rdiagbuf(17,ii) = data(iuob,i) ! u wind component observation (m/s) -! rdiagbuf(18,ii) = dudiff ! u obs-ges used in analysis (m/s) -! rdiagbuf(19,ii) = uob-ugesin ! u obs-ges w/o bias correction (m/s) (future slot) -! rdiagbuf(20,ii) = data(ivob,i) ! v wind component observation (m/s) -! rdiagbuf(21,ii) = dvdiff ! v obs-ges used in analysis (m/s) -! rdiagbuf(22,ii) = vob-vgesin ! v obs-ges w/o bias correction (m/s) (future slot) -! rdiagbuf(23,ii) = factw ! 10m wind reduction factor - else if (obtype == ' ps') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - do n=1,ii - if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - rdiagbuf(16,n) > errorlimit2)cycle - if(rdiagbuf(17,n) < 0.001_r_kind .or. & - rdiagbuf(17,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' ps conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8),rdiagbuf(17,n) - write (6,*) (rdiagbuf2(i,n),i=1,8),rdiagbuf2(17,n) - call stop2(-98) - end if - else - rdiagbuf2(18,n) = rdiagbuf(18,n) - rdiagbuf2(19,n) = rdiagbuf(19,n) + if (rdiagbuf(12,n) < zero .or. & + error < errorlimit .or. error > errorlimit2 .or. & + abs(obmax) > 1.e9_r_kind .or. & + pres < 0.001_r_kind .or. pres > 1200._r_kind) cycle + ! skipping sst obs since ENKF does not how how to handle them yet. + if (obtype == 'sst') cycle + if (twofiles) then + if (rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. & + abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & + abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. & + abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5) then + write (6,*) obtype, ' conv ob data inconsistency ' + write (6,*) (rdiagbuf(i,n),i=1,8) + write (6,*) (rdiagbuf2(i,n),i=1,8) + call stop2(-98) end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(17,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 - else - x_errorig(nob) = 1.e10_r_kind - endif - ! error modified by GSI. - x_err(nob) = (one/rdiagbuf(16,n))**2 - ! unmodified error from read_prepbufr - !if (rdiagbuf(15,n) > tiny(rdiagbuf(1,1))) then - !x_err(nob) = (one/rdiagbuf(15,n))**2 - x_obs(nob) = rdiagbuf(17,n) - x_type(nob) = obtype - ! ob minus ens mean bias-corrected background - h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf(18,n) - ! ob minus un-bias-corrected background (individ members) - h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(19,n) - enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) -! rdiagbuf(6,ii) = data(ipres,i)*r10 ! observation pressure (hPa) -! rdiagbuf(7,ii) = dhgt ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (hPa**-1) -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (hPa**-1) -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error (hPa**-1) -! rdiagbuf(17,ii) = pob ! surface pressure observation (hPa) -! rdiagbuf(18,ii) = pob-pges ! obs-ges used in analysis (coverted to hPa) -! rdiagbuf(19,ii) = pob-pgesorig ! obs-ges w/o adjustment to guess surface pressure (hPa) - else if (obtype == 'tcp') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - do n=1,ii - if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - rdiagbuf(16,n) > errorlimit2)cycle - if(rdiagbuf(17,n) < 0.001_r_kind .or. & - rdiagbuf(17,n) > 1200._r_kind) cycle + end if + nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(17,n)-rdiagbuf2(17,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' tcp conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8),rdiagbuf(17,n) - write (6,*) (rdiagbuf2(i,n),i=1,8),rdiagbuf2(17,n) - call stop2(-98) - end if + x_used(nobdiag) = 1 + x_code(nob) = rdiagbuf(1,n) + + ! observation location and time + x_lat(nob) = rdiagbuf(3,n) + x_lon(nob) = rdiagbuf(4,n) + x_press(nob) = pres + x_time(nob) = rdiagbuf(8,n) + + ! observation errors + if (errororig > 1.e-5_r_kind) then + x_errorig(nob) = (one/errororig)**2 else - rdiagbuf2(18,n) = rdiagbuf(18,n) - rdiagbuf2(19,n) = rdiagbuf(19,n) - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(17,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 + x_errorig(nob) = 1.e10_r_kind + endif + x_err(nob) = (one/error)**2 + ! special handling of gps error + if (obtype == 'gps' .and. x_errorig(nob) .gt. 1.e9) x_errorig(nob)=x_err(nob) + + ! observation + x_obs(nob) = rdiagbuf(17,n) + + ! hx and hxnobc + ! special handling of gps hx + if (obtype == 'gps') then + hx_mean(nob) = rdiagbuf(17,n) - (rdiagbuf(5,n)*rdiagbuf(17,n)) + hx_mean_nobc(nob) = rdiagbuf(17,n) - (rdiagbuf(5,n)*rdiagbuf(17,n)) else - x_errorig(nob) = 1.e10_r_kind + hx_mean(nob) = rdiagbuf(17,n)-rdiagbuf(18,n) + hx_mean_nobc(nob) = rdiagbuf(17,n)-rdiagbuf(19,n) endif - ! error modified by GSI. - x_err(nob) = (one/rdiagbuf(16,n))**2 - ! unmodified error from read_prepbufr - !if (rdiagbuf(15,n) > tiny(rdiagbuf(1,1))) then - !x_err(nob) = (one/rdiagbuf(15,n))**2 - x_obs(nob) = rdiagbuf(17,n) - x_type(nob) = ' ps' - ! ob minus ens mean bias-corrected background - h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf(18,n) - ! ob minus un-bias-corrected background (individ members) - h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(19,n) - enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) - else if (obtype == 'tcx') then - !print*,'reading in tcx ob',nreal,ii,id,id2 - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2) cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - !print*,'tcx',rdiagbuf(1,1:7),nob,ii - do n=1,ii - if(rdiagbuf(6,n) < errorlimit .or. & - rdiagbuf(6,n) > errorlimit2)cycle - if(abs(rdiagbuf(7,n)) > 1.e9_r_kind .or. & - rdiagbuf(4,n) < 0.001_r_kind .or. & - rdiagbuf(4,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(abs(rdiagbuf(2,n)-rdiagbuf2(2,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5)then - write (6,*) ' tcx conv ob data inconsistency ' - write (6,*) rdiagbuf(:,n) - write (6,*) rdiagbuf2(:,n) - call stop2(-98) - end if + ! ????? just repeating whatever was in the previous code; I don't know + ! whether that's reasonable + if (obtype == ' q' .or. obtype == 'spd' .or. obtype == ' dw' .or. & + obtype == ' pw') then + hx_mean_nobc(nob) = hx_mean(nob) endif - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(2,n) - x_lon(nob) = rdiagbuf(3,n) - x_press(nob) = rdiagbuf(4,n) - x_time(nob) = 0 - x_obs(nob) = rdiagbuf(7,n) - x_errorig(nob) = rdiagbuf(6,n)**2 - x_err(nob) = rdiagbuf(6,n)**2 - x_type(nob) = 'tcx' - h_x_ensmean(nob) = rdiagbuf(5,n) - h_xnobc(nob) = rdiagbuf2(5,n) - enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) - else if (obtype == 'tcy') then - !print*,'reading in tcy ob',nreal,ii,id,id2 - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2) cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - !print*,'tcy',rdiagbuf(1,1:7),nob,ii - do n=1,ii - if(rdiagbuf(6,n) < errorlimit .or. & - rdiagbuf(6,n) > errorlimit2)cycle - if(abs(rdiagbuf(7,n)) > 1.e9_r_kind .or. & - rdiagbuf(4,n) < 0.001_r_kind .or. & - rdiagbuf(4,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(abs(rdiagbuf(2,n)-rdiagbuf2(2,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5)then - write (6,*) ' tcx conv ob data inconsistency ' - write (6,*) rdiagbuf(:,n) - write (6,*) rdiagbuf2(:,n) - call stop2(-98) - end if + + ! observation type + x_type(nob) = obtype + if (obtype == ' uv') x_type(nob) = ' u' + if (obtype == 'tcp') x_type(nob) = ' ps' + if (obtype == ' rw') x_type(nob) = ' rw' + + ! get Hx + if (nanal <= nanals) then + ! read full Hx from file + if (.not. lobsdiag_forenkf) then + if (obtype == 'gps') then + hx(nob) = rdiagbuf2(17,n) - (rdiagbuf2(5,n)*rdiagbuf2(17,n)) + else + hx(nob) = rdiagbuf(17,n) - rdiagbuf2(19,n) + endif + if (obtype == ' q' .or. obtype == 'spd' .or. obtype == ' dw' .or. & + obtype == ' pw') then + hx(nob) = rdiagbuf(17,n) - rdiagbuf2(18,n) + endif + + ! run the linearized Hx + else + ind = ioff0 + 1 + call readarray(dhx_dx_read, rdiagbuf(ind:nreal,n)) + ind = ind + size(dhx_dx_read) + dhx_dx = dhx_dx_read + t1 = mpi_wtime() + rlat = x_lat(nob)*deg2rad + rlon = x_lon(nob)*deg2rad + rtim = x_time(nob) + if (nob > 1) then + rlat_prev = x_lat(nob-1)*deg2rad + rlon_prev = x_lon(nob-1)*deg2rad + rtim_prev = x_time(nob-1) + endif + if (abs(rlat-rlat_prev) > eps .or. & + abs(rlon-rlon_prev) > eps .or. & + abs(rtim-rtim_prev) > eps) then + call setup_linhx(rlat,rlon,rtim, & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + endif + call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx(nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + ! compute modulated ensemble in obs space + if (neigv > 0) then + call calc_linhx_modens(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx_modens(:,nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, delxp, & + vlocal_evecs) + endif + + t2 = mpi_wtime() + tsum = tsum + t2-t1 + + call delete(dhx_dx) + call delete(dhx_dx_read) + endif + + ! normalize q by qsatges + if (obtype == ' q') then + hx(nob) = hx(nob) /rdiagbuf(20,n) + endif + + endif + + ! normalize q by qsatges + if (obtype == ' q') then + x_obs(nob) = x_obs(nob) /rdiagbuf(20,n) + hx_mean(nob) = hx_mean(nob) /rdiagbuf(20,n) + hx_mean_nobc(nob) = hx_mean_nobc(nob) /rdiagbuf(20,n) + endif + + ! for wind, also read v-component + if (obtype == ' uv') then + nob = nob + 1 + x_code(nob) = rdiagbuf(1,n) + + ! observation location and time + x_lat(nob) = rdiagbuf(3,n) + x_lon(nob) = rdiagbuf(4,n) + x_press(nob) = pres + x_time(nob) = rdiagbuf(8,n) + + ! errors + if (errororig > 1.e-5_r_kind) then + x_errorig(nob) = (one/errororig)**2 + else + x_errorig(nob) = 1.e10_r_kind + endif + x_err(nob) = (one/error)**2 + + ! observation + x_obs(nob) = rdiagbuf(20,n) + + ! hx and hxnobc + hx_mean(nob) = rdiagbuf(20,n)-rdiagbuf(21,n) + hx_mean_nobc(nob) = rdiagbuf(20,n)-rdiagbuf(22,n) + + ! observation type + x_type(nob) = ' v' + + ! run linearized hx + if (nanal <= nanals) then + ! read full Hx + if (.not. lobsdiag_forenkf) then + hx(nob) = rdiagbuf(20,n)-rdiagbuf2(22,n) + ! run linearized Hx + else + call readarray(dhx_dx_read, rdiagbuf(ind:nreal,n)) + dhx_dx = dhx_dx_read + + t1 = mpi_wtime() + ! don't need this since we know ob location is the same? + rlat = x_lat(nob)*deg2rad + rlon = x_lon(nob)*deg2rad + rtim = x_time(nob) + if (nob > 1) then + rlat_prev = x_lat(nob-1)*deg2rad + rlon_prev = x_lon(nob-1)*deg2rad + rtim_prev = x_time(nob-1) + endif + if (abs(rlat-rlat_prev) > eps .or. & + abs(rlon-rlon_prev) > eps .or. & + abs(rtim-rtim_prev) > eps) then + call setup_linhx(rlat,rlon,rtim, & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + endif + call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx(nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + ! compute modulated ensemble in obs space + if (neigv > 0) then + call calc_linhx_modens(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx_modens(:,nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, delxp, & + vlocal_evecs) + endif + + t2 = mpi_wtime() + tsum = tsum + t2-t1 + + call delete(dhx_dx) + call delete(dhx_dx_read) + endif + endif endif - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(2,n) - x_lon(nob) = rdiagbuf(3,n) - x_press(nob) = rdiagbuf(4,n) - x_time(nob) = 0 - x_obs(nob) = rdiagbuf(7,n) - x_errorig(nob) = rdiagbuf(6,n)**2 - x_err(nob) = rdiagbuf(6,n)**2 - x_type(nob) = 'tcx' - h_x_ensmean(nob) = rdiagbuf(5,n) - h_xnobc(nob) = rdiagbuf2(5,n) enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) - else if (obtype == 'tcz') then - !print*,'reading in tcz ob',nreal,ii,id,id2 - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) + deallocate(cdiagbuf,rdiagbuf) + if (twofiles) deallocate(cdiagbuf2,rdiagbuf2) + + else if (obtype == 'tcx' .or. obtype == 'tcy' .or. obtype == 'tcz') then + allocate(cdiagbuf(ii),rdiagbuf(nreal,ii)) read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) + if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2) cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) + allocate(cdiagbuf2(ii2),rdiagbuf2(nreal2,ii2)) + read(iunit2) cdiagbuf2(1:ii2),rdiagbuf2(:,1:ii2) end if - !print*,'tcz',rdiagbuf(1,1:7),nob,ii + do n=1,ii - if(rdiagbuf(6,n) < errorlimit .or. & + nobdiag = nobdiag + 1 + if(rdiagbuf(6,n) < errorlimit .or. & rdiagbuf(6,n) > errorlimit2)cycle if(abs(rdiagbuf(7,n)) > 1.e9_r_kind .or. & - rdiagbuf(4,n) < 0.001_r_kind .or. & - rdiagbuf(4,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(abs(rdiagbuf(2,n)-rdiagbuf2(2,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5)then - write (6,*) ' tcz conv ob data inconsistency ' - write (6,*) rdiagbuf(:,n) - write (6,*) rdiagbuf2(:,n) - call stop2(-98) - end if - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(2,n) - x_lon(nob) = rdiagbuf(3,n) - x_press(nob) = rdiagbuf(4,n) - x_time(nob) = 0 - x_obs(nob) = rdiagbuf(7,n) - x_errorig(nob) = rdiagbuf(6,n)**2 - x_err(nob) = rdiagbuf(6,n)**2 - x_type(nob) = 'tcz' - h_x_ensmean(nob) = rdiagbuf(5,n) - h_xnobc(nob) = rdiagbuf2(5,n) - enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) - else if (obtype == ' q') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - do n=1,ii - error=rdiagbuf(16,n)*rdiagbuf(20,n) - if(rdiagbuf(12,n) < zero .or. error < errorlimit .or. & - error > errorlimit2)cycle - if(abs(rdiagbuf(17,n)/rdiagbuf(20,n)) > 1.e9_r_kind .or. & - rdiagbuf(6,n) < 0.001_r_kind .or. & - rdiagbuf(6,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' q conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8) - write (6,*) (rdiagbuf2(i,n),i=1,8) - call stop2(-98) - end if - else - rdiagbuf2(18,n) = rdiagbuf(18,n) - rdiagbuf2(19,n) = rdiagbuf(19,n) - rdiagbuf2(20,n) = rdiagbuf(20,n) - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(6,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n)*rdiagbuf(20,n) > 1.e-5_r_kind) then -! normalize by qsatges - x_errorig(nob) = (1._r_kind/(rdiagbuf(20,n)*rdiagbuf(14,n)))**2 - else - x_errorig(nob) = 1.e10_r_kind + rdiagbuf(4,n) < 0.001_r_kind .or. & + rdiagbuf(4,n) > 1200._r_kind) cycle + if (twofiles) then + if (abs(rdiagbuf(2,n)-rdiagbuf2(2,n)) .gt. 1.e-5 .or. & + abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5) then + write (6,*) obtype, ' conv ob data inconsistency ' + write (6,*) rdiagbuf(:,n) + write (6,*) rdiagbuf2(:,n) + call stop2(-98) endif -! normalize by qsatges - x_err(nob) = (1._r_kind/(rdiagbuf(20,n)*rdiagbuf(16,n)))**2 - x_obs(nob) = rdiagbuf(17,n)/rdiagbuf(20,n) - h_x_ensmean(nob) = (rdiagbuf(17,n)-rdiagbuf(18,n))/rdiagbuf(20,n) - h_xnobc(nob) = (rdiagbuf(17,n)-rdiagbuf2(18,n))/rdiagbuf(20,n) - !h_xnobc(nob) = (rdiagbuf(17,n)-rdiagbuf2(19,n))/rdiagbuf(20,n) - x_type(nob) = obtype - enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) -! rdiagbuf(6,ii) = presq ! observation pressure (hPa) -! rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse observation error -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error -! rdiagbuf(17,ii) = data(iqob,i) ! observation -! rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis -! rdiagbuf(19,ii) = qob-qges ! obs-ges w/o bias correction (future slot) -! rdiagbuf(20,ii) = qsges ! guess saturation specific humidity - else if (obtype == 'spd') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - do n=1,ii - if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - rdiagbuf(16,n) > errorlimit2)cycle - if(abs(rdiagbuf(17,n)) > 1.e9_r_kind .or. & - rdiagbuf(6,n) < 0.001_r_kind .or. & - rdiagbuf(6,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' spd conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8) - write (6,*) (rdiagbuf2(i,n),i=1,8) - call stop2(-98) - end if - else - rdiagbuf2(18,n) = rdiagbuf(18,n) - rdiagbuf2(19,n) = rdiagbuf(19,n) - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(6,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 - else - x_errorig(nob) = 1.e10_r_kind endif - x_err(nob) = (one/rdiagbuf(16,n))**2 - x_obs(nob) = rdiagbuf(17,n) - h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf(18,n) - h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(18,n) - !h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(19,n) - x_type(nob) = obtype - enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) -! rdiagbuf(6,ii) = presw ! observation pressure (hPa) -! rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m/s)**-1 -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m/s)**-1 -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m/s)**-1 -! rdiagbuf(17,ii) = spdob ! wind speed observation (m/s) -! rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (m/s) -! rdiagbuf(19,ii) = spdob0-spdges ! obs-ges w/o bias correction (m/s) (future slot) -! rdiagbuf(20,ii) = factw ! 10m wind reduction factor - else if (obtype == 'sst') then ! skip sst - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - ! do n=1,ii - ! if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - ! rdiagbuf(16,n) > errorlimit2)cycle - ! if(abs(rdiagbuf(17,n)) > 1.e9_r_kind .or. & - ! rdiagbuf(6,n) < 0.001_r_kind .or. & - ! rdiagbuf(6,n) > 1200._r_kind) cycle - ! nob = nob + 1 - ! if(twofiles)then - ! if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - ! abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - ! write (6,*) ' sst conv ob data inconsistency ' - ! write (6,*) (rdiagbuf(i,n),i=1,8) - ! write (6,*) (rdiagbuf2(i,n),i=1,8) - ! call stop2(-98) - ! end if - ! else - ! rdiagbuf2(18,n) = rdiagbuf(18,n) - ! end if - ! x_code(nob) = rdiagbuf(1,n) - ! x_lat(nob) = rdiagbuf(3,n) - ! x_lon(nob) = rdiagbuf(4,n) - ! x_press(nob) = rdiagbuf(6,n) - ! x_time(nob) = rdiagbuf(8,n) - ! if (rdiagbuf(14,n) > 1.e-5_r_kind) then - ! x_errorig(nob) = (one/rdiagbuf(14,n))**2 - ! else - ! x_errorig(nob) = 1.e10_r_kind - ! endif - ! x_err(nob) = (one/rdiagbuf(16,n))**2 - ! x_obs(nob) = rdiagbuf(17,n) - ! h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf2(18,n) - ! x_type(nob) = obtype - ! enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) -! rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) -! rdiagbuf(7,ii) = data(idepth,i) ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) -! rdiagbuf(17,ii) = data(isst,i) ! SST observation (K) -! rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) -! rdiagbuf(19,ii) = data(isst,i)-sstges! obs-ges w/o bias correction (K) (future slot) -! rdiagbuf(20,ii) = data(iotype,i) ! type of measurement - else if (obtype == 'srw') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - !do n=1,ii - ! if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - ! rdiagbuf(16,n) > errorlimit2)cycle - ! if(abs(rdiagbuf(17,n)) > 1.e9_r_kind .or. & - ! rdiagbuf(6,n) < 0.001_r_kind .or. & - ! rdiagbuf(6,n) > 1200._r_kind) cycle - ! nob = nob + 1 - ! if(twofiles)then - ! if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - ! abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - ! write (6,*) ' srw conv ob data inconsistency ' - ! write (6,*) (rdiagbuf(i,n),i=1,8) - ! write (6,*) (rdiagbuf2(i,n),i=1,8) - ! call stop2(-98) - ! end if - ! else - ! rdiagbuf2(18,n) = rdiagbuf(18,n) - ! rdiagbuf2(19,n) = rdiagbuf(19,n) - ! end if - ! x_code(nob) = rdiagbuf(1,n) - ! x_lat(nob) = rdiagbuf(3,n) - ! x_lon(nob) = rdiagbuf(4,n) - ! x_press(nob) = rdiagbuf(6,n) - ! x_time(nob) = rdiagbuf(8,n) - ! if (rdiagbuf(14,n) > 1.e-5_r_kind) then - ! x_errorig(nob) = (one/rdiagbuf(14,n))**2 - ! else - ! x_errorig(nob) = 1.e10_r_kind - ! endif - ! x_err(nob) = (one/rdiagbuf(16,n))**2 - ! x_obs(nob) = rdiagbuf(17,n) - ! h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf2(18,n) - ! h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(19,n) - ! x_type(nob) = obtype - !enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! radar wind superobs -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = rmiss_single ! station elevation (meters) -! rdiagbuf(6,ii) = presw ! observation pressure (hPa) -! rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = rmiss_single ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error -! rdiagbuf(17,ii) = data(ihat1,i) ! observation -! rdiagbuf(18,ii) = d1diff ! obs-ges used in analysis -! rdiagbuf(19,ii) = data(ihat1,i)-srw1gesin ! obs-ges w/o bias correction (future slot) -! rdiagbuf(20,ii) = data(ihat2,i) ! observation -! rdiagbuf(21,ii) = d2diff ! obs_ges used in analysis -! rdiagbuf(22,ii) = data(ihat2,i)-srw2gesin ! obs-ges w/o bias correction (future slot) -! rdiagbuf(23,ii) = factw ! 10m wind reduction factor -! rdiagbuf(24,ii)= data(irange,i) ! superob mean range from radar (m) - else if (obtype == ' rw') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - do n=1,ii - if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - rdiagbuf(16,n) > errorlimit2)cycle - if(abs(rdiagbuf(17,n)) > 1.e9_r_kind .or. & - rdiagbuf(6,n) < 0.001_r_kind .or. & - rdiagbuf(6,n) > 1200._r_kind) cycle + nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' rw conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8) - write (6,*) (rdiagbuf2(i,n),i=1,8) - call stop2(-98) - end if - else - rdiagbuf2(18,n) = rdiagbuf(18,n) - rdiagbuf2(19,n) = rdiagbuf(19,n) - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(6,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 - else - x_errorig(nob) = 1.e10_r_kind - endif - x_err(nob) = (one/rdiagbuf(16,n))**2 - x_obs(nob) = rdiagbuf(17,n) - h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf(18,n) - h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(18,n) - !h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(19,n) - x_type(nob) = obtype + x_used(nobdiag) = 1 + x_code(nob) = rdiagbuf(1,n) + x_lat(nob) = rdiagbuf(2,n) + x_lon(nob) = rdiagbuf(3,n) + x_press(nob) = rdiagbuf(4,n) + x_time(nob) = 0 + x_obs(nob) = rdiagbuf(7,n) + x_errorig(nob) = rdiagbuf(6,n)**2 + x_err(nob) = rdiagbuf(6,n)**2 + x_type(nob) = obtype + if (obtype == 'tcy') x_type(nob) = 'tcx' + hx_mean(nob) = rdiagbuf(5,n) + hx_mean_nobc(nob) = rdiagbuf(5,n) + if (.not. lobsdiag_forenkf) hx(nob) = rdiagbuf2(5,n) enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! radar radial winds -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) -! rdiagbuf(6,ii) = presw ! observation pressure (hPa) -! rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = rmiss_single ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(12,ii) = -one -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m/s)**-1 -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m/s)**-1 -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m/s)**-1 -! rdiagbuf(17,ii) = data(irwob,i) ! radial wind speed observation (m/s) -! rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (m/s) -! rdiagbuf(19,ii) = data(irwob,i)-rwwind ! obs-ges w/o bias correction (m/s) (future slot) -! rdiagbuf(20,ii)=data(iazm,i)*rad2deg ! azimuth angle -! rdiagbuf(21,ii)=data(itilt,i)*rad2deg! tilt angle -! rdiagbuf(22,ii) = factw ! 10m wind reduction factor - else if (obtype == 'gps') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if (rdiagbuf(20,1)==1) errorlimit2=errorlimit2_bnd - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if - do n=1,ii - if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - rdiagbuf(16,n) > errorlimit2)cycle - if(abs(rdiagbuf(17,n)) > 1.e9_r_kind .or. & - rdiagbuf(6,n) < 0.001_r_kind .or. & - rdiagbuf(6,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' gps conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8) - write (6,*) (rdiagbuf2(i,n),i=1,8) - call stop2(-98) - end if - else - rdiagbuf2(17,n) = rdiagbuf(17,n) - rdiagbuf2(5,n) = rdiagbuf(5,n) - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(6,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 - else - x_errorig(nob) = 1.e10_r_kind - end if - x_err(nob) = (one/rdiagbuf(16,n))**2 - if (x_errorig(nob) .gt. 1.e9) x_errorig(nob)=x_err(nob) - x_obs(nob) = rdiagbuf(17,n) + deallocate(cdiagbuf,rdiagbuf) + if (twofiles) deallocate(cdiagbuf2,rdiagbuf2) + else + print *,'warning - unknown ob type ',obtype + endif -! Convert to innovation (as pointed out by Lidia) - h_x_ensmean(nob) = rdiagbuf(17,n) - (rdiagbuf(5,n)*rdiagbuf(17,n)) - h_xnobc(nob) = rdiagbuf2(17,n) - (rdiagbuf2(5,n)*rdiagbuf2(17,n)) -!! !h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(19,n) + go to 10 +20 continue + print *,'error reading diag_conv file' +30 continue + close(iunit) + if (twofiles) close(iunit2) + + enddo peloop ! ipe loop - x_type(nob) = obtype + if (nanal == nanals .and. lobsdiag_forenkf) print *,'time in calc_linhx for conv obs on proc',nproc,' =',tsum + if (nob .ne. nobs_max) then + print *,'bin: number of obs not what expected in get_convobs_data',nob,nobs_max + call stop2(94) + end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total obs in diag not what expected in get_convobs_data',nobdiag, nobs_maxdiag + call stop2(94) + endif + + end subroutine get_convobs_data_bin + +! writing spread diagnostics +subroutine write_convobs_data(obspath, datestring, nobs_max, nobs_maxdiag, & + x_fit, x_sprd, x_used, id, id2, gesid2) + implicit none + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + + real(r_single), dimension(nobs_max), intent(in) :: x_fit, x_sprd + integer(i_kind), dimension(nobs_maxdiag), intent(in) :: x_used + + character(len=10), intent(in) :: id, id2, gesid2 + + if (netcdf_diag) then + call write_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & + x_fit, x_sprd, x_used, id, gesid2) + else + call write_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & + x_fit, x_sprd, x_used, id, id2, gesid2) + endif +end subroutine write_convobs_data + + +! writing spread diagnostics to binary file +subroutine write_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & + x_fit, x_sprd, x_used, id, id2, gesid2) + implicit none + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + + real(r_single), dimension(nobs_max), intent(in) :: x_fit, x_sprd + integer(i_kind), dimension(nobs_maxdiag), intent(in) :: x_used + + character(len=10), intent(in) :: id, id2, gesid2 + + + character*500 obsfile,obsfile2 + character(len=4) pe_name + + character(len=3) :: obtype + integer(i_kind) :: iunit, iunit2 + integer(i_kind) :: nob, nobdiag, n, ind_sprd + integer(i_kind) :: nchar, nreal, ii, ipe, ios, idate, mype, ioff0 + character(8),allocatable,dimension(:) :: cdiagbuf + real(r_single),allocatable,dimension(:,:) :: rdiagbuf + logical :: fexist, init_pass + + iunit = 7 + iunit2 = 17 + + nob = 0 + nobdiag = 0 + init_pass = .true. + + + if (datestring .eq. '0000000000') then + obsfile2 = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(gesid2))//"."//trim(adjustl(id2)) + else + obsfile2 = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(gesid2))//"."//datestring//'_'//trim(adjustl(id2)) + endif + peloop: do ipe=0,npefiles + + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_conv_ges."//datestring//'_'//trim(adjustl(id)) + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') then + obsfile = trim(adjustl(obspath))//"diag_conv_ges."//trim(adjustl(id)) + endif + else ! read raw, unconcatenated pe* files. + obsfile = trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.conv_01' + endif + + inquire(file=obsfile,exist=fexist) + if (.not. fexist) cycle peloop + + open(iunit,form="unformatted",file=obsfile,iostat=ios) + rewind(iunit) + if (init_pass) then + open(iunit2,form="unformatted",file=obsfile2,iostat=ios) + read(iunit) idate + write(iunit2) idate + init_pass = .false. + endif +10 continue + read(iunit,err=20,end=30) obtype,nchar,nreal,ii,mype,ioff0 + allocate(cdiagbuf(ii),rdiagbuf(nreal,ii)) + read(iunit,err=20) cdiagbuf(1:ii),rdiagbuf(1:nreal,1:ii) + + ind_sprd = -1 + if (obtype == ' t' .or. obtype == ' ps' .or. obtype == 'tcp' .or. & + obtype == ' pw') then + ind_sprd = 20 + elseif (obtype == ' q' .or. obtype == 'spd') then + ind_sprd = 21 + elseif (obtype == 'gps') then + ind_sprd = 22 + elseif (obtype == ' dw') then + ind_sprd = 27 + endif + + if (obtype == ' t' .or. obtype == ' ps' .or. obtype == 'tcp' .or. & + obtype == ' q' .or. obtype == ' dw' .or. obtype == ' pw' .or. & + obtype == 'spd' .or. obtype == 'gps') then + ! defaults for not used in EnKF + rdiagbuf(12,:) = -1 ! not used in EnKF + ! only process if this record was used in EnKF + do n=1,ii + nobdiag = nobdiag + 1 + ! skip if not used in EnKF + if (x_used(nobdiag) == 1) then + ! update if it is used in EnKF + nob = nob + 1 + rdiagbuf(12,n) = 1 + if (obtype == 'gps') then + rdiagbuf(5,n) = x_fit(nob) / rdiagbuf(17,n) + else if (obtype == ' q') then + rdiagbuf(19,n) = (x_fit(nob) + rdiagbuf(19,n) - rdiagbuf(18,n)) * rdiagbuf(20,n) + rdiagbuf(18,n) = x_fit(nob) * rdiagbuf(20,n) + else + rdiagbuf(19,n) = x_fit(nob) + rdiagbuf(19,n) - rdiagbuf(18,n) + rdiagbuf(18,n) = x_fit(nob) + endif + rdiagbuf(ind_sprd,n) = x_sprd(nob) + if (obtype == ' q') then + rdiagbuf(ind_sprd,n) = x_sprd(nob) * rdiagbuf(20,n)*rdiagbuf(20,n) + endif + endif enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! refractivity (setupref.f90) -! rdiagbuf(1,i) = ictype(ikx) ! observation type -! rdiagbuf(2,i) = zero ! uses gps_ref (one=use of bending angle) -! rdiagbuf(3,i) = data(ilate,i) ! lat in degrees -! rdiagbuf(4,i) = data(ilone,i) ! lon in degrees -! rdiagbuf(5,i) = gps2work(3,i) ! incremental bending angle (x100 %) -! rdiagbuf(6,i) = pressure(i) ! guess observation pressure (hPa) -! rdiagbuf(7,i) = elev ! height in meters -! rdiagbuf(8,i) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,i) = data(ipctc,i) ! input bufr qc - index of per cent confidence -! rdiagbuf(9,i) = elev-zsges ! height above model terrain (m) -! rdiagbuf(11,i) = data(iuse,i) ! data usage flag -! bending angle (setupbend.f90) -! rdiagbuf(1,i) = ictype(ikx) ! observation type -! rdiagbuf(2,i) = one ! uses gps_ref (one = use of bending angle) -! rdiagbuf(3,i) = data(ilate,i) ! lat in degrees -! rdiagbuf(4,i) = data(ilone,i) ! lon in degrees -! rdiagbuf(5,i) = gps2work(3,i) ! incremental bending angle (x100 %) -! rdiagbuf(6,i) = dpressure(i) ! guess observation pressure (hPa) -! rdiagbuf(7,i) = tpdpres-rocprof ! impact height in meters -! rdiagbuf(8,i) = dtptimes ! obs time (hours relative to analysis time) -! rdiagbuf(9,i) = data(ipctc,i) ! input bufr qc - index of per cent confidence -! if(qcfail_loc(i) == one) rdiagbuf(10,i) = one -! if(qcfail_high(i) == one) rdiagbuf(10,i) = two -! if(qcfail_gross(i) == one) then -! if(qcfail_high(i) == one) then -! rdiagbuf(10,i) = four -! else -! rdiagbuf(10,i) = three -! endif -! else if(qcfail_stats_1(i) == one) then -! if(qcfail_high(i) == one) then -! rdiagbuf(10,i) = six -! else -! rdiagbuf(10,i) = five -! endif -! else if(qcfail_stats_2(i) == one) then -! if(qcfail_high(i) == one) then -! rdiagbuf(10,i) = eight -! else -! rdiagbuf(10,i) = seven -! endif -! end if -! if(muse(i)) then ! modified in genstats_gps due to toss_gps -! rdiagbuf(12,i) = one ! minimization usage flag (1=use, -1=not used) -! else -! rdiagbuf(12,i) = -one -! endif -! rdiagbuf(13,i) = zero !nonlinear qc relative weight - will be defined in genstats_gps -! rdiagbuf(14,i) = errinv_input ! original inverse gps obs error (N**-1) -! rdiagbuf(15,i) = errinv_adjst ! original + represent error inverse gps -! ! obs error (N**-1) -! rdiagbuf(16,i) = errinv_final ! final inverse observation error due to -! ! superob factor (N**-1) -! ! modified in genstats_gps -! rdiagbuf (17,i) = data(igps,i) ! refractivity observation (units of N) -! rdiagbuf (18,i) = data(igps,i)-nrefges ! obs-ges used in analysis (units of N) -! rdiagbuf (19,i) = data(igps,i)-nrefges ! obs-ges w/o bias correction (future slot) -! rdiagbuf(11,i) = data(iuse,i) ! data usage flag -! rdiagbuf (17,i) = data(igps,i) ! bending angle observation (degrees) -! rdiagbuf (18,i) = data(igps,i)-dbend(i) ! obs-ges used in analysis (degrees) -! rdiagbuf (19,i) = data(igps,i)-dbend(i) ! obs-ges w/o bias correction (future slot) - else if (obtype == ' dw') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if + ! special processing for u and v + else if (obtype == ' uv') then + ! defaults for not used in EnKF + rdiagbuf(12,:) = -1 do n=1,ii - if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - rdiagbuf(16,n) > errorlimit2)cycle - if(abs(rdiagbuf(17,n)) > 1.e9_r_kind .or. & - rdiagbuf(6,n) < 0.001_r_kind .or. & - rdiagbuf(6,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' dw conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8) - write (6,*) (rdiagbuf2(i,n),i=1,8) - call stop2(-98) - end if - else - rdiagbuf2(18,n) = rdiagbuf(18,n) - rdiagbuf2(19,n) = rdiagbuf(19,n) - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(6,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 - else - x_errorig(nob) = 1.e10_r_kind + nobdiag = nobdiag + 1 + if (x_used(nobdiag) == 1) then + nob = nob + 1 + rdiagbuf(12,n) = 1 + ! u should be saved first + rdiagbuf(19,n) = x_fit(nob) + rdiagbuf(19,n) - rdiagbuf(18,n) + rdiagbuf(18,n) = x_fit(nob) + rdiagbuf(24,n) = x_sprd(nob) + nob = nob + 1 + rdiagbuf(22,n) = x_fit(nob) + rdiagbuf(22,n) - rdiagbuf(21,n) + rdiagbuf(21,n) = x_fit(nob) + rdiagbuf(25,n) = x_sprd(nob) endif - x_err(nob) = (one/rdiagbuf(16,n))**2 - x_obs(nob) = rdiagbuf(17,n) - h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf(18,n) - h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(18,n) - !h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(19,n) - x_type(nob) = obtype enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! doppler lidar winds -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = rmiss_single ! station elevation (meters) -! rdiagbuf(6,ii) = presw ! observation pressure (hPa) -! rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = rmiss_single ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(12,ii) = -one -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error -! rdiagbuf(17,ii) = data(ilob,i) ! observation -! rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis -! rdiagbuf(19,ii) = data(ilob,i)-dwwind! obs-ges w/o bias correction (future slot) -! rdiagbuf(20,ii) = factw ! 10m wind reduction factor -! rdiagbuf(21,ii) = data(ielva,i)*rad2deg! elevation angle (degrees) -! rdiagbuf(22,ii) = data(iazm,i)*rad2deg ! bearing or azimuth (degrees) -! rdiagbuf(23,ii) = data(inls,i) ! number of laser shots -! rdiagbuf(24,ii) = data(incls,i) ! number of cloud laser shots -! rdiagbuf(25,ii) = data(iatd,i) ! atmospheric depth -! rdiagbuf(26,ii) = data(ilob,i) ! line of sight component of wind orig. - else if (obtype == ' pw') then - allocate(cdiagbuf(ii),rdiagbuf(nreal,ii),rdiagbuf2(nreal,ii)) - read(iunit) cdiagbuf(1:ii),rdiagbuf(:,1:ii) - if(twofiles)then - allocate(cdiagbuf2(ii)) - read(iunit2)cdiagbuf2(1:ii),rdiagbuf2(:,1:ii) - end if + ! tcx, tcy, tcz have guess in different field from the rest + else if ((obtype == 'tcx') .or. (obtype == 'tcy') .or. (obtype == 'tcz')) then + rdiagbuf(5,:) = 1.e10 do n=1,ii - if(rdiagbuf(12,n) < zero .or. rdiagbuf(16,n) < errorlimit .or. & - rdiagbuf(16,n) > errorlimit2)cycle - if(abs(rdiagbuf(17,n)) > 1.e9_r_kind .or. & - rdiagbuf(6,n) < 0.001_r_kind .or. & - rdiagbuf(6,n) > 1200._r_kind) cycle - nob = nob + 1 - if(twofiles)then - if(rdiagbuf(1,n) /= rdiagbuf2(1,n) .or. abs(rdiagbuf(3,n)-rdiagbuf2(3,n)) .gt. 1.e-5 .or. & - abs(rdiagbuf(4,n)-rdiagbuf2(4,n)) .gt. 1.e-5 .or. abs(rdiagbuf(8,n)-rdiagbuf2(8,n)) .gt. 1.e-5)then - write (6,*) ' pw conv ob data inconsistency ' - write (6,*) (rdiagbuf(i,n),i=1,8) - write (6,*) (rdiagbuf2(i,n),i=1,8) - call stop2(-98) - end if - else - rdiagbuf2(18,n) = rdiagbuf(18,n) - rdiagbuf2(19,n) = rdiagbuf(19,n) - end if - x_code(nob) = rdiagbuf(1,n) - x_lat(nob) = rdiagbuf(3,n) - x_lon(nob) = rdiagbuf(4,n) - x_press(nob) = rdiagbuf(6,n) - x_time(nob) = rdiagbuf(8,n) - if (rdiagbuf(14,n) > 1.e-5_r_kind) then - x_errorig(nob) = (one/rdiagbuf(14,n))**2 - else - x_errorig(nob) = 1.e10_r_kind + nobdiag = nobdiag + 1 + if (x_used(nobdiag) == 1) then + nob = nob + 1 + rdiagbuf(5,n) = x_fit(nob) endif - x_err(nob) = (one/rdiagbuf(16,n))**2 - x_obs(nob) = rdiagbuf(17,n) - h_x_ensmean(nob) = rdiagbuf(17,n)-rdiagbuf(18,n) - h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(18,n) - !h_xnobc(nob) = rdiagbuf(17,n)-rdiagbuf2(19,n) - x_type(nob) = obtype enddo - deallocate(cdiagbuf,rdiagbuf,rdiagbuf2) - if(twofiles)deallocate(cdiagbuf2) -! total column water -! cdiagbuf(ii) = station_id ! station id -! rdiagbuf(1,ii) = ictype(ikx) ! observation type -! rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype -! rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) -! rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) -! rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) -! rdiagbuf(6,ii) = data(iobsprs,i) ! observation pressure (hPa) -! rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) -! rdiagbuf(8,ii) = dtime ! obs time (hours relative to analysis time) -! rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark -! rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark -! rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag -! rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) -! rdiagbuf(12,ii) = -one -! rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight -! rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error -! rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error -! rdiagbuf(16,ii) = errinv_final ! final inverse observation error -! rdiagbuf(17,ii) = dpw ! total precipitable water obs (kg/m**2) -! rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (kg/m**2) -! rdiagbuf(19,ii) = dpw-pwges ! obs-ges w/o bias correction (kg/m**2) (future slot) else - print *,'warning - unknown ob type ',obtype - end if + nobdiag = nobdiag + ii + endif + ! write the updated rdiagbuf + write(iunit2,err=20) obtype,nchar,nreal,ii,mype,ioff0 + write(iunit2) cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + go to 10 20 continue print *,'error reading diag_conv file' 30 continue close(iunit) - if(twofiles) close(iunit2) enddo peloop ! ipe loop + close(iunit2) + if (nob .ne. nobs_max) then - print *,'number of obs not what expected in get_convobs_data',nob,nobs_max + print *,'number of obs not what expected in write_convobs_data',nob,nobs_max call stop2(94) end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total obs in diag not what expected in write_convobs_data',nobdiag, nobs_maxdiag + call stop2(94) + endif + + end subroutine write_convobs_data_bin + +! writing spread diagnostics to netcdf file +subroutine write_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & + x_fit, x_sprd, x_used, id, gesid) + use netcdf, only: nf90_inq_dimid, nf90_open, nf90_close, NF90_NETCDF4, & + nf90_inquire_dimension, NF90_WRITE, nf90_create, nf90_def_dim + use ncdw_climsg, only: nclayer_check + + use constants, only: r_missing + implicit none + + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + + real(r_single), dimension(nobs_max), intent(in) :: x_fit, x_sprd + integer(i_kind), dimension(nobs_maxdiag), intent(in) :: x_used + + character(len=10), intent(in) :: id, gesid + + character*500 obsfile, obsfile2 + character(len=4) pe_name + + character(len=3) :: obtype + integer(i_kind) :: iunit, nobsid + integer(i_kind) :: nob, nobdiag, nobs, ipe, i, itype + integer(i_kind), dimension(:), allocatable :: enkf_use_flag, enkf_use_flag_v + real(r_single), dimension(:), allocatable :: enkf_fit, enkf_fit_v + real(r_single), dimension(:), allocatable :: enkf_sprd, enkf_sprd_v + logical :: fexist + + nob = 0 + nobdiag = 0 + + + obtypeloop: do itype=1, nobtype + + obtype = obtypes(itype) + peloop: do ipe=0,npefiles + + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//datestring//'_'//trim(adjustl(id))//'.nc4' + obsfile2 = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//datestring//'_'//trim(adjustl(id))//'_spread.nc4' + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') & + obsfile = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//trim(adjustl(id))//'.nc4' + obsfile2 = trim(adjustl(obspath))//"diag_conv_"//trim(adjustl(obtype))//"_ges."//trim(adjustl(id))//'_spread.nc4' + else ! read raw, unconcatenated pe* files. + obsfile = & + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.conv_'//trim(adjustl(obtype))//'_01.nc4' + obsfile2 = & + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.conv_'//trim(adjustl(obtype))//'_01_spread.nc4' + endif - end subroutine get_convobs_data + inquire(file=obsfile,exist=fexist) + if (.not. fexist) cycle peloop + + call nclayer_check(nf90_open(obsfile, NF90_WRITE, iunit, cache_size = 2147483647)) + call nclayer_check(nf90_inq_dimid(iunit, "nobs", nobsid)) + call nclayer_check(nf90_inquire_dimension(iunit, nobsid, len = nobs)) + call nclayer_check(nf90_close(iunit)) + + if (nobs <= 0) cycle peloop + + allocate(enkf_use_flag(nobs), enkf_fit(nobs), enkf_sprd(nobs)) + + if (obtype == ' uv') then + allocate(enkf_use_flag_v(nobs), enkf_fit_v(nobs), enkf_sprd_v(nobs)) + endif + + + do i = 1, nobs + nobdiag = nobdiag + 1 + + ! skip if not used in EnKF + if (x_used(nobdiag) == 1) then + ! update if it is used in EnKF + nob = nob + 1 + enkf_use_flag(i) = 1 + enkf_fit(i) = x_fit(nob) + enkf_sprd(i) = x_sprd(nob) + if (obtype== ' uv') then + nob = nob + 1 + enkf_use_flag_v(i) = 1 + enkf_fit_v(i) = x_fit(nob) + enkf_sprd_v(i) = x_sprd(nob) + endif + else + enkf_use_flag(i) = -1 + enkf_fit(i) = r_missing + enkf_sprd(i) = r_missing + if (obtype== ' uv') then + enkf_use_flag_v(i) = -1 + enkf_fit_v(i) = r_missing + enkf_sprd_v(i) = r_missing + endif + + endif + enddo + + inquire(file=obsfile2,exist=fexist) + if (.not. fexist) then + call nclayer_check(nf90_create(trim(obsfile2), NF90_NETCDF4, & + iunit)) + call nclayer_check(nf90_def_dim(iunit, "nobs", nobs, nobsid)) + else + call nclayer_check(nf90_open(obsfile2, NF90_WRITE, iunit)) + call nclayer_check(nf90_inq_dimid(iunit, "nobs", nobsid)) + endif + + if (obtype == ' uv') then + call write_ncvar_int(iunit, nobsid, "u_EnKF_use_flag", enkf_use_flag) + call write_ncvar_int(iunit, nobsid, "v_EnKF_use_flag", enkf_use_flag_v) + deallocate(enkf_use_flag, enkf_use_flag_v) + call write_ncvar_single(iunit, nobsid, "u_EnKF_fit_"//trim(gesid), enkf_fit) + call write_ncvar_single(iunit, nobsid, "v_EnKF_fit_"//trim(gesid), enkf_fit_v) + deallocate(enkf_fit, enkf_fit_v) + call write_ncvar_single(iunit, nobsid, "u_EnKF_spread_"//trim(gesid), enkf_sprd) + call write_ncvar_single(iunit, nobsid, "v_EnKF_spread_"//trim(gesid), enkf_sprd_v) + deallocate(enkf_sprd, enkf_sprd_v) + else + call write_ncvar_int(iunit, nobsid, "EnKF_use_flag", enkf_use_flag) + deallocate(enkf_use_flag) + call write_ncvar_single(iunit, nobsid, "EnKF_fit_"//trim(gesid), enkf_fit) + deallocate(enkf_fit) + call write_ncvar_single(iunit, nobsid, "EnKF_spread_"//trim(gesid), enkf_sprd) + deallocate(enkf_sprd) + endif + + call nclayer_check(nf90_close(iunit)) + + enddo peloop ! ipe loop + enddo obtypeloop + + if (nob .ne. nobs_max) then + print *,'number of obs not what expected in write_convobs_data',nob,nobs_max + call stop2(94) + end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total obs in diag not what expected in write_convobs_data',nobdiag, nobs_maxdiag + call stop2(94) + endif + + contains + subroutine write_ncvar_single(iunit, dimid, varname, field) + use netcdf, only: nf90_def_var, nf90_put_var, nf90_inq_varid, & + nf90_def_var_deflate,NF90_FLOAT, NF90_ENOTVAR + use ncdw_climsg, only: nclayer_check + use ncdw_types, only: NLAYER_COMPRESSION + implicit none + integer(i_kind), intent(in) :: iunit, dimid + character(*), intent(in) :: varname + real(r_single), dimension(:), allocatable :: field + + integer :: ierr, varid + + ierr = nf90_inq_varid(iunit, varname, varid) + if (ierr == NF90_ENOTVAR) then + call nclayer_check(nf90_def_var(iunit, varname, NF90_FLOAT, dimid, varid)) + call nclayer_check(nf90_def_var_deflate(iunit, varid, 1, 1, int(NLAYER_COMPRESSION))) + endif + call nclayer_check(nf90_put_var(iunit, varid, field)) + end subroutine write_ncvar_single + + subroutine write_ncvar_int(iunit, dimid, varname, field) + use netcdf, only: nf90_def_var, nf90_put_var, nf90_inq_varid, & + nf90_def_var_deflate,NF90_INT, NF90_ENOTVAR + use ncdw_climsg, only: nclayer_check + use ncdw_types, only: NLAYER_COMPRESSION + implicit none + integer(i_kind), intent(in) :: iunit, dimid + character(*), intent(in) :: varname + integer(i_kind), dimension(:), allocatable :: field + + integer :: ierr, varid + + ierr = nf90_inq_varid(iunit, varname, varid) + if (ierr == NF90_ENOTVAR) then + call nclayer_check(nf90_def_var(iunit, varname, NF90_INT, dimid, varid)) + call nclayer_check(nf90_def_var_deflate(iunit, varid, 1, 1, int(NLAYER_COMPRESSION))) + endif + call nclayer_check(nf90_put_var(iunit, varid, field)) + end subroutine write_ncvar_int + +end subroutine write_convobs_data_nc end module readconvobs + + diff --git a/src/enkf/readozobs.f90 b/src/enkf/readozobs.f90 index 638e88545..0768dd9fb 100644 --- a/src/enkf/readozobs.f90 +++ b/src/enkf/readozobs.f90 @@ -10,35 +10,58 @@ module readozobs ! ! Public Subroutines: ! get_num_ozobs: determine the number of observations to read. -! get_ozobs_data: read the data. +! get_ozobs_data: read the data and calculate H(x) for ensemble members. +! write_ozvobs_data: output diag file with spread ! ! Public Variables: None ! ! program history log: ! 2009-02-23 Initial version. +! 2016-11-29 shlyaeva - updated read routine to calculate linearized H(x) +! added write_ozvobs_data to output ensemble spread +! 2017-12-13 shlyaeva - added netcdf diag read/write capability ! ! attributes: ! language: f95 ! !$$$ -use kinds, only: r_single,i_kind,r_kind -use params, only: nsats_oz,sattypes_oz,npefiles - +use kinds, only: r_single,i_kind,r_kind,r_double +use params, only: nsats_oz,sattypes_oz,npefiles,netcdf_diag +use constants, only: deg2rad, zero implicit none private -public :: get_num_ozobs, get_ozobs_data +public :: get_num_ozobs, get_ozobs_data, write_ozobs_data contains -subroutine get_num_ozobs(obspath,datestring,num_obs_tot,id) - character (len=500), intent(in) :: obspath - character (len=10), intent(in) :: datestring - character(len=500) obsfile - character(len=8), intent(in) :: id - character(len=4) pe_name - integer(i_kind) :: nlevs ! number of levels (layer amounts + total column) per obs +! get number of ozone observations +subroutine get_num_ozobs(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + implicit none + character(len=500), intent(in) :: obspath + character(len=10), intent(in) :: datestring + character(len=10), intent(in) :: id + integer(i_kind), intent(out) :: num_obs_tot, num_obs_totdiag + + if (netcdf_diag) then + call get_num_ozobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + else + call get_num_ozobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + endif +end subroutine get_num_ozobs + +! get number of ozone observations from binary file +subroutine get_num_ozobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + implicit none + character(len=500), intent(in) :: obspath + character(len=10), intent(in) :: datestring + character(len=8), intent(in) :: id + integer(i_kind), intent(out) :: num_obs_tot, num_obs_totdiag + + character(len=500) :: obsfile + character(len=4) :: pe_name + integer(i_kind) :: nlevsoz ! number of levels (layer amounts + total column) per obs character(20) :: isis ! sensor/instrument/satellite id character(10) :: obstype ! type of ozone obs character(10) :: dplat ! sat sensor @@ -47,13 +70,13 @@ subroutine get_num_ozobs(obspath,datestring,num_obs_tot,id) real(r_single),allocatable,dimension(:,:,:)::rdiagbuf real(r_kind) :: errorlimit,errorlimit2 integer(i_kind),allocatable,dimension(:,:)::idiagbuf - integer(i_kind) iunit,jiter,ii,ireal,iint,iextra,idate,ios,nsat,n,k,ipe - integer(i_kind), intent(out) :: num_obs_tot + integer(i_kind) iunit,jiter,ii,ireal,irdim1,ioff0,iint,idate,ios,nsat,n,k,ipe integer(i_kind), allocatable, dimension(:) :: iouse integer(i_kind):: nread,nkeep logical :: fexist, init_pass iunit = 7 num_obs_tot = 0 + num_obs_totdiag = 0 ! make consistent with screenobs errorlimit=1._r_kind/sqrt(1.e9_r_kind) errorlimit2=1._r_kind/sqrt(1.e-6_r_kind) @@ -75,12 +98,11 @@ subroutine get_num_ozobs(obspath,datestring,num_obs_tot,id) endif inquire(file=obsfile,exist=fexist) if (.not. fexist) cycle peloop - !print *,'obsfile=',obsfile open(iunit,form="unformatted",file=obsfile,iostat=ios) if (init_pass) then - read(iunit,err=20,end=30) isis,dplat,obstype,jiter,nlevs,idate,iint,ireal,iextra + read(iunit,err=20,end=30) isis,dplat,obstype,jiter,nlevsoz,idate,iint,ireal,irdim1,ioff0 if(allocated(pob))deallocate(pob,grs,err,iouse) - allocate(pob(nlevs),grs(nlevs),err(nlevs),iouse(nlevs)) + allocate(pob(nlevsoz),grs(nlevsoz),err(nlevsoz),iouse(nlevsoz)) read(iunit,err=20,end=30) pob,grs,err,iouse init_pass = .false. endif @@ -88,10 +110,11 @@ subroutine get_num_ozobs(obspath,datestring,num_obs_tot,id) read(iunit,err=20,end=30) ii allocate(idiagbuf(iint,ii)) allocate(diagbuf(ireal,ii)) - allocate(rdiagbuf(6,nlevs,ii)) + allocate(rdiagbuf(irdim1,nlevsoz,ii)) read(iunit,err=20,end=30) idiagbuf,diagbuf,rdiagbuf - do k=1,nlevs + do k=1,nlevsoz nread=nread+ii + num_obs_totdiag = num_obs_totdiag + ii if (iouse(k) < 0 .or. pob(k) <= 0.001 .or. & pob(k) > 1200._r_kind) cycle do n=1,ii @@ -115,29 +138,177 @@ subroutine get_num_ozobs(obspath,datestring,num_obs_tot,id) enddo peloop ! ipe enddo ! satellite print *,num_obs_tot,' ozone obs' + print *,num_obs_totdiag, ' total ozone obs in diag file' if(allocated(pob))deallocate(pob,grs,err,iouse) -end subroutine get_num_ozobs +end subroutine get_num_ozobs_bin + +! get number of observations from netcdf file +subroutine get_num_ozobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + use nc_diag_read_mod, only: nc_diag_read_get_var + use nc_diag_read_mod, only: nc_diag_read_get_dim + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + implicit none -subroutine get_ozobs_data(obspath, datestring, nobs_max, h_x, h_xnobc, x_obs, x_err, & - x_lon, x_lat, x_press, x_time, x_code, x_errorig, x_type, id,id2) + character(len=500), intent(in) :: obspath + character(len=10), intent(in) :: datestring + integer(i_kind), intent(out) :: num_obs_tot, num_obs_totdiag + character(len=8), intent(in) :: id + character(len=500) obsfile + character(len=4) pe_name + real(r_kind) :: errorlimit,errorlimit2 + integer(i_kind) iunit + integer(i_kind) :: i, nsat, ipe, nobs_curr + integer(i_kind):: nread,nkeep + logical :: fexist + + real(r_single), allocatable, dimension (:) :: Pressure + integer(i_kind), allocatable, dimension (:) :: Analysis_Use_Flag + real(r_single), allocatable, dimension (:) :: Errinv + real(r_single), allocatable, dimension (:) :: Observation + + num_obs_tot = 0 + num_obs_totdiag = 0 +! make consistent with screenobs + errorlimit=1._r_kind/sqrt(1.e9_r_kind) + errorlimit2=1._r_kind/sqrt(1.e-6_r_kind) + do nsat=1,nsats_oz + nread = 0 + nkeep = 0 + peloop: do ipe=0,npefiles + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//datestring//'_'//trim(adjustl(id))//'.nc4' + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') & + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//trim(adjustl(id))//'.nc4' + else ! read raw, unconcatenated pe* files. + obsfile =& + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_oz(nsat))//'_01.nc4' + endif + inquire(file=obsfile,exist=fexist) + if (.not. fexist) cycle peloop + + call nc_diag_read_init(obsfile, iunit) + + nobs_curr = nc_diag_read_get_dim(iunit,'nobs') + + if (nobs_curr <= 0) then + call nc_diag_read_close(obsfile) + cycle peloop + endif + + allocate(Pressure(nobs_curr), Analysis_Use_Flag(nobs_curr), & + Errinv(nobs_curr), Observation(nobs_curr)) + + call nc_diag_read_get_var(iunit, 'Reference_Pressure', Pressure) + call nc_diag_read_get_var(iunit, 'Analysis_Use_Flag', Analysis_Use_Flag) + call nc_diag_read_get_var(iunit, 'Inverse_Observation_Error', Errinv) + call nc_diag_read_get_var(iunit, 'Observation', Observation) + + call nc_diag_read_close(obsfile) + + num_obs_totdiag = num_obs_totdiag + nobs_curr + nread = nread + nobs_curr + do i = 1, nobs_curr + if (Analysis_Use_Flag(i) < 0 .or. Pressure(i) <= 0.001 .or. & + Pressure(i) > 1200._r_kind) cycle + if (Errinv(i) <= errorlimit .or. & + Errinv(i) >= errorlimit2 .or. & + abs(Observation(i)) > 1.e9_r_kind) cycle + nkeep = nkeep + 1 + num_obs_tot = num_obs_tot + 1 + end do + if (ipe .eq. npefiles) then + write(6,100) nsat,trim(sattypes_oz(nsat)),nread,nkeep,num_obs_tot +100 format(2x,i3,2x,a20,2x,'nread= ',i9,2x,'nkeep=',i9,2x,'num_obs_tot= ',i9) + endif + deallocate(Pressure, Analysis_Use_Flag, Errinv, Observation) + enddo peloop ! ipe + enddo ! satellite + print *,num_obs_tot,' ozone obs' + print *,num_obs_totdiag, ' total ozone obs in diag file' +end subroutine get_num_ozobs_nc + +! read ozone observation data +subroutine get_ozobs_data(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, x_errorig, x_type, x_used, id, nanal, nmem) + use params, only: neigv + implicit none character*500, intent(in) :: obspath - character*500 obsfile,obsfile2 - character*10, intent(in) :: datestring - character(len=8), intent(in) :: id,id2 - character(len=4) pe_name + character*10, intent(in) :: datestring + + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + real(r_single), dimension(nobs_max), intent(out) :: hx_mean, hx_mean_nobc, hx + ! hx_modens holds modulated ensemble in ob space (zero size and not referenced if neigv=0) + real(r_single), dimension(neigv,nobs_max), intent(out) :: hx_modens + real(r_single), dimension(nobs_max), intent(out) :: x_obs + real(r_single), dimension(nobs_max), intent(out) :: x_err, x_errorig + real(r_single), dimension(nobs_max), intent(out) :: x_lon, x_lat + real(r_single), dimension(nobs_max), intent(out) :: x_press, x_time + integer(i_kind), dimension(nobs_max), intent(out) :: x_code + character(len=20), dimension(nobs_max), intent(out) :: x_type + integer(i_kind), dimension(nobs_maxdiag), intent(out) :: x_used + + character(len=8), intent(in) :: id + integer(i_kind), intent(in) :: nanal, nmem + + if (netcdf_diag) then + call get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, x_errorig, x_type, x_used, id, nanal, nmem) + else + call get_ozobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, x_errorig, x_type, x_used, id, nanal, nmem) + endif - integer(i_kind) :: nlevs ! number of levels (layer amounts + total column) per obs - character(20) :: isis,isis2 ! sensor/instrument/satellite id +end subroutine get_ozobs_data + +! read ozone observation data from binary file +subroutine get_ozobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, x_errorig, x_type, x_used, id, nanal, nmem) + + use sparsearr,only:sparr, sparr2, readarray, delete, assignment(=) + use params,only: nanals, lobsdiag_forenkf, neigv, vlocal_evecs + use statevec, only: state_d + use mpisetup, only: mpi_wtime, nproc + use observer_enkf, only: calc_linhx, calc_linhx_modens, setup_linhx + implicit none + + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + real(r_single), dimension(nobs_max), intent(out) :: hx_mean, hx_mean_nobc, hx + ! hx_modens holds modulated ensemble in ob space (zero size and not referenced if neigv=0) + real(r_single), dimension(neigv,nobs_max), intent(out) :: hx_modens + real(r_single), dimension(nobs_max), intent(out) :: x_obs + real(r_single), dimension(nobs_max), intent(out) :: x_err, x_errorig + real(r_single), dimension(nobs_max), intent(out) :: x_lon, x_lat + real(r_single), dimension(nobs_max), intent(out) :: x_press, x_time + integer(i_kind), dimension(nobs_max), intent(out) :: x_code + character(len=20), dimension(nobs_max), intent(out) :: x_type + integer(i_kind), dimension(nobs_maxdiag), intent(out) :: x_used + + character(len=8), intent(in) :: id + integer(i_kind), intent(in) :: nanal, nmem + + character*500 :: obsfile, obsfile2 + character(len=8) :: id2 + character(len=4) :: pe_name + + integer(i_kind) :: nlevsoz ! number of levels (layer amounts + total column) per obs + character(20) :: isis,isis2 ! sensor/instrument/satellite id character(10) :: obstype,obstype2 ! type of ozone obs - character(10) :: dplat,dplat2 ! sat sensor - integer(i_kind) iunit,jiter,ii,ireal,iint,iextra,idate,nob,n,ios,nobs_max,nsat,k - integer(i_kind) iunit2,jiter2,nlevs2,idate2,iint2,ireal2,iextra2,ii2,ipe + character(10) :: dplat,dplat2 ! sat sensor + integer(i_kind) nob, nobdiag, n, ios, nsat, k + integer(i_kind) iunit,jiter,ii,ireal,iint,irdim1,idate,ioff0 + integer(i_kind) iunit2,jiter2,ii2,ireal2,iint2,irdim12,idate2,ioff02,nlevsoz2 + integer(i_kind) ipe,ind - real(r_single), dimension(nobs_max) :: h_x,h_xnobc,x_obs,x_err,x_lon,& - x_lat,x_press,x_time,x_errorig - integer(i_kind), dimension(nobs_max) :: x_code - character(len=20), dimension(nobs_max) :: x_type + real(r_double) t1,t2,tsum + type(sparr) :: dhx_dx + type(sparr2) :: dhx_dx_read real(r_single),allocatable,dimension(:,:)::diagbuf,diagbuf2 real(r_single),allocatable,dimension(:,:,:)::rdiagbuf,rdiagbuf2 @@ -145,17 +316,34 @@ subroutine get_ozobs_data(obspath, datestring, nobs_max, h_x, h_xnobc, x_obs, x_ real(r_single), allocatable, dimension(:) :: err,grs,pob real(r_single), allocatable, dimension(:) :: err2,grs2,pob2 integer(i_kind), allocatable, dimension(:) :: iouse,iouse2 - logical twofiles, fexist, fexist2, init_pass, init_pass2 + logical fexist, init_pass + logical twofiles, fexist2, init_pass2 real(r_kind) :: errorlimit,errorlimit2 + integer(i_kind) :: ix, iy, it, ixp, iyp, itp + real(r_kind) :: delx, dely, delxp, delyp, delt, deltp + real(r_single) :: rlat,rlon,rtim,rlat_prev,rlon_prev,rtim_prev,eps ! make consistent with screenobs errorlimit=1._r_kind/sqrt(1.e9_r_kind) errorlimit2=1._r_kind/sqrt(1.e-6_r_kind) + eps = 1.e-3 - twofiles = id /= id2 + twofiles = (.not. lobsdiag_forenkf) .and. (nanal <= nanals) + id2 = 'ensmean' + if (nanal <= nanals) then + write(id2,'(a3,(i3.3))') 'mem',nanal + endif + + + tsum = 0 iunit = 7 iunit2 = 17 nob = 0 + rlat_prev = -1.e30; rlon_prev=-1.e30; rtim_prev = -1.e30 + nobdiag = 0 + x_used = 0 + + hx = zero do nsat=1,nsats_oz init_pass = .true. @@ -173,14 +361,15 @@ subroutine get_ozobs_data(obspath, datestring, nobs_max, h_x, h_xnobc, x_obs, x_ trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_oz(nsat))//'_01' endif inquire(file=obsfile,exist=fexist) - if (.not. fexist) cycle peloop - !print *,'obsfile=',obsfile + if (.not. fexist) then + cycle peloop + endif open(iunit,form="unformatted",file=obsfile,iostat=ios) rewind(iunit) if (init_pass) then - read(iunit,err=20,end=30) isis,dplat,obstype,jiter,nlevs,idate,iint,ireal,iextra + read(iunit,err=20,end=30) isis,dplat,obstype,jiter,nlevsoz,idate,iint,ireal,irdim1,ioff0 if(allocated(pob))deallocate(pob,grs,err,iouse) - allocate(pob(nlevs),grs(nlevs),err(nlevs),iouse(nlevs)) + allocate(pob(nlevsoz),grs(nlevsoz),err(nlevsoz),iouse(nlevsoz)) read(iunit,err=20,end=30) pob,grs,err,iouse init_pass = .false. endif @@ -195,28 +384,27 @@ subroutine get_ozobs_data(obspath, datestring, nobs_max, h_x, h_xnobc, x_obs, x_ obsfile2 =& trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id2))//'/pe'//pe_name//'.'//trim(sattypes_oz(nsat))//'_01' endif - !print *,obsfile2 open(iunit2,form="unformatted",file=obsfile2,iostat=ios) rewind(iunit2) if (init_pass2) then - read(iunit2,err=20,end=30) isis2,dplat2,obstype2,jiter2,nlevs2,idate2,iint2,ireal2,iextra2 + read(iunit2,err=20,end=30) isis2,dplat2,obstype2,jiter2,nlevsoz2,idate2,iint2,ireal2,irdim12,ioff02 if(isis /= isis2 .or. dplat /= dplat2 .or. obstype /= obstype2 .or. jiter /= jiter2 .or. & - nlevs /= nlevs2 .or. idate /= idate2 .or. iint /= iint2 .or. ireal /= ireal2)then + nlevsoz /= nlevsoz2 .or. idate /= idate2 .or. iint /= iint2 .or. ireal /= ireal2)then write(6,*) 'inconsistency in ozone files' write(6,*) 'isis',isis,isis2 write(6,*) 'dplat',dplat,dplat2 write(6,*) 'obstype',obstype,obstype2 write(6,*) 'jiter',jiter,jiter2 - write(6,*) 'nlevs',nlevs,nlevs2 + write(6,*) 'nlevsoz',nlevsoz,nlevsoz2 write(6,*) 'idate',idate,idate2 write(6,*) 'iint',iint,iint2 write(6,*) 'ireal',ireal,ireal2 call stop2(66) end if if (allocated(pob2)) deallocate(pob2,err2,grs2,iouse2) - allocate(pob2(nlevs),grs2(nlevs),err2(nlevs),iouse2(nlevs)) + allocate(pob2(nlevsoz),grs2(nlevsoz),err2(nlevsoz),iouse2(nlevsoz)) read(iunit2,err=20,end=30) pob2,grs2,err2,iouse2 - do k=1,nlevs + do k=1,nlevsoz if(pob(k) /= pob2(k) .or. grs(k) /= grs2(k) .or. err(k) /= err2(k) .or. & iouse(k) /= iouse2(k))then write(6,*) ' ozone file vertical inconsistency level = ',k @@ -230,60 +418,103 @@ subroutine get_ozobs_data(obspath, datestring, nobs_max, h_x, h_xnobc, x_obs, x_ init_pass2 = .false. endif end if + 10 continue read(iunit,err=20,end=30) ii allocate(idiagbuf(iint,ii)) allocate(diagbuf(ireal,ii)) - allocate(rdiagbuf(6,nlevs,ii)) - allocate(rdiagbuf2(6,nlevs,ii)) + allocate(rdiagbuf(irdim1,nlevsoz,ii)) read(iunit,err=20,end=30) idiagbuf,diagbuf,rdiagbuf - if(twofiles)then - read(iunit2,err=20,end=30) ii2 - if(ii /= ii2)then - write(6,*) 'ii inconsistency in ozone ',ii,ii2 - call stop2(68) - end if - allocate(idiagbuf2(iint,ii)) - allocate(diagbuf2(ireal,ii)) - read(iunit2,err=20,end=30) idiagbuf2,diagbuf2,rdiagbuf2 - else - do n=1,ii - do k=1,nlevs - rdiagbuf2(2,k,n)=rdiagbuf(2,k,n) - end do - end do - end if - do k=1,nlevs + if (twofiles) then + read(iunit2,err=20,end=30) ii2 + if(ii /= ii2)then + write(6,*) 'ii inconsistency in ozone ',ii,ii2 + call stop2(68) + end if + allocate(idiagbuf2(iint,ii), diagbuf2(ireal,ii),rdiagbuf2(irdim1,nlevsoz,ii)) + read(iunit2,err=20,end=30) idiagbuf2,diagbuf2,rdiagbuf2 + endif + do k=1,nlevsoz if (iouse(k) < 0 .or. pob(k) <= 0.001 .or. & - pob(k) > 1200._r_kind) cycle + pob(k) > 1200._r_kind) then + nobdiag = nobdiag + ii + cycle + endif do n=1,ii - if(twofiles)then - if(diagbuf(1,n) /= diagbuf2(1,n) .or. diagbuf(2,n) /= diagbuf2(2,n))then - write(6,*) 'lat lon inconsistency in ozone ' - write(6,*) 'lat',diagbuf(1,n),diagbuf2(1,n) - write(6,*) 'lon',diagbuf(2,n),diagbuf2(2,n) - end if + if (twofiles) then + if (diagbuf(1,n) /= diagbuf2(1,n) .or. diagbuf(2,n) /=diagbuf2(2,n))then + write(6,*) 'lat lon inconsistency in ozone ' + write(6,*) 'lat',diagbuf(1,n),diagbuf2(1,n) + write(6,*) 'lon',diagbuf(2,n),diagbuf2(2,n) + end if end if + + nobdiag = nobdiag + 1 if (rdiagbuf(3,k,n) <= errorlimit .or. & rdiagbuf(3,k,n) >= errorlimit2 .or. & abs(rdiagbuf(1,k,n)) > 1.e9_r_kind) cycle nob = nob + 1 + x_used(nobdiag) = 1 x_code(nob) = 700 + k ! made up code for ozone level k x_lat(nob) = diagbuf(1,n) x_lon(nob) = diagbuf(2,n) - !print *,n,k,pob(k) x_press(nob) = pob(k) x_time(nob) = diagbuf(3,n) x_err(nob) = (1./rdiagbuf(3,k,n))**2 x_errorig(nob) = x_err(nob) x_obs(nob) = rdiagbuf(1,k,n) - h_xnobc(nob) = rdiagbuf(1,k,n)-rdiagbuf2(2,k,n) - h_x(nob) = rdiagbuf(1,k,n)-rdiagbuf(2,k,n) + hx_mean(nob) = rdiagbuf(1,k,n)-rdiagbuf(2,k,n) + hx_mean_nobc(nob) = rdiagbuf(1,k,n)-rdiagbuf(2,k,n) x_type(nob) = ' oz ' + if (nanal <= nanals) then + ! read full Hx from diag file + if (.not. lobsdiag_forenkf) then + hx(nob) = rdiagbuf(1,k,n)-rdiagbuf2(2,k,n) + ! run linearized Hx + else + ind = ioff0 + 1 + ! read dHx/dx profile + call readarray(dhx_dx_read, rdiagbuf(ind:irdim1,k,n)) + dhx_dx = dhx_dx_read + t1 = mpi_wtime() + rlat = x_lat(nob)*deg2rad + rlon = x_lon(nob)*deg2rad + rtim = x_time(nob) + if (nob > 1) then + rlat_prev = x_lat(nob-1)*deg2rad + rlon_prev = x_lon(nob-1)*deg2rad + rtim_prev = x_time(nob-1) + endif + if (abs(rlat-rlat_prev) > eps .or. & + abs(rlon-rlon_prev) > eps .or. & + abs(rtim-rtim_prev) > eps) then + call setup_linhx(rlat,rlon,rtim, & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + endif + call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx(nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + ! compute modulated ensemble in obs space + if (neigv > 0) then + call calc_linhx_modens(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx_modens(:,nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp, vlocal_evecs) + endif + t2 = mpi_wtime() + tsum = tsum + t2-t1 + + call delete(dhx_dx) + call delete(dhx_dx_read) + endif + endif + end do ! nn end do ! k - deallocate(idiagbuf,diagbuf,rdiagbuf,rdiagbuf2) - if (twofiles) deallocate(idiagbuf2,diagbuf2) + deallocate(idiagbuf,diagbuf,rdiagbuf) + if (twofiles) deallocate(idiagbuf2,diagbuf2,rdiagbuf2) go to 10 20 continue print *,'error reading diag_sbuv file' @@ -292,15 +523,531 @@ subroutine get_ozobs_data(obspath, datestring, nobs_max, h_x, h_xnobc, x_obs, x_ if(twofiles) close(iunit2) enddo peloop ! ipe enddo ! satellite + if (nanal == nanals .and. lobsdiag_forenkf) print *,'time in calc_linhx for oz obs on proc',nproc,' = ',tsum if (nob /= nobs_max) then print *,'number of obs not what expected in get_ozobs_data',nob,nobs_max call stop2(93) end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total diag obs not what expected in get_ozobs_data',nobdiag,nobs_maxdiag + call stop2(93) + end if if(allocated(pob))deallocate(pob,grs,err,iouse) if(allocated(pob2))deallocate(pob2,grs2,err2,iouse2) - end subroutine get_ozobs_data + end subroutine get_ozobs_data_bin + +! read ozone observation data from netcdf file +subroutine get_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_code, x_errorig, x_type, x_used, id, nanal, nmem) + use nc_diag_read_mod, only: nc_diag_read_get_var + use nc_diag_read_mod, only: nc_diag_read_get_dim, nc_diag_read_get_global_attr + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + + use sparsearr,only:sparr, sparr2, readarray, delete, assignment(=) + use params,only: nanals, lobsdiag_forenkf, neigv, vlocal_evecs + use statevec, only: state_d + use mpisetup, only: mpi_wtime, nproc + use observer_enkf, only: calc_linhx, calc_linhx_modens, setup_linhx + implicit none + + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + real(r_single), dimension(nobs_max), intent(out) :: hx_mean, hx_mean_nobc, hx + ! hx_modens holds modulated ensemble in ob space (zero size and not referenced if neigv=0) + real(r_single), dimension(neigv,nobs_max), intent(out) :: hx_modens + real(r_single), dimension(nobs_max), intent(out) :: x_obs + real(r_single), dimension(nobs_max), intent(out) :: x_err, x_errorig + real(r_single), dimension(nobs_max), intent(out) :: x_lon, x_lat + real(r_single), dimension(nobs_max), intent(out) :: x_press, x_time + integer(i_kind), dimension(nobs_max), intent(out) :: x_code + character(len=20), dimension(nobs_max), intent(out) :: x_type + integer(i_kind), dimension(nobs_maxdiag), intent(out) :: x_used + + character(len=8), intent(in) :: id + integer(i_kind), intent(in) :: nanal, nmem + + character*500 :: obsfile, obsfile2 + character(len=8) :: id2 + character(len=4) :: pe_name + + integer(i_kind) :: nobs_curr, nob, nobdiag, i, nsat, ipe, nsdim + integer(i_kind) :: iunit, iunit2 + + real(r_double) t1,t2,tsum + type(sparr) :: dhx_dx + + real(r_single), allocatable, dimension (:) :: Latitude, Longitude, Pressure, Time + integer(i_kind), allocatable, dimension (:) :: Analysis_Use_Flag + real(r_single), allocatable, dimension (:) :: Errinv + real(r_single), allocatable, dimension (:) :: Observation + real(r_single), allocatable, dimension (:) :: Obs_Minus_Forecast_adjusted, Obs_Minus_Forecast_adjusted2 + real(r_single), allocatable, dimension (:) :: Obs_Minus_Forecast_unadjusted + real(r_single), allocatable, dimension (:,:) :: Observation_Operator_Jacobian + + logical fexist + logical twofiles, fexist2 + real(r_kind) :: errorlimit,errorlimit2 + + integer(i_kind) :: ix, iy, it, ixp, iyp, itp + real(r_kind) :: delx, dely, delxp, delyp, delt, deltp + real(r_single) :: rlat,rlon,rtim,rlat_prev,rlon_prev,rtim_prev,eps + +! make consistent with screenobs + errorlimit=1._r_kind/sqrt(1.e9_r_kind) + errorlimit2=1._r_kind/sqrt(1.e-6_r_kind) + eps = 1.e-3 + + twofiles = (.not. lobsdiag_forenkf) .and. (nanal <= nanals) + id2 = 'ensmean' + if (nanal <= nanals) then + write(id2,'(a3,(i3.3))') 'mem',nanal + endif + + tsum = 0 + nob = 0 + rlat_prev = -1.e30; rlon_prev=-1.e30; rtim_prev = -1.e30 + nobdiag = 0 + x_used = 0 + + hx = zero + + do nsat=1,nsats_oz + peloop: do ipe=0,npefiles + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//datestring//'_'//trim(adjustl(id))//'.nc4' + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') & + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//trim(adjustl(id))//'.nc4' + else ! read raw, unconcatenated pe* files. + obsfile =& + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_oz(nsat))//'_01.nc4' + endif + inquire(file=obsfile,exist=fexist) + if (.not. fexist) then + cycle peloop + endif + + call nc_diag_read_init(obsfile, iunit) + + nobs_curr = nc_diag_read_get_dim(iunit,'nobs') + + if (nobs_curr <= 0) then + call nc_diag_read_close(obsfile) + cycle peloop + endif + + allocate(Latitude(nobs_curr), Longitude(nobs_curr), Time(nobs_curr), Pressure(nobs_curr), & + Analysis_Use_Flag(nobs_curr), Errinv(nobs_curr), Observation(nobs_curr), & + Obs_Minus_Forecast_adjusted(nobs_curr), Obs_Minus_Forecast_unadjusted(nobs_curr)) + call nc_diag_read_get_var(iunit, 'Latitude', Latitude) + call nc_diag_read_get_var(iunit, 'Longitude', Longitude) + call nc_diag_read_get_var(iunit, 'Time', Time) + call nc_diag_read_get_var(iunit, 'Reference_Pressure', Pressure) + call nc_diag_read_get_var(iunit, 'Analysis_Use_Flag', Analysis_Use_Flag) + call nc_diag_read_get_var(iunit, 'Inverse_Observation_Error', Errinv) + call nc_diag_read_get_var(iunit, 'Observation', Observation) + call nc_diag_read_get_var(iunit, 'Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted) + call nc_diag_read_get_var(iunit, 'Obs_Minus_Forecast_unadjusted', Obs_Minus_Forecast_unadjusted) + + if (lobsdiag_forenkf) then + call nc_diag_read_get_global_attr(iunit, "Number_of_state_vars", nsdim) + allocate(Observation_Operator_Jacobian(nsdim, nobs_curr)) + call nc_diag_read_get_var(iunit, 'Observation_Operator_Jacobian', Observation_Operator_Jacobian) + endif + + call nc_diag_read_close(obsfile) + + + if(twofiles)then + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//datestring//'_'//trim(adjustl(id2))//'.nc4' + inquire(file=obsfile2,exist=fexist2) + if (.not. fexist2 .or. datestring .eq. '0000000000') & + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//trim(adjustl(id2))//'.nc4' + else ! read raw, unconcatenated pe* files. + obsfile2 =& + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id2))//'/pe'//pe_name//'.'//trim(sattypes_oz(nsat))//'_01.nc4' + endif + + call nc_diag_read_init(obsfile2, iunit2) + + allocate(Obs_Minus_Forecast_adjusted2(nobs_curr)) + call nc_diag_read_get_var(iunit2, 'Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted2) + + call nc_diag_read_close(obsfile2) + + end if + + do i = 1, nobs_curr + nobdiag = nobdiag + 1 + if (Analysis_Use_Flag(i) < 0 .or. Pressure(i) <= 0.001 .or. & + Pressure(i) > 1200._r_kind) cycle + + if (Errinv(i) <= errorlimit .or. Errinv(i) >= errorlimit2 .or. & + abs(Observation(i)) > 1.e9_r_kind) cycle + nob = nob + 1 + x_used(nobdiag) = 1 + x_code(nob) = 700 ! made up code + x_lat(nob) = Latitude(i) + x_lon(nob) = Longitude(i) + x_press(nob) = Pressure(i) + x_time(nob) = Time(i) + x_err(nob) = (1./Errinv(i))**2 + x_errorig(nob) = x_err(nob) + x_obs(nob) = Observation(i) + hx_mean(nob) = Observation(i) - Obs_Minus_Forecast_adjusted(i) + hx_mean_nobc(nob) = Observation(i) - Obs_Minus_Forecast_unadjusted(i) + x_type(nob) = ' oz ' + if (nanal <= nanals) then + ! read full Hx from diag file + if (.not. lobsdiag_forenkf) then + hx(nob) = Observation(i) - Obs_Minus_Forecast_adjusted2(i) + ! run linearized Hx + else + dhx_dx = Observation_Operator_Jacobian(1:nsdim,i) + t1 = mpi_wtime() + rlat = x_lat(nob)*deg2rad + rlon = x_lon(nob)*deg2rad + rtim = x_time(nob) + if (nob > 1) then + rlat_prev = x_lat(nob-1)*deg2rad + rlon_prev = x_lon(nob-1)*deg2rad + rtim_prev = x_time(nob-1) + endif + if (abs(rlat-rlat_prev) > eps .or. & + abs(rlon-rlon_prev) > eps .or. & + abs(rtim-rtim_prev) > eps) then + call setup_linhx(rlat,rlon,rtim, & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + endif + call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx(nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + ! compute modulated ensemble in obs space + if (neigv > 0) then + call calc_linhx_modens(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx_modens(:,nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp, vlocal_evecs) + endif + t2 = mpi_wtime() + tsum = tsum + t2-t1 + + call delete(dhx_dx) + endif + endif + + end do ! k + + deallocate(Latitude, Longitude, Time, Pressure, Analysis_Use_Flag, Errinv, & + Observation, Obs_Minus_Forecast_adjusted, & + Obs_Minus_Forecast_unadjusted) + if (twofiles) then + deallocate(Obs_Minus_Forecast_adjusted2) + endif + if (lobsdiag_forenkf) then + deallocate(Observation_Operator_Jacobian) + endif + enddo peloop ! ipe + enddo ! satellite + if (nanal == nanals .and. lobsdiag_forenkf) print *, 'time in calc_linhx for oz obs on proc',nproc,' =',tsum + + if (nob /= nobs_max) then + print *,'number of obs not what expected in get_ozobs_data',nob,nobs_max + call stop2(93) + end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total diag obs not what expected in get_ozobs_data',nobdiag,nobs_maxdiag + call stop2(93) + end if + + + end subroutine get_ozobs_data_nc + +! write spread diagnostics +subroutine write_ozobs_data(obspath, datestring, nobs_max, nobs_maxdiag, x_fit, x_sprd, x_used, id, id2, gesid2) +implicit none + + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + real(r_single), dimension(nobs_max), intent(in) :: x_fit, x_sprd + integer(i_kind), dimension(nobs_maxdiag), intent(in) :: x_used + character(len=8), intent(in) :: id, id2, gesid2 + + if (netcdf_diag) then + call write_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, x_fit, x_sprd, x_used, id, gesid2) + else + call write_ozobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, x_fit, x_sprd, x_used, id, id2, gesid2) + endif +end subroutine write_ozobs_data + +! write spread diagnostics to binary file +subroutine write_ozobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, x_fit, x_sprd, x_used, id, id2, gesid2) + implicit none + + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + real(r_single), dimension(nobs_max), intent(in) :: x_fit, x_sprd + integer(i_kind), dimension(nobs_maxdiag), intent(in) :: x_used + character(len=8), intent(in) :: id, id2, gesid2 + + character*500 :: obsfile, obsfile2 + character(len=4) pe_name + + integer(i_kind) :: nlevsoz ! number of levels (layer amounts + total column) per obs + character(20) :: isis ! sensor/instrument/satellite id + character(10) :: obstype ! type of ozone obs + character(10) :: dplat ! sat sensor + integer(i_kind) iunit,jiter,ii,ireal,iint,irdim1,idate,nob,nobdiag,n,ios,nsat,k,ipe,ioff0 + integer(i_kind) iunit2 + + real(r_single),allocatable,dimension(:,:)::diagbuf + real(r_single),allocatable,dimension(:,:,:)::rdiagbuf + integer(i_kind),allocatable,dimension(:,:)::idiagbuf + real(r_single), allocatable, dimension(:) :: err,grs,pob + integer(i_kind), allocatable, dimension(:) :: iouse + logical fexist, init_pass + + iunit = 7 + iunit2 = 17 + nob = 0 + nobdiag = 0 + + do nsat=1,nsats_oz + init_pass = .true. + if (datestring .eq. '0000000000') then + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_"//trim(adjustl(gesid2))//"."//trim(adjustl(id2)) + else + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_"//trim(adjustl(gesid2))//"."//datestring//'_'//trim(adjustl(id2)) + endif + peloop: do ipe=0,npefiles + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//datestring//'_'//trim(adjustl(id)) + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') then + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//trim(adjustl(id)) + endif + else ! raw, unconcatenated pe* files. + obsfile = trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_oz(nsat))//'_01' + endif + inquire(file=obsfile,exist=fexist) + if (.not. fexist) cycle peloop + open(iunit,form="unformatted",file=obsfile,iostat=ios) + rewind(iunit) + if (init_pass) then + open(iunit2,form="unformatted",file=obsfile2,iostat=ios) + read(iunit,err=20,end=30) isis,dplat,obstype,jiter,nlevsoz,idate,iint,ireal,irdim1,ioff0 + write(iunit2,err=20) isis,dplat,obstype,jiter,nlevsoz,idate,iint,ireal,irdim1,ioff0 + if(allocated(pob))deallocate(pob,grs,err,iouse) + allocate(pob(nlevsoz),grs(nlevsoz),err(nlevsoz),iouse(nlevsoz)) + read(iunit,err=20,end=30) pob,grs,err,iouse + write(iunit2,err=20) pob,grs,err,iouse + init_pass = .false. + endif +10 continue + read(iunit,err=20,end=30) ii + allocate(idiagbuf(iint,ii)) + allocate(diagbuf(ireal,ii)) + allocate(rdiagbuf(irdim1,nlevsoz,ii)) + read(iunit,err=20,end=30) idiagbuf,diagbuf,rdiagbuf + rdiagbuf(2,:,:) = 1.e10 + do k=1,nlevsoz + do n=1,ii + nobdiag = nobdiag + 1 + if (x_used(nobdiag) == 1) then + nob = nob + 1 + rdiagbuf(2,k,n) = x_fit(nob) + rdiagbuf(7,k,n) = x_sprd(nob) + endif + enddo + enddo + write(iunit2) ii + write(iunit2) idiagbuf,diagbuf,rdiagbuf + deallocate(idiagbuf,diagbuf,rdiagbuf) + go to 10 +20 continue + print *,'error reading diag_oz file' +30 continue + close(iunit) + enddo peloop ! ipe + close(iunit2) + enddo ! satellite + + if (nob /= nobs_max) then + print *,'number of obs not what expected in write_ozobs_data',nob,nobs_max + call stop2(93) + end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total diag obs not what expected in write_ozobs_data',nobdiag,nobs_maxdiag + call stop2(93) + end if + + if(allocated(pob))deallocate(pob,grs,err,iouse) + +end subroutine write_ozobs_data_bin + +! writing spread diagnostics to netcdf file +subroutine write_ozobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & + x_fit, x_sprd, x_used, id, gesid) + use netcdf, only: nf90_inq_dimid, nf90_open, nf90_close, NF90_NETCDF4, & + nf90_inquire_dimension, NF90_WRITE, nf90_create, nf90_def_dim + use ncdw_climsg, only: nclayer_check + + use constants, only: r_missing + implicit none + + character*500, intent(in) :: obspath + character*10, intent(in) :: datestring + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + real(r_single), dimension(nobs_max), intent(in) :: x_fit, x_sprd + integer(i_kind), dimension(nobs_maxdiag), intent(in) :: x_used + character(len=8), intent(in) :: id, gesid + + + character*500 obsfile, obsfile2 + character(len=4) pe_name + + integer(i_kind) :: iunit, nobsid + integer(i_kind) :: nob, nobdiag, nobs, ipe, i, nsat + integer(i_kind), dimension(:), allocatable :: enkf_use_flag + real(r_single), dimension(:), allocatable :: enkf_fit, enkf_sprd + logical :: fexist + + nob = 0 + nobdiag = 0 + + do nsat=1,nsats_oz + peloop: do ipe=0,npefiles + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//datestring//'_'//trim(adjustl(id))//'.nc4' + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//datestring//'_'//trim(adjustl(id))//'_spread.nc4' + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') then + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//trim(adjustl(id))//'.nc4' + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_oz(nsat))//"_ges."//trim(adjustl(id))//'_spread.nc4' + endif + else ! raw, unconcatenated pe* files. + obsfile = trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_oz(nsat))//'_01'//'.nc4' + obsfile2 = trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_oz(nsat))//'_01'//'_spread.nc4' + endif + + inquire(file=obsfile,exist=fexist) + if (.not. fexist) cycle peloop + + call nclayer_check(nf90_open(obsfile, NF90_WRITE, iunit)) + call nclayer_check(nf90_inq_dimid(iunit, "nobs", nobsid)) + call nclayer_check(nf90_inquire_dimension(iunit, nobsid, len = nobs)) + call nclayer_check(nf90_close(iunit)) + + if (nobs <= 0) cycle peloop + + allocate(enkf_use_flag(nobs), enkf_fit(nobs), enkf_sprd(nobs)) + enkf_use_flag = -1 + enkf_fit = r_missing + enkf_sprd = r_missing + + do i = 1, nobs + nobdiag = nobdiag + 1 + ! skip if not used in EnKF + if (x_used(nobdiag) == 1) then + ! update if it is used in EnKF + nob = nob + 1 + enkf_use_flag(i) = 1 + enkf_fit(i) = x_fit(nob) + enkf_sprd(i) = x_sprd(nob) + endif + enddo + + inquire(file=obsfile2,exist=fexist) + if (.not. fexist) then + call nclayer_check(nf90_create(trim(obsfile2), NF90_NETCDF4, & + iunit)) + call nclayer_check(nf90_def_dim(iunit, "nobs", nobs, nobsid)) + else + call nclayer_check(nf90_open(obsfile2, NF90_WRITE, iunit)) + call nclayer_check(nf90_inq_dimid(iunit, "nobs", nobsid)) + endif + + call write_ncvar_int(iunit, nobsid, "EnKF_use_flag", enkf_use_flag) + call write_ncvar_single(iunit, nobsid, "EnKF_fit_"//trim(gesid), enkf_fit) + call write_ncvar_single(iunit, nobsid, "EnKF_spread_"//trim(gesid), enkf_sprd) + + call nclayer_check(nf90_close(iunit)) + + deallocate(enkf_use_flag, enkf_fit, enkf_sprd) + + enddo peloop ! ipe loop + enddo + + if (nob .ne. nobs_max) then + print *,'number of obs not what expected in write_ozobs_data',nob,nobs_max + call stop2(94) + end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total obs in diag not what expected in write_ozobs_data',nobdiag, nobs_maxdiag + call stop2(94) + endif + + + contains + subroutine write_ncvar_single(iunit, dimid, varname, field) + use netcdf, only: nf90_def_var, nf90_put_var, nf90_inq_varid, & + nf90_def_var_deflate,NF90_FLOAT, NF90_ENOTVAR + use ncdw_climsg, only: nclayer_check + use ncdw_types, only: NLAYER_COMPRESSION + implicit none + integer(i_kind), intent(in) :: iunit, dimid + character(*), intent(in) :: varname + real(r_single), dimension(:), allocatable :: field + + integer :: ierr, varid + + ierr = nf90_inq_varid(iunit, varname, varid) + if (ierr == NF90_ENOTVAR) then + call nclayer_check(nf90_def_var(iunit, varname, NF90_FLOAT, dimid, varid)) + call nclayer_check(nf90_def_var_deflate(iunit, varid, 1, 1, int(NLAYER_COMPRESSION))) + endif + call nclayer_check(nf90_put_var(iunit, varid, field)) + end subroutine write_ncvar_single + + subroutine write_ncvar_int(iunit, dimid, varname, field) + use netcdf, only: nf90_def_var, nf90_put_var, nf90_inq_varid, & + nf90_def_var_deflate,NF90_INT, NF90_ENOTVAR + use ncdw_climsg, only: nclayer_check + use ncdw_types, only: NLAYER_COMPRESSION + implicit none + integer(i_kind), intent(in) :: iunit, dimid + character(*), intent(in) :: varname + integer(i_kind), dimension(:), allocatable :: field + + integer :: ierr, varid + + ierr = nf90_inq_varid(iunit, varname, varid) + if (ierr == NF90_ENOTVAR) then + call nclayer_check(nf90_def_var(iunit, varname, NF90_INT, dimid, varid)) + call nclayer_check(nf90_def_var_deflate(iunit, varid, 1, 1, int(NLAYER_COMPRESSION))) + endif + call nclayer_check(nf90_put_var(iunit, varid, field)) + end subroutine write_ncvar_int + + +end subroutine write_ozobs_data_nc + end module readozobs diff --git a/src/enkf/readsatobs.f90 b/src/enkf/readsatobs.f90 index 85796a3ab..4f32a8855 100644 --- a/src/enkf/readsatobs.f90 +++ b/src/enkf/readsatobs.f90 @@ -11,7 +11,8 @@ module readsatobs ! ! Public Subroutines: ! get_num_satobs: determine the number of observations to read. -! get_satobs_data: read the data. +! get_satobs_data: read the data and calculate H(x) for ensemble members. +! write_satobs_data: output diag file with spread ! ! Public Variables: ! @@ -20,35 +21,56 @@ module readsatobs ! program history log: ! 2009-02-23 Initial version. ! 2016-06-03 Collard - Added changes to allow for historical naming conventions +! 2016-11-29 shlyaeva - updated read routine to calculate linearized H(x) +! added write_ozvobs_data to output ensemble spread +! 2017-12-13 shlyaeva - added netcdf diag read/write capability ! ! attributes: ! language: f95 ! !$$$ - -use kinds, only: r_kind,i_kind,r_single + +use kinds, only: r_kind,i_kind,r_single,r_double use read_diag, only: diag_data_fix_list,diag_header_fix_list,diag_header_chan_list, & diag_data_chan_list,diag_data_extra_list,read_radiag_data,read_radiag_header, & - diag_data_name_list -use params, only: nsats_rad, nsatmax_rad, dsis, sattypes_rad, npefiles + diag_data_name_list, open_radiag, close_radiag +use params, only: nsats_rad, dsis, sattypes_rad, npefiles, netcdf_diag, lupd_satbiasc implicit none private -public :: get_satobs_data, get_num_satobs +public :: get_satobs_data, get_num_satobs, write_satobs_data contains -subroutine get_num_satobs(obspath,datestring,num_obs_tot,id) - use radinfo, only: iuse_rad,nusis,jpch_rad,nuchan,npred - character (len=500), intent(in) :: obspath +! get number of radiance observations +subroutine get_num_satobs(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + implicit none + character(len=500), intent(in) :: obspath + character(len=10), intent(in) :: id, datestring + integer(i_kind), intent(out) :: num_obs_tot, num_obs_totdiag + + if (netcdf_diag) then + call get_num_satobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + else + call get_num_satobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + endif +end subroutine get_num_satobs + +! get number of radiance observations from binary file +subroutine get_num_satobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + use radinfo, only: iuse_rad,nusis,jpch_rad,npred + implicit none + + character(len=500), intent(in) :: obspath + character(len=10), intent(in) :: id, datestring + integer(i_kind), intent(out) :: num_obs_tot, num_obs_totdiag + character(len=500) obsfile - character(len=10), intent(in) :: id, datestring character(len=20) :: sat_type character(len=4) :: pe_name - integer(i_kind), intent(out) :: num_obs_tot - integer(i_kind) iunit, iflag, nsat, ios,n,nkeep, i, jpchstart,indxsat,ipe - integer(i_kind) npred_radiag + integer(i_kind) iunit, iflag, nsat, n, nkeep, i, jpchstart,indxsat,ipe + integer(i_kind) npred_radiag, istatus logical fexist,lretrieval,lverbose,init_pass real(r_kind) :: errorlimit,errorlimit2 @@ -64,10 +86,13 @@ subroutine get_num_satobs(obspath,datestring,num_obs_tot,id) errorlimit2=1._r_kind/sqrt(1.e-6_r_kind) iunit = 7 lretrieval=.false. + print *,'npred = ',npred npred_radiag=npred lverbose=.false. num_obs_tot = 0 + num_obs_totdiag = 0 + do nsat=1,nsats_rad jpchstart=0 do i=1,jpch_rad @@ -105,20 +130,19 @@ subroutine get_num_satobs(obspath,datestring,num_obs_tot,id) inquire(file=obsfile,exist=fexist) if (.not.fexist) cycle peloop nkeep = 0 + call open_radiag(obsfile,iunit,istatus) - !print *,'obsfile=',trim(obsfile) - - open(iunit,form="unformatted",file=obsfile,iostat=ios) - rewind(iunit) if (init_pass) then call read_radiag_header(iunit,npred_radiag,lretrieval,header_fix0,header_chan0,data_name0,iflag,lverbose) + if (iflag /= 0) exit init_pass = .false. endif do - call read_radiag_data(iunit,header_fix0,lretrieval,data_fix0,data_chan0,data_extra0,iflag ) + call read_radiag_data(iunit,header_fix0,lretrieval,data_fix0,data_chan0,data_extra0,iflag) if( iflag /= 0 )exit chan: do n=1,header_fix0%nchan + num_obs_totdiag = num_obs_totdiag + 1 if(header_chan0(n)%iuse<1) cycle chan indxsat=header_chan0(n)%iochan if(data_chan0(n)%qcmark < 0. .or. data_chan0(n)%errinv < errorlimit & @@ -135,60 +159,253 @@ subroutine get_num_satobs(obspath,datestring,num_obs_tot,id) end do chan enddo num_obs_tot = num_obs_tot + nkeep - close(iunit) + call close_radiag(obsfile,iunit) if (ipe .eq. npefiles) then write(6,100) nsat,trim(sattypes_rad(nsat)),num_obs_tot 100 format(2x,i3,2x,a20,2x,'num_obs_tot= ',i9) endif enddo peloop ! ipe enddo ! satellite -end subroutine get_num_satobs +end subroutine get_num_satobs_bin -subroutine get_satobs_data(obspath, datestring, nobs_max, h_x, h_xnobc, x_obs, x_err, & - x_lon, x_lat, x_press, x_time, x_channum, x_errorig, x_type, x_biaspred, x_indx,id,id2) - use radinfo, only: iuse_rad,nusis,jpch_rad,nuchan,npred,adp_anglebc,emiss_bc - character*500, intent(in) :: obspath - character*500 obsfile,obsfile2 - character(len=10), intent(in) :: id,id2 +! get number of radiance observations from netcdf file +subroutine get_num_satobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) + use radinfo, only: iuse_rad,nusis,jpch_rad + use nc_diag_read_mod, only: nc_diag_read_get_var + use nc_diag_read_mod, only: nc_diag_read_get_dim + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + implicit none + + character(len=500), intent(in) :: obspath + character(len=10), intent(in) :: id, datestring + integer(i_kind), intent(out) :: num_obs_tot, num_obs_totdiag + + character(len=500) obsfile + character(len=20) :: sat_type + character(len=4) :: pe_name + integer(i_kind) iunit, nsat, nobs, nchans, ipe, nkeep, i, jpchstart + logical fexist + real(r_kind) :: errorlimit,errorlimit2 + + integer(i_kind), dimension(:), allocatable :: Satinfo_Chan, Use_Flag, chind + real(r_single), dimension(:), allocatable :: Pressure, QC_Flag, Inv_Error, Observation + + +! make consistent with screenobs + errorlimit=1._r_kind/sqrt(1.e9_r_kind) + errorlimit2=1._r_kind/sqrt(1.e-6_r_kind) + iunit = 7 + + num_obs_tot = 0 + num_obs_totdiag = 0 + + do nsat=1,nsats_rad + jpchstart=0 + do i=1,jpch_rad + write(sat_type,'(a20)') adjustl(dsis(nsat)) + ! The following is to sort out some historical naming conventions + select case (sat_type(1:4)) + case ('airs') + sat_type='airs_aqua' + case ('iasi') + if (index(sat_type,'metop-a') /= 0) sat_type='iasi_metop-a' + if (index(sat_type,'metop-b') /= 0) sat_type='iasi_metop-b' + if (index(sat_type,'metop-c') /= 0) sat_type='iasi_metop-c' + end select + + if(sat_type == trim(nusis(i)) .and. iuse_rad(i) > 0) then + jpchstart=i + exit + end if + end do + if(jpchstart == 0) cycle + peloop: do ipe=0,npefiles + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//datestring//'_'//trim(adjustl(id))//".nc4" + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') & + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//trim(adjustl(id))//".nc4" + else ! read raw, unconcatenated pe* files. + obsfile =& + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_rad(nsat))//'_01'//".nc4" + endif + + + inquire(file=obsfile,exist=fexist) + if (.not.fexist) cycle peloop + + nkeep = 0 + + call nc_diag_read_init(obsfile, iunit) + + nobs = nc_diag_read_get_dim(iunit,'nobs') + + if (nobs <= 0) then + call nc_diag_read_close(obsfile) + cycle peloop + endif + + nchans = nc_diag_read_get_dim(iunit,'nchans') + allocate(Satinfo_Chan(nchans), Use_Flag(nchans), Pressure(nobs), QC_Flag(nobs), & + Inv_Error(nobs), Observation(nobs), chind(nobs)) + + call nc_diag_read_get_var(iunit, 'satinfo_chan', Satinfo_Chan) + call nc_diag_read_get_var(iunit, 'use_flag', Use_Flag) + call nc_diag_read_get_var(iunit, 'Channel_Index', chind) + call nc_diag_read_get_var(iunit, 'Press_Max_Weight_Function', Pressure) + call nc_diag_read_get_var(iunit, 'QC_Flag', QC_Flag) + call nc_diag_read_get_var(iunit, 'Inverse_Observation_Error', Inv_Error) + call nc_diag_read_get_var(iunit, 'Observation', Observation) + + call nc_diag_read_close(obsfile) + + + do i = 1, nobs + num_obs_totdiag = num_obs_totdiag + 1 + if(Use_Flag(chind(i)) < 1 ) cycle + if(QC_Flag(i) < 0. .or. Inv_Error(i) < errorlimit & + .or. Inv_Error(i) > errorlimit2 & + .or. Satinfo_Chan(chind(i)) == 0) cycle + if(Pressure(i) <= 0.001_r_kind .or. & + Pressure(i) > 1200._r_kind .or. & + abs(Observation(i)) > 1.e9_r_kind) cycle + nkeep = nkeep + 1 + enddo + num_obs_tot = num_obs_tot + nkeep + + if (ipe .eq. npefiles) then + write(6,100) nsat,trim(sattypes_rad(nsat)),num_obs_tot +100 format(2x,i3,2x,a20,2x,'num_obs_tot= ',i9) + endif + + deallocate(Satinfo_Chan, Use_Flag, Pressure, QC_Flag, Inv_Error, Observation, chind) + enddo peloop ! ipe + enddo ! satellite + +end subroutine get_num_satobs_nc + +! read radiance data +subroutine get_satobs_data(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_channum, x_errorig, x_type, x_biaspred, x_indx, x_used, id, nanal, nmem) + use radinfo, only: npred + use params, only: neigv + implicit none + + character*500, intent(in) :: obspath + character(len=10), intent(in) :: datestring + + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + + real(r_single), dimension(nobs_max), intent(out) :: hx_mean,hx_mean_nobc, hx + ! hx_modens holds modulated ensemble in ob space (zero size and not referenced if neigv=0) + real(r_single), dimension(neigv, nobs_max), intent(out) :: hx_modens + real(r_single), dimension(nobs_max), intent(out) :: x_obs + real(r_single), dimension(nobs_max), intent(out) :: x_err, x_errorig + real(r_single), dimension(nobs_max), intent(out) :: x_lon, x_lat + real(r_single), dimension(nobs_max), intent(out) :: x_press, x_time + integer(i_kind), dimension(nobs_max), intent(out) :: x_channum, x_indx + character(len=20), dimension(nobs_max), intent(out) :: x_type + real(r_single), dimension(npred+1,nobs_max), intent(out) :: x_biaspred + integer(i_kind), dimension(nobs_maxdiag), intent(out) :: x_used + + character(len=10), intent(in) :: id + integer(i_kind), intent(in) :: nanal,nmem + + if (netcdf_diag) then + call get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_channum, x_errorig, x_type, x_biaspred, x_indx, x_used, id, nanal, nmem) + else + call get_satobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_channum, x_errorig, x_type, x_biaspred, x_indx, x_used, id, nanal, nmem) + endif + +end subroutine get_satobs_data + +! read radiance data from binary file +subroutine get_satobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_channum, x_errorig, x_type, x_biaspred, x_indx, x_used, id, nanal, nmem) + use radinfo, only: iuse_rad,nusis,jpch_rad,npred,adp_anglebc,emiss_bc + use params, only: nanals, lobsdiag_forenkf, neigv, vlocal_evecs + use statevec, only: state_d + use constants, only: deg2rad, zero + use mpisetup, only: nproc, mpi_wtime + use observer_enkf, only: calc_linhx, calc_linhx_modens, setup_linhx + implicit none + + character*500, intent(in) :: obspath + character(len=10), intent(in) :: datestring + + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + + real(r_single), dimension(nobs_max), intent(out) :: hx_mean,hx_mean_nobc, hx + ! hx_modens holds modulated ensemble in ob space (zero size and not referenced if neigv=0) + real(r_single), dimension(neigv, nobs_max), intent(out) :: hx_modens + real(r_single), dimension(nobs_max), intent(out) :: x_obs + real(r_single), dimension(nobs_max), intent(out) :: x_err, x_errorig + real(r_single), dimension(nobs_max), intent(out) :: x_lon, x_lat + real(r_single), dimension(nobs_max), intent(out) :: x_press, x_time + integer(i_kind), dimension(nobs_max), intent(out) :: x_channum, x_indx + character(len=20), dimension(nobs_max), intent(out) :: x_type + real(r_single), dimension(npred+1,nobs_max), intent(out) :: x_biaspred + integer(i_kind), dimension(nobs_maxdiag), intent(out) :: x_used + + + character(len=10), intent(in) :: id + integer(i_kind), intent(in) :: nanal, nmem + + character*500 obsfile, obsfile2 + character(len=10) :: id2 character(len=4) pe_name - real(r_single), dimension(nobs_max) :: h_x,h_xnobc,x_obs,x_err,x_lon,& - x_lat,x_press,x_time,x_errorig - real(r_single), dimension(npred+1,nobs_max) :: x_biaspred - integer(i_kind), dimension(nobs_max) :: x_channum,x_indx - character(len=20), dimension(nobs_max) :: x_type character(len=20) :: sat_type - character(len=10), intent(in) :: datestring - integer(i_kind) nobs_max, iunit, iunit2,iflag,nobs,n,nsat,ipe,i,jpchstart,indxsat - integer(i_kind) npred_radiag,iflag2 - logical twofiles,fexist1,fexist2,lretrieval,lverbose,init_pass,init_pass2 + integer(i_kind) iunit, iflag,nob,nobdiag, n,nsat,ipe,i,jpchstart,indxsat,nn + integer(i_kind) iunit2, iflag2, istatus + integer(i_kind) npred_radiag + logical fexist,lretrieval,lverbose,init_pass + logical twofiles,fexist2,init_pass2 real(r_kind) :: errorlimit,errorlimit2 + real(r_double) t1,t2,tsum,tsum2 + integer(i_kind) :: ix, iy, it, ixp, iyp, itp + real(r_kind) :: delx, dely, delxp, delyp, delt, deltp + real(r_single) :: rlat,rlon,rtim,rlat_prev,rlon_prev,rtim_prev,eps - type(diag_header_fix_list ) :: header_fix1,header_fix2 - type(diag_header_chan_list),allocatable :: header_chan1(:),header_chan2(:) - type(diag_data_fix_list ) :: data_fix1,data_fix2 - type(diag_data_chan_list ),allocatable :: data_chan1(:),data_chan2(:) - type(diag_data_extra_list) ,allocatable :: data_extra1(:,:),data_extra2(:,:) - type(diag_data_name_list) :: data_name1,data_name2 + type(diag_header_fix_list ) :: header_fix, header_fix2 + type(diag_header_chan_list),allocatable :: header_chan(:), header_chan2(:) + type(diag_data_fix_list ) :: data_fix, data_fix2 + type(diag_data_chan_list ),allocatable :: data_chan(:), data_chan2(:) + type(diag_data_extra_list) ,allocatable :: data_extra(:,:), data_extra2(:,:) + type(diag_data_name_list) :: data_name, data_name2 ! make consistent with screenobs errorlimit=1._r_kind/sqrt(1.e9_r_kind) errorlimit2=1._r_kind/sqrt(1.e-6_r_kind) + eps = 1.e-3 + tsum = 0; tsum2 = 0 iunit = 7 iunit2 = 17 lretrieval=.false. npred_radiag=npred lverbose=.false. - nobs = 0 - twofiles = id /= id2 + twofiles = (.not. lobsdiag_forenkf) .and. (nanal <= nanals) + id2 = 'ensmean' + if (nanal <= nanals) then + write(id2,'(a3,(i3.3))') 'mem',nanal + endif + + hx = zero + nob = 0 + rlat_prev = -1.e30; rlon_prev=-1.e30; rtim_prev = -1.e30 + nobdiag = 0 + x_used = 0 do nsat=1,nsats_rad jpchstart=0 do i=1,jpch_rad - write(sat_type,'(a20)') adjustl(dsis(nsat)) ! The following is to sort out some historical naming conventions select case (sat_type(1:4)) @@ -212,20 +429,21 @@ subroutine get_satobs_data(obspath, datestring, nobs_max, h_x, h_xnobc, x_obs, x if (npefiles .eq. 0) then ! read diag file (concatenated pe* files) obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//datestring//'_'//trim(adjustl(id)) - inquire(file=obsfile,exist=fexist1) - if (.not. fexist1 .or. datestring .eq. '0000000000') & + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') & obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//trim(adjustl(id)) else ! read raw, unconcatenated pe* files. obsfile =& trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_rad(nsat))//'_01' endif - inquire(file=obsfile,exist=fexist1) - if(.not.fexist1) cycle peloop - open(iunit,form="unformatted",file=obsfile) - rewind(iunit) + inquire(file=obsfile,exist=fexist) + if(.not.fexist) cycle peloop + call open_radiag(obsfile,iunit,istatus) + if (init_pass) then - call read_radiag_header(iunit,npred_radiag,lretrieval,header_fix1,header_chan1,data_name1,iflag,lverbose) + call read_radiag_header(iunit,npred_radiag,lretrieval,header_fix,header_chan,data_name,iflag,lverbose) + if( iflag /= 0 ) exit init_pass = .false. endif @@ -241,109 +459,935 @@ subroutine get_satobs_data(obspath, datestring, nobs_max, h_x, h_xnobc, x_obs, x trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id2))//'/pe'//pe_name//'.'//trim(sattypes_rad(nsat))//'_01' endif - open(iunit2,form="unformatted",file=obsfile2) - rewind(iunit2) + call open_radiag(obsfile2, iunit2,istatus) + if (init_pass2) then call read_radiag_header(iunit2,npred_radiag,lretrieval,header_fix2,header_chan2,data_name2,iflag2,lverbose) init_pass2 = .false. endif end if - do - call read_radiag_data(iunit,header_fix1,lretrieval,data_fix1,data_chan1,data_extra1,iflag ) + t1 = mpi_wtime() + call read_radiag_data(iunit,header_fix,lretrieval,data_fix,data_chan,data_extra,iflag ) + t2 = mpi_wtime() + tsum2 = tsum2 + t2-t1 if( iflag /= 0 ) then exit end if if(twofiles)then call read_radiag_data(iunit2,header_fix2,lretrieval,data_fix2,data_chan2,data_extra2,iflag2 ) - if( header_fix1%nchan /= header_fix2%nchan .or. abs(data_fix1%lat-data_fix2%lat) .gt. 1.e-5 .or. & - abs(data_fix1%lon-data_fix2%lon) .gt. 1.e-5 .or. abs(data_fix1%obstime-data_fix2%obstime) .gt. 1.e-5) then + if( header_fix%nchan /= header_fix2%nchan .or. abs(data_fix%lat-data_fix2%lat) .gt. 1.e-5 .or. & + abs(data_fix%lon-data_fix2%lon) .gt. 1.e-5 .or. abs(data_fix%obstime-data_fix2%obstime) .gt. 1.e-5) then write(6,*) 'inconsistent files',trim(obsfile2) - write(6,*) 'nchan',header_fix1%nchan,header_fix2%nchan - write(6,*) 'lat',data_fix1%lat,data_fix2%lat - write(6,*) 'lon',data_fix1%lon,data_fix2%lon - write(6,*) 'obstim',data_fix1%obstime,data_fix2%obstime + write(6,*) 'nchan',header_fix%nchan,header_fix2%nchan + write(6,*) 'lat',data_fix%lat,data_fix2%lat + write(6,*) 'lon',data_fix%lon,data_fix2%lon + write(6,*) 'obstim',data_fix%obstime,data_fix2%obstime call stop2(-99) end if end if - chan:do n=1,header_fix1%nchan - if(header_chan1(n)%iuse<1) cycle chan - indxsat=header_chan1(n)%iochan - if(data_chan1(n)%qcmark < 0. .or. data_chan1(n)%errinv < errorlimit & - .or. data_chan1(n)%errinv > errorlimit2 & + chan:do n=1,header_fix%nchan + + nobdiag = nobdiag + 1 + if(header_chan(n)%iuse<1) cycle chan + indxsat=header_chan(n)%iochan + if(data_chan(n)%qcmark < 0. .or. data_chan(n)%errinv < errorlimit & + .or. data_chan(n)%errinv > errorlimit2 & .or. indxsat == 0) cycle chan - if (header_fix1%iextra > 0) then - if(data_extra1(1,n)%extra <= 0.001_r_kind .or. & - data_extra1(1,n)%extra > 1200._r_kind .or. & - abs(data_chan1(n)%tbobs) > 1.e9_r_kind) cycle chan + if (header_fix%iextra > 0) then + if(data_extra(1,n)%extra <= 0.001_r_kind .or. & + data_extra(1,n)%extra > 1200._r_kind .or. & + abs(data_chan(n)%tbobs) > 1.e9_r_kind) cycle chan else - if(abs(data_chan1(n)%tbobs) > 1.e9_r_kind) cycle chan + if(abs(data_chan(n)%tbobs) > 1.e9_r_kind) cycle chan endif - nobs = nobs + 1 - if (nobs > nobs_max) then + nob = nob + 1 + + x_used(nobdiag) = 1 + if (nob > nobs_max) then print *,'warning: exceeding array bounds in readinfo_from_file',& - nobs,nobs_max + nob,nobs_max end if - x_type(nobs)= sat_type - x_channum(nobs) = n - x_indx(nobs) = indxsat - x_lon(nobs) = data_fix1%lon - x_lat(nobs) = data_fix1%lat - x_time(nobs) = data_fix1%obstime - x_obs(nobs) = data_chan1(n)%tbobs + x_type(nob)= sat_type + x_channum(nob) = n + x_indx(nob) = indxsat + x_lon(nob) = data_fix%lon + x_lat(nob) = data_fix%lat + x_time(nob) = data_fix%obstime + x_obs(nob) = data_chan(n)%tbobs ! bias corrected Hx - h_x(nobs) = x_obs(nobs) - data_chan1(n)%omgbc + hx_mean(nob) = x_obs(nob) - data_chan(n)%omgbc ! un-bias corrected Hx - if(twofiles)then - h_xnobc(nobs) = x_obs(nobs) - data_chan2(n)%omgnbc - else - h_xnobc(nobs) = x_obs(nobs) - data_chan1(n)%omgnbc - end if + hx_mean_nobc(nob) = x_obs(nob) - data_chan(n)%omgnbc + + if (nanal <= nanals) then + ! read full Hx + if (.not. lobsdiag_forenkf) then + hx(nob) = x_obs(nob) - data_chan2(n)%omgnbc + ! run linearized Hx + else + rlat = x_lat(nob)*deg2rad + rlon = x_lon(nob)*deg2rad + rtim = x_time(nob) + if (nob > 1) then + rlat_prev = x_lat(nob-1)*deg2rad + rlon_prev = x_lon(nob-1)*deg2rad + rtim_prev = x_time(nob-1) + endif + if (abs(rlat-rlat_prev) > eps .or. & + abs(rlon-rlon_prev) > eps .or. & + abs(rtim-rtim_prev) > eps) then + call setup_linhx(rlat,rlon,rtim, & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + endif + call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + data_chan(n)%dhx_dx, hx(nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + ! compute modulated ensemble in obs space + if (neigv > 0) then + call calc_linhx_modens(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + data_chan(n)%dhx_dx, hx_modens(:,nob), & + ix, delx, ixp, delxp, iy, dely, iyp, delyp, & + it, delt, itp, deltp, vlocal_evecs) + endif + t2 = mpi_wtime() + tsum = tsum + t2-t1 + endif + endif + ! data_chan%errinv is inverse error variance. - x_errorig(nobs) = header_chan1(n)%varch**2 - x_err(nobs) = (1._r_kind/data_chan1(n)%errinv)**2 - if (header_fix1%iextra > 0) then - x_press(nobs) = data_extra1(1,n)%extra + x_errorig(nob) = header_chan(n)%varch**2 + x_err(nob) = (1._r_kind/data_chan(n)%errinv)**2 + if (header_fix%iextra > 0) then + x_press(nob) = data_extra(1,n)%extra else - x_press(nobs) = 99999 + x_press(nob) = 99999 endif !! DTK: **NOTE** !! The bifix term will need to be expanded if/when the GSI/GDAS goes to using !! a higher polynomial version of the angle dependent bias correction (if !! and when it is moved into part of the varbc) -!! x_biaspred(1,nobs) = data_chan1(n)%bifix! fixed angle dependent bias - x_biaspred(1,nobs) = data_chan1(n)%bifix(1) ! fixed angle dependent bias - x_biaspred(2,nobs) = data_chan1(n)%bicons ! constant bias correction - x_biaspred(3,nobs) = data_chan1(n)%biang ! scan angle bias correction - x_biaspred(4,nobs) = data_chan1(n)%biclw ! CLW bias correction - x_biaspred(5,nobs) = data_chan1(n)%bilap2 ! square lapse rate bias corr - x_biaspred(6,nobs) = data_chan1(n)%bilap ! lapse rate bias correction - if (npred == 7) then - x_biaspred(7,nobs) = data_chan1(n)%bicos ! node*cos(lat) bias correction for SSMIS - x_biaspred(8,nobs) = data_chan1(n)%bisin ! sin(lat) bias correction for SSMIS - endif - if (emiss_bc) x_biaspred(9,nobs) = data_chan1(n)%biemis - - if (adp_anglebc) then - x_biaspred( 1,nobs) = data_chan1(n)%bifix(5) ! fixed angle dependent bias correction - x_biaspred(npred-2,nobs) = data_chan1(n)%bifix(1) ! 4th order scan angle (predictor) - x_biaspred(npred-1,nobs) = data_chan1(n)%bifix(2) ! 3rd order scan angle (predictor) - x_biaspred(npred,nobs) = data_chan1(n)%bifix(3) ! 2nd order scan angle (predictor) - x_biaspred(npred+1,nobs) = data_chan1(n)%bifix(4) ! 1st order scan angle (predictor) +! from radinfo: radiance bias correction terms are as follows: +! pred(1,:) = global offset +! pred(2,:) = zenith angle predictor, is not used and set to zero now +! pred(3,:) = cloud liquid water predictor for clear-sky microwave radiance assimilation +! pred(4,:) = square of temperature laps rate predictor +! pred(5,:) = temperature laps rate predictor +! pred(6,:) = cosinusoidal predictor for SSMI/S ascending/descending bias +! pred(7,:) = sinusoidal predictor for SSMI/S +! pred(8,:) = emissivity sensitivity predictor for land/sea differences +! pred(9,:) = fourth order polynomial of angle bias correction +! pred(10,:) = third order polynomial of angle bias correction +! pred(11,:) = second order polynomial of angle bias correction +! pred(12,:) = first order polynomial of angle bias correction + if (lupd_satbiasc) then ! bias predictors only used if lupd_satbiasc=T + x_biaspred(1,nob) = data_chan(n)%bicons ! constant bias correction + x_biaspred(2,nob) = data_chan(n)%biang ! scan angle bias correction + x_biaspred(3,nob) = data_chan(n)%biclw ! CLW bias correction + x_biaspred(4,nob) = data_chan(n)%bilap2 ! square lapse rate bias corr + x_biaspred(5,nob) = data_chan(n)%bilap ! lapse rate bias correction + x_biaspred(6,nob) = data_chan(n)%bicos ! node*cos(lat) bias correction for SSMIS + x_biaspred(7,nob) = data_chan(n)%bisin ! sin(lat) bias correction for SSMIS + if (emiss_bc) then + x_biaspred(8,nob) = data_chan(n)%biemis + nn = 9 + else + nn = 8 + endif + + if (adp_anglebc) then + x_biaspred(nn ,nob) = data_chan(n)%bifix(1) ! 4th order scan angle (predictor) + x_biaspred(nn+1,nob) = data_chan(n)%bifix(2) ! 3rd order scan angle (predictor) + x_biaspred(nn+2,nob) = data_chan(n)%bifix(3) ! 2nd order scan angle (predictor) + x_biaspred(nn+3,nob) = data_chan(n)%bifix(4) ! 1st order scan angle (predictor) + endif + x_biaspred(npred+1,nob) = data_chan(n)%bifix(1) ! fixed angle dependent bias + else + x_biaspred(:,nob) =zero ! lupd_satbiasc=F, don't need bias predictors endif enddo chan enddo - cycle + call close_radiag(obsfile,iunit) + + if (twofiles) call close_radiag(obsfile2,iunit2) + enddo peloop ! ipe + enddo ! satellite + if (nanal == nanals .and. lobsdiag_forenkf) print *,'time in calc_linhx for sat obs on proc',nproc,' = ',tsum + if (nanal == nanals) print *,'time in read_raddiag_data for sat obs on proc',nproc,' = ',tsum2 + + if (nob /= nobs_max) then + print *,'number of obs not what expected in get_satobs_data',nob,nobs_max + call stop2(92) + end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total diag obs not what expected in get_satobs_data',nobdiag,nobs_maxdiag + call stop2(92) + end if + + end subroutine get_satobs_data_bin + +! read radiance data from netcdf file +subroutine get_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, hx_mean, hx_mean_nobc, hx, hx_modens, x_obs, x_err, & + x_lon, x_lat, x_press, x_time, x_channum, x_errorig, x_type, x_biaspred, x_indx, x_used, id, nanal, nmem) + use nc_diag_read_mod, only: nc_diag_read_get_var + use nc_diag_read_mod, only: nc_diag_read_get_dim, nc_diag_read_get_global_attr + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + + use radinfo, only: iuse_rad,nusis,jpch_rad,npred,adp_anglebc,emiss_bc + use params, only: nanals, lobsdiag_forenkf, neigv, vlocal_evecs + use statevec, only: state_d + use constants, only: deg2rad, zero + use mpisetup, only: nproc, mpi_wtime + use observer_enkf, only: calc_linhx, calc_linhx_modens, setup_linhx + use sparsearr, only: sparr, assignment(=), delete, sparr2, new + + implicit none + + character*500, intent(in) :: obspath + character(len=10), intent(in) :: datestring + + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + + real(r_single), dimension(nobs_max), intent(out) :: hx_mean,hx_mean_nobc, hx + ! hx_modens holds modulated ensemble in ob space (zero size and not referenced if neigv=0) + real(r_single), dimension(neigv,nobs_max), intent(out) :: hx_modens + real(r_single), dimension(nobs_max), intent(out) :: x_obs + real(r_single), dimension(nobs_max), intent(out) :: x_err, x_errorig + real(r_single), dimension(nobs_max), intent(out) :: x_lon, x_lat + real(r_single), dimension(nobs_max), intent(out) :: x_press, x_time + integer(i_kind), dimension(nobs_max), intent(out) :: x_channum, x_indx + character(len=20), dimension(nobs_max), intent(out) :: x_type + real(r_single), dimension(npred+1,nobs_max), intent(out) :: x_biaspred + integer(i_kind), dimension(nobs_maxdiag), intent(out) :: x_used + + + character(len=10), intent(in) :: id + integer(i_kind), intent(in) :: nanal, nmem + + character*500 obsfile, obsfile2 + character(len=10) :: id2 + character(len=4) pe_name + + character(len=20) :: sat_type + + integer(i_kind) iunit, nobs, nobdiag, i, nsat, ipe, jpchstart, nchans + integer(i_kind) iunit2, nob, nobs2, nnz, nind, nn + integer(i_kind) npred_radiag, angord + logical fexist + logical twofiles,fexist2 + real(r_kind) :: errorlimit,errorlimit2 + real(r_double) t1,t2,tsum,tsum2 + real(r_single) :: rlat,rlon,rtim,rlat_prev,rlon_prev,rtim_prev,eps + + type(sparr2) :: dhx_dx_read + type(sparr) :: dhx_dx + + integer(i_kind), dimension(:), allocatable :: Satinfo_Chan, Use_Flag, chind, chaninfoidx + real(r_kind), dimension(:), allocatable :: error_variance + real(r_single), dimension(:), allocatable :: Pressure, QC_Flag, Inv_Error, Observation + real(r_single), dimension(:), allocatable :: Latitude, Longitude, Time + real(r_single), dimension(:), allocatable :: Obs_Minus_Forecast_adjusted + real(r_single), dimension(:), allocatable :: Obs_Minus_Forecast_unadjusted, Obs_Minus_Forecast_unadjusted2 + integer(i_kind), allocatable, dimension (:,:) :: Observation_Operator_Jacobian_stind + integer(i_kind), allocatable, dimension (:,:) :: Observation_Operator_Jacobian_endind + real(r_single), allocatable, dimension (:,:) :: Observation_Operator_Jacobian_val + real(r_single), dimension(:), allocatable :: BC_Fixed_Scan_Position, BCPred_Constant, BCPred_Scan_Angle + real(r_single), dimension(:), allocatable :: BCPred_Cloud_Liquid_Water, BCPred_Lapse_Rate_Squared, BCPred_Lapse_Rate + real(r_single), dimension(:), allocatable :: BCPred_Cosine_Latitude_times_Node, BCPred_Sine_Latitude + real(r_single), dimension(:), allocatable :: BCPred_Emissivity + real(r_single), allocatable, dimension (:,:) :: BCPred_angord + integer(i_kind) :: ix, iy, it, ixp, iyp, itp + real(r_kind) :: delx, dely, delxp, delyp, delt, deltp + +! make consistent with screenobs + errorlimit=1._r_kind/sqrt(1.e9_r_kind) + errorlimit2=1._r_kind/sqrt(1.e-6_r_kind) + eps = 1.e-3 + + tsum = 0; tsum2 = 0 + npred_radiag=npred + + twofiles = (.not. lobsdiag_forenkf) .and. (nanal <= nanals) + id2 = 'ensmean' + if (nanal <= nanals) then + write(id2,'(a3,(i3.3))') 'mem',nanal + endif + + hx = zero + nob = 0 + rlat_prev = huge(rlat); rlon_prev=huge(rlon); rtim_prev = huge(rtim) + nobdiag = 0 + x_used = 0 + + do nsat=1,nsats_rad + jpchstart=0 + do i=1,jpch_rad + write(sat_type,'(a20)') adjustl(dsis(nsat)) + ! The following is to sort out some historical naming conventions + select case (sat_type(1:4)) + case ('airs') + sat_type='airs_aqua' + case ('iasi') + if (index(sat_type,'metop-a') /= 0) sat_type='iasi_metop-a' + if (index(sat_type,'metop-b') /= 0) sat_type='iasi_metop-b' + if (index(sat_type,'metop-c') /= 0) sat_type='iasi_metop-c' + end select + + if(sat_type == trim(nusis(i)) .and. iuse_rad(i) > 0) then + jpchstart = i + exit + end if + end do + if(jpchstart == 0) cycle + + peloop: do ipe=0,npefiles + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//datestring//'_'//trim(adjustl(id))//".nc4" + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') & + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//trim(adjustl(id))//".nc4" + else ! read raw, unconcatenated pe* files. + obsfile =& + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_rad(nsat))//'_01.nc4' + endif + + inquire(file=obsfile,exist=fexist) + if(.not.fexist) cycle peloop + + t1 = mpi_wtime() + call nc_diag_read_init(obsfile, iunit) + + nobs = nc_diag_read_get_dim(iunit,'nobs') + + if (nobs <= 0) then + call nc_diag_read_close(obsfile) + cycle peloop + endif + + nchans = nc_diag_read_get_dim(iunit,'nchans') + allocate(Satinfo_Chan(nchans), Use_Flag(nchans), error_variance(nchans)) + allocate(Pressure(nobs), QC_Flag(nobs), Inv_Error(nobs), Latitude(nobs), & + Longitude(nobs), Time(nobs), Observation(nobs), chind(nobs), & + Obs_Minus_Forecast_unadjusted(nobs), Obs_Minus_Forecast_adjusted(nobs)) + call nc_diag_read_get_var(iunit, 'satinfo_chan', Satinfo_Chan) + call nc_diag_read_get_var(iunit, 'use_flag', Use_Flag) + call nc_diag_read_get_var(iunit, 'error_variance', error_variance) + call nc_diag_read_get_var(iunit, 'chaninfoidx', chaninfoidx) + + call nc_diag_read_get_var(iunit, 'Channel_Index', chind) + call nc_diag_read_get_var(iunit, 'Press_Max_Weight_Function', Pressure) + call nc_diag_read_get_var(iunit, 'QC_Flag', QC_Flag) + call nc_diag_read_get_var(iunit, 'Inverse_Observation_Error', Inv_Error) + call nc_diag_read_get_var(iunit, 'Latitude', Latitude) + call nc_diag_read_get_var(iunit, 'Longitude', Longitude) + call nc_diag_read_get_var(iunit, 'Obs_Time', Time) + call nc_diag_read_get_var(iunit, 'Observation', Observation) + call nc_diag_read_get_var(iunit, 'Obs_Minus_Forecast_unadjusted', Obs_Minus_Forecast_unadjusted) + call nc_diag_read_get_var(iunit, 'Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted) + + if (lupd_satbiasc) then ! bias predictors only needed if lupd_satbiasc=T + allocate(BC_Fixed_Scan_Position(nobs), BCPred_Constant(nobs), BCPred_Scan_Angle(nobs), & + BCPred_Cloud_Liquid_Water(nobs), BCPred_Lapse_Rate_Squared(nobs), & + BCPred_Lapse_Rate(nobs)) + call nc_diag_read_get_var(iunit, 'BC_Fixed_Scan_Position', BC_Fixed_Scan_Position) + call nc_diag_read_get_var(iunit, 'BCPred_Constant', BCPred_Constant) + call nc_diag_read_get_var(iunit, 'BCPred_Scan_Angle', BCPred_Scan_Angle) + call nc_diag_read_get_var(iunit, 'BCPred_Cloud_Liquid_Water', BCPred_Cloud_Liquid_Water) + call nc_diag_read_get_var(iunit, 'BCPred_Lapse_Rate_Squared', BCPred_Lapse_Rate_Squared) + call nc_diag_read_get_var(iunit, 'BCPred_Lapse_Rate', BCPred_Lapse_Rate) + + allocate(BCPred_Cosine_Latitude_times_Node(nobs), BCPred_Sine_Latitude(nobs)) + call nc_diag_read_get_var(iunit, 'BCPred_Cosine_Latitude_times_Node', BCPred_Cosine_Latitude_times_Node) + call nc_diag_read_get_var(iunit, 'BCPred_Sine_Latitude', BCPred_Sine_Latitude) + + if (emiss_bc) then + allocate(BCPred_Emissivity(nobs)) + call nc_diag_read_get_var(iunit, 'BCPred_Emissivity', BCPred_Emissivity) + endif + + if (adp_anglebc) then + call nc_diag_read_get_global_attr(iunit, "angord", angord) + allocate(BCPred_angord(angord, nobs)) + call nc_diag_read_get_var(iunit, 'BCPred_angord', BCPred_angord) + endif + endif ! lupd_satbiasc=T, read bias predictors + + if (lobsdiag_forenkf) then + call nc_diag_read_get_global_attr(iunit, "jac_nnz", nnz) + call nc_diag_read_get_global_attr(iunit, "jac_nind", nind) + allocate(Observation_Operator_Jacobian_stind(nind, nobs)) + allocate(Observation_Operator_Jacobian_endind(nind, nobs)) + allocate(Observation_Operator_Jacobian_val(nnz, nobs)) + call nc_diag_read_get_var(iunit, 'Observation_Operator_Jacobian_stind', Observation_Operator_Jacobian_stind) + call nc_diag_read_get_var(iunit, 'Observation_Operator_Jacobian_endind', Observation_Operator_Jacobian_endind) + call nc_diag_read_get_var(iunit, 'Observation_Operator_Jacobian_val', Observation_Operator_Jacobian_val) + endif + + call nc_diag_read_close(obsfile) + + t2 = mpi_wtime() + tsum2 = tsum2 + t2-t1 + + + if(twofiles)then + if (npefiles .eq. 0) then + ! read diag file (concatenated pe* files) + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//datestring//'_'//trim(adjustl(id2))//".nc4" + inquire(file=obsfile2,exist=fexist2) + if (.not. fexist2 .or. datestring .eq. '0000000000') & + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//trim(adjustl(id2))//".nc4" + else ! read raw, unconcatenated pe* files. + obsfile2 =& + trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id2))//'/pe'//pe_name//'.'//trim(sattypes_rad(nsat))//'_01'//".nc4" + endif + + call nc_diag_read_init(obsfile2, iunit2) + + nobs2 = nc_diag_read_get_dim(iunit2,'nobs') + + if (nobs2 /= nobs) print *, nanal, trim(obsfile), nobs, nobs2 + + allocate(Obs_Minus_Forecast_unadjusted2(nobs)) + call nc_diag_read_get_var(iunit2, 'Obs_Minus_Forecast_unadjusted', Obs_Minus_Forecast_unadjusted2) + + call nc_diag_read_close(obsfile2) + + end if + + do i = 1, nobs + nobdiag = nobdiag + 1 + if (Use_Flag(chind(i)) < 1) cycle + if (QC_Flag(i) < 0. .or. Inv_Error(i) < errorlimit & + .or. Inv_Error(i) > errorlimit2 & + .or. Satinfo_Chan(chind(i)) == 0) cycle + if (Pressure(i) <= 0.001_r_kind .or. & + Pressure(i) > 1200._r_kind .or. & + abs(Observation(i)) > 1.e9_r_kind) cycle + + nob = nob + 1 + + x_used(nobdiag) = 1 + x_type(nob)= sat_type + + x_channum(nob) = chaninfoidx(chind(i)) + x_indx(nob) = Satinfo_Chan(chind(i)) + + x_lon(nob) = Longitude(i) + x_lat(nob) = Latitude(i) + x_time(nob) = Time(i) + x_obs(nob) = Observation(i) + ! bias corrected Hx + hx_mean(nob) = x_obs(nob) - Obs_Minus_Forecast_adjusted(i) + ! un-bias corrected Hx + hx_mean_nobc(nob) = x_obs(nob) - Obs_Minus_Forecast_unadjusted(i) + + if (nanal <= nanals) then + ! read full Hx + if (.not. lobsdiag_forenkf) then + hx(nob) = x_obs(nob) - Obs_Minus_Forecast_unadjusted2(i) + ! run linearized Hx + else + call new(dhx_dx_read, nnz, nind) + dhx_dx_read%st_ind = Observation_Operator_Jacobian_stind(:,i) + dhx_dx_read%end_ind = Observation_Operator_Jacobian_endind(:,i) + dhx_dx_read%val = Observation_Operator_Jacobian_val(:,i) + dhx_dx = dhx_dx_read + t1 = mpi_wtime() + rlat = x_lat(nob)*deg2rad + rlon = x_lon(nob)*deg2rad + rtim = x_time(nob) + if (nob > 1) then + rlat_prev = x_lat(nob-1)*deg2rad + rlon_prev = x_lon(nob-1)*deg2rad + rtim_prev = x_time(nob-1) + endif + if (abs(rlat-rlat_prev) > eps .or. & + abs(rlon-rlon_prev) > eps .or. & + abs(rtim-rtim_prev) > eps) then + call setup_linhx(rlat,rlon,rtim, & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + endif + call calc_linhx(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx(nob), & + ix, delx, ixp, delxp, iy, dely, & + iyp, delyp, it, delt, itp, deltp) + ! compute modulated ensemble in obs space + if (neigv > 0) then + call calc_linhx_modens(hx_mean_nobc(nob), state_d(:,:,:,nmem), & + dhx_dx, hx_modens(:,nob), & + ix, delx, ixp, delxp, iy, dely, iyp, delyp, & + it, delt, itp, deltp, vlocal_evecs) + endif + t2 = mpi_wtime() + tsum = tsum + t2-t1 + call delete(dhx_dx) + call delete(dhx_dx_read) + endif + endif + + x_errorig(nob) = error_variance(chind(i))**2 + x_err(nob) = (1._r_kind/Inv_Error(i))**2 + x_press(nob) = Pressure(i) + +! DTK: **NOTE** +! The bifix term will need to be expanded if/when the GSI/GDAS goes to using +! a higher polynomial version of the angle dependent bias correction (if +! and when it is moved into part of the varbc) +! from radinfo: radiance bias correction terms are as follows: +! pred(1,:) = global offset +! pred(2,:) = zenith angle predictor, is not used and set to zero now +! pred(3,:) = cloud liquid water predictor for clear-sky microwave radiance assimilation +! pred(4,:) = square of temperature laps rate predictor +! pred(5,:) = temperature laps rate predictor +! pred(6,:) = cosinusoidal predictor for SSMI/S ascending/descending bias +! pred(7,:) = sinusoidal predictor for SSMI/S +! pred(8,:) = emissivity sensitivity predictor for land/sea differences +! pred(9,:) = fourth order polynomial of angle bias correction +! pred(10,:) = third order polynomial of angle bias correction +! pred(11,:) = second order polynomial of angle bias correction +! pred(12,:) = first order polynomial of angle bias correction + if (lupd_satbiasc) then ! bias predictors only used if lupd_satbiasc=T + x_biaspred(1,nob) = BCPred_Constant(i) ! global offset + x_biaspred(2,nob) = BCPred_Scan_Angle(i) ! zenith angle predictor, not used + x_biaspred(3,nob) = BCPred_Cloud_Liquid_Water(i) ! CLW bias correction + x_biaspred(4,nob) = BCPred_Lapse_Rate_Squared(i) ! square lapse rate bias corr + x_biaspred(5,nob) = BCPred_Lapse_Rate(i) ! lapse rate bias correction + x_biaspred(6,nob) = BCPred_Cosine_Latitude_times_Node(i) ! node*cos(lat) bias correction for SSMIS + x_biaspred(7,nob) = BCPred_Sine_Latitude(i) ! sin(lat) bias correction for SSMIS + if (emiss_bc) then + x_biaspred(8,nob) = BCPred_Emissivity(i) + nn = 9 + else + nn = 8 + endif + + if (adp_anglebc) then + x_biaspred(nn ,nob) = BCPred_angord(1,i) ! 4th order scan angle (predictor) + x_biaspred(nn+1,nob) = BCPred_angord(2,i) ! 3rd order scan angle (predictor) + x_biaspred(nn+2,nob) = BCPred_angord(3,i) ! 2nd order scan angle (predictor) + x_biaspred(nn+3,nob) = BCPred_angord(4,i) ! 1st order scan angle (predictor) + endif + ! total angle dependent bias correction (sum of four terms) + x_biaspred(npred+1,nob) = BC_Fixed_Scan_Position(i) + else + x_biaspred(:,nob)=zero ! lupd_biaspredc=F, don't need bias predictors + endif + + enddo + + deallocate(Satinfo_Chan, Use_Flag, error_variance, chaninfoidx) + deallocate(Pressure, QC_Flag, Inv_Error, Latitude, Longitude, Time, & + Observation, chind, Obs_Minus_Forecast_unadjusted, & + Obs_Minus_Forecast_adjusted) + if (lupd_satbiasc) then ! bias predictors only used if lupd_satbiasc=T + deallocate(BC_Fixed_Scan_Position, BCPred_Constant, BCPred_Scan_Angle, & + BCPred_Cloud_Liquid_Water, BCPred_Lapse_Rate_Squared, & + BCPred_Lapse_Rate) + deallocate(BCPred_Cosine_Latitude_times_Node, BCPred_Sine_Latitude) + if (emiss_bc) deallocate(BCPred_Emissivity) + if (adp_anglebc) deallocate(BCPred_angord) + endif + if (twofiles) deallocate(Obs_Minus_Forecast_unadjusted2) + if (lobsdiag_forenkf) then + deallocate(Observation_Operator_Jacobian_stind, Observation_Operator_Jacobian_endind, & + Observation_Operator_Jacobian_val) + endif + + enddo peloop ! ipe + enddo ! satellite + if (nanal == nanals .and. lobsdiag_forenkf) print *,'time in calc_linhx for sat obs on proc',nproc,' = ',tsum + if (nanal == nanals) print *,'time in read_raddiag_data for sat obs on proc',nproc,' = ',tsum2 + + if (nob /= nobs_max) then + print *,'number of obs not what expected in get_satobs_data',nob,nobs_max + call stop2(92) + end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total diag obs not what expected in get_satobs_data',nobdiag,nobs_maxdiag + call stop2(92) + end if + + end subroutine get_satobs_data_nc + +! write spread diagnostics +subroutine write_satobs_data(obspath, datestring, nobs_max, nobs_maxdiag, x_fit, x_sprd, x_used, id, id2, gesid2) + implicit none + character*500, intent(in) :: obspath + character(len=10), intent(in) :: datestring + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + real(r_single), dimension(nobs_max), intent(in) :: x_fit, x_sprd + integer(i_kind), dimension(nobs_maxdiag), intent(in) :: x_used + character(len=10), intent(in) :: id, id2, gesid2 + + + if (netcdf_diag) then + call write_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, x_fit, x_sprd, x_used, id, gesid2) + else + call write_satobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, x_fit, x_sprd, x_used, id, id2, gesid2) + endif + +end subroutine write_satobs_data + +! write spread diagnostics to binary file +subroutine write_satobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, x_fit, x_sprd, x_used, id, id2, gesid2) + use radinfo, only: iuse_rad,jpch_rad,nusis + use read_diag, only: iversion_radiag_2, ireal_radiag, ireal_old_radiag + implicit none + + character*500, intent(in) :: obspath + character(len=10), intent(in) :: datestring + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + real(r_single), dimension(nobs_max), intent(in) :: x_fit, x_sprd + integer(i_kind), dimension(nobs_maxdiag), intent(in) :: x_used + character(len=10), intent(in) :: id, id2, gesid2 + + character*500 obsfile,obsfile2 + character(len=4) pe_name + + character(len=20) :: sat_type + + integer(i_kind) iunit,iunit2,iflag,nobs, nobsdiag,n,nsat,ipe,i,jpchstart + logical fexist,init_pass + + character(len=10):: satid,sentype + character(len=20):: sensat + + integer(i_kind):: jiter,nchanl,npred,ianldate,ireal,ipchan,iextra,jextra + integer(i_kind):: idiag,angord,iversion,inewpc,isens,ijacob + integer(i_kind):: iuse_tmp,nuchan_tmp,iochan_tmp + real(r_single) :: freq_tmp,polar_tmp,wave_tmp,varch_tmp,tlapmean_tmp + + real(r_single),dimension(:,:),allocatable :: data_tmp + real(r_single),dimension(:),allocatable :: fix_tmp + real(r_single),dimension(:,:),allocatable :: extra_tmp + + + iunit = 7 + iunit2 = 17 + + nobs = 0 + nobsdiag = 0 + + do nsat=1,nsats_rad + jpchstart=0 + do i=1,jpch_rad + write(sat_type,'(a20)') adjustl(dsis(nsat)) + ! The following is to sort out some historical naming conventions + select case (sat_type(1:4)) + case ('airs') + sat_type='airs_aqua' + case ('iasi') + if (index(sat_type,'metop-a') /= 0) sat_type='iasi_metop-a' + if (index(sat_type,'metop-b') /= 0) sat_type='iasi_metop-b' + if (index(sat_type,'metop-c') /= 0) sat_type='iasi_metop-c' + end select + if(sat_type == trim(nusis(i)) .and. iuse_rad(i) > 0) then + jpchstart = i + exit + end if + end do + if(jpchstart == 0) cycle + init_pass = .true. + if (datestring .eq. '0000000000') then + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_"//trim(adjustl(gesid2))//"."//trim(adjustl(id2)) + else + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_"//trim(adjustl(gesid2))//"."//datestring//'_'//trim(adjustl(id2)) + endif + peloop: do ipe=0,npefiles + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//datestring//'_'//trim(adjustl(id)) + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') then + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//trim(adjustl(id)) + endif + else ! raw, unconcatenated pe* files. + obsfile = trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_rad(nsat))//'_01' + endif + inquire(file=obsfile,exist=fexist) + if(.not.fexist) cycle peloop + + open(iunit,form="unformatted",file=obsfile) + rewind(iunit) + if (init_pass) then + open(iunit2,form="unformatted",file=obsfile2) + ! Read header (fixed_part). + read(iunit,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc,isens,ijacob + if (iflag == 0) then + write(iunit2) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc,isens,ijacob + else + rewind(iunit) + read(iunit,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc,isens + ijacob=0 + if (iflag==0) then + write(iunit2) sensat,satid,sentype,jiter,nchanl,npred,ianldate, & + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc,isens + else + rewind(iunit) + read(iunit,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate, & + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc + if (iflag==0) then + write(iunit2) sensat,satid,sentype,jiter,nchanl,npred,ianldate, & + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc + else + rewind(iunit) + read(iunit,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate, & + ireal,ipchan,iextra,jextra + if (iflag==0) then + write(iunit2) sensat,satid,sentype,jiter,nchanl,npred,ianldate, & + ireal,ipchan,iextra,jextra + else + write(6,*)'READ_RADIAG_HEADER: ***ERROR*** Unknown file format.Cannot read' + call stop2(5555) + endif + endif + endif + endif + ! read header (channel part) + do n=1, nchanl + read(iunit,IOSTAT=iflag) freq_tmp,polar_tmp,wave_tmp,varch_tmp,tlapmean_tmp, & + iuse_tmp,nuchan_tmp,iochan_tmp + write(iunit2) freq_tmp,polar_tmp,wave_tmp,varch_tmp,tlapmean_tmp,iuse_tmp, & + nuchan_tmp,iochan_tmp + if (iflag/=0) return + end do + init_pass = .false. + endif + allocate(data_tmp(idiag,nchanl)) + if (iversion < iversion_radiag_2) then + allocate( fix_tmp( ireal_old_radiag ) ) + else + allocate( fix_tmp( ireal_radiag ) ) + end if + if (iextra > 0) then + allocate(extra_tmp(iextra,jextra)) + endif + + do + if (iextra == 0) then + read(iunit,IOSTAT=iflag) fix_tmp, data_tmp + else + read(iunit,IOSTAT=iflag) fix_tmp, data_tmp, extra_tmp + endif + if( iflag /= 0 ) then + exit + end if + chan:do n=1,nchanl + if (data_tmp(5,n) == 0) data_tmp(5,n) = 100 ! qcmark: not used in EnKF + nobsdiag = nobsdiag + 1 + if (x_used(nobsdiag) == 1) then + nobs = nobs + 1 + data_tmp(5,n) = 0 + data_tmp(3,n) = x_fit(nobs) + data_tmp(3,n)-data_tmp(2,n) + data_tmp(2,n) = x_fit(nobs) + data_tmp(16+angord+3,n) = x_sprd(nobs) + endif + enddo chan + if (iextra == 0) then + write(iunit2) fix_tmp, data_tmp + else + write(iunit2) fix_tmp, data_tmp, extra_tmp + endif + enddo + if (allocated(data_tmp)) deallocate(data_tmp) + if (allocated(fix_tmp)) deallocate(fix_tmp) + if (allocated(extra_tmp)) deallocate(extra_tmp) -900 continue close(iunit) - if(twofiles)close(iunit2) enddo peloop ! ipe + close(iunit2) enddo ! satellite - end subroutine get_satobs_data + if (nobs /= nobs_max) then + print *,'number of obs not what expected in get_satobs_data',nobs,nobs_max + call stop2(92) + end if + if (nobsdiag /= nobs_maxdiag) then + print *,'number of total diag obs not what expected in get_satobs_data',nobsdiag,nobs_maxdiag + call stop2(92) + end if + end subroutine write_satobs_data_bin + +! writing spread diagnostics to netcdf file +subroutine write_satobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & + x_fit, x_sprd, x_used, id, gesid) + use netcdf, only: nf90_inq_dimid, nf90_open, nf90_close, NF90_NETCDF4, & + nf90_inquire_dimension, NF90_WRITE, nf90_create, nf90_def_dim + use ncdw_climsg, only: nclayer_check + + use radinfo, only: iuse_rad,nusis,jpch_rad + use constants, only: r_missing + implicit none + + character*500, intent(in) :: obspath + character(len=10), intent(in) :: datestring + integer(i_kind), intent(in) :: nobs_max, nobs_maxdiag + real(r_single), dimension(nobs_max), intent(in) :: x_fit, x_sprd + integer(i_kind), dimension(nobs_maxdiag), intent(in) :: x_used + character(len=10), intent(in) :: id, gesid + + character*500 obsfile, obsfile2 + character(len=4) pe_name + character(len=20) :: sat_type + + integer(i_kind) :: iunit, nobsid + integer(i_kind) :: nob, nobdiag, nobs, ipe, i, nsat, jpchstart + integer(i_kind), dimension(:), allocatable :: enkf_use_flag + real(r_single), dimension(:), allocatable :: enkf_fit, enkf_sprd + logical :: fexist + + nob = 0 + nobdiag = 0 + + do nsat=1,nsats_rad + jpchstart=0 + do i=1,jpch_rad + write(sat_type,'(a20)') adjustl(dsis(nsat)) + ! The following is to sort out some historical naming conventions + select case (sat_type(1:4)) + case ('airs') + sat_type='airs_aqua' + case ('iasi') + if (index(sat_type,'metop-a') /= 0) sat_type='iasi_metop-a' + if (index(sat_type,'metop-b') /= 0) sat_type='iasi_metop-b' + if (index(sat_type,'metop-c') /= 0) sat_type='iasi_metop-c' + end select + if(sat_type == trim(nusis(i)) .and. iuse_rad(i) > 0) then + jpchstart = i + exit + end if + end do + if(jpchstart == 0) cycle + peloop: do ipe=0,npefiles + write(pe_name,'(i4.4)') ipe + if (npefiles .eq. 0) then + ! diag file (concatenated pe* files) + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//datestring//'_'//trim(adjustl(id))//".nc4" + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//datestring//'_'//trim(adjustl(id))//"_spread.nc4" + inquire(file=obsfile,exist=fexist) + if (.not. fexist .or. datestring .eq. '0000000000') then + obsfile = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//trim(adjustl(id))//".nc4" + obsfile2 = trim(adjustl(obspath))//"diag_"//trim(sattypes_rad(nsat))//"_ges."//trim(adjustl(id))//"_spread.nc4" + endif + else ! raw, unconcatenated pe* files. + obsfile = trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_rad(nsat))//'_01'//".nc4" + obsfile2 = trim(adjustl(obspath))//'gsitmp_'//trim(adjustl(id))//'/pe'//pe_name//'.'//trim(sattypes_rad(nsat))//'_01'//"_spread.nc4" + endif + + inquire(file=obsfile,exist=fexist) + if (.not. fexist) cycle peloop + + + call nclayer_check(nf90_open(obsfile, NF90_WRITE, iunit)) + call nclayer_check(nf90_inq_dimid(iunit, "nobs", nobsid)) + call nclayer_check(nf90_inquire_dimension(iunit, nobsid, len = nobs)) + call nclayer_check(nf90_close(iunit)) + + if (nobs <= 0) cycle peloop + + allocate(enkf_use_flag(nobs), enkf_fit(nobs), enkf_sprd(nobs)) + + do i = 1, nobs + nobdiag = nobdiag + 1 + + ! skip if not used in EnKF + if (x_used(nobdiag) == 1) then + ! update if it is used in EnKF + nob = nob + 1 + enkf_use_flag(i) = 1 + enkf_fit(i) = x_fit(nob) + enkf_sprd(i) = x_sprd(nob) + else + enkf_use_flag(i) = -1 + enkf_fit(i) = r_missing + enkf_sprd(i) = r_missing + endif + enddo + + inquire(file=obsfile2,exist=fexist) + if (.not. fexist) then + call nclayer_check(nf90_create(trim(obsfile2), NF90_NETCDF4, & + iunit)) + call nclayer_check(nf90_def_dim(iunit, "nobs", nobs, nobsid)) + else + call nclayer_check(nf90_open(obsfile2, NF90_WRITE, iunit)) + call nclayer_check(nf90_inq_dimid(iunit, "nobs", nobsid)) + endif + + call write_ncvar_int(iunit, nobsid, "EnKF_use_flag", enkf_use_flag) + call write_ncvar_single(iunit, nobsid, "EnKF_fit_"//trim(gesid), enkf_fit) + call write_ncvar_single(iunit, nobsid, "EnKF_spread_"//trim(gesid), enkf_sprd) + + call nclayer_check(nf90_close(iunit)) + + deallocate(enkf_use_flag, enkf_fit, enkf_sprd) + + enddo peloop ! ipe loop + enddo + + if (nob .ne. nobs_max) then + print *,'number of obs not what expected in write_satobs_data',nob,nobs_max + call stop2(94) + end if + if (nobdiag /= nobs_maxdiag) then + print *,'number of total obs in diag not what expected in write_satobs_data',nobdiag, nobs_maxdiag + call stop2(94) + endif + + contains + subroutine write_ncvar_single(iunit, dimid, varname, field) + use netcdf, only: nf90_def_var, nf90_put_var, nf90_inq_varid, & + nf90_def_var_deflate,NF90_FLOAT, NF90_ENOTVAR + use ncdw_climsg, only: nclayer_check + use ncdw_types, only: NLAYER_COMPRESSION + implicit none + integer(i_kind), intent(in) :: iunit, dimid + character(*), intent(in) :: varname + real(r_single), dimension(:), allocatable :: field + + integer :: ierr, varid + + ierr = nf90_inq_varid(iunit, varname, varid) + if (ierr == NF90_ENOTVAR) then + call nclayer_check(nf90_def_var(iunit, varname, NF90_FLOAT, dimid, varid)) + call nclayer_check(nf90_def_var_deflate(iunit, varid, 1, 1, int(NLAYER_COMPRESSION))) + endif + call nclayer_check(nf90_put_var(iunit, varid, field)) + end subroutine write_ncvar_single + + subroutine write_ncvar_int(iunit, dimid, varname, field) + use netcdf, only: nf90_def_var, nf90_put_var, nf90_inq_varid, & + nf90_def_var_deflate,NF90_INT, NF90_ENOTVAR + use ncdw_climsg, only: nclayer_check + use ncdw_types, only: NLAYER_COMPRESSION + implicit none + integer(i_kind), intent(in) :: iunit, dimid + character(*), intent(in) :: varname + integer(i_kind), dimension(:), allocatable :: field + + integer :: ierr, varid + + ierr = nf90_inq_varid(iunit, varname, varid) + if (ierr == NF90_ENOTVAR) then + call nclayer_check(nf90_def_var(iunit, varname, NF90_INT, dimid, varid)) + call nclayer_check(nf90_def_var_deflate(iunit, varid, 1, 1, int(NLAYER_COMPRESSION))) + endif + call nclayer_check(nf90_put_var(iunit, varid, field)) + end subroutine write_ncvar_int + + +end subroutine write_satobs_data_nc end module readsatobs diff --git a/src/enkf/smooth_fv3reg.f90 b/src/enkf/smooth_fv3reg.f90 new file mode 100644 index 000000000..39646071a --- /dev/null +++ b/src/enkf/smooth_fv3reg.f90 @@ -0,0 +1,23 @@ +module smooth_mod + +use mpisetup +use params, only: nlons,nlats,smoothparm +use controlvec, only: ncdim +use kinds, only: r_kind +use gridinfo, only: npts + +implicit none + +private +public :: smooth + +contains + +subroutine smooth(grids) +real(r_single), intent(inout) :: grids(npts,ncdim) ! there are ndim 2d grids. +! stub - not yet implemented. +if (nproc .eq. 0) print *,'FV3reg inflation smoothing not yet implemented!,stop' +call stop2(544) +end subroutine smooth + +end module smooth_mod diff --git a/src/enkf/smooth_gfs.f90 b/src/enkf/smooth_gfs.f90 index a1e3181aa..2defe5bfd 100644 --- a/src/enkf/smooth_gfs.f90 +++ b/src/enkf/smooth_gfs.f90 @@ -5,11 +5,12 @@ module smooth_mod ! reduced). Isotropic spectral smoothing (gaussian) is used. use mpisetup -use params, only: ndim, nlons, nlats, reducedgrid, smoothparm +use params, only: nlons, nlats, reducedgrid, smoothparm use kinds, only: r_kind, i_kind, r_single use gridinfo, only: npts, ntrunc use constants, only: zero use reducedgrid_mod, only: regtoreduced, reducedtoreg +use controlvec, only: ncdim implicit none @@ -25,28 +26,29 @@ subroutine smooth(grids) ! root task. on return, grids on root will contain ! smoothed grids. ! smoothing controlled by parameter smoothparm. -use specmod, only: sptez_s, init_spec_vars, jcap, isinitialized +use specmod, only: sptez_s, init_spec_vars, isinitialized implicit none integer(i_kind) np,ierr,m,nmdim,nm,nn,n,delta,npmax -real(r_single), intent(inout) :: grids(npts,ndim) ! there are ndim 2d grids. +real(r_single), intent(inout) :: grids(npts,ncdim) ! there are ncdim 2d grids. real(r_single) smoothfact ! smoothing parameter. real(r_kind) reggrd(nlons*nlats) real(r_kind), allocatable, dimension(:) :: specdat integer(i_kind) n1(0:numproc-1),n2(0:numproc-1) -delta = ndim/numproc -if (delta*numproc < ndim) delta = delta + 1 +delta = ncdim/numproc +if (delta*numproc < ncdim) delta = delta + 1 npmax = 0 do np=0,numproc-1 n1(np) = 1 + np*delta n2(np) = (np+1)*delta - if (n2(np) > ndim) n2(np) = ndim - if (n1(np) > ndim .and. npmax == 0) npmax = np-1 + if (n2(np) > ncdim) n2(np) = ncdim + if (n1(np) > ncdim .and. npmax == 0) npmax = np-1 enddo +if (npmax == 0) npmax = numproc-1 ! spectrally smooth the grids ! bcast out to all procs. if (nproc <= npmax) then if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4) - do nn=1,ndim + do nn=1,ncdim if (nn < n1(nproc) .or. nn > n2(nproc)) grids(:,nn)=zero enddo nmdim = (ntrunc+1)*(ntrunc+2)/2 @@ -73,15 +75,14 @@ subroutine smooth(grids) else grids(:,nn) = reggrd endif - enddo !nn=1,ndim + enddo !nn=1,ncdim deallocate(specdat) else ! np > npmax grids = zero end if -!call mpi_allreduce(mpi_in_place,grids,npts*ndim,mpi_real4,mpi_sum,mpi_comm_world,ierr) -do nn=1,ndim +!call mpi_allreduce(mpi_in_place,grids,npts*ncdim,mpi_real4,mpi_sum,mpi_comm_world,ierr) +do nn=1,ncdim call mpi_allreduce(mpi_in_place,grids(1,nn),npts,mpi_real4,mpi_sum,mpi_comm_world,ierr) enddo end subroutine smooth end module smooth_mod - diff --git a/src/enkf/smooth_nmmb.f90 b/src/enkf/smooth_nmmb.f90 index d79283b33..af512935e 100644 --- a/src/enkf/smooth_nmmb.f90 +++ b/src/enkf/smooth_nmmb.f90 @@ -1,7 +1,8 @@ module smooth_mod use mpisetup -use params, only: ndim,nlons,nlats,smoothparm +use params, only: nlons,nlats,smoothparm +use controlvec, only: ncdim use kinds, only: r_kind use gridinfo, only: npts @@ -13,7 +14,7 @@ module smooth_mod contains subroutine smooth(grids) -real(r_single), intent(inout) :: grids(npts,ndim) ! there are ndim 2d grids. +real(r_single), intent(inout) :: grids(npts,ncdim) ! there are ndim 2d grids. ! stub - not yet implemented. if (nproc .eq. 0) print *,'nmmb inflation smoothing not yet implemented!' end subroutine smooth diff --git a/src/enkf/smooth_wrf.f90 b/src/enkf/smooth_wrf.f90 index 03018dc30..e90ebbd24 100644 --- a/src/enkf/smooth_wrf.f90 +++ b/src/enkf/smooth_wrf.f90 @@ -1,7 +1,8 @@ module smooth_mod use mpisetup -use params, only: ndim,nlons,nlats,smoothparm +use params, only: nlons,nlats,smoothparm +use controlvec, only: ncdim use kinds, only: r_kind use gridinfo, only: npts @@ -13,10 +14,9 @@ module smooth_mod contains subroutine smooth(grids) -real(r_single), intent(inout) :: grids(npts,ndim) ! there are ndim 2d grids. +real(r_single), intent(inout) :: grids(npts,ncdim) ! there are ncdim 2d grids. ! stub - not yet implemented. if (nproc .eq. 0) print *,'wrf inflation smoothing not yet implemented!' end subroutine smooth end module smooth_mod - diff --git a/src/enkf/statevec.f90 b/src/enkf/statevec.f90 index b64a88370..6c0726d81 100644 --- a/src/enkf/statevec.f90 +++ b/src/enkf/statevec.f90 @@ -1,38 +1,27 @@ module statevec !$$$ module documentation block ! -! module: statevec read ensemble members, distribute each -! to each task. Collect updated ensemble -! members on root task, write out. +! module: statevec read ensemble members, write out ! ! prgmmr: whitaker org: esrl/psd date: 2009-02-23 ! ! abstract: ensemble IO. ! ! Public Subroutines: -! read_ensemble: read ensemble members on root, distribute pieces (defined by module loadbal) -! to each task. -! write_ensemble: retrieve pieces of updated ensemble from each task on root, -! write out. Optionally save ensemble mean analysis increment. +! init_statevec: read anavinfo table +! read_state: read ensemble members on IO tasks ! statevec_cleanup: deallocate allocatable arrays. ! ! Public Variables: ! nanals: (integer scalar) number of ensemble members (from module params) -! npts_max: (integer scalar) maximum number of grid points assigned to a task. ! nlevs: number of analysis vertical levels (from module params). -! nvars: number of 3d 'non-tracer' variables updated by analysis (from module params). -! ndim: (nvars + ntrac_update) * nlevs (from module params). -! nbackgrounds: number of time levels in background -! anal_chunk(nanals,npts_max,ndim,nbackgrounds): real array of ensemble perturbations -! updated on each task. -! anal_chunk_prior(nanals,npts_max,ndim,nbackgrounds): real array of prior ensemble -! perturbations. Before analysis anal_chunk=anal_chunk_prior, after -! analysis anal_chunk contains posterior perturbations. -! ensmean_chunk(npts_max,ndim,nbackgrounds): real array containing pieces of ensemble -! mean to be updated on each task. -! ensmean_chunk_prior(npts_max,ndim,nbackgrounds): as above, for ensemble mean prior. -! Before analysis ensmean_chunk=ensmean_chunk_prior, after analysis -! ensmean_chunk contains posterior ensemble mean. +! ns3d: number of 3D variables +! ns2d: number of 2D variables +! svars3d: names of 3D variables +! svars2d: names of 2D variables +! nsdim: total number of 2D fields to update (ns3d*nlevs+ns2d) +! nstatefields: number of time levels in background +! state_d: ensemble perturbations ! ! Modules Used: mpisetup, params, kinds, loadbal, gridio, gridinfo ! @@ -40,326 +29,193 @@ module statevec ! 2009-02-23 Initial version. ! 2009-11-28 revamped to improve IO speed ! 2015-06-29 add multiple time levels to background +! 2016-05-02 shlyaeva: Modification for reading state vector from table +! 2016-09-07 shlyaeva: moved distribution of ens members to loadbal +! 2016-11-29 shlyaeva: separated controlvec from statevec; gridinfo init and +! cleanup are called from here now ! ! attributes: ! language: f95 ! !$$$ -use gridio, only: readgriddata,writegriddata_wrf +use gridio, only: readgriddata use mpisetup -use gridinfo, only: lonsgrd, latsgrd, ptop, npts, nvarhumid -use params, only: nlevs,nvars,ndim,nbackgrounds,& - nanals,pseudo_rh,massbal_adjust,use_qsatensmean +use gridinfo, only: getgridinfo, gridinfo_cleanup, & + npts, vars3d_supported, vars2d_supported +use params, only: nlevs,nstatefields,nanals,statefileprefixes,& + ntasks_io,nanals_per_iotask,nanal1,nanal2 use kinds, only: r_kind, i_kind, r_double, r_single -use loadbal, only: npts_max,indxproc,numptsperproc -use enkf_obsmod, only: nobstot +use mpeu_util, only: gettablesize, gettable, getindex +use constants, only : max_varname_length implicit none private -public :: read_ensemble, write_ensemble, statevec_cleanup -real(r_single),public, allocatable, dimension(:,:,:,:) :: anal_chunk, anal_chunk_prior -real(r_single),public, allocatable, dimension(:,:,:) :: ensmean_chunk, ensmean_chunk_prior -real(r_single),public, allocatable, dimension(:,:,:) :: grdin -real(r_double),public, allocatable, dimension(:,:,:) :: qsat -integer(i_kind), allocatable, dimension(:) :: scounts, displs, rcounts +public :: read_state, statevec_cleanup, init_statevec +real(r_single),public, allocatable, dimension(:,:,:,:) :: state_d + +integer(i_kind), public :: ns2d, ns3d, nsdim +character(len=max_varname_length), allocatable, dimension(:), public :: svars3d +character(len=max_varname_length), allocatable, dimension(:), public :: svars2d +integer(i_kind), allocatable, dimension(:), public :: slevels contains -subroutine read_ensemble() -! read ensemble members on IO tasks, -! distribute pieces (defined by module loadbal) to each task. -! for now, first nanals tasks are IO tasks. +subroutine init_statevec() +! read table with state vector variables +! (code adapted from GSI state_vectors.f90 init_anasv routine +! by Anna Shlyaeva, April 18, 2016) implicit none -real(r_single), allocatable, dimension(:) :: sendbuf,recvbuf -real(r_double) t1,t2 -integer(i_kind) nanal,nn,i,n,nb,nlev -! npts,nlevs,ntrac arrays -integer(i_kind) ierr, np - -! must at least nanals tasks allocated. -if (numproc < nanals) then - print *,'need at least nanals =',nanals,'MPI tasks, exiting ...' - call mpi_barrier(mpi_comm_world,ierr) - call mpi_finalize(ierr) -end if -if (npts < numproc) then - print *,'cannot allocate more than npts =',npts,'MPI tasks, exiting ...' - call mpi_barrier(mpi_comm_world,ierr) - call mpi_finalize(ierr) -end if - -allocate(scounts(0:numproc-1)) -allocate(displs(0:numproc-1)) -allocate(rcounts(0:numproc-1)) -! only IO tasks send any data. -! scounts is number of data elements to send to processor np. -! rcounts is number of data elements to recv from processor np. -! displs is displacement into send array for data to go to proc np -do np=0,numproc-1 - displs(np) = np*npts_max*ndim -enddo -if (nproc <= nanals-1) then - scounts = npts_max*ndim -else - scounts = 0 -endif -! displs is also the displacement into recv array for data to go into anal_chunk on -! task np. -do np=0,numproc-1 - if (np <= nanals-1) then - rcounts(np) = npts_max*ndim +character(len=*),parameter:: rcname='anavinfo' +character(len=*),parameter:: tbname='state_vector::' +character(len=256),allocatable,dimension(:):: utable +character(len=20) var,source,funcof +integer(i_kind) luin,ii,i,ntot,nvars +integer(i_kind) ilev, itracer + +! load file +luin=914 +open(luin,file=rcname,form='formatted') + +! Scan file for desired table first +! and get size of table +call gettablesize(tbname,luin,ntot,nvars) + +! Get contents of table +allocate(utable(nvars)) +call gettable(tbname,luin,ntot,nvars,utable) + +! release file unit +close(luin) + +! Retrieve each token of interest from table and define +! variables participating in state vector + +! Count variables first +ns3d=0; ns2d=0; nsdim=0; +do ii=1,nvars + read(utable(ii),*) var, ilev, itracer, source, funcof + if(ilev==1) then + ns2d=ns2d+1 + nsdim=nsdim+1 else - rcounts(np) = 0 - end if + ns3d=ns3d+1 + nsdim=nsdim+ilev + endif enddo -! allocate array to hold pieces of state vector on each proc. -allocate(anal_chunk(nanals,npts_max,ndim,nbackgrounds)) -if (nproc == 0) print *,'anal_chunk size = ',size(anal_chunk) - -! read in whole state vector on i/o procs - keep in memory -! (needed in write_ensemble) -if (nproc <= nanals-1) then - allocate(grdin(npts,ndim,nbackgrounds)) - allocate(qsat(npts,nlevs,nbackgrounds)) - nanal = nproc + 1 - t1 = mpi_wtime() - call readgriddata(nanal,grdin,qsat) - !print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat) - if (use_qsatensmean) then - ! convert qsat to ensemble mean. - do nb=1,nbackgrounds - do nlev=1,nlevs - call mpi_allreduce(mpi_in_place,qsat(1,nlev,nb),npts,mpi_real8,mpi_sum,mpi_comm_io,ierr) - enddo - enddo - qsat = qsat/real(nanals) - !print *,'min/max qsat ensmean',nanal,'=',minval(qsat),maxval(qsat) +allocate(svars3d(ns3d),svars2d(ns2d),slevels(0:ns3d)) + +! Now load information from table +ns3d=0;ns2d=0 +slevels = 0 +do ii=1,nvars + read(utable(ii),*) var, ilev, itracer, source, funcof + if(ilev==1) then + ns2d=ns2d+1 + svars2d(ns2d)=trim(adjustl(var)) + else if (ilev==nlevs .or. ilev==nlevs+1) then + ns3d=ns3d+1 + svars3d(ns3d)=trim(adjustl(var)) + slevels(ns3d)=ilev + slevels(ns3d-1) + else + if (nproc .eq. 0) print *,'Error: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev + call stop2(503) endif - if (nproc == 0) then - t2 = mpi_wtime() - print *,'time in readgridata on root',t2-t1,'secs' - t1 = mpi_wtime() - end if - !print *,'min/max ps ens mem',nanal,'=',& - ! minval(grdin(:,ndim,nbackgrounds/2+1)),maxval(grdin(:,ndim,nbackgrounds/2+1)) - if (pseudo_rh .and. nvarhumid > 0) then - do nb=1,nbackgrounds - ! create normalized humidity analysis variable. - grdin(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs,nb) = & - grdin(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs,nb)/qsat(:,:,nb) - enddo - end if -endif -call mpi_barrier(mpi_comm_world, ierr) +enddo -allocate(anal_chunk_prior(nanals,npts_max,ndim,nbackgrounds)) -allocate(ensmean_chunk(npts_max,ndim,nbackgrounds)) -allocate(ensmean_chunk_prior(npts_max,ndim,nbackgrounds)) -ensmean_chunk = 0. -allocate(sendbuf(numproc*npts_max*ndim)) -allocate(recvbuf(numproc*npts_max*ndim)) +deallocate(utable) -! send and receive buffers. -do nb=1,nbackgrounds ! loop over time levels in background +! sanity checks +if (nsdim == 0) then + if (nproc == 0) print *, 'Error: there are no variables in state vector.' + call stop2(501) +endif -if (nproc <= nanals-1) then - ! fill up send buffer. - do np=1,numproc - do nn=1,ndim - do i=1,numptsperproc(np) - n = ((np-1)*ndim + (nn-1))*npts_max + i - sendbuf(n) = grdin(indxproc(np,i),nn,nb) - enddo - enddo - enddo -end if -call mpi_alltoallv(sendbuf, scounts, displs, mpi_real4, recvbuf, rcounts, displs,& - mpi_real4, mpi_comm_world, ierr) +do i = 1, ns2d + if (getindex(vars2d_supported, svars2d(i))<0) then + if (nproc .eq. 0) then + print *,'Error: 2D variable ', svars2d(i), ' is not supported in current version.' + print *,'Supported variables: ', vars2d_supported + endif + call stop2(502) + endif +enddo +do i = 1, ns3d + if (getindex(vars3d_supported, svars3d(i))<0) then + if (nproc .eq. 0) then + print *,'Error: 3D variable ', svars3d(i), ' is not supported in current version.' + print *,'Supported variables: ', vars3d_supported + endif + call stop2(502) + endif +enddo -!==> compute ensemble of first guesses on each task, remove mean from anal. -!$omp parallel do schedule(dynamic,1) private(nn,i,nanal,n) -do nn=1,ndim - do i=1,numptsperproc(nproc+1) - do nanal=1,nanals - n = ((nanal-1)*ndim + (nn-1))*npts_max + i - anal_chunk(nanal,i,nn,nb) = recvbuf(n) - enddo - ensmean_chunk(i,nn,nb) = sum(anal_chunk(:,i,nn,nb))/float(nanals) - ensmean_chunk_prior(i,nn,nb) = ensmean_chunk(i,nn,nb) -! remove mean from ensemble. - do nanal=1,nanals - anal_chunk(nanal,i,nn,nb) = anal_chunk(nanal,i,nn,nb)-ensmean_chunk(i,nn,nb) - anal_chunk_prior(nanal,i,nn,nb)=anal_chunk(nanal,i,nn,nb) - end do - end do -end do -!$omp end parallel do +if (nproc == 0) then + print *, '2D state variables: ', svars2d + print *, '3D state variables: ', svars3d + print *, '3D levels :', slevels + print *, 'ns3d: ', ns3d, ', ns2d: ', ns2d, ', nsdim: ', nsdim +endif -enddo ! loop over nbackgrounds -deallocate(sendbuf, recvbuf) +call getgridinfo(statefileprefixes(nstatefields/2+1), .false.) -if (nproc == 0) then - t2 = mpi_wtime() - print *,'time to scatter state on root',t2-t1,'secs' -endif +end subroutine init_statevec -end subroutine read_ensemble -subroutine write_ensemble(no_inflate_flag) -! retrieve pieces of updated ensemble from each task to IO tasks, -! write out each ensemble member to a separate file. -! for now, first nanals tasks are IO tasks. +subroutine read_state() +! read ensemble members on IO tasks, implicit none -logical, intent(in) :: no_inflate_flag -real(r_single), allocatable, dimension(:) :: sendbuf, recvbuf -real(r_single), allocatable, dimension(:,:,:) :: ensmean -real(r_double) t1,t2 -integer(i_kind) nanal,i,nvar -integer(i_kind) ierr, np, n, nn, nb +integer(i_kind) nanal, i, nb, ne +real(r_double), allocatable, dimension(:,:,:,:) :: qsat +real(r_single), allocatable, dimension(:) :: state_mean +integer(i_kind) ierr -! all tasks send data, but only IO tasks receive any data. -! scounts is number of data elements to send to processor np. -! rcounts is number of data elements to recv from processor np. -! displs is displacement into send array for data to go to proc np -if (nproc <= nanals-1) then - rcounts = npts_max*ndim -else - rcounts = 0 -endif -do np=0,numproc-1 - displs(np) = np*npts_max*ndim - if (np <= nanals-1) then - scounts(np) = npts_max*ndim - else - scounts(np) = 0 - end if -enddo -allocate(recvbuf(numproc*npts_max*ndim)) -allocate(sendbuf(numproc*npts_max*ndim)) +! must at least nanals tasks allocated. +if (numproc < ntasks_io) then + print *,'need at least ntasks_io =',ntasks_io,'MPI tasks, exiting ...' + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) +end if +if (npts < numproc) then + print *,'cannot allocate more than npts =',npts,'MPI tasks, exiting ...' + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) +end if -t1 = mpi_wtime() -do nb=1,nbackgrounds ! loop over time levels in background - do nn=1,ndim - do i=1,numptsperproc(nproc+1) - do nanal=1,nanals - n = ((nanal-1)*ndim + (nn-1))*npts_max + i - ! add ensemble mean back in. - sendbuf(n) = anal_chunk(nanal,i,nn,nb)+ensmean_chunk(i,nn,nb) - ! convert to increment (A-F). - sendbuf(n) = sendbuf(n)-(anal_chunk_prior(nanal,i,nn,nb)+ensmean_chunk_prior(i,nn,nb)) - enddo - enddo - enddo - call mpi_alltoallv(sendbuf, scounts, displs, mpi_real4, recvbuf, rcounts, displs,& - mpi_real4, mpi_comm_world, ierr) - if (nproc <= nanals-1) then - do np=1,numproc - do nn=1,ndim - do i=1,numptsperproc(np) - n = ((np-1)*ndim + (nn-1))*npts_max + i - grdin(indxproc(np,i),nn,nb) = recvbuf(n) +! read in whole state vector on i/o procs - keep in memory +if (nproc <= ntasks_io-1) then + allocate(state_d(npts,nsdim,nstatefields,nanals_per_iotask)) + allocate(qsat(npts,nlevs,nstatefields,nanals_per_iotask)) + nanal = nproc + 1 + + call readgriddata(nanal1(nproc),nanal2(nproc),svars3d,svars2d,ns3d,ns2d,slevels,nsdim,nstatefields,statefileprefixes,.false.,state_d,qsat) + + ! subtract the mean + allocate(state_mean(npts)) + do nb = 1, nstatefields + do i = 1, nsdim + state_mean = sum(state_d(:,i,nb,:),dim=2)/real(nanals_per_iotask) + call mpi_allreduce(mpi_in_place,state_mean,npts,mpi_real4,mpi_sum,mpi_comm_io,ierr) + state_mean = state_mean/real(ntasks_io) + do ne=1,nanals_per_iotask + state_d(:,i,nb,ne) = state_d(:,i,nb,ne) - state_mean enddo - enddo enddo - !print *,nproc,'min/max ps',minval(grdin(:,ndim)),maxval(grdin(:,ndim)) - end if -enddo ! end loop over background time levels - -if (nproc == 0) then - t2 = mpi_wtime() - print *,'time to gather state on root',t2-t1,'secs' -endif - -deallocate(sendbuf,recvbuf) -if (nproc == 0) then - allocate(ensmean(npts,ndim,nbackgrounds)) -end if -allocate(sendbuf(npts*ndim)) -allocate(recvbuf(npts*ndim)) -if (nproc == 0) t1 = mpi_wtime() -do nb=1,nbackgrounds - if (nproc .eq. 0) then - print *,'time level ',nb - print *,'--------------' - endif - ! gather ens. mean anal. increment on root, print out max/mins. - n = 0 - do nn=1,ndim - do i=1,numptsperproc(nproc+1) - n = n + 1 - ! anal. increment. - sendbuf(n) = ensmean_chunk(i,nn,nb)-ensmean_chunk_prior(i,nn,nb) - enddo enddo - do np=0,numproc-1 - scounts(np) = numptsperproc(np+1)*ndim - n = 0 - do nn=1,np - n = n + numptsperproc(nn)*ndim - enddo - displs(np) = n - enddo - call mpi_gatherv(sendbuf, numptsperproc(nproc+1)*ndim, mpi_real4, recvbuf, & - scounts, displs, mpi_real4, 0, mpi_comm_world, ierr) - if (nproc == 0) then - n = 0 - do np=1,numproc - do nn=1,ndim - do i=1,numptsperproc(np) - n = n + 1 - ensmean(indxproc(np,i),nn,nb) = recvbuf(n) - enddo - enddo - enddo - if (massbal_adjust) then - print *,'ens. mean anal. increment min/max ps tend', minval(ensmean(:,ndim-1,nb)),maxval(ensmean(:,ndim-1,nb)) - endif - print *,'ens. mean anal. increment min/max ps', minval(ensmean(:,ndim,nb)),maxval(ensmean(:,ndim,nb)) - do nvar=1,nvars - print *,'ens. mean anal. increment min/max var',nvar, & - minval(ensmean(:,(nvar-1)*nlevs+1:nvar*nlevs,nb)),maxval(ensmean(:,(nvar-1)*nlevs+1:nvar*nlevs,nb)) - enddo - end if -enddo ! end loop over time levels in background + deallocate(state_mean) + deallocate(qsat) -if (nproc .eq. 0) then - t2 = mpi_wtime() - print *,'time to gather ens mean increment on root',t2-t1,'secs' endif -deallocate(sendbuf,recvbuf) -if (nproc == 0) deallocate(ensmean) - -if (nproc <= nanals-1) then - nanal = nproc + 1 - t1 = mpi_wtime() - if (pseudo_rh .and. nvarhumid > 0) then - do nb=1,nbackgrounds - ! re-scale normalized spfh with sat. sphf of first guess - grdin(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs,nb) = & - grdin(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs,nb)*qsat(:,:,nb) - enddo - end if -! call writegriddata(nanal,grdin,no_inflate_flag) - call writegriddata_wrf(nanal,grdin) - if (nproc == 0) then - t2 = mpi_wtime() - print *,'time in writegriddata_wrf on root',t2-t1,'secs' - endif -end if - -end subroutine write_ensemble +end subroutine read_state subroutine statevec_cleanup() ! deallocate module-level allocatable arrays. -if (allocated(anal_chunk)) deallocate(anal_chunk) -if (allocated(anal_chunk_prior)) deallocate(anal_chunk_prior) -if (allocated(ensmean_chunk)) deallocate(ensmean_chunk) -if (allocated(ensmean_chunk_prior)) deallocate(ensmean_chunk_prior) -if (nproc <= nanals-1 .and. allocated(grdin)) deallocate(grdin) -if (nproc <= nanals-1 .and. allocated(qsat)) deallocate(qsat) -deallocate(displs,scounts,rcounts) +if (allocated(svars3d)) deallocate(svars3d) +if (allocated(svars2d)) deallocate(svars2d) +if (allocated(slevels)) deallocate(slevels) +if (nproc <= ntasks_io-1 .and. allocated(state_d)) deallocate(state_d) +call gridinfo_cleanup() end subroutine statevec_cleanup end module statevec diff --git a/src/enkf/write_fv3reg_restarts.f90 b/src/enkf/write_fv3reg_restarts.f90 new file mode 100644 index 000000000..522740029 --- /dev/null +++ b/src/enkf/write_fv3reg_restarts.f90 @@ -0,0 +1,79 @@ + module write_fv3regional_restarts +! modified from write_fv3_restarts.f90 + +! ifort -I${NETCDF}/include -O2 -traceback write_fv3_restarts.f90 kinds.o +! netcdf_mod.o -L/${NETCDF}/lib -lnetcdf -lnetcdff + +! read data from FV3 restart files. + + + use kinds, only: i_kind,r_single,r_kind + use netcdf, only: nf90_open,nf90_close,nf90_put_var,nf90_noerr + use netcdf, only: nf90_inq_dimid,nf90_inq_varid + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf_mod, only: nc_check + public write_fv3_restart_data1d,write_fv3_restart_data2d + public write_fv3_restart_data3d,write_fv3_restart_data4d + + contains + + subroutine write_fv3_restart_data1d(varname,filename,file_id,data_arr) + real(r_single), intent(inout), dimension(:) :: data_arr + character(len=24),parameter :: myname_ = 'write_fv3_restart_data1d' + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + integer(i_kind), intent(in) :: file_id + integer(i_kind) :: var_id + data_arr=data_arr(ubound(data_arr,1):lbound(data_arr,1):-1) + call nc_check( nf90_inq_varid(file_id,trim(adjustl(varname)),var_id),& + myname_,'inq_varid '//trim(adjustl(varname))//' '//trim(filename) ) + call nc_check( nf90_put_var(file_id,var_id,data_arr),& + myname_,'get_var '//trim(adjustl(varname))//' '//trim(filename) ) + end subroutine write_fv3_restart_data1d + + subroutine write_fv3_restart_data2d(varname,filename,file_id,data_arr) + real(r_single), intent(inout), dimension(:,:) :: data_arr + character(len=24),parameter :: myname_ = 'write_fv3_restart_data2d' + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + integer(i_kind), intent(in) :: file_id + integer(i_kind) :: var_id + data_arr=data_arr(ubound(data_arr,1):lbound(data_arr,1):-1,ubound(data_arr,2):lbound(data_arr,2):-1) + call nc_check( nf90_inq_varid(file_id,trim(adjustl(varname)),var_id),& + myname_,'inq_varid '//trim(adjustl(varname))//' '//trim(filename) ) + call nc_check( nf90_put_var(file_id,var_id,data_arr),& + myname_,'get_var '//trim(adjustl(varname))//' '//trim(filename) ) + end subroutine write_fv3_restart_data2d + + subroutine write_fv3_restart_data3d(varname,filename,file_id,data_arr) + real(r_single), intent(inout), dimension(:,:,:) :: data_arr + character(len=24),parameter :: myname_ = 'write_fv3_restart_data3d' + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + integer(i_kind), intent(in) :: file_id + integer(i_kind) :: var_id + data_arr=data_arr(ubound(data_arr,1):lbound(data_arr,1):-1,ubound(data_arr,2):lbound(data_arr,2):-1, & + ubound(data_arr,3):lbound(data_arr,3):-1) + call nc_check( nf90_inq_varid(file_id,trim(adjustl(varname)),var_id),& + myname_,'inq_varid '//trim(adjustl(varname))//' '//trim(filename) ) + call nc_check( nf90_put_var(file_id,var_id,data_arr),& + myname_,'get_var '//trim(adjustl(varname))//' '//trim(filename) ) + end subroutine write_fv3_restart_data3d + + subroutine write_fv3_restart_data4d(varname,filename,file_id,data_arr) + real(r_single), intent(inout), dimension(:,:,:,:) :: data_arr + character(len=24),parameter :: myname_ = 'write_fv3_restart_data4d' + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + integer(i_kind), intent(in) :: file_id + integer(i_kind) :: var_id + data_arr=data_arr(ubound(data_arr,1):lbound(data_arr,1):-1,ubound(data_arr,2):lbound(data_arr,2):-1, & + ubound(data_arr,3):lbound(data_arr,3):-1,lbound(data_arr,4):ubound(data_arr,4)) +!Notice, the 4th dimension is not reversed + call nc_check( nf90_inq_varid(file_id,trim(adjustl(varname)),var_id),& + myname_,'inq_varid '//trim(adjustl(varname))//' '//trim(filename) ) + call nc_check( nf90_put_var(file_id,var_id,data_arr),& + myname_,'get_var '//trim(adjustl(varname))//' '//trim(filename) ) + end subroutine write_fv3_restart_data4d + + end module write_fv3regional_restarts diff --git a/src/evaljo.f90 b/src/evaljo.f90 deleted file mode 100644 index c91642eeb..000000000 --- a/src/evaljo.f90 +++ /dev/null @@ -1,173 +0,0 @@ -subroutine evaljo(pjo,kobs,kprt,louter) -!$$$ subprogram documentation block -! . . . . -! subprogram: evaljo -! prgmmr: tremolet -! -! abstract: Computes and prints Jo components -! -! program history log: -! 2007-03-01 tremolet -! 2009-01-15 todling - quad precision for reproducibility -! 2009-08-14 lueken - update documentation -! -! input argument list: -! kprt - print level -! louter -! -! output argument list: -! kobs - Number of obs used in evaluating Jo -! pjo - Jo value -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - use kinds, only: r_kind,i_kind,r_quad - use obsmod, only: nobs_type,cobstype,obscounts - use obsmod, only: obsdiags - use obsmod, only: obs_diag - use gsi_4dvar, only: nobs_bins - use constants, only: zero_quad - use mpimod, only: ierror,mpi_comm_world,mpi_sum,mpi_integer,mype - use jfunc, only: jiter - use mpl_allreducemod, only: mpl_allreduce - - implicit none - -! Declare passed variables - real(r_quad) ,intent( out) :: pjo - integer(i_kind),intent( out) :: kobs - integer(i_kind),intent(in ) :: kprt - logical ,intent(in ) :: louter - -! Declare local variables - integer(i_kind) :: ii,jj,ij,ilen - integer(i_kind) :: iobs(nobs_type) - real(r_quad) :: zjo,zz - real(r_kind) :: zdep - real(r_quad) :: zjo2(nobs_type,nobs_bins) - real(r_quad) :: zjo1(nobs_type) - real(r_quad) :: zprods(nobs_type*nobs_bins) - integer(i_kind) :: iobsgrp(nobs_type,nobs_bins),iobsglb(nobs_type,nobs_bins) - type(obs_diag),pointer:: obsptr -! ---------------------------------------------------------- - -zprods(:)=zero_quad -iobsgrp(:,:)=0 -iobsglb(:,:)=0 - -ij=0 -do ii=1,nobs_bins - do jj=1,nobs_type - ij=ij+1 - - obsptr => obsdiags(jj,ii)%head - do while (associated(obsptr)) - if (obsptr%luse.and.obsptr%muse(jiter)) then - if (louter) then - zdep=obsptr%nldepart(jiter) - else - zdep=obsptr%tldepart(jiter)-obsptr%nldepart(jiter) - endif - zprods(ij) = zprods(ij) + obsptr%wgtjo * zdep * zdep - iobsgrp(jj,ii)=iobsgrp(jj,ii)+1 - endif - obsptr => obsptr%next - enddo - - enddo -enddo - -! Sum Jo contributions -call mpl_allreduce(nobs_type*nobs_bins,qpvals=zprods) - -! Sum number of observations -ilen=nobs_bins*nobs_type -call mpi_allreduce(iobsgrp,iobsglb,ilen, & - & mpi_integer,mpi_sum,mpi_comm_world,ierror) - -! Gather Jo contributions - -ij=0 -do ii=1,nobs_bins - do jj=1,nobs_type - ij=ij+1 - zjo2(jj,ii)=zprods(ij) - enddo -enddo - -zjo1=zero_quad -iobs=0 -DO ii=1,nobs_bins - zjo1(:)=zjo1(:)+zjo2(:,ii) - iobs(:)=iobs(:)+iobsglb(:,ii) -ENDDO - -zjo=zero_quad -kobs=0 -DO ii=1,nobs_type - zjo=zjo+zjo1(ii) - kobs=kobs+iobs(ii) -ENDDO - -pjo=zjo - -! Prints -IF (kprt>=2.and.mype==0) THEN - if (louter) then - write(6,*)'Begin Jo table outer loop' - else - write(6,*)'Begin Jo table inner loop' - endif - - IF (kprt>=3.and.nobs_bins>1) THEN - write(6,400)'Observation Type','Bin','Nobs','Jo','Jo/n' - DO ii=1,nobs_type - DO jj=1,nobs_bins - IF (iobsglb(ii,jj)>0) THEN - zz=zjo2(ii,jj)/iobsglb(ii,jj) - write(6,100)cobstype(ii),jj,iobsglb(ii,jj),real(zjo2(ii,jj),r_kind),real(zz,r_kind) - ENDIF - ENDDO - ENDDO - ENDIF - - write(6,400)'Observation Type',' ','Nobs','Jo','Jo/n' - DO ii=1,nobs_type - IF (iobs(ii)>0) THEN - zz=zjo1(ii)/iobs(ii) - write(6,200)cobstype(ii),iobs(ii),real(zjo1(ii),r_kind),real(zz,r_kind) - ENDIF - ENDDO - - IF (kobs>0) THEN - zz=zjo/kobs - ELSE - zz=-999.999_r_quad - ENDIF - write(6,400)' ',' ','Nobs','Jo','Jo/n' - write(6,300)"Jo Global",kobs,real(zjo,r_kind),real(zz,r_kind) - - if (louter) then - write(6,*)'End Jo table outer loop' - else - write(6,*)'End Jo table inner loop' - endif -ENDIF - -if (.not.allocated(obscounts)) then - write(6,*)'evaljo: obscounts not allocated' - call stop2(125) -end if -obscounts(:,:)=iobsglb(:,:) - -100 format(a20,2x,i3,2x,i8,2x,es24.16,2x,f10.3) -200 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3) -300 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3) -400 format(a20,2x,a3,2x,a8,2x,a24,4x,a8) - -! ---------------------------------------------------------- -return -end subroutine evaljo diff --git a/src/genstats_gps.f90 b/src/genstats_gps.f90 deleted file mode 100644 index 4b592b4ff..000000000 --- a/src/genstats_gps.f90 +++ /dev/null @@ -1,682 +0,0 @@ -module m_gpsStats -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_gpsStats -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2015-08-28 -! -! abstract: a modular wrapper of (gsp_allhead, gps_alltail), and genstats_gps() -! -! program history log: -! 2007-06-22 cucurull - modify gps_all_ob_type structure -! 2015-08-28 j guo - created this module on top of genstats_gps(); -! . completed with type/data components from obsmod; -! . changed code where this module needs to be used; -! . added this document block; -! . for earlier history log, see the history log section -! inside ::genstats_gps() below. -! 2016-05-18 j guo - Made the type private, since this is only a single -! instance module object, with its components defined -! as module variables (gps_allhead, and gsp_alltail). -! . Removed old interface names, which are no longer used -! in this version of GSI. -! . Edited the in-file documentation. -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - - use m_gpsNode, only: gps_ob_type => gpsNode - use kinds , only: r_kind,i_kind - implicit none - private ! except - - ! Data Structure: - !public:: gps_all_ob_type ! currently not required to be public - - type gps_all_ob_type - type(gps_all_ob_type),pointer :: llpoint => NULL() - type(gps_ob_type),pointer :: mmpoint => NULL() - real(r_kind) :: ratio_err - real(r_kind) :: obserr - real(r_kind) :: dataerr - real(r_kind) :: pg - real(r_kind) :: b - real(r_kind) :: loc - real(r_kind) :: type - - real(r_kind),dimension(:),pointer :: rdiag => NULL() - integer(i_kind) :: kprof - logical :: luse ! flag indicating if ob is used in pen. - - logical :: muse ! flag indicating if ob is used in pen. - character(8) :: cdiag - - integer(i_kind) :: idv,iob ! device id and obs index for sorting - real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - end type gps_all_ob_type - - type gps_all_ob_head - integer(i_kind):: n_alloc=0 - type(gps_all_ob_type),pointer :: head => NULL() - end type gps_all_ob_head - - ! Data objects: - - public:: gps_allhead - public:: gps_alltail - - ! interfaces: - - public:: gpsStats_create - public:: gpsStats_destroy - - interface gpsStats_create ; module procedure create_; end interface - interface gpsStats_destroy; module procedure destroy_genstats_gps; end interface - - public:: gpsStats_genStats - - interface gpsStats_genStats; module procedure genstats_gps; end interface - - ! Synopsis: - ! - []_create: allocated in gsimod::gsimain_initialize(). It was - ! done through ::create_obsmod_vars(), and now next to it. - ! - ! - externally built, node-by-node, in setupbend() or setupref(). - ! This is the reason why the ADT can not be defined as "private". - ! - ! - []_genStats: used to update m_rhs::[ab]work, in setuprhsall(), - ! through ::genstats_gps(); - ! - ! - []_destroy: deallocated within genstats_gps(), when it it - ! finished. - ! - ! The use of []_create()/[]_destroy() pair is obviously not symmetric. It - ! would cleaner if they are be moved to the level of setuprhsall(), - ! where m_rhs::[ab]work are computed. e.g., - ! - ! if(init_pass) call gpsStats_create() - ! ... - ! if(last_pass) then - ! call gpsStats_genstats(bwork,awork,...) - ! call gpsStats_destroy() - ! endif - ! - ! As it is now, the second half has been done, but the first half - ! stayed at where it has been, for later. - -! Most implementations of this module, are snap-shots of gps_all_ob_type, from -! obsmod, its original home. These implementations include, the type -! definition (gps_all_ob_type and gsp_app_ob_head), instantiation of the type -! (gps_allhead and gsp_alltail), and interfaces for the operations of this -! object ([]_create, []_genstats, []_destroy). The part of implementation for -! the node-growing, is remained in setupbend() and setupref() as is. - - type(gps_all_ob_head),dimension(:),pointer :: gps_allhead => null() - type(gps_all_ob_head),dimension(:),pointer :: gps_alltail => null() - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='genstats_gps' -contains - - subroutine create_() - use gsi_4dvar, only: nobs_bins - implicit none - - ALLOCATE(gps_allhead(nobs_bins)) - ALLOCATE(gps_alltail(nobs_bins)) - end subroutine create_ - - subroutine destroy_genstats_gps() -!$$$ subprogram documentation block -! . . . . -! subprogram: destroy_genstats_gps -! prgmmr: treadon org: np20 date: 2005-12-21 -! -! abstract: deallocate arrays holding gps information -! -! program history log: -! 2005-12-21 treadon -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ end documentation block - use gsi_4dvar, only: nobs_bins - use kinds, only: i_kind - implicit none - - integer(i_kind):: istatus,ii - - do ii=1,nobs_bins - gps_alltail(ii)%head => gps_allhead(ii)%head - do while (associated(gps_alltail(ii)%head)) - gps_allhead(ii)%head => gps_alltail(ii)%head%llpoint - deallocate(gps_alltail(ii)%head,stat=istatus) - if (istatus/=0) write(6,*)'DESTROY_GENSTATS_GPS: deallocate error for gps_all, istatus=',istatus - gps_alltail(ii)%head => gps_allhead(ii)%head - end do - end do - - return - end subroutine destroy_genstats_gps - -subroutine genstats_gps(bwork,awork,toss_gps_sub,conv_diagsave,mype) -!$$$ subprogram documentation block -! . . . . -! subprogram: genstats_gps generate statistics for gps observations -! prgmmr: treadon org: np20 date: 2005-12-21 -! -! abstract: For gps observations, this routine -! a) collects statistics for runtime diagnostic output -! f) adjusts observation error ratio based on superobs factor -! -! program history log: -! 2005-12-21 treadon -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! 2006-09-20 cucurull - replace superobs factor for obs in a top (non-full) layer -! 2007-03-01 treadon - add array toss_gps -! 2007-03-19 tremolet - binning of observations -! 2007-06-21 cucurull - add conv_diagsave and mype in argument list; -! modify qc and output for diagnostic file based on toss_gps -! print out diagnostic files if requested -! add wgtlim and huge_single in constants module -! 2008-02-27 cucurull - modify diagnostics output file -! 2008-04-14 treadon - compute super_gps within this routine -! 2008-06-04 safford - rm unused vars and uses -! 2008-09-05 lueken - merged ed's changes into q1fy09 code -! 2008-25-08 todling - adapt obs-binning change to GSI-May2008 -! 2009-02-05 cucurull - modify latitude range four statistics output -! 2009-10-22 shen - add high_gps -! 2010-04-09 cucurull - fix several bugs for high_gps (diag information, counters, -! - consider failure of gross check, obs-binning structures, QC for CL profiles) -! - reorganize high_gps structure -! - modify dimension of diagnostic structure -! 2010-07-23 treadon - add ratio_error=zero to reqional QC block, replace (izero,ione) with (0,1), -! remove _i_kind suffix from integer constants, clean up use statements -! 2010-08-17 treadon - convert high_gps from m to km one time only; break out regional -! QC as separate if/then block (global will bypass); replace -! ratio_errors_reg with logical toss -! 2010-10-25 cucurull - add quality control options for C/NOFS satellite -! 2011-01-18 cucurull - increase the size of nreal and mreal by one element to -! add gps_dtype information -! 2012-10-16 cucurull - increase the size of nreal and mreal by one element to -! add qrefges information, replace qcfail=5 by 4, add regional QC for MetOpB -! add dtype, dobs to distinguish use of toss_gps between ref/bending, add SR QC for obs -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-12-13 derber - minor optimization modifications -! 2015-07-28 cucurull - add QC for regional bending angle assimilation -! 2015-08-28 guo - wrapped as a module (m_gpsStats) -! moved the call to obsmod::destroy_genstats_gps() to -! where this routine was used (setuprhsall()), with its -! new module interface name. gpsStats_destroy(). -! -! input argument list: -! toss_gps_sub - array of qc'd profile heights -! conv_diagsave - logical to save innovation diagnostics -! mype - mpi task id -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,i_kind,r_single - use obsmod, only: nprof_gps - use obsmod, only: obs_diag,lobsdiagsave,luse_obsdiag - use gridmod, only: nsig,regional - use constants, only: tiny_r_kind,half,wgtlim,one,two,zero,five,four - use qcmod, only: npres_print,ptop,pbot - use mpimod, only: ierror,mpi_comm_world,mpi_rtype,mpi_sum,mpi_max - use jfunc, only: jiter,miter - use gsi_4dvar, only: nobs_bins - use convinfo, only: nconvtype - implicit none - -! Declare passed variables - logical ,intent(in):: conv_diagsave - integer(i_kind) ,intent(in) :: mype - real(r_kind),dimension(100+7*nsig) ,intent(inout):: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout):: bwork - real(r_kind),dimension(max(1,nprof_gps)) ,intent(in):: toss_gps_sub - -! Declare local parameters - real(r_kind),parameter:: ten = 10.0_r_kind - real(r_kind),parameter:: six = 6.0_r_kind - real(r_kind),parameter:: r1em3 = 1.0e-3_r_kind - real(r_kind),parameter:: r20 = 20.0_r_kind - real(r_kind),parameter:: scale = 100.0_r_kind - -! Declare local variables - logical:: luse,muse,toss - integer(i_kind):: k,jsig,icnt,khgt,kprof,ikx,nn,j,nchar,nreal,mreal,ii,ioff - real(r_kind):: pressure,arg,wgross,wgt,term,cg_gps,valqc,elev,satid,dtype,dobs - real(r_kind):: ress,val,ratio_errors,val2 - real(r_kind):: exp_arg,data_ikx,data_rinc,cg_term,rat_err2,elat - real(r_kind):: wnotgross,data_ipg,data_ier,data_ib,factor,super_gps_up,rhgt - real(r_kind),dimension(nsig,max(1,nprof_gps)):: super_gps_sub,super_gps - real(r_kind),dimension(max(1,nprof_gps)):: toss_gps - real(r_kind),dimension(max(1,nprof_gps)):: high_gps,high_gps_sub - real(r_kind),dimension(max(1,nprof_gps)):: dobs_height,dobs_height_sub - - real(r_single),allocatable,dimension(:,:)::sdiag - character(8),allocatable,dimension(:):: cdiag - - type(obs_diag), pointer :: obsptr => NULL() - type(gps_ob_type), pointer:: gpsptr - type(gps_all_ob_type), pointer:: gps_allptr - - -!******************************************************************************* -! Check to see if there are any profiles to process. If none, return. - if (nprof_gps==0) then - if (mype==0) write(6,*)'GENSTATS_GPS: no profiles to process (nprof_gfs=',nprof_gps,'), EXIT routine' - return - endif - -! Reduce sub-domain specific QC'd profile height cutoff values to -! maximum global value for each profile - toss_gps=zero - call mpi_allreduce(toss_gps_sub,toss_gps,nprof_gps,mpi_rtype,mpi_max,& - mpi_comm_world,ierror) - -! Get height of maximum bending angle - dobs_height_sub = zero - DO ii=1,nobs_bins - gps_allptr => gps_allhead(ii)%head - do while (associated(gps_allptr)) - -! Load local work variables - kprof = gps_allptr%kprof - dtype = gps_allptr%rdiag(20) - dobs = gps_allptr%rdiag(17) - - if (dtype == one .and. toss_gps(kprof) > zero .and. dobs == toss_gps(kprof)) then - dobs_height_sub(kprof) = gps_allptr%rdiag(7) - endif - - gps_allptr => gps_allptr%llpoint - -! End loop over observations - end do - -! End of loop over time bins - END DO - -! Reduce sub-domain specific QC'd profile height to maximum global value for each profile - dobs_height=zero - call mpi_allreduce(dobs_height_sub,dobs_height,nprof_gps,mpi_rtype,mpi_max,& - mpi_comm_world,ierror) - - -! Compute superobs factor on sub-domains using global QC'd profile height - super_gps_sub=zero - high_gps_sub = zero - DO ii=1,nobs_bins - gps_allptr => gps_allhead(ii)%head - do while (associated(gps_allptr)) - -! Load local work variables - ratio_errors = gps_allptr%ratio_err - data_ier = gps_allptr%obserr - luse = gps_allptr%luse - kprof = gps_allptr%kprof - dtype = gps_allptr%rdiag(20) - -! Accumulate superobs factors and get highest good gps obs within a profile - - if (dtype == zero) then ! refractivity - rhgt = gps_allptr%loc - if (rhgt >toss_gps(kprof)) then - if(ratio_errors*data_ier>tiny_r_kind) then - elev = gps_allptr%rdiag(7) - high_gps_sub(kprof)=max(high_gps_sub(kprof),elev) - if(luse) then - khgt = gps_allptr%loc - k=min(max(1,khgt),nsig) - super_gps_sub(k,kprof)=super_gps_sub(k,kprof)+one - endif - endif - endif - - else ! bending angle - dobs = gps_allptr%rdiag(17) - if(toss_gps(kprof) == zero .or. (toss_gps(kprof) > zero .and. dobs < toss_gps(kprof))) then ! will not fail SR from obs qc - elev = gps_allptr%rdiag(7) - if(elev > dobs_height(kprof)) then - if(ratio_errors*data_ier>tiny_r_kind) then - high_gps_sub(kprof)=max(high_gps_sub(kprof),elev) - if(luse) then - khgt = gps_allptr%loc - k=min(max(1,khgt),nsig) - super_gps_sub(k,kprof)=super_gps_sub(k,kprof)+one - endif - endif - endif - endif - endif - - - gps_allptr => gps_allptr%llpoint - -! End loop over observations - end do - -! End of loop over time bins - END DO - - super_gps = zero - high_gps = zero -! Reduce sub-domain specifc superobs factors to global values for each profile - call mpi_allreduce(super_gps_sub,super_gps,nsig*nprof_gps,mpi_rtype,mpi_sum,& - mpi_comm_world,ierror) - -! Reduce sub-domain specific high_gps values to global values for each profile - call mpi_allreduce(high_gps_sub,high_gps,nprof_gps,mpi_rtype,mpi_max,& - mpi_comm_world,ierror) - -! Convert high_gps from meters to kilometers - high_gps = r1em3*high_gps - - -! If generating diagnostic output, need to determine dimension of output arrays. - nreal=0 - ioff =nreal - if (conv_diagsave) then - icnt = zero - DO ii=1,nobs_bins - gps_allptr => gps_allhead(ii)%head - do while (associated(gps_allptr)) - luse = gps_allptr%luse - if(luse)icnt=icnt+1 - gps_allptr => gps_allptr%llpoint - end do - END DO - if(icnt > 0)then - nreal =21 - ioff =nreal - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiag(icnt),sdiag(nreal,icnt)) - end if - endif - - - -! Loop over data to apply final qc, superobs factors, accumulate -! statistics and (optionally) load diagnostic output arrays - icnt=0 - DO ii=1,nobs_bins - gps_allptr => gps_allhead(ii)%head - do while (associated(gps_allptr)) - -! Load local work variables - ratio_errors = gps_allptr%ratio_err - data_ier = gps_allptr%obserr - luse = gps_allptr%luse - muse = gps_allptr%muse - khgt = gps_allptr%loc - kprof = gps_allptr%kprof - dtype = gps_allptr%rdiag(20) - gpsptr => gps_allptr%mmpoint - if(muse .and. associated(gpsptr) .and. luse_obsdiag)then - obsptr => gpsptr%diags - endif - -! Transfer diagnostic information to output arrays - if(conv_diagsave .and. luse) then - icnt=icnt+1 - cdiag(icnt) = gps_allptr%cdiag - do j=1,nreal - sdiag(j,icnt)= gps_allptr%rdiag(j) - enddo - endif - -! Determine model level to which observation is mapped to - k=min(max(1,khgt),nsig) - -! Normalize ratio_errors by superobs factor. Update ratio_error -! term used in minimization - super_gps_up=zero - - if (super_gps(k,kprof)>tiny_r_kind) then - do j=min(k+1,nsig),nsig - super_gps_up = max(super_gps_up,super_gps(j,kprof)) - enddo - - if (super_gps_up >tiny_r_kind) then - factor = one / sqrt(super_gps(k,kprof)) - else - factor = one / sqrt(max(super_gps(k-1,kprof),super_gps(k,kprof))) - endif - ratio_errors = ratio_errors * factor - if(conv_diagsave .and. luse) then - if(gps_allptr%rdiag(16) >tiny_r_kind) sdiag(16,icnt)=ratio_errors*data_ier - endif - -! Adjust error ratio for observations used in inner loop - if (associated(gpsptr)) then - gpsptr%raterr2 = ratio_errors **2 - if(associated(obsptr) .and. luse_obsdiag)then - obsptr%wgtjo=(ratio_errors*data_ier)**2 - end if - endif - endif - - -! For given profile, check if observation level is below level at -! which profile data is tossed. If so, set error parameter to -! zero (effectively tossing the obs). - - rhgt = gps_allptr%loc - mreal = 21 - if(dtype == zero) then !refractivity - if (rhgt<=toss_gps(kprof)) then - if(ratio_errors*data_ier > tiny_r_kind) then ! obs was good - if (luse) then - if(conv_diagsave) then - sdiag(10,icnt) = four - sdiag(12,icnt) = -one - sdiag(16,icnt) = zero - if(lobsdiagsave) sdiag(mreal+jiter,icnt) = -one - endif - elat = gps_allptr%rdiag(3) - if(elat > r20) then - awork(22) = awork(22)+one - else if(elat< -r20)then - awork(23) = awork(23)+one - else - awork(24) = awork(24)+one - end if - endif - endif - ratio_errors = zero - if (associated(gpsptr)) then - gpsptr%raterr2 = ratio_errors **2 - if(associated(obsptr) .and. luse_obsdiag)then - obsptr%wgtjo=zero - obsptr%muse(jiter)=.false. - end if - endif - endif - else - elev = gps_allptr%rdiag(7) - dobs = gps_allptr%rdiag(17) - if (toss_gps(kprof) > zero .and. (dobs == toss_gps(kprof) .or. elev < dobs_height(kprof))) then ! SR from obs - if(ratio_errors*data_ier > tiny_r_kind) then ! obs was good - if (luse) then - if(conv_diagsave) then - sdiag(10,icnt) = four - sdiag(12,icnt) = -one - sdiag(16,icnt) = zero - if(lobsdiagsave) sdiag(mreal+jiter,icnt) = -one - endif - elat = gps_allptr%rdiag(3) - if(elat > r20) then - awork(22) = awork(22)+one - else if(elat< -r20)then - awork(23) = awork(23)+one - else - awork(24) = awork(24)+one - end if - endif - endif - ratio_errors = zero - if (associated(gpsptr)) then - gpsptr%raterr2 = ratio_errors **2 - if(associated(obsptr) .and. luse_obsdiag)then - obsptr%wgtjo=zero - obsptr%muse(jiter)=.false. - end if - endif - endif - endif - - - -! Regional QC. Remove obs if highest good obs in -! profile is below platform specific threshold height. - if(regional) then - toss=.false. - if(ratio_errors*data_ier > tiny_r_kind) then - if(dtype==zero) then !refractivity - satid = gps_allptr%rdiag(1) - if((satid==41).or.(satid==722).or.(satid==723).or.(satid==4).or.(satid==786).or.(satid==3)) then - if ((high_gps(kprof)) < ten) toss=.true. - else ! OL - if ((high_gps(kprof)) < five) toss=.true. - endif - else !bending angle - if ((high_gps(kprof)) <= six) toss=.true. - endif - endif - if (toss) then - if (luse) then - if(conv_diagsave) then - sdiag(10,icnt) = four - sdiag(12,icnt) = -one - sdiag(16,icnt) = zero - if(lobsdiagsave) sdiag(mreal+jiter,icnt) = -one - endif - elat = gps_allptr%rdiag(3) - if(elat > r20) then - awork(22) = awork(22)+one - else if(elat< -r20)then - awork(23) = awork(23)+one - else - awork(24) = awork(24)+one - end if - end if - ratio_errors = zero - if (associated(gpsptr)) then - gpsptr%raterr2 = ratio_errors **2 - if(associated(obsptr) .and. luse_obsdiag)then - obsptr%wgtjo=zero - obsptr%muse(jiter)=.false. - end if - endif - endif - endif ! regional - -! Compute penalty terms - if (ratio_errors*data_ier <= tiny_r_kind) muse = .false. - if(luse)then - val = gps_allptr%dataerr - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - data_ipg = gps_allptr%pg - if (data_ipg > tiny_r_kind) then - data_ib = gps_allptr%b - cg_gps=cg_term/data_ib - wnotgross= one-data_ipg - wgross = data_ipg*cg_gps - arg = exp(exp_arg) - term = log(wnotgross*arg+wgross) - wgt = wnotgross*arg/(wnotgross*arg+wgross) - else - term = exp_arg - wgt = one - endif - if(conv_diagsave) sdiag(13,icnt) = wgt/wgtlim - valqc = -two*rat_err2*term - - -! Accumulate statistics for obs belonging to this task -! based on interface (not mid-point) level - val2=val2*rat_err2 - if(muse)then - if(wgt < wgtlim) awork(21) = awork(21)+one - -! Accumulate values for penalty and data count - jsig=max(1,khgt) - awork(jsig+3*nsig+100)=awork(jsig+3*nsig+100)+valqc - awork(jsig+5*nsig+100)=awork(jsig+5*nsig+100)+one - awork(jsig+6*nsig+100)=awork(jsig+6*nsig+100)+val2 - nn=1 - else - nn=2 - if(ratio_errors*data_ier >=tiny_r_kind)nn=3 - endif - - data_ikx = gps_allptr%type - ikx = nint(data_ikx) - pressure = gps_allptr%rdiag(6) - data_rinc = gps_allptr%rdiag(5)*scale -! Loop over pressure level groupings and obs to accumulate -! statistics as a function of observation type. - do k = 1,npres_print - if(pressure>ptop(k) .and. pressure<=pbot(k))then - ress=data_rinc - - bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count - bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ress ! (o-g) - bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ress*ress ! (o-g)**2 - bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2 ! penalty - bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty - - end if - end do - end if - - gps_allptr => gps_allptr%llpoint - -! End loop over observations - end do - -! End of loop over time bins - END DO - -! If requested, write information to diagnostic file - if(conv_diagsave .and. icnt > 0)then - nchar = 1 - write(7)'gps',nchar,nreal,icnt,mype,ioff - write(7)cdiag,sdiag - deallocate(cdiag,sdiag) - endif - - -! Destroy arrays holding gps data - call destroy_genstats_gps - -end subroutine genstats_gps -end module m_gpsStats diff --git a/src/get_nmmb_ensperts.f90 b/src/get_nmmb_ensperts.f90 deleted file mode 100644 index 466e9f13b..000000000 --- a/src/get_nmmb_ensperts.f90 +++ /dev/null @@ -1,267 +0,0 @@ -subroutine get_nmmb_ensperts - -!$$$ subprogram documentation block -! . . . . -! subprogram: get_nmmb_ensperts adaptation of get_gefs_ensperts_dualres -! prgmmr: kleist org: np22 date: 2010-01-05 -! -! abstract: read ensemble members, and construct ensemble perturbations, for use -! with hybrid ensemble option. -! -! program history log: -! 2011-07-01 carley - initial adaptation for NMMB (not yet dual-res compat.) -! 2011-09-19 carley - implement single precision bundle changes -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - use kinds, only: r_kind,i_kind,r_single - use gridmod, only: pt_ll,pdtop_ll,aeta2_ll,aeta1_ll - use hybrid_ensemble_parameters, only: en_perts,ps_bar,nelen - use constants,only: zero,one,one_tenth,ten - use mpimod, only: mpi_comm_world,ierror,mype - use hybrid_ensemble_parameters, only: n_ens,grd_ens,q_hyb_ens - use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d - use gsi_bundlemod, only: gsi_bundlecreate,gsi_bundleset,gsi_grid,gsi_bundle, & - gsi_bundlegetpointer,gsi_bundledestroy,gsi_gridcreate - implicit none - - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig):: u,v,tv,q,oz,qs,rh,tsen,prsl - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2):: z,ps,sst2 - real(r_kind),pointer,dimension(:,:,:):: x3 - real(r_single),pointer,dimension(:,:,:) :: w3 - real(r_kind),pointer,dimension(:,:):: x2 - real(r_single),pointer,dimension(:,:):: w2 - type(gsi_bundle):: en_bar - type(gsi_grid) :: grid_ens - real(r_kind) bar_norm,sig_norm - - integer(i_kind) istatus,i,ic2,ic3,j,k,n,iderivative - character(70) filename - logical ice - - call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) - call gsi_bundlecreate(en_bar,grid_ens,'ensemble',istatus,names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)' get_nmmb_ensperts: trouble creating en_bar bundle' - call stop2(999) - endif - - do n=1,n_ens - en_perts(n,1)%valuesr4=zero - end do - - en_bar%values=zero - sst2=zero ! for now, sst not used in ensemble perturbations, so if sst array is called for - ! then sst part of en_perts will be zero when sst2=zero - - do n=1,n_ens - write(filename,100) n !make the filename -100 format('nmmb_ens_mem',i3.3) - - - if (mype==0)write(6,*) 'CALL GENERAL_READ_NMMB FOR ENS FILE : ',filename - call general_read_nmmb(grd_ens,filename,mype,z,ps,u,v,tv,tsen,q,oz) - -! For regional application (NMMB) use the the u,v option (i.e. uv_hyb_ens) -! Compute RH -! get 3d pressure at layer midpoints -! using code adapted from subroutine load_prsges for nmmb -! (in guess_grids.F90) - - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prsl(i,j,k)=one_tenth* & - (aeta1_ll(k)*pdtop_ll + & - aeta2_ll(k)*(ten*ps(i,j)-pdtop_ll-pt_ll) + & - pt_ll) - end do - end do - end do - - if (.not.q_hyb_ens) then - ice=.true. - iderivative=0 - call genqsat(qs,tsen(1,1,1),prsl(1,1,1),grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,ice,iderivative) - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - rh(i,j,k) = q(i,j,k)/qs(i,j,k) - end do - end do - end do - end if - - do ic3=1,nc3d - - call gsi_bundlegetpointer(en_perts(n,1),trim(cvars3d(ic3)),w3,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for ensemble member ',n,' in get_nmmb_ensperts' - call stop2(999) - end if - call gsi_bundlegetpointer(en_bar,trim(cvars3d(ic3)),x3,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for en_bar in get_nmmb_ensperts' - call stop2(999) - end if - - select case (trim(cvars3d(ic3))) - - case('sf','SF') - - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - w3(i,j,k) = u(i,j,k) - x3(i,j,k)=x3(i,j,k)+u(i,j,k) - end do - end do - end do - - case('vp','VP') - - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - w3(i,j,k) = v(i,j,k) - x3(i,j,k)=x3(i,j,k)+v(i,j,k) - end do - end do - end do - - case('t','T') - - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - w3(i,j,k) = tv(i,j,k) - x3(i,j,k)=x3(i,j,k)+tv(i,j,k) - end do - end do - end do - - case('q','Q') - if (.not.q_hyb_ens) then ! use RH - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - w3(i,j,k) = rh(i,j,k) - x3(i,j,k)=x3(i,j,k)+rh(i,j,k) - end do - end do - end do - else ! use Q - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - w3(i,j,k) = q(i,j,k) - x3(i,j,k)=x3(i,j,k)+q(i,j,k) - end do - end do - end do - end if - - case('oz','OZ') - - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - w3(i,j,k) = oz(i,j,k) - x3(i,j,k)=x3(i,j,k)+oz(i,j,k) - end do - end do - end do - - end select - end do - - do ic2=1,nc2d - - call gsi_bundlegetpointer(en_perts(n,1),trim(cvars2d(ic2)),w2,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for ensemble member ',n, ' in get_nmmb_ensperts' - call stop2(999) - end if - call gsi_bundlegetpointer(en_bar,trim(cvars2d(ic2)),x2,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar in get_nmmb_ensperts' - call stop2(999) - end if - - select case (trim(cvars2d(ic2))) - - case('ps','PS') - - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - w2(i,j) = ps(i,j) - x2(i,j)=x2(i,j)+ps(i,j) - end do - end do - - case('sst','SST') - - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - w2(i,j) = sst2(i,j) - x2(i,j)=x2(i,j)+sst2(i,j) - end do - end do - - end select - end do - end do ! end do over ensemble - -! Convert to mean - bar_norm = one/float(n_ens) - en_bar%values=en_bar%values*bar_norm - -! Copy pbar to module array. ps_bar may be needed for vertical localization -! in terms of scale heights/normalized p/p - do ic2=1,nc2d - - if(trim(cvars2d(ic2)) == 'ps'.or.trim(cvars2d(ic2)) == 'PS') then - - call gsi_bundlegetpointer(en_bar,trim(cvars2d(ic2)),x2,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar in get_nmmb_ensperts' - call stop2(999) - end if - - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - ps_bar(i,j,1)=x2(i,j) - end do - end do - exit - end if - end do - - call mpi_barrier(mpi_comm_world,ierror) - -! Convert ensemble members to perturbations - sig_norm=sqrt(one/max(one,n_ens-one)) - - do n=1,n_ens - do i=1,nelen - en_perts(n,1)%valuesr4(i)=(en_perts(n,1)%valuesr4(i)-en_bar%values(i))*sig_norm - end do - end do - - call gsi_bundledestroy(en_bar,istatus) - if(istatus/=0) then - write(6,*)' in get_nmmb_ensperts: trouble destroying en_bar bundle in get_nmmb_ensperts' - call stop2(999) - endif - - if (mype==0)write(6,*) 'get_nmmb_ensperts DONE' - return - -end subroutine get_nmmb_ensperts diff --git a/src/gsi/CMakeLists.txt b/src/gsi/CMakeLists.txt new file mode 100644 index 000000000..92ac4bea7 --- /dev/null +++ b/src/gsi/CMakeLists.txt @@ -0,0 +1,154 @@ +cmake_minimum_required(VERSION 2.8) +# need to set CMP0046 when using add_dependencies with cmake version 3.6.2 + if(crayComp) + cmake_policy(SET CMP0046 NEW) + endif() + set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/cmake/Modules/") +# get a list of all the fortran source files + file(GLOB GSIFORT_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90 ) +# get a list of all the c source files + file(GLOB GSI_C_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*c ) +# get a list of all cplr files + file(GLOB CLASS_SRC ${CMAKE_CURRENT_SOURCE_DIR}/class*90 ) +# create a list of all corresponding stub files + string(REGEX REPLACE "class" "stub" STUB_SRC "${CLASS_SRC}") +# create a list of all corresponding class files + string(REGEX REPLACE "class" "cplr" CPLR_SRC "${CLASS_SRC}") + +# GSIMAIN_SRC is a list of Fortram main(s), to be used to define GSIEXEC, +# and to be excluded from GSI libraries. + set(GSIMAIN_SRC + ${CMAKE_CURRENT_SOURCE_DIR}/gsimain.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/gsimod.F90 + ) + +# GSIUTIL_SRC is a list of all Fortran modules as *base level* utilities. +# This list can be extended to include any module, which depends (USEs) +# only on module(s) already included in this list, in one of CORE_LIBRARIES, +# or in one of system libraries. Any module dynamically depending on external +# libraries through configuration, such as WRF, NCDIAG, etc. should not be +# included. + + set(GSIUTIL_SRC + ${CMAKE_CURRENT_SOURCE_DIR}/mpeu_util.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/mpimod.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/mpeu_mpif.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/kinds.F90 + ) + +# GSIFORT_SRC is a list of all Fortran modules for GSI core implementations, +# after all configuration dependent code (some stub and cplr), base level +# utilities, the main are removed from the rest of source files + +# Remove CLASS_SRC list related STUB_SRC and CPLR_SRC, as configurable +# grid components + list( REMOVE_ITEM GSIFORT_SRC + ${STUB_SRC} + ${CPLR_SRC} + ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_REGIONAL.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_GFS.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/stub_nstmod.f90 + ${GSIUTIL_SRC} + ${GSIMAIN_SRC} + ) + +# remove NCDIAG, if it is a component built somewhere else. + if( BUILD_NCDIAG ) + list( REMOVE_ITEM GSIFORT_SRC "${CMAKE_CURRENT_SOURCE_DIR}/nc_diag_read_mod.f90" ) + list( REMOVE_ITEM GSIFORT_SRC "${CMAKE_CURRENT_SOURCE_DIR}/nc_diag_write_mod.f90" ) + endif( BUILD_NCDIAG ) + +# The specific regional/WRF source files + if(USE_WRF) + list( APPEND GSIFORT_SRC + ${CPLR_SRC} + ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_REGIONAL.F90 + ) + endif() + +# The specific global source files + if(BUILD_GLOBAL) + list( APPEND GSIFORT_SRC + ${STUB_SRC} + ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_GFS.F90 + ) + endif(BUILD_GLOBAL) + +# set up the compiler flags + set_source_files_properties( ${GSIMAIN_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) + set_source_files_properties( ${GSIFORT_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) + set_source_files_properties( ${GSIUTIL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) + set_source_files_properties( ${GSI_C_SRC} PROPERTIES COMPILE_FLAGS ${GSI_CFLAGS} ) + + set( GSICORE_SRC ${GSIFORT_SRC} ${GSI_C_SRC} ) + +# Add the include paths + message("MPI include PATH ${MPI_Fortran_INCLUDE_PATH}") + include_directories( ${CORE_INCS} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} "./" ) + +#define the name used for GSI Shared lib and add it with properties and include dirs + set(GSISHAREDLIB "gsilib_shrd${debug_suffix}" CACHE INTERNAL "") + add_library(${GSISHAREDLIB} STATIC ${GSIUTIL_SRC} ) + set_target_properties(${GSISHAREDLIB} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") + target_include_directories(${GSISHAREDLIB} PUBLIC "${PROJECT_BINARY_DIR}/include") + +# Definte the base name of the executable + if(BUILD_PRODUCTION) + set(GSIBASE "global_gsi.x") + else() + if(BUILD_GLOBAL) + set(GSIBASE "gsi_global") + else() + set(GSIBASE "gsi") + endif() + set(GSISUFFIX ".x" CACHE INTERNAL "Executable suffix") + endif() + +# Set names, libs, and properties depending on if we are building with WRF or not + if(USE_WRF) + set(GSIEXEC "${GSIBASE}${debug_suffix}${GSISUFFIX}" CACHE INTERNAL "GSI Executable Name") + add_executable(${GSIEXEC} ${CMAKE_CURRENT_SOURCE_DIR}/gsimain.f90 ${CMAKE_CURRENT_SOURCE_DIR}/gsimod.F90 ) + set(GSILIB "gsilib_wrf${debug_suffix}" CACHE INTERNAL "") + add_library(${GSILIB} STATIC ${GSICORE_SRC} ) + set_target_properties(${GSILIB} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") + target_include_directories(${GSILIB} PUBLIC "${PROJECT_BINARY_DIR}/include") + set_target_properties(${GSIEXEC} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") + target_link_libraries( ${GSILIB} ${GSISHAREDLIB} ${wrflib} ) + endif() + + if(BUILD_GLOBAL) + set(GSIEXEC "${GSIBASE}${debug_suffix}${GSISUFFIX}" CACHE INTERNAL "GSI Executable Name") + add_executable( ${GSIEXEC} ${GSIMAIN_SRC} ) + set(GSILIB "gsilib_global${debug_suffix}" CACHE INTERNAL "") + set(WRF_LIBRARIES "") + add_library(${GSILIB} STATIC ${GSICORE_SRC} ) + target_link_libraries( ${GSILIB} ${GSISHAREDLIB} ) + add_dependencies(${GSILIB} ${GSISHAREDLIB} ) + target_link_libraries( ${GSISHAREDLIB} ${CORE_LIBRARIES}) + set_target_properties( ${GSILIB} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") + target_include_directories( ${GSILIB} PUBLIC "${PROJECT_BINARY_DIR}/include") + set_target_properties(${GSIEXEC} PROPERTIES Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") + endif() + + if( BUILD_NCDIAG ) + add_dependencies(${GSILIB} ${NCDIAG_LIBRARIES} ) + endif( BUILD_NCDIAG ) + add_dependencies(${GSILIB} ${GSISHAREDLIB} ) + +# Add dependencies if we are building the core libs or are just using pre-built libs + if(CORE_BUILT) + add_dependencies(${GSILIB} ${GSISHAREDLIB} ${CORE_BUILT} ) + add_dependencies(${GSISHAREDLIB} ${bacio} ${CORE_BUILT} ) + add_dependencies(${GSIEXEC} ${GSISHAREDLIB} ${GSILIB} ${CORE_BUILT} ) + else() + add_dependencies(${GSIEXEC} ${GSISHAREDLIB} ${GSILIB} ) + endif() +# Specify all the libraries to be linked into the executable + target_link_libraries(${GSIEXEC} ${GSISHAREDLIB} ${GSILIB} ${GSISHAREDLIB} ${WRF_LIBRARIES} + ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_LIBRARIES} + ${LAPACK_LIBRARIES} -L./ ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${CORE_LIBRARIES} ${CORE_BUILT} + ${GSI_LDFLAGS} ${NCDIAG_LIBRARIES} ${GSDCLOUD_LIBRARY} ${ZLIB_LIBRARIES} ${wrflib} ${EXTRA_LINKER_FLAGS} ) + install(TARGETS ${GSIEXEC} + RUNTIME DESTINATION ${CMAKE_INSTALL_PREFIX}/bin + LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib + ARCHIVE DESTINATION ${CMAKE_INSTALL_PREFIX}/lib/static) diff --git a/src/Nst_Var_ESMFMod.f90 b/src/gsi/Nst_Var_ESMFMod.f90 similarity index 100% rename from src/Nst_Var_ESMFMod.f90 rename to src/gsi/Nst_Var_ESMFMod.f90 diff --git a/src/gsi/abstract_ensmod.f90 b/src/gsi/abstract_ensmod.f90 new file mode 100644 index 000000000..2bfef38fe --- /dev/null +++ b/src/gsi/abstract_ensmod.f90 @@ -0,0 +1,134 @@ +module abstract_ensmod +!$$$ subprogram documentation block +! . . . . +! subprogram: abstract_ensmod handles abstract ensemble +! prgmmr: mpotts org: emc/ncep date: 2016-06-30 +! +! abstract: Handle abstract ensemble (full fields and perturbations) +! +! program history log: +! 2016-07-20 mpotts - introduced as class_gfs_ensmod.f90 +! 2019-06-30 todling - revised as abstract layer - no GFS referencing +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + implicit none + private + public :: abstractEnsemble + public :: abstractEnsemble_typename + + interface abstractEnsemble_typename; module procedure typename_; end interface + + type, abstract :: abstractEnsemble + private + contains + procedure(mytype ), nopass, deferred :: mytype + procedure(create_sub2grid_info ), nopass, deferred :: create_sub2grid_info + procedure(destroy_sub2grid_info), nopass, deferred :: destroy_sub2grid_info + procedure(get_user_ens ), deferred :: get_user_ens + procedure(get_user_Nens ), deferred :: get_user_Nens + procedure(put_user_ens ), deferred :: put_user_ens + procedure(non_gaussian_ens_grid), deferred :: non_gaussian_ens_grid + end type abstractEnsemble + + abstract interface + function mytype() result(type_) + implicit none + character(:),allocatable:: type_ + end function mytype + end interface + + abstract interface + subroutine create_sub2grid_info(s2gi,nsig,npe,s2gi_ref) + use kinds, only: i_kind + use general_sub2grid_mod, only: sub2grid_info + import abstractEnsemble + implicit none + type(sub2grid_info), intent(out ) :: s2gi + integer(i_kind ), intent(in ) :: nsig + integer(i_kind ), intent(in ) :: npe + type(sub2grid_info), intent(in ) :: s2gi_ref + end subroutine create_sub2grid_info + end interface + + abstract interface + subroutine destroy_sub2grid_info(s2gi) + use general_sub2grid_mod, only: sub2grid_info + import abstractEnsemble + implicit none + type(sub2grid_info), intent(inout) :: s2gi + end subroutine destroy_sub2grid_info + end interface + + abstract interface + subroutine get_user_ens(this,grd,member,ntindex,atm_bundle,iret) + use kinds, only: i_kind + use general_sub2grid_mod, only: sub2grid_info + use gsi_bundlemod, only: gsi_bundle + import abstractEnsemble + implicit none + class(abstractEnsemble), intent(inout) :: this + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(in ) :: member + integer(i_kind), intent(in ) :: ntindex + type(gsi_bundle), intent(inout) :: atm_bundle + integer(i_kind), intent( out) :: iret + end subroutine get_user_ens + end interface + + abstract interface + subroutine get_user_Nens(this,grd,members,ntindex,atm_bundle,iret) + use kinds, only: i_kind + use general_sub2grid_mod, only: sub2grid_info + use gsi_bundlemod, only: gsi_bundle + import abstractEnsemble + implicit none + class(abstractEnsemble), intent(inout) :: this + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(in ) :: members + integer(i_kind), intent(in ) :: ntindex + type(gsi_bundle), intent(inout) :: atm_bundle(:) + integer(i_kind), intent( out) :: iret + end subroutine get_user_Nens + end interface + + abstract interface + subroutine put_user_ens(this,grd,member,ntindex,pert,iret) + use kinds, only: i_kind + use gsi_bundlemod, only: gsi_bundle + use general_sub2grid_mod, only: sub2grid_info + import abstractEnsemble + implicit none + class(abstractEnsemble), intent(inout) :: this + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(in ) :: member + integer(i_kind), intent(in ) :: ntindex + type(gsi_bundle), intent(inout) :: pert + integer(i_kind), intent( out) :: iret + end subroutine put_user_ens + end interface + + abstract interface + subroutine non_gaussian_ens_grid(this,elats,elons) + use kinds, only: r_kind + import abstractEnsemble + implicit none + class(abstractEnsemble), intent(inout) :: this + real(r_kind), intent(out) :: elats(:),elons(:) + end subroutine non_gaussian_ens_grid + end interface + +contains + +function typename_() result(typename) +!-- Return the type name. + implicit none + character(len=:),allocatable:: typename + typename="[abstractEnsemble]" +end function typename_ + +end module abstract_ensmod diff --git a/src/adjtest.f90 b/src/gsi/adjtest.f90 similarity index 100% rename from src/adjtest.f90 rename to src/gsi/adjtest.f90 diff --git a/src/adjtest_obs.f90 b/src/gsi/adjtest_obs.f90 similarity index 100% rename from src/adjtest_obs.f90 rename to src/gsi/adjtest_obs.f90 diff --git a/src/adjust_cloudobs_mod.f90 b/src/gsi/adjust_cloudobs_mod.f90 similarity index 100% rename from src/adjust_cloudobs_mod.f90 rename to src/gsi/adjust_cloudobs_mod.f90 diff --git a/src/gsi/aero_guess_at_obs_locations.f90 b/src/gsi/aero_guess_at_obs_locations.f90 new file mode 100644 index 000000000..ffb74e0e2 --- /dev/null +++ b/src/gsi/aero_guess_at_obs_locations.f90 @@ -0,0 +1,128 @@ +SUBROUTINE aero_guess_at_obs_locations(& + &obstime,data_s,nchanl,nreal,nsig,n_aerosols,& + &aero,aero_names) + ! from M. Pagowski, added to this branch by C. Martin - 2/21/2019 + + USE kinds, ONLY: r_kind,i_kind + USE gsi_bundlemod, ONLY: gsi_bundlegetpointer + USE gsi_chemguess_mod, ONLY: gsi_chemguess_bundle + USE gsi_chemguess_mod, ONLY: gsi_chemguess_get + USE gridmod, ONLY: istart,jstart,nlon,nlat,lon1 + USE constants, ONLY: max_varname_length, zero, one + USE mpimod, ONLY: mype + USE guess_grids, ONLY: hrdifsig,nfldsig + + IMPLICIT NONE + +! Declare passed variables + + INTEGER(i_kind), INTENT(in ) :: nchanl,nreal,nsig, n_aerosols + REAL(r_kind), INTENT(in ) :: obstime + + REAL(r_kind),DIMENSION(nreal+nchanl), INTENT(in ) ::data_s + CHARACTER(len=max_varname_length), DIMENSION(n_aerosols), INTENT(in ) :: aero_names + + REAL(r_kind),DIMENSION(nsig,n_aerosols), INTENT( out) :: aero + + + INTEGER(i_kind):: j,k,m1,ix,ix1,ixp,iy,iy1,iyp,ii + INTEGER(i_kind):: itsig,itsigp + + REAL(r_kind):: w00,w01,w10,w11,dx,dy + REAL(r_kind):: delx,dely,delx1,dely1,dtsig,dtsigp + + INTEGER(i_kind):: ilon, ilat, ier + + REAL(r_kind),POINTER,DIMENSION(:,:,:)::aeroges_itsig =>NULL() + REAL(r_kind),POINTER,DIMENSION(:,:,:)::aeroges_itsigp=>NULL() + + m1=mype+1 + + ilon = 3 ! index of grid relative obs location (x) + ilat = 4 ! index of grid relative obs location (y) + + dx = data_s(ilat) ! grid relative latitude + dy = data_s(ilon) ! grid relative longitude + +! Set spatial interpolation indices and weights + ix1=dx + ix1=MAX(1,MIN(ix1,nlat)) + delx=dx-ix1 + delx=MAX(zero,MIN(delx,one)) + ix=ix1-istart(m1)+2 + ixp=ix+1 + IF(ix1==nlat) THEN + ixp=ix + END IF + delx1=one-delx + + iy1=dy + dely=dy-iy1 + iy=iy1-jstart(m1)+2 + IF(iy<1) THEN + iy1=iy1+nlon + iy=iy1-jstart(m1)+2 + END IF + IF(iy>lon1+1) THEN + iy1=iy1-nlon + iy=iy1-jstart(m1)+2 + END IF + iyp=iy+1 + dely1=one-dely + + w00=delx1*dely1; w10=delx*dely1; w01=delx1*dely; w11=delx*dely + + +! Get time interpolation factors for sigma files + IF(obstime > hrdifsig(1) .AND. obstime < hrdifsig(nfldsig))THEN + DO j=1,nfldsig-1 + IF(obstime > hrdifsig(j) .AND. obstime <= hrdifsig(j+1))THEN + itsig=j + itsigp=j+1 + dtsig=((hrdifsig(j+1)-obstime)/(hrdifsig(j+1)-hrdifsig(j))) + END IF + END DO + ELSE IF(obstime <=hrdifsig(1))THEN + itsig=1 + itsigp=1 + dtsig=one + ELSE + itsig=nfldsig + itsigp=nfldsig + dtsig=one + END IF + dtsigp=one-dtsig + + ier=0 + + IF(n_aerosols>0)THEN + IF(SIZE(gsi_chemguess_bundle)==1) THEN + DO ii=1,n_aerosols + CALL gsi_bundlegetpointer(gsi_chemguess_bundle(1),aero_names(ii),aeroges_itsig ,ier) + DO k=1,nsig + aero(k,ii) =(aeroges_itsig(ix ,iy ,k)*w00+ & + aeroges_itsig(ixp,iy ,k)*w10+ & + aeroges_itsig(ix ,iyp,k)*w01+ & + aeroges_itsig(ixp,iyp,k)*w11) + END DO + ENDDO + ELSE + DO ii=1,n_aerosols + CALL gsi_bundlegetpointer(gsi_chemguess_bundle(itsig ),aero_names(ii),aeroges_itsig ,ier) + CALL gsi_bundlegetpointer(gsi_chemguess_bundle(itsigp),aero_names(ii),aeroges_itsigp,ier) + DO k=1,nsig + aero(k,ii) =(aeroges_itsig (ix ,iy ,k)*w00+ & + aeroges_itsig (ixp,iy ,k)*w10+ & + aeroges_itsig (ix ,iyp,k)*w01+ & + aeroges_itsig (ixp,iyp,k)*w11)*dtsig + & + (aeroges_itsigp(ix ,iy ,k)*w00+ & + aeroges_itsigp(ixp,iy ,k)*w10+ & + aeroges_itsigp(ix ,iyp,k)*w01+ & + aeroges_itsigp(ixp,iyp,k)*w11)*dtsigp + END DO + ENDDO + ENDIF + + ENDIF + +END SUBROUTINE aero_guess_at_obs_locations diff --git a/src/aeroinfo.f90 b/src/gsi/aeroinfo.f90 similarity index 100% rename from src/aeroinfo.f90 rename to src/gsi/aeroinfo.f90 diff --git a/src/aircraftinfo.f90 b/src/gsi/aircraftinfo.f90 similarity index 93% rename from src/aircraftinfo.f90 rename to src/gsi/aircraftinfo.f90 index 986935cfe..b84455f47 100644 --- a/src/aircraftinfo.f90 +++ b/src/gsi/aircraftinfo.f90 @@ -50,6 +50,7 @@ module aircraftinfo public :: upd_aircraft public :: nsort,itail_sort,idx_sort public :: hdist_aircraft + logical :: aircraft_t_bc ! logical to turn off or on the aircraft temperature bias correction logical :: aircraft_t_bc_pof ! logical to turn off or on the aircraft temperature bias correction with pof logical :: aircraft_t_bc_ext ! logical to turn off or on the externally supplied aircraft bias correction @@ -76,8 +77,7 @@ module aircraftinfo real(r_kind),allocatable,dimension(:,:):: varA_t real(r_quad),allocatable,dimension(:,:):: ostats_t real(r_quad),allocatable,dimension(:,:):: rstats_t - - + contains @@ -122,7 +122,7 @@ subroutine init_aircraft upd_pred_t=one hdist_aircraft=60000.0_r_kind - + end subroutine init_aircraft @@ -420,42 +420,43 @@ subroutine indexc40(n,carrin,indx) l = n/2 + 1 ir = n - 33 continue - if(l.gt.1) then - l = l - 1 - indxt = indx(l) - cc = carrin(indxt) - else - indxt = indx(ir) - cc = carrin(indxt) - indx(ir) = indx(1) - ir = ir - 1 - if(ir.eq.1) then - indx(1) = indxt - return + do + if(l.gt.1) then + l = l - 1 + indxt = indx(l) + cc = carrin(indxt) + else + indxt = indx(ir) + cc = carrin(indxt) + indx(ir) = indx(1) + ir = ir - 1 + if(ir.eq.1) then + indx(1) = indxt + return + endif endif - endif - - i = l - j = l * 2 - - 30 continue - if(j.le.ir) then - if(j.lt.ir) then - if(carrin(indx(j)).lt.carrin(indx(j+1))) j = j + 1 - endif - if(cc.lt.carrin(indx(j))) then - indx(i) = indx(j) - i = j - j = j + i - else - j = ir + 1 - endif - endif - - if(j.le.ir) go to 30 - indx(i) = indxt - go to 33 + + i = l + j = l * 2 + + do + if(j.le.ir) then + if(j.lt.ir) then + if(carrin(indx(j)).lt.carrin(indx(j+1))) j = j + 1 + endif + if(cc.lt.carrin(indx(j))) then + indx(i) = indx(j) + i = j + j = j + i + else + j = ir + 1 + endif + endif + + if(j > ir) exit + end do + indx(i) = indxt + end do end subroutine indexc40 diff --git a/src/aircraftobsqc.f90 b/src/gsi/aircraftobsqc.f90 similarity index 88% rename from src/aircraftobsqc.f90 rename to src/gsi/aircraftobsqc.f90 index d366fd174..0c1ed0234 100644 --- a/src/aircraftobsqc.f90 +++ b/src/gsi/aircraftobsqc.f90 @@ -92,12 +92,12 @@ subroutine init_aircraft_rjlists ! wind,temperature, and humidity if it exists inquire(file='current_bad_aircraft',exist=listexist_aircraft) - if(listexist_aircraft) then - open (aircraft_unit,file='current_bad_aircraft',form='formatted') - do m=1,16 - read(aircraft_unit,*,end=141) - enddo -140 continue + if(.not. listexist_aircraft)return + open (aircraft_unit,file='current_bad_aircraft',form='formatted') + do m=1,16 + read(aircraft_unit,*,end=141) + enddo + read_loop:do read(aircraft_unit,'(a30)',end=141) cstring if(cstring(11:11) == 'T') then ntrjs_aircraft=ntrjs_aircraft+1 @@ -114,11 +114,14 @@ subroutine init_aircraft_rjlists q_aircraft_rjlist(nqrjs_aircraft,1)=cstring(1:8) q_aircraft_rjlist(nqrjs_aircraft,2)=cstring(22:29) endif - goto 140 -141 continue - print*,'aircraft_rejectlist: T, W, R=', ntrjs_aircraft,nwrjs_aircraft,nqrjs_aircraft - endif - close(aircraft_unit) + if(max(ntrjs_aircraft,nqrjs_aircraft,nqrjs_aircraft) == nmax)then + print*, 'aircraft_rjlist reached maximum ', nmax, ' stop reading list -- increase nmax' + exit read_loop + end if + end do read_loop +141 close(aircraft_unit) + print*,'aircraft_rejectlist: T, W, R=', ntrjs_aircraft,nwrjs_aircraft,nqrjs_aircraft + return ! end subroutine init_aircraft_rjlists @@ -129,10 +132,10 @@ subroutine get_aircraft_usagerj(kx,obstype,c_station_id,usage_rj) ! prgmmr: ! ! abstract: determine the usage value of read_prepbufr for aircraft obs. the following -! is done: (i) if incoming usage value is >=100. then do nothing, since +! is done: (i) if incoming usage value is >=6 then do nothing, since ! read_prepbufr has already flagged this ob and assigned a specific usage -! value to it. (ii) use usage=500. for temperature, moisture, or surface pressure -! obs which are found in the rejectlist. (iii) +! value to it. (ii) use usage=450 for temperature, moisture, or surface pressure +! obs which are found in the rejectlist. ! ! program history log: ! 2010-10-28 Hu @@ -161,7 +164,6 @@ subroutine get_aircraft_usagerj(kx,obstype,c_station_id,usage_rj) ! Declare local variables integer(i_kind) m,nlen character(8) ch8,ch8MDCRS - real(r_kind) usage_rj0 ! Declare local parameters real(r_kind),parameter:: r6 = 6.0_r_kind @@ -169,8 +171,6 @@ subroutine get_aircraft_usagerj(kx,obstype,c_station_id,usage_rj) if (usage_rj >= r6) return - usage_rj0=usage_rj - if (kx<190) then !<==mass obs if(obstype=='t' .and. (ntrjs_aircraft > 0) ) then @@ -210,6 +210,7 @@ subroutine get_aircraft_usagerj(kx,obstype,c_station_id,usage_rj) endif end if + return end subroutine get_aircraft_usagerj subroutine destroy_aircraft_rjlists @@ -238,6 +239,7 @@ subroutine destroy_aircraft_rjlists deallocate(t_aircraft_rjlist) deallocate(q_aircraft_rjlist) + return end subroutine destroy_aircraft_rjlists end module aircraftobsqc diff --git a/src/anberror.f90 b/src/gsi/anberror.f90 similarity index 100% rename from src/anberror.f90 rename to src/gsi/anberror.f90 diff --git a/src/anbkerror.f90 b/src/gsi/anbkerror.f90 similarity index 100% rename from src/anbkerror.f90 rename to src/gsi/anbkerror.f90 diff --git a/src/aniso_ens_util.f90 b/src/gsi/aniso_ens_util.f90 similarity index 98% rename from src/aniso_ens_util.f90 rename to src/gsi/aniso_ens_util.f90 index 62d3182ec..249b01130 100644 --- a/src/aniso_ens_util.f90 +++ b/src/gsi/aniso_ens_util.f90 @@ -156,13 +156,12 @@ subroutine ens_uv_to_psichi(u,v,truewind) !========================================================================== n0=max(nlat,nlon) ijext=4 -100 continue - n1=n0+2*ijext - call check_32primes(n1,lprime) - if (.not.lprime) then - ijext=ijext+1 - goto 100 - endif + prime_loop: do + n1=n0+2*ijext + call check_32primes(n1,lprime) + if (lprime) exit prime_loop + ijext=ijext+1 + end do prime_loop nxs=ijext+1 nxe=ijext+nlon @@ -218,6 +217,7 @@ subroutine ens_uv_to_psichi(u,v,truewind) deallocate(dxy) deallocate(dxyb) deallocate(tdxyb) + return end subroutine ens_uv_to_psichi ! -------------------------------------------------------------- !======================================================================= @@ -259,6 +259,7 @@ subroutine set_grdparm212(iy,jx,jxp,alat1,elon1,ds,elonv,alatan) elon1=226.541_r_kind elonv=265.000_r_kind alatan=25.000_r_kind + return end subroutine set_grdparm212 !======================================================================= !======================================================================= @@ -502,17 +503,16 @@ subroutine ens_intpcoeffs_reg(ngrds,igbox,iref,jref,igbox0f,ensmask,enscoeff,gbl ilateral=2 jlateral=2 -100 continue - ilower=i1+ilateral - iupper=i2-ilateral - jleft=j1+jlateral - jright=j2-jlateral - ltest=any(ensmask(ilower:iupper,jleft:jright,kg)>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> !simple diagnostic output -!allocate(slab00(nlat,nlon),slab11(nlat,nlon)) -!do n=1,14 -! slab00=zero_single -! slab11=zero_single -! do j=2,lon2-1 -! jglob=j+jstart(mm1)-2 -! do i=2,lat2-1 -! iglob=i+istart(mm1)-2 -! if (n<=4) slab00(iglob,jglob)=bckg0f_stdz(i,j,1,N) -! if (n>4 .and. n<13) slab00(iglob,jglob)=bckg0f_stdp(i,j,1,N-4) -! if (n==13) slab00(iglob,jglob)=z0f_std(i,j,1) -! if (n==14) slab00(iglob,jglob)=valleys0f(i,j,1) -! end do -! end do -! call mpi_reduce(slab00,slab11,nlat*nlon,mpi_real4,mpi_sum,0,mpi_comm_world,ierror) -! if (mype==0) print*,'3D-n:slab11,min,max=',n,minval(slab11),maxval(slab11) -! if (mype==0) then -! write(clun,'(i2.2)') n -! open (54,file='FLD_STD_'//clun//'.dat',form='unformatted') -! write(54) slab11 -! close(54) -! endif -!enddo -!deallocate(slab00,slab11) + if (.not.turnoff_all_stdmodels .and. writeout_stdmodel_diagnostics) then + allocate(slab00(nlat,nlon),slab11(nlat,nlon)) + + do n=1,nrf3 + ivar=nrf3_loc(n) + chvarname=fvarname(ivar) + lstdmodel0=lstdmodel(chvarname) + if (.not.lstdmodel0) cycle + + slab00=zero_single + slab11=zero_single + do j=2,lon2-1 + jglob=j+jstart(mm1)-2 + do i=2,lat2-1 + iglob=i+istart(mm1)-2 + slab00(iglob,jglob)=bckg_stdz0f(i,j,1,n) + end do + end do + call mpi_reduce(slab00,slab11,nlat*nlon,mpi_real4,mpi_sum,0,mpi_comm_world,ierror) + if (mype==0) print*,'3D-n:chvarname,slab11,min,max=',n,trim(chvarname),minval(slab11),maxval(slab11) + if (mype==0) then + open (54,file='FLD_STD.dat_'//trim(chvarname),form='unformatted') + write(54) slab11 + close(54) + endif + enddo + + do n=1,nrf2 + ivar=nrf2_loc(n) + chvarname=fvarname(ivar) + lstdmodel0=lstdmodel(chvarname) + if (.not.lstdmodel0) cycle + + slab00=zero_single + slab11=zero_single + do j=2,lon2-1 + jglob=j+jstart(mm1)-2 + do i=2,lat2-1 + iglob=i+istart(mm1)-2 + slab00(iglob,jglob)=bckg_stdp0f(i,j,1,n) + end do + end do + call mpi_reduce(slab00,slab11,nlat*nlon,mpi_real4,mpi_sum,0,mpi_comm_world,ierror) + if (mype==0) print*,'2D-n:chvarname,slab11,min,max=',n,trim(chvarname),minval(slab11),maxval(slab11) + if (mype==0) then + open (54,file='FLD_STD.dat_'//trim(chvarname),form='unformatted') + write(54) slab11 + close(54) + endif + enddo + + do n=1,mvars + ivar=nmotl_loc(n) + lstdmodel0=lstdmodel(chvarname) + if (.not.lstdmodel0) cycle + + nn=nrf2+n + + slab00=zero_single + slab11=zero_single + do j=2,lon2-1 + jglob=j+jstart(mm1)-2 + do i=2,lat2-1 + iglob=i+istart(mm1)-2 + slab00(iglob,jglob)=bckg_stdp0f(i,j,1,nn) + end do + end do + call mpi_reduce(slab00,slab11,nlat*nlon,mpi_real4,mpi_sum,0,mpi_comm_world,ierror) + if (mype==0) print*,'2D-n:chvarname,slab11,min,max=',n,trim(chvarname),minval(slab11),maxval(slab11) + if (mype==0) then + open (54,file='FLD_STD.dat_'//trim(chvarname),form='unformatted') + write(54) slab11 + close(54) + endif + enddo + + chvarname='terrain' + slab00=zero_single + slab11=zero_single + do j=2,lon2-1 + jglob=j+jstart(mm1)-2 + do i=2,lat2-1 + iglob=i+istart(mm1)-2 + slab00(iglob,jglob)=z0f_std(i,j,1) + end do + end do + call mpi_reduce(slab00,slab11,nlat*nlon,mpi_real4,mpi_sum,0,mpi_comm_world,ierror) + if (mype==0) print*,'2D-n:chvarname,slab11,min,max=',n,trim(chvarname),minval(slab11),maxval(slab11) + if (mype==0) then + open (54,file='FLD_STD.dat_'//trim(chvarname),form='unformatted') + write(54) slab11 + close(54) + endif + + chvarname='valleymap' + slab00=zero_single + slab11=zero_single + do j=2,lon2-1 + jglob=j+jstart(mm1)-2 + do i=2,lat2-1 + iglob=i+istart(mm1)-2 + slab00(iglob,jglob)=valleys0f(i,j,1) + end do + end do + call mpi_reduce(slab00,slab11,nlat*nlon,mpi_real4,mpi_sum,0,mpi_comm_world,ierror) + if (mype==0) print*,'2D-n:chvarname,slab11,min,max=',n,trim(chvarname),minval(slab11),maxval(slab11) + if (mype==0) then + open (54,file='FLD_STD.dat_'//trim(chvarname),form='unformatted') + write(54) slab11 + close(54) + endif + + deallocate(slab00,slab11) + endif !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> deallocate(region_dy4,region_dx4) @@ -5472,9 +5637,9 @@ subroutine get2berr_reg_subdomain_option(mype) deallocate(u0f,v0f,z0f,z0f2,z0f3) deallocate(vis0f,cldch0f,valleys0f) deallocate(z0f_std) - deallocate(bckg0f_stdz,bckg0f_stdp) - deallocate(bckg_stdmax_z,bckg_stdbump_z) - deallocate(bckg_stdmax_p,bckg_stdbump_p) + deallocate(bckg_stdz0f,bckg_stdp0f) + deallocate(bckg_stdmax_z,bckg_stdfact_z,bckg_valleyfact_z) + deallocate(bckg_stdmax_p,bckg_stdfact_p,bckg_valleyfact_p) deallocate(zsmooth4a,psg4a) deallocate(zsmooth4,psg4) deallocate(fltvals0) @@ -5578,7 +5743,7 @@ subroutine get_background_subdomain_option(mype) logical lstdmodel0 real(r_kind) :: fstdmax0 - logical fexist + logical fexist,gexist real(r_kind) flon,flat logical glerlarea @@ -5792,24 +5957,28 @@ subroutine get_background_subdomain_option(mype) endif allocate( z0f_std(lat2,lon2,nsig) ) - allocate( bckg0f_stdz(lat2,lon2,nsig,nrf3) ) - allocate( bckg0f_stdp(lat2,lon2,nsig,nvars-nrf3) ) + allocate( bckg_stdz0f(lat2,lon2,nsig,nrf3) ) + allocate( bckg_stdp0f(lat2,lon2,nsig,nvars-nrf3) ) allocate (bckg_stdmax_z(nrf3)) - allocate (bckg_stdbump_z(nrf3)) + allocate (bckg_stdfact_z(nrf3)) + allocate (bckg_valleyfact_z(nrf3)) allocate (bckg_stdmax_p(nvars-nrf3)) - allocate (bckg_stdbump_p(nvars-nrf3)) + allocate (bckg_stdfact_p(nvars-nrf3)) + allocate (bckg_valleyfact_p(nvars-nrf3)) allocate(slab0(ids:ide , jds:jde , 1:nsig)) allocate(slab1(ids:ide , jds:jde , 1:nsig)) z0f_std=sone - bckg0f_stdz=sone - bckg0f_stdp=sone - bckg_stdbump_z=one - bckg_stdmax_z=one - bckg_stdbump_p=one - bckg_stdmax_p=one + bckg_stdz0f=sone + bckg_stdp0f=sone + bckg_stdfact_z=zero + bckg_valleyfact_z=one + bckg_stdmax_z=huge(bckg_stdmax_z) + bckg_stdfact_p=zero + bckg_valleyfact_p=one + bckg_stdmax_p=huge(bckg_stdmax_p) do kk=kps,kpe! Looping through analysis variables @@ -5827,50 +5996,51 @@ subroutine get_background_subdomain_option(mype) if (trim(cvarstype(ivar))=='static3d') then do n=1,nrf3 if (nrf3_loc(n)==ivar) then - if (.not.stdmodel_z_based) then - - if (l_nostd) then - bckg0f_stdz(:,:,:,n) = 1._r_single - else - do k=1,nsig - do j=2,lon2-1 - jglob=j+jstart(mm1)-2 - if(jglob<1.or.jglob>nlona) cycle - do i=2,lat2-1 - iglob=i+istart(mm1)-2 - if(iglob<1.or.iglob>nlata) cycle - if (trim(chvarname)=='t') slab0 (iglob,jglob,k) = ges_tv_it (i,j,k)/(one+fv*ges_q_it(i,j,k)) - if (trim(chvarname)=='pseudorh') slab0 (iglob,jglob,k) = ges_q_it (i,j,k) - end do - end do - end do + if (lstdmodel0) then - call mpi_allreduce(slab0,slab1,(ide-ids+1)*(jde-jds+1)*(nsig-1+1),mpi_real4,mpi_sum,mpi_comm_world,ierror) - call get_fldstd(slab1,ids,ide,jds,jde,1,nsig,std_radius,npass_for_std,mype) + if (l_nostd) then + bckg_stdz0f(:,:,:,n) = 1._r_single + else + do k=1,nsig + do j=2,lon2-1 + jglob=j+jstart(mm1)-2 + if(jglob<1.or.jglob>nlona) cycle + do i=2,lat2-1 + iglob=i+istart(mm1)-2 + if(iglob<1.or.iglob>nlata) cycle + if (trim(chvarname)=='t') slab0 (iglob,jglob,k) = ges_tv_it (i,j,k)/(one+fv*ges_q_it(i,j,k)) + if (trim(chvarname)=='pseudorh') slab0 (iglob,jglob,k) = ges_q_it (i,j,k) + end do + end do + end do + + call mpi_allreduce(slab0,slab1,(ide-ids+1)*(jde-jds+1)*nsig,mpi_real4,mpi_sum,mpi_comm_world,ierror) + call get_fldstd(slab1,ids,ide,jds,jde,1,nsig,std_radius,npass_for_std,mype) + + do k=1,nsig + do j=1,lon2 + jglob=j+jstart(mm1)-2 + if(jglob<1.or.jglob>nlona) cycle + do i=1,lat2 + iglob=i+istart(mm1)-2 + if(iglob<1.or.iglob>nlata) cycle + bckg_stdz0f (i,j,k,n) = slab1 (iglob,jglob,k) + end do + end do + end do + end if - do k=1,nsig - do j=1,lon2 - jglob=j+jstart(mm1)-2 - if(jglob<1.or.jglob>nlona) cycle - do i=1,lat2 - iglob=i+istart(mm1)-2 - if(iglob<1.or.iglob>nlata) cycle - bckg0f_stdz (i,j,k,n) = slab1 (iglob,jglob,k) - end do - end do - end do - end if - end if !stdmodel_z_based condition - if (lstdmodel0) then - bckg_stdbump_z(n)=stdbump(chvarname) - fstdmax0=fstdmax(chvarname) - bckg_stdmax_z(n)=maxval(corz(:,kvar,n))*an_amp(1,ivar)*fstdmax0 - if (mype==0) print*,'chvarname=',trim(chvarname) - if (mype==0) print*,'kk,n,bckg_stdbump_z(n),bckg_stdmax_z(n)=',kk,n,bckg_stdbump_z(n),bckg_stdmax_z(n) - if (mype==0) print*,'kk,n,ivar,an_amp(1,ivar)=',kk,n,ivar,an_amp(1,ivar) - if (mype==0) print*,'kk,slab1,min,max=',kk,minval(slab1),maxval(slab1) - if (mype==0) print*,'=================================' - if (mype==0) print*,'=================================' + bckg_stdfact_z(n)=stdfact(chvarname) + bckg_valleyfact_z(n)=valleyfact(chvarname) + fstdmax0=fstdmax(chvarname) + bckg_stdmax_z(n)=maxval(corz(:,kvar,n))*an_amp(1,ivar)*fstdmax0 + if (mype==0) print*,'chvarname=',trim(chvarname) + if (mype==0) print*,'kk,n,bckg_stdfact_z(n),bckg_stdmax_z(n)=',kk,n,bckg_stdfact_z(n),bckg_stdmax_z(n) + if (mype==0) print*,'kk,n,bckg_valleyfact_z(n)=',kk,n,bckg_valleyfact_z(n) + if (mype==0) print*,'kk,n,ivar,an_amp(1,ivar)=',kk,n,ivar,an_amp(1,ivar) + if (mype==0) print*,'kk,slab1,min,max=',kk,minval(slab1),maxval(slab1) + if (mype==0) print*,'=================================' + if (mype==0) print*,'=================================' end if exit end if @@ -5879,47 +6049,48 @@ subroutine get_background_subdomain_option(mype) else if (trim(cvarstype(ivar))=='static2d') then do n=1,nrf2 if (nrf2_loc(n)==ivar) then - if (.not.stdmodel_z_based) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),trim(chvarname), ges_wrk2d, istatus) - - do k=1,nsig - do j=2,lon2-1 - jglob=j+jstart(mm1)-2 - if(jglob<1.or.jglob>nlona) cycle - do i=2,lat2-1 - iglob=i+istart(mm1)-2 - if(iglob<1.or.iglob>nlata) cycle - slab0 (iglob,jglob,k) = ges_wrk2d(i,j) - end do - end do - end do - if (trim(chvarname)=='ps') slab0 = slab0*1000._r_single - - call mpi_allreduce(slab0,slab1,(ide-ids+1)*(jde-jds+1)*(nsig-1+1),mpi_real4,mpi_sum,mpi_comm_world,ierror) - call get_fldstd(slab1,ids,ide,jds,jde,1,nsig,std_radius,npass_for_std,mype) - - do k=1,nsig - do j=1,lon2 - jglob=j+jstart(mm1)-2 - if(jglob<1.or.jglob>nlona) cycle - do i=1,lat2 - iglob=i+istart(mm1)-2 - if(iglob<1.or.iglob>nlata) cycle - bckg0f_stdp (i,j,k,n) = slab1 (iglob,jglob,k) - end do - end do - end do - end if!stdmodel_z_based condition if (lstdmodel0) then - bckg_stdbump_p(n)=stdbump(chvarname) - fstdmax0=fstdmax(chvarname) - bckg_stdmax_p(n)=maxval(corp(:,n))*an_amp(1,ivar)*fstdmax0 - if (mype==0) print*,'chvarname=',trim(chvarname) - if (mype==0) print*,'kk,n,bckg_stdbump_p(n),bckg_stdmax_p(n)=',kk,n,bckg_stdbump_p(n),bckg_stdmax_p(n) - if (mype==0) print*,'kk,n,ivar,an_amp(1,ivar)=',kk,n,ivar,an_amp(1,ivar) - if (mype==0) print*,'kk,slab1,min,max=',kk,minval(slab1),maxval(slab1) - if (mype==0) print*,'=================================' - if (mype==0) print*,'=================================' + call gsi_bundlegetpointer (gsi_metguess_bundle(it),trim(chvarname), ges_wrk2d, istatus) + + do k=1,nsig + do j=2,lon2-1 + jglob=j+jstart(mm1)-2 + if(jglob<1.or.jglob>nlona) cycle + do i=2,lat2-1 + iglob=i+istart(mm1)-2 + if(iglob<1.or.iglob>nlata) cycle + slab0 (iglob,jglob,k) = ges_wrk2d(i,j) + end do + end do + end do + if (trim(chvarname)=='ps') slab0 = slab0*1000._r_single + + call mpi_allreduce(slab0,slab1,(ide-ids+1)*(jde-jds+1)*nsig,mpi_real4,mpi_sum,mpi_comm_world,ierror) + call get_fldstd(slab1,ids,ide,jds,jde,1,nsig,std_radius,npass_for_std,mype) + + do k=1,nsig + do j=1,lon2 + jglob=j+jstart(mm1)-2 + if(jglob<1.or.jglob>nlona) cycle + do i=1,lat2 + iglob=i+istart(mm1)-2 + if(iglob<1.or.iglob>nlata) cycle + bckg_stdp0f (i,j,k,n) = slab1 (iglob,jglob,k) + end do + end do + end do + + bckg_stdfact_p(n)=stdfact(chvarname) + bckg_valleyfact_p(n)=valleyfact(chvarname) + fstdmax0=fstdmax(chvarname) + bckg_stdmax_p(n)=maxval(corp(:,n))*an_amp(1,ivar)*fstdmax0 + if (mype==0) print*,'chvarname=',trim(chvarname) + if (mype==0) print*,'kk,n,bckg_stdfact_p(n),bckg_stdmax_p(n)=',kk,n,bckg_stdfact_p(n),bckg_stdmax_p(n) + if (mype==0) print*,'kk,n,bckg_valleyfact_p(n)=',kk,n,bckg_valleyfact_p(n) + if (mype==0) print*,'kk,n,ivar,an_amp(1,ivar)=',kk,n,ivar,an_amp(1,ivar) + if (mype==0) print*,'kk,slab1,min,max=',kk,minval(slab1),maxval(slab1) + if (mype==0) print*,'=================================' + if (mype==0) print*,'=================================' end if exit end if @@ -5940,25 +6111,27 @@ subroutine get_background_subdomain_option(mype) do k=1,nsig do j=1,lon2 do i=1,lat2 - if (trim(chvarname)=='twter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdz(i,j,k,nrf3_t) - if (trim(chvarname)=='qwter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdz(i,j,k,nrf3_q) - if (trim(chvarname)=='pswter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdp(i,j,k,nrf2_ps) - if (trim(chvarname)=='gustwter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdp(i,j,k,nrf2_gust) - if (trim(chvarname)=='wspd10mwter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdp(i,j,k,nrf2_wspd10m) - if (trim(chvarname)=='td2mwter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdp(i,j,k,nrf2_td2m) - if (trim(chvarname)=='mxtmwter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdp(i,j,k,nrf2_mxtm) - if (trim(chvarname)=='mitmwter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdp(i,j,k,nrf2_mitm) - if (trim(chvarname)=='uwnd10mwter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdp(i,j,k,nrf2_uwnd10m) - if (trim(chvarname)=='vwnd10mwter') bckg0f_stdp(i,j,k,nn) = bckg0f_stdp(i,j,k,nrf2_vwnd10m) + if (trim(chvarname)=='twter') bckg_stdp0f(i,j,k,nn) = bckg_stdz0f(i,j,k,nrf3_t) + if (trim(chvarname)=='qwter') bckg_stdp0f(i,j,k,nn) = bckg_stdz0f(i,j,k,nrf3_q) + if (trim(chvarname)=='pswter') bckg_stdp0f(i,j,k,nn) = bckg_stdp0f(i,j,k,nrf2_ps) + if (trim(chvarname)=='gustwter') bckg_stdp0f(i,j,k,nn) = bckg_stdp0f(i,j,k,nrf2_gust) + if (trim(chvarname)=='wspd10mwter') bckg_stdp0f(i,j,k,nn) = bckg_stdp0f(i,j,k,nrf2_wspd10m) + if (trim(chvarname)=='td2mwter') bckg_stdp0f(i,j,k,nn) = bckg_stdp0f(i,j,k,nrf2_td2m) + if (trim(chvarname)=='mxtmwter') bckg_stdp0f(i,j,k,nn) = bckg_stdp0f(i,j,k,nrf2_mxtm) + if (trim(chvarname)=='mitmwter') bckg_stdp0f(i,j,k,nn) = bckg_stdp0f(i,j,k,nrf2_mitm) + if (trim(chvarname)=='uwnd10mwter') bckg_stdp0f(i,j,k,nn) = bckg_stdp0f(i,j,k,nrf2_uwnd10m) + if (trim(chvarname)=='vwnd10mwter') bckg_stdp0f(i,j,k,nn) = bckg_stdp0f(i,j,k,nrf2_vwnd10m) end do end do end do if (lstdmodel0) then - bckg_stdbump_p(nn)=stdbump(chvarname) + bckg_stdfact_p(nn)=stdfact(chvarname) + bckg_valleyfact_p(nn)=valleyfact(chvarname) fstdmax0=fstdmax(chvarname) bckg_stdmax_p(nn)=maxval(corp(:,nn))*an_amp(1,ivar)*fstdmax0 if (mype==0) print*,'chvarname=',trim(chvarname) - if (mype==0) print*,'kk,nn,bckg_stdbump_p(nn),bckg_stdmax_p(nn)=',kk,n,bckg_stdbump_p(nn),bckg_stdmax_p(nn) + if (mype==0) print*,'kk,nn,bckg_stdfact_p(nn),bckg_stdmax_p(nn)=',kk,n,bckg_stdfact_p(nn),bckg_stdmax_p(nn) + if (mype==0) print*,'kk,nn,bckg_valleyfact_p(nn)=',kk,n,bckg_valleyfact_p(nn) if (mype==0) print*,'kk,nn,ivar,an_amp(1,ivar)=',kk,nn,ivar,an_amp(1,ivar) if (mype==0) print*,'kk,slab1,min,max=',kk,minval(slab1),maxval(slab1) if (mype==0) print*,'=================================' @@ -5985,7 +6158,7 @@ subroutine get_background_subdomain_option(mype) end do slab1=zero_single - call mpi_allreduce(slab0,slab1,(ide-ids+1)*(jde-jds+1)*(nsig-1+1),mpi_real4,mpi_sum,mpi_comm_world,ierror) + call mpi_allreduce(slab0,slab1,(ide-ids+1)*(jde-jds+1)*nsig,mpi_real4,mpi_sum,mpi_comm_world,ierror) call get_fldstd(slab1,ids,ide,jds,jde,1,nsig,std_radius,npass_for_std,mype) do k=1,nsig @@ -6008,46 +6181,79 @@ subroutine get_background_subdomain_option(mype) allocate( valleys0f(lat2,lon2,nsig) ) valleys0f=1._r_single - inquire(file='valley_map_unsmoothed.dat',exist=fexist) - if (fexist) then - allocate(valleys(jds:jde , ids:ide)) !Note the transposing - open (55,file='valley_map_unsmoothed.dat',form='unformatted') - read(55) valleys - close(55) + if (.not.turnoff_all_stdmodels) then + allocate(valleys(jds:jde , ids:ide)) !Note the transpose - do k=kps0,kpe0 - do j=jps,jpe - do i=ips,ipe - field(i,j,k)=valleys(j,i) + inquire(file='valley_map_unsmoothed.dat',exist=fexist) + if (fexist) then + if (mype==0) then + open (55,file='valley_map_unsmoothed.dat',form='unformatted') + read(55) valleys + close(55) + endif + call mpi_bcast (valleys, (jde-jds+1)*(ide-ids+1), mpi_real4, 0, mpi_comm_world, ierror) + + do k=kps0,kpe0 + do j=jps,jpe + do i=ips,ipe + field(i,j,k)=valleys(j,i) + enddo enddo enddo - enddo - do n=1,n_valley_pass - call raf_sm4(field,filter_all,ngauss_smooth,ips,ipe,jps,jpe,kps0,kpe0,npe) - call raf_sm4_ad(field,filter_all,ngauss_smooth,ips,ipe,jps,jpe,kps0,kpe0,npe) - enddo + do n=1,n_valley_pass + call raf_sm4(field,filter_all,ngauss_smooth,ips,ipe,jps,jpe,kps0,kpe0,npe) + call raf_sm4_ad(field,filter_all,ngauss_smooth,ips,ipe,jps,jpe,kps0,kpe0,npe) + enddo - do k=kps0,kpe0 - do j=jps,jpe - jloc=j-jstart(mm1)+2 - do i=ips,ipe - iloc=i-istart(mm1)+2 - field2(iloc,jloc,k)=field(i,j,k) + do k=kps0,kpe0 + do j=jps,jpe + jloc=j-jstart(mm1)+2 + do i=ips,ipe + iloc=i-istart(mm1)+2 + field2(iloc,jloc,k)=field(i,j,k) + end do end do end do - end do - call halo_update_reg(field2,nsig) + call halo_update_reg(field2,nsig) - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - valleys0f(i,j,k)=field2(i,j,k) + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + valleys0f(i,j,k)=field2(i,j,k) + end do end do end do - end do - deallocate(valleys) + else + inquire(file='valley_map.dat',exist=gexist) + if (gexist) then + if (mype==0) then + open (55,file='valley_map.dat',form='unformatted') + read(55) valleys + close(55) + endif + + call mpi_bcast (valleys, (jde-jds+1)*(ide-ids+1), mpi_real4, 0, mpi_comm_world, ierror) + + do k=1,nsig + do j=1,lon2 + jglob=j+jstart(mm1)-2 + if(jglob<1.or.jglob>nlona) cycle + do i=1,lat2 + iglob=i+istart(mm1)-2 + if(iglob<1.or.iglob>nlata) cycle + valleys0f(i,j,k)=valleys(jglob,iglob) + enddo + enddo + enddo + else + if (mype==0) print*,'in get_background_subdomain_option: could not find valley_map.dat ... aborting' + call mpi_finalize(ierror) + stop + endif + endif + deallocate(valleys) endif diff --git a/src/anisofilter_glb.f90 b/src/gsi/anisofilter_glb.f90 similarity index 100% rename from src/anisofilter_glb.f90 rename to src/gsi/anisofilter_glb.f90 diff --git a/src/antcorr_application.f90 b/src/gsi/antcorr_application.f90 similarity index 100% rename from src/antcorr_application.f90 rename to src/gsi/antcorr_application.f90 diff --git a/src/antest_maps0.f90 b/src/gsi/antest_maps0.f90 similarity index 100% rename from src/antest_maps0.f90 rename to src/gsi/antest_maps0.f90 diff --git a/src/antest_maps0_glb.f90 b/src/gsi/antest_maps0_glb.f90 similarity index 100% rename from src/antest_maps0_glb.f90 rename to src/gsi/antest_maps0_glb.f90 diff --git a/src/atms_spatial_average_mod.f90 b/src/gsi/atms_spatial_average_mod.f90 similarity index 81% rename from src/atms_spatial_average_mod.f90 rename to src/gsi/atms_spatial_average_mod.f90 index e04f1ba3b..dd05faa23 100644 --- a/src/atms_spatial_average_mod.f90 +++ b/src/gsi/atms_spatial_average_mod.f90 @@ -169,16 +169,16 @@ SUBROUTINE ATMS_Spatial_Average(Num_Obs, NChanl, FOV, Time, BT_InOut, & do i=1,nchannels if (channelnumber(i) == ichan) then CALL MODIFY_BEAMWIDTH ( max_fov, max_scan, bt_image(:,:,ichan), & - sampling_dist, beamwidth(i), newwidth(i), & - cutoff(i), nxaverage(i), nyaverage(i), & - qc_dist(i), MinBT(Ichan), MaxBT(IChan), IOS) + sampling_dist, beamwidth(i), newwidth(i), & + cutoff(i), nxaverage(i), nyaverage(i), & + qc_dist(i), MinBT(Ichan), MaxBT(IChan), IOS) IF (IOS == 0) THEN do iscan=1,max_scan do ifov=1,max_fov IF (Scanline_Back(IFov, IScan) > 0) & - bt_inout(ichan,Scanline_Back(IFov, IScan)) = & - BT_Image(ifov,iscan,ichan) + bt_inout(ichan,Scanline_Back(IFov, IScan)) = & + BT_Image(ifov,iscan,ichan) end do end do ELSE @@ -187,6 +187,7 @@ SUBROUTINE ATMS_Spatial_Average(Num_Obs, NChanl, FOV, Time, BT_InOut, & end if end do END DO + do ichan=1,nchanl if(err(ichan) >= 1)then error_status = 1 @@ -563,32 +564,35 @@ SUBROUTINE SFFTCF( X, N, M ) ! IF ( N == 1 ) RETURN ! - 100 J = 1 + J = 1 N1 = N - 1 DO 104, I = 1, N1 - IF ( I >= J ) GOTO 101 - XT = X(J) - X(J) = X(I) - X(I) = XT - 101 K = N / 2 - 102 IF ( K >= J ) GOTO 103 + IF ( I < J ) THEN + XT = X(J) + X(J) = X(I) + X(I) = XT + END IF + K = N / 2 + 102 DO WHILE (K < J) J = J - K K = K / 2 - GOTO 102 - 103 J = J + K + END DO + J = J + K 104 CONTINUE ! IS = 1 ID = 4 - 70 DO 60, I0 = IS, N, ID - I1 = I0 + 1 - R1 = X(I0) - X(I0) = R1 + X(I1) - X(I1) = R1 - X(I1) - 60 CONTINUE - IS = 2 * ID - 1 - ID = 4 * ID - IF ( IS < N ) GOTO 70 + LOOP1:DO + DO 60, I0 = IS, N, ID + I1 = I0 + 1 + R1 = X(I0) + X(I0) = R1 + X(I1) + X(I1) = R1 - X(I1) + 60 CONTINUE + IS = 2 * ID - 1 + ID = 4 * ID + IF ( IS >= N ) EXIT LOOP1 + END DO LOOP1 ! N2 = 2 DO 10, K = 2, M @@ -598,30 +602,32 @@ SUBROUTINE SFFTCF( X, N, M ) E = TWOPI / N2 IS = 0 ID = N2 * 2 - 40 DO 38, I = IS, N-1, ID - I1 = I + 1 - I2 = I1 + N4 - I3 = I2 + N4 - I4 = I3 + N4 - T1 = X(I4) + X(I3) - X(I4) = X(I4) - X(I3) - X(I3) = X(I1) - T1 - X(I1) = X(I1) + T1 - IF ( N4 == 1 ) GOTO 38 - I1 = I1 + N8 - I2 = I2 + N8 - I3 = I3 + N8 - I4 = I4 + N8 - T1 = ( X(I3) + X(I4) ) / SQRT2 - T2 = ( X(I3) - X(I4) ) / SQRT2 - X(I4) = X(I2) - T1 - X(I3) = - X(I2) - T1 - X(I2) = X(I1) - T2 - X(I1) = X(I1) + T2 - 38 CONTINUE - IS = 2 * ID - N2 - ID = 4 * ID - IF ( IS < N ) GOTO 40 + LOOP2: DO + DO 38, I = IS, N-1, ID + I1 = I + 1 + I2 = I1 + N4 + I3 = I2 + N4 + I4 = I3 + N4 + T1 = X(I4) + X(I3) + X(I4) = X(I4) - X(I3) + X(I3) = X(I1) - T1 + X(I1) = X(I1) + T1 + IF ( N4 == 1 ) CYCLE + I1 = I1 + N8 + I2 = I2 + N8 + I3 = I3 + N8 + I4 = I4 + N8 + T1 = ( X(I3) + X(I4) ) / SQRT2 + T2 = ( X(I3) - X(I4) ) / SQRT2 + X(I4) = X(I2) - T1 + X(I3) = - X(I2) - T1 + X(I2) = X(I1) - T2 + X(I1) = X(I1) + T2 + 38 CONTINUE + IS = 2 * ID - N2 + ID = 4 * ID + IF ( IS >= N ) EXIT LOOP2 + END DO LOOP2 A = E DO 32, J = 2, N8 A3 = 3 * A @@ -632,39 +638,41 @@ SUBROUTINE SFFTCF( X, N, M ) A = J * E IS = 0 ID = 2 * N2 - 36 DO 30, I = IS, N-1, ID - I1 = I + J - I2 = I1 + N4 - I3 = I2 + N4 - I4 = I3 + N4 - I5 = I + N4 - J + 2 - I6 = I5 + N4 - I7 = I6 + N4 - I8 = I7 + N4 - T1 = X(I3) * CC1 + X(I7) * SS1 - T2 = X(I7) * CC1 - X(I3) * SS1 - T3 = X(I4) * CC3 + X(I8) * SS3 - T4 = X(I8) * CC3 - X(I4) * SS3 - T5 = T1 + T3 - T6 = T2 + T4 - T3 = T1 - T3 - T4 = T2 - T4 - T2 = X(I6) + T6 - X(I3) = T6 - X(I6) - X(I8) = T2 - T2 = X(I2) - T3 - X(I7) = - X(I2) - T3 - X(I4) = T2 - T1 = X(I1) + T5 - X(I6) = X(I1) - T5 - X(I1) = T1 - T1 = X(I5) + T4 - X(I5) = X(I5) - T4 - X(I2) = T1 - 30 CONTINUE - IS = 2 * ID - N2 - ID = 4 * ID - IF ( IS < N ) GOTO 36 + LOOP3: DO + DO 30, I = IS, N-1, ID + I1 = I + J + I2 = I1 + N4 + I3 = I2 + N4 + I4 = I3 + N4 + I5 = I + N4 - J + 2 + I6 = I5 + N4 + I7 = I6 + N4 + I8 = I7 + N4 + T1 = X(I3) * CC1 + X(I7) * SS1 + T2 = X(I7) * CC1 - X(I3) * SS1 + T3 = X(I4) * CC3 + X(I8) * SS3 + T4 = X(I8) * CC3 - X(I4) * SS3 + T5 = T1 + T3 + T6 = T2 + T4 + T3 = T1 - T3 + T4 = T2 - T4 + T2 = X(I6) + T6 + X(I3) = T6 - X(I6) + X(I8) = T2 + T2 = X(I2) - T3 + X(I7) = - X(I2) - T3 + X(I4) = T2 + T1 = X(I1) + T5 + X(I6) = X(I1) - T5 + X(I1) = T1 + T1 = X(I5) + T4 + X(I5) = X(I5) - T4 + X(I2) = T1 + 30 CONTINUE + IS = 2 * ID - N2 + ID = 4 * ID + IF ( IS >= N ) EXIT LOOP3 + END DO LOOP3 32 CONTINUE 10 CONTINUE RETURN @@ -733,31 +741,33 @@ SUBROUTINE SFFTCB( X, N, M ) N4 = N2 / 4 N8 = N4 / 2 E = TWOPI / N2 - 17 DO 15, I = IS, N-1, ID - I1 = I + 1 - I2 = I1 + N4 - I3 = I2 + N4 - I4 = I3 + N4 - T1 = X(I1) - X(I3) - X(I1) = X(I1) + X(I3) - X(I2) = 2 * X(I2) - X(I3) = T1 - 2 * X(I4) - X(I4) = T1 + 2 * X(I4) - IF ( N4 == 1 ) GOTO 15 - I1 = I1 + N8 - I2 = I2 + N8 - I3 = I3 + N8 - I4 = I4 + N8 - T1 = ( X(I2) - X(I1) ) / SQRT2 - T2 = ( X(I4) + X(I3) ) / SQRT2 - X(I1) = X(I1) + X(I2) - X(I2) = X(I4) - X(I3) - X(I3) = 2 * ( - T2 - T1 ) - X(I4) = 2 * ( -T2 + T1 ) - 15 CONTINUE - IS = 2 * ID - N2 - ID = 4 * ID - IF ( IS < N-1 ) GOTO 17 + LOOP1: DO + DO 15, I = IS, N-1, ID + I1 = I + 1 + I2 = I1 + N4 + I3 = I2 + N4 + I4 = I3 + N4 + T1 = X(I1) - X(I3) + X(I1) = X(I1) + X(I3) + X(I2) = 2 * X(I2) + X(I3) = T1 - 2 * X(I4) + X(I4) = T1 + 2 * X(I4) + IF ( N4 == 1 ) CYCLE + I1 = I1 + N8 + I2 = I2 + N8 + I3 = I3 + N8 + I4 = I4 + N8 + T1 = ( X(I2) - X(I1) ) / SQRT2 + T2 = ( X(I4) + X(I3) ) / SQRT2 + X(I1) = X(I1) + X(I2) + X(I2) = X(I4) - X(I3) + X(I3) = 2 * ( - T2 - T1 ) + X(I4) = 2 * ( -T2 + T1 ) + 15 CONTINUE + IS = 2 * ID - N2 + ID = 4 * ID + IF ( IS >= N-1 ) EXIT LOOP1 + END DO LOOP1 A = E DO 20, J = 2, N8 A3 = 3 * A @@ -768,63 +778,68 @@ SUBROUTINE SFFTCB( X, N, M ) A = J * E IS = 0 ID = 2 * N2 - 40 DO 30, I = IS, N-1, ID - I1 = I + J - I2 = I1 + N4 - I3 = I2 + N4 - I4 = I3 + N4 - I5 = I + N4 - J + 2 - I6 = I5 + N4 - I7 = I6 + N4 - I8 = I7 + N4 - T1 = X(I1) - X(I6) - X(I1) = X(I1) + X(I6) - T2 = X(I5) - X(I2) - X(I5) = X(I2) + X(I5) - T3 = X(I8) + X(I3) - X(I6) = X(I8) - X(I3) - T4 = X(I4) + X(I7) - X(I2) = X(I4) - X(I7) - T5 = T1 - T4 - T1 = T1 + T4 - T4 = T2 - T3 - T2 = T2 + T3 - X(I3) = T5 * CC1 + T4 * SS1 - X(I7) = - T4 * CC1 + T5 * SS1 - X(I4) = T1 * CC3 - T2 * SS3 - X(I8) = T2 * CC3 + T1 * SS3 - 30 CONTINUE - IS = 2 * ID - N2 - ID = 4 * ID - IF ( IS < N-1 ) GOTO 40 + LOOP2: DO + 40 DO 30, I = IS, N-1, ID + I1 = I + J + I2 = I1 + N4 + I3 = I2 + N4 + I4 = I3 + N4 + I5 = I + N4 - J + 2 + I6 = I5 + N4 + I7 = I6 + N4 + I8 = I7 + N4 + T1 = X(I1) - X(I6) + X(I1) = X(I1) + X(I6) + T2 = X(I5) - X(I2) + X(I5) = X(I2) + X(I5) + T3 = X(I8) + X(I3) + X(I6) = X(I8) - X(I3) + T4 = X(I4) + X(I7) + X(I2) = X(I4) - X(I7) + T5 = T1 - T4 + T1 = T1 + T4 + T4 = T2 - T3 + T2 = T2 + T3 + X(I3) = T5 * CC1 + T4 * SS1 + X(I7) = - T4 * CC1 + T5 * SS1 + X(I4) = T1 * CC3 - T2 * SS3 + X(I8) = T2 * CC3 + T1 * SS3 + 30 CONTINUE + IS = 2 * ID - N2 + ID = 4 * ID + IF ( IS >= N-1 ) EXIT LOOP2 + END DO LOOP2 20 CONTINUE 10 CONTINUE ! IS = 1 ID = 4 - 70 DO 60, I0 = IS, N, ID - I1 = I0 + 1 - R1 = X(I0) - X(I0) = R1 + X(I1) - X(I1) = R1 - X(I1) - 60 CONTINUE - IS = 2 * ID - 1 - ID = 4 * ID - IF ( IS < N ) GOTO 70 -! - 100 J = 1 + LOOP3: DO + DO 60, I0 = IS, N, ID + I1 = I0 + 1 + R1 = X(I0) + X(I0) = R1 + X(I1) + X(I1) = R1 - X(I1) + 60 CONTINUE + IS = 2 * ID - 1 + ID = 4 * ID + IF ( IS >= N ) EXIT LOOP3 + END DO LOOP3 +! + J = 1 N1 = N - 1 DO 104, I = 1, N1 - IF ( I >= J ) GOTO 101 - XT = X(J) - X(J) = X(I) - X(I) = XT - 101 K = N / 2 - 102 IF ( K >= J ) GOTO 103 + IF ( I < J ) THEN + XT = X(J) + X(J) = X(I) + X(I) = XT + END IF + K = N / 2 + DO WHILE (K < J ) J = J - K K = K / 2 - GOTO 102 - 103 J = J + K + END DO + J = J + K 104 CONTINUE XT = 1.0_r_kind / FLOAT( N ) DO 99, I = 1, N diff --git a/src/balmod.f90 b/src/gsi/balmod.f90 similarity index 99% rename from src/balmod.f90 rename to src/gsi/balmod.f90 index aa550e841..59ec5a5b9 100644 --- a/src/balmod.f90 +++ b/src/gsi/balmod.f90 @@ -958,10 +958,9 @@ subroutine locatelat_reg(mype) rllat(i,j)=float(m) llmax=max0(m,llmax) llmin=min0(m,llmin) - go to 1234 + exit end if end do -1234 continue rllat(i,j)=rllat(i,j)+(region_lat(i,j)-clat_avn(m))/(clat_avn(m1)-clat_avn(m)) endif end do diff --git a/src/berror.f90 b/src/gsi/berror.f90 similarity index 100% rename from src/berror.f90 rename to src/gsi/berror.f90 diff --git a/src/bias_predictors.f90 b/src/gsi/bias_predictors.f90 similarity index 86% rename from src/bias_predictors.f90 rename to src/gsi/bias_predictors.f90 index e3ebcaf0e..39e8bb139 100644 --- a/src/bias_predictors.f90 +++ b/src/gsi/bias_predictors.f90 @@ -12,6 +12,10 @@ module bias_predictors ! 2012-07-13 todling - add read and write ! 2013-05-21 zhu - add aircraft temperature bias correction coefficients ! 2014-02-07 todling - move bias preds update inside this module +! 2018-08-10 guo - added a []_getdim() interface. +! 2018-11-29 guo - replaced CRTM:file_utility::get_lun() with a new but +! standard Fortran open(newunit=iunit) +! ! ! subroutines included: ! sub setup_predictors @@ -31,7 +35,6 @@ module bias_predictors use kinds, only: r_kind,i_kind use constants, only : zero -use file_utility, only : get_lun implicit none save @@ -40,6 +43,8 @@ module bias_predictors assignment(=), setup_predictors, read_preds, write_preds, & update_bias_preds +public:: predictors_getdim + type predictors real(r_kind), pointer :: values(:) => NULL() @@ -50,7 +55,7 @@ module bias_predictors logical :: lallocated = .false. end type predictors -integer(i_kind) :: nrclen,nsclen,npclen,ntclen +integer(i_kind),save :: nrclen,nsclen,npclen,ntclen logical :: llinit = .false. @@ -97,6 +102,38 @@ subroutine setup_predictors(krclen,ksclen,kpclen,ktclen) return end subroutine setup_predictors + +subroutine predictors_getdim(lbnd_r,ubnd_r,size_r, & + lbnd_s,ubnd_s,size_s, & + lbnd_p,ubnd_p,size_p, & + lbnd_t,ubnd_t,size_t ) + implicit none + integer(i_kind),optional,intent(out):: lbnd_r,ubnd_r,size_r + integer(i_kind),optional,intent(out):: lbnd_s,ubnd_s,size_s + integer(i_kind),optional,intent(out):: lbnd_p,ubnd_p,size_p + integer(i_kind),optional,intent(out):: lbnd_t,ubnd_t,size_t + +! total size of all predictors, (lbnd_r:ubnd_r) == (1 : size_r) + if(present(lbnd_r)) lbnd_r=1 + if(present(ubnd_r)) ubnd_r=nrclen + if(present(size_r)) size_r=nrclen + +! size of rad predictors, (lbnd_s:ubnd_s) == (1 : size_s) + if(present(lbnd_s)) lbnd_s=1 + if(present(ubnd_s)) ubnd_s=nsclen + if(present(size_s)) size_s=nsclen + +! size of q predictors, (lbnd_p:ubnd_p) == ubnd_s + (1:size_p) + if(present(lbnd_p)) lbnd_p=nsclen+1 + if(present(ubnd_p)) ubnd_p=nsclen+npclen + if(present(size_p)) size_p=npclen + +! size of t predictors, (lbnd_t:ubnd_t) == ubnd_p+ (1:size_t) + if(present(lbnd_t)) lbnd_t=nsclen+npclen+1 + if(present(ubnd_t)) ubnd_t=nsclen+npclen+ntclen + if(present(size_t)) size_t=ntclen + +end subroutine predictors_getdim ! ---------------------------------------------------------------------- subroutine allocate_preds(yst) !$$$ subprogram documentation block @@ -292,8 +329,7 @@ subroutine read_preds (yst,filename) allwell=.true. allocate(preds(nsclen),predp(npclen),predt(ntclen)) - iunit=get_lun() - open(iunit,file=trim(filename),form='unformatted') + open(newunit=iunit,file=trim(filename),form='unformatted') read(iunit)nsclen_in,npclen_in,ntclen_in if(nsclen_in/=nsclen .or. npclen_in/=npclen) then allwell=.false. @@ -358,9 +394,8 @@ subroutine write_preds (yst,filename,mype) predt = yst%values(ii+1:ii+ntclen) endif - iunit=get_lun() if (mype==0) then - open(iunit,file=trim(filename),form='unformatted') + open(newunit=iunit,file=trim(filename),form='unformatted') write(iunit)nsclen,npclen,ntclen if(ntclen>0) then write(iunit)preds,predp,predt diff --git a/src/bicg.f90 b/src/gsi/bicg.f90 similarity index 100% rename from src/bicg.f90 rename to src/gsi/bicg.f90 diff --git a/src/bicglanczos.F90 b/src/gsi/bicglanczos.F90 old mode 100644 new mode 100755 similarity index 97% rename from src/bicglanczos.F90 rename to src/gsi/bicglanczos.F90 index 87bb9127f..ea0d89ddd --- a/src/bicglanczos.F90 +++ b/src/gsi/bicglanczos.F90 @@ -20,6 +20,7 @@ module bicglanczos ! 2016-03-25 todling - beta-mult param now within cov (following Dave Parrish corrections) ! 2016-05-13 parrish - remove call to beta12mult -- replaced by sqrt_beta_s_mult in ! bkerror, and sqrt_beta_e_mult inside bkerror_a_en. +! 2017-06-27 todling - knob to bypass calc when gradient is tiny(zero) ! ! Subroutines Included: ! save_pcgprecond - Save eigenvectors for constructing the next preconditioner @@ -53,7 +54,7 @@ module bicglanczos !============================================================= use kinds , only : r_kind,i_kind,r_quad,r_single,r_double -use constants, only : zero, one, half,two, zero_quad +use constants, only : zero, one, half,two, zero_quad,tiny_r_kind use timermod , only : timer_ini, timer_fnl use lanczos , only : save_precond use gsi_4dvar, only : iorthomax @@ -255,10 +256,6 @@ subroutine pcglanczos(xhat,yhat,pcost,gradx,grady,preduc,kmaxit,lsavevecs) ilen=xhat%lencv -allocate(alpha(kmaxit),beta(kmaxit),delta(0:kmaxit),gam(0:kmaxit)) -alpha(:)=zero_quad -beta(:)=zero_quad - if(diag_precon) dirw=zero !$omp parallel do @@ -285,6 +282,26 @@ subroutine pcglanczos(xhat,yhat,pcost,gradx,grady,preduc,kmaxit,lsavevecs) end if zg0=dot_product(gradx,grady,r_quad) +if(zg0=1.and.ltcost_) call deallocate_cv(gradf) + call deallocate_cv(diry) + call deallocate_cv(dirx) + call deallocate_cv(gradw) + call deallocate_cv(ytry) ! not in PCGSOI + call deallocate_cv(xtry) ! not in PCGSOI + call deallocate_cv(grad0) ! not in PCGSOI (use ydiff instead) + if (mype==0) then + write(6,999)trim(myname),': zero gradient, likely no observations', jiter,iter,zg0 + endif + return ! get out of here. +endif + +allocate(alpha(kmaxit),beta(kmaxit),delta(0:kmaxit),gam(0:kmaxit)) +alpha(:)=zero_quad +beta(:)=zero_quad + zgk=zg0 delta(0)=zg0 zg0=sqrt(zg0) diff --git a/src/bkerror.f90 b/src/gsi/bkerror.f90 similarity index 100% rename from src/bkerror.f90 rename to src/gsi/bkerror.f90 diff --git a/src/bkgcov.f90 b/src/gsi/bkgcov.f90 similarity index 100% rename from src/bkgcov.f90 rename to src/gsi/bkgcov.f90 diff --git a/src/bkgvar.f90 b/src/gsi/bkgvar.f90 similarity index 100% rename from src/bkgvar.f90 rename to src/gsi/bkgvar.f90 diff --git a/src/bkgvar_rewgt.f90 b/src/gsi/bkgvar_rewgt.f90 similarity index 100% rename from src/bkgvar_rewgt.f90 rename to src/gsi/bkgvar_rewgt.f90 diff --git a/src/blacklist.f90 b/src/gsi/blacklist.f90 similarity index 100% rename from src/blacklist.f90 rename to src/gsi/blacklist.f90 diff --git a/src/blendmod.f90 b/src/gsi/blendmod.f90 similarity index 100% rename from src/blendmod.f90 rename to src/gsi/blendmod.f90 diff --git a/src/blockIO.c b/src/gsi/blockIO.c similarity index 100% rename from src/blockIO.c rename to src/gsi/blockIO.c diff --git a/src/buddycheck_mod.f90 b/src/gsi/buddycheck_mod.f90 similarity index 99% rename from src/buddycheck_mod.f90 rename to src/gsi/buddycheck_mod.f90 index da0dc521e..ae4a29cc6 100644 --- a/src/buddycheck_mod.f90 +++ b/src/gsi/buddycheck_mod.f90 @@ -50,7 +50,8 @@ subroutine buddy_check_t(is,data,luse,mype,nele,nobs,muse,buddyuse) use gridmod, only: nsig,regional use guess_grids, only: nfldsig, hrdifsig,ges_lnprsl,& - geop_hgtl,ges_tsen,pt_ll + geop_hgtl,ges_tsen + use gridmod,only:pt_ll use constants, only: zero,one,r10 use obsmod, only: bmiss,sfcmodel,time_offset use m_dtime, only: dtime_setup, dtime_check, dtime_show diff --git a/src/calc_fov_conical.f90 b/src/gsi/calc_fov_conical.f90 similarity index 100% rename from src/calc_fov_conical.f90 rename to src/gsi/calc_fov_conical.f90 diff --git a/src/calc_fov_crosstrk.f90 b/src/gsi/calc_fov_crosstrk.f90 similarity index 99% rename from src/calc_fov_crosstrk.f90 rename to src/gsi/calc_fov_crosstrk.f90 index 8c80599bb..75fffb108 100644 --- a/src/calc_fov_crosstrk.f90 +++ b/src/gsi/calc_fov_crosstrk.f90 @@ -1287,6 +1287,8 @@ subroutine get_sat_height(satid, height, valid) height=866._r_kind case('npp') height=840._r_kind + case('n20') + height=840._r_kind case default write(6,*) 'GET_SAT_HEIGHT: ERROR, unrecognized satellite id: ', trim(satid) valid=.false. diff --git a/src/calctends.f90 b/src/gsi/calctends.f90 similarity index 82% rename from src/calctends.f90 rename to src/gsi/calctends.f90 index 9fd0d5391..4bd2c64e2 100644 --- a/src/calctends.f90 +++ b/src/gsi/calctends.f90 @@ -30,6 +30,8 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency) ! 2013-10-19 todling - revamp interface with fields now in bundles; still ! needs generalization ! 2013-10-28 todling - rename p3d to prse +! 2019-03-13 eliu - use derivative var table instead of the control var table +! 2019-05-09 eliu - point cloud water(cw) to derived value (cwgues) when cw is not in met_guess table ! ! usage: ! input argument list: @@ -53,7 +55,7 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency) use constants, only: zero,half,one,two,rearth,rd,rcp,omega,grav use tendsmod, only: what9,prsth9,r_prsum9,r_prdif9,prdif9,pr_xsum9,pr_xdif9,pr_ysum9,& pr_ydif9,curvx,curvy,coriolis - use control_vectors, only: cvars3d + use derivsmod, only: dvars3d,cwgues use mpeu_util, only: getindex use gsi_bundlemod, only: gsi_bundle @@ -77,7 +79,7 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency) real(r_kind),dimension(lat2,lon2,nsig+1):: pri_x,pri_y real(r_kind),dimension(lat2,lon2):: sumkm1,sumvkm1,sum2km1,sum2vkm1 real(r_kind) tmp,tmp2 - integer(i_kind) i,j,k,ix,ixm,ixp,jx,jxm,jxp,kk,icw + integer(i_kind) i,j,k,ix,ixm,ixp,jx,jxm,jxp,kk,icw,iq,ioz,ip3d real(r_kind) sumk,sumvk,sum2k,sum2vk,uuvv real(r_kind),dimension(:,: ),pointer :: z =>NULL() @@ -263,13 +265,16 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency) ! what9(i,k,1) & what9(i,j,nsig+1) = zero ! p_t(i,j,1) is the same as the surface pressure tendency - do k=1,nsig+1 - do j=jtstart(kk),jtstop(kk) - do i=1,lat2 - p_t(i,j,k)=prsth9(i,j,k)-what9(i,j,k) - end do - end do - end do + ip3d=getindex(dvars3d,'prse') + if (ip3d>0) then + do k=1,nsig+1 + do j=jtstart(kk),jtstop(kk) + do i=1,lat2 + p_t(i,j,k)=prsth9(i,j,k)-what9(i,j,k) + end do + end do + end do + endif ! before big k loop, zero out the km1 summation arrays do j=jtstart(kk),jtstop(kk) @@ -283,7 +288,10 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency) ! Compute tendencies for wind components & Temperature - icw=getindex(cvars3d,'cw') + icw =getindex(dvars3d,'cw') + ioz =getindex(dvars3d,'oz') + iq =getindex(dvars3d,'q') + ip3d=getindex(dvars3d,'prse') do k=1,nsig do j=jtstart(kk),jtstop(kk) do i=1,lat2 @@ -299,11 +307,9 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency) ! horizontal advection of "tracer" quantities - q_t (i,j,k) = -u(i,j,k)*q_x (i,j,k) - v(i,j,k)*q_y (i,j,k) - oz_t(i,j,k) = -u(i,j,k)*oz_x(i,j,k) - v(i,j,k)*oz_y(i,j,k) - if(icw>0)then - cw_t(i,j,k) = -u(i,j,k)*cw_x(i,j,k) - v(i,j,k)*cw_y(i,j,k) - end if + if (iq >0) q_t (i,j,k) = -u(i,j,k)*q_x (i,j,k) - v(i,j,k)*q_y (i,j,k) + if (ioz>0) oz_t(i,j,k) = -u(i,j,k)*oz_x(i,j,k) - v(i,j,k)*oz_y(i,j,k) + if (icw>0) cw_t(i,j,k) = -u(i,j,k)*cw_x(i,j,k) - v(i,j,k)*cw_y(i,j,k) ! vertical flux terms @@ -312,22 +318,18 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency) u_t (i,j,k) = u_t (i,j,k) - tmp*(u (i,j,k-1)-u (i,j,k)) v_t (i,j,k) = v_t (i,j,k) - tmp*(v (i,j,k-1)-v (i,j,k)) t_t (i,j,k) = t_t (i,j,k) - tmp*(t (i,j,k-1)-t (i,j,k)) - q_t (i,j,k) = q_t (i,j,k) - tmp*(q (i,j,k-1)-q (i,j,k)) - oz_t(i,j,k) = oz_t(i,j,k) - tmp*(oz(i,j,k-1)-oz(i,j,k)) - if(icw>0)then - cw_t(i,j,k) = cw_t(i,j,k) - tmp*(cw(i,j,k-1)-cw(i,j,k)) - end if + if (iq >0) q_t (i,j,k) = q_t (i,j,k) - tmp*(q (i,j,k-1)-q (i,j,k)) + if (ioz>0) oz_t(i,j,k) = oz_t(i,j,k) - tmp*(oz(i,j,k-1)-oz(i,j,k)) + if (icw>0) cw_t(i,j,k) = cw_t(i,j,k) - tmp*(cw(i,j,k-1)-cw(i,j,k)) end if if (k0)then - cw_t(i,j,k) = cw_t(i,j,k) - tmp*(cw(i,j,k)-cw(i,j,k+1)) - end if + if (iq >0) q_t (i,j,k) = q_t (i,j,k) - tmp*(q (i,j,k)-q (i,j,k+1)) + if (ioz>0) oz_t(i,j,k) = oz_t(i,j,k) - tmp*(oz(i,j,k)-oz(i,j,k+1)) + if (icw>0) cw_t(i,j,k) = cw_t(i,j,k) - tmp*(cw(i,j,k)-cw(i,j,k+1)) end if end do !end do j end do !end do i @@ -391,6 +393,11 @@ subroutine init_vars_ (thiscase,bundle) ! code. However, this can be easily generalized by a little re-write ! of the main code in the subroutine above - TO BE DONE. + icw =getindex(dvars3d,'cw') + ioz =getindex(dvars3d,'oz') + iq =getindex(dvars3d,'q') + ip3d=getindex(dvars3d,'prse') + ! If require guess vars available, extract from bundle ... if (trim(thiscase)=='guess') then ier=0 @@ -402,12 +409,22 @@ subroutine init_vars_ (thiscase,bundle) ier=ier+istatus call gsi_bundlegetpointer(bundle,'tv',t ,istatus) ier=ier+istatus - call gsi_bundlegetpointer(bundle,'q' ,q ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(bundle,'oz',oz ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(bundle,'cw',cw ,istatus) - ier=ier+istatus + if (iq>0) then + call gsi_bundlegetpointer(bundle,'q' ,q ,istatus) + ier=ier+istatus + endif + if (ioz>0) then + call gsi_bundlegetpointer(bundle,'oz',oz ,istatus) + ier=ier+istatus + endif + if (icw>0) then + call gsi_bundlegetpointer(bundle,'cw',cw ,istatus) + if (istatus /=0) then + cw => cwgues + istatus=0 + endif + ier=ier+istatus + endif endif if (trim(thiscase)=='xderivative') then ier=0 @@ -419,12 +436,18 @@ subroutine init_vars_ (thiscase,bundle) ier=ier+istatus call gsi_bundlegetpointer(bundle,'tv',t_x ,istatus) ier=ier+istatus - call gsi_bundlegetpointer(bundle,'q' ,q_x ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(bundle,'oz',oz_x,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(bundle,'cw',cw_x,istatus) - ier=ier+istatus + if (iq>0) then + call gsi_bundlegetpointer(bundle,'q' ,q_x ,istatus) + ier=ier+istatus + endif + if (ioz>0) then + call gsi_bundlegetpointer(bundle,'oz',oz_x,istatus) + ier=ier+istatus + endif + if (icw>0) then + call gsi_bundlegetpointer(bundle,'cw',cw_x,istatus) + ier=ier+istatus + endif endif if (trim(thiscase)=='yderivative') then ier=0 @@ -436,12 +459,18 @@ subroutine init_vars_ (thiscase,bundle) ier=ier+istatus call gsi_bundlegetpointer(bundle,'tv',t_y ,istatus) ier=ier+istatus - call gsi_bundlegetpointer(bundle,'q' ,q_y ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(bundle,'oz',oz_y,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(bundle,'cw',cw_y,istatus) - ier=ier+istatus + if (iq>0) then + call gsi_bundlegetpointer(bundle,'q' ,q_y ,istatus) + ier=ier+istatus + endif + if (ioz>0) then + call gsi_bundlegetpointer(bundle,'oz',oz_y,istatus) + ier=ier+istatus + endif + if (icw>0) then + call gsi_bundlegetpointer(bundle,'cw',cw_y,istatus) + ier=ier+istatus + endif endif if(trim(thiscase)=='tendency') then ier=0 @@ -451,14 +480,22 @@ subroutine init_vars_ (thiscase,bundle) ier=ier+istatus call gsi_bundlegetpointer(bundle,'tv',t_t ,istatus) ier=ier+istatus - call gsi_bundlegetpointer(bundle,'q' ,q_t ,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(bundle,'oz',oz_t,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(bundle,'cw',cw_t,istatus) - ier=ier+istatus - call gsi_bundlegetpointer(bundle,'prse',p_t,istatus) - ier=ier+istatus + if (iq>0) then + call gsi_bundlegetpointer(bundle,'q' ,q_t ,istatus) + ier=ier+istatus + endif + if (ioz>0) then + call gsi_bundlegetpointer(bundle,'oz',oz_t,istatus) + ier=ier+istatus + endif + if (icw>0) then + call gsi_bundlegetpointer(bundle,'cw',cw_t,istatus) + ier=ier+istatus + endif + if (ip3d>0) then + call gsi_bundlegetpointer(bundle,'prse',p_t,istatus) + ier=ier+istatus + endif endif if (ier/=0) then call die(myname_,': missing fields in '//trim(thiscase)//' ier=',ier) diff --git a/src/calctends_ad.f90 b/src/gsi/calctends_ad.f90 similarity index 99% rename from src/calctends_ad.f90 rename to src/gsi/calctends_ad.f90 index 4e79150e2..72b5b76ff 100644 --- a/src/calctends_ad.f90 +++ b/src/gsi/calctends_ad.f90 @@ -235,7 +235,7 @@ subroutine calctends_ad(fields,fields_dt,mype) ! loop over threads !$omp parallel do schedule(dynamic,1) private(i,j,k,kk,tmp,tmp2,ix,& -!$omp tmp3,sumk,sumvk,sum2k,sum2vk) +!$omp tmp3,sumk,sumvk,sum2k,sum2vk,var) do kk=1,nthreads ! zero arrays diff --git a/src/calctends_no_ad.f90 b/src/gsi/calctends_no_ad.f90 similarity index 99% rename from src/calctends_no_ad.f90 rename to src/gsi/calctends_no_ad.f90 index 08a09a7ba..e50f96df7 100644 --- a/src/calctends_no_ad.f90 +++ b/src/gsi/calctends_no_ad.f90 @@ -139,7 +139,7 @@ subroutine calctends_no_ad(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag) endif !$omp parallel do private(i,j,k,kk,tmp,tmp2,ix,& -!$omp tmp3,sumk,sumvk,sum2k,sum2vk) +!$omp tmp3,sumk,sumvk,sum2k,sum2vk,var) do kk=1,nthreads diff --git a/src/calctends_no_tl.f90 b/src/gsi/calctends_no_tl.f90 similarity index 100% rename from src/calctends_no_tl.f90 rename to src/gsi/calctends_no_tl.f90 diff --git a/src/calctends_tl.f90 b/src/gsi/calctends_tl.f90 similarity index 100% rename from src/calctends_tl.f90 rename to src/gsi/calctends_tl.f90 diff --git a/src/chemmod.f90 b/src/gsi/chemmod.f90 similarity index 97% rename from src/chemmod.f90 rename to src/gsi/chemmod.f90 index 4d337ce4d..952e13aab 100644 --- a/src/chemmod.f90 +++ b/src/gsi/chemmod.f90 @@ -14,6 +14,7 @@ module chemmod ! NB: keep aerosol names capital for consistency with cmaq output names ! 2011-09-09 pagowski - add codes for PM2.5 for prepbufr and bufr dump files ! 2013-11-01 pagowski - add code for PM2.5 assimilation with wrf-chem +! 2019-03-21 Wei/Martin - logical if to read in aerosols from ext. file (default F) use kinds, only : i_kind, r_kind, r_single @@ -51,6 +52,7 @@ module chemmod public :: wrf_pm2_5 + public :: lread_ext_aerosol public :: aero_ratios public :: upper2lower,lower2upper @@ -63,6 +65,7 @@ module chemmod real(r_kind) :: ppmv_conv = 96.06_r_kind/28.964_r_kind*1.0e+3_r_kind logical :: wrf_pm2_5 + logical :: lread_ext_aerosol ! if true, will read in aerosols from aerfXX rather than from sigfXX real(r_kind),parameter :: s_2_5=0.942_r_kind,d_2_5=0.286_r_kind,& d_10=0.87_r_kind,nh4_mfac=1.375_r_kind,oc_mfac=1.8_r_kind @@ -209,6 +212,8 @@ end subroutine init_aerotot_guess subroutine init_chem ! prgmmr: pagowski date: 2010-09-13 +! program history log: +! 2019-03-21 Martin - cleaned up contribution from S-W Wei at UAlbany !initialiazes default values to &CHEM namelist parameters @@ -234,6 +239,7 @@ subroutine init_chem wrf_pm2_5=.false. aero_ratios=.false. + lread_ext_aerosol = .false. end subroutine init_chem diff --git a/src/gsi/class_get_fv3_regional_ensperts.f90 b/src/gsi/class_get_fv3_regional_ensperts.f90 new file mode 100644 index 000000000..6c51a4fd8 --- /dev/null +++ b/src/gsi/class_get_fv3_regional_ensperts.f90 @@ -0,0 +1,49 @@ +module abstract_get_fv3_regional_ensperts_mod +!$$$ module documentation block +! . . . . +! module: abstract_get_fv3_regional_ensperts_mod +! first copied from class_get_wrf_nmm_ensperts.f90 +! prgmmr: Ting , EMC/NCEP +! +! abstract: IO routines for regional FV3 +! +! program history log: +! +! subroutines included: +! +! variable definitions: +! +! attributes: +! langauge: f90 +! machine: +! +!$$$ end documentation block + type, abstract :: abstract_get_fv3_regional_ensperts_class + contains + procedure(get_fv3_regional_ensperts), deferred, pass(this) :: get_fv3_regional_ensperts + end type abstract_get_fv3_regional_ensperts_class + + abstract interface + subroutine get_fv3_regional_ensperts(this,en_perts,nelen,ps_bar) + use gsi_bundlemod, only: gsi_bundle + use kinds, only: r_kind,i_kind,r_single + + import abstract_get_fv3_regional_ensperts_class + implicit none + class(abstract_get_fv3_regional_ensperts_class),intent(inout) :: this + type(gsi_bundle),allocatable, intent(inout) :: en_perts(:,:) + integer(i_kind), intent(in ):: nelen + real(r_single),dimension(:,:,:),allocatable, intent(inout):: ps_bar + + end subroutine get_fv3_regional_ensperts + end interface + abstract interface + + subroutine convert_binary_fv3_regional_ens(this) + import abstract_get_fv3_regional_ensperts_class + implicit none + class(abstract_get_fv3_regional_ensperts_class),intent(inout) :: this + end subroutine convert_binary_fv3_regional_ens + end interface + +end module abstract_get_fv3_regional_ensperts_mod diff --git a/src/class_get_pseudo_ensperts.f90 b/src/gsi/class_get_pseudo_ensperts.f90 similarity index 100% rename from src/class_get_pseudo_ensperts.f90 rename to src/gsi/class_get_pseudo_ensperts.f90 diff --git a/src/class_get_wrf_mass_ensperts.f90 b/src/gsi/class_get_wrf_mass_ensperts.f90 similarity index 100% rename from src/class_get_wrf_mass_ensperts.f90 rename to src/gsi/class_get_wrf_mass_ensperts.f90 diff --git a/src/class_get_wrf_nmm_ensperts.f90 b/src/gsi/class_get_wrf_nmm_ensperts.f90 similarity index 100% rename from src/class_get_wrf_nmm_ensperts.f90 rename to src/gsi/class_get_wrf_nmm_ensperts.f90 diff --git a/src/class_read_wrf_mass_files.f90 b/src/gsi/class_read_wrf_mass_files.f90 similarity index 100% rename from src/class_read_wrf_mass_files.f90 rename to src/gsi/class_read_wrf_mass_files.f90 diff --git a/src/class_read_wrf_mass_guess.f90 b/src/gsi/class_read_wrf_mass_guess.f90 similarity index 100% rename from src/class_read_wrf_mass_guess.f90 rename to src/gsi/class_read_wrf_mass_guess.f90 diff --git a/src/class_read_wrf_nmm_files.f90 b/src/gsi/class_read_wrf_nmm_files.f90 similarity index 100% rename from src/class_read_wrf_nmm_files.f90 rename to src/gsi/class_read_wrf_nmm_files.f90 diff --git a/src/class_read_wrf_nmm_guess.f90 b/src/gsi/class_read_wrf_nmm_guess.f90 similarity index 100% rename from src/class_read_wrf_nmm_guess.f90 rename to src/gsi/class_read_wrf_nmm_guess.f90 diff --git a/src/class_regional_io.f90 b/src/gsi/class_regional_io.f90 similarity index 100% rename from src/class_regional_io.f90 rename to src/gsi/class_regional_io.f90 diff --git a/src/class_wrf_binary_interface.f90 b/src/gsi/class_wrf_binary_interface.f90 similarity index 100% rename from src/class_wrf_binary_interface.f90 rename to src/gsi/class_wrf_binary_interface.f90 diff --git a/src/class_wrf_netcdf_interface.f90 b/src/gsi/class_wrf_netcdf_interface.f90 similarity index 100% rename from src/class_wrf_netcdf_interface.f90 rename to src/gsi/class_wrf_netcdf_interface.f90 diff --git a/src/class_wrwrfmassa.f90 b/src/gsi/class_wrwrfmassa.f90 similarity index 100% rename from src/class_wrwrfmassa.f90 rename to src/gsi/class_wrwrfmassa.f90 diff --git a/src/class_wrwrfnmma.f90 b/src/gsi/class_wrwrfnmma.f90 similarity index 100% rename from src/class_wrwrfnmma.f90 rename to src/gsi/class_wrwrfnmma.f90 diff --git a/src/cloud_efr_mod.f90 b/src/gsi/cloud_efr_mod.f90 similarity index 97% rename from src/cloud_efr_mod.f90 rename to src/gsi/cloud_efr_mod.f90 index 9c71d37ae..e965d29e3 100644 --- a/src/cloud_efr_mod.f90 +++ b/src/gsi/cloud_efr_mod.f90 @@ -258,7 +258,7 @@ subroutine cloud_calc(p0d,q1d,t1d,clwmr,fice,frain,frimef,& return end subroutine cloud_calc -subroutine cloud_calc_gfs(g_ql,g_qi,g_cwmr,g_q,g_tv,lower_bound) +subroutine cloud_calc_gfs(g_ql,g_qi,g_cwmr,g_q,g_tv,lower_bound,g_cf) !$$$ subprogram documentation block ! . . . . ! subprogram: cloud_calc_gfs calculate cloud mixing ratio @@ -272,6 +272,7 @@ subroutine cloud_calc_gfs(g_ql,g_qi,g_cwmr,g_q,g_tv,lower_bound) ! 2014-11-28 zhu - assign cwgues0 in this subroutine; ! - set lower bound to cloud after assigning cwgues0,change atrribute of g_cwmr ! 2016-04-28 eliu - remove cwgues0 to read_gfs subroutine in ncegfs_io.f90 +! 2019-06-06 eliu - add handling for cloud fraction use gridmod, only: lat2,lon2,nsig @@ -284,6 +285,7 @@ subroutine cloud_calc_gfs(g_ql,g_qi,g_cwmr,g_q,g_tv,lower_bound) real(r_kind),dimension(lat2,lon2,nsig),intent(inout):: g_cwmr ! mixing ratio of total condensates [Kg/Kg] real(r_kind),dimension(lat2,lon2,nsig),intent(in ):: g_q ! specific humidity [Kg/Kg] real(r_kind),dimension(lat2,lon2,nsig),intent(in ):: g_tv ! virtual temperature [K] + real(r_kind),dimension(lat2,lon2,nsig),intent(inout), optional:: g_cf ! cloud fractio logical,intent(in):: lower_bound ! If .true., set lower bound to cloud ! Declare local variables @@ -317,6 +319,17 @@ subroutine cloud_calc_gfs(g_ql,g_qi,g_cwmr,g_q,g_tv,lower_bound) enddo enddo enddo + + if (present(g_cf)) then + do k=1, nsig + do j=1, lon2 + do i=1, lat2 + ! set lower bound to hydrometeors + g_cf(i,j,k) = min(max(zero,g_cf(i,j,k)),one) + enddo + enddo + enddo + endif return end subroutine cloud_calc_gfs diff --git a/src/clw_mod.f90 b/src/gsi/clw_mod.f90 similarity index 97% rename from src/clw_mod.f90 rename to src/gsi/clw_mod.f90 index 475a0e633..512aaded0 100644 --- a/src/clw_mod.f90 +++ b/src/gsi/clw_mod.f90 @@ -38,7 +38,7 @@ module clw_mod ! set default to private private ! set routines used externally to public - public :: calc_clw, ret_amsua + public :: calc_clw, ret_amsua, gmi_37pol_diff contains @@ -63,6 +63,11 @@ subroutine calc_clw(nadir,tb_obs,tsim,ich,nchanl,no85GHz,amsua,ssmi,ssmis,amsre, ! retrieval_gmi subroutine. ! 2015-03-11 ejones- added call to retrieval_amsr2 subroutine ! 2015-03-23 ejones- added call to retrieval_saphir subroutine +! 2015-08-20 zhu - set negative clw to be zero +! 2016-11-07 sienkiewicz - Additional constraint on AMSUA/ATMS ch 1,2 +! for calculating CLW sensitivyt term to exclude +! invalid BT values Leave CLW sensitivity term as 0. +! if retrieval failed ! ! input argument list: ! nadir - scan position @@ -111,6 +116,7 @@ subroutine calc_clw(nadir,tb_obs,tsim,ich,nchanl,no85GHz,amsua,ssmi,ssmis,amsre, ! Declare local parameters real(r_kind),parameter:: r284=284.0_r_kind real(r_kind),parameter:: r285=285.0_r_kind + real(r_kind),parameter:: tbmax=550.0_r_kind ! Declare local variables real(r_kind) tbcx1,tbcx2 @@ -118,9 +124,11 @@ subroutine calc_clw(nadir,tb_obs,tsim,ich,nchanl,no85GHz,amsua,ssmi,ssmis,amsre, if (amsua .or. atms) then + clw = zero ! We want to reject sea ice points that may be frozen. The sea freezes ! around -1.9C but we set the threshold at 1C to be safe. - if(tsavg5>t0c-one .and. tb_obs(1) > zero .and. tb_obs(2) > zero) then + if(tsavg5>t0c-one .and. tb_obs(1) > zero .and. tb_obs(2) > zero .and. & + tb_obs(1) < tbmax .and. tb_obs(2) < tbmax ) then if (adp_anglebc) then tbcx1=tsim(1)+cbias(nadir,ich(1))*ang_rad(ich(1))+predx(1,ich(1))*air_rad(ich(1)) tbcx2=tsim(2)+cbias(nadir,ich(2))*ang_rad(ich(2))+predx(1,ich(2))*air_rad(ich(2)) @@ -137,7 +145,7 @@ subroutine calc_clw(nadir,tb_obs,tsim,ich,nchanl,no85GHz,amsua,ssmi,ssmis,amsre, ierrret = 1 endif else - clw = r1000 +! clw = r1000 ierrret = 1 end if @@ -1915,7 +1923,6 @@ subroutine ret_amsua(tb_obs,nchanl,tsavg5,zasat,clwp_amsua,ierrret,scat) ! surface temperature ! 2014-01-17 zhu - add scattering index scat ! 2014-01-31 mkim - add ierrret return flag for cloud qc near seaice edge -! 2015-08-20 zhu - set negative clw to be zero ! ! input argument list: ! tb_obs - observed brightness temperatures @@ -1947,7 +1954,6 @@ subroutine ret_amsua(tb_obs,nchanl,tsavg5,zasat,clwp_amsua,ierrret,scat) integer(i_kind) ,intent( out) :: ierrret real(r_kind),optional ,intent( out) :: scat -! real(r_kind) :: tpwc_amsua real(r_kind),parameter:: r285=285.0_r_kind real(r_kind),parameter:: r284=284.0_r_kind real(r_kind),parameter:: r1000=1000.0_r_kind @@ -1965,13 +1971,10 @@ subroutine ret_amsua(tb_obs,nchanl,tsavg5,zasat,clwp_amsua,ierrret,scat) if (tsavg5>t0c-one .and. tb_obs(1)<=r284 .and. tb_obs(2)<=r284 .and. & tb_obs(1)>zero .and. tb_obs(2)>zero) then clwp_amsua=cos(zasat)*(d0 + d1*log(r285-tb_obs(1)) + d2*log(r285-tb_obs(2))) -! tpwc_amsua=cos(zasat)*(c0 + c1*log(r285-tb_obs(1)) + c2*log(r285-tb_obs(2))) ierrret = 0 clwp_amsua=max(zero,clwp_amsua) -! tpwc_amsua=max(zero,tpwc_amsua) else clwp_amsua = r1000 -! tpwc_amsua = r1000 ierrret = 1 endif @@ -1983,4 +1986,44 @@ subroutine ret_amsua(tb_obs,nchanl,tsavg5,zasat,clwp_amsua,ierrret,scat) end subroutine ret_amsua +subroutine gmi_37pol_diff(tb37v,tb37h,tsim37v,tsim37h,clw,ierrret) +!$$$ subprogram documentation block +! . . . . +! subprogram: gmi_37pol_diff +! +! prgmmr: Min-Jeong Kim +! +! abstract: calculates cloud amount index over ocean using normalized 37GHz polization difference +! +! output argument list: +! clw +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ +! + use kinds, only: r_kind, i_kind + use constants, only: r1000, zero, one + implicit none + + real(r_kind) ,intent(in ) :: tb37v,tb37h + real(r_kind) ,intent(in ) :: tsim37v,tsim37h + real(r_kind) ,intent( out) :: clw + integer(i_kind) ,intent( out) :: ierrret + +! Declare local variables + + ierrret = 0 + + clw = one - (tb37v-tb37h)/(tsim37v-tsim37h) + clw=max(zero,clw) + if(tb37h > tb37v) then + ierrret = 1 + clw= r1000 + endif + +end subroutine gmi_37pol_diff + end module clw_mod diff --git a/src/cmaq_routines.f90 b/src/gsi/cmaq_routines.f90 similarity index 99% rename from src/cmaq_routines.f90 rename to src/gsi/cmaq_routines.f90 index 5e9c2f5ab..821348835 100644 --- a/src/cmaq_routines.f90 +++ b/src/gsi/cmaq_routines.f90 @@ -95,17 +95,16 @@ subroutine read_cmaq_files(mype) write(6,*)'read_cmaq_files: sigma guess file, nming2 ',hourg,idateg,nming2 t4dv=real((nming2-iwinbgn),r_kind)*r60inv if (l4dvar.or.l4densvar) then - if (t4dvwinlen) go to 110 + if (t4dvwinlen) cycle else ndiff=nming2-nminanl - if(abs(ndiff) > 60*nhr_half ) go to 110 + if(abs(ndiff) > 60*nhr_half ) cycle endif iwan=iwan+1 time_ges(iwan,1) = real((nming2-iwinbgn),r_kind)*r60inv time_ges(iwan+100,1)=i+r0_001 end if -110 continue end do time_ges(201,1)=one diff --git a/src/co_mop_ak.f90 b/src/gsi/co_mop_ak.f90 similarity index 100% rename from src/co_mop_ak.f90 rename to src/gsi/co_mop_ak.f90 diff --git a/src/coinfo.f90 b/src/gsi/coinfo.f90 similarity index 100% rename from src/coinfo.f90 rename to src/gsi/coinfo.f90 diff --git a/src/combine_radobs.f90 b/src/gsi/combine_radobs.f90 similarity index 100% rename from src/combine_radobs.f90 rename to src/gsi/combine_radobs.f90 diff --git a/src/compact_diffs.f90 b/src/gsi/compact_diffs.f90 similarity index 100% rename from src/compact_diffs.f90 rename to src/gsi/compact_diffs.f90 diff --git a/src/compute_derived.f90 b/src/gsi/compute_derived.f90 similarity index 100% rename from src/compute_derived.f90 rename to src/gsi/compute_derived.f90 diff --git a/src/compute_fact10.f90 b/src/gsi/compute_fact10.f90 similarity index 100% rename from src/compute_fact10.f90 rename to src/gsi/compute_fact10.f90 diff --git a/src/compute_qvar3d.f90 b/src/gsi/compute_qvar3d.f90 similarity index 86% rename from src/compute_qvar3d.f90 rename to src/gsi/compute_qvar3d.f90 index 7b296b3b9..54aa7721b 100644 --- a/src/compute_qvar3d.f90 +++ b/src/gsi/compute_qvar3d.f90 @@ -48,6 +48,7 @@ subroutine compute_qvar3d use gsi_bundlemod, only: gsi_bundlegetpointer use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use radiance_mod, only: icloud_cv,n_clouds_fwd,cloud_names_fwd + use obsmod, only: l_wcp_cwm implicit none @@ -58,11 +59,15 @@ subroutine compute_qvar3d real(r_kind) d,dn1,dn2 real(r_kind),allocatable,dimension(:,:,:):: rhgues - integer(i_kind):: istatus,ier + integer(i_kind):: istatus,ier,ier6 real(r_kind):: cwtmp real(r_kind),pointer,dimension(:,:,:):: ges_var=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_ql=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_qi=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qr=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qs=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qg=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qh=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_q =>NULL() integer(i_kind):: maxvarq1 @@ -154,6 +159,11 @@ subroutine compute_qvar3d call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'ql',ges_ql,istatus);ier=istatus call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'qi',ges_qi,istatus);ier=ier+istatus if (ier/=0) return + call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'qr',ges_qr,istatus);ier6=istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'qs',ges_qs,istatus);ier6=ier6+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'qg',ges_qg,istatus);ier6=ier6+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'qh',ges_qh,istatus);ier6=ier6+istatus + if (l_wcp_cwm .and. ier6/=0) return if (cwoption==3) then do k = 1,nsig @@ -163,6 +173,11 @@ subroutine compute_qvar3d dssv(i,j,k,nrf3_cw)=zero else cwtmp=ges_ql(i,j,k)+ges_qi(i,j,k) + if (l_wcp_cwm .and. ier6==0) then + cwtmp=cwtmp & + +ges_qr(i,j,k)+ges_qs(i,j,k) & + +ges_qg(i,j,k)+ges_qh(i,j,k) + endif if (cwtmp<1.0e-10_r_kind) cwtmp=1.0e-10_r_kind dn1=0.05_r_kind*cwtmp dssv(i,j,k,nrf3_cw)=dn1*dssv(i,j,k,nrf3_cw) @@ -176,6 +191,11 @@ subroutine compute_qvar3d do j = 1,lon2 do i = 1,lat2 cwtmp=ges_ql(i,j,k)+ges_qi(i,j,k) + if (l_wcp_cwm .and. ier6==0) then + cwtmp=cwtmp & + +ges_qr(i,j,k)+ges_qs(i,j,k) & + +ges_qg(i,j,k)+ges_qh(i,j,k) + endif if (cwtmp<1.0e-10_r_kind) cwtmp=1.0e-10_r_kind d=-2.0_r_kind*log(cwtmp) + one n=int(d) diff --git a/src/configure b/src/gsi/configure similarity index 100% rename from src/configure rename to src/gsi/configure diff --git a/src/gsi/constants.f90 b/src/gsi/constants.f90 new file mode 100644 index 000000000..9d7e7b067 --- /dev/null +++ b/src/gsi/constants.f90 @@ -0,0 +1,470 @@ +module constants +!$$$ module documentation block +! . . . . +! module: constants +! prgmmr: treadon org: np23 date: 2003-09-25 +! +! abstract: This module contains the definition of various constants +! used in the gsi code +! +! program history log: +! 2003-09-25 treadon - original code +! 2004-03-02 treadon - allow global and regional constants to differ +! 2004-06-16 treadon - update documentation +! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind +! and tiny_single +! 2004-11-16 treadon - add huge_single, huge_r_kind parameters +! 2005-08-24 derber - move cg_term to constants from qcmod +! 2006-03-07 treadon - add rd_over_cp_mass +! 2006-05-18 treadon - add huge_i_kind +! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) +! 2006-07-28 derber - add r1000 +! 2007-03-20 rancic - add r3600 +! 2009-02-05 cucurull - modify refractive indexes for gpsro data +! 2010-08-25 cucurull - add constants to compute compressibility factor +! - add option to use Rueger/Bevis refractive index coeffs +! 2010-12-20 pagowski - add max_varname_length=12 +! 2010-04-01 li - add maximum diurnal thermocline thickness +! 2011-10-27 Huang - add i_missing and r_missing to detect missing values +! 2011-11-01 eliu - add minimum value for cloud water mixing ratio +! 2012-03-07 todling - define lower bound for trace-gases (arbitrary unit as long as small) +! 2016-02-15 Johnson, Y. Wang, X. Wang - define additional constant values for +! radar DA, POC: xuguang.wang@ou.edu +! +! Subroutines Included: +! sub init_constants_derived - compute derived constants +! sub init_constants - set regional/global constants +! sub gps_constants - set Rueger/Bevis refractive index coefficients +! +! Variable Definitions: +! see below +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: r_single,r_kind,i_kind,r_quad,i_long + implicit none + +! set default as private + private +! set subroutines as public + public :: init_constants_derived + public :: init_constants + public :: gps_constants +! set passed variables to public + public :: one,two,half,zero,deg2rad,pi,three,quarter,one_tenth + public :: rad2deg,zero_quad,r3600,r1000,r60inv,five,four,rd_over_cp,grav + public :: rd,rv,rozcon,rearth_equator,zero_single,tiny_r_kind,tiny_single,ten + public :: cvap,cliq,csol + public :: omega,rcp,rearth,fv,h300,cp,cg_term,tpwcon,xb,ttp,psatk,xa,tmix + public :: xai,xbi,psat,eps,omeps,wgtlim,one_quad,two_quad,epsq,climit,epsm1,hvap + public :: hsub,cclimit,el2orc,elocp,h1000,cpr,pcpeff0,pcpeff2,delta,pcpeff1 + public :: factor1,c0,pcpeff3,factor2,dx_inv,dx_min,rhcbot,rhctop,hfus,ke2 + public :: rrow,cmr,cws,r60,huge_i_kind,huge_r_kind,t0c,rd_over_cp_mass + public :: somigliana,grav_equator,grav_ratio,flattening,semi_major_axis + public :: n_b,n_a,eccentricity,huge_single,constoz,g_over_rd,amsua_clw_d2 + public :: amsua_clw_d1,n_c,rd_over_g,zero_ilong + public :: r10,r100,sqrt_tiny_r_kind,r2000,r4000 + public :: r0_01,r0_02,r0_03,r0_04,r0_05,r400,r2400 + public :: cpf_a0, cpf_a1, cpf_a2, cpf_b0, cpf_b1, cpf_c0, cpf_c1, cpf_d, cpf_e + public :: psv_a, psv_b, psv_c, psv_d + public :: ef_alpha, ef_beta, ef_gamma + public :: max_varname_length + public :: z_w_max,tfrozen + public :: qmin,qcmin,tgmin + public :: i_missing, r_missing + public :: tice,t_wfr,e00,rvgas,rdgas,hlv,hlf,cp_vap,c_liq,c_ice,cp_air,cv_air + + public :: izero, qimin, qsmin, qgmin,qrmin + public :: partialSnowThreshold + public :: soilmoistmin + +! Declare derived constants + integer(i_kind):: huge_i_kind + integer(i_kind), parameter :: max_varname_length=32 + real(r_single):: tiny_single, huge_single + real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g + real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 + real(r_kind):: factor1, huge_r_kind, tiny_r_kind, deg2rad, pi, rad2deg, cg_term + real(r_kind):: eccentricity_linear, cv, rv, rd_over_cp_mass, cliq, rd, cp_mass + real(r_kind):: eccentricity, grav, rearth, r60inv + real(r_kind):: sqrt_tiny_r_kind + real(r_kind):: n_a, n_b, n_c + +! Define constants common to global and regional applications + real(r_kind),parameter:: rearth_equator= 6.37813662e6_r_kind ! equatorial earth radius (m) + real(r_kind),parameter:: omega = 7.2921e-5_r_kind ! angular velocity of earth (1/s) + real(r_kind),parameter:: cp = 1.0046e+3_r_kind ! specific heat of air @pressure (J/kg/K) + real(r_kind),parameter:: cvap = 1.8460e+3_r_kind ! specific heat of h2o vapor (J/kg/K) + real(r_kind),parameter:: csol = 2.1060e+3_r_kind ! specific heat of solid h2o (ice)(J/kg/K) + real(r_kind),parameter:: hvap = 2.5000e+6_r_kind ! latent heat of h2o condensation (J/kg) + real(r_kind),parameter:: hfus = 3.3358e+5_r_kind ! latent heat of h2o fusion (J/kg) + real(r_kind),parameter:: psat = 6.1078e+2_r_kind ! pressure at h2o triple point (Pa) + real(r_kind),parameter:: t0c = 2.7315e+2_r_kind ! temperature at zero celsius (K) + real(r_kind),parameter:: ttp = 2.7316e+2_r_kind ! temperature at h2o triple point (K) + real(r_kind),parameter:: jcal = 4.1855e+0_r_kind ! joules per calorie () +! real(r_kind),parameter:: stndrd_atmos_ps = 1013.25e2_r_kind ! 1976 US standard atmosphere ps (Pa) + +! Numeric constants + + integer(i_long),parameter:: zero_ilong = 0_i_long + + real(r_single),parameter:: zero_single= 0.0_r_single + + real(r_kind),parameter:: zero = 0.0_r_kind + real(r_kind),parameter:: r0_01 = 0.01_r_kind + real(r_kind),parameter:: r0_02 = 0.02_r_kind + real(r_kind),parameter:: r0_03 = 0.03_r_kind + real(r_kind),parameter:: r0_04 = 0.04_r_kind + real(r_kind),parameter:: r0_05 = 0.05_r_kind + real(r_kind),parameter:: one_tenth = 0.10_r_kind + real(r_kind),parameter:: quarter = 0.25_r_kind + real(r_kind),parameter:: one = 1.0_r_kind + real(r_kind),parameter:: two = 2.0_r_kind + real(r_kind),parameter:: three = 3.0_r_kind + real(r_kind),parameter:: four = 4.0_r_kind + real(r_kind),parameter:: five = 5.0_r_kind + real(r_kind),parameter:: ten = 10.0_r_kind + real(r_kind),parameter:: r10 = 10.0_r_kind + real(r_kind),parameter:: r60 = 60._r_kind + real(r_kind),parameter:: r100 = 100.0_r_kind + real(r_kind),parameter:: r400 = 400.0_r_kind + real(r_kind),parameter:: r1000 = 1000.0_r_kind + real(r_kind),parameter:: r2000 = 2000.0_r_kind + real(r_kind),parameter:: r2400 = 2400.0_r_kind + real(r_kind),parameter:: r4000 = 4000.0_r_kind + real(r_kind),parameter:: r3600 = 3600.0_r_kind + + real(r_kind),parameter:: z_w_max = 30.0_r_kind ! maximum diurnal thermocline thickness + real(r_kind),parameter:: tfrozen = 271.2_r_kind ! sea water frozen point temperature + + real(r_quad),parameter:: zero_quad = 0.0_r_quad + real(r_quad),parameter:: one_quad = 1.0_r_quad + real(r_quad),parameter:: two_quad = 2.0_r_quad + +! Constants for compressibility factor (Davis et al 1992) + real(r_kind),parameter:: cpf_a0 = 1.58123e-6_r_kind ! K/Pa + real(r_kind),parameter:: cpf_a1 = -2.9331e-8_r_kind ! 1/Pa + real(r_kind),parameter:: cpf_a2 = 1.1043e-10_r_kind ! 1/K 1/Pa + real(r_kind),parameter:: cpf_b0 = 5.707e-6_r_kind ! K/Pa + real(r_kind),parameter:: cpf_b1 = -2.051e-8_r_kind ! 1/Pa + real(r_kind),parameter:: cpf_c0 = 1.9898e-4_r_kind ! K/Pa + real(r_kind),parameter:: cpf_c1 = -2.376e-6_r_kind ! 1/Pa + real(r_kind),parameter:: cpf_d = 1.83e-11_r_kind ! K2/Pa2 + real(r_kind),parameter:: cpf_e = -0.765e-8_r_kind ! K2/Pa2 + +! Constants for vapor pressure at saturation + real(r_kind),parameter:: psv_a = 1.2378847e-5_r_kind ! (1/K2) + real(r_kind),parameter:: psv_b = -1.9121316e-2_r_kind ! (1/K) + real(r_kind),parameter:: psv_c = 33.93711047_r_kind ! + real(r_kind),parameter:: psv_d = -6.3431645e+3_r_kind ! (K) + +! Constants for enhancement factor to calculating the mole fraction of water vapor + real(r_kind),parameter:: ef_alpha = 1.00062_r_kind ! + real(r_kind),parameter:: ef_beta = 3.14e-8_r_kind ! (1/Pa) + real(r_kind),parameter:: ef_gamma = 5.6e-7_r_kind ! (1/K2) + +! Parameters below from WGS-84 model software inside GPS receivers. + real(r_kind),parameter:: semi_major_axis = 6378.1370e3_r_kind ! (m) + real(r_kind),parameter:: semi_minor_axis = 6356.7523142e3_r_kind ! (m) + real(r_kind),parameter:: grav_polar = 9.8321849378_r_kind ! (m/s2) + real(r_kind),parameter:: grav_equator = 9.7803253359_r_kind ! (m/s2) + real(r_kind),parameter:: earth_omega = 7.292115e-5_r_kind ! (rad/s) + real(r_kind),parameter:: grav_constant = 3.986004418e14_r_kind ! (m3/s2) + +! Derived geophysical constants + real(r_kind),parameter:: flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis + real(r_kind),parameter:: somigliana = & + (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one + real(r_kind),parameter:: grav_ratio = (earth_omega*earth_omega * & + semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant + +! Derived thermodynamic constants + real(r_kind),parameter:: dldti = cvap-csol + real(r_kind),parameter:: hsub = hvap+hfus + real(r_kind),parameter:: psatk = psat*0.001_r_kind + real(r_kind),parameter:: tmix = ttp-20._r_kind + real(r_kind),parameter:: elocp = hvap/cp + real(r_kind),parameter:: rcp = one/cp + + real(r_kind),parameter:: tice = t0c ! temperature at 0 deg C [K] + real(r_kind),parameter:: t_wfr = t0c - 40.0_r_kind ! homogeneous freezing temperature + real(r_kind),parameter:: e00 = psat ! saturation vapor pressure at 0 deg C (611.21 Pa) + real(r_kind),parameter:: hlv = hvap ! latent heat of evaporation + real(r_kind),parameter:: hlf = hfus ! latent heat of fusion + real(r_kind),parameter:: cp_vap = cvap ! heat capacity of water vapor at const. pressure + real(r_kind),parameter:: rvgas = 4.6150e+2_r_kind ! gas constant for waver vapor + real(r_kind),parameter:: rdgas = 2.8705e+2_r_kind ! gas constant for dry air + real(r_kind),parameter:: c_liq = 4.1855e+3_r_kind ! heat capacity of water at 15 deg C + real(r_kind),parameter:: c_ice = 1972.0_r_kind ! heat capacity of ice at -15 deg C (csol) + real(r_kind),parameter:: cp_air = 1.0046e+3_r_kind ! heat capacity of dry air at constant pressure (hydrostatic) + real(r_kind),parameter:: cv_air = cp_air - rdgas ! heat capacity of dry air at constant volume (non-hydrostatic) + +! Constants used in GFS moist physics + real(r_kind),parameter:: h300 = 300._r_kind + real(r_kind),parameter:: half = 0.5_r_kind + real(r_kind),parameter:: cclimit = 0.001_r_kind + real(r_kind),parameter:: climit = 1.e-20_r_kind + real(r_kind),parameter:: epsq = 2.e-12_r_kind + real(r_kind),parameter:: h1000 = r1000 + real(r_kind),parameter:: rhcbot=0.85_r_kind + real(r_kind),parameter:: rhctop=0.85_r_kind + real(r_kind),parameter:: dx_max=-8.8818363_r_kind + real(r_kind),parameter:: dx_min=-5.2574954_r_kind + real(r_kind),parameter:: dx_inv=one/(dx_max-dx_min) + real(r_kind),parameter:: c0=0.002_r_kind + real(r_kind),parameter:: delta=0.6077338_r_kind + real(r_kind),parameter:: pcpeff0=1.591_r_kind + real(r_kind),parameter:: pcpeff1=-0.639_r_kind + real(r_kind),parameter:: pcpeff2=0.0953_r_kind + real(r_kind),parameter:: pcpeff3=-0.00496_r_kind + real(r_kind),parameter:: cmr = one/0.0003_r_kind + real(r_kind),parameter:: cws = 0.025_r_kind + real(r_kind),parameter:: ke2 = 0.00002_r_kind + real(r_kind),parameter:: row = r1000 + real(r_kind),parameter:: rrow = one/row +! real(r_kind),parameter:: qmin = 1.e-7_r_kind !lower bound on ges_q + +! Constant used to process ozone + real(r_kind),parameter:: constoz = 604229.0_r_kind + +! Constants used in cloud liquid water correction for AMSU-A +! brightness temperatures + real(r_kind),parameter:: amsua_clw_d1 = 0.754_r_kind + real(r_kind),parameter:: amsua_clw_d2 = -2.265_r_kind + +! Constants used for variational qc + real(r_kind),parameter:: wgtlim = quarter ! Cutoff weight for concluding that obs has been + ! rejected by nonlinear qc. This limit is arbitrary + ! and DOES NOT affect nonlinear qc. It only affects + ! the printout which "counts" the number of obs that + ! "fail" nonlinear qc. Observations counted as failing + ! nonlinear qc are still assimilated. Their weight + ! relative to other observations is reduced. Changing + ! wgtlim does not alter the analysis, only + ! the nonlinear qc data "count" + +! Minimum values for water vapor, cloud water mixing ratio, and trace gases + real(r_kind),parameter:: qmin = 1.e-07_r_kind ! lower bound on ges_q + real(r_kind),parameter:: qcmin = 0.0_r_kind ! lower bound on ges_cw + real(r_kind),parameter:: tgmin = 1.e-15_r_kind ! lower bound on trace gases + + integer(i_kind),parameter:: izero = 0 + real(r_kind),parameter:: qimin = 0.0_r_kind + real(r_kind),parameter:: qgmin = 0.0_r_kind + real(r_kind),parameter:: qsmin = 0.0_r_kind + real(r_kind),parameter:: qrmin = 0.0_r_kind + real(r_kind),parameter:: log10qcmin = -10_r_single + real(r_kind),parameter:: r10log10qcmin = 1.0e-10_r_single + real(r_kind),parameter:: log10qrmin = -6.0_r_single + real(r_kind),parameter:: r10log10qrmin = 1.0e-6_r_single + real(r_kind),parameter:: log10qimin = -8_r_single + real(r_kind),parameter:: r10log10qimin = 1.0e-8_r_single + real(r_kind),parameter:: log10qgmin = -8_r_single + real(r_kind),parameter:: r10log10qgmin = 1.0e-8_r_single + real(r_kind),parameter:: log10qsmin = -9_r_single + real(r_kind),parameter:: r10log10qsmin = 1.0e-9_r_single + +! Minimum values for soil adjustment + real(r_single),parameter:: soilmoistmin = 0.002_r_single ! minimum soil + ! moisture (sand) + real(r_kind), parameter :: partialSnowThreshold = 32._r_kind ! mm + +! Constant used to detect missing input value + integer(i_kind),parameter:: i_missing=-9999 + integer(r_kind),parameter:: r_missing=-9999._r_kind + +contains + + subroutine init_constants_derived +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants_derived set derived constants +! prgmmr: treadon org: np23 date: 2004-12-02 +! ! abstract: This routine sets derived constants +! +! program history log: +! 2004-12-02 treadon +! 2005-03-03 treadon - add implicit none +! 2008-06-04 safford - rm unused vars +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + +! Trigonometric constants + pi = acos(-one) + deg2rad = pi/180.0_r_kind + rad2deg = one/deg2rad + cg_term = (sqrt(two*pi))/two ! constant for variational qc + tiny_r_kind = tiny(zero) + sqrt_tiny_r_kind = r10*sqrt(tiny_r_kind) + huge_r_kind = huge(zero) + tiny_single = tiny(zero_single) + huge_single = huge(zero_single) + huge_i_kind = huge(0) + r60inv=one/r60 + +! Geophysical parameters used in conversion of geopotential to +! geometric height + eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) + eccentricity = eccentricity_linear / semi_major_axis + + return + end subroutine init_constants_derived + + subroutine init_constants(regional) +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants set regional or global constants +! prgmmr: treadon org: np23 date: 2004-03-02 +! +! abstract: This routine sets constants specific to regional or global +! applications of the gsi +! +! program history log: +! 2004-03-02 treadon +! 2004-06-16 treadon, documentation +! 2004-10-28 treadon - use intrinsic TINY function to set value +! for smallest machine representable positive +! number +! 2004-12-03 treadon - move derived constants to init_constants_derived +! 2005-03-03 treadon - add implicit none +! +! input argument list: +! regional - if .true., set regional gsi constants; +! otherwise (.false.), use global constants +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + + logical,intent(in ) :: regional + + real(r_kind) reradius,g,r_d,r_v,cliq_wrf + +! Define regional constants here + if (regional) then + +! Name given to WRF constants + reradius = one/6370.e03_r_kind + g = 9.81_r_kind + r_d = 287.04_r_kind + r_v = 461.6_r_kind + cliq_wrf = 4190.0_r_kind + cp_mass = 1004.67_r_kind + +! Transfer WRF constants into unified GSI constants + rearth = one/reradius + grav = g + rd = r_d + rv = r_v + cv = cp-r_d + cliq = cliq_wrf + +! Define global constants here + else + rearth = 6.3712e+6_r_kind + grav = 9.80665e+0_r_kind + rd = 2.8705e+2_r_kind + rv = 4.6150e+2_r_kind + cv = 7.1760e+2_r_kind + cliq = 4.1855e+3_r_kind + cp_mass= cp + endif + + +! Now define derived constants which depend on constants +! which differ between global and regional applications. + +! Constants related to ozone assimilation + rd_over_cp_mass = rd / cp_mass + ozcon = grav*21.4e-9_r_kind + rozcon= one/ozcon + +! Constant used in vertical integral for precipitable water + tpwcon = 100.0_r_kind/grav + +! Derived atmospheric constants + fv = rv/rd-one ! used in virtual temperature equation + dldt = cvap-cliq + xa = -(dldt/rv) + xai = -(dldti/rv) + xb = xa+hvap/(rv*ttp) + xbi = xai+hsub/(rv*ttp) + eps = rd/rv + epsm1 = rd/rv-one + omeps = one-eps + factor1 = (cvap-cliq)/rv + factor2 = hvap/rv-factor1*t0c + cpr = cp*rd + el2orc = hvap*hvap/(rv*cp) + rd_over_g = rd/grav + rd_over_cp = rd/cp + g_over_rd = grav/rd + + return + end subroutine init_constants + + subroutine gps_constants(use_compress) +!$$$ subprogram documentation block +! . . . . +! subprogram: gps_constants set Bevis or Rueger refractive index coeff +! prgmmr: cucurull org: np23 date: 2010-08-25 +! +! abstract: This routine sets constants for the refractivity equation. GSI uses Bevis +! coefficients when the compressibility factors option is turned off +! and uses Rueger coefficients otherwise. +! +! program history log: +! 2010-08-25 cucurull +! 2010-08-25 cucurull, documentation +! +! input argument list: +! compress - if .true., set Rueger coefficients; +! otherwise (.false.), use Bevis coefficients +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + + logical,intent(in ) :: use_compress + +! Define refractive index coefficients here + if (use_compress) then + + ! Constants for gpsro data (Rueger 2002) + n_a = 77.6890_r_kind ! K/mb + n_b = 3.75463e+5_r_kind ! K^2/mb + n_c = 71.2952_r_kind ! K/mb + else + ! Constants for gpsro data (Bevis et al 1994) + n_a = 77.60_r_kind ! K/mb + n_b = 3.739e+5_r_kind ! K^2/mb + n_c = 70.4_r_kind ! K/mb + endif + + return + end subroutine gps_constants + +end module constants diff --git a/src/control2model.f90 b/src/gsi/control2model.f90 similarity index 100% rename from src/control2model.f90 rename to src/gsi/control2model.f90 diff --git a/src/control2model_ad.f90 b/src/gsi/control2model_ad.f90 similarity index 100% rename from src/control2model_ad.f90 rename to src/gsi/control2model_ad.f90 diff --git a/src/control2state.f90 b/src/gsi/control2state.f90 similarity index 90% rename from src/control2state.f90 rename to src/gsi/control2state.f90 index 41f4176b9..c652d1574 100644 --- a/src/control2state.f90 +++ b/src/gsi/control2state.f90 @@ -42,6 +42,7 @@ subroutine control2state(xhat,sval,bval) ! 2014-12-03 derber - introduce parallel regions for optimization ! 2015-07-10 pondeca - add cldch ! 2016-05-03 pondeca - add uwnd10m and vwnd10m +! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu ! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars. ! ! input argument list: @@ -62,6 +63,7 @@ subroutine control2state(xhat,sval,bval) use gridmod, only: regional,lat2,lon2,nsig, nlat, nlon, twodvar_regional use jfunc, only: nsclen,npclen,ntclen use cwhydromod, only: cw2hydro_tl +use cwhydromod, only: cw2hydro_tl_hwrf use gsi_bundlemod, only: gsi_bundlecreate use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -75,6 +77,7 @@ subroutine control2state(xhat,sval,bval) use constants, only : max_varname_length, zero use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_commvars_mod, only: s2g_cv +use gridmod, only: nems_nmmb_regional implicit none ! Declare passed variables @@ -104,7 +107,6 @@ subroutine control2state(xhat,sval,bval) 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() -real(r_kind),pointer,dimension(:,:) :: cv_vis=>NULL() real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() @@ -113,32 +115,32 @@ subroutine control2state(xhat,sval,bval) real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() -real(r_kind),pointer,dimension(:,:) :: cv_cldch=>NULL() ! Declare required local state variables -integer(i_kind), parameter :: nsvars = 8 +integer(i_kind), parameter :: nsvars = 12 integer(i_kind) :: isps(nsvars) character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ' /) + 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & + 'qr ', 'qs ', 'qg ', 'qh ' /) logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi +logical :: ls_qr,ls_qs,ls_qg,ls_qh real(r_kind),pointer,dimension(:,:) :: sv_ps=>NULL(),sv_sst=>NULL() -real(r_kind),pointer,dimension(:,:) :: sv_gust=>NULL(),sv_vis=>NULL() -real(r_kind),pointer,dimension(:,:) :: sv_pblh=>NULL(),sv_wspd10m=>NULL() -real(r_kind),pointer,dimension(:,:) :: sv_tcamt=>NULL(),sv_lcbas=>NULL() -real(r_kind),pointer,dimension(:,:) :: sv_td2m=>NULL(),sv_mxtm=>NULL() -real(r_kind),pointer,dimension(:,:) :: sv_mitm=>NULL(),sv_pmsl=>NULL() -real(r_kind),pointer,dimension(:,:) :: sv_howv=>NULL(),sv_cldch=>NULL() +real(r_kind),pointer,dimension(:,:) :: sv_gust=>NULL(),sv_vis=>NULL(),sv_pblh=>NULL() +real(r_kind),pointer,dimension(:,:) :: sv_wspd10m=>NULL(),sv_tcamt=>NULL(),sv_lcbas=>NULL() +real(r_kind),pointer,dimension(:,:) :: sv_td2m=>NULL(),sv_mxtm=>NULL(),sv_mitm=>NULL() +real(r_kind),pointer,dimension(:,:) :: sv_pmsl=>NULL(),sv_howv=>NULL(),sv_cldch=>NULL() real(r_kind),pointer,dimension(:,:) :: sv_uwnd10m=>NULL(),sv_vwnd10m=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: sv_u=>NULL(),sv_v=>NULL(),sv_w=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: sv_prse=>NULL(),sv_q=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: sv_tsen=>NULL(),sv_tv=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: sv_oz=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: sv_u=>NULL(),sv_v=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: sv_w=>NULL(),sv_dw=>NULL(),sv_prse=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: sv_q=>NULL(),sv_tsen=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: sv_tv=>NULL(),sv_oz=>NULL() real(r_kind),pointer,dimension(:,:,:) :: sv_rank3=>NULL() real(r_kind),pointer,dimension(:,:) :: sv_rank2=>NULL() real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter logical :: do_getprs_tl,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro +logical :: do_cw_to_hydro_hwrf !****************************************************************************** @@ -178,6 +180,8 @@ subroutine control2state(xhat,sval,bval) ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 ls_qi =isps(7)>0; ls_w =isps(8)>0 +ls_qr =isps(9)>0; ls_qs =isps(10)>0 +ls_qg =isps(11)>0; ls_qh =isps(12)>0 ! Define what to do depending on what's in CV and SV do_getprs_tl =lc_ps.and.lc_t .and.ls_prse @@ -186,8 +190,10 @@ subroutine control2state(xhat,sval,bval) do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v do_cw_to_hydro=.false. +do_cw_to_hydro_hwrf=.false. if (regional) then do_cw_to_hydro=lc_cw.and.ls_ql.and.ls_qi + do_cw_to_hydro_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh else do_cw_to_hydro=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global endif @@ -231,7 +237,7 @@ subroutine control2state(xhat,sval,bval) call general_grid2sub(s2g_cv,hwork,wbundle%values) end if -!$omp parallel sections private(istatus,ii,ic,id) +!$omp parallel sections private(istatus,ii,ic,id,sv_u,sv_v,sv_prse,sv_q,sv_tsen,uland,vland,uwter,vwter) !$omp section @@ -279,7 +285,6 @@ subroutine control2state(xhat,sval,bval) call gsi_bundlegetpointer (sval(jj),'tv' ,sv_tv, istatus) call gsi_bundlegetpointer (sval(jj),'tsen',sv_tsen,istatus) call gsi_bundlegetpointer (sval(jj),'q' ,sv_q , istatus) - call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus) call gsi_bundlegetpointer (wbundle,'t' ,cv_t, istatus) call gsi_bundlegetpointer (wbundle,'q' ,cv_rh ,istatus) @@ -296,10 +301,17 @@ subroutine control2state(xhat,sval,bval) ! Copy other variables call gsi_bundlegetvar ( wbundle, 't' , sv_tv, istatus ) - if (do_cw_to_hydro) then + if (do_cw_to_hydro .and. .not.do_cw_to_hydro_hwrf) then ! Case when cloud-vars do not map one-to-one (cv-to-sv) ! e.g. cw-to-ql&qi call cw2hydro_tl(sval(jj),wbundle,clouds,nclouds) + elseif (do_cw_to_hydro_hwrf) then +! Case when cloud-vars do not map one-to-one (cv-to-sv) +! e.g. cw-to-ql&qi&qr&qs&qg&qh + if (.not.do_tv_to_tsen) then + call tv_to_tsen(cv_t,sv_q,sv_tsen) + endif + call cw2hydro_tl_hwrf(sval(jj),wbundle,sv_tsen) else ! Case when cloud-vars map one-to-one (cv-to-sv), take care of them together ! e.g. cw-to-cw @@ -332,10 +344,8 @@ subroutine control2state(xhat,sval,bval) call gsi_bundlegetvar ( wbundle, 'pblh', sv_pblh, istatus ) end if if (icvis >0) then - call gsi_bundlegetpointer (wbundle,'vis',cv_vis,istatus) call gsi_bundlegetpointer (sval(jj),'vis' ,sv_vis , istatus) - ! Convert log(vis) to vis - call logvis_to_vis(cv_vis,sv_vis) + call gsi_bundlegetvar (wbundle,'vis',sv_vis,istatus) end if if (icwspd10m>0) then call gsi_bundlegetpointer (sval(jj),'wspd10m' ,sv_wspd10m, istatus) @@ -364,6 +374,10 @@ subroutine control2state(xhat,sval,bval) if (icw>0) then call gsi_bundlegetpointer (sval(jj),'w' ,sv_w, istatus) call gsi_bundlegetvar ( wbundle, 'w', sv_w, istatus ) + if(nems_nmmb_regional)then + call gsi_bundlegetpointer (sval(jj),'dw' ,sv_dw, istatus) + call gsi_bundlegetvar ( wbundle, 'dw' , sv_dw, istatus ) + end if end if if (ictcamt>0) then call gsi_bundlegetpointer (sval(jj),'tcamt' ,sv_tcamt, istatus) @@ -376,10 +390,8 @@ subroutine control2state(xhat,sval,bval) call loglcbas_to_lcbas(cv_lcbas,sv_lcbas) end if if (iccldch >0) then - call gsi_bundlegetpointer (wbundle,'cldch',cv_cldch,istatus) call gsi_bundlegetpointer (sval(jj),'cldch' ,sv_cldch , istatus) - ! Convert log(cldch) to cldch - call logcldch_to_cldch(cv_cldch,sv_cldch) + call gsi_bundlegetvar (wbundle,'cldch',sv_cldch,istatus) end if if (icuwnd10m>0) then call gsi_bundlegetpointer (sval(jj),'uwnd10m' ,sv_uwnd10m, istatus) diff --git a/src/control2state_ad.f90 b/src/gsi/control2state_ad.f90 similarity index 91% rename from src/control2state_ad.f90 rename to src/gsi/control2state_ad.f90 index 7c14f0eb0..ed4f8a759 100644 --- a/src/control2state_ad.f90 +++ b/src/gsi/control2state_ad.f90 @@ -39,6 +39,7 @@ subroutine control2state_ad(rval,bval,grad) ! 2014-12-03 derber - introduce parallel regions for optimization ! 2015-07-10 pondeca - add cloud ceiling height (cldch) ! 2016-05-03 pondeca - add uwnd10m, and vwnd10m +! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu ! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars. ! 2016-05-03 pondeca - add uwnd10m, and vwnd10m ! @@ -57,6 +58,7 @@ subroutine control2state_ad(rval,bval,grad) use gridmod, only: regional,lat2,lon2,nsig,twodvar_regional use jfunc, only: nsclen,npclen,ntclen use cwhydromod, only: cw2hydro_ad +use cwhydromod, only: cw2hydro_ad_hwrf use gsi_bundlemod, only: gsi_bundlecreate use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -67,6 +69,7 @@ subroutine control2state_ad(rval,bval,grad) use gsi_metguess_mod, only: gsi_metguess_get use mpeu_util, only: getindex use constants, only: max_varname_length,zero +use gridmod, only: nems_nmmb_regional implicit none @@ -95,7 +98,6 @@ subroutine control2state_ad(rval,bval,grad) 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() -real(r_kind),pointer,dimension(:,:) :: cv_vis=>NULL() real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() @@ -104,32 +106,30 @@ subroutine control2state_ad(rval,bval,grad) real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() -real(r_kind),pointer,dimension(:,:) :: cv_cldch=>NULL() ! Declare required local state variables -integer(i_kind), parameter :: nsvars = 8 +integer(i_kind), parameter :: nsvars = 12 integer(i_kind) :: isps(nsvars) character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ' /) + 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & + 'qr ', 'qs ', 'qg ', 'qh ' /) logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi +logical :: ls_qr,ls_qs,ls_qg,ls_qh real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL(),rv_sst=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_pblh=>NULL(),rv_wspd10m=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_tcamt=>NULL(),rv_lcbas=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_mitm=>NULL(),rv_pmsl=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_howv=>NULL(),rv_cldch=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_wspd10m=>NULL(),rv_tcamt,rv_lcbas=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL() real(r_kind),pointer,dimension(:,:) :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_w=>NULL(),rv_prse=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_tv=>NULL(),rv_oz=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL() real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL() real(r_kind),pointer,dimension(:,:) :: rv_rank2=>NULL() real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad,do_cw_to_hydro_ad +logical :: do_cw_to_hydro_ad_hwrf !****************************************************************************** @@ -165,6 +165,8 @@ subroutine control2state_ad(rval,bval,grad) ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 ls_qi =isps(7)>0; ls_w =isps(8)>0 +ls_qr =isps(9)>0; ls_qs =isps(10)>0 +ls_qg =isps(11)>0; ls_qh =isps(12)>0 ! Define what to do depending on what's in CV and SV do_getuv =lc_sf.and.lc_vp.and.ls_u .and.ls_v @@ -173,8 +175,10 @@ subroutine control2state_ad(rval,bval,grad) do_getprs_ad =lc_t .and.lc_ps.and.ls_prse do_cw_to_hydro_ad=.false. +do_cw_to_hydro_ad_hwrf=.false. if (regional) then do_cw_to_hydro_ad=lc_cw.and.ls_ql.and.ls_qi + do_cw_to_hydro_ad_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh else do_cw_to_hydro_ad=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global endif @@ -208,7 +212,7 @@ subroutine control2state_ad(rval,bval,grad) call stop2(999) endif -!$omp parallel sections private(istatus,ii,ic,id,istatus_oz) +!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter) !$omp section @@ -273,10 +277,14 @@ subroutine control2state_ad(rval,bval,grad) call gsi_bundleputvar ( wbundle, 'q' , zero, istatus ) call gsi_bundleputvar ( wbundle, 'ps', rv_ps, istatus ) - if (do_cw_to_hydro_ad) then + if (do_cw_to_hydro_ad .and. .not.do_cw_to_hydro_ad_hwrf) then ! Case when cloud-vars do not map one-to-one ! e.g. cw-to-ql&qi call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds) + elseif (do_cw_to_hydro_ad_hwrf) then +! Case when cloud-vars do not map one-to-one +! e.g. cw-to-ql&qi&qr&qs&qg&qh + call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen) else ! Case when cloud-vars map one-to-one, take care of them together ! e.g. cw-to-cw @@ -332,11 +340,8 @@ subroutine control2state_ad(rval,bval,grad) call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus ) end if if (icvis >0) then - call gsi_bundlegetpointer (wbundle,'vis' ,cv_vis ,istatus) call gsi_bundlegetpointer (rval(jj),'vis' ,rv_vis , istatus) - call gsi_bundleputvar ( wbundle, 'vis' , zero , istatus ) - ! Adjoint of convert logvis to vis - call logvis_to_vis_ad(cv_vis,rv_vis) + call gsi_bundleputvar ( wbundle, 'vis' , rv_vis , istatus ) end if if (icpblh>0)then call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus) @@ -369,6 +374,10 @@ subroutine control2state_ad(rval,bval,grad) if (icw>0) then call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus) call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus ) + if(nems_nmmb_regional)then + call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus) + call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus ) + end if end if if (ictcamt>0) then call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus) @@ -382,11 +391,8 @@ subroutine control2state_ad(rval,bval,grad) call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas) end if if (iccldch >0) then - call gsi_bundlegetpointer (wbundle,'cldch' ,cv_cldch ,istatus) call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus) - call gsi_bundleputvar ( wbundle, 'cldch' , zero , istatus ) - ! Adjoint of convert logcldch to cldch - call logcldch_to_cldch_ad(cv_cldch,rv_cldch) + call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch , istatus ) end if if (icuwnd10m>0) then call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus) diff --git a/src/control_vectors.f90 b/src/gsi/control_vectors.f90 similarity index 98% rename from src/control_vectors.f90 rename to src/gsi/control_vectors.f90 index 0f3d28216..01bb3bce4 100644 --- a/src/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -27,6 +27,12 @@ module control_vectors ! 2010-05-28 todling - remove all nrf2/3_VAR-specific "pointers" ! 2011-07-04 todling - fixes to run either single or double precision ! 2013-05-20 zhu - add aircraft temperature bias correction coefficients as control variables +! 2016-02-15 Johnson, Y. Wang, X. Wang - add variables to control reading +! state variables for radar DA. POC: xuguang.wang@ou.edu +! 2019-03-14 eliu - add logic to turn on using full set of hydrometeors +! in obs operator and analysis +! 2019-07-11 Todling - move WRF specific variables w_exist and dbz_exit to a new wrf_vars_mod.f90. +! . move imp_physics and lupp to ncepnems_io.f90. ! ! subroutines included: ! sub init_anacv @@ -58,8 +64,7 @@ module control_vectors ! ! variable definitions: ! def n_ens - number of ensemble perturbations (=0 except when hybrid ensemble option turned on) -! def imp_physics - type of microphysics used in the GFS. 99: Zhao-Carr, 11: GFDL -! def lupp - if T, UPP is used and additional variables are output +! def lcalc_gfdl_cfrac - if T, calculate and use GFDL cloud fraction in obs operator ! ! attributes: ! language: f90 @@ -121,8 +126,7 @@ module control_vectors public as2d ! normalized scale factor for background error 2d-variables public atsfc_sdv ! standard deviation of surface temperature error over (1) land (and (2) ice public an_amp0 ! multiplying factors on reference background error variances -public imp_physics ! type of GFS microphysics -public lupp ! when .t., UPP is used and extra variables are output +public lcalc_gfdl_cfrac ! when .t., calculate and use GFDL cloud fraction in obs operator public nrf2_loc,nrf3_loc,nmotl_loc ! what are these for?? public ntracer @@ -145,8 +149,8 @@ module control_vectors integer(i_kind) :: nclen,nclen1,nsclen,npclen,ntclen,nrclen,nsubwin,nval_len integer(i_kind) :: latlon11,latlon1n,lat2,lon2,nsig,n_ens -integer(i_kind) :: nval_lenz_en,imp_physics -logical :: lsqrtb,lupp +integer(i_kind) :: nval_lenz_en +logical,save :: lsqrtb,lcalc_gfdl_cfrac integer(i_kind) :: m_vec_alloc, max_vec_alloc, m_allocs, m_deallocs @@ -335,7 +339,7 @@ subroutine init_anacv ! want to rid code from the following ... nrf=nc2d+nc3d -allocate(nrf_3d(nrf),nrf2_loc(nc2d),nrf3_loc(nc3d),nmotl_loc(mvars)) +allocate(nrf_3d(nrf),nrf2_loc(nc2d),nrf3_loc(nc3d),nmotl_loc(max(1,mvars))) ! Now load information from table nc3d=0;nc2d=0;mvars=0 @@ -382,9 +386,7 @@ subroutine init_anacv write(6,*) myname_,': MOTLEY CONTROL VARIABLES ', cvarsmd write(6,*) myname_,': ALL CONTROL VARIABLES ', nrf_var end if - -imp_physics=99 -lupp = .false. +lcalc_gfdl_cfrac = .false. end subroutine init_anacv subroutine final_anacv diff --git a/src/convb_ps.f90 b/src/gsi/convb_ps.f90 similarity index 100% rename from src/convb_ps.f90 rename to src/gsi/convb_ps.f90 diff --git a/src/convb_q.f90 b/src/gsi/convb_q.f90 similarity index 100% rename from src/convb_q.f90 rename to src/gsi/convb_q.f90 diff --git a/src/convb_t.f90 b/src/gsi/convb_t.f90 similarity index 100% rename from src/convb_t.f90 rename to src/gsi/convb_t.f90 diff --git a/src/convb_uv.f90 b/src/gsi/convb_uv.f90 similarity index 100% rename from src/convb_uv.f90 rename to src/gsi/convb_uv.f90 diff --git a/src/converr.f90 b/src/gsi/converr.f90 similarity index 100% rename from src/converr.f90 rename to src/gsi/converr.f90 diff --git a/src/converr_ps.f90 b/src/gsi/converr_ps.f90 similarity index 100% rename from src/converr_ps.f90 rename to src/gsi/converr_ps.f90 diff --git a/src/converr_pw.f90 b/src/gsi/converr_pw.f90 similarity index 100% rename from src/converr_pw.f90 rename to src/gsi/converr_pw.f90 diff --git a/src/converr_q.f90 b/src/gsi/converr_q.f90 similarity index 100% rename from src/converr_q.f90 rename to src/gsi/converr_q.f90 diff --git a/src/converr_t.f90 b/src/gsi/converr_t.f90 similarity index 100% rename from src/converr_t.f90 rename to src/gsi/converr_t.f90 diff --git a/src/converr_uv.f90 b/src/gsi/converr_uv.f90 similarity index 100% rename from src/converr_uv.f90 rename to src/gsi/converr_uv.f90 diff --git a/src/convinfo.f90 b/src/gsi/convinfo.f90 old mode 100644 new mode 100755 similarity index 98% rename from src/convinfo.f90 rename to src/gsi/convinfo.f90 index 20cdce0b4..eda9f9e30 --- a/src/convinfo.f90 +++ b/src/gsi/convinfo.f90 @@ -77,11 +77,15 @@ module convinfo public :: use_prepb_satwnd public :: index_sub public :: id_drifter + public :: id_ship + public :: ec_amv_qc logical diag_conv logical :: ihave_pm2_5 logical :: use_prepb_satwnd logical :: id_drifter + logical :: id_ship + logical :: ec_amv_qc=.true. integer(i_kind) nconvtype,mype_conv real(r_kind),allocatable,dimension(:)::ctwind,cgross,cermax,cermin,cvar_b,cvar_pg, & rmesh_conv,pmesh_conv,pmot_conv,ptime_conv @@ -123,6 +127,7 @@ subroutine init_convinfo mype_conv = 0 ! mpi task to collect and print conv obs use information use_prepb_satwnd=.false. ! allow use of satwind stored in prepbufr file id_drifter=.false. ! modify KX of drifting buoys + id_ship=.false. ! modify KX of ships call init_pm2_5 diff --git a/src/convthin.f90 b/src/gsi/convthin.f90 similarity index 86% rename from src/convthin.f90 rename to src/gsi/convthin.f90 index 36de51d1d..cc6d2ed1b 100644 --- a/src/convthin.f90 +++ b/src/gsi/convthin.f90 @@ -147,6 +147,10 @@ subroutine make3grids(rmesh,nlevp) hll(i,j)=itxmax glon(i,j) = rlon_min + (i-1)*delon glon(i,j) = glon(i,j)*deg2rad + + if (glon(i,j) > twopi) glon(i,j) = glon(i,j) - twopi + if (glon(i,j) < zero) glon(i,j) = glon(i,j) + twopi + glon(i,j) = min(max(zero,glon(i,j)),twopi) enddo @@ -241,7 +245,7 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs real(r_kind) dlat1,dlon1,pob1 real(r_kind) dx,dy,dp,dxx,dyy,dpp - real(r_kind) crit,dist1 + real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -287,7 +291,7 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs itx=hll(ix,iy) ! Compute distance metric (smaller is closer to center of cube) - dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half +! dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half ! Examine various cases regarding what to do with current obs. @@ -295,45 +299,11 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs iuse=.true. ! Determine "score" for observation. Lower score is better. - crit = crit1*dist1 - - if(foreswp .or. aftswp) goto 65 +! crit = crit1*dist1 + crit = crit1 -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then - iuse=.false. - return -! Case: obs score < best value at this location, -! --> update score, count, and best obs counters - elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then - score_crit(itx,ip)= crit - iobsout=ibest_obs(itx,ip) - icount(itx,ip)=icount(itx,ip)+1 - iiout = ibest_save(itx,ip) - ibest_save(itx,ip)=iin - -! Case: first obs at this location, -! --> keep this obs as starting point - elseif (icount(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs - score_crit(itx,ip)= crit - ibest_obs(itx,ip) = iobs - icount(itx,ip)=icount(itx,ip)+1 - ibest_save(itx,ip) = iin - -! Case: none of the above cases are satisified, -! --> don't use this obs - else - iuse = .false. - end if - - return - -65 continue -! TDR fore/aft (Pseudo-dual-Doppler-radars) +! TDR fore (Pseudo-dual-Doppler-radars) if(foreswp) then ! fore sweeps @@ -345,7 +315,6 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs icount_fore(itx,ip)=icount_fore(itx,ip)+1 ibest_obs(itx,ip) = iobs ibest_save(itx,ip) = iin - return ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters @@ -355,22 +324,19 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs iobsout=ibest_obs(itx,ip) iiout = ibest_save(itx,ip) ibest_save(itx,ip)=iin - return ! Case(3): obs score > best value at this location, ! --> do not use this obs, return to calling program. elseif (icount_fore(itx,ip) > 0 .and. crit > score_crit_fore(itx,ip)) then iuse=.false. - return ! Case(4): none of the above cases are satisified, don't use this obs else iuse = .false. - return endif ! cases - end if ! fore sweeps ended - if(aftswp) then ! aft sweeps +! TDR aft (Pseudo-dual-Doppler-radars) + else if(aftswp) then ! aft sweeps ! Case(1): first obs at this location, keep this obs as starting point if (icount_aft(itx,ip)==0) then @@ -380,7 +346,6 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs icount_aft(itx,ip)=icount_aft(itx,ip)+1 ibest_obs(itx,ip) = iobs ibest_save(itx,ip) = iin - return ! Case(2): obs score < best value at this location, @@ -391,23 +356,51 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs iobsout=ibest_obs(itx,ip) iiout = ibest_save(itx,ip) ibest_save(itx,ip)=iin - return ! Case(3): obs score > best value at this location, ! --> do not use this obs, return to calling program. elseif(icount_aft(itx,ip) > 0 .and. crit > score_crit_aft(itx,ip)) then iuse=.false. - return ! Case(4): none of the above cases are satisified, ! --> don't use this obs else iuse = .false. - return endif ! cases - end if ! fore sweeps ended - return + else +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. + if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then + iuse=.false. + +! Case: obs score < best value at this location, +! --> update score, count, and best obs counters + elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then + score_crit(itx,ip)= crit + iobsout=ibest_obs(itx,ip) + icount(itx,ip)=icount(itx,ip)+1 + iiout = ibest_save(itx,ip) + ibest_save(itx,ip)=iin + +! Case: first obs at this location, +! --> keep this obs as starting point + elseif (icount(itx,ip)==0) then + iobs=iobs+1 + iobsout=iobs + score_crit(itx,ip)= crit + ibest_obs(itx,ip) = iobs + icount(itx,ip)=icount(itx,ip)+1 + ibest_save(itx,ip) = iin + +! Case: none of the above cases are satisified, +! --> don't use this obs + else + iuse = .false. + end if + end if + return + end subroutine map3grids @@ -481,7 +474,7 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io real(r_kind) dlat1,dlon1,pob1 real(r_kind) dx,dy,dp,dxx,dyy,dpp - real(r_kind) crit,dist1 + real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -528,7 +521,7 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io itx=hll(ix,iy) ! Compute distance metric (smaller is closer to center of cube) - dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half +! dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half ! Examine various cases regarding what to do with current obs. @@ -536,56 +529,10 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io iuse=.true. ! Determine "score" for observation. Lower score is better. - crit = crit1*dist1 - - if(foreswp .or. aftswp) goto 65 - -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind - return - -! Case: obs score < best value at this location, -! --> update score, count, and best obs counters - elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then - iobs=iobs+1 - iobsout=iobs - score_crit(itx,ip)= crit - icount(itx,ip)=icount(itx,ip)+1 - iiout = ibest_obs(itx,ip) - ibest_save(itx,ip)=iin - ibest_obs(itx,ip)=iobs - rusage(iiout)=101.0_r_kind - rusage(iobs)=usage +! crit = crit1*dist1 + crit = crit1 -! Case: first obs at this location, -! --> keep this obs as starting point - elseif (icount(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs - score_crit(itx,ip)= crit - ibest_obs(itx,ip) = iobs - icount(itx,ip)=icount(itx,ip)+1 - ibest_save(itx,ip) = iin - rusage(iobs)=usage - -! Case: none of the above cases are satisified, -! --> don't use this obs - else - iuse = .false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind - end if - return - -65 continue ! TDR fore/aft (Pseudo-dual-Doppler-radars) - if(foreswp) then ! fore sweeps ! Case(1): first obs at this location, keep this obs as starting point @@ -598,7 +545,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io rusage(iobs)=usage ibest_save(itx,ip)=iin - return ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters @@ -612,7 +558,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io rusage(iiout)=101.0_r_kind rusage(iobs)=usage ibest_save(itx,ip)=iobs - return ! Case(3): obs score > best value at this location, ! --> do not use this obs, return to calling program. @@ -621,7 +566,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io iobsout=iobs rusage(iobs)=101.1_r_kind iuse=.false. - return ! Case(4): none of the above cases are satisified, don't use this obs else @@ -629,11 +573,9 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io iobs=iobs+1 iobsout=iobs rusage(iobs)=101.1_r_kind - return endif ! cases - end if ! fore sweeps ended - if(aftswp) then ! aft sweeps + else if(aftswp) then ! aft sweeps ! Case(1): first obs at this location, keep this obs as starting point if (icount_aft(itx,ip)==0) then @@ -643,7 +585,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io icount_aft(itx,ip)=icount_aft(itx,ip)+1 ibest_obs(itx,ip) = iobs ibest_save(itx,ip) = iin - return ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters @@ -656,7 +597,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io iiout = ibest_save(itx,ip) ibest_save(itx,ip)=iobs rusage(iobs)=usage - return ! Case(3): obs score > best value at this location, ! --> do not use this obs, return to calling program. @@ -665,7 +605,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io iobs=iobs+1 iobsout=iobs rusage(iobs)=101.1_r_kind - return ! Case(4): none of the above cases are satisified, ! --> don't use this obs @@ -674,9 +613,50 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io iobs=iobs+1 iobsout=iobs rusage(iobs)=101.1_r_kind - return endif ! cases - end if ! fore sweeps ended + + else +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. + if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then + iuse=.false. + iobs=iobs+1 + iobsout=iobs + rusage(iobs)=101.0_r_kind + +! Case: obs score < best value at this location, +! --> update score, count, and best obs counters + elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then + iobs=iobs+1 + iobsout=iobs + score_crit(itx,ip)= crit + icount(itx,ip)=icount(itx,ip)+1 + iiout = ibest_obs(itx,ip) + ibest_save(itx,ip)=iin + ibest_obs(itx,ip)=iobs + rusage(iiout)=101.0_r_kind + rusage(iobs)=usage + +! Case: first obs at this location, +! --> keep this obs as starting point + elseif (icount(itx,ip)==0) then + iobs=iobs+1 + iobsout=iobs + score_crit(itx,ip)= crit + ibest_obs(itx,ip) = iobs + icount(itx,ip)=icount(itx,ip)+1 + ibest_save(itx,ip) = iin + rusage(iobs)=usage + +! Case: none of the above cases are satisified, +! --> don't use this obs + else + iuse = .false. + iobs=iobs+1 + iobsout=iobs + rusage(iobs)=101.0_r_kind + end if + end if return end subroutine map3grids_m diff --git a/src/convthin_time.f90 b/src/gsi/convthin_time.f90 similarity index 82% rename from src/convthin_time.f90 rename to src/gsi/convthin_time.f90 index 552150a52..36ab17839 100644 --- a/src/convthin_time.f90 +++ b/src/gsi/convthin_time.f90 @@ -227,7 +227,7 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& real(r_kind) dlat1,dlon1,pob1 real(r_kind) dx,dy,dp,dxx,dyy,dpp - real(r_kind) crit,dist1 + real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -273,7 +273,7 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& itx=hll(ix,iy) ! Compute distance metric (smaller is closer to center of cube) - dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half +! dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half ! Examine various cases regarding what to do with current obs. @@ -281,46 +281,10 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& iuse=.true. ! Determine "score" for observation. Lower score is better. - crit = crit1*dist1 - - if(foreswp .or. aftswp) goto 65 - -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then - iuse=.false. - return - -! Case: obs score < best value at this location, -! --> update score, count, and best obs counters - elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then - score_crit_tm(itx,ip,itm)= crit - iobsout=ibest_obs_tm(itx,ip,itm) - icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 - iiout = ibest_save_tm(itx,ip,itm) - ibest_save_tm(itx,ip,itm)=iin - -! Case: first obs at this location, -! --> keep this obs as starting point - elseif (icount_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs - score_crit_tm(itx,ip,itm)= crit - ibest_obs_tm(itx,ip,itm) = iobs - icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 - ibest_save_tm(itx,ip,itm) = iin - -! Case: none of the above cases are satisified, -! --> don't use this obs - else - iuse = .false. - end if - - return - -65 continue -! TDR fore/aft (Pseudo-dual-Doppler-radars) +! crit = crit1*dist1 + crit = crit1 +! TDR fore (Pseudo-dual-Doppler-radars) if(foreswp) then ! fore sweeps ! Case(1): first obs at this location, keep this obs as starting point @@ -331,7 +295,6 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1 ibest_obs_tm(itx,ip,itm) = iobs ibest_save_tm(itx,ip,itm) = iin - return ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters @@ -341,23 +304,20 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& iobsout=ibest_obs_tm(itx,ip,itm) iiout = ibest_save_tm(itx,ip,itm) ibest_save_tm(itx,ip,itm)=iin - return ! Case(3): obs score > best value at this location, ! --> do not use this obs, return to calling program. elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit > score_crit_fore_tm(itx,ip,itm)) then iuse=.false. - return ! Case(4): none of the above cases are satisified, don't use this obs else iuse = .false. - return endif ! cases - end if ! fore sweeps ended - if(aftswp) then ! aft sweeps +! TDR aft (Pseudo-dual-Doppler-radars) + else if(aftswp) then ! aft sweeps -! Case(1): first obs at this location, keep this obs as starting point +! Case(1): first obs at this location, keep this obs as starting point if (icount_aft_tm(itx,ip,itm)==0) then iobs=iobs+1 iobsout=iobs @@ -365,35 +325,61 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 ibest_obs_tm(itx,ip,itm) = iobs ibest_save_tm(itx,ip,itm) = iin - return -! Case(2): obs score < best value at this location, -! --> update score, count, and best obs counters - elseif (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then +! Case(2): obs score < best value at this location, +! --> update score, count, and best obs counters + elseif (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then score_crit_aft_tm(itx,ip,itm)= crit icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 iobsout=ibest_obs_tm(itx,ip,itm) iiout = ibest_save_tm(itx,ip,itm) ibest_save_tm(itx,ip,itm)=iin - return -! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif(icount_aft_tm(itx,ip,itm) > 0 .and. crit > score_crit_aft_tm(itx,ip,itm)) then +! Case(3): obs score > best value at this location, +! --> do not use this obs, return to calling program. + elseif(icount_aft_tm(itx,ip,itm) > 0 .and. crit > score_crit_aft_tm(itx,ip,itm)) then iuse=.false. - return -! Case(4): none of the above cases are satisified, -! --> don't use this obs +! Case(4): none of the above cases are satisified, +! --> don't use this obs else - iuse = .false. - return + iuse = .false. endif ! cases - end if ! fore sweeps ended - return + else +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. + if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then + iuse=.false. + +! Case: obs score < best value at this location, +! --> update score, count, and best obs counters + elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then + score_crit_tm(itx,ip,itm)= crit + iobsout=ibest_obs_tm(itx,ip,itm) + icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 + iiout = ibest_save_tm(itx,ip,itm) + ibest_save_tm(itx,ip,itm)=iin + +! Case: first obs at this location, +! --> keep this obs as starting point + elseif (icount_tm(itx,ip,itm)==0) then + iobs=iobs+1 + iobsout=iobs + score_crit_tm(itx,ip,itm)= crit + ibest_obs_tm(itx,ip,itm) = iobs + icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 + ibest_save_tm(itx,ip,itm) = iin +! Case: none of the above cases are satisified, +! --> don't use this obs + else + iuse = .false. + end if + end if + + return end subroutine map3grids_tm @@ -462,7 +448,7 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c real(r_kind) dlat1,dlon1,pob1 real(r_kind) dx,dy,dp,dxx,dyy,dpp - real(r_kind) crit,dist1 + real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -509,7 +495,7 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c itx=hll(ix,iy) ! Compute distance metric (smaller is closer to center of cube) - dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half +! dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half ! Examine various cases regarding what to do with current obs. @@ -517,58 +503,10 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c iuse=.true. ! Determine "score" for observation. Lower score is better. - crit = crit1*dist1 - - if(foreswp .or. aftswp) goto 65 - -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind - return - -! Case: obs score < best value at this location, -! --> update score, count, and best obs counters - elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs - score_crit_tm(itx,ip,itm)= crit - icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 - iiout = ibest_obs_tm(itx,ip,itm) - rusage(iiout)=101.0_r_kind - rusage(iobs)=usage - ibest_save_tm(itx,ip,itm)=iin - ibest_obs_tm(itx,ip,itm)=iobs - -! Case: first obs at this location, -! --> keep this obs as starting point - elseif (icount_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=usage - score_crit_tm(itx,ip,itm)= crit - ibest_obs_tm(itx,ip,itm) = iobs - icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 - ibest_save_tm(itx,ip,itm) = iin - -! Case: none of the above cases are satisified, -! --> don't use this obs - else - iuse = .false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind - end if - - return - -65 continue - -! TDR fore/aft (Pseudo-dual-Doppler-radars) +! crit = crit1*dist1 + crit = crit1 +! TDR fore (Pseudo-dual-Doppler-radars) if(foreswp) then ! fore sweeps ! Case: obs score > best value at this location, ! --> do not use this obs, return to calling program. @@ -577,7 +515,6 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c iobs=iobs+1 iobsout=iobs rusage(iobs)=101.1_r_kind - return ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters @@ -611,10 +548,9 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c iobsout=iobs rusage(iobs)=101.0_r_kind end if - endif - return - if(aftswp) then ! fore sweeps +! TDR aft (Pseudo-dual-Doppler-radars) + else if(aftswp) then ! fore sweeps ! Case: obs score > best value at this location, ! --> do not use this obs, return to calling program. if(crit > score_crit_aft_tm(itx,ip,itm) .and. icount_aft_tm(itx,ip,itm) > 0) then @@ -654,8 +590,52 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c iobsout=iobs rusage(iobs)=101.1_r_kind end if - endif + + else +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. + if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then + iuse=.false. + iobs=iobs+1 + iobsout=iobs + rusage(iobs)=101.0_r_kind + +! Case: obs score < best value at this location, +! --> update score, count, and best obs counters + elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then + iobs=iobs+1 + iobsout=iobs + score_crit_tm(itx,ip,itm)= crit + icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 + iiout = ibest_obs_tm(itx,ip,itm) + rusage(iiout)=101.0_r_kind + rusage(iobs)=usage + ibest_save_tm(itx,ip,itm)=iin + ibest_obs_tm(itx,ip,itm)=iobs + +! Case: first obs at this location, +! --> keep this obs as starting point + elseif (icount_tm(itx,ip,itm)==0) then + iobs=iobs+1 + iobsout=iobs + rusage(iobs)=usage + score_crit_tm(itx,ip,itm)= crit + ibest_obs_tm(itx,ip,itm) = iobs + icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 + ibest_save_tm(itx,ip,itm) = iin + +! Case: none of the above cases are satisified, +! --> don't use this obs + else + iuse = .false. + iobs=iobs+1 + iobsout=iobs + rusage(iobs)=101.0_r_kind + end if + end if + return + end subroutine map3grids_m_tm subroutine del3grids_tm diff --git a/src/gsi/correlated_obsmod.F90 b/src/gsi/correlated_obsmod.F90 new file mode 100644 index 000000000..7ac201305 --- /dev/null +++ b/src/gsi/correlated_obsmod.F90 @@ -0,0 +1,1488 @@ +!BOI + +! !TITLE: Correlated\_ObsMod: Inter-channel Observation Correlation Module + +! !AUTHORS: Ricardo Todling + +! !AFFILIATION: Global Modeling and Assimilation Office, NASA/GSFC, Greenbelt, MD 20771 + +! !DATE: 13 April 2014 + +! !INTRODUCTION: Overview +#ifdef __PROTEX__ + +This module introduces the ability for GSI to account for inter-channel +correlated errors for radiance observations. It assumes an offline estimate of +an observation error covariance for a given instrument is available. + +At GMAO, the offline estimation of the error covariances required by this module +is performed by a FORTRAN program that reads the GSI-diag files and performs +statistics on the observation-minus-background and observation-minus-analysis +residuals, following the so-called Desroziers approach (e.g., Desroziers et al. +2005; Q. J. R. Meteorol. Soc., 131, 3385-3396). + +At NCEP, the offline estimation of the error covariances can be computed +by the cov_calc module, located in util/Correlated_Obs. This module is also +based on the Desroziers method. + +This module defines the so-called Obs\_Error\_Cov. + +As Met\_Guess and other like-modules, the idea is for this module to define nearly +opaque object. However, so far, we have had no need to add inquire-like functions - that +is, no code outside this code needs to know what is inside GSI\_Obs\_Error\_Cov. +So far, only very general `methods'' are made public from this module, these +being, + +\begin{verbatim} +public :: corr_ob_initialize +public :: corr_ob_amiset +public :: corr_adjust_jacobian +public :: corr_ob_finalize +\end{verbatim} + +and never the variables themselves; the only exception being the GSI\_MetGuess\_Bundle itself +(until it is no longer treated as a common-block). Some of the public methods above are +overloaded and all have internal interfaces (name of which appears in the index of this protex +document. It should be a rule here that any new routine to be made public should +have a declared interface procedure. + +\begin{center} +\fbox{Obs\_Error\_Cov is defined via the {\it correlated\_observations} table in a resource file} +\end{center} + +\underline{Defining Observation Error Covariance Models} is done via the table {\it correlated\_observations}, +usually embedded in the {\it anavinfo} file. An example of such table follows: +\begin{verbatim} +correlated_observations:: +! isis method kreq kmut type cov_file + airs281_aqua 1 60. 1.0 ice airs_rcov.bin + airs281_aqua 1 60. 1.0 land airs_rcov.bin + airs281_aqua 1 60. 1.0 sea airs_rcov.bin + airs281_aqua 1 60. 1.0 snow airs_rcov.bin + airs281_aqua 1 60. 1.0 mixed airs_rcov.bin +# cris_npp 1 -99. 1.0 snow cris_rcov.bin +# cris_npp 1 -99. 1.0 land cris_rcov.bin +# cris_npp 1 -99. 1.0 sea cris_rcov.bin + iasi_metop-a 2 0.12 1.3 snow iasi_sea_rcov.bin + iasi_metop-a 2 0.22 1.3 land iasi_land_rcov.bin + iasi_metop-a 2 0.05 1.3 sea iasi_sea_rcov.bin + iasi_metop-a 2 0.12 1.3 ice iasi_sea_rcov.bin + iasi_metop-a 2 0.12 1.3 mixed iasi_sea_rcov.bin +# ssmis_f17 1 -99. 1.0 mixed ssmis_rcov.bin +# ssmis_f17 1 -99. 1.0 land ssmis_rcov.bin +# ssmis_f17 1 -99. 1.0 sea ssmis_rcov.bin + +:: +\end{verbatim} +Notice that the covariance can be supplied for all five surface types, +namely, ice, snow, mixed, land, and sea. However, they can be made the same, by simply +pointing the different types to the same file. In the example above, only AIRS and +IASI from Metop-A are being specially handled by this module. In the case of +AIRS, no distinction is made among the different types of surfaces, whereas +in the case of IASI, a distinction is made between land and sea, with everything +else being treated as sea. It is not necessary to specify a covariance file for +each surface type. + +The instrument name is the same as it would be in the satinfo file. + +As usual, this table follows INPAK/ESMF convention, begining with a name +(correlated\_observations), followed by double colons (::) to open the table and +ending with double colons. Any line starting with an exclamation mark or a pound sign +is taken as a comment. + +The current {\it correlated\_observations} table has four columns defined as follows: + +\begin{verbatim} +Column 1: isis - refers to instrument/platform type (follows, typical GSI nomenclature) +Column 2: method - specify different possibilities for handling the corresponding + cov(R) at present: + <0 - reproduces GSI running with the default(for testing only) + 0 - diag of est(R) only + 1 - using the correlations extracted from est(R) and variances from the satinfo file. + 2 - as (1), but using the full est(R) + 3 - diag of est(R) used as scaling factor to internally-defined errors +Column 3: kreq - level of required condition for the corresponding cov(R) + at present: + if<0 and method=0, 1 or 3 does not recondition matrix + if>0 and method=1 recondition the (correlation) matrix following + the 2nd method in Weston et al. (2014; + Q. J. R. Meteorol. Soc., DOI: 10.1002/qj.2306) + Note that the resulting correlation matrix has + condition number equal to approximatetly twice kreq. + if>0 and method=0 or 3 recondition the (covariance) matrix using Westons 2nd method + if method=2 recondition the covariance matrix by inflating the + diagional so that R_{r,r}=(sqrt{R_{r,r}+kreq)^2 + Note that kreq should be specified as 0NULL() ! indexes of active channels in between 1 and nchanl + real(r_kind), pointer :: R(:,:) =>NULL() ! nch_active x nch_active + real(r_kind), pointer :: Revals(:) =>NULL() ! eigenvalues of R +end type + +! !PUBLIC TYPES: + +type(ObsErrorCov),pointer :: GSI_BundleErrorCov(:) + +! strictly internal quantities +character(len=*),parameter :: myname='correlated_obsmod' +logical :: initialized_=.false. +logical, parameter :: VERBOSE_=.true. +integer(i_kind),parameter :: methods_avail(5)=(/-1, & ! do nothing + 0, & ! use dianonal of estimate(R) + 1, & ! use the correlations extracted from the full est(R) + 2, & ! use full est(R) + 3/) ! use diag est(R), as scaling factor to GSI(R) +contains + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ini_ --- Initialize info about correlated obs (read resource table) +! +! !INTERFACE: +! +subroutine ini_ (iamroot) +! !USES: +use mpeu_util, only: die +implicit none +! !INPUT PARAMETERS: + logical,optional,intent(in) :: iamroot +! !DESCRIPTION: Define parameters and setting for handling correlated +! observation errors via resouce file reading. +! +! !REVISION HISTORY: +! 2014-04-13 todling initial code +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Ricardo Todling org: gmao date: 2014-04-13 +! +!EOP +!------------------------------------------------------------------------- +!BOC +character(len=*),parameter:: rcname='anavinfo' ! filename should have extension +character(len=*),parameter:: tbname='correlated_observations::' +integer(i_kind) luin,ii,ntot,nrows,method +character(len=MAXSTR),allocatable,dimension(:):: utable +character(len=20) instrument, mask +character(len=30) filename +real(r_kind) kreq4 +real(r_kind) kmut4 +real(r_kind) kreq +real(r_kind) kmut +character(len=*),parameter::myname_=myname//'*ini_' + +if(initialized_) return + +iamroot_=mype==0 +if(present(iamroot)) iamroot_=iamroot + +! load file +luin=luavail() +open(luin,file=rcname,form='formatted') + +! Scan file for desired table first +! and get size of table +call gettablesize(tbname,luin,ntot,nrows) +if(nrows==0) then + close(luin) + return +endif +ninstr=nrows + +! Get contents of table +allocate(utable(ninstr),instruments(ninstr),idnames(ninstr)) +call gettable(tbname,luin,ntot,ninstr,utable) + +! release file unit +close(luin) + +allocate(GSI_BundleErrorCov(ninstr)) + +! Retrieve each token of interest from table and define +! variables participating in state vector + +! Count variables first +if(iamroot_) write(6,*) myname_,': Correlated-Obs for the following instruments' +do ii=1,ninstr + read(utable(ii),*) instrument, method, kreq4, kmut4, mask, filename ! if adding col to table leave fname as last + instruments(ii) = trim(instrument) + idnames(ii) = trim(instrument)//':'//trim(mask) + kreq=kreq4 + kmut=kmut4 + if(iamroot_) then + write(6,'(1x,2(a,1x),i4,1x,2f20.16,1x,a)') trim(instrument), trim(mask), method, kreq4, kmut4, trim(filename) + endif +! check method validity + if(ALL(methods_avail/=method)) then + call die(myname_,' invalid choice of method, aborting') + endif + call set_(trim(instrument),trim(filename),mask,method,kreq,kmut,GSI_BundleErrorCov(ii)) +enddo + +! release table +deallocate(utable) + +! initialize +if(lupdqc)call upd_varch_ + +end subroutine ini_ +!EOC + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: set_ --- set error covariances for different instruments +! +! !INTERFACE: +! +subroutine set_(instrument,fname,mask,method,kreq,kmut,ErrorCov) +use radinfo, only: nusis,iuse_rad,jpch_rad +implicit none + +! !INPUT PARAMETERS: + +character(len=*),intent(in) :: instrument ! name of instrument +character(len=*),intent(in) :: fname ! filename holding cov(R) +character(len=*),intent(in) :: mask ! land/sea/etc mask +integer,intent(in):: method ! method to apply when using this cov(R) +real(r_kind),intent(in) :: kreq ! conditioning factor for cov(R) +real(r_kind),intent(in) :: kmut ! multiplicative inflation factor for cov(R) +type(ObsErrorCov),intent(inout) :: ErrorCov ! cov(R) for this instrument + +! !DESCRIPTION: Given basic information on the instrument type +! this routine reads an available estimate +! of the corresponding fully-correlated error +! covariance and fills the FORTRAN type defined +! as ObsErrorCov. +! +! !REVISION HISTORY: +! 2014-04-13 todling initial code +! 2014-08-06 todling platform-specific correlated obs handle +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Ricardo Todling org: gmao date: 2014-04-13 +! +!EOP +!------------------------------------------------------------------------- +!BOC + +character(len=*),parameter :: myname_=myname//'*set' +integer(i_kind) nch_active,lu,ii,ioflag,iprec,nctot,coun + +real(r_single),allocatable, dimension(:,:) :: readR4 ! nch_active x nch_active x ninstruments +real(r_double),allocatable, dimension(:,:) :: readR8 ! nch_active x nch_active x ninstruments +real(r_kind),allocatable, dimension(:) :: diag +logical :: corr_obs + + ErrorCov%instrument = trim(instrument) + ErrorCov%mask = trim(mask) + ErrorCov%name = trim(instrument)//':'//trim(mask) + ErrorCov%method = method + ErrorCov%kreq = kreq + ErrorCov%kmut = kmut + + inquire(file=trim(fname), exist=corr_obs) + + if (corr_obs) then + lu = luavail() + open(lu,file=trim(fname),convert='little_endian',form='unformatted') + if (GMAO_ObsErrorCov) then + read(lu,IOSTAT=ioflag) nch_active, iprec + else + read(lu,IOSTAT=ioflag) nch_active, nctot, iprec + endif + if(ioflag/=0) call die(myname_,' failed to read nch from '//trim(fname)) +! if no data available, turn off Correlated Error + coun=0 + do ii=1,jpch_rad + if (nusis(ii)==ErrorCov%instrument) then + if (iuse_rad(ii)>0) coun=coun+1 + endif + enddo + if (coun=0) then + allocate(diag(nch_active)) + do ii=1,nch_active + diag(ii)=ErrorCov%R(ii,ii) + enddo + if(iamroot_) then + write(6,'(3a)') 'Rcov(stdev) for instrument: ', trim(ErrorCov%name), ' recond' + write(6,'(9(es13.6))') sqrt(diag) + endif + deallocate(diag) + endif + + initialized_=.true. +end subroutine set_ +!EOC + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: create_ --- creates type to hold observation error covariance +! +! !INTERFACE: +! +subroutine create_ (nch,ErrorCov) +implicit none +! !INPUT PARAMETERS: +integer(i_kind),intent(in) :: nch +! !INPUT/OUTPUT PARAMETERS: +type(ObsErrorCov),intent(inout) :: ErrorCov +! !DESCRIPTION: Allocates space for FORTRAN type hold observation error +! covariance and required information. +! +! !REVISION HISTORY: +! 2014-04-13 todling initial code +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Ricardo Todling org: gmao date: 2014-04-13 +! +!EOP +!------------------------------------------------------------------------- +!BOC + allocate(ErrorCov%R(nch,nch)) + allocate(ErrorCov%indxR(nch)) + allocate(ErrorCov%Revals(nch)) +end subroutine create_ +!EOC + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: destroy_ --- destroy type holding observation error covariance +! +! !INTERFACE: +! +subroutine destroy_ (ErrorCov) +implicit none +! !INPUT/OUTPUT PARAMETERS: +type(ObsErrorCov),intent(inout) :: ErrorCov +! !DESCRIPTION: Deallocates space held for observation error covariance. +! +! !REVISION HISTORY: +! 2014-04-13 todling initial code +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Ricardo Todling org: gmao date: 2014-04-13 +! +!EOP +!------------------------------------------------------------------------- +!BOC + if (associated(ErrorCov%Revals)) deallocate(ErrorCov%Revals) + if (associated(ErrorCov%indxR)) deallocate(ErrorCov%indxR) + if (associated(ErrorCov%R)) deallocate(ErrorCov%R) +end subroutine destroy_ +!EOC + + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: solver_ --- entry-point to the decomposition of cov(R) +! +! !INTERFACE: +! + +subroutine solver_(ErrorCov) +implicit none +! !INPUT/OUTPUT PARAMETERS: +type(ObsErrorCov),intent(inout) :: ErrorCov + +! !DESCRIPTION: This routine is the entry point to the eigen-decomposition +! of the obs error covariance. Depending on the method chosen +! by the user, it might call the proper routines to recondition +! the offline estimate of cov(R). +! +! !REVISION HISTORY: +! 2014-04-13 todling initial code +! 2015-08-18 W. Gu, Switich the reconditioning method from adding a constant value +! to each eigenvalue to adding a constant value in standard deviation to +! each diagnoal element. +! 2018-07-27 W. Gu, code changes to reduce the round-off errors. +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Ricardo Todling org: gmao date: 2014-04-13 +! +!EOP +!------------------------------------------------------------------------- +!BOC +character(len=*), parameter :: myname_=myname//'*solver_' +real(r_kind) lambda_max,lambda_min,lambda_inc +integer(i_kind) ii,jj,ndim +logical adjspec +real(r_kind),allocatable,dimension(:,:):: Revecs +real(r_kind),allocatable,dimension(:):: invstd + +ndim = size(ErrorCov%R,1) +allocate(Revecs(ndim,ndim)) + +! This extracts the diagonal of R (error variances), setting the +! eigenvalues as such and the eigenvectors as the unit vectors +! This is to allow using the estimated error variances, but +! but still pretend the covariance is diagnoal - no correlations. +! This is largely for testing consistency of the implementation. +if ( ErrorCov%method==0 .or. ErrorCov%method==3 ) then + Revecs = zero + do ii=1,ndim + ErrorCov%Revals(ii) = ErrorCov%R(ii,ii) + Revecs(ii,ii) = one + enddo + call westonEtAl_spectrum_boost_(adjspec) + if (adjspec) then + call rebuild_rcov_ + endif +endif ! method=0 + +! This takes only corr(Re) and +! any reconditioning is of correlation matrix +if ( ErrorCov%method==1 ) then + ! reduce R to correlation matrix + allocate(invstd(ndim)) + do jj=1,ndim + invstd(jj) = ErrorCov%R(jj,jj) + enddo + do jj=1,ndim + do ii=1,ndim + ErrorCov%R(ii,jj) = ErrorCov%R(ii,jj)/sqrt(invstd(ii)*invstd(jj)) + enddo + enddo + deallocate(invstd) + Revecs=ErrorCov%R + call decompose_(trim(ErrorCov%name),ErrorCov%Revals,Revecs,ndim,.true.) + call westonEtAl_spectrum_boost_(adjspec) + if (adjspec) then + call rebuild_rcov_ + allocate(invstd(ndim)) + do jj=1,ndim + invstd(jj) = ErrorCov%R(jj,jj) + enddo + do jj=1,ndim + do ii=1,ndim + ErrorCov%R(ii,jj) = ErrorCov%R(ii,jj)/sqrt(invstd(ii)*invstd(jj)) + enddo + enddo + deallocate(invstd) + endif +endif ! method=1 + +! This does the actual full eigendecomposition of the R matrix +! Here, recondioning is of covariance matrix +if ( ErrorCov%method==2 ) then + Revecs=ErrorCov%R + call decompose_(trim(ErrorCov%name),ErrorCov%Revals,Revecs,ndim,.true.) + if ((ErrorCov%kreq>zero).or.(ErrorCov%kmut>one)) then + do jj=1,ndim + do ii=1,ndim + if(ii==jj) then + ! inflated by constant standard deviation + ErrorCov%R(ii,ii)=ErrorCov%kmut*ErrorCov%kmut*& + (sqrt(ErrorCov%R(ii,ii))+ErrorCov%kreq)**2 + else + ErrorCov%R(ii,jj)=ErrorCov%kmut*ErrorCov%kmut*ErrorCov%R(ii,jj) + endif + enddo + enddo + Revecs=ErrorCov%R + call decompose_(trim(ErrorCov%name),ErrorCov%Revals,Revecs,ndim,.true.) + endif + ! In this case, we can wipe out the eigen-decomp since it will be redone for + ! each profile at each location at setup time. + ErrorCov%Revals=zero +endif ! method=2 + +deallocate(Revecs) + + contains + subroutine westonEtAl_spectrum_boost_(adjspec) + implicit none + logical,intent(out) :: adjspec + adjspec=.false. + if(ErrorCov%kreq < zero) return + lambda_max=maxval(ErrorCov%Revals) + lambda_min=minval(ErrorCov%Revals) + lambda_inc=(lambda_max - (lambda_min * ErrorCov%kreq))/(ErrorCov%kreq-1) + if(lambda_inc>zero) then + ErrorCov%Revals = ErrorCov%Revals + lambda_inc + else + if (iamroot_) then + write(6,'(2a,1x,es10.3)') myname_, ' Spectrum of cov(R) not changed, poor choice of kreq = ', & + ErrorCov%kreq + endif + endif + adjspec=.true. + end subroutine westonEtAl_spectrum_boost_ + subroutine rebuild_rcov_ + implicit none + integer(i_kind) ii,jj,kk + real(r_kind), allocatable, dimension(:,:) :: tmp + allocate(tmp(ndim,ndim)) + ! D*U^T + do jj=1,ndim + tmp(:,jj) = ErrorCov%Revals(:) * Revecs(jj,:) + enddo + ! U*(D*U^T) + ErrorCov%R = matmul(Revecs,tmp) + Revecs =ErrorCov%R + call decompose_(trim(ErrorCov%name),ErrorCov%Revals,Revecs,ndim,.true.) + ! clean up + deallocate(tmp) + end subroutine rebuild_rcov_ +end subroutine solver_ +!EOC + + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: decompose_ --- calculates eigen-decomposition of cov(R) +! +! !INTERFACE: +! +subroutine decompose_(instrument,Evals,Evecs,ndim,lprt) +! !USES: + use constants, only: tiny_r_kind + implicit none +! !INPUT PARAMETERS: + character(len=*),intent(in):: instrument + integer(i_kind),intent(in) :: ndim + logical,intent(in) :: lprt +! !INPUT/OUTPUT PARAMETERS: + real(r_kind),intent(inout) :: Evals(:) + real(r_kind),intent(inout) :: Evecs(:,:) ! on entry: matrix to decompose + ! on exit: eigenvectors + +! !DESCRIPTION: This routine makes a LAPACK call to eigen-decompose cov(R). +! Its initial implementation is the crudest possible; it does +! not make use of the fact that only the upper or lower triangles +! of the matrix are needed; the problems solver are so small that +! at present this does not seem to be an issue; this could be +! easily revisited in the future. +! +! !REVISION HISTORY: +! 2014-04-13 todling initial code +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Ricardo Todling org: gmao date: 2014-04-13 +! +!EOP +!------------------------------------------------------------------------- +!BOC + character(len=*),parameter :: myname_=myname//'decompose_' + character*1 jobz + integer(i_kind) lwork,info + real(r_kind) lambda_max,lambda_min,cond + real(r_kind),allocatable, dimension(:) :: work + jobz = 'V' ! evals & evecs + lwork = max(1,3*ndim-1) + allocate(work(lwork)) + if(r_kind==r_single) then ! this trick only works because this uses the f77 lapack interfaces + call SSYEV( jobz, 'U', ndim, Evecs, ndim, Evals, WORK, lwork, info ) + else if(r_kind==r_double) then + call DSYEV( jobz, 'U', ndim, Evecs, ndim, Evals, WORK, lwork, info ) + else + call die(myname_,'no corresponding LAPACK call for solving eigenproblem') + endif + if (info==0) then + if (lprt) then + cond=-999._r_kind + lambda_max=maxval(Evals) + lambda_min=minval(abs(Evals)) + if(lambda_min>tiny_r_kind) cond=abs(lambda_max/lambda_min) ! formal definition (lambda>0 for SPD matrix) + if (iamroot_) then + write(6,'(2a,1x,a,1x,es20.10)') 'Rcov(Evals) for Instrument: ', trim(instrument), ' cond= ', cond + write(6,'(9(es13.6))') Evals + endif + endif + else + call die(myname_,'trouble solving eigenproblem') + endif + deallocate(work) +end subroutine decompose_ +!EOC + +!BOP +! +! !IROUTINE: upd_varch_ --- replace the obs error prescribed in satinfo for instrument accounted for inter-channel covariance. +! +! !INTERFACE: +! +subroutine upd_varch_ +! !USES: + use mpeu_util, only: die + use radinfo, only: jpch_rad,iuse_rad,nusis,varch,varch_sea,varch_land,varch_ice,varch_snow,varch_mixed + implicit none +! !DESCRIPTION: This routine will replace the prescribed obs errors in satinfo for instruments we account +! for inter-channel covariances. +! +! !REVISION HISTORY: +! 2014-11-26 W. Gu Initial code +! 2019-02-26 kbathmann Update to be surface type dependent. +! 2019-08-12 W. Gu Clean up the code, update varch_sea,varch_land etc directly by using indxR +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Wei Gu org: gmao date: 2014-11-26 +! +!EOP +!------------------------------------------------------------------------- +!BOC + + character(len=*),parameter :: myname_=myname//'*upd_varch_' + character(len=80) covtype + integer(i_kind) :: nch_active,ii,jj,iii,jjj,mm,nn,ncp,ifound,jj0,itbl,ntrow + integer(i_kind),dimension(6) ::nsatype + integer(i_kind)::nsat,isurf,rr + integer(i_kind),allocatable,dimension(:) :: ircv + integer(i_kind),allocatable,dimension(:) :: ijac + integer(i_kind),allocatable,dimension(:) :: IRsubset + integer(i_kind),allocatable,dimension(:) :: IJsubset + integer(i_kind) iinstr,indR + integer(i_kind),allocatable,dimension(:) :: ich1 ! true channel number + integer(i_kind),allocatable,dimension(:,:) :: tblidx + integer(i_kind) :: nchanl1,jc ! total number of channels in instrument + if(.not.allocated(idnames)) then + return + endif + ntrow = size(idnames) + allocate(ich1(jpch_rad),tblidx(5,ntrow)) + + nsatype=0 + do jj0=1,ntrow + + if (GSI_BundleErrorCov(jj0)%method > 1 .or. & + GSI_BundleErrorCov(jj0)%method == 0) then + + covtype=trim(idnames(jj0)) + iinstr=len_trim(covtype) + if(covtype(iinstr-3:iinstr)==':sea')then + nsatype(1)=nsatype(1)+1 + nsatype(6)=nsatype(6)+1 + tblidx(1,nsatype(1))=jj0 + endif + if(covtype(iinstr-4:iinstr)==':land')then + nsatype(2)=nsatype(2)+1 + nsatype(6)=nsatype(6)+1 + tblidx(2,nsatype(2))=jj0 + endif + if(covtype(iinstr-3:iinstr)==':ice')then + nsatype(3)=nsatype(3)+1 + nsatype(6)=nsatype(6)+1 + tblidx(3,nsatype(3))=jj0 + endif + if(covtype(iinstr-4:iinstr)==':snow')then + nsatype(4)=nsatype(4)+1 + nsatype(6)=nsatype(6)+1 + tblidx(4,nsatype(4))=jj0 + endif + if(covtype(iinstr-5:iinstr)==':mixed')then + nsatype(5)=nsatype(5)+1 + nsatype(6)=nsatype(6)+1 + tblidx(5,nsatype(5))=jj0 + endif + endif + enddo + + if(nsatype(6)==0) return + + do isurf=1,5 + nsat=nsatype(isurf) + if (nsat>0) then + + do jj0=1,nsat + + itbl=tblidx(isurf,jj0) !a row number + jc=0 + covtype = '' + ich1=0 + do ii=1,jpch_rad + if (isurf==1) then + covtype = trim(nusis(ii))//':sea' + else if (isurf==2) then + covtype = trim(nusis(ii))//':land' + else if (isurf==3) then + covtype = trim(nusis(ii))//':ice' + else if (isurf==4) then + covtype = trim(nusis(ii))//':snow' + else if (isurf==5) then + covtype = trim(nusis(ii))//':mixed' + end if + if(trim(idnames(itbl))==trim(covtype)) then + jc=jc+1 + ich1(jc)=ii + endif + enddo + nchanl1=jc + + if(nchanl1==0) call die(myname_,' improperly set GSI_BundleErrorCov') + if(.not.amiset_(GSI_BundleErrorCov(itbl))) then !KAB + if (iamroot_) write(6,*) 'WARNING: Error Covariance not set for ',trim(idnames(itbl)) + return + endif + + nch_active=GSI_BundleErrorCov(itbl)%nch_active + if(nch_active<0) return + + if(GMAO_ObsErrorCov)then + do jj=1,nch_active + nn=GSI_BundleErrorCov(itbl)%indxR(jj) + mm=ich1(nn) + if( iuse_rad(mm)<1 ) then + call die(myname_,' active channels used in R do not match those used in GSI, aborting') + endif + if(isurf==1) then + if(iamroot_)write(6,'(1x,a6,a20,2i6,2f20.15)')'>>>',idnames(itbl),jj,nn,varch(mm),sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + endif + if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + enddo + else + allocate(ircv(nchanl1)) + allocate(ijac(nchanl1)) + ircv = -1 + ijac = -1 + do jj=1,nchanl1 + mm=ich1(jj) ! true channel number (has no bearing here except in iuse) + if (iuse_rad(mm)>=1) then + ifound=-1 + do ii=1,nch_active + if (GSI_BundleErrorCov(itbl)%nctot>nchanl1) then + indR=ii + else + indR=GSI_BundleErrorCov(itbl)%indxR(ii) + end if + if(jj==indR) then + ifound=ii + exit + endif + enddo + if(ifound/=-1) then + ijac(jj)=jj ! index value in 1 to nchanl + ircv(jj)=ifound ! index value in 1 to nch_active + endif + endif + enddo + ncp=count(ircv>0) ! number of active channels in profile + if(ncp/=nch_active) then + call die(myname_,'serious inconsistency in handling correlated obs') + endif + allocate(IRsubset(ncp)) ! these indexes apply to the matrices/vec in ErrorCov + allocate(IJsubset(ncp)) ! these indexes in 1 to nchanl + iii=0;jjj=0 + do ii=1,nchanl1 + if(ircv(ii)>0) then + iii=iii+1 + IRsubset(iii)=ircv(ii) ! subset indexes in R presently in use + endif + if(ijac(ii)>0) then + jjj=jjj+1 + IJsubset(iii)=ijac(ii) ! subset indexes in channels presently in use + endif + enddo + if (iii/=ncp) then + if (iamroot_) then + write(6,*) myname, ' iii,ncp= ',iii,ncp + endif + call die(myname_,' serious dimensions insconsistency, aborting') + endif + if (jjj/=ncp) then + if (iamroot_) then + write(6,*) myname, ' jjj,ncp= ',jjj,ncp + endif + call die(myname_,' serious dimensions insconsistency, aborting') + endif + do ii=1,ncp + nn=IJsubset(ii) + mm=ich1(nn) + rr=IRsubset(ii) + if(isurf==1) varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + enddo +! clean up + deallocate(IJsubset) + deallocate(IRsubset) + deallocate(ijac) + deallocate(ircv) + endif + enddo !jj=1,nsat + endif !nsat >0 + enddo !isurf=1,5 + + deallocate(ich1,tblidx) + +end subroutine upd_varch_ +!EOC +logical function adjust_jac_ (iinstr,nchanl,nsigradjac,ich,varinv,depart, & + err2,raterr2,wgtjo,jacobian,method,nchasm,rsqrtinv,rinvdiag) +!$$$ subprogram documentation block +! . . . +! subprogram: adjust_jac_ +! +! prgrmmr: todling org: gmao date: 2014-04-15 +! +! abstract: provide hook to module handling inter-channel ob correlated errors +! +! program history log: +! 2014-04-15 todling - initial code +! 2014-08-06 todling - change obtype to isis for more flexibity +! 2014-10-01 todling - add wgtjo to arg list +! 2015-04-01 W. Gu - clean the code +! 2015-08-18 W. Gu - add the dependence of the correlated obs errors on the surface types. +! 2016-06-01 W. Gu - move the function radinfo_adjust_jacobian from radinfo +! 2017-07-27 kbathmann Merge subroutine rsqrtinv into scale_jac, define rinvdiag +! to fix diag_precon for correlated error, and reorder several nested loops +! 2019-04-22 kbathmann change to cholesky factorization +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + use constants, only: zero,one + use mpeu_util, only: die + implicit none + integer(i_kind), intent(in) :: nchasm + integer(i_kind), intent(in) :: iinstr + integer(i_kind), intent(in) :: nchanl + integer(i_kind), intent(in) :: nsigradjac + integer(i_kind), intent(in) :: ich(nchanl) + integer(i_kind), intent(out) :: method + real(r_kind), intent(in) :: varinv(nchanl) + real(r_kind), intent(inout) :: depart(nchanl) + real(r_kind), intent(inout) :: err2(nchanl) + real(r_kind), intent(inout) :: raterr2(nchanl) + real(r_kind), intent(inout) :: wgtjo(nchanl) + real(r_kind), intent(inout) :: jacobian(nsigradjac,nchanl) + real(r_kind), intent(inout) :: rsqrtinv((nchasm*(nchasm+1))/2) + real(r_kind), intent(inout) :: rinvdiag(nchasm) + + character(len=*),parameter::myname_ = myname//'*adjust_jac_' + + adjust_jac_=.false. + + if(.not.amiset_(GSI_BundleErrorCov(iinstr))) then + if (iamroot_) write(6,*) 'WARNING: Error Covariance not set for ', & + trim(GSI_BundleErrorCov(iinstr)%instrument) + return + endif + + if( GSI_BundleErrorCov(iinstr)%nch_active < 0) return + + adjust_jac_ = scale_jac_ (depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & + ich,nchasm,rsqrtinv,rinvdiag,GSI_BundleErrorCov(iinstr)) + + method = GSI_BundleErrorCov(iinstr)%method + + end function adjust_jac_ + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: scale_jac_ --- scale Jacbian, residuals, and related errors +! +! !INTERFACE: +! +logical function scale_jac_(depart,err2,raterr2,jacobian,nchanl,varinv,wgtjo, & + ich,nchasm,rsqrtinv,rinvdiag,ErrorCov) +! !USES: + use constants, only: tiny_r_kind + use radinfo, only: iuse_rad + use mpeu_util, only: die + implicit none +! !INPUT PARAMETERS: + integer(i_kind),intent(in) :: nchasm + integer(i_kind),intent(in) :: nchanl ! total number of channels in instrument + integer(i_kind),intent(in) :: ich(:) ! true channel numeber + real(r_kind), intent(in) :: varinv(:) ! inverse of specified ob-error-variance +! !INPUT/OUTPUT PARAMETERS: + real(r_kind),intent(inout) :: depart(:) ! observation-minus-guess departure + real(r_kind),intent(inout) :: err2(:) ! input: square of inverse of original obs errors + real(r_kind),intent(inout) :: raterr2(:) ! input: square of original obs error/inflated obs errors + real(r_kind),intent(inout) :: wgtjo(:) ! weight in Jo-term + real(r_kind),intent(inout) :: jacobian(:,:)! Jacobian matrix + real(r_kind),intent(inout) :: rsqrtinv(:) + real(r_kind),intent(inout) :: rinvdiag(:) + type(ObsErrorCov),intent(inout) :: ErrorCov + +! !DESCRIPTION: This routine is the main entry-point to the outside world. +! It redefines the Jacobian matrix so it embeds the inverse of the square root +! observation error covariance matrix. Only the sub-matrix related +! to the active and accepted channels in the given profile is +! taken into account. +! +! !REVISION HISTORY: +! 2014-04-13 todling initial code +! 2014-11-15 W. Gu bug fix in R-inverse indexation +! 2014-12-19 W. Gu use the eigenvalue decomposition to form a square root decomposition, and then +! apply to correlated R-covariance matrix(R= QD^(1/2)Q^T QD^(1/2)Q^T). +! 2015-04-01 W. Gu clean the code +! 2016-04-18 W. Gu combine QC inflation factors into the correlated obs errors(method=2) +! 2016-10-28 W. Gu merge the code for method=1 and method=2 together +! 2016-10-28 W. Gu remove rsqrtinv_ and do the inverse of sqrt(R) directly here. +! 2019-04-22 kbathmann & W. Gu use of Cholesky factorization of R to update the OMF and Jacobian +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Ricardo Todling org: gmao date: 2014-04-13 +! +!EOP +!------------------------------------------------------------------------- +!BOC + + character(len=*),parameter :: myname_=myname//'*scale_jac' + integer(i_kind) :: chan_count + integer(i_kind) :: nch_active,ii,jj,kk,iii,jjj,mm,nn,ncp,ifound,nsigjac,indR + integer(i_kind),allocatable,dimension(:) :: ircv + integer(i_kind),allocatable,dimension(:) :: ijac + integer(i_kind),allocatable,dimension(:) :: IRsubset + integer(i_kind),allocatable,dimension(:) :: IJsubset + real(r_quad), allocatable,dimension(:) :: col + real(r_quad), allocatable,dimension(:,:) :: row + real(r_kind), allocatable,dimension(:) :: qcaj + real(r_kind), allocatable,dimension(:,:) :: UT + logical subset + + scale_jac_=.false. + nch_active=ErrorCov%nch_active + + call timer_ini('scljac') + +! get indexes for the internal channels matching those +! used in estimating the observation error covariance + allocate(ircv(nchanl)) + allocate(ijac(nchanl)) + ircv = -1 + ijac = -1 + do jj=1,nchanl + mm=ich(jj) ! true channel number (has no bearing here except in iuse) + if (varinv(jj)>tiny_r_kind .and. iuse_rad(mm)>=1) then + ifound=-1 + do ii=1,nch_active + if(GMAO_ObsErrorCov)then + if(jj==ErrorCov%indxR(ii)) then + ifound=ii + exit + endif + else + if (ErrorCov%nctot>nchanl) then + indR=ii + else + indR=ErrorCov%indxR(ii) + end if + if(jj==indR) then + ifound=ii + exit + endif + endif + enddo + if(ifound/=-1) then + ijac(jj)=jj ! index value applies to the jacobian and departure + ircv(jj)=ifound ! index value applies to ErrorCov + endif + endif + enddo + +! following should never happen, but just in case ... + ncp=count(ircv>0) ! number of active channels in profile + if(ncp==0 .or. ncp>nch_active) then + call die(myname_,'serious inconsitency in handling correlated obs') + endif + if(ncp /= nchasm) then + call die(myname_,'serious inconsitency in handling correlated obs: ncp .ne. nchasm') + endif + +! Get subset indexes; without QC and other on-the-fly analysis choices these +! two indexes would be the same, but because the analysis +! remove data here and there, most often there will be less +! channels being processed for a given profile than the set +! of active channels used to get an offline estimate of R. + allocate(IRsubset(ncp)) ! these indexes apply to the matrices/vec in ErrorCov + allocate(IJsubset(ncp)) ! these indexes apply to the Jacobian/departure + iii=0;jjj=0 + do ii=1,nchanl + if(ircv(ii)>0) then + iii=iii+1 + IRsubset(iii)=ircv(ii) ! subset indexes in R presently in use + endif + if(ijac(ii)>0) then + jjj=jjj+1 + IJsubset(iii)=ijac(ii) ! subset indexes in Jac/dep presently in use + endif + enddo + if (iii/=ncp) then + if (iamroot_) then + write(6,*) myname, ' iii,ncp= ',iii,ncp + endif + call die(myname_,' serious dimensions insconsistency (R), aborting') + endif + if (jjj/=ncp) then + if (iamroot_) then + write(6,*) myname, ' jjj,ncp= ',jjj,ncp + endif + call die(myname_,' serious dimensions insconsistency (J), aborting') + endif + + if( ErrorCov%method<0 ) then +! Keep departures and Jacobian unchanged +! Do as GSI would do otherwise + do jj=1,ncp + mm=IJsubset(jj) + raterr2(mm) = raterr2(mm) + err2(mm) = err2(mm) + wgtjo(mm) = varinv(mm) + enddo + else + if( ErrorCov%method== 0 ) then + + ! use diag(Re) replaces GSI specified errors + ! inv(Rg) = inv(De) + + do jj=1,ncp + mm=IJsubset(jj) + err2(mm) = one/ErrorCov%R(IRsubset(jj),IRsubset(jj)) + if(.not.lqcoef)raterr2(mm) = one + wgtjo(mm) = raterr2(mm)/ErrorCov%R(IRsubset(jj),IRsubset(jj)) + enddo + + else if( ErrorCov%method==1 .or. ErrorCov%method== 2) then + + ! case=1 is default; uses corr(Re) only + ! case=2: uses full Re; + +! decompose the sub-matrix - returning the result in the +! structure holding the full covariance + nsigjac=size(jacobian,1) + allocate(row(nsigjac,ncp)) + allocate(col(ncp)) + row=zero_quad + col=zero_quad + + allocate(qcaj(ncp)) + allocate(UT(ncp,ncp)) + qcaj = one + UT = zero + if( ErrorCov%method==2 ) then + if(lqcoef)then + do jj=1,ncp + jjj=IJsubset(jj) + qcaj(jj) = raterr2(jjj) + enddo + subset = choleskydecom_inv_ (IRsubset,ErrorCov,UT,qcaj) + else + subset = choleskydecom_inv_ (IRsubset,ErrorCov,UT) + endif + else if( ErrorCov%method==1 ) then + do jj=1,ncp + jjj=IJsubset(jj) + qcaj(jj) = varinv(jjj) + enddo + subset = choleskydecom_inv_ (IRsubset,ErrorCov,UT,qcaj) + + endif + if(.not.subset) then + call die(myname_,' failed to decompose correlated R') + endif + + chan_count = 0 + do ii=1,ncp + do jj=1,ii + chan_count = chan_count + 1 + rsqrtinv(chan_count) = UT(jj,ii) + enddo + enddo + + do ii=1,ncp + do kk=ii,ncp + rinvdiag(ii)=rinvdiag(ii)+UT(ii,kk)**2 + enddo + enddo + + do ii=1,ncp + do jj=1,ii + nn=IJsubset(jj) + col(ii) = col(ii) + UT(jj,ii) * depart(nn) + row(:,ii) = row(:,ii) + UT(jj,ii) * jacobian(:,nn) + enddo + enddo + +! Place Jacobian and departure in output arrays + do jj=1,ncp + mm=IJsubset(jj) + depart(mm)=col(jj) + jacobian(:,mm)=row(:,jj) + raterr2(mm) = one + err2(mm) = one + wgtjo(mm) = one + enddo + + deallocate(col) + deallocate(row) + deallocate(qcaj) + deallocate(UT) + + else if( ErrorCov%method==3 ) then !use diag(Re) scales GSI specified errors + ! inv(Rg) = inv(De*Dg) + do jj=1,ncp + mm=IJsubset(jj) + raterr2(mm) = raterr2(mm)/ErrorCov%Revals(IRsubset(jj)) + err2(mm) = err2(mm) + wgtjo(mm) = varinv(mm)/ErrorCov%Revals(IRsubset(jj)) + enddo + + + endif + + endif + +! clean up + deallocate(IJsubset) + deallocate(IRsubset) + deallocate(ijac) + deallocate(ircv) + + scale_jac_=.true. + + call timer_fnl('scljac') + +end function scale_jac_ +!EOC + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: choleskydecom_inv_ --- compute Choleskyi factorization of cov(R), i.e., +! R = U^T * U, then invert U +! +! !INTERFACE: +! +logical function choleskydecom_inv_(Isubset,ErrorCov,UT,qcaj) +! !USES: + implicit none + integer(i_kind),intent(in) :: Isubset(:) + real(r_kind),intent(inout) :: UT(:,:) + real(r_kind),optional,intent(in) :: qcaj(:) + type(ObsErrorCov),intent(in) :: ErrorCov +! !DESCRIPTION: This routine makes a LAPACK call to Cholesky factorization of cov(R), +! then inverts the lower triangular matrix. +! +! !REVISION HISTORY: +! 2019-04-22 kbathmann/Wei initial code +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHORS: +! Kristen Bathmann, EMC date: 2019-04-22 +! Wei Gu org: gmao date: 2019-04-22 +! +!EOP +!------------------------------------------------------------------------- +!BOC + character(len=*),parameter :: myname_=myname//'choleskydecom_inv_' + integer(i_kind) ii,jj,ncp + integer(i_kind) info,info1 + + choleskydecom_inv_=.false. + ncp=size(Isubset) ! number of channels actually used in this profile + +! extract subcomponent of R + if( present(qcaj) ) then + do jj=1,ncp + do ii=1,ncp + UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj))/sqrt(qcaj(ii)*qcaj(jj)) + enddo + enddo + else + do jj=1,ncp + do ii=1,ncp + UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj)) + enddo + enddo + endif + if(r_kind==r_single) then ! this trick only works because this uses the f77 lapack interfaces + call SPOTRF('U', ncp, UT, ncp, info ) + else if(r_kind==r_double) then + call DPOTRF('U', ncp, UT, ncp, info ) + endif + if (info==0) then + if(r_kind==r_single) then + call STRTRI('U', 'N', ncp, UT, ncp, info1 ) + else if(r_kind==r_double) then + call DTRTRI('U', 'N', ncp, UT, ncp, info1 ) + endif + if(info1 /= 0)call die(myname_,'trouble inverting upper triangular matrix ') + else + call die(myname_,'trouble performing cholesky factorization') + endif + + choleskydecom_inv_=.true. + +end function choleskydecom_inv_ +!EOC + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: amiset_ --- checks whether a particular cov(R) has been set or not +! +! !INTERFACE: +! + +logical function amiset_ (ErrorCov) +implicit none +! !INPUT/OUTPUT PARAMETERS: +type(ObsErrorCov),intent(in) :: ErrorCov + +! !DESCRIPTION: This routine returns the status of a particular instance of +! the FORTRAN typing holding the observation error covariance. +! +! !REVISION HISTORY: +! 2014-04-13 todling initial code +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Ricardo Todling org: gmao date: 2014-04-13 +! +!EOP +!------------------------------------------------------------------------- +!BOC +logical failed +failed=.false. +amiset_=.false. +if(ErrorCov%nch_active<0) failed=.true. +if(.not.associated(ErrorCov%indxR)) failed=.true. +if(.not.associated(ErrorCov%R)) failed=.true. +if(.not.associated(ErrorCov%REvals)) failed=.true. +if(.not.failed) amiset_=.true. +end function amiset_ +!EOC + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: fnl_ --- destroy all instances of cov(R) +! +! !INTERFACE: +! +subroutine fnl_ +implicit none + +! !DESCRIPTION: Deallocates space held for observation error covariance. +! +! !REVISION HISTORY: +! 2014-04-13 todling initial code +! +! !REMARKS: +! language: f90 +! machine: discover +! +! !AUTHOR: +! Ricardo Todling org: gmao date: 2014-04-13 +! +!EOP +!------------------------------------------------------------------------- +!BOC +integer(i_kind) ii,ndim +if(.not.initialized_) return +ndim=size(GSI_BundleErrorCov) +do ii=1,ndim + call destroy_(GSI_BundleErrorCov(ii)) +enddo +deallocate(GSI_BundleErrorCov) +if(allocated(idnames)) deallocate(idnames) +if(allocated(instruments)) deallocate(instruments) +end subroutine fnl_ +!EOC + +end module correlated_obsmod diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 new file mode 100644 index 000000000..68b29b9a4 --- /dev/null +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -0,0 +1,648 @@ +module get_fv3_regional_ensperts_mod +use abstract_get_fv3_regional_ensperts_mod,only: abstract_get_fv3_regional_ensperts_class + use kinds, only : i_kind + type, extends(abstract_get_fv3_regional_ensperts_class) :: get_fv3_regional_ensperts_class + contains + procedure, pass(this) :: get_fv3_regional_ensperts => get_fv3_regional_ensperts_run + procedure, pass(this) :: ens_spread_dualres_regional => ens_spread_dualres_regional_fv3_regional + procedure, pass(this) :: general_read_fv3_regional + end type get_fv3_regional_ensperts_class +contains + subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: get_fv3_regional_ensperts read arw model ensemble members + ! prgmmr: Ting org: EMC/NCEP date: 2018-12-13 + ! + ! abstract: read ensemble members from the fv3 regional (fv3_SAR) + ! model,following Wanshu's programs to read those background files + ! + ! + ! program history log: + ! 2011-08-31 todling - revisit en_perts (single-prec) in light of extended bundle + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: + ! + !$$$ end documentation block + + use kinds, only: r_kind,i_kind,r_single + use constants, only: zero,one,half,zero_single,rd_over_cp,one_tenth + use mpimod, only: mpi_comm_world,ierror,mype + use hybrid_ensemble_parameters, only: n_ens,grd_ens + use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path + use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d + use gsi_bundlemod, only: gsi_bundlecreate + use gsi_bundlemod, only: gsi_grid + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_bundlemod, only: gsi_bundledestroy + use gsi_bundlemod, only: gsi_gridcreate + use guess_grids, only: ntguessig,ifilesig + use gsi_4dvar, only: nhr_assimilation + use gsi_4dvar, only: ens_fhrlevs + use gsi_rfv3io_mod, only: type_fv3regfilenameg + + implicit none + class(get_fv3_regional_ensperts_class), intent(inout) :: this + type(gsi_bundle),allocatable, intent(inout) :: en_perts(:,:) + integer(i_kind), intent(in ):: nelen + real(r_single),dimension(:,:,:),allocatable,intent(inout):: ps_bar + + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig):: u,v,tv,oz,rh + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2):: ps + + real(r_single),pointer,dimension(:,:,:):: w3 + real(r_single),pointer,dimension(:,:):: w2 + real(r_kind),pointer,dimension(:,:,:):: x3 + real(r_kind),pointer,dimension(:,:):: x2 + type(gsi_bundle),allocatable,dimension(:):: en_bar + type(gsi_grid):: grid_ens + real(r_kind):: bar_norm,sig_norm,kapr,kap1 + + integer(i_kind):: i,j,k,n,mm1,istatus + integer(i_kind):: ic2,ic3 + integer(i_kind):: m + + + character(255) ensfilenam_str + type(type_fv3regfilenameg)::fv3_filename + + call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) + ! Allocate bundle to hold mean of ensemble members + allocate(en_bar(ntlevs_ens)) + do m=1,ntlevs_ens + call gsi_bundlecreate(en_bar(m),grid_ens,'ensemble',istatus,names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)' get_fv3_regional_ensperts_netcdf: trouble creating en_bar bundle' + call stop2(9991) + endif + enddo ! for m + + + do m=1,ntlevs_ens + + + + ! + ! INITIALIZE ENSEMBLE MEAN ACCUMULATORS + en_bar(m)%values=zero + + do n=1,n_ens + en_perts(n,m)%valuesr4 = zero + enddo + + mm1=mype+1 + kap1=rd_over_cp+one + kapr=one/rd_over_cp + ! + ! LOOP OVER ENSEMBLE MEMBERS + do n=1,n_ens + write(ensfilenam_str,22) trim(adjustl(ensemble_path)),ens_fhrlevs(m),n +22 format(a,'fv3SAR',i2.2,'_ens_mem',i3.3) + ! DEFINE INPUT FILE NAME + fv3_filename%grid_spec=trim(ensfilenam_str)//'-fv3_grid_spec' !exmaple thinktobe + fv3_filename%ak_bk=trim(ensfilenam_str)//'-fv3_akbk' + fv3_filename%dynvars=trim(ensfilenam_str)//'-fv3_dynvars' + fv3_filename%tracers=trim(ensfilenam_str)//"-fv3_tracer" + fv3_filename%sfcdata=trim(ensfilenam_str)//"-fv3_sfcdata" + fv3_filename%couplerres=trim(ensfilenam_str)//"-coupler.res" + ! + ! READ ENEMBLE MEMBERS DATA + if (mype == 0) write(6,'(a,a)') 'CALL READ_FV3_REGIONAL_ENSPERTS FOR ENS DATA with the filename str : ',trim(ensfilenam_str) + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz) + + ! SAVE ENSEMBLE MEMBER DATA IN COLUMN VECTOR + do ic3=1,nc3d + + call gsi_bundlegetpointer(en_perts(n,m),trim(cvars3d(ic3)),w3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for ensemble member ',n + call stop2(9992) + end if + call gsi_bundlegetpointer(en_bar(m),trim(cvars3d(ic3)),x3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for en_bar' + call stop2(9993) + end if + + select case (trim(cvars3d(ic3))) + + case('sf','SF') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = u(j,i,k) + x3(j,i,k)=x3(j,i,k)+u(j,i,k) + end do + end do + end do + + case('vp','VP') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = v(j,i,k) + x3(j,i,k)=x3(j,i,k)+v(j,i,k) + end do + end do + end do + + case('t','T') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = tv(j,i,k) + x3(j,i,k)=x3(j,i,k)+tv(j,i,k) + end do + end do + end do + + case('q','Q') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = rh(j,i,k) + x3(j,i,k)=x3(j,i,k)+rh(j,i,k) + end do + end do + end do + + case('oz','OZ') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = oz(j,i,k) + x3(j,i,k)=x3(j,i,k)+oz(j,i,k) + end do + end do + end do + + + end select + end do + + do ic2=1,nc2d + + call gsi_bundlegetpointer(en_perts(n,m),trim(cvars2d(ic2)),w2,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for ensemble member ',n + call stop2(9994) + end if + call gsi_bundlegetpointer(en_bar(m),trim(cvars2d(ic2)),x2,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar' + call stop2(9995) + end if + + select case (trim(cvars2d(ic2))) + + case('ps','PS') + + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w2(j,i) = ps(j,i) + x2(j,i)=x2(j,i)+ps(j,i) + end do + end do + + case('sst','SST') + ! IGNORE SST IN HYBRID for now + + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w2(j,i) = zero + x2(j,i)=zero + end do + end do + + end select + end do + enddo + ! + ! CALCULATE ENSEMBLE MEAN + bar_norm = one/float(n_ens) + en_bar(m)%values=en_bar(m)%values*bar_norm + + ! Copy pbar to module array. ps_bar may be needed for vertical localization + ! in terms of scale heights/normalized p/p + do ic2=1,nc2d + + if(trim(cvars2d(ic2)) == 'ps'.or.trim(cvars2d(ic2)) == 'PS') then + + call gsi_bundlegetpointer(en_bar(m),trim(cvars2d(ic2)),x2,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar to get ps_bar' + call stop2(9996) + end if + + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + ps_bar(j,i,1)=x2(j,i) + end do + end do + exit + end if + end do + + call mpi_barrier(mpi_comm_world,ierror) + ! + ! CALCULATE ENSEMBLE SPREAD + call this%ens_spread_dualres_regional(mype,en_perts,nelen,en_bar(m)) + call mpi_barrier(mpi_comm_world,ierror) + ! + ! CONVERT ENSEMBLE MEMBERS TO ENSEMBLE PERTURBATIONS + sig_norm=sqrt(one/max(one,n_ens-one)) + + do n=1,n_ens + do i=1,nelen + en_perts(n,m)%valuesr4(i)=(en_perts(n,m)%valuesr4(i)-en_bar(m)%values(i))*sig_norm + end do + end do + + enddo ! it 4d loop + do m=1,ntlevs_ens + call gsi_bundledestroy(en_bar(m),istatus) + if(istatus/=0) then + write(6,*)' in get_fv3_regional_ensperts_netcdf: trouble destroying en_bar bundle' + call stop2(9997) + endif + end do + + deallocate(en_bar) + ! + + return + +30 write(6,*) 'get_fv3_regional_ensperts_netcdf: open filelist failed ' + call stop2(555) +20 write(6,*) 'get_fv3_regional_ensperts_netcdf: read WRF-ARW ens failed ',n + call stop2(555) + + end subroutine get_fv3_regional_ensperts_run + + subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g_rh,g_oz) + !$$$ subprogram documentation block + ! first compied from general_read_arw_regional . . . . + ! subprogram: general_read_fv3_regional read fv3sar model ensemble members + ! prgmmr: Ting org: emc/ncep date: 2018 + ! + ! abstract: read ensemble members from the fv3sar model in "restart" or "cold start" netcdf format + ! for use with hybrid ensemble option. + ! + ! program history log: + ! 2018- Ting - intial versions + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + + use netcdf, only: nf90_nowrite + use netcdf, only: nf90_open,nf90_close + use netcdf, only: nf90_inq_dimid,nf90_inquire_dimension + use netcdf, only: nf90_inq_varid,nf90_inquire_variable,nf90_get_var + use kinds, only: r_kind,r_single,i_kind + use gridmod, only: nsig,eta1_ll,pt_ll,aeta1_ll,eta2_ll,aeta2_ll + use constants, only: zero,one,fv,zero_single,rd_over_cp_mass,one_tenth,h300 + use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens + use hybrid_ensemble_parameters, only: fv3sar_ensemble_opt + + use mpimod, only: mpi_comm_world,ierror,mpi_rtype + use mpimod, only: npe + use netcdf_mod, only: nc_check + use gsi_rfv3io_mod,only: type_fv3regfilenameg + use gsi_rfv3io_mod,only:n2d + use gsi_rfv3io_mod,only:mype_t,mype_p ,mype_q,mype_oz + use constants, only: half,zero + use gsi_rfv3io_mod, only: gsi_fv3ncdf_read + use gsi_rfv3io_mod, only: gsi_fv3ncdf_read_v1 + use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv + use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv_v1 + use gsi_rfv3io_mod, only: gsi_fv3ncdf2d_read_v1 + + implicit none + ! + ! Declare passed variables + class(get_fv3_regional_ensperts_class), intent(inout) :: this + type (type_fv3regfilenameg) , intent (in) :: fv3_filenameginput + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out)::g_u,g_v,g_tv,g_rh,g_oz + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) ::g_tsen, g_q,g_prsl + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig+1) ::g_prsi + ! + ! Declare local parameters + real(r_kind),parameter:: r0_01 = 0.01_r_kind + real(r_kind),parameter:: r10 = 10.0_r_kind + real(r_kind),parameter:: r100 = 100.0_r_kind + ! + ! Declare local variables + + integer(i_kind):: i,j,k,kp + integer(i_kind) iderivative + + + logical ice + + character(len=24),parameter :: myname_ = 'general_read_fv3_regional' + + character(len=:),allocatable :: grid_spec !='fv3_grid_spec' + character(len=:),allocatable :: ak_bk !='fv3_akbk' + character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: tracers !='fv3_tracer' + character(len=:),allocatable :: sfcdata !='fv3_sfcdata' + character(len=:),allocatable :: couplerres!='coupler.res' + + associate( this => this ) ! eliminates warning for unused dummy argument needed for binding + end associate + + + + grid_spec=fv3_filenameginput%grid_spec + ak_bk=fv3_filenameginput%ak_bk + dynvars=fv3_filenameginput%dynvars + tracers=fv3_filenameginput%tracers + sfcdata=fv3_filenameginput%sfcdata + couplerres=fv3_filenameginput%couplerres + + + +!cltthinktobe should be contained in variable like grd_ens + + + if(fv3sar_ensemble_opt == 0 ) then + call gsi_fv3ncdf_readuv(dynvars,g_u,g_v) + else + call gsi_fv3ncdf_readuv_v1(dynvars,g_u,g_v) + endif + if(fv3sar_ensemble_opt == 0) then + call gsi_fv3ncdf_read(dynvars,'T','t',g_tsen,mype_t) + else + call gsi_fv3ncdf_read_v1(dynvars,'t','T',g_tsen,mype_t) + endif + if (fv3sar_ensemble_opt == 0) then + call gsi_fv3ncdf_read(dynvars,'DELP','delp',g_prsi,mype_p) + g_prsi(:,:,grd_ens%nsig+1)=eta1_ll(grd_ens%nsig+1) !thinkto be done , should use eta1_ll from ensemble grid + do i=grd_ens%nsig,1,-1 + g_prsi(:,:,i)=g_prsi(:,:,i)*0.001_r_kind+g_prsi(:,:,i+1) + enddo + g_ps(:,:)=g_prsi(:,:,1) + else ! for the ensemble processed frm CHGRES + call gsi_fv3ncdf2d_read_v1(dynvars,'ps','PS',g_ps,mype_p) + g_ps=g_ps*0.001_r_kind + do k=1,grd_ens%nsig+1 + g_prsi(:,:,k)=eta1_ll(k)+eta2_ll(k)*g_ps + enddo + + + endif + + if(fv3sar_ensemble_opt == 0) then + call gsi_fv3ncdf_read(tracers,'SPHUM','sphum',g_q,mype_q) + call gsi_fv3ncdf_read(tracers,'O3MR','o3mr',g_oz,mype_oz) + else + call gsi_fv3ncdf_read_v1(tracers,'sphum','SPHUM',g_q,mype_q) + call gsi_fv3ncdf_read_v1(tracers,'o3mr','O3MR',g_oz,mype_oz) + endif + +!! tsen2tv !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + g_tv(i,j,k)=g_tsen(i,j,k)*(one+fv*g_q(i,j,k)) + enddo + enddo + enddo + if (.not.q_hyb_ens) then + ice=.true. + iderivative=0 + do k=1,grd_ens%nsig + kp=k+1 + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + g_prsl(i,j,k)=(g_prsi(i,j,k)+g_prsi(i,j,kp))*half + end do + end do + end do + call genqsat(g_rh,g_tsen(1,1,1),g_prsl(1,1,1),grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,ice,iderivative) + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + g_rh(i,j,k) = g_q(i,j,k)/g_rh(i,j,k) + end do + end do + end do + else + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + g_rh(i,j,k) = g_q(i,j,k) + end do + end do + end do + end if + + + + + + return + end subroutine general_read_fv3_regional + subroutine ens_spread_dualres_regional_fv3_regional(this,mype,en_perts,nelen,en_bar) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: ens_spread_dualres_regional + ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 + ! + ! abstract: + ! + ! + ! program history log: + ! 2010-08-11 parrish, initial documentation + ! 2011-04-05 parrish - add pseudo-bundle capability + ! 2011-08-31 todling - revisit en_perts (single-prec) in light of extended bundle + ! + ! input argument list: + ! en_bar - ensemble mean + ! mype - current processor number + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + ! + use kinds, only: r_single,r_kind,i_kind + use hybrid_ensemble_parameters, only: n_ens,grd_ens,grd_anl,p_e2a,uv_hyb_ens, & + regional_ensemble_option + use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sube2suba + use constants, only: zero,two,half,one + use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d + use gsi_bundlemod, only: gsi_bundlecreate + use gsi_bundlemod, only: gsi_grid + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_bundlemod, only: gsi_bundledestroy + use gsi_bundlemod, only: gsi_gridcreate + implicit none + + class(get_fv3_regional_ensperts_class), intent(inout) :: this + type(gsi_bundle),OPTIONAL,intent(in):: en_bar + integer(i_kind),intent(in):: mype + type(gsi_bundle),allocatable, intent(in ) :: en_perts(:,:) + integer(i_kind), intent(in ):: nelen + + type(gsi_bundle):: sube,suba + type(gsi_grid):: grid_ens,grid_anl + real(r_kind) sp_norm,sig_norm_sq_inv + type(sub2grid_info)::se,sa + integer(i_kind) k + + integer(i_kind) i,n,ic3 + logical regional + integer(i_kind) num_fields,inner_vars,istat,istatus + logical,allocatable::vector(:) + real(r_kind),pointer,dimension(:,:,:):: st,vp,tv,rh,oz,cw + real(r_kind),pointer,dimension(:,:):: ps + real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig),target::dum3 + real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2),target::dum2 + + associate( this => this ) ! eliminates warning for unused dummy argument needed for binding + end associate + + ! create simple regular grid + call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) + call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) + + ! create two internal bundles, one on analysis grid and one on ensemble grid + + call gsi_bundlecreate (suba,grid_anl,'ensemble work',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)' in ens_spread_dualres_regional: trouble creating bundle_anl bundle' + call stop2(9998) + endif + call gsi_bundlecreate (sube,grid_ens,'ensemble work ens',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)' ens_spread_dualres_regional: trouble creating bundle_ens bundle' + call stop2(9999) + endif + + sp_norm=(one/float(n_ens)) + + sube%values=zero + ! + + if(regional_ensemble_option == 1)then + print *,'global ensemble' + sig_norm_sq_inv=n_ens-one + + do n=1,n_ens + do i=1,nelen + sube%values(i)=sube%values(i) & + +en_perts(n,1)%valuesr4(i)*en_perts(n,1)%valuesr4(i) + end do + end do + + do i=1,nelen + sube%values(i) = sqrt(sp_norm*sig_norm_sq_inv*sube%values(i)) + end do + else + do n=1,n_ens + do i=1,nelen + sube%values(i)=sube%values(i) & + +(en_perts(n,1)%valuesr4(i)-en_bar%values(i))*(en_perts(n,1)%valuesr4(i)-en_bar%values(i)) + end do + end do + + do i=1,nelen + sube%values(i) = sqrt(sp_norm*sube%values(i)) + end do + end if + + if(grd_ens%latlon1n == grd_anl%latlon1n) then + do i=1,nelen + suba%values(i)=sube%values(i) + end do + else + inner_vars=1 + num_fields=max(0,nc3d)*grd_ens%nsig+max(0,nc2d) + allocate(vector(num_fields)) + vector=.false. + do ic3=1,nc3d + if(trim(cvars3d(ic3))=='sf'.or.trim(cvars3d(ic3))=='vp') then + do k=1,grd_ens%nsig + vector((ic3-1)*grd_ens%nsig+k)=uv_hyb_ens + end do + end if + end do + call general_sub2grid_create_info(se,inner_vars,grd_ens%nlat,grd_ens%nlon,grd_ens%nsig,num_fields, & + regional,vector) + call general_sub2grid_create_info(sa,inner_vars,grd_anl%nlat,grd_anl%nlon,grd_anl%nsig,num_fields, & + regional,vector) + deallocate(vector) + call general_sube2suba(se,sa,p_e2a,sube%values,suba%values,regional) + end if + + dum2=zero + dum3=zero + call gsi_bundlegetpointer(suba,'sf',st,istat) + if(istat/=0) then + write(6,*)' no sf pointer in ens_spread_dualres, point st at dum3 array' + st => dum3 + end if + call gsi_bundlegetpointer(suba,'vp',vp,istat) + if(istat/=0) then + write(6,*)' no vp pointer in ens_spread_dualres, point vp at dum3 array' + vp => dum3 + end if + call gsi_bundlegetpointer(suba,'t',tv,istat) + if(istat/=0) then + write(6,*)' no t pointer in ens_spread_dualres, point tv at dum3 array' + tv => dum3 + end if + call gsi_bundlegetpointer(suba,'q',rh,istat) + if(istat/=0) then + write(6,*)' no q pointer in ens_spread_dualres, point rh at dum3 array' + rh => dum3 + end if + call gsi_bundlegetpointer(suba,'oz',oz,istat) + if(istat/=0) then + write(6,*)' no oz pointer in ens_spread_dualres, point oz at dum3 array' + oz => dum3 + end if + call gsi_bundlegetpointer(suba,'cw',cw,istat) + if(istat/=0) then + write(6,*)' no cw pointer in ens_spread_dualres, point cw at dum3 array' + cw => dum3 + end if + call gsi_bundlegetpointer(suba,'ps',ps,istat) + if(istat/=0) then + write(6,*)' no ps pointer in ens_spread_dualres, point ps at dum2 array' + ps => dum2 + end if + + call write_spread_dualres(st,vp,tv,rh,oz,cw,ps,mype) + + return + end subroutine ens_spread_dualres_regional_fv3_regional + +end module get_fv3_regional_ensperts_mod diff --git a/src/cplr_get_pseudo_ensperts.f90 b/src/gsi/cplr_get_pseudo_ensperts.f90 similarity index 100% rename from src/cplr_get_pseudo_ensperts.f90 rename to src/gsi/cplr_get_pseudo_ensperts.f90 diff --git a/src/gsi/cplr_get_wrf_mass_ensperts.f90 b/src/gsi/cplr_get_wrf_mass_ensperts.f90 new file mode 100644 index 000000000..6ddafd445 --- /dev/null +++ b/src/gsi/cplr_get_wrf_mass_ensperts.f90 @@ -0,0 +1,1925 @@ +module get_wrf_mass_ensperts_mod +use abstract_get_wrf_mass_ensperts_mod + use kinds, only : i_kind + type, extends(abstract_get_wrf_mass_ensperts_class) :: get_wrf_mass_ensperts_class + contains + procedure, pass(this) :: get_wrf_mass_ensperts => get_wrf_mass_ensperts_wrf + procedure, pass(this) :: ens_spread_dualres_regional => ens_spread_dualres_regional_wrf + procedure, pass(this) :: general_read_wrf_mass + procedure, pass(this) :: parallel_read_wrf_mass_step1 + procedure, pass(this) :: parallel_read_wrf_mass_step2 + procedure, pass(this) :: general_read_wrf_mass2 + procedure, nopass :: fill_regional_2d + end type get_wrf_mass_ensperts_class +contains + subroutine get_wrf_mass_ensperts_wrf(this,en_perts,nelen,ps_bar) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: get_wrf_mass_ensperts read arw model ensemble members + ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 + ! + ! abstract: read ensemble members from the arw model in netcdf format, for use + ! with hybrid ensemble option. ensemble spread is also written out as + ! a byproduct for diagnostic purposes. + ! + ! + ! program history log: + ! 2010-08-11 parrish, initial documentation + ! 2011-08-31 todling - revisit en_perts (single-prec) in light of extended bundle + ! 2012-02-08 kleist - add extra dimension to en_perts for 4d application + ! (currently use placeholder of value 1, since regional 4d application not + ! 2017-07-30 Hu - added code to read in multiple-time level ensemble forecast to + ! get 4D peerturbations + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + + use kinds, only: r_kind,i_kind,r_single + use constants, only: zero,one,half,zero_single,rd_over_cp,one_tenth + use mpimod, only: mpi_comm_world,ierror,mype,npe + use hybrid_ensemble_parameters, only: n_ens,grd_ens,ens_fast_read + use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path + use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d + use gsi_bundlemod, only: gsi_bundlecreate + use gsi_bundlemod, only: gsi_grid + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_bundlemod, only: gsi_bundledestroy + use gsi_bundlemod, only: gsi_gridcreate + use mpeu_util, only: getindex + use guess_grids, only: ntguessig,ifilesig + use gsi_4dvar, only: nhr_assimilation + + implicit none + class(get_wrf_mass_ensperts_class), intent(inout) :: this + type(gsi_bundle),allocatable, intent(inout) :: en_perts(:,:) + integer(i_kind), intent(in ):: nelen + real(r_single),dimension(:,:,:),allocatable:: ps_bar + + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig):: u,v,tv,cwmr,oz,rh + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2):: ps + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)::w,qr,qi,qg,qs,qni,qnc,qnr + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)::dbz + + real(r_single),pointer,dimension(:,:,:):: w3 + real(r_single),pointer,dimension(:,:):: w2 + real(r_kind),pointer,dimension(:,:,:):: x3 + real(r_kind),pointer,dimension(:,:):: x2 + type(gsi_bundle):: en_bar + type(gsi_grid):: grid_ens + real(r_kind):: bar_norm,sig_norm,kapr,kap1 + + integer(i_kind):: i,j,k,n,mm1,istatus + integer(i_kind):: ic2,ic3,i_radar_qr,i_radar_qg + integer(i_kind):: its,ite, it + + character(255) filelists(ntlevs_ens) + character(255) filename + + logical :: do_radar + logical :: do_ens_fast_read + + ! Variables used only by the ensemble fast read + integer(i_kind) :: iope + logical :: bad_input + real(r_kind),dimension(:,:,:),allocatable :: gg_u,gg_v,gg_tv,gg_rh + real(r_kind),dimension(:,:),allocatable :: gg_ps + + call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) + call gsi_bundlecreate(en_bar,grid_ens,'ensemble',istatus,names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)' get_wrf_mass_ensperts_netcdf: trouble creating en_bar bundle' + call stop2(999) + endif + + if(ntlevs_ens > 1) then + do i=1,ntlevs_ens + write(filelists(i),'("filelist",i2.2)')ifilesig(i) + enddo + its=1 + ite=ntlevs_ens + else + write(filelists(1),'("filelist",i2.2)')nhr_assimilation + its=ntguessig + ite=ntguessig + endif + + do it=its,ite + if (mype == 0) write(*,*) 'ensemble file==',it,its,ite,ntlevs_ens,n_ens + if(ntlevs_ens > 1) then + open(10,file=trim(filelists(it)),form='formatted',err=30) + else + open(10,file=trim(filelists(1)),form='formatted',err=30) + endif + + + ! + ! INITIALIZE ENSEMBLE MEAN ACCUMULATORS + en_bar%values=zero + + do n=1,n_ens + en_perts(n,it)%valuesr4 = zero + enddo + + ! Determine if qr and qg are control variables for radar data assimilation, + i_radar_qr=0 + i_radar_qg=0 + i_radar_qr=getindex(cvars3d,'qr') + i_radar_qg=getindex(cvars3d,'qg') + do_radar=i_radar_qr > 0 .and. i_radar_qg > 0 + + mm1=mype+1 + kap1=rd_over_cp+one + kapr=one/rd_over_cp + + ! If ens_fast_read is requested, check whether we really can use it. + do_ens_fast_read = ens_fast_read + can_ens_fast_read: if( do_ens_fast_read ) then ! make sure we can + if(n_ens>npe) then + do_ens_fast_read=.false. +130 format('Disabling ens_fast_read because number of ensemble members (',I0,') is greater than number of MPI ranks (',I0,').') + if(mype==0) then + write(6,130) n_ens,npe + endif + endif + if(do_radar) then + do_ens_fast_read=.false. + if(mype==0) then + write(6,'(A)') 'Disabling ens_fast_read because "radar mode" is in use (qg and qr are control variables). Fast read is not yet implemented in "radar mode."' + endif + endif + endif can_ens_fast_read + if(do_ens_fast_read .and. mype==0) then + write(6,'(I0,A)') mype,': will read ensemble data in parallel (ens_fast_read=.true.)' + endif + + ! + ! If we're doing ens_fast_read, then this loop reads data. + ens_parallel_read: if(do_ens_fast_read) then + if(mype==0) then + write(0,*) 'Will use ens_fast_read to read ARW ensemble.' + endif + ens_read_loop: do n=1,n_ens + read(10,'(a)',err=20,end=20)filename + filename=trim(ensemble_path) // trim(filename) + iope=(n-1)*npe/n_ens + if(mype==iope) then + allocate(gg_u(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_v(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_tv(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_rh(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_ps(grd_ens%nlat,grd_ens%nlon)) + bad_input=.false. + call this%parallel_read_wrf_mass_step1(filename,gg_ps,gg_tv,gg_u,gg_v,gg_rh) + endif + end do ens_read_loop + + call MPI_Barrier(mpi_comm_world,ierror) + end if ens_parallel_read + + rewind(10) + ! + ! LOOP OVER ENSEMBLE MEMBERS + ens_main_loop: do n=1,n_ens + ! + ! DEFINE INPUT FILE NAME + ! + ! READ OR SCATTER ENEMBLE MEMBER DATA + read(10,'(a)',err=20,end=20)filename + filename=trim(ensemble_path) // trim(filename) + scatter_or_read: if(do_ens_fast_read) then + ! Scatter data from the parallel read. + iope=(n-1)*npe/n_ens + if(mype==iope) then + write(0,'(I0,A,I0,A)') mype,': scatter member ',n,' to other ranks...' + call this%parallel_read_wrf_mass_step2(mype,iope,& + ps,u,v,tv,rh,cwmr,oz, & + gg_ps,gg_tv,gg_u,gg_v,gg_rh) + else + call this%parallel_read_wrf_mass_step2(mype,iope,& + ps,u,v,tv,rh,cwmr,oz) + endif + else + if (mype == 0) then + write(6,'(a,a)') 'CALL READ_WRF_MASS_ENSPERTS FOR ENS DATA : ',trim(filename) + endif + if( do_radar )then + call this%general_read_wrf_mass2(filename,ps,u,v,tv,rh,cwmr,oz,w,dbz,qs,qg,qi,qr,qnc,qni,qnr,mype) + else + call this%general_read_wrf_mass(filename,ps,u,v,tv,rh,cwmr,oz,mype) + end if + endif scatter_or_read + + call MPI_Barrier(mpi_comm_world,ierror) + + ! SAVE ENSEMBLE MEMBER DATA IN COLUMN VECTOR + member_data_loop: do ic3=1,nc3d + + call gsi_bundlegetpointer(en_perts(n,it),trim(cvars3d(ic3)),w3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for ensemble member ',n + call stop2(999) + end if + call gsi_bundlegetpointer(en_bar,trim(cvars3d(ic3)),x3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for en_bar' + call stop2(999) + end if + + select case (trim(cvars3d(ic3))) + + case('sf','SF') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = u(j,i,k) + x3(j,i,k)=x3(j,i,k)+u(j,i,k) + end do + end do + end do + + case('vp','VP') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = v(j,i,k) + x3(j,i,k)=x3(j,i,k)+v(j,i,k) + end do + end do + end do + + case('t','T') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = tv(j,i,k) + x3(j,i,k)=x3(j,i,k)+tv(j,i,k) + end do + end do + end do + + case('q','Q') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = rh(j,i,k) + x3(j,i,k)=x3(j,i,k)+rh(j,i,k) + end do + end do + end do + + case('w','W') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = w(j,i,k) + x3(j,i,k)=x3(j,i,k)+w(j,i,k) + end do + end do + end do + + case('qr','QR') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = qr(j,i,k) + x3(j,i,k)=x3(j,i,k)+qr(j,i,k) + end do + end do + end do + + case('qs','QS') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = qs(j,i,k) + x3(j,i,k)=x3(j,i,k)+qs(j,i,k) + end do + end do + end do + + case('qi','QI') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = qi(j,i,k) + x3(j,i,k)=x3(j,i,k)+qi(j,i,k) + end do + end do + end do + + case('qnr','QNR') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = qnr(j,i,k) + x3(j,i,k)=x3(j,i,k)+qnr(j,i,k) + end do + end do + end do + + case('qnc','QNC') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = qnc(j,i,k) + x3(j,i,k)=x3(j,i,k)+qnc(j,i,k) + end do + end do + end do + + case('qni','QNI') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = qni(j,i,k) + x3(j,i,k)=x3(j,i,k)+qni(j,i,k) + end do + end do + end do + + case('dbz','DBZ') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = dbz(j,i,k) + x3(j,i,k)=x3(j,i,k)+dbz(j,i,k) + end do + end do + end do + + case('qg','QG') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = qg(j,i,k) + x3(j,i,k)=x3(j,i,k)+qg(j,i,k) + end do + end do + end do + + case('oz','OZ') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = oz(j,i,k) + x3(j,i,k)=x3(j,i,k)+oz(j,i,k) + end do + end do + end do + + case('cw','CW', 'ql', 'QL') + + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = cwmr(j,i,k) + x3(j,i,k)=x3(j,i,k)+cwmr(j,i,k) + end do + end do + end do + + end select + end do member_data_loop + + member_mass_loop: do ic2=1,nc2d + + call gsi_bundlegetpointer(en_perts(n,it),trim(cvars2d(ic2)),w2,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for ensemble member ',n + call stop2(999) + end if + call gsi_bundlegetpointer(en_bar,trim(cvars2d(ic2)),x2,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar' + call stop2(999) + end if + + select case (trim(cvars2d(ic2))) + + case('ps','PS') + + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w2(j,i) = ps(j,i) + x2(j,i)=x2(j,i)+ps(j,i) + end do + end do + + case('sst','SST') + ! IGNORE SST IN HYBRID for now + + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w2(j,i) = zero + x2(j,i)=zero + end do + end do + + end select + end do member_mass_loop + enddo ens_main_loop + + ! + ! CALCULATE ENSEMBLE MEAN + bar_norm = one/float(n_ens) + en_bar%values=en_bar%values*bar_norm + + ! Copy pbar to module array. ps_bar may be needed for vertical localization + ! in terms of scale heights/normalized p/p + pbar_loop: do ic2=1,nc2d + + if(trim(cvars2d(ic2)) == 'ps'.or.trim(cvars2d(ic2)) == 'PS') then + + call gsi_bundlegetpointer(en_bar,trim(cvars2d(ic2)),x2,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar to get ps_bar' + call stop2(999) + end if + + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + ps_bar(j,i,1)=x2(j,i) + end do + end do + exit + end if + end do pbar_loop + + call mpi_barrier(mpi_comm_world,ierror) + ! + ! CALCULATE ENSEMBLE SPREAD + call this%ens_spread_dualres_regional(mype,en_perts,nelen,en_bar) + call mpi_barrier(mpi_comm_world,ierror) + ! + ! CONVERT ENSEMBLE MEMBERS TO ENSEMBLE PERTURBATIONS + sig_norm=sqrt(one/max(one,n_ens-one)) + + do n=1,n_ens + do i=1,nelen + en_perts(n,it)%valuesr4(i)=(en_perts(n,it)%valuesr4(i)-en_bar%values(i))*sig_norm + end do + end do + + enddo ! it 4d loop + ! + call gsi_bundledestroy(en_bar,istatus) + if(istatus/=0) then + write(6,*)' in get_wrf_mass_ensperts_netcdf: trouble destroying en_bar bundle' + call stop2(999) + endif + + if(allocated(gg_u)) deallocate(gg_u) + if(allocated(gg_v)) deallocate(gg_v) + if(allocated(gg_tv)) deallocate(gg_tv) + if(allocated(gg_rh)) deallocate(gg_rh) + if(allocated(gg_ps)) deallocate(gg_ps) + + return +30 write(6,*) 'get_wrf_mass_ensperts_netcdf: open filelist failed ' + call stop2(555) +20 write(6,*) 'get_wrf_mass_ensperts_netcdf: read WRF-ARW ens failed ',n + call stop2(555) + + end subroutine get_wrf_mass_ensperts_wrf + + subroutine general_read_wrf_mass(this,filename,g_ps,g_u,g_v,g_tv,g_rh,g_cwmr,g_oz,mype) + use kinds, only: r_kind,i_kind,r_single + use hybrid_ensemble_parameters, only: grd_ens + implicit none + ! + ! Declare passed variables + class(get_wrf_mass_ensperts_class), intent(inout) :: this + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out):: & + g_u,g_v,g_tv,g_rh,g_cwmr,g_oz + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps + character(255),intent(in):: filename + integer,intent(in) :: mype + + real(r_kind),dimension(:,:,:),allocatable :: gg_u,gg_v,gg_tv,gg_rh + real(r_kind),dimension(:,:),allocatable :: gg_ps + + if(mype==0) then + allocate(gg_u(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_v(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_tv(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_rh(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_ps(grd_ens%nlat,grd_ens%nlon)) + call this%parallel_read_wrf_mass_step1(filename,gg_ps,gg_tv,gg_u,gg_v,gg_rh) + call this%parallel_read_wrf_mass_step2(mype,0, & + g_ps,g_u,g_v,g_tv,g_rh,g_cwmr,g_oz, & + gg_ps,gg_tv,gg_u,gg_v,gg_rh) + deallocate(gg_u,gg_v,gg_tv,gg_rh,gg_ps) + else + call this%parallel_read_wrf_mass_step2(mype,0, & + g_ps,g_u,g_v,g_tv,g_rh,g_cwmr,g_oz) + endif + end subroutine general_read_wrf_mass + + subroutine parallel_read_wrf_mass_step1(this,filename,gg_ps,gg_tv,gg_u,gg_v,gg_rh) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: general_read_wrf_mass read arw model ensemble members + ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 + ! + ! abstract: read ensemble members from the arw model in "wrfout" netcdf format + ! for use with hybrid ensemble option. + ! + ! program history log: + ! 2010-08-11 parrish, initial documentation + ! 2010-09-10 parrish, modify so ensemble variables are read in the same way as in + ! subroutines convert_netcdf_mass and read_wrf_mass_binary_guess. + ! There were substantial differences due to different opinion about what + ! to use for surface pressure. This issue should be resolved by coordinating + ! with Ming Hu (ming.hu@noaa.gov). At the moment, these changes result in + ! agreement to single precision between this input method and the guess input + ! procedure when the same file is read by both methods. + ! 2012-03-12 whitaker: read data on root, distribute with scatterv. + ! remove call to general_reload. + ! simplify, fix memory leaks, reduce memory footprint. + ! use genqsat, remove genqsat2_regional. + ! replace bare 'stop' statements with call stop2(999). + ! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS core + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + + use netcdf, only: nf90_nowrite + use netcdf, only: nf90_open,nf90_close + use netcdf, only: nf90_inq_dimid,nf90_inquire_dimension + use netcdf, only: nf90_inq_varid,nf90_inquire_variable,nf90_get_var + use kinds, only: r_kind,r_single,i_kind + use gridmod, only: nsig,eta1_ll,pt_ll,aeta1_ll,eta2_ll,aeta2_ll + use constants, only: zero,one,fv,zero_single,rd_over_cp_mass,one_tenth,h300 + use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens + use netcdf_mod, only: nc_check + use mpimod, only: mype + + implicit none + ! + ! Declare passed variables + class(get_wrf_mass_ensperts_class), intent(inout) :: this + + character(255),intent(in):: filename + + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig) :: gg_u,gg_v,gg_tv,gg_rh + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon):: gg_ps + + ! + ! Declare local parameters + real(r_kind),parameter:: r0_01 = 0.01_r_kind + real(r_kind),parameter:: r10 = 10.0_r_kind + real(r_kind),parameter:: r100 = 100.0_r_kind + ! + ! Declare local variables + real(r_single),allocatable,dimension(:):: temp_1d + real(r_single),allocatable,dimension(:,:):: temp_2d,temp_2d2 + real(r_single),allocatable,dimension(:,:,:):: temp_3d + real(r_kind),allocatable,dimension(:):: p_top + real(r_kind),allocatable,dimension(:,:):: q_integral,q_integralc4h + real(r_kind),allocatable,dimension(:,:,:):: tsn,qst,prsl + integer(i_kind),allocatable,dimension(:):: dim,dim_id + + integer(i_kind):: nx,ny,nz,i,j,k,d_max,file_id,var_id,ndim + integer(i_kind):: Time_id,s_n_id,w_e_id,b_t_id,s_n_stag_id,w_e_stag_id,b_t_stag_id + integer(i_kind):: Time_len,s_n_len,w_e_len,b_t_len,s_n_stag_len,w_e_stag_len,b_t_stag_len + integer(i_kind) iderivative + + real(r_kind):: deltasigma + real(r_kind) psfc_this_dry,psfc_this + real(r_kind) work_prslk,work_prsl + + logical ice + + character(len=24),parameter :: myname_ = 'general_read_wrf_mass' + + + associate( this => this ) ! eliminates warning for unused dummy argument + ! needed for binding + end associate + + ! + ! OPEN ENSEMBLE MEMBER DATA FILE +30 format(I0,': read ',A) + write(6,*) mype,trim(filename) + call nc_check( nf90_open(trim(filename),nf90_nowrite,file_id),& + myname_,'open '//trim(filename) ) + ! + ! WRF FILE DIMENSIONS + call nc_check( nf90_inq_dimid(file_id,'Time',Time_id),& + myname_,'inq_dimid Time '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'south_north',s_n_id),& + myname_,'inq_dimid south_north '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'west_east',w_e_id),& + myname_,'inq_dimid west_east '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'bottom_top',b_t_id),& + myname_,'inq_dimid bottom_top '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'south_north_stag',s_n_stag_id),& + myname_,'inq_dimid south_north_stag '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'west_east_stag',w_e_stag_id),& + myname_,'inq_dimid west_east_stag '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'bottom_top_stag',b_t_stag_id),& + myname_,'inq_dimid bottom_top_stag '//trim(filename) ) + + d_max=max(Time_id, s_n_id, w_e_id, b_t_id, s_n_stag_id, w_e_stag_id, b_t_stag_id) + allocate(dim(d_max)) + dim(:)=-999 + + call nc_check( nf90_inquire_dimension(file_id,Time_id,len=Time_len),& + myname_,'inquire_dimension Time '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,s_n_id,len=s_n_len),& + myname_,'inquire_dimension south_north '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,w_e_id,len=w_e_len),& + myname_,'inquire_dimension west_east '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,b_t_id,len=b_t_len),& + myname_,'inquire_dimension bottom_top '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,s_n_stag_id,len=s_n_stag_len),& + myname_,'inquire_dimension south_north_stag '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,w_e_stag_id,len=w_e_stag_len),& + myname_,'inquire_dimension west_east_stag '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,b_t_stag_id,len=b_t_stag_len),& + myname_,'inquire_dimension bottom_top_stag '//trim(filename) ) + + nx=w_e_len + ny=s_n_len + nz=b_t_len + if (nx /= grd_ens%nlon .or. ny /= grd_ens%nlat .or. nz /= grd_ens%nsig) then + print *,trim(filename)//': ','incorrect grid size in netcdf file' + print *,trim(filename)//': ','nx,ny,nz,nlon,nlat,nsig',nx,ny,nz,grd_ens%nlon,grd_ens%nlat,grd_ens%nsig + call stop2(999) + endif + + dim(Time_id)=Time_len + dim(s_n_id)=s_n_len + dim(w_e_id)=w_e_len + dim(b_t_id)=b_t_len + dim(s_n_stag_id)=s_n_stag_len + dim(w_e_stag_id)=w_e_stag_len + dim(b_t_stag_id)=b_t_stag_len + ! + ! READ PERTURBATION POTENTIAL TEMPERATURE (K) + ! print *,trim(filename)//': ', 'read T ',filename + call nc_check( nf90_inq_varid(file_id,'T',var_id),& + myname_,'inq_varid T '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable T '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable T '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var T '//trim(filename) ) + allocate(tsn(dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3)))) + tsn = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + + ! READ MU, MUB, P_TOP (construct psfc as done in gsi--gives different result compared to PSFC) + + call nc_check( nf90_inq_varid(file_id,'P_TOP',var_id),& + myname_,'inq_varid P_TOP '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable P_TOP '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable P_TOP '//trim(filename) ) + allocate(temp_1d(dim(dim_id(1)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_1d),& + myname_,'get_var P_TOP '//trim(filename) ) + allocate(p_top(dim(dim_id(1)))) + do i=1,dim(dim_id(1)) + p_top(i)=temp_1d(i) + enddo + deallocate(dim_id) + + call nc_check( nf90_inq_varid(file_id,'MUB',var_id),& + myname_,'inq_varid MUB '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable MUB '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable MUB '//trim(filename) ) + allocate(temp_2d(dim(dim_id(1)),dim(dim_id(2)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_2d),& + myname_,'get_var MUB '//trim(filename) ) + deallocate(dim_id) + + call nc_check( nf90_inq_varid(file_id,'MU',var_id),& + myname_,'inq_varid MU '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable MU '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable MU '//trim(filename) ) + allocate(temp_2d2(dim(dim_id(1)),dim(dim_id(2)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_2d2),& + myname_,'get_var MU '//trim(filename) ) + + do j=1,dim(dim_id(2)) + do i=1,dim(dim_id(1)) + temp_2d2(i,j)=temp_2d(i,j)+temp_2d2(i,j)+temp_1d(1) + gg_ps(j,i)=temp_2d2(i,j) + enddo + enddo + print *,trim(filename)//': ','min/max ps',minval(gg_ps),maxval(gg_ps) + deallocate(temp_2d,temp_2d2,temp_1d,dim_id) + + ! + ! READ U (m/s) + !print *,trim(filename)//': ', 'read U ',filename + call nc_check( nf90_inq_varid(file_id,'U',var_id),& + myname_,'inq_varid U '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable U '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable U '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var U '//trim(filename) ) + ! + ! INTERPOLATE TO MASS GRID + do k=1,dim(dim_id(3)) + do j=1,dim(dim_id(2)) + do i=1,dim(dim_id(1))-1 + gg_u(j,i,k)=.5*(temp_3d(i,j,k)+temp_3d(i+1,j,k)) + enddo + enddo + enddo + deallocate(temp_3d) + deallocate(dim_id) + ! + ! READ V (m/s) + !print *,trim(filename)//': ', 'read V ',filename + call nc_check( nf90_inq_varid(file_id,'V',var_id),& + myname_,'inq_varid V '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable V '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable V '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var V '//trim(filename) ) + ! + ! INTERPOLATE TO MASS GRID + do k=1,dim(dim_id(3)) + do j=1,dim(dim_id(2))-1 + do i=1,dim(dim_id(1)) + gg_v(j,i,k)=.5*(temp_3d(i,j,k)+temp_3d(i,j+1,k)) + enddo + enddo + enddo + deallocate(temp_3d) + deallocate(dim_id) + print *,trim(filename)//': ','min/max u',minval(gg_u),maxval(gg_u) + print *,trim(filename)//': ','min/max v',minval(gg_v),maxval(gg_v) + ! + ! READ QVAPOR (kg/kg) + !print *,trim(filename)//': ', 'read QVAPOR ',filename + call nc_check( nf90_inq_varid(file_id,'QVAPOR',var_id),& + myname_,'inq_varid QVAPOR '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QVAPOR '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QVAPOR '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QVAPOR '//trim(filename) ) + gg_rh = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id,dim) + + call nc_check( nf90_close(file_id),& + myname_,'close '//trim(filename) ) + ! + ! CALCULATE TOTAL POTENTIAL TEMPERATURE (K) + !print *,trim(filename)//': ', 'calculate total temperature ',filename + do i=1,nx + do j=1,ny + do k=1,nz + tsn(j,i,k)=tsn(j,i,k)+h300 + enddo + enddo + enddo + ! + ! INTEGRATE {1 + WATER VAPOR} TO CONVERT DRY AIR PRESSURE + !print *,trim(filename)//': ', 'integrate 1 + q vertically ',filename + allocate(q_integral(ny,nx)) + allocate(q_integralc4h(ny,nx)) + q_integral(:,:)=one + q_integralc4h=0.0_r_single + do i=1,nx + do j=1,ny + do k=1,nz + deltasigma=eta1_ll(k)-eta1_ll(k+1) + q_integral(j,i)=q_integral(j,i)+deltasigma*gg_rh(j,i,k) + q_integralc4h(j,i)=q_integralc4h(j,i)+(eta2_ll(k)-eta2_ll(k+1))*gg_rh(j,i,k) + enddo + enddo + enddo + ! + ! CONVERT WATER VAPOR MIXING RATIO TO SPECIFIC HUMIDITY + do i=1,nx + do j=1,ny + do k=1,nz + gg_rh(j,i,k)=gg_rh(j,i,k)/(one+gg_rh(j,i,k)) + enddo + enddo + enddo + + ! obtaining psfc as done in subroutine read_wrf_mass_netcdf_guess + do i=1,nx + do j=1,ny + psfc_this_dry=r0_01*gg_ps(j,i) + psfc_this=(psfc_this_dry-pt_ll)*q_integral(j,i)+pt_ll+q_integralc4h(j,i) + gg_ps(j,i)=one_tenth*psfc_this ! convert from mb to cb + end do + end do + ! + ! CONVERT POTENTIAL TEMPERATURE TO VIRTUAL TEMPERATURE + !print *,trim(filename)//': ', 'convert potential temp to virtual temp ',filename + allocate(prsl(ny,nx,nz)) + do k=1,nz + do i=1,nx + do j=1,ny + work_prsl = one_tenth*(aeta1_ll(k)*(r10*gg_ps(j,i)-pt_ll)+& + aeta2_ll(k) + pt_ll) + prsl(j,i,k)=work_prsl + work_prslk = (work_prsl/r100)**rd_over_cp_mass + ! sensible temp from pot temp + tsn(j,i,k) = tsn(j,i,k)*work_prslk + ! virtual temp from sensible temp + gg_tv(j,i,k) = tsn(j,i,k) * (one+fv*gg_rh(j,i,k)) + ! recompute sensible temp from virtual temp + tsn(j,i,k)= gg_tv(j,i,k)/(one+fv*max(zero,gg_rh(j,i,k))) + end do + end do + end do + print *,trim(filename)//': ','min/max tv',minval(gg_tv),maxval(gg_tv) + + ! + ! CALCULATE PSEUDO RELATIVE HUMIDITY IF USING RH VARIABLE + if (.not.q_hyb_ens) then + allocate(qst(ny,nx,nz)) + ice=.true. + iderivative=0 + call genqsat(qst,tsn,prsl,ny,nx,nsig,ice,iderivative) + do k=1,nz + do i=1,nx + do j=1,ny + gg_rh(j,i,k)=gg_rh(j,i,k)/qst(j,i,k) + enddo + enddo + enddo + print *,trim(filename)//': ','min/max rh',minval(gg_rh),maxval(gg_rh) + deallocate(qst) + else + print *,trim(filename)//': ','min/max q',minval(gg_rh),maxval(gg_rh) + end if + + ! DEALLOCATE REMAINING TEMPORARY STORAGE + deallocate(tsn,prsl,q_integral,p_top) + + return + end subroutine parallel_read_wrf_mass_step1 + + subroutine parallel_read_wrf_mass_step2(this,mype,iope, & + g_ps,g_u,g_v,g_tv,g_rh,g_cwmr,g_oz, & + gg_ps,gg_tv,gg_u,gg_v,gg_rh) + + use hybrid_ensemble_parameters, only: grd_ens + use mpimod, only: mpi_comm_world,ierror,mpi_rtype + use kinds, only: r_kind,r_single,i_kind + implicit none + + ! + ! Declare passed variables + class(get_wrf_mass_ensperts_class), intent(inout) :: this + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out):: & + g_u,g_v,g_tv,g_rh,g_cwmr,g_oz + integer(i_kind), intent(in) :: mype, iope + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps + + ! The gg_ arrays are only sent by the rank doing I/O (mype==iope) + real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig) :: & + gg_u,gg_v,gg_tv,gg_rh + real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon):: gg_ps + + ! Declare local variables + real(r_kind),allocatable,dimension(:):: wrk_send_2d + integer(i_kind) :: k + + ! transfer data from root to subdomains on each task + ! scatterv used, since full grids exist only on root task. + allocate(wrk_send_2d(grd_ens%itotsub)) + ! first PS (output from fill_regional_2d is a column vector with a halo) + if(mype==iope) call this%fill_regional_2d(gg_ps,wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_ps,grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + ! then TV,U,V,RH + do k=1,grd_ens%nsig + if (mype==iope) then + call this%fill_regional_2d(gg_tv(:,:,k),wrk_send_2d) + endif + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_tv(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_u(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_u(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_v(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_v(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_rh(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_rh(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + enddo + ! for now, don't do anything with oz, cwmr + g_oz = 0.; g_cwmr = 0. + deallocate(wrk_send_2d) + end subroutine parallel_read_wrf_mass_step2 + + subroutine general_read_wrf_mass2(this,filename,g_ps,g_u,g_v,g_tv,g_rh,g_cwmr,g_oz,& + g_w,g_dbz,g_qs,g_qg,g_qi,g_qr,g_qnc,g_qni,g_qnr,mype) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: general_read_wrf_mass read arw model ensemble members + ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 + ! + ! abstract: read ensemble members from the arw model in "wrfout" netcdf format + ! for use with hybrid ensemble option. + ! + ! program history log: + ! 2010-08-11 parrish, initial documentation + ! 2010-09-10 parrish, modify so ensemble variables are read in the same way + ! as in + ! subroutines convert_netcdf_mass and + ! read_wrf_mass_binary_guess. + ! There were substantial differences due to different opinion + ! about what + ! to use for surface pressure. This issue should be resolved by + ! coordinating + ! with Ming Hu (ming.hu@noaa.gov). At the moment, these changes + ! result in + ! agreement to single precision between this input method and + ! the guess input + ! procedure when the same file is read by both methods. + ! 2012-03-12 whitaker: read data on root, distribute with scatterv. + ! remove call to general_reload. + ! simplify, fix memory leaks, reduce memory + ! footprint. + ! use genqsat, remove genqsat2_regional. + ! replace bare 'stop' statements with call + ! stop2(999). + ! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF + ! MASS core + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + + use netcdf, only: nf90_nowrite + use netcdf, only: nf90_open,nf90_close + use netcdf, only: nf90_inq_dimid,nf90_inquire_dimension + use netcdf, only: nf90_inq_varid,nf90_inquire_variable,nf90_get_var + use kinds, only: r_kind,r_single,i_kind + use gridmod, only: nsig,eta1_ll,pt_ll,aeta1_ll,eta2_ll,aeta2_ll + use constants, only: zero,one,fv,zero_single,rd_over_cp_mass,one_tenth,h300,rd,r1000 + use constants, only: r0_01,r10,r100 + use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens + use mpimod, only: mpi_comm_world,ierror,mpi_rtype + use netcdf_mod, only: nc_check + use wrf_vars_mod, only : w_exist, dbz_exist + use obsmod,only: if_model_dbz + use setupdbz_lib,only: hx_dart + + implicit none + ! + ! Declare passed variables + class(get_wrf_mass_ensperts_class), intent(inout) :: this + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out):: & + g_u,g_v,g_tv,g_rh,g_cwmr,g_oz, & + g_w,g_dbz,g_qs,g_qg,g_qi,g_qr, & + g_qnc,g_qni,g_qnr + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps + character(24),intent(in):: filename + ! + ! Declare local variables + real(r_single),allocatable,dimension(:):: temp_1d + real(r_single),allocatable,dimension(:,:):: temp_2d,temp_2d2 + real(r_single),allocatable,dimension(:,:,:):: temp_3d + real(r_kind),allocatable,dimension(:):: p_top + real(r_kind),allocatable,dimension(:,:):: q_integral,gg_ps,q_integralc4h + real(r_kind),allocatable,dimension(:,:,:):: tsn,qst,prsl,& + gg_u,gg_v,gg_tv,gg_rh + real(r_kind),allocatable,dimension(:,:,:):: gg_w,gg_qr,gg_qi,gg_qg,gg_qs,& + gg_dbz,gg_rho,gg_cwmr,gg_qnc,gg_qni,gg_qnr + real(r_kind),allocatable,dimension(:):: wrk_fill_2d + integer(i_kind),allocatable,dimension(:):: dim,dim_id + + integer(i_kind):: nx,ny,nz,i,j,k,d_max,file_id,var_id,ndim,mype + integer(i_kind):: Time_id,s_n_id,w_e_id,b_t_id,s_n_stag_id,w_e_stag_id,b_t_stag_id + integer(i_kind):: Time_len,s_n_len,w_e_len,b_t_len,s_n_stag_len,w_e_stag_len,b_t_stag_len + integer(i_kind) iderivative + + real(r_kind):: deltasigma + real(r_kind) psfc_this_dry,psfc_this + real(r_kind) work_prslk,work_prsl + + logical ice + + character(len=24),parameter :: myname_ = 'general_read_wrf_mass2' + + + ! + ! OPEN ENSEMBLE MEMBER DATA FILE + if (mype==0) then ! only read data on root proc + allocate(gg_u(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_v(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_tv(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_rh(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_ps(grd_ens%nlat,grd_ens%nlon)) + if( w_exist ) allocate(gg_w(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + if( dbz_exist ) allocate(gg_dbz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qr(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qs(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qi(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qg(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_rho(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_cwmr(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qnc(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qni(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qnr(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + call nc_check( nf90_open(trim(filename),nf90_nowrite,file_id),& + myname_,'open '//trim(filename) ) + ! + ! WRF FILE DIMENSIONS + call nc_check( nf90_inq_dimid(file_id,'Time',Time_id),& + myname_,'inq_dimid Time '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'south_north',s_n_id),& + myname_,'inq_dimid south_north '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'west_east',w_e_id),& + myname_,'inq_dimid west_east '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'bottom_top',b_t_id),& + myname_,'inq_dimid bottom_top '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'south_north_stag',s_n_stag_id),& + myname_,'inq_dimid south_north_stag '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'west_east_stag',w_e_stag_id),& + myname_,'inq_dimid west_east_stag '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'bottom_top_stag',b_t_stag_id),& + myname_,'inq_dimid bottom_top_stag '//trim(filename) ) + + d_max=max(Time_id, s_n_id, w_e_id, b_t_id, s_n_stag_id, w_e_stag_id, b_t_stag_id) + allocate(dim(d_max)) + dim(:)=-999 + + call nc_check( nf90_inquire_dimension(file_id,Time_id,len=Time_len),& + myname_,'inquire_dimension Time '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,s_n_id,len=s_n_len),& + myname_,'inquire_dimension south_north '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,w_e_id,len=w_e_len),& + myname_,'inquire_dimension west_east '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,b_t_id,len=b_t_len),& + myname_,'inquire_dimension bottom_top '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,s_n_stag_id,len=s_n_stag_len),& + myname_,'inquire_dimension south_north_stag '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,w_e_stag_id,len=w_e_stag_len),& + myname_,'inquire_dimension west_east_stag '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,b_t_stag_id,len=b_t_stag_len),& + myname_,'inquire_dimension bottom_top_stag '//trim(filename) ) + + nx=w_e_len + ny=s_n_len + nz=b_t_len + if (nx /= grd_ens%nlon .or. ny /= grd_ens%nlat .or. nz /= grd_ens%nsig) then + print *,'incorrect grid size in netcdf file' + print *,'nx,ny,nz,nlon,nlat,nsig',nx,ny,nz,grd_ens%nlon,grd_ens%nlat,grd_ens%nsig + call stop2(999) + endif + + dim(Time_id)=Time_len + dim(s_n_id)=s_n_len + dim(w_e_id)=w_e_len + dim(b_t_id)=b_t_len + dim(s_n_stag_id)=s_n_stag_len + dim(w_e_stag_id)=w_e_stag_len + dim(b_t_stag_id)=b_t_stag_len + ! + ! READ PERTURBATION POTENTIAL TEMPERATURE (K) + call nc_check( nf90_inq_varid(file_id,'T',var_id),& + myname_,'inq_varid T '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable T '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable T '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var T '//trim(filename) ) + allocate(tsn(dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3)))) + tsn = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + + ! READ MU, MUB, P_TOP (construct psfc as done in gsi--gives different result + ! compared to PSFC) + + call nc_check( nf90_inq_varid(file_id,'P_TOP',var_id),& + myname_,'inq_varid P_TOP '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable P_TOP '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable P_TOP '//trim(filename) ) + allocate(temp_1d(dim(dim_id(1)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_1d),& + myname_,'get_var P_TOP '//trim(filename) ) + allocate(p_top(dim(dim_id(1)))) + do i=1,dim(dim_id(1)) + p_top(i)=temp_1d(i) + enddo + deallocate(dim_id) + + call nc_check( nf90_inq_varid(file_id,'MUB',var_id),& + myname_,'inq_varid MUB '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable MUB '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable MUB '//trim(filename) ) + allocate(temp_2d(dim(dim_id(1)),dim(dim_id(2)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_2d),& + myname_,'get_var MUB '//trim(filename) ) + deallocate(dim_id) + + call nc_check( nf90_inq_varid(file_id,'MU',var_id),& + myname_,'inq_varid MU '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable MU '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable MU '//trim(filename) ) + allocate(temp_2d2(dim(dim_id(1)),dim(dim_id(2)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_2d2),& + myname_,'get_var MU '//trim(filename) ) + + do j=1,dim(dim_id(2)) + do i=1,dim(dim_id(1)) + temp_2d2(i,j)=temp_2d(i,j)+temp_2d2(i,j)+temp_1d(1) + gg_ps(j,i)=temp_2d2(i,j) + enddo + enddo + print *,'min/max ps',minval(gg_ps),maxval(gg_ps) + deallocate(temp_2d,temp_2d2,temp_1d,dim_id) + + ! + ! READ U (m/s) + call nc_check( nf90_inq_varid(file_id,'U',var_id),& + myname_,'inq_varid U '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable U '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable U '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var U '//trim(filename) ) + ! + ! INTERPOLATE TO MASS GRID + do k=1,dim(dim_id(3)) + do j=1,dim(dim_id(2)) + do i=1,dim(dim_id(1))-1 + gg_u(j,i,k)=.5*(temp_3d(i,j,k)+temp_3d(i+1,j,k)) + enddo + enddo + enddo + deallocate(temp_3d) + deallocate(dim_id) + ! + ! READ V (m/s) + call nc_check( nf90_inq_varid(file_id,'V',var_id),& + myname_,'inq_varid V '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable V '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable V '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var V '//trim(filename) ) + ! + ! INTERPOLATE TO MASS GRID + do k=1,dim(dim_id(3)) + do j=1,dim(dim_id(2))-1 + do i=1,dim(dim_id(1)) + gg_v(j,i,k)=.5*(temp_3d(i,j,k)+temp_3d(i,j+1,k)) + enddo + enddo + enddo + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max u',minval(gg_u),maxval(gg_u) + print *,'min/max v',minval(gg_v),maxval(gg_v) + + if( w_exist )then + ! + ! READ W (m/s) + call nc_check( nf90_inq_varid(file_id,'W',var_id),& + myname_,'inq_varid W '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable W '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable W '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var W '//trim(filename) ) + ! + ! INTERPOLATE TO MASS GRID + do k=1,dim(dim_id(3))-1 + do j=1,dim(dim_id(2)) + do i=1,dim(dim_id(1)) + gg_w(j,i,k)=.5*(temp_3d(i,j,k)+temp_3d(i,j,k+1)) + enddo + enddo + enddo + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max w',minval(gg_w),maxval(gg_w) + end if + + ! + ! READ QR (kg/kg) + call nc_check( nf90_inq_varid(file_id,'QRAIN',var_id),& + myname_,'inq_varid QR '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QR '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QR '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QR '//trim(filename) ) + + gg_qr = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max qr',minval(gg_qr),maxval(gg_qr) + + ! + ! READ QS (kg/kg) + call nc_check( nf90_inq_varid(file_id,'QSNOW',var_id),& + myname_,'inq_varid QS '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QS '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QS '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QS '//trim(filename) ) + + gg_qs = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max qs',minval(gg_qs),maxval(gg_qs) + + ! + ! READ QI (kg/kg) + call nc_check( nf90_inq_varid(file_id,'QICE',var_id),& + myname_,'inq_varid QI '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QI '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QI '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QI '//trim(filename) ) + + gg_qi = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max qi',minval(gg_qi),maxval(gg_qi) + + ! + ! READ QG (kg/kg) + call nc_check( nf90_inq_varid(file_id,'QGRAUP',var_id),& + myname_,'inq_varid QG '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QG '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QG '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QG '//trim(filename) ) + + gg_qg = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max qg',minval(gg_qg),maxval(gg_qg) + + ! + ! READ QNC + call nc_check( nf90_inq_varid(file_id,'QNCLOUD',var_id),& + myname_,'inq_varid QNC '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QNC '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QNC '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QNC '//trim(filename) ) + + gg_qnc = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max qnc',minval(gg_qnc),maxval(gg_qnc) + + ! + ! READ QNI + call nc_check( nf90_inq_varid(file_id,'QNICE',var_id),& + myname_,'inq_varid QNI '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QNI '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QNI '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QNI '//trim(filename) ) + + gg_qni = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max qni',minval(gg_qni),maxval(gg_qni) + + ! + ! READ QNR + call nc_check( nf90_inq_varid(file_id,'QNRAIN',var_id),& + myname_,'inq_varid QNR '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QNR '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QNR '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QNR '//trim(filename) ) + + gg_qnr = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max qnr',minval(gg_qnr),maxval(gg_qnr) + + ! + ! READ QC (kg/kg) + call nc_check( nf90_inq_varid(file_id,'QCLOUD',var_id),& + myname_,'inq_varid QC '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QC '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QC '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QC '//trim(filename) ) + + gg_cwmr = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max qc',minval(gg_cwmr),maxval(gg_cwmr) + + if( if_model_dbz .and. dbz_exist ) then + ! + ! READ Reflectivity (dBZ) + call nc_check( nf90_inq_varid(file_id,'REFL_10CM',var_id),& + myname_,'inq_varid dBZ '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable dBZ '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable dBZ '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var dBZ '//trim(filename) ) + + gg_dbz = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + where( gg_dbz < 0.0_r_kind ) + gg_dbz = 0.0_r_kind + end where + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max dBZ',minval(gg_dbz),maxval(gg_dbz) + end if + + ! + ! READ QVAPOR (kg/kg) + call nc_check( nf90_inq_varid(file_id,'QVAPOR',var_id),& + myname_,'inq_varid QVAPOR '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QVAPOR '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QVAPOR '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QVAPOR '//trim(filename) ) + gg_rh = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id,dim) + + call nc_check( nf90_close(file_id),& + myname_,'close '//trim(filename) ) + ! + ! CALCULATE TOTAL POTENTIAL TEMPERATURE (K) + !print *, 'calculate total temperature ',filename + do i=1,nx + do j=1,ny + do k=1,nz + tsn(j,i,k)=tsn(j,i,k)+h300 + enddo + enddo + enddo + ! + ! INTEGRATE {1 + WATER VAPOR} TO CONVERT DRY AIR PRESSURE + allocate(q_integral(ny,nx)) + allocate(q_integralc4h(ny,nx)) + q_integral(:,:)=one + q_integralc4h=0.0_r_single + do i=1,nx + do j=1,ny + do k=1,nz + deltasigma=eta1_ll(k)-eta1_ll(k+1) + q_integral(j,i)=q_integral(j,i)+deltasigma*gg_rh(j,i,k) + q_integralc4h(j,i)=q_integralc4h(j,i)+(eta2_ll(k)-eta2_ll(k+1))*gg_rh(j,i,k) + enddo + enddo + enddo + ! + ! CONVERT WATER VAPOR MIXING RATIO TO SPECIFIC HUMIDITY + do i=1,nx + do j=1,ny + do k=1,nz + gg_rh(j,i,k)=gg_rh(j,i,k)/(one+gg_rh(j,i,k)) + enddo + enddo + enddo + + ! obtaining psfc as done in subroutine read_wrf_mass_netcdf_guess + do i=1,nx + do j=1,ny + psfc_this_dry=r0_01*gg_ps(j,i) + psfc_this=(psfc_this_dry-pt_ll)*q_integral(j,i)+pt_ll+q_integralc4h(j,i) + gg_ps(j,i)=one_tenth*psfc_this ! convert from mb to cb + end do + end do + ! + ! CONVERT POTENTIAL TEMPERATURE TO VIRTUAL TEMPERATURE + allocate(prsl(ny,nx,nz)) + do k=1,nz + do i=1,nx + do j=1,ny + work_prsl = one_tenth*(aeta1_ll(k)*(r10*gg_ps(j,i)-pt_ll)+& + aeta2_ll(k) + pt_ll) + prsl(j,i,k)=work_prsl + work_prslk = (work_prsl/r100)**rd_over_cp_mass + ! sensible temp from pot temp + tsn(j,i,k) = tsn(j,i,k)*work_prslk + ! virtual temp from sensible temp + gg_tv(j,i,k) = tsn(j,i,k) * (one+fv*gg_rh(j,i,k)) + ! recompute sensible temp from virtual temp + tsn(j,i,k)= gg_tv(j,i,k)/(one+fv*max(zero,gg_rh(j,i,k))) + end do + end do + end do + print *,'min/max tv',minval(gg_tv),maxval(gg_tv) + + if( dbz_exist .and. (.not. if_model_dbz) )then + gg_rho = (prsl/(gg_tv*rd))*r1000 + do k=1,nz + do i=1,nx + do j=1,ny + call hx_dart(gg_qr(j,i,k),gg_qg(j,i,k),gg_qs(j,i,k),gg_rho(j,i,k),tsn(j,i,k),gg_dbz(j,i,k),.false.) + enddo + enddo + enddo + end if + + ! + ! CALCULATE PSEUDO RELATIVE HUMIDITY IF USING RH VARIABLE + if (.not.q_hyb_ens) then + allocate(qst(ny,nx,nz)) + ice=.true. + iderivative=0 + call genqsat(qst,tsn,prsl,ny,nx,nsig,ice,iderivative) + do k=1,nz + do i=1,nx + do j=1,ny + gg_rh(j,i,k)=gg_rh(j,i,k)/qst(j,i,k) + enddo + enddo + enddo + print *,'min/max rh',minval(gg_rh),maxval(gg_rh) + deallocate(qst) + else + print *,'min/max q',minval(gg_rh),maxval(gg_rh) + end if + + ! DEALLOCATE REMAINING TEMPORARY STORAGE + deallocate(tsn,prsl,q_integral,p_top) + endif ! done netcdf read on root + + ! transfer data from root to subdomains on each task + ! scatterv used, since full grids exist only on root task. + allocate(wrk_fill_2d(grd_ens%itotsub)) + ! first PS (output from fill_regional_2d is a column vector with a halo) + if(mype==0) call this%fill_regional_2d(gg_ps,wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_ps,grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + ! then TV,U,V,RH + do k=1,grd_ens%nsig + if (mype==0) call this%fill_regional_2d(gg_tv(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_tv(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_u(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_u(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_v(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_v(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_rh(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_rh(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if(w_exist)then + if (mype==0) call this%fill_regional_2d(gg_w(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_w(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + end if + if(dbz_exist)then + if (mype==0) call this%fill_regional_2d(gg_dbz(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_dbz(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + end if + if (mype==0) call this%fill_regional_2d(gg_qr(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_qr(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_qs(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_qs(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_qi(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_qi(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_qg(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_qg(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_cwmr(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_cwmr(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_qnc(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_qnc(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_qni(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_qni(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + if (mype==0) call this%fill_regional_2d(gg_qnr(1,1,k),wrk_fill_2d) + call mpi_scatterv(wrk_fill_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_qnr(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,0,mpi_comm_world,ierror) + enddo + ! for now, don't do anything with oz, cwmr + g_oz = 0.0_r_kind + deallocate(wrk_fill_2d) + if (mype==0) deallocate(gg_u,gg_v,gg_tv,gg_rh,gg_ps,gg_dbz,gg_w,& + gg_qr,gg_qs,gg_qi,gg_qg,gg_cwmr,gg_qnc, & + gg_qni,gg_qnr) + + return + end subroutine general_read_wrf_mass2 + + subroutine fill_regional_2d(fld_in,fld_out) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: fill_regional_2d + ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 + ! + ! abstract: create a column vector for the subdomain (including halo) + ! from global 2d grid. + ! + ! + ! program history log: + ! 2010-08-11 parrish, initial documentation + ! 2012-03-12 whitaker, remove nx,ny,itotsub from argument list. + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + use kinds, only: r_kind,i_kind + use hybrid_ensemble_parameters, only: grd_ens + implicit none + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon)::fld_in + real(r_kind),dimension(grd_ens%itotsub)::fld_out + integer(i_kind):: i,j,k + do k=1,grd_ens%itotsub + i=grd_ens%ltosj_s(k) + j=grd_ens%ltosi_s(k) + fld_out(k)=fld_in(j,i) + enddo + return + end subroutine fill_regional_2d + subroutine ens_spread_dualres_regional_wrf(this,mype,en_perts,nelen,en_bar) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: ens_spread_dualres_regional + ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 + ! + ! abstract: + ! + ! + ! program history log: + ! 2010-08-11 parrish, initial documentation + ! 2011-04-05 parrish - add pseudo-bundle capability + ! 2011-08-31 todling - revisit en_perts (single-prec) in light of extended bundle + ! + ! input argument list: + ! en_bar - ensemble mean + ! mype - current processor number + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + ! + use kinds, only: r_single,r_kind,i_kind + use hybrid_ensemble_parameters, only: n_ens,grd_ens,grd_anl,p_e2a,uv_hyb_ens, & + regional_ensemble_option,write_ens_sprd + use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sube2suba + use constants, only: zero,two,half,one + use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d + use gsi_bundlemod, only: gsi_bundlecreate + use gsi_bundlemod, only: gsi_grid + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_bundlemod, only: gsi_bundledestroy + use gsi_bundlemod, only: gsi_gridcreate + implicit none + + class(get_wrf_mass_ensperts_class), intent(inout) :: this + type(gsi_bundle),OPTIONAL,intent(in):: en_bar + integer(i_kind),intent(in):: mype + type(gsi_bundle),allocatable, intent(in ) :: en_perts(:,:) + integer(i_kind), intent(in ):: nelen + + type(gsi_bundle):: sube,suba + type(gsi_grid):: grid_ens,grid_anl + real(r_kind) sp_norm,sig_norm_sq_inv + type(sub2grid_info)::se,sa + integer(i_kind) k + + integer(i_kind) i,n,ic3 + logical regional + integer(i_kind) num_fields,inner_vars,istat,istatus + logical,allocatable::vector(:) + real(r_kind),pointer,dimension(:,:,:):: st,vp,tv,rh,oz,cw + real(r_kind),pointer,dimension(:,:):: ps + real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig),target::dum3 + real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2),target::dum2 + + associate( this => this ) ! eliminates warning for unused dummy argument needed for binding + end associate + + ! create simple regular grid + call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) + call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) + + ! create two internal bundles, one on analysis grid and one on ensemble grid + + call gsi_bundlecreate (suba,grid_anl,'ensemble work',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)' in ens_spread_dualres_regional: trouble creating bundle_anl bundle' + call stop2(999) + endif + call gsi_bundlecreate (sube,grid_ens,'ensemble work ens',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)' ens_spread_dualres_regional: trouble creating bundle_ens bundle' + call stop2(999) + endif + + sp_norm=(one/float(n_ens)) + + sube%values=zero + ! + + if(regional_ensemble_option == 1)then + print *,'global ensemble' + sig_norm_sq_inv=n_ens-one + + do n=1,n_ens + do i=1,nelen + sube%values(i)=sube%values(i) & + +en_perts(n,1)%valuesr4(i)*en_perts(n,1)%valuesr4(i) + end do + end do + + do i=1,nelen + sube%values(i) = sqrt(sp_norm*sig_norm_sq_inv*sube%values(i)) + end do + else + do n=1,n_ens + do i=1,nelen + sube%values(i)=sube%values(i) & + +(en_perts(n,1)%valuesr4(i)-en_bar%values(i))*(en_perts(n,1)%valuesr4(i)-en_bar%values(i)) + end do + end do + + do i=1,nelen + sube%values(i) = sqrt(sp_norm*sube%values(i)) + end do + end if + + if(grd_ens%latlon1n == grd_anl%latlon1n) then + do i=1,nelen + suba%values(i)=sube%values(i) + end do + else + inner_vars=1 + num_fields=max(0,nc3d)*grd_ens%nsig+max(0,nc2d) + allocate(vector(num_fields)) + vector=.false. + do ic3=1,nc3d + if(trim(cvars3d(ic3))=='sf'.or.trim(cvars3d(ic3))=='vp') then + do k=1,grd_ens%nsig + vector((ic3-1)*grd_ens%nsig+k)=uv_hyb_ens + end do + end if + end do + call general_sub2grid_create_info(se,inner_vars,grd_ens%nlat,grd_ens%nlon,grd_ens%nsig,num_fields, & + regional,vector) + call general_sub2grid_create_info(sa,inner_vars,grd_anl%nlat,grd_anl%nlon,grd_anl%nsig,num_fields, & + regional,vector) + deallocate(vector) + call general_sube2suba(se,sa,p_e2a,sube%values,suba%values,regional) + end if + + dum2=zero + dum3=zero + call gsi_bundlegetpointer(suba,'sf',st,istat) + if(istat/=0) then + write(6,*)' no sf pointer in ens_spread_dualres, point st at dum3 array' + st => dum3 + end if + call gsi_bundlegetpointer(suba,'vp',vp,istat) + if(istat/=0) then + write(6,*)' no vp pointer in ens_spread_dualres, point vp at dum3 array' + vp => dum3 + end if + call gsi_bundlegetpointer(suba,'t',tv,istat) + if(istat/=0) then + write(6,*)' no t pointer in ens_spread_dualres, point tv at dum3 array' + tv => dum3 + end if + call gsi_bundlegetpointer(suba,'q',rh,istat) + if(istat/=0) then + write(6,*)' no q pointer in ens_spread_dualres, point rh at dum3 array' + rh => dum3 + end if + call gsi_bundlegetpointer(suba,'oz',oz,istat) + if(istat/=0) then + write(6,*)' no oz pointer in ens_spread_dualres, point oz at dum3 array' + oz => dum3 + end if + call gsi_bundlegetpointer(suba,'cw',cw,istat) + if(istat/=0) then + write(6,*)' no cw pointer in ens_spread_dualres, point cw at dum3 array' + cw => dum3 + end if + call gsi_bundlegetpointer(suba,'ps',ps,istat) + if(istat/=0) then + write(6,*)' no ps pointer in ens_spread_dualres, point ps at dum2 array' + ps => dum2 + end if + + if(write_ens_sprd) call write_spread_dualres(st,vp,tv,rh,oz,cw,ps,mype) + + return + end subroutine ens_spread_dualres_regional_wrf +end module get_wrf_mass_ensperts_mod diff --git a/src/cplr_get_wrf_nmm_ensperts.f90 b/src/gsi/cplr_get_wrf_nmm_ensperts.f90 similarity index 100% rename from src/cplr_get_wrf_nmm_ensperts.f90 rename to src/gsi/cplr_get_wrf_nmm_ensperts.f90 diff --git a/src/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 similarity index 79% rename from src/cplr_gfs_ensmod.f90 rename to src/gsi/cplr_gfs_ensmod.f90 index e869470fe..dbf7211e2 100644 --- a/src/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -1,24 +1,64 @@ module get_gfs_ensmod_mod +!$$$ subprogram documentation block +! . . . . +! subprogram: get_gfs_ensmod_mod handles gfs ensemble +! prgmmr: mahajan org: emc/ncep date: 2016-06-30 +! +! abstract: Handle GFS ensemble (full fields and perturbations) +! +! program history log: +! 2016-06-30 mahajan - initial code +! 2019-07-09 todling - revised abstract layer +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ use mpeu_util, only: die use mpimod, only: mype,npe - use abstract_get_gfs_ensmod_mod + use abstract_ensmod, only: this_ens_class => abstractEnsemble implicit none - - type, extends(abstract_get_gfs_ensmod_class) :: get_gfs_ensmod_class - contains - procedure, pass(this) :: non_gaussian_ens_grid_ => non_gaussian_ens_grid_gfs - procedure, pass(this) :: get_user_ens_ => get_user_ens_gfs - procedure, pass(this) :: put_gsi_ens_ => put_gsi_ens_gfs - end type get_gfs_ensmod_class + private + public :: ensemble + public :: ensemble_typemold + + type, extends(this_ens_class) :: ensemble + private + contains + procedure :: get_user_ens => get_gfs_ens + procedure :: get_user_Nens => get_gfs_Nens + procedure :: put_user_ens => put_gfs_ens + procedure :: non_gaussian_ens_grid => non_gaussian_ens_grid_gfs + procedure, nopass:: mytype => typename + procedure, nopass:: create_sub2grid_info + procedure, nopass:: destroy_sub2grid_info + end type ensemble + + character(len=*),parameter:: myname="gfs_ensmod" + + type(ensemble),target:: mold_ contains -subroutine get_user_ens_gfs(this,grd,ntindex,atm_bundle,iret) +function ensemble_typemold() + implicit none + type(ensemble),pointer:: ensemble_typemold + ensemble_typemold => mold_ +end function ensemble_typemold + +function typename() + implicit none + character(len=:),allocatable:: typename + typename='['//myname//'::ensemble]' +end function typename + +subroutine get_gfs_Nens(this,grd,members,ntindex,atm_bundle,iret) !$$$ subprogram documentation block ! . . . . -! subprogram: get_user_ens_ pretend atmos bkg is the ensemble +! subprogram: get_gfs_Nens pretend atmos bkg is the ensemble ! prgmmr: mahajan org: emc/ncep date: 2016-06-30 ! ! abstract: Read in GFS ensemble members in to GSI ensemble. @@ -26,10 +66,11 @@ subroutine get_user_ens_gfs(this,grd,ntindex,atm_bundle,iret) ! program history log: ! 2016-06-30 mahajan - initial code ! 2016-07-20 mpotts - refactored into class/module +! 2019-07-09 todling - revised in light of truly abstract layer ! ! input argument list: ! grd - grd info for ensemble -! member - index for ensemble member +! members - number of ensemble members (size of bundle) ! ntindex - time index for ensemble ! ! output argument list: @@ -45,7 +86,7 @@ subroutine get_user_ens_gfs(this,grd,ntindex,atm_bundle,iret) use kinds, only: i_kind,r_kind,r_single use gridmod, only: use_gfs_nemsio use general_sub2grid_mod, only: sub2grid_info - use hybrid_ensemble_parameters, only: n_ens,ens_fast_read + use hybrid_ensemble_parameters, only: ens_fast_read use hybrid_ensemble_parameters, only: grd_ens use gsi_bundlemod, only: gsi_bundle use control_vectors, only: nc2d,nc3d @@ -53,8 +94,9 @@ subroutine get_user_ens_gfs(this,grd,ntindex,atm_bundle,iret) implicit none ! Declare passed variables - class(get_gfs_ensmod_class), intent(inout) :: this + class(ensemble), intent(inout) :: this type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(in ) :: members integer(i_kind), intent(in ) :: ntindex type(gsi_bundle), intent(inout) :: atm_bundle(:) integer(i_kind), intent( out) :: iret @@ -71,25 +113,25 @@ subroutine get_user_ens_gfs(this,grd,ntindex,atm_bundle,iret) end associate if ( use_gfs_nemsio .and. ens_fast_read ) then - allocate(en_loc3(grd_ens%lat2,grd_ens%lon2,nc2d+nc3d*grd_ens%nsig,n_ens)) + allocate(en_loc3(grd_ens%lat2,grd_ens%lon2,nc2d+nc3d*grd_ens%nsig,members)) allocate(clons(grd_ens%nlon),slons(grd_ens%nlon)) call get_user_ens_gfs_fastread_(ntindex,en_loc3,m_cvars2d,m_cvars3d, & grd_ens%lat2,grd_ens%lon2,grd_ens%nsig, & - nc2d,nc3d,n_ens,iret,clons,slons) - do n=1,n_ens + nc2d,nc3d,members,iret,clons,slons) + do n=1,members call move2bundle_(grd,en_loc3(:,:,:,n),atm_bundle(n), & m_cvars2d,m_cvars3d,iret,clons,slons) end do deallocate(en_loc3,clons,slons) else - do n = 1,n_ens - call get_user_ens_gfs_member_(grd,n,ntindex,atm_bundle(n),iret) + do n = 1,members + call get_gfs_ens(this,grd,n,ntindex,atm_bundle(n),iret) end do endif return -end subroutine get_user_ens_gfs +end subroutine get_gfs_Nens subroutine get_user_ens_gfs_fastread_(ntindex,en_loc3,m_cvars2d,m_cvars3d, & lat2in,lon2in,nsigin,nc2din,nc3din,n_ensin,iret,clons,slons) @@ -292,6 +334,7 @@ subroutine move2bundle_(grd,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret,clons,sl ! program history log: ! 2016-06-30 parrish -- copy and adapt get_user_ens_member_ to transfer 1 ! ensemble member +! 2019-03-13 eliu -- add precipitation components ! ! input argument list: ! grd - grd info for ensemble @@ -317,6 +360,7 @@ subroutine move2bundle_(grd,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret,clons,sl use gsi_bundlemod, only: gsi_bundlegetpointer,gsi_bundleputvar use gsi_bundlemod, only : assignment(=) use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d + use mpeu_util, only: getindex implicit none @@ -334,9 +378,11 @@ subroutine move2bundle_(grd,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret,clons,sl integer(i_kind) :: ierr integer(i_kind) :: im,jm,km,m,k + integer(i_kind) :: icw,iql,iqi,iqr,iqs,iqg real(r_kind),pointer,dimension(:,:) :: ps !real(r_kind),pointer,dimension(:,:) :: sst real(r_kind),pointer,dimension(:,:,:) :: u,v,tv,q,oz,cwmr + real(r_kind),pointer,dimension(:,:,:) :: qlmr,qimr,qrmr,qsmr,qgmr real(r_single),allocatable,dimension(:,:) :: scr2 real(r_single),allocatable,dimension(:,:,:) :: scr3 type(sub2grid_info) :: grd2d,grd3d @@ -349,6 +395,14 @@ subroutine move2bundle_(grd,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret,clons,sl allocate(scr2(im,jm)) allocate(scr3(im,jm,km)) + ! Check hydrometeors in control variables + icw=getindex(cvars3d,'cw') + iql=getindex(cvars3d,'ql') + iqi=getindex(cvars3d,'qi') + iqr=getindex(cvars3d,'qr') + iqs=getindex(cvars3d,'qs') + iqg=getindex(cvars3d,'qg') + ! initialize atm_bundle to zero atm_bundle=zero @@ -360,14 +414,21 @@ subroutine move2bundle_(grd,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret,clons,sl call gsi_bundlegetpointer(atm_bundle,'t' ,tv, ierr); iret = ierr + iret call gsi_bundlegetpointer(atm_bundle,'q' ,q , ierr); iret = ierr + iret call gsi_bundlegetpointer(atm_bundle,'oz',oz, ierr); iret = ierr + iret - call gsi_bundlegetpointer(atm_bundle,'cw',cwmr,ierr); iret = ierr + iret + if (icw>0) call gsi_bundlegetpointer(atm_bundle,'cw',cwmr,ierr); iret = ierr + iret + if (iql>0) call gsi_bundlegetpointer(atm_bundle,'ql',qlmr,ierr); iret = ierr + iret + if (iqi>0) call gsi_bundlegetpointer(atm_bundle,'qi',qimr,ierr); iret = ierr + iret + if (iqr>0) call gsi_bundlegetpointer(atm_bundle,'qr',qrmr,ierr); iret = ierr + iret + if (iqs>0) call gsi_bundlegetpointer(atm_bundle,'qs',qsmr,ierr); iret = ierr + iret + if (iqg>0) call gsi_bundlegetpointer(atm_bundle,'qg',qgmr,ierr); iret = ierr + iret if ( iret /= 0 ) then if ( mype == 0 ) then write(6,'(A)') trim(myname_) // ': ERROR!' write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz,cw' write(6,'(A)') trim(myname_) // ': but some have not been found. Aborting ... ' + write(6,'(A)') trim(myname_) // ': WARNING!' + write(6,'(3A,I5)') trim(myname_) // ': Trouble reading ensemble file : ', trim(filename), ', IRET = ', iret endif - goto 100 + return endif do m=1,nc2d @@ -385,6 +446,11 @@ subroutine move2bundle_(grd,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret,clons,sl if(trim(cvars3d(m))=='q') q = scr3 if(trim(cvars3d(m))=='oz') oz = scr3 if(trim(cvars3d(m))=='cw') cwmr = scr3 + if(trim(cvars3d(m))=='ql') qlmr = scr3 + if(trim(cvars3d(m))=='qi') qimr = scr3 + if(trim(cvars3d(m))=='qr') qrmr = scr3 + if(trim(cvars3d(m))=='qs') qsmr = scr3 + if(trim(cvars3d(m))=='qg') qgmr = scr3 enddo ! convert ps from Pa to cb @@ -403,7 +469,12 @@ subroutine move2bundle_(grd,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret,clons,sl call update_scalar_poles_(grd3d,tv) call update_scalar_poles_(grd3d,q) call update_scalar_poles_(grd3d,oz) - call update_scalar_poles_(grd3d,cwmr) + if (icw>0) call update_scalar_poles_(grd3d,cwmr) + if (iql>0) call update_scalar_poles_(grd3d,qlmr) + if (iqi>0) call update_scalar_poles_(grd3d,qimr) + if (iqr>0) call update_scalar_poles_(grd3d,qrmr) + if (iqs>0) call update_scalar_poles_(grd3d,qsmr) + if (iqg>0) call update_scalar_poles_(grd3d,qgmr) call gsi_bundleputvar(atm_bundle,'ps',ps, ierr); iret = ierr !call gsi_bundleputvar(atm_bundle,'sst',sst,ierr); iret = ierr + iret ! no sst for now @@ -412,15 +483,21 @@ subroutine move2bundle_(grd,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret,clons,sl call gsi_bundleputvar(atm_bundle,'t' ,tv, ierr); iret = ierr + iret call gsi_bundleputvar(atm_bundle,'q' ,q , ierr); iret = ierr + iret call gsi_bundleputvar(atm_bundle,'oz',oz, ierr); iret = ierr + iret - call gsi_bundleputvar(atm_bundle,'cw',cwmr,ierr); iret = ierr + iret - + if (icw>0) call gsi_bundleputvar(atm_bundle,'cw',cwmr,ierr); iret = ierr + iret + if (iql>0) call gsi_bundleputvar(atm_bundle,'ql',qlmr,ierr); iret = ierr + iret + if (iqi>0) call gsi_bundleputvar(atm_bundle,'qi',qimr,ierr); iret = ierr + iret + if (iqr>0) call gsi_bundleputvar(atm_bundle,'qr',qrmr,ierr); iret = ierr + iret + if (iqs>0) call gsi_bundleputvar(atm_bundle,'qs',qsmr,ierr); iret = ierr + iret + if (iqg>0) call gsi_bundleputvar(atm_bundle,'qg',qgmr,ierr); iret = ierr + iret if ( iret /= 0 ) then if ( mype == 0 ) then write(6,'(A)') trim(myname_) // ': ERROR!' write(6,'(A)') trim(myname_) // ': For now, GFS needs to put all MetFields: ps,u,v,(sf,vp)tv,q,oz,cw' write(6,'(A)') trim(myname_) // ': but some have not been found. Aborting ... ' + write(6,'(A)') trim(myname_) // ': WARNING!' + write(6,'(3A,I5)') trim(myname_) // ': Trouble reading ensemble file : ', trim(filename), ', IRET = ', iret endif - goto 100 + return endif call general_sub2grid_destroy_info(grd2d,grd) @@ -429,15 +506,6 @@ subroutine move2bundle_(grd,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret,clons,sl if ( allocated(scr2) ) deallocate(scr2) if ( allocated(scr3) ) deallocate(scr3) -100 continue - - if ( iret /= 0 ) then - if ( mype == 0 ) then - write(6,'(A)') trim(myname_) // ': WARNING!' - write(6,'(3A,I5)') trim(myname_) // ': Trouble reading ensemble file : ', trim(filename), ', IRET = ', iret - endif - endif - return end subroutine move2bundle_ @@ -669,7 +737,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi use kinds, only: i_kind,r_kind,r_single use constants, only: r60,r3600,zero,one,half,pi,deg2rad use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close - use ncepnems_io, only: error_msg + use ncepnems_io, only: error_msg,imp_physics use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv use nemsio_module, only: nemsio_getrechead use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d @@ -692,14 +760,16 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi ! Declare local variables integer(i_kind) i,ii,j,jj,k,lonb,latb,levs integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf - integer(i_kind) iret,istop + integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg + integer(i_kind) iret + integer(i_kind) :: istop = 101 integer(i_kind),dimension(7):: idate integer(i_kind),dimension(4):: odate integer(i_kind) nframe,nfhour,nfminute,nfsecondn,nfsecondd integer(i_kind) nrec character(len=120) :: myname_ = 'parallel_read_nemsio_state_' character(len=1) :: null = ' ' - real(r_single),allocatable,dimension(:) :: work + real(r_single),allocatable,dimension(:) :: work,work2 ! NOTE: inportant to keep 8 byte precision for work array, even though what is ! on ensemble NEMS file is 4 byte precision. The NEMSIO automatically (through ! interfaces presumably) must be able to read 4 byte and 8 byte records and pass @@ -714,10 +784,10 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi real(r_single),allocatable,dimension(:) ::r4lats,r4lons if ( init_head)call nemsio_init(iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),null,'init',istop,iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),null,'init',istop,iret,.true.) call nemsio_open(gfile,filename,'READ',iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),null,'open',istop+1,iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),null,'open',istop+1,iret,.true.) call nemsio_getfilehead(gfile,iret=iret, nframe=nframe, & nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & @@ -761,9 +831,11 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi odate(4) = idate(1) !year allocate(work(nlon*(nlat-2))) + if (imp_physics == 11) allocate(work2(nlon*(nlat-2))) allocate(temp3(nlat,nlon,nsig,nc3d)) allocate(temp2(nlat,nlon,nc2d)) k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0 + k3ql=0; k3qi=0; k3qr=0; k3qs=0; k3qg=0 do k3=1,nc3d if(cvars3d(k3)=='sf') k3u=k3 if(cvars3d(k3)=='vp') k3v=k3 @@ -771,35 +843,69 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi if(cvars3d(k3)=='q') k3q=k3 if(cvars3d(k3)=='cw') k3cw=k3 if(cvars3d(k3)=='oz') k3oz=k3 + if(cvars3d(k3)=='ql') k3ql=k3 + if(cvars3d(k3)=='qi') k3qi=k3 + if(cvars3d(k3)=='qr') k3qr=k3 + if(cvars3d(k3)=='qs') k3qs=k3 + if(cvars3d(k3)=='qg') k3qg=k3 do k=1,nsig if(trim(cvars3d(k3))=='cw') then call nemsio_readrecv(gfile,'clwmr','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'clwmr','read',istop+6,iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'clwmr','read',istop+6,iret,.true.) + if (imp_physics == 11) then + call nemsio_readrecv(gfile,'icmr','mid layer',k,work2,iret=iret) + if (iret /= 0) then + call error_msg(trim(myname_),trim(filename),'icmr','read',istop+7,iret,.true.) + else + work = work + work2 + endif + endif + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='ql') then + call nemsio_readrecv(gfile,'clwmr','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'clwmr','read',istop+8,iret) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='qi') then + call nemsio_readrecv(gfile,'icmr','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'icmr','read',istop+9,iret) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='qr') then + call nemsio_readrecv(gfile,'rwmr','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'rwmr','read',istop+10,iret) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='qs') then + call nemsio_readrecv(gfile,'snmr','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'snmr','read',istop+11,iret) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='qg') then + call nemsio_readrecv(gfile,'grle','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'grle','read',istop+12,iret) call move1_(work,temp3(:,:,k,k3),nlon,nlat) elseif(trim(cvars3d(k3))=='oz') then call nemsio_readrecv(gfile,'o3mr','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret,.true.) call move1_(work,temp3(:,:,k,k3),nlon,nlat) elseif(trim(cvars3d(k3))=='q') then call nemsio_readrecv(gfile,'spfh','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret,.true.) call move1_(work,temp3(:,:,k,k3),nlon,nlat) elseif(trim(cvars3d(k3))=='t') then call nemsio_readrecv(gfile,'tmp','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret,.true.) call move1_(work,temp3(:,:,k,k3),nlon,nlat) elseif(trim(cvars3d(k3))=='sf') then call nemsio_readrecv(gfile,'ugrd','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret,.true.) call move1_(work,temp3(:,:,k,k3),nlon,nlat) elseif(trim(cvars3d(k3))=='vp') then call nemsio_readrecv(gfile,'vgrd','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret,.true.) call move1_(work,temp3(:,:,k,k3),nlon,nlat) endif enddo enddo - if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3cw==0.or.k3oz==0) & +! if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3cw==0.or.k3oz==0) & + if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3oz==0) & write(6,'(" WARNING, problem with one of k3-")') ! convert T to Tv: postpone this calculation @@ -809,17 +915,18 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi do k2=1,nc2d !if(trim(cvars2d(k2))=='sst') then ! call nemsio_readrecv(gfile,'hgt','sfc',1,work,iret=iret) - ! if (iret /= 0) call error_msg(trim(myname_),trim(filename),'pres','read',istop+7,iret) + ! if (iret /= 0) call error_msg(trim(myname_),trim(filename),'pres','read',istop+7,iret,.true.) ! call move1_(work,temp2(:,:,k2),nlon,nlat) !elseif(trim(cvars2d(k2))=='ps') then if(trim(cvars2d(k2))=='ps') then call nemsio_readrecv(gfile,'pres','sfc',1,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'hgt','read',istop+8,iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'hgt','read',istop+8,iret,.true.) !work=r0_001*work ! convert Pa to cb ! postpone this calculation call move1_(work,temp2(:,:,k2),nlon,nlat) endif enddo deallocate(work) + if (imp_physics == 11) deallocate(work2) ! move temp2,temp3 to en_full kf=0 @@ -1025,16 +1132,17 @@ subroutine move1_(work,temp,nlon,nlat) end subroutine move1_ -subroutine get_user_ens_gfs_member_(grd,member,ntindex,atm_bundle,iret) + subroutine get_gfs_ens(this,grd,member,ntindex,atm_bundle,iret) !$$$ subprogram documentation block ! . . . . -! subprogram: get_user_ens_member_ +! subprogram: get_gfs_ens ! prgmmr: mahajan org: emc/ncep date: 2016-06-30 ! ! abstract: Read in GFS ensemble members in to GSI ensemble. ! ! program history log: ! 2016-06-30 mahajan - initial code +! 2019-03-13 eliu - add precipitation component ! ! input argument list: ! grd - grd info for ensemble @@ -1059,10 +1167,12 @@ subroutine get_user_ens_gfs_member_(grd,member,ntindex,atm_bundle,iret) use hybrid_ensemble_parameters, only: uv_hyb_ens use hybrid_ensemble_parameters, only: sp_ens use gsi_bundlemod, only: gsi_bundle + use gridmod, only: fv3_full_hydro implicit none ! Declare passed variables + class(ensemble), intent(inout) :: this type(sub2grid_info), intent(in ) :: grd integer(i_kind), intent(in ) :: member integer(i_kind), intent(in ) :: ntindex @@ -1075,6 +1185,9 @@ subroutine get_user_ens_gfs_member_(grd,member,ntindex,atm_bundle,iret) logical :: zflag = .false. logical,save :: inithead = .true. + associate( this => this ) ! eliminates warning for unused dummy argument needed for binding + end associate + ! if member == 0, read ensemble mean if ( member == 0 ) then write(filename,12) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex) @@ -1085,8 +1198,17 @@ subroutine get_user_ens_gfs_member_(grd,member,ntindex,atm_bundle,iret) 22 format(a,'sigf',i2.2,'_ens_mem',i3.3) if ( use_gfs_nemsio ) then - call general_read_gfsatm_nems(grd,sp_ens,filename,uv_hyb_ens,.false., & - zflag,atm_bundle,.true.,iret) + if (fv3_full_hydro) then + + call general_read_fv3atm_nems(grd,sp_ens,filename,uv_hyb_ens,.false., & + zflag,atm_bundle,.true.,iret) + + else + + call general_read_gfsatm_nems(grd,sp_ens,filename,uv_hyb_ens,.false., & + zflag,atm_bundle,.true.,iret) + + endif else call general_read_gfsatm(grd,sp_ens,sp_ens,filename,uv_hyb_ens,.false., & zflag,atm_bundle,inithead,iret) @@ -1103,12 +1225,12 @@ subroutine get_user_ens_gfs_member_(grd,member,ntindex,atm_bundle,iret) return -end subroutine get_user_ens_gfs_member_ +end subroutine get_gfs_ens -subroutine put_gsi_ens_gfs(this,grd,member,ntindex,atm_bundle,iret) +subroutine put_gfs_ens(this,grd,member,ntindex,pert,iret) !$$$ subprogram documentation block ! . . . . -! subprogram: put_gsi_ens_ write out an internally gen ens to file +! subprogram: put_gfs_ens write out an internally gen ens to file ! prgmmr: mahajan org: emc/ncep date: 2016-06-30 ! ! abstract: Write out GSI ensemble to file. @@ -1121,7 +1243,7 @@ subroutine put_gsi_ens_gfs(this,grd,member,ntindex,atm_bundle,iret) ! grd - grd info for ensemble ! member - index for ensemble member ! ntindex - time index for ensemble -! atm_bundle - bundle of ensemble perturbations +! pert - bundle of ensemble perturbations ! ! output argument list: ! iret - return code, 0 for successful write @@ -1143,15 +1265,15 @@ subroutine put_gsi_ens_gfs(this,grd,member,ntindex,atm_bundle,iret) implicit none ! Declare passed variables - class(get_gfs_ensmod_class), intent(inout) :: this + class(ensemble), intent(inout) :: this type(sub2grid_info), intent(in ) :: grd integer(i_kind), intent(in ) :: member integer(i_kind), intent(in ) :: ntindex - type(gsi_bundle), intent(inout) :: atm_bundle + type(gsi_bundle), intent(inout) :: pert integer(i_kind), intent( out) :: iret ! Declare internal variables - character(len=*),parameter :: myname_='put_gsi_ens_gfs' + character(len=*),parameter :: myname_='put_gfs_ens' character(len=70) :: filename integer(i_kind) :: mype_atm logical,save :: inithead = .true. @@ -1171,7 +1293,7 @@ subroutine put_gsi_ens_gfs(this,grd,member,ntindex,atm_bundle,iret) !call write_nemsatm(grd,...) else call general_write_gfsatm(grd,sp_ens,sp_ens,filename,mype_atm, & - atm_bundle,ntindex,inithead,iret) + pert,ntindex,inithead,iret) endif inithead = .false. @@ -1185,7 +1307,7 @@ subroutine put_gsi_ens_gfs(this,grd,member,ntindex,atm_bundle,iret) return -end subroutine put_gsi_ens_gfs +end subroutine put_gfs_ens subroutine non_gaussian_ens_grid_gfs(this,elats,elons) @@ -1195,16 +1317,61 @@ subroutine non_gaussian_ens_grid_gfs(this,elats,elons) implicit none ! Declare passed variables - class(get_gfs_ensmod_class), intent(inout) :: this - real(r_kind), intent(out) :: elats(size(sp_ens%rlats)),elons(size(sp_ens%rlons)) + class(ensemble), intent(inout) :: this + real(r_kind), intent(out) :: elats(:),elons(:) + + character(len=*),parameter :: myname_=myname//'non_gaussian_ens_grid' associate( this => this ) ! eliminates warning for unused dummy argument needed for binding end associate - elats=sp_ens%rlats - elons=sp_ens%rlons - return + if (size(elats)/=size(sp_ens%rlats).or.size(elons)/=size(sp_ens%rlons)) then + if(mype==0) then + write(6,*) myname_,': inconsistent ens nlat/nlon' + write(6,*) myname_,': actual(vec) ', size(elats),size(elons) + write(6,*) myname_,': defined(vec) ', size(sp_ens%rlats),size(sp_ens%rlons) + endif + call stop2(999) + endif + + elats=sp_ens%rlats + elons=sp_ens%rlons + + return end subroutine non_gaussian_ens_grid_gfs +subroutine create_sub2grid_info(s2gi,nsig,npe,s2gi_ref) +!> Create temporary communication information object for read ensemble routines + use kinds, only: i_kind + use gridmod, only: regional + use general_sub2grid_mod, only: sub2grid_info + use general_sub2grid_mod, only: general_sub2grid_create_info + implicit none + + ! Declare passed variables + type(sub2grid_info), intent(out ) :: s2gi + integer(i_kind), intent(in ) :: nsig + integer(i_kind), intent(in ) :: npe + type(sub2grid_info), intent(in ) :: s2gi_ref + + call general_sub2grid_create_info(s2gi, inner_vars=1, & + nlat=s2gi_ref%nlat,nlon=s2gi_ref%nlon,nsig=nsig, & + num_fields=min(6*nsig+1,npe),regional=regional) +return +end subroutine create_sub2grid_info + +subroutine destroy_sub2grid_info(s2gi) +!> Destroy the object + use general_sub2grid_mod, only: sub2grid_info + use general_sub2grid_mod, only: general_sub2grid_destroy_info + implicit none + + ! Declare passed variables + type(sub2grid_info), intent(inout) :: s2gi + + call general_sub2grid_destroy_info(s2gi) +return +end subroutine destroy_sub2grid_info + end module get_gfs_ensmod_mod diff --git a/src/cplr_gfs_nstmod.f90 b/src/gsi/cplr_gfs_nstmod.f90 similarity index 98% rename from src/cplr_gfs_nstmod.f90 rename to src/gsi/cplr_gfs_nstmod.f90 index 1dd078b3c..1f08aa033 100644 --- a/src/cplr_gfs_nstmod.f90 +++ b/src/gsi/cplr_gfs_nstmod.f90 @@ -118,7 +118,7 @@ subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr) !$$$ use kinds, only: r_kind,i_kind use constants, only: zero,one,z_w_max - use gridmod, only: nlat,nlon,regional,tll2xy,nlat_sfc,nlon_sfc,rlats_sfc,rlons_sfc + use gridmod, only: regional,tll2xy,nlat_sfc,nlon_sfc,rlats_sfc,rlons_sfc use guess_grids, only: nfldnst,hrdifnst use gsi_nstcouplermod, only: fac_dtl,fac_tsl use gsi_nstcouplermod, only: tref_full,dt_cool_full,z_c_full,dt_warm_full,z_w_full,& @@ -374,10 +374,10 @@ subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr) endif endif - if ( tztr <= one .and. tztr > half ) then - tztr = tztr - else -! write(*,'(a,2I2,3F12.6,F9.3,5F12.6,F8.3,F9.6,F8.3)') ' cal_tztr : ',fac_dtl,fac_tsl,c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr + if ( tztr <= -1.0_r_kind .or. tztr > 4.0_r_kind ) then + write(6,100) fac_dtl,fac_tsl,c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr +100 format('CAL_TZTR compute ',2(i2,1x),12(g13.6,1x),' RESET tztr to 1.0') + tztr = one endif end subroutine cal_tztr_ diff --git a/src/cplr_read_wrf_mass_files.f90 b/src/gsi/cplr_read_wrf_mass_files.f90 similarity index 95% rename from src/cplr_read_wrf_mass_files.f90 rename to src/gsi/cplr_read_wrf_mass_files.f90 index ebca9b025..1627d185b 100644 --- a/src/cplr_read_wrf_mass_files.f90 +++ b/src/gsi/cplr_read_wrf_mass_files.f90 @@ -44,6 +44,7 @@ subroutine read_wrf_mass_files_wrf(this,mype) use guess_grids, only: nfldsig,nfldsfc,ntguessig,ntguessfc,& ifilesig,ifilesfc,hrdifsig,hrdifsfc,create_gesfinfo use guess_grids, only: hrdifsig_all,hrdifsfc_all + use gridmod, only: regional_fhr use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,nhr_assimilation use constants, only: zero,one,zero_single,r60inv use obsmod, only: iadate,time_offset @@ -102,22 +103,22 @@ subroutine read_wrf_mass_files_wrf(this,mype) open(in_unit,file=filename,form='unformatted') read(in_unit) idate5 close(in_unit) - hourg = zero + hourg4= regional_fhr + hourg = hourg4 call w3fs21(idate5,nmings) nming2=nmings+60*hourg write(6,*)'READ_wrf_mass_FILES: sigma guess file, nming2 ',hourg,idate5,nming2 t4dv=real((nming2-iwinbgn),r_kind)*r60inv if (l4dvar.or.l4densvar) then - if (t4dvwinlen) go to 110 + if (t4dvwinlen) cycle else ndiff=nming2-nminanl - if(abs(ndiff) > 60*nhr_half ) go to 110 + if(abs(ndiff) > 60*nhr_half ) cycle endif iwan=iwan+1 time_ges(iwan,1) = real((nming2-iwinbgn),r_kind)*r60inv time_ges(iwan+100,1)=i+r0_001 end if - 110 continue end do time_ges(201,1)=one time_ges(202,1)=one @@ -162,12 +163,12 @@ subroutine read_wrf_mass_files_wrf(this,mype) nming2=nmings+60*hourg write(6,*)'READ_wrf_mass_FILES: surface guess file, nming2 ',hourg,idateg,nming2 ndiff=nming2-nminanl - if(abs(ndiff) > 60*nhr_half ) go to 210 - iwan=iwan+1 - time_ges(iwan,2) = real((nming2-iwinbgn),r_kind)*r60inv - time_ges(iwan+100,2)=i+r0_001 + if(abs(ndiff) <= 60*nhr_half ) then + iwan=iwan+1 + time_ges(iwan,2) = real((nming2-iwinbgn),r_kind)*r60inv + time_ges(iwan+100,2)=i+r0_001 + end if end if - 210 continue if(iwan==1) exit end do time_ges(201,2)=one diff --git a/src/cplr_read_wrf_mass_guess.f90 b/src/gsi/cplr_read_wrf_mass_guess.f90 similarity index 96% rename from src/cplr_read_wrf_mass_guess.f90 rename to src/gsi/cplr_read_wrf_mass_guess.f90 index 7342aa414..2c2a69ead 100644 --- a/src/cplr_read_wrf_mass_guess.f90 +++ b/src/gsi/cplr_read_wrf_mass_guess.f90 @@ -106,7 +106,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) use constants, only: zero,one,grav,fv,zero_single,rd_over_cp_mass,one_tenth,h300,r10,r100 use constants, only: r0_01 use gsi_io, only: lendian_in,verbose - use rapidrefresh_cldsurf_mod, only: l_cloud_analysis,l_gsd_soilTQ_nudge,i_use_2mq4b,i_use_2mt4b + use rapidrefresh_cldsurf_mod, only: l_hydrometeor_bkio,l_gsd_soilTQ_nudge,i_use_2mq4b,i_use_2mt4b use wrf_mass_guess_mod, only: soil_temp_cld,isli_cld,ges_xlon,ges_xlat,ges_tten,create_cld_grids use gsi_bundlemod, only: GSI_BundleGetPointer use gsi_metguess_mod, only: gsi_metguess_get,GSI_MetGuess_Bundle @@ -238,7 +238,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) ! Following is for convenient WRF MASS input num_mass_fields=15+5*lm+2*nsig_soil ! The 9 3D cloud analysis fields are: ql,qi,qr,qs,qg,qnr,qni,qnc,tt - if(l_cloud_analysis .and. n_actual_clouds>0) num_mass_fields=num_mass_fields+9*lm+2 + if(l_hydrometeor_bkio .and. n_actual_clouds>0) num_mass_fields=num_mass_fields+9*lm+2 if(l_gsd_soilTQ_nudge) num_mass_fields=num_mass_fields+2 num_loc_groups=num_mass_fields/npe if(print_verbose) then @@ -306,7 +306,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) endif ! for cloud analysis - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ! get pointer to relevant instance of cloud-related background ier=0 @@ -320,7 +320,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnc',ges_qnc,istatus );ier=ier+istatus if (ier/=0 .and. mype == 0) then write(6,*)'READ_WRF_MASS_BINARY_GUESS: getpointer failed, cannot do cloud analysis' - l_cloud_analysis=.false. + l_hydrometeor_bkio=.false. endif i=0 @@ -557,7 +557,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) if(print_verbose) write(6,*)' th2 i,igtype(i),offset(i) = ',i,igtype(i),offset(i) ! for cloud array - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then i_qc=i+1 read(lendian_in) n_position,memoryorder @@ -868,7 +868,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) end if ! for cloud analysis - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ! read qc if(kord(i_qc)/=1) then allocate(jbuf(im,lm,jbegin(mype):jend(mype))) @@ -1014,7 +1014,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) deallocate(jbuf) end if - endif ! l_cloud_analysis + endif ! l_hydrometeor_bkio !---------------------- read surface files last do k=kbegin(mype),kend(mype) @@ -1066,7 +1066,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) ku=i_u-1 kv=i_v-1 ! hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then kqc=i_qc-1 kqr=i_qr-1 kqs=i_qs-1 @@ -1090,7 +1090,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) ku=ku+1 kv=kv+1 ! hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then kqc=kqc+1 kqr=kqr+1 kqs=kqs+1 @@ -1115,7 +1115,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) ! Add offset to get guess potential temperature ges_pot(j,i,k) = real(all_loc(j,i,kt),r_kind) + h300 ! hydrometeors - if(l_cloud_analysis .or. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ges_qc(j,i,k) = real(all_loc(j,i,kqc),r_kind) ges_qi(j,i,k) = real(all_loc(j,i,kqi),r_kind) ges_qr(j,i,k) = real(all_loc(j,i,kqr),r_kind) @@ -1182,7 +1182,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) !GSD soil_moi(j,i,it)=real(all_loc(j,i,i_smois),r_kind) !GSD soil_temp(j,i,it)=real(all_loc(j,i,i_tslb),r_kind) ! for cloud analysis - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then soil_temp_cld(j,i,it)=soil_temp(j,i,it) ges_xlon(j,i,it)=real(all_loc(j,i,i_xlon),r_kind)/rad2deg_single ges_xlat(j,i,it)=real(all_loc(j,i,i_xlat),r_kind)/rad2deg_single @@ -1247,7 +1247,7 @@ subroutine read_wrf_mass_binary_guess_wrf(this,mype) j,i,mype,sfct(j,i,it) end if sfc_rough(j,i,it)=rough_default - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then isli_cld(j,i,it)=isli(j,i,it) endif end do @@ -1321,6 +1321,10 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) ! number concentration) ! 2017-03-23 Hu - add code to read hybrid vertical coodinate in WRF MASS ! + ! 2016-02-14 Johnson, Y. Wang, X. Wang - add code to read vertical velocity (W) and + ! Reflectivity (REFL_10CM) for radar + ! DA, POC: xuguang.wang@ou.edu + ! ! input argument list: ! mype - pe number ! @@ -1350,17 +1354,21 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) use gridmod, only: lat2,lon2,nlat_regional,nlon_regional,& nsig,nsig_soil,ijn_s,displs_s,eta1_ll,pt_ll,itotsub,aeta1_ll,eta2_ll,aeta2_ll use constants, only: zero,one,grav,fv,zero_single,rd_over_cp_mass,one_tenth,r10,r100 - use constants, only: r0_01, tiny_r_kind - use gsi_io, only: lendian_in,verbose + use constants, only: r0_01, tiny_r_kind,rd,r1000 + use gsi_io, only: lendian_in, verbose use chemmod, only: laeroana_gocart,nh4_mfac,oc_mfac,& aerotot_guess,init_aerotot_guess,wrf_pm2_5,aero_ratios - use rapidrefresh_cldsurf_mod, only: l_cloud_analysis,l_gsd_soiltq_nudge + use rapidrefresh_cldsurf_mod, only: l_hydrometeor_bkio,l_gsd_soiltq_nudge use rapidrefresh_cldsurf_mod, only: i_use_2mq4b,i_use_2mt4b use wrf_mass_guess_mod, only: soil_temp_cld,isli_cld,ges_xlon,ges_xlat,ges_tten,create_cld_grids use gsi_bundlemod, only: GSI_BundleGetPointer use gsi_metguess_mod, only: gsi_metguess_get,GSI_MetGuess_Bundle use gsi_chemguess_mod, only: GSI_ChemGuess_Bundle, gsi_chemguess_get use mpeu_util, only: die + use guess_grids, only: ges_w_btlev + use wrf_vars_mod, only : w_exist, dbz_exist + use setupdbz_lib,only: hx_dart + use obsmod,only: if_model_dbz implicit none class(read_wrf_mass_guess_class),intent(inout) :: this @@ -1372,7 +1380,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) real(r_kind),parameter:: rough_default=0.05_r_kind ! Declare local variables - integer(i_kind) kt,kq,ku,kv + integer(i_kind) kt,kq,ku,kv,kw,kw0,kdbz ! MASS variable names stuck in here @@ -1398,7 +1406,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) real(r_kind) deltasigma,deltasigmac4h real(r_kind):: work_prsl,work_prslk integer(i_kind),allocatable :: i_chem(:),kchem(:) - integer(i_kind) i_qc,i_qi,i_qr,i_qs,i_qg,i_qnr,i_qni,i_qnc + integer(i_kind) i_qc,i_qi,i_qr,i_qs,i_qg,i_qnr,i_qni,i_qnc,i_w,i_dbz integer(i_kind) kqc,kqi,kqr,kqs,kqg,kqnr,kqni,kqnc,i_xlon,i_xlat,i_tt,ktt integer(i_kind) i_th2,i_q2,i_soilt1,ksmois,ktslb integer(i_kind) ier, istatus @@ -1409,6 +1417,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) indx_dust3, indx_dust4, indx_dust5, & indx_seas1, indx_seas2, indx_seas3, indx_seas4,indx_p25 character(len=5),allocatable :: cvar(:) + real(r_kind) :: ges_rho, tsn real(r_kind), pointer :: ges_ps_it (:,: )=>NULL() real(r_kind), pointer :: ges_th2_it(:,: )=>NULL() @@ -1422,6 +1431,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) real(r_kind), pointer :: ges_v_it (:,:,:)=>NULL() real(r_kind), pointer :: ges_tv_it (:,:,:)=>NULL() real(r_kind), pointer :: ges_q_it (:,:,:)=>NULL() + real(r_kind), pointer :: ges_w_it (:,:,:)=>NULL() real(r_kind), pointer :: ges_qc (:,:,:)=>NULL() real(r_kind), pointer :: ges_qi (:,:,:)=>NULL() @@ -1431,6 +1441,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) real(r_kind), pointer :: ges_qnr(:,:,:)=>NULL() real(r_kind), pointer :: ges_qni(:,:,:)=>NULL() real(r_kind), pointer :: ges_qnc(:,:,:)=>NULL() + real(r_kind), pointer :: ges_dbz(:,:,:)=>NULL() real(r_kind), pointer :: ges_sulf(:,:,:)=>NULL() real(r_kind), pointer :: ges_bc1(:,:,:)=>NULL() @@ -1482,6 +1493,9 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnc',ges_qnc,istatus );ier=ier+istatus if (ier/=0) n_actual_clouds=0 end if + if( dbz_exist )then + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz',ges_dbz,istatus );ier=ier+istatus + end if if (l_gsd_soilTQ_nudge) then ier=0 call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'tskn', ges_tsk_it, istatus );ier=ier+istatus @@ -1497,7 +1511,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) num_mass_fields_base=14+4*lm num_mass_fields=num_mass_fields_base ! The 9 3D cloud analysis fields are: ql,qi,qr,qs,qg,qnr,qni,qnc,tt - if(l_cloud_analysis .and.n_actual_clouds>0) num_mass_fields=num_mass_fields+9*lm+2 + if(l_hydrometeor_bkio .and.n_actual_clouds>0) num_mass_fields=num_mass_fields+9*lm+2 if(l_gsd_soilTQ_nudge) num_mass_fields=num_mass_fields+2*(nsig_soil-1)+1 if(i_use_2mt4b > 0 ) num_mass_fields=num_mass_fields + 2 if(i_use_2mq4b > 0 .and. i_use_2mt4b <=0 ) num_mass_fields=num_mass_fields + 1 @@ -1520,6 +1534,9 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) if ( wrf_pm2_5 ) then num_mass_fields = num_mass_fields + lm endif + + if( w_exist) num_mass_fields = num_mass_fields + lm + 1 + if( dbz_exist.and.if_model_dbz ) num_mass_fields = num_mass_fields + lm num_all_fields=num_mass_fields*nfldsig @@ -1559,7 +1576,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) i=0 ! for cloud analysis - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then i=i+1 ; i_xlat=i ! xlat write(identity(i),'("record ",i3,"--xlat")')i jsig_skip(i)=3 ! number of files to skip before getting to xlat @@ -1573,7 +1590,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) i=i+1 ; i_psfc=i ! psfc write(identity(i),'("record ",i3,"--psfc")')i jsig_skip(i)=5 ! number of files to skip before getting to psfc - if(l_cloud_analysis .and. n_actual_clouds>0) jsig_skip(i)=0 ! number of files to skip before getting to psfc + if(l_hydrometeor_bkio .and. n_actual_clouds>0) jsig_skip(i)=0 ! number of files to skip before getting to psfc igtype(i)=1 i=i+1 ; i_fis=i ! sfc geopotential write(identity(i),'("record ",i3,"--fis")')i @@ -1604,6 +1621,14 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) write(identity(i),'("record ",i3,"--v(",i2,")")')i,k jsig_skip(i)=0 ; igtype(i)=3 end do + if(w_exist) then + i_w=i+1 + do k=1,lm+1 + i=i+1 ! w(k) + write(identity(i),'("record ",i3,"--w(",i2,")")')i,k + jsig_skip(i)=0 ; igtype(i)=1 + end do + endif i=i+1 ; i_sm=i ! landmask write(identity(i),'("record ",i3,"--sm")')i jsig_skip(i)=0 ; igtype(i)=1 @@ -1671,7 +1696,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) jsig_skip(i)=0 ; igtype(i)=1 endif ! for cloud array - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then i_qc=i+1 do k=1,lm i=i+1 ! qc(k) @@ -1720,6 +1745,14 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) write(identity(i),'("record ",i3,"--qnc(",i2,")")')i,k jsig_skip(i)=0 ; igtype(i)=1 end do + if( dbz_exist.and.if_model_dbz )then + i_dbz=i+1 + do k=1,lm + i=i+1 ! dbz(k) + write(identity(i),'("record ",i3,"--tt(",i2,")")')i,k + jsig_skip(i)=0 ; igtype(i)=1 + end do + end if i_tt=i+1 do k=1,lm i=i+1 ! tt(k) @@ -1843,6 +1876,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) kq=i_0+i_q-1 ku=i_0+i_u-1 kv=i_0+i_v-1 + if(w_exist) kw=i_0+i_w-1 ! typical meteorological fields ier=0 @@ -1850,6 +1884,8 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'z', ges_z_it, istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u', ges_u_it, istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v', ges_v_it, istatus );ier=ier+istatus + if (w_exist) & + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'w', ges_w_it, istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'tv',ges_tv_it,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q_it, istatus );ier=ier+istatus if (ier/=0) call die(trim(myname),'cannot get pointers for met-fields, ier =',ier) @@ -1868,7 +1904,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) endif ! hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ! Get pointer for each of the hydrometeors from guess at time index "it" call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql', ges_qc, istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qi', ges_qi, istatus );ier=ier+istatus @@ -1888,6 +1924,10 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) kqnc=i_0+i_qnc-1 ktt=i_0+i_tt-1 endif + if( dbz_exist ) then + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz',ges_dbz,istatus );ier=ier+istatus + if( if_model_dbz )kdbz=i_0+i_dbz-1 + end if if ( laeroana_gocart ) then if (aero_ratios) then @@ -1984,6 +2024,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) q_integral=one q_integralc4h=zero + if(w_exist) kw0 = kw + 1 do k=1,nsig deltasigma=eta1_ll(k)-eta1_ll(k+1) deltasigmac4h=eta2_ll(k)-eta2_ll(k+1) @@ -1991,8 +2032,9 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) kq=kq+1 ku=ku+1 kv=kv+1 + if(w_exist) kw=kw+1 ! hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then kqc=kqc+1 kqr=kqr+1 kqs=kqs+1 @@ -2003,6 +2045,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) kqnc=kqnc+1 ktt=ktt+1 endif + if(dbz_exist.and.if_model_dbz) kdbz=kdbz+1 if ( laeroana_gocart ) then if ( n_gocart_var > 0 ) then do iv = 1, n_gocart_var @@ -2024,11 +2067,14 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) ges_q_it(j,i,k) = real(all_loc(j,i,kq),r_kind) q_integral(j,i) = q_integral(j,i)+deltasigma*ges_q_it(j,i,k) q_integralc4h(j,i) = q_integralc4h(j,i)+deltasigmac4h*ges_q_it(j,i,k) + if(w_exist) then + ges_w_it(j,i,k) = 0.5*real((all_loc(j,i,kw)+all_loc(j,i,kw+1)),r_kind) + end if ! Convert guess mixing ratio to specific humidity ges_q_it(j,i,k) = ges_q_it(j,i,k)/(one+ges_q_it(j,i,k)) ! hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ges_qc(j,i,k) = real(all_loc(j,i,kqc),r_kind) ges_qi(j,i,k) = real(all_loc(j,i,kqi),r_kind) ges_qr(j,i,k) = real(all_loc(j,i,kqr),r_kind) @@ -2042,6 +2088,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) if(k==nsig) ges_tten(j,i,k,it) = -10.0_r_single endif + if(dbz_exist.and.if_model_dbz) ges_dbz(j,i,k) = real(all_loc(j,i,kdbz),r_kind) if ( laeroana_gocart ) then if (indx_sulf>0) ges_sulf(j,i,k) = real(all_loc(j,i,kchem(indx_sulf)),r_kind) if (indx_bc1>0) ges_bc1(j,i,k) = real(all_loc(j,i,kchem(indx_bc1)),r_kind) @@ -2130,6 +2177,15 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) enddo enddo endif + + if(w_exist) then + do i=1,lon2 + do j=1,lat2 + ges_w_btlev(j,i,1,it) = all_loc(j,i,kw0) + ges_w_btlev(j,i,2,it) = all_loc(j,i,kw+1) + enddo + enddo + endif do i=1,lon2 do j=1,lat2 @@ -2157,7 +2213,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) ges_q2_it(j,i)=ges_q2_it(j,i)/(one+ges_q2_it(j,i)) endif ! for cloud analysis - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then soil_temp_cld(j,i,it)=soil_temp(j,i,it) ges_xlon(j,i,it)=real(all_loc(j,i,i_0+i_xlon),r_kind) ges_xlat(j,i,it)=real(all_loc(j,i,i_0+i_xlat),r_kind) @@ -2179,6 +2235,11 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) work_prslk = (work_prsl/r100)**rd_over_cp_mass ges_tsen(j,i,k,it) = ges_pot(j,i,k)*work_prslk ges_tv_it(j,i,k) = ges_tsen(j,i,k,it) * (one+fv*ges_q_it(j,i,k)) + if( dbz_exist.and.(.not. if_model_dbz) )then + ges_rho = (work_prsl/(ges_tv_it(j,i,k)*rd))*r1000 + tsn=ges_tv_it(j,i,k)/(one+fv*max(zero,ges_q_it(j,i,k))) + call hx_dart(ges_qr(j,i,k),ges_qg(j,i,k),ges_qs(j,i,k),ges_rho,tsn,ges_dbz(j,i,k),.false.) + end if end do end do end do @@ -2214,7 +2275,7 @@ subroutine read_wrf_mass_netcdf_guess_wrf(this,mype) j,i,mype,sfct(j,i,it) num_doubtful_sfct=num_doubtful_sfct+1 end if - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then isli_cld(j,i,it)=isli(j,i,it) endif end do diff --git a/src/cplr_read_wrf_nmm_files.f90 b/src/gsi/cplr_read_wrf_nmm_files.f90 similarity index 95% rename from src/cplr_read_wrf_nmm_files.f90 rename to src/gsi/cplr_read_wrf_nmm_files.f90 index a84c7a96b..8a28cba42 100644 --- a/src/cplr_read_wrf_nmm_files.f90 +++ b/src/gsi/cplr_read_wrf_nmm_files.f90 @@ -109,16 +109,15 @@ subroutine read_wrf_nmm_files_wrf(this,mype) write(6,*)'READ_wrf_nmm_FILES: sigma guess file, nming2 ',hourg,idate5,nming2 t4dv=real((nming2-iwinbgn),r_kind)*r60inv if (l4dvar.or.l4densvar) then - if (t4dvwinlen) go to 110 + if (t4dvwinlen) cycle else ndiff=nming2-nminanl - if(abs(ndiff) > 60*nhr_half ) go to 110 + if(abs(ndiff) > 60*nhr_half ) cycle endif iwan=iwan+1 time_ges(iwan,1) =real((nming2-iwinbgn),r_kind)*r60inv time_ges(iwan+100,1)=i+r0_001 end if - 110 continue end do time_ges(201,1)=one time_ges(202,1)=one @@ -158,12 +157,12 @@ subroutine read_wrf_nmm_files_wrf(this,mype) nming2=nmings+60*hourg write(6,*)'READ_wrf_nmm_FILES: surface guess file, nming2 ',hourg,idateg,nming2 ndiff=nming2-nminanl - if(abs(ndiff) > 60*nhr_half ) go to 210 - iwan=iwan+1 - time_ges(iwan,2) = real((nming2-iwinbgn),r_kind)*r60inv - time_ges(iwan+100,2)=i+r0_001 + if(abs(ndiff) <= 60*nhr_half )then + iwan=iwan+1 + time_ges(iwan,2) = real((nming2-iwinbgn),r_kind)*r60inv + time_ges(iwan+100,2)=i+r0_001 + end if end if - 210 continue if(iwan==1) exit end do time_ges(201,2)=one @@ -310,7 +309,7 @@ subroutine read_nems_nmmb_files_wrf(this,mype) integer(i_kind),dimension(4):: idateg integer(i_kind),dimension(5):: idate5 real(r_single) hourg4 - real(r_kind) hourg,temp,t4dv + real(r_kind) hourg,temp,t4dv,minuteg real(r_kind),dimension(202,2):: time_ges associate( this => this ) ! eliminates warning for unused dummy argument needed for binding @@ -344,25 +343,24 @@ subroutine read_nems_nmmb_files_wrf(this,mype) inquire(file=filename,exist=fexist) if(fexist)then open(in_unit,file=filename,form='unformatted') - read(in_unit) idate5,isecond,hourg + read(in_unit) idate5,isecond,hourg,minuteg close(in_unit) ! idate5(5)=0 call w3fs21(idate5,nmings) - nming2=nmings+60*hourg - write(6,*)'READ_nems_nmmb_FILES: sigma guess file, nming2 ',hourg,idate5,nming2 + nming2=nmings+60*hourg+minuteg + write(6,*)'READ_nems_nmmb_FILES: sigma guess file, nming2 ',hourg,minuteg,idate5,nming2 t4dv=real((nming2-iwinbgn),r_kind)*r60inv if (l4dvar.or.l4densvar) then - if (t4dvwinlen) go to 110 + if (t4dvwinlen) cycle else ndiff=nming2-nminanl !for test with the 3 hr files with FGAT - ! if(abs(ndiff) > 60*nhr_half ) go to 110 + ! if(abs(ndiff) > 60*nhr_half ) cycle endif iwan=iwan+1 time_ges(iwan,1) =real((nming2-iwinbgn),r_kind)*r60inv time_ges(iwan+100,1)=i+r0_001 end if - 110 continue end do time_ges(201,1)=one time_ges(202,1)=one @@ -402,12 +400,12 @@ subroutine read_nems_nmmb_files_wrf(this,mype) nming2=nmings+60*hourg write(6,*)'READ_nems_nmmb_FILES: surface guess file, nming2 ',hourg,idateg,nming2 ndiff=nming2-nminanl - if(abs(ndiff) > 60*nhr_half ) go to 210 - iwan=iwan+1 - time_ges(iwan,2) =real((nming2-iwinbgn),r_kind)*r60inv - time_ges(iwan+100,2)=i+r0_001 + if(abs(ndiff) <= 60*nhr_half ) then + iwan=iwan+1 + time_ges(iwan,2) =real((nming2-iwinbgn),r_kind)*r60inv + time_ges(iwan+100,2)=i+r0_001 + end if end if - 210 continue if(iwan==1) exit end do time_ges(201,2)=one diff --git a/src/cplr_read_wrf_nmm_guess.f90 b/src/gsi/cplr_read_wrf_nmm_guess.f90 similarity index 92% rename from src/cplr_read_wrf_nmm_guess.f90 rename to src/gsi/cplr_read_wrf_nmm_guess.f90 index c2114fb1a..63b1bac54 100644 --- a/src/cplr_read_wrf_nmm_guess.f90 +++ b/src/gsi/cplr_read_wrf_nmm_guess.f90 @@ -1133,6 +1133,10 @@ subroutine read_wrf_nmm_netcdf_guess_wrf(this,mype) real(r_kind),pointer,dimension(:,:,:):: ges_qs=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_qg=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_qh=>NULL() + + real(r_kind),pointer,dimension(:,:,:):: ges_fice=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_frain=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_frimef=>NULL() logical print_verbose associate( this => this ) ! eliminates warning for unused dummy argument needed for binding @@ -1513,6 +1517,12 @@ subroutine read_wrf_nmm_netcdf_guess_wrf(this,mype) if (n_actual_clouds>0) then call gsi_bundlegetpointer (gsi_metguess_bundle(it),'cw',ges_cwmr,iret) if (iret==0) ges_cwmr=clwmr + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'fice',ges_fice,iret) + if (iret==0) ges_fice=fice + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'frain',ges_frain,iret) + if (iret==0) ges_frain=frain + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'frimef',ges_frimef,iret) + if (iret==0) ges_frimef=frimef end if @@ -1672,6 +1682,8 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) ! 2016_03_02 s.liu/carley - remove use_reflectivity and use i_gsdcldanal_type ! 2016_06_21 s.liu - delete unused variable qhtmp ! 2016_06_30 s.liu - delete unused variable gridtype in read fraction + ! 2017-05-12 Y. Wang, X. Wang - add code to read vertical velocity (W), hydrometeors and + ! Reflectivity (REFL_10CM) for direct radar DA, POC: xuguang.wang@ou.edu ! 2016-08-12 lippi - add include_w. If true, reads in guess vertical velocity (w) profile. ! ! input argument list: @@ -1705,16 +1717,18 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) use gridmod, only: lat2,lon2,pdtop_ll,pt_ll,nsig,nmmb_verttype,use_gfs_ozone,regional_ozone,& aeta1_ll,aeta2_ll use rapidrefresh_cldsurf_mod, only: i_gsdcldanal_type - use constants, only: zero,one_tenth,half,one,fv,rd_over_cp,r100,r0_01,ten + use constants, only: zero,one_tenth,half,one,fv,rd_over_cp,r100,r0_01,ten,rd,r1000 use wrf_params_mod, only: update_pint, cold_start - use gsi_nemsio_mod, only: gsi_nemsio_open,gsi_nemsio_close,gsi_nemsio_read,gsi_nemsio_read_fraction + use gsi_nemsio_mod, only: gsi_nemsio_open,gsi_nemsio_close,gsi_nemsio_read,gsi_nemsio_read_fraction, gsi_nemsio_read_fractionnew use gfs_stratosphere, only: use_gfs_stratosphere,nsig_save,good_o3mr,add_gfs_stratosphere use gsi_metguess_mod, only: gsi_metguess_get,gsi_metguess_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use mpeu_util, only: die,getindex use control_vectors, only: cvars3d use cloud_efr_mod, only: cloud_calc,cloud_calc_gfs + use obsmod,only: if_model_dbz + use wrf_vars_mod, only : dbz_exist implicit none ! Declare passed variables here @@ -1734,11 +1748,15 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) real(r_kind) pd,psfc_this,wmag,pd_to_ps integer(i_kind) num_doubtful_sfct,num_doubtful_sfct_all real(r_kind),dimension(lat2,lon2):: smthis,sicethis,u10this,v10this,sstthis,tskthis + + real(r_kind) :: Cr=3.6308e9_r_kind ! Rain constant coef. + real(r_kind) :: Cli=3.268e9_r_kind ! Precip. ice constant coef. ! variables for cloud info logical good_fice, good_frain, good_frimef - integer(i_kind) iqtotal,icw4crtm,ier,iret,n_actual_clouds,istatus,ierr - real(r_kind),dimension(lat2,lon2,nsig):: clwmr,fice,frain,frimef + integer(i_kind) iqtotal,icw4crtm,ier,iret,n_actual_clouds,istatus,ierr, & + i_radar_qr,i_radar_qli,i_radar_qh + real(r_kind),dimension(lat2,lon2,nsig):: clwmr,fice,frain,frimef,ges_rho,Ze,Zer, Zeli real(r_kind),pointer,dimension(:,: ):: ges_pd =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_ps =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_z =>NULL() @@ -1752,6 +1770,8 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) real(r_kind),pointer,dimension(:,:,:):: ges_cwmr=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_ref =>NULL() real(r_kind),pointer,dimension(:,:,:):: dfi_tten=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_dw =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_dbz =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_ql=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_qi=>NULL() @@ -1759,6 +1779,7 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) real(r_kind),pointer,dimension(:,:,:):: ges_qs=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_qg=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_qh=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qli=>NULL() associate( this => this ) ! eliminates warning for unused dummy argument needed for binding end associate @@ -1784,6 +1805,14 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) ! Determine whether or not total moisture (water vapor+total cloud condensate) is the control variable iqtotal=getindex(cvars3d,'qt') + + ! Determine if qr and qli are control variables for radar data assimilation, + i_radar_qr=0 + i_radar_qli=0 + i_radar_qh=0 + i_radar_qr=getindex(cvars3d,'qr') + i_radar_qli=getindex(cvars3d,'qli') + i_radar_qh=getindex(cvars3d,'qh') ! Inquire about cloud guess fields call gsi_metguess_get('clouds::3d',n_actual_clouds,istatus) @@ -1799,6 +1828,7 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'z' , ges_z ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u' , ges_u ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v' , ges_v ,istatus );ier=ier+istatus + if(dbz_exist) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz' , ges_dbz ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'tv' ,ges_tv ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'oz' ,ges_oz ,istatus );ier=ier+istatus @@ -1807,6 +1837,7 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) if (istatus==0) then include_w=.true. if(mype==0) write(6,*)'READ_WRF_NMM_GUESS: Using vertical velocity.' + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dw' , ges_dw ,istatus );ier=ier+istatus else include_w=.false. if(mype==0) write(6,*)'READ_WRF_NMM_GUESS: NOT using vertical velocity.' @@ -1844,6 +1875,11 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) ges_q(:,:,k)=zero ges_tsen(:,:,k,it)=zero ges_oz(:,:,k)=zero + if(include_w) then + ges_w(:,:,k)=zero + ges_dw(:,:,k)=zero + end if + if(dbz_exist) ges_dbz(:,:,k)=zero end do do kr=1,nsig_read k=nsig_read+1-kr @@ -1853,6 +1889,7 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) call gsi_nemsio_read('tmp' ,'mid layer','H',kr,ges_tsen(:,:,k,it),mype,mype_input) if(include_w) then call gsi_nemsio_read('w_tot','mid layer','H',kr,ges_w(:,:,k),mype,mype_input) + call gsi_nemsio_read('dwdt','mid layer','H',kr,ges_dw(:,:,k), mype,mype_input) end if do i=1,lon2 do j=1,lat2 @@ -1873,47 +1910,111 @@ subroutine read_nems_nmmb_guess_wrf(this,mype) end if end do - ! ! cloud liquid water,ice,snow,graupel,hail,rain for cloudy radiance - if (n_actual_clouds>0 .and. (i_gsdcldanal_type/=2)) then - - ! Get pointer to cloud water mixing ratio + if( i_gsdcldanal_type == 0 .and. i_radar_qr>0 .and. i_radar_qli>0 )then + ! For directly assimilating radar reflectivity rather than cloud analysis + + ier = 0 call gsi_bundlegetpointer (gsi_metguess_bundle(it),'ql',ges_ql,iret); ier=iret - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qi',ges_qi,iret); ier=ier+iret call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qr',ges_qr,iret); ier=ier+iret - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qs',ges_qs,iret); ier=ier+iret - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qg',ges_qg,iret); ier=ier+iret - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qh',ges_qh,iret); ier=ier+iret - if ((icw4crtm>0 .or. iqtotal>0) .and. ier==0) then - ges_ql=zero; ges_qi=zero; ges_qr=zero; ges_qs=zero; ges_qg=zero; ges_qh=zero - efr_ql=zero; efr_qi=zero; efr_qr=zero; efr_qs=zero; efr_qg=zero; efr_qh=zero - do kr=1,nsig_read - k=nsig_read+1-kr - call gsi_nemsio_read('clwmr', 'mid layer','H',kr,clwmr(:,:,k), mype,mype_input) !read total condensate - call gsi_nemsio_read('f_ice', 'mid layer','H',kr,fice(:,:,k), mype,mype_input,good_fice) !read ice fraction - call gsi_nemsio_read('f_rain','mid layer','H',kr,frain(:,:,k), mype,mype_input,good_frain) !read rain fraction - call gsi_nemsio_read('f_rimef','mid layer','H',kr,frimef(:,:,k), mype,mype_input,good_frimef) !read rime factor - if (good_fice .and. good_frain .and. good_frimef) cold_start=.false. - if (.not. cold_start) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qi',ges_qi,iret); ier=ier+iret + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qli',ges_qli,iret); ier=ier+iret + if(dbz_exist) call gsi_bundlegetpointer (gsi_metguess_bundle(it),'dbz',ges_dbz,iret); ier=ier+iret + if (ier/=0) call die(trim(myname),'cannot get pointers for met-fields related to hydrometeor, ier =',ier) + + if (ier==0) then + frain=zero + fice=zero + clwmr=zero + do kr=1,nsig + k=nsig+1-kr + if( dbz_exist .and. if_model_dbz ) then + call gsi_nemsio_read('refl_10cm' ,'mid layer','H',kr,ges_dbz(:,:,k),mype,mype_input) + where( ges_dbz(:,:,k) < 0.0_r_kind ) + ges_dbz(:,:,k) = 0.0_r_kind + end where + end if + call gsi_nemsio_read_fractionnew('f_rain','f_ice','clwmr','f_rimef','mid layer',kr, & + ges_qi(:,:,k),ges_qli(:,:,k),ges_qr(:,:,k),ges_ql(:,:,k), mype,mype_input) + if( dbz_exist .and. (.not. if_model_dbz) )then do i=1,lon2 do j=1,lat2 ges_prsl(j,i,k,it)=one_tenth* & (aeta1_ll(k)*pdtop_ll + & aeta2_ll(k)*(ten*ges_ps(j,i)-pdtop_ll-pt_ll) + & pt_ll) + ges_rho(j,i,k)=(ges_prsl(j,i,k,it)/(ges_tv(j,i,k)*rd))*r1000 end do end do - call cloud_calc(ges_prsl(:,:,k,it),ges_q(:,:,k),ges_tsen(:,:,k,it),clwmr(:,:,k), & - fice(:,:,k),frain(:,:,k),frimef(:,:,k), & - ges_ql(:,:,k),ges_qi(:,:,k),ges_qr(:,:,k),ges_qs(:,:,k),ges_qg(:,:,k),ges_qh(:,:,k), & - efr_ql(:,:,k,it),efr_qi(:,:,k,it),efr_qr(:,:,k,it),efr_qs(:,:,k,it),efr_qg(:,:,k,it),efr_qh(:,:,k,it)) - end if - end do - if (cold_start) call cloud_calc_gfs(ges_ql,ges_qi,clwmr,ges_q,ges_tv,.true.) + + Zer(:,:,k) = Cr * (ges_rho(:,:,k) * ges_qr(:,:,k))**(1.75_r_kind) + Zeli(:,:,k) = Cli * (ges_rho(:,:,k) * ges_qli(:,:,k))**(2.0_r_kind) + Ze(:,:,k)=Zer(:,:,k)+Zeli(:,:,k) + + ges_dbz(:,:,k) = 0.0_r_kind + + where ( Ze(:,:,k) > 0.0_r_kind ) + ges_dbz(:,:,k) = ten * log10(Ze(:,:,k)) + end where + where( ges_dbz(:,:,k) < 0.0_r_kind ) + ges_dbz(:,:,k) = 0.0_r_kind + end where + end if + end do + if (mype==0) then + write(6,*)'QLI,max, min,',maxval(ges_qli),minval(ges_qli) + write(6,*)'QR,max, min,',maxval(ges_qr),minval(ges_qr) + write(6,*)'QL,max, min,',maxval(ges_ql),minval(ges_ql) + if( dbz_exist ) write(6,*)'DBZ,max, min,',maxval(ges_dbz),minval(ges_dbz) + end if + else + if (mype==0) write(6,*) 'ERROR GETTING POINTERS FOR HYDROMETEORS WITH RADAR DATA ASSIMILATION IN READ NMMB GUESS' + end if ! ier==0 + + else ! i_radar_qli > 0 + + ! ! cloud liquid water,ice,snow,graupel,hail,rain for cloudy radiance + if (n_actual_clouds>0 .and. (i_gsdcldanal_type/=2) .and. i_radar_qh > 0 ) then + + ! Get pointer to cloud water mixing ratio + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'ql',ges_ql,iret); ier=iret + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qi',ges_qi,iret); ier=ier+iret + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qr',ges_qr,iret); ier=ier+iret + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qs',ges_qs,iret); ier=ier+iret + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qg',ges_qg,iret); ier=ier+iret + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qh',ges_qh,iret); ier=ier+iret + if ((icw4crtm>0 .or. iqtotal>0) .and. ier==0) then + ges_ql=zero; ges_qi=zero; ges_qr=zero; ges_qs=zero; ges_qg=zero; ges_qh=zero + efr_ql=zero; efr_qi=zero; efr_qr=zero; efr_qs=zero; efr_qg=zero; efr_qh=zero + do kr=1,nsig_read + k=nsig_read+1-kr + call gsi_nemsio_read('clwmr', 'mid layer','H',kr,clwmr(:,:,k), mype,mype_input) !read total condensate + call gsi_nemsio_read('f_ice', 'mid layer','H',kr,fice(:,:,k), mype,mype_input,good_fice) !read ice fraction + call gsi_nemsio_read('f_rain','mid layer','H',kr,frain(:,:,k), mype,mype_input,good_frain) !read rain fraction + call gsi_nemsio_read('f_rimef','mid layer','H',kr,frimef(:,:,k), mype,mype_input,good_frimef) !read rime factor + if (good_fice .and. good_frain .and. good_frimef) cold_start=.false. + if (.not. cold_start) then + do i=1,lon2 + do j=1,lat2 + ges_prsl(j,i,k,it)=one_tenth* & + (aeta1_ll(k)*pdtop_ll + & + aeta2_ll(k)*(ten*ges_ps(j,i)-pdtop_ll-pt_ll) + & + pt_ll) + end do + end do + call cloud_calc(ges_prsl(:,:,k,it),ges_q(:,:,k),ges_tsen(:,:,k,it),clwmr(:,:,k), & + fice(:,:,k),frain(:,:,k),frimef(:,:,k), & + ges_ql(:,:,k),ges_qi(:,:,k),ges_qr(:,:,k),ges_qs(:,:,k),ges_qg(:,:,k),ges_qh(:,:,k), & + efr_ql(:,:,k,it),efr_qi(:,:,k,it),efr_qr(:,:,k,it),efr_qs(:,:,k,it),efr_qg(:,:,k,it),efr_qh(:,:,k,it)) + end if + end do + if (cold_start) call cloud_calc_gfs(ges_ql,ges_qi,clwmr,ges_q,ges_tv,.true.) - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'cw',ges_cwmr,iret) - if (iret==0) ges_cwmr=clwmr - end if ! icw4crtm>10 .or. iqtotal>0 - end if ! end of (n_actual_clouds>0) + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'cw',ges_cwmr,iret) + if (iret==0) ges_cwmr=clwmr + end if ! icw4crtm>10 .or. iqtotal>0 + end if ! end of (n_actual_clouds>0) + + end if ! i_radar_qli > 0 ! if (n_actual_clouds>0 .and. use_reflectivity) then diff --git a/src/cplr_regional_io.f90 b/src/gsi/cplr_regional_io.f90 similarity index 100% rename from src/cplr_regional_io.f90 rename to src/gsi/cplr_regional_io.f90 diff --git a/src/cplr_wrf_binary_interface.f90 b/src/gsi/cplr_wrf_binary_interface.f90 similarity index 96% rename from src/cplr_wrf_binary_interface.f90 rename to src/gsi/cplr_wrf_binary_interface.f90 index 19c06b0ec..0910d8039 100644 --- a/src/cplr_wrf_binary_interface.f90 +++ b/src/gsi/cplr_wrf_binary_interface.f90 @@ -122,7 +122,7 @@ subroutine convert_binary_mass_wrf(this) use kinds, only: r_single,i_llong,i_kind use gsi_4dvar, only: nhr_assimilation use gsi_io, only: lendian_out, verbose - use rapidrefresh_cldsurf_mod, only: l_cloud_analysis,l_gsd_soilTQ_nudge + use rapidrefresh_cldsurf_mod, only: l_hydrometeor_bkio,l_gsd_soilTQ_nudge use gsi_metguess_mod, only: gsi_metguess_get use gridmod, only: wrf_mass_hybridcord implicit none @@ -654,7 +654,7 @@ subroutine convert_binary_mass_wrf(this) write(lendian_out)n_position ! TH2 endif - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ! QCLOUD call this%retrieve_index(index,'QCLOUD',varname_all,nrecs) if(index<0) stop @@ -718,7 +718,7 @@ subroutine convert_binary_mass_wrf(this) if(print_verbose)write(6,*)' byte offset, memoryorder for RAD_TTEN_DFI(',k,' = ',n_position,memoryorder_all(index) write(lendian_out)n_position,memoryorder_all(index) ! offset for RAD_TTEN_DFI(k) - endif ! l_cloud_analysis + endif ! l_hydrometeor_bkio !??????????????????/later put in z0 here, but for now just fill with something call this%retrieve_index(index,'TSK',varname_all,nrecs) @@ -1551,7 +1551,7 @@ subroutine convert_nems_nmmb_wrf(this,update_pint,ctph0,stph0,tlm0) character(8),allocatable:: recname(:) character(16),allocatable :: reclevtyp(:) integer(i_kind),allocatable:: reclev(:) - real(r_kind) date6,date7,second,fhour + real(r_kind) date6,date7,second,fhour,fminute character(3) nmmb_verttype ! 'OLD' for old vertical coordinate definition ! old def: p = eta1*pdtop+eta2*(psfc-pdtop-ptop)+ptop ! 'NEW' for new vertical coordinate definition @@ -1648,6 +1648,7 @@ subroutine convert_nems_nmmb_wrf(this,update_pint,ctph0,stph0,tlm0) if(print_verbose)write(6,*)' convert_nems_nmmb: pdtop_regional,iret=',pdtop_regional,iret fhour=nfhour + fminute=nfminute ! dsg1 (used to be deta1) @@ -1797,7 +1798,7 @@ subroutine convert_nems_nmmb_wrf(this,update_pint,ctph0,stph0,tlm0) end if - write(lendian_out) iyear,imonth,iday,ihour,iminute,isecond,fhour, & + write(lendian_out)iyear,imonth,iday,ihour,iminute,isecond,fhour,fminute, & nlon_regional,nlat_regional,nsig_regional, & dlmd_regional,dphd_regional,pt_regional,pdtop_regional,nmmb_verttype write(lendian_out)deta1 ! DETA1 @@ -2129,7 +2130,10 @@ subroutine count_recs_wrf_binary_file(this,in_unit,wrfges,nrecs) do i=1,4 nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2139,11 +2143,22 @@ subroutine count_recs_wrf_binary_file(this,in_unit,wrfges,nrecs) num_swap=1 call to_native_endianness_i4(lenrec,num_swap) end if - if(lenrec(1) <= 0_i_long .and. lastbuf) go to 900 - if(lenrec(1) <= 0_i_long .and. .not.lastbuf) go to 885 + if(lenrec(1) <= 0_i_long .and. lastbuf) then + call closefile(in_unit,ierr) + return + end if + if(lenrec(1) <= 0_i_long .and. .not.lastbuf) then + write(6,*)' problem in count_recs_wrf_binary_file, lenrec has bad value before end of file' + write(6,*)' lenrec =',lenrec(1) + call closefile(in_unit,ierr) + return + end if nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2156,7 +2171,10 @@ subroutine count_recs_wrf_binary_file(this,in_unit,wrfges,nrecs) loc_count=loc_count+1 nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf)then + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2166,14 +2184,20 @@ subroutine count_recs_wrf_binary_file(this,in_unit,wrfges,nrecs) loc_count=loc_count+1 nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if end do nextbyte=nextbyte-loc_count+lenrec(1) locbyte=locbyte-loc_count+lenrec(1) - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2181,7 +2205,10 @@ subroutine count_recs_wrf_binary_file(this,in_unit,wrfges,nrecs) do i=1,4 nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2191,36 +2218,22 @@ subroutine count_recs_wrf_binary_file(this,in_unit,wrfges,nrecs) num_swap=1 call to_native_endianness_i4(lenrec,num_swap) end if - if(lenrec(1) /= lensave) go to 890 + if(lenrec(1) /= lensave) then + write(6,*)' problem in count_recs_wrf_binary_file, beginning and ending rec len words unequal' + write(6,*)' begining reclen =',lensave + write(6,*)' ending reclen =',lenrec(1) + write(6,*)' in_unit =',in_unit + call closefile(in_unit,ierr) + return + end if + end do - 880 continue write(6,*)' reached impossible place in count_recs_wrf_binary_file' call closefile(in_unit,ierr) return - 885 continue - write(6,*)' problem in count_recs_wrf_binary_file, lenrec has bad value before end of file' - write(6,*)' lenrec =',lenrec(1) - call closefile(in_unit,ierr) - return - - 890 continue - write(6,*)' problem in count_recs_wrf_binary_file, beginning and ending rec len words unequal' - write(6,*)' begining reclen =',lensave - write(6,*)' ending reclen =',lenrec(1) - write(6,*)' in_unit =',in_unit - call closefile(in_unit,ierr) - return - - 900 continue -! write(6,*)' normal end of file reached in count_recs_wrf_binary_file' -! write(6,*)' nblocks=',thisblock -! write(6,*)' nrecs=',nrecs -! write(6,*)' nreads=',nreads - call closefile(in_unit,ierr) - end subroutine count_recs_wrf_binary_file subroutine initialize_byte_swap_wrf_binary_file(this,in_unit,wrfges) @@ -2425,7 +2438,12 @@ subroutine inventory_wrf_binary_file(this,in_unit,wrfges,nrecs, & do i=1,4 nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + write(6,*)' normal end of file reached in inventory_wrf_binary_file' + write(6,*)' nblocks=',thisblock,' irecs,nrecs=',irecs,nrecs,' nreads=',nreads + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2435,12 +2453,33 @@ subroutine inventory_wrf_binary_file(this,in_unit,wrfges,nrecs, & num_swap=1 call to_native_endianness_i4(lenrec,num_swap) end if - if(lenrec(1) <= 0_i_long .and. lastbuf) go to 900 - if(lenrec(1) <= 0_i_long .and. .not. lastbuf) go to 885 - if(mod(lenrec(1),4)/=0) go to 886 + if(lenrec(1) <= 0_i_long .and. lastbuf) then + write(6,*)' normal end of file reached in inventory_wrf_binary_file' + write(6,*)' nblocks=',thisblock,' irecs,nrecs=',irecs,nrecs,' nreads=',nreads + call closefile(in_unit,ierr) + return + end if + if(lenrec(1) <= 0_i_long .and. .not. lastbuf) then + write(6,*)' problem in inventory_wrf_binary_file, lenrec has bad value before end of file' + write(6,*)' lenrec =',lenrec(1) + call closefile(in_unit,ierr) + return + end if + + if(mod(lenrec(1),4)/=0) then + write(6,*)' problem in inventory_wrf_binary_file, lenrec not a multiple of 4' + write(6,*)' lenrec =',lenrec(1) + call closefile(in_unit,ierr) + return + end if nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + write(6,*)' normal end of file reached in inventory_wrf_binary_file' + write(6,*)' nblocks=',thisblock,' irecs,nrecs=',irecs,nrecs,' nreads=',nreads + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2463,7 +2502,12 @@ subroutine inventory_wrf_binary_file(this,in_unit,wrfges,nrecs, & loc_count=loc_count+1 nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + write(6,*)' normal end of file reached in inventory_wrf_binary_file' + write(6,*)' nblocks=',thisblock,' irecs,nrecs=',irecs,nrecs,' nreads=',nreads + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2483,7 +2527,12 @@ subroutine inventory_wrf_binary_file(this,in_unit,wrfges,nrecs, & loc_count=loc_count+1 nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + write(6,*)' normal end of file reached in inventory_wrf_binary_file' + write(6,*)' nblocks=',thisblock,' irecs,nrecs=',irecs,nrecs,' nreads=',nreads + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2522,7 +2571,12 @@ subroutine inventory_wrf_binary_file(this,in_unit,wrfges,nrecs, & nextbyte=nextbyte-loc_count+lenrec(1) locbyte=locbyte-loc_count+lenrec(1) - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + write(6,*)' normal end of file reached in inventory_wrf_binary_file' + write(6,*)' nblocks=',thisblock,' irecs,nrecs=',irecs,nrecs,' nreads=',nreads + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2532,7 +2586,12 @@ subroutine inventory_wrf_binary_file(this,in_unit,wrfges,nrecs, & do i=1,4 nextbyte=nextbyte+1_i_llong locbyte=locbyte+1_i_llong - if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl .and. lastbuf) then + write(6,*)' normal end of file reached in inventory_wrf_binary_file' + write(6,*)' nblocks=',thisblock,' irecs,nrecs=',irecs,nrecs,' nreads=',nreads + call closefile(in_unit,ierr) + return + end if if(locbyte > lrecl) then call this%next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) end if @@ -2542,40 +2601,22 @@ subroutine inventory_wrf_binary_file(this,in_unit,wrfges,nrecs, & num_swap=1 call to_native_endianness_i4(lenrec,num_swap) end if - if(lenrec(1) /= lensave) go to 890 + if(lenrec(1) /= lensave) then + write(6,*)' problem in inventory_wrf_binary_file, beginning and ending rec len words unequal' + write(6,*)' begining reclen =',lensave + write(6,*)' ending reclen =',lenrec(1) + write(6,*)' irecs =',irecs + write(6,*)' nrecs =',nrecs + call closefile(in_unit,ierr) + return + end if end do - 880 continue write(6,*)' reached impossible place in inventory_wrf_binary_file' call closefile(in_unit,ierr) return - 885 continue - write(6,*)' problem in inventory_wrf_binary_file, lenrec has bad value before end of file' - write(6,*)' lenrec =',lenrec(1) - call closefile(in_unit,ierr) - return - - 886 continue - write(6,*)' problem in inventory_wrf_binary_file, lenrec not a multiple of 4' - write(6,*)' lenrec =',lenrec(1) - call closefile(in_unit,ierr) - return - - 890 continue - write(6,*)' problem in inventory_wrf_binary_file, beginning and ending rec len words unequal' - write(6,*)' begining reclen =',lensave - write(6,*)' ending reclen =',lenrec(1) - write(6,*)' irecs =',irecs - write(6,*)' nrecs =',nrecs - call closefile(in_unit,ierr) - return - - 900 continue - write(6,*)' normal end of file reached in inventory_wrf_binary_file' - write(6,*)' nblocks=',thisblock,' irecs,nrecs=',irecs,nrecs,' nreads=',nreads - call closefile(in_unit,ierr) end subroutine inventory_wrf_binary_file subroutine next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) diff --git a/src/cplr_wrf_netcdf_interface.f90 b/src/gsi/cplr_wrf_netcdf_interface.f90 similarity index 96% rename from src/cplr_wrf_netcdf_interface.f90 rename to src/gsi/cplr_wrf_netcdf_interface.f90 index 825ccd9d8..2924e574c 100644 --- a/src/cplr_wrf_netcdf_interface.f90 +++ b/src/gsi/cplr_wrf_netcdf_interface.f90 @@ -40,6 +40,10 @@ subroutine convert_netcdf_mass_wrf(this) ! 2017-03-23 Hu - add code to read hybrid vertical coodinate in WRF MASS ! core ! + ! 2016-02-14 Johnson, Y. Wang, X. Wang - add code to read vertical velocity (W) and + ! Reflectivity (REFL_10CM) for radar + ! DA, POC: xuguang.wang@ou.edu + ! ! input argument list: ! ! output argument list: @@ -57,13 +61,17 @@ subroutine convert_netcdf_mass_wrf(this) use kinds, only: r_single,i_kind use constants, only: h300 use gsi_4dvar, only: nhr_assimilation - use rapidrefresh_cldsurf_mod, only: l_cloud_analysis,l_gsd_soilTQ_nudge + use rapidrefresh_cldsurf_mod, only: l_hydrometeor_bkio,l_gsd_soilTQ_nudge use rapidrefresh_cldsurf_mod, only: i_use_2mt4b,i_use_2mq4b use gsi_metguess_mod, only: gsi_metguess_get use chemmod, only: laeroana_gocart, ppmv_conv,wrf_pm2_5 use gsi_chemguess_mod, only: gsi_chemguess_get use gridmod, only: wrf_mass_hybridcord use netcdf_mod, only: nc_check + + use wrf_vars_mod, only : w_exist, dbz_exist + use constants, only: zero + use obsmod, only : if_model_dbz use gsi_io, only: verbose implicit none @@ -104,6 +112,9 @@ subroutine convert_netcdf_mass_wrf(this) real(r_single) rdx,rdy real(r_single),allocatable::field3(:,:,:),field2(:,:),field1(:),field2b(:,:),field2c(:,:) real(r_single),allocatable::field3u(:,:,:),field3v(:,:,:),field1a(:) + + real(r_single),allocatable::field3w(:,:,:) + integer(i_kind),allocatable::ifield2(:,:) real(r_single) rad2deg_single integer(i_kind) wrf_real @@ -209,6 +220,9 @@ subroutine convert_netcdf_mass_wrf(this) allocate(ifield2(nlon_regional,nlat_regional)) allocate(field1(max(nlon_regional,nlat_regional,nsig_regional))) allocate(field1a(max(nlon_regional,nlat_regional,nsig_regional))) + if(w_exist) then + allocate(field3w(nlon_regional,nlat_regional,nsig_regional+1)) + end if rmse_var='P_TOP' call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & @@ -640,6 +654,36 @@ subroutine convert_netcdf_mass_wrf(this) field3v(nlon_regional/2,nlat_regional/2,k) write(iunit)((field3v(i,j,k),i=1,nlon_regional),j=1,nlat_regional+1) ! V end do + + if(w_exist) then + rmse_var='W' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index=',end_index + end if + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field3w,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + do k=1,nsig_regional+1 + if(print_verbose)then + write(6,*)' k,max,min,mid W=',k,maxval(field3w(:,:,k)),minval(field3w(:,:,k)), & + field3w(nlon_regional/2,nlat_regional/2,k) + end if + write(iunit)((field3w(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! w + end do + end if + ! rmse_var='LANDMASK' rmse_var='XLAND' @@ -974,7 +1018,7 @@ subroutine convert_netcdf_mass_wrf(this) write(iunit)field2 !TH2 endif - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then rmse_var='QCLOUD' call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & start_index,end_index, WrfType, ierr ) @@ -1155,6 +1199,33 @@ subroutine convert_netcdf_mass_wrf(this) write(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! Qnc end do + if( dbz_exist .and. if_model_dbz ) then + rmse_var='REFL_10CM' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering,& + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + end if + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + do k=1,nsig_regional +! notes: the negative reflectivity is valid value in real observation. + if(print_verbose)then + write(6,*)' k,max,min,mid Dbz=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end if + write(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) !dBZ + end do + end if + rmse_var='RAD_TTEN_DFI' call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & start_index,end_index, WrfType, ierr ) @@ -1178,7 +1249,7 @@ subroutine convert_netcdf_mass_wrf(this) write(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! TTEN end do - endif ! l_cloud_analysis + endif ! l_hydrometeor_bkio if(laeroana_gocart) then call gsi_chemguess_get('aerosols::3d', n_gocart_var, ier) @@ -1277,6 +1348,7 @@ subroutine convert_netcdf_mass_wrf(this) deallocate(field1,field1a,field2,field2b,field2c,ifield2,field3,field3u,field3v) + if(w_exist) deallocate(field3w) close(iunit) call ext_ncd_ioclose(dh1, Status) @@ -2354,7 +2426,8 @@ subroutine update_netcdf_mass_wrf(this) use netcdf, only: nf90_write,nf90_global use kinds, only: r_single,i_kind,r_kind use constants, only: h300,tiny_single - use rapidrefresh_cldsurf_mod, only: l_cloud_analysis,l_gsd_soilTQ_nudge + use rapidrefresh_cldsurf_mod, only: l_hydrometeor_bkio,l_gsd_soilTQ_nudge + use rapidrefresh_cldsurf_mod, only: i_gsdcldanal_type use gsi_metguess_mod, only: gsi_metguess_get,GSI_MetGuess_Bundle use rapidrefresh_cldsurf_mod, only: i_use_2mt4b,i_use_2mq4b use gsi_bundlemod, only: GSI_BundleGetPointer @@ -2362,6 +2435,8 @@ subroutine update_netcdf_mass_wrf(this) use chemmod, only: laeroana_gocart, ppmv_conv,wrf_pm2_5 use gsi_chemguess_mod, only: gsi_chemguess_get use netcdf_mod, only: nc_check + use wrf_vars_mod, only : w_exist, dbz_exist + use obsmod, only : if_model_dbz use gsi_io, only: verbose implicit none @@ -2386,6 +2461,7 @@ subroutine update_netcdf_mass_wrf(this) character (len= 3) :: ordering character (len=80), dimension(3) :: dimnames + character (len=80) :: SysDepInfo character(len=24),parameter :: myname_ = 'update_netcdf_mass' @@ -2398,8 +2474,9 @@ subroutine update_netcdf_mass_wrf(this) real(r_kind), pointer :: ges_qnr(:,:,:)=>NULL() real(r_kind), pointer :: ges_qni(:,:,:)=>NULL() real(r_kind), pointer :: ges_qnc(:,:,:)=>NULL() + real(r_kind), pointer :: ges_dbz(:,:,:)=>NULL() + ! binary stuff logical print_verbose - ! rmse stuff @@ -2409,7 +2486,7 @@ subroutine update_netcdf_mass_wrf(this) integer(i_kind) nlon_regional,nlat_regional,nsig_regional,nsig_soil_regional real(r_single) pt_regional real(r_single),allocatable::field3(:,:,:),field2(:,:),field1(:),field2b(:,:) - real(r_single),allocatable::field3u(:,:,:),field3v(:,:,:) + real(r_single),allocatable::field3u(:,:,:),field3v(:,:,:),field3w(:,:,:) integer(i_kind),allocatable::ifield2(:,:) integer(i_kind) wrf_real data iunit / 15 / @@ -2439,12 +2516,13 @@ subroutine update_netcdf_mass_wrf(this) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnr',ges_qnr,istatus );ierr=ierr+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qni',ges_qni,istatus );ierr=ierr+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnc',ges_qnc,istatus );ierr=ierr+istatus + if(dbz_exist) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it),'dbz',ges_dbz,istatus );ierr=ierr+istatus if (ierr/=0) n_actual_clouds=0 end if ! transfer code from diffwrf for converting netcdf wrf nmm restart file ! to temporary binary format - + if( i_gsdcldanal_type==6 .or. i_gsdcldanal_type==3 .or. i_gsdcldanal_type==7) call ext_ncd_ioinit(sysdepinfo,status) ! ! update mass core netcdf file with analysis variables from 3dvar ! @@ -2486,6 +2564,7 @@ subroutine update_netcdf_mass_wrf(this) allocate(field2(nlon_regional,nlat_regional),field3(nlon_regional,nlat_regional,nsig_regional)) allocate(field3u(nlon_regional+1,nlat_regional,nsig_regional)) allocate(field3v(nlon_regional,nlat_regional+1,nsig_regional)) + allocate(field3w(nlon_regional,nlat_regional,nsig_regional+1)) allocate(field2b(nlon_regional,nlat_regional)) allocate(ifield2(nlon_regional,nlat_regional)) allocate(field1(max(nlon_regional,nlat_regional,nsig_regional))) @@ -2673,6 +2752,33 @@ subroutine update_netcdf_mass_wrf(this) start_index,end_index1, & !mem start_index,end_index1, & !pat ierr ) + + if(w_exist)then + do k=1,nsig_regional+1 + read(iunit)((field3w(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! V + write(6,*)' k,max,min,mid W=',k,maxval(field3w(:,:,k)),minval(field3w(:,:,k)), & + field3w(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='W' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + end if + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3w,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + end if read(iunit) field2 ! LANDMASK if(print_verbose)write(6,*)'max,min LANDMASK=',maxval(field2),minval(field2) @@ -2884,7 +2990,7 @@ subroutine update_netcdf_mass_wrf(this) ierr ) endif - if (l_cloud_analysis .and. n_actual_clouds>0) then + if (l_hydrometeor_bkio .and. n_actual_clouds>0) then do k=1,nsig_regional read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! Qc if(print_verbose) & @@ -3100,7 +3206,36 @@ subroutine update_netcdf_mass_wrf(this) start_index,end_index1, & !mem start_index,end_index1, & !pat ierr ) + end if ! l_hydrometeor_bkio + + if(dbz_exist .and. if_model_dbz)then + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! V + if(print_verbose) write(6,*)' k,max,min,mid dbz=',k,maxval(field3v(:,:,k)),minval(field3v(:,:,k)), & + field3v(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='REFL_10CM' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + end if + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + end if + if( l_hydrometeor_bkio )then do k=1,nsig_regional read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! TTEN if(print_verbose) & @@ -3127,7 +3262,7 @@ subroutine update_netcdf_mass_wrf(this) start_index,end_index1, & !pat ierr ) - endif ! l_cloud_analysis + end if ! l_hydrometeor_bkio if(laeroana_gocart) then call gsi_chemguess_get('aerosols::3d', n_gocart_var, ier) @@ -3226,7 +3361,7 @@ subroutine update_netcdf_mass_wrf(this) ierr ) endif - deallocate(field1,field2,field2b,ifield2,field3,field3u,field3v) + deallocate(field1,field2,field2b,ifield2,field3,field3u,field3v,field3w) call ext_ncd_ioclose(dh1, Status) close(iunit) ! diff --git a/src/cplr_wrwrfmassa.f90 b/src/gsi/cplr_wrwrfmassa.f90 similarity index 94% rename from src/cplr_wrwrfmassa.f90 rename to src/gsi/cplr_wrwrfmassa.f90 index 5acc8eb86..a90147a88 100644 --- a/src/cplr_wrwrfmassa.f90 +++ b/src/gsi/cplr_wrwrfmassa.f90 @@ -80,8 +80,9 @@ subroutine wrwrfmassa_binary_wrf(this,mype) nsig,nsig_soil,eta1_ll,pt_ll,itotsub,iglobal,update_regsfc,& aeta1_ll,eta2_ll,aeta2_ll use constants, only: one,zero_single,rd_over_cp_mass,one_tenth,h300,r10,r100 + use constants, only: soilmoistmin use gsi_io, only: lendian_in,verbose - use rapidrefresh_cldsurf_mod, only: l_cloud_analysis,l_gsd_soilTQ_nudge,& + use rapidrefresh_cldsurf_mod, only: l_hydrometeor_bkio,l_gsd_soilTQ_nudge,& i_use_2mq4b use wrf_mass_guess_mod, only: destroy_cld_grids use gsi_bundlemod, only: GSI_BundleGetPointer @@ -135,6 +136,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) integer(i_long),allocatable:: ibuf(:,:) integer(i_long),allocatable:: jbuf(:,:,:) real(r_single),allocatable::mub(:,:), landmask(:,:),snow(:,:),seaice(:,:) + real(r_single),allocatable::t1st2d(:,:) integer(i_kind) kdim_mub,i_snowT_check integer(i_kind) kt,kq,ku,kv integer(i_kind) mfcst @@ -197,12 +199,13 @@ subroutine wrwrfmassa_binary_wrf(this,mype) lm=nsig num_mass_fields=4*lm+4 - if(l_cloud_analysis .and. n_actual_clouds>0) num_mass_fields=4*lm+4+9*lm + if(l_hydrometeor_bkio .and. n_actual_clouds>0) num_mass_fields=4*lm+4+9*lm if(l_gsd_soilTQ_nudge) num_mass_fields=4*lm+4+2*nsig_soil+2 - if(l_cloud_analysis .and. l_gsd_soilTQ_nudge) num_mass_fields=4*lm+4+9*lm+2*nsig_soil+2 + if(l_hydrometeor_bkio .and. l_gsd_soilTQ_nudge) num_mass_fields=4*lm+4+9*lm+2*nsig_soil+2 allocate(offset(num_mass_fields)) allocate(igtype(num_mass_fields),kdim(num_mass_fields),kord(num_mass_fields)) allocate(length(num_mass_fields)) + allocate(t1st2d(im,jm)) ! igtype is a flag indicating whether each input MASS field is h-, u-, or v-grid ! and whether integer or real @@ -409,7 +412,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) endif ! for cloud/hydrometeor analysis fields - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then i_qc=i+1 read(lendian_in) n_position,memoryorder @@ -546,7 +549,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) if(print_verbose.and.k==1) write(6,*)' tt i,igtype,offset,kdim(i) = ',i,igtype(i),offset(i),kdim(i) end do - endif ! l_cloud_analysis + endif ! l_hydrometeor_bkio close(lendian_in) @@ -603,7 +606,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) q_integral=one q_integralc4h=zero_single ! for hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ! get pointer to relevant instance of cloud-related backgroud ier=0 call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql', ges_qc, istatus );ier=ier+istatus @@ -645,7 +648,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) ku=ku+1 kv=kv+1 ! for hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then kqc=kqc+1 kqi=kqi+1 kqr=kqr+1 @@ -678,7 +681,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) all_loc(j,i,kq)= ges_q(jp1,ip1,k)/(one-ges_q(jp1,ip1,k)) ! for hydrometeors - if(l_cloud_analysis .or. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then all_loc(j,i,kqc)=ges_qc(jp1,ip1,k) all_loc(j,i,kqi)=ges_qi(jp1,ip1,k) all_loc(j,i,kqr)=ges_qr(jp1,ip1,k) @@ -905,7 +908,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) endif ! read hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ! read qc if(kord(i_qc)/=1) then allocate(jbuf(im,lm,jbegin(mype):min(jend(mype),jm))) @@ -1041,7 +1044,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) deallocate(jbuf) end if - endif ! l_cloud_analysis + endif ! l_hydrometeor_bkio !---------------------- read surface files last do k=kbegin(mype),kend(mype) @@ -1089,11 +1092,20 @@ subroutine wrwrfmassa_binary_wrf(this,mype) (ifld >=i_tslb .and. ifld <=i_tslb+ksize-1) ) then ! for 2X soil nudging i_snowT_check=0 - if(ifld==i_tsk .or. ifld==i_soilt1 .or. ifld ==i_tslb) & - i_snowT_check=1 + if(ifld==i_tsk) i_snowT_check=1 + if(ifld==i_soilt1) i_snowT_check=4 + if(ifld==i_tslb) i_snowT_check=3 if(ifld >=i_smois .and. ifld <=i_smois+ksize-1) i_snowT_check=2 call unfill_mass_grid2t_ldmk(tempa(1,ifld),im,jm,temp1,landmask, & - snow,seaice,i_snowT_check) + snow,seaice,t1st2d,i_snowT_check) + ! make sure soil moisture is larger than soilmoistmin (whih is 0.002 (sand)). + if(ifld >=i_smois .and. ifld <=i_smois+ksize-1) then + do i=1,im + do j=1,jm + temp1(i,j) = max(temp1(i,j),soilmoistmin) + end do + end do + endif else call unfill_mass_grid2t(tempa(1,ifld),im,jm,temp1) endif @@ -1216,7 +1228,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) endif ! write hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ! write qc if(kord(i_qc)/=1) then allocate(jbuf(im,lm,jbegin(mype):min(jend(mype),jm))) @@ -1352,7 +1364,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) deallocate(jbuf) end if - end if ! l_cloud_analysis + end if ! l_hydrometeor_bkio !---------------------- write surface files last do k=kbegin(mype),kend(mype) if(kdim(k)==1.or.kord(k)==1) then @@ -1377,6 +1389,7 @@ subroutine wrwrfmassa_binary_wrf(this,mype) deallocate(landmask) deallocate(snow) deallocate(seaice) + deallocate(t1st2d) deallocate(tempa) deallocate(tempb) deallocate(temp1) @@ -1808,21 +1821,24 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) !$$$ use kinds, only: r_kind,r_single,i_kind use guess_grids, only: ntguessfc,ntguessig,ifilesig,dsfct,& - ges_tsen + ges_tsen, ges_w_btlev use wrf_mass_guess_mod, only: ges_tten use mpimod, only: mpi_comm_world,ierror,mpi_real4 use gridmod, only: pt_ll,eta1_ll,lat2,iglobal,itotsub,update_regsfc,& lon2,nsig,nsig_soil,lon1,lat1,nlon_regional,nlat_regional,ijn,displs_g,& aeta1_ll,strip,eta2_ll,aeta2_ll use constants, only: one,zero_single,rd_over_cp_mass,one_tenth,r10,r100 + use constants, only: soilmoistmin use gsi_io, only: lendian_in, lendian_out - use rapidrefresh_cldsurf_mod, only: l_cloud_analysis,l_gsd_soilTQ_nudge,& + use rapidrefresh_cldsurf_mod, only: l_hydrometeor_bkio,l_gsd_soilTQ_nudge,& i_use_2mq4b,i_use_2mt4b use chemmod, only: laeroana_gocart,wrf_pm2_5 use gsi_bundlemod, only: GSI_BundleGetPointer use gsi_metguess_mod, only: gsi_metguess_get,GSI_MetGuess_Bundle use gsi_chemguess_mod, only: GSI_ChemGuess_Bundle, gsi_chemguess_get use mpeu_util, only: die + use wrf_vars_mod, only : w_exist, dbz_exist + use obsmod,only: if_model_dbz implicit none ! Declare passed variables @@ -1838,11 +1854,11 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) real(r_single),allocatable::temp1(:),temp1u(:),temp1v(:),tempa(:),tempb(:) real(r_single),allocatable::all_loc(:,:,:) real(r_single),allocatable::strp(:) - real(r_single),allocatable::landmask(:),snow(:),seaice(:) + real(r_single),allocatable::landmask(:),snow(:),seaice(:),t1st2d(:),pt2t(:) character(6) filename - integer(i_kind) i,j,k,kt,kq,ku,kv,it,i_psfc,i_t,i_q,i_u,i_v + integer(i_kind) i,j,k,kt,kq,ku,kv,it,i_psfc,i_t,i_q,i_u,i_v,i_w,i_dbz integer(i_kind) i_qc,i_qi,i_qr,i_qs,i_qg,i_qnr,i_qni,i_qnc - integer(i_kind) kqc,kqi,kqr,kqs,kqg,kqnr,kqni,kqnc,i_tt,ktt + integer(i_kind) kqc,kqi,kqr,kqs,kqg,kqnr,kqni,kqnc,i_tt,ktt,kw,kdbz integer(i_kind) i_sst,i_skt,i_th2,i_q2,i_soilt1,i_tslb,i_smois,ktslb,ksmois integer(i_kind) :: iv, n_gocart_var,i_snowT_check integer(i_kind),allocatable :: i_chem(:), kchem(:) @@ -1867,6 +1883,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) real(r_kind), pointer :: ges_smois_it(:,:,:)=>NULL() real(r_kind), pointer :: ges_u (:,:,:)=>NULL() real(r_kind), pointer :: ges_v (:,:,:)=>NULL() + real(r_kind), pointer :: ges_w (:,:,:)=>NULL() real(r_kind), pointer :: ges_q (:,:,:)=>NULL() real(r_kind), pointer :: ges_qc(:,:,:)=>NULL() real(r_kind), pointer :: ges_qi(:,:,:)=>NULL() @@ -1876,6 +1893,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) real(r_kind), pointer :: ges_qnr(:,:,:)=>NULL() real(r_kind), pointer :: ges_qni(:,:,:)=>NULL() real(r_kind), pointer :: ges_qnc(:,:,:)=>NULL() + real(r_kind), pointer :: ges_dbz(:,:,:)=>NULL() real(r_kind), pointer :: ges_sulf (:,:,:)=>NULL() real(r_kind), pointer :: ges_bc1 (:,:,:)=>NULL() @@ -1921,7 +1939,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) num_mass_fields_base=2+4*lm + 1 num_mass_fields=num_mass_fields_base ! The 9 3D cloud analysis fields are: ql,qi,qr,qs,qg,qnr,qni,qnc,tt - if(l_cloud_analysis .and. n_actual_clouds>0) num_mass_fields=num_mass_fields + 9*lm + if(l_hydrometeor_bkio .and. n_actual_clouds>0) num_mass_fields=num_mass_fields + 9*lm if(l_gsd_soilTQ_nudge) num_mass_fields=num_mass_fields+2*nsig_soil+1 if(i_use_2mt4b > 0 ) num_mass_fields=num_mass_fields+2 if(i_use_2mt4b <= 0 .and. i_use_2mq4b > 0) num_mass_fields=num_mass_fields+1 @@ -1941,6 +1959,9 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) allocate(i_chem(1)) allocate(kchem(1)) endif + + if(w_exist) num_mass_fields = num_mass_fields +lm+1 + if(dbz_exist.and.if_model_dbz) num_mass_fields = num_mass_fields +lm num_all_fields=num_mass_fields @@ -1953,7 +1974,12 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) i_q=i_t+lm i_u=i_q+lm i_v=i_u+lm - i_sst=i_v+lm + if(w_exist)then + i_w=i_v+lm + i_sst=i_w+lm+1 + else + i_sst=i_v+lm + endif if(i_use_2mt4b > 0) then i_th2=i_sst+1 else @@ -1977,7 +2003,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) endif ! for hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then i_qc=i_q2+1 i_qr=i_qc+lm i_qs=i_qr+lm @@ -1986,7 +2012,12 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) i_qnr=i_qg+lm i_qni=i_qnr+lm i_qnc=i_qni+lm - i_tt=i_qnc+lm + if(dbz_exist.and.if_model_dbz)then + i_dbz=i_qnc+lm + i_tt=i_dbz+lm + else + i_tt=i_qnc+lm + end if if ( laeroana_gocart ) then do iv = 1, n_gocart_var i_chem(iv)=i_tt+(iv-1)*lm+1 @@ -2014,7 +2045,10 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) endif allocate(temp1(im*jm),temp1u((im+1)*jm),temp1v(im*(jm+1))) - allocate(landmask(im*jm),snow(im*jm),seaice(im*jm)) + if(mype==0) then + allocate(landmask(im*jm),snow(im*jm),seaice(im*jm)) + allocate(t1st2d(im*jm),pt2t(im*jm)) + endif if(mype == 0) write(6,*)' at 2 in wrwrfmassa' @@ -2038,9 +2072,11 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnr',ges_qnr,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qni',ges_qni,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnc',ges_qnc,istatus );ier=ier+istatus + if(dbz_exist) & + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz',ges_dbz,istatus );ier=ier+istatus if (ier/=0) then write(6,*)'READ_WRF_MASS_BINARY_GUESS: getpointer failed, cannot do cloud analysis' - if (l_cloud_analysis .and. n_actual_clouds>0) call stop2(999) + if (l_hydrometeor_bkio .and. n_actual_clouds>0) call stop2(999) endif endif @@ -2048,6 +2084,9 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ps', ges_ps, istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u' , ges_u , istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v' , ges_v , istatus );ier=ier+istatus + if(w_exist)then + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'w' , ges_w , istatus );ier=ier+istatus + endif call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' , ges_q , istatus );ier=ier+istatus if (ier/=0) then ! doesn't have to die - code can be generalized to bypass missing vars write(6,*)'wrwrfmassa_binary: getpointer failed, cannot retrieve ps,u,v,q' @@ -2061,8 +2100,9 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) kq=i_q-1 ku=i_u-1 kv=i_v-1 + if(w_exist)kw=i_w-1 ! for hydrometeors - if(l_cloud_analysis .or. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then kqc=i_qc-1 kqi=i_qi-1 kqr=i_qr-1 @@ -2071,6 +2111,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) kqnr=i_qnr-1 kqni=i_qni-1 kqnc=i_qnc-1 + if(dbz_exist.and.if_model_dbz)kdbz=i_dbz-1 ktt=i_tt-1 endif if ( laeroana_gocart ) then @@ -2120,7 +2161,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) ku=ku+1 kv=kv+1 ! for hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then kqc=kqc+1 kqi=kqi+1 kqr=kqr+1 @@ -2129,6 +2170,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) kqnr=kqnr+1 kqni=kqni+1 kqnc=kqnc+1 + if(dbz_exist.and.if_model_dbz)kdbz=kdbz+1 ktt=ktt+1 endif if ( laeroana_gocart ) then @@ -2157,7 +2199,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) all_loc(j,i,kq)= ges_q(j,i,k)/(one-ges_q(j,i,k)) ! for hydrometeors - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then all_loc(j,i,kqc)=ges_qc(j,i,k) all_loc(j,i,kqi)=ges_qi(j,i,k) all_loc(j,i,kqr)=ges_qr(j,i,k) @@ -2166,6 +2208,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) all_loc(j,i,kqnr)=ges_qnr(j,i,k) all_loc(j,i,kqni)=ges_qni(j,i,k) all_loc(j,i,kqnc)=ges_qnc(j,i,k) + if(dbz_exist.and.if_model_dbz)all_loc(j,i,kdbz)=ges_dbz(j,i,k) all_loc(j,i,ktt)=ges_tten(j,i,k,it) endif @@ -2199,6 +2242,33 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) end do end do end do + + if(w_exist) then + kw=kw+1 + do i=1,lon2 + do j=1,lat2 + all_loc(j,i,kw)=ges_w_btlev(j,i,1,it) ! for w on the bottom not changed + enddo + enddo + + do k=1,nsig-1 + kw=kw+1 + do i=1,lon2 + do j=1,lat2 + all_loc(j,i,kw)=0.5*(ges_w(j,i,k)+ges_w(j,i,k+1)) + enddo + enddo + enddo + + kw=kw+1 + do i=1,lon2 + do j=1,lat2 + all_loc(j,i,kw)=ges_w_btlev(j,i,2,it) ! for w on the top not changed + enddo + enddo + endif + + do i=1,lon2 do j=1,lat2 psfc_this=r10*ges_ps(j,i) ! convert from cb to mb @@ -2235,6 +2305,10 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) end do call unfill_mass_grid2t(tempa,im,jm,temp1) write(lendian_out)temp1 + do i=1,im*jm + work_prsl = one_tenth*(aeta1_ll(1)*(temp1(i)/r100-pt_ll)+aeta2_ll(1)+pt_ll) + pt2t(i) = (work_prsl/r100)**rd_over_cp_mass + enddo end if ! FIS read/write @@ -2258,6 +2332,12 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) end do call unfill_mass_grid2t(tempa,im,jm,temp1) write(lendian_out)temp1 + if(k==1) then + do i=1,im*jm + t1st2d(i)=temp1(i)*pt2t(i) ! convert potential to sensible T + end do + pt2t=t1st2d ! save a copy + endif end if end do @@ -2314,6 +2394,27 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) write(lendian_out)temp1v end if end do + + if(w_exist) then + ! Update w + kw=i_w-1 + do k=1,nsig+1 + kw=kw+1 + if(mype == 0) read(lendian_in)temp1 + call strip(all_loc(:,:,kw),strp) + call mpi_gatherv(strp,ijn(mype+1),mpi_real4, & + tempa,ijn,displs_g,mpi_real4,0,mpi_comm_world,ierror) + if(mype == 0) then + call fill_mass_grid2t(temp1,im,jm,tempb,2) + do i=1,iglobal + tempa(i)=tempa(i)-tempb(i) + end do + call unfill_mass_grid2t(tempa,im,jm,temp1) + write(lendian_out)temp1 + end if + end do + endif ! for w_exist + ! Load updated skin temperature array if writing out to analysis file if (update_regsfc) then @@ -2456,7 +2557,11 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) end do i_snowT_check=2 call unfill_mass_grid2t_ldmk(tempa,im,jm,temp1,landmask,& - snow,seaice,i_snowT_check) + snow,seaice,t1st2d,i_snowT_check) + ! make sure soil moisture is larger than soilmoistmin (0.002 (sand)). + do i=1,im*jm + temp1(i) = max(temp1(i),soilmoistmin) + enddo write(lendian_out)temp1 end if end do @@ -2473,10 +2578,10 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) do i=1,iglobal tempa(i)=tempa(i)-tempb(i) end do - i_snowT_check=0 - if(k==1) i_snowT_check=1 + i_snowT_check=3 + if(k==1) t1st2d=temp1-t1st2d call unfill_mass_grid2t_ldmk(tempa,im,jm,temp1,landmask, & - snow,seaice,i_snowT_check) + snow,seaice,t1st2d,i_snowT_check) write(lendian_out)temp1 end if end do @@ -2507,8 +2612,9 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) end if end do i_snowT_check=1 + t1st2d=temp1-pt2t call unfill_mass_grid2t_ldmk(tempa,im,jm,temp1,landmask, & - snow,seaice,i_snowT_check) + snow,seaice,t1st2d,i_snowT_check) write(lendian_out)temp1 end if else @@ -2558,9 +2664,9 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) tempa(i)=tempa(i)-tempb(i) end do write(6,*)' at 10.3 in wrwrfmassa,max,min(tempa)=',maxval(tempa),minval(tempa) - i_snowT_check=1 + i_snowT_check=4 call unfill_mass_grid2t_ldmk(tempa,im,jm,temp1,landmask, & - snow,seaice,i_snowT_check) + snow,seaice,t1st2d,i_snowT_check) write(6,*)' at 10.4 in wrwrfmassa,max,min(temp1)=',maxval(temp1),minval(temp1) write(lendian_out)temp1 end if !endif mype==0 @@ -2590,7 +2696,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) endif ! i_use_2mt4b>0 ! ! for saving cloud analysis results - if(l_cloud_analysis .and. n_actual_clouds>0) then + if(l_hydrometeor_bkio .and. n_actual_clouds>0) then ! Update qc kqc=i_qc-1 do k=1,nsig @@ -2735,6 +2841,26 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) end if end do + if(dbz_exist.and.if_model_dbz)then + ! Update refl_10cm + kdbz=i_dbz-1 + do k=1,nsig + kdbz=kdbz+1 + if(mype == 0) read(lendian_in)temp1 + call strip(all_loc(:,:,kdbz),strp) + call mpi_gatherv(strp,ijn(mype+1),mpi_real4, & + tempa,ijn,displs_g,mpi_real4,0,mpi_comm_world,ierror) + if(mype == 0) then + call fill_mass_grid2t(temp1,im,jm,tempb,2) + do i=1,iglobal + tempa(i)=tempa(i)-tempb(i) + end do + call unfill_mass_grid2t(tempa,im,jm,temp1) + write(lendian_out)temp1 + end if + end do + end if + ! Update tten ktt=i_tt-1 do k=1,nsig @@ -2753,7 +2879,7 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) end if end do - endif ! l_cloud_analysis + endif ! l_hydrometeor_bkio if ( laeroana_gocart ) then do iv = 1, n_gocart_var @@ -2814,9 +2940,13 @@ subroutine wrwrfmassa_netcdf_wrf(this,mype) deallocate(temp1v) deallocate(tempa) deallocate(tempb) - deallocate(landmask) - deallocate(snow) - deallocate(seaice) + if(mype==0) then + deallocate(landmask) + deallocate(snow) + deallocate(seaice) + deallocate(t1st2d) + deallocate(pt2t) + endif end subroutine wrwrfmassa_netcdf_wrf diff --git a/src/cplr_wrwrfnmma.f90 b/src/gsi/cplr_wrwrfnmma.f90 similarity index 95% rename from src/cplr_wrwrfnmma.f90 rename to src/gsi/cplr_wrwrfnmma.f90 index 911ef55bd..2497efca3 100644 --- a/src/cplr_wrwrfnmma.f90 +++ b/src/gsi/cplr_wrwrfnmma.f90 @@ -1096,6 +1096,9 @@ subroutine wrnemsnmma_binary(this,mype) ! 2016-03-02 s.liu/carley - remove use_reflectivity and use i_gsdcldanal_type ! 2016-06-23 lippi - add read of vertical velocity (w). ! 2016-06-30 s.liu - remove gridtype, add_saved in write_fraction + ! 2017-05-12 Y. Wang and X. Wang - add write of hydrometeor-related + ! variables (f_rain, f_ice, clwmr and refl_10cm) and W for radar DA, + ! POC: xuguang.wang@ou.edu ! ! input argument list: ! mype - pe number @@ -1126,7 +1129,9 @@ subroutine wrnemsnmma_binary(this,mype) use gfs_stratosphere, only: revert_to_nmmb,restore_nmmb_gfs use mpimod, only: mpi_comm_world,ierror,mpi_rtype,mpi_integer4,mpi_min,mpi_max,mpi_sum use gsi_4dvar, only: nhr_assimilation - use gsi_nemsio_mod, only: gsi_nemsio_update,gsi_nemsio_write_fraction + use gsi_nemsio_mod, only: gsi_nemsio_update,gsi_nemsio_write_fraction,gsi_nemsio_write_fractionnew + use wrf_vars_mod, only : dbz_exist + use obsmod,only: if_model_dbz implicit none ! Declare passed variables @@ -1140,10 +1145,10 @@ subroutine wrnemsnmma_binary(this,mype) integer(i_kind) i,it,j,k,kr,mype_input,nsig_write integer(i_kind) near_sfc,kp - integer(i_kind) icw4crtm,iqtotal + integer(i_kind) icw4crtm,iqtotal,i_radar_qr,i_radar_qli real(r_kind) pd,psfc_this,pd_to_ps,wmag real(r_kind),dimension(lat2,lon2):: work_sub,pd_new,delu10,delv10,u10this,v10this,fact10_local - real(r_kind),dimension(lat2,lon2):: work_sub_t,work_sub_i,work_sub_r,work_sub_l + real(r_kind),dimension(lat2,lon2):: work_sub_t,work_sub_i,work_sub_r,work_sub_l, work_sub_s real(r_kind),dimension(lat2,lon2):: delt2,delq2,t2this,q2this,fact2t_local,fact2q_local real(r_kind),dimension(lat2,lon2,6):: delu,delv,delw,delt,delq,pott real(r_kind) hmin,hmax,hmin0,hmax0,ten,wgt1,wgt2 @@ -1170,6 +1175,9 @@ subroutine wrnemsnmma_binary(this,mype) real(r_kind),pointer,dimension(:,:,:):: ges_qh =>NULL() real(r_kind),pointer,dimension(:,:,:):: dfi_tten=>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_ref =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_dw =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qli =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_dbz =>NULL() ! if use_gfs_stratosphere is true, then convert ges fields from nmmb-gfs ! extended vertical coordinate to nmmb vertical coordinate. @@ -1218,6 +1226,8 @@ subroutine wrnemsnmma_binary(this,mype) it=ntguessig mype_input=0 add_saved=.true. + i_radar_qr = 0 + i_radar_qli = 0 call gsi_metguess_get('clouds::3d',n_actual_clouds,iret) if(mype == 0) write(6,*)' in wrnemsnmma_binary after gsi_metguess_get, nclouds,iret=',& @@ -1229,6 +1239,10 @@ subroutine wrnemsnmma_binary(this,mype) ! Determine whether or not total moisture (water vapor+total cloud condensate) is the control variable iqtotal=getindex(cvars3d,'qt') + + ! Determine if qr and qli are control variables for radar data assimilation, + i_radar_qr=getindex(cvars3d,'qr') + i_radar_qli=getindex(cvars3d,'qli') ! Get pointer to cloud water mixing ratio call gsi_bundlegetpointer (gsi_metguess_bundle(it),'cw',ges_cw,iret); ier_cloud=iret @@ -1240,6 +1254,19 @@ subroutine wrnemsnmma_binary(this,mype) call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qh',ges_qh,iret); ier_cloud=ier_cloud+iret if ((icw4crtm<=0 .and. iqtotal<=0) .or. ier_cloud/=0) n_actual_clouds=0 + + if (i_radar_qr>0 .and. i_radar_qli>0) then + ! Get pointer to cloud water mixing ratio + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'ql',ges_ql,iret); ier_cloud=iret + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qi',ges_qi,iret); ier_cloud=iret + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qr',ges_qr,iret); ier_cloud=ier_cloud+iret + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qli',ges_qli,iret); ier_cloud=ier_cloud+iret + if(dbz_exist)& + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'dbz',ges_dbz,iret); ier_cloud=ier_cloud+iret + if (ier_cloud/=0) n_actual_clouds=0 + else + n_actual_clouds=0 + end if else if (i_gsdcldanal_type==2)then @@ -1308,8 +1335,6 @@ subroutine wrnemsnmma_binary(this,mype) end if call gsi_nemsio_write('vgrd','mid layer','V',kr,work_sub(:,:),mype,mype_input,add_saved) endif - - ! w call gsi_bundlegetpointer (gsi_metguess_bundle(it),'w',ges_w,iret) if (iret==0) then @@ -1328,8 +1353,25 @@ subroutine wrnemsnmma_binary(this,mype) end if call gsi_nemsio_write('w_tot','mid layer','H',kr,work_sub(:,:),mype,mype_input,add_saved) endif - + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'dwdt',ges_dw,iret) + if (iret==0) then + call gsi_nemsio_read('dwdt','mid layer','H',kr,work_sub(:,:),mype,mype_input) + do i=1,lon2 + do j=1,lat2 + work_sub(j,i)=ges_dw(j,i,k)-work_sub(j,i) + end do + end do + if(k <= near_sfc) then + do i=1,lon2 + do j=1,lat2 + delv(j,i,k)=work_sub(j,i) + end do + end do + end if + call gsi_nemsio_write('dwdt','mid layer','H',kr,work_sub(:,:),mype,mype_input,add_saved) + endif + ! q call gsi_bundlegetpointer (gsi_metguess_bundle(it),'q',ges_q,iret) @@ -1347,6 +1389,10 @@ subroutine wrnemsnmma_binary(this,mype) end do end do end if + where( ges_q < zero ) + ges_q = zero + end where + work_sub(:,:)=ges_q(:,:,k) call gsi_nemsio_write('spfh','mid layer','H',kr,work_sub(:,:),mype,mype_input,add_saved) endif @@ -1427,7 +1473,7 @@ subroutine wrnemsnmma_binary(this,mype) end if ! cloud - if (n_actual_clouds>0 .and. (i_gsdcldanal_type/=2)) then + if (n_actual_clouds>0 .and. (i_gsdcldanal_type/=2) .and. i_radar_qli <= 0) then call gsi_nemsio_read('clwmr','mid layer','H',kr,work_sub(:,:),mype,mype_input) if (cold_start) then do i=1,lon2 @@ -1471,6 +1517,44 @@ subroutine wrnemsnmma_binary(this,mype) call gsi_nemsio_read('f_rimef','mid layer','H',kr,work_sub(:,:),mype,mype_input) call gsi_nemsio_write('f_rimef','mid layer','H',kr,work_sub(:,:),mype,mype_input,.false.) end if ! end of non-coldstart + + if (i_radar_qr>0 .and. i_radar_qli>0)then + + if( dbz_exist .and. if_model_dbz )then + ! refl_10cm + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'dbz',ges_dbz,iret) + if (iret==0) then + where( ges_dbz < zero ) + ges_dbz = zero + end where + work_sub(:,:)=ges_dbz(:,:,k) + call gsi_nemsio_write('refl_10cm','mid layer','H',kr,work_sub(:,:),mype,mype_input,.false.) + endif + end if + + do i=1,lon2 + do j=1,lat2 + work_sub_s(j,i)=ges_qli(j,i,k) + work_sub_r(j,i)=ges_qr(j,i,k) + work_sub_l(j,i)=ges_ql(j,i,k) + work_sub_i(j,i)=ges_qi(j,i,k) + end do + end do + + add_saved=.false. + call gsi_nemsio_write_fractionnew('f_rain','f_ice','f_rimef','mid layer',kr, & + work_sub_s(:,:),work_sub_i(:,:),work_sub_r(:,:),work_sub_l(:,:),mype,mype_input) + ges_qg=ges_ql+ges_qr+ges_qli + + do i=1,lon2 + do j=1,lat2 + work_sub(j,i)=ges_qg(j,i,k) + end do + end do + call gsi_nemsio_write('clwmr','mid layer','H',kr,work_sub(:,:),mype,mype_input,add_saved) + + end if + end if ! end of nguess end do @@ -2299,16 +2383,23 @@ subroutine wrwrfnmma_netcdf_wrf(this,mype) kcwm=i_cwm-1 do k=1,nsig_write kcwm=kcwm+1 - if(mype == 0) temp1=zero ! no read-in of guess fields + if(mype == 0) read(lendian_in)temp1 + if(mype == 0) write(6,*)' k,max,min(temp1) CWM in =',k,maxval(temp1),minval(temp1) call strip(all_loc(:,:,kcwm),strp) call mpi_gatherv(strp,ijn(mype+1),mpi_real4, & tempa,ijn,displs_g,mpi_real4,0,mpi_comm_world,ierror) if(mype == 0) then call this%get_bndy_file(temp1,pdbg,tbg,qbg,cwmbg,ubg,vbg,kcwm,i_pd,i_t,i_q,i_cwm,i_u,i_v, & n_actual_clouds,im,jm,lm,bdim,igtypeh) + if(filled_grid) call fill_nmm_grid2(temp1,im,jm,tempb,igtypeh,2) + if(half_grid) call half_nmm_grid2(temp1,im,jm,tempb,igtypeh,2) + do i=1,iglobal + tempa(i)=tempa(i)-tempb(i) + end do if(filled_grid) call unfill_nmm_grid2(tempa,im,jm,temp1,igtypeh,2) if(half_grid) call unhalf_nmm_grid2(tempa,im,jm,temp1,igtypeh,2) write(lendian_out)temp1 + write(6,*)' k,max,min(temp1) CWM out =',k,maxval(temp1),minval(temp1) call this%get_bndy_file(temp1,pdba,tba,qba,cwmba,uba,vba,kcwm,i_pd,i_t,i_q,i_cwm,i_u,i_v, & n_actual_clouds,im,jm,lm,bdim,igtypeh) end if @@ -2318,14 +2409,21 @@ subroutine wrwrfnmma_netcdf_wrf(this,mype) kf_ice=i_f_ice-1 do k=1,nsig_write kf_ice=kf_ice+1 - if(mype == 0) temp1=zero ! no read-in of guess fields + if(mype == 0) read(lendian_in)temp1 + if(mype == 0) write(6,*)' k,max,min(temp1) F_ICE in =',k,maxval(temp1),minval(temp1) call strip(all_loc(:,:,kf_ice),strp) call mpi_gatherv(strp,ijn(mype+1),mpi_real4, & tempa,ijn,displs_g,mpi_real4,0,mpi_comm_world,ierror) if(mype == 0) then + if(filled_grid) call fill_nmm_grid2(temp1,im,jm,tempb,igtypeh,2) + if(half_grid) call half_nmm_grid2(temp1,im,jm,tempb,igtypeh,2) + do i=1,iglobal + tempa(i)=tempa(i)-tempb(i) + end do if(filled_grid) call unfill_nmm_grid2(tempa,im,jm,temp1,igtypeh,2) if(half_grid) call unhalf_nmm_grid2(tempa,im,jm,temp1,igtypeh,2) write(lendian_out)temp1 + write(6,*)' k,max,min(temp1) F_ICE out =',k,maxval(temp1),minval(temp1) end if end do @@ -2334,13 +2432,21 @@ subroutine wrwrfnmma_netcdf_wrf(this,mype) do k=1,nsig_write kf_rain=kf_rain+1 if(mype == 0) temp1=zero ! no read-in of guess fields + if(mype == 0) read(lendian_in)temp1 + if(mype == 0) write(6,*) ' k,max,min(temp1) F_RAIN in =',k,maxval(temp1),minval(temp1) call strip(all_loc(:,:,kf_rain),strp) call mpi_gatherv(strp,ijn(mype+1),mpi_real4, & tempa,ijn,displs_g,mpi_real4,0,mpi_comm_world,ierror) if(mype == 0) then + if(filled_grid) call fill_nmm_grid2(temp1,im,jm,tempb,igtypeh,2) + if(half_grid) call half_nmm_grid2(temp1,im,jm,tempb,igtypeh,2) + do i=1,iglobal + tempa(i)=tempa(i)-tempb(i) + end do if(filled_grid) call unfill_nmm_grid2(tempa,im,jm,temp1,igtypeh,2) if(half_grid) call unhalf_nmm_grid2(tempa,im,jm,temp1,igtypeh,2) write(lendian_out)temp1 + write(6,*) ' k,max,min(temp1) F_RAIN out =',k,maxval(temp1),minval(temp1) end if end do diff --git a/src/gsi/crtm_interface.f90 b/src/gsi/crtm_interface.f90 new file mode 100644 index 000000000..6a3048e9d --- /dev/null +++ b/src/gsi/crtm_interface.f90 @@ -0,0 +1,3135 @@ +module crtm_interface +!$$$ module documentation block +! . . . +! module: crtm_interface module for setuprad. Calculates profile and calls crtm +! prgmmr: +! +! abstract: crtm_interface module for setuprad. Initializes CRTM, Calculates profile and +! calls CRTM and destroys initialization +! +! program history log: +! 2010-08-17 Derber - initial creation from intrppx +! 2011-05-06 merkova/todling - add use of q-clear calculation for AIRS +! 2011-04-08 li - (1) Add nst_gsi, itref,idtw, idtc, itz_tr to apply NSST. +! - (2) Use Tz instead of Ts as water surface temperature when nst_gsi > 1 +! - (3) add tzbgr as one of the out dummy variable +! - (4) Include tz_tr in ts calculation over water +! - (5) Change minmum temperature of water surface from 270.0 to 271.0 +! 2011-07-04 todling - fixes to run either single or double precision +! 2011-09-20 hclin - modified for modis_aod +! (1) The jacobian of wrfchem/gocart p25 species (not calculated in CRTM) +! is derived from dust1 and dust2 +! (2) skip loading geometry and surface structures for modis_aod +! (3) separate jacobian calculation for modis_aod +! 2012-01-17 sienkiewicz - pass date to crtm for SSU cell pressure +! 2013-02-25 zhu - add cold_start option for regional applications +! 2013-10-19 todling - metguess now holds background +! 2013-11-16 todling - merge in latest DTC AOD development; +! revisit handling of green-house-gases +! 2014-01-01 li - change the protection of data_s(itz_tr) +! 2014-02-26 zhu - add non zero jacobian +! 2014-04-27 eliu - add call crtm_forward to calculate clear-sky Tb under all-sky condition +! 2015-09-10 zhu - generalize enabling all-sky and using aerosol (radiance_mod & radmod) in radiance +! assimilation. use n_clouds_jac,cloud_names_jac,n_aerosols_jac,aerosol_names_jac, +! n_clouds_fwd,cloud_names_fwd, etc for difference sensors and channels +! - add handling of mixed_use of channels in a sensor (some are clear-sky, others all-sky) +! 2016-06-03 collard - Added changes to allow for historical naming conventions +! 2017-02-24 zhu/todling - remove gmao cloud fraction treatment +! 2018-01-12 collard - Force all satellite and solar zenith angles to be >= 0. +! 2019-03-13 eliu - add precipitation component +! 2019-03-13 eliu - add quality control to identify areas with cold-air outbreak +! 2019-03-13 eliu - add calculation of GFDL cloud fraction +! 2019-03-22 Wei/Martin - Added VIIRS AOD capability alongside MODIS AOD +! +! +! subroutines included: +! sub init_crtm +! sub call_crtm +! sub destroy_crtm +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds,only: r_kind,i_kind,r_single +use crtm_module, only: crtm_atmosphere_type,crtm_surface_type,crtm_geometry_type, & + crtm_options_type,crtm_rtsolution_type,crtm_destroy,crtm_options_destroy, & + crtm_options_create,crtm_options_associated,success,crtm_atmosphere_create, & + crtm_surface_create,crtm_k_matrix,crtm_forward, & + ssu_input_setvalue, & + crtm_channelinfo_type, & + crtm_surface_destroy, crtm_surface_associated, crtm_surface_zero, & + crtm_atmosphere_associated, & + crtm_atmosphere_destroy,crtm_atmosphere_zero, & + crtm_rtsolution_type, crtm_rtsolution_create, & + crtm_rtsolution_destroy, crtm_rtsolution_associated, & + crtm_irlandcoeff_classification, & + crtm_kind => fp, & + crtm_microwave_sensor => microwave_sensor +use gridmod, only: lat2,lon2,nsig,msig,nvege_type,regional,wrf_mass_regional,netcdf,use_gfs_ozone +use mpeu_util, only: die +use crtm_aod_module, only: crtm_aod_k +use radiance_mod, only: n_actual_clouds,cloud_names,n_clouds_fwd,cloud_names_fwd, & + n_clouds_jac,cloud_names_jac,n_actual_aerosols,aerosol_names,n_aerosols_fwd,aerosol_names_fwd, & + n_aerosols_jac,aerosol_names_jac,rad_obs_type,cw_cv,ql_cv +use control_vectors, only: lcalc_gfdl_cfrac +use ncepnems_io, only: imp_physics + +implicit none + +private +public init_crtm ! Subroutine initializes crtm for specified instrument +public call_crtm ! Subroutine creates profile for crtm, calls crtm, then adjoint of create +public destroy_crtm ! Subroutine destroys initialization for crtm +public sensorindex +public surface +public isatid ! = 1 index of satellite id +public itime ! = 2 index of analysis relative obs time +public ilon ! = 3 index of grid relative obs location (x) +public ilat ! = 4 index of grid relative obs location (y) +public ilzen_ang ! = 5 index of local (satellite) zenith angle (radians) +public ilazi_ang ! = 6 index of local (satellite) azimuth angle (radians) +public iscan_ang ! = 7 index of scan (look) angle (radians) +public iscan_pos ! = 8 index of integer scan position +public iszen_ang ! = 9 index of solar zenith angle (degrees) +public isazi_ang ! = 10 index of solar azimuth angle (degrees) +public ifrac_sea ! = 11 index of ocean percentage +public ifrac_lnd ! = 12 index of land percentage +public ifrac_ice ! = 13 index of ice percentage +public ifrac_sno ! = 14 index of snow percentage +public its_sea ! = 15 index of ocean temperature +public its_lnd ! = 16 index of land temperature +public its_ice ! = 17 index of ice temperature +public its_sno ! = 18 index of snow temperature +public itsavg ! = 19 index of average temperature +public ivty ! = 20 index of vegetation type +public ivfr ! = 21 index of vegetation fraction +public isty ! = 22 index of soil type +public istp ! = 23 index of soil temperature +public ism ! = 24 index of soil moisture +public isn ! = 25 index of snow depth +public izz ! = 26 index of surface height +public idomsfc ! = 27 index of dominate surface type +public isfcr ! = 28 index of surface roughness +public iff10 ! = 29 index of ten meter wind factor +public ilone ! = 30 index of earth relative longitude (degrees) +public ilate ! = 31 index of earth relative latitude (degrees) +public iclr_sky ! = 7 index of clear sky amount (goes_img, seviri, abi) +public isst_navy ! = 7 index of navy sst retrieval (K) (avhrr_navy) +public idata_type ! = 32 index of data type (151=day, 152=night, avhrr_navy) +public iclavr ! = 32 index of clavr cloud flag (avhrr) +public isst_hires ! = 33 index of interpolated hires sst +public itref ! = 34/36 index of Tr +public idtw ! = 35/37 index of d(Tw) +public idtc ! = 36/38 index of d(Tc) +public itz_tr ! = 37/39 index of d(Tz)/d(Tr) + +! For TMI and GMI +public iedge_log ! = 32 ! index, if obs is to be obleted beause of locating near scan edges. +! For GMI 1CR (obstype=='gmi') data channel 10-13. +public ilzen_ang2 ! = 33 index of local (satellite) zenith angle (radians) +public ilazi_ang2 ! = 34 index of local (satellite) azimuth angle (radians) +public iscan_ang2 ! = 35 index of scan (look) angle (radians) +public iszen_ang2 ! = 36 index of solar zenith angle (degrees) +public isazi_ang2 ! = 37 index of solar azimuth angle (degrees) + +! Note other module variables are only used within this routine + + character(len=*), parameter :: myname='crtm_interface' + + ! Indices for the CRTM NPOESS EmisCoeff file + integer(i_kind), parameter :: INVALID_LAND = 0 + integer(i_kind), parameter :: COMPACTED_SOIL = 1 + integer(i_kind), parameter :: TILLED_SOIL = 2 + integer(i_kind), parameter :: IRRIGATED_LOW_VEGETATION = 5 + integer(i_kind), parameter :: MEADOW_GRASS = 6 + integer(i_kind), parameter :: SCRUB = 7 + integer(i_kind), parameter :: BROADLEAF_FOREST = 8 + integer(i_kind), parameter :: PINE_FOREST = 9 + integer(i_kind), parameter :: TUNDRA = 10 + integer(i_kind), parameter :: GRASS_SOIL = 11 + integer(i_kind), parameter :: BROADLEAF_PINE_FOREST = 12 + integer(i_kind), parameter :: GRASS_SCRUB = 13 + integer(i_kind), parameter :: URBAN_CONCRETE = 15 + integer(i_kind), parameter :: BROADLEAF_BRUSH = 17 + integer(i_kind), parameter :: WET_SOIL = 18 + integer(i_kind), parameter :: SCRUB_SOIL = 19 + + real(r_kind) , save ,allocatable,dimension(:,:) :: aero ! aerosol (guess) profiles at obs location + real(r_kind) , save ,allocatable,dimension(:,:) :: aero_conc ! aerosol (guess) concentrations at obs location + real(r_kind) , save ,allocatable,dimension(:) :: auxrh ! temporary array for rh profile as seen by CRTM + + character(len=20),save,allocatable,dimension(:) :: ghg_names ! names of green-house gases + + integer(i_kind), save ,allocatable,dimension(:) :: icloud ! cloud index for those considered here + integer(i_kind), save ,allocatable,dimension(:) :: jcloud ! cloud index for those fed to CRTM + real(r_kind) , save ,allocatable,dimension(:,:) :: cloud ! cloud considered here + real(r_kind) , save ,allocatable,dimension(:,:) :: cloudefr ! effective radius of cloud type in CRTM + real(r_kind) , save ,allocatable,dimension(:,:) :: cloud_cont ! cloud content fed into CRTM + real(r_kind) , save ,allocatable,dimension(:,:) :: cloud_efr ! effective radius of cloud type in CRTM + real(r_kind) , save ,allocatable,dimension(:) :: cf ! effective radius of cloud type in CRTM + real(r_kind) , save ,allocatable,dimension(:) :: hwp_guess ! column total for each hydrometeor + + real(r_kind) , save ,allocatable,dimension(:,:,:,:) :: gesqsat ! qsat to calc rh for aero particle size estimate + real(r_kind) , save ,allocatable,dimension(:) :: table,table2,tablew ! GFDL saturation water vapor pressure tables + real(r_kind) , save ,allocatable,dimension(:) :: des2,desw ! GFDL saturation water vapor presure + real(r_kind) , save ,allocatable,dimension(:) :: lcloud4crtm_wk ! cloud info usage index for each channel + + integer(i_kind),save, allocatable,dimension(:) :: map_to_crtm_ir + integer(i_kind),save, allocatable,dimension(:) :: map_to_crtm_mwave + integer(i_kind),save, allocatable,dimension(:) :: icw + integer(i_kind),save, allocatable,dimension(:) :: iaero_jac + integer(i_kind),save :: isatid,itime,ilon,ilat,ilzen_ang,ilazi_ang,iscan_ang + integer(i_kind),save :: iscan_pos,iszen_ang,isazi_ang,ifrac_sea,ifrac_lnd,ifrac_ice + integer(i_kind),save :: ifrac_sno,its_sea,its_lnd,its_ice,its_sno,itsavg + integer(i_kind),save :: ivty,ivfr,isty,istp,ism,isn,izz,idomsfc,isfcr,iff10,ilone,ilate + integer(i_kind),save :: iclr_sky,isst_navy,idata_type,isst_hires,iclavr + integer(i_kind),save :: itref,idtw,idtc,itz_tr,istype + integer(i_kind),save :: sensorindex + integer(i_kind),save :: ico2,ico24crtm + integer(i_kind),save :: n_actual_aerosols_wk ! number of aerosols considered + integer(i_kind),save :: n_aerosols_fwd_wk ! number of aerosols considered + integer(i_kind),save :: n_aerosols_jac_wk ! number of aerosols considered + integer(i_kind),save :: n_actual_clouds_wk ! number of clouds considered + integer(i_kind),save :: n_clouds_fwd_wk ! number of clouds considered + integer(i_kind),save :: n_clouds_jac_wk ! number of clouds considered + integer(i_kind),save :: n_ghg ! number of green-house gases + integer(i_kind),save :: itv,iqv,ioz,ius,ivs,isst + integer(i_kind),save :: indx_p25, indx_dust1, indx_dust2 + logical ,save :: lwind + logical ,save :: cld_sea_only_wk + logical ,save :: lprecip_wk + logical ,save :: mixed_use + integer(i_kind), parameter :: min_n_absorbers = 2 + + integer(i_kind),save :: iedge_log + integer(i_kind),save :: ilzen_ang2,ilazi_ang2,iscan_ang2,iszen_ang2,isazi_ang2 + + type(crtm_atmosphere_type),save,dimension(1) :: atmosphere + type(crtm_surface_type),save,dimension(1) :: surface + type(crtm_geometry_type),save,dimension(1) :: geometryinfo + type(crtm_options_type),save,dimension(1) :: options + type(crtm_channelinfo_type),save,dimension(1) :: channelinfo + + + type(crtm_atmosphere_type),save,allocatable,dimension(:,:):: atmosphere_k + type(crtm_atmosphere_type),save,allocatable,dimension(:,:):: atmosphere_k_clr + type(crtm_surface_type),save,allocatable,dimension(:,:):: surface_k + type(crtm_surface_type),save,allocatable,dimension(:,:):: surface_k_clr + type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution + type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution0 + type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution_clr + type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution_k + type(crtm_rtsolution_type),save,allocatable,dimension(:,:):: rtsolution_k_clr + +! Mapping land surface type of GFS to CRTM +! Notes: index 0 is water, and index 13 is ice. The two indices are not +! used and just assigned to COMPACTED_SOIL. Also, since there +! is currently one relevant mapping for the global we apply +! 'crtm' in the naming convention. + integer(i_kind), parameter, dimension(0:13) :: gfs_to_crtm=(/COMPACTED_SOIL, & + BROADLEAF_FOREST, BROADLEAF_FOREST, BROADLEAF_PINE_FOREST, PINE_FOREST, & + PINE_FOREST, BROADLEAF_BRUSH, SCRUB, SCRUB, SCRUB_SOIL, TUNDRA, & + COMPACTED_SOIL, TILLED_SOIL, COMPACTED_SOIL/) +! Mapping surface classification to CRTM + integer(i_kind), parameter :: USGS_N_TYPES = 24 + integer(i_kind), parameter :: IGBP_N_TYPES = 20 + integer(i_kind), parameter :: GFS_N_TYPES = 13 + integer(i_kind), parameter :: SOIL_N_TYPES = 16 + integer(i_kind), parameter :: GFS_SOIL_N_TYPES = 9 + integer(i_kind), parameter :: GFS_VEGETATION_N_TYPES = 13 + integer(i_kind), parameter, dimension(1:USGS_N_TYPES) :: usgs_to_npoess=(/URBAN_CONCRETE, & + COMPACTED_SOIL, IRRIGATED_LOW_VEGETATION, GRASS_SOIL, MEADOW_GRASS, & + MEADOW_GRASS, MEADOW_GRASS, SCRUB, GRASS_SCRUB, MEADOW_GRASS, & + BROADLEAF_FOREST, PINE_FOREST, BROADLEAF_FOREST, PINE_FOREST, & + BROADLEAF_PINE_FOREST, INVALID_LAND, WET_SOIL, WET_SOIL, & + IRRIGATED_LOW_VEGETATION, TUNDRA, TUNDRA, TUNDRA, TUNDRA, & + INVALID_LAND/) + integer(i_kind), parameter, dimension(1:IGBP_N_TYPES) :: igbp_to_npoess=(/PINE_FOREST, & + BROADLEAF_FOREST, PINE_FOREST, BROADLEAF_FOREST, BROADLEAF_PINE_FOREST, & + SCRUB, SCRUB_SOIL, BROADLEAF_BRUSH, BROADLEAF_BRUSH, SCRUB, BROADLEAF_BRUSH, & + TILLED_SOIL, URBAN_CONCRETE, TILLED_SOIL, INVALID_LAND, COMPACTED_SOIL, & + INVALID_LAND, TUNDRA, TUNDRA, TUNDRA/) + integer(i_kind), parameter, dimension(1:USGS_N_TYPES) :: usgs_to_usgs=(/1, & + 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, & + 20, 21, 22, 23, 24/) + integer(i_kind), parameter, dimension(1:IGBP_N_TYPES) :: igbp_to_igbp=(/1, & + 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, & + 20/) + integer(i_kind), parameter, dimension(1:IGBP_N_TYPES) :: igbp_to_gfs=(/4, & + 1, 5, 2, 3, 8, 9, 6, 6, 7, 8, 12, 7, 12, 13, 11, 0, 10, 10, 11/) + integer(i_kind), parameter, dimension(1:USGS_N_TYPES) :: usgs_to_gfs=(/7, & + 12, 12, 12, 12, 12, 7, 9, 8, 6, 2, 5, 1, 4, 3, 0, 8, 8, 11, 10, 10, & + 10, 11, 13/) + ! Mapping soil types to CRTM + ! The CRTM soil types for microwave calculations are based on the + ! GFS use of the 9 category Zobler dataset. The regional soil types + ! are based on a 16 category representation of FAO/STATSGO. + integer(i_kind), parameter, dimension(1:SOIL_N_TYPES) :: map_soil_to_crtm=(/1, & + 1, 4, 2, 2, 8, 7, 2, 6, 5, 2, 3, 8, 1, 6, 9/) + +contains +subroutine init_crtm(init_pass,mype_diaghdr,mype,nchanl,nreal,isis,obstype,radmod) +!$$$ subprogram documentation block +! . . . . +! subprogram: init_crtm initializes things for use with call to crtm from setuprad +! +! prgmmr: derber org: np2 date: 2010-08-17 +! +! abstract: initialize things for use with call to crtm from setuprad. +! +! program history log: +! 2010-08-17 derber +! 2011-02-16 todling - add calculation of rh when aerosols are available +! 2011-05-03 todling - merge with Min-Jeong's MW cloudy radiance; combine w/ metguess +! 2011-05-20 mccarty - add atms wmo_sat_id hack (currently commented out) +! 2011-07-20 zhu - modified codes for lcw4crtm +! 2012-03-12 yang - modify to use ch4,n2o,and co +! 2012-12-03 eliu - add logic for RH total +! 2014-01-31 mkim - add flexibility in the variable lcw4crtm for the case when ql and +! qi are separate control variables for all-sky MW radiance DA +! 2014-04-27 eliu - add capability to call CRTM forward model to calculate +! clear-sky Tb under all-sky condition +! 2015-09-20 zhu - use centralized radiance info from radiance_mod: rad_obs_type, +! n_clouds_jac,cloud_names_jac,n_aerosols_jac,aerosol_names_jac,etc +! 2015-09-04 J.Jung - Added mods for CrIS full spectral resolution (FSR) and +! CRTM subset code for CrIS. +! 2019-04-25 H.Liu - Add nreal into the namelist to allow flexible SST variable index assigned +! +! input argument list: +! init_pass - state of "setup" processing +! mype_diaghdr - processor to produce output from crtm +! mype - current processor +! nchanl - number of channels +! isis - instrument/sensor character string +! obstype - observation type +! nreal - number of descriptor information in data_s +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_chemguess_mod, only: gsi_chemguess_bundle ! for now, a common block + use gsi_chemguess_mod, only: gsi_chemguess_get + use gsi_metguess_mod, only: gsi_metguess_bundle ! for now, a common block + use gsi_metguess_mod, only: gsi_metguess_get + use crtm_module, only: mass_mixing_ratio_units,co2_id,o3_id,crtm_init, & + crtm_channelinfo_subset, crtm_channelinfo_n_channels, toa_pressure,max_n_layers, & + volume_mixing_ratio_units,h2o_id,ch4_id,n2o_id,co_id + use radinfo, only: crtm_coeffs_path + use radinfo, only: radjacindxs,radjacnames,jpch_rad,nusis,nuchan + use aeroinfo, only: aerojacindxs + use guess_grids, only: ges_tsen,ges_prsl,nfldsig + use gridmod, only: fv3_full_hydro + use mpeu_util, only: getindex + use constants, only: zero,max_varname_length + use obsmod, only: dval_use + use gsi_io, only: verbose + + implicit none + +! argument + logical ,intent(in) :: init_pass + integer(i_kind),intent(in) :: nchanl,mype_diaghdr,mype,nreal + character(20) ,intent(in) :: isis + character(10) ,intent(in) :: obstype + type(rad_obs_type),intent(in) :: radmod + +! local parameters + character(len=*), parameter :: myname_=myname//'*init_crtm' + integer(i_kind), parameter :: length = 2621 ! lenth of GFL qsat table + +! local variables + integer(i_kind) :: ier,ii,error_status,iderivative + integer(i_kind) :: k, subset_start, subset_end + logical :: ice,Load_AerosolCoeff,Load_CloudCoeff + character(len=20),dimension(1) :: sensorlist + integer(i_kind) :: indx,iii,icloud4crtm +! ...all "additional absorber" variables + integer(i_kind) :: j,icount + integer(i_kind) :: ig + integer(i_kind) :: n_absorbers + logical quiet + logical print_verbose + + + print_verbose=.false. + if(verbose)print_verbose=.true. + isst=-1 + ivs=-1 + ius=-1 + ioz=-1 + iqv=-1 + itv=-1 +! Get indexes of variables composing the jacobian + indx =getindex(radjacnames,'tv') + if(indx>0) itv=radjacindxs(indx) + indx =getindex(radjacnames,'q' ) + if(indx>0) iqv=radjacindxs(indx) + indx =getindex(radjacnames,'oz') + if(indx>0) ioz=radjacindxs(indx) + indx =getindex(radjacnames,'u') + if(indx>0) ius=radjacindxs(indx) + indx =getindex(radjacnames,'v') + if(indx>0) ivs=radjacindxs(indx) + lwind=ius>0.and.ivs>0 + indx=getindex(radjacnames,'sst') + if(indx>0) isst=radjacindxs(indx) + +! Get indexes of variables for cloud jacobians + if (n_clouds_jac>0) then + allocate(icw(max(n_clouds_jac,1))) + icw=-1 + icount=0 + do ii=1,n_clouds_jac + indx=getindex(radjacnames,trim(cloud_names_jac(ii))) + if (indx>0) then + icount=icount+1 + icw(icount)=radjacindxs(indx) + end if + end do + end if + +! Get indexes of variables composing the jacobian_aero + if (n_actual_aerosols > 0) then + indx_p25 = getindex(aerosol_names,'p25') + indx_dust1 = getindex(aerosol_names,'dust1') + indx_dust2 = getindex(aerosol_names,'dust2') + if (n_aerosols_jac >0) then + allocate(iaero_jac(n_aerosols_jac)) + iaero_jac=-1 + icount=0 + do ii=1,n_actual_aerosols + indx=getindex(aerosol_names_jac,trim(aerosol_names(ii))) + if(indx>0) then + icount=icount+1 + iaero_jac(icount)=aerojacindxs(indx) + endif + end do + endif + endif + +! When Cloud is available in MetGuess, defined Cloudy Radiance + mixed_use=.false. + if (radmod%lcloud_fwd) then + allocate(lcloud4crtm_wk(radmod%nchannel)) + lcloud4crtm_wk(:) = radmod%lcloud4crtm(:) + do ii=1,radmod%nchannel + if (lcloud4crtm_wk(ii)<0) then + mixed_use=.true. + exit + end if + end do + + allocate(cloud_cont(msig,n_clouds_fwd)) + allocate(cloud_efr(msig,n_clouds_fwd)) + allocate(jcloud(n_clouds_fwd)) + allocate(cloud(nsig,n_clouds_fwd)) + allocate(cloudefr(nsig,n_clouds_fwd)) + allocate(icloud(n_actual_clouds)) + allocate(cf(nsig)) + allocate(hwp_guess(n_clouds_fwd)) + cloud_cont=zero + cloud_efr =zero + cloud =zero + cloudefr =zero + cf =zero + hwp_guess =zero + + call gsi_bundlegetpointer(gsi_metguess_bundle(1),cloud_names,icloud,ier) + + iii=0 + do ii=1,n_actual_clouds + call gsi_metguess_get ( 'i4crtm::'//trim(cloud_names(ii)), icloud4crtm, ier ) + if (icloud4crtm>10) then + iii=iii+1 + jcloud(iii)=ii + endif + end do + if(iii/=n_clouds_fwd) call die(myname_,'inconsistent cloud count',1) + + n_actual_clouds_wk = n_actual_clouds + n_clouds_fwd_wk = n_clouds_fwd + n_clouds_jac_wk = n_clouds_jac + cld_sea_only_wk = radmod%cld_sea_only + Load_CloudCoeff = .true. + lprecip_wk = radmod%lprecip .or. fv3_full_hydro + else + n_actual_clouds_wk = 0 + n_clouds_fwd_wk = 0 + n_clouds_jac_wk = 0 + cld_sea_only_wk = .false. + Load_CloudCoeff = .false. + endif + +! Set up index for input satellite data array + + isatid = 1 ! index of satellite id + itime = 2 ! index of analysis relative obs time + ilon = 3 ! index of grid relative obs location (x) + ilat = 4 ! index of grid relative obs location (y) + ilzen_ang = 5 ! index of local (satellite) zenith angle (radians) + ilazi_ang = 6 ! index of local (satellite) azimuth angle (radians) + iscan_ang = 7 ! index of scan (look) angle (radians) + iscan_pos = 8 ! index of integer scan position + iszen_ang = 9 ! index of solar zenith angle (degrees) + isazi_ang = 10 ! index of solar azimuth angle (degrees) + ifrac_sea = 11 ! index of ocean percentage + ifrac_lnd = 12 ! index of land percentage + ifrac_ice = 13 ! index of ice percentage + ifrac_sno = 14 ! index of snow percentage + its_sea = 15 ! index of ocean temperature + its_lnd = 16 ! index of land temperature + its_ice = 17 ! index of ice temperature + its_sno = 18 ! index of snow temperature + itsavg = 19 ! index of average temperature + ivty = 20 ! index of vegetation type + ivfr = 21 ! index of vegetation fraction + isty = 22 ! index of soil type + istp = 23 ! index of soil temperature + ism = 24 ! index of soil moisture + isn = 25 ! index of snow depth + izz = 26 ! index of surface height + idomsfc = 27 ! index of dominate surface type + isfcr = 28 ! index of surface roughness + iff10 = 29 ! index of ten meter wind factor + ilone = 30 ! index of earth relative longitude (degrees) + ilate = 31 ! index of earth relative latitude (degrees) + icount=ilate + if(dval_use) icount=icount+2 + if ( obstype == 'avhrr_navy' .or. obstype == 'avhrr' ) then + icount=icount+2 ! when an independent SST analysis is read in + else if ( obstype == 'tmi' ) then + iedge_log = 32 ! index, if obs is to be obleted beause of locating near scan edges. + icount = iedge_log+2 + else if ( obstype == 'gmi' ) then + iedge_log = 32 ! index, if obs is to be obleted beause of locating near scan edges. + ilzen_ang2= 33 ! index of local (satellite) zenith angle (radians) + ilazi_ang2= 34 ! index of local (satellite) azimuth angle (radians) + iscan_ang2= 35 ! index of scan (look) angle (radians) + iszen_ang2= 36 ! index of solar zenith angle (degrees) + isazi_ang2= 37 ! index of solar azimuth angle (degrees) + icount = isazi_ang2 + if(dval_use) icount=icount+2 + else if ( obstype == 'amsr2' ) then + icount=ilate+2 + endif + + itref = nreal-3 ! index of foundation temperature: Tr + idtw = nreal-2 ! index of diurnal warming: d(Tw) at depth zob + idtc = nreal-1 ! index of sub-layer cooling: d(Tc) at depth zob + itz_tr = nreal ! index of d(Tz)/d(Tr) + + + if (obstype == 'goes_img' .or. obstype == 'abi') then + iclr_sky = 7 ! index of clear sky amount + elseif (obstype == 'avhrr_navy') then + isst_navy = 7 ! index of navy sst (K) retrieval + idata_type = 32 ! index of data type (151=day, 152=night) + isst_hires = 33 ! index of interpolated hires sst (K) + elseif (obstype == 'avhrr') then + iclavr = 32 ! index CLAVR cloud flag with AVHRR data + isst_hires = 33 ! index of interpolated hires sst (K) + elseif (obstype == 'seviri') then + iclr_sky = 7 ! index of clear sky amount + endif + + +! get the number of trace gases present in the chemguess bundle + n_ghg=0 + if(size(gsi_chemguess_bundle)>0) then + call gsi_chemguess_get('ghg',n_ghg,ier) + if (n_ghg>0) then + allocate(ghg_names(n_ghg)) + call gsi_chemguess_get('ghg',ghg_names,ier) + endif + endif + n_absorbers = min_n_absorbers + n_ghg + + +! Are there aerosols to affect CRTM? + if (radmod%laerosol_fwd) then + if(.not.allocated(aero)) allocate(aero(nsig,n_actual_aerosols)) + if(.not.allocated(aero_conc)) allocate(aero_conc(msig,n_actual_aerosols),auxrh(msig)) + n_actual_aerosols_wk=n_actual_aerosols + n_aerosols_fwd_wk=n_aerosols_fwd + n_aerosols_jac_wk=n_aerosols_jac + Load_AerosolCoeff=.true. + else + n_actual_aerosols_wk=0 + n_aerosols_fwd_wk=0 + n_aerosols_jac_wk=0 + Load_AerosolCoeff=.false. + endif + +! Initialize radiative transfer + + sensorlist(1)=isis + quiet=.not. print_verbose + if( crtm_coeffs_path /= "" ) then + if(init_pass .and. mype==mype_diaghdr .and. print_verbose) & + write(6,*)myname_,': crtm_init() on path "'//trim(crtm_coeffs_path)//'"' + error_status = crtm_init(sensorlist,channelinfo,& + Process_ID=mype,Output_Process_ID=mype_diaghdr, & + Load_CloudCoeff=Load_CloudCoeff,Load_AerosolCoeff=Load_AerosolCoeff, & + File_Path = crtm_coeffs_path,quiet=quiet ) + else + error_status = crtm_init(sensorlist,channelinfo,& + Process_ID=mype,Output_Process_ID=mype_diaghdr, & + Load_CloudCoeff=Load_CloudCoeff,Load_AerosolCoeff=Load_AerosolCoeff,& + quiet=quiet) + endif + if (error_status /= success) then + write(6,*)myname_,': ***ERROR*** crtm_init error_status=',error_status,& + ' TERMINATE PROGRAM EXECUTION' + call stop2(71) + endif + + sensorindex = 0 + if (channelinfo(1)%sensor_id == isis) then + sensorindex = 1 + + if (isis(1:4) == 'iasi' .or. & + trim(isis) == 'amsua_aqua' .or. & + isis(1:4) == 'airs' .or. & + isis(1:4) == 'cris' ) then + subset_start = 0 + subset_end = 0 + do k=1, jpch_rad + if (isis == nusis(k)) then + if (subset_start == 0) subset_start = k + subset_end = k + endif + end do + + error_status = crtm_channelinfo_subset(channelinfo(1), & + channel_subset = nuchan(subset_start:subset_end)) + + endif + +! This is to try to keep the CrIS naming conventions more flexible. +! The consistency of CRTM and BUFR files is checked in read_cris: +else if (channelinfo(1)%sensor_id(1:8) == 'cris-fsr' .AND. isis(1:8) == 'cris-fsr') then + sensorindex = 1 + subset_start = 0 + subset_end = 0 + do k=1, jpch_rad + if (isis == nusis(k)) then + if (subset_start == 0) subset_start = k + subset_end = k + endif + end do + + error_status = crtm_channelinfo_subset(channelinfo(1), & + channel_subset = nuchan(subset_start:subset_end)) + +else if (channelinfo(1)%sensor_id(1:4) == 'cris' .AND. isis(1:4) == 'cris') then + sensorindex = 1 + subset_start = 0 + subset_end = 0 + do k=1, jpch_rad + if (isis == nusis(k)) then + if (subset_start == 0) subset_start = k + subset_end = k + endif + end do + + error_status = crtm_channelinfo_subset(channelinfo(1), & + channel_subset = nuchan(subset_start:subset_end)) + +else if (channelinfo(1)%sensor_id(1:4) == 'iasi' .AND. isis(1:4) == 'iasi') then + sensorindex = 1 + subset_start = 0 + subset_end = 0 + do k=1, jpch_rad + if (isis == nusis(k)) then + if (subset_start == 0) subset_start = k + subset_end = k + endif + end do + + error_status = crtm_channelinfo_subset(channelinfo(1), & + channel_subset = nuchan(subset_start:subset_end)) + +else if (channelinfo(1)%sensor_id(1:4) == 'airs' .AND. isis(1:4) == 'airs') then + sensorindex = 1 + subset_start = 0 + subset_end = 0 + do k=1, jpch_rad + if (isis == nusis(k)) then + if (subset_start == 0) subset_start = k + subset_end = k + endif + end do + + error_status = crtm_channelinfo_subset(channelinfo(1), & + channel_subset = nuchan(subset_start:subset_end)) + +endif + + if (sensorindex == 0 ) then + write(6,*)myname_,': ***WARNING*** problem with sensorindex=',isis,& + ' --> CAN NOT PROCESS isis=',isis,' TERMINATE PROGRAM EXECUTION found ',& + channelinfo(1)%sensor_id + call stop2(71) + endif + +! Check for consistency between user specified number of channels (nchanl) +! and those defined by CRTM channelinfo structure. Return to calling +! routine if there is a mismatch. + + if (nchanl /= crtm_channelinfo_n_channels(channelinfo(sensorindex))) then + write(6,*)myname_,': ***WARNING*** mismatch between nchanl=',& + nchanl,' and n_channels=',crtm_channelinfo_n_channels(channelinfo(sensorindex)),& + ' --> CAN NOT PROCESS isis=',isis,' TERMINATE PROGRAM EXECUTION' + call stop2(71) + endif + +! Allocate structures for radiative transfer + + if (radmod%lcloud_fwd .and. (.not. mixed_use) .and. (.not. allocated(rtsolution0)) ) & + allocate(rtsolution0(channelinfo(sensorindex)%n_channels,1)) + + allocate(& + rtsolution (channelinfo(sensorindex)%n_channels,1),& + rtsolution_k(channelinfo(sensorindex)%n_channels,1),& + atmosphere_k(channelinfo(sensorindex)%n_channels,1),& + surface_k (channelinfo(sensorindex)%n_channels,1)) + if (mixed_use) allocate(& + rtsolution_clr (channelinfo(sensorindex)%n_channels,1),& + rtsolution_k_clr(channelinfo(sensorindex)%n_channels,1),& + atmosphere_k_clr(channelinfo(sensorindex)%n_channels,1),& + surface_k_clr (channelinfo(sensorindex)%n_channels,1)) + +! Check to ensure that number of levels requested does not exceed crtm max + + if(msig > max_n_layers)then + write(6,*) myname_,': msig > max_n_layers - increase crtm max_n_layers ',& + msig,max_n_layers + call stop2(36) + end if + +! Create structures for radiative transfer + + call crtm_atmosphere_create(atmosphere(1),msig,n_absorbers,n_clouds_fwd_wk,n_aerosols_fwd_wk) +!_RTod-NOTE if(r_kind==r_single .and. crtm_kind/=r_kind) then ! take care of case: GSI(single); CRTM(double) +!_RTod-NOTE call crtm_surface_create(surface(1),channelinfo(sensorindex)%n_channels,tolerance=1.0e-5_crtm_kind) +!_RTod-NOTE else +!_RTod-NOTE: the following will work in single precision but issue lots of msg and remove more obs than needed + if ( channelinfo(sensorindex)%sensor_type == crtm_microwave_sensor ) then + call crtm_surface_create(surface(1),channelinfo(sensorindex)%n_channels) + if (.NOT.(crtm_surface_associated(surface(1)))) then + write(6,*)myname_,' ***ERROR** creating surface.' + else + surface(1)%sensordata%sensor_id = channelinfo(sensorindex)%sensor_id + surface(1)%sensordata%wmo_sensor_id = channelinfo(sensorindex)%wmo_sensor_id + surface(1)%sensordata%wmo_satellite_id = channelinfo(sensorindex)%wmo_satellite_id + surface(1)%sensordata%sensor_channel = channelinfo(sensorindex)%sensor_channel + end if + end if +!_RTod-NOTE endif + if (radmod%lcloud_fwd .and. (.not. mixed_use)) & + call crtm_rtsolution_create(rtsolution0,msig) + call crtm_rtsolution_create(rtsolution,msig) + call crtm_rtsolution_create(rtsolution_k,msig) + call crtm_options_create(options,nchanl) + + if (mixed_use) then + call crtm_rtsolution_create(rtsolution_clr,msig) + call crtm_rtsolution_create(rtsolution_k_clr,msig) + end if + + if (.NOT.(crtm_atmosphere_associated(atmosphere(1)))) & + write(6,*)myname_,' ***ERROR** creating atmosphere.' + if (.NOT.(ANY(crtm_rtsolution_associated(rtsolution)))) & + write(6,*)myname_,' ***ERROR** creating rtsolution.' + if (radmod%lcloud_fwd .and. (.not. mixed_use)) then + if (.NOT.(ANY(crtm_rtsolution_associated(rtsolution0)))) & + write(6,*)' ***ERROR** creating rtsolution0.' + endif + if (.NOT.(ANY(crtm_rtsolution_associated(rtsolution_k)))) & + write(6,*)myname_,' ***ERROR** creating rtsolution_k.' + if (.NOT.(ANY(crtm_options_associated(options)))) & + write(6,*)myname_,' ***ERROR** creating options.' + +! Turn off antenna correction + + options(1)%use_antenna_correction = .false. + +! Load surface sensor data structure + + surface(1)%sensordata%n_channels = channelinfo(sensorindex)%n_channels + +!! REL-1.2 CRTM +!! surface(1)%sensordata%select_wmo_sensor_id = channelinfo(1)%wmo_sensor_id +!! RB-1.1.rev1855 CRTM + + atmosphere(1)%n_layers = msig + atmosphere(1)%absorber_id(1) = H2O_ID + atmosphere(1)%absorber_id(2) = O3_ID + atmosphere(1)%absorber_units(1) = MASS_MIXING_RATIO_UNITS + atmosphere(1)%absorber_units(2) = VOLUME_MIXING_RATIO_UNITS + atmosphere(1)%level_pressure(0) = TOA_PRESSURE + +! Currently all considered trace gases affect CRTM. Load trace gases into CRTM atmosphere + ico2=-1 + if (n_ghg>0) then + do ig=1,n_ghg + j = min_n_absorbers + ig + select case(trim(ghg_names(ig))) + case('co2'); atmosphere(1)%absorber_id(j) = CO2_ID + case('ch4'); atmosphere(1)%absorber_id(j) = CH4_ID + case('n2o'); atmosphere(1)%absorber_id(j) = N2O_ID + case('co') ; atmosphere(1)%absorber_id(j) = CO_ID + case default + call die(myname_,': invalid absorber TERMINATE PROGRAM'//trim(ghg_names(ig)),71) + end select + atmosphere(1)%absorber_units(j) = VOLUME_MIXING_RATIO_UNITS + if (trim(ghg_names(ig))=='co2') ico2=j + enddo + endif + ico24crtm=-1 + if (ico2>0) call gsi_chemguess_get ( 'i4crtm::co2', ico24crtm, ier ) + +! Allocate structure for _k arrays (jacobians) + + do ii=1,nchanl + atmosphere_k(ii,1) = atmosphere(1) + surface_k(ii,1) = surface(1) + end do + + if (mixed_use) then + do ii=1,nchanl + atmosphere_k_clr(ii,1) = atmosphere(1) + surface_k_clr(ii,1) = surface(1) + end do + end if + +! Mapping land surface type to CRTM surface fields + if (regional .or. nvege_type==IGBP_N_TYPES) then + allocate(map_to_crtm_ir(nvege_type)) + allocate(map_to_crtm_mwave(nvege_type)) + if(nvege_type==USGS_N_TYPES)then + ! Assign mapping for CRTM microwave calculations + map_to_crtm_mwave=usgs_to_gfs + ! map usgs to CRTM + select case ( TRIM(CRTM_IRlandCoeff_Classification()) ) + case('NPOESS'); map_to_crtm_ir=usgs_to_npoess + case('USGS') ; map_to_crtm_ir=usgs_to_usgs + end select + else if(nvege_type==IGBP_N_TYPES)then + ! Assign mapping for CRTM microwave calculations + map_to_crtm_mwave=igbp_to_gfs + ! nmm igbp to CRTM + select case ( TRIM(CRTM_IRlandCoeff_Classification()) ) + case('NPOESS'); map_to_crtm_ir=igbp_to_npoess + case('IGBP') ; map_to_crtm_ir=igbp_to_igbp + end select + else + write(6,*)myname_,': ***ERROR*** invalid vegetation types' & + //' for the CRTM IRland EmisCoeff file used.', & + ' (only 20 and 24 are setup) nvege_type=',nvege_type, & + ' ***STOP IN SETUPRAD***' + call stop2(71) + endif ! nvege_type + endif ! regional or IGBP + +! Calculate RH when aerosols are present and/or cloud-fraction used + if (n_actual_aerosols_wk>0 .or. n_clouds_fwd_wk>0) then + allocate(gesqsat(lat2,lon2,nsig,nfldsig)) + ice=.true. + iderivative=0 + do ii=1,nfldsig + call genqsat(gesqsat(1,1,1,ii),ges_tsen(1,1,1,ii),ges_prsl(1,1,1,ii),lat2,lon2,nsig,ice,iderivative) + end do + endif + +! Initial GFDL saturation water vapor pressure tables + if (n_actual_aerosols_wk>0 .or. n_clouds_fwd_wk>0 .and. imp_physics==11) then + + if (mype==0) write(6,*)myname_,':initial and load GFDL saturation water vapor pressure tables' + + allocate(table (length)) + allocate(table2(length)) + allocate(tablew(length)) + allocate(des2 (length)) + allocate(desw (length)) + + call qs_table (length) + call qs_table2(length) + call qs_tablew(length) + + do ii = 1, length - 1 + des2 (ii) = max (zero, table2 (ii + 1) - table2 (ii)) + desw (ii) = max (zero, tablew (ii + 1) - tablew (ii)) + enddo + des2 (length) = des2 (length - 1) + desw (length) = desw (length - 1) + + endif + + return +end subroutine init_crtm +subroutine destroy_crtm +!$$$ subprogram documentation block +! . . . . +! subprogram: destroy_crtm deallocates crtm arrays +! prgmmr: parrish org: np22 date: 2005-01-22 +! +! abstract: deallocates crtm arrays +! +! program history log: +! 2010-08-17 derber +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + implicit none + + character(len=*),parameter::myname_ = myname//'*destroy_crtm' + integer(i_kind) error_status + + error_status = crtm_destroy(channelinfo) + if (error_status /= success) & + write(6,*)myname_,': ***ERROR*** error_status=',error_status + if (n_actual_aerosols_wk>0 .or. n_clouds_fwd_wk>0) then + deallocate(gesqsat) + if (imp_physics==11) then + deallocate(table) + deallocate(table2) + deallocate(tablew) + deallocate(des2) + deallocate(desw) + endif + endif + call crtm_atmosphere_destroy(atmosphere(1)) + call crtm_surface_destroy(surface(1)) + if (n_clouds_fwd_wk>0 .and. (.not. mixed_use)) & + call crtm_rtsolution_destroy(rtsolution0) + call crtm_rtsolution_destroy(rtsolution) + call crtm_rtsolution_destroy(rtsolution_k) + if (mixed_use) then + call crtm_rtsolution_destroy(rtsolution_clr) + call crtm_rtsolution_destroy(rtsolution_k_clr) + end if + call crtm_options_destroy(options) + if (crtm_atmosphere_associated(atmosphere(1))) & + write(6,*)myname_,' ***ERROR** destroying atmosphere.' + if (crtm_surface_associated(surface(1))) & + write(6,*)myname_,' ***ERROR** destroying surface.' + if (ANY(crtm_rtsolution_associated(rtsolution))) & + write(6,*)myname_,' ***ERROR** destroying rtsolution.' + if (n_clouds_fwd_wk>0 .and. (.not. mixed_use)) then + if (ANY(crtm_rtsolution_associated(rtsolution0))) & + write(6,*)' ***ERROR** destroying rtsolution0.' + endif + if (ANY(crtm_rtsolution_associated(rtsolution_k))) & + write(6,*)myname_,' ***ERROR** destroying rtsolution_k.' + if (ANY(crtm_options_associated(options))) & + write(6,*)myname_,' ***ERROR** destroying options.' + deallocate(rtsolution,atmosphere_k,surface_k,rtsolution_k) + if (mixed_use) deallocate(rtsolution_clr,atmosphere_k_clr, & + surface_k_clr,rtsolution_k_clr) + if (n_clouds_fwd_wk>0 .and. (.not. mixed_use)) & + deallocate(rtsolution0) + if(n_actual_aerosols_wk>0)then + deallocate(aero,aero_conc,auxrh) + if(n_aerosols_jac>0) deallocate(iaero_jac) + endif + if (n_ghg>0) then + deallocate(ghg_names) + endif + if(allocated(icloud)) deallocate(icloud) + if(allocated(cloud)) deallocate(cloud) + if(allocated(cloudefr)) deallocate(cloudefr) + if(allocated(jcloud)) deallocate(jcloud) + if(allocated(cloud_cont)) deallocate(cloud_cont) + if(allocated(cloud_efr)) deallocate(cloud_efr) + if(allocated(cf)) deallocate(cf) + if(allocated(hwp_guess)) deallocate(hwp_guess) + if(allocated(icw)) deallocate(icw) + if(allocated(lcloud4crtm_wk)) deallocate(lcloud4crtm_wk) + if(regional .or. nvege_type==IGBP_N_TYPES)deallocate(map_to_crtm_ir) + if(regional .or. nvege_type==IGBP_N_TYPES)deallocate(map_to_crtm_mwave) + + return +end subroutine destroy_crtm +subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & + h,q,clw_guess,ciw_guess,rain_guess,snow_guess,prsl,prsi, & + trop5,tzbgr,dtsavg,sfc_speed,& + tsim,emissivity,ptau5,ts, & + emissivity_k,temp,wmix,jacobian,error_status,tsim_clr,tcc, & + tcwv,hwp_ratio,stability,layer_od,jacobian_aero) +!$$$ subprogram documentation block +! . . . . +! subprogram: call_crtm creates vertical profile of t,q,oz,p,zs,etc., +! calls crtm, and does adjoint of creation (where necessary) for setuprad +! prgmmr: parrish org: np22 date: 1990-10-11 +! +! abstract: creates vertical profile of t,q,oz,p,zs,etc., +! calls crtm, and does adjoint of creation (where necessary) for setuprad +! +! program history log: +! 2010-08-17 derber - modify from intrppx and add threading +! 2011-02-23 todling/da silva - revisit interface to fill in aerosols +! 2011-03-25 yang - turn off the drop-off of co2 amount when using climatological CO2 +! 2011-05-03 todling - merge with Min-Jeong's MW cloudy radiance; combine w/ metguess +! (did not include tendencies since they were calc but not used) +! 2011-05-17 auligne/todling - add handling for hydrometeors +! 2011-06-29 todling - no explict reference to internal bundle arrays +! 2011-07-05 zhu - add cloud_efr & cloudefr; add cloud_efr & jcloud in the interface of Set_CRTM_Cloud +! 2011-07-05 zhu - rewrite cloud_cont & cwj for cloud control variables (lcw4crtm) +! 2012-03-12 veldelst-- add a internal interpolation function (option) +! 2012-04-25 yang - modify to use trace gas chem_bundle. Trace gas variables are +! invoked by the global_anavinfo.ghg.l64.txt +! 2013-02-25 zhu - add cold_start option for regional applications +! 2014-01-31 mkim-- remove 60.0degree boundary for icmask for all-sky MW radiance DA +! 2014-02-26 zhu - add non zero jacobian so jacobian will be produced for +! clear-sky background or background with small amount of cloud +! 2014-04-27 eliu - add option to calculate clear-sky Tb under all-sky condition +! 2015-02-27 eliu-- wind direction fix for using CRTM FASTEM model +! 2015-03-23 zaizhong ma - add Himawari-8 ahi +! 2015-09-10 zhu - generalize enabling all-sky and aerosol usage in radiance assimilation, +! use n_clouds_fwd_wk,n_aerosols_fwd_wk,cld_sea_only_wk, cld_sea_only_wk,cw_cv,etc +! 2019-03-22 Wei/Martin - added VIIRS AOD obs in addition to MODIS AOD obs +! +! input argument list: +! obstype - type of observations for which to get profile +! obstime - time of observations for which to get profile +! data_s - array containing input data information +! nchanl - number of channels +! nreal - number of descriptor information in data_s +! ich - channel number array +! +! output argument list: +! h - interpolated temperature +! q - interpolated specific humidity (max(qsmall,q)) +! prsl - interpolated layer pressure (nsig) +! prsi - interpolated level pressure (nsig+1) +! trop5 - interpolated tropopause pressure +! tzbgr - water surface temperature used in Tz retrieval +! dtsavg - delta average skin temperature over surface types +! uu5 - interpolated bottom sigma level zonal wind +! vv5 - interpolated bottom sigma level meridional wind +! tsim - simulated brightness temperatures +! emissivity - surface emissivities +! ptau5 - level transmittances +! ts - skin temperature sensitivities +! emissivity_k - surface emissivity sensitivities +! temp - temperature sensitivities +! wmix - humidity sensitivities +! jacobian - nsigradjac level jacobians for use in intrad and stprad +! error_status - error status from crtm +! layer_od - layer optical depth +! jacobian_aero- nsigaerojac level jacobians for use in intaod +! tsim_clr - option to output simulated brightness temperatures for clear sky +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ +!-------- + use kinds, only: r_kind,i_kind + use mpimod, only: mype + use radinfo, only: ifactq + use radinfo, only: nsigradjac + use gsi_nstcouplermod, only: nst_gsi + use guess_grids, only: ges_tsen,& + ges_prsl,ges_prsi,tropprs,dsfct,add_rtm_layers, & + hrdifsig,nfldsig,hrdifsfc,nfldsfc,ntguessfc,isli2,sno2, & + hrdifaer,nfldaer ! for separate aerosol input file + use cloud_efr_mod, only: efr_ql,efr_qi,efr_qr,efr_qs,efr_qg,efr_qh + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_chemguess_mod, only: gsi_chemguess_bundle ! for now, a common block + use gsi_chemguess_mod, only: gsi_chemguess_get + use gsi_metguess_mod, only: gsi_metguess_bundle ! for now, a common block + use gsi_metguess_mod, only: gsi_metguess_get + use gridmod, only: istart,jstart,nlon,nlat,lon1,rlats,rlons + use wrf_params_mod, only: cold_start + use constants, only: zero,half,one,one_tenth,fv,r0_05,r10,r100,r1000,constoz,grav,rad2deg, & + sqrt_tiny_r_kind,constoz,two,three,four,five,t0c,rd,eps,rd_over_cp,rearth + use constants, only: max_varname_length,pi + use set_crtm_aerosolmod, only: set_crtm_aerosol + use set_crtm_cloudmod, only: set_crtm_cloud + use crtm_module, only: limit_exp,o3_id,toa_pressure + use obsmod, only: iadate + use aeroinfo, only: nsigaerojac + use chemmod, only: lread_ext_aerosol !for separate aerosol input file + + implicit none + +! Declare passed variables + real(r_kind) ,intent(in ) :: obstime + integer(i_kind) ,intent(in ) :: nchanl,nreal + integer(i_kind),dimension(nchanl) ,intent(in ) :: ich + real(r_kind) ,intent( out) :: trop5,tzbgr + real(r_kind),dimension(nsig) ,intent( out) :: h,q,prsl + real(r_kind),dimension(nsig+1) ,intent( out) :: prsi + real(r_kind) ,intent( out) :: sfc_speed,dtsavg + real(r_kind),dimension(nchanl+nreal) ,intent(in ) :: data_s + real(r_kind),dimension(nchanl) ,intent( out) :: tsim,emissivity,ts,emissivity_k + character(10) ,intent(in ) :: obstype + integer(i_kind) ,intent( out) :: error_status + real(r_kind),dimension(nsig,nchanl) ,intent( out) :: temp,ptau5,wmix + real(r_kind),dimension(nsigradjac,nchanl),intent(out):: jacobian + real(r_kind) ,intent( out) :: clw_guess,ciw_guess,rain_guess,snow_guess + real(r_kind),dimension(nchanl) ,intent( out), optional :: tsim_clr + real(r_kind),dimension(nchanl) ,intent( out), optional :: tcc + real(r_kind) ,intent( out), optional :: tcwv + real(r_kind) ,intent( out), optional :: hwp_ratio + real(r_kind) ,intent( out), optional :: stability + real(r_kind),dimension(nsigaerojac,nchanl),intent(out),optional :: jacobian_aero + real(r_kind),dimension(nsig,nchanl) ,intent( out) ,optional :: layer_od + +! Declare local parameters + character(len=*),parameter::myname_=myname//'*call_crtm' + real(r_kind),parameter:: minsnow=one_tenth + real(r_kind),parameter:: qsmall = 1.e-6_r_kind + real(r_kind),parameter:: ozsmall = 1.e-10_r_kind + real(r_kind),parameter:: small_wind = 1.e-3_r_kind + real(r_kind),parameter:: windscale = 999999.0_r_kind + real(r_kind),parameter:: windlimit = 0.0001_r_kind + real(r_kind),parameter:: quadcof (4, 2 ) = & + reshape((/0.0_r_kind, 1.0_r_kind, 1.0_r_kind, 2.0_r_kind, 1.0_r_kind, & + -1.0_r_kind, 1.0_r_kind, -1.0_r_kind/), (/4, 2/)) + real(r_kind),parameter:: jac_pert = 1.0_r_kind + +! Declare local variables + integer(i_kind):: iquadrant + integer(i_kind):: ier,ii,kk,kk2,i,itype,leap_day,day_of_year + integer(i_kind):: ig,istatus + integer(i_kind):: j,k,m1,ix,ix1,ixp,iy,iy1,iyp,m,iii + integer(i_kind):: i_minus, i_plus, j_minus, j_plus + integer(i_kind):: itsig,itsigp,itsfc,itsfcp,itaer,itaerp + integer(i_kind):: istyp00,istyp01,istyp10,istyp11 + integer(i_kind):: iqs,iozs,icfs + integer(i_kind):: error_status_clr + integer(i_kind):: idx700,dprs,dprs_min + integer(i_kind),dimension(8)::obs_time,anal_time + integer(i_kind),dimension(msig) :: klevel + +! ****************************** +! Constrained indexing for lai +! CRTM 2.1 implementation change +! ****************************** + integer(i_kind):: lai_type + + real(r_kind):: wind10,wind10_direction,windratio,windangle + real(r_kind):: w00,w01,w10,w11,kgkg_kgm2,f10,panglr,dx,dy + real(r_kind):: delx,dely,delx1,dely1,dtsig,dtsigp,dtsfc,dtsfcp,dtaer,dtaerp + real(r_kind):: sst00,sst01,sst10,sst11,total_od,term,uu5,vv5, ps + real(r_kind):: sno00,sno01,sno10,sno11,secant_term + real(r_kind):: hwp_total,theta_700,theta_sfc,hs + real(r_kind):: dlon,dlat,dxx,dyy,yy,zz,garea + real(r_kind),dimension(0:3):: wgtavg + real(r_kind),dimension(nsig,nchanl):: omix + real(r_kind),dimension(nsig,nchanl,n_aerosols_jac):: jaero + real(r_kind),dimension(nchanl) :: uwind_k,vwind_k + real(r_kind),dimension(msig+1) :: prsi_rtm + real(r_kind),dimension(msig) :: prsl_rtm + real(r_kind),dimension(msig) :: auxq,auxdp + real(r_kind),dimension(nsig) :: poz + real(r_kind),dimension(nsig) :: rh,qs + real(r_kind),dimension(5) :: tmp_time + real(r_kind),dimension(0:3) :: dtskin + real(r_kind),dimension(msig) :: c6 + real(r_kind),dimension(nsig) :: c2,c3,c4,c5 + real(r_kind),dimension(nsig) :: ugkg_kgm2,cwj + real(r_kind),dimension(nsig) :: rho_air ! density of air (kg/m3) + real(r_kind),dimension(nsig) :: cf_calc ! GFDL cloud fraction calculation + real(r_kind),dimension(nsig) :: qmix ! water vapor mixing ratio + real(r_kind),allocatable,dimension(:,:) :: tgas1d + real(r_kind),pointer,dimension(:,: )::psges_itsig =>NULL() + real(r_kind),pointer,dimension(:,: )::psges_itsigp=>NULL() + real(r_kind),pointer,dimension(:,:,:)::uges_itsig =>NULL() + real(r_kind),pointer,dimension(:,:,:)::uges_itsigp=>NULL() + real(r_kind),pointer,dimension(:,:,:)::vges_itsig =>NULL() + real(r_kind),pointer,dimension(:,:,:)::vges_itsigp=>NULL() + real(r_kind),pointer,dimension(:,:,:)::qges_itsig =>NULL() + real(r_kind),pointer,dimension(:,:,:)::qges_itsigp=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ozges_itsig =>NULL() + real(r_kind),pointer,dimension(:,:,:)::ozges_itsigp=>NULL() + real(r_kind),pointer,dimension(:,:,:)::tgasges_itsig =>NULL() + real(r_kind),pointer,dimension(:,:,:)::tgasges_itsigp=>NULL() + real(r_kind),pointer,dimension(:,:,:)::aeroges_itsig =>NULL() + real(r_kind),pointer,dimension(:,:,:)::aeroges_itsigp=>NULL() + real(r_kind),pointer,dimension(:,:,:)::cfges_itsig =>NULL() + real(r_kind),pointer,dimension(:,:,:)::cfges_itsigp=>NULL() + + logical :: sea,icmask + + integer(i_kind),parameter,dimension(12):: mday=(/0,31,59,90,& + 120,151,181,212,243,273,304,334/) + real(r_kind) :: lai + + m1=mype+1 + + if (n_clouds_fwd_wk>0) hwp_guess=zero + hwp_total=zero + theta_700=zero + theta_sfc=zero + if (present(stability)) stability=zero + if (present(hwp_ratio)) hwp_ratio=zero + if (present(tcwv)) tcwv=zero + if (present(tcc)) tcc=zero + + dx = data_s(ilat) ! grid relative latitude + dy = data_s(ilon) ! grid relative longitude + hs = data_s(izz) ! surface height + +! calculate anaysis grid area at obs location + dlat = data_s(ilat)+1.0e-6_r_kind + dlon = data_s(ilon)+1.0e-6_r_kind + j_minus = floor(dlat) + j_plus = ceiling(dlat) + i_minus = floor(dlon) + i_plus = ceiling(dlon) + if (dlon >= nlon) then + i_minus = 1 + i_plus = 2 + endif + if (dlat >= nlat) then + j_minus = nlat-1 + j_plus = nlat + endif + dxx = abs(rlons(i_plus)-rlons(i_minus)) + dyy = abs(rlats(j_plus)-rlats(j_minus)) + zz = half*(rlats(j_minus)+rlats(j_plus)) + if (zz >= zero) yy = abs(rlats(nlat)-zz) + if (zz < zero) yy = abs(rlats(1)-zz) + garea = (rearth*sin(yy)*dxx)*(rearth*dyy) + +! Set spatial interpolation indices and weights + ix1=dx + ix1=max(1,min(ix1,nlat)) + delx=dx-ix1 + delx=max(zero,min(delx,one)) + ix=ix1-istart(m1)+2 + ixp=ix+1 + if(ix1==nlat) then + ixp=ix + end if + delx1=one-delx + + iy1=dy + dely=dy-iy1 + iy=iy1-jstart(m1)+2 + if(iy<1) then + iy1=iy1+nlon + iy=iy1-jstart(m1)+2 + end if + if(iy>lon1+1) then + iy1=iy1-nlon + iy=iy1-jstart(m1)+2 + end if + iyp=iy+1 + dely1=one-dely + + w00=delx1*dely1; w10=delx*dely1; w01=delx1*dely; w11=delx*dely +! w_weights = (/w00,w10,w01,w11/) + + +! Get time interpolation factors for sigma files + if(obstime > hrdifsig(1) .and. obstime < hrdifsig(nfldsig))then + do j=1,nfldsig-1 + if(obstime > hrdifsig(j) .and. obstime <= hrdifsig(j+1))then + itsig=j + itsigp=j+1 + dtsig=((hrdifsig(j+1)-obstime)/(hrdifsig(j+1)-hrdifsig(j))) + end if + end do + else if(obstime <=hrdifsig(1))then + itsig=1 + itsigp=1 + dtsig=one + else + itsig=nfldsig + itsigp=nfldsig + dtsig=one + end if + dtsigp=one-dtsig + +! Get time interpolation factors for surface files + if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then + do j=1,nfldsfc-1 + if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then + itsfc=j + itsfcp=j+1 + dtsfc=((hrdifsfc(j+1)-obstime)/(hrdifsfc(j+1)-hrdifsfc(j))) + end if + end do + else if(obstime <=hrdifsfc(1))then + itsfc=1 + itsfcp=1 + dtsfc=one + else + itsfc=nfldsfc + itsfcp=nfldsfc + dtsfc=one + end if + dtsfcp=one-dtsfc + +! Get time interpolation factors for external files + if ( lread_ext_aerosol ) then + if(obstime > hrdifaer(1) .and. obstime < hrdifaer(nfldaer))then + do j=1,nfldaer-1 + if(obstime > hrdifaer(j) .and. obstime <= hrdifaer(j+1))then + itaer=j + itaerp=j+1 + dtaer=((hrdifaer(j+1)-obstime)/(hrdifaer(j+1)-hrdifaer(j))) + end if + end do + else if(obstime <=hrdifaer(1))then + itaer=1 + itaerp=1 + dtaer=one + else + itaer=nfldaer + itaerp=nfldaer + dtaer=one + end if + dtaerp=one-dtaer + end if ! lread_ext_aerosol + + ier=0 + call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'ps',psges_itsig ,istatus) + ier=ier+istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'ps',psges_itsigp,istatus) + ier=ier+istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'u' ,uges_itsig ,istatus) + ier=ier+istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'u' ,uges_itsigp ,istatus) + ier=ier+istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'v' ,vges_itsig ,istatus) + ier=ier+istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'v' ,vges_itsigp ,istatus) + ier=ier+istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'oz',ozges_itsig ,iozs) + iozs=istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'oz',ozges_itsigp,iozs) + iozs=iozs+istatus + + call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'q',qges_itsig ,istatus) + iqs=istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'q',qges_itsigp,istatus) + iqs=iqs+istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsig ),'cf',cfges_itsig ,icfs) + icfs=istatus + call gsi_bundlegetpointer(gsi_metguess_bundle(itsigp),'cf',cfges_itsigp,icfs) + icfs=icfs+istatus + +! Space-time interpolation of temperature (h) and q fields from sigma files +!$omp parallel do schedule(dynamic,1) private(k,ii,iii) + do k=1,nsig + if(k == 1)then + jacobian=zero +! Set surface type flag. (Same logic as in subroutine deter_sfc) + + istyp00 = isli2(ix ,iy ) + istyp10 = isli2(ixp,iy ) + istyp01 = isli2(ix ,iyp) + istyp11 = isli2(ixp,iyp) + sno00= sno2(ix ,iy ,itsfc)*dtsfc+sno2(ix ,iy ,itsfcp)*dtsfcp + sno01= sno2(ix ,iyp,itsfc)*dtsfc+sno2(ix ,iyp,itsfcp)*dtsfcp + sno10= sno2(ixp,iy ,itsfc)*dtsfc+sno2(ixp,iy ,itsfcp)*dtsfcp + sno11= sno2(ixp,iyp,itsfc)*dtsfc+sno2(ixp,iyp,itsfcp)*dtsfcp + if(istyp00 >= 1 .and. sno00 > minsnow)istyp00 = 3 + if(istyp01 >= 1 .and. sno01 > minsnow)istyp01 = 3 + if(istyp10 >= 1 .and. sno10 > minsnow)istyp10 = 3 + if(istyp11 >= 1 .and. sno11 > minsnow)istyp11 = 3 + +! Find delta Surface temperatures for all surface types + + sst00= dsfct(ix ,iy,ntguessfc) ; sst01= dsfct(ix ,iyp,ntguessfc) + sst10= dsfct(ixp,iy,ntguessfc) ; sst11= dsfct(ixp,iyp,ntguessfc) + dtsavg=sst00*w00+sst10*w10+sst01*w01+sst11*w11 + + dtskin(0:3)=zero + wgtavg(0:3)=zero + + if(istyp00 == 1)then + wgtavg(1) = wgtavg(1) + w00 + dtskin(1)=dtskin(1)+w00*sst00 + else if(istyp00 == 2)then + wgtavg(2) = wgtavg(2) + w00 + dtskin(2)=dtskin(2)+w00*sst00 + else if(istyp00 == 3)then + wgtavg(3) = wgtavg(3) + w00 + dtskin(3)=dtskin(3)+w00*sst00 + else + wgtavg(0) = wgtavg(0) + w00 + dtskin(0)=dtskin(0)+w00*sst00 + end if + + if(istyp01 == 1)then + wgtavg(1) = wgtavg(1) + w01 + dtskin(1)=dtskin(1)+w01*sst01 + else if(istyp01 == 2)then + wgtavg(2) = wgtavg(2) + w01 + dtskin(2)=dtskin(2)+w01*sst01 + else if(istyp01 == 3)then + wgtavg(3) = wgtavg(3) + w01 + dtskin(3)=dtskin(3)+w01*sst01 + else + wgtavg(0) = wgtavg(0) + w01 + dtskin(0)=dtskin(0)+w01*sst01 + end if + + if(istyp10 == 1)then + wgtavg(1) = wgtavg(1) + w10 + dtskin(1)=dtskin(1)+w10*sst10 + else if(istyp10 == 2)then + wgtavg(2) = wgtavg(2) + w10 + dtskin(2)=dtskin(2)+w10*sst10 + else if(istyp10 == 3)then + wgtavg(3) = wgtavg(3) + w10 + dtskin(3)=dtskin(3)+w10*sst10 + else + wgtavg(0) = wgtavg(0) + w10 + dtskin(0)=dtskin(0)+w10*sst10 + end if + + if(istyp11 == 1)then + wgtavg(1) = wgtavg(1) + w11 + dtskin(1)=dtskin(1)+w11*sst11 + else if(istyp11 == 2)then + wgtavg(2) = wgtavg(2) + w11 + dtskin(2)=dtskin(2)+w11*sst11 + else if(istyp11 == 3)then + wgtavg(3) = wgtavg(3) + w11 + dtskin(3)=dtskin(3)+w11*sst11 + else + wgtavg(0) = wgtavg(0) + w11 + dtskin(0)=dtskin(0)+w11*sst11 + end if + + if(wgtavg(0) > zero)then + dtskin(0) = dtskin(0)/wgtavg(0) + else + dtskin(0) = dtsavg + end if + if(wgtavg(1) > zero)then + dtskin(1) = dtskin(1)/wgtavg(1) + else + dtskin(1) = dtsavg + end if + if(wgtavg(2) > zero)then + dtskin(2) = dtskin(2)/wgtavg(2) + else + dtskin(2) = dtsavg + end if + if(wgtavg(3) > zero)then + dtskin(3) = dtskin(3)/wgtavg(3) + else + dtskin(3) = dtsavg + end if + + if (n_clouds_fwd_wk>0) then + ps=(psges_itsig (ix,iy )*w00+psges_itsig (ixp,iy )*w10+ & + psges_itsig (ix,iyp)*w01+psges_itsig (ixp,iyp)*w11)*dtsig + & + (psges_itsigp(ix,iy )*w00+psges_itsigp(ixp,iy )*w10+ & + psges_itsigp(ix,iyp)*w01+psges_itsigp(ixp,iyp)*w11)*dtsigp + endif + +! skip loading surface structure if obstype is modis_aod or viirs_aod + if ( trim(obstype) /= 'modis_aod' .and. trim(obstype) /= 'viirs_aod' ) then + +! Load surface structure + +! **NOTE: The model surface type --> CRTM surface type +! mapping below is specific to the versions NCEP +! GFS and NNM as of Summer 2016 + + itype = nint(data_s(ivty)) + istype = nint(data_s(isty)) + if (regional .or. nvege_type==IGBP_N_TYPES) then + itype = min(max(1,itype),nvege_type) + istype = min(max(1,istype),SOIL_N_TYPES) + if (ChannelInfo(sensorindex)%sensor_type == crtm_microwave_sensor)then + surface(1)%land_type = max(1,map_to_crtm_mwave(itype)) + else + surface(1)%land_type = max(1,map_to_crtm_ir(itype)) + end if + surface(1)%Vegetation_Type = max(1,map_to_crtm_mwave(itype)) + surface(1)%Soil_Type = map_soil_to_crtm(istype) + lai_type = map_to_crtm_mwave(itype) + elseif (nvege_type==GFS_N_TYPES) then + itype = min(max(0,itype),GFS_VEGETATION_N_TYPES) + istype = min(max(1,istype),GFS_SOIL_N_TYPES) + surface(1)%land_type = gfs_to_crtm(itype) + surface(1)%Vegetation_Type = max(1,itype) + surface(1)%Soil_Type = istype + lai_type = itype + else + write(6,*)myname_,': ***ERROR*** invalid vegetation types' & + //' the information does not match any currenctly.', & + ' supported surface type maps to the CRTM,', & + ' ***STOP IN SETUPRAD***' + call stop2(71) + end if + + if (lwind) then +! Interpolate lowest level winds to observation location + + uu5=(uges_itsig (ix,iy ,1)*w00+uges_itsig (ixp,iy ,1)*w10+ & + uges_itsig (ix,iyp,1)*w01+uges_itsig (ixp,iyp,1)*w11)*dtsig + & + (uges_itsigp(ix,iy ,1)*w00+uges_itsigp(ixp,iy ,1)*w10+ & + uges_itsigp(ix,iyp,1)*w01+uges_itsigp(ixp,iyp,1)*w11)*dtsigp + vv5=(vges_itsig (ix,iy ,1)*w00+vges_itsig (ixp,iy ,1)*w10+ & + vges_itsig (ix,iyp,1)*w01+vges_itsig (ixp,iyp,1)*w11)*dtsig + & + (vges_itsigp(ix,iy ,1)*w00+vges_itsigp(ixp,iy ,1)*w10+ & + vges_itsigp(ix,iyp,1)*w01+vges_itsigp(ixp,iyp,1)*w11)*dtsigp + f10=data_s(iff10) + sfc_speed = f10*sqrt(uu5*uu5+vv5*vv5) + wind10 = sfc_speed + if (uu5*f10 >= 0.0_r_kind .and. vv5*f10 >= 0.0_r_kind) iquadrant = 1 + if (uu5*f10 >= 0.0_r_kind .and. vv5*f10 < 0.0_r_kind) iquadrant = 2 + if (uu5*f10 < 0.0_r_kind .and. vv5*f10 >= 0.0_r_kind) iquadrant = 4 + if (uu5*f10 < 0.0_r_kind .and. vv5*f10 < 0.0_r_kind) iquadrant = 3 + if (abs(vv5*f10) >= windlimit) then + windratio = (uu5*f10) / (vv5*f10) + else + windratio = 0.0_r_kind + if (abs(uu5*f10) > windlimit) then + windratio = windscale * uu5*f10 + endif + endif + windangle = atan(abs(windratio)) ! wind azimuth is in radians + wind10_direction = quadcof(iquadrant, 1) * pi + windangle * quadcof(iquadrant, 2) + surface(1)%wind_speed = sfc_speed + surface(1)%wind_direction = rad2deg*wind10_direction + else !RTodling: not sure the following option makes any sense + surface(1)%wind_speed = zero + surface(1)%wind_direction = zero + endif + +! CRTM will reject surface coverages if greater than one and it is possible for +! these values to be larger due to round off. + + surface(1)%water_coverage = min(max(zero,data_s(ifrac_sea)),one) + surface(1)%land_coverage = min(max(zero,data_s(ifrac_lnd)),one) + surface(1)%ice_coverage = min(max(zero,data_s(ifrac_ice)),one) + surface(1)%snow_coverage = min(max(zero,data_s(ifrac_sno)),one) + +! +! get vegetation lai from summer and winter values. +! + + surface(1)%Lai = zero + if (surface(1)%land_coverage>zero) then + if(lai_type>0)then + call get_lai(data_s,nchanl,nreal,itime,ilate,lai_type,lai) + surface(1)%Lai = lai ! LAI + endif + + ! for Glacial land ice soil type and vegetation type + if(surface(1)%Soil_Type == 9 .OR. surface(1)%Vegetation_Type == 13) then + surface(1)%ice_coverage = min(surface(1)%ice_coverage + surface(1)%land_coverage, one) + surface(1)%land_coverage = zero + endif + endif + + surface(1)%water_temperature = max(data_s(its_sea)+dtskin(0),270._r_kind) + if(nst_gsi>1 .and. surface(1)%water_coverage>zero) then + surface(1)%water_temperature = max(data_s(itref)+data_s(idtw)-data_s(idtc)+dtskin(0),271._r_kind) + endif + surface(1)%land_temperature = data_s(its_lnd)+dtskin(1) + surface(1)%ice_temperature = min(data_s(its_ice)+dtskin(2),280._r_kind) + surface(1)%snow_temperature = min(data_s(its_sno)+dtskin(3),280._r_kind) + surface(1)%soil_moisture_content = data_s(ism) + surface(1)%vegetation_fraction = data_s(ivfr) + surface(1)%soil_temperature = data_s(istp) + surface(1)%snow_depth = data_s(isn) + + sea = min(max(zero,data_s(ifrac_sea)),one) >= 0.99_r_kind + icmask = (sea .and. cld_sea_only_wk) .or. (.not. cld_sea_only_wk) + +! assign tzbgr for Tz retrieval when necessary + tzbgr = surface(1)%water_temperature + + endif ! end of loading surface structure + +! Load geometry structure + +! skip loading geometry structure if obstype is modis_aod or viirs_aod +! iscan_ang,ilzen_ang,ilazi_ang are not available in the modis aod bufr file +! also, geometryinfo is not needed in crtm aod calculation + if ( trim(obstype) /= 'modis_aod' .and. trim(obstype) /= 'viirs_aod' ) then + panglr = data_s(iscan_ang) + if(obstype == 'goes_img' .or. obstype == 'seviri' .or. obstype == 'abi')panglr = zero + + geometryinfo(1)%sensor_zenith_angle = abs(data_s(ilzen_ang)*rad2deg) ! local zenith angle + geometryinfo(1)%source_zenith_angle = abs(data_s(iszen_ang)) ! solar zenith angle +! geometryinfo(1)%sensor_zenith_angle = data_s(ilzen_ang)*rad2deg ! local zenith angle +! geometryinfo(1)%source_zenith_angle = data_s(iszen_ang) ! solar zenith angle + geometryinfo(1)%sensor_azimuth_angle = data_s(ilazi_ang) ! local azimuth angle + geometryinfo(1)%source_azimuth_angle = data_s(isazi_ang) ! solar azimuth angle + geometryinfo(1)%sensor_scan_angle = panglr*rad2deg ! scan angle + geometryinfo(1)%ifov = nint(data_s(iscan_pos)) ! field of view position + +! For some microwave instruments the solar and sensor azimuth angles can be +! missing (given a value of 10^11). Set these to zero to get past CRTM QC. + + if (geometryinfo(1)%source_azimuth_angle > 360.0_r_kind .OR. & + geometryinfo(1)%source_azimuth_angle < zero ) & + geometryinfo(1)%source_azimuth_angle = zero + if (geometryinfo(1)%sensor_azimuth_angle > 360.0_r_kind .OR. & + geometryinfo(1)%sensor_azimuth_angle < zero ) & + geometryinfo(1)%sensor_azimuth_angle = zero + + endif ! end of loading geometry structure + +! Special block for SSU cell pressure leakage correction. Need to compute +! observation time and load into Time component of geometryinfo structure. +! geometryinfo%time is only defined in CFSRR CRTM. + if (obstype == 'ssu') then + +! Compute absolute observation time + + anal_time=0 + obs_time=0 + tmp_time=zero + tmp_time(2)=obstime + anal_time(1)=iadate(1) + anal_time(2)=iadate(2) + anal_time(3)=iadate(3) + anal_time(5)=iadate(4) + +!external-subroutine w3movdat() + + call w3movdat(tmp_time,anal_time,obs_time) + +! Compute decimal year, for example 1/10/1983 +! d_year = 1983.0 + 10.0/365.0 + + leap_day = 0 + if( mod(obs_time(1),4)==0 ) then + if( (mod(obs_time(1),100)/=0).or.(mod(obs_time(1),400)==0) ) leap_day = 1 + endif + day_of_year = mday(obs_time(2)) + obs_time(3) + if(obs_time(2) > 2) day_of_year = day_of_year + leap_day + + call ssu_input_setvalue( options%SSU, & + Time=dble(obs_time(1)) + dble(day_of_year)/(365.0_r_kind+leap_day)) + + endif + +! Load surface sensor data structure + do i=1,nchanl + + +! Set-up to return Tb jacobians. + + rtsolution_k(i,1)%radiance = zero + rtsolution_k(i,1)%brightness_temperature = one + if (mixed_use) then + rtsolution_k_clr(i,1)%radiance = zero + rtsolution_k_clr(i,1)%brightness_temperature = one + end if + + if ( trim(obstype) /= 'modis_aod' .and. trim(obstype) /= 'viirs_aod' )then + +! Pass CRTM array of tb for surface emissiviy calculations + if ( channelinfo(1)%sensor_type == crtm_microwave_sensor .and. & + crtm_surface_associated(surface(1)) ) & + surface(1)%sensordata%tb(i) = data_s(nreal+i) + +! set up to return layer_optical_depth jacobians + rtsolution_k(i,1)%layer_optical_depth = one + if (mixed_use) rtsolution_k_clr(i,1)%layer_optical_depth = one + endif + + end do + + end if + + h(k) =(ges_tsen(ix ,iy ,k,itsig )*w00+ & + ges_tsen(ixp,iy ,k,itsig )*w10+ & + ges_tsen(ix ,iyp,k,itsig )*w01+ & + ges_tsen(ixp,iyp,k,itsig )*w11)*dtsig + & + (ges_tsen(ix ,iy ,k,itsigp)*w00+ & + ges_tsen(ixp,iy ,k,itsigp)*w10+ & + ges_tsen(ix ,iyp,k,itsigp)*w01+ & + ges_tsen(ixp,iyp,k,itsigp)*w11)*dtsigp +! Interpolate layer pressure to observation point + prsl(k)=(ges_prsl(ix ,iy ,k,itsig )*w00+ & + ges_prsl(ixp,iy ,k,itsig )*w10+ & + ges_prsl(ix ,iyp,k,itsig )*w01+ & + ges_prsl(ixp,iyp,k,itsig )*w11)*dtsig + & + (ges_prsl(ix ,iy ,k,itsigp)*w00+ & + ges_prsl(ixp,iy ,k,itsigp)*w10+ & + ges_prsl(ix ,iyp,k,itsigp)*w01+ & + ges_prsl(ixp,iyp,k,itsigp)*w11)*dtsigp +! Interpolate level pressure to observation point + prsi(k)=(ges_prsi(ix ,iy ,k,itsig )*w00+ & + ges_prsi(ixp,iy ,k,itsig )*w10+ & + ges_prsi(ix ,iyp,k,itsig )*w01+ & + ges_prsi(ixp,iyp,k,itsig )*w11)*dtsig + & + (ges_prsi(ix ,iy ,k,itsigp)*w00+ & + ges_prsi(ixp,iy ,k,itsigp)*w10+ & + ges_prsi(ix ,iyp,k,itsigp)*w01+ & + ges_prsi(ixp,iyp,k,itsigp)*w11)*dtsigp + if (iqs==0) then + q(k) =(qges_itsig (ix ,iy ,k)*w00+ & + qges_itsig (ixp,iy ,k)*w10+ & + qges_itsig (ix ,iyp,k)*w01+ & + qges_itsig (ixp,iyp,k)*w11)*dtsig + & + (qges_itsigp(ix ,iy ,k)*w00+ & + qges_itsigp(ixp,iy ,k)*w10+ & + qges_itsigp(ix ,iyp,k)*w01+ & + qges_itsigp(ixp,iyp,k)*w11)*dtsigp +! Ensure q is greater than or equal to qsmall + q(k)=max(qsmall,q(k)) + else + q(k) = qsmall + endif + c2(k)=one/(one+fv*q(k)) + c3(k)=one/(one-q(k)) + c4(k)=fv*h(k)*c2(k) + c5(k)=r1000*c3(k)*c3(k) + qmix(k)=q(k)*c3(k) !conver specific humidity to mixing ratio +! Space-time interpolation of ozone(poz) + if (iozs==0) then + poz(k)=((ozges_itsig (ix ,iy ,k)*w00+ & + ozges_itsig (ixp,iy ,k)*w10+ & + ozges_itsig (ix ,iyp,k)*w01+ & + ozges_itsig (ixp,iyp,k)*w11)*dtsig + & + (ozges_itsigp(ix ,iy ,k)*w00+ & + ozges_itsigp(ixp,iy ,k)*w10+ & + ozges_itsigp(ix ,iyp,k)*w01+ & + ozges_itsigp(ixp,iyp,k)*w11)*dtsigp)*constoz + +! Ensure ozone is greater than ozsmall + + poz(k)=max(ozsmall,poz(k)) + endif ! oz +! Space-time interpolation of cloud fraction (cf) + if (n_clouds_fwd_wk>0 .and. icfs==0) then + cf(k)=((cfges_itsig (ix ,iy ,k)*w00+ & + cfges_itsig (ixp,iy ,k)*w10+ & + cfges_itsig (ix ,iyp,k)*w01+ & + cfges_itsig (ixp,iyp,k)*w11)*dtsig + & + (cfges_itsigp(ix ,iy ,k)*w00+ & + cfges_itsigp(ixp,iy ,k)*w10+ & + cfges_itsigp(ix ,iyp,k)*w01+ & + cfges_itsigp(ixp,iyp,k)*w11)*dtsigp) + +! Ensure ozone is greater than ozsmall + + cf(k)=min(max(zero,cf(k)),one) + endif ! cf +! Quantities required for MW cloudy radiance calculations + + if (n_clouds_fwd_wk>0) then + rho_air(k) = eps*(10.0_r_kind*100.0_r_kind*prsl(k))/(rd*h(k)*(q(k)+eps)) + do ii=1,n_clouds_fwd_wk + iii=jcloud(ii) + cloud(k,ii) =(gsi_metguess_bundle(itsig )%r3(icloud(iii))%q(ix ,iy ,k)*w00+ & ! kg/kg + gsi_metguess_bundle(itsig )%r3(icloud(iii))%q(ixp,iy ,k)*w10+ & + gsi_metguess_bundle(itsig )%r3(icloud(iii))%q(ix ,iyp,k)*w01+ & + gsi_metguess_bundle(itsig )%r3(icloud(iii))%q(ixp,iyp,k)*w11)*dtsig + & + (gsi_metguess_bundle(itsigp)%r3(icloud(iii))%q(ix ,iy ,k)*w00+ & + gsi_metguess_bundle(itsigp)%r3(icloud(iii))%q(ixp,iy ,k)*w10+ & + gsi_metguess_bundle(itsigp)%r3(icloud(iii))%q(ix ,iyp,k)*w01+ & + gsi_metguess_bundle(itsigp)%r3(icloud(iii))%q(ixp,iyp,k)*w11)*dtsigp + cloud(k,ii)=max(cloud(k,ii),zero) + + if (regional .and. (.not. wrf_mass_regional)) then + if (trim(cloud_names(iii))== 'ql' ) then + cloudefr(k,ii)=(efr_ql(ix ,iy ,k,itsig)*w00+efr_ql(ixp,iy ,k,itsig)*w10+ & + efr_ql(ix ,iyp,k,itsig)*w01+efr_ql(ixp,iyp,k,itsig)*w11)*dtsig + & + (efr_ql(ix ,iy ,k,itsigp)*w00+efr_ql(ixp,iy ,k,itsigp)*w10+ & + efr_ql(ix ,iyp,k,itsigp)*w01+efr_ql(ixp,iyp,k,itsigp)*w11)*dtsigp + else if (trim(cloud_names(iii))== 'qi' ) then + cloudefr(k,ii)=(efr_qi(ix ,iy ,k,itsig)*w00+efr_qi(ixp,iy ,k,itsig)*w10+ & + efr_qi(ix ,iyp,k,itsig)*w01+efr_qi(ixp,iyp,k,itsig)*w11)*dtsig + & + (efr_qi(ix ,iy ,k,itsigp)*w00+efr_qi(ixp,iy ,k,itsigp)*w10+ & + efr_qi(ix ,iyp,k,itsigp)*w01+efr_qi(ixp,iyp,k,itsigp)*w11)*dtsigp + else if (trim(cloud_names(iii))== 'qs' ) then + cloudefr(k,ii)=(efr_qs(ix ,iy ,k,itsig)*w00+efr_qs(ixp,iy ,k,itsig)*w10+ & + efr_qs(ix ,iyp,k,itsig)*w01+efr_qs(ixp,iyp,k,itsig)*w11)*dtsig + & + (efr_qs(ix ,iy ,k,itsigp)*w00+efr_qs(ixp,iy ,k,itsigp)*w10+ & + efr_qs(ix ,iyp,k,itsigp)*w01+efr_qs(ixp,iyp,k,itsigp)*w11)*dtsigp + else if (trim(cloud_names(iii))== 'qg' ) then + cloudefr(k,ii)=(efr_qg(ix ,iy ,k,itsig)*w00+efr_qg(ixp,iy ,k,itsig)*w10+ & + efr_qg(ix ,iyp,k,itsig)*w01+efr_qg(ixp,iyp,k,itsig)*w11)*dtsig + & + (efr_qg(ix ,iy ,k,itsigp)*w00+efr_qg(ixp,iy ,k,itsigp)*w10+ & + efr_qg(ix ,iyp,k,itsigp)*w01+efr_qg(ixp,iyp,k,itsigp)*w11)*dtsigp + else if (trim(cloud_names(iii))== 'qh' ) then + cloudefr(k,ii)=(efr_qh(ix ,iy ,k,itsig)*w00+efr_qh(ixp,iy ,k,itsig)*w10+ & + efr_qh(ix ,iyp,k,itsig)*w01+efr_qh(ixp,iyp,k,itsig)*w11)*dtsig + & + (efr_qh(ix ,iy ,k,itsigp)*w00+efr_qh(ixp,iy ,k,itsigp)*w10+ & + efr_qh(ix ,iyp,k,itsigp)*w01+efr_qh(ixp,iyp,k,itsigp)*w11)*dtsigp + else if (trim(cloud_names(iii))== 'qr' ) then + cloudefr(k,ii)=(efr_qr(ix ,iy ,k,itsig)*w00+efr_qr(ixp,iy ,k,itsig)*w10+ & + efr_qr(ix ,iyp,k,itsig)*w01+efr_qr(ixp,iyp,k,itsig)*w11)*dtsig + & + (efr_qr(ix ,iy ,k,itsigp)*w00+efr_qr(ixp,iy ,k,itsigp)*w10+ & + efr_qr(ix ,iyp,k,itsigp)*w01+efr_qr(ixp,iyp,k,itsigp)*w11)*dtsigp + end if + end if + end do + endif ! + end do + ! Calculate GFDL effective radius for each hydrometeor + if ( icmask .and. n_clouds_fwd_wk > 0 .and. imp_physics==11 .and. lprecip_wk) then + do ii = 1, n_clouds_fwd_wk + iii=jcloud(ii) + call calc_gfdl_reff(rho_air,h,cloud(:,ii),cloud_names(iii),cloudefr(:,ii)) + end do + endif + + ! Calculate GFDL cloud fraction (if no cf in metguess table) based on PDF scheme + if ( icmask .and. n_clouds_fwd_wk > 0 .and. imp_physics==11 .and. lcalc_gfdl_cfrac ) then + cf_calc = zero + call calc_gfdl_cloudfrac(rho_air,h,qmix,cloud,hs,garea,cf_calc) + cf = cf_calc + icfs = 0 ! load cloud fraction into CRTM + endif + +! Interpolate level pressure to observation point for top interface + prsi(nsig+1)=(ges_prsi(ix ,iy ,nsig+1,itsig )*w00+ & + ges_prsi(ixp,iy ,nsig+1,itsig )*w10+ & + ges_prsi(ix ,iyp,nsig+1,itsig )*w01+ & + ges_prsi(ixp,iyp,nsig+1,itsig )*w11)*dtsig + & + (ges_prsi(ix ,iy ,nsig+1,itsigp)*w00+ & + ges_prsi(ixp,iy ,nsig+1,itsigp)*w10+ & + ges_prsi(ix ,iyp,nsig+1,itsigp)*w01+ & + ges_prsi(ixp,iyp,nsig+1,itsigp)*w11)*dtsigp + +! if(any(prsl0) then + allocate (tgas1d(nsig,n_ghg)) + do ig=1,n_ghg + if(size(gsi_chemguess_bundle)==1) then + call gsi_bundlegetpointer(gsi_chemguess_bundle(1), ghg_names(ig),tgasges_itsig ,ier) + do k=1,nsig +! choice: use the internal interpolation function +! or just explicitly code, not sure which one is efficient +! tgas1d(k,ig) = crtm_interface_interp(tgasges_itsig(ix:ixp,iy:iyp,:),& +! w_weights, & +! 1.0_r_kind) + tgas1d(k,ig) =(tgasges_itsig(ix ,iy ,k)*w00+ & + tgasges_itsig(ixp,iy ,k)*w10+ & + tgasges_itsig(ix ,iyp,k)*w01+ & + tgasges_itsig(ixp,iyp,k)*w11) + enddo + else + call gsi_bundlegetpointer(gsi_chemguess_bundle(itsig ),ghg_names(ig),tgasges_itsig ,ier) + call gsi_bundlegetpointer(gsi_chemguess_bundle(itsigp),ghg_names(ig),tgasges_itsigp,ier) + do k=1,nsig +! tgas1d(k,ig) = crtm_interface_interp(tgasges_itsig(ix:ixp,iy:iyp,k),& +! w_weights, & +! dtsig) + & +! crtm_interface_interp(tgasges_itsigp(ix:ixp,iy:iyp,k),& +! w_weights, & +! dtsigp) + + + tgas1d(k,ig) =(tgasges_itsig (ix ,iy ,k)*w00+ & + tgasges_itsig (ixp,iy ,k)*w10+ & + tgasges_itsig (ix ,iyp,k)*w01+ & + tgasges_itsig (ixp,iyp,k)*w11)*dtsig + & + (tgasges_itsigp(ix ,iy ,k)*w00+ & + tgasges_itsigp(ixp,iy ,k)*w10+ & + tgasges_itsigp(ix ,iyp,k)*w01+ & + tgasges_itsigp(ixp,iyp,k)*w11)*dtsigp + enddo + endif + enddo + endif + + +! Space-time interpolation of aerosol fields from sigma files + + if(n_actual_aerosols_wk>0)then + if(size(gsi_chemguess_bundle)==1) then + do ii=1,n_actual_aerosols_wk + call gsi_bundlegetpointer(gsi_chemguess_bundle(1),aerosol_names(ii),aeroges_itsig ,ier) + do k=1,nsig + aero(k,ii) =(aeroges_itsig(ix ,iy ,k)*w00+ & + aeroges_itsig(ixp,iy ,k)*w10+ & + aeroges_itsig(ix ,iyp,k)*w01+ & + aeroges_itsig(ixp,iyp,k)*w11) + end do + enddo + else + if (lread_ext_aerosol) then + do ii=1,n_actual_aerosols_wk + call gsi_bundlegetpointer(gsi_chemguess_bundle(itaer),aerosol_names(ii),aeroges_itsig,ier) + call gsi_bundlegetpointer(gsi_chemguess_bundle(itaerp),aerosol_names(ii),aeroges_itsigp,ier) + do k=1,nsig + aero(k,ii) =(aeroges_itsig (ix ,iy ,k)*w00+ & + aeroges_itsig (ixp,iy ,k)*w10+ & + aeroges_itsig (ix ,iyp,k)*w01+ & + aeroges_itsig (ixp,iyp,k)*w11)*dtaer + & + (aeroges_itsigp(ix ,iy ,k)*w00+ & + aeroges_itsigp(ixp,iy ,k)*w10+ & + aeroges_itsigp(ix ,iyp,k)*w01+ & + aeroges_itsigp(ixp,iyp,k)*w11)*dtaerp + end do + end do + else + do ii=1,n_actual_aerosols_wk + call gsi_bundlegetpointer(gsi_chemguess_bundle(itsig ),aerosol_names(ii),aeroges_itsig ,ier) + call gsi_bundlegetpointer(gsi_chemguess_bundle(itsigp),aerosol_names(ii),aeroges_itsigp,ier) + do k=1,nsig + aero(k,ii) =(aeroges_itsig (ix ,iy ,k)*w00+ & + aeroges_itsig (ixp,iy ,k)*w10+ & + aeroges_itsig (ix ,iyp,k)*w01+ & + aeroges_itsig (ixp,iyp,k)*w11)*dtsig + & + (aeroges_itsigp(ix ,iy ,k)*w00+ & + aeroges_itsigp(ixp,iy ,k)*w10+ & + aeroges_itsigp(ix ,iyp,k)*w01+ & + aeroges_itsigp(ixp,iyp,k)*w11)*dtsigp + end do + end do + end if ! lread_ext_aerosol + end if ! n_actual_aerosols_wk > 0 + do k=1,nsig + qs(k) = (gesqsat(ix ,iy ,k,itsig )*w00+ & + gesqsat(ixp,iy ,k,itsig )*w10+ & + gesqsat(ix ,iyp,k,itsig )*w01+ & + gesqsat(ixp,iyp,k,itsig )*w11)*dtsig + & + (gesqsat(ix ,iy ,k,itsigp)*w00+ & + gesqsat(ixp,iy ,k,itsigp)*w10+ & + gesqsat(ix ,iyp,k,itsigp)*w01+ & + gesqsat(ixp,iyp,k,itsigp)*w11)*dtsigp + rh(k) = q(k)/qs(k) + end do + endif + + +! Find tropopause height at observation + + trop5= one_tenth*(tropprs(ix,iy )*w00+tropprs(ixp,iy )*w10+ & + tropprs(ix,iyp)*w01+tropprs(ixp,iyp)*w11) + +! Zero atmosphere jacobian structures + + call crtm_atmosphere_zero(atmosphere_k(:,:)) + call crtm_surface_zero(surface_k(:,:)) + if (mixed_use) then + call crtm_atmosphere_zero(atmosphere_k_clr(:,:)) + call crtm_surface_zero(surface_k_clr(:,:)) + end if + call crtm_atmosphere_zero(atmosphere) + atmosphere(1)%level_pressure(0) = TOA_PRESSURE + + clw_guess = zero + ciw_guess = zero + rain_guess = zero + snow_guess = zero + + if (n_actual_aerosols_wk>0) then + do k = 1, nsig +! Convert mixing-ratio to concentration + ugkg_kgm2(k)=1.0e-9_r_kind*(prsi(k)-prsi(k+1))*r1000/grav + aero(k,:)=aero(k,:)*ugkg_kgm2(k) + enddo + endif + + sea = min(max(zero,data_s(ifrac_sea)),one) >= 0.99_r_kind + icmask = (sea .and. cld_sea_only_wk) .or. (.not. cld_sea_only_wk) + dprs_min = 9999.0_r_kind + idx700 = 1 + do k = 1,msig + +! Load profiles into extended RTM model layers + + kk = msig - k + 1 + atmosphere(1)%level_pressure(k) = r10*prsi_rtm(kk) + atmosphere(1)%pressure(k) = r10*prsl_rtm(kk) + + kk2 = klevel(kk) + atmosphere(1)%temperature(k) = h(kk2) + atmosphere(1)%absorber(k,1) = r1000*q(kk2)*c3(kk2) + if(iozs==0) then + atmosphere(1)%absorber(k,2) = poz(kk2) + else + atmosphere(1)%absorber(k,2) = O3_ID + endif + if (n_ghg > 0) then + do ig=1,n_ghg + j=min_n_absorbers+ ig + atmosphere(1)%absorber(k,j) = tgas1d(kk2,ig) + enddo + endif + + if (n_actual_aerosols_wk>0) then + aero_conc(k,:)=aero(kk2,:) + auxrh(k) =rh(kk2) + endif + +! Include cloud guess profiles in mw radiance computation + + if (n_clouds_fwd_wk>0) then + kgkg_kgm2=(atmosphere(1)%level_pressure(k)-atmosphere(1)%level_pressure(k-1))*r100/grav + if (cw_cv.or.ql_cv) then + if (icmask) then + c6(k) = kgkg_kgm2 + auxdp(k)=abs(prsi_rtm(kk+1)-prsi_rtm(kk))*r10 + auxq (k)=q(kk2) + + if (regional .and. (.not. wrf_mass_regional) .and. (.not. cold_start)) then + do ii=1,n_clouds_fwd_wk + cloud_cont(k,ii)=cloud(kk2,ii)*c6(k) + cloud_efr (k,ii)=cloudefr(kk2,ii) + end do + else + do ii=1,n_clouds_fwd_wk + cloud_cont(k,ii)=cloud(kk2,ii)*c6(k) + end do + end if + + clw_guess = clw_guess + cloud_cont(k,1) + ciw_guess = ciw_guess + cloud_cont(k,2) + if(n_clouds_fwd_wk > 2) rain_guess = rain_guess + cloud_cont(k,3) + if(n_clouds_fwd_wk > 3) snow_guess = snow_guess + cloud_cont(k,4) + + do ii=1,n_clouds_fwd_wk + if (ii==1 .and. atmosphere(1)%temperature(k)-t0c>-20.0_r_kind) & + cloud_cont(k,1)=max(1.001_r_kind*1.0E-6_r_kind, cloud_cont(k,1)) + if (ii==2 .and. atmosphere(1)%temperature(k) 1.0e-6_r_kind) then + cloud_efr (k,ii)=cloudefr(kk2,ii) + else + cloud_efr (k,ii)=zero + endif + enddo + + if (cloud_cont(k,1) >= 1.0e-6_r_kind) clw_guess = clw_guess + cloud_cont(k,1) + tcwv = tcwv + (atmosphere(1)%absorber(k,1)*0.001_r_kind)*c6(k) + do ii=1,n_clouds_fwd_wk + if (cloud_cont(k,ii) >= 1.0e-6_r_kind) hwp_guess(ii) = hwp_guess(ii) + cloud_cont(k,ii) + enddo + + !Add lower bound to all hydrometers + !note: may want to add lower bound value for effective radius + do ii=1,n_clouds_fwd_wk + if (trim(cloud_names_fwd(ii))=='ql' .and. atmosphere(1)%temperature(k)-t0c>-20.0_r_kind) & + cloud_cont(k,ii)=max(1.001_r_kind*1.0E-6_r_kind, cloud_cont(k,ii)) + if (trim(cloud_names_fwd(ii))=='qi' .and. atmosphere(1)%temperature(k)-20.0_r_kind) & + cloud_cont(k,ii)=max(1.001_r_kind*1.0E-6_r_kind, cloud_cont(k,ii)) + if (trim(cloud_names_fwd(ii))=='qs' .and. atmosphere(1)%temperature(k)0 .and. icmask) then + if ((hwp_guess(1)+hwp_guess(2))>=1.0e-06_r_kind) hwp_ratio = hwp_guess(1)/(hwp_guess(1)+hwp_guess(2)) + hwp_total = sum(hwp_guess(:)) + theta_700 = atmosphere(1)%temperature(idx700)*(r1000/atmosphere(1)%pressure(idx700))**rd_over_cp + theta_sfc = data_s(itsavg)*(r100/ps)**rd_over_cp + stability = theta_700 - theta_sfc + endif + +! Set clouds for CRTM + if(n_clouds_fwd_wk>0) then + atmosphere(1)%n_clouds = n_clouds_fwd_wk + call Set_CRTM_Cloud (msig,n_actual_clouds_wk,cloud_names,icmask,n_clouds_fwd_wk,cloud_cont,cloud_efr,jcloud,auxdp, & + atmosphere(1)%temperature,atmosphere(1)%pressure,auxq,atmosphere(1)%cloud,lprecip_wk) + endif + +! Set aerosols for CRTM + if(n_actual_aerosols_wk>0) then + call Set_CRTM_Aerosol ( msig, n_actual_aerosols_wk, n_aerosols_fwd_wk, aerosol_names, aero_conc, auxrh, & + atmosphere(1)%aerosol ) + endif + +! Call CRTM K Matrix model + + + error_status = 0 + if ( trim(obstype) /= 'modis_aod' .and. trim(obstype) /= 'viirs_aod' ) then + error_status = crtm_k_matrix(atmosphere,surface,rtsolution_k,& + geometryinfo,channelinfo(sensorindex:sensorindex),atmosphere_k,& + surface_k,rtsolution,options=options) + + if (mixed_use) then + ! Zero out data array in cloud structure + atmosphere(1)%n_clouds = 0 + error_status_clr = crtm_k_matrix(atmosphere,surface,rtsolution_k_clr,& + geometryinfo,channelinfo(sensorindex:sensorindex),atmosphere_k_clr,& + surface_k_clr,rtsolution_clr,options=options) + end if + else + do i=1,nchanl + rtsolution_k(i,1)%layer_optical_depth(:) = jac_pert + enddo + error_status = crtm_aod_k(atmosphere,rtsolution_k,& + channelinfo(sensorindex:sensorindex),rtsolution,atmosphere_k) + end if + +! If the CRTM returns an error flag, do not assimilate any channels for this ob +! and set the QC flag to 10 (done in setuprad). + + if (error_status /=0) then + write(6,*)myname_,': ***ERROR*** during crtm_k_matrix call ',& + error_status + end if + +! Calculate clear-sky Tb for AMSU-A over sea when allsky condition is on + if (n_clouds_fwd_wk>0 .and. present(tsim_clr) .and. (.not. mixed_use)) then + ! Zero out data array in cloud structure: water content, effective + ! radius and variance + + atmosphere(1)%n_clouds = 0 +! call crtm_cloud_zero(atmosphere(1)%cloud) + + ! call crtm forward model for clear-sky calculation + error_status = crtm_forward(atmosphere,surface,& + geometryinfo,channelinfo(sensorindex:sensorindex),& + rtsolution0,options=options) + ! If the CRTM returns an error flag, do not assimilate any channels for this ob + ! and set the QC flag to 10 (done in setuprad). + if (error_status /=0) then + write(6,*)'CRTM_FORWARD ***ERROR*** during crtm_forward call ',& + error_status + end if + endif + + if (trim(obstype) /= 'modis_aod' .and. trim(obstype) /= 'viirs_aod' ) then +! Secant of satellite zenith angle + + secant_term = one/cos(data_s(ilzen_ang)) + + if (mixed_use) then + do i=1,nchanl + if (lcloud4crtm_wk(i)<0) then + rtsolution(i,1) = rtsolution_clr(i,1) + rtsolution_k(i,1) = rtsolution_k_clr(i,1) + atmosphere_k(i,1) = atmosphere_k_clr(i,1) + surface_k(i,1) = surface_k_clr(i,1) + end if + end do + end if + +!$omp parallel do schedule(dynamic,1) private(i) & +!$omp private(total_od,k,kk,m,term,ii,cwj) + do i=1,nchanl +! Zero jacobian and transmittance arrays + do k=1,nsig + omix(k,i)=zero + temp(k,i)=zero + ptau5(k,i)=zero + wmix(k,i)=zero + end do + +! Simulated brightness temperatures + tsim(i)=rtsolution(i,1)%brightness_temperature + +! if (present(tcc)) tcc(i)=rtsolution(i,1)%total_cloud_cover !crtm2.3.x + + if (n_clouds_fwd_wk>0 .and. present(tsim_clr)) then + if (mixed_use) then + tsim_clr(i)=rtsolution_clr(i,1)%brightness_temperature + else + tsim_clr(i)=rtsolution0(i,1)%brightness_temperature + end if + end if + +! Estimated emissivity + emissivity(i) = rtsolution(i,1)%surface_emissivity + +! Emissivity sensitivities + emissivity_k(i) = rtsolution_k(i,1)%surface_emissivity + +! Surface temperature sensitivity + if(nst_gsi > 1 .and. (data_s(itz_tr) > half .and. data_s(itz_tr) <= one) ) then + ts(i) = surface_k(i,1)%water_temperature*data_s(itz_tr) + & + surface_k(i,1)%land_temperature + & + surface_k(i,1)%ice_temperature + & + surface_k(i,1)%snow_temperature + else + ts(i) = surface_k(i,1)%water_temperature + & + surface_k(i,1)%land_temperature + & + surface_k(i,1)%ice_temperature + & + surface_k(i,1)%snow_temperature + endif + + + if (abs(ts(i))small_wind) then + term = surface_k(i,1)%wind_speed * f10*f10 / surface(1)%wind_speed + uwind_k(i) = term * uu5 + vwind_k(i) = term * vv5 + else + uwind_k(i) = zero + vwind_k(i) = zero + endif + + + total_od = zero + +! Accumulate values from extended into model layers +! temp - temperature sensitivity +! wmix - moisture sensitivity +! omix - ozone sensitivity +! ptau5 - layer transmittance + do k=1,msig + kk = klevel(msig-k+1) + temp(kk,i) = temp(kk,i) + atmosphere_k(i,1)%temperature(k) + wmix(kk,i) = wmix(kk,i) + atmosphere_k(i,1)%absorber(k,1) + omix(kk,i) = omix(kk,i) + atmosphere_k(i,1)%absorber(k,2) + total_od = total_od + rtsolution(i,1)%layer_optical_depth(k) + ptau5(kk,i) = exp(-min(limit_exp,total_od*secant_term)) + end do + +! Load jacobian array + do k=1,nsig + +! Small sensitivities for temp + if (abs(temp(k,i)) + +! Deflate moisture jacobian above the tropopause. + if (itv>=0) then + do k=1,nsig + jacobian(itv+k,i)=temp(k,i)*c2(k) ! virtual temperature sensitivity + end do ! + endif + if (iqv>=0) then + m=ich(i) + do k=1,nsig + jacobian(iqv+k,i)=c5(k)*wmix(k,i)-c4(k)*temp(k,i) ! moisture sensitivity + if (prsi(k) < trop5) then + term = (prsi(k)-trop5)/(trop5-prsi(nsig)) + jacobian(iqv+k,i) = exp(ifactq(m)*term)*jacobian(iqv+k,i) + endif + end do ! + endif + if (ioz>=0) then +! if (.not. regional .or. use_gfs_ozone)then + do k=1,nsig + jacobian(ioz+k,i)=omix(k,i)*constoz ! ozone sensitivity + end do ! +! end if + endif + + if (n_clouds_fwd_wk>0 .and. n_clouds_jac_wk>0) then + if (lcloud4crtm_wk(i)<=0) then + do ii=1,n_clouds_jac_wk + do k=1,nsig + jacobian(icw(ii)+k,i) = zero + end do + end do + else + if (icmask) then + do ii=1,n_clouds_jac_wk + do k=1,nsig + cwj(k)=zero + end do + do k=1,msig + kk = klevel(msig-k+1) + cwj(kk) = cwj(kk) + atmosphere_k(i,1)%cloud(ii)%water_content(k)*c6(k) + end do + do k=1,nsig + jacobian(icw(ii)+k,i) = cwj(k) + end do ! + end do + else + do ii=1,n_clouds_jac_wk + do k=1,nsig + jacobian(icw(ii)+k,i) = zero + end do ! + end do + endif + endif + endif + + if (ius>=0) then + jacobian(ius+1,i)=uwind_k(i) ! surface u wind sensitivity + endif + if (ivs>=0) then + jacobian(ivs+1,i)=vwind_k(i) ! surface v wind sensitivity + endif + if (isst>=0) then + jacobian(isst+1,i)=ts(i) ! surface skin temperature sensitivity + endif + end do + + else ! obstype == '?????_aod' + ! initialize intent(out) variables that are not available with modis_aod + tzbgr = zero + sfc_speed = zero + tsim = zero + emissivity = zero + ts = zero + emissivity_k = zero + ptau5 = zero + temp = zero + wmix = zero + jaero = zero + if(present(layer_od)) layer_od = zero + if(present(jacobian_aero)) jacobian_aero = zero + do i=1,nchanl + do k=1,msig + kk = klevel(msig-k+1) + if(present(layer_od)) then + layer_od(kk,i) = layer_od(kk,i) + rtsolution(i,1)%layer_optical_depth(k) + endif + do ii=1,n_aerosols_jac_wk + if ( n_aerosols_jac_wk > n_aerosols_fwd_wk .and. ii == indx_p25 ) then + jaero(kk,i,ii) = jaero(kk,i,ii) + & + (0.5_r_kind*(0.78_r_kind*atmosphere_k(i,1)%aerosol(indx_dust1)%concentration(k) + & + 0.22_r_kind*atmosphere_k(i,1)%aerosol(indx_dust2)%concentration(k)) ) + else + jaero(kk,i,ii) = jaero(kk,i,ii) + atmosphere_k(i,1)%aerosol(ii)%concentration(k) + endif + enddo + enddo + if (present(jacobian_aero)) then + do k=1,nsig + do ii=1,n_aerosols_jac_wk + jacobian_aero(iaero_jac(ii)+k,i) = jaero(k,i,ii)*ugkg_kgm2(k) + end do + enddo + endif + enddo + endif + if (n_ghg >0) deallocate (tgas1d) + +! contains + +! pure function crtm_interface_interp(a,w,dtsig) result(intresult) +! real(r_kind), intent(in) :: a(:,:) +! real(r_kind), intent(in) :: w(:,:) +! real(r_kind), intent(in) :: dtsig +! real(r_kind) :: intresult +! integer :: i, j, n +! n = size(a,dim=1) +! intresult = 0.0_r_kind +! do j = 1, n +! do i = 1, n +! intresult = intresult + a(i,j)*w(i,j) +! enddo +! enddo +! intresult = intresult * dtsig +! end function crtm_interface_interp + end subroutine call_crtm + + subroutine calc_gfdl_reff(rho_air,tsen,qxmr,cloud_name,reff) + + use constants, only: zero, pi, t0c, half + implicit none + +! Declare passed variables + character(10) ,intent(in ) :: cloud_name + real(r_kind), dimension(nsig) ,intent(in ) :: rho_air ! [ kg/m3 ] + real(r_kind), dimension(nsig) ,intent(in ) :: tsen ! [ K ] + real(r_kind), dimension(nsig) ,intent(in ) :: qxmr ! [ kg/kg ] + real(r_kind), dimension(nsig) ,intent(inout) :: reff ! [ micron ] + +! Declare local variables + character(len=*), parameter :: myname_ = 'calc_gfdl_reff' + integer(i_kind) :: k + real(r_kind) :: tmp, qx + real(r_kind) :: reff_min, reff_max + + ! Parameters + real(r_kind), parameter :: qmin = 1.0e-12_r_kind ! [kg/kg ] + + ! Parameters for water cloud + real(r_kind), parameter :: ccn = 1.0e8_r_kind + real(r_kind), parameter :: rho_w = 1000.0_r_kind ! [kg/m3 ] + real(r_kind), parameter :: reff_w_min = 5.0_r_kind ! + real(r_kind), parameter :: reff_w_max = 10.0_r_kind + + ! Parameters for ice cloud (Hemisfield and mcFarquhar 1996) + real(r_kind), parameter :: rho_i = 890.0_r_kind ! [kg/m3 ] + real(r_kind), parameter :: beta = 1.22_r_kind + real(r_kind), parameter :: pice1 = 0.891_r_kind + real(r_kind), parameter :: pice2 = 0.920_r_kind + real(r_kind), parameter :: pice3 = 0.945_r_kind + real(r_kind), parameter :: pice4 = 0.969_r_kind + real(r_kind), parameter :: bice1 = 9.917_r_kind + real(r_kind), parameter :: bice2 = 9.337_r_kind + real(r_kind), parameter :: bice3 = 9.208_r_kind + real(r_kind), parameter :: bice4 = 9.387_r_kind + real(r_kind), parameter :: reff_i_min = 10_r_kind + real(r_kind), parameter :: reff_i_max = 150.0_r_kind + ! Parameters for rain (Lin 1983) + real(r_kind), parameter :: rho_r = 1000.0_r_kind ! [kg/m3 ] + real(r_kind), parameter :: no_r = 8.0e6_r_kind ! [m-4 ] + real(r_kind), parameter :: reff_r_min = 0.0_r_kind ! [micron] + real(r_kind), parameter :: reff_r_max = 10000.0_r_kind ! [micron] + real(r_kind), parameter :: alpha_r = 0.8_r_kind + real(r_kind), parameter :: gamma_r = 17.837789_r_kind + real(r_kind) :: lam_r + + ! Parameters for snow (Lin 1983) + real(r_kind), parameter :: rho_s = 100.0_r_kind ! [kg/m3 ] + real(r_kind), parameter :: no_s = 3.0e6_r_kind ! [m-4 ] + real(r_kind), parameter :: reff_s_min = 0.0_r_kind ! [micron] + real(r_kind), parameter :: reff_s_max = 10000.0_r_kind ! [micron] + real(r_kind), parameter :: alpha_s = 0.25_r_kind + real(r_kind), parameter :: gamma_s = 8.2850630_r_kind + real(r_kind) :: lam_s + ! Parameters for graupel (Lin 1983) + real(r_kind), parameter :: rho_g = 400.0_r_kind ! [kg/m3 ] + real(r_kind), parameter :: no_g = 4.0e6_r_kind ! [m-4 ] + real(r_kind), parameter :: reff_g_min = 0.0_r_kind ! [micron] + real(r_kind), parameter :: reff_g_max = 10000.0_r_kind ! [micron] + real(r_kind), parameter :: alpha_g = 0.5_r_kind + real(r_kind), parameter :: gamma_g = 11.631769_r_kind + real(r_kind) :: lam_g + + ! Cloud Water + if (trim(cloud_name)=='ql') then + reff_min = reff_w_min + reff_max = reff_w_max + do k = 1, nsig + qx = qxmr(k) * rho_air(k) ! convert mixing ratio (kg/kg) to water content (kg/m3) + if (qx > qmin) then + reff(k) = exp (1.0_r_kind / 3.0_r_kind * log ((3.0_r_kind * qx) / (4.0_r_kind * pi * rho_w * ccn))) * 1.0e6_r_kind + reff(k) = max(reff_min, min(reff_max, reff(k))) + ! reff(k) = 10.0_r_kind + else + reff(k) = zero + endif + enddo + ! Cloud Ice + else if (trim(cloud_name)=='qi') then + ! Hemisfield and mcFarquhar (1996) + reff_min = reff_i_min + reff_max = reff_i_max + do k = 1, nsig + qx = qxmr(k) * rho_air(k) ! convert mixing ratio (kg/kg) to water content (kg/m3) + if (qx > qmin) then + tmp = tsen(k)-t0c ! convert degree K to C + if (tmp < -50.0_r_kind) then + reff(k) = beta / bice1 * exp ((1.0_r_kind - pice1) * log (1.0e3_r_kind * qx)) * 1.0e3_r_kind + else if (tmp < -40.0_r_kind .and. tmp >= -50.0_r_kind) then + reff(k) = beta / bice2 * exp ((1.0_r_kind - pice2) * log (1.0e3_r_kind * qx)) * 1.0e3_r_kind + else if (tmp < -30.0_r_kind .and. tmp >= -40.0_r_kind) then + reff(k) = beta / bice3 * exp ((1.0_r_kind - pice3) * log (1.0e3_r_kind * qx)) * 1.0e3_r_kind + else + reff(k) = beta / bice4 * exp ((1.0_r_kind - pice4) * log (1.0e3_r_kind * qx)) * 1.0e3_r_kind + endif + reff(k) = max(reff_min, min(reff_max, reff(k))) + ! reff(k) = 30.0_r_kind + else + reff(k) = zero + endif + enddo + ! Rain + else if (trim(cloud_name)=='qr') then + reff_min = reff_r_min + reff_max = reff_r_max + do k = 1, nsig + qx = qxmr(k) * rho_air(k) ! convert mixing ratio (kg/kg) to water content (kg/m3) + if (qx > qmin) then + lam_r = exp (0.25_r_kind * log (pi * rho_r * no_r / qx )) + reff(k) = 0.5_r_kind * (3.0_r_kind/ lam_r ) * 1.0e6_r_kind + ! reff(k) = 0.5_r_kind * exp (log (gamma_r / 6.0_r_kind) / alpha_r) / lam_r * 1.0e6_r_kind !orig + reff(k) = max(reff_min, min(reff_max, reff(k))) + ! reff(k) = 300.0_r_kind + else + reff(k) = zero + endif + enddo + ! Snow + else if (trim(cloud_name)=='qs') then + reff_min = reff_s_min + reff_max = reff_s_max + do k = 1, nsig + qx = qxmr(k) * rho_air(k) ! convert mixing ratio (kg/kg) to water content (kg/m3) + if (qx > qmin) then + lam_s = exp (0.25_r_kind * log (pi * rho_s * no_s / qx )) + reff(k) = 0.5_r_kind * (3.0_r_kind/ lam_s ) * 1.0e6_r_kind + ! reff(k) = 0.5_r_kind * exp (log (gamma_s / 6.0_r_kind) / alpha_s) / lam_s * 1.0e6_r_kind !orig + reff(k) = max(reff_min, min(reff_max, reff(k))) + ! reff(k) = 600.0_r_kind + else + reff(k) = zero + endif + enddo + ! Graupel + else if (trim(cloud_name)=='qg') then + reff_min = reff_g_min + reff_max = reff_g_max + do k = 1, nsig + qx = qxmr(k)*rho_air(k) ! convert mixing ratio (kg/kg) to water content (kg/m3) + if (qx > qmin) then + lam_g = exp (0.25_r_kind * log (pi * rho_g * no_g / qx )) + reff(k) = 0.5_r_kind * (3.0_r_kind/ lam_g ) * 1.0e6_r_kind + ! reff(k) = 0.5_r_kind * exp (log (gamma_g / 6.0_r_kind) / alpha_g) / lam_g * 1.0e6_r_kind + reff(k) = max(reff_min, min(reff_max, reff(k))) + ! reff(k) = 600.0_r_kind + else + reff(k) = zero + endif + enddo + ! Mysterious + else + call die(myname_,"cannot recognize cloud name <"//trim(myname_)//">") + endif + + end subroutine calc_gfdl_reff + + subroutine calc_gfdl_cloudfrac(den,pt1,qv,cloud,hs,area,cfrac) +!$$$ subprogram documentation block +! . . . . +! subprogram: calc_gfdl_cloudfrac calculate GFDL cloud fraction +! based on PDF scheme +! +! prgmmr: eliu +! +! abstract: +! +! program history log: +! +! 2018-08-31 eliu +! +! input argument list: +! den - density of air +! pt1 - sensible temperature +! qv - specific humidity +! cloud - hydrometeor mixing ratio +! hs - surface elevation +! area - analysis grid area +! cfrac - cloud fraction +! +! output argument list: +! cfrac - cloud fraction +! +! language: f90 +! +!$$$ +!-------- + + use constants, only: one, zero, ten, half, grav + use constants, only: tice,t_wfr,rvgas,hlv,hlf,c_liq,c_ice,cp_air,cv_air + + implicit none +! +! Declare passed variables + real(r_kind), dimension(nsig) ,intent(in ) :: den ! air density[ kg/m3 ] + real(r_kind), dimension(nsig) ,intent(in ) :: pt1 ! sensible temperature[ K ] + real(r_kind), dimension(nsig) ,intent(in ) :: qv ! specific humudity + real(r_kind), dimension(nsig,n_clouds_fwd_wk) ,intent(in ) :: cloud ! hydroeteor mixing ratio + real(r_kind), intent(in ) :: hs ! surface elevation [ m ] + real(r_kind), intent(in ) :: area ! analysis grid area [ m2 ] + real(r_kind), dimension(nsig) ,intent(inout) :: cfrac ! cloud fraction +! +! Declare local variables + character(len=*), parameter :: myname_ = 'calc_gfdl_cloudfrac' + integer(i_kind) :: i,k + integer(i_kind) :: icloud_f + real(r_kind), parameter :: qrmin = 1.0e-8_r_kind + real(r_kind), parameter :: qvmin = 1.0e-20_r_kind ! min value for water vapor + real(r_kind), parameter :: qcmin = 1.0e-12_r_kind ! min value for cloud condensates + real(r_kind), parameter :: cld_min = 0.05_r_kind ! min value for cloud fraction + real(r_kind) :: tin,qsi,qsw + real(r_kind) :: qpz,q_cond,rh,hvar,cvm + real(r_kind) :: rqi,dq,d0_vap,dc_ice,lv00,li00 + real(r_kind) :: mc_air,c_air,c_vap + real(r_kind) :: cp_vap,cv_vap + real(r_kind) :: lhi,lhl,lcp2,icp2 + real(r_kind) :: q_plus,q_minus,qstar + real(r_kind) :: dw,dw_land,dw_ocean + real(r_kind) :: q_sol,q_liq + real(r_kind) :: qa + real(r_kind), dimension(nsig) :: ql,qi,qr,qs,qg + logical :: hydrostatic + +! parameters + icloud_f = 1 + cv_vap = 3.0_r_kind * rvgas ! heat capacity of water vapor at constant volume (non-hydrostatic) cv_vap=1384.5 + cp_vap = 4.0_r_kind * rvgas ! heat capacity of water voiar at constant pressure (hydrostatic) cp_vap=1846.0 + dw_land = 0.20_r_kind ! base value for subgrid variability over land + dw_ocean = 0.10_r_kind ! base value for subgrid variability over ocean + hydrostatic = .false. ! default + + if (hydrostatic) then + c_air = cp_air + c_vap = cp_vap + else + c_air = cv_air + c_vap = cv_vap + endif + +! Derived parameters + dc_ice = c_liq - c_ice ! isobaric heating/cooling (2213.5) + d0_vap = c_vap - c_liq ! d0_vap = cv_vap-cliq = -2801.0 +! dc_vap = c_vap - c_liq ! dc_vap = cp_vap-cliq = -2339.5 + lv00 = hlv - d0_vap * tice ! evaporation latent heat coefficient at 0 deg (3139057.82) + li00 = hlf - dc_ice * tice ! fusion latent heat coefficient at 0 deg (-271059.665) + +! ----------------------------------------------------------------------- +! calculate horizontal subgrid variability +! total water subgrid deviation in horizontal direction +! default area dependent form: use dx ~ 100 km as the base +! ----------------------------------------------------------------------- +! higher than 10 m is considered "land" and will have higher subgrid variability + dw = dw_ocean + (dw_land - dw_ocean) * min (one, abs(hs) / (ten * grav)) +! "scale - aware" subgrid variability: 100 - km as the base + hvar = min (0.2_r_kind, max (0.01_r_kind, dw * sqrt (sqrt (area) / 100.e3_r_kind))) + +! Load hydrometeor mixing ratio + ql=zero; qi=zero; qr=zero; qs=zero; qg=zero + do i = 1, n_clouds_fwd_wk + if (trim(cloud_names_fwd(i))=='ql') ql(:) = cloud(:,i) + if (trim(cloud_names_fwd(i))=='qi') qi(:) = cloud(:,i) + if (trim(cloud_names_fwd(i))=='qr') qr(:) = cloud(:,i) + if (trim(cloud_names_fwd(i))=='qs') qs(:) = cloud(:,i) + if (trim(cloud_names_fwd(i))=='qg') qg(:) = cloud(:,i) + enddo +! Loop each layer to calculate cloud fraction based on PDF scheme + do k = 1, nsig + + q_sol = qi(k) + qs(k) + qg(k) + q_liq = ql(k) + qr(k) + q_cond = q_liq + q_sol + qpz = qv(k) + q_cond ! total water qpz is conserved + + lhi = li00 + dc_ice * pt1(k) + lhl = lv00 + d0_vap * pt1(k) + mc_air = (one - qpz) * c_air + cvm = mc_air + (qv(k) + q_liq + q_sol) * c_vap + lcp2 = lhl / cvm + icp2 = lhi / cvm + + ! ----------------------------------------------------------------------- + ! use the "liquid - frozen water temperature" (tin) to compute saturated + ! specific humidity + ! ----------------------------------------------------------------------- + tin = pt1(k) - (lcp2 * q_cond+ icp2 * q_sol) ! minimum temperature + + ! ----------------------------------------------------------------------- + ! determine saturated specific humidity + ! ----------------------------------------------------------------------- + if (tin <= t_wfr) then + ! ice phase: + qstar = iqs1 (tin, den(k)) + elseif (tin >= tice) then + ! liquid phase: + qstar = wqs1 (tin, den(k)) + else + ! mixed phase: + qsi = iqs1 (tin, den(k)) + qsw = wqs1 (tin, den(k)) + if (q_cond > 1.e-6_r_kind) then + rqi = q_sol / q_cond + else + ! -------------------------------------------------------------- + ! mostly liquid water q_cond at initial cloud development stage + ! -------------------------------------------------------------- + rqi = (tice - tin) / (tice - t_wfr) + endif + qstar = rqi * qsi + (one - rqi) * qsw + endif + + ! ----------------------------------------------------------------------- + ! partial cloudiness by pdf: + ! assuming subgrid linear distribution in horizontal; this is + ! effectively a smoother for the + ! binary cloud scheme; qa = 0.5 if qstar (i) == qpz + ! ----------------------------------------------------------------------- + rh = qpz / qstar + ! ----------------------------------------------------------------------- + ! icloud_f = 0: bug - fixed + ! icloud_f = 1: old fvgfs gfdl) mp implementation + ! icloud_f = 2: binary cloud scheme (0 / 1) + ! ----------------------------------------------------------------------- + if (rh > 0.75_r_kind .and. qpz > 1.e-6_r_kind) then + dq = hvar * qpz + q_plus = qpz + dq + q_minus = qpz - dq + if (icloud_f == 2) then + if (qpz > qstar) then + qa = one + elseif (qstar < q_plus .and. q_cond > 1.e-6_r_kind) then + qa = ((q_plus - qstar) / dq) ** 2 + qa = min (one, qa) + else + qa = zero + endif + else + if (qstar < q_minus) then + qa = one + else + if (qstar < q_plus) then + if (icloud_f == 0) then + qa = (q_plus - qstar) / (dq + dq) + else + qa = (q_plus - qstar) / (2._r_kind * dq * (one - q_cond)) + endif + else + qa = zero + endif + ! impose minimum cloudiness if substantial q_cond exist + if (q_cond > 1.e-6_r_kind) then + qa = max (cld_min, qa) + endif + qa = min (one, qa) + endif + endif + else + qa = zero + endif + cfrac(k) = qa + enddo !k-loop + end subroutine calc_gfdl_cloudfrac + +subroutine qs_table(n) +!$$$ subprogram documentation block +! . . . . +! subprogram: qs_table GFDL saturation water vapor pressure table I +! +! prgmmr: eliu +! +! abstract: +! +! program history log: +! +! 2018-08-31 eliu +! +! input argument list: +! n - table index +! +! output argument list: +! table - saturation vapor pressure +! +! language: f90 +! +!$$$ +!-------- + + use constants, only: tice,e00,rvgas,hlv,hlf,cp_vap,c_liq,c_ice + + implicit none + + integer(i_kind), intent (in) :: n + + integer(i_kind) :: i + real(r_kind) :: delt = 0.1_r_kind + real(r_kind) :: tmin, tem, esh20 + real(r_kind) :: wice, wh2o, fac0, fac1, fac2 + real(r_kind) :: esupc (200) + + real(r_kind) :: dc_vap, dc_ice, d2ice + real(r_kind) :: lv0, li00, li2 + + ! Derived parameters + dc_vap = cp_vap - c_liq ! isobaric heating/cooling (-2339.5) + dc_ice = c_liq - c_ice ! isobaric heating/cooling (-2213.5) + d2ice = dc_vap + dc_ice ! isobaric heating/cooling ( -126) + lv0 = hlv - dc_vap * tice ! 3139057.82 + li00 = hlf - dc_ice * tice ! -271059.55 + li2 = lv0 + li00 ! 2867998.15 + tmin = tice - 160._r_kind + + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, 1600 + tem = tmin + delt * real(i - 1) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * li2 + fac2 = (d2ice * log(tem / tice) + fac1) / rvgas + table(i) = e00 * exp(fac2) + enddo + + ! -------------------------------------------------------- + ! compute es over water between - 20 deg c and 102 deg c. + ! -------------------------------------------------------- + + do i = 1, n-1400 + tem = 253.16_r_kind + delt * real(i - 1) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log(tem / tice) + fac1) / rvgas + esh20 = e00 * exp(fac2) + if (i <= 200) then + esupc(i) = esh20 + else + table(i + 1400) = esh20 + endif + enddo + + ! --------------------------------------------------------- + ! derive blended es over ice and supercooled water between + !- 20 deg c and 0 deg c + ! --------------------------------------------------------- + + do i = 1, 200 + tem = 253.16_r_kind + delt * real (i - 1) + wice = 0.05_r_kind * (tice - tem) + wh2o = 0.05_r_kind * (tem - 253.16_r_kind) + table(i + 1400) = wice * table(i + 1400) + wh2o * esupc(i) + enddo + +end subroutine qs_table + +subroutine qs_table2(n) +!$$$ subprogram documentation block +! . . . . +! subprogram: qs_table2 GFDL saturation water vapor pressure table III +! +! prgmmr: eliu +! +! abstract: +! +! program history log: +! +! 2018-08-31 eliu +! +! input argument list: +! n - table index +! +! output argument list: +! table2 - saturation vapor pressure +! +! language: f90 +! +!$$$ +!-------- + + use constants, only: tice,e00,rvgas,hlv,hlf,cp_vap,c_liq,c_ice + + implicit none + + integer(i_kind), intent (in) :: n + integer(i_kind) :: i, i0, i1 + + real(r_kind) :: delt = 0.1_r_kind + real(r_kind) :: tmin, tem0, tem1, fac0, fac1, fac2 + real(r_kind) :: dc_vap, dc_ice, d2ice + real(r_kind) :: lv0, li00, li2 + + ! Derived parameters + dc_vap = cp_vap - c_liq ! isobaric heating/cooling + dc_ice = c_liq - c_ice ! isobaric heating/cooling + d2ice = dc_vap + dc_ice ! isobaric heating/cooling + lv0 = hlv - dc_vap * tice + li00 = hlf - dc_ice * tice + li2 = lv0 + li00 + tmin = tice - 160._r_kind + + do i = 1, n + tem0 = tmin + delt * real(i - 1) + fac0 = (tem0 - tice) / (tem0 * tice) + if (i <= 1600) then + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * li2 + fac2 = (d2ice * log(tem0 / tice) + fac1) / rvgas + else + ! ----------------------------------------------------------------------- + ! compute es over water between 0 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * lv0 + fac2 = (dc_vap * log(tem0 / tice) + fac1) / rvgas + endif + table2 (i) = e00 * exp(fac2) + enddo + + ! ----------------------------------------------------------------------- + ! smoother around 0 deg c + ! ----------------------------------------------------------------------- + i0 = 1600 + i1 = 1601 + tem0 = 0.25_r_kind * (table2 (i0 - 1) + 2._r_kind * table (i0) + table2 (i0 + 1)) + tem1 = 0.25_r_kind * (table2 (i1 - 1) + 2._r_kind * table (i1) + table2 (i1 + 1)) + table2 (i0) = tem0 + table2 (i1) = tem1 + +end subroutine qs_table2 + +subroutine qs_tablew (n) +!$$$ subprogram documentation block +! . . . . +! subprogram: qs_tablew GFDL saturation water vapor pressure table II +! +! prgmmr: eliu +! +! abstract: +! +! program history log: +! +! 2018-08-31 eliu +! +! input argument list: +! n - table index +! +! output argument list: +! tablew - saturation vapor pressure +! +! language: f90 +! +!$$$ +!-------- + + use constants, only: tice,e00,rvgas,hlv,cp_vap,c_liq + + implicit none + + integer(i_kind), intent (in) :: n + + integer(i_kind) :: i + real(r_kind) :: delt = 0.1_r_kind + real(r_kind) :: tmin, tem, fac0, fac1, fac2 + real(r_kind) :: dc_vap, lv0 + + ! Derived parameters + dc_vap = cp_vap - c_liq ! isobaric heating/cooling + lv0 = hlv - dc_vap * tice + tmin = tice - 160._r_kind + + ! ----------------------------------------------------------------------- + ! compute es over water + ! ----------------------------------------------------------------------- + do i = 1, n + tem = tmin + delt * real(i - 1) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log(tem / tice) + fac1) / rvgas + tablew (i) = e00 * exp(fac2) + enddo +end subroutine qs_tablew + +real function iqs1 (ta, den) +!$$$ subprogram documentation block +! . . . . +! subprogram: iqsl computes the saturated specific humidity for table III +! (ice phase) +! prgmmr: eliu +! +! abstract: +! +! program history log: +! +! 2018-08-31 eliu +! +! input argument list: +! ta - sensible temeprature +! +! output argument list: +! den - density of air +! +! language: f90 +! +!$$$ +!-------- + use constants, only: tice,rvgas,one + implicit none + + ! water - ice phase; universal dry / moist formular using air density + ! input "den" can be either dry or moist air density + + real(r_kind), intent (in) :: ta, den + real(r_kind) :: es, ap1, tmin + integer(i_kind) :: it + + + tmin = tice - 160._r_kind + ap1 = 10._r_kind * dim (ta, tmin) + one + ap1 = min (2621._r_kind, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs1 = es / (rvgas * ta * den) + +end function iqs1 + +real function wqs1 (ta, den) +!$$$ subprogram documentation block +! . . . . +! subprogram: wqsl computes the saturated specific humidity for table II +! (liquid phase) +! prgmmr: eliu +! +! abstract: +! +! program history log: +! +! 2018-08-31 eliu +! +! input argument list: +! ta - sensible temeprature +! +! output argument list: +! den - density of air +! +! language: f90 +! +!$$$ +!-------- + use constants, only: tice,rvgas,one + implicit none + + ! pure water phase; universal dry / moist formular using air density + ! input "den" can be either dry or moist air density + + real(r_kind), intent (in) :: ta, den + real(r_kind) :: es, ap1, tmin + integer(i_kind) :: it + + + tmin = tice - 160._r_kind + ap1 = 10._r_kind * dim (ta, tmin) + one + ap1 = min (2621._r_kind, ap1) + it = ap1 + es = tablew(it) + (ap1 - it) * desw(it) + wqs1 = es / (rvgas * ta * den) + +end function wqs1 + +subroutine get_lai(data_s,nchanl,nreal,itime,ilate,lai_type,lai) +!$$$ subprogram documentation block +! . . . . +! subprogram: get_lai interpolate vegetation LAI data for call_crtm +! +! prgmmr: +! +! abstract: +! +! program history log: +! +! input argument list: +! data_s - array containing input data information +! nchanl - number of channels +! nreal - number of descriptor information in data_s +! itime - index of analysis relative obs time +! ilate - index of earth relative latitude (degrees) +! +! output argument list: +! lai - interpolated vegetation leaf-area-index for various types (13) +! +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ +!-------- + use kinds, only: r_kind,i_kind + use constants, only: zero + use obsmod, only: iadate + implicit none + +! Declare passed variables + integer(i_kind) ,intent(in ) :: nchanl,nreal + real(r_kind),dimension(nchanl+nreal) ,intent(in ) :: data_s + integer(i_kind) ,intent(in ) :: itime, ilate,lai_type + real(r_kind) ,intent( out) :: lai + +! Declare local variables + integer(i_kind),dimension(8)::obs_time,anal_time + real(r_kind),dimension(5) :: tmp_time + + integer(i_kind) jdow, jdoy, jday + real(r_kind) rjday + real(r_kind),dimension(3):: dayhf + data dayhf/15.5_r_kind, 196.5_r_kind, 380.5_r_kind/ + real(r_kind),dimension(13):: lai_min, lai_max + data lai_min/3.08_r_kind, 1.85_r_kind, 2.80_r_kind, 5.00_r_kind, 1.00_r_kind, & + 0.50_r_kind, 0.52_r_kind, 0.60_r_kind, 0.50_r_kind, 0.60_r_kind, & + 0.10_r_kind, 1.56_r_kind, 0.01_r_kind / + data lai_max/6.48_r_kind, 3.31_r_kind, 5.50_r_kind, 6.40_r_kind, 5.16_r_kind, & + 3.66_r_kind, 2.90_r_kind, 2.60_r_kind, 3.66_r_kind, 2.60_r_kind, & + 0.75_r_kind, 5.68_r_kind, 0.01_r_kind / + real(r_kind),dimension(2):: lai_season + real(r_kind) wei1s, wei2s + integer(i_kind) n1, n2, mm, mmm, mmp +! + anal_time=0 + obs_time=0 + tmp_time=zero + tmp_time(2)=data_s(itime) + anal_time(1)=iadate(1) + anal_time(2)=iadate(2) + anal_time(3)=iadate(3) + anal_time(5)=iadate(4) + call w3movdat(tmp_time,anal_time,obs_time) + + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(obs_time,jdow,jdoy,jday) + rjday=jdoy+obs_time(5)/24.0_r_kind + if(rjday.lt.dayhf(1)) rjday=rjday+365.0 + + DO MM=1,2 + MMM=MM + MMP=MM+1 + IF(RJDAY.GE.DAYHF(MMM).AND.RJDAY.LT.DAYHF(MMP)) THEN + N1=MMM + N2=MMP + EXIT + ENDIF + if(mm == 2)PRINT *,'WRONG RJDAY',RJDAY + ENDDO + WEI1S = (DAYHF(N2)-RJDAY)/(DAYHF(N2)-DAYHF(N1)) + WEI2S = (RJDAY-DAYHF(N1))/(DAYHF(N2)-DAYHF(N1)) + IF(N2.EQ.3) N2=1 + + lai_season(1) = lai_min(lai_type) + lai_season(2) = lai_max(lai_type) + if(data_s(ilate) < 0.0_r_kind) then + lai = wei1s * lai_season(n2) + wei2s * lai_season(n1) + else + lai = wei1s * lai_season(n1) + wei2s * lai_season(n2) + endif + + return + end subroutine get_lai + + end module crtm_interface diff --git a/src/cvsection.f90 b/src/gsi/cvsection.f90 similarity index 100% rename from src/cvsection.f90 rename to src/gsi/cvsection.f90 diff --git a/src/gsi/cwhydromod.f90 b/src/gsi/cwhydromod.f90 new file mode 100644 index 000000000..a27bba545 --- /dev/null +++ b/src/gsi/cwhydromod.f90 @@ -0,0 +1,489 @@ +module cwhydromod + +!$$$ module documentation block +! . . . . +! module: cwhydromod module for cw2hydro and its adjoint cw2hydro_ad +! prgmmr: yanqiu zhu +! +! abstract: module for cw2hydro and its adjoint cw2hydro_ad for cloudy radiance assimilation +! +! program history log: +! 2011-07-12 zhu - initial code +! +! +! subroutines included: +! sub init_cw2hydro +! sub destroy_cw2hydro +! sub cw2hydro +! sub cw2hydro_ad +! +! variable definitions: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds, only: r_kind,i_kind +use constants, only: zero,one,r0_05,t0c,fv,max_varname_length +use gridmod, only: lat2,lon2,nsig +use guess_grids, only: ges_tsen,ntguessig +use derivsmod, only: cwgues +use gsi_bundlemod, only: gsi_bundle +use gsi_bundlemod, only: gsi_bundlegetpointer +use gsi_metguess_mod, only: gsi_metguess_bundle +implicit none + +PRIVATE +PUBLIC cw2hydro_tl +PUBLIC cw2hydro_ad +PUBLIC cw2hydro_tl_hwrf +PUBLIC cw2hydro_ad_hwrf +real(r_kind),parameter :: t1=t0c-30.0_r_kind +real(r_kind),parameter :: t2=t0c-40.0_r_kind +real(r_kind),parameter :: coef1=0.05_r_kind +real(r_kind),parameter :: coef2=0.10_r_kind +real(r_kind),pointer,dimension(:,:,:):: fice=>NULL() +real(r_kind),pointer,dimension(:,:,:):: frain=>NULL() +real(r_kind),pointer,dimension(:,:,:):: frimef=>NULL() +integer(i_kind) :: istatus + + +contains + +subroutine cw2hydro(sval,clouds,nclouds) +!$$$ subprogram documentation block +! . . . . +! subprogram: cw2hydro +! prgmmr: yanqiu zhu +! +! abstract: Converts control variable cw to hydrometers +! +! program history log: +! 2011-07-12 zhu - initial code +! +! input argument list: +! sval - State variable +! wbundle - bundle for control variable +! clouds - cloud names +! +! output argument list: +! sval - State variable +! +!$$$ end documentation block + +implicit none + +! Declare passed variables +type(gsi_bundle),intent(inout):: sval +integer(i_kind),intent(in) :: nclouds +character(len=max_varname_length),intent(in):: clouds(nclouds) + +! Declare local variables +integer(i_kind) i,j,k,ic,istatus +real(r_kind),dimension(lat2,lon2,nsig) :: work +real(r_kind),pointer,dimension(:,:,:) :: sv_rank3 + +do k=1,nsig + do j=1,lon2 + do i=1,lat2 + work(i,j,k)=-r0_05*(ges_tsen(i,j,k,ntguessig)-t0c) + work(i,j,k)=max(zero,work(i,j,k)) + work(i,j,k)=min(one,work(i,j,k)) + end do + end do +end do + +! Split cw into cloud_lqw and cloud_ice, very simple for now +do ic=1,nclouds + call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) + if (istatus/=0) cycle + sv_rank3=zero + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + if (clouds(ic)=='ql') sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k)) + if (clouds(ic)=='qi') sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k) + end do + end do + end do +end do + +return +end subroutine cw2hydro + + +subroutine cw2hydro_tl(sval,wbundle,clouds,nclouds) +!$$$ subprogram documentation block +! . . . . +! subprogram: cw2hydro_tl +! prgmmr: yanqiu zhu +! +! abstract: Tangent linear of converting control variable cw to hydrometers +! +! program history log: +! 2011-07-12 zhu - initial code +! 2014-04-24 zhu - comment out temperature increment impact on cloud for now +! +! input argument list: +! sval - State variable +! wbundle - bundle for control variable +! clouds - cloud names +! +! output argument list: +! sval - State variable +! +!$$$ end documentation block + +implicit none + +! Declare passed variables +type(gsi_bundle),intent(inout):: sval +type(gsi_bundle),intent(in):: wbundle +integer(i_kind),intent(in) :: nclouds +!real(r_kind),intent(in) :: sv_tsen(lat2,lon2,nsig) +character(len=max_varname_length),intent(in):: clouds(nclouds) + +! Declare local variables +integer(i_kind) i,j,k,ic,istatus +real(r_kind),dimension(lat2,lon2,nsig) :: work0 +! real(r_kind),dimension(lat2,lon2,nsig) :: work +real(r_kind),pointer,dimension(:,:,:) :: cv_cw +real(r_kind),pointer,dimension(:,:,:) :: sv_rank3 + +! Get pointer to required control variable +call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) + +do k=1,nsig + do j=1,lon2 + do i=1,lat2 + work0(i,j,k)=-r0_05*(ges_tsen(i,j,k,ntguessig)-t0c) + work0(i,j,k)=max(zero,work0(i,j,k)) + work0(i,j,k)=min(one,work0(i,j,k)) + +! work(i,j,k)=-r0_05*sv_tsen(i,j,k) +! if (work0(i,j,k)<=zero) work(i,j,k)=zero +! if (work0(i,j,k)>=one) work(i,j,k)=zero + end do + end do +end do + +! Split cv_cw into cloud_lqw and cloud_ice, very simple for now +do ic=1,nclouds + call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) + if (istatus/=0) cycle + sv_rank3=zero + do k=1,nsig + do j=1,lon2 + do i=1,lat2 +! if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k) +! if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k) + if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k)) + if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k) + end do + end do + end do +end do + +return +end subroutine cw2hydro_tl + +subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds) +!$$$ subprogram documentation block +! . . . . +! subprogram: cw2hydro_ad +! prgmmr: yanqiu zhu +! +! abstract: adjoint of cw2hydro +! +! program history log: +! 2011-07-12 zhu - initial code +! 2014-04-24 zhu - comment out temperature increment impact on cloud for now +! +! input argument list: +! rval - State variable +! wbundle - work bundle +! clouds - cloud names +! +! output argument list: +! wbundle +! +!$$$ end documentation block + +implicit none + +! Declare passed variables +type(gsi_bundle),intent(in):: rval +type(gsi_bundle),intent(inout):: wbundle +integer(i_kind),intent(in) :: nclouds +character(len=max_varname_length),intent(in):: clouds(nclouds) + +! Declare local variables +integer(i_kind) i,j,k,ic,istatus +real(r_kind),dimension(lat2,lon2,nsig) :: work0 +real(r_kind),pointer,dimension(:,:,:) :: rv_rank3 +real(r_kind),pointer,dimension(:,:,:) :: cv_cw + +! Get pointer to required control variable +call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) +cv_cw=zero + +do k=1,nsig + do j=1,lon2 + do i=1,lat2 + work0(i,j,k)=-r0_05*(ges_tsen(i,j,k,ntguessig)-t0c) + work0(i,j,k)=max(zero,work0(i,j,k)) + work0(i,j,k)=min(one,work0(i,j,k)) + end do + end do +end do + +do ic=1,nclouds + call gsi_bundlegetpointer (rval,clouds(ic),rv_rank3,istatus) + if (istatus/=0) cycle + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + if (clouds(ic)=='ql') then + cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*(one-work0(i,j,k)) + rv_rank3(i,j,k)=zero + end if + + if (clouds(ic)=='qi') then + cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*work0(i,j,k) + rv_rank3(i,j,k)=zero + end if + + end do + end do + end do +end do + +return +end subroutine cw2hydro_ad + +subroutine cw2hydro_tl_hwrf(sval,wbundle,sv_tsen) +!$$$ subprogram documentation block +! . . . . +! subprogram: cw2hydro_tl_hwrf +! prgmmr: Ting-Chi Wu +! +! abstract: Tangent linear of converting control variable cw to hydrometers +! +! program history log: +! 2017-07-19 T.-C. Wu - modified from cw2hydro_tl to use 6 instead of 2 hydrometeors +! +! input argument list: +! sval - state variable +! wbundle - bundel for control variable +! clouds - cloud names +! +! output argument list: +! sval - state variable +! +!$$$ end documentation block + +implicit none + +! Declare passed variables +type(gsi_bundle), intent(inout):: sval +type(gsi_bundle), intent(in ):: wbundle +real(r_kind), intent(in ):: sv_tsen(lat2,lon2,nsig) + +! Declare local variables +integer(i_kind) i,j,k,istatus +real(r_kind) coef, dcoefdt +real(r_kind) dicedt, dicedcw, dprecicedt, dprecicedcw +real(r_kind), pointer, dimension(:,:,:) :: cv_cw +real(r_kind), pointer, dimension(:,:,:) :: sv_cw, sv_ql, sv_qi, sv_qr, sv_qs, sv_qg, sv_qh + +call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig), 'fice', fice,istatus) +call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig), 'frain', frain,istatus) +call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'frimef', frimef,istatus) + +! Split cw into cloud_liquid, cloud_ice, rain, snow, graupel, and hail +! (cloud_calc in cloud_efr_mod.f90) +call gsi_bundlegetpointer (wbundle, 'cw', cv_cw, istatus) +call gsi_bundlegetpointer (sval, 'cw', sv_cw, istatus) +call gsi_bundlegetpointer (sval, 'ql', sv_ql, istatus) +call gsi_bundlegetpointer (sval, 'qi', sv_qi, istatus) +call gsi_bundlegetpointer (sval, 'qr', sv_qr, istatus) +call gsi_bundlegetpointer (sval, 'qs', sv_qs, istatus) +call gsi_bundlegetpointer (sval, 'qg', sv_qg, istatus) +call gsi_bundlegetpointer (sval, 'qh', sv_qh, istatus) + +sv_ql=zero +sv_qi=zero +sv_qr=zero +sv_qs=zero +sv_qg=zero +sv_qh=zero +sv_cw=zero + +do k=1,nsig + do j=1,lon2 + do i=1,lat2 + sv_ql(i,j,k)=cv_cw(i,j,k)*(one-fice(i,j,k))*(one-frain(i,j,k)) ! ql is not a function of T + sv_qr(i,j,k)=cv_cw(i,j,k)*(one-fice(i,j,k))*frain(i,j,k) ! qr is not a function of T + + if ( ges_tsen(i,j,k,ntguessig) > t0c-30.0_r_kind) then + dicedcw = 0.05_r_kind*fice(i,j,k) + dprecicedcw = 0.95_r_kind*fice(i,j,k) + dicedt = zero + dprecicedt = zero + else + coef=(ges_tsen(i,j,k,ntguessig)-t2)/(t1-t2)*coef1+ & + (ges_tsen(i,j,k,ntguessig)-t1)/(t1-t2)*coef2 + dcoefdt = one/(t1-t2)*coef1+one/(t1-t2)*coef2 + dicedcw = coef*fice(i,j,k) + dprecicedcw = (one-coef)*fice(i,j,k) + dicedt = dcoefdt*cwgues(i,j,k)*fice(i,j,k) + dprecicedt = -dcoefdt*cwgues(i,j,k)*fice(i,j,k) + endif + + sv_qi(i,j,k)=cv_cw(i,j,k)*dicedcw+sv_tsen(i,j,k)*dicedt + + if (frimef(i,j,k)>=one .and. frimef(i,j,k)<=5.0_r_kind) then + sv_qs(i,j,k)=cv_cw(i,j,k)*dprecicedcw+sv_tsen(i,j,k)*dprecicedt + endif + if (frimef(i,j,k)>5.0_r_kind .and. frimef(i,j,k)<=20.0_r_kind) then + sv_qg(i,j,k)=cv_cw(i,j,k)*dprecicedcw+sv_tsen(i,j,k)*dprecicedt + endif + if (frimef(i,j,k)>20.0_r_kind) then + sv_qh(i,j,k)=cv_cw(i,j,k)*dprecicedcw+sv_tsen(i,j,k)*dprecicedt + endif + + end do + end do +end do + +sv_cw=cv_cw + +return + +end subroutine cw2hydro_tl_hwrf + +subroutine cw2hydro_ad_hwrf(rval,wbundle,rv_tsen) +!$$$ subprogram documentation block +! . . . . +! subprogram: cw2hydro_ad_hwrf +! prgmmr: Ting-Chi Wu +! +! abstract: adjoint of cw2hydro_hwrf (subroutine cloud_calc) +! +! program history log: +! 2017-07-19 T.-C. Wu - modified from cw2hydro_ad to use 6 instead of 2 hydrometeors +! +! input argument list: +! rval - state variable +! wbundle - work bundle +! +! output argument list: +! wbundle +! +!$$$ end documentation block + +implicit none + +! Declare passed variables +type(gsi_bundle), intent(in ):: rval +type(gsi_bundle), intent(inout):: wbundle +real(r_kind),intent(inout) :: rv_tsen(:,:,:) + +! Declare local variables +integer(i_kind) i,j,k, istatus +real(r_kind) coef, dcoefdt +real(r_kind) dicedt, dicedcw, dprecicedt, dprecicedcw +real(r_kind) work +real(r_kind), pointer, dimension(:,:,:) :: cv_cw +real(r_kind), pointer, dimension(:,:,:) :: rv_cw, rv_ql, rv_qi, rv_qr, rv_qs, rv_qg, rv_qh + +call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig), 'fice', fice,istatus) +call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig), 'frain', frain,istatus) +call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'frimef', frimef,istatus) + +call gsi_bundlegetpointer (wbundle, 'cw', cv_cw, istatus) +call gsi_bundlegetpointer (rval, 'cw', rv_cw, istatus) +call gsi_bundlegetpointer (rval, 'ql', rv_ql, istatus) +call gsi_bundlegetpointer (rval, 'qi', rv_qi, istatus) +call gsi_bundlegetpointer (rval, 'qr', rv_qr, istatus) +call gsi_bundlegetpointer (rval, 'qs', rv_qs, istatus) +call gsi_bundlegetpointer (rval, 'qg', rv_qg, istatus) +call gsi_bundlegetpointer (rval, 'qh', rv_qh, istatus) + +do k=1,nsig + do j=1,lon2 + do i=1,lat2 + rv_cw(i,j,k)=rv_cw(i,j,k)+rv_ql(i,j,k)*(one-fice(i,j,k))*(one-frain(i,j,k)) + rv_ql(i,j,k)=zero +! rv_tsen(i,j,k)=rv_tsen(i,j,k)+zero ! ql is not a function of T + end do + end do +end do +do k=1,nsig + do j=1,lon2 + do i=1,lat2 + rv_cw(i,j,k)=rv_cw(i,j,k)+rv_qr(i,j,k)*(one-fice(i,j,k))*frain(i,j,k) + rv_qr(i,j,k)=zero +! rv_tsen(i,j,k)=rv_tsen(i,j,k)+zero ! qr is not a function of T + end do + end do +end do + + +do k=1,nsig + do j=1,lon2 + do i=1,lat2 + if ( ges_tsen(i,j,k,ntguessig) > t0c-30.0_r_kind) then + dicedcw = 0.05_r_kind*fice(i,j,k) + dprecicedcw = 0.95_r_kind*fice(i,j,k) + dicedt = zero + dprecicedt = zero + else + coef=(ges_tsen(i,j,k,ntguessig)-t2)/(t1-t2)*coef1+ & + (ges_tsen(i,j,k,ntguessig)-t1)/(t1-t2)*coef2 + dcoefdt = one/(t1-t2)*coef1+one/(t1-t2)*coef2 + + dicedcw = coef*fice(i,j,k) + dprecicedcw = (one-coef)*fice(i,j,k) + dicedt = dcoefdt*cwgues(i,j,k)*fice(i,j,k) + dprecicedt = -dcoefdt*cwgues(i,j,k)*fice(i,j,k) + endif + + work=zero + work=work+rv_qi(i,j,k)*dicedt + rv_cw(i,j,k)=rv_cw(i,j,k)+rv_qi(i,j,k)*dicedcw + rv_qi(i,j,k)=zero + rv_tsen(i,j,k)=rv_tsen(i,j,k)+work + if (frimef(i,j,k)>=one .and. frimef(i,j,k)<=5.0_r_kind) then + work=work+rv_qs(i,j,k)*dprecicedt + rv_cw(i,j,k)=rv_cw(i,j,k)+rv_qs(i,j,k)*dprecicedcw + rv_qs(i,j,k)=zero + rv_tsen(i,j,k)=rv_tsen(i,j,k)+work + endif + if (frimef(i,j,k)>5.0_r_kind .and. frimef(i,j,k)<=20.0_r_kind) then + work=work+rv_qg(i,j,k)*dprecicedt + rv_cw(i,j,k)=rv_cw(i,j,k)+rv_qg(i,j,k)*dprecicedcw + rv_qg(i,j,k)=zero + rv_tsen(i,j,k)=rv_tsen(i,j,k)+work + endif + if (frimef(i,j,k)>20.0_r_kind) then + work=work+rv_qh(i,j,k)*dprecicedt + rv_cw(i,j,k)=rv_cw(i,j,k)+rv_qh(i,j,k)*dprecicedcw + rv_qh(i,j,k)=zero + rv_tsen(i,j,k)=rv_tsen(i,j,k)+work + endif + end do + end do +end do + +cv_cw=rv_cw +rv_cw=zero + +return + +end subroutine cw2hydro_ad_hwrf + + +end module cwhydromod diff --git a/src/derivsmod.f90 b/src/gsi/derivsmod.f90 similarity index 93% rename from src/derivsmod.f90 rename to src/gsi/derivsmod.f90 index b29bd335c..b251ac774 100644 --- a/src/derivsmod.f90 +++ b/src/gsi/derivsmod.f90 @@ -11,6 +11,9 @@ module derivsmod ! 2014-06-18 Carley - add lgues and dlcbasdlog ! 2015-07-10 Pondeca - add cldchgues and dcldchdlog ! 2016-05-10 Thomas - remove references to cwgues0 +! 2019-05-08 mtong - replace set_ with init_anadv +! 2019-05-08 eliu - recover logic (drv_set_) to indicate the derivative +! vars are allocated and defined ! ! public subroutines: ! drv_initialized - initialize name of fields to calc derivs for @@ -23,6 +26,7 @@ module derivsmod ! dvars2d, dvars3d - names of 2d/3d derivatives ! dsrcs2d, dsrcs3d - names of where original fields reside ! drv_initialized - flag indicating initialization status +! drv_set_ - flag indicating the variables are allocated and defined ! ! attributes: ! language: f90 @@ -53,6 +57,7 @@ module derivsmod private public :: drv_initialized +public :: drv_set_ public :: create_ges_derivatives public :: destroy_ges_derivatives @@ -60,10 +65,11 @@ module derivsmod public :: gsi_yderivative_bundle public :: dvars2d, dvars3d public :: dsrcs2d, dsrcs3d -public :: cwgues +public :: cwgues,cfgues public :: ggues,vgues,pgues,lgues,dvisdlog,dlcbasdlog public :: w10mgues,howvgues,cldchgues,dcldchdlog public :: qsatg,qgues,dqdt,dqdrh,dqdp +public :: init_anadv logical :: drv_initialized = .false. @@ -75,16 +81,16 @@ module derivsmod real(r_kind),allocatable,dimension(:,:,:):: qsatg,qgues,dqdt,dqdrh,dqdp real(r_kind),allocatable,dimension(:,:):: ggues,vgues,pgues,lgues,dvisdlog,dlcbasdlog real(r_kind),allocatable,dimension(:,:):: w10mgues,howvgues,cldchgues,dcldchdlog -real(r_kind),target,allocatable,dimension(:,:,:):: cwgues +real(r_kind),target,allocatable,dimension(:,:,:):: cwgues,cfgues ! below this point: declare vars not to be made public character(len=*),parameter:: myname='derivsmod' -logical,save :: drv_set_=.false. +logical,save :: drv_set_=.false. integer(i_kind),allocatable,dimension(:):: levels contains -subroutine set_ (iamroot,rcname) +subroutine init_anadv !$$$ subprogram documentation block ! . . . . ! subprogram: define derivatives @@ -97,6 +103,9 @@ subroutine set_ (iamroot,rcname) ! program history log: ! 2013-09-27 todling - initial code ! 2014-02-03 todling - negative levels mean rank-3 array +! 2019-05-08 mtong - replace set_ with init_anadv +! 2019-05-08 eliu - recover logic (drv_set_) to indicate the derivative +! vars are allocated and defined ! ! input argument list: see Fortran 90 style document below ! @@ -107,14 +116,12 @@ subroutine set_ (iamroot,rcname) ! machine: ! !$$$ end subprogram documentation block -use file_utility, only : get_lun use mpeu_util, only: gettablesize use mpeu_util, only: gettable use mpeu_util, only: getindex implicit none -logical,optional,intent(in) :: iamroot ! optional root processor id -character(len=*),optional,intent(in) :: rcname ! optional input filename +character(len=*),parameter:: rcname='anavinfo' character(len=*),parameter::myname_=myname//'*set_' character(len=*),parameter:: tbname='state_derivatives::' @@ -124,20 +131,11 @@ subroutine set_ (iamroot,rcname) character(len=256),allocatable,dimension(:):: utable character(len=max_varname_length),allocatable,dimension(:):: vars character(len=max_varname_length),allocatable,dimension(:):: sources -logical iamroot_,matched +logical matched -if(drv_set_) return +if(drv_set_) return -iamroot_=mype==0 -if(present(iamroot)) iamroot_=iamroot - -! load file -if (present(rcname)) then - luin=get_lun() - open(luin,file=trim(rcname),form='formatted') -else - luin=5 -endif +open(newunit=luin,file=trim(rcname),form='formatted') ! Scan file for desired table first ! and get size of table @@ -235,7 +233,7 @@ subroutine set_ (iamroot,rcname) endif enddo -if (iamroot_) then +if (mype == 0) then write(6,*) myname_,': DERIVATIVE VARIABLES: ' write(6,*) myname_,': 2D-DERV STATE VARIABLES: ' do ii=1,n2d @@ -248,9 +246,9 @@ subroutine set_ (iamroot,rcname) end if deallocate(vars,nlevs,sources) -drv_set_=.true. +drv_set_=.true. - end subroutine set_ + end subroutine init_anadv subroutine create_ges_derivatives(switch_on_derivatives,nfldsig) !$$$ subprogram documentation block @@ -289,9 +287,6 @@ subroutine create_ges_derivatives(switch_on_derivatives,nfldsig) if (.not.switch_on_derivatives) return if (drv_initialized) return -! initialize table with fields - call set_(rcname='anavinfo') - ! create derivative grid call GSI_GridCreate(grid,lat2,lon2,nsig) @@ -451,6 +446,15 @@ subroutine create_auxiliar_ end do end do + allocate(cfgues(lat2,lon2,nsig)) + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + cfgues(i,j,k)=zero + end do + end do + end do + if (getindex(svars2d,'gust')>0) then allocate(ggues(lat2,lon2)) do j=1,lon2 @@ -551,6 +555,7 @@ subroutine destroy_auxiliar_ if(allocated(qsatg)) deallocate(qsatg) if(allocated(qgues)) deallocate(qgues) if(allocated(cwgues)) deallocate(cwgues) + if(allocated(cfgues)) deallocate(cfgues) if(allocated(ggues)) deallocate(ggues) if(allocated(vgues)) deallocate(vgues) if(allocated(dvisdlog)) deallocate(dvisdlog) diff --git a/src/deter_sfc_mod.f90 b/src/gsi/deter_sfc_mod.f90 similarity index 84% rename from src/deter_sfc_mod.f90 rename to src/gsi/deter_sfc_mod.f90 index 6df0b546a..3c88aabb2 100644 --- a/src/deter_sfc_mod.f90 +++ b/src/gsi/deter_sfc_mod.f90 @@ -16,6 +16,7 @@ module deter_sfc_mod ! sub deter_sfc2 ! sub deter_sfc_fov ! sub deter_sfc_amsre_low +! sub deter_sfc_gmi ! sub deter_zsfc_model ! sub reduce2full ! sub init_sfc @@ -48,6 +49,7 @@ module deter_sfc_mod public deter_sfc2 public deter_sfc_fov public deter_sfc_amsre_low + public deter_sfc_gmi public deter_zsfc_model contains @@ -1018,150 +1020,149 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,& subgrid_lengths_x = nint(one/dx_fov) + 1 subgrid_lengths_y = nint(one/dy_fov) + 1 - 99 continue + loop1:do -! If the fov is very small compared to the model grid, it -! is more computationally efficient to take a simple average. +! If the fov is very small compared to the model grid, it +! is more computationally efficient to take a simple average. - if (subgrid_lengths_x > 7 .or. subgrid_lengths_y > 7) then -! print*,'FOV MUCH SMALLER THAN MODEL GRID POINTS, TAKE SIMPLE AVERAGE.' - call init_sfc(sfc_sum) - if (regional) then - do j = jstart, jend - do i = min_i(j), max_i(j) - call time_int_sfc(i,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) - power = one - call accum_sfc(i,j,power,sfc_mdl,sfc_sum) + if (subgrid_lengths_x > 7 .or. subgrid_lengths_y > 7) then +! print*,'FOV MUCH SMALLER THAN MODEL GRID POINTS, TAKE SIMPLE AVERAGE.' + call init_sfc(sfc_sum) + if (regional) then + do j = jstart, jend + do i = min_i(j), max_i(j) + call time_int_sfc(i,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) + power = one + call accum_sfc(i,j,power,sfc_mdl,sfc_sum) + enddo enddo - enddo - else ! global - do j = jstart, jend - do i = min_i(j), max_i(j) - ii = i - call reduce2full(ii,j,ifull) - call time_int_sfc(ifull,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) - power = one - call accum_sfc(ifull,j,power,sfc_mdl,sfc_sum) + else ! global + do j = jstart, jend + do i = min_i(j), max_i(j) + ii = i + call reduce2full(ii,j,ifull) + call time_int_sfc(ifull,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) + power = one + call accum_sfc(ifull,j,power,sfc_mdl,sfc_sum) + enddo enddo - enddo + endif + exit loop1 endif - call calc_sfc(sfc_sum,isflg,idomsfc,sfcpct,vfr,sty,vty,sm,stp,ff10,sfcr,zz,sn,ts,tsavg) - deallocate(max_i,min_i) - return - endif - mid = (float(subgrid_lengths_y)-one)/two + one - del = one/ float(subgrid_lengths_y) + mid = (float(subgrid_lengths_y)-one)/two + one + del = one/ float(subgrid_lengths_y) - allocate (y_off(subgrid_lengths_y)) + allocate (y_off(subgrid_lengths_y)) - do i= 1, subgrid_lengths_y - y_off(i) = (float(i)-mid)*del - enddo + do i= 1, subgrid_lengths_y + y_off(i) = (float(i)-mid)*del + enddo - mid = (float(subgrid_lengths_x)-one)/two + one - del = one / float(subgrid_lengths_x) + mid = (float(subgrid_lengths_x)-one)/two + one + del = one / float(subgrid_lengths_x) - allocate (x_off(subgrid_lengths_x)) - do i= 1, subgrid_lengths_x - x_off(i) = (float(i)-mid)*del - enddo + allocate (x_off(subgrid_lengths_x)) + do i= 1, subgrid_lengths_x + x_off(i) = (float(i)-mid)*del + enddo -! Determine the surface characteristics by integrating over the -! fov. +! Determine the surface characteristics by integrating over the +! fov. - call init_sfc(sfc_sum) + call init_sfc(sfc_sum) - if (regional) then - do j = jstart, jend - do i = min_i(j), max_i(j) - call time_int_sfc(i,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) - do jjj = 1, subgrid_lengths_y - y = float(j) + y_off(jjj) - do iii = 1, subgrid_lengths_x - x = float(i) + x_off(iii) - call txy2ll(x,y,lon_rad,lat_rad) - lat_mdl = lat_rad*rad2deg - lon_mdl = lon_rad*rad2deg - if (lon_mdl < zero) lon_mdl = lon_mdl + 360._r_kind - if (lon_mdl >= 360._r_kind) lon_mdl = lon_mdl - 360._r_kind - if (fov_flag=="crosstrk")then - call inside_fov_crosstrk(instr,ifov,sat_aziang, & - dlat_earth_deg,dlon_earth_deg, & - lat_mdl, lon_mdl, & - expansion, ichan, power ) - elseif (fov_flag=="conical")then - call inside_fov_conical(instr,ichan,sat_aziang, & - dlat_earth_deg,dlon_earth_deg,& - lat_mdl, lon_mdl, & - expansion, power ) - endif - call accum_sfc(i,j,power,sfc_mdl,sfc_sum) + if (regional) then + do j = jstart, jend + do i = min_i(j), max_i(j) + call time_int_sfc(i,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) + do jjj = 1, subgrid_lengths_y + y = float(j) + y_off(jjj) + do iii = 1, subgrid_lengths_x + x = float(i) + x_off(iii) + call txy2ll(x,y,lon_rad,lat_rad) + lat_mdl = lat_rad*rad2deg + lon_mdl = lon_rad*rad2deg + if (lon_mdl < zero) lon_mdl = lon_mdl + 360._r_kind + if (lon_mdl >= 360._r_kind) lon_mdl = lon_mdl - 360._r_kind + if (fov_flag=="crosstrk")then + call inside_fov_crosstrk(instr,ifov,sat_aziang, & + dlat_earth_deg,dlon_earth_deg, & + lat_mdl, lon_mdl, & + expansion, ichan, power ) + elseif (fov_flag=="conical")then + call inside_fov_conical(instr,ichan,sat_aziang, & + dlat_earth_deg,dlon_earth_deg,& + lat_mdl, lon_mdl, & + expansion, power ) + endif + call accum_sfc(i,j,power,sfc_mdl,sfc_sum) + enddo enddo enddo enddo - enddo - else - allocate(powerx(subgrid_lengths_x,subgrid_lengths_y)) - do j = jstart, jend - jj = j - if (j > nlat_sfc/2) jj = nlat_sfc - j + 1 - do i = min_i(j), max_i(j) - call reduce2full(i,j,ifull) - call time_int_sfc(ifull,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) + else + allocate(powerx(subgrid_lengths_x,subgrid_lengths_y)) + do j = jstart, jend + jj = j + if (j > nlat_sfc/2) jj = nlat_sfc - j + 1 + do i = min_i(j), max_i(j) + call reduce2full(i,j,ifull) + call time_int_sfc(ifull,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) !$omp parallel do schedule(dynamic,1)private(jjj,iii,lat_mdl,lon_mdl) - do jjj = 1, subgrid_lengths_y - if (y_off(jjj) >= zero) then - lat_mdl = (one-y_off(jjj))*rlats_sfc(j)+y_off(jjj)*rlats_sfc(j+1) - else - lat_mdl = (one+y_off(jjj))*rlats_sfc(j)-y_off(jjj)*rlats_sfc(j-1) - endif - lat_mdl = lat_mdl * rad2deg - do iii = 1, subgrid_lengths_x -! Note, near greenwich, "i" index may be out of range. that is -! ok here when calculating longitude even if the value is -! greater than 360. the ellipse code works from longitude relative -! to the center of the fov. - lon_mdl = (float(i)+x_off(iii) - one) * dx_gfs(jj) - if (fov_flag=="crosstrk")then - call inside_fov_crosstrk(instr,ifov,sat_aziang, & - dlat_earth_deg,dlon_earth_deg, & - lat_mdl, lon_mdl, & - expansion, ichan, powerx(iii,jjj) ) - elseif (fov_flag=="conical")then - call inside_fov_conical(instr,ichan,sat_aziang, & - dlat_earth_deg,dlon_earth_deg,& - lat_mdl, lon_mdl, & - expansion, powerx(iii,jjj) ) + do jjj = 1, subgrid_lengths_y + if (y_off(jjj) >= zero) then + lat_mdl = (one-y_off(jjj))*rlats_sfc(j)+y_off(jjj)*rlats_sfc(j+1) + else + lat_mdl = (one+y_off(jjj))*rlats_sfc(j)-y_off(jjj)*rlats_sfc(j-1) endif + lat_mdl = lat_mdl * rad2deg + do iii = 1, subgrid_lengths_x +! Note, near greenwich, "i" index may be out of range. that is +! ok here when calculating longitude even if the value is +! greater than 360. the ellipse code works from longitude relative +! to the center of the fov. + lon_mdl = (float(i)+x_off(iii) - one) * dx_gfs(jj) + if (fov_flag=="crosstrk")then + call inside_fov_crosstrk(instr,ifov,sat_aziang, & + dlat_earth_deg,dlon_earth_deg, & + lat_mdl, lon_mdl, & + expansion, ichan, powerx(iii,jjj) ) + elseif (fov_flag=="conical")then + call inside_fov_conical(instr,ichan,sat_aziang, & + dlat_earth_deg,dlon_earth_deg,& + lat_mdl, lon_mdl, & + expansion, powerx(iii,jjj) ) + endif + enddo enddo - enddo - do jjj = 1, subgrid_lengths_y - do iii = 1, subgrid_lengths_x - call accum_sfc(ifull,j,powerx(iii,jjj),sfc_mdl,sfc_sum) + do jjj = 1, subgrid_lengths_y + do iii = 1, subgrid_lengths_x + call accum_sfc(ifull,j,powerx(iii,jjj),sfc_mdl,sfc_sum) + enddo enddo enddo enddo - enddo - deallocate(powerx) - endif ! regional or global - deallocate (x_off, y_off) - -! If there were no model points within the fov, the model points need to be -! "chopped" into smaller pieces. - - if (sum(sfc_sum%count) == zero) then - close(9) - subgrid_lengths_x = subgrid_lengths_x + 1 - subgrid_lengths_y = subgrid_lengths_y + 1 -! print*,'NO GRID POINTS INSIDE FOV, CHOP MODEL BOX INTO FINER PIECES',subgrid_lengths_x,subgrid_lengths_y - goto 99 - else - call calc_sfc(sfc_sum,isflg,idomsfc,sfcpct,vfr,sty,vty,sm,stp,ff10,sfcr,zz,sn,ts,tsavg) - endif - + deallocate(powerx) + endif ! regional or global + deallocate (x_off, y_off) + +! If there were no model points within the fov, the model points need to be +! "chopped" into smaller pieces. + + if (sum(sfc_sum%count) == zero) then + close(9) + subgrid_lengths_x = subgrid_lengths_x + 1 + subgrid_lengths_y = subgrid_lengths_y + 1 +! print*,'NO GRID POINTS INSIDE FOV, CHOP MODEL BOX INTO FINER PIECES',subgrid_lengths_x,subgrid_lengths_y + else + exit loop1 + endif + end do loop1 deallocate (max_i, min_i) + call calc_sfc(sfc_sum,isflg,idomsfc,sfcpct,vfr,sty,vty,sm,stp,ff10,sfcr,zz,sn,ts,tsavg) + return end subroutine deter_sfc_fov @@ -1332,6 +1333,173 @@ subroutine deter_sfc_amsre_low(dlat_earth,dlon_earth,isflg,sfcpct) end subroutine deter_sfc_amsre_low + +subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) +!$$$ subprogram documentation block +! . . . . +! subprogram: deter_sfc_gmi determine land surface type +! prgmmr: mkim1 org: np2 date: 2017-10-04 +! +! abstract: determines land surface type based on surrounding land +! surface types for GMI large FOV observation +! +! program history log: +! 2017-10-04 mkim1 - refered from ( subroutine deter_sfc ) +! +! input argument list: +! dlat_earth - latitude +! dlon_earth - longitude +! +! output argument list: +! isflg - surface flag +! 0 sea +! 1 land +! 2 sea ice +! 3 snow +! 4 mixed +! sfcpct(0:3)- percentage of 4 surface types +! (0) - sea percentage +! (1) - land percentage +! (2) - sea ice percentage +! (3) - snow percentage +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + implicit none + + real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth + integer(i_kind) ,intent( out) :: isflg + real(r_kind),dimension(0:3),intent( out) :: sfcpct + + integer(i_kind) jsli,it + integer(i_kind):: klat1,klon1,klatp1,klonp1 + real(r_kind):: dx,dy,dx1,dy1,w00,w10,w01,w11 + real(r_kind) :: dlat,dlon + logical :: outside + integer(i_kind):: klat2,klon2,klatp2,klonp2 + +! +! For interpolation, we usually use o points (4points for land sea decision) +! In case of lowfreq channel (Large FOV), add the check of x points(8 points) +! (klatp2,klon1),(klatp2,klonp1) +! ---#---x---x---#--- klatp2 (klatp1,klon2),(klatp1,klonp2) +! | | | | (klat1,klon2),(klat1,klonp2) +! ---x---o---o---x--- klatp1 (klat2,klon1),(klat2,klonp1) +! | | + | | +! ---x---o---o---x--- klat1 +! | | | | +! ---#---x---x---#--- klat2 +! klon1 klonp2 +! klon2 klonp1 +! +! In total, 12 points are used to make mean sst and sfc percentage. +! + it=ntguessfc + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + else + dlat=dlat_earth + dlon=dlon_earth + call grdcrd1(dlat,rlats_sfc,nlat_sfc,1) + call grdcrd1(dlon,rlons_sfc,nlon_sfc,1) + end if + + klon1=int(dlon); klat1=int(dlat) + dx =dlon-klon1; dy =dlat-klat1 + dx1 =one-dx; dy1 =one-dy + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + klat1=min(max(1,klat1),nlat_sfc); klon1=min(max(0,klon1),nlon_sfc) + if(klon1==0) klon1=nlon_sfc + klatp1=min(nlat_sfc,klat1+1); klonp1=klon1+1 + if(klonp1==nlon_sfc+1) klonp1=1 + klonp2 = klonp1+1 + if(klonp2==nlon_sfc+1) klonp2=1 + klon2=klon1-1 + if(klon2==0)klon2=nlon_sfc + klat2=max(1,klat1-1) + klatp2=min(nlat_sfc,klatp1+1) + +! Set surface type flag. Begin by assuming obs over ice-free water + + sfcpct = zero + + jsli = isli_full(klat1 ,klon1 ) + if(sno_full(klat1 ,klon1 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klatp1,klon1 ) + if(sno_full(klatp1 ,klon1 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klat1 ,klonp1) + if(sno_full(klat1 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klatp1,klonp1) + if(sno_full(klatp1 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klatp2,klon1) + if(sno_full(klatp2 ,klon1 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klatp2,klonp1) + if(sno_full(klatp2 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klatp1,klon2) + if(sno_full(klatp1 ,klon2 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klatp1,klonp2) + if(sno_full(klatp1 ,klonp2 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klat1,klon2) + if(sno_full(klat1 ,klon2 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klat1,klonp2) + if(sno_full(klat1 ,klonp2 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klat2,klon1) + if(sno_full(klat2 ,klon1 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + jsli = isli_full(klat2,klonp1) + if(sno_full(klat2 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 + sfcpct(jsli)=sfcpct(jsli)+one + + sfcpct=sfcpct/12.0_r_kind + +! sfcpct(3)=min(sfcpct(3),sfcpct(1)) +! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3)) + + isflg = 0 + if(sfcpct(0) > 0.99_r_kind)then + isflg = 0 + else if(sfcpct(1) > 0.99_r_kind)then + isflg = 1 + else if(sfcpct(2) > 0.99_r_kind)then + isflg = 2 + else if(sfcpct(3) > 0.99_r_kind)then + isflg = 3 + else + isflg = 4 + end if + + return + + end subroutine deter_sfc_gmi + + subroutine deter_zsfc_model(dlat,dlon,zsfc) !$$$ subprogram documentation block ! . . . . diff --git a/src/dtast.f90 b/src/gsi/dtast.f90 similarity index 100% rename from src/dtast.f90 rename to src/gsi/dtast.f90 diff --git a/src/egrid2agrid_mod.f90 b/src/gsi/egrid2agrid_mod.f90 similarity index 99% rename from src/egrid2agrid_mod.f90 rename to src/gsi/egrid2agrid_mod.f90 index a2d3acaee..626aa5436 100644 --- a/src/egrid2agrid_mod.f90 +++ b/src/gsi/egrid2agrid_mod.f90 @@ -1392,6 +1392,7 @@ subroutine g_create_egrid2agrid(nlata,rlata,nlona,rlona,nlate,rlate,nlone,rlone, !$$$ end documentation block use constants, only: zero,half,one,two,pi + use mpimod, only: mype implicit none integer(i_kind),intent(in) :: nlata,nlona,nlate,nlone,nord_e2a @@ -1417,7 +1418,9 @@ subroutine g_create_egrid2agrid(nlata,rlata,nlona,rlona,nlate,rlate,nlone,rlone, if(nlata == nlate.and.nlona == nlone) then if(present(eqspace)) then if(eqspace) then - write(6,*) 'g_create_egrid2agrid: WARNING, forced p%identity true ' + if(mype==0) then + write(6,*) 'g_create_egrid2agrid: WARNING, forced p%identity true ' + endif p%identity=.true. endif endif diff --git a/src/en_perts_io.f90 b/src/gsi/en_perts_io.f90 similarity index 96% rename from src/en_perts_io.f90 rename to src/gsi/en_perts_io.f90 index 72ea257b2..1a9dc58a5 100644 --- a/src/en_perts_io.f90 +++ b/src/gsi/en_perts_io.f90 @@ -88,7 +88,9 @@ subroutine en_perts_get_from_save_fulldomain write(6,'(a,i5,a,i5,a)') '***ERROR*** MPI_FILE_OPEN failed on task = ', & mype, ' ierror = ', ierror iret = ierror - goto 1000 + write(6,*)'PREPROC_READ_GFSATM: ***ERROR*** reading ',& + trim(filename),' IRET=',iret + return endif allocate(work_grd(grd_arw%inner_vars,grd_arw%nlat,grd_arw%nlon,grd_arw%kbegin_loc:grd_arw%kend_alloc)) @@ -99,7 +101,9 @@ subroutine en_perts_get_from_save_fulldomain write(6,'(a,i5,a,i5,a)') '***ERROR*** MPI_FILE_READ_AT failed on task =', & mype, ' ierror = ', ierror iret = ierror - goto 1000 + write(6,*)'PREPROC_READ_GFSATM: ***ERROR*** reading ',& + trim(filename),' IRET=',iret + return endif call mpi_file_close(iunit,ierror) @@ -107,7 +111,9 @@ subroutine en_perts_get_from_save_fulldomain write(6,'(a,i5,a,i5,a)') '***ERROR*** MPI_FILE_CLOSE failed on task = ',& mype, ' ierror = ', ierror iret = ierror - goto 1000 + write(6,*)'PREPROC_READ_GFSATM: ***ERROR*** reading ',& + trim(filename),' IRET=',iret + return endif allocate(work_sub(grd_arw%inner_vars,im,jm,grd_arw%num_fields)) @@ -154,12 +160,6 @@ subroutine en_perts_get_from_save_fulldomain return -1000 continue - - write(6,*)'PREPROC_READ_GFSATM: ***ERROR*** reading ',& - trim(filename),' IRET=',iret - return - end subroutine en_perts_get_from_save_fulldomain subroutine en_perts_get_from_save diff --git a/src/enorm_state.f90 b/src/gsi/enorm_state.f90 similarity index 100% rename from src/enorm_state.f90 rename to src/gsi/enorm_state.f90 diff --git a/src/ens_spread_mod.f90 b/src/gsi/ens_spread_mod.f90 similarity index 100% rename from src/ens_spread_mod.f90 rename to src/gsi/ens_spread_mod.f90 diff --git a/src/ensctl2model.f90 b/src/gsi/ensctl2model.f90 similarity index 100% rename from src/ensctl2model.f90 rename to src/gsi/ensctl2model.f90 diff --git a/src/ensctl2model_ad.f90 b/src/gsi/ensctl2model_ad.f90 similarity index 100% rename from src/ensctl2model_ad.f90 rename to src/gsi/ensctl2model_ad.f90 diff --git a/src/ensctl2state.f90 b/src/gsi/ensctl2state.f90 similarity index 83% rename from src/ensctl2state.f90 rename to src/gsi/ensctl2state.f90 index 2d9b02767..f37123201 100644 --- a/src/ensctl2state.f90 +++ b/src/gsi/ensctl2state.f90 @@ -12,6 +12,8 @@ subroutine ensctl2state(xhat,mval,eval) ! 2013-10-28 todling - rename p3d to prse ! 2013-11-22 kleist - add option for q perturbations ! 2014-12-03 derber - introduce parallel regions for optimization +! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu +! 2019-07-11 Todling - check on w and dw on the fly ! ! input argument list: ! xhat - Control variable @@ -42,7 +44,9 @@ subroutine ensctl2state(xhat,mval,eval) use gsi_metguess_mod, only: gsi_metguess_get use mod_strong, only: tlnmc_option use cwhydromod, only: cw2hydro_tl +use cwhydromod, only: cw2hydro_tl_hwrf use timermod, only: timer_ini,timer_fnl +use gridmod, only: nems_nmmb_regional implicit none ! Declare passed variables @@ -55,27 +59,32 @@ subroutine ensctl2state(xhat,mval,eval) character(len=max_varname_length),allocatable,dimension(:) :: clouds integer(i_kind) :: jj,ic,id,istatus,nclouds -integer(i_kind), parameter :: ncvars = 6 +integer(i_kind), parameter :: ncvars = 8 integer(i_kind) :: icps(ncvars) type(gsi_bundle):: wbundle_c ! work bundle character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here 'sf ', 'vp ', 'ps ', 't ', & - 'q ', 'cw '/) + 'q ', 'cw ', 'w ', 'dw '/) logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh,lc_cw +logical :: lc_w,lc_dw real(r_kind),pointer,dimension(:,:,:) :: cv_sf,cv_vp,cv_rh ! Declare required local state variables -integer(i_kind), parameter :: nsvars = 7 +integer(i_kind), parameter :: nsvars = 13 integer(i_kind) :: isps(nsvars) character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ','qi ' /) + 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ','qi ', & + 'qr ', 'qs ', 'qg ', 'qh ', 'w ', 'dw ' /) logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi +logical :: ls_qr,ls_qs,ls_qg,ls_qh +logical :: ls_w,ls_dw real(r_kind),pointer,dimension(:,:) :: sv_ps,sv_sst real(r_kind),pointer,dimension(:,:,:) :: sv_u,sv_v,sv_prse,sv_q,sv_tsen,sv_tv,sv_oz -real(r_kind),pointer,dimension(:,:,:) :: sv_rank3 +real(r_kind),pointer,dimension(:,:,:) :: sv_rank3,sv_w,sv_dw logical :: do_getprs_tl,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,lstrong_bk_vars logical :: do_tlnmc,do_q_copy logical :: do_cw_to_hydro +logical :: do_cw_to_hydro_hwrf ! **************************************************************************** @@ -94,12 +103,16 @@ subroutine ensctl2state(xhat,mval,eval) call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus) lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 +lc_w =icps(7)>0; lc_dw =icps(8)>0 ! Since each internal vector of xhat has the same structure, pointers are ! the same independent of the subwindow jj call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus) ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0; ls_qi =isps(7)>0 +ls_qr =isps(8)>0; ls_qs =isps(9)>0 +ls_qg =isps(10)>0; ls_qh =isps(11)>0 +ls_w =isps(12)>0; ls_dw =isps(13)>0 ! Define what to do depending on what's in CV and SV lstrong_bk_vars =lc_ps.and.lc_sf.and.lc_vp.and.lc_t @@ -121,6 +134,8 @@ subroutine ensctl2state(xhat,mval,eval) do_cw_to_hydro = .false. do_cw_to_hydro = lc_cw .and. ls_ql .and. ls_qi +do_cw_to_hydro_hwrf = .false. +do_cw_to_hydro_hwrf = lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh ! Initialize ensemble contribution to zero !$omp parallel do schedule(dynamic,1) private(jj) @@ -188,10 +203,17 @@ subroutine ensctl2state(xhat,mval,eval) end if - if (do_cw_to_hydro) then + if (do_cw_to_hydro .and. .not.do_cw_to_hydro_hwrf) then ! Case when cloud-vars do not map one-to-one (cv-to-sv) ! e.g. cw-to-ql&qi call cw2hydro_tl(eval(jj),wbundle_c,clouds,nclouds) + elseif (do_cw_to_hydro_hwrf) then +! Case when cloud-vars do not map one-to-one (cv-to-sv) +! e.g. cw-to-ql&qi&qr&qs&qg&qh + if (.not.do_tv_to_tsen) then + call tv_to_tsen(sv_tv,sv_q,sv_tsen) + endif + call cw2hydro_tl_hwrf(eval(jj),wbundle_c,sv_tsen) else ! Since cloud-vars map one-to-one, take care of them together do ic=1,nclouds @@ -209,9 +231,21 @@ subroutine ensctl2state(xhat,mval,eval) ! Get pointers to required state variables call gsi_bundlegetpointer (eval(jj),'oz' ,sv_oz , istatus) call gsi_bundlegetpointer (eval(jj),'sst' ,sv_sst, istatus) + if(ls_w)then + call gsi_bundlegetpointer (eval(jj),'w' ,sv_w, istatus) + if(ls_dw.and.nems_nmmb_regional)then + call gsi_bundlegetpointer (eval(jj),'dw' ,sv_dw, istatus) + end if + end if ! Copy variables call gsi_bundlegetvar ( wbundle_c, 'oz' , sv_oz, istatus ) call gsi_bundlegetvar ( wbundle_c, 'sst', sv_sst, istatus ) + if(lc_w)then + call gsi_bundlegetvar ( wbundle_c, 'w' , sv_w, istatus ) + if(lc_dw.and.nems_nmmb_regional)then + call gsi_bundlegetvar ( wbundle_c, 'dw' , sv_dw, istatus ) + end if + end if !$omp end parallel sections diff --git a/src/ensctl2state_ad.f90 b/src/gsi/ensctl2state_ad.f90 similarity index 83% rename from src/ensctl2state_ad.f90 rename to src/gsi/ensctl2state_ad.f90 index f3c4c31d0..91a45035b 100644 --- a/src/ensctl2state_ad.f90 +++ b/src/gsi/ensctl2state_ad.f90 @@ -11,6 +11,8 @@ subroutine ensctl2state_ad(eval,mval,grad) ! 2013-10-28 todling - rename p3d to prse ! 2013-11-22 kleist - add option for q perturbations ! 2014-12-03 derber - introduce parallel regions for optimization +! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu +! 2019-07-11 Todling - there should be no need to check on the existence of w and dw ! ! input argument list: ! eval - Ensemble state variable variable @@ -41,7 +43,9 @@ subroutine ensctl2state_ad(eval,mval,grad) use gsi_metguess_mod, only: gsi_metguess_get use mod_strong, only: tlnmc_option use cwhydromod, only: cw2hydro_ad +use cwhydromod, only: cw2hydro_ad_hwrf use timermod, only: timer_ini,timer_fnl +use gridmod, only: nems_nmmb_regional implicit none ! Declare passed variables @@ -54,27 +58,33 @@ subroutine ensctl2state_ad(eval,mval,grad) character(len=max_varname_length),allocatable,dimension(:) :: clouds integer(i_kind) :: jj,ic,id,istatus,nclouds -integer(i_kind), parameter :: ncvars = 6 +integer(i_kind), parameter :: ncvars = 8 integer(i_kind) :: icps(ncvars) type(gsi_bundle):: wbundle_c ! work bundle character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here 'sf ', 'vp ', 'ps ', 't ', & - 'q ','cw '/) + 'q ', 'cw ', 'w ', 'dw '/) logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh,lc_cw +logical :: lc_w,lc_dw real(r_kind),pointer,dimension(:,:,:) :: cv_sf,cv_vp,cv_rh ! Declare required local state variables -integer(i_kind), parameter :: nsvars = 7 +integer(i_kind), parameter :: nsvars = 13 integer(i_kind) :: isps(nsvars) character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen','ql ','qi ' /) + 'u ', 'v ', 'prse', 'q ', 'tsen','ql ','qi ', & + 'qr ', 'qs ', 'qg ', 'qh ', 'w ','dw ' /) logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi +logical :: ls_qr,ls_qs,ls_qg,ls_qh +logical :: ls_w,ls_dw real(r_kind),pointer,dimension(:,:) :: rv_ps,rv_sst real(r_kind),pointer,dimension(:,:,:) :: rv_u,rv_v,rv_prse,rv_q,rv_tsen,rv_tv,rv_oz -real(r_kind),pointer,dimension(:,:,:) :: rv_rank3 +real(r_kind),pointer,dimension(:,:,:) :: rv_rank3,rv_w,rv_dw logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad,lstrong_bk_vars logical :: do_tlnmc,do_q_copy logical :: do_cw_to_hydro_ad +logical :: do_cw_to_hydro_ad_hwrf +logical :: wdw_exist !**************************************************************************** @@ -93,12 +103,16 @@ subroutine ensctl2state_ad(eval,mval,grad) call gsi_bundlegetpointer (grad%step(1),mycvars,icps,istatus) lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 +lc_w =icps(7)>0; lc_dw =icps(8)>0 ! Since each internal vector of grad has the same structure, pointers are ! the same independent of the subwindow jj call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus) ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0; ls_qi =isps(7)>0 +ls_qr =isps(8)>0; ls_qs =isps(9)>0 +ls_qg =isps(10)>0; ls_qh =isps(11)>0 +ls_w =isps(12)>0; ls_dw =isps(13)>0 ! Define what to do depending on what's in CV and SV lstrong_bk_vars =lc_sf.and.lc_vp.and.lc_ps .and.lc_t @@ -114,6 +128,10 @@ subroutine ensctl2state_ad(eval,mval,grad) do_cw_to_hydro_ad=.false. do_cw_to_hydro_ad=lc_cw.and.ls_ql.and.ls_qi +do_cw_to_hydro_ad_hwrf=.false. +do_cw_to_hydro_ad_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh + +wdw_exist = lc_w.and.lc_dw.and.ls_w.and.ls_dw ! Initialize mval%values=zero @@ -181,13 +199,25 @@ subroutine ensctl2state_ad(eval,mval,grad) call gsi_bundlegetpointer (eval(jj),'sst' ,rv_sst, istatus) call gsi_bundleputvar ( wbundle_c, 'oz', rv_oz, istatus ) call gsi_bundleputvar ( wbundle_c, 'sst', rv_sst, istatus ) + if(wdw_exist)then + call gsi_bundlegetpointer (eval(jj),'w' ,rv_w, istatus) + call gsi_bundleputvar ( wbundle_c, 'w', rv_w, istatus ) + if(nems_nmmb_regional)then + call gsi_bundlegetpointer (eval(jj),'dw' ,rv_dw, istatus) + call gsi_bundleputvar ( wbundle_c, 'dw', rv_dw, istatus ) + end if + end if !$omp section - if (do_cw_to_hydro_ad) then + if (do_cw_to_hydro_ad .and. .not.do_cw_to_hydro_ad_hwrf) then ! Case when cloud-vars do not map one-to-one ! e.g. cw-to-ql&qi call cw2hydro_ad(eval(jj),wbundle_c,clouds,nclouds) + elseif (do_cw_to_hydro_ad_hwrf) then +!! Case when cloud-vars do not map one-to-one +!! e.g. cw-to-ql&qi&qr&qs&qg&qh + call cw2hydro_ad_hwrf(eval(jj),wbundle_c,rv_tsen) else ! Since cloud-vars map one-to-one, take care of them together do ic=1,nclouds diff --git a/src/evaljgrad.f90 b/src/gsi/evaljgrad.f90 similarity index 97% rename from src/evaljgrad.f90 rename to src/gsi/evaljgrad.f90 index 0b4d6e19a..788454034 100644 --- a/src/evaljgrad.f90 +++ b/src/gsi/evaljgrad.f90 @@ -27,6 +27,8 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) ! 2015-09-03 guo - obsmod::yobs has been replaced with m_obsHeadBundle, ! where yobs is created and destroyed when and where it ! is needed. +! 2018-08-10 guo - replace intjo() related implementations with a new +! polymoprhic implementation of intjomod::intjo(). ! ! input argument list: ! xhat - current state estimate (in control space) @@ -62,7 +64,6 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) use bias_predictors, only: predictors,allocate_preds,deallocate_preds,assignment(=) use bias_predictors, only: update_bias_preds use intjomod, only: intjo -use intradmod, only: setrad use intjcmod, only: intjcdfi use gsi_4dcouplermod, only: gsi_4dcoupler_grtests use gsi_bundlemod, only: gsi_bundle @@ -73,9 +74,6 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) use mpeu_util, only: die use mpl_allreducemod, only: mpl_allreduce -use m_obsHeadBundle, only: obsHeadBundle -use m_obsHeadBundle, only: obsHeadBundle_create -use m_obsHeadBundle, only: obsHeadBundle_destroy implicit none ! Declare passed variables @@ -101,7 +99,6 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) character(len=255) :: seqcalls real(r_quad),dimension(max(1,nrclen)) :: qpred -type(obsHeadBundle),pointer,dimension(:):: yobs !********************************************************************** @@ -197,13 +194,11 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) mval(ii)=zero end do -call setrad(sval(1)) qpred=zero_quad + ! Compare obs to solution and transpose back to grid (H^T R^{-1} H) -call obsHeadBundle_create(yobs,nobs_bins) -do ibin=1,size(yobs) ! == nobs_bins - call intjo(yobs(ibin),rval(ibin),qpred,sval(ibin),sbias,ibin) -end do +call intjo(rval,qpred,sval,sbias) + ! Take care of background error for bias correction terms call mpl_allreduce(nrclen,qpvals=qpred) @@ -219,7 +214,6 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) rbias%predt(i)=rbias%predt(i)+qpred(nsclen+npclen+i) end do end if -call obsHeadBundle_destroy(yobs) ! Evaluate Jo call evaljo(zjo,iobs,nprt,llouter) diff --git a/src/gsi/evaljo.f90 b/src/gsi/evaljo.f90 new file mode 100644 index 000000000..95d003ab6 --- /dev/null +++ b/src/gsi/evaljo.f90 @@ -0,0 +1,189 @@ +subroutine evaljo(pjo,kobs,kprt,louter) +!$$$ subprogram documentation block +! . . . . +! subprogram: evaljo +! prgmmr: tremolet +! +! abstract: Computes and prints Jo components +! +! program history log: +! 2007-03-01 tremolet +! 2009-01-15 todling - quad precision for reproducibility +! 2009-08-14 lueken - update documentation +! +! input argument list: +! kprt - print level +! louter +! +! output argument list: +! kobs - Number of obs used in evaluating Jo +! pjo - Jo value +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind,r_quad + use obs_sensitivity, only: obsensCounts_set + use gsi_obOperTypeManager, only: obOper_typeInfo + use m_obsdiags , only: obsdiags + use m_obsdiagNode, only: obs_diag + use gsi_4dvar, only: nobs_bins + use constants, only: zero_quad + use mpimod, only: ierror,mpi_comm_world,mpi_sum,mpi_integer,mype + use jfunc, only: jiter + use mpl_allreducemod, only: mpl_allreduce + use mpeu_util, only: perr,die + + implicit none + +! Declare passed variables + real(r_quad) ,intent( out) :: pjo + integer(i_kind),intent( out) :: kobs + integer(i_kind),intent(in ) :: kprt + logical ,intent(in ) :: louter + +! Declare local variables + character(len=*), parameter :: myname='evaljo' + integer(i_kind) :: ii,jj,ij,ilen + integer(i_kind) :: iobs(size(obsdiags,1)) + real(r_quad) :: zjo,zz + real(r_kind) :: zdep + real(r_quad) :: zjo1(size(obsdiags,1)) + real(r_quad) :: zjo2(size(obsdiags,1),nobs_bins) + real(r_quad) :: zprods(size(obsdiags,1)*nobs_bins) + integer(i_kind) :: iobsgrp(size(obsdiags,1),nobs_bins) + integer(i_kind) :: iobsglb(size(obsdiags,1),nobs_bins) + type(obs_diag),pointer:: obsptr + character(len=20):: cobstype_ii + integer(i_kind) :: nobs_type +! ---------------------------------------------------------- + +zprods(:)=zero_quad +iobsgrp(:,:)=0 +iobsglb(:,:)=0 +nobs_type = size(obsdiags,1) + +if(size(obsdiags,2)/=nobs_bins) then + call perr(myname,'size(obsdiags,2)/=nobs_bins, size(obsdiags,2) =',size(obsdiags,2)) + call perr(myname,' nobs_bins =',nobs_bins) + call die(myname) +endif + +ij=0 +do ii=1,nobs_bins + do jj=1,nobs_type + ij=ij+1 + + !++ if(louter) then + !++ zprods(ij) = obsLL(jj,ii)%NLDdotprod(jiter,nob=iobsgrp(jj,ii)) + !++ else + !++ zprods(ij) = obsLL(jj,ii)%DELdotprod(jiter,nob=iobsgrp(jj,ii)) + !++ endif + obsptr => obsdiags(jj,ii)%head + do while (associated(obsptr)) + if (obsptr%luse.and.obsptr%muse(jiter)) then + if (louter) then + zdep=obsptr%nldepart(jiter) + else + zdep=obsptr%tldepart(jiter)-obsptr%nldepart(jiter) + endif + zprods(ij) = zprods(ij) + obsptr%wgtjo * zdep * zdep + iobsgrp(jj,ii)=iobsgrp(jj,ii)+1 + endif + obsptr => obsptr%next + enddo + + enddo +enddo + +! Sum Jo contributions +call mpl_allreduce(nobs_type*nobs_bins,qpvals=zprods) + +! Sum number of observations +ilen=nobs_bins*nobs_type +call mpi_allreduce(iobsgrp,iobsglb,ilen, & + & mpi_integer,mpi_sum,mpi_comm_world,ierror) + +! Gather Jo contributions + +ij=0 +do ii=1,nobs_bins + do jj=1,nobs_type + ij=ij+1 + zjo2(jj,ii)=zprods(ij) + enddo +enddo + +zjo1=zero_quad +iobs=0 +DO ii=1,nobs_bins + zjo1(:)=zjo1(:)+zjo2(:,ii) + iobs(:)=iobs(:)+iobsglb(:,ii) +ENDDO + +zjo=zero_quad +kobs=0 +DO ii=1,nobs_type + zjo=zjo+zjo1(ii) + kobs=kobs+iobs(ii) +ENDDO + +pjo=zjo + +! Prints +IF (kprt>=2.and.mype==0) THEN + if (louter) then + write(6,*)'Begin Jo table outer loop' + else + write(6,*)'Begin Jo table inner loop' + endif + + IF (kprt>=3.and.nobs_bins>1) THEN + write(6,400)'Observation Type','Bin','Nobs','Jo','Jo/n' + DO ii=1,nobs_type + cobstype_ii=obOper_typeInfo(ii) + DO jj=1,nobs_bins + IF (iobsglb(ii,jj)>0) THEN + zz=zjo2(ii,jj)/iobsglb(ii,jj) + write(6,100)cobstype_ii,jj,iobsglb(ii,jj),real(zjo2(ii,jj),r_kind),real(zz,r_kind) + ENDIF + ENDDO + ENDDO + ENDIF + + write(6,400)'Observation Type',' ','Nobs','Jo','Jo/n' + DO ii=1,nobs_type + cobstype_ii=obOper_typeInfo(ii) + IF (iobs(ii)>0) THEN + zz=zjo1(ii)/iobs(ii) + write(6,200)cobstype_ii,iobs(ii),real(zjo1(ii),r_kind),real(zz,r_kind) + ENDIF + ENDDO + + IF (kobs>0) THEN + zz=zjo/kobs + ELSE + zz=-999.999_r_quad + ENDIF + write(6,400)' ',' ','Nobs','Jo','Jo/n' + write(6,300)"Jo Global",kobs,real(zjo,r_kind),real(zz,r_kind) + + if (louter) then + write(6,*)'End Jo table outer loop' + else + write(6,*)'End Jo table inner loop' + endif +ENDIF + +call obsensCounts_set(iobsglb(:,:)) + +100 format(a20,2x,i3,2x,i8,2x,es24.16,2x,f10.3) +200 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3) +300 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3) +400 format(a20,2x,a3,2x,a8,2x,a24,4x,a8) + +! ---------------------------------------------------------- +return +end subroutine evaljo diff --git a/src/evalqlim.f90 b/src/gsi/evalqlim.f90 similarity index 84% rename from src/evalqlim.f90 rename to src/gsi/evalqlim.f90 index a0ad37e16..085fa8772 100644 --- a/src/evalqlim.f90 +++ b/src/gsi/evalqlim.f90 @@ -14,6 +14,7 @@ subroutine evalqlim(sval,pbc,rval) ! 2010-03-23 derber - made consistent with stplimq and intlimq (but not checked) ! 2010-05-05 derber - omp commands removed ! 2010-05-13 todling - udpate to use gsi_bundle; interface change +! 2019-03-05 martin - update to weight factqmin/max by latitude ! ! input argument list: ! sq @@ -31,12 +32,13 @@ subroutine evalqlim(sval,pbc,rval) !$$$ end documentation block use kinds, only: r_kind,i_kind,r_quad use constants, only: zero,one,zero_quad - use gridmod, only: lat1,lon1,nsig + use gridmod, only: lat1,lon1,nsig,istart,wgtfactlats use jfunc, only: factqmin,factqmax use derivsmod, only: qgues,qsatg use mpl_allreducemod, only: mpl_allreduce use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer + use mpimod, only: mype implicit none ! Declare passed variables @@ -45,7 +47,7 @@ subroutine evalqlim(sval,pbc,rval) real(r_quad) ,intent(inout) :: pbc ! Declare local variables - integer(i_kind) i,j,k,ier,istatus + integer(i_kind) i,j,k,ier,istatus,ii,mm1 real(r_quad) :: zbc(2) real(r_kind) :: q,term real(r_kind),pointer,dimension(:,:,:) :: sq @@ -61,23 +63,28 @@ subroutine evalqlim(sval,pbc,rval) call gsi_bundlegetpointer(rval,'q',rq,istatus);ier=istatus+ier if(ier/=0)return + mm1 = mype+1 + zbc=zero_quad ! Loop over interior of subdomain do k = 1,nsig do j = 2,lon1+1 do i = 2,lat1+1 + ii=istart(mm1)+i-2 ! Value for q q = qgues(i,j,k) + sq(i,j,k) ! Compute penalty for neg q if (qqsatg(i,j,k)) then - term=factqmax*(q-qsatg(i,j,k))/(qsatg(i,j,k)*qsatg(i,j,k)) + term=(factqmax*wgtfactlats(ii))*(q-qsatg(i,j,k))& + /(qsatg(i,j,k)*qsatg(i,j,k)) zbc(2) = zbc(2) + term*(q-qsatg(i,j,k)) ! Adjoint rq(i,j,k) = rq(i,j,k) + term diff --git a/src/fgrid2agrid_mod.f90 b/src/gsi/fgrid2agrid_mod.f90 similarity index 100% rename from src/fgrid2agrid_mod.f90 rename to src/gsi/fgrid2agrid_mod.f90 diff --git a/src/fill_mass_grid2.f90 b/src/gsi/fill_mass_grid2.f90 similarity index 100% rename from src/fill_mass_grid2.f90 rename to src/gsi/fill_mass_grid2.f90 diff --git a/src/fill_nmm_grid2.f90 b/src/gsi/fill_nmm_grid2.f90 similarity index 100% rename from src/fill_nmm_grid2.f90 rename to src/gsi/fill_nmm_grid2.f90 diff --git a/src/fpvsx_ad.f90 b/src/gsi/fpvsx_ad.f90 similarity index 100% rename from src/fpvsx_ad.f90 rename to src/gsi/fpvsx_ad.f90 diff --git a/src/gsi/fv3_regional_interface.f90 b/src/gsi/fv3_regional_interface.f90 new file mode 100644 index 000000000..80ce16ba8 --- /dev/null +++ b/src/gsi/fv3_regional_interface.f90 @@ -0,0 +1,48 @@ +subroutine convert_fv3_regional +!$$$ subprogram documentation block +! . . . . +! subprogram: convert_fv3_regional read single fv3 nest +! prgmmr: parrish org: np22 date: 2017-04-09 +! +! abstract: using routines from gsi_rfv3io_mod.f90 module to setup for +! reading tile of forecast fields from an fv3 forecast. +! NOTE: run on single processor, with information stored on unit lendian_out +! +!################################################################################# +!################################################################################# +! Use subroutine convert_nems_nmmb (in wrf_binary_interface.F90) as pattern. +!################################################################################# +!################################################################################# +! +! program history log: +! 2017-04-08 parrish +! 2018-02-16 wu - read in grid and time infor from fv3 files +! read directly from fv3 files and not writeout GSI internal file +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + use kinds, only: r_single,r_kind,i_kind + use gsi_rfv3io_mod, only: gsi_rfv3io_get_grid_specs + use gsi_rfv3io_mod, only: bg_fv3regfilenameg + + implicit none + integer(i_kind) ierr + character(128) grid_spec,ak_bk + + +!!!!!!!!!!! get grid specs !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + grid_spec='fv3_grid_spec' ! horizontal grid information + ak_bk='fv3_akbk' ! vertical grid information + call bg_fv3regfilenameg%init(grid_spec_input='fv3_grid_spec',ak_bk_input='fv3_akbk') + call gsi_rfv3io_get_grid_specs(bg_fv3regfilenameg,ierr) + if(ierr/=0)then + write(6,*)' problem in convert_fv3_regional - get_grid_specs Status = ',ierr + call stop2 (555) + endif +end subroutine convert_fv3_regional + diff --git a/src/general_commvars_mod.f90 b/src/gsi/general_commvars_mod.f90 similarity index 96% rename from src/general_commvars_mod.f90 rename to src/gsi/general_commvars_mod.f90 index 9f74d6774..daf182fbd 100644 --- a/src/general_commvars_mod.f90 +++ b/src/gsi/general_commvars_mod.f90 @@ -88,6 +88,9 @@ subroutine init_general_commvars ! program history log: ! 2012-06-25 parrish ! 2013-10-28 todling - rename p3d to prse +! 2018-05-09 mtong - use derivative vector to structure variable s2g_d +! 2018-05-09 eliu - construct variable s2g_d for derivatives when derivative variables +! are set (drv_set_ = .true.) ! ! input argument list: ! @@ -104,6 +107,7 @@ subroutine init_general_commvars ijn_s,irc_s,ijn,displs_g,isc_g,isd_g,vlevs use mpimod, only: npe,levs_id,nvar_id,nvar_pe use control_vectors, only: cvars2d,cvars3d,mvars,cvarsmd,nrf_var + use derivsmod, only: dvars2d, dvars3d, drv_set_ use general_sub2grid_mod, only: general_sub2grid_create_info use mpeu_util, only: getindex @@ -204,29 +208,33 @@ subroutine init_general_commvars ! create general_sub2grid structure variable s2g_d, which is used in get_derivatives.f90 - inner_vars=1 - num_fields=size(cvars2d)+nsig*size(cvars3d) + if (drv_set_) then + + inner_vars=1 + num_fields=size(dvars2d)+nsig*size(dvars3d) ! obtain pointer to each variable in bundle, then populate corresponding names in names_s2g_d for -! general_sub2grid_create_info. this is needed for replacing nvar_id. - allocate(names_s2g_d(inner_vars,num_fields),vector_s2g_d(num_fields)) -! bundlemod stores 3d fields first, followed by 2d fields, followed by 1d fields - i=0 - do k=1,size(cvars3d) - do j=1,nsig +! general_sub2grid_create_info. this is needed for replacing nvar_id. + allocate(names_s2g_d(inner_vars,num_fields),vector_s2g_d(num_fields)) +! bundlemod stores 3d fields first, followed by 2d fields, followed by 1d fields + i=0 + do k=1,size(dvars3d) + do j=1,nsig + i=i+1 + names_s2g_d(1,i)=dvars3d(k) + vector_s2g_d(i)=names_s2g_d(1,i) == 'u'.or.names_s2g_d(1,i) == 'v' + end do + end do + do k=1,size(dvars2d) i=i+1 - names_s2g_d(1,i)=cvars3d(k) - vector_s2g_d(i)=names_s2g_d(1,i) == 'sf'.or.names_s2g_d(1,i) == 'vp' + names_s2g_d(1,i)=dvars2d(k) + vector_s2g_d(i)=names_s2g_d(1,i) == 'u'.or.names_s2g_d(1,i) == 'v' end do - end do - do k=1,size(cvars2d) - i=i+1 - names_s2g_d(1,i)=cvars2d(k) - vector_s2g_d(i)=names_s2g_d(1,i) == 'sf'.or.names_s2g_d(1,i) == 'vp' - end do - call general_sub2grid_create_info(s2g_d,inner_vars,nlat,nlon,nsig,num_fields,regional, & + call general_sub2grid_create_info(s2g_d,inner_vars,nlat,nlon,nsig,num_fields,regional, & vector=vector_s2g_d,names=names_s2g_d,s_ref=s2g_raf) - deallocate(names_s2g_d,vector_s2g_d) + deallocate(names_s2g_d,vector_s2g_d) + + endif ! create general_sub2grid structure variable g1, which is used in get_derivatives.f90 diff --git a/src/gsi/general_read_fv3atm.f90 b/src/gsi/general_read_fv3atm.f90 new file mode 100644 index 000000000..3d2646fbb --- /dev/null +++ b/src/gsi/general_read_fv3atm.f90 @@ -0,0 +1,1101 @@ +subroutine general_read_fv3atm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & + gfs_bundle,init_head,iret_read) +!$$$ subprogram documentation block +! . . . . +! subprogram: general_read_fv3atm adaptation of read_fv3atm for general resolutions +! prgmmr: parrish org: np22 date: 1990-10-10 +! +! abstract: copied from read_gfsatm, primarily for reading in gefs sigma files, where the +! input resolution and the grid that variables are reconstructed on can be +! different from the analysis grid/resolution. +! +! program history log: +! 2018-04-15 eliu - copied from general_read_gfsatm.f90 to handle multiple fv3 physic +! schemes except for Zhao-Carr scheme (imp_physics=99) +! ** imp_physics: 11=GFDL 10=MG 8=Thompson 6=WSM6 +! ** set fv3_full_hydro=.true. and imp_physics in the setup namelist +! (currently working for 11-GFDL; will be generalized for other schemes) +! +! input argument list: +! grd - structure variable containing information about grid +! (initialized by general_sub2grid_create_info, located in general_sub2grid_mod.f90) +! sp_a - structure variable containing spectral information for analysis +! (initialized by general_init_spec_vars, located in general_specmod.f90) +! sp_b - structure variable containing spectral information for input +! fields +! (initialized by general_init_spec_vars, located in general_specmod.f90) +! filename - input sigma file name +! uvflag - logical to use u,v (.true.) or st,vp (.false.) perturbations +! vordivflag - logical to determine if routine should output vorticity and +! divergence +! zflag - logical to determine if surface height field should be output +! init_head- flag to read header record. Usually .true. unless repeatedly +! reading similar files (ensembles) +! +! output argument list: +! gfs_bundle - bundle carrying guess fields +! iret_read - return code, 0 for successful read. +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,r_single,i_kind + use mpimod, only: mype + use general_sub2grid_mod, only: sub2grid_info + use general_specmod, only: spec_vars + use mpimod, only: npe + use constants, only: zero,one,fv,r0_01 + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close + use ncepnems_io, only: error_msg + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv + use egrid2agrid_mod,only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid + use general_commvars_mod, only: fill2_ns,filluv2_ns + use constants, only: two,pi,half,deg2rad,r60,r3600 + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_metguess_mod, only: gsi_metguess_get + use ncepnems_io, only: imp_physics + + + implicit none + + ! Declare local parameters + real(r_kind),parameter:: r0_001 = 0.001_r_kind + + ! Declare passed variables + type(sub2grid_info) ,intent(in ) :: grd + type(spec_vars) ,intent(in ) :: sp_a + character(*) ,intent(in ) :: filename + logical ,intent(in ) :: uvflag,zflag,vordivflag,init_head + integer(i_kind) ,intent( out) :: iret_read + type(gsi_bundle) ,intent(inout) :: gfs_bundle + + real(r_kind),pointer,dimension(:,:) :: ptr2d + real(r_kind),pointer,dimension(:,:,:) :: ptr3d + real(r_kind),pointer,dimension(:,:) :: g_ps + real(r_kind),pointer,dimension(:,:,:) :: g_vor,g_div,& + g_q,g_oz,g_tv + real(r_kind),pointer,dimension(:,:,:) :: g_ql,g_qi,g_qr,g_qs,g_qg,g_cf + real(r_kind),allocatable,dimension(:,:) :: g_z + real(r_kind),allocatable,dimension(:,:,:) :: g_u,g_v + + ! Declare local variables + character(len=120) :: my_name = 'GENERAL_READ_FV3ATM_NEMS' + character(len=1) :: null = ' ' + integer(i_kind):: iret,nlatm2,nlevs,icm,nord_int + integer(i_kind):: i,j,k,icount,kk + integer(i_kind) :: ier,istatus,istatus1,iredundant + integer(i_kind) :: latb, lonb, levs, nframe + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind) :: istop = 101 + integer(i_kind),dimension(npe)::ilev,iflag,mype_use + integer(i_kind),dimension(7):: idate + integer(i_kind),dimension(4):: odate + real(r_kind) :: fhour + + real(r_kind),allocatable,dimension(:):: spec_div,spec_vor + real(r_kind),allocatable,dimension(:,:) :: grid, grid_v, & + grid_vor, grid_div, grid_b, grid_b2 + real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid2, grid_c2 + real(r_kind),allocatable,dimension(:) :: work, work_v + real(r_kind),allocatable,dimension(:) :: rwork1d0, rwork1d1 + real(r_kind),allocatable,dimension(:) :: rlats,rlons,clons,slons + real(4),allocatable,dimension(:) :: r4lats,r4lons + + logical :: procuse,diff_res,eqspace + type(nemsio_gfile) :: gfile + type(egrid2agrid_parm) :: p_high + logical,dimension(1) :: vector + + !****************************************************************************** + ! Initialize variables used below + iret_read=0 + iret=0 + nlatm2=grd%nlat-2 + iflag = 0 + ilev = 0 + + nlevs=grd%nsig + mype_use=-1 + icount=0 + procuse=.false. + if ( mype == 0 ) procuse = .true. + do i=1,npe + if ( grd%recvcounts_s(i-1) > 0 ) then + icount = icount+1 + mype_use(icount)=i-1 + if ( i-1 == mype ) procuse=.true. + endif + enddo + icm=icount + allocate( work(grd%itotsub),work_v(grd%itotsub) ) + work=zero + work_v=zero + + if ( procuse ) then + + if ( init_head)call nemsio_init(iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'init',istop,iret) + + call nemsio_open(gfile,filename,'READ',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop+1,iret) + + call nemsio_getfilehead(gfile,iret=iret, nframe=nframe, & + nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + idate=idate, dimx=lonb, dimy=latb,dimz=levs) + + if ( nframe /= 0 ) then + if ( mype == 0 ) & + write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe + call stop2(101) + endif + + fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + + diff_res=.false. + if ( latb /= nlatm2 ) then + diff_res=.true. + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlatm2 = '',i4,tr1,''latb = '',i4)') & + trim(my_name),nlatm2,latb + !call stop2(101) + endif + if ( lonb /= grd%nlon ) then + diff_res=.true. + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlon = '',i4,tr1,''lonb = '',i4)') & + trim(my_name),grd%nlon,lonb + !call stop2(101) + endif + if ( levs /= grd%nsig ) then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & + trim(my_name),grd%nsig,levs + call stop2(101) + endif + + allocate( spec_vor(sp_a%nc), spec_div(sp_a%nc) ) + allocate( grid(grd%nlon,nlatm2), grid_v(grd%nlon,nlatm2) ) + if ( diff_res ) then + allocate(grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid2(grd%nlat,grd%nlon,1)) + allocate(grid_b2(lonb,latb),grid_c2(latb+2,lonb,1)) + endif + allocate(rwork1d0(latb*lonb)) + allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) + allocate(rwork1d1(latb*lonb)) + call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) + call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) + do j=1,latb + rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) + enddo + do j=1,lonb + rlons(j)=deg2rad*r4lons(j) + enddo + deallocate(r4lats,r4lons) + rlats(1)=-half*pi + rlats(latb+2)=half*pi + do j=1,lonb + clons(j)=cos(rlons(j)) + slons(j)=sin(rlons(j)) + enddo + + nord_int=4 + eqspace=.false. + call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons, & + latb+2,rlats,lonb,rlons,& + nord_int,p_high,.true.,eqspace=eqspace) + deallocate(rlats,rlons) + + endif ! if ( procuse ) + + ! Get pointer to relevant variables (this should be made flexible and general) + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_fv3atm_nems: ERROR' + write(6,*) 'cannot handle having both sf and div' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_fv3atm_nems: ERROR' + write(6,*) 'cannot handle having both vp and vor' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_fv3atm_nems: ERROR' + write(6,*) 'cannot handle having both t and tv' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus = istatus + ier + call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus = istatus + ier + call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus = istatus + ier + call gsi_bundlegetpointer(gfs_bundle,'ql',g_ql ,ier);istatus1= istatus + ier + call gsi_bundlegetpointer(gfs_bundle,'qi',g_qi ,ier);istatus1= istatus1+ ier + call gsi_bundlegetpointer(gfs_bundle,'qr',g_qr ,ier);istatus1= istatus1+ ier + call gsi_bundlegetpointer(gfs_bundle,'qs',g_qs ,ier);istatus1= istatus1+ ier + call gsi_bundlegetpointer(gfs_bundle,'qg',g_qg ,ier);istatus1= istatus1+ ier + call gsi_bundlegetpointer(gfs_bundle,'cf',g_cf ,ier);istatus1= istatus1+ ier + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_fv3atm_nems: ERROR' + write(6,*) 'Missing some of the required fields' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + if ( istatus1 /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_fv3atm_nems: ERROR' + write(6,*) 'Missing some of the required hydrometeor fields for imp_physics = ', imp_physics + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + + allocate(g_u(grd%lat2,grd%lon2,grd%nsig),g_v(grd%lat2,grd%lon2,grd%nsig)) + allocate(g_z(grd%lat2,grd%lon2)) + + icount=0 + + ! Process guess fields according to type of input file. NCEP_SIGIO files + ! are spectral coefficient files and need to be transformed to the grid. + ! Once on the grid, fields need to be scattered from the full domain to + ! sub-domains. + + ! Only read Terrain when zflag is true. + if ( zflag ) then + + icount=icount+1 + iflag(icount)=1 + ilev(icount)=1 + + ! Terrain: spectral --> grid transform, scatter to all mpi tasks + if (mype==mype_use(icount)) then + ! read hs + call nemsio_readrecv(gfile,'hgt', 'sfc',1,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','read',istop+2,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + endif + + icount=icount+1 + iflag(icount)=2 + ilev(icount)=1 + + ! Surface pressure: same procedure as terrain + if (mype==mype_use(icount)) then + ! read ps + call nemsio_readrecv(gfile,'pres','sfc',1,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pres','read',istop+3,iret) + rwork1d1 = r0_001*rwork1d0 ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d1,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + ! Thermodynamic variable: s-->g transform, communicate to all tasks + ! For multilevel fields, each task handles a given level. Periodic + ! mpi_alltoallv calls communicate the grids to all mpi tasks. + ! Finally, the grids are loaded into guess arrays used later in the + ! code. + + do k=1,nlevs + + icount=icount+1 + iflag(icount)=3 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! read T/Tv/etc. + call nemsio_readrecv(gfile,'tmp','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop+7,iret) + call nemsio_readrecv(gfile,'spfh','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','read',istop+7,iret) + rwork1d0=rwork1d0*(one+fv*rwork1d1) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + if ( vordivflag .or. .not. uvflag ) then + + icount=icount+1 + iflag(icount)=4 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Vorticity + ! Convert grid u,v to div and vor + call nemsio_readrecv(gfile,'ugrd','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','read',istop+4,iret) + call nemsio_readrecv(gfile,'vgrd','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','read',istop+5,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + grid_b2=reshape(rwork1d1,(/size(grid_b2,1),size(grid_b2,2)/)) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + grid_v=reshape(rwork1d1,(/size(grid_v,1),size(grid_v,2)/)) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_vor(grd%nlon,nlatm2)) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_vor,work) + deallocate(grid_vor) + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=5 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Divergence + ! Convert grid u,v to div and vor + call nemsio_readrecv(gfile,'ugrd','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','read',istop+4,iret) + call nemsio_readrecv(gfile,'vgrd','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','read',istop+5,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + grid_b2=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + grid_v=reshape(rwork1d1,(/size(grid_v,1),size(grid_v,2)/)) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_div(grd%nlon,nlatm2) ) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_div,work) + deallocate(grid_div) + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + endif ! if ( vordivflag .or. .not. uvflag ) + + if ( uvflag ) then + + icount=icount+1 + iflag(icount)=6 + ilev(icount)=k + + if (mype==mype_use(icount)) then + + ! U + call nemsio_readrecv(gfile,'ugrd','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','read',istop+4,iret) + call nemsio_readrecv(gfile,'vgrd','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','read',istop+5,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + grid_b2=reshape(rwork1d1,(/size(grid_b2,1),size(grid_b2,2)/)) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + grid_v=reshape(rwork1d1,(/size(grid_v,1),size(grid_v,2)/)) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=7 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! V + call nemsio_readrecv(gfile,'ugrd','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','read',istop+4,iret) + call nemsio_readrecv(gfile,'vgrd','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','read',istop+5,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + grid_b2=reshape(rwork1d1,(/size(grid_b2,1),size(grid_b2,2)/)) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + grid_v=reshape(rwork1d1,(/size(grid_v,1),size(grid_v,2)/)) + ! Note work_v and work are switched because output must be in work. + call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + endif ! if ( uvflag ) + + icount=icount+1 + iflag(icount)=8 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Specific humidity + call nemsio_readrecv(gfile,'spfh','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','read',istop+6,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=9 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Ozone mixing ratio + call nemsio_readrecv(gfile,'o3mr','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','read',istop+8,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=10 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Cloud liquid water mixing ratio + call nemsio_readrecv(gfile,'clwmr','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','read',istop+9,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=11 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Cloud ice water mixing ratio + call nemsio_readrecv(gfile,'icmr','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','read',istop+10,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=12 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! rain water mixing ratio + call nemsio_readrecv(gfile,'rwmr','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','read',istop+11,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=13 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! snow water mixing ratio + call nemsio_readrecv(gfile,'snmr','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','read',istop+12,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=14 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! snow water mixing ratio + call nemsio_readrecv(gfile,'grle','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'grle','read',istop+13,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=15 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! cloud amount + call nemsio_readrecv(gfile,'cld_amt','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'cld_amt','read',istop+14,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm .or. k==nlevs ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + enddo ! do k=1,nlevs + + if ( procuse ) then + if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2) + call destroy_egrid2agrid(p_high) + deallocate(spec_div,spec_vor) + deallocate(rwork1d1,clons,slons) + deallocate(rwork1d0) + deallocate(grid,grid_v) + call nemsio_close(gfile,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop+9,iret) + endif + deallocate(work,work_v) + + ! Convert dry temperature to virtual temperature + !do k=1,grd%nsig + ! do j=1,grd%lon2 + ! do i=1,grd%lat2 + ! g_tv(i,j,k) = g_tv(i,j,k)*(one+fv*g_q(i,j,k)) + ! enddo + ! enddo + !enddo + + ! Load u->div and v->vor slot when uv are used instead + if ( uvflag ) then + call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + endif + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + if (zflag) then + call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier) + if ( ier == 0 ) ptr2d=g_z + endif + + ! Clean up + deallocate(g_z) + deallocate(g_u,g_v) + + ! Print date/time stamp + if ( mype == 0 ) then + write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,& + fhour,odate,trim(filename) +700 format('GENERAL_READ_FV3ATM_NEMS: read lonb,latb,levs=',& + 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a) + endif + + return + + ! ERROR detected while reading file +1000 continue + write(6,*)'GENERAL_READ_FV3ATM_NEMS: ***ERROR*** reading ',& + trim(filename),' mype,iret_read=',mype,iret_read,grd%nsig,nlevs + return + + ! End of routine. Return + + return +end subroutine general_read_fv3atm_nems + +subroutine general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_cf,icount,iflag,ilev,work,uvflag,vdflag) + +! !USES: + + use kinds, only: r_kind,i_kind + use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype + use general_sub2grid_mod, only: sub2grid_info + implicit none + +! !INPUT PARAMETERS: + + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(inout) :: icount + integer(i_kind),dimension(npe), intent(inout) :: ilev,iflag + real(r_kind),dimension(grd%itotsub),intent(in ) :: work + logical, intent(in ) :: uvflag,vdflag + +! !OUTPUT PARAMETERS: + + real(r_kind),dimension(grd%lat2,grd%lon2), intent( out) :: g_ps + real(r_kind),dimension(grd%lat2,grd%lon2), intent(inout) :: g_z + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent( out) :: g_u,g_v,& + g_vor,g_div,g_q,g_oz,g_tv,g_ql,g_qi,g_qr,g_qs,g_qg,g_cf + + +! !DESCRIPTION: Transfer contents of 2-d array global to 3-d subdomain array +! +! !REVISION HISTORY: +! 2004-05-14 treadon +! 2004-07-15 todling, protex-compliant prologue +! 2014-12-03 derber - introduce vdflag and optimize routines +! +! !REMARKS: +! +! language: f90 +! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp +! +! !AUTHOR: +! treadon org: np23 date: 2004-05-14 +! +!EOP +!------------------------------------------------------------------------- + + integer(i_kind) i,j,k,ij,klev + real(r_kind),dimension(grd%lat2*grd%lon2,npe):: sub + + call mpi_alltoallv(work,grd%sendcounts_s,grd%sdispls_s,mpi_rtype,& + sub,grd%recvcounts_s,grd%rdispls_s,mpi_rtype,& + mpi_comm_world,ierror) + +!$omp parallel do schedule(dynamic,1) private(k,i,j,ij,klev) + do k=1,icount + if ( iflag(k) == 1 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_z(i,j)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 2 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_ps(i,j)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 3 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_tv(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 4 ) then + klev=ilev(k) + if ( vdflag ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_vor(i,j,klev)=sub(ij,k) + enddo + enddo + endif + if ( .not. uvflag ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_u(i,j,klev)=sub(ij,k) + enddo + enddo + endif + elseif ( iflag(k) == 5 ) then + klev=ilev(k) + if ( vdflag ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_div(i,j,klev)=sub(ij,k) + enddo + enddo + endif + if ( .not. uvflag ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_v(i,j,klev)=sub(ij,k) + enddo + enddo + endif + elseif ( iflag(k) == 6 ) then + if ( .not. uvflag) then + write(6,*) 'error in general_reload u ' + endif + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_u(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 7 ) then + if ( .not. uvflag) then + write(6,*) 'error in general_reload v ' + endif + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_v(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 8 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_q(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 9 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_oz(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 10 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_ql(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 11 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_qi(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 12 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_qr(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 13 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_qs(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 14 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_qg(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 15 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_cf(i,j,klev)=sub(ij,k) + enddo + enddo + endif + enddo ! do k=1,icount + + icount=0 + ilev=0 + iflag=0 + + return + +end subroutine general_reload2 diff --git a/src/general_read_gfsatm.f90 b/src/gsi/general_read_gfsatm.f90 old mode 100644 new mode 100755 similarity index 91% rename from src/general_read_gfsatm.f90 rename to src/gsi/general_read_gfsatm.f90 index 88ec6e5ac..c73638b14 --- a/src/general_read_gfsatm.f90 +++ b/src/gsi/general_read_gfsatm.f90 @@ -1,3 +1,196 @@ +module gfsreadmod + +contains +subroutine general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vdflag,g_cf) +! !USES: + use kinds, only: r_kind,i_kind + use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype + use general_sub2grid_mod, only: sub2grid_info + + implicit none +! !INPUT PARAMETERS: + + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(inout) :: icount + integer(i_kind),dimension(npe), intent(inout) :: ilev,iflag + real(r_kind),dimension(grd%itotsub),intent(in ) :: work + logical, intent(in ) :: uvflag,vdflag + +! !OUTPUT PARAMETERS: + + real(r_kind),dimension(grd%lat2,grd%lon2), intent( out) :: g_ps + real(r_kind),dimension(grd%lat2,grd%lon2), intent(inout) :: g_z + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent( out) :: g_u,g_v,& + g_vor,g_div,g_cwmr,g_q,g_oz,g_tv + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent( out),optional :: g_cf + + +! !DESCRIPTION: Transfer contents of 2-d array global to 3-d subdomain array +! +! !REVISION HISTORY: +! 2004-05-14 treadon +! 2004-07-15 todling, protex-compliant prologue +! 2014-12-03 derber - introduce vdflag and optimize routines +! +! !REMARKS: +! +! language: f90 +! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp +! +! !AUTHOR: +! treadon org: np23 date: 2004-05-14 +! +!EOP +!------------------------------------------------------------------------- + + integer(i_kind) i,j,k,ij,klev + real(r_kind),dimension(grd%lat2*grd%lon2,npe):: sub + + call mpi_alltoallv(work,grd%sendcounts_s,grd%sdispls_s,mpi_rtype,& + sub,grd%recvcounts_s,grd%rdispls_s,mpi_rtype,& + mpi_comm_world,ierror) + +!$omp parallel do schedule(dynamic,1) private(k,i,j,ij,klev) + do k=1,icount + if ( iflag(k) == 1 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_z(i,j)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 2 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_ps(i,j)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 3 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_tv(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 4 ) then + klev=ilev(k) + if ( vdflag ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_vor(i,j,klev)=sub(ij,k) + enddo + enddo + endif + if ( .not. uvflag ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_u(i,j,klev)=sub(ij,k) + enddo + enddo + endif + elseif ( iflag(k) == 5 ) then + klev=ilev(k) + if ( vdflag ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_div(i,j,klev)=sub(ij,k) + enddo + enddo + endif + if ( .not. uvflag ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_v(i,j,klev)=sub(ij,k) + enddo + enddo + endif + elseif ( iflag(k) == 6 ) then + if ( .not. uvflag) then + write(6,*) 'error in general_reload u ' + endif + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_u(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 7 ) then + if ( .not. uvflag) then + write(6,*) 'error in general_reload v ' + endif + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_v(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 8 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_q(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 9 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_oz(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 10 ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_cwmr(i,j,klev)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 11 .and. present(g_cf) ) then + klev=ilev(k) + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_cf(i,j,klev)=sub(ij,k) + enddo + enddo + endif + enddo ! do k=1,icount + + icount=0 + ilev=0 + iflag=0 + + return + +end subroutine general_reload + +end module gfsreadmod + subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, & gfs_bundle,init_head,iret_read) !$$$ subprogram documentation block @@ -55,6 +248,7 @@ subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, & sigio_rrdbti,sigio_rclose use ncepgfs_io, only: sigio_cnvtdv8,sighead use gsi_bundlemod, only: gsi_bundle,gsi_bundlegetpointer + use gfsreadmod, only: general_reload implicit none @@ -122,9 +316,17 @@ subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, & call sigio_rropen(lunges,filename,iret) if ( init_head .or. mype == 0 ) then call sigio_rrhead(lunges,sighead,iret_read) - if ( iret_read /= 0 ) goto 1000 + if ( iret_read /= 0 ) then + write(6,*)'GENERAL_READ_GFSATM: ***ERROR*** reading ',& + trim(filename),' mype,iret_read=',mype,iret_read,grd%nsig,nlevs + return + end if endif - if ( nlevs /= sighead%levs ) goto 1000 + if ( nlevs /= sighead%levs ) then + write(6,*)'GENERAL_READ_GFSATM: ***ERROR*** reading ',& + trim(filename),' mype,iret_read=',mype,iret_read,grd%nsig,nlevs + return + end if endif ! Get pointer to relevant variables (this should be made flexible and general) @@ -556,15 +758,6 @@ subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, & return - ! ERROR detected while reading file -1000 continue - write(6,*)'GENERAL_READ_GFSATM: ***ERROR*** reading ',& - trim(filename),' mype,iret_read=',mype,iret_read,grd%nsig,nlevs - return - - ! End of routine. Return - - return end subroutine general_read_gfsatm subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & @@ -585,6 +778,7 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & ! 2014-11-30 todling - genelize interface to handle bundle instead of fields; ! internal code should be generalized ! 2014-12-03 derber - introduce vordivflag, zflag and optimize routines +! 2019-06-06 eliu - add cloud fraction ! ! input argument list: ! grd - structure variable containing information about grid @@ -617,15 +811,15 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & use general_specmod, only: spec_vars use mpimod, only: npe use constants, only: zero,one,fv,r0_01 - use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close - use ncepnems_io, only: error_msg - use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close,nemsio_charkind + use ncepnems_io, only: error_msg,imp_physics + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv,nemsio_getrechead use egrid2agrid_mod,only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid use general_commvars_mod, only: fill2_ns,filluv2_ns use constants, only: two,pi,half,deg2rad,r60,r3600 use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer - use control_vectors, only: imp_physics + use gfsreadmod, only: general_reload implicit none @@ -644,7 +838,7 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & real(r_kind),pointer,dimension(:,:,:) :: ptr3d real(r_kind),pointer,dimension(:,:) :: g_ps real(r_kind),pointer,dimension(:,:,:) :: g_vor,g_div,& - g_cwmr,g_q,g_oz,g_tv + g_cwmr,g_q,g_oz,g_tv,g_cf real(r_kind),allocatable,dimension(:,:) :: g_z real(r_kind),allocatable,dimension(:,:,:) :: g_u,g_v @@ -652,6 +846,7 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & ! Declare local variables character(len=120) :: my_name = 'GENERAL_READ_GFSATM_NEMS' character(len=1) :: null = ' ' + integer(i_kind):: jrec,nrec integer(i_kind):: iret,nlatm2,nlevs,icm,nord_int integer(i_kind):: i,j,k,icount,kk integer(i_kind) :: ier,istatus,iredundant @@ -672,7 +867,8 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & real(r_kind),allocatable,dimension(:) :: rlats,rlons,clons,slons real(4),allocatable,dimension(:) :: r4lats,r4lons - logical :: procuse,diff_res,eqspace + logical :: procuse,diff_res,eqspace,has_cf + character(nemsio_charkind),allocatable:: recname(:) type(nemsio_gfile) :: gfile type(egrid2agrid_parm) :: p_high logical,dimension(1) :: vector @@ -720,6 +916,16 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & call stop2(101) endif + ! check if cloud fraction (cld_amt) is in the file + call nemsio_getfilehead(gfile,nrec=nrec,iret=iret) + allocate(recname(nrec)) + call nemsio_getfilehead(gfile,recname=recname,iret=iret) + has_cf = .false. + do jrec=1,nrec + if (recname(jrec)=='cld_amt') has_cf=.true. + enddo + if (mype==0) write(6,*) trim(my_name), ' has_cf = ', has_cf + fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 odate(1) = idate(4) !hour odate(2) = idate(2) !month @@ -827,6 +1033,8 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier + if(has_cf) call gsi_bundlegetpointer(gfs_bundle,'cf',g_cf, ier);istatus=istatus+ier + if ( istatus /= 0 ) then if ( mype == 0 ) then write(6,*) 'general_read_gfsatm_nems: ERROR' @@ -873,8 +1081,13 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & endif endif if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif endif endif @@ -904,8 +1117,13 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & endif endif if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif endif ! Thermodynamic variable: s-->g transform, communicate to all tasks @@ -943,8 +1161,13 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & endif endif if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif endif if ( vordivflag .or. .not. uvflag ) then @@ -1000,8 +1223,13 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & deallocate(grid_vor) endif if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif endif icount=icount+1 @@ -1055,8 +1283,13 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & deallocate(grid_div) endif if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif endif endif ! if ( vordivflag .or. .not. uvflag ) @@ -1092,8 +1325,13 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & endif endif if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif endif icount=icount+1 @@ -1125,8 +1363,13 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & endif endif if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif endif endif ! if ( uvflag ) @@ -1155,8 +1398,13 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & endif endif if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif endif icount=icount+1 @@ -1183,8 +1431,13 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & endif endif if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif endif icount=icount+1 @@ -1218,13 +1471,47 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) call general_fill_ns(grd,grid,work) endif + endif + ! if ( icount == icm .or. k == nlevs ) then + if ( icount == icm .or. ( (.not. has_cf) .and. k==nlevs) ) then + if (has_cf) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) + else + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + endif - endif + if (has_cf) then + icount=icount+1 + iflag(icount)=11 + ilev(icount)=k - if ( icount == icm .or. k == nlevs ) then + if (mype==mype_use(icount)) then + ! cloud amount + call nemsio_readrecv(gfile,'cld_amt','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'cld_amt','read',istop+11,iret) + if ( diff_res ) then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm .or. k==nlevs ) then call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + icount,iflag,ilev,work,uvflag,vordivflag,g_cf) endif + endif enddo ! do k=1,nlevs @@ -1278,6 +1565,8 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & ! Clean up deallocate(g_z) deallocate(g_u,g_v) + if (allocated(recname)) deallocate(recname) + ! Print date/time stamp if ( mype == 0 ) then @@ -1289,197 +1578,8 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & return - ! ERROR detected while reading file -1000 continue - write(6,*)'GENERAL_READ_GFSATM_NEMS: ***ERROR*** reading ',& - trim(filename),' mype,iret_read=',mype,iret_read,grd%nsig,nlevs - return - - ! End of routine. Return - - return end subroutine general_read_gfsatm_nems -subroutine general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vdflag) - -! !USES: - - use kinds, only: r_kind,i_kind - use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype - use general_sub2grid_mod, only: sub2grid_info - implicit none - -! !INPUT PARAMETERS: - - type(sub2grid_info), intent(in ) :: grd - integer(i_kind), intent(inout) :: icount - integer(i_kind),dimension(npe), intent(inout) :: ilev,iflag - real(r_kind),dimension(grd%itotsub),intent(in ) :: work - logical, intent(in ) :: uvflag,vdflag - -! !OUTPUT PARAMETERS: - - real(r_kind),dimension(grd%lat2,grd%lon2), intent( out) :: g_ps - real(r_kind),dimension(grd%lat2,grd%lon2), intent(inout) :: g_z - real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent( out) :: g_u,g_v,& - g_vor,g_div,g_cwmr,g_q,g_oz,g_tv - - -! !DESCRIPTION: Transfer contents of 2-d array global to 3-d subdomain array -! -! !REVISION HISTORY: -! 2004-05-14 treadon -! 2004-07-15 todling, protex-compliant prologue -! 2014-12-03 derber - introduce vdflag and optimize routines -! -! !REMARKS: -! -! language: f90 -! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp -! -! !AUTHOR: -! treadon org: np23 date: 2004-05-14 -! -!EOP -!------------------------------------------------------------------------- - - integer(i_kind) i,j,k,ij,klev - real(r_kind),dimension(grd%lat2*grd%lon2,npe):: sub - - call mpi_alltoallv(work,grd%sendcounts_s,grd%sdispls_s,mpi_rtype,& - sub,grd%recvcounts_s,grd%rdispls_s,mpi_rtype,& - mpi_comm_world,ierror) - -!$omp parallel do schedule(dynamic,1) private(k,i,j,ij,klev) - do k=1,icount - if ( iflag(k) == 1 ) then - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_z(i,j)=sub(ij,k) - enddo - enddo - elseif ( iflag(k) == 2 ) then - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_ps(i,j)=sub(ij,k) - enddo - enddo - elseif ( iflag(k) == 3 ) then - klev=ilev(k) - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_tv(i,j,klev)=sub(ij,k) - enddo - enddo - elseif ( iflag(k) == 4 ) then - klev=ilev(k) - if ( vdflag ) then - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_vor(i,j,klev)=sub(ij,k) - enddo - enddo - endif - if ( .not. uvflag ) then - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_u(i,j,klev)=sub(ij,k) - enddo - enddo - endif - elseif ( iflag(k) == 5 ) then - klev=ilev(k) - if ( vdflag ) then - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_div(i,j,klev)=sub(ij,k) - enddo - enddo - endif - if ( .not. uvflag ) then - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_v(i,j,klev)=sub(ij,k) - enddo - enddo - endif - elseif ( iflag(k) == 6 ) then - if ( .not. uvflag) then - write(6,*) 'error in general_reload u ' - endif - klev=ilev(k) - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_u(i,j,klev)=sub(ij,k) - enddo - enddo - elseif ( iflag(k) == 7 ) then - if ( .not. uvflag) then - write(6,*) 'error in general_reload v ' - endif - klev=ilev(k) - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_v(i,j,klev)=sub(ij,k) - enddo - enddo - elseif ( iflag(k) == 8 ) then - klev=ilev(k) - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_q(i,j,klev)=sub(ij,k) - enddo - enddo - elseif ( iflag(k) == 9 ) then - klev=ilev(k) - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_oz(i,j,klev)=sub(ij,k) - enddo - enddo - elseif ( iflag(k) == 10 ) then - klev=ilev(k) - ij=0 - do j=1,grd%lon2 - do i=1,grd%lat2 - ij=ij+1 - g_cwmr(i,j,klev)=sub(ij,k) - enddo - enddo - endif - enddo ! do k=1,icount - - icount=0 - ilev=0 - iflag=0 - - return - -end subroutine general_reload - subroutine general_fill_ns(grd,grid_in,grid_out) ! !USES: diff --git a/src/gsi/general_read_nemsaero.f90 b/src/gsi/general_read_nemsaero.f90 new file mode 100644 index 000000000..721545bc6 --- /dev/null +++ b/src/gsi/general_read_nemsaero.f90 @@ -0,0 +1,550 @@ +subroutine general_read_nemsaero(grd,sp_a,filename,mype,gfschem_bundle, & + naero,aeroname,init_head,iret_read) +!$$$ subprogram documentation block +! . . . . +! subprogram: general_read_nemsaero adaptation of general_read_gfsatm +! for reading in aerosols from NEMSI/O +! +! abstract: copied from general_read_gfsatm, primarily for reading in aerosol +! tracer variables from NEMS GFS I/O files +! +! program history log: +! 2019-04-19 Wei/Martin - copied and modified to read in aerosol arrays +! from either FV3-Chem or NEMS +! +! input argument list: +! grd - structure variable containing information about grid +! (initialized by general_sub2grid_create_info, +! located in general_sub2grid_mod.f90) +! sp_a - structure variable containing spectral information for +! analysis +! (initialized by general_init_spec_vars, located in +! general_specmod.f90) +! filename - input sigma file name +! mype - mpi task id +! naero - number of aerosol tracers to read +! aeroname - len(naero) character strings of aerosol tracers to read +! init_head- flag to read header record. Usually .true. unless +! repeatedly +! reading similar files (ensembles) +! +! input/output list: +! gfschem_bundle - GSI bundle containing chem/aerosol arrays +! +! output argument list: +! iret_read - return code, 0 for successful read. +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,r_single,i_kind + use gridmod, only: use_fv3_aero + use general_commvars_mod, only: fill_ns,fill2_ns + use general_sub2grid_mod, only: sub2grid_info + use general_specmod, only: spec_vars + use mpimod, only: npe + use constants, only: zero,one,r0_01 + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close + use ncepnems_io, only: error_msg + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv + use egrid2agrid_mod, only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid + use constants, only: two,pi,half,deg2rad,r60,r3600 + use gsi_bundlemod, only: gsi_bundle, gsi_bundlegetpointer + + implicit none + +! Declare local parameters + real(r_kind),parameter:: r0_001 = 0.001_r_kind + +! Declare passed variables + type(sub2grid_info) ,intent(in ) :: grd + type(spec_vars) ,intent(in ) :: sp_a + character(*) ,intent(in ) :: filename + integer(i_kind) ,intent(in ) :: mype + integer(i_kind) ,intent(in ) :: naero + character(*),dimension(naero) ,intent(in ) :: aeroname + logical ,intent(in ) :: init_head + integer(i_kind) ,intent( out) :: iret_read + type(gsi_bundle) ,intent(inout) :: gfschem_bundle + +! Declare local variables + character(len=120) :: my_name = 'general_read_nemsaero' + character(len=1) :: null = ' ' + character(len=20),dimension(npe) :: ch_aero + integer(i_kind):: iret,nlatm2,nlevs,icm,nord_int + integer(i_kind):: i,j,k,l,icount,kk,istatus,ier + integer(i_kind) :: latb, lonb, levs, nframe + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind) :: istop = 101 + integer(i_kind),dimension(npe)::ilev,iflag,mype_use + integer(i_kind),dimension(7):: idate + integer(i_kind),dimension(4):: odate + real(r_kind) :: fhour + real(r_kind),dimension(:,:,:),pointer :: & + ae_d1,ae_d2,ae_d3,ae_d4,ae_d5,& + ae_s1,ae_s2,ae_s3,ae_s4,ae_so4,& + ae_ocpho,ae_ocphi,ae_bcpho,ae_bcphi + + real(r_kind),allocatable,dimension(:,:) :: grid, grid_v,grid_b + real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid2 + real(r_kind),allocatable,dimension(:) :: work + real(r_kind),allocatable,dimension(:) :: rwork1d0, rwork1d1, rwork1d2 + real(r_kind),allocatable,dimension(:) :: rlats,rlons,clons,slons + real(r_single),allocatable,dimension(:) :: r4lats,r4lons + + logical :: procuse,diff_res,eqspace + type(nemsio_gfile) :: gfile + type(egrid2agrid_parm) :: p_high + logical,dimension(1) :: vector + +!****************************************************************************** + if(mype==0) write(6,*) trim(my_name)," start and filename is ",trim(filename) + +! Initialize variables used below + iret_read=0 + iret=0 + nlatm2=grd%nlat-2 + iflag = 0 + ilev = 0 + + nlevs=grd%nsig + mype_use=-1 + icount=0 + procuse=.false. + if(mype == 0)procuse = .true. + do i=1,npe + if(grd%recvcounts_s(i-1) > 0)then + icount = icount+1 + mype_use(icount)=i-1 + if(i-1 == mype) procuse=.true. + end if + end do + icm=icount + allocate( work(grd%itotsub)) + work=zero + if(procuse)then + + if (init_head) call nemsio_init(iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'init',istop,iret) + + call nemsio_open(gfile,filename,'READ',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop+1,iret) + + call nemsio_getfilehead(gfile,iret=iret, nframe=nframe, & + nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + idate=idate, dimx=lonb, dimy=latb,dimz=levs) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'getfilehead',istop+1,iret) + + if( nframe /= 0 ) then + if ( mype == 0 ) & + write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe + call stop2(101) + end if + + fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + + if ( iret == 0 .and. mype == 0 ) then + write(6,'(''Aerosol file time='',i4.4,i2.2,i2.2,i2.2)') odate(4),odate(2),odate(3),odate(1) + end if +! +! g_* array already pre-allocate as (lat2,lon2,) => 2D and <3D> +! array +! + diff_res=.false. + if(latb /= nlatm2) then + diff_res=.true. + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlatm2 = '',i4,tr1,''latb = '',i4)') & + trim(my_name),nlatm2,latb + end if + if(lonb /= grd%nlon) then + diff_res=.true. + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlon = '',i4,tr1,''lonb = '',i4)') & + trim(my_name),grd%nlon,lonb + end if + if(levs /= grd%nsig)then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & + trim(my_name),grd%nsig,levs + call stop2(101) + end if + + allocate( grid(grd%nlon,nlatm2), grid_v(grd%nlon,nlatm2) ) + if(diff_res)then + allocate( grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid2(grd%nlat,grd%nlon,1)) + end if + allocate( rwork1d0(latb*lonb) ) + allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) + allocate(rwork1d1(latb*lonb),rwork1d2(latb*lonb)) + call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) + call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) + do j=1,latb + rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) + end do + do j=1,lonb + rlons(j)=deg2rad*r4lons(j) + end do + deallocate(r4lats,r4lons) + rlats(1)=-half*pi + rlats(latb+2)=half*pi + do j=1,lonb + clons(j)=cos(rlons(j)) + slons(j)=sin(rlons(j)) + end do + + nord_int=4 + eqspace=.false. + + call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons,& + latb+2,rlats,lonb,rlons,& + nord_int,p_high,.true.,eqspace=eqspace) + deallocate(rlats,rlons) + + end if + + istatus=0 + do l=1,naero + select case(trim(aeroname(l))) + case ('sulf') + call gsi_bundlegetpointer(gfschem_bundle,'sulf' ,ae_so4 ,ier); istatus=istatus+ier + case ('oc1') + call gsi_bundlegetpointer(gfschem_bundle,'oc1' ,ae_ocpho,ier); istatus=istatus+ier + case ('oc2') + call gsi_bundlegetpointer(gfschem_bundle,'oc2' ,ae_ocphi,ier); istatus=istatus+ier + case ('bc1') + call gsi_bundlegetpointer(gfschem_bundle,'bc1' ,ae_bcpho,ier); istatus=istatus+ier + case ('bc2') + call gsi_bundlegetpointer(gfschem_bundle,'bc2' ,ae_bcphi,ier); istatus=istatus+ier + case ('dust1') + call gsi_bundlegetpointer(gfschem_bundle,'dust1',ae_d1 ,ier); istatus=istatus+ier + case ('dust2') + call gsi_bundlegetpointer(gfschem_bundle,'dust2',ae_d2 ,ier); istatus=istatus+ier + case ('dust3') + call gsi_bundlegetpointer(gfschem_bundle,'dust3',ae_d3 ,ier); istatus=istatus+ier + case ('dust4') + call gsi_bundlegetpointer(gfschem_bundle,'dust4',ae_d4 ,ier); istatus=istatus+ier + case ('dust5') + call gsi_bundlegetpointer(gfschem_bundle,'dust5',ae_d5 ,ier); istatus=istatus+ier + case ('seas1') + call gsi_bundlegetpointer(gfschem_bundle,'seas1',ae_s1 ,ier); istatus=istatus+ier + case ('seas2') + call gsi_bundlegetpointer(gfschem_bundle,'seas2',ae_s2 ,ier); istatus=istatus+ier + case ('seas3') + call gsi_bundlegetpointer(gfschem_bundle,'seas3',ae_s3 ,ier); istatus=istatus+ier + case ('seas4') + call gsi_bundlegetpointer(gfschem_bundle,'seas4',ae_s4 ,ier); istatus=istatus+ier + end select + end do + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_nemsaero: ERROR' + write(6,*) 'Missing some of the required fields' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + + icount=0 +! Process guess fields according to type of input file. NCEP_SIGIO +! files +! are spectral coefficient files and need to be transformed to the +! grid. +! Once on the grid, fields need to be scattered from the full domain +! to +! sub-domains. + do l=1,naero + do k=1,nlevs + icount=icount+1 + ilev(icount)=k + ch_aero(icount)=trim(aeroname(l)) + vector(1)=.false. + if (mype==mype_use(icount)) then + + if (use_fv3_aero) then + ! variable names in FV3GFS-GSDChem + if ( aeroname(l)(1:4) == 'seas') then + select case ( trim(aeroname(l)) ) + case ('seas1') + call nemsio_readrecv(gfile,'seas1','mid layer',k,rwork1d1,iret=iret) + call nemsio_readrecv(gfile,'seas2','mid layer',k,rwork1d2,iret=iret) + rwork1d0=rwork1d1+rwork1d2 + case ('seas2') + call nemsio_readrecv(gfile,'seas3','mid layer',k,rwork1d0,iret=iret) + case ('seas3') + call nemsio_readrecv(gfile,'seas4','mid layer',k,rwork1d0,iret=iret) + case ('seas4') + call nemsio_readrecv(gfile,'seas5','mid layer',k,rwork1d0,iret=iret) + end select + else + ! many of the names are the same in the GSI bundle as they are + ! in the FV3GFS-GSDChem NEMSIO files + call nemsio_readrecv(gfile,trim(aeroname(l)),'mid layer',k,rwork1d0,iret=iret) + end if + else + ! variable names in NGACv2 + select case ( trim(aeroname(l)) ) + case ('sulf') + call nemsio_readrecv(gfile,'so4','mid layer',k,rwork1d0,iret=iret) + case ('bc1') + call nemsio_readrecv(gfile,'bcphobic','mid layer',k,rwork1d0,iret=iret) + case ('bc2') + call nemsio_readrecv(gfile,'bcphilic','mid layer',k,rwork1d0,iret=iret) + case ('oc1') + call nemsio_readrecv(gfile,'ocphobic','mid layer',k,rwork1d0,iret=iret) + case ('oc2') + call nemsio_readrecv(gfile,'ocphilic','mid layer',k,rwork1d0,iret=iret) + case ('dust1') + call nemsio_readrecv(gfile,'du001','mid layer',k,rwork1d0,iret=iret) + case ('dust2') + call nemsio_readrecv(gfile,'du002','mid layer',k,rwork1d0,iret=iret) + case ('dust3') + call nemsio_readrecv(gfile,'du003','mid layer',k,rwork1d0,iret=iret) + case ('dust4') + call nemsio_readrecv(gfile,'du004','mid layer',k,rwork1d0,iret=iret) + case ('dust5') + call nemsio_readrecv(gfile,'du005','mid layer',k,rwork1d0,iret=iret) + case ('seas1') + call nemsio_readrecv(gfile,'ss001','mid layer',k,rwork1d1,iret=iret) + call nemsio_readrecv(gfile,'ss002','mid layer',k,rwork1d2,iret=iret) + rwork1d0=rwork1d1+rwork1d2 + case ('seas2') + call nemsio_readrecv(gfile,'ss003','mid layer',k,rwork1d0,iret=iret) + case ('seas3') + call nemsio_readrecv(gfile,'ss004','mid layer',k,rwork1d0,iret=iret) + case ('seas4') + call nemsio_readrecv(gfile,'ss005','mid layer',k,rwork1d0,iret=iret) + end select + + ! Convert NGAC mixing ratio unit from kg/kg( 10^3 g/kg ) to ug/kg( 10^-6 g/kg ) + rwork1d0=rwork1d0*1.0e+9_r_kind + end if ! NGAC vs FV3-Chem + + + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop+7,iret) + if(diff_res)then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + end do + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call general_fill_ns(grd,grid,work) + end if + + end if + if(icount == icm)then + call aerosol_reload(grd,ae_d1,ae_d2,ae_d3,ae_d4,ae_d5, & + ae_s1,ae_s2,ae_s3,ae_s4,ae_so4,& + ae_ocpho,ae_ocphi,ae_bcpho,ae_bcphi, & + icount,ilev,ch_aero,work) + end if + end do + end do + + if(procuse)then + if(diff_res) deallocate(grid_b,grid_c,grid2) + call destroy_egrid2agrid(p_high) + deallocate(rwork1d1,clons,slons) + deallocate(rwork1d0) + deallocate(grid) + call nemsio_close(gfile,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop+9,iret) + end if + deallocate(work) + + +! Print date/time stamp + if(mype==0) then + write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,& + fhour,odate +700 format('READ_GLOBAL_AEROSOL: ges read/scatter, lonb,latb,levs=',& + 3i6,', nlon,nlat=',2i6,', hour=',f10.1,', idate=',4i5) + end if + + return + + +! ERROR detected while reading file +1000 continue + write(6,*)'GENERAL_READ_GFSATM: ***ERROR*** reading ',& + trim(filename),' mype,iret_read=',mype,iret_read,grd%nsig,nlevs + return + +! End of routine. Return + + return +end subroutine general_read_nemsaero +! +subroutine aerosol_reload(grd,ae_d1,ae_d2,ae_d3,ae_d4,ae_d5, & + ae_s1,ae_s2,ae_s3,ae_s4,ae_so4, & + ae_ocpho,ae_ocphi,ae_bcpho,ae_bcphi, & + icount,ilev,chaero,work) + +! !USES: + + use kinds, only: r_kind,i_kind + use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype + use general_sub2grid_mod, only: sub2grid_info + implicit none + +! !INPUT PARAMETERS: + + type(sub2grid_info) ,intent(in ) :: grd + integer(i_kind),intent(inout) ::icount + integer(i_kind),dimension(npe),intent(inout):: ilev!,iflag + real(r_kind),dimension(grd%itotsub),intent(in) :: work + character(*),dimension(npe) , intent(in) :: chaero + +! !OUTPUT PARAMETERS: + + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent( out) :: & + ae_d1,ae_d2,ae_d3,ae_d4,ae_d5, & + ae_s1,ae_s2,ae_s3,ae_s4,ae_so4, & + ae_ocpho,ae_ocphi,ae_bcpho,ae_bcphi + + +! !DESCRIPTION: Transfer contents of 2-d array to 3-d array +! +! !REVISION HISTORY: +! 2004-05-14 treadon +! 2004-07-15 todling, protex-compliant prologue +! +! !REMARKS: +! +! language: f90 +! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp +! +! !AUTHOR: +! treadon org: np23 date: 2004-05-14 +! +!EOP +!------------------------------------------------------------------------- + + integer(i_kind) i,j,k,ij,klev + real(r_kind),dimension(grd%lat2*grd%lon2,npe):: sub + + call mpi_alltoallv(work,grd%sendcounts_s,grd%sdispls_s,mpi_rtype,& + sub,grd%recvcounts_s,grd%rdispls_s,mpi_rtype,& + mpi_comm_world,ierror) +!$omp parallel do schedule(dynamic,1) private(k,i,j,ij,klev) + do k=1,icount + klev=ilev(k) + ij=0 + select case ( chaero(k) ) + case ('sulf') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_so4(i,j,klev)=sub(ij,k) + end do + end do + case ('bc1') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_bcpho(i,j,klev)=sub(ij,k) + end do + end do + case ('bc2') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_bcphi(i,j,klev)=sub(ij,k) + end do + end do + case ('oc1') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_ocpho(i,j,klev)=sub(ij,k) + end do + end do + case ('oc2') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_ocphi(i,j,klev)=sub(ij,k) + end do + end do + case ('dust1') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_d1(i,j,klev)=sub(ij,k) + end do + end do + case ('dust2') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_d2(i,j,klev)=sub(ij,k) + end do + end do + case ('dust3') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_d3(i,j,klev)=sub(ij,k) + end do + end do + case ('dust4') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_d4(i,j,klev)=sub(ij,k) + end do + end do + case ('dust5') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_d5(i,j,klev)=sub(ij,k) + end do + end do + case ('seas1') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_s1(i,j,klev)=sub(ij,k) + end do + end do + case ('seas2') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_s2(i,j,klev)=sub(ij,k) + end do + end do + case ('seas3') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_s3(i,j,klev)=sub(ij,k) + end do + end do + case ('seas4') + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + ae_s4(i,j,klev)=sub(ij,k) + end do + end do + end select + end do +!$omp end parallel do + icount=0 + ilev=0 + return +end subroutine aerosol_reload + diff --git a/src/general_read_nmmb.f90 b/src/gsi/general_read_nmmb.f90 similarity index 100% rename from src/general_read_nmmb.f90 rename to src/gsi/general_read_nmmb.f90 diff --git a/src/gsi/general_read_nmmb_radar.f90 b/src/gsi/general_read_nmmb_radar.f90 new file mode 100644 index 000000000..e6a01520b --- /dev/null +++ b/src/gsi/general_read_nmmb_radar.f90 @@ -0,0 +1,168 @@ +subroutine general_read_nmmb_radar(grd,filename,mype,g_z,g_ps,g_u,g_v,g_w,g_qr,g_qli,g_ql,g_qi,g_dbz,g_dw,g_tv,g_tsen,g_q,g_oz) +!$$$ subprogram documentation block +! . . . . +! subprogram: general_read_nmmb_radar is same as general_read_nmmb but for reading in more variables +! prgmmr: parrish org: np22 date: 2003-09-05 +! +! abstract: copied from read_nems_nmmb_guess, primarily for reading in NMMB NEMSIO files, for now the +! input resolution and the grid that variables are reconstructed on MUST be the same +! as the analysis grid/resolution. +! +! program history log: +! 2011-07-01 carley - Initial adaptation +! 2015-05-12 wu - changes to read in multiple guess files for FGAT/4DEnVar +! 2017-05-12 Y. Wang and X. Wang - add this option to read hydrometeors and +! vertical velocity. Ting provides codes to +! convert fraction variables to mixing +! ratios. POC: xuguang.wang@ou.edu +! +! input argument list: +! grd - structure variable containing information about grid +! (initialized by general_sub2grid_create_info, located in general_sub2grid_mod.f90) +! filename - input nemsio file name +! mype - mpi task id +! +! output argument list: +! g_* - guess fields +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + use kinds, only: r_kind,i_kind,r_single + use gridmod, only: pdtop_ll,pt_ll,nmmb_verttype,use_gfs_ozone,regional_ozone + use constants, only: zero,one_tenth,one,fv,r0_01, ten + use gsi_nemsio_mod, only: gsi_nemsio_open,gsi_nemsio_close,gsi_nemsio_read,gsi_nemsio_read_fractionnew + use general_sub2grid_mod, only: sub2grid_info + use wrf_vars_mod, only :w_exist,dbz_exist + use obsmod,only:if_model_dbz + use gridmod, only: pt_ll,aeta2_ll,aeta1_ll,pdtop_ll + use constants, only: rd, r1000 + + implicit none + +! Declare passed variables + type(sub2grid_info) ,intent(in ) :: grd + character(70) ,intent(in ) :: filename + integer(i_kind) ,intent(in ) :: mype + real(r_kind),dimension(grd%lat2,grd%lon2) ,intent( out) :: g_z,g_ps + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent( out) :: g_u,g_v,& + g_tv,g_tsen,g_q,g_oz,g_w,g_qr,g_qli,g_ql,g_dbz,g_dw, g_qi + +! Declare local variables + integer(i_kind) i,j,k,kr,nsig,lat2,lon2,mype_input,ierr + real(r_kind) pd,psfc_this,pd_to_ps,dumtv + logical good_o3mr + real(r_kind),dimension(grd%lat2,grd%lon2) :: g_pd + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig) :: dbz, & + Ze, Zer, Zeli,g_prsl, g_rho + real(r_kind) :: Cr=3.6308e9_r_kind ! Rain constant coef. + real(r_kind) :: Cli=3.268e9_r_kind ! Precip. ice constant coef. + +! get conversion factor for pd to psfc + + if(nmmb_verttype=='OLD') then + pd_to_ps=pdtop_ll+pt_ll + else + pd_to_ps=pt_ll + end if + + + lat2=grd%lat2 + lon2=grd%lon2 + nsig=grd%nsig + + mype_input=0 + + call gsi_nemsio_open(filename,'READ', & + 'GENERAL_READ_NMMB: problem with ens input file!',mype,mype_input,ierr) + +! ! pd + + call gsi_nemsio_read('dpres','hybrid sig lev','H',1,g_pd(:,:),mype,mype_input) + do i=1,lon2 + do j=1,lat2 +! convert wrf nmm pd variable to psfc in mb, and then to log(psfc) in cb + pd=r0_01*g_pd(j,i) + psfc_this=pd+pd_to_ps + g_ps(j,i)=one_tenth*psfc_this + end do + end do + +! ! fis + + call gsi_nemsio_read('hgt','sfc','H',1,g_z(:,:),mype,mype_input) + +! ! u,v,q,tsen,tv,cwmr,qr,qli + do kr=1,nsig + k=nsig+1-kr + call gsi_nemsio_read('ugrd','mid layer','V',kr,g_u(:,:,k), mype,mype_input) + call gsi_nemsio_read('vgrd','mid layer','V',kr,g_v(:,:,k), mype,mype_input) + if(w_exist)then + call gsi_nemsio_read('w_tot','mid layer','H',kr,g_w(:,:,k), mype,mype_input) + call gsi_nemsio_read('dwdt','mid layer','H',kr,g_dw(:,:,k), mype,mype_input) + end if + call gsi_nemsio_read('spfh','mid layer','H',kr,g_q(:,:,k), mype,mype_input) + call gsi_nemsio_read('tmp' ,'mid layer','H',kr,g_tsen(:,:,k),mype,mype_input) + + if( if_model_dbz )& + call gsi_nemsio_read('refl_10cm' ,'mid layer','H',kr,dbz(:,:,k),mype,mype_input) + do i=1,lon2 + do j=1,lat2 + g_tv(j,i,k) = g_tsen(j,i,k) * (one+fv*g_q(j,i,k)) !To be consistent with read_nems_nmmb_guess + ! compute tv prior to enforcing the limit on q. + g_q(j,i,k)=max(g_q(j,i,k),1.e-10_r_kind) !step comes from compute_qvar3d.f90 + dumtv=g_tsen(j,i,k) * (one+fv*g_q(j,i,k)) + g_tsen(j,i,k)=dumtv/(one+fv*max(zero,g_q(j,i,k))) !Recompute tsen based on the limit enforced on q. + + if( dbz_exist .and. ( .not. if_model_dbz ) ) then + g_prsl(j,i,k)=one_tenth* & + (aeta1_ll(k)*pdtop_ll + & + aeta2_ll(k)*(ten*g_ps(j,i)-pdtop_ll-pt_ll) + & + pt_ll) + + g_rho(j,i,k)=(g_prsl(j,i,k)/(g_tv(j,i,k)*rd))*r1000 + end if + + + if( dbz_exist )then + if ( if_model_dbz )then + g_dbz(j,i,k) = max( dbz(j,i,k), 0.0_r_kind ) + end if + end if + end do + end do + call gsi_nemsio_read_fractionnew('f_rain','f_ice','clwmr','f_rimef','mid layer',kr, & + g_qi(:,:,k),g_qli(:,:,k),g_qr(:,:,k),g_ql(:,:,k), mype,mype_input) + + if ( dbz_exist .and. (.not. if_model_dbz) )then + Zer(:,:,k) = Cr * (g_rho(:,:,k) * g_qr(:,:,k))**(1.75_r_kind) + Zeli(:,:,k) = Cli * (g_rho(:,:,k) * g_qli(:,:,k))**(2.0_r_kind) + Ze(:,:,k)=Zer(:,:,k)+Zeli(:,:,k) + + g_dbz(:,:,k) = 0.0_r_kind + + where ( Ze(:,:,k) > 0.0_r_kind ) + g_dbz(:,:,k) = ten * log10(Ze(:,:,k)) + end where + where( g_dbz(:,:,k) < 0.0_r_kind ) + g_dbz(:,:,k) = 0.0_r_kind + endwhere + end if + + if(regional_ozone) then + if(use_gfs_ozone) then + g_oz(:,:,k)=zero + else + good_o3mr=.false. + call gsi_nemsio_read('o3mr' ,'mid layer','H',kr,g_oz(:,:,k),mype,mype_input,good_o3mr) + if(.not.good_o3mr) write(6,*)' IN GENERAL_READ_NMMB, O3MR FIELD NOT YET AVAILABLE' + end if + end if + end do + + call gsi_nemsio_close(filename,'GENERAL_READ_NMMB',mype,mype_input) + return +end subroutine general_read_nmmb_radar diff --git a/src/general_specmod.f90 b/src/gsi/general_specmod.f90 similarity index 100% rename from src/general_specmod.f90 rename to src/gsi/general_specmod.f90 diff --git a/src/general_spectral_transforms.f90 b/src/gsi/general_spectral_transforms.f90 similarity index 100% rename from src/general_spectral_transforms.f90 rename to src/gsi/general_spectral_transforms.f90 diff --git a/src/general_sub2grid_mod.f90 b/src/gsi/general_sub2grid_mod.f90 similarity index 98% rename from src/general_sub2grid_mod.f90 rename to src/gsi/general_sub2grid_mod.f90 index b606427f7..f0548643b 100644 --- a/src/general_sub2grid_mod.f90 +++ b/src/gsi/general_sub2grid_mod.f90 @@ -143,30 +143,30 @@ module general_sub2grid_mod type sub2grid_info - integer(i_kind) inner_vars ! number of inner-most loop variables - integer(i_kind) lat1 ! no. of lats on subdomain (no buffer) - integer(i_kind) lon1 ! no. of lons on subdomain (no buffer) - integer(i_kind) lat2 ! no. of lats on subdomain (buffer) - integer(i_kind) lon2 ! no. of lons on subdomain (buffer) - integer(i_kind) latlon11 ! no. of points on subdomain (including buffer) - integer(i_kind) latlon1n ! latlon11*nsig - integer(i_kind) nlat ! no. of latitudes - integer(i_kind) nlon ! no. of longitudes - integer(i_kind) nsig ! no. of vertical levels - integer(i_kind) num_fields ! total number of fields/levels - integer(i_kind) iglobal ! number of horizontal points on global grid - integer(i_kind) itotsub ! number of horizontal points of all subdomains combined - integer(i_kind) kbegin_loc ! starting slab index for local processor - integer(i_kind) kend_loc ! ending slab index for local processor - integer(i_kind) kend_alloc ! kend_loc can = kbegin_loc - 1, for a processor not involved. - ! this causes problems with array allocation: - ! to correct this, use kend_alloc=max(kend_loc,kbegin_loc) - integer(i_kind) nlevs_loc ! number of active local levels ( = kend_loc-kbegin_loc+1) - integer(i_kind) nlevs_alloc ! number of allocatec local levels ( = kend_alloc-kbegin_loc+1) - integer(i_kind) npe ! total number of processors - integer(i_kind) mype ! local processor - integer(i_kind) nskip ! # of processors skipped between full horizontal fields in grid mode. - logical periodic ! logical flag for periodic e/w domains + integer(i_kind):: inner_vars=0 ! number of inner-most loop variables + integer(i_kind):: lat1=0 ! no. of lats on subdomain (no buffer) + integer(i_kind):: lon1=0 ! no. of lons on subdomain (no buffer) + integer(i_kind):: lat2=0 ! no. of lats on subdomain (buffer) + integer(i_kind):: lon2=0 ! no. of lons on subdomain (buffer) + integer(i_kind):: latlon11=0 ! no. of points on subdomain (including buffer) + integer(i_kind):: latlon1n=0 ! latlon11*nsig + integer(i_kind):: nlat=0 ! no. of latitudes + integer(i_kind):: nlon=0 ! no. of longitudes + integer(i_kind):: nsig=0 ! no. of vertical levels + integer(i_kind):: num_fields=0 ! total number of fields/levels + integer(i_kind):: iglobal=0 ! number of horizontal points on global grid + integer(i_kind):: itotsub=0 ! number of horizontal points of all subdomains combined + integer(i_kind):: kbegin_loc=0 ! starting slab index for local processor + integer(i_kind):: kend_loc=0 ! ending slab index for local processor + integer(i_kind):: kend_alloc=0 ! kend_loc can = kbegin_loc - 1, for a processor not involved. + ! this causes problems with array allocation: + ! to correct this, use kend_alloc=max(kend_loc,kbegin_loc) + integer(i_kind):: nlevs_loc=0 ! number of active local levels ( = kend_loc-kbegin_loc+1) + integer(i_kind):: nlevs_alloc=0 ! number of allocatec local levels ( = kend_alloc-kbegin_loc+1) + integer(i_kind):: npe=0 ! total number of processors + integer(i_kind):: mype=-1 ! local processor + integer(i_kind):: nskip=0 ! # of processors skipped between full horizontal fields in grid mode. + logical:: periodic=.false. ! logical flag for periodic e/w domains logical,pointer :: periodic_s(:) => null() ! logical flag for periodic e/w subdomain (all tasks) logical,pointer :: vector(:) => null() ! logical flag, true for vector variables integer(i_kind),pointer :: ilat1(:) => null() ! no. of lats for each subdomain (no buffer) diff --git a/src/general_tll2xy_mod.f90 b/src/gsi/general_tll2xy_mod.f90 similarity index 100% rename from src/general_tll2xy_mod.f90 rename to src/gsi/general_tll2xy_mod.f90 diff --git a/src/general_transform.f90 b/src/gsi/general_transform.f90 similarity index 100% rename from src/general_transform.f90 rename to src/gsi/general_transform.f90 diff --git a/src/general_write_gfsatm.f90 b/src/gsi/general_write_gfsatm.f90 similarity index 97% rename from src/general_write_gfsatm.f90 rename to src/gsi/general_write_gfsatm.f90 index 5be2af226..e3202db5e 100644 --- a/src/general_write_gfsatm.f90 +++ b/src/gsi/general_write_gfsatm.f90 @@ -125,7 +125,11 @@ subroutine general_write_gfsatm(grd,sp_a,sp_b,filename,mype_out,& ! All tasks should also open output file for random write call sigio_rwopen(lunanl,filename,iret_write) - if ( iret_write /= 0 ) goto 1000 + if ( iret_write /= 0 ) then + write(6,*)'GENERAL_WRITE_GFSATM: ***ERROR*** writing ',& + trim(filename),' mype,iret_write=',mype,iret_write + return + end if endif ! Load date and write header @@ -326,15 +330,11 @@ subroutine general_write_gfsatm(grd,sp_a,sp_b,filename,mype_out,& call sigio_rclose(lunges,iret) call sigio_rclose(lunanl,iret) iret_write=iret_write+iret - if ( iret_write /= 0 ) goto 1000 - endif - return - - - ! ERROR detected while reading file -1000 continue - write(6,*)'GENERAL_WRITE_GFSATM: ***ERROR*** writing ',& + if ( iret_write /= 0 ) then + write(6,*)'GENERAL_WRITE_GFSATM: ***ERROR*** writing ',& trim(filename),' mype,iret_write=',mype,iret_write + end if + endif return end subroutine general_write_gfsatm diff --git a/src/genex_mod.f90 b/src/gsi/genex_mod.f90 similarity index 100% rename from src/genex_mod.f90 rename to src/gsi/genex_mod.f90 diff --git a/src/gengrid_vars.f90 b/src/gsi/gengrid_vars.f90 similarity index 89% rename from src/gengrid_vars.f90 rename to src/gsi/gengrid_vars.f90 index 4e81afdb9..a2d352c0b 100644 --- a/src/gengrid_vars.f90 +++ b/src/gsi/gengrid_vars.f90 @@ -15,6 +15,7 @@ subroutine gengrid_vars ! 2010-01-12 treadon - add hires_b section ! 2010-03-10 lueken - remove hires_b section ! 2010-03-31 treadon - replace specmod components with sp_a structure +! 2019-03-05 martin - add wgtfactlats for factqmin/factqmax scaling ! ! input argument list: ! @@ -29,7 +30,7 @@ subroutine gengrid_vars !$$$ use kinds, only: r_kind,i_kind use gridmod, only: sinlon,coslon,region_lat,rbs2,& - rlons,rlats,corlats,nlon,nlat,regional,wgtlats,sp_a + rlons,rlats,corlats,nlon,nlat,regional,wgtlats,sp_a,wgtfactlats use constants, only: zero,half,one,four,pi,two,omega implicit none @@ -50,12 +51,13 @@ subroutine gengrid_vars i1=nlon/4 do i=1,nlat wgtlats(i)=zero + wgtfactlats(i) = one rbs2(i)=one/cos(region_lat(i,i1))**2 end do else -! This is global run, so get global lons, lats, wgtlats +! This is global run, so get global lons, lats, wgtlats, wgtfactlats ! Set local constants anlon=float(nlon) @@ -92,6 +94,7 @@ subroutine gengrid_vars do i=1,nlat corlats(i)=two*omega*sin(rlats(i)) + wgtfactlats(i)=wgtlats(i) end do end if !end if global diff --git a/src/genqsat.f90 b/src/gsi/genqsat.f90 similarity index 95% rename from src/genqsat.f90 rename to src/gsi/genqsat.f90 index ff4c97ec2..37927f184 100644 --- a/src/genqsat.f90 +++ b/src/gsi/genqsat.f90 @@ -26,6 +26,7 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative) ! 2010-12-17 pagowski - add cmaq ! 2011-08-15 gu/todling - add pseudo-q2 options ! 2014-12-03 derber - add additional threading +! 2018-02-15 wu - add code for fv3_regional option ! ! input argument list: ! tsen - input sensibile temperature field (lat2,lon2,nsig) @@ -56,6 +57,7 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative) use derivsmod, only: qgues,dqdt,dqdrh,dqdp use jfunc, only: pseudo_q2 use gridmod, only: wrf_nmm_regional,wrf_mass_regional,nems_nmmb_regional,aeta2_ll,regional,cmaq_regional + use gridmod, only: fv3_regional use guess_grids, only: tropprs,ges_prslavg,ges_psfcavg implicit none @@ -88,7 +90,8 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative) endif end do end if - if (wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) then + if (wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional .or. & + fv3_regional) then kpres = nsig do k=1,nsig if (aeta2_ll(k)==zero) then @@ -118,6 +121,7 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative) end do do i=1,lat2 tdry = mint(i) + if( abs(tdry) < 1.0e-8_r_kind ) tdry = 1.0e-8_r_kind tr = ttp/tdry if (tdry >= ttp .or. .not. ice) then estmax(i) = psat * (tr**xa) * exp(xb*(one-tr)) @@ -132,8 +136,8 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative) do k = 1,nsig do i = 1,lat2 - tdry = tsen(i,j,k) + if( abs(tdry) < 1.0e-8_r_kind ) tdry = 1.0e-8_r_kind tr = ttp/tdry if (tdry >= ttp .or. .not. ice) then es = psat * (tr**xa) * exp(xb*(one-tr)) @@ -176,7 +180,7 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative) idtupdate=.false. end if if(wrf_nmm_regional .or. nems_nmmb_regional.or.& - cmaq_regional) then + cmaq_regional .or. fv3_regional) then ! Decouple T and p at different levels for nmm core if(k >= kpres)idpupdate = .false. if(k >= k150 )idtupdate = .false. diff --git a/src/gsi/genstats_gps.f90 b/src/gsi/genstats_gps.f90 new file mode 100644 index 000000000..13e2b4be4 --- /dev/null +++ b/src/gsi/genstats_gps.f90 @@ -0,0 +1,816 @@ +module m_gpsStats +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_gpsStats +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2015-08-28 +! +! abstract: a modular wrapper of (gsp_allhead, gps_alltail), and genstats_gps() +! +! program history log: +! 2007-06-22 cucurull - modify gps_all_ob_type structure +! 2015-08-28 j guo - created this module on top of genstats_gps(); +! . completed with type/data components from obsmod; +! . changed code where this module needs to be used; +! . added this document block; +! . for earlier history log, see the history log section +! inside ::genstats_gps() below. +! 2016-05-18 j guo - Made the type private, since this is only a single +! instance module object, with its components defined +! as module variables (gps_allhead, and gsp_alltail). +! . Removed old interface names, which are no longer used +! in this version of GSI. +! . Edited the in-file documentation. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use m_gpsNode, only: gps_ob_type => gpsNode + use kinds , only: r_kind,i_kind + implicit none + private ! except + + ! Data Structure: + !public:: gps_all_ob_type ! currently not required to be public + + type gps_all_ob_type + type(gps_all_ob_type),pointer :: llpoint => NULL() + type(gps_ob_type),pointer :: mmpoint => NULL() + real(r_kind) :: ratio_err + real(r_kind) :: obserr + real(r_kind) :: dataerr + real(r_kind) :: pg + real(r_kind) :: b + real(r_kind) :: loc + real(r_kind) :: type + + real(r_kind),dimension(:),pointer :: rdiag => NULL() + integer(i_kind) :: kprof + logical :: luse ! flag indicating if ob is used in pen. + + logical :: muse ! flag indicating if ob is used in pen. + character(8) :: cdiag + + integer(i_kind) :: idv,iob ! device id and obs index for sorting + real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + end type gps_all_ob_type + + type gps_all_ob_head + integer(i_kind):: n_alloc=0 + type(gps_all_ob_type),pointer :: head => NULL() + end type gps_all_ob_head + + ! Data objects: + + public:: gps_allhead + public:: gps_alltail + + ! interfaces: + + public:: gpsStats_create + public:: gpsStats_destroy + + interface gpsStats_create ; module procedure create_; end interface + interface gpsStats_destroy; module procedure destroy_genstats_gps; end interface + + public:: gpsStats_genStats + + interface gpsStats_genStats; module procedure genstats_gps; end interface + + ! Synopsis: + ! - []_create: allocated in gsimod::gsimain_initialize(). It was + ! done through ::create_obsmod_vars(), and now next to it. + ! + ! - externally built, node-by-node, in setupbend() or setupref(). + ! This is the reason why the ADT can not be defined as "private". + ! + ! - []_genStats: used to update m_rhs::[ab]work, in setuprhsall(), + ! through ::genstats_gps(); + ! + ! - []_destroy: deallocated within genstats_gps(), when it it + ! finished. + ! + ! The use of []_create()/[]_destroy() pair is obviously not symmetric. It + ! would cleaner if they are be moved to the level of setuprhsall(), + ! where m_rhs::[ab]work are computed. e.g., + ! + ! if(init_pass) call gpsStats_create() + ! ... + ! if(last_pass) then + ! call gpsStats_genstats(bwork,awork,...) + ! call gpsStats_destroy() + ! endif + ! + ! As it is now, the second half has been done, but the first half + ! stayed at where it has been, for later. + +! Most implementations of this module, are snap-shots of gps_all_ob_type, from +! obsmod, its original home. These implementations include, the type +! definition (gps_all_ob_type and gsp_app_ob_head), instantiation of the type +! (gps_allhead and gsp_alltail), and interfaces for the operations of this +! object ([]_create, []_genstats, []_destroy). The part of implementation for +! the node-growing, is remained in setupbend() and setupref() as is. + + type(gps_all_ob_head),dimension(:),pointer :: gps_allhead => null() + type(gps_all_ob_head),dimension(:),pointer :: gps_alltail => null() + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='genstats_gps' +contains + + subroutine create_() + use gsi_4dvar, only: nobs_bins + implicit none + + ALLOCATE(gps_allhead(nobs_bins)) + ALLOCATE(gps_alltail(nobs_bins)) + end subroutine create_ + + subroutine destroy_genstats_gps() +!$$$ subprogram documentation block +! . . . . +! subprogram: destroy_genstats_gps +! prgmmr: treadon org: np20 date: 2005-12-21 +! +! abstract: deallocate arrays holding gps information +! +! program history log: +! 2005-12-21 treadon +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ end documentation block + use gsi_4dvar, only: nobs_bins + use kinds, only: i_kind + implicit none + + integer(i_kind):: istatus,ii + + do ii=1,nobs_bins + gps_alltail(ii)%head => gps_allhead(ii)%head + do while (associated(gps_alltail(ii)%head)) + gps_allhead(ii)%head => gps_alltail(ii)%head%llpoint + deallocate(gps_alltail(ii)%head,stat=istatus) + if (istatus/=0) write(6,*)'DESTROY_GENSTATS_GPS: deallocate error for gps_all, istatus=',istatus + gps_alltail(ii)%head => gps_allhead(ii)%head + end do + end do + + return + end subroutine destroy_genstats_gps + +subroutine genstats_gps(bwork,awork,toss_gps_sub,conv_diagsave,mype) +!$$$ subprogram documentation block +! . . . . +! subprogram: genstats_gps generate statistics for gps observations +! prgmmr: treadon org: np20 date: 2005-12-21 +! +! abstract: For gps observations, this routine +! a) collects statistics for runtime diagnostic output +! f) adjusts observation error ratio based on superobs factor +! +! program history log: +! 2005-12-21 treadon +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! 2006-09-20 cucurull - replace superobs factor for obs in a top (non-full) layer +! 2007-03-01 treadon - add array toss_gps +! 2007-03-19 tremolet - binning of observations +! 2007-06-21 cucurull - add conv_diagsave and mype in argument list; +! modify qc and output for diagnostic file based on toss_gps +! print out diagnostic files if requested +! add wgtlim and huge_single in constants module +! 2008-02-27 cucurull - modify diagnostics output file +! 2008-04-14 treadon - compute super_gps within this routine +! 2008-06-04 safford - rm unused vars and uses +! 2008-09-05 lueken - merged ed's changes into q1fy09 code +! 2008-25-08 todling - adapt obs-binning change to GSI-May2008 +! 2009-02-05 cucurull - modify latitude range four statistics output +! 2009-10-22 shen - add high_gps +! 2010-04-09 cucurull - fix several bugs for high_gps (diag information, counters, +! - consider failure of gross check, obs-binning structures, QC for CL profiles) +! - reorganize high_gps structure +! - modify dimension of diagnostic structure +! 2010-07-23 treadon - add ratio_error=zero to reqional QC block, replace (izero,ione) with (0,1), +! remove _i_kind suffix from integer constants, clean up use statements +! 2010-08-17 treadon - convert high_gps from m to km one time only; break out regional +! QC as separate if/then block (global will bypass); replace +! ratio_errors_reg with logical toss +! 2010-10-25 cucurull - add quality control options for C/NOFS satellite +! 2011-01-18 cucurull - increase the size of nreal and mreal by one element to +! add gps_dtype information +! 2012-10-16 cucurull - increase the size of nreal and mreal by one element to +! add qrefges information, replace qcfail=5 by 4, add regional QC for MetOpB +! add dtype, dobs to distinguish use of toss_gps between ref/bending, add SR QC for obs +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-12-13 derber - minor optimization modifications +! 2015-07-28 cucurull - add QC for regional bending angle assimilation +! 2015-08-28 guo - wrapped as a module (m_gpsStats) +! moved the call to obsmod::destroy_genstats_gps() to +! where this routine was used (setuprhsall()), with its +! new module interface name. gpsStats_destroy(). +! 2016-11-29 shlyaeva - increase the size of nreal for saving linearized Hx for EnKF +! 2016-12-09 mccarty - add ncdiag writing support +! +! input argument list: +! toss_gps_sub - array of qc'd profile heights +! conv_diagsave - logical to save innovation diagnostics +! mype - mpi task id +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obsdiagNode_set + use obsmod, only: nprof_gps,lobsdiag_forenkf + use obsmod, only: lobsdiagsave,luse_obsdiag + use obsmod, only: binary_diag,netcdf_diag,dirname,ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gridmod, only: nsig,regional + use constants, only: tiny_r_kind,half,wgtlim,one,two,zero,five,four + use qcmod, only: npres_print,ptop,pbot + use mpimod, only: ierror,mpi_comm_world,mpi_rtype,mpi_sum,mpi_max + use jfunc, only: jiter,miter,jiterstart + use gsi_4dvar, only: nobs_bins + use convinfo, only: nconvtype + use state_vectors, only: nsdim + implicit none + +! Declare passed variables + logical ,intent(in):: conv_diagsave + integer(i_kind) ,intent(in) :: mype + real(r_kind),dimension(100+7*nsig) ,intent(inout):: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout):: bwork + real(r_kind),dimension(max(1,nprof_gps)) ,intent(in):: toss_gps_sub + +! Declare local parameters + real(r_kind),parameter:: ten = 10.0_r_kind + real(r_kind),parameter:: six = 6.0_r_kind + real(r_kind),parameter:: r1em3 = 1.0e-3_r_kind + real(r_kind),parameter:: r20 = 20.0_r_kind + real(r_kind),parameter:: scale = 100.0_r_kind + +! Declare local variables + logical:: luse,muse,toss,save_jacobian + integer(i_kind):: k,jsig,icnt,khgt,kprof,ikx,nn,j,nchar,nreal,mreal,ii,ioff + real(r_kind):: pressure,arg,wgross,wgt,term,cg_gps,valqc,elev,satid,dtype,dobs + real(r_kind):: ress,val,ratio_errors,val2 + real(r_kind):: exp_arg,data_ikx,data_rinc,cg_term,rat_err2,elat + real(r_kind):: wnotgross,data_ipg,data_ier,data_ib,factor,super_gps_up,rhgt + real(r_kind),dimension(nsig,max(1,nprof_gps)):: super_gps_sub,super_gps + real(r_kind),dimension(max(1,nprof_gps)):: toss_gps + real(r_kind),dimension(max(1,nprof_gps)):: high_gps,high_gps_sub + real(r_kind),dimension(max(1,nprof_gps)):: dobs_height,dobs_height_sub + + real(r_single),allocatable,dimension(:,:)::sdiag + character(8),allocatable,dimension(:):: cdiag + + real(r_single), dimension(nsdim) :: dhx_dx_array + + type(obs_diag), pointer :: obsptr => NULL() + + integer(i_kind) :: nnz, nind + type(gps_ob_type), pointer:: gpsptr + type(gps_all_ob_type), pointer:: gps_allptr + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +!******************************************************************************* +! Check to see if there are any profiles to process. If none, return. + if (nprof_gps==0) then + if (mype==0) write(6,*)'GENSTATS_GPS: no profiles to process (nprof_gfs=',nprof_gps,'), EXIT routine' + return + endif + +! Reduce sub-domain specific QC'd profile height cutoff values to +! maximum global value for each profile + toss_gps=zero + call mpi_allreduce(toss_gps_sub,toss_gps,nprof_gps,mpi_rtype,mpi_max,& + mpi_comm_world,ierror) + +! If netcdf diag, initialize it + if (conv_diagsave.and.netcdf_diag) call init_netcdf_diag_ + +! Get height of maximum bending angle + dobs_height_sub = zero + DO ii=1,nobs_bins + gps_allptr => gps_allhead(ii)%head + do while (associated(gps_allptr)) + +! Load local work variables + kprof = gps_allptr%kprof + dtype = gps_allptr%rdiag(20) + dobs = gps_allptr%rdiag(17) + + if (dtype == one .and. toss_gps(kprof) > zero .and. dobs == toss_gps(kprof)) then + dobs_height_sub(kprof) = gps_allptr%rdiag(7) + endif + + gps_allptr => gps_allptr%llpoint + +! End loop over observations + end do + +! End of loop over time bins + END DO + +! Reduce sub-domain specific QC'd profile height to maximum global value for each profile + dobs_height=zero + call mpi_allreduce(dobs_height_sub,dobs_height,nprof_gps,mpi_rtype,mpi_max,& + mpi_comm_world,ierror) + + +! Compute superobs factor on sub-domains using global QC'd profile height + super_gps_sub=zero + high_gps_sub = zero + DO ii=1,nobs_bins + gps_allptr => gps_allhead(ii)%head + do while (associated(gps_allptr)) + +! Load local work variables + ratio_errors = gps_allptr%ratio_err + data_ier = gps_allptr%obserr + luse = gps_allptr%luse + kprof = gps_allptr%kprof + dtype = gps_allptr%rdiag(20) + +! Accumulate superobs factors and get highest good gps obs within a profile + + if (dtype == zero) then ! refractivity + rhgt = gps_allptr%loc + if (rhgt >toss_gps(kprof)) then + if(ratio_errors*data_ier>tiny_r_kind) then + elev = gps_allptr%rdiag(7) + high_gps_sub(kprof)=max(high_gps_sub(kprof),elev) + if(luse) then + khgt = gps_allptr%loc + k=min(max(1,khgt),nsig) + super_gps_sub(k,kprof)=super_gps_sub(k,kprof)+one + endif + endif + endif + + else ! bending angle + dobs = gps_allptr%rdiag(17) + if(toss_gps(kprof) == zero .or. (toss_gps(kprof) > zero .and. dobs < toss_gps(kprof))) then ! will not fail SR from obs qc + elev = gps_allptr%rdiag(7) + if(elev > dobs_height(kprof)) then + if(ratio_errors*data_ier>tiny_r_kind) then + high_gps_sub(kprof)=max(high_gps_sub(kprof),elev) + if(luse) then + khgt = gps_allptr%loc + k=min(max(1,khgt),nsig) + super_gps_sub(k,kprof)=super_gps_sub(k,kprof)+one + endif + endif + endif + endif + endif + + + gps_allptr => gps_allptr%llpoint + +! End loop over observations + end do + +! End of loop over time bins + END DO + + super_gps = zero + high_gps = zero +! Reduce sub-domain specifc superobs factors to global values for each profile + call mpi_allreduce(super_gps_sub,super_gps,nsig*nprof_gps,mpi_rtype,mpi_sum,& + mpi_comm_world,ierror) + +! Reduce sub-domain specific high_gps values to global values for each profile + call mpi_allreduce(high_gps_sub,high_gps,nprof_gps,mpi_rtype,mpi_max,& + mpi_comm_world,ierror) + +! Convert high_gps from meters to kilometers + high_gps = r1em3*high_gps + + +! If generating diagnostic output, need to determine dimension of output arrays. + nreal=0 + ioff =nreal + if (conv_diagsave) then + icnt = zero + DO ii=1,nobs_bins + gps_allptr => gps_allhead(ii)%head + do while (associated(gps_allptr)) + luse = gps_allptr%luse + if(luse)icnt=icnt+1 + gps_allptr => gps_allptr%llpoint + end do + END DO + if(icnt > 0)then + nreal =22 + ioff =nreal + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (save_jacobian) then + nnz = 3*nsig + nind = 3 + nreal = nreal + 2*nind + nnz + 2 + endif + allocate(cdiag(icnt),sdiag(nreal,icnt)) + end if + endif + + + +! Loop over data to apply final qc, superobs factors, accumulate +! statistics and (optionally) load diagnostic output arrays + icnt=0 + DO ii=1,nobs_bins + gps_allptr => gps_allhead(ii)%head + do while (associated(gps_allptr)) + +! Load local work variables + ratio_errors = gps_allptr%ratio_err + data_ier = gps_allptr%obserr + luse = gps_allptr%luse + muse = gps_allptr%muse + khgt = gps_allptr%loc + kprof = gps_allptr%kprof + dtype = gps_allptr%rdiag(20) + gpsptr => gps_allptr%mmpoint + if(muse .and. associated(gpsptr) .and. luse_obsdiag)then + obsptr => gpsptr%diags + endif + +! Determine model level to which observation is mapped to + k=min(max(1,khgt),nsig) + +! Normalize ratio_errors by superobs factor. Update ratio_error +! term used in minimization + super_gps_up=zero + + if (super_gps(k,kprof)>tiny_r_kind) then + do j=min(k+1,nsig),nsig + super_gps_up = max(super_gps_up,super_gps(j,kprof)) + enddo + + if (super_gps_up >tiny_r_kind) then + factor = one / sqrt(super_gps(k,kprof)) + else + factor = one / sqrt(max(super_gps(k-1,kprof),super_gps(k,kprof))) + endif + ratio_errors = ratio_errors * factor + if(conv_diagsave .and. luse) then + if(gps_allptr%rdiag(16) >tiny_r_kind) gps_allptr%rdiag(16)=ratio_errors*data_ier + endif + +! Adjust error ratio for observations used in inner loop + if (associated(gpsptr)) then + gpsptr%raterr2 = ratio_errors **2 + if(associated(obsptr) .and. luse_obsdiag)then + !-- obsptr%wgtjo=(ratio_errors*data_ier)**2 + call obsdiagNode_set(obsptr,wgtjo=(ratio_errors*data_ier)**2) + end if + endif + endif + + +! For given profile, check if observation level is below level at +! which profile data is tossed. If so, set error parameter to +! zero (effectively tossing the obs). + + rhgt = gps_allptr%loc + mreal = 22 + if(dtype == zero) then !refractivity + if (rhgt<=toss_gps(kprof)) then + if(ratio_errors*data_ier > tiny_r_kind) then ! obs was good + if (luse) then + if(conv_diagsave) then + gps_allptr%rdiag(10) = four + gps_allptr%rdiag(12) = -one + gps_allptr%rdiag(16) = zero + if(lobsdiagsave) gps_allptr%rdiag(mreal+jiter) = -one + endif + elat = gps_allptr%rdiag(3) + if(elat > r20) then + awork(22) = awork(22)+one + else if(elat< -r20)then + awork(23) = awork(23)+one + else + awork(24) = awork(24)+one + end if + endif + endif + ratio_errors = zero + if (associated(gpsptr)) then + gpsptr%raterr2 = ratio_errors **2 + if(associated(obsptr) .and. luse_obsdiag)then + !-- obsptr%wgtjo=zero + !-- obsptr%muse(jiter)=.false. + call obsdiagNode_set(obsptr,wgtjo=zero,jiter=jiter,muse=.false.) + end if + endif + endif + else + elev = gps_allptr%rdiag(7) + dobs = gps_allptr%rdiag(17) + if (toss_gps(kprof) > zero .and. (dobs == toss_gps(kprof) .or. elev < dobs_height(kprof))) then ! SR from obs + if(ratio_errors*data_ier > tiny_r_kind) then ! obs was good + if (luse) then + if(conv_diagsave) then + gps_allptr%rdiag(10) = four + gps_allptr%rdiag(12) = -one + gps_allptr%rdiag(16) = zero + if(lobsdiagsave) gps_allptr%rdiag(mreal+jiter) = -one + endif + elat = gps_allptr%rdiag(3) + if(elat > r20) then + awork(22) = awork(22)+one + else if(elat< -r20)then + awork(23) = awork(23)+one + else + awork(24) = awork(24)+one + end if + endif + endif + ratio_errors = zero + if (associated(gpsptr)) then + gpsptr%raterr2 = ratio_errors **2 + if(associated(obsptr) .and. luse_obsdiag)then + !-- obsptr%wgtjo=zero + !-- obsptr%muse(jiter)=.false. + call obsdiagNode_set(obsptr,wgtjo=zero,jiter=jiter,muse=.false.) + end if + endif + endif + endif + + + +! Regional QC. Remove obs if highest good obs in +! profile is below platform specific threshold height. + if(regional) then + toss=.false. + if(ratio_errors*data_ier > tiny_r_kind) then + if(dtype==zero) then !refractivity + satid = gps_allptr%rdiag(1) + if((satid==41).or.(satid==722).or.(satid==723).or.(satid==4).or.(satid==786).or.(satid==3)) then + if ((high_gps(kprof)) < ten) toss=.true. + else ! OL + if ((high_gps(kprof)) < five) toss=.true. + endif + else !bending angle + if ((high_gps(kprof)) <= six) toss=.true. + endif + endif + if (toss) then + if (luse) then + if(conv_diagsave) then + gps_allptr%rdiag(10) = four + gps_allptr%rdiag(12) = -one + gps_allptr%rdiag(16) = zero + if(lobsdiagsave) gps_allptr%rdiag(mreal+jiter) = -one + endif + elat = gps_allptr%rdiag(3) + if(elat > r20) then + awork(22) = awork(22)+one + else if(elat< -r20)then + awork(23) = awork(23)+one + else + awork(24) = awork(24)+one + end if + end if + ratio_errors = zero + if (associated(gpsptr)) then + gpsptr%raterr2 = ratio_errors **2 + if(associated(obsptr) .and. luse_obsdiag)then + !-- obsptr%wgtjo=zero + !-- obsptr%muse(jiter)=.false. + call obsdiagNode_set(obsptr,wgtjo=zero,jiter=jiter,muse=.false.) + end if + endif + endif + endif ! regional + +! Compute penalty terms + if (ratio_errors*data_ier <= tiny_r_kind) muse = .false. + if(luse)then + val = gps_allptr%dataerr + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + data_ipg = gps_allptr%pg + if (data_ipg > tiny_r_kind) then + data_ib = gps_allptr%b + cg_gps=cg_term/data_ib + wnotgross= one-data_ipg + wgross = data_ipg*cg_gps + arg = exp(exp_arg) + term = log(wnotgross*arg+wgross) + wgt = wnotgross*arg/(wnotgross*arg+wgross) + else + term = exp_arg + wgt = one + endif + if(conv_diagsave) gps_allptr%rdiag(13) = wgt/wgtlim + valqc = -two*rat_err2*term + + +! Accumulate statistics for obs belonging to this task +! based on interface (not mid-point) level + val2=val2*rat_err2 + if(muse)then + if(wgt < wgtlim) awork(21) = awork(21)+one + +! Accumulate values for penalty and data count + jsig=max(1,khgt) + awork(jsig+3*nsig+100)=awork(jsig+3*nsig+100)+valqc + awork(jsig+5*nsig+100)=awork(jsig+5*nsig+100)+one + awork(jsig+6*nsig+100)=awork(jsig+6*nsig+100)+val2 + nn=1 + else + nn=2 + if(ratio_errors*data_ier >=tiny_r_kind)nn=3 + endif + + data_ikx = gps_allptr%type + ikx = nint(data_ikx) + pressure = gps_allptr%rdiag(6) + data_rinc = gps_allptr%rdiag(5)*scale +! Loop over pressure level groupings and obs to accumulate +! statistics as a function of observation type. + do k = 1,npres_print + if(pressure>ptop(k) .and. pressure<=pbot(k))then + ress=data_rinc + + bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count + bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ress ! (o-g) + bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ress*ress ! (o-g)**2 + bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2 ! penalty + bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + end do + end if + +! Transfer diagnostic information to output arrays + if(conv_diagsave .and. luse) then + icnt=icnt+1 + cdiag(icnt) = gps_allptr%cdiag + do j=1,nreal + sdiag(j,icnt)= gps_allptr%rdiag(j) + enddo + endif + + + if (conv_diagsave .and. netcdf_diag .and. luse) call contents_netcdf_diag_ + + gps_allptr => gps_allptr%llpoint + +! End loop over observations + end do + +! End of loop over time bins + END DO + +! If requested, write information to diagnostic file + if(conv_diagsave) then + if (netcdf_diag) call nc_diag_write + if (binary_diag .and. icnt > 0)then + nchar = 1 + write(7)'gps',nchar,nreal,icnt,mype,ioff + write(7)cdiag,sdiag + deallocate(cdiag,sdiag) + endif + endif + + +! Destroy arrays holding gps data + call destroy_genstats_gps +contains + +subroutine init_netcdf_diag_ + integer(i_kind) ncd_fileid, ncd_nobs + character(len=80) string + character(len=128) diag_conv_file + logical append_diag + logical,parameter::verbose=.false. + + write(string,900) jiter +900 format('conv_gps_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif +end subroutine init_netcdf_diag_ + +subroutine contents_binary_diag_ +end subroutine contents_binary_diag_ + +subroutine contents_netcdf_diag_ + use sparsearr, only: sparr2, readarray, fullarray + integer(i_kind),dimension(miter) :: obsdiag_iuse + integer(i_kind) :: obstype, obssubtype + type(sparr2) :: dhx_dx + +! Observation class + character(7),parameter :: obsclass = ' gps' + + call nc_diag_metadata("Station_ID", gps_allptr%cdiag ) + call nc_diag_metadata("Observation_Class", obsclass ) + obstype = gps_allptr%rdiag(1) + obssubtype = gps_allptr%rdiag(2) + call nc_diag_metadata("Observation_Type", obstype ) + call nc_diag_metadata("Observation_Subtype", obssubtype ) + call nc_diag_metadata("Latitude", sngl(gps_allptr%rdiag(3)) ) + call nc_diag_metadata("Longitude", sngl(gps_allptr%rdiag(4)) ) + call nc_diag_metadata("Incremental_Bending_Angle", sngl(gps_allptr%rdiag(5)) ) + call nc_diag_metadata("Pressure", sngl(gps_allptr%rdiag(6)) ) + call nc_diag_metadata("Height", sngl(gps_allptr%rdiag(7)) ) + call nc_diag_metadata("Time", sngl(gps_allptr%rdiag(8)) ) + call nc_diag_metadata("Model_Elevation", sngl(gps_allptr%rdiag(9)) ) + call nc_diag_metadata("Setup_QC_Mark", sngl(gps_allptr%rdiag(10)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(gps_allptr%rdiag(11)) ) + call nc_diag_metadata("Analysis_Use_Flag", sngl(gps_allptr%rdiag(12)) ) + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(gps_allptr%rdiag(13)) ) + call nc_diag_metadata("Errinv_Input", sngl(gps_allptr%rdiag(14)) ) + call nc_diag_metadata("Errinv_Adjust", sngl(gps_allptr%rdiag(15)) ) + call nc_diag_metadata("Errinv_Final", sngl(gps_allptr%rdiag(16)) ) + call nc_diag_metadata("Observation", sngl(gps_allptr%rdiag(17)) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) ) + call nc_diag_metadata("GPS_Type", sngl(gps_allptr%rdiag(20)) ) + call nc_diag_metadata("Temperature_at_Obs_Location", sngl(gps_allptr%rdiag(18)) ) + call nc_diag_metadata("Specific_Humidity_at_Obs_Location", sngl(gps_allptr%rdiag(21)) ) + + if (save_jacobian) then + call readarray(dhx_dx, gps_allptr%rdiag(ioff+1:nreal)) + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + + +! call nc_diag_data2d("T_Jacobian", gps_allptr%mmpoint%jac_t ) + if (lobsdiagsave) then + print *,'ERROR: OBSDIAGSAVE SKIPPED IN NCDIAG DEVELOPMENT. STOPPING.' + call stop2(55) +! do jj=1,miter +! if (gps_allptr%diags%muse(jj)) then +! obsdiag_iuse(jj) = one +! else +! obsdiag_iuse(jj) = -one +! endif +! enddo +! +! call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) +! call nc_diag_data2d("ObsDiagSave_nldepart", gps_allptr%diags%nldepart ) +! call nc_diag_data2d("ObsDiagSave_tldepart", gps_allptr%diags%tldepart ) +! call nc_diag_data2d("ObsDiagSave_obssen", gps_allptr%diags%obssen ) + endif +end subroutine contents_netcdf_diag_ +end subroutine genstats_gps + +end module m_gpsStats diff --git a/src/gesinfo.f90 b/src/gsi/gesinfo.f90 similarity index 94% rename from src/gesinfo.f90 rename to src/gsi/gesinfo.f90 index 545981855..fb37e07d4 100644 --- a/src/gesinfo.f90 +++ b/src/gsi/gesinfo.f90 @@ -31,6 +31,9 @@ subroutine gesinfo ! (1) remove idvm(5) and derivation of idpsfc5 and idthrm5 ! (2) remove cpi, NEMSIO input always is dry tempersture (no ! conversion from enthalpy w/ cpi is needed) +! 2017-05-12 Y. Wang and X. Wang - forecast length in minute unit is included in analysis time calculation +! for subhourly DA, POC: xuguang.wang@ou.edu +! 2017-10-10 wu,w - setup for FV3 ! ! input argument list: ! @@ -71,10 +74,11 @@ subroutine gesinfo use gsi_4dvar, only: nhr_assimilation,min_offset use mpimod, only: npe,mype use gridmod, only: idvc5,ak5,bk5,ck5,tref5,& - regional,nsig,regional_fhr,regional_time,& + regional,nsig,regional_fhr,regional_time,fv3_regional,& wrf_nmm_regional,wrf_mass_regional,twodvar_regional,nems_nmmb_regional,cmaq_regional,& ntracer,ncloud,idvm5,& - ncepgfs_head,ncepgfs_headv,idpsfc5,idthrm5,idsl5,cp5,jcap_b, use_gfs_nemsio + ncepgfs_head,ncepgfs_headv,idpsfc5,idthrm5,idsl5,cp5,jcap_b, use_gfs_nemsio, & + regional_fmin use sigio_module, only: sigio_head,sigio_srhead,sigio_sclose,& sigio_sropen use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close @@ -82,6 +86,7 @@ subroutine gesinfo use constants, only: zero,h300,r60,r3600,i_missing + use gsi_rfv3io_mod, only: read_fv3_files use read_wrf_mass_files_mod, only: read_wrf_mass_files_class use read_wrf_nmm_files_mod, only: read_wrf_nmm_files_class use gsi_io, only: verbose @@ -103,13 +108,13 @@ subroutine gesinfo integer(i_kind) iyr,ihourg,k integer(i_kind) mype_out,iret,iret2,intype - integer(i_kind),dimension(4):: idate4 + integer(i_kind),dimension(5):: idate4 integer(i_kind),dimension(8):: ida,jda integer(i_kind) :: nmin_an integer(i_kind),dimension(7):: idate integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd - real(r_kind) hourg + real(r_kind) hourg, minuteg real(r_kind),dimension(5) :: fha real(r_single),allocatable,dimension(:,:,:) :: nems_vcoord @@ -130,12 +135,14 @@ subroutine gesinfo print_verbose=.false. if(verbose)print_verbose=.true. ! Handle non-GMAO interface (ie, NCEP interface) - write(filename,'("sigf",i2.2)')nhr_assimilation - inquire(file=filename,exist=fexist) - if(.not.fexist) then - write(6,*)' GESINFO: ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' - call stop2(99) - stop + if(.not. fv3_regional) then + write(filename,'("sigf",i2.2)')nhr_assimilation + inquire(file=filename,exist=fexist) + if(.not.fexist) then + write(6,*)' GESINFO: ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' + call stop2(99) + stop + end if end if ! Handle NCEP regional case @@ -144,7 +151,9 @@ subroutine gesinfo idate4(2)=regional_time(2) ! month idate4(3)=regional_time(3) ! day idate4(4)=regional_time(1) ! year + idate4(5)=regional_time(5) ! minutes hourg=regional_fhr ! fcst hour + minuteg=regional_fmin ! fcst minute ! Handle RURTMA date: get iadatemn iadatemn(1)=regional_time(1) ! year iadatemn(2)=regional_time(2) ! month @@ -238,7 +247,7 @@ subroutine gesinfo idsl=gfshead%idsl, ncldt=gfshead%ncldt, iret=iret2) ! FV3GFS write component does not include JCAP, infer from DIMY-2 - if (gfshead%jcap<0) gfshead%jcap=gfshead%latb-2 + !if (gfshead%jcap<0) gfshead%jcap=gfshead%latb-2 if ( iret2 /= 0 .or. TRIM(filetype) /= 'NEMSIO' ) then write(6,*)' GESINFO: UNKNOWN FORMAT FOR GFSATM file = ', & @@ -455,17 +464,23 @@ subroutine gesinfo end if fha=zero; ida=0; jda=0 fha(2)=ihourg ! relative time interval in hours + if(regional) fha(3)=minuteg ! relative time interval in minutes ida(1)=iyr ! year ida(2)=idate4(2) ! month ida(3)=idate4(3) ! day ida(4)=0 ! time zone ida(5)=idate4(1) ! hour + if(regional) ida(6)=idate4(5) ! minute call w3movdat(fha,ida,jda) iadate(1)=jda(1) ! year iadate(2)=jda(2) ! mon iadate(3)=jda(3) ! day iadate(4)=jda(5) ! hour - iadate(5)=0 ! minute + if(regional) then + iadate(5)=jda(6) !regional_time(5) ! minute + else + iadate(5)=0 ! minute + end if ianldate =jda(1)*1000000+jda(2)*10000+jda(3)*100+jda(5) ! Determine date and time at start of assimilation window @@ -516,6 +531,8 @@ subroutine gesinfo call wrf_nmm_files%read_nems_nmmb_files(mype) else if(wrf_mass_regional) then call wrf_mass_files%read_wrf_mass_files(mype) + else if(fv3_regional) then + call read_fv3_files(mype) else if(twodvar_regional) then call read_2d_files(mype) else if(cmaq_regional) then diff --git a/src/get_derivatives.f90 b/src/gsi/get_derivatives.f90 similarity index 100% rename from src/get_derivatives.f90 rename to src/gsi/get_derivatives.f90 diff --git a/src/get_derivatives2.f90 b/src/gsi/get_derivatives2.f90 similarity index 100% rename from src/get_derivatives2.f90 rename to src/gsi/get_derivatives2.f90 diff --git a/src/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 similarity index 80% rename from src/get_gefs_ensperts_dualres.f90 rename to src/gsi/get_gefs_ensperts_dualres.f90 index 01559b1ac..39ec7541d 100644 --- a/src/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -29,11 +29,14 @@ subroutine get_gefs_ensperts_dualres ! call genqsat(qs,tsen,prsl,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,ice,iderivative) ! 2014-11-30 todling - partially generalized to handle any control vector ! (GFS hook needs further attention) +! - also, take SST from members of ensemble ! - avoid alloc GFS workscape when not GFS ! 2014-12-03 derber - Simplify code and optimize routine - turn off reading ! of vort/div and surface height since not needed ! 2014-12-05 zhu - set lower bound for cwmr ! 2016-07-01 mahajan - use GSI ensemble coupler +! 2018-02-15 wu - add code for fv3_regional option +! 2019-03-13 eliu - add precipitation component ! ! input argument list: ! @@ -46,9 +49,9 @@ subroutine get_gefs_ensperts_dualres !$$$ end documentation block use mpeu_util, only: die - use gridmod, only: idsl5,regional + use gridmod, only: idsl5 use hybrid_ensemble_parameters, only: n_ens,write_ens_sprd,oz_univ_static,ntlevs_ens - use hybrid_ensemble_parameters, only: use_gfs_ens,s_ens_v + use hybrid_ensemble_parameters, only: sst_staticB use hybrid_ensemble_parameters, only: en_perts,ps_bar,nelen use constants,only: zero,zero_single,half,fv,rd_over_cp,one,qcmin use mpimod, only: mpi_comm_world,mype,npe @@ -62,7 +65,9 @@ subroutine get_gefs_ensperts_dualres use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_bundlemod, only: gsi_bundledestroy use gsi_bundlemod, only: gsi_gridcreate - use get_gfs_ensmod_mod, only: get_gfs_ensmod_class + use gsi_enscouplermod, only: gsi_enscoupler_get_user_nens + use gsi_enscouplermod, only: gsi_enscoupler_create_sub2grid_info + use gsi_enscouplermod, only: gsi_enscoupler_destroy_sub2grid_info use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info implicit none @@ -85,12 +90,10 @@ subroutine get_gefs_ensperts_dualres ! integer(i_kind),dimension(grd_ens%nlat,grd_ens%nlon):: idum integer(i_kind) istatus,iret,i,ic2,ic3,j,k,n,mm1,iderivative,im,jm,km,m,ipic - integer(i_kind) inner_vars,num_fields integer(i_kind) ipc3d(nc3d),ipc2d(nc2d) integer(i_kind) ier ! integer(i_kind) il,jl - type(get_gfs_ensmod_class) :: enscoupler - logical ice + logical ice,hydrometeor type(sub2grid_info) :: grd_tmp ! Create perturbations grid and get variable names from perturbations @@ -125,14 +128,7 @@ subroutine get_gefs_ensperts_dualres km=en_perts(1,1)%grid%km ! Create temporary communication information for read ensemble routines - if (use_gfs_ens) then - inner_vars=1 - num_fields=min(6*km+1,npe) - call general_sub2grid_create_info(grd_tmp,inner_vars,grd_ens%nlat,grd_ens%nlon, & - km,num_fields,regional) - else - grd_tmp = grd_ens - endif + call gsi_enscoupler_create_sub2grid_info(grd_tmp,km,npe,grd_ens) ! Allocate bundle to hold mean of ensemble members allocate(en_bar(ntlevs_ens)) @@ -160,14 +156,14 @@ subroutine get_gefs_ensperts_dualres en_bar(m)%values=zero - call enscoupler%get_user_ens_(grd_tmp,m,en_read,iret) + call gsi_enscoupler_get_user_Nens(grd_tmp,n_ens,m,en_read,iret) ! Check read return code. Revert to static B if read error detected if ( iret /= 0 ) then beta_s0=one beta_s=one beta_e=zero - if ( mype == npe ) & + if ( mype == 0 ) & write(6,'(A,I4,A,F6.3)')'***WARNING*** ERROR READING ENS FILE, iret = ',iret,' RESET beta_s0 = ',beta_s0 cycle endif @@ -219,6 +215,11 @@ subroutine get_gefs_ensperts_dualres !_$omp parallel do schedule(dynamic,1) private(i,k,j,ic3,rh) do ic3=1,nc3d + hydrometeor = trim(cvars3d(ic3))=='cw' .or. trim(cvars3d(ic3))=='ql' .or. & + trim(cvars3d(ic3))=='qi' .or. trim(cvars3d(ic3))=='qr' .or. & + trim(cvars3d(ic3))=='qs' .or. trim(cvars3d(ic3))=='qg' .or. & + trim(cvars3d(ic3))=='qh' + call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) if(istatus/=0) then write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',m @@ -250,7 +251,7 @@ subroutine get_gefs_ensperts_dualres cycle end if end if - if ( trim(cvars3d(ic3)) == 'cw' ) then + if ( hydrometeor ) then !$omp parallel do schedule(dynamic,1) private(i,j,k) do k=1,km do j=1,jm @@ -291,7 +292,7 @@ subroutine get_gefs_ensperts_dualres end if call gsi_bundlegetpointer(en_perts(n,m),trim(cvars2d(ic2)),w2,istatus) if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for ensemble member ',n + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for ens-pert member ',n call stop2(999) end if call gsi_bundlegetpointer(en_bar(m),trim(cvars2d(ic2)),x2,istatus) @@ -303,13 +304,19 @@ subroutine get_gefs_ensperts_dualres !$omp parallel do schedule(dynamic,1) private(i,j) do j=1,jm do i=1,im - w2(i,j) = p2(i,j) + w2(i,j)=p2(i,j) x2(i,j)=x2(i,j)+p2(i,j) end do end do - if (trim(cvars2d(ic2))=='sst') then + if (sst_staticB.and.trim(cvars2d(ic2))=='sst') then w2 = zero + x2 = zero +! NOTE: if anyone implements alternative use of SST (as from sst2) care need +! be given to those applications getting SST directly from the members of +! the ensemble for which this code is already handling - i.e., I don't +! know who would want to commented out code below but be mindful +! of how it interacts with option sst_staticB, please - Todling. !_$omp parallel do schedule(dynamic,1) private(i,j) ! do j=1,jm ! do i=1,im @@ -324,14 +331,14 @@ subroutine get_gefs_ensperts_dualres end do n_ens_loop ! end do over ensemble end do ntlevs_ens_loop !end do over bins - do n=1,n_ens + do n=n_ens,1,-1 call gsi_bundledestroy(en_read(n),istatus) if ( istatus /= 0 ) & call die('get_gefs_ensperts_dualres',': trouble destroying en_read bundle, istatus = ', istatus) end do deallocate(en_read) - call general_sub2grid_destroy_info(grd_tmp) + call gsi_enscoupler_destroy_sub2grid_info(grd_tmp) ! Copy pbar to module array. ps_bar may be needed for vertical localization ! in terms of scale heights/normalized p/p @@ -345,20 +352,21 @@ subroutine get_gefs_ensperts_dualres end do ! Before converting to perturbations, get ensemble spread - if (m == 1 .and. write_ens_sprd ) call ens_spread_dualres(en_bar(1),1) + !-- if (m == 1 .and. write_ens_sprd ) call ens_spread_dualres(en_bar(1),1) + !!! it is not clear of the next statement is thread/$omp safe. + if (write_ens_sprd ) call ens_spread_dualres(en_bar(m),m) - if(s_ens_v <= zero)then - call gsi_bundlegetpointer(en_bar(m),'ps',x2,istatus) - if(istatus/=0) & - call die('get_gefs_ensperts_dualres:',' error retrieving pointer to (ps) for en_bar, istatus = ', istatus) + call gsi_bundlegetpointer(en_bar(m),'ps',x2,istatus) + if(istatus/=0) & + call die('get_gefs_ensperts_dualres:',' error retrieving pointer to (ps) for en_bar, istatus = ', istatus) - do j=1,jm - do i=1,im - ps_bar(i,j,m)=x2(i,j) - end do + do j=1,jm + do i=1,im + ps_bar(i,j,m)=x2(i,j) end do - end if + end do + ! Convert ensemble members to perturbations do n=1,n_ens @@ -428,11 +436,11 @@ subroutine get_gefs_ensperts_dualres ! end do ! end do - do m=1,ntlevs_ens + do m=ntlevs_ens,1,-1 call gsi_bundledestroy(en_bar(m),istatus) if(istatus/=0) then write(6,*)' in get_gefs_ensperts_dualres: trouble destroying en_bar bundle' - call stop2(999) + call stop2(999) endif end do @@ -458,6 +466,7 @@ subroutine ens_spread_dualres(en_bar,ibin) ! 2010-02-28 parrish - make changes to allow dual resolution capability ! 2011-03-19 parrish - add pseudo-bundle capability ! 2011-11-01 kleist - 4d capability for ensemble/hybrid +! 2019-07-10 todling - truly handling 4d output; and upd to out all ens c-variables ! ! input argument list: ! en_bar - ensemble mean @@ -475,6 +484,7 @@ subroutine ens_spread_dualres(en_bar,ibin) use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sube2suba use constants, only: zero,two,half,one use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d + use mpeu_util, only: getindex use gsi_bundlemod, only: gsi_bundlecreate use gsi_bundlemod, only: gsi_grid use gsi_bundlemod, only: gsi_bundle @@ -493,12 +503,8 @@ subroutine ens_spread_dualres(en_bar,ibin) integer(i_kind) i,n,ic3,k logical regional - integer(i_kind) num_fields,inner_vars,istat,istatus + integer(i_kind) num_fields,inner_vars,istatus logical,allocatable::vector(:) - real(r_kind),pointer,dimension(:,:,:):: st,vp,tv,rh,oz,cw - real(r_kind),pointer,dimension(:,:):: ps - real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig),target::dum3 - real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2),target::dum2 ! create simple regular grid call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) @@ -558,51 +564,13 @@ subroutine ens_spread_dualres(en_bar,ibin) call general_sube2suba(se,sa,p_e2a,sube%values,suba%values,regional) end if - dum2=zero - dum3=zero - call gsi_bundlegetpointer(suba,'sf',st,istat) - if(istat/=0) then - write(6,*)' no sf pointer in ens_spread_dualres, point st at dum3 array' - st => dum3 - end if - call gsi_bundlegetpointer(suba,'vp',vp,istat) - if(istat/=0) then - write(6,*)' no vp pointer in ens_spread_dualres, point vp at dum3 array' - vp => dum3 - end if - call gsi_bundlegetpointer(suba,'t',tv,istat) - if(istat/=0) then - write(6,*)' no t pointer in ens_spread_dualres, point tv at dum3 array' - tv => dum3 - end if - call gsi_bundlegetpointer(suba,'q',rh,istat) - if(istat/=0) then - write(6,*)' no q pointer in ens_spread_dualres, point rh at dum3 array' - rh => dum3 - end if - call gsi_bundlegetpointer(suba,'oz',oz,istat) - if(istat/=0) then - write(6,*)' no oz pointer in ens_spread_dualres, point oz at dum3 array' - oz => dum3 - end if - call gsi_bundlegetpointer(suba,'cw',cw,istat) - if(istat/=0) then - write(6,*)' no cw pointer in ens_spread_dualres, point cw at dum3 array' - cw => dum3 - end if - call gsi_bundlegetpointer(suba,'ps',ps,istat) - if(istat/=0) then - write(6,*)' no ps pointer in ens_spread_dualres, point ps at dum2 array' - ps => dum2 - end if - - call write_spread_dualres(st,vp,tv,rh,oz,cw,ps) + call write_spread_dualres(ibin,suba) return end subroutine ens_spread_dualres -subroutine write_spread_dualres(a,b,c,d,e,f,g2in) +subroutine write_spread_dualres(ibin,bundle) !$$$ subprogram documentation block ! . . . . ! subprogram: write_spread_dualres write ensemble spread for diagnostics @@ -615,15 +583,12 @@ subroutine write_spread_dualres(a,b,c,d,e,f,g2in) ! program history log: ! 2010-01-05 kleist, initial documentation ! 2010-02-28 parrish - make changes to allow dual resolution capability +! 2018-04-01 eliu - add hydrometeors +! 2019-07-10 todling - generalize to write out all variables in the ensemble +! - also allows for print out of different time bins ! ! input argument list: -! a - spread variable 1 -! b - spread variable 2 -! c - spread variable 3 -! d - spread variable 4 -! e - spread variable 5 -! f - spread variable 6 -! g - spread variable 7 +! bundle - spread bundle ! ! output argument list: ! @@ -634,55 +599,55 @@ subroutine write_spread_dualres(a,b,c,d,e,f,g2in) !$$$ end documentation block use mpimod, only: mype use kinds, only: r_kind,i_kind,r_single + use guess_grids, only: get_ref_gesprs use hybrid_ensemble_parameters, only: grd_anl + use gsi_bundlemod, only: gsi_grid + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use constants, only: zero implicit none - character(255):: grdfile + integer(i_kind), intent(in) :: ibin + type(gsi_bundle):: bundle - real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig),intent(in):: a,b,c,d,e,f - real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2),intent(in):: g2in - real(r_kind),dimension(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig,6):: g3in +! local variables + character(255):: grdfile,grdctl - real(r_kind),dimension(grd_anl%nlat,grd_anl%nlon,grd_anl%nsig):: work8_3d - real(r_kind),dimension(grd_anl%nlat,grd_anl%nlon):: work8_2d + real(r_kind),allocatable,dimension(:,:,:):: work8_3d + real(r_kind),allocatable,dimension(:,:):: work8_2d - real(r_single),dimension(grd_anl%nlon,grd_anl%nlat,grd_anl%nsig):: work4_3d - real(r_single),dimension(grd_anl%nlon,grd_anl%nlat):: work4_2d + real(r_single),allocatable,dimension(:,:,:):: work4_3d + real(r_single),allocatable,dimension(:,:):: work4_2d - integer(i_kind) ncfggg,iret,i,j,k,n,mem2d,mem3d,num3d + real(r_kind),pointer,dimension(:,:,:):: ptr3d + real(r_kind),pointer,dimension(:,:):: ptr2d + + integer(i_kind) iret,i,j,k,n,mem2d,mem3d,num3d,lu,istat + real(r_kind),dimension(grd_anl%nsig+1) :: prs ! Initial memory used by 2d and 3d grids mem2d = 4*grd_anl%nlat*grd_anl%nlon mem3d = 4*grd_anl%nlat*grd_anl%nlon*grd_anl%nsig - num3d=6 - -! transfer 2d arrays to generic work aray - do k=1,grd_anl%nsig - do j=1,grd_anl%lon2 - do i=1,grd_anl%lat2 - g3in(i,j,k,1)=a(i,j,k) - g3in(i,j,k,2)=b(i,j,k) - g3in(i,j,k,3)=c(i,j,k) - g3in(i,j,k,4)=d(i,j,k) - g3in(i,j,k,5)=e(i,j,k) - g3in(i,j,k,6)=f(i,j,k) - end do - end do - end do + num3d=11 + + allocate(work8_3d(grd_anl%nlat,grd_anl%nlon,grd_anl%nsig)) + allocate(work8_2d(grd_anl%nlat,grd_anl%nlon)) + allocate(work4_3d(grd_anl%nlon,grd_anl%nlat,grd_anl%nsig)) + allocate(work4_2d(grd_anl%nlon,grd_anl%nlat)) if (mype==0) then - grdfile='ens_spread.grd' - ncfggg=len_trim(grdfile) - call baopenwt(22,grdfile(1:ncfggg),iret) + write(grdfile,'(a,i3.3,a)') 'ens_spread_',ibin, '.grd' + call baopenwt(22,trim(grdfile),iret) write(6,*)'WRITE_SPREAD_DUALRES: open 22 to ',trim(grdfile),' with iret=',iret endif ! Process 3d arrays - do n=1,num3d + do n=1,nc3d + call gsi_bundlegetpointer(bundle,cvars3d(n),ptr3d,istat) work8_3d=zero do k=1,grd_anl%nsig - call gather_stuff2(g3in(1,1,k,n),work8_3d(1,1,k),mype,0) + call gather_stuff2(ptr3d(1,1,k),work8_3d(1,1,k),mype,0) end do if (mype==0) then do k=1,grd_anl%nsig @@ -698,18 +663,20 @@ subroutine write_spread_dualres(a,b,c,d,e,f,g2in) end do ! Process 2d array - work8_2d=zero - call gather_stuff2(g2in,work8_2d,mype,0) - if (mype==0) then - do j=1,grd_anl%nlon - do i=1,grd_anl%nlat - work4_2d(j,i)=work8_2d(i,j) - end do - end do - call wryte(22,mem2d,work4_2d) - write(6,*)'WRITE_SPREAD_DUALRES FOR 2D FIELD ' - endif - + do n=1,nc2d + call gsi_bundlegetpointer(bundle,cvars2d(n),ptr2d,istat) + work8_2d=zero + call gather_stuff2(ptr2d,work8_2d,mype,0) + if (mype==0) then + do j=1,grd_anl%nlon + do i=1,grd_anl%nlat + work4_2d(j,i)=work8_2d(i,j) + end do + end do + call wryte(22,mem2d,work4_2d) + write(6,*)'WRITE_SPREAD_DUALRES FOR 2D FIELD ' + endif + end do ! Close byte-addressable binary file for grads if (mype==0) then @@ -717,6 +684,36 @@ subroutine write_spread_dualres(a,b,c,d,e,f,g2in) write(6,*)'WRITE_SPREAD_DUALRES: close 22 with iret=',iret end if +! Get reference pressure levels for grads purposes + call get_ref_gesprs(prs) + +! Write out a corresponding grads control file + if (mype==0) then + write(grdctl,'(a,i3.3,a)') 'ens_spread_',ibin, '.ctl' + open(newunit=lu,file=trim(grdctl),form='formatted') + write(lu,'(2a)') 'DSET ^', trim(grdfile) + write(lu,'(2a)') 'TITLE ', 'gsi ensemble spread' + write(lu,'(a,2x,e13.6)') 'UNDEF', 1.E+15 ! any other preference for this? + write(lu,'(a,2x,i4,2x,a,2x,f5.1,2x,f9.6)') 'XDEF',grd_anl%nlon, 'LINEAR', 0.0, 360./grd_anl%nlon + write(lu,'(a,2x,i4,2x,a,2x,f5.1,2x,f9.6)') 'YDEF',grd_anl%nlat, 'LINEAR', -90.0, 180./(grd_anl%nlat-1.) + write(lu,'(a,2x,i4,2x,a,100(1x,f10.5))') 'ZDEF',grd_anl%nsig, 'LEVELS', prs(1:grd_anl%nsig) + write(lu,'(a,2x,i4,2x,a)') 'TDEF', 1, 'LINEAR 12:00Z04JUL1776 6hr' ! any date suffices + write(lu,'(a,2x,i4)') 'VARS',nc3d+nc2d + do n=1,nc3d + write(lu,'(a,1x,2(i4,1x),a)') trim(cvars3d(n)),grd_anl%nsig,0,trim(cvars3d(n)) + enddo + do n=1,nc2d + write(lu,'(a,1x,2(i4,1x),a)') trim(cvars2d(n)), 1,0,trim(cvars2d(n)) + enddo + write(lu,'(a)') 'ENDVARS' + close(lu) + endif + +! clean up + deallocate(work4_2d) + deallocate(work4_3d) + deallocate(work8_2d) + deallocate(work8_3d) return end subroutine write_spread_dualres @@ -755,7 +752,7 @@ subroutine general_getprs_glb(ps,tv,prs) use constants,only: zero,half,one_tenth,rd_over_cp,one use gridmod,only: nsig,ak5,bk5,ck5,tref5,idvc5 use gridmod,only: wrf_nmm_regional,nems_nmmb_regional,eta1_ll,eta2_ll,pdtop_ll,pt_ll,& - regional,wrf_mass_regional,twodvar_regional + regional,wrf_mass_regional,twodvar_regional,fv3_regional use hybrid_ensemble_parameters, only: grd_ens implicit none @@ -786,6 +783,15 @@ subroutine general_getprs_glb(ps,tv,prs) end do end do end do + elseif (fv3_regional) then + do k=1,nsig+1 + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=eta1_ll(k)+ eta2_ll(k)*ps(i,j) + end do + end do + end do + elseif (twodvar_regional) then do k=1,nsig+1 do j=1,grd_ens%lon2 diff --git a/src/get_gefs_for_regional.f90 b/src/gsi/get_gefs_for_regional.f90 similarity index 98% rename from src/get_gefs_for_regional.f90 rename to src/gsi/get_gefs_for_regional.f90 index cb338383f..022f1f161 100644 --- a/src/get_gefs_for_regional.f90 +++ b/src/gsi/get_gefs_for_regional.f90 @@ -39,7 +39,7 @@ subroutine get_gefs_for_regional use hybrid_ensemble_parameters, only: en_perts,ps_bar,nelen use hybrid_ensemble_parameters, only: n_ens,grd_ens,grd_a1,grd_e1,p_e2a,uv_hyb_ens,dual_res use hybrid_ensemble_parameters, only: full_ensemble,q_hyb_ens,l_ens_in_diff_time,write_ens_sprd - use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path + use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path,jcap_ens !use hybrid_ensemble_parameters, only: add_bias_perturbation use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use gsi_bundlemod, only: gsi_bundlecreate @@ -76,6 +76,7 @@ subroutine get_gefs_for_regional use nemsio_module, only: nemsio_gfile,nemsio_getfilehead use get_wrf_mass_ensperts_mod, only: get_wrf_mass_ensperts_class use gsi_io, only: verbose + use obsmod, only: l_wcp_cwm implicit none type(sub2grid_info) grd_gfs,grd_mix,grd_gfst @@ -243,7 +244,18 @@ subroutine get_gefs_for_regional nlat_gfs=sighead%latf+2 nlon_gfs=sighead%lonf nsig_gfs=sighead%levs - jcap_gfs=sighead%jcap + if(sighead%jcap > 0)then + jcap_gfs=sighead%jcap + else if(jcap_ens > 0)then + jcap_gfs=jcap_ens + else + write(6,*)'get_gefs_for_regional:ERROR jcap is undefined' + call stop2(555) + endif + + + + idvc=sighead%idvc idsl=sighead%idsl ! Extract header information @@ -275,8 +287,15 @@ subroutine get_gefs_for_regional nlat_gfs=latb+2 nlon_gfs=lonb nsig_gfs=levs - jcap_gfs=njcap - + if(njcap > 0)then + jcap_gfs=njcap + else if(jcap_ens > 0)then + jcap_gfs=jcap_ens + else + write(6,*)'get_gefs_for_regional:ERROR jcap is undefined' + call stop2(555) + endif + if(allocated(nems_vcoord)) deallocate(nems_vcoord) allocate(nems_vcoord(levs+1,3,2)) call nemsio_getfilehead(gfile,iret=iret,vcoord=nems_vcoord) if ( iret /= 0 ) call error_msg(trim(my_name),trim(filename),' ', & @@ -299,6 +318,7 @@ subroutine get_gefs_for_regional call stop2(85) endif + if(allocated(vcoord)) deallocate(vcoord) allocate(vcoord(levs+1,nvcoord)) vcoord(:,1:nvcoord) = nems_vcoord(:,1:nvcoord,1) deallocate(nems_vcoord) @@ -1224,16 +1244,25 @@ subroutine get_gefs_for_regional end do case('cw','CW') -! temporarily ignore cloud water perturbations - - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - ! w3(i,j,k) = cwt(i,j,k)*sig_norm - w3(i,j,k) = zero +! open cloud water perturbations for regional analysis + + if(l_wcp_cwm) then + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = cwt(i,j,k)*sig_norm + end do end do end do - end do + else + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = zero + end do + end do + end do + endif end select end do diff --git a/src/gsi/get_nmmb_ensperts.f90 b/src/gsi/get_nmmb_ensperts.f90 new file mode 100644 index 000000000..93d23c837 --- /dev/null +++ b/src/gsi/get_nmmb_ensperts.f90 @@ -0,0 +1,360 @@ +subroutine get_nmmb_ensperts + +!$$$ subprogram documentation block +! . . . . +! subprogram: get_nmmb_ensperts adaptation of get_gefs_ensperts_dualres +! prgmmr: kleist org: np22 date: 2010-01-05 +! +! abstract: read ensemble members, and construct ensemble perturbations, for use +! with hybrid ensemble option. +! +! program history log: +! 2011-07-01 carley - initial adaptation for NMMB (not yet dual-res compat.) +! 2011-09-19 carley - implement single precision bundle changes +! 2017-05-12 Y. Wang and X. wang - add one option to read hydrometeors and W +! for radar DA, POC: xuguang.wang@ou.edu +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind,r_single + use gridmod, only: pt_ll,pdtop_ll,aeta2_ll,aeta1_ll + use hybrid_ensemble_parameters, only: en_perts,ps_bar,nelen + use constants,only: zero,one,one_tenth,ten + use mpimod, only: mpi_comm_world,ierror,mype + use hybrid_ensemble_parameters, only: n_ens,grd_ens,q_hyb_ens + use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d + use gsi_bundlemod, only: gsi_bundlecreate,gsi_bundleset,gsi_grid,gsi_bundle, & + gsi_bundlegetpointer,gsi_bundledestroy,gsi_gridcreate + + use mpeu_util, only: getindex + implicit none + + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig):: u,v,tv,q,oz,qs,rh,tsen,prsl + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig):: w, qr, qli, ql, dbz, dw, qi + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2):: z,ps,sst2 + real(r_kind),pointer,dimension(:,:,:):: x3 + real(r_single),pointer,dimension(:,:,:) :: w3 + real(r_kind),pointer,dimension(:,:):: x2 + real(r_single),pointer,dimension(:,:):: w2 + type(gsi_bundle):: en_bar + type(gsi_grid) :: grid_ens + real(r_kind) bar_norm,sig_norm + + integer(i_kind) istatus,i,ic2,ic3,j,k,n,iderivative,i_radar_qr,i_radar_qli + character(70) filename + logical ice + + call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) + call gsi_bundlecreate(en_bar,grid_ens,'ensemble',istatus,names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)' get_nmmb_ensperts: trouble creating en_bar bundle' + call stop2(999) + endif + + do n=1,n_ens + en_perts(n,1)%valuesr4=zero + end do + + en_bar%values=zero + sst2=zero ! for now, sst not used in ensemble perturbations, so if sst array is called for + ! then sst part of en_perts will be zero when sst2=zero + +! Determine if qr and qli are control variables for radar data assimilation, + i_radar_qr=0 + i_radar_qli=0 + i_radar_qr=getindex(cvars3d,'qr') + i_radar_qli=getindex(cvars3d,'qli') + + do n=1,n_ens + write(filename,100) n !make the filename +100 format('nmmb_ens_mem',i3.3) + + + if (mype==0)write(6,*) 'CALL GENERAL_READ_NMMB FOR ENS FILE : ',filename + if( i_radar_qr > 0 .and. i_radar_qli > 0 )then + call general_read_nmmb_radar(grd_ens,filename,mype,z,ps,u,v,w,qr,qli,ql,qi,dbz,dw,tv,tsen,q,oz) + else + call general_read_nmmb(grd_ens,filename,mype,z,ps,u,v,tv,tsen,q,oz) + end if + +! For regional application (NMMB) use the the u,v option (i.e. uv_hyb_ens) +! Compute RH +! get 3d pressure at layer midpoints +! using code adapted from subroutine load_prsges for nmmb +! (in guess_grids.F90) + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prsl(i,j,k)=one_tenth* & + (aeta1_ll(k)*pdtop_ll + & + aeta2_ll(k)*(ten*ps(i,j)-pdtop_ll-pt_ll) + & + pt_ll) + end do + end do + end do + + if (.not.q_hyb_ens) then + ice=.true. + iderivative=0 + call genqsat(qs,tsen(1,1,1),prsl(1,1,1),grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,ice,iderivative) + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + rh(i,j,k) = q(i,j,k)/qs(i,j,k) + end do + end do + end do + end if + + do ic3=1,nc3d + + call gsi_bundlegetpointer(en_perts(n,1),trim(cvars3d(ic3)),w3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for ensemble member ',n,' in get_nmmb_ensperts' + call stop2(999) + end if + call gsi_bundlegetpointer(en_bar,trim(cvars3d(ic3)),x3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for en_bar in get_nmmb_ensperts' + call stop2(999) + end if + + select case (trim(cvars3d(ic3))) + + case('sf','SF') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = u(i,j,k) + x3(i,j,k)=x3(i,j,k)+u(i,j,k) + end do + end do + end do + + case('vp','VP') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = v(i,j,k) + x3(i,j,k)=x3(i,j,k)+v(i,j,k) + end do + end do + end do + + case('w','W') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = w(i,j,k) + x3(i,j,k)=x3(i,j,k)+w(i,j,k) + end do + end do + end do + + case('dw','DW') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = dw(i,j,k) + x3(i,j,k)=x3(i,j,k)+dw(i,j,k) + end do + end do + end do + + case('t','T') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = tv(i,j,k) + x3(i,j,k)=x3(i,j,k)+tv(i,j,k) + end do + end do + end do + + case('q','Q') + if (.not.q_hyb_ens) then ! use RH + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = rh(i,j,k) + x3(i,j,k)=x3(i,j,k)+rh(i,j,k) + end do + end do + end do + else ! use Q + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = q(i,j,k) + x3(i,j,k)=x3(i,j,k)+q(i,j,k) + end do + end do + end do + end if + + case('qr','QR') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = qr(i,j,k) + x3(i,j,k)=x3(i,j,k)+qr(i,j,k) + end do + end do + end do + + case('qli','QLI') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = qli(i,j,k) + x3(i,j,k)=x3(i,j,k)+qli(i,j,k) + end do + end do + end do + + case('qi','QI') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = qi(i,j,k) + x3(i,j,k)=x3(i,j,k)+qi(i,j,k) + end do + end do + end do + + case('ql','QL') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = ql(i,j,k) + x3(i,j,k)=x3(i,j,k)+ql(i,j,k) + end do + end do + end do + + case('dbz','DBZ') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = dbz(i,j,k) + x3(i,j,k)=x3(i,j,k)+dbz(i,j,k) + end do + end do + end do + + + case('oz','OZ') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = oz(i,j,k) + x3(i,j,k)=x3(i,j,k)+oz(i,j,k) + end do + end do + end do + + end select + end do + + do ic2=1,nc2d + + call gsi_bundlegetpointer(en_perts(n,1),trim(cvars2d(ic2)),w2,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for ensemble member ',n, ' in get_nmmb_ensperts' + call stop2(999) + end if + call gsi_bundlegetpointer(en_bar,trim(cvars2d(ic2)),x2,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar in get_nmmb_ensperts' + call stop2(999) + end if + + select case (trim(cvars2d(ic2))) + + case('ps','PS') + + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w2(i,j) = ps(i,j) + x2(i,j)=x2(i,j)+ps(i,j) + end do + end do + + case('sst','SST') + + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w2(i,j) = sst2(i,j) + x2(i,j)=x2(i,j)+sst2(i,j) + end do + end do + + end select + end do + end do ! end do over ensemble + +! Convert to mean + bar_norm = one/float(n_ens) + en_bar%values=en_bar%values*bar_norm + +! Copy pbar to module array. ps_bar may be needed for vertical localization +! in terms of scale heights/normalized p/p + do ic2=1,nc2d + + if(trim(cvars2d(ic2)) == 'ps'.or.trim(cvars2d(ic2)) == 'PS') then + + call gsi_bundlegetpointer(en_bar,trim(cvars2d(ic2)),x2,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar in get_nmmb_ensperts' + call stop2(999) + end if + + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + ps_bar(i,j,1)=x2(i,j) + end do + end do + exit + end if + end do + + call mpi_barrier(mpi_comm_world,ierror) + +! Convert ensemble members to perturbations + sig_norm=sqrt(one/max(one,n_ens-one)) + + do n=1,n_ens + do i=1,nelen + en_perts(n,1)%valuesr4(i)=(en_perts(n,1)%valuesr4(i)-en_bar%values(i))*sig_norm + end do + end do + + call gsi_bundledestroy(en_bar,istatus) + if(istatus/=0) then + write(6,*)' in get_nmmb_ensperts: trouble destroying en_bar bundle in get_nmmb_ensperts' + call stop2(999) + endif + + if (mype==0)write(6,*) 'get_nmmb_ensperts DONE' + return + +end subroutine get_nmmb_ensperts diff --git a/src/get_semimp_mats.f90 b/src/gsi/get_semimp_mats.f90 similarity index 96% rename from src/get_semimp_mats.f90 rename to src/gsi/get_semimp_mats.f90 index 18136621e..891995b70 100644 --- a/src/get_semimp_mats.f90 +++ b/src/gsi/get_semimp_mats.f90 @@ -420,18 +420,20 @@ subroutine iminv (a,n,d,l,m) ! final row and column interchange ! k=n - 100 k=(k-1) - if(k) 150,150,105 - 105 i=l(k) - if(i-k) 120,120,108 - 108 jq=n*(k-1) - jr=n*(i-1) - do 110 j=1,n - jk=jq+j - hold=a(jk) - ji=jr+j - a(jk)=-a(ji) - 110 a(ji) =hold + do + 100 k=(k-1) + if(k) 150,150,105 + 105 i=l(k) + if(i-k) 120,120,108 + 108 jq=n*(k-1) + jr=n*(i-1) + do 110 j=1,n + jk=jq+j + hold=a(jk) + ji=jr+j + a(jk)=-a(ji) + a(ji) =hold + 110 continue 120 j=m(k) if(j-k) 100,100,125 125 ki=k-n @@ -440,7 +442,8 @@ subroutine iminv (a,n,d,l,m) hold=a(ki) ji=ki-k+j a(ki)=-a(ji) - 130 a(ji) =hold - go to 100 - 150 return + a(ji) =hold + 130 continue + end do + 150 return end subroutine iminv diff --git a/src/getcount_bufr.f90 b/src/gsi/getcount_bufr.f90 similarity index 100% rename from src/getcount_bufr.f90 rename to src/gsi/getcount_bufr.f90 diff --git a/src/getprs.f90 b/src/gsi/getprs.f90 similarity index 95% rename from src/getprs.f90 rename to src/gsi/getprs.f90 index 5a512fe10..195079dc4 100644 --- a/src/getprs.f90 +++ b/src/gsi/getprs.f90 @@ -16,6 +16,7 @@ subroutine getprs(ps,prs) ! 2010-09-15 pagowski - added cmaq ! 2013-10-19 todling - metguess now holds background ! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS core +! 2018-02-15 wu - add code for fv3_regional ! ! input argument list: ! ps - surface pressure @@ -33,7 +34,7 @@ subroutine getprs(ps,prs) use constants,only: zero,half,one_tenth,rd_over_cp,one use gridmod,only: nsig,lat2,lon2,ak5,bk5,ck5,tref5,idvc5 use gridmod,only: wrf_nmm_regional,nems_nmmb_regional,eta1_ll,eta2_ll,pdtop_ll,pt_ll,& - regional,wrf_mass_regional,cmaq_regional,twodvar_regional + regional,wrf_mass_regional,cmaq_regional,twodvar_regional,fv3_regional use guess_grids, only: ntguessig use gsi_metguess_mod, only: gsi_metguess_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -67,6 +68,15 @@ subroutine getprs(ps,prs) end do end do end do + elseif (fv3_regional) then + do k=1,nsig+1 + do j=1,lon2 + do i=1,lat2 + prs(i,j,k)=eta1_ll(k)+ eta2_ll(k)*ps(i,j) + end do + end do + end do + elseif (twodvar_regional) then do k=1,nsig+1 do j=1,lon2 @@ -162,7 +172,7 @@ subroutine getprs_horiz(ps_x,ps_y,prs,prs_x,prs_y) use constants,only: zero use gridmod,only: nsig,lat2,lon2 use gridmod,only: regional,wrf_nmm_regional,nems_nmmb_regional,eta2_ll,& - cmaq_regional + cmaq_regional,fv3_regional use compact_diffs, only: compact_dlat,compact_dlon use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_commvars_mod, only: s2g2 @@ -182,7 +192,8 @@ subroutine getprs_horiz(ps_x,ps_y,prs,prs_x,prs_y) allocate(hwork_g(s2g2%inner_vars,s2g2%nlat,s2g2%nlon,s2g2%kbegin_loc:s2g2%kend_alloc)) if(regional)then - if(wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) then + if(wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional& + .or. fv3_regional) then do k=1,nsig+1 do j=1,lon2 do i=1,lat2 @@ -270,7 +281,7 @@ subroutine getprs_tl(ps,t,prs) use constants,only: zero,one,rd_over_cp,half use gridmod,only: nsig,lat2,lon2,bk5,ck5,idvc5,tref5 use gridmod,only: wrf_nmm_regional,nems_nmmb_regional,eta2_ll,eta1_ll,regional,wrf_mass_regional,cmaq_regional,& - twodvar_regional + twodvar_regional,fv3_regional use guess_grids, only: ntguessig use gsi_metguess_mod, only: gsi_metguess_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -288,7 +299,7 @@ subroutine getprs_tl(ps,t,prs) if (regional) then if(wrf_nmm_regional.or.nems_nmmb_regional.or.& - cmaq_regional) then + fv3_regional .or. cmaq_regional) then do k=1,nsig+1 do j=1,lon2 do i=1,lat2 @@ -387,7 +398,7 @@ subroutine getprs_horiz_tl(ps_x,ps_y,prs,prs_x,prs_y) use constants,only: zero use gridmod,only: nsig,lat2,lon2 use gridmod,only: regional,wrf_nmm_regional,nems_nmmb_regional,eta2_ll,& - cmaq_regional + cmaq_regional,fv3_regional use compact_diffs, only: compact_dlat,compact_dlon use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_commvars_mod, only: s2g2 @@ -407,7 +418,8 @@ subroutine getprs_horiz_tl(ps_x,ps_y,prs,prs_x,prs_y) allocate(hwork_g(s2g2%inner_vars,s2g2%nlat,s2g2%nlon,s2g2%kbegin_loc:s2g2%kend_alloc)) if(regional)then - if(wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) then + if(wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional& + .or. fv3_regional) then do k=1,nsig+1 do j=1,lon2 do i=1,lat2 @@ -497,7 +509,7 @@ subroutine getprs_ad(ps,t,prs) use kinds,only: r_kind,i_kind use gridmod,only: nsig,lat2,lon2,bk5,ck5,tref5,idvc5 use gridmod,only: wrf_nmm_regional,nems_nmmb_regional,eta2_ll,regional,wrf_mass_regional,cmaq_regional,eta1_ll,& - twodvar_regional + twodvar_regional,fv3_regional use guess_grids, only: ntguessig use constants,only: zero,half,one,rd_over_cp use gsi_metguess_mod, only: gsi_metguess_bundle @@ -518,7 +530,7 @@ subroutine getprs_ad(ps,t,prs) if (regional) then if(wrf_nmm_regional.or.nems_nmmb_regional.or.& - cmaq_regional) then + cmaq_regional .or. fv3_regional) then do k=1,nsig+1 do j=1,lon2 do i=1,lat2 @@ -629,7 +641,7 @@ subroutine getprs_horiz_ad(ps_x,ps_y,prs,prs_x,prs_y) use constants,only: zero use gridmod,only: nsig,lat2,lon2 use gridmod,only: regional,wrf_nmm_regional,nems_nmmb_regional,eta2_ll,& - cmaq_regional + cmaq_regional,fv3_regional use compact_diffs, only: tcompact_dlat,tcompact_dlon use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_commvars_mod, only: s2g2 @@ -651,7 +663,8 @@ subroutine getprs_horiz_ad(ps_x,ps_y,prs,prs_x,prs_y) ! Adjoint of horizontal derivatives if (regional) then - if(wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) then + if(wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional& + .or. fv3_regional) then do k=1,nsig+1 do j=1,lon2 do i=1,lat2 diff --git a/src/getsiga.f90 b/src/gsi/getsiga.f90 similarity index 100% rename from src/getsiga.f90 rename to src/gsi/getsiga.f90 diff --git a/src/getuv.f90 b/src/gsi/getuv.f90 similarity index 100% rename from src/getuv.f90 rename to src/gsi/getuv.f90 diff --git a/src/getvvel.f90 b/src/gsi/getvvel.f90 similarity index 100% rename from src/getvvel.f90 rename to src/gsi/getvvel.f90 diff --git a/src/gfs_stratosphere.f90 b/src/gsi/gfs_stratosphere.f90 similarity index 100% rename from src/gfs_stratosphere.f90 rename to src/gsi/gfs_stratosphere.f90 diff --git a/src/glbsoi.f90 b/src/gsi/glbsoi.f90 similarity index 97% rename from src/glbsoi.f90 rename to src/gsi/glbsoi.f90 index 6a24c5416..888cfdefb 100644 --- a/src/glbsoi.f90 +++ b/src/gsi/glbsoi.f90 @@ -153,6 +153,7 @@ subroutine glbsoi hybens_localization_setup,hybens_grid_setup use gfs_stratosphere, only: destroy_nmmb_vcoords,use_gfs_stratosphere use aircraftinfo, only: aircraftinfo_write,aircraft_t_bc_pof,aircraft_t_bc,mype_airobst + use rapidrefresh_cldsurf_mod, only: i_gsdcldanal_type use m_prad, only: prad_updatePredx ! was -- prad_bias() use m_obsdiags, only: obsdiags_write @@ -209,6 +210,23 @@ subroutine glbsoi ! Read observations and scatter call observer_set +! cloud analysis + if(i_gsdcldanal_type==6 .or. i_gsdcldanal_type==3) then + call gsdcloudanalysis(mype) + +! Write output analysis files + call write_all(-1,mype) + call prt_guess('analysis') + +! Finalize observer + call observer_finalize + +! Finalize timer for this procedure + call timer_fnl('glbsoi') + + return + endif + ! Create/setup background error and background error balance if (regional)then call create_balance_vars_reg(mype) @@ -430,12 +448,12 @@ subroutine glbsoi ! Write updated bias correction coefficients if (.not.twodvar_regional) then if (l4dvar) then - if(mype == 0) call radinfo_write + call radinfo_write(0) if(mype == npe-1) call pcpinfo_write if(mype==mype_airobst .and. (aircraft_t_bc_pof .or. aircraft_t_bc)) call aircraftinfo_write else if (jiter==miter+1 ) then - if(mype == 0) call radinfo_write + call radinfo_write(0) if(mype == npe-1) call pcpinfo_write if(mype==mype_airobst .and. (aircraft_t_bc_pof .or. aircraft_t_bc)) call aircraftinfo_write endif diff --git a/src/grdcrd.f90 b/src/gsi/grdcrd.f90 similarity index 98% rename from src/grdcrd.f90 rename to src/gsi/grdcrd.f90 index 7dd774f8e..c20e02ce7 100644 --- a/src/grdcrd.f90 +++ b/src/gsi/grdcrd.f90 @@ -188,14 +188,14 @@ function isrchf(nx1,x,y,flg) do k=1,nx1 if(y<=x(k)) then isrchf=k - go to 100 + return end if end do else do k=1,nx1 if(y>=x(k)) then isrchf=k - go to 100 + return end if end do end if @@ -203,6 +203,5 @@ function isrchf(nx1,x,y,flg) isrchf=nx1+1 if(nx1<=0) isrchf=0 -100 continue return end function isrchf diff --git a/src/gridmod.F90 b/src/gsi/gridmod.F90 similarity index 98% rename from src/gridmod.F90 rename to src/gsi/gridmod.F90 index 8965167ca..069109585 100644 --- a/src/gridmod.F90 +++ b/src/gsi/gridmod.F90 @@ -86,6 +86,9 @@ module gridmod ! 2016-03-02 s.liu/carley - remove use_reflectivity and use i_gsdcldanal_type ! 2017-03-23 Hu - add code to get eta2_ll and aeta2_ll ready for hybrid vertical coodinate in WRF MASS CORE ! 2017-08-31 Li - add sfcnst_comb to handle surface and nsst combined file +! 2018-02-15 wu - add fv3_regional & grid_ratio_fv3_regional +! 2019-03-05 martin - add wgtfactlats for factqmin/factqmax scaling +! 2019-04-19 martin - add use_fv3_aero option to distingiush between NGAC and FV3-Chem ! ! ! @@ -135,16 +138,19 @@ module gridmod public :: rlon_min_dd,coslon,sinlon,rlons,ird_s,irc_s,periodic,idthrm5 public :: cp5,idvm5,ncepgfs_head,idpsfc5,nlon_sfc,nlat_sfc public :: rlons_sfc,rlats_sfc,jlon1,ilat1,periodic_s,latlon1n1 - public :: nsig2,wgtlats,corlats,rbs2,ncepgfs_headv,regional_time - public :: regional_fhr,region_dyi,coeffx,region_dxi,coeffy,nsig_hlf + public :: regional_fhr,region_dyi,coeffx,region_dxi,coeffy,nsig_hlf,regional_fmin + public :: nsig2,wgtlats,corlats,rbs2,ncepgfs_headv,regional_time,wgtfactlats public :: nlat_regional,nlon_regional,update_regsfc,half_grid,gencode public :: diagnostic_reg,nmmb_reference_grid,filled_grid public :: grid_ratio_nmmb,isd_g,isc_g,dx_gfs,lpl_gfs,nsig5,nmmb_verttype + public :: grid_ratio_fv3_regional,fv3_regional public :: nsig3,nsig4,grid_ratio_wrfmass public :: use_gfs_ozone,check_gfs_ozone_date,regional_ozone,nvege_type public :: jcap,jcap_b,hires_b,sp_a,grd_a public :: jtstart,jtstop,nthreads public :: use_gfs_nemsio + public :: fv3_full_hydro + public :: use_fv3_aero public :: sfcnst_comb public :: use_readin_anl_sfcmask public :: jcap_gfs,nlat_gfs,nlon_gfs @@ -165,6 +171,7 @@ module gridmod logical diagnostic_reg ! .t. to activate regional analysis diagnostics logical wrf_nmm_regional ! + logical fv3_regional ! .t. to run with fv3 regional model logical nems_nmmb_regional! .t. to run with NEMS NMMB model logical wrf_mass_regional ! logical wrf_mass_hybridcord @@ -180,12 +187,15 @@ module gridmod logical update_regsfc ! logical hires_b ! .t. when jcap_b requires double FFT logical use_gfs_nemsio ! .t. for using NEMSIO to real global first guess + logical fv3_full_hydro ! .t. for using NEMSIO to real global first guess + logical use_fv3_aero ! .t. for using FV3 Aerosols, .f. for NGAC logical sfcnst_comb ! .t. for using combined sfc & nst file logical use_sp_eqspace ! .t. use equally-space grid in spectral transforms logical use_readin_anl_sfcmask ! .t. for using readin surface mask character(1) nmmb_reference_grid ! ='H': use nmmb H grid as reference for analysis grid ! ='V': use nmmb V grid as reference for analysis grid + real(r_kind) grid_ratio_fv3_regional ! ratio of analysis grid to fv3 model grid in fv3 grid units. real(r_kind) grid_ratio_nmmb ! ratio of analysis grid to nmmb model grid in nmmb model grid units. real(r_kind) grid_ratio_wrfmass ! ratio of analysis grid to wrf model grid in wrf mass grid units. character(3) nmmb_verttype ! 'OLD' for old vertical coordinate definition @@ -282,6 +292,7 @@ module gridmod real(r_kind),allocatable,dimension(:):: coslon ! cos(grid longitudes (radians)) real(r_kind),allocatable,dimension(:):: sinlon ! sin(grid longitudes (radians)) real(r_kind),allocatable,dimension(:):: wgtlats ! gaussian integration weights + real(r_kind),allocatable,dimension(:):: wgtfactlats ! gaussian integration weights if global, 1 if regional real(r_kind),allocatable,dimension(:):: corlats ! coriolis parameter by latitude real(r_kind),allocatable,dimension(:):: rbs2 ! 1./sin(grid latitudes))**2 @@ -304,7 +315,7 @@ module gridmod real(r_kind) dt_ll,pdtop_ll,pt_ll integer(i_kind) nlon_regional,nlat_regional - real(r_kind) regional_fhr + real(r_kind) regional_fhr,regional_fmin integer(i_kind) regional_time(6) integer(i_kind) jcap_gfs,nlat_gfs,nlon_gfs @@ -393,6 +404,7 @@ subroutine init_grid ! 2011-09-14 todling - add use_sp_eqspace to better control lat/lon grid case ! 2016-08-28 li - tic591: add use_readin_anl_sfcmask for consistent sfcmask ! between analysis grids and others +! 2019-04-19 martin - add use_fv3_aero option for NGAC vs FV3-Chem ! ! !REMARKS: ! language: f90 @@ -403,7 +415,7 @@ subroutine init_grid ! !EOP !------------------------------------------------------------------------- - use constants, only: two + use constants, only: one,two use gsi_io, only: verbose implicit none @@ -428,6 +440,7 @@ subroutine init_grid wrf_mass_regional = .false. wrf_mass_hybridcord = .false. cmaq_regional=.false. + fv3_regional=.false. nems_nmmb_regional = .false. twodvar_regional = .false. use_gfs_ozone = .false. @@ -436,8 +449,9 @@ subroutine init_grid netcdf = .false. filled_grid = .false. half_grid = .false. + grid_ratio_fv3_regional = one grid_ratio_nmmb = sqrt(two) - grid_ratio_wrfmass = 1.0_r_kind + grid_ratio_wrfmass = one nmmb_reference_grid = 'H' nmmb_verttype = 'OLD' lat1 = nlat @@ -468,6 +482,8 @@ subroutine init_grid nthreads = 1 ! initialize the number of threads use_gfs_nemsio = .false. + fv3_full_hydro = .false. + use_fv3_aero = .false. sfcnst_comb = .false. use_readin_anl_sfcmask = .false. @@ -496,6 +512,7 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) use mpeu_util, only: getindex use general_specmod, only: spec_cut use gsi_io, only: verbose + use gsi_metguess_mod, only: gsi_metguess_get implicit none ! !INPUT PARAMETERS: @@ -536,6 +553,8 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) integer(i_kind) i,k,inner_vars,num_fields integer(i_kind) n3d,n2d,nvars,tid,nth integer(i_kind) ipsf,ipvp,jpsf,jpvp,isfb,isfe,ivpb,ivpe + integer(i_kind) istatus,icw,iql,iqi + integer(i_kind) icw_cv,iql_cv,iqi_cv logical,allocatable,dimension(:):: vector logical print_verbose @@ -556,6 +575,17 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) n2d =size(cvars2d) nvars=size(cvars) + icw_cv = getindex(cvars3d(1:n3d),'cw') + iql_cv = getindex(cvars3d(1:n3d),'ql') + iqi_cv = getindex(cvars3d(1:n3d),'qi') + call gsi_metguess_get('var::cw', icw, istatus) + call gsi_metguess_get('var::ql', iql, istatus) + call gsi_metguess_get('var::qi', iqi, istatus) + fv3_full_hydro = ( iql>0 .and. iqi>0 .and. (.not. icw>0) ) .and. & + ( iql_cv>0 .and. iqi_cv>0 .and. (.not. icw_cv>0)) + + if (mype==0) write(6,*) myname, ' fv3_full_hydro ', fv3_full_hydro + ! Allocate and initialize variables for mapping between global ! domain and subdomains call create_mapping(npe) @@ -782,7 +812,7 @@ subroutine create_grid_vars implicit none allocate(rlats(nlat),rlons(nlon),coslon(nlon),sinlon(nlon),& - wgtlats(nlat),rbs2(nlat),corlats(nlat)) + wgtlats(nlat),rbs2(nlat),corlats(nlat),wgtfactlats(nlat)) allocate(ak5(nsig+1),bk5(nsig+1),ck5(nsig+1),tref5(nsig)) return end subroutine create_grid_vars @@ -820,7 +850,7 @@ subroutine destroy_grid_vars !------------------------------------------------------------------------- implicit none - deallocate(rlats,rlons,corlats,coslon,sinlon,wgtlats,rbs2) + deallocate(rlats,rlons,corlats,coslon,sinlon,wgtlats,wgtfactlats,rbs2) deallocate(ak5,bk5,ck5,tref5) if (allocated(cp5)) deallocate(cp5) if (allocated(dx_gfs)) deallocate(dx_gfs) @@ -1002,6 +1032,7 @@ subroutine init_reg_glob_ll(mype,lendian_in) ! 2009-01-02 todling - remove unused vars ! 2012-01-24 parrish - correct bug in definition of region_dx, region_dy. ! 2014-03-12 Hu - Code for GSI analysis on Mass grid larger than background mass grid +! 2017-10-10 Wu,W - setup FV3 ! ! !REMARKS: ! language: f90 @@ -1050,6 +1081,19 @@ subroutine init_reg_glob_ll(mype,lendian_in) dt_ll=zero end if + + if(fv3_regional) then ! begin fv3 regional section + if(diagnostic_reg.and.mype==0) write(6,*)' in init_reg_glob_ll for FV3 ' + rlon_min_ll=one + rlat_min_ll=one + rlon_max_ll=nlon + rlat_max_ll=nlat + rlat_min_dd=rlat_min_ll+r1_5/grid_ratio_fv3_regional + rlat_max_dd=rlat_max_ll-r1_5/grid_ratio_fv3_regional + rlon_min_dd=rlon_min_ll+r1_5/grid_ratio_fv3_regional + rlon_max_dd=rlon_max_ll-r1_5/grid_ratio_fv3_regional + endif ! fv3_regional + if(wrf_nmm_regional) then ! begin wrf_nmm section ! This is a wrf_nmm regional run. if(diagnostic_reg.and.mype==0) & @@ -1346,7 +1390,8 @@ subroutine init_reg_glob_ll(mype,lendian_in) allocate(region_dyi(nlat,nlon),region_dxi(nlat,nlon)) allocate(coeffy(nlat,nlon),coeffx(nlat,nlon)) -! trasfer earth lats and lons to arrays region_lat, region_lon +! trasfer earth lats and lons to arrays region_lat, region_lon +! NOTE: The glat_an and glon_an are the latlon values for ensemble perturbation grid allocate(glat_an(nlon,nlat),glon_an(nlon,nlat)) do k=1,nlon @@ -1399,7 +1444,7 @@ subroutine init_reg_glob_ll(mype,lendian_in) write(filename,'("sigf",i2.2)') ihrmid open(lendian_in,file=filename,form='unformatted') rewind lendian_in - read(lendian_in) regional_time,regional_fhr,nlon_regional,nlat_regional,nsig, & + read(lendian_in) regional_time,regional_fhr,regional_fmin,nlon_regional,nlat_regional,nsig, & dlmd,dphd,pt,pdtop,nmmb_verttype if(diagnostic_reg.and.mype==0) then diff --git a/src/grtest.f90 b/src/gsi/grtest.f90 similarity index 100% rename from src/grtest.f90 rename to src/gsi/grtest.f90 diff --git a/src/gscond_ad.f90 b/src/gsi/gscond_ad.f90 similarity index 100% rename from src/gscond_ad.f90 rename to src/gsi/gscond_ad.f90 diff --git a/src/gsd_terrain_match_surfTobs.f90 b/src/gsi/gsd_terrain_match_surfTobs.f90 similarity index 100% rename from src/gsd_terrain_match_surfTobs.f90 rename to src/gsi/gsd_terrain_match_surfTobs.f90 diff --git a/src/gsd_update_mod.f90 b/src/gsi/gsd_update_mod.f90 similarity index 94% rename from src/gsd_update_mod.f90 rename to src/gsi/gsd_update_mod.f90 index a6c8844d4..59e04ff46 100644 --- a/src/gsd_update_mod.f90 +++ b/src/gsi/gsd_update_mod.f90 @@ -65,6 +65,7 @@ subroutine gsd_update_soil_tq(tinc,is_t,qinc,is_q,it) use jfunc, only: tsensible,qoption use derivsmod, only: qsatg use constants, only: zero,one,fv,one_tenth,deg2rad,pi + use constants, only: partialSnowThreshold,t0c use gridmod, only: lat2,lon2,nsig,nsig_soil use gridmod, only: regional_time use guess_grids, only: ges_tsen,sno,coast_prox @@ -218,13 +219,27 @@ subroutine gsd_update_soil_tq(tinc,is_t,qinc,is_q,it) ges_tslb(i,j,3) = ges_tslb(i,j,3) + & min(1._r_kind,max(dts_min,tincf*0.2_r_kind)) endif - if (sno(i,j,it) < snowthreshold) THEN - ges_tsk(i,j) = ges_tsk(i,j) + min(1._r_kind,max(dts_min,tincf*0.6_r_kind)) + if (sno(i,j,it) < partialSnowThreshold) THEN +! partialSnowThreshold (32 mm) is the threshold for partial snow. +! When grid cell is partially covered with snow or snow-free - always update TSK and SOILT1 + ges_tsk(i,j) = ges_tsk(i,j) + min(1._r_kind,max(dts_min,tincf*0.6_r_kind)) ges_soilt1(i,j) = ges_soilt1(i,j) + min(1._r_kind,max(dts_min,tincf*0.6_r_kind)) - else ! if snow cover, then only adjust TSK and SOILT1 - ges_tsk(i,j) = ges_tsk(i,j) + min(1._r_kind,max(-2._r_kind,tincf*0.6_r_kind)) - ges_soilt1(i,j) = ges_soilt1(i,j) + min(1._r_kind,max(-2._r_kind,tincf*0.6_r_kind)) - endif ! sno(i,j,it) < snowthreshold + else +! grid cell is fully covered with snow + if(tincf < zero) then +! always adjust TSK and SOILT1 when tincf < 0 - cooling + ges_tsk(i,j) = ges_tsk(i,j) + min(1._r_kind,max(-2._r_kind,tincf*0.6_r_kind)) + ges_soilt1(i,j) = ges_soilt1(i,j) + min(1._r_kind,max(-2._r_kind,tincf*0.6_r_kind)) + else +! if ticnf > 0 - warming, then adjust snow TSK and SOILT1 only if TSK < t0c (273 K). +! If TSK > t0c(273 K) most likely due to melting process, then leave TSK and SOILT1 unchanged. + if(ges_tsk(i,j) < t0c ) then + ges_tsk(i,j) = min(t0c,ges_tsk(i,j) + min(1._r_kind,max(-2._r_kind,tincf*0.6_r_kind))) + ges_soilt1(i,j) = min(t0c,ges_soilt1(i,j) + min(1._r_kind,max(-2._r_kind,tincf*0.6_r_kind))) + endif ! tsk < 273 K + endif ! tincf < 0. + + endif ! sno(i,j,it) < 32 end do end do ! end do ! it diff --git a/src/gsdcloudanalysis.F90 b/src/gsi/gsdcloudanalysis.F90 similarity index 80% rename from src/gsdcloudanalysis.F90 rename to src/gsi/gsdcloudanalysis.F90 index 58b594da9..381aa012b 100644 --- a/src/gsdcloudanalysis.F90 +++ b/src/gsi/gsdcloudanalysis.F90 @@ -75,7 +75,9 @@ subroutine gsdcloudanalysis(mype) build_cloud_frac_p, clear_cloud_frac_p, & nesdis_npts_rad, & iclean_hydro_withRef, iclean_hydro_withRef_allcol, & - i_lightpcp, l_numconc + l_use_hydroretrieval_all, & + i_lightpcp, l_numconc, qv_max_inc,ioption, & + l_precip_clear_only,l_fog_off,cld_bld_coverage,cld_clr_coverage use gsi_metguess_mod, only: GSI_MetGuess_Bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -228,7 +230,6 @@ subroutine gsdcloudanalysis(mype) ! ! misc. ! - logical :: l_use_hydroretrieval_all integer(i_kind) :: i,j,k,itsig,itsfc integer(i_kind) :: iglobal,jglobal,ilocal,jlocal logical :: ifindomain @@ -238,6 +239,7 @@ subroutine gsdcloudanalysis(mype) character(10) :: obstype integer(i_kind) :: lunin, is, ier, istatus integer(i_kind) :: nreal,nchanl,ilat1s,ilon1s + integer(i_kind) :: clean_count,build_count,part_count,miss_count character(20) :: isis real(r_kind) :: refmax,snowtemp,raintemp,nraintemp,graupeltemp @@ -249,11 +251,16 @@ subroutine gsdcloudanalysis(mype) real(r_kind),parameter :: pi = 4._r_kind*atan(1._r_kind) real(r_kind),parameter :: rho_w = 999.97_r_kind, rho_a = 1.2_r_kind - real(r_kind),parameter :: cldDiameter = 10.0D3_r_kind + real(r_kind),parameter :: cldDiameter = 10.0E3_r_kind ! ! + clean_count=0 + build_count=0 + part_count=0 + miss_count=0 + itsig=1 ! _RT shouldn't this be ntguessig? itsfc=1 ! _RT shouldn't this be ntguessig? ! @@ -273,15 +280,14 @@ subroutine gsdcloudanalysis(mype) call gsi_bundlegetpointer (GSI_MetGuess_Bundle(itsig),'qnc',ges_qnc,istatus);ier=ier+istatus if(ier/=0) return ! no guess, nothing to do - if(mype==0) then - write(6,*) '========================================' - write(6,*) 'gsdcloudanalysis: Start generalized cloud analysis ' - write(6,*) '========================================' - endif + !if(mype==0) then + ! write(6,*) '========================================' + write(6,*) 'gsdcloudanalysis: Start generalized cloud analysis', mype + ! write(6,*) '========================================' + !endif ! ! ! - l_use_hydroretrieval_all=.false. krad_bot=7.0_r_single r_radius=metar_impact_radius r_radius_lowCloud=metar_impact_radius_lowCloud @@ -376,7 +382,7 @@ subroutine gsdcloudanalysis(mype) allocate(oistation(numsao)) allocate(ojstation(numsao)) allocate(wimaxstation(numsao)) - call read_Surface(mype,lunin,regional_time,istart(mype+1),jstart(mype+1),lon2,lat2, & + call read_Surface(mype,lunin,istart(mype+1),jstart(mype+1),lon2,lat2, & numsao,nvarcld_p,oi,oj,ocld,owx,oelvtn,odist,cstation,oistation,ojstation) if(mype == 0) write(6,*) 'gsdcloudanalysis: ', & 'Surface cloud observations are read in successfully' @@ -387,8 +393,8 @@ subroutine gsdcloudanalysis(mype) ! elseif( dtype(is) == 'gos_ctp' ) then - call read_NESDIS(mype,lunin,nsat1(is),regional_time,istart(mype+1), & - jstart(mype+1),lon2,lat2,sat_ctp,sat_tem,w_frac,nesdis_npts_rad) + call read_NESDIS(mype,lunin,nsat1(is),istart(mype+1), & + jstart(mype+1),lon2,lat2,sat_ctp,sat_tem,w_frac,nesdis_npts_rad,ioption) if(mype == 0) write(6,*) 'gsdcloudanalysis: ', & 'NESDIS cloud products are read in successfully' istat_nesdis = 1 @@ -401,7 +407,7 @@ subroutine gsdcloudanalysis(mype) allocate( ref_mosaic31(lon2,lat2,31) ) ref_mosaic31=-99999.0_r_kind - call read_radar_ref(mype,lunin,regional_time,istart(mype+1),jstart(mype+1), & + call read_radar_ref(mype,lunin,istart(mype+1),jstart(mype+1), & lon2,lat2,nmsclvl_radar,nsat1(is),ref_mosaic31) if(mype == 0) write(6,*) 'gsdcloudanalysis: ', & ' radar reflectivity is read in successfully' @@ -412,7 +418,7 @@ subroutine gsdcloudanalysis(mype) ! elseif( dtype(is)=='lghtn' ) then - call read_Lightning2cld(mype,lunin,regional_time,istart(mype+1),jstart(mype+1), & + call read_Lightning2cld(mype,lunin,istart(mype+1),jstart(mype+1), & lon2,lat2,nsat1(is),lightning) if(mype == 0) write(6,*) 'gsdcloudanalysis: Lightning is read in successfully' istat_lightning = 1 @@ -426,7 +432,7 @@ subroutine gsdcloudanalysis(mype) allocate(nasalarc_cld(lon2,lat2,5)) nasalarc_cld=miss_obs_real - call read_NASALaRC(mype,lunin,nsat1(is),regional_time,istart(mype+1), & + call read_NASALaRC(mype,lunin,nsat1(is),istart(mype+1), & jstart(mype+1),lon2,lat2,nasalarc_cld) if(mype == 0) write(6,*) 'gsdcloudanalysis:', & 'NASA LaRC cloud products are read in successfully' @@ -438,8 +444,8 @@ subroutine gsdcloudanalysis(mype) allocate(nasalarc_cld(lon2,lat2,5)) nasalarc_cld=miss_obs_real - call read_map_nasalarc(mype,lunin,nsat1(is),regional_time,istart(mype+1), & - jstart(mype+1),lon2,lat2,nasalarc_cld) + call read_map_nasalarc(mype,lunin,nsat1(is),istart(mype+1), & + jstart(mype+1),lon2,lat2,nasalarc_cld,ioption) if(mype == 0) write(6,*) 'gsdcloudanalysis:', & 'NASA LaRC global cloud products are read in successfully' istat_nasalarc = 1 @@ -699,7 +705,7 @@ subroutine gsdcloudanalysis(mype) if(istat_nesdis == 1 ) then call cloudCover_NESDIS(mype,regional_time,lat2,lon2,nsig, & - xlon,xlat,t_bk,p_bk,h_bk,zh,xland, & + xlon,xlat,t_bk,p_bk,h_bk,xland, & soiltbk,sat_ctp,sat_tem,w_frac, & l_cld_bld,cld_bld_hgt, & build_cloud_frac_p,clear_cloud_frac_p,nlev_cld, & @@ -711,8 +717,8 @@ subroutine gsdcloudanalysis(mype) ! for Rapid Refresh application, turn off the radar reflectivity impact ! on cloud distribution (Oct. 14, 2010) ! if(istat_radar == 1 .or. istat_lightning == 1 ) then -! call cloudCover_radar(mype,lat2,lon2,nsig,h_bk,zh,ref_mos_3d, & -! cld_cover_3d,cld_type_3d,wthr_type_2d) +! call cloudCover_radar(mype,lat2,lon2,nsig,h_bk,ref_mos_3d, & +! cld_cover_3d,wthr_type_2d) ! if(mype == 0) write(6,*) 'gsdcloudanalysis: ', & ! ' success in cloud cover analysis using radar data' ! endif @@ -809,37 +815,42 @@ subroutine gsdcloudanalysis(mype) do k=1,nsig do j=2,lat2-1 do i=2,lon2-1 - if( cld_cover_3d(i,j,k) > -0.001_r_kind ) then - if( cld_cover_3d(i,j,k) > 0.6_r_kind ) then ! build cloud -! mhu: Feb2017: set qnc=1e8 and qni=1e6 when build cloud - cloudwater=0.001_r_kind*cldwater_3d(i,j,k) - cloudice=0.001_r_kind*cldice_3d(i,j,k) - cldwater_3d(i,j,k) = max(cloudwater,ges_ql(j,i,k)) - cldice_3d(i,j,k) = max(cloudice,ges_qi(j,i,k)) - if(cloudwater > 1.0e-7_r_kind .and. cloudwater >= ges_ql(j,i,k)) then - nwater_3d(i,j,k) = 1.0E8_r_single - else - nwater_3d(i,j,k) = ges_qnc(j,i,k) - endif - if(cloudice > 1.0e-7_r_kind .and. cloudice >= ges_qi(j,i,k)) then - nice_3d(i,j,k) = 1.0E6_r_single - else - nice_3d(i,j,k) = ges_qni(j,i,k) - endif - !nwater_3d(i,j,k) = ((6. * rho_a * cldwater_3d(i,j,k)) / (pi * rho_w * cldDiameter)) /1000. - !Hong et al. 2004 - !nice_3d(i,j,k) = 5.38E7*((1.2754*cldice_3d(i,j,k))**0.75)*100.0 - else ! clean cloud - cldwater_3d(i,j,k) = zero - cldice_3d(i,j,k) = zero - nice_3d(i,j,k) = zero - nwater_3d(i,j,k) = zero + ! clean cloud + if( cld_cover_3d(i,j,k) > -0.001_r_kind .and. cld_cover_3d(i,j,k) <= cld_clr_coverage) then + cldwater_3d(i,j,k) = zero + cldice_3d(i,j,k) = zero + nice_3d(i,j,k) = zero + nwater_3d(i,j,k) = zero + clean_count = clean_count+1 + ! build cloud + elseif( cld_cover_3d(i,j,k) > cld_bld_coverage .and. cld_cover_3d(i,j,k) < 2.0_r_kind ) then + cloudwater =0.001_r_kind*cldwater_3d(i,j,k) + cloudice =0.001_r_kind*cldice_3d(i,j,k) + cldwater_3d(i,j,k) = max(cloudwater,ges_ql(j,i,k)) + cldice_3d(i,j,k) = max(cloudice,ges_qi(j,i,k)) + ! mhu: Feb2017: set qnc=1e8 and qni=1e6 when build cloud + if(cloudwater > 1.0e-7_r_kind .and. cloudwater >= ges_ql(j,i,k)) then + nwater_3d(i,j,k) = 1.0E8_r_single + else + nwater_3d(i,j,k) = ges_qnc(j,i,k) + endif + if(cloudice > 1.0e-7_r_kind .and. cloudice >= ges_qi(j,i,k)) then + nice_3d(i,j,k) = 1.0E6_r_single + else + nice_3d(i,j,k) = ges_qni(j,i,k) endif - else ! unknown, using background values + build_count=build_count+1 + ! unknown or partial cloud, using background values + else cldwater_3d(i,j,k) = ges_ql(j,i,k) - cldice_3d(i,j,k) = ges_qi(j,i,k) - nice_3d(i,j,k) = ges_qni(j,i,k) - nwater_3d(i,j,k) = ges_qnc(j,i,k) + cldice_3d(i,j,k) = ges_qi(j,i,k) + nice_3d(i,j,k) = ges_qni(j,i,k) + nwater_3d(i,j,k) = ges_qnc(j,i,k) + if( cld_cover_3d(i,j,k) > cld_clr_coverage ) then + part_count=part_count+1 + else + miss_count=miss_count+1 + endif endif end do end do @@ -858,7 +869,7 @@ subroutine gsdcloudanalysis(mype) ! 2013) ! - if(l_use_hydroretrieval_all) then + if(l_use_hydroretrieval_all) then !RTMA qrlimit=15.0_r_kind*0.001_r_kind do k=1,nsig do j=2,lat2-1 @@ -871,19 +882,15 @@ subroutine gsdcloudanalysis(mype) snow_3d(i,j,k) = ges_qs(j,i,k) graupel_3d(i,j,k) = ges_qg(j,i,k) if(ref_mos_3d(i,j,k) > zero ) then - snow_3d(i,j,k) = MIN(max(max(snowtemp,zero)*0.001_r_kind,ges_qs(j,i,k)),qrlimit) -! rain_3d(i,j,k) = MIN(max(max(raintemp,zero)*0.001_r_kind,ges_qr(j,i,k)),qrlimit) +! snow_3d(i,j,k) = MIN(max(max(snowtemp,zero)*0.001_r_kind,ges_qs(j,i,k)),qrlimit) + snow_3d(i,j,k) = MIN( max(snowtemp,zero)*0.001_r_kind ,qrlimit) raintemp = max(raintemp,zero)*0.001_r_kind - if(raintemp > ges_qr(j,i,k) ) then - if(raintemp <= qrlimit) then - rain_3d(i,j,k) = raintemp - nrain_3d(i,j,k)= nraintemp - else - rain_3d(i,j,k) = qrlimit - nrain_3d(i,j,k)= nraintemp*(qrlimit/raintemp) - endif + if(raintemp <= qrlimit) then + rain_3d(i,j,k) = raintemp + nrain_3d(i,j,k)= nraintemp else - rain_3d(i,j,k) = MIN(ges_qr(j,i,k),qrlimit) + rain_3d(i,j,k) = qrlimit + nrain_3d(i,j,k)= nraintemp*(qrlimit/raintemp) endif elseif( ref_mos_3d(i,j,k) <= zero .and. & ref_mos_3d(i,j,k) > -100.0_r_kind ) then @@ -900,126 +907,144 @@ subroutine gsdcloudanalysis(mype) end do end do end do - else ! hydrometeor anlysis for RAP forecast - qrlimit=3.0_r_kind*0.001_r_kind - qrlimit_lightpcp=1.0_r_kind*0.001_r_kind - do j=2,lat2-1 - do i=2,lon2-1 - refmax=-999.0_r_kind - imaxlvl_ref=0 - do k=1,nsig - if(ref_mos_3d(i,j,k) > refmax) then - imaxlvl_ref=k - refmax=ref_mos_3d(i,j,k) - endif - rain_3d(i,j,k)=max(rain_3d(i,j,k)*0.001_r_kind,zero) - snow_3d(i,j,k)=max(snow_3d(i,j,k)*0.001_r_kind,zero) - rain_1d_save(k)=rain_3d(i,j,k) - snow_1d_save(k)=snow_3d(i,j,k) - nrain_1d_save(k)=nrain_3d(i,j,k) -! ges_qnr(i,j,k)=max(ges_qnr(i,j,k),zero) - enddo - if( refmax > 0 .and. (imaxlvl_ref > 0 .and. imaxlvl_ref < nsig ) ) then ! use retrieval hybrometeors - tsfc=t_bk(i,j,1)*(p_bk(i,j,1)/h1000)**rd_over_cp - 273.15_r_kind - if(tsfc < r_cleanSnow_WarmTs_threshold) then ! add snow on cold sfc - do k=1,nsig - snowtemp=snow_3d(i,j,k) + elseif(l_precip_clear_only) then !only clear for HRRRE + do k=1,nsig + do j=2,lat2-1 + do i=2,lon2-1 + if( ref_mos_3d(i,j,k) <= zero .and. ref_mos_3d(i,j,k) > -100.0_r_kind ) then + rain_3d(i,j,k) = zero + nrain_3d(i,j,k) = zero + snow_3d(i,j,k) = zero + graupel_3d(i,j,k) = zero + else rain_3d(i,j,k) = ges_qr(j,i,k) nrain_3d(i,j,k)= ges_qnr(j,i,k) snow_3d(i,j,k) = ges_qs(j,i,k) graupel_3d(i,j,k) = ges_qg(j,i,k) - if(ref_mos_3d(i,j,k) > zero ) then - snowtemp = MIN(max(snowtemp,ges_qs(j,i,k)),qrlimit) - snowadd = max(snowtemp - snow_3d(i,j,k),zero) - snow_3d(i,j,k) = snowtemp - raintemp=rain_3d(i,j,k) + graupel_3d(i,j,k) - if(raintemp > snowadd ) then - if(raintemp > 1.0e-6_r_kind) then - ratio2=1.0_r_kind - snowadd/raintemp - rain_3d(i,j,k) = rain_3d(i,j,k) * ratio2 - graupel_3d(i,j,k) = graupel_3d(i,j,k) * ratio2 - endif - else - rain_3d(i,j,k) = 0.0_r_kind - graupel_3d(i,j,k) = 0.0_r_kind - endif - endif - end do - else ! adjust hydrometeors based on maximum reflectivity level - max_retrieved_qrqs=snow_3d(i,j,imaxlvl_ref)+rain_3d(i,j,imaxlvl_ref) - max_bk_qrqs=-999.0_r_kind - do k=1,nsig - if(ges_qr(j,i,k)+ges_qs(j,i,k) > max_bk_qrqs) then - max_bk_qrqs = ges_qr(j,i,k)+ges_qs(j,i,k) - endif - enddo - if( max_bk_qrqs > max_retrieved_qrqs) then ! tune background hyhro - ratio_hyd_bk2obs=max(min(max_retrieved_qrqs/max_bk_qrqs,1.0_r_kind),0.0_r_kind) + endif + enddo + enddo + enddo + else ! hydrometeor anlysis for RAP forecast + qrlimit=3.0_r_kind*0.001_r_kind + qrlimit_lightpcp=1.0_r_kind*0.001_r_kind + do j=2,lat2-1 + do i=2,lon2-1 + refmax=-999.0_r_kind + imaxlvl_ref=0 + do k=1,nsig + if(ref_mos_3d(i,j,k) > refmax) then + imaxlvl_ref=k + refmax=ref_mos_3d(i,j,k) + endif + rain_3d(i,j,k)=max(rain_3d(i,j,k)*0.001_r_kind,zero) + snow_3d(i,j,k)=max(snow_3d(i,j,k)*0.001_r_kind,zero) + rain_1d_save(k)=rain_3d(i,j,k) + snow_1d_save(k)=snow_3d(i,j,k) + nrain_1d_save(k)=nrain_3d(i,j,k) +! ges_qnr(i,j,k)=max(ges_qnr(i,j,k),zero) + enddo + if( refmax > 0 .and. (imaxlvl_ref > 0 .and. imaxlvl_ref < nsig ) ) then ! use retrieval hybrometeors + tsfc=t_bk(i,j,1)*(p_bk(i,j,1)/h1000)**rd_over_cp - 273.15_r_kind + if(tsfc < r_cleanSnow_WarmTs_threshold) then ! add snow on cold sfc do k=1,nsig - graupel_3d(i,j,k) = ges_qg(j,i,k) + snowtemp=snow_3d(i,j,k) rain_3d(i,j,k) = ges_qr(j,i,k) nrain_3d(i,j,k)= ges_qnr(j,i,k) snow_3d(i,j,k) = ges_qs(j,i,k) - if(ges_qr(j,i,k) > zero) then - rain_3d(i,j,k) = ges_qr(j,i,k)*ratio_hyd_bk2obs - nrain_3d(i,j,k)= ges_qnr(j,i,k)*ratio_hyd_bk2obs - endif - if(ges_qs(j,i,k) > zero) & - snow_3d(i,j,k) = ges_qs(j,i,k)*ratio_hyd_bk2obs - enddo - else ! use hydro in max refl level - do k=1,nsig graupel_3d(i,j,k) = ges_qg(j,i,k) - if(k==imaxlvl_ref) then - snow_3d(i,j,k) = MIN(snow_3d(i,j,k),qrlimit) - rain_3d(i,j,k) = MIN(rain_3d(i,j,k),qrlimit) ! do we need qrlimit? - nrain_3d(i,j,k) = nrain_3d(i,j,k) - else - rain_3d(i,j,k) = ges_qr(j,i,k) - snow_3d(i,j,k) = ges_qs(j,i,k) - nrain_3d(i,j,k) = ges_qnr(j,i,k) + if(ref_mos_3d(i,j,k) > zero ) then + snowtemp = MIN(max(snowtemp,ges_qs(j,i,k)),qrlimit) + snowadd = max(snowtemp - snow_3d(i,j,k),zero) + snow_3d(i,j,k) = snowtemp + raintemp=rain_3d(i,j,k) + graupel_3d(i,j,k) + if(raintemp > snowadd ) then + if(raintemp > 1.0e-6_r_kind) then + ratio2=1.0_r_kind - snowadd/raintemp + rain_3d(i,j,k) = rain_3d(i,j,k) * ratio2 + graupel_3d(i,j,k) = graupel_3d(i,j,k) * ratio2 + endif + else + rain_3d(i,j,k) = 0.0_r_kind + graupel_3d(i,j,k) = 0.0_r_kind + endif endif end do - endif - if(i_lightpcp == 1) then -! keep light precipitation between 28-15 dBZ + else ! adjust hydrometeors based on maximum reflectivity level + max_retrieved_qrqs=snow_3d(i,j,imaxlvl_ref)+rain_3d(i,j,imaxlvl_ref) + max_bk_qrqs=-999.0_r_kind do k=1,nsig - if(ref_mos_3d(i,j,k) >=15.0_r_single .and. & - ref_mos_3d(i,j,k) <=28.0_r_single ) then - rain_3d(i,j,k) = max(min(rain_1d_save(k),qrlimit_lightpcp),rain_3d(i,j,k)) - snow_3d(i,j,k) = max(min(snow_1d_save(k),qrlimit_lightpcp),snow_3d(i,j,k)) - nrain_3d(i,j,k)= max(nrain_1d_save(k),nrain_3d(i,j,k)) + if(ges_qr(j,i,k)+ges_qs(j,i,k) > max_bk_qrqs) then + max_bk_qrqs = ges_qr(j,i,k)+ges_qs(j,i,k) endif - enddo ! light pcp + enddo + if( max_bk_qrqs > max_retrieved_qrqs) then ! tune background hyhro + ratio_hyd_bk2obs=max(min(max_retrieved_qrqs/max_bk_qrqs,1.0_r_kind),0.0_r_kind) + do k=1,nsig + graupel_3d(i,j,k) = ges_qg(j,i,k) + rain_3d(i,j,k) = ges_qr(j,i,k) + nrain_3d(i,j,k)= ges_qnr(j,i,k) + snow_3d(i,j,k) = ges_qs(j,i,k) + if(ges_qr(j,i,k) > zero) then + rain_3d(i,j,k) = ges_qr(j,i,k)*ratio_hyd_bk2obs + nrain_3d(i,j,k)= ges_qnr(j,i,k)*ratio_hyd_bk2obs + endif + if(ges_qs(j,i,k) > zero) & + snow_3d(i,j,k) = ges_qs(j,i,k)*ratio_hyd_bk2obs + enddo + else ! use hydro in max refl level + do k=1,nsig + graupel_3d(i,j,k) = ges_qg(j,i,k) + if(k==imaxlvl_ref) then + snow_3d(i,j,k) = MIN(snow_3d(i,j,k),qrlimit) + rain_3d(i,j,k) = MIN(rain_3d(i,j,k),qrlimit) ! do we need qrlimit? + nrain_3d(i,j,k) = nrain_3d(i,j,k) + else + rain_3d(i,j,k) = ges_qr(j,i,k) + snow_3d(i,j,k) = ges_qs(j,i,k) + nrain_3d(i,j,k) = ges_qnr(j,i,k) + endif + end do + endif + if(i_lightpcp == 1) then +! keep light precipitation between 28-15 dBZ + do k=1,nsig + if(ref_mos_3d(i,j,k) >=15.0_r_single .and. & + ref_mos_3d(i,j,k) <=28.0_r_single ) then + rain_3d(i,j,k) = max(min(rain_1d_save(k),qrlimit_lightpcp),rain_3d(i,j,k)) + snow_3d(i,j,k) = max(min(snow_1d_save(k),qrlimit_lightpcp),snow_3d(i,j,k)) + nrain_3d(i,j,k)= max(nrain_1d_save(k),nrain_3d(i,j,k)) + endif + enddo ! light pcp + endif endif - endif - else ! clean if ref=0 or use background hydrometeors - do k=1,nsig - rain_3d(i,j,k) = ges_qr(j,i,k) - nrain_3d(i,j,k)= ges_qnr(j,i,k) - snow_3d(i,j,k) = ges_qs(j,i,k) - graupel_3d(i,j,k) = ges_qg(j,i,k) - if((iclean_hydro_withRef==1)) then - if( iclean_hydro_withRef_allcol==1 .and. & - (refmax <= zero .and. refmax >= -100_r_kind) .and. & - (sat_ctp(i,j) >=1010.0_r_kind .and. sat_ctp(i,j) <1050._r_kind)) then - rain_3d(i,j,k) = zero - nrain_3d(i,j,k)= zero - snow_3d(i,j,k) = zero - graupel_3d(i,j,k) = zero - else - if((ref_mos_3d(i,j,k) <= zero .and. & - ref_mos_3d(i,j,k) > -100.0_r_kind)) then + else ! clean if ref=0 or use background hydrometeors + do k=1,nsig + rain_3d(i,j,k) = ges_qr(j,i,k) + nrain_3d(i,j,k)= ges_qnr(j,i,k) + snow_3d(i,j,k) = ges_qs(j,i,k) + graupel_3d(i,j,k) = ges_qg(j,i,k) + if((iclean_hydro_withRef==1)) then + if( iclean_hydro_withRef_allcol==1 .and. & + (refmax <= zero .and. refmax >= -100_r_kind) .and. & + (sat_ctp(i,j) >=1010.0_r_kind .and. sat_ctp(i,j) <1050._r_kind)) then rain_3d(i,j,k) = zero nrain_3d(i,j,k)= zero snow_3d(i,j,k) = zero graupel_3d(i,j,k) = zero + else + if((ref_mos_3d(i,j,k) <= zero .and. & + ref_mos_3d(i,j,k) > -100.0_r_kind)) then + rain_3d(i,j,k) = zero + nrain_3d(i,j,k)= zero + snow_3d(i,j,k) = zero + graupel_3d(i,j,k) = zero + endif endif endif - endif - end do - endif - end do + end do + endif + end do end do endif ! @@ -1074,26 +1099,28 @@ subroutine gsdcloudanalysis(mype) ! call cloud_saturation(mype,l_conserve_thetaV,i_conserve_thetaV_iternum, & lat2,lon2,nsig,q_bk,t_bk,p_bk, & - cld_cover_3d,wthr_type_2d,cldwater_3d,cldice_3d,sumqci) + cld_cover_3d,wthr_type_2d,cldwater_3d,cldice_3d,sumqci,qv_max_inc) + ! ! add fog (12/08/2015) ! - do j=2,lat2-1 - do i=2,lon2-1 - if( vis2qc(i,j) > zero ) then - - do k=1,2 - Temp = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp - watwgt = max(0._r_kind,min(1._r_kind,(Temp-263.15_r_kind)/& + if (.not. l_fog_off) then + do j=2,lat2-1 + do i=2,lon2-1 + if( vis2qc(i,j) > zero ) then + do k=1,2 + Temp = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + watwgt = max(0._r_kind,min(1._r_kind,(Temp-263.15_r_kind)/& (268.15_r_kind - 263.15_r_kind))) - cldwater_3d(i,j,k) = max(watwgt*vis2qc(i,j),cldwater_3d(i,j,k)) - cldice_3d(i,j,k) = max((1.0_r_single-watwgt)*vis2qc(i,j),cldice_3d(i,j,k)) - enddo - endif - end do - end do -! + cldwater_3d(i,j,k) = max(watwgt*vis2qc(i,j),cldwater_3d(i,j,k)) + cldice_3d(i,j,k) = max((1.0_r_single-watwgt)*vis2qc(i,j),cldice_3d(i,j,k)) + enddo + endif + enddo + enddo + endif + ! ! call check_cloud(mype,lat2,lon2,nsig,q_bk,rain_3d,snow_3d,graupel_3d, & ! cldwater_3d,cldice_3d,t_bk,p_bk,h_bk, & @@ -1158,6 +1185,7 @@ subroutine gsdcloudanalysis(mype) deallocate(sat_ctp,sat_tem,w_frac,nlev_cld) deallocate(ref_mos_3d,ref_mos_3d_tten,lightning) + write(*,*) "CLDcount", clean_count,build_count,part_count,miss_count if(mype==0) then write(6,*) '========================================' write(6,*) 'gsdcloudanalysis: generalized cloud analysis finished:',mype diff --git a/src/gsdcloudanalysis4NMMB.F90 b/src/gsi/gsdcloudanalysis4NMMB.F90 similarity index 99% rename from src/gsdcloudanalysis4NMMB.F90 rename to src/gsi/gsdcloudanalysis4NMMB.F90 index d709d24ea..21040ed64 100644 --- a/src/gsdcloudanalysis4NMMB.F90 +++ b/src/gsi/gsdcloudanalysis4NMMB.F90 @@ -77,7 +77,8 @@ SUBROUTINE gsdcloudanalysis4NMMB(mype) nesdis_npts_rad, & l_use_hydroretrieval_all, & iclean_hydro_withRef, & - iclean_hydro_withRef_allcol + iclean_hydro_withRef_allcol, & + ioption use gsi_metguess_mod, only: GSI_MetGuess_Bundle use gsi_metguess_mod, only: GSI_MetGuess_get use gsi_bundlemod, only: gsi_bundlegetpointer @@ -420,7 +421,7 @@ SUBROUTINE gsdcloudanalysis4NMMB(mype) 'start to read NESDIS cloud products' call read_NESDIS(mype,lunin,nsat1(is),regional_time,istart(mype+1), & - jstart(mype+1),lon2,lat2,sat_ctp,sat_tem,w_frac) + jstart(mype+1),lon2,lat2,sat_ctp,sat_tem,w_frac,ioption) sat_ctp_nesdis=sat_ctp sat_tem_nesdis=sat_tem w_frac_nesdis=w_frac @@ -1192,5 +1193,10 @@ SUBROUTINE gsdcloudanalysis4NMMB(mype) use kinds, only: i_kind implicit none integer(i_kind),intent(in) :: mype + +if(mype==0) then + write(*,*) 'dummy subroutine gsdcloudanalysis4NMMB' +endif + END SUBROUTINE gsdcloudanalysis4NMMB #endif /* End no NNMB cloud analysis library block */ diff --git a/src/gsdcloudanalysis4gfs.F90 b/src/gsi/gsdcloudanalysis4gfs.F90 similarity index 99% rename from src/gsdcloudanalysis4gfs.F90 rename to src/gsi/gsdcloudanalysis4gfs.F90 index 0d4c549ab..74c38d6a2 100644 --- a/src/gsdcloudanalysis4gfs.F90 +++ b/src/gsi/gsdcloudanalysis4gfs.F90 @@ -74,7 +74,7 @@ subroutine gsdcloudanalysis4gfs(mype) build_cloud_frac_p, clear_cloud_frac_p, & nesdis_npts_rad, & iclean_hydro_withRef, iclean_hydro_withRef_allcol, & - i_lightpcp,i_gsdcldanal_type + i_lightpcp,i_gsdcldanal_type,ioption use gsi_metguess_mod, only: GSI_MetGuess_Bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -420,7 +420,7 @@ subroutine gsdcloudanalysis4gfs(mype) elseif( dtype(is) == 'gos_ctp' ) then call read_NESDIS(mype,lunin,nsat1(is),regional_time,istart(mype+1), & - jstart(mype+1),lon2,lat2,sat_ctp,sat_tem,w_frac,nesdis_npts_rad) + jstart(mype+1),lon2,lat2,sat_ctp,sat_tem,w_frac,nesdis_npts_rad,ioption) if(mype == 0) write(6,*) 'gsdcloudanalysis: ', & 'NESDIS cloud products are read in successfully' istat_nesdis = 1 @@ -458,7 +458,7 @@ subroutine gsdcloudanalysis4gfs(mype) nasalarc_cld=miss_obs_real call read_map_nasalarc(mype,lunin,nsat1(is),regional_time,istart(mype+1), & - jstart(mype+1),lon2,lat2,nasalarc_cld) + jstart(mype+1),lon2,lat2,nasalarc_cld,ioption) if(mype == 0) write(6,*) 'gsdcloudanalysis:', & 'NASA LaRC cloud products are read in successfully', & mype @@ -713,7 +713,7 @@ subroutine gsdcloudanalysis4gfs(mype) enddo if(i_gsdcldanal_type==30) then - call BackgroundCldgfs(mype,lon2,lat2,nsig,t_bk,p_bk,ps_bk,q_bk,h_bk,zh) + call BackgroundCldgfs(mype,lon2,lat2,nsig,t_bk,p_bk,ps_bk,q_bk,h_bk) else call BackgroundCld(mype,lon2,lat2,nsig,t_bk,p_bk,ps_bk,q_bk,h_bk, & zh,pt_ll,eta1_ll,aeta1_ll,regional,wrf_mass_regional) @@ -782,7 +782,7 @@ subroutine gsdcloudanalysis4gfs(mype) if(istat_nesdis == 1 ) then call cloudCover_NESDIS(mype,regional_time,lat2,lon2,nsig, & - xlon,xlat,t_bk,p_bk,h_bk,zh,xland, & + xlon,xlat,t_bk,p_bk,h_bk,xland, & soiltbk,sat_ctp,sat_tem,w_frac, & l_cld_bld,cld_bld_hgt, & build_cloud_frac_p,clear_cloud_frac_p,nlev_cld, & diff --git a/src/gsi/gsdcloudlib_pseudoq_mod.f90 b/src/gsi/gsdcloudlib_pseudoq_mod.f90 new file mode 100644 index 000000000..5afba7045 --- /dev/null +++ b/src/gsi/gsdcloudlib_pseudoq_mod.f90 @@ -0,0 +1,448 @@ +module gsdcloudlib_pseudoq_mod +!$$$ module documentation block +! . . . . +! module: gsdcloudlib_pseudoq_mod contains cloud analysis subroutines +! for generating pseudo moisture +! prgmmr: Ming Hu org: GSD date: 2019-05-29 +! +! abstract: contains routines for generating pseudo moisture +! +! program history log: +! 2005-01-22 Hu +! +! subroutines included: +! sub create_balance_vars - create arrays for balance vars +! sub destroy_balance_vars - remove arrays for balance vars +! +! Variable Definitions: +! +! attributes: +! language: f90 +! machine: JET +! +!$$$ end documentation block + + implicit none + +! set default to private + private +! set subroutines to public + public :: cloudCover_Surface_col + public :: cloudLWC_pseudo + +contains + +SUBROUTINE cloudCover_Surface_col(mype,nsig,& + cld_bld_hgt,h_bk,zh, & + NVARCLD_P,ocld,Oelvtn,& + wthr_type,pcp_type_obs, & + vis2qc,cld_cover_obs) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_Surface_col cloud cover analysis for a column using surface observation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine determines cloud fractional cover using surface observations +! For each vertical column +! Code based on RUC assimilation code (hybfront/hybcloud.f) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2017-19 Ladwig adaptation for columns +! +! +! input argument list: +! mype - processor ID +! nsig - no. of levels +! cld_bld_hgt - Height below which cloud building is done +! +! h_bk - 3D background height (m) +! zh - terrain (m) +! +! NVARCLD_P - first dimension of OCLD +! OCLD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! +! output argument list: +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! pcp_type_3d - 3D weather precipitation type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: nsig + real(r_kind), intent(in) :: cld_bld_hgt +! +! surface observation +! + INTEGER(i_kind),intent(in) :: NVARCLD_P + INTEGER(i_kind),intent(in) :: OCLD(NVARCLD_P) ! cloud amount, cloud height, visibility + real(r_single), intent(in) :: Oelvtn ! elevation + integer(i_kind), intent(inout) :: wthr_type +! +! background +! + real(r_kind),intent(in) :: zh ! terrain + real(r_kind),intent(in) :: h_bk(nsig) ! height +! +! Variables for cloud analysis +! + integer(i_kind),intent(inout) :: pcp_type_obs(nsig) + real (r_single),intent(inout) :: vis2qc + real (r_single),intent(inout) :: cld_cover_obs(nsig) +! +! local +! + real (r_single) :: cloud_zthick_p + data cloud_zthick_p /30._r_kind/ +! + INTEGER(i_kind) :: k + INTEGER(i_kind) :: ic + integer(i_kind) :: firstcloud,cl_base_broken_k,obused + integer(i_kind) :: kcld + real(r_single) :: underlim + REAL(r_kind) :: zdiff + REAL(r_kind) :: zlev_clr,cloud_dz,cl_base_ista,betav + + +!==================================================================== +! Begin +! +! set constant names consistent with original RUC code +! + vis2qc=-9999.0_r_single + zlev_clr = 3650._r_kind + firstcloud = 0 + obused =0 + kcld=-9 +! +!***************************************************************** +! analysis of surface/METAR cloud observations +! ***************************************************************** + +! Consider clear condition case +! ----------------------------- + if (ocld(1)==0) then + + !QC, make sure clear ob has missing for the rest of the layers + do ic=1,6 + if(real(abs(ocld(6+ic)),r_kind) < 55555.0_r_kind) then + write(6,*) 'cloudCover_Surface: Observed cloud above the clear level !!!' + write(6,*) 'cloudCover_Surface: some thing is wrong in surface cloud observation !' + write(6,*) 'cloudCover_Surface: check the station no.', 'at process ', mype + write(6,*) ic + write(6,*) (ocld(k),k=1,12) + call stop2(114) + endif + enddo + +! -- Now consider non-clear obs +! -------------------------- + else + + ! legacy - increase zthick by 1.5x factor for ceiling < 900 m (~3000 ft - MVFR) + cloud_dz = cloud_zthick_p + cl_base_broken_k = -9 + + do ic = 1,6 + if (obused == 0) then + if (ocld(ic)>0 .and. ocld(ic)<50) then + if(ocld(ic) == 4) then + if(wthr_type > 10 .and. wthr_type < 20) cloud_dz = 1000._r_kind + ! precipitation + highest level + if(wthr_type == 1) cloud_dz = 10000._r_kind ! thunderstorm + endif + + ! convert cloud base observation from AGL to ASL + cl_base_ista = float(ocld(6+ic)) + Oelvtn - zh + if(zh < 1.0_r_kind .and. Oelvtn > 20.0_r_kind & + .and. float(ocld(6+ic)) < 250.0_r_kind) then + cycle ! limit the use of METAR station over oceas for low cloud base + endif + + firstcloud = 0 + underlim = 10._r_kind ! + + do k=1,nsig + if (firstcloud==0) then + zdiff = cl_base_ista - h_bk(k) +! Must be within cloud_dz meters (300 or 1000 currently) +! ------------------------------------------------------------------- +! -- Bring in the clouds if model level is within 10m under cloud level. + if(k==1) underlim=(h_bk(k+1)-h_bk(k))*0.5_r_kind + if(k==2) underlim=10.0_r_kind ! 100 feet + if(k==3) underlim=20.0_r_kind ! 300 feet + if(k==4) underlim=15.0_r_kind ! 500 feet + if(k==5) underlim=33.0_r_kind ! 1000 feet + if (k>=6 .and. k <= 7) underlim = (h_bk(k+1)-h_bk(k))*0.6_r_kind + if(k==8) underlim=95.0_r_kind ! 3000 feet + if(k>=9 .and. k= 1.0_r_kind .and. (firstcloud==0 .or. abs(zdiff) 10 .and. wthr_type < 20) then + pcp_type_obs(k)=1 + endif + else + write(6,*) 'cloudCover_Surface: wrong cloud coverage observation!' + call stop2(114) + endif !ocld values + endif ! below cld_bld_hgt + kcld=k + firstcloud = firstcloud + 1 + endif ! zdiff < cloud_dz + endif ! underlim + endif ! firstcloud + enddo ! end K loop + + endif ! end if ocld valid + endif ! obused + enddo ! end IC loop + endif ! end if cloudy ob + +! -- Use visibility for low-level cloud whether + if (wthr_type < 30 .and. wthr_type > 20 .and. & + ocld(13) < 5000 .and. ocld(13) > 1 ) then + betav = 3.912_r_kind / (float(ocld(13)) / 1000._r_kind) + vis2qc = ( (betav/144.7_r_kind) ** 1.14_r_kind) / 1000._r_kind + endif ! cloud or clear + +END SUBROUTINE cloudCover_Surface_col + + +SUBROUTINE cloudLWC_pseudo(nsig,q_bk,t_bk,p_bk, & + cld_cover_obs, & + cldwater_obs,cldice_obs) +! +! find cloud liquid water content +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLWC_pseudo find cloud liquid water content +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculate liquid water content for stratiform cloud +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2017-19 Ladwig Adapt for pseudo obs +! +! +! input argument list: +! mype - processor ID +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! cld_cover_obs- vertical column of cloud cover +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cldwater_obs - vertical column cloud water mixing ratio (g/kg) +! cldice_obs - vertical column cloud ice mixing ratio (g/kg) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: nsig +! +! background +! + real(r_kind),intent(in) :: t_bk(nsig) ! potential temperature + real(r_kind),intent(inout) :: q_bk(nsig) ! mixing ratio (kg/kg) + real(r_kind),intent(in) :: p_bk(nsig) ! pressure +! +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_obs(nsig) +! +! cloud water and cloud ice +! + real (r_single),intent(out) :: cldwater_obs(nsig) + real (r_single),intent(out) :: cldice_obs(nsig) + real (r_single) :: cloudtmp_obs(nsig) +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: k + real(r_single) :: p_pa_1d(nsig), thv(nsig) + real(r_single) :: cloudqvis(nsig) + real(r_single) :: rh(nsig) + +! --- Key parameters +! Rh_clear_p = 0.80 RH to use when clearing cloud +! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice + + real(r_single) Cloud_q_qvis_rat_p, cloud_q_qvis_ratio + real(r_single) auto_conver + data Cloud_q_qvis_rat_p/ 0.05_r_single/ + data auto_conver /0.0002_r_single/ + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + real(r_kind) :: temp_qvis1, temp_qvis2 + data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ + + REAL(r_kind) stab, stab_threshold + INTEGER(i_kind) :: kp3,km3 + + REAL(r_kind) :: Temp, evs, qvs1, eis, qvi1, watwgt, qavail +! +!==================================================================== +! Begin +! + cldwater_obs=-99999.9_r_kind + cldice_obs=-99999.9_r_kind + cloudtmp_obs=-99999.9_r_kind + rh=0.0_r_single + stab_threshold = 3._r_kind/10000._r_kind +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + !VIRTUAL POTENTIAL TEMP + do k = 1,nsig + thv(k) = (t_bk(k)*(100._r_single/p_bk(k))**rd_over_cp)*(1.0_r_single + 0.6078_r_single*q_bk(k)) + !p_pa1d is pressure in pascal + p_pa_1d(k) = p_bk(k)*1000.0_r_single + enddo + + + do k = 2,nsig-1 + + if (cld_cover_obs(k) <= -0.001_r_kind) then + cycle + elseif (cld_cover_obs(k) > -0.001_r_kind .and. cld_cover_obs(k) < 0.001_r_kind) then + cldwater_obs(k) = 0.0_r_kind + cldice_obs(k)= 0.0_r_kind + ! non-var analysis also clears for partial cloud, changes will be considered for this case + elseif (cld_cover_obs(k) > 0.001_r_kind .and. cld_cover_obs(k) < 0.6_r_kind ) then + cldwater_obs(k) = 0.0_r_kind + cldice_obs(k)= 0.0_r_kind + elseif (cld_cover_obs(k) >= 0.6_r_kind .and. cld_cover_obs(k) < 1.5_r_kind) then + !t_bk is sensible temp + Temp=t_bk(k) + + ! evs, eis in mb + evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) + qvs1 = 0.62198_r_kind*evs*100._r_kind/(p_pa_1d(k)-100._r_kind*evs) ! qvs1 is mixing ratio kg/kg, so no need next line + eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) + qvi1 = 0.62198_r_kind*eis*100._r_kind/(p_pa_1d(k)-100._r_kind*eis) ! qvi1 is mixing ratio kg/kg, so no need next line + ! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 + watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + cloudtmp_obs(k)= Temp + cloudqvis(k)= (watwgt*qvs1 + (1._r_kind-watwgt)*qvi1) + rh(k) = q_bk(k)/cloudqvis(k) + + ! STABILITY CHECK, used in RUC keep it for now + ! -- change these to +/- 3 vertical levels + kp3 = min(nsig,k+5) + km3 = max(1 ,k) + stab = (thv(kp3)-thv(km3))/(p_pa_1d(km3)-p_pa_1d(kp3)) + + ! -- stability check. Use 2K/100 mb above 600 mb and + ! 3K/100mb below (nearer sfc) + if ((stab600._r_kind) & + .or. stab<0.66_r_kind*stab_threshold ) then + cld_cover_obs(k)=-9999.0_r_single + elseif(rh(k) < 0.40_r_single .and. ((cloudqvis(k)-q_bk(k)) > 0.003_r_kind)) then + cld_cover_obs(k)=-9999.0_r_single + else + !dk * we need to avoid adding cloud if sat_ctp is lower than 650mb + ! ph - 2/7/2012 - use a temperature-dependent cloud_q_qvis_ratio + ! and with 0.1 smaller condensate mixing ratio building also for temp < 263.15 + Temp = cloudtmp_obs(k) + watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + cloud_q_qvis_ratio = watwgt*cloud_q_qvis_rat_p & + + (1.0_r_single-watwgt)*0.1_r_single*cloud_q_qvis_rat_p + qavail = min(0.5_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(k)) + + !------------------------------------------------------------------- + ! - set cloud water mixing ratio - no more than 0.1 g/kg, + ! which is the current autoconversion mixing ratio set in exmoisg + ! according to John Brown - 14 May 99 + !------------------------------------------------------------------- + cldwater_obs(k) = watwgt*qavail*1000.0_r_kind ! g/kg + ! - set ice mixing ratio + cldice_obs(k)= (1.-watwgt)*qavail*1000.0_r_kind ! g/kg + end if + else + write(*,*) 'WARNING, cld_cover_obs outside of known ranges.', cld_cover_obs(k) + endif + enddo ! k + +END SUBROUTINE cloudLWC_pseudo + +end module gsdcloudlib_pseudoq_mod diff --git a/src/gsi_4dcouplermod.f90 b/src/gsi/gsi_4dcouplermod.f90 similarity index 100% rename from src/gsi_4dcouplermod.f90 rename to src/gsi/gsi_4dcouplermod.f90 diff --git a/src/gsi_4dvar.f90 b/src/gsi/gsi_4dvar.f90 similarity index 93% rename from src/gsi_4dvar.f90 rename to src/gsi/gsi_4dvar.f90 index f5531c676..d955bd57d 100644 --- a/src/gsi_4dvar.f90 +++ b/src/gsi/gsi_4dvar.f90 @@ -24,6 +24,7 @@ module gsi_4dvar ! 2015-02-23 Rancic/Thomas - iwinbgn changed from hours to mins, added thin4d ! option to remove thinning in time ! 2015-10-01 Guo - trigger for redistribution of obs when applicable +! 2017-05-06 todling - add tau_fcst to determine EFSOI-like calculation ! ! Subroutines Included: ! sub init_4dvar - @@ -82,6 +83,8 @@ module gsi_4dvar ! will be set to center of window for 4D-ens mode ! lwrite4danl - logical to turn on writing out of 4D analysis state for 4D analysis modes ! ** currently only set up for write_gfs in ncepgfs_io module +! nhr_anal - forecast times to output if lwrite4danl=T. if zero, output all times (default). +! if > 0, output specific fcst time given by nhr_anal ! thin4d - When .t., removes thinning of observations due to ! location in the time window ! @@ -112,8 +115,12 @@ module gsi_4dvar public :: ladtest,ladtest_obs,lgrtest,lcongrad,nhr_obsbin,nhr_subwin,nwrvecs public :: jsiga,ltcost,iorthomax,liauon,lnested_loops public :: l4densvar,ens_nhr,ens_fhrlevs,ens_nstarthr,ibin_anl - public :: lwrite4danl,thin4d + public :: lwrite4danl,thin4d,nhr_anal public :: mPEs_observer + public :: tau_fcst + public :: efsoi_order + public :: efsoi_afcst + public :: efsoi_ana logical :: l4dvar logical :: lsqrtb @@ -132,6 +139,10 @@ module gsi_4dvar logical :: lnested_loops logical :: lwrite4danl logical :: thin4d + logical :: efsoi_afcst + logical :: efsoi_ana + + integer(i_kind),dimension(21) :: nhr_anal integer(i_kind) :: iwrtinc integer(i_kind) :: iadatebgn, iadateend @@ -144,6 +155,8 @@ module gsi_4dvar integer(i_kind) :: jsiga integer(i_kind) :: ens_nhr,ens_nstarthr,ibin_anl integer(i_kind),allocatable,dimension(:) :: ens_fhrlevs + integer(i_kind) :: tau_fcst + integer(i_kind) :: efsoi_order integer(i_kind),save:: mPEs_observer=0 @@ -210,6 +223,14 @@ subroutine init_4dvar () lwrite4danl = .false. thin4d = .false. +! if zero, output all times. +! if > 0, output specific fcst time given by nhr_anal +nhr_anal = 0 + +tau_fcst = -1 ! ensemble of forecast at hour current+tau_fcst +efsoi_order = 1 ! order of appox used in EFSOI-like settings +efsoi_afcst = .false. ! internal EFSOI-like parameter (NEVER to be in namelist) +efsoi_ana = .false. ! internal EFSOI-like parameter (NEVER to be in namelist) end subroutine init_4dvar ! -------------------------------------------------------------------- @@ -380,6 +401,7 @@ subroutine setup_4dvar(mype) write(6,*)'SETUP_4DVAR: liauon=',liauon write(6,*)'SETUP_4DVAR: ljc4tlevs=',ljc4tlevs write(6,*)'SETUP_4DVAR: ibin_anl=',ibin_anl + write(6,*)'SETUP_4DVAR: tau_fcst=',tau_fcst endif end subroutine setup_4dvar diff --git a/src/gsi/gsi_aeroOper.F90 b/src/gsi/gsi_aeroOper.F90 new file mode 100644 index 000000000..05ca0bd83 --- /dev/null +++ b/src/gsi/gsi_aeroOper.F90 @@ -0,0 +1,156 @@ +module gsi_aeroOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_aeroOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for aeroNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use aero_setup, only: setup + use m_aeroNode, only: aeroNode + use intaodmod , only: intjo => intaod + use stpaodmod , only: stpjo => stpaod + implicit none + public:: aeroOper ! data stracture + + type,extends(obOper):: aeroOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type aeroOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_aeroOper' + type(aeroNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[aeroOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use obsmod , only: write_diag + use aeroinfo, only: diag_aero + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(aeroOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + + diagsave = write_diag(jiter) .and. diag_aero + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,nchanl,nreal,nobs,obstype,isis,is,diagsave,init_pass) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(aeroOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(aeroOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_aeroOper diff --git a/src/gsi_bias.f90 b/src/gsi/gsi_bias.f90 similarity index 100% rename from src/gsi_bias.f90 rename to src/gsi/gsi_bias.f90 diff --git a/src/gsi_bundlemod.F90 b/src/gsi/gsi_bundlemod.F90 similarity index 99% rename from src/gsi_bundlemod.F90 rename to src/gsi/gsi_bundlemod.F90 index 272316c15..ad0a370a4 100644 --- a/src/gsi_bundlemod.F90 +++ b/src/gsi/gsi_bundlemod.F90 @@ -4,6 +4,11 @@ ! !MODULE: GSI_BundleMod --- GSI Bundle ! ! !INTERFACE: +! +! program change log: +! 2018-01-18 G. Ge: change pointer,intent(out) to pointer,intent(inout) +! to solve the GSI crash under INTEL v18+ +! module GSI_BundleMod @@ -13,7 +18,6 @@ module GSI_BundleMod use constants, only: zero_single,zero,zero_quad use m_rerank, only: rerank use mpeu_util, only: perr, die - use gsi_io, only: verbose implicit none private @@ -280,6 +284,8 @@ module GSI_BundleMod ! 04Jul2011 Todling - large revision of REAL*4 or REAL*8 implementation ! 27Jun2012 Parrish - set verbose_ to .false. to turn off diagnostic print in subroutine merge_. ! 05Oct2014 Todling - add 4d-like interfaces to getvars +! 26Aug2017 G. Ge - change names(nd) to names(:) to make the passing of assumed size character +! array consistent between nested calls ! ! !SEE ALSO: ! gsi_metguess_mod.F90 @@ -340,6 +346,7 @@ module GSI_BundleMod !noBOC character(len=*), parameter :: myname='GSI_BundleMod' + logical, parameter :: VERBOSE_=.false. integer, parameter :: bundle_kind_def = r_kind ! default kind CONTAINS @@ -357,7 +364,7 @@ subroutine init1d_(flds,nd,names,istatus,longnames,units,thisKind) ! !INPUT PARAMETERS: integer(i_kind), intent(in):: nd - character(len=*),intent(in):: names(nd) + character(len=*),intent(in):: names(:) character(len=*),OPTIONAL,intent(in):: longnames(nd) character(len=*),OPTIONAL,intent(in):: units(nd) integer(i_kind), OPTIONAL,intent(in):: thisKind @@ -417,7 +424,7 @@ end subroutine clean1d_ subroutine init2d_(flds,nd,names,istatus,longnames,units,thisKind) integer(i_kind), intent(in) :: nd type(GSI_2D), intent(inout):: flds(nd) - character(len=*),intent(in):: names(nd) + character(len=*),intent(in):: names(:) integer(i_kind), intent(out):: istatus character(len=*),OPTIONAL,intent(in):: longnames(nd) character(len=*),OPTIONAL,intent(in):: units(nd) @@ -459,7 +466,7 @@ end subroutine clean2d_ subroutine init3d_(flds,nd,names,istatus,longnames,units,thisKind) integer(i_kind), intent(in) :: nd type(GSI_3D), intent(inout):: flds(nd) - character(len=*),intent(in):: names(nd) + character(len=*),intent(in):: names(:) integer(i_kind), intent(out):: istatus character(len=*),OPTIONAL,intent(in):: longnames(nd) character(len=*),OPTIONAL,intent(in):: units(nd) @@ -1820,7 +1827,7 @@ subroutine get31r8_ ( Bundle, fldname, pntr, istatus ) ! !OUTPUT PARAMETERS: - real(r_double),pointer,intent(out) :: pntr(:) ! actual pointer to individual field + real(r_double),pointer,intent(inout) :: pntr(:) ! actual pointer to individual field integer(i_kind), intent(out) :: istatus ! status error code ! !DESCRIPTION: Retrieve pointer to specific rank-1 field. @@ -1876,7 +1883,7 @@ subroutine get31r4_ ( Bundle, fldname, pntr, istatus ) ! !OUTPUT PARAMETERS: - real(r_single),pointer,intent(out) :: pntr(:) ! actual pointer to individual field + real(r_single),pointer,intent(inout) :: pntr(:) ! actual pointer to individual field integer(i_kind), intent(out) :: istatus ! status error code ! !DESCRIPTION: Retrieve pointer to specific rank-1 field. @@ -1930,7 +1937,7 @@ subroutine get32r8_ ( Bundle, fldname, pntr, istatus ) ! !OUTPUT PARAMETERS: - real(r_double),pointer,intent(out) :: pntr(:,:) ! actual pointer to individual field + real(r_double),pointer,intent(inout) :: pntr(:,:) ! actual pointer to individual field integer(i_kind), intent(out) :: istatus ! status error code ! !DESCRIPTION: Retrieve pointer to specific rank-2 field. @@ -1971,7 +1978,7 @@ subroutine get32r4_ ( Bundle, fldname, pntr, istatus ) ! !OUTPUT PARAMETERS: - real(r_single),pointer,intent(out) :: pntr(:,:) ! actual pointer to individual field + real(r_single),pointer,intent(inout) :: pntr(:,:) ! actual pointer to individual field integer(i_kind),intent(out) :: istatus ! status error code ! !DESCRIPTION: Retrieve pointer to specific rank-2 field. @@ -2011,7 +2018,7 @@ subroutine get33r8_ ( Bundle, fldname, pntr, istatus ) ! !OUTPUT PARAMETERS: - real(r_double),pointer,intent(out) :: pntr(:,:,:) ! actual pointer to individual field + real(r_double),pointer,intent(inout) :: pntr(:,:,:) ! actual pointer to individual field integer(i_kind),intent(out) :: istatus ! status error code ! !DESCRIPTION: Retrieve pointer to specific rank-3 field. @@ -2051,7 +2058,7 @@ subroutine get33r4_ ( Bundle, fldname, pntr, istatus ) ! !OUTPUT PARAMETERS: - real(r_single),pointer,intent(out) :: pntr(:,:,:) ! actual pointer to individual field + real(r_single),pointer,intent(inout) :: pntr(:,:,:) ! actual pointer to individual field integer(i_kind),intent(out) :: istatus ! status error code ! !DESCRIPTION: Retrieve pointer to specific rank-3 field. @@ -3121,7 +3128,7 @@ subroutine merge_ ( MergeBundle, Bundle1, Bundle2, NewName, istatus ) deallocate(idi,ido) endif endif - if(verbose) print*, 'complete merge' + if(verbose_) print*, 'complete merge' end subroutine merge_ !noEOC diff --git a/src/gsi_chemguess_mod.F90 b/src/gsi/gsi_chemguess_mod.F90 similarity index 100% rename from src/gsi_chemguess_mod.F90 rename to src/gsi/gsi_chemguess_mod.F90 diff --git a/src/gsi/gsi_cldchOper.F90 b/src/gsi/gsi_cldchOper.F90 new file mode 100644 index 000000000..96c4a1db7 --- /dev/null +++ b/src/gsi/gsi_cldchOper.F90 @@ -0,0 +1,161 @@ +module gsi_cldchOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_cldchOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for cldchNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper , only: obOper + use m_cldchNode, only: cldchNode + implicit none + public:: cldchOper ! data stracture + + type,extends(obOper):: cldchOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type cldchOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_cldchOper' + type(cldchNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[cldchOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use cldch_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_cldch + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(cldchOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intcldchmod, only: intjo => intcldch + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(cldchOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpcldchmod, only: stpjo => stpcldch + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(cldchOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_cldchOper diff --git a/src/gsi/gsi_cldtotOper.F90 b/src/gsi/gsi_cldtotOper.F90 new file mode 100644 index 000000000..5a63e2476 --- /dev/null +++ b/src/gsi/gsi_cldtotOper.F90 @@ -0,0 +1,185 @@ +module gsi_cldtotOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_cldtotOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2019-07-22 +! +! abstract: an obOper extension for cldtot operator +! +! program history log: +! 2019-07-22 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_qNode , only: qNode + implicit none + public:: cldtotOper ! data stracture + + type,extends(obOper):: cldtotOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type cldtotOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_cldtotOper' + type(qNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[cldtotOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use cldtot_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_cldtot + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + use rapidrefresh_cldsurf_mod, only: i_cloud_q_innovation + + use mpeu_util, only: die,perr + implicit none + class(cldtotOper), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + ! try data header + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) then + call perr(myname_,'read(obstype,...), iostat =',ier) + call perr(myname_,' nobs =',nobs) + call die(myname_) + endif + + nele = nreal+nchanl + diagsave = write_diag(jiter) .and. diag_conv + + select case(i_cloud_q_innovation) + case(2) + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + case default + ! try to skip data record + read(lunin,iostat=ier) + if(ier/=0) then + call perr(myname_,'read(lunin), iostat =',ier) + call perr(myname_,' nobs =',nobs) + call perr(myname_,' obstype =',trim(obstype)) + call perr(myname_,' isis =',trim(isis)) + call perr(myname_,' nreal =',nreal) + call perr(myname_,' nchanl =',nchanl) + call die(myname_) + endif + + end select + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intqmod, only: intjo => intq + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(cldtotOper),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + ! qNode is used, so there is no specific operation + return + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpqmod, only: stpjo => stpq + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(cldtotOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_cldtotOper diff --git a/src/gsi/gsi_colvkOper.F90 b/src/gsi/gsi_colvkOper.F90 new file mode 100644 index 000000000..9d32cfb7a --- /dev/null +++ b/src/gsi/gsi_colvkOper.F90 @@ -0,0 +1,157 @@ +module gsi_colvkOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_colvkOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for colvkNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper , only: obOper + use m_colvkNode, only: colvkNode + implicit none + public:: colvkOper ! data stracture + + type,extends(obOper):: colvkOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type colvkOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_colvkOper' + type(colvkNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[colvkOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use colvk_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: stats => rhs_stats_co + use obsmod, only: write_diag + use coinfo, only: diag_co + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(colvkOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + + diagsave = write_diag(jiter) .and. diag_co + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,stats,nchanl,nreal,nobs,obstype,isis,is,diagsave,init_pass) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intcomod, only: intjo => intco + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(colvkOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpcomod, only: stpjo => stpco + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(colvkOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_colvkOper diff --git a/src/gsi/gsi_dbzOper.F90 b/src/gsi/gsi_dbzOper.F90 new file mode 100644 index 000000000..74d9bdf65 --- /dev/null +++ b/src/gsi/gsi_dbzOper.F90 @@ -0,0 +1,169 @@ +module gsi_dbzOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_dbzOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for dbzNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! 2019-06-25 Hu - add diag_radardbz for controling radar reflectivity +! diag file (in module obsmod). +! 2019-07-22 j Guo - moved diag_radardbz and its description here from +! obsmod. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_dbzNode , only: dbzNode + implicit none + public:: dbzOper ! data stracture + public:: diag_radardbz + + type,extends(obOper):: dbzOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type dbzOper + +! def diag_radardbz- namelist logical to compute/write (=true) radar +! reflectiivty diag files + logical,save:: diag_radardbz=.false. + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_dbzOper' + type(dbzNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[dbzOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use dbz_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_dbz + + use obsmod , only: write_diag + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(dbzOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_radardbz + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave,init_pass) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intdbzmod, only: intjo => intdbz + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(dbzOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpdbzmod, only: stpjo => stpdbz + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(dbzOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_dbzOper diff --git a/src/gsi/gsi_dwOper.F90 b/src/gsi/gsi_dwOper.F90 new file mode 100644 index 000000000..177228291 --- /dev/null +++ b/src/gsi/gsi_dwOper.F90 @@ -0,0 +1,162 @@ +module gsi_dwOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_dwOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for dwNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_dwNode , only: dwNode + + implicit none + public:: dwOper ! data stracture + + type,extends(obOper):: dwOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type dwOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_dwOper' + type(dwNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[dwOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use dw_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_dw + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(dwOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intdwmod, only: intjo => intdw + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(dwOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpdwmod, only: stpjo => stpdw + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(dwOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_dwOper diff --git a/src/gsi/gsi_enscouplermod.f90 b/src/gsi/gsi_enscouplermod.f90 new file mode 100644 index 000000000..6382b1e5b --- /dev/null +++ b/src/gsi/gsi_enscouplermod.f90 @@ -0,0 +1,211 @@ +!---------------------------------------------------------------------------- +!BOP +! +! !MODULE: GSI_EnsCouplerMod --- +! +! !INTERFACE: + +module GSI_EnsCouplerMod + +! !USES: + +use abstract_ensmod, only: abstractEnsemble +use gsi_bundlemod, only: gsi_bundle +use mpeu_util, only: tell,warn +implicit none +private + +! !PUBLIC MEMBER FUNCTIONS: + + public GSI_EnsCoupler_localization_grid + public GSI_EnsCoupler_get_user_ens + public GSI_EnsCoupler_get_user_Nens + public GSI_EnsCoupler_put_gsi_ens + public GSI_EnsCoupler_registry + public GSI_EnsCoupler_name + public GSI_EnsCoupler_create_sub2grid_info + public GSI_EnsCoupler_destroy_sub2grid_info + +! !INTERFACES: + interface GSI_EnsCoupler_localization_grid; module procedure non_gaussian_ens_grid_; end interface + interface GSI_EnsCoupler_get_user_ens; module procedure get_user_ens_; end interface + interface GSI_EnsCoupler_get_user_Nens; module procedure get_user_Nens_; end interface + interface GSI_EnsCoupler_put_gsi_ens; module procedure put_user_ens_; end interface + + interface GSI_EnsCoupler_registry ; module procedure typedef_ ; end interface + interface GSI_EnsCoupler_name; module procedure typename_; end interface + interface GSI_EnsCoupler_create_sub2grid_info ; module procedure create_s2gi; end interface + interface GSI_EnsCoupler_destroy_sub2grid_info; module procedure destroy_s2gi; end interface + +! !CLASSES: + + class(abstractEnsemble),allocatable,target,save:: typemold_ + class(abstractEnsemble),allocatable,target,save:: this_ensemble_ + +! This flag controls internal debugging messages. + logical,parameter:: verbose=.false. + !logical,parameter:: verbose=.true. + + character(len=*),parameter:: myname='GSI_EnsCouplerMod' +contains + +subroutine typedef_(mold) +!-- A high-level interface type-define the concrete multi-ensemble to use. + + use stub_ensmod, only: stub_ensemble => ensemble + implicit none + class(abstractEnsemble),optional,target,intent(in):: mold + + character(len=*),parameter:: myname_=myname//'::typedef_' + class(abstractEnsemble),pointer:: pmold_ + + ! argument checking + pmold_ => null() + if(present(mold)) then + pmold_ => mold + if(.not.associated(pmold_)) & ! is argument _mold_ a null-object? + call warn(myname_,'a null argument (mold) is given. Will typedef to default') + endif + + ! reset current typemold + if(allocated(typemold_)) then + if(verbose) call tell(myname_,'deallocating, typemold_%mytype() = '//typemold_%mytype()) + deallocate(typemold_) + endif + + ! (re)allocate the new typemold_ + if(associated(pmold_)) then + allocate(typemold_,mold=pmold_) + pmold_ => null() + else + allocate(stub_ensemble::typemold_) + endif + if(verbose) call tell(myname_,'allocated, typemold_%mytype() = '//typemold_%mytype()) +end subroutine typedef_ + +function typename_() result(name) +!-- Return the name of the current concrete multi-ensemble type. + + use abstract_ensmod, only: abstractEnsemble_typename + implicit none + character(len=:),allocatable:: name ! return the type name + name=abstractEnsemble_typename() + if(allocated(typemold_)) name=typemold_%mytype() + ! Note the use of typemold_, instead of this_ensemble_. +end function typename_ + + subroutine get_user_ens_(grd,member,ntindex,atm_bundle,iret) + use kinds, only: i_kind,r_kind + use gsi_bundlemod, only: gsi_bundle + use general_sub2grid_mod, only: sub2grid_info + implicit none +! Declare passed variables + type(sub2grid_info) ,intent(in ) :: grd + integer(i_kind) ,intent(in ) :: member + integer(i_kind) ,intent(in ) :: ntindex + type(gsi_bundle) ,intent(inout) :: atm_bundle + integer(i_kind) ,intent( out) :: iret + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%get_user_ens(grd,member,ntindex,atm_bundle,iret) + end subroutine get_user_ens_ + + subroutine get_user_Nens_(grd,members,ntindex,atm_bundle,iret) + use kinds, only: i_kind,r_kind + use gsi_bundlemod, only: gsi_bundle + use general_sub2grid_mod, only: sub2grid_info + implicit none +! Declare passed variables + type(sub2grid_info) ,intent(in ) :: grd + integer(i_kind) ,intent(in ) :: members + integer(i_kind) ,intent(in ) :: ntindex + type(gsi_bundle) ,intent(inout) :: atm_bundle(:) + integer(i_kind) ,intent( out) :: iret + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%get_user_Nens(grd,members,ntindex,atm_bundle,iret) + end subroutine get_user_Nens_ + + subroutine put_user_ens_(grd,member,ntindex,pert,iret) + use kinds, only: i_kind,r_kind + use general_sub2grid_mod, only: sub2grid_info + use gsi_bundlemod, only: gsi_bundle + implicit none +! Declare passed variables + type(sub2grid_info),intent(in ) :: grd + integer(i_kind), intent(in ) :: member + integer(i_kind), intent(in ) :: ntindex + type(gsi_bundle), intent(inout) :: pert + integer(i_kind), intent( out) :: iret + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%put_user_ens(grd,member,ntindex,pert,iret) + end subroutine put_user_ens_ + + subroutine non_gaussian_ens_grid_ (elats,elons) + use kinds, only: i_kind,r_kind + implicit none + real(r_kind),intent(out) :: elats(:),elons(:) + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%non_gaussian_ens_grid(elats,elons) + end subroutine non_gaussian_ens_grid_ + + subroutine ifn_alloc_() +!-- If-not-properly-allocated(this_ensemble_), do something + implicit none + class(abstractEnsemble),pointer:: pmold_ + + ! First, check to make sure typemold_ is type-defined, at least to a + ! default multi-ensemble type. + pmold_ => typemold_ + if(.not.associated(pmold_)) call typedef_() + pmold_ => null() + + ! Then, check and possibly instantiate this_ensemble_, which is must be + ! typed the same as typemold_ + + if(allocated(this_ensemble_)) then + if(same_type_as(typemold_,this_ensemble_)) return ! Everything seems good. + + ! Otherwise, this_ensemble_ must be re-intentiated with a different type. + + deallocate(this_ensemble_) + endif + allocate(this_ensemble_,mold=typemold_) + end subroutine ifn_alloc_ + +! !DESCRIPTION: This module provides general interface for +! ensemble capability +! +! !REVISION HISTORY: +! +! 19Sep2011 Todling - Initial code +! 30Nov2014 Todling - Update interface to get (bundle passed in) +! 28Jun2018 Todling - Revamp in light of truly abstract ensemble interface +! +!EOP +!------------------------------------------------------------------------- + +subroutine create_s2gi(s2gi, nsig, npe, s2gi_ref) + use kinds, only: i_kind + use general_sub2grid_mod, only: sub2grid_info + implicit none +! Declare passed variables + type(sub2grid_info),intent( out) :: s2gi + integer(i_kind), intent(in ) :: nsig + integer(i_kind), intent(in ) :: npe + type(sub2grid_info),intent(in ) :: s2gi_ref + + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%create_sub2grid_info(s2gi, nsig,npe, s2gi_ref) +return +end subroutine create_s2gi +subroutine destroy_s2gi(s2gi) + use general_sub2grid_mod, only: sub2grid_info + implicit none +! Declare passed variables + type(sub2grid_info),intent(inout) :: s2gi + + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%destroy_sub2grid_info(s2gi) +return +end subroutine destroy_s2gi + +end module GSI_EnsCouplerMod diff --git a/src/gsi/gsi_fixture_GFS.F90 b/src/gsi/gsi_fixture_GFS.F90 new file mode 100644 index 000000000..3be63f590 --- /dev/null +++ b/src/gsi/gsi_fixture_GFS.F90 @@ -0,0 +1,65 @@ +module gsi_fixture +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_fixture_GFS (but named as gsi_fixture) +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2019-08-04 +! +! abstract: - configure GSI extensions for GFS global fixture. +! +! program history log: +! 2019-08-04 j guo - initial code +! . a generic module name "gsi_fixture" is used to let +! the code compilable with a simple switch through +! CMakeLists.txt file selection. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + implicit none + private ! except + public:: fixture_config + + ! fixture_config() is the interface to all configuration extension + ! details. It is not implemented as a generic interface, to emphasize + ! its exclusiveness. + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_fixture_GFS' + +contains +subroutine fixture_config() +!> In a GFS fixture as it is, +!> - use GSI stub_timer +!> - use GSI get_gfs_ensmod_mod from cplr_gfs_ensmod.f90. + +!> singleton timermod and gsi_enscouplemod, which manage the actual timer and +!> gfs_ensenble extentions. + + use timermod , only: timer_typedef + use gsi_enscouplermod, only: ensemble_typedef => gsi_enscoupler_registry + +!> Define the actual extensions (timermod and gfs_ensemble) to be used. + + use m_stubTimer , only: my_timer_mold => timer_typemold + use get_gfs_ensmod_mod, only: my_ensemble_mold => ensemble_typemold + + implicit none + +!> Fix up the extensions used by corresponding GSI singleton modules. + + call timer_typedef(my_timer_mold()) + call ensemble_typedef(my_ensemble_mold()) + +end subroutine fixture_config +end module gsi_fixture diff --git a/src/gsi/gsi_fixture_REGIONAL.F90 b/src/gsi/gsi_fixture_REGIONAL.F90 new file mode 100644 index 000000000..69e923e72 --- /dev/null +++ b/src/gsi/gsi_fixture_REGIONAL.F90 @@ -0,0 +1,75 @@ +module gsi_fixture +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_fixture_REGIONAL (but named as gsi_fixture) +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2019-08-04 +! +! abstract: - configure GSI extensions for a REGIONAL fixture. +! +! program history log: +! 2019-08-04 j guo - initial code +! . a generic module name "gsi_fixture" is used to let +! the code compilable with a simple switch through +! CMakeLists.txt file selection. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + implicit none + private ! except + public:: fixture_config + + ! fixture_config() is the interface to all configuration extension + ! details. It is not implemented as a generic interface, to emphasize + ! its exclusiveness. + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_fixture_REGIONAL' + +contains +subroutine fixture_config() +!> In a REGIONAL fixture as it is, +!> - use GSI stub_timer +!> - if (use_gfs_ens) then +!> use GSI get_gfs_ensmod_mod from cplr_gfs_ensmod.f90 +!> else +!> use GSI stub_ensmod from stub_ensmod.f90 +!> endif + +!> singleton timermod and gsi_enscouplemod, which manage the actual timer and +!> gfs_ensenble extentions. + + use timermod , only: timer_typedef + use gsi_enscouplermod, only: ensemble_typedef => gsi_enscoupler_registry + +!> Define the actual extensions (timermod and gfs_ensemble) to be used. + use hybrid_ensemble_parameters, only: use_gfs_ens + use m_stubTimer , only: my_timer_mold => timer_typemold + use stub_ensmod , only: stub_ensemble_mold => ensemble_typemold + use get_gfs_ensmod_mod, only: gfs_ensemble_mold => ensemble_typemold + + implicit none + +!> Fix up the extensions used by corresponding GSI singleton modules. + + call timer_typedef(my_timer_mold()) + + if(use_gfs_ens) then + call ensemble_typedef( gfs_ensemble_mold()) + else + call ensemble_typedef(stub_ensemble_mold()) + endif + +end subroutine fixture_config +end module gsi_fixture diff --git a/src/gsi/gsi_gpsbendOper.F90 b/src/gsi/gsi_gpsbendOper.F90 new file mode 100644 index 000000000..66a037605 --- /dev/null +++ b/src/gsi/gsi_gpsbendOper.F90 @@ -0,0 +1,161 @@ +module gsi_gpsbendOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_gpsbendOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for gpsNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_gpsNode, only: gpsNode + implicit none + public:: gpsbendOper ! data stracture + + type,extends(obOper):: gpsbendOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type gpsbendOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_gpsbendOper' + type(gpsNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[gpsbendOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use gpsbend_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: iwork => i_gps + use m_rhs , only: toss_gps_sub => rhs_toss_gps + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: perr,die + implicit none + class(gpsbendOper), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,awork(:,iwork),nele,nobs,toss_gps_sub,is,init_pass,last_pass,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intgpsmod, only: intjo => intgps + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(gpsbendOper),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpgpsmod, only: stpjo => stpgps + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(gpsbendOper),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_gpsbendOper diff --git a/src/gsi/gsi_gpsrefOper.F90 b/src/gsi/gsi_gpsrefOper.F90 new file mode 100644 index 000000000..edadba119 --- /dev/null +++ b/src/gsi/gsi_gpsrefOper.F90 @@ -0,0 +1,162 @@ +module gsi_gpsrefOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_gpsrefOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for gpsNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_gpsbendOper, only: gpsbendOper + use m_gpsNode, only: gpsNode + implicit none + public:: gpsrefOper ! data stracture + + type,extends(gpsbendOper):: gpsrefOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type gpsrefOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_gpsrefOper' + type(gpsNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[gpsrefOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use gpsref_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: iwork => i_gps + use m_rhs , only: toss_gps_sub => rhs_toss_gps + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: perr,die + implicit none + class(gpsrefOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,awork(:,iwork),nele,nobs,toss_gps_sub,is,init_pass,last_pass,diagsave) + + return + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intgpsmod, only: intjo => intgps + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(gpsrefOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpgpsmod, only: stpjo => stpgps + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(gpsrefOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_gpsrefOper diff --git a/src/gsi/gsi_gustOper.F90 b/src/gsi/gsi_gustOper.F90 new file mode 100644 index 000000000..522fa0da3 --- /dev/null +++ b/src/gsi/gsi_gustOper.F90 @@ -0,0 +1,161 @@ +module gsi_gustOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_gustOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for gustNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_gustNode, only: gustNode + implicit none + public:: gustOper ! data stracture + + type,extends(obOper):: gustOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type gustOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_gustOper' + type(gustNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[gustOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use gust_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_gust + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(gustOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intgustmod, only: intjo => intgust + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(gustOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpgustmod, only: stpjo => stpgust + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(gustOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_gustOper diff --git a/src/gsi/gsi_howvOper.F90 b/src/gsi/gsi_howvOper.F90 new file mode 100644 index 000000000..ade056700 --- /dev/null +++ b/src/gsi/gsi_howvOper.F90 @@ -0,0 +1,161 @@ +module gsi_howvOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_howvOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for howvNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_howvNode, only: howvNode + implicit none + public:: howvOper ! data stracture + + type,extends(obOper):: howvOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type howvOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_howvOper' + type(howvNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[howvOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use howv_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_howv + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(howvOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use inthowvmod, only: intjo => inthowv + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(howvOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stphowvmod, only: stpjo => stphowv + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(howvOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_howvOper diff --git a/src/gsi_io.f90 b/src/gsi/gsi_io.f90 similarity index 96% rename from src/gsi_io.f90 rename to src/gsi/gsi_io.f90 index 3324aee81..1c6ece20f 100644 --- a/src/gsi_io.f90 +++ b/src/gsi/gsi_io.f90 @@ -30,12 +30,14 @@ module gsi_io integer(i_kind):: lendian_in,lendian_out integer(i_kind):: mype_io logical verbose + logical print_obs_para private public lendian_in, lendian_out public mype_io public init_io public verbose + public print_obs_para character(len=*), parameter :: myname='gsi_io' @@ -75,6 +77,7 @@ subroutine init_io(mype,iope) lendian_in = 15 lendian_out = 66 verbose = .false. + print_obs_para = .false. if (mype==0) write(6,*)'INIT_IO: reserve units lendian_in=',lendian_in,& ' and lendian_out=',lendian_out,' for little endian i/o' diff --git a/src/gsi/gsi_lcbasOper.F90 b/src/gsi/gsi_lcbasOper.F90 new file mode 100644 index 000000000..329c478c4 --- /dev/null +++ b/src/gsi/gsi_lcbasOper.F90 @@ -0,0 +1,161 @@ +module gsi_lcbasOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_lcbasOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for lcbasNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper , only: obOper + use m_lcbasNode, only: lcbasNode + implicit none + public:: lcbasOper ! data stracture + + type,extends(obOper):: lcbasOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type lcbasOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_lcbasOper' + type(lcbasNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[lcbasOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use lcbas_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_lcbas + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(lcbasOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intlcbasmod, only: intjo => intlcbas + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(lcbasOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stplcbasmod, only: stpjo => stplcbas + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(lcbasOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_lcbasOper diff --git a/src/gsi/gsi_lightOper.F90 b/src/gsi/gsi_lightOper.F90 new file mode 100644 index 000000000..54bd583f1 --- /dev/null +++ b/src/gsi/gsi_lightOper.F90 @@ -0,0 +1,208 @@ +module gsi_lightOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_lightOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for lightNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_lightNode, only: lightNode + use kinds , only: i_kind + implicit none + public:: lightOper ! data stracture + public:: lightOper_config + interface lightOper_config; module procedure config_; end interface + + type,extends(obOper):: lightOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type lightOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_lightOper' + type(lightNode),save,target:: myNodeMold_ + +!> Configurations specific to this observation operator. + + logical,parameter:: DEFAULT_USE_NSIG_SAVED_=.false. + logical ,save:: use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ + integer(kind=i_kind),save:: nsig_saved_ + +!> At gsi_obOpers coupling time, e.g. +!> +!> > call obopers_config() +!> +!> which does +!> +!> > use gfs_stratosphere, only: use_gfs_stratosphere, nsig_save +!> > if (use_gfs_stratosphere) then +!> > call lightOper_config(nsig_save=nsig_save) +!> > endif +!> + + +contains +subroutine config_(nsig_save,use_nsig_save) +!> config_() is the place to couple configurations external to +!> gsi_lwOper and gsi_obOper. Some of these external configurations will +!> gradually become obsolete through refactorings. + +!> call + + implicit none + integer(i_kind),optional:: nsig_save ! set nsig_save if present + logical ,optional:: use_nsig_save ! switch the use of nsig_save + + logical:: reset_ + reset_=.true. + if(present(use_nsig_save)) then + use_nsig_saved_=use_nsig_save + reset_=.false. + endif + if(present( nsig_save)) then + nsig_saved_=nsig_save + use_nsig_saved_=.true. + reset_=.false. + endif + if(reset_) use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ +end subroutine config_ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[lightOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use light_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_light + + use obsmod , only: write_diag + use lightinfo,only: diag_light + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(lightOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_light + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave,init_pass) + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intlightmod, only: intjo => intlight + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(lightOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stplightmod, only: stpjo => stplight + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(lightOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_lightOper diff --git a/src/gsi/gsi_lwcpOper.F90 b/src/gsi/gsi_lwcpOper.F90 new file mode 100644 index 000000000..3c966b373 --- /dev/null +++ b/src/gsi/gsi_lwcpOper.F90 @@ -0,0 +1,215 @@ +module gsi_lwcpOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_lwcpOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for lwcpNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_lwcpNode, only: lwcpNode + use kinds , only: i_kind + implicit none + public:: lwcpOper ! data stracture + public:: lwcpOper_config + interface lwcpOper_config; module procedure config_; end interface + + type,extends(obOper):: lwcpOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type lwcpOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_lwcpOper' + type(lwcpNode),save,target:: myNodeMold_ + +!> Configurations specific to this observation operator. + + logical,parameter:: DEFAULT_USE_NSIG_SAVED_=.false. + logical ,save:: use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ + integer(kind=i_kind),save:: nsig_saved_ + +!> At gsi_obOpers coupling time, e.g. +!> +!> > call obopers_config() +!> +!> which does +!> +!> > use gfs_stratosphere, only: use_gfs_stratosphere, nsig_save +!> > if (use_gfs_stratosphere) then +!> > call lwcpOper_config(nsig_save=nsig_save) +!> > endif +!> + + +contains +subroutine config_(nsig_save,use_nsig_save) +!> config_() is the place to couple configurations external to +!> gsi_lwOper and gsi_obOper. Some of these external configurations will +!> gradually become obsolete through refactorings. + +!> call + + implicit none + integer(i_kind),optional:: nsig_save ! set nsig_save if present + logical ,optional:: use_nsig_save ! switch the use of nsig_save + + logical:: reset_ + reset_=.true. + if(present(use_nsig_save)) then + use_nsig_saved_=use_nsig_save + reset_=.false. + endif + if(present( nsig_save)) then + nsig_saved_=nsig_save + use_nsig_saved_=.true. + reset_=.false. + endif + if(reset_) use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ +end subroutine config_ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[lwcpOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use lwcp_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_lwcp + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(lwcpOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + if(use_nsig_saved_) then + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave, & + nsig_saved=nsig_saved_) + else + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + endif + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intlwcpmod, only: intjo => intlwcp + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(lwcpOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stplwcpmod, only: stpjo => stplwcp + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(lwcpOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_lwcpOper diff --git a/src/gsi_metguess_mod.F90 b/src/gsi/gsi_metguess_mod.F90 similarity index 100% rename from src/gsi_metguess_mod.F90 rename to src/gsi/gsi_metguess_mod.F90 diff --git a/src/gsi/gsi_mitmOper.F90 b/src/gsi/gsi_mitmOper.F90 new file mode 100644 index 000000000..6c63c7565 --- /dev/null +++ b/src/gsi/gsi_mitmOper.F90 @@ -0,0 +1,161 @@ +module gsi_mitmOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_mitmOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for mitmNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_mitmNode, only: mitmNode + implicit none + public:: mitmOper ! data stracture + + type,extends(obOper):: mitmOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type mitmOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_mitmOper' + type(mitmNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[mitmOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use mitm_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_mitm + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(mitmOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intmitmmod, only: intjo => intmitm + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(mitmOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpmitmmod, only: stpjo => stpmitm + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(mitmOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_mitmOper diff --git a/src/gsi/gsi_mxtmOper.F90 b/src/gsi/gsi_mxtmOper.F90 new file mode 100644 index 000000000..e0eae49dc --- /dev/null +++ b/src/gsi/gsi_mxtmOper.F90 @@ -0,0 +1,161 @@ +module gsi_mxtmOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_mxtmOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for mxtmNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_mxtmNode, only: mxtmNode + implicit none + public:: mxtmOper ! data stracture + + type,extends(obOper):: mxtmOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type mxtmOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_mxtmOper' + type(mxtmNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[mxtmOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use mxtm_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_mxtm + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(mxtmOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intmxtmmod, only: intjo => intmxtm + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(mxtmOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpmxtmmod, only: stpjo => stpmxtm + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(mxtmOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_mxtmOper diff --git a/src/gsi/gsi_nemsio_mod.f90 b/src/gsi/gsi_nemsio_mod.f90 new file mode 100644 index 000000000..87b5c232f --- /dev/null +++ b/src/gsi/gsi_nemsio_mod.f90 @@ -0,0 +1,1367 @@ +module gsi_nemsio_mod +!$$$ module documentation block +! . . . . +! module: gsi_nemsio_mod +! prgmmr: +! +! abstract: +! +! program history log: +! 2009-08-04 lueken - added module doc block +! 2014-06-30 wu - remove debugging printout +! 2015_05_13 wu - output error flag of nemsio_open +! 2015-06-10 s.liu - add gsi_nemsio_read_fraction to handle NMMB f_rain and f_ice +! 2015-06-10 s.liu - add gsi_nemsio_write_fraction to handle NMMB f_rain and f_ice +! 2016-02-05 s.liu - add fraction2variable and variable2fraction to handle NMMB f_rain and f_ice +! +! subroutines included: +! sub gsi_nemsio_open +! sub gsi_nemsio_update +! sub gsi_nemsio_close +! sub gsi_nemsio_read +! sub gsi_nemsio_read_fraction +! sub gsi_nemsio_write +! sub gsi_nemsio_write_fraction +! sub fraction2variable +! sub variable2fraction +! +! variable definitions: +! +! attributes: +! langauge: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind,r_single + use nemsio_module, only: nemsio_gfile + use gridmod, only: nlon_regional,nlat_regional + implicit none + + type(nemsio_gfile) :: gfile + save gfile + + real(r_single),allocatable::work_saved(:) + +! set default to private + private +! set subroutines to public + public :: gsi_nemsio_open + public :: gsi_nemsio_update + public :: gsi_nemsio_close + public :: gsi_nemsio_read + public :: gsi_nemsio_read_fraction + public :: gsi_nemsio_read_fractionnew + public :: gsi_nemsio_write + public :: gsi_nemsio_write_fraction + public :: gsi_nemsio_write_fractionnew + +contains + + subroutine gsi_nemsio_open(file_name,iostatus,message,mype,mype_io,ierr) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_open +! pgrmmr: +! +! abstract: +! +! program history log: +! 2009-08-04 lueken - added subprogram doc block +! +! input argument list: +! file_name +! iostatus +! message +! mype - mpi task id +! mype_io +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use nemsio_module, only: nemsio_init,nemsio_open + implicit none + + character(*) ,intent(in ) :: file_name ! input file name + character(*) ,intent(in ) :: iostatus ! 'READ' for read only, 'rdwr' for read/write + character(*) ,intent(in ) :: message ! info to appear in write statement on status of file open + integer(i_kind),intent(in ) :: mype,mype_io + integer(i_kind),intent(out ) :: ierr + + integer(i_kind) iret + + if(mype==mype_io) then + call nemsio_init(iret=iret) + if(iret/=0) then + write(6,*)trim(message),' problem with nemsio_init, Status = ',iret + call stop2(74) + end if + ierr=0 + call nemsio_open(gfile,file_name,trim(iostatus),iret=iret) + if(iret/=0) then + write(6,*)trim(message),' problem opening file',trim(file_name),', Status = ',iret + ierr=1 + return + end if + end if + allocate(work_saved(nlon_regional*nlat_regional)) + + end subroutine gsi_nemsio_open + + subroutine gsi_nemsio_update(file_name,message,mype,mype_io) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_update +! pgrmmr: +! +! abstract: +! +! program history log: +! 2009-08-04 lueken - added subprogram doc block +! +! input argument list: +! file_name +! message +! mype - mpi task id +! mype_io +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_getfilehead,nemsio_close,nemsio_setheadvar + use nemsio_module, only: nemsio_getheadvar + use constants, only: zero + implicit none + + character(*) ,intent(in ) :: file_name ! input file name + character(*) ,intent(in ) :: message ! info to appear in write statement on status of file open + integer(i_kind),intent(in ) :: mype,mype_io + + integer(i_kind) iret,nrec + integer(i_kind) idate(7),jdate(7),nfhour,nfminute,nfsecondn,nfday,ihrst,idat(3) + integer(i_kind),dimension(8):: ida,jda + real(r_kind),dimension(5):: fha + integer(i_kind) im,jm,lm,nfsecondd,nframe,ntrac,nsoil,nmeta,ntimestep + logical extrameta + character(4) gdatatype,modelname + character(32) gtype + + if(mype==mype_io) then + call nemsio_init(iret=iret) + if(iret/=0) then + write(6,*)trim(message),' problem with nemsio_init, Status = ',iret + call stop2(74) + end if + call nemsio_open(gfile,file_name,'RDWR',iret=iret) + if(iret/=0) then + write(6,*)trim(message),' problem opening file',trim(file_name),', Status = ',iret + call stop2(74) + end if + call nemsio_getheadvar(gfile,'idat',idat,iret) + write(6,*)' check old idat after getheadvar, idat,iret=',idat,iret + call nemsio_getheadvar(gfile,'ihrst',ihrst,iret) + write(6,*)' check old ihrst after getheadvar, ihrst,iret=',ihrst,iret + call nemsio_getheadvar(gfile,'ntimestep',ntimestep,iret) + write(6,*)' check old ntimestep after getheadvar, ntimestep,iret=',ntimestep,iret + call nemsio_getfilehead(gfile,iret=iret,nrec=nrec,dimx=im,dimy=jm, & + dimz=lm,idate=idate,gdatatype=gdatatype,gtype=gtype,modelname=modelname, & + nfhour=nfhour,nfminute=nfminute,nfsecondn=nfsecondn,nfsecondd=nfsecondd, & + nfday=nfday, & + nframe=nframe,ntrac=ntrac,nsoil=nsoil,extrameta=extrameta,nmeta=nmeta) + + write(6,*)' in gsi_nemsio_update, guess yr,mn,dy,hr,fhr=',idate(1:4),nfhour + fha=zero ; ida=0 ; jda=0 + fha(2)=nfhour + fha(3)=nfminute + ida(1)=idate(1) ! year + ida(2)=idate(2) ! month + ida(3)=idate(3) ! day + ida(4)=0 ! time zone + ida(5)=idate(4) ! hour + ida(6)=idate(5) ! minute + call w3movdat(fha,ida,jda) + jdate(1)=jda(1) ! new year + jdate(2)=jda(2) ! new month + jdate(3)=jda(3) ! new day + jdate(4)=jda(5) ! new hour + jdate(5)=jda(6) ! new minute + jdate(6)=0 ! new scaled seconds + jdate(7)=idate(7) ! new seconds multiplier + nfhour=0 ! new forecast hour + nfminute=0 + nfsecondn=0 + ntimestep=0 + + + call nemsio_setheadvar(gfile,'idate',jdate,iret) + write(6,*)' after setheadvar, jdate,iret=',jdate,iret + call nemsio_setheadvar(gfile,'nfhour',nfhour,iret) + write(6,*)' after setheadvar, nfhour,iret=',nfhour,iret + call nemsio_setheadvar(gfile,'nfminute',nfminute,iret) + write(6,*)' after setheadvar, nfminute,iret=',nfminute,iret + call nemsio_setheadvar(gfile,'nfsecondn',nfsecondn,iret) + write(6,*)' after setheadvar, nfsecondn,iret=',nfsecondn,iret + +! + idat(3)=jdate(1) ! forecast starting year + idat(2)=jdate(2) ! forecast starting month + idat(1)=jdate(3) ! forecast starting day + ihrst=jdate(4) ! forecast starting hour (0-23) + call nemsio_setheadvar(gfile,'idat',idat,iret) + write(6,*)' after setheadvar, idat,iret=',idat,iret + call nemsio_setheadvar(gfile,'ihrst',ihrst,iret) + write(6,*)' after setheadvar, ihrst,iret=',ihrst,iret + call nemsio_setheadvar(gfile,'ntimestep',ntimestep,iret) + write(6,*)' after setheadvar, ntimestep,iret=',ntimestep,iret + + + +! Following is diagnostic to check if date updated: + + call nemsio_getfilehead(gfile,iret=iret,nrec=nrec,dimx=im,dimy=jm, & + dimz=lm,idate=idate,gdatatype=gdatatype,gtype=gtype,modelname=modelname, & + nfhour=nfhour,nfminute=nfminute,nfsecondn=nfsecondn,nfsecondd=nfsecondd, & + nfday=nfday, & + nframe=nframe,ntrac=ntrac,nsoil=nsoil,extrameta=extrameta,nmeta=nmeta) + write(6,*)' in gsi_nemsio_update, analysis yr,mn,dy,hr,fhr=',idate(1:4),nfhour + call nemsio_getheadvar(gfile,'idat',idat,iret) + write(6,*)' check new idat after getheadvar, idat,iret=',idat,iret + call nemsio_getheadvar(gfile,'ihrst',ihrst,iret) + write(6,*)' check new ihrst after getheadvar, ihrst,iret=',ihrst,iret + call nemsio_getheadvar(gfile,'ntimestep',ntimestep,iret) + write(6,*)' check new ntimestep after getheadvar, ntimestep,iret=',ntimestep,iret + call nemsio_close(gfile,iret=iret) + if(iret/=0) then + write(6,*)trim(message),' problem closing file',trim(file_name),', Status = ',iret + call stop2(74) + end if + + end if + + end subroutine gsi_nemsio_update + + subroutine gsi_nemsio_close(file_name,message,mype,mype_io) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_close +! pgrmmr: +! +! abstract: +! +! program history log: +! 2009-08-04 lueken - added subprogram doc block +! +! input argument list: +! file_name +! message +! mype - mpi task id +! mype_io +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use nemsio_module, only: nemsio_close + implicit none + + character(*) ,intent(in ) :: file_name ! input file name + character(*) ,intent(in ) :: message ! info to appear in write statement on status of file open + integer(i_kind),intent(in ) :: mype,mype_io + + integer(i_kind) iret + + if(mype==mype_io) then + call nemsio_close(gfile,iret=iret) + if(iret/=0) then + write(6,*)trim(message),' problem closing file',trim(file_name),', Status = ',iret + call stop2(74) + end if + end if + deallocate(work_saved) + + end subroutine gsi_nemsio_close + + subroutine gsi_nemsio_read(varname,vartype,gridtype,lev,var,mype,mype_io,good_var) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_read +! pgrmmr: parrish +! +! abstract: intermediate level routine to read nmmb model fields using nems_io. +! the desired field is retrieved from the previously opened file as a +! full 2d horizontal field, then interpolated to the analysis grid +! from the nmmb model grid. finally, the 2d field is scattered from +! processor mype_io to subdomains in output array var. +! a copy of the original field on the nmmb grid is saved internally in array +! work_saved in case this field is to be updated by the analysis +! increment in a call to gsi_nemsio_write immediately after the call to +! gsi_nemsio_read. +! +! program history log: +! 2009-08-04 lueken - added subprogram doc block +! 2010-01-22 parrish - added optional variable good_var to detect read errors in calling program +! and have option to avoid program stop. +! 2013-10-25 todling - reposition ltosi and others to commvars +! +! input argument list: +! varname,vartype,gridtype - descriptors for variable to be retrieved from nmmb file +! lev - vertical level number +! mype - mpi task id +! mype_io - mpi task where field is read from disk +! good_var - optional, on input, set to .false. if present(good_var) then error stop is +! bypassed and good_var is returned .true. for successful read, .false. otherwise. +! +! output argument list: +! var - for successful read, contains desired variable on subdomains. +! good_var - see above +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpimod, only: mpi_rtype,mpi_comm_world,ierror,mpi_integer4 + use gridmod, only: lat2,lon2,nlon,nlat + use gridmod, only: ijn_s,displs_s,itotsub + use general_commvars_mod, only: ltosi_s,ltosj_s + use nemsio_module, only: nemsio_readrecv + use mod_nmmb_to_a, only: nmmb_h_to_a,nmmb_v_to_a + implicit none + + character(*) ,intent(in ) :: varname,vartype,gridtype ! gridtype='H' or 'V' + integer(i_kind),intent(in ) :: lev ! vertical level of desired variable + real(r_kind) ,intent( out) :: var(lat2*lon2) + integer(i_kind),intent(in ) :: mype,mype_io + logical,optional,intent(inout):: good_var + + integer(i_kind) i,iret,j,mm1,n + real(r_kind) work(itotsub) + real(r_kind) work_a(nlat,nlon) + real(r_single) work_b(nlon_regional*nlat_regional) + logical good_var_loc + + mm1=mype+1 + + if(mype==mype_io) then + +! read field from file with nemsio + + call nemsio_readrecv(gfile,trim(varname),trim(vartype),lev,work_b,iret=iret) + if(iret==0) then + work_saved=work_b + +! interpolate to analysis grid + + if(trim(gridtype)=='H') call nmmb_h_to_a(work_b,work_a) + if(trim(gridtype)=='V') call nmmb_v_to_a(work_b,work_a) + + +! scatter to subdomains + + do n=1,itotsub + i=ltosi_s(n) + j=ltosj_s(n) + work(n)=work_a(i,j) + end do + end if + end if + call mpi_bcast(iret,1,mpi_integer4,mype_io,mpi_comm_world,ierror) + good_var_loc=.true. + if(iret/=0) then + good_var_loc=.false. + if(mype==0) then + write(6,*)' problem reading varname=',trim(varname),', vartype=',trim(vartype),', Status = ',iret + if(.not.present(good_var)) call stop2(74) + end if + end if + if(present(good_var)) good_var=good_var_loc + + if(good_var_loc) & + call mpi_scatterv(work,ijn_s,displs_s,mpi_rtype, & + var,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + + end subroutine gsi_nemsio_read + + subroutine gsi_nemsio_read_fraction(varname_frain,varname_fice,varname_clwmr,varname_t, & + vartype,lev,var_qi,var_qs,var_qr,var_qw,mype,mype_io,good_var) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_read_fraction +! pgrmmr: Shun Liu +! +! abstract: copy from gsi_nemsio_read. To read in NMMB f_rain, f_ice, f_rime and +! T together and then convert to rain water mixing ratio and snow +! mixing ratio +! +! program history log: + +! 2015-06-5 S.Liu - read in f_rain, f_ice, f_rimef and T +! 2016-02-10 S.Liu - remove gridtype if-test since all variables are in mass point +! +! input argument list: +! varname,vartype,gridtype - descriptors for variable to be retrieved from +! nmmb file +! lev - vertical level number +! mype - mpi task id +! mype_io - mpi task where field is read from disk +! good_var - optional, on input, set to .false. if present(good_var) then +! error stop is +! bypassed and good_var is returned .true. for successful read, +! .false. otherwise. +! +! output argument list: +! var - for successful read, contains desired variable on subdomains. +! good_var - see above +! +! attributes: +! language: f90 +! machine: +! + +!$$$ end documentation block + use mpimod, only: mpi_rtype,mpi_comm_world,ierror,mpi_integer4 + use gridmod, only: lat2,lon2,nlon,nlat + use gridmod, only: ijn_s,displs_s,itotsub + use general_commvars_mod, only: ltosi_s,ltosj_s + use nemsio_module, only: nemsio_readrecv + use mod_nmmb_to_a, only: nmmb_h_to_a,nmmb_v_to_a + implicit none + + character(*) ,intent(in ) :: vartype ! gridtype='H' or 'V' + character(*) ,intent(in ) :: varname_frain, varname_fice, varname_clwmr, varname_t ! gridtype='H' or 'V' + integer(i_kind),intent(in ) :: lev ! vertical level of desired variable + + real(r_kind) ,intent( out) :: var_qi(lat2*lon2) + real(r_kind) ,intent( out) :: var_qs(lat2*lon2) + real(r_kind) ,intent( out) :: var_qr(lat2*lon2) + real(r_kind) ,intent( out) :: var_qw(lat2*lon2) + + integer(i_kind),intent(in ) :: mype,mype_io + logical,optional,intent(inout):: good_var + + integer(i_kind) i,iret,j,mm1,n + + real(r_kind) work_qi(itotsub) + real(r_kind) work_qs(itotsub) + real(r_kind) work_qr(itotsub) + real(r_kind) work_qw(itotsub) + + real(r_kind) work_a_qi(nlat,nlon) + real(r_kind) work_a_qs(nlat,nlon) + real(r_kind) work_a_qr(nlat,nlon) + real(r_kind) work_a_qw(nlat,nlon) + + real(r_single) work_b_frain(nlon_regional*nlat_regional) + real(r_single) work_b_fice(nlon_regional*nlat_regional) + real(r_single) work_b_clwmr(nlon_regional*nlat_regional) + real(r_single) work_b_t(nlon_regional*nlat_regional) + + real(r_single) work_b_qi(nlon_regional*nlat_regional) + real(r_single) work_b_qs(nlon_regional*nlat_regional) + real(r_single) work_b_qr(nlon_regional*nlat_regional) + real(r_single) work_b_qw(nlon_regional*nlat_regional) + + real(r_single) :: t, f_ice, f_rain, wc, qi, qs, qr, qw + logical good_var_loc + + mm1=mype+1 + + if(mype==mype_io) then + +! read field from file with nemsio + + call nemsio_readrecv(gfile,trim(varname_frain),trim(vartype),lev,work_b_frain,iret=iret) + call nemsio_readrecv(gfile,trim(varname_fice),trim(vartype),lev,work_b_fice,iret=iret) + call nemsio_readrecv(gfile,trim(varname_clwmr),trim(vartype),lev,work_b_clwmr,iret=iret) + call nemsio_readrecv(gfile,trim(varname_t),trim(vartype),lev,work_b_t,iret=iret) + + do n=1,nlon_regional*nlat_regional + t=work_b_t(n) + f_rain=work_b_frain(n) + f_ice=work_b_fice(n) + wc=work_b_clwmr(n) + call fraction2variable(t,f_ice,f_rain,wc,qi,qs,qr,qw) + work_b_qi(n)=qi + work_b_qs(n)=qs + work_b_qr(n)=qr + work_b_qw(n)=qw + end do + + if(iret==0) then +! work_saved=work_b + +! interpolate to analysis grid + + call nmmb_h_to_a(work_b_qi,work_a_qi) + call nmmb_h_to_a(work_b_qs,work_a_qs) + call nmmb_h_to_a(work_b_qr,work_a_qr) + call nmmb_h_to_a(work_b_qw,work_a_qw) + + +! scatter to subdomains + + do n=1,itotsub + i=ltosi_s(n) + j=ltosj_s(n) + work_qi(n)=work_a_qi(i,j) + work_qs(n)=work_a_qs(i,j) + work_qr(n)=work_a_qr(i,j) + work_qw(n)=work_a_qw(i,j) + end do + end if + end if + + call mpi_bcast(iret,1,mpi_integer4,mype_io,mpi_comm_world,ierror) + good_var_loc=.true. + if(iret/=0) then + good_var_loc=.false. + if(mype==0) then + write(6,*)' problem reading varname=',trim(varname_frain),', vartype=',trim(vartype),', Status = ',iret + if(.not.present(good_var)) call stop2(74) + end if + end if + if(present(good_var)) good_var=good_var_loc + + if(good_var_loc) then + call mpi_scatterv(work_qi,ijn_s,displs_s,mpi_rtype, & + var_qi,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_scatterv(work_qs,ijn_s,displs_s,mpi_rtype, & + var_qs,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_scatterv(work_qr,ijn_s,displs_s,mpi_rtype, & + var_qr,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_scatterv(work_qw,ijn_s,displs_s,mpi_rtype, & + var_qw,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + end if + + end subroutine gsi_nemsio_read_fraction + subroutine gsi_nemsio_write(varname,vartype,gridtype,lev,var,mype,mype_io,add_saved) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_write +! pgrmmr: +! +! abstract: +! +! program history log: +! 2009-08-04 lueken - added subprogram doc block +! 2013-10-25 todling - reposition ltosi and others to commvars +! +! input argument list: +! varname,vartype,gridtype +! lev +! add_saved +! mype - mpi task id +! mype_io +! +! output argument list: +! var +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpimod, only: mpi_rtype,mpi_comm_world,ierror + use gridmod, only: lat2,lon2,nlon,nlat,lat1,lon1 + use gridmod, only: ijn,displs_g,itotsub,iglobal + use general_commvars_mod, only: ltosi,ltosj + use nemsio_module, only: nemsio_writerecv + use mod_nmmb_to_a, only: nmmb_a_to_h,nmmb_a_to_v + implicit none + + character(*) ,intent(in ) :: varname,vartype,gridtype ! gridtype='H' or 'V' + integer(i_kind),intent(in ) :: lev ! vertical level of desired variable + real(r_kind) ,intent(in ) :: var(lat2,lon2) + integer(i_kind),intent(in ) :: mype,mype_io + logical ,intent(in ) :: add_saved + + integer(i_kind) i,iret,j,mm1,n + real(r_kind) work(itotsub),work_sub(lat1,lon1) + real(r_kind) work_a(nlat,nlon) + real(r_single) work_b(nlon_regional*nlat_regional) + + mm1=mype+1 + + do i=1,lon1 + do j=1,lat1 + work_sub(j,i)=var(j+1,i+1) + end do + end do + call mpi_gatherv(work_sub,ijn(mm1),mpi_rtype, & + work,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + if(mype==mype_io) then + do n=1,iglobal + i=ltosi(n) + j=ltosj(n) + work_a(i,j)=work(n) + end do + if(trim(gridtype)=='H') call nmmb_a_to_h(work_a,work_b) + if(trim(gridtype)=='V') call nmmb_a_to_v(work_a,work_b) + if(add_saved) work_b=work_b+work_saved + call nemsio_writerecv(gfile,trim(varname),trim(vartype),lev,work_b,iret=iret) + if(iret/=0) then + write(6,*)' problem writing varname=',trim(varname),', vartype=',trim(vartype),', Status = ',iret + call stop2(74) + end if + end if + + end subroutine gsi_nemsio_write + + subroutine gsi_nemsio_write_fraction(varname_frain,varname_fice,vartype,lev,var_t,var_i,var_r,var_l,mype,mype_io) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_write_fraction +! pgrmmr: Shun Liu +! +! abstract: +! +! program history log: +! 2015-05-12 S.Liu - copy from gsi_nemsio_write and modify to handle NMMB hydrometor fraction variable +! +! input argument list: +! varname,vartype,gridtype +! lev +! add_saved +! mype - mpi task id +! mype_io +! +! output argument list: +! var_frain, var_fice +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpimod, only: mpi_rtype,mpi_comm_world,ierror + use gridmod, only: lat2,lon2,nlon,nlat,lat1,lon1 + use gridmod, only: ijn,displs_g,itotsub,iglobal + use general_commvars_mod, only: ltosi,ltosj + use nemsio_module, only: nemsio_writerecv + use mod_nmmb_to_a, only: nmmb_a_to_h,nmmb_a_to_v + implicit none + + character(*) ,intent(in ) :: varname_frain,varname_fice,vartype ! gridtype='H' or 'V' + integer(i_kind),intent(in ) :: lev ! vertical level of desired variable + real(r_kind) ,intent(in ) :: var_i(lat2,lon2), var_r(lat2,lon2), var_l(lat2,lon2), var_t(lat2,lon2) + integer(i_kind),intent(in ) :: mype,mype_io +! logical ,intent(in ) :: add_saved + + integer(i_kind) i,iret,j,mm1,n + real(r_kind) work_t(itotsub),work_sub_t(lat1,lon1) + real(r_kind) work_a_t(nlat,nlon) + real(r_single) work_b_t(nlon_regional*nlat_regional) + + real(r_kind) work_i(itotsub),work_sub_i(lat1,lon1) + real(r_kind) work_a_i(nlat,nlon) + real(r_single) work_b_i(nlon_regional*nlat_regional) + + real(r_kind) work_r(itotsub),work_sub_r(lat1,lon1) + real(r_kind) work_a_r(nlat,nlon) + real(r_single) work_b_r(nlon_regional*nlat_regional) + + real(r_kind) work_l(itotsub),work_sub_l(lat1,lon1) + real(r_kind) work_a_l(nlat,nlon) + real(r_single) work_b_l(nlon_regional*nlat_regional) + + real(r_single) work_b_frain(nlon_regional*nlat_regional) + real(r_single) work_b_fice(nlon_regional*nlat_regional) + real(r_single) t,qfi,qfr,qfw,f_rain,f_ice + + mm1=mype+1 + + do i=1,lon1 + do j=1,lat1 + work_sub_t(j,i)=var_t(j+1,i+1) + work_sub_i(j,i)=var_i(j+1,i+1) + work_sub_r(j,i)=var_r(j+1,i+1) + work_sub_l(j,i)=var_l(j+1,i+1) + end do + end do +! write(6,*)'writeout1', maxval(work_sub_t),maxval(work_sub_i),maxval(work_sub_r) + call mpi_gatherv(work_sub_t,ijn(mm1),mpi_rtype, & + work_t,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_gatherv(work_sub_i,ijn(mm1),mpi_rtype, & + work_i,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_gatherv(work_sub_r,ijn(mm1),mpi_rtype, & + work_r,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_gatherv(work_sub_l,ijn(mm1),mpi_rtype, & + work_l,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) +! write(6,*)'writeout2', maxval(work_t),maxval(work_i),maxval(work_r) + if(mype==mype_io) then + do n=1,iglobal + i=ltosi(n) + j=ltosj(n) + work_a_t(i,j)=work_t(n) + work_a_i(i,j)=work_i(n) + work_a_r(i,j)=work_r(n) + work_a_l(i,j)=work_l(n) + end do +! write(6,*)'writeout3', maxval(work_a_r),maxval(work_a_l) + + call nmmb_a_to_h(work_a_t,work_b_t) + call nmmb_a_to_h(work_a_i,work_b_i) + call nmmb_a_to_h(work_a_r,work_b_r) + call nmmb_a_to_h(work_a_l,work_b_l) + +! if(trim(gridtype)=='V') call nmmb_a_to_v(work_a_t,work_b_i) +! if(trim(gridtype)=='V') call nmmb_a_to_v(work_a_i,work_b_i) +! if(trim(gridtype)=='V') call nmmb_a_to_v(work_a_r,work_b_r) +! if(trim(gridtype)=='V') call nmmb_a_to_v(work_a_l,work_b_l) + +! if(add_saved) work_b_t=work_b_t+work_saved_t +! if(add_saved) work_b_i=work_b_i+work_saved_i +! if(add_saved) work_b_r=work_b_r+work_saved_r +! if(add_saved) work_b_l=work_b_l+work_saved_l +! write(6,*)'writeout4', maxval(work_b_r),maxval(work_b_l) +! write(6,*)'writeout44',nlon_regional,nlat_regional,nlon,nlat + do n=1,nlon_regional*nlat_regional + t=work_b_t(n) + qfi=work_b_i(n) + qfr=work_b_r(n) + qfw=work_b_l(n) + call variable2fraction(t, qfi, qfr, qfw, f_ice, f_rain) + work_b_frain(n)=f_rain + work_b_fice(n)=f_ice +! work_b_frain(n)=qfr +! work_b_fice(n)=qfw + end do + + call nemsio_writerecv(gfile,trim(varname_frain),trim(vartype),lev,work_b_frain,iret=iret) + call nemsio_writerecv(gfile,trim(varname_fice),trim(vartype),lev,work_b_fice,iret=iret) +! write(6,*)'writeout5', maxval(work_b_frain),maxval(work_b_fice) + + if(iret/=0) then + write(6,*)' problem writing varname=',trim(varname_frain),', vartype=',trim(vartype),', Status = ',iret + call stop2(74) + end if + end if + + end subroutine gsi_nemsio_write_fraction + + Subroutine fraction2variable(t,f_ice,f_rain, wc, qi,qs,qr,qw) + +!$$$ subprogram documentation block +! . . . . +! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor +! analysis +! +! PRGMMR: Shun Liu ORG: EMC/NCEP DATE: 2015-05-28 +! +! ABSTRACT: +! This subroutine fraction to qi, qs, qr, qw +! +! PROGRAM HISTORY LOG: +! 2015-05-28 Shun Liu Add NCO document block +! 2016-06-21 Shun Liu give number precisio and remove f_rimef +! +! +! input argument list: +! mype - processor ID that does this IO +! +! output argument list: +! +! USAGE: +! INTPUT: +! t - sensible temperature +! f_ice - fraction of condensate in form of ice +! f_rain - fraction of liquid water in form of rain +! f_rimef - ratio of total ice growth to deposition groth +! OUTPUT +! qi - cloud ice mixing ratio +! qs - large ice mixing ratio +! qr - rain mixing ratio +! qw - cloud water mixing ratio +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: WCOSS at NOAA/ESRL - college park, DC +! +!$$$ + + use kinds, only: r_kind,r_single + + real(r_single) t, qi,qs, qr, qw, wc + real(r_single) f_ice, f_rain + real(r_single),parameter:: epsq=1.e-12_r_single + real(r_single),parameter:: tice=233.15_r_single,ticek=273.15_r_single + real(r_single),parameter:: tice_mix=243.15_r_single + real(r_single) ::t1,t2, coef1, coef2, coef + + + qi=0.0_r_single; qs=0.0_r_single; qr=0.0_r_single; qw=0.0_r_single + if(wc > 0.0_r_single) then + + if(f_ice>1.0_r_single) f_ice=1.0_r_single + if(f_ice<0.0_r_single) f_ice=0.0_r_single + if(f_rain>1.0_r_single) f_rain=1.0_r_single + if(f_rain<0.0_r_single) f_rain=0.0_r_single + + qi=0.05_r_single*wc*f_ice + qs=0.95_r_single*wc*f_ice + + if(t<=tice_mix)then + t1=tice_mix + t2=tice + coef1=0.05_r_single + coef2=0.10_r_single + coef=(t-t2)/(t1-t2)*coef1+(t-t1)/(t2-t1)*coef2 + qi=coef*wc*f_ice + qs=(1.0_r_single-coef)*wc*f_ice + end if + +!* do not consider frime at the moment + qr=wc*(1.0_r_single-f_ice)*f_rain + qw=wc*(1.0_r_single-f_ice)*(1.0_r_single-f_rain) + end if + + end subroutine fraction2variable + + + subroutine variable2fraction(t, qi, qr, qw, f_ice, f_rain) + +!$$$ subprogram documentation block +! . . . . +! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor analysis +! +! PRGMMR: Shun Liu ORG: EMC/NCEP DATE: 2012-10-24 +! +! ABSTRACT: +! This subroutine qi qr qw to fraction +! +! PROGRAM HISTORY LOG: +! 2013-10-18 Shun Liu Add NCO document block +! 2015-11-16 Shun Liu move from gsdcldanalysis4nmmb.F90 to this module +! 2016-06-21 Shun Liu give number precisio +! +! +! input argument list: +! mype - processor ID that does this IO +! +! output argument list: +! +! USAGE: +! INPUT +! qi - cloud ice mixing ratio +! qr - rain mixing ratio +! qw - cloud water mixing ratio +! OUTPUT: +! f_ice - fraction of condensate in form of ice +! f_rain - fraction of liquid water in form of rain +! f_rimef - ratio of total ice growth to deposition groth +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: WCOSS at NOAA/ESRL - college park, DC +! +!$$$ + + use kinds, only: r_kind,r_single + + real(r_single) t, qi, qr, qw, wc, dum + real(r_single) f_ice, f_rain + real(r_single),parameter:: epsq=1.e-12_r_single + real(r_single),parameter:: tice=233.15_r_single,ticek=273.15_r_single + + wc=qi+qr+qw + if(wc > 0.0_r_single) then + if(qi %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use o3l_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: stats => rhs_stats_oz + use obsmod, only: write_diag + use ozinfo, only: diag_ozone + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(o3lOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + + diagsave = write_diag(jiter) .and. diag_ozone + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,stats,nchanl,nreal,nobs,obstype,isis,is,diagsave,init_pass) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use into3lmod, only: intjo => intozlev + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(o3lOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpo3lmod, only: stpjo => stpozlev + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(o3lOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_o3lOper diff --git a/src/gsi/gsi_obOper.F90 b/src/gsi/gsi_obOper.F90 new file mode 100644 index 000000000..0b0716159 --- /dev/null +++ b/src/gsi/gsi_obOper.F90 @@ -0,0 +1,370 @@ +module gsi_obOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_obOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-06-26 +! +! abstract: GSI observation operator, bundling obs_diags and obsLList objects +! +! program history log: +! 2018-06-26 j guo - a new module for abstract GSI obOper. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use m_obsdiagNode, only: obs_diags + use m_obsLList , only: obsLList + + use kinds, only: i_kind + use mpeu_util, only: assert_ + implicit none + private ! except + public :: obOper ! data structure + public :: len_obstype + public :: len_isis + + integer(i_kind),parameter:: len_obstype=10 + integer(i_kind),parameter:: len_isis =20 + + ! obOper is a bundle of observation operator arrays (or lists), such as + ! linked-lists of obs_diag (obs_diags) and obsNode (obsLList), plus type + ! specific parameters. + ! + ! In this implementation, an obOper, with pointers _associated_ to + ! rank-1 arrays of obs_diags and obsLList, where both targets are + ! instantiated separately with own fixed dimensions in nobs_type and + ! nobs_bins. + ! + ! It is planned in the future, to implement an obOper _contains_ dynamic + ! components of these rank-1 arrays. + + type,abstract:: obOper + !private + ! In the first obOper implementation, %obsLL(:) and odiagLL(:) are + ! treated as aliases to the instances of m_obsdiags::obsdiags(:,:) and + ! m_obsdiagss::obsLLists(:,:). Both linked-lists are dimensioned for + ! 1:nobs_type in the current implementation, and accesssed once per type + ! and per bin, in intjo() and stpjo(). + ! + ! On the other hand, in the current setuprhsall() implementation, obOper + ! objects are accessed for 1:ndat, or once per obs-stream, where each + ! type is in general accessed in zero or multiple times. + + type(obs_diags),pointer,dimension(:):: odiagLL ! (1:nobs_bins) + type(obsLList ),pointer,dimension(:):: obsLL ! (1:nobs_bins) + + contains + procedure(mytype ),deferred,nopass:: mytype ! type information + procedure(nodeMold),deferred,nopass:: nodeMold ! type information + + procedure, non_overridable:: init => init_ ! initialize + procedure, non_overridable:: clean => clean_ ! finalize + + generic:: setup => setup_ + procedure(setup_ ),deferred:: setup_ ! incremental object initialization + generic:: intjo => intjo_, intjo1_ + procedure, non_overridable:: intjo_ ! interface supporting intjo() + procedure(intjo1_),deferred:: intjo1_ ! interface for 1-bin intjo() + generic:: stpjo => stpjo_, stpjo1_ + procedure, non_overridable:: stpjo_ ! interface supporting stpjo() + procedure(stpjo1_),deferred:: stpjo1_ ! interface for 1-bin stpjo() + + end type obOper + + ! In setuprhsall(), + ! + ! | use m_obsdiags, only: obOper_associate, obOper_dissociate + ! | use gsi_obOper, only: obOper + ! | use gsi_obOperTypeManager, only: obOper_typeMold + ! | use obsmod, only: ndat,dtype + ! + ! then in a loop of obs-streams + ! + ! | class(obOper),pointer:: my_obOper + ! | do is=1,ndat + ! | my_obOper => obOper_associate(obOper_typeMold(dtype(is))) + ! | call my_obOper%setup(...) + ! | call obOper_dissociate(my_obOper) + ! | enddo + ! + + ! In intjo() or stpjo(), + ! + ! | use gsi_obOperTypeManager, only: lbound_obOper + ! | use gsi_obOperTypeManager, only: ubound_obOper + ! | use gsi_obOperTypeManager, only: obOper_typeMold + ! + ! then in a loop of obOper + ! + ! | class(obOper),pointer:: my_obOper + ! | do iOp=lbound_obOper,ubound_obOper + ! | my_obOper => obOper_associate(obOper_typeMold(iOp)) + ! | call my_obOper%intjo(...) + ! | call obOper_dissociate(my_obOper) + ! | enddo + +!--- Design Considerations --- +! (1) Fully objectize obOper, meaning, capable of being instantiated where and +! when it is needed. +! +! +! (2) For continuity, its instantiation is a type-indexed array of polymorphic +! class(obOper), containing rank-1 pointers aliased to obsLList(1:nobs_bins) +! and diagLList(1:nobs_bins). This means its current instantiation is +! declared based on a type-wrapper-array structure, +! +! type,abstract:: obOper; ... +! type:: obOper_element; class(obOper),pointer:: ptr; ... +! type(obOper_element),dimension(nobs_type):: obopers +! +! defined in a type-loop, (m_obsdiags?) +! +! allocate(obopers(it)%ptr,mold=obOper_typeMold(it)) +! +! | oboper_typeMold(it) result(mold) +! | select case(it) +! | case(iobType_rad); mold => radOper_mold() +! | case ... +! +! followed by +! +! associate(i_op => obopers(...)%ptr) +! call i_op%init(...) # type-bound init(), with a line of +! # self%nodetype=obOper%mytype(nodetype=.true.) +! end associate +! +! +! (3) In future implementations, one might want to define obOper on a per-stream +! base. Then it would be instantiated in a stream-loop, +! +! allocate(obopers(is)%ptr,mold=obOper_typeMold(dtype(is))) +! +! | oboper_typeMold(dtype) result(mold) +! | select case(dtype) +! | case("rad","amsua",...); mold => radOper_mold() +! | case ... +! +! (4) So types of obOpers are now one-to-one mapped to obsNode types. This means +! that each obOper type must be hardwired to a known obsNode type, while +! dtype(:) to obOpers(:) types are not. +! + +!--------- interfaces +abstract interface + function mytype(nodetype) + ! %mytype() for self's typename + ! %mytype(nodetype=.true.) for self's corresponding node type name + implicit none + character(len=:), allocatable:: mytype + logical, optional, intent(in):: nodetype ! if .true., return %mytype() of its obsNode + + ! logical:: nodetype_ + ! nodetype_=.false. + ! if(present(nodetype)) nodetype_=nodetype + ! if(nodetype_) then + ! if(nodetype) mytype=myNodeMold_%mytype() + ! else + ! mytype="[radOper]" + ! endif + + end function mytype +end interface + +abstract interface + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + + !> For a given + !> type(someOper):: myOper + !> + !> then code + !> + !> class(obsNode),pointer:: myNodeMold_ + !> myNodeMold_ => myOper%nodeMold() + !> + !> would return a mold of myOper's corresponding obsNode type + + end function nodeMold +end interface + +abstract interface + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use kinds, only: i_kind + import:: obOper + implicit none + class(obOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + ! An example in radOper%setup(), + ! + ! if(nobs == 0) return + ! + ! read(lunin,iostat=ier) obstype,isis,nreal,nchanl + ! if(ier/=0) call die(myname_,'read(), iostat =',ier) + ! nele=nreal+nchanl + ! + ! call setuprad(self%obsLL(:),self%odiagLL(:), lunin, mype, & + ! aivals,stats,nchanl,nreal,nobs,obstype,isis,is,rad_diagsave,init_pass,last_pass) + + end subroutine setup_ +end interface + +abstract interface + !>> This is the interface for single bin intjo(). + !>> call self%intjo(ib,rval(ib),sval(ib),qpred(:,ib),sbias) + + subroutine intjo1_(self, ibin, rval, sval, qpred, sbias) + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use kinds , only: i_kind, r_quad + import:: obOper + implicit none + class(obOper ), intent(in ):: self + integer(i_kind ), intent(in ):: ibin + type(gsi_bundle), intent(inout):: rval + type(gsi_bundle), intent(in ):: sval + real(r_quad ), target, dimension(:),intent(inout):: qpred ! a buffer of rbias + type(predictors), target, intent(in ):: sbias + + ! This implementation can be used both to an obOper instance with + ! multiple bins, or a "slice" of obOper instance with a single bin, + ! where the slice of self contains arrays (ibin:ibin) of components. + + !do ibin=lbound(self%obsLL,1),ubound(self%obsLL,1) + ! call self%intjo(ibin, rval(ibin),sval(ibin), qpred(:,ibin),sbias) + !enddo + end subroutine intjo1_ +end interface + +abstract interface + !>> This is the interface for single bin stpjo(). + !>> call self%stpjo(ib,dval(ib),xval(ib),pbcjo(:,it,ib),sges,nstep,dbias,xbias) + + subroutine stpjo1_(self, ibin,dval,xval,pbcjo,sges,nstep,dbias,xbias) + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use kinds , only: r_quad,r_kind,i_kind + import:: obOper + implicit none + class(obOper ),intent(in):: self + integer(i_kind),intent(in):: ibin + + type(gsi_bundle),intent(in ):: dval + type(gsi_bundle),intent(in ):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind ), intent(in ):: nstep + type(predictors), target, intent(in):: dbias + type(predictors), target, intent(in):: xbias + + end subroutine stpjo1_ +end interface + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=*),parameter:: myname="gsi_obOper" + +contains +#include "myassert.H" + +subroutine init_(self,obsLL,odiagLL) + implicit none + class(obOper),intent(inout):: self + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + self%odiagLL => odiagLL(:) + self% obsLL => obsLL(:) +end subroutine init_ + +subroutine clean_(self) + implicit none + class(obOper),intent(inout):: self + self%odiagLL => null() + self% obsLL => null() +end subroutine clean_ + +subroutine intjo_(self, rval,sval,qpred,sbias) + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use kinds, only: i_kind, r_quad + implicit none + class(obOper ), intent(in):: self + type(gsi_bundle), dimension(: ),intent(inout):: rval + type(gsi_bundle), dimension(: ),intent(in ):: sval + real(r_quad ), dimension(:,:),intent(inout):: qpred + type(predictors) ,intent(in ):: sbias + + ! nb=nobs_bins + ! do ityp=1,nobs_type + ! iop => obOper_associate(mold=obOper_typemold(ityp)) + ! call iop%intjo(rval(:nb),sval(:nb), qpred(:,:nb),sbias) + ! call obOper_dissociate(iop) + ! enddo + ! + ! This implementation can be used both to an obOper instance with + ! multiple bins, or a "slice" of obOper instance with a single bin, + ! where the slice of self contains arrays (ibin:ibin) of components. + + character(len=*),parameter:: myname_=myname//"::intjo_" + integer(i_kind):: lbnd,ubnd,ibin + + lbnd = lbound(self%obsLL,1) + ubnd = ubound(self%obsLL,1) + ASSERT(lbnd == lbound( rval,1) .and. ubnd == ubound( rval,1)) + ASSERT(lbnd == lbound( sval,1) .and. ubnd == ubound( sval,1)) + ASSERT(lbnd == lbound(qpred,2) .and. ubnd == ubound(qpred,2)) + + do ibin=lbnd,ubnd + call self%intjo(ibin,rval(ibin),sval(ibin),qpred(:,ibin),sbias) + enddo +end subroutine intjo_ + +subroutine stpjo_(self, dval,xval, pbcjo,sges,nstep, dbias,xbias) + use kinds, only: r_quad,r_kind,i_kind + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + implicit none + class(obOper ),intent(in):: self + type(gsi_bundle),dimension( :),intent(in ):: dval + type(gsi_bundle),dimension( :),intent(in ):: xval + real(r_quad ),dimension(:,:),intent(inout):: pbcjo ! (1:4,1:nbin) + real(r_kind ),dimension(: ),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors), intent(in):: dbias + type(predictors), intent(in):: xbias + + integer(i_kind):: lbnd,ubnd,ibin + + lbnd = lbound(self%obsLL,1) + ubnd = ubound(self%obsLL,1) + ASSERT(lbnd == lbound( dval,1) .and. ubnd == ubound( dval,1)) + ASSERT(lbnd == lbound( xval,1) .and. ubnd == ubound( xval,1)) + ASSERT(lbnd == lbound(pbcjo,2) .and. ubnd == ubound(pbcjo,2)) + + do ibin=lbnd,ubnd + call self%stpjo(ibin,dval(ibin),xval(ibin),pbcjo(:,ibin),sges,nstep,dbias,xbias) + enddo +end subroutine stpjo_ +end module gsi_obOper +!. diff --git a/src/gsi/gsi_obOperTypeManager.F90 b/src/gsi/gsi_obOperTypeManager.F90 new file mode 100644 index 000000000..9af3a62a7 --- /dev/null +++ b/src/gsi/gsi_obOperTypeManager.F90 @@ -0,0 +1,606 @@ +module gsi_obOperTypeManager +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_obOperTypeManager +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-07-12 +! +! abstract: GSI observation operator (obOper) type manager +! +! program history log: +! 2018-07-12 j guo - a type-manager for all obOper extensions. +! - an enum mapping of obsinput::dtype(:) to obOper type +! extensions. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + + use gsi_aeroOper , only: aeroOper + use gsi_cldchOper , only: cldchOper + use gsi_colvkOper , only: colvkOper + use gsi_dwOper , only: dwOper + use gsi_gpsbendOper , only: gpsbendOper + use gsi_gpsrefOper , only: gpsrefOper + use gsi_gustOper , only: gustOper + use gsi_howvOper , only: howvOper + use gsi_lcbasOper , only: lcbasOper + use gsi_lwcpOper , only: lwcpOper + use gsi_mitmOper , only: mitmOper + use gsi_mxtmOper , only: mxtmOper + use gsi_o3lOper , only: o3lOper + use gsi_ozOper , only: ozOper + use gsi_pblhOper , only: pblhOper + use gsi_pcpOper , only: pcpOper + use gsi_pm10Oper , only: pm10Oper + use gsi_pm2_5Oper , only: pm2_5Oper + use gsi_pmslOper , only: pmslOper + use gsi_psOper , only: psOper + use gsi_pwOper , only: pwOper + use gsi_qOper , only: qOper + use gsi_radOper , only: radOper + use gsi_rwOper , only: rwOper + use gsi_spdOper , only: spdOper + use gsi_sstOper , only: sstOper + use gsi_swcpOper , only: swcpOper + use gsi_tcamtOper , only: tcamtOper + use gsi_tcpOper , only: tcpOper + use gsi_td2mOper , only: td2mOper + use gsi_tOper , only: tOper + use gsi_uwnd10mOper , only: uwnd10mOper + use gsi_visOper , only: visOper + use gsi_vwnd10mOper , only: vwnd10mOper + use gsi_wOper , only: wOper + use gsi_wspd10mOper , only: wspd10mOper + + use gsi_lightOper , only: lightOper + use gsi_dbzOper , only: dbzOper + use gsi_cldtotOper , only: cldtotOper + + use kinds , only: i_kind + use mpeu_util , only: perr,die + implicit none + private ! except + + public:: obOper_typeMold + public:: obOper_typeIndex + public:: obOper_typeInfo + interface obOper_typeMold; module procedure & + dtype2vmold_, & + index2vmold_ ; end interface + interface obOper_typeIndex; module procedure & + vmold2index_, & + dtype2index_ ; end interface + interface obOper_typeInfo; module procedure & + vmold2tinfo_, & + index2tinfo_ ; end interface + + !public:: obOper_config + ! interface obOper_config; module procedure config_; end interface + + public:: obOper_undef + public:: obOper_lbound + public:: obOper_ubound + !public:: obOper_size + public:: obOper_count + + public:: iobOper_kind + public:: iobOper_ps + public:: iobOper_t + public:: iobOper_w + public:: iobOper_q + public:: iobOper_spd + public:: iobOper_rw + public:: iobOper_dw + public:: iobOper_sst + public:: iobOper_pw + public:: iobOper_pcp + public:: iobOper_oz + public:: iobOper_o3l + public:: iobOper_gpsbend + public:: iobOper_gpsref + public:: iobOper_rad + public:: iobOper_tcp + !public:: iobOper_lag + public:: iobOper_colvk + public:: iobOper_aero + !public:: iobOper_aerol + public:: iobOper_pm2_5 + public:: iobOper_gust + public:: iobOper_vis + public:: iobOper_pblh + public:: iobOper_wspd10m + public:: iobOper_td2m + public:: iobOper_mxtm + public:: iobOper_mitm + public:: iobOper_pmsl + public:: iobOper_howv + public:: iobOper_tcamt + public:: iobOper_lcbas + public:: iobOper_pm10 + public:: iobOper_cldch + public:: iobOper_uwnd10m + public:: iobOper_vwnd10m + public:: iobOper_swcp + public:: iobOper_lwcp + public:: iobOper_light + public:: iobOper_dbz + public:: iobOper_cldtot + + enum, bind(C) + enumerator:: iobOper_zero_ = 0 + + enumerator:: iobOper_ps + enumerator:: iobOper_t + enumerator:: iobOper_w + enumerator:: iobOper_q + enumerator:: iobOper_spd + enumerator:: iobOper_rw + enumerator:: iobOper_dw + enumerator:: iobOper_sst + enumerator:: iobOper_pw + enumerator:: iobOper_pcp + enumerator:: iobOper_oz + enumerator:: iobOper_o3l + enumerator:: iobOper_gpsbend + enumerator:: iobOper_gpsref + enumerator:: iobOper_rad + enumerator:: iobOper_tcp + !enumerator:: iobOper_lag + enumerator:: iobOper_colvk + enumerator:: iobOper_aero + !enumerator:: iobOper_aerol + enumerator:: iobOper_pm2_5 + enumerator:: iobOper_gust + enumerator:: iobOper_vis + enumerator:: iobOper_pblh + enumerator:: iobOper_wspd10m + enumerator:: iobOper_td2m + enumerator:: iobOper_mxtm + enumerator:: iobOper_mitm + enumerator:: iobOper_pmsl + enumerator:: iobOper_howv + enumerator:: iobOper_tcamt + enumerator:: iobOper_lcbas + enumerator:: iobOper_pm10 + enumerator:: iobOper_cldch + enumerator:: iobOper_uwnd10m + enumerator:: iobOper_vwnd10m + enumerator:: iobOper_swcp + enumerator:: iobOper_lwcp + enumerator:: iobOper_light + enumerator:: iobOper_dbz + enumerator:: iobOper_cldtot + + enumerator:: iobOper_extra_ + end enum + + integer(i_kind),parameter:: enum_kind = kind(iobOper_zero_) + integer(i_kind),parameter:: iobOper_kind = enum_kind + + integer(enum_kind),parameter:: obOper_undef = -1_enum_kind + integer(enum_kind),parameter:: obOper_lbound = iobOper_zero_ +1 + integer(enum_kind),parameter:: obOper_ubound = iobOper_extra_-1 + integer(enum_kind),parameter:: obOper_size = obOper_ubound-obOper_lbound+1 + integer(enum_kind),parameter:: obOper_count = obOper_size + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_obOperTypeManager' + logical,save:: obOper_configured_ = .false. + + character(len=20),dimension(obOper_lbound:obOper_ubound):: cobstype + logical,save:: cobstype_configured_=.false. + + type( psOper), target, save:: psOper_mold + type( tOper), target, save:: tOper_mold + type( wOper), target, save:: wOper_mold + type( qOper), target, save:: qOper_mold + type( spdOper), target, save:: spdOper_mold + type( rwOper), target, save:: rwOper_mold + type( dwOper), target, save:: dwOper_mold + type( sstOper), target, save:: sstOper_mold + type( pwOper), target, save:: pwOper_mold + type( pcpOper), target, save:: pcpOper_mold + type( ozOper), target, save:: ozOper_mold + type( o3lOper), target, save:: o3lOper_mold + type(gpsbendOper), target, save:: gpsbendOper_mold + type( gpsrefOper), target, save:: gpsrefOper_mold + type( radOper), target, save:: radOper_mold + type( tcpOper), target, save:: tcpOper_mold + !type( lagOper), target, save:: lagOper_mold + type( colvkOper), target, save:: colvkOper_mold + type( aeroOper), target, save:: aeroOper_mold + !type( aerolOper), target, save:: aerolOper_mold + type( pm2_5Oper), target, save:: pm2_5Oper_mold + type( gustOper), target, save:: gustOper_mold + type( visOper), target, save:: visOper_mold + type( pblhOper), target, save:: pblhOper_mold + type(wspd10mOper), target, save:: wspd10mOper_mold + type( td2mOper), target, save:: td2mOper_mold + type( mxtmOper), target, save:: mxtmOper_mold + type( mitmOper), target, save:: mitmOper_mold + type( pmslOper), target, save:: pmslOper_mold + type( howvOper), target, save:: howvOper_mold + type( tcamtOper), target, save:: tcamtOper_mold + type( lcbasOper), target, save:: lcbasOper_mold + type( pm10Oper), target, save:: pm10Oper_mold + type( cldchOper), target, save:: cldchOper_mold + type(uwnd10mOper), target, save:: uwnd10mOper_mold + type(vwnd10mOper), target, save:: vwnd10mOper_mold + type( swcpOper), target, save:: swcpOper_mold + type( lwcpOper), target, save:: lwcpOper_mold + type( lightOper), target, save:: lightOper_mold + type( dbzOper), target, save:: dbzOper_mold + type( cldtotOper), target, save:: cldtotOper_mold + +contains +function dtype2index_(dtype) result(index_) + use mpeu_util, only: lowercase + implicit none + integer(i_kind):: index_ + character(len=*),intent(in):: dtype + + select case(lowercase(dtype)) + case("ps" ,"[psoper]" ); index_= iobOper_ps + case("t" ,"[toper]" ); index_= iobOper_t + + case("w" ,"[woper]" ); index_= iobOper_w + case("uv" ); index_= iobOper_w + + case("q" ,"[qoper]" ); index_= iobOper_q + case("spd" ,"[spdoper]" ); index_= iobOper_spd + case("rw" ,"[rwoper]" ); index_= iobOper_rw + case("dw" ,"[dwoper]" ); index_= iobOper_dw + case("sst" ,"[sstoper]" ); index_= iobOper_sst + case("pw" ,"[pwoper]" ); index_= iobOper_pw + + case("pcp" ,"[pcpoper]" ); index_= iobOper_pcp + case("pcp_ssmi"); index_= iobOper_pcp + case("pcp_tmi" ); index_= iobOper_pcp + + case("oz" ,"[ozoper]" ); index_= iobOper_oz + case("sbuv2" ); index_= iobOper_oz + case("omi" ); index_= iobOper_oz + case("gome" ); index_= iobOper_oz + case("ompstc8"); index_= iobOper_oz + case("ompsnp" ); index_= iobOper_oz + case("ompsnm" ); index_= iobOper_oz + + case("o3l" ,"[o3loper]" ); index_= iobOper_o3l + case("o3lev" ); index_= iobOper_o3l + case("mls20" ); index_= iobOper_o3l + case("mls22" ); index_= iobOper_o3l + case("mls30" ); index_= iobOper_o3l + case("mls55" ); index_= iobOper_o3l + case("omieff" ); index_= iobOper_o3l + case("tomseff" ); index_= iobOper_o3l + case("ompslpuv" ); index_= iobOper_o3l + case("ompslpvis"); index_= iobOper_o3l + case("ompslp" ); index_= iobOper_o3l + + case("gpsbend","[gpsbendoper]"); index_= iobOper_gpsbend + case("gps_bnd"); index_= iobOper_gpsbend + + case("gpsref" ,"[gpsrefoper]" ); index_= iobOper_gpsref + case("gps_ref"); index_= iobOper_gpsref + + case("rad" ,"[radoper]" ); index_= iobOper_rad + ! + case("abi" ); index_= iobOper_rad + ! + case("amsua" ); index_= iobOper_rad + case("amsub" ); index_= iobOper_rad + case("msu" ); index_= iobOper_rad + case("mhs" ); index_= iobOper_rad + case("hirs2" ); index_= iobOper_rad + case("hirs3" ); index_= iobOper_rad + case("hirs4" ); index_= iobOper_rad + case("ssu" ); index_= iobOper_rad + ! + case("atms" ); index_= iobOper_rad + case("saphir" ); index_= iobOper_rad + ! + case("airs" ); index_= iobOper_rad + case("hsb" ); index_= iobOper_rad + ! + case("iasi" ); index_= iobOper_rad + case("cris" ); index_= iobOper_rad + case("cris-fsr" ); index_= iobOper_rad + ! + case("sndr" ); index_= iobOper_rad + case("sndrd1" ); index_= iobOper_rad + case("sndrd2" ); index_= iobOper_rad + case("sndrd3" ); index_= iobOper_rad + case("sndrd4" ); index_= iobOper_rad + ! + case("ssmi" ); index_= iobOper_rad + ! + case("amsre" ); index_= iobOper_rad + case("amsre_low"); index_= iobOper_rad + case("amsre_mid"); index_= iobOper_rad + case("amsre_hig"); index_= iobOper_rad + ! + case("ssmis" ); index_= iobOper_rad + case("ssmis_las"); index_= iobOper_rad + case("ssmis_uas"); index_= iobOper_rad + case("ssmis_img"); index_= iobOper_rad + case("ssmis_env"); index_= iobOper_rad + ! + case("amsr2" ); index_= iobOper_rad + case("goes_img"); index_= iobOper_rad + case("gmi" ); index_= iobOper_rad + case("seviri" ); index_= iobOper_rad + case("ahi" ); index_= iobOper_rad + ! + case("avhrr_navy"); index_= iobOper_rad + case("avhrr" ); index_= iobOper_rad + + case("tcp" ,"[tcpoper]" ); index_= iobOper_tcp + + !case("lag" ,"[lagoper]" ); index_= iobOper_lag + + case("colvk" ,"[colvkoper]" ); index_= iobOper_colvk + case("mopitt" ); index_= iobOper_colvk + + case("aero" ,"[aerooper]" ); index_= iobOper_aero + case("aod" ); index_= iobOper_aero + case("modis_aod"); index_= iobOper_aero + + !case("aerol" ,"[aeroloper]" ); index_= iobOper_aerol + + case("pm2_5" ,"[pm2_5oper]" ); index_= iobOper_pm2_5 + case("gust" ,"[gustoper]" ); index_= iobOper_gust + case("vis" ,"[visoper]" ); index_= iobOper_vis + case("pblh" ,"[pblhoper]" ); index_= iobOper_pblh + + case("wspd10m","[wspd10moper]"); index_= iobOper_wspd10m + case("uwnd10m","[uwnd10moper]"); index_= iobOper_uwnd10m + case("vwnd10m","[vwnd10moper]"); index_= iobOper_vwnd10m + + case("td2m" ,"[td2moper]" ); index_= iobOper_td2m + case("mxtm" ,"[mxtmoper]" ); index_= iobOper_mxtm + case("mitm" ,"[mitmoper]" ); index_= iobOper_mitm + case("pmsl" ,"[pmsloper]" ); index_= iobOper_pmsl + case("howv" ,"[howvoper]" ); index_= iobOper_howv + case("tcamt" ,"[tcamtoper]" ); index_= iobOper_tcamt + case("lcbas" ,"[lcbasoper]" ); index_= iobOper_lcbas + + case("pm10" ,"[pm10oper]" ); index_= iobOper_pm10 + case("cldch" ,"[cldchoper]" ); index_= iobOper_cldch + + case("swcp" ,"[swcpoper]" ); index_= iobOper_swcp + case("lwcp" ,"[lwcpoper]" ); index_= iobOper_lwcp + + case("light" ,"[lightoper]" ); index_= iobOper_light + case("goes_glm" ); index_= iobOper_light + + case("dbz" ,"[dbzoper]" ); index_= iobOper_dbz + + case("cldtot" ,"[cldtotoper]" ); index_= iobOper_cldtot + case("mta_cld" ); index_= iobOper_cldtot + + ! Known dtype values, but no known obOper type defined + case("gos_ctp"); index_= obOper_undef + case("rad_ref"); index_= obOper_undef + case("lghtn" ); index_= obOper_undef + case("larccld"); index_= obOper_undef + case("larcglb"); index_= obOper_undef + + ! A catch all case + case default ; index_= obOper_undef + end select +end function dtype2index_ + +function vmold2index_(mold) result(index_) + implicit none + integer(i_kind):: index_ + class(obOper),target,intent(in):: mold + + character(len=*),parameter:: myname_=myname//"::vmold2index_" + class(obOper),pointer:: ptr_ + ptr_ => mold + if(.not.associated(ptr_)) call die(myname_,'not assoicated, argument mold') + nullify(ptr_) + + index_=dtype2index_(mold%mytype()) + + ! An alternative implementation to cache a managed iobOper value inside each + ! obOper class. This implementation requires two new TBPs, %myinfo_get() and + ! %myinfo_set(). + ! + ! call mold%myinfo_get(iobOper=index_) + ! if(index_obOper_ubound) then + ! index_=dtype2index_(mold%mytype()) + ! call mold%myinfo_set(iobOper_=index_) + ! endif + +end function vmold2index_ + +function dtype2vmold_(dtype) result(vmold_) + implicit none + class(obOper),pointer:: vmold_ + character(len=*),intent(in):: dtype + + integer(i_kind):: iobOper_ + iobOper_ = dtype2index_(dtype) + vmold_ => index2vmold_(iobOper_) +end function dtype2vmold_ + +function index2vmold_(iobOper) result(vmold_) + implicit none + class(obOper),pointer:: vmold_ + integer(i_kind),intent(in):: iobOper + select case(iobOper) + + case(iobOper_ps ); vmold_ => psOper_mold + case(iobOper_t ); vmold_ => tOper_mold + case(iobOper_w ); vmold_ => wOper_mold + case(iobOper_q ); vmold_ => qOper_mold + case(iobOper_spd ); vmold_ => spdOper_mold + case(iobOper_rw ); vmold_ => rwOper_mold + case(iobOper_dw ); vmold_ => dwOper_mold + case(iobOper_sst ); vmold_ => sstOper_mold + case(iobOper_pw ); vmold_ => pwOper_mold + case(iobOper_pcp ); vmold_ => pcpOper_mold + case(iobOper_oz ); vmold_ => ozOper_mold + case(iobOper_o3l ); vmold_ => o3lOper_mold + case(iobOper_gpsbend ); vmold_ => gpsbendOper_mold + case(iobOper_gpsref ); vmold_ => gpsrefOper_mold + case(iobOper_rad ); vmold_ => radOper_mold + case(iobOper_tcp ); vmold_ => tcpOper_mold + !case(iobOper_lag ); vmold_ => lagOper_mold + case(iobOper_colvk ); vmold_ => colvkOper_mold + case(iobOper_aero ); vmold_ => aeroOper_mold + !case(iobOper_aerol ); vmold_ => aerolOper_mold + case(iobOper_pm2_5 ); vmold_ => pm2_5Oper_mold + case(iobOper_gust ); vmold_ => gustOper_mold + case(iobOper_vis ); vmold_ => visOper_mold + case(iobOper_pblh ); vmold_ => pblhOper_mold + case(iobOper_wspd10m ); vmold_ => wspd10mOper_mold + case(iobOper_td2m ); vmold_ => td2mOper_mold + case(iobOper_mxtm ); vmold_ => mxtmOper_mold + case(iobOper_mitm ); vmold_ => mitmOper_mold + case(iobOper_pmsl ); vmold_ => pmslOper_mold + case(iobOper_howv ); vmold_ => howvOper_mold + case(iobOper_tcamt ); vmold_ => tcamtOper_mold + case(iobOper_lcbas ); vmold_ => lcbasOper_mold + case(iobOper_pm10 ); vmold_ => pm10Oper_mold + case(iobOper_cldch ); vmold_ => cldchOper_mold + case(iobOper_uwnd10m ); vmold_ => uwnd10mOper_mold + case(iobOper_vwnd10m ); vmold_ => vwnd10mOper_mold + case(iobOper_swcp ); vmold_ => swcpOper_mold + case(iobOper_lwcp ); vmold_ => lwcpOper_mold + case(iobOper_light ); vmold_ => lightOper_mold + case(iobOper_dbz ); vmold_ => dbzOper_mold + case(iobOper_cldtot ); vmold_ => cldtotOper_mold + + case( obOper_undef ); vmold_ => null() + case default ; vmold_ => null() + end select +end function index2vmold_ + +function vmold2tinfo_(mold) result(info_) +!>> Simply mold%info(), but just in case one needs some indirection, with +!>> multiple obOper classes. + implicit none + character(len=:),allocatable:: info_ + class(obOper),target,intent(in):: mold + + character(len=*),parameter:: myname_=myname//"::vmold2tinfo_" + class(obOper),pointer:: vmold__ + vmold__ => mold + + if(.not.associated(vmold__)) call die(myname_,'not assoicated, argument mold') + nullify(vmold__) + + info_=index2tinfo_(vmold2index_(mold)) +end function vmold2tinfo_ + +function index2tinfo_(iobOper) result(info_) +!>> + implicit none + character(len=:),allocatable:: info_ + integer(i_kind),intent(in):: iobOper + + if(.not.cobstype_configured_) call cobstype_config_() + info_="" + if(iobOper>=obOper_lbound .and. & + iobOper<=obOper_ubound) info_=cobstype(iobOper) +end function index2tinfo_ + +subroutine config_() + implicit none + character(len=*),parameter:: myname_=myname//"::config_" + class(obOper),pointer:: vmold_ + integer(i_kind):: iset_,iget_ + logical:: good_ + + good_=.true. + do iset_ = obOper_lbound, obOper_ubound + vmold_ => index2vmold_(iset_) + if(.not.associated(vmold_)) then + call perr(myname_,'unexpected index, iset_ =',iset_) + call perr(myname_,' obOper_lbound =',obOper_lbound) + call perr(myname_,' obOper_ubound =',obOper_ubound) + call die(myname_) + endif + + iget_=iset_ ! for additional test. + !call vmold_%myinfo_set(iobOper=iset_) + !call vmold_%myinfo_get(iobOper=iget_) + if(iget_/=iset_) then + call perr(myname_,'unexpected return, %myinfo_get(iobOper) =',iget_) + call perr(myname_,' %myinfo_set(iobOper) =',iset_) + call perr(myname_,' %mytype() =',vmold_%mytype()) + good_=.false. + endif + + vmold_ => null() + enddo + if(.not.good_) call die(myname_) + + obOper_configured_ = .true. +end subroutine config_ + +subroutine cobstype_config_() +!>> Should this information be provided by individual obOper extensions, or +!>> be provided by this manager? There are pros and cons in either approach. + + implicit none + cobstype(iobOper_ps ) ="surface pressure " ! ps_ob_type + cobstype(iobOper_t ) ="temperature " ! t_ob_type + cobstype(iobOper_w ) ="wind " ! w_ob_type + cobstype(iobOper_q ) ="moisture " ! q_ob_type + cobstype(iobOper_spd ) ="wind speed " ! spd_ob_type + cobstype(iobOper_rw ) ="radial wind " ! rw_ob_type + cobstype(iobOper_dw ) ="doppler wind " ! dw_ob_type + cobstype(iobOper_sst ) ="sst " ! sst_ob_type + cobstype(iobOper_pw ) ="precipitable water " ! pw_ob_type + cobstype(iobOper_pcp ) ="precipitation " ! pcp_ob_type + cobstype(iobOper_oz ) ="ozone " ! oz_ob_type + cobstype(iobOper_o3l ) ="level ozone " ! o3l_ob_type + cobstype(iobOper_gpsbend ) ="gps bending angle " ! using gps_ob_type + cobstype(iobOper_gpsref ) ="gps refractivity " ! using gps_ob_type + cobstype(iobOper_rad ) ="radiance " ! rad_ob_type + cobstype(iobOper_tcp ) ="tcp (tropic cyclone)" ! tcp_ob_type + !cobstype(iobOper_lag ) ="lagrangian tracer " ! lag_ob_type + cobstype(iobOper_colvk ) ="carbon monoxide " ! colvk_ob_type + cobstype(iobOper_aero ) ="aerosol aod " ! aero_ob_type + !cobstype(iobOper_aerol ) ="level aero aod " ! aerol_ob_type + cobstype(iobOper_pm2_5 ) ="in-situ pm2_5 obs " ! pm2_5_ob_type + cobstype(iobOper_pm10 ) ="in-situ pm10 obs " ! pm10_ob_type + cobstype(iobOper_gust ) ="gust " ! gust_ob_type + cobstype(iobOper_vis ) ="vis " ! vis_ob_type + cobstype(iobOper_pblh ) ="pblh " ! pblh_ob_type + cobstype(iobOper_wspd10m ) ="wspd10m " ! wspd10m_ob_type + cobstype(iobOper_td2m ) ="td2m " ! td2m_ob_type + cobstype(iobOper_mxtm ) ="mxtm " ! mxtm_ob_type + cobstype(iobOper_mitm ) ="mitm " ! mitm_ob_type + cobstype(iobOper_pmsl ) ="pmsl " ! pmsl_ob_type + cobstype(iobOper_howv ) ="howv " ! howv_ob_type + cobstype(iobOper_tcamt ) ="tcamt " ! tcamt_ob_type + cobstype(iobOper_lcbas ) ="lcbas " ! lcbas_ob_type + cobstype(iobOper_cldch ) ="cldch " ! cldch_ob_type + cobstype(iobOper_uwnd10m ) ="uwnd10m " ! uwnd10m_ob_type + cobstype(iobOper_vwnd10m ) ="vwnd10m " ! vwnd10m_ob_type + cobstype(iobOper_swcp ) ="swcp " ! swcp_ob_type + cobstype(iobOper_lwcp ) ="lwcp " ! lwcp_ob_type + cobstype(iobOper_light ) ="light " ! light_ob_type + cobstype(iobOper_dbz ) ="dbz " ! dbz_ob_type + cobstype(iobOper_cldtot ) ="cldtot " ! using q_ob_type + + cobstype_configured_=.true. +end subroutine cobstype_config_ + +end module gsi_obOperTypeManager diff --git a/src/gsi/gsi_ozOper.F90 b/src/gsi/gsi_ozOper.F90 new file mode 100644 index 000000000..8bc21baf0 --- /dev/null +++ b/src/gsi/gsi_ozOper.F90 @@ -0,0 +1,157 @@ +module gsi_ozOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_ozOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for ozNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_ozNode , only: ozNode + implicit none + public:: ozOper ! data stracture + + type,extends(obOper):: ozOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type ozOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_ozOper' + type(ozNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[ozOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use oz_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: stats => rhs_stats_oz + use obsmod, only: write_diag + use ozinfo, only: diag_ozone + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(ozOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + + diagsave = write_diag(jiter) .and. diag_ozone + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,stats,nchanl,nreal,nobs,obstype,isis,is,diagsave,init_pass) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intozmod, only: intjo => intozlay + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(ozOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpozmod, only: stpjo => stpozlay + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(ozOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_ozOper diff --git a/src/gsi/gsi_pblhOper.F90 b/src/gsi/gsi_pblhOper.F90 new file mode 100644 index 000000000..390315b3b --- /dev/null +++ b/src/gsi/gsi_pblhOper.F90 @@ -0,0 +1,161 @@ +module gsi_pblhOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_pblhOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for pblhNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_pblhNode, only: pblhNode + implicit none + public:: pblhOper ! data stracture + + type,extends(obOper):: pblhOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pblhOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_pblhOper' + type(pblhNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[pblhOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use pblh_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_pblh + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(pblhOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intpblhmod, only: intjo => intpblh + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(pblhOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stppblhmod, only: stpjo => stppblh + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(pblhOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_pblhOper diff --git a/src/gsi/gsi_pcpOper.F90 b/src/gsi/gsi_pcpOper.F90 new file mode 100644 index 000000000..b03462745 --- /dev/null +++ b/src/gsi/gsi_pcpOper.F90 @@ -0,0 +1,158 @@ +module gsi_pcpOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_pcpOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for pcpNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_pcpNode , only: pcpNode + implicit none + public:: pcpOper ! data stracture + + type,extends(obOper):: pcpOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pcpOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_pcpOper' + type(pcpNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[pcpOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use pcp_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs, only: aivals => rhs_aivals + use obsmod, only: write_diag + use pcpinfo, only: diag_pcp + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(pcpOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_pcp + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,aivals,nele,nobs,obstype,isis,is,diagsave,init_pass) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intpcpmod, only: intjo => intpcp + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(pcpOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stppcpmod, only: stpjo => stppcp + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(pcpOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_pcpOper diff --git a/src/gsi/gsi_pm10Oper.F90 b/src/gsi/gsi_pm10Oper.F90 new file mode 100644 index 000000000..8da67ce78 --- /dev/null +++ b/src/gsi/gsi_pm10Oper.F90 @@ -0,0 +1,157 @@ +module gsi_pm10Oper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_pm10Oper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for pm10Node type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_pm10Node, only: pm10Node + implicit none + public:: pm10Oper ! data stracture + + type,extends(obOper):: pm10Oper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pm10Oper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_pm10Oper' + type(pm10Node),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[pm10Oper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use pm10_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(pm10Oper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,nele,nobs,isis,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intpm10mod, only: intjo => intpm10 + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(pm10Oper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stppm10mod, only: stpjo => stppm10 + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(pm10Oper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_pm10Oper diff --git a/src/gsi/gsi_pm2_5Oper.F90 b/src/gsi/gsi_pm2_5Oper.F90 new file mode 100644 index 000000000..221e997f5 --- /dev/null +++ b/src/gsi/gsi_pm2_5Oper.F90 @@ -0,0 +1,157 @@ +module gsi_pm2_5Oper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_pm2_5Oper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for pm2_5Node type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper , only: obOper + use m_pm2_5Node, only: pm2_5Node + implicit none + public:: pm2_5Oper ! data stracture + + type,extends(obOper):: pm2_5Oper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pm2_5Oper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_pm2_5Oper' + type(pm2_5Node),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[pm2_5Oper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use pm2_5_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(pm2_5Oper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,nele,nobs,isis,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intpm2_5mod, only: intjo => intpm2_5 + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(pm2_5Oper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stppm2_5mod, only: stpjo => stppm2_5 + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(pm2_5Oper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_pm2_5Oper diff --git a/src/gsi/gsi_pmslOper.F90 b/src/gsi/gsi_pmslOper.F90 new file mode 100644 index 000000000..700707562 --- /dev/null +++ b/src/gsi/gsi_pmslOper.F90 @@ -0,0 +1,161 @@ +module gsi_pmslOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_pmslOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for pmslNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_pmslNode, only: pmslNode + implicit none + public:: pmslOper ! data stracture + + type,extends(obOper):: pmslOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pmslOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_pmslOper' + type(pmslNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[pmslOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use pmsl_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_pmsl + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(pmslOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intpmslmod, only: intjo => intpmsl + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(pmslOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stppmslmod, only: stpjo => stppmsl + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(pmslOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_pmslOper diff --git a/src/gsi/gsi_psOper.F90 b/src/gsi/gsi_psOper.F90 new file mode 100644 index 000000000..87f1cd921 --- /dev/null +++ b/src/gsi/gsi_psOper.F90 @@ -0,0 +1,161 @@ +module gsi_psOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_psOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for psNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_psNode , only: psNode + implicit none + public:: psOper ! data stracture + + type,extends(obOper):: psOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type psOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_psOper' + type(psNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[psOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use ps_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_ps + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(psOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intpsmod, only: intjo => intps + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(psOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stppsmod, only: stpjo => stpps + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(psOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_psOper diff --git a/src/gsi/gsi_pwOper.F90 b/src/gsi/gsi_pwOper.F90 new file mode 100644 index 000000000..d5193931d --- /dev/null +++ b/src/gsi/gsi_pwOper.F90 @@ -0,0 +1,161 @@ +module gsi_pwOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_pwOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for pwNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_pwNode , only: pwNode + implicit none + public:: pwOper ! data stracture + + type,extends(obOper):: pwOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pwOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_pwOper' + type(pwNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[pwOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use pw_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_pw + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(pwOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intpwmod, only: intjo => intpw + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(pwOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stppwmod, only: stpjo => stppw + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(pwOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_pwOper diff --git a/src/gsi/gsi_qOper.F90 b/src/gsi/gsi_qOper.F90 new file mode 100644 index 000000000..75de80212 --- /dev/null +++ b/src/gsi/gsi_qOper.F90 @@ -0,0 +1,161 @@ +module gsi_qOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_qOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for qNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_qNode , only: qNode + implicit none + public:: qOper ! data stracture + + type,extends(obOper):: qOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type qOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_qOper' + type(qNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[qOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use q_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_q + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(qOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intqmod, only: intjo => intq + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(qOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpqmod, only: stpjo => stpq + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(qOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_qOper diff --git a/src/gsi/gsi_radOper.F90 b/src/gsi/gsi_radOper.F90 new file mode 100644 index 000000000..34c688e62 --- /dev/null +++ b/src/gsi/gsi_radOper.F90 @@ -0,0 +1,183 @@ +module gsi_radOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_radOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for radNode type +! +! program history log: +! 2018-08-10 j guo - added this document block for initial implementation +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_radNode , only: radNode + implicit none + public:: radOper ! data stracture + + type,extends(obOper):: radOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type radOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_radOper' + type(radNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[radOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use rad_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: aivals => rhs_aivals + use m_rhs , only: stats => rhs_stats + + use obsmod , only: write_diag + use radinfo, only: diag_rad + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(radOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + + diagsave = write_diag(jiter) .and. diag_rad + + call setup(self%obsLL(:), self%odiagLL(:), lunin, mype, & + aivals,stats,nchanl,nreal,nobs,obstype,isis,is,diagsave, & + init_pass,last_pass) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + !-- a single bin interface, with %pred resolved + use intradmod, only: intjo => intrad + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use bias_predictors, only: predictors_getdim + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(radOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target,intent(in ):: sbias + + !!$omp ... + ! do ib=1,nobs_bins + ! do it=1,nobs_type + ! iop => obOper_create(mold=obOper_typemold(it)) + ! call iop%intjo(ib, rval(ib),sval(ib), qpred(:,ib),sbias) + ! iop => null() + ! enddo + ! enddo + + character(len=*),parameter:: myname_=myname//"::intjo1_" + integer(i_kind):: i,l + class(obsNode),pointer:: headNode + + call predictors_getdim(lbnd_s=i,ubnd_s=l) + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval, qpred(i:l),sbias%predr) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + !-- a single bin interface, with %pred resolved + use stpradmod, only: stpjo => stprad + use kinds, only: r_quad,r_kind,i_kind + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors,predictors_getdim + use radinfo, only: npred,jpch_rad + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + implicit none + class(radOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + real(r_kind),pointer,dimension(:,:):: dpred,xpred + integer(i_kind):: n + + headNode => obsLList_headNode(self%obsLL(ibin)) + + call predictors_getdim(size_s=n) + dpred(1:npred,1:jpch_rad) => dbias%predr(1:n) + xpred(1:npred,1:jpch_rad) => xbias%predr(1:n) + + call stpjo(headNode,dval,xval, dpred,xpred,pbcjo(:),sges,nstep) + + dpred => null() + xpred => null() + + headNode => null() + end subroutine stpjo1_ + +end module gsi_radOper diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 new file mode 100644 index 000000000..28cb99658 --- /dev/null +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -0,0 +1,2264 @@ +module gsi_rfv3io_mod +!$$$ module documentation block +! . . . . +! module: gsi_rfv3io_mod +! prgmmr: +! +! abstract: IO routines for regional FV3 +! +! program history log: +! 2017-03-08 parrish - create new module gsi_rfv3io_mod, starting from +! gsi_nemsio_mod as a pattern. +! 2017-10-10 wu - setup A grid and interpolation coeff in generate_anl_grid +! 2018-02-22 wu - add subroutines for read/write fv3_ncdf +! 2019 ting - modifications for use for ensemble IO and cold start files +! subroutines included: +! sub gsi_rfv3io_get_grid_specs +! sub read_fv3_files +! sub read_fv3_netcdf_guess +! sub gsi_fv3ncdf2d_read +! sub gsi_fv3ncdf_read +! sub gsi_fv3ncdf_readuv +! sub wrfv3_netcdf +! sub gsi_fv3ncdf_writeuv +! sub gsi_fv3ncdf_writeps +! sub gsi_fv3ncdf_write +! sub check +! +! variable definitions: +! +! attributes: +! langauge: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + use gridmod, only: nlon_regional,nlat_regional + implicit none + public type_fv3regfilenameg + public bg_fv3regfilenameg + public fv3sar_bg_opt + +! directory names (hardwired for now) + type type_fv3regfilenameg + character(len=:),allocatable :: grid_spec !='fv3_grid_spec' + character(len=:),allocatable :: ak_bk !='fv3_akbk' + character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: tracers !='fv3_tracer' + character(len=:),allocatable :: sfcdata !='fv3_sfcdata' + character(len=:),allocatable :: couplerres!='coupler.res' + contains + procedure , pass(this):: init=>fv3regfilename_init + end type type_fv3regfilenameg + + integer(i_kind):: fv3sar_bg_opt=0 + type(type_fv3regfilenameg):: bg_fv3regfilenameg + integer(i_kind) nx,ny,nz + real(r_kind),allocatable:: grid_lon(:,:),grid_lont(:,:),grid_lat(:,:),grid_latt(:,:) + real(r_kind),allocatable:: ak(:),bk(:) + integer(i_kind),allocatable:: ijns2d(:),displss2d(:),ijns(:),displss(:) + integer(i_kind),allocatable:: ijnz(:),displsz_g(:) + +! set default to private + private +! set subroutines to public + public :: gsi_rfv3io_get_grid_specs + public :: gsi_fv3ncdf_read + public :: gsi_fv3ncdf_read_v1 + public :: gsi_fv3ncdf_readuv + public :: gsi_fv3ncdf_readuv_v1 + public :: read_fv3_files + public :: read_fv3_netcdf_guess + public :: wrfv3_netcdf + public :: gsi_fv3ncdf2d_read_v1 + + public :: mype_u,mype_v,mype_t,mype_q,mype_p,mype_oz,mype_ql + public :: k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc + public :: k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc + public :: ijns,ijns2d,displss,displss2d,ijnz,displsz_g + + integer(i_kind) mype_u,mype_v,mype_t,mype_q,mype_p,mype_oz,mype_ql + integer(i_kind) k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc + integer(i_kind) k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc + parameter( & + k_f10m =1, & !fact10 + k_stype=2, & !soil_type + k_vfrac=3, & !veg_frac + k_vtype=4, & !veg_type + k_zorl =5, & !sfc_rough + k_tsea =6, & !sfct ? + k_snwdph=7, & !sno ? + k_stc =8, & !soil_temp + k_smc =9, & !soil_moi + k_slmsk=10, & !isli + k_orog =11, & !terrain + n2d=11 ) + +contains + subroutine fv3regfilename_init(this,grid_spec_input,ak_bk_input,dynvars_input, & + tracers_input,sfcdata_input,couplerres_input) + implicit None + class(type_fv3regfilenameg),intent(inout):: this + character(*),optional :: grid_spec_input,ak_bk_input,dynvars_input, & + tracers_input,sfcdata_input,couplerres_input + if(present(grid_spec_input))then + + this%grid_spec=grid_spec_input + else + this%grid_spec='fv3_grid_spec' + endif + if(present(ak_bk_input))then + this%ak_bk=ak_bk_input + else + this%ak_bk='fv3_ak_bk' + endif + if(present(dynvars_input))then + + this%dynvars=dynvars_input + else + this%dynvars='fv3_dynvars' + endif + if(present(tracers_input))then + + this%tracers=tracers_input + else + this%tracers='fv3_tracer' + endif + if(present(sfcdata_input))then + + this%sfcdata=sfcdata_input + else + this%sfcdata='fv3_sfcdata' + endif + + if(present(couplerres_input))then + + this%couplerres=couplerres_input + else + this%couplerres='coupler.res' + endif + + end subroutine fv3regfilename_init + + +subroutine gsi_rfv3io_get_grid_specs(fv3filenamegin,ierr) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_rfv3io_get_grid_specs +! pgrmmr: parrish org: np22 date: 2017-04-03 +! +! abstract: obtain grid dimensions nx,ny and grid definitions +! grid_x,grid_xt,grid_y,grid_yt,grid_lon,grid_lont,grid_lat,grid_latt +! nz,ak(nz),bk(nz) +! +! program history log: +! 2017-04-03 parrish - initial documentation +! 2017-10-10 wu - setup A grid and interpolation coeff with generate_anl_grid +! 2018-02-16 wu - read in time info from file coupler.res +! read in lat, lon at the center and corner of the grid cell +! from file fv3_grid_spec, and vertical grid infor from file fv3_akbk +! setup A grid and interpolation/rotation coeff +! input argument list: +! grid_spec +! ak_bk +! lendian_out +! +! output argument list: +! ierr +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use mpimod, only: mype + use mod_fv3_lola, only: generate_anl_grid + use gridmod, only:nsig,regional_time,regional_fhr,aeta1_ll,aeta2_ll + use gridmod, only:nlon_regional,nlat_regional,eta1_ll,eta2_ll + use kinds, only: i_kind,r_kind + use constants, only: half,zero + use mpimod, only: mpi_comm_world,mpi_itype,mpi_rtype + + implicit none + integer(i_kind) gfile_grid_spec + type (type_fv3regfilenameg) :: fv3filenamegin + character(:),allocatable :: grid_spec + character(:),allocatable :: ak_bk + character(len=:),allocatable :: coupler_res_filenam + integer(i_kind),intent( out) :: ierr + integer(i_kind) i,k,ndimensions,iret,nvariables,nattributes,unlimiteddimid + integer(i_kind) len,gfile_loc + character(len=128) :: name + integer(i_kind) myear,mmonth,mday,mhour,mminute,msecond + real(r_kind),allocatable:: abk_fv3(:) + + coupler_res_filenam=fv3filenamegin%couplerres + grid_spec=fv3filenamegin%grid_spec + ak_bk=fv3filenamegin%ak_bk + +!!!!! set regional_time + open(24,file=trim(coupler_res_filenam),form='formatted') + read(24,*) + read(24,*) + read(24,*)myear,mmonth,mday,mhour,mminute,msecond + close(24) + if(mype==0) write(6,*)' myear,mmonth,mday,mhour,mminute,msecond=', myear,mmonth,mday,mhour,mminute,msecond + regional_time(1)=myear + regional_time(2)=mmonth + regional_time(3)=mday + regional_time(4)=mhour + regional_time(5)=mminute + regional_time(6)=msecond + regional_fhr=zero ! forecast hour set zero for now + +!!!!!!!!!! grid_spec !!!!!!!!!!!!!!! + ierr=0 + iret=nf90_open(trim(grid_spec),nf90_nowrite,gfile_grid_spec) + if(iret/=nf90_noerr) then + write(6,*)' gsi_rfv3io_get_grid_specs: problem opening ',trim(grid_spec),', Status = ',iret + ierr=1 + return + endif + + iret=nf90_inquire(gfile_grid_spec,ndimensions,nvariables,nattributes,unlimiteddimid) + gfile_loc=gfile_grid_spec + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + if(trim(name)=='grid_xt') nx=len + if(trim(name)=='grid_yt') ny=len + enddo + nlon_regional=nx + nlat_regional=ny + if(mype==0)write(6,*),'nx,ny=',nx,ny + +!!! get nx,ny,grid_lon,grid_lont,grid_lat,grid_latt,nz,ak,bk + + allocate(grid_lat(nx+1,ny+1)) + allocate(grid_lon(nx+1,ny+1)) + allocate(grid_latt(nx,ny)) + allocate(grid_lont(nx,ny)) + + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)=='grid_lat') then + iret=nf90_get_var(gfile_loc,k,grid_lat) + endif + if(trim(name)=='grid_lon') then + iret=nf90_get_var(gfile_loc,k,grid_lon) + endif + if(trim(name)=='grid_latt') then + iret=nf90_get_var(gfile_loc,k,grid_latt) + endif + if(trim(name)=='grid_lont') then + iret=nf90_get_var(gfile_loc,k,grid_lont) + endif + enddo + + iret=nf90_close(gfile_loc) + + iret=nf90_open(ak_bk,nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)'gsi_rfv3io_get_grid_specs: problem opening ',trim(ak_bk),', Status = ',iret + ierr=1 + return + endif + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + if(trim(name)=='xaxis_1') nz=len + enddo + if(mype==0)write(6,'(" nz=",i5)') nz + + nsig=nz-1 + +!!! get ak,bk + + allocate(aeta1_ll(nsig),aeta2_ll(nsig)) + allocate(eta1_ll(nsig+1),eta2_ll(nsig+1)) + allocate(ak(nz),bk(nz),abk_fv3(nz)) + + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)=='ak'.or.trim(name)=='AK') then + iret=nf90_get_var(gfile_loc,k,abk_fv3) + do i=1,nz + ak(i)=abk_fv3(nz+1-i) + enddo + endif + if(trim(name)=='bk'.or.trim(name)=='BK') then + iret=nf90_get_var(gfile_loc,k,abk_fv3) + do i=1,nz + bk(i)=abk_fv3(nz+1-i) + enddo + endif + enddo + iret=nf90_close(gfile_loc) + +!!!!! change unit of ak + do i=1,nsig+1 + eta1_ll(i)=ak(i)*0.001_r_kind + eta2_ll(i)=bk(i) + enddo + do i=1,nsig + aeta1_ll(i)=half*(ak(i)+ak(i+1))*0.001_r_kind + aeta2_ll(i)=half*(bk(i)+bk(i+1)) + enddo + if(mype==0)then + do i=1,nz + write(6,'(" ak,bk(",i3,") = ",2f17.6)') i,ak(i),bk(i) + enddo + endif + +!!!!!!! setup A grid and interpolation/rotation coeff. + call generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) + + deallocate (grid_lon,grid_lat,grid_lont,grid_latt) + deallocate (ak,bk,abk_fv3) + + return +end subroutine gsi_rfv3io_get_grid_specs + +subroutine read_fv3_files(mype) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_fv3_files +! prgmmr: wu org: np22 date: 2017-10-10 +! +! abstract: read in from fv3 files and figure out available time levels +! of background fields starting from read_files as a pattern +! temporary setup for one first guess file +! program history log: +! +! input argument list: +! mype - pe number +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + use mpimod, only: mpi_comm_world,ierror,mpi_rtype,npe + use guess_grids, only: nfldsig,nfldsfc,ntguessig,ntguessfc,& + ifilesig,ifilesfc,hrdifsig,hrdifsfc,create_gesfinfo + use guess_grids, only: hrdifsig_all,hrdifsfc_all + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,nhr_assimilation + use constants, only: zero,one,r60inv + use obsmod, only: iadate,time_offset + use gridmod, only:regional_time + implicit none + +! Declare passed variables + integer(i_kind),intent(in ) :: mype + +! Declare local parameters + real(r_kind),parameter:: r0_001=0.001_r_kind + +! Declare local variables + logical(4) fexist + character(6) filename + integer(i_kind) in_unit + integer(i_kind) i,j,iwan,npem1 + integer(i_kind) nhr_half + integer(i_kind) nminanl,nmings,nming2,ndiff,isecond + integer(i_kind),dimension(4):: idateg + integer(i_kind),dimension(5):: idate5 + real(r_kind) hourg,temp,t4dv + real(r_kind),dimension(202,2):: time_ges + +!----------------------------------------------------------------------------- +! Start read_nems_nmmb_files here. + nhr_half=nhr_assimilation/2 + if(nhr_half*2 < nhr_assimilation) nhr_half=nhr_half+1 + npem1=npe-1 + + do i=1,202 + time_ges(i,1) = 999_r_kind + time_ges(i,2) = 999_r_kind + end do + + +! Let a single task query the guess files. + if(mype==npem1) then + +! Convert analysis time to minutes relative to fixed date + call w3fs21(iadate,nminanl) + write(6,*)'READ_netcdf_fv3_FILES: analysis date,minutes ',iadate,nminanl + +! Check for consistency of times from sigma guess files. + in_unit=15 + iwan=0 +!WWWWWW setup for one first guess file for now +! do i=0,9 !place holder for FGAT + i=3 + +!wwww read in from the external file directly, no internal files sigfxx for FV3 + idate5(1)= regional_time(1) + idate5(2)= regional_time(2) + idate5(3)= regional_time(3) + idate5(4)= regional_time(4) + idate5(5)= regional_time(5) + isecond = regional_time(6) + hourg = zero ! forcast hour + + call w3fs21(idate5,nmings) + nming2=nmings+60*hourg + write(6,*)'READ_netcdf_fv3_FILES: sigma guess file, nming2 ',hourg,idate5,nming2 + t4dv=real((nming2-iwinbgn),r_kind)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) then + write(6,*)'ges file not in time range, t4dv=',t4dv +! cycle ! place holder for FGAT + endif + else + ndiff=nming2-nminanl +!for test with the 3 hr files with FGAT + if(abs(ndiff) > 60*nhr_half ) then + write(6,*)'ges file not in time range, ndiff=',ndiff +! cycle ! place holder for FGAT + endif + endif + iwan=iwan+1 + time_ges(iwan,1) =real((nming2-iwinbgn),r_kind)*r60inv + time_ges(iwan+100,1)=i+r0_001 +! end do ! i !place holder for FGAT + time_ges(201,1)=one + time_ges(202,1)=one + if(iwan > 1)then + do i=1,iwan + do j=i+1,iwan + if(time_ges(j,1) < time_ges(i,1))then + temp=time_ges(i+100,1) + time_ges(i+100,1)=time_ges(j+100,1) + time_ges(j+100,1)=temp + temp=time_ges(i,1) + time_ges(i,1)=time_ges(j,1) + time_ges(j,1)=temp + end if + end do + if(abs(time_ges(i,1)-time_offset) < r0_001)time_ges(202,1) = i + end do + end if + time_ges(201,1) = iwan+r0_001 + +! Check for consistency of times from surface guess files. + iwan=0 + do i=0,99 + write(filename,200)i + 200 format('sfcf',i2.2) + inquire(file=filename,exist=fexist) + if(fexist)then + idateg(4)=iadate(1); idateg(2)=iadate(2) + idateg(3)=iadate(3); idateg(1)=iadate(4) + hourg = zero + idate5(1)=idateg(4); idate5(2)=idateg(2) + idate5(3)=idateg(3); idate5(4)=idateg(1); idate5(5)=0 + call w3fs21(idate5,nmings) + nming2=nmings+60*hourg + write(6,*)'READ_netcdf_fv3_FILES: surface guess file, nming2 ',hourg,idateg,nming2 + ndiff=nming2-nminanl + if(abs(ndiff) > 60*nhr_half ) then + write(6,*)'ges file not in time range, ndiff=',ndiff +! cycle ! place holder for FGAT + endif + iwan=iwan+1 + time_ges(iwan,2) =real((nming2-iwinbgn),r_kind)*r60inv + time_ges(iwan+100,2)=i+r0_001 + end if + if(iwan==1) exit + end do + time_ges(201,2)=one + time_ges(202,2)=one + if(iwan > 1)then + do i=1,iwan + do j=i+1,iwan + if(time_ges(j,2) < time_ges(i,2))then + temp=time_ges(i+100,2) + time_ges(i+100,2)=time_ges(j+100,2) + time_ges(j+100,2)=temp + temp=time_ges(i,2) + time_ges(i,2)=time_ges(j,2) + time_ges(j,2)=temp + end if + end do + if(abs(time_ges(i,2)-time_offset) < r0_001)time_ges(202,2) = i + end do + end if + time_ges(201,2) = iwan+r0_001 + end if + + +! Broadcast guess file information to all tasks + call mpi_bcast(time_ges,404,mpi_rtype,npem1,mpi_comm_world,ierror) + + nfldsig = nint(time_ges(201,1)) +!!nfldsfc = nint(time_ges(201,2)) + nfldsfc = nfldsig + +! Allocate space for guess information files + call create_gesfinfo + + do i=1,nfldsig + ifilesig(i) = -100 + hrdifsig(i) = zero + end do + + do i=1,nfldsfc + ifilesfc(i) = -100 + hrdifsfc(i) = zero + end do + +! Load time information for sigma guess field sinfo into output arrays + ntguessig = nint(time_ges(202,1)) + do i=1,nfldsig + hrdifsig(i) = time_ges(i,1) + ifilesig(i) = nint(time_ges(i+100,1)) + hrdifsig_all(i) = hrdifsig(i) + end do + if(mype == 0) write(6,*)'READ_netcdf_fv3_FILES: sigma fcst files used in analysis : ',& + (ifilesig(i),i=1,nfldsig),(hrdifsig(i),i=1,nfldsig),ntguessig + + +! Load time information for surface guess field info into output arrays + ntguessfc = nint(time_ges(202,2)) + do i=1,nfldsfc + hrdifsfc(i) = time_ges(i,2) + ifilesfc(i) = nint(time_ges(i+100,2)) + hrdifsfc_all(i) = hrdifsfc(i) + end do + +! Below is a temporary fix. The nems_nmmb regional mode does not have a +! surface +! file. Instead the surface fields are passed through the atmospheric guess +! file. Without a separate surface file the code above sets ntguessig and +! nfldsig to zero. This causes problems later in the code when arrays for +! the surface fields are allocated --> one of the array dimensions is nfldsfc +! and it will be zero. This portion of the code should be rewritten, but +! until +! it is, the fix below gets around the above mentioned problem. + + ntguessfc = ntguessig +!!nfldsfc = nfldsig + do i=1,nfldsfc + hrdifsfc(i) = hrdifsig(i) + ifilesfc(i) = ifilesig(i) + hrdifsfc_all(i) = hrdifsfc(i) + end do + if(mype == 0) write(6,*)'READ_nems_nmb_FILES: surface fcst files used in analysis: ',& + (ifilesfc(i),i=1,nfldsfc),(hrdifsfc(i),i=1,nfldsfc),ntguessfc + + +! End of routine + return +end subroutine read_fv3_files + +subroutine read_fv3_netcdf_guess(fv3filenamegin) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_fv3_netcdf_guess read fv3 interface file +! prgmmr: wu org: np22 date: 2017-07-06 +! +! abstract: read guess for FV3 regional model +! program history log: +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use mpimod, only: npe + use guess_grids, only: nfldsig,ges_tsen,ges_prsi + use gridmod, only: lat2,lon2,nsig,ijn,eta1_ll,eta2_ll,ijn_s + use constants, only: one,fv + use gsi_metguess_mod, only: gsi_metguess_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use mpeu_util, only: die + use guess_grids, only: ntguessig + + implicit none + + type (type_fv3regfilenameg),intent (in) :: fv3filenamegin + character(len=24),parameter :: myname = 'read_fv3_netcdf_guess' + integer(i_kind) k,i,j + integer(i_kind) it,ier,istatus + real(r_kind),dimension(:,:),pointer::ges_ps=>NULL() + real(r_kind),dimension(:,:),pointer::ges_z=>NULL() + real(r_kind),dimension(:,:,:),pointer::ges_u=>NULL() + real(r_kind),dimension(:,:,:),pointer::ges_v=>NULL() + real(r_kind),dimension(:,:,:),pointer::ges_q=>NULL() +! real(r_kind),dimension(:,:,:),pointer::ges_ql=>NULL() + real(r_kind),dimension(:,:,:),pointer::ges_oz=>NULL() + real(r_kind),dimension(:,:,:),pointer::ges_tv=>NULL() + + character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: tracers !='fv3_tracer' + + + + dynvars= fv3filenamegin%dynvars + tracers= fv3filenamegin%tracers + + if(npe< 8) then + call die('read_fv3_netcdf_guess','not enough PEs to read in fv3 fields' ) + endif + mype_u=0 + mype_v=1 + mype_t=2 + mype_p=3 + mype_q=4 + mype_ql=5 + mype_oz=6 + mype_2d=7 + + allocate(ijns(npe),ijns2d(npe),ijnz(npe) ) + allocate(displss(npe),displss2d(npe),displsz_g(npe) ) + + do i=1,npe + ijns(i)=ijn_s(i)*nsig + ijnz(i)=ijn(i)*nsig + ijns2d(i)=ijn_s(i)*n2d + enddo + displss(1)=0 + displsz_g(1)=0 + displss2d(1)=0 + do i=2,npe + displss(i)=displss(i-1)+ ijns(i-1) + displsz_g(i)=displsz_g(i-1)+ ijnz(i-1) + displss2d(i)=displss2d(i-1)+ ijns2d(i-1) + enddo + +! do it=1,nfldsig + it=ntguessig + + + ier=0 + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ps' ,ges_ps ,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'z' , ges_z ,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u' , ges_u ,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v' , ges_v ,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'tv' ,ges_tv ,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus );ier=ier+istatus +! call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql' ,ges_ql ,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'oz' ,ges_oz ,istatus );ier=ier+istatus + if (ier/=0) call die(trim(myname),'cannot get pointers for fv3 met-fields, ier =',ier) + + if( fv3sar_bg_opt == 0) then + call gsi_fv3ncdf_readuv(dynvars,ges_u,ges_v) + else + call gsi_fv3ncdf_readuv_v1(dynvars,ges_u,ges_v) + endif + if( fv3sar_bg_opt == 0) then + call gsi_fv3ncdf_read(dynvars,'T','t',ges_tsen(1,1,1,it),mype_t) + else + call gsi_fv3ncdf_read_v1(dynvars,'t','T',ges_tsen(1,1,1,it),mype_t) + endif + + if( fv3sar_bg_opt == 0) then + call gsi_fv3ncdf_read(dynvars,'DELP','delp',ges_prsi,mype_p) + ges_prsi(:,:,nsig+1,it)=eta1_ll(nsig+1) + do i=nsig,1,-1 + ges_prsi(:,:,i,it)=ges_prsi(:,:,i,it)*0.001_r_kind+ges_prsi(:,:,i+1,it) + enddo + ges_ps(:,:)=ges_prsi(:,:,1,it) + else + call gsi_fv3ncdf2d_read_v1(dynvars,'ps','PS',ges_ps,mype_p) + ges_prsi(:,:,nsig+1,it)=eta1_ll(nsig+1) + do k=1,nsig + ges_prsi(:,:,k,it)=eta1_ll(k)+eta2_ll(k)*ges_ps + enddo + endif + + + + + + if( fv3sar_bg_opt == 0) then + call gsi_fv3ncdf_read(tracers,'SPHUM','sphum',ges_q,mype_q) +! call gsi_fv3ncdf_read(tracers,'LIQ_WAT','liq_wat',ges_ql,mype_ql) + call gsi_fv3ncdf_read(tracers,'O3MR','o3mr',ges_oz,mype_oz) + else + call gsi_fv3ncdf_read_v1(tracers,'sphum','SPHUM',ges_q,mype_q) + call gsi_fv3ncdf_read_v1(tracers,'o3mr','O3MR',ges_oz,mype_oz) + endif + +!! tsen2tv !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + ges_tv(i,j,k)=ges_tsen(i,j,k,it)*(one+fv*ges_q(i,j,k)) + enddo + enddo + enddo + + call gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z) + +end subroutine read_fv3_netcdf_guess + +subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_fv3ncdf2d_read +! prgmmr: wu w org: np22 date: 2017-10-17 +! +! abstract: read in 2d fields from fv3_sfcdata file in mype_2d +! Scatter the field to each PE +! program history log: +! input argument list: +! it - time index for 2d fields +! +! output argument list: +! ges_z - surface elevation +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype + use guess_grids, only: fact10,soil_type,veg_frac,veg_type,sfc_rough, & + sfct,sno,soil_temp,soil_moi,isli + use gridmod, only: lat2,lon2,itotsub,ijn_s + use general_commvars_mod, only: ltosi_s,ltosj_s + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use mod_fv3_lola, only: fv3_h_to_ll,nxa,nya + use constants, only: grav + + implicit none + + integer(i_kind),intent(in) :: it + real(r_kind),intent(in),dimension(:,:),pointer::ges_z + type (type_fv3regfilenameg),intent(in) :: fv3filenamegin + character(len=128) :: name + integer(i_kind),allocatable,dimension(:):: dim_id,dim + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:):: a + real(r_kind),allocatable,dimension(:,:,:):: sfcn2d + real(r_kind),allocatable,dimension(:,:,:):: sfc + real(r_kind),allocatable,dimension(:,:):: sfc1 + integer(i_kind) iret,gfile_loc,i,k,len,ndim + integer(i_kind) ndimensions,nvariables,nattributes,unlimiteddimid + integer(i_kind) kk,n,ns,j,ii,jj,mm1 + character(len=:),allocatable :: sfcdata !='fv3_sfcdata' + character(len=:),allocatable :: dynvars !='fv3_dynvars' + + sfcdata= fv3filenamegin%sfcdata + dynvars= fv3filenamegin%dynvars + + mm1=mype+1 + allocate(a(nya,nxa)) + allocate(work(itotsub*n2d)) + allocate( sfcn2d(lat2,lon2,n2d)) + + if(mype==mype_2d ) then + iret=nf90_open(sfcdata,nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' problem opening3 ',trim(sfcdata),', Status = ',iret + return + endif + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + allocate(dim(ndimensions)) + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + dim(k)=len + enddo +!!!!!!!!!!!! read in 2d variables !!!!!!!!!!!!!!!!!!!!!!!!!! + do i=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,i,name,len) + if( trim(name)=='f10m'.or.trim(name)=='F10M' ) then + k=k_f10m + else if( trim(name)=='stype'.or.trim(name)=='STYPE' ) then + k=k_stype + else if( trim(name)=='vfrac'.or.trim(name)=='VFRAC' ) then + k=k_vfrac + else if( trim(name)=='vtype'.or.trim(name)=='VTYPE' ) then + k=k_vtype + else if( trim(name)=='zorl'.or.trim(name)=='ZORL' ) then + k=k_zorl + else if( trim(name)=='tsea'.or.trim(name)=='TSEA' ) then + k=k_tsea + else if( trim(name)=='sheleg'.or.trim(name)=='SHELEG' ) then + k=k_snwdph + else if( trim(name)=='stc'.or.trim(name)=='STC' ) then + k=k_stc + else if( trim(name)=='smc'.or.trim(name)=='SMC' ) then + k=k_smc + else if( trim(name)=='SLMSK'.or.trim(name)=='slmsk' ) then + k=k_slmsk + else + cycle + endif + iret=nf90_inquire_variable(gfile_loc,i,ndims=ndim) + if(allocated(dim_id )) deallocate(dim_id ) + allocate(dim_id(ndim)) + iret=nf90_inquire_variable(gfile_loc,i,dimids=dim_id) + if(allocated(sfc )) deallocate(sfc ) + allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + iret=nf90_get_var(gfile_loc,i,sfc) + call fv3_h_to_ll(sfc(:,:,1),a,nx,ny,nxa,nya) + + kk=0 + do n=1,npe + ns=displss2d(n)+(k-1)*ijn_s(n) + do j=1,ijn_s(n) + ns=ns+1 + kk=kk+1 + ii=ltosi_s(kk) + jj=ltosj_s(kk) + work(ns)=a(ii,jj) + end do + end do + enddo ! i + iret=nf90_close(gfile_loc) + +!!!! read in orog from dynam !!!!!!!!!!!! + iret=nf90_open(trim(dynvars ),nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' problem opening4 ',trim(dynvars ),gfile_loc,', Status = ',iret + return + endif + + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + if(allocated(dim )) deallocate(dim ) + allocate(dim(ndimensions)) + + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + dim(k)=len + enddo + + + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)=='PHIS' .or. trim(name)=='phis' ) then + iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim) + if(allocated(dim_id )) deallocate(dim_id ) + allocate(dim_id(ndim)) + iret=nf90_inquire_variable(gfile_loc,k,dimids=dim_id) + allocate(sfc1(dim(dim_id(1)),dim(dim_id(2))) ) + iret=nf90_get_var(gfile_loc,k,sfc1) + exit + endif + enddo ! k + iret=nf90_close(gfile_loc) + + k=k_orog + call fv3_h_to_ll(sfc1,a,nx,ny,nxa,nya) + + kk=0 + do n=1,npe + ns=displss2d(n)+(k-1)*ijn_s(n) + do j=1,ijn_s(n) + ns=ns+1 + kk=kk+1 + ii=ltosi_s(kk) + jj=ltosj_s(kk) + work(ns)=a(ii,jj) + end do + end do + + deallocate (dim_id,sfc,sfc1,dim) + endif ! mype + + +!!!!!!! scatter !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call mpi_scatterv(work,ijns2d,displss2d,mpi_rtype,& + sfcn2d,ijns2d(mm1),mpi_rtype,mype_2d,mpi_comm_world,ierror) + + deallocate ( work ) + + fact10(:,:,it)=sfcn2d(:,:,k_f10m) + soil_type(:,:,it)=sfcn2d(:,:,k_stype) + veg_frac(:,:,it)=sfcn2d(:,:,k_vfrac) + veg_type(:,:,it)=sfcn2d(:,:,k_vtype) + sfc_rough(:,:,it)=sfcn2d(:,:,k_zorl) + sfct(:,:,it)=sfcn2d(:,:,k_tsea) + sno(:,:,it)=sfcn2d(:,:,k_snwdph) + soil_temp(:,:,it)=sfcn2d(:,:,k_stc) + soil_moi(:,:,it)=sfcn2d(:,:,k_smc) + ges_z(:,:)=sfcn2d(:,:,k_orog)/grav + isli(:,:,it)=nint(sfcn2d(:,:,k_slmsk)) + deallocate (sfcn2d,a) + return +end subroutine gsi_fv3ncdf2d_read +subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_fv23ncdf2d_readv1 +! prgmmr: T. Lei date: 2019-03-28 +! modified from gsi_fv3ncdf_read and gsi_fv3ncdf2d_read +! +! abstract: read in a 2d field from a netcdf FV3 file in mype_io +! then scatter the field to each PE +! program history log: +! +! input argument list: +! filename - file name to read from +! varname - variable name to read in +! varname2 - variable name to read in +! mype_io - pe to read in the field +! +! output argument list: +! work_sub - output sub domain field +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + + use kinds, only: r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype + use gridmod, only: lat2,lon2,nsig,nlat,nlon,itotsub,ijn_s,displs_s + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inq_varid + use netcdf, only: nf90_inquire_variable + use mod_fv3_lola, only: fv3_h_to_ll + use general_commvars_mod, only: ltosi_s,ltosj_s + + implicit none + character(*) ,intent(in ) :: varname,varname2,filenamein + real(r_kind) ,intent(out ) :: work_sub(lat2,lon2) + integer(i_kind) ,intent(in ) :: mype_io + real(r_kind),allocatable,dimension(:,:,:):: uu + integer(i_kind),allocatable,dimension(:):: dim_id,dim + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:):: a + + + integer(i_kind) n,ndim + integer(i_kind) gfile_loc,var_id,iret + integer(i_kind) kk,j,mm1,ii,jj + integer(i_kind) ndimensions,nvariables,nattributes,unlimiteddimid + + mm1=mype+1 + allocate (work(itotsub)) + + if(mype==mype_io ) then + iret=nf90_open(trim(filenamein),nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' gsi_fv3ncdf2d_read_v1: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret + write(6,*)' gsi_fv3ncdf2d_read_v1: problem opening with varnam ',trim(varname) + return + endif + + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + allocate(dim(ndimensions)) + allocate(a(nlat,nlon)) + + iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) + if(iret/=nf90_noerr) then + iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname2)),var_id) + if(iret/=nf90_noerr) then + write(6,*)' wrong to get var_id ',var_id + endif + endif + + iret=nf90_inquire_variable(gfile_loc,var_id,ndims=ndim) + if(allocated(dim_id )) deallocate(dim_id ) + allocate(dim_id(ndim)) + iret=nf90_inquire_variable(gfile_loc,var_id,dimids=dim_id) + if(allocated(uu )) deallocate(uu ) + allocate(uu(nx,ny,1)) + iret=nf90_get_var(gfile_loc,var_id,uu) + call fv3_h_to_ll(uu(:,:,1),a,nx,ny,nlon,nlat) + kk=0 + do n=1,npe + do j=1,ijn_s(n) + kk=kk+1 + ii=ltosi_s(kk) + jj=ltosj_s(kk) + work(kk)=a(ii,jj) + end do + end do + + iret=nf90_close(gfile_loc) + deallocate (uu,a,dim,dim_id) + + endif !mype + + call mpi_scatterv(work,ijn_s,displs_s,mpi_rtype,& + work_sub,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + + deallocate (work) + return +end subroutine gsi_fv3ncdf2d_read_v1 + +subroutine gsi_fv3ncdf_read(filenamein,varname,varname2,work_sub,mype_io) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_fv3ncdf_read +! prgmmr: wu org: np22 date: 2017-10-10 +! +! abstract: read in a field from a netcdf FV3 file in mype_io +! then scatter the field to each PE +! program history log: +! +! input argument list: +! filename - file name to read from +! varname - variable name to read in +! varname2 - variable name to read in +! mype_io - pe to read in the field +! +! output argument list: +! work_sub - output sub domain field +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + + use kinds, only: r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype + use gridmod, only: lat2,lon2,nsig,nlat,nlon,itotsub,ijn_s + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use mod_fv3_lola, only: fv3_h_to_ll + use general_commvars_mod, only: ltosi_s,ltosj_s + + implicit none + character(*) ,intent(in ) :: varname,varname2,filenamein + real(r_kind) ,intent(out ) :: work_sub(lat2,lon2,nsig) + integer(i_kind) ,intent(in ) :: mype_io + character(len=128) :: name + real(r_kind),allocatable,dimension(:,:,:):: uu + integer(i_kind),allocatable,dimension(:):: dim_id,dim + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:):: a + + + integer(i_kind) n,ns,k,len,ndim + integer(i_kind) gfile_loc,iret + integer(i_kind) nz,nzp1,kk,j,mm1,i,ir,ii,jj + integer(i_kind) ndimensions,nvariables,nattributes,unlimiteddimid + + mm1=mype+1 + allocate (work(itotsub*nsig)) + + if(mype==mype_io ) then + iret=nf90_open(trim(filenamein),nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret + write(6,*)' gsi_fv3ncdf_read:problem opening5 with varnam ',trim(varname) + return + endif + + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + allocate(dim(ndimensions)) + allocate(a(nlat,nlon)) + + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + dim(k)=len + enddo + + + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)==varname .or. trim(name)==varname2) then + iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim) + if(allocated(dim_id )) deallocate(dim_id ) + allocate(dim_id(ndim)) + iret=nf90_inquire_variable(gfile_loc,k,dimids=dim_id) + if(allocated(uu )) deallocate(uu ) + allocate(uu(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + iret=nf90_get_var(gfile_loc,k,uu) + exit + endif + enddo ! k + nz=nsig + nzp1=nz+1 + do i=1,nz + ir=nzp1-i + call fv3_h_to_ll(uu(:,:,i),a,dim(dim_id(1)),dim(dim_id(2)),nlon,nlat) + kk=0 + do n=1,npe + ns=displss(n)+(ir-1)*ijn_s(n) + do j=1,ijn_s(n) + ns=ns+1 + kk=kk+1 + ii=ltosi_s(kk) + jj=ltosj_s(kk) + work(ns)=a(ii,jj) + end do + end do + enddo ! i + + iret=nf90_close(gfile_loc) + deallocate (uu,a,dim,dim_id) + + endif !mype + + call mpi_scatterv(work,ijns,displss,mpi_rtype,& + work_sub,ijns(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + + deallocate (work) + return +end subroutine gsi_fv3ncdf_read + +subroutine gsi_fv3ncdf_read_v1(filenamein,varname,varname2,work_sub,mype_io) + +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_fv3ncdf_read _v1 +! Lei modified from gsi_fv3ncdf_read +! prgmmr: wu org: np22 date: 2017-10-10 +! +! abstract: read in a field from a netcdf FV3 file in mype_io +! then scatter the field to each PE +! program history log: +! +! input argument list: +! filename - file name to read from +! varname - variable name to read in +! varname2 - variable name to read in +! mype_io - pe to read in the field +! +! output argument list: +! work_sub - output sub domain field +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + + use kinds, only: r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype + use gridmod, only: lat2,lon2,nsig,nlat,nlon,itotsub,ijn_s + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use netcdf, only: nf90_inq_varid + use mod_fv3_lola, only: fv3_h_to_ll + use general_commvars_mod, only: ltosi_s,ltosj_s + + implicit none + character(*) ,intent(in ) :: varname,varname2,filenamein + real(r_kind) ,intent(out ) :: work_sub(lat2,lon2,nsig) + integer(i_kind) ,intent(in ) :: mype_io + character(len=128) :: name + real(r_kind),allocatable,dimension(:,:,:):: uu + real(r_kind),allocatable,dimension(:,:,:):: temp0 + integer(i_kind),allocatable,dimension(:):: dim + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:):: a + + + integer(i_kind) n,ns,k,len,var_id + integer(i_kind) gfile_loc,iret + integer(i_kind) nztmp,nzp1,kk,j,mm1,i,ir,ii,jj + integer(i_kind) ndimensions,nvariables,nattributes,unlimiteddimid + + mm1=mype+1 + allocate (work(itotsub*nsig)) + + if(mype==mype_io ) then + iret=nf90_open(trim(filenamein),nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' gsi_fv3ncdf_read_v1: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret + write(6,*)' gsi_fv3ncdf_read_v1: problem opening5 with varnam ',trim(varname) + return + endif + + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + allocate(dim(ndimensions)) + allocate(a(nlat,nlon)) + + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + dim(k)=len + enddo + + allocate(uu(nx,ny,nsig)) + allocate(temp0(nx,ny,nsig+1)) + + iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) + if(iret/=nf90_noerr) then + iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname2)),var_id) + if(iret/=nf90_noerr) then + write(6,*)' wrong to get var_id ',var_id + endif + endif + + iret=nf90_get_var(gfile_loc,var_id,temp0) + uu(:,:,:)=temp0(:,:,2:(nsig+1)) + + nztmp=nsig + nzp1=nztmp+1 + do i=1,nztmp + ir=nzp1-i + call fv3_h_to_ll(uu(:,:,i),a,nx,ny,nlon,nlat) + kk=0 + do n=1,npe + ns=displss(n)+(ir-1)*ijn_s(n) + do j=1,ijn_s(n) + ns=ns+1 + kk=kk+1 + ii=ltosi_s(kk) + jj=ltosj_s(kk) + work(ns)=a(ii,jj) + end do + end do + enddo ! i + + iret=nf90_close(gfile_loc) + deallocate (uu,a,dim) + deallocate (temp0) + + endif !mype + + call mpi_scatterv(work,ijns,displss,mpi_rtype,& + work_sub,ijns(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + + deallocate (work) + return +end subroutine gsi_fv3ncdf_read_v1 + +subroutine gsi_fv3ncdf_readuv(dynvarsfile,ges_u,ges_v) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_fv3ncdf_readuv +! prgmmr: wu w org: np22 date: 2017-11-22 +! +! abstract: read in a field from a netcdf FV3 file in mype_u,mype_v +! then scatter the field to each PE +! program history log: +! +! input argument list: +! +! output argument list: +! ges_u - output sub domain u field +! ges_v - output sub domain v field +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype + use gridmod, only: lat2,lon2,nsig,itotsub,ijn_s + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use netcdf, only: nf90_inq_varid + use mod_fv3_lola, only: fv3_h_to_ll,nya,nxa,fv3uv2earth + use general_commvars_mod, only: ltosi_s,ltosj_s + + implicit none + character(*) ,intent(in ):: dynvarsfile + real(r_kind) ,intent(out ) :: ges_u(lat2,lon2,nsig) + real(r_kind) ,intent(out ) :: ges_v(lat2,lon2,nsig) + character(len=128) :: name + real(r_kind),allocatable,dimension(:,:,:):: uu,temp1 + integer(i_kind),allocatable,dimension(:):: dim_id,dim + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:):: a + real(r_kind),allocatable,dimension(:,:):: u,v + + integer(i_kind) n,ns,k,len,ndim + integer(i_kind) gfile_loc,iret + integer(i_kind) nz,nzp1,kk,j,mm1,i,ir,ii,jj + integer(i_kind) ndimensions,nvariables,nattributes,unlimiteddimid + + allocate (work(itotsub*nsig)) + mm1=mype+1 + if(mype==mype_u .or. mype==mype_v) then + iret=nf90_open(dynvarsfile,nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' problem opening6 ',trim(dynvarsfile),', Status = ',iret + return + endif + + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + + allocate(dim(ndimensions)) + allocate(a(nya,nxa)) + + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + dim(k)=len + enddo + + allocate(u(dim(1),dim(4))) + allocate(v(dim(1),dim(4))) + iret=nf90_inq_varid(gfile_loc,trim(adjustl("xaxis_1")),k) !thinkdeb + iret=nf90_get_var(gfile_loc,k,u(:,1)) + + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)=='u'.or.trim(name)=='U' .or. & + trim(name)=='v'.or.trim(name)=='V' ) then + iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim) + if(allocated(dim_id )) deallocate(dim_id ) + allocate(dim_id(ndim)) + iret=nf90_inquire_variable(gfile_loc,k,dimids=dim_id) +! NOTE: dimension of variables on native fv3 grid. +! u and v have an extra row in one of the dimensions + if(allocated(uu)) deallocate(uu) + allocate(uu(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + iret=nf90_get_var(gfile_loc,k,uu) + if(trim(name)=='u'.or.trim(name)=='U') then + allocate(temp1(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + temp1=uu + else if(trim(name)=='v'.or.trim(name)=='V') then + exit + endif + endif + enddo ! k +! transfor to earth u/v, interpolate to analysis grid, reverse vertical order + nz=nsig + nzp1=nz+1 + do i=1,nz + ir=nzp1-i + call fv3uv2earth(temp1(:,:,i),uu(:,:,i),nx,ny,u,v) + if(mype==mype_u)then + call fv3_h_to_ll(u,a,nx,ny,nxa,nya) + else + call fv3_h_to_ll(v,a,nx,ny,nxa,nya) + endif + kk=0 + do n=1,npe + ns=displss(n)+(ir-1)*ijn_s(n) + do j=1,ijn_s(n) + ns=ns+1 + kk=kk+1 + ii=ltosi_s(kk) + jj=ltosj_s(kk) + work(ns)=a(ii,jj) + end do + end do + enddo ! i + deallocate(temp1,a) + deallocate (dim,dim_id,uu,v,u) + iret=nf90_close(gfile_loc) + endif ! mype + +!! scatter to ges_u,ges_v !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call mpi_scatterv(work,ijns,displss,mpi_rtype,& + ges_u,ijns(mm1),mpi_rtype,mype_u,mpi_comm_world,ierror) + call mpi_scatterv(work,ijns,displss,mpi_rtype,& + ges_v,ijns(mm1),mpi_rtype,mype_v,mpi_comm_world,ierror) + deallocate(work) +end subroutine gsi_fv3ncdf_readuv +subroutine gsi_fv3ncdf_readuv_v1(dynvarsfile,ges_u,ges_v) +!$$$ subprogram documentation block +! subprogram: gsi_fv3ncdf_readuv_v1 +! prgmmr: wu w org: np22 date: 2017-11-22 +! +! program history log: +! 2019-04 lei modified from gsi_fv3ncdf_readuv to deal with cold start files . . . +! abstract: read in a field from a "cold start" netcdf FV3 file in mype_u,mype_v +! then scatter the field to each PE +! program history log: +! +! input argument list: +! +! output argument list: +! ges_u - output sub domain u field +! ges_v - output sub domain v field +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use constants, only: half + use kinds, only: r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype + use gridmod, only: lat2,lon2,nsig,itotsub,ijn_s + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use netcdf, only: nf90_inq_varid + use mod_fv3_lola, only: fv3_h_to_ll,nya,nxa,fv3uv2earth + use general_commvars_mod, only: ltosi_s,ltosj_s + + implicit none + character(*) ,intent(in ):: dynvarsfile + real(r_kind) ,intent(out ) :: ges_u(lat2,lon2,nsig) + real(r_kind) ,intent(out ) :: ges_v(lat2,lon2,nsig) + character(len=128) :: name + real(r_kind),allocatable,dimension(:,:,:):: uu,temp0 + integer(i_kind),allocatable,dimension(:):: dim + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:):: a + real(r_kind),allocatable,dimension(:,:):: uorv + + integer(i_kind) n,ns,k,len,ndim,var_id + integer(i_kind) gfile_loc,iret + integer(i_kind) nztmp,nzp1,kk,j,mm1,i,ir,ii,jj + integer(i_kind) ndimensions,nvariables,nattributes,unlimiteddimid + + allocate (work(itotsub*nsig)) + mm1=mype+1 + if(mype==mype_u .or. mype==mype_v) then + iret=nf90_open(dynvarsfile,nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' gsi_fv3ncdf_readuv_v1: problem opening ',trim(dynvarsfile),', Status = ',iret + return + endif + + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + + allocate(dim(ndimensions)) + allocate(a(nya,nxa)) + + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + dim(k)=len + enddo + allocate(uorv(nx,ny)) + if(mype == mype_u) then + allocate(uu(nx,ny+1,nsig)) + else ! for mype_v + allocate(uu(nx+1,ny,nsig)) + endif + +! transfor to earth u/v, interpolate to analysis grid, reverse vertical order + if(mype == mype_u) then + iret=nf90_inq_varid(gfile_loc,trim(adjustl("u_s")),var_id) + + iret=nf90_inquire_variable(gfile_loc,var_id,ndims=ndim) + allocate(temp0(nx,ny+1,nsig+1)) + iret=nf90_get_var(gfile_loc,var_id,temp0) + uu(:,:,:)=temp0(:,:,2:nsig+1) + deallocate(temp0) + endif + if(mype == mype_v) then + allocate(temp0(nx+1,ny,nsig+1)) + iret=nf90_inq_varid(gfile_loc,trim(adjustl("v_w")),var_id) + iret=nf90_inquire_variable(gfile_loc,var_id,ndims=ndim) + iret=nf90_get_var(gfile_loc,var_id,temp0) + uu(:,:,:)=(temp0(:,:,2:nsig+1)) + deallocate (temp0) + endif + nztmp=nsig + nzp1=nztmp+1 + do i=1,nztmp + ir=nzp1-i + if(mype == mype_u)then + do j=1,ny + uorv(:,j)=half*(uu(:,j,i)+uu(:,j+1,i)) + enddo + + call fv3_h_to_ll(uorv(:,:),a,nx,ny,nxa,nya) + else + do j=1,nx + uorv(j,:)=half*(uu(j,:,i)+uu(j+1,:,i)) + enddo + call fv3_h_to_ll(uorv(:,:),a,nx,ny,nxa,nya) + endif + kk=0 + do n=1,npe + ns=displss(n)+(ir-1)*ijn_s(n) + do j=1,ijn_s(n) + ns=ns+1 + kk=kk+1 + ii=ltosi_s(kk) + jj=ltosj_s(kk) + work(ns)=a(ii,jj) + end do + end do + enddo ! i + deallocate(a) + deallocate (uu,uorv) + iret=nf90_close(gfile_loc) + endif ! mype + +!! scatter to ges_u,ges_v !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call mpi_scatterv(work,ijns,displss,mpi_rtype,& + ges_u,ijns(mm1),mpi_rtype,mype_u,mpi_comm_world,ierror) + call mpi_scatterv(work,ijns,displss,mpi_rtype,& + ges_v,ijns(mm1),mpi_rtype,mype_v,mpi_comm_world,ierror) + deallocate(work) +end subroutine gsi_fv3ncdf_readuv_v1 + +subroutine wrfv3_netcdf(fv3filenamegin) +!$$$ subprogram documentation block +! . . . . +! subprogram: wrfv3_netcdf write out FV3 analysis increments +! prgmmr: wu org: np22 date: 2017-10-23 +! +! abstract: write FV3 analysis in netcdf format +! +! program history log: +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind + use guess_grids, only: ntguessig,ges_tsen + use gsi_metguess_mod, only: gsi_metguess_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use mpeu_util, only: die + implicit none + type (type_fv3regfilenameg),intent(in) :: fv3filenamegin + +! Declare local constants + logical add_saved + character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: tracers !='fv3_tracer' + ! variables for cloud info + integer(i_kind) ier,istatus,it + real(r_kind),pointer,dimension(:,: ):: ges_ps =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_u =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_v =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_q =>NULL() + dynvars=fv3filenamegin%dynvars + tracers=fv3filenamegin%tracers + + it=ntguessig + ier=0 + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ps' ,ges_ps ,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u' , ges_u ,istatus);ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v' , ges_v ,istatus);ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus);ier=ier+istatus + if (ier/=0) call die('get ges','cannot get pointers for fv3 met-fields, ier =',ier) + + add_saved=.true. + +! write out + if( fv3sar_bg_opt == 0) then + call gsi_fv3ncdf_write(dynvars,'T',ges_tsen(1,1,1,it),mype_t,add_saved) + call gsi_fv3ncdf_write(tracers,'sphum',ges_q ,mype_q,add_saved) + call gsi_fv3ncdf_writeuv(dynvars,ges_u,ges_v,mype_v,add_saved) + call gsi_fv3ncdf_writeps(dynvars,'delp',ges_ps,mype_p,add_saved) + else + call gsi_fv3ncdf_write(dynvars,'t',ges_tsen(1,1,1,it),mype_t,add_saved) + call gsi_fv3ncdf_write(tracers,'sphum',ges_q ,mype_q,add_saved) + call gsi_fv3ncdf_writeuv_v1(dynvars,ges_u,ges_v,mype_v,add_saved) + call gsi_fv3ncdf_writeps_v1(dynvars,'ps',ges_ps,mype_p,add_saved) + + endif + +end subroutine wrfv3_netcdf + +subroutine gsi_fv3ncdf_writeuv(dynvars,varu,varv,mype_io,add_saved) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_writeuv +! pgrmmr: wu +! +! abstract: gather u/v fields to mype_io, put u/v in FV3 model defined directions & orders +! then write out +! +! program history log: +! +! input argument list: +! varu,varv +! add_saved - true: add analysis increments to readin guess then write out +! - false: write out total analysis fields +! mype_io +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpimod, only: mpi_rtype,mpi_comm_world,ierror,npe,mype + use gridmod, only: lat2,lon2,nlon,nlat,lat1,lon1,nsig, & + ijn,displs_g,itotsub,iglobal, & + nlon_regional,nlat_regional + use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll, & + fv3uv2earth,earthuv2fv3 + use general_commvars_mod, only: ltosi,ltosj + use netcdf, only: nf90_open,nf90_close,nf90_noerr + use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_put_var,nf90_get_var + + implicit none + character(len=*),intent(in) :: dynvars !='fv3_dynvars' + + real(r_kind) ,intent(in ) :: varu(lat2,lon2,nsig) + real(r_kind) ,intent(in ) :: varv(lat2,lon2,nsig) + integer(i_kind),intent(in ) :: mype_io + logical ,intent(in ) :: add_saved + + integer(i_kind) :: ugrd_VarId,gfile_loc,vgrd_VarId + integer(i_kind) i,j,mm1,n,k,ns,kr,m + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:,:):: work_sub,work_au,work_av + real(r_kind),allocatable,dimension(:,:,:):: work_bu,work_bv + real(r_kind),allocatable,dimension(:,:):: u,v,workau2,workav2 + real(r_kind),allocatable,dimension(:,:):: workbu2,workbv2 + + mm1=mype+1 + + allocate( work(max(iglobal,itotsub)*nsig),work_sub(lat1,lon1,nsig)) +!!!!!! gather analysis u !! revers k !!!!!!!!!!! + do k=1,nsig + kr=nsig+1-k + do i=1,lon1 + do j=1,lat1 + work_sub(j,i,kr)=varu(j+1,i+1,k) + end do + end do + enddo + call mpi_gatherv(work_sub,ijnz(mm1),mpi_rtype, & + work,ijnz,displsz_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + + if(mype==mype_io) then + allocate( work_au(nlat,nlon,nsig),work_av(nlat,nlon,nsig)) + ns=0 + do m=1,npe + do k=1,nsig + do n=displs_g(m)+1,displs_g(m)+ijn(m) + ns=ns+1 + work_au(ltosi(n),ltosj(n),k)=work(ns) + end do + enddo + enddo + endif ! mype + +!!!!!! gather analysis v !! reverse k !!!!!!!!!!!!!!!!!! + do k=1,nsig + kr=nsig+1-k + do i=1,lon1 + do j=1,lat1 + work_sub(j,i,kr)=varv(j+1,i+1,k) + end do + end do + enddo + call mpi_gatherv(work_sub,ijnz(mm1),mpi_rtype, & + work,ijnz,displsz_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + + if(mype==mype_io) then + ns=0 + do m=1,npe + do k=1,nsig + do n=displs_g(m)+1,displs_g(m)+ijn(m) + ns=ns+1 + work_av(ltosi(n),ltosj(n),k)=work(ns) + end do + enddo + enddo + deallocate(work,work_sub) + allocate( u(nlon_regional,nlat_regional+1)) + allocate( v(nlon_regional+1,nlat_regional)) + allocate( work_bu(nlon_regional,nlat_regional+1,nsig)) + allocate( work_bv(nlon_regional+1,nlat_regional,nsig)) + call check( nf90_open(trim(dynvars ),nf90_write,gfile_loc) ) + call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) ) + call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) ) + + if(add_saved)then + allocate( workau2(nlat,nlon),workav2(nlat,nlon)) + allocate( workbu2(nlon_regional,nlat_regional+1)) + allocate( workbv2(nlon_regional+1,nlat_regional)) +!!!!!!!! readin work_b !!!!!!!!!!!!!!!! + call check( nf90_get_var(gfile_loc,ugrd_VarId,work_bu) ) + call check( nf90_get_var(gfile_loc,vgrd_VarId,work_bv) ) + do k=1,nsig + call fv3uv2earth(work_bu(1,1,k),work_bv(1,1,k),nlon_regional,nlat_regional,u,v) + call fv3_h_to_ll(u,workau2,nlon_regional,nlat_regional,nlon,nlat) + call fv3_h_to_ll(v,workav2,nlon_regional,nlat_regional,nlon,nlat) +!!!!!!!! find analysis_inc: work_a !!!!!!!!!!!!!!!! + work_au(:,:,k)=work_au(:,:,k)-workau2(:,:) + work_av(:,:,k)=work_av(:,:,k)-workav2(:,:) + call fv3_ll_to_h(work_au(:,:,k),u,nlon,nlat,nlon_regional,nlat_regional,.true.) + call fv3_ll_to_h(work_av(:,:,k),v,nlon,nlat,nlon_regional,nlat_regional,.true.) + call earthuv2fv3(u,v,nlon_regional,nlat_regional,workbu2,workbv2) +!!!!!!!! add analysis_inc to readin work_b !!!!!!!!!!!!!!!! + work_bu(:,:,k)=work_bu(:,:,k)+workbu2(:,:) + work_bv(:,:,k)=work_bv(:,:,k)+workbv2(:,:) + enddo + deallocate(workau2,workbu2,workav2,workbv2) + else + do k=1,nsig + call fv3_ll_to_h(work_au(:,:,k),u,nlon,nlat,nlon_regional,nlat_regional,.true.) + call fv3_ll_to_h(work_av(:,:,k),v,nlon,nlat,nlon_regional,nlat_regional,.true.) + call earthuv2fv3(u,v,nlon_regional,nlat_regional,work_bu(:,:,k),work_bv(:,:,k)) + enddo + endif + + deallocate(work_au,work_av,u,v) + print *,'write out u/v to ',trim(dynvars ) + call check( nf90_put_var(gfile_loc,ugrd_VarId,work_bu) ) + call check( nf90_put_var(gfile_loc,vgrd_VarId,work_bv) ) + call check( nf90_close(gfile_loc) ) + deallocate(work_bu,work_bv) + end if !mype_io + + if(allocated(work))deallocate(work) + if(allocated(work_sub))deallocate(work_sub) + +end subroutine gsi_fv3ncdf_writeuv + +subroutine gsi_fv3ncdf_writeps(filename,varname,var,mype_io,add_saved) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_writeps +! pgrmmr: wu +! +! abstract: write out analyzed "delp" to fv_core.res.nest02.tile7.nc +! +! program history log: +! +! input argument list: +! varu,varv +! add_saved +! mype - mpi task id +! mype_io +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpimod, only: mpi_rtype,mpi_comm_world,ierror,mype + use gridmod, only: lat2,lon2,nlon,nlat,lat1,lon1,nsig + use gridmod, only: ijn,displs_g,itotsub,iglobal + use gridmod, only: nlon_regional,nlat_regional,eta1_ll,eta2_ll + use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll + use general_commvars_mod, only: ltosi,ltosj + use netcdf, only: nf90_open,nf90_close + use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_put_var,nf90_get_var + implicit none + + real(r_kind) ,intent(in ) :: var(lat2,lon2) + integer(i_kind),intent(in ) :: mype_io + logical ,intent(in ) :: add_saved + character(*) ,intent(in ) :: varname,filename + + integer(i_kind) :: VarId,gfile_loc + integer(i_kind) i,j,mm1,k,kr,kp + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:):: work_sub,work_a + real(r_kind),allocatable,dimension(:,:,:):: work_b,work_bi + real(r_kind),allocatable,dimension(:,:):: workb2,worka2 + + + mm1=mype+1 + allocate( work(max(iglobal,itotsub)),work_sub(lat1,lon1) ) + do i=1,lon1 + do j=1,lat1 + work_sub(j,i)=var(j+1,i+1) + end do + end do + call mpi_gatherv(work_sub,ijn(mm1),mpi_rtype, & + work,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + + if(mype==mype_io) then + allocate( work_a(nlat,nlon)) + do i=1,iglobal + work_a(ltosi(i),ltosj(i))=work(i) + end do + allocate( work_bi(nlon_regional,nlat_regional,nsig+1)) + allocate( work_b(nlon_regional,nlat_regional,nsig)) + call check( nf90_open(trim(filename),nf90_write,gfile_loc) ) + call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + + if(add_saved)then + allocate( workb2(nlon_regional,nlat_regional)) + allocate( worka2(nlat,nlon)) +!!!!!!!! read in guess delp !!!!!!!!!!!!!! + call check( nf90_get_var(gfile_loc,VarId,work_b) ) + work_bi(:,:,1)=eta1_ll(nsig+1) + do i=2,nsig+1 + work_bi(:,:,i)=work_b(:,:,i-1)*0.001_r_kind+work_bi(:,:,i-1) + enddo + call fv3_h_to_ll(work_bi(:,:,nsig+1),worka2,nlon_regional,nlat_regional,nlon,nlat) +!!!!!!! analysis_inc Psfc: work_a + work_a(:,:)=work_a(:,:)-worka2(:,:) + call fv3_ll_to_h(work_a,workb2,nlon,nlat,nlon_regional,nlat_regional,.true.) + do k=1,nsig+1 + kr=nsig+2-k +!!!!!!! ges_prsi+hydrostatic analysis_inc !!!!!!!!!!!!!!!! + work_bi(:,:,k)=work_bi(:,:,k)+eta2_ll(kr)*workb2(:,:) + enddo + else + call fv3_ll_to_h(work_a,workb2,nlon,nlat,nlon_regional,nlat_regional,.true.) + do k=1,nsig+1 + kr=nsig+2-k +!!!!!!! Psfc_ges+hydrostatic analysis_inc !!!!!!!!!!!!!!!! + work_bi(:,:,k)=eta1_ll(kr)+eta2_ll(kr)*workb2(:,:) + enddo + endif +! delp + do k=nsig,1,-1 + kp=k+1 + work_b(:,:,k)=(work_bi(:,:,kp)-work_bi(:,:,k))*1000._r_kind + enddo + + call check( nf90_put_var(gfile_loc,VarId,work_b) ) + call check( nf90_close(gfile_loc) ) + deallocate(worka2,workb2) + deallocate(work_b,work_a,work_bi) + + end if !mype_io + + deallocate(work,work_sub) +end subroutine gsi_fv3ncdf_writeps +subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_writeuv +! pgrmmr: wu +! +! abstract: gather u/v fields to mype_io, put u/v in FV3 model defined directions & orders +! then write out +! +! program history log: +! 2019-04-22 lei modified from gsi_nemsio_writeuv_v1 for update +! u_w,v_w,u_s,v_s in the cold start files! +! input argument list: +! varu,varv +! add_saved - true: add analysis increments to readin guess then write out +! - false: write out total analysis fields +! mype_io +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use constants, only: half,zero + use mpimod, only: mpi_rtype,mpi_comm_world,ierror,npe,mype + use gridmod, only: lat2,lon2,nlon,nlat,lat1,lon1,nsig, & + ijn,displs_g,itotsub,iglobal, & + nlon_regional,nlat_regional + use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll, & + fv3uv2earth,earthuv2fv3 + use general_commvars_mod, only: ltosi,ltosj + use netcdf, only: nf90_open,nf90_close,nf90_noerr + use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_put_var,nf90_get_var + + implicit none + character(len=*),intent(in) :: dynvars !='fv3_dynvars' + + real(r_kind) ,intent(in ) :: varu(lat2,lon2,nsig) + real(r_kind) ,intent(in ) :: varv(lat2,lon2,nsig) + integer(i_kind),intent(in ) :: mype_io + logical ,intent(in ) :: add_saved + + integer(i_kind) :: gfile_loc + integer(i_kind) :: u_wgrd_VarId,v_wgrd_VarId + integer(i_kind) :: u_sgrd_VarId,v_sgrd_VarId + integer(i_kind) i,j,mm1,n,k,ns,kr,m + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:,:):: work_sub,work_au,work_av + real(r_kind),allocatable,dimension(:,:,:):: work_bu_s,work_bv_s + real(r_kind),allocatable,dimension(:,:,:):: work_bu_w,work_bv_w + real(r_kind),allocatable,dimension(:,:):: u,v,workau2,workav2 + real(r_kind),allocatable,dimension(:,:):: workbu_s2,workbv_s2 + real(r_kind),allocatable,dimension(:,:):: workbu_w2,workbv_w2 + + mm1=mype+1 + + allocate( work(max(iglobal,itotsub)*nsig),work_sub(lat1,lon1,nsig)) +!!!!!! gather analysis u !! revers k !!!!!!!!!!! + do k=1,nsig + kr=nsig+1-k + do i=1,lon1 + do j=1,lat1 + work_sub(j,i,kr)=varu(j+1,i+1,k) + end do + end do + enddo + call mpi_gatherv(work_sub,ijnz(mm1),mpi_rtype, & + work,ijnz,displsz_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + + if(mype==mype_io) then + allocate( work_au(nlat,nlon,nsig),work_av(nlat,nlon,nsig)) + ns=0 + do m=1,npe + do k=1,nsig + do n=displs_g(m)+1,displs_g(m)+ijn(m) + ns=ns+1 + work_au(ltosi(n),ltosj(n),k)=work(ns) + end do + enddo + enddo + endif ! mype + +!!!!!! gather analysis v !! reverse k !!!!!!!!!!!!!!!!!! + do k=1,nsig + kr=nsig+1-k + do i=1,lon1 + do j=1,lat1 + work_sub(j,i,kr)=varv(j+1,i+1,k) + end do + end do + enddo + call mpi_gatherv(work_sub,ijnz(mm1),mpi_rtype, & + work,ijnz,displsz_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + + if(mype==mype_io) then + ns=0 + do m=1,npe + do k=1,nsig + do n=displs_g(m)+1,displs_g(m)+ijn(m) + ns=ns+1 + work_av(ltosi(n),ltosj(n),k)=work(ns) + end do + enddo + enddo + deallocate(work,work_sub) +!clt u and v would contain winds at either D-grid or A-grid +!clt do not diretly use them in between fv3uv2eath and fv3_h_to_ll unless paying +!attention to the actual storage layout + call check( nf90_open(trim(dynvars ),nf90_write,gfile_loc) ) + + allocate( u(nlon_regional,nlat_regional)) + allocate( v(nlon_regional,nlat_regional)) + + allocate( work_bu_s(nlon_regional,nlat_regional+1,nsig)) + allocate( work_bv_s(nlon_regional,nlat_regional+1,nsig)) + allocate( work_bu_w(nlon_regional+1,nlat_regional,nsig)) + allocate( work_bv_w(nlon_regional+1,nlat_regional,nsig)) + + + + call check( nf90_inq_varid(gfile_loc,'u_s',u_sgrd_VarId) ) + call check( nf90_inq_varid(gfile_loc,'u_w',u_wgrd_VarId) ) + call check( nf90_inq_varid(gfile_loc,'v_s',v_sgrd_VarId) ) + call check( nf90_inq_varid(gfile_loc,'v_w',v_wgrd_VarId) ) + + if(add_saved)then + allocate( workau2(nlat,nlon),workav2(nlat,nlon)) + allocate( workbu_w2(nlon_regional+1,nlat_regional)) + allocate( workbv_w2(nlon_regional+1,nlat_regional)) + allocate( workbu_s2(nlon_regional,nlat_regional+1)) + allocate( workbv_s2(nlon_regional,nlat_regional+1)) +!!!!!!!! readin work_b !!!!!!!!!!!!!!!! + call check( nf90_get_var(gfile_loc,u_sgrd_VarId,work_bu_s) ) + call check( nf90_get_var(gfile_loc,u_wgrd_VarId,work_bu_w) ) + call check( nf90_get_var(gfile_loc,v_sgrd_VarId,work_bv_s) ) + call check( nf90_get_var(gfile_loc,v_wgrd_VarId,work_bv_w) ) + do k=1,nsig + do j=1,nlat_regional + u(:,j)=half * (work_bu_s(:,j,k)+ work_bu_s(:,j+1,k)) + enddo + do i=1,nlon_regional + v(i,:)=half*(work_bv_w(i,:,k)+work_bv_w(i+1,:,k)) + enddo + call fv3_h_to_ll(u,workau2,nlon_regional,nlat_regional,nlon,nlat) + call fv3_h_to_ll(v,workav2,nlon_regional,nlat_regional,nlon,nlat) +!!!!!!!! find analysis_inc: work_a !!!!!!!!!!!!!!!! + work_au(:,:,k)=work_au(:,:,k)-workau2(:,:) + work_av(:,:,k)=work_av(:,:,k)-workav2(:,:) + call fv3_ll_to_h(work_au(:,:,k),u,nlon,nlat,nlon_regional,nlat_regional,.true.) + call fv3_ll_to_h(work_av(:,:,k),v,nlon,nlat,nlon_regional,nlat_regional,.true.) +!!!!!!!! add analysis_inc to readin work_b !!!!!!!!!!!!!!!! + do i=2,nlon_regional-1 + workbu_w2(i,:)=half*(u(i,:)+u(i+1,:)) + workbv_w2(i,:)=half*(v(i,:)+v(i+1,:)) + enddo + workbu_w2(1,:)=u(1,:) + workbv_w2(1,:)=v(1,:) + workbu_w2(nlon_regional+1,:)=u(nlon_regional,:) + workbv_w2(nlon_regional+1,:)=v(nlon_regional,:) + + do j=2,nlat_regional-1 + workbu_s2(:,j)=half*(u(:,j)+u(:,j+1)) + workbv_s2(:,j)=half*(v(:,j)+v(:,j+1)) + enddo + workbu_s2(:,1)=u(:,1) + workbv_s2(:,1)=v(:,1) + workbu_s2(:,nlat_regional+1)=u(:,nlat_regional) + workbv_s2(:,nlat_regional+1)=v(:,nlat_regional) + + + + work_bu_w(:,:,k)=work_bu_w(:,:,k)+workbu_w2(:,:) + work_bu_s(:,:,k)=work_bu_s(:,:,k)+workbu_s2(:,:) + work_bv_w(:,:,k)=work_bv_w(:,:,k)+workbv_w2(:,:) + work_bv_s(:,:,k)=work_bv_s(:,:,k)+workbv_s2(:,:) + enddo + deallocate(workau2,workav2) + deallocate(workbu_w2,workbv_w2) + deallocate(workbu_s2,workbv_s2) + else + do k=1,nsig + call fv3_ll_to_h(work_au(:,:,k),u,nlon,nlat,nlon_regional,nlat_regional,.true.) + call fv3_ll_to_h(work_av(:,:,k),v,nlon,nlat,nlon_regional,nlat_regional,.true.) + + do i=2,nlon_regional-1 + work_bu_w(i,:,k)=half*(u(i,:)+u(i+1,:)) + work_bv_w(i,:,k)=half*(v(i,:)+v(i+1,:)) + enddo + work_bu_w(1,:,k)=u(1,:) + work_bv_w(1,:,k)=v(1,:) + work_bu_w(nlon_regional+1,:,k)=u(nlon_regional,:) + work_bv_w(nlon_regional+1,:,k)=v(nlon_regional,:) + + do j=2,nlat_regional-1 + work_bu_s(:,j,k)=half*(u(:,j)+u(:,j+1)) + work_bv_s(:,j,k)=half*(v(:,j)+v(:,j+1)) + enddo + work_bu_s(:,1,k)=u(:,1) + work_bv_s(:,1,k)=v(:,1) + work_bu_s(:,nlat_regional+1,k)=u(:,nlat_regional) + work_bv_s(:,nlat_regional+1,k)=v(:,nlat_regional) + + + enddo + endif + + deallocate(work_au,work_av,u,v) + print *,'write out u/v to ',trim(dynvars ) + call check( nf90_put_var(gfile_loc,u_wgrd_VarId,work_bu_w) ) + call check( nf90_put_var(gfile_loc,u_sgrd_VarId,work_bu_s) ) + call check( nf90_put_var(gfile_loc,v_wgrd_VarId,work_bv_w) ) + call check( nf90_put_var(gfile_loc,v_sgrd_VarId,work_bv_s) ) + call check( nf90_close(gfile_loc) ) + deallocate(work_bu_w,work_bv_w) + deallocate(work_bu_s,work_bv_s) + end if !mype_io + + if(allocated(work))deallocate(work) + if(allocated(work_sub))deallocate(work_sub) + +end subroutine gsi_fv3ncdf_writeuv_v1 + +subroutine gsi_fv3ncdf_writeps_v1(filename,varname,var,mype_io,add_saved) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_writeps +! pgrmmr: wu +! +! abstract: write out analyzed "delp" to fv_core.res.nest02.tile7.nc +! +! program history log: +! 2019-04 lei, modified from gsi_nemsio_writeps to deal with cold start files +! +! input argument list: +! varu,varv +! add_saved +! mype - mpi task id +! mype_io +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpimod, only: mpi_rtype,mpi_comm_world,ierror,mype + use gridmod, only: lat2,lon2,nlon,nlat,lat1,lon1,nsig + use gridmod, only: ijn,displs_g,itotsub,iglobal + use gridmod, only: nlon_regional,nlat_regional,eta1_ll,eta2_ll + use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll + use general_commvars_mod, only: ltosi,ltosj + use netcdf, only: nf90_open,nf90_close + use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_put_var,nf90_get_var + implicit none + + real(r_kind) ,intent(in ) :: var(lat2,lon2) + integer(i_kind),intent(in ) :: mype_io + logical ,intent(in ) :: add_saved + character(*) ,intent(in ) :: varname,filename + + integer(i_kind) :: VarId,gfile_loc + integer(i_kind) i,j,mm1 + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:):: work_sub,work_a + real(r_kind),allocatable,dimension(:,:):: work_b,work_bi + real(r_kind),allocatable,dimension(:,:):: workb2,worka2 + + + mm1=mype+1 + allocate( work(max(iglobal,itotsub)),work_sub(lat1,lon1) ) + do i=1,lon1 + do j=1,lat1 + work_sub(j,i)=var(j+1,i+1) + end do + end do + call mpi_gatherv(work_sub,ijn(mm1),mpi_rtype, & + work,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + + if(mype==mype_io) then + allocate( work_a(nlat,nlon)) + do i=1,iglobal + work_a(ltosi(i),ltosj(i))=work(i) + end do + allocate( work_bi(nlon_regional,nlat_regional)) + allocate( work_b(nlon_regional,nlat_regional)) + call check( nf90_open(trim(filename),nf90_write,gfile_loc) ) + call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + work_a=work_a*1000.0_r_kind + if(add_saved)then + allocate( workb2(nlon_regional,nlat_regional)) + allocate( worka2(nlat,nlon)) +!!!!!!!! read in guess delp !!!!!!!!!!!!!! + call check( nf90_get_var(gfile_loc,VarId,work_b) ) + call fv3_h_to_ll(work_b,worka2,nlon_regional,nlat_regional,nlon,nlat) +!!!!!!! analysis_inc Psfc: work_a + work_a(:,:)=work_a(:,:)-worka2(:,:) + call fv3_ll_to_h(work_a,workb2,nlon,nlat,nlon_regional,nlat_regional,.true.) + work_b(:,:)=work_b(:,:)+workb2(:,:) + else + call fv3_ll_to_h(work_a,work_b,nlon,nlat,nlon_regional,nlat_regional,.true.) + + endif + + call check( nf90_put_var(gfile_loc,VarId,work_b) ) + call check( nf90_close(gfile_loc) ) + deallocate(worka2,workb2) + deallocate(work_b,work_a,work_bi) + + end if !mype_io + + deallocate(work,work_sub) +end subroutine gsi_fv3ncdf_writeps_v1 + +subroutine gsi_fv3ncdf_write(filename,varname,var,mype_io,add_saved) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_nemsio_write +! pgrmmr: wu +! +! abstract: +! +! program history log: +! +! input argument list: +! varu,varv +! add_saved +! mype - mpi task id +! mype_io +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpimod, only: mpi_rtype,mpi_comm_world,ierror,npe,mype + use gridmod, only: lat2,lon2,nlon,nlat,lat1,lon1,nsig + use gridmod, only: ijn,displs_g,itotsub,iglobal + use mod_fv3_lola, only: fv3_ll_to_h + use mod_fv3_lola, only: fv3_h_to_ll + use general_commvars_mod, only: ltosi,ltosj + use netcdf, only: nf90_open,nf90_close + use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_put_var,nf90_get_var + implicit none + + real(r_kind) ,intent(in ) :: var(lat2,lon2,nsig) + integer(i_kind),intent(in ) :: mype_io + logical ,intent(in ) :: add_saved + character(*) ,intent(in ) :: varname,filename + + integer(i_kind) :: VarId,gfile_loc + integer(i_kind) i,j,mm1,k,kr,ns,n,m + real(r_kind),allocatable,dimension(:):: work + real(r_kind),allocatable,dimension(:,:,:):: work_sub,work_a + real(r_kind),allocatable,dimension(:,:,:):: work_b + real(r_kind),allocatable,dimension(:,:):: workb2,worka2 + + + mm1=mype+1 + + allocate( work(max(iglobal,itotsub)*nsig),work_sub(lat1,lon1,nsig)) +!!!!!!!! reverse z !!!!!!!!!!!!!! + do k=1,nsig + kr=nsig+1-k + do i=1,lon1 + do j=1,lat1 + work_sub(j,i,kr)=var(j+1,i+1,k) + end do + end do + enddo + call mpi_gatherv(work_sub,ijnz(mm1),mpi_rtype, & + work,ijnz,displsz_g,mpi_rtype,mype_io,mpi_comm_world,ierror) + + if(mype==mype_io) then + allocate( work_a(nlat,nlon,nsig)) + ns=0 + do m=1,npe + do k=1,nsig + do n=displs_g(m)+1,displs_g(m)+ijn(m) + ns=ns+1 + work_a(ltosi(n),ltosj(n),k)=work(ns) + end do + enddo + enddo + + allocate( work_b(nlon_regional,nlat_regional,nsig)) + + call check( nf90_open(trim(filename),nf90_write,gfile_loc) ) + call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + + + if(add_saved)then + allocate( workb2(nlon_regional,nlat_regional)) + allocate( worka2(nlat,nlon)) + call check( nf90_get_var(gfile_loc,VarId,work_b) ) + + do k=1,nsig + call fv3_h_to_ll(work_b(:,:,k),worka2,nlon_regional,nlat_regional,nlon,nlat) +!!!!!!!! analysis_inc: work_a !!!!!!!!!!!!!!!! + work_a(:,:,k)=work_a(:,:,k)-worka2(:,:) + call fv3_ll_to_h(work_a(1,1,k),workb2,nlon,nlat,nlon_regional,nlat_regional,.true.) + work_b(:,:,k)=work_b(:,:,k)+workb2(:,:) + enddo + deallocate(worka2,workb2) + else + do k=1,nsig + call fv3_ll_to_h(work_a(1,1,k),work_b(1,1,k),nlon,nlat,nlon_regional,nlat_regional,.true.) + enddo + endif + + print *,'write out ',trim(varname),' to ',trim(filename) + call check( nf90_put_var(gfile_loc,VarId,work_b) ) + call check( nf90_close(gfile_loc) ) + deallocate(work_b,work_a) + end if !mype_io + + deallocate(work,work_sub) + +end subroutine gsi_fv3ncdf_write +subroutine check(status) + use kinds, only: i_kind + use netcdf, only: nf90_noerr,nf90_strerror + integer(i_kind), intent ( in) :: status + + if(status /= nf90_noerr) then + print *,'ncdf error ', trim(nf90_strerror(status)) + stop + end if +end subroutine check + + +end module gsi_rfv3io_mod diff --git a/src/gsi/gsi_rwOper.F90 b/src/gsi/gsi_rwOper.F90 new file mode 100644 index 000000000..e5806afba --- /dev/null +++ b/src/gsi/gsi_rwOper.F90 @@ -0,0 +1,161 @@ +module gsi_rwOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_rwOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for rwNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_rwNode , only: rwNode + implicit none + public:: rwOper ! data stracture + + type,extends(obOper):: rwOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type rwOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_rwOper' + type(rwNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[rwOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use rw_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_rw + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(rwOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intrwmod, only: intjo => intrw + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(rwOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stprwmod, only: stpjo => stprw + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(rwOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_rwOper diff --git a/src/gsi/gsi_spdOper.F90 b/src/gsi/gsi_spdOper.F90 new file mode 100644 index 000000000..c121adc9d --- /dev/null +++ b/src/gsi/gsi_spdOper.F90 @@ -0,0 +1,161 @@ +module gsi_spdOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_spdOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for spdNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_spdNode , only: spdNode + implicit none + public:: spdOper ! data stracture + + type,extends(obOper):: spdOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type spdOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_spdOper' + type(spdNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[spdOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use spd_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_uv + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(spdOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intspdmod, only: intjo => intspd + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(spdOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpspdmod, only: stpjo => stpspd + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(spdOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_spdOper diff --git a/src/gsi/gsi_sstOper.F90 b/src/gsi/gsi_sstOper.F90 new file mode 100644 index 000000000..ef75786ae --- /dev/null +++ b/src/gsi/gsi_sstOper.F90 @@ -0,0 +1,161 @@ +module gsi_sstOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_sstOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for sstNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_sstNode , only: sstNode + implicit none + public:: sstOper ! data stracture + + type,extends(obOper):: sstOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type sstOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_sstOper' + type(sstNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[sstOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use sst_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_sst + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(sstOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intsstmod, only: intjo => intsst + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(sstOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpsstmod, only: stpjo => stpsst + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(sstOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_sstOper diff --git a/src/gsi/gsi_swcpOper.F90 b/src/gsi/gsi_swcpOper.F90 new file mode 100644 index 000000000..3c6dc1ea4 --- /dev/null +++ b/src/gsi/gsi_swcpOper.F90 @@ -0,0 +1,161 @@ +module gsi_swcpOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_swcpOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for swcpNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_swcpNode, only: swcpNode + implicit none + public:: swcpOper ! data stracture + + type,extends(obOper):: swcpOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type swcpOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_swcpOper' + type(swcpNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[swcpOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use swcp_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_swcp + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(swcpOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intswcpmod, only: intjo => intswcp + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(swcpOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpswcpmod, only: stpjo => stpswcp + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(swcpOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_swcpOper diff --git a/src/gsi/gsi_tOper.F90 b/src/gsi/gsi_tOper.F90 new file mode 100644 index 000000000..47f3e4c60 --- /dev/null +++ b/src/gsi/gsi_tOper.F90 @@ -0,0 +1,190 @@ +module gsi_tOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_tOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for tNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_tNode , only: tNode + implicit none + public:: tOper ! data stracture + + type,extends(obOper):: tOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type tOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_tOper' + type(tNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[tOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use t_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_t + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(tOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use inttmod, only: intjo => intt + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use bias_predictors, only: predictors_getdim + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(tOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + integer(i_kind):: i,l,n + class(obsNode),pointer:: headNode + +! Are the different calls to intt() with optional arguments realy needed? +! There is no checking of present(rpred) or present(spred) inside intt_() +! anyway. Other logic is used to avoid accessing non-present rpred(:) and +! spred(:). + + call predictors_getdim(lbnd_t=i,ubnd_t=l,size_t=n) + headNode => obsLList_headNode(self%obsLL(ibin)) + if(n>0) then + call intjo(headNode, rval,sval, qpred(i:l),sbias%predt) + else + call intjo(headNode, rval,sval) + endif + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stptmod, only: stpjo => stpt + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors, predictors_getdim + use aircraftinfo, only: npredt,ntail,aircraft_t_bc_pof,aircraft_t_bc + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(tOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + real(r_kind),pointer,dimension(:,:) :: dpred,xpred + integer(i_kind):: n + +! Are the different calls to stpt() with optional arguments realy needed? +! There is no checking of present(rpred) or present(spred) inside intt_() +! anyway. Other logic is used to avoid accessing non-present rpred(:) and +! spred(:). + + headNode => obsLList_headNode(self%obsLL(ibin)) + call predictors_getdim(size_t=n) + if(n<=0 .or. .not. (aircraft_t_bc_pof .or. aircraft_t_bc)) then + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + else + dpred(1:npredt,1:ntail) => dbias%predt(1:n) + xpred(1:npredt,1:ntail) => xbias%predt(1:n) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep,dpred,xpred) + dpred => null() + xpred => null() + endif + headNode => null() + end subroutine stpjo1_ + +end module gsi_tOper diff --git a/src/gsi/gsi_tcamtOper.F90 b/src/gsi/gsi_tcamtOper.F90 new file mode 100644 index 000000000..f12ac72a6 --- /dev/null +++ b/src/gsi/gsi_tcamtOper.F90 @@ -0,0 +1,161 @@ +module gsi_tcamtOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_tcamtOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for tcamtNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper , only: obOper + use m_tcamtNode, only: tcamtNode + implicit none + public:: tcamtOper ! data stracture + + type,extends(obOper):: tcamtOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type tcamtOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_tcamtOper' + type(tcamtNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[tcamtOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use tcamt_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_tcamt + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(tcamtOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use inttcamtmod, only: intjo => inttcamt + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(tcamtOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stptcamtmod, only: stpjo => stptcamt + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(tcamtOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_tcamtOper diff --git a/src/gsi/gsi_tcpOper.F90 b/src/gsi/gsi_tcpOper.F90 new file mode 100644 index 000000000..706c24164 --- /dev/null +++ b/src/gsi/gsi_tcpOper.F90 @@ -0,0 +1,161 @@ +module gsi_tcpOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_tcpOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for tcpNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_tcpNode , only: tcpNode + implicit none + public:: tcpOper ! data stracture + + type,extends(obOper):: tcpOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type tcpOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_tcpOper' + type(tcpNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[tcpOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use tcp_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_tcp + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(tcpOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use inttcpmod, only: intjo => inttcp + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(tcpOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stptcpmod, only: stpjo => stptcp + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(tcpOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_tcpOper diff --git a/src/gsi/gsi_td2mOper.F90 b/src/gsi/gsi_td2mOper.F90 new file mode 100644 index 000000000..3a99169b9 --- /dev/null +++ b/src/gsi/gsi_td2mOper.F90 @@ -0,0 +1,161 @@ +module gsi_td2mOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_td2mOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for td2mNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_td2mNode, only: td2mNode + implicit none + public:: td2mOper ! data stracture + + type,extends(obOper):: td2mOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type td2mOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_td2mOper' + type(td2mNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[td2mOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use td2m_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_td2m + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(td2mOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use inttd2mmod, only: intjo => inttd2m + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(td2mOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stptd2mmod, only: stpjo => stptd2m + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(td2mOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_td2mOper diff --git a/src/gsi_unformatted.F90 b/src/gsi/gsi_unformatted.F90 similarity index 100% rename from src/gsi_unformatted.F90 rename to src/gsi/gsi_unformatted.F90 diff --git a/src/gsi/gsi_uwnd10mOper.F90 b/src/gsi/gsi_uwnd10mOper.F90 new file mode 100644 index 000000000..4d35a61c3 --- /dev/null +++ b/src/gsi/gsi_uwnd10mOper.F90 @@ -0,0 +1,161 @@ +module gsi_uwnd10mOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_uwnd10mOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for uwnd10mNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper , only: obOper + use m_uwnd10mNode, only: uwnd10mNode + implicit none + public:: uwnd10mOper ! data stracture + + type,extends(obOper):: uwnd10mOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type uwnd10mOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_uwnd10mOper' + type(uwnd10mNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[uwnd10mOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use uwnd10m_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_uwnd10m + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(uwnd10mOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intuwnd10mmod, only: intjo => intuwnd10m + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(uwnd10mOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpuwnd10mmod, only: stpjo => stpuwnd10m + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(uwnd10mOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_uwnd10mOper diff --git a/src/gsi/gsi_visOper.F90 b/src/gsi/gsi_visOper.F90 new file mode 100644 index 000000000..d8cc41efd --- /dev/null +++ b/src/gsi/gsi_visOper.F90 @@ -0,0 +1,161 @@ +module gsi_visOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_visOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for visNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_visNode , only: visNode + implicit none + public:: visOper ! data stracture + + type,extends(obOper):: visOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type visOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_visOper' + type(visNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[visOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use vis_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_vis + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(visOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intvismod, only: intjo => intvis + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(visOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpvismod, only: stpjo => stpvis + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(visOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_visOper diff --git a/src/gsi/gsi_vwnd10mOper.F90 b/src/gsi/gsi_vwnd10mOper.F90 new file mode 100644 index 000000000..081d8c150 --- /dev/null +++ b/src/gsi/gsi_vwnd10mOper.F90 @@ -0,0 +1,161 @@ +module gsi_vwnd10mOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_vwnd10mOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for vwnd10mNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper , only: obOper + use m_vwnd10mNode, only: vwnd10mNode + implicit none + public:: vwnd10mOper ! data stracture + + type,extends(obOper):: vwnd10mOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type vwnd10mOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_vwnd10mOper' + type(vwnd10mNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[vwnd10mOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use vwnd10m_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_vwnd10m + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(vwnd10mOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intvwnd10mmod, only: intjo => intvwnd10m + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(vwnd10mOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpvwnd10mmod, only: stpjo => stpvwnd10m + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(vwnd10mOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_vwnd10mOper diff --git a/src/gsi/gsi_wOper.F90 b/src/gsi/gsi_wOper.F90 new file mode 100644 index 000000000..0df699f82 --- /dev/null +++ b/src/gsi/gsi_wOper.F90 @@ -0,0 +1,161 @@ +module gsi_wOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_wOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for wNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_wNode , only: wNode + implicit none + public:: wOper ! data stracture + + type,extends(obOper):: wOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type wOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_wOper' + type(wNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[wOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use w_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_uv + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(wOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intwmod, only: intjo => intw + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(wOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpwmod, only: stpjo => stpw + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(wOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_wOper diff --git a/src/gsi/gsi_wspd10mOper.F90 b/src/gsi/gsi_wspd10mOper.F90 new file mode 100644 index 000000000..0fbb19e5e --- /dev/null +++ b/src/gsi/gsi_wspd10mOper.F90 @@ -0,0 +1,161 @@ +module gsi_wspd10mOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_wspd10mOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for wspd10mNode type +! +! program history log: +! 2018-08-10 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper , only: obOper + use m_wspd10mNode, only: wspd10mNode + implicit none + public:: wspd10mOper ! data stracture + + type,extends(obOper):: wspd10mOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type wspd10mOper + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_wspd10mOper' + type(wspd10mNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[wspd10mOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) + use wspd10m_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_wspd10m + + use obsmod , only: write_diag + use convinfo, only: diag_conv + use jfunc , only: jiter + + use mpeu_util, only: die + implicit none + class(wspd10mOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + + if(nobs == 0) return + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_conv + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intwspd10mmod, only: intjo => intwspd10m + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(wspd10mOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpwspd10mmod, only: stpjo => stpwspd10m + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(wspd10mOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() + end subroutine stpjo1_ + +end module gsi_wspd10mOper diff --git a/src/gsimain.f90 b/src/gsi/gsimain.f90 similarity index 94% rename from src/gsimain.f90 rename to src/gsi/gsimain.f90 index 0216c3d42..5eaa38286 100644 --- a/src/gsimain.f90 +++ b/src/gsi/gsimain.f90 @@ -9,6 +9,8 @@ program gsi + use gsi_fixture, only: my_fixture_config => fixture_config + use gsimod, only: gsimain_initialize,gsimain_run,gsimain_finalize use gsi_4dvar, only: l4dvar use gsi_4dcouplermod, only: gsi_4dcoupler_init_traj @@ -124,6 +126,11 @@ program gsi ! and gsi_4dcoupler_final_traj() from gsimain_finalize(), ! 2011-08-01 lueken - replaced F90 with f90 (no machine logic) ! 2013-07-02 parrish - remove error message 328 - tlnmc_type > 2 not allowed +! 2018-02-15 wu - add fv3_regional +! 2017-11-29 apodaca - add information, source codes, and exit states +! related to the GOES/GLM lightnig assimilation +! 2019-07-09 todling - add initialization of abstract layer defining use of GFS ensemble +! 2019-08-04 guo - moved ensemble object configuration into module gsi_fixture. ! ! usage: ! input files: @@ -137,6 +144,7 @@ program gsi ! satbias_angle - satellite angle dependent file ! satbias_in - satellite bias correction coefficient file ! satinfo - satellite channel info file +! lightinfo - lightning flash rate observation info file ! sfcf** - background surface files (typically sfcf03,sfcf06 and sfcf09) ! sigf** - background forecast files (typically sigf03,sigf06 and sigf09) ! spectral_coefficients - radiative transfer spectral coefficient file @@ -175,26 +183,26 @@ program gsi ! fill_mass_grid2, fill_nmm_grid2, fpvsx_ad, gengrid_vars, genqsat, ! glbsoi, grdcrd, grdsphdp, grid2sub, gridmod, gscond_ad, ! gsimain, gsisub, guess_grids, half_nmm_grid2, hopers, iceem_amsu, -! inguesfc, inisph, intall, intall_qc, intdw, intlimq, +! inguesfc, inisph, intall, intall_qc, intdw, intlight, intlimq, ! intoz, intpcp, intps, intpw, intq, intrad, intref, intbend, intrp2a, intrp3, ! intrp3oz, intrppx, intrw, intspd, intsst, intt, intw, jfunc, -! kinds, landem, locatelat_reg, mpimod, nlmsas_ad, obs_para, obsmod, -! omegas_ad, oneobmod, ozinfo, pcgsoi, pcpinfo, polcarf, precpd_ad, -! prewgt, prewgt_reg, psichi2uv_reg, psichi2uvt_reg, +! kinds, landem, lightbias, lightinfo, locatelat_reg, mpimod, nlmsas_ad, +! obs_para, obsmod, omegas_ad, oneobmod, ozinfo, pcgsoi, pcpinfo, polcarf, +! precpd_ad, prewgt, prewgt_reg, psichi2uv_reg, psichi2uvt_reg, ! qcmod, rad_tran_k, radinfo, rdgesig, rdgstat_reg, rdsfull, ! read_airs, read_avhrr_navy, read_bufrtovs, read_files, read_goesimg, -! read_goesndr, read_gps_ref, read_guess, read_ieeetovs, read_lidar, -! read_obs, read_ozone, read_pcp, read_prepbufr, read_radar, +! read_goesglm, read_goesndr, read_gps_ref, read_guess, read_ieeetovs, +! read_lidar, read_obs, read_ozone, read_pcp, read_prepbufr, read_radar, ! read_superwinds, read_wrf_mass_files, read_wrf_mass_guess, ! read_wrf_nmm_files, read_wrf_nmm_guess, rfdpar, rsearch, satthin, ! setupdw, setupoz, setuppcp, setupps, setuppw, setupq, setuprad, -! setupref, setupbend, setuprhsall, setuprw, setupspd, setupsst, +! setupref, setupbend, setuplight, setuprhsall, setuprw, setupspd, setupsst, ! setupt, setupw, simpin1, simpin1_init, smooth121, smoothrf, ! smoothwwrf, smoothzrf, snwem_amsu, specmod, -! sst_retrieval, statsconv, statsoz, statspcp, statsrad, stop2, stpbend, -! stpcalc, stpcalc_qc, stpdw, stplimq, stpoz, stppcp, stpps, stppw, +! sst_retrieval, statsconv, statslight, statsoz, statspcp, statsrad, stop2, stpbend, +! stpcalc, stpcalc_qc, stpdw, stplight, stplimq, stpoz, stppcp, stpps, stppw, ! stpq, stprad, stpref, stprw, stpspd, stpsst, stpt, stpw, -! stvp2uv, stvp2uv_reg, sub2grid, tbalance, tintrp2a, tintrp3, +! stvp2uv, stvp2uv_reg, sub2grid, sumslightbias, tbalance, tintrp2a, tintrp3, ! tpause, tpause_t, transform, tstvp2uv, tstvp2uv_reg, unfill_mass_grid2, ! unfill_nmm_grid2, unhalf_nmm_grid2, update_ggrid, wrf_binary_interface, ! wrf_netcdf_interface, write_all, wrsfca, wrsiga, wrwrfmassa, wrwrfnmma, @@ -519,6 +527,9 @@ program gsi ! = 339 - error:more than one MLS data type not allowed ! = 340 - error reading aircraft temperature bias file ! = 341 - aircraft tail number exceeds maximum +! = 342 - setuplight: failure to allocate obsdiags +! = 343 - setuplight: failure to allocate obsdiags +! = 344 - setuplight: index error ! = 899 - foto no longer available ! ! @@ -569,6 +580,7 @@ program gsi ! new regional model added: ! ! nems_nmmb_regional = .true. input is from NEMS NMMB model +! fv3_regional = .true. input is from fv3 model ! cmaq_regional = .true. input is from CMAQ model ! ! For a regional run, several additional namelist parameters must be specified: @@ -605,6 +617,11 @@ program gsi call gsimain_initialize + call my_fixture_config() ! Choose configurable extensions for a + ! particular system fixture. Note a user + ! defined gsi_fixture implementation is uniquely + ! selected in CMakeLists.txt at build-time. + ! Initialize atmospheric AD and TL model trajectory ! if(l4dvar) then ! call gsi_4dcoupler_init_traj(idmodel,rc=ier) diff --git a/src/gsimod.F90 b/src/gsi/gsimod.F90 similarity index 84% rename from src/gsimod.F90 rename to src/gsi/gsimod.F90 index dd2a72702..cedc18f97 100644 --- a/src/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -18,27 +18,55 @@ module gsimod time_window,perturb_obs,perturb_fact,sfcmodel,destroy_obsmod_vars,dsis,& dtbduv_on,time_window_max,offtime_data,init_directories,oberror_tune,ext_sonde, & blacklst,init_obsmod_vars,lobsdiagsave,lobskeep,lobserver,hilbert_curve,& - lread_obs_save,lread_obs_skip + lread_obs_save,lread_obs_skip,time_window_rad + use gsi_dbzOper, only: diag_radardbz + + use obsmod, only: doradaroneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& + radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& + rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_vrobs_raw,& + minobrangedbz,maxobrangedbz,maxobrangevr,maxtiltvr,missing_to_nopcp,& + ntilt_radarfiles,whichradar,& + minobrangevr,maxtiltdbz,mintiltvr,mintiltdbz,l2rwthin,hurricane_radar !Xu + use obsmod, only: lwrite_predterms, & - lwrite_peakwt,use_limit,lrun_subdirs,l_foreaft_thin,& + lwrite_peakwt,use_limit,lrun_subdirs,l_foreaft_thin,lobsdiag_forenkf,& obsmod_init_instr_table,obsmod_final_instr_table use obsmod, only: luse_obsdiag + use obsmod, only: netcdf_diag, binary_diag + use obsmod, only: l_wcp_cwm + use obsmod, only: aircraft_recon, & + + ! The following variables are the coefficients that describe + ! the linear regression fits that are used to define the + ! dynamic observation error (DOE) specifications for all + ! reconnissance observations collected within + ! hurricanes/tropical cyclones; these apply only to the + ! regional forecast models (e.g., HWRF); Henry R. Winterbottom + ! (henry.winterbottom@noaa.gov). + + q_doe_a_136,q_doe_a_137,q_doe_b_136,q_doe_b_137, & + t_doe_a_136,t_doe_a_137,t_doe_b_136,t_doe_b_137, & + uv_doe_a_236,uv_doe_a_237,uv_doe_a_292,uv_doe_b_236,uv_doe_b_237,& + uv_doe_b_292 + use aircraftinfo, only: init_aircraft,hdist_aircraft,aircraft_t_bc_pof,aircraft_t_bc, & aircraft_t_bc_ext,biaspredt,upd_aircraft,cleanup_tail + use obs_sensitivity, only: lobsensfc,lobsensincr,lobsensjb,lsensrecompute, & lobsensadj,lobsensmin,iobsconv,llancdone,init_obsens use gsi_4dvar, only: setup_4dvar,init_4dvar,nhr_assimilation,min_offset, & l4dvar,nhr_obsbin,nhr_subwin,nwrvecs,iorthomax,& lbicg,lsqrtb,lcongrad,lbfgsmin,ltlint,ladtest,ladtest_obs, lgrtest,& idmodel,clean_4dvar,iwrtinc,lanczosave,jsiga,ltcost,liauon, & - l4densvar,ens_nstarthr,lnested_loops,lwrite4danl,thin4d + l4densvar,ens_nstarthr,lnested_loops,lwrite4danl,nhr_anal,thin4d,tau_fcst,efsoi_order use gsi_4dvar, only: mPEs_observer use m_obsdiags, only: alwaysLocal => obsdiags_alwaysLocal use obs_ferrscale, only: lferrscale use mpimod, only: npe,mpi_comm_world,ierror,mype use radinfo, only: retrieval,diag_rad,init_rad,init_rad_vars,adp_anglebc,angord,upd_pred,& biaspredvar,use_edges,passive_bc,newpc4pred,final_rad_vars,emiss_bc,& - ssmis_method,ssmis_precond,gmi_method,amsr2_method + ssmis_method,ssmis_precond,gmi_method,amsr2_method,bias_zero_start, & + reset_bad_radbc,cld_det_dec2bin,diag_version,lupdqc,lqcoef use radinfo, only: tzr_qc,tzr_bufrsave use radinfo, only: crtm_coeffs_path use ozinfo, only: diag_ozone,init_oz @@ -46,7 +74,9 @@ module gsimod use coinfo, only: diag_co,init_co use convinfo, only: init_convinfo, & diag_conv,& - use_prepb_satwnd,id_drifter + use_prepb_satwnd,id_drifter, ec_amv_qc,& + id_ship + use lightinfo, only: diag_light,init_light use oneobmod, only: oblon,oblat,obpres,obhourset,obdattim,oneob_type,& oneobtest,magoberr,maginnov,init_oneobmod,pctswitch,lsingleradob,obchan,& @@ -56,16 +86,19 @@ module gsimod use qcmod, only: dfact,dfact1,create_qcvars,destroy_qcvars,& erradar_inflate,tdrerr_inflate,use_poq7,qc_satwnds,& init_qcvars,vadfile,noiqc,c_varqc,qc_noirjaco3,qc_noirjaco3_pole,& - buddycheck_t,buddydiag_save,njqc,vqc,closest_obs,vadwnd_l2rw_qc + buddycheck_t,buddydiag_save,njqc,vqc,vadwnd_l2rw_qc, & + pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cao_check use pcpinfo, only: npredp,diag_pcp,dtphys,deltim,init_pcp use jfunc, only: iout_iter,iguess,miter,factqmin,factqmax, & + factql,factqi,factqr,factqs,factqg, & factv,factl,factp,factg,factw10m,facthowv,factcldch,niter,niter_no_qc,biascor,& init_jfunc,qoption,cwoption,switch_on_derivatives,tendsflag,jiterstart,jiterend,R_option,& bcoption,diurnalbc,print_diag_pcg,tsensible,lgschmidt,diag_precon,step_start,pseudo_q2,& clip_supersaturation use state_vectors, only: init_anasv,final_anasv use control_vectors, only: init_anacv,final_anacv,nrf,nvars,nrf_3d,cvars3d,cvars2d,& - nrf_var,imp_physics,lupp + nrf_var,lcalc_gfdl_cfrac + use derivsmod, only: init_anadv use berror, only: norh,ndeg,vs,bw,init_berror,hzscl,hswgt,pert_berr,pert_berr_fct,& bkgv_flowdep,bkgv_rewgtfct,bkgv_write,fpsproj,nhscrf,adjustozvar,fut2ps,cwcoveqqcov use anberror, only: anisotropic,ancovmdl,init_anberror,npass,ifilt_ord,triad4, & @@ -74,28 +107,29 @@ module gsimod rtma_subdomain_option,rtma_bkerr_sub2slab,nsmooth,nsmooth_shapiro,& pf2aP1,pf2aP2,pf2aP3,afact0,covmap,lreadnorm use compact_diffs, only: noq,init_compact_diffs - use jcmod, only: init_jcvars,ljcdfi,alphajc,ljcpdry,bamp_jcpdry,eps_eer,ljc4tlevs + use jcmod, only: init_jcvars,ljcdfi,alphajc,ljcpdry,bamp_jcpdry,eps_eer,ljc4tlevs,ljclimqc use tendsmod, only: ctph0,stph0,tlm0 use mod_vtrans, only: nvmodes_keep,init_vtrans use mod_strong, only: l_tlnmc,reg_tlnmc_type,nstrong,tlnmc_option,& period_max,period_width,init_strongvars,baldiag_full,baldiag_inc - use gridmod, only: nlat,nlon,nsig,wrf_nmm_regional,nems_nmmb_regional,cmaq_regional,& - nmmb_reference_grid,grid_ratio_nmmb,grid_ratio_wrfmass,& + use gridmod, only: nlat,nlon,nsig,wrf_nmm_regional,nems_nmmb_regional,fv3_regional,cmaq_regional,& + nmmb_reference_grid,grid_ratio_nmmb,grid_ratio_wrfmass,grid_ratio_fv3_regional,& filled_grid,half_grid,wrf_mass_regional,nsig1o,nnnn1o,update_regsfc,& diagnostic_reg,gencode,nlon_regional,nlat_regional,nvege_type,& twodvar_regional,regional,init_grid,init_reg_glob_ll,init_grid_vars,netcdf,& nlayers,use_gfs_ozone,check_gfs_ozone_date,regional_ozone,jcap,jcap_b,vlevs,& use_gfs_nemsio,sfcnst_comb,use_readin_anl_sfcmask,use_sp_eqspace,final_grid_vars,& - jcap_gfs,nlat_gfs,nlon_gfs,jcap_cut,wrf_mass_hybridcord + jcap_gfs,nlat_gfs,nlon_gfs,jcap_cut,wrf_mass_hybridcord,& + use_fv3_aero use guess_grids, only: ifact10,sfcmod_gfs,sfcmod_mm5,use_compress,nsig_ext,gpstop - use gsi_io, only: init_io,lendian_in,verbose + use gsi_io, only: init_io,lendian_in,verbose,print_obs_para use regional_io_mod, only: regional_io_class use wrf_params_mod, only: update_pint, preserve_restart_date use constants, only: zero,one,init_constants,gps_constants,init_constants_derived,three use fgrid2agrid_mod, only: nord_f2a,init_fgrid2agrid,final_fgrid2agrid,set_fgrid2agrid use smooth_polcarf, only: norsp,init_smooth_polcas use read_l2bufr_mod, only: minnum,del_azimuth,del_elev,del_range,del_time,& - range_max,elev_angle_max,initialize_superob_radar,l2superob_only + range_max,elev_angle_max,initialize_superob_radar,l2superob_only,radar_sites,radar_box,radar_rmesh,radar_zmesh!Xu use m_berror_stats,only : berror_stats ! filename if other than "berror_stats" use lag_fields,only : infile_lag,lag_nmax_bal,& &lag_vorcore_stderr_a,lag_vorcore_stderr_b,lag_modini @@ -103,12 +137,12 @@ module gsimod use lag_traj,only : lag_stepduration use hybrid_ensemble_parameters,only : l_hyb_ens,uv_hyb_ens,aniso_a_en,generate_ens,& n_ens,nlon_ens,nlat_ens,jcap_ens,jcap_ens_test,oz_univ_static,& - regional_ensemble_option,merge_two_grid_ensperts, & + regional_ensemble_option,fv3sar_ensemble_opt,merge_two_grid_ensperts, & full_ensemble,pseudo_hybens,pwgtflg,& beta_s0,s_ens_h,s_ens_v,init_hybrid_ensemble_parameters,& readin_localization,write_ens_sprd,eqspace_ensgrid,grid_ratio_ens,& readin_beta,use_localization_grid,use_gfs_ens,q_hyb_ens,i_en_perts_io, & - l_ens_in_diff_time,ensemble_path,ens_fast_read + l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB use rapidrefresh_cldsurf_mod, only: init_rapidrefresh_cldsurf, & dfi_radar_latent_heat_time_period,metar_impact_radius,& metar_impact_radius_lowcloud,l_gsd_terrain_match_surftobs, & @@ -119,11 +153,13 @@ module gsimod l_cleansnow_warmts,l_conserve_thetaV,r_cleansnow_warmts_threshold, & i_conserve_thetav_iternum,l_gsd_soiltq_nudge,l_cld_bld, cld_bld_hgt, & build_cloud_frac_p, clear_cloud_frac_p, & - l_cloud_analysis,nesdis_npts_rad, & + l_hydrometeor_bkio,nesdis_npts_rad, & iclean_hydro_withRef,iclean_hydro_withRef_allcol, & i_use_2mq4b,i_use_2mt4b,i_gsdcldanal_type,i_gsdsfc_uselist, & i_lightpcp,i_sfct_gross,l_use_hydroretrieval_all,l_numconc,l_closeobs,& - i_coastline,i_gsdqc + i_coastline,i_gsdqc,qv_max_inc,ioption,l_precip_clear_only,l_fog_off,& + cld_bld_coverage,cld_clr_coverage,& + i_cloud_q_innovation,i_ens_mean,DTsTmax use gsi_metguess_mod, only: gsi_metguess_init,gsi_metguess_final use gsi_chemguess_mod, only: gsi_chemguess_init,gsi_chemguess_final use tcv_mod, only: init_tcps_errvals,tcp_refps,tcp_width,tcp_ermin,tcp_ermax @@ -132,15 +168,18 @@ module gsimod oneob_type_chem,oblat_chem,& oblon_chem,obpres_chem,diag_incr,elev_tolerance,tunable_error,& in_fname,out_fname,incr_fname, & - laeroana_gocart, l_aoderr_table, aod_qa_limit, luse_deepblue + laeroana_gocart, l_aoderr_table, aod_qa_limit, luse_deepblue, lread_ext_aerosol use chemmod, only : wrf_pm2_5,aero_ratios use gfs_stratosphere, only: init_gfs_stratosphere,use_gfs_stratosphere,pblend0,pblend1 use gfs_stratosphere, only: broadcast_gfs_stratosphere_vars use general_commvars_mod, only: init_general_commvars,destroy_general_commvars use radiance_mod, only: radiance_mode_init,radiance_mode_destroy, & - radiance_obstype_destroy,radiance_parameter_cloudy_destroy + radiance_obstype_destroy use gsi_nstcouplermod, only: gsi_nstcoupler_init_nml use gsi_nstcouplermod, only: nst_gsi,nstinfo,zsea1,zsea2,fac_dtl,fac_tsl + use ncepnems_io, only: init_nems,imp_physics,lupp + use wrf_vars_mod, only: init_wrf_vars + use gsi_rfv3io_mod,only : fv3sar_bg_opt implicit none @@ -324,6 +363,7 @@ module gsimod ! 10-01-2015 guo option to redistribute observations in 4d observer mode ! 07-20-2015 zhu re-structure codes for enabling all-sky/aerosol radiance assimilation, ! add radiance_mode_init, radiance_mode_destroy & radiance_obstype_destroy +! 01-28-2016 mccarty add netcdf_diag capability ! 03-02-2016 s.liu/carley - remove use_reflectivity and use i_gsdcldanal_type ! 03-10-2016 ejones add control for gmi noise reduction ! 03-25-2016 ejones add control for amsr2 noise reduction @@ -340,6 +380,8 @@ module gsimod ! matricies for univariate analysis. ! 08-28-2016 li - tic591: add use_readin_anl_sfcmask for consistent sfcmask ! between analysis grids and others +! 11-29-2016 shlyaeva add lobsdiag_forenkf option for writing out linearized +! H(x) for EnKF ! 12-14-2016 lippi added nml variable learthrel_rw for single radial ! wind observation test, and nml option for VAD QC ! vadwnd_l2rw_qc of level 2 winds. @@ -347,7 +389,42 @@ module gsimod ! operator for surface observations along the coastline area ! 04-01-2017 Hu added option i_gsdqc to turn on special observation qc ! from GSD (for RAP/HRRR application) +! 02-15-2016 Y. Wang, Johnson, X. Wang - added additional options if_vterminal, if_model_dbz, +! for radar DA, POC: xuguang.wang@ou.edu ! 08-31-2017 Li add sfcnst_comb for option to read sfc & nst combined file +! 10-10-2017 Wu,W added option fv3_regional and rid_ratio_fv3_regional, setup FV3, earthuv +! 01-11-2018 Yang add namelist variables required by the nonlinear transform to vis and cldch +! (Jim Purser 2018). Add estvisoe and estcldchoe to replace the hardwired +! prescribed vis/cldch obs. errort in read_prepbufr. (tentatively?) +! 03-22-2018 Yang remove "logical closest_obs", previously applied to the analysis of vis and cldch. +! The option to use only the closest ob to the analysis time is now handled +! by Ming Hu's "logical l_closeobs" for all variables. +! 01-04-2018 Apodaca add diag_light and lightinfo for GOES/GLM lightning +! data assimilation +! 08-16-2018 akella id_ship flag - modify KX values for ships if set +! 08-25-2018 Collard Introduce bias_zero_start +! 03-29-2019 lei add integer parameter fv3sar_ensemble_opt to select the format of the FV3SAR ensembles +! =0; restart files +! =1; cold start IC files from CHGRES +! 09-12-2018 Ladwig added option l_precip_clear_only +! 03-28-2019 Ladwig merging additional options for cloud product assimilation +! 03-11-2019 Collard Introduce ec_amv_qc as temporary control of GOES-16/17 AMVS +! 03-14-2019 eliu add logic to turn on using full set of hydrometeors in +! obs operator and analysis +! 03-14-2019 eliu add precipitation component +! 05-09-2019 mtong move initializing derivative vector here +! 06-19-2019 Hu Add option reset_bad_radbc for reseting radiance bias correction when it is bad +! 06-25-2019 Hu Add option print_obs_para to turn on OBS_PARA list +! 07-09-2019 Todling Introduce cld_det_dec2bin and diag_version +! 07-11-2019 Todling move vars imp_physics,lupp from CV to init_nems +! 08-14-2019 W. Gu add lupdqc to replace the obs errors from satinfo with diag of est(R) +! 08-14-2019 W. Gu add lqcoef to combine the inflation coefficients generated by qc with est(R) +! 10-15-2019 Wei/Martin added option lread_ext_aerosol to read in aerfXX file for NEMS aerosols; +! added option use_fv3_aero to choose between NGAC and FV3GFS-GSDChem +! 01-27-2020 Winterbottom Moved regression coeffcients for regional +! model (e.g., HWRF) aircraft recon dynamic +! observation error (DOE) specification to +! GSI namelist level (beneath obsmod.F90). ! !EOP !------------------------------------------------------------------------- @@ -400,6 +477,8 @@ module gsimod ! diag_ozone - logical to turn off or on the diagnostic ozone file (true=on) ! diag_aero - logical to turn off or on the diagnostic aerosol file (true=on) ! diag_co - logical to turn off or on the diagnostic carbon monoxide file (true=on) +! diag_light - logical to turn off or on the diagnostic lightning file (true=on) +! diag_radardbz - logical to turn off or on the diagnostic radar reflectivity file (true=on) ! write_diag - logical to write out diagnostic files on outer iteration ! lobsdiagsave - write out additional observation diagnostics ! ltlint - linearize inner loop @@ -463,6 +542,7 @@ module gsimod ! angord - order of polynomial for variational angle bias correction ! newpc4pred - option for additional preconditioning for pred coeff. ! passive_bc - option to turn on bias correction for passive (monitored) channels +! reset_bad_radbc - option to turn on reseting bias correction coefficient when it is bad ! use_edges - option to exclude radiance data on scan edges ! biaspredvar - set background error variance for radiance bias coeffs ! (default 0.1K) @@ -470,10 +550,12 @@ module gsimod ! nsig_ext - number of layers above the model top which are necessary to compute the bending angle for gpsro ! gpstop - maximum height for gpsro data assimilation. Reject anything above this height. ! use_gfs_nemsio - option to use nemsio to read global model NEMS/GFS first guess +! use_fv3_aero - option to use FV3-Chem vs NGAC for global aerosol analysis ! sfcnst_comb - option to use nemsio sfc history file by regriding FV3 grid ! use_readin_anl_sfcmask - option to use readin surface mask ! use_prepb_satwnd - allow using satwnd''s from prepbufr (historical) file ! id_drifter - option to identify drifting buoy observations (modify KX from 180/280) +! id_ship - option to identify ship observations (modify KX from 180) ! use_gfs_stratosphere - for now, can only be set to true if nems_nmmb_regional=true. Later extend ! to other regional models. When true, a guess gfs valid at the same time ! as the nems-nmmb guess is used to replace the upper levels with gfs values. @@ -491,6 +573,7 @@ module gsimod ! l4densvar - logical to turn on ensemble 4dvar ! ens_nstarthr - start hour for ensemble perturbations (generally should match min_offset) ! lwrite4danl - logical to write out 4d analysis states if 4dvar or 4denvar mode +! nhr_anal - forecast hours to write out if lwrite4danal=T ! ladtest - if true, doing the adjoint test for the operator that maps ! control_vector to the model state_vector ! ladtest_obs - if true, doing the adjoint adjoint check for the @@ -507,46 +590,73 @@ module gsimod ! ssmis_precond - weighting factor for SSMIS preconditioning (if not using newpc4pred) ! gmi_method - choose method for GMI noise reduction. 0=no smoothing, 4=default ! amsr2_method - choose method for AMSR2 noise reduction. 0=no smoothing, 5=default +! bias_zero_start - Initialise bias correction from zero (default=true, +! false=mode start method) +! ec_amv_qc - If true use additional QC from ECMWF addressing issues with +! upper level GOES-16/17 winds (default = true) ! R_option - Option to use variable correlation length for lcbas based on data ! density - follows Hayden and Purser (1995) (twodvar_regional only) ! thin4d - if true, removes thinning of observations due to the location in ! the time window +! lobsdiag_forenkf - if true, save linearized H operator (jacobian) in +! diagnostic file on 1st outer iteration. The Jacobian can then be used by +! the EnKF to compute ensemble perturbations in observation space. ! luse_obsdiag - use obsdiags (useful when running EnKF observers; e.g., echo Jo table) ! imp_physics - type of GFS microphysics ! lupp - if T, UPP is used and extra variables are output +! lcalc_gfdl_cfrac - if T, calculate and use GFDL cloud fraction in observation operator +! cao_check - if T, turn on cold-air-outbreak screening for quality control +! binary_diag - trigger binary diag-file output (being phased out) +! netcdf_diag - trigger netcdf diag-file output +! diag_version - specifies desired version of diag files +! l_wcp_cwm - namelist logical whether to use swcp/lwcp operator that includes cwm +! aircraft_recon - namelist logical whether to apply DOE to aircraft data +! tau_fcst - controls EFSOI-like calculation +! efsoi_order - sets order of EFSOI-like calculation +! lupdqc - logical to replace the obs errors from satinfo with diag of est(R) in the case of correlated obs +! lqcoef - logical to combine the inflation coefficients generated by qc with est(R) ! ! NOTE: for now, if in regional mode, then iguess=-1 is forced internally. ! add use of guess file later for regional mode. namelist/setup/gencode,factqmin,factqmax,clip_supersaturation, & + factql,factqi,factqr,factqs,factqg, & factv,factl,factp,factg,factw10m,facthowv,factcldch,R_option,deltim,dtphys,& biascor,bcoption,diurnalbc,& niter,niter_no_qc,miter,qoption,cwoption,nhr_assimilation,& min_offset,pseudo_q2,& iout_iter,npredp,retrieval,& tzr_qc,tzr_bufrsave,& - diag_rad,diag_pcp,diag_conv,diag_ozone,diag_aero,diag_co,iguess, & + diag_rad,diag_pcp,diag_conv,diag_ozone,diag_aero,diag_co,diag_light,diag_radardbz,iguess, & write_diag,reduce_diag, & oneobtest,sfcmodel,dtbduv_on,ifact10,l_foto,offtime_data,& use_pbl,use_compress,nsig_ext,gpstop,& perturb_obs,perturb_fact,oberror_tune,preserve_restart_date, & crtm_coeffs_path,berror_stats, & - newpc4pred,adp_anglebc,angord,passive_bc,use_edges,emiss_bc,upd_pred, & - ssmis_method, ssmis_precond, gmi_method, amsr2_method, & - lobsdiagsave, & + newpc4pred,adp_anglebc,angord,passive_bc,use_edges,emiss_bc,upd_pred,reset_bad_radbc,& + ssmis_method, ssmis_precond, gmi_method, amsr2_method, bias_zero_start, & + ec_amv_qc, lobsdiagsave, lobsdiag_forenkf, & l4dvar,lbicg,lsqrtb,lcongrad,lbfgsmin,ltlint,nhr_obsbin,nhr_subwin,& mPES_observer,& alwaysLocal,& + use_fv3_aero,& nwrvecs,iorthomax,ladtest,ladtest_obs, lgrtest,lobskeep,lsensrecompute,jsiga,ltcost, & lobsensfc,lobsensjb,lobsensincr,lobsensadj,lobsensmin,iobsconv, & - idmodel,iwrtinc,lwrite4danl,jiterstart,jiterend,lobserver,lanczosave,llancdone, & + idmodel,iwrtinc,lwrite4danl,nhr_anal,jiterstart,jiterend,lobserver,lanczosave,llancdone, & lferrscale,print_diag_pcg,tsensible,lgschmidt,lread_obs_save,lread_obs_skip, & use_gfs_ozone,check_gfs_ozone_date,regional_ozone,lwrite_predterms,& lwrite_peakwt,use_gfs_nemsio,sfcnst_comb,liauon,use_prepb_satwnd,l4densvar,ens_nstarthr,& use_gfs_stratosphere,pblend0,pblend1,step_start,diag_precon,lrun_subdirs,& use_sp_eqspace,lnested_loops,lsingleradob,thin4d,use_readin_anl_sfcmask,& - luse_obsdiag,id_drifter,verbose,lsingleradar,singleradar,lnobalance,imp_physics,& - lupp + luse_obsdiag,id_drifter,id_ship,verbose,print_obs_para,lsingleradar,singleradar,lnobalance, & + missing_to_nopcp,minobrangedbz,minobrangedbz,maxobrangedbz,& + maxobrangevr,maxtiltvr,whichradar,doradaroneob,oneoblat,& + oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& + rmesh_vr,zmesh_dbz,zmesh_vr, ntilt_radarfiles, whichradar,& + radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& + minobrangevr, maxtiltdbz, mintiltvr,mintiltdbz,if_vterminal,if_vrobs_raw,& + if_model_dbz,imp_physics,lupp,netcdf_diag,binary_diag,l_wcp_cwm,aircraft_recon,hurricane_radar,diag_version,& + cao_check,lcalc_gfdl_cfrac,tau_fcst,efsoi_order,lupdqc,lqcoef,l2rwthin !Xu ! GRIDOPTS (grid setup variables,including regional specific variables): ! jcap - spectral resolution @@ -563,12 +673,14 @@ module gsimod ! - otherwise wrf files are in binary format. ! regional - logical for regional GSI run ! wrf_nmm_regional - logical for input from WRF NMM +! fv3_regional - logical for input from FV3 regional ! wrf_mass_regional - logical for input from WRF MASS-CORE ! cmaq_regional - logical for input from CMAQ ! nems_nmmb_regional- logical for input from NEMS NMMB ! nmmb_reference_grid= 'H', then analysis grid covers H grid domain ! = 'V', then analysis grid covers V grid domain ! grid_ratio_nmmb - ratio of analysis grid to nmmb model grid in nmmb model grid units. +! grid_ratio_fv3_regional - ratio of analysis grid to fv3 grid in fv3 grid units. ! grid_ratio_wrfmass - ratio of analysis grid to wrf mass grid in wrf grid units. ! twodvar_regional - logical for regional 2d-var analysis ! filled_grid - logical to fill in puts on WRF-NMM E-grid @@ -585,9 +697,10 @@ module gsimod namelist/gridopts/jcap,jcap_b,nsig,nlat,nlon,nlat_regional,nlon_regional,& - diagnostic_reg,update_regsfc,netcdf,regional,wrf_nmm_regional,nems_nmmb_regional,& + diagnostic_reg,update_regsfc,netcdf,regional,wrf_nmm_regional,nems_nmmb_regional,fv3_regional,& wrf_mass_regional,twodvar_regional,filled_grid,half_grid,nvege_type,nlayers,cmaq_regional,& - nmmb_reference_grid,grid_ratio_nmmb,grid_ratio_wrfmass,jcap_gfs,jcap_cut,wrf_mass_hybridcord + nmmb_reference_grid,grid_ratio_nmmb,grid_ratio_fv3_regional,grid_ratio_wrfmass,jcap_gfs,jcap_cut,& + wrf_mass_hybridcord ! BKGERR (background error related variables): ! vs - scale factor for vertical correlation lengths for background error @@ -676,7 +789,7 @@ module gsimod ! namelist/jcopts/ljcdfi,alphajc,switch_on_derivatives,tendsflag,ljcpdry,bamp_jcpdry,eps_eer,& - ljc4tlevs + ljc4tlevs,ljclimqc ! STRONGOPTS (strong dynamic constraint) ! reg_tlnmc_type - =1 for 1st version of regional strong constraint @@ -738,23 +851,79 @@ module gsimod ! obs run through the buddy check ! njqc - When true, use Purser''s non linear QC ! vqc - when true, use ECMWF's non linear QC -! closest_obs- when true, choose the timely closest surface observation from ! multiple observations at a station. Currently only applied to Ceiling ! height and visibility. - - namelist/obsqc/ dfact,dfact1,erradar_inflate,tdrerr_inflate,oberrflg,& +! pvis - power parameter in nonlinear transformation for vis +! pcldch - power parameter in nonlinear transformation for cldch +! scale_cv - scaling constant in meter +! estvisoe - estimate of vis observation error +! estcldchoe - estimate of cldch observation error +! vis_thres - threshold value for both vis observation and input first guess +! cldch_thres - threshold value for both cldch observation and input first guess +! cld_det_dec2bin - re-interprets cld_det in satinfo as binary entries + +! The following variables are the coefficients that describe the +! linear regression fits that are used to define the dynamic +! observation error (DOE) specifications for all reconnissance +! observations collected within hurricanes/tropical cyclones; these +! apply only to the regional forecast models (e.g., HWRF); Henry +! R. Winterbottom (henry.winterbottom@noaa.gov). + +! Observation types: + +! 1/236: HDOB (e.g., flight-level) observations. + +! 1/237: Dropsonde observations. + +! 292: SFMR observations. + +! The following correspond to the specific humidity (q) observations: + +! q_doe_a_136, q_doe_a_137 - specific humidity linear regression +! derived 'a' coefficients for specific +! humidity observations. + +! q_doe_b_136, q_doe_b_137 - specific humidity linear regression +! derived 'b' coefficients for specific +! humidity observations. + +! t_doe_a_136, t_doe_a_137 - temperature linear regression derived +! 'a' coefficients for temperature +! observations. + +! t_doe_b_136, t_doe_b_137 - temperature linear regression derived +! 'b' coefficients for temperature +! observations. + +! uv_doe_a_236, uv_doe_a_237, uv_doe_a_292 - wind linear +! regression derived +! 'a' coefficients for +! wind observations. + +! uv_doe_b_236, uv_doe_b_237, uv_doe_b_292 - wind linear +! regression derived +! 'b' coefficients for +! wind observations. + + + namelist/obsqc/dfact,dfact1,erradar_inflate,tdrerr_inflate,oberrflg,& vadfile,noiqc,c_varqc,blacklst,use_poq7,hilbert_curve,tcp_refps,tcp_width,& tcp_ermin,tcp_ermax,qc_noirjaco3,qc_noirjaco3_pole,qc_satwnds,njqc,vqc,& aircraft_t_bc_pof,aircraft_t_bc,aircraft_t_bc_ext,biaspredt,upd_aircraft,cleanup_tail,& - hdist_aircraft,buddycheck_t,buddydiag_save,closest_obs,vadwnd_l2rw_qc + hdist_aircraft,buddycheck_t,buddydiag_save,vadwnd_l2rw_qc, & + pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cld_det_dec2bin, & + q_doe_a_136,q_doe_a_137,q_doe_b_136,q_doe_b_137, & + t_doe_a_136,t_doe_a_137,t_doe_b_136,t_doe_b_137, & + uv_doe_a_236,uv_doe_a_237,uv_doe_a_292,uv_doe_b_236,uv_doe_b_237,uv_doe_b_292 ! OBS_INPUT (controls input data): ! dmesh(max(dthin))- thinning mesh for each group ! time_window_max - upper limit on time window for all input data +! time_window_rad - upper limit on time window for certain radiance input data ! ext_sonde - logical for extended forward model on sonde data ! l_foreaft_thin - separate TDR fore/aft scan for thinning - namelist/obs_input/dmesh,time_window_max, & + namelist/obs_input/dmesh,time_window_max,time_window_rad, & ext_sonde,l_foreaft_thin ! SINGLEOB_TEST (one observation test case setup): @@ -788,7 +957,7 @@ module gsimod ! files are very large and hard to work with) namelist/superob_radar/del_azimuth,del_elev,del_range,del_time,& - elev_angle_max,minnum,range_max,l2superob_only + elev_angle_max,minnum,range_max,l2superob_only,radar_sites,radar_box,radar_rmesh,radar_zmesh!Xu ! LAG_DATA (lagrangian data assimilation related variables): ! lag_accur - Accuracy used to decide whether or not a balloon is on the grid @@ -861,14 +1030,15 @@ module gsimod ! from analysis time in hybrid analysis ! ensemble_path - path to ensemble members; default './' ! ens_fast_read - read ensemble in parallel; default '.false.' +! sst_staticB - use only static background error covariance for SST statistic ! ! namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,nlon_ens,nlat_ens,jcap_ens,& - pseudo_hybens,merge_two_grid_ensperts,regional_ensemble_option,full_ensemble,pwgtflg,& + pseudo_hybens,merge_two_grid_ensperts,regional_ensemble_option,fv3sar_bg_opt,fv3sar_ensemble_opt,full_ensemble,pwgtflg,& jcap_ens_test,beta_s0,s_ens_h,s_ens_v,readin_localization,eqspace_ensgrid,readin_beta,& grid_ratio_ens, & oz_univ_static,write_ens_sprd,use_localization_grid,use_gfs_ens, & - i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read + i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB ! rapidrefresh_cldsurf (options for cloud analysis and surface ! enhancement for RR appilcation ): @@ -915,7 +1085,14 @@ module gsimod ! =0. no cloud analysis (default) ! =1. cloud analysis after var analysis for WRF_ARW ! =2. cloud analysis after var analysis for NMMB -! =5. skip cloud analysis and NETCDF file update +! =3. cloud analysis only; var is skipped +! =5. skip cloud analysis and updating NETCDF result file at +! the end of the analysis +! =6. skip NETCDF background read step and do cloud analysis only +! =7 cloud analysis in observer with I/O +! =30 cloud analysis for GFS +! =99 only read hydrometer fields but no cloud analysis + ! i_gsdsfc_uselist - options for how to use surface observation use or ! rejection list ! =0 . EMC method (default) @@ -948,6 +1125,26 @@ module gsimod ! from GSD (for RAP/HRRR application) ! =0 turn off ! =2 turn on +! qv_max_inc - threshold to limit the maximum water vapor increment +! ioption - interpolation option for satellite mapping +! =1 if selection is nearest neighbor +! =2 if selection is median of samples +! l_precip_clear_only - the precipitation analysis only clears; it does not +! make any updates for positive precipitating hydrometeors +! l_fog_off - turn off using fog observations +! cld_bld_coverage - cloud coverage required for qc/qi building +! cld_clr_coverage - cloud coverage required for qc/qi clearing +! i_cloud_q_innovation - integer to choose if and how cloud obs are used +! 0= no innovations +! 1= cloud total innovations +! 2= water vapor innovations +! 3= cloud total & water vapor innovations +! i_ens_mean - integer for setupcldtot behavior +! 0=single model run +! 1=ensemble mean +! 2=ensemble members +! DTsTmax - maximum allowed difference between Tskin and the first +! level T. This is to safety guard soil T adjustment. ! namelist/rapidrefresh_cldsurf/dfi_radar_latent_heat_time_period, & metar_impact_radius,metar_impact_radius_lowcloud, & @@ -963,7 +1160,9 @@ module gsimod iclean_hydro_withRef,iclean_hydro_withRef_allcol,& i_use_2mq4b,i_use_2mt4b,i_gsdcldanal_type,i_gsdsfc_uselist, & i_lightpcp,i_sfct_gross,l_use_hydroretrieval_all,l_numconc,l_closeobs,& - i_coastline,i_gsdqc + i_coastline,i_gsdqc,qv_max_inc,ioption,l_precip_clear_only,l_fog_off,& + cld_bld_coverage,cld_clr_coverage,& + i_cloud_q_innovation,i_ens_mean,DTsTmax ! chem(options for gsi chem analysis) : ! berror_chem - .true. when background for chemical species that require @@ -982,20 +1181,21 @@ module gsimod ! in_fname - CMAQ input filename ! out_fname - CMAQ output filename ! incr_fname - CMAQ increment filename -! laeroana_gocart - when true, do chem analysis with wrfchem and modis +! laeroana_gocart - when true, do chem analysis with wrfchem (or NGAC) ! l_aoderr_table - whethee to use aod error table or default error ! aod_qa_limit - minimum acceptable value of error flag for total column AOD ! luse_deepblue - whether to use MODIS AOD from the deepblue algorithm +! lread_ext_aerosol - if true, reads aerfNN file for aerosol arrays rather than sigfNN (NGAC NEMS IO) namelist/chem/berror_chem,oneobtest_chem,maginnov_chem,magoberr_chem,& oneob_type_chem,oblat_chem,oblon_chem,obpres_chem,& diag_incr,elev_tolerance,tunable_error,& in_fname,out_fname,incr_fname,& laeroana_gocart, l_aoderr_table, aod_qa_limit, luse_deepblue,& - aero_ratios,wrf_pm2_5 + aero_ratios,wrf_pm2_5, lread_ext_aerosol ! NST (NSST control namelist) : -! nst_gsi - indicator to control the Tr Analysis mode: 0 = no nst info ingsi at all; +! nst_gsi - indicator to control the Tr Analysis mode: 0 = no nst info in gsi at all; ! 1 = input nst info, but used for monitoring only ! 2 = input nst info, and used in CRTM simulation, but no Tr analysis ! 3 = input nst info, and used in CRTM simulation and Tr analysis is on @@ -1048,12 +1248,14 @@ subroutine gsimain_initialize ! Initialize defaults of vars in modules call init_4dvar call regional_io%init_regional_io + call init_nems ! Read in user specification of state and control variables call gsi_metguess_init call gsi_chemguess_init call init_anasv call init_anacv + call init_wrf_vars call radiance_mode_init call init_constants_derived @@ -1061,6 +1263,7 @@ subroutine gsimain_initialize call init_qcvars call init_obsmod_dflts call init_pcp + call init_light call init_rad call init_oz call init_aero @@ -1143,6 +1346,7 @@ subroutine gsimain_initialize if(ios/=0) call die(myname_,'read(strongopts)',ios) read(11,obsqc,iostat=ios) + if(ios/=0) call die(myname_,'read(obsqc)',ios) read(11,obs_input,iostat=ios) @@ -1168,7 +1372,6 @@ subroutine gsimain_initialize close(11) #endif - if(jcap > jcap_cut)then jcap_cut = jcap+1 if(mype == 0)then @@ -1240,6 +1443,7 @@ subroutine gsimain_initialize ! Set regional parameters if(filled_grid.and.half_grid) filled_grid=.false. regional=wrf_nmm_regional.or.wrf_mass_regional.or.twodvar_regional.or.nems_nmmb_regional .or. cmaq_regional + regional=regional.or.fv3_regional ! Currently only able to have use_gfs_stratosphere=.true. for nems_nmmb_regional=.true. use_gfs_stratosphere=use_gfs_stratosphere.and.(nems_nmmb_regional.or.wrf_nmm_regional) @@ -1319,6 +1523,8 @@ subroutine gsimain_initialize diag_aero=.false. diag_co=.false. diag_pcp=.false. + diag_light=.false. + diag_radardbz=.false. use_limit = 0 end if if(reduce_diag) use_limit = 0 @@ -1331,8 +1537,14 @@ subroutine gsimain_initialize ! Force turn off cloud analysis and hydrometeor IO if (i_gsdcldanal_type==0) then - l_cloud_analysis = .false. - if (mype==0) write(6,*)'GSIMOD: ***WARNING*** set l_cloud_analysis=false' + l_hydrometeor_bkio = .false. + if (mype==0) write(6,*)'GSIMOD: ***WARNING*** set l_hydrometeor_bkio=false' + else if(i_gsdcldanal_type==1 .or. i_gsdcldanal_type==2 .or. & + i_gsdcldanal_type==3 .or. i_gsdcldanal_type==5 .or. & + i_gsdcldanal_type==6 .or. i_gsdcldanal_type==7 .or. & + i_gsdcldanal_type==99 ) then + l_hydrometeor_bkio = .true. + if (mype==0) write(6,*)'GSIMOD: set l_hydrometeor_bkio=true:',i_gsdcldanal_type endif if((i_coastline == 1 .or. i_coastline == 3) .and. i_use_2mt4b==0) then i_coastline=0 @@ -1374,6 +1586,16 @@ subroutine gsimain_initialize baldiag_inc =.false. end if +! If reflectivity is intended to be assimilated, beta_s0 should be zero. + if ( beta_s0 > 0.0_r_kind )then + do i=1,ndat + if ( index(dtype(i), 'dbz') /= 0 )then + write(6,*)'beta_s0 needs to be set to zero in this GSI version, when reflectivity is directly assimilated. Static B extended for radar reflectivity assimilation will be included in future version.' + call stop2(8888) + end if + end do + end if + ! Turn off uv option if hybrid/ensemble options is false for purposes ! of TLNMC if (.not.l_hyb_ens) uv_hyb_ens=.false. @@ -1392,7 +1614,6 @@ subroutine gsimain_initialize ! Turn off Jc-pdry weak constraint if regional application if (regional) ljcpdry=.false. - ! Initialize lagrangian data assimilation - must be called after gsi_4dvar call lag_modini() @@ -1521,13 +1742,21 @@ subroutine gsimain_initialize ! If this is a wrf regional run, then run interface with wrf update_pint=.false. - if (regional) call regional_io%convert_regional_guess(mype,ctph0,stph0,tlm0) + if (regional) then + if (fv3_regional) then + call convert_fv3_regional + else + if(i_gsdcldanal_type.ne.6) call regional_io%convert_regional_guess(mype,ctph0,stph0,tlm0) + endif + endif + if (regional.and.use_gfs_stratosphere) call broadcast_gfs_stratosphere_vars ! Initialize variables, create/initialize arrays call init_reg_glob_ll(mype,lendian_in) call init_grid_vars(jcap,npe,cvars3d,cvars2d,nrf_var,mype) + if (switch_on_derivatives) call init_anadv ! moved from derivsmod call init_general_commvars call create_obsmod_vars call gpsStats_create() ! extracted from obsmod::create_obsmod_vars() @@ -1541,6 +1770,7 @@ subroutine gsimain_initialize ! Initialize values in aeroinfo call init_aero_vars + end subroutine gsimain_initialize !------------------------------------------------------------------------- @@ -1605,7 +1835,6 @@ subroutine gsimain_finalize call final_fgrid2agrid(pf2aP1) endif call radiance_obstype_destroy - call radiance_parameter_cloudy_destroy call final_aero_vars call final_rad_vars if(passive_bc) call prad_destroy() ! replacing -- call destroyobs_passive @@ -1631,4 +1860,3 @@ subroutine gsimain_finalize end subroutine gsimain_finalize end module gsimod - diff --git a/src/gsisub.F90 b/src/gsi/gsisub.F90 similarity index 91% rename from src/gsisub.F90 rename to src/gsi/gsisub.F90 index e3706945a..afc9e8a96 100644 --- a/src/gsisub.F90 +++ b/src/gsi/gsisub.F90 @@ -61,6 +61,9 @@ subroutine gsisub(init_pass,last_pass) ! 2015-07-20 zhu - centralize radiance info for the usages of clouds & aerosols ! - add radiance_obstype_init,radiance_parameter_cloudy_init,radiance_parameter_aerosol_init ! 2016-07-28 lippi - add oneobmakerwsupob if 'rw' single ob test and skips radar_bufr_read_all. +! 2018-02-15 wu - add code for fv3_regional option +! 2018-01-04 Apodaca - add lightinfo_read call for GOES/GLM lightning observations +! 2018-07-24 W. Gu - move routine corr_ob_initialize/finalize from radinfo ! ! input argument list: ! @@ -72,18 +75,20 @@ subroutine gsisub(init_pass,last_pass) ! !$$$ use kinds, only: i_kind - use obsmod, only: iadate,lobserver + use obsmod, only: iadate,lobserver,l2rwthin !Xu use observermod, only: observer_init,observer_run,observer_finalize - use gridmod, only: twodvar_regional,create_grid_vars,destroy_grid_vars + use gridmod, only: twodvar_regional,create_grid_vars,destroy_grid_vars,fv3_regional use gridmod, only: wrf_mass_regional,wrf_nmm_regional,nems_nmmb_regional,cmaq_regional use mpimod, only: mype,npe,mpi_comm_world,ierror use radinfo, only: radinfo_read + use correlated_obsmod, only: corr_ob_initialize,corr_ob_finalize use pcpinfo, only: pcpinfo_read,create_pcp_random,& destroy_pcp_random use aeroinfo, only: aeroinfo_read use convinfo, only: convinfo_read use ozinfo, only: ozinfo_read use coinfo, only: coinfo_read + use lightinfo, only: lightinfo_read use read_l2bufr_mod, only: radar_bufr_read_all use oneobmod, only: oneobtest,oneobmakebufr,oneobmakerwsupob,oneob_type use aircraftinfo, only: aircraftinfo_read,aircraft_t_bc_pof,aircraft_t_bc,& @@ -122,7 +127,6 @@ subroutine gsisub(init_pass,last_pass) ! Allocate grid arrays. call create_grid_vars - ! Get date, grid, and other information from model guess files call gesinfo @@ -139,8 +143,10 @@ subroutine gsisub(init_pass,last_pass) end if ! Process any level 2 bufr format land doppler radar winds and create radar wind superob file - if(wrf_nmm_regional.or.wrf_mass_regional.or.nems_nmmb_regional .or. cmaq_regional) then - if(.not. oneobtest) call radar_bufr_read_all(npe,mype) + if(wrf_nmm_regional.or.wrf_mass_regional.or.nems_nmmb_regional .or. cmaq_regional & + .or. fv3_regional) then + if(.not. oneobtest .and. (.not. l2rwthin)) call radar_bufr_read_all(npe,mype) !Xu + !if(.not. oneobtest) call radar_bufr_read_all(npe,mype) end if !at some point cmaq will become also an online met/chem model (?) @@ -148,6 +154,7 @@ subroutine gsisub(init_pass,last_pass) if (init_pass) then if (.not.twodvar_regional) then call radinfo_read + call corr_ob_initialize call radiance_obstype_init call radiance_parameter_cloudy_init call ozinfo_read @@ -159,8 +166,10 @@ subroutine gsisub(init_pass,last_pass) call aircraftinfo_read endif call convinfo_read + call lightinfo_read if(print_verbose)then call tell('gsisub','returned from convinfo_read()') + call tell('gsisub','returned from lightinfo_read()') end if endif @@ -196,6 +205,7 @@ subroutine gsisub(init_pass,last_pass) if(last_pass) then ! Deallocate arrays + call corr_ob_finalize call destroy_pcp_random #ifndef HAVE_ESMF call destroy_grid_vars diff --git a/src/guess_grids.F90 b/src/gsi/guess_grids.F90 similarity index 92% rename from src/guess_grids.F90 rename to src/gsi/guess_grids.F90 index 03a8dcac5..76e68f3a3 100644 --- a/src/guess_grids.F90 +++ b/src/gsi/guess_grids.F90 @@ -14,14 +14,6 @@ module guess_grids use kinds, only: r_single,r_kind,i_kind use constants, only: max_varname_length - use gridmod, only: regional - use gridmod, only: wrf_nmm_regional,nems_nmmb_regional - use gridmod, only: eta1_ll - use gridmod, only: eta2_ll - use gridmod, only: aeta1_ll - use gridmod, only: aeta2_ll - use gridmod, only: pdtop_ll - use gridmod, only: pt_ll use gsi_bundlemod, only : gsi_bundlegetpointer @@ -106,6 +98,10 @@ module guess_grids ! all tendencies now in a bundle (see tendsmod) ! all derivaties now in a bundle (see derivsmod) ! 2015-01-15 Hu - Add coast_prox to hold coast proximity +! 2017-05-12 Y. Wang and X. Wang - add bottom and top levels of w and rho for +! radar DA later, POC: xuguang.wang@ou.edu +! 2017-10-10 wu - Add code for fv3_regional +! 2019-03-21 Wei/Martin - add code for external aerosol file input ! ! !AUTHOR: ! kleist org: np20 date: 2003-12-01 @@ -134,6 +130,7 @@ module guess_grids public :: destroy_metguess_grids public :: create_chemges_grids public :: destroy_chemges_grids + public :: get_ref_gesprs ! set passed variables to public public :: ntguessig,ges_prsi,ges_psfcavg,ges_prslavg public :: isli2,ges_prsl,nfldsig @@ -142,20 +139,26 @@ module guess_grids public :: ntguessfc,ntguesnst,dsfct,ifilesig,veg_frac,soil_type,veg_type public :: sno2,ifilesfc,ifilenst,sfc_rough,fact10,sno,isli,soil_temp,soil_moi,coast_prox public :: nfldsfc,nfldnst,hrdifsig,ges_tsen,sfcmod_mm5,sfcmod_gfs,ifact10,hrdifsfc,hrdifnst - public :: geop_hgti,ges_lnprsi,ges_lnprsl,geop_hgtl,pt_ll,pbl_height + public :: geop_hgti,ges_lnprsi,ges_lnprsl,geop_hgtl,pbl_height,ges_geopi public :: wgt_lcbas public :: ges_qsat public :: use_compress,nsig_ext,gpstop + public :: ntguesaer,ifileaer,nfldaer,hrdifaer ! variables for external aerosol files public :: ges_initialized public :: nfldsig_all,nfldsig_now,hrdifsig_all public :: nfldsfc_all,nfldsfc_now,hrdifsfc_all public :: nfldnst_all,nfldnst_now,hrdifnst_all + public :: nfldaer_all,nfldaer_now,hrdifaer_all ! variables for external aerosol files public :: extrap_intime public :: ntguessig_ref public :: ntguessfc_ref public :: ntguesnst_ref + public :: ntguesaer_ref + + public :: ges_w_btlev + public :: ges_rho logical:: sfcmod_gfs = .false. ! .true. = recompute 10m wind factor using gfs physics logical:: sfcmod_mm5 = .false. ! .true. = recompute 10m wind factor using mm5 physics @@ -167,10 +170,12 @@ module guess_grids integer(i_kind) ntguessig ! location of actual guess time for sigma fields integer(i_kind) ntguessfc ! location of actual guess time for sfc fields integer(i_kind) ntguesnst ! location of actual guess time for nst FCST fields + integer(i_kind) ntguesaer ! location of actual guess time for aer FCST fields integer(i_kind), save:: ntguessig_ref ! replace ntguessig as the storage for its original value integer(i_kind), save:: ntguessfc_ref ! replace ntguessfc as the storage for its original value integer(i_kind), save:: ntguesnst_ref ! replace ntguesnst as the storage for its original value + integer(i_kind), save:: ntguesaer_ref ! replace ntguesaer as the storage for its original value integer(i_kind):: ifact10 = 0 ! 0 = use 10m wind factor from guess integer(i_kind):: nsig_ext = 13 ! use 13 layers above model top to compute the bending angle for gpsro @@ -180,6 +185,7 @@ module guess_grids real(r_kind), allocatable, dimension(:), save:: hrdifsig_all ! a list of all times real(r_kind), allocatable, dimension(:), save:: hrdifsfc_all ! a list of all times real(r_kind), allocatable, dimension(:), save:: hrdifnst_all ! a list of all times + real(r_kind), allocatable, dimension(:), save:: hrdifaer_all ! a list of all times integer(i_kind), save:: nfldsig_all ! expected total count of time slots integer(i_kind), save:: nfldsfc_all @@ -193,16 +199,23 @@ module guess_grids integer(i_kind), save:: nfldsfc_now integer(i_kind), save:: nfldnst_now +! variables for external aerosol files + integer(i_kind), save:: nfldaer_all + integer(i_kind), save:: nfldaer ! actual count of in-cache time slots for AER file + integer(i_kind), save:: nfldaer_now + logical, save:: extrap_intime ! compute o-f interpolate within the time ranges of guess_grids, ! or also extrapolate outside the time ranges. real(r_kind), allocatable, dimension(:):: hrdifsig ! times for cached sigma guess_grid real(r_kind), allocatable, dimension(:):: hrdifsfc ! times for cached surface guess_grid real(r_kind), allocatable, dimension(:):: hrdifnst ! times for cached nst guess_grid + real(r_kind), allocatable, dimension(:):: hrdifaer ! times for cached aer guess_grid integer(i_kind),allocatable, dimension(:)::ifilesfc ! array used to open the correct surface guess files integer(i_kind),allocatable, dimension(:)::ifilesig ! array used to open the correct sigma guess files integer(i_kind),allocatable, dimension(:)::ifilenst ! array used to open the correct nst guess files + integer(i_kind),allocatable, dimension(:)::ifileaer ! array used to open the correct aer guess files integer(i_kind),allocatable,dimension(:,:,:):: isli ! snow/land/ice mask integer(i_kind),allocatable,dimension(:,:,:):: isli_g ! isli on horiz/global grid @@ -234,6 +247,7 @@ module guess_grids real(r_kind),allocatable,dimension(:,:,:,:):: geop_hgtl ! guess geopotential height at mid-layers real(r_kind),allocatable,dimension(:,:,:,:):: geop_hgti ! guess geopotential height at level interfaces + real(r_kind),allocatable,dimension(:,:,:,:):: ges_geopi ! input guess geopotential height at level interfaces real(r_kind),allocatable,dimension(:,:,:):: pbl_height ! GSD PBL height in hPa ! Guess Fields ... @@ -248,6 +262,9 @@ module guess_grids real(r_kind),allocatable,dimension(:,:,:):: fact_tv ! 1./(one+fv*ges_q) for virt to sen calc. real(r_kind),allocatable,dimension(:,:,:,:):: ges_qsat ! 4d qsat array + real(r_kind),allocatable,dimension(:,:,:,:):: ges_w_btlev + real(r_kind),allocatable,dimension(:,:,:,:):: ges_rho + interface guess_grids_print module procedure print1r8_ module procedure print2r8_ @@ -391,6 +408,7 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) ! !USES: + use wrf_vars_mod, only : w_exist use constants,only: zero,one use gridmod, only: lat2,lon2,nsig implicit none @@ -421,6 +439,7 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) ! 2012-05-14 todling - revisit cw check to check also on some hydrometeors ! 2013-10-19 todling - revisit initialization of certain vars wrt ESMF ! 2014-06-09 carley/zhu - add wgt_lcbas +! 2019-03-21 Wei/Martin - add capability to read external aerosol file ! ! !REMARKS: ! language: f90 @@ -445,6 +464,8 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) nfldsig_now=0 ! _now variables are not used if not for ESMF nfldsfc_now=0 nfldnst_now=0 + nfldaer_all=nfldaer + nfldaer_now=0 extrap_intime=.true. #endif /* HAVE_ESMF */ @@ -453,11 +474,18 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) ges_lnprsl(lat2,lon2,nsig,nfldsig),ges_lnprsi(lat2,lon2,nsig+1,nfldsig),& ges_tsen(lat2,lon2,nsig,nfldsig),& ges_teta(lat2,lon2,nsig,nfldsig),& + ges_rho(lat2,lon2,nsig,nfldsig), & geop_hgtl(lat2,lon2,nsig,nfldsig), & geop_hgti(lat2,lon2,nsig+1,nfldsig),ges_prslavg(nsig),& + ges_geopi(lat2,lon2,nsig+1,nfldsig),& tropprs(lat2,lon2),fact_tv(lat2,lon2,nsig),& pbl_height(lat2,lon2,nfldsig),wgt_lcbas(lat2,lon2), & ges_qsat(lat2,lon2,nsig,nfldsig),stat=istatus) + + if(w_exist)then + allocate(ges_w_btlev(lat2,lon2,2,nfldsig),stat=istatus) + endif + if (istatus/=0) write(6,*)'CREATE_GES_GRIDS(ges_prsi,..): allocate error, istatus=',& istatus,lat2,lon2,nsig,nfldsig @@ -496,6 +524,7 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) do i=1,lat2 ges_prsl(i,j,k,n)=zero ges_lnprsl(i,j,k,n)=zero + ges_rho(i,j,k,n)=zero ges_qsat(i,j,k,n)=zero ges_tsen(i,j,k,n)=zero ges_teta(i,j,k,n)=zero @@ -509,6 +538,7 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) ges_prsi(i,j,k,n)=zero ges_lnprsi(i,j,k,n)=zero geop_hgti(i,j,k,n)=zero + ges_geopi(i,j,k,n)=zero end do end do end do @@ -520,6 +550,10 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) end do end do + if(w_exist) then + ges_w_btlev=zero + endif + end if ! ges_initialized ! If tendencies option on, allocate/initialize _ten arrays to zero @@ -759,6 +793,7 @@ end subroutine destroy_chemges_grids subroutine destroy_ges_grids ! !USES: + use wrf_vars_mod, only : w_exist implicit none @@ -795,8 +830,9 @@ subroutine destroy_ges_grids call destroy_ges_tendencies ! deallocate(ges_prsi,ges_prsl,ges_lnprsl,ges_lnprsi,& - ges_tsen,ges_teta,geop_hgtl,geop_hgti,ges_prslavg,& + ges_tsen,ges_teta,geop_hgtl,geop_hgti,ges_geopi,ges_prslavg,ges_rho,& tropprs,fact_tv,pbl_height,wgt_lcbas,ges_qsat,stat=istatus) + if(w_exist) deallocate(ges_w_btlev,stat=istatus) if (istatus/=0) & write(6,*)'DESTROY_GES_GRIDS(ges_prsi,..): deallocate error, istatus=',& istatus @@ -888,6 +924,7 @@ subroutine create_gesfinfo ! ! !REVISION HISTORY: ! 2009-01-08 todling +! 2019-03-21 Wei/Martin - added separate aerosol input file ! ! !REMARKS: ! language: f90 @@ -910,13 +947,17 @@ subroutine create_gesfinfo nfldsig_now=0 ! _now variables are not used if not for ESMF nfldsfc_now=0 nfldnst_now=0 + nfldaer_all=nfldaer + nfldaer_now=0 extrap_intime=.true. allocate(hrdifsfc(nfldsfc),ifilesfc(nfldsfc), & hrdifnst(nfldnst),ifilenst(nfldnst), & hrdifsig(nfldsig),ifilesig(nfldsig), & + hrdifaer(nfldaer),ifileaer(nfldaer), & hrdifsfc_all(nfldsfc_all), & hrdifnst_all(nfldnst_all), & hrdifsig_all(nfldsig_all), & + hrdifaer_all(nfldaer_all), & stat=istatus) if (istatus/=0) & write(6,*)'CREATE_GESFINFO(hrdifsfc,..): allocate error, istatus=',& @@ -945,6 +986,7 @@ subroutine destroy_gesfinfo ! ! !REVISION HISTORY: ! 2009-01-08 todling +! 2019-03-21 Wei/Martin - added external aerosol file variables ! ! !REMARKS: ! language: f90 @@ -961,8 +1003,8 @@ subroutine destroy_gesfinfo gesfinfo_created_=.false. #ifndef HAVE_ESMF - deallocate(hrdifsfc,ifilesfc,hrdifnst,ifilenst,hrdifsig,ifilesig, & - hrdifsfc_all,hrdifnst_all,hrdifsig_all,stat=istatus) + deallocate(hrdifsfc,ifilesfc,hrdifnst,hrdifaer,ifilenst,hrdifsig,ifilesig,ifileaer,& + hrdifsfc_all,hrdifnst_all,hrdifsig_all,hrdifaer_all,stat=istatus) if (istatus/=0) & write(6,*)'DESTROY_GESFINFO: deallocate error, istatus=',& istatus @@ -973,6 +1015,8 @@ subroutine destroy_gesfinfo nfldsfc =0 nfldnst =0 nfldsig =0 + nfldaer_all=0 + nfldaer =0 #endif /* HAVE_ESMF */ return @@ -992,11 +1036,12 @@ subroutine load_prsges ! !USES: - use constants,only: zero,one,rd_over_cp,one_tenth,half,ten + use constants,only: zero,one,rd_over_cp,one_tenth,half,ten,rd,r1000 use gridmod, only: lat2,lon2,nsig,ak5,bk5,ck5,tref5,idvc5,& regional,wrf_nmm_regional,nems_nmmb_regional,wrf_mass_regional,& - cmaq_regional,pt_ll,aeta2_ll,& + cmaq_regional,pt_ll,aeta2_ll,fv3_regional,& aeta1_ll,eta2_ll,pdtop_ll,eta1_ll,twodvar_regional,idsl5 + use obsmod, only: dtype,ndat implicit none ! !DESCRIPTION: populate guess pressure arrays @@ -1034,7 +1079,8 @@ subroutine load_prsges real(r_kind) kap1,kapr,trk real(r_kind),dimension(:,:) ,pointer::ges_ps=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_tv=>NULL() - integer(i_kind) i,j,k,jj,itv,ips + real(r_kind) pinc(lat2,lon2) + integer(i_kind) i,j,k,ii,jj,itv,ips,kp logical ihaveprs(nfldsig) kap1=rd_over_cp+one @@ -1048,6 +1094,23 @@ subroutine load_prsges if(idvc5==3) then if(itv/=0) call die(myname_,': tv must be present when idvc5=3, abort',itv) endif + +!!!!!!!!!!!! load delp to ges_prsi in read_fv3_netcdf_guess !!!!!!!!!!!!!!!!! + if (fv3_regional ) then + do j=1,lon2 + do i=1,lat2 + pinc(i,j)=(ges_ps(i,j)-ges_prsi(i,j,1,jj)) + enddo + enddo + do k=1,nsig+1 + do j=1,lon2 + do i=1,lat2 + ges_prsi(i,j,k,jj)=ges_prsi(i,j,k,jj)+eta2_ll(k)*pinc(i,j) + enddo + enddo + enddo + endif + do k=1,nsig+1 do j=1,lon2 do i=1,lat2 @@ -1105,6 +1168,22 @@ subroutine load_prsges end do end do end if ! end if wrf_nmm regional block + + if (fv3_regional) then + do jj=1,nfldsig + do k=1,nsig + kp=k+1 + do j=1,lon2 + do i=1,lat2 + ges_prsl(i,j,k,jj)=(ges_prsi(i,j,k,jj)+ges_prsi(i,j,kp,jj))*half + ges_lnprsl(i,j,k,jj)=log(ges_prsl(i,j,k,jj)) + + end do + end do + end do + end do + end if ! end if fv3 regional + if (twodvar_regional .or. cmaq_regional) then ! load using aeta coefficients do jj=1,nfldsig @@ -1175,6 +1254,26 @@ subroutine load_prsges end if ! end regional/global block +! Compute density for dBZ assimilation purposes - multiply by 1000 to convert +! to Pa + do ii=1,ndat + if ( index(dtype(ii), 'dbz') /= 0 )then + do jj=1,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(jj),'tv' ,ges_tv,itv) + if(idvc5==3) then + if(itv/=0) call die(myname_,': tv must be present when idvc5=3,abort',itv) + endif + do j=1,lon2 + do i=1,lat2 + do k=1,nsig + ges_rho(i,j,k,jj)=(ges_prsl(i,j,k,jj)/(ges_tv(i,j,k)*rd))*r1000 + end do + end do + end do + end do + end if + end do + ! For regional applications only, load variables containing mean ! surface pressure and pressure profile at the layer midpoints if (regional) then @@ -1183,6 +1282,10 @@ subroutine load_prsges do k=1,nsig ges_prslavg(k)=aeta1_ll(k)*pdtop_ll+aeta2_ll(k)*(r1013-pdtop_ll-pt_ll)+pt_ll end do + elseif (fv3_regional) then + do k=1,nsig + ges_prslavg(k)=aeta1_ll(k)*ten+r1013*aeta2_ll(k) + end do elseif (wrf_mass_regional) then do k=1,nsig ges_prslavg(k)=aeta1_ll(k)*(r1013-pt_ll)+aeta2_ll(k) + pt_ll @@ -1198,6 +1301,52 @@ subroutine load_prsges return end subroutine load_prsges + subroutine get_ref_gesprs(prs) + use constants, only: zero,one_tenth,r100,r1000 + use gridmod, only: regional,twodvar_regional,cmaq_regional + use gridmod, only: wrf_nmm_regional,nems_nmmb_regional,wrf_mass_regional,fv3_regional + use gridmod, only: idvc5,ak5,bk5 + use gridmod, only: eta1_ll + use gridmod, only: eta2_ll + use gridmod, only: pdtop_ll + use gridmod, only: pt_ll + use gridmod, only: nsig + implicit none + real(r_kind), dimension(nsig+1), intent(out) :: prs + + integer(i_kind) k + +! get some reference-like pressure levels + do k=1,nsig+1 + if(regional) then + if (wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) & + prs(k)=one_tenth* & + (eta1_ll(k)*pdtop_ll + & + eta2_ll(k)*(r1000-pdtop_ll-pt_ll) + & + pt_ll) + if (twodvar_regional) & + prs(k)=one_tenth*(eta1_ll(k)*(r1000-pt_ll) + pt_ll) + if (fv3_regional ) & + prs(k)=eta1_ll(k)+r100*eta2_ll(k) + if (wrf_mass_regional) & + prs(k)=one_tenth*(eta1_ll(k)*(r1000-pt_ll) + eta2_ll(k) + pt_ll) + else + if (idvc5==1 .or. idvc5==2) then + prs(k)=ak5(k)+(bk5(k)*r1000) + else if (idvc5==3) then + if (k==1) then + prs(k)=r1000 + else if (k==nsig+1) then + prs(k)=zero + else + prs(k)=ak5(k)+(bk5(k)*r1000)! +(ck5(k)*trk) + end if + end if + endif + enddo + end subroutine get_ref_gesprs + + !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- @@ -1469,7 +1618,8 @@ subroutine load_gsdpbl_hgt(mype) use constants, only: one,rd_over_cp_mass,r1000,ten,zero,two use gridmod, only: lat2, lon2, nsig,wrf_mass_regional, & - twodvar_regional,nems_nmmb_regional + aeta1_ll,aeta2_ll,pdtop_ll,pt_ll,& + twodvar_regional,nems_nmmb_regional,fv3_regional implicit none @@ -1503,6 +1653,10 @@ subroutine load_gsdpbl_hgt(mype) real(r_kind),dimension(:,:,:),pointer::ges_tv=>NULL() if (twodvar_regional) return + if (fv3_regional) then + if(mype==0)write(6,*)'not setup for fv3_regional in load_gsdpbl_hgt' + return + endif ! Compute geopotential height at midpoint of each layer do jj=1,nfldsig diff --git a/src/half_nmm_grid2.f90 b/src/gsi/half_nmm_grid2.f90 similarity index 100% rename from src/half_nmm_grid2.f90 rename to src/gsi/half_nmm_grid2.f90 diff --git a/src/hilbert_curve.f90 b/src/gsi/hilbert_curve.f90 similarity index 100% rename from src/hilbert_curve.f90 rename to src/gsi/hilbert_curve.f90 diff --git a/src/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 similarity index 98% rename from src/hybrid_ensemble_isotropic.F90 rename to src/gsi/hybrid_ensemble_isotropic.F90 index e90837003..4e50bd974 100644 --- a/src/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -47,6 +47,7 @@ module hybrid_ensemble_isotropic ! 2014-12-02 derber - many optimization changes ! 2015-04-07 carley - bug fix to allow grd_loc%nlat=grd_loc%nlon ! 2016-05-13 parrish - remove beta12mult +! 2018-02-15 wu - add code for fv3_regional option ! ! subroutines included: ! sub init_rf_z - initialize localization recursive filter (z direction) @@ -226,9 +227,9 @@ subroutine init_rf_z(z_len) use gridmod, only: nsig,ak5,bk5,eta1_ll,eta2_ll,pt_ll,pdtop_ll,twodvar_regional, & wrf_nmm_regional,nems_nmmb_regional,wrf_mass_regional,cmaq_regional, & - regional + regional,fv3_regional use constants, only: half,one,rd_over_cp,zero,one_tenth,ten,two - use hybrid_ensemble_parameters, only: grd_ens,s_ens_v + use hybrid_ensemble_parameters, only: grd_ens use hybrid_ensemble_parameters, only: ps_bar implicit none @@ -248,10 +249,11 @@ subroutine init_rf_z(z_len) ! use new factorization: - allocate(fmatz(nxy,2,nsig,2),fmat0z(nxy,nsig,2)) + if(.not.allocated(fmatz)) allocate(fmatz(nxy,2,nsig,2)) + if(.not.allocated(fmat0z)) allocate(fmat0z(nxy,nsig,2)) allocate(fmatz_tmp(2,nsig,2),fmat0z_tmp(nsig,2)) ! for z_len < zero, use abs val z_len and assume localization scale is in units of ln(p) - if(s_ens_v > zero) then + if(maxval(z_len) > zero) then ! z_len is in grid units do k=1,nsig @@ -296,6 +298,9 @@ subroutine init_rf_z(z_len) eta2_ll(k)*(ten*ps_bar(ii,jj,1)-pdtop_ll-pt_ll) + & pt_ll) endif + if (fv3_regional) then + p_interface(k)=eta1_ll(k)+ eta2_ll(k)*ps_bar(ii,jj,1) + endif if (twodvar_regional) then p_interface(k)=one_tenth*(eta1_ll(k)*(ten*ps_bar(ii,jj,1)-pt_ll)+pt_ll) endif @@ -1168,14 +1173,17 @@ subroutine load_ensemble use mpimod, only: mype use get_pseudo_ensperts_mod, only: get_pseudo_ensperts_class use get_wrf_mass_ensperts_mod, only: get_wrf_mass_ensperts_class + use get_fv3_regional_ensperts_mod, only: get_fv3_regional_ensperts_class use get_wrf_nmm_ensperts_mod, only: get_wrf_nmm_ensperts_class use hybrid_ensemble_parameters, only: region_lat_ens,region_lon_ens + use mpimod, only: mpi_comm_world,ierror implicit none type(get_pseudo_ensperts_class) :: pseudo_enspert type(get_wrf_mass_ensperts_class) :: wrf_mass_enspert type(get_wrf_nmm_ensperts_class) :: wrf_nmm_enspert + type(get_fv3_regional_ensperts_class) :: fv3_regional_enspert type(gsi_bundle),allocatable:: en_bar(:) type(gsi_bundle):: bundle_anl,bundle_ens type(gsi_grid) :: grid_anl,grid_ens @@ -1295,7 +1303,7 @@ subroutine load_ensemble else - if(regional_ensemble_option < 1 .or. regional_ensemble_option > 4) then + if(regional_ensemble_option < 1 .or. regional_ensemble_option > 5) then if(mype==0) then write(6,'(" IMPROPER CHOICE FOR ENSEMBLE INPUT IN SUBROUTINE LOAD_ENSEMBLE")') write(6,'(" regional_ensemble_option = ",i5)') regional_ensemble_option @@ -1312,7 +1320,6 @@ subroutine load_ensemble end if call stop2(999) end if - select case(regional_ensemble_option) case(1) @@ -1350,6 +1357,10 @@ subroutine load_ensemble ! regional_ensemble_option = 4: ensembles are NEMS NMMB format. call get_nmmb_ensperts + case(5) +! regional_ensemble_option = 5: ensembles are fv3 regional. + call fv3_regional_enspert%get_fv3_regional_ensperts(en_perts,nelen,ps_bar) + end select @@ -2531,7 +2542,8 @@ subroutine sqrt_beta_s_mult_cvec(grady) ! 2010-03-29 kleist comment out beta_s0 for SST ! 2010-04-28 todling update to use gsi_bundle ! 2011-06-13 wu used height dependent beta for regional -! 12-05-2012 el akkraoui hybrid beta parameters now vertically varying +! 2012-05-12 el akkraoui hybrid beta parameters now vertically varying +! 2015-09-18 todling - add sst_staticB to control use of ensemble SST error covariance ! ! input argument list: ! grady - input field grady_x1 @@ -2548,6 +2560,7 @@ subroutine sqrt_beta_s_mult_cvec(grady) use gsi_4dvar, only: nsubwin use hybrid_ensemble_parameters, only: oz_univ_static use hybrid_ensemble_parameters, only: sqrt_beta_s + use hybrid_ensemble_parameters, only: sst_staticB use constants, only: one use gsi_bundlemod, only: gsi_bundlegetpointer use control_vectors,only: control_vector @@ -2595,7 +2608,13 @@ subroutine sqrt_beta_s_mult_cvec(grady) enddo do ic2=1,nc2d ! Default to static B estimate for SST - if ( trim(StrUpCase(cvars2d(ic2))) == 'SST' ) cycle + if ( trim(StrUpCase(cvars2d(ic2))) == 'SST' ) then + if(sst_staticB) then + cycle + else + if(j==1.and.mype==0) write(6,*) myname_, ': scale static SST B-error by ', sqrt_beta_s(1) + endif + endif do i=1,lat2 grady%step(ii)%r2(ipc2d(ic2))%q(i,j) = sqrt_beta_s(1)*grady%step(ii)%r2(ipc2d(ic2))%q(i,j) enddo @@ -2622,7 +2641,8 @@ subroutine sqrt_beta_s_mult_bundle(grady) ! 2010-03-29 kleist comment out sqrt_beta_s for SST ! 2010-04-28 todling update to use gsi_bundle ! 2011-06-13 wu used height dependent beta for regional -! 12-05-2012 el akkraoui hybrid beta parameters now vertically varying +! 2012-05-12 el akkraoui hybrid beta parameters now vertically varying +! 2015-09-18 todling - add sst_staticB to control use of ensemble SST error covariance ! ! input argument list: ! grady - input field grady_x1 @@ -2638,6 +2658,7 @@ subroutine sqrt_beta_s_mult_bundle(grady) use kinds, only: r_kind,i_kind use hybrid_ensemble_parameters, only: oz_univ_static use hybrid_ensemble_parameters, only: sqrt_beta_s + use hybrid_ensemble_parameters, only: sst_staticB use constants, only: one use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -2684,7 +2705,13 @@ subroutine sqrt_beta_s_mult_bundle(grady) enddo do ic2=1,nc2d ! Default to static B estimate for SST - if ( trim(StrUpCase(cvars2d(ic2))) == 'SST' ) cycle + if ( trim(StrUpCase(cvars2d(ic2))) == 'SST' ) then + if(sst_staticB) then + cycle + else + if(mype==0) write(6,*) myname_, ': scale static SST B-error by ', sqrt_beta_s(1) + endif + endif do i=1,lat2 grady%r2(ipc2d(ic2))%q(i,j) = sqrt_beta_s(1)*grady%r2(ipc2d(ic2))%q(i,j) enddo @@ -3027,8 +3054,8 @@ subroutine init_sf_xy(jcap_in) rkm(1+(grd_sploc%nlat-2)/2), & -rkm(grd_sploc%nlat-(grd_sploc%nlat-2)/2)+rkm(1+(grd_sploc%nlat-2)/2),' km' - allocate(spectral_filter(sp_loc%nc,grd_sploc%nsig)) - allocate(sqrt_spectral_filter(sp_loc%nc,grd_sploc%nsig)) + if(.not.allocated(spectral_filter)) allocate(spectral_filter(sp_loc%nc,grd_sploc%nsig)) + if(.not.allocated(sqrt_spectral_filter)) allocate(sqrt_spectral_filter(sp_loc%nc,grd_sploc%nsig)) allocate(g(sp_loc%nc),gsave(sp_loc%nc)) allocate(pn0_npole(0:sp_loc%jcap)) allocate(ksame(grd_sploc%nsig)) @@ -3036,6 +3063,7 @@ subroutine init_sf_xy(jcap_in) do k=2,grd_sploc%nsig if(s_ens_hv(k) == s_ens_hv(k-1))ksame(k)=.true. enddo + spectral_filter=zero do k=1,grd_sploc%nsig if(ksame(k))then spectral_filter(:,k)=spectral_filter(:,k-1) @@ -3111,11 +3139,18 @@ subroutine init_sf_xy(jcap_in) enddo deallocate(g,gsave,pn0_npole,ksame) - sqrt_spectral_filter=sqrt(spectral_filter) +! Compute sqrt(spectral_filter). Ensure spectral_filter >=0 zero +!$omp parallel do schedule(dynamic,1) private(k,i) + do k=1,grd_sploc%nsig + do i=1,sp_loc%nc + if (spectral_filter(i,k) < zero) spectral_filter(i,k)=zero + sqrt_spectral_filter(i,k) = sqrt(spectral_filter(i,k)) + end do + end do ! assign array k_index for each processor, based on grd_loc%kbegin_loc,grd_loc%kend_loc - allocate(k_index(grd_loc%kbegin_loc:grd_loc%kend_alloc)) + if(.not.allocated(k_index)) allocate(k_index(grd_loc%kbegin_loc:grd_loc%kend_alloc)) k_index=0 do k=grd_loc%kbegin_loc,grd_loc%kend_loc k_index(k)=1+mod(k-1,grd_loc%nsig) @@ -4001,7 +4036,7 @@ subroutine hybens_localization_setup if ( istat /= 0 ) then write(6,*) 'HYBENS_LOCALIZATION_SETUP: ***ERROR*** error in ',trim(fname) write(6,*) 'HYBENS_LOCALIZATION_SETUP: error reading file, iostat = ',istat - stop(123) + call stop2(123) endif if ( msig /= grd_ens%nsig ) then write(6,*) 'HYBENS_LOCALIZATION_SETUP: ***ERROR*** error in ',trim(fname) @@ -4009,7 +4044,7 @@ subroutine hybens_localization_setup close(lunin) call stop2(123) endif - if(print_verbose) write(6,'(" LOCALIZATION, BETA_S, BETA_E VERTICAL PROFILES FOLLOW")') + if(mype==0) write(6,'(" LOCALIZATION, BETA_S, BETA_E VERTICAL PROFILES FOLLOW")') do k = 1,grd_ens%nsig read(lunin,101) s_ens_hv(k), s_ens_vv(k), beta_s(k), beta_e(k) if(mype==0) write(6,101) s_ens_hv(k), s_ens_vv(k), beta_s(k), beta_e(k) @@ -4027,13 +4062,15 @@ subroutine hybens_localization_setup vvlocal = .true. nz = msig kl = grd_loc%kend_alloc-grd_loc%kbegin_loc+1 - allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens),s_ens_h_gu_y(grd_loc%nsig*n_ens)) + if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens)) + if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(grd_loc%nsig*n_ens)) endif endif ! if ( readin_localization .or. readin_beta ) 100 format(I4) -101 format(F8.1,3x,F5.1,2(3x,F8.4)) +!101 format(F8.1,3x,F5.1,2(3x,F8.4)) +101 format(F8.1,3x,F8.3,F8.4,3x,F8.4) if ( .not. readin_beta ) then ! assign all levels to same value, sum = 1.0 beta_s = beta_s0 @@ -4052,7 +4089,8 @@ subroutine hybens_localization_setup if ( .not. readin_localization ) then ! assign all levels to same value, s_ens_h, s_ens_v nz = 1 kl = 1 - allocate(s_ens_h_gu_x(1),s_ens_h_gu_y(1)) + if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(1)) + if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(1)) s_ens_hv = s_ens_h s_ens_vv = s_ens_v endif diff --git a/src/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90 similarity index 98% rename from src/hybrid_ensemble_parameters.f90 rename to src/gsi/hybrid_ensemble_parameters.f90 index 5c78ca47a..9ea28c9ee 100644 --- a/src/hybrid_ensemble_parameters.f90 +++ b/src/gsi/hybrid_ensemble_parameters.f90 @@ -114,6 +114,7 @@ module hybrid_ensemble_parameters ! function of z, default = .false. ! ensemble_path: path to ensemble members; default './' ! ens_fast_read: read ensemble in parallel; default '.false.' +! sst_staticB: if .true. (default) uses only static part of B error covariance for SST !===================================================================================================== ! ! @@ -146,6 +147,7 @@ module hybrid_ensemble_parameters ! 2014-05-14 wu - add logical variable vvlocal for vertically verying horizontal localization length in regional ! 2015-01-22 Hu - add flag i_en_perts_io to control reading ensemble perturbation. ! 2015-02-11 Hu - add flag l_ens_in_diff_time to force GSI hybrid use ensembles not available at analysis time +! 2015-09-18 todling - add sst_staticB to control use of ensemble SST error covariance ! ! subroutines included: @@ -274,6 +276,8 @@ module hybrid_ensemble_parameters public :: pseudo_hybens public :: merge_two_grid_ensperts public :: regional_ensemble_option + public :: fv3sar_ensemble_opt + public :: write_ens_sprd public :: nval_lenz_en public :: ntlevs_ens @@ -285,8 +289,9 @@ module hybrid_ensemble_parameters public :: region_lat_ens,region_lon_ens public :: region_dx_ens,region_dy_ens public :: ens_fast_read + public :: sst_staticB - logical l_hyb_ens,uv_hyb_ens,q_hyb_ens,oz_univ_static + logical l_hyb_ens,uv_hyb_ens,q_hyb_ens,oz_univ_static,sst_staticB logical aniso_a_en logical full_ensemble,pwgtflg logical generate_ens @@ -321,6 +326,7 @@ module hybrid_ensemble_parameters integer(i_kind) nval_lenz_en integer(i_kind) ntlevs_ens integer(i_kind) regional_ensemble_option + integer(i_kind) fv3sar_ensemble_opt character(len=512),save :: ensemble_path ! following is for storage of ensemble perturbations: @@ -374,11 +380,13 @@ subroutine init_hybrid_ensemble_parameters uv_hyb_ens=.false. q_hyb_ens=.false. oz_univ_static=.false. + sst_staticB=.true. aniso_a_en=.false. generate_ens=.true. pseudo_hybens=.false. merge_two_grid_ensperts=.false. regional_ensemble_option=0 + fv3sar_ensemble_opt=0 write_ens_sprd=.false. readin_localization=.false. readin_beta=.false. diff --git a/src/inc2guess.f90 b/src/gsi/inc2guess.f90 similarity index 100% rename from src/inc2guess.f90 rename to src/gsi/inc2guess.f90 diff --git a/src/init_jcdfi.f90 b/src/gsi/init_jcdfi.f90 similarity index 100% rename from src/init_jcdfi.f90 rename to src/gsi/init_jcdfi.f90 diff --git a/src/gsi/insitu_info.f90 b/src/gsi/insitu_info.f90 new file mode 100644 index 000000000..de1f2c640 --- /dev/null +++ b/src/gsi/insitu_info.f90 @@ -0,0 +1,443 @@ +module insitu_info +!$$$ +! . . . . +! module: insitu_info +! prgmmr: Xu Li org: np22 date: 2008-04-22 +! +! abstract: This module classify the depth & instrument dependent +! moored buoy and ships observations +! +! +! program history log: +! ?????? li - intial version +! 10Jul2011 todling - careful about existence of info-text file +! 20190115 li - add to handle mbuoyb +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: i_kind,r_kind + implicit none + +! Declare parameters + integer(i_kind),parameter:: n_comps = 3 + integer(i_kind),parameter:: n_scripps = 40 + integer(i_kind),parameter:: n_triton = 70 + integer(i_kind),parameter:: n_3mdiscus = 153 + integer(i_kind),parameter:: lunship = 11 + integer(i_kind),save :: n_ship = 2011 + +! Declare variables + integer(i_kind) :: i + character(len=10) :: filename + character(len=5),allocatable,dimension(:):: cid_mbuoy + character(len=7),allocatable,dimension(:):: cid_mbuoyb + type, public :: shipvar + character(len=10), allocatable, dimension(:) :: id + real(r_kind), allocatable, dimension(:) :: depth + character(len=5), allocatable, dimension(:) :: sensor + end type + type(shipvar):: ship + + contains + + subroutine mbuoy_info(mype) +!************************************************************************** +! +! assign the depth dependent moored buoy station ID +! + + integer(i_kind), intent(in) :: mype + allocate(cid_mbuoy(n_3mdiscus)) +! +! initialize cid +! + cid_mbuoy = ' ' +! +! COMPS moored buoy (depth = 1.2m) +! + cid_mbuoy( 1) = '42022' + cid_mbuoy( 2) = '42023' + cid_mbuoy( 3) = '42024' +! +! SCRIPPS moored buoy (depth = 0.45m) +! + cid_mbuoy( 4) = '31201' + cid_mbuoy( 5) = '41112' + cid_mbuoy( 6) = '41113' + cid_mbuoy( 7) = '41114' + cid_mbuoy( 8) = '42099' + cid_mbuoy( 9) = '46211' + cid_mbuoy(10) = '46212' + cid_mbuoy(11) = '46213' + cid_mbuoy(12) = '46214' + cid_mbuoy(13) = '46215' + cid_mbuoy(14) = '46216' + cid_mbuoy(15) = '46217' + cid_mbuoy(16) = '46218' + cid_mbuoy(17) = '46219' + cid_mbuoy(18) = '46220' + cid_mbuoy(19) = '46221' + cid_mbuoy(10) = '46222' + cid_mbuoy(21) = '46223' + cid_mbuoy(22) = '46224' + cid_mbuoy(23) = '46225' + cid_mbuoy(24) = '46226' + cid_mbuoy(25) = '46227' + cid_mbuoy(26) = '46228' + cid_mbuoy(27) = '46229' + cid_mbuoy(28) = '46230' + cid_mbuoy(29) = '46231' + cid_mbuoy(30) = '46232' + cid_mbuoy(31) = '46233' + cid_mbuoy(32) = '46234' + cid_mbuoy(33) = '46235' + cid_mbuoy(34) = '46236' + cid_mbuoy(35) = '46237' + cid_mbuoy(36) = '46238' + cid_mbuoy(37) = '51201' + cid_mbuoy(38) = '51202' + cid_mbuoy(39) = '51203' + cid_mbuoy(40) = '52200' +! +! TRITON buoys (depth = 1.5m) +! + cid_mbuoy(41) = '52071' + cid_mbuoy(42) = '52072' + cid_mbuoy(43) = '52073' + cid_mbuoy(44) = '52074' + cid_mbuoy(45) = '52075' + cid_mbuoy(46) = '52076' + cid_mbuoy(47) = '52077' + cid_mbuoy(48) = '52078' + cid_mbuoy(49) = '52079' + cid_mbuoy(50) = '52080' + cid_mbuoy(51) = '52081' + cid_mbuoy(52) = '52082' + cid_mbuoy(53) = '52083' + cid_mbuoy(54) = '52084' + cid_mbuoy(55) = '52085' + cid_mbuoy(56) = '52086' + cid_mbuoy(57) = '52087' + cid_mbuoy(58) = '52088' + cid_mbuoy(59) = '53056' + cid_mbuoy(60) = '53057' + cid_mbuoy(61) = '52043' + cid_mbuoy(62) = '52044' + cid_mbuoy(63) = '52045' + cid_mbuoy(64) = '52046' +! +! NDBC 3-meter buoy (depth = 0.6m) +! + cid_mbuoy(71) = '41004' + cid_mbuoy(72) = '41008' + cid_mbuoy(73) = '41012' + cid_mbuoy(74) = '41013' + cid_mbuoy(75) = '41025' + cid_mbuoy(76) = '41035' + cid_mbuoy(77) = '41036' + cid_mbuoy(78) = '42007' + cid_mbuoy(79) = '42019' + cid_mbuoy(80) = '42020' + cid_mbuoy(81) = '42035' + cid_mbuoy(82) = '42036' + cid_mbuoy(83) = '42039' + cid_mbuoy(84) = '42040' + cid_mbuoy(85) = '44007' + cid_mbuoy(86) = '44008' + cid_mbuoy(87) = '44009' + cid_mbuoy(88) = '44013' + cid_mbuoy(89) = '44014' + cid_mbuoy(90) = '44017' + cid_mbuoy(91) = '44018' + cid_mbuoy(92) = '44025' + cid_mbuoy(93) = '44027' + cid_mbuoy(94) = '45001' + cid_mbuoy(95) = '45002' + cid_mbuoy(96) = '45003' + cid_mbuoy(97) = '45004' + cid_mbuoy(98) = '45005' + cid_mbuoy(99) = '45006' + cid_mbuoy(100) = '45007' + cid_mbuoy(101) = '45008' + cid_mbuoy(102) = '45012' + cid_mbuoy(103) = '46011' + cid_mbuoy(104) = '46012' + cid_mbuoy(105) = '46013' + cid_mbuoy(106) = '46014' + cid_mbuoy(107) = '46015' + cid_mbuoy(108) = '46022' + cid_mbuoy(109) = '46025' + cid_mbuoy(110) = '46026' + cid_mbuoy(111) = '46027' + cid_mbuoy(112) = '46028' + cid_mbuoy(113) = '46029' + cid_mbuoy(114) = '46042' + cid_mbuoy(115) = '46047' + cid_mbuoy(116) = '46050' + cid_mbuoy(117) = '46053' + cid_mbuoy(118) = '46060' + cid_mbuoy(119) = '46063' + cid_mbuoy(120) = '46069' + cid_mbuoy(121) = '46081' + cid_mbuoy(122) = '46086' + cid_mbuoy(123) = '46087' + cid_mbuoy(124) = '46088' + cid_mbuoy(125) = '46089' + cid_mbuoy(126) = '51001' + cid_mbuoy(127) = '51028' +! +! Canadian 3-meter buoy (depth = 0.6m) +! + cid_mbuoy(128) = '44258' + cid_mbuoy(129) = '45132' + cid_mbuoy(130) = '45135' + cid_mbuoy(131) = '45136' + cid_mbuoy(132) = '45137' + cid_mbuoy(133) = '45138' + cid_mbuoy(134) = '45143' + cid_mbuoy(135) = '45144' + cid_mbuoy(136) = '45145' + cid_mbuoy(137) = '46131' + cid_mbuoy(138) = '46132' + cid_mbuoy(139) = '46134' + cid_mbuoy(140) = '46145' + cid_mbuoy(141) = '46146' + cid_mbuoy(142) = '46147' + cid_mbuoy(143) = '46181' + cid_mbuoy(144) = '46183' + cid_mbuoy(145) = '46185' + cid_mbuoy(146) = '46204' + cid_mbuoy(147) = '46205' + cid_mbuoy(148) = '46206' + cid_mbuoy(149) = '46207' + cid_mbuoy(150) = '46208' +! +! MBARI moored buoy (depth = 0.6m) +! + cid_mbuoy(151) = '46091' + cid_mbuoy(152) = '46092' + cid_mbuoy(153) = '46093' + + if(mype == 0) write(6,1000) n_comps,n_scripps,n_triton,n_3mdiscus +1000 format(' in mbuoy_info,n_comps = ',i10,' n_scripps = ',i10, & + ' n_triton = ',i10,' n_3mdiscus = ',i10) + end subroutine mbuoy_info + + subroutine mbuoyb_info(mype) +!************************************************************************** +! +! assign the depth dependent moored buoyb station ID +! + + integer(i_kind), intent(in) :: mype + allocate(cid_mbuoyb(n_3mdiscus)) +! +! initialize cid +! + cid_mbuoyb = ' ' +! +! COMPS moored buoy (depth = 1.2m) +! + cid_mbuoyb( 1) = '4200022' + cid_mbuoyb( 2) = '4200023' + cid_mbuoyb( 3) = '4200024' +! +! SCRIPPS moored buoy (depth = 0.45m) +! + cid_mbuoyb( 4) = '3100201' + cid_mbuoyb( 5) = '4100112' + cid_mbuoyb( 6) = '4100113' + cid_mbuoyb( 7) = '4100114' + cid_mbuoyb( 8) = '4200099' + cid_mbuoyb( 9) = '4600211' + cid_mbuoyb(10) = '4600212' + cid_mbuoyb(11) = '4600213' + cid_mbuoyb(12) = '4600214' + cid_mbuoyb(13) = '4600215' + cid_mbuoyb(14) = '4600216' + cid_mbuoyb(15) = '4600217' + cid_mbuoyb(16) = '4600218' + cid_mbuoyb(17) = '4600219' + cid_mbuoyb(18) = '4600220' + cid_mbuoyb(19) = '4600221' + cid_mbuoyb(10) = '4600222' + cid_mbuoyb(21) = '4600223' + cid_mbuoyb(22) = '4600224' + cid_mbuoyb(23) = '4600225' + cid_mbuoyb(24) = '4600226' + cid_mbuoyb(25) = '4600227' + cid_mbuoyb(26) = '4600228' + cid_mbuoyb(27) = '4600229' + cid_mbuoyb(28) = '4600230' + cid_mbuoyb(29) = '4600231' + cid_mbuoyb(30) = '4600232' + cid_mbuoyb(31) = '4600233' + cid_mbuoyb(32) = '4600234' + cid_mbuoyb(33) = '4600235' + cid_mbuoyb(34) = '4600236' + cid_mbuoyb(35) = '4600237' + cid_mbuoyb(36) = '4600238' + cid_mbuoyb(37) = '5100201' + cid_mbuoyb(38) = '5100202' + cid_mbuoyb(39) = '5100203' + cid_mbuoyb(40) = '5200200' +! +! TRITON buoys (depth = 1.5m) +! + cid_mbuoyb(41) = '5200071' + cid_mbuoyb(42) = '5200072' + cid_mbuoyb(43) = '5200073' + cid_mbuoyb(44) = '5200074' + cid_mbuoyb(45) = '5200075' + cid_mbuoyb(46) = '5200076' + cid_mbuoyb(47) = '5200077' + cid_mbuoyb(48) = '5200078' + cid_mbuoyb(49) = '5200079' + cid_mbuoyb(50) = '5200080' + cid_mbuoyb(51) = '5200081' + cid_mbuoyb(52) = '5200082' + cid_mbuoyb(53) = '5200083' + cid_mbuoyb(54) = '5200084' + cid_mbuoyb(55) = '5200085' + cid_mbuoyb(56) = '5200086' + cid_mbuoyb(57) = '5200087' + cid_mbuoyb(58) = '5200088' + cid_mbuoyb(59) = '5300056' + cid_mbuoyb(60) = '5300057' + cid_mbuoyb(61) = '5200043' + cid_mbuoyb(62) = '5200044' + cid_mbuoyb(63) = '5200045' + cid_mbuoyb(64) = '5200046' +! +! NDBC 3-meter buoy (depth = 0.6m) +! + cid_mbuoyb(71) = '4100004' + cid_mbuoyb(72) = '4100008' + cid_mbuoyb(73) = '4100012' + cid_mbuoyb(74) = '4100013' + cid_mbuoyb(75) = '4100025' + cid_mbuoyb(76) = '4100035' + cid_mbuoyb(77) = '4100036' + cid_mbuoyb(78) = '4200007' + cid_mbuoyb(79) = '4200019' + cid_mbuoyb(80) = '4200020' + cid_mbuoyb(81) = '4200035' + cid_mbuoyb(82) = '4200036' + cid_mbuoyb(83) = '4200039' + cid_mbuoyb(84) = '4200040' + cid_mbuoyb(85) = '4400007' + cid_mbuoyb(86) = '4400008' + cid_mbuoyb(87) = '4400009' + cid_mbuoyb(88) = '4400013' + cid_mbuoyb(89) = '4400014' + cid_mbuoyb(90) = '4400017' + cid_mbuoyb(91) = '4400018' + cid_mbuoyb(92) = '4400025' + cid_mbuoyb(93) = '4400027' + cid_mbuoyb(94) = '4500001' + cid_mbuoyb(95) = '4500002' + cid_mbuoyb(96) = '4500003' + cid_mbuoyb(97) = '4500004' + cid_mbuoyb(98) = '4500005' + cid_mbuoyb(99) = '4500006' + cid_mbuoyb(100) = '4500007' + cid_mbuoyb(101) = '4500008' + cid_mbuoyb(102) = '4500012' + cid_mbuoyb(103) = '4600011' + cid_mbuoyb(104) = '4600012' + cid_mbuoyb(105) = '4600013' + cid_mbuoyb(106) = '4600014' + cid_mbuoyb(107) = '4600015' + cid_mbuoyb(108) = '4600022' + cid_mbuoyb(109) = '4600025' + cid_mbuoyb(110) = '4600026' + cid_mbuoyb(111) = '4600027' + cid_mbuoyb(112) = '4600028' + cid_mbuoyb(113) = '4600029' + cid_mbuoyb(114) = '4600042' + cid_mbuoyb(115) = '4600047' + cid_mbuoyb(116) = '4600050' + cid_mbuoyb(117) = '4600053' + cid_mbuoyb(118) = '4600060' + cid_mbuoyb(119) = '4600063' + cid_mbuoyb(120) = '4600069' + cid_mbuoyb(121) = '4600081' + cid_mbuoyb(122) = '4600086' + cid_mbuoyb(123) = '4600087' + cid_mbuoyb(124) = '4600088' + cid_mbuoyb(125) = '4600089' + cid_mbuoyb(126) = '5100001' + cid_mbuoyb(127) = '5100028' +! +! Canadian 3-meter buoy (depth = 0.6m) +! + cid_mbuoyb(128) = '4400258' + cid_mbuoyb(129) = '4500132' + cid_mbuoyb(130) = '4500135' + cid_mbuoyb(131) = '4500136' + cid_mbuoyb(132) = '4500137' + cid_mbuoyb(133) = '4500138' + cid_mbuoyb(134) = '4500143' + cid_mbuoyb(135) = '4500144' + cid_mbuoyb(136) = '4500145' + cid_mbuoyb(137) = '4600131' + cid_mbuoyb(138) = '4600132' + cid_mbuoyb(139) = '4600134' + cid_mbuoyb(140) = '4600145' + cid_mbuoyb(141) = '4600146' + cid_mbuoyb(142) = '4600147' + cid_mbuoyb(143) = '4600181' + cid_mbuoyb(144) = '4600183' + cid_mbuoyb(145) = '4600185' + cid_mbuoyb(146) = '4600204' + cid_mbuoyb(147) = '4600205' + cid_mbuoyb(148) = '4600206' + cid_mbuoyb(149) = '4600207' + cid_mbuoyb(150) = '4600208' +! +! MBARI moored buoy (depth = 0.6m) +! + cid_mbuoyb(151) = '4600091' + cid_mbuoyb(152) = '4600092' + cid_mbuoyb(153) = '4600093' + + if(mype == 0) write(6,1000) n_comps,n_scripps,n_triton,n_3mdiscus +1000 format(' in mbuoyb_info,n_comps = ',i10,' n_scripps = ',i10, & + ' n_triton = ',i10,' n_3mdiscus = ',i10) + end subroutine mbuoyb_info + + subroutine read_ship_info(mype) + +! +! read ship info from an external file to determine the depth and instrument +! + integer(i_kind), intent(in) :: mype + + integer(i_kind) ios + logical iexist + + filename='insituinfo' + inquire(file=trim(filename),exist=iexist) + if(iexist) then + open(lunship,file=filename,form='formatted',iostat=ios) + allocate (ship%id(n_ship),ship%depth(n_ship),ship%sensor(n_ship)) + if(ios==0) then + do i = 1, n_ship + read(lunship,'(a10,f6.1,1x,a5)') ship%id(i),ship%depth(i),ship%sensor(i) + enddo + endif + else + n_ship=0 + allocate (ship%id(n_ship),ship%depth(n_ship),ship%sensor(n_ship)) + endif + + if(mype == 0) write(6,*) ' in read_ship_info, n_ship = ', n_ship + end subroutine read_ship_info +end module insitu_info diff --git a/src/intall.f90 b/src/gsi/intall.f90 similarity index 85% rename from src/intall.f90 rename to src/gsi/intall.f90 index 5867e2ecc..43c2b9f35 100644 --- a/src/intall.f90 +++ b/src/gsi/intall.f90 @@ -17,6 +17,9 @@ module intallmod ! 2015-09-03 guo - obsmod::yobs has been replaced with m_obsHeadBundle, ! where yobs is created and destroyed when and where it ! is needed. +! 2018-08-10 guo - removed obsHeadBundle references. +! - replaced intjo() related implementations with a new +! polymorphic implementation of intjomod::intjo(). ! ! subroutines included: ! sub intall @@ -152,6 +155,7 @@ subroutine intall(sval,sbias,rval,rbias) ! 2014-05-07 pondeca - Add RHS calculation for howv constraint ! 2014-06-17 carley/zhu - Add RHS calculation for lcbas constraint ! 2015-07-10 pondeca - Add RHS calculation for cldch constraint +! 2019-03-13 eliu - add precipitation component ! ! input argument list: ! sval - solution on grid @@ -175,25 +179,21 @@ subroutine intall(sval,sbias,rval,rbias) use kinds, only: i_kind,r_quad use gsi_4dvar, only: nobs_bins,ltlint,ibin_anl use constants, only: zero,zero_quad - use jcmod, only: ljcpdry,ljc4tlevs,ljcdfi + use jcmod, only: ljcpdry,ljc4tlevs,ljcdfi,ljclimqc use jfunc, only: nrclen,nsclen,npclen,ntclen - use intradmod, only: setrad use intjomod, only: intjo use bias_predictors, only : predictors,assignment(=) use state_vectors, only: allocate_state,deallocate_state use intjcmod, only: intlimq,intlimg,intlimv,intlimp,intlimw10m,intlimhowv,intlimcldch,& - intliml,intjcpdry1,intjcpdry2,intjcdfi + intliml,intjcpdry1,intjcpdry2,intjcdfi,intlimqc use timermod, only: timer_ini,timer_fnl use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) - use state_vectors, only: svars2d + use state_vectors, only: svars2d, svars3d use mpeu_util, only: getindex use guess_grids, only: ntguessig,nfldsig use mpl_allreducemod, only: mpl_allreduce - use m_obsHeadBundle, only: obsHeadBundle - use m_obsHeadBundle, only: obsHeadBundle_create - use m_obsHeadBundle, only: obsHeadBundle_destroy implicit none ! Declare passed variables @@ -201,15 +201,12 @@ subroutine intall(sval,sbias,rval,rbias) type(predictors), intent(in ) :: sbias type(gsi_bundle), intent(inout) :: rval(nobs_bins) type(predictors), intent(inout) :: rbias - real(r_quad),dimension(max(1,nrclen),nobs_bins) :: qpred_bin real(r_quad),dimension(max(1,nrclen)) :: qpred real(r_quad),dimension(2*nobs_bins) :: mass ! Declare local variables integer(i_kind) :: ibin,ii,it,i - type(obsHeadBundle),pointer,dimension(:):: yobs - !****************************************************************************** ! Initialize timer call timer_ini('intall') @@ -220,22 +217,10 @@ subroutine intall(sval,sbias,rval,rbias) rval(ii)=zero enddo -! Compute RHS in physical space - call setrad(sval(1)) - qpred_bin=zero_quad - call obsHeadBundle_create(yobs,nobs_bins) -! RHS for Jo -!$omp parallel do schedule(dynamic,1) private(ibin) - do ibin=1,size(yobs) ! == nobs_bins - call intjo(yobs(ibin),rval(ibin),qpred_bin(:,ibin),sval(ibin),sbias,ibin) - end do qpred=zero_quad - do ibin=1,size(yobs) ! == nobs_bins - do i=1,nrclen - qpred(i)=qpred(i)+qpred_bin(i,ibin) - end do - end do - call obsHeadBundle_destroy(yobs) + +! Compute RHS in physical space (rval,qpred) + call intjo(rval,qpred,sval,sbias) if(.not.ltlint)then ! RHS for moisture constraint @@ -251,7 +236,28 @@ subroutine intall(sval,sbias,rval,rbias) call intlimq(rval(ibin),sval(ibin),it) end do end if - + if (ljclimqc) then + if (.not.ljc4tlevs) then + if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'ql') + if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qi') + if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qr') + if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qs') + if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qg') + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin),sval(ibin),it,'ql') + if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin),sval(ibin),it,'qi') + if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin),sval(ibin),it,'qr') + if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin),sval(ibin),it,'qs') + if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin),sval(ibin),it,'qg') + end do + end if + end if ! ljclimqc ! RHS for gust constraint if (getindex(svars2d,'gust')>0)call intlimg(rval(1),sval(1)) diff --git a/src/intaod.f90 b/src/gsi/intaod.f90 similarity index 94% rename from src/intaod.f90 rename to src/gsi/intaod.f90 index c08ebb0a8..c55e59e33 100644 --- a/src/intaod.f90 +++ b/src/gsi/intaod.f90 @@ -73,6 +73,7 @@ subroutine intaod_(aerohead,rval,sval) use gsi_bundlemod, only: gsi_bundleputvar use gsi_chemguess_mod, only: gsi_chemguess_get use mpeu_util, only: getindex + use m_obsdiagNode, only: obsdiagNode_set implicit none ! Declare passed variables @@ -153,9 +154,11 @@ subroutine intaod_(aerohead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then val = val*aeroptr%err2(nn)*aeroptr%raterr2(nn) - aeroptr%diags(nn)%ptr%obssen(jiter) = val + !-- aeroptr%diags(nn)%ptr%obssen(jiter) = val + call obsdiagNode_set(aeroptr%diags(nn)%ptr,jiter=jiter,obssen=val) else - if (aeroptr%luse) aeroptr%diags(nn)%ptr%tldepart(jiter) = val + !-- if (aeroptr%luse) aeroptr%diags(nn)%ptr%tldepart(jiter) = val + if (aeroptr%luse) call obsdiagNode_set(aeroptr%diags(nn)%ptr,jiter=jiter,tldepart=val) endif endif diff --git a/src/intcldch.f90 b/src/gsi/intcldch.f90 similarity index 92% rename from src/intcldch.f90 rename to src/gsi/intcldch.f90 index 2d957a7a8..ca75f5736 100644 --- a/src/intcldch.f90 +++ b/src/gsi/intcldch.f90 @@ -25,6 +25,7 @@ module intcldchmod use m_cldchNode, only: cldchNode use m_cldchNode, only: cldchNode_typecast use m_cldchNode, only: cldchNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -110,9 +111,11 @@ subroutine intcldch(cldchhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*cldchptr%raterr2*cldchptr%err2 - cldchptr%diags%obssen(jiter) = grad + !-- cldchptr%diags%obssen(jiter) = grad + call obsdiagNode_set(cldchptr%diags,jiter=jiter,obssen=grad) else - if (cldchptr%luse) cldchptr%diags%tldepart(jiter)=val + !-- if (cldchptr%luse) cldchptr%diags%tldepart(jiter)=val + if (cldchptr%luse) call obsdiagNode_set(cldchptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intco.f90 b/src/gsi/intco.f90 similarity index 95% rename from src/intco.f90 rename to src/gsi/intco.f90 index a8905db60..d67a36112 100644 --- a/src/intco.f90 +++ b/src/gsi/intco.f90 @@ -32,6 +32,7 @@ module intcomod use m_colvkNode , only: colvkNode use m_colvkNode , only: colvkNode_typecast use m_colvkNode , only: colvkNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -222,9 +223,11 @@ subroutine intcolev_(colvkhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then valx=val1*colvkptr%err2(k)*colvkptr%raterr2(k) - colvkptr%diags(k)%ptr%obssen(jiter)=valx + !-- colvkptr%diags(k)%ptr%obssen(jiter)=valx + call obsdiagNode_set(colvkptr%diags(k)%ptr,jiter=jiter,obssen=real(valx,r_kind)) else - if (colvkptr%luse) colvkptr%diags(k)%ptr%tldepart(jiter)=val1 + !-- if (colvkptr%luse) colvkptr%diags(k)%ptr%tldepart(jiter)=val1 + if (colvkptr%luse) call obsdiagNode_set(colvkptr%diags(k)%ptr,tldepart=real(val1,r_kind)) endif endif diff --git a/src/gsi/intdbz.f90 b/src/gsi/intdbz.f90 new file mode 100644 index 000000000..aa225aa83 --- /dev/null +++ b/src/gsi/intdbz.f90 @@ -0,0 +1,257 @@ +module intdbzmod +!$$$ module documentation block +! . . . . +! module: intdbzmod module for intdbz and its tangent linear intdbz_tl +! prgmmr: +! +! abstract: module for intdbz and its tangent linear intdbz_tl +! +! program history log: +! 2017-05-12 Y. Wang and X. Wang - add tangent linear of dbz operator to directly assimilate reflectivity +! for both ARW and NMMB models (Wang and Wang 2017 MWR). POC: xuguang.wang@ou.edu +! 2019-07-11 todling - introduced wrf_vars_mod +! +! subroutines included: +! sub intdbz_ +! +! variable definitions: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use m_obsNode, only: obsNode +use m_dbzNode, only: dbzNode +use m_dbzNode, only: dbzNode_typecast +use m_dbzNode, only: dbzNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set +implicit none + +PRIVATE +PUBLIC intdbz + +interface intdbz; module procedure & + intdbz_ +end interface + +contains + +subroutine intdbz_(dbzhead,rval,sval) +!$$$ subprogram documentation block +! . . . . +! subprogram: intdbz apply nonlin qc operator for radar reflectivity +! prgmmr: derber org: np23 date: 1991-02-26 +! +! abstract: apply observation operator for radar winds +! with nonlinear qc operator +! +! program history log: +! 1991-02-26 derber +! 1999-11-22 yang +! 2004-08-02 treadon - add only to module use, add intent in/out +! 2004-10-08 parrish - add nonlinear qc option +! 2005-03-01 parrish - nonlinear qc change to account for inflated obs error +! 2005-04-11 treadon - merge intdbz and intdbz_qc into single routine +! 2005-08-02 derber - modify for variational qc parameters for each ob +! 2005-09-28 derber - consolidate location and weight arrays +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - unify NL qc +! 2007-02-15 rancic - add foto +! 2007-03-19 tremolet - binning of observations +! 2007-06-05 tremolet - use observation diagnostics structure +! 2007-07-09 tremolet - observation sensitivity +! 2008-01-04 tremolet - Don't apply H^T if l_do_adjoint is false +! 2008-11-28 todling - turn FOTO optional; changed ptr%time handle +! 2010-05-13 todlng - update to use gsi_bundle; update interface +! 2012-09-14 Syed RH Rizvi, NCAR/NESL/MMM/DAS - introduced ladtest_obs +! 2014-12-03 derber - modify so that use of obsdiags can be turned off +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind + use constants, only: half,one,tiny_r_kind,cg_term,r3600 + use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag + use qcmod, only: nlnqc_iter,varqc_iter + use gridmod, only: wrf_mass_regional + use jfunc, only: jiter + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_4dvar, only: ladtest_obs + + use wrf_vars_mod, only : dbz_exist + implicit none + +! Declare passed variables + class(obsNode), pointer, intent(in ) :: dbzhead + type(gsi_bundle), intent(in ) :: sval + type(gsi_bundle), intent(inout) :: rval + +! Declare local varibles + integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus +! real(r_kind) penalty + real(r_kind) val,w1,w2,w3,w4,w5,w6,w7,w8,valqr,valqs,valqg,valdbz + real(r_kind) cg_dbz,p0,grad,wnotgross,wgross,pg_dbz + real(r_kind) qrtl,qstl, qgtl + real(r_kind),pointer,dimension(:) :: sqr,sqs,sqg,sdbz + real(r_kind),pointer,dimension(:) :: rqr,rqs,rqg,rdbz + type(dbzNode), pointer :: dbzptr + +! If no dbz data return + if(.not. associated(dbzhead))return + +! Retrieve pointers +! Simply return if any pointer not found + ier=0 + if(dbz_exist)then + call gsi_bundlegetpointer(sval,'dbz',sdbz,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'dbz',rdbz,istatus);ier=istatus+ier + else + call gsi_bundlegetpointer(sval,'qr',sqr,istatus);ier=istatus+ier + if (wrf_mass_regional) then + call gsi_bundlegetpointer(sval,'qs',sqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qg',sqg,istatus);ier=istatus+ier + end if + + call gsi_bundlegetpointer(rval,'qr',rqr,istatus);ier=istatus+ier + if (wrf_mass_regional) then + call gsi_bundlegetpointer(rval,'qs',rqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qg',rqg,istatus);ier=istatus+ier + end if + end if + + if(ier/=0)return + + + dbzptr => dbzNode_typecast(dbzhead) + do while (associated(dbzptr)) + j1=dbzptr%ij(1) + j2=dbzptr%ij(2) + j3=dbzptr%ij(3) + j4=dbzptr%ij(4) + j5=dbzptr%ij(5) + j6=dbzptr%ij(6) + j7=dbzptr%ij(7) + j8=dbzptr%ij(8) + w1=dbzptr%wij(1) + w2=dbzptr%wij(2) + w3=dbzptr%wij(3) + w4=dbzptr%wij(4) + w5=dbzptr%wij(5) + w6=dbzptr%wij(6) + w7=dbzptr%wij(7) + w8=dbzptr%wij(8) + + +! Forward mode l + if( dbz_exist )then + val = w1* sdbz(j1)+w2* sdbz(j2)+w3* sdbz(j3)+w4* sdbz(j4)+ & + w5* sdbz(j5)+w6* sdbz(j6)+w7* sdbz(j7)+w8* sdbz(j8) + else + qrtl = w1* sqr(j1)+w2* sqr(j2)+w3* sqr(j3)+w4* sqr(j4)+ & + w5* sqr(j5)+w6* sqr(j6)+w7* sqr(j7)+w8* sqr(j8) + if ( wrf_mass_regional )then + qstl = w1* sqs(j1)+w2* sqs(j2)+w3* sqs(j3)+w4* sqs(j4)+ & + w5* sqs(j5)+w6* sqs(j6)+w7* sqs(j7)+w8* sqs(j8) + + qgtl = w1* sqg(j1)+w2* sqg(j2)+w3* sqg(j3)+w4* sqg(j4)+ & + w5* sqg(j5)+w6* sqg(j6)+w7* sqg(j7)+w8* sqg(j8) + + val = (dbzptr%jqr)*qrtl + (dbzptr%jqs)*qstl + (dbzptr%jqg)*qgtl + end if + + end if + + if(luse_obsdiag)then + if (lsaveobsens) then + grad = val*dbzptr%raterr2*dbzptr%err2 + !-- dbzptr%diags%obssen(jiter) = grad + call obsdiagNode_set(dbzptr%diags,jiter=jiter,obssen=grad) + + else + !-- if (dbzptr%luse) dbzptr%diags%tldepart(jiter)=val + if (dbzptr%luse) call obsdiagNode_set(dbzptr%diags,jiter=jiter,tldepart=val) + endif + endif + + if (l_do_adjoint) then + if (.not. lsaveobsens) then + if( .not. ladtest_obs ) val=val-dbzptr%res + +! gradient of nonlinear operator + if (nlnqc_iter .and. dbzptr%pg > tiny_r_kind .and. & + dbzptr%b > tiny_r_kind) then + pg_dbz=dbzptr%pg*varqc_iter + cg_dbz=cg_term/dbzptr%b + wnotgross= one-pg_dbz + wgross = pg_dbz*cg_dbz/wnotgross + p0 = wgross/(wgross+exp(-half*dbzptr%err2*val**2)) + val = val*(one-p0) + endif + + if( ladtest_obs) then + grad = val + else + grad = val*dbzptr%raterr2*dbzptr%err2 + end if + + endif + +! Adjoint + if(dbz_exist)then + valdbz = grad + rdbz(j1)=rdbz(j1)+w1*valdbz + rdbz(j2)=rdbz(j2)+w2*valdbz + rdbz(j3)=rdbz(j3)+w3*valdbz + rdbz(j4)=rdbz(j4)+w4*valdbz + rdbz(j5)=rdbz(j5)+w5*valdbz + rdbz(j6)=rdbz(j6)+w6*valdbz + rdbz(j7)=rdbz(j7)+w7*valdbz + rdbz(j8)=rdbz(j8)+w8*valdbz + else + valqr = dbzptr%jqr*grad + rqr(j1)=rqr(j1)+w1*valqr + rqr(j2)=rqr(j2)+w2*valqr + rqr(j3)=rqr(j3)+w3*valqr + rqr(j4)=rqr(j4)+w4*valqr + rqr(j5)=rqr(j5)+w5*valqr + rqr(j6)=rqr(j6)+w6*valqr + rqr(j7)=rqr(j7)+w7*valqr + rqr(j8)=rqr(j8)+w8*valqr + if ( wrf_mass_regional )then + valqs=dbzptr%jqs*grad + valqg=dbzptr%jqg*grad + + rqs(j1)=rqs(j1)+w1*valqs + rqs(j2)=rqs(j2)+w2*valqs + rqs(j3)=rqs(j3)+w3*valqs + rqs(j4)=rqs(j4)+w4*valqs + rqs(j5)=rqs(j5)+w5*valqs + rqs(j6)=rqs(j6)+w6*valqs + rqs(j7)=rqs(j7)+w7*valqs + rqs(j8)=rqs(j8)+w8*valqs + + rqg(j1)=rqg(j1)+w1*valqg + rqg(j2)=rqg(j2)+w2*valqg + rqg(j3)=rqg(j3)+w3*valqg + rqg(j4)=rqg(j4)+w4*valqg + rqg(j5)=rqg(j5)+w5*valqg + rqg(j6)=rqg(j6)+w6*valqg + rqg(j7)=rqg(j7)+w7*valqg + rqg(j8)=rqg(j8)+w8*valqg + end if + end if + + endif + + !dbzptr => dbzptr%llpoint + dbzptr => dbzNode_nextcast(dbzptr) + end do + return +end subroutine intdbz_ + +end module intdbzmod diff --git a/src/intdw.f90 b/src/gsi/intdw.f90 similarity index 95% rename from src/intdw.f90 rename to src/gsi/intdw.f90 index 796a32bdb..ba2f973dc 100644 --- a/src/intdw.f90 +++ b/src/gsi/intdw.f90 @@ -30,6 +30,7 @@ module intdwmod use m_dwNode , only: dwNode use m_dwNode , only: dwNode_typecast use m_dwNode , only: dwNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -152,9 +153,11 @@ subroutine intdw_(dwhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val * dwptr%raterr2 * dwptr%err2 - dwptr%diags%obssen(jiter) = grad + !-- dwptr%diags%obssen(jiter) = grad + call obsdiagNode_set(dwptr%diags,jiter=jiter,obssen=grad) else - if (dwptr%luse) dwptr%diags%tldepart(jiter)=val + !-- if (dwptr%luse) dwptr%diags%tldepart(jiter)=val + if (dwptr%luse) call obsdiagNode_set(dwptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intgps.f90 b/src/gsi/intgps.f90 similarity index 96% rename from src/intgps.f90 rename to src/gsi/intgps.f90 index 6842223bb..bc78db085 100644 --- a/src/intgps.f90 +++ b/src/gsi/intgps.f90 @@ -29,6 +29,7 @@ module intgpsmod use m_gpsNode, only: gpsNode use m_gpsNode, only: gpsNode_typecast use m_gpsNode, only: gpsNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -168,9 +169,11 @@ subroutine intgps_(gpshead,rval,sval) if (luse_obsdiag)then if (lsaveobsens) then grad = val*gpsptr%raterr2*gpsptr%err2 - gpsptr%diags%obssen(jiter) = grad + !-- gpsptr%diags%obssen(jiter) = grad + call obsdiagNode_set(gpsptr%diags,jiter=jiter,obssen=grad) else - if (gpsptr%luse) gpsptr%diags%tldepart(jiter)=val + !-- if (gpsptr%luse) gpsptr%diags%tldepart(jiter)=val + if (gpsptr%luse) call obsdiagNode_set(gpsptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intgust.f90 b/src/gsi/intgust.f90 similarity index 93% rename from src/intgust.f90 rename to src/gsi/intgust.f90 index 8165481c3..6e34a6526 100644 --- a/src/intgust.f90 +++ b/src/gsi/intgust.f90 @@ -25,6 +25,7 @@ module intgustmod use m_gustNode, only: gustNode use m_gustNode, only: gustNode_typecast use m_gustNode, only: gustNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -111,9 +112,11 @@ subroutine intgust(gusthead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*gustptr%raterr2*gustptr%err2 - gustptr%diags%obssen(jiter) = grad + !-- gustptr%diags%obssen(jiter) = grad + call obsdiagNode_set(gustptr%diags,jiter=jiter,obssen=grad) else - if (gustptr%luse) gustptr%diags%tldepart(jiter)=val + !-- if (gustptr%luse) gustptr%diags%tldepart(jiter)=val + if (gustptr%luse) call obsdiagNode_set(gustptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/inthowv.f90 b/src/gsi/inthowv.f90 similarity index 93% rename from src/inthowv.f90 rename to src/gsi/inthowv.f90 index dd1c95fc6..381baf723 100644 --- a/src/inthowv.f90 +++ b/src/gsi/inthowv.f90 @@ -25,6 +25,7 @@ module inthowvmod use m_howvNode, only: howvNode use m_howvNode, only: howvNode_typecast use m_howvNode, only: howvNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -111,9 +112,11 @@ subroutine inthowv(howvhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*howvptr%raterr2*howvptr%err2 - howvptr%diags%obssen(jiter) = grad + !-- howvptr%diags%obssen(jiter) = grad + call obsdiagNode_set(howvptr%diags,jiter=jiter,obssen=grad) else - if (howvptr%luse) howvptr%diags%tldepart(jiter)=val + !-- if (howvptr%luse) howvptr%diags%tldepart(jiter)=val + if (howvptr%luse) call obsdiagNode_set(howvptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intjcmod.f90 b/src/gsi/intjcmod.f90 similarity index 80% rename from src/intjcmod.f90 rename to src/gsi/intjcmod.f90 index f4a892f83..d264cd4b5 100644 --- a/src/intjcmod.f90 +++ b/src/gsi/intjcmod.f90 @@ -13,6 +13,9 @@ module intjcmod ! 2014-05-07 pondeca - add weak constraint subroutine for howv ! 2014-06-17 carley/zhu - add intliml for lcbas + some cleanup ! 2015-07-10 pondeca - add weak constraint subroutine for cldch +! 2019-03-05 martin - update intlimq to weight factqmin/max by latitude +! 2019-03-14 eliu - add intlimqc to constraint negative hydrometeors +! 2019-03-14 eliu - add precipitation components in various constraints ! ! subroutines included: ! @@ -28,7 +31,7 @@ module intjcmod implicit none PRIVATE -PUBLIC intlimq,intlimg,intlimp,intlimv,intlimw10m,intlimhowv,intliml,intlimcldch,intjcdfi,intjcpdry,intjcpdry1,intjcpdry2 +PUBLIC intlimqc,intlimq,intlimg,intlimp,intlimv,intlimw10m,intlimhowv,intliml,intlimcldch,intjcdfi,intjcpdry,intjcpdry1,intjcpdry2 contains @@ -51,6 +54,7 @@ subroutine intlimq(rval,sval,itbin) ! 2008-06-02 safford - rm unused vars ! 2010-05-13 todling - update to use gsi_bundle ! 2011-12-27 kleist - add multiple time level capability (for 4densvar option) +! 2019-03-05 martin - update to weight factqmin/max by latitude ! ! input argument list: ! sq - increment in grid space @@ -66,10 +70,11 @@ subroutine intlimq(rval,sval,itbin) ! machine: ibm RS/6000 SP ! !$$$ - use gridmod, only: nsig,lat1,lon1 + use gridmod, only: nsig,lat1,lon1,istart,wgtfactlats use jfunc, only: factqmin,factqmax use gsi_metguess_mod, only: gsi_metguess_bundle use guess_grids, only: ges_qsat + use mpimod, only: mype implicit none ! Declare passed variables @@ -78,13 +83,15 @@ subroutine intlimq(rval,sval,itbin) integer, intent(in) :: itbin ! Declare local variables - integer(i_kind) i,j,k,ier,istatus + integer(i_kind) i,j,k,ier,istatus,ii,mm1 real(r_kind) q real(r_kind),pointer,dimension(:,:,:) :: sq=>NULL() real(r_kind),pointer,dimension(:,:,:) :: rq=>NULL() real(r_kind),pointer,dimension(:,:,:) :: ges_q_it=>NULL() if (factqmin==zero .and. factqmax==zero) return + + mm1=mype+1 ! Retrieve pointers ! Simply return if any pointer not found @@ -100,15 +107,17 @@ subroutine intlimq(rval,sval,itbin) do k = 1,nsig do j = 2,lon1+1 do i = 2,lat1+1 + ii=istart(mm1)+i-2 q = ges_q_it(i,j,k) + sq(i,j,k) ! Lower constraint limit if (q < zero) then - rq(i,j,k) = rq(i,j,k) + factqmin*q/(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) + rq(i,j,k) = rq(i,j,k) + (factqmin*wgtfactlats(ii))*q & + /(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) ! Upper constraint limit else if (q > ges_qsat(i,j,k,itbin)) then - rq(i,j,k) = rq(i,j,k) + factqmax*(q-ges_qsat(i,j,k,itbin))/ & + rq(i,j,k) = rq(i,j,k) + (factqmax*wgtfactlats(ii))*(q-ges_qsat(i,j,k,itbin))/ & (ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) end if @@ -118,7 +127,106 @@ subroutine intlimq(rval,sval,itbin) return end subroutine intlimq +subroutine intlimqc(rval,sval,itbin,cldtype) +!$$$ subprogram documentation block +! . . . . +! subprogram: intlimqc +! prgmmr: eliu org: np23 date: 2018-05-19 +! +! abstract: limit negative hydrometeors as a weak constraint +! +! program history log: +! 2018-05-19 eliu +! +! input argument list: +! sqc - increment in grid space +! itbin - observation bin (time level) +! +! output argument list: +! rqc - results from limiting operator +! +! remarks: see modules used +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpimod, only: mype + use gridmod, only: nsig,lat1,lon1 + use jfunc, only: factql,factqi,factqr,factqs,factqg + use gsi_metguess_mod, only: gsi_metguess_bundle + use guess_grids, only: ges_qsat + implicit none + +! Declare passed variables + type(gsi_bundle),intent(in ) :: sval + type(gsi_bundle),intent(inout) :: rval + integer(i_kind), intent(in) :: itbin + character(2), intent(in) :: cldtype + +! Declare local variables + integer(i_kind) i,j,k,ier,ier1,istatus + real(r_kind) qc + real(r_kind) factqc + real(r_kind),pointer,dimension(:,:,:) :: sqc=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: rqc=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: ges_qc_it=>NULL() + + ier=0 + ier1=0 + if (trim(cldtype) == 'ql') then + factqc = factql + call gsi_bundlegetpointer(sval,'ql',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'ql',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'ql',ges_qc_it,ier1) + endif + if (trim(cldtype) == 'qi') then + factqc = factqi + call gsi_bundlegetpointer(sval,'qi',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qi',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qi',ges_qc_it,ier1) + endif + if (trim(cldtype) == 'qr') then + factqc = factqr + call gsi_bundlegetpointer(sval,'qr',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qr',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qr',ges_qc_it,ier1) + endif + if (trim(cldtype) == 'qs') then + factqc = factqs + call gsi_bundlegetpointer(sval,'qs',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qs',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qs',ges_qc_it,ier1) + endif + if (trim(cldtype) == 'qg') then + factqc = factqg + call gsi_bundlegetpointer(sval,'qg',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qg',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qg',ges_qc_it,ier1) + endif + if (mype==0) write(6,*) 'intlimqc: factqc = ', factqc + if (mype==0) write(6,*) 'intlimqc: ier ier1= ', ier, ier1 + if (factqc == zero) return + if (ier/=0 .or. ier1/=0) return + +!$omp parallel do schedule(dynamic,1) private(k,j,i,qc) + do k = 1,nsig + do j = 2,lon1+1 + do i = 2,lat1+1 + qc = ges_qc_it(i,j,k) + sqc(i,j,k) + +! Lower constraint limit + if (qc < zero) then + rqc(i,j,k) = rqc(i,j,k) + factqc*qc/(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) + end if + end do + end do + end do + + return +end subroutine intlimqc subroutine intlimg(rval,sval) !$$$ subprogram documentation block ! . . . . @@ -748,6 +856,7 @@ subroutine intjcpdry1(sval,nbins,mass) ! 2013-05-05 todling - separate dry mass from the rest (zero-diff change) ! collapse two verions of this routine into one (add opt arg) ! 2014-12-02 derber - fix comments - break up into 2 parts to minimize +! 2018-04-16 eliu - add controbution from precipitating hydrometeors ! communications ! ! input argument list: @@ -776,11 +885,16 @@ subroutine intjcpdry1(sval,nbins,mass) ! Declare local variables real(r_quad),dimension(nsig) :: mass2 real(r_quad) rcon,con - integer(i_kind) i,j,k,it,ii,mm1,ier,icw,iql,iqi,istatus + integer(i_kind) i,j,k,it,ii,mm1,icw,iql,iqi + integer(i_kind) iq,iqr,iqs,iqg,iqh,ips real(r_kind),pointer,dimension(:,:,:) :: sq =>NULL() real(r_kind),pointer,dimension(:,:,:) :: sc =>NULL() real(r_kind),pointer,dimension(:,:,:) :: sql=>NULL() real(r_kind),pointer,dimension(:,:,:) :: sqi=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: sqr=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: sqs=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: sqg=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: sqh=>NULL() real(r_kind),pointer,dimension(:,:) :: sp =>NULL() integer(i_kind) :: n @@ -793,18 +907,22 @@ subroutine intjcpdry1(sval,nbins,mass) do n=1,nbins ! Retrieve pointers ! Simply return if any pointer not found - ier=0; icw=0; iql=0; iqi=0 - call gsi_bundlegetpointer(sval(n),'q' ,sq, istatus);ier=istatus+ier - call gsi_bundlegetpointer(sval(n),'cw',sc, istatus);icw=istatus+icw - call gsi_bundlegetpointer(sval(n),'ql',sql,istatus);iql=istatus+iql - call gsi_bundlegetpointer(sval(n),'qi',sqi,istatus);iqi=istatus+iqi - call gsi_bundlegetpointer(sval(n),'ps',sp, istatus);ier=istatus+ier - if(ier+icw*(iql+iqi)/=0)then - if (mype==0) write(6,*)'intjcpdry: checking ier+icw*(iql+iqi)=', ier+icw*(iql+iqi) + iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0 + call gsi_bundlegetpointer(sval(n),'q' ,sq, iq ) + call gsi_bundlegetpointer(sval(n),'cw',sc, icw ) + call gsi_bundlegetpointer(sval(n),'ql',sql, iql ) + call gsi_bundlegetpointer(sval(n),'qi',sqi, iqi ) + call gsi_bundlegetpointer(sval(n),'qr',sqr, iqr ) + call gsi_bundlegetpointer(sval(n),'qs',sqs, iqs ) + call gsi_bundlegetpointer(sval(n),'qg',sqg, iqg ) + call gsi_bundlegetpointer(sval(n),'qh',sqh, iqh ) + call gsi_bundlegetpointer(sval(n),'ps',sp, ips ) + if ( iq*ips/=0 .or. icw*(iql+iqi)/=0 ) then + if (mype==0) write(6,*)'intjcpdry1: warning - missing some required variables' + if (mype==0) write(6,*)'intjcpdry1: constraint for dry mass constraint not performed' return end if - ! Calculate mean surface pressure contribution in subdomain do j=2,lon2-1 do i=2,lat2-1 @@ -826,6 +944,10 @@ subroutine intjcpdry1(sval,nbins,mass) mass2(k)=mass2(k)+sc(i,j,k)*con else mass2(k)=mass2(k)+(sql(i,j,k)+sqi(i,j,k))*con + if (iqr==0) mass2(k)=mass2(k)+sqr(i,j,k)*con + if (iqs==0) mass2(k)=mass2(k)+sqs(i,j,k)*con + if (iqg==0) mass2(k)=mass2(k)+sqg(i,j,k)*con + if (iqh==0) mass2(k)=mass2(k)+sqh(i,j,k)*con endif end do end do @@ -854,6 +976,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) ! 2013-05-05 todling - separate dry mass from the rest (zero-diff change) ! collapse two verions of this routine into one (add opt arg) ! 2014-12-02 derber - fix comments - break up into 2 parts to minimize +! 2018-04-16 eliu - add controbution from precipitating hydrometeors ! communications ! ! input argument list: @@ -885,11 +1008,16 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) ! Declare local variables real(r_quad) rcon,con,dmass - integer(i_kind) i,j,k,it,ii,mm1,ier,icw,iql,iqi,istatus + integer(i_kind) i,j,k,it,ii,mm1,icw,iql,iqi + integer(i_kind) iq,iqr,iqs,iqg,iqh,ips real(r_kind),pointer,dimension(:,:,:) :: rq =>NULL() real(r_kind),pointer,dimension(:,:,:) :: rc =>NULL() real(r_kind),pointer,dimension(:,:,:) :: rql=>NULL() real(r_kind),pointer,dimension(:,:,:) :: rqi=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: rqr=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: rqs=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: rqg=>NULL() + real(r_kind),pointer,dimension(:,:,:) :: rqh=>NULL() real(r_kind),pointer,dimension(:,:) :: rp =>NULL() integer(i_kind) :: n @@ -899,14 +1027,19 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) mm1=mype+1 do n=1,nbins - ier=0; icw=0; iql=0; iqi=0 - call gsi_bundlegetpointer(rval(n),'q' ,rq, istatus);ier=istatus+ier - call gsi_bundlegetpointer(rval(n),'cw',rc, istatus);icw=istatus+icw - call gsi_bundlegetpointer(rval(n),'ql',rql,istatus);iql=istatus+iql - call gsi_bundlegetpointer(rval(n),'qi',rqi,istatus);iqi=istatus+iqi - call gsi_bundlegetpointer(rval(n),'ps',rp, istatus);ier=istatus+ier - if(ier+icw*(iql+iqi)/=0)then - if (mype==0) write(6,*)'intjcpdry: checking ier+icw*(iql+iqi)=', ier+icw*(iql+iqi) + iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0 + call gsi_bundlegetpointer(rval(n),'q' ,rq, iq ) + call gsi_bundlegetpointer(rval(n),'cw',rc, icw ) + call gsi_bundlegetpointer(rval(n),'ql',rql, iql ) + call gsi_bundlegetpointer(rval(n),'qi',rqi, iqi ) + call gsi_bundlegetpointer(rval(n),'qr',rqr, iqr ) + call gsi_bundlegetpointer(rval(n),'qs',rqs, iqs ) + call gsi_bundlegetpointer(rval(n),'qg',rqg, iqg ) + call gsi_bundlegetpointer(rval(n),'qh',rqh, iqh ) + call gsi_bundlegetpointer(rval(n),'ps',rp, ips ) + if( iq*ips /=0 .or. icw*(iql+iqi) /=0 ) then + if (mype==0) write(6,*)'intjcpdry2: warning - missing some required variables' + if (mype==0) write(6,*)'intjcpdry2: constraint for dry mass constraint not performed' return end if ! Remove water-vapor contribution to get incremental dry ps @@ -938,6 +1071,10 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) else rql(i,j,k)=rql(i,j,k)-con rqi(i,j,k)=rqi(i,j,k)-con + if (iqr==0) rqr(i,j,k)=rqr(i,j,k)-con + if (iqs==0) rqs(i,j,k)=rqs(i,j,k)-con + if (iqg==0) rqg(i,j,k)=rqg(i,j,k)-con + if (iqh==0) rqh(i,j,k)=rqh(i,j,k)-con endif end do end do diff --git a/src/gsi/intjo.f90 b/src/gsi/intjo.f90 new file mode 100644 index 000000000..e514a38a2 --- /dev/null +++ b/src/gsi/intjo.f90 @@ -0,0 +1,336 @@ +module intjomod +!$$$ module documentation block +! . . . . +! module: intjo module for intjo +! prgmmr: +! +! abstract: module for H'R^{-1}H +! +! program history log: +! 2008-12-01 Todling - wrap in module +! 2009-08-13 lueken - update documentation +! 2015-09-03 guo - obsmod::obs_handle has been replaced with obsHeadBundle, +! defined by m_obsHeadBundle. +! 2016-08-29 J Guo - Separated calls to intozlay() and intozlev() +! 2018-08-10 guo - a new generic intjo() implementation replaced type +! specific intXYZ() calls with polymorphic %intjo(). +! +! subroutines included: +! sub intjo_ +! +! variable definitions: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use gsi_obOperTypeManager, only: obOper_count +use gsi_obOperTypeManager, only: obOper_typeInfo +use gsi_obOperTypeManager, only: & + iobOper_t, iobOper_pw, iobOper_q, & + iobOper_cldtot, iobOper_w, iobOper_dw, & + iobOper_rw, iobOper_dbz, & + iobOper_spd, iobOper_oz, iobOper_o3l, iobOper_colvk, & + iobOper_pm2_5, iobOper_pm10, iobOper_ps, iobOper_tcp, iobOper_sst, & + iobOper_gpsbend, iobOper_gpsref, & + iobOper_rad, iobOper_pcp, iobOper_aero, iobOper_gust, & + iobOper_vis, iobOper_pblh, iobOper_wspd10m, iobOper_td2m, iobOper_mxtm, & + iobOper_mitm, iobOper_pmsl, iobOper_howv, iobOper_tcamt, iobOper_lcbas, & + iobOper_cldch, iobOper_uwnd10m, iobOper_vwnd10m, iobOper_swcp, iobOper_lwcp, & + iobOper_light +use kinds, only: i_kind +use mpeu_util, only: perr,die + +implicit none + +PRIVATE +PUBLIC intjo + +interface intjo; module procedure & + intjo_, intjo_reduced_ +end interface + +! This is a mapping to the exact %intjo() calling sequence in the earlier +! non-polymorphic implementation, to reproduce the exactly same summation +! ordering for rval and qpred. It is not necessary, and can be removed once +! some non-zero-diff modifications are introduced. + +integer(i_kind),parameter,dimension(obOper_count):: ix_obtype = (/ & + iobOper_t, iobOper_pw, iobOper_q, & + iobOper_cldtot, iobOper_w, iobOper_dw, & + iobOper_rw, iobOper_dbz, & + iobOper_spd, iobOper_oz, iobOper_o3l, iobOper_colvk, & + iobOper_pm2_5, iobOper_pm10, iobOper_ps, iobOper_tcp, iobOper_sst, & + iobOper_gpsbend, iobOper_gpsref, & + iobOper_rad, iobOper_pcp, iobOper_aero, iobOper_gust, & + iobOper_vis, iobOper_pblh, iobOper_wspd10m, iobOper_td2m, iobOper_mxtm, & + iobOper_mitm, iobOper_pmsl, iobOper_howv, iobOper_tcamt, iobOper_lcbas, & + iobOper_cldch, iobOper_uwnd10m, iobOper_vwnd10m, iobOper_swcp, iobOper_lwcp, & + iobOper_light /) +!...|....1....|....2....|....3....|....4....|....5....|....6....|....7....|....8....|....9....|....0 + +character(len=*),parameter:: myname="intjomod" + +contains + +subroutine intjo_(rval,qpred,sval,sbias) + +!$$$ subprogram documentation block +! . . . . +! subprogram: intjo calculate RHS for analysis equation +! prgmmr: derber org: np23 date: 2003-12-18 +! +! abstract: calculate RHS for all variables (nonlinear qc version) +! +! A description of nonlinear qc follows: +! +! The observation penalty Jo is defined as +! +! Jo = - (sum over obs) 2*log(Po) +! +! where, +! +! Po = Wnotgross*exp(-.5*(Hn(x+xb) - yo)**2 ) + Wgross +! with +! Hn = the forward model (possibly non-linear) normalized by +! observation error +! x = the current estimate of the analysis increment +! xb = the background state +! yo = the observation normalized by observation error +! +! Note: The factor 2 in definition of Jo is present because the +! penalty Jo as used in this code is 2*(usual definition +! of penalty) +! +! Wgross = Pgross*cg +! +! Wnotgross = 1 - Wgross +! +! Pgross = probability of gross error for observation (assumed +! here to have uniform distribution over the possible +! range of values) +! +! cg = sqrt(2*pi)/2b +! +! b = possible range of variable for gross errors, normalized by +! observation error +! +! The values for the above parameters that Bill Collins used in the +! eta 3dvar are: +! +! cg = cg_term/b, where cg_term = sqrt(2*pi)/2 +! +! b = 10. ! range for gross errors, normalized by obs error +! +! pg_q=.002 ! probability of gross error for specific humidity +! pg_pw=.002 ! probability of gross error for precipitable water +! pg_p=.002 ! probability of gross error for pressure +! pg_w=.005 ! probability of gross error for wind +! pg_t=.007 ! probability of gross error for temperature +! pg_rad=.002 ! probability of gross error for radiances +! +! +! Given the above Jo, the gradient of Jo is as follows: +! +! T +! gradx(Jo) = - (sum over observations) 2*H (Hn(x+xb)-yo)*(Po - Wgross)/Po +! +! where, +! +! H = tangent linear model of Hn about x+xb +! +! +! Note that if Pgross = 0.0, then Wnotgross=1.0 and Wgross=0.0. That is, +! the code runs as though nonlinear quality control were not present +! (which is indeed the case since the gross error probability is 0). +! +! As a result the same int* routines may be used for use with or without +! nonlinear quality control. +! +! +! program history log: +! 2003-12-18 derber +! 2004-07-23 derber - modify to include conventional sst +! 2004-07-28 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - add nonlinear qc option +! 2004-10-06 kleist - separate control vector for u,v, & convert int +! for wind components into int for st,vp +! 2004-11-30 treadon - add brightness temperatures to nonlinear +! quality control +! 2004-12-03 treadon - replace mpe_iallreduce (IBM extension) with +! standard mpi_allreduce +! 2005-01-20 okamoto - add u,v to intrad +! 2005-02-23 wu - changes related to normalized rh option +! 2005-04-11 treadon - rename intall_qc as intall +! 2005-05-18 yanqiu zhu - add 'use int*mod',and modify call interfaces for using these modules +! 2005-05-24 pondeca - take into consideration that npred=npredp=0 +! for 2dvar only surface analysis option +! 2005-06-03 parrish - add horizontal derivatives +! 2005-07-10 kleist - add dynamic constraint term +! 2005-09-29 kleist - expand Jc term, include time derivatives vector +! 2005-11-21 kleist - separate tendencies from Jc term, add call to calctends adjoint +! 2005-12-01 cucurull - add code for GPS local bending angle, add use obsmod for ref_obs +! 2005-12-20 parrish - add arguments to call to intt to allow for option of using boundary +! layer forward tlm. +! 2006-02-03 derber - modify to increase reproducibility +! 2006-03-17 park - correct error in call to intt--rval,sval --> rvaluv,svaluv +! in order to correctly pass wind variables. +! 2006-04-06 kleist - include both Jc formulations +! 2006-07-26 parrish - correct inconsistency in computation of space and time derivatives of q +! currently, if derivatives computed, for q it is normalized q, but +! should be mixing ratio. +! 2006-07-26 parrish - add strong constraint initialization option +! 2007-03-19 tremolet - binning of observations +! 2007-04-13 tremolet - split jo from other components of intall +! 2007-06-04 derber - use quad precision to get reproducibility over number of processors +! 2008-11-27 todling - add tendencies for FOTO support and new interface to int's +! 2009-01-08 todling - remove reference to ozohead +! 2009-03-23 meunier - Add call to intlag (lagrangian observations) +! 2010-01-11 zhang,b - Bug fix: bias predictors need to be accumulated over nbins +! 2010-03-24 zhu - change the interfaces of intt,intrad,intpcp for generalizing control variable +! 2010-05-13 todling - harmonized interfaces to int* routines when it comes to state_vector (add only's) +! 2010-06-13 todling - add intco call +! 2010-10-15 pagowski - add intpm2_5 call +! 2010-10-20 hclin - added aod +! 2011-02-20 zhu - add intgust,intvis,intpblh calls +! 2013-05-20 zhu - add codes related to aircraft temperature bias correction +! 2014-06-18 carley/zhu - add lcbas and tcamt +! 2014-03-19 pondeca - add intwspd10m +! 2014-04-10 pondeca - add inttd2m,intmxtm,intmitm,intpmsl +! 2014-05-07 pondeca - add inthowv +! 2015-07-10 pondeca - add intcldch +! 2016-03-07 pondeca - add intuwnd10m,intvwnd10m +! +! input argument list: +! ibin +! yobs +! sval - solution on grid +! sbias +! rval +! qpred +! +! output argument list: +! rval - RHS on grid +! qpred +! +! remarks: +! 1) if strong initialization, then svalt, svalp, svaluv +! are all grid fields after strong initialization. +! +! 2) The two interfaces to the int-routines should be temporary. +! In the framework of the 4dvar-code, foto can be re-implemented as +! an approximate M and M' to the model matrices in 4dvar. Once that +! is done, the int-routines should no longer need the time derivatives. +! (Todling) +! 3) Notice that now (2010-05-13) int routines handle non-essential +! variables internally; also, when pointers non-existent, int routines +! simply return (Todling). +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ +use kinds, only: i_kind,r_quad +use gsi_bundlemod, only: gsi_bundle +use bias_predictors, only: predictors +use m_obsdiags, only: obOper_create +use m_obsdiags, only: obOper_destroy +use gsi_obOper, only: obOper + +use intradmod, only: setrad + +implicit none + +! Declare passed variables +type(gsi_bundle), dimension( :), intent(inout) :: rval ! (nobs_bins) +type(gsi_bundle), dimension( :), intent(in ) :: sval ! (nobs_bins) +real(r_quad ), dimension(:,:), intent(inout) :: qpred ! (:,nobs_bins) +type(predictors), intent(in ) :: sbias + +character(len=*),parameter:: myname_=myname//"::intjo_" + +! Declare local variables +integer(i_kind):: ibin,it,ix +class(obOper),pointer:: it_obOper + +!****************************************************************************** + call setrad(sval(1)) + +! "RHS for jo", as it was labeled in intall(). +!$omp parallel do schedule(dynamic,1) private(ibin,it,ix,it_obOper) + do ibin=1,size(sval) + do it=1,obOper_count + !ix=ix_obtype(it) ! Use this line to ensure the same jo summartion + ! sequence as intjo was in its early implementation, + ! for reproducibility. + + ix=it ! Using this line, jo summation sequence is not the same as + ! it used to be, nor the same if someone chooses to change + ! enumration sequence of obOpers in gsi_obOperTypeManager.F90. + ! But it would make this code more portable to new obOper + ! extensions. + + it_obOper => obOper_create(ix) + + if(.not.associated(it_obOper)) then + call perr(myname_,'unexpected obOper, associated(it_obOper) =',associated(it_obOper)) + call perr(myname_,' obOper_typeInfo(ioper) =',obOper_typeInfo(ix)) + call perr(myname_,' ioper =',ix) + call perr(myname_,' it =',it) + call perr(myname_,' obOper_count =',obOper_count) + call perr(myname_,' ibin =',ibin) + call die(myname_) + endif + + if(.not.associated(it_obOper%obsLL)) then + call perr(myname_,'unexpected component, associated(%obsLL) =',associated(it_obOper%obsLL)) + call perr(myname_,' obOper_typeInfo(ioper) =',obOper_typeInfo(ix)) + call perr(myname_,' ioper =',ix) + call perr(myname_,' it =',it) + call perr(myname_,' obOper_count =',obOper_count) + call perr(myname_,' ibin =',ibin) + call die(myname_) + endif + + call it_obOper%intjo(ibin,rval(ibin),sval(ibin),qpred(:,ibin),sbias) + call obOper_destroy(it_obOper) + enddo + end do + +return +end subroutine intjo_ + +subroutine intjo_reduced_(rval,qpred,sval,sbias) + use kinds, only: i_kind,r_quad + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use constants, only: zero_quad + implicit none +! Declare passed variables + type(gsi_bundle), dimension(:), intent(inout) :: rval + real(r_quad ), dimension(:), intent(inout) :: qpred + + type(gsi_bundle), dimension(:), intent(in ) :: sval + type(predictors), intent(in ) :: sbias + +!---------------------------------------- + real(kind(qpred)),allocatable,dimension(:,:):: qpred_bin + integer(i_kind):: ibin + + allocate(qpred_bin(size(qpred),size(rval))) + qpred_bin=zero_quad + + call intjo_(rval,qpred_bin,sval,sbias) + + do ibin=1,size(rval) + qpred(:)=qpred(:)+qpred_bin(:,ibin) + enddo + + deallocate(qpred_bin) + +end subroutine intjo_reduced_ + +end module intjomod diff --git a/src/intlag.f90 b/src/gsi/intlag.f90 similarity index 90% rename from src/intlag.f90 rename to src/gsi/intlag.f90 index 7413c84de..de2738df5 100644 --- a/src/intlag.f90 +++ b/src/gsi/intlag.f90 @@ -27,6 +27,7 @@ module intlagmod use m_lagNode, only: lagNode use m_lagNode, only: lagNode_typecast use m_lagNode, only: lagNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -152,17 +153,21 @@ subroutine intlag(laghead,rval,sval,obsbin) if (iv_debug>=1) print *,'TL correction:',lon_tl*rad2deg,lat_tl*rad2deg if (lsaveobsens) then - lagptr%diag_lon%obssen(jiter) = lon_tl*lagptr%raterr2*lagptr%err2_lon - lagptr%diag_lat%obssen(jiter) = lat_tl*lagptr%raterr2*lagptr%err2_lat + grad_lon = lon_tl*lagptr%raterr2*lagptr%err2_lon + grad_lat = lat_tl*lagptr%raterr2*lagptr%err2_lat + !-- lagptr%diag_lon%obssen(jiter) = lon_tl*lagptr%raterr2*lagptr%err2_lon + !-- lagptr%diag_lat%obssen(jiter) = lat_tl*lagptr%raterr2*lagptr%err2_lat + call obsdiagNode_set(lagptr%diag_lon,jiter=jiter,obssen=grad_lon) + call obsdiagNode_set(lagptr%diag_lat,jiter=jiter,obssen=grad_lat) else - if (lagptr%luse) lagptr%diag_lon%tldepart(jiter)=lon_tl - if (lagptr%luse) lagptr%diag_lat%tldepart(jiter)=lat_tl + !-- if (lagptr%luse) lagptr%diag_lon%tldepart(jiter)=lon_tl + !-- if (lagptr%luse) lagptr%diag_lat%tldepart(jiter)=lat_tl + if (lagptr%luse) call obsdiagNode_set(lagptr%diag_lon,jiter=jiter,tldepart=lon_tl) + if (lagptr%luse) call obsdiagNode_set(lagptr%diag_lat,jiter=jiter,tldepart=lat_tl) endif if (l_do_adjoint) then if (lsaveobsens) then - grad_lon = lagptr%diag_lon%obssen(jiter) - grad_lat = lagptr%diag_lat%obssen(jiter) grad_p = zero else diff --git a/src/intlcbas.f90 b/src/gsi/intlcbas.f90 similarity index 92% rename from src/intlcbas.f90 rename to src/gsi/intlcbas.f90 index 04c4c1bee..7b0a69522 100644 --- a/src/intlcbas.f90 +++ b/src/gsi/intlcbas.f90 @@ -24,6 +24,7 @@ module intlcbasmod use m_lcbasNode, only: lcbasNode use m_lcbasNode, only: lcbasNode_typecast use m_lcbasNode, only: lcbasNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -111,9 +112,11 @@ subroutine intlcbas(lcbashead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*lcbasptr%raterr2*lcbasptr%err2 - lcbasptr%diags%obssen(jiter) = grad + !-- lcbasptr%diags%obssen(jiter) = grad + call obsdiagNode_set(lcbasptr%diags,jiter=jiter,obssen=grad) else - if (lcbasptr%luse) lcbasptr%diags%tldepart(jiter)=val + !-- if (lcbasptr%luse) lcbasptr%diags%tldepart(jiter)=val + if (lcbasptr%luse) call obsdiagNode_set(lcbasptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/gsi/intlight.f90 b/src/gsi/intlight.f90 new file mode 100644 index 000000000..b9e7e2624 --- /dev/null +++ b/src/gsi/intlight.f90 @@ -0,0 +1,987 @@ +module intlightmod + +!$$$ module documentation block +! . . . . +! module: intlightmod int module for the observation operator for lightning flash rate (LFR) +! +! prgmmr: k apodaca +! org: CSU/CIRA, Data Assimilation Group +! date: 2016-05-04 +! +! abstract: module for the tangent linear (flashrate_TL) and adjoint models (flashrate_AD) +! of LFR +! +! program history log: +! 2016-05-04 apodaca - implement TL and AD of the LFR observation operator +! 2018-02-08 apodaca - replaced ob_type with polymorphic obsNode through type casting +! 2019-03-01 j guo - encapsulated access to obsdiagNode through obsdiagNode_set() +! +! subroutines included: +! sub intlight_ +! +! variable definitions: +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end documentation block +use m_obsNode, only: obsNode +use m_lightNode, only: lightNode +use m_lightNode, only: lightNode_typecast +use m_lightNode, only: lightNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set +implicit none + +PRIVATE +PUBLIC intlight + +interface intlight; module procedure & + intlight_ +end interface + +contains + +subroutine intlight_(lighthead,rval,sval) + +!$$$ subprogram documentation block +! . . . . +! subprogram: intlight TL and subsequent AD of the forward observation operator for LFR +! prgmmr: k apodaca +! org: CSU/CIRA, Data Assimilation Group +! date: 2016-05-04 +! +! abstract: In this program, the tangent linear and adjoint models of a +! lightning flash rate observation operator are calculated +! using a 12-point horizontal grid to calculate finite-difference +! derivatives and for interpolation in specific quadrants. +! +! The tangent linear equations represent a way to map +! the perturbation vectors for the control variables +! q, qi, qs, qg, t, u, and v. +! +! Moreover, the adjoint equations map the sensitivity gradient +! vectors for the control variables (q, qi, qs, qg, t, u, v), +! thus providing a first order aproximation or linear projection +! of the sesitivity (impact) of observations. +! +! program history log: +! 2018-01-18 k apodaca revision of AD code +! 2018-08-18 k apodaca add a the TL and AD of second oservation operator for lightning +! observations suitable for non-hydrostatic, cloud-resolving models +! with additional ice-phase hydrometeor control variables +! +! input argument list: +! lighthead - obs type pointer to obs structure +! sq - q increment in grid space +! sqi - qi increment in grid space +! sqs - qs increment in grid space +! sqg - qg increment in grid space +! st - t increment in grid space +! su - u increment in grid space +! sv - v increment in grid space +! +! output argument list: +! rq, rqi, rqs, rqg - control variabble updates resulting from +! rt, ru, rv the assimilation of lightning flash rate +! observations +! +! comments: +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + + use kinds, only: r_kind,i_kind + use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag + use gridmod, only: nsig + use gridmod, only: wrf_mass_regional,regional + use qcmod, only: nlnqc_iter,varqc_iter + use constants, only: zero,fv,one,half,two,tiny_r_kind,cg_term + use jfunc, only: jiter + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_4dvar, only: ladtest_obs + implicit none + +! Declare passed variables + class(obsNode), pointer, intent(in ) :: lighthead + type(gsi_bundle), intent(in ) :: sval + type(gsi_bundle), intent(inout) :: rval + +! Declare local variables + integer(i_kind) k,ier,istatus + integer(i_kind),dimension(nsig) :: i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12 + real(r_kind) val,w1,w2,w3,w4 + real(r_kind) cg_light,grad,p0,wnotgross,wgross,pg_light + real(r_kind),pointer,dimension(:) :: sq,sqi,sqs,sqg,su,sv,st + real(r_kind),pointer,dimension(:) :: rq,rqi,rqs,rqg,ru,rv,rt + type(lightNode), pointer :: lightptr + +! Variables for TL and AD of lightning flash rate + real(r_kind),dimension(1:nsig) :: z_TL + real(r_kind),dimension(1:nsig) :: horiz_adv_TL + real(r_kind),dimension(1:nsig) :: vert_adv_TL + real(r_kind),dimension(1:nsig) :: w_TL + real(r_kind) :: wmaxi1_TL,wmaxi2_TL,wmaxi3_TL,wmaxi4_TL + real(r_kind) :: flashrate_TL,flashratei1_TL,flashratei2_TL + real(r_kind) :: flashratei3_TL, flashratei4_TL + real(r_kind) :: h1i1_TL,h1i2_TL,h1i3_TL,h1i4_TL + real(r_kind) :: h2i1_TL,h2i2_TL,h2i3_TL,h2i4_TL + real(r_kind) :: totice_colinti1_TL,totice_colinti2_TL + real(r_kind) :: totice_colinti3_TL,totice_colinti4_TL + real(r_kind) :: htot_TL,htoti1_TL,htoti2_TL,htoti3_TL,htoti4_TL + real(r_kind) :: flashrate_AD,flashratei1_AD,flashratei2_AD + real(r_kind) :: flashratei3_AD,flashratei4_AD + real(r_kind) :: wmaxi1_AD,wmaxi2_AD,wmaxi3_AD,wmaxi4_AD + real(r_kind) :: h1i1_AD,h1i2_AD,h1i3_AD,h1i4_AD + real(r_kind) :: h2i1_AD,h2i2_AD,h2i3_AD,h2i4_AD + real(r_kind) :: totice_colinti1_AD,totice_colinti2_AD + real(r_kind) :: totice_colinti3_AD,totice_colinti4_AD + real(r_kind) :: htot_AD,htoti1_AD,htoti2_AD,htoti3_AD,htoti4_AD + real(r_kind),dimension(1:nsig) :: z_AD + real(r_kind),dimension(1:nsig) :: w_AD + real(r_kind),dimension(1:nsig) :: vert_adv_AD,horiz_adv_AD + real(r_kind),dimension(1:nsig) :: diffq + real(r_kind),dimension(1:nsig) :: difft + real(r_kind),dimension(1:nsig) :: diffz +! wmax variables for lightning flash rate + real(r_kind) :: wmax + real(r_kind),parameter :: k3=0.95_r_kind + +! Output files +! character :: tlh_file*40 + + +! If no light data return + if(.not. associated(lighthead))return +! Retrieve pointers +! Simply return if any pointer not found + ier=0 + call gsi_bundlegetpointer(sval,'q',sq,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'q',rq,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'tsen',st,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'tsen',rt,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'u',su,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'u',ru,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'v',sv,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'v',rv,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qi',sqi,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qi',rqi,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qg',sqg,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qg',rqg,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qs',sqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qs',rqs,istatus);ier=istatus+ier + if(ier/=0)return + + + + lightptr => lightNode_typecast(lighthead) + do while (associated(lightptr)) + +! Load location information into local variables + + w1=lightptr%wij(1) + w2=lightptr%wij(2) + w3=lightptr%wij(3) + w4=lightptr%wij(4) + + do k=1,nsig + i1(k)=lightptr%ij(1,k) + i2(k)=lightptr%ij(2,k) + i3(k)=lightptr%ij(3,k) + i4(k)=lightptr%ij(4,k) + i5(k)=lightptr%ij(5,k) + i6(k)=lightptr%ij(6,k) + i7(k)=lightptr%ij(7,k) + i8(k)=lightptr%ij(8,k) + i9(k)=lightptr%ij(9,k) + i10(k)=lightptr%ij(10,k) + i11(k)=lightptr%ij(11,k) + i12(k)=lightptr%ij(12,k) + end do + +! . . . . + +! In the case of lightning observations (e.g. GOES/GLM), the schematic shown below is +! used for bi-linear interpolation of background fields to the location of an observation +! (+) and for the finite-difference derivation method used in the calculation of the TL of +! the observation operator for lightning flash rate. Calculations are done +! at each quadrant, i.e., central, north, south, east, and west. +! +! i6-------i8 +! | | +! | | +! i10-----i2-------i4-----i12 +! | | | | +! | | + | | +! i9------i1-------i3-----i11 +! | | +! | | +! i5-------i7 +! + +! . . . . + +! In the following section, the tangent linear of the lightning flash rate observation +! operator is calculated by being broken into parts. + +! Tangent linear of height (z) + + z_TL(:)=zero + horiz_adv_TL(:)=zero + + do k=2,nsig-1 + + z_TL(i1(1))=lightptr%jac_z0i1 + z_TL(i2(1))=lightptr%jac_z0i2 + z_TL(i3(1))=lightptr%jac_z0i3 + z_TL(i4(1))=lightptr%jac_z0i4 + z_TL(i5(1))=lightptr%jac_z0i5 + z_TL(i6(1))=lightptr%jac_z0i6 + z_TL(i7(1))=lightptr%jac_z0i7 + z_TL(i8(1))=lightptr%jac_z0i8 + z_TL(i9(1))=lightptr%jac_z0i9 + z_TL(i10(1))=lightptr%jac_z0i10 + z_TL(i11(1))=lightptr%jac_z0i11 + z_TL(i12(1))=lightptr%jac_z0i12 + + + z_TL(i1(k))=z_TL(i1(k-1))+lightptr%jac_vertti1(k)*st(i1(k)) & + +lightptr%jac_vertqi1(k)*sq(i1(k)) + + z_TL(i2(k))=z_TL(i2(k-1))+lightptr%jac_vertti2(k)*st(i2(k)) & + +lightptr%jac_vertqi2(k)*sq(i2(k)) + + z_TL(i3(k))=z_TL(i3(k-1))+lightptr%jac_vertti3(k)*st(i3(k)) & + +lightptr%jac_vertqi3(k)*sq(i3(k)) + + z_TL(i4(k))=z_TL(i4(k-1))+lightptr%jac_vertti4(k)*st(i4(k)) & + +lightptr%jac_vertqi4(k)*sq(i4(k)) + + z_TL(i5(k))=z_TL(i5(k-1))+lightptr%jac_vertti5(k)*st(i5(k)) & + +lightptr%jac_vertqi5(k)*sq(i5(k)) + + z_TL(i6(k))=z_TL(i6(k-1))+lightptr%jac_vertti6(k)*st(i6(k)) & + +lightptr%jac_vertqi6(k)*sq(i6(k)) + + z_TL(i7(k))=z_TL(i7(k-1))+lightptr%jac_vertti7(k)*st(i7(k)) & + +lightptr%jac_vertqi7(k)*sq(i7(k)) + + z_TL(i8(k))=z_TL(i8(k-1))+lightptr%jac_vertti8(k)*st(i8(k)) & + +lightptr%jac_vertqi8(k)*sq(i8(k)) + + z_TL(i9(k))=z_TL(i9(k-1))+lightptr%jac_vertti9(k)*st(i9(k)) & + +lightptr%jac_vertqi9(k)*sq(i9(k)) + + z_TL(i10(k))=z_TL(i10(k-1))+lightptr%jac_vertti10(k)*st(i10(k)) & + +lightptr%jac_vertqi10(k)*sq(i10(k)) + + z_TL(i11(k))=z_TL(i11(k-1))+lightptr%jac_vertti11(k)*st(i11(k)) & + +lightptr%jac_vertqi11(k)*sq(i11(k)) + + z_TL(i12(k))=z_TL(i12(k-1))+lightptr%jac_vertti12(k)*st(i12(k)) & + +lightptr%jac_vertqi12(k)*sq(i12(k)) + + +! Tangent Linear of the Horizontal Advection Section + + + horiz_adv_TL(i1(k))=lightptr%jac_zdxi1(k)*su(i1(k)) & + +lightptr%jac_zdyi1(k)*sv(i1(k)) & + +lightptr%jac_udxi1(k)*(z_TL(i3(k))-z_TL(i9(k))) & + +lightptr%jac_vdyi1(k)*(z_TL(i2(k))-z_TL(i5(k))) + horiz_adv_TL(i2(k))=lightptr%jac_zdxi2(k)*su(i2(k)) & + +lightptr%jac_zdyi2(k)*sv(i2(k)) & + +lightptr%jac_udxi2(k)*(z_TL(i4(k))-z_TL(i10(k))) & + +lightptr%jac_vdyi2(k)*(z_TL(i6(k))-z_TL(i1 (k))) + + horiz_adv_TL(i3(k))=lightptr%jac_zdxi3(k)*su(i3(k)) & + +lightptr%jac_zdyi3(k)*sv(i3(k)) & + +lightptr%jac_udxi3(k)*(z_TL(i11(k))-z_TL(i1(k))) & + +lightptr%jac_vdyi3(k)*(z_TL(i4 (k))-z_TL(i7(k))) + + horiz_adv_TL(i4(k))=lightptr%jac_zdxi4(k)*su(i4(k)) & + +lightptr%jac_zdyi4(k)*sv(i4(k)) & + +lightptr%jac_udxi4(k)*(z_TL(i12(k))-z_TL(i2(k))) & + +lightptr%jac_vdyi4(k)*(z_TL(i8 (k))-z_TL(i3(k))) + + enddo ! do k=2,nsig-1 + +! Tangent Linear of the Vertical Advection Section + + vert_adv_TL(:)=zero + w_TL(:)=zero + + do k=1,nsig-1 + + vert_adv_TL(i1(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti1(k)* & + (((one+fv*lightptr%jac_qi1(k))*st(i1(k))) & + +(lightptr%jac_ti1(k)*fv*sq(i1(k)))) + + vert_adv_TL(i2(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti2(k)* & + (((one+fv*lightptr%jac_qi2(k))*st(i2(k))) & + +(lightptr%jac_ti2(k)*fv*sq(i2(k)))) + + vert_adv_TL(i3(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti3(k)* & + (((one+fv*lightptr%jac_qi3(k))*st(i3(k))) & + +(lightptr%jac_ti3(k)*fv*sq(i3(k)))) + + vert_adv_TL(i4(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti4(k)* & + (((one+fv*lightptr%jac_qi4(k))*st(i4(k))) & + +(lightptr%jac_ti4(k)*fv*sq(i4(k)))) + + + +! Tangent Linear of Vertical Velocity + + + w_TL(i1(k))=horiz_adv_TL(i1(k))+vert_adv_TL(i1(k)) + w_TL(i2(k))=horiz_adv_TL(i2(k))+vert_adv_TL(i2(k)) + w_TL(i3(k))=horiz_adv_TL(i3(k))+vert_adv_TL(i3(k)) + w_TL(i4(k))=horiz_adv_TL(i4(k))+vert_adv_TL(i4(k)) + + enddo !do k=1,nsig-1 + +! . . . . +! Tangent Linear of lightning flash rate + +! . . . . +! Regional + + if (regional) then + +!-- WRF-ARW + + if (wrf_mass_regional) then + +! Tangent linear - Lightning flash rate as a function of +! vertical graupel flux within the mixed-phase region +! (-15 deg C) + + + if (lightptr%kboti1 > zero) then + h1i1_TL=lightptr%jac_qgmai1(lightptr%kboti1)*sqg(i1(lightptr%kboti1))+& + lightptr%jac_qgmbi1(lightptr%kboti1)*& + (half*(w_TL(i1(lightptr%kboti1))+w_TL(i1(lightptr%kboti1+1)))) + h1i1_TL=h1i1_TL/(abs(h1i1_TL)) + else + h1i1_TL=zero + endif + + if (lightptr%kboti2 > zero) then + h1i2_TL=lightptr%jac_qgmai2(lightptr%kboti2)*sqg(i2(lightptr%kboti2))+& + lightptr%jac_qgmbi2(lightptr%kboti2)*& + (half*(w_TL(i2(lightptr%kboti2))+w_TL(i2(lightptr%kboti2+1)))) + h1i2_TL=h1i2_TL/(abs(h1i2_TL)) + else + h1i2_TL=zero + endif + + if (lightptr%kboti3 > zero) then + h1i3_TL=lightptr%jac_qgmai3(lightptr%kboti3)*sqg(i3(lightptr%kboti3))+& + lightptr%jac_qgmbi3(lightptr%kboti3)*& + (half*(w_TL(i3(lightptr%kboti3))+w_TL(i3(lightptr%kboti3+1)))) + h1i3_TL=h1i3_TL/(abs(h1i3_TL)) + else + h1i3_TL=zero + endif + + if (lightptr%kboti4 > zero) then + h1i4_TL=lightptr%jac_qgmai4(lightptr%kboti4)*sqg(i4(lightptr%kboti4))+& + lightptr%jac_qgmbi4(lightptr%kboti4)*& + (half*(w_TL(i4(lightptr%kboti4))+w_TL(i4(lightptr%kboti4+1)))) + h1i4_TL=h1i4_TL/(abs(h1i4_TL)) + else + h1i4_TL=zero + endif + + +! Tangent Linear - Lightning flash rate as a function of total column-integrated +! ice-phase hydrometeors + + totice_colinti1_TL=zero + totice_colinti2_TL=zero + totice_colinti3_TL=zero + totice_colinti4_TL=zero + + do k=1,nsig-1 + + totice_colinti1_TL = totice_colinti1_TL+lightptr%jac_icei1(k) * & + (sqi(i1(k))+sqs(i1(k))+sqg(i1(k)))+& + lightptr%jac_zicei1(k)*z_TL(i1(k)) + + totice_colinti2_TL = totice_colinti2_TL+lightptr%jac_icei2(k) * & + (sqi(i2(k))+sqs(i2(k))+sqg(i2(k)))+& + lightptr%jac_zicei2(k)*z_TL(i2(k)) + + totice_colinti3_TL = totice_colinti3_TL+lightptr%jac_icei3(k) * & + (sqi(i3(k))+sqs(i3(k))+sqg(i3(k)))+& + lightptr%jac_zicei3(k)*z_TL(i3(k)) + + totice_colinti4_TL = totice_colinti4_TL+lightptr%jac_icei4(k) * & + (sqi(i4(k))+sqs(i4(k))+sqg(i4(k)))+& + lightptr%jac_zicei4(k)*z_TL(i4(k)) + + enddo !do k=1,nsig-1 + + h2i1_TL=(1-k3)*totice_colinti1_TL + h2i2_TL=(1-k3)*totice_colinti2_TL + h2i3_TL=(1-k3)*totice_colinti3_TL + h2i4_TL=(1-k3)*totice_colinti4_TL + + + htoti1_TL= h1i1_TL+h2i1_TL + htoti2_TL= h1i2_TL+h2i2_TL + htoti3_TL= h1i3_TL+h2i3_TL + htoti4_TL= h1i4_TL+h2i4_TL + +! Interpolation of lightning flash rate to observation location (2D field) +! Forward Model + + htot_TL = (w1*htoti1_TL + w2*htoti2_TL + & + w3*htoti3_TL + w4*htoti4_TL) + val = htot_TL + + endif ! wrf_mass_regional + + endif !if (regional) then + +! . . . . +! Global + + if (.not. regional) then ! Global + +! Cloud Mask + +! If clouds are present, find the maximum value of vertical velocity +! (wmax_TL) at four points sorounding an observation (+) +! and amongst all vertical levels, otherwise set wmax_TL to zero. + + wmaxi1_TL=zero + wmaxi2_TL=zero + wmaxi3_TL=zero + wmaxi4_TL=zero + + if (lightptr%jac_wmaxflagi1) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (w_TL(i1(k)) > wmax) then + lightptr%jac_kverti1=k + wmaxi1_TL=w_TL(i1(lightptr%jac_kverti1)) + endif + if (wmaxi1_TL < zero) then + wmaxi1_TL=zero + endif + enddo ! k loop + endif + + if (lightptr%jac_wmaxflagi2) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (w_TL(i2(k)) > wmax) then + lightptr%jac_kverti2=k + wmaxi2_TL=w_TL(i2(lightptr%jac_kverti2)) + endif + if (wmaxi2_TL < zero) then + wmaxi2_TL=zero + endif + enddo ! k loop + endif + + if (lightptr%jac_wmaxflagi3) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (w_TL(i3(k)) > wmax) then + lightptr%jac_kverti3=k + wmaxi3_TL=w_TL(i3(lightptr%jac_kverti3)) + endif + if (wmaxi3_TL < zero) then + wmaxi3_TL=zero + endif + enddo ! k loop + endif + + if (lightptr%jac_wmaxflagi4) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (w_TL(i4(k)) > wmax) then + lightptr%jac_kverti4=k + wmaxi4_TL=w_TL(i4(lightptr%jac_kverti4)) + endif + if (wmaxi4_TL < zero) then + wmaxi4_TL=zero + endif + enddo ! k loop + endif + +! Tangent Linear of Lightning Flash Rate + + flashratei1_TL=lightptr%jac_fratei1*wmaxi1_TL + flashratei2_TL=lightptr%jac_fratei1*wmaxi2_TL + flashratei3_TL=lightptr%jac_fratei1*wmaxi3_TL + flashratei4_TL=lightptr%jac_fratei1*wmaxi4_TL + +! Interpolation of lightning flash rate to observation location (2D field) +! Forward Model + + flashrate_TL = (w1*flashratei1_TL + w2*flashratei2_TL + & + w3*flashratei3_TL + w4*flashratei4_TL) + val = flashrate_TL + + end if ! global block + + if (luse_obsdiag)then + if (lsaveobsens) then + grad = val*lightptr%raterr2*lightptr%err2 + !-- lightptr%diags%obssen(jiter) = grad + call obsdiagNode_set(lightptr%diags,jiter=jiter,obssen=grad) + else + !-- if (lightptr%luse) lightptr%diags%tldepart(jiter)=val + if (lightptr%luse) call obsdiagNode_set(lightptr%diags,jiter=jiter,tldepart=val) + endif + end if + + +! . . . . + +! Adjoint test + + if (l_do_adjoint) then +! Difference from observation + if (.not. lsaveobsens) then + if (.not. ladtest_obs) val=val-lightptr%res + +! needed for gradient of nonlinear qc operator + if (nlnqc_iter .and. lightptr%pg > tiny_r_kind .and. & + lightptr%b > tiny_r_kind) then + pg_light=lightptr%pg*varqc_iter + cg_light=cg_term/lightptr%b + wnotgross= one-pg_light + wgross = pg_light*cg_light/wnotgross + p0 = wgross/(wgross+exp(-half*lightptr%err2*val**2)) + val = val*(one-p0) + endif + + if( ladtest_obs) then + grad = val + else + grad = val*lightptr%raterr2*lightptr%err2 + end if + endif + + +! . . . . + +! Adjoint of the Lightning Flash Rate Observation Operator + +! . . . . +! Variable initialization + + z_AD(:)=zero + w_AD(:)=zero + +! Regional + + if (regional) then + +!-- WRF-ARW + + if (wrf_mass_regional) then + + htot_AD=grad + +! Adjoint - Total lightning flash rate + + htoti1_AD=htoti1_AD+w1*htot_AD + htoti2_AD=htoti2_AD+w1*htot_AD + htoti3_AD=htoti3_AD+w1*htot_AD + htoti4_AD=htoti4_AD+w1*htot_AD + + h1i1_AD=h1i1_AD+htoti1_AD + h2i1_AD=h2i1_AD+htoti1_AD + + h1i2_AD=h1i2_AD+htoti2_AD + h2i2_AD=h2i2_AD+htoti2_AD + + h1i3_AD=h1i3_AD+htoti3_AD + h2i3_AD=h2i3_AD+htoti3_AD + + h1i4_AD=h1i4_AD+htoti4_AD + h2i4_AD=h2i4_AD+htoti4_AD + + totice_colinti1_AD=totice_colinti1_AD+(1-k3)*h2i1_AD + totice_colinti2_AD=totice_colinti2_AD+(1-k3)*h2i2_AD + totice_colinti3_AD=totice_colinti3_AD+(1-k3)*h2i3_AD + totice_colinti4_AD=totice_colinti4_AD+(1-k3)*h2i4_AD + +! Adjoint - Lightning flash rate as a function of total column-integrated +! ice-phase hydrometeors + + + do k=nsig-1,1,-1 + + z_AD(i1(k))=z_AD(i1(k))+lightptr%jac_zicei1(k)*totice_colinti1_AD + rqi(i1(k))=rqi(i1(k))+lightptr%jac_icei1(k)*totice_colinti1_AD + rqs(i1(k))=rqs(i1(k))+lightptr%jac_icei1(k)*totice_colinti1_AD + rqg(i1(k))=rqg(i1(k))+lightptr%jac_icei1(k)*totice_colinti1_AD + totice_colinti1_AD=two*totice_colinti1_AD + + z_AD(i2(k))=z_AD(i2(k))+lightptr%jac_zicei2(k)*totice_colinti2_AD + rqi(i2(k))=rqi(i2(k))+lightptr%jac_icei2(k)*totice_colinti2_AD + rqs(i2(k))=rqs(i2(k))+lightptr%jac_icei2(k)*totice_colinti2_AD + rqg(i2(k))=rqg(i2(k))+lightptr%jac_icei2(k)*totice_colinti2_AD + totice_colinti2_AD=two*totice_colinti2_AD + + z_AD(i3(k))=z_AD(i3(k))+lightptr%jac_zicei3(k)*totice_colinti3_AD + rqi(i3(k))=rqi(i3(k))+lightptr%jac_icei3(k)*totice_colinti3_AD + rqs(i3(k))=rqs(i3(k))+lightptr%jac_icei3(k)*totice_colinti3_AD + rqg(i3(k))=rqg(i3(k))+lightptr%jac_icei3(k)*totice_colinti3_AD + totice_colinti3_AD=two*totice_colinti3_AD + + z_AD(i4(k))=z_AD(i4(k))+lightptr%jac_zicei4(k)*totice_colinti4_AD + rqi(i4(k))=rqi(i4(k))+lightptr%jac_icei4(k)*totice_colinti4_AD + rqs(i4(k))=rqs(i4(k))+lightptr%jac_icei4(k)*totice_colinti4_AD + rqg(i4(k))=rqg(i4(k))+lightptr%jac_icei4(k)*totice_colinti4_AD + totice_colinti4_AD=two*totice_colinti4_AD + +! Adjoint - Lightning flash rate as a function of +! vertical graupel flux within the mixed-phase region +! (-15 deg C) + + if (lightptr%kboti1 > zero) then + h1i1_AD=h1i1_AD+(h1i1_AD/abs(h1i1_AD)) + rqg(i1(lightptr%kboti1))=rqg(i1(lightptr%kboti1))+& + lightptr%jac_qgmai1(lightptr%kboti1)*h1i1_AD + w_AD(i1(lightptr%kboti1))=w_AD(i1(lightptr%kboti1))+& + half*lightptr%jac_qgmbi1(lightptr%kboti1)*h1i1_AD + w_AD(i1(lightptr%kboti1+1))=w_AD(i1(lightptr%kboti1+1))+& + half*lightptr%jac_qgmbi1(lightptr%kboti1)*h1i1_AD + else + h1i1_AD=zero + rqg(i1(lightptr%kboti1))=zero + w_AD(i1(lightptr%kboti1))=zero + w_AD(i1(lightptr%kboti1+1))=zero + endif + + if (lightptr%kboti2 > zero) then + h1i2_AD=h1i2_AD+(h1i2_AD/abs(h1i2_AD)) + rqg(i2(lightptr%kboti2))=rqg(i2(lightptr%kboti2))+& + lightptr%jac_qgmai2(lightptr%kboti2)*h1i2_AD + w_AD(i2(lightptr%kboti2))=w_AD(i2(lightptr%kboti2))+& + half*lightptr%jac_qgmbi2(lightptr%kboti2)*h1i2_AD + w_AD(i2(lightptr%kboti2+1))=w_AD(i2(lightptr%kboti2+1))+& + half*lightptr%jac_qgmbi2(lightptr%kboti2)*h1i2_AD + else + h1i2_AD=zero + rqg(i2(lightptr%kboti2))=zero + w_AD(i2(lightptr%kboti2+1))=zero + endif + + if (lightptr%kboti3 > zero) then + h1i3_AD=h1i3_AD+(h1i3_AD/abs(h1i3_AD)) + rqg(i3(lightptr%kboti3))=rqg(i3(lightptr%kboti3))+& + lightptr%jac_qgmai3(lightptr%kboti3)*h1i3_AD + w_AD(i3(lightptr%kboti3))=w_AD(i3(lightptr%kboti3))+& + half*lightptr%jac_qgmbi3(lightptr%kboti3)*h1i3_AD + w_AD(i3(lightptr%kboti3+1))=w_AD(i3(lightptr%kboti3+1))+& + half*lightptr%jac_qgmbi3(lightptr%kboti3)*h1i3_AD + else + h1i3_AD=zero + rqg(i3(lightptr%kboti3))=zero + w_AD(i3(lightptr%kboti3+1))=zero + endif + + if (lightptr%kboti4 > zero) then + h1i4_AD=h1i4_AD+(h1i4_AD/abs(h1i4_AD)) + rqg(i4(lightptr%kboti4))=rqg(i4(lightptr%kboti4))+& + lightptr%jac_qgmai4(lightptr%kboti4)*h1i4_AD + w_AD(i4(lightptr%kboti4))=w_AD(i4(lightptr%kboti4))+& + half*lightptr%jac_qgmbi4(lightptr%kboti4)*h1i4_AD + w_AD(i4(lightptr%kboti4+1))=w_AD(i4(lightptr%kboti4+1))+& + half*lightptr%jac_qgmbi4(lightptr%kboti4)*h1i4_AD + else + h1i4_AD=zero + rqg(i4(lightptr%kboti4))=zero + w_AD(i4(lightptr%kboti4+1))=zero + endif + + + enddo !do k=nsig-1,1,-1 + + endif ! wrf_mass_regional + + endif !if (regional) then + +! . . . . +! Global + + if (.not. regional) then + + flashrate_AD=grad + + + flashratei1_AD=flashratei1_AD+w1*flashrate_AD + flashratei2_AD=flashratei2_AD+w2*flashrate_AD + flashratei3_AD=flashratei3_AD+w3*flashrate_AD + flashratei4_AD=flashratei4_AD+w4*flashrate_AD + +! Adjoint of Maximum Vertical Velocity + + wmaxi1_AD=wmaxi1_AD+lightptr%jac_fratei1*flashratei1_AD + wmaxi2_AD=wmaxi2_AD+lightptr%jac_fratei2*flashratei2_AD + wmaxi3_AD=wmaxi3_AD+lightptr%jac_fratei3*flashratei3_AD + wmaxi4_AD=wmaxi3_AD+lightptr%jac_fratei4*flashratei4_AD + + if (lightptr%jac_wmaxflagi1) then + wmax=-1.e+10_r_kind + do k=nsig-1,1,-1 + if (wmaxi1_AD < zero) then + wmaxi1_AD=zero + endif + if (wmaxi1_AD > wmax) then + lightptr%jac_kverti1=k + w_AD(i1(lightptr%jac_kverti1))=w_AD(i1(lightptr%jac_kverti1))+wmaxi1_AD + endif + enddo + endif + + if (lightptr%jac_wmaxflagi2) then + wmax=-1.e+10_r_kind + do k=nsig-1,1,-1 + if (wmaxi2_AD < zero) then + wmaxi2_AD=zero + endif + if (wmaxi2_AD > wmax) then + lightptr%jac_kverti2=k + w_AD(i2(lightptr%jac_kverti2))=w_AD(i2(lightptr%jac_kverti2))+wmaxi2_AD + endif + enddo + endif + + if (lightptr%jac_wmaxflagi3) then + wmax=-1.e+10_r_kind + do k=nsig-1,1,-1 + if (wmaxi3_AD < zero) then + wmaxi3_AD=zero + endif + if (wmaxi3_AD > wmax) then + lightptr%jac_kverti3=k + w_AD(i3(lightptr%jac_kverti3))=w_AD(i3(lightptr%jac_kverti3))+wmaxi3_AD + endif + enddo + endif + + if (lightptr%jac_wmaxflagi4) then + wmax=-1.e+10_r_kind + do k=nsig-1,1,-1 + if (wmaxi4_AD < zero) then + wmaxi4_AD=zero + endif + if (wmaxi4_AD > wmax) then + lightptr%jac_kverti4=k + w_AD(i4(lightptr%jac_kverti4))=w_AD(i4(lightptr%jac_kverti4))+wmaxi4_AD + endif + enddo + endif + + + endif ! end global block +! . . . . + +! Adjoint of Vertical Velocity (from Vertical and Horizontal Advection) + + vert_adv_AD(:)=zero + + do k=nsig-1,1,-1 + + vert_adv_AD(i4(k))=vert_adv_AD(i4(k))+w_AD(i4(k)) + vert_adv_AD(i3(k))=vert_adv_AD(i3(k))+w_AD(i3(k)) + vert_adv_AD(i2(k))=vert_adv_AD(i2(k))+w_AD(i2(k)) + vert_adv_AD(i1(k))=vert_adv_AD(i1(k))+w_AD(i1(k)) + + enddo + + horiz_adv_AD(:)=zero + + do k=nsig-1,2,-1 + + horiz_adv_AD(i4(k))=horiz_adv_AD(i4(k))+w_AD(i4(k)) + horiz_adv_AD(i4(k))=horiz_adv_AD(i3(k))+w_AD(i3(k)) + horiz_adv_AD(i2(k))=horiz_adv_AD(i2(k))+w_AD(i2(k)) + horiz_adv_AD(i1(k))=horiz_adv_AD(i1(k))+w_AD(i1(k)) + + enddo + +! Adjoint of q and t from the Vertical Advection Section + + diffq(:)=zero + difft(:)=zero + + do k=nsig-1,1,-1 + + diffq(i1(k))=-(lightptr%jac_ti1(k)*fv*lightptr%jac_vert(K) & + *lightptr%jac_sigdoti1(k))*vert_adv_AD(i1(k)) + difft(i1(k))=-((one+fv*lightptr%jac_qi1(k))*lightptr%jac_vert(k) & + *lightptr%jac_sigdoti1(k))*vert_adv_AD(i1(k)) + diffq(i2(k))=-(lightptr%jac_ti2(k)*fv*lightptr%jac_vert(k) & + *lightptr%jac_sigdoti2(k))*vert_adv_AD(i2(k)) + difft(i2(k))=-((one+fv*lightptr%jac_qi2(k))*lightptr%jac_vert(k) & + *lightptr%jac_sigdoti2(k))*vert_adv_AD(i2(k)) + diffq(i3(k))=-(lightptr%jac_ti3(k)*fv*lightptr%jac_vert(k) & + *lightptr%jac_sigdoti3(k))*vert_adv_AD(i3(k)) + difft(i3(k))=-((one+fv*lightptr%jac_qi3(k))*lightptr%jac_vert(k) & + *lightptr%jac_sigdoti3(k))*vert_adv_AD(i3(k)) + diffq(i4(k))=-(lightptr%jac_ti4(k)*fv*lightptr%jac_vert(k) & + *lightptr%jac_sigdoti4(k))*vert_adv_AD(i4(k)) + difft(i4(k))=-((one+fv*lightptr%jac_qi4(k))*lightptr%jac_vert(k) & + *lightptr%jac_sigdoti4(k))*vert_adv_AD(i4(k)) + + rq(i1(k))=rq(i1(k))+diffq(i1(k)) + + rt(i1(k))=rt(i1(k))+difft(i1(k)) + + rq(i2(k))=rq(i2(k))+diffq(i2(k)) + + rq(i3(k))=rq(i3(k))+diffq(i3(k)) + + rt(i3(k))=rt(i3(k))+difft(i3(k)) + + rq(i4(k))=rq(i4(k))+diffq(i4(k)) + + rt(i4(k))=rt(i4(k))+difft(i4(k)) + + enddo + + + +! Adjoint of z, u, and v from the Horizontal Advection Section + + diffz(:)=zero + z_AD(:)=zero + + do k=nsig-1,2,-1 + + diffz(i5(k))=-lightptr%jac_vdyi1(k)*horiz_adv_AD(i1(k)) + diffz(i9(k))=-lightptr%jac_udxi1(k)*horiz_adv_AD(i1(k)) + + z_AD(i5(k))=z_AD(i5(k))+diffz(i5(k)) + z_AD(i2(k))=z_AD(i2(k))+(lightptr%jac_vdyi1(k)*horiz_adv_AD(i1(k))) + z_AD(i9(k))=z_AD(i9(k))+(diffz(i9(k))) + z_AD(i3(k))=z_AD(i3(k))+(lightptr%jac_udxi1(k)*horiz_adv_AD(i1(k))) + + rv(i1(k))=rv(i1(k))+(lightptr%jac_zdyi1(k)*horiz_adv_AD(i1(k))) + ru(i1(k))=ru(i1(k))+(lightptr%jac_zdxi1(k)*horiz_adv_AD(i1(k))) + + diffz(i1(k)) =-lightptr%jac_vdyi2(k)*horiz_adv_AD(i2(k)) + diffz(i10(k))=-lightptr%jac_udxi2(k)*horiz_adv_AD(i2(k)) + + z_AD(i1(k))=z_AD(i1(k))+(diffz(i1(k))) + z_AD(i6(k))=z_AD(i6(k))+(lightptr%jac_vdyi2(k)*horiz_adv_AD(i2(k))) + z_AD(i10(k))=z_AD(i10(k))+(diffz(i10(k))) + z_AD(i4(k))=z_AD(i4(k))+(lightptr%jac_udxi2(k)*horiz_adv_AD(i2(k))) + rv(i2(k))=rv(i2(k))+(lightptr%jac_zdyi2(k)*horiz_adv_AD(i2(k))) + ru(i2(k))=ru(i2(k))+(lightptr%jac_zdxi2(k)*horiz_adv_AD(i2(k))) + + diffz(i7(k))= -lightptr%jac_vdyi3(k)*horiz_adv_AD(i3(k)) + diffz(i1(k))= -lightptr%jac_udxi3(k)*horiz_adv_AD(i3(k)) + + z_AD(i7(k)) = z_AD(i7(k))+diffz(i7(k)) + z_AD(i4(k)) = z_AD(i4(k))+(lightptr%jac_vdyi3(k)*horiz_adv_AD(i3(k))) + z_AD(i1(k)) = z_AD(i1(k))+diffz(i1(k)) + z_AD(i11(k))= z_AD(i11(k))+(lightptr%jac_udxi3(k)*horiz_adv_AD(i3(k))) + rv(i3(k)) = rv(i3(k))+(lightptr%jac_zdyi3(k)*horiz_adv_AD(i3(k))) + ru(i3(k)) = ru(i3(k))+(lightptr%jac_zdxi3(k)*horiz_adv_AD(i3(k))) + + diffz(i3(k))=-lightptr%jac_vdyi4(k)*horiz_adv_AD(i4(k)) + diffz(i2(k))=-z_TL(i2(k))-lightptr%jac_udxi4(k)*horiz_adv_AD(i4(k)) + + z_AD(i3(k)) = z_AD(i3(k))+diffz(i3(k)) + z_AD(i8(k)) = z_AD(i8(k))+(lightptr%jac_vdyi4(k)*horiz_adv_AD(i4(k))) + z_AD(i2(k)) = z_TL(i2(k))+diffz(i2(k)) + z_AD(i12(k))= z_AD(i12(k))+(lightptr%jac_udxi4(k)*horiz_adv_AD(i4(k))) + rv(i4(k)) = rv(i4(k))+(lightptr%jac_zdyi4(k)*horiz_adv_AD(i4(k))) + ru(i4(k)) = ru(i4(k))+(lightptr%jac_zdxi4(k)*horiz_adv_AD(i4(k))) + + enddo + +! Adjoint of q and t from the Calculation of Height (z) + + do k=nsig-1,2,-1 + + rq(i1(k))=rq(i1(k))+lightptr%jac_vertqi1(k)*z_AD(i1(k)) + rt(i1(k))=rt(i1(k))+lightptr%jac_vertti1(k)*z_AD(i1(k)) + z_AD(i1(k-1))=z_AD(i1(k-1))+z_AD(i1(k)) + z_AD(i1(k))=zero + + rq(i2(k))=rq(i2(k))+lightptr%jac_vertqi2(k)*z_AD(i2(k)) + rt(i2(k))=rt(i2(k))+lightptr%jac_vertti12(k)*z_AD(i2(k)) + z_AD(i2(k-1))=z_AD(i2(k-1))+z_AD(i2(k)) + z_AD(i2(k))=zero + + rq(i3(k))=rq(i3(k))+lightptr%jac_vertqi3(k)*z_AD(i3(k)) + rt(i3(k))=rt(i3(k))+lightptr%jac_vertti3(k)*z_AD(i3(k)) + z_AD(i3(k-1))=z_AD(i3(k-1))+z_AD(i3(k)) + z_AD(i3(k))=zero + + rq(i4(k))=rq(i4(k))+lightptr%jac_vertqi4(k)*z_AD(i4(k)) + rt(i4(k))=rt(i4(k))+lightptr%jac_vertti4(k)*z_AD(i4(k)) + z_AD(i4(k-1))=z_AD(i4(k-1))+z_AD(i4(k)) + z_AD(i4(k))=zero + + rq(i5(k))=rq(i5(k))+lightptr%jac_vertqi5(k)*z_AD(i5(k)) + rt(i5(k))=rt(i5(k))+lightptr%jac_vertti5(k)*z_AD(i5(k)) + z_AD(i5(k-1))=z_AD(i5(k-1))+z_AD(i5(k)) + z_AD(i5(k))=zero + + rq(i6(k))=rq(i6(k))+lightptr%jac_vertqi6(k)*z_AD(i6(k)) + rt(i6(k))=rt(i6(k))+lightptr%jac_vertti6(k)*z_AD(i6(k)) + z_AD(i6(k-1))=z_AD(i6(k-1))+z_AD(i6(k)) + z_AD(i6(k))=zero + + rq(i7(k))=rq(i7(k))+lightptr%jac_vertqi7(k)*z_AD(i7(k)) + rt(i7(k))=rt(i7(k))+lightptr%jac_vertti7(k)*z_AD(i7(k)) + z_AD(i7(k-1))=z_AD(i7(k-1))+z_AD(i7(k)) + z_AD(i7(k))=zero + + rq(i8(k))=rq(i8(k))+lightptr%jac_vertqi8(k)*z_AD(i8(k)) + rt(i8(k))=rt(i8(k))+lightptr%jac_vertti8(k)*z_AD(i8(k)) + z_AD(i8(k-1))=z_AD(i8(k-1))+z_AD(i8(k)) + z_AD(i8(k))=zero + + rq(i9(k))=rq(i9(k))+lightptr%jac_vertqi9(k)*z_AD(i9(k)) + rt(i9(k))=rt(i9(k))+lightptr%jac_vertti9(k)*z_AD(i9(k)) + z_AD(i9(k-1))=z_AD(i9(k-1))+z_AD(i9(k)) + z_AD(i9(k))=zero + + rq(i10(k))=rq(i10(k))+lightptr%jac_vertqi10(k)*z_AD(i10(k)) + rt(i10(k))=rt(i10(k))+lightptr%jac_vertti10(k)*z_AD(i10(k)) + z_AD(i10(k-1))=z_AD(i10(k-1))+z_AD(i10(k)) + z_AD(i10(k))=zero + + rq(i11(k))=rq(i11(k))+lightptr%jac_vertqi11(k)*z_AD(i11(k)) + rt(i11(k))=rt(i11(k))+lightptr%jac_vertti11(k)*z_AD(i11(k)) + z_AD(i11(k-1))=z_AD(i11(k-1))+z_AD(i11(k)) + z_AD(i11(k))=zero + + rq(i12(k))=rq(i12(k))+lightptr%jac_vertqi12(k)*z_AD(i12(k)) + rt(i12(k))=rt(i12(k))+lightptr%jac_vertti12(k)*z_AD(i12(k)) + z_AD(i12(k-1))=z_AD(i12(k-1))+z_AD(i12(k)) + z_AD(i12(k))=zero + + enddo + + + endif !Adjoint + + lightptr => lightNode_nextcast(lightptr) + + enddo ! do while (associated(lightptr)) + + + return +end subroutine intlight_ + +end module intlightmod diff --git a/src/gsi/intlwcp.f90 b/src/gsi/intlwcp.f90 new file mode 100644 index 000000000..fac9c9794 --- /dev/null +++ b/src/gsi/intlwcp.f90 @@ -0,0 +1,251 @@ +module intlwcpmod + +!$$$ module documentation block +! . . . . +! module: intlwcpmod module for intlwcp and its tangent linear intlwcp_tl +! prgmmr: +! +! abstract: module for intlwcp and its tangent linear intlwcp_tl +! +! program history log: +! +! subroutines included: +! sub intlwcp_ +! +! variable definitions: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use m_obsNode, only: obsNode +use m_lwcpNode, only: lwcpNode +use m_lwcpNode, only: lwcpNode_typecast +use m_lwcpNode, only: lwcpNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set +implicit none + +PRIVATE +PUBLIC intlwcp + +interface intlwcp; module procedure & + intlwcp_ +end interface + +contains + +subroutine intlwcp_(lwcphead,rval,sval) +!$$$ subprogram documentation block +! . . . . +! subprogram: intlwcp apply nonlin qc obs operator for lwcp +! prgmmr: Ting-Chi Wu org: CIRA/CSU date: 2017-06-28 +! +! abstract: apply observation operator and adjoint for solid-water content path +! with addition of nonlinear qc. +! +! program history log: +! 2017-06-28 Ting-Chi Wu - mimic the structure in intpw.f90 and intgps.f90 +! - intlwcp.f90 includes 2 TL/ADJ options +! 1) when l_wcp_cwm = .false.: +! operator = f(T,P,q) +! 2) when l_wcp_cwm = .true. and CWM partition6: +! operator = f(ql,qr) partition6 +! +! input argument list: +! lwcphead - obs type pointer to obs structure +! st - t increment in grid space +! sp - p increment in grid space +! sq - q increment in grid space +! sql - ql increment in grid space +! sqr - qr increment in grid space +! +! output argument list: +! rt - results of t from lwcp observation operator +! rp - results of p from lwcp observation operator +! rq - results of q from lwcp observation operator +! rql - results of ql from lwcp observation operator +! rqr - results of qr from lwcp observation operator +! +! comments: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind + use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag + use obsmod, only: l_wcp_cwm + use gridmod, only: nsig + use qcmod, only: nlnqc_iter,varqc_iter + use constants, only: zero,half,one,tiny_r_kind,cg_term,r3600 + use jfunc, only: jiter + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_4dvar, only: ladtest_obs + implicit none + +! Declare passed variables + class(obsNode), pointer, intent(in ) :: lwcphead + type(gsi_bundle) ,intent(in ) :: sval + type(gsi_bundle) ,intent(inout) :: rval + +! Declare local variables + integer(i_kind) k,ier,istatus + integer(i_kind),dimension(nsig):: i1,i2,i3,i4 +! real(r_kind) penalty + real(r_kind) :: t_TL,p_TL,q_TL + real(r_kind) :: t_AD,p_AD,q_AD + real(r_kind) :: ql_TL,qr_TL + real(r_kind) :: ql_AD,qr_AD + real(r_kind) val,w1,w2,w3,w4 + real(r_kind) cg_lwcp,grad,p0,wnotgross,wgross,pg_lwcp + real(r_kind),pointer,dimension(:) :: st, sp, sq + real(r_kind),pointer,dimension(:) :: sql, sqr + real(r_kind),pointer,dimension(:) :: rt, rp, rq + real(r_kind),pointer,dimension(:) :: rql, rqr + type(lwcpNode), pointer :: lwcpptr + +! If no lwcp data return + if(.not. associated(lwcphead))return +! Retrieve pointers +! Simply return if any pointer not found + ier=0 + + if (.not.l_wcp_cwm) then + + call gsi_bundlegetpointer(sval,'tsen',st,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'prse',sp,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'q' ,sq,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'tsen',rt,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'prse',rp,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'q' ,rq,istatus);ier=istatus+ier + + else + + call gsi_bundlegetpointer(sval,'ql',sql,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qr',sqr,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'ql',rql,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qr',rqr,istatus);ier=istatus+ier + + endif ! l_wcp_cwm + + if(ier/=0)return + + !lwcpptr => lwcphead + lwcpptr => lwcpNode_typecast(lwcphead) + do while (associated(lwcpptr)) + + w1=lwcpptr%wij(1) + w2=lwcpptr%wij(2) + w3=lwcpptr%wij(3) + w4=lwcpptr%wij(4) + do k=1,nsig + i1(k)=lwcpptr%ij(1,k) + i2(k)=lwcpptr%ij(2,k) + i3(k)=lwcpptr%ij(3,k) + i4(k)=lwcpptr%ij(4,k) + enddo + + val=zero + +! Forward model + + if (.not.l_wcp_cwm) then + do k=1,nsig + t_TL=w1* st(i1(k))+w2* st(i2(k))+w3* st(i3(k))+w4* st(i4(k)) + p_TL=w1* sp(i1(k))+w2* sp(i2(k))+w3* sp(i3(k))+w4* sp(i4(k)) + q_TL=w1* sq(i1(k))+w2* sq(i2(k))+w3* sq(i3(k))+w4* sq(i4(k)) + val = val + ( t_TL*lwcpptr%jac_t(k) + & + p_TL*lwcpptr%jac_p(k) + & + q_TL*lwcpptr%jac_q(k) ) ! tpwcon*r10*(piges(k)-piges(k+1)) already did in setuplwcp.f90 + end do + else + do k=1,nsig + ql_TL=w1* sql(i1(k))+w2* sql(i2(k))+w3* sql(i3(k))+w4* sql(i4(k)) + qr_TL=w1* sqr(i1(k))+w2* sqr(i2(k))+w3* sqr(i3(k))+w4* sqr(i4(k)) + val = val + ( ql_TL*lwcpptr%jac_ql(k) + & + qr_TL*lwcpptr%jac_qr(k) ) ! tpwcon*r10*(piges(k)-piges(k+1)) already did in setuplwcp.f90 + end do + endif ! l_wcp_cwm + + if(luse_obsdiag)then + if (lsaveobsens) then + grad = val*lwcpptr%raterr2*lwcpptr%err2 + !-- lwcpptr%diags%obssen(jiter) = grad + call obsdiagNode_set(lwcpptr%diags,jiter=jiter,obssen=grad) + else + !-- if (lwcpptr%luse) lwcpptr%diags%tldepart(jiter)=val + if (lwcpptr%luse) call obsdiagNode_set(lwcpptr%diags,jiter=jiter,tldepart=val) + endif + end if + + if (l_do_adjoint) then + if (.not. lsaveobsens) then +! Difference from observation + if( .not. ladtest_obs) val=val-lwcpptr%res +! needed for gradient of nonlinear qc operator + if (nlnqc_iter .and. lwcpptr%pg > tiny_r_kind .and. & + lwcpptr%b > tiny_r_kind) then + pg_lwcp=lwcpptr%pg*varqc_iter + cg_lwcp=cg_term/lwcpptr%b + wnotgross= one-pg_lwcp + wgross = pg_lwcp*cg_lwcp/wnotgross + p0 = wgross/(wgross+exp(-half*lwcpptr%err2*val**2)) + val = val*(one-p0) + endif + if( ladtest_obs) then + grad = val + else + grad = val*lwcpptr%raterr2*lwcpptr%err2 + end if + endif + +! Adjoint + + if (.not.l_wcp_cwm) then + do k=1,nsig + t_AD = grad*lwcpptr%jac_t(k) + rt(i1(k))=rt(i1(k))+w1*t_AD + rt(i2(k))=rt(i2(k))+w2*t_AD + rt(i3(k))=rt(i3(k))+w3*t_AD + rt(i4(k))=rt(i4(k))+w4*t_AD + p_AD = grad*lwcpptr%jac_p(k) + rp(i1(k))=rp(i1(k))+w1*p_AD + rp(i2(k))=rp(i2(k))+w2*p_AD + rp(i3(k))=rp(i3(k))+w3*p_AD + rp(i4(k))=rp(i4(k))+w4*p_AD + q_AD = grad*lwcpptr%jac_q(k) + rq(i1(k))=rq(i1(k))+w1*q_AD + rq(i2(k))=rq(i2(k))+w2*q_AD + rq(i3(k))=rq(i3(k))+w3*q_AD + rq(i4(k))=rq(i4(k))+w4*q_AD + enddo + else + do k=1,nsig + ql_AD = grad*lwcpptr%jac_ql(k) + rql(i1(k))=rql(i1(k))+w1*ql_AD + rql(i2(k))=rql(i2(k))+w2*ql_AD + rql(i3(k))=rql(i3(k))+w3*ql_AD + rql(i4(k))=rql(i4(k))+w4*ql_AD + qr_AD = grad*lwcpptr%jac_qr(k) + rqr(i1(k))=rqr(i1(k))+w1*qr_AD + rqr(i2(k))=rqr(i2(k))+w2*qr_AD + rqr(i3(k))=rqr(i3(k))+w3*qr_AD + rqr(i4(k))=rqr(i4(k))+w4*qr_AD + enddo + endif ! l_wcp_cwm + + endif ! l_do_adjoint + + !lwcpptr => lwcpptr%llpoint + lwcpptr => lwcpNode_nextcast(lwcpptr) + + end do + + return +end subroutine intlwcp_ + +end module intlwcpmod diff --git a/src/intmitm.f90 b/src/gsi/intmitm.f90 similarity index 92% rename from src/intmitm.f90 rename to src/gsi/intmitm.f90 index 6ac3cb977..97b8e3e9a 100644 --- a/src/intmitm.f90 +++ b/src/gsi/intmitm.f90 @@ -25,6 +25,7 @@ module intmitmmod use m_mitmNode, only: mitmNode use m_mitmNode, only: mitmNode_typecast use m_mitmNode, only: mitmNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -111,9 +112,11 @@ subroutine intmitm(mitmhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*mitmptr%raterr2*mitmptr%err2 - mitmptr%diags%obssen(jiter) = grad + !-- mitmptr%diags%obssen(jiter) = grad + call obsdiagNode_set(mitmptr%diags,jiter=jiter,obssen=grad) else - if (mitmptr%luse) mitmptr%diags%tldepart(jiter)=val + !-- if (mitmptr%luse) mitmptr%diags%tldepart(jiter)=val + if (mitmptr%luse) call obsdiagNode_set(mitmptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intmxtm.f90 b/src/gsi/intmxtm.f90 similarity index 92% rename from src/intmxtm.f90 rename to src/gsi/intmxtm.f90 index 2c739cbf0..487344672 100644 --- a/src/intmxtm.f90 +++ b/src/gsi/intmxtm.f90 @@ -25,6 +25,7 @@ module intmxtmmod use m_mxtmNode, only: mxtmNode use m_mxtmNode, only: mxtmNode_typecast use m_mxtmNode, only: mxtmNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -111,9 +112,11 @@ subroutine intmxtm(mxtmhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*mxtmptr%raterr2*mxtmptr%err2 - mxtmptr%diags%obssen(jiter) = grad + !-- mxtmptr%diags%obssen(jiter) = grad + call obsdiagNode_set(mxtmptr%diags,jiter=jiter,obssen=grad) else - if (mxtmptr%luse) mxtmptr%diags%tldepart(jiter)=val + !-- if (mxtmptr%luse) mxtmptr%diags%tldepart(jiter)=val + if (mxtmptr%luse) call obsdiagNode_set(mxtmptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intoz.f90 b/src/gsi/intoz.f90 similarity index 85% rename from src/intoz.f90 rename to src/gsi/intoz.f90 index c863c1d72..a727e20d8 100644 --- a/src/intoz.f90 +++ b/src/gsi/intoz.f90 @@ -15,11 +15,11 @@ module intozmod ! 2012-09-14 Syed RH Rizvi, NCAR/NESL/MMM/DAS - implemented obs adjoint test ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting ! 2016-08-29 J. Guo - added individual interfaces, intozlay() and intozlev() +! 2018-07-13 J. Guo - splitted original module intozmod into this intozmod with +! subroutine intozlay() only, and module into3lmod below. ! ! subroutines included: -! sub intoz_ ! sub intozlay_ -! sub intozlev_ ! ! variable definitions: ! @@ -33,62 +33,12 @@ module intozmod implicit none PRIVATE -PUBLIC intoz public:: intozlay -public:: intozlev -interface intoz; module procedure & - intoz_ -end interface interface intozlay; module procedure intozlay_; end interface -interface intozlev; module procedure intozlev_; end interface contains -subroutine intoz_(ozhead,o3lhead,rval,sval) - -!$$$ subprogram documentation block -! . . . . -! subprogram: intoz call individual ozone obs operators -! prgmmr: todling org: np23 date: 2008-11-28 -! -! abstract: This routine calls the individual components of the -! ozone observation operator. -! -! program history log: -! 2008-11-28 todling -! 2009-01-08 todling - remove reference to ozohead -! 2010-05-13 todling - update to use gsi_bundle -! -! input argument list: -! ozhead - layer ozone obs type pointer to obs structure -! o3lhead - level ozone obs type pointer to obs structure -! soz - ozone increment in grid space -! -! output argument list: -! roz - ozone results from observation operator -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ -!-------- - use gsi_bundlemod, only: gsi_bundle - implicit none - -! Declare passed variables - class(obsNode),pointer,intent(in):: ozhead - class(obsNode),pointer,intent(in):: o3lhead - type(gsi_bundle),intent(in ) :: sval - type(gsi_bundle),intent(inout) :: rval - -! If obs exist call int routines - if(associated(ozhead))call intozlay_( ozhead,rval,sval) - if(associated(o3lhead))call intozlev_(o3lhead,rval,sval) - -end subroutine intoz_ - subroutine intozlay_(ozhead,rval,sval) !$$$ subprogram documentation block ! . . . . @@ -150,6 +100,8 @@ subroutine intozlay_(ozhead,rval,sval) use m_ozNode , only: ozNode use m_ozNode , only: ozNode_typecast use m_ozNode , only: ozNode_nextcast + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_set implicit none ! Declare passed variables @@ -162,6 +114,7 @@ subroutine intozlay_(ozhead,rval,sval) integer(i_kind) k,j1,j2,j3,j4,kk,iz1,iz2,kl real(r_kind) dz1,pob,delz real(r_quad) val1,valx + !-- real(r_kind) valx_ real(r_kind) w1,w2,w3,w4 real(r_kind),pointer,dimension(:,:,:) :: sozp real(r_kind),pointer,dimension(:,:,:) :: rozp @@ -234,9 +187,11 @@ subroutine intozlay_(ozhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then valx=val1*ozptr%err2(k)*ozptr%raterr2(k) - ozptr%diags(k)%ptr%obssen(jiter)=valx + !-- ozptr%diags(k)%ptr%obssen(jiter)=valx + call obsdiagNode_set(ozptr%diags(k)%ptr,jiter=jiter,obssen=real(valx,r_kind)) else - if (ozptr%luse) ozptr%diags(k)%ptr%tldepart(jiter)=val1 + !-- if (ozptr%luse) ozptr%diags(k)%ptr%tldepart(jiter)=val1 + if (ozptr%luse) call obsdiagNode_set(ozptr%diags(k)%ptr,jiter=jiter,tldepart=real(val1,r_kind)) endif endif @@ -323,9 +278,11 @@ subroutine intozlay_(ozhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then valx=val1*ozptr%err2(k)*ozptr%raterr2(k) - ozptr%diags(k)%ptr%obssen(jiter)=valx + !-- ozptr%diags(k)%ptr%obssen(jiter)=valx + call obsdiagNode_set(ozptr%diags(k)%ptr,jiter=jiter,obssen=real(valx,r_kind)) else - if (ozptr%luse) ozptr%diags(k)%ptr%tldepart(jiter)=val1 + !-- if (ozptr%luse) ozptr%diags(k)%ptr%tldepart(jiter)=val1 + if (ozptr%luse) call obsdiagNode_set(ozptr%diags(k)%ptr,jiter=jiter,tldepart=real(val1,r_kind)) endif endif @@ -354,7 +311,16 @@ subroutine intozlay_(ozhead,rval,sval) enddo else ! OMI ozone with efficiency factor if (lsaveobsens) then - valx = ozptr%diags(k)%ptr%obssen(jiter) + ! Precondition: luse_obsdiag .or. .not.lsaveobsens + ! ------------------------------------------------- + ! lsaveobsens implies luse_obsdiag in a valid configuration. So + ! there is no need to get valx back from %diags(k)%ptr%obssen(jiter). + ! Also, this operation to get the value back from %obssen(jiter) will + ! result an accuracy lost due to the kind difference between valx and + ! %obssen(:). + !-- valx = ozptr%diags(k)%ptr%obssen(jiter) ! or ... + !-- call obsdiagNode_get(ozptr%diags(k)%ptr,jiter=jiter,obssen=valx_) + !-- valx=valx_ ! see vlax_ declaration on the top) else if(ladtest_obs) then valx=val1 @@ -412,6 +378,42 @@ subroutine intozlay_(ozhead,rval,sval) ! End of routine return end subroutine intozlay_ +end module intozmod + +module into3lmod + +!$$$ module documentation block +! . . . . +! module: intozlevmod module for intozlev() +! prgmmr: +! +! abstract: module for intozlev() +! +! program history log: +! 2018-07-13 J. Guo - splitted from original module intozmod into this into3lmod +! with subroutine intozlev(). See intozmod for more +! about earlier history logs. +! +! subroutines included: +! sub intozlev_ +! +! variable definitions: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use m_obsNode, only: obsNode +implicit none + +PRIVATE +public:: intozlev + +interface intozlev; module procedure intozlev_; end interface + +contains subroutine intozlev_(o3lhead,rval,sval) !$$$ subprogram documentation block @@ -461,6 +463,7 @@ subroutine intozlev_(o3lhead,rval,sval) use m_o3lNode, only: o3lNode use m_o3lNode, only: o3lNode_typecast use m_o3lNode, only: o3lNode_nextcast + use m_obsdiagNode, only: obsdiagNode_set implicit none ! Declare passed variables @@ -516,12 +519,14 @@ subroutine intozlev_(o3lhead,rval,sval) val=w1*soz1d(j1)+w2*soz1d(j2)+w3*soz1d(j3)+w4*soz1d(j4)+ & w5*soz1d(j5)+w6*soz1d(j6)+w7*soz1d(j7)+w8*soz1d(j8) - if (luse_obsdiag ) then + if (luse_obsdiag ) then ! need to save either obssen=grad or tldepart=val if (lsaveobsens) then grad = val*o3lptr%raterr2*o3lptr%err2 - o3lptr%diags%obssen(jiter) = grad + !-- o3lptr%diags%obssen(jiter) = grad + call obsdiagNode_set(o3lptr%diags,jiter=jiter,obssen=grad) else - if (o3lptr%luse) o3lptr%diags%tldepart(jiter)=val + !-- if (o3lptr%luse) o3lptr%diags%tldepart(jiter)=val + if (o3lptr%luse) call obsdiagNode_set(o3lptr%diags,jiter=jiter,tldepart=val) endif endif @@ -557,4 +562,4 @@ subroutine intozlev_(o3lhead,rval,sval) end subroutine intozlev_ -end module intozmod +end module into3lmod diff --git a/src/intpblh.f90 b/src/gsi/intpblh.f90 similarity index 93% rename from src/intpblh.f90 rename to src/gsi/intpblh.f90 index cedc6a55b..b5e9d7155 100644 --- a/src/intpblh.f90 +++ b/src/gsi/intpblh.f90 @@ -26,6 +26,7 @@ module intpblhmod use m_pblhNode, only: pblhNode use m_pblhNode, only: pblhNode_typecast use m_pblhNode, only: pblhNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -112,9 +113,11 @@ subroutine intpblh(pblhhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*pblhptr%raterr2*pblhptr%err2 - pblhptr%diags%obssen(jiter) = grad + !-- pblhptr%diags%obssen(jiter) = grad + call obsdiagNode_set(pblhptr%diags,jiter=jiter,obssen=grad) else - if (pblhptr%luse) pblhptr%diags%tldepart(jiter)=val + !-- if (pblhptr%luse) pblhptr%diags%tldepart(jiter)=val + if (pblhptr%luse) call obsdiagNode_set(pblhptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intpcp.f90 b/src/gsi/intpcp.f90 similarity index 97% rename from src/intpcp.f90 rename to src/gsi/intpcp.f90 index e52f96abb..991c5fb62 100644 --- a/src/intpcp.f90 +++ b/src/gsi/intpcp.f90 @@ -29,6 +29,7 @@ module intpcpmod use m_pcpNode, only: pcpNode use m_pcpNode, only: pcpNode_typecast use m_pcpNode, only: pcpNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -239,9 +240,11 @@ subroutine intpcp_(pcphead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then termges_ad = termges_tl*pcpptr%err2*pcpptr%raterr2 - pcpptr%diags%obssen(jiter) = termges_ad + !-- pcpptr%diags%obssen(jiter) = termges_ad + call obsdiagNode_set(pcpptr%diags,jiter=jiter,obssen=termges_ad) else - if (pcpptr%luse) pcpptr%diags%tldepart(jiter)=termges_tl + !-- if (pcpptr%luse) pcpptr%diags%tldepart(jiter)=termges_tl + if (pcpptr%luse) call obsdiagNode_set(pcpptr%diags,jiter=jiter,tldepart=termges_tl) endif endif diff --git a/src/intpm10.f90 b/src/gsi/intpm10.f90 similarity index 97% rename from src/intpm10.f90 rename to src/gsi/intpm10.f90 index 3e65d107a..92e831e22 100644 --- a/src/intpm10.f90 +++ b/src/gsi/intpm10.f90 @@ -26,6 +26,8 @@ module intpm10mod use m_pm10Node, only: pm10Node use m_pm10Node, only: pm10Node_typecast use m_pm10Node, only: pm10Node_nextcast + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_set implicit none private @@ -338,15 +340,18 @@ subroutine intpm10_(pm10head,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then - pm10ptr%diags%obssen(jiter) = val*pm10ptr%raterr2*pm10ptr%err2 + !-- pm10ptr%diags%obssen(jiter) = val*pm10ptr%raterr2*pm10ptr%err2 + call obsdiagNode_set(pm10ptr%diags,jiter=jiter,obssen=val*pm10ptr%raterr2*pm10ptr%err2) else - if (pm10ptr%luse) pm10ptr%diags%tldepart(jiter)=val + !-- if (pm10ptr%luse) pm10ptr%diags%tldepart(jiter)=val + if (pm10ptr%luse) call obsdiagNode_set(pm10ptr%diags,jiter=jiter,tldepart=val) endif endif if (l_do_adjoint) then if (lsaveobsens) then - grad = pm10ptr%diags%obssen(jiter) + !-- grad = pm10ptr%diags%obssen(jiter) + call obsdiagNode_get(pm10ptr%diags,jiter=jiter,obssen=grad) else if( .not. ladtest_obs ) val=val-pm10ptr%res diff --git a/src/intpm2_5.f90 b/src/gsi/intpm2_5.f90 similarity index 94% rename from src/intpm2_5.f90 rename to src/gsi/intpm2_5.f90 index b278f5756..33467c32c 100644 --- a/src/intpm2_5.f90 +++ b/src/gsi/intpm2_5.f90 @@ -26,6 +26,8 @@ module intpm2_5mod use m_pm2_5Node, only: pm2_5Node use m_pm2_5Node, only: pm2_5Node_typecast use m_pm2_5Node, only: pm2_5Node_nextcast + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_set implicit none private @@ -132,15 +134,18 @@ subroutine intpm2_5_(pm2_5head,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then - pm2_5ptr%diags%obssen(jiter) = val*pm2_5ptr%raterr2*pm2_5ptr%err2 + !-- pm2_5ptr%diags%obssen(jiter) = val*pm2_5ptr%raterr2*pm2_5ptr%err2 + call obsdiagNode_set(pm2_5ptr%diags,jiter=jiter,obssen=val*pm2_5ptr%raterr2*pm2_5ptr%err2) else - if (pm2_5ptr%luse) pm2_5ptr%diags%tldepart(jiter)=val + !-- if (pm2_5ptr%luse) pm2_5ptr%diags%tldepart(jiter)=val + if (pm2_5ptr%luse) call obsdiagNode_set(pm2_5ptr%diags,jiter=jiter,tldepart=val) endif endif if (l_do_adjoint) then if (lsaveobsens) then - grad = pm2_5ptr%diags%obssen(jiter) + !-- grad = pm2_5ptr%diags%obssen(jiter) + call obsdiagNode_get(pm2_5ptr%diags,jiter=jiter,obssen=grad) else if( .not. ladtest_obs ) val=val-pm2_5ptr%res @@ -366,15 +371,18 @@ subroutine intpm2_5_(pm2_5head,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then - pm2_5ptr%diags%obssen(jiter) = val*pm2_5ptr%raterr2*pm2_5ptr%err2 + !-- pm2_5ptr%diags%obssen(jiter) = val*pm2_5ptr%raterr2*pm2_5ptr%err2 + call obsdiagNode_set(pm2_5ptr%diags,jiter=jiter,obssen=val*pm2_5ptr%raterr2*pm2_5ptr%err2) else - if (pm2_5ptr%luse) pm2_5ptr%diags%tldepart(jiter)=val + !-- if (pm2_5ptr%luse) pm2_5ptr%diags%tldepart(jiter)=val + if (pm2_5ptr%luse) call obsdiagNode_set(pm2_5ptr%diags,jiter=jiter,tldepart=val) endif endif if (l_do_adjoint) then if (lsaveobsens) then - grad = pm2_5ptr%diags%obssen(jiter) + !-- grad = pm2_5ptr%diags%obssen(jiter) + call obsdiagNode_get(pm2_5ptr%diags,jiter=jiter,obssen=grad) else if( .not. ladtest_obs ) val=val-pm2_5ptr%res diff --git a/src/intpmsl.f90 b/src/gsi/intpmsl.f90 similarity index 92% rename from src/intpmsl.f90 rename to src/gsi/intpmsl.f90 index 8c1697b72..e44190639 100644 --- a/src/intpmsl.f90 +++ b/src/gsi/intpmsl.f90 @@ -25,6 +25,7 @@ module intpmslmod use m_pmslNode, only: pmslNode use m_pmslNode, only: pmslNode_typecast use m_pmslNode, only: pmslNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -111,9 +112,11 @@ subroutine intpmsl(pmslhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*pmslptr%raterr2*pmslptr%err2 - pmslptr%diags%obssen(jiter) = grad + !-- pmslptr%diags%obssen(jiter) = grad + call obsdiagNode_set(pmslptr%diags,jiter=jiter,obssen=grad) else - if (pmslptr%luse) pmslptr%diags%tldepart(jiter)=val + !-- if (pmslptr%luse) pmslptr%diags%tldepart(jiter)=val + if (pmslptr%luse) call obsdiagNode_set(pmslptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intps.f90 b/src/gsi/intps.f90 similarity index 95% rename from src/intps.f90 rename to src/gsi/intps.f90 index 18934f22a..0da0e1191 100644 --- a/src/intps.f90 +++ b/src/gsi/intps.f90 @@ -33,6 +33,7 @@ module intpsmod use m_psNode , only: psNode use m_psNode , only: psNode_typecast use m_psNode , only: psNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -143,9 +144,11 @@ subroutine intps_(pshead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*psptr%raterr2*psptr%err2 - psptr%diags%obssen(jiter) = grad + !-- psptr%diags%obssen(jiter) = grad + call obsdiagNode_set(psptr%diags,jiter=jiter,obssen=grad) else - if (psptr%luse) psptr%diags%tldepart(jiter)=val + !-- if (psptr%luse) psptr%diags%tldepart(jiter)=val + if (psptr%luse) call obsdiagNode_set(psptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intpw.f90 b/src/gsi/intpw.f90 similarity index 95% rename from src/intpw.f90 rename to src/gsi/intpw.f90 index 2934d9306..69835a504 100644 --- a/src/intpw.f90 +++ b/src/gsi/intpw.f90 @@ -30,6 +30,7 @@ module intpwmod use m_pwNode, only: pwNode use m_pwNode, only: pwNode_typecast use m_pwNode, only: pwNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -157,9 +158,11 @@ subroutine intpw_(pwhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*pwptr%raterr2*pwptr%err2 - pwptr%diags%obssen(jiter) = grad + !-- pwptr%diags%obssen(jiter) = grad + call obsdiagNode_set(pwptr%diags,jiter=jiter,obssen=grad) else - if (pwptr%luse) pwptr%diags%tldepart(jiter)=val + !-- if (pwptr%luse) pwptr%diags%tldepart(jiter)=val + if (pwptr%luse) call obsdiagNode_set(pwptr%diags,jiter=jiter,tldepart=val) endif end if diff --git a/src/intq.f90 b/src/gsi/intq.f90 similarity index 95% rename from src/intq.f90 rename to src/gsi/intq.f90 index 85ec796b8..ef7cba5f3 100644 --- a/src/intq.f90 +++ b/src/gsi/intq.f90 @@ -32,6 +32,7 @@ module intqmod use m_qNode, only: qNode use m_qNode, only: qNode_typecast use m_qNode, only: qNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -149,9 +150,11 @@ subroutine intq_(qhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*qptr%raterr2*qptr%err2 - qptr%diags%obssen(jiter) = grad + !-- qptr%diags%obssen(jiter) = grad + call obsdiagNode_set(qptr%diags,jiter=jiter,obssen=grad) else - if (qptr%luse) qptr%diags%tldepart(jiter)=val + !-- if (qptr%luse) qptr%diags%tldepart(jiter)=val + if (qptr%luse) call obsdiagNode_set(qptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intrad.f90 b/src/gsi/intrad.f90 similarity index 87% rename from src/intrad.f90 rename to src/gsi/intrad.f90 index 515711410..6d3f0f330 100644 --- a/src/intrad.f90 +++ b/src/gsi/intrad.f90 @@ -34,6 +34,7 @@ module intradmod use m_radNode, only: radNode use m_radNode, only: radNode_typecast use m_radNode, only: radNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -248,7 +249,8 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) ! 2012-09-14 Syed RH Rizvi, NCAR/NESL/MMM/DAS - introduced ladtest_obs ! 2015-04-01 W. Gu - scale the bias correction term to handle the ! - inter-channel correlated obs errors. -! 2016-07-19 kbathmann - move decomposition of correlated R to outer loop. +! 2019-04-22 kbathmann/W. Gu - use of Cholesky factoriztion of R to update the bias correction term +! 2019-08-14 W. Gu/guo- speed up bias correction term in the case of the correlated obs ! ! input argument list: ! radhead - obs type pointer to obs structure @@ -288,7 +290,7 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) use jfunc, only: jiter use gridmod, only: latlon11,nsig use qcmod, only: nlnqc_iter,varqc_iter - use constants, only: zero,half,one,tiny_r_kind,cg_term,r3600 + use constants, only: zero,half,one,tiny_r_kind,cg_term,r3600,zero_quad use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_metguess_mod, only: gsi_metguess_get @@ -305,7 +307,7 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) real(r_quad),dimension(npred*jpch_rad),intent(inout) :: rpred ! Declare local variables - integer(i_kind) j1,j2,j3,j4,i1,i2,i3,i4,n,k,ic,ix,nn,mm + integer(i_kind) j1,j2,j3,j4,i1,i2,i3,i4,n,k,ic,ix,nn,mm,ncr1,ncr2 integer(i_kind) ier,istatus integer(i_kind),dimension(nsig) :: i1n,i2n,i3n,i4n real(r_kind),allocatable,dimension(:):: val @@ -313,13 +315,13 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) real(r_kind),dimension(nsigradjac):: tval,tdir real(r_kind) cg_rad,p0,wnotgross,wgross type(radNode), pointer :: radptr - real(r_kind),allocatable,dimension(:,:) :: rsqrtinv + real(r_kind),allocatable,dimension(:) :: biasvect integer(i_kind) :: ic1,ix1 - integer(i_kind) :: chan_count, ii, jj real(r_kind),pointer,dimension(:) :: st,sq,scw,soz,su,sv,sqg,sqh,sqi,sql,sqr,sqs real(r_kind),pointer,dimension(:) :: sst real(r_kind),pointer,dimension(:) :: rt,rq,rcw,roz,ru,rv,rqg,rqh,rqi,rql,rqr,rqs real(r_kind),pointer,dimension(:) :: rst + real(r_quad) :: val_quad ! If no rad observations return if(.not.associated(radhead)) return @@ -394,17 +396,6 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) w2=radptr%wij(2) w3=radptr%wij(3) w4=radptr%wij(4) - if (radptr%use_corr_obs) then - allocate(rsqrtinv(radptr%nchan,radptr%nchan)) - chan_count=0 - do ii=1,radptr%nchan - do jj=ii,radptr%nchan - chan_count=chan_count+1 - rsqrtinv(ii,jj)=radptr%rsqrtinv(chan_count) - rsqrtinv(jj,ii)=radptr%rsqrtinv(chan_count) - end do - end do - end if ! Begin Forward model ! calculate temperature, q, ozone, sst vector at observation location i1n(1) = j1 @@ -482,6 +473,21 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) ! For all other configurations ! begin channel specific calculations allocate(val(radptr%nchan)) + + if (.not. ladtest_obs) then + allocate(biasvect(radptr%nchan)) + do nn=1,radptr%nchan + ic1=radptr%icx(nn) + ix1=(ic1-1)*npred + val_quad = zero_quad + do n=1,npred + val_quad = val_quad + spred(ix1+n)*radptr%pred(n,nn) + end do + biasvect(nn) = val_quad + end do + end if + ncr1=0 + do nn=1,radptr%nchan ic=radptr%icx(nn) ix=(ic-1)*npred @@ -497,31 +503,32 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) ! Include contributions from remaining bias correction terms if( .not. ladtest_obs) then if(radptr%use_corr_obs)then - do n=1,npred - do mm=1,radptr%nchan - ic1=radptr%icx(mm) - ix1=(ic1-1)*npred - val(nn)=val(nn)+rsqrtinv(nn,mm)*spred(ix1+n)*radptr%pred(n,mm) - enddo + val_quad = zero_quad + do mm=1,nn + ncr1=ncr1+1 + val_quad=val_quad+radptr%rsqrtinv(ncr1)*biasvect(mm) enddo + val(nn)=val(nn) + val_quad else - do n=1,npred - val(nn)=val(nn)+spred(ix+n)*radptr%pred(n,nn) - end do + val(nn)=val(nn)+biasvect(nn) endif end if - if(luse_obsdiag)then if (lsaveobsens) then - val(nn) = val(nn)*radptr%err2(nn)*radptr%raterr2(nn) - radptr%diags(nn)%ptr%obssen(jiter) = val(nn) + val(nn)=val(nn)*radptr%err2(nn)*radptr%raterr2(nn) + !-- radptr%diags(nn)%ptr%obssen(jiter) = val(nn) + call obsdiagNode_set(radptr%diags(nn)%ptr,jiter=jiter,obssen=val(nn)) else - if (radptr%luse) radptr%diags(nn)%ptr%tldepart(jiter) = val(nn) + !-- if (radptr%luse) radptr%diags(nn)%ptr%tldepart(jiter) = val(nn) + if (radptr%luse) call obsdiagNode_set(radptr%diags(nn)%ptr,jiter=jiter,tldepart=val(nn)) endif endif + end do - if (l_do_adjoint) then + if (l_do_adjoint) then + do nn=1,radptr%nchan + ic=radptr%icx(nn) if (.not. lsaveobsens) then if( .not. ladtest_obs) val(nn)=val(nn)-radptr%res(nn) @@ -535,33 +542,54 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) val(nn) = val(nn)*(one-p0) endif - if(.not. ladtest_obs )val(nn) = val(nn)*radptr%err2(nn)*radptr%raterr2(nn) + if(.not.ladtest_obs) val(nn) = val(nn)*radptr%err2(nn)*radptr%raterr2(nn) endif + enddo ! Extract contributions from bias correction terms ! use compensated summation - if( .not. ladtest_obs) then - if(radptr%luse)then - if(radptr%use_corr_obs)then - do n=1,npred - do mm=1,radptr%nchan - ic1=radptr%icx(mm) - ix1=(ic1-1)*npred - rpred(ix1+n)=rpred(ix1+n)+rsqrtinv(nn,mm)*radptr%pred(n,mm)*val(nn) - enddo - enddo - else - do n=1,npred - rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn) - end do - end if - end if - end if ! not ladtest_obs - end if - end do + + if( .not. ladtest_obs) then + if (radptr%use_corr_obs) then + ncr2 = 0 + ncr1 = 0 + do mm=1,radptr%nchan + ncr1 = ncr1 + mm + ncr2 = ncr1 + biasvect(mm) = zero + do nn=mm,radptr%nchan + biasvect(mm)=biasvect(mm)+radptr%rsqrtinv(ncr2)*val(nn) + ncr2 = ncr2 + nn + enddo + end do + endif + + if(radptr%luse)then + if(radptr%use_corr_obs)then + do mm=1,radptr%nchan + ic1=radptr%icx(mm) + ix1=(ic1-1)*npred + do n=1,npred + rpred(ix1+n)=rpred(ix1+n)+biasvect(mm)*radptr%pred(n,mm) + enddo + enddo + else + do nn=1,radptr%nchan + ic=radptr%icx(nn) + ix=(ic-1)*npred + do n=1,npred + rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn) + end do + end do + end if + end if + + deallocate(biasvect) + end if ! not ladtest_obs + + endif ! Begin adjoint - if (radptr%use_corr_obs) deallocate(rsqrtinv) if (l_do_adjoint) then do k=1,nsigradjac tval(k)=zero diff --git a/src/intrp2a.f90 b/src/gsi/intrp2a.f90 similarity index 100% rename from src/intrp2a.f90 rename to src/gsi/intrp2a.f90 diff --git a/src/intrp3oz.f90 b/src/gsi/intrp3oz.f90 similarity index 96% rename from src/intrp3oz.f90 rename to src/gsi/intrp3oz.f90 index 3f1845e97..8d16d2477 100644 --- a/src/intrp3oz.f90 +++ b/src/gsi/intrp3oz.f90 @@ -177,7 +177,7 @@ subroutine intrp3oz(f,g,dx,dy,dz,obstime,n,nlevs,mype) return end subroutine intrp3oz -subroutine intrp3oz1(f,g,dx,dy,dz,obstime,nlevs,mype) +subroutine intrp3oz1(f,g,dx,dy,dz,obstime,nlevs,mype,dg_dz) !$$$ subprogram documentation block ! . . . . ! subprogram: intrp3oz space-time linear interpolation for ozone @@ -190,6 +190,7 @@ subroutine intrp3oz1(f,g,dx,dy,dz,obstime,nlevs,mype) ! ! program history log: ! 2013-01-26 parrish +! 2016-11-29 shlyaeva - save dg/dz for linearized H(x) for EnKF ! ! input argument list: ! f - input interpolator (gridded guess ozone fields) @@ -200,6 +201,7 @@ subroutine intrp3oz1(f,g,dx,dy,dz,obstime,nlevs,mype) ! ! output argument list: ! g - output interpolatees (guess ozone at observation location) +! dg_dz - output (nsig,nlevs) derivatives ! ! attributes: ! language: f90 @@ -219,6 +221,7 @@ subroutine intrp3oz1(f,g,dx,dy,dz,obstime,nlevs,mype) real(r_kind),dimension(nlevs-1) ,intent(in ) :: dz real(r_kind),dimension(lat2,lon2,nsig,nfldsig),intent(in ) :: f real(r_kind),dimension(nlevs) ,intent( out) :: g + real(r_kind),dimension(nsig,nlevs) ,intent( out) :: dg_dz ! Declare local variables integer(i_kind) j,k,ix,ix1,iy,iy1,kk,itsig,itsigp,iz1,iz2 @@ -285,6 +288,8 @@ subroutine intrp3oz1(f,g,dx,dy,dz,obstime,nlevs,mype) ! Given horizontal (spatial) and temporal interpolate weights, loop ! over the number of layered ozone observations at the given location + dg_dz = zero + dz1=nsig+1 do k=1,nlevs-1 pob = dz(k) @@ -312,6 +317,7 @@ subroutine intrp3oz1(f,g,dx,dy,dz,obstime,nlevs,mype) + f(ixp,iy ,kk,itsigp)*w10*rozcon*delp6 & + f(ix ,iyp,kk,itsigp)*w01*rozcon*delp7 & + f(ixp,iyp,kk,itsigp)*w11*rozcon*delp8)*delz)*dtsigp + dg_dz(kk,k) = rozcon*delz*(delp1+delp2+delp3+delp4+delp5+delp6+delp7+delp8) / 8._r_kind enddo dz1=pob enddo @@ -337,6 +343,7 @@ subroutine intrp3oz1(f,g,dx,dy,dz,obstime,nlevs,mype) + f(ixp,iy ,kk,itsigp)*w10*rozcon*delp6 & + f(ix ,iyp,kk,itsigp)*w01*rozcon*delp7 & + f(ixp,iyp,kk,itsigp)*w11*rozcon*delp8)*dtsigp + dg_dz(kk,nlevs) = rozcon*(delp1+delp2+delp3+delp4+delp5+delp6+delp7+delp8) / 8._r_kind enddo ! End of routine diff --git a/src/intrp_msk.f90 b/src/gsi/intrp_msk.f90 similarity index 100% rename from src/intrp_msk.f90 rename to src/gsi/intrp_msk.f90 diff --git a/src/intrw.f90 b/src/gsi/intrw.f90 similarity index 94% rename from src/intrw.f90 rename to src/gsi/intrw.f90 index 44fc3c8e6..df3ec162a 100644 --- a/src/intrw.f90 +++ b/src/gsi/intrw.f90 @@ -29,6 +29,7 @@ module intrwmod use m_rwNode, only: rwNode use m_rwNode, only: rwNode_typecast use m_rwNode, only: rwNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -60,6 +61,7 @@ subroutine intrw_(rwhead,rval,sval) ! 2005-09-28 derber - consolidate location and weight arrays ! 2006-07-28 derber - modify to use new inner loop obs data structure ! - unify NL qc +! 2007-02-15 rancic - add foto ! 2007-03-19 tremolet - binning of observations ! 2007-06-05 tremolet - use observation diagnostics structure ! 2007-07-09 tremolet - observation sensitivity @@ -68,6 +70,8 @@ subroutine intrw_(rwhead,rval,sval) ! 2010-05-13 todlng - update to use gsi_bundle; update interface ! 2012-09-14 Syed RH Rizvi, NCAR/NESL/MMM/DAS - introduced ladtest_obs ! 2014-12-03 derber - modify so that use of obsdiags can be turned off +! 2017-05-12 Y. Wang and X. Wang - include w into tangent linear of rw operator, +! POC: xuguang.wang@ou.edu ! 2016-06-23 lippi - add terms for vertical velocity (w) in forward operator ! and adjoint code (uses include_w to check if w is ! being used). Now, the multiplications of costilt @@ -176,9 +180,11 @@ subroutine intrw_(rwhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*rwptr%raterr2*rwptr%err2 - rwptr%diags%obssen(jiter) = grad + !-- rwptr%diags%obssen(jiter) = grad + call obsdiagNode_set(rwptr%diags,jiter=jiter,obssen=grad) else - if (rwptr%luse) rwptr%diags%tldepart(jiter)=val + !-- if (rwptr%luse) rwptr%diags%tldepart(jiter)=val + if (rwptr%luse) call obsdiagNode_set(rwptr%diags,jiter=jiter,tldepart=val) endif endif @@ -235,8 +241,6 @@ subroutine intrw_(rwhead,rval,sval) rw(j7)=rw(j7)+w7*valw rw(j8)=rw(j8)+w8*valw end if - - endif !rwptr => rwptr%llpoint diff --git a/src/intspd.f90 b/src/gsi/intspd.f90 similarity index 87% rename from src/intspd.f90 rename to src/gsi/intspd.f90 index 0ce0504a4..50365e91b 100644 --- a/src/intspd.f90 +++ b/src/gsi/intspd.f90 @@ -29,6 +29,7 @@ module intspdmod use m_spdNode, only: spdNode use m_spdNode, only: spdNode_typecast use m_spdNode, only: spdNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -162,9 +163,11 @@ subroutine intspd_(spdhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad=spdptr%raterr2*spdptr%err2*spdatl - spdptr%diags%obssen(jiter)=grad + !-- spdptr%diags%obssen(jiter)=grad + call obsdiagNode_set(spdptr%diags,jiter=jiter,obssen=grad) else - if (spdptr%luse) spdptr%diags%tldepart(jiter)=spdatl + !-- if (spdptr%luse) spdptr%diags%tldepart(jiter)=spdatl + if (spdptr%luse) call obsdiagNode_set(spdptr%diags,jiter=jiter,tldepart=spdatl) endif endif @@ -184,8 +187,10 @@ subroutine intspd_(spdhead,rval,sval) endif else if(luse_obsdiag)then - if (spdptr%luse) spdptr%diags%tldepart(jiter)=zero - if (lsaveobsens) spdptr%diags%obssen(jiter)=zero + !-- if (spdptr%luse) spdptr%diags%tldepart(jiter)=zero + if (spdptr%luse) call obsdiagNode_set(spdptr%diags,jiter=jiter,tldepart=zero) + !-- if (lsaveobsens) spdptr%diags%obssen(jiter)=zero + if (lsaveobsens) call obsdiagNode_set(spdptr%diags,jiter=jiter,obssen=zero) end if endif @@ -196,7 +201,8 @@ subroutine intspd_(spdhead,rval,sval) uanl=spdptr%uges+w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4) vanl=spdptr%vges+w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) spdanl=sqrt(uanl*uanl+vanl*vanl) - if (luse_obsdiag .and. spdptr%luse) spdptr%diags%tldepart(jiter)=spdanl-spdtra + !-- if (luse_obsdiag .and. spdptr%luse) spdptr%diags%tldepart(jiter)=spdanl-spdtra + if (luse_obsdiag .and. spdptr%luse) call obsdiagNode_set(spdptr%diags,jiter=jiter,tldepart=spdanl-spdtra) if (l_do_adjoint) then valu=zero @@ -207,7 +213,8 @@ subroutine intspd_(spdhead,rval,sval) ! Adjoint ! if(spdanl > tiny_r_kind*100._r_kind) then if (spdanl>EPSILON(spdanl)) then - if (luse_obsdiag .and. lsaveobsens) spdptr%diags%obssen(jiter)=grad + !-- if (luse_obsdiag .and. lsaveobsens) spdptr%diags%obssen(jiter)=grad + if (luse_obsdiag .and. lsaveobsens) call obsdiagNode_set(spdptr%diags,jiter=jiter,obssen=grad) valu=uanl/spdanl valv=vanl/spdanl if (nlnqc_iter .and. spdptr%pg > tiny_r_kind .and. & diff --git a/src/intsst.f90 b/src/gsi/intsst.f90 similarity index 95% rename from src/intsst.f90 rename to src/gsi/intsst.f90 index 790267793..d91024752 100644 --- a/src/intsst.f90 +++ b/src/gsi/intsst.f90 @@ -30,6 +30,7 @@ module intsstmod use m_sstNode, only: sstNode use m_sstNode, only: sstNode_typecast use m_sstNode, only: sstNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -142,9 +143,11 @@ subroutine intsst(ssthead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*sstptr%raterr2*sstptr%err2 - sstptr%diags%obssen(jiter) = grad + !-- sstptr%diags%obssen(jiter) = grad + call obsdiagNode_set(sstptr%diags,jiter=jiter,obssen=grad) else - if (sstptr%luse) sstptr%diags%tldepart(jiter)=val + !-- if (sstptr%luse) sstptr%diags%tldepart(jiter)=val + if (sstptr%luse) call obsdiagNode_set(sstptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/gsi/intswcp.f90 b/src/gsi/intswcp.f90 new file mode 100644 index 000000000..13f163fa8 --- /dev/null +++ b/src/gsi/intswcp.f90 @@ -0,0 +1,273 @@ +module intswcpmod + +!$$$ module documentation block +! . . . . +! module: intswcpmod module for intswcp and its tangent linear intswcp_tl +! prgmmr: +! +! abstract: module for intswcp and its tangent linear intswcp_tl +! +! program history log: +! +! subroutines included: +! sub intswcp_ +! +! variable definitions: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use m_obsNode, only: obsNode +use m_swcpNode, only: swcpNode +use m_swcpNode, only: swcpNode_typecast +use m_swcpNode, only: swcpNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set +implicit none + +PRIVATE +PUBLIC intswcp + +interface intswcp; module procedure & + intswcp_ +end interface + +contains + +subroutine intswcp_(swcphead,rval,sval) +!$$$ subprogram documentation block +! . . . . +! subprogram: intswcp apply nonlin qc obs operator for swcp +! prgmmr: Ting-Chi Wu org: CIRA/CSU date: 2017-06-28 +! +! abstract: apply observation operator and adjoint for solid-water content path +! with addition of nonlinear qc. +! +! program history log: +! 2017-06-28 Ting-Chi Wu - mimic the structure in intpw.f90 and intgps.f90 +! - intswcp.f90 includes 2 TL/ADJ options +! 1) when l_wcp_cwm = .false.: +! operator = f(T,P,q) +! 2) when l_wcp_cwm = .true. and CWM partition6: +! operator = f(qi,qs,qg,qh) partition6 +! +! input argument list: +! swcphead - obs type pointer to obs structure +! st - t increment in grid space +! sp - p increment in grid space +! sq - q increment in grid space +! sqi - qi increment in grid space +! sqs - qs increment in grid space +! sqg - qg increment in grid space +! sqh - qh increment in grid space +! +! output argument list: +! rt - results of t from swcp observation operator +! rp - results of p from swcp observation operator +! rq - results of q from swcp observation operator +! rqi - results of qi from swcp observation operator +! rqs - results of qs from swcp observation operator +! rqg - results of qg from swcp observation operator +! rqh - results of qh from swcp observation operator +! +! comments: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind + use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag + use obsmod, only: l_wcp_cwm + use gridmod, only: nsig + use qcmod, only: nlnqc_iter,varqc_iter + use constants, only: zero,half,one,tiny_r_kind,cg_term,r3600 + use jfunc, only: jiter + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_4dvar, only: ladtest_obs + implicit none + +! Declare passed variables + class(obsNode), pointer, intent(in ) :: swcphead + type(gsi_bundle) ,intent(in ) :: sval + type(gsi_bundle) ,intent(inout) :: rval + +! Declare local variables + integer(i_kind) k,ier,istatus + integer(i_kind),dimension(nsig):: i1,i2,i3,i4 +! real(r_kind) penalty + real(r_kind) :: t_TL,p_TL,q_TL + real(r_kind) :: t_AD,p_AD,q_AD + real(r_kind) :: qi_TL,qs_TL,qg_TL,qh_TL + real(r_kind) :: qi_AD,qs_AD,qg_AD,qh_AD + real(r_kind) val,w1,w2,w3,w4 + real(r_kind) cg_swcp,grad,p0,wnotgross,wgross,pg_swcp + real(r_kind),pointer,dimension(:) :: st, sp, sq + real(r_kind),pointer,dimension(:) :: sqi, sqs, sqg, sqh + real(r_kind),pointer,dimension(:) :: rt, rp, rq + real(r_kind),pointer,dimension(:) :: rqi, rqs, rqg, rqh + type(swcpNode), pointer :: swcpptr + +! If no swcp data return + if(.not. associated(swcphead))return +! Retrieve pointers +! Simply return if any pointer not found + ier=0 + + if (.not.l_wcp_cwm) then + + call gsi_bundlegetpointer(sval,'tsen',st,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'prse',sp,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'q' ,sq,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'tsen',rt,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'prse',rp,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'q' ,rq,istatus);ier=istatus+ier + + else + + call gsi_bundlegetpointer(sval,'qi',sqi,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qs',sqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qg',sqg,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qh',sqh,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qi',rqi,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qs',rqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qg',rqg,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qh',rqh,istatus);ier=istatus+ier + + endif ! l_wcp_cwm + + if(ier/=0)return + + !swcpptr => swcphead + swcpptr => swcpNode_typecast(swcphead) + do while (associated(swcpptr)) + + do k=1,nsig + i1(k)=swcpptr%ij(1,k) + i2(k)=swcpptr%ij(2,k) + i3(k)=swcpptr%ij(3,k) + i4(k)=swcpptr%ij(4,k) + enddo + w1=swcpptr%wij(1) + w2=swcpptr%wij(2) + w3=swcpptr%wij(3) + w4=swcpptr%wij(4) + + val=zero + +! Forward model (linear operator) + + if (.not.l_wcp_cwm) then + do k=1,nsig + t_TL=w1* st(i1(k))+w2* st(i2(k))+w3* st(i3(k))+w4* st(i4(k)) + p_TL=w1* sp(i1(k))+w2* sp(i2(k))+w3* sp(i3(k))+w4* sp(i4(k)) + q_TL=w1* sq(i1(k))+w2* sq(i2(k))+w3* sq(i3(k))+w4* sq(i4(k)) + val = val + ( t_TL*swcpptr%jac_t(k) + & + p_TL*swcpptr%jac_p(k) + & + q_TL*swcpptr%jac_q(k) ) ! tpwcon*r10*(piges(k)-piges(k+1)) already did in setupswcp.f90 + end do + else + do k=1,nsig + qi_TL=w1* sqi(i1(k))+w2* sqi(i2(k))+w3* sqi(i3(k))+w4* sqi(i4(k)) + qs_TL=w1* sqs(i1(k))+w2* sqs(i2(k))+w3* sqs(i3(k))+w4* sqs(i4(k)) + qg_TL=w1* sqg(i1(k))+w2* sqg(i2(k))+w3* sqg(i3(k))+w4* sqg(i4(k)) + qh_TL=w1* sqh(i1(k))+w2* sqh(i2(k))+w3* sqh(i3(k))+w4* sqh(i4(k)) + val = val + ( qi_TL*swcpptr%jac_qi(k) + & + qs_TL*swcpptr%jac_qs(k) + & + qg_TL*swcpptr%jac_qg(k) + & + qh_TL*swcpptr%jac_qh(k) ) ! tpwcon*r10*(piges(k)-piges(k+1)) already did in setupswcp.f90 + end do + endif ! l_wcp_cwm + + if(luse_obsdiag)then + if (lsaveobsens) then + grad = val*swcpptr%raterr2*swcpptr%err2 + !-- swcpptr%diags%obssen(jiter) = grad + call obsdiagNode_set(swcpptr%diags,jiter=jiter,obssen=grad) + else + !-- if (swcpptr%luse) swcpptr%diags%tldepart(jiter)=val + if (swcpptr%luse) call obsdiagNode_set(swcpptr%diags,jiter=jiter,tldepart=val) + endif + end if + + if (l_do_adjoint) then + if (.not. lsaveobsens) then +! Difference from observation + if( .not. ladtest_obs) val=val-swcpptr%res +! needed for gradient of nonlinear qc operator + if (nlnqc_iter .and. swcpptr%pg > tiny_r_kind .and. & + swcpptr%b > tiny_r_kind) then + pg_swcp=swcpptr%pg*varqc_iter + cg_swcp=cg_term/swcpptr%b + wnotgross= one-pg_swcp + wgross = pg_swcp*cg_swcp/wnotgross + p0 = wgross/(wgross+exp(-half*swcpptr%err2*val**2)) + val = val*(one-p0) + endif + if( ladtest_obs) then + grad = val + else + grad = val*swcpptr%raterr2*swcpptr%err2 + end if + endif + +! Adjoint + if (.not.l_wcp_cwm) then + do k=1,nsig + t_AD = grad*swcpptr%jac_t(k) + rt(i1(k))=rt(i1(k))+w1*t_AD + rt(i2(k))=rt(i2(k))+w2*t_AD + rt(i3(k))=rt(i3(k))+w3*t_AD + rt(i4(k))=rt(i4(k))+w4*t_AD + p_AD = grad*swcpptr%jac_p(k) + rp(i1(k))=rp(i1(k))+w1*p_AD + rp(i2(k))=rp(i2(k))+w2*p_AD + rp(i3(k))=rp(i3(k))+w3*p_AD + rp(i4(k))=rp(i4(k))+w4*p_AD + q_AD = grad*swcpptr%jac_q(k) + rq(i1(k))=rq(i1(k))+w1*q_AD + rq(i2(k))=rq(i2(k))+w2*q_AD + rq(i3(k))=rq(i3(k))+w3*q_AD + rq(i4(k))=rq(i4(k))+w4*q_AD + enddo + else + do k=1,nsig + qi_AD = grad*swcpptr%jac_qi(k) + rqi(i1(k))=rqi(i1(k))+w1*qi_AD + rqi(i2(k))=rqi(i2(k))+w2*qi_AD + rqi(i3(k))=rqi(i3(k))+w3*qi_AD + rqi(i4(k))=rqi(i4(k))+w4*qi_AD + qs_AD = grad*swcpptr%jac_qs(k) + rqs(i1(k))=rqs(i1(k))+w1*qs_AD + rqs(i2(k))=rqs(i2(k))+w2*qs_AD + rqs(i3(k))=rqs(i3(k))+w3*qs_AD + rqs(i4(k))=rqs(i4(k))+w4*qs_AD + qg_AD = grad*swcpptr%jac_qg(k) + rqg(i1(k))=rqg(i1(k))+w1*qg_AD + rqg(i2(k))=rqg(i2(k))+w2*qg_AD + rqg(i3(k))=rqg(i3(k))+w3*qg_AD + rqg(i4(k))=rqg(i4(k))+w4*qg_AD + qh_AD = grad*swcpptr%jac_qh(k) + rqh(i1(k))=rqh(i1(k))+w1*qh_AD + rqh(i2(k))=rqh(i2(k))+w2*qh_AD + rqh(i3(k))=rqh(i3(k))+w3*qh_AD + rqh(i4(k))=rqh(i4(k))+w4*qh_AD + enddo + endif ! l_wcp_cwm + endif ! l_do_adjoint + + + !swcpptr => swcpptr%llpoint + swcpptr => swcpNode_nextcast(swcpptr) + + end do + + return + +end subroutine intswcp_ + +end module intswcpmod diff --git a/src/intt.f90 b/src/gsi/intt.f90 similarity index 97% rename from src/intt.f90 rename to src/gsi/intt.f90 index 182c9e075..f5ba3ebdd 100644 --- a/src/intt.f90 +++ b/src/gsi/intt.f90 @@ -32,6 +32,7 @@ module inttmod use m_tNode, only: tNode use m_tNode, only: tNode_typecast use m_tNode, only: tNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -245,9 +246,11 @@ subroutine intt_(thead,rval,sval,rpred,spred) if(luse_obsdiag)then if (lsaveobsens) then grad = val*tptr%raterr2*tptr%err2 - tptr%diags%obssen(jiter) = grad + !-- tptr%diags%obssen(jiter) = grad + call obsdiagNode_set(tptr%diags,jiter=jiter,obssen=grad) else - if (tptr%luse) tptr%diags%tldepart(jiter)=val + !-- if (tptr%luse) tptr%diags%tldepart(jiter)=val + if (tptr%luse) call obsdiagNode_set(tptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/inttcamt.f90 b/src/gsi/inttcamt.f90 similarity index 92% rename from src/inttcamt.f90 rename to src/gsi/inttcamt.f90 index 1dfdb0fec..16c68177e 100644 --- a/src/inttcamt.f90 +++ b/src/gsi/inttcamt.f90 @@ -25,6 +25,7 @@ module inttcamtmod use m_tcamtNode, only: tcamtNode use m_tcamtNode, only: tcamtNode_typecast use m_tcamtNode, only: tcamtNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -112,9 +113,11 @@ subroutine inttcamt(tcamthead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*tcamtptr%raterr2*tcamtptr%err2 - tcamtptr%diags%obssen(jiter) = grad + !-- tcamtptr%diags%obssen(jiter) = grad + call obsdiagNode_set(tcamtptr%diags,jiter=jiter,obssen=grad) else - if (tcamtptr%luse) tcamtptr%diags%tldepart(jiter)=val + !-- if (tcamtptr%luse) tcamtptr%diags%tldepart(jiter)=val + if (tcamtptr%luse) call obsdiagNode_set(tcamtptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/inttcp.f90 b/src/gsi/inttcp.f90 similarity index 93% rename from src/inttcp.f90 rename to src/gsi/inttcp.f90 index a9d324ee5..78becf70b 100644 --- a/src/inttcp.f90 +++ b/src/gsi/inttcp.f90 @@ -30,6 +30,7 @@ module inttcpmod use m_tcpNode, only: tcpNode use m_tcpNode, only: tcpNode_typecast use m_tcpNode, only: tcpNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -120,9 +121,11 @@ subroutine inttcp_(tcphead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*tcpptr%raterr2*tcpptr%err2 - tcpptr%diags%obssen(jiter) = grad + !-- tcpptr%diags%obssen(jiter) = grad + call obsdiagNode_set(tcpptr%diags,jiter=jiter,obssen=grad) else - if (tcpptr%luse) tcpptr%diags%tldepart(jiter)=val + !-- if (tcpptr%luse) tcpptr%diags%tldepart(jiter)=val + if (tcpptr%luse) call obsdiagNode_set(tcpptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/inttd2m.f90 b/src/gsi/inttd2m.f90 similarity index 92% rename from src/inttd2m.f90 rename to src/gsi/inttd2m.f90 index a12878ef0..33014380d 100644 --- a/src/inttd2m.f90 +++ b/src/gsi/inttd2m.f90 @@ -25,6 +25,7 @@ module inttd2mmod use m_td2mNode, only: td2mNode use m_td2mNode, only: td2mNode_typecast use m_td2mNode, only: td2mNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -111,9 +112,11 @@ subroutine inttd2m(td2mhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*td2mptr%raterr2*td2mptr%err2 - td2mptr%diags%obssen(jiter) = grad + !-- td2mptr%diags%obssen(jiter) = grad + call obsdiagNode_set(td2mptr%diags,jiter=jiter,obssen=grad) else - if (td2mptr%luse) td2mptr%diags%tldepart(jiter)=val + !-- if (td2mptr%luse) td2mptr%diags%tldepart(jiter)=val + if (td2mptr%luse) call obsdiagNode_set(td2mptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intuwnd10m.f90 b/src/gsi/intuwnd10m.f90 similarity index 93% rename from src/intuwnd10m.f90 rename to src/gsi/intuwnd10m.f90 index 57bf377f9..23fea78b0 100644 --- a/src/intuwnd10m.f90 +++ b/src/gsi/intuwnd10m.f90 @@ -26,7 +26,7 @@ module intuwnd10mmod use m_uwnd10mNode, only: uwnd10mNode use m_uwnd10mNode, only: uwnd10mNode_typecast use m_uwnd10mNode, only: uwnd10mNode_nextcast - +use m_obsdiagNode, only: obsdiagNode_set implicit none @@ -115,9 +115,11 @@ subroutine intuwnd10m(uwnd10mhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*uwnd10mptr%raterr2*uwnd10mptr%err2 - uwnd10mptr%diags%obssen(jiter) = grad + !-- uwnd10mptr%diags%obssen(jiter) = grad + call obsdiagNode_set(uwnd10mptr%diags,jiter=jiter,obssen=grad) else - if (uwnd10mptr%luse) uwnd10mptr%diags%tldepart(jiter)=val + !-- if (uwnd10mptr%luse) uwnd10mptr%diags%tldepart(jiter)=val + if (uwnd10mptr%luse) call obsdiagNode_set(uwnd10mptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intvis.f90 b/src/gsi/intvis.f90 similarity index 93% rename from src/intvis.f90 rename to src/gsi/intvis.f90 index e2b18cc4f..fe1f2836e 100644 --- a/src/intvis.f90 +++ b/src/gsi/intvis.f90 @@ -25,6 +25,7 @@ module intvismod use m_visNode, only: visNode use m_visNode, only: visNode_typecast use m_visNode, only: visNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -111,9 +112,11 @@ subroutine intvis(vishead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*visptr%raterr2*visptr%err2 - visptr%diags%obssen(jiter) = grad + !-- visptr%diags%obssen(jiter) = grad + call obsdiagNode_set(visptr%diags,jiter=jiter,obssen=grad) else - if (visptr%luse) visptr%diags%tldepart(jiter)=val + !-- if (visptr%luse) visptr%diags%tldepart(jiter)=val + if (visptr%luse) call obsdiagNode_set(visptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intvwnd10m.f90 b/src/gsi/intvwnd10m.f90 similarity index 93% rename from src/intvwnd10m.f90 rename to src/gsi/intvwnd10m.f90 index a50476444..e33be8116 100644 --- a/src/intvwnd10m.f90 +++ b/src/gsi/intvwnd10m.f90 @@ -25,7 +25,7 @@ module intvwnd10mmod use m_vwnd10mNode, only: vwnd10mNode use m_vwnd10mNode, only: vwnd10mNode_typecast use m_vwnd10mNode, only: vwnd10mNode_nextcast - +use m_obsdiagNode, only: obsdiagNode_set implicit none @@ -114,9 +114,11 @@ subroutine intvwnd10m(vwnd10mhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*vwnd10mptr%raterr2*vwnd10mptr%err2 - vwnd10mptr%diags%obssen(jiter) = grad + !-- vwnd10mptr%diags%obssen(jiter) = grad + call obsdiagNode_set(vwnd10mptr%diags,jiter=jiter,obssen=grad) else - if (vwnd10mptr%luse) vwnd10mptr%diags%tldepart(jiter)=val + !-- if (vwnd10mptr%luse) vwnd10mptr%diags%tldepart(jiter)=val + if (vwnd10mptr%luse) call obsdiagNode_set(vwnd10mptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/intw.f90 b/src/gsi/intw.f90 similarity index 93% rename from src/intw.f90 rename to src/gsi/intw.f90 index 07be61060..d1013d60a 100644 --- a/src/intw.f90 +++ b/src/gsi/intw.f90 @@ -31,6 +31,7 @@ module intwmod use m_wNode, only: wNode use m_wNode, only: wNode_typecast use m_wNode, only: wNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -155,12 +156,16 @@ subroutine intw_(whead,rval,sval) if (lsaveobsens) then gradu = valu*wptr%raterr2*wptr%err2 gradv = valv*wptr%raterr2*wptr%err2 - wptr%diagu%obssen(jiter) = gradu - wptr%diagv%obssen(jiter) = gradv + !-- wptr%diagu%obssen(jiter) = gradu + !-- wptr%diagv%obssen(jiter) = gradv + call obsdiagNode_set(wptr%diagu,jiter=jiter,obssen=gradu) + call obsdiagNode_set(wptr%diagv,jiter=jiter,obssen=gradv) else if (wptr%luse) then - wptr%diagu%tldepart(jiter)=valu - wptr%diagv%tldepart(jiter)=valv + !-- wptr%diagu%tldepart(jiter)=valu + !-- wptr%diagv%tldepart(jiter)=valv + call obsdiagNode_set(wptr%diagu,jiter=jiter,tldepart=valu) + call obsdiagNode_set(wptr%diagv,jiter=jiter,tldepart=valv) endif endif endif diff --git a/src/intwspd10m.f90 b/src/gsi/intwspd10m.f90 similarity index 93% rename from src/intwspd10m.f90 rename to src/gsi/intwspd10m.f90 index 9b65177b6..d89b604e7 100644 --- a/src/intwspd10m.f90 +++ b/src/gsi/intwspd10m.f90 @@ -25,6 +25,7 @@ module intwspd10mmod use m_wspd10mNode, only: wspd10mNode use m_wspd10mNode, only: wspd10mNode_typecast use m_wspd10mNode, only: wspd10mNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set implicit none PRIVATE @@ -111,9 +112,11 @@ subroutine intwspd10m(wspd10mhead,rval,sval) if(luse_obsdiag)then if (lsaveobsens) then grad = val*wspd10mptr%raterr2*wspd10mptr%err2 - wspd10mptr%diags%obssen(jiter) = grad + !-- wspd10mptr%diags%obssen(jiter) = grad + call obsdiagNode_set(wspd10mptr%diags,jiter=jiter,obssen=grad) else - if (wspd10mptr%luse) wspd10mptr%diags%tldepart(jiter)=val + !-- if (wspd10mptr%luse) wspd10mptr%diags%tldepart(jiter)=val + if (wspd10mptr%luse) call obsdiagNode_set(wspd10mptr%diags,jiter=jiter,tldepart=val) endif endif diff --git a/src/jcmod.f90 b/src/gsi/jcmod.f90 similarity index 92% rename from src/jcmod.f90 rename to src/gsi/jcmod.f90 index 1bd19bc4f..723ac832b 100644 --- a/src/jcmod.f90 +++ b/src/gsi/jcmod.f90 @@ -16,6 +16,8 @@ module jcmod ! 2007-10-18 tremolet - added Jc DFI option ! 2012-02-08 kleist - add parameter ljc4tlevs ! 2013-05-15 todling - add knobs to control constraint on total water +! 2018-05-19 eliu - add logic (ljclimqc) for limiting negative hydrometeors +! as a weak constraint ! ! subroutines included: ! sub init_jcvars - initialize Jc related variables @@ -45,8 +47,9 @@ module jcmod ! set passed variables to public public :: ljcdfi,alphajc,wgtdfi,bamp_jcpdry,ljcpdry,eps_eer public :: ljc4tlevs + public :: ljclimqc - logical ljcdfi,ljcpdry,ljc4tlevs + logical ljcdfi,ljcpdry,ljc4tlevs,ljclimqc real(r_kind) alphajc,bamp_jcpdry,eps_eer real(r_kind),allocatable :: wgtdfi(:) @@ -79,6 +82,7 @@ subroutine init_jcvars implicit none ! load defaults for non-allocatable arrays + ljclimqc=.false. ljcdfi=.false. ljcpdry=.false. ljc4tlevs=.false. diff --git a/src/jfunc.f90 b/src/gsi/jfunc.f90 similarity index 99% rename from src/jfunc.f90 rename to src/gsi/jfunc.f90 index 5def032bd..428ad41ec 100644 --- a/src/jfunc.f90 +++ b/src/gsi/jfunc.f90 @@ -47,6 +47,7 @@ module jfunc ! 2014-05-07 pondeca - add facthowv ! 2014-06-18 carley/zhu - add lcbas and tcamt ! 2015-07-10 pondeca - add factcldch +! 2018-05-19 eliu - add control factors (factql,factqi, ....) for hydrometeors ! ! Subroutines Included: ! sub init_jfunc - set defaults for cost function variables @@ -131,6 +132,7 @@ module jfunc public :: switch_on_derivatives,jiterend,jiterstart,jiter,iter,niter,miter public :: diurnalbc,bcoption,biascor,nval2d,xhatsave,first public :: factqmax,factqmin,clip_supersaturation,last,yhatsave,nvals_len,nval_levs,iout_iter,nclen + public :: factql,factqi,factqr,factqs,factqg public :: niter_no_qc,print_diag_pcg,lgschmidt,penorig,gnormorig,iguess public :: factg,factv,factp,factl,R_option,factw10m,facthowv,factcldch,diag_precon,step_start public :: pseudo_q2 @@ -149,6 +151,7 @@ module jfunc integer(i_kind),dimension(0:50):: niter,niter_no_qc real(r_kind) factqmax,factqmin,gnormorig,penorig,biascor(2),diurnalbc,factg,factv,factp,factl,& factw10m,facthowv,factcldch,step_start + real(r_kind) factql,factqi,factqr,factqs,factqg integer(i_kind) bcoption real(r_kind),allocatable,dimension(:,:):: varq real(r_kind),allocatable,dimension(:,:):: varcw @@ -200,6 +203,11 @@ subroutine init_jfunc factqmin=zero factqmax=zero + factql=zero + factqi=zero + factqr=zero + factqs=zero + factqg=zero clip_supersaturation=.false. factg=zero factv=zero diff --git a/src/jgrad.f90 b/src/gsi/jgrad.f90 old mode 100644 new mode 100755 similarity index 95% rename from src/jgrad.f90 rename to src/gsi/jgrad.f90 index f3f2e63dc..2e3255646 --- a/src/jgrad.f90 +++ b/src/gsi/jgrad.f90 @@ -17,17 +17,21 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) ! 2014-09-17 todling - handle output of 4d-inc more carefully to allow for ! update of state in non-convensional 4d (ie, 4densvar) ! 2014-10-14 todling - write-all only called at last outer iteration -! 2015-12-01 todling - add setrad to init pointers in intrad ! 2015-09-03 guo - obsmod::yobs has been replaced with m_obsHeadBundle, ! where yobs is created and destroyed when and where it ! is needed. +! 2015-12-01 todling - add setrad to init pointers in intrad ! 2016-05-09 todling - allow increment to be written out at end of outer iter +! 2018-08-10 guo - removed obsHeadBundle references. +! - replaced intjo() related implementations to a new +! polymorphic implementation of intjpmod::intjo(). ! !$$$ use kinds, only: r_kind,i_kind,r_quad use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar, ltlint, iwrtinc use gsi_4dvar, only: l4densvar +use gsi_4dvar, only: efsoi_order use constants, only: zero,zero_quad use mpimod, only: mype use jfunc, only : xhatsave,yhatsave @@ -49,15 +53,12 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) use bias_predictors, only: update_bias_preds use intjomod, only: intjo use intjcmod, only: intjcdfi -use intradmod, only: setrad use gsi_4dcouplermod, only: gsi_4dcoupler_grtests use xhat_vordivmod, only : xhat_vordiv_init, xhat_vordiv_calc, xhat_vordiv_clean use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens use mpl_allreducemod, only: mpl_allreduce +use obs_sensitivity, only: efsoi_o2_update -use m_obsHeadBundle, only: obsHeadBundle -use m_obsHeadBundle, only: obsHeadBundle_create -use m_obsHeadBundle, only: obsHeadBundle_destroy implicit none ! Declare passed variables @@ -83,7 +84,6 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) character(len=8) :: xincfile real(r_quad),dimension(max(1,nrclen)) :: qpred -type(obsHeadBundle),pointer,dimension(:):: yobs !********************************************************************** @@ -143,6 +143,12 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) endif end if +if (.not.l_do_adjoint) then + if(lsaveobsens.and.l_hyb_ens.and.efsoi_order==2) then + call efsoi_o2_update(sval) + end if +end if + if (nprt>=2) then do ii=1,nobs_bins call prt_state_norms(sval(ii),'sval') @@ -158,14 +164,10 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) mval(ii)=zero end do -call setrad(sval(1)) qpred=zero_quad ! Compare obs to solution and transpose back to grid (H^T R^{-1} H) -call obsHeadBundle_create(yobs,nobs_bins) +call intjo(rval,qpred,sval,sbias) -do ibin=1,size(yobs) ! == nobs_bins - call intjo(yobs(ibin),rval(ibin),qpred,sval(ibin),sbias,ibin) -end do ! Take care of background error for bias correction terms call mpl_allreduce(nrclen,qpvals=qpred) @@ -182,8 +184,6 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) end do end if -call obsHeadBundle_destroy(yobs) - ! Evaluate Jo call evaljo(zjo,iobs,nprt,llouter) diff --git a/src/kinds.F90 b/src/gsi/kinds.F90 similarity index 100% rename from src/kinds.F90 rename to src/gsi/kinds.F90 diff --git a/src/lag_fields.f90 b/src/gsi/lag_fields.f90 similarity index 100% rename from src/lag_fields.f90 rename to src/gsi/lag_fields.f90 diff --git a/src/lag_interp.f90 b/src/gsi/lag_interp.f90 similarity index 100% rename from src/lag_interp.f90 rename to src/gsi/lag_interp.f90 diff --git a/src/lag_traj.f90 b/src/gsi/lag_traj.f90 similarity index 100% rename from src/lag_traj.f90 rename to src/gsi/lag_traj.f90 diff --git a/src/lagmod.f90 b/src/gsi/lagmod.f90 similarity index 100% rename from src/lagmod.f90 rename to src/gsi/lagmod.f90 diff --git a/src/lanczos.F90 b/src/gsi/lanczos.F90 similarity index 100% rename from src/lanczos.F90 rename to src/gsi/lanczos.F90 diff --git a/src/gsi/lightinfo.f90 b/src/gsi/lightinfo.f90 new file mode 100755 index 000000000..b0ebcdacf --- /dev/null +++ b/src/gsi/lightinfo.f90 @@ -0,0 +1,219 @@ +module lightinfo +!$$$ module documentation block +! . . . . +! module: lightinfo +! prgmmr: Apodaca org: CSU/CIRA date: 2015-08-11 +! abstract: This module contains variables related to the +! direct assimilation of lightning observations +! (e.g. GOES-16 GLM). +! +! program history log: +! +! . . . . . . . . +! 2016-05-03 Apodaca - updates regarding GLM observation errors +! +! Subroutines Included: +! sub init_light - initialize lightning related variables to defaults +! sub lightinfo_read - read in lightning information + + + +! Variable Definitions +! def diag_light - flag to toggle the creation of a lightning diagnostic file +! def nlighttype - maximum number of lightning data types +! def mype_light - task id for writing out lightning diagnostics +! def deltiml - model timestep +! def loberr - lightning observation error +! def gross_light - gross error for lightning obs +! def glermax - gross error parameter - max error +! def glermin - gross error parameter - min error +! def b_light - b value for variational QC +! def pg_light - pg value for variational QC +! def nulight - satellite/instrument +! def iuse_light - use to turn off lightning data +! +! attributes: +! language: Fortran 90 or higher +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + implicit none + +! set default to private + private +! set subroutines to public + public :: init_light + public :: lightinfo_read +! set passed variables to public + public :: nulight,nlighttype,pg_light,b_light,diag_light,iuse_light + public :: glermin,glermax,gross_light,mype_light + public :: loberr + character(len=80) :: fname = 'lightinfo' + logical diag_light + integer(i_kind) nlighttype,mype_light + real(r_kind) deltiml + real(r_kind),allocatable,dimension(:)::loberr,gross_light,b_light,pg_light + real(r_kind),allocatable,dimension(:)::glermin,glermax + integer(i_kind),allocatable,dimension(:)::iuse_light + character(len=20),allocatable,dimension(:)::nulight +contains + + subroutine init_light +!$$$ subprogram documentation block +! . . . . +! subprogram: init_light +! prgmmr: apodaca org: CSU/CIRA date: 2015-08-11 +! +! abstract: set defaults for variables used in lightning +! assimilation routines +! +! program history log: +! 2016-05-03 apodaca, updates regarding GLM observation errors +! 2016-06-13 apodaca, documentation +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + use constants, only: r3600,one + implicit none + + real(r_kind),parameter:: r1200=1200.0_r_kind + + nlighttype = 0 ! number of entries read from lightinfo, + deltiml = r1200 ! model timestep + diag_light =.true. ! flag to toggle creation of lightning diagnostic file + mype_light = 0 ! task to print light info. Note that mype_light + ! MUST equal mype_rad (see radinfo.f90) in order for + ! statspcp.f90 to print out the correct information + end subroutine init_light + + subroutine lightinfo_read +!$$$ subprogram documentation block +! . . . . +! subprogram: lightinfo_read +! prgmmr: apodaca org: CSU/CIRA date: 2015-08-14 +! +! abstract: read text file containing information (satellite/instrument id, +! observation type, error, usage flags) for lightning observations. +! +! program history log: +! 2015-08-14 apodaca - original code based on pcpinfo and aeroinfo +! 2016-05-03 apodaca - updates regarding GLM observation errors +! input argument list: +! mype - mpi task id +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + use mpimod, only: mype + use constants, only: zero + use obsmod, only: iout_light + implicit none + +! Declare local varianbes + logical lexist + character(len=1):: cflg + character(len=120) crecord + integer(i_kind) lunin,j,k,istat,nlines + + data lunin / 47 / + + + ! Check the status of input file + + inquire(file=trim(fname),exist=lexist) + + if ( lexist ) then + +!----------------------------------------------------------- +! Determine number of entries in light information file +!----------------------------------------------------------- + + open(lunin,file='lightinfo',form='formatted') + + + j=0 + nlines=0 + read1: do + read(lunin,100,iostat=istat,end=120) cflg,crecord + if (istat /= 0) exit + nlines=nlines+1 + if (cflg == '!') cycle + j=j+1 + end do read1 + 120 continue + + if (istat>0) then + write(6,*)'LIGHTINFO_READ: ***ERROR*** error reading lightinfo, istat=',istat + close(lunin) + write(6,*)'LIGHTINFO_READ: stop program execution' + call stop2(79) + endif + nlighttype=j + + + ! Allocate arrays to hold lightning information + allocate(nulight(nlighttype),iuse_light(nlighttype),loberr(nlighttype), gross_light(nlighttype), & + glermin(nlighttype),glermax(nlighttype),b_light(nlighttype),pg_light(nlighttype)) + + + ! All mpi tasks open and read lightinfo information file. + ! Task mype_light writes information to light runtime file + + if (mype==mype_light) then + open(iout_light) + write(iout_light,110) nlighttype +110 format('LIGHTINFO_READ: nlighttype=',1x,i6) + endif + rewind(lunin) + +!---------------------------------------------------------- +! READ INFO FILE +!---------------------------------------------------------- + j=0 + do k=1,nlines + read(lunin,100) cflg,crecord + if (cflg == '!') cycle + j=j+1 + read(crecord,*) nulight(j),iuse_light(j),loberr(j),& + gross_light(j),glermin(j),glermax(j),b_light(j),pg_light(j) + if (mype==mype_light) write(iout_light,130) nulight(j),& + iuse_light(j),loberr(j),gross_light(j),glermax(j),& + glermin(j),b_light(j),pg_light(j) + end do + + close(lunin) + if (mype==mype_light) close(iout_light) + +100 format(a1,a120) +130 format(a20,' iuse_light = ',i2, ' err = ',& + f7.3,' gross = ',f7.3,' glermax = ',f7.3,' glermin = ',f7.3, ' b_light = ',f7.3, ' pg_light = ',f7.3) + + ! Successful read, return to calling routine + + else + ! File does not exist, write warning message to alert users + if (mype==mype_light) then + open(iout_light) + write(iout_light,*)'LIGHTINFO_READ: ***WARNING*** FILE ',trim(fname),'does not exist' + close(iout_light) + endif + end if + + return + end subroutine lightinfo_read + + +end module lightinfo diff --git a/src/logcldch_to_cldch.f90 b/src/gsi/logcldch_to_cldch.f90 similarity index 100% rename from src/logcldch_to_cldch.f90 rename to src/gsi/logcldch_to_cldch.f90 diff --git a/src/loglcbas_to_lcbas.f90 b/src/gsi/loglcbas_to_lcbas.f90 similarity index 100% rename from src/loglcbas_to_lcbas.f90 rename to src/gsi/loglcbas_to_lcbas.f90 diff --git a/src/logvis_to_vis.f90 b/src/gsi/logvis_to_vis.f90 similarity index 100% rename from src/logvis_to_vis.f90 rename to src/gsi/logvis_to_vis.f90 diff --git a/src/looplimits.f90 b/src/gsi/looplimits.f90 similarity index 100% rename from src/looplimits.f90 rename to src/gsi/looplimits.f90 diff --git a/src/m_aeroNode.F90 b/src/gsi/m_aeroNode.F90 similarity index 93% rename from src/m_aeroNode.F90 rename to src/gsi/m_aeroNode.F90 index e724a8899..b1dfe7005 100644 --- a/src/m_aeroNode.F90 +++ b/src/gsi/m_aeroNode.F90 @@ -23,8 +23,8 @@ module m_aeroNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag,aofp_obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag,aofp_obs_diag => fptr_obsdiagNode + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell @@ -73,6 +73,9 @@ module m_aeroNode interface aeroNode_typecast; module procedure typecast_ ; end interface interface aeroNode_nextcast; module procedure nextcast_ ; end interface + public:: aeroNode_appendto + interface aeroNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_aeroNode" #include "myassert.H" @@ -84,14 +87,12 @@ function typecast_(aNode) result(ptr_) implicit none type(aeroNode),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(aeroNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -101,13 +102,28 @@ function nextcast_(aNode) result(ptr_) use m_obsNode, only: obsNode,obsNode_next implicit none type(aeroNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(aeroNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_aerolNode.F90 b/src/gsi/m_aerolNode.F90 similarity index 89% rename from src/m_aerolNode.F90 rename to src/gsi/m_aerolNode.F90 index efb61fb85..8ad15bd02 100644 --- a/src/m_aerolNode.F90 +++ b/src/gsi/m_aerolNode.F90 @@ -24,7 +24,7 @@ module m_aerolNode ! module interface: - use obsmod, only: obs_diag + use m_obsdiagNode, only: obs_diag use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -70,6 +70,9 @@ module m_aerolNode interface aerolNode_typecast; module procedure typecast_ ; end interface interface aerolNode_nextcast; module procedure nextcast_ ; end interface + public:: aerolNode_appendto + interface aerolNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_aerolNode" #include "myassert.H" @@ -80,15 +83,13 @@ function typecast_(aNode) result(ptr_) use m_obsNode, only: obsNode implicit none type(aerolNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" + class(obsNode ),pointer,intent(in):: aNode ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(aerolNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -98,13 +99,28 @@ function nextcast_(aNode) result(ptr_) use m_obsNode, only: obsNode,obsNode_next implicit none type(aerolNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode ),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(aerolNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() @@ -115,7 +131,7 @@ end function mytype subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) use m_obsdiagNode, only: obsdiagLookup_locate - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diags implicit none class(aerolNode), intent(inout):: aNode integer(i_kind), intent(in ):: iunit diff --git a/src/m_berror_stats.f90 b/src/gsi/m_berror_stats.f90 similarity index 100% rename from src/m_berror_stats.f90 rename to src/gsi/m_berror_stats.f90 diff --git a/src/m_berror_stats_reg.f90 b/src/gsi/m_berror_stats_reg.f90 similarity index 98% rename from src/m_berror_stats_reg.f90 rename to src/gsi/m_berror_stats_reg.f90 index 3a58c12e3..896a43da4 100644 --- a/src/m_berror_stats_reg.f90 +++ b/src/gsi/m_berror_stats_reg.f90 @@ -361,6 +361,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt integer(i_kind) :: nrf2_td2m,nrf2_mxtm,nrf2_mitm,nrf2_pmsl,nrf2_howv,nrf2_tcamt,nrf2_lcbas,nrf2_cldch integer(i_kind) :: nrf2_uwnd10m,nrf2_vwnd10m integer(i_kind) :: nrf3_sfwter,nrf3_vpwter + integer(i_kind) :: nrf3_dbz integer(i_kind) :: inerr,istat integer(i_kind) :: nsigstat,nlatstat,isig integer(i_kind) :: loc,m1,m,i,n,j,k,n0,ivar,ic @@ -552,6 +553,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt nrf3_cw =getindex(cvars3d,'cw') nrf3_sf =getindex(cvars3d,'sf') nrf3_vp =getindex(cvars3d,'vp') + nrf3_dbz=getindex(cvars3d,'dbz') nrf2_sst=getindex(cvars2d,'sst') nrf2_gust=getindex(cvars2d,'gust') nrf2_vis=getindex(cvars2d,'vis') @@ -580,6 +582,16 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt enddo endif + if( nrf3_dbz>0 )then + if(.not. nrf3_t>0) then + write(6,*)'not as expect,stop' + stop + endif + corz(:,:,nrf3_dbz)=10.0_r_kind + hwll(:,:,nrf3_dbz)=hwll(:,:,nrf3_t) + vz(:,:,nrf3_dbz)=vz(:,:,nrf3_t) + endif + if (nrf3_oz>0) then factoz = 0.0002_r_kind*r25 corz(:,:,nrf3_oz)=factoz @@ -674,7 +686,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt end if if (n==nrf2_vis) then do i=1,mlat - corp(i,n)=20000.0_r_kind + corp(i,n)=3.0_r_kind end do do i=0,mlat+1 hwllp(i,n)=hwll(i,1,nrf3_t) @@ -767,7 +779,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt end if if (n==nrf2_cldch) then do i=1,mlat - corp(i,n)=40000.0_r_kind + corp(i,n)=3.0_r_kind end do do i=0,mlat+1 hwllp(i,n)=hwll(i,1,nrf3_t) diff --git a/src/m_cldchNode.F90 b/src/gsi/m_cldchNode.F90 similarity index 89% rename from src/m_cldchNode.F90 rename to src/gsi/m_cldchNode.F90 index 5281f42f3..068595529 100644 --- a/src/m_cldchNode.F90 +++ b/src/gsi/m_cldchNode.F90 @@ -24,8 +24,8 @@ module m_cldchNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -70,6 +70,9 @@ module m_cldchNode interface cldchNode_typecast; module procedure typecast_ ; end interface interface cldchNode_nextcast; module procedure nextcast_ ; end interface + public:: cldchNode_appendto + interface cldchNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_cldchNode" #include "myassert.H" @@ -80,15 +83,13 @@ function typecast_(aNode) result(ptr_) use m_obsNode, only: obsNode implicit none type(cldchNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" + class(obsNode ),pointer,intent(in):: aNode ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(cldchNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -98,14 +99,28 @@ function nextcast_(aNode) result(ptr_) use m_obsNode, only: obsNode,obsNode_next implicit none type(cldchNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + class(obsNode ),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(cldchNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_colvkNode.F90 b/src/gsi/m_colvkNode.F90 similarity index 93% rename from src/m_colvkNode.F90 rename to src/gsi/m_colvkNode.F90 index b92aee0ff..3db8c2f73 100644 --- a/src/m_colvkNode.F90 +++ b/src/gsi/m_colvkNode.F90 @@ -23,8 +23,8 @@ module m_colvkNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag,aofp_obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag,aofp_obs_diag => fptr_obsdiagNode + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -77,6 +77,7 @@ module m_colvkNode ! procedure, nopass:: headerWrite => obsHeader_write_ ! procedure:: init => obsNode_init_ procedure:: clean => obsNode_clean_ + end type colvkNode public:: colvkNode_typecast @@ -84,6 +85,9 @@ module m_colvkNode interface colvkNode_typecast; module procedure typecast_ ; end interface interface colvkNode_nextcast; module procedure nextcast_ ; end interface + public:: colvkNode_appendto + interface colvkNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_colvkNode" #include "myassert.H" @@ -94,16 +98,13 @@ function typecast_(aNode) result(ptr_) use m_obsNode, only: obsNode implicit none type(colvkNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - - character(len=*),parameter:: myname_=MYNAME//"::typecast_" + class(obsNode ),pointer,intent(in):: aNode ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(colvkNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -113,14 +114,27 @@ function nextcast_(aNode) result(ptr_) use m_obsNode, only: obsNode,obsNode_next implicit none type(colvkNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + class(obsNode ),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(colvkNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() @@ -146,6 +160,7 @@ subroutine obsNode_clean_(aNode) if(associated(aNode%ap )) deallocate(aNode%ap ) if(associated(aNode%wk )) deallocate(aNode%wk ) if(associated(aNode%wij )) deallocate(aNode%wij ) + _EXIT_(myname_) return end subroutine obsNode_clean_ diff --git a/src/m_cvgridLookup.F90 b/src/gsi/m_cvgridLookup.F90 similarity index 100% rename from src/m_cvgridLookup.F90 rename to src/gsi/m_cvgridLookup.F90 diff --git a/src/gsi/m_dbzNode.F90 b/src/gsi/m_dbzNode.F90 new file mode 100644 index 000000000..6a80f0df8 --- /dev/null +++ b/src/gsi/m_dbzNode.F90 @@ -0,0 +1,264 @@ +module m_dbzNode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_dbzNode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type dbzNode (radar reflectivity) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2017-05-12 Y. Wang and X. Wang - module for defining reflectivity observation, +! POC: xuguang.wang@ou.edu +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsNode, only: obsNode + implicit none + private + + public:: dbzNode + + type,extends(obsNode):: dbzNode +! type(dbz_ob_type),pointer :: llpoint => NULL() + type(obs_diag), pointer :: diags => NULL() + real(r_kind) :: res ! Radar reflectivity residual (ob-ges) + real(r_kind) :: err2 ! radar reflectivity error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + real(r_kind) :: jqr ! for TL and ADJ !modified: + real(r_kind) :: jqs ! for TL and ADJ + !real(r_kind) :: jqi ! for TL and ADJ + real(r_kind) :: jqg ! for TL and ADJ + !real(r_kind) :: jnr ! for TL and ADJ + !real(r_kind) :: jni ! for TL and ADJ + real(r_kind) :: jqli ! for TL and ADJ + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: wij(8) ! horizontal interpolation weights + integer(i_kind) :: ij(8) ! horizontal locations +! logical :: luse ! flag indicating if ob is used in pen. + +! integer(i_kind) :: idv,iob ! device id and obs index for sorting + + real (r_kind) :: dlev ! reference to the vertical grid + contains + procedure,nopass:: mytype + procedure:: setHop => obsNode_setHop_ + procedure:: xread => obsNode_xread_ + procedure:: xwrite => obsNode_xwrite_ + procedure:: isvalid => obsNode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerRead => obsHeader_read_ + ! procedure, nopass:: headerWrite => obsHeader_write_ + ! procedure:: init => obsNode_init_ + ! procedure:: clean => obsNode_clean_ + end type dbzNode + + public:: dbzNode_typecast + public:: dbzNode_nextcast + interface dbzNode_typecast; module procedure typecast_ ; end interface + interface dbzNode_nextcast; module procedure nextcast_ ; end interface + + public:: dbzNode_appendto + interface dbzNode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: MYNAME="m_dbzNode" + +!#define CHECKSUM_VERBOSE +!#define DEBUG_TRACE +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(dbzNode) + use m_obsNode, only: obsNode + implicit none + type (dbzNode),pointer:: ptr_ + class(obsNode),pointer,intent(in):: aNode + ptr_ => null() + if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer + select type(aNode) + type is(dbzNode) + ptr_ => aNode + end select +return +end function typecast_ + +function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(dbzNode) + use m_obsNode, only: obsNode,obsNode_next + implicit none + type (dbzNode),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) +return +end function nextcast_ + +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(dbzNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + +! obsNode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[dbzNode]" +end function mytype + +subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) + use m_obsdiagNode, only: obsdiagLookup_locate + implicit none + class(dbzNode),intent(inout):: aNode + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent( out):: istat + type(obs_diags),intent(in ):: diagLookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_' + logical:: skip_ +_ENTRY_(myname_) + skip_=.false. + if(present(skip)) skip_=skip + + istat=0 + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) aNode%res , & + aNode%err2 , & + aNode%raterr2, & + aNode%b , & + aNode%pg , & + aNode%jqr , & + aNode%jqs , & + aNode%jqg , & + aNode%jqli , & + aNode%dlev , & + aNode%wij , & + aNode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) + if(.not.associated(aNode%diags)) then + call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) + call perr(myname_,' %iob =',aNode%iob) + call die(myname_) + endif + endif +_EXIT_(myname_) +return +end subroutine obsNode_xread_ + +subroutine obsNode_xwrite_(aNode,junit,jstat) + implicit none + class(dbzNode),intent(in):: aNode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_' +_ENTRY_(myname_) + + jstat=0 + write(junit,iostat=jstat) aNode%res , & + aNode%err2 , & + aNode%raterr2, & + aNode%b , & + aNode%pg , & + aNode%jqr , & + aNode%jqs , & + aNode%jqg , & + aNode%jqli , & + aNode%dlev , & + aNode%wij , & + aNode%ij + if (jstat/=0) then + call perr(myname_,'write(%(res,err2,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) +return +end subroutine obsNode_xwrite_ + +subroutine obsNode_setHop_(aNode) + use m_cvgridLookup, only: cvgridLookup_getiw + implicit none + class(dbzNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' +_ENTRY_(myname_) + call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%dlev,aNode%ij,aNode%wij) +_EXIT_(myname_) +return +end subroutine obsNode_setHop_ + +function obsNode_isvalid_(aNode) result(isvalid_) + implicit none + logical:: isvalid_ + class(dbzNode),intent(in):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' +_ENTRY_(myname_) + isvalid_=associated(aNode%diags) +_EXIT_(myname_) +return +end function obsNode_isvalid_ + +pure subroutine gettlddp_(aNode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(dbzNode), intent(in):: aNode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 +return +end subroutine gettlddp_ + +end module m_dbzNode diff --git a/src/m_dgeevx.F90 b/src/gsi/m_dgeevx.F90 similarity index 100% rename from src/m_dgeevx.F90 rename to src/gsi/m_dgeevx.F90 diff --git a/src/m_distance.f90 b/src/gsi/m_distance.f90 similarity index 100% rename from src/m_distance.f90 rename to src/gsi/m_distance.f90 diff --git a/src/m_dtime.F90 b/src/gsi/m_dtime.F90 similarity index 99% rename from src/m_dtime.F90 rename to src/gsi/m_dtime.F90 index a1a5fed58..367f932f8 100644 --- a/src/m_dtime.F90 +++ b/src/gsi/m_dtime.F90 @@ -203,7 +203,7 @@ subroutine dtime_show(who,what,it) call tell(who,what//' '//trim(bufr)) #else - call tell(who,what//', iobs_type=',it) + call tell(who,what//', iobs_stream=',it) call tell(who,what//', nt=',nt) call tell(who,what//', at=',at) diff --git a/src/m_dwNode.F90 b/src/gsi/m_dwNode.F90 similarity index 90% rename from src/m_dwNode.F90 rename to src/gsi/m_dwNode.F90 index abb16465c..3e211e078 100644 --- a/src/m_dwNode.F90 +++ b/src/gsi/m_dwNode.F90 @@ -23,8 +23,8 @@ module m_dwNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -73,6 +73,9 @@ module m_dwNode interface dwNode_typecast; module procedure typecast_ ; end interface interface dwNode_nextcast; module procedure nextcast_ ; end interface + public:: dwNode_appendto + interface dwNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_dwNode" #include "myassert.H" @@ -82,16 +85,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(dwNode) use m_obsNode, only: obsNode implicit none - type(dwNode),pointer:: ptr_ + type (dwNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(dwNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -100,15 +101,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(dwNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(dwNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type (dwNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(dwNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_extOzone.F90 b/src/gsi/m_extOzone.F90 similarity index 86% rename from src/m_extOzone.F90 rename to src/gsi/m_extOzone.F90 index 288d68b9d..31cdedbeb 100644 --- a/src/m_extOzone.F90 +++ b/src/gsi/m_extOzone.F90 @@ -29,6 +29,8 @@ module m_extOzone ! 2015-09-17 Thomas - add l4densvar and thin4d to data selection procedure ! 2015-10-01 guo - consolidate use of ob location (in deg) ! 2016-09-19 guo - moved function dfile_format() here from obsmod.F90. +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. +! 2018-05-25 wargan - added OMPS and hooks for LIMS, UARS MLS, MIPAS ! ! input argument list: see Fortran 90 style document below ! @@ -43,6 +45,7 @@ module m_extOzone ! module interface: use kinds, only: i_kind,r_kind,r_double + use obsmod, only: time_window_max implicit none private ! except @@ -70,6 +73,8 @@ module m_extOzone real (kind=r_kind), parameter:: badoz = 10000.0_r_kind real (kind=r_kind), parameter:: r6 = 6.0_r_kind real (kind=r_kind), parameter:: r360 = 360.0_r_kind + real (kind=r_kind) :: ptime,timeinflat,crit0 + integer(kind=i_kind) :: ithin_time,n_tbin,it_mesh contains function is_extOzone_(dfile,dtype,dplat,class) @@ -151,15 +156,27 @@ function is_extOzone_(dfile,dtype,dplat,class) select case(class_) case(iANY) is_extOzone_= & - ifile_==iBUFR .and. dtype == 'o3lev' .or. & - ifile_==iNC .and. dtype == 'mls55' .or. & - ifile_==iNC .and. dtype == 'omieff' .or. & + ifile_==iBUFR .and. dtype == 'o3lev' .or. & + ifile_==iNC .and. dtype == 'mls55' .or. & + ifile_==iNC .and. dtype == 'ompslpvis' .or. & + ifile_==iNC .and. dtype == 'ompslpuv' .or. & + ifile_==iNC .and. dtype == 'ompslp' .or. & + ifile_==iNC .and. dtype == 'lims' .or. & + ifile_==iNC .and. dtype == 'uarsmls' .or. & + ifile_==iNC .and. dtype == 'mipas' .or. & + ifile_==iNC .and. dtype == 'omieff' .or. & ifile_==iNC .and. dtype == 'tomseff' case(iLEVEL) is_extOzone_= & - ifile_==iBUFR .and. dtype == 'o3lev' .or. & - ifile_==iNC .and. dtype == 'mls55' + ifile_==iBUFR .and. dtype == 'o3lev' .or. & + ifile_==iNC .and. dtype == 'mls55' .or. & + ifile_==iNC .and. dtype == 'ompslpvis' .or. & + ifile_==iNC .and. dtype == 'ompslpuv' .or. & + ifile_==iNC .and. dtype == 'ompslp' .or. & + ifile_==iNC .and. dtype == 'lims' .or. & + ifile_==iNC .and. dtype == 'uarsmls' .or. & + ifile_==iNC .and. dtype == 'mipas' case(iLAYER) is_extOzone_= .false. @@ -259,6 +276,7 @@ subroutine read_(dfile,dtype,dplat,dsis, & ! intent(in), keys for type mana use constants, only: zero use mpeu_util, only: die,perr,tell use mpimod, only: npe + use satthin, only: satthin_time_info => radthin_time_info ! use mpeu_util, only: mprefix,stdout ! nobs - array of observations on each subdomain for each processor @@ -306,6 +324,12 @@ subroutine read_(dfile,dtype,dplat,dsis, & ! intent(in), keys for type mana call perr(myname_,' dplat =',dplat) call die (myname_) endif + call satthin_time_info(dtype, dplat, dsis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif select case(dtype) case('omieff','tomseff') ! layer-ozone or total-ozone types @@ -357,16 +381,16 @@ subroutine read_(dfile,dtype,dplat,dsis, & ! intent(in), keys for type mana jsatid, gstime,twind) end select - case('mls55') + case('mls55','ompslpvis','ompslpuv','ompslp','lims','uarsmls','mipas') select case(dfile_format(dfile)) case('nc') call ozlev_ncInquire_( nreal,nchan,ilat,ilon,maxobs) allocate(p_out(nreal+nchan,maxobs)) p_out(:,:)=RMISS - - call ozlev_ncRead_(dfile, p_out,nread,npuse,nouse, & - gstime,twind) + + call ozlev_ncRead_(dfile,dtype, p_out,nread,npuse,nouse, gstime,twind) + end select end select @@ -437,7 +461,7 @@ subroutine oztot_ncInquire_( nreal,nchan,ilat,ilon, ithin,rmesh,maxrec) ilon=3 ! Make thinning grids, and to define the total record size. - call satthin_makegrids(rmesh,ithin) + call satthin_makegrids(rmesh,ithin,n_tbin=n_tbin) maxrec=satthin_itxmax end subroutine oztot_ncInquire_ @@ -457,12 +481,13 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & use netcdf, only: nf90_close use satthin, only: satthin_makegrids => makegrids + use satthin, only: satthin_tdiff2crit => tdiff2crit use satthin, only: satthin_map2tgrid => map2tgrid use satthin, only: satthin_finalcheck => finalcheck use satthin, only: satthin_destroygrids => destroygrids use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons - use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar,thin4d + use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar use obsmod, only: nloz_omi use constants, only: deg2rad,zero,r60inv @@ -507,7 +532,7 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & real (kind=r_kind):: dlon,dlon_earth,dlon_earth_deg real (kind=r_kind):: dlat,dlat_earth,dlat_earth_deg - real (kind=r_kind):: tdiff,sstime,t4dv,timedif,crit1,dist1,rsat + real (kind=r_kind):: tdiff,sstime,t4dv,crit1,dist1,rsat integer(kind=i_kind):: idate5(5) real (kind=r_double):: totoz, sza @@ -527,7 +552,10 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & call check(nf90_open(trim(dfile),nf90_nowrite,ncid),stat=ier) ! ignore if the file is not actually present. - if(ier/=nf90_noerr) go to 136 + if(ier/=nf90_noerr) then + call satthin_destroygrids() + return + end if ! Get dimensions from OMI input file call check(nf90_inq_dimid(ncid, "nrec", nrecDimId),stat=ier) @@ -535,7 +563,8 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & ! ignore if the file header is empty if(ier/=nf90_noerr) then call check(nf90_close(ncid),stat=ier) - go to 136 + call satthin_destroygrids() + return endif ! Get dimensions from OMI/TOMS input file @@ -545,7 +574,8 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & ! ignore if the file header is empty if(ier/=nf90_noerr .or. nmrecs==0) then call check(nf90_close(ncid),stat=ier) - go to 136 + call satthin_destroygrids() + return endif ! Continue the input @@ -608,7 +638,7 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & call check(nf90_close(ncid)) ! now screen the data and put them into the right places - do irec = 1, nmrecs + recloop: do irec = 1, nmrecs iy = iya(irec) im = ima(irec) idd = idda(irec) @@ -636,7 +666,7 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & !!!! nmrecs=nmrecs+1 ! Convert observation location to radians - if(abs(slats)>90._r_kind .or. abs(slons)>r360) go to 135 + if(abs(slats)>90._r_kind .or. abs(slons)>r360) cycle recloop if(slons< zero) slons=slons+r360 if(slons==r360) slons=zero dlat_earth_deg = slats @@ -646,7 +676,7 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & if(regional)then call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if(outside) go to 135 + if(outside) cycle recloop else dlat = dlat_earth dlon = dlon_earth @@ -666,12 +696,12 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & sstime=real(nmind,r_kind) tdiff=(sstime-gstime)*r60inv if (l4dvar.or.l4densvar) then - if (t4dvwinlen) go to 135 + if (t4dvwinlen) cycle recloop else - if(abs(tdiff) > twind) go to 135 + if(abs(tdiff) > twind) cycle recloop end if - if (totoz > badoz ) goto 135 + if (totoz > badoz ) cycle recloop ! Apply data screening based on quality flags ! Bit 10 (from the left) in TOQF represents row anomaly. All 17 bits in toqf is @@ -681,42 +711,39 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & select case(dtype) case('omieff') - if (toqf .ne. 0 .and. toqf .ne. 1) go to 135 + if (toqf .ne. 0 .and. toqf .ne. 1) cycle recloop ! Remove obs at high solar zenith angles - if (sza > 84.0_r_kind) goto 135 + if (sza > 84.0_r_kind) cycle recloop ! remove the bad scan position data: fovn beyond 25 if (removeScans) then - if (fovn >=25_i_kind) goto 135 + if (fovn >=25_i_kind) cycle recloop endif - if (fovn <=2_i_kind .or. fovn >=58_i_kind) goto 135 + if (fovn <=2_i_kind .or. fovn >=58_i_kind) cycle recloop ! remove the data in which the C-pair algorithm ((331 and 360 nm) is used. - if (alqf == 3_i_kind .or. alqf == 13_i_kind) goto 135 + if (alqf == 3_i_kind .or. alqf == 13_i_kind) cycle recloop case('tomseff') ! The meaning of quality flags for TOMS version 8 is similar to that ! for SBUV: ! 0 - good data, 1 - good data with SZA > 84 deg - if (toqf /= 0) goto 135 + if (toqf /= 0) cycle recloop case default end select ! thin OMI/TOMS data - if (thin4d) then - timedif = zero - else - timedif = r6*abs(tdiff) ! range: 0 to 18 - endif - crit1 = 0.01_r_kind+timedif + crit0 = 0.01_r_kind + timeinflat=r6 + call satthin_tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) if (ithin /= 0) then - call satthin_map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,dsis) - if(.not. iuse)go to 135 + call satthin_map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,dsis,it_mesh=it_mesh) + if(.not. iuse)cycle recloop call satthin_finalcheck(dist1,crit1,itx,iuse) - if(.not. iuse)go to 135 + if(.not. iuse)cycle recloop ndata=ndata+1 nodata=ndata else @@ -753,13 +780,11 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & !! ASSERT_(size(ozout,1)==37) -135 continue - end do + end do recloop deallocate(iya,ima,idda,ihha,imina, & rseca,fovna,slatsa,slonsa,totoza, & toqfa,alqfa,szaa,aprioria,efficiencya) -136 continue ! end ! End of loop over observations ! End of OMI block with efficiency factors in NetCDF format @@ -769,6 +794,7 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & nodata=min(ndata,maxobs) ! write(stdout,'(3a,3i8,f8.2)') mprefix('read_ozone'), & ! ' obstype,nmrecs,ndata,nodata,no/ndata = ',dtype,nmrecs,ndata,nodata,real(nodata)/ndata + return end subroutine oztot_ncread_ !.................................................................................. @@ -788,7 +814,7 @@ subroutine ozlev_ncInquire_( nreal,nchan,ilat,ilon, maxrec) ! Configure the record, they are not (dfile,dtype,dplat) dependent in this case. nreal = 12 - nchan = 1 ! There are 'mlslevs' levels but each is treated + nchan = 1 ! There are 'levs' levels but each is treated ! as a separate observation so that nchanl = 1 ilat=4 ilon=3 @@ -797,7 +823,7 @@ subroutine ozlev_ncInquire_( nreal,nchan,ilat,ilon, maxrec) end subroutine ozlev_ncInquire_ !.................................................................................. -subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) +subroutine ozlev_ncread_(dfile,dtype,ozout,nmrecs,ndata,nodata, gstime,twind) !.................................................................................. use netcdf, only: nf90_open use netcdf, only: nf90_nowrite @@ -818,6 +844,7 @@ subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) implicit none character(len=*), intent(in):: dfile ! obs_input filename + character(len=*), intent(in):: dtype ! obs_input dtype real (kind=r_kind), dimension(:,:), intent(out):: ozout integer(kind=i_kind), intent(out):: nmrecs ! count of records read @@ -832,27 +859,23 @@ subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) integer(kind=i_kind):: ier, iprof, nprofs, maxobs integer(kind=i_kind):: i, ilev, ikx, ncid, k0 -! integer(kind=i_kind) ier, ncid, nomilevs integer(kind=i_kind),allocatable,dimension(:):: ipos integer(kind=i_kind):: nrecDimId,lonVarID,latVarID,yyVarID,mmVarID integer(kind=i_kind):: ddVarID,hhVarID,minVarID,ssVarID integer(kind=i_kind):: pressVarID - integer(kind=i_kind):: convVarID, qualVarID, mlserrVarID, mlsozoneVarID - integer(kind=i_kind):: mlslevsDimID,mlslevs + integer(kind=i_kind):: convVarID, errVarID, ozoneVarID + integer(kind=i_kind):: levsDimID,levs integer(kind=i_kind), allocatable :: iya(:),ima(:),idda(:),ihha(:),imina(:),iseca(:) real (kind=r_kind), allocatable :: slatsa(:),slonsa(:) - real (kind=r_kind), allocatable :: mlspress(:), mlsozone(:,:), mlsqual(:) - real (kind=r_kind), allocatable :: mlsconv(:), mlserr(:,:) + real (kind=r_kind), allocatable :: press(:), ozone(:,:), qual(:), press2d(:,:) + real (kind=r_kind), allocatable :: conv(:), err(:,:) integer(kind=i_kind):: nmind real (kind=r_kind):: slons0,slats0 real (kind=r_kind):: ppmv, pres, pob, obserr, usage - !real(kind=r_kind) tdiff,sstime,slons,slats,dlon,dlat,t4dv,timedif,crit1,dist1 - !real(kind=r_kind) !slons0,slats0,rsat,solzen,solzenp,dlat_earth,dlon_earth - !real(kind=r_kind) !rsec, ppmv, prec, pres, pob, obserr, usage real (kind=r_kind):: dlon,dlon_earth,dlon_earth_deg real (kind=r_kind):: dlat,dlat_earth,dlat_earth_deg @@ -868,68 +891,74 @@ subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) nmrecs=0 nodata=-1 !.................................................................................. - ! ---------------MLS NRT NetCDF ----------------------------- - ! Process MLS o3lev in NetCDF format + ! ---------------MLS and other limb ozone data in NetCDF format ---------- ! Open file and read dimensions call check(nf90_open(trim(dfile),nf90_nowrite,ncid),stat=ier) ! ignore if the file is not actually present. - if(ier/=nf90_noerr) return ! go to 170 - + if(ier/=nf90_noerr) return + ! Get dimensions from OMI input file call check(nf90_inq_dimid(ncid, "nprofiles", nrecDimId),stat=ier) ! ignore if the file header is empty if(ier/=nf90_noerr) then call check(nf90_close(ncid),stat=ier) - return ! go to 170 + return endif - ! Get dimensions from MLS input file: # of profiles and # of levels + ! Get dimensions from the input file: # of profiles and # of levels nprofs=0 call check(nf90_inquire_dimension(ncid, nrecDimId, len = nprofs),stat=ier) ! ignore if the file header is empty if(ier/=nf90_noerr) then call check(nf90_close(ncid),stat=ier) - return ! go to 170 + return endif if(nprofs==0) then nodata=0 call check(nf90_close(ncid),stat=ier) - return ! go to 170 + return endif ! Continue the input - call check(nf90_inq_dimid(ncid, "nlevs", mlslevsDimId)) - call check(nf90_inquire_dimension(ncid, mlslevsDimId, len = mlslevs)) + call check(nf90_inq_dimid(ncid, "nlevs", levsDimId)) + call check(nf90_inquire_dimension(ncid, levsDimId, len = levs)) ! NOTE: Make sure that 'ozinfo' has the same number of levels ! for NRT it is 55 - allocate(ipos(mlslevs)) - + allocate(ipos(levs)) ipos=999 + + ! Process limb data in NetDCF format ikx = 0 first=.false. do i=1,jpch_oz - if( (.not. first) .and. index(nusis_oz(i),'mls55')/=0) then + if( (.not. first) .and. index(nusis_oz(i), trim(dtype))/=0) then k0=i first=.true. end if - if(first.and.index(nusis_oz(i),'mls55')/=0) then ! MLS .nc data + if(first.and.index(nusis_oz(i),trim(dtype))/=0) then ikx=ikx+1 ipos(ikx)=k0+ikx-1 end if end do - if (ikx/=mlslevs) call die(myname_//': inconsistent mlslevs') - + + if (ikx/=levs) call die(myname_//': inconsistent levs for '//dtype) + nmrecs=0 ! Allocate space and read data allocate(iya(nprofs),ima(nprofs),idda(nprofs),ihha(nprofs),imina(nprofs), & - iseca(nprofs),slatsa(nprofs),slonsa(nprofs), mlsozone(mlslevs,nprofs), & - mlserr(mlslevs,nprofs),mlsqual(nprofs), mlsconv(nprofs), mlspress(mlslevs)) + iseca(nprofs),slatsa(nprofs),slonsa(nprofs), ozone(levs,nprofs), & + err(levs,nprofs),qual(nprofs), conv(nprofs)) + if (index(dtype, 'ompslp') == 0) then + allocate(press(levs)) + else + allocate(press2d(levs,nprofs)) + endif ! Read variables and store them in these arrays call check(nf90_inq_varid(ncid, "lon", lonVarId)) @@ -956,20 +985,27 @@ subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) call check(nf90_inq_varid(ncid, "ss", ssVarId)) call check(nf90_get_var(ncid, ssVarId, iseca)) - call check(nf90_inq_varid(ncid, "press", pressVarId)) - call check(nf90_get_var(ncid, pressVarId, mlspress)) - - call check(nf90_inq_varid(ncid, "conv", convVarId)) - call check(nf90_get_var(ncid, convVarId, mlsconv)) + if (index(dtype, 'ompslp') == 0) then + call check(nf90_inq_varid(ncid, "press", pressVarId)) + call check(nf90_get_var(ncid, pressVarId, press)) + else + call check(nf90_inq_varid(ncid, "press", pressVarId)) + call check(nf90_get_var(ncid, pressVarId, press2d)) + endif - call check(nf90_inq_varid(ncid, "qual", qualVarId)) - call check(nf90_get_var(ncid, qualVarId, mlsqual)) + if (index(dtype, 'ompslp') == 0) then + call check(nf90_inq_varid(ncid, "conv", convVarId)) + call check(nf90_get_var(ncid, convVarId, conv)) + end if - call check(nf90_inq_varid(ncid, "oberr", mlserrVarId)) - call check(nf90_get_var(ncid, mlserrVarId, mlserr)) + ! call check(nf90_inq_varid(ncid, "qual", qualVarId)) + ! call check(nf90_get_var(ncid, qualVarId, qual)) + + call check(nf90_inq_varid(ncid, "oberr", errVarId)) + call check(nf90_get_var(ncid, errVarId, err)) - call check(nf90_inq_varid(ncid, "ozone", mlsozoneVarId)) - call check(nf90_get_var(ncid, mlsozoneVarId, mlsozone)) + call check(nf90_inq_varid(ncid, "ozone", ozoneVarId)) + call check(nf90_get_var(ncid, ozoneVarId, ozone)) ! close the data file call check(nf90_close(ncid)) @@ -978,17 +1014,12 @@ subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) nmrecs = 0 nodata = 0 do iprof = 1, nprofs - do ilev = 1, mlslevs + do ilev = 1, levs ! note that most of the quality control is done at the ! pre-processing stage - if (mlspress(ilev) .gt. 262.0 .or. mlspress(ilev) .lt. 0.1 ) cycle ! goto 145 - if (mlsozone(ilev, iprof) .lt. -900.0) cycle ! goto 145 ! undefined - if (mlserr(ilev, iprof) .lt. -900.0) cycle ! goto 145 ! undefined -! if (ndata >= maxobs) then -! write(6,*) ' read_ozone: Number of MLS obs reached maxobs = ', & -! maxobs -! return ! goto 150 -! endif +!! if (press(ilev) > 262.0_r_kind .or. press(ilev) < 0.1_r_kind ) cycle ! undefined + if (ozone(ilev, iprof) < -900.0_r_kind) cycle ! undefined + if (err(ilev, iprof) < -900.0_r_kind) cycle ! undefined if (iuse_oz(ipos(ilev)) < 0) then usage = 100._r_kind else @@ -1015,8 +1046,6 @@ subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) dlon = dlon_earth call grdcrd1(dlat,rlats,nlat,1) call grdcrd1(dlon,rlons,nlon,1) - ! call grdcrd(dlat,1,rlats,nlat,1) - ! call grdcrd(dlon,1,rlons,nlon,1) endif idate5(1) = iya(iprof) !year @@ -1028,7 +1057,7 @@ subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) t4dv=real((nmind-iwinbgn),r_kind)*r60inv if (l4dvar.or.l4densvar) then if (t4dvwinlen) then - write(6,*)'read_ozone: mls obs time idate5=',idate5,', t4dv=',& + write(6,*)'read_ozone: ', dtype,' obs time idate5=',idate5,', t4dv=',& t4dv,' is outside time window, sstime=',sstime*r60inv cycle end if @@ -1036,17 +1065,20 @@ subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) sstime=real(nmind,r_kind) tdiff=(sstime-gstime)*r60inv if(abs(tdiff) > twind)then - write(6,*)'read_ozone: mls obs time idate5=',idate5,', tdiff=',& + write(6,*)'read_ozone: ',dtype,' obs time idate5=',idate5,', tdiff=',& tdiff,' is outside time window=',twind cycle end if end if - - obserr = mlserr(ilev, iprof) - ppmv = mlsozone(ilev, iprof) - pres = mlspress(ilev) - pob = log(pres * one_tenth) + obserr = err(ilev, iprof) + ppmv = ozone(ilev, iprof) + if (index(dtype, 'ompslp') == 0) then + pres = press(ilev) + else + pres = press2d(ilev, iprof) + end if + pob = log(pres * one_tenth) ndata = ndata+1 if(ndata<=maxobs) then nodata = nodata + 1 @@ -1062,31 +1094,34 @@ subroutine ozlev_ncread_(dfile, ozout,nmrecs,ndata,nodata, gstime,twind) ozout(9,ndata)=pob ! pressure ozout(10,ndata)=obserr ! ozone mixing ratio precision in ppmv ozout(11,ndata)=float(ipos(ilev)) ! pointer of obs level index in ozinfo.txt - ozout(12,ndata)=mlslevs ! # of mls vertical levels + ozout(12,ndata)=levs ! # of vertical levels ozout(13,ndata)=ppmv ! ozone mixing ratio in ppmv endif -! 145 continue end do end do - deallocate(iya,ima,idda,ihha,imina,iseca,slatsa,slonsa, mlsozone, & - mlserr,mlsqual, mlsconv, mlspress) + deallocate(iya,ima,idda,ihha,imina,iseca,slatsa,slonsa, ozone, & + err,qual, conv) + if (index(dtype, 'ompslp') == 0) then + deallocate(press) + else + deallocate(press2d) + end if deallocate(ipos) + + ! write(stdout,'(3a,3i8,f8.2)') mprefix('read_ozone'), & + ! ' obstype,nmrecs,ndata,nodata,no/ndata = ',dtype,nmrecs,ndata,nodata,real(nodata)/ndata + + if (ndata > maxobs) then + call perr(myname_,'Number of limb obs reached maxobs = ', maxobs) + call perr(myname_,' ndata = ', ndata) + call perr(myname_,' nodata = ', nodata) + call die(myname_) + endif -! write(stdout,'(3a,3i8,f8.2)') mprefix('read_ozone'), & -! ' obstype,nmrecs,ndata,nodata,no/ndata = ',dtype,nmrecs,ndata,nodata,real(nodata)/ndata - - if (ndata > maxobs) then - call perr('read_ozone','Number of MLS obs reached maxobs = ', maxobs) - call perr(myname_,'Number of MLS obs reached maxobs = ', maxobs) - call perr(myname_,' ndata = ', ndata) - call perr(myname_,' nodata = ', nodata) - call die(myname_) - endif !---------------END MLS NRT NetCDF--------------------------- -!!end subroutine read_mlsnc_ end subroutine ozlev_ncread_ subroutine ozlev_bufrInquire_(nreal,nchan,ilat,ilon,maxrec) @@ -1233,12 +1268,12 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & !! This is the top of the profile loop ndata=0 iprofs=0 -139 continue + obsloop: do call readsb(lunin,iret) if (iret/=0) then !JJJ, end of the subset call readmg(lunin,subset,jdate,iret) !JJJ open a new mg - if (iret/=0) goto 150 !JJJ, no more mg, EOF - goto 139 + if (iret/=0) exit obsloop !JJJ, no more mg, EOF + cycle obsloop endif do k=1,nloz @@ -1254,14 +1289,14 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & rsat = hdrmls(1); ksatid=rsat if(jsatid == 'aura')kidsat = 785 - if (ksatid /= kidsat) go to 139 + if (ksatid /= kidsat) cycle obsloop nmrecs=nmrecs+nloz ! Convert observation location to radians slats0= hdrmls(2) slons0= hdrmls(3) - if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) go to 139 + if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle obsloop if(slons0< zero) slons0=slons0+r360 if(slons0==r360) slons0=zero dlat_earth_deg = slats0 @@ -1271,7 +1306,7 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & if(regional)then call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if(outside) go to 139 + if(outside) cycle obsloop else dlat = dlat_earth dlon = dlon_earth @@ -1292,7 +1327,7 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & if (t4dvwinlen) then write(6,*)'read_ozone: mls obs time idate5=',idate5,', t4dv=',& t4dv,' is outside time window, sstime=',sstime*r60inv - go to 139 + cycle obsloop endif else sstime=real(nmind,r_kind) @@ -1300,7 +1335,7 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & if (abs(tdiff) > twind) then write(6,*)'read_ozone: mls obs time idate5=',idate5,', tdiff=',& tdiff,' is outside time window=',twind - go to 139 + cycle obsloop endif end if @@ -1318,9 +1353,9 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & decimal=int(hdrmls(12)) call dec2bin(decimal,binary_mls,18) - if (binary_mls(1) == 1 ) goto 139 + if (binary_mls(1) == 1 ) cycle obsloop - if(hdrmls(11) >= 1.8_r_kind) go to 139 + if(hdrmls(11) >= 1.8_r_kind) cycle obsloop ! extract pressure, ozone mixing ratio and precision call ufbrep(lunin,hdrmlsl2,4,nloz,iret,mlstrl2) @@ -1377,8 +1412,7 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & endif end do - go to 139 -150 continue ! this is the bottom of the profile loop + end do obsloop ! End of o3lev bufr loop nodata=min(ndata,maxobs) ! count of retained data diff --git a/src/m_find.f90 b/src/gsi/m_find.f90 similarity index 100% rename from src/m_find.f90 rename to src/gsi/m_find.f90 diff --git a/src/m_gpsNode.F90 b/src/gsi/m_gpsNode.F90 similarity index 92% rename from src/m_gpsNode.F90 rename to src/gsi/m_gpsNode.F90 index 72bf975f3..513962814 100644 --- a/src/m_gpsNode.F90 +++ b/src/gsi/m_gpsNode.F90 @@ -23,8 +23,8 @@ module m_gpsNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell @@ -77,6 +77,9 @@ module m_gpsNode interface gpsNode_typecast; module procedure typecast_ ; end interface interface gpsNode_nextcast; module procedure nextcast_ ; end interface + public:: gpsNode_appendto + interface gpsNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_gpsNode" #include "myassert.H" @@ -86,16 +89,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(gpsNode) use m_obsNode, only: obsNode implicit none - type(gpsNode),pointer:: ptr_ + type(gpsNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(gpsNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -104,23 +105,37 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(gpsNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(gpsNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(gpsNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(gpsNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + +! obsNode implementations + function mytype() implicit none character(len=:),allocatable:: mytype mytype="[gpsNode]" end function mytype -! obsNode implementations - subroutine obsHeader_read_(iunit,mobs,jread,istat) use gridmod, only: nsig implicit none diff --git a/src/m_gpsrhs.F90 b/src/gsi/m_gpsrhs.F90 similarity index 100% rename from src/m_gpsrhs.F90 rename to src/gsi/m_gpsrhs.F90 diff --git a/src/m_gsiBiases.f90 b/src/gsi/m_gsiBiases.f90 similarity index 100% rename from src/m_gsiBiases.f90 rename to src/gsi/m_gsiBiases.f90 diff --git a/src/m_gustNode.F90 b/src/gsi/m_gustNode.F90 similarity index 89% rename from src/m_gustNode.F90 rename to src/gsi/m_gustNode.F90 index a7567556f..8d3efdec3 100644 --- a/src/m_gustNode.F90 +++ b/src/gsi/m_gustNode.F90 @@ -23,8 +23,8 @@ module m_gustNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -69,6 +69,9 @@ module m_gustNode interface gustNode_typecast; module procedure typecast_ ; end interface interface gustNode_nextcast; module procedure nextcast_ ; end interface + public:: gustNode_appendto + interface gustNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_gustNode" #include "myassert.H" @@ -80,14 +83,12 @@ function typecast_(aNode) result(ptr_) implicit none type(gustNode),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(gustNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -97,14 +98,28 @@ function nextcast_(aNode) result(ptr_) use m_obsNode, only: obsNode,obsNode_next implicit none type(gustNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(gustNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_howvNode.F90 b/src/gsi/m_howvNode.F90 similarity index 89% rename from src/m_howvNode.F90 rename to src/gsi/m_howvNode.F90 index bfadbf32a..ab322cdc0 100644 --- a/src/m_howvNode.F90 +++ b/src/gsi/m_howvNode.F90 @@ -24,8 +24,8 @@ module m_howvNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,39 +71,57 @@ module m_howvNode interface howvNode_typecast; module procedure typecast_ ; end interface interface howvNode_nextcast; module procedure nextcast_ ; end interface + public:: howvNode_appendto + interface howvNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_howvNode" #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(howvNode) use m_obsNode, only: obsNode implicit none type(howvNode),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(howvNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(howvNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(howvNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(howvNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_lagNode.F90 b/src/gsi/m_lagNode.F90 similarity index 91% rename from src/m_lagNode.F90 rename to src/gsi/m_lagNode.F90 index fc3a571e5..1eba38699 100644 --- a/src/m_lagNode.F90 +++ b/src/gsi/m_lagNode.F90 @@ -23,8 +23,8 @@ module m_lagNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -77,6 +77,9 @@ module m_lagNode interface lagNode_typecast; module procedure typecast_ ; end interface interface lagNode_nextcast; module procedure nextcast_ ; end interface + public:: lagNode_appendto + interface lagNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_lagNode" #include "myassert.H" @@ -86,16 +89,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(lagNode) use m_obsNode, only: obsNode implicit none - type(lagNode),pointer:: ptr_ + type(lagNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(lagNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -104,15 +105,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(lagNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(lagNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(lagNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(lagNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() @@ -135,7 +150,7 @@ end subroutine obsNode_init_ subroutine obsNode_clean_(aNode) implicit none - class(lagNode) ,intent(inout):: aNode + class(lagNode),intent(inout):: aNode character(len=*),parameter:: myname_=MYNAME//'::obsNode_clean_' _ENTRY_(myname_) diff --git a/src/m_latlonRange.F90 b/src/gsi/m_latlonRange.F90 similarity index 98% rename from src/m_latlonRange.F90 rename to src/gsi/m_latlonRange.F90 index 189fc9207..15e4e1491 100644 --- a/src/m_latlonRange.F90 +++ b/src/gsi/m_latlonRange.F90 @@ -31,6 +31,7 @@ module m_latlonRange use mpeu_mpif, only: MPI_iKIND use mpeu_util, only: assert_ use mpeu_util, only: tell,perr,die + use timermod, only: timer_ini,timer_fnl implicit none private ! except public :: latlonRange ! data structure @@ -147,14 +148,11 @@ module m_latlonRange #ifdef _TIMER_ON_ #undef _TIMER_ON_ #undef _TIMER_OFF_ -#undef _TIMER_USE_ #define _TIMER_ON_(id) call timer_ini(id) #define _TIMER_OFF_(id) call timer_fnl(id) -#define _TIMER_USE_ use timermod, only: timer_ini,timer_fnl #else #define _TIMER_ON_(id) #define _TIMER_OFF_(id) -#define _TIMER_USE_ #endif !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ character(len=*),parameter :: myname='m_latlonRange' @@ -352,7 +350,6 @@ subroutine gatherWrite_(llrange,hdfile,root,comm) use gsi_unformatted, only: unformatted_open use mpimod, only: nPEs => nPE use mpimod, only: myPE - _TIMER_USE_ implicit none type(latlonRange ),intent(in):: llrange ! a laglonRange to write character(len=* ),intent(in):: hdfile ! a filename to write to @@ -421,7 +418,6 @@ subroutine readBcast_(hdfile,allRanges,root,comm) use gsi_unformatted, only: unformatted_open use mpeu_mpif, only: MPI_type use mpimod, only: myPE - _TIMER_USE_ implicit none character(len=* ),intent(in):: hdfile ! input file type(latlonRange),dimension(0:),intent(out):: allranges ! data received by all PEs. @@ -492,7 +488,6 @@ subroutine alldump_(allRanges,varname) use mpeu_util, only: stdout_lead use mpeu_util, only: stdout_open use mpeu_util, only: stdout_close - _TIMER_USE_ implicit none type(latlonRange), dimension(0:), intent(in):: allRanges character(len=* ), intent(in):: varname @@ -514,8 +509,7 @@ subroutine alldump_(allRanges,varname) end subroutine alldump_ subroutine gatherdump_local_(varname,root,comm) -!-- gahter-dump the internal lat-lon-range of the cvgrid, localRange_ - _TIMER_USE_ +!-- gather-dump the internal lat-lon-range of the cvgrid, localRange_ implicit none character(len=* ),intent(in):: varname ! identity of the range integer(kind=i_kind),intent(in):: root @@ -537,7 +531,6 @@ subroutine gatherdump_(llrange,varname,root,comm) use mpeu_util, only: stdout_lead use mpimod, only: nPEs => nPE use mpimod, only: myPE - _TIMER_USE_ implicit none type(latlonRange ),intent(in):: llrange ! a laglonRange to write character(len=* ),intent(in):: varname ! identity of the range diff --git a/src/m_lcbasNode.F90 b/src/gsi/m_lcbasNode.F90 similarity index 88% rename from src/m_lcbasNode.F90 rename to src/gsi/m_lcbasNode.F90 index 22d89afa5..81eabfbb4 100644 --- a/src/m_lcbasNode.F90 +++ b/src/gsi/m_lcbasNode.F90 @@ -24,8 +24,8 @@ module m_lcbasNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,39 +71,57 @@ module m_lcbasNode interface lcbasNode_typecast; module procedure typecast_ ; end interface interface lcbasNode_nextcast; module procedure nextcast_ ; end interface + public:: lcbasNode_appendto + interface lcbasNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_lcbasNode" #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(lcbasNode) use m_obsNode, only: obsNode implicit none type(lcbasNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" + class(obsNode ),pointer,intent(in):: aNode ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(lcbasNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(lcbasNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(lcbasNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode ),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(lcbasNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/gsi/m_lightNode.F90 b/src/gsi/m_lightNode.F90 new file mode 100644 index 000000000..463e6e187 --- /dev/null +++ b/src/gsi/m_lightNode.F90 @@ -0,0 +1,832 @@ +module m_lightNode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_lightNode +! prgmmr: k apodaca +! org: CSU/CIRA, Data Assimilation Group +! date: 2018-01-18 +! +! abstract: class-module of obs-type lightNode (Lightning) +! +! program history log: +! 2018-01-18 k apodaca - add this document block for the implementation of +! variational lightning data assimilation. +! 2018-08-26 k apodaca - add coefficients relaed to a second observaion operator +! for lighning flash rate, suitable for non-hydrostatic, +! cloud-resolving models. +! + +! . . . . + +! In the case of lightning observations (e.g. GOES/GLM), the schematic shown below is +! used for the interpolation of background fields to the location of an observation (+) +! and for the finite-difference derivation method used in the calculation of the TL of +! the observation operator for lightning flash rate. Calculations are done at each +! quadrant (i.e. central, north, south, east, and west). +! +! i6-------i8 +! | | +! | | +! i10-----i2-------i4-----i12 +! | | | | +! | | + | | +! i9------i1-------i3-----i11 +! | | +! | | +! i5-------i7 +! + +! . . . . + +! 2019-03-01 j guo - Merged in some cleaning up changes as in other +! obsNode types: +! . Added a type specific subroutine appendto_(), to avoid +! unnecessary type generalization between a generic +! append() and user code. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsNode, only: obsNode + implicit none + private + + public:: lightNode + + type,extends(obsNode):: lightNode + !type(light_ob_type),pointer :: llpoint => NULL() + type(obs_diag), pointer :: diags => NULL() + real(r_kind) :: res =0._r_kind ! light residual + real(r_kind) :: err2 =0._r_kind ! light error squared + real(r_kind) :: raterr2=0._r_kind ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b =0._r_kind ! variational quality control parameter + real(r_kind) :: pg =0._r_kind ! variational quality control parameter + real(r_kind) :: wij(4) =0._r_kind ! horizontal interpolation weights + +! Central quadrant + real(r_kind),pointer :: jac_z0i1 => NULL() ! surface z at i1 + real(r_kind),pointer :: jac_z0i2 => NULL() ! surface z at i2 + real(r_kind),pointer :: jac_z0i3 => NULL() ! surface z at i3 + real(r_kind),pointer :: jac_z0i4 => NULL() ! surface z at i4 + real(r_kind),dimension(:),pointer :: jac_vertqi1 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertqi2 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertqi3 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertqi4 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti1 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti2 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti3 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti4 => NULL() + real(r_kind),dimension(:),pointer :: jac_zdxi1 => NULL() + real(r_kind),dimension(:),pointer :: jac_zdxi2 => NULL() + real(r_kind),dimension(:),pointer :: jac_zdxi3 => NULL() + real(r_kind),dimension(:),pointer :: jac_zdxi4 => NULL() + real(r_kind),dimension(:),pointer :: jac_zdyi1 => NULL() + real(r_kind),dimension(:),pointer :: jac_zdyi2 => NULL() + real(r_kind),dimension(:),pointer :: jac_zdyi3 => NULL() + real(r_kind),dimension(:),pointer :: jac_zdyi4 => NULL() + real(r_kind),dimension(:),pointer :: jac_udxi1 => NULL() + real(r_kind),dimension(:),pointer :: jac_udxi2 => NULL() + real(r_kind),dimension(:),pointer :: jac_udxi3 => NULL() + real(r_kind),dimension(:),pointer :: jac_udxi4 => NULL() + real(r_kind),dimension(:),pointer :: jac_vdyi1 => NULL() + real(r_kind),dimension(:),pointer :: jac_vdyi2 => NULL() + real(r_kind),dimension(:),pointer :: jac_vdyi3 => NULL() + real(r_kind),dimension(:),pointer :: jac_vdyi4 => NULL() + real(r_kind),dimension(:),pointer :: jac_vert => NULL() + real(r_kind),dimension(:),pointer :: jac_sigdoti1 => NULL() + real(r_kind),dimension(:),pointer :: jac_sigdoti2 => NULL() + real(r_kind),dimension(:),pointer :: jac_sigdoti3 => NULL() + real(r_kind),dimension(:),pointer :: jac_sigdoti4 => NULL() + real(r_kind),dimension(:),pointer :: jac_qi1 => NULL() + real(r_kind),dimension(:),pointer :: jac_qi2 => NULL() + real(r_kind),dimension(:),pointer :: jac_qi3 => NULL() + real(r_kind),dimension(:),pointer :: jac_qi4 => NULL() + real(r_kind),dimension(:),pointer :: jac_ti1 => NULL() + real(r_kind),dimension(:),pointer :: jac_ti2 => NULL() + real(r_kind),dimension(:),pointer :: jac_ti3 => NULL() + real(r_kind),dimension(:),pointer :: jac_ti4 => NULL() + real(r_kind),dimension(:),pointer :: jac_qgmai1 => NULL() + real(r_kind),dimension(:),pointer :: jac_qgmai2 => NULL() + real(r_kind),dimension(:),pointer :: jac_qgmai3 => NULL() + real(r_kind),dimension(:),pointer :: jac_qgmai4 => NULL() + real(r_kind),dimension(:),pointer :: jac_qgmbi1 => NULL() + real(r_kind),dimension(:),pointer :: jac_qgmbi2 => NULL() + real(r_kind),dimension(:),pointer :: jac_qgmbi3 => NULL() + real(r_kind),dimension(:),pointer :: jac_qgmbi4 => NULL() + real(r_kind),dimension(:),pointer :: jac_icei1 => NULL() + real(r_kind),dimension(:),pointer :: jac_icei2 => NULL() + real(r_kind),dimension(:),pointer :: jac_icei3 => NULL() + real(r_kind),dimension(:),pointer :: jac_icei4 => NULL() + real(r_kind),dimension(:),pointer :: jac_zicei1 => NULL() + real(r_kind),dimension(:),pointer :: jac_zicei2 => NULL() + real(r_kind),dimension(:),pointer :: jac_zicei3 => NULL() + real(r_kind),dimension(:),pointer :: jac_zicei4 => NULL() + real(r_kind),pointer :: kboti1 => NULL() + real(r_kind),pointer :: kboti2 => NULL() + real(r_kind),pointer :: kboti3 => NULL() + real(r_kind),pointer :: kboti4 => NULL() + real(r_kind),pointer :: jac_kverti1 => NULL() + real(r_kind),pointer :: jac_kverti2 => NULL() + real(r_kind),pointer :: jac_kverti3 => NULL() + real(r_kind),pointer :: jac_kverti4 => NULL() + real(r_kind),pointer :: jac_fratei1 => NULL() + real(r_kind),pointer :: jac_fratei2 => NULL() + real(r_kind),pointer :: jac_fratei3 => NULL() + real(r_kind),pointer :: jac_fratei4 => NULL() + logical,pointer :: jac_wmaxflagi1 => NULL() ! wmax flag at i1 + logical,pointer :: jac_wmaxflagi2 => NULL() ! wmax flag at i2 + logical,pointer :: jac_wmaxflagi3 => NULL() ! wmax flag at i3 + logical,pointer :: jac_wmaxflagi4 => NULL() ! wmax flag at i4 + +! South quadrant + real(r_kind),pointer :: jac_z0i5 => NULL() + real(r_kind),pointer :: jac_z0i7 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertqi5 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertqi7 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti5 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti7 => NULL() + +! North quadrant + real(r_kind),pointer :: jac_z0i6 => NULL() + real(r_kind),pointer :: jac_z0i8 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertqi6 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertqi8 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti6 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti8 => NULL() + +! West quadrant + real(r_kind),pointer :: jac_z0i9 => NULL() ! surface z at i9 + real(r_kind),pointer :: jac_z0i10 => NULL() ! surface z at i10 + real(r_kind),dimension(:),pointer :: jac_vertqi9 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertqi10 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti9 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti10 => NULL() + +! East quadrant + real(r_kind),pointer :: jac_z0i11 => NULL() ! surface z at i11 + real(r_kind),pointer :: jac_z0i12 => NULL() ! surface z at i12 + real(r_kind),dimension(:),pointer :: jac_vertqi11 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertqi12 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti11 => NULL() + real(r_kind),dimension(:),pointer :: jac_vertti12 => NULL() + + integer(i_kind),dimension(:,:),pointer :: ij => NULL() + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: setHop => obsNode_setHop_ + procedure:: xread => obsNode_xread_ + procedure:: xwrite => obsNode_xwrite_ + procedure:: isvalid => obsNode_isvalid_ + procedure:: gettlddp => gettlddp_ + + procedure, nopass:: headerRead => obsHeader_read_ + procedure, nopass:: headerWrite => obsHeader_write_ + procedure:: init => obsNode_init_ + procedure:: clean => obsNode_clean_ + end type lightNode + + public:: lightNode_typecast + public:: lightNode_nextcast + interface lightNode_typecast; module procedure typecast_ ; end interface + interface lightNode_nextcast; module procedure nextcast_ ; end interface + + public:: lightNode_appendto + interface lightNode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: MYNAME="m_lightNode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(lightNode) + use m_obsNode, only: obsNode + implicit none + type(lightNode),pointer:: ptr_ + class(obsNode ),pointer,intent(in):: aNode + + ptr_ => null() + if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(aNode) + type is(lightNode) + ptr_ => aNode + end select + return +end function typecast_ + +function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(lightNode) + use m_obsNode, only: obsNode,obsNode_next + implicit none + type(lightNode),pointer:: ptr_ + class(obsNode ),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(lightNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + +! obsNode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[lightNode]" +end function mytype + +subroutine obsHeader_read_(iunit,mobs,jread,istat) + use gridmod, only: nsig + implicit none + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent(out):: mobs + integer(i_kind),intent(out):: jread + integer(i_kind),intent(out):: istat + + character(len=*),parameter:: myname_=myname//"::obsHeader_read" + integer(i_kind):: msig +_ENTRY_(myname_) + + msig=-1 + read(iunit,iostat=istat) mobs,jread, msig + if(istat==0 .and. msig/=nsig) then + call perr(myname_,'unmatched dimension information, expecting nsig =',nsig) + call perr(myname_,' but read msig =',msig) + call die(myname_) + endif +_EXIT_(myname_) + return +end subroutine obsHeader_read_ + +subroutine obsHeader_write_(junit,mobs,jwrite,jstat) + use gridmod, only: nsig + implicit none + integer(i_kind),intent(in ):: junit + integer(i_kind),intent(in ):: mobs + integer(i_kind),intent(in ):: jwrite + integer(i_kind),intent(out):: jstat + + character(len=*),parameter:: myname_=myname//"::obsHeader_write" +_ENTRY_(myname_) + write(junit,iostat=jstat) mobs,jwrite, nsig +_EXIT_(myname_) + return +end subroutine obsHeader_write_ + +subroutine obsNode_init_(aNode) + use gridmod, only: nsig + implicit none + class(lightNode),intent(out):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_init_' +_ENTRY_(myname_) + allocate(aNode%jac_z0i1, aNode%jac_z0i2, & + aNode%jac_z0i3, aNode%jac_z0i4, & + aNode%jac_z0i5, aNode%jac_z0i6, & + aNode%jac_z0i7, aNode%jac_z0i8, & + aNode%jac_z0i9, aNode%jac_z0i10, & + aNode%jac_z0i11, aNode%jac_z0i12 ) + + allocate(aNode%jac_vertqi1(nsig), aNode%jac_vertqi2(nsig), & + aNode%jac_vertqi3(nsig), aNode%jac_vertqi4(nsig), & + aNode%jac_vertqi5(nsig), aNode%jac_vertqi6(nsig), & + aNode%jac_vertqi7(nsig), aNode%jac_vertqi8(nsig), & + aNode%jac_vertqi9(nsig), aNode%jac_vertqi10(nsig), & + aNode%jac_vertqi11(nsig),aNode%jac_vertqi12(nsig) ) + + + allocate(aNode%jac_vertti1(nsig), aNode%jac_vertti2(nsig), & + aNode%jac_vertti3(nsig), aNode%jac_vertti4(nsig), & + aNode%jac_vertti5(nsig), aNode%jac_vertti6(nsig), & + aNode%jac_vertti7(nsig), aNode%jac_vertti8(nsig), & + aNode%jac_vertti9(nsig), aNode%jac_vertti10(nsig), & + aNode%jac_vertti11(nsig),aNode%jac_vertti12(nsig) ) + + allocate(aNode%jac_zdxi1(nsig), aNode%jac_zdxi2(nsig), & + aNode%jac_zdxi3(nsig), aNode%jac_zdxi4(nsig) ) + + allocate(aNode%jac_zdyi1(nsig), aNode%jac_zdyi2(nsig), & + aNode%jac_zdyi3(nsig), aNode%jac_zdyi4(nsig) ) + + allocate(aNode%jac_udxi1(nsig), aNode%jac_udxi2(nsig), & + aNode%jac_udxi3(nsig), aNode%jac_udxi4(nsig) ) + + allocate(aNode%jac_vdyi1(nsig), aNode%jac_vdyi2(nsig), & + aNode%jac_vdyi3(nsig), aNode%jac_vdyi4(nsig) ) + + allocate(aNode%jac_vert(nsig) ) + + allocate(aNode%jac_sigdoti1(nsig),aNode%jac_sigdoti2(nsig), & + aNode%jac_sigdoti3(nsig),aNode%jac_sigdoti4(nsig) ) + + allocate(aNode%jac_qi1(nsig), aNode%jac_qi2(nsig), & + aNode%jac_qi3(nsig), aNode%jac_qi4(nsig) ) + + allocate(aNode%jac_ti1(nsig), aNode%jac_ti2(nsig), & + aNode%jac_ti3(nsig), aNode%jac_ti4(nsig) ) + + allocate(aNode%jac_qgmai1(nsig), aNode%jac_qgmai2(nsig), & + aNode%jac_qgmai3(nsig), aNode%jac_qgmai4(nsig) ) + + allocate(aNode%jac_qgmbi1(nsig), aNode%jac_qgmbi2(nsig), & + aNode%jac_qgmbi3(nsig), aNode%jac_qgmbi4(nsig) ) + + allocate(aNode%jac_icei1(nsig), aNode%jac_icei2(nsig), & + aNode%jac_icei3(nsig), aNode%jac_icei4(nsig) ) + + allocate(aNode%jac_zicei1(nsig), aNode%jac_zicei2(nsig), & + aNode%jac_zicei3(nsig), aNode%jac_zicei4(nsig) ) + + allocate(aNode%kboti1, aNode%kboti2, & + aNode%kboti3, aNode%kboti4 ) + + allocate(aNode%jac_kverti1, aNode%jac_kverti2, & + aNode%jac_kverti3, aNode%jac_kverti4 ) + + allocate(aNode%jac_fratei1, aNode%jac_fratei2, & + aNode%jac_fratei3, aNode%jac_fratei4 ) + + allocate(aNode%jac_wmaxflagi1, aNode%jac_wmaxflagi2, & + aNode%jac_wmaxflagi3, aNode%jac_wmaxflagi4, & + aNode%ij(12,nsig) ) +_EXIT_(myname_) + return +end subroutine obsNode_init_ + +subroutine obsNode_clean_(aNode) + implicit none + class(lightNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_clean_' +_ENTRY_(myname_) +!_TRACEV_(myname_,'%mytype() =',aNode%mytype()) + if(associated(aNode%jac_z0i1 )) deallocate(aNode%jac_z0i1 ) + if(associated(aNode%jac_z0i2 )) deallocate(aNode%jac_z0i2 ) + if(associated(aNode%jac_z0i3 )) deallocate(aNode%jac_z0i3 ) + if(associated(aNode%jac_z0i4 )) deallocate(aNode%jac_z0i4 ) + if(associated(aNode%jac_z0i5 )) deallocate(aNode%jac_z0i5 ) + if(associated(aNode%jac_z0i6 )) deallocate(aNode%jac_z0i6 ) + if(associated(aNode%jac_z0i7 )) deallocate(aNode%jac_z0i7 ) + if(associated(aNode%jac_z0i8 )) deallocate(aNode%jac_z0i8 ) + if(associated(aNode%jac_z0i9 )) deallocate(aNode%jac_z0i9 ) + if(associated(aNode%jac_z0i10)) deallocate(aNode%jac_z0i10) + if(associated(aNode%jac_z0i11)) deallocate(aNode%jac_z0i11) + if(associated(aNode%jac_z0i12)) deallocate(aNode%jac_z0i12) + + if(associated(aNode%jac_vertqi1 )) deallocate(aNode%jac_vertqi1 ) + if(associated(aNode%jac_vertqi2 )) deallocate(aNode%jac_vertqi2 ) + if(associated(aNode%jac_vertqi3 )) deallocate(aNode%jac_vertqi3 ) + if(associated(aNode%jac_vertqi4 )) deallocate(aNode%jac_vertqi4 ) + if(associated(aNode%jac_vertqi5 )) deallocate(aNode%jac_vertqi5 ) + if(associated(aNode%jac_vertqi6 )) deallocate(aNode%jac_vertqi6 ) + if(associated(aNode%jac_vertqi7 )) deallocate(aNode%jac_vertqi7 ) + if(associated(aNode%jac_vertqi8 )) deallocate(aNode%jac_vertqi8 ) + if(associated(aNode%jac_vertqi9 )) deallocate(aNode%jac_vertqi9 ) + if(associated(aNode%jac_vertqi10)) deallocate(aNode%jac_vertqi10) + if(associated(aNode%jac_vertqi11)) deallocate(aNode%jac_vertqi11) + if(associated(aNode%jac_vertqi12)) deallocate(aNode%jac_vertqi12) + + if(associated(aNode%jac_vertti1 )) deallocate(aNode%jac_vertti1 ) + if(associated(aNode%jac_vertti2 )) deallocate(aNode%jac_vertti2 ) + if(associated(aNode%jac_vertti3 )) deallocate(aNode%jac_vertti3 ) + if(associated(aNode%jac_vertti4 )) deallocate(aNode%jac_vertti4 ) + if(associated(aNode%jac_vertti5 )) deallocate(aNode%jac_vertti5 ) + if(associated(aNode%jac_vertti6 )) deallocate(aNode%jac_vertti6 ) + if(associated(aNode%jac_vertti7 )) deallocate(aNode%jac_vertti7 ) + if(associated(aNode%jac_vertti8 )) deallocate(aNode%jac_vertti8 ) + if(associated(aNode%jac_vertti9 )) deallocate(aNode%jac_vertti9 ) + if(associated(aNode%jac_vertti10)) deallocate(aNode%jac_vertti10) + if(associated(aNode%jac_vertti11)) deallocate(aNode%jac_vertti11) + if(associated(aNode%jac_vertti12)) deallocate(aNode%jac_vertti12) + + if(associated(aNode%jac_zdxi1)) deallocate(aNode%jac_zdxi1) + if(associated(aNode%jac_zdxi2)) deallocate(aNode%jac_zdxi2) + if(associated(aNode%jac_zdxi3)) deallocate(aNode%jac_zdxi3) + if(associated(aNode%jac_zdxi4)) deallocate(aNode%jac_zdxi4) + + if(associated(aNode%jac_zdyi1)) deallocate(aNode%jac_zdyi1) + if(associated(aNode%jac_zdyi2)) deallocate(aNode%jac_zdyi2) + if(associated(aNode%jac_zdyi3)) deallocate(aNode%jac_zdyi3) + if(associated(aNode%jac_zdyi4)) deallocate(aNode%jac_zdyi4) + + if(associated(aNode%jac_udxi1)) deallocate(aNode%jac_udxi1) + if(associated(aNode%jac_udxi2)) deallocate(aNode%jac_udxi2) + if(associated(aNode%jac_udxi3)) deallocate(aNode%jac_udxi3) + if(associated(aNode%jac_udxi4)) deallocate(aNode%jac_udxi4) + + if(associated(aNode%jac_vdyi1)) deallocate(aNode%jac_vdyi1) + if(associated(aNode%jac_vdyi2)) deallocate(aNode%jac_vdyi2) + if(associated(aNode%jac_vdyi3)) deallocate(aNode%jac_vdyi3) + if(associated(aNode%jac_vdyi4)) deallocate(aNode%jac_vdyi4) + + if(associated(aNode%jac_vert)) deallocate(aNode%jac_vert) + + if(associated(aNode%jac_sigdoti1)) deallocate(aNode%jac_sigdoti1) + if(associated(aNode%jac_sigdoti2)) deallocate(aNode%jac_sigdoti2) + if(associated(aNode%jac_sigdoti3)) deallocate(aNode%jac_sigdoti3) + if(associated(aNode%jac_sigdoti1)) deallocate(aNode%jac_sigdoti4) + + if(associated(aNode%jac_qi1 )) deallocate(aNode%jac_qi1 ) + if(associated(aNode%jac_qi2 )) deallocate(aNode%jac_qi2 ) + if(associated(aNode%jac_qi3 )) deallocate(aNode%jac_qi3 ) + if(associated(aNode%jac_qi4 )) deallocate(aNode%jac_qi4 ) + + if(associated(aNode%jac_ti1 )) deallocate(aNode%jac_ti1 ) + if(associated(aNode%jac_ti2 )) deallocate(aNode%jac_ti2 ) + if(associated(aNode%jac_ti3 )) deallocate(aNode%jac_ti3 ) + if(associated(aNode%jac_ti4 )) deallocate(aNode%jac_ti4 ) + + if(associated(aNode%jac_qgmai1)) deallocate(aNode%jac_qgmai1) + if(associated(aNode%jac_qgmai2)) deallocate(aNode%jac_qgmai2) + if(associated(aNode%jac_qgmai3)) deallocate(aNode%jac_qgmai3) + if(associated(aNode%jac_qgmai4)) deallocate(aNode%jac_qgmai4) + + if(associated(aNode%jac_qgmbi1)) deallocate(aNode%jac_qgmbi1) + if(associated(aNode%jac_qgmbi2)) deallocate(aNode%jac_qgmbi2) + if(associated(aNode%jac_qgmbi3)) deallocate(aNode%jac_qgmbi3) + if(associated(aNode%jac_qgmbi4)) deallocate(aNode%jac_qgmbi4) + + if(associated(aNode%jac_icei1)) deallocate(aNode%jac_icei1) + if(associated(aNode%jac_icei2)) deallocate(aNode%jac_icei2) + if(associated(aNode%jac_icei3)) deallocate(aNode%jac_icei3) + if(associated(aNode%jac_icei4)) deallocate(aNode%jac_icei4) + + if(associated(aNode%jac_zicei1)) deallocate(aNode%jac_zicei1) + if(associated(aNode%jac_zicei2)) deallocate(aNode%jac_zicei2) + if(associated(aNode%jac_zicei3)) deallocate(aNode%jac_zicei3) + if(associated(aNode%jac_zicei4)) deallocate(aNode%jac_zicei4) + + if(associated(aNode%kboti1)) deallocate(aNode%kboti1) + if(associated(aNode%kboti2)) deallocate(aNode%kboti2) + if(associated(aNode%kboti3)) deallocate(aNode%kboti3) + if(associated(aNode%kboti4)) deallocate(aNode%kboti4) + + if(associated(aNode%jac_kverti1)) deallocate(aNode%jac_kverti1) + if(associated(aNode%jac_kverti2)) deallocate(aNode%jac_kverti2) + if(associated(aNode%jac_kverti3)) deallocate(aNode%jac_kverti3) + if(associated(aNode%jac_kverti4)) deallocate(aNode%jac_kverti4) + + if(associated(aNode%jac_fratei1)) deallocate(aNode%jac_fratei1) + if(associated(aNode%jac_fratei2)) deallocate(aNode%jac_fratei2) + if(associated(aNode%jac_fratei3)) deallocate(aNode%jac_fratei3) + if(associated(aNode%jac_fratei4)) deallocate(aNode%jac_fratei4) + + if(associated(aNode%jac_wmaxflagi1)) deallocate(aNode%jac_wmaxflagi1) + if(associated(aNode%jac_wmaxflagi2)) deallocate(aNode%jac_wmaxflagi2) + if(associated(aNode%jac_wmaxflagi3)) deallocate(aNode%jac_wmaxflagi3) + if(associated(aNode%jac_wmaxflagi4)) deallocate(aNode%jac_wmaxflagi4) + if(associated(aNode%ij )) deallocate(aNode%ij ) +_EXIT_(myname_) + return +end subroutine obsNode_clean_ + +subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) + use m_obsdiagNode, only: obsdiagLookup_locate + implicit none + class(lightNode) , intent(inout):: aNode + integer(i_kind) , intent(in ):: iunit + integer(i_kind) , intent( out):: istat + type(obs_diags) , intent(in ):: diagLookup + logical,optional , intent(in ):: skip + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_xread_' + logical:: skip_ +_ENTRY_(myname_) + skip_=.false. + if(present(skip)) skip_=skip + + istat=0 + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) aNode%res , & + aNode%err2 , & + aNode%raterr2 , & + aNode%b , & + aNode%pg , & + aNode%jac_z0i1 , & + aNode%jac_z0i2 , & + aNode%jac_z0i3 , & + aNode%jac_z0i4 , & + aNode%jac_z0i5 , & + aNode%jac_z0i6 , & + aNode%jac_z0i7 , & + aNode%jac_z0i8 , & + aNode%jac_z0i9 , & + aNode%jac_z0i10 , & + aNode%jac_z0i11 , & + aNode%jac_z0i12 , & + aNode%jac_vertqi1 , & !( nsig) + aNode%jac_vertqi2 , & !( nsig) + aNode%jac_vertqi3 , & !( nsig) + aNode%jac_vertqi4 , & !( nsig) + aNode%jac_vertqi5 , & !( nsig) + aNode%jac_vertqi6 , & !( nsig) + aNode%jac_vertqi7 , & !( nsig) + aNode%jac_vertqi8 , & !( nsig) + aNode%jac_vertqi9 , & !( nsig) + aNode%jac_vertqi10 , & !( nsig) + aNode%jac_vertqi11 , & !( nsig) + aNode%jac_vertqi12 , & !( nsig) + aNode%jac_vertti1 , & !( nsig) + aNode%jac_vertti2 , & !( nsig) + aNode%jac_vertti3 , & !( nsig) + aNode%jac_vertti4 , & !( nsig) + aNode%jac_vertti5 , & !( nsig) + aNode%jac_vertti6 , & !( nsig) + aNode%jac_vertti7 , & !( nsig) + aNode%jac_vertti8 , & !( nsig) + aNode%jac_vertti9 , & !( nsig) + aNode%jac_vertti10 , & !( nsig) + aNode%jac_vertti11 , & !( nsig) + aNode%jac_vertti12 , & !( nsig) + aNode%jac_zdxi1 , & !( nsig) + aNode%jac_zdxi2 , & !( nsig) + aNode%jac_zdxi3 , & !( nsig) + aNode%jac_zdxi4 , & !( nsig) + aNode%jac_zdyi1 , & !( nsig) + aNode%jac_zdyi2 , & !( nsig) + aNode%jac_zdyi3 , & !( nsig) + aNode%jac_zdyi4 , & !( nsig) + aNode%jac_udxi1 , & !( nsig) + aNode%jac_udxi2 , & !( nsig) + aNode%jac_udxi3 , & !( nsig) + aNode%jac_udxi4 , & !( nsig) + aNode%jac_vdyi1 , & !( nsig) + aNode%jac_vdyi2 , & !( nsig) + aNode%jac_vdyi3 , & !( nsig) + aNode%jac_vdyi4 , & !( nsig) + aNode%jac_vert , & !( nsig) + aNode%jac_sigdoti1 , & !( nsig) + aNode%jac_sigdoti2 , & !( nsig) + aNode%jac_sigdoti3 , & !( nsig) + aNode%jac_sigdoti4 , & !( nsig) + aNode%jac_qi1 , & !( nsig) + aNode%jac_qi2 , & !( nsig) + aNode%jac_qi3 , & !( nsig) + aNode%jac_qi4 , & !( nsig) + aNode%jac_ti1 , & !( nsig) + aNode%jac_ti2 , & !( nsig) + aNode%jac_ti3 , & !( nsig) + aNode%jac_ti4 , & !( nsig) + aNode%jac_qgmai1 , & !( nsig) + aNode%jac_qgmai2 , & !( nsig) + aNode%jac_qgmai3 , & !( nsig) + aNode%jac_qgmai4 , & !( nsig) + aNode%jac_qgmbi1 , & !( nsig) + aNode%jac_qgmbi2 , & !( nsig) + aNode%jac_qgmbi3 , & !( nsig) + aNode%jac_qgmbi4 , & !( nsig) + aNode%jac_icei1 , & !( nsig) + aNode%jac_icei2 , & !( nsig) + aNode%jac_icei3 , & !( nsig) + aNode%jac_icei4 , & !( nsig) + aNode%jac_zicei1 , & !( nsig) + aNode%jac_zicei2 , & !( nsig) + aNode%jac_zicei3 , & !( nsig) + aNode%jac_zicei4 , & !( nsig) + aNode%kboti1 , & + aNode%kboti2 , & + aNode%kboti3 , & + aNode%kboti4 , & + aNode%jac_kverti1 , & + aNode%jac_kverti2 , & + aNode%jac_kverti3 , & + aNode%jac_kverti4 , & + aNode%jac_fratei1 , & + aNode%jac_fratei2 , & + aNode%jac_fratei3 , & + aNode%jac_fratei4 , & + aNode%jac_wmaxflagi1, & + aNode%jac_wmaxflagi2, & + aNode%jac_wmaxflagi3, & + aNode%jac_wmaxflagi4, & + aNode%wij , & !(4) + aNode%ij !(12,nsig) + if (istat/=0) then + call perr(myname_,'read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) + if(.not.associated(aNode%diags)) then + call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) + call perr(myname_,' %iob =',aNode%iob) + call die(myname_) + endif + endif +_EXIT_(myname_) + return +end subroutine obsNode_xread_ + +subroutine obsNode_xwrite_(aNode,junit,jstat) + implicit none + class(lightNode),intent(in):: aNode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_xwrite_' +_ENTRY_(myname_) + + jstat=0 + write(junit,iostat=jstat) aNode%res , & + aNode%err2 , & + aNode%raterr2 , & + aNode%b , & + aNode%pg , & + aNode%jac_z0i1 , & + aNode%jac_z0i2 , & + aNode%jac_z0i3 , & + aNode%jac_z0i4 , & + aNode%jac_z0i5 , & + aNode%jac_z0i6 , & + aNode%jac_z0i7 , & + aNode%jac_z0i8 , & + aNode%jac_z0i9 , & + aNode%jac_z0i10 , & + aNode%jac_z0i11 , & + aNode%jac_z0i12 , & + aNode%jac_vertqi1 , & !( nsig) + aNode%jac_vertqi2 , & !( nsig) + aNode%jac_vertqi3 , & !( nsig) + aNode%jac_vertqi4 , & !( nsig) + aNode%jac_vertqi5 , & !( nsig) + aNode%jac_vertqi6 , & !( nsig) + aNode%jac_vertqi7 , & !( nsig) + aNode%jac_vertqi8 , & !( nsig) + aNode%jac_vertqi9 , & !( nsig) + aNode%jac_vertqi10 , & !( nsig) + aNode%jac_vertqi11 , & !( nsig) + aNode%jac_vertqi12 , & !( nsig) + aNode%jac_vertti1 , & !( nsig) + aNode%jac_vertti2 , & !( nsig) + aNode%jac_vertti3 , & !( nsig) + aNode%jac_vertti4 , & !( nsig) + aNode%jac_vertti5 , & !( nsig) + aNode%jac_vertti6 , & !( nsig) + aNode%jac_vertti7 , & !( nsig) + aNode%jac_vertti8 , & !( nsig) + aNode%jac_vertti9 , & !( nsig) + aNode%jac_vertti10 , & !( nsig) + aNode%jac_vertti11 , & !( nsig) + aNode%jac_vertti12 , & !( nsig) + aNode%jac_zdxi1 , & !( nsig) + aNode%jac_zdxi2 , & !( nsig) + aNode%jac_zdxi3 , & !( nsig) + aNode%jac_zdxi4 , & !( nsig) + aNode%jac_zdyi1 , & !( nsig) + aNode%jac_zdyi2 , & !( nsig) + aNode%jac_zdyi3 , & !( nsig) + aNode%jac_zdyi4 , & !( nsig) + aNode%jac_udxi1 , & !( nsig) + aNode%jac_udxi2 , & !( nsig) + aNode%jac_udxi3 , & !( nsig) + aNode%jac_udxi4 , & !( nsig) + aNode%jac_vdyi1 , & !( nsig) + aNode%jac_vdyi2 , & !( nsig) + aNode%jac_vdyi3 , & !( nsig) + aNode%jac_vdyi4 , & !( nsig) + aNode%jac_vert , & !( nsig) + aNode%jac_sigdoti1 , & !( nsig) + aNode%jac_sigdoti2 , & !( nsig) + aNode%jac_sigdoti3 , & !( nsig) + aNode%jac_sigdoti4 , & !( nsig) + aNode%jac_qi1 , & !( nsig) + aNode%jac_qi2 , & !( nsig) + aNode%jac_qi3 , & !( nsig) + aNode%jac_qi4 , & !( nsig) + aNode%jac_ti1 , & !( nsig) + aNode%jac_ti2 , & !( nsig) + aNode%jac_ti3 , & !( nsig) + aNode%jac_ti4 , & !( nsig) + aNode%jac_qgmai1 , & !( nsig) + aNode%jac_qgmai2 , & !( nsig) + aNode%jac_qgmai3 , & !( nsig) + aNode%jac_qgmai4 , & !( nsig) + aNode%jac_qgmbi1 , & !( nsig) + aNode%jac_qgmbi2 , & !( nsig) + aNode%jac_qgmbi3 , & !( nsig) + aNode%jac_qgmbi4 , & !( nsig) + aNode%jac_icei1 , & !( nsig) + aNode%jac_icei2 , & !( nsig) + aNode%jac_icei3 , & !( nsig) + aNode%jac_icei4 , & !( nsig) + aNode%jac_zicei1 , & !( nsig) + aNode%jac_zicei2 , & !( nsig) + aNode%jac_zicei3 , & !( nsig) + aNode%jac_zicei4 , & !( nsig) + aNode%kboti1 , & + aNode%kboti2 , & + aNode%kboti3 , & + aNode%kboti4 , & + aNode%jac_kverti1 , & + aNode%jac_kverti2 , & + aNode%jac_kverti3 , & + aNode%jac_kverti4 , & + aNode%jac_fratei1 , & + aNode%jac_fratei2 , & + aNode%jac_fratei3 , & + aNode%jac_fratei4 , & + aNode%jac_wmaxflagi1, & + aNode%jac_wmaxflagi2, & + aNode%jac_wmaxflagi3, & + aNode%jac_wmaxflagi4, & + aNode%wij , & !(4) + aNode%ij !(12,nsig) + if (jstat/=0) then + call perr(myname_,'write(%(res,err2,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine obsNode_xwrite_ + +subroutine obsNode_setHop_(aNode) + use m_cvgridLookup, only: cvgridLookup_getiw + use gridmod, only: nsig,latlon11 + implicit none + class(lightNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' + integer(i_kind):: k +_ENTRY_(myname_) + + ASSERT(size(aNode%ij,2)==nsig) + ASSERT(nsig>0) + + call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij(:,1),aNode%wij) + do k=2,nsig + aNode%ij(:,k) = aNode%ij(:,1)+(k-1)*latlon11 + enddo +_EXIT_(myname_) + return +end subroutine obsNode_setHop_ + +function obsNode_isvalid_(aNode) result(isvalid_) + implicit none + logical:: isvalid_ + class(lightNode),intent(in):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' +_ENTRY_(myname_) + isvalid_=associated(aNode%diags) +_EXIT_(myname_) +end function obsNode_isvalid_ + +pure subroutine gettlddp_(aNode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(lightNode), intent(in):: aNode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 + return +end subroutine gettlddp_ + +end module m_lightNode diff --git a/src/gsi/m_lwcpNode.F90 b/src/gsi/m_lwcpNode.F90 new file mode 100644 index 000000000..9ef1e1415 --- /dev/null +++ b/src/gsi/m_lwcpNode.F90 @@ -0,0 +1,356 @@ +module m_lwcpNode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_lwcpNode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type lwcpNode (liquid-water content path) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsNode, only: obsNode + implicit none + private + + public:: lwcpNode + + type,extends(obsNode):: lwcpNode + !type(lwcp_ob_type),pointer :: llpoint => NULL() + type(obs_diag), pointer :: diags => NULL() + real(r_kind) :: res ! liquid-water content path residual + real(r_kind) :: err2 ! liquid-water content path error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: wij(4) ! horizontal interpolation weights + real(r_kind),dimension(:),pointer :: jac_t => NULL() + ! t jacobian + real(r_kind),dimension(:),pointer :: jac_p => NULL() + ! p jacobian + real(r_kind),dimension(:),pointer :: jac_q => NULL() + ! q jacobian + real(r_kind),dimension(:),pointer :: jac_ql => NULL() + ! ql jacobian + real(r_kind),dimension(:),pointer :: jac_qr => NULL() + ! qr jacobian +! real(r_kind),dimension(:),pointer :: dp => NULL() +! ! delta pressure at mid layers at obs locations + integer(i_kind),dimension(:,:),pointer :: ij => NULL() + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: setHop => obsNode_setHop_ + procedure:: xread => obsNode_xread_ + procedure:: xwrite => obsNode_xwrite_ + procedure:: isvalid => obsNode_isvalid_ + procedure:: gettlddp => gettlddp_ + + procedure, nopass:: headerRead => obsHeader_read_ + procedure, nopass:: headerWrite => obsHeader_write_ + procedure:: init => obsNode_init_ + procedure:: clean => obsNode_clean_ + end type lwcpNode + + public:: lwcpNode_typecast + public:: lwcpNode_nextcast + interface lwcpNode_typecast; module procedure typecast_ ; end interface + interface lwcpNode_nextcast; module procedure nextcast_ ; end interface + + public:: lwcpNode_appendto + interface lwcpNode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: MYNAME="m_lwcpNode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(lwcpNode) + use m_obsNode, only: obsNode + implicit none + type(lwcpNode),pointer:: ptr_ + class(obsNode),pointer,intent(in):: aNode + ptr_ => null() + if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(aNode) + type is(lwcpNode) + ptr_ => aNode + end select +return +end function typecast_ + +function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(lwcpNode) + use m_obsNode, only: obsNode,obsNode_next + implicit none + type(lwcpNode),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) +return +end function nextcast_ + +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(lwcpNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + +! obsNode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[lwcpNode]" +end function mytype + +subroutine obsHeader_read_(iunit,mobs,jread,istat) + use gridmod, only: nsig + implicit none + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent(out):: mobs + integer(i_kind),intent(out):: jread + integer(i_kind),intent(out):: istat + + character(len=*),parameter:: myname_=myname//".obsHeader_read_" + integer(i_kind):: msig +_ENTRY_(myname_) + + read(iunit,iostat=istat) mobs,jread, msig + if(istat==0 .and. nsig/=msig) then + call perr(myname_,'unexpected dimension information, nsig =',nsig) + call perr(myname_,' but read msig =',msig) + call die(myname_) + endif +_EXIT_(myname_) +return +end subroutine obsHeader_read_ + +subroutine obsHeader_write_(junit,mobs,jwrite,jstat) + use gridmod, only: nsig + implicit none + integer(i_kind),intent(in ):: junit + integer(i_kind),intent(in ):: mobs + integer(i_kind),intent(in ):: jwrite + integer(i_kind),intent(out):: jstat + + character(len=*),parameter:: myname_=myname//".obsHeader_write_" +_ENTRY_(myname_) + write(junit,iostat=jstat) mobs,jwrite, nsig +_EXIT_(myname_) +return +end subroutine obsHeader_write_ + +subroutine obsNode_init_(aNode) + use gridmod, only: nsig + implicit none + class(lwcpNode),intent(out):: aNode + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_init_' +_ENTRY_(myname_) + aNode%llpoint => null() + aNode%luse = .false. + aNode%elat = 0._r_kind + aNode%elon = 0._r_kind + aNode%time = 0._r_kind + aNode%idv =-1 + aNode%iob =-1 + allocate(aNode%jac_t(nsig ), & + aNode%jac_p(nsig+1), & + aNode%jac_q(nsig ), & + aNode%jac_ql(nsig ), & + aNode%jac_qr(nsig ), & + aNode%ij(4, nsig ) ) +! allocate(aNode%dp(nsig)) +_EXIT_(myname_) +return +end subroutine obsNode_init_ + +subroutine obsNode_clean_(aNode) + implicit none + class(lwcpNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_clean_' +_ENTRY_(myname_) +!_TRACEV_(myname_,'%mytype() =',aNode%mytype()) + if(associated(aNode%jac_t )) deallocate(aNode%jac_t ) + if(associated(aNode%jac_p )) deallocate(aNode%jac_p ) + if(associated(aNode%jac_q )) deallocate(aNode%jac_q ) + if(associated(aNode%jac_ql)) deallocate(aNode%jac_ql) + if(associated(aNode%jac_qr)) deallocate(aNode%jac_qr) +! if(associated(aNode%dp )) deallocate(aNode%dp ) + if(associated(aNode%ij )) deallocate(aNode%ij ) +_EXIT_(myname_) +return +end subroutine obsNode_clean_ + +subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) + use m_obsdiagNode, only: obsdiagLookup_locate + implicit none + class(lwcpNode) , intent(inout):: aNode + integer(i_kind) , intent(in ):: iunit + integer(i_kind) , intent( out):: istat + type(obs_diags) , intent(in ):: diagLookup + logical,optional, intent(in ):: skip + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_' + logical:: skip_ +_ENTRY_(myname_) + skip_=.false. + if(present(skip)) skip_=skip + + istat=0 + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) aNode%res , & + aNode%err2 , & + aNode%raterr2, & + aNode%b , & + aNode%pg , & + aNode%wij , & + aNode%jac_t , & + aNode%jac_p , & + aNode%jac_q , & + aNode%jac_ql , & + aNode%jac_qr , & + aNode%ij +! aNode%dp + if (istat/=0) then + call perr(myname_,'read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) + if(.not.associated(aNode%diags)) then + call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) + call perr(myname_,' %iob =',aNode%iob) + call die(myname_) + endif + endif +_EXIT_(myname_) +return +end subroutine obsNode_xread_ + +subroutine obsNode_xwrite_(aNode,junit,jstat) + implicit none + class(lwcpNode),intent(in):: aNode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_' +_ENTRY_(myname_) + + jstat=0 + write(junit,iostat=jstat) aNode%res , & + aNode%err2 , & + aNode%raterr2, & + aNode%b , & + aNode%pg , & + aNode%wij , & + aNode%jac_t , & + aNode%jac_p , & + aNode%jac_q , & + aNode%jac_ql , & + aNode%jac_qr , & + aNode%ij +! aNode%dp + if (jstat/=0) then + call perr(myname_,'write(%(res,err2,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) +return +end subroutine obsNode_xwrite_ + +subroutine obsNode_setHop_(aNode) + use m_cvgridLookup, only: cvgridLookup_getiw + use gridmod, only: nsig,latlon11 + implicit none + class(lwcpNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' + integer(i_kind):: k +_ENTRY_(myname_) + + ASSERT(size(aNode%ij,2)==nsig) + ASSERT(nsig>0) + + call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij(:,1),aNode%wij) + do k=2,nsig + aNode%ij(:,k) = aNode%ij(:,1)+(k-1)*latlon11 + enddo +_EXIT_(myname_) +return +end subroutine obsNode_setHop_ + +function obsNode_isvalid_(aNode) result(isvalid_) + implicit none + logical:: isvalid_ + class(lwcpNode),intent(in):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' +_ENTRY_(myname_) + isvalid_=associated(aNode%diags) +_EXIT_(myname_) +return +end function obsNode_isvalid_ + +pure subroutine gettlddp_(aNode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(lwcpNode), intent(in):: aNode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 +return +end subroutine gettlddp_ + +end module m_lwcpNode diff --git a/src/m_mitmNode.F90 b/src/gsi/m_mitmNode.F90 similarity index 89% rename from src/m_mitmNode.F90 rename to src/gsi/m_mitmNode.F90 index c9f64e5fd..3f0706371 100644 --- a/src/m_mitmNode.F90 +++ b/src/gsi/m_mitmNode.F90 @@ -24,8 +24,8 @@ module m_mitmNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,39 +71,57 @@ module m_mitmNode interface mitmNode_typecast; module procedure typecast_ ; end interface interface mitmNode_nextcast; module procedure nextcast_ ; end interface + public:: mitmNode_appendto + interface mitmNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_mitmNode" #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(mitmNode) use m_obsNode, only: obsNode implicit none type(mitmNode),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(mitmNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(mitmNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(mitmNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(mitmNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_mxtmNode.F90 b/src/gsi/m_mxtmNode.F90 similarity index 89% rename from src/m_mxtmNode.F90 rename to src/gsi/m_mxtmNode.F90 index 1b29d5f89..b6caec26b 100644 --- a/src/m_mxtmNode.F90 +++ b/src/gsi/m_mxtmNode.F90 @@ -24,8 +24,8 @@ module m_mxtmNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,39 +71,57 @@ module m_mxtmNode interface mxtmNode_typecast; module procedure typecast_ ; end interface interface mxtmNode_nextcast; module procedure nextcast_ ; end interface + public:: mxtmNode_appendto + interface mxtmNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_mxtmNode" #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(mxtmNode) use m_obsNode, only: obsNode implicit none type(mxtmNode),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(mxtmNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(mxtmNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(mxtmNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(mxtmNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_o3lNode.F90 b/src/gsi/m_o3lNode.F90 similarity index 89% rename from src/m_o3lNode.F90 rename to src/gsi/m_o3lNode.F90 index 5218461ff..aa98994cf 100644 --- a/src/m_o3lNode.F90 +++ b/src/gsi/m_o3lNode.F90 @@ -23,8 +23,8 @@ module m_o3lNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -70,6 +70,9 @@ module m_o3lNode interface o3lNode_typecast; module procedure typecast_ ; end interface interface o3lNode_nextcast; module procedure nextcast_ ; end interface + public:: o3lNode_appendto + interface o3lNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_o3lNode" #include "myassert.H" @@ -79,16 +82,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(o3lNode) use m_obsNode, only: obsNode implicit none - type(o3lNode),pointer:: ptr_ + type(o3lNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(o3lNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -97,15 +98,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(o3lNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(o3lNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(o3lNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(o3lNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_obsLList.F90 b/src/gsi/m_obsLList.F90 similarity index 92% rename from src/m_obsLList.F90 rename to src/gsi/m_obsLList.F90 index 44d8939af..74b9baa2c 100644 --- a/src/m_obsLList.F90 +++ b/src/gsi/m_obsLList.F90 @@ -15,6 +15,8 @@ module m_obsLList ! latlonRange from (elat,elon) values of observations. ! 2016-07-25 j.guo - added getTLDdotprod, to accumulate obsNode TLD-dot_produst ! 2016-09-19 j.guo - added function lincr_() to extend []_lsize(). +! 2017-08-26 G.Ge - change allocate(headLL%mold,mold=mold) +! to allocate(headLL%mold,source=mold) ! ! input argument list: see Fortran 90 style document below ! @@ -40,7 +42,7 @@ module m_obsLList integer(i_kind):: n_alloc =0 integer(i_kind):: my_obsType =0 - class(obsNode),allocatable:: mold ! a mold for the nodes + class(obsNode),pointer:: mold => null() ! a mold for the nodes class(obsNode),pointer:: head => null() ! class(obsNode),pointer:: tail => null() @@ -124,7 +126,7 @@ function lmold_(headLL) result(ptr_) class(obsNode),pointer:: ptr_ type(obsLList),target,intent(in):: headLL ptr_ => null() - if(allocated(headLL%mold)) ptr_ => headLL%mold + if(associated(headLL%mold)) ptr_ => headLL%mold end function lmold_ !--------------------------- will go to m_obsLList ---------------------- @@ -203,67 +205,55 @@ subroutine lreset_(headLL,mold,stat) ! !$$$ end documentation block use m_obsNode, only: obsNode_next + use m_obsNode, only: obsNode_clean + use m_obsNode, only: obsNode_type => obsNode_mytype implicit none type(obsLList), intent(inout):: headLL - class(obsNode), intent(in):: mold + class(obsNode), intent(in ):: mold integer(i_kind),optional,intent(out):: stat character(len=*),parameter:: myname_=MYNAME//"::lreset_" - class(obsNode),pointer:: l_obsNode - class(obsNode),pointer:: n_obsNode - character(len=:),allocatable:: mytype_ + character(len=:),allocatable:: mymold_ integer(i_kind):: n integer(i_kind):: ier _ENTRY_(myname_) - !call tell(myname_,' mold%mytype() =',mold%mytype()) - !if(allocated(headLL%mold)) then - ! call tell(myname_,'obsLList%mold%mytype() =',headLL%mold%mytype()) - ! call tell(myname_,' obsLList%n_alloc =',headLL%n_alloc) - !endif if(present(stat)) stat=0 - n=0 - - l_obsNode => lheadNode_(headLL) - do while(associated(l_obsNode)) - ! Steps of forward resetting (not a recursive resetting), - ! (1) hold the %next node; - ! (2) clean then deallocate the current node, while leave the %next node untouched; - ! (3) switch the current node to the held %next node. - n=n+1 - n_obsNode => obsNode_next(l_obsNode) - mytype_=l_obsNode%mytype() - call nodeDestroy_(l_obsNode,stat=ier) - if(ier/=0) then - call perr(myname_,'call nodeDestroy_(), stat =',ier) - call perr(myname_,' count =',n) - call perr(myname_,' l_obsNode%mytype() =',mytype_) - call perr(myname_,' headLL%mold%mytype() =',headLL%mold%mytype()) + + call obsNode_clean(headLL%head,deep=.true.,depth=n,stat=ier) + if(ier/=0.or.n/=0) then + call perr(myname_,'obsNode_clean(.deep.), stat =',ier) + call perr(myname_,' depth =',n) + call perr(myname_,' lsize(headLL) =',lsize_(headLL)) + call perr(myname_,' headLL%head%mytype() =',obsNode_type(headLL%head)) + call perr(myname_,' headLL%mold%mytype() =',obsNode_type(headLL%mold)) if(.not.present(stat)) call die(myname_) stat=ier _EXIT_(myname_) return endif - l_obsNode => n_obsNode - enddo + + call nodeDestroy_(headLL%head) headLL%n_alloc = 0 headLL%l_alloc = 0 headLL%head => null() headLL%tail => null() - if(allocated(headLL%mold)) then - mytype_=headLL%mold%mytype() + + if(associated(headLL%mold)) then + mymold_ = obsNode_type(headLL%mold) deallocate(headLL%mold,stat=ier) if(ier/=0) then call perr(myname_,'deallocate(headLL%mold), stat =',ier) - call perr(myname_,' headLL%mold%mytype() =',mytype_) + call perr(myname_,' obsNode_type(headLL%mold) =',mymold_) if(.not.present(stat)) call die(myname_) stat=ier _EXIT_(myname_) return endif endif - allocate(headLL%mold,mold=mold) + + allocate(headLL%mold, mold=mold) _EXIT_(myname_) return end subroutine lreset_ @@ -293,10 +283,12 @@ subroutine lappendNode_(headLL,targetNode) use m_obsNode, only: obsNode_append implicit none type(obsLList), intent(inout):: headLL - class(obsNode), target, intent(in):: targetNode + !class(obsNode), target, intent(in):: targetNode + class(obsNode), pointer, intent(in):: targetNode character(len=*),parameter:: myname_=MYNAME//'::lappendNode_' !_ENTRY_(myname_) + ASSERT(associated(targetNode)) if(.not.associated(headLL%head)) then ! this is a fresh starting -node- for this linked-list ... @@ -342,7 +334,8 @@ subroutine lread_(headLL,iunit,redistr,diagLookup,jtype) ! !$$$ end documentation block - use obsmod, only: obs_diags + !use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diags use m_obsNode, only: obsNode_read use m_obsNode, only: obsNode_setluse implicit none @@ -363,7 +356,7 @@ subroutine lread_(headLL,iunit,redistr,diagLookup,jtype) ! a collection of nodes of the same _obsNode_ type, ! !-- not about the corresponding linked-list. - ASSERT(allocated(headLL%mold)) + ASSERT(associated(headLL%mold)) call obsHeader_read_(headLL%mold,iunit,mobs,jread,istat) @@ -425,6 +418,7 @@ subroutine lread_(headLL,iunit,redistr,diagLookup,jtype) enddo ! < mobs > call nodeDestroy_(aNode) ! Clean up the working-space an_onsNode + _EXIT_(myname_) return end subroutine lread_ @@ -484,7 +478,7 @@ subroutine lwrite_(headLL,iunit,luseonly,jtype,luseRange) ! !-- A header is about a collection of nodes of the same obsNode type, ! !-- not about the corresponding linked-list. - ASSERT(allocated(headLL%mold)) + ASSERT(associated(headLL%mold)) lobs = lcount_(headLL,luseonly=luseonly) ! actual count of write mobs = lobs @@ -893,28 +887,20 @@ function alloc_nodeCreate_(mold) result(ptr_) return end function alloc_nodeCreate_ -subroutine nodeDestroy_(node,stat) +subroutine nodeDestroy_(node) !-- clean() + deallocate() + use m_obsNode, only: obsNode_type => obsNode_mytype implicit none class(obsNode),pointer,intent(inout):: node - integer(i_kind),optional,intent(out):: stat - - character(len=*),parameter:: myname_=myname//"::nodeDestroy_" + character(len=*),parameter:: myname_=myname//'::nodeDestroy_' integer(i_kind):: ier - character(len=:),allocatable:: mytype_ - if(present(stat)) stat=0 - !call tell( myname_,'associated(node) =',associated(node)) if(associated(node)) then - !call tell(myname_,' node%mytype() =',node%mytype()) - mytype_=node%mytype() call node%clean() - !call tell(myname_,'associated(node) =',associated(node)) deallocate(node,stat=ier) if(ier/=0) then call perr(myname_,'can not deallocate(node), stat =',ier) - call perr(myname_,' %mytype() =',mytype_) - if(.not.present(stat)) call die(myname_) - stat=ier + call perr(myname_,' obsNode_type(node) =',obsNode_type(node)) + call die(myname_) endif endif return @@ -928,7 +914,7 @@ subroutine obsHeader_read_(aNode,iunit,iobs,itype,istat) integer(i_kind),intent(in ):: iunit integer(i_kind),intent(out):: iobs,itype integer(i_kind),intent(out):: istat - call aNode%header_read(iunit,iobs,itype,istat) + call aNode%headerRead(iunit,iobs,itype,istat) end subroutine obsHeader_read_ subroutine obsHeader_write_(aNode,junit,mobs,mtype,istat) @@ -939,6 +925,6 @@ subroutine obsHeader_write_(aNode,junit,mobs,mtype,istat) integer(i_kind),intent(in ):: junit integer(i_kind),intent(in ):: mobs,mtype integer(i_kind),intent(out):: istat - call aNode%header_write(junit,mobs,mtype,istat) + call aNode%headerWrite(junit,mobs,mtype,istat) end subroutine obsHeader_write_ end module m_obsLList diff --git a/src/m_obsNode.F90 b/src/gsi/m_obsNode.F90 similarity index 77% rename from src/m_obsNode.F90 rename to src/gsi/m_obsNode.F90 index adcdc449b..42a7dc8f7 100644 --- a/src/m_obsNode.F90 +++ b/src/gsi/m_obsNode.F90 @@ -27,6 +27,8 @@ module m_obsNode use kinds, only: i_kind,r_kind use mpeu_util, only: tell,perr,die use mpeu_util, only: assert_ + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags implicit none private ! except public:: obsNode ! data structure @@ -47,17 +49,20 @@ module m_obsNode real(r_kind) :: elat = 0._r_kind ! earth lat-lon for redistribution real(r_kind) :: elon = 0._r_kind ! earth lat-lon for redistribution -! real(r_kind) :: dlat = 0._r_kind ! for verification, only temorary -! real(r_kind) :: dlon = 0._r_kind ! for verification, only temorary - integer(i_kind) :: idv =-1 ! device ID integer(i_kind) :: iob =-1 ! initial obs sequential ID +#ifdef _TO_DO_ + integer(i_kind):: nprof ! count of corresponding profile locations + integer(i_kind):: idspl ! cross referencing index to profile locations + ! given i-th observation, corresponding profile + ! is block ([]%idspl+1 : []%idspl+[]%nprof) +#endif contains !----------- overrideable procedures ----------------------------------- - procedure, nopass:: header_read => obsHeader_read_ ! read a header - procedure, nopass:: header_write => obsHeader_write_ ! write a header + procedure, nopass:: headerRead => obsHeader_read_ ! read a header + procedure, nopass:: headerWrite => obsHeader_write_ ! write a header procedure:: init => init_ ! initialize a node procedure:: clean => clean_ ! clean a node @@ -75,6 +80,9 @@ module m_obsNode !-- module procedures, such as base-specific operations + public:: obsNode_clean + interface obsNode_clean; module procedure deepclean_; end interface + ! Nodes operations public:: obsNode_next ! nextNode => obsNode_next (thisNode) public:: obsNode_append ! call obsNode_append(thisNode,targetNode) @@ -100,13 +108,16 @@ module m_obsNode interface obsNode_read ; module procedure read_ ; end interface interface obsNode_write ; module procedure write_ ; end interface - public:: obsNode_show ! call obsNode_init(aNode) + public:: obsNode_show ! call obsNode_show(aNode) interface obsNode_show ; module procedure show_ ; end interface + public:: obsNode_mytype ! call obsNode_type(aNode) + interface obsNode_mytype ; module procedure nodetype_ ; end interface + abstract interface subroutine intrfc_xread_(aNode,iunit,istat,diagLookup,skip) use kinds,only: i_kind - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diags import:: obsNode implicit none class(obsNode), intent(inout):: aNode @@ -173,26 +184,33 @@ end subroutine intrfc_gettlddp_ #include "myassert.H" contains - function next_(aNode) result(here_) !-- associate to thisNode%llpoint. implicit none class(obsNode),pointer:: here_ class(obsNode),target,intent(in):: aNode + + character(len=*),parameter :: myname_=myname//'::next_' +_ENTRY_(myname_) + !!! trying to go next on a null reference is a serious logical error. here_ => aNode%llpoint +_EXIT_(myname_) +return end function next_ subroutine append_(thisNode,targetNode,follow) !-- append targetNode to thisNode%llpoint, or thisNode if .not.associated(thisNode) implicit none class(obsNode),pointer ,intent(inout):: thisNode - class(obsNode),target ,intent(in ):: targetNode + class(obsNode),pointer ,intent(in ):: targetNode logical ,optional,intent(in):: follow ! Follow targetNode%llpoint to its last node. ! The default is to nullify(thisNode%llpoint) character(len=*),parameter:: myname_=myname//"::append_" logical:: follow_ _ENTRY_(myname_) + ASSERT(associated(targetNode)) ! verify for any exception. + follow_=.false. if(present(follow)) follow_=follow @@ -435,7 +453,7 @@ subroutine clean_(aNode) ! subprogram: clean_ ! prgmmr: J. Guo ! -! abstract: clean a node +! abstract: a shallow node clean ! ! program history log: ! 2015-01-12 guo - constructed for generic obsNode @@ -455,11 +473,125 @@ subroutine clean_(aNode) character(len=*),parameter:: myname_=MYNAME//'::clean_' _ENTRY_(myname_) !_TRACEV_(myname_,'%mytype() =',aNode%mytype()) - call init_(aNode) + call anode%init() _EXIT_(myname_) return end subroutine clean_ +subroutine deepclean_(aNode,deep,depth,stat) +!$$$ subprogram documentation block +! . . . . +! subprogram: subroutine deepclean_ +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-04-11 +! +! abstract: a deep node clean +! +! program history log: +! 2018-04-11 j guo - added this document block +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + + implicit none + class(obsNode ),pointer ,intent(inout):: aNode + logical ,optional,intent(in ):: deep ! with deep=.true., the full + ! linked-list headed by aNode + ! will be "deep" cleaned. + integer(i_kind),optional,intent(out):: depth ! depth of deep-cleaned nodes at + ! the return. zero is expected + ! unless in an error. + integer(i_kind),optional,intent(out):: stat ! status return. + + character(len=*),parameter:: myname_=MYNAME//'::deepclean_' + integer(i_kind):: ier,depth_ + logical:: deep_ + + if(present(depth)) depth=0 + if(present(stat )) stat=0 + + if(.not.associated(aNode)) return + + deep_=.false. + if(present(deep )) deep_=deep + + if(deep_) then + depth_=0 + call recurs_nodeclean_(aNode,depth_,ier) + if(present(depth)) depth=depth_ + + if(ier/=0) then + call perr(myname_,'recurs_nodeclean_(), stat =',ier) + call perr(myname_,' depth =',depth_) + call perr(myname_,' aNode%mytype() =',nodetype_(aNode)) + if(.not.present(stat)) call die(myname_) + stat=ier + return + endif + + else + ! Full-clean aNode itself, but not %llpoint. This includes any dynamic + ! component of aNode defined in its type/endtype block. + call aNode%clean() + endif + +return +end subroutine deepclean_ + +recursive subroutine recurs_nodeclean_(aNode,depth,stat) + implicit none + class(obsNode),pointer,intent(inout):: aNode + ! This routine intends to fully erase the contents of argument aNode, + ! but not the storage of it. A target attribute is used to prevent any + ! attempt to deallocate. Also see step (2) and (4) below. + integer(i_kind),intent(inout):: depth + integer(i_kind),intent( out):: stat + + character(len=*),parameter:: myname_=MYNAME//"::recurs_nodeclean_" + + stat=0 + if(associated(aNode)) then + + if(associated(aNode%llpoint)) then + depth=depth+1 + + ! (1) deep-clean the target of %llpoint, a level deeper than aNode. + + call recurs_nodeclean_(aNode%llpoint,depth,stat) + if(stat/=0) return + + ! (2) deallocate %llpoint to release the memory associated with it. This is + ! in concert with step (4) below. + + deallocate(aNode%llpoint,stat=stat) + if(stat/=0) then + call perr(myname_,"deallocate(aNode%llpoint), stat =",stat) + call perr(myname_,' depth =',depth) + return + endif + + depth=depth-1 + endif + + ! (3) full-clean aNode itself other than %llpoint, including any its dynamic + ! component defined in its type/endtype block. + + call aNode%clean() + + ! (4) memory storage of aNode itself is NOT expected to be deallocated. + ! This is in concert with step (2) above. + endif +return +end subroutine recurs_nodeclean_ + subroutine read_(aNode,iunit,istat,redistr,diagLookup) !$$$ subprogram documentation block ! . . . . @@ -481,8 +613,8 @@ subroutine read_(aNode,iunit,istat,redistr,diagLookup) ! !$$$ end documentation block use m_obsdiagNode, only: obsdiagLookup_locate - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags implicit none class(obsNode),intent(inout):: aNode integer(i_kind),intent(in ):: iunit @@ -557,7 +689,6 @@ subroutine write_(aNode,junit,jstat) jstat=0 write(junit,iostat=jstat) aNode%luse,aNode%time,aNode%elat,aNode%elon, & - !aNode%dlat,aNode%dlon, & aNode%idv,aNode%iob if(jstat/=0) then call perr(myname_,'write(%(luse,elat,elon,...)), jstat =',jstat) @@ -610,4 +741,13 @@ subroutine show_(aNode,iob) return end subroutine show_ +function nodetype_(aNode) +!-- Return its type information, even when the argument is a NULL. + implicit none + character(len=:),allocatable:: nodetype_ + class(obsNode),pointer,intent(in):: aNode + nodetype_=".null.[obsNode]" + if(associated(aNode)) nodetype_=aNode%mytype() +end function nodetype_ + end module m_obsNode diff --git a/src/gsi/m_obsNodeTypeManager.F90 b/src/gsi/m_obsNodeTypeManager.F90 new file mode 100644 index 000000000..b5ecc6e1b --- /dev/null +++ b/src/gsi/m_obsNodeTypeManager.F90 @@ -0,0 +1,453 @@ +module m_obsNodeTypeManager +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_obsNodeTypeManager +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2015-08-13 +! +! abstract: obsNode type manager, as an enumerated type molder. +! +! program history log: +! 2015-08-13 j guo - added this document block. +! 2016-05-18 j guo - finished its initial polymorphic implementation, +! with total 33 obs-types. +! 2018-01-23 k apodaca - add a new observation type i.e. lightning (light) +! suitable for the GOES/GLM instrument +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use m_psNode , only: psNode + use m_tNode , only: tNode + use m_wNode , only: wNode + use m_qNode , only: qNode + use m_spdNode , only: spdNode + use m_rwNode , only: rwNode + use m_dwNode , only: dwNode + use m_sstNode , only: sstNode + use m_pwNode , only: pwNode + use m_pcpNode , only: pcpNode + use m_ozNode , only: ozNode + use m_o3lNode , only: o3lNode + use m_gpsNode , only: gpsNode + use m_radNode , only: radNode + use m_tcpNode , only: tcpNode + use m_lagNode , only: lagNode + use m_colvkNode, only: colvkNode + use m_aeroNode , only: aeroNode + use m_aerolNode, only: aerolNode + use m_pm2_5Node, only: pm2_5Node + use m_gustNode , only: gustNode + use m_visNode , only: visNode + use m_pblhNode , only: pblhNode + + use m_wspd10mNode, only: wspd10mNode + use m_uwnd10mNode, only: uwnd10mNode + use m_vwnd10mNode, only: vwnd10mNode + + use m_td2mNode , only: td2mNode + use m_mxtmNode , only: mxtmNode + use m_mitmNode , only: mitmNode + use m_pmslNode , only: pmslNode + use m_howvNode , only: howvNode + use m_tcamtNode, only: tcamtNode + use m_lcbasNode, only: lcbasNode + use m_pm10Node , only: pm10Node + use m_cldchNode, only: cldchNode + + use m_swcpNode , only: swcpNode + use m_lwcpNode , only: lwcpNode + + use m_lightNode, only: lightNode + use m_dbzNode , only: dbzNode + + use kinds, only: i_kind + use m_obsNode, only: obsNode + use mpeu_util, only: perr,die + + implicit none + private ! except + + public:: obsNodeType_undef + public:: obsNodeType_lbound + public:: obsNodeType_ubound + public:: obsNodeType_count + + public:: iobsNode_kind + public:: iobsNode_ps + public:: iobsNode_t + public:: iobsNode_w + public:: iobsNode_q + public:: iobsNode_spd + public:: iobsNode_rw + public:: iobsNode_dw + public:: iobsNode_sst + public:: iobsNode_pw + public:: iobsNode_pcp + public:: iobsNode_oz + public:: iobsNode_o3l + public:: iobsNode_gps + public:: iobsNode_rad + public:: iobsNode_tcp + public:: iobsNode_lag + public:: iobsNode_colvk + public:: iobsNode_aero + public:: iobsNode_aerol + public:: iobsNode_pm2_5 + public:: iobsNode_gust + public:: iobsNode_vis + public:: iobsNode_pblh + public:: iobsNode_wspd10m + public:: iobsNode_uwnd10m + public:: iobsNode_vwnd10m + public:: iobsNode_td2m + public:: iobsNode_mxtm + public:: iobsNode_mitm + public:: iobsNode_pmsl + public:: iobsNode_howv + public:: iobsNode_tcamt + public:: iobsNode_lcbas + public:: iobsNode_pm10 + public:: iobsNode_cldch + public:: iobsNode_swcp + public:: iobsNode_lwcp + + public:: iobsNode_light + public:: iobsNode_dbz + + public :: obsNode_typeMold + public :: obsNode_typeIndex + + interface obsNode_typeMold; module procedure & + index2vmold_, & + vname2vmold_ + end interface + interface obsNode_typeIndex; module procedure & + vmold2index_, & + vname2index_ + end interface + + type(psNode ), target, save:: ps_mold + type(tNode ), target, save:: t_mold + type(wNode ), target, save:: w_mold + type(qNode ), target, save:: q_mold + type(spdNode ), target, save:: spd_mold + type(rwNode ), target, save:: rw_mold + type(dwNode ), target, save:: dw_mold + type(sstNode ), target, save:: sst_mold + type(pwNode ), target, save:: pw_mold + type(pcpNode ), target, save:: pcp_mold + type(ozNode ), target, save:: oz_mold + type(o3lNode ), target, save:: o3l_mold + type(gpsNode ), target, save:: gps_mold + type(radNode ), target, save:: rad_mold + type(tcpNode ), target, save:: tcp_mold + type(lagNode ), target, save:: lag_mold + type(colvkNode), target, save:: colvk_mold + type(aeroNode ), target, save:: aero_mold + type(aerolNode), target, save:: aerol_mold + type(pm2_5Node), target, save:: pm2_5_mold + type(gustNode ), target, save:: gust_mold + type(visNode ), target, save:: vis_mold + type(pblhNode ), target, save:: pblh_mold + + type(wspd10mNode), target, save:: wspd10m_mold + type(uwnd10mNode), target, save:: uwnd10m_mold + type(vwnd10mNode), target, save:: vwnd10m_mold + + type( td2mNode), target, save:: td2m_mold + type( mxtmNode), target, save:: mxtm_mold + type( mitmNode), target, save:: mitm_mold + type( pmslNode), target, save:: pmsl_mold + type( howvNode), target, save:: howv_mold + type( tcamtNode), target, save:: tcamt_mold + type( lcbasNode), target, save:: lcbas_mold + type( pm10Node), target, save:: pm10_mold + type( cldchNode), target, save:: cldch_mold + + type( swcpNode), target, save:: swcp_mold + type( lwcpNode), target, save:: lwcp_mold + type( lightNode), target, save:: light_mold + type( dbzNode), target, save:: dbz_mold +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='m_obsNodeTypeManager' + +! UseCase 1: configuration of a single mold +! +! use m_obsNodeTypeManager, only: obsNode_typeMold +! use m_psNode, only: i_psNode +! ... +! allocate(psLList%mold, source=obsNode_typeMold(i_psNode)) +! or, for Fortran 2008 ALLOCATE() with MOLD= specifier +! allocate(psLList%mold, mold=obsNode_typeMold(i_psNode)) +! +! UseCase 2: configuration of molds in an array +! +! use m_obsLList, only: obsLList_moldConfig +! use m_obsNodeTypeManager, only: obsNode_typeMold +! ... +! do jtype=lbound(obsdiags,2),ubound(obsdiags,2) +! do ibin=lbound(obsdiags,1),ubound(obsdiags,1) +! call obsLList_moldConfig(obsdiags(ibin,jtype),mold=obsNode_typeMold(jtype)) +! enddo +! enddo +! + + enum, bind(C) + enumerator:: iobsNode_zero_ = 0 + + enumerator:: iobsNode_ps + enumerator:: iobsNode_t + enumerator:: iobsNode_w + enumerator:: iobsNode_q + enumerator:: iobsNode_spd + enumerator:: iobsNode_rw + enumerator:: iobsNode_dw + enumerator:: iobsNode_sst + enumerator:: iobsNode_pw + enumerator:: iobsNode_pcp + enumerator:: iobsNode_oz + enumerator:: iobsNode_o3l + enumerator:: iobsNode_gps + enumerator:: iobsNode_rad + enumerator:: iobsNode_tcp + enumerator:: iobsNode_lag + enumerator:: iobsNode_colvk + enumerator:: iobsNode_aero + enumerator:: iobsNode_aerol + enumerator:: iobsNode_pm2_5 + enumerator:: iobsNode_gust + enumerator:: iobsNode_vis + enumerator:: iobsNode_pblh + enumerator:: iobsNode_wspd10m + enumerator:: iobsNode_uwnd10m + enumerator:: iobsNode_vwnd10m + enumerator:: iobsNode_td2m + enumerator:: iobsNode_mxtm + enumerator:: iobsNode_mitm + enumerator:: iobsNode_pmsl + enumerator:: iobsNode_howv + enumerator:: iobsNode_tcamt + enumerator:: iobsNode_lcbas + enumerator:: iobsNode_pm10 + enumerator:: iobsNode_cldch + enumerator:: iobsNode_swcp + enumerator:: iobsNode_lwcp + enumerator:: iobsNode_light + enumerator:: iobsNode_dbz + + enumerator:: iobsNode_extra_ + end enum + + integer(i_kind),parameter:: iobsNode_kind = kind(iobsNode_zero_) + + integer(iobsNode_kind),parameter:: obsNodeType_undef = -1_iobsNode_kind + integer(iobsNode_kind),parameter:: obsNodeType_lbound = iobsNode_zero_ +1 + integer(iobsNode_kind),parameter:: obsNodeType_ubound = iobsNode_extra_-1 + integer(iobsNode_kind),parameter:: obsNodeType_count = obsNodeType_ubound-obsNodeType_lbound+1 + +contains +function vname2index_(vname) result(index_) + use mpeu_util, only: lowercase + implicit none + integer(i_kind):: index_ + character(len=*),intent(in):: vname + character(len=len(vname)):: vname_ + vname_=lowercase(vname) + + index_=0 ! a default return value, if the given name is unknown. + select case(vname_) + case("ps" , "[psnode]"); index_ = iobsNode_ps + case("t" , "[tnode]"); index_ = iobsNode_t + case("w" , "[wnode]"); index_ = iobsNode_w + case("q" , "[qnode]"); index_ = iobsNode_q + case("spd" , "[spdnode]"); index_ = iobsNode_spd + case("rw" , "[rwnode]"); index_ = iobsNode_rw + case("dw" , "[dwnode]"); index_ = iobsNode_dw + case("sst" , "[sstnode]"); index_ = iobsNode_sst + case("pw" , "[pwnode]"); index_ = iobsNode_pw + case("pcp" , "[pcpnode]"); index_ = iobsNode_pcp + case("oz" , "[oznode]"); index_ = iobsNode_oz + case("o3l" , "[o3lnode]"); index_ = iobsNode_o3l + case("gps" , "[gpsnode]"); index_ = iobsNode_gps + case("rad" , "[radnode]"); index_ = iobsNode_rad + case("tcp" , "[tcpnode]"); index_ = iobsNode_tcp + case("lag" , "[lagnode]"); index_ = iobsNode_lag + case("colvk","[colvknode]"); index_ = iobsNode_colvk + case("aero" , "[aeronode]"); index_ = iobsNode_aero + case("aerol","[aerolnode]"); index_ = iobsNode_aerol + case("pm2_5","[pm2_5node]"); index_ = iobsNode_pm2_5 + case("gust" , "[gustnode]"); index_ = iobsNode_gust + case("vis" , "[visnode]"); index_ = iobsNode_vis + case("pblh" , "[pblhnode]"); index_ = iobsNode_pblh + + case("wspd10m", & + "[wspd10mnode]"); index_ = iobsNode_wspd10m + case("uwnd10m", & + "[uwnd10mnode]"); index_ = iobsNode_uwnd10m + case("vwnd10m", & + "[vwnd10mnode]"); index_ = iobsNode_vwnd10m + + case("td2m" , "[td2mnode]"); index_ = iobsNode_td2m + case("mxtm" , "[mxtmnode]"); index_ = iobsNode_mxtm + case("mitm" , "[mitmnode]"); index_ = iobsNode_mitm + case("pmsl" , "[pmslnode]"); index_ = iobsNode_pmsl + case("howv" , "[howvnode]"); index_ = iobsNode_howv + case("tcamt","[tcamtnode]"); index_ = iobsNode_tcamt + case("lcbas","[lcbasnode]"); index_ = iobsNode_lcbas + + case("pm10" , "[pm10node]"); index_ = iobsNode_pm10 + case("cldch","[cldchnode]"); index_ = iobsNode_cldch + + case("swcp" , "[swcpnode]"); index_ = iobsNode_swcp + case("lwcp" , "[lwcpnode]"); index_ = iobsNode_lwcp + + case("light","[lightnode]"); index_ = iobsNode_light + case("dbz" , "[dbznode]"); index_ = iobsNode_dbz + + end select +end function vname2index_ + +function vmold2index_(mold) result(index_) + implicit none + integer(i_kind):: index_ + class(obsNode),target,intent(in):: mold + + index_=vname2index_(mold%mytype()) +end function vmold2index_ + +function vmold2index_select_(mold) result(index_) + implicit none + integer(i_kind):: index_ + class(obsNode),target,intent(in):: mold + + index_=0 + select type(mold) + type is( psNode); index_ = iobsNode_ps + type is( tNode); index_ = iobsNode_t + type is( wNode); index_ = iobsNode_w + type is( qNode); index_ = iobsNode_q + type is( spdNode); index_ = iobsNode_spd + type is( rwNode); index_ = iobsNode_rw + type is( dwNode); index_ = iobsNode_dw + type is( sstNode); index_ = iobsNode_sst + type is( pwNode); index_ = iobsNode_pw + type is( pcpNode); index_ = iobsNode_pcp + type is( ozNode); index_ = iobsNode_oz + type is( o3lNode); index_ = iobsNode_o3l + type is( gpsNode); index_ = iobsNode_gps + type is( radNode); index_ = iobsNode_rad + type is( tcpNode); index_ = iobsNode_tcp + type is( lagNode); index_ = iobsNode_lag + type is(colvkNode); index_ = iobsNode_colvk + type is( aeroNode); index_ = iobsNode_aero + type is(aerolNode); index_ = iobsNode_aerol + type is(pm2_5Node); index_ = iobsNode_pm2_5 + type is( gustNode); index_ = iobsNode_gust + type is( visNode); index_ = iobsNode_vis + type is( pblhNode); index_ = iobsNode_pblh + + type is(wspd10mNode); index_ = iobsNode_wspd10m + type is(uwnd10mNode); index_ = iobsNode_uwnd10m + type is(vwnd10mNode); index_ = iobsNode_vwnd10m + + type is( td2mNode); index_ = iobsNode_td2m + type is( mxtmNode); index_ = iobsNode_mxtm + type is( mitmNode); index_ = iobsNode_mitm + type is( pmslNode); index_ = iobsNode_pmsl + type is( howvNode); index_ = iobsNode_howv + type is(tcamtNode); index_ = iobsNode_tcamt + type is(lcbasNode); index_ = iobsNode_lcbas + + type is( pm10Node); index_ = iobsNode_pm10 + type is(cldchNode); index_ = iobsNode_cldch + + type is( swcpNode); index_ = iobsNode_swcp + type is( lwcpNode); index_ = iobsNode_lwcp + + type is(lightNode); index_ = iobsNode_light + type is( dbzNode); index_ = iobsNode_dbz + + end select +end function vmold2index_select_ + +function index2vmold_(i_obType) result(obsmold_) + implicit none + class(obsNode),pointer:: obsmold_ + integer(kind=i_kind),intent(in):: i_obType + + character(len=*),parameter:: myname_=myname//"::index2vmold_" + + obsmold_ => null() + select case(i_obType) + case(iobsNode_ps ); obsmold_ => ps_mold + case(iobsNode_t ); obsmold_ => t_mold + case(iobsNode_w ); obsmold_ => w_mold + case(iobsNode_q ); obsmold_ => q_mold + case(iobsNode_spd ); obsmold_ => spd_mold + case(iobsNode_rw ); obsmold_ => rw_mold + case(iobsNode_dw ); obsmold_ => dw_mold + case(iobsNode_sst ); obsmold_ => sst_mold + case(iobsNode_pw ); obsmold_ => pw_mold + case(iobsNode_pcp ); obsmold_ => pcp_mold + case(iobsNode_oz ); obsmold_ => oz_mold + case(iobsNode_o3l ); obsmold_ => o3l_mold + case(iobsNode_gps ); obsmold_ => gps_mold + case(iobsNode_rad ); obsmold_ => rad_mold + case(iobsNode_tcp ); obsmold_ => tcp_mold + case(iobsNode_lag ); obsmold_ => lag_mold + case(iobsNode_colvk); obsmold_ => colvk_mold + case(iobsNode_aero ); obsmold_ => aero_mold + case(iobsNode_aerol); obsmold_ => aerol_mold + case(iobsNode_pm2_5); obsmold_ => pm2_5_mold + case(iobsNode_gust ); obsmold_ => gust_mold + case(iobsNode_vis ); obsmold_ => vis_mold + case(iobsNode_pblh ); obsmold_ => pblh_mold + + case(iobsNode_wspd10m); obsmold_ => wspd10m_mold + case(iobsNode_uwnd10m); obsmold_ => uwnd10m_mold + case(iobsNode_vwnd10m); obsmold_ => vwnd10m_mold + + case(iobsNode_td2m ); obsmold_ => td2m_mold + case(iobsNode_mxtm ); obsmold_ => mxtm_mold + case(iobsNode_mitm ); obsmold_ => mitm_mold + case(iobsNode_pmsl ); obsmold_ => pmsl_mold + case(iobsNode_howv ); obsmold_ => howv_mold + case(iobsNode_tcamt); obsmold_ => tcamt_mold + case(iobsNode_lcbas); obsmold_ => lcbas_mold + + case(iobsNode_pm10 ); obsmold_ => pm10_mold + case(iobsNode_cldch); obsmold_ => cldch_mold + + case(iobsNode_swcp ); obsmold_ => swcp_mold + case(iobsNode_lwcp ); obsmold_ => lwcp_mold + + case(iobsNode_light); obsmold_ => light_mold + case(iobsNode_dbz); obsmold_ => dbz_mold + + end select +end function index2vmold_ + +function vname2vmold_(vname) result(obsmold_) + implicit none + class(obsNode),pointer:: obsmold_ + character(len=*),intent(in):: vname + + character(len=*),parameter:: myname_=myname//"::vname2vmold_" + integer(kind=i_kind):: i_obType + + i_obType=vname2index_(vname) + obsmold_ => index2vmold_(i_obType) +end function vname2vmold_ + +end module m_obsNodeTypeManager diff --git a/src/gsi/m_obsdiagNode.F90 b/src/gsi/m_obsdiagNode.F90 new file mode 100644 index 000000000..8d21b9721 --- /dev/null +++ b/src/gsi/m_obsdiagNode.F90 @@ -0,0 +1,1591 @@ +module m_obsdiagNode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_obsdiagNode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: module of node type obs_diag and linked-list type obs_diags. +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial implementation. +! 2016-06-24 j.guo - Added support of using m_latlonRange to find a cluster +! latlonRange from (elat,elon) values of observations. +! . cleaned out some components from obsdiagNode, which +! were put in for debugging purposes. (%dlat,%dlon). +! . removed some earlier routines for debuggings and +! testings. e.g. lmock_() and obsnode_mock_(). +! . use a fixed miter size for both write_() and read_(), +! for a simpler control in the future. +! . renamed lsize_() to lcount_(). Then reimplemented a +! new lsize_() to separate different functionalities. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,tell,warn,perr,die + implicit none + + private + + public:: obs_diag + public:: obs_diags + public:: fptr_obsdiagNode + + ! Primery behaviors: + public:: obsdiagLList_reset ! destructor + initializer + public:: obsdiagLList_appendNode + public:: obsdiagLList_rewind ! rewind an obsdiagLList + public:: obsdiagLList_nextNode + + public:: obsdiagLList_headNode + public:: obsdiagLList_tailNode + + public:: obsdiagLList_read ! reader, for input + public:: obsdiagLList_write ! writer, for otuput + public:: obsdiagLList_lsize ! size inquiry + public:: obsdiagLList_lcount ! size inquiry with recount + public:: obsdiagLList_lsort ! sort nodes according to their keys + public:: obsdiagLList_checksum! size consistency checking + public:: obsdiagLList_summary ! status report + + interface obsdiagLList_reset ; module procedure lreset_; end interface + interface obsdiagLList_rewind; module procedure lrewind_; end interface + interface obsdiagLList_read ; module procedure lread_; end interface + interface obsdiagLList_checksum; module procedure & + lchecksum_ , & + lchecksum1_ , & + lchecksum2_ ; end interface + interface obsdiagLList_lsize ; module procedure lsize_ ; end interface + interface obsdiagLList_lcount ; module procedure lcount_ ; end interface + interface obsdiagLList_lsort ; module procedure lsort_ ; end interface + interface obsdiagLList_write ; module procedure lwrite_ ; end interface + interface obsdiagLList_summary; module procedure lsummary_; end interface + + interface obsdiagLList_appendNode; module procedure obsNode_append_; end interface + interface obsdiagLList_nextNode ; module procedure & + obsNode_next_, & + make_or_next_; end interface + + interface obsdiagLList_headNode ; module procedure lheadNode_ ; end interface + interface obsdiagLList_tailNode ; module procedure ltailNode_ ; end interface + + ! Node lookup, secondary function with its searching component + public:: obsdiagLookup_build ! setup, its searching component + public:: obsdiagLookup_locate ! node lookup, with the searching component + public:: obsdiagLookup_clean ! clean, its searching component + + interface obsdiagLookup_build ; module procedure lbuild_; end interface + interface obsdiagLookup_locate; module procedure locate_; end interface + interface obsdiagLookup_clean ; module procedure lclean_; end interface + + public:: obsdiagLList_dump + interface obsdiagLList_dump; module procedure ldump_; end interface + + !public:: obsdiagNode_append + ! interface obsdiagNode_append; module procedure obsNode_append_; end interface + !public:: obsdiagNode_first + ! interface obsdiagNode_first ; module procedure obsNode_first_; end interface + !public:: obsdiagNode_next + ! interface obsdiagNode_next ; module procedure obsNode_next_; end interface + public:: obsdiagNode_init + public:: obsdiagNode_assert + public:: obsdiagNode_set + public:: obsdiagNode_get + interface obsdiagNode_init ; module procedure obsNode_init_; end interface + interface obsdiagNode_assert; module procedure anode_assert_; end interface + interface obsdiagNode_set ; module procedure obsNode_set_ ; end interface + interface obsdiagNode_get ; module procedure obsNode_get_ ; end interface + + type obs_diag + type(obs_diag), pointer :: next => NULL() + real(r_kind), pointer :: nldepart(:) => null() ! (miter+1) + real(r_kind), pointer :: tldepart(:) => null() ! (miter) + real(r_kind), pointer :: obssen(:) => null() ! (miter) + real(r_kind) :: wgtjo + real(r_kind) :: elat, elon ! earth lat-lon for redistribution + integer(i_kind) :: idv,iob,ich ! device, obs., and channel indices + logical, pointer :: muse(:) => null() ! (miter+1), according the setup()s + logical :: luse + end type obs_diag + + type fptr_obsdiagNode ! Fortran array element of a type(obs_diag) pointer + type(obs_diag),pointer:: ptr => null() + end type fptr_obsdiagNode + + type:: obs_diags + integer(i_kind):: n_alloc=0 + type(obs_diag), pointer :: head => NULL() + type(obs_diag), pointer :: tail => NULL() + type(fptr_obsdiagNode), allocatable, dimension(:):: lookup + end type obs_diags + +#include "myassert.H" +#include "mytrace.H" + + character(len=*),parameter:: myname="m_obsdiagNode" + +#define _obsNode_ obs_diag +#define _obsLList_ obs_diags + +contains +subroutine lgotoNode_(headLL,thisNode) +! Move the tail pointer to thisNode. +! It is assumed that given thisNode is one of nodes in the list. Otherwise +! this function would break the list. + implicit none + type(_obsLList_),target,intent(inout):: headLL + type(_obsNode_ ),target,intent(in ):: thisNode + headLL%tail => thisNode +end subroutine lgotoNode_ + +function lheadNode_(headLL) result(here_) +! Return the head node + implicit none + type(_obsNode_),pointer:: here_ + type(_obsLList_),target,intent(in):: headLL + here_ => headLL%head +end function lheadNode_ + +function ltailNode_(headLL) result(here_) +! Return the current tail node + implicit none + type(_obsNode_ ),pointer:: here_ + type(_obsLList_),target,intent(in):: headLL + here_ => headLL%tail +end function ltailNode_ + +subroutine lwrite_(diagLL,iunit,luseonly,jiter,miter,jj_type,ii_bin,luseRange) + use m_latlonRange , only: latlonRange + use m_latlonRange , only: latlonRange_enclose + use mpeu_util, only: stdout + use mpeu_util, only: stdout_lead + implicit none + type(_obsLList_) ,intent(inout):: diagLL ! the linked list of data + integer(kind=i_kind),intent(in ):: iunit ! the output unit + logical ,intent(in ):: luseonly ! write only if(luse) + integer(kind=i_kind),intent(in ):: jiter ! diag width for the IO (or this iter) + integer(kind=i_kind),intent(in ):: miter ! diag width of the memory + integer(kind=i_kind),intent(in ):: jj_type, ii_bin + type(latlonRange),optional,intent(inout):: luseRange + + character(len=*),parameter:: myname_=myname//"::lwrite_" + integer(kind=i_kind):: iobs,kobs,lobs,mobs + integer(kind=i_kind):: istat + type(_obsNode_), pointer:: iNode + logical:: isluse_ +_ENTRY_(myname_) +!_TIMER_ON_(myname_) + + lobs=obsdiagLList_lcount(diagLL,luseonly=luseonly) + mobs=lobs + if(.not.luseonly) mobs=obsdiagLList_lsize(diagLL) + + call obsHeader_write_(iunit,ii_bin,jj_type,lobs,jiter,miter,istat) + if(istat/=0) then + call perr(myname_,'obsHeader_write_(), istat =',istat) + call perr(myname_,' iunit =',iunit) + call perr(myname_,' ii_bin =',ii_bin) + call perr(myname_,' jtype =',jj_type) + call perr(myname_,' jiter =',jiter) + call perr(myname_,' miter =',miter) + call perr(myname_,' total-luse-node, lobs =',lobs) + call perr(myname_,' total-all-node, mobs =',mobs) + call perr(myname_,' luseonly =',luseonly) + call die(myname_) + endif + + _TRACE_(myname_,'looping through obshead pointers') + + if(lobs<=0) then + !_TIMER_OFF_(myname_) + _EXIT_(myname_) + return + endif + + iobs=0 + kobs=0 + iNode => obsNode_first_(diagLL) + do while(associated(iNode)) + iobs=iobs+1 + isluse_=obsNode_isluse_(iNode) + if(isluse_ .or. .not.luseonly) then + + ! Update luseRange with a luse observation, for the lat-lon- + ! range on the current PE. + + if(isluse_ .and. present(luseRange)) & + call latlonRange_enclose(luseRange,iNode%elat,iNode%elon) + + ! Count it, then write the node out. Use of miter suggests a + ! fixed output size. + kobs=kobs+1 + call obsNode_write_(iNode,iunit,miter,istat) + if(istat/=0) then + call perr(myname_,'obsNode_write_(), istat =',istat) + call perr(myname_,' iunit =',iunit) + call perr(myname_,' jiter =',jiter) + call perr(myname_,' miter =',miter) + call perr(myname_,' ii_bin =',ii_bin) + call perr(myname_,' jtype =',jj_type) + call perr(myname_,'current-luse-node, kobs =',kobs) + call perr(myname_,' current-all-node, iobs =',iobs) + call perr(myname_,' total-luse-node, lobs =',lobs) + call perr(myname_,' total-all-node, mobs =',mobs) + call perr(myname_,' luseonly =',luseonly) + call die(myname_) + endif + endif + iNode => obsNode_next_(diagLL) + enddo + + ASSERT(kobs==lobs) + ASSERT(iobs==mobs) + +!_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine lwrite_ + +subroutine ldump_(diagLL,jiter) + use mpeu_util, only: stdout + implicit none + type(_obsLList_), intent(inout):: diagLL ! the list to dump + integer(i_kind ),optional,intent(in ):: jiter ! jiter of diagLL + + character(len=*),parameter:: myname_=myname//"::ldump_" + integer(kind=i_kind):: iobs,lobs,mobs + integer(kind=i_kind):: jiter_ + type(_obsNode_), pointer:: iNode + logical:: isluse_,ismuse_ +_ENTRY_(myname_) +!_TIMER_ON_(myname_) + jiter_=0 + if(present(jiter)) jiter_=jiter + + call lbuild_(diagLL) ! create a pointer array %lookup, sorted by (idv,iob,ich) + + lobs=0 + mobs=0 + do iobs=1,size(diagLL%lookup(:)) + iNode => diagLL%lookup(iobs)%ptr + + isluse_=obsNode_isluse_(iNode) + if(isluse_) lobs=lobs+1 + + ismuse_=jiter_>=1.and.jiter_<=size(iNode%muse) + if(ismuse_) ismuse_=iNode%muse(jiter_) + if(ismuse_) mobs=mobs+1 + + write(stdout,'(2x,2l1,3i8,2x,2f12.4)') isluse_,ismuse_, & + iNode%idv,iNode%iob,iNode%ich, iNode%elat,iNode%elon + enddo + write(stdout,'(2x,a,4i8)') '***',jiter_,size(diagLL%lookup(:)),lobs,mobs + call lclean_(diagLL) ! destroy the pointer array %lookup. + +!_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine ldump_ + +subroutine lread_(diagLL,iunit,redistr,jiter,miter,jj_type,ii_bin,jread,leadNode,jiter_expected) +!_TIMER_USE_ + implicit none + type(_obsLList_),intent(inout):: diagLL + integer(kind=i_kind),intent(in ):: iunit + logical ,intent(in ):: redistr + integer(kind=i_kind),intent(in ):: jiter + integer(kind=i_kind),intent(in ):: miter + integer(kind=i_kind),intent(in ):: jj_type, ii_bin + integer(kind=i_kind),intent( out):: jread + type(_obsNode_), pointer, intent(out):: leadNode + + integer(kind=i_kind),intent(in),optional:: jiter_expected + + character(len=*),parameter:: myname_=myname//"::lread_" + integer(kind=i_kind):: ki,kj,kobs + integer(kind=i_kind):: kiter,miter_read + ! jiter : current iter count + ! miter : maximum iter size + ! kiter(read): current iter count as it was written + ! miter_read : maximum iter size as it was written + integer(kind=i_kind):: kk,istat + type(_obsNode_), pointer:: aNode +_ENTRY_(myname_) +!_TIMER_ON_(myname_) +!call timer_ini(myname_) + + call obsHeader_read_(iunit,ki,kj,kobs,kiter,miter_read,istat) + if(istat/=0) then + call perr(myname_,'obsHeader_read_(), istat =',istat) + call perr(myname_,' iunit =',iunit) + call die(myname_) + endif + + if(ki/=ii_bin .or. kj/=jj_type .or. miter/=miter_read) then + call perr(myname_,'obsHeader_read_(), unexpected header values (ii,jj,miter)') + call perr(myname_,' expecting miter =',miter) + call perr(myname_,' actual miter =',miter_read) + call perr(myname_,' expecting ii =',ii_bin) + call perr(myname_,' actual ii =',ki) + call perr(myname_,' expecting jj =',jj_type) + call perr(myname_,' actual jj =',kj) + call die(myname_) + endif + + if(present(jiter_expected)) then + if(jiter_expected>=0) then + if(kiter/=jiter_expected) then + call perr(myname_,'obsHeader_read_(), unexpected input jiter =',kiter) + call perr(myname_,' with input miter =',miter_read) + call perr(myname_,' expecting input jiter =',jiter_expected) + call perr(myname_,' miter =',miter) + call perr(myname_,' jiter =',jiter) + call die(myname_) + endif + endif + endif + jread=kiter + + !-- construct an an_obsNode + leadNode => null() + aNode => obsNode_alloc_(miter) + do kk=1,kobs + !-- initialize an_obsNode from a file (iunit). Use of miter suggests a + !-- fixed input size. + call obsNode_read_(aNode,iunit,miter,istat,redistr=redistr) + if(istat<0) then + call perr(myname_,'obsNode_read_(), istat =',istat) + call perr(myname_,' redistr =',redistr) + call die(myname_) + endif + + ! istat <0: a failed read(aNode) + ! ==0: passed, thus an incomplete aNode + ! >0: a good aNode to keep + if(istat==0) cycle + if(redistr) call obsNode_setluse_(aNode) + + ! keep this obsNode in its linked-list, diagLL := obsdiags(jj,ii) + call obsNode_append_(diagLL,aNode) + !-- mark the beginning of this linked-list segment + if(.not.associated(leadNode)) leadNode => aNode + + !-- drop this aNode, to construct a new. This _alloc_ + ! ensures an aNode is not in anyway referencible to + ! the one that has been appended to the linked-list. + ! Then, a deep-deallocation of aNode is alwasy safe. + aNode => obsNode_alloc_(miter) + enddo ! < kobs > + call obsNode_dealloc_(aNode,deep=.true.) ! Clean up the malloc of aNode + +! ---------------------------------------------------------- +!call timer_fnl(myname_) +!_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine lread_ + +subroutine lreset_(diagLL) + implicit none + type(_obsLList_), intent(inout):: diagLL + + character(len=*),parameter:: myname_=myname//"::lreset_" + type(_obsNode_),pointer:: l_obsNode + type(_obsNode_),pointer:: n_obsNode + integer(kind=i_kind):: ip +_ENTRY_(myname_) + + l_obsNode => obsNode_first_(diagLL) + ip=0 + do while(associated(l_obsNode)) + ip=ip+1 + !_TRACEV_(myname_,'deallocating at ip =',ip) + !call obsNode_check_(myname_,l_obsNode) + ! Steps of forward resetting, + ! (1) hold the %next node, + ! (2) clean (leaving the %next node untouched, + ! (3) deallocate the current node, + ! (4) point the starting point to the %next node. + n_obsNode => obsNode_next_(diagLL) + call obsNode_dealloc_(l_obsNode,deep=.true.) + l_obsNode => n_obsNode + enddo + !n_obsNode => null() + !l_obsNode => null() + + diagLL%n_alloc = 0 + diagLL%head => null() + diagLL%tail => null() + if(allocated(diagLL%lookup)) deallocate(diagLL%lookup) + +_EXIT_(myname_) +return +end subroutine lreset_ +subroutine lrewind_(diagLL) + implicit none + type(_obsLList_),target,intent(inout):: diagLL + diagLL%tail => null() +return +end subroutine lrewind_ + +subroutine lchecksum_(diagLL,leadNode,itype,ibin,sorted) +!$$$ subprogram documentation block +! . . . . +! subprogram: lchecksum_ +! prgmmr: J. Guo +! +! abstract: check the size values against a known counts. +! +! program history log: +! 2015-06-26 guo - +! +! input argument list: (see Fortran declarations below) +! +! output argument list: (see Fortran declarations below) +! +! attributes: +! language: f90/f95/f2003/f2008 +! machine: +! +!$$$ end documentation block + use mpeu_util, only: stdout + use mpeu_util, only: stdout_lead + implicit none + type(_obsLList_), intent(in):: diagLL + type(_obsNode_ ), pointer, optional, intent(in):: leadNode + integer(kind=i_kind),optional,intent(in ):: itype + integer(kind=i_kind),optional,intent(in ):: ibin + logical ,optional,intent(out):: sorted + + character(len=*),parameter:: myname_=MYNAME//"::lchecksum_" + integer(kind=i_kind):: jtype,jbin + integer(kind=i_kind):: mcount + integer(kind=i_kind):: nuse,nooo,ndup + integer(kind=i_kind),dimension(3):: ksum +!jtest +! logical:: lasso,lhead + +_ENTRY_(myname_) +!jtest +! ASSERT(present(leadNode)) +! lasso=associated(leadNode) +! lhead=associated(diagLL%head,leadNode) + + mcount=lcount_(diagLL,recount=.true.,nuse=nuse,nooo=nooo,ndup=ndup,ksum=ksum,leadNode=leadNode) + if(present(sorted)) sorted = nooo==0.and.ndup==0 + +!jtest +! if(mcount/=diagLL%n_alloc) then +! call perr(myname_,'checksum failed, mcount =',mcount) +! call perr(myname_,' diagLList%n_alloc =',diagLL%n_alloc) +! if(present(itype)) & +! call perr(myname_,' itype =',itype) +! if(present(ibin)) & +! call perr(myname_,' ibin =',ibin) +! call die(myname_) +! endif + + if(present(itype)) jtype=itype + if(present(ibin)) jbin =ibin +_EXIT_(myname_) +return +end subroutine lchecksum_ +subroutine lchecksum1_(diagLL,leadNode,itype) +!$$$ subprogram documentation block +! . . . . +! subprogram: lchecksum_ +! prgmmr: J. Guo +! +! abstract: check the size values against a known counts. +! +! program history log: +! 2015-06-26 guo - +! +! input argument list: (see Fortran declarations below) +! +! output argument list: (see Fortran declarations below) +! +! attributes: +! language: f90/f95/f2003/f2008 +! machine: +! +!$$$ end documentation block + implicit none + type(_obsLList_), dimension(:),intent(in):: diagLL + integer(kind=i_kind),optional,intent(in):: itype + type(fptr_obsdiagNode),optional,dimension(:),intent(in):: leadNode + + character(len=*),parameter:: myname_=MYNAME//"::lchecksum1_" + integer(kind=i_kind):: i +_ENTRY_(myname_) + if(present(leadNode)) then + ASSERT(size(diagLL)==size(leadNode)) + do i=1,size(diagLL) + call lchecksum_(diagLL(i),itype=itype,ibin=i,leadNode=leadNode(i)%ptr) + enddo + else + do i=1,size(diagLL) + call lchecksum_(diagLL(i),itype=itype,ibin=i) + enddo + endif +_EXIT_(myname_) +return +end subroutine lchecksum1_ +subroutine lchecksum2_(diagLL) +!$$$ subprogram documentation block +! . . . . +! subprogram: lchecksum_ +! prgmmr: J. Guo +! +! abstract: check the size values against a known counts. +! +! program history log: +! 2015-06-26 guo - +! +! input argument list: (see Fortran declarations below) +! +! output argument list: (see Fortran declarations below) +! +! attributes: +! language: f90/f95/f2003/f2008 +! machine: +! +!$$$ end documentation block + implicit none + type(_obsLList_), dimension(:,:),intent(in):: diagLL + + character(len=*),parameter:: myname_=MYNAME//"::lchecksum2_" + integer(kind=i_kind):: it,ib +_ENTRY_(myname_) + do it=1,size(diagLL,1) + do ib=1,size(diagLL,2) + call lchecksum_(diagLL(it,ib),itype=it,ibin=ib) + enddo + enddo +_EXIT_(myname_) +return +end subroutine lchecksum2_ + +subroutine lsummary_(diagLL,verbose) + implicit none + type(_obsLList_), intent(in):: diagLL + logical,optional, intent(in):: verbose + + character(len=*),parameter:: myname_=MYNAME//"::lsummary_" + type(_obsNode_ ), pointer:: iNode + type(_obsLList_), target :: tempLL + integer(kind=i_kind):: iobs_ + logical:: verbose_ + verbose_=.false. + if(present(verbose)) verbose_=verbose +_ENTRY_(myname_) + + if(verbose_) then + tempLL = diagLL + iobs_ = 0 + iNode => obsNode_first_(tempLL) + do while(associated(iNode)) + iobs_=iobs_+1 + call obsNode_show_(iNode,iobs_) + iNode => obsNode_next_(tempLL) + enddo + endif +_EXIT_(myname_) +return +end subroutine lsummary_ + +function lsize_(diagLL) result(lobs_) + implicit none + integer(kind=i_kind):: lobs_ + type(_obsLList_), target, intent(in):: diagLL + lobs_=diagLL%n_alloc +end function lsize_ + +function lcount_(diagLL,luseonly,recount,nuse,nooo,ndup,ksum,leadNode) result(lobs_) + use mpeu_util, only: assert_ + implicit none + integer(kind=i_kind):: lobs_ + type(_obsLList_), target, intent(in):: diagLL + logical , optional, intent(in):: luseonly + logical , optional, intent(in):: recount + integer(kind=i_kind),optional,intent(out):: nuse ! no. of luse + integer(kind=i_kind),optional,intent(out):: nooo ! no. out-of-orders + integer(kind=i_kind),optional,intent(out):: ndup ! no. duplicates + integer(kind=i_kind),optional,dimension(:),intent(out):: ksum ! key value sum + type(_obsNode_ ), pointer, optional, intent(in):: leadNode + + character(len=*),parameter:: myname_=myname//"::lcount_" + type(_obsNode_ ), pointer:: iNode + type(_obsLList_), target :: tempLL + integer(kind=i_kind):: nuse_ + integer(kind=i_kind):: k + integer(kind=i_kind),dimension(3) :: kprev + logical:: luseonly_,recount_,checksum_ +_ENTRY_(myname_) + + luseonly_=.false. + if(present(luseonly)) luseonly_=luseonly + recount_ =.false. + if(present(recount )) recount_ =recount + if(present(leadNode)) recount_ =.true. + + checksum_= present(nuse).or.present(nooo).or.present(ndup).or.present(ksum) + recount_ = recount_ .or. checksum_ + !if(.not.recount_) recount_ = checksum_ + + if(present(ksum)) then + ALWAYS_ASSERT( size(ksum)==size(kprev) ) + endif + + if(.not.(luseonly_.or.recount_)) then + lobs_=diagLL%n_alloc + + else ! recount through the list + tempLL = diagLL ! A copy of diagLL, such that diagLL can remain intent(in) + + lobs_ = 0 + nuse_ = 0 + + if(checksum_) call checksum_init_(kprev,nooo=nooo,ndup=ndup,ksum=ksum) + + iNode => obsNode_first_(tempLL,atNode=leadNode) + do while(associated(iNode)) + if(obsNode_isluse_(iNode)) nuse_=nuse_+1 + if(.not.luseonly_ .or. obsNode_isluse_(iNode)) lobs_=lobs_+1 + + if(checksum_) call checksum_add_(kprev, & + (/iNode%idv,iNode%iob,iNode%ich/),nooo=nooo,ndup=ndup,ksum=ksum) + + iNode => obsNode_next_(tempLL) + enddo + if(present(nuse)) nuse=nuse_ + endif + +_EXIT_(myname_) +return +contains +subroutine checksum_init_(kprev,nooo,ndup,ksum) + implicit none + integer(kind=i_kind),dimension(:),intent(out):: kprev + integer(kind=i_kind),optional,intent(out):: nooo + integer(kind=i_kind),optional,intent(out):: ndup + integer(kind=i_kind),optional,dimension(:),intent(out):: ksum + + kprev(:)= 0 + if(present(nooo)) nooo=0 + if(present(ndup)) ndup=0 + if(present(ksum)) ksum(:)=0 +end subroutine checksum_init_ +subroutine checksum_add_(kprev,knext,nooo,ndup,ksum) + implicit none + integer(kind=i_kind),dimension(:),intent(inout):: kprev + integer(kind=i_kind),dimension(:),intent(in ):: knext + integer(kind=i_kind),optional,intent(inout):: nooo + integer(kind=i_kind),optional,intent(inout):: ndup + integer(kind=i_kind),optional,dimension(:),intent(inout):: ksum + + k=compare_(kprev,knext) + if(present(nooo).and.k> 0) nooo=nooo+1 + if(present(ndup).and.k==0) ndup=ndup+1 + if(present(ksum)) ksum(:)=ksum(:)+knext(:) + kprev(:)=knext(:) +end subroutine checksum_add_ +end function lcount_ + +function obsNode_first_(diagLL,atNode) result(here_) + implicit none + type(_obsNode_ ), pointer :: here_ + type(_obsLList_), target, intent(inout):: diagLL + type(_obsNode_ ), optional, pointer,intent(in):: atNode + + character(len=*),parameter:: myname_=myname//"::obsNode_first_" +_ENTRY_(myname_) + !_TRACEV_(myname_,'%n_alloc =',diagLL%n_alloc) + !_TRACEV_(myname_,'associated(%head) =',associated(diagLL%head)) + here_ => diagLL%head + if(present(atNode)) here_=>atNode + diagLL%tail => here_ ! update the tail-node + + if(associated(here_)) call obsNode_check_(myname_,here_) +_EXIT_(myname_) +return +end function obsNode_first_ + +function obsNode_next_(diagLL) result(next_) + implicit none + type(_obsNode_ ), pointer :: next_ + type(_obsLList_), target, intent(inout):: diagLL + + character(len=*),parameter:: myname_=myname//"::obsNode_next_" +_ENTRY_(myname_) + next_ => diagLL%head + if(associated(diagLL%tail)) next_ => diagLL%tail%next + diagLL%tail => next_ ! update the tail-node +_EXIT_(myname_) +return +end function obsNode_next_ + +function make_or_next_(diagLL,create,idv,iob,ich,elat,elon,luse,miter) result(next_) + implicit none + type(_obsNode_ ), pointer :: next_ + type(_obsLList_), target, intent(inout):: diagLL + + logical , intent(in):: create ! make or next + integer(kind=i_kind), intent(in):: idv,iob,ich + real (kind=r_kind), intent(in):: elat,elon + logical , intent(in):: luse + integer(kind=i_kind), intent(in):: miter + + character(len=*),parameter:: myname_=myname//"::make_or_next_" + logical:: matched +_ENTRY_(myname_) + + if(create) then + allocate(next_) + call obsNode_append_(diagLL,next_) + call obsNode_init_(next_,idv,iob,ich,elat,elon,luse,miter) + + else + next_ => diagLL%head + if(associated(diagLL%tail)) next_ => diagLL%tail%next + diagLL%tail => next_ ! update the tail-node + + ! Check the next node against (idv,iob,ich) + matched = associated(next_) + if(matched) matched = next_%idv==idv .and. & + next_%iob==iob .and. & + next_%ich==ich + + if(.not.matched) then + call perr(myname_,"unexpected node, associated(next) =", associated(next_)) + call perr(myname_," expecting (idv,iob,ich) =", (/idv,iob,ich/)) + call perr(myname_," elat =", elat) + call perr(myname_," elon =", elon) + if(associated(next_)) then + call perr(myname_," next%(idv,iob,ich) =", (/next_%idv,next_%iob,next_%ich/)) + call perr(myname_," next%elat =", next_%elat) + call perr(myname_," next%elon =", next_%elon) + call perr(myname_," next%luse =", next_%luse) + call perr(myname_," size(next%muse) =", size(next_%muse)) + endif + call die(myname_) + endif + endif ! (create) +_EXIT_(myname_) +return +end function make_or_next_ + +subroutine obsNode_append_(diagLL,targetNode) + ! Link the next node of the list to the given targetNode. The return + ! result is a pointer associated to the same targetNode. +!-- use jfunc, only: miter + implicit none + type(_obsLList_), intent(inout):: diagLL + type(_obsNode_ ), pointer, intent(in):: targetNode + + character(len=*),parameter:: myname_=myname//"::obsNode_append_" +!-- type(_obsNode_ ),pointer:: aNode +_ENTRY_(myname_) + if(.not.associated(diagLL%head)) then + ! this is a fresh starting -node- for this linked-list ... + diagLL%n_alloc = 1 + diagLL%head => targetNode + diagLL%tail => diagLL%head + + else + ! this is for a new next -node- from here ... + diagLL%n_alloc = diagLL%n_alloc +1 + diagLL%tail%next => targetNode + diagLL%tail => diagLL%tail%next + + !diagLL%tail%append(next_) + ! append(t,next_) + ! t%next => next_ + ! t => t%next + endif + if(associated(diagLL%tail)) diagLL%tail%next => null() + +!-- aNode => diagLL%tail +!-- ASSERT(lbound(aNode%muse ,1)==1.and.ubound(aNode%muse ,1)==miter+1) +!-- ASSERT(lbound(aNode%nldepart,1)==1.and.ubound(aNode%nldepart,1)==miter+1) +!-- ASSERT(lbound(aNode%tldepart,1)==1.and.ubound(aNode%tldepart,1)==miter ) +!-- ASSERT(lbound(aNode%obssen ,1)==1.and.ubound(aNode%obssen ,1)==miter ) +!-- aNode => null() + +_EXIT_(myname_) +return +end subroutine obsNode_append_ + +subroutine obsNode_insert_(diagLL,targetNode) + ! Insert targetNode to diagLL's current location, mostly %tail. At the + ! return, diagLL%tail is associated to targetNode. +!-- use jfunc, only: miter + implicit none + type(_obsLList_), intent(inout):: diagLL + type(_obsNode_ ), pointer, intent(in):: targetNode + + character(len=*),parameter:: myname_=myname//"::obsNode_insert_" + type(_obsNode_),pointer:: next_ +_ENTRY_(myname_) + if(.not.associated(diagLL%head)) then + ! This is a fresh start case: insert a node as append + diagLL%n_alloc = 1 + diagLL%head => targetNode + diagLL%tail => diagLL%head ! now the current node + diagLL%tail%next => null() ! set %next to nothing there before + + elseif(.not.associated(diagLL%tail)) then + ! This is a rewound case: insert a node as the new %head + next_ => diagLL%head + diagLL%n_alloc = diagLL%n_alloc +1 + diagLL%head => targetNode + diagLL%tail => diagLL%head ! now the current node + diagLL%tail%next => next_ ! set %next to the original %head + + else + ! This is a normal case: insert a node in between %tail and + ! %tail%next. + next_ => diagLL%tail%next + diagLL%n_alloc = diagLL%n_alloc +1 + diagLL%tail%next => targetNode + diagLL%tail => diagLL%tail%next ! now the current node. + diagLL%tail%next => next_ ! set %next to the original %tail%next + ! Note in the last stateument, targetNode%next has been implicitly modifed. + endif + +!-- associate(aNode => diagLL%tail) +!-- ASSERT(lbound(aNode%muse ,1)==1.and.ubound(aNode%muse ,1)==miter+1) +!-- ASSERT(lbound(aNode%nldepart,1)==1.and.ubound(aNode%nldepart,1)==miter+1) +!-- ASSERT(lbound(aNode%tldepart,1)==1.and.ubound(aNode%tldepart,1)==miter ) +!-- ASSERT(lbound(aNode%obssen ,1)==1.and.ubound(aNode%obssen ,1)==miter ) +!-- end associate ! (aNode => diagLL%tail) + +_EXIT_(myname_) +return +end subroutine obsNode_insert_ + +subroutine lsort_(diagLL,itype,ibin) +! lsort_: node-sort diagLL, to line-up nodes according to their keys +!_TIMER_USE_ +! use timermod , only: timer_ini,timer_fnl + !use mpeu_util, only: IndexSet + !use mpeu_util, only: IndexSort + !use mpeu_util, only: die + implicit none + type(_obsLList_) , intent(inout):: diagLL + integer(kind=i_kind),optional,intent(in):: itype,ibin + + character(len=*),parameter:: myname_=myname//'::lsort_' + integer(kind=i_kind):: i,nobs,mobs + logical:: sorted +_ENTRY_(myname_) +!_TIMER_ON_(myname_) +! call timer_ini(myname_) + + call lchecksum_(diagLL,itype=itype,ibin=ibin,sorted=sorted) + if(sorted) then + _EXIT_(myname_) + return + endif + + ! created a sorted table + call lbuild_(diagLL) + + nobs = diagLL%n_alloc + mobs = size(diagLL%lookup(:)) + ASSERT(nobs==mobs) + + ! rebuild the linked-list + diagLL%n_alloc=0 + diagLL%head => null() + diagLL%tail => null() + + ! rebuild the list according to the sorted table + do i=1,mobs + call obsNode_append_(diagLL,diagLL%lookup(i)%ptr) + enddo + ASSERT(nobs==diagLL%n_alloc) + if(associated(diagLL%tail)) then + ASSERT(.not.associated(diagLL%tail%next)) + endif + + ! discard the sorted table + call lclean_(diagLL) + + call lchecksum_(diagLL,itype=itype,ibin=ibin,sorted=sorted) + if(.not.sorted) then + call perr(myname_,'failed post-sorting lchecksum_(diagLL), sorted =',sorted) + if(present(itype)) & + call perr(myname_,' itype =',itype) + if(present(ibin )) & + call perr(myname_,' ibin =',ibin ) + call die(myname_) + endif + +! call timer_fnl(myname_) +!_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine lsort_ + +subroutine lbuild_(diagLL,leadNode,jiter) +!_TIMER_USE_ +! use timermod , only: timer_ini,timer_fnl + use mpeu_util, only: IndexSet + use mpeu_util, only: IndexSort + !use mpeu_util, only: die + implicit none + type(_obsLList_), intent(inout):: diagLL + type(_obsNode_ ), pointer, optional, intent(in):: leadNode + integer(i_kind) , optional, intent(in):: jiter + + character(len=*),parameter:: myname_=myname//'::lbuild_' + type(_obsNode_),pointer:: iNode,pNode + integer(kind=i_kind),allocatable,dimension(:):: indx,idv_,iob_,ich_ + integer(kind=i_kind):: i,m,n + integer(kind=i_kind):: idum + logical:: good +_ENTRY_(myname_) +!_TIMER_ON_(myname_) +! call timer_ini(myname_) + if(present(jiter)) idum=jiter + + ! Mark the leading node + iNode => null() + if(present(leadNode)) iNode => leadNode + if(.not.associated(iNode)) iNode => diagLL%head + + m=diagLL%n_alloc + if(m<0) call die(myname_,'unexpected diagLL, %n_alloc =',m) + + ! Count, starting from the leading node + n=0 + pNode => iNode + do while(associated(pNode)) + n=n+1 + pNode => pNode%next + enddo + + if(n>diagLL%n_alloc) then + call perr(myname_,'unexpected diagLL, %n_alloc =',m) + call die(myname_,' actual count =',n) + endif + + allocate(diagLL%lookup(n)) + allocate(indx(n),idv_(n),iob_(n),ich_(n)) + + associate(lookup => diagLL%lookup(:)) + ! Loop over the linked-list, to get keys. + i=0 + pNode => iNode + do while(associated(pNode)) + i=i+1 + if(i<=n) then + lookup(i)%ptr => pNode + idv_(i) = pNode%idv + iob_(i) = pNode%iob + ich_(i) = pNode%ich + !call obsNode_get(idv=idv_(i),iob=iob_(i),ich=ich_(i)) + endif + pNode => pNode%next + enddo + end associate + + ! sort %lookup(1:n), by its (idv,iob,ich) values + call IndexSet (indx) + call IndexSort(indx,ich_) + call IndexSort(indx,iob_) + call IndexSort(indx,idv_) + + associate(lookup => diagLL%lookup(:)) + lookup(1:n) = lookup(indx(1:n)) + end associate + + idv_(1:n) = idv_(indx(1:n)) + iob_(1:n) = iob_(indx(1:n)) + ich_(1:n) = ich_(indx(1:n)) + + associate(lookup => diagLL%lookup(:)) + good = .true. + do i=1,n + good = lookup(i)%ptr%idv==idv_(i) .and. & + lookup(i)%ptr%iob==iob_(i) .and. & + lookup(i)%ptr%ich==ich_(i) + if(.not.good) exit + enddo + + if(.not.good) then + call perr(myname_,'verification failed at %lookup(i)%ptr, i =',i) + call perr(myname_,' %ptr%idv =',lookup(i)%ptr%idv) + call perr(myname_,' idv_=',idv_(i)) + call perr(myname_,' %ptr%iob =',lookup(i)%ptr%iob) + call perr(myname_,' iob_=',iob_(i)) + call perr(myname_,' %ptr%ich =',lookup(i)%ptr%ich) + call perr(myname_,' ich_=',ich_(i)) + call die(myname_) + endif + end associate + + deallocate(indx,idv_,iob_,ich_) + +! call timer_fnl(myname_) +!_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine lbuild_ + +subroutine lclean_(diagLL) + implicit none + type(_obsLList_), intent(inout):: diagLL + + character(len=*),parameter:: myname_=myname//'::lclean_' + integer(kind=i_kind):: ier,i +_ENTRY_(myname_) + associate(lookup => diagLL%lookup(:)) + do i=1,size(lookup) + lookup(i)%ptr => null() + end do + end associate + deallocate(diagLL%lookup,stat=ier) + if(ier/=0) call die(myname_,'deallocate(diagLL%lookup), stat =',ier) +_EXIT_(myname_) +return +end subroutine lclean_ + +function locate_(diagLL,idv,iob,ich) result(here_) + use timermod , only: timer_ini,timer_fnl + implicit none + type(_obsNode_ ), pointer:: here_ + type(_obsLList_), intent(in):: diagLL + integer(kind=i_kind), intent(in):: idv,iob,ich + + character(len=*),parameter:: myname_=myname//"::locate_" + type(_obsNode_ ),pointer:: idiag + integer(kind=i_kind):: m,i,lb,ub + logical:: done +_ENTRY_(myname_) + call timer_ini(myname_) + + here_ => null() ! return null() if the key is not located. + + associate(lookup => diagLL%lookup(:)) + lb=lbound(lookup,1) + ub=ubound(lookup,1) + done=.false. + do while(.not.done) + i=(lb+ub)/2 + idiag => lookup(i)%ptr + + m=compare_((/idiag%idv,idiag%iob,idiag%ich/),(/idv,iob,ich/)) + done = m==0 + if(done) exit + + ! We are searching for EQUAL, so skip the i-th point if not equal. + if(m<0) then + ! if idiag%(idv,iob,ich) < (/idv,iob,ich/), move the lower range (lb) up + ! to continue the search above i + lb=i+1 + else + ! if idiag%(idv,iob,ich) > (/idv,iob,ich/), move the upper range (ub) down + ! to continue the search below i. + ub=i-1 + endif + + if(ub idiag + endif + + call timer_fnl(myname_) +_EXIT_(myname_) +return +end function locate_ + +function compare_(key1,key2) result (m) + implicit none + integer(kind=i_kind):: m + integer(kind=i_kind),dimension(:),intent(in):: key1,key2 + + integer(kind=i_kind):: n,i + m=0 + n=min(size(key1),size(key2)) + do i=1,n + if (key1(i)key2(i)) then + m=+1; exit + endif + enddo +end function compare_ + +!------------------- +function obsNode_islocal_(aNode) result(islocal_) + use mpimod, only: myPE + use m_cvgridLookup, only: cvgridLookup_islocal + implicit none + logical:: islocal_ + type(_obsNode_),intent(in):: aNode + + character(len=*),parameter:: myname_=myname//"::obsNode_islocal_" +_ENTRY_(myname_) + islocal_=cvgridLookup_islocal(aNode%elat,aNode%elon,myPE) +_EXIT_(myname_) +return +end function obsNode_islocal_ + +function obsNode_isluse_(aNode) result(isluse_) + implicit none + logical:: isluse_ + type(_obsNode_),intent(in):: aNode + + character(len=*),parameter:: myname_=myname//"::obsNode_isluse_" +_ENTRY_(myname_) + isluse_=aNode%luse +_EXIT_(myname_) +return +end function obsNode_isluse_ + +subroutine obsNode_setluse_(aNode) + use mpimod, only: myPE + use m_cvgridLookup, only: cvgridLookup_isluse + implicit none + type(_obsNode_),intent(inout):: aNode + + character(len=*),parameter:: myname_=myname//"::obsNode_setluse_" +_ENTRY_(myname_) + aNode%luse=cvgridLookup_isluse(aNode%elat, aNode%elon, myPE) + ! call obstype_setluse(aNode%luse, aNode%elat, aNode%elon, myPE) +_EXIT_(myname_) +return +end subroutine obsNode_setluse_ + +subroutine obsHeader_read_(iunit,ii_bin,jj_type,lobs,jiter,miter,istat) + implicit none + integer(kind=i_kind),intent(in ):: iunit + integer(kind=i_kind),intent(out):: ii_bin,jj_type,lobs,jiter,miter + integer(kind=i_kind),intent(out):: istat + + character(len=*),parameter:: myname_=myname//"::obsHeader_read_" +_ENTRY_(myname_) + read(iunit,iostat=istat) ii_bin,jj_type,lobs,jiter,miter +_EXIT_(myname_) +return +end subroutine obsHeader_read_ + +subroutine obsHeader_write_(iunit,ii_bin,jj_type,lobs,jiter,miter,istat) + implicit none + integer(kind=i_kind),intent(in ):: iunit + integer(kind=i_kind),intent(in ):: ii_bin,jj_type,lobs,jiter,miter + integer(kind=i_kind),intent(out):: istat + + character(len=*),parameter:: myname_=myname//"::obsHeader_write_" +_ENTRY_(myname_) + write(iunit,iostat=istat) ii_bin,jj_type,lobs,jiter,miter +_EXIT_(myname_) +return +end subroutine obsHeader_write_ + +subroutine obsNode_check_(who,aNode) +!-- use jfunc, only: miter ! for debugging + implicit none + character(len=*),intent(in):: who + type(_obsNode_),intent(in):: aNode + + logical:: equival + character(len=256)::mywho + + mywho=who + !_TRACEV_(who,'associated(aNode%muse ) =',associated(aNode%muse )) + !_TRACEV_(who,'associated(aNode%nldepart) =',associated(aNode%nldepart)) + !_TRACEV_(who,'associated(aNode%tldepart) =',associated(aNode%tldepart)) + !_TRACEV_(who,'associated(aNode%obssen ) =',associated(aNode%obssen )) + + equival = associated(aNode%nldepart) .eqv. associated(aNode%muse ) + if(equival) equival = associated(aNode%tldepart) .eqv. associated(aNode%nldepart) + if(equival) equival = associated(aNode%obssen ) .eqv. associated(aNode%tldepart) + if(equival) equival = associated(aNode%muse) + + ASSERT(equival) + +!-- ASSERT(lbound(aNode%muse ,1)==1.and.ubound(aNode%muse ,1)==miter+1) +!-- ASSERT(lbound(aNode%nldepart,1)==1.and.ubound(aNode%nldepart,1)==miter+1) +!-- ASSERT(lbound(aNode%tldepart,1)==1.and.ubound(aNode%tldepart,1)==miter ) +!-- ASSERT(lbound(aNode%obssen ,1)==1.and.ubound(aNode%obssen ,1)==miter ) + +return +end subroutine obsNode_check_ + +function obsNode_alloc_(miter) result(aNode_) + implicit none + type(_obsNode_), pointer :: aNode_ + integer(kind=i_kind), intent(in):: miter + + character(len=*),parameter:: myname_=myname//"::obsNode_alloc_" +_ENTRY_(myname_) + allocate(aNode_) + aNode_%next => null() + + allocate(aNode_%muse (miter+1), & + aNode_%nldepart(miter+1), & + aNode_%tldepart(miter ), & + aNode_%obssen (miter ) ) + + aNode_%luse = .false. + aNode_%elat = 0._r_kind + aNode_%elon = 0._r_kind + aNode_%idv =-1 + aNode_%iob =-1 + aNode_%ich =-1 + + aNode_%muse (:)= .false. + aNode_%nldepart(:)=-huge(0._r_kind) + aNode_%tldepart(:)= 0._r_kind + aNode_%wgtjo =-huge(0._r_kind) + aNode_%obssen (:)= 0._r_kind + + call obsNode_check_(myname_,aNode_) +_EXIT_(myname_) +return +end function obsNode_alloc_ + +subroutine obsNode_init_(anode,idv,iob,ich,elat,elon,luse,miter) + implicit none + type(_obsNode_),intent(inout):: anode + integer(kind=i_kind), intent(in):: idv,iob,ich + real (kind=r_kind), intent(in):: elat,elon + logical, intent(in):: luse + integer(kind=i_kind), intent(in):: miter + + character(len=*),parameter:: myname_=myname//"::obsNode_init_" +_ENTRY_(myname_) + + aNode%next => null() + anode%idv = idv + anode%iob = iob + anode%ich = ich + aNode%elat = elat + aNode%elon = elon + anode%luse = luse + + + + aNode%wgtjo =-huge(0._r_kind) + + allocate(aNode%muse (miter+1), & + aNode%nldepart(miter+1), & + aNode%tldepart(miter ), & + aNode%obssen (miter ) ) + + aNode%muse (:)= .false. + aNode%nldepart(:)=-huge(0._r_kind) + aNode%tldepart(:)= 0._r_kind + aNode%obssen (:)= 0._r_kind + + call obsNode_check_(myname_,aNode) +_EXIT_(myname_) +return +end subroutine obsNode_init_ + +subroutine anode_assert_(anode,idv,iob,ich,who,what) + implicit none + type(_obsNode_),intent(in):: anode + integer(kind=i_kind), intent(in):: idv,iob,ich + character(len=*),intent(in):: who + character(len=*),intent(in):: what + + character(len=*),parameter:: myname_=myname//"::anode_assert_" + logical:: valid + character(len=:),allocatable:: what_ +_ENTRY_(myname_) + valid = & + anode%idv == idv .and. & + anode%iob == iob .and. & + anode%ich == ich + + if(.not.valid) then + what_=repeat(" ",len(trim(what))) + call perr(who,trim(what)//", %(idv,iob,ich) =",(/anode%idv,anode%iob,anode%ich/)) + call perr(who, what_//" (idv,iob,ich) =",(/ idv, iob, ich/)) + call die(who) + endif + +_EXIT_(myname_) +return +end subroutine anode_assert_ + +subroutine obsNode_set_(anode, & + idv,iob,ich,elat,elon,luse,wgtjo, & + jiter,muse,nldepart,tldepart,obssen) + implicit none + type(_obsNode_),intent(inout):: anode + integer(kind=i_kind),optional,intent(in):: idv,iob,ich + real (kind=r_kind),optional,intent(in):: elat,elon + logical ,optional,intent(in):: luse + real (kind=r_kind),optional,intent(in):: wgtjo + + integer(kind=i_kind),optional,intent(in):: jiter + logical ,optional,intent(in):: muse + real (kind=r_kind),optional,intent(in):: nldepart + real (kind=r_kind),optional,intent(in):: tldepart + real (kind=r_kind),optional,intent(in):: obssen + + character(len=*),parameter:: myname_=myname//"::obsNode_set_" +_ENTRY_(myname_) + + if(present(idv )) aNode%idv =idv + if(present(iob )) aNode%iob =iob + if(present(ich )) aNode%ich =ich + if(present(elat)) aNode%elat=elat + if(present(elon)) aNode%elon=elon + if(present(luse)) aNode%luse=luse + + if(present(wgtjo )) aNode%wgtjo =wgtjo + + + if(present(jiter)) then + if(present(muse ).or.present(nldepart)) then + ASSERT(jiter>=lbound(anode%muse ,1)) + ASSERT(jiter<=ubound(anode%muse ,1)) + ASSERT(jiter>=lbound(anode%nldepart,1)) + ASSERT(jiter<=ubound(anode%nldepart,1)) + endif + if(present(obssen).or.present(tldepart)) then + ASSERT(jiter>=lbound(anode%obssen ,1)) + ASSERT(jiter<=ubound(anode%obssen ,1)) + ASSERT(jiter>=lbound(anode%tldepart,1)) + ASSERT(jiter<=ubound(anode%tldepart,1)) + endif + + if(present(muse )) aNode%muse (jiter) = muse + if(present(nldepart)) aNode%nldepart(jiter) = nldepart + if(present(tldepart)) aNode%tldepart(jiter) = tldepart + if(present(obssen )) aNode%obssen (jiter) = obssen + endif + + !call obsNode_check_(myname_,aNode_) +_EXIT_(myname_) +return +end subroutine obsNode_set_ + +subroutine obsNode_get_(anode, & + idv,iob,ich,elat,elon,luse,wgtjo, & + jiter,muse,nldepart,tldepart,obssen) + implicit none + type(_obsNode_),intent(inout):: anode + integer(kind=i_kind),optional,intent(out):: idv,iob,ich + real (kind=r_kind),optional,intent(out):: elat,elon + logical ,optional,intent(out):: luse + real (kind=r_kind),optional,intent(out):: wgtjo + + integer(kind=i_kind),optional,intent(in ):: jiter + logical ,optional,intent(out):: muse + real(kind=r_kind) ,optional,intent(out):: nldepart + real(kind=r_kind) ,optional,intent(out):: tldepart + real(kind=r_kind) ,optional,intent(out):: obssen + + character(len=*),parameter:: myname_=myname//"::obsNode_get_" +_ENTRY_(myname_) + + if(present(idv )) idv = aNode%idv + if(present(iob )) iob = aNode%iob + if(present(ich )) ich = aNode%ich + if(present(elat)) elat = aNode%elat + if(present(elon)) elon = aNode%elon + if(present(luse)) luse = aNode%luse + + if(present(wgtjo )) wgtjo = aNode%wgtjo + + if(present(jiter)) then + if(present(muse ).or.present(nldepart)) then + ASSERT(jiter>=lbound(anode%muse ,1)) + ASSERT(jiter<=ubound(anode%muse ,1)) + ASSERT(jiter>=lbound(anode%nldepart,1)) + ASSERT(jiter<=ubound(anode%nldepart,1)) + endif + if(present(obssen).or.present(tldepart)) then + ASSERT(jiter>=lbound(anode%obssen ,1)) + ASSERT(jiter<=ubound(anode%obssen ,1)) + ASSERT(jiter>=lbound(anode%tldepart,1)) + ASSERT(jiter<=ubound(anode%tldepart,1)) + endif + + if(present(muse )) muse = aNode%muse (jiter) + if(present(nldepart)) nldepart = aNode%nldepart(jiter) + if(present(tldepart)) tldepart = aNode%tldepart(jiter) + if(present(obssen )) obssen = aNode%obssen (jiter) + endif + + !call obsNode_check_(myname_,aNode_) +_EXIT_(myname_) +return +end subroutine obsNode_get_ + +subroutine obsNode_read_(aNode,iunit,kiter,istat,redistr) + implicit none + type(_obsNode_), intent(inout):: aNode + integer(kind=i_kind), intent(in ):: iunit + integer(kind=i_kind), intent(in ):: kiter ! input size + integer(kind=i_kind), intent(out ):: istat + logical , intent(in ):: redistr + + character(len=*),parameter:: myname_=myname//'::obsNode_read_' + integer(kind=i_kind):: ier + !real(kind=r_kind),dimension(1:kiter):: zobssen +_ENTRY_(myname_) + + istat=0 + read(iunit,iostat=ier) aNode%luse,aNode%elat,aNode%elon, & + aNode%idv ,aNode%iob ,aNode%ich + if(ier/=0) then + call perr(myname_,'read(%luse,%elat,%elon,...), iostat =',ier) + istat=-1 + _EXIT_(myname_) + return + endif + + istat=1 + if(redistr) then + istat=0 + if(aNode%luse) then + if(obsNode_islocal_(aNode)) istat=1 + endif + endif + + if(istat==0) then + read(iunit,iostat=ier) + if(ier/=0) then + call perr(myname_,'skipping read(%nchanl,%muse,...), iostat =',ier) + istat=-2 + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=ier) & + aNode%muse (1:kiter+1), & ! = lmuse(1:kiter) + aNode%nldepart(1:kiter+1), & ! = znldepart(1:kiter) + aNode%tldepart(1:kiter), & ! = ztldepart(1:kiter) + aNode%wgtjo, & ! = zwgtjo + aNode%obssen (1:kiter) ! = zobssen(1:kiter) + if(ier/=0) then + call perr(myname_,'read(%nchanl,%muse,...), iostat =',ier) + istat=-3 + _EXIT_(myname_) + return + endif + +! if (lobsensfc.and..not.lsensrecompute) then +! aNode%obssen(jiter+1:miter )=zobssen(jiter+1:miter ) +! elseif(lobserver) then +! aNode%obssen( 1:jiter-1)=zobssen( 1:jiter-1) +! else +! aNode%obssen( 1:miter )=zobssen( 1:miter ) +! endif + endif + + call obsNode_check_(myname_,aNode) +_EXIT_(myname_) +return +end subroutine obsNode_read_ + +subroutine obsNode_write_(aNode,iunit,jiter,istat) + implicit none + type(_obsNode_), intent(in ):: aNode + integer(kind=i_kind), intent(in ):: iunit + integer(kind=i_kind), intent(in ):: jiter ! the output size + integer(kind=i_kind), intent(inout):: istat + + character(len=*),parameter:: myname_=myname//'::obsNode_write_' +_ENTRY_(myname_) + + write(iunit,iostat=istat) aNode%luse,aNode%elat,aNode%elon, & + aNode%idv,aNode%iob,aNode%ich + if(istat/=0) then + call perr(myname_,'write(%luse,%elat,%elon,...), iostat =',istat) + _EXIT_(myname_) + return + endif + + write(iunit,iostat=istat) & + aNode%muse (1:jiter+1),& + aNode%nldepart(1:jiter+1),& + aNode%tldepart(1:jiter),& + aNode%wgtjo, & + aNode%obssen(1:jiter) + + if(istat/=0) then + call perr(myname_,'write(%nchanl,%muse,...), iostat =',istat) + _EXIT_(myname_) + return + endif + call obsNode_check_(myname_,aNode) +_EXIT_(myname_) +return +end subroutine obsNode_write_ + +subroutine obsNode_dealloc_(aNode,deep) + implicit none + type(_obsNode_),pointer,intent(inout):: aNode + logical,optional,intent(in):: deep + + character(len=*),parameter:: myname_=myname//'::obsNode_dealloc_' + logical:: deep_ +_ENTRY_(myname_) + call obsNode_check_(myname_,aNode) + + deep_=.false. + if(present(deep)) deep_=deep + ASSERT(associated(aNode)) + +! _TRACEV_(myname_,'if(deep_), deep_ =',deep_) + if(deep_) then +! _TRACEV_(myname_,'associated(aNode%nldepart) =',associated(aNode%nldepart)) + if(associated(aNode%nldepart)) deallocate(aNode%nldepart) +! _TRACEV_(myname_,'associated(aNode%tldepart) =',associated(aNode%tldepart)) + if(associated(aNode%tldepart)) deallocate(aNode%tldepart) +! _TRACEV_(myname_,'associated(aNode%obssen ) =',associated(aNode%obssen )) + if(associated(aNode%obssen )) deallocate(aNode%obssen ) +! _TRACEV_(myname_,'associated(aNode%muse ) =',associated(aNode%muse )) + if(associated(aNode%muse )) deallocate(aNode%muse ) + endif + ! This is NOT a recursive dealloc_(). Therefore, the associated target of + ! %next is not deallocated, but only %next itself is nullified. +! _TRACEV_(myname_,'associated(%next) =',associated(aNode%next)) + aNode%next => null() +! _TRACEV_(myname_,'associated(%next) =',associated(aNode%next)) + deallocate(aNode) +! _TRACEV_(myname_,'associated(aNode) =',associated(aNode)) +_EXIT_(myname_) +return +end subroutine obsNode_dealloc_ + +subroutine obsNode_show_(aNode,iob) + use mpeu_util, only: stdout + implicit none + type(_obsNode_),intent(in):: aNode + integer(kind=i_kind),intent(in):: iob + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_show_' +_ENTRY_(myname_) + write(stdout,'(2a,5i4,l4,2f8.2)') myname,":: iob,ity,%(idv,iob,ich,luse,elat,elon) =", & + iob,0,aNode%idv,aNode%iob,aNode%ich,aNode%luse,aNode%elat,aNode%elon + call obsNode_check_(myname_,aNode) +_EXIT_(myname_) +return +end subroutine obsNode_show_ + +end module m_obsdiagNode diff --git a/src/gsi/m_obsdiags.F90 b/src/gsi/m_obsdiags.F90 new file mode 100644 index 000000000..c95b998cd --- /dev/null +++ b/src/gsi/m_obsdiags.F90 @@ -0,0 +1,1436 @@ +module m_obsdiags +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_obsdiags +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2015-02-04 +! +! abstract: a bundle of GSI multiple obstypes and the obsdiags linked-lists +! +! program history log: +! 2015-02-04 j guo - Re-implemented read_obsdiags() and write_obsdiags(), +! to support reconfigurable observation operators. This +! implemenstation uses an obsLList template to support, +! in ceterian degree, static polymoprhism for different +! observation types. +! 2015-10-09 j guo - By using Fortran 2003 dynamic polymorphism, this +! version has removed many ugly type dispatching SELECT +! CASE constructs, by using an obsLList, a linked-list +! of dynamic polymorphic observation type (obsNode), +! which replaced the earlier obsLList template. +! 2016-06-22 j guo - Added latlonRange for selected file readings, to let +! []_mread() to skip unnecessary read() of some files +! containing no relevant observations. +! . Added obsdiags_alwaysLocal, as a user controlable +! switch to allow or to bypass selected file readings. +! . Added CHECK_SIZES_ outputs to allow size checkings. +! . Added #define SHOW_LLRANGE, for text-dumping of latlonRanges. +! . Added #define DEBUG_obsdiags, for text-dumping +! specific sections of obsdiags(:,:). +! . Locally renamed MPI_comm_world to gsi_comm_world. +! 2018-01-23 k apodaca - Add a new observation type i.e. lightning (light) +! suitable for the GOES/GLM instrument +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use kinds, only: i_kind, r_kind + use mpeu_util, only: tell,warn,perr,die + use mpeu_util, only: assert_ + use mpeu_util, only: stdout_open,stdout_close,stdout + use mpeu_mpif, only: gsi_comm_world => MPI_comm_world + + use gsi_obOper, only: obOper + + use m_obsLList, only: obsLList + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + + use gsi_obOperTypeManager, only: nobs_type => obOper_count + use gsi_4dvar , only: nobs_bins + + !use obsmod, only: obsdiags ! (nobs_type,nobs_bins) + implicit none + private ! except + + public:: obOpers_config + interface obOpers_config; module procedure config_; end interface + + ! obOper instance creater with initialization to objects corresponding + ! linked-list data instances. + public:: obOper_create + public:: obOper_headNode + public:: obOper_destroy + interface obOper_create; module procedure & + createbydtype_, & + createbyindex_, & + createbyvmold_ + end interface + interface obOper_headNode; module procedure headnode_; end interface + interface obOper_destroy ; module procedure destroy_ ; end interface + + public:: obsdiags_reset + public:: obsdiags_write + public:: obsdiags_read + public:: obsdiags_sort + + interface obsdiags_reset; module procedure reset_; end interface + interface obsdiags_write; module procedure write_; end interface + interface obsdiags_read ; module procedure mread_; end interface + interface obsdiags_sort ; module procedure lsort_; end interface + + public:: obsdiags_create + public:: obsdiags_destroy + public:: obsdiags_inquire + interface obsdiags_create ; module procedure create_obsmod_vars; end interface + interface obsdiags_destroy; module procedure destroy_obsmod_vars; end interface + interface obsdiags_inquire; module procedure inquire_obsdiags ; end interface + + public:: obsdiags_summary + + interface obsdiags_summary ; module procedure summary_ ; end interface + + public:: obsdiags_alwaysLocal + logical,save:: obsdiags_alwaysLocal = .false. + +! Note: User configurables +! +! (1) obsdiags_mread(..,mPEs,..) via /SETUP/:mPEs_observer: +! +! mPEs==0, for reading "my own data"; +! mPEs=>0, reading "all data", from PE 0 to mPEs-1, but only up to the +! highest count of the actually accessible files. +! +! This value is configured through gsimod namelist/SETUP/:mPEs_observer, +! with the default value set to 0, to behave as it was ("my own data"). +! Otherwise, a simple usage is to let mPEs_observer=1024, or other large +! enough value, such that the solver-mode will try to determine how many +! files created by the observer-mode are actually there to read. +! +! (2) obsdiags_alwaysLocal via /SETUP/:alwaysLocal: +! +! obsdiags_alwaysLocal sets an alternative default value of the optional +! argument of obsdiags_mread(..,alwaysLocal). +! +! obsdiags_alwaysLocal==.false., its default value. +! It let obsdiags_mread() to check the locality of a file first, +! using latlonRange_islocal(iPE), to avoid unnecessary opening+ +! reading some files. +! obsdiags_alwaysLocal==.true., override latlonRange_islocal(iPE). +! It let obsdiags_mread() to always open+read all file. + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='m_obsdiags' + logical,save:: lobsdiags_allocated_ = .false. + logical,save:: lobstypes_allocated_ = .false. + + logical,parameter:: All_PEs =.false. ! report status on all PEs or root only + !logical,parameter:: All_PEs =.true. ! report status on all PEs or root only + logical,parameter:: DO_SUMMARY =.false. ! report status on all PEs or root only + !logical,parameter:: DO_SUMMARY =.true. ! report status on all PEs or root only + + ! SYNCH_MESSAGES is a flag to invoke MPI_Barrier() calls before some + ! status messages. These calls are otherwise not necessary for the + ! functionalities, but used here to ensure those messages mean what they + ! intent to mean, in case that only the root PE is used to report some + ! all PE status. + + !logical,parameter:: SYNCH_MESSAGES = .true. ! turn synch on + !logical,parameter:: SYNCH_MESSAGES = .not. All_PEs ! conditionally turn on + logical,parameter:: SYNCH_MESSAGES = .false. ! turn synch off + + public :: obsdiags + public :: obsLLists + + type(obsLList ),save,dimension(:,:),pointer :: obsLLists => null() + type(obs_diags),save,dimension(:,:),pointer :: obsdiags => null() ! (nobs_type,nobs_bins) + + integer(i_kind),save:: jfunc__jiter = -1 + integer(i_kind),save:: jfunc__miter = -1 + integer(i_kind),save:: jfunc__jiterstart = -1 + + integer(i_kind),save:: gsi_4dvar__nobs_bins = -1 + integer(i_kind),save:: gsi_4dvar__min_offset = -1 + real (r_kind),save:: gsi_4dvar__hr_obsbin = -999._r_kind + +!#define DEBUG_TRACE +!#define DEBUG_VERBOSE +#include "mytrace.H" +#include "myassert.H" + +#define _TIMER_ON_ +#ifdef _TIMER_ON_ +#undef _TIMER_ON_ +#undef _TIMER_OFF_ +#undef _TIMER_USE_ +#define _TIMER_ON_(id) call timer_ini(id) +#define _TIMER_OFF_(id) call timer_fnl(id) +#define _TIMER_USE_ use timermod, only: timer_ini,timer_fnl +#else +#define _TIMER_ON_(id) +#define _TIMER_OFF_(id) +#define _TIMER_USE_ +#endif + + logical,parameter:: CHECK_SIZES_=.false. + !logical,parameter:: CHECK_SIZES_=.true. + + !-- if(CHECK_SIZES_) then + !-- these size counters, + + integer(i_kind),allocatable,dimension(:),save:: lsize_type ! luse counts of ob_type + integer(i_kind),allocatable,dimension(:),save:: nsize_type ! total counts of ob_type + integer(i_kind),allocatable,dimension(:),save:: lsize_diag ! luse counts of obs_diags + integer(i_kind),allocatable,dimension(:),save:: msize_diag ! muse counts of obs_diags + integer(i_kind),allocatable,dimension(:),save:: nsize_diag ! total counts of obs_diags + + !-- will be used to generate extra log-information, reporting different + !-- size-counts of linked-lists, of all j-type, i-bin, on all PEs. Search + !-- "CHECK_SIZES_" here for details. + !-- endif + +contains + +subroutine config_() +!> Coupling external configurations (through external modules) to obOpers' own +!> module configurations + implicit none + +!> For all obOpers, import external configurations + call jfunc__import_() + call gsi_4dvar__import_() + +!> For specific obOpers, import specific configurations + call lwcpOper__config_() + +return +contains +subroutine jfunc__import_() + !> jfunc parameters imported + use jfunc, only: jiter + use jfunc, only: miter + use jfunc, only: jiterstart + implicit none + jfunc__jiter = jiter + jfunc__miter = miter + jfunc__jiterstart = jiterstart + return + end subroutine jfunc__import_ +subroutine gsi_4dvar__import_() + !> gsi4dvar parameters imported + use gsi_4dvar, only: nobs_bins + use gsi_4dvar, only: min_offset + use gsi_4dvar, only: hr_obsbin + implicit none + gsi_4dvar__nobs_bins = nobs_bins + gsi_4dvar__min_offset = min_offset + gsi_4dvar__hr_obsbin = hr_obsbin + return + end subroutine gsi_4dvar__import_ +subroutine lwcpOper__config_() + !> gsi_lwcpOper parameters for configuration + !> gfs_stratosphere imports + use gfs_stratosphere, only: use_gfs_stratosphere + use gfs_stratosphere, only: nsig_save + !> lwcpOper + use gsi_lwcpOper , only: lwcpOper_config + implicit none + + call lwcpOper_config() ! reset to default + !> From gfs_stratosphere to gsi_lwcpOper, and expected to be refactored into an attribute of profile-vectors objects) + if(use_gfs_stratosphere) call lwcpOper_config(nsig_save=nsig_save) + return + end subroutine lwcpOper__config_ +end subroutine config_ + +function createbydtype_(dtype) result(self) +!>> create an obOper to its components instanciated in this data module, with +!>> a given obOper registered dtype + use gsi_obOperTypeManager, only: obOper_typeMold ! (dtype) + implicit none + class(obOper),pointer:: self + character(len=*),intent(in):: dtype + character(len=*),parameter:: myname_=myname//"::createbydtype_" + + self => createbyvmold_(obOper_typeMold(dtype)) + +#ifdef DEBUG_VERBOSE +! show status of the object for debugging + call tell(myname_,'--- argument dtype =',trim(dtype)) + call tell(myname_,'associated(return) =',associated(self)) + !if(associated(self)) call obOper_show_(myname_,self) +#endif +end function createbydtype_ + +function createbyindex_(ioper) result(self) +!>> create an obOper to its components instanciated in this data module, with +!>> a given obOper registered index. + use gsi_obOperTypeManager, only: obOper_typeMold ! (ioper) + use gsi_obOperTypeManager, only: obOper_lbound + use gsi_obOperTypeManager, only: obOper_ubound + implicit none + class(obOper),pointer:: self + integer(kind=i_kind),intent(in):: ioper + + character(len=*),parameter:: myname_=myname//"::createbyindex_" + class(obOper),pointer:: mold_ + + mold_ => obOper_typeMold(ioper) + if(associated(mold_)) then + allocate(self,mold=mold_) + + if(ioperubound(obsLLists,1)) then + call perr(myname_,'unexpected value, ioper =',ioper) + call perr(myname_,' lbound(obsLLists,1) =',lbound(obsLLists,1)) + call perr(myname_,' ubound(obsLLists,1) =',ubound(obsLLists,1)) + call perr(myname_,' %mytype() =',self%mytype()) + call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) + call die(myname_) + endif + if(ioperubound( obsdiags,1)) then + call perr(myname_,'unexpected value, ioper =',ioper) + call perr(myname_,' lbound( obsdiags,1) =',lbound( obsdiags,1)) + call perr(myname_,' ubound( obsdiags,1) =',ubound( obsdiags,1)) + call perr(myname_,' %mytype() =',self%mytype()) + call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) + call die(myname_) + endif + + call self%init(obsLLists(ioper,:), & + obsdiags(ioper,:) ) + mold_ => null() + + else + call perr(myname_,'.not.associated, ioper =',ioper) + call die(myname_) + endif + +#ifdef DEBUG_VERBOSE +!>> show status of the object for debugging + call tell(myname_,'--- argument ioper =',ioper) + call tell(myname_,'associated(return) =',associated(self)) + !if(associated(self)) call obOper_show_(myname_,self) +#endif +end function createbyindex_ + +function createbyvmold_(mold) result(self) +!>> initialize an obOper to its components (linked-lists) + use gsi_obOperTypeManager, only: obOper_typeIndex ! to type-index + use gsi_obOperTypeManager, only: obOper_typeIndex ! to type-index + implicit none + class(obOper),pointer:: self + class(obOper),target,intent(in):: mold + + character(len=*),parameter:: myname_=myname//"::createbyvmold_" + integer(kind=i_kind):: itype ! for a registered obsNode type index + + self => mold + if(associated(self)) then + allocate(self,mold=mold) + + ! Get its corresponding obsNode type name, then convert to its type-index + itype=obOper_typeIndex(self) + + if(itypeubound(obsLLists,1)) then + call perr(myname_,'unexpected value, itype =',itype) + call perr(myname_,' lbound(obsLLists,1) =',lbound(obsLLists,1)) + call perr(myname_,' ubound(obsLLists,1) =',ubound(obsLLists,1)) + call perr(myname_,' %mytype() =',self%mytype()) + call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) + call die(myname_) + endif + if(itypeubound( obsdiags,1)) then + call perr(myname_,'unexpected value, itype =',itype) + call perr(myname_,' lbound( obsdiags,1) =',lbound( obsdiags,1)) + call perr(myname_,' ubound( obsdiags,1) =',ubound( obsdiags,1)) + call perr(myname_,' %mytype() =',self%mytype()) + call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) + call die(myname_) + endif + + call self%init(obsLLists(itype,:), & + obsdiags(itype,:) ) + endif + +#ifdef DEBUG_VERBOSE +! show status of the object for debugging + call tell(myname_,'--- argument mold%mytype() =',mold%mytype()) + call tell(myname_,' mold%mytype(nodetype) =',mold%mytype(nodetype=.true.)) + call tell(myname_,' associated(return) =',associated(self)) + if(associated(self)) call obOper_show_(myname_,self) +#endif +end function createbyvmold_ + +subroutine oboper_show_(mname,self) + use gsi_obOper, only: obOper + use gsi_obOperTypeManager, only: obOper_typeIndex + use gsi_obOperTypeManager, only: obOper_typeInfo + use m_obsNodeTypeManager , only: obsNode_typeIndex ! to type-index + use mpeu_util, only: tell + implicit none + character(len=*),intent(in):: mname + class(obOper),target,intent(in):: self + + call tell(mname,' obOper_typeIndex(%) =',obOper_typeIndex(self)) + call tell(mname,' obOper_typeInfo(%) =',obOper_typeInfo(self)) + call tell(mname,' associated(%obsLL) =',associated(self%obsLL)) + call tell(mname,'associated(%odiagLL) =',associated(self%odiagLL)) + call tell(mname,' self%nodetype() =', self%mytype(nodetype=.true.)) +end subroutine obOper_show_ + +subroutine destroy_(self) + implicit none + class(obOper),pointer,intent(inout):: self + if(associated(self)) then + call self%clean() + deallocate(self) + endif +end subroutine destroy_ + +function headNode_(iobOper,ibin) result(anode) +!>> Example: -- get the head node of an obOper%obsLL(ibin) +!>> psptr => psNode_typecast(headNode(iobOper_ps)) + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use gsi_obOper, only: obOper + implicit none + integer(kind=i_kind),intent(in):: iobOper + integer(kind=i_kind),intent(in):: ibin + class(obsNode),pointer:: anode + + character(len=*),parameter:: myname_=myname//"::headNode_" + class(obOper),pointer:: obOper_ + + obOper_ => createbyindex_(iobOper) + if(.not.associated(obOper_)) then + call perr(myname_,'createbuindex_(), associated(obOper_) =',associated(obOper_)) + call perr(myname_,' ioper =',iobOper) + call perr(myname_,' ibin =',ibin) + call die(myname_) + endif + + anode => obsLList_headNode(obOper_%obsLL(ibin)) + call destroy_(obOper_) +end function headNode_ + +subroutine lobsdiags_statusCheck_(who,allocated) +!-- check the allocation status of basic obsdiags components. + use obsmod, only: luse_obsdiag + implicit none + character(len=*),intent(in):: who + logical,intent(in):: allocated + + if(.not.luse_obsdiag) return + if(allocated) then + if( .not.lobsdiags_allocated_ .or. & + .not.lobstypes_allocated_ ) then + if(.not.lobsdiags_allocated_) call perr(who,'.not.lobsdiags_allocated_') + if(.not.lobstypes_allocated_) call perr(who,'.not.lobstypes_allocated_') + call die(who) + endif + + else + if( lobsdiags_allocated_ .or. & + lobstypes_allocated_ ) then + if(lobsdiags_allocated_) call perr(who,'lobsdiags_allocated_ already') + if(lobstypes_allocated_) call perr(who,'lobstypes_allocated_ already') + call die(who) + endif + endif +end subroutine lobsdiags_statusCheck_ + +subroutine mread_(cdfile,mPEs,force,jiter_expected,alwaysLocal) +!$$$ subprogram documentation block +! . . . . +! subprogram: m_obdiags::mread_ +! prgmmr: tremolet +! +! abstract: Read obsdiags data structure from file. +! +! program history log: +! 2007-07-05 tremolet +! 2007-08-04 todling - using get_lun to determine file unit number +! 2007-10-03 todling - expanded to account for full observer +! 2009-01-08 todling - remove reference to ozohead +! 2009-01-23 todling - add read_gpshead +! 2009-04-02 meunier - add read_laghead +! 2010-04-27 tangborn - addded read_colvkhead +! 2010-05-26 treadon - add read_tcphead +! 2011-05-18 todling - aero, aerol, and pm2_5 +! 2011-09-20 hclin - 1d wij for aero +! 2015-02-04 j guo - Re-implemented to support re-configurable observation +! operators. read_() is split to read_() for a single +! file, and mread_() for one file only or all files for +! redistribution +! 2015-10-09 j guo - Now it uses Fortran 2003 dynamic polymorphism. +! +! input argument list: +! cdfile - filename to read data from +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpeu_util, only: tell,perr,die,stdout_open,stdout_close,stdout + _TIMER_USE_ + use kinds, only: r_kind,i_kind + + use obsmod, only: lobserver + use mpimod, only: myPE + use m_latlonRange, only: latlonRange + use m_latlonRange, only: latlonRange_reset + use m_latlonRange, only: latlonRange_islocal + use m_latlonRange, only: latlonRange_readBcast + use m_latlonRange, only: latlonRange_allDump + + use m_obsdiagNode, only: obsdiagLList_dump + implicit none + character(len=*), intent(in) :: cdfile ! prefix, "obsdiags." + integer(i_kind),optional,intent(in):: mPEs ! number of files, from 0 to mPEs-1 + logical ,optional,intent(in):: force ! force to read ob_types, regardless l4dvar etc. + integer(i_kind),optional,intent(in):: jiter_expected ! expected input jiter + logical ,optional,intent(in):: alwaysLocal ! read all files + +! ---------------------------------------------------------- + character(len=*),parameter:: myname_=myname//"::mread_" + logical:: redistr,exist_ + integer(i_kind):: lPE,uPE,iPE,ier + integer(i_kind):: jtyp,jread + logical:: force_read + logical:: alwaysLocal_ + logical:: fileislocal + type(latlonRange),allocatable,dimension(:):: allRanges +_ENTRY_(myname_) +_TIMER_ON_(myname_) +!call stdout_open("obsdiags_mread") + force_read=.false. + if(present(force)) force_read=force + alwaysLocal_=obsdiags_alwaysLocal + if(present(alwaysLocal)) alwaysLocal_=alwaysLocal + + call lobsdiags_statusCheck_(myname_,allocated=.true.) + + ! Determine the configuration, either read-my-own-data-only, or + ! try-to-read-all-data-available. + + lPE=myPE + uPE=lPE + redistr=.false. + if(present(mPEs)) then + if(mPEs>0) then + redistr=.true. + lPE=0 + uPE=-1 + do iPE=lPE,mPEs-1 + inquire(file=trim(filename_(cdfile,iPE)), exist=exist_) + if(exist_) uPE=iPE + enddo + endif + endif + + ! Reset components of obsdiags, for their re-construction from files + call reset_() + + if(CHECK_SIZES_) then + allocate(lsize_type(nobs_type)) + allocate(nsize_type(nobs_type)) + allocate(lsize_diag(nobs_type)) + allocate(nsize_diag(nobs_type)) + allocate(msize_diag(nobs_type)) + + lsize_type(:)=0 + nsize_type(:)=0 + lsize_diag(:)=0 + nsize_diag(:)=0 + msize_diag(:)=0 + endif + + ! MPI_Barrier() calls are not necessary. They are used here to ensure + ! the log-messages mean what they really mean, if only the root is used to + ! report the all-PE status. + + if(SYNCH_MESSAGES) call MPI_Barrier(gsi_comm_world,ier) + + if(redistr) then + if(mype==0) then + call tell(myname_,'Reading obsdiags files for redistribution, nPEs =',uPE-lPE+1) + call tell(myname_,' prefix of the files, cdfile =',trim(cdfile)) + call tell(myname_,' lPE =',lPE) + call tell(myname_,' uPE =',uPE) + call tell(myname_,' alwaysLocal =',alwaysLocal_) + endif + + allocate(allRanges(0:uPE)) + call latlonRange_reset(allRanges) + call latlonRange_readBcast(hdfilename_(cdfile),allRanges,root=0,comm=gsi_comm_world) + +!#define SHOW_LLRANGE +#ifdef SHOW_LLRANGE + call latlonRange_alldump(allRanges,"obsLLRange") +#endif + + + jread=-1 ! checker of the input jiter values + do iPE=lPE,uPE + fileislocal=latlonRange_islocal(allRanges(iPE)) + if(alwaysLocal_.or.fileislocal) then + call read_(cdfile,iPE,redistr,fileislocal=fileislocal, & + force=force, & + jiter_expected=jiter_expected, & + verbose=.not.alwaysLocal_.or.myPE==0, & + jread=jread) + endif + enddo + +!#define DEBUG_obsdiags +#ifdef DEBUG_obsdiags + ! This is an example of dumping information for debugging, on selected + ! PEs, for specific jtyp and ibin. + ! + ! This example is on PE #1, for (jtype==3 .and. ibin==3). + + if(myPE==1) then + call tell(myname_) + call tell(myname_,'dumping obsdiags(), jtyp =',3) + call tell(myname_,' ibin =',3) + call tell(myname_,' jread =',jread) + call obsdiagLList_dump(obsdiags(3,3),jiter=jread) + endif +#endif + + ! Sort to ensure the ordering is unique. + call lsort_() + + call latlonRange_reset(allRanges) + deallocate(allRanges) + + else ! of if(redistr) + call read_(cdfile,myPE,redistr,fileislocal=.true., & + force=force, & + jiter_expected=jiter_expected, & + verbose=.true.) + + endif ! of if(redistr) + + if(myPE==0) then + call tell(myname_,'Finished reading of all obsdiags files, nPEs =',uPE-lPE+1) + endif + + if(CHECK_SIZES_) then + do jtyp=lbound(lsize_type,1),ubound(lsize_type,1) + if( msize_diag(jtyp)>0.or.lsize_diag(jtyp)>0.or.nsize_diag(jtyp)>0 .or. & + lsize_type(jtyp)>0.or.nsize_type(jtyp)>0 ) then + write(stdout,'(i5.3,i5,7x,5i8,2x,l1)') myPE,jtyp ,lsize_type(jtyp),nsize_type(jtyp), & + msize_diag(jtyp),lsize_diag(jtyp),nsize_diag(jtyp) + endif + enddo + + call iMPI_reduceSUM_(lsize_type,root=0,comm=gsi_comm_world) + call iMPI_reduceSUM_(nsize_type,root=0,comm=gsi_comm_world) + call iMPI_reduceSUM_(lsize_diag,root=0,comm=gsi_comm_world) + call iMPI_reduceSUM_(nsize_diag,root=0,comm=gsi_comm_world) + call iMPI_reduceSUM_(msize_diag,root=0,comm=gsi_comm_world) + + if(myPE==0) then + do jtyp=lbound(lsize_type,1),ubound(lsize_type,1) + if( msize_diag(jtyp)>0.or.lsize_diag(jtyp)>0.or.nsize_diag(jtyp)>0 .or. & + lsize_type(jtyp)>0.or.nsize_type(jtyp)>0 ) then + write(stdout,'(2x,a,i5,7x,5i8,2x,l1)') '***',jtyp ,lsize_type(jtyp),nsize_type(jtyp), & + msize_diag(jtyp),lsize_diag(jtyp),nsize_diag(jtyp) + endif + enddo + endif + + deallocate(lsize_type) + deallocate(nsize_type) + deallocate(lsize_diag) + deallocate(nsize_diag) + deallocate(msize_diag) + endif + + if(SYNCH_MESSAGES) call MPI_Barrier(gsi_comm_world,ier) + if(DO_SUMMARY) call summary_(myname_) + + if(lobserver) then + if(.not.force_read) then + !call destroyobs( skipit=.true.) + call reset_(obsdiags_keep=.true.) + endif + endif +!call stdout_close() +_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine mread_ + +subroutine reset_(obsdiags_keep) + !use obsmod, only: obsdiags + use obsmod, only: luse_obsdiag + use obsmod, only: lobsdiag_allocated + + use m_obsdiagNode, only: obsdiagLList_reset + use m_obsdiagNode, only: obsdiagLList_rewind + use m_obsLList, only: obsLList_reset + use m_obsNode , only: obsNode + use gsi_obOperTypeManager, only: obOper_typeMold + use gsi_obOperTypeManager, only: obOper_lbound + use gsi_obOperTypeManager, only: obOper_ubound + use m_obsNodeTypeManager , only: obsNode_typeMold + + _TIMER_USE_ + implicit none + logical,optional,intent(in):: obsdiags_keep + character(len=*),parameter:: myname_=myname//'::reset_' + integer(i_kind):: ii,jj + logical:: obsdiags_keep_ + integer(i_kind):: ier + class(obsNode),pointer:: mNode_ + class(obOper ),pointer:: mOper_ +_ENTRY_(myname_) +_TIMER_ON_(myname_) + +_TRACEV_(myname_,'lobsdiag_allocated =',lobsdiag_allocated) +_TRACEV_(myname_,'lobsdiags_allocated_ =',lobsdiags_allocated_) + + ASSERT(nobs_type>0) + ASSERT(nobs_bins>0) + + ! Both objects, obsdiags and obsLLists are checked for their associated sizes + ! and allocated shapes, regardless luse_obsdiag or not. This is to simplify + ! the algorithm logic. The enforcements of (luse_obsdiag) are done on lower + ! levels only. + + if(.not.lobstypes_allocated_) then + lobstypes_allocated_=.true. + if(.not.associated(obsLLists)) call die(myname_,'unexpectedly, .not.associated(obsLLists)') + endif + + if(.not.lobsdiags_allocated_) then + lobsdiags_allocated_=.true. + if(.not.associated(obsdiags )) call die(myname_,'unexpectedly, .not.associated(obsdiags)') + endif + + ASSERT(all(shape(obsdiags )==shape(obsLLists ))) + ASSERT( size(obsdiags,1)== size(obsLLists,1) ) + ASSERT( size(obsdiags,2)== size(obsLLists,2) ) + + obsdiags_keep_=.false. + if(present(obsdiags_keep)) obsdiags_keep_=obsdiags_keep + + do ii=1,size(obsLLists,2) ! nobs_bins + do jj=1,size(obsLLists,1) ! nobs_type + if(luse_obsdiag) then + if(.not.obsdiags_keep_) then + call obsdiagLList_reset(obsdiags(jj,ii)) + lobsdiag_allocated=.false. + + else + call obsdiagLList_rewind(obsdiags(jj,ii)) + + ! In cases of rewinding without resetting, an obsdiagLList can + ! be either initialized (lobsdiag_allocated), or not initialized + ! (.not.lobsdiag_allocated). So the code here should not try + ! to alter the value of lobsdiag_allocated. + endif + endif + +!++++ + mOper_ => obOper_typeMold(jj) + if(.not.associated(mOper_)) then + call perr(myname_,'obOper_typeMold(j) not associated, j =',jj) + call perr(myname_,' obOper_lbound =',obOper_lbound) + call perr(myname_,' obOper_ubound =',obOper_ubound) + call die(myname_) + endif + + mNode_ => mOper_%nodeMold() + if(.not.associated(mNode_)) then + call perr(myname_,'mOper_%nodeMold() not associated, j =',jj) + call perr(myname_,' mOper_%mytype() =',mOper_%mytype()) + call die(myname_) + endif + + mOper_ => null() + +!++++ + + call obsLList_reset(obsLLists(jj,ii),mold=mNode_, stat=ier) + if(ier/=0) then + call perr(myname_,'call obsLList_reset(), stat =',ier) + call perr(myname_,' ibin =',ii) + call perr(myname_,' jtype =',jj) + call perr(myname_,' mold%mytype() =',mNode_%mytype()) + call die(myname_) + endif + + mNode_ => null() + enddo + enddo +_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine reset_ + +subroutine lsort_() +!$$$ subprogram documentation block +! +! abstract: sort entries of obsdiags(:,:) and obsLLists(:,:) +! +! program history log: +! +! input argument list: +! +!$$$ + + use gsi_unformatted, only: unformatted_open + use obsmod, only: luse_obsdiag + + use m_obsLList, only: obsLList_lsort + use m_obsdiagNode, only: obsdiagLList_lsize + use m_obsdiagNode, only: obsdiagLList_lsort + + _TIMER_USE_ + implicit none + + character(len=*), parameter :: myname_=myname//"::lsort_" + + integer(i_kind) :: ii,jj !,iobs,lobs,ierr +_ENTRY_(myname_) +_TIMER_ON_(myname_) +! ---------------------------------------------------------- + call lobsdiags_statusCheck_(myname_,allocated=.true.) + + if (luse_obsdiag) then + + ASSERT(all(shape(obsdiags)==shape(obsLLists))) + ASSERT(size(obsdiags,1)==size(obsLLists,1)) + ASSERT(size(obsdiags,2)==size(obsLLists,2)) + + endif + + do jj=1,size(obsdiags,1) + do ii=1,size(obsdiags,2) + call obsdiagLList_lsort(obsdiags(jj,ii),itype=jj,ibin=ii) + enddo + enddo + + do jj=1,size(obsLLists,1) + do ii=1,size(obsLLists,2) + call obsLList_lsort(obsLLists(jj,ii),itype=jj,ibin=ii) + enddo + enddo + +! ---------------------------------------------------------- +_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine lsort_ + +subroutine write_(cdfile,luseonly,force) +!$$$ subprogram documentation block +! +! abstract: Write obsdiags data structure to file. +! +! program history log: +! 2007-07-05 tremolet +! 2007-10-03 todling - expanded to account for full observer +! 2007-10-24 todling - add parameter nchnperobs to obsdiag +! 2009-01-08 todling - remove reference to ozohead +! 2009-01-27 todling - add gps write +! 2010-05-26 treadon - add write_tcphead +! 2010-06-03 todling - add write_colvkhead +! 2011-05-18 todling - aero, aerol, and pm2_5 +! 2015-02-04 j guo - Re-implemented to support re-configurable observation +! operators. +! 2015-10-09 j guo - Now it uses Fortran 2003 dynamic polymorphism. +! +! input argument list: +! cdfile - filename to write data +! +!$$$ + +use mpeu_util, only: tell,die,perr,stdout_open,stdout_close +_TIMER_USE_ + + use gsi_unformatted, only: unformatted_open + use mpimod, only: mype + use gsi_4dvar, only: l4dvar + use jfunc, only: jiter, miter + + use m_obsLList, only: obsLList_write + use m_obsdiagNode, only: obsdiagLList_lsize + use m_obsdiagNode, only: obsdiagLList_write + + use m_latlonRange, only: latlonRange + use m_latlonRange, only: latlonRange_reset + use m_latlonRange, only: latlonRange_gatherWrite + use m_latlonRange, only: latlonRange_gatherDump + + implicit none + character(len=*), intent(in) :: cdfile ! := "obsdiags." + logical,optional, intent(in) :: luseonly ! output only if(%luse) + logical,optional, intent(in) :: force ! write all out regardlessly + + character(len=*), parameter :: myname_=myname//"::write_" + +integer(i_kind) :: iunit,istat +integer(i_kind) :: ii,jj,ier +logical :: luseonly_ +logical :: force_write +type(latlonRange):: luseRange +! ---------------------------------------------------------- +_ENTRY_(myname_) +_TIMER_ON_(myname_) +!call stdout_open("obsdiags_write") + force_write=.false. + if(present(force)) force_write=force + call lobsdiags_statusCheck_(myname_,allocated=.true.) + + ASSERT(all(shape(obsdiags)==shape(obsLLists))) + ASSERT(size(obsdiags,1)==size(obsLLists,1)) + ASSERT(size(obsdiags,2)==size(obsLLists,2)) + + luseonly_=.false. + if(present(luseonly)) luseonly_=luseonly + + call unformatted_open( unit=iunit, & + file=trim(filename_(cdfile,myPE)), & + class='.obsdiags.', & + action='write', & + status='unknown', & + newunit=.true., & ! with newunit=.true., unit returns a value assigned by Fortran. + iostat=istat,silent=.true.) + if(istat/=0) then + call perr(myname_,'unformatted_open(), file =',filename_(cdfile,myPE)) + call perr(myname_,' newunit =',iunit) + call perr(myname_,' iostat =',istat) + call die(myname_) + endif + + if(DO_SUMMARY) call summary_(myname_) + + do ii=1,size(obsdiags,2) + do jj=1,size(obsdiags,1) + call obsdiagLList_write(obsdiags(jj,ii),iunit,luseonly_,jiter,miter,jj,ii,luseRange=luseRange) + + if (force_write .or. l4dvar) then + call obsLList_write(obsLLists(jj,ii),iunit,luseonly_,jj,luseRange=luseRange) + endif + + write(iunit)ii,jj ! a jj_obstype-block trailer + enddo + enddo + + close(iunit) + + ! latlonRange_gatherWrite() implies a mpi_barrier() action. + call latlonRange_gatherWrite(luseRange,hdfilename_(cdfile),root=0,comm=gsi_comm_world) + +#ifdef SHOW_LLRANGE + ! Text-dump to diagnose the values + call latlonRange_gatherDump( "cvgLLRange",root=0,comm=gsi_comm_world) + call latlonRange_gatherDump(luseRange,"obsLLRange",root=0,comm=gsi_comm_world) +#endif + + call latlonRange_reset(luseRange) + + if(SYNCH_MESSAGES) call MPI_Barrier(gsi_comm_world,ier) + if (mype==0) call tell(myname_,'Finish writing obsdiags to file ',filename_(cdfile,myPE)) + +! ---------------------------------------------------------- +!call stdout_close() +_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine write_ + +subroutine read_(cdfile,iPE,redistr,fileislocal,force,jiter_expected,verbose,jread) + use mpeu_util, only: tell,perr,die + use mpeu_util, only: stdout + use mpimod, only: mype + use gsi_4dvar, only: l4dvar + use gsi_unformatted, only: unformatted_open + use jfunc, only: jiter,miter + _TIMER_USE_ + + use obsmod, only: lobserver + + use m_obsLList, only: obsLList_read + use m_obsLList, only: obsLList_lsize + use m_obsLList, only: obsLList_lcount + + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obsdiagLList_read + use m_obsdiagNode, only: obsdiagLList_lsize + use m_obsdiagNode, only: obsdiagLList_lcount + use m_obsdiagNode, only: obsdiagLookup_build + use m_obsdiagNode, only: obsdiagLookup_clean + + implicit none + character(len=*), intent(in ):: cdfile ! prefix of the input file + integer(i_kind ), intent(in ):: iPE ! iPE of the input file + logical , intent(in ):: redistr ! data redistribution is expected + logical , intent(in ):: fileislocal ! the file to read, is known local + + logical,optional, intent(in ):: force ! (force to read ob_type data + integer(i_kind ), optional, intent(in ):: jiter_expected ! expecte input jiter + logical,optional, intent(in ):: verbose ! report each reading + integer(i_kind ), optional, intent(inout):: jread ! jiter read from the input + + character(len=*),parameter:: myname_=myname//'::read_' + character(len=*),parameter:: diag_timer_=myname_//'.obsdiagLList_read' + character(len=*),parameter:: list_timer_=myname_//'.obsLList_read' + integer(i_kind):: ii,jj + integer(i_kind):: ki,kj + integer(i_kind):: iunit,istat + integer(i_kind):: jread_ + integer(i_kind):: lsize_type_,nsize_type_ + integer(i_kind):: lsize_diag_,nsize_diag_,msize_diag_ + type(obs_diag),pointer:: leadNode => NULL() + logical:: force_read + logical:: verbose_ +_ENTRY_(myname_) +_TIMER_ON_(myname_) + + call lobsdiags_statusCheck_(myname_,allocated=.true.) + force_read=.false. + if(present(force)) force_read=force + + verbose_=.false. + if(present(verbose)) verbose_=verbose + + ASSERT(all(shape(obsdiags)==shape(obsLLists))) + ASSERT(size(obsdiags,1)==size(obsLLists,1)) + ASSERT(size(obsdiags,2)==size(obsLLists,2)) + if(CHECK_SIZES_) then + ASSERT(size(obsdiags,1)==size(lsize_type )) + ASSERT(size(obsdiags,1)==size(nsize_type )) + ASSERT(size(obsdiags,1)==size(lsize_diag )) + ASSERT(size(obsdiags,1)==size(nsize_diag )) + endif + + call unformatted_open( unit=iunit, & + file=trim(filename_(cdfile,iPE)), & + class='.obsdiags.', & + action='read', & + status='old', & + newunit=.true., & ! with newunit=.true., unit returns a value assigned by Fortran. + iostat=istat,silent=.true.) + if(istat/=0) then + call perr(myname_,'unformatted_open(), file =',trim(filename_(cdfile,iPE))) + call perr(myname_,' myPE =',myPE) + call perr(myname_,' iPE =',iPE) + call perr(myname_,' miter =',miter) + call perr(myname_,' redistr =',redistr) + call perr(myname_,' newunit =',iunit) + call perr(myname_,' iostat =',istat) + call die(myname_) + endif + + if(verbose_) call tell(myname_,'Reading obsdiags, file =',trim(filename_(cdfile,iPE))) + + leadNode => null() + do ii=1,size(obsdiags,2) + do jj=1,size(obsdiags,1) + if(CHECK_SIZES_) then + lsize_type_= obsLList_lcount(obsLLists(jj,ii),luseonly=.true.,recount=.true.) + nsize_type_= obsLList_lsize (obsLLists(jj,ii) ) + + lsize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),luseonly=.true.,recount=.true.) + !msize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),museonly=.true.) + nsize_diag_= obsdiagLList_lsize (obsdiags(jj,ii) ) + endif + + call obsdiagLList_read(obsdiags(jj,ii),iunit,redistr,jiter,miter,jj,ii,jread_,leadNode=leadNode, & + jiter_expected=jiter_expected) + if(present(jread)) then + if(jread/=jread_) then + if(jread>0) then + call perr(myname_,'not the same iteration, jiter =',jiter) + call perr(myname_,' saved jread =',jread) + call perr(myname_,' current jread =',jread_) + call die(myname_) + endif + jread=jread_ + endif + endif + + call obsdiagLookup_build(obsdiags(jj,ii),leadNode=leadNode,jiter=jread) + leadNode => null() ! nullified after its use, to avoid leadNode dangling arround. + + if (force_read .or. l4dvar.and..not.(lobserver.and.jiter==1)) then + call obsLList_read(obsLLists(jj,ii),iunit,redistr,obsdiags(jj,ii),jj) + endif + + call obsdiagLookup_clean(obsdiags(jj,ii)) + + read(iunit)ki,kj + if(ki/=ii .or. kj/=jj) then + call perr(myname_,'mismatched block id, file =',filename_(cdfile,iPE)) + if(kj/=jj) then + call perr(myname_,' reading kj =',kj) + call perr(myname_,' expecting jj =',jj) + endif + if(ki/=ii) then + call perr(myname_,' reading ki =',ki) + call perr(myname_,' expecting ii =',ii) + endif + call perr(myname_,' file =',filename_(cdfile,iPE)) + call perr(myname_,' cdfile =',cdfile) + call perr(myname_,' myPE =',myPE) + call perr(myname_,' iPE =',iPE) + call perr(myname_,' miter =',miter) + call perr(myname_,' redistr =',redistr) + call perr(myname_,' newunit =',iunit) + call perr(myname_,' iostat =',istat) + call die(myname_) + endif + + ASSERT(1<=jj.and.jj<=nobs_type) + + if(CHECK_SIZES_) then + lsize_type_= obsLList_lcount(obsLLists(jj,ii),luseonly=.true.)-lsize_type_ + nsize_type_= obsLList_lsize (obsLLists(jj,ii) )-nsize_type_ + + lsize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),luseonly=.true.)-lsize_diag_ + !msize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),museonly=.true.)-msize_diag_ + nsize_diag_= obsdiagLList_lsize (obsdiags(jj,ii) )-nsize_diag_ + + if( fileislocal .or. lsize_type_>0.or.nsize_type_>0 .or. & + msize_diag_>0.or. lsize_diag_>0.or.nsize_diag_>0 ) then + write(stdout,'(i5.3,2i5,2x,5i6,2x,l1)') iPE,jj,ii,lsize_type_,nsize_type_, & + msize_diag_,lsize_diag_,nsize_diag_,fileislocal + endif + + lsize_type(jj)= lsize_type(jj) +lsize_type_ + nsize_type(jj)= nsize_type(jj) +nsize_type_ + + lsize_diag(jj)= lsize_diag(jj) +lsize_diag_ + !msize_diag(jj)= msize_diag(jj) +msize_diag_ + nsize_diag(jj)= nsize_diag(jj) +nsize_diag_ + endif + + enddo ! jj=1,size(obsdiags,1) + enddo ! ii=1,size(obsdiags,2) + + close(iunit) +! ---------------------------------------------------------- +_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine read_ + +function filename_(prefix,iPE) +!>> name of partitioned (obsdiags,obsLLists) files + implicit none + character(len=:),allocatable:: filename_ + character(len=*) , intent(in ):: prefix + integer(kind=i_kind), intent(in ):: iPE + + character(len=4):: chPE + write(chPE,'(i4.4)') iPE + filename_=trim(adjustl(prefix))//'.'//trim(chPE) +end function filename_ + +function hdfilename_(prefix) +!>> name of the header file + use kinds, only: i_kind + implicit none + character(len=:),allocatable:: hdfilename_ + character(len=*) , intent(in ):: prefix + hdfilename_=trim(adjustl(prefix))//'.headers' +end function hdfilename_ + +subroutine summary_(title) +!-- get a summary of obsdiags(:,:) and obsLLists(:,:) +use obsmod, only: luse_obsdiag +use mpeu_util, only: tell,die,perr,stdout_open,stdout_close +_TIMER_USE_ + + use gsi_unformatted, only: unformatted_open + use gsi_4dvar, only: nobs_bins + + use m_obsLList, only: obsLList_lsize => obsLList_lcount + use m_obsdiagNode, only: obsdiagLList_lsize => obsdiagLList_lcount + + implicit none + character(len=*), intent(in) :: title + + character(len=*), parameter :: myname_=myname//"::summary_" + + integer(i_kind) :: ii,jj + integer(i_kind),dimension(nobs_type,nobs_bins):: ldiag,ndiag + integer(i_kind),dimension(nobs_type,nobs_bins):: lobss,nobss +_ENTRY_(myname_) +_TIMER_ON_(myname_) +! ---------------------------------------------------------- + + call lobsdiags_statusCheck_(myname_,allocated=.true.) + + if (luse_obsdiag) then + ASSERT(all(shape(obsdiags)==shape(obsLLists))) + ASSERT(size(obsdiags,1)==size(obsLLists,1)) + ASSERT(size(obsdiags,2)==size(obsLLists,2)) + endif + + do ii=1,size(obsdiags,2) + do jj=1,size(obsdiags,1) + ldiag(jj,ii) = obsdiagLList_lsize(obsdiags(jj,ii),luseonly=.true. ,recount=.true.) + ndiag(jj,ii) = obsdiagLList_lsize(obsdiags(jj,ii),luseonly=.false.,recount=.true.) + enddo + enddo + + do ii=1,size(obsLLists,2) + do jj=1,size(obsLLists,1) + lobss(jj,ii) = obsLList_lsize(obsLLists(jj,ii),luseonly=.true. ,recount=.true.) + nobss(jj,ii) = obsLList_lsize(obsLLists(jj,ii),luseonly=.false.,recount=.true.) + enddo + enddo + + call gather_write_(title,lobss,ldiag,nobss,ndiag,root=0,comm=gsi_comm_world) + +! ---------------------------------------------------------- +_TIMER_OFF_(myname_) +_EXIT_(myname_) +return +end subroutine summary_ + +subroutine gather_write_(title,lobss,ldiag,nobss,ndiag,root,comm) + use mpimod , only: mype,nPE + use kinds , only: i_kind + use mpeu_mpif, only: MPI_ikind + _TIMER_USE_ + implicit none + character(len=*),intent(in):: title + integer(kind=i_kind),dimension(:,:),intent(in):: lobss,ldiag + integer(kind=i_kind),dimension(:,:),intent(in):: nobss,ndiag + integer(kind=MPI_ikind),intent(in):: root + integer(kind=MPI_ikind),intent(in):: comm + + character(len=*),parameter:: myname_=myname//'::gather_write_' + integer(kind=i_kind):: jj,ii,iPE + integer(kind=i_kind) :: mtyp,mbin,mPEs + integer(kind=i_kind),allocatable,dimension(:,:,:):: ldiagm,ndiagm + integer(kind=i_kind),allocatable,dimension(:,:,:):: lobssm,nobssm + +_ENTRY_(myname_) +_TIMER_ON_(myname_) + mtyp=size(lobss,1) + mbin=size(lobss,2) + ASSERT(mtyp==size(nobss,1)) + ASSERT(mbin==size(nobss,2)) + ASSERT(mtyp==size(ldiag,1)) + ASSERT(mbin==size(ldiag,2)) + ASSERT(mtyp==size(ndiag,1)) + ASSERT(mbin==size(ndiag,2)) + + mPEs=0 ! its value is significant only on root + if(myPE==root) mPEs=nPE + + allocate(lobssm(mtyp,mbin,0:mPEs-1)) + allocate(ldiagm(mtyp,mbin,0:mPEs-1)) + allocate(nobssm(mtyp,mbin,0:mPEs-1)) + allocate(ndiagm(mtyp,mbin,0:mPEs-1)) + + call iMPI_gather_(lobss,lobssm,root,comm) + call iMPI_gather_(nobss,nobssm,root,comm) + call iMPI_gather_(ldiag,ldiagm,root,comm) + call iMPI_gather_(ndiag,ndiagm,root,comm) + + if(myPE==root) then + do iPE=0,nPE-1 + write(stdout,'(2a,i6)' ) title,'(): local obs/diag counts, iPE =',iPE + write(stdout,'(2a,9(1x,a))') title,'(): typ', ('| -----lo -----ld -----no -----nd',ii=1,mbin) + do jj=1,mtyp + write(stdout,'(2a,i3,9(1x,a,2(1x,2i8)))') & + title,'(): ',jj , & + ("|",lobssm(jj,ii,iPE),ldiagm(jj,ii,iPE), & + nobssm(jj,ii,iPE),ndiagm(jj,ii,iPE), ii=1,mbin) + enddo + enddo + endif + + deallocate(lobssm) + deallocate(ldiagm) + deallocate(nobssm) + deallocate(ndiagm) +_TIMER_OFF_(myname_) +_EXIT_(myname_) +end subroutine gather_write_ + +subroutine iMPI_barrier_(comm) + use mpeu_mpif, only: MPI_ikind + use mpeu_util, only: die + implicit none + integer(kind=MPI_ikind),intent(in):: comm + + character(len=*),parameter:: myname_=myname//"::iMPI_barrier_" + integer(kind=MPI_ikind):: ier + + call MPI_barrier(comm,ier) + if(ier/=0) call die(myname_,'MPI_barrier() error, ierror =',ier) +end subroutine iMPI_barrier_ + +subroutine iMPI_gather_(isend,irecv,root,comm) + use mpeu_mpif,only: MPI_ikind,MPI_type + use mpeu_util, only: die + use kinds, only: i_kind + implicit none + integer(kind=i_kind),dimension(:,: ),intent(in ):: isend + integer(kind=i_kind),dimension(:,:,:),intent(out):: irecv + integer(kind=MPI_ikind),intent(in):: root + integer(kind=MPI_ikind),intent(in):: comm + + character(len=*),parameter:: myname_=myname//"::iMPI_gather_" + integer(kind=MPI_ikind):: itype,isize,ierr + + isize=size(isend) + itype=MPI_type(isend) + call MPI_gather(isend,isize,itype, & + irecv,isize,itype, root,comm,ierr) + if(ierr/=0) call die(myname_,'MPI_gather() error, ierror =',ierr) +end subroutine iMPI_gather_ + +subroutine iMPI_reduceSUM_(iredu,root,comm) + use mpeu_mpif,only: MPI_ikind,MPI_type,MPI_SUM + use mpeu_util, only: die + use kinds, only: i_kind + implicit none + integer(kind=i_kind),dimension(:),intent(inout):: iredu + integer(kind=MPI_ikind),intent(in):: root + integer(kind=MPI_ikind),intent(in):: comm + + character(len=*),parameter:: myname_=myname//"::iMPI_reduceSUM_" + integer(kind=MPI_ikind):: itype,isize,ierr + !integer(kind=kind(iredu)),dimension(size(iredu)):: irecv + + isize=size(iredu) + itype=MPI_type(iredu) + call MPI_reduce((iredu),iredu,isize,itype, MPI_SUM, root,comm,ierr) + if(ierr/=0) call die(myname_,'MPI_reduce(MPI_SUM) error, ierror =',ierr) + !iredu(:)=irecv(:) +end subroutine iMPI_reduceSUM_ + +subroutine create_obsmod_vars() +!$$$ subprogram documentation block +! . . . . +! subprogram: create_obsmod_vars +! prgmmr: derber org: np23 date: 2003-09-25 +! +! abstract: allocate arrays to hold observation related information +! +! program history log: +! 2003-09-25 derber +! 2004-05-13 treadon, documentation +! 2015-10-09 j guo - moved here from MODULE OBSMOD with modifcations +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ end documentation block + use gsi_4dvar, only: nobs_bins + implicit none + lobstypes_allocated_=.true. + lobsdiags_allocated_=.true. + allocate(obsllists(nobs_type,nobs_bins)) + allocate(obsdiags (nobs_type,nobs_bins)) + return +end subroutine create_obsmod_vars + +subroutine destroy_obsmod_vars() +!-- Created to pair with create_obsmod_vars(). + implicit none + deallocate(obsllists) + deallocate(obsdiags ) + lobstypes_allocated_=.false. + lobsdiags_allocated_=.false. + return +end subroutine destroy_obsmod_vars + +! ---------------------------------------------------------------------- +subroutine inquire_obsdiags(kiter) +!$$$ subprogram documentation block +! . . . . +! subprogram: inquire_obsdiags +! prgmmr: +! +! abstract: +! +! program history log: +! 2009-08-07 lueken - added subprogram doc block +! +! input argument list: +! kiter +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use constants, only: one,two,three,four,five +use mpimod, only: mpi_max,mpi_comm_world,ierror,mype +use mpeu_mpif, only: mpi_type, MPI_IKIND +implicit none + +integer(i_kind), intent(in ) :: kiter + +real(r_kind) :: sizei, sizer, sizel, sizep, ziter, zsize, ztot +integer(i_kind) :: ii,jj,iobsa(2),iobsb(2) +type(obs_diag), pointer :: obsptr => null() + +! Any better way to determine size or i_kind, r_kind, etc... ? +sizei=four +sizer=8.0_r_kind +sizel=one +sizep=four + +iobsa(:)=0 +do ii=1,size(obsdiags,2) + do jj=1,size(obsdiags,1) + obsptr => obsdiags(jj,ii)%head + do while (associated(obsptr)) + iobsa(1)=iobsa(1)+1 + if (ANY(obsptr%muse(:))) iobsa(2)=iobsa(2)+1 + obsptr => obsptr%next + enddo + enddo +enddo + +call mpi_reduce(iobsa,iobsb,2_MPI_IKIND,mpi_type(iobsa),mpi_max,0_MPI_IKIND,mpi_comm_world,ierror) + +if (mype==0) then + ziter=real(kiter,r_kind) + zsize = sizer*(three*ziter+two) + sizei + sizel*(ziter+one) + sizep*five + ztot=real(iobsb(1),r_kind)*zsize + ztot=ztot/(1024.0_r_kind*1024.0_r_kind) + + write(6,*)'obsdiags: Bytes per element=',NINT(zsize) + write(6,*)'obsdiags: length total, used=',iobsb(1),iobsb(2) + write(6,'(A,F8.1,A)')'obsdiags: Estimated memory usage= ',ztot,' Mb' +endif + +end subroutine inquire_obsdiags + +end module m_obsdiags diff --git a/src/m_ozNode.F90 b/src/gsi/m_ozNode.F90 similarity index 91% rename from src/m_ozNode.F90 rename to src/gsi/m_ozNode.F90 index 730451337..c59634158 100644 --- a/src/m_ozNode.F90 +++ b/src/gsi/m_ozNode.F90 @@ -23,8 +23,8 @@ module m_ozNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag,aofp_obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag,aofp_obs_diag => fptr_obsdiagNode + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -81,6 +81,9 @@ module m_ozNode interface ozNode_typecast; module procedure typecast_ ; end interface interface ozNode_nextcast; module procedure nextcast_ ; end interface + public:: ozNode_appendto + interface ozNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_ozNode" #include "myassert.H" @@ -90,16 +93,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(ozNode) use m_obsNode, only: obsNode implicit none - type(ozNode),pointer:: ptr_ + type (ozNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(ozNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -108,15 +109,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(ozNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(ozNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type (ozNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(ozNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() @@ -266,9 +281,15 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) _ENTRY_(myname_) mlev =size(aNode%diags) + mlevp=size(aNode%prs) + if(mlev/=aNode%nloz+1) then + call perr(myname_,'mlev/=aNode%nloz+1, mlev =',mlev) + call perr(myname_,' mlevp =',mlevp) + call perr(myname_,' %nloz =',aNode%nloz) + call die(myname_) + endif ASSERT(mlev==aNode%nloz+1) - mlevp=size(aNode%prs) meff =size(aNode%apriori) msig =size(aNode%dprsi) diff --git a/src/m_pblhNode.F90 b/src/gsi/m_pblhNode.F90 similarity index 90% rename from src/m_pblhNode.F90 rename to src/gsi/m_pblhNode.F90 index a94e8a466..a80fed905 100644 --- a/src/m_pblhNode.F90 +++ b/src/gsi/m_pblhNode.F90 @@ -23,8 +23,8 @@ module m_pblhNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -69,6 +69,9 @@ module m_pblhNode interface pblhNode_typecast; module procedure typecast_ ; end interface interface pblhNode_nextcast; module procedure nextcast_ ; end interface + public:: pblhNode_appendto + interface pblhNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_pblhNode" #include "myassert.H" @@ -80,14 +83,12 @@ function typecast_(aNode) result(ptr_) implicit none type(pblhNode),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(pblhNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -97,14 +98,28 @@ function nextcast_(aNode) result(ptr_) use m_obsNode, only: obsNode,obsNode_next implicit none type(pblhNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(pblhNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_pcpNode.F90 b/src/gsi/m_pcpNode.F90 similarity index 92% rename from src/m_pcpNode.F90 rename to src/gsi/m_pcpNode.F90 index 576fa0243..3dd4a9b5d 100644 --- a/src/m_pcpNode.F90 +++ b/src/gsi/m_pcpNode.F90 @@ -23,8 +23,8 @@ module m_pcpNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -72,6 +72,9 @@ module m_pcpNode interface pcpNode_typecast; module procedure typecast_ ; end interface interface pcpNode_nextcast; module procedure nextcast_ ; end interface + public:: pcpNode_appendto + interface pcpNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_pcpNode" #include "myassert.H" @@ -81,16 +84,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(pcpNode) use m_obsNode, only: obsNode implicit none - type(pcpNode),pointer:: ptr_ + type(pcpNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(pcpNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -99,15 +100,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(pcpNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(pcpNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(pcpNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(pcpNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_pm10Node.F90 b/src/gsi/m_pm10Node.F90 similarity index 90% rename from src/m_pm10Node.F90 rename to src/gsi/m_pm10Node.F90 index 7ee0b0cb7..3536403fa 100644 --- a/src/m_pm10Node.F90 +++ b/src/gsi/m_pm10Node.F90 @@ -23,8 +23,8 @@ module m_pm10Node !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -75,6 +75,9 @@ module m_pm10Node interface pm10Node_typecast; module procedure typecast_ ; end interface interface pm10Node_nextcast; module procedure nextcast_ ; end interface + public:: pm10Node_appendto + interface pm10Node_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_pm10Node" #include "myassert.H" @@ -86,14 +89,12 @@ function typecast_(aNode) result(ptr_) implicit none type(pm10Node),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(pm10Node) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -103,14 +104,28 @@ function nextcast_(aNode) result(ptr_) use m_obsNode, only: obsNode,obsNode_next implicit none type(pm10Node),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(pm10Node),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_pm2_5Node.F90 b/src/gsi/m_pm2_5Node.F90 similarity index 90% rename from src/m_pm2_5Node.F90 rename to src/gsi/m_pm2_5Node.F90 index e79d5da3b..4a865e530 100644 --- a/src/m_pm2_5Node.F90 +++ b/src/gsi/m_pm2_5Node.F90 @@ -23,8 +23,8 @@ module m_pm2_5Node !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -75,6 +75,9 @@ module m_pm2_5Node interface pm2_5Node_typecast; module procedure typecast_ ; end interface interface pm2_5Node_nextcast; module procedure nextcast_ ; end interface + public:: pm2_5Node_appendto + interface pm2_5Node_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_pm2_5Node" #include "myassert.H" @@ -85,15 +88,13 @@ function typecast_(aNode) result(ptr_) use m_obsNode, only: obsNode implicit none type(pm2_5Node),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" + class(obsNode ),pointer,intent(in):: aNode ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(pm2_5Node) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -103,14 +104,28 @@ function nextcast_(aNode) result(ptr_) use m_obsNode, only: obsNode,obsNode_next implicit none type(pm2_5Node),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + class(obsNode ),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(pm2_5Node),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_pmslNode.F90 b/src/gsi/m_pmslNode.F90 similarity index 88% rename from src/m_pmslNode.F90 rename to src/gsi/m_pmslNode.F90 index b70707fb5..2c41d0cf2 100644 --- a/src/m_pmslNode.F90 +++ b/src/gsi/m_pmslNode.F90 @@ -24,8 +24,8 @@ module m_pmslNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,40 +71,57 @@ module m_pmslNode interface pmslNode_typecast; module procedure typecast_ ; end interface interface pmslNode_nextcast; module procedure nextcast_ ; end interface + public:: pmslNode_appendto + interface pmslNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_pmslNode" #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(pmslNode) use m_obsNode, only: obsNode implicit none type(pmslNode),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(pmslNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(pmslNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(pmslNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(pmslNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_psNode.F90 b/src/gsi/m_psNode.F90 similarity index 89% rename from src/m_psNode.F90 rename to src/gsi/m_psNode.F90 index 1d9a41add..2ee19558c 100644 --- a/src/m_psNode.F90 +++ b/src/gsi/m_psNode.F90 @@ -25,7 +25,7 @@ module m_psNode ! module interface: use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell - use obsmod, only: obs_diag + use m_obsdiagNode, only: obs_diag use m_obsNode, only: obsNode implicit none private @@ -37,6 +37,7 @@ module m_psNode type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res =0._r_kind ! surface pressure residual real(r_kind) :: err2 =0._r_kind ! surface pressure error squared + ! in reciprocal real(r_kind) :: raterr2=0._r_kind ! square of ratio of final obs error ! to original obs error real(r_kind) :: b =0._r_kind ! variational quality control parameter @@ -72,6 +73,9 @@ module m_psNode interface psNode_typecast; module procedure typecast_ ; end interface interface psNode_nextcast; module procedure nextcast_ ; end interface + public:: psNode_appendto + interface psNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_psNode" #include "myassert.H" @@ -81,16 +85,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(psNode) use m_obsNode, only: obsNode implicit none - type(psNode),pointer:: ptr_ + type (psNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(psNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -99,15 +101,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(psNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(psNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type (psNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(psNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() @@ -118,7 +134,7 @@ end function mytype subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) use m_obsdiagNode, only: obsdiagLookup_locate - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diags implicit none class(psNode), intent(inout):: aNode integer(i_kind), intent(in ):: iunit diff --git a/src/m_pwNode.F90 b/src/gsi/m_pwNode.F90 similarity index 92% rename from src/m_pwNode.F90 rename to src/gsi/m_pwNode.F90 index fc08e7f20..7ad1f390d 100644 --- a/src/m_pwNode.F90 +++ b/src/gsi/m_pwNode.F90 @@ -23,8 +23,8 @@ module m_pwNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,6 +71,9 @@ module m_pwNode interface pwNode_typecast; module procedure typecast_ ; end interface interface pwNode_nextcast; module procedure nextcast_ ; end interface + public:: pwNode_appendto + interface pwNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_pwNode" #include "myassert.H" @@ -80,16 +83,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(pwNode) use m_obsNode, only: obsNode implicit none - type(pwNode),pointer:: ptr_ + type(pwNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(pwNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -101,12 +102,26 @@ function nextcast_(aNode) result(ptr_) type(pwNode),pointer:: ptr_ class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(pwNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_qNode.F90 b/src/gsi/m_qNode.F90 similarity index 82% rename from src/m_qNode.F90 rename to src/gsi/m_qNode.F90 index bdcfd532a..e71c41885 100644 --- a/src/m_qNode.F90 +++ b/src/gsi/m_qNode.F90 @@ -23,8 +23,8 @@ module m_qNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -55,6 +55,9 @@ module m_qNode !real (r_kind) :: elat, elon ! earth lat-lon for redistribution !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution real (r_kind) :: dlev ! reference to the vertical grid + + integer(i_kind) :: ich0=0 ! ich code to mark derived data. See + ! qNode_ich0 and qNode_ich0_PBL_Pseudo below contains procedure,nopass:: mytype procedure:: setHop => obsNode_setHop_ @@ -74,6 +77,19 @@ module m_qNode interface qNode_typecast; module procedure typecast_ ; end interface interface qNode_nextcast; module procedure nextcast_ ; end interface + public:: qNode_appendto + interface qNode_appendto; module procedure appendto_ ; end interface + + ! Because there are two components in qNode for an ordinary wind obs, + ! ich values are set to (1,2). Therefore, ich values for PBL_pseudo_surfobsUV + ! are set to (3,4), and qNode_ich0_pbl_pseudo is set to 2. + + public:: qNode_ich0 + public:: qNode_ich0_PBL_pseudo + + integer(i_kind),parameter :: qNode_ich0 = 0 ! ich=0+1 + integer(i_kind),parameter :: qNode_ich0_PBL_pseudo = qNode_ich0+1 ! ich=1+1 + character(len=*),parameter:: MYNAME="m_qNode" #include "myassert.H" @@ -83,16 +99,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(qNode) use m_obsNode, only: obsNode implicit none - type(qNode),pointer:: ptr_ + type(qNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(qNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -101,15 +115,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(qNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(qNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(qNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(qNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() @@ -154,6 +182,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%k1 , & aNode%kx , & aNode%dlev , & + aNode%ich0 , & aNode%wij , & aNode%ij if (istat/=0) then @@ -162,10 +191,11 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) return end if - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) + aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,aNode%ich0+1_i_kind) if(.not.associated(aNode%diags)) then call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) call perr(myname_,' %iob =',aNode%iob) + call perr(myname_,' %ich0 =',aNode%ich0) call die(myname_) endif endif @@ -193,6 +223,7 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%k1 , & aNode%kx , & aNode%dlev , & + aNode%ich0 , & aNode%wij , & aNode%ij if (jstat/=0) then diff --git a/src/gsi/m_radNode.F90 b/src/gsi/m_radNode.F90 new file mode 100644 index 000000000..33070e838 --- /dev/null +++ b/src/gsi/m_radNode.F90 @@ -0,0 +1,453 @@ +module m_radNode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_radNode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type radNode (radiances) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2016-07-19 kbathmann - add rsqrtinv and use_corr_obs to rad_ob_type +! 2019-04-22 kbathmann - change rsqrtinv to Rpred +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagNode, only: obs_diag,aofp_obs_diag => fptr_obsdiagNode + use m_obsdiagNode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsNode, only: obsNode + implicit none + private + + public:: radNode + + type,extends(obsNode):: radNode + type(aofp_obs_diag), dimension(:), pointer :: diags => NULL() + real(r_kind),dimension(:),pointer :: res => NULL() + ! obs-guess residual (nchan) + real(r_kind),dimension(:),pointer :: err2 => NULL() + ! error variances squared (nchan) + real(r_kind),dimension(:),pointer :: raterr2 => NULL() + ! ratio of error variances squared (nchan) + real(r_kind) :: wij(4) ! horizontal interpolation weights + real(r_kind),dimension(:,:),pointer :: pred => NULL() + ! predictors (npred,nchan) + real(r_kind),dimension(:,:),pointer :: dtb_dvar => NULL() + ! radiance jacobian (nsigradjac,nchan) + + real(r_kind),dimension(:,:),pointer :: Rpred => NULL() + ! square root of inverse of R, multiplied + ! by bias predictor jacobian + ! only used if using correlated obs + real(r_kind),dimension(: ),pointer :: rsqrtinv => NULL() + ! square root of inverse of R, only used + ! if using correlated obs + + integer(i_kind),dimension(:),pointer :: icx => NULL() + integer(i_kind),dimension(:),pointer :: ich => NULL() + integer(i_kind) :: nchan ! number of channels for this profile + integer(i_kind) :: ij(4) ! horizontal locations + logical :: use_corr_obs = .false. ! to indicate if correlated obs is implemented + integer(i_kind) :: iuse_PredOper_type = 0 ! indicate which type of correlated predictor operator is implemented + ! 0 uses none (diagonal) + ! 1 uses rsqrtinv + ! 2 uses Rpred + +!!! Is %isis or %isfctype ever being assigned somewhere in the code? +!!! They are used in intrad(). +!!! +!!! Now, they are not written to an obsdiags file, nor read from one. + + character(20) :: isis ! sensor/instrument/satellite id, e.g. amsua_n15 + !integer(i_kind) :: isfctype ! surf mask: ocean=0,land=1,ice=2,snow=3,mixed=4 + character(80) :: covtype ! surf mask: ocean=0,land=1,ice=2,snow=3,mixed=4 + contains + procedure,nopass:: mytype + procedure:: setHop => obsNode_setHop_ + procedure:: xread => obsNode_xread_ + procedure:: xwrite => obsNode_xwrite_ + procedure:: isvalid => obsNode_isvalid_ + procedure:: gettlddp => gettlddp_ + + procedure, nopass:: headerRead => obsHeader_read_ + procedure, nopass:: headerWrite => obsHeader_write_ + ! procedure:: init => obsNode_init_ + procedure:: clean => obsNode_clean_ + end type radNode + + public:: radNode_typecast + public:: radNode_nextcast + interface radNode_typecast; module procedure typecast_ ; end interface + interface radNode_nextcast; module procedure nextcast_ ; end interface + + public:: radNode_appendto + interface radNode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: MYNAME="m_radNode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(radNode) + use m_obsNode, only: obsNode + implicit none + type(radNode ),pointer:: ptr_ + class(obsNode),pointer,intent(in):: aNode + ptr_ => null() + if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(aNode) + type is(radNode) + ptr_ => aNode + end select +return +end function typecast_ + +function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(radNode) + use m_obsNode, only: obsNode,obsNode_next + implicit none + type(radNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) +return +end function nextcast_ + +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(radNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + +! obsNode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[radNode]" +end function mytype + +subroutine obsHeader_read_(iunit,mobs,jread,istat) + use radinfo, only: npred,nsigradjac + implicit none + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent(out):: mobs + integer(i_kind),intent(out):: jread + integer(i_kind),intent(out):: istat + + character(len=*),parameter:: myname_=myname//'.obsHeader_read_' + integer(i_kind):: mpred,msigradjac +_ENTRY_(myname_) + + read(iunit,iostat=istat) mobs,jread, mpred,msigradjac + if(istat==0 .and. (npred/=mpred .or. nsigradjac/=msigradjac)) then + call perr(myname_,'unmatched dimension information, npred or nsigradjac') + if(npred/=mpred) then + call perr(myname_,' expecting npred =',npred) + call perr(myname_,' but read mpred =',mpred) + endif + if(nsigradjac/=msigradjac) then + call perr(myname_,'expecting nsigradjac =',nsigradjac) + call perr(myname_,' but read msigradjac =',msigradjac) + endif + call die(myname_) + endif +_EXIT_(myname_) +return +end subroutine obsHeader_read_ + +subroutine obsHeader_write_(junit,mobs,jwrite,jstat) + use radinfo, only: npred,nsigradjac + implicit none + integer(i_kind),intent(in ):: junit + integer(i_kind),intent(in ):: mobs + integer(i_kind),intent(in ):: jwrite + integer(i_kind),intent(out):: jstat + + character(len=*),parameter:: myname_=myname//'.obsHeader_write_' +_ENTRY_(myname_) + write(junit,iostat=jstat) mobs,jwrite, npred,nsigradjac +_EXIT_(myname_) +return +end subroutine obsHeader_write_ + +subroutine obsNode_clean_(aNode) + implicit none + class(radNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_clean_' +_ENTRY_(myname_) +!_TRACEV_(myname_,'%mytype() =',aNode%mytype()) + if(associated(aNode%diags )) deallocate(aNode%diags ) + if(associated(aNode%ich )) deallocate(aNode%ich ) + if(associated(aNode%res )) deallocate(aNode%res ) + if(associated(aNode%err2 )) deallocate(aNode%err2 ) + if(associated(aNode%raterr2 )) deallocate(aNode%raterr2 ) + if(associated(aNode%pred )) deallocate(aNode%pred ) + if(associated(aNode%dtb_dvar)) deallocate(aNode%dtb_dvar) + if(associated(aNode%Rpred )) deallocate(aNode%Rpred ) + if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv) + if(associated(aNode%icx )) deallocate(aNode%icx ) +_EXIT_(myname_) +return +end subroutine obsNode_clean_ + +subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) + use m_obsdiagNode, only: obsdiagLookup_locate + use radinfo, only: npred,nsigradjac + implicit none + class(radNode),intent(inout):: aNode + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent( out):: istat + type(obs_diags),intent(in ):: diagLookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_' + integer(i_kind):: k,nchan + logical:: skip_ +_ENTRY_(myname_) + skip_=.false. + if(present(skip)) skip_=skip + + istat=0 + if(skip_) then + read(iunit,iostat=istat) + if (istat/=0) then + call perr(myname_,'skipping read(%(nchan,iuse_PredOper_type)), iostat =',istat) + _EXIT_(myname_) + return + end if + + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(Rpred||rsqrtinv)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) aNode%nchan,aNode%use_corr_obs,aNode%iuse_PredOper_type + if (istat/=0) then + call perr(myname_,'read(%(nchan,use_corr_obs,iuse_PredOper_type)), iostat =',istat) + _EXIT_(myname_) + return + end if + + if(associated(aNode%diags )) deallocate(aNode%diags ) + if(associated(aNode%ich )) deallocate(aNode%ich ) + if(associated(aNode%res )) deallocate(aNode%res ) + if(associated(aNode%err2 )) deallocate(aNode%err2 ) + if(associated(aNode%raterr2 )) deallocate(aNode%raterr2 ) + if(associated(aNode%pred )) deallocate(aNode%pred ) + if(associated(aNode%dtb_dvar)) deallocate(aNode%dtb_dvar) + if(associated(aNode%Rpred )) deallocate(aNode%Rpred) + if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv) + if(associated(aNode%icx )) deallocate(aNode%icx ) + + nchan=aNode%nchan + allocate( aNode%diags(nchan), & + aNode%res (nchan), & + aNode%err2 (nchan), & + aNode%raterr2 (nchan), & + aNode%pred (npred,nchan), & + aNode%dtb_dvar(nsigradjac,nchan), & + aNode%ich (nchan), & + aNode%icx (nchan) ) + + read(iunit,iostat=istat) aNode%ich , & + aNode%res , & + aNode%err2 , & + aNode%raterr2 , & + aNode%pred , & + aNode%icx , & + aNode%dtb_dvar, & + aNode%wij , & + aNode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + if(.not.aNode%use_corr_obs) aNode%iuse_PredOper_type=0 + select case(aNode%iuse_PredOper_type) + case(1) + allocate(aNode%rsqrtinv(((nchan+1)*nchan)/2)) + read(iunit,iostat=istat) aNode%rsqrtinv + if (istat/=0) then + call perr(myname_,'read(%rsqrtinv), iostat =',istat) + _EXIT_(myname_) + return + end if + case(2) + allocate(aNode%Rpred(((nchan+1)*nchan)/2,npred)) + read(iunit,iostat=istat) aNode%Rpred + if (istat/=0) then + call perr(myname_,'read(%Rpred), iostat =',istat) + _EXIT_(myname_) + return + end if + + case default + read(iunit,iostat=istat) + end select + + do k=1,nchan + aNode%diags(k)%ptr => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,aNode%ich(k)) + if(.not.associated(aNode%diags(k)%ptr)) then + call perr(myname_,'obsdiagLookup_locate(k), k =',k) + call perr(myname_,' %idv =',aNode%idv) + call perr(myname_,' %iob =',aNode%iob) + call perr(myname_,' %ich(k) =',aNode%ich(k)) + call die(myname_) + endif + enddo + endif +_EXIT_(myname_) +return +end subroutine obsNode_xread_ + +subroutine obsNode_xwrite_(aNode,junit,jstat) + use radinfo, only: npred + implicit none + class(radNode),intent(in):: aNode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_' + integer(i_kind):: k + integer(i_kind):: iuse_PredOper_type +_ENTRY_(myname_) + + jstat=0 + iuse_PredOper_type=0 + if(aNode%use_corr_obs) iuse_PredOper_type=aNode%iuse_PredOper_type + write(junit,iostat=jstat) aNode%nchan,aNode%use_corr_obs,iuse_PredOper_type + if (jstat/=0) then + call perr(myname_,'write(%(nchan,use_corr_obs, etc.)), iostat =',jstat) + _EXIT_(myname_) + return + end if + + write(junit,iostat=jstat) (/ (aNode%ich(k),k=1,aNode%nchan) /), & + aNode%res , & + aNode%err2 , & + aNode%raterr2 , & + aNode%pred , & + aNode%icx , & + aNode%dtb_dvar, & + aNode%wij , & + aNode%ij + if (jstat/=0) then + call perr(myname_,'write(%(ich,res,err2,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if + + select case(iuse_PredOper_type) + case(1) + ASSERT(size(aNode%rsqrtinv)==((aNode%nchan+1)*aNode%nchan)/2) + write(junit,iostat=jstat) aNode%rsqrtinv + if (jstat/=0) then + call perr(myname_,'write(%rsqrtinv), iostat =',jstat) + _EXIT_(myname_) + return + end if + case(2) + ASSERT(size(aNode%Rpred,1)==((aNode%nchan+1)*aNode%nchan)/2) + ASSERT(size(aNode%Rpred,2)==npred) + write(junit,iostat=jstat) aNode%Rpred + if (jstat/=0) then + call perr(myname_,'write(%Rpred), iostat =',jstat) + _EXIT_(myname_) + return + end if + + case default + write(junit,iostat=jstat) + if (jstat/=0) then + call perr(myname_,'write as skip record, iostat =',jstat) + _EXIT_(myname_) + return + end if + end select + +_EXIT_(myname_) +return +end subroutine obsNode_xwrite_ + +subroutine obsNode_setHop_(aNode) + use m_cvgridLookup, only: cvgridLookup_getiw + implicit none + class(radNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' +_ENTRY_(myname_) + call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) +_EXIT_(myname_) +return +end subroutine obsNode_setHop_ + +function obsNode_isvalid_(aNode) result(isvalid_) + implicit none + logical:: isvalid_ + class(radNode),intent(in):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' + integer(i_kind):: k +_ENTRY_(myname_) + isvalid_=all( (/ (associated(aNode%diags(k)%ptr),k=1,aNode%nchan) /) ) +_EXIT_(myname_) +return +end function obsNode_isvalid_ + +pure subroutine gettlddp_(aNode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(radNode), intent(in):: aNode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + integer(kind=i_kind):: k + do k=1,aNode%nchan + tlddp = tlddp + aNode%diags(k)%ptr%tldepart(jiter)*aNode%diags(k)%ptr%tldepart(jiter) + enddo + if(present(nob)) nob=nob+aNode%nchan +return +end subroutine gettlddp_ + +end module m_radNode diff --git a/src/m_rerank.f90 b/src/gsi/m_rerank.f90 similarity index 100% rename from src/m_rerank.f90 rename to src/gsi/m_rerank.f90 diff --git a/src/gsi/m_rhs.F90 b/src/gsi/m_rhs.F90 new file mode 100644 index 000000000..baee07468 --- /dev/null +++ b/src/gsi/m_rhs.F90 @@ -0,0 +1,240 @@ +module m_rhs +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_rhs +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 900.3 +! date: 2010-03-22 +! +! abstract: defines persistant workspace for multiple-pass setuprhsall() +! +! program history log: +! 2010-03-22 j guo - added this document block +! 2010-04-22 tangborn- add co knobs +! 2010-05-27 j guo - cut off GPS related variables to m_gpsrhs +! 2018-08-10 j guo - moved in all type-indices from setuprhsall(). These +! type-indices are now defined from this module itself, +! through an enum block. +! - removed external dimension argument aworkdim2 of +! rhs_alloc(). +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +#include "mytrace.H" + +! module interface: + + use kinds, only: r_kind, i_kind, r_single + use mpeu_util, only: die,perr,tell + implicit none + private + public:: rhs_alloc ! interface for allocation + public:: rhs_dealloc ! interface for deallocation + public:: rhs_allocated ! state of all moduel variables + + public:: rhs_awork ! variables ... + public:: rhs_bwork + public:: rhs_aivals + public:: rhs_stats + public:: rhs_stats_oz + public:: rhs_stats_co + public:: rhs_toss_gps + + ! variable indices to rhs_awork(:,i_work). e.g. + ! ps_awork(:) => rhs_awork(:,i_ps) + public:: i_ps + public:: i_uv + public:: i_t + public:: i_q + public:: i_pw + public:: i_rw + public:: i_dw + public:: i_gps + public:: i_sst + public:: i_tcp + public:: i_lag + public:: i_co + public:: i_gust + public:: i_vis + public:: i_pblh + public:: i_wspd10m + public:: i_td2m + public:: i_mxtm + public:: i_mitm + public:: i_pmsl + public:: i_howv + public:: i_tcamt + public:: i_lcbas + public:: i_cldch + public:: i_uwnd10m + public:: i_vwnd10m + public:: i_swcp + public:: i_lwcp + public:: i_light + public:: i_dbz + public:: i_cldtot + + public:: awork_size + public:: awork_lbound + public:: awork_ubound + +! Revision history: +! 2009-08-19 guo - created to support multi-pass setuprhsall(). +! This module contains all statistics variables +! defined for any single pass but all passes. + + !! usage: + !! use xyz_mod, only: npres_print,nconvtype,nsig + !! use m_rhs, only: rhs_alloc + !! use m_rhs, only: rhs_dealloc + !! use m_rhs, only: rhs_allocated + !! use m_rhs, only: awork => rhs_awork + !! use m_rhs, only: bwork => rhs_bwork + !! + !! if(.not.rhs_allocated) & + !! call rhs_alloc() + !! call xxxx(awork,bwork,...) + !! call rhs_dealloc() + + logical,save:: rhs_allocated=.false. + real(r_kind),allocatable,dimension(:,: ),save:: rhs_awork + real(r_kind),allocatable,dimension(:,:,:,:),save:: rhs_bwork + real(r_kind),allocatable,dimension(:,: ),save:: rhs_aivals + real(r_kind),allocatable,dimension(:,: ),save:: rhs_stats + real(r_kind),allocatable,dimension(:,: ),save:: rhs_stats_oz + real(r_kind),allocatable,dimension(:,: ),save:: rhs_stats_co + real(r_kind),allocatable,dimension(: ),save:: rhs_toss_gps + + enum, bind(C) + enumerator:: i_zero = 0 + + enumerator:: i_ps + enumerator:: i_uv + enumerator:: i_t + enumerator:: i_q + enumerator:: i_pw + enumerator:: i_rw + enumerator:: i_dw + enumerator:: i_gps + enumerator:: i_sst + enumerator:: i_tcp + enumerator:: i_lag + enumerator:: i_co + enumerator:: i_gust + enumerator:: i_vis + enumerator:: i_pblh + enumerator:: i_wspd10m + enumerator:: i_td2m + enumerator:: i_mxtm + enumerator:: i_mitm + enumerator:: i_pmsl + enumerator:: i_howv + enumerator:: i_tcamt + enumerator:: i_lcbas + enumerator:: i_cldch + enumerator:: i_uwnd10m + enumerator:: i_vwnd10m + enumerator:: i_swcp + enumerator:: i_lwcp + enumerator:: i_light + enumerator:: i_dbz + enumerator:: i_cldtot + + enumerator:: i_outbound + end enum + + integer(i_kind) ,parameter:: enum_kind = kind(i_zero) + integer(kind=enum_kind),parameter:: awork_lbound = i_zero +1 + integer(kind=enum_kind),parameter:: awork_ubound = i_outbound-1 + integer(kind=enum_kind),parameter:: awork_size = awork_ubound-awork_lbound +1 + + character(len=*),parameter:: myname="m_rhs" + +contains +subroutine rhs_alloc() + ! supporting information + use kinds, only: i_kind + use constants, only: zero + + ! run-time dimensional information + use obsmod , only: ndat + use obsmod , only: nprof_gps + use radinfo , only: jpch_rad + use ozinfo , only: jpch_oz + use coinfo , only: jpch_co + use qcmod , only: npres_print + use gridmod , only: nsig + use convinfo, only: nconvtype + + ! indirectly used counter + use obsmod , only: nchan_total + use gsi_io, only: verbose + implicit none + character(len=*),parameter:: myname_=myname//'.alloc' + logical print_verbose +_ENTRY_(myname_) + print_verbose=.false. + if(verbose) print_verbose=.true. + if(rhs_allocated) call die(myname_,'already allocated') + + if(print_verbose)then + call tell(myname_,'nsig =' ,nsig) + call tell(myname_,'npres_print =',npres_print) + call tell(myname_,'nconvtype =' ,nconvtype) + call tell(myname_,'ndat =' ,ndat) + call tell(myname_,'jpch_rad =' ,jpch_rad) + call tell(myname_,'jpch_co =' ,jpch_co) + call tell(myname_,'jpch_oz =' ,jpch_oz) + call tell(myname_,'nprof_gps =' ,nprof_gps) + end if + + rhs_allocated=.true. + allocate(rhs_awork(7*nsig+100,awork_size)) + allocate(rhs_bwork(npres_print,nconvtype,5,3)) + allocate(rhs_aivals(40,ndat)) + allocate(rhs_stats(7,jpch_rad)) + allocate(rhs_stats_co(9,jpch_co)) + allocate(rhs_stats_oz(9,jpch_oz)) + + allocate(rhs_toss_gps(max(1,nprof_gps))) + + rhs_awork =zero + rhs_bwork =zero + rhs_aivals =zero + rhs_stats =zero + rhs_stats_co =zero + rhs_stats_oz =zero + rhs_toss_gps =zero + + nchan_total =0 +_EXIT_(myname_) +end subroutine rhs_alloc + +subroutine rhs_dealloc() + use kinds, only: i_kind + implicit none + character(len=*),parameter:: myname_=myname//'.dealloc' +_ENTRY_(myname_) + if(.not.rhs_allocated) call die(myname_,'can not be deallocted') + + rhs_allocated=.false. + deallocate(rhs_awork) + deallocate(rhs_bwork) + deallocate(rhs_aivals) + deallocate(rhs_stats) + deallocate(rhs_stats_co) + deallocate(rhs_stats_oz) + + deallocate(rhs_toss_gps) +_EXIT_(myname_) +end subroutine rhs_dealloc + +end module m_rhs diff --git a/src/m_rwNode.F90 b/src/gsi/m_rwNode.F90 similarity index 91% rename from src/m_rwNode.F90 rename to src/gsi/m_rwNode.F90 index 35ab00484..3186fa8ea 100644 --- a/src/m_rwNode.F90 +++ b/src/gsi/m_rwNode.F90 @@ -26,8 +26,8 @@ module m_rwNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -80,6 +80,9 @@ module m_rwNode interface rwNode_typecast; module procedure typecast_ ; end interface interface rwNode_nextcast; module procedure nextcast_ ; end interface + public:: rwNode_appendto + interface rwNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_rwNode" #include "myassert.H" @@ -89,16 +92,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(rwNode) use m_obsNode, only: obsNode implicit none - type(rwNode),pointer:: ptr_ + type(rwNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(rwNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -107,15 +108,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(rwNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(rwNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(rwNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(rwNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/gsi/m_sortind.f90 b/src/gsi/m_sortind.f90 new file mode 100644 index 000000000..8aeacbbf6 --- /dev/null +++ b/src/gsi/m_sortind.f90 @@ -0,0 +1,226 @@ +module m_sortind + +!$$$ module documentation block +! . . . . +! module: m_sortind finds indices to sort an array in ascending order +! prgmmr: eliu +! +! abstract: module to find indices to sort an array in ascending order +! assimilation +! +! program history log: +! 1996-10-01 Joiner/Karki - initial coding from NASA/GMAO +! 2012-02-15 eliu - reformat to use in GSI +! +! subroutines included: +! +! variable definitions: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds,only : i_kind, r_kind + interface sortind + module procedure r_sortind + module procedure i_sortind + end interface + + contains + + function r_sortind(arr) result(arr2) + implicit none + + !input parameters: + real(r_kind), dimension(:) :: arr ! input vector to sort + !output parameters: + integer(i_kind), dimension(size(arr)) :: arr2 + + call indexx(size(arr),arr, arr2) + + end function r_sortind + + function i_sortind(arr) result(arr2) + + implicit none + + integer(i_kind), dimension(:) :: arr + integer(i_kind), dimension(size(arr)) :: arr2 + + call iindexx(size(arr),arr, arr2) + + end function i_sortind + + SUBROUTINE indexx(n,arr,indx) + + INTEGER(i_kind):: n,indx(n),M,NSTACK + REAL(r_kind) :: arr(n) + PARAMETER (M=7,NSTACK=50) + INTEGER(i_kind):: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) + REAL(r_kind) :: a + do 11 j=1,n + indx(j)=j +11 continue + jstack=0 + l=1 + ir=n + loop2: do + if(ir-l.lt.M)then + loop: do j=l+1,ir + indxt=indx(j) + a=arr(indxt) + do 12 i=j-1,1,-1 + if(arr(indx(i)).le.a)then + indx(i+1)=indxt + cycle loop + end if + indx(i+1)=indx(i) +12 continue + indx(1)=indxt + end do loop + if(jstack.eq.0)return + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + itemp=indx(k) + indx(k)=indx(l+1) + indx(l+1)=itemp + if(arr(indx(l+1)) > arr(indx(ir)))then + itemp=indx(l+1) + indx(l+1)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l)) > arr(indx(ir)))then + itemp=indx(l) + indx(l)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l+1)) > arr(indx(l)))then + itemp=indx(l+1) + indx(l+1)=indx(l) + indx(l)=itemp + endif + i=l+1 + j=ir + indxt=indx(l) + a=arr(indxt) + loop1: do + i=i+1 + if(arr(indx(i)).lt.a)cycle loop1 + do +4 continue + j=j-1 + if(arr(indx(j))<=a)exit + end do + if(j.lt.i)exit loop1 + itemp=indx(i) + indx(i)=indx(j) + indx(j)=itemp + end do loop1 +5 indx(l)=indx(j) + indx(j)=indxt + jstack=jstack+2 + if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' + if(ir-i+1.ge.j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + end do loop2 + END subroutine indexx + + SUBROUTINE iindexx(n,arr,indx) + INTEGER(i_kind):: n,indx(n),M,NSTACK + INTEGER(i_kind):: arr(n) + PARAMETER (M=7,NSTACK=50) + INTEGER(i_kind):: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) + INTEGER(i_kind):: a + do 11 j=1,n + indx(j)=j +11 continue + jstack=0 + l=1 + ir=n + loop2: do + if(ir-l.lt.M)then + loop: do j=l+1,ir + indxt=indx(j) + a=arr(indxt) + do 12 i=j-1,1,-1 + if(arr(indx(i)).le.a)then + indx(i+1)=indxt + cycle loop + end if + indx(i+1)=indx(i) +12 continue + indx(1)=indxt + end do loop + if(jstack.eq.0)return + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + itemp=indx(k) + indx(k)=indx(l+1) + indx(l+1)=itemp + if(arr(indx(l+1)).gt.arr(indx(ir)))then + itemp=indx(l+1) + indx(l+1)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l)).gt.arr(indx(ir)))then + itemp=indx(l) + indx(l)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l+1)).gt.arr(indx(l)))then + itemp=indx(l+1) + indx(l+1)=indx(l) + indx(l)=itemp + endif + i=l+1 + j=ir + indxt=indx(l) + a=arr(indxt) + loop1: do + do + i=i+1 + if(arr(indx(i))>=a)exit + end do + do + j=j-1 + if(arr(indx(j))<=a)exit + end do + if(j.lt.i)exit loop1 + itemp=indx(i) + indx(i)=indx(j) + indx(j)=itemp + end do loop1 + indx(l)=indx(j) + indx(j)=indxt + jstack=jstack+2 + if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' + if(ir-i+1.ge.j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + end do loop2 + END subroutine iindexx + +end module m_sortind diff --git a/src/m_spdNode.F90 b/src/gsi/m_spdNode.F90 similarity index 90% rename from src/m_spdNode.F90 rename to src/gsi/m_spdNode.F90 index 02a394e7f..c46ad60a5 100644 --- a/src/m_spdNode.F90 +++ b/src/gsi/m_spdNode.F90 @@ -23,8 +23,8 @@ module m_spdNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -72,6 +72,9 @@ module m_spdNode interface spdNode_typecast; module procedure typecast_ ; end interface interface spdNode_nextcast; module procedure nextcast_ ; end interface + public:: spdNode_appendto + interface spdNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_spdNode" #include "myassert.H" @@ -81,16 +84,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(spdNode) use m_obsNode, only: obsNode implicit none - type(spdNode),pointer:: ptr_ + type(spdNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(spdNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -99,15 +100,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(spdNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(spdNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(spdNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(spdNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_sstNode.F90 b/src/gsi/m_sstNode.F90 similarity index 89% rename from src/m_sstNode.F90 rename to src/gsi/m_sstNode.F90 index c22aba9bb..9afb24aaf 100644 --- a/src/m_sstNode.F90 +++ b/src/gsi/m_sstNode.F90 @@ -23,8 +23,8 @@ module m_sstNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,6 +71,9 @@ module m_sstNode interface sstNode_typecast; module procedure typecast_ ; end interface interface sstNode_nextcast; module procedure nextcast_ ; end interface + public:: sstNode_appendto + interface sstNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_sstNode" #include "myassert.H" @@ -80,16 +83,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(sstNode) use m_obsNode, only: obsNode implicit none - type(sstNode),pointer:: ptr_ + type(sstNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(sstNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -98,15 +99,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(sstNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(sstNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(sstNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(sstNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_stats.f90 b/src/gsi/m_stats.f90 similarity index 100% rename from src/m_stats.f90 rename to src/gsi/m_stats.f90 diff --git a/src/gsi/m_stubTimer.f90 b/src/gsi/m_stubTimer.f90 new file mode 100644 index 000000000..4b7099a6c --- /dev/null +++ b/src/gsi/m_stubTimer.f90 @@ -0,0 +1,235 @@ +module m_abstractTimer +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_abstractTimer +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2017-06-30 +! +! abstract: an abstract multi-timer replacing stub_timermod.f90 with m_stubTimer +! +! program history log: +! 2017-06-30 j guo - Replaced stub_timermod with this module and module +! m_stubTimer, in the same file m_stubTimer.f90. +! . With abstractTimer type and stubTimer type, this +! implementation is extensible either from abstractTimer +! or from default stubTimer. +! +! input argument list: see Fortran inline document below +! +! output argument list: see Fortran inline document below + +! attributes: +! language: Fortran 2003/2008 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use kinds , only: i_kind + use mpeu_util, only: tell + implicit none + private + public:: abstractTimer + public:: abstractTimer_typename + + interface abstractTimer_typename; module procedure typename_; end interface + + type, abstract:: abstractTimer + private + contains + procedure(mytype ),nopass,deferred:: mytype ! typename inquiry + procedure(on ), deferred:: on ! turn on a single named timer + procedure(off ), deferred:: off ! turn off a single named timer + procedure(reset ), deferred:: reset ! reset all timers + procedure(flush ), deferred:: flush ! summerize all local timers + procedure(allflush), deferred:: allflush ! reduce-summarize distributed timers + end type abstractTimer + + abstract interface + function mytype() result(type_) + implicit none + character(:),allocatable:: type_ + end function mytype + end interface + + abstract interface + subroutine on(tm,name) + import abstractTimer + implicit none + class(abstractTimer), intent(inout):: tm + character(len=*) , intent(in ):: name + end subroutine on + end interface + + abstract interface + subroutine off(tm,name) + import abstractTimer + implicit none + class(abstractTimer), intent(inout):: tm + character(len=*) , intent(in ):: name + end subroutine off + end interface + + abstract interface + subroutine reset(tm) + import abstractTimer + implicit none + class(abstractTimer), intent(inout):: tm + end subroutine reset + end interface + + abstract interface + subroutine flush(tm,lu) + import abstractTimer + import i_kind + implicit none + class(abstractTimer), intent(in):: tm + integer(kind=i_kind), intent(in):: lu + end subroutine flush + end interface + + abstract interface + subroutine allflush(tm,lu,comm,root) + import abstractTimer + import i_kind + implicit none + class(abstractTimer), intent(in):: tm + integer(kind=i_kind), intent(in):: lu + integer(kind=i_kind), intent(in):: comm + integer(kind=i_kind), intent(in):: root + end subroutine allflush + end interface + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='m_abstractTimer' + +contains +function typename_() result(typename) +!-- Return the type name. + implicit none + character(len=:),allocatable:: typename + typename="[abstractTimer]" +end function typename_ + +end module m_abstractTimer + +module m_stubTimer +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_abstractTimer +! prgmmr: todling org: gmao date: 2007-10-01 +! +! abstract: a do-nothing multi-timer +! +! program history log: +! 2007-10-01 todling - Original stub_timermod +! 2009-02-26 todling - if-def from GMAO_FVGSI to GEOS_PERT +! 2009-08-13 lueken - update documentation +! 2010-06-16 guo - separated stub implementation with implicit interfaces +! from module implementation with explicit interfaces. +! 2011-08-01 lueken - replaced F90 with f90 (no machine logic) +! 2017-06-30 j guo - replaced stub_timermod.f90 with this module and module +! m_stubTimer, in the same file m_stubTimer.f90. +! . With abstractTimer type and stubTimer type, this +! implementation is extensible either from abstractTimer +! or from default stubTimer. +! +! input argument list: see Fortran inline document below +! +! output argument list: see Fortran inline document below + +! attributes: +! language: Fortran 2003/2008 and/or above +! machine: +! +!$$$ end subprogram documentation block + + use m_abstractTimer, only: abstractTimer + use kinds , only: i_kind + use mpeu_util, only: tell,die + implicit none + private + public:: timer + public:: timer_typemold + + type, extends(abstractTimer):: timer + private + contains + ! see m_abstractTimer for more information + procedure,nopass:: mytype + procedure:: on + procedure:: off + procedure:: reset + procedure:: flush + procedure:: allflush + end type timer + + character(len=*),parameter:: myname ="m_stubTimer" + type(timer),target:: typemold_ + + logical,parameter:: verbose=.false. + !logical,parameter:: verbose=.true. + +contains + +function timer_typemold() result(typemold) +!-- return a mold of timer + implicit none + type(timer),pointer:: typemold + typemold => typemold_ +end function timer_typemold + +!-------------------------------------------------- +! type-bound-procedures. See type(abstrctTimer) in module +! m_abstractTimer for sepcifications. +function mytype() + implicit none + character(len=:), allocatable:: mytype + mytype="["//myname//"::timer]" +end function mytype + +subroutine on(tm,name) + implicit none + class(timer), intent(inout):: tm + character(len=*), intent(in):: name + if(verbose) call tell(tm%mytype()//'%on','timer = ',trim(name)) +end subroutine on + +subroutine off(tm,name) + implicit none + class(timer), intent(inout):: tm + character(len=*), intent(in):: name + if(verbose) call tell(tm%mytype()//'%off','timer = ',trim(name)) +end subroutine off + +subroutine reset(tm) + implicit none + class(timer), intent(inout):: tm + if(verbose) call tell(tm%mytype()//'%reset','no action taken') +end subroutine reset + +subroutine flush(tm,lu) + implicit none + class(timer) , intent(in):: tm + integer(kind=i_kind), intent(in):: lu + if(verbose) call tell(tm%mytype()//'%flush','no action taken, lu =',lu) +end subroutine flush + +subroutine allflush(tm,lu,comm,root) + use mpeu_mpif,only: MPI_ikind + implicit none + class(timer) , intent(in):: tm ! a handle to this timer + integer(kind=i_kind), intent(in):: lu ! output logic unit + integer(kind=i_kind), intent(in):: comm ! communicator + integer(kind=i_kind), intent(in):: root ! root PE + + character(len=*),parameter:: myname_=myname//'::allflush' + integer(kind=MPI_ikind):: myPE,ier + + call MPI_comm_rank(comm,myPE,ier) + if(ier/=0) call die(myname_,'MPI_comm_rank(), ierror =',ier) + if(verbose.and.myPE==root) call tell(tm%mytype()//'%allflush','no action taken, lu =',lu) +end subroutine allflush + +end module m_stubTimer diff --git a/src/gsi/m_swcpNode.F90 b/src/gsi/m_swcpNode.F90 new file mode 100644 index 000000000..6ca14721c --- /dev/null +++ b/src/gsi/m_swcpNode.F90 @@ -0,0 +1,368 @@ +module m_swcpNode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_swcpNode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type swcpNode (solid-water content path) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsNode, only: obsNode + implicit none + private + + public:: swcpNode + + type,extends(obsNode):: swcpNode + !type(swcp_ob_type),pointer :: llpoint => NULL() + type(obs_diag), pointer :: diags => NULL() + real(r_kind) :: res ! solid-water content path residual + real(r_kind) :: err2 ! solid-water content path error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: wij(4) ! horizontal interpolation weights + real(r_kind),dimension(:),pointer :: jac_t => NULL() + ! t jacobian + real(r_kind),dimension(:),pointer :: jac_p => NULL() + ! p jacobian + real(r_kind),dimension(:),pointer :: jac_q => NULL() + ! q jacobian + real(r_kind),dimension(:),pointer :: jac_qi => NULL() + ! qi jacobian + real(r_kind),dimension(:),pointer :: jac_qs => NULL() + ! qs jacobian + real(r_kind),dimension(:),pointer :: jac_qg => NULL() + ! qg jacobian + real(r_kind),dimension(:),pointer :: jac_qh => NULL() + ! qh jacobian +! real(r_kind),dimension(:),pointer :: dp => NULL() +! ! delta pressure at mid layers at obs locations + integer(i_kind),dimension(:,:),pointer :: ij => NULL() + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: setHop => obsNode_setHop_ + procedure:: xread => obsNode_xread_ + procedure:: xwrite => obsNode_xwrite_ + procedure:: isvalid => obsNode_isvalid_ + procedure:: gettlddp => gettlddp_ + + procedure, nopass:: headerRead => obsHeader_read_ + procedure, nopass:: headerWrite => obsHeader_write_ + procedure:: init => obsNode_init_ + procedure:: clean => obsNode_clean_ + end type swcpNode + + public:: swcpNode_typecast + public:: swcpNode_nextcast + interface swcpNode_typecast; module procedure typecast_ ; end interface + interface swcpNode_nextcast; module procedure nextcast_ ; end interface + + public:: swcpNode_appendto + interface swcpNode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: MYNAME="m_swcpNode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(swcpNode) + use m_obsNode, only: obsNode + implicit none + type(swcpNode),pointer:: ptr_ + class(obsNode),pointer,intent(in):: aNode + ptr_ => null() + if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(aNode) + type is(swcpNode) + ptr_ => aNode + end select +return +end function typecast_ + +function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(swcpNode) + use m_obsNode, only: obsNode,obsNode_next + implicit none + type(swcpNode),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) +return +end function nextcast_ + +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(swcpNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + +! obsNode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[swcpNode]" +end function mytype + +subroutine obsHeader_read_(iunit,mobs,jread,istat) + use gridmod, only: nsig + implicit none + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent(out):: mobs + integer(i_kind),intent(out):: jread + integer(i_kind),intent(out):: istat + + character(len=*),parameter:: myname_=myname//".obsHeader_read_" + integer(i_kind):: msig +_ENTRY_(myname_) + + read(iunit,iostat=istat) mobs,jread, msig + if(istat==0 .and. nsig/=msig) then + call perr(myname_,'unexpected dimension information, nsig =',nsig) + call perr(myname_,' but read msig =',msig) + call die(myname_) + endif +_EXIT_(myname_) +return +end subroutine obsHeader_read_ + +subroutine obsHeader_write_(junit,mobs,jwrite,jstat) + use gridmod, only: nsig + implicit none + integer(i_kind),intent(in ):: junit + integer(i_kind),intent(in ):: mobs + integer(i_kind),intent(in ):: jwrite + integer(i_kind),intent(out):: jstat + + character(len=*),parameter:: myname_=myname//".obsHeader_write_" +_ENTRY_(myname_) + write(junit,iostat=jstat) mobs,jwrite, nsig +_EXIT_(myname_) +return +end subroutine obsHeader_write_ + +subroutine obsNode_init_(aNode) + use gridmod, only: nsig + implicit none + class(swcpNode),intent(out):: aNode + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_init_' +_ENTRY_(myname_) + aNode%llpoint => null() + aNode%luse = .false. + aNode%elat = 0._r_kind + aNode%elon = 0._r_kind + aNode%time = 0._r_kind + aNode%idv =-1 + aNode%iob =-1 + allocate(aNode%jac_t(nsig ), & + aNode%jac_p(nsig+1), & + aNode%jac_q(nsig ), & + aNode%jac_qi(nsig ), & + aNode%jac_qs(nsig ), & + aNode%jac_qg(nsig ), & + aNode%jac_qh(nsig ), & + aNode%ij(4, nsig ) ) +! allocate(aNode%dp(nsig)) +_EXIT_(myname_) +return +end subroutine obsNode_init_ + +subroutine obsNode_clean_(aNode) + implicit none + class(swcpNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_clean_' +_ENTRY_(myname_) +!_TRACEV_(myname_,'%mytype() =',aNode%mytype()) + if(associated(aNode%jac_t )) deallocate(aNode%jac_t ) + if(associated(aNode%jac_p )) deallocate(aNode%jac_p ) + if(associated(aNode%jac_q )) deallocate(aNode%jac_q ) + if(associated(aNode%jac_qi)) deallocate(aNode%jac_qi) + if(associated(aNode%jac_qs)) deallocate(aNode%jac_qs) + if(associated(aNode%jac_qg)) deallocate(aNode%jac_qg) + if(associated(aNode%jac_qh)) deallocate(aNode%jac_qh) +! if(associated(aNode%dp )) deallocate(aNode%dp ) + if(associated(aNode%ij )) deallocate(aNode%ij ) +_EXIT_(myname_) +return +end subroutine obsNode_clean_ + +subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) + use m_obsdiagNode, only: obsdiagLookup_locate + implicit none + class(swcpNode) , intent(inout):: aNode + integer(i_kind) , intent(in ):: iunit + integer(i_kind) , intent( out):: istat + type(obs_diags) , intent(in ):: diagLookup + logical,optional, intent(in ):: skip + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_' + logical:: skip_ +_ENTRY_(myname_) + skip_=.false. + if(present(skip)) skip_=skip + + istat=0 + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) aNode%res , & + aNode%err2 , & + aNode%raterr2, & + aNode%b , & + aNode%pg , & + aNode%wij , & !(4) + aNode%jac_t , & !( nsig) + aNode%jac_p , & !( nsig) + aNode%jac_q , & !( nsig) + aNode%jac_qi , & !( nsig) + aNode%jac_qs , & !( nsig) + aNode%jac_qg , & !( nsig) + aNode%jac_qh , & !(4,nsig) + aNode%ij +! aNode%dp + if (istat/=0) then + call perr(myname_,'read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) + if(.not.associated(aNode%diags)) then + call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) + call perr(myname_,' %iob =',aNode%iob) + call die(myname_) + endif + endif +_EXIT_(myname_) +return +end subroutine obsNode_xread_ + +subroutine obsNode_xwrite_(aNode,junit,jstat) + implicit none + class(swcpNode),intent(in):: aNode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_' +_ENTRY_(myname_) + + jstat=0 + write(junit,iostat=jstat) aNode%res , & + aNode%err2 , & + aNode%raterr2, & + aNode%b , & + aNode%pg , & + aNode%wij , & + aNode%jac_t , & + aNode%jac_p , & + aNode%jac_q , & + aNode%jac_qi , & + aNode%jac_qs , & + aNode%jac_qg , & + aNode%jac_qh , & + aNode%ij +! aNode%dp + if (jstat/=0) then + call perr(myname_,'write(%(res,err2,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) +return +end subroutine obsNode_xwrite_ + +subroutine obsNode_setHop_(aNode) + use m_cvgridLookup, only: cvgridLookup_getiw + use gridmod, only: nsig,latlon11 + implicit none + class(swcpNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' + integer(i_kind):: k +_ENTRY_(myname_) + + ASSERT(size(aNode%ij,2)==nsig) + ASSERT(nsig>0) + + call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij(:,1),aNode%wij) + do k=2,nsig + aNode%ij(:,k) = aNode%ij(:,1)+(k-1)*latlon11 + enddo +_EXIT_(myname_) +return +end subroutine obsNode_setHop_ + +function obsNode_isvalid_(aNode) result(isvalid_) + implicit none + logical:: isvalid_ + class(swcpNode),intent(in):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' +_ENTRY_(myname_) + isvalid_=associated(aNode%diags) +_EXIT_(myname_) +return +end function obsNode_isvalid_ + +pure subroutine gettlddp_(aNode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(swcpNode), intent(in):: aNode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 +return +end subroutine gettlddp_ + +end module m_swcpNode diff --git a/src/m_tNode.F90 b/src/gsi/m_tNode.F90 similarity index 89% rename from src/m_tNode.F90 rename to src/gsi/m_tNode.F90 index 1fceaf4a3..902e254db 100644 --- a/src/m_tNode.F90 +++ b/src/gsi/m_tNode.F90 @@ -23,8 +23,8 @@ module m_tNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -62,6 +62,9 @@ module m_tNode !real (r_kind) :: elat, elon ! earth lat-lon for redistribution !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution real (r_kind) :: dlev ! reference to the vertical grid + + integer(i_kind) :: ich0=0 ! ich code to mark derived data. See + ! tNode_ich0 and tNode_ich0_PBL_Pseudo below contains procedure,nopass:: mytype procedure:: setHop => obsNode_setHop_ @@ -81,6 +84,14 @@ module m_tNode interface tNode_typecast; module procedure typecast_ ; end interface interface tNode_nextcast; module procedure nextcast_ ; end interface + public:: tNode_appendto + interface tNode_appendto; module procedure appendto_ ; end interface + + public:: tNode_ich0 + public:: tNode_ich0_pbl_pseudo + integer(i_kind),parameter:: tNode_ich0 = 0 + integer(i_kind),parameter:: tNode_ich0_pbl_pseudo = tNode_ich0+1 + character(len=*),parameter:: MYNAME="m_tNode" #include "myassert.H" @@ -90,16 +101,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(tNode) use m_obsNode, only: obsNode implicit none - type(tNode),pointer:: ptr_ + type(tNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(tNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -108,15 +117,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(tNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(tNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(tNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(tNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() @@ -205,6 +228,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%k1 , & aNode%kx , & aNode%dlev , & + aNode%ich0 , & aNode%wij , & aNode%ij if(istat/=0) then @@ -230,6 +254,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%k1 , & aNode%kx , & aNode%dlev , & + aNode%ich0 , & aNode%wij , & aNode%ij if(istat/=0) then @@ -241,10 +266,11 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) endif end if - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) + aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,aNode%ich0+1_i_kind) if(.not.associated(aNode%diags)) then call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) call perr(myname_,' %iob =',aNode%iob) + call perr(myname_,' %ich0 =',aNode%ich0) call die(myname_) endif endif @@ -277,6 +303,7 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%k1 , & aNode%kx , & aNode%dlev , & + aNode%ich0 , & aNode%wij , & aNode%ij if(jstat/=0) then @@ -302,6 +329,7 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%k1 , & aNode%kx , & aNode%dlev , & + aNode%ich0 , & aNode%wij , & aNode%ij if(jstat/=0) then diff --git a/src/m_tcamtNode.F90 b/src/gsi/m_tcamtNode.F90 similarity index 89% rename from src/m_tcamtNode.F90 rename to src/gsi/m_tcamtNode.F90 index 4f2382ea8..8598c1d84 100644 --- a/src/m_tcamtNode.F90 +++ b/src/gsi/m_tcamtNode.F90 @@ -24,8 +24,8 @@ module m_tcamtNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,6 +71,9 @@ module m_tcamtNode interface tcamtNode_typecast; module procedure typecast_ ; end interface interface tcamtNode_nextcast; module procedure nextcast_ ; end interface + public:: tcamtNode_appendto + interface tcamtNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_tcamtNode" #include "myassert.H" @@ -80,15 +83,13 @@ function typecast_(aNode) result(ptr_) use m_obsNode, only: obsNode implicit none type(tcamtNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" + class(obsNode ),pointer,intent(in):: aNode ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(tcamtNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -97,13 +98,28 @@ function nextcast_(aNode) result(ptr_) use m_obsNode, only: obsNode,obsNode_next implicit none type(tcamtNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode ),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(tcamtNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_tcpNode.F90 b/src/gsi/m_tcpNode.F90 similarity index 89% rename from src/m_tcpNode.F90 rename to src/gsi/m_tcpNode.F90 index f0ffd4f1a..6a5edf5e7 100644 --- a/src/m_tcpNode.F90 +++ b/src/gsi/m_tcpNode.F90 @@ -23,8 +23,8 @@ module m_tcpNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,6 +71,9 @@ module m_tcpNode interface tcpNode_typecast; module procedure typecast_ ; end interface interface tcpNode_nextcast; module procedure nextcast_ ; end interface + public:: tcpNode_appendto + interface tcpNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_tcpNode" #include "myassert.H" @@ -80,16 +83,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(tcpNode) use m_obsNode, only: obsNode implicit none - type(tcpNode),pointer:: ptr_ + type(tcpNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(tcpNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -98,15 +99,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(tcpNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(tcpNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(tcpNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(tcpNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_td2mNode.F90 b/src/gsi/m_td2mNode.F90 similarity index 89% rename from src/m_td2mNode.F90 rename to src/gsi/m_td2mNode.F90 index 381c69bc9..3ad005dc6 100644 --- a/src/m_td2mNode.F90 +++ b/src/gsi/m_td2mNode.F90 @@ -24,8 +24,8 @@ module m_td2mNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,39 +71,57 @@ module m_td2mNode interface td2mNode_typecast; module procedure typecast_ ; end interface interface td2mNode_nextcast; module procedure nextcast_ ; end interface + public:: td2mNode_appendto + interface td2mNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_td2mNode" #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(td2mNode) use m_obsNode, only: obsNode implicit none type(td2mNode),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(td2mNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(td2mNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(td2mNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(td2mNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_tick.F90 b/src/gsi/m_tick.F90 similarity index 95% rename from src/m_tick.F90 rename to src/gsi/m_tick.F90 index 2ef19f175..b2285f578 100644 --- a/src/m_tick.F90 +++ b/src/gsi/m_tick.F90 @@ -185,18 +185,18 @@ integer(i_kind) FUNCTION INCYMD (NYMD,M) IF (NM==2 .AND. leap_year(NY)) ND = 29 ENDIF - IF (ND==29 .AND. NM==2 .AND. leap_year(ny)) GO TO 20 - - IF (ND>NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM>12) THEN - NM = 1 - NY = NY + 1 + IF (.not. (ND==29 .AND. NM==2 .AND. leap_year(ny))) then + + IF (ND>NDPM(NM)) THEN + ND = 1 + NM = NM + 1 + IF (NM>12) THEN + NM = 1 + NY = NY + 1 + ENDIF ENDIF - ENDIF - 20 CONTINUE + end if INCYMD = NY*10000 + NM*100 + ND RETURN END function INCYMD diff --git a/src/m_uniq.f90 b/src/gsi/m_uniq.f90 similarity index 100% rename from src/m_uniq.f90 rename to src/gsi/m_uniq.f90 diff --git a/src/m_uwnd10mNode.F90 b/src/gsi/m_uwnd10mNode.F90 similarity index 88% rename from src/m_uwnd10mNode.F90 rename to src/gsi/m_uwnd10mNode.F90 index 0220d1bfc..b41cc4da4 100644 --- a/src/m_uwnd10mNode.F90 +++ b/src/gsi/m_uwnd10mNode.F90 @@ -25,8 +25,8 @@ module m_uwnd10mNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -72,41 +72,57 @@ module m_uwnd10mNode interface uwnd10mNode_typecast; module procedure typecast_ ; end interface interface uwnd10mNode_nextcast; module procedure nextcast_ ; end interface + public:: uwnd10mNode_appendto + interface uwnd10mNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_uwnd10mNode" -!#define CHECKSUM_VERBOSE -!#define DEBUG_TRACE #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(uwnd10mNode) use m_obsNode, only: obsNode implicit none type(uwnd10mNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" + class(obsNode ),pointer,intent(in):: aNode ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(uwnd10mNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(uwnd10mNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(uwnd10mNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode ),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(uwnd10mNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_visNode.F90 b/src/gsi/m_visNode.F90 similarity index 89% rename from src/m_visNode.F90 rename to src/gsi/m_visNode.F90 index 91fc3c9f9..525deb100 100644 --- a/src/m_visNode.F90 +++ b/src/gsi/m_visNode.F90 @@ -23,8 +23,8 @@ module m_visNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -69,6 +69,9 @@ module m_visNode interface visNode_typecast; module procedure typecast_ ; end interface interface visNode_nextcast; module procedure nextcast_ ; end interface + public:: visNode_appendto + interface visNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_visNode" #include "myassert.H" @@ -78,16 +81,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(visNode) use m_obsNode, only: obsNode implicit none - type(visNode),pointer:: ptr_ + type(visNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(visNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -96,15 +97,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(visNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(visNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(visNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(visNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_vwnd10mNode.F90 b/src/gsi/m_vwnd10mNode.F90 similarity index 89% rename from src/m_vwnd10mNode.F90 rename to src/gsi/m_vwnd10mNode.F90 index 60a6cff81..c5b09da81 100644 --- a/src/m_vwnd10mNode.F90 +++ b/src/gsi/m_vwnd10mNode.F90 @@ -25,8 +25,8 @@ module m_vwnd10mNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -72,41 +72,57 @@ module m_vwnd10mNode interface vwnd10mNode_typecast; module procedure typecast_ ; end interface interface vwnd10mNode_nextcast; module procedure nextcast_ ; end interface + public:: vwnd10mNode_appendto + interface vwnd10mNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_vwnd10mNode" -!#define CHECKSUM_VERBOSE -!#define DEBUG_TRACE #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(vwnd10mNode) use m_obsNode, only: obsNode implicit none type(vwnd10mNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" + class(obsNode ),pointer,intent(in):: aNode ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(vwnd10mNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(vwnd10mNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(vwnd10mNode),pointer:: ptr_ class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(vwnd10mNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/m_wNode.F90 b/src/gsi/m_wNode.F90 similarity index 82% rename from src/m_wNode.F90 rename to src/gsi/m_wNode.F90 index aea4f9b93..43190b75c 100644 --- a/src/m_wNode.F90 +++ b/src/gsi/m_wNode.F90 @@ -23,8 +23,8 @@ module m_wNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -59,6 +59,9 @@ module m_wNode !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution real (r_kind) :: dlev ! reference to the vertical grid real (r_kind) :: factw ! factor of 10m wind + + integer(i_kind) :: ich0=0 ! ich code to mark derived data. See + ! wNode_ich0 and wNode_ich0_PBL_Pseudo below contains procedure,nopass:: mytype procedure:: setHop => obsNode_setHop_ @@ -78,6 +81,18 @@ module m_wNode interface wNode_typecast; module procedure typecast_ ; end interface interface wNode_nextcast; module procedure nextcast_ ; end interface + public:: wNode_appendto + interface wNode_appendto; module procedure appendto_ ; end interface + + ! Because there are two components in wNode for an ordinary wind obs, + ! ich values are set to (1,2). Therefore, ich values for PBL_pseudo_surfobsUV + ! are set to (3,4), and wNode_ich0_pbl_pseudo is set to 2. + + public:: wNode_ich0 + public:: wNode_ich0_PBL_pseudo + integer(i_kind),parameter :: wNode_ich0 = 0 ! (1,2) + integer(i_kind),parameter :: wNode_ich0_PBL_pseudo = wNode_ich0+2 ! (3,4) + character(len=*),parameter:: MYNAME="m_wNode" #include "myassert.H" @@ -87,16 +102,14 @@ function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(wNode) use m_obsNode, only: obsNode implicit none - type(wNode),pointer:: ptr_ + type(wNode ),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(wNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ @@ -105,15 +118,29 @@ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(wNode) use m_obsNode, only: obsNode,obsNode_next implicit none - type(wNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode + type(wNode ),pointer:: ptr_ + class(obsNode),target ,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(wNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() @@ -160,6 +187,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%kx , & aNode%dlev , & aNode%factw , & + aNode%ich0 , & aNode%wij , & aNode%ij if (istat/=0) then @@ -168,17 +196,18 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) return end if - aNode%diagu => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) - aNode%diagv => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,2_i_kind) + aNode%diagu => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,aNode%ich0+1_i_kind) + aNode%diagv => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,aNode%ich0+2_i_kind) if(.not. (associated(aNode%diagu) .and. & associated(aNode%diagv) ) ) then call perr(myname_,'obsdiagLookup_locate(u,v), %idv =',aNode%idv) call perr(myname_,' %iob =',aNode%iob) + call perr(myname_,' %ich0 =',aNode%ich0) if(.not.associated(aNode%diagu)) & - call perr(myname_,' can not locate %diagu, ich =',1_i_kind) + call perr(myname_,' .not.associated(%diagu), ich =',aNode%ich0+1_i_kind) if(.not.associated(aNode%diagv)) & - call perr(myname_,' can not locate %diagv, ich =',2_i_kind) + call perr(myname_,' .not.associated(%diagv), ich =',aNode%ich0+2_i_kind) call die(myname_) endif endif @@ -209,6 +238,7 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%kx , & aNode%dlev , & aNode%factw , & + aNode%ich0 , & aNode%wij , & aNode%ij if (jstat/=0) then diff --git a/src/m_wspd10mNode.F90 b/src/gsi/m_wspd10mNode.F90 similarity index 87% rename from src/m_wspd10mNode.F90 rename to src/gsi/m_wspd10mNode.F90 index f435fc32a..646ab2d99 100644 --- a/src/m_wspd10mNode.F90 +++ b/src/gsi/m_wspd10mNode.F90 @@ -1,7 +1,7 @@ module m_wspd10mNode !$$$ subprogram documentation block ! . . . . -! subprogram: module m_wspd10mlNode +! subprogram: module m_wspd10mNode ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2016-05-18 @@ -24,8 +24,8 @@ module m_wspd10mNode !$$$ end subprogram documentation block ! module interface: - use obsmod, only: obs_diag - use obsmod, only: obs_diags + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags use kinds , only: i_kind,r_kind use mpeu_util, only: assert_,die,perr,warn,tell use m_obsNode, only: obsNode @@ -71,39 +71,57 @@ module m_wspd10mNode interface wspd10mNode_typecast; module procedure typecast_ ; end interface interface wspd10mNode_nextcast; module procedure nextcast_ ; end interface + public:: wspd10mNode_appendto + interface wspd10mNode_appendto; module procedure appendto_ ; end interface + character(len=*),parameter:: MYNAME="m_wspd10mNode" #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(wspd10mNode) use m_obsNode, only: obsNode implicit none type(wspd10mNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" + class(obsNode ),pointer,intent(in):: aNode ptr_ => null() if(.not.associated(aNode)) return + ! logically, typecast of a null-reference is a null pointer. select type(aNode) type is(wspd10mNode) ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) end select return end function typecast_ function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(wspd10mNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(wspd10mNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) + class(obsNode ),target ,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) return end function nextcast_ +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(wspd10mNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + ! obsNode implementations function mytype() diff --git a/src/make_depend.bash b/src/gsi/make_depend.bash similarity index 100% rename from src/make_depend.bash rename to src/gsi/make_depend.bash diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90 new file mode 100644 index 000000000..d3b4a1032 --- /dev/null +++ b/src/gsi/mod_fv3_lola.f90 @@ -0,0 +1,935 @@ +module mod_fv3_lola +!$$$ module documentation block +! . . . . +! module: mod_fv3_lola +! prgmmr: parrish +! +! abstract: This module contains routines to interpolate from a single +! fv3 D grid tile to a rotated lat-lon analysis grid which completely +! covers the fv3 tile. Points beyond the fv3 tile are +! filled with nearest fv3 edge values, but have no actual +! impact on the analysis. +! +! program history log: +! 2017-02-24 parrish--initial documentation (patterned after +! mod_fv3_to_a.f90) +! 2017-10-10 wu w - setup interpolation and trnsform coeff in generate_anl_grid +! add routines earthuv2fv3, fv3uv2earth, fv3_h_to_ll +! fv3_ll_to_h +! 2019-11-01 wu - add checks in generate_anl_grid to present the mean +! longitude correctly to fix problem near lon=0 +! +! subroutines included: +! sub generate_anl_grid +! sub earthuv2fv3 +! sub fv3uv2earth +! sub fv3_h_to_ll +! sub fv3_ll_to_h +! sub rotate2deg +! sub unrotate2deg +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +! DIAGRAM: D-Grid layout: +! +! 1 nx +! . . (U,H) +! +! 1 nx +1 +! . . (V) + +! U U U U U U + ny +1 (for U) +! V H V H V H V H V H V H V + ny (for V,H) +! U U U U U U xh(i) = i dx=1 +! V H V H V H V H V H V H V xu(i) = i +! U U U U U U xv(i) = i-0.5 +! V H V H V H V H V H V H V +! U U U U U U yh(j) = j dy=1 +! V H V H V H V H V H V H V yu(j) = j-0.5 +! U U U U U U yv(j) = j +! V H V H V H V H V H V H V +! U U U U U U +! V H V H V H V H V H V H V + 1 (for V,H) +! U U U U U U + 1 (for U) + +! U(nx ,ny +1),V(nx +1,ny ),H(nx ,ny ) + + use kinds, only: r_kind,i_kind + implicit none +! + private + public :: generate_anl_grid,fv3_h_to_ll,fv3_ll_to_h,fv3uv2earth,earthuv2fv3 + public :: fv3dx,fv3dx1,fv3dy,fv3dy1,fv3ix,fv3ixp,fv3jy,fv3jyp,a3dx,a3dx1,a3dy,a3dy1,a3ix,a3ixp,a3jy,a3jyp + public :: nxa,nya,cangu,sangu,cangv,sangv,nx,ny,bilinear + + logical bilinear + integer(i_kind) nxa,nya,nx,ny + real(r_kind) ,allocatable,dimension(:,:):: fv3dx,fv3dx1,fv3dy,fv3dy1 + integer(i_kind),allocatable,dimension(:,:):: fv3ix,fv3ixp,fv3jy,fv3jyp + real(r_kind) ,allocatable,dimension(:,:):: a3dx,a3dx1,a3dy,a3dy1 + real(r_kind) ,allocatable,dimension(:,:):: cangu,sangu,cangv,sangv + integer(i_kind),allocatable,dimension(:,:):: a3ix,a3ixp,a3jy,a3jyp + + +contains + +subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) +!$$$ subprogram documentation block +! . . . . +! subprogram: generate_anl_grid +! prgmmr: parrish +! +! abstract: define rotated lat-lon analysis grid which is centered on fv3 tile +! and oriented to completely cover the tile. +! +! program history log: +! 2017-05-02 parrish +! 2017-10-10 wu - 1. setup analysis A-grid, +! 2. compute/setup FV3 to A grid interpolation parameters +! 3. compute/setup A to FV3 grid interpolation parameters +! 4. setup weightings for wind conversion from FV3 to earth +! 2019-11-01 wu - add checks to present the mean longitude correctly to fix +! problem near lon=0 +! +! input argument list: +! nx, ny - number of cells = nx*ny +! grid_lon ,grid_lat - longitudes and latitudes of fv3 grid cell corners +! grid_lont,grid_latt - longitudes and latitudes of fv3 grid cell centers +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + use constants, only: quarter,one,two,half,zero,deg2rad,rearth,rad2deg + use gridmod, only:grid_ratio_fv3_regional, region_lat,region_lon,nlat,nlon + use gridmod, only: region_dy,region_dx,region_dyi,region_dxi,coeffy,coeffx + use gridmod, only:init_general_transform,region_dy,region_dx + use mpimod, only: mype + use egrid2agrid_mod, only: egrid2agrid_parm + implicit none + + real(r_kind),allocatable,dimension(:)::xbh_a,xa_a,xa_b + real(r_kind),allocatable,dimension(:)::ybh_a,ya_a,ya_b,yy + real(r_kind),allocatable,dimension(:,:)::xbh_b,ybh_b + real(r_kind) dlat,dlon,dyy,dxx,dyyi,dxxi + real(r_kind) dyyh,dxxh + + + integer(i_kind), intent(in ) :: nx,ny ! fv3 tile x- and y-dimensions + real(r_kind) , intent(inout) :: grid_lon(nx+1,ny+1) ! fv3 cell corner longitudes + real(r_kind) , intent(inout) :: grid_lont(nx,ny) ! fv3 cell center longitudes + real(r_kind) , intent(inout) :: grid_lat(nx+1,ny+1) ! fv3 cell corner latitudes + real(r_kind) , intent(inout) :: grid_latt(nx,ny) ! fv3 cell center latitudes + + integer(i_kind) i,j,ir,jr,n + real(r_kind),allocatable,dimension(:,:) :: xc,yc,zc,gclat,gclon,gcrlat,gcrlon,rlon_in,rlat_in + real(r_kind),allocatable,dimension(:,:) :: glon_an,glat_an + real(r_kind) xcent,ycent,zcent,rnorm,centlat,centlon + real(r_kind) adlon,adlat,alon,clat,clon + integer(i_kind) nlonh,nlath,nxh,nyh + integer(i_kind) ib1,ib2,jb1,jb2,jj + + integer(i_kind) nord_e2a + real(r_kind)gxa,gya + + real(r_kind) x(nx+1,ny+1),y(nx+1,ny+1),z(nx+1,ny+1), xr,yr,zr,xu,yu,zu,rlat,rlon + real(r_kind) xv,yv,zv,vval + real(r_kind) cx,cy + real(r_kind) uval,ewval,nsval + real(r_kind) diff,sq180 + real(r_kind) d(4),ds + integer(i_kind) kk,k + + + nord_e2a=4 + bilinear=.false. + + +! create xc,yc,zc for the cell centers. + allocate(xc(nx,ny)) + allocate(yc(nx,ny)) + allocate(zc(nx,ny)) + allocate(gclat(nx,ny)) + allocate(gclon(nx,ny)) + allocate(gcrlat(nx,ny)) + allocate(gcrlon(nx,ny)) + do j=1,ny + do i=1,nx + xc(i,j)=cos(grid_latt(i,j)*deg2rad)*cos(grid_lont(i,j)*deg2rad) + yc(i,j)=cos(grid_latt(i,j)*deg2rad)*sin(grid_lont(i,j)*deg2rad) + zc(i,j)=sin(grid_latt(i,j)*deg2rad) + enddo + enddo + +! compute center as average x,y,z coordinates of corners of domain -- + + xcent=quarter*(xc(1,1)+xc(1,ny)+xc(nx,1)+xc(nx,ny)) + ycent=quarter*(yc(1,1)+yc(1,ny)+yc(nx,1)+yc(nx,ny)) + zcent=quarter*(zc(1,1)+zc(1,ny)+zc(nx,1)+zc(nx,ny)) + + rnorm=one/sqrt(xcent**2+ycent**2+zcent**2) + xcent=rnorm*xcent + ycent=rnorm*ycent + zcent=rnorm*zcent + centlat=asin(zcent)*rad2deg + centlon=atan2(ycent,xcent)*rad2deg + +!! compute new lats, lons + call rotate2deg(grid_lont,grid_latt,gcrlon,gcrlat, & + centlon,centlat,nx,ny) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! compute analysis A-grid lats, lons +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!--------------------------obtain analysis grid dimensions nxa,nya + nxa=1+nint((nx-one)/grid_ratio_fv3_regional) + nya=1+nint((ny-one)/grid_ratio_fv3_regional) + nlat=nya + nlon=nxa + if(mype==0) print *,'nlat,nlon=nya,nxa= ',nlat,nlon + +!--------------------------obtain analysis grid spacing + dlat=(maxval(gcrlat)-minval(gcrlat))/(ny-1) + dlon=(maxval(gcrlon)-minval(gcrlon))/(nx-1) + adlat=dlat*grid_ratio_fv3_regional + adlon=dlon*grid_ratio_fv3_regional + +!-------setup analysis A-grid; find center of the domain + nlonh=nlon/2 + nlath=nlat/2 + + if(nlonh*2==nlon)then + clon=adlon/two + cx=half + else + clon=adlon + cx=one + endif + + if(nlath*2==nlat)then + clat=adlat/two + cy=half + else + clat=adlat + cy=one + endif + +! +!-----setup analysis A-grid from center of the domain +! + allocate(rlat_in(nlat,nlon),rlon_in(nlat,nlon)) + do j=1,nlon + alon=(j-nlonh)*adlon-clon + do i=1,nlat + rlon_in(i,j)=alon + enddo + enddo + + + do j=1,nlon + do i=1,nlat + rlat_in(i,j)=(i-nlath)*adlat-clat + enddo + enddo + + if (allocated(region_dx )) deallocate(region_dx ) + if (allocated(region_dy )) deallocate(region_dy ) + allocate(region_dx(nlat,nlon),region_dy(nlat,nlon)) + allocate(region_dxi(nlat,nlon),region_dyi(nlat,nlon)) + allocate(coeffx(nlat,nlon),coeffy(nlat,nlon)) + dyy=rearth*adlat*deg2rad + dyyi=one/dyy + dyyh=half/dyy + do j=1,nlon + do i=1,nlat + region_dy(i,j)=dyy + region_dyi(i,j)=dyyi + coeffy(i,j)=dyyh + enddo + enddo + + do i=1,nlat + dxx=rearth*cos(rlat_in(i,1)*deg2rad)*adlon*deg2rad + dxxi=one/dxx + dxxh=half/dxx + do j=1,nlon + region_dx(i,j)=dxx + region_dxi(i,j)=dxxi + coeffx(i,j)=dxxh + enddo + enddo + +! +!---------- setup region_lat,region_lon in earth coord +! + if (allocated(region_lat)) deallocate(region_lat) + if (allocated(region_lon)) deallocate(region_lon) + allocate(region_lat(nlat,nlon),region_lon(nlat,nlon)) + allocate(glat_an(nlon,nlat),glon_an(nlon,nlat)) + + call unrotate2deg(region_lon,region_lat,rlon_in,rlat_in, & + centlon,centlat,nlat,nlon) + + region_lat=region_lat*deg2rad + region_lon=region_lon*deg2rad + + do j=1,nlat + do i=1,nlon + glat_an(i,j)=region_lat(j,i) + glon_an(i,j)=region_lon(j,i) + enddo + enddo + + call init_general_transform(glat_an,glon_an) + + deallocate(glat_an,glon_an) + +!--------------------compute all combinations of relative coordinates + + allocate(xbh_a(nx),xbh_b(nx,ny),xa_a(nxa),xa_b(nxa)) + allocate(ybh_a(ny),ybh_b(nx,ny),ya_a(nya),ya_b(nya)) + + nxh=nx/2 + nyh=ny/2 + +!!!!!! fv3 rotated grid; not equal spacing, non_orthogonal !!!!!! + do j=1,ny + jr=ny+1-j + do i=1,nx + ir=nx+1-i + xbh_b(ir,jr)=gcrlon(i,j)/dlon + end do + end do + do j=1,ny + jr=ny+1-j + do i=1,nx + ir=nx+1-i + ybh_b(ir,jr)=gcrlat(i,j)/dlat + end do + end do + +!!!! define analysis A grid !!!!!!!!!!!!! + do j=1,nxa + xa_a(j)=(float(j-nlonh)-cx)*grid_ratio_fv3_regional + end do + do i=1,nya + ya_a(i)=(float(i-nlath)-cy)*grid_ratio_fv3_regional + end do + +!!!!!compute fv3 to A grid interpolation parameters !!!!!!!!! + allocate ( fv3dx(nxa,nya),fv3dx1(nxa,nya),fv3dy(nxa,nya),fv3dy1(nxa,nya) ) + allocate ( fv3ix(nxa,nya),fv3ixp(nxa,nya),fv3jy(nxa,nya),fv3jyp(nxa,nya) ) + allocate(yy(ny)) + +! iteration to find the fv3 grid cell + jb1=1 + ib1=1 + do j=1,nya + do i=1,nxa + do n=1,3 + gxa=xa_a(i) + if(gxa < xbh_b(1,jb1))then + gxa= 1 + else if(gxa > xbh_b(nx,jb1))then + gxa= nx + else + call grdcrd1(gxa,xbh_b(1,jb1),nx,1) + endif + ib2=ib1 + ib1=gxa + do jj=1,ny + yy(jj)=ybh_b(ib1,jj) + enddo + gya=ya_a(j) + if(gya < yy(1))then + gya= 1 + else if(gya > yy(ny))then + gya= ny + else + call grdcrd1(gya,yy,ny,1) + endif + jb2=jb1 + jb1=gya + + if((ib1 == ib2) .and. (jb1 == jb2)) exit + if(n==3 ) then +!!!!!!! if not converge, find the nearest corner point + d(1)=(xa_a(i)-xbh_b(ib1,jb1))**2+(ya_a(j)-ybh_b(ib1,jb1))**2 + d(2)=(xa_a(i)-xbh_b(ib1+1,jb1))**2+(ya_a(j)-ybh_b(ib1+1,jb1))**2 + d(3)=(xa_a(i)-xbh_b(ib1,jb1+1))**2+(ya_a(j)-ybh_b(ib1,jb1+1))**2 + d(4)=(xa_a(i)-xbh_b(ib1+1,jb1+1))**2+(ya_a(j)-ybh_b(ib1+1,jb1+1))**2 + kk=1 + do k=2,4 + if(d(k) xa_a(nxa))then + gxa= nxa + else + call grdcrd1(gxa,xa_a,nxa,1) + endif + a3ix(j,i)=int(gxa) + a3ix(j,i)=min(max(1,a3ix(j,i)),nxa) + a3dx(j,i)=max(zero,min(one,gxa-a3ix(j,i))) + a3dx1(j,i)=one-a3dx(j,i) + a3ixp(j,i)=min(nxa,a3ix(j,i)+1) + end do + end do + + do i=1,nx + do j=1,ny + gya=ybh_b(i,j) + if(gya < ya_a(1))then + gya= 1 + else if(gya > ya_a(nya))then + gya= nya + else + call grdcrd1(gya,ya_a,nya,1) + endif + a3jy(j,i)=int(gya) + a3jy(j,i)=min(max(1,a3jy(j,i)),nya) + a3dy(j,i)=max(zero,min(one,gya-a3jy(j,i))) + a3dy1(j,i)=one-a3dy(j,i) + a3jyp(j,i)=min(ny,a3jy(j,i)+1) + end do + end do + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! find coefficients for wind conversion btw FV3 & earth +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + allocate ( cangu(nx,ny+1),sangu(nx,ny+1),cangv(nx+1,ny),sangv(nx+1,ny) ) + +! 1. compute x,y,z at cell cornor from grid_lon, grid_lat + + do j=1,ny+1 + do i=1,nx+1 + x(i,j)=cos(grid_lat(i,j)*deg2rad)*cos(grid_lon(i,j)*deg2rad) + y(i,j)=cos(grid_lat(i,j)*deg2rad)*sin(grid_lon(i,j)*deg2rad) + z(i,j)=sin(grid_lat(i,j)*deg2rad) + enddo + enddo + +! 2 find angles to E-W and N-S for U edges + sq180=180._r_kind**2 + do j=1,ny+1 + do i=1,nx +! center lat/lon of the edge + rlat=half*(grid_lat(i,j)+grid_lat(i+1,j)) + diff=(grid_lon(i,j)-grid_lon(i+1,j))**2 + if(diff < sq180)then + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) + else + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)-360._r_kind) + endif +! vector to center of the edge + xr=cos(rlat*deg2rad)*cos(rlon*deg2rad) + yr=cos(rlat*deg2rad)*sin(rlon*deg2rad) + zr=sin(rlat*deg2rad) +! vector of the edge + xu= x(i+1,j)-x(i,j) + yu= y(i+1,j)-y(i,j) + zu= z(i+1,j)-z(i,j) +! find angle with cross product + uval=sqrt((xu**2+yu**2+zu**2)) + ewval=sqrt((xr**2+yr**2)) + nsval=sqrt((xr*zr)**2+(zr*yr)**2+(xr*xr+yr*yr)**2) + cangu(i,j)=(-yr*xu+xr*yu)/ewval/uval + sangu(i,j)=(-xr*zr*xu-zr*yr*yu+(xr*xr+yr*yr)*zu) / nsval/uval + enddo + enddo + +! 3 find angles to E-W and N-S for V edges + do j=1,ny + do i=1,nx+1 + rlat=half*(grid_lat(i,j)+grid_lat(i,j+1)) + diff=(grid_lon(i,j)-grid_lon(i,j+1))**2 + if(diff < sq180)then + rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)) + else + rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)-360._r_kind) + endif + xr=cos(rlat*deg2rad)*cos(rlon*deg2rad) + yr=cos(rlat*deg2rad)*sin(rlon*deg2rad) + zr=sin(rlat*deg2rad) + xv= x(i,j+1)-x(i,j) + yv= y(i,j+1)-y(i,j) + zv= z(i,j+1)-z(i,j) + vval=sqrt((xv**2+yv**2+zv**2)) + ewval=sqrt((xr**2+yr**2)) + nsval=sqrt((xr*zr)**2+(zr*yr)**2+(xr*xr+yr*yr)**2) + cangv(i,j)=(-yr*xv+xr*yv)/ewval/vval + sangv(i,j)=(-xr*zr*xv-zr*yr*yv+(xr*xr+yr*yr)*zv) / nsval/vval + enddo + enddo + deallocate( xc,yc,zc,gclat,gclon,gcrlat,gcrlon) +end subroutine generate_anl_grid + +subroutine earthuv2fv3(u,v,nx,ny,u_out,v_out) +!$$$ subprogram documentation block +! . . . . +! subprogram: earthuv2fv3 +! prgmmr: wu 2017-06-15 +! +! abstract: project earth UV to fv3 UV and interpolate to edge of the cell +! +! program history log: +! +! +! input argument list: +! u,v - earth wind components at center of the cell +! nx,ny - dimensions +! +! output argument list: +! u_out,v_out - output fv3 winds on the cell boundaries +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + use constants, only: half + implicit none + + integer(i_kind), intent(in ) :: nx,ny ! fv3 tile x- and y-dimensions + real(r_kind),intent(in ) :: u(nx,ny),v(nx,ny) + real(r_kind),intent( out) :: u_out(nx,ny+1),v_out(nx+1,ny) + integer(i_kind) i,j + + +!!!!!!! earth u/v to covariant u/v + j=1 + do i=1,nx + u_out(i,j)= u(i,j)*cangu(i,j)+v(i,j)*sangu(i,j) + end do + + do j=2,ny + do i=1,nx + u_out(i,j)=half *( (u(i,j)+u(i,j-1))*cangu(i,j)+(v(i,j)+v(i,j-1))*sangu(i,j) ) + end do + end do + j=ny + do i=1,nx + u_out(i,j+1)= u(i,j)*cangu(i,j+1)+v(i,j)*sangu(i,j+1) + end do + + do j=1,ny + v_out(1,j)=u(1,j)*cangv(1,j)+v(1,j)*sangv(1,j) + do i=2,nx + v_out(i,j)=half *( (u(i,j)+u(i-1,j))*cangv(i,j)+(v(i,j)+v(i-1,j))*sangv(i,j) ) + end do + v_out(nx+1,j)=u(nx,j)*cangv(nx+1,j)+v(nx,j)*sangv(nx+1,j) + end do +end subroutine earthuv2fv3 + +subroutine fv3uv2earth(u,v,nx,ny,u_out,v_out) +!$$$ subprogram documentation block +! . . . . +! subprogram: fv3uv2earth +! prgmmr: wu 2017-06-15 +! +! abstract: project fv3 UV to earth UV and interpolate to the center of the cells +! +! program history log: +! +! +! input argument list: +! u,v - fv3 winds on the cell boundaries +! nx,ny - dimensions +! +! output argument list: +! u_out,v_out - output earth wind components at center of the cell +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + use constants, only: half + implicit none + + integer(i_kind), intent(in ) :: nx,ny ! fv3 tile x- and y-dimensions + real(r_kind),intent(in ) :: u(nx,ny+1),v(nx+1,ny) + real(r_kind),intent( out) :: u_out(nx,ny),v_out(nx,ny) + integer(i_kind) i,j + + do j=1,ny + do i=1,nx + u_out(i,j)=half *( (u(i,j)*sangv(i,j)-v(i,j)*sangu(i,j))/(cangu(i,j)*sangv(i,j)-sangu(i,j)*cangv(i,j)) & + +(u(i,j+1)*sangv(i+1,j)-v(i+1,j)*sangu(i,j+1))/(cangu(i,j+1)*sangv(i+1,j)-sangu(i,j+1)*cangv(i+1,j))) + v_out(i,j)=half *( (u(i,j)*cangv(i,j)-v(i,j)*cangu(i,j))/(sangu(i,j)*cangv(i,j)-cangu(i,j)*sangv(i,j)) & + +(u(i,j+1)*cangv(i+1,j)-v(i+1,j)*cangu(i,j+1))/(sangu(i,j+1)*cangv(i+1,j)-cangu(i,j+1)*sangv(i+1,j))) + end do + end do + return +end subroutine fv3uv2earth + +subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma) +!$$$ subprogram documentation block +! . . . . +! subprogram: fv3_h_to_ll +! prgmmr: wu 2017-05-30 +! +! abstract: interpolate from rotated fv3 grid to A grid. +! Interpolation choices 1)bilinear both ways +! 2)inverse-distance weighting average +! reverse E-W and N-S directions & reverse i,j for output array a(nlat,nlon) +! +! program history log: +! +! +! input argument list: +! mb,nb - fv3 dimensions +! ma,na - a dimensions +! b - input variable b +! xb,yb - b array x and y coordinates +! xa,ya - a array coordinates (xa in xb units, ya in yb units) +! +! output argument list: +! a - output interpolated array +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use constants, only: zero,one + implicit none + + integer(i_kind),intent(in ) :: mb,nb,ma,na + real(r_kind) ,intent(in ) :: b_in(nb,mb) + real(r_kind) ,intent( out) :: a(ma,na) + + integer(i_kind) i,j,ir,jr,mbp,nbp + real(r_kind) b(nb,mb) + +!!!!!!!!! reverse E-W and N-S + mbp=mb+1 + nbp=nb+1 + do j=1,mb + jr=mbp-j + do i=1,nb + ir=nbp-i + b(ir,jr)=b_in(i,j) + end do + end do +!!!!!!!!! interpolate to A grid & reverse ij for array a(lat,lon) + if(bilinear)then ! bilinear interpolation + do j=1,ma + do i=1,na + a(j,i)=fv3dx1(i,j)*(fv3dy1(i,j)*b(fv3ix (i,j),fv3jy(i,j))+fv3dy(i,j)*b(fv3ix (i,j),fv3jyp(i,j))) & + +fv3dx (i,j)*(fv3dy1(i,j)*b(fv3ixp(i,j),fv3jy(i,j))+fv3dy(i,j)*b(fv3ixp(i,j),fv3jyp(i,j))) + end do + end do + else ! inverse-distance weighting average + do j=1,ma + do i=1,na + a(j,i)=fv3dx(i,j)*b(fv3ix (i,j),fv3jy(i,j))+fv3dy(i,j)*b(fv3ix (i,j),fv3jyp(i,j)) & + +fv3dx1(i,j)*b(fv3ixp(i,j),fv3jy(i,j))+fv3dy1(i,j)*b(fv3ixp(i,j),fv3jyp(i,j)) + end do + end do + endif + return +end subroutine fv3_h_to_ll + +subroutine fv3_ll_to_h(a,b,nxa,nya,nxb,nyb,rev_flg) +!$$$ subprogram documentation block +! . . . . +! subprogram: fv3_ll_to_h +! prgmmr: wu 2017-05-30 +! +! abstract: interpolate from analysis A grid to rotated fv3 grid. +! Interpolation is bilinear both ways. Reverse E-W and N-S and +! reverse i,j for output array b(nxb,nyb) +! +! program history log: +! +! +! input argument list: +! nxa,nya - a array dimensions +! nxb,nyb - b array dimensions +! +! b - input variable b +! rev_flg - flag for reverse i,j order +! output argument list: +! a - output interpolated array +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + use constants, only: zero,one + implicit none + + integer(i_kind),intent(in ) :: nyb,nxb,nya,nxa + real(r_kind) ,intent(in ) :: a(nya,nxa) + logical ,intent(in ) :: rev_flg + real(r_kind) ,intent( out) :: b(nxb*nyb) + + integer(i_kind) i,j,ir,jr,nybp,nxbp,ijr + + if(rev_flg)then +!!!!!!!!!! output in reverse E-W, N-S and reversed i,j !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + nybp=nyb+1 + nxbp=nxb+1 + do i=1,nyb + ir=nybp-i + ijr=(ir-1)*nxb + do j=1,nxb + jr=nxbp-j + b(jr+ijr)=a3dy1(i,j)*(a3dx1(i,j)*a(a3jy (i,j),a3ix(i,j))+a3dx(i,j)*a(a3jy (i,j),a3ixp(i,j))) & + +a3dy (i,j)*(a3dx1(i,j)*a(a3jyp(i,j),a3ix(i,j))+a3dx(i,j)*a(a3jyp(i,j),a3ixp(i,j))) + end do + end do + else +!!!!!!!!!! output order as input W-E S-N and (i:lat,j:lon) !!!!!!!!!!! + do j=1,nxb + ijr=(j-1)*nyb + do i=1,nyb + b(i+ijr)=a3dy1(i,j)*(a3dx1(i,j)*a(a3jy (i,j),a3ix(i,j))+a3dx(i,j)*a(a3jy (i,j),a3ixp(i,j))) & + +a3dy (i,j)*(a3dx1(i,j)*a(a3jyp(i,j),a3ix(i,j))+a3dx(i,j)*a(a3jyp(i,j),a3ixp(i,j))) + end do + end do + endif +end subroutine fv3_ll_to_h + +end module mod_fv3_lola + +subroutine rotate2deg(rlon_in,rlat_in,rlon_out,rlat_out,rlon0,rlat0,nx,ny) +!$$$ subprogram documentation block +! . . . . +! subprogram: rotate2deg +! +! prgmmr: parrish +! +! Rotate right-handed spherical coordinate to new right-handed spherical +! coordinate. The coordinates are latitude (-90 to 90) and longitude. +! Output for longitude is principle range of atan2d function ( -180 < rlon_out <= 180 ) +! +! program history log: +! 2017-05-02 parrish +! +! Method is as follows: +! 1. define x,y,z coordinate system with origin at center of sphere, +! x intersecting sphere at 0 deg N, 0 deg E, +! y intersecting sphere at 0 deg N, 90 deg E, +! z intersecting sphere at 90 deg N (north pole). + +! 4 steps: + +! 1. compute x,y,z from rlon_in, rlat_in + +! 2. rotate (x,y,z) about z axis by amount rlon0 -- (x,y,z) --> (xt,yt,zt) + +! 3. rotate (xt,yt,zt) about yt axis by amount rlat0 --- (xt,yt,zt) --> (xtt,ytt,ztt) + +! 4. compute rlon_out, rlat_out from xtt,ytt,ztt + +! This is the desired new orientation, where (0N, 0E) maps to point +! (rlon0,rlat0) in original coordinate and the new equator is tangent to +! the original latitude circle rlat0 at original longitude rlon0. +! attributes: +! langauge: f90 +! machine: +! +!$$$ end documentation block + + + use kinds, only: r_kind,i_kind + use constants, only: deg2rad,rad2deg + implicit none + + integer(i_kind), intent(in ) :: nx,ny ! fv3 tile x- and y-dimensions + real(r_kind),intent(in ) :: rlon_in(nx,ny),rlat_in(nx,ny),rlon0,rlat0 + real(r_kind),intent( out) :: rlon_out(nx,ny),rlat_out(nx,ny) + + real(r_kind) x,y,z, xt,yt,zt, xtt,ytt,ztt + integer(i_kind) i,j + + do j=1,ny + do i=1,nx +! 1. compute x,y,z from rlon_in, rlat_in + + x=cos(rlat_in(i,j)*deg2rad)*cos(rlon_in(i,j)*deg2rad) + y=cos(rlat_in(i,j)*deg2rad)*sin(rlon_in(i,j)*deg2rad) + z=sin(rlat_in(i,j)*deg2rad) + +! 2. rotate (x,y,z) about z axis by amount rlon0 -- (x,y,z) --> (xt,yt,zt) + + xt= x*cos(rlon0*deg2rad)+y*sin(rlon0*deg2rad) + yt=-x*sin(rlon0*deg2rad)+y*cos(rlon0*deg2rad) + zt=z + +! 3. rotate (xt,yt,zt) about yt axis by amount rlat0 --- (xt,yt,zt) --> (xtt,ytt,ztt) + + xtt= xt*cos(rlat0*deg2rad)+zt*sin(rlat0*deg2rad) + ytt= yt + ztt=-xt*sin(rlat0*deg2rad)+zt*cos(rlat0*deg2rad) + +! 4. compute rlon_out, rlat_out from xtt,ytt,ztt + + rlat_out(i,j)=asin(ztt)*rad2deg + rlon_out(i,j)=atan2(ytt,xtt)*rad2deg + enddo + enddo +end subroutine rotate2deg + +subroutine unrotate2deg(rlon_in,rlat_in,rlon_out,rlat_out,rlon0,rlat0,nx,ny) +!$$$ subprogram documentation block +! . . . . +! subprogram: unrotate2deg +! +! prgmmr: parrish +! +! abstract: inverse of rotate2deg. +! +! program history log: +! 2017-05-02 parrish + +! attributes: +! langauge: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + use constants, only: deg2rad,rad2deg + implicit none + + real(r_kind),intent(in ) :: rlon_out(nx,ny),rlat_out(nx,ny),rlon0,rlat0 + integer(i_kind),intent(in ) :: nx,ny + real(r_kind),intent( out) :: rlon_in(nx,ny),rlat_in(nx,ny) + + real(r_kind) x,y,z, xt,yt,zt, xtt,ytt,ztt + integer(i_kind) i,j + do j=1,ny + do i=1,nx + xtt=cos(rlat_out(i,j)*deg2rad)*cos(rlon_out(i,j)*deg2rad) + ytt=cos(rlat_out(i,j)*deg2rad)*sin(rlon_out(i,j)*deg2rad) + ztt=sin(rlat_out(i,j)*deg2rad) + + xt= xtt*cos(rlat0*deg2rad)-ztt*sin(rlat0*deg2rad) + yt= ytt + zt= xtt*sin(rlat0*deg2rad)+ztt*cos(rlat0*deg2rad) + + x= xt*cos(rlon0*deg2rad)-yt*sin(rlon0*deg2rad) + y= xt*sin(rlon0*deg2rad)+yt*cos(rlon0*deg2rad) + z= zt + + rlat_in(i,j)=asin(z)*rad2deg + rlon_in(i,j)=atan2(y,x)*rad2deg + enddo + enddo + +end subroutine unrotate2deg diff --git a/src/mod_nmmb_to_a.f90 b/src/gsi/mod_nmmb_to_a.f90 similarity index 100% rename from src/mod_nmmb_to_a.f90 rename to src/gsi/mod_nmmb_to_a.f90 diff --git a/src/mod_strong.f90 b/src/gsi/mod_strong.f90 similarity index 100% rename from src/mod_strong.f90 rename to src/gsi/mod_strong.f90 diff --git a/src/mod_vtrans.f90 b/src/gsi/mod_vtrans.f90 similarity index 98% rename from src/mod_vtrans.f90 rename to src/gsi/mod_vtrans.f90 index b0e95a2b3..7f72fb858 100644 --- a/src/mod_vtrans.f90 +++ b/src/gsi/mod_vtrans.f90 @@ -38,6 +38,7 @@ module mod_vtrans ! eigenvalues need be computed. The complete computation if the eigenvectors ! and eigenvalues without using dgeev uses less than 2 seconds for 8 ! eigenvalue/vectors and all related computations. +! 2018-02-15 wu - add code for fv3_regional option ! ! subroutines included: ! sub init_vtrans - initialize vertical mode related variables @@ -501,7 +502,7 @@ subroutine getabc(ahat,bhat,chat) ! !$$$ end documentation block use constants,only: zero,ten - use gridmod,only: nsig,ak5,bk5,ck5 + use gridmod,only: nsig,ak5,bk5,ck5,fv3_regional use gridmod,only: wrf_nmm_regional,nems_nmmb_regional,eta1_ll,eta2_ll,pdtop_ll,pt_ll,cmaq_regional implicit none @@ -517,6 +518,12 @@ subroutine getabc(ahat,bhat,chat) bhat(k)=eta2_ll(k) chat(k)=zero end do + elseif(fv3_regional) then + do k=1,nsig+1 + ahat(k)=eta1_ll(k)*0.01_r_kind + bhat(k)=eta2_ll(k) + chat(k)=zero + end do else do k=1,nsig+1 ahat(k)=ak5(k)*ten @@ -1376,18 +1383,20 @@ subroutine iminv_quad (a,n,d,l,m) ! final row and column interchange ! k=n - 100 k=(k-1) - if(k) 150,150,105 - 105 i=l(k) - if(i-k) 120,120,108 - 108 jq=n*(k-1) - jr=n*(i-1) - do 110 j=1,n - jk=jq+j - hold=a(jk) - ji=jr+j - a(jk)=-a(ji) - 110 a(ji) =hold + do + 100 k=(k-1) + if(k) 150,150,105 + 105 i=l(k) + if(i-k) 120,120,108 + 108 jq=n*(k-1) + jr=n*(i-1) + do 110 j=1,n + jk=jq+j + hold=a(jk) + ji=jr+j + a(jk)=-a(ji) + a(ji) =hold + 110 continue 120 j=m(k) if(j-k) 100,100,125 125 ki=k-n @@ -1396,7 +1405,8 @@ subroutine iminv_quad (a,n,d,l,m) hold=a(ki) ji=ki-k+j a(ki)=-a(ji) - 130 a(ji) =hold - go to 100 - 150 return + a(ji) =hold + 130 continue + end do + 150 return end subroutine iminv_quad diff --git a/src/mod_wrfmass_to_a.f90 b/src/gsi/mod_wrfmass_to_a.f90 similarity index 100% rename from src/mod_wrfmass_to_a.f90 rename to src/gsi/mod_wrfmass_to_a.f90 diff --git a/src/model_ad.F90 b/src/gsi/model_ad.F90 similarity index 100% rename from src/model_ad.F90 rename to src/gsi/model_ad.F90 diff --git a/src/model_tl.F90 b/src/gsi/model_tl.F90 similarity index 100% rename from src/model_tl.F90 rename to src/gsi/model_tl.F90 diff --git a/src/mp_compact_diffs_mod1.f90 b/src/gsi/mp_compact_diffs_mod1.f90 similarity index 100% rename from src/mp_compact_diffs_mod1.f90 rename to src/gsi/mp_compact_diffs_mod1.f90 diff --git a/src/mp_compact_diffs_support.f90 b/src/gsi/mp_compact_diffs_support.f90 similarity index 100% rename from src/mp_compact_diffs_support.f90 rename to src/gsi/mp_compact_diffs_support.f90 diff --git a/src/mpeu_mpif.F90 b/src/gsi/mpeu_mpif.F90 similarity index 100% rename from src/mpeu_mpif.F90 rename to src/gsi/mpeu_mpif.F90 diff --git a/src/mpeu_util.F90 b/src/gsi/mpeu_util.F90 similarity index 100% rename from src/mpeu_util.F90 rename to src/gsi/mpeu_util.F90 diff --git a/src/mpimod.F90 b/src/gsi/mpimod.F90 similarity index 100% rename from src/mpimod.F90 rename to src/gsi/mpimod.F90 diff --git a/src/mpl_allreduce.F90 b/src/gsi/mpl_allreduce.F90 similarity index 100% rename from src/mpl_allreduce.F90 rename to src/gsi/mpl_allreduce.F90 diff --git a/src/mpl_bcast.f90 b/src/gsi/mpl_bcast.f90 similarity index 100% rename from src/mpl_bcast.f90 rename to src/gsi/mpl_bcast.f90 diff --git a/src/gsi/mrmsmod.f90 b/src/gsi/mrmsmod.f90 new file mode 100644 index 000000000..713b974d7 --- /dev/null +++ b/src/gsi/mrmsmod.f90 @@ -0,0 +1,129 @@ +module mrmsmod +implicit none +private +public l_mrms_run +public l_mrms_sparse_netcdf +public mrms_listfile +public l_new_cldvar,l_ens_dbz_clip +public load_mrms_data_info + +logical l_mrms_run +logical l_mrms_sparse_netcdf +logical,save::l_ens_dbz_clip=.false. +logical,save::l_new_cldvar=.false. +character(len=*),parameter:: mrms_listfile='mrms_listfile' +contains + +subroutine load_mrms_data_info (mrms_listfile,nrows0,ntot_mrms,nrows_mrms,nrows,obsfile_all,dfile,dtype,ditype,dplat,dsis,dval,dthin,ipoint,dsfcalc,time_window,rcname) + + use kinds, only: r_kind,i_kind + use file_utility, only : get_lun + use mpeu_util, only: gettablesize + use mpeu_util, only: gettable + use mpeu_util, only: getindex + + implicit none + + integer(i_kind),parameter::nobstype_mrms=2 ! first for vr, and the second for ref + integer(i_kind),intent(in):: nrows0,ntot_mrms,nrows_mrms,nrows + character(len=*),intent(in),optional ::mrms_listfile, rcname ! input filename + character(10),intent(inout),dimension(nrows):: dtype,ditype,dplat + character(20),intent(inout),dimension(nrows):: obsfile_all + character(*),intent(inout),dimension(nrows):: dfile + character(20),intent(inout),dimension(nrows):: dsis + real(r_kind) ,intent(inout),dimension(nrows):: dval + integer(i_kind),intent(inout),dimension(nrows):: dsfcalc,dthin,ipoint + real(r_kind) ,intent(inout),dimension(nrows):: time_window + + character(len=*),parameter:: tbname_mrms='OBS_INPUT_MRMS::' + integer(i_kind) luin_mrms,ii0,itype_mrms + character(len=256),allocatable,dimension(:):: utable_mrms_list + character(len=256),allocatable,dimension(:):: utable_mrms + + + real(r_kind),allocatable,dimension(:):: dmesh_mrms + character(10),allocatable,dimension(:):: dtype_mrms,ditype_mrms,dplat_mrms + character(120),allocatable,dimension(:):: dfile_mrms + character(20),allocatable,dimension(:):: dsis_mrms + real(r_kind) ,allocatable,dimension(:):: dval_mrms + integer(i_kind) ,allocatable,dimension(:):: dsfcalc_mrms,dthin_mrms,ipoint_mrms + real(r_kind) ,allocatable,dimension(:):: time_window_mrms + real(r_kind) ,save:: time_window_mrms_max=3.0_r_kind + + integer(i_kind):: ii,ier + + luin_mrms=get_lun() + open(luin_mrms,file=trim(mrms_listfile),form='formatted',iostat=ier) + allocate(utable_mrms_list(nrows_mrms)) + call gettable(mrms_listfile,luin_mrms,ntot_mrms,nrows_mrms,utable_mrms_list) + if(luin_mrms/=5) close(luin_mrms ) + allocate(dfile_mrms(nobstype_mrms),dtype_mrms(nobstype_mrms),dplat_mrms(nobstype_mrms),& + dsis_mrms(nobstype_mrms),dval_mrms(nobstype_mrms),dthin_mrms(nobstype_mrms),dsfcalc_mrms(nobstype_mrms),& + dmesh_mrms(nobstype_mrms), & + time_window_mrms(nobstype_mrms)) + allocate(ditype_mrms(nobstype_mrms),ipoint_mrms(nobstype_mrms)) + ! variables participating in state vector + if (present(rcname)) then + luin_mrms=get_lun() + open(luin_mrms,file=trim(rcname),form='formatted') + else + luin_mrms=5 + endif + allocate(utable_mrms(nobstype_mrms)) + call gettable(tbname_mrms,luin_mrms,nobstype_mrms,nobstype_mrms,utable_mrms) + if(luin_mrms/=5) close(luin_mrms) + + do ii=1,nobstype_mrms + + read(utable_mrms(ii),*)dmesh_mrms(ii), dfile_mrms(ii),& ! local file name from which to read observatinal data + dtype_mrms(ii),& ! character string identifying type of observatio + dplat_mrms(ii),& ! currently contains satellite id (no meaning for non-sat data) + dsis_mrms(ii), & ! sensor/instrument/satellite identifier for info files + dval_mrms(ii), & ! + dthin_mrms(ii),& ! thinning flag (1=thinning on; otherwise off) + dsfcalc_mrms(ii) ! use orig bilinear FOV surface calculation (routine deter_sfc) + + if(trim(dplat_mrms(ii))=='null') dplat_mrms(ii)=' ' + ditype_mrms(ii)= ' ' ! character string identifying group type of ob (see read_obs) + ipoint_mrms(ii)= 0 ! default pointer (values set in gsisub) _RT: This is never needed + time_window_mrms(ii) = time_window_mrms_max ! default to maximum time window + + enddo + + deallocate(utable_mrms) + do ii=1,nrows_mrms + ii0=nrows0+ii + + read(utable_mrms_list(ii),*) dfile(ii0) ! ! local file name from which to read observatinal data + if(index(dfile(ii0),'vr') > 0) then + itype_mrms=1 ! for vr + elseif(index(dfile(ii0),'ref') > 0) then + itype_mrms=2 ! for ref + else + write(6,*) 'the mrms files to be read not recognizable, stop' + call stop2(255) + endif + + dtype(ii0)= dtype_mrms(itype_mrms) ! ! character string identifying type of observatio + dplat(ii0)=dplat_mrms(itype_mrms) ! currently contains satellite id (no meaning for non-sat data) + dsis (ii0)= dsis_mrms(itype_mrms) ! sensor/instrument/satellite identifier for info files + dval(ii0)=dval_mrms(itype_mrms) ! + dthin(ii0)= dthin_mrms(itype_mrms) ! thinning flag (1=thinning on; otherwise off) + dsfcalc(ii0)=dsfcalc_mrms(itype_mrms) ! use orig bilinear FOV surface calculation (routine deter_sfc) + ditype(ii0)=ditype_mrms(itype_mrms) + ipoint(ii0)=ipoint_mrms(itype_mrms) + time_window(ii0)=time_window_mrms(itype_mrms) + write(obsfile_all(ii0),'(a,i4.4)') 'obs_input.', ii0 ! name of scratch file to hold obs data + enddo + + deallocate(utable_mrms_list) + deallocate(dfile_mrms,dtype_mrms,dplat_mrms,& + dsis_mrms,dval_mrms,dthin_mrms,dsfcalc_mrms,dmesh_mrms,& + time_window_mrms) + deallocate(ditype_mrms,ipoint_mrms) + + + + +end subroutine load_mrms_data_info +end module mrmsmod diff --git a/src/myassert.H b/src/gsi/myassert.H similarity index 100% rename from src/myassert.H rename to src/gsi/myassert.H diff --git a/src/mytrace.H b/src/gsi/mytrace.H similarity index 100% rename from src/mytrace.H rename to src/gsi/mytrace.H diff --git a/src/native_endianness.f90 b/src/gsi/native_endianness.f90 similarity index 100% rename from src/native_endianness.f90 rename to src/gsi/native_endianness.f90 diff --git a/src/gsi/nc_diag_read_mod.f90 b/src/gsi/nc_diag_read_mod.f90 new file mode 100644 index 000000000..ff56c09f7 --- /dev/null +++ b/src/gsi/nc_diag_read_mod.f90 @@ -0,0 +1,93 @@ +module nc_diag_read_mod +use kinds, only: i_kind,r_single,r_double +private +public :: nc_diag_read_init +public :: nc_diag_read_get_var +public :: nc_diag_read_get_global_attr +public :: nc_diag_read_close +public :: nc_diag_read_get_dim +! +interface nc_diag_read_get_var + module procedure nc_diag_read_get_var_i + module procedure nc_diag_read_get_var_rd + module procedure nc_diag_read_get_var_rs + module procedure nc_diag_read_get_var_i_rank1 + module procedure nc_diag_read_get_var_rd_rank1 + module procedure nc_diag_read_get_var_rs_rank1 + module procedure nc_diag_read_get_var_rd_rank2 + module procedure nc_diag_read_get_var_rs_rank2 +end interface +interface nc_diag_read_get_global_attr + module procedure nc_diag_read_get_global_attr_i + module procedure nc_diag_read_get_global_attr_c + module procedure nc_diag_read_get_global_attr_rs + module procedure nc_diag_read_get_global_attr_rd +end interface +contains + subroutine nc_diag_read_init(fname,id) + character(len=*):: fname + integer(i_kind) :: id + end subroutine nc_diag_read_init + integer function nc_diag_read_get_dim(id,vname) + integer(i_kind) :: id + character(len=*):: vname + nc_diag_read_get_dim = 0 + end function nc_diag_read_get_dim + subroutine nc_diag_read_close(fname) + character(len=*):: fname + end subroutine nc_diag_read_close +! get rank 0 + subroutine nc_diag_read_get_var_i(name,mold) + character(len=*):: name + integer(i_kind):: mold + end subroutine nc_diag_read_get_var_i + subroutine nc_diag_read_get_var_rs(name,mold) + character(len=*):: name + real(r_single):: mold + end subroutine nc_diag_read_get_var_rs + subroutine nc_diag_read_get_var_rd(name,mold) + character(len=*):: name + real(r_double):: mold + end subroutine nc_diag_read_get_var_rd +! get rank 1 + subroutine nc_diag_read_get_var_i_rank1(name,mold) + character(len=*):: name + integer(i_kind):: mold(:) + end subroutine nc_diag_read_get_var_i_rank1 + subroutine nc_diag_read_get_var_rs_rank1(name,mold) + character(len=*):: name + real(r_single):: mold(:) + end subroutine nc_diag_read_get_var_rs_rank1 + subroutine nc_diag_read_get_var_rd_rank1(name,mold) + character(len=*):: name + real(r_double):: mold(:) + end subroutine nc_diag_read_get_var_rd_rank1 +! get rank 1 + subroutine nc_diag_read_get_var_rs_rank2(name,mold) + character(len=*):: name + real(r_single):: mold(:,:) + end subroutine nc_diag_read_get_var_rs_rank2 + subroutine nc_diag_read_get_var_rd_rank2(name,mold) + character(len=*):: name + real(r_double):: mold(:,:) + end subroutine nc_diag_read_get_var_rd_rank2 +! global_attr + subroutine nc_diag_read_get_global_attr_i(imold1,name,mold2) + character(len=*):: name + integer(i_kind):: imold1,mold2 + end subroutine nc_diag_read_get_global_attr_i + subroutine nc_diag_read_get_global_attr_c(imold1,name,mold2) + character(len=*):: name,mold2 + integer(i_kind):: imold1 + end subroutine nc_diag_read_get_global_attr_c + subroutine nc_diag_read_get_global_attr_rs(imold1,name,mold2) + character(len=*):: name + integer(i_kind):: imold1 + real(r_single):: mold2 + end subroutine nc_diag_read_get_global_attr_rs + subroutine nc_diag_read_get_global_attr_rd(imold1,name,mold2) + character(len=*):: name + integer(i_kind):: imold1 + real(r_double):: mold2 + end subroutine nc_diag_read_get_global_attr_rd +end module nc_diag_read_mod diff --git a/src/gsi/nc_diag_write_mod.f90 b/src/gsi/nc_diag_write_mod.f90 new file mode 100644 index 000000000..66ad48fd8 --- /dev/null +++ b/src/gsi/nc_diag_write_mod.f90 @@ -0,0 +1,116 @@ +module nc_diag_write_mod +use kinds, only: i_kind,r_single,r_double +private +public nc_diag_init +public nc_diag_header +public nc_diag_metadata +public nc_diag_data2d +public nc_diag_chaninfo_dim_set +public nc_diag_chaninfo +public nc_diag_write + interface nc_diag_header + module procedure nc_diag_header_i + module procedure nc_diag_header_c + module procedure nc_diag_header_rs + module procedure nc_diag_header_rd + end interface + interface nc_diag_metadata + module procedure nc_diag_metadata_i + module procedure nc_diag_metadata_c + module procedure nc_diag_metadata_rs + module procedure nc_diag_metadata_rd + end interface + interface nc_diag_chaninfo + module procedure nc_diag_chaninfo_i + module procedure nc_diag_chaninfo_c + module procedure nc_diag_chaninfo_rs + module procedure nc_diag_chaninfo_rd + end interface + interface nc_diag_data2d + module procedure nc_diag_data1d_rs + module procedure nc_diag_data1d_rd + module procedure nc_diag_data2d_rs + module procedure nc_diag_data2d_rd + end interface +contains +! init + subroutine nc_diag_init(fname,append) + character(len=*):: fname + logical(i_kind),optional :: append + end subroutine nc_diag_init +! header + subroutine nc_diag_header_i(vname,ivar) + character(len=*):: vname + integer(i_kind) :: ivar + end subroutine nc_diag_header_i + subroutine nc_diag_header_c(vname,cvar) + character(len=*):: vname + character(len=*):: cvar + end subroutine nc_diag_header_c + subroutine nc_diag_header_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar + end subroutine nc_diag_header_rs + subroutine nc_diag_header_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar + end subroutine nc_diag_header_rd +! metadata + subroutine nc_diag_metadata_i(vname,ivar) + character(len=*):: vname + integer(i_kind) :: ivar + end subroutine nc_diag_metadata_i + subroutine nc_diag_metadata_c(vname,cvar) + character(len=*):: vname + character(len=*):: cvar + end subroutine nc_diag_metadata_c + subroutine nc_diag_metadata_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar + end subroutine nc_diag_metadata_rs + subroutine nc_diag_metadata_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar + end subroutine nc_diag_metadata_rd +! data2d - not sure why original code no wrap these with metadata interface! + subroutine nc_diag_data1d_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar(:) + end subroutine nc_diag_data1d_rs + subroutine nc_diag_data1d_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar(:) + end subroutine nc_diag_data1d_rd + subroutine nc_diag_data2d_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar(:,:) + end subroutine nc_diag_data2d_rs + subroutine nc_diag_data2d_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar(:,:) + end subroutine nc_diag_data2d_rd +! + subroutine nc_diag_chaninfo_dim_set(ivar) + integer(i_kind) :: ivar + end subroutine nc_diag_chaninfo_dim_set +! metadata + subroutine nc_diag_chaninfo_i(vname,ivar) + character(len=*):: vname + integer(i_kind) :: ivar + end subroutine nc_diag_chaninfo_i + subroutine nc_diag_chaninfo_c(vname,cvar) + character(len=*):: vname + character(len=*):: cvar + end subroutine nc_diag_chaninfo_c + subroutine nc_diag_chaninfo_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar + end subroutine nc_diag_chaninfo_rs + subroutine nc_diag_chaninfo_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar + end subroutine nc_diag_chaninfo_rd +! final + subroutine nc_diag_write + end subroutine nc_diag_write +end module nc_diag_write_mod diff --git a/src/ncepgfs_ghg.f90 b/src/gsi/ncepgfs_ghg.f90 similarity index 93% rename from src/ncepgfs_ghg.f90 rename to src/gsi/ncepgfs_ghg.f90 index 45d2092a7..6c5fa7bb9 100644 --- a/src/ncepgfs_ghg.f90 +++ b/src/gsi/ncepgfs_ghg.f90 @@ -74,6 +74,8 @@ module ncepgfs_ghg ! --- co2 2-d monthly data and global mean from observed data real(r_kind), save :: co2_glb = co2vmr_def + real(r_kind) :: julday ! Used in calculating default value with + ! annual trend integer(i_kind), save :: kyrsav = 0 ! year of data saved integer(i_kind), save :: kmonsav = 0 ! month of data saved @@ -189,18 +191,25 @@ subroutine read_gfsco2 & endif if ( ico2 == 0 ) then -! --- ... use prescribed global mean co2 data +! --- ... use prescribed global mean co2 data based on date + + julday = (1461 * (iyear + 4800 + (month -14)/12))/4 + & + (367 * (month -2 -12 * ((month -14)/12)))/12 - & + (3 * ((iyear + 4900 + (month - 14)/12)/100))/4 + idd - 32075 + + co2_glb = 0.00602410_r_kind * (julday - 2455563.0_r_kind) + 389.5_r_kind do k = 1, nlev do j = 1, lon2 do i = 1, lat2 - atmco2(i,j,k) = co2vmr_def + atmco2(i,j,k) = co2_glb enddo enddo enddo if ( mype == 0 ) then - write(6,*) ' - Using prescribed co2 global mean value=',co2vmr_def + write(6,*) ' - Using prescribed co2 global mean value=',co2_glb,& + 'for Julian Day',julday endif return @@ -208,10 +217,10 @@ subroutine read_gfsco2 & ! --- ... auto select co2 data table for required month and year else if ( ico2 == 1 ) then - if ( mype == 0 ) then - write(6,*) ' ico2 == 1 not valid ' - write(6,*) ' *** Stopped in subroutine read_gfsco2 !!' - endif + if ( mype == 0 ) then + write(6,*) ' ico2 == 1 not valid ' + write(6,*) ' *** Stopped in subroutine read_gfsco2 !!' + endif call stop2(332) else if ( ico2 == 2 ) then @@ -226,10 +235,10 @@ subroutine read_gfsco2 & inquire (file=cfile, exist=file_exist) if ( .not. file_exist ) then - if ( mype == 0 ) then - write(6,*) ' Can not find co2 data source file' - write(6,*) ' *** Stopped in subroutine read_gfsco2 !!' - endif + if ( mype == 0 ) then + write(6,*) ' Can not find co2 data source file' + write(6,*) ' *** Stopped in subroutine read_gfsco2 !!' + endif call stop2(332) endif ! end if_file_exist_block @@ -237,23 +246,23 @@ subroutine read_gfsco2 & ! --- ... read in co2 2-d data for the requested month open (luco2,file=cfile,form='formatted',status='old',iostat=ierr) - if (ierr /= 0) then - if ( mype == 0 ) then - write(6,*) ' error opening file = '//cfile - write(6,*) ' *** Stopped in subroutine read_gfsco2 !!' - endif - call stop2(332) - endif + if (ierr /= 0) then + if ( mype == 0 ) then + write(6,*) ' error opening file = '//cfile + write(6,*) ' *** Stopped in subroutine read_gfsco2 !!' + endif + call stop2(332) + endif rewind luco2 read (luco2, 36,iostat=ierr) iyr, nmxlon, nmxlat, ires, co2g1 36 format(i4,t25,2i4,t58,i3,t99,f7.2) - if (ierr /= 0) then - if ( mype == 0 ) then - write(6,*) ' error reading file = '//cfile - write(6,*) ' *** Stopped in subroutine read_gfsco2 !!' - endif - call stop2(332) - endif + if (ierr /= 0) then + if ( mype == 0 ) then + write(6,*) ' error reading file = '//cfile + write(6,*) ' *** Stopped in subroutine read_gfsco2 !!' + endif + call stop2(332) + endif resco2 = ires co2_glb = co2g1 diff --git a/src/ncepgfs_io.f90 b/src/gsi/ncepgfs_io.f90 similarity index 92% rename from src/ncepgfs_io.f90 rename to src/gsi/ncepgfs_io.f90 index a3d365ed5..2a7ad4aa3 100644 --- a/src/ncepgfs_io.f90 +++ b/src/gsi/ncepgfs_io.f90 @@ -169,7 +169,7 @@ subroutine read_gfs endif inner_vars=1 - num_fields=min(8*grd_a%nsig+2,npe) + num_fields=min(8*grd_a%nsig+2,npe) ! Create temporary communication information fore read routines call general_sub2grid_create_info(grd_t,inner_vars,grd_a%nlat,grd_a%nlon, & grd_a%nsig,num_fields,regional) @@ -211,6 +211,7 @@ subroutine read_gfs ! Set values to actual MetGuess fields call set_guess_ + l_cld_derived = associated(ges_cwmr_it).and.& associated(ges_q_it) .and.& associated(ges_ql_it) .and.& @@ -223,7 +224,6 @@ subroutine read_gfs if (l_cld_derived) then call cloud_calc_gfs(ges_ql_it,ges_qi_it,ges_cwmr_it,ges_q_it,ges_tv_it,.true.) end if - end do call gsi_bundledestroy(atm_bundle,istatus) @@ -520,7 +520,7 @@ subroutine write_ghg_grid(a,char_ghg) call gather_stuff2(a(1,1,k),ag(1,1,k),mype,0) end do if (mype==0) then - write(6,*) 'WRITE OUT INTERPOLATED',char_ghg + write(6,*) 'WRITE OUT INTERPOLATED ',char_ghg ! load single precision arrays do k=1,nsig do j=1,nlon @@ -1133,6 +1133,8 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) ! gues while original cw gues still have negative values. ! 2013-10-19 todling - update cloud_efr module name ! 2013-10-29 todling - revisit write to allow skipping vars not in MetGuess +! 2018-05-19 eliu - add I/O for fv3 hydrometeors +! 2019-03-21 Wei/Martin - write out global aerosol arrays if needed ! ! input argument list: ! increment - when >0 will write increment from increment-index slot @@ -1163,8 +1165,13 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) use constants, only: qcmin use constants, only:zero use general_specmod, only: general_init_spec_vars,general_destroy_spec_vars,spec_vars - use gsi_4dvar, only: lwrite4danl + use gsi_4dvar, only: lwrite4danl,nhr_anal use ncepnems_io, only: write_nemsatm,write_nemssfc,write_nems_sfc_nst + use ncepnems_io, only: write_fv3atm_nems + use gridmod, only: fv3_full_hydro + use gsi_chemguess_mod, only: gsi_chemguess_get,gsi_chemguess_bundle + use chemmod, only: laeroana_gocart + use radiance_mod, only: aerosol_names implicit none @@ -1182,7 +1189,12 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) real(r_kind),pointer,dimension(:,:,:):: aux_q real(r_kind),pointer,dimension(:,:,:):: aux_oz real(r_kind),pointer,dimension(:,:,:):: aux_cwmr - + real(r_kind),pointer,dimension(:,:,:):: aux_ql + real(r_kind),pointer,dimension(:,:,:):: aux_qi + real(r_kind),pointer,dimension(:,:,:):: aux_qr + real(r_kind),pointer,dimension(:,:,:):: aux_qs + real(r_kind),pointer,dimension(:,:,:):: aux_qg + real(r_kind),pointer,dimension(:,:,:):: aux_cf real(r_kind),pointer,dimension(:,: ):: ges_ps_it =>null() real(r_kind),pointer,dimension(:,:,:):: ges_u_it =>null() real(r_kind),pointer,dimension(:,:,:):: ges_v_it =>null() @@ -1192,16 +1204,45 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) real(r_kind),pointer,dimension(:,:,:):: ges_q_it =>null() real(r_kind),pointer,dimension(:,:,:):: ges_oz_it =>null() real(r_kind),pointer,dimension(:,:,:):: ges_cwmr_it=>null() - + real(r_kind),pointer,dimension(:,:,:):: ges_ql_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_qi_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_qr_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_qs_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_qg_it =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_cf_it =>null() + +! for aerosols + real(r_kind),pointer,dimension(:,:,:):: aux_du1,aux_du2,aux_du3,aux_du4,aux_du5 + real(r_kind),pointer,dimension(:,:,:):: aux_ss1,aux_ss2,aux_ss3,aux_ss4,aux_so4 + real(r_kind),pointer,dimension(:,:,:):: aux_oc1,aux_oc2,aux_bc1,aux_bc2 + real(r_kind),pointer,dimension(:,:,:):: ges_du1_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_du2_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_du3_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_du4_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_du5_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_ss1_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_ss2_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_ss3_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_ss4_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_so4_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_oc1_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_oc2_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_bc1_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_bc2_it=>NULL() + type(gsi_bundle) :: chem_bundle type(gsi_bundle) :: atm_bundle type(gsi_grid) :: atm_grid integer(i_kind),parameter :: n2d=2 - integer(i_kind),parameter :: n3d=8 + integer(i_kind),parameter :: n3d=14 character(len=4), parameter :: vars2d(n2d) = (/ 'z ', 'ps ' /) character(len=4), parameter :: vars3d(n3d) = (/ 'u ', 'v ', & 'vor ', 'div ', & 'tv ', 'q ', & - 'cw ', 'oz ' /) + 'cw ', 'oz ', & + 'ql ', 'qi ', & + 'qr ', 'qs ', & + 'qg ', 'cf ' /) + logical :: inithead type(spec_vars):: sp_b @@ -1237,13 +1278,67 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) if ( istatus == 0 ) aux_q = zero call gsi_bundlegetpointer(atm_bundle,'oz',aux_oz,istatus) if ( istatus == 0 ) aux_oz = zero + call gsi_bundlegetpointer(atm_bundle,'ql',aux_ql,istatus) + if ( istatus == 0 ) aux_ql = zero + call gsi_bundlegetpointer(atm_bundle,'qi',aux_qi,istatus) + if ( istatus == 0 ) aux_qi = zero + call gsi_bundlegetpointer(atm_bundle,'qr',aux_qr,istatus) + if ( istatus == 0 ) aux_qr = zero + call gsi_bundlegetpointer(atm_bundle,'qs',aux_qs,istatus) + if ( istatus == 0 ) aux_qs = zero + call gsi_bundlegetpointer(atm_bundle,'qg',aux_qg,istatus) + if ( istatus == 0 ) aux_qg = zero + call gsi_bundlegetpointer(atm_bundle,'cf',aux_cf,istatus) + if ( istatus == 0 ) aux_cf = zero call gsi_bundlegetpointer(atm_bundle,'cw',aux_cwmr,istatus) if ( istatus == 0 ) aux_cwmr = zero + + ! if aerosols + if ( laeroana_gocart ) then + call gsi_bundlecreate(chem_bundle,atm_grid,'aux-chem-write',istatus,names3d=aerosol_names) + if ( istatus /= 0 ) then + write(6,*)' write_gfs: trouble creating chem_bundle' + call stop2(999) + endif + call gsi_bundlegetpointer(chem_bundle,'sulf',aux_so4,istatus) + if ( istatus == 0 ) aux_so4 = zero + call gsi_bundlegetpointer(chem_bundle,'bc1',aux_bc1,istatus) + if ( istatus == 0 ) aux_bc1 = zero + call gsi_bundlegetpointer(chem_bundle,'bc2',aux_bc2,istatus) + if ( istatus == 0 ) aux_bc2 = zero + call gsi_bundlegetpointer(chem_bundle,'oc1',aux_oc1,istatus) + if ( istatus == 0 ) aux_oc1 = zero + call gsi_bundlegetpointer(chem_bundle,'oc2',aux_oc2,istatus) + if ( istatus == 0 ) aux_oc2 = zero + call gsi_bundlegetpointer(chem_bundle,'dust1',aux_du1,istatus) + if ( istatus == 0 ) aux_du1 = zero + call gsi_bundlegetpointer(chem_bundle,'dust2',aux_du2,istatus) + if ( istatus == 0 ) aux_du2 = zero + call gsi_bundlegetpointer(chem_bundle,'dust3',aux_du3,istatus) + if ( istatus == 0 ) aux_du3 = zero + call gsi_bundlegetpointer(chem_bundle,'dust4',aux_du4,istatus) + if ( istatus == 0 ) aux_du4 = zero + call gsi_bundlegetpointer(chem_bundle,'dust5',aux_du5,istatus) + if ( istatus == 0 ) aux_du5 = zero + call gsi_bundlegetpointer(chem_bundle,'seas1',aux_ss1,istatus) + if ( istatus == 0 ) aux_ss1 = zero + call gsi_bundlegetpointer(chem_bundle,'seas2',aux_ss2,istatus) + if ( istatus == 0 ) aux_ss2 = zero + call gsi_bundlegetpointer(chem_bundle,'seas3',aux_ss3,istatus) + if ( istatus == 0 ) aux_ss3 = zero + call gsi_bundlegetpointer(chem_bundle,'seas4',aux_ss4,istatus) + if ( istatus == 0 ) aux_ss4 = zero + end if ! laeroana_gocart inithead=.true. do it=1,ntlevs if ( lwrite4danl ) then + ! check to see if we want to output this time. + ! if not, skip to next time + if (count(nhr_anal/=0)>0) then + if (count(nhr_anal==ifilesig(it))==0) cycle + endif itoutsig = it if ( it == ntguessig ) then if ( increment > 0 ) then @@ -1291,13 +1386,68 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) if ( istatus == 0 ) aux_q = ges_q_it call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'oz',ges_oz_it ,istatus) if ( istatus == 0 ) aux_oz = ges_oz_it - call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'cw',ges_cwmr_it,istatus) + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'ql',ges_ql_it,istatus) + if ( istatus == 0 ) aux_ql = ges_ql_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qi',ges_qi_it,istatus) + if ( istatus == 0 ) aux_qi = ges_qi_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qr',ges_qr_it,istatus) + if ( istatus == 0 ) aux_qr = ges_qr_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qs',ges_qs_it,istatus) + if ( istatus == 0 ) aux_qs = ges_qs_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'qg',ges_qg_it,istatus) + if ( istatus == 0 ) aux_qg = ges_qg_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'cf',ges_cf_it,istatus) + if ( istatus == 0 ) aux_cf = ges_cf_it + call gsi_bundlegetpointer (gsi_metguess_bundle(itoutsig),'cw',ges_cwmr_it,istatus) if ( istatus == 0 ) aux_cwmr = ges_cwmr_it +! if aerosols, get the data from chem bundle to output + if ( laeroana_gocart ) then + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust1',ges_du1_it,istatus) + if( istatus==0 ) aux_du1 = ges_du1_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust2',ges_du2_it,istatus) + if( istatus==0 ) aux_du2 = ges_du2_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust3',ges_du3_it,istatus) + if( istatus==0 ) aux_du3 = ges_du3_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust4',ges_du4_it,istatus) + if( istatus==0 ) aux_du4 = ges_du4_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'dust5',ges_du5_it,istatus) + if( istatus==0 ) aux_du5 = ges_du5_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas1',ges_ss1_it,istatus) + if( istatus==0 ) aux_ss1 = ges_ss1_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas2',ges_ss2_it,istatus) + if( istatus==0 ) aux_ss2 = ges_ss2_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas3',ges_ss3_it,istatus) + if( istatus==0 ) aux_ss3 = ges_ss3_it + call gsi_bundlegetpointer(gsi_chemguess_bundle(itoutsig),'seas4',ges_ss4_it,istatus) + if( istatus==0 ) aux_ss4 = ges_ss4_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'sulf',ges_so4_it,istatus) + if( istatus==0 ) aux_so4 = ges_so4_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'oc1',ges_oc1_it,istatus) + if( istatus==0 ) aux_oc1 = ges_oc1_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'oc2',ges_oc2_it,istatus) + if( istatus==0 ) aux_oc2 = ges_oc2_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'bc1',ges_bc1_it,istatus) + if( istatus==0 ) aux_bc1 = ges_bc1_it + call gsi_bundlegetpointer (gsi_chemguess_bundle(itoutsig),'bc2',ges_bc2_it,istatus) + if( istatus==0 ) aux_bc2 = ges_bc2_it + end if ! laeroana_gocart if ( use_gfs_nemsio ) then - call write_nemsatm(grd_a,sp_a,filename,mype_atm, & - atm_bundle,itoutsig) + if (fv3_full_hydro) then + call write_fv3atm_nems(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig) + else + ! if using aerosols, optional chem_bundle argument + if ( laeroana_gocart ) then + call write_nemsatm(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig,chem_bundle) + else + ! otherwise, just atm_bundle + call write_nemsatm(grd_a,sp_a,filename,mype_atm, & + atm_bundle,itoutsig) + end if ! laeroana_gocart + endif else @@ -2075,7 +2225,6 @@ subroutine write_tf_inc_nc(mype_so,xvar2) use guess_grids, only: isli2 use general_commvars_mod, only: ltosi,ltosj - use obsmod, only: iadate use constants, only: rad2deg implicit none diff --git a/src/gsi/ncepnems_io.f90 b/src/gsi/ncepnems_io.f90 new file mode 100755 index 000000000..7727cce33 --- /dev/null +++ b/src/gsi/ncepnems_io.f90 @@ -0,0 +1,5322 @@ +module ncepnems_io +!$$$ module documentation block +! . . . . +! module: ncepnems_io +! prgmmr: Huang org: np23 date: 2010-02-22 +! +! abstract: This module contains routines which handle input/output +! operations for NCEP NEMS global atmospheric and surface files. +! +! program history log: +! 2010-02-22 Huang Initial version. Based on ncepgfs_io +! 2010-10-18 Huang Remove subroutine reorder_gfsgrib for no longer been called in GSI +! For Now, subroutine sfc_interpolate is kept in ncepgfs_io.f90. +! When sigio and gfsio are both retired, i.e., remove ncepgfs_io.f90. +! move this routines back to this module +! 2011-03-03 Huang Changes has been made to adopt to high resolution GSI run (T382 & T574) +! both for CPU and memory issues. +! Future development of nemsio need to consider a mapping routine be +! inserted between read-in forecast field and GSI first guess field, +! as well as GSI analysis field and write-out data field for forecast +! model. Due to computation resource, GSI may not be able to run at +! the same resolution as that of forecast model, e.g., run GSI at T382 +! w/ T574 forecast model output. +! 2011-10-25 Huang (1) Add unified error message routine to make the code cleaner +! (2) To reduce the memory allocation as low as possible, remove all +! reference to sfc_head and re-used the same local arrays. +! Remove unneeded nemsio_data & gfsdata. +! (3) Add parallel IO code to read_atm_ +! 2011-11-01 Huang (1) add integer nst_gsi to control the mode of NSST +! (2) add read_nemsnst to read ncep nst file +! (3) add subroutine write_nemssfc_nst to save sfc and nst files +! 2016-01-01 Li (1) Move tran_gfssfc from ncepgfs_io.f90 to here +! (2) Modify write_sfc_nst_ to follows the update done in sfcio +! (3) Modify read_sfc_ to follows the update done in sfcio for more effective I/O +! 2016-04-20 Li Modify to handle the updated nemsio sig file (P, DP & DPDT removed) +! 2016-08-18 li - tic591: add read_sfc_anl & read_nemssfc_anl to read nemsio sfc file (isli only) with analysis resolution +! change/modify sfc_interpolate to be intrp22 to handle more general interpolation (2d to 2d) +! 2016-11-18 li - tic615: change nst mask name from slmsk to land +! 2017-08-30 li - tic659: modify read_nems_sfc_ and read_sfc_ to read sfc file in +! nemsio Gaussin grids generated by FV3 WriteComponent +! 2018-05-19 eliu - add I/O component for fv3 hydrometeors +! +! Subroutines Included: +! sub read_nems - driver to read ncep nems atmospheric and surface +! sub read_nems_chem +! sub read_nemsatm - read ncep nems atmospheric file, scatter +! on grid to analysis subdomains +! sub read_nemssfc - read ncep nems surface file, scatter on grid to +! analysis subdomains +! sub read_nemssfc_anl- read ncep EnKF nems surface file, scatter on grid to +! analysis subdomains +! sub write_nems - driver to write ncep nems atmospheric and surface +! analysis files +! sub write_nemsatm - gather on grid, write ncep nems atmospheric analysis file +! sub write_nemssfc - gather/write on grid ncep surface analysis file +! sub read_nemsnst - read ncep nst file, scatter on grid to analysis subdomains +! sub write_nems_sfc_nst - gather/write on grid ncep surface & nst analysis file +! sub intrp22 - interpolate from one grid to another grid (2D) +! sub read_nems_sfcnst - read sfc hist file, including sfc and nst vars, scatter on grid to analysis subdomains +! +! Variable Definitions: +! The difference of time Info between operational GFS IO (gfshead%, sfc_head%), +! analysis time (iadate), and NEMSIO (idate=) +! +! gfshead & sfc_head NEMSIO Header Analysis time (obsmod) +! =================== ============================ ========================== +! %idate(1) Hour idate(1) Year iadate(1) Year +! %idate(2) Month idate(2) Month iadate(2) Month +! %idate(3) Day idate(3) Day iadate(3) Day +! %idate(4) Year idate(4) Hour iadate(4) Hour +! idate(5) Minute iadate(5) Minute +! idate(6) Scaled seconds +! idate(7) Seconds multiplier +! +! The difference of header forecasting hour Info bewteen operational GFS IO +! (gfshead%, sfc_head%) and NEMSIO +! +! gfshead & sfc_head NEMSIO Header +! ========================== ============================ +! %fhour FCST Hour (r_kind) nfhour FCST Hour (i_kind) +! nfminute FCST Mins (i_kind) +! nfsecondn FCST Secs (i_kind) numerator +! nfsecondd FCST Secs (i_kind) denominator +! +! %fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 +! +! nframe - nframe is the number of grids extend outward from the +! edge of modeling domain. +! +! NEMSIO provides a more flexible read. User can get the +! size of record (1D) to be read from file header. The +! normal record size should be delx*dely, i.e., total model +! grid points. However, some regional models also ouput +! additional data of grids around the modeling domain +! (buffer zone). For this type of output, nframe needs to +! be know to calculate the size of record, i.e., +! array size = (delx+2*nframe) * (dely+2*nframe) +! +! However, nframe should always be zero for global model. +! To simplify the code for reading and writing global model +! files, we will not factor in the nframe for computing +! array size or array index shift (by nframe) between +! input/output array and internal GSI array. The normal +! size of I/O record remains as delx*dely. Add a checking +! routine to assure nframe=zero. +! +! def imp_physics - type of microphysics used in the GFS. 99: Zhao-Carr, 11: GFDL +! def lupp - if T, UPP is used and additional variables are output +! +! attributes: +! language: f90 +! machine: +! +! NOTE: When global meteorology switched to NEMS/GFS, all routines and +! modules of old GFS (sigio) can be deactivated. To keep the code +! clean, all "nems" can be replaced by "gfs" for minimal changes +! of GSI code structure. For dual purpose, two distincit routine +! names are used to accomodiate old and new systems. It is now +! controled by a namelist argument "use_gfs_nemsio" +! +! +!$$$ end documentation block + + use constants, only: zero,one,fv,r60,r3600 + use kinds, only: i_kind,r_kind + implicit none + + private + public init_nems + public read_nems + public read_nems_chem + public read_nemsatm + public read_nemssfc + public read_nemssfc_anl + public write_fv3atm_nems + public write_nemsatm + public write_nemssfc + public read_nemsnst + public write_nems_sfc_nst + public intrp22 + public tran_gfssfc + public error_msg + + public imp_physics + public lupp + + interface init_nems + module procedure init_ + end interface + + interface read_nems + module procedure read_ + end interface + + interface read_nems_chem + module procedure read_chem_ + end interface + + interface read_nemsatm + module procedure read_atm_ + end interface + + interface read_nemssfc + module procedure read_nemssfc_ + end interface + + interface read_nemssfc_anl + module procedure read_nemssfc_anl_ + end interface + + interface read_nemsnst + module procedure read_nemsnst_ + end interface + + interface write_nemsatm + module procedure write_atm_ + end interface + + interface write_fv3atm_nems + module procedure write_fv3atm_ + end interface + + interface write_nemssfc + module procedure write_sfc_ + end interface + + interface write_nems_sfc_nst + module procedure write_sfc_nst_ + end interface + + interface error_msg + module procedure error_msg_ + end interface + + character(len=*),parameter::myname='ncepnems_io' + + integer(i_kind),save :: imp_physics + logical,save :: lupp +contains + + subroutine init_ +!$$$ subprogram documentation block +! . . . +! subprogram: read_nems +! +! prgrmmr: Todling +! +! abstract: +! +! program history log: +! 2019-07-11 Todling - create to initialize vars that should not be in CV file +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + imp_physics=99 + lupp = .false. + end subroutine init_ + + subroutine read_ +!$$$ subprogram documentation block +! . . . +! subprogram: read_nems +! +! prgrmmr: Ho-Chun Huang +! +! abstract: +! +! program history log: +! 2010-03-31 Huang - create routine based on read_gfs +! 2010-10-19 Huang - remove spectral part for gridded NEMS/GFS +! 2011-05-01 todling - cwmr no longer in guess-grids; use metguess bundle now +! 2013-10-19 todling - metguess now holds background +! 2016-03-30 todling - update interface to general read (pass bundle) +! 2016-06-23 Li - Add cloud partitioning, which was missed (based on GFS +! ticket #239, comment 18) +! 2018-05-19 eliu - add components to read in hydrometeor related +! variables +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: i_kind,r_kind + use constants, only: qcmin + use gridmod, only: sp_a,grd_a,lat2,lon2,nsig + use guess_grids, only: ifilesig,nfldsig,ntguessig + use gsi_metguess_mod, only: gsi_metguess_bundle,gsi_metguess_get + use guess_grids, only: ifilesig,nfldsig + use gsi_metguess_mod, only: gsi_metguess_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_bundlemod, only: gsi_bundlecreate + use gsi_bundlemod, only: gsi_grid + use gsi_bundlemod, only: gsi_gridcreate + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundledestroy + use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info + use mpimod, only: npe,mype + use cloud_efr_mod, only: cloud_calc_gfs,set_cloud_lower_bound + use gridmod, only: fv3_full_hydro + implicit none + + character(len=*),parameter::myname_=myname//'*read_' + character(24) filename + integer(i_kind):: it, istatus, inner_vars, num_fields + integer(i_kind):: i,j,k + + real(r_kind),pointer,dimension(:,: ):: ges_ps_it =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_z_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_u_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_v_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_div_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_vor_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_tv_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_q_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_oz_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_cwmr_it=>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_ql_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qi_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qr_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qs_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_qg_it =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_cf_it =>NULL() + + type(sub2grid_info) :: grd_t + logical regional + logical:: l_cld_derived,zflag,inithead + + type(gsi_bundle) :: atm_bundle + type(gsi_grid) :: atm_grid + integer(i_kind),parameter :: n2d=2 + integer(i_kind),parameter :: n3d=14 + + character(len=4), parameter :: vars2d(n2d) = (/ 'z ', 'ps ' /) + character(len=4), parameter :: vars3d(n3d) = (/ 'u ', 'v ', & + 'vor ', 'div ', & + 'tv ', 'q ', & + 'cw ', 'oz ', & + 'ql ', 'qi ', & + 'qr ', 'qs ', & + 'qg ', 'cf ' /) + + real(r_kind),pointer,dimension(:,:):: ptr2d =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ptr3d =>NULL() + + regional=.false. + inner_vars=1 + +! num_fields=min(8*grd_a%nsig+2,npe) + num_fields=min(n3d*grd_a%nsig+n2d,npe) + if (mype==0) write(6,*)'npe num_fields = ', npe,n3d*grd_a%nsig+n2d,num_fields + + + +! Create temporary communication information fore read routines + call general_sub2grid_create_info(grd_t,inner_vars,grd_a%nlat,grd_a%nlon, & + grd_a%nsig,num_fields,regional) + +! Allocate bundle used for reading members + call gsi_gridcreate(atm_grid,lat2,lon2,nsig) + call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d) + if(istatus/=0) then + write(6,*) myname_,': trouble creating atm_bundle' + call stop2(999) + endif + + + do it=1,nfldsig + + write(filename,'(''sigf'',i2.2)') ifilesig(it) + +! Read background fields into bundle + if (mype==0) write(6,*)'fv3_full_hydro = ', fv3_full_hydro + if (fv3_full_hydro) then + call general_read_fv3atm_nems(grd_t,sp_a,filename,.true.,.true.,.true.,& + atm_bundle,.true.,istatus) + else + call general_read_gfsatm_nems(grd_t,sp_a,filename,.true.,.true.,.true.,& + atm_bundle,.true.,istatus) + endif + + inithead=.false. + zflag=.false. + +! Set values to actual MetGuess fields + call set_guess_ + + if (it==ntguessig) then + if (mype==0) write(6,*)'Print guess field ... after set_guess' + call prt_guess('guess') + endif + if (fv3_full_hydro) then + do k=1, nsig + do j=1, lon2 + do i=1, lat2 + ! set lower bound to hydrometeors + if (associated(ges_ql_it)) ges_ql_it(i,j,k) = max(qcmin,ges_ql_it(i,j,k)) + if (associated(ges_qi_it)) ges_qi_it(i,j,k) = max(qcmin,ges_qi_it(i,j,k)) + if (associated(ges_qr_it)) ges_qr_it(i,j,k) = max(qcmin,ges_qr_it(i,j,k)) + if (associated(ges_qs_it)) ges_qs_it(i,j,k) = max(qcmin,ges_qs_it(i,j,k)) + if (associated(ges_qg_it)) ges_qg_it(i,j,k) = max(qcmin,ges_qg_it(i,j,k)) + if (associated(ges_cf_it)) ges_cf_it(i,j,k) = min(max(zero,ges_cf_it(i,j,k)),one) + enddo + enddo + enddo + else + l_cld_derived = associated(ges_cwmr_it).and.& + associated(ges_q_it) .and.& + associated(ges_ql_it) .and.& + associated(ges_qi_it) .and.& + associated(ges_tv_it) +! call set_cloud_lower_bound(ges_cwmr_it) + if (mype==0) write(6,*)'READ_GFS_NEMS: l_cld_derived = ', l_cld_derived + if (l_cld_derived) then + if (associated(ges_cf_it)) then + call cloud_calc_gfs(ges_ql_it,ges_qi_it,ges_cwmr_it,ges_q_it,ges_tv_it,.true.,ges_cf_it) + else + call cloud_calc_gfs(ges_ql_it,ges_qi_it,ges_cwmr_it,ges_q_it,ges_tv_it,.true.) + endif + end if + end if + if (it==ntguessig) then + if (mype==0) write(6,*)'Print guess field ... after reset cloud lower bound' + call prt_guess('guess') + endif + + end do + call general_sub2grid_destroy_info(grd_t) + call gsi_bundledestroy(atm_bundle,istatus) + + contains + + subroutine set_guess_ + + call gsi_bundlegetpointer (atm_bundle,'ps',ptr2d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'ps',ges_ps_it ,istatus) + if(istatus==0) ges_ps_it = ptr2d + endif + call gsi_bundlegetpointer (atm_bundle,'z',ptr2d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'z' ,ges_z_it ,istatus) + if(istatus==0) ges_z_it = ptr2d + endif + call gsi_bundlegetpointer (atm_bundle,'u',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'u' ,ges_u_it ,istatus) + if(istatus==0) ges_u_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'v',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'v' ,ges_v_it ,istatus) + if(istatus==0) ges_v_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'vor',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'vor',ges_vor_it,istatus) + if(istatus==0) ges_vor_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'div',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'div',ges_div_it,istatus) + if(istatus==0) ges_div_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'tv',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'tv',ges_tv_it ,istatus) + if(istatus==0) ges_tv_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'q',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'q' ,ges_q_it ,istatus) + if(istatus==0) ges_q_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'oz',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'oz',ges_oz_it ,istatus) + if(istatus==0) ges_oz_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'cw',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'cw',ges_cwmr_it,istatus) + if(istatus==0) ges_cwmr_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'ql',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'ql',ges_ql_it,istatus) + if(istatus==0) ges_ql_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'qi',ptr3d,istatus) + + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qi',ges_qi_it,istatus) + if(istatus==0) ges_qi_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'qr',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qr',ges_qr_it,istatus) + if(istatus==0) ges_qr_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'qs',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qs',ges_qs_it,istatus) + if(istatus==0) ges_qs_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'qg',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qg',ges_qg_it,istatus) + if(istatus==0) ges_qg_it = ptr3d + endif + call gsi_bundlegetpointer (atm_bundle,'cf',ptr3d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'cf',ges_cf_it,istatus) + if(istatus==0) ges_cf_it = ptr3d + endif + end subroutine set_guess_ + + end subroutine read_ + + subroutine read_chem_ ( iyear, month,idd ) +!$$$ subprogram documentation block +! . . . +! subprogram: read_nems_chem +! +! prgrmmr: todling +! +! abstract: fills chemguess_bundle with GFS chemistry. +! +! remarks: +! 1. Right now, only CO2 is done and even this is treated +! as constant througout the assimialation window. +! 2. iyear and month could come from obsmod, but logically +! this program should never depend on obsmod +! +! +! program history log: +! 2010-12-23 Huang - initial code, based on read_gfs_chem +! 2011-06-29 todling - no explict reference to internal bundle arrays +! 2019-04-19 Wei/Martin - modified to read NEMS aerosols from either +! NGAC or FV3-Chem +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: i_kind, r_kind + use mpimod, only: mype + use gridmod, only: lat2,lon2,nsig,nlat,rlats,istart + use ncepgfs_ghg, only: read_gfsco2 + use guess_grids, only: nfldsig + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_chemguess_mod, only: gsi_chemguess_bundle + use gsi_chemguess_mod, only: gsi_chemguess_get + use gsi_bundlemod, only: gsi_bundle,gsi_bundlecreate,gsi_bundledestroy + use gsi_bundlemod, only: gsi_grid,gsi_gridcreate + use gridmod, only: regional,use_fv3_aero + use radiance_mod, only: n_aerosols_fwd,aerosol_names_fwd + use gridmod, only: grd_a,sp_a,regional + use guess_grids, only: ifilesig,ifileaer,nfldaer + use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info + use mpimod, only: npe + use chemmod, only: lread_ext_aerosol + + implicit none + +! Declared argument list + integer(i_kind), intent(in):: iyear + integer(i_kind), intent(in):: month + integer(i_kind), intent(in):: idd + +! Declare local variables + integer(i_kind) :: igfsco2, i, j, n, iret + real(r_kind),dimension(lat2):: xlats + real(r_kind),pointer,dimension(:,:,:)::p_co2=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ptr3d=>NULL() + + integer(i_kind) :: i4crtm + real(r_kind),pointer,dimension(:,:,:)::ae_du001_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_du002_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_du003_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_du004_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_du005_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_ss001_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_ss002_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_ss003_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_ss004_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_so4_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_ocpho_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_ocphi_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_bcpho_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ae_bcphi_it=>NULL() + + type(sub2grid_info) :: grd_ae + character(24) filename,str_crtmuse + integer(i_kind) :: it,ia,ier,iera,inner_vars,num_fields,istatus + integer(i_kind) :: anfld + + type(gsi_bundle) :: chem_bundle + type(gsi_grid) :: chem_grid + + if(.not.associated(gsi_chemguess_bundle)) return + call gsi_bundlegetpointer(gsi_chemguess_bundle(1),'co2',p_co2,iret) + if(iret /= 0) return + +! Get subdomain latitude array + j = mype + 1 + do i = 1, lat2 + n = min(max(1, istart(j)+i-2), nlat) + xlats(i) = rlats(n) + enddo + +! Read in CO2 + call gsi_chemguess_get ( 'i4crtm::co2', igfsco2, iret ) + call read_gfsco2 ( iyear,month,idd,igfsco2,xlats,& + lat2,lon2,nsig,mype, p_co2 ) + +! Approximation: setting all times co2 values equal to the daily co2 values + + do n = 2, nfldsig + call gsi_bundlegetpointer(gsi_chemguess_bundle(n),'co2',ptr3d,iret) + ptr3d = p_co2 + enddo + +! Read in Aerosol field via nemsio + if ( n_aerosols_fwd > 0 ) then + if ( mype == 0 ) write(6,*) 'n_aerosols_fwd and aerosol_names_fwd',n_aerosols_fwd,aerosol_names_fwd + call gsi_gridcreate(chem_grid,lat2,lon2,nsig) + call gsi_bundlecreate(chem_bundle,chem_grid,'aux-chem-read',istatus,names3d=aerosol_names_fwd) + + inner_vars=1 + num_fields=min(n_aerosols_fwd*grd_a%nsig,npe) +! Create temporary communication information fore read routines + call general_sub2grid_create_info(grd_ae,inner_vars,grd_a%nlat,grd_a%nlon,grd_a%nsig,num_fields,regional) + + if (lread_ext_aerosol) then + anfld=nfldaer + else + anfld=nfldsig + end if + + do it=1,anfld +! Get pointer to aerosol field + if (lread_ext_aerosol) then + write(filename,'(''aerf'',i2.2)') ifileaer(it) + else + write(filename,'(''sigf'',i2.2)') ifilesig(it) + end if + if (mype==0) write(6,*) "aerosol field come from ",filename + + ier=0 + call general_read_nemsaero(grd_ae,sp_a,filename,mype,chem_bundle,& + n_aerosols_fwd,aerosol_names_fwd,.true.,ier) + + do ia=1,n_aerosols_fwd + + write(str_crtmuse,'(''i4crtm::'',a)') trim(aerosol_names_fwd(ia)) + call gsi_chemguess_get ( str_crtmuse, i4crtm, iera ) + if(mype==0) write(6,*) trim(aerosol_names_fwd(ia))," for crtm is ",i4crtm + + call gsi_bundlegetpointer (chem_bundle,trim(aerosol_names_fwd(ia)),ptr3d,istatus) + if (istatus==0) then + select case ( trim(aerosol_names_fwd(ia)) ) + case ('sulf') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'sulf',ae_so4_it,iret) + if (iret==0) ae_so4_it=ptr3d + case ('bc1') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'bc1',ae_bcpho_it,iret) + if (iret==0) ae_bcpho_it=ptr3d + case ('bc2') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'bc2',ae_bcphi_it,iret) + if (iret==0) ae_bcphi_it=ptr3d + case ('oc1') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'oc1',ae_ocpho_it,iret) + if (iret==0) ae_ocpho_it=ptr3d + case ('oc2') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'oc2',ae_ocphi_it,iret) + if (iret==0) ae_ocphi_it=ptr3d + case ('dust1') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'dust1',ae_du001_it,iret) + if (iret==0) ae_du001_it=ptr3d + case ('dust2') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'dust2',ae_du002_it,iret) + if (iret==0) ae_du002_it=ptr3d + case ('dust3') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'dust3',ae_du003_it,iret) + if (iret==0) ae_du003_it=ptr3d + case ('dust4') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'dust4',ae_du004_it,iret) + if (iret==0) ae_du004_it=ptr3d + case ('dust5') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'dust5',ae_du005_it,iret) + if (iret==0) ae_du005_it=ptr3d + case ('seas1') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'seas1',ae_ss001_it,iret) + if (iret==0) ae_ss001_it=ptr3d + case ('seas2') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'seas2',ae_ss002_it,iret) + if (iret==0) ae_ss002_it=ptr3d + case ('seas3') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'seas3',ae_ss003_it,iret) + if (iret==0) ae_ss003_it=ptr3d + case ('seas4') + call gsi_bundlegetpointer(gsi_chemguess_bundle(it),'seas4',ae_ss004_it,iret) + if (iret==0) ae_ss004_it=ptr3d + end select ! different aerosol tracers + + if(iret/=0 .and. mype==0 ) write(6,*) trim(aerosol_names_fwd(ia))," getpointer fail" + ier=ier+iret + endif ! end if successfully able to get pointer + end do ! n_aerosols_fwd + + if (ier/=0) then + write(6,*) "before call read_ngac_aerosol ier=",ier + cycle ! this allows code to be free from met-fields + end if + + end do ! nfldaer + call general_sub2grid_destroy_info(grd_ae) + call gsi_bundledestroy(chem_bundle,istatus) + + end if ! end if n_aerosols_fwd > 0 + + end subroutine read_chem_ + + subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & + g_z,g_ps,g_vor,g_div,g_u,g_v,& + g_tv,g_q,g_cwmr,g_oz) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_nemsatm read nems atm and send to all mpi tasks +! prgmmr: Huang org: np23 date: 2010-02-22 +! +! abstract: read ncep nems/gfs atmospheric guess field and +! scatter to subdomains +! +! program history log: +! 2010-02-22 Huang Initial version. Based on sub read_gfsatm +! 2011-02-28 Huang Re-arrange the read sequence to be same as model +! write sequence. Alsom allocate and deallocate +! temporary working array immediatelt before and after +! the processing and scattering first guess field to reduce +! maximum resident memory size. Page fault can happen +! when running at high resolution GSI, e.g., T574. +! 2011-09-23 Huang Add NEMS parallel IO capability +! 2013-10-25 todling reposition fill_ns,filluv_ns to commvars +! +! input argument list: +! grd - structure variable containing information about grid +! (initialized by general_sub2grid_create_info, located in +! general_sub2grid_mod.f90) +! sp_a - structure variable containing spectral information for analysis +! (initialized by general_init_spec_vars, located in +! general_specmod.f90) +! uvflag - logical to use u,v (.true.) or st,vp (.false.) perturbations +! vordivflag - logical to determine if routine should output vorticity and +! divergence +! zflag - logical to determine if surface height field should be output +! +! output argument list: +! g_* - guess fields +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind + use gridmod, only: ntracer,ncloud,reload,itotsub + use general_commvars_mod, only: fill_ns,filluv_ns,fill2_ns,filluv2_ns,ltosj_s,ltosi_s + use general_specmod, only: spec_vars + use general_sub2grid_mod, only: sub2grid_info + use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype,mype + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv + use egrid2agrid_mod,only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid + use constants, only: two,pi,half,deg2rad + implicit none + +! Declare local parameters + real(r_kind),parameter:: r0_001 = 0.001_r_kind + +! Declare passed variables + type(sub2grid_info) ,intent(in ) :: grd + character(len=24) ,intent(in ) :: filename + logical ,intent(in ) :: uvflag,vordivflag,zflag + real(r_kind),dimension(grd%lat2,grd%lon2) ,intent( out) :: g_z,g_ps + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent( out) :: g_u,g_v,& + g_vor,g_div,g_cwmr,g_q,g_oz,g_tv + type(spec_vars) ,intent(in ) :: sp_a + +! Declare local variables + character(len=120) :: my_name = 'READ_NEMSATM' + character(len=1) :: null = ' ' + integer(i_kind),dimension(7):: idate + integer(i_kind),dimension(4):: odate + integer(i_kind) :: iret,nlatm2,nflds + integer(i_kind) :: k,icount,icount_prev,mm1,i,j,kk + integer(i_kind) :: mype_hs, mype_ps,nord_int + integer(i_kind) :: latb, lonb, levs, nframe + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind) :: istop = 101 + real(r_kind),allocatable,dimension(:,:) :: grid, grid_v, & + grid_vor, grid_div, grid_b, grid_b2 + real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid2, grid_c2 + real(r_kind),allocatable,dimension(:) :: work, work_vor, work_div, & + work_v + real(r_kind),allocatable,dimension(:,:) :: sub, sub_vor, sub_div, & + sub_v + real(r_kind),dimension(sp_a%nc):: spec_vor,spec_div + real(r_kind),allocatable,dimension(:) :: rwork1d0, rwork1d1, rwork1d2 + real(r_kind),allocatable,dimension(:) :: rlats,rlons,clons,slons + real(4),allocatable,dimension(:) :: r4lats,r4lons + real(r_kind) :: fhour + type(nemsio_gfile) :: gfile + logical diff_res,eqspace + logical,dimension(1) :: vector + type(egrid2agrid_parm) :: p_high + +!****************************************************************************** +! Initialize variables used below + mm1=mype+1 + mype_hs=min(1,npe-1) + mype_ps=0 + nlatm2=grd%nlat-2 + nflds=5*grd%nsig+1 + if(zflag) nflds=nflds+1 + if(vordivflag .or. .not. uvflag)nflds=nflds+2*grd%nsig +! nflds=npe + nflds=grd%nsig + levs=grd%nsig + + allocate( work(grd%itotsub),work_v(grd%itotsub) ) + work=zero + work_v=zero + allocate( sub(grd%lat2*grd%lon2,max(grd%nsig,npe)),sub_v(grd%lat2*grd%lon2,max(grd%nsig,npe)) ) + allocate( sub_div(grd%lat2*grd%lon2,max(grd%nsig,npe)),sub_vor(grd%lat2*grd%lon2,max(grd%nsig,npe)) ) + if(mype < nflds)then + + call nemsio_init(iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'init',istop,iret) + + call nemsio_open(gfile,filename,'READ',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop+1,iret) + + call nemsio_getfilehead(gfile,iret=iret, nframe=nframe, & + nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + idate=idate, dimx=lonb, dimy=latb,dimz=levs) + + if( nframe /= 0 ) then + if ( mype == 0 ) & + write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe + call stop2(101) + end if + + fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year +! +! g_* array already pre-allocate as (lat2,lon2,) => 2D and <3D> array +! + diff_res=.false. + if(latb /= nlatm2) then + diff_res=.true. + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlatm2 = '',i4,tr1,''latb = '',i4)') & + trim(my_name),nlatm2,latb + ! call stop2(101) + end if + if(lonb /= grd%nlon) then + diff_res=.true. + if ( mype == 0 ) write(6, & + '(a,'': different spatial dimension nlon = '',i4,tr1,''lonb = '',i4)') & + trim(my_name),grd%nlon,lonb + ! call stop2(101) + end if + if(levs /= grd%nsig)then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & + trim(my_name),grd%nsig,levs + call stop2(101) + end if +! + allocate( grid(grd%nlon,nlatm2), grid_v(grd%nlon,nlatm2) ) + if(diff_res)then + allocate( grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid2(grd%nlat,grd%nlon,1)) + allocate( grid_b2(lonb,latb),grid_c2(latb+2,lonb,1)) + end if + allocate( rwork1d0(latb*lonb) ) + allocate( rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) + allocate(rwork1d1(latb*lonb)) + call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) + call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) + do j=1,latb + rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) + end do + do j=1,lonb + rlons(j)=deg2rad*r4lons(j) + end do + deallocate(r4lats,r4lons) + rlats(1)=-half*pi + rlats(latb+2)=half*pi + do j=1,lonb + clons(j)=cos(rlons(j)) + slons(j)=sin(rlons(j)) + end do + + nord_int=4 + eqspace=.false. + call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons, & + latb+2,rlats,lonb,rlons,& + nord_int,p_high,.true.,eqspace) + deallocate(rlats,rlons) + end if +! +! Load values into rows for south and north pole before scattering +! +! Terrain: scatter to all mpi tasks +! + if(zflag)then + if (mype==mype_hs) then + call nemsio_readrecv(gfile,'hgt', 'sfc',1,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','read',istop+2,iret) + if(diff_res)then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,itotsub + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) + end do + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call fill_ns(grid,work) + end if + endif + call mpi_scatterv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& + g_z,grd%ijn_s(mm1),mpi_rtype,mype_hs,mpi_comm_world,ierror) + end if + +! Surface pressure: same procedure as terrain, but handled by task mype_ps +! + if (mype==mype_ps) then + call nemsio_readrecv(gfile,'pres','sfc',1,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pres','read',istop+3,iret) + rwork1d1 = r0_001*rwork1d0 + if(diff_res)then + vector(1)=.false. + grid_b=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,itotsub + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) + end do + else + grid=reshape(rwork1d1,(/size(grid,1),size(grid,2)/)) ! convert Pa to cb + call fill_ns(grid,work) + endif + endif + call mpi_scatterv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& + g_ps,grd%ijn_s(mm1),mpi_rtype,mype_ps,mpi_comm_world,ierror) + +! Divergence and voriticity. Compute u and v from div and vor + sub_vor=zero + sub_div=zero + sub =zero + sub_v =zero + icount =0 + icount_prev=1 + allocate( work_vor(grd%itotsub),work_div(grd%itotsub) ) + do k=1,levs + icount=icount+1 + if (mype==mod(icount-1,npe)) then + ! Convert grid u,v to div and vor + call nemsio_readrecv(gfile,'ugrd','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','read',istop+4,iret) + call nemsio_readrecv(gfile,'vgrd','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','read',istop+5,iret) + if(diff_res)then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + grid_b2=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,itotsub + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) + end do + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + end do + end do + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,itotsub + i=ltosi_s(kk) + j=ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + end do + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + end do + end do + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + grid_v=reshape(rwork1d1,(/size(grid_v,1),size(grid_v,2)/)) + call filluv_ns(grid,grid_v,work,work_v) + end if + + if(vordivflag .or. .not. uvflag)then + + allocate( grid_vor(grd%nlon,nlatm2), grid_div(grd%nlon,nlatm2) ) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) + call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) + + ! Load values into rows for south and north pole + call fill_ns(grid_div,work_div) + call fill_ns(grid_vor,work_vor) + deallocate(grid_vor,grid_div) + end if + endif + ! Scatter to sub + if (mod(icount,npe)==0 .or. icount==levs) then + if(vordivflag .or. .not. uvflag)then + call mpi_alltoallv(work_vor,grd%ijn_s,grd%displs_s,mpi_rtype,& + sub_vor(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& + mpi_comm_world,ierror) + call mpi_alltoallv(work_div,grd%ijn_s,grd%displs_s,mpi_rtype,& + sub_div(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& + mpi_comm_world,ierror) + end if + if(uvflag)then + call mpi_alltoallv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& + sub(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& + mpi_comm_world,ierror) + call mpi_alltoallv(work_v,grd%ijn_s,grd%displs_s,mpi_rtype,& + sub_v(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& + mpi_comm_world,ierror) + end if + icount_prev=icount+1 + endif + end do + deallocate(work_vor,work_div) + + ! Transfer vor,div,u,v into real(r_kind) guess arrays + call reload(sub_vor,g_vor) + call reload(sub_div,g_div) + call reload(sub,g_u) + call reload(sub_v,g_v) + deallocate(sub_vor,sub_div) + +! Thermodynamic variable and Specific humidity: communicate to all tasks +! + sub=zero + icount=0 + icount_prev=1 + do k=1,levs + icount=icount+1 + if (mype==mod(icount-1,npe)) then + + call nemsio_readrecv(gfile,'spfh','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','read',istop+6,iret) + if(diff_res)then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,itotsub + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) + end do + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call fill_ns(grid,work) + end if + + call nemsio_readrecv(gfile,'tmp','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop+7,iret) + allocate(rwork1d2(latb*lonb)) + rwork1d2 = rwork1d1*(one+fv*rwork1d0) + if(diff_res)then + grid_b=reshape(rwork1d2,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,itotsub + i=ltosi_s(kk) + j=ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + end do + else + grid_v=reshape(rwork1d2,(/size(grid_v,1),size(grid_v,2)/)) + call fill_ns(grid_v,work_v) + end if + + deallocate(rwork1d2) + endif + + if (mod(icount,npe)==0 .or. icount==levs) then + call mpi_alltoallv(work_v,grd%ijn_s,grd%displs_s,mpi_rtype,& + sub_v(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& + mpi_comm_world,ierror) + call mpi_alltoallv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& + sub(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& + mpi_comm_world,ierror) + icount_prev=icount+1 + endif + end do + call reload(sub_v,g_tv) + call reload(sub,g_q) + deallocate(sub_v,work_v) + + sub=zero + icount=0 + icount_prev=1 + do k=1,levs + icount=icount+1 + if (mype==mod(icount-1,npe)) then + call nemsio_readrecv(gfile,'o3mr','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','read',istop+8,iret) + if(diff_res)then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,itotsub + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) + end do + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call fill_ns(grid,work) + end if + endif + if (mod(icount,npe)==0 .or. icount==levs) then + call mpi_alltoallv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& + sub(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& + mpi_comm_world,ierror) + icount_prev=icount+1 + endif + end do + call reload(sub,g_oz) + +! Cloud condensate mixing ratio. + + if (ntracer>2 .or. ncloud>=1) then + sub=zero + icount=0 + icount_prev=1 + do k=1,levs + icount=icount+1 + if (mype==mod(icount-1,npe)) then + call nemsio_readrecv(gfile,'clwmr','mid layer',k,rwork1d0,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','read',istop+9,iret) + if (imp_physics == 11) then + call nemsio_readrecv(gfile,'icmr','mid layer',k,rwork1d1,iret=iret) + if (iret == 0) then + rwork1d0 = rwork1d0 + rwork1d1 + else + call error_msg(trim(my_name),trim(filename),'icmr','read',istop+10,iret) + endif + endif + if(diff_res)then + grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,itotsub + i=ltosi_s(kk) + j=ltosj_s(kk) + work(kk)=grid2(i,j,1) + end do + else + grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) + call fill_ns(grid,work) + end if + + endif + if (mod(icount,npe)==0 .or. icount==levs) then + call mpi_alltoallv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& + sub(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& + mpi_comm_world,ierror) + icount_prev=icount+1 + endif + end do + call reload(sub,g_cwmr) + else + g_cwmr = zero + endif + + if(mype < nflds)then + if(diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2) + call destroy_egrid2agrid(p_high) + deallocate(rwork1d1,clons,slons) + deallocate(rwork1d0) + deallocate(grid,grid_v) + call nemsio_close(gfile,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop+9,iret) + end if + deallocate(work,sub) + +! Print date/time stamp + if ( mype == 0 ) write(6, & + '(a,'': ges read/scatter,lonb,latb,levs= '',3i6,'',hour= '',f4.1,'',idate= '',4i5)') & + trim(my_name),lonb,latb,levs,fhour,odate + + end subroutine read_atm_ + + subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & + veg_type,soil_type,terrain,isli,use_sfc_any, & + tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_sfc_ read nems hist file +! prgmmr: Li org: np23 date: 2017-08-30 +! +! abstract: read nems sfc & nst combined file +! +! program history log: +! +! input argument list: +! use_sfc_any - true if any processor uses extra surface fields +! +! output argument list: +! sfct - surface temperature (skin temp) +! soil_moi - soil moisture of first layer +! sno - snow depth +! soil_temp - soil temperature of first layer +! veg_frac - vegetation fraction +! fact10 - 10 meter wind factor +! sfc_rough - surface roughness +! veg_type - vegetation type +! soil_type - soil type +! terrain - terrain height +! isli - sea/land/ice mask +! tref - optional, oceanic foundation temperature +! dt_cool - optional, sub-layer cooling amount at sub-skin layer +! z_c - optional, depth of sub-layer cooling layer +! dt_warm - optional, diurnal warming amount at sea surface +! z_w - optional, depth of diurnal warming layer +! c_0 - optional, coefficient to calculate d(Tz)/d(tr) in dimensionless +! c_d - optional, coefficient to calculate d(Tz)/d(tr) in m^-1 +! w_0 - optional, coefficient to calculate d(Tz)/d(tr) in dimensionless +! w_d - optional, coefficient to calculate d(Tz)/d(tr) in m^-1 + +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpimod, only: mype + use kinds, only: r_kind,i_kind,r_single + use gridmod, only: nlat_sfc,nlon_sfc + use guess_grids, only: nfldsfc,ifilesfc + use constants, only: zero,two + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv + implicit none + +! Declare passed variables + logical, intent(in) :: use_sfc_any + real(r_single), dimension(nlat_sfc,nlon_sfc,nfldsfc), intent(out) :: sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough + real(r_single), dimension(nlat_sfc,nlon_sfc), intent(out) :: veg_type,soil_type,terrain + integer(i_kind), dimension(nlat_sfc,nlon_sfc), intent(out) :: isli + real(r_single), optional, dimension(nlat_sfc,nlon_sfc,nfldsfc), intent(out) :: tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d + +! Declare local parameters + integer(i_kind), parameter :: nsfc_all=11 + integer(i_kind),dimension(7):: idate + integer(i_kind),dimension(4):: odate +! Declare local variables + real(r_single), dimension(nlat_sfc,nlon_sfc,nfldsfc) :: xt + character(len=24) :: filename + character(len=120) :: my_name = 'READ_SFCNST' + character(len=1) :: null = ' ' + integer(i_kind) :: i,j,it,n,nsfc + integer(i_kind) :: iret, nframe, lonb, latb + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + real(r_single) :: fhour + integer(i_kind) :: istop = 102 + real(r_single), allocatable, dimension(:) :: rwork2d + real(r_single), allocatable, dimension(:,:) :: work,outtmp +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Define read variable property !!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + type(nemsio_gfile) :: gfile +!----------------------------------------------------------------------------- + call nemsio_init(iret=iret) + if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) + + do it = 1, nfldsfc +! read a surface history file on the task + write(filename,200)ifilesfc(it) +200 format('sfcf',i2.2) + + call nemsio_open(gfile,filename,'READ',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) + + call nemsio_getfilehead(gfile, idate=idate, iret=iret, nframe=nframe, & + nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + dimx=lonb, dimy=latb ) + + if( nframe /= 0 ) then + if ( mype == 0 ) & + write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global sfc hist read, nframe = ', nframe + call stop2(102) + end if + + fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + + if ( (latb /= nlat_sfc-2) .or. (lonb /= nlon_sfc) ) then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension '',''nlon,nlatm2 = '',2(i4,tr1),''-vs- sfc file lonb,latb = '',i4)') & + trim(my_name),nlon_sfc,nlat_sfc-2,lonb,latb + call stop2(102) + endif +! +! Read the surface records (lonb, latb) and convert to GSI array pattern (nlat_sfc,nlon_sfc) +! Follow the read order sfcio in ncepgfs_io +! + allocate(work(lonb,latb)) + allocate(rwork2d(size(work,1)*size(work,2))) + work = zero + rwork2d = zero + + if(it == 1)then + nsfc=nsfc_all + else + nsfc=nsfc_all-4 + end if + + do n = 1, nsfc + + if (n == 1) then ! skin temperature + +! Tsea + call nemsio_readrecv(gfile, 'tmp', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,sfct(1,1,it),lonb,latb) + + elseif(n == 2 .and. use_sfc_any) then ! soil moisture + +! smc/soilw + call nemsio_readrecv(gfile, 'smc', 'soil layer', 1, rwork2d, iret=iret) + ! FV3 nemsio files use 'soilw 0-10cm down' insted of 'smc soil layer 1' + if (iret /= 0) then + if ( mype == 0 ) print *,'could not read smc, try to read soilw 0-10 cm down instead...' + call nemsio_readrecv(gfile,'soilw','0-10 cm down',1,rwork2d,iret=iret) + if (iret /= 0) & + call error_msg(trim(my_name),trim(filename),'smc/soilw','read',istop,iret) + endif + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,soil_moi(1,1,it),lonb,latb) + + elseif(n == 3) then ! snow depth + +! sheleg + call nemsio_readrecv(gfile, 'weasd','sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'weasd','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,sno(1,1,it),lonb,latb) + + elseif(n == 4 .and. use_sfc_any) then ! soil temperature + +! stc/tmp + call nemsio_readrecv(gfile, 'stc', 'soil layer', 1, rwork2d, iret=iret) + if (iret /= 0) then + ! FV3 nemsio files use 'tmp 0-10cm down' insted of 'stc soil layer 1' + if ( mype == 0 ) print *,'could not read stc, try to read tmp 0-10 cm down instead...' + call nemsio_readrecv(gfile,'tmp','0-10 cm down',1,rwork2d,iret=iret) + if (iret /= 0) & + call error_msg(trim(my_name),trim(filename),'stc/tmp','read',istop,iret) + endif + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,soil_temp(1,1,it),lonb,latb) + + elseif(n == 5 .and. use_sfc_any) then ! vegetation cover + +! vfrac + call nemsio_readrecv(gfile, 'veg', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'veg','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,veg_frac(1,1,it),lonb,latb) + + elseif(n == 6) then ! 10m wind factor + +! f10m + call nemsio_readrecv(gfile, 'f10m', '10 m above gnd', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'f10m','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,fact10(1,1,it),lonb,latb) + + elseif(n == 7) then ! suface roughness + +! zorl + call nemsio_readrecv(gfile, 'sfcr', 'sfc', 1, rwork2d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'sfcr','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,sfc_rough(1,1,it),lonb,latb) + + elseif(n == 8 .and. use_sfc_any) then ! vegetation type + +! vtype + call nemsio_readrecv(gfile, 'vtype','sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vtype','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,veg_type,lonb,latb) + + elseif(n == 9 .and. use_sfc_any) then ! soil type + +! stype + call nemsio_readrecv(gfile, 'sotyp','sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'sotyp','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,soil_type,lonb,latb) + + elseif(n == 10) then ! terrain + +! orog + call nemsio_readrecv(gfile, 'orog', 'sfc', 1, rwork2d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'orog','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,terrain,lonb,latb) + + elseif(n == 11) then ! sea/land/ice flag + +! slmsk + call nemsio_readrecv(gfile, 'land', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'land','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + allocate(outtmp(latb+2,lonb)) + call tran_gfssfc(work,outtmp,lonb,latb) + do j=1,lonb + do i=1,latb+2 + isli(i,j) = nint(outtmp(i,j)) + end do + end do + deallocate(outtmp) + + endif +! End of loop over data records + enddo + + if( present(tref) ) then + if ( mype == 0 ) write(6,*) ' read 9 optional NSST variables ' + + call nemsio_readrecv(gfile, 'tref', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tref','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,tref(1,1,it),lonb,latb) + + call nemsio_readrecv(gfile, 'dtcool','sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dtcool','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,dt_cool(1,1,it),lonb,latb) + + call nemsio_readrecv(gfile, 'zc', 'sfc', 1, rwork2d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'z_c','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,z_c(1,1,it),lonb,latb) + + call nemsio_readrecv(gfile, 'xt', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'xt','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,xt(1,1,it),lonb,latb) + + call nemsio_readrecv(gfile, 'xz', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'xz','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,z_w(1,1,it),lonb,latb) + + call nemsio_readrecv(gfile, 'c0', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'c0','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,c_0(1,1,it),lonb,latb) + + call nemsio_readrecv(gfile, 'cd', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'cd','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,c_d(1,1,it),lonb,latb) + + call nemsio_readrecv(gfile, 'w0', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'w0','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,w_0(1,1,it),lonb,latb) + + call nemsio_readrecv(gfile, 'wd', 'sfc', 1, rwork2d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'wd','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,w_d(1,1,it),lonb,latb) +! +! Get diurnal warming amout at z=0 +! + do j = 1,nlon_sfc + do i = 1,nlat_sfc + if (z_w(i,j,it) > zero) then + dt_warm(i,j,it) = two*xt(i,j,it)/z_w(i,j,it) + end if + end do + end do + endif +! Deallocate local work arrays + deallocate(work,rwork2d) + + call nemsio_close(gfile,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) +! +! Print date/time stamp + if ( mype == 0 ) write(6, & + '(a,'': sfc read,nlon,nlat= '',2i6,'',hour= '',f4.1,'',idate= '',4i5)') & + trim(my_name),lonb,latb,fhour,odate +! End of loop over time levels + end do + end subroutine read_sfc_ + + subroutine read_nemssfc_(iope,sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & + veg_type,soil_type,terrain,isli,use_sfc_any, & + tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_nemssfc_ read nems hist file +! prgmmr: xuli org: np23 date: 2017-08-30 +! +! abstract: read nems surface file +! +! program history log: +! 2017-08-30 li +! +! input argument list: +! iope - mpi task handling i/o +! use_sfc_any - true if any processor uses extra surface fields +! +! output argument list: +! sfct - surface temperature (skin temp) +! soil_moi - soil moisture of first layer +! sno - snow depth +! soil_temp - soil temperature of first layer +! veg_frac - vegetation fraction +! fact10 - 10 meter wind factor +! sfc_rough - surface roughness +! veg_type - vegetation type +! soil_type - soil type +! terrain - terrain height +! isli - sea/land/ice mask +! tref - oceanic foundation temperature +! dt_cool - optional, sub-layer cooling amount at sub-skin layer +! z_c - optional, depth of sub-layer cooling layer +! dt_warm - optional, diurnal warming amount at sea surface +! z_w - optional, depth of diurnal warming layer +! c_0 - optional, coefficient to calculate d(Tz)/d(tf) +! c_d - optional, coefficient to calculate d(Tz)/d(tf) +! w_0 - optional, coefficient to calculate d(Tz)/d(tf) +! w_d - optional, coefficient to calculate d(Tz)/d(tf) +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use gridmod, only: nlat_sfc,nlon_sfc + use guess_grids, only: nfldsfc,sfcmod_mm5,sfcmod_gfs + use mpimod, only: mpi_itype,mpi_rtype4,mpi_comm_world,mype + use constants, only: zero + implicit none + +! Declare passed variables + integer(i_kind), intent(in) :: iope + logical, intent(in) :: use_sfc_any + real(r_single), dimension(nlat_sfc,nlon_sfc,nfldsfc), intent(out) :: sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough + real(r_single), dimension(nlat_sfc,nlon_sfc), intent(out) :: veg_type,soil_type,terrain + integer(i_kind), dimension(nlat_sfc,nlon_sfc), intent(out) :: isli + real(r_single), optional, dimension(nlat_sfc,nlon_sfc,nfldsfc), intent(out) :: tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d + +! Declare local variables + integer(i_kind):: iret,npts,nptsall + +!----------------------------------------------------------------------------- +! Read surface history file on processor iope + if(mype == iope)then + if ( present(tref) ) then + call read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & + veg_type,soil_type,terrain,isli,use_sfc_any, & + tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) + write(*,*) 'read_sfc nemsio, with NSST variables' + else + call read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & + veg_type,soil_type,terrain,isli,use_sfc_any) + write(*,*) 'read_sfc nemsio, without NSST variables' + endif + endif + +! Load onto all processors + + npts=nlat_sfc*nlon_sfc + nptsall=npts*nfldsfc + + call mpi_bcast(sfct, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(fact10, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(sno, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + if(sfcmod_mm5 .or. sfcmod_gfs)then + call mpi_bcast(sfc_rough, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + else + sfc_rough = zero + endif + call mpi_bcast(terrain, npts, mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(isli, npts, mpi_itype, iope,mpi_comm_world,iret) + if(use_sfc_any)then + call mpi_bcast(veg_frac, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(soil_temp,nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(soil_moi, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(veg_type, npts, mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(soil_type,npts, mpi_rtype4,iope,mpi_comm_world,iret) + endif + if ( present(tref) ) then + call mpi_bcast(tref, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(dt_cool, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(z_c, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(dt_warm, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(z_w, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(c_0, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(c_d, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(w_0, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(w_d, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + endif + + end subroutine read_nemssfc_ + + subroutine read_sfc_anl_(isli_anl) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_sfc_anl_ read nems surface file with analysis resolution +! +! prgmmr: li org: np23 date: 2016-08-18 +! +! abstract: read nems surface file at analysis grids when nlon /= nlon_sfc or nlat /= nlat_sfc +! +! program history log: +! +! input argument list: +! +! output argument list: +! isli - sea/land/ice mask +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpimod, only: mype + use kinds, only: r_kind,i_kind,r_single + use gridmod, only: nlat,nlon + use constants, only: zero + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv + implicit none + +! Declare passed variables + integer(i_kind), dimension(nlat,nlon), intent( out) :: isli_anl + +! Declare local parameters + integer(i_kind),dimension(7):: idate + integer(i_kind),dimension(4):: odate + + +! Declare local variables + character(len=24) :: filename + character(len=120) :: my_name = 'READ_NEMSSFC_ANL' + character(len=1) :: null = ' ' + integer(i_kind) :: i,j + integer(i_kind) :: iret, nframe, lonb, latb + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + real(r_single) :: fhour + integer(i_kind) :: istop = 102 + real(r_single), allocatable, dimension(:) :: rwork2d + real(r_single), allocatable, dimension(:,:) :: work,outtmp + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Define read variable property !!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + type(nemsio_gfile) :: gfile +!----------------------------------------------------------------------------- + + call nemsio_init(iret=iret) + if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) + + + filename='sfcf06_anlgrid' + call nemsio_open(gfile,trim(filename),'READ',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) + + call nemsio_getfilehead(gfile, idate=idate, iret=iret, nframe=nframe, & + nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + dimx=lonb, dimy=latb ) + + if( nframe /= 0 ) then + if ( mype == 0 ) & + write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe + call stop2(102) + end if + + fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + + if ( (latb /= nlat-2) .or. (lonb /= nlon) ) then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension '',''nlon,nlatm2 = '',2(i4,tr1),''-vs- sfc file lonb,latb = '',i4)') & + trim(my_name),nlon,nlat-2,lonb,latb + call stop2(102) + endif +! +! Read the surface records (lonb, latb) and convert to GSI array pattern (nlat,nlon) +! Follow the read order sfcio in ncepgfs_io +! + allocate(work(lonb,latb)) + allocate(rwork2d(size(work,1)*size(work,2))) + work = zero + rwork2d = zero + +! slmsk + call nemsio_readrecv(gfile, 'land', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'land','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + allocate(outtmp(latb+2,lonb)) + call tran_gfssfc(work,outtmp,lonb,latb) + do j=1,lonb + do i=1,latb+2 + isli_anl(i,j) = nint(outtmp(i,j)) + end do + end do + deallocate(outtmp) + +! Deallocate local work arrays + deallocate(work,rwork2d) + + call nemsio_close(gfile,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) +! +! Print date/time stamp + if ( mype == 0 ) write(6, & + '(a,'': read_sfc_anl_ ,nlon,nlat= '',2i6,'',hour= '',f4.1,'',idate= '',4i5)') & + trim(my_name),lonb,latb,fhour,odate + end subroutine read_sfc_anl_ + + subroutine read_nemssfc_anl_(iope,isli_anl) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_nemssfc_anl read nems surface guess file with analysis resolution +! +! prgmmr: xuli org: np23 date: 2016-08-18 +! +! abstract: read nems surface file at analysis grids +! +! program history log: +! +! input argument list: +! iope - mpi task handling i/o +! +! output argument list: +! isli - sea/land/ice mask +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use gridmod, only: nlat,nlon + use mpimod, only: mpi_itype,mpi_comm_world,mype + implicit none + +! Declare passed variables + integer(i_kind), intent(in ) :: iope + integer(i_kind), dimension(nlat,nlon), intent( out) :: isli_anl + + +! Declare local variables + integer(i_kind):: iret,npts + +!----------------------------------------------------------------------------- +! Read surface file on processor iope + if(mype == iope)then + call read_sfc_anl_(isli_anl) + write(*,*) 'read_sfc nemsio' + end if + +! Load onto all processors + npts=nlat*nlon + call mpi_bcast(isli_anl,npts,mpi_itype,iope,mpi_comm_world,iret) + + end subroutine read_nemssfc_anl_ + + subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) + +!$$$ subprogram documentation block +! . . . . +! subprogram: read_nst_ read nems nst surface guess file (quadratic +! Gaussin grids) without scattering to tasks +! prgmmr: Huang org: np23 date: 2011-11-01 +! +! abstract: read nems surface NST file +! +! program history log: +! 2011-11-01 Huang Initial version based on sub read_gfsnst +! 2016-03-13 Li Modify for more effective I/O +! +! input argument list: +! +! output argument list: +! tref (:,:) ! oceanic foundation temperature +! dt_cool (:,:) ! sub-layer cooling amount at sub-skin layer +! z_c (:,:) ! depth of sub-layer cooling layer +! dt_warm (:,:) ! diurnal warming amount at sea surface (skin layer) +! z_w (:,:) ! depth of diurnal warming layer +! c_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) +! c_d (:,:) ! coefficient to calculate d(Tz)/d(tr) +! w_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) +! w_d (:,:) ! coefficient to calculate d(Tz)/d(tr) +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use mpimod, only: mype + use gridmod, only: nlat_sfc,nlon_sfc + use constants, only: zero,two + use guess_grids, only: nfldnst,ifilenst + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv + implicit none + +! Declare passed variables + real(r_single) , dimension(nlat_sfc,nlon_sfc,nfldnst), intent( out) :: & + tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d +! Declare local parameters + integer(i_kind),parameter :: n_nst=9 + integer(i_kind),dimension(7) :: idate + integer(i_kind),dimension(4) :: odate + +! Declare local variables + character(len=6) :: filename + character(len=120) :: my_name = 'READ_NEMSNST' + character(len=1) :: null = ' ' + integer(i_kind) :: i,j,it,latb,lonb + integer(i_kind) :: iret, nframe + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind) :: istop = 103 + real(r_single) :: fhour + real(r_single), dimension(nlat_sfc,nlon_sfc,nfldnst) :: xt + real(r_single), allocatable, dimension(:) :: rwork2d + real(r_single), allocatable, dimension(:,:) :: work + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Define read variable property !!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + type(nemsio_gfile) :: gfile +!----------------------------------------------------------------------------- + + call nemsio_init(iret=iret) + if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) + + + do it=1,nfldnst +! read a nst file on the task + write(filename,200)ifilenst(it) +200 format('nstf',i2.2) + call nemsio_open(gfile,trim(filename),'READ',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) + + call nemsio_getfilehead(gfile, idate=idate, iret=iret, nframe=nframe, & + nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + dimx=lonb, dimy=latb ) + + if( nframe /= 0 ) then + if ( mype == 0 ) & + write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe + call stop2(istop) + end if + + fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + odate(1) = idate(4) !hour + odate(2) = idate(2) !month + odate(3) = idate(3) !day + odate(4) = idate(1) !year + + if ( (latb /= nlat_sfc-2) .or. (lonb /= nlon_sfc) ) then + if ( mype == 0 ) & + write(6,'(a,'': inconsistent spatial dimension nlon,nlatm2 = '',2(i4,tr1),''-vs- sfc file lonb,latb = '',i4)') & + trim(my_name),nlon_sfc,nlat_sfc-2,lonb,latb + call stop2(80) + endif +! +! Load surface fields into local work array +! Follow NEMS/GFS sfcf read order +! + allocate(work(lonb,latb)) + allocate(rwork2d(size(work,1)*size(work,2))) + work = zero + rwork2d = zero + +! Tref + call nemsio_readrecv(gfile, 'tref', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tref','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,tref(1,1,it),lonb,latb) + +! dt_cool + call nemsio_readrecv(gfile, 'dtcool','sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dt_cool','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,dt_cool(1,1,it),lonb,latb) + +! z_c + call nemsio_readrecv(gfile, 'zc', 'sfc', 1, rwork2d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'z_c','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,z_c(1,1,it),lonb,latb) + +! xt + call nemsio_readrecv(gfile, 'xt', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'xt','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,xt(1,1,it),lonb,latb) + +! xz + call nemsio_readrecv(gfile, 'xz', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'xz','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,z_w(1,1,it),lonb,latb) +! +! c_0 + call nemsio_readrecv(gfile, 'c0', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'c_0','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,c_0(1,1,it),lonb,latb) + +! c_d + call nemsio_readrecv(gfile, 'cd', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'c_d','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,c_d(1,1,it),lonb,latb) + +! w_0 + call nemsio_readrecv(gfile, 'w0', 'sfc', 1, rwork2d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'w_0','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,w_0(1,1,it),lonb,latb) + +! w_d + call nemsio_readrecv(gfile, 'wd', 'sfc', 1, rwork2d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'w_d','read',istop,iret) + work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) + call tran_gfssfc(work,w_d(1,1,it),lonb,latb) + +! +! Get diurnal warming amout at z=0 +! + do j = 1,nlon_sfc + do i = 1,nlat_sfc + if (z_w(i,j,it) > zero) then + dt_warm(i,j,it) = two*xt(i,j,it)/z_w(i,j,it) + end if + end do + end do + +! Deallocate local work arrays + deallocate(work,rwork2d) + + call nemsio_close(gfile,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) +! End of loop over time levels + end do + end subroutine read_nst_ + + + subroutine read_nemsnst_ (iope,tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) + +!$$$ subprogram documentation block +! . . . . +! subprogram: read_nems_nst +! prgmmr: li org: np23 date: 2016-03-13 +! +! abstract: read nems nst fields from a specific task and then broadcast to others +! +! input argument list: +! iope - mpi task handling i/o +! +! output argument list: +! tref (:,:) ! oceanic foundation temperature +! dt_cool (:,:) ! sub-layer cooling amount at sub-skin layer +! z_c (:,:) ! depth of sub-layer cooling layer +! dt_warm (:,:) ! diurnal warming amount at sea surface +! z_w (:,:) ! depth of diurnal warming layer +! c_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) in dimensionless +! c_d (:,:) ! coefficient to calculate d(Tz)/d(tr) in m^-1 +! w_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) in dimensionless +! w_d (:,:) ! coefficient to calculate d(Tz)/d(tr) in m^-1 +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use gridmod, only: nlat_sfc,nlon_sfc + use guess_grids, only: nfldnst + use mpimod, only: mpi_itype,mpi_rtype4,mpi_comm_world + use mpimod, only: mype + use constants, only: zero + implicit none + +! Declare passed variables + integer(i_kind), intent(in ) :: iope + real(r_single), dimension(nlat_sfc,nlon_sfc,nfldnst), intent( out) :: & + tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d + +! Declare local variables + integer(i_kind):: iret,npts,nptsall + +!----------------------------------------------------------------------------- +! Read nst file on processor iope + if(mype == iope)then + write(*,*) 'read_nst nemsio' + call read_nst_(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) + end if + +! Load onto all processors + + npts=nlat_sfc*nlon_sfc + nptsall=npts*nfldnst + + call mpi_bcast(tref, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(dt_cool, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(z_c, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(dt_warm, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(z_w, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(c_0, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(c_d, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(w_0, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + call mpi_bcast(w_d, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) + + end subroutine read_nemsnst_ + + subroutine write_fv3atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) + +!$$$ subprogram documentation block +! . . . +! subprogram: write_fv3atm --- Gather, transform, and write out +! +! prgmmr: eliu org: np23 date: 2018-05-15 +! +! abstract: This routine gathers fields needed for the GSI analysis +! file from subdomains and then transforms the fields from +! analysis grid to model guess grid, then written to an +! atmospheric analysis file. +! +! program history log: +! 2018-05-19 eliu Initial version. Based on write_nemsatm (Huang) +! +! input argument list: +! filename - file to open and write to +! mype_out - mpi task to write output file +! gfs_bundle - bundle containing fields on subdomains +! ibin - time bin +! gfschem_bundle - (optional) bundle containing chemistry fields +! +! output argument list: +! +! attributes: +! language: f90 +! machines: ibm RS/6000 SP; SGI Origin 2000; Compaq HP +! +!$$$ end documentation block + +! !USES: + use kinds, only: r_kind,i_kind + + use constants, only: r1000,fv,one,zero,qcmin,r0_05,t0c + + use mpimod, only: mpi_rtype + use mpimod, only: mpi_comm_world + use mpimod, only: ierror + use mpimod, only: mype + + use guess_grids, only: ifilesig + use guess_grids, only: ges_prsl,ges_prsi + use guess_grids, only: load_geop_hgt,geop_hgti,ges_geopi + + use gridmod, only: ntracer + use gridmod, only: ncloud + use gridmod, only: strip,jcap_b,bk5 + + use general_commvars_mod, only: load_grid,fill2_ns,filluv2_ns + use general_specmod, only: spec_vars + + use obsmod, only: iadate + use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_init,& + nemsio_getfilehead,nemsio_close,nemsio_writerecv,nemsio_readrecv + use gsi_4dvar, only: ibdate,nhr_obsbin,lwrite4danl + use general_sub2grid_mod, only: sub2grid_info + use egrid2agrid_mod,only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid + use constants, only: two,pi,half,deg2rad + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use control_vectors, only: cvars3d + use cloud_efr_mod, only: cloud_calc_gfs + use mpeu_util, only: getindex + + implicit none + +! !INPUT PARAMETERS: + + type(sub2grid_info), intent(in) :: grd + type(spec_vars), intent(in) :: sp_a + character(len=24), intent(in) :: filename ! file to open and write to + integer(i_kind), intent(in) :: mype_out ! mpi task to write output file + type(gsi_bundle), intent(in) :: gfs_bundle + integer(i_kind), intent(in) :: ibin ! time bin + +!------------------------------------------------------------------------- + + real(r_kind),parameter:: r0_001 = 0.001_r_kind + character(6):: fname_ges + character(len=120) :: my_name = 'WRITE_FV3ATM_NEMS' + character(len=1) :: null = ' ' + integer(i_kind),dimension(7):: idate, jdate + integer(i_kind),dimension(4):: odate + integer(i_kind) :: k, mm1, nlatm2, nord_int, i, j, kk + integer(i_kind) :: iret, lonb, latb, levs, istatus + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind) :: istop = 104 + integer(i_kind),dimension(5):: mydate + integer(i_kind),dimension(8) :: ida,jda + real(r_kind),dimension(5) :: fha + real(r_kind) :: fhour + + real(r_kind),pointer,dimension(:,:) :: sub_ps + real(r_kind),pointer,dimension(:,:,:) :: sub_u,sub_v,sub_tv + real(r_kind),pointer,dimension(:,:,:) :: sub_q,sub_oz + real(r_kind),pointer,dimension(:,:,:) :: sub_ql,sub_qi,sub_qr,sub_qs,sub_qg + + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig) :: sub_dzb,sub_dza + + real(r_kind),dimension(grd%lat1*grd%lon1) :: psm + real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: tvsm, usm, vsm + real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: qsm, ozsm + real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: dzsm + real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: qlsm,qism,qrsm,qssm,qgsm + + real(r_kind),dimension(max(grd%iglobal,grd%itotsub)) :: work1,work2 + real(r_kind),dimension(grd%nlon,grd%nlat-2):: grid + real(r_kind),allocatable,dimension(:) :: rwork1d,rwork1d1,rlats,rlons,clons,slons + real(4),allocatable,dimension(:) :: r4lats,r4lons + real(r_kind),allocatable,dimension(:,:) :: grid_b,grid_b2 + real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid3, grid_c2 + type(nemsio_gfile) :: gfile,gfileo + logical diff_res,eqspace + logical lql,lqi,lqr,lqs,lqg + logical,dimension(1) :: vector + type(egrid2agrid_parm) :: p_low,p_high + +!************************************************************************* +! Initialize local variables + mm1=mype+1 + nlatm2=grd%nlat-2 + diff_res=.false. + + lql=getindex(cvars3d,'ql')>0 + lqi=getindex(cvars3d,'qi')>0 + lqr=getindex(cvars3d,'qr')>0 + lqs=getindex(cvars3d,'qs')>0 + lqg=getindex(cvars3d,'qg')>0 + + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'ps', sub_ps,iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'u', sub_u, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'v', sub_v, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'tv', sub_tv,iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'q', sub_q, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'oz', sub_oz,iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'ql', sub_ql,iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'qi', sub_qi,iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'qr', sub_qr,iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'qs', sub_qs,iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'qg', sub_qg,iret); istatus=istatus+iret + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'write_fv3atm_: ERROR' + write(6,*) 'Missing some of the required fields' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + + if ( sp_a%jcap /= jcap_b ) then + if ( mype == 0 ) write(6, & + '('' dual resolution for nems sp_a%jcap,jcap_b = '',2i6)') & + sp_a%jcap,jcap_b + diff_res = .true. + endif + + + ! Single task writes analysis data to analysis file + if ( mype == mype_out ) then + write(fname_ges,'(''sigf'',i2.2)') ifilesig(ibin) + + ! Read header information from first guess file. + call nemsio_init(iret) + if ( iret /= 0 ) call error_msg(trim(my_name),null,null,'init',istop,iret) + + call nemsio_open(gfile,trim(fname_ges),'read',iret) + if ( iret /= 0 ) call error_msg(trim(my_name),trim(fname_ges),null,'open',istop,iret) + + call nemsio_getfilehead(gfile, iret=iret, nfhour=nfhour, & + nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + idate=idate, dimx=lonb, dimy=latb, dimz=levs) + if ( iret /= 0 ) then + write(6,*) trim(my_name),': problem with nemsio_getfilehead, Status = ',iret + call stop2(103) + endif + if ( levs /= grd%nsig ) then + write(6,*) trim(my_name),': problem in data dimension background levs = ',levs,' nsig = ',grd%nsig + call stop2(103) + endif + ! copy input header info to output header info + gfileo=gfile + + ! Update header information (with ibdate) and write it to analysis file + ! (w/ _open statement). + mydate=ibdate + fha(:)=zero ; ida=0; jda=0 + fha(2)=real(nhr_obsbin*(ibin-1)) ! relative time interval in hours + ida(1)=mydate(1) ! year + ida(2)=mydate(2) ! month + ida(3)=mydate(3) ! day + ida(4)=0 ! time zone + ida(5)=mydate(4) ! hour + + ! Move date-time forward by nhr_assimilation hours + call w3movdat(fha,ida,jda) + + jdate(1) = jda(1) ! analysis year + jdate(2) = jda(2) ! analysis month + jdate(3) = jda(3) ! analysis day + jdate(4) = jda(5) ! analysis hour + jdate(5) = iadate(5) ! analysis minute + jdate(6) = 0 ! analysis scaled seconds + jdate(7) = idate(7) ! analysis seconds multiplier + + nfhour =0 ! new forecast hour, zero at analysis time + nfminute =0 + nfsecondn=0 + nfsecondd=100 ! default for denominator + + fhour = zero + odate(1) = jdate(4) !hour + odate(2) = jdate(2) !month + odate(3) = jdate(3) !day + odate(4) = jdate(1) !year + + ! open new output file with new header gfileo with "write" access. + ! Use this call to update header as well + + call nemsio_open(gfileo,trim(filename),'write',iret=iret, & + idate=jdate, nfhour=nfhour, nfminute=nfminute, & + nfsecondn=nfsecondn, nfsecondd=nfsecondd) + if ( iret /= 0 ) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) + + ! Allocate structure arrays to hold data + allocate(rwork1d(latb*lonb),rwork1d1(latb*lonb)) + if ( diff_res .or. lupp) then + allocate( grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid3(grd%nlat,grd%nlon,1)) + allocate( grid_b2(lonb,latb),grid_c2(latb+2,lonb,1)) + allocate( rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) + call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) + call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) + do j=1,latb + rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) + enddo + rlats(1)=-half*pi + rlats(latb+2)=half*pi + do j=1,lonb + rlons(j)=deg2rad*r4lons(j) + enddo + do j=1,lonb + clons(j)=cos(rlons(j)) + slons(j)=sin(rlons(j)) + enddo + nord_int=4 + eqspace=.false. + call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons, & + latb+2,rlats,lonb,rlons,& + nord_int,p_low,.false.,eqspace=eqspace) + call g_create_egrid2agrid(latb+2,rlats,lonb,rlons, & + grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons,& + nord_int,p_high,.false.,eqspace=eqspace) + + deallocate(rlats,rlons,r4lats,r4lons) + endif ! if ( diff_res ) + + ! Terrain + ! Write out input file surface height + + call nemsio_readrecv(gfile,'hgt', 'sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','writeread',istop,iret) + call nemsio_writerecv(gfileo,'hgt','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','write',istop,iret) + endif ! if ( mype == mype_out ) + + ! Calculate delz increment for UPP + if (lupp) then + do k=1,grd%nsig + sub_dzb(:,:,k) = ges_geopi(:,:,k+1,ibin) - ges_geopi(:,:,k,ibin) + enddo + + if ((.not. lwrite4danl) .or. ibin == 1) call load_geop_hgt + do k=1,grd%nsig + sub_dza(:,:,k) = geop_hgti(:,:,k+1,ibin) - geop_hgti(:,:,k,ibin) + enddo + + sub_dza = sub_dza - sub_dzb !sub_dza is increment + endif + + ! Strip off boundary points from subdomains + call strip(sub_ps ,psm) + call strip(sub_tv ,tvsm ,grd%nsig) + call strip(sub_q ,qsm ,grd%nsig) + call strip(sub_oz ,ozsm ,grd%nsig) + call strip(sub_u ,usm ,grd%nsig) + call strip(sub_v ,vsm ,grd%nsig) + if (lql ) call strip(sub_ql ,qlsm ,grd%nsig) + if (lqi ) call strip(sub_qi ,qism ,grd%nsig) + if (lqr ) call strip(sub_qr ,qrsm ,grd%nsig) + if (lqs ) call strip(sub_qs ,qssm ,grd%nsig) + if (lqg ) call strip(sub_qg ,qgsm ,grd%nsig) + if (lupp) call strip(sub_dza ,dzsm ,grd%nsig) + + ! Thermodynamic variable + ! The GSI analysis variable is virtual temperature (Tv). For NEMSIO + ! output we need the sensible temperature. + + ! Convert Tv to T + tvsm = tvsm/(one+fv*qsm) + + ! Generate and write analysis fields + + ! Surface pressure. + call mpi_gatherv(psm,grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype==mype_out) then + if(diff_res .or. lupp)then + call nemsio_readrecv(gfile,'pres','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pres','read',istop,iret) + rwork1d1 = r0_001*rwork1d + grid_b=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + if (lupp) work1(kk)=grid3(i,j,1) + end do + if (lupp) then + do k=1,grd%nsig + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)*(bk5(k)-bk5(k+1)) + enddo + call g_egrid2agrid(p_high,grid3,grid_c2,1,1,vector) + call nemsio_readrecv(gfile,'dpres','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dpres','read',istop,iret) + grid_b2=reshape(rwork1d,(/size(grid_b2,1),size(grid_b2,2)/)) + do j=1,latb + do i=1,lonb + grid_b2(i,j)=grid_b2(i,j)+r1000*(grid_c2(latb-j+2,i,1)) + enddo + enddo + rwork1d = reshape(grid_b2,(/size(rwork1d)/)) + call nemsio_writerecv(gfileo,'dpres','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dpres','write',istop,iret) + enddo + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk) + enddo + endif + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=r1000*(grid_b(i,j)+grid_c(latb-j+2,i,1)) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + grid = grid*r1000 + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'pres','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'psfc','write',istop,iret) + endif +! u, v + do k=1,grd%nsig + call mpi_gatherv(usm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + call mpi_gatherv(vsm(1,k),grd%ijn(mm1),mpi_rtype,& + work2,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype==mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'ugrd','mid layer',k,rwork1d,iret=iret) + call nemsio_readrecv(gfile,'vgrd','mid layer',k,rwork1d1,iret=iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + grid_b2=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + call g_egrid2agrid(p_low,grid_c2,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work2(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b2(i,j)=grid_b2(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + rwork1d1 = reshape(grid_b2,(/size(rwork1d1)/)) + + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + call load_grid(work2,grid) + rwork1d1 = reshape(grid,(/size(rwork1d1)/)) + end if + + ! Zonal wind + call nemsio_writerecv(gfileo,'ugrd','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','write',istop,iret) + ! Meridional wind + call nemsio_writerecv(gfileo,'vgrd','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','write',istop,iret) + endif + end do +! Thermodynamic variable + do k=1,grd%nsig + call mpi_gatherv(tvsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'tmp','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'tmp','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','write',istop,iret) + endif + end do +! Specific humidity + do k=1,grd%nsig + call mpi_gatherv(qsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'spfh','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'spfh','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','write',istop,iret) + endif + end do +! Ozone + do k=1,grd%nsig + call mpi_gatherv(ozsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'o3mr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'o3mr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','write',istop,iret) + endif + end do +! Cloud condensate mixing ratio + if (ntracer>2 .or. ncloud>=1) then +! Cloud liquid water + do k=1,grd%nsig + if (lql) then + call mpi_gatherv(qlsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'clwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-max(grid3(i,j,1),qcmin) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'clwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','write',istop,iret) + endif + else + if (mype == mype_out) then + call nemsio_readrecv(gfile,'clwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','read',istop,iret) + call nemsio_writerecv(gfileo,'clwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','write',istop,iret) + endif + endif + end do +! Cloud ice + do k=1,grd%nsig + if (lqi) then + call mpi_gatherv(qism(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'icmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-max(grid3(i,j,1),qcmin) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'icmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','write',istop,iret) + endif + else + if (mype == mype_out) then + call nemsio_readrecv(gfile,'icmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','read',istop,iret) + call nemsio_writerecv(gfileo,'icmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','write',istop,iret) + endif + endif + end do +! Rain + do k=1,grd%nsig + if (lqr) then + call mpi_gatherv(qrsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'rwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-max(grid3(i,j,1),qcmin) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'rwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','write',istop,iret) + endif + else + if (mype == mype_out) then + call nemsio_readrecv(gfile,'rwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','read',istop,iret) + call nemsio_writerecv(gfileo,'rwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','write',istop,iret) + endif + endif + end do +! Snow + do k=1,grd%nsig + if (lqs) then + call mpi_gatherv(qssm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'snmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-max(grid3(i,j,1),qcmin) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'snmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','write',istop,iret) + endif + else + if (mype == mype_out) then + call nemsio_readrecv(gfile,'snmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','read',istop,iret) + call nemsio_writerecv(gfileo,'snmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','write',istop,iret) + endif + endif + end do +! Graupel + do k=1,grd%nsig + if (lqg) then + call mpi_gatherv(qgsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'grle','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'grle','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-max(grid3(i,j,1),qcmin) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'grle','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'grle','write',istop,iret) + endif + else + if (mype == mype_out) then + call nemsio_readrecv(gfile,'grle','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'grle','read',istop,iret) + call nemsio_writerecv(gfileo,'grle','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'grle','write',istop,iret) + endif + endif + end do +! Cloud Amount (cloud fraction) - should be the same as the input guess values + do k=1,grd%nsig + if (mype==mype_out) then + call nemsio_readrecv(gfile,'cld_amt','mid layer',k,rwork1d,iret=iret) + if (iret == 0) then + call nemsio_writerecv(gfileo,'cld_amt','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'cld_amt','write',istop,iret) + endif + endif + enddo + endif !ntracer +! Variables needed by the Unified Post Processor (dzdt, delz, delp) + if (lupp) then + if (mype == mype_out) then + do k=1,grd%nsig + call nemsio_readrecv(gfile,'dzdt','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dzdt','read',istop,iret) + call nemsio_writerecv(gfileo,'dzdt','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dzdt','write',istop,iret) + enddo + endif + do k=1,grd%nsig + call mpi_gatherv(dzsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + call nemsio_readrecv(gfile,'delz','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'delz','read',istop,iret) + if (sum(rwork1d) < zero) work1 = work1 * -1.0_r_kind !Flip sign, FV3 is top to bottom + if(diff_res)then + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = rwork1d + reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'delz','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'delz','write',istop,iret) + endif + end do + endif +! +! Deallocate local array +! + if (mype==mype_out) then + if (diff_res .or. lupp) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid3,clons,slons) + + call nemsio_close(gfile,iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),null,'close',istop,iret) + + call nemsio_close(gfileo,iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) +! +! Deallocate local array +! + deallocate(rwork1d,rwork1d1) +! + write(6,'(a,'': atm anal written for lonb,latb,levs= '',3i6,'',valid hour= '',f4.1,'',idate= '',4i5)') & + trim(my_name),lonb,latb,levs,fhour,odate + endif + + end subroutine write_fv3atm_ + + subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin,gfschem_bundle) + +!$$$ subprogram documentation block +! . . . +! subprogram: write_nemsatm --- Gather, transform, and write out +! +! prgmmr: Huang org: np23 date: 2010-02-22 +! +! abstract: This routine gathers fields needed for the GSI analysis +! file from subdomains and then transforms the fields from +! analysis grid to model guess grid, then written to an +! atmospheric analysis file. +! +! program history log: +! 2010-02-22 Huang Initial version. Based on write_gfsatm +! 2011-02-14 Huang Re-arrange the write sequence to be same as model +! read/rite sequence. +! 2013-10-25 todling reposition load_grid to commvars +! 2016-07-28 mahajan update with bundling ability +! 2019-04-19 Wei/Martin - added gfschem_bundle to write optional aerosols +! for both FV3-Chem and NGAC +! +! input argument list: +! filename - file to open and write to +! mype_out - mpi task to write output file +! gfs_bundle - bundle containing fields on subdomains +! ibin - time bin +! +! output argument list: +! +! attributes: +! language: f90 +! machines: ibm RS/6000 SP; SGI Origin 2000; Compaq HP +! +!$$$ end documentation block + +! !USES: + use kinds, only: r_kind,i_kind + + use constants, only: r1000,fv,one,zero,qcmin,r0_05,t0c + + use mpimod, only: mpi_rtype + use mpimod, only: mpi_comm_world + use mpimod, only: ierror + use mpimod, only: mype + + use guess_grids, only: ifilesig + use guess_grids, only: ges_prsl,ges_prsi + use guess_grids, only: load_geop_hgt,geop_hgti,ges_geopi + + use gridmod, only: ntracer + use gridmod, only: ncloud + use gridmod, only: strip,jcap_b,bk5 + use gridmod, only: use_fv3_aero + + use general_commvars_mod, only: load_grid,fill2_ns,filluv2_ns + use general_specmod, only: spec_vars + + use obsmod, only: iadate + + use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_init,& + nemsio_getfilehead,nemsio_close,nemsio_writerecv,nemsio_readrecv + use gsi_4dvar, only: ibdate,nhr_obsbin,lwrite4danl + use general_sub2grid_mod, only: sub2grid_info + use egrid2agrid_mod,only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid + use constants, only: two,pi,half,deg2rad + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use cloud_efr_mod, only: cloud_calc_gfs + use chemmod, only: laeroana_gocart + + implicit none + +! !INPUT PARAMETERS: + + type(sub2grid_info), intent(in) :: grd + type(spec_vars), intent(in) :: sp_a + character(len=24), intent(in) :: filename ! file to open and write to + integer(i_kind), intent(in) :: mype_out ! mpi task to write output file + type(gsi_bundle), intent(in) :: gfs_bundle + type(gsi_bundle),optional,intent(in) :: gfschem_bundle ! for aerosols + integer(i_kind), intent(in) :: ibin ! time bin + +!------------------------------------------------------------------------- + + real(r_kind),parameter:: r0_001 = 0.001_r_kind + character(6):: fname_ges + character(len=120) :: my_name = 'WRITE_NEMSATM' + character(len=1) :: null = ' ' + integer(i_kind),dimension(7):: idate, jdate + integer(i_kind),dimension(4):: odate + integer(i_kind) :: k, mm1, nlatm2, nord_int, i, j, kk + integer(i_kind) :: iret, lonb, latb, levs, istatus + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind) :: istop = 104 + integer(i_kind),dimension(5):: mydate + integer(i_kind),dimension(8) :: ida,jda + real(r_kind),dimension(5) :: fha + real(r_kind) :: fhour + + real(r_kind),pointer,dimension(:,:) :: sub_ps + real(r_kind),pointer,dimension(:,:,:) :: sub_u,sub_v,sub_tv + real(r_kind),pointer,dimension(:,:,:) :: sub_q,sub_oz,sub_cwmr +! Sub-domain aerosol arrays + real(r_kind),pointer,dimension(:,:,:) :: sub_du1,sub_du2,sub_du3,sub_du4,sub_du5 + real(r_kind),pointer,dimension(:,:,:) :: sub_ss1,sub_ss2,sub_ss3,sub_ss4,sub_so4 + real(r_kind),pointer,dimension(:,:,:) :: sub_oc1,sub_oc2,sub_bc1,sub_bc2 + + real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig) :: sub_dzb,sub_dza + + real(r_kind),dimension(grd%lat1*grd%lon1) :: psm + real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: tvsm, usm, vsm + real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: qsm, ozsm + real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: cwsm, dzsm +! Aerosol array + real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: & + du001sm,du002sm,du003sm,du004sm,du005sm, & + ss001sm,ss002sm,ss003sm,ss004sm, & + so4sm,ocphosm,ocphism,bcphosm,bcphism + integer(i_kind) :: m + real(r_kind),dimension(max(grd%iglobal,grd%itotsub)) :: work1,work2 + real(r_kind),dimension(grd%nlon,grd%nlat-2):: grid + real(r_kind),allocatable,dimension(:) :: rwork1d,rwork1d1,rlats,rlons,clons,slons + real(4),allocatable,dimension(:) :: r4lats,r4lons + real(r_kind),allocatable,dimension(:,:) :: grid_b,grid_b2 + real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid3, grid_c2, grid3b + + type(nemsio_gfile) :: gfile,gfileo + logical diff_res,eqspace + logical,dimension(1) :: vector + type(egrid2agrid_parm) :: p_low,p_high + +!************************************************************************* +! Initialize local variables + mm1=mype+1 + nlatm2=grd%nlat-2 + diff_res=.false. + + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'ps', sub_ps, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'u', sub_u, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'v', sub_v, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'tv', sub_tv, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'q', sub_q, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'oz', sub_oz, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfs_bundle,'cw', sub_cwmr,iret); istatus=istatus+iret + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'write_atm_: ERROR' + write(6,*) 'Missing some of the required fields' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + + if (present(gfschem_bundle) .and. laeroana_gocart) then + call gsi_bundlegetpointer(gfschem_bundle,'sulf', sub_so4, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'oc1', sub_oc1, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'oc2', sub_oc2, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'bc1', sub_bc1, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'bc2', sub_bc2, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'dust1', sub_du1, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'dust2', sub_du2, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'dust3', sub_du3, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'dust4', sub_du4, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'dust5', sub_du5, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'seas1', sub_ss1, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'seas2', sub_ss2, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'seas3', sub_ss3, iret); istatus=istatus+iret + call gsi_bundlegetpointer(gfschem_bundle,'seas4', sub_ss4, iret); istatus=istatus+iret + end if + + if ( sp_a%jcap /= jcap_b ) then + if ( mype == 0 ) write(6, & + '('' dual resolution for nems sp_a%jcap,jcap_b = '',2i6)') & + sp_a%jcap,jcap_b + diff_res = .true. + endif + + + ! Single task writes analysis data to analysis file + if ( mype == mype_out ) then + write(fname_ges,'(''sigf'',i2.2)') ifilesig(ibin) + + ! Read header information from first guess file. + call nemsio_init(iret) + if ( iret /= 0 ) call error_msg(trim(my_name),null,null,'init',istop,iret) + + call nemsio_open(gfile,trim(fname_ges),'read',iret) + if ( iret /= 0 ) call error_msg(trim(my_name),trim(fname_ges),null,'open',istop,iret) + + call nemsio_getfilehead(gfile, iret=iret, nfhour=nfhour, & + nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + idate=idate, dimx=lonb, dimy=latb, dimz=levs) + if ( iret /= 0 ) then + write(6,*) trim(my_name),': problem with nemsio_getfilehead, Status = ',iret + call stop2(103) + endif + if ( levs /= grd%nsig ) then + write(6,*) trim(my_name),': problem in data dimension background levs = ',levs,' nsig = ',grd%nsig + call stop2(103) + endif + + ! copy input header info to output header info + gfileo=gfile + + ! Update header information (with ibdate) and write it to analysis file (w/ _open statement). + mydate=ibdate + fha(:)=zero ; ida=0; jda=0 + fha(2)=real(nhr_obsbin*(ibin-1)) ! relative time interval in hours + ida(1)=mydate(1) ! year + ida(2)=mydate(2) ! month + ida(3)=mydate(3) ! day + ida(4)=0 ! time zone + ida(5)=mydate(4) ! hour + + ! Move date-time forward by nhr_assimilation hours + call w3movdat(fha,ida,jda) + + jdate(1) = jda(1) ! analysis year + jdate(2) = jda(2) ! analysis month + jdate(3) = jda(3) ! analysis day + jdate(4) = jda(5) ! analysis hour + jdate(5) = iadate(5) ! analysis minute + jdate(6) = 0 ! analysis scaled seconds + jdate(7) = idate(7) ! analysis seconds multiplier + + nfhour =0 ! new forecast hour, zero at analysis time + nfminute =0 + nfsecondn=0 + nfsecondd=100 ! default for denominator + + fhour = zero + odate(1) = jdate(4) !hour + odate(2) = jdate(2) !month + odate(3) = jdate(3) !day + odate(4) = jdate(1) !year + + ! open new output file with new header gfileo with "write" access. + ! Use this call to update header as well + + call nemsio_open(gfileo,trim(filename),'write',iret=iret, & + idate=jdate, nfhour=nfhour, nfminute=nfminute, & + nfsecondn=nfsecondn, nfsecondd=nfsecondd) + if ( iret /= 0 ) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) + + ! Allocate structure arrays to hold data + allocate(rwork1d(latb*lonb),rwork1d1(latb*lonb)) + if (imp_physics == 11) allocate(grid3b(grd%nlat,grd%nlon,1)) + if ( diff_res .or. imp_physics == 11 .or. lupp) then + allocate( grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid3(grd%nlat,grd%nlon,1)) + allocate( grid_b2(lonb,latb),grid_c2(latb+2,lonb,1)) + allocate( rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) + call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) + call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) + do j=1,latb + rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) + enddo + rlats(1)=-half*pi + rlats(latb+2)=half*pi + do j=1,lonb + rlons(j)=deg2rad*r4lons(j) + enddo + do j=1,lonb + clons(j)=cos(rlons(j)) + slons(j)=sin(rlons(j)) + enddo + + nord_int=4 + eqspace=.false. + call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons, & + latb+2,rlats,lonb,rlons,& + nord_int,p_low,.false.,eqspace=eqspace) + call g_create_egrid2agrid(latb+2,rlats,lonb,rlons, & + grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons,& + nord_int,p_high,.false.,eqspace=eqspace) + + deallocate(rlats,rlons,r4lats,r4lons) + endif ! if ( diff_res ) + + ! Terrain + ! Write out input file surface height + + call nemsio_readrecv(gfile,'hgt', 'sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','writeread',istop,iret) + call nemsio_writerecv(gfileo,'hgt','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','write',istop,iret) + endif ! if ( mype == mype_out ) + + ! Calculate delz increment for UPP + if (lupp) then + do k=1,grd%nsig + sub_dzb(:,:,k) = ges_geopi(:,:,k+1,ibin) - ges_geopi(:,:,k,ibin) + enddo + + if ((.not. lwrite4danl) .or. ibin == 1) call load_geop_hgt + do k=1,grd%nsig + sub_dza(:,:,k) = geop_hgti(:,:,k+1,ibin) - geop_hgti(:,:,k,ibin) + enddo + + sub_dza = sub_dza - sub_dzb !sub_dza is increment + endif + + ! Strip off boundary points from subdomains + call strip(sub_ps ,psm) + call strip(sub_tv ,tvsm ,grd%nsig) + call strip(sub_q ,qsm ,grd%nsig) + call strip(sub_oz ,ozsm ,grd%nsig) + call strip(sub_cwmr,cwsm ,grd%nsig) + call strip(sub_u ,usm ,grd%nsig) + call strip(sub_v ,vsm ,grd%nsig) + if (lupp) call strip(sub_dza ,dzsm ,grd%nsig) + if (laeroana_gocart) then + call strip(sub_du1 ,du001sm ,grd%nsig) + call strip(sub_du2 ,du002sm ,grd%nsig) + call strip(sub_du3 ,du003sm ,grd%nsig) + call strip(sub_du4 ,du004sm ,grd%nsig) + call strip(sub_du5 ,du005sm ,grd%nsig) + call strip(sub_ss1 ,ss001sm ,grd%nsig) + call strip(sub_ss2 ,ss002sm ,grd%nsig) + call strip(sub_ss3 ,ss003sm ,grd%nsig) + call strip(sub_ss4 ,ss004sm ,grd%nsig) + call strip(sub_so4 ,so4sm ,grd%nsig) + call strip(sub_oc1 ,ocphosm ,grd%nsig) + call strip(sub_oc2 ,ocphism ,grd%nsig) + call strip(sub_bc1 ,bcphosm ,grd%nsig) + call strip(sub_bc2 ,bcphism ,grd%nsig) + end if + + ! Thermodynamic variable + ! The GSI analysis variable is virtual temperature (Tv). For NEMSIO + ! output we need the sensible temperature. + + ! Convert Tv to T + tvsm = tvsm/(one+fv*qsm) + + ! Generate and write analysis fields + + ! Surface pressure. + call mpi_gatherv(psm,grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype==mype_out) then + if(diff_res .or. lupp)then + call nemsio_readrecv(gfile,'pres','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pres','read',istop,iret) + rwork1d1 = r0_001*rwork1d + grid_b=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + if (lupp) work1(kk)=grid3(i,j,1) + end do + if (lupp) then + do k=1,grd%nsig + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)*(bk5(k)-bk5(k+1)) + enddo + call g_egrid2agrid(p_high,grid3,grid_c2,1,1,vector) + call nemsio_readrecv(gfile,'dpres','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dpres','read',istop,iret) + grid_b2=reshape(rwork1d,(/size(grid_b2,1),size(grid_b2,2)/)) + do j=1,latb + do i=1,lonb + grid_b2(i,j)=grid_b2(i,j)+r1000*(grid_c2(latb-j+2,i,1)) + enddo + enddo + rwork1d = reshape(grid_b2,(/size(rwork1d)/)) + call nemsio_writerecv(gfileo,'dpres','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dpres','write',istop,iret) + enddo + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk) + enddo + endif + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=r1000*(grid_b(i,j)+grid_c(latb-j+2,i,1)) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + grid = grid*r1000 + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'pres','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'psfc','write',istop,iret) + endif + +! u, v + do k=1,grd%nsig + call mpi_gatherv(usm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + call mpi_gatherv(vsm(1,k),grd%ijn(mm1),mpi_rtype,& + work2,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype==mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'ugrd','mid layer',k,rwork1d,iret=iret) + call nemsio_readrecv(gfile,'vgrd','mid layer',k,rwork1d1,iret=iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + grid_b2=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + call g_egrid2agrid(p_low,grid_c2,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work2(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b2(i,j)=grid_b2(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + rwork1d1 = reshape(grid_b2,(/size(rwork1d1)/)) + + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + call load_grid(work2,grid) + rwork1d1 = reshape(grid,(/size(rwork1d1)/)) + end if + + ! Zonal wind + call nemsio_writerecv(gfileo,'ugrd','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','write',istop,iret) + ! Meridional wind + call nemsio_writerecv(gfileo,'vgrd','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','write',istop,iret) + endif + end do + +! Thermodynamic variable + do k=1,grd%nsig + call mpi_gatherv(tvsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'tmp','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'tmp','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','write',istop,iret) + endif + end do + +! Specific humidity + do k=1,grd%nsig + call mpi_gatherv(qsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'spfh','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'spfh','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','write',istop,iret) + endif + end do + +! Ozone + do k=1,grd%nsig + call mpi_gatherv(ozsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + call nemsio_readrecv(gfile,'o3mr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'o3mr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','write',istop,iret) + endif + end do + +! Cloud condensate mixing ratio + if (ntracer>2 .or. ncloud>=1) then + + do k=1,grd%nsig + call mpi_gatherv(cwsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (imp_physics == 11) then + call mpi_gatherv(tvsm(1,k),grd%ijn(mm1),mpi_rtype,& + work2,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + endif + if (mype == mype_out) then + if(diff_res .or. imp_physics == 11)then + call nemsio_readrecv(gfile,'clwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + if (imp_physics == 11) then + call nemsio_readrecv(gfile,'icmr','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','read',istop,iret) + grid_b2=reshape(rwork1d1,(/size(grid_b2,1),size(grid_b2,2)/)) + grid_b = grid_b + grid_b2 + endif + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-max(grid3(i,j,1),qcmin) + if (imp_physics == 11) then + work2(kk) = -r0_05*(work2(kk) - t0c) + work2(kk) = max(zero,work2(kk)) + work2(kk) = min(one,work2(kk)) + grid3b(i,j,1)=grid3(i,j,1) + grid3(i,j,1)=grid3b(i,j,1)*(one - work2(kk)) + endif + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + if (imp_physics == 11) grid_b = grid_b - grid_b2 + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + if (imp_physics == 11) then + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=grid3b(i,j,1)*work2(kk) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b2(i,j)=grid_b2(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d1 = reshape(grid_b2,(/size(rwork1d1)/)) + endif + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + endif + call nemsio_writerecv(gfileo,'clwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','write',istop,iret) + if (imp_physics == 11) then + call nemsio_writerecv(gfileo,'icmr','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','write',istop,iret) + + if (lupp) then + call nemsio_readrecv(gfile,'rwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','read',istop,iret) + call nemsio_writerecv(gfileo,'rwmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','write',istop,iret) + + call nemsio_readrecv(gfile,'snmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','read',istop,iret) + call nemsio_writerecv(gfileo,'snmr','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','write',istop,iret) + + call nemsio_readrecv(gfile,'grle','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'grle','read',istop,iret) + call nemsio_writerecv(gfileo,'grle','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'grle','write',istop,iret) + endif + + call nemsio_readrecv(gfile,'cld_amt','mid layer',k,rwork1d,iret=iret) + if (iret == 0) then + call nemsio_writerecv(gfileo,'cld_amt','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'cld_amt','write',istop,iret) + endif + + endif + endif !mype == mype_out + end do + endif !ntracer + +! Variables needed by the Unified Post Processor (dzdt, delz, delp) + if (lupp) then + if (mype == mype_out) then + do k=1,grd%nsig + call nemsio_readrecv(gfile,'dzdt','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dzdt','read',istop,iret) + call nemsio_writerecv(gfileo,'dzdt','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dzdt','write',istop,iret) + enddo + endif + do k=1,grd%nsig + call mpi_gatherv(dzsm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + call nemsio_readrecv(gfile,'delz','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'delz','read',istop,iret) + if (sum(rwork1d) < zero) work1 = work1 * -1.0_r_kind ! Flip sign, FV3 is top to bottom + if(diff_res)then + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = rwork1d + reshape(grid,(/size(rwork1d)/)) + end if + call nemsio_writerecv(gfileo,'delz','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'delz','write',istop,iret) + endif + end do + endif + +! aerosol output if laeroana_gocart is T +! du001 + if (laeroana_gocart) then + do k=1,grd%nsig + call mpi_gatherv(du001sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'dust1','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'du001','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du001','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'dust1','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'du001','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du001','write',istop,iret) + endif + end do +! du002 + do k=1,grd%nsig + call mpi_gatherv(du002sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'dust2','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'du002','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du002','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'dust2','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'du002','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du002','write',istop,iret) + endif + end do +! du003 + do k=1,grd%nsig + call mpi_gatherv(du003sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'dust3','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'du003','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du003','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'dust3','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'du003','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du003','write',istop,iret) + endif + end do +! du004 + do k=1,grd%nsig + call mpi_gatherv(du004sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'dust4','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'du004','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du004','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'dust4','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'du004','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du004','write',istop,iret) + endif + end do +! du005 + do k=1,grd%nsig + call mpi_gatherv(du005sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'dust5','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'du005','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du005','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'dust5','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'du005','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'du005','write',istop,iret) + endif + end do +! ss001 and ss002 NOTE: It depends the ratio of ss1 and ss2 in guess to +! distribute the analysis mixing ratio + do k=1,grd%nsig + call mpi_gatherv(ss001sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'seas1','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss001','read',istop,iret) + call nemsio_readrecv(gfile,'seas2','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss002','read',istop,iret) + else + call nemsio_readrecv(gfile,'ss001','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss001','read',istop,iret) + call nemsio_readrecv(gfile,'ss002','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss002','read',istop,iret) + end if + rwork1d=rwork1d+rwork1d1 ! first guess ss1+ss2, rwork1d become the original total mixing ratio + do m=1,size(rwork1d) + if (rwork1d(m) == zero) then ! if original total mixing ratio is zero, which mean ss1=ss2=0. Set the rwork1d1:ss2ratio to zero + rwork1d1(m)=zero + else + rwork1d1(m)=rwork1d1(m)/rwork1d(m) ! if original total mixing ratio isn't zero, which mean ss1!=0 or ss2!=0. + ! Set + ! rwork1d1:ss2ratio=rwork1d1:ss2/rwork1d:total + end if + end do + if(diff_res)then + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) ! analysis total mixing ratio + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) ! analysis total mixing ratio + end if + ! if there is increment in analysis but nothing originally, half-half to + ! analysis sea salt 1 and 2 respectively. + ! + do m=1,size(rwork1d) + if (rwork1d(m) /= zero .and. rwork1d1(m) == zero ) then ! if ana!=0, ratio=0. Then ss1=ss2=half total mixing ratio + rwork1d1(m)=half*rwork1d(m) ! sea salt 2 + else if ( rwork1d1(m) /= zero .and. rwork1d(m) == zero ) then ! if ratio!=0, ana=0. Then ss1=ss2=0. Set ss2=0. + rwork1d1(m)=zero + else ! else mean ana=0 ratio=0 or ana!=0 ratio!=0. + ! Then ss2=ana*ratio + rwork1d1(m)=rwork1d(m)*rwork1d1(m) ! sea salt 2 + end if + rwork1d(m)=rwork1d(m)-rwork1d1(m) ! sea salt 1 + enddo + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'seas1','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss001','write',istop,iret) + call nemsio_writerecv(gfileo,'seas2','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss002','write',istop,iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + rwork1d1=rwork1d1*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'ss001','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss001','write',istop,iret) + call nemsio_writerecv(gfileo,'ss002','mid layer',k,rwork1d1,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss002','write',istop,iret) + end if + endif + end do +! ss003 + do k=1,grd%nsig + call mpi_gatherv(ss002sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'seas3','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'ss003','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss003','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'seas3','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'ss003','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss003','write',istop,iret) + endif + end do +! ss004 + do k=1,grd%nsig + call mpi_gatherv(ss003sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'seas4','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'ss004','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss004','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'seas4','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'ss004','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss004','write',istop,iret) + endif + end do +! ss005 + do k=1,grd%nsig + call mpi_gatherv(ss004sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'seas5','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'ss005','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss005','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'seas5','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'ss005','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ss005','write',istop,iret) + endif + end do +! dms, msa, so2 + do k=1,grd%nsig + if (mype == mype_out) then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'DMS','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'dms','mid layer',k,rwork1d,iret=iret) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'DMS','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'dms','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dms','write',istop,iret) + endif + end do + + do k=1,grd%nsig + if (mype == mype_out) then + call nemsio_readrecv(gfile,'msa','mid layer',k,rwork1d,iret=iret) + call nemsio_writerecv(gfileo,'msa','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'msa','write',istop,iret) + endif + end do + + do k=1,grd%nsig + if (mype == mype_out) then + call nemsio_readrecv(gfile,'so2','mid layer',k,rwork1d,iret=iret) + call nemsio_writerecv(gfileo,'so2','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'so2','write',istop,iret) + endif + end do +! so4 + do k=1,grd%nsig + call mpi_gatherv(so4sm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'sulf','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'so4','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'so4','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'sulf','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'so4','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'so4','write',istop,iret) + endif + end do +! oc1 + do k=1,grd%nsig + call mpi_gatherv(ocphosm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'oc1','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'ocphobic','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ocphobic','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'oc1','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'ocphobic','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ocphobic','write',istop,iret) + endif + end do +! oc2 + do k=1,grd%nsig + call mpi_gatherv(ocphism(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'oc2','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'ocphilic','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ocphilic','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'oc2','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'ocphilic','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ocphilic','write',istop,iret) + endif + end do +! bc1 + do k=1,grd%nsig + call mpi_gatherv(bcphosm(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'bc1','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'bcphobic','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'bcphobic','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'bc1','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'bcphobic','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'bcphobic','write',istop,iret) + endif + end do +! bc2 + do k=1,grd%nsig + call mpi_gatherv(bcphism(1,k),grd%ijn(mm1),mpi_rtype,& + work1,grd%ijn,grd%displs_g,mpi_rtype,& + mype_out,mpi_comm_world,ierror) + if (mype == mype_out) then + if(diff_res)then + if (use_fv3_aero) then + call nemsio_readrecv(gfile,'bc2','mid layer',k,rwork1d,iret=iret) + else + call nemsio_readrecv(gfile,'bcphilic','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'bcphilic','read',istop,iret) + grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) + do kk=1,grd%iglobal + i=grd%ltosi(kk) + j=grd%ltosj(kk) + grid3(i,j,1)=work1(kk)-grid3(i,j,1) + end do + call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) + do j=1,latb + do i=1,lonb + grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) + end do + end do + rwork1d = reshape(grid_b,(/size(rwork1d)/)) + else + call load_grid(work1,grid) + rwork1d = reshape(grid,(/size(rwork1d)/)) + end if + if (use_fv3_aero) then + call nemsio_writerecv(gfileo,'bc2','mid layer',k,rwork1d,iret=iret) + else + rwork1d=rwork1d*1.0e-9_r_kind ! convert ug/kg back to kg/kg + call nemsio_writerecv(gfileo,'bcphilic','mid layer',k,rwork1d,iret=iret) + end if + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'bcphilic','write',istop,iret) + endif + end do + +! output extra variables if FV3-Chem + if (use_fv3_aero) then + do k=1,grd%nsig + if (mype == mype_out) then + call nemsio_readrecv(gfile,'pp25','mid layer',k,rwork1d,iret=iret) + call nemsio_writerecv(gfileo,'pp25','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pp25','write',istop,iret) + end if + end do + do k=1,grd%nsig + if (mype == mype_out) then + call nemsio_readrecv(gfile,'pp10','mid layer',k,rwork1d,iret=iret) + call nemsio_writerecv(gfileo,'pp10','mid layer',k,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pp10','write',istop,iret) + end if + end do + end if + end if ! end if laeroana_gocart +! +! Deallocate local array +! + if (mype==mype_out) then + if (diff_res .or. lupp .or. imp_physics == 11) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid3,clons,slons) + if (imp_physics == 11) deallocate(grid3b) + + call nemsio_close(gfile,iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),null,'close',istop,iret) + + call nemsio_close(gfileo,iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) +! +! Deallocate local array +! + deallocate(rwork1d,rwork1d1) +! + write(6,'(a,'': atm anal written for lonb,latb,levs= '',3i6,'',valid hour= '',f4.1,'',idate= '',4i5)') & + trim(my_name),lonb,latb,levs,fhour,odate + endif + + end subroutine write_atm_ + + subroutine write_sfc_ (filename,mype_sfc,dsfct) +!$$$ subprogram documentation block +! . . . +! subprogram: write_nemssfc --- Write surface analysis to file +! +! prgmmr: Huang org: np23 date: 2010-02-22 +! +! abstract: This routine writes the updated surface analysis. At +! this point (20101020) the only surface field update by +! the gsi is the skin temperature. The current (20101020) +! GDAS setup does use the updated surface file. Rather, +! the output from surface cycle is used as the surface +! analysis for subsequent NEMS/GFS runs. +! +! The routine gathers surface fields from subdomains, +! reformats the data records, and then writes each record +! to the output file. +! +! Since the gsi only update the skin temperature, all +! other surface fields are simply read from the guess +! surface file and written to the analysis file. +! +! program history log: +! 2010-02-22 Huang Initial version. Based on write_gfssfc +! 2011-04-01 Huang change type of buffer2, grid2 from single to r_kind +! 2013-10-25 todling - reposition ltosi and others to commvars +! +! input argument list: +! filename - file to open and write to +! dsfct - delta skin temperature +! mype_sfc - mpi task to write output file +! +! output argument list: +! +! attributes: +! language: f90 +! machines: ibm RS/6000 SP; SGI Origin 2000; Compaq HP +! +!$$$ end documentation block + +! !USES: + use kinds, only: r_kind,i_kind,r_single + + use mpimod, only: mpi_rtype + use mpimod, only: mpi_comm_world + use mpimod, only: ierror + use mpimod, only: mype + + use gridmod, only: nlat,nlon + use gridmod, only: lat1,lon1 + use gridmod, only: lat2,lon2 + use gridmod, only: iglobal + use gridmod, only: ijn + use gridmod, only: displs_g + use gridmod, only: itotsub + use gridmod, only: rlats,rlons,rlats_sfc,rlons_sfc + + use general_commvars_mod, only: ltosi,ltosj + + use obsmod, only: iadate + + use constants, only: zero + + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close,nemsio_readrecv + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead + use nemsio_module, only: nemsio_readrec, nemsio_writerec, nemsio_writerecv + + implicit none + +! !INPUT PARAMETERS: + character(24) ,intent(in ) :: filename ! file to open and write to + + real(r_kind),dimension(lat2,lon2),intent(in ) :: dsfct ! delta skin temperature + + integer(i_kind) ,intent(in ) :: mype_sfc ! mpi task to write output file + +! !OUTPUT PARAMETERS: + +!------------------------------------------------------------------------- + +! Declare local parameters + character( 6),parameter:: fname_ges='sfcf06' +! Declare local variables + character(len=120) :: my_name = 'WRITE_NEMSSFC' + character(len=1) :: null = ' ' + integer(i_kind),dimension(7):: idate, jdate + integer(i_kind),dimension(4):: odate + integer(i_kind) :: i, j, ip1, jp1, ilat, ilon, jj, mm1 + integer(i_kind) :: nlatm2, n, nrec, lonb, latb, iret + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind) :: istop = 105 + real(r_kind) :: fhour + + real(r_kind),dimension(lat1,lon1):: sfcsub + real(r_kind),dimension(nlon,nlat):: grid + real(r_kind),dimension(max(iglobal,itotsub)):: sfcall + real(r_kind),allocatable,dimension(:,:) :: tsea + real(r_kind),allocatable,dimension(:) :: rwork1d + real(r_single),dimension(nlon,nlat):: buffer + real(r_single),allocatable,dimension(:,:) :: buffer2,grid2 + + type(nemsio_gfile) :: gfile, gfileo +!***************************************************************************** + +! Initialize local variables + mm1=mype+1 + nlatm2=nlat-2 + +! Gather skin temperature information from all tasks. + do j=1,lon1 + jp1 = j+1 + do i=1,lat1 + ip1 = i+1 + sfcsub(i,j)=dsfct(ip1,jp1) + end do + end do + call mpi_gatherv(sfcsub,ijn(mm1),mpi_rtype,& + sfcall,ijn,displs_g,mpi_rtype,mype_sfc,& + mpi_comm_world,ierror) + +! Only MPI task mype_sfc writes the surface file. + if (mype==mype_sfc) then + +! Reorder updated skin temperature to output format + do i=1,iglobal + ilon=ltosj(i) + ilat=ltosi(i) + grid(ilon,ilat)=sfcall(i) + end do + do j=1,nlat + jj=nlat-j+1 + do i=1,nlon + buffer(i,j)=grid(i,jj) + end do + end do + +! Read surface guess file + call nemsio_init(iret=iret) + if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) + + call nemsio_open(gfile,fname_ges,'read',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),null,'open',istop,iret) +! + call nemsio_getfilehead(gfile, nrec=nrec, idate=idate, dimx=lonb, & + dimy=latb, nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, & + nfsecondd=nfsecondd, iret=iret) +! +! Replace header record date with analysis time from iadate +! + jdate(1) = iadate(1) ! analysis year + jdate(2) = iadate(2) ! analysis month + jdate(3) = iadate(3) ! analysis day + jdate(4) = iadate(4) ! analysis hour + jdate(5) = iadate(5) ! analysis minute + jdate(5) = 0 ! analysis minute + jdate(6) = 0 ! analysis scaled seconds + jdate(7) = idate(7) ! analysis seconds multiplier + + nfhour=0 ! new forecast hour, zero at analysis time + nfminute=0 + nfsecondn=0 + nfsecondd=100 ! default for denominator + + fhour = zero + odate(1) = jdate(4) !hour + odate(2) = jdate(2) !month + odate(3) = jdate(3) !day + odate(4) = jdate(1) !year +! +! Start to write output sfc file : filename +! open new output file with new header gfileo with "write" access. +! Use this call to update header as well +! +! + gfileo=gfile ! copy input header info to output header info + ! need to do this before nemsio_close(gfile) + call nemsio_open(gfileo,filename,'write',iret=iret, idate=jdate, nfhour=nfhour,& + nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd ) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) +! +! First copy entire data from fname_ges to filename, then do selective update +! + allocate(rwork1d(lonb*latb)) + allocate(buffer2(lonb,latb)) + allocate(grid2(lonb,latb)) + allocate(tsea(lonb,latb)) + + do n = 1, nrec + call nemsio_readrec (gfile, n,rwork1d,iret=iret) + if ( iret /= 0 ) write(6,*) 'readrec nrec = ', n, ' Status = ', iret + call nemsio_writerec(gfileo,n,rwork1d,iret=iret) + if ( iret /= 0 ) write(6,*) 'writerec nrec = ', n, ' Status = ', iret + end do +! +! Only sea surface temperature will be updated in the SFC files +! + + call nemsio_readrecv(gfile,'tmp','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),'tmp','read',istop,iret) + tsea=reshape(rwork1d,(/size(tsea,1),size(tsea,2)/)) + + if ( (latb /= nlatm2) .or. (lonb /= nlon) ) then + write(6,*)trim(my_name),': different grid dimensions analysis', & + ' vs sfc. interpolating sfc temperature nlon,nlat-2=',nlon, & + nlatm2,' -vs- sfc file lonb,latb=',lonb,latb + call intrp22(buffer, rlons,rlats,nlon,nlat, & + buffer2,rlons_sfc,rlats_sfc,lonb,latb) + else + do j=1,latb + do i=1,lonb + buffer2(i,j)=buffer(i,j+1) + end do + end do + endif + + grid2 = tsea + buffer2 + rwork1d = reshape( grid2,(/size(rwork1d)/) ) + + deallocate(buffer2) + +! update tsea record + call nemsio_writerecv(gfileo,'tmp','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','write',istop,iret) + deallocate(rwork1d) + + call nemsio_close(gfile, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),null,'close',istop,iret) + + call nemsio_close(gfileo,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) + + write(6,'(a,'': sfc anal written for lonb,latb= '',2i6,'',valid hour= '',f4.1,'',idate= '',4i5)') & + trim(my_name),lonb,latb,fhour,odate + endif + end subroutine write_sfc_ + + subroutine write_sfc_nst_ (mype_so,dsfct) + +!$$$ subprogram documentation block +! . . . +! subprogram: write_sfc_nst --- Write both sfc and nst surface analysis to file +! +! prgmmr: Huang org: np23 date: 2011-11-01 +! +! abstract: This routine writes the sfc & nst analysis files and is nst_gsi dependent. +! Tr (foundation temperature), instead of skin temperature, is the analysis variable. +! nst_gsi > 2: Tr analysis is on +! nst_gsi <= 2: Tr analysis is off +! +! The routine gathers Tr field from subdomains, +! reformats the data records, and then writes each record +! to the output files. +! +! Since the gsi only update the Tr temperature, all +! other fields in surface are simply read from the guess +! files and written to the analysis file. +! +! program history log: +! 2011-11-01 Huang initial version based on routine write_gfs_sfc_nst +! 2013-10-25 todling - reposition ltosi and others to commvars +! 2016-01-01 li - update write_sfc_nst_ (nemsio) as for write_gfs_sfc_nst (sfcio) +! +! input argument list: +! dsfct - delta skin temperature +! mype_so - mpi task to write output file +! +! output argument list: +! +! attributes: +! language: f90 +! machines: ibm RS/6000 SP; SGI Origin 2000; Compaq HP +! +!$$$ end documentation block + +! !USES: + use kinds, only: r_kind,i_kind,r_single + + use mpimod, only: mpi_rtype,mpi_itype + use mpimod, only: mpi_comm_world + use mpimod, only: ierror + use mpimod, only: mype + + use gridmod, only: nlat,nlon + use gridmod, only: lat1,lon1 + use gridmod, only: lat2,lon2 + use gridmod, only: nlat_sfc,nlon_sfc + use gridmod, only: iglobal + use gridmod, only: ijn + use gridmod, only: displs_g + use gridmod, only: itotsub + + use general_commvars_mod, only: ltosi,ltosj + + use obsmod, only: iadate + + use constants, only: zero,two,tfrozen,z_w_max + use constants, only: zero_single + + use guess_grids, only: isli2 + use gsi_nstcouplermod, only: nst_gsi,zsea1,zsea2 + use gridmod, only: rlats,rlons,rlats_sfc,rlons_sfc + + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close,nemsio_readrecv + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead + use nemsio_module, only: nemsio_readrec, nemsio_writerec, nemsio_writerecv + + implicit none + +! !INPUT PARAMETERS: + + real(r_kind),dimension(lat2,lon2),intent(in ) :: dsfct ! delta skin temperature + integer(i_kind) ,intent(in ) :: mype_so ! mpi task to write output file + +! !OUTPUT PARAMETERS: + +!------------------------------------------------------------------------- + +! Declare local parameters + character(6), parameter:: fname_sfcges = 'sfcf06' + character(6), parameter:: fname_sfcgcy = 'sfcgcy' + character(6), parameter:: fname_sfctsk = 'sfctsk' + character(6), parameter:: fname_sfcanl = 'sfcanl' + character(6), parameter:: fname_nstges = 'nstf06' + character(6), parameter:: fname_nstanl = 'nstanl' + character(6), parameter:: fname_dtfanl = 'dtfanl' + +! Declare local variables + integer(i_kind), parameter:: io_dtfanl = 54 + integer(i_kind), parameter:: nprep=15 + real(r_kind),parameter :: houra = zero_single + character(len=120) :: my_name = 'WRITE_SFC_NST' + character(len=1) :: null = ' ' + integer(i_kind),dimension(7):: idate, jdate + integer(i_kind),dimension(4):: odate + integer(i_kind) :: i, j, ip1, jp1, ilat, ilon, mm1 + integer(i_kind) :: lonb, latb, nlatm2, n, nrec_sfc, nrec_nst, iret + integer(i_kind) :: lonb_nst, latb_nst + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind) :: istop = 106 + real(r_kind) :: fhour + real(r_single) :: r_zsea1,r_zsea2 + + real(r_kind), dimension(lat1,lon1):: dsfct_sub + integer(i_kind), dimension(lat1,lon1):: isli_sub + + real(r_kind), dimension(max(iglobal,itotsub)):: dsfct_all + integer(i_kind), dimension(max(iglobal,itotsub)):: isli_all + + real(r_kind), dimension(nlat,nlon):: dsfct_glb,dsfct_tmp + integer(i_kind), dimension(nlat,nlon):: isli_glb,isli_tmp + + real(r_kind), dimension(nlat_sfc,nlon_sfc) :: dsfct_gsi + integer(i_kind), dimension(nlat_sfc,nlon_sfc) :: isli_gsi + + real(r_kind), dimension(nlon_sfc,nlat_sfc-2):: dsfct_anl + real(r_single), dimension(nlon_sfc,nlat_sfc-2):: dtzm + real(r_single), dimension(nlat_sfc,nlon_sfc) :: work + + real(r_single), allocatable, dimension(:,:) :: tsea,xt,xs,xu,xv,xz,zm,xtts,xzts,dt_cool,z_c, & + c_0,c_d,w_0,w_d,d_conv,ifd,tref,qrain + real(r_single), allocatable, dimension(:,:) :: slmsk_ges,slmsk_anl + real(r_single), allocatable, dimension(:) :: rwork1d + + type(nemsio_gfile) :: gfile_sfcges,gfile_sfcgcy,gfile_nstges,gfile_sfctsk,gfile_sfcanl,gfile_nstanl + +!***************************************************************************** + +! Initialize local variables + mm1=mype+1 + nlatm2=nlat-2 +! +! Extract the analysis increment and surface mask in subdomain without the buffer +! + do j=1,lon1 + jp1 = j+1 + do i=1,lat1 + ip1 = i+1 + dsfct_sub(i,j) = dsfct(ip1,jp1) + isli_sub (i,j) = isli2(ip1,jp1) + end do + end do +! +! Gather global analysis increment and surface mask info from subdomains +! + call mpi_gatherv(dsfct_sub,ijn(mm1),mpi_rtype,& + dsfct_all,ijn,displs_g,mpi_rtype,mype_so ,& + mpi_comm_world,ierror) + + call mpi_gatherv(isli_sub,ijn(mm1),mpi_itype,& + isli_all,ijn,displs_g,mpi_itype,mype_so ,& + mpi_comm_world,ierror) + +! Only MPI task mype_so writes the surface file. + if (mype==mype_so ) then + + write(*,'(a,5(1x,a6))') 'write_nems_sfc_nst:',fname_sfcges,fname_nstges,fname_sfctsk,fname_sfcanl,fname_nstanl +! +! get Tf analysis increment and surface mask at analysis (lower resolution) grids +! + do i=1,iglobal + ilon=ltosj(i) + ilat=ltosi(i) + dsfct_glb(ilat,ilon) = dsfct_all(i) + isli_glb (ilat,ilon) = isli_all (i) + end do +! +! write dsfct_anl to a data file for later use (at eupd step at present) +! + open(io_dtfanl,file=fname_dtfanl,form='unformatted') + write(io_dtfanl) nlon,nlat + write(io_dtfanl) dsfct_glb + write(io_dtfanl) isli_glb + +! Initiate nemsio + call nemsio_init(iret=iret) + if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) + +! open nsst guess file + call nemsio_open(gfile_nstges,trim(fname_nstges),'read',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),null,'open',istop,iret) +! open surface guess file + call nemsio_open(gfile_sfcges,trim(fname_sfcges),'read',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcges),null,'open',istop,iret) +! open surface gcycle file + call nemsio_open(gfile_sfcgcy,trim(fname_sfcgcy),'read',iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcgcy),null,'open',istop,iret) + +! read a few surface guess file header records + call nemsio_getfilehead(gfile_sfcges, nrec=nrec_sfc, idate=idate, & + dimx=lonb, dimy=latb, nfhour=nfhour, nfminute=nfminute, & + nfsecondn=nfsecondn, nfsecondd=nfsecondd, iret=iret) + +! read some nsst guess file header records (dimensions) + call nemsio_getfilehead(gfile_nstges, nrec=nrec_nst, dimx=lonb_nst,dimy=latb_nst,iret=iret) + + write(6,*) 'nrec_sfc, nrec_nst = ',nrec_sfc, nrec_nst + +! check the dimensions consistency in sfc, nst files and the used. + if ( latb /= latb_nst .or. lonb /= lonb_nst ) then + write(6,*) 'Inconsistent dimension for sfc & nst files. latb,lonb : ',latb,lonb, & + 'latb_nst,lonb_nst : ',latb_nst,lonb_nst + call stop2(80) + endif + + if ( nlat_sfc /= latb+2 .or. nlon_sfc /= lonb ) then + write(6,*) 'Inconsistent dimension for used and read. nlat_sfc,nlon_sfc : ',nlat_sfc,nlon_sfc, & + 'latb+2,lonb :',latb+2,lonb + call stop2(81) + endif +! + allocate(slmsk_ges(lonb,latb),slmsk_anl(lonb,latb)) + allocate(rwork1d(lonb*latb)) + +! read slmsk in fname_sfcges to get slmsk_ges + call nemsio_readrecv(gfile_sfcges, 'land', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcges),'land','read',istop,iret) + slmsk_ges=reshape(rwork1d,(/size(slmsk_ges,1),size(slmsk_ges,2)/)) + +! read slmsk in fname_sfcgcy to get slmsk_anl + call nemsio_readrecv(gfile_sfcgcy, 'land', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcgcy),'land','read',istop,iret) + slmsk_anl=reshape(rwork1d,(/size(slmsk_anl,1),size(slmsk_anl,2)/)) +! +! Replace header record date with analysis time from iadate +! + jdate(1) = iadate(1) ! analysis year + jdate(2) = iadate(2) ! analysis month + jdate(3) = iadate(3) ! analysis day + jdate(4) = iadate(4) ! analysis hour + jdate(5) = iadate(5) ! analysis minute + jdate(5) = 0 ! analysis minute + jdate(6) = 0 ! analysis scaled seconds + jdate(7) = idate(7) ! analysis seconds multiplier + + nfhour=0 ! new forecast hour, zero at analysis time + nfminute=0 + nfsecondn=0 + nfsecondd=100 ! default for denominator + + fhour = zero + odate(1) = jdate(4) !hour + odate(2) = jdate(2) !month + odate(3) = jdate(3) !day + odate(4) = jdate(1) !year + + if ( (latb /= nlatm2) .or. (lonb /= nlon) ) then + write(6,*)'WRITE_NEMSIO_SFC_NST: different grid dimensions analysis vs sfc. interpolating sfc temperature ',& + ', nlon,nlat-2=',nlon,nlatm2,' -vs- sfc file lonb,latb=',lonb,latb + write(6,*) ' WRITE_NEMSIO_SFC_NST, nlon_sfc,nlat_sfc : ', nlon_sfc,nlat_sfc +! +! Get the expanded values for a surface type (0 = water now) and the new mask +! + call int2_msk_glb_prep(dsfct_glb,isli_glb,dsfct_tmp,isli_tmp,nlat,nlon,0,nprep) +! +! Get updated/analysis surface mask info from sfcgcy file +! + call tran_gfssfc(slmsk_anl,work,lonb,latb) + do j=1,lonb + do i=1,latb+2 + isli_gsi(i,j) = nint(work(i,j)) + end do + end do +! +! Interpolate dsfct_tmp(nlat,nlon) to dsfct_gsi(nlat_sfc,nlon_sfc) with surface mask accounted +! + call int22_msk_glb(dsfct_tmp,isli_tmp,rlats,rlons,nlat,nlon, & + dsfct_gsi,isli_gsi,rlats_sfc,rlons_sfc,nlat_sfc,nlon_sfc,0) +! +! transform the dsfct_gsi(latb+2,lonb) to dsfct_anl(lonb,latb) for sfc file format +! + do j = 1, latb + do i = 1, lonb + dsfct_anl(i,j) = dsfct_gsi(latb+2-j,i) + end do + end do + + else +! +! transform the dsfct_glb(nlat,nlon) to dsfct_anl(lonb,latb) for sfc file +! format when nlat == latb-2 & nlon = lonb +! + do j=1,latb + do i=1,lonb + dsfct_anl(i,j)=dsfct_glb(latb+1-j,i) + end do + end do + endif ! if ( (latb /= nlatm2) .or. (lonb /= nlon) ) then + +! +! Start to write output sfc file : fname_sfcanl & fname_nstanl +! open new output file with new header gfile_sfcanl and gfile_nstanl with "write" access. +! Use this call to update header as well +! +! copy input header info to output header info for sfcanl, need to do this before nemsio_close(gfile) +! + gfile_sfcanl=gfile_sfcgcy +! open nemsio sfcanl + call nemsio_open(gfile_sfcanl,trim(fname_sfcanl),'write',iret=iret, idate=jdate, nfhour=nfhour,& + nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd ) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcanl),null,'open',istop,iret) + + gfile_sfctsk=gfile_sfcgcy +! open nemsio sfctsk + call nemsio_open(gfile_sfctsk,trim(fname_sfctsk),'write',iret=iret, idate=jdate, nfhour=nfhour,& + nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd ) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfctsk),null,'open',istop,iret) +! +! copy input header info to output header info for nstanl, need to do this before nemsio_close(gfile) +! + gfile_nstanl=gfile_nstges +! open nemsio nstanl + call nemsio_open(gfile_nstanl,trim(fname_nstanl),'write',iret=iret, idate=jdate, nfhour=nfhour,& + nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd ) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),null,'open',istop,iret) +! Allocate work array (rwork1d) and tsea in sfc file + allocate(tsea(lonb,latb)) + +! Allocate nsst variables + allocate(xt(lonb,latb)) + allocate(xs(lonb,latb)) + allocate(xu(lonb,latb)) + allocate(xv(lonb,latb)) + allocate(xz(lonb,latb)) + allocate(zm(lonb,latb)) + allocate(xtts(lonb,latb)) + allocate(xzts(lonb,latb)) + allocate(dt_cool(lonb,latb)) + allocate(z_c(lonb,latb)) + allocate(c_0(lonb,latb)) + allocate(c_d(lonb,latb)) + allocate(w_0(lonb,latb)) + allocate(w_d(lonb,latb)) + allocate(d_conv(lonb,latb)) + allocate(ifd(lonb,latb)) + allocate(tref(lonb,latb)) + allocate(qrain(lonb,latb)) +! +! First copy entire data from sfcgcy to fname_anl, then do selective update +! +! read the nrec_sfc variables from sfcgcy and then write then to sfcanl +! + do n = 1, nrec_sfc + call nemsio_readrec(gfile_sfcgcy,n,rwork1d,iret=iret) + if ( iret /= 0 ) write(6,*) 'readrec for gfile_sfcgcy, nrec_sfc = ', n, ' Status = ', iret + call nemsio_writerec(gfile_sfcanl,n,rwork1d,iret=iret) + if ( iret /= 0 ) write(6,*) 'writerec for gfile_sfcanl, nrec_sfc = ', n, ' Status = ', iret + call nemsio_writerec(gfile_sfctsk,n,rwork1d,iret=iret) + if ( iret /= 0 ) write(6,*) 'writerec for gfile_sfctsk, nrec_sfc = ', n, ' Status = ', iret + end do + + write(*,*) 'read gfile_sfcgcy, and the write to gfile_sfcanl, gfile_sfctsk' +! +! For sfcanl, Only tsea (sea surface temperature) will be updated in the SFC +! Need values from nstges for tref update +! read tsea from sfcges + call nemsio_readrecv(gfile_sfcges,'tmp','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcges),'tmp','read',istop,iret) + tsea=reshape(rwork1d,(/size(tsea,1),size(tsea,2)/)) + +! For nstanl, Only tref (foundation temperature) is updated by analysis +! others are updated for snow melting case +! read 18 nsst variables from nstges +! xt + call nemsio_readrecv(gfile_nstges, 'xt', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xt','read',istop,iret) + xt=reshape(rwork1d,(/size(xt,1),size(xt,2)/)) +! xs + call nemsio_readrecv(gfile_nstges, 'xs', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xs','read',istop,iret) + xs=reshape(rwork1d,(/size(xs,1),size(xs,2)/)) +! xu + call nemsio_readrecv(gfile_nstges, 'xu', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xu','read',istop,iret) + xu=reshape(rwork1d,(/size(xu,1),size(xu,2)/)) +! xv + call nemsio_readrecv(gfile_nstges, 'xv', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xv','read',istop,iret) + xv=reshape(rwork1d,(/size(xv,1),size(xv,2)/)) +! xz + call nemsio_readrecv(gfile_nstges, 'xz', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xz','read',istop,iret) + xz=reshape(rwork1d,(/size(xz,1),size(xz,2)/)) +! zm + call nemsio_readrecv(gfile_nstges, 'zm', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'zm','read',istop,iret) + zm=reshape(rwork1d,(/size(zm,1),size(zm,2)/)) +! xtts + call nemsio_readrecv(gfile_nstges, 'xtts', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xtts','read',istop,iret) + xtts=reshape(rwork1d,(/size(xtts,1),size(xtts,2)/)) +! xzts + call nemsio_readrecv(gfile_nstges, 'xzts', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xzts','read',istop,iret) + xzts=reshape(rwork1d,(/size(xzts,1),size(xzts,2)/)) +! dt_cool + call nemsio_readrecv(gfile_nstges, 'dtcool','sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'dt_cool','read',istop,iret) + dt_cool=reshape(rwork1d,(/size(dt_cool,1),size(dt_cool,2)/)) +! z_c + call nemsio_readrecv(gfile_nstges, 'zc','sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'zc','read',istop,iret) + z_c=reshape(rwork1d,(/size(z_c,1),size(z_c,2)/)) +! c_0 + call nemsio_readrecv(gfile_nstges, 'c0','sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'c0','read',istop,iret) + c_0=reshape(rwork1d,(/size(c_0,1),size(c_0,2)/)) +! c_d + call nemsio_readrecv(gfile_nstges, 'cd','sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'cd','read',istop,iret) + c_d=reshape(rwork1d,(/size(c_d,1),size(c_d,2)/)) +! w_0 + call nemsio_readrecv(gfile_nstges, 'w0','sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'w0','read',istop,iret) + w_0=reshape(rwork1d,(/size(w_0,1),size(w_0,2)/)) +! w_d + call nemsio_readrecv(gfile_nstges, 'wd','sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'wd','read',istop,iret) + w_d=reshape(rwork1d,(/size(w_d,1),size(w_d,2)/)) +! tref + call nemsio_readrecv(gfile_nstges, 'tref', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'tref','read',istop,iret) + tref=reshape(rwork1d,(/size(tref,1),size(tref,2)/)) +! d_conv + call nemsio_readrecv(gfile_nstges, 'dconv', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'dconv','read',istop,iret) + d_conv=reshape(rwork1d,(/size(d_conv,1),size(d_conv,2)/)) +! ifd + call nemsio_readrecv(gfile_nstges, 'ifd', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'ifd','read',istop,iret) + ifd=reshape(rwork1d,(/size(ifd,1),size(ifd,2)/)) +! qrain + call nemsio_readrecv(gfile_nstges, 'qrain', 'sfc', 1, rwork1d, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'qrain','read',istop,iret) + qrain=reshape(rwork1d,(/size(qrain,1),size(qrain,2)/)) +! +! update tref (in nst file) & tsea (in the surface file) when Tr analysis is on +! reset NSSTM variables for new open water grids +! + if ( nst_gsi > 2 ) then +! +! For the new open water (sea ice just melted) grids, (1) set dsfct_anl = zero; (2) reset the NSSTM variables +! +! Notes: slmsk_ges is the mask of the background +! slmsk_anl is the mask of the analysis +! + where ( slmsk_anl(:,:) == zero .and. slmsk_ges(:,:) == two ) + + dsfct_anl(:,:) = zero + + xt(:,:) = zero + xs(:,:) = zero + xu(:,:) = zero + xv(:,:) = zero + xz(:,:) = z_w_max + zm(:,:) = zero + xtts(:,:) = zero + xzts(:,:) = zero + dt_cool(:,:) = zero + z_c(:,:) = zero + c_0(:,:) = zero + c_d(:,:) = zero + w_0(:,:) = zero + w_d(:,:) = zero + d_conv(:,:) = zero + ifd(:,:) = zero + tref(:,:) = tfrozen + qrain(:,:) = zero + end where +! +! update analysis variable: Tref (foundation temperature) for nst file +! + where ( slmsk_anl(:,:) == zero ) + tref(:,:) = max(tref(:,:) + dsfct_anl(:,:),tfrozen) + elsewhere + tref(:,:) = tsea(:,:) + end where +! +! update SST: tsea for sfc file with NSST profile +! + r_zsea1 = 0.001_r_single*real(zsea1) + r_zsea2 = 0.001_r_single*real(zsea2) + call dtzm_2d(xt,xz,dt_cool,z_c,slmsk_anl,r_zsea1,r_zsea2,lonb,latb,dtzm) + + where ( slmsk_anl(:,:) == zero ) + tsea(:,:) = max(tref(:,:) + dtzm(:,:), tfrozen) + end where + + else ! when (nst_gsi <= 2) + + do j=1,latb + do i=1,lonb + tref(i,j) = tsea(i,j) ! keep tref as tsea before analysis + end do + end do +! +! For the new open water (sea ice just melted) grids, reset the NSSTM variables +! + where ( slmsk_anl(:,:) == zero .and. slmsk_ges(:,:) == two ) + + xt(:,:) = zero + xs(:,:) = zero + xu(:,:) = zero + xv(:,:) = zero + xz(:,:) = z_w_max + zm(:,:) = zero + xtts(:,:) = zero + xzts(:,:) = zero + dt_cool(:,:) = zero + z_c(:,:) = zero + c_0(:,:) = zero + c_d(:,:) = zero + w_0(:,:) = zero + w_d(:,:) = zero + d_conv(:,:) = zero + ifd(:,:) = zero + tref(:,:) = tfrozen + qrain(:,:) = zero + end where +! +! update tsea when NO Tf analysis +! + do j=1,latb + do i=1,lonb + tsea(i,j) = max(tsea(i,j) + dsfct_anl(i,j),tfrozen) + end do + end do + + endif ! if ( nst_gsi > 2 ) then +! +! update tsea record in sfcanl +! + rwork1d = reshape(tsea, (/size(rwork1d)/) ) + call nemsio_writerecv(gfile_sfcanl,'tmp','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcanl),'tmp','write',istop,iret) + write(6,100) fname_sfcanl,lonb,latb,houra,iadate(1:4),iret +100 format(' WRITE_NEMSIO_SFC_NST: update tsea in ',a6,2i6,1x,f4.1,4(i4,1x),' with iret=',i2) +! +! update tsea record in sfctsk +! + rwork1d = reshape(tsea, (/size(rwork1d)/) ) + call nemsio_writerecv(gfile_sfctsk,'tmp','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfctsk),'tmp','write',istop,iret) + write(6,101) fname_sfctsk,lonb,latb,houra,iadate(1:4),iret +101 format(' WRITE_NEMSIO_SFC_NST: update tsea in ',a6,2i6,1x,f4.1,4(i4,1x),' with iret=',i2) +! +! update nsst records in nstanl +! +! slmsk + rwork1d = reshape( slmsk_anl,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'land','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'land','write',istop,iret) +! xt + rwork1d = reshape( xt,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'xt','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xt','write',istop,iret) +! xs + rwork1d = reshape( xs,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'xs','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xs','write',istop,iret) +! xu + rwork1d = reshape( xu,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'xu','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xu','write',istop,iret) +! xv + rwork1d = reshape( xv,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'xv','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xv','write',istop,iret) +! xz + rwork1d = reshape( xz,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'xz','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xz','write',istop,iret) +! zm + rwork1d = reshape( zm,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'zm','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'zm','write',istop,iret) +! xtts + rwork1d = reshape( xtts,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'xtts','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xtts','write',istop,iret) +! xzts + rwork1d = reshape( xzts,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'xzts','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xzts','write',istop,iret) +! z_0 + rwork1d = reshape( dt_cool,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'dtcool','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'dtcool','write',istop,iret) +! z_c + rwork1d = reshape( z_c,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'zc','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'zc','write',istop,iret) +! c_0 + rwork1d = reshape( c_0,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'c0','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'c0','write',istop,iret) +! c_d + rwork1d = reshape( c_d,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'cd','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'cd','write',istop,iret) +! w_0 + rwork1d = reshape( w_0,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'w0','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'w0','write',istop,iret) +! w_d + rwork1d = reshape( w_d,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'wd','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'wd','write',istop,iret) +! d_conv + rwork1d = reshape( d_conv,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'dconv','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'dconv','write',istop,iret) +! ifd + rwork1d = reshape( ifd,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'ifd','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'ifd','write',istop,iret) +! tref + rwork1d = reshape( tref,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'tref','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'tref','write',istop,iret) +! qrain + rwork1d = reshape( qrain,(/size(rwork1d)/) ) + call nemsio_writerecv(gfile_nstanl,'qrain','sfc',1,rwork1d,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'qrain','write',istop,iret) + + write(6,200) fname_nstanl,lonb,latb,houra,iadate(1:4),iret +200 format(' WRITE_NEMSIO_SFC_NST: update variables in ',a6,2i6,1x,f4.1,4(i4,1x),' with iret=',i2) + + deallocate(xt,xs,xu,xv,xz,zm,xtts,xzts,dt_cool,z_c,c_0,c_d,w_0,w_d,d_conv,ifd,tref,qrain) + deallocate(rwork1d) + + call nemsio_close(gfile_sfcges, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcges),null,'close',istop,iret) + + call nemsio_close(gfile_sfcgcy, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcgcy),null,'close',istop,iret) + + call nemsio_close(gfile_nstges, iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),null,'close',istop,iret) + + call nemsio_close(gfile_sfcanl,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcanl),null,'close',istop,iret) + + call nemsio_close(gfile_nstanl,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),null,'close',istop,iret) + + call nemsio_close(gfile_sfctsk,iret=iret) + if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfctsk),null,'close',istop,iret) + + write(6,'(a,'': nemsio sfc_nst anal written for lonb,latb= '',2i6,'',valid hour= '',f4.1,'',idate= '',4i5)') & + trim(my_name),lonb,latb,fhour,odate + endif + end subroutine write_sfc_nst_ + + subroutine error_msg_(sub_name,file_name,var_name,action,stop_code,error_code,lprint) + use mpimod, only: mype + use kinds, only: i_kind + implicit none + + character(len=*), intent(in) :: sub_name,file_name,var_name,action + integer(i_kind), intent(in) :: stop_code, error_code + logical, optional,intent(in) :: lprint + + if ( mype == 0 .or. present(lprint) ) then + select case (trim(action)) + case('init') + write(6,'(a,'': PROBLEM with nemsio_init, Status = '', i3)') & + trim(sub_name), error_code + case('open') + write(6,'(a,'': ***ERROR*** problem opening file '',a,'', Status = '', i3)') & + trim(sub_name), trim(file_name), error_code + case('close') + write(6,'(a,'': ***ERROR*** problem closing file '',a,'', Status = '', i3)') & + trim(sub_name), trim(file_name), error_code + case default + write(6,'(a,'': ***ERROR*** '',a,tr1,a,'',variable = '',a,'',Status = '',i3)') & + trim(sub_name),trim(action),trim(file_name),trim(var_name),error_code + end select + end if + if ( stop_code /= 0 ) call stop2(stop_code) + end subroutine error_msg_ + + subroutine intrp22(a,rlons_a,rlats_a,nlon_a,nlat_a, & + b,rlons_b,rlats_b,nlon_b,nlat_b) +!$$$ subprogram documentation block +! . . . +! subprogram: intrp22 --- interpolates from one 2-d grid to another 2-d grid +! like analysis to surface grid or vice versa +! prgrmmr: li - initial version; org: np2 +! +! abstract: This routine interpolates a grid to b grid +! +! program history log: +! +! input argument list: +! rlons_a - longitudes of input array +! rlats_a - latitudes of input array +! nlon_a - number of longitude of input array +! nlat_a - number of latitude of input array +! rlons_b - longitudes of output array +! rlats_b - latitudes of output array +! nlon_b - number of longitude of output array +! nlat_b - number of latitude of output array +! a - input values +! +! output argument list: +! b - output values +! +! attributes: +! language: f90 +! machines: ibm RS/6000 SP; SGI Origin 2000; Compaq HP +! +!$$$ end documentation block + +! !USES: + use kinds, only: r_kind,i_kind,r_single + use constants, only: zero,one + + implicit none + +! !INPUT PARAMETERS: + integer(i_kind) ,intent(in ) :: nlon_a,nlat_a,nlon_b,nlat_b + real(r_kind), dimension(nlon_a) ,intent(in ) :: rlons_a + real(r_kind), dimension(nlat_a) ,intent(in ) :: rlats_a + real(r_kind), dimension(nlon_b) ,intent(in ) :: rlons_b + real(r_kind), dimension(nlat_b) ,intent(in ) :: rlats_b + + real(r_single), dimension(nlon_a,nlat_a),intent(in ) :: a + +! !OUTPUT PARAMETERS: + real(r_single), dimension(nlon_b,nlat_b),intent( out) :: b + +! Declare local variables + integer(i_kind) i,j,ix,iy,ixp,iyp + real(r_kind) dx1,dy1,dx,dy,w00,w01,w10,w11,bout,dlat,dlon + +!***************************************************************************** + + b=zero +! Loop over all points to get interpolated value + do j=1,nlat_b + dlat=rlats_b(j) + call grdcrd1(dlat,rlats_a,nlat_a,1) + iy=int(dlat) + iy=min(max(1,iy),nlat_a) + dy =dlat-iy + dy1 =one-dy + iyp=min(nlat_a,iy+1) + + do i=1,nlon_b + dlon=rlons_b(i) + call grdcrd1(dlon,rlons_a,nlon_a,1) + ix=int(dlon) + dx =dlon-ix + dx=max(zero,min(dx,one)) + dx1 =one-dx + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + ix=min(max(0,ix),nlon_a) + ixp=ix+1 + if(ix==0) ix=nlon_a + if(ixp==nlon_a+1) ixp=1 + bout=w00*a(ix,iy)+w01*a(ix,iyp)+w10*a(ixp,iy)+w11*a(ixp,iyp) + b(i,j)=bout + + end do + end do + + +! End of routine + return + end subroutine intrp22 + + subroutine tran_gfssfc(ain,aout,lonb,latb) +!$$$ subprogram documentation block +! . . . . +! subprogram: tran_gfssfc transform gfs surface file to analysis grid +! prgmmr: derber org: np2 date: 2003-04-10 +! +! abstract: transform gfs surface file to analysis grid +! +! program history log: +! 2012-31-38 derber - initial routine +! +! input argument list: +! ain - input surface record on processor iope +! lonb - input number of longitudes +! latb - input number of latitudes +! +! output argument list: +! aout - output transposed surface record +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_single + use constants, only: zero + use sfcio_module, only: sfcio_realkind + implicit none + +! Declare passed variables + integer(i_kind) ,intent(in ) :: lonb,latb + real(sfcio_realkind),dimension(lonb,latb),intent(in ) :: ain + real(r_single),dimension(latb+2,lonb),intent(out) :: aout + +! Declare local variables + integer(i_kind) i,j + real(r_kind) sumn,sums +! of surface guess array + sumn = zero + sums = zero + do i=1,lonb + sumn = ain(i,1) + sumn + sums = ain(i,latb) + sums + end do + sumn = sumn/float(lonb) + sums = sums/float(lonb) +! Transfer from local work array to surface guess array + do j = 1,lonb + aout(1,j)=sums + do i=2,latb+1 + aout(i,j) = ain(j,latb+2-i) + end do + aout(latb+2,j)=sumn + end do + + return + end subroutine tran_gfssfc +end module ncepnems_io + diff --git a/src/netcdf_mod.f90 b/src/gsi/netcdf_mod.f90 similarity index 100% rename from src/netcdf_mod.f90 rename to src/gsi/netcdf_mod.f90 diff --git a/src/nlmsas_ad.f90 b/src/gsi/nlmsas_ad.f90 similarity index 100% rename from src/nlmsas_ad.f90 rename to src/gsi/nlmsas_ad.f90 diff --git a/src/gsi/nltransf.f90 b/src/gsi/nltransf.f90 new file mode 100644 index 000000000..8eb251aeb --- /dev/null +++ b/src/gsi/nltransf.f90 @@ -0,0 +1,80 @@ +module nltransf + +!$$$ module documentation block +! module: nltransf +! program history log: +! 2018-01-18 yang/Guo ! Jim Purser's nonlinear transformation for vis and cldch. +! will work on the document late +!$$$ end documentation block +! . . . . + + use kinds, only: r_kind, i_kind + use constants, only: zero + + implicit none + private + + public:: nltransf_forward + interface nltransf_forward ; module procedure forward; end interface + public:: nltransf_inverse + interface nltransf_inverse ; module procedure inverse; end interface + +! + +CONTAINS + +subroutine forward(zin,zout,powerp,scale_cv) + +!-------------------------------------------------------------- +! input argument: +! zin - vis or cldch +! powerp - parameter for nltr +! output argument: +! zout - the vis or cldch after the nonlinear transformation +!-------------------------------------------------------------- + implicit none + real(r_kind),intent(in):: zin + real(r_kind),intent(in):: powerp + real(r_kind),intent(in):: scale_cv + real(r_kind) :: zout + +! local variable + real(r_kind) :: temp ! after the nltransformation +! do not choose negative powerp + if (abs(powerp) > zero) then + !non-log conversion + temp =(zin/scale_cv)**powerp + zout =(temp-1.0_r_kind)/powerp + else + !log conversion + zout=log(zin/scale_cv) + endif + return +end subroutine forward + +subroutine inverse(zin,zout,powerp,scale_cv) + implicit none + real(r_kind),intent(in):: zin + real(r_kind),intent(in):: powerp + real(r_kind),intent(in):: scale_cv + real(r_kind) :: zout + +! Local variable + real(r_kind) :: powerpinv + real(r_kind) :: z1 + +!change zin from nltr space back to physical space + if (abs(powerp)> zero) then + ! non-log conversion + powerpinv=1.0_r_kind/powerp + z1=(powerp*zin + 1.0_r_kind) + z1=z1**powerpinv + zout=z1*scale_cv + else + ! log conversion + zout=exp(zin)*scale_cv + endif + return +end subroutine inverse + +end module nltransf diff --git a/src/normal_rh_to_q.f90 b/src/gsi/normal_rh_to_q.f90 similarity index 100% rename from src/normal_rh_to_q.f90 rename to src/gsi/normal_rh_to_q.f90 diff --git a/src/nstio_module.f90 b/src/gsi/nstio_module.f90 similarity index 100% rename from src/nstio_module.f90 rename to src/gsi/nstio_module.f90 diff --git a/src/obs_ferrscale.F90 b/src/gsi/obs_ferrscale.F90 similarity index 96% rename from src/obs_ferrscale.F90 rename to src/gsi/obs_ferrscale.F90 index e19ec070c..f04260a2b 100644 --- a/src/obs_ferrscale.F90 +++ b/src/gsi/obs_ferrscale.F90 @@ -14,6 +14,8 @@ module obs_ferrscale ! 2015-09-03 guo - obsmod::yobs has been replaced with m_obsHeadBundle, ! where yobs is created and destroyed when and where it ! is needed. +! 2018-08-10 guo - replaced intjo() related code to a new polymorphic +! implementation intjomod::intjo(). ! ! Subroutines Included: ! init_ferr_scale - Initialize parameters @@ -301,13 +303,9 @@ subroutine hrm1h_ferr_scale(xin,xout,nprt,calledby) use constants, only: zero_quad use mpimod, only: mype use intjomod, only: intjo -use intradmod, only: setrad use mpl_allreducemod, only: mpl_allreduce use jfunc, only: nrclen,nsclen,npclen,ntclen -use m_obsHeadBundle, only: obsHeadBundle -use m_obsHeadBundle, only: obsHeadBundle_create -use m_obsHeadBundle, only: obsHeadBundle_destroy implicit none ! Declare passed variables @@ -322,13 +320,12 @@ subroutine hrm1h_ferr_scale(xin,xout,nprt,calledby) type(gsi_bundle) :: mval(nsubwin) type(predictors) :: sbias, rbias real(r_quad) :: zjb,zjo,zjc,zjl -integer(i_kind) :: ii,iobs,ibin,i +integer(i_kind) :: ii,iobs,i logical :: llprt,llouter character(len=255) :: seqcalls real(r_quad),dimension(max(1,nrclen)) :: qpred -type(obsHeadBundle),pointer,dimension(:):: yobs !********************************************************************** @@ -383,15 +380,10 @@ subroutine hrm1h_ferr_scale(xin,xout,nprt,calledby) do ii=1,nsubwin mval(ii)=zero end do -call setrad(rval(1)) qpred=zero_quad ! Compare obs to solution and transpose back to grid (H^T R^{-1} H) -call obsHeadBundle_create(yobs,nobs_bins) -do ibin=1,size(yobs) ! == nobs_bins - call intjo(yobs(ibin),rval(ibin),qpred,sval(ibin),sbias,ibin) -end do -call obsHeadBundle_destroy(yobs) +call intjo(rval,qpred,sval,sbias) ! Take care of background error for bias correction terms diff --git a/src/obs_para.f90 b/src/gsi/obs_para.f90 similarity index 98% rename from src/obs_para.f90 rename to src/gsi/obs_para.f90 index 14844a622..e560fafe1 100644 --- a/src/obs_para.f90 +++ b/src/gsi/obs_para.f90 @@ -58,11 +58,11 @@ subroutine obs_para(ndata,mype) use constants, only: zero use jfunc, only: factqmin,factqmax use mpimod, only: npe,mpi_itype,mpi_comm_world,ierror - use obsmod, only: obs_setup,dtype,mype_diaghdr,ndat,nsat1, & - obsfile_all,dplat,nobs_sub,obs_sub_comm + use obsmod, only: obs_setup,dtype,mype_diaghdr,ndat,nsat1 + use obsmod, only: obsfile_all,dplat,nobs_sub,obs_sub_comm use gridmod, only: twodvar_regional use qcmod, only: buddycheck_t,buddydiag_save - use gsi_io, only: verbose + use gsi_io, only: verbose, print_obs_para implicit none ! Declare passed variables @@ -119,7 +119,7 @@ subroutine obs_para(ndata,mype) end if end if nsat1(is)= nobs_sub(mm1,is) - if(mm1 == 1 .and. print_verbose)then + if(mm1 == 1 .and. (print_verbose .or. print_obs_para))then write(6,1000)dtype(is),dplat(is),(nobs_sub(ii,is),ii=1,npe) 1000 format('OBS_PARA: ',2A10,8I10,/,(10X,10I10)) end if diff --git a/src/gsi/obs_sensitivity.f90 b/src/gsi/obs_sensitivity.f90 new file mode 100644 index 000000000..880ee6384 --- /dev/null +++ b/src/gsi/obs_sensitivity.f90 @@ -0,0 +1,616 @@ +module obs_sensitivity +!$$$ module documentation block +! . . . . +! module: obs_sensitivity +! prgmmr: tremolet +! +! abstract: Contains variables and routines for computation of +! forecast sensitivity to observations. +! +! program history log: +! 2007-06-26 tremolet +! 2007-07-19 tremolet - increment sensitivity to observations +! 2009-08-07 lueken - updated documentation +! 2010-04-30 tangborn - add pointer to carbon monoxide +! 2010-05-27 todling - remove all user-specific TL-related references +! 2010-07-16 todling - add reference to aero and aerol +! 2010-08-19 lueken - add only to module use;no machine code, so use .f90 +! 2011-03-29 todling - add reference to pm2_5 +! 2012-04-15 todling - add reference to gust, vis, pblh +! 2015-07-10 pondeca - add reference to wspd10m, td2m ,mxtm ,mitm ,pmsl, +! howv ,tcamt, lcbas, cldch +! 2016-02-20 pagowski - add pm10 +! 2016-05-05 pondeca - add reference to uwnd10m, vwnd10m +! 2017-05-12 Y. Wang and X. Wang - add reflectivity (dBZ), POC: xuguang.wang@ou.edu +! 2017-01-16 Apodaca - add reference to lightning +! 2017-05-06 todling - reload ensemble when FSOI calc doing EFSOI-like +! 2017-05-21 todling - implement ability to do 2nd EFSOI-like calc +! +! Subroutines Included: +! init_fc_sens - Initialize computations +! +! Variable Definitions: +! fcsens - forecast sensitivity gradient +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block +! ------------------------------------------------------------------------------ +use kinds, only: r_kind,i_kind,r_quad +use constants, only: zero, zero_quad, two +use gsi_4dvar, only: nobs_bins, l4dvar, lsqrtb, nsubwin +use gsi_4dvar, only: tau_fcst,efsoi_order,efsoi_afcst,efsoi_ana +use jfunc, only: jiter, miter, niter, iter + +use gsi_obOperTypeManager, only: nobs_type => obOper_count +use gsi_obOperTypeManager, only: obOper_typeinfo +use mpimod, only: mype +use control_vectors, only: control_vector,allocate_cv,read_cv,deallocate_cv, & + dot_product,assignment(=) +use state_vectors, only: allocate_state,deallocate_state +use gsi_bundlemod, only: self_add +use gsi_bundlemod, only: assignment(=) +use gsi_bundlemod, only: gsi_bundle +use bias_predictors, only: predictors,allocate_preds,deallocate_preds, & + assignment(=) +use mpl_allreducemod, only: mpl_allreduce +use gsi_4dcouplermod, only: gsi_4dcoupler_getpert +use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens,destroy_hybens_localization_parameters +use hybrid_ensemble_isotropic, only: create_ensemble,load_ensemble,destroy_ensemble +use hybrid_ensemble_isotropic, only: hybens_localization_setup +use mpeu_util, only: perr,die +! ------------------------------------------------------------------------------ +implicit none +save +private +public lobsensfc,lobsensjb,lobsensincr,lobsensadj,& + lobsensmin,iobsconv,llancdone,lsensrecompute, & + fcsens, sensincr, & + init_obsens, init_fc_sens, save_fc_sens, dot_prod_obs +public efsoi_o2_update + +public:: obsensCounts_realloc +public:: obsensCounts_set +public:: obsensCounts_dealloc + +logical lobsensfc,lobsensjb,lobsensincr, & + lobsensadj,lobsensmin,llancdone,lsensrecompute +integer(i_kind) :: iobsconv + +! ------------------------------------------------------------------------------ +type(control_vector) :: fcsens +real(r_kind), allocatable :: sensincr(:,:,:) +integer(i_kind):: orig_tau_fcst=-1 + +integer(i_kind),save,allocatable:: obscounts(:,:) + +character(len=*),parameter:: myname="obs_sensitivity" +! ------------------------------------------------------------------------------ +contains +!>> object obsensCounts_: +!>> this object was public obsmod::obscounts(:,:), but now private module +!>> variable in this module. It is accessed through following module procedures +!>> []_alloc(), []_set() and []_dealloc(). + +subroutine obsensCounts_realloc(ntype,nbin) +!>> was implemented in setuprhsall() + implicit none + integer(i_kind),intent(in):: ntype + integer(i_kind),intent(in):: nbin + character(len=*),parameter:: myname_=myname//"::obsensCounts_realloc" + if(allocated(obscounts)) deallocate(obscounts) + allocate(obscounts(ntype,nbin)) +end subroutine obsensCounts_realloc + +subroutine obsensCounts_set(iobsglb) +!>> was implemented in evaljo() + implicit none + integer(i_kind),dimension(:,:),intent(in):: iobsglb + character(len=*),parameter:: myname_=myname//"::obsensCounts_set" + if(.not.allocated(obscounts)) then + call perr(myname_,'not allocated, obscounts') + call perr(myname_,'was evaljo() exception 125') + call die(myname_) + endif + if(any(shape(obscounts)/=shape(iobsglb))) then + call perr(myname_,'mismatched, storage size(obscounts,1) =',size(obscounts,1)) + call perr(myname_,' argument size(iobsglb,1) =',size(iobsglb,1)) + call perr(myname_,' storage size(obscounts,2) =',size(obscounts,2)) + call perr(myname_,' argument size(iobsglb,2) =',size(iobsglb,2)) + call die(myname_) + endif + obscounts(:,:)=iobsglb(:,:) +end subroutine obsensCounts_set + +subroutine obsensCounts_dealloc() +!>> was a part of obsmod::destroyobs_(). + implicit none + character(len=*),parameter:: myname_=myname//"::obsensCounts_dealloc" + if(allocated(obscounts)) deallocate(obscounts) +end subroutine obsensCounts_dealloc + +! ------------------------------------------------------------------------------ +subroutine init_obsens +!$$$ subprogram documentation block +! . . . . +! subprogram: init_obsens +! prgmmr: +! +! abstract: +! +! program history log: +! 2009-08-07 lueken - added subprogram doc block +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block +implicit none + +lobsensfc=.false. +lobsensjb=.false. +lobsensincr=.false. +lobsensadj=.false. +lobsensmin=.false. +lsensrecompute=.false. +llancdone=.false. +iobsconv=0 + +end subroutine init_obsens +! ------------------------------------------------------------------------------ +subroutine init_fc_sens +!$$$ subprogram documentation block +! . . . . +! subprogram: init_fc_sens +! prgmmr: tremolet +! +! abstract: Read forecast sensitivity gradient +! +! program history log: +! 2007-06-26 tremolet - initial code +! 2009-08-07 lueken - added subprogram doc block +! 2010-05-27 todling - gsi_4dcoupler; remove dependence on GMAO specifics +! 2012-05-22 todling - update interface to getpert +! 2015-12-01 todling - add several obs-types that Pondeca forget to add here +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none + +character(len=12) :: clfile +type(gsi_bundle) :: fcgrad(nsubwin) +type(gsi_bundle) :: eval(ntlevs_ens) +type(predictors) :: zbias +type(control_vector) :: xwork +real(r_kind) :: zjx +integer(i_kind) :: ii +character(len=80),allocatable,dimension(:)::fname + +if (mype==0) then + write(6,*)'init_fc_sens: lobsensincr,lobsensfc,lobsensjb=', & + lobsensincr,lobsensfc,lobsensjb + write(6,*)'init_fc_sens: lobsensadj,lobsensmin,iobsconv=', & + lobsensadj,lobsensmin,iobsconv + write(6,*)'init_fc_sens: lsensrecompute=',lsensrecompute +endif + +call allocate_cv(fcsens) +fcsens=zero + +if (lobsensadj.and.lobsensmin) then + write(6,*)'init_fc_sens: unknown method',lobsensadj,lobsensmin + call stop2(155) +end if + +if (iobsconv>=2) then + allocate(sensincr(nobs_bins,nobs_type,niter(jiter))) +else + allocate(sensincr(nobs_bins,nobs_type,1)) +endif +sensincr=zero + +! Initialize fcsens +if (lobsensfc) then + if (lobsensincr) then + clfile='xhatsave.ZZZ' + write(clfile(10:12),'(I3.3)') jiter + call read_cv(fcsens,clfile) + if (jiter>1) then + clfile='xhatsave.ZZZ' + write(clfile(10:12),'(I3.3)') jiter-1 + call allocate_cv(xwork) + call read_cv(xwork,clfile) + do ii=1,fcsens%lencv + fcsens%values(ii) = fcsens%values(ii) - xwork%values(ii) + end do + call deallocate_cv(xwork) + endif + else + if (jiter==miter) then + if (lobsensjb) then + clfile='xhatsave.ZZZ' + write(clfile(10:12),'(I3.3)') miter + call read_cv(fcsens,clfile) + else +! read and convert output of GCM adjoint + allocate(fname(nsubwin)) + fname='NULL' + if (tau_fcst>0) then + fname='B' + endif + do ii=1,nsubwin + call allocate_state(fcgrad(ii)) + end do + call allocate_preds(zbias) + zbias=zero + call gsi_4dcoupler_getpert(fcgrad,nsubwin,'adm',fname) + if (lsqrtb) then + call control2model_ad(fcgrad,zbias,fcsens) + else + if (l_hyb_ens) then + do ii=1,ntlevs_ens + call allocate_state(eval(ii)) + end do + eval(1)=fcgrad(1) + fcgrad(1)=zero + call ensctl2state_ad(eval,fcgrad(1),fcsens) + call control2state_ad(fcgrad,zbias,fcsens) + do ii=1,ntlevs_ens + call deallocate_state(eval(ii)) + end do + if (tau_fcst>0) then + call destroy_hybens_localization_parameters + call destroy_ensemble + call create_ensemble + ! now load actual ens background + efsoi_afcst=.false. + orig_tau_fcst=tau_fcst + tau_fcst=-1 + call load_ensemble + call hybens_localization_setup + endif + else + call control2state_ad(fcgrad,zbias,fcsens) + end if + endif + do ii=1,nsubwin + call deallocate_state(fcgrad(ii)) + end do + call deallocate_preds(zbias) + deallocate(fname) + endif + else +! read gradient from outer loop jiter+1 + clfile='fgsens.ZZZ' + WRITE(clfile(8:10),'(I3.3)') jiter+1 + call read_cv(fcsens,clfile) + endif + endif + zjx=dot_product(fcsens,fcsens) + if (mype==0) write(6,888)'init_fc_sens: Norm fcsens=',sqrt(zjx) +endif +888 format(A,3(1X,ES25.18)) + +return +end subroutine init_fc_sens +! ------------------------------------------------------------------------------ +subroutine efsoi_o2_update(sval) +!$$$ subprogram documentation block +! . . . . +! subprogram: order2_fc_sens +! prgmmr: todling +! +! abstract: Read forecast sensitivity gradient +! +! program history log: +! 2007-06-26 tremolet - initial code +! 2009-08-07 lueken - added subprogram doc block +! 2010-05-27 todling - gsi_4dcoupler; remove dependence on GMAO specifics +! 2012-05-22 todling - update interface to getpert +! 2015-12-01 todling - add several obs-types that Pondeca forget to add here +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none +type(gsi_bundle),intent(inout) :: sval(nobs_bins) + +character(len=80),allocatable,dimension(:)::fname +type(gsi_bundle) :: fcgrad(nsubwin) +type(gsi_bundle) :: eval(ntlevs_ens) +type(gsi_bundle) :: mval(nsubwin) +type(predictors) :: zbias +real(r_kind) :: zjx +integer(i_kind) :: ii + +tau_fcst=orig_tau_fcst +if (tau_fcst<=0) return +if (efsoi_order/=2) return +if (.not.l_hyb_ens) return + +if (mype==0) then + print *, 'in order2_fc_sens ...' +endif + +if (lobsensadj.and.lobsensmin) then + write(6,*)'order2_fc_sens: unknown method',lobsensadj,lobsensmin + call stop2(155) +end if + +! Zero out whatever is in fcsens + fcsens=zero + +! read and convert output of GCM adjoint + allocate(fname(nsubwin)) + fname='A' + do ii=1,nsubwin + call allocate_state(fcgrad(ii)) + end do + call allocate_preds(zbias) + zbias=zero + do ii=1,ntlevs_ens + call allocate_state(eval(ii)) + end do + do ii=1,nsubwin + fcgrad(ii)=zero + end do + call gsi_4dcoupler_getpert(fcgrad,nsubwin,'adm',fname) +! Wipe out loaded ensemble members to allow reloading ensemble of analysis + call destroy_ensemble +! Read in ens forecasts issues from "analysis" + efsoi_afcst=.true. + call create_ensemble + call load_ensemble + do ii=1,ntlevs_ens + call allocate_state(eval(ii)) + end do + eval(1)=fcgrad(1) + fcgrad(1)=zero + call ensctl2state_ad(eval,fcgrad(1),fcsens) + call control2state_ad(fcgrad,zbias,fcsens) + do ii=1,ntlevs_ens + call deallocate_state(eval(ii)) + end do + do ii=1,nsubwin + call deallocate_state(fcgrad(ii)) + end do + call deallocate_preds(zbias) + deallocate(fname) +! Wipe outensemble from memory + call destroy_ensemble + +! Report magnitude of input vector + zjx=dot_product(fcsens,fcsens) + if (mype==0) write(6,888)'order2_fc_sens: Norm fcsens=',sqrt(zjx) +888 format(A,3(1X,ES25.18)) + +! Read in ensemble of analysis (these are EnKF, not GSI, analyses obviously) + efsoi_ana=.true. + tau_fcst=-1 + call create_ensemble + call load_ensemble + +! Allocate local variables + do ii=1,nsubwin + call allocate_state(mval(ii)) + end do + do ii=1,ntlevs_ens + call allocate_state(eval(ii)) + end do + call allocate_preds(zbias) + +! Convert from control variable to state space + call control2state(fcsens,mval,zbias) + +! Convert ensemble control variable to state space and update from previous value + call ensctl2state(fcsens,mval(1),eval) + do ii=1,ntlevs_ens + call self_add(sval(ii),eval(ii)) + end do + +! Release memory +call deallocate_preds(zbias) +do ii=1,ntlevs_ens + call deallocate_state(eval(ii)) +end do +do ii=1,nsubwin + call deallocate_state(mval(ii)) +end do + +return +end subroutine efsoi_o2_update +subroutine save_fc_sens +!$$$ subprogram documentation block +! . . . . +! subprogram: save_fc_sens +! prgmmr: tremolet +! +! abstract: Compute and save forecast sensitivity to observations +! +! program history log: +! 2007-06-26 tremolet - initial code +! 2009-08-07 lueken - added subprogram doc block +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block +implicit none + +real(r_kind) :: zz +integer(i_kind) :: ii,jj,kk + +! Save statistics +if (mype==0) then + +! Full stats + do jj=1,nobs_type + write(6,'(A,2X,I3,2X,A)')'Obs types:',jj,obOper_typeinfo(jj) + enddo + write(6,'(A,2X,I4)')'Obs bins:',nobs_bins + write(6,*)'Obs Count Begin' + if (.not.allocated(obscounts)) then + write(6,*)'save_fc_sens: obscounts not allocated' + call stop2(156) + end if + do jj=1,nobs_type + write(6,'((1X,I12))')(obscounts(jj,ii),ii=1,nobs_bins) + enddo + write(6,*)'Obs Count End' + + write(6,*)'Obs Impact Begin' + do kk=1,SIZE(sensincr,3) + if (SIZE(sensincr,3)==1) then + write(6,'(A,I4)')'Obs Impact iteration= ',niter(jiter) + else + write(6,'(A,I4)')'Obs Impact iteration= ',kk + endif + do jj=1,nobs_type + write(6,'((1X,ES12.5))')(sensincr(ii,jj,kk),ii=1,nobs_bins) + enddo + enddo + write(6,*)'Obs Impact End' + + kk=SIZE(sensincr,3) +! Summary by obs type + do jj=1,nobs_type + zz=zero + do ii=1,nobs_bins + zz=zz+sensincr(ii,jj,kk) + enddo + if (zz/=zero) write(6,'(A,2X,A3,2X,ES12.5)')'Obs Impact type',obOper_typeinfo(jj),zz + enddo + +! Summary by obs bins + do ii=1,nobs_bins + zz=zero + do jj=1,nobs_type + zz=zz+sensincr(ii,jj,kk) + enddo + if (zz/=zero) write(6,'(A,2X,I3,2X,ES12.5)')'Obs Impact bin',ii,zz + enddo + +endif + +deallocate(sensincr) +call deallocate_cv(fcsens) + +return +end subroutine save_fc_sens +! ------------------------------------------------------------------------------ +real(r_kind) function dot_prod_obs() +!$$$ subprogram documentation block +! . . . . +! subprogram: init_fc_sens +! prgmmr: tremolet +! +! abstract: Computes scalar product in observation space +! (based on evaljo) +! +! program history log: +! 2007-06-27 tremolet +! 2009-01-18 todling - carry summations in quad precision +! 2009-08-07 lueken - added subprogram doc block +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block +use m_obsdiagNode, only: obs_diag +use m_obsdiags, only: obsdiags +implicit none + +integer(i_kind) :: ii,jj,ij,it +real(r_quad) :: zzz +real(r_quad) :: zprods(nobs_type*nobs_bins) +type(obs_diag),pointer:: obsptr +! ---------------------------------------------------------- + +zprods(:)=zero_quad + +ij=0 +do ii=1,size(obsdiags,2) + do jj=1,size(obsdiags,1) + ij=ij+1 + + obsptr => obsdiags(jj,ii)%head + do while (associated(obsptr)) + if (obsptr%luse.and.obsptr%muse(jiter)) then + zprods(ij) = zprods(ij) + obsptr%nldepart(jiter) * obsptr%obssen(jiter) + endif + obsptr => obsptr%next + enddo + + enddo +enddo + +! Gather contributions +call mpl_allreduce(nobs_type*nobs_bins,qpvals=zprods) + +! Save intermediate values +it=-1 +if (iobsconv>=2) then + if (iter>=1.and.iter<=niter(jiter)) it=iter +else + it=1 +endif + +if (it>0) then + ij=0 + do ii=1,nobs_bins + do jj=1,nobs_type + ij=ij+1 + sensincr(ii,jj,it)=zprods(ij) + enddo + enddo +endif + +! Sum +zzz=zero_quad + +ij=0 +do ii=1,nobs_bins + do jj=1,nobs_type + ij=ij+1 + zzz=zzz+zprods(ij) + enddo +enddo + +dot_prod_obs=zzz + +return +end function dot_prod_obs +! ------------------------------------------------------------------------------ +end module obs_sensitivity diff --git a/src/obserr_allsky_mw.f90 b/src/gsi/obserr_allsky_mw.f90 similarity index 100% rename from src/obserr_allsky_mw.f90 rename to src/gsi/obserr_allsky_mw.f90 diff --git a/src/observer.F90 b/src/gsi/observer.F90 similarity index 98% rename from src/observer.F90 rename to src/gsi/observer.F90 index 30cd46bde..7ac91e5ee 100644 --- a/src/observer.F90 +++ b/src/gsi/observer.F90 @@ -43,8 +43,8 @@ module observermod use guess_grids, only: create_ges_grids,create_sfc_grids,& destroy_ges_grids,destroy_sfc_grids,nfldsig use cloud_efr_mod, only: cloud_init,cloud_final - use obsmod, only: write_diag,obs_setup,ndat,dirname,lobserver,ndat,nobs_sub, & - lread_obs_skip,nprof_gps,ditype,obs_input_common,iadate,luse_obsdiag + use obsmod, only: write_diag,obs_setup,ndat,dirname,lobserver,ndat,nobs_sub + use obsmod, only: lread_obs_skip,nprof_gps,ditype,obs_input_common,iadate use satthin, only: superp,super_val1,getsfc,destroy_sfc use gsi_4dvar, only: l4dvar use convinfo, only: convinfo_destroy @@ -294,6 +294,7 @@ subroutine set_ ! 2007-10-03 todling - created this file from slipt of glbsoi ! 2009-01-28 todling - split observer into init/set/run/finalize ! 2017-08-31 li - add gsi_nstcoupler_final +! 2019-07-09 todling - move gsi_nstcoupler_final to destroy_sfc (consistency) ! ! input argument list: ! mype - mpi task id @@ -307,7 +308,6 @@ subroutine set_ !$$$ use mpeu_util, only: tell,die - use gsi_nstcouplermod, only: nst_gsi,gsi_nstcoupler_final use gsi_io, only: mype_io implicit none character(len=*), parameter :: Iam="observer_set" @@ -375,7 +375,6 @@ subroutine set_ ! isli2 and sno2 are used in intppx (called from setuprad) and setuppcp. call getsfc(mype,mype_io,.false.,.false.) call destroy_sfc - if (nst_gsi > 0) call gsi_nstcoupler_final() endif diff --git a/src/obsmod.F90 b/src/gsi/obsmod.F90 similarity index 78% rename from src/obsmod.F90 rename to src/gsi/obsmod.F90 index 12df2db62..49d93b9de 100644 --- a/src/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -112,6 +112,7 @@ module obsmod ! procedures into module m_prad in file prad_bias.f90. ! 2015-09-03 guo - moved type::obs_handle, its instance yobs, and its ! allocation, into m_obsHeadBundle.F90. +! 2016-01-28 mccarty - add netcdf_diag capability ! 2016-03-07 pondeca - add uwnd10m,vwnd10m ! 2016-05-04 guo - moved all ob_type and ob_head type-definitions into ! their *own* class-style-modules, including 9 recent @@ -127,6 +128,27 @@ module obsmod ! 2016-07-26 guo - moved away most cldch_ob_type contents to a new module, m_cldchNode ! 2016-08-20 guo - moved (stpcnt,ll_jo,ib_jo) to stpjo.f90. ! 2016-09-19 guo - moved function dfile_format() to m_extOzone.F90 +! 2016-02-15 Johnson, Y. Wang, X. Wang - add dbz type for reflectivity DA. +! POC: xuguang.wang@ou.edu +! 2016-11-29 shlyaeva - add lobsdiag_forenkf option for writing out linearized +! H(x) for EnKF +! 2018-01-01 apodaca - add GOES/GLM lightning observations +! 2019-05-28 guo - moved all type-constants {i_xx_ob_type} as enumerators of +! (1) obsNode types to module m_obsNodeTypeManager.F90 (iobNode_xx); and +! (2) obOper Types to module gsi_obOperTypeManager.F90 (iobOper_xx). +! Note that a single type specification i_xx_ob_type is now split into two, +! one for obsNode types, and another for obOper types. +! - moved nobs_type to module gsi_obOperTypeManager.F90 (obOper_count). +! - moved cobstype(:) to module gsi_obOperTypeManager.F90. +! - moved type obs_diag, obs_diags, aofp_obs_diag, and variable obsdiags(:,:) +! with subroutine inquire_obsdiags() into m_obsdiagNode.F90. +! - moved obscounts(:) into obs_sensitivity.f90. +! 2019-06-25 Hu - add diag_radardbz for controling radar reflectivity +! diag file +! 01-27-2020 Winterbottom Moved regression coeffcients for regional +! model (e.g., HWRF) aircraft recon dynamic +! observation error (DOE) specification to +! GSI namelist level. ! ! Subroutines Included: ! sub init_obsmod_dflts - initialize obs related variables to default values @@ -148,6 +170,8 @@ module obsmod ! def perturb_obs - namelist logical to perturb (=true) observations ! def perturb_fact - namelist scaling factor for observation perturbations ! def write_diag - namelist logical array to compute/write (=true) diag files +! def diag_radardbz- namelist logical to compute/write (=true) radar +! reflectiivty diag files ! def reduce_diag - namelist logical to produce reduced radiance diagnostic files ! def use_limit - parameter set equal to -1 if diag files produced or 0 if not diag files or reduce_diag ! def obs_setup - prefix for files passing pe relative obs data to setup routines @@ -160,6 +184,7 @@ module obsmod ! def ditype - observation group type (set in read_obs, e.g. rad,conv,etc) ! def time_window - half time window for obs type (hours) ! def time_window_max - maximum half time window (hours) +! def time_window_rad - maximum half time window (hours) for cetain radiance ! def obsfile_all - file containing observations after initial read ! def ndat_types - number of available data types ! def ndat_times - number of available synoptic times @@ -248,6 +273,12 @@ module obsmod ! def uwnd10mtail - 10m-uwind linked list tail ! def vwnd10mhead - 10m-vwind linked list head ! def vwnd10mtail - 10m-vwind linked list tail +! def swcphead - solid-water content path linked list head +! def swcptail - solid-water content path linked list tail +! def lwcphead - liquid-water content path linked list head +! def lwcptail - liquid-water content path linked list tail +! def lighthead - lightning linked list head +! def lighttail - lightning linked list tail ! def lunobs_obs - unit to save satellite observation ! def iout_rad - output unit for satellite stats ! def iout_pcp - output unit for precipitation stats @@ -282,6 +313,9 @@ module obsmod ! def iout_vwnd10m - output unit for conventional 10-m vwind stats ! def iout_pm2_5 - output unit for pm2_5 stats ! def iout_pm10 - output unit for pm10 stats +! def iout_swcp - output unit for swcp stats +! def iout_lwcp - output unit for lwcp stats +! def iout_light - output unit for lightning stats ! def mype_t - task to handle temperature stats ! def mype_q - task to handle moisture stats ! def mype_uv - task to handle wind stats @@ -309,6 +343,9 @@ module obsmod ! def mype_aero - task to handle aerosol stats ! def mype_pm2_5 - task to handle pm2_5 ! def mype_pm10 - task to handle pm10 +! def mype_swcp - task to handle swcp +! def mype_lwcp - task to handle lwcp +! def mype_light - task to lightning stats ! def oberrflg - logical for reading in new observation error table ! .true. will read in obs errors from file 'errtable' ! .false. will not read in new obs errors @@ -348,6 +385,11 @@ module obsmod ! data ! def obs_sub - number of observations of each type in each subdomain ! (nobs_type,npe) +! def binary_diag - trigger binary diag-file output (being phased out) +! def netcdf_diag - trigger netcdf diag-file output +! def l_wcp_cwm - namelist logical whether to use operator that +! includes cwm for both swcp and lwcp or not +! def aircraft_recon - namelist logibal whether to use DOE for aircraft ! ! attributes: ! langauge: f90 @@ -372,56 +414,104 @@ module obsmod public :: destroy_obsmod_vars public :: ran01dom,dval_use public :: iout_pcp,iout_rad,iadate,iadatemn,write_diag,reduce_diag,oberrflg,bflag,ndat,dthin,dmesh,l_do_adjoint + public :: diag_radardbz public :: lsaveobsens - public :: i_ps_ob_type,i_t_ob_type,i_w_ob_type,i_q_ob_type - public :: i_spd_ob_type,i_rw_ob_type,i_dw_ob_type,i_sst_ob_type - public :: i_gust_ob_type,i_vis_ob_type,i_pblh_ob_type,i_wspd10m_ob_type,i_td2m_ob_type - public :: i_uwnd10m_ob_type,i_vwnd10m_ob_type - public :: i_mxtm_ob_type,i_mitm_ob_type,i_pmsl_ob_type,i_howv_ob_type,i_tcamt_ob_type,i_lcbas_ob_type - public :: i_cldch_ob_type, iout_cldch, mype_cldch - public :: i_pw_ob_type,i_pcp_ob_type,i_oz_ob_type,i_o3l_ob_type,i_colvk_ob_type,i_gps_ob_type - public :: i_rad_ob_type,i_tcp_ob_type,i_lag_ob_type - public :: obscounts,nobs_type - public :: cobstype,nprof_gps,time_offset,ianldate + public :: iout_cldch, mype_cldch + public :: nprof_gps,time_offset,ianldate public :: iout_oz,iout_co,dsis,ref_obs,obsfile_all,lobserver,perturb_obs,ditype,dsfcalc,dplat public :: time_window,dval,dtype,dfile,dirname,obs_setup,oberror_tune,offtime_data - public :: lobsdiagsave,blacklst,hilbert_curve,lobskeep,time_window_max,sfcmodel,ext_sonde + public :: lobsdiagsave,lobsdiag_forenkf,blacklst,hilbert_curve,lobskeep,time_window_max,sfcmodel,ext_sonde + public :: time_window_rad public :: perturb_fact,dtbduv_on,nsat1,obs_sub_comm,mype_diaghdr public :: lobsdiag_allocated - public :: i_aero_ob_type - public :: i_aerol_ob_type - public :: i_pm2_5_ob_type - public :: i_pm10_ob_type public :: nloz_v8,nloz_v6,nloz_omi,nlco,nobskeep public :: grids_dim,rmiss_single,nchan_total,mype_sst,mype_gps public :: mype_uv,mype_dw,mype_rw,mype_q,mype_tcp,mype_lag,mype_ps,mype_t public :: mype_pw,iout_rw,iout_dw,iout_sst,iout_pw,iout_t,iout_q,iout_tcp - public :: iout_lag,iout_uv,iout_gps,iout_ps + public :: iout_lag,iout_uv,iout_gps,iout_ps,iout_light,mype_light public :: mype_gust,mype_vis,mype_pblh,iout_gust,iout_vis,iout_pblh public :: mype_tcamt,mype_lcbas,iout_tcamt,iout_lcbas public :: mype_wspd10m,mype_td2m,iout_wspd10m,iout_td2m public :: mype_uwnd10m,mype_vwnd10m,iout_uwnd10m,iout_vwnd10m public :: mype_mxtm,mype_mitm,iout_mxtm,iout_mitm public :: mype_pmsl,mype_howv,iout_pmsl,iout_howv + public :: mype_swcp,mype_lwcp,iout_swcp,iout_lwcp public :: lread_obs_save,obs_input_common,lread_obs_skip public :: ndat_times,lwrite_predterms,lwrite_peakwt public :: bmiss - public :: obs_diags ! types - public :: obs_diag ! types - public :: aofp_obs_diag ! types - public :: obsptr ! a local working pointer (to be removed) - public :: obsdiags ! objects - public :: inquire_obsdiags public :: mype_aero,iout_aero,nlaero public :: mype_pm2_5,iout_pm2_5 public :: mype_pm10,iout_pm10 public :: use_limit,lrun_subdirs public :: l_foreaft_thin,luse_obsdiag + ! ==== DBZ DA === + public :: ntilt_radarfiles + public :: whichradar + public :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, l2rwthin !Xu + + public :: doradaroneob,oneoblat,oneoblon + public :: oneobddiff,oneobvalue,oneobheight,oneobradid + public :: ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz,rmesh_vr,zmesh_vr + public :: radar_no_thinning + public :: mintiltvr,maxtiltvr,minobrangevr,maxobrangevr + public :: mintiltdbz,maxtiltdbz,minobrangedbz,maxobrangedbz + public :: debugmode + public :: missing_to_nopcp + + public :: iout_dbz, mype_dbz + ! --- DBZ DA --- + public :: obsmod_init_instr_table public :: obsmod_final_instr_table public :: nobs_sub + public :: netcdf_diag, binary_diag + + public :: l_wcp_cwm + public :: aircraft_recon + public :: hurricane_radar + + ! The following public variables are the coefficients that describe + ! the linear regression fits that are used to define the dynamic + ! observation error (DOE) specifications for all reconnissance + ! observations collected within hurricanes/tropical cyclones; these + ! apply only to the regional forecast models (e.g., HWRF); Henry + ! R. Winterbottom (henry.winterbottom@noaa.gov). + + ! Observation types: + + ! 1/236: HDOB (e.g., flight-level) observations. + + ! 1/237: Dropsonde observations. + + ! 292: SFMR observations. + + ! The following correspond to the specific humidity (q) + ! observations: + + public :: q_doe_a_136 + public :: q_doe_a_137 + public :: q_doe_b_136 + public :: q_doe_b_137 + + ! The following correspond to the temperature (t) observations: + + public :: t_doe_a_136 + public :: t_doe_a_137 + public :: t_doe_b_136 + public :: t_doe_b_137 + + ! The following correspond to the wind (uv) observations: + + public :: uv_doe_a_236 + public :: uv_doe_a_237 + public :: uv_doe_a_292 + public :: uv_doe_b_236 + public :: uv_doe_b_237 + public :: uv_doe_b_292 + + interface obsmod_init_instr_table module procedure init_instr_table_ end interface @@ -440,82 +530,18 @@ module obsmod #endif logical luse_obsdiag -! Declare types + logical binary_diag, netcdf_diag - integer(i_kind),parameter:: i_ps_ob_type= 1 ! ps_ob_type - integer(i_kind),parameter:: i_t_ob_type= 2 ! t_ob_type - integer(i_kind),parameter:: i_w_ob_type= 3 ! w_ob_type - integer(i_kind),parameter:: i_q_ob_type= 4 ! q_ob_type - integer(i_kind),parameter:: i_spd_ob_type= 5 ! spd_ob_type - integer(i_kind),parameter:: i_rw_ob_type= 6 ! rw_ob_type - integer(i_kind),parameter:: i_dw_ob_type= 7 ! dw_ob_type - integer(i_kind),parameter:: i_sst_ob_type= 8 ! sst_ob_type - integer(i_kind),parameter:: i_pw_ob_type= 9 ! pw_ob_type - integer(i_kind),parameter:: i_pcp_ob_type=10 ! pcp_ob_type - integer(i_kind),parameter:: i_oz_ob_type=11 ! oz_ob_type - integer(i_kind),parameter:: i_o3l_ob_type=12 ! o3l_ob_type - integer(i_kind),parameter:: i_gps_ob_type=13 ! gps_ob_type - integer(i_kind),parameter:: i_rad_ob_type=14 ! rad_ob_type - integer(i_kind),parameter:: i_tcp_ob_type=15 ! tcp_ob_type - integer(i_kind),parameter:: i_lag_ob_type=16 ! lag_ob_type - integer(i_kind),parameter:: i_colvk_ob_type= 17 ! colvk_ob_type - integer(i_kind),parameter:: i_aero_ob_type =18 ! aero_ob_type - integer(i_kind),parameter:: i_aerol_ob_type=19 ! aerol_ob_type - integer(i_kind),parameter:: i_pm2_5_ob_type=20 ! pm2_5_ob_type - integer(i_kind),parameter:: i_gust_ob_type=21 ! gust_ob_type - integer(i_kind),parameter:: i_vis_ob_type=22 ! vis_ob_type - integer(i_kind),parameter:: i_pblh_ob_type=23 ! pblh_ob_type - integer(i_kind),parameter:: i_wspd10m_ob_type=24! wspd10m_ob_type - integer(i_kind),parameter:: i_td2m_ob_type=25 ! td2m_ob_type - integer(i_kind),parameter:: i_mxtm_ob_type=26 ! mxtm_ob_type - integer(i_kind),parameter:: i_mitm_ob_type=27 ! mitm_ob_type - integer(i_kind),parameter:: i_pmsl_ob_type=28 ! pmsl_ob_type - integer(i_kind),parameter:: i_howv_ob_type=29 ! howv_ob_type - integer(i_kind),parameter:: i_tcamt_ob_type=30 ! tcamt_ob_type - integer(i_kind),parameter:: i_lcbas_ob_type=31 ! lcbas_ob_type - integer(i_kind),parameter:: i_pm10_ob_type=32 ! pm10_ob_type - integer(i_kind),parameter:: i_cldch_ob_type=33 ! cldch_ob_type - integer(i_kind),parameter:: i_uwnd10m_ob_type=34! uwnd10m_ob_type - integer(i_kind),parameter:: i_vwnd10m_ob_type=35! vwnd10m_ob_type - - integer(i_kind),parameter:: nobs_type = 35 ! number of observation types +! Declare types ! Structure for diagnostics - type obs_diag - type(obs_diag), pointer :: next => NULL() - real(r_kind), pointer :: nldepart(:) => null() ! (miter+1) - real(r_kind), pointer :: tldepart(:) => null() ! (miter) - real(r_kind), pointer :: obssen(:) => null() ! (miter) - real(r_kind) :: wgtjo - real(r_kind) :: elat, elon ! earth lat-lon for redistribution - integer(i_kind) :: indxglb ! a combined index similar to (ich,iob) - integer(i_kind) :: nchnperobs ! number of channels per observations - integer(i_kind) :: idv,iob,ich ! device, obs., and channel indices - logical, pointer :: muse(:) => null() ! (miter+1), according the setup()s - logical :: luse - end type obs_diag - - type aofp_obs_diag ! array-of-Fortran-pointers of type(obs_diag) - type(obs_diag), pointer :: ptr => NULL() - end type aofp_obs_diag - - type obs_diags - integer(i_kind):: n_alloc=0 - type(obs_diag), pointer :: head => NULL() - type(obs_diag), pointer :: tail => NULL() - type(aofp_obs_diag), allocatable, dimension(:):: lookup - end type obs_diags - - type(obs_diags), pointer :: obsdiags(:,:) => null() ! (nobs_type,nobs_bins) - type(obs_diag), pointer :: obsptr => null() - ! Declare interfaces interface destroyobs; module procedure destroyobs_; end interface ! Declare global variables - real(r_kind) perturb_fact,time_window_max,time_offset + real(r_kind) perturb_fact,time_window_max,time_offset,time_window_rad real(r_kind),dimension(50):: dmesh integer(i_kind) grids_dim,nchan_total,ianldate @@ -523,7 +549,7 @@ module obsmod integer(i_kind) lunobs_obs,nloz_v6,nloz_v8,nobskeep,nloz_omi integer(i_kind) nlco,use_limit integer(i_kind) iout_rad,iout_pcp,iout_t,iout_q,iout_uv, & - iout_oz,iout_ps,iout_pw,iout_rw + iout_oz,iout_ps,iout_pw,iout_rw, iout_dbz integer(i_kind) iout_dw,iout_gps,iout_sst,iout_tcp,iout_lag integer(i_kind) iout_co,iout_gust,iout_vis,iout_pblh,iout_tcamt,iout_lcbas integer(i_kind) iout_cldch @@ -533,17 +559,19 @@ module obsmod mype_rw,mype_dw,mype_gps,mype_sst, & mype_tcp,mype_lag,mype_co,mype_gust,mype_vis,mype_pblh, & mype_wspd10m,mype_td2m,mype_mxtm,mype_mitm,mype_pmsl,mype_howv,& - mype_uwnd10m,mype_vwnd10m, mype_tcamt,mype_lcbas + mype_uwnd10m,mype_vwnd10m, mype_tcamt,mype_lcbas, mype_dbz integer(i_kind) mype_cldch + integer(i_kind) iout_swcp, iout_lwcp + integer(i_kind) mype_swcp, mype_lwcp integer(i_kind) nlaero, iout_aero, mype_aero integer(i_kind) iout_pm2_5, mype_pm2_5 integer(i_kind) iout_pm10, mype_pm10 + integer(i_kind) iout_light, mype_light integer(i_kind),dimension(5):: iadate integer(i_kind),dimension(5):: iadatemn integer(i_kind),allocatable,dimension(:):: dsfcalc,dthin,ipoint integer(i_kind),allocatable,dimension(:):: nsat1,mype_diaghdr integer(i_kind),allocatable :: nobs_sub(:,:) - integer(i_kind),allocatable :: obscounts(:,:) integer(i_kind),allocatable :: obs_sub_comm(:) character(128) obs_setup @@ -551,18 +579,35 @@ module obsmod character(128) obs_input_common character(20),allocatable,dimension(:):: obsfile_all character(10),allocatable,dimension(:):: dtype,ditype,dplat - character(20),allocatable,dimension(:):: dfile + character(120),allocatable,dimension(:):: dfile character(20),allocatable,dimension(:):: dsis real(r_kind) ,allocatable,dimension(:):: dval real(r_kind) ,allocatable,dimension(:):: time_window - character(len=20) :: cobstype(nobs_type) + + integer(i_kind) ntilt_radarfiles + + logical :: doradaroneob + logical :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, l2rwthin!Xu + character(4) :: whichradar,oneobradid + real(r_kind) :: oneoblat,oneoblon,oneobddiff,oneobvalue,oneobheight + logical :: radar_no_thinning + logical :: ens_hx_dbz_cut + real(r_kind) ::static_gsi_nopcp_dbz + real(r_kind) ::rmesh_dbz,zmesh_dbz + real(r_kind) ::rmesh_vr,zmesh_vr + + logical :: debugmode + real(r_kind) :: minobrangevr,maxobrangevr,mintiltvr,maxtiltvr + real(r_kind) :: minobrangedbz,maxobrangedbz,mintiltdbz,maxtiltdbz + logical :: missing_to_nopcp logical, save :: obs_instr_initialized_=.false. logical oberrflg,bflag,oberror_tune,perturb_obs,ref_obs,sfcmodel,dtbduv_on,dval_use logical blacklst,lobsdiagsave,lobsdiag_allocated,lobskeep,lsaveobsens - logical lobserver,l_do_adjoint + logical lobserver,l_do_adjoint, lobsdiag_forenkf logical,dimension(0:50):: write_diag + logical diag_radardbz logical reduce_diag logical offtime_data logical hilbert_curve @@ -574,7 +619,44 @@ module obsmod logical lrun_subdirs logical l_foreaft_thin + logical l_wcp_cwm + logical aircraft_recon + logical hurricane_radar + character(len=*),parameter:: myname='obsmod' + + ! The following variable declarations pertain to the coefficients + ! that describe the linear regression fits that are used to define + ! the dynamic observation error (DOE) specifications for all + ! reconnissance observations collected within hurricanes/tropical + ! cyclones; these apply only to the regional forecast models (e.g., + ! HWRF); Henry R. Winterbottom (henry.winterbottom@noaa.gov). + + ! Observation types: + + ! 1/236: HDOB (e.g., flight-level) observations. + + ! 1/237: Dropsonde observations. + + ! 292: SFMR observations. + + ! The following correspond to the specific humidity (q) + ! observations: + + real(r_kind) :: q_doe_a_136, q_doe_b_136 + real(r_kind) :: q_doe_a_137, q_doe_b_137 + + ! The following correspond to the temperature (t) observations: + + real(r_kind) :: t_doe_a_136, t_doe_b_136 + real(r_kind) :: t_doe_a_137, t_doe_b_137 + + ! The following correspond to the wind (uv) observations: + + real(r_kind) :: uv_doe_a_236, uv_doe_b_236 + real(r_kind) :: uv_doe_a_237, uv_doe_b_237 + real(r_kind) :: uv_doe_a_292, uv_doe_b_292 + contains subroutine init_obsmod_dflts @@ -621,6 +703,40 @@ subroutine init_obsmod_dflts integer(i_kind) i + ntilt_radarfiles=1 + vr_dealisingopt=.false. + if_vterminal=.false. + l2rwthin =.false. !Xu + if_vrobs_raw=.false. + if_model_dbz=.true. + inflate_obserr=.false. + whichradar="KKKK" + + oneobradid="KKKK" + doradaroneob=.false. + oneoblat=-999_r_kind + oneoblon=-999_r_kind + oneobddiff=-999_r_kind + oneobvalue=-999_r_kind + oneobheight=-999_r_kind + radar_no_thinning=.false. + ens_hx_dbz_cut=.false. + static_gsi_nopcp_dbz=0.0_r_kind + rmesh_dbz=2 + rmesh_vr=2 + zmesh_dbz=500.0_r_kind + zmesh_vr=500.0_r_kind + minobrangedbz=10000.0_r_kind + maxobrangedbz=200000.0_r_kind + debugmode=.false. + + mintiltdbz=0.0_r_kind + maxtiltdbz=20.0_r_kind + minobrangevr=10000.0_r_kind + maxobrangevr=200000.0_r_kind + mintiltvr=0.0_r_kind + maxtiltvr=20.0_r_kind + missing_to_nopcp=.false. ! Set logical flag perturb_obs = .false. ! .true. = perturb observations @@ -630,10 +746,12 @@ subroutine init_obsmod_dflts write_diag(i)=.false. end do write_diag(1)=.true. + diag_radardbz = .false. reduce_diag = .false. use_limit = -1 lobsdiagsave=.false. lobsdiag_allocated=.false. + lobsdiag_forenkf = .false. lobskeep=.false. nobskeep=0 lsaveobsens=.false. @@ -687,6 +805,10 @@ subroutine init_obsmod_dflts iout_cldch=232 ! cloud ceiling height iout_uwnd10m=233 ! 10-m uwnd iout_vwnd10m=234 ! 10-m vwnd + iout_swcp=235 ! solid-water content path + iout_lwcp=236 ! liquid-water content path + iout_light=237 ! lightning + iout_dbz=238 ! radar reflectivity mype_ps = npe-1 ! surface pressure mype_t = max(0,npe-2) ! temperature @@ -717,10 +839,15 @@ subroutine init_obsmod_dflts mype_cldch=max(0,npe-27) ! cloud ceiling height mype_uwnd10m= max(0,npe-28)! uwnd10m mype_vwnd10m= max(0,npe-29)! vwnd10m + mype_swcp=max(0,npe-30) ! solid-water content path + mype_lwcp=max(0,npe-31) ! liquid-water content path + mype_light=max(0,npe-32)! GOES/GLM lightning + mype_dbz=max(0,npe-33) ! radar reflectivity ! Initialize arrays used in namelist obs_input time_window_max = three ! set maximum time window to +/-three hours + time_window_rad = three ! set maximum time window to +/-three hours for radiance ! Other initializations @@ -737,45 +864,6 @@ subroutine init_obsmod_dflts nprof_gps = 0 -! Define a name for obs types - cobstype( i_ps_ob_type) ="surface pressure " ! ps_ob_type - cobstype( i_t_ob_type) ="temperature " ! t_ob_type - cobstype( i_w_ob_type) ="wind " ! w_ob_type - cobstype( i_q_ob_type) ="moisture " ! q_ob_type - cobstype(i_spd_ob_type) ="wind speed " ! spd_ob_type - cobstype( i_rw_ob_type) ="radial wind " ! rw_ob_type - cobstype( i_dw_ob_type) ="doppler wind " ! dw_ob_type - cobstype(i_sst_ob_type) ="sst " ! sst_ob_type - cobstype( i_pw_ob_type) ="precipitable water " ! pw_ob_type - cobstype(i_pcp_ob_type) ="precipitation " ! pcp_ob_type - cobstype( i_oz_ob_type) ="ozone " ! oz_ob_type - cobstype(i_o3l_ob_type) ="level ozone " ! o3l_ob_type - cobstype(i_gps_ob_type) ="gps " ! gps_ob_type - cobstype(i_rad_ob_type) ="radiance " ! rad_ob_type - cobstype(i_tcp_ob_type) ="tcp (tropic cyclone)" ! tcp_ob_type - cobstype(i_lag_ob_type) ="lagrangian tracer " ! lag_ob_type - cobstype(i_colvk_ob_type)="carbon monoxide " ! colvk_ob_type - cobstype( i_aero_ob_type)="aerosol aod " ! aero_ob_type - cobstype(i_aerol_ob_type)="level aero aod " ! aerol_ob_type - cobstype( i_pm2_5_ob_type)="in-situ pm2_5 obs " ! pm2_5_ob_type - cobstype( i_pm10_ob_type)="in-situ pm10 obs " ! pm10_ob_type - cobstype(i_gust_ob_type) ="gust " ! gust_ob_type - cobstype(i_vis_ob_type) ="vis " ! vis_ob_type - cobstype(i_pblh_ob_type) ="pblh " ! pblh_ob_type - cobstype(i_wspd10m_ob_type) ="wspd10m " ! wspd10m_ob_type - cobstype(i_td2m_ob_type) ="td2m " ! td2m_ob_type - cobstype(i_mxtm_ob_type) ="mxtm " ! mxtm_ob_type - cobstype(i_mitm_ob_type) ="mitm " ! mitm_ob_type - cobstype(i_pmsl_ob_type) ="pmsl " ! pmsl_ob_type - cobstype(i_howv_ob_type) ="howv " ! howv_ob_type - cobstype(i_tcamt_ob_type)="tcamt " ! tcamt_ob_type - cobstype(i_lcbas_ob_type)="lcbas " ! lcbas_ob_type - cobstype(i_cldch_ob_type)="cldch " ! cldch_ob_type - cobstype(i_uwnd10m_ob_type) ="uwnd10m " ! uwnd10m_ob_type - cobstype(i_vwnd10m_ob_type) ="vwnd10m " ! vwnd10m_ob_type - - - hilbert_curve=.false. obs_input_common = 'obs_input.common' @@ -787,6 +875,54 @@ subroutine init_obsmod_dflts l_foreaft_thin = .false. luse_obsdiag = .false. +! set default on diag writing + netcdf_diag = .false. ! by default, do not write netcdf_diag + binary_diag = .true. ! by default, do write binary diag + + l_wcp_cwm = .false. ! .true. = use operator that involves cwm + aircraft_recon = .false. ! .true. = use DOE for aircraft data + hurricane_radar = .false. ! .true. = use radar data for hurricane application + + ! The following variable initializations pertain to the + ! coefficients that describe the linear regression fits that are + ! used to define the dynamic observation error (DOE) + ! specifications for all reconnissance observations collected + ! within hurricanes/tropical cyclones; these apply only to the + ! regional forecast models (e.g., HWRF); Henry R. Winterbottom + ! (henry.winterbottom@noaa.gov). + + ! Observation types: + + ! 1/236: HDOB (e.g., flight-level) observations. + + ! 1/237: Dropsonde observations. + + ! 292: SFMR observations. + + ! The following correspond to the specific humidity (q) + ! observations: + + q_doe_a_136 = 1.0_r_kind + q_doe_b_136 = 0.0_r_kind + q_doe_a_137 = 1.0_r_kind + q_doe_b_137 = 0.0_r_kind + + ! The following correspond to the temperature (t) observations: + + t_doe_a_136 = 1.0_r_kind + t_doe_b_136 = 0.0_r_kind + t_doe_a_137 = 1.0_r_kind + t_doe_b_137 = 0.0_r_kind + + ! The following correspond to the wind (uv) observations: + + uv_doe_a_236 = 1.0_r_kind + uv_doe_b_236 = 0.0_r_kind + uv_doe_a_237 = 1.0_r_kind + uv_doe_b_237 = 0.0_r_kind + uv_doe_a_292 = 1.0_r_kind + uv_doe_b_292 = 0.0_r_kind + return end subroutine init_obsmod_dflts @@ -858,7 +994,6 @@ subroutine create_obsmod_vars ! machine: ibm rs/6000 sp ! !$$$ end documentation block - use gsi_4dvar, only: nobs_bins use mpimod, only: mype implicit none @@ -882,12 +1017,6 @@ subroutine create_obsmod_vars allocate (nsat1(ndat),mype_diaghdr(ndat),obs_sub_comm(ndat)) - if(luse_obsdiag)then - ALLOCATE(obsdiags(nobs_type,nobs_bins)) - else - ALLOCATE(obsdiags(0,0)) - endif - return end subroutine create_obsmod_vars @@ -934,6 +1063,16 @@ subroutine init_obsmod_vars(nhr_assim,mype) time_window(ii) = time_window_max limit = .true. endif +! for cris, iasi, atms, regional analysis may want shorter time window + if (index(dtype(ii),'cris') /= 0 .or. index(dtype(ii),'atms') /= 0 .or. & + index(dtype(ii),'iasi') /= 0 ) then + if(time_window(ii)>time_window_rad) then + time_window(ii) = time_window_rad + if (mype==0) write(6,*) 'INIT_OBSMOD_VARS: reset time window for ',dtype(ii),& + ' to ',time_window_rad + endif + endif +! end do if (mype==0 .and. limit) & write(6,*)'INIT_OBSMOD_VARS: reset time window for one or ',& @@ -1008,7 +1147,6 @@ subroutine destroyobs_() implicit none - if (allocated(obscounts)) deallocate(obscounts) if (allocated(nobs_sub)) deallocate(nobs_sub) return @@ -1080,69 +1218,6 @@ real(r_kind) function ran01dom() return end function ran01dom -! ---------------------------------------------------------------------- -subroutine inquire_obsdiags(kiter) -!$$$ subprogram documentation block -! . . . . -! subprogram: inquire_obsdiags -! prgmmr: -! -! abstract: -! -! program history log: -! 2009-08-07 lueken - added subprogram doc block -! -! input argument list: -! kiter -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -implicit none - -integer(i_kind), intent(in ) :: kiter - -real(r_kind) :: sizei, sizer, sizel, sizep, ziter, zsize, ztot -integer(i_kind) :: ii,jj,iobsa(2),iobsb(2) - -! Any better way to determine size or i_kind, r_kind, etc... ? -sizei=four -sizer=8.0_r_kind -sizel=one -sizep=four - -iobsa(:)=0 -do ii=1,size(obsdiags,2) - do jj=1,size(obsdiags,1) - obsptr => obsdiags(jj,ii)%head - do while (associated(obsptr)) - iobsa(1)=iobsa(1)+1 - if (ANY(obsptr%muse(:))) iobsa(2)=iobsa(2)+1 - obsptr => obsptr%next - enddo - enddo -enddo - -call mpi_reduce(iobsa,iobsb,2,mpi_itype,mpi_max,0,mpi_comm_world,ierror) - -if (mype==0) then - ziter=real(kiter,r_kind) - zsize = sizer*(three*ziter+two) + sizei + sizel*(ziter+one) + sizep*five - ztot=real(iobsb(1),r_kind)*zsize - ztot=ztot/(1024.0_r_kind*1024.0_r_kind) - - write(6,*)'obsdiags: Bytes per element=',NINT(zsize) - write(6,*)'obsdiags: length total, used=',iobsb(1),iobsb(2) - write(6,'(A,F8.1,A)')'obsdiags: Estimated memory usage= ',ztot,' Mb' -endif - -end subroutine inquire_obsdiags - ! ---------------------------------------------------------------------- subroutine init_instr_table_ (nhr_assim,nall,iamroot,rcname) !$$$ subprogram documentation block @@ -1172,6 +1247,8 @@ subroutine init_instr_table_ (nhr_assim,nall,iamroot,rcname) use mpeu_util, only: gettable use mpeu_util, only: getindex use gridmod, only: twodvar_regional +use mrmsmod,only: l_mrms_run,mrms_listfile +use mrmsmod,only: load_mrms_data_info implicit none integer(i_kind),intent(in) :: nhr_assim ! number of assimilation hours @@ -1181,13 +1258,17 @@ subroutine init_instr_table_ (nhr_assim,nall,iamroot,rcname) character(len=*),parameter::myname_=myname//'*init_instr_table_' character(len=*),parameter:: tbname='OBS_INPUT::' -integer(i_kind) luin,ii,ntot,nrows +integer(i_kind) luin,ii,ntot,nrows,luin_mrms character(len=256),allocatable,dimension(:):: utable logical iamroot_ +integer (i_kind)::nrows0 +integer(i_kind) ntot_mrms,nrows_mrms nall=0 if(obs_instr_initialized_) return +inquire(file=trim(mrms_listfile), exist=l_mrms_run) + iamroot_=mype==0 if(present(iamroot)) iamroot_=iamroot @@ -1204,7 +1285,17 @@ subroutine init_instr_table_ (nhr_assim,nall,iamroot,rcname) call gettablesize(tbname,luin,ntot,nrows) if(nrows==0) then if(luin/=5) close(luin) - return + if (.not.l_mrms_run) return +endif + +nrows0=nrows +if (l_mrms_run) then ! a run with radar ref data from MRMS + luin_mrms=get_lun() + open(luin_mrms,file=trim(mrms_listfile),form='formatted') + call gettablesize(mrms_listfile,luin_mrms,ntot_mrms,nrows_mrms) + nrows0=nrows + nrows=nrows+nrows_mrms + if(luin_mrms/=5) close(luin_mrms ) endif ! Get contents of table @@ -1232,14 +1323,14 @@ subroutine init_instr_table_ (nhr_assim,nall,iamroot,rcname) ! Retrieve each token of interest from table and define ! variables participating in state vector dval_use = .false. -do ii=1,nrows - read(utable(ii),*) dfile(ii),& ! local file name from which to read observatinal data - dtype(ii),& ! character string identifying type of observatio - dplat(ii),& ! currently contains satellite id (no meaning for non-sat data) - dsis(ii), & ! sensor/instrument/satellite identifier for info files - dval(ii), & ! - dthin(ii),& ! thinning flag (1=thinning on; otherwise off) - dsfcalc(ii) ! use orig bilinear FOV surface calculation (routine deter_sfc) +do ii=1,nrows0 + read(utable(ii),*) dfile(ii),& ! local file name from which to read observatinal data + dtype(ii),& ! character string identifying type of observatio + dplat(ii),& ! currently contains satellite id (no meaning for non-sat data) + dsis(ii), & ! sensor/instrument/satellite identifier for info files + dval(ii), & ! + dthin(ii),& ! thinning flag (1=thinning on; otherwise off) + dsfcalc(ii) ! use orig bilinear FOV surface calculation (routine deter_sfc) ! The following is to sort out some historical naming conventions select case (dsis(ii)(1:4)) @@ -1262,6 +1353,14 @@ subroutine init_instr_table_ (nhr_assim,nall,iamroot,rcname) deallocate(utable) +if (l_mrms_run) then + if(present(rcname)) then + call load_mrms_data_info(mrms_listfile,nrows0,ntot_mrms,nrows_mrms,nrows,obsfile_all,dfile,dtype,ditype,dplat,dsis,dval,dthin,ipoint,dsfcalc,time_window,rcname) + else + call load_mrms_data_info(mrms_listfile,nrows0,ntot_mrms,nrows_mrms,nrows,obsfile_all,dfile,dtype,ditype,dplat,dsis,dval,dthin,ipoint,dsfcalc,time_window) + endif +endif + obs_instr_initialized_=.true. end subroutine init_instr_table_ diff --git a/src/omegas_ad.f90 b/src/gsi/omegas_ad.f90 similarity index 100% rename from src/omegas_ad.f90 rename to src/gsi/omegas_ad.f90 diff --git a/src/oneobmod.F90 b/src/gsi/oneobmod.F90 similarity index 100% rename from src/oneobmod.F90 rename to src/gsi/oneobmod.F90 diff --git a/src/ozinfo.f90 b/src/gsi/ozinfo.f90 similarity index 100% rename from src/ozinfo.f90 rename to src/gsi/ozinfo.f90 diff --git a/src/patch2grid_mod.f90 b/src/gsi/patch2grid_mod.f90 similarity index 100% rename from src/patch2grid_mod.f90 rename to src/gsi/patch2grid_mod.f90 diff --git a/src/pcgsoi.f90 b/src/gsi/pcgsoi.f90 similarity index 90% rename from src/pcgsoi.f90 rename to src/gsi/pcgsoi.f90 index 918172952..414c8498a 100644 --- a/src/pcgsoi.f90 +++ b/src/gsi/pcgsoi.f90 @@ -13,8 +13,9 @@ module pcgsoimod ! 2008-11-26 Todling - remove pcgsoi_tl ! 2009-08-12 lueken - update documentation ! 2009-09-17 parrish - add bkerror_a_en and anbkerror_reg_a_en for hybrid ensemble control variable a_en -! 2014-12-03 derber - thread dot products and modify so obsdiag can be turned -! off +! 2014-12-03 derber - thread dot products and modify so obsdiag can be turned off +! 2018-08-10 guo - removed m_obsHeadBundle references +! - replaced stpjo_setup() with a new stpjomod::stpjo_setup() ! ! subroutines included: ! sub pcgsoi @@ -157,11 +158,9 @@ subroutine pcgsoi() use gsi_4dcouplermod, only : gsi_4dcoupler_grtests use rapidrefresh_cldsurf_mod, only: i_gsdcldanal_type use gsi_io, only: verbose + use berror, only: vprecond use stpjomod, only: stpjo_setup - use m_obsHeadBundle, only: obsHeadBundle - use m_obsHeadBundle, only: obsHeadBundle_create - use m_obsHeadBundle, only: obsHeadBundle_destroy implicit none ! Declare passed variables @@ -178,11 +177,11 @@ subroutine pcgsoi() real(r_double) pennorm real(r_quad) zjo real(r_quad) :: zdla - real(r_quad),dimension(3):: dprod - real(r_kind),dimension(2):: gnorm + real(r_quad),dimension(4):: dprod + real(r_kind),dimension(3):: gnorm real(r_kind) :: zgini,zfini,fjcost(4),fjcostnew(4),zgend,zfend real(r_kind) :: fjcost_e - type(control_vector) :: xhat,gradx,grady,dirx,diry,dirw,ydiff,xdiff + type(control_vector) :: xhat,gradx,grady,dirx,diry,ydiff,xdiff type(gsi_bundle) :: sval(nobs_bins), rval(nobs_bins) type(gsi_bundle) :: eval(ntlevs_ens) type(gsi_bundle) :: mval(nsubwin) @@ -190,7 +189,6 @@ subroutine pcgsoi() type(control_vector), allocatable, dimension(:) :: cglwork type(control_vector), allocatable, dimension(:) :: cglworkhat - type(obsHeadBundle),pointer,dimension(:):: yobs integer(i_kind) :: iortho logical :: print_verbose logical:: lanlerr @@ -233,14 +231,12 @@ subroutine pcgsoi() lanlerr=.false. if ( twodvar_regional .and. jiter==1 ) lanlerr=.true. ! Allocate required memory and initialize fields - call init_(lanlerr) + call init_ if(print_diag_pcg)call prt_guess('guess') if ( lanlerr .and. lgschmidt ) call init_mgram_schmidt nlnqc_iter=.false. - call obsHeadBundle_create(yobs,nobs_bins) - call stpjo_setup(yobs) - call obsHeadBundle_destroy(yobs) + call stpjo_setup(nobs_bins) if(iorthomax>0) then allocate(cglwork(iorthomax+1)) @@ -404,43 +400,66 @@ subroutine pcgsoi() end if end if -! Add potential additional preconditioner - if(diag_precon)call precond(grady) - if (iter==0 .and. print_diag_pcg) then call prt_control_norms(grady,'grady') endif - if (iter>0) gsave=gnorm(1) - b=zero ! Calculate new norm of gradients - if (lanlerr) then - dprod(1) = qdot_prod_sub(gradx,grady) - call mpl_allreduce(1,qpvals=dprod) - gnorm(1)=dprod(1) - gnorm(2)=gnorm(1) + if (iter>0) gsave=gnorm(3) + dprod(1) = qdot_prod_sub(gradx,grady) + if(diag_precon)then + if (lanlerr) then +! xdiff used as a temporary array + do i=1,nclen + xdiff%values(i)=vprecond(i)*gradx%values(i) + end do + dprod(2) = qdot_prod_sub(xdiff,grady) + call mpl_allreduce(2,qpvals=dprod) + gnorm(2)=dprod(2) + gnorm(3)=dprod(2) + else + do i=1,nclen + xdiff%values(i)=vprecond(i)*(gradx%values(i)-xdiff%values(i)) + ydiff%values(i)=vprecond(i)*(grady%values(i)-ydiff%values(i)) + end do + dprod(2) = qdot_prod_sub(xdiff,grady) + dprod(3) = qdot_prod_sub(ydiff,gradx) +! xdiff used as a temporary array + do i=1,nclen + xdiff%values(i)=vprecond(i)*gradx%values(i) + end do + dprod(4) = qdot_prod_sub(xdiff,grady) + call mpl_allreduce(4,qpvals=dprod) +! Two dot products in gnorm(2) should be same, but are slightly +! different due to round off, so use average. + gnorm(2)=0.5_r_quad*(dprod(2)+dprod(3)) + gnorm(3)=dprod(4) + end if else - do i=1,nclen - xdiff%values(i)=gradx%values(i)-xdiff%values(i) - ydiff%values(i)=grady%values(i)-ydiff%values(i) - end do - dprod(1) = qdot_prod_sub(gradx,grady) - dprod(2) = qdot_prod_sub(xdiff,grady) - dprod(3) = qdot_prod_sub(ydiff,gradx) - call mpl_allreduce(3,qpvals=dprod) - gnorm(1)=dprod(1) - -! Two dot products in gnorm(2) should be same, but are slightly -! different due to round-off so use average. - gnorm(2)=0.5_r_quad*(dprod(2)+dprod(3)) - do i=1,nclen - xdiff%values(i)=gradx%values(i) - ydiff%values(i)=grady%values(i) - end do + if (lanlerr) then + call mpl_allreduce(1,qpvals=dprod) + gnorm(2)=dprod(1) + gnorm(3)=dprod(1) + else + do i=1,nclen + xdiff%values(i)=gradx%values(i)-xdiff%values(i) + ydiff%values(i)=grady%values(i)-ydiff%values(i) + end do + dprod(2) = qdot_prod_sub(xdiff,grady) + dprod(3) = qdot_prod_sub(ydiff,gradx) + call mpl_allreduce(3,qpvals=dprod) +! Two dot products in gnorm(2) should be same, but are slightly +! different due to round off, so use average. + gnorm(2)=0.5_r_quad*(dprod(2)+dprod(3)) + gnorm(3)=dprod(1) + end if end if - if(mype == 0)write(iout_iter,*)'Minimization iteration',iter + gnorm(1)=dprod(1) + + b=zero if (gsave>1.e-16_r_kind .and. iter>0) b=gnorm(2)/gsave + if(mype == 0)write(iout_iter,*)'Minimization iteration',iter if (bfive) then if (mype==0) then if (iout_6) write(6,105) gnorm(2),gsave,b @@ -448,33 +467,35 @@ subroutine pcgsoi() endif b=zero endif - if (mype==0 .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:2),b=',gnorm,b + if (mype==0 .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:3),b=',gnorm,b ! Calculate new search direction if (.not. restart) then - if(diag_precon)then - do i=1,nclen - diry%values(i)=dirw%values(i) - end do + if(.not. lanlerr)then + do i=1,nclen + xdiff%values(i)=gradx%values(i) + ydiff%values(i)=grady%values(i) + end do end if - do i=1,nclen - dirx%values(i)=-grady%values(i)+b*dirx%values(i) - diry%values(i)=-gradx%values(i)+b*diry%values(i) - end do if(diag_precon)then - do i=1,nclen - dirw%values(i)=diry%values(i) - end do - call precond(diry) + do i=1,nclen + dirx%values(i)=-vprecond(i)*grady%values(i)+b*dirx%values(i) + diry%values(i)=-vprecond(i)*gradx%values(i)+b*diry%values(i) + end do + else + do i=1,nclen + dirx%values(i)=-grady%values(i)+b*dirx%values(i) + diry%values(i)=-gradx%values(i)+b*diry%values(i) + end do end if else ! If previous solution available, transfer into local arrays. - call read_guess_solution(dirx,diry,mype) - stp=one - if(.not. lanlerr)then + if( .not. lanlerr)then xdiff=zero ydiff=zero end if + call read_guess_solution(dirx,diry,mype) + stp=one endif ! Convert search direction from control space to physical space @@ -624,7 +645,7 @@ subroutine pcgsoi() call penal(sval(1)) xhatsave=zero yhatsave=zero - call clean_(lanlerr) + call clean_ return endif @@ -711,10 +732,6 @@ subroutine pcgsoi() end if -! Add potential additional preconditioner - if(diag_precon)call precond(grady) - - ! Print final Jo table zgend=dot_product(gradx,grady,r_quad) ! nprt=2 @@ -815,7 +832,7 @@ subroutine pcgsoi() call xhat_vordiv_clean ! Clean up major fields - call clean_(lanlerr) + call clean_ ! Finalize timer call timer_fnl('pcgsoi') @@ -825,7 +842,7 @@ subroutine pcgsoi() contains -subroutine init_(lanlerr) +subroutine init_ !$$$ subprogram documentation block ! . . . . ! subprogram: init_ initialize pcgsoi @@ -848,7 +865,6 @@ subroutine init_(lanlerr) use jfunc, only: diag_precon implicit none - logical,intent(in):: lanlerr ! Allocate local variables call allocate_cv(xhat) @@ -856,13 +872,8 @@ subroutine init_(lanlerr) call allocate_cv(grady) call allocate_cv(dirx) call allocate_cv(diry) - if(diag_precon)call allocate_cv(dirw) - if(.not. lanlerr)then - call allocate_cv(ydiff) - call allocate_cv(xdiff) - ydiff=zero - xdiff=zero - end if + call allocate_cv(ydiff) + call allocate_cv(xdiff) do ii=1,nobs_bins call allocate_state(sval(ii)) call allocate_state(rval(ii)) @@ -881,13 +892,14 @@ subroutine init_(lanlerr) grady=zero dirx=zero diry=zero - if(diag_precon)dirw=zero + ydiff=zero + xdiff=zero xhat=zero end subroutine init_ -subroutine clean_(lanlerr) +subroutine clean_ !$$$ subprogram documentation block ! . . . . ! subprogram: clean_ clean pcgsoi @@ -912,7 +924,6 @@ subroutine clean_(lanlerr) use m_obsdiags, only: obsdiags_reset use obsmod, only: destroyobs,lobsdiagsave implicit none - logical,intent(in):: lanlerr ! Deallocate obs file if (.not.l4dvar) call destroyobs() ! phasing out, by gradually reducing its funtionality @@ -924,11 +935,8 @@ subroutine clean_(lanlerr) call deallocate_cv(grady) call deallocate_cv(dirx) call deallocate_cv(diry) - if(diag_precon)call deallocate_cv(dirw) - if(.not. lanlerr)then - call deallocate_cv(ydiff) - call deallocate_cv(xdiff) - end if + call deallocate_cv(ydiff) + call deallocate_cv(xdiff) ! Release bias-predictor memory call deallocate_preds(sbias) diff --git a/src/pcgsqrt.f90 b/src/gsi/pcgsqrt.f90 similarity index 100% rename from src/pcgsqrt.f90 rename to src/gsi/pcgsqrt.f90 diff --git a/src/pcp_k.f90 b/src/gsi/pcp_k.f90 similarity index 100% rename from src/pcp_k.f90 rename to src/gsi/pcp_k.f90 diff --git a/src/pcpinfo.f90 b/src/gsi/pcpinfo.f90 similarity index 100% rename from src/pcpinfo.f90 rename to src/gsi/pcpinfo.f90 diff --git a/src/gsi/penal.f90 b/src/gsi/penal.f90 new file mode 100644 index 000000000..4f68f7226 --- /dev/null +++ b/src/gsi/penal.f90 @@ -0,0 +1,442 @@ +subroutine penal(xhat) +!$$$ subprogram documentation block +! . . . . +! subprogram: penal oberror tuning +! prgmmr: wu org: np23 date: 2005-08-26 +! +! abstract: randomized estimation of Tr(KH) and Tr(HK) and +! adaptive tuning +! +! +! program history log: +! 2005-08-15 wu - oberror tuning +! 2008-03-24 wu - use convinfo ikx as index for oberr tune +! 2008-05-27 safford - rm unused vars +! 2008-12-03 todling - update in light of state vector and obs binning +! 2010-05-13 todling - update to use gsi_bundle +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2018-10-02 wu - re-arrange dimensions since subtypes are used in convinfo but not in errtable +! select height dependent (or not) base on amount of the observation +! sfc obs tuning is not height dependent +! put back code to calculate tuning corf's and write out the new errtable +! +! usage: intt(st,rt) +! input argument list: +! xhat - increment in grid space +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_single,r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,mpi_sum,mpi_rtype,mype + use constants, only: zero,one + use gsi_4dvar, only: nobs_bins + use m_obsNode, only: obsNode + use m_qNode , only: qNode, qNode_typecast, qNode_nextcast + use m_tNode , only: tNode, tNode_typecast, tNode_nextcast + use m_wNode , only: wNode, wNode_typecast, wNode_nextcast + use m_psNode, only: psNode,psNode_typecast,psNode_nextcast + use m_obsdiags, only: obOper_headNode + use gsi_obOperTypeManager, only: iobOper_q + use gsi_obOperTypeManager, only: iobOper_t + use gsi_obOperTypeManager, only: iobOper_w + use gsi_obOperTypeManager, only: iobOper_ps + + use converr, only:etabl + use jfunc, only: jiterstart,jiter + use convinfo, only: ictype + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + implicit none + +! Declare passed variables + + type(gsi_bundle),intent(in ) :: xhat + +! Declare passed variables + integer(i_kind), parameter :: ld=300 + integer(i_kind), parameter :: np=33 + integer(i_kind), parameter :: nv=4 + + real(r_kind),save,dimension(np,ld,nv) :: penalty,trace + +! Declare local variables + real(r_kind) err2 + + integer(i_kind) i,n,k,ibin,ier,istatus + real(r_kind) tpenalty(np,ld,nv),ttrace(np,ld,nv) + real(r_kind) valu,valv,val,so(np,ld,nv),sosum + integer(i_kind) itype,ncat,k1,m,l + real(r_kind) cat_num(np,ld,nv),tcat_num(np,ld,nv),cat_numt(ld,nv) + real(r_kind),pointer,dimension(:):: xhat_u,xhat_v,xhat_q,xhat_t,xhat_p + character(2) obtype(nv) + + type( qNode),pointer:: qptr + type( tNode),pointer:: tptr + type( wNode),pointer:: wptr + type(psNode),pointer:: psptr + +! Get pointers and return if not found + obtype(1)='ps' + obtype(2)='t ' + obtype(3)='q ' + obtype(4)='uv' + ier=0 + call gsi_bundlegetpointer(xhat,'u' ,xhat_u,istatus);ier=istatus+ier + call gsi_bundlegetpointer(xhat,'v' ,xhat_v,istatus);ier=istatus+ier + call gsi_bundlegetpointer(xhat,'q' ,xhat_q,istatus);ier=istatus+ier + call gsi_bundlegetpointer(xhat,'tv',xhat_t,istatus);ier=istatus+ier + call gsi_bundlegetpointer(xhat,'ps',xhat_p,istatus);ier=istatus+ier + if(ier/=0) return + + ncat=np*ld*nv + + if(jiter==jiterstart)then + trace=zero + penalty=zero + + do ibin=1,nobs_bins + +! Moisture + !!qptr => qNode_typecast(obsLList_headNode(qhead(ibin))) + !anode => obsLList_headNode(qhead(ibin)) + !qptr => qNode_typecast(anode) + !anode => null() + qptr => qNode_typecast(obOper_headNode(iobOper_q,ibin)) + m=3 + do while (associated(qptr)) + n=qptr%kx + itype=ictype(n) + n=itype + + if(itype > 179)then + k1=1 + else + k1=qptr%k1 + endif + + err2=qptr%raterr2*qptr%err2 +! Forward model + val= qptr%wij(1)* xhat_q(qptr%ij(1))+qptr%wij(2)* xhat_q(qptr%ij(2))& + +qptr%wij(3)* xhat_q(qptr%ij(3))+qptr%wij(4)* xhat_q(qptr%ij(4))& + +qptr%wij(5)* xhat_q(qptr%ij(5))+qptr%wij(6)* xhat_q(qptr%ij(6))& + +qptr%wij(7)* xhat_q(qptr%ij(7))+qptr%wij(8)* xhat_q(qptr%ij(8)) + + trace(k1,n,m)=trace(k1,n,m)-qptr%qpertb*val*err2 + penalty(k1,n,m)=penalty(k1,n,m)+(val-qptr%res)**2*err2 + qptr => qNode_nextcast(qptr) + end do + +! Temperature + !!tptr => tNode_typecast(obsLList_headNode(thead(ibin))) + !anode => obsLList_headNode(thead(ibin)) + !tptr => tNode_typecast(anode) + !anode => null() + tptr => tNode_typecast(obOper_headNode(iobOper_t,ibin)) + m=2 + do while (associated(tptr)) + n=tptr%kx + itype=ictype(n) + n=itype + + if(itype > 179)then + k1=1 + else + k1=tptr%k1 + endif + + err2=tptr%raterr2*tptr%err2 +! Forward model + val= tptr%wij(1)* xhat_t(tptr%ij(1))+tptr%wij(2)* xhat_t(tptr%ij(2))& + +tptr%wij(3)* xhat_t(tptr%ij(3))+tptr%wij(4)* xhat_t(tptr%ij(4))& + +tptr%wij(5)* xhat_t(tptr%ij(5))+tptr%wij(6)* xhat_t(tptr%ij(6))& + +tptr%wij(7)* xhat_t(tptr%ij(7))+tptr%wij(8)* xhat_t(tptr%ij(8)) + + trace(k1,n,m)=trace(k1,n,m)-tptr%tpertb*val*err2 + penalty(k1,n,m)=penalty(k1,n,m)+(val-tptr%res)**2*err2 + tptr => tNode_nextcast(tptr) + end do + +! Surface pressure + !!psptr => psNode_typecast(obsLList_headNode(pshead(ibin))) + !anode => obsLList_headNode(pshead(ibin)) + !psptr => psNode_typecast(anode) + !anode => null() + psptr => psNode_typecast(obOper_headNode(iobOper_ps,ibin)) + m=1 + do while (associated(psptr)) + n=psptr%kx + itype=ictype(n) + k1=1 + n=itype + + err2=psptr%raterr2*psptr%err2 +! Forward model + val= psptr%wij(1)* xhat_p(psptr%ij(1))+psptr%wij(2)* xhat_p(psptr%ij(2))& + +psptr%wij(3)* xhat_p(psptr%ij(3))+psptr%wij(4)* xhat_p(psptr%ij(4)) + + trace(k1,n,m)=trace(k1,n,m)-psptr%ppertb*val*err2 + penalty(k1,n,m)=penalty(k1,n,m)+(val-psptr%res)**2*err2 + psptr => psNode_nextcast(psptr) + end do + +! Winds + !!wptr => wNode_typecast(obsLList_headNode(whead(ibin))) + !anode => obsLList_headNode(whead(ibin)) + !wptr => wNode_typecast(anode) + !anode => null() + wptr => wNode_typecast(obOper_headNode(iobOper_w,ibin)) + m=4 + do while (associated(wptr)) + n=wptr%kx + itype=ictype(n) + n=itype + + if(itype > 279)then + k1=1 + else + k1=wptr%k1 + endif + + err2=wptr%raterr2*wptr%err2 +! Forward model + valu= wptr%wij(1)* xhat_u(wptr%ij(1))+wptr%wij(2)* xhat_u(wptr%ij(2))& + +wptr%wij(3)* xhat_u(wptr%ij(3))+wptr%wij(4)* xhat_u(wptr%ij(4))& + +wptr%wij(5)* xhat_u(wptr%ij(5))+wptr%wij(6)* xhat_u(wptr%ij(6))& + +wptr%wij(7)* xhat_u(wptr%ij(7))+wptr%wij(8)* xhat_u(wptr%ij(8)) + valv= wptr%wij(1)* xhat_v(wptr%ij(1))+wptr%wij(2)* xhat_v(wptr%ij(2))& + +wptr%wij(3)* xhat_v(wptr%ij(3))+wptr%wij(4)* xhat_v(wptr%ij(4))& + +wptr%wij(5)* xhat_v(wptr%ij(5))+wptr%wij(6)* xhat_v(wptr%ij(6))& + +wptr%wij(7)* xhat_v(wptr%ij(7))+wptr%wij(8)* xhat_v(wptr%ij(8)) + + trace(k1,n,m)=trace(k1,n,m)-(wptr%upertb*valu+wptr%vpertb*valv)*err2 + penalty(k1,n,m)=penalty(k1,n,m)+((valu-wptr%ures)**2+(valv-wptr%vres)**2)*err2 + wptr => wNode_nextcast(wptr) + end do + + end do ! ibin + + else ! jiter + cat_num=zero + + do ibin=1,nobs_bins + +! Moisture +! ratiomin=one + !!qptr => qNode_typecast(obsLList_headNode(qhead(ibin))) + !anode => obsLList_headNode(qhead(ibin)) + !qptr => qNode_typecast(anode) + !anode => null() + qptr => qNode_typecast(obOper_headNode(iobOper_q,ibin)) + m=3 + do while (associated(qptr)) + n=qptr%kx + itype=ictype(n) + n=itype + + if(itype > 179)then + k1=1 + else + k1=qptr%k1 + endif + + err2=qptr%raterr2*qptr%err2 +! Forward model + val= qptr%wij(1)* xhat_q(qptr%ij(1))+qptr%wij(2)* xhat_q(qptr%ij(2))& + +qptr%wij(3)* xhat_q(qptr%ij(3))+qptr%wij(4)* xhat_q(qptr%ij(4))& + +qptr%wij(5)* xhat_q(qptr%ij(5))+qptr%wij(6)* xhat_q(qptr%ij(6))& + +qptr%wij(7)* xhat_q(qptr%ij(7))+qptr%wij(8)* xhat_q(qptr%ij(8)) + + cat_num(k1,n,m)=cat_num(k1,n,m)+one + trace(k1,n,m)=trace(k1,n,m)+qptr%qpertb*val*err2 + qptr => qNode_nextcast(qptr) + end do + +! Temperature + !!tptr => tNode_typecast(obsLList_headNode(thead(ibin))) + !anode => obsLList_headNode(thead(ibin)) + !tptr => tNode_typecast(anode) + !anode => null() + tptr => tNode_typecast(obOper_headNode(iobOper_t,ibin)) + m=2 + do while (associated(tptr)) + n=tptr%kx + itype=ictype(n) + n=itype + + if(itype>179 )then + k1=1 + else + k1=tptr%k1 + endif + + err2=tptr%raterr2*tptr%err2 +! Forward model + val= tptr%wij(1)* xhat_t(tptr%ij(1))+tptr%wij(2)* xhat_t(tptr%ij(2))& + +tptr%wij(3)* xhat_t(tptr%ij(3))+tptr%wij(4)* xhat_t(tptr%ij(4))& + +tptr%wij(5)* xhat_t(tptr%ij(5))+tptr%wij(6)* xhat_t(tptr%ij(6))& + +tptr%wij(7)* xhat_t(tptr%ij(7))+tptr%wij(8)* xhat_t(tptr%ij(8)) + + cat_num(k1,n,m)=cat_num(k1,n,m)+one + trace(k1,n,m)=trace(k1,n,m)+tptr%tpertb*val*err2 + tptr => tNode_nextcast(tptr) + end do + +! Surface pressure + !!psptr => psNode_typecast(obsLList_headNode(pshead(ibin))) + !anode => obsLList_headNode(pshead(ibin)) + !psptr => psNode_typecast(anode) + !anode => null() + psptr => psNode_typecast(obOper_headNode(iobOper_ps,ibin)) + m=1 + do while (associated(psptr)) + n=psptr%kx + itype=ictype(n) + k1=1 + n=itype + + err2=psptr%raterr2*psptr%err2 +! Forward model + val= psptr%wij(1)* xhat_p(psptr%ij(1))+psptr%wij(2)* xhat_p(psptr%ij(2))& + +psptr%wij(3)* xhat_p(psptr%ij(3))+psptr%wij(4)* xhat_p(psptr%ij(4)) + + cat_num(k1,n,m)=cat_num(k1,n,m)+one + trace(k1,n,m)=trace(k1,n,m)+psptr%ppertb*val*err2 + psptr => psNode_nextcast(psptr) + end do +! Winds + !!wptr => wNode_typecast(obsLList_headNode(whead(ibin))) + !anode => obsLList_headNode(whead(ibin)) + !wptr => wNode_typecast(anode) + !anode => null() + wptr => wNode_typecast(obOper_headNode(iobOper_w,ibin)) + m=4 + do while (associated(wptr)) + n=wptr%kx + itype=ictype(n) + n=itype + + if(itype > 279)then + k1=1 + else + k1=wptr%k1 + endif + + err2=wptr%raterr2*wptr%err2 +! Forward model + valu= wptr%wij(1)* xhat_u(wptr%ij(1))+wptr%wij(2)* xhat_u(wptr%ij(2))& + +wptr%wij(3)* xhat_u(wptr%ij(3))+wptr%wij(4)* xhat_u(wptr%ij(4))& + +wptr%wij(5)* xhat_u(wptr%ij(5))+wptr%wij(6)* xhat_u(wptr%ij(6))& + +wptr%wij(7)* xhat_u(wptr%ij(7))+wptr%wij(8)* xhat_u(wptr%ij(8)) + valv= wptr%wij(1)* xhat_v(wptr%ij(1))+wptr%wij(2)* xhat_v(wptr%ij(2))& + +wptr%wij(3)* xhat_v(wptr%ij(3))+wptr%wij(4)* xhat_v(wptr%ij(4))& + +wptr%wij(5)* xhat_v(wptr%ij(5))+wptr%wij(6)* xhat_v(wptr%ij(6))& + +wptr%wij(7)* xhat_v(wptr%ij(7))+wptr%wij(8)* xhat_v(wptr%ij(8)) + + cat_num(k1,n,m)=cat_num(k1,n,m)+one + trace(k1,n,m)=trace(k1,n,m)+(wptr%upertb*valu+wptr%vpertb*valv)*err2 + wptr => wNode_nextcast(wptr) + end do + + do m=1,nv + do n=100,299 + do k=1,np + trace(k,n,m)=cat_num(k,n,m)-trace(k,n,m) + enddo + enddo + enddo + + end do ! ibin + call mpi_reduce(trace,ttrace,size(trace),mpi_rtype,mpi_sum,0, & + mpi_comm_world,ierror) + call mpi_reduce(penalty,tpenalty,size(penalty),mpi_rtype,mpi_sum,0, & + mpi_comm_world,ierror) + call mpi_reduce(cat_num,tcat_num,size(cat_num),mpi_rtype,mpi_sum,0, & + mpi_comm_world,ierror) + + if(mype==0)then + cat_numt=zero + do m=1,nv + do i=100,299 + do k=1,np + cat_numt(i,m)=cat_numt(i,m)+tcat_num(k,i,m) + enddo + enddo + enddo + + so=one + do m=1,nv + do n=100,299 + if(cat_numt(n,m)>zero)then + write(333,*)'obs type=',n,obtype(m) + do k=1,np + if(tcat_num(k,n,m)>3._r_kind .and. ttrace(k,n,m) /= zero )then + write(333,*)k,tpenalty(k,n,m),ttrace(k,n,m),int(tcat_num(k,n,m)) + so(k,n,m)=tpenalty(k,n,m)/ttrace(k,n,m) + if(so(k,n,m) >= zero) then + so(k,n,m)=sqrt(so(k,n,m)) + write(334,*)k,n,obtype(m),so(k,n,m),int(tcat_num(k,n,m)) + endif + endif + enddo + endif + enddo + enddo + + sosum=zero + do i=1,ncat + sosum=sosum+(so(i,1,1)-one)**2 + enddo + write(335,*)'sosum=',sosum + +! Update etabl + do l=100,299 + do n=1,nv + m=n + if(n==1)m=5 + if(cat_numt(l,n)>zero)then + if( (m==3 .and. l<180 ) .or. & + (m==2 .and. l<180 ) .or. & + (m==4 .and. l<280 ) ) then + write(335,*)l,obtype(n),'33',cat_numt(l,n) + do k=1,np + if( etabl(l,k,m) < 1.e8_r_single) etabl(l,k,m)=etabl(l,k,m)*so(k,l,n) + end do + else + write(335,*)l,obtype(n),'1',cat_numt(l,n) + do k=1,np + if( etabl(l,k,m) < 1.e8_r_single) etabl(l,k,m)=etabl(l,k,m)*so(1,l,n) + end do + endif + endif + enddo + enddo + +! Write out err table + open(59,file='errtable_out',form='formatted') + rewind 59 + do l=100,299 + if(etabl(l,1,1)==1100._r_single)then + write(59,100)l + do k=1,np + write(59,110)(etabl(l,k,i),i=1,6) + end do + endif ! etable1=1100 + end do + close(59) + + endif ! mype + + call mpi_finalize(ierror) + stop + endif ! jiter + +100 format(1x,i3,' OBSERVATION TYPE') +110 format(1x,6e12.5) + + return +end subroutine penal diff --git a/src/phil.f90 b/src/gsi/phil.f90 similarity index 100% rename from src/phil.f90 rename to src/gsi/phil.f90 diff --git a/src/phil1.f90 b/src/gsi/phil1.f90 similarity index 100% rename from src/phil1.f90 rename to src/gsi/phil1.f90 diff --git a/src/plib8.f90 b/src/gsi/plib8.f90 similarity index 99% rename from src/plib8.f90 rename to src/gsi/plib8.f90 index 764a7e3b3..2b87e498d 100644 --- a/src/plib8.f90 +++ b/src/gsi/plib8.f90 @@ -8291,7 +8291,7 @@ subroutine jfit(ng,ig1,igm,ns,iw,cofg,dsdg,dhdg,cofs,ins1,wts) ! s- and g-grids are the ones NOT staggered wrt the domain boundaries.) !---------------------------------------------------------------------------- ie=ig0 -do i=is0+1,ism-1 ! Loop over s-grid target points interior to this segment +iloop: do i=is0+1,ism-1 ! Loop over s-grid target points interior to this segment et=i !---------------------------------------------------------------------------- ! Find the g-grid interval containing this target: @@ -8312,16 +8312,19 @@ subroutine jfit(ng,ig1,igm,ns,iw,cofg,dsdg,dhdg,cofs,ins1,wts) destar=dot_product(dwt,sofg(ie1:ien)) ! <- d(estar)/dg. dr=-estar/destar ! <- Newton correction to r r=r+dr ! <- Refined estimate, r - if(abs(dr) <= rcrit)goto 1 ! <- Converged enough yet? + if(abs(dr) <= rcrit)then ! <- Converged enough yet? + wt=wt+dr*dwt ! <- Final refinement to wt + cofs(i)=dot_product(wt, cofg(ie1:ien)) ! <- Interpolate c(s) + cycle iloop + end if enddo ! stop 'Too many Newton iterations' ! <- It never convergenced! write(6,*)' Too many Newton iterations' ! <- It never convergenced! ns=-1 return -1 wt=wt+dr*dwt ! <- Final refinement to wt - cofs(i)=dot_product(wt, cofg(ie1:ien)) ! <- Interpolate c(s) -enddo +enddo iloop cofs(ism)=cofg(igm) ! <- End value directly +return end subroutine jfit diff --git a/src/polcarf.f90 b/src/gsi/polcarf.f90 similarity index 97% rename from src/polcarf.f90 rename to src/gsi/polcarf.f90 index 595fe232f..4ed450daa 100644 --- a/src/polcarf.f90 +++ b/src/gsi/polcarf.f90 @@ -271,7 +271,10 @@ subroutine setwtt(wtaxt,wtbat,inaxt,inbat,rs,df,qr,nxe,nxg,mrr,nrr,mf,nf,nor) real(r_kind),dimension(20):: dw real(r_kind),dimension(0:20):: ys,qy - if(mod(nor,2)/=0.or.nor<=0)goto 803 + if(mod(nor,2)/=0.or.nor<=0)then + write(6,*)'invalid nor in setwtt; must be even and at least 2' + return + end if piq=quarter*pi dx=piq/nxe dxi=one/dx @@ -293,29 +296,37 @@ subroutine setwtt(wtaxt,wtbat,inaxt,inbat,rs,df,qr,nxe,nxg,mrr,nrr,mf,nf,nor) ia=mf ir=mrr-1 r=ia*secx - irp=ir -410 irp=irp+1 - if(rs(irp)<=r)goto 410 + irp=ir + 1 + do while (rs(irp) <= r) + irp=irp+1 + end do ir=irp-1 mra=irp-norh ! the lowest radial grid source index actually used ! write(6,'("lowest radial grid source index, mra=",i4)') mra if(mra<0)mra=0 - if(mranrr)then - write(6,'(" irp,r,rs(nrr)=",i5,2(1x,e13.6))') irp,r,rs(nrr) - goto 800 - endif - if(rs(irp)<=r)goto 411 + irp=ir+1 + do while(rs(irp)<=r) + if(irp>nrr)then + write(6,'(" irp,r,rs(nrr)=",i5,2(1x,e13.6))') irp,r,rs(nrr) + write(6,*)'nrr must be increased for interpolations required in polca' + return + endif + irp=irp+1 + end do ir=irp-1 nra=ir+norh ! the highest radial grid source index actually used ! write(6,'(" highest radial grid source index, nra=",i4)') nra - if(nra>nrr)goto 800 + if(nra>nrr)then + write(6,*)'nrr must be increased for interpolations required in polca' + end if do ir=mra,nra-norm call setq(qr(0,ir),rs(ir),nor) ! lagrange denomimators for radial grid. enddo @@ -325,18 +336,19 @@ subroutine setwtt(wtaxt,wtbat,inaxt,inbat,rs,df,qr,nxe,nxg,mrr,nrr,mf,nf,nor) irp=mra+norh-1 do ia=mf,nf r=ia*secx -400 continue - if(rs(irp)>r) go to 402 - irp=irp+1 - go to 400 -402 continue + do while (rs(irp) <= r) + irp=irp+1 + end do ic0=irp-norh inaxt(ia,ix)=ic0 call lagw(rs(ic0),r,qr(0,ic0),wtaxt(0,ia,ix),dw,nor) enddo enddo - if(mf<=0)goto 802 + if(mf<=0)then + write(6,*)'mf must exceed 0 for interpolations of polca' + return + end if do ia=mf,nf fsai=one/ia do ib=0,ia @@ -359,10 +371,6 @@ subroutine setwtt(wtaxt,wtbat,inaxt,inbat,rs,df,qr,nxe,nxg,mrr,nrr,mf,nf,nor) enddo return -800 write(6,*)'nrr must be increased for interpolations required in polca' -801 write(6,*)'mrr must be decreased for interpolations required in polca' -802 write(6,*)'mf must exceed 0 for interpolations of polca' -803 write(6,*)'invalid nor in setwtt; must be even and at least 2' end subroutine setwtt subroutine setwts(wtaxs,wtxrs,inaxs,inxrs,rs,df,nor,nxe,nf,mr,nr) diff --git a/src/prad_bias.f90 b/src/gsi/prad_bias.f90 similarity index 98% rename from src/prad_bias.f90 rename to src/gsi/prad_bias.f90 index 5daafed0b..344a7b6a6 100644 --- a/src/prad_bias.f90 +++ b/src/gsi/prad_bias.f90 @@ -139,9 +139,10 @@ subroutine destroyobs_passive !$$$ end documentation block implicit none - call lreset_(radheadm(:)) - deallocate(radheadm) - + if(associated(radheadm)) then + call lreset_(radheadm(:)) + deallocate(radheadm) + endif return end subroutine destroyobs_passive diff --git a/src/precond.f90 b/src/gsi/precond.f90 similarity index 100% rename from src/precond.f90 rename to src/gsi/precond.f90 diff --git a/src/precpd_ad.f90 b/src/gsi/precpd_ad.f90 similarity index 100% rename from src/precpd_ad.f90 rename to src/gsi/precpd_ad.f90 diff --git a/src/prewgt.f90 b/src/gsi/prewgt.f90 similarity index 100% rename from src/prewgt.f90 rename to src/gsi/prewgt.f90 diff --git a/src/prewgt_reg.f90 b/src/gsi/prewgt_reg.f90 similarity index 100% rename from src/prewgt_reg.f90 rename to src/gsi/prewgt_reg.f90 diff --git a/src/projmethod_support.f90 b/src/gsi/projmethod_support.f90 similarity index 99% rename from src/projmethod_support.f90 rename to src/gsi/projmethod_support.f90 index 14c1f046d..156161dbc 100644 --- a/src/projmethod_support.f90 +++ b/src/gsi/projmethod_support.f90 @@ -168,7 +168,7 @@ subroutine mgram_schmidt(gradx,grady) print*,'in mgram_schmidt: likely to happen when using fast version of inner product' print*,'in mgram_schmidt: iter,k,prd0=',iter,k,prd0 endif - goto 100 + return endif gx(1:nclen,iter)=gx(1:nclen,iter)/sqrt(prd0) gy(1:nclen,iter)=gy(1:nclen,iter)/sqrt(prd0) @@ -180,8 +180,6 @@ subroutine mgram_schmidt(gradx,grady) gradx%values(1:nclen)=gx(1:nclen,iter)*sqrt(prd0) grady%values(1:nclen)=gy(1:nclen,iter)*sqrt(prd0) -100 continue - contains real(r_kind) function dplev_mask(dx,dy,mype) diff --git a/src/gsi/prt_guess.f90 b/src/gsi/prt_guess.f90 new file mode 100644 index 000000000..ad5cb8002 --- /dev/null +++ b/src/gsi/prt_guess.f90 @@ -0,0 +1,833 @@ +subroutine prt_guess(sgrep) +!$$$ subprogram documentation block +! . . . . +! subprogram: prt_guess +! prgmmr: tremolet +! +! abstract: Print some diagnostics about the guess arrays +! +! program history log: +! 2007-04-13 tremolet - initial code +! 2007-04-17 todling - time index to summarize; bound in arrays +! 2009-01-17 todling - update tv/tsen names +! 2011-05-01 todling - cwmr no longer in guess_grids +! 2011-08-01 zhu - use cwgues for regional if cw is not in guess table +! 2011-12-02 zhu - add safe-guard for the case when there is no entry in the metguess table +! 2013-10-19 todling - metguess now holds background +! 2013-04-15 zhu - account for aircraft bias correction +! 2018-04-16 eliu - add prt_guess2 +! 2019-06-06 eliu - add cloud fraction in prt_guess +! +! input argument list: +! sgrep - prefix for write statement +! +! output argument list: +! +! remarks: +! +! 1. this routine needs generalization to handle met-guess and chem-bundle +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,mpi_rtype,npe,mype + use constants, only: zero + use gridmod, only: lat1,lon1,nsig + use gridmod, only: regional + use guess_grids, only: ges_tsen,ges_prsl,sfct + use guess_grids, only: ntguessig,ntguessfc + use radinfo, only: predx + use pcpinfo, only: predxp + use aircraftinfo, only: predt + use derivsmod, only: cwgues,cfgues + use jfunc, only: npclen,nsclen,ntclen + use gsi_metguess_mod, only: gsi_metguess_get,gsi_metguess_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use mpeu_util, only: die + use gridmod, only: fv3_full_hydro + + implicit none + +! Declare passed variables + character(len=*), intent(in ) :: sgrep + +! Declare local variables + integer(i_kind), parameter :: nvars=13 + integer(i_kind) ii,istatus,ier,icf + integer(i_kind) ntsig + integer(i_kind) ntsfc + integer(i_kind) n_actual_clouds + real(r_kind) :: zloc(3*nvars+3),zall(3*nvars+3,npe),zz + real(r_kind) :: zmin(nvars+3),zmax(nvars+3),zavg(nvars+3) + real(r_kind),pointer,dimension(:,: )::ges_ps_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_u_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_v_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_div_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_vor_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_tv_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_q_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_oz_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_cwmr_it=>NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_cf_it=>NULL() + character(len=4) :: cvar(nvars+3) + +!******************************************************************************* + + if (fv3_full_hydro) then + call prt_guess2(sgrep) + return + endif + + ntsig = ntguessig + ntsfc = ntguessfc + + ier=0; icf=0 + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'ps',ges_ps_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'u',ges_u_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'v',ges_v_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'div',ges_div_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'vor',ges_vor_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'tv',ges_tv_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'q',ges_q_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'oz',ges_oz_it,istatus) + ier=ier+istatus + if (ier/=0) return ! this is a fundamental routine, when some not found just return + + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'cf',ges_cf_it,icf) + if (icf/=0) ges_cf_it =>cfgues + +! get pointer to cloud water condensate + call gsi_metguess_get('clouds::3d',n_actual_clouds,ier) + if (n_actual_clouds>0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'cw',ges_cwmr_it,istatus) + if (istatus/=0) then + if (regional) then + ges_cwmr_it => cwgues + else + ier=99 + end if + end if + else + if(associated(ges_cwmr_it)) then + ges_cwmr_it => cwgues + else + ier=99 + endif + end if + if (ier/=0) return ! this is a fundamental routine, when some not found just return + + cvar( 1)='U ' + cvar( 2)='V ' + cvar( 3)='TV ' + cvar( 4)='Q ' + cvar( 5)='TSEN' + cvar( 6)='OZ ' + cvar( 7)='CW ' + cvar( 8)='CF ' + cvar( 9)='DIV ' + cvar(10)='VOR ' + cvar(11)='PRSL' + cvar(12)='PS ' + cvar(13)='SST ' + cvar(14)='radb' + cvar(15)='pcpb' + cvar(16)='aftb' + + zloc(1) = sum (ges_u_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2) = sum (ges_v_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(3) = sum (ges_tv_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(4) = sum (ges_q_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(5) = sum (ges_tsen (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(6) = sum (ges_oz_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(7) = sum (ges_cwmr_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(8) = sum (ges_cf_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(9) = sum (ges_div_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(10) = sum (ges_vor_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(11) = sum (ges_prsl (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(12) = sum (ges_ps_it (2:lat1+1,2:lon1+1 )) + zloc(13) = sum (sfct (2:lat1+1,2:lon1+1, ntsfc)) + zloc(nvars+1) = minval(ges_u_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+2) = minval(ges_v_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+3) = minval(ges_tv_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+4) = minval(ges_q_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+5) = minval(ges_tsen (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(nvars+6) = minval(ges_oz_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+7) = minval(ges_cwmr_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+8) = minval(ges_cf_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+9) = minval(ges_div_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+10) = minval(ges_vor_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+11) = minval(ges_prsl (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(nvars+12) = minval(ges_ps_it (2:lat1+1,2:lon1+1 )) + zloc(nvars+13) = minval(sfct (2:lat1+1,2:lon1+1, ntsfc)) + zloc(2*nvars+1) = maxval(ges_u_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+2) = maxval(ges_v_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+3) = maxval(ges_tv_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+4) = maxval(ges_q_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+5) = maxval(ges_tsen (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(2*nvars+6) = maxval(ges_oz_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+7) = maxval(ges_cwmr_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+8) = maxval(ges_cf_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+9) = maxval(ges_div_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+10) = maxval(ges_vor_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+11) = maxval(ges_prsl (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(2*nvars+12) = maxval(ges_ps_it (2:lat1+1,2:lon1+1 )) + zloc(2*nvars+13) = maxval(sfct (2:lat1+1,2:lon1+1, ntsfc)) + zloc(3*nvars+1) = real(lat1*lon1*nsig*ntsig,r_kind) + zloc(3*nvars+2) = real(lat1*lon1*ntsig,r_kind) + zloc(3*nvars+3) = real(lat1*lon1*nsig*ntsig,r_kind) + + +! Gather contributions + call mpi_allgather(zloc,3*nvars+3,mpi_rtype, & + & zall,3*nvars+3,mpi_rtype, mpi_comm_world,ierror) + + if (mype==0) then + zmin=zero + zmax=zero + zavg=zero + zz=SUM(zall(3*nvars+1,:)) + do ii=1,nvars-2 + zavg(ii)=SUM(zall(ii,:))/zz + enddo + zz=SUM(zall(3*nvars+2,:)) + do ii=nvars-1,nvars + zavg(ii)=SUM(zall(ii,:))/zz + enddo + do ii=1,nvars + zmin(ii)=MINVAL(zall( nvars+ii,:)) + zmax(ii)=MAXVAL(zall(2*nvars+ii,:)) + enddo + +! Duplicated part of vector + if (nsclen>0) then + zmin(nvars+1) = minval(predx(:,:)) + zmax(nvars+1) = maxval(predx(:,:)) + zavg(nvars+1) = sum(predx(:,:))/nsclen + endif + if (npclen>0) then + zmin(nvars+2) = minval(predxp(:,:)) + zmax(nvars+2) = maxval(predxp(:,:)) + zavg(nvars+2) = sum(predxp(:,:))/npclen + endif + if (ntclen>0) then + zmin(nvars+3) = minval(predt(:,:)) + zmax(nvars+3) = maxval(predt(:,:)) + zavg(nvars+3) = sum(predt(:,:))/ntclen + endif + + write(6,'(80a)') ('=',ii=1,80) + write(6,'(a,2x,a,10x,a,17x,a,20x,a)') 'Status ', 'Var', 'Mean', 'Min', 'Max' + do ii=1,nvars+3 + write(6,999)sgrep,cvar(ii),zavg(ii),zmin(ii),zmax(ii) + enddo + write(6,'(80a)') ('=',ii=1,80) + endif +999 format(A,1X,A,3(1X,ES20.12)) + + return +end subroutine prt_guess + +subroutine prt_guess2(sgrep) +!$$$ subprogram documentation block +! . . . . +! subprogram: prt_guess2 +! prgmmr: tremolet +! +! abstract: Print some diagnostics about the guess arrays +! +! program history log: +! 2018-04-16 eliu - account for hydrometeors +! +! input argument list: +! sgrep - prefix for write statement +! +! output argument list: +! +! remarks: +! +! 1. this routine needs generalization to handle met-guess and chem-bundle +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,mpi_rtype,npe,mype + use constants, only: zero + use gridmod, only: lat1,lon1,nsig + use guess_grids, only: ges_tsen,ges_prsl,sfct + use guess_grids, only: ntguessig,ntguessfc + use radinfo, only: predx + use pcpinfo, only: predxp + use aircraftinfo, only: predt + use jfunc, only: npclen,nsclen,ntclen + use gsi_metguess_mod, only: gsi_metguess_get,gsi_metguess_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use mpeu_util, only: die + + implicit none + +! Declare passed variables + character(len=*), intent(in ) :: sgrep + +! Declare local variables +! integer(i_kind), parameter :: nvars=17 + integer(i_kind), parameter :: nvars1=6 + integer(i_kind), parameter :: nvars3=5 + integer(i_kind) :: nvars,nvars2,nvarsc,nc + integer(i_kind) ii,istatus,ier,ivar + integer(i_kind) iql,iqi,iqr,iqs,iqg,icf + integer(i_kind) ntsig + integer(i_kind) ntsfc + integer(i_kind) n_actual_clouds + real(r_kind),allocatable,dimension(:) :: zloc,zmin,zmax,zavg + real(r_kind),allocatable,dimension(:,:) :: zall + real(r_kind) :: zz + real(r_kind),pointer,dimension(:,: )::ges_ps_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_u_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_v_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_div_it=> NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_vor_it=> NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_tv_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_q_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_oz_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_ql_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_qi_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_qr_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_qs_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_qg_it => NULL() + real(r_kind),pointer,dimension(:,:,:)::ges_cf_it => NULL() +! character(len=4) :: cvar(nvars+3) + character(len=4),allocatable,dimension(:) :: cvar + +!******************************************************************************* + + ntsig = ntguessig + ntsfc = ntguessfc + + ier=0 + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'ps', ges_ps_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'u', ges_u_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'v', ges_v_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'div',ges_div_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'vor',ges_vor_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'tv', ges_tv_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'q', ges_q_it,istatus) + ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'oz', ges_oz_it,istatus) + ier=ier+istatus + if (ier/=0) return ! this is a fundamental routine, when some not found just return + +! get pointer to cloud water condensate + ier=0;nvarsc=0 + iql=0;iqi=0;iqr=0;iqs=0;iqg=0 + call gsi_metguess_get('clouds::3d',n_actual_clouds,ier) + if (mype==0) write(6,*)'prt_guess2: n_actual_clouds = ', n_actual_clouds + if (n_actual_clouds>0) then + call gsi_metguess_get ( 'var::ql', ivar, ier ); iql=ivar + if (ivar > 0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'ql',ges_ql_it,istatus) + ier=ier+istatus + endif + call gsi_metguess_get ( 'var::qi', ivar, ier ); iqi=ivar + if (ivar > 0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'qi',ges_qi_it,istatus) + ier=ier+istatus + endif + call gsi_metguess_get ( 'var::qr', ivar, ier ); iqr=ivar + if (ivar > 0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'qr',ges_qr_it,istatus) + ier=ier+istatus + endif + call gsi_metguess_get ( 'var::qs', ivar, ier ); iqs=ivar + if (ivar > 0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'qs',ges_qs_it,istatus) + ier=ier+istatus + endif + call gsi_metguess_get ( 'var::qg', ivar, ier ); iqg=ivar + if (ivar > 0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'qg',ges_qg_it,istatus) + ier=ier+istatus + endif + end if + nvarsc=n_actual_clouds + call gsi_metguess_get ( 'var::cf', ivar, ier ); icf=ivar + if (ivar > 0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'cf',ges_cf_it,istatus) + ier=ier+istatus + nvarsc=nvarsc+1 + endif + if (ier/=0) return ! this is a fundamental routine, when some not found just + + nvars = nvars1+nvarsc+nvars3 + nvars2 = nvars1+nvarsc + + if ( nvars > 0 ) then + allocate(zloc(3*nvars+3)) + allocate(zall(3*nvars+3,npe)) + allocate(zmin(nvars+3)) + allocate(zmax(nvars+3)) + allocate(zavg(nvars+3)) + allocate(cvar(nvars+3)) + endif + + cvar( 1)='U ' + cvar( 2)='V ' + cvar( 3)='TV ' + cvar( 4)='Q ' + cvar( 5)='TSEN' + cvar( 6)='OZ ' + nc=0 + if(iql>0) then + nc=nc+1 + cvar(nvars1+nc)='QL ' + endif + if(iqi>0) then + nc=nc+1 + cvar(nvars1+nc)='QI ' + endif + if(iqr>0) then + nc=nc+1 + cvar(nvars1+nc)='QR ' + endif + if(iqs>0) then + nc=nc+1 + cvar(nvars1+nc)='QS ' + endif + if(iqg>0) then + nc=nc+1 + cvar(nvars1+nc)='QG ' + endif + if(icf>0) then + nc=nc+1 + cvar(nvars1+nc)='CF ' + endif + cvar(nvars2+1)='DIV ' + cvar(nvars2+2)='VOR ' + cvar(nvars2+3)='PRSL' + cvar(nvars2+4)='PS ' + cvar(nvars2+5)='SST ' + cvar(nvars +1)='radb' + cvar(nvars +2)='pcpb' + cvar(nvars +3)='aftb' + + zloc( 1) = sum (ges_u_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc( 2) = sum (ges_v_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc( 3) = sum (ges_tv_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc( 4) = sum (ges_q_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc( 5) = sum (ges_tsen (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc( 6) = sum (ges_oz_it (2:lat1+1,2:lon1+1,1:nsig)) + nc=0 + if(iql>0) then + nc=nc+1 + zloc(nvars1+nc) = sum (ges_ql_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqi>0) then + nc=nc+1 + zloc(nvars1+nc) = sum (ges_qi_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqr>0) then + nc=nc+1 + zloc(nvars1+nc) = sum (ges_qr_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqs>0) then + nc=nc+1 + zloc(nvars1+nc) = sum (ges_qs_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqg>0) then + nc=nc+1 + zloc(nvars1+nc) = sum (ges_qg_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(icf>0) then + nc=nc+1 + zloc(nvars1+nc) = sum (ges_cf_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + zloc(nvars2+1) = sum (ges_div_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars2+2) = sum (ges_vor_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars2+3) = sum (ges_prsl (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(nvars2+4) = sum (ges_ps_it (2:lat1+1,2:lon1+1 )) + zloc(nvars2+5) = sum (sfct (2:lat1+1,2:lon1+1, ntsfc)) + zloc(nvars+ 1) = minval(ges_u_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+ 2) = minval(ges_v_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+ 3) = minval(ges_tv_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+ 4) = minval(ges_q_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+ 5) = minval(ges_tsen (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(nvars+ 6) = minval(ges_oz_it (2:lat1+1,2:lon1+1,1:nsig)) + nc=0 + if(iql>0) then + nc=nc+1 + zloc(nvars+nvars1+nc) = minval(ges_ql_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqi>0) then + nc=nc+1 + zloc(nvars+nvars1+nc) = minval(ges_qi_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqr>0) then + nc=nc+1 + zloc(nvars+nvars1+nc) = minval(ges_qr_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqs>0) then + nc=nc+1 + zloc(nvars+nvars1+nc) = minval(ges_qs_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqg>0) then + nc=nc+1 + zloc(nvars+nvars1+nc) = minval(ges_qg_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(icf>0) then + nc=nc+1 + zloc(nvars+nvars1+nc) = minval(ges_cf_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + zloc(nvars+nvars2+1) = minval(ges_div_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+nvars2+2) = minval(ges_vor_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+nvars2+3) = minval(ges_prsl (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(nvars+nvars2+4) = minval(ges_ps_it (2:lat1+1,2:lon1+1 )) + zloc(nvars+nvars2+5) = minval(sfct (2:lat1+1,2:lon1+1, ntsfc)) + zloc(2*nvars+ 1) = maxval(ges_u_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+ 2) = maxval(ges_v_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+ 3) = maxval(ges_tv_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+ 4) = maxval(ges_q_it (2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+ 5) = maxval(ges_tsen (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(2*nvars+ 6) = maxval(ges_oz_it (2:lat1+1,2:lon1+1,1:nsig)) + nc=0 + if(iql>0) then + nc=nc+1 + zloc(2*nvars+nvars1+nc) = maxval(ges_ql_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqi>0) then + nc=nc+1 + zloc(2*nvars+nvars1+nc) = maxval(ges_qi_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqr>0) then + nc=nc+1 + zloc(2*nvars+nvars1+nc) = maxval(ges_qr_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqs>0) then + nc=nc+1 + zloc(2*nvars+nvars1+nc) = maxval(ges_qs_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(iqg>0) then + nc=nc+1 + zloc(2*nvars+nvars1+nc) = maxval(ges_qg_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + if(icf>0) then + nc=nc+1 + zloc(2*nvars+nvars1+nc) = maxval(ges_cf_it (2:lat1+1,2:lon1+1,1:nsig)) + endif + zloc(2*nvars+nvars2+1) = maxval(ges_div_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+nvars2+2) = maxval(ges_vor_it(2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+nvars2+3) = maxval(ges_prsl (2:lat1+1,2:lon1+1,1:nsig,ntsig)) + zloc(2*nvars+nvars2+4) = maxval(ges_ps_it (2:lat1+1,2:lon1+1 )) + zloc(2*nvars+nvars2+5) = maxval(sfct (2:lat1+1,2:lon1+1, ntsfc)) + zloc(3*nvars+1) = real(lat1*lon1*nsig*ntsig,r_kind) + zloc(3*nvars+2) = real(lat1*lon1*ntsig,r_kind) + zloc(3*nvars+3) = real(lat1*lon1*nsig*ntsig,r_kind) + +! Gather contributions + call mpi_allgather(zloc,3*nvars+3,mpi_rtype, & + & zall,3*nvars+3,mpi_rtype, mpi_comm_world,ierror) + + if (mype==0) then + zmin=zero + zmax=zero + zavg=zero + zz=SUM(zall(3*nvars+1,:)) + do ii=1,nvars-2 + zavg(ii)=SUM(zall(ii,:))/zz + enddo + zz=SUM(zall(3*nvars+2,:)) + do ii=nvars-1,nvars + zavg(ii)=SUM(zall(ii,:))/zz + enddo + do ii=1,nvars + zmin(ii)=MINVAL(zall( nvars+ii,:)) + zmax(ii)=MAXVAL(zall(2*nvars+ii,:)) + enddo + +! Duplicated part of vector + if (nsclen>0) then + zmin(nvars+1) = minval(predx(:,:)) + zmax(nvars+1) = maxval(predx(:,:)) + zavg(nvars+1) = sum(predx(:,:))/nsclen + endif + if (npclen>0) then + zmin(nvars+2) = minval(predxp(:,:)) + zmax(nvars+2) = maxval(predxp(:,:)) + zavg(nvars+2) = sum(predxp(:,:))/npclen + endif + if (ntclen>0) then + zmin(nvars+3) = minval(predt(:,:)) + zmax(nvars+3) = maxval(predt(:,:)) + zavg(nvars+3) = sum(predt(:,:))/ntclen + endif + + write(6,'(80a)') ('=',ii=1,80) + write(6,'(a,2x,a,10x,a,17x,a,20x,a)') 'Status ', 'Var', 'Mean', 'Min', 'Max' + do ii=1,nvars+3 + write(6,999)sgrep,cvar(ii),zavg(ii),zmin(ii),zmax(ii) + enddo + write(6,'(80a)') ('=',ii=1,80) + endif +999 format(A,1X,A,3(1X,ES20.12)) + + if ( nvars > 0 ) then + deallocate(zloc) + deallocate(zall) + deallocate(zmin) + deallocate(zmax) + deallocate(zavg) + deallocate(cvar) + endif + return +end subroutine prt_guess2 + +subroutine prt_guessfc2(sgrep,use_sfc) +!$$$ subprogram documentation block +! . . . . +! subprogram: prt_guessfc2 +! pgrmmr: todling +! +! abstract: Print some diagnostics about the guess arrays +! +! program history log: +! 2009-01-23 todling - create based on prt_guess +! +! input argument list: +! sgrep - prefix for write statement +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use satthin, only: isli_full,fact10_full,soil_moi_full,soil_temp_full,veg_frac_full,& + soil_type_full,veg_type_full,sfc_rough_full,sst_full,sno_full + use guess_grids, only: ntguessfc + use constants, only: zero + + implicit none + +! Declare passed variables + character(len=*), intent(in ) :: sgrep + logical, intent(in ) :: use_sfc + +! Declare local variables + integer(i_kind), parameter :: nvars=10 + integer(i_kind) ii + integer(i_kind) ntsfc + real(r_kind) :: zall(3*nvars+2),zz + real(r_kind) :: zmin(nvars+2),zmax(nvars+2),zavg(nvars+2) + character(len=4) :: cvar(nvars+2) + +!******************************************************************************* + + ntsfc = ntguessfc + + cvar( 1)='FC10' + cvar( 2)='SNOW' + cvar( 3)='VFRC' + cvar( 4)='SRGH' + cvar( 5)='STMP' + cvar( 6)='SMST' + cvar( 7)='SST ' + cvar( 8)='VTYP' + cvar( 9)='ISLI' + cvar(10)='STYP' + +! Default to -99999.9 if not used. + zall = -99999.9_r_kind ! missing flag + zavg = -99999.9_r_kind ! missing flag + zall(1) = sum (fact10_full ) + zall(2) = sum (sno_full ) + zall(4) = sum (sfc_rough_full) + zall(7) = sum (sst_full ) + zall(9) = sum (isli_full ) + zall(nvars+1) = minval(fact10_full ) + zall(nvars+2) = minval(sno_full ) + zall(nvars+4) = minval(sfc_rough_full) + zall(nvars+7) = minval(sst_full ) + zall(nvars+9) = minval(isli_full ) + zall(2*nvars+1) = maxval(fact10_full ) + zall(2*nvars+2) = maxval(sno_full ) + zall(2*nvars+4) = maxval(sfc_rough_full) + zall(2*nvars+7) = maxval(sst_full ) + zall(2*nvars+9) = maxval(isli_full ) + zall(3*nvars+1) = real(SIZE(fact10_full),r_kind) + zall(3*nvars+2) = real(SIZE(isli_full),r_kind) + + if(use_sfc)then + zall(3) = sum (veg_frac_full ) + zall(5) = sum (soil_temp_full) + zall(6) = sum (soil_moi_full ) + zall(8) = sum (veg_type_full ) + zall(10) = sum (soil_type_full) + zall(nvars+3) = minval(veg_frac_full ) + zall(nvars+5) = minval(soil_temp_full) + zall(nvars+6) = minval(soil_moi_full ) + zall(nvars+8) = minval(veg_type_full ) + zall(nvars+10) = minval(soil_type_full) + zall(2*nvars+3) = maxval(veg_frac_full ) + zall(2*nvars+5) = maxval(soil_temp_full) + zall(2*nvars+6) = maxval(soil_moi_full ) + zall(2*nvars+8) = maxval(veg_type_full ) + zall(2*nvars+10) = maxval(soil_type_full) + end if + + + zz=zall(3*nvars+1) + do ii=1,nvars-3 + if( zall(ii) > -99999.0_r_kind) zavg(ii)=zall(ii)/zz + enddo + zz=zall(3*nvars+2) + do ii=nvars-2,nvars + if( zall(ii) > -99999.0_r_kind) zavg(ii)=zall(ii)/zz + enddo + do ii=1,nvars + zmin(ii)=zall( nvars+ii) + zmax(ii)=zall(2*nvars+ii) + enddo + + write(6,'(80a)') ('=',ii=1,80) + write(6,'(a,2x,a,10x,a,17x,a,20x,a)') 'Status ', 'Var', 'Mean', 'Min', 'Max' + do ii=1,nvars + write(6,999)sgrep,cvar(ii),zavg(ii),zmin(ii),zmax(ii) + enddo + write(6,'(80a)') ('=',ii=1,80) +999 format(A,1X,A,3(1X,ES20.12)) + + + return +end subroutine prt_guessfc2 + +subroutine prt_guesschem(sgrep) +!$$$ subprogram documentation block +! . . . . +! subprogram: prt_guesschem +! prgmmr: hclin +! +! abstract: Print some diagnostics about the chem guess arrays +! +! program history log: +! 2011-09-20 hclin - +! 2013-11-16 todling - revisit return logic +! +! input argument list: +! sgrep - prefix for write statement +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use mpimod, only: ierror,mpi_comm_world,mpi_rtype,npe,mype + use constants, only: zero + use gridmod, only: lat1,lon1,nsig + use guess_grids, only: ntguessig + use gsi_chemguess_mod, only: gsi_chemguess_bundle, gsi_chemguess_get + use gsi_bundlemod, only: gsi_bundlegetpointer + + implicit none + +! Declare passed variables + character(len=*), intent(in ) :: sgrep + +! Declare local variables + integer(i_kind) nvars + integer(i_kind) ii + integer(i_kind) ntsig + real(r_kind),allocatable,dimension(:) :: zloc,zmin,zmax,zavg + real(r_kind),allocatable,dimension(:,:) :: zall + real(r_kind) zz + character(len=5),allocatable,dimension(:) :: cvar + real(r_kind), pointer, dimension(:,:,:) :: ptr3d=>NULL() + integer(i_kind) ier, istatus + +!******************************************************************************* + + ntsig = ntguessig + + call gsi_chemguess_get('aerosols::3d',nvars,istatus) + if(istatus/=0.or.nvars==0) return + + if ( nvars > 0 ) then + allocate(zloc(3*nvars+1)) + allocate(zall(3*nvars+1,npe)) + allocate(zmin(nvars)) + allocate(zmax(nvars)) + allocate(zavg(nvars)) + allocate(cvar(nvars)) + call gsi_chemguess_get ('aerosols::3d',cvar,ier) + endif + + ier = 0 + do ii = 1, nvars + call GSI_BundleGetPointer(GSI_ChemGuess_Bundle(ntsig),cvar(ii),ptr3d,istatus);ier=ier+istatus + if ( ier == 0 ) then + zloc(ii) = sum (ptr3d(2:lat1+1,2:lon1+1,1:nsig)) + zloc(nvars+ii) = minval(ptr3d(2:lat1+1,2:lon1+1,1:nsig)) + zloc(2*nvars+ii) = maxval(ptr3d(2:lat1+1,2:lon1+1,1:nsig)) + zloc(3*nvars+1) = real(lat1*lon1*nsig*ntsig,r_kind) + endif + enddo + +! Gather contributions + call mpi_allgather(zloc,3*nvars+1,mpi_rtype, & + & zall,3*nvars+1,mpi_rtype, mpi_comm_world,ierror) + + if (mype==0) then + zmin=zero + zmax=zero + zavg=zero + zz=SUM(zall(3*nvars+1,:)) + do ii=1,nvars + zavg(ii)=SUM(zall(ii,:))/zz + enddo + do ii=1,nvars + zmin(ii)=MINVAL(zall( nvars+ii,:)) + zmax(ii)=MAXVAL(zall(2*nvars+ii,:)) + enddo + + write(6,'(80a)') ('=',ii=1,80) + write(6,'(a,2x,a,10x,a,17x,a,20x,a)') 'Status ', 'Var', 'Mean', 'Min', 'Max' + do ii=1,nvars + write(6,999)sgrep,cvar(ii),zavg(ii),zmin(ii),zmax(ii) + enddo + write(6,'(80a)') ('=',ii=1,80) + endif +999 format(A,1X,A,3(1X,ES20.12)) + + if ( nvars > 0 ) then + deallocate(zloc) + deallocate(zall) + deallocate(zmin) + deallocate(zmax) + deallocate(zavg) + deallocate(cvar) + endif + + return +end subroutine prt_guesschem + diff --git a/src/psichi2uv_reg.f90 b/src/gsi/psichi2uv_reg.f90 similarity index 100% rename from src/psichi2uv_reg.f90 rename to src/gsi/psichi2uv_reg.f90 diff --git a/src/psichi2uvt_reg.f90 b/src/gsi/psichi2uvt_reg.f90 similarity index 100% rename from src/psichi2uvt_reg.f90 rename to src/gsi/psichi2uvt_reg.f90 diff --git a/src/q_diag.f90 b/src/gsi/q_diag.f90 similarity index 97% rename from src/q_diag.f90 rename to src/gsi/q_diag.f90 index 39138b8ed..2ab12872c 100644 --- a/src/q_diag.f90 +++ b/src/gsi/q_diag.f90 @@ -85,7 +85,8 @@ subroutine q_diag(it,mype) if (regional) then ges_cwmr_it => cwgues ! temporarily else - call die('q_diag','cannot get pointer to cwmr, istatus =',istatus) + ! call die('q_diag','cannot get pointer to cwmr, istatus =',istatus) + ges_cwmr_it => cwgues ! do not die end if end if else diff --git a/src/qcmod.f90 b/src/gsi/qcmod.f90 similarity index 84% rename from src/qcmod.f90 rename to src/gsi/qcmod.f90 index 38aff9534..09670c041 100644 --- a/src/qcmod.f90 +++ b/src/gsi/qcmod.f90 @@ -49,6 +49,7 @@ module qcmod ! 2015-01-16 ejones - added qc_gmi ! 2015-03-11 ejones - added qc_amsr2 ! 2015-03-23 ejones - added qc_saphir +! 2015-03-26 m.kim - apply extra optional qc for MHS and AIRS using iextra in satinfo file ! 2015-03-31 zhu - observation error adjustments based on mis-matched ! cloud info, diff_clw, scattering and surface wind ! speed for AMSUA/ATMS cloudy radiance assimilation @@ -62,11 +63,19 @@ module qcmod ! closest to the analysis time from multiple surface obs. at a station. ! 2016-05-22 zhu - add errormod_aircraft ! 2016-09-16 tong - Remove tdrgross_fact (not used) +! 2016-10-13 zhu - modified qc_amsua for all-sky ATMS ! 2016-10-20 acollard- Ensure AMSU-A channels 1-6,15 are not assimilated if ! any of these are missing. ! 2016-11-22 sienkiewicz - fix a couple of typos in HIRS qc ! 2016-12-14 lippi - add nml option vadwnd_l2rw_qc. ! 2016-10-13 zhu - modified qc_amsua for all-sky ATMS +! 2018-02-21 yang - add namelist variables used in module nltransf +! 2018-03-22 yang - remove "logical closest_obs", previously applied to the analysis +! of vis and cldch. the option to use the closest ob to the +! analysis time only is now handled by Ming Hu's "logical l_closeobs" +! for all variables +! 2019-03-27 h. liu - add ABI QC +! 2019-04-19 eliu - add QC flag for cold-air outbreak ! ! subroutines included: ! sub init_qcvars @@ -89,6 +98,7 @@ module qcmod ! sub qc_gmi - qc gmi data ! sub qc_amsr2 - qc amsr2 data ! sub qc_saphir - qc saphir data +! sub qc_abi - qc abi data ! ! remarks: variable definitions below ! def dfact - factor for duplicate obs at same location for conv. data @@ -101,14 +111,23 @@ module qcmod ! def ptopo3,pboto3 - arrays containing top pressure and bottom pressure of print levels for o3 levels ! def vadfile - local name of bufr file containing vad winds (used by read_radar) ! def use_poq7 - if true, accept sbuv/2 obs with profile ozone quality flag 7 +! def cao_check - if true, turn on cold-air-outbreak screening ! -! following used for nonlinear qc: +! following used for nonlinear qc: ! ! def nlnqc_iter - logical flag (T=nonlinear qc on, F=nonlinear qc off) for iteration -! def njqc - logical flag (T=Purse's nonlinear qc on, F=off) -! +! def njqc - logical flag (T=Purser's nonlinear qc on, F=off) ! def noiqc - logic flag for oiqc, noiqc='false' with oiqc on ! +! following used for NonLinear TRansformation to visibility and ceiling height +! def pvis - power value in non-linear transformation for vis +! def pcldch - power value in non-linear transformation for cldch +! def scale_cv - scaling constant in meter +! def estvisoe - prescribed obs vis error +! def estcldchoe - prescribed obs cldch error +! def vis_thres - threshold value for vis +! def cldch_thres - threshold value for cldch +! ! ! attributes: ! language: f90 @@ -139,6 +158,7 @@ module qcmod public :: qc_seviri public :: qc_ssu public :: qc_goesimg + public :: qc_abi public :: qc_msu public :: qc_irsnd public :: qc_avhrr @@ -156,10 +176,15 @@ module qcmod public :: use_poq7,noiqc,vadfile,dfact1,dfact,erradar_inflate public :: pboto3,ptopo3,pbotq,ptopq,newvad,tdrerr_inflate public :: igood_qc,ifail_crtm_qc,ifail_satinfo_qc,ifail_interchan_qc,& - ifail_gross_qc,ifail_cloud_qc,ifail_outside_range,ifail_scanedge_qc - - public :: buddycheck_t,buddydiag_save,closest_obs + ifail_gross_qc,ifail_cloud_qc,ifail_outside_range,& + ifail_scanedge_qc, ifail_emiss_qc, ifail_cao_qc + public :: ifail_iland_det, ifail_isnow_det, ifail_iice_det, ifail_iwater_det,& + ifail_imix_det, ifail_iomg_det, ifail_isst_det, ifail_itopo_det,& + ifail_iwndspeed_det + public :: cao_check + public :: buddycheck_t,buddydiag_save public :: vadwnd_l2rw_qc + public :: pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres logical nlnqc_iter,njqc,vqc logical noiqc @@ -171,13 +196,14 @@ module qcmod logical qc_satwnds logical buddycheck_t logical buddydiag_save - logical closest_obs logical vadwnd_l2rw_qc + logical cao_check character(10):: vadfile integer(i_kind) npres_print real(r_kind) dfact,dfact1,erradar_inflate,c_varqc real(r_kind) varqc_iter + real(r_kind) pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres real(r_kind),allocatable,dimension(:)::ptop,pbot,ptopq,pbotq,ptopo3,pboto3 ! Declare variables for QC with Tz retrieval @@ -210,7 +236,8 @@ module qcmod integer(i_kind),parameter:: ifail_range_qc=9 ! Reject because outside the range of lsingleradob integer(i_kind),parameter:: ifail_outside_range=11 - +! Reject due to cold-air outbreak area check in setuprad + integer(i_kind),parameter:: ifail_cao_qc=12 ! Failures specific to qc routine start at 50 and the numbers overlap ! QC_SSMI failures ! Reject due to krain type not equal to 0 in subroutine qc_ssmi @@ -278,6 +305,26 @@ module qcmod ! Reject because fact1 > limit in subroutine qc_mhs integer(i_kind),parameter:: ifail_fact1_qc=50 +! OPTIONAL EXTRA QC +! Reject because of iland_det + integer(i_kind),parameter:: ifail_iland_det=61 +! Reject because of isnow_det + integer(i_kind),parameter:: ifail_isnow_det=62 +! Reject because of iice_det + integer(i_kind),parameter:: ifail_iice_det=63 +! Reject because of iwater_det + integer(i_kind),parameter:: ifail_iwater_det=64 +! Reject because of imix_det + integer(i_kind),parameter:: ifail_imix_det=65 +! Reject because of iomg_det + integer(i_kind),parameter:: ifail_iomg_det=66 +! Reject because of isst_det + integer(i_kind),parameter:: ifail_isst_det=67 +! Reject because of itopo_det + integer(i_kind),parameter:: ifail_itopo_det=68 +! Reject because of iwndspeed_det + integer(i_kind),parameter:: ifail_iwndspeed_det=69 + ! QC_SSU ! QC_MSU @@ -286,6 +333,10 @@ module qcmod ! Reject because terrain height > 1km. integer(i_kind),parameter:: ifail_terrain_qc=50 +! QC_abi +! Reject because of standard deviation in subroutine qc_abi + integer(i_kind),parameter:: ifail_std_abi_qc=50 + ! QC_avhrr ! Reject because of too large surface temperature physical retrieval in qc routine: tz_retrieval (see tzr_qc) integer(i_kind),parameter:: ifail_tzr_qc=10 @@ -357,6 +408,7 @@ subroutine init_qcvars vadfile='none' use_poq7 = .false. + cao_check = .false. qc_noirjaco3 = .false. ! when .f., use O3 Jac from IR instruments qc_noirjaco3_pole = .false. ! true=do not use O3 Jac from IR instruments near poles @@ -367,9 +419,14 @@ subroutine init_qcvars buddydiag_save=.false. ! When true, output files containing buddy check QC info for all ! obs run through the buddy check - closest_obs=.false. ! When true, select timely nearest obs. - vadwnd_l2rw_qc=.true. ! When false, DO NOT run the vadwnd qc on level 2 radial wind obs. + pvis=one + pcldch=one + scale_cv=one + estvisoe=one + estcldchoe=one + vis_thres=16000.0_r_kind + cldch_thres=16000.0_r_kind return end subroutine init_qcvars @@ -506,7 +563,7 @@ subroutine setup_tzr_qc(obstype) obstype == 'sndr' .or. obstype == 'sndrd1' .or. obstype == 'sndrd2'.or. & obstype == 'sndrd3' .or. obstype == 'sndrd4' .or. & obstype == 'goes_img' .or. obstype == 'ahi' .or. obstype == 'airs' .or. obstype == 'iasi' .or. & - obstype == 'cris' .or. obstype == 'cris-fsr' .or. obstype == 'seviri' ) then + obstype == 'cris' .or. obstype == 'cris-fsr' .or. obstype == 'seviri' .or. obstype == 'abi') then tzchk = 0.85_r_kind endif @@ -1266,8 +1323,8 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, & return end subroutine qc_ssmi -subroutine qc_gmi(nchanl,sfchgt,luse,sea,cenlat, & - kraintype,clw,tsavg5,tbobs,gmi,varinv,aivals,id_qc) +subroutine qc_gmi(nchanl,sfchgt,luse,sea,cenlat, cenlon, & + kraintype,clw,tsavg5,tbobs,gmi,varinv,aivals,id_qc,lcw4crtm_gmi) ! kraintype,clw,tsavg5,tbobs,gmi,varinv,aivals,id_qc,radmod) ! all-sky !$$$ subprogram documentation block ! . . . @@ -1320,11 +1377,12 @@ subroutine qc_gmi(nchanl,sfchgt,luse,sea,cenlat, & logical ,intent(in ) :: gmi real(r_kind) ,intent(in ) :: sfchgt,clw,tsavg5 - real(r_kind) ,intent(in ) :: cenlat + real(r_kind) ,intent(in ) :: cenlat,cenlon real(r_kind) ,dimension(nchanl),intent(in ) :: tbobs real(r_kind) ,dimension(nchanl),intent(inout) :: varinv real(r_kind) ,dimension(40) ,intent(inout) :: aivals + logical ,intent(in) :: lcw4crtm_gmi !MJK ! Declare local variables integer(i_kind) :: l,i,idx @@ -1357,7 +1415,7 @@ subroutine qc_gmi(nchanl,sfchgt,luse,sea,cenlat, & if(sea) then ! rain qc - if( kraintype /= 0 ) then + if(.not. lcw4crtm_gmi .and. kraintype /= 0 ) then !MJK efact=zero; vfact=zero if(luse) then aivals(8) = aivals(8) + one @@ -1370,8 +1428,7 @@ subroutine qc_gmi(nchanl,sfchgt,luse,sea,cenlat, & end do end if - else if(clw > zero)then - + else if(.not. lcw4crtm_gmi .and. clw > zero)then ! If dtb is larger than demissivity and dwmin contribution, ! it is assmued to be affected by rain and cloud, tossing it out do l=1,nchanl @@ -1450,18 +1507,27 @@ subroutine qc_gmi(nchanl,sfchgt,luse,sea,cenlat, & diff_em_36h = em36h - em2_36h ! check emissivity difference values against thresholds and assign flag if needed - if ( (diff_em_10h > 0.01_r_kind) .or. (diff_em_18h > 0.035_r_kind) .or. (diff_em_36h > 0.05_r_kind) ) then - do i=1,13 + if( .not. lcw4crtm_gmi)then + if ( (diff_em_10h > 0.01_r_kind) .or. (diff_em_18h > 0.035_r_kind) .or. (diff_em_36h > 0.05_r_kind) ) then + do i=1,13 varinv(1:13)=zero if (id_qc(i) == igood_qc) id_qc(i)=ifail_emiss_qc - end do - end if + end do + end if + else + do i=1,nchanl + if(clw < clwcutofx(i) .and. ((diff_em_10h > 0.01_r_kind) .or. (diff_em_18h > 0.035_r_kind) .or. (diff_em_36h > 0.05_r_kind))) then + varinv(i)=zero + if (id_qc(i) == igood_qc) id_qc(i)=ifail_emiss_qc + endif + enddo + endif ! check latitude. If obs is south of 55S or north of 55N, don't use it; it ! may be affected by sea ice. if (abs(cenlat)>55.0_r_kind) then do i=1,13 - varinv(1:13)=zero + varinv(i)=zero if (id_qc(i) == igood_qc) id_qc(i)=ifail_lat_qc end do end if @@ -1478,6 +1544,7 @@ subroutine qc_gmi(nchanl,sfchgt,luse,sea,cenlat, & efact = fact*efact vfact = fact*vfact end if + varinv(1:13)=zero end if ! Check for the observations at the scan edge (where only ch 1-9 are recorded) @@ -1494,6 +1561,20 @@ subroutine qc_gmi(nchanl,sfchgt,luse,sea,cenlat, & end do end if + if(tsavg5 < 275.0_r_kind)then + do l=1,nchanl + id_qc(l)=ifail_surface_qc + varinv(l)=zero + enddo + endif + + if(cenlat .gt. -20.0_r_kind .and. cenlat .lt. zero .and. cenlon .gt. 25.0_r_kind .and. cenlon .lt. 40.0_r_kind) then + do l=1,nchanl + id_qc(l)=ifail_surface_qc + varinv(l)=zero + enddo + endif + return end subroutine qc_gmi @@ -1850,7 +1931,7 @@ subroutine qc_saphir(nchanl,sfchgt,luse,sea, & end subroutine qc_saphir subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & - cris, zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tnoise, & + cris, hirs, zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole) ! id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole,radmod) ! all-sky @@ -1868,6 +1949,8 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! 2010-08-10 derber transfered from setuprad ! 2011-08-20 zhu add cloud qc for passive channels based on the cloud ! level determined by channels with irad_use=1 and 0 +! 2015-03-26 mkim add extra qc for sfc sensitive channels +! These qc are optional.(On/off by depending on the number in satinfo table) ! ! input argument list: ! nchanl - number of channels per obs @@ -1923,11 +2006,12 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & !$$$ end documentation block use kinds, only: r_kind, i_kind + use radinfo, only: iomg_det, itopo_det, isst_det implicit none ! Declare passed variables - logical, intent(in ) :: sea,land,ice,snow,luse,goessndr, cris + logical, intent(in ) :: sea,land,ice,snow,luse,goessndr, cris, hirs logical, intent(inout) :: zero_irjaco3_pole integer(i_kind), intent(in ) :: nsig,nchanl,ndat,is integer(i_kind),dimension(nchanl), intent(in ) :: ich @@ -1937,7 +2021,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & real(r_kind), intent(in ) :: tzbgr,tsavg5,zasat real(r_kind), intent( out) :: cld,cldp real(r_kind),dimension(40,ndat), intent(inout) :: aivals - real(r_kind),dimension(nchanl), intent(in ) :: tbc,emissivity_k,ts,wavenumber,tb_obs + real(r_kind),dimension(nchanl), intent(in ) :: tbc,emissivity_k,ts,wavenumber,tb_obs,tbcnob real(r_kind),dimension(nchanl), intent(in ) :: tnoise real(r_kind),dimension(nsig,nchanl),intent(in ) :: ptau5,temp,wmix real(r_kind),dimension(nsig), intent(in ) :: prsltmp,tvp @@ -1951,7 +2035,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & real(r_kind) :: demisf,dtempf,efact,dtbf,term,cenlatx,sfchgtfact real(r_kind) :: sum,sum2,sum3,cloudp,tmp,dts,delta real(r_kind),dimension(nchanl) :: dtb - integer(i_kind) :: i,j,k,kk,lcloud + integer(i_kind) :: i,j,k,kk,lcloud,m integer(i_kind), dimension(nchanl) :: irday real(r_kind) :: dtz,ts_ave,xindx,tzchks real(r_kind),parameter:: tbmax = 550._r_kind @@ -2202,6 +2286,95 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & end if end do + do i=1,nchanl + m=ich(i) + if (sea .and. isst_det(m) > 0 .and. tsavg5 < 274.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_isst_det + endif + end do + + + if(hirs) then + do i=1,nchanl + m=ich(i) + if (iomg_det(m) > 0 .and. i < 4 .and. abs(tbcnob(8)) > 40.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + if(iomg_det(m) > 0 .and. i == 12 .and. abs(tbcnob(8)) > 10.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif +!90S-60S + if(cenlat >= -90.0_r_kind .and. cenlat < -60.0_r_kind) then + if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 12.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 6.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 4.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif +!60S-30S + else if(cenlat >= -60.0_r_kind .and. cenlat < -30.0_r_kind) then + if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 10.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.5_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif +!30S-30N + else if(cenlat >= -30.0_r_kind .and. cenlat < 30.0_r_kind) then + if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 5.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + if(iomg_det(m) > 0 .and. i == 5 .and. (tbcnob(8) < -2.0_r_kind .or. tbcnob(8) > 3.0_r_kind)) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + if(iomg_det(m) > 0 .and. i == 6 .and. (tbcnob(8) < -1.5_r_kind .or. tbcnob(8) > 3.0_r_kind)) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif +!30N-60N + else if(cenlat >= 30.0_r_kind .and. cenlat < 60.0_r_kind) then + if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 8.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + endif !cenlat + + if (itopo_det(m) > 0 .and. zsges > 1500.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_itopo_det + endif + end do + endif !! if (hirs) +!---mkim + + + + return end subroutine qc_irsnd @@ -2222,6 +2395,7 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & ! ! program history log: ! 2011-04-08 li modified from qc_irsnd +! 2018-02-15 li : Zeroing dtb since it used outside the loop in which is defined ! ! input argument list: ! nchanl - number of channels per obs @@ -2375,6 +2549,10 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & lcloud=0 cld=zero cldp=r10*prsltmp(1) +! +! Zeroing dtb since it used outside the loop in which is defined +! + dtb=zero do k=1,nsig if(prsltmp(k) > trop5)then @@ -2498,8 +2676,8 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & end subroutine qc_avhrr subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & - zsges,cenlat,tb_obsbc1,cosza,clw,tbc,ptau5,emissivity_k,ts, & - pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,factch6, & + zsges,cenlat,tb_obsbc1,si_mean,cosza,clw,tbc,ptau5,emissivity_k,ts, & + pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,cldeff_fg,factch6, & cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod) !$$$ subprogram documentation block @@ -2528,6 +2706,7 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & ! speed for AMSUA/ATMS cloudy radiance assimilation ! 2015-09-20 zhu - add radmod to generalize all-sky condition for radiance ! 2016-10-13 zhu - add codes for assimilating non-precipitating cloudy ATMS over ocean +! 2019-03-13 eliu - add codes for assimilating precipitating-affected AMSUA/ATMS over ocean ! ! input argument list: ! nchanl - number of channels per obs @@ -2560,7 +2739,7 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & ! aivals - array holding sums for various statistics as a function of obs type ! errf - criteria of gross error ! varinv - observation weight (modified obs var error inverse) -! cldeff_obs - observed cloud effect +! cldeff_obs - observed cloud effect ! factch6 - precipitation screening using channel 6 ! ! attributes: @@ -2580,8 +2759,8 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & logical, intent(in ) :: sea,land,ice,snow,mixed,luse integer(i_kind), intent(in ) :: ndat,nsig,npred,nchanl,is integer(i_kind),dimension(nchanl), intent(inout) :: id_qc - real(r_kind), intent(in ) :: zsges,cenlat,tb_obsbc1 - real(r_kind),dimension(nchanl), intent(in ) :: cldeff_obs + real(r_kind), intent(in ) :: zsges,cenlat,tb_obsbc1,si_mean + real(r_kind),dimension(nchanl), intent(in ) :: cldeff_obs,cldeff_fg real(r_kind), intent(in ) :: cosza,clw,clwp_amsua,clw_guess_retrieval real(r_kind), intent(in ) :: sfc_speed,scatp real(r_kind), intent(inout) :: factch6 @@ -2722,7 +2901,7 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & else ! QC for all-sky condition - if (radmod%lcloud_fwd) then + if (radmod%lcloud_fwd) then ! all-sky check qc4emiss=.false. if(.not. sea) then if(factch6 >= one .or. latms_surfaceqc) then @@ -2790,85 +2969,147 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & else !QC for data over open water ! calcalculate scattering index ! screen out channels 1 to 6, and 15 if channel 6 is affected by precipitation - if(factch6 >= one)then - efactmc=zero - vfactmc=zero - errf(1:ich544)=zero - varinv(1:ich544)=zero - do i=1,ich544 - if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch6_qc - end do - if(id_qc(ich890) == igood_qc)id_qc(ich890)=ifail_factch6_qc - errf(ich890) = zero - varinv(ich890) = zero - if (latms) then - do i=17,22 ! AMSU-B/MHS like channels - if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch6_qc - errf(i) = zero - varinv(i) = zero - enddo - endif -! QC3 in statsrad - if(.not. mixed.and. luse)aivals(10,is) = aivals(10,is) + one - else if (cldeff_obs(ich536) < -0.50_r_kind) then - efactmc=zero - vfactmc=zero - errf(1:ich544)=zero - varinv(1:ich544)=zero - do i=1,ich544 - if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch5_qc - end do - if(id_qc(ich890) == igood_qc)id_qc(ich890)=ifail_factch5_qc - errf(ich890) = zero - varinv(ich890) = zero - if (latms) then - do i=17,22 ! AMSU-B/MHS like channels + ! for precipitating clouds + if(radmod%lprecip) then + if (cldeff_obs(ich536) < -0.50_r_kind .or. cldeff_fg(ich536) < -0.5_r_kind) then + efactmc=zero + vfactmc=zero + errf(1:ich544)=zero + varinv(1:ich544)=zero + do i=1,ich544 if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch5_qc - errf(i) = zero - varinv(i) = zero - enddo - endif - else if (latms) then - if (abs(cldeff_obs(16)-cldeff_obs(17))>10.0_r_kind) then - if(id_qc(ich890) == igood_qc)id_qc(ich890)=ifail_factch1617_qc + end do + if(id_qc(ich890) == igood_qc)id_qc(ich890)=ifail_factch5_qc errf(ich890) = zero varinv(ich890) = zero - do i=17,22 ! AMSU-B/MHS like channels - if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch1617_qc - errf(i) = zero - varinv(i) = zero - enddo - if (abs(cldeff_obs(16)-cldeff_obs(17))>15.0_r_kind) then + if (latms) then + do i=17,22 ! AMSU-B/MHS like channels + if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch5_qc + errf(i) = zero + varinv(i) = zero + enddo + endif + else if (latms) then + if (si_mean >= 20.0_r_kind) then efactmc=zero vfactmc=zero + if(id_qc(ich890) == igood_qc)id_qc(ich890)=ifail_factch1617_qc + errf(ich890) = zero + varinv(ich890) = zero + do i=17,22 ! AMSU-B/MHS like channels + if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch1617_qc + errf(i) = zero + varinv(i) = zero + enddo errf(1:ich544)=zero varinv(1:ich544)=zero do i=1,ich544 if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch1617_qc end do end if + else ! QC based on the sensitivity of Tb to the surface emissivity +! de1,de2,de3,de15 become smaller as the observation is more cloudy -- +! i.e., less affected by the surface emissivity quality control check + thrd1=0.025_r_kind + thrd2=0.015_r_kind + thrd3=0.030_r_kind + thrd15=0.030_r_kind + dtde1 = emissivity_k(ich238) + de1 = zero + if (dtde1 /= zero) de1=abs(tbc(ich238))/dtde1*(errf0(ich238)/errf(ich238))*(one-max(one,10.0_r_kind*clwp_amsua)) + dtde2 = emissivity_k(ich314) + de2 = zero + if (dtde2 /= zero) de2=abs(tbc(ich314))/dtde2*(errf0(ich314)/errf(ich314))*(one-max(one,10.0_r_kind*clwp_amsua)) + dtde3 = emissivity_k(ich503) + de3 = zero + if (dtde3 /= zero) de3=abs(tbc(ich503))/dtde3*(errf0(ich503)/errf(ich503))*(one-max(one,10.0_r_kind*clwp_amsua)) + dtde15= emissivity_k(ich890) + de15 = zero + if (dtde15 /= zero) de15=abs(tbc(ich890))/dtde15*(errf0(ich890)/errf(ich890))*(one-max(one,10.0_r_kind*clwp_amsua)) + qc4emiss= de2>thrd2 .or. de3>thrd3 .or. de1>thrd1 .or. de15>thrd15 end if - else ! QC based on the sensitivity of Tb to the surface emissivity -! de1,de2,de3,de15 become smaller as the observation is more cloudy -- -! i.e., less affected by the surface emissivity quality control check - thrd1=0.025_r_kind - thrd2=0.015_r_kind - thrd3=0.030_r_kind - thrd15=0.030_r_kind - dtde1 = emissivity_k(ich238) - de1 = zero - if (dtde1 /= zero) de1=abs(tbc(ich238))/dtde1*(errf0(ich238)/errf(ich238))*(one-max(one,10.0_r_kind*clwp_amsua)) - dtde2 = emissivity_k(ich314) - de2 = zero - if (dtde2 /= zero) de2=abs(tbc(ich314))/dtde2*(errf0(ich314)/errf(ich314))*(one-max(one,10.0_r_kind*clwp_amsua)) - dtde3 = emissivity_k(ich503) - de3 = zero - if (dtde3 /= zero) de3=abs(tbc(ich503))/dtde3*(errf0(ich503)/errf(ich503))*(one-max(one,10.0_r_kind*clwp_amsua)) - dtde15= emissivity_k(ich890) - de15 = zero - if (dtde15 /= zero) de15=abs(tbc(ich890))/dtde15*(errf0(ich890)/errf(ich890))*(one-max(one,10.0_r_kind*clwp_amsua)) - qc4emiss= de2>thrd2 .or. de3>thrd3 .or. de1>thrd1 .or. de15>thrd15 - endif + else + ! for non-precipitation clouds + if(factch6 >= one)then + efactmc=zero + vfactmc=zero + errf(1:ich544)=zero + varinv(1:ich544)=zero + do i=1,ich544 + if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch6_qc + end do + if(id_qc(ich890) == igood_qc)id_qc(ich890)=ifail_factch6_qc + errf(ich890) = zero + varinv(ich890) = zero + if (latms) then + do i=17,22 ! AMSU-B/MHS like channels + if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch6_qc + errf(i) = zero + varinv(i) = zero + enddo + endif + ! QC3 in statsrad + if(.not. mixed.and. luse)aivals(10,is) = aivals(10,is) + one + else if (cldeff_obs(ich536) < -0.50_r_kind) then + efactmc=zero + vfactmc=zero + errf(1:ich544)=zero + varinv(1:ich544)=zero + do i=1,ich544 + if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch5_qc + end do + if(id_qc(ich890) == igood_qc)id_qc(ich890)=ifail_factch5_qc + errf(ich890) = zero + varinv(ich890) = zero + if (latms) then + do i=17,22 ! AMSU-B/MHS like channels + if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch5_qc + errf(i) = zero + varinv(i) = zero + enddo + endif + else if (latms) then + if (abs(cldeff_obs(16)-cldeff_obs(17))>10.0_r_kind) then + if(id_qc(ich890) == igood_qc)id_qc(ich890)=ifail_factch1617_qc + errf(ich890) = zero + varinv(ich890) = zero + do i=17,22 ! AMSU-B/MHS like channels + if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch1617_qc + errf(i) = zero + varinv(i) = zero + enddo + if (abs(cldeff_obs(16)-cldeff_obs(17))>15.0_r_kind) then + efactmc=zero + vfactmc=zero + errf(1:ich544)=zero + varinv(1:ich544)=zero + do i=1,ich544 + if(id_qc(i) == igood_qc)id_qc(i)=ifail_factch1617_qc + end do + end if + end if + else ! QC based on the sensitivity of Tb to the surface emissivity + ! de1,de2,de3,de15 become smaller as the observation is more cloudy -- + ! i.e., less affected by the surface emissivity quality control check + thrd1=0.025_r_kind + thrd2=0.015_r_kind + thrd3=0.030_r_kind + thrd15=0.030_r_kind + dtde1 = emissivity_k(ich238) + de1 = zero + if (dtde1 /= zero) de1=abs(tbc(ich238))/dtde1*(errf0(ich238)/errf(ich238))*(one-max(one,10.0_r_kind*clwp_amsua)) + dtde2 = emissivity_k(ich314) + de2 = zero + if (dtde2 /= zero) de2=abs(tbc(ich314))/dtde2*(errf0(ich314)/errf(ich314))*(one-max(one,10.0_r_kind*clwp_amsua)) + dtde3 = emissivity_k(ich503) + de3 = zero + if (dtde3 /= zero) de3=abs(tbc(ich503))/dtde3*(errf0(ich503)/errf(ich503))*(one-max(one,10.0_r_kind*clwp_amsua)) + dtde15= emissivity_k(ich890) + de15 = zero + if (dtde15 /= zero) de15=abs(tbc(ich890))/dtde15*(errf0(ich890)/errf(ich890))*(one-max(one,10.0_r_kind*clwp_amsua)) + qc4emiss= de2>thrd2 .or. de3>thrd3 .or. de1>thrd1 .or. de15>thrd15 + endif + endif ! radmod%lprecip endif ! if sea ! QC for clear condition else ! @@ -2966,7 +3207,7 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & end if end if end if - endif ! + endif ! all-sky chk if (qc4emiss) then ! QC2 in statsrad @@ -2990,7 +3231,7 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & endif end if -end if + end if ! Apply to both clear and all-sky condition ! Reduce q.c. bounds over higher topography @@ -3222,8 +3463,8 @@ subroutine qc_mhs(nchanl,ndat,nsig,is,sea,land,ice,snow,mhs,luse, & end subroutine qc_mhs subroutine qc_atms(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & - zsges,cenlat,tb_obsbc1,cosza,clw,tbc,ptau5,emissivity_k,ts, & - pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,factch6, & + zsges,cenlat,tb_obsbc1,si_mean,cosza,clw,tbc,ptau5,emissivity_k,ts, & + pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,cldeff_fg,factch6, & cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod) !$$$ subprogram documentation block @@ -3295,13 +3536,13 @@ subroutine qc_atms(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & logical, intent(in ) :: sea,land,ice,snow,mixed,luse integer(i_kind), intent(in ) :: nchanl,is,ndat,nsig,npred integer(i_kind),dimension(nchanl), intent(inout) :: id_qc - real(r_kind), intent(in ) :: zsges,cenlat,tb_obsbc1 - real(r_kind),dimension(nchanl), intent(in ) :: cldeff_obs + real(r_kind), intent(in ) :: zsges,cenlat,tb_obsbc1,si_mean + real(r_kind),dimension(nchanl), intent(in ) :: cldeff_obs, cldeff_fg real(r_kind), intent(in ) :: cosza,clw,clwp_amsua,clw_guess_retrieval real(r_kind), intent(in ) :: sfc_speed,scatp real(r_kind), intent(inout) :: factch6 real(r_kind),dimension(40,ndat), intent(inout) :: aivals - real(r_kind),dimension(nchanl), intent(in ) :: tbc,emissivity_k,ts + real(r_kind),dimension(nchanl), intent(in ) :: tbc,emissivity_k,ts real(r_kind),dimension(nsig,nchanl), intent(in ) :: ptau5 real(r_kind),dimension(npred,nchanl),intent(in ) :: pred,predchan real(r_kind),dimension(nchanl), intent(inout) :: errf,errf0,varinv @@ -3311,8 +3552,8 @@ subroutine qc_atms(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & ! For now, just pass all channels to qc_amsua call qc_amsua (nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & - zsges,cenlat,tb_obsbc1,cosza,clw,tbc,ptau5,emissivity_k,ts, & - pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,factch6, & + zsges,cenlat,tb_obsbc1,si_mean,cosza,clw,tbc,ptau5,emissivity_k,ts, & + pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,cldeff_fg,factch6, & cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod) return @@ -3755,6 +3996,341 @@ subroutine qc_seviri(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & return end subroutine qc_seviri + +subroutine qc_abi(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & + zsges,trop5,tzbgr,tsavg5,tb_obs_sdv,tbc,tb_obs,tnoise,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & +! id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole) + id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax) + +!$$$ subprogram documentation block +! . . . +! subprogram: qc_abi QC for ABI data +! +! prgmmr: H.Liu org: np23 date: 2018-05-20 +! +! abstract: set quality control criteria for ABI data +! +! program history log: +! 2018-05-20 H.Liu initially added into qcmod +! +! input argument list: +! nchanl - number of channels per obs +! ich - channel number +! is - integer counter for number of observation types to process +! sea - logical, sea flag +! land - logical, land flag +! ice - logical, ice flag +! snow - logical, snow flag +! luse - logical use flag +! zsges - elevation of guess +! trop5 - tropopause pressure +! tzbgr - Tz over water + +! tsavg5 - surface skin temperature +! tbc - simulated - observed BT with bias correction +! tb_obs - observed Brightness temperatures +! tnoise - channel noise array +! ptau5 - transmittances as a function of level and channel + + +! prsltmp - array of layer pressures in vertical (surface to toa) +! tvp - array of temperatures in vertical (surface to toa) +! temp - temperature sensitivity array +! wmix - moisture sensitivity array +! emissivity_k - surface emissivity sensitivity +! ts - skin temperature sensitivity +! id_qc - qc index - see qcmod definition +! aivals - array holding sums for various statistics as a function of obs type +! errf - criteria of gross error +! varinv - observation weight (modified obs var error inverse) +! varinv_use - observation weight used(modified obs var error inverse) +! +! output argument list: +! id_qc - qc index - see qcmod definition +! aivals - array holding sums for various statistics as a function of obs type +! errf - criteria of gross error +! varinv - observation weight (modified obs var error inverse) +! varinv_use - observation weight used(modified obs var error inverse) +! cld - cloud fraction +! cldp - cloud pressure +! zero_irjaco3_pole - logical to control use of ozone jacobians near poles +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: r_kind, i_kind + implicit none + +! Declare passed variables + + logical, intent(in ) :: sea,land,ice,snow,luse + integer(i_kind), intent(in ) :: nchanl,ndat,nsig,is + integer(i_kind),dimension(nchanl),intent(in ) :: ich + integer(i_kind),dimension(nchanl),intent(inout) :: id_qc + integer(i_kind),dimension(nchanl), intent(in ) :: kmax + real(r_kind), intent(in ) :: zsges + real(r_kind), intent(in ) :: tzbgr + real(r_kind),dimension(40,ndat), intent(inout) :: aivals + real(r_kind),dimension(nchanl), intent(in ) :: tbc,tnoise,emissivity_k,ts + real(r_kind),dimension(nsig,nchanl),intent(in ) :: temp,wmix + real(r_kind),dimension(nchanl), intent(inout) :: errf,varinv,varinv_use + real(r_kind), intent(in ) :: trop5,tsavg5 + real(r_kind),dimension(nchanl), intent(in ) :: tb_obs,tb_obs_sdv + real(r_kind),dimension(nsig,nchanl),intent(in ) :: ptau5 + real(r_kind),dimension(nsig), intent(in ) :: prsltmp,tvp + real(r_kind), intent( out) :: cld,cldp +! logical, intent(inout) :: zero_irjaco3_pole + +! Declare local parameters + real(r_kind) :: demisf,dtempf,sfchgtfact,term,dtbf,efact,vfact + real(r_kind) :: sum,sum2,sum3,cloudp,tmp,dts,delta + real(r_kind),dimension(nchanl) :: dtb + integer(i_kind) :: i,j,k,kk,lcloud + integer(i_kind), dimension(nchanl) :: irday + real(r_kind) :: dtz,ts_ave,xindx,tzchks + + if(sea)then + demisf = r0_01 + dtempf = half + else if(land)then + demisf = r0_02 + dtempf = two + else if(ice)then + demisf = r0_03 + dtempf = four + else if(snow)then + demisf = r0_02 + dtempf = two + else + demisf = r0_03 + dtempf = four + end if + +! Optionally turn off ozone jacabians near poles +! zero_irjaco3_pole=.false. +! if (qc_noirjaco3_pole .and. (abs(cenlat)>r60)) zero_irjaco3_pole=.true. + +! Reduce weight for obs over higher topography + sfchgtfact=one + if (zsges > r2000) then +! QC1 in statsrad + if(luse)aivals(8,is) = aivals(8,is) + one + sfchgtfact = (r2000/zsges)**4 + endif + + do i=1,nchanl + +! use chn 2, 3 and 4 over both sea and land while other IR chns only over sea + if (sea) then + efact=one + vfact=one + else if (land ) then + if (i == 2 .or. i ==3 .or. i==4 ) then + efact=one + vfact=one + else + efact=zero + vfact=zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_surface_qc + end if + else + efact=zero + vfact=zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_surface_qc + end if +! modified variances. + errf(i) = efact*errf(i) + varinv(i) = vfact*varinv(i) + varinv_use(i) = vfact*varinv_use(i) + end do + +! Generate q.c. bounds and modified variances for height change and ptau5 + sum3=zero + do i=1,nchanl + if (tb_obs(i) > r1000 .or. tb_obs(i) <= zero) then + varinv(i)=zero + varinv_use(i)=zero + end if + tmp=one-(one-sfchgtfact)*ptau5(1,i) + varinv(i) = varinv(i)*tmp + varinv_use(i) = varinv_use(i)*tmp + +! Modify error based on transmittance at top of model + varinv(i)=varinv(i)*ptau5(nsig,i) + varinv_use(i)=varinv_use(i)*ptau5(nsig,i) + errf(i)=errf(i)*ptau5(nsig,i) + +! QC based on presence/absence of cloud + sum3=sum3+tbc(i)*tbc(i)*varinv_use(i) + end do + sum3=0.75_r_kind*sum3 + lcloud=0 + cld=zero + cldp=r10*prsltmp(1) + + do k=1,nsig + if(prsltmp(k) > trop5)then + do i=1,nchanl + dtb(i)=(tvp(k)-tsavg5)*ts(i) + end do + do kk=1,k-1 + do i=1,nchanl + dtb(i)=dtb(i)+(tvp(k)-tvp(kk))*temp(kk,i) + end do + end do + sum=zero + sum2=zero + do i=1,nchanl + if(varinv_use(i) > tiny_r_kind)then + sum=sum+tbc(i)*dtb(i)*varinv_use(i) + sum2=sum2+dtb(i)*dtb(i)*varinv_use(i) + end if + end do + if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) + cloudp=min(max(sum/sum2,zero),one) + sum=zero + do i=1,nchanl + if(varinv_use(i) > tiny_r_kind)then + tmp=tbc(i)-cloudp*dtb(i) + sum=sum+tmp*tmp*varinv_use(i) + end if + end do + if(sum < sum3)then + sum3=sum + lcloud=k + cld=cloudp + cldp=r10*prsltmp(k) + end if + end if + + end do + if ( lcloud > 0 ) then ! If cloud detected, reject channels affected by it. + do i=1,nchanl + +! reject channels with iuse_rad(j)=-1 when they are peaking below the cloud + j=ich(i) + if (passive_bc .and. iuse_rad(j)==-1) then + if (lcloud >= kmax(i)) then + if(luse)aivals(11,is) = aivals(11,is) + one + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc + cycle + end if + end if + +! If more than 2% of the transmittance comes from the cloud layer, +! reject the channel (0.02 is a tunable parameter) + + delta = 0.02_r_kind + if ( ptau5(lcloud,i) > 0.02_r_kind) then +! QC4 in statsrad + if(luse)aivals(11,is) = aivals(11,is) + one + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc + end if + end do + +! If no clouds check surface temperature/emissivity + else ! If no cloud was detected, do surface temp/emiss checks + sum=zero + sum2=zero + do i=1,nchanl + sum=sum+tbc(i)*ts(i)*varinv_use(i) + sum2=sum2+ts(i)*ts(i)*varinv_use(i) + end do + if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) + dts=abs(sum/sum2) + if(abs(dts) > one)then + if(.not. sea)then + dts=min(dtempf,dts) + else + dts=min(three,dts) + end if + do i=1,nchanl + delta=max(r0_05*tnoise(i),r0_02) + if(abs(dts*ts(i)) > delta)then +! QC3 in statsrad + if(luse .and. varinv(i) > zero) & + aivals(10,is) = aivals(10,is) + one + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc + end if + end do + end if + endif + + do i = 1, nchanl + +! Tighter qc for chn7.3: toss data for chn7.3 and surface chns if rclrsky<98% (done in setuprad) or stdev >= 0.5 for chn10.3 + if(tb_obs_sdv(7)>=0.5_r_kind .and. varinv(i) > zero)then + if(i/=2 .and. i/=3) then +! QC3 in statsrad + if(luse)aivals(9,is)= aivals(9,is) + one + if(id_qc(i) == igood_qc ) id_qc(i)=ifail_std_abi_qc + varinv(i)=zero + end if + end if + +! adjust varinv according to the BT standard deviation + if( i== 2 .or. i==3 .or. i==4 .and. varinv(i) > zero) then + if (tb_obs_sdv(2) >0.4_r_kind .and. tb_obs_sdv(2) <=0.5_r_kind) & + varinv(i)=varinv(i)/1.32_r_kind + if (tb_obs_sdv(2) >0.5_r_kind .and. tb_obs_sdv(2) <=0.6_r_kind) & + varinv(i)=varinv(i)/1.67_r_kind + if (tb_obs_sdv(2) >0.6_r_kind .and. tb_obs_sdv(2) <=0.7_r_kind) & + varinv(i)=varinv(i)/2.24_r_kind + if (tb_obs_sdv(2) >0.7_r_kind ) & + varinv(i)=varinv(i)/2.31_r_kind + end if + + end do +! +! Apply Tz retrieval +! + if(tzr_qc > 0)then + dtz = rmiss_single + if ( sea ) then + call tz_retrieval(nchanl,nsig,ich,irday,temp,wmix,tnoise,varinv,ts,tbc,tzbgr,1,0,dtz,ts_ave) + endif +! +! Apply QC with Tz retrieval +! + if (dtz /= rmiss_single ) then + do i = 1, nchanl + if ( varinv(i) > tiny_r_kind .and. iuse_rad(ich(i)) >= 1 .and. ts(i) > tschk ) then + xindx = ((ts(i)-ts_ave)/(one-ts_ave))**3 + tzchks = tzchk*(half)**xindx + + if ( abs(dtz) > tzchks ) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_tzr_qc + if(luse)aivals(13,is) = aivals(13,is) + one + endif + endif + enddo + endif + end if + +! Generate q.c. bounds and modified variances. + do i=1,nchanl + if(varinv(i) > tiny_r_kind)then + dtbf = demisf*abs(emissivity_k(i))+dtempf*abs(ts(i)) + term = dtbf*dtbf + if(term > tiny_r_kind)varinv(i)=varinv(i)/(one+varinv(i)*term) + end if + end do + + + return + +end subroutine qc_abi + + subroutine qc_goesimg(nchanl,is,ndat,nsig,ich,dplat,sea,land,ice,snow,luse, & zsges,cld,tzbgr,tb_obs,tb_obs_sdv,tbc,tnoise,temp,wmix,emissivity_k,ts, & id_qc,aivals,errf,varinv) diff --git a/src/qnewton3.f90 b/src/gsi/qnewton3.f90 similarity index 100% rename from src/qnewton3.f90 rename to src/gsi/qnewton3.f90 diff --git a/src/gsi/radiance_mod.f90 b/src/gsi/radiance_mod.f90 new file mode 100644 index 000000000..9b677730f --- /dev/null +++ b/src/gsi/radiance_mod.f90 @@ -0,0 +1,1341 @@ +module radiance_mod +!$$$ module documentation block +! . . . . +! module: radiance_mod +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 +! +! abstract: This module contains variables and routines related +! to cloud and aerosol usages for radiance assimilation +! +! program history log: +! 2015-07-20 Yanqiu Zhu +! 2016-10-27 Yanqiu - add ATMS +! +! subroutines included: +! sub radiance_mode_init - guess init +! radiance_mode_destroy +! radiance_obstype_init +! radiance_obstype_search +! radiance_obstype_destroy +! radiance_parameter_cloudy_init +! radiance_parameter_aerosol_init +! radiance_ex_obserr +! radiance_ex_biascor +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + +! !USES: + + use kinds, only: r_kind,i_kind + use constants, only: zero,half + use mpimod, only: mype + implicit none + save + +! set subroutines to public + public :: radiance_mode_init + public :: radiance_mode_destroy + public :: radiance_obstype_init + public :: radiance_obstype_search + public :: radiance_obstype_destroy + public :: radiance_parameter_cloudy_init + public :: radiance_parameter_aerosol_init + public :: radiance_ex_obserr + public :: radiance_ex_obserr_gmi + public :: radiance_ex_biascor + public :: radiance_ex_biascor_gmi + + public :: icloud_fwd,icloud_cv,iallsky,cw_cv,ql_cv + public :: n_actual_clouds,n_clouds_fwd,n_clouds_jac + public :: cloud_names,cloud_names_jac,cloud_names_fwd + public :: idx_cw,idx_ql,idx_qi,idx_qr,idx_qs,idx_qg,idx_qh + + public :: iaerosol_fwd,iaerosol_cv,iaerosol + public :: n_actual_aerosols,n_aerosols_fwd,n_aerosols_jac + public :: aerosol_names,aerosol_names_fwd,aerosol_names_jac + + public :: total_rad_type + public :: rad_type_info + public :: total_aod_type + public :: aod_type_info + + public :: rad_obs_type + + interface radiance_ex_obserr + module procedure radiance_ex_obserr_1 + module procedure radiance_ex_obserr_2 +! module procedure radiance_ex_obserr_3 !for GMI + end interface + + interface radiance_ex_biascor + module procedure radiance_ex_biascor_1 + module procedure radiance_ex_biascor_2 +! module procedure radiance_ex_biascor_3 ! for GMI + end interface + + character(len=20),save,allocatable,dimension(:) :: cloud_names + character(len=20),save,allocatable,dimension(:) :: cloud_names_fwd + character(len=20),save,allocatable,dimension(:) :: cloud_names_jac + character(len=20),save,allocatable,dimension(:) :: aerosol_names + character(len=20),save,allocatable,dimension(:) :: aerosol_names_fwd + character(len=20),save,allocatable,dimension(:) :: aerosol_names_jac + logical :: icloud_fwd,icloud_cv,iallsky,cw_cv,ql_cv + logical :: iaerosol_fwd,iaerosol_cv,iaerosol,iprecip + integer(i_kind) :: n_actual_clouds,n_clouds_jac,n_clouds_fwd + integer(i_kind) :: n_actual_aerosols,n_aerosols_fwd,n_aerosols_jac + integer(i_kind) :: idx_cw,idx_ql,idx_qi,idx_qr,idx_qs,idx_qg,idx_qh + + integer(i_kind) :: total_rad_type + integer(i_kind) :: total_aod_type + + type rad_obs_type + character(len=10) :: rtype ! instrument + integer(i_kind) :: nchannel ! total channel number +! character(len=8) :: cfoption ! cloud fraction option: gmao_lcf4crtm, emc_lcf4crtm + character(len=10) :: ex_obserr ! indicator for special obs error assignment: ex_obserr1 or ex_obserr2 + logical :: cld_sea_only ! .true. only perform all-sky over ocean + logical :: ex_biascor ! .true. for special bias correction + logical :: cld_effect ! .true. additional cloud effect quality control + logical :: lcloud_fwd,lallsky + logical :: lprecip + integer(i_kind),pointer,dimension(:) :: lcloud4crtm=> NULL() ! -1 clear-sky; 0 forwad operator only; 1 iallsky + logical :: laerosol_fwd,laerosol + integer(i_kind),pointer,dimension(:) :: laerosol4crtm => NULL() ! -1 no aero used; 0 forwad operator only; 1 iaerosol + real(r_kind),pointer,dimension(:) :: cclr => NULL() + real(r_kind),pointer,dimension(:) :: ccld => NULL() + real(r_kind),pointer,dimension(:) :: cldval1 => NULL() + end type rad_obs_type + + type(rad_obs_type),save,dimension(:),allocatable :: rad_type_info + type(rad_obs_type),save,dimension(:),allocatable :: aod_type_info + +contains + + subroutine radiance_mode_init +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_mode_init +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 +! +! abstract: This routine sets default values for variables used in +! the radiance processing routines. +! +! program history log: +! 2015-07-20 zhu +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + + use kinds, only: i_kind,r_kind + use gsi_metguess_mod, only: gsi_metguess_get + use gsi_chemguess_mod, only: gsi_chemguess_get + use mpeu_util, only: getindex + use control_vectors, only: cvars3d + implicit none + + integer(i_kind) icw_av,iql_av,iqi_av,iqtotal,ier + integer(i_kind) iqr,iqs,iqg + integer(i_kind) indx_p25,indx_dust1,indx_dust2,ip25_av,idust1_av,idust2_av + +! initialize variables + icloud_fwd=.false. + icloud_cv=.false. + iallsky=.false. + cw_cv=.false. + ql_cv=.false. + + n_actual_clouds=0 + n_clouds_fwd=0 + n_clouds_jac=0 + + iaerosol_fwd=.false. + iaerosol_cv=.false. + iaerosol=.false. + + iprecip=.false. + + n_actual_aerosols=0 + n_aerosols_fwd=0 + n_aerosols_jac=0 + +! inquire number of clouds + call gsi_metguess_get ( 'clouds::3d', n_actual_clouds, ier ) + if (n_actual_clouds>0) then + allocate(cloud_names(n_actual_clouds)) + call gsi_metguess_get ('clouds::3d', cloud_names, ier) + call gsi_metguess_get ('clouds_4crtm_fwd::3d', n_clouds_fwd, ier) + n_clouds_fwd=max(0,n_clouds_fwd) + if (n_clouds_fwd>0) then + icloud_fwd=.true. + allocate(cloud_names_fwd(max(n_clouds_fwd,1))) + call gsi_metguess_get ('clouds_4crtm_fwd::3d', cloud_names_fwd, ier) + + call gsi_metguess_get ('clouds_4crtm_jac::3d', n_clouds_jac, ier ) + n_clouds_jac=max(0,n_clouds_jac) + if (n_clouds_jac>0) then + allocate(cloud_names_jac(max(n_clouds_jac,1))) + call gsi_metguess_get ('clouds_4crtm_jac::3d', cloud_names_jac, ier) + end if + iqr = getindex(cloud_names_fwd,'qr') + iqs = getindex(cloud_names_fwd,'qs') + iqg = getindex(cloud_names_fwd,'qg') + if (iqr>0 .or. iqs>0 .or. iqg>0) iprecip = .true. + end if + +! inquire number of clouds to participate in CRTM calculations + call gsi_metguess_get ( 'i4crtm::ql', idx_ql, ier ) + call gsi_metguess_get ( 'i4crtm::qi', idx_qi, ier ) + call gsi_metguess_get ( 'i4crtm::qr', idx_qr, ier ) + call gsi_metguess_get ( 'i4crtm::qs', idx_qs, ier ) + call gsi_metguess_get ( 'i4crtm::qg', idx_qg, ier ) + call gsi_metguess_get ( 'i4crtm::qh', idx_qh, ier ) +! if (idx_ql>10 .or. idx_qi>10 .or. idx_qr>10 .or. idx_qs>10 & +! .or. idx_qg>10 .or. idx_qh>10) icloud_fwd=.true. + +! Determine whether or not cloud-condensate is the control variable +! (ges_cw=ges_ql+ges_qi) + icw_av=getindex(cvars3d,'cw') + iql_av=getindex(cvars3d,'ql') + iqi_av=getindex(cvars3d,'qi') + +! Determine whether or not total moisture (water vapor+total cloud +! condensate) is the control variable + iqtotal=getindex(cvars3d,'qt') + + if (icw_av>0) cw_cv=.true. + if (iql_av>0) ql_cv=.true. + if (icw_av>0 .or. iql_av>0 .or. iqi_av>0 .or. iqtotal>0) icloud_cv=.true. + if (icloud_cv .and. icloud_fwd) iallsky=.true. + + end if ! end of (n_actual_clouds>0) + + +! inquire number of aerosols + call gsi_chemguess_get ( 'aerosols::3d', n_actual_aerosols, ier ) + if (n_actual_aerosols > 0) then + iaerosol_fwd=.true. + allocate(aerosol_names(n_actual_aerosols)) + call gsi_chemguess_get ('aerosols::3d',aerosol_names,ier) + indx_p25 = getindex(aerosol_names,'p25') + indx_dust1 = getindex(aerosol_names,'dust1') + indx_dust2 = getindex(aerosol_names,'dust2') + + call gsi_chemguess_get ( 'aerosols_4crtm::3d', n_aerosols_fwd, ier ) + if (n_aerosols_fwd >0) then + allocate(aerosol_names_fwd(n_aerosols_fwd)) + call gsi_chemguess_get ( 'aerosols_4crtm::3d', aerosol_names_fwd, ier) + end if + call gsi_chemguess_get ( 'aerosols_4crtm_jac::3d', n_aerosols_jac, ier ) + if (n_aerosols_jac >0) then + allocate(aerosol_names_jac(n_aerosols_jac)) + call gsi_chemguess_get ( 'aerosols_4crtm_jac::3d', aerosol_names_jac, ier) + end if + endif + +! Determine whether aerosols are control variables + ip25_av=getindex(cvars3d,'p25') + idust1_av=getindex(cvars3d,'dust1') + idust2_av=getindex(cvars3d,'dust2') + if (ip25_av>0 .or. idust1_av>0 .or. idust2_av>0) iaerosol_cv=.true. + + if (iaerosol_cv .and. iaerosol_fwd) iaerosol=.true. + + if (mype==0) then + write(6,*) 'radiance_mode_init: icloud_fwd=',icloud_fwd,' iallsky=',iallsky, & + ' cw_cv=',cw_cv,' ql_cv=',ql_cv,' iaerosol_fwd=',iaerosol_fwd,' iaerosol=',iaerosol, & + ' iprecip=',iprecip + write(6,*) 'radiance_mode_init: n_actual_clouds=',n_actual_clouds + if (n_actual_clouds>0) write(6,*) 'radiance_mode_init: cloud_names=',cloud_names + write(6,*) 'radiance_mode_init: n_clouds_fwd=',n_clouds_fwd + if (n_clouds_fwd>0) write(6,*) 'radiance_mode_init: cloud_names_fwd=',cloud_names_fwd + write(6,*) 'radiance_mode_init: n_clouds_jac=',n_clouds_jac + if (n_clouds_jac>0) write(6,*) 'radiance_mode_init: cloud_names_jac=',cloud_names_jac + write(6,*) 'radiance_mode_init: n_actual_aerosols=',n_actual_aerosols + if (n_actual_aerosols>0) write(6,*) 'radiance_mode_init: aerosol_names=',aerosol_names + write(6,*) 'radiance_mode_init: n_aerosols_fwd=',n_aerosols_fwd + if (n_aerosols_fwd>0) write(6,*) 'radiance_mode_init: aerosol_names_fwd=',aerosol_names_fwd + write(6,*) 'radiance_mode_init: n_aerosols_jac=',n_aerosols_jac + if (n_aerosols_jac>0) write(6,*) 'radiance_mode_init: aerosol_names_jac=',aerosol_names_jac + end if + + end subroutine radiance_mode_init + + subroutine radiance_mode_destroy +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_mode_destroy +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 +! +! abstract: This routine deallocate arrays +! +! program history log: +! 2015-07-20 zhu +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + + implicit none + + if(allocated(cloud_names)) deallocate(cloud_names) + if(allocated(cloud_names_fwd)) deallocate(cloud_names_fwd) + if(allocated(cloud_names_jac)) deallocate(cloud_names_jac) + + if(allocated(aerosol_names)) deallocate(aerosol_names) + if(allocated(aerosol_names_fwd)) deallocate(aerosol_names_fwd) + if(allocated(aerosol_names_jac)) deallocate(aerosol_names_jac) + + end subroutine radiance_mode_destroy + + subroutine radiance_obstype_init +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_obstype_init +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 +! +! abstract: This routine sets default values for variables used in +! the cloudy/with aerosol radiance processing routines. +! +! program history log: +! 2015-07-20 zhu -- initial code +! 2018-04-04 zhu -- move rad_type_info(k)%cclr and rad_type_info(k)%ccld to this subroutine +! 2018-04-06 derber -- change rad_type_info(k)%cclr default value from zero to a large number +! 2019-03-21 Wei/Martin - fix capabilities for AOD assimilation +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + + use kinds, only: i_kind,r_kind + use radinfo, only: nusis,jpch_rad,icloud4crtm,iaerosol4crtm + use obsmod, only: ndat,dtype,dsis + use gsi_io, only: verbose + use chemmod, only: laeroana_gocart, lread_ext_aerosol + implicit none + + logical :: first,diffistr,found + integer(i_kind) :: i,j,k,ii,nn1,nn2,nn + integer(i_kind),dimension(ndat) :: k2i + character(10),dimension(ndat) :: rtype,rrtype,drtype + logical print_verbose + + print_verbose=.false. + if(verbose)print_verbose=.true. +! Cross-check + do j=1,jpch_rad + if (icloud4crtm(j)>=0) then + if (.not. iallsky) icloud4crtm(j)=0 + if (.not. icloud_fwd) icloud4crtm(j)=-1 + end if + if (iaerosol4crtm(j)>=0) then + if (.not. iaerosol) iaerosol4crtm(j)=0 + if (.not. iaerosol_fwd) iaerosol4crtm(j)=-1 + end if + end do + + if (icloud_fwd .and. all(icloud4crtm<0)) then + icloud_fwd=.false. + iallsky=.false. + n_clouds_fwd=0 + n_clouds_jac=0 + cloud_names_fwd=' ' + cloud_names_jac=' ' + end if + + if (iaerosol_fwd .and. all(iaerosol4crtm<0)) then + iaerosol=.false. + if ( .not. laeroana_gocart ) then + iaerosol_fwd=.false. + n_aerosols_fwd=0 + n_aerosols_jac=0 + aerosol_names_fwd=' ' + aerosol_names_jac=' ' + end if + end if + + if (iallsky .and. all(icloud4crtm<1)) then + iallsky=.false. + n_clouds_jac=0 + cloud_names_jac=' ' + end if + + if (iaerosol .and. all(iaerosol4crtm<1)) then + iaerosol=.false. + n_aerosols_jac=0 + aerosol_names_jac=' ' + end if + +! determine rads type + drtype='other' + do i=1,ndat + rtype(i)=dtype(i) ! rtype - observation types to process + if (index(dtype(i),'amsre') /= 0) rtype(i)='amsre' + if (index(dtype(i),'ssmis') /= 0) rtype(i)='ssmis' + if (index(dtype(i),'sndr') /= 0) rtype(i)='sndr' + if (index(dtype(i),'hirs') /= 0) rtype(i)='hirs' + if (index(dtype(i),'avhrr') /= 0) rtype(i)='avhrr' + if (index(dtype(i),'modis') /= 0) rtype(i)='modis' + if (index(dtype(i),'seviri') /= 0) rtype(i)='seviri' + + if(rtype(i) == 'hirs' .or. rtype(i) == 'sndr' .or. rtype(i) == 'seviri' .or. & + rtype(i) == 'airs' .or. rtype(i) == 'amsua' .or. rtype(i) == 'msu' .or. & + rtype(i) == 'iasi' .or. rtype(i) == 'amsub' .or. rtype(i) == 'mhs' .or. & + rtype(i) == 'hsb' .or. rtype(i) == 'goes_img' .or. rtype(i) == 'ahi' .or. & + rtype(i) == 'avhrr' .or. rtype(i) == 'amsre' .or. rtype(i) == 'ssmis' .or. & + rtype(i) == 'ssmi' .or. rtype(i) == 'atms' .or. rtype(i) == 'cris' .or. & + rtype(i) == 'amsr2' .or. rtype(i) == 'gmi' .or. rtype(i) == 'saphir' .or. & + rtype(i) == 'cris-fsr' ) then + drtype(i)='rads' + end if + end do + +! Determine total rad types + k=0 + k2i=0 + first=.true. + rrtype='' + do i=1,ndat + if (drtype(i) /= 'rads') cycle + + found=.false. + if (first) then + k=k+1 + rrtype(k)=rtype(i) + k2i(k)=i + first=.false. + else + do j=1,k + if (trim(rtype(i)) == trim(rrtype(j))) then + found=.true. + exit + end if + end do + if (.not. found) then + k=k+1 + rrtype(k)=rtype(i) + k2i(k)=i + end if + end if + end do + total_rad_type=k + if (mype==0) write(6,*) 'radiance_obstype_init: total_rad_type=', k,' types are: ', rrtype(1:total_rad_type) + + if (total_rad_type<=0) return + + allocate(rad_type_info(total_rad_type)) + + do k=1, total_rad_type + rad_type_info(k)%rtype=rrtype(k) + rad_type_info(k)%cld_sea_only=.false. +! rad_type_info(k)%ex_obserr=.false. + rad_type_info(k)%ex_obserr=' ' + rad_type_info(k)%ex_biascor=.false. + rad_type_info(k)%cld_effect=.false. + rad_type_info(k)%lcloud_fwd=.false. + rad_type_info(k)%lprecip=.false. + rad_type_info(k)%lallsky=.false. + rad_type_info(k)%laerosol_fwd=.false. + rad_type_info(k)%laerosol=.false. + + if (iprecip) rad_type_info(k)%lprecip=.true. + + ii=k2i(k) + first=.true. + nn1=0 + nn2=0 + do j=1,jpch_rad + if (j==jpch_rad) then + diffistr = .true. + else + diffistr = trim(nusis(j))/=trim(nusis(j+1)) + end if + if (trim(dsis(ii))==trim(nusis(j))) then +! if (index(trim(nusis(j)),trim(rrtype(k))) /= 0) then + if (first) then + nn1=j + first=.false. + else + nn2=j + end if + if (diffistr) exit + end if + end do + if (nn1/=0 .and. nn2/=0) then + rad_type_info(k)%nchannel=nn2-nn1+1 + else + cycle + end if + +! determine usages of cloud and aerosol in each type + allocate(rad_type_info(k)%lcloud4crtm(rad_type_info(k)%nchannel)) + allocate(rad_type_info(k)%laerosol4crtm(rad_type_info(k)%nchannel)) + nn=0 + do j=nn1,nn2 + nn=nn+1 + rad_type_info(k)%lcloud4crtm(nn)=icloud4crtm(j) + rad_type_info(k)%laerosol4crtm(nn)=iaerosol4crtm(j) + + if (icloud4crtm(j)<0 .and. iaerosol4crtm(j)<0) cycle + if (.not. rad_type_info(k)%lallsky) then + if (icloud4crtm(j)==1) then + rad_type_info(k)%lallsky=.true. + rad_type_info(k)%lcloud_fwd=.true. + end if + end if + if (.not. rad_type_info(k)%lcloud_fwd) then + if (icloud4crtm(j)==0) rad_type_info(k)%lcloud_fwd=.true. + end if + if (.not. rad_type_info(k)%laerosol) then + if (iaerosol4crtm(j)==1) then + rad_type_info(k)%laerosol=.true. + rad_type_info(k)%laerosol_fwd=.true. + end if + end if + if (.not. rad_type_info(k)%laerosol_fwd) then + if (iaerosol4crtm(j)==0) rad_type_info(k)%laerosol_fwd=.true. + end if + end do + + if (mype==0 .and. print_verbose) & + write(6,*) 'radiance_obstype_init: type=', rad_type_info(k)%rtype, & + ' nch=',rad_type_info(k)%nchannel, & + ' lcloud_fwd=',rad_type_info(k)%lcloud_fwd, & + ' lprecip=',rad_type_info(k)%lprecip, & + ' lallsky=',rad_type_info(k)%lallsky, & + ' laerosol_fwd=',rad_type_info(k)%laerosol_fwd, & + ' laerosol=',rad_type_info(k)%laerosol + + allocate(rad_type_info(k)%cclr(rad_type_info(k)%nchannel)) + allocate(rad_type_info(k)%ccld(rad_type_info(k)%nchannel)) + allocate(rad_type_info(k)%cldval1(rad_type_info(k)%nchannel)) + rad_type_info(k)%cclr(:)=9999.9_r_kind + rad_type_info(k)%ccld(:)=zero + rad_type_info(k)%cldval1(:)=zero + + end do ! end total_rad_type + + end subroutine radiance_obstype_init + + subroutine radiance_obstype_search(obstype,radmod) +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_obstype_search find the rad_type_info(i) that +! matches the input obstype +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-08-20 +! +! abstract: +! +! program history log: +! 2015-08-20 zhu +! 2019-03-21 Wei/Martin - added in AOD type support +! +! input argument list: +! obstype +! +! output argument list: +! radmod +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + implicit none + character(10) :: obstype + type(rad_obs_type) :: radmod + logical match + integer(i_kind) i + + if (total_rad_type<=0 .and. total_aod_type<=0) return + + match=.false. + do i=1,total_rad_type + if (trim(rad_type_info(i)%rtype)=='msu') then + match=trim(obstype)==trim(rad_type_info(i)%rtype) + else + match=index(trim(obstype),trim(rad_type_info(i)%rtype)) /= 0 + end if + if (match) then +! if (mype==0) write(6,*) 'radiance_obstype_search: obstype=',obstype, & +! ' rtype=',rad_type_info(i)%rtype + radmod%rtype = rad_type_info(i)%rtype + radmod%nchannel = rad_type_info(i)%nchannel + radmod%cld_sea_only = rad_type_info(i)%cld_sea_only + radmod%cld_effect = rad_type_info(i)%cld_effect + radmod%ex_obserr = rad_type_info(i)%ex_obserr + radmod%ex_biascor = rad_type_info(i)%ex_biascor + + radmod%lcloud_fwd = rad_type_info(i)%lcloud_fwd + radmod%lallsky = rad_type_info(i)%lallsky + radmod%lcloud4crtm => rad_type_info(i)%lcloud4crtm + + radmod%laerosol_fwd = rad_type_info(i)%laerosol_fwd + radmod%laerosol = rad_type_info(i)%laerosol + radmod%laerosol4crtm => rad_type_info(i)%laerosol4crtm + + radmod%cclr => rad_type_info(i)%cclr + radmod%ccld => rad_type_info(i)%ccld + radmod%cldval1 => rad_type_info(i)%cldval1 + radmod%lprecip = radmod%lcloud_fwd .and. rad_type_info(i)%lprecip + + return + end if + end do + do i=1,total_aod_type + match=index(trim(obstype),trim(aod_type_info(i)%rtype)) /= 0 + if (match) then + radmod%rtype = aod_type_info(i)%rtype + radmod%nchannel = aod_type_info(i)%nchannel + radmod%cld_sea_only = aod_type_info(i)%cld_sea_only + radmod%cld_effect = aod_type_info(i)%cld_effect + radmod%ex_obserr = aod_type_info(i)%ex_obserr + radmod%ex_biascor = aod_type_info(i)%ex_biascor + + radmod%lcloud_fwd = aod_type_info(i)%lcloud_fwd + radmod%lallsky = aod_type_info(i)%lallsky + radmod%lcloud4crtm => aod_type_info(i)%lcloud4crtm + + radmod%laerosol_fwd = aod_type_info(i)%laerosol_fwd + radmod%laerosol = aod_type_info(i)%laerosol + radmod%laerosol4crtm => aod_type_info(i)%laerosol4crtm + + radmod%cclr => aod_type_info(i)%cclr + radmod%ccld => aod_type_info(i)%ccld + return + end if ! match + end do + if (mype==0) write(6,*) 'radiance_obstype_search type not found: obstype=',obstype + + if (.not. match) then + if (mype==0) write(6,*) 'radiance_obstype_search: #WARNING# obstype=',obstype,' not found in rtype' + end if + + end subroutine radiance_obstype_search + + + subroutine radiance_obstype_destroy +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_obstype_destroy +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 +! +! abstract: +! +! program history log: +! 2015-07-20 zhu +! 2019-03-21 Wei/Martin - added in aod_type support +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + implicit none + + integer(i_kind) :: k + if (total_rad_type>0) then + do k=1, total_rad_type + if(associated(rad_type_info(k)%lcloud4crtm)) deallocate(rad_type_info(k)%lcloud4crtm) + if(associated(rad_type_info(k)%laerosol4crtm)) deallocate(rad_type_info(k)%laerosol4crtm) + if(associated(rad_type_info(k)%cclr)) deallocate(rad_type_info(k)%cclr) + if(associated(rad_type_info(k)%ccld)) deallocate(rad_type_info(k)%ccld) + end do + end if + if (total_aod_type>0) then + do k=1, total_aod_type + if(associated(aod_type_info(k)%lcloud4crtm)) deallocate(aod_type_info(k)%lcloud4crtm) + if(associated(aod_type_info(k)%laerosol4crtm)) deallocate(aod_type_info(k)%laerosol4crtm) + if(associated(aod_type_info(k)%cclr)) deallocate(aod_type_info(k)%cclr) + if(associated(aod_type_info(k)%ccld)) deallocate(aod_type_info(k)%ccld) + end do + end if + + do k=1, total_rad_type + if(associated(rad_type_info(k)%lcloud4crtm)) deallocate(rad_type_info(k)%lcloud4crtm) + if(associated(rad_type_info(k)%laerosol4crtm)) deallocate(rad_type_info(k)%laerosol4crtm) + if(associated(rad_type_info(k)%cclr)) deallocate(rad_type_info(k)%cclr) + if(associated(rad_type_info(k)%ccld)) deallocate(rad_type_info(k)%ccld) + if(associated(rad_type_info(k)%cldval1)) deallocate(rad_type_info(k)%cldval1) + end do + if(allocated(rad_type_info)) deallocate(rad_type_info) + if(allocated(aod_type_info)) deallocate(aod_type_info) + end subroutine radiance_obstype_destroy + + + subroutine radiance_parameter_cloudy_init +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_parameter_cloudy_init +! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 +! +! abstract: This routine sets default values for variables used in +! the cloudy radiance processing routines. +! +! program history log: +! 2015-07-20 zhu +! 2016-10-27 zhu - add ATMS +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + + use kinds, only: i_kind,r_kind + use mpeu_util, only: gettablesize, gettable + implicit none + + character(len=*),parameter:: fixfilename='cloudy_radiance_info.txt' + character(len=*),parameter:: toptablename='radiance_mod_instr_input' + integer(i_kind) :: lunin + character(len=20) :: tablename + character(len=10) :: obsname + character(len=10) :: ex_obserr + character(len=8) :: obsloc ! global, sea, or, land ... + logical :: ex_biascor,cld_effect + logical :: pcexist + logical :: obs_found + + integer(i_kind) i,ii,istr,ntot,nrows + character(len=256),allocatable,dimension(:):: utable + + if (.not. icloud_fwd .or. total_rad_type<=0) return + + inquire(file=fixfilename,exist=pcexist) + if (.not. pcexist) then + write(6,*)'radiance_parameter_cloudy_init: cloudy_radiance_info.txt is missing' + call stop2(79) + end if + lunin=11 + open(lunin,file=fixfilename,form='formatted') + +! Scan file for desired table first and get size of table + call gettablesize(toptablename,lunin,ntot,nrows) + if (mype==0) write(6,*) 'radiance_parameter_cloudy_init: ',toptablename, nrows + if(nrows==0) then + return + endif + +! Get contents of table + allocate(utable(nrows)) + call gettable(toptablename,lunin,ntot,nrows,utable) + + do ii=1,nrows + read(utable(ii),*) obsname,obsloc,ex_obserr,ex_biascor,cld_effect + if (mype==0) write(6,*) obsname,obsloc,ex_obserr,ex_biascor,cld_effect + + obs_found=.false. + do i=1,total_rad_type + if (index(trim(rad_type_info(i)%rtype),trim(obsname)) /= 0) then + obs_found=.true. + istr=i + if (trim(obsloc)=='sea') rad_type_info(i)%cld_sea_only=.true. + rad_type_info(i)%ex_obserr=ex_obserr + rad_type_info(i)%ex_biascor=ex_biascor + rad_type_info(i)%cld_effect=cld_effect + + if (.not. rad_type_info(i)%lcloud_fwd) then + rad_type_info(i)%cld_sea_only=.false. + rad_type_info(i)%cld_effect=.false. + rad_type_info(i)%ex_obserr=' ' + rad_type_info(i)%ex_biascor=.false. + end if + + if (mype==0) write(6,*) 'cloudy_radiance_info for ', trim(obsname),& + ' cld_sea_only=', rad_type_info(i)%cld_sea_only, & + ' ex_obserr=', rad_type_info(i)%ex_obserr, & + ' ex_biascor=', rad_type_info(i)%ex_biascor + +! allocate space for entries from table, Obtain table contents + tablename='obs_'//trim(obsname) + if ( rad_type_info(i)%ex_obserr == 'ex_obserr3' ) then + call sensor_parameter_table(trim(tablename),lunin,rad_type_info(i)%nchannel,rad_type_info(i)%cclr,rad_type_info(i)%ccld,rad_type_info(i)%cldval1) + else + call sensor_parameter_table(trim(tablename),lunin,rad_type_info(i)%nchannel,rad_type_info(i)%cclr,rad_type_info(i)%ccld) + endif + exit + end if + end do + if (.not. obs_found) cycle + enddo ! end of nrows + deallocate(utable) + close(lunin) + end subroutine radiance_parameter_cloudy_init + + + subroutine sensor_parameter_table(filename,lunin,nchal,cclr,ccld,cldval1) +!$$$ subprogram documentation block +! . . . +! subprogram: sensor_parameter_table +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-09-10 +! +! abstract: This routine retrieves parameters used for AMSUA all-sky radiance +! +! program history log: +! 2015-09-10 zhu +! 2018-08-10 mkim : added a column of data 'cldval1' in the all-sky sensor parameter table +! 2019-07-108 todling : turn cldval1 into optional to avoid forcing another column in info file when not needed +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + use kinds, only: i_kind,r_kind + use mpeu_util, only: gettablesize + use mpeu_util, only: gettable + use gsi_io, only: verbose + implicit none + + character(len=*), intent(in) :: filename + integer(i_kind) , intent(in) :: lunin + integer(i_kind) , intent(in) :: nchal + real(r_kind) , dimension(nchal), intent(inout) :: cclr,ccld + real(r_kind) , dimension(nchal), optional, intent(inout) :: cldval1 + + integer(i_kind) ii,ntot,nrows,ich0 + real(r_kind) cclr0,ccld0,cldval1_0 + character(len=256),allocatable,dimension(:):: utable + logical print_verbose + + print_verbose=.false. + if(verbose .and. mype == 0)print_verbose=.true. +! Initialize the arrays + cclr(:)=zero + ccld(:)=zero + if ( present(cldval1) ) then + cldval1(:)=zero + endif + +! Scan file for desired table first and get size of table + call gettablesize(filename,lunin,ntot,nrows) + if (print_verbose) write(6,*) 'sensor_parameter_table: ',filename, nrows + if(nrows==0) then + return + endif + +! Get contents of table + allocate(utable(nrows)) + call gettable(filename,lunin,ntot,nrows,utable) + +! Retrieve each token of interest from table + do ii=1,nrows + if (present(cldval1)) then + read(utable(ii),*) ich0,cclr0,ccld0,cldval1_0 + cldval1(ich0)=cldval1_0 + else + read(utable(ii),*) ich0,cclr0,ccld0 + endif + cclr(ich0)=cclr0 + ccld(ich0)=ccld0 + enddo + deallocate(utable) + + if (print_verbose) then + if (present(cldval1)) then + write(6,*) 'sensor_parameter_table: ich cclr ccld cldval1' + do ii=1,nchal + write(6,*) ii,cclr(ii),ccld(ii),cldval1(ii) + end do + else + write(6,*) 'sensor_parameter_table: ich cclr ccld' + do ii=1,nchal + write(6,*) ii,cclr(ii),ccld(ii) + end do + endif + end if + + end subroutine sensor_parameter_table + + subroutine radiance_parameter_aerosol_init + ! History: 2018-10-31 Wei/Martin - fix stub + use aeroinfo, only: jpch_aero,nusis_aero + use obsmod, only: ndat,dtype,dsis + use gsi_io, only: verbose + implicit none + logical :: first,diffistr,found + integer(i_kind) :: i,j,k,ii,nn1,nn2 + integer(i_kind),dimension(ndat) :: k2i + character(10),dimension(ndat) :: rtype,rrtype,drtype + logical print_verbose + + if (.not. iaerosol_fwd) return + + print_verbose=.false. + if(verbose)print_verbose=.true. + + drtype='nonaod' + do i=1,ndat + rtype(i)=dtype(i)! rtype - observation types to process + if (rtype(i) == 'modis_aod' .or. rtype(i) == 'viirs_aod') then + drtype='aod' + end if + end do + + k=0 + k2i=0 + first=.true. + rrtype='' + do i=1,ndat + if (drtype(i) /= 'aod') cycle + + found=.false. + if (first) then + k=k+1 + rrtype(k)=rtype(i) + k2i(k)=i + first=.false. + else + do j=1,k + if (trim(rtype(i)) == trim(rrtype(j))) then + found=.true. + exit + end if + end do + if (.not. found) then + k=k+1 + rrtype(k)=rtype(i) + k2i(k)=i + end if + end if + end do + total_aod_type=k + + if (mype==0) write(6,*) 'radiance_obstype_init: total_aod_type=',k,' types are: ', rrtype(1:total_aod_type) + + if (total_aod_type<=0) return + allocate(aod_type_info(total_aod_type)) + + do k=1, total_aod_type + aod_type_info(k)%rtype=rrtype(k) + aod_type_info(k)%cld_sea_only=.false. + aod_type_info(k)%ex_obserr=' ' + aod_type_info(k)%ex_biascor=.false. + aod_type_info(k)%cld_effect=.false. + aod_type_info(k)%lcloud_fwd=.false. + aod_type_info(k)%lallsky=.false. + aod_type_info(k)%laerosol_fwd=.true. + aod_type_info(k)%laerosol=.true. + + ii=k2i(k) + first=.true. + nn1=0 + nn2=0 + do j=1,jpch_aero + if (j==jpch_aero) then + diffistr = .true. + else + diffistr = trim(nusis_aero(j))/=trim(nusis_aero(j+1)) + end if + if (trim(dsis(ii))==trim(nusis_aero(j))) then + if (first) then + nn1=j + first=.false. + else + nn2=j + end if + if (diffistr) exit + end if + end do + if (nn1/=0 .and. nn2/=0) then + aod_type_info(k)%nchannel=nn2-nn1+1 + else + cycle + end if + + allocate(aod_type_info(k)%lcloud4crtm(aod_type_info(k)%nchannel)) + allocate(aod_type_info(k)%laerosol4crtm(aod_type_info(k)%nchannel)) + aod_type_info(k)%lcloud4crtm=0 + aod_type_info(k)%laerosol4crtm=0 + + if (mype==0) & + write(6,*) 'radiance_obstype_init: type=',aod_type_info(k)%rtype, & + ' nch=',aod_type_info(k)%nchannel, & + ' lcloud_fwd=',aod_type_info(k)%lcloud_fwd, & + ' lallsky=',aod_type_info(k)%lallsky, & + ' laerosol_fwd=',aod_type_info(k)%laerosol_fwd, & + ' laerosol=',aod_type_info(k)%laerosol + + allocate(aod_type_info(k)%cclr(aod_type_info(k)%nchannel)) + allocate(aod_type_info(k)%ccld(aod_type_info(k)%nchannel)) + aod_type_info(k)%cclr(:)=9999.9_r_kind + aod_type_info(k)%ccld(:)=zero + + end do ! end total_aod_type + + end subroutine radiance_parameter_aerosol_init + + subroutine radiance_ex_obserr_1(radmod,nchanl,clwp_amsua,clw_guess_retrieval, & + tnoise,tnoise_cld,error0) +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_ex_obserr_1 +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-09-10 +! +! abstract: This routine includes extra observation error assignment routines. +! +! program history log: +! 2015-09-10 zhu +! 2016-10-27 zhu - add ATMS +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + use kinds, only: i_kind,r_kind + implicit none + + integer(i_kind),intent(in) :: nchanl + real(r_kind),intent(in) :: clwp_amsua,clw_guess_retrieval + real(r_kind),dimension(nchanl),intent(in):: tnoise,tnoise_cld + real(r_kind),dimension(nchanl),intent(inout) :: error0 + type(rad_obs_type),intent(in) :: radmod + + integer(i_kind) :: i + real(r_kind) :: clwtmp + real(r_kind),dimension(nchanl) :: cclr,ccld + + do i=1,nchanl + cclr(i)=radmod%cclr(i) + ccld(i)=radmod%ccld(i) + end do + + do i=1,nchanl + if (radmod%lcloud4crtm(i)<0) cycle + clwtmp=half*(clwp_amsua+clw_guess_retrieval) + if(clwtmp <= cclr(i)) then + error0(i) = tnoise(i) + else if(clwtmp > cclr(i) .and. clwtmp < ccld(i)) then + error0(i) = tnoise(i) + (clwtmp-cclr(i))* & + (tnoise_cld(i)-tnoise(i))/(ccld(i)-cclr(i)) + else + error0(i) = tnoise_cld(i) + endif + end do + return + + end subroutine radiance_ex_obserr_1 + + subroutine radiance_ex_obserr_2(radmod,nchanl,cldeff1,cldeff2,tnoise,tnoise_cld,error0) +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_ex_obserr_1 +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-09-10 +! +! abstract: This routine includes extra observation error assignment routines. +! +! +! program history log: +! 2018-04-04 zhu/bi -- adapted from radiance_ex_obserr_1 +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + use kinds, only: i_kind,r_kind + implicit none + + integer(i_kind),intent(in) :: nchanl + real(r_kind),dimension(nchanl),intent(in) :: cldeff1,cldeff2 + real(r_kind),dimension(nchanl),intent(in) :: tnoise,tnoise_cld + real(r_kind),dimension(nchanl),intent(inout) :: error0 + type(rad_obs_type),intent(in) :: radmod + + integer(i_kind) :: i + real(r_kind) :: cldeff + real(r_kind),dimension(nchanl) :: cclr,ccld + + do i=1,nchanl + cclr(i)=radmod%cclr(i) + ccld(i)=radmod%ccld(i) + end do + + do i=1,nchanl + if (radmod%lcloud4crtm(i)<0) cycle + cldeff=half*(abs(cldeff1(i))+abs(cldeff2(i))) + if(cldeff <= cclr(i)) then + error0(i) = tnoise(i) + else if(cldeff > cclr(i) .and. cldeff < ccld(i)) then + error0(i) = tnoise(i) + (cldeff-cclr(i))* & + (tnoise_cld(i)-tnoise(i))/(ccld(i)-cclr(i)) + else + error0(i) = tnoise_cld(i) + endif + end do + return + + end subroutine radiance_ex_obserr_2 + + subroutine radiance_ex_biascor_1(radmod,nchanl,tsim_bc,tsavg5,zasat, & + clw_guess_retrieval,clwp_amsua,cld_rbc_idx,ierrret) +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_ex_biascor_1 +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-09-20 +! +! abstract: This routine include extra radiance bias correction routines. +! +! program history log: +! 2015-09-20 zhu +! 2016-10-27 zhu - add ATMS +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + use kinds, only: i_kind,r_kind + use clw_mod, only: ret_amsua + implicit none + + integer(i_kind) ,intent(in ) :: nchanl + real(r_kind),dimension(nchanl) ,intent(in ) :: tsim_bc + real(r_kind) ,intent(in ) :: tsavg5,zasat + real(r_kind),dimension(nchanl) ,intent(inout) :: cld_rbc_idx + real(r_kind) ,intent(inout) :: clwp_amsua + real(r_kind) ,intent(inout) :: clw_guess_retrieval + type(rad_obs_type) ,intent(in) :: radmod + integer(i_kind) ,intent( out) :: ierrret + + integer(i_kind) :: i + real(r_kind),dimension(nchanl) :: cclr + + do i=1,nchanl + cclr(i)=radmod%cclr(i) + end do + +! call ret_amsua(tb_obs,nchanl,tsavg5,zasat,clwp_amsua,ierrret) + call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) + + do i=1,nchanl + if (radmod%lcloud4crtm(i)<0) cycle + if ((clwp_amsua-cclr(i))*(clw_guess_retrieval-cclr(i))=0.005_r_kind) cld_rbc_idx(i)=zero + end do + return + + end subroutine radiance_ex_biascor_1 + + subroutine radiance_ex_biascor_2(radmod,nchanl,cldeff1,cldeff2,cld_rbc_idx) +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_ex_biascor_1 +! +! prgrmmr: yanqiu zhu org: np23 date: 2015-09-20 +! +! abstract: This routine include extra radiance bias correction routines using +! cloud effect. +! +! program history log: +! 2018-04-04 zhu - adapted from radiance_ex_biascor_1 +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + use kinds, only: i_kind,r_kind + use clw_mod, only: ret_amsua + implicit none + + integer(i_kind) ,intent(in ) :: nchanl + real(r_kind),dimension(nchanl) ,intent(inout) :: cld_rbc_idx + real(r_kind),dimension(nchanl) ,intent(in) :: cldeff1 + real(r_kind),dimension(nchanl) ,intent(in) :: cldeff2 + type(rad_obs_type) ,intent(in) :: radmod + + integer(i_kind) :: i + real(r_kind),dimension(nchanl) :: cclr + + do i=1,nchanl + cclr(i)=radmod%cclr(i) + end do + + do i=1,nchanl + if (radmod%lcloud4crtm(i)<0) cycle + if ((abs(cldeff1(i))-cclr(i))*(abs(cldeff2(i))-cclr(i))=0.1_r_kind) cld_rbc_idx(i)=zero + end do + return + + end subroutine radiance_ex_biascor_2 + + subroutine radiance_ex_obserr_gmi(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0) +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_ex_obserr_3 +! +! prgrmmr: min-jeong kim org: np23 date: 2018-08-10 +! +! abstract: This routine include extra radiance bias correction routines. +! +! program history log: +! 2015-09-20 zhu +! 2016-10-27 zhu - add ATMS +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + + use kinds, only: i_kind,r_kind + implicit none + + integer(i_kind),intent(in) :: nchanl + real(r_kind),intent(in) :: clw_obs,clw_guess_retrieval + real(r_kind),dimension(nchanl),intent(in):: tnoise,tnoise_cld + real(r_kind),dimension(nchanl),intent(inout) :: error0 + type(rad_obs_type),intent(in) :: radmod + + integer(i_kind) :: i + real(r_kind) :: clwavg + real(r_kind),dimension(nchanl) :: cclr,ccld,tnoise_cldval1 + + do i=1,nchanl + cclr(i)=radmod%cclr(i) + ccld(i)=radmod%ccld(i) + tnoise_cldval1(i)=radmod%cldval1(i) + end do + + do i=1,nchanl + if (radmod%lcloud4crtm(i)<0) cycle + clwavg=half*(clw_obs+clw_guess_retrieval) + if(clwavg < cclr(i)) then + error0(i) = tnoise(i) + else if(clwavg >= cclr(i) .and. clwavg < ccld(i)) then + error0(i) = tnoise_cldval1(i) + (tnoise(i) - tnoise_cldval1(i))*(ccld(i)-clwavg)/(ccld(i)-cclr(i)) + else if(clwavg >= ccld(i) .and. clwavg < 0.5_r_kind) then + error0(i) = tnoise_cld(i) + (tnoise_cldval1(i)-tnoise_cld(i)) * (0.5_r_kind-clwavg)/(0.5_r_kind-ccld(i)) + else + error0(i) = tnoise_cld(i) + endif + end do + return + +! end subroutine radiance_ex_obserr_3 + end subroutine radiance_ex_obserr_gmi + +! subroutine radiance_ex_biascor_3(radmod,nchanl,tsim_bc,tsavg5,zasat, & + subroutine radiance_ex_biascor_gmi(radmod,clw_obs,clw_guess_retrieval,nchanl,cld_rbc_idx) +!$$$ subprogram documentation block +! . . . +! subprogram: radiance_ex_biascor_gmi +! +! prgrmmr: min-jeong kim org: np23 date: 2085-08-10 +! +! abstract: This routine include extra radiance bias correction routines. +! +! program history log: +! 2018-08-10 mkim +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +!$$$ end documentation block + use kinds, only: i_kind,r_kind + use constants, only: zero,one + + implicit none + + integer(i_kind) ,intent(in ) :: nchanl + real(r_kind),dimension(nchanl) ,intent(inout) :: cld_rbc_idx + real(r_kind) ,intent(inout) :: clw_obs + real(r_kind) ,intent(inout) :: clw_guess_retrieval + type(rad_obs_type) ,intent(in) :: radmod + + integer(i_kind) :: i + real(r_kind),dimension(nchanl) :: cclr + + do i=1,nchanl + cclr(i)=radmod%cclr(i) + end do + + do i=1,nchanl + if (radmod%lcloud4crtm(i)<0) cycle + if (clw_obs <= cclr(i) .and. clw_guess_retrieval <= cclr(i) .and. abs(clw_obs-clw_guess_retrieval) < 0.001_r_kind) then + cld_rbc_idx(i)=one !clear/clear + else + cld_rbc_idx(i)=zero + endif + end do + return + +! end subroutine radiance_ex_biascor_3 + end subroutine radiance_ex_biascor_gmi + + +end module radiance_mod + diff --git a/src/radinfo.f90 b/src/gsi/radinfo.f90 similarity index 85% rename from src/radinfo.f90 rename to src/gsi/radinfo.f90 index a5038a3ac..83f69e307 100644 --- a/src/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -41,13 +41,20 @@ module radinfo ! 2014-04-23 li - change scan bias correction mode for avhrr and avhrr_navy ! 2014-04-24 li - apply abs (absolute) to AA and be for safeguarding ! 2015-03-01 li - add zsea1 & zsea2 to handle the vertical mean temperature based on NSST T-Profile +! 2015-03-26 m.kim - add flexibility to bring in new qc using "iextra" in satinfo file ! 2015-7-10 zhu - add two additional columns to satinfo file: icloud4crtm & iaerosol4crtm +! 2015-07-10 zhu - read in and determine icloud4crtm & iaerosol4crtm for all channels +! for generalized all-sky radiance assimilation, as all-sky +! may be enabled for part of the channels for certain instruments ! 2016-03-10 ejones - add control for GMI noise reduction ! 2016-03-24 ejones - add control for AMSR2 noise reduction ! 2016-06-03 Collard - Added changes to allow for historical naming conventions ! 2016-08-12 mahajan - moved nst related variables from radinfo to gsi_nstcouplermod ! 2016-09-20 Guo - added SAVE attributes to module variables *_method, to ! improve standard conformance of the code. +! 2016-11-29 shlyaeva - make nvarjac public +! 2018-07-24 W. Gu - the routines to handle correlated R-covariance moved out +! 2019-06-19 Hu - add option reset_bad_radbc for reset radiance bias correction coefficient if it is bad. ! ! subroutines included: ! sub init_rad - set satellite related variables to defaults @@ -87,30 +94,36 @@ module radinfo public :: jpch_rad,npred,b_rad,pg_rad,diag_rad,iuse_rad,nusis,inew_rad public :: crtm_coeffs_path,retrieval,predx,ang_rad,newchn,cbias,icld_det public :: air_rad,nuchan,numt,varch,varch_cld,fbias,ermax_rad,tlapmean + public :: varch_sea,varch_land,varch_ice,varch_snow,varch_mixed public :: ifactq,mype_rad public :: ostats,rstats,varA - public :: adp_anglebc,angord,use_edges, maxscan + public :: adp_anglebc,angord,use_edges, maxscan, bias_zero_start public :: emiss_bc public :: passive_bc + public :: reset_bad_radbc public :: upd_pred public :: ssmis_method,gmi_method,amsr2_method public :: radstart,radstep public :: newpc4pred public :: biaspredvar - public :: radjacnames,radjacindxs,nsigradjac + public :: radjacnames,radjacindxs,nsigradjac,nvarjac public :: tzr_bufrsave,tzr_qc + public :: diag_version public :: radedge1, radedge2 public :: ssmis_precond - public :: radinfo_adjust_jacobian public :: icloud4crtm,iaerosol4crtm - public :: radinfo_get_rsqrtinv + public :: iland_det, isnow_det, imix_det, iice_det, iwater_det + public :: itopo_det, isst_det, iwndspeed_det, iomg_det public :: dec2bin + public :: cld_det_dec2bin + public :: lupdqc, lqcoef integer(i_kind),parameter:: numt = 33 ! size of AVHRR bias correction file integer(i_kind),parameter:: ntlapthresh = 100 ! threshhold value of cycles if tlapmean update is needed + integer(i_kind) diag_version ! default verison of diag files logical diag_rad ! logical to turn off or on the diagnostic radiance file (true=on) logical retrieval ! logical to turn off or on the SST retrieval with AVHRR data logical tzr_bufrsave! logical to turn off or on the bufr file output for Tz retrieval (true=on) @@ -118,7 +131,12 @@ module radinfo logical adp_anglebc ! logical to turn off or on the variational radiance angle bias correction logical emiss_bc ! logical to turn off or on the emissivity predictor logical passive_bc ! logical to turn off or on radiance bias correction for monitored channels + logical reset_bad_radbc ! logical to turn off or on reseting radiance bias correction coefficient when it + ! goes bad. Mainly used for safety check in regional + ! analysis logical use_edges ! logical to use data on scan edges (.true.=to use) + logical bias_zero_start ! logical to start bias correction from zero (otherwise mode start) + logical cld_det_dec2bin ! re-interprets cld_det as binary entry integer(i_kind) tzr_qc ! indicator of Tz retrieval QC tzr integer(i_kind) ssmis_method ! noise reduction method for SSMIS @@ -135,6 +153,11 @@ module radinfo real(r_kind) :: ssmis_precond real(r_kind),allocatable,dimension(:):: varch ! variance for clear radiance each satellite channel + real(r_kind),allocatable,dimension(:):: varch_sea ! optional variance in case of correlated error over sea + real(r_kind),allocatable,dimension(:):: varch_land ! optional variance in case of correlated error over land + real(r_kind),allocatable,dimension(:):: varch_ice ! optional variance in case of correlated error over ice + real(r_kind),allocatable,dimension(:):: varch_snow ! optional variance in case of correlated error over snow + real(r_kind),allocatable,dimension(:):: varch_mixed ! optional variance in case of correlated error over mixed surfaces real(r_kind),allocatable,dimension(:):: varch_cld ! variance for cloudy radiance real(r_kind),allocatable,dimension(:):: ermax_rad ! error maximum (qc) real(r_kind),allocatable,dimension(:):: b_rad ! variational b value @@ -183,8 +206,17 @@ module radinfo ! = 2 use data with no airmass bias correction ! = 3 use data with no angle dependent bias correction ! = 4 use data with no bias correction - integer(i_kind),allocatable,dimension(:):: icld_det ! Use this channel in cloud detection (only used for -! certain instruments. Set to greater than zero to use + integer(i_kind),allocatable,dimension(:):: icld_det ! Use this channel in cloud detection (only used for +! certain instruments. Set to greater than zero to use + integer(i_kind),allocatable,dimension(:):: iwater_det ! Use this channel in extra QC depending on sfc type + integer(i_kind),allocatable,dimension(:):: iland_det ! Use this channel in extra QC depending on sfc type + integer(i_kind),allocatable,dimension(:):: iice_det ! Use this channel in extra QC depending on sfc type + integer(i_kind),allocatable,dimension(:):: isnow_det ! Use this channel in extra QC depending on sfc type + integer(i_kind),allocatable,dimension(:):: imix_det ! Use this channel in extra QC depending on sfc type + integer(i_kind),allocatable,dimension(:):: itopo_det ! Use this channel in extra QC depending on sfc type + integer(i_kind),allocatable,dimension(:):: iomg_det ! Use this channel in extra QC depending on sfc type + integer(i_kind),allocatable,dimension(:):: isst_det ! Use this channel in extra QC depending on sfc type + integer(i_kind),allocatable,dimension(:):: iwndspeed_det ! Use this channel in extra QC depending on sfc type logical,allocatable,dimension(:):: inew_rad ! indicator if it needs initialized for satellite radiance data logical,allocatable,dimension(:):: update_tlapmean ! indicator if tlapmean update is needed @@ -196,15 +228,15 @@ module radinfo character(len=20),allocatable,dimension(:):: nusis ! sensor/instrument/satellite indicator character(len=256),save:: crtm_coeffs_path = "./" ! path of CRTM_Coeffs files - integer(i_kind) :: nsigradjac + integer(i_kind) :: nsigradjac, nvarjac character(len=20),allocatable,dimension(:):: radjacnames integer(i_kind), allocatable,dimension(:):: radjacindxs real(r_kind) :: biaspredvar logical,save :: newpc4pred ! controls preconditioning due to sat-bias correction term + logical,save :: lupdqc, lqcoef - interface radinfo_adjust_jacobian; module procedure adjust_jac_; end interface - interface radinfo_get_rsqrtinv; module procedure get_rsqrtinv_; end interface + integer(i_kind),allocatable, dimension(:):: iextra_det character(len=*),parameter :: myname='radinfo' contains @@ -236,6 +268,10 @@ subroutine init_rad ! 2016-03-24 ejones - add amsr2_method for using ssmis spatial averaging code ! for amsr2 ! 2017-09-14 li - change default value of tzr_qc = 1 +! 2018-08-25 collard - Add bias_zero_start +! 2019-06-19 hu - add reset_bad_radbc +! 2019-08-14 W. Gu - add lupdqc to replace the obs errors from satinfo with diag of est(R). +! 2019-08-14 W. Gu - add lqcoef to combine the inflation coefficients generated by qc with est(R) ! ! input argument list: ! @@ -258,10 +294,13 @@ subroutine init_rad npred=7 ! number of bias correction predictors tzr_qc = 1 ! 0 = no Tz ret in gsi; 1 = retrieve and applied to QC tzr_bufrsave = .false. ! .true.=generate bufr file for Tz retrieval + diag_version= 40000 ! default version of diag files newpc4pred = .false. ! .true.=turn on new preconditioning for bias coefficients passive_bc = .false. ! .true.=turn on bias correction for monitored channels + reset_bad_radbc = .false. ! .true.=turn on reseting bas radiance bias correction coefficients adp_anglebc = .false. ! .true.=turn on angle bias correction + bias_zero_start = .true. ! .true.=Zero start; .false.=mode start emiss_bc = .false. ! .true.=turn on emissivity bias correction angord = 0 ! order of polynomial for angle bias correction use_edges = .true. ! .true.=to use data on scan edges @@ -270,6 +309,10 @@ subroutine init_rad ssmis_precond = r0_01 ! default preconditioner for ssmis bias terms gmi_method = 0 ! 4= default gmi smoothing method amsr2_method = 0 ! 5= default amsr2 smoothing method + lupdqc = .true. ! .true.= replace the obs errors specified in satinfo with the diags of est(R) + lqcoef = .true. ! .true.= combine the inflation coefficients generated by QC with est(R) + + cld_det_dec2bin = .false. ! converts cld_det from decimal to binary end subroutine init_rad @@ -295,6 +338,7 @@ subroutine init_rad_vars ! 2013-10-26 todling - revisit given that metguess now holds upper air ! 2013-11-21 todling - add set_radiag; should be revisited to accommodate all ! versions of diag-file, but perhaps done somewhere else +! 2016-11-29 shlyaeva - make nvarjac public (for saving linearized H(x) for EnKF) ! ! input argument list: ! @@ -314,7 +358,7 @@ subroutine init_rad_vars implicit none integer(i_kind) ii,jj,mxlvs,isum,ndim,ib,ie,ier - integer(i_kind) nvarjac,n_meteo,n_clouds_jac,n_aeros_jac + integer(i_kind) n_meteo,n_clouds_jac,n_aeros_jac integer(i_kind),allocatable,dimension(:)::aux,all_levels character(len=20),allocatable,dimension(:)::meteo_names character(len=20),allocatable,dimension(:)::clouds_names_jac @@ -338,11 +382,13 @@ subroutine init_rad_vars if (angord/=0) angord=0 end if - call set_radiag ('version',30303,ier) +! call set_radiag ('version',30303,ier) + call set_radiag ('version',40000,ier) if (adp_anglebc) npred=npred+angord if (emiss_bc) then npred=npred+1 - call set_radiag ('version',30303,ier) +! call set_radiag ('version',30303,ier) + call set_radiag ('version',40000,ier) endif ! inquire about variables in guess @@ -482,10 +528,8 @@ subroutine final_rad_vars ! !$$$ end documentation block - use correlated_obsmod, only: corr_ob_finalize implicit none - call corr_ob_finalize if(allocated(radjacindxs)) deallocate(radjacindxs) if(allocated(radjacnames)) deallocate(radjacnames) @@ -542,11 +586,8 @@ subroutine radinfo_read ! 2013-02-13 eliu - change write-out format for iout_rad (for two ! additional SSMIS bias correction coefficients) ! 2013-05-14 guo - add read error messages to alarm user a format change. -! 2014-04-13 todling - add initialization of correlated R-covariance ! 2014-07-28 sienkiewicz - revert to allocate cbias, cbiasx after maxscan ! reset in non adp_anglebc case -! 2014-12-19 W. Gu - update the obs error in satinfo for instruments accounted for the correlated R-covariance -! 2015-04-01 W. Gu - add the hook to scale the bias correction term for inter-channel correlated obs errors. ! 2015-07-10 zhu - read in and determine icloud4crtm & iaerosol4crtm for all channels ! for generalized all-sky radiance assimilation, as all-sky ! may be enabled for part of the channels for certain instruments @@ -565,7 +606,6 @@ subroutine radinfo_read ! !USES: - use correlated_obsmod, only: corr_ob_initialize,corr_oberr_qc use obsmod, only: iout_rad use constants, only: zero,one,zero_quad use mpimod, only: mype @@ -573,9 +613,7 @@ subroutine radinfo_read implicit none ! !INPUT PARAMETERS: - - - integer(i_kind) i,j,k,ich,lunin,lunout,nlines + integer(i_kind) i,j,k,ich,lunin,nlines integer(i_kind) ip,istat,n,ichan,nstep,edge1,edge2,ntlapupdate,icw,iaeros real(r_kind),dimension(npred):: predr real(r_kind) tlapm @@ -605,8 +643,9 @@ subroutine radinfo_read logical pcexist logical cold_start_seviri ! flag to fix wrong channel numbers for seviri. True = fix, false = already correct + integer(i_kind) binary_iextra_det(10) + data lunin / 49 / - data lunout / 51 / !============================================================================ @@ -659,7 +698,28 @@ subroutine radinfo_read ifactq(jpch_rad),varch(jpch_rad),varch_cld(jpch_rad), & ermax_rad(jpch_rad),b_rad(jpch_rad),pg_rad(jpch_rad), & ang_rad(jpch_rad),air_rad(jpch_rad),inew_rad(jpch_rad),& - icld_det(jpch_rad),icloud4crtm(jpch_rad),iaerosol4crtm(jpch_rad)) + icld_det(jpch_rad),icloud4crtm(jpch_rad),iaerosol4crtm(jpch_rad), & + iextra_det(jpch_rad), & + isnow_det(jpch_rad), & + iland_det(jpch_rad),iice_det(jpch_rad), & + iwater_det(jpch_rad),imix_det(jpch_rad),& + itopo_det(jpch_rad),isst_det(jpch_rad), & + iwndspeed_det(jpch_rad),iomg_det(jpch_rad)) + + allocate(varch_sea(jpch_rad),varch_land(jpch_rad),varch_ice(jpch_rad), & + varch_snow(jpch_rad),varch_mixed(jpch_rad)) + +! initialize flags + iland_det = 0 + isnow_det = 0 + imix_det = 0 + iice_det = 0 + iwater_det = 0 + iomg_det = 0 + itopo_det = 0 + isst_det = 0 + iwndspeed_det = 0 + allocate(nfound(jpch_rad)) iuse_rad(0)=-999 inew_rad=.true. @@ -680,8 +740,14 @@ subroutine radinfo_read do k=1,nlines read(lunin,100) cflg,crecord if (cflg == '!') cycle - read(crecord,*,iostat=istat) nusis(j),nuchan(j),iuse_rad(j),varch(j), & - varch_cld(j),ermax_rad(j),b_rad(j),pg_rad(j),icld_det(j),icw,iaeros + read(crecord,*,iostat=istat) nusis(j),nuchan(j),iuse_rad(j), varch(j), & + varch_cld(j),ermax_rad(j),b_rad(j),pg_rad(j),iextra_det(j),icw,iaeros + + if(istat/=0) then + call perr('radinfo_read','read(crecord), crecord =',trim(crecord)) + call perr('radinfo_read',' istat =',istat) + call die('radinfo_read') + endif ! The following is to sort out some historical naming conventions select case (nusis(j)(1:4)) @@ -693,13 +759,7 @@ subroutine radinfo_read if (index(nusis(j),'metop-c') /= 0) nusis(j)='iasi_metop-c' end select - if(istat/=0) then - call perr('radinfo_read','read(crecord), crecord =',trim(crecord)) - call perr('radinfo_read',' istat =',istat) - call die('radinfo_read') - endif - - if ( .not. diag_rad .and. iuse_rad(j) < 0 .and. icld_det(j) < 0 .and. & + if ( .not. diag_rad .and. iuse_rad(j) < 0 .and. iextra_det(j) < 0 .and. & ( nusis(j)(1:4) == 'cris' .or. nusis(j)(1:4) == 'iasi' .or. nusis(j)(1:4) == 'airs')) cycle if(iuse_rad(j) == 4 .or. iuse_rad(j) == 2) air_rad(j)=zero @@ -707,9 +767,31 @@ subroutine radinfo_read icloud4crtm(j)=icw iaerosol4crtm(j)=iaeros - if (mype==mype_rad) write(iout_rad,110) j,nusis(j), & + if ( cld_det_dec2bin ) then + if (mype==mype_rad) write(iout_rad,111) j,nusis(j), & nuchan(j),varch(j),varch_cld(j),iuse_rad(j),ermax_rad(j), & - b_rad(j),pg_rad(j),icld_det(j),icloud4crtm(j),iaerosol4crtm(j) + b_rad(j),pg_rad(j),iextra_det(j),icloud4crtm(j),iaerosol4crtm(j) + + call dec2bin(iextra_det(j),binary_iextra_det,10) + + icld_det(j) = binary_iextra_det(1) + iland_det(j) = binary_iextra_det(2) + isnow_det(j) = binary_iextra_det(3) + imix_det(j) = binary_iextra_det(4) + iice_det(j) = binary_iextra_det(5) + iwater_det(j) = binary_iextra_det(6) + iomg_det(j) = binary_iextra_det(7) + itopo_det(j) = binary_iextra_det(8) + isst_det(j) = binary_iextra_det(9) + iwndspeed_det(j) = binary_iextra_det(10) + else + if (mype==mype_rad) write(iout_rad,110) j,nusis(j), & + nuchan(j),varch(j),varch_cld(j),iuse_rad(j),ermax_rad(j), & + b_rad(j),pg_rad(j),iextra_det(j),icloud4crtm(j),iaerosol4crtm(j) + + icld_det(j) = iextra_det(j) ! leave variable as set in info file + + end if j=j+1 end do @@ -718,15 +800,18 @@ subroutine radinfo_read 110 format(i4,1x,a20,' chan= ',i4, & ' var= ',f7.3,' varch_cld=',f7.3,' use= ',i2,' ermax= ',F7.3, & ' b_rad= ',F7.2,' pg_rad=',F7.2,' icld_det=',I2,' icloud=',I2,' iaeros=',I2) +111 format(i4,1x,a20,' chan= ',i4, & + ' var= ',f7.3,' varch_cld=',f7.3,' use= ',i2,' ermax= ',F7.3, & + ' b_rad= ',F7.2,' pg_rad=',F7.2,' iextra_det=',I2, 'icloud=',I2,'iaeros=', I2) ! Allocate arrays for additional preconditioning info ! Read in information for data number and preconditioning if (newpc4pred) then - allocate(ostats(jpch_rad), rstats(npred,jpch_rad),varA(npred,jpch_rad)) + allocate(ostats(jpch_rad),rstats(npred,jpch_rad),varA(npred,jpch_rad)) varA = zero ostats = zero - rstats = zero_quad + rstats = zero_quad inquire(file='satbias_pc',exist=pcexist) if (pcexist) then @@ -753,7 +838,7 @@ subroutine radinfo_read if( isis(1:6) == 'seviri' .and. ichan < 4 ) cold_start_seviri = .true. ! If not seviri or seviri channels are correct, proceed. - if( .not. cold_start_seviri .or. isis(1:6) /= 'seviri' ) then + if( .not. cold_start_seviri .or. isis(1:6) /= 'seviri' .or. .not. bias_zero_start) then do j =1,jpch_rad if(trim(isis) == trim(nusis(j)) .and. ichan == nuchan(j))then cfound = .true. @@ -987,7 +1072,7 @@ subroutine radinfo_read if( isis(1:6) == 'seviri' .and. ichan < 4 ) cold_start_seviri = .true. ! If not seviri or seviri channels are correct, proceed. - if( .not. cold_start_seviri .or. isis(1:6) /= 'seviri' ) then + if( .not. cold_start_seviri .or. isis(1:6) /= 'seviri' .or. .not. bias_zero_start ) then do j =1,jpch_rad if(trim(isis) == trim(nusis(j)) .and. ichan == nuchan(j))then cfound = .true. @@ -1054,16 +1139,6 @@ subroutine radinfo_read iuse_rad(j)=-1 end if end do - - if (mype==mype_rad) then - open(lunout,file='satbias_ang.out',form='formatted') - write(lunout,'(I5)') maxscan - do j=1,jpch_rad - write(lunout,'(I5,1x,A20,2x,I4,e15.6/100(4x,10f7.3/))') & - j,nusis(j),nuchan(j),tlapmean(j),(cbias(i,j),i=1,maxscan) - end do - close(lunout) - end if end if endif @@ -1116,9 +1191,11 @@ subroutine radinfo_read ! Initialize observation error covariance for ! instruments we account for inter-channel correlations - call corr_ob_initialize - call corr_oberr_qc(jpch_rad,iuse_rad,nusis,varch) - + varch_sea=zero + varch_land=zero + varch_ice=zero + varch_snow=zero + varch_mixed=zero ! Close unit for runtime output. Return to calling routine if(mype==mype_rad)close(iout_rad) return @@ -1126,7 +1203,7 @@ subroutine radinfo_read end subroutine radinfo_read - subroutine radinfo_write + subroutine radinfo_write(pe_out) !$$$ subprogram documentation block ! . . . ! subprogram: radinfo_write @@ -1145,6 +1222,7 @@ subroutine radinfo_write ! 2010-04-29 zhu - add analysis variance info for radiance bias correction coefficients ! 2010-05-06 zhu - add option adp_anglebc ! 2011-04-07 todling - adjust argument list (interface) since newpc4pred is local now +! 2019-07-19 guo - change pe_out to optional, for backward compatible ! ! input argument list: ! @@ -1158,51 +1236,115 @@ subroutine radinfo_write ! !USES: + use mpimod, only: mype implicit none + integer(i_kind),optional, intent(in) :: pe_out + integer(i_kind) lunout,jch,ip,i real(r_kind),dimension(npred):: varx data lunout / 51 / + integer(kind(pe_out)):: pe_out_ + pe_out_=0 + if(present(pe_out)) pe_out_=pe_out + +! Write output only on pe_out_ + if ( mype==pe_out_ ) then + +! Open unit to output file. Write analysis variance info. Close unit. + if (newpc4pred) then + open(lunout,file='satbias_pc.out',form='formatted') + rewind lunout + do jch=1,jpch_rad + do i=1,npred + varx(i)=varA(i,jch) + end do + write(lunout,'(I5,1x,A20,1x,I5,e15.7/2(4x,10e15.7/))') jch,nusis(jch),& + nuchan(jch),ostats(jch),(varx(ip),ip=1,npred) + end do + close(lunout) + end if -! Open unit to output file. Write analysis variance info. Close unit. - if (newpc4pred) then - open(lunout,file='satbias_pc.out',form='formatted') +! Open unit to output file. Write updated coefficients. Close unit. + open(lunout,file='satbias_out',form='formatted') rewind lunout - do jch=1,jpch_rad - do i=1,npred - varx(i)=varA(i,jch) + if (.not. adp_anglebc) then + do jch=1,jpch_rad + write(lunout,'(I5,1x,a20,1x,i5,10f12.6)') jch,nusis(jch),nuchan(jch),& + (predx(ip,jch),ip=1,npred) end do - write(lunout,'(I5,1x,A20,1x,I5,e15.7/2(4x,10e15.7/))') jch,nusis(jch),& - nuchan(jch),ostats(jch),(varx(ip),ip=1,npred) - end do + else + do jch=1,jpch_rad + if(reset_bad_radbc) then + do ip=1,npred + if(abs(predx(ip,jch)) > 9999.0_r_kind) then + write(6,*) 'Bad coefficient:', jch,nusis(jch),nuchan(jch), & + predx(ip,jch),' reset to 0.0' + predx(ip,jch)=0.0_r_kind + endif + enddo + endif + write(lunout,'(I5,1x,a20,1x,i5,2e15.6,1x,I5/2(4x,10f12.6/))') jch,nusis(jch),nuchan(jch),& + tlapmean(jch),tsum_tlapmean(jch),count_tlapmean(jch),(predx(ip,jch),ip=1,npred) + end do + end if close(lunout) - end if -! Open unit to output file. Write updated coefficients. Close unit. - open(lunout,file='satbias_out',form='formatted') - rewind lunout - if (.not. adp_anglebc) then - do jch=1,jpch_rad - write(lunout,'(I5,1x,a20,1x,i5,10f12.6)') jch,nusis(jch),nuchan(jch),& - (predx(ip,jch),ip=1,npred) - end do - else - do jch=1,jpch_rad - write(lunout,'(I5,1x,a20,1x,i5,2e15.6,1x,I5/2(4x,10f12.6/))') jch,nusis(jch),nuchan(jch),& - tlapmean(jch),tsum_tlapmean(jch),count_tlapmean(jch),(predx(ip,jch),ip=1,npred) - end do end if - close(lunout) ! Deallocate data arrays for bias correction and those which hold ! information from satinfo file. - deallocate (predx,cbias,tlapmean,nuchan,nusis,iuse_rad,air_rad,ang_rad, & - ifactq,varch,varch_cld,inew_rad,icld_det,icloud4crtm,iaerosol4crtm) + if(allocated(predx)) deallocate(predx) + if(allocated(cbias)) deallocate(cbias) + if(allocated(tlapmean)) deallocate(tlapmean) + if(allocated(nuchan)) deallocate(nuchan) + if(allocated(nusis)) deallocate(nusis) + if(allocated(iuse_rad)) deallocate(iuse_rad) + if(allocated(air_rad)) deallocate(air_rad) + if(allocated(ang_rad)) deallocate(ang_rad) + if(allocated(ifactq)) deallocate(ifactq) + if(allocated(inew_rad)) deallocate(inew_rad) + + if(allocated(iextra_det)) deallocate(iextra_det) + if(allocated(icld_det)) deallocate(icld_det) + if(allocated(icloud4crtm)) deallocate(icloud4crtm) + if(allocated(iaerosol4crtm)) deallocate(iaerosol4crtm) + if(allocated(iland_det)) deallocate(iland_det) + if(allocated(isnow_det)) deallocate(isnow_det) + if(allocated(iice_det)) deallocate(iice_det) + if(allocated(iwater_det)) deallocate(iwater_det) + if(allocated(imix_det)) deallocate(imix_det) + if(allocated(itopo_det)) deallocate(itopo_det) + if(allocated(isst_det)) deallocate(isst_det) + if(allocated(iwndspeed_det)) deallocate(iwndspeed_det) + if(allocated(iomg_det)) deallocate(iomg_det) + + if(allocated(varch)) deallocate(varch) + if(allocated(varch_cld)) deallocate(varch_cld) + if(allocated(varch_sea)) deallocate(varch_sea) + if(allocated(varch_land)) deallocate(varch_land) + if(allocated(varch_ice)) deallocate(varch_ice) + if(allocated(varch_snow)) deallocate(varch_snow) + if(allocated(varch_mixed)) deallocate(varch_mixed) + if (adp_anglebc) then + if(allocated(count_tlapmean)) deallocate(count_tlapmean) + if(allocated(update_tlapmean)) deallocate(update_tlapmean) + if(allocated(tsum_tlapmean)) deallocate(tsum_tlapmean) + end if + + if (newpc4pred) then + if(allocated(ostats)) deallocate(ostats) + if(allocated(rstats)) deallocate(rstats) + if(allocated(varA)) deallocate(varA) + end if + + if(allocated(radstart)) deallocate(radstart) + if(allocated(radstep)) deallocate(radstep) + if(allocated(radnstep)) deallocate(radnstep) + if(allocated(radedge1)) deallocate(radedge1) + if(allocated(radedge2)) deallocate(radedge2) - if (adp_anglebc) deallocate(count_tlapmean,update_tlapmean,tsum_tlapmean) - if (newpc4pred) deallocate(ostats,rstats,varA) - deallocate (radstart,radstep,radnstep,radedge1,radedge2) return end subroutine radinfo_write @@ -1467,8 +1609,8 @@ subroutine satstep(isis,start,step,nstep,edge1,edge2) edge1 = 5 edge2 = 56 else if (index(isis,'cris')/=0) then - step = 3.322_r_kind - start = -51.675_r_kind + step = 3.3331_r_kind + start = -48.330_r_kind nstep = 30 edge1 = 1 edge2 = 30 @@ -1520,12 +1662,12 @@ subroutine init_predx use mpimod, only: npe,mype,mpi_comm_world,ierror use read_diag, only: read_radiag_header,read_radiag_data,diag_header_fix_list,& diag_header_chan_list,diag_data_fix_list,diag_data_chan_list,& - diag_data_extra_list,diag_data_name_list + diag_data_extra_list,diag_data_name_list,open_radiag,close_radiag,set_netcdf_read use constants, only: zero,one,deg2rad + use obsmod, only: netcdf_diag implicit none ! Declare local parameters - integer(i_kind),parameter:: lndiag = 21 integer(i_kind),parameter:: lntemp = 51 integer(i_kind),parameter:: nthreshold = 100 @@ -1540,14 +1682,16 @@ subroutine init_predx logical mean_only logical ssmi,ssmis,amsre,amsre_low,amsre_mid,amsre_hig,tmi,gmi,amsr2,saphir logical ssmis_las,ssmis_uas,ssmis_env,ssmis_img - logical avhrr,avhrr_navy,goessndr,goes_img,ahi,seviri + logical avhrr,avhrr_navy,goessndr,goes_img,ahi,seviri,abi character(len=20):: obstype,platid character(len=20):: satsens,satsens_id - character(len=50):: fdiag_rad,dname,fname + character(len=50):: dname,fname + character(len=500):: fdiag_rad + integer(i_kind):: lndiag integer(i_kind):: ix,ii,iii,iich,ndatppe - integer(i_kind):: i,j,jj,n_chan,k,lunout + integer(i_kind):: i,j,jj,jjj,n_chan,k,lunout integer(i_kind):: istatus,ispot integer(i_kind):: np,new_chan,nc integer(i_kind):: counttmp, jjstart, sensor_start, sensor_end @@ -1579,6 +1723,8 @@ subroutine init_predx !************************************************************************ ! Return if no new channels AND update_tlapmean=.false. if (.not. (any(inew_rad) .or. any(update_tlapmean))) return + if (ndat==0) return + if (mype==0) write(6,*) 'INIT_PREDX: enter routine' ! Allocate and initialize data arrays @@ -1621,16 +1767,20 @@ subroutine init_predx ! Create diagnostic filename fdiag_rad = 'diag_' // trim(dtype(iii)) // '_' // trim(dplat(iii)) +! Set diagnostic file type + call set_netcdf_read(netcdf_diag) + ! See if diagnostic file exists inquire(file=fdiag_rad,exist=lexist) if (.not.lexist) cycle loopf ! Open file and read header - open(lndiag,file=fdiag_rad,form='unformatted',status='old',iostat=istatus) + lndiag = 21 + call open_radiag(fdiag_rad,lndiag,istatus) if (istatus/=0) then write(6,'(''INIT_PREDX: Task '',i5,'' problem opening file '',a,'' iostat='',i4)') & mype,trim(fdiag_rad),istatus - close(lndiag) + call close_radiag(fdiag_rad,lndiag) cycle loopf endif @@ -1639,7 +1789,7 @@ subroutine init_predx if (istatus/=0) then write(6,'(''INIT_PREDX: Task '',i5,'' problem reading file '',a,'' header, iostat='',i4)') & mype,trim(fdiag_rad),istatus - close(lndiag) + call close_radiag(fdiag_rad,lndiag) cycle loopf endif @@ -1683,7 +1833,7 @@ subroutine init_predx ! Seviri channels should start at 4. If the first seviri channel is less than 4 ! do not use this diag* file if ( satsens(1:6) == 'seviri' .and. header_chan(1)%nuchan < 4) then - close(lndiag) + call close_radiag(fdiag_rad,lndiag) cycle loopf endif @@ -1701,9 +1851,9 @@ subroutine init_predx endif end do end do loop_a - + if (.not. update .and. new_chan==0) then - close(lndiag) + call close_radiag(fdiag_rad,lndiag) cycle loopf end if @@ -1712,6 +1862,7 @@ subroutine init_predx obstype == 'sndrd4' goes_img = obstype == 'goes_img' ahi = obstype == 'ahi' + abi = obstype == 'abi' avhrr = obstype == 'avhrr' avhrr_navy = obstype == 'avhrr_navy' ssmi = obstype == 'ssmi' @@ -1731,7 +1882,7 @@ subroutine init_predx saphir = obstype == 'saphir' amsr2 = obstype == 'amsr2' mean_only=ssmi .or. ssmis .or. amsre .or. goessndr .or. goes_img & - .or. ahi .or. seviri .or. tmi + .or. ahi .or. seviri .or. tmi .or. abi ! Allocate arrays and initialize if (mean_only) then np=1 @@ -1849,7 +2000,7 @@ subroutine init_predx ! End of loop over diagnostic file enddo loopd - close(lndiag) + call close_radiag(fdiag_rad,lndiag) ! Compute tlapmean if (update) then @@ -1917,6 +2068,17 @@ subroutine init_predx if (all(abs(AA) 200.0_r_kind) jjj=jjj+1 + enddo + if(jjj>0) cycle + endif predx(1,ich(i))=be(1) if (.not. mean_only) then @@ -2078,122 +2240,4 @@ subroutine dec2bin(dec,bin,ndim) RETURN END subroutine dec2bin - logical function adjust_jac_ (iinstr,isis,isfctype,nchanl,nsigradjac,ich,varinv,& - depart,obvarinv,adaptinf,wgtjo,jacobian) -!$$$ subprogram documentation block -! . . . -! subprogram: adjust_jac_ -! -! prgrmmr: todling org: gmao date: 2014-04-15 -! -! abstract: provide hook to module handling inter-channel ob correlated errors -! -! program history log: -! 2014-04-15 todling - initial code -! 2014-08-06 todling - change obtype to isis for more flexibity -! 2014-10-01 todling - add wgtjo to arg list -! 2015-04-01 W. Gu - revisit bias handling -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - use constants, only: zero,one - use correlated_obsmod, only: idnames - use correlated_obsmod, only: corr_ob_amiset - use correlated_obsmod, only: corr_ob_scale_jac - use correlated_obsmod, only: GSI_BundleErrorCov - use mpeu_util, only: getindex - use mpeu_util, only: die - implicit none - - character(len=*),intent(in) :: isis - integer(i_kind), intent(in) :: isfctype - integer(i_kind), intent(in) :: nchanl - integer(i_kind), intent(in) :: nsigradjac - integer(i_kind), intent(in) :: ich(nchanl) - real(r_kind), intent(inout) :: varinv(nchanl) - real(r_kind), intent(inout) :: depart(nchanl) - real(r_kind), intent(inout) :: obvarinv(nchanl) - real(r_kind), intent(inout) :: adaptinf(nchanl) - real(r_kind), intent(inout) :: wgtjo(nchanl) - real(r_kind), intent(inout) :: jacobian(nsigradjac,nchanl) - integer(i_kind), intent(out) :: iinstr - character(len=*),parameter::myname_ = myname//'*adjust_jac_' - character(len=80) covtype - - adjust_jac_=.false. - - if(.not.allocated(idnames)) then - return - endif - - iinstr=-1 - if(isfctype==0)then - covtype = trim(isis)//':sea' - iinstr=getindex(idnames,trim(covtype)) - else if(isfctype==1)then - covtype = trim(isis)//':land' - iinstr=getindex(idnames,trim(covtype)) - else if(isfctype==2)then - covtype = trim(isis)//':ice' - iinstr=getindex(idnames,trim(covtype)) - else if(isfctype==3)then - covtype = trim(isis)//':snow' - iinstr=getindex(idnames,trim(covtype)) - else if(isfctype==4)then - covtype = trim(isis)//':mixed' - iinstr=getindex(idnames,trim(covtype)) - endif - if(iinstr<0) return ! do not use the correlated errors - - if(.not.corr_ob_amiset(GSI_BundleErrorCov(iinstr))) then - call die(myname_,' improperly set GSI_BundleErrorCov') - endif - - if( GSI_BundleErrorCov(iinstr)%nch_active < 0) return - - adjust_jac_ = corr_ob_scale_jac(depart,obvarinv,adaptinf,jacobian,nchanl,jpch_rad,varinv,wgtjo, & - iuse_rad,ich,GSI_BundleErrorCov(iinstr)) -end function adjust_jac_ - -subroutine get_rsqrtinv_ (nchanl,iinstr,nchasm,ich,ichasm,varinv,rsqrtinv) -!$$$ subprogram documentation block -! . . . -! subprogram: get_rsqrtinv_ -! -! prgrmmr: Wei org: gmao date: 2015-03-11 -! -! abstract: provide hook to obtain the inverse of the square-root of R -! -! program history log: -! 2015-03-11 W. Gu - initial code -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - use constants, only: zero,one - use correlated_obsmod, only: corr_ob_rsqrtinv - use correlated_obsmod, only: GSI_BundleErrorCov - use mpeu_util, only: getindex - use mpeu_util, only: die - implicit none - integer(i_kind), intent(in) :: iinstr - integer(i_kind), intent(in) :: nchasm - integer(i_kind), intent(in) :: nchanl - integer(i_kind), intent(in) :: ich(nchasm) - integer(i_kind), intent(in) :: ichasm(nchasm) - real(r_kind), intent(in) :: varinv(nchasm) ! inverse of specified ob-error-variance - real(r_kind), intent(inout) :: rsqrtinv(nchasm,nchasm) - - character(len=*),parameter::myname_ = myname//'*get_rsqrtinv_' - - call corr_ob_rsqrtinv (nchanl,jpch_rad,iuse_rad,nchasm,ich,ichasm,varinv,& - rsqrtinv,GSI_BundleErrorCov(iinstr)) - -end subroutine get_rsqrtinv_ - end module radinfo diff --git a/src/raflib.f90 b/src/gsi/raflib.f90 similarity index 97% rename from src/raflib.f90 rename to src/gsi/raflib.f90 index 1dd70ec3a..227bda3cb 100644 --- a/src/raflib.f90 +++ b/src/gsi/raflib.f90 @@ -1325,45 +1325,41 @@ subroutine indexxi4(n,arrin4,indx) l=n/2+1 ir=n - 10 continue - - if(l>1) then - l=l-1 - indxt=indx(l) - q4=arrin4(indxt) - else - indxt=indx(ir) - q4=arrin4(indxt) - indx(ir)=indx(1) - ir=ir-1 - if(ir==1) then - indx(1)=indxt - return - end if - end if - - i=l - j=l+l - - 20 continue - - if(j<=ir) then - if(j1) then + l=l-1 + indxt=indx(l) + q4=arrin4(indxt) + else + indxt=indx(ir) + q4=arrin4(indxt) + indx(ir)=indx(1) + ir=ir-1 + if(ir==1) then + indx(1)=indxt + return + end if + end if + + i=l + j=l+l + + do while (j<=ir) + if(j1) then - l=l-1 - indxt=indx(l) - q8=arrin8(indxt) - else - indxt=indx(ir) - q8=arrin8(indxt) - indx(ir)=indx(1) - ir=ir-1 - if(ir==1) then - indx(1)=indxt - return + if(l>1) then + l=l-1 + indxt=indx(l) + q8=arrin8(indxt) + else + indxt=indx(ir) + q8=arrin8(indxt) + indx(ir)=indx(1) + ir=ir-1 + if(ir==1) then + indx(1)=indxt + return + end if end if - end if - i=l - j=l+l + i=l + j=l+l - 20 continue - - if(j<=ir) then - if(jzero) then ANORM=1.414_r_kind*SQRT(ANORM) ANRMX=ANORM*RANGE/FLOAT(N) ! @@ -4501,120 +4494,116 @@ SUBROUTINE EIGEN(A,R,N,MV) ! IND=0 THR=ANORM - 45 continue - THR=THR/FLOAT(N) - 50 continue - L=1 - 55 continue - M=L+1 -! -! COMPUTE SIN AND COS -! - 60 continue - MQ=(M*M-M)/2 - LQ=(L*L-L)/2 - LM=L+MQ - 62 continue - if(abs(a(lm))-thr=zero) go to 75 - Y=-Y + loop1: do + THR=THR/FLOAT(N) + loop2: do + L=1 + loop3: do + M=L+1 +! +! COMPUTE SIN AND COS +! + loop4: do + MQ=(M*M-M)/2 + LQ=(L*L-L)/2 + LM=L+MQ +! 62 continue + if(abs(a(lm))-thr>=zero) then + IND=1 + LL=L+LQ + MM=M+MQ + X=half*(A(LL)-A(MM)) + Y=-A(LM)/ SQRT(A(LM)*A(LM)+X*X) + if(x0) enddo - l_cloud_analysis = all(have_hmeteor) + l_hydrometeor_bkio = all(have_hmeteor) end if l_sfcobserror_ramp_t = .false. ! .true. = turn on GSD surface temperature observation error adjustment @@ -299,6 +342,15 @@ subroutine init_rapidrefresh_cldsurf l_closeobs = .false. ! .true. = pick the obs close to analysis time i_coastline = 0 ! turn coastline surface observation operator off i_gsdqc = 0 ! turn gsd obs QC off + qv_max_inc = 0.005_r_kind ! maximum water vapor increment in kg/kg + ioption = 2 ! default is median of samples + l_precip_clear_only = .false. ! .true. only use precip to clear + l_fog_off = .false. ! .true. is to turn off fog updates + cld_bld_coverage = 0.6_r_kind ! Percentage of cloud coverage for building qc/qi + cld_clr_coverage = 0.6_r_kind ! Percentage of cloud coverage for clearing qc/qi + i_cloud_q_innovation = 0 ! 0 = no increments from cloud obs + i_ens_mean = 0 ! typical ob behavior + DTsTmax = 20.0_r_kind ! maximum allowed difference between Ts and T 1st level return end subroutine init_rapidrefresh_cldsurf diff --git a/src/rdgrbsst.f90 b/src/gsi/rdgrbsst.f90 similarity index 100% rename from src/rdgrbsst.f90 rename to src/gsi/rdgrbsst.f90 diff --git a/src/read_Lightning.f90 b/src/gsi/read_Lightning.f90 similarity index 100% rename from src/read_Lightning.f90 rename to src/gsi/read_Lightning.f90 diff --git a/src/read_NASA_LaRC_cloud.f90 b/src/gsi/read_NASA_LaRC_cloud.f90 similarity index 100% rename from src/read_NASA_LaRC_cloud.f90 rename to src/gsi/read_NASA_LaRC_cloud.f90 diff --git a/src/gsi/read_abi.f90 b/src/gsi/read_abi.f90 new file mode 100644 index 000000000..465d7f22a --- /dev/null +++ b/src/gsi/read_abi.f90 @@ -0,0 +1,526 @@ +subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,& + gstime,infile,lunout,obstype,nread,ndata,nodata,twind,sis, & + mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs, & + nrec_start,dval_use) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_abi read abi bufr data +! prgmmr: liu, haixia org: np23 date: 2018-02-21 +! +! abstract: This routine reads BUFR format ABI 1b radiance (brightness +! temperature) files, which are bufrized from the NESDIS 1b data. Optionally, the +! data are thinned to a specified resolution using simple +! quality control checks. +! +! When running the gsi in regional mode, the code only +! retains those observations that fall within the regional +! domain +! +! program history log: +! 2018-02-21 hliu start the read_abi routine +! +! input argument list: +! mype - mpi task id +! val_abi - weighting factor applied to super obs +! ithin - flag to thin data +! rmesh - thinning mesh size (km) +! jsatid - satellite to read +! gstime - analysis time in minutes from reference date +! infile - unit from which to read BUFR data +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! twind - input group time window (hours) +! sis - satellite/instrument/sensor indicator +! nrec_start - first subset with useful information +! +! output argument list: +! nread - number of BUFR ABI 1b observations read +! ndata - number of BUFR ABI 1b profiles retained for further processing +! nodata - number of BUFR ABI 1b observations retained for further processing +! nobs - array of observations on each subdomain for each processor +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,r_double,i_kind + use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & + checkob,finalcheck,score_crit + use gridmod, only: diagnostic_reg,regional,nlat,nlon,txy2ll,tll2xy,rlats,rlons + use constants, only: deg2rad,zero,one,rad2deg,r60inv + use obsmod, only: bmiss + use radinfo, only: iuse_rad,jpch_rad,nusis + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use deter_sfc_mod, only: deter_sfc + use gsi_nstcouplermod, only: nst_gsi,nstinfo + use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter + use mpimod, only: npe + implicit none + +! Declare passed variables + character(len=*),intent(in):: infile,obstype,jsatid + character(len=20),intent(in):: sis + integer(i_kind),intent(in):: mype,lunout,ithin,nrec_start + integer(i_kind),intent(inout):: ndata,nodata + integer(i_kind),intent(inout):: nread + integer(i_kind),dimension(npe),intent(inout):: nobs + real(r_kind),intent(in):: rmesh,gstime,twind + real(r_kind),intent(inout):: val_abi + integer(i_kind),intent(in) :: mype_root + integer(i_kind),intent(in) :: mype_sub + integer(i_kind),intent(in) :: npe_sub + integer(i_kind),intent(in) :: mpi_comm_sub + logical ,intent(in) :: dval_use + +! Declare local parameters + real(r_kind),parameter:: r70=70.0_r_kind + real(r_kind),parameter:: r65=65.0_r_kind + real(r_kind),parameter:: r360=360.0_r_kind + real(r_kind),parameter:: tbmin=50.0_r_kind + real(r_kind),parameter:: tbmax=550.0_r_kind + +! Declare local variables + logical outside,iuse,assim,clrsky,allsky + + character(8) subset,subcsr,subasr + character(80):: hdrabi ! abi header + + integer(i_kind) nchanl,ilath,ilonh,ilzah,iszah,irec,next,ilazi,isazi + integer(i_kind) nmind,lnbufr,idate,ilat,ilon,nhdr,nchn,ncld,nbrst,jj + integer(i_kind) ireadmg,ireadsb,iret,nreal,nele,itt + integer(i_kind) itx,i,k,isflg,kidsat,n,iscan,idomsfc + integer(i_kind) idate5(5),maxinfo + integer(i_kind),allocatable,dimension(:)::nrec + + real(r_kind) dg2ew,sstime,tdiff,t4dv,sfcr + real(r_kind) dlon,dlat,timedif,crit1,dist1 + real(r_kind) dlon_earth,dlat_earth + real(r_kind) dlon_earth_deg,dlat_earth_deg + real(r_kind) pred + real(r_kind),dimension(0:4):: rlndsea + real(r_kind),dimension(0:3):: sfcpct + real(r_kind),dimension(0:3):: ts + real(r_kind) :: tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10 + real(r_kind),allocatable,dimension(:,:):: data_all + + real(r_kind),allocatable,dimension(:):: hdr ! abi imager header + real(r_kind),allocatable,dimension(:,:):: dataabi1,dataabi2,dataabi,dataabi3 ! abi imager data + real(r_kind) rclrsky,rcldfrc + real(r_kind) :: zob,tref,dtw,dtc,tz_tr + + real(r_kind) cdist,disterr,disterrmax,dlon00,dlat00 + integer(i_kind) ntest + + logical :: allchnmiss + +!************************************************************************** +! Initialize variables + maxinfo=32 + lnbufr = 10 + disterrmax=zero + ntest=0 + dg2ew = r360*deg2rad + + ilon=3 + ilat=4 + + if (nst_gsi > 0 ) then + call gsi_nstcoupler_skindepth(obstype, zob) ! get penetration depth (zob) for the obstype + endif + +! HLIU: NEED TO confirm + rlndsea(0) = zero + rlndsea(1) = 15._r_kind + rlndsea(2) = 10._r_kind + rlndsea(3) = 15._r_kind + rlndsea(4) = 30._r_kind + + nread=0 + ndata=0 + nodata=0 + nchanl=10 ! total # of IR channels + + ilath=8 ! the position of latitude in the header + ilonh=9 ! the position of longitude in the header + ilzah=10 ! satellite zenith angle + ilazi=11 ! satellite azimuth angle + iszah=12 ! solar zenith angle + isazi=13 ! solar azimuth angle + subcsr='NC021046' ! sub message + subasr='NC021045' ! sub message + +! If all channels of a given sensor are set to monitor or not +! assimilate mode (iuse_rad<1), reset relative weight to zero. +! We do not want such observations affecting the relative +! weighting between observations within a given thinning group. + + assim=.false. + search: do i=1,jpch_rad + if ((trim(nusis(i))==trim(sis)) .and. (iuse_rad(i)>0)) then + assim=.true. + exit search + endif + end do search + if (.not.assim) val_abi=zero + +! Open bufr file. + call closbf(lnbufr) + open(lnbufr,file=trim(infile),form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + call datelen(10) + call readmg(lnbufr,subset,idate,iret) + +! Check the data set + if( iret/=0) then + write(6,*) 'READ_ABI: SKIP PROCESSING OF ABI FILE' + write(6,*) 'infile=', lnbufr, infile + return + endif + + clrsky=.false. + allsky=.false. + if(subset == subcsr) then + clrsky=.true. + elseif(subset == subasr) then + allsky=.true. + else + write(6,*) 'READ_ABI: SKIP PROCESSING OF ABI FILE' + write(6,*) 'infile=', lnbufr, infile,' subset=', subset + return + endif + +! Make thinning grids + call makegrids(rmesh,ithin) + +! Set BUFR string based on abi data set + hdrabi='SAID YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH SAZA BEARAZ SOZA SOLAZI' + nhdr=13 + if (clrsky) then + nchn=10 + ncld=nchn + nbrst=nchn + else if (allsky) then + nchn=10 + ncld=2 + nbrst=nchn*6 ! channel dependent: all, clear, cloudy, low, middle and high clouds + endif + allocate(dataabi(1,4)) ! CLDMNT for ASR: not channel dependent + allocate(dataabi1(1,ncld)) ! NCLDMNT: 2 for ASR, not channel dependent; ncld for CSR, chn dependent + allocate(dataabi2(1,nbrst)) ! BT: channel dependent: all, clear, cloudy, low, middle and high clouds + allocate(dataabi3(1,nbrst)) ! SDTB: channel dependent: all, clear, cloudy, low, middle and high clouds + allocate(hdr(nhdr)) + + +! Allocate arrays to hold all data for given satellite + maxinfo=maxinfo+nchanl + if(dval_use) maxinfo = maxinfo + 2 + nreal = maxinfo + nstinfo + nele = nreal + nchanl + allocate(data_all(nele,itxmax),nrec(itxmax)) + + +! Reopen unit to bufr file + call closbf(lnbufr) + open(lnbufr,file=infile,form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + if(jsatid == 'gr' .or. jsatid == 'g16') kidsat = 270 + + + nrec=999999 + irec=0 + next=0 +! Big loop over bufr file + read_msg: do while (ireadmg(lnbufr,subset,idate) >= 0) + irec=irec+1 + if(irec < nrec_start) cycle read_msg + next=next+1 + if(next == npe_sub)next=0 + if(next /= mype_sub)cycle + + read_loop: do while (ireadsb(lnbufr) == 0) + +! Read through each record + call ufbint(lnbufr,hdr,nhdr,1,iret,hdrabi) + if(nint(hdr(1)) /= kidsat) cycle read_loop +! remove the obs whose satellite zenith angles larger than 65 degree + if ( hdr(ilzah) > r65 ) then + cycle read_loop + end if + +! Convert obs location from degrees to radians + if (hdr(ilonh)>=r360) hdr(ilonh)=hdr(ilonh)-r360 + if (hdr(ilonh)< zero) hdr(ilonh)=hdr(ilonh)+r360 + + dlon_earth_deg=hdr(ilonh) + dlat_earth_deg=hdr(ilath) + dlon_earth=hdr(ilonh)*deg2rad + dlat_earth=hdr(ilath)*deg2rad + +! If regional, map obs lat,lon to rotated grid. + if(regional)then + +! Convert to rotated coordinate. dlon centered on 180 (pi), +! so always positive for limited area + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + + if(diagnostic_reg) then + call txy2ll(dlon,dlat,dlon00,dlat00) + ntest=ntest+1 + cdist=sin(dlat_earth)*sin(dlat00)+cos(dlat_earth)*cos(dlat00)* & + (sin(dlon_earth)*sin(dlon00)+cos(dlon_earth)*cos(dlon00)) + cdist=max(-one,min(cdist,one)) + disterr=acos(cdist)*rad2deg + disterrmax=max(disterrmax,disterr) + end if + +! Check to see if in domain. outside=.true. if dlon_earth, +! dlat_earth outside domain, =.false. if inside + if(outside) cycle read_loop + +! Global case + else + dlon=dlon_earth + dlat=dlat_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + +! Compare relative obs time with window. If obs +! falls outside of window, don't use this obs + idate5(1) = hdr(2) ! year + idate5(2) = hdr(3) ! month + idate5(3) = hdr(4) ! day + idate5(4) = hdr(5) ! hours + idate5(5) = hdr(6) ! minutes + call w3fs21(idate5,nmind) + t4dv = (real((nmind-iwinbgn),r_kind) + real(hdr(7),r_kind)*r60inv)*r60inv + sstime = real(nmind,r_kind) + real(hdr(7),r_kind)*r60inv + tdiff=(sstime-gstime)*r60inv +! remove the tdiff QC check + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle read_loop + else + if (abs(tdiff)>twind) cycle read_loop + endif + if (thin4d) then + crit1=0.01_r_kind + else + timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 + crit1=0.01_r_kind+timedif + endif + + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + if(.not. iuse)cycle read_loop + + nread=nread+nchanl + + if(clrsky) then + call ufbrep(lnbufr,dataabi1,1,ncld,iret,'NCLDMNT') + rclrsky=bmiss +! dataabi1(1,2) is high-peaking water vapor channel +! for ABI CSR, clear-sky percentage are the same for all the channels + if(dataabi1(1,2)>= zero .and. dataabi1(1,2) <= 100.0_r_kind ) then + rclrsky=dataabi1(1,2) +! first QC filter out data with less clear sky fraction + if ( rclrsky < r70 ) cycle read_loop + end if + else if(allsky) then + call ufbrep(lnbufr,dataabi1,1,2,iret,'NCLDMNT') + rclrsky=dataabi1(1,2) !clear-sky percentage over sea + call ufbrep(lnbufr,dataabi,1,4,iret,'CLDMNT') + rcldfrc=dataabi(1,1) !total cloud + end if + + call ufbrep(lnbufr,dataabi2,1,nbrst,iret,'TMBRST') + call ufbrep(lnbufr,dataabi3,1,nbrst,iret,'SDTB') + +! toss data if SDTB>1.3 + do i=1,nbrst + if(i==2 .or. i==3 .or. i==4) then ! 3 water-vapor channels + if(dataabi3(1,i)>1.3_r_kind) cycle read_loop + end if + end do + + allchnmiss=.true. + do n=1,nchn + if(clrsky) then + if(dataabi2(1,n)<500.0_r_kind) then + allchnmiss=.false. + end if + else if(allsky) then + jj=(n-1)*6+1 + if(dataabi2(1,jj)<500.0_r_kind) then + allchnmiss=.false. + end if + end if + end do + if(allchnmiss) then + cycle read_loop + end if + +! Locate the observation on the analysis grid. Get sst and land/sea/ice +! mask. + +! isflg - surface flag +! 0 sea +! 1 land +! 2 sea ice +! 3 snow +! 4 mixed + + + call deter_sfc(dlat,dlon,dlat_earth,dlon_earth,t4dv,isflg,idomsfc,sfcpct, & + ts,tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr) + + crit1=crit1+rlndsea(isflg) + call checkob(dist1,crit1,itx,iuse) + if(.not. iuse)cycle read_loop + + +! Set common predictor parameters +! use NCLDMNT from chn7 (10.8 micron) as a QC predictor +! add SDTB from chn7 as QC predictor + pred=10-dataabi1(1,7)/10.0_r_kind+dataabi3(1,7)*10.0_r_kind +! +! Compute "score" for observation. All scores>=0.0. Lowest score is "best" + + crit1 = crit1+pred + call finalcheck(dist1,crit1,itx,iuse) + + if(.not. iuse)cycle read_loop + + iscan = nint(hdr(ilzah))+1.001_r_kind ! integer scan position HLIU check this + +! +! interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr +! + if ( nst_gsi > 0 ) then + tref = ts(0) + dtw = zero + dtc = zero + tz_tr = one + if ( sfcpct(0) > zero ) then + call gsi_nstcoupler_deter(dlat_earth,dlon_earth,t4dv,zob,tref,dtw,dtc,tz_tr) + endif + endif + + ndata=ndata+1 + +! Transfer information to work array + data_all( 1,itx) = hdr(1) ! satellite id + data_all( 2,itx) = t4dv ! analysis relative time + data_all( 3,itx) = dlon ! grid relative longitude + data_all( 4,itx) = dlat ! grid relative latitude + data_all( 5,itx) = hdr(ilzah)*deg2rad ! satellite zenith angle (radians) + data_all( 6,itx) = hdr(ilazi)*deg2rad ! satellite azimuth angle (radians) + data_all( 7,itx) = rclrsky ! clear sky amount + data_all( 8,itx) = iscan ! integer scan position + data_all( 9,itx) = hdr(iszah) ! solar zenith angle + data_all(10,itx) = hdr(isazi) ! solar azimuth angle + data_all(11,itx) = sfcpct(0) ! sea percentage of + data_all(12,itx) = sfcpct(1) ! land percentage + data_all(13,itx) = sfcpct(2) ! sea ice percentage + data_all(14,itx) = sfcpct(3) ! snow percentage + data_all(15,itx)= ts(0) ! ocean skin temperature + data_all(16,itx)= ts(1) ! land skin temperature + data_all(17,itx)= ts(2) ! ice skin temperature + data_all(18,itx)= ts(3) ! snow skin temperature + data_all(19,itx)= tsavg ! average skin temperature + data_all(20,itx)= vty ! vegetation type + data_all(21,itx)= vfr ! vegetation fraction + data_all(22,itx)= sty ! soil type + data_all(23,itx)= stp ! soil temperature + data_all(24,itx)= sm ! soil moisture + data_all(25,itx)= sn ! snow depth + data_all(26,itx)= zz ! surface height + data_all(27,itx)= idomsfc + 0.001_r_kind ! dominate surface type + data_all(28,itx)= sfcr ! surface roughness + data_all(29,itx)= ff10 ! ten meter wind factor + data_all(30,itx) = dlon_earth_deg ! earth relative longitude (degrees) + data_all(31,itx) = dlat_earth_deg ! earth relative latitude (degrees) + data_all(32,itx) = rcldfrc ! total cloud fraction from ABIASR + do k=1,nchanl + if(clrsky) then + data_all(32+k,itx) = dataabi3(1,k) ! BT standard deviation from ABICSR + else if(allsky) then + jj=k*6+1 + data_all(32+k,itx) = dataabi3(1,jj) ! BT standard deviation from ABIASR + end if + end do + + if(dval_use)then + data_all(maxinfo-1,itx) = val_abi + data_all(maxinfo,itx) = itt + end if + + if ( nst_gsi > 0 ) then + data_all(maxinfo+1,itx) = tref ! foundation temperature + data_all(maxinfo+2,itx) = dtw ! dt_warm at zob + data_all(maxinfo+3,itx) = dtc ! dt_cool at zob + data_all(maxinfo+4,itx) = tz_tr ! d(Tz)/d(Tr) + endif + + do k=1,nchanl + if (clrsky) then + data_all(k+nreal,itx)=dataabi2(1,k) ! for chn7,8,9,10,11,12,13,14,15,16 + else if (allsky) then + jj=k*6+1 + data_all(k+nreal,itx)=dataabi2(1,jj) ! all-sky radiance for chn 4,5,6,7,8,9,10,11 + end if + end do + nrec(itx)=irec + +! End of satellite read block + enddo read_loop + enddo read_msg + + call closbf(lnbufr) + + call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,& + nele,itxmax,nread,ndata,data_all,score_crit,nrec) + +! Allow single task to check for bad obs, update superobs sum, +! and write out data to scratch file for further processing. + if (mype_sub==mype_root.and.ndata>0) then + + do n=1,ndata + do k=1,nchanl + if(data_all(k+nreal,n) > tbmin .and. & + data_all(k+nreal,n) < tbmax)nodata=nodata+1 + end do + end do + if(dval_use .and. assim)then + do n=1,ndata + itt=nint(data_all(maxinfo,n)) + super_val(itt)=super_val(itt)+val_abi + end do + end if + +! Write retained data to local file + call count_obs(ndata,nele,ilat,ilon,data_all,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) ((data_all(k,n),k=1,nele),n=1,ndata) + + endif + +! Deallocate local arrays + deallocate(data_all,nrec) + deallocate(hdr,dataabi2,dataabi1,dataabi,dataabi3) + +! Deallocate satthin arrays + call destroygrids + +! Print data counts +! write(6,9000) infile,sis,nread,rmesh,ndata +!9000 format(' READ_ABI: infile=',a10,& +! ' sis=',a20,& +! ' nread=',i10, & +! ' rmesh=',f7.3,' ndata=',i10) + + if(diagnostic_reg.and.ntest>0) write(6,*)'READ_ABI: ',& + 'mype,ntest,disterrmax=',mype,ntest,disterrmax + +! End of routine + return +end subroutine read_abi diff --git a/src/gsi/read_aerosol.f90 b/src/gsi/read_aerosol.f90 new file mode 100644 index 000000000..67e6ab8e5 --- /dev/null +++ b/src/gsi/read_aerosol.f90 @@ -0,0 +1,585 @@ +subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, & + obstype,twind,sis,ithin,rmesh, & + mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_aerosol read aerosol data +! prgmmr: hchuang org: np23 date: 2009-01-26 +! +! abstract: This routine reads MODIS aerosol total column AOD observations. +! ONLY total column values are read in. The routine has +! the ability to read both IEEE and BUFR format MODIS +! as well as BUFR format VIIRS +! aerosol data files. +! +! When running the gsi in regional mode, the code only +! retains those observations that fall within the regional +! domain +! +! program history log: +! 2009-04-08 Huang - modified from read_ozone to read in MODIS AEROSOL data +! 2010-10-20 hclin - modified for total aod in channels +! 2011-01-05 hclin - added three more BUFR records (STYP DBCF QAOD) +! 2011-08-01 lueken - changed F90 to f90 (no machine logic) +! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) +! 2015-02-23 Rancic/Thomas - add thin4d to time window logical +! 2015-10-01 guo - calc ob location once in deg +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. +! 2019-03-22 martin - add VIIRS BUFR capability based on code from S-W Wei and Q. Zhao +! +! input argument list: +! obstype - observation type to process +! jsatid - satellite id to read +! infile - unit from which to read aerosol data +! gstime - analysis time in minutes from reference date +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! twind - input group time window (hours) +! sis - satellite/instrument/sensor indicator +! ithin - flag to thin data +! rmesh - thinning mesh size (km) +! mype - mpi task id +! mype_root - "root" task for sub-communicator +! mype_sub - mpi task id within sub-communicator +! npe_sub - number of data read tasks +! mpi_comm_sub - sub-communicator for data read +! +! output argument list: +! nread - number of modis aerosol observations read +! ndata - number of modis aerosol profiles retained for further processing +! nodata - number of modis aerosol observations retained for further processing +! nobs - array of observations on each subdomain for each processor +! +! remarks: +! +! attributes: +! language: f90 +! machine: IBM AIX Cirrus +! +!$$$ + use kinds, only: r_kind, r_double, i_kind + use gridmod, only: nlat, nlon, regional, tll2xy, rlats, rlons + use chemmod, only: aod_qa_limit, luse_deepblue + use constants, only: deg2rad, zero, one, two, three, four, five, r0_01, r60inv + use obsmod, only: rmiss_single + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen + use satthin, only: itxmax,makegrids,destroygrids,checkob, & + finalcheck,map2tgrid,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max + use mpimod, only: npe + implicit none +! +! Declare local parameters + real(r_kind), parameter :: r360 = 360.0_r_kind +! +! Declare passed variables +! + character(len=*),intent(in) :: obstype, infile, jsatid + character(len=20),intent(in) :: sis + integer(i_kind), intent(in) :: lunout, ithin + integer(i_kind), intent(inout) :: nread + integer(i_kind),dimension(npe), intent(inout) :: nobs + integer(i_kind), intent(inout) :: ndata, nodata + integer(i_kind) ,intent(in) :: mype_root + integer(i_kind) ,intent(in) :: mype_sub + integer(i_kind) ,intent(in) :: npe_sub + integer(i_kind) ,intent(in) :: mpi_comm_sub + real(r_kind), intent(in) :: gstime, twind, rmesh +! +! Declare local variables +! + logical :: outside, iuse + + character (len= 8) :: subset + character (len=10) :: date + + integer(i_kind) :: naerodat + integer(i_kind) :: idate, jdate, ksatid, iy, iret, im, ihh, idd + integer(i_kind) :: lunin = 10 + integer(i_kind) :: nmind, i, n + integer(i_kind) :: k, ilat, ilon, nreal, nchanl + integer(i_kind) :: kidsat + integer(i_kind), dimension(5) :: idate5 +! +!| NC008041 | SAID AEROSOL CLONH CLATH YYMMDD HHMMSS SOZA SOLAZI | +!| NC008041 | SCATTA OPTD AEROTP | +! +!| YYMMDD | YEAR MNTH DAYS | +!| | | +!| HHMMSS | HOUR MINU SECO | +! +! SAID Satellite identifier code table (eg, 783 == 'TERRA') +! AEROSOL Aerosol Optical Depth (AOD) source code table (eg, 5 == 'AATSR' ) +! YEAR Year +! MNTH Month +! DAYS Day +! HOUR Hour +! MINU Minute +! SECO Second +! CLATH Latitude (high accuracy) degree (5 decimal precision) +! CLONH Longitude (high accuracy) degree (5 decimal precision) +! SOLAZI Solar azimuth degree (2 decimal precision) +! SOZA Solar zenith angle degree (2 decimal precision) +! OPTD Optical depth numeric +! SCATTA Scattering angle degree (2 decimal precsion) +! AEROTP Aerosol type land code table (eg, 1 == 'DUST', 2 == 'SULFATE') +! +! 0-15-195 - AEROTP (Aerosol land type) +! +! CODE DESCRIPTION +! ==== =========== +! 0 Mixed +! 1 Dust +! 2 Sulfate +! 3 Smoke +! 4 Heavy absorbing smoke +! 5-14 Reserved +! 15 Missing value +! + character (len= 4) :: aerostr = 'OPTD' + character (len=53) :: aerogstr = & + 'SAID CLATH CLONH YEAR MNTH DAYS HOUR MINU SOZA SOLAZI' + +! VIIRS AOD code + character (len= 9) :: vaodchstr = 'CHWL AOTH' + character (len=69) :: vaodgstr = & + 'SAID CLATH CLONH YEAR MNTH DAYS HOUR MINU SOZA SOLAZI RSST VAOTQ QPLR' + integer(i_kind), parameter :: mxib = 20 + integer(i_kind) :: nib + integer(i_kind) :: ibit(mxib) + + integer(i_kind) :: itx, itt, irec + + real(r_kind) :: tdiff, sstime, dlon, dlat, t4dv, crit1, dist1 + real(r_kind) :: slons0, slats0, rsat, solzen, azimuth, dlat_earth, dlon_earth + real(r_kind) :: dlat_earth_deg, dlon_earth_deg + real(r_kind) :: styp, dbcf, qaod, smask, qcall + real(r_kind) :: qcall_limit ! qcall >= qcall_limit will be retained + + real(r_kind),dimension(0:6):: rlndsea + + real(r_kind), allocatable, dimension(:,:) :: aeroout + real(r_kind), allocatable, dimension(:) :: dataaod + integer(i_kind),allocatable,dimension(:) :: nrec + real(r_double), dimension( 10) :: hdraerog + real(r_double) :: aod_550 + real(r_double), dimension(3) :: aod_flags + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh +! for VIIRS + real(r_double),dimension(13) :: hdrvaodg + real(r_double),dimension(2,12) :: vaodch + real(r_double) :: aod_lb,aod_ub + +!************************************************************************** +! Set constants. Initialize variables + rsat=999._r_kind + ! output position of LON and LAT + ilon=3 + ilat=4 + nread = 0 + ndata = 0 + nodata = 0 + + ! Set rlndsea for types we would prefer selecting + rlndsea(0) = zero ! styp 0: water + rlndsea(1) = 15._r_kind ! styp 1: coast + rlndsea(2) = 20._r_kind ! styp 2: desert + rlndsea(3) = 10._r_kind ! styp 3: land + rlndsea(4) = 25._r_kind ! styp 4: deep blue + rlndsea(5) = 30._r_kind ! styp 5: nnr ocean + rlndsea(6) = 35._r_kind ! styp 6: nnr land + + + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif +! Make thinning grids + call makegrids(rmesh,ithin,n_tbin=n_tbin) + + if ( obstype == 'modis_aod' ) then +! + open(lunin,file=trim(infile),form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + call readmg(lunin,subset,idate,iret) + + if ( iret == 0 ) then +! + if (subset == 'NC008041') then + write(6,*)'READ_AEROSOL: MODIS data type, subset = ',subset + ! Set dependent variables and allocate arrays + nreal=11 !9 + nchanl=20 ! 19 + 1 additional vis channel in CRTM coeff file + naerodat=nreal+nchanl + allocate (aeroout(naerodat,itxmax),nrec(itxmax)) + allocate (dataaod(nchanl)) + + iy = 0 + im = 0 + idd= 0 + ihh= 0 + write(date,'( i10)') idate + read (date,'(i4,3i2)') iy,im,idd,ihh + write(6,'(''READ_AEROSOL: aerosol bufr file '',a,'' date is '',i4,4i2.2,a)')trim(infile),iy,im,idd,ihh + + nrec=999999 + irec=0 + read_modis: do + irec=irec+1 + call readsb(lunin,iret) + if (iret/=0) then + call readmg(lunin,subset,jdate,iret) + if (iret/=0) exit read_modis + cycle read_modis + endif + + ! extract header information + call ufbint(lunin,hdraerog,10,1,iret,aerogstr) + rsat = hdraerog(1); ksatid=rsat + + if ( jsatid == 'terra' ) kidsat = 783 + if ( jsatid == 'aqua' ) kidsat = 784 + + if ( ksatid /= kidsat ) cycle read_modis + + ! Convert observation location to radians + slats0= hdraerog(2) + slons0= hdraerog(3) + if(slons0< zero) slons0=slons0+r360 + if(slons0>=r360) slons0=slons0-r360 + dlat_earth_deg = slats0 + dlon_earth_deg = slons0 + dlat_earth = slats0 * deg2rad + dlon_earth = slons0 * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if(outside) cycle read_modis + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + + solzen = hdraerog(9) + azimuth = hdraerog(10) + + ! Convert observation time to relative time + idate5(1) = hdraerog(4) !year + idate5(2) = hdraerog(5) !month + idate5(3) = hdraerog(6) !day + idate5(4) = hdraerog(7) !hour + idate5(5) = hdraerog(8) !minute + + ! extract total column aod 1 value 'OPTD' as defined in aerostr + call ufbint(lunin,aod_550,1,1,iret,aerostr) + + call w3fs21(idate5,nmind) + t4dv=real((nmind-iwinbgn),r_kind)*r60inv + sstime=real(nmind,r_kind) + tdiff=(sstime-gstime)*r60inv + if (l4dvar.or.l4densvar) then + if(t4dvwinlen) cycle read_modis + else + if ( abs(tdiff) > twind ) cycle read_modis + end if + + nread = nread + 1 !nread = nread + nchanl + + if ( aod_550 > 1.0e+10_r_double ) cycle read_modis + + ! extract STYP, DBCF, and QAOD + ! these are missing from the 008041 bufr files + styp = rmiss_single + dbcf = rmiss_single + qaod = zero + + if ( .not. luse_deepblue .and. nint(styp)==4 ) cycle read_modis + if ( qaod > aod_qa_limit ) cycle read_modis + + ! Map obs to thinning grid + crit0 = 0.01_r_kind + timeinflat=two + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) + if ( .not. iuse ) cycle read_modis + + if ( (styp > rmiss_single) .and. (styp >= zero .and. styp <= four) ) then + crit1 = crit1 + rlndsea(nint(styp)) + end if + if ( (qaod > rmiss_single) .and. (qaod >= aod_qa_limit .and. qaod <= three) ) then + crit1 = crit1 + 10.0_r_kind*(four-qaod) + end if + call checkob(dist1,crit1,itx,iuse) + if ( .not. iuse ) cycle read_modis + + ! Compute "score" for observation. All scores>=0.0. Lowest score is "best" + call finalcheck(dist1,crit1,itx,iuse) + if ( .not. iuse ) cycle read_modis + + dataaod = rmiss_single + dataaod(4) = aod_550 + + aeroout( 1,itx) = rsat + aeroout( 2,itx) = tdiff + aeroout( 3,itx) = dlon ! grid relative longitude + aeroout( 4,itx) = dlat ! grid relative latitude + aeroout( 5,itx) = dlon_earth_deg ! earth relative longitude (degrees) + aeroout( 6,itx) = dlat_earth_deg ! earth relative latitude (degrees) + aeroout( 7,itx) = qaod ! total column AOD error flag + aeroout( 8,itx) = solzen ! solar zenith angle + aeroout( 9,itx) = azimuth ! solar azimuth angle + aeroout(10,itx) = styp ! surface type + aeroout(11,itx) = dbcf ! deep blue confidence flag + do i = 1, nchanl + aeroout(i+nreal,itx) = dataaod(i) + end do + nrec(itx)=irec + + end do read_modis + + call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,& + naerodat,itxmax,nread,ndata,aeroout,score_crit,nrec) + + if ( mype_sub == mype_root ) then + do n = 1, ndata + do i = 1, nchanl + if ( aeroout(i+nreal,n) > rmiss_single ) nodata = nodata + 1 + end do + end do + ! Write final set of "best" observations to output file + call count_obs(ndata,naerodat,ilat,ilon,aeroout,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) ((aeroout(k,n),k=1,naerodat),n=1,ndata) + end if + + ! Deallocate local arrays + deallocate(aeroout) + deallocate(dataaod) + + ! End of MODIS bufr block + else ! subset /= NC008041 + write(6,*)'READ_AEROSOL: *** WARNING: unknown aerosol data type, subset=',subset + write(6,*)' infile=',infile, ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid + write(6,*)' SKIP PROCESSING OF THIS MODIS FILE' + endif + + else ! read subset iret /= 0 + write(6,*)'READ_AEROSOL: *** WARNING: read subset error, obstype=',obstype,', iret=',iret + end if + call closbf(lunin) + close(lunin) + else if ( obstype == 'viirs_aod' ) then + open(lunin,file=trim(infile),form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + call readmg(lunin,subset,idate,iret) + + if ( iret == 0 ) then + + if (subset == 'NC008043') then + write(6,*)'READ_AEROSOL: VIIRS AOD data type, subset = ',subset + ! Set dependent variables and allocate arrays + nreal=10 + nchanl=11 + naerodat=nreal+nchanl + allocate (aeroout(naerodat,itxmax),nrec(itxmax)) + allocate (dataaod(nchanl)) + + iy = 0 + im = 0 + idd= 0 + ihh= 0 + write(date,'( i10)') idate + read (date,'(i4,3i2)') iy,im,idd,ihh + write(6,'(''READ_AEROSOL: aerosol bufr file '',a,'' date is '',i4,3i2.2)') trim(infile),iy,im,idd,ihh + +! set qcall_limit + if (idate >= 2018021300) then + qcall_limit = aod_qa_limit + r0_01 ! for the viirs data after 2018/02/13 + else + qcall_limit = aod_qa_limit - r0_01 + end if + +! set valid range of AOD to ingest + aod_lb = zero + aod_ub = five + nrec=999999 + irec=0 + read_viirs: do + irec=irec+1 + call readsb(lunin,iret) + if (iret/=0) then + call readmg(lunin,subset,jdate,iret) + if (iret/=0) exit read_viirs + cycle read_viirs + endif + + ! extract header information + call ufbint(lunin,hdrvaodg,13,1,iret,vaodgstr) + rsat = hdrvaodg(1); ksatid=rsat + + if ( jsatid == 'NPP' .or. jsatid == 'npp' ) kidsat = 225 + + if ( ksatid /= kidsat ) cycle read_viirs + + ! Convert observation location to radians + slats0= hdrvaodg(2) + slons0= hdrvaodg(3) + if(slons0< zero) slons0=slons0+r360 + if(slons0>=r360) slons0=slons0-r360 + dlat_earth_deg = slats0 + dlon_earth_deg = slons0 + dlat_earth = slats0 * deg2rad + dlon_earth = slons0 * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if(outside) cycle read_viirs + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + + solzen = hdrvaodg(9) + azimuth = hdrvaodg(10) + + smask = zero ! over water + if (nint(hdrvaodg(11)) > 0) then ! over land + smask = one ! dark surface + call upftbv(lunin,"VAOTQ",hdrvaodg(12),mxib,ibit,nib) + if (nib > 0) then + if(any(ibit(1:nib) == 6)) then + smask = two ! bright surface + endif + endif + endif + + qcall = hdrvaodg(13) + + ! Convert observation time to relative time + idate5(1) = hdrvaodg(4) !year + idate5(2) = hdrvaodg(5) !month + idate5(3) = hdrvaodg(6) !day + idate5(4) = hdrvaodg(7) !hour + idate5(5) = hdrvaodg(8) !minute + + call w3fs21(idate5,nmind) + t4dv=real((nmind-iwinbgn),r_kind)*r60inv + sstime=real(nmind,r_kind) + tdiff=(sstime-gstime)*r60inv + + if (l4dvar.or.l4densvar) then + if(t4dvwinlen) cycle read_viirs + else + if ( abs(tdiff) > twind ) cycle read_viirs + end if + + nread = nread + 1 !nread = nread + nchanl + + if (idate >= 2018021300) then + if ( qcall > qcall_limit ) cycle read_viirs + else + if ( qcall < qcall_limit ) cycle read_viirs + end if + + ! extract VAODCH pairs 'CHWL AOPT' as defined in vaodchstr + call ufbrep(lunin,vaodch,2,12,iret,vaodchstr) + aod_550 = vaodch(2,12) + + if ( aod_550 < aod_lb .OR. aod_550 >= aod_ub ) cycle read_viirs + + + ! Map obs to thinning grid + crit0 = 0.01_r_kind + timeinflat=two + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + + if ( .not. iuse ) cycle read_viirs + + crit1 = crit1 + 10.0_r_kind*smask + ! is below needed now because of the change in QC flags? CRM + if (idate >= 2018021300) then + crit1 = crit1 + 10.0_r_kind*(four+qcall) + else + crit1 = crit1 + 10.0_r_kind*(four-qcall) + end if + call checkob(dist1,crit1,itx,iuse) + + if ( .not. iuse ) cycle read_viirs + + ! Compute "score" for observation. All scores>=0.0. Lowest score + ! is "best" + call finalcheck(dist1,crit1,itx,iuse) + + if ( .not. iuse ) cycle read_viirs + + dataaod = rmiss_single + dataaod(4) = aod_550 + + aeroout( 1,itx) = rsat + aeroout( 2,itx) = tdiff + aeroout( 3,itx) = dlon ! grid relative longitude + aeroout( 4,itx) = dlat ! grid relative latitude + aeroout( 5,itx) = dlon_earth_deg ! earth relative longitude (degrees) + aeroout( 6,itx) = dlat_earth_deg ! earth relative latitude (degrees) + aeroout( 7,itx) = qcall ! total column AOD error flag + aeroout( 8,itx) = solzen ! solar zenith angle + aeroout( 9,itx) = azimuth ! solar azimuth angle + aeroout(10,itx) = smask ! surface type mask + do i = 1, nchanl + aeroout(i+nreal,itx) = dataaod(i) + enddo + nrec(itx)=irec + + end do read_viirs + + call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,& + naerodat,itxmax,nread,ndata,aeroout,score_crit,nrec) + + if ( mype_sub == mype_root ) then + do n = 1, ndata + do i = 1, nchanl + if ( aeroout(i+nreal,n) > rmiss_single ) nodata = nodata + 1 + end do + end do + ! Write final set of "best" observations to output file + call count_obs(ndata,naerodat,ilat,ilon,aeroout,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) ((aeroout(k,n),k=1,naerodat),n=1,ndata) + end if + + ! Deallocate local arrays + deallocate(aeroout) + + ! End of VIIRS AOD bufr block + + else ! subset /= NC008043 + write(6,*)'READ_AEROSOL: *** WARNING: unknown aerosol data type, subset=',subset + write(6,*)' infile=',infile, ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid + write(6,*)' SKIP PROCESSING OF THIS VIIRS_AOD FILE' + endif + + else ! read subset iret /= 0 + write(6,*)'READ_AEROSOL: *** WARNING: read subset error, obstype=',obstype,', iret=',iret + end if + call closbf(lunin) + close(lunin) + + else ! obstype /= 'modis' or 'viirs' + write(6,*)'READ_AEROSOL: *** WARNING: unknown aerosol input type, obstype=',obstype + endif + + ! Deallocate satthin arrays + call destroygrids + +end subroutine read_aerosol diff --git a/src/read_ahi.f90 b/src/gsi/read_ahi.f90 similarity index 93% rename from src/read_ahi.f90 rename to src/gsi/read_ahi.f90 index e4908f98c..b7f8ee3ae 100644 --- a/src/read_ahi.f90 +++ b/src/gsi/read_ahi.f90 @@ -1,6 +1,6 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& infile,lunout,obstype,nread,ndata,nodata,twind,sis, & - mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs) + mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs,dval_use) !$$$ subprogram documentation block ! . . . . ! subprogram: read_ahi read himawari-8 ahi data @@ -21,6 +21,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& ! 2015-03-23 zaizhong cleaned up and finalized with the real sample data ! 2015-09-17 Thomas add l4densvar and thin4d to data selection procedure ! 2016-03-11 j. guo Fixed {dlat,dlon}_earth_deg in the obs data stream +! 2018-05-21 j.jin Added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -49,10 +50,12 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & checkob,finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use gridmod, only: diagnostic_reg,regional,nlat,nlon,txy2ll,tll2xy,rlats,rlons use constants, only: deg2rad,zero,one,rad2deg,r60inv,r60 use radinfo, only: iuse_rad,jpch_rad,nusis - use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar,thin4d + use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar use deter_sfc_mod, only: deter_sfc use gsi_nstcouplermod, only: nst_gsi,nstinfo use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter @@ -74,10 +77,10 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& integer(i_kind) ,intent(in ) :: mype_sub integer(i_kind) ,intent(in ) :: npe_sub integer(i_kind) ,intent(in ) :: mpi_comm_sub + logical ,intent(in) :: dval_use ! Declare local parameters integer(i_kind),parameter:: nimghdr=13 - integer(i_kind),parameter:: maxinfo=33 integer(i_kind),parameter:: maxchanl=11 real(r_kind),parameter:: r360=360.0_r_kind real(r_kind),parameter:: r180=180.0_r_kind @@ -91,7 +94,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& character(8) subset - integer(i_kind) nchanl,ilath,ilonh,ilzah,iszah,irec,next + integer(i_kind) nchanl,ilath,ilonh,ilzah,iszah,irec,next,maxinfo integer(i_kind) nmind,lnbufr,idate,ilat,ilon integer(i_kind) ireadmg,ireadsb,iret,nreal,nele,itt integer(i_kind) itx,i,k,isflg,kidsat,n,iscan,idomsfc @@ -99,7 +102,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& integer(i_kind),allocatable,dimension(:)::nrec real(r_kind) dg2ew,sstime,tdiff,t4dv,sfcr - real(r_kind) dlon,dlat,timedif,crit1,dist1 + real(r_kind) dlon,dlat,crit1,dist1 real(r_kind) dlon_earth,dlat_earth real(r_kind) dlon_earth_deg,dlat_earth_deg real(r_kind) pred @@ -128,6 +131,8 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& real(r_kind) disterr,disterrmax,dlon00,dlat00 integer(i_kind) ntest + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh !************************************************************************** ! Initialize variables @@ -165,9 +170,14 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& end do search if (.not.assim) val_img=zero - + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Open bufr file. @@ -178,6 +188,9 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& if(jsatid == 'himawari8') kidsat = 173 ! Allocate arrays to hold all data for given satellite + + maxinfo=31 + if(dval_use) maxinfo = maxinfo + 2 nreal = maxinfo + nstinfo nele = nreal + nchanl allocate(data_all(nele,itxmax),nrec(itxmax)) @@ -270,13 +283,10 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& call grdcrd1(dlon,rlons,nlon,1) endif - if (thin4d) then - crit1=0.01_r_kind - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - crit1=0.01_r_kind+timedif - endif - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0 = 0.01_r_kind + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle read_loop @@ -395,8 +405,11 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& data_all(29,itx)= ff10 ! ten meter wind factor data_all(30,itx)= dlon_earth_deg ! earth relative longitude (degrees) data_all(31,itx)= dlat_earth_deg ! earth relative latitude (degrees) - data_all(32,itx) = val_img - data_all(33,itx) = itt + + if(dval_use)then + data_all(maxinfo-1,itx) = val_img + data_all(maxinfo,itx) = itt + end if if ( nst_gsi > 0 ) then data_all(maxinfo+1,itx) = tref ! foundation temperature @@ -426,9 +439,13 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,& if(data_all(k+nreal,n) > tbmin .and. & data_all(k+nreal,n) < tbmax)nodata=nodata+1 end do - itt=nint(data_all(maxinfo,n)) - super_val(itt)=super_val(itt)+val_img end do + if(dval_use .and. assim)then + do n=1,ndata + itt=nint(data_all(maxinfo,n)) + super_val(itt)=super_val(itt)+val_img + end do + end if ! Write final set of "best" observations to output file call count_obs(ndata,nele,ilat,ilon,data_all,nobs) diff --git a/src/read_airs.f90 b/src/gsi/read_airs.f90 similarity index 97% rename from src/read_airs.f90 rename to src/gsi/read_airs.f90 index 85fa11dd7..62e4cc2ea 100644 --- a/src/read_airs.f90 +++ b/src/gsi/read_airs.f90 @@ -71,6 +71,7 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,& ! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) ! 2015-02-23 Rancic/Thomas - add thin4d to time window logical ! 2015-10-22 Jung - added logic to allow subset changes based on the satinfo file +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -109,13 +110,15 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & finalcheck,checkob,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only: cbias,newchn,iuse_rad,nusis,jpch_rad,ang_rad, & nuchan, adp_anglebc,use_edges,radedge1,radedge2, & radstep,radstart,newpc4pred use gridmod, only: diagnostic_reg,regional,nlat,nlon,& tll2xy,txy2ll,rlats,rlons use constants, only: zero,deg2rad,one,three,five,rad2deg,r60inv - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use calc_fov_crosstrk, only : instrument_init, fov_cleanup, fov_check use deter_sfc_mod, only: deter_sfc_fov,deter_sfc use gsi_nstcouplermod, only: nst_gsi,nstinfo @@ -189,7 +192,7 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind) :: ch15, ch3, df2, tt real(r_kind) :: dlon, dlat real(r_kind) :: dlon_earth,dlat_earth, lza - real(r_kind) :: timedif, pred, crit1, qval, ch1, ch2, d0, cosza, dist1 + real(r_kind) :: pred, crit1, qval, ch1, ch2, d0, cosza, dist1 real(r_kind) :: sat_zenang, sol_zenang, sat_aziang, sol_aziang real(r_kind) :: ch8ch18, ch8ch19, ch18ch19, tmpinv real(r_kind) :: tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10 @@ -227,6 +230,8 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,& integer(i_kind) ntest logical :: airs, amsua, hsb, airstab + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh logical print_verbose @@ -350,8 +355,14 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,& endif endif + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Open BUFR file open(lnbufr,file=trim(infile),form='unformatted') @@ -515,13 +526,10 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,& ! Increment nread ounter by satinfo_nchan nread = nread + satinfo_nchan - if (thin4d) then - crit1 = 0.01_r_kind - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - crit1 = 0.01_r_kind+timedif - endif - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0 = 0.01_r_kind + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle read_loop ! "Score" observation. We use this information to identify "best" obs diff --git a/src/read_amsr2.f90 b/src/gsi/read_amsr2.f90 similarity index 95% rename from src/read_amsr2.f90 rename to src/gsi/read_amsr2.f90 index d761cca3d..ed0429483 100644 --- a/src/read_amsr2.f90 +++ b/src/gsi/read_amsr2.f90 @@ -1,4 +1,4 @@ -subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& +subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,jsatid,gstime,& infile,lunout,obstype,nread,ndata,nodata,twind,sis,& mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs) @@ -24,6 +24,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& ! 2016-07-25 ejones - made most allocatable arrays static ! 2016-09-20 j. guo - Refixed dlxx_earth_deg, for the new dlxx_earth_save(:). ! 2017-01-03 todling - treat save arrays as allocatable +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! ! input argument list: @@ -56,11 +57,13 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & checkob,finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only: iuse_rad,nusis,jpch_rad,amsr2_method use gridmod, only: diagnostic_reg,regional,nlat,nlon,rlats,rlons,& tll2xy use constants, only: deg2rad,zero,one,three,r60inv,two - use gsi_4dvar, only: l4dvar, iwinbgn, winlen, l4densvar, thin4d + use gsi_4dvar, only: l4dvar, iwinbgn, winlen, l4densvar use calc_fov_conical, only: instrument_init use deter_sfc_mod, only: deter_sfc_fov,deter_sfc use gsi_nstcouplermod, only: nst_gsi,nstinfo @@ -74,7 +77,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& ! Input variables character(len=*) ,intent(in ) :: infile - character(len=*) ,intent(in ) :: obstype + character(len=*) ,intent(in ) :: obstype,jsatid integer(i_kind) ,intent(in ) :: mype integer(i_kind) ,intent(in ) :: ithin integer(i_kind) ,intent(in ) :: lunout @@ -122,7 +125,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& integer(i_kind),dimension(n_amsrch) :: kchamsr2 real(r_kind) :: sfcr real(r_kind) :: dlon, dlat - real(r_kind) :: timedif, dist1 + real(r_kind) :: dist1 real(r_kind),allocatable,dimension(:,:):: data_all integer(i_kind),allocatable,dimension(:)::nrec integer(i_kind):: irec,next @@ -152,6 +155,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& integer(i_kind),target,allocatable,dimension(:) :: iscan_save integer(i_kind),target,allocatable,dimension(:) :: iorbn_save integer(i_kind),target,allocatable,dimension(:) :: inode_save + integer(i_kind),target,allocatable,dimension(:) :: it_mesh_save real(r_kind),target,allocatable,dimension(:) :: dlon_earth_save real(r_kind),target,allocatable,dimension(:) :: dlat_earth_save real(r_kind),target,allocatable,dimension(:) :: sat_zen_ang_save,sat_az_ang_save @@ -185,6 +189,9 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& real(r_kind),parameter:: one_minute=0.01666667_r_kind real(r_kind),parameter:: minus_one_minute=-0.01666667_r_kind + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin + integer(i_kind),pointer:: it_mesh => null() ! ---------------------------------------------------------------------- ! Initialize variables @@ -231,8 +238,14 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& end do search if (.not.assim) val_amsr2=zero + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) inode_save = 0 @@ -256,6 +269,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& dlon_earth => dlon_earth_save(iobs) dlat_earth => dlat_earth_save(iobs) crit1 => crit1_save(iobs) + it_mesh => it_mesh_save(iobs) ifov => ifov_save(iobs) iscan => iscan_save(iobs) iorbn => iorbn_save(iobs) @@ -315,12 +329,10 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& else if (abs(tdiff)>twind) cycle read_loop endif - if (thin4d) then - timedif = zero - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - endif + crit0 = 0.01_r_kind + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) ! --- Check observing position ----- clath= amsrspot_d(08) @@ -345,8 +357,6 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& dlat_earth = clath !* deg2rad dlon_earth = clonh !* deg2rad - crit1 = 0.01_r_kind+timedif - !! Retrieve bufr 3/4 : get amsrchan call ufbrep(lnbufr,amsrchan_d,3,14,iret,'SCCF ACQF TMBR') @@ -437,6 +447,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& dlon_earth_save(1:num_obs) = dlon_earth_save(sorted_index) dlat_earth_save(1:num_obs) = dlat_earth_save(sorted_index) crit1_save(1:num_obs) = crit1_save(sorted_index) + it_mesh_save(1:num_obs) = it_mesh_save(sorted_index) ifov_save(1:num_obs) = ifov_save(sorted_index) iscan_save(1:num_obs) = iscan_save(sorted_index) iorbn_save(1:num_obs) = iorbn_save(sorted_index) @@ -484,6 +495,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& dlon_earth => dlon_earth_save(iobs) dlat_earth => dlat_earth_save(iobs) crit1 => crit1_save(iobs) + it_mesh => it_mesh_save(iobs) ifov => ifov_save(iobs) iscan => iscan_save(iobs) iorbn => iorbn_save(iobs) @@ -519,15 +531,15 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,gstime,& endif ! Check time + tdiff=t4dv+(iwinbgn-gstime)*r60inv if (l4dvar) then if (t4dvwinlen) cycle obsloop else - tdiff=t4dv+(iwinbgn-gstime)*r60inv if(abs(tdiff) > twind) cycle obsloop endif ! Map obs to thinning grid - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse) then cycle obsloop endif @@ -697,6 +709,7 @@ subroutine init_(kchanl,maxobs) allocate(sun_zen_ang_save(maxobs),sun_az_ang_save(maxobs)) allocate(t4dv_save(maxobs)) allocate(crit1_save(maxobs)) + allocate(it_mesh_save(maxobs)) allocate(tbob_save(kchanl,maxobs)) end subroutine init_ @@ -705,6 +718,7 @@ subroutine clean_ deallocate(tbob_save) deallocate(crit1_save) + deallocate(it_mesh_save) deallocate(t4dv_save) deallocate(sun_zen_ang_save,sun_az_ang_save) deallocate(sat_zen_ang_save,sat_az_ang_save) diff --git a/src/read_amsre.f90 b/src/gsi/read_amsre.f90 old mode 100644 new mode 100755 similarity index 97% rename from src/read_amsre.f90 rename to src/gsi/read_amsre.f90 index 0d916e6a8..99a325c6c --- a/src/read_amsre.f90 +++ b/src/gsi/read_amsre.f90 @@ -1,4 +1,4 @@ -subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,gstime,& +subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,jsatid,gstime,& infile,lunout,obstype,nread,ndata,nodata,twind,sis,& mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs,nrec_start,dval_use) @@ -63,6 +63,7 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,gstime,& ! 2012-03-05 akella - nst now controlled via coupler ! 2015-02-23 Rancic/Thomas - add thin4d to time window logical ! 2015-10-01 guo - consolidate use of ob location (in deg) +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -98,11 +99,13 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,gstime,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & checkob,finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only: iuse_rad,nusis,jpch_rad use gridmod, only: diagnostic_reg,regional,nlat,nlon,rlats,rlons,& tll2xy use constants, only: deg2rad,zero,one,three,r60inv - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use calc_fov_conical, only: instrument_init use deter_sfc_mod, only: deter_sfc_fov,deter_sfc,deter_sfc_amsre_low use gsi_nstcouplermod, only: nst_gsi,nstinfo @@ -114,7 +117,7 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,gstime,& ! Input variables character(len=*) ,intent(in ) :: infile - character(len=*) ,intent(in ) :: obstype + character(len=*) ,intent(in ) :: obstype,jsatid integer(i_kind) ,intent(in ) :: mype,nrec_start integer(i_kind) ,intent(inout) :: isfcalc integer(i_kind) ,intent(in ) :: ithin @@ -163,7 +166,7 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,gstime,& real(r_kind) :: sfcr real(r_kind) :: dlon, dlat real(r_kind) :: dlon_earth,dlat_earth - real(r_kind) :: timedif, pred, crit1, dist1 + real(r_kind) :: pred, crit1, dist1 real(r_kind),allocatable,dimension(:,:):: data_all integer(i_kind),allocatable,dimension(:)::nrec integer(i_kind):: irec,next @@ -229,6 +232,8 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,gstime,& ! logical :: remove_ovlporbit = .true. !looks like AMSRE overlap problem is not as bad as SSM/I 10/14/04 kozo integer(i_kind) :: orbit, old_orbit, iorbit, ireadsb, ireadmg real(r_kind) :: saz + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh ! data selection @@ -327,8 +332,14 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,gstime,& endif endif + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Open BUFR file @@ -389,11 +400,6 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,gstime,& else if (abs(tdiff)>twind) cycle read_loop endif - if (thin4d) then - timedif = zero - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - endif ! --- Check observing position ----- if(amsre_low .or. amsre_mid) then @@ -451,8 +457,10 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,gstime,& ! some observations that may be rejected later due to bad BTs. nread=nread+kchanl - crit1 = 0.01_r_kind+timedif - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0 = 0.01_r_kind + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if (.not.iuse) cycle read_loop ! QC: "Score" observation. We use this information to identify "best" obs diff --git a/src/read_anowbufr.f90 b/src/gsi/read_anowbufr.f90 similarity index 100% rename from src/read_anowbufr.f90 rename to src/gsi/read_anowbufr.f90 diff --git a/src/read_atms.f90 b/src/gsi/read_atms.f90 similarity index 94% rename from src/read_atms.f90 rename to src/gsi/read_atms.f90 index 9a146a2ed..0964db248 100644 --- a/src/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -34,6 +34,9 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ! 2016-10-20 collard - fix to allow monitoring and limited assimilation of spectra when key ! channels are missing. ! 2016-10-25 zhu - add changes for assimilating radiances affected by non-precipitating clouds +! 2018-02-05 collard - get orbit height from BUFR file +! 2018-04-19 eliu - allow data selection for precipitation-affected data +! 2018-05-21 j.jin - added time-thinning, to replace thin4d ! ! input argument list: ! mype - mpi task id @@ -72,14 +75,16 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,destroygrids,checkob, & finalcheck,map2tgrid,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only: iuse_rad,newchn,cbias,nusis,jpch_rad,air_rad,ang_rad, & use_edges,radedge1,radedge2,nusis,radstart,radstep,newpc4pred,maxscan use radinfo, only: adp_anglebc use gridmod, only: diagnostic_reg,regional,nlat,nlon,tll2xy,txy2ll,rlats,rlons - use constants, only: deg2rad,zero,one,two,three,rad2deg,r60inv,r100 + use constants, only: deg2rad,zero,one,two,three,rad2deg,r60inv,r100,rearth_equator use crtm_module, only : max_sensor_zenith_angle use calc_fov_crosstrk, only : instrument_init, fov_cleanup, fov_check - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use deter_sfc_mod, only: deter_sfc_fov,deter_sfc use atms_spatial_average_mod, only : atms_spatial_average use gsi_nstcouplermod, only: nst_gsi,nstinfo @@ -110,7 +115,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ! Declare local parameters character(8),parameter:: fov_flag="crosstrk" - integer(i_kind),parameter:: n1bhdr=12 + integer(i_kind),parameter:: n1bhdr=13 integer(i_kind),parameter:: n2bhdr=4 integer(i_kind),parameter:: maxobs = 800000 integer(i_kind),parameter:: max_chanl = 22 @@ -120,8 +125,6 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ! The next two are one minute in hours real(r_kind),parameter:: one_minute=0.01666667_r_kind real(r_kind),parameter:: minus_one_minute=-0.01666667_r_kind - real(r_kind),parameter:: rato=1.1363987_r_kind ! ratio of satellite height to - ! distance from Earth's centre ! Declare local variables logical outside,iuse,assim,valid @@ -154,6 +157,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& real(r_kind),dimension(0:3):: ts real(r_kind) :: tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10 real(r_kind) :: zob,tref,dtw,dtc,tz_tr + real(r_kind) :: satellite_height, rato real(r_kind) pred real(r_kind) dlat,panglr,dlon,tdiff @@ -166,6 +170,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& real(r_kind), POINTER :: bt_in(:), crit1,rsat, t4dv, solzen, solazi real(r_kind), POINTER :: dlon_earth,dlat_earth,satazi, lza + integer(i_kind), ALLOCATABLE, TARGET :: it_mesh_save(:) real(r_kind), ALLOCATABLE, TARGET :: rsat_save(:) real(r_kind), ALLOCATABLE, TARGET :: t4dv_save(:) real(r_kind), ALLOCATABLE, TARGET :: dlon_earth_save(:) @@ -185,6 +190,9 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& real(r_kind) cdist,disterr,disterrmax,dlon00,dlat00 logical :: critical_channels_missing + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin + integer(i_kind),pointer :: it_mesh => null() !************************************************************************** ! Initialize variables @@ -204,8 +212,14 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& call gsi_nstcoupler_skindepth(obstype,zob) endif + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Set nadir position based on value of maxscan if (maxscan < 96) then @@ -336,6 +350,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ALLOCATE(dlon_earth_save(maxobs)) ALLOCATE(dlat_earth_save(maxobs)) ALLOCATE(crit1_save(maxobs)) + ALLOCATE(it_mesh_save(maxobs)) ALLOCATE(lza_save(maxobs)) ALLOCATE(satazi_save(maxobs)) ALLOCATE(solzen_save(maxobs)) @@ -365,7 +380,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& if(ierr /= 0) cycle ears_db_loop call openbf(lnbufr,'IN',lnbufr) - hdr1b ='SAID FOVN YEAR MNTH DAYS HOUR MINU SECO CLAT CLON CLATH CLONH' + hdr1b ='SAID FOVN YEAR MNTH DAYS HOUR MINU SECO CLAT CLON CLATH CLONH HMSL' hdr2b ='SAZA SOZA BEARAZ SOLAZI' ! Loop to read bufr file @@ -378,6 +393,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& dlon_earth => dlon_earth_save(iob) dlat_earth => dlat_earth_save(iob) crit1 => crit1_save(iob) + it_mesh => it_mesh_save(iob) ifov => ifov_save(iob) lza => lza_save(iob) satazi => satazi_save(iob) @@ -385,8 +401,9 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& solazi => solazi_save(iob) ! inflate selection value for ears_db data - crit1 = zero - if ( llll > 1 ) crit1 = r100 * float(llll) + crit0 = 0.01_r_kind + crit0 = zero ! shouldn't it = 0.01_r_kind? + if ( llll > 1 ) crit0 = crit0 + r100 * float(llll) call ufbint(lnbufr,bfr1bhdr,n1bhdr,1,iret,hdr1b) @@ -425,11 +442,9 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& else if(abs(tdiff) > twind+one_minute) cycle read_loop endif - if (thin4d) then - crit1 = crit1 + zero - else - crit1 = crit1 + two*abs(tdiff) ! range: 0 to 6 - endif + + timeinflat=two + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) call ufbint(lnbufr,bfr2bhdr,n2bhdr,1,iret,hdr2b) @@ -443,6 +458,11 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& if(ifov <= 48) lza=-lza panglr=(start+float(ifov-1)*step)*deg2rad + satellite_height=bfr1bhdr(13) +! Ensure orbit height is reasonable + if (satellite_height < 780000.0_r_kind .OR. & + satellite_height > 900000.0_r_kind) satellite_height = 824000.0_r_kind + rato = one + satellite_height/rearth_equator lzaest = asin(rato*sin(panglr)) if(abs(lza)*rad2deg > MAX_SENSOR_ZENITH_ANGLE) then @@ -508,6 +528,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& dlon_earth => dlon_earth_save(iob) dlat_earth => dlat_earth_save(iob) crit1 => crit1_save(iob) + it_mesh => it_mesh_save(iob) ifov => ifov_save(iob) lza => lza_save(iob) satazi => satazi_save(iob) @@ -558,7 +579,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& endif ! Map obs to thinning grid - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle ObsLoop ! @@ -659,6 +680,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& else qval = zero end if + if (radmod%lprecip) qval=zero else d0 = 8.24_r_kind - 2.622_r_kind*cosza + 1.846_r_kind*cosza*cosza qval = cosza*(d0+d1*log(285.0_r_kind-ch1)+d2*log(285.0_r_kind-ch2)) @@ -765,6 +787,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& DEALLOCATE(dlon_earth_save) DEALLOCATE(dlat_earth_save) DEALLOCATE(crit1_save) + DEALLOCATE(it_mesh_save) DEALLOCATE(lza_save) DEALLOCATE(satazi_save) DEALLOCATE(solzen_save) diff --git a/src/read_avhrr.f90 b/src/gsi/read_avhrr.f90 old mode 100644 new mode 100755 similarity index 95% rename from src/read_avhrr.f90 rename to src/gsi/read_avhrr.f90 index d38f6d4f6..ffc5a8205 --- a/src/read_avhrr.f90 +++ b/src/gsi/read_avhrr.f90 @@ -46,6 +46,7 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,& ! add check: bufsat(jsatid) == satellite id ! 2015-02-23 Rancic/Thomas - add thin4d to time window logical ! 2015-10-01 guo - consolidate use of ob location (in deg) +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -75,12 +76,14 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & checkob, finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use gridmod, only: diagnostic_reg,regional,nlat,nlon,tll2xy,txy2ll,rlats,rlons use constants, only: deg2rad, zero, one, two, half, rad2deg, r60inv ! use radinfo, only: cbias,predx,air_rad,ang_rad,newpc4pred use radinfo, only: retrieval,iuse_rad,jpch_rad,nusis, & newchn - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use deter_sfc_mod, only: deter_sfc use obsmod, only: bmiss use gsi_nstcouplermod, only: nst_gsi,nstinfo @@ -135,7 +138,7 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,& integer(i_kind) nlat_sst,nlon_sst integer(i_kind) ksatid - real(r_kind) dlon,dlat,timedif,rsc + real(r_kind) dlon,dlat,rsc real(r_kind) dlon_earth,dlat_earth,sfcr real(r_kind) dlon_earth_deg,dlat_earth_deg real(r_kind) w00,w01,w10,w11,dx1,dy1 @@ -166,6 +169,8 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,& ! real(r_kind), dimension(3,2) :: bandcor_a,bandcor_b ! data bandcor_a/-1.70686_r_kind,-0.27201_r_kind,-0.30949_r_kind,-1.70388_r_kind,-0.43725_r_kind,-0.25342_r_kind/ ! data bandcor_b/1.002629_r_kind,1.001207_r_kind,1.000989_r_kind,1.003049_r_kind,1.001395_r_kind,1.000944_r_kind/ + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh !************************************************************************** @@ -199,10 +204,13 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,& rlndsea(3) = 30._r_kind rlndsea(4) = 30._r_kind - ! 207, 208 or 209 for NOAA-16, 17 & 18 respectively + ! 205,206,207,208 or 209 for NOAA-14,16,16,17 & 18 respectively + if(jsatid == 'n14')bufsat = 205 + if(jsatid == 'n15')bufsat = 206 if(jsatid == 'n16')bufsat = 207 -! if(jsatid == 'n17')bufsat = 208 - if(jsatid == 'n17')bufsat = 4 + if(jsatid == 'n17')bufsat = 208 +! if(jsatid == 'n17')bufsat = 4 + if(jsatid == 'n17')bufsat = 208 if(jsatid == 'n18')bufsat = 209 if(jsatid == 'n19')bufsat = 223 if(jsatid == 'metop-a')bufsat = 4 @@ -224,8 +232,14 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,& if (.not.assim) val_avhrr=zero + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Read hi-res sst analysis @@ -331,14 +345,10 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,& nread = nread + 1 - if (thin4d) then - crit1 = 0.01_r_kind - else - timedif = r6*abs(tdiff) ! range: 0 to 18 - crit1 = 0.01_r_kind+timedif - endif - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) - + crit0 = 0.01_r_kind + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle read_loop ! Interpolate hi-res sst analysis to observation location diff --git a/src/read_avhrr_navy.f90 b/src/gsi/read_avhrr_navy.f90 similarity index 96% rename from src/read_avhrr_navy.f90 rename to src/gsi/read_avhrr_navy.f90 index 7a3608341..64a5b1990 100644 --- a/src/read_avhrr_navy.f90 +++ b/src/gsi/read_avhrr_navy.f90 @@ -50,6 +50,7 @@ subroutine read_avhrr_navy(mype,val_avhrr,ithin,rmesh,jsatid,& ! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) ! 2015-02-23 Rancic/Thomas - add thin4d to time window logical ! 2015-10-01 guo - consolidate use of ob location (in deg) +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -79,10 +80,12 @@ subroutine read_avhrr_navy(mype,val_avhrr,ithin,rmesh,jsatid,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use gridmod, only: diagnostic_reg,regional,nlat,nlon,tll2xy,txy2ll,rlats,rlons use constants, only: deg2rad, zero, one, rad2deg, r60inv use radinfo, only: retrieval,iuse_rad,jpch_rad,nusis - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use deter_sfc_mod, only: deter_sfc use obsmod, only: bmiss use gsi_nstcouplermod, only: nst_gsi,nstinfo @@ -135,7 +138,7 @@ subroutine read_avhrr_navy(mype,val_avhrr,ithin,rmesh,jsatid,& integer(i_kind) nlat_sst,nlon_sst,irec,next integer(i_kind),allocatable,dimension(:)::nrec - real(r_kind) dlon,dlat,timedif,sfcr + real(r_kind) dlon,dlat,sfcr real(r_kind) dlon_earth,dlat_earth real(r_kind) dlon_earth_deg,dlat_earth_deg real(r_kind) w00,w01,w10,w11,dx1,dy1 @@ -159,6 +162,8 @@ subroutine read_avhrr_navy(mype,val_avhrr,ithin,rmesh,jsatid,& real(r_kind) cdist,disterr,disterrmax,dlon00,dlat00 integer(i_kind) ntest + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh !************************************************************************** ! Start routine here. Set constants. Initialize variables @@ -209,8 +214,14 @@ subroutine read_avhrr_navy(mype,val_avhrr,ithin,rmesh,jsatid,& if (.not.assim) val_avhrr=zero + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Read hi-res sst analysis @@ -321,17 +332,11 @@ subroutine read_avhrr_navy(mype,val_avhrr,ithin,rmesh,jsatid,& endif ! Set common predictor parameters - - if (thin4d) then - crit1 = 0.01_r_kind - else - timedif = r6*abs(tdiff) ! range: 0 to 18 -! Compute "score" for observation. All scores>=0.0. Lowest score is "best" - crit1 = 0.01_r_kind+timedif - endif - ! Map obs to thinning grid - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0 = 0.01_r_kind + timeinflat=r6 + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle read_loop diff --git a/src/read_bufrtovs.f90 b/src/gsi/read_bufrtovs.f90 similarity index 97% rename from src/read_bufrtovs.f90 rename to src/gsi/read_bufrtovs.f90 index 55fdf6102..9e9795b00 100644 --- a/src/read_bufrtovs.f90 +++ b/src/gsi/read_bufrtovs.f90 @@ -89,6 +89,8 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! 2016-04-28 jung - added logic for RARS and direct broadcast from NESDIS/UW ! 2016-10-20 collard - fix to allow monitoring and limited assimilation of spectra when key ! channels are missing. +! 2018-04-19 eliu - allow data selection for precipitation-affected data +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -128,6 +130,8 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,destroygrids,checkob, & finalcheck,map2tgrid,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only: iuse_rad,newchn,cbias,predx,nusis,jpch_rad,air_rad,ang_rad, & use_edges,radedge1, radedge2, radstart,radstep,newpc4pred use radinfo, only: crtm_coeffs_path,adp_anglebc @@ -138,7 +142,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& MAX_SENSOR_ZENITH_ANGLE use crtm_spccoeff, only: sc,crtm_spccoeff_load,crtm_spccoeff_destroy use calc_fov_crosstrk, only : instrument_init, fov_cleanup, fov_check - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use antcorr_application, only: remove_antcorr use mpeu_util, only: getindex use deter_sfc_mod, only: deter_sfc_fov,deter_sfc @@ -214,7 +218,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& real(r_kind) dlon_earth_deg,dlat_earth_deg,sat_aziang real(r_kind) dlon_earth,dlat_earth,r01 real(r_kind) crit1,step,start,ch8flg,dist1 - real(r_kind) terrain,timedif,lza,df2,tt,lzaest + real(r_kind) terrain,lza,df2,tt,lzaest real(r_kind),dimension(0:4):: rlndsea real(r_kind),allocatable,dimension(:,:):: data_all @@ -225,6 +229,8 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& real(r_kind) disterr,disterrmax,cdist,dlon00,dlat00 + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh logical :: critical_channels_missing,quiet logical :: print_verbose @@ -248,8 +254,14 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& call gsi_nstcoupler_skindepth(obstype, zob) ! get penetration depth (zob) for the obstype endif + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Set various variables depending on type of data to be read @@ -613,17 +625,13 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& nread=nread+nchanl - if (thin4d) then - timedif = zero - else - timedif = two*abs(tdiff) ! range: 0 to 6 - endif - terrain = 50._r_kind if(llll == 1)terrain = 0.01_r_kind*abs(bfr1bhdr(13)) - crit1 = 0.01_r_kind + terrain + timedif - if (llll > 1 ) crit1 = crit1 + r100 * float(llll) - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0 = 0.01_r_kind + terrain + if (llll > 1 ) crit0 = crit0 + r100 * float(llll) + timeinflat=two + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle read_loop call ufbint(lnbufr,bfr2bhdr,n2bhdr,1,iret,hdr2b) @@ -800,6 +808,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& else qval=zero end if + if (radmod%lprecip) qval=zero ! favor thinner clouds ! cosza = cos(lza) ! d0= 8.24_r_kind - 2.622_r_kind*cosza + 1.846_r_kind*cosza*cosza diff --git a/src/gsi/read_co.f90 b/src/gsi/read_co.f90 new file mode 100644 index 000000000..b79d8b8f3 --- /dev/null +++ b/src/gsi/read_co.f90 @@ -0,0 +1,224 @@ +subroutine read_co(nread,ndata,nodata,infile,gstime,lunout, & + obstype,sis,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_co read co data +! prgmmr: yang org: np23 date: 1998-05-15 +! +! abstract: This routine reads CO observations. The initial code is taken +! from read_ozone. + +! program history log: + +! 2010-03-30 Tangborn, initial code. +! 2011-08-01 Lueken - replaced F90 with f90 (no machine logic), fixed indentation +! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) +! +! input argument list: +! obstype - observation type to process +! infile - unit from which to read co data +! gstime - analysis time in minutes from reference date +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! sis - satellite/instrument/sensor indicator +! +! output argument list: +! nread - number of co observations read +! ndata - number of co profiles retained for further processing +! nodata - number of co observations retained for further processing +! nobs - array of observations on each subdomain for each processor + + use kinds, only: r_kind,r_double,i_kind + use satthin, only: makegrids,map2tgrid,finalcheck + use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons + use constants, only: deg2rad,zero,one_tenth,r60inv,two + use obsmod, only: nlco + use gsi_4dvar, only: iwinbgn + use mpimod, only: npe + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype,infile + character(len=20),intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: nread + integer(i_kind),dimension(npe) ,intent(inout) :: nobs + integer(i_kind) ,intent(inout) :: ndata,nodata + real(r_kind) ,intent(in ) :: gstime + +! Declare local parameters + real(r_kind),parameter:: r360 = 360.0_r_kind + + real(r_kind),parameter:: badco = 10000.0_r_kind + +! Declare local variables + logical outside + logical lerror,leof,lmax + + + integer(i_kind) maxobs,ncodat + integer(i_kind) lunin + integer(i_kind) nmind,i,j + integer(i_kind) imin + integer(i_kind) k,ilat,ilon,nreal,nchanl +! integer(i_kind) ithin,kidsat + integer(i_kind) idate5(5) + integer(i_kind) inum,iyear,imonth,iday,ihour,iferror + + + integer(i_kind) ipoq7 + + real(r_kind) tdiff,sstime,dlon,dlat,t4dv,poq + real(r_kind) slons0,slats0,rsat,solzen,dlat_earth,dlon_earth + real(r_kind) dlat_earth_deg,dlon_earth_deg + real(r_kind) rlat,rlon,rpress,rsza + real(r_kind),allocatable,dimension(:):: pco + real(r_kind),allocatable,dimension(:):: apco + real(r_kind),allocatable,dimension(:,:):: aker + + +! maximum number of observations set to + real(r_kind),allocatable,dimension(:,:):: coout + + real(r_double),dimension(10):: hdrco + +! Set constants. Initialize variables + rsat=999._r_kind + maxobs=1e6 + ilon=3 + ilat=4 + ipoq7=0 + nreal=nlco*nlco+8+nlco + + if (obstype == 'mopitt' )then + +! Set dependent variables and allocate arrays +! nchanl=nlco+1 + nchanl=nlco + ncodat=nreal + allocate (coout(ncodat+nchanl,maxobs)) + allocate ( pco(nlco)) + allocate( apco(nlco)) + allocate( aker(nlco,nlco)) + + +! Read in observations from ascii file + +! Opening file for reading + open(lunin,file=trim(infile),form='formatted',iostat=iferror) + lerror = (iferror/=0) + + obsloop: do + +! Read the first line of the data file + if (.not.lerror) then + read(lunin,fmt=*,iostat=iferror) & + inum,iyear,imonth,iday,ihour,imin,rlat,rlon,rpress,rsza + if(iferror/=0) exit obsloop + do i=1,nlco + read(lunin,fmt=*,iostat=iferror) (aker(i,j),j=1,nlco) + enddo + read(lunin,fmt=*,iostat=iferror) (apco(j),j=1,nlco) + read(lunin,fmt=*,iostat=iferror) (pco(j),j=1,nlco) + +! lerror=(iferror>0) + leof =(iferror<0) + lmax =.false. + end if + + + hdrco(2)=rlat + hdrco(3)=rlon + hdrco(4)=iyear + hdrco(5)=imonth + hdrco(6)=iday + hdrco(8)=ihour + hdrco(9)=imin + +! Convert observation location to radians + slats0= hdrco(2) + slons0= hdrco(3) + if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle obsloop + if(slons0< zero) slons0=slons0+r360 + if(slons0>=r360) slons0=slons0-r360 + dlat_earth_deg = slats0 + dlon_earth_deg = slons0 + dlat_earth = slats0 * deg2rad + dlon_earth = slons0 * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if(outside) cycle obsloop + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + +! Convert observation time to relative time + idate5(1) = hdrco(4) !year + idate5(2) = hdrco(5) !month + idate5(3) = hdrco(6) !day + idate5(4) = hdrco(7) !hour + idate5(5) = hdrco(8) !minute + call w3fs21(idate5,nmind) + t4dv=real((nmind-iwinbgn),r_kind)*r60inv + sstime=real(nmind,r_kind) + tdiff=(sstime-gstime)*r60inv + +! Check co layer values. If any layer value is bad, toss entire profile +! do k=1,nlco +! if (pco(k)>badco) cycle obsloop +! end do + +! Write co record to output file + ndata=min(ndata+1,maxobs) + nodata=nodata+nlco + + coout(1,ndata)=rsat + coout(2,ndata)=t4dv + coout(3,ndata)=dlon ! grid relative longitude + coout(4,ndata)=dlat ! grid relative latitude + coout(5,ndata)=dlon_earth_deg ! earth relative longitude (degrees) + coout(6,ndata)=dlat_earth_deg ! earth relative latitude (degrees) + coout(7,ndata)=poq ! profile co error flag + coout(8,ndata)=solzen ! solar zenith angle + do k=1,nlco + coout(k+8,ndata)=apco(k) + enddo + do i=1,nlco + do j=1,nlco + coout(j+(i-1)*nlco+8+nlco,ndata)=aker(i,j) + enddo + enddo + do k=1,nlco + coout(k+8+nlco*nlco+nlco,ndata)=pco(k) + end do + +! Loop back to read next profile + end do obsloop + + endif + +! Write header record and data to output file for further processing + call count_obs(ndata,ncodat+nchanl,ilat,ilon,coout,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) ((coout(k,i),k=1,ncodat+nchanl),i=1,ndata) + nread=ndata ! nmrecs + + +! Deallocate local arrays +160 continue + if (obstype == 'mopitt') then + deallocate(aker) + deallocate(apco) + deallocate(pco) + deallocate(coout) + endif + close(lunin) + + return + +end subroutine read_co + diff --git a/src/read_cris.f90 b/src/gsi/read_cris.f90 similarity index 96% rename from src/read_cris.f90 rename to src/gsi/read_cris.f90 index f742e3042..91bac38c6 100644 --- a/src/read_cris.f90 +++ b/src/gsi/read_cris.f90 @@ -34,6 +34,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! 2017-05-09 jung - mods to include all fovs, sensor twist in scan angle, ! thinning routine including cloud info, and test 431 ! subset. +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -74,6 +75,8 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & finalcheck,checkob,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only:iuse_rad,nuchan,nusis,jpch_rad,crtm_coeffs_path,use_edges, & radedge1,radedge2,radstart,radstep use crtm_module, only: success, & @@ -83,7 +86,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& use gridmod, only: diagnostic_reg,regional,nlat,nlon,& tll2xy,txy2ll,rlats,rlons use constants, only: zero,deg2rad,rad2deg,r60inv,one,ten,r100,r1000 - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use calc_fov_crosstrk, only: instrument_init, fov_check, fov_cleanup use deter_sfc_mod, only: deter_sfc_fov,deter_sfc use gsi_nstcouplermod, only: nst_gsi,nstinfo @@ -160,7 +163,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind) :: dlon, dlat real(r_kind) :: dlon_earth,dlat_earth,dlon_earth_deg,dlat_earth_deg real(r_kind) :: rsat - real(r_kind) :: timedif, pred, crit1, dist1 + real(r_kind) :: pred, crit1, dist1 real(r_kind) :: sat_zenang, sat_look_angle, look_angle_est real(crtm_kind) :: radiance real(r_kind) :: tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr @@ -214,6 +217,8 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind),parameter:: tbmin = 50._r_kind real(r_kind),parameter:: tbmax = 550._r_kind real(r_kind),parameter:: rato = 0.87997285_r_kind + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh logical print_verbose print_verbose = .false. @@ -362,8 +367,14 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& rlndsea(4) = 30._r_kind endif + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Allocate arrays to hold data ! The number of channels is obtained from the satinfo file being used. @@ -571,15 +582,11 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! Increment nread counter by bufr_nchan (should be changed to number of channels in satinfo file? (satinfo_nchan)) nread = nread + satinfo_nchan - - if (thin4d) then - crit1 = 0.01_r_kind - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - crit1 = 0.01_r_kind+timedif - endif - if( llll > 1 ) crit1 = crit1 + r100 * float(llll) - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0 = 0.01_r_kind + if( llll > 1 ) crit0 = crit0 + r100 * float(llll) + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle read_loop ! Observational info @@ -643,7 +650,12 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! CrIS data read radiance values and channel numbers ! Read CRIS channel number(CHNM) and radiance (SRAD) - call ufbint(lnbufr,allchan,2,bufr_nchan,iret,'SRAD CHNM') + if( char_mtyp == 'FSR') then + call ufbseq( lnbufr,allchan,2,bufr_nchan,iret,'CRCHNM') + else + call ufbseq( lnbufr,allchan,2,bufr_nchan,iret,'CRCHN') + endif + if( iret /= bufr_nchan)then write(6,*)'READ_CRIS: ### ERROR IN READING ', senname, ' BUFR DATA:', & iret, ' CH DATA IS READ INSTEAD OF ',bufr_nchan @@ -652,13 +664,13 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! Coordinate bufr channels with satinfo file channels ! If this is the first time or a change in the bufr channels is detected, sync with satinfo file - if (ANY(int(allchan(2,:)) /= bufr_chan_test(:))) then + if (ANY(int(allchan(1,:)) /= bufr_chan_test(:))) then sfc_channel_index = 0 ! surface channel used for qc and thinning test bufr_index(:) = 0 bufr_chans: do l=1,bufr_nchan - bufr_chan_test(l) = int(allchan(2,l)) ! Copy this bufr channel selection into array for comparison to next profile + bufr_chan_test(l) = int(allchan(1,l)) ! Copy this bufr channel selection into array for comparison to next profile satinfo_chans: do i=1,satinfo_nchan ! Loop through sensor (cris) channels in the satinfo file - if ( channel_number(i) == int(allchan(2,l)) ) then ! Channel found in both bufr and satinfo file + if ( channel_number(i) == int(allchan(1,l)) ) then ! Channel found in both bufr and satinfo file bufr_index(i) = l if ( channel_number(i) == sfc_channel ) sfc_channel_index = l exit satinfo_chans ! go to next bufr channel @@ -693,7 +705,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! If cloud_properties is missing from BUFR, use proxy of warmest fov. ! the surface channel is fixed and set earlier in the code (501). - radiance = allchan(1,sfc_channel_index) * r1000 ! Conversion from W to mW + radiance = allchan(2,sfc_channel_index) * r1000 ! Conversion from W to mW call crtm_planck_temperature(sensorindex,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation if (temperature(sfc_channel_index) > tbmin .and. temperature(sfc_channel_index) < tbmax ) then if ( tsavg*0.98_r_kind <= temperature(sfc_channel_index)) then ! 0.98 is a crude estimate of the surface emissivity @@ -726,8 +738,8 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! Check that channel radiance is within reason and channel number is consistent with CRTM initialisation ! Negative radiance values are entirely possible for shortwave channels due to the high noise, but for ! now such spectra are rejected. - if (( allchan(1,bufr_chan) > zero .and. allchan(1,bufr_chan) < 99999._r_kind)) then ! radiance bounds - radiance = allchan(1,bufr_chan) * r1000 ! Conversion from W to mW + if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds + radiance = allchan(2,bufr_chan) * r1000 ! Conversion from W to mW call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) ! radiance to BT calculation else ! error with channel number or radiance temperature(bufr_chan) = tbmin diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 new file mode 100644 index 000000000..89eebde8b --- /dev/null +++ b/src/gsi/read_dbz_nc.f90 @@ -0,0 +1,542 @@ +subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_dbz read MRMS gridded QC'd radar reflectivity files in DART-like netcdf format +! +! abstract: Read and process MRMS gridded QC'd radar reflectivity (dBZ) +! observations in DART-like netcdf format. +! +! program history log: +! 2016-02-14 Y. Wang, Johnson, X. Wang - modify read_radar.f90 to read MRMS dbz in netcdf format +! in collaboration with Carley, POC: xuguang.wang@ou.edu +! 2019-02-27 D. Dowell : changed data_r_1d from real(r_kind) to real; added new array data_r_2d +! changed lon and lat to 2D arrays +! changed value for dbznoise +! +! program history log: +! +! input argument list: +! infile - file from which to read data +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! +! output argument list: +! nread - number of radar reflectivity observations read +! ndata - number of radar reflectivity observations retained for further processing +! nodata - number of radar reflectivity observations retained for further processing +! sis - satellite/instrument/sensor indicator +! +! Variable Definitions: +! +! cdata_all - real - dim(maxdat,maxobs) - array holding all data for assimilation +! cstaid - char - radar station ide +! dlat - real - grid relative latitude of observation (grid units) +! dlon - real - grid relative longitude of observation (grid units) +! maxobs - int - max number of obs converted to no precip observations +! num_m2nopcp -int - number of missing obs +! num_missing - int - number of missing observations +! num_noise - int - number of rejected noise observations +! num_nopcp - int - number of noise obs converted to no precip observations +! numbadtime - int - number of elevations outside time window +! outside - logical - if observations are outside the domain -> true +! radartwindow - real - time window for radar observations (minutes) +! rmins_an - real - analysis time from reference date (minutes) +! rmins_ob - real - observation time from reference date (minutes) +! rstation_id - real - radar station id +! thisazimuthr - real - 90deg minues the actual azimuth and converted to radians +! thiserr - real - observation error +! thislat - real - latitude of observation, point +! thislon - real - longitude of observation, point +! thisrange - real - range of observation from radar +! thishgt - real - observation height, point +! this_stahgt - real - radar station height (meters about sea level) +! this_staid - char - radar station id +! thistiltr - real- radar tilt angle (radians) +! timeb - real - obs time (analyis relative minutes) +! dbzQC - real - reflectivity observation +! dbz_err - real - observation error of reflectivity +! height - real - height of observation +! lon - real - longitude of observation +! lat - real - latitude of observation +! utime - real - time for each observation point +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: r_kind,r_double,i_kind,r_single + use constants, only: zero,half,one,two,deg2rad,rad2deg, & + one_tenth,r1000,r60,r60inv,r100,r400,grav_equator, & + eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening + use gridmod, only: tll2xy,nsig,nlat,nlon + use obsmod, only: iadate,doradaroneob, & + mintiltdbz,maxtiltdbz,minobrangedbz,maxobrangedbz,& + static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz + use hybrid_ensemble_parameters,only : l_hyb_ens + use obsmod,only: radar_no_thinning,missing_to_nopcp + use convinfo, only: nconvtype,ctwind,icuse,ioctype + use convthin, only: make3grids,map3grids,del3grids,use_all + use jfunc, only: miter + use mpimod, only: npe + implicit none + + include 'netcdf.inc' + +! Declare passed variables + character(len=*),intent(in ) :: obstype,infile + character(len=*),intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: nread,ndata,nodata + real(r_kind),dimension(nlat,nlon,nsig),intent(in):: hgtl_full + integer(i_kind),dimension(npe) ,intent(inout) :: nobs + +! Declare local parameters + real(r_kind),parameter:: r6 = 6.0_r_kind + real(r_kind),parameter:: r360=360.0_r_kind + integer(i_kind),parameter:: maxdat=18 + character(len=4), parameter :: radid = 'XXXX' + +! === Grid dbz data declaration + + real(r_single), allocatable, dimension(:) :: data_r_1d + real(r_single), allocatable, dimension(:,:) :: data_r_2d + real(r_kind), allocatable, dimension(:) :: height + real(r_kind), allocatable, dimension(:,:) :: lon, lat + real(r_single), allocatable, dimension(:,:,:) :: data_r_3d + real(r_kind), allocatable, dimension(:,:,:) :: dbzQC + + integer(i_kind), parameter :: max_num_vars = 50, max_num_dims = 20 + + integer(i_kind) :: length, rcode, cdfid + character( len = 20 ),dimension(max_num_vars) :: var_list + integer(i_kind), dimension(max_num_vars) :: id_var, ndims + integer(i_kind), dimension(max_num_dims) :: dimids, one_read + integer(i_kind) :: natts, ivtype + integer(i_kind) , dimension(max_num_vars, max_num_dims) :: dims + + logical :: if_input_exist + integer(i_kind) :: ivar, var_num, sec70 + + +!--Counters for diagnostics + integer(i_kind) :: num_missing=0,num_nopcp=0, & !counts + numbadtime=0, & + num_m2nopcp=0, & + num_noise=0,num_limmax=0 + integer(i_kind) num_dbz2mindbz,imissing2nopcp + + + integer(i_kind) :: ithin,zflag,nlevz,icntpnt,klon1,klat1,kk,klatp1,klonp1 + real(r_kind) :: rmesh,xmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11 + real(r_kind), allocatable, dimension(:) :: zl_thin + real(r_kind),dimension(nsig):: hges,zges + real(r_kind) sin2,termg,termr,termrg,zobs,hgt + integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2 + real(r_kind) crit1,timedif + real(r_kind),parameter:: r16000 = 16000.0_r_kind + + logical :: luse + integer(i_kind) maxout,maxdata + integer(i_kind),allocatable,dimension(:):: isort + + !--General declarations + integer(i_kind) :: ierror,i,j,k,nvol, & + ikx,mins_an + integer(i_kind) :: maxobs,nchanl,ilat,ilon,scount + + real(r_kind) :: thistiltr,thisrange,this_stahgt,thishgt + real(r_kind) :: thisazimuthr,t4dv, & + dlat,dlon,thiserr,thislon,thislat, & + timeb + real(r_kind) :: radartwindow + real(r_kind) :: rmins_an + real(r_kind),allocatable,dimension(:,:):: cdata_all + real(r_double) rstation_id + + character(8) cstaid + character(4) this_staid + equivalence (this_staid,cstaid) + equivalence (cstaid,rstation_id) + + logical :: outside + + real(r_kind) :: minobrange,maxobrange,mintilt,maxtilt + + real(r_kind) :: dbznoise=-10.0_r_kind ! dBZ obs must be >= dbznoise for assimilation + logical :: l_limmax=.true. ! If true, observations > 60 dBZ are limited to be 60 dBZ. This is + ! due to representativeness error associated with the model + + minobrange=minobrangedbz + maxobrange=maxobrangedbz + mintilt=mintiltdbz + maxtilt=maxtiltdbz + + num_dbz2mindbz=0 + + write(6,*)'missing_to_nopcp is ',missing_to_nopcp + write(6,*)'radar_no_thinning is ',radar_no_thinning +!--------------------------------------------------------------------------------------! +! END OF ALL DECLARATIONS ! +!--------------------------------------------------------------------------------------! + + write(6,*)'think in read_dbz static_gsi_nopcp_dbz is ', static_gsi_nopcp_dbz + !-Check if reflectivity is in the convinfo file and extract necessary attributes + + ithin=1 !number of obs to keep per grid box + if(radar_no_thinning) then + ithin=-1 + endif + + scount=0 + ikx=0 + do i=1,nconvtype + if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then + ikx=i + radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes + ! (default setting for dbz within convinfo is 0.05 hours) + exit !Exit loop when finished with initial convinfo fields + else if ( i==nconvtype ) then + write(6,*) 'READ_dBZ: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO' + write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!' + return + endif + end do + + if (minobrange >= maxobrange) then + write(6,*) 'MININMUM OB RANGE >= MAXIMUM OB RANGE FOR READING dBZ - PROGRAM STOPPING FROM READ_DBZ.F90' + call stop2(400) + end if + + !-next three values are dummy values for now + nchanl=0 + ilon=2 + ilat=3 + + maxobs=50000000 !value taken from read_radar.f90 + + !--Allocate cdata_all array + allocate(cdata_all(maxdat,maxobs),isort(maxobs)) + rmesh=rmesh_dbz + zmesh=zmesh_dbz + + + maxout=0 + maxdata=0 + isort=0 + ntdrvr_thin2=0 + icntpnt=0 + zflag=0 + + use_all=.true. + if (ithin > 0) then + write(6,*)'READ_RADAR_DBZ: ithin,rmesh :',ithin,rmesh + use_all=.false. + if(zflag == 0)then + nlevz=nsig + else + nlevz=r16000/zmesh + endif + xmesh=rmesh + call make3grids(xmesh,nlevz) +! call make3grids2(xmesh,nlevz) + + allocate(zl_thin(nlevz)) + if (zflag == 1) then + do k=1,nlevz + zl_thin(k)=k*zmesh + enddo + endif + write(6,*)'READ_RADAR_DBZ: xmesh, zflag, nlevz =', xmesh, zflag, nlevz + endif +!!end modified for thinning + + var_list(1:4) = (/ "reflectivity", "height ", "longitude ", "latitude "/) + var_num = 4 + + print *, "read_Dbz.f90: open ",trim(infile) + length = len_trim(infile) + + inquire(file=infile(1:length), exist=if_input_exist) + + +fileopen: if (if_input_exist) then + + rcode = nf_open( infile(1:length), NF_NOWRITE, cdfid ) + + DO ivar = 1, var_num + + + ! Check variable is in file, and get variable id: + rcode = nf_inq_varid ( cdfid, trim(var_list(ivar)), id_var(ivar) ) + if ( rcode /= 0 ) then + write(6,FMT='(A,A)') & + trim(var_list(ivar)), ' variable is not in input file' + end if + + ! Get number of dimensions, and check of real type: + dimids = 0 + rcode = nf_inq_var( cdfid, id_var(ivar), trim(var_list(ivar)), ivtype, ndims(ivar), dimids, natts ) + if ( ivtype /= 5 ) then + write(6,FMT='(A,A)') trim(var_list(ivar)), ' variable is not real type' + end if + + ! Get dimensions of field: + dims(ivar,:) = 0 + do i = 1, ndims(ivar) + rcode = nf_inq_dimlen( cdfid, dimids(i), dims(ivar,i) ) + end do + + END DO ! ivar + + allocate( dbzQC(dims(1,1),dims(1,2),dims(1,3)), height(dims(2,1)), & + lon(dims(3,1),dims(3,2)), lat(dims(4,1),dims(4,2)) ) + + one_read = 1 + + do ivar = 1, var_num + if( ivar == 1 )then + allocate( data_r_3d(dims(ivar,1),dims(ivar,2),dims(ivar,3)) ) + + call ncvgt( cdfid, id_var(ivar), one_read, dims(ivar,:), data_r_3d, rcode ) + + dbzQC = data_r_3d + + else if( ivar == 2 )then + allocate( data_r_1d(dims(ivar,1)) ) + + call ncvgt( cdfid, id_var(ivar), one_read, dims(ivar,:), data_r_1d, rcode ) + + height = data_r_1d + + deallocate( data_r_1d ) + + else + allocate( data_r_2d(dims(ivar,1),dims(ivar,2)) ) + + call ncvgt( cdfid, id_var(ivar), one_read, dims(ivar,:), data_r_2d, rcode ) + + if( ivar == 3 )then + lon = data_r_2d + else if( ivar == 4 )then + lat = data_r_2d + end if + + deallocate( data_r_2d ) + + end if + + end do + + + !-Obtain analysis time in minutes since reference date + + sec70 = 252460800 ! seconds since from 01/01/1970 + + + call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978 + rmins_an=mins_an !convert to real number + + ivar = 1 + + ILOOP : & + do i = 1, dims(ivar,1) + do j = 1, dims(ivar,2) + do k = 1, dims(ivar,3) + + imissing2nopcp = 0 +! Missing data in the input file have the value -999.0 + if( dbzQC(i,j,k) <= -900.0_r_kind ) then + !--Extend no precip observations to missing data fields? + ! May help suppress spurious convection if a problem. + if (missing_to_nopcp .and. dbzQC(i,j,k) > -1000.0_r_kind ) then + imissing2nopcp = 1 + dbzQC(i,j,k) = static_gsi_nopcp_dbz + num_m2nopcp = num_m2nopcp + 1 + else + num_missing = num_missing + 1 + cycle + end if + end if + + if(miter /= 0 .and. (.not. l_hyb_ens) ) then ! For gsi 3DVar run + if (l_limmax) then + if ( dbzQC(i,j,k) > 60_r_kind ) then + dbzQC(i,j,k) = 60_r_kind + num_limmax = num_limmax + 1 + end if + end if + end if + + if ( dbzQC(i,j,k) < static_gsi_nopcp_dbz ) then + dbzQC(i,j,k) = static_gsi_nopcp_dbz + num_dbz2mindbz = num_dbz2mindbz + 1 + end if + + thishgt = height(k) ! unit : meter + hgt = thishgt + + + thislon = lon(i,j) + thislat = lat(i,j) + + !-Check format of longitude and correct if necessary + + if(thislon>=r360) thislon=thislon-r360 + if(thislon 0)then + + if(zflag == 0)then + klon1= int(dlon); klat1= int(dlat) + dx = dlon-klon1; dy = dlat-klat1 + dx1 = one-dx; dy1 = one-dy + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) + if (klon1==0) klon1=nlon + klatp1=min(nlat,klat1+1); klonp1=klon1+1 + if (klonp1==nlon+1) klonp1=1 + do kk=1,nsig + hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + & + w10*hgtl_full(klatp1,klon1 ,kk) + & + w01*hgtl_full(klat1 ,klonp1,kk) + & + w11*hgtl_full(klatp1,klonp1,kk) + end do + sin2 = sin(thislat)*sin(thislat) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do kk=1,nsig + zges(kk) = (termr*hges(kk)) / (termrg-hges(kk)) + zl_thin(kk)=zges(kk) + end do + endif + + zobs = hgt + + + ntmp=ndata ! counting moved to map3gridS + timedif=abs(t4dv) !don't know about this + crit1 = timedif/r6+half + + call map3grids(1,zflag,zl_thin,nlevz,thislat,thislon,& + zobs,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) + + + maxout=max(maxout,iout) + maxdata=max(maxdata,ndata) + + if (.not. luse) then + ntdrvr_thin2=ntdrvr_thin2+1 + cycle + endif + if(iiout > 0) isort(iiout)=0 + if (ndata > ntmp) then + nodata=nodata+1 + endif + isort(icntpnt)=iout + else + ndata =ndata+1 + nodata=nodata+1 + iout=ndata + isort(icntpnt)=iout + endif + + !!end modified for thinning + + thisazimuthr=0.0_r_kind + this_staid=radid !Via equivalence in declaration, value is propagated + ! to rstation_id used below. + cdata_all(1,iout) = thiserr ! reflectivity obs error (dB) - inflated/adjusted + cdata_all(2,iout) = dlon ! grid relative longitude + cdata_all(3,iout) = dlat ! grid relative latitude + cdata_all(4,iout) = thishgt ! obs absolute height (m) + cdata_all(5,iout) = dbzQC(i,j,k) ! radar reflectivity factor + cdata_all(6,iout) = thisazimuthr ! 90deg-azimuth angle (radians) + + cdata_all(7,iout) = timeb*r60inv ! obs time (analyis relative hour) + cdata_all(8,iout) = ikx ! type + cdata_all(9,iout) = thistiltr ! tilt angle (radians) + cdata_all(10,iout)= this_stahgt ! station elevation (m) + + cdata_all(11,iout)= rstation_id ! station id + cdata_all(12,iout)= icuse(ikx) ! usage parameter + cdata_all(13,iout)= thislon*rad2deg ! earth relative longitude (degrees) + cdata_all(14,iout)= thislat*rad2deg ! earth relative latitude (degrees) + + cdata_all(15,iout)= thisrange ! range from radar in m + + cdata_all(16,iout)= thiserr ! orginal error from convinfo file + cdata_all(17,iout)= dbznoise ! noise threshold for reflectivity (dBZ) + cdata_all(18,iout)= imissing2nopcp !=0, normal + !=1, !values !converted !from !missing !values + + if(doradaroneob .and. (cdata_all(5,iout) > -99.0_r_kind) ) exit ILOOP + + end do ! k + end do ! j + end do ILOOP ! i + + if (.not. use_all) then + deallocate(zl_thin) + call del3grids + endif + !---all looping done now print diagnostic output + + write(6,*)'READ_dBZ: Reached eof on radar reflectivity file' + write(6,*)'READ_dBZ: # volumes in input file =',nvol + write(6,*)'READ_dBZ: # read in obs. number =',nread + write(6,*)'READ_dBZ: # elevations outside time window =',numbadtime + write(6,*)'READ_dBZ: # of noise obs to no precip obs =',num_nopcp + write(6,*)'READ_dBZ: # of missing data to no precip obs =',num_m2nopcp + write(6,*)'READ_dBZ: # of rejected noise obs =',num_noise + write(6,*)'READ_dBZ: # of missing data =',num_missing + write(6,*)'READ_dBZ: # changed to min dbz =',num_dbz2mindbz + write(6,*)'READ_dBZ: # restricted to 60dBZ limit =',num_limmax + + !---Write observation to scratch file---! + + call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) + write(lunout) obstype,sis,maxdat,nchanl,ilat,ilon + write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) + + + !---------------DEALLOCATE ARRAYS-------------! + + deallocate(cdata_all) +else !fileopen + write(6,*) 'READ_dBZ: ERROR OPENING RADAR REFLECTIVITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...' +end if fileopen + + +end subroutine read_dbz_nc diff --git a/src/gsi/read_dbz_netcdf.f90 b/src/gsi/read_dbz_netcdf.f90 new file mode 100644 index 000000000..994680451 --- /dev/null +++ b/src/gsi/read_dbz_netcdf.f90 @@ -0,0 +1,1329 @@ +subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_dbz read level2 raw QC'd radar reflectivity files +! +! prgmmr: carley org: np22 date: 2011-04-04 +! +! abstract: Reads and processes level 2 horizontal radar reflectivity (dBZ) by +! radar site. Data are on radar scan surafces. Also reads, but does +! not process unfolded radial velocities. Processing includes +! finding the lat/lon and height of each observation. +! This formulation is not outfitted for 4dvar, but will +! work with 3dvar and hybrid ensemble. +! +! program history log: +! 2011-08-12 carley - Fix dBZ oberror to be 3dBZ and add optional +! upper bound limit to observed dBZ to account +! for representativeness error. +! 2011-12-08 carley - Fix dBZ oberror to 5 dBZ +! +! 2015 Lei -- modify from read_dbz to read_dbz_mrms_netcdf +! input argument list: +! infile - file from which to read data +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! +! output argument list: +! nread - number of radar reflectivity observations read +! ndata - number of radar reflectivity observations retained for further processing +! nodata - number of radar reflectivity observations retained for further processing +! sis - satellite/instrument/sensor indicator +! +! Variable Definitions: +! +! a43 - real - (4/3)*(earth radius) +! a,b,c,ha,epsh,h,aactual - real - used in computing radar observation height +! cdata_all - real - dim(maxdat,maxobs) - array holding all data for assimilation +! celev0,selev0 - real- cos and sin of elevation angle (raw) +! celev,selev - real - corrected cos and sin of elevation angle +! clat0 - real - cos of radar station latitude +! cstaid - char - radar station ide +! dbzerr - real - observation error (obtained from convinfo - dBZ) +! dlat - real - grid relative latitude of observation (grid units) +! dlon - real - grid relative longitude of observation (grid units) +! gamma - real - used in finding observation latlon +! lunrad - int - unit number for reading radar data from file +! maxobs - int - max number of obs converted to no precip observations +! num_m2nopcp -int - number of missing obs +! num_missing - int - number of missing observations +! num_noise - int - number of rejected noise observations +! num_nopcp - int - number of noise obs converted to no precip observations +! numbadtime - int - number of elevations outside time window +! num_badtilt - int - number of elevations outside specified interval +! num_badrange - int - number of obs outside specified range distance +! obdate - int - dim(5) - yyyy,mm,dd,hh,minmin of observation +! outside - logical - if observations are outside the domain -> true +! radartwindow - real - time window for radar observations (minutes) +! rlatglob - real - earth relative latitude of observation (radians) +! rlatloc - real - latitude of observation on radar-relative projection +! rlonglob - real - earth relative longitude of observation (radians) +! rlonloc - real - longitude of observation on radar-relative projection +! rlon0 - real - radar station longitude (radians) +! rmins_an - real - analysis time from reference date (minutes) +! rmins_ob - real - observation time from reference date (minutes) +! rstation_id - real - radar station id +! slat0 - real - sin of radar station latitude +! thisazimuthr - real - 90deg minues the actual azimuth and converted to radians +! thiserr - real - observation error +! thislat - real - latitude of observation +! thislon - real - longitude of observation +! thisrange - real - range of observation from radar +! thishgt - real - observation height +! this_stahgt - real - radar station height (meters about sea level) +! this_staid - char - radar station id +! thistilt - real - radar tilt angle (degrees) +! thistiltr - real- radar tilt angle (radians) +! timeb - real - obs time (analyis relative minutes) +! +! +! +! Derived data types +! +! radar - derived data type for containing volume scan information +! nelv- int - number of elevation angles +! radid - char*4 - radar ID (e.g. KAMA) +! vcpnum - int - volume coverage pattern number +! year - int - UTC +! day - int - UTC +! month - int - UTC +! hour - in - UTC +! minute - int - UTC +! second - int - UTC +! radhgt - real - elevation of the radar above sea level in meters (I believe +! this includes the height of the antenna as well) +! radlat - real - latitude location of the radar +! radlon - real - longitude location of the radar +! fstgatdis - real - first gate distance (meters) +! gatewidth - real - gate width (meters) +! elev_angle - real - radar elevation angle (degrees) +! num_beam - int - number of beams +! num_gate - int - number of gates +! nyq_vel - real - nyquist velocity +! azim - real - azimuth angles +! field - real - radar data variable (reflectivity or velocity) +! +! Defined radar types: +! strct_in_vel - radar - contains volume scan information related to +! radial velocity +! strct_in_dbz - radar - contains volume scan information related to +! radar reflectivity +! strct_in_rawvel - radar - contains volume scan information related to +! raw radial velocity +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use netcdf + use mpimod,only:mype + use kinds, only: r_kind,r_double,i_kind,r_single + use constants, only: zero,half,one,two,deg2rad,rearth,rad2deg, & + one_tenth,r1000,r60,r60inv,r100,r400 + use gridmod, only: tll2xy + use obsmod, only: iadate + use convinfo, only: nconvtype,ctwind,icuse,ioctype + use mpimod, only: npe + use read_l2bufr_mod, only : invtllv + + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype,infile + character(len=*),intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: nread,ndata,nodata + integer(i_kind),dimension(npe),intent(inout) :: nobs + +! Declare local parameters + real(r_kind),parameter :: four_thirds = 4.0_r_kind / 3.0_r_kind + real(r_kind),parameter :: r8 = 8.0_r_kind + real(r_kind),parameter:: r360=360.0_r_kind + integer(i_kind),parameter:: maxdat=17 ! Used in generating cdata array + integer (i_kind):: iyear,imon,iday,ihour,imin,isec + +!--Derived data type declaration + + type :: radar + character(4) :: radid + integer(i_kind) :: vcpnum + integer(i_kind) :: year + integer(i_kind) :: month + integer(i_kind) :: day + integer(i_kind) :: hour + integer(i_kind) :: minute + integer(i_kind) :: second + real(r_kind) :: radlat + real(r_kind) :: radlon + real(r_kind) :: radhgt + real(r_kind) :: fstgatdis + real(r_kind) :: gateWidth + real(r_kind) :: elev_angle + integer(i_kind) :: num_beam + integer(i_kind) :: num_gate + real(r_kind) :: nyq_vel + real(r_kind),allocatable :: azim(:) !has dimension (num_beam) + real(r_kind),allocatable :: field(:,:) !has dimension (num_gate,num_beam) + end type radar + +!--Counters for diagnostics + integer(i_kind) :: num_missing=0,num_nopcp=0, & !counts + numbadtime=0,num_badtilt=0, & + num_badrange=0,num_m2nopcp=0, & + num_noise=0,num_limmax=0 ,num_limmin=0 + + + +!--General declarations + integer(i_kind) :: ierror,lunrad,i,j,k,v,na,nb,nelv,nvol, & + ikx,mins_an,mins_ob + integer(i_kind) :: maxobs,nchanl,ilat,ilon,scount + + integer(i_kind),dimension(5) :: obdate + + real(r_kind) :: b,c,ha,epsh,h,aactual,a43,thistilt + real(r_kind) :: thistiltr,selev0,celev0,thisrange,this_stahgt,thishgt + real(r_kind) :: celev,selev,gamma,thisazimuthr,rlon0, & + clat0,slat0,dlat,dlon,thiserr,thislon,thislat, & + rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter + real(r_kind) :: radartwindow + real(r_kind) :: dbzerr,rmins_an,rmins_ob + real(r_kind),allocatable,dimension(:,:):: cdata_all + real(r_double) rstation_id + + character(8) cstaid + character(4) this_staid + equivalence (this_staid,cstaid) + equivalence (cstaid,rstation_id) + + logical :: outside + + type(radar),allocatable :: strct_in_dbz(:,:) + + !---------SETTINGS FOR FUTURE NAMELIST---------! + integer(i_kind) :: maxobrange=999000 ! Range (m) *within* which to use observations - obs *outside* this range are not used + integer(i_kind) :: minobrange=-999 ! Range (m) *outside* of which to use observatons - obs *inside* this range are not used + real(r_kind) :: mintilt=0.0_r_kind ! Only use tilt(elevation) angles (deg) >= this number + real(r_kind) :: maxtilt=20.0_r_kind ! Do no use tilt(elevation) angles (deg) >= this number + logical :: missing_to_nopcp=.false. ! Set missing observations to 'no precipitation' observations -> dbznoise (See Aksoy et al. 2009, MWR) + real(r_kind) :: dbznoise=2.0_r_kind ! dBZ obs must be >= dbznoise for assimilation + logical :: l_limmax=.true. ! If true, observations > 60 dBZ are limited to be 60 dBZ. This is + logical :: l_limmin=.true. ! If true, observations <0 dBZ are limited to be 0 dBZ. This is + + character (len=4) :: radarsite_nc + character (len=256) vcpstr_nc + + +!following the treatment on the precision issue for netcdf like in +!wrf_netcdf_interface.F90 +integer(i_kind) :: ncid,ierr,dimid1,dimid2 +integer(i_kind) :: varid1,varid2,varid3,varid4,varid6 +integer(i_kind) :: numazim_nc,numgate_nc,vcp_nc +real(r_single) :: elev_nc,firstgate_nc,lat_nc,lon_nc,height_nc + + +real(r_single), allocatable :: azimuth_nc(:),beamwidth_nc(:),azimspacing_nc(:),gatewidth_nc(:) +real(r_single), allocatable :: nyquist_nc(:),obdata_nc(:,:) +real(r_single) nyquist_default_nc +parameter(nyquist_default_nc=50.0_r_kind) +!clg + ! ! due to representativeness error associated with the model + !----------------------------------------------! + +!--------------------------------------------------------------------------------------! +! END OF ALL DECLARATIONS ! +!--------------------------------------------------------------------------------------! + + !-Check if reflectivity is in the convinfo file and extract necessary attributes + scount=0 + ikx=0 + do i=1,nconvtype + if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then + ikx=i + radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes + ! (default setting for dbz within convinfo is 0.05 hours) + dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor + exit !Exit loop when finished with initial convinfo fields + else if ( i==nconvtype ) then + write(6,*) 'READ_dBZ: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO' + write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!' + return + endif + end do + + if (minobrange >= maxobrange) then + write(6,*) 'MININMUM OB RANGE >= MAXIMUM OB RANGE FOR READING dBZ - PROGRAM STOPPING FROM READ_DBZ.F90' + call stop2(400) + end if + + + !-next three values are dummy values for now + nchanl=0 + ilon=2 + ilat=3 + + maxobs=2000000 !value taken from read_radar.f90 + + !--Allocate cdata_all array + + allocate(cdata_all(maxdat,maxobs)) + + lunrad=31 +! get the time from the file name + +!read the QC radar data in titls in netcdf format from K. Cooper. + nvol=1 + nelv=1 + v=1;k=1 + + allocate(strct_in_dbz(nvol,nelv)) + +!!READ RADAR DATA +ierr = NF90_OPEN(trim(infile),0,ncid) + +if (ierr /= nf90_noerr) call handle_err(ierr,"open") + +ierr = NF90_INQ_DIMID(ncid,'Azimuth',dimid1) +if (ierr /= nf90_noerr) call handle_err(ierr,"Azimuth") +ierr = NF90_INQ_DIMID(ncid,'Gate',dimid2) +if (ierr /= nf90_noerr) call handle_err(ierr,"Gate") + + + +ierr = NF90_INQ_VARID(ncid,'Azimuth',varid1) +if (ierr /= nf90_noerr) call handle_err(ierr,"Azimuth") +ierr = NF90_INQ_VARID(ncid,'BeamWidth',varid2) +if (ierr /= nf90_noerr) call handle_err(ierr,"BeamWidth") +ierr = NF90_INQ_VARID(ncid,'AzimuthalSpacing',varid3) +if (ierr /= nf90_noerr) call handle_err(ierr,"azimuthalspacing") +ierr = NF90_INQ_VARID(ncid,'GateWidth',varid4) +if (ierr /= nf90_noerr) call handle_err(ierr,"gatewidth") +ierr = NF90_INQ_VARID(ncid,'ReflectivityQC',varid6) +if (ierr /= nf90_noerr) call handle_err(ierr,"ReflectivityQC") + + +ierr = nf90_inquire_dimension(ncid, dimid1, len = numazim_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"numazim data") +ierr = nf90_inquire_dimension(ncid, dimid2, len = numgate_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"numgate data") + + +ierr = NF90_GET_ATT(ncid,nf90_global,'Elevation',elev_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"get elev") +ierr = NF90_GET_ATT(ncid,nf90_global,'RangeToFirstGate',firstgate_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"get firstgate") +ierr = NF90_GET_ATT(ncid,nf90_global,'Latitude',lat_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"get lat") +ierr = NF90_GET_ATT(ncid,nf90_global,'Longitude',lon_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"get lon") +ierr = NF90_GET_ATT(ncid,nf90_global,'radarName-value',radarsite_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"radarsite") +ierr = NF90_GET_ATT(ncid,nf90_global,'vcp-value',vcpstr_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"vcp") +read(vcpstr_nc,*) vcp_nc +ierr = NF90_GET_ATT(ncid,nf90_global,'Height',height_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"height") + + +!reverse order of dimensions as stated in ncdump: +allocate(azimuth_nc(numazim_nc),beamwidth_nc(numazim_nc),azimspacing_nc(numazim_nc),gatewidth_nc(numazim_nc)) +allocate(nyquist_nc(numazim_nc),obdata_nc(numgate_nc,numazim_nc)) + +ierr = NF90_GET_VAR(ncid,varid1,azimuth_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"azimuth data") +ierr = NF90_GET_VAR(ncid,varid2,beamwidth_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"beamwidth data") +ierr = NF90_GET_VAR(ncid,varid3,azimspacing_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"azimspacing data") +ierr = NF90_GET_VAR(ncid,varid4,gatewidth_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"gatewidth data") +ierr = NF90_GET_VAR(ncid,varid6,obdata_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"obdata data") + +ierr = NF90_CLOSE(ncid) +if (ierr /= nf90_noerr) call handle_err(ierr,"close") + +do i=1,numazim_nc + if ( (beamwidth_nc(i) /= beamwidth_nc(1)) .or. (gatewidth_nc(i) /= gatewidth_nc(1)) )then + print *, "stopping: non-uniform scan" + endif +enddo +read(infile(21:24),'(I4.4)')iyear +read(infile(25:26),'(I2.2)')imon +read(infile(27:28),'(I2.2)')iday +read(infile(30:31),'(I2.2)')ihour +read(infile(32:33),'(I2.2)')imin +read(infile(34:35),'(I2.2)')isec +do i=1,numgate_nc + do j=1,numazim_nc + if(obdata_nc(i,j) <= -999_r_kind) obdata_nc(i,j)=-999_r_kind + enddo +enddo + + +!transform the read-in ob to the intermidate obs variables( radar obs to be used in GSI + +strct_in_dbz(v,k)%radid=radarsite_nc +strct_in_dbz(v,k)%vcpnum=vcp_nc +strct_in_dbz(v,k)%year=iyear ! to be defind from infile name +strct_in_dbz(v,k)%month=imon +strct_in_dbz(v,k)%day=iday +strct_in_dbz(v,k)%hour=ihour +strct_in_dbz(v,k)%minute=imin +strct_in_dbz(v,k)%second=isec +strct_in_dbz(v,k)%radlat=lat_nc +strct_in_dbz(v,k)%radlon=lon_nc +strct_in_dbz(v,k)%radhgt=height_nc +strct_in_dbz(v,k)%fstgatdis =firstgate_nc +strct_in_dbz(v,k)%gateWidth=gatewidth_nc(1) ! always the same ??) +strct_in_dbz(v,k)%elev_angle=elev_nc +strct_in_dbz(v,k)%num_beam=numazim_nc +strct_in_dbz(v,k)%num_gate=numgate_nc +na=strct_in_dbz(v,k)%num_beam +nb=strct_in_dbz(v,k)%num_gate + +!******allocate arrays within radar data type**********! +allocate(strct_in_dbz(v,k)%azim(na)) +allocate(strct_in_dbz(v,k)%field(nb,na)) +!******************************************************! + +strct_in_dbz(v,k)%azim(:)=azimuth_nc(:) +strct_in_dbz(v,k)%field(:,:)=obdata_nc(:,:) + ierror=0 + fileopen: if (ierror == 0) then !Check to make sure file is open - will also fail if file does not exist. Closing endif at end of subroutine. + + !*************************IMPORTANT***************************! + ! ! + ! All data = 999.0 correspond to missing or bad data ! + ! ! + !*************************************************************! + + + !------Begin processing--------------------------! + + + !-Obtain analysis time in minutes since reference date + if(ndata/=0) then ! for further thinking + write(6,*)'ndata is not 0 in read_dbz_netcdf, its impact needs to be considered ,stop' + endif + + call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978 +! w3movedat to help get a date from the time difference + rmins_an=mins_an !convert to real number + + volumes: do v=1,nvol + + tilts: do k=1,nelv + + !--Check if observation fits within specified time window--! + !-Find reference time of observation + + obdate(1)=strct_in_dbz(v,k)%year + obdate(2)=strct_in_dbz(v,k)%month + obdate(3)=strct_in_dbz(v,k)%day + obdate(4)=strct_in_dbz(v,k)%hour + obdate(5)=strct_in_dbz(v,k)%minute + call w3fs21(obdate,mins_ob) !mins_ob -integer number of mins snce 01/01/1978 + rmins_ob=mins_ob !convert to real number + rmins_ob=rmins_ob+(strct_in_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time + + !-Comparison is done in units of minutes + + timeb = rmins_ob-rmins_an + if(abs(timeb) > 100_r_kind) cycle + + write(6,*) 'Processing obdate:',obdate,strct_in_dbz(v,k)%second + !--Time window check complete--! + + thistilt=strct_in_dbz(v,k)%elev_angle + if (thistilt <= maxtilt .and. thistilt >= mintilt) then + + gates: do i=1,strct_in_dbz(v,k)%num_gate + + thisrange=strct_in_dbz(v,k)%fstgatdis + float(i-1)*strct_in_dbz(v,k)%gateWidth + + !-Check to make sure observations are within specified range + + if (thisrange <= maxobrange .and. thisrange >= minobrange) then + azms: do j=1,strct_in_dbz(v,k)%num_beam + + !-Check to see if this is a missing observation + + nread=nread+1 + + if ( abs(strct_in_dbz(v,k)%field(i,j)) >= 99.0_r_kind ) then + + !--Extend no precip observations to missing data fields? + ! May help suppress spurious convection if a problem. + + if (missing_to_nopcp) then + strct_in_dbz(v,k)%field(i,j) = dbznoise + num_m2nopcp = num_m2nopcp+1 + else + num_missing=num_missing+1 + cycle azms !No reason to process the ob if it is missing + end if + + end if + + + if (l_limmax) then + if ( strct_in_dbz(v,k)%field(i,j) > 60_r_kind ) then + strct_in_dbz(v,k)%field(i,j) = 60_r_kind + num_limmax=num_limmax+1 + end if + end if + if (l_limmin) then + if ( strct_in_dbz(v,k)%field(i,j) < 0_r_kind ) then + strct_in_dbz(v,k)%field(i,j) = 0_r_kind + num_limmin=num_limmin+1 + end if + end if + + !--Find observation height using method from read_l2bufr_mod.f90 + + this_stahgt=strct_in_dbz(v,k)%radhgt + aactual=rearth+this_stahgt + a43=four_thirds*aactual + thistiltr=thistilt*deg2rad + selev0=sin(thistiltr) + celev0=cos(thistiltr) + b=thisrange*(thisrange+two*aactual*selev0) + c=sqrt(aactual*aactual+b) + ha=b/(aactual+c) + epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) + h=ha-epsh + thishgt=this_stahgt+h + + !--Find observation location using method from read_l2bufr_mod.f90 + + !-Get corrected tilt angle + celev=celev0 + selev=selev0 + celev=a43*celev0/(a43+h) + selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) + + gamma=half*thisrange*(celev0+celev) + + !-Get earth lat lon of observation + + rlon0=deg2rad*strct_in_dbz(v,k)%radlon + clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat) + slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat) + thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to + ! be consistent with + ! read_l2bufr_mod.f90 + rad_per_meter=one/rearth + rlonloc=rad_per_meter*gamma*cos(thisazimuthr) + rlatloc=rad_per_meter*gamma*sin(thisazimuthr) + + call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) + + thislat=rlatglob*rad2deg + thislon=rlonglob*rad2deg + + !-Check format of longitude and correct if necessary + + if(thislon>=r360) thislon=thislon-r360 + if(thislon true +! radartwindow - real - time window for radar observations (minutes) +! rlatglob - real - earth relative latitude of observation (radians) +! rlatloc - real - latitude of observation on radar-relative projection +! rlonglob - real - earth relative longitude of observation (radians) +! rlonloc - real - longitude of observation on radar-relative projection +! rlon0 - real - radar station longitude (radians) +! rmins_an - real - analysis time from reference date (minutes) +! rmins_ob - real - observation time from reference date (minutes) +! rstation_id - real - radar station id +! slat0 - real - sin of radar station latitude +! thisazimuthr - real - 90deg minues the actual azimuth and converted to radians +! thiserr - real - observation error +! thislat - real - latitude of observation +! thislon - real - longitude of observation +! thisrange - real - range of observation from radar +! thishgt - real - observation height +! this_stahgt - real - radar station height (meters about sea level) +! this_staid - char - radar station id +! thistilt - real - radar tilt angle (degrees) +! thistiltr - real- radar tilt angle (radians) +! timeb - real - obs time (analyis relative minutes) +! +! +! +! Derived data types +! +! radar - derived data type for containing volume scan information +! nelv- int - number of elevation angles +! radid - char*4 - radar ID (e.g. KAMA) +! vcpnum - int - volume coverage pattern number +! year - int - UTC +! day - int - UTC +! month - int - UTC +! hour - in - UTC +! minute - int - UTC +! second - int - UTC +! radhgt - real - elevation of the radar above sea level in meters (I believe +! this includes the height of the antenna as well) +! radlat - real - latitude location of the radar +! radlon - real - longitude location of the radar +! fstgatdis - real - first gate distance (meters) +! gatewidth - real - gate width (meters) +! elev_angle - real - radar elevation angle (degrees) +! num_beam - int - number of beams +! num_gate - int - number of gates +! nyq_vel - real - nyquist velocity +! azim - real - azimuth angles +! field - real - radar data variable (reflectivity or velocity) +! +! Defined radar types: +! strct_in_vel - radar - contains volume scan information related to +! radial velocity +! strct_in_dbz - radar - contains volume scan information related to +! radar reflectivity +! strct_in_rawvel - radar - contains volume scan information related to +! raw radial velocity +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use netcdf + use kinds, only: r_kind,r_double,i_kind,i_short,r_single + use constants, only: zero,half,one,two,deg2rad,rearth,rad2deg, & + one_tenth,r1000,r60,r60inv,r100,r400 + use gridmod, only: tll2xy + use obsmod, only: iadate + use convinfo, only: nconvtype,ctwind,icuse,ioctype + use mpimod, only: npe + use read_l2bufr_mod, only : invtllv + + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype,infile + character(len=*),intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: nread,ndata,nodata + integer(i_kind),dimension(npe),intent(inout) :: nobs + +! Declare local parameters + real(r_kind),parameter :: four_thirds = 4.0_r_kind / 3.0_r_kind + real(r_kind),parameter :: r8 = 8.0_r_kind + real(r_kind),parameter:: r360=360.0_r_kind + integer(i_kind),parameter:: maxdat=17 ! Used in generating cdata array + integer (i_kind):: iyear,imon,iday,ihour,imin,isec + +!--Derived data type declaration + + type :: radar + character(4) :: radid + integer(i_kind) :: vcpnum + integer(i_kind) :: year + integer(i_kind) :: month + integer(i_kind) :: day + integer(i_kind) :: hour + integer(i_kind) :: minute + integer(i_kind) :: second + real(r_kind) :: radlat + real(r_kind) :: radlon + real(r_kind) :: radhgt + real(r_kind) :: fstgatdis + real(r_kind) :: gateWidth + real(r_kind) :: elev_angle + integer(i_kind) :: num_beam + integer(i_kind) :: num_gate + real(r_kind) :: nyq_vel + real(r_kind),allocatable :: azim(:) !has dimension (num_beam) + real(r_kind),allocatable :: field(:,:) !has dimension (num_gate,num_beam) + end type radar + +!--Counters for diagnostics + integer(i_kind) :: num_missing=0,num_nopcp=0, & !counts + numbadtime=0,num_badtilt=0, & + num_badrange=0,num_m2nopcp=0, & + num_noise=0,num_limmax=0 ,num_limmin=0 + + + +!--General declarations + integer(i_kind) :: ierror,lunrad,i,j,k,v,na,nb,nelv,nvol, & + ikx,mins_an,mins_ob + integer(i_kind) :: maxobs,nchanl,ilat,ilon,scount + + integer(i_kind),dimension(5) :: obdate + + real(r_kind) :: b,c,ha,epsh,h,aactual,a43,thistilt + real(r_kind) :: thistiltr,selev0,celev0,thisrange,this_stahgt,thishgt + real(r_kind) :: celev,selev,gamma,thisazimuthr,rlon0, & + clat0,slat0,dlat,dlon,thiserr,thislon,thislat, & + rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter + real(r_kind) :: radartwindow + real(r_kind) :: dbzerr,rmins_an,rmins_ob + real(r_kind),allocatable,dimension(:,:):: cdata_all + real(r_double) rstation_id + + character(8) cstaid + character(4) this_staid + equivalence (this_staid,cstaid) + equivalence (cstaid,rstation_id) + + logical :: outside + + type(radar),allocatable :: strct_in_dbz(:,:) + + !---------SETTINGS FOR FUTURE NAMELIST---------! + integer(i_kind) :: maxobrange=99900000 ! Range (m) *within* which to use observations - obs *outside* this range are not used + integer(i_kind) :: minobrange=-999 ! Range (m) *outside* of which to use observatons - obs *inside* this range are not used + real(r_kind) :: mintilt=0.0_r_kind ! Only use tilt(elevation) angles (deg) >= this number + real(r_kind) :: maxtilt=20.0_r_kind ! Do no use tilt(elevation) angles (deg) >= this number + logical :: missing_to_nopcp=.false. ! Set missing observations to 'no precipitation' observations -> dbznoise (See Aksoy et al. 2009, MWR) + real(r_kind) :: dbznoise=2_r_kind ! dBZ obs must be >= dbznoise for assimilation + logical :: l_limmax=.true. ! If true, observations > 60 dBZ are limited to be 60 dBZ. This is + logical :: l_limmin=.true. ! If true, observations <0 dBZ are limited to be 0 dBZ. This is + + character (len=4) :: radarsite_nc + character (len=256) vcpstr_nc + + +!following the treatment on the precision issue for netcdf like in +!wrf_netcdf_interface.F90 +integer(i_kind) :: ncid,ierr,dimid1,dimid2,dimid3 +integer(i_kind) :: varid1,varid2,varid3,varid4,varid6 +integer(i_kind) :: pixel_x_varid,pixel_y_varid +integer(i_kind) :: numazim_nc,numgate_nc,num_pixel_nc,real_num_pixel,vcp_nc +real(r_single) :: elev_nc,firstgate_nc,lat_nc,lon_nc,height_nc +integer(i_short),allocatable :: pixel_x_nc(:),pixel_y_nc(:) + + +real(r_single), allocatable :: azimuth_nc(:),beamwidth_nc(:),azimspacing_nc(:),gatewidth_nc(:) +real(r_single), allocatable :: nyquist_nc(:),obdata_nc(:,:),obdata_pixel_nc(:) +real(r_single) nyquist_default_nc +parameter(nyquist_default_nc=50.0_r_kind) +logical l_pixel_unlimited +integer(i_kind):: ipix +integer(i_kind)::real_numpixel,start_nc(1),count_nc(1) + + !-Check if reflectivity is in the convinfo file and extract necessary attributes + scount=0 + ikx=0 + do i=1,nconvtype + if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then + ikx=i + radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes + ! (default setting for dbz within convinfo is 0.05 hours) + dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor + exit !Exit loop when finished with initial convinfo fields + else if ( i==nconvtype ) then + write(6,*) 'READ_dBZ: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO' + write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!' + return + endif + end do + + if (minobrange >= maxobrange) then + write(6,*) 'MININMUM OB RANGE >= MAXIMUM OB RANGE FOR READING dBZ - PROGRAM STOPPING FROM READ_DBZ.F90' + call stop2(400) + end if + + + !-next three values are dummy values for now + nchanl=0 + ilon=2 + ilat=3 + + maxobs=2000000 !value taken from read_radar.f90 + + !--Allocate cdata_all array + + allocate(cdata_all(maxdat,maxobs)) + + lunrad=31 + + nvol=1 + nelv=1 + v=1;k=1 + + allocate(strct_in_dbz(nvol,nelv)) + +!!READ RADAR DATA +ierr = NF90_OPEN(trim(infile),0,ncid) + +if (ierr /= nf90_noerr) call handle_err(ierr,"open") + +ierr = NF90_INQ_DIMID(ncid,'Azimuth',dimid1) +if (ierr /= nf90_noerr) call handle_err(ierr,"Azimuth") +ierr = NF90_INQ_DIMID(ncid,'Gate',dimid2) +if (ierr /= nf90_noerr) call handle_err(ierr,"Gate") +ierr = NF90_INQ_DIMID(ncid,'pixel',dimid3) +if (ierr /= nf90_noerr) call handle_err(ierr,"Pixel number") + + + +ierr = NF90_INQ_VARID(ncid,'Azimuth',varid1) +if (ierr /= nf90_noerr) call handle_err(ierr,"Azimuth") +ierr = NF90_INQ_VARID(ncid,'BeamWidth',varid2) +if (ierr /= nf90_noerr) call handle_err(ierr,"BeamWidth") +ierr = NF90_INQ_VARID(ncid,'AzimuthalSpacing',varid3) +if (ierr /= nf90_noerr) call handle_err(ierr,"azimuthalspacing") +ierr = NF90_INQ_VARID(ncid,'GateWidth',varid4) +if (ierr /= nf90_noerr) call handle_err(ierr,"gatewidth") +ierr = NF90_INQ_VARID(ncid,'pixel_x',pixel_x_varid) +ierr = NF90_INQ_VARID(ncid,'pixel_y',pixel_y_varid) +ierr = NF90_INQ_VARID(ncid,'ReflectivityQC',varid6) +if (ierr /= nf90_noerr) call handle_err(ierr,"ReflectivityQC") + + +ierr = nf90_inquire_dimension(ncid, dimid1, len = numazim_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"numazim data") +ierr = nf90_inquire_dimension(ncid, dimid2, len = numgate_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"numgate data") +ierr = nf90_inquire_dimension(ncid, dimid3, len = num_pixel_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"num_pixel_ncdata") +if(num_pixel_nc<=0 ) then !unlimited size + num_pixel_nc=numazim_nc*numgate_nc + l_pixel_unlimited=.true. +else + real_num_pixel=num_pixel_nc + l_pixel_unlimited=.false. +endif + + +ierr = NF90_GET_ATT(ncid,nf90_global,'Elevation',elev_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"get elev") +ierr = NF90_GET_ATT(ncid,nf90_global,'RangeToFirstGate',firstgate_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"get firstgate") +ierr = NF90_GET_ATT(ncid,nf90_global,'Latitude',lat_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"get lat") +ierr = NF90_GET_ATT(ncid,nf90_global,'Longitude',lon_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"get lon") +ierr = NF90_GET_ATT(ncid,nf90_global,'radarName-value',radarsite_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"radarsite") +ierr = NF90_GET_ATT(ncid,nf90_global,'vcp-value',vcpstr_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"vcp") +read(vcpstr_nc,*) vcp_nc +ierr = NF90_GET_ATT(ncid,nf90_global,'Height',height_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"height") + + +!reverse order of dimensions as stated in ncdump: +allocate(azimuth_nc(numazim_nc),beamwidth_nc(numazim_nc),azimspacing_nc(numazim_nc),gatewidth_nc(numazim_nc)) +allocate(nyquist_nc(numazim_nc),obdata_nc(numgate_nc,numazim_nc)) +allocate(obdata_pixel_nc(num_pixel_nc)) +allocate(pixel_x_nc(num_pixel_nc)) +allocate(pixel_y_nc(num_pixel_nc)) + +ierr = NF90_GET_VAR(ncid,varid1,azimuth_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"azimuth data") +ierr = NF90_GET_VAR(ncid,varid2,beamwidth_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"beamwidth data") +ierr = NF90_GET_VAR(ncid,varid3,azimspacing_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"azimspacing data") +ierr = NF90_GET_VAR(ncid,varid4,gatewidth_nc) +if (ierr /= nf90_noerr) call handle_err(ierr,"gatewidth data") +if(.not.l_pixel_unlimited) then + ierr = NF90_GET_VAR(ncid,varid6,obdata_pixel_nc) + real_numpixel=num_pixel_nc +if (ierr /= nf90_noerr) call handle_err(ierr,"obdata_pixel data") + ierr = NF90_GET_VAR(ncid,pixel_x_varid,pixel_x_nc) + ierr = NF90_GET_VAR(ncid,pixel_y_varid,pixel_y_nc) +else + ierr=nf90_noerr + ipix=1 + start_nc=(/1/) + count_nc=(/1/) + ipix=1 + do 255, while (ierr == nf90_noerr) + start_nc(1)=ipix + ierr = NF90_GET_VAR(ncid,varid6,obdata_pixel_nc(ipix:ipix),start=start_nc,count=count_nc) + ierr = NF90_GET_VAR(ncid,pixel_x_varid,pixel_x_nc(ipix:ipix),start=start_nc,count=count_nc) + ierr = NF90_GET_VAR(ncid,pixel_y_varid,pixel_y_nc(ipix:ipix),start=start_nc,count=count_nc) + ipix=ipix+1 +255 continue + real_numpixel=ipix-2 + +endif + +ierr = NF90_CLOSE(ncid) +if (ierr /= nf90_noerr) call handle_err(ierr,"close") + +do i=1,numazim_nc + if ( (beamwidth_nc(i) /= beamwidth_nc(1)) .or. (gatewidth_nc(i) /= gatewidth_nc(1)) )then + print *, "stopping: non-uniform scan" + endif +enddo +read(infile(21:24),'(I4.4)')iyear +read(infile(25:26),'(I2.2)')imon +read(infile(27:28),'(I2.2)')iday +read(infile(30:31),'(I2.2)')ihour +read(infile(32:33),'(I2.2)')imin +read(infile(34:35),'(I2.2)')isec +do j=1,real_numpixel + if(obdata_pixel_nc(j) < -999_r_kind) obdata_pixel_nc(j)=-999_r_kind +enddo + + +! transform the read-in ob to the intermidate obs variables( radar obs to be used in GSI + + strct_in_dbz(v,k)%radid=radarsite_nc + strct_in_dbz(v,k)%vcpnum=vcp_nc + strct_in_dbz(v,k)%year=iyear ! to be defind from infile name + strct_in_dbz(v,k)%month=imon + strct_in_dbz(v,k)%day=iday + strct_in_dbz(v,k)%hour=ihour + strct_in_dbz(v,k)%minute=imin + strct_in_dbz(v,k)%second=isec + strct_in_dbz(v,k)%radlat=lat_nc + strct_in_dbz(v,k)%radlon=lon_nc + strct_in_dbz(v,k)%radhgt=height_nc + strct_in_dbz(v,k)%fstgatdis =firstgate_nc + strct_in_dbz(v,k)%gateWidth=gatewidth_nc(1) ! always the same ??) + strct_in_dbz(v,k)%elev_angle=elev_nc + strct_in_dbz(v,k)%num_beam=numazim_nc + strct_in_dbz(v,k)%num_gate=numgate_nc + na=strct_in_dbz(v,k)%num_beam + nb=strct_in_dbz(v,k)%num_gate + + !******allocate arrays within radar data type**********! + allocate(strct_in_dbz(v,k)%azim(na)) + !******************************************************! + + strct_in_dbz(v,k)%azim(:)=azimuth_nc(:) + ierror=0 + fileopen: if (ierror == 0) then !Check to make sure file is open - will also fail if file does not exist. Closing endif at end of subroutine. + + + !-Obtain analysis time in minutes since reference date + + call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978 +! w3movedat to help get a date from the time difference + rmins_an=mins_an !convert to real number + + volumes: do v=1,nvol + + tilts: do k=1,nelv + + !--Check if observation fits within specified time window--! + !-Find reference time of observation + + obdate(1)=strct_in_dbz(v,k)%year + obdate(2)=strct_in_dbz(v,k)%month + obdate(3)=strct_in_dbz(v,k)%day + obdate(4)=strct_in_dbz(v,k)%hour + obdate(5)=strct_in_dbz(v,k)%minute + call w3fs21(obdate,mins_ob) !mins_ob -integer number of mins snce 01/01/1978 + + rmins_ob=mins_ob !convert to real number + rmins_ob=rmins_ob+(strct_in_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time + + !-Comparison is done in units of minutes + + timeb = rmins_ob-rmins_an +! now the window is controled by the preprocessing script starting from +!5/14/2015 +! if(abs(timeb) > abs(radartwindow)) then +! numbadtime=numbadtime+1 +! cycle tilts !If not in time window, cycle the loop +! end if + + write(6,*) 'Processing obdate:',obdate,strct_in_dbz(v,k)%second + if(abs(timeb) > 99999_r_kind) cycle + !--Time window check complete--! + + thistilt=strct_in_dbz(v,k)%elev_angle + if (thistilt <= maxtilt .and. thistilt >= mintilt) then + + pixel: do ipix=1,real_numpixel + j=pixel_x_nc(ipix)+1 + i=pixel_y_nc(ipix)+1 + + thisrange=strct_in_dbz(v,k)%fstgatdis + float(i-1)*strct_in_dbz(v,k)%gateWidth + + !-Check to make sure observations are within specified range + + if (thisrange <= maxobrange .and. thisrange >= minobrange) then + + + nread=nread+1 + if ( abs(obdata_pixel_nc(ipix)) >= 999.0_r_kind ) then + + !--Extend no precip observations to missing data fields? + ! May help suppress spurious convection if a problem. + + if (missing_to_nopcp) then + obdata_pixel_nc(ipix) = dbznoise + num_m2nopcp = num_m2nopcp+1 + else + num_missing=num_missing+1 + cycle pixel !No reason to process the ob if it is missing + end if + + end if + + + if (l_limmax) then + if ( obdata_pixel_nc(ipix) > 60_r_kind ) then + obdata_pixel_nc(ipix) = 60_r_kind + num_limmax=num_limmax+1 + end if + end if + if (l_limmin) then + if ( obdata_pixel_nc(ipix) < 0_r_kind ) then + obdata_pixel_nc(ipix) = 0_r_kind + num_limmin=num_limmin+1 + end if + end if + + !-Special treatment for no-precip obs? + + + !--Find observation height using method from read_l2bufr_mod.f90 + + this_stahgt=strct_in_dbz(v,k)%radhgt + aactual=rearth+this_stahgt + a43=four_thirds*aactual + thistiltr=thistilt*deg2rad + selev0=sin(thistiltr) + celev0=cos(thistiltr) + b=thisrange*(thisrange+two*aactual*selev0) + c=sqrt(aactual*aactual+b) + ha=b/(aactual+c) + epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) + h=ha-epsh + thishgt=this_stahgt+h + + !--Find observation location using method from read_l2bufr_mod.f90 + + !-Get corrected tilt angle + celev=celev0 + selev=selev0 + celev=a43*celev0/(a43+h) + selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) + + gamma=half*thisrange*(celev0+celev) + + !-Get earth lat lon of observation + + rlon0=deg2rad*strct_in_dbz(v,k)%radlon + clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat) + slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat) + thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to + ! be consistent with + ! read_l2bufr_mod.f90 + rad_per_meter=one/rearth + rlonloc=rad_per_meter*gamma*cos(thisazimuthr) + rlatloc=rad_per_meter*gamma*sin(thisazimuthr) + + call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) + + thislat=rlatglob*rad2deg + thislon=rlonglob*rad2deg + + !-Check format of longitude and correct if necessary + + if(thislon>=r360) thislon=thislon-r360 + if(thislon 30) and ipchan_radiag (7 -> 8) +! 2011-07-24 safford - make structure size for reading data_fix data version dependent +! 2013-11-21 todling - revisit how versions are set (add set/get_radiag) +! 2014-01-27 todling - add ob sensitivity index +! 2016-11-12 shlyaeva - add H(x) jacobian for EnKF +! 2017-07-13 mccarty - incorporate hooks for nc4/binary diag reading +! +! contains +! read_radiag_header - read radiance diagnostic file header +! read_radiag_data - read radiance diagnostic file data +! set_netcdf_read - call set_netcdf_read(.true.) to use nc4 hooks, otherwise read file as +! traditional binary format +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +module read_diag + + use kinds, only: i_kind,r_single,r_kind + use sparsearr, only: sparr, sparr2, readarray, assignment(=), delete + use nc_diag_read_mod, only: nc_diag_read_get_var, nc_diag_read_get_global_attr + use nc_diag_read_mod, only: nc_diag_read_get_dim + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + implicit none + +! Declare public and private + private + + public :: diag_header_fix_list + public :: diag_header_chan_list + public :: diag_data_name_list + public :: diag_data_fix_list + public :: diag_data_chan_list + public :: diag_data_extra_list + public :: open_radiag + public :: close_radiag + public :: read_radiag_header + public :: read_radiag_data + public :: iversion_radiag + public :: iversion_radiag_1 + public :: iversion_radiag_2 + public :: iversion_radiag_3 + public :: iversion_radiag_4 + public :: iversion_radiag_5 + public :: ireal_old_radiag + public :: set_netcdf_read +! public :: iversion_radiag +! public :: iversion_radiag_1 +! public :: iversion_radiag_2 +! public :: iversion_radiag_3 +! public :: iversion_radiag_4 + public :: ireal_radiag + public :: ipchan_radiag + public :: set_radiag + public :: get_radiag + + interface set_radiag + module procedure set_radiag_int_ ! internal procedure for integers + end interface + interface get_radiag + module procedure get_radiag_int_ ! internal procedure for integers + end interface + + integer(i_kind),parameter :: ireal_radiag = 30 ! number of real entries per spot in radiance diagnostic file + integer(i_kind),parameter :: ireal_old_radiag = 26 ! number of real entries per spot in versions older than iversion_radiag_2 + integer(i_kind),parameter :: ipchan_radiag = 8 ! number of entries per channel per spot in radiance diagnostic file + +! Declare structures for radiance diagnostic file information + type diag_header_fix_list + character(len=20) :: isis ! sat and sensor type + character(len=10) :: id ! sat type + character(len=10) :: obstype ! observation type + integer(i_kind) :: jiter ! outer loop counter + integer(i_kind) :: nchan ! number of channels in the sensor + integer(i_kind) :: npred ! number of updating bias correction predictors + integer(i_kind) :: idate ! time (yyyymmddhh) + integer(i_kind) :: ireal ! # of real elements in the fix part of a data record + integer(i_kind) :: ipchan ! # of elements for each channel except for bias correction terms + integer(i_kind) :: iextra ! # of extra elements for each channel + integer(i_kind) :: jextra ! # of extra elements + integer(i_kind) :: idiag ! first dimension of diag_data_chan + integer(i_kind) :: angord ! order of polynomial for adp_anglebc option + integer(i_kind) :: iversion ! radiance diagnostic file version number + integer(i_kind) :: inewpc ! indicator of newpc4pred (1 on, 0 off) + integer(i_kind) :: ijacob ! indicates whether jacobian included (1 yes, 0 no) + integer(i_kind) :: isens ! sensitivity index + end type diag_header_fix_list + + type diag_data_name_list + character(len=10),dimension(ireal_radiag) :: fix + character(len=10),dimension(:),allocatable :: chn + end type diag_data_name_list + + type diag_header_chan_list + real(r_single) :: freq ! frequency (Hz) + real(r_single) :: polar ! polarization + real(r_single) :: wave ! wave number (cm^-1) + real(r_single) :: varch ! error variance (or SD error?) + real(r_single) :: tlapmean ! mean lapse rate + integer(i_kind):: iuse ! use flag + integer(i_kind):: nuchan ! sensor relative channel number + integer(i_kind):: iochan ! satinfo relative channel number + end type diag_header_chan_list + + type diag_data_fix_list + real(r_single) :: lat ! latitude (deg) + real(r_single) :: lon ! longitude (deg) + real(r_single) :: zsges ! guess elevation at obs location (m) + real(r_single) :: obstime ! observation time relative to analysis + real(r_single) :: senscn_pos ! sensor scan position (integer(i_kind)) + real(r_single) :: satzen_ang ! satellite zenith angle (deg) + real(r_single) :: satazm_ang ! satellite azimuth angle (deg) + real(r_single) :: solzen_ang ! solar zenith angle (deg) + real(r_single) :: solazm_ang ! solar azimumth angle (deg) + real(r_single) :: sungln_ang ! sun glint angle (deg) + real(r_single) :: water_frac ! fractional coverage by water + real(r_single) :: land_frac ! fractional coverage by land + real(r_single) :: ice_frac ! fractional coverage by ice + real(r_single) :: snow_frac ! fractional coverage by snow + real(r_single) :: water_temp ! surface temperature over water (K) + real(r_single) :: land_temp ! surface temperature over land (K) + real(r_single) :: ice_temp ! surface temperature over ice (K) + real(r_single) :: snow_temp ! surface temperature over snow (K) + real(r_single) :: soil_temp ! soil temperature (K) + real(r_single) :: soil_mois ! soil moisture + real(r_single) :: land_type ! land type (integer(i_kind)) + real(r_single) :: veg_frac ! vegetation fraction + real(r_single) :: snow_depth ! snow depth + real(r_single) :: sfc_wndspd ! surface wind speed + real(r_single) :: qcdiag1 ! ir=cloud fraction, mw=cloud liquid water + real(r_single) :: qcdiag2 ! ir=cloud top pressure, mw=total column water + real(r_single) :: tref ! reference temperature (Tr) in NSST + real(r_single) :: dtw ! dt_warm at zob + real(r_single) :: dtc ! dt_cool at zob + real(r_single) :: tz_tr ! d(Tz)/d(Tr) + end type diag_data_fix_list + + type diag_data_chan_list + real(r_single) :: tbobs ! Tb (obs) (K) + real(r_single) :: omgbc ! Tb_(obs) - Tb_(simulated w/ bc) (K) + real(r_single) :: omgnbc ! Tb_(obs) - Tb_(simulated_w/o bc) (K) + type(sparr) :: dhx_dx ! profile of dH(x) / dx + real(r_single) :: sprd ! ensemble spread + real(r_single) :: errinv ! inverse error (K**(-1)) + real(r_single) :: qcmark ! quality control mark + real(r_single) :: emiss ! surface emissivity + real(r_single) :: tlap ! temperature lapse rate + real(r_single) :: tb_tz ! d(Tb)/d(Tz) + real(r_single) :: bicons ! constant bias correction term + real(r_single) :: biang ! scan angle bias correction term + real(r_single) :: biclw ! CLW bias correction term + real(r_single) :: bilap2 ! square lapse rate bias correction term + real(r_single) :: bilap ! lapse rate bias correction term + real(r_single) :: bicos ! node*cos(lat) bias correction term + real(r_single) :: bisin ! sin(lat) bias correction term + real(r_single) :: biemis ! emissivity sensitivity bias correction term + real(r_single),dimension(:),allocatable :: bifix ! angle dependent bias + real(r_single) :: bisst ! SST bias correction term + end type diag_data_chan_list + + type diag_data_extra_list + real(r_single) :: extra ! extra information + end type diag_data_extra_list + + integer(i_kind),save :: iversion_radiag ! Current version (see set routine) + integer(i_kind),parameter:: iversion_radiag_1 = 11104 ! Version when bias-correction entries were modified + integer(i_kind),parameter:: iversion_radiag_2 = 13784 ! Version when NSST entries were added + integer(i_kind),parameter:: iversion_radiag_3 = 19180 ! Version when SSMIS added + integer(i_kind),parameter:: iversion_radiag_4 = 30303 ! Version when emissivity predictor added + integer(i_kind),parameter:: iversion_radiag_5 = 40000 ! Version when ensemble spread (and optional jacobian) added + + real(r_single),parameter:: rmiss_radiag = -9.9e11_r_single + + logical,save :: netcdf = .false. + + type ncdiag_status + logical :: nc_read + integer(i_kind) :: cur_ob_idx + integer(i_kind) :: num_records + type(diag_data_fix_list), allocatable :: all_data_fix(:) + type(diag_data_chan_list), allocatable :: all_data_chan(:,:) + type(diag_data_extra_list), allocatable :: all_data_extra(:,:,:) + end type ncdiag_status + + integer(i_kind), parameter :: MAX_OPEN_NCDIAG = 2 + integer(i_kind), save :: nopen_ncdiag = 0 + integer(i_kind), dimension(MAX_OPEN_NCDIAG), save :: ncdiag_open_id = (/-1, -1/) + type(ncdiag_status), dimension(MAX_OPEN_NCDIAG), save :: ncdiag_open_status + +contains + +subroutine set_radiag_int_ (what,iv,ier) +character(len=*),intent(in) :: what +integer(i_kind),intent(in) :: iv +integer(i_kind),intent(out):: ier +ier=-1 +if(trim(what)=='version') then + iversion_radiag = iv + ier=0 +endif +end subroutine set_radiag_int_ + +subroutine get_radiag_int_ (what,iv,ier) +character(len=*),intent(in) :: what +integer(i_kind),intent(out):: iv +integer(i_kind),intent(out):: ier +ier=-1 +if(trim(what)=='version') then + iv = iversion_radiag + ier=0 +endif +end subroutine get_radiag_int_ + +subroutine set_netcdf_read(use_netcdf) +! . . . . +! subprogram: read_diag_header_bin read rad diag header +! prgmmr: mccarty org: gmao date: 2015-08-06 +! +! abstract: This routine sets the routines to read from a netcdf file. +! The default currently is to read binary files +! +! program history log: +! 2015-08-06 mccarty - created routine +! +! input argument list: +! use_netcdf - logical .true. tells routine to read netcdf diag +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + logical,intent(in) :: use_netcdf + + netcdf = use_netcdf +end subroutine set_netcdf_read + + +subroutine open_radiag(filename, ftin, istatus) + character*500, intent(in) :: filename + integer(i_kind), intent(inout) :: ftin + integer(i_kind), intent(out):: istatus + + integer(i_kind) :: i + + istatus = -999 + if (netcdf) then + if (nopen_ncdiag >= MAX_OPEN_NCDIAG) then + write(6,*) 'OPEN_RADIAG: ***ERROR*** Cannot open more than ', & + MAX_OPEN_NCDIAG, ' netcdf diag files.' + call stop2(456) + endif + call nc_diag_read_init(filename,ftin) + istatus=0 + do i = 1, MAX_OPEN_NCDIAG + if (ncdiag_open_id(i) < 0) then + ncdiag_open_id(i) = ftin + ncdiag_open_status(i)%nc_read = .false. + ncdiag_open_status(i)%cur_ob_idx = -9999 + ncdiag_open_status(i)%num_records = -9999 + if (allocated(ncdiag_open_status(i)%all_data_fix)) then + deallocate(ncdiag_open_status(i)%all_data_fix) + endif + if (allocated(ncdiag_open_status(i)%all_data_chan)) then + deallocate(ncdiag_open_status(i)%all_data_chan) + endif + if (allocated(ncdiag_open_status(i)%all_data_extra)) then + deallocate(ncdiag_open_status(i)%all_data_extra) + endif + nopen_ncdiag = nopen_ncdiag + 1 + exit + endif + enddo + else + open(ftin,form="unformatted",file=filename,iostat=istatus) + rewind(ftin) + endif + +end subroutine open_radiag + +subroutine close_radiag(filename, ftin) + character*500, intent(in) :: filename + integer(i_kind), intent(inout) :: ftin + + integer(i_kind) :: id + + if (netcdf) then + id = find_ncdiag_id(ftin) + if (id < 0) then + write(6,*) 'CLOSE_RADIAG: ***ERROR*** ncdiag file ', filename, & + ' was not opened' + call stop2(456) + endif + call nc_diag_read_close(filename) + ncdiag_open_id(id) = -1 + ncdiag_open_status(id)%nc_read = .false. + ncdiag_open_status(id)%cur_ob_idx = -9999 + ncdiag_open_status(id)%num_records = -9999 + if (allocated(ncdiag_open_status(id)%all_data_fix)) then + deallocate(ncdiag_open_status(id)%all_data_fix) + endif + if (allocated(ncdiag_open_status(id)%all_data_chan)) then + deallocate(ncdiag_open_status(id)%all_data_chan) + endif + if (allocated(ncdiag_open_status(id)%all_data_extra)) then + deallocate(ncdiag_open_status(id)%all_data_extra) + endif + nopen_ncdiag = nopen_ncdiag - 1 + else + close(ftin) + endif + +end subroutine close_radiag + +subroutine read_radiag_header(ftin,npred_radiag,retrieval,header_fix,header_chan,data_name,iflag,lverbose) +! . . . . +! subprogram: read_diag_header_bin read rad diag header +! prgmmr: mccarty org: gmao date: 2015-08-06 +! +! abstract: This routine reads the header record from a radiance +! diagnostic file +! +! program history log: +! 2015-08-06 mccarty - created routine w/ fork for ncdiag or binary +! +! input argument list: +! ftin - unit number connected to diagnostic file +! npred_radiag - number of bias correction terms +! retrieval - .true. if sst retrieval +! +! output argument list: +! header_fix - header information structure +! header_chan - channel information structure +! data_name - diag file data names +! iflag - error code +! lverbose - optional flag to turn off default output to standard out +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + integer(i_kind),intent(in) :: npred_radiag + logical,intent(in) :: retrieval + type(diag_header_fix_list ),intent(out):: header_fix + type(diag_header_chan_list),allocatable :: header_chan(:) + type(diag_data_name_list) :: data_name + integer(i_kind),intent(out) :: iflag + logical,optional,intent(in) :: lverbose + + iflag = 0 + if (netcdf) then + call read_radiag_header_nc(ftin,header_fix,header_chan,iflag) + else + call read_radiag_header_bin(ftin,npred_radiag,retrieval,header_fix,header_chan,data_name,iflag,lverbose) + endif + +end subroutine read_radiag_header + +subroutine read_radiag_header_nc(ftin,header_fix,header_chan,iflag) +! . . . . +! subprogram: read_diag_header_nc read rad diag header +! prgmmr: mccarty org: gmao date: 2003-01-01 +! +! abstract: This routine reads the header record from a radiance +! diagnostic file +! +! program history log: +! 2015-08-06 mccarty - Created routine for ncdiag header reading +! +! input argument list: +! ftin - unit number connected to diagnostic file +! +! output argument list: +! header_fix - header information structure +! header_chan - channel information structure +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + type(diag_header_fix_list ),intent(out):: header_fix + type(diag_header_chan_list),allocatable :: header_chan(:) + integer(i_kind),intent(out) :: iflag + +! local variables + integer(i_kind) :: nchan_dim + real(r_kind),allocatable,dimension(:) :: r_var_stor + integer(i_kind),allocatable,dimension(:) :: i_var_stor + character(20) :: isis + character(10) :: id, obstype +! integer(i_kind),dimension(:),allocatable :: jiter, nchan_diag, npred, idate, & + integer(i_kind) :: jiter, nchan_diag, npred, idate, & + ireal, ipchan, iextra, jextra, & + idiag, angord, iversion, inewpc, & + isens, ijacob + + iflag = 0 +! allocate(nchan_diag(1) ) + nchan_dim = nc_diag_read_get_dim(ftin,'nchans') + header_fix%nchan = nchan_dim + + call nc_diag_read_get_global_attr(ftin, "Number_of_channels", nchan_diag) + + if (nchan_dim /= nchan_diag) then + write(*,*)'ERROR: Number of channels from dimension do not match those from header, aborting.' + call stop2(321) + endif + + call nc_diag_read_get_global_attr(ftin, "Satellite_Sensor", isis) ; header_fix%isis = isis + call nc_diag_read_get_global_attr(ftin, "Satellite", id) ; header_fix%id = id + call nc_diag_read_get_global_attr(ftin, "Observation_type", obstype) ; header_fix%obstype = obstype + call nc_diag_read_get_global_attr(ftin, "Outer_Loop_Iteration", jiter) ; header_fix%jiter = jiter + call nc_diag_read_get_global_attr(ftin, "Number_of_Predictors", npred) ; header_fix%npred = npred + call nc_diag_read_get_global_attr(ftin, "date_time", idate) ; header_fix%idate = idate + call nc_diag_read_get_global_attr(ftin, "ireal_radiag", ireal) ; header_fix%ireal = ireal + call nc_diag_read_get_global_attr(ftin, "ipchan_radiag", ipchan) ; header_fix%ipchan = ipchan + call nc_diag_read_get_global_attr(ftin, "iextra", iextra) ; header_fix%iextra = iextra + call nc_diag_read_get_global_attr(ftin, "jextra", jextra) ; header_fix%jextra = jextra + call nc_diag_read_get_global_attr(ftin, "idiag", idiag) ; header_fix%idiag = idiag + call nc_diag_read_get_global_attr(ftin, "angord", angord) ; header_fix%angord = angord + call nc_diag_read_get_global_attr(ftin, "iversion_radiag", iversion) ; header_fix%iversion = iversion + call nc_diag_read_get_global_attr(ftin, "New_pc4pred", inewpc) ; header_fix%inewpc = inewpc + call nc_diag_read_get_global_attr(ftin, "ioff0", isens) ; header_fix%isens = isens + call nc_diag_read_get_global_attr(ftin, "ijacob", ijacob) ; header_fix%ijacob = ijacob + + + if (allocated(header_chan)) deallocate(header_chan) + allocate(header_chan(nchan_dim) ) + + if (allocated(r_var_stor)) deallocate(r_var_stor) + if (allocated(i_var_stor)) deallocate(i_var_stor) + allocate(r_var_stor(nchan_dim), & + i_var_stor(nchan_dim) ) +! call nc_diag_read_get_var('Var', var_stor) + call nc_diag_read_get_var(ftin, 'frequency',r_var_stor) ; header_chan%freq = r_var_stor + call nc_diag_read_get_var(ftin, 'polarization',i_var_stor) ; header_chan%polar = i_var_stor + call nc_diag_read_get_var(ftin, 'wavenumber',r_var_stor) ; header_chan%wave = r_var_stor + call nc_diag_read_get_var(ftin, 'error_variance',r_var_stor) ; header_chan%varch = r_var_stor + call nc_diag_read_get_var(ftin, 'mean_lapse_rate',r_var_stor); header_chan%tlapmean = r_var_stor + call nc_diag_read_get_var(ftin, 'use_flag',i_var_stor) ; header_chan%iuse = i_var_stor + call nc_diag_read_get_var(ftin, 'sensor_chan',i_var_stor) ; header_chan%nuchan = i_var_stor + call nc_diag_read_get_var(ftin, 'satinfo_chan',i_var_stor) ; header_chan%iochan = i_var_stor + + +end subroutine read_radiag_header_nc + +subroutine read_radiag_header_bin(ftin,npred_radiag,retrieval,header_fix,header_chan,data_name,iflag,lverbose) +! . . . . +! subprogram: read_diag_header_bin read rad diag header +! prgmmr: tahara org: np20 date: 2003-01-01 +! +! abstract: This routine reads the header record from a radiance +! diagnostic file +! +! program history log: +! 2010-10-05 treadon - add this doc block +! 2011-02-22 kleist - changes related to memory allocation and standard output +! 2014-07-25 sienkiewicz - supress warning if npred_radiag == 0 +! 2017-07-17 mccarty - renamed routine to _bin suffix for ncdiag +! +! input argument list: +! ftin - unit number connected to diagnostic file +! npred_radiag - number of bias correction terms +! retrieval - .true. if sst retrieval +! +! output argument list: +! header_fix - header information structure +! header_chan - channel information structure +! data_name - diag file data names +! iflag - error code +! lverbose - optional flag to turn off default output to standard out +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + integer(i_kind),intent(in) :: npred_radiag + logical,intent(in) :: retrieval + type(diag_header_fix_list ),intent(out):: header_fix + type(diag_header_chan_list),allocatable :: header_chan(:) + type(diag_data_name_list) :: data_name + integer(i_kind),intent(out) :: iflag + logical,optional,intent(in) :: lverbose + +! Declare local variables + character(len=2):: string + character(len=10):: satid,sentype + character(len=20):: sensat + integer(i_kind) :: i,ich + integer(i_kind):: jiter,nchanl,npred,ianldate,ireal,ipchan,iextra,jextra + integer(i_kind):: idiag,angord,iversion,inewpc,isens,ijacob + integer(i_kind):: iuse_tmp,nuchan_tmp,iochan_tmp + real(r_single) :: freq_tmp,polar_tmp,wave_tmp,varch_tmp,tlapmean_tmp + logical loutall + + loutall=.true. + if(present(lverbose)) loutall=lverbose + +! Read header (fixed_part). + read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc,isens,ijacob + if (iflag/=0) then + rewind(ftin) + read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc,isens + ijacob=0 + if (iflag/=0) then + rewind(ftin) + read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc + isens=0 + end if + end if + + if (iflag/=0) then + rewind(ftin) + read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra + idiag=ipchan+npred+1 + angord=0 + iversion=0 + inewpc=0 + isens=0 + if (iflag/=0) then + write(6,*)'READ_RADIAG_HEADER: ***ERROR*** Unknown file format. Cannot read' + return + endif + endif + + header_fix%isis = sensat + header_fix%id = satid + header_fix%obstype = sentype + header_fix%jiter = jiter + header_fix%nchan = nchanl + header_fix%npred = npred + header_fix%idate = ianldate + header_fix%ireal = ireal + header_fix%ipchan = ipchan + header_fix%iextra = iextra + header_fix%jextra = jextra + header_fix%idiag = idiag + header_fix%ijacob = ijacob + header_fix%angord = angord + header_fix%iversion= iversion + header_fix%inewpc = inewpc + header_fix%isens = isens + + if (loutall) then + write(6,*)'READ_RADIAG_HEADER: isis=',header_fix%isis,& + ' nchan=',header_fix%nchan,& + ' npred=',header_fix%npred,& + ' angord=',header_fix%angord,& + ' idiag=',header_fix%idiag,& + ' iversion=',header_fix%iversion,& + ' inewpc=',header_fix%inewpc,& + ' isens=',header_fix%isens,& + ' ijacob=',header_fix%ijacob + + if ( header_fix%iextra /= 0) & + write(6,*)'READ_RADIAG_HEADER: extra diagnostic information available, ',& + 'iextra=',header_fix%iextra + end if + + if (header_fix%npred /= npred_radiag .and. npred_radiag /= 0) & + write(6,*) 'READ_RADIAG_HEADER: **WARNING** header_fix%npred,npred=',& + header_fix%npred,npred_radiag + +! Allocate and initialize as needed + if (allocated(header_chan)) deallocate(header_chan) + if (allocated(data_name%chn)) deallocate(data_name%chn) + + allocate(header_chan( header_fix%nchan)) + allocate(data_name%chn(header_fix%idiag)) + + data_name%fix(1) ='lat ' + data_name%fix(2) ='lon ' + data_name%fix(3) ='zsges ' + data_name%fix(4) ='obstim ' + data_name%fix(5) ='scanpos ' + data_name%fix(6) ='satzen ' + data_name%fix(7) ='satazm ' + data_name%fix(8) ='solzen ' + data_name%fix(9) ='solazm ' + data_name%fix(10)='sungln ' + data_name%fix(11)='fwater ' + data_name%fix(12)='fland ' + data_name%fix(13)='fice ' + data_name%fix(14)='fsnow ' + data_name%fix(15)='twater ' + data_name%fix(16)='tland ' + data_name%fix(17)='tice ' + data_name%fix(18)='tsnow ' + data_name%fix(19)='tsoil ' + data_name%fix(20)='soilmoi ' + data_name%fix(21)='landtyp ' + data_name%fix(22)='vegfrac ' + data_name%fix(23)='snowdep ' + data_name%fix(24)='wndspd ' + data_name%fix(25)='qc1 ' + data_name%fix(26)='qc2 ' + data_name%fix(27)='tref ' + data_name%fix(28)='dtw ' + data_name%fix(29)='dtc ' + data_name%fix(30)='tz_tr ' + + data_name%chn(1)='obs ' + data_name%chn(2)='omgbc ' + data_name%chn(3)='omgnbc ' + data_name%chn(4)='errinv ' + data_name%chn(5)='qcmark ' + data_name%chn(6)='emiss ' + data_name%chn(7)='tlap ' + data_name%chn(8)='tb_tz ' + + if (header_fix%iversion < iversion_radiag_1) then + data_name%chn( 8)= 'bifix ' + data_name%chn( 9)= 'bilap ' + data_name%chn(10)= 'bilap2 ' + data_name%chn(11)= 'bicons ' + data_name%chn(12)= 'biang ' + data_name%chn(13)= 'biclw ' + if (retrieval) data_name%chn(13)= 'bisst ' + elseif ( header_fix%iversion < iversion_radiag_2 .and. header_fix%iversion >= iversion_radiag_1 ) then + data_name%chn( 8)= 'bicons ' + data_name%chn( 9)= 'biang ' + data_name%chn(10)= 'biclw ' + data_name%chn(11)= 'bilap2 ' + data_name%chn(12)= 'bilap ' + do i=1,header_fix%angord + write(string,'(i2.2)') header_fix%angord-i+1 + data_name%chn(12+i)= 'bifix' // string + end do + data_name%chn(12+header_fix%angord+1)= 'bifix ' + data_name%chn(12+header_fix%angord+2)= 'bisst ' + elseif ( header_fix%iversion < iversion_radiag_3 .and. header_fix%iversion >= iversion_radiag_2 ) then + data_name%chn( 9)= 'bicons ' + data_name%chn(10)= 'biang ' + data_name%chn(11)= 'biclw ' + data_name%chn(12)= 'bilap2 ' + data_name%chn(13)= 'bilap ' + do i=1,header_fix%angord + write(string,'(i2.2)') header_fix%angord-i+1 + data_name%chn(13+i)= 'bifix' // string + end do + data_name%chn(13+header_fix%angord+1)= 'bifix ' + data_name%chn(13+header_fix%angord+2)= 'bisst ' + elseif ( header_fix%iversion < iversion_radiag_4 .and. header_fix%iversion >= iversion_radiag_3 ) then + data_name%chn( 9)= 'bicons ' + data_name%chn(10)= 'biang ' + data_name%chn(11)= 'biclw ' + data_name%chn(12)= 'bilap2 ' + data_name%chn(13)= 'bilap ' + data_name%chn(14)= 'bicos ' + data_name%chn(15)= 'bisin ' + do i=1,header_fix%angord + write(string,'(i2.2)') header_fix%angord-i+1 + data_name%chn(15+i)= 'bifix' // string + end do + data_name%chn(15+header_fix%angord+1)= 'bifix ' + data_name%chn(15+header_fix%angord+2)= 'bisst ' + else + data_name%chn( 9)= 'bicons ' + data_name%chn(10)= 'biang ' + data_name%chn(11)= 'biclw ' + data_name%chn(12)= 'bilap2 ' + data_name%chn(13)= 'bilap ' + data_name%chn(14)= 'bicos ' + data_name%chn(15)= 'bisin ' + data_name%chn(16)= 'biemis ' + do i=1,header_fix%angord + write(string,'(i2.2)') header_fix%angord-i+1 + data_name%chn(16+i)= 'bifix' // string + end do + data_name%chn(16+header_fix%angord+1)= 'bifix ' + data_name%chn(16+header_fix%angord+2)= 'bisst ' + endif + +! Read header (channel part) + do ich=1, header_fix%nchan + read(ftin,IOSTAT=iflag) freq_tmp,polar_tmp,wave_tmp,varch_tmp,tlapmean_tmp,iuse_tmp,nuchan_tmp,iochan_tmp + header_chan(ich)%freq = freq_tmp + header_chan(ich)%polar = polar_tmp + header_chan(ich)%wave = wave_tmp + header_chan(ich)%varch = varch_tmp + header_chan(ich)%tlapmean = tlapmean_tmp + header_chan(ich)%iuse = iuse_tmp + header_chan(ich)%nuchan = nuchan_tmp + header_chan(ich)%iochan = iochan_tmp + if (iflag/=0) return + end do + +! Construct array containing menonics for data record entries + + +end subroutine read_radiag_header_bin + +integer(i_kind) function find_ncdiag_id(ftin) + integer(i_kind), intent(in) :: ftin + + integer(i_kind) :: i + + find_ncdiag_id = -1 + do i = 1, MAX_OPEN_NCDIAG + if (ncdiag_open_id(i) == ftin) then + find_ncdiag_id = i + return + endif + enddo + return + +end function find_ncdiag_id + +subroutine read_radiag_data(ftin,header_fix,retrieval,data_fix,data_chan,data_extra,iflag ) +! . . . . +! subprogram: read_radiag_dat read rad diag data +! prgmmr: tahara org: np20 date: 2003-01-01 +! +! abstract: This routine reads the data record from a radiance +! diagnostic file +! +! program history log: +! 2010-10-05 treadon - add this doc block +! 2011-02-22 kleist - changes related to memory allocation +! 2017-07-17 mccarty - change routine to be generalized for bin/nc4 files +! +! input argument list: +! ftin - unit number connected to diagnostic file +! header_fix - header information structure +! +! output argument list: +! data_fix - spot header information structure +! data_chan - spot channel information structure +! data_extra - spot extra information +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + type(diag_header_fix_list ),intent(in) :: header_fix + logical,intent(in) :: retrieval + type(diag_data_fix_list) ,intent(out):: data_fix + type(diag_data_chan_list) ,allocatable :: data_chan(:) + type(diag_data_extra_list) ,allocatable :: data_extra(:,:) + integer(i_kind),intent(out) :: iflag + + integer(i_kind) :: id + + if (netcdf) then + + id = find_ncdiag_id(ftin) + if (id < 0) then + write(6,*) 'READ_RADIAG_DATA: ***ERROR*** netcdf diag file ', ftin, ' has not been opened yet.' + iflag = -2 + return + endif + + if (.not. ncdiag_open_status(id)%nc_read) then + call read_radiag_data_nc_init(ftin, ncdiag_open_status(id), header_fix, retrieval, iflag) + endif + + if (iflag /= 0) then + return + endif + + if (ncdiag_open_status(id)%cur_ob_idx == ncdiag_open_status(id)%num_records ) then + iflag = 0 + else if (ncdiag_open_status(id)%cur_ob_idx > ncdiag_open_status(id)%num_records) then + iflag = -1 + else + iflag = 1 + endif + + if (iflag >= 0) then + call read_radiag_data_nc(ncdiag_open_status(id),header_fix,data_fix,data_chan,data_extra,iflag) + endif + + else + call read_radiag_data_bin(ftin,header_fix,retrieval,data_fix,data_chan,data_extra,iflag ) + endif + +end subroutine read_radiag_data + +subroutine read_radiag_data_nc_init(ftin, diag_status, header_fix, retrieval, iflag) +! . . . . +! subprogram: read_radiag_data_nc_init read rad diag data +! prgmmr: mccarty org: np20 date: 2015-08-10 +! +! abstract: This routine reads the data record from a netcdf radiance +! diagnostic file +! +! program history log: +! 2015-06-10 mccarty - create routine +! +! input argument list: +! ftin - unit number connected to diagnostic file +! header_fix - header information structure +! +! output argument list: +! data_fix - spot header information structure +! data_chan - spot channel information structure +! data_extra - spot extra information +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + type(ncdiag_status), intent(inout) :: diag_status + type(diag_header_fix_list ),intent(in) :: header_fix + logical,intent(in) :: retrieval + integer(i_kind),intent(out) :: iflag + +! Declare local variables + integer(i_kind) :: nrecord, ndatum, nangord + integer(i_kind) :: cch, ic, ir, cdatum, nsdim + real(r_single), allocatable, dimension(:) :: Latitude, Longitude, Elevation, Obs_Time, Scan_Position, & + Sat_Zenith_Angle, Sat_Azimuth_Angle, Sol_Zenith_Angle, Sol_Azimuth_Angle, & + Sun_Glint_Angle, Water_Fraction, Land_Fraction, Ice_Fraction, & + Snow_Fraction, Water_Temperature, Land_Temperature, Ice_Temperature, & + Snow_Temperature, Soil_Temperature, Soil_Moisture, & + tsavg5, sstcu, sstph, sstnv, dta, dqa, dtp_avh, Vegetation_Fraction, & + Snow_Depth, clw_guess_retrieval, Sfc_Wind_Speed, & + Cloud_Frac, CTP, CLW, TPWC, clw_obs, clw_guess, Foundation_Temperature, SST_Warm_layer_dt, & + SST_Cool_layer_tdrop, SST_dTz_dTfound, Observation, Obs_Minus_Forecast_adjusted, & + Obs_Minus_Forecast_unadjusted, Inverse_Observation_Error, QC_Flag, Emissivity, & + Weighted_Lapse_Rate, dTb_dTs, BC_Constant, BC_Scan_Angle, & + BC_Cloud_Liquid_Water, BC_Lapse_Rate_Squared, BC_Lapse_Rate, BC_Cosine_Latitude_times_Node, & + BC_Sine_Latitude,BC_Emissivity,BC_Fixed_Scan_Position, Press_Max_Weight_Function + integer(i_kind), allocatable, dimension(:) :: Channel_Index, Land_Type_Index + real(r_single), allocatable, dimension(:,:) :: BC_angord ! (nobs, BC_angord_arr_dim) ; + real(r_single), allocatable, dimension(:,:) :: Observation_Operator_Jacobian + + real(r_kind) :: clat, clon + + ndatum = nc_diag_read_get_dim(ftin,'nobs') + if (ndatum <= 0) then + iflag = -3 + return + endif + + if (header_fix%angord > 0) then + nangord = nc_diag_read_get_dim(ftin,'BC_angord_arr_dim') + end if + + nrecord = ndatum / header_fix%nchan + diag_status%num_records = nrecord + + allocate( Channel_Index(ndatum), & + Latitude(ndatum), Longitude(ndatum), Elevation(ndatum), & + Obs_Time(ndatum), Scan_Position(ndatum), Sat_Zenith_Angle(ndatum), & + Sat_Azimuth_Angle(ndatum), Sol_Zenith_Angle(ndatum), Sol_Azimuth_Angle(ndatum), & + Sun_Glint_Angle(ndatum), Water_Fraction(ndatum), Land_Fraction(ndatum), & + Ice_Fraction(ndatum), Snow_Fraction(ndatum), Water_Temperature(ndatum), & + Land_Temperature(ndatum), Ice_Temperature(ndatum), Snow_Temperature(ndatum), & + Soil_Temperature(ndatum), Soil_Moisture(ndatum), tsavg5(ndatum), & + sstcu(ndatum), sstph(ndatum), sstnv(ndatum), & + dta(ndatum), dqa(ndatum), dtp_avh(ndatum), & + Vegetation_Fraction(ndatum), Snow_Depth(ndatum), & + clw_guess_retrieval(ndatum), Sfc_Wind_Speed(ndatum), Cloud_Frac(ndatum), & + CTP(ndatum), CLW(ndatum), TPWC(ndatum), & + clw_obs(ndatum), clw_guess(ndatum), Foundation_Temperature(ndatum), & + SST_Warm_layer_dt(ndatum), SST_Cool_layer_tdrop(ndatum), SST_dTz_dTfound(ndatum), & + Observation(ndatum), Obs_Minus_Forecast_adjusted(ndatum),Obs_Minus_Forecast_unadjusted(ndatum), & + Inverse_Observation_Error(ndatum),QC_Flag(ndatum), Emissivity(ndatum), & + Weighted_Lapse_Rate(ndatum), dTb_dTs(ndatum), BC_Constant(ndatum), & + BC_Scan_Angle(ndatum), BC_Cloud_Liquid_Water(ndatum), BC_Lapse_Rate_Squared(ndatum), & + BC_Lapse_Rate(ndatum), BC_Cosine_Latitude_times_Node(ndatum), BC_Sine_Latitude(ndatum), & + BC_Emissivity(ndatum), BC_Fixed_Scan_Position(ndatum), Land_Type_Index(ndatum) ) + + if (header_fix%iextra > 0) then + allocate(Press_Max_Weight_Function(ndatum)) + endif + if (header_fix%angord > 0) then + allocate( BC_angord(nangord, ndatum) ) + end if + if (header_fix%ijacob > 0) then + call nc_diag_read_get_global_attr(ftin, "Number_of_state_vars", nsdim) + allocate(Observation_Operator_Jacobian(nsdim, ndatum)) + endif + + if (allocated(diag_status%all_data_fix)) deallocate(diag_status%all_data_fix) + if (allocated(diag_status%all_data_chan)) deallocate(diag_status%all_data_chan) + if (allocated(diag_status%all_data_extra)) deallocate(diag_status%all_data_extra) + allocate( diag_status%all_data_fix(nrecord) ) + allocate( diag_status%all_data_chan(nrecord, header_fix%nchan)) + allocate( diag_status%all_data_extra(nrecord, header_fix%iextra, header_fix%jextra) ) + + call nc_diag_read_get_var(ftin, 'Channel_Index', Channel_Index) + call nc_diag_read_get_var(ftin, 'Latitude', Latitude) + call nc_diag_read_get_var(ftin, 'Longitude', Longitude) + call nc_diag_read_get_var(ftin, 'Elevation', Elevation) + call nc_diag_read_get_var(ftin, 'Obs_Time', Obs_Time) + call nc_diag_read_get_var(ftin, 'Scan_Position', Scan_Position) + call nc_diag_read_get_var(ftin, 'Sat_Zenith_Angle', Sat_Zenith_Angle) + call nc_diag_read_get_var(ftin, 'Sat_Azimuth_Angle', Sat_Azimuth_Angle) + call nc_diag_read_get_var(ftin, 'Sol_Zenith_Angle', Sol_Zenith_Angle) + call nc_diag_read_get_var(ftin, 'Sol_Azimuth_Angle', Sol_Azimuth_Angle) + call nc_diag_read_get_var(ftin, 'Sun_Glint_Angle', Sun_Glint_Angle) + call nc_diag_read_get_var(ftin, 'Water_Fraction', Water_Fraction) + call nc_diag_read_get_var(ftin, 'Land_Fraction', Land_Fraction) + call nc_diag_read_get_var(ftin, 'Ice_Fraction', Ice_Fraction) + call nc_diag_read_get_var(ftin, 'Snow_Fraction', Snow_Fraction) + call nc_diag_read_get_var(ftin, 'Water_Temperature', Water_Temperature) + call nc_diag_read_get_var(ftin, 'Land_Temperature', Land_Temperature) + call nc_diag_read_get_var(ftin, 'Ice_Temperature', Ice_Temperature) + call nc_diag_read_get_var(ftin, 'Snow_Temperature', Snow_Temperature) + call nc_diag_read_get_var(ftin, 'Soil_Temperature', Soil_Temperature) + call nc_diag_read_get_var(ftin, 'Soil_Moisture', Soil_Moisture) + call nc_diag_read_get_var(ftin, 'tsavg5', tsavg5) + call nc_diag_read_get_var(ftin, 'sstcu', sstcu) + call nc_diag_read_get_var(ftin, 'sstph', sstph) + call nc_diag_read_get_var(ftin, 'sstnv', sstnv) + call nc_diag_read_get_var(ftin, 'dta', dta) + call nc_diag_read_get_var(ftin, 'dqa', dqa) + call nc_diag_read_get_var(ftin, 'dtp_avh', dtp_avh) + call nc_diag_read_get_var(ftin, 'Vegetation_Fraction', Vegetation_Fraction) + call nc_diag_read_get_var(ftin, 'Snow_Depth', Snow_Depth) + call nc_diag_read_get_var(ftin, 'clw_guess_retrieval', clw_guess_retrieval) + call nc_diag_read_get_var(ftin, 'Sfc_Wind_Speed', Sfc_Wind_Speed) + call nc_diag_read_get_var(ftin, 'Cloud_Frac', Cloud_Frac) + call nc_diag_read_get_var(ftin,'CTP', CTP) + call nc_diag_read_get_var(ftin, 'CLW', CLW) + call nc_diag_read_get_var(ftin, 'TPWC', TPWC) + call nc_diag_read_get_var(ftin, 'clw_obs', clw_obs) + call nc_diag_read_get_var(ftin, 'clw_guess', clw_guess) + call nc_diag_read_get_var(ftin, 'Foundation_Temperature', Foundation_Temperature) + call nc_diag_read_get_var(ftin, 'SST_Warm_layer_dt', SST_Warm_layer_dt) + call nc_diag_read_get_var(ftin, 'SST_Cool_layer_tdrop', SST_Cool_layer_tdrop) + call nc_diag_read_get_var(ftin, 'SST_dTz_dTfound', SST_dTz_dTfound) + call nc_diag_read_get_var(ftin, 'Observation', Observation) + call nc_diag_read_get_var(ftin, 'Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted) + call nc_diag_read_get_var(ftin, 'Obs_Minus_Forecast_unadjusted', Obs_Minus_Forecast_unadjusted) + call nc_diag_read_get_var(ftin, 'Inverse_Observation_Error', Inverse_Observation_Error) + call nc_diag_read_get_var(ftin, 'QC_Flag', QC_Flag) + call nc_diag_read_get_var(ftin, 'Emissivity', Emissivity) + call nc_diag_read_get_var(ftin, 'Weighted_Lapse_Rate', Weighted_Lapse_Rate) + call nc_diag_read_get_var(ftin, 'dTb_dTs', dTb_dTs) + call nc_diag_read_get_var(ftin, 'BC_Constant', BC_Constant) + call nc_diag_read_get_var(ftin, 'BC_Scan_Angle', BC_Scan_Angle) + call nc_diag_read_get_var(ftin, 'BC_Cloud_Liquid_Water', BC_Cloud_Liquid_Water) + call nc_diag_read_get_var(ftin, 'BC_Lapse_Rate_Squared', BC_Lapse_Rate_Squared) + call nc_diag_read_get_var(ftin, 'BC_Lapse_Rate', BC_Lapse_Rate) + call nc_diag_read_get_var(ftin, 'BC_Cosine_Latitude_times_Node', BC_Cosine_Latitude_times_Node) + call nc_diag_read_get_var(ftin, 'BC_Sine_Latitude', BC_Sine_Latitude) + call nc_diag_read_get_var(ftin, 'BC_Emissivity', BC_Emissivity) + call nc_diag_read_get_var(ftin, 'BC_Fixed_Scan_Position', BC_Fixed_Scan_Position) + call nc_diag_read_get_var(ftin, 'Land_Type_Index', Land_Type_Index) + if (header_fix%iextra > 0) then + call nc_diag_read_get_var(ftin, 'Press_Max_Weight_Function', Press_Max_Weight_Function) + endif + if (header_fix%angord > 0) then + call nc_diag_read_get_var(ftin, 'BC_angord ', BC_angord ) + end if + if (header_fix%ijacob > 0) then + call nc_diag_read_get_var(ftin, 'Observation_Operator_Jacobian', Observation_Operator_Jacobian) + endif + cdatum = 1 + +! allocate( all_data_fix(nrecord) ) +! allocate( all_data_chan(nrecord, nchan)) + + + do ir=1,nrecord + clat = Latitude(cdatum) + clon = Longitude(cdatum) + diag_status%all_data_fix(ir)%lat = Latitude(cdatum) + diag_status%all_data_fix(ir)%lon = Longitude(cdatum) + diag_status%all_data_fix(ir)%zsges = Elevation(cdatum) + diag_status%all_data_fix(ir)%obstime = Obs_Time(cdatum) + diag_status%all_data_fix(ir)%senscn_pos = Scan_Position(cdatum) + diag_status%all_data_fix(ir)%satzen_ang = Sat_Zenith_Angle(cdatum) + diag_status%all_data_fix(ir)%satazm_ang = Sat_Azimuth_Angle(cdatum) + diag_status%all_data_fix(ir)%solzen_ang = Sol_Zenith_Angle(cdatum) + diag_status%all_data_fix(ir)%solazm_ang = Sol_Azimuth_Angle(cdatum) + diag_status%all_data_fix(ir)%sungln_ang = Sun_Glint_Angle(cdatum) + diag_status%all_data_fix(ir)%water_frac = Water_Fraction(cdatum) + diag_status%all_data_fix(ir)%land_frac = Land_Fraction(cdatum) + diag_status%all_data_fix(ir)%ice_frac = Ice_Fraction(cdatum) + diag_status%all_data_fix(ir)%snow_frac = Snow_Fraction(cdatum) + diag_status%all_data_fix(ir)%water_temp = Water_Temperature(cdatum) + diag_status%all_data_fix(ir)%land_temp = Land_Temperature(cdatum) + diag_status%all_data_fix(ir)%ice_temp = Ice_Temperature(cdatum) + diag_status%all_data_fix(ir)%snow_temp = Snow_Temperature(cdatum) + diag_status%all_data_fix(ir)%soil_temp = Soil_Temperature(cdatum) + diag_status%all_data_fix(ir)%soil_mois = Soil_Moisture(cdatum) + diag_status%all_data_fix(ir)%land_type = Land_Type_Index(cdatum) + diag_status%all_data_fix(ir)%veg_frac = Vegetation_Fraction(cdatum) + diag_status%all_data_fix(ir)%snow_depth = Snow_Depth(cdatum) + diag_status%all_data_fix(ir)%sfc_wndspd = Sfc_Wind_Speed(cdatum) + diag_status%all_data_fix(ir)%qcdiag1 = Cloud_Frac(cdatum) + diag_status%all_data_fix(ir)%qcdiag2 = CTP(cdatum) + diag_status%all_data_fix(ir)%tref = Foundation_Temperature(cdatum) + diag_status%all_data_fix(ir)%dtw = SST_Warm_layer_dt(cdatum) + diag_status%all_data_fix(ir)%dtc = SST_Cool_layer_tdrop(cdatum) + diag_status%all_data_fix(ir)%tz_tr = SST_dTz_dTfound(cdatum) + + if (retrieval) then + diag_status%all_data_fix(ir)%water_temp = tsavg5(cdatum) + diag_status%all_data_fix(ir)%land_temp = sstcu(cdatum) + diag_status%all_data_fix(ir)%ice_temp = sstph(cdatum) + diag_status%all_data_fix(ir)%snow_temp = sstnv(cdatum) + diag_status%all_data_fix(ir)%soil_temp = dta(cdatum) + diag_status%all_data_fix(ir)%soil_mois = dqa(cdatum) + diag_status%all_data_fix(ir)%land_type = dtp_avh(cdatum) + endif + + do ic=1,header_fix%nchan + if (clat /= Latitude(cdatum) .or. clon /= Longitude(cdatum)) then + write(*,*) 'ERROR: Lats & Lons are mismatched. This is bad' + print *,'irecord=',ir + print *,'clat,clon=',clat,clon + print *,'lat/lon(datum)=',Latitude(cdatum), Longitude(cdatum) + call abort + endif + cch = Channel_Index(cdatum) + if (allocated(diag_status%all_data_chan(ir,cch)%bifix)) deallocate(diag_status%all_data_chan(ir,cch)%bifix ) + if (header_fix%angord > 0) then + allocate(diag_status%all_data_chan(ir,cch)%bifix(nangord)) + else + allocate(diag_status%all_data_chan(ir,cch)%bifix(1)) + end if + + diag_status%all_data_chan(ir,cch)%tbobs = Observation(cdatum) + diag_status%all_data_chan(ir,cch)%omgbc = Obs_Minus_Forecast_adjusted(cdatum) + diag_status%all_data_chan(ir,cch)%omgnbc= Obs_Minus_Forecast_unadjusted(cdatum) + diag_status%all_data_chan(ir,cch)%errinv= Inverse_Observation_Error(cdatum) + diag_status%all_data_chan(ir,cch)%qcmark= QC_Flag(cdatum) + diag_status%all_data_chan(ir,cch)%emiss = Emissivity(cdatum) + diag_status%all_data_chan(ir,cch)%tlap = Weighted_Lapse_Rate(cdatum) + diag_status%all_data_chan(ir,cch)%tb_tz = dTb_dTs(cdatum) + diag_status%all_data_chan(ir,cch)%bicons= BC_Constant(cdatum) + diag_status%all_data_chan(ir,cch)%biang = BC_Scan_Angle(cdatum) + diag_status%all_data_chan(ir,cch)%biclw = BC_Cloud_Liquid_Water(cdatum) + diag_status%all_data_chan(ir,cch)%bilap2= BC_Lapse_Rate_Squared(cdatum) + diag_status%all_data_chan(ir,cch)%bilap = BC_Lapse_Rate(cdatum) + diag_status%all_data_chan(ir,cch)%bicos = BC_Cosine_Latitude_times_Node(cdatum) + diag_status%all_data_chan(ir,cch)%bisin = BC_Sine_Latitude(cdatum) + diag_status%all_data_chan(ir,cch)%biemis= BC_Emissivity(cdatum) + if (header_fix%angord > 0) then + diag_status%all_data_chan(ir,cch)%bifix = BC_angord(1:nangord,cdatum) + else + diag_status%all_data_chan(ir,cch)%bifix(1) = BC_Fixed_Scan_Position(cdatum) + endif + if (header_fix%ijacob > 0) then + diag_status%all_data_chan(ir,cch)%dhx_dx = Observation_Operator_Jacobian(1:nsdim,cdatum) + endif + ! placeholder for SST BC + if (header_fix%iextra > 0) then + diag_status%all_data_extra(ir,1,cch)%extra = Press_Max_Weight_Function(cdatum) + endif + cdatum = cdatum + 1 + enddo + enddo + + diag_status%nc_read = .true. + diag_status%cur_ob_idx = 1 + + + deallocate(Channel_Index, Latitude, Longitude, Elevation, Obs_Time, Scan_Position, & + Sat_Zenith_Angle, Sat_Azimuth_Angle, Sol_Zenith_Angle, Sol_Azimuth_Angle, & + Sun_Glint_Angle, Water_Fraction, Land_Fraction, Ice_Fraction, & + Snow_Fraction, Water_Temperature, Land_Temperature, Ice_Temperature, & + Snow_Temperature, Soil_Temperature, Soil_Moisture, tsavg5, sstcu, sstph, & + sstnv, dta, dqa, dtp_avh, Vegetation_Fraction, Snow_Depth, & + clw_guess_retrieval, Sfc_Wind_Speed, Cloud_Frac, CTP, CLW, TPWC, clw_obs, & + clw_guess, Foundation_Temperature, SST_Warm_layer_dt, SST_Cool_layer_tdrop, & + SST_dTz_dTfound, Observation, Obs_Minus_Forecast_adjusted, & + Obs_Minus_Forecast_unadjusted, Inverse_Observation_Error, QC_Flag, & + Emissivity, Weighted_Lapse_Rate, dTb_dTs, BC_Constant, BC_Scan_Angle, & + BC_Cloud_Liquid_Water, BC_Lapse_Rate_Squared, BC_Lapse_Rate, & + BC_Cosine_Latitude_times_Node, BC_Sine_Latitude, BC_Emissivity, & + BC_Fixed_Scan_Position, Land_Type_Index) + + if (header_fix%iextra > 0) then + deallocate(Press_Max_Weight_Function) + endif + if (header_fix%angord > 0) then + deallocate(BC_angord) + end if + if (header_fix%ijacob > 0) then + deallocate(Observation_Operator_Jacobian) + endif + + +end subroutine read_radiag_data_nc_init + +subroutine read_radiag_data_nc(diag_status,header_fix,data_fix,data_chan,data_extra,iflag ) +! . . . . +! subprogram: read_radiag_dat read rad diag data +! prgmmr: tahara org: np20 date: 2015-08-10 +! +! abstract: This routine reads the data record from a netcdf radiance +! diagnostic file +! +! program history log: +! 2015-08-10 mccarty - create routine +! +! input argument list: +! header_fix - header information structure +! +! output argument list: +! data_fix - spot header information structure +! data_chan - spot channel information structure +! data_extra - spot extra information +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! Declare passed arguments + type(ncdiag_status), intent(inout) :: diag_status + type(diag_header_fix_list ),intent(in) :: header_fix + type(diag_data_fix_list) ,intent(out):: data_fix + type(diag_data_chan_list) ,allocatable :: data_chan(:) + type(diag_data_extra_list) ,allocatable :: data_extra(:,:) + integer(i_kind),intent(out) :: iflag + + iflag = 0 + if (.not. allocated(data_chan)) allocate(data_chan(header_fix%nchan) ) + if (.not. allocated(data_extra)) allocate(data_extra(header_fix%iextra, header_fix%nchan) ) + + data_fix = diag_status%all_data_fix(diag_status%cur_ob_idx) + data_chan(:) = diag_status%all_data_chan(diag_status%cur_ob_idx,:) + data_extra(:,:) = diag_status%all_data_extra(diag_status%cur_ob_idx,:,:) + + diag_status%cur_ob_idx = diag_status%cur_ob_idx + 1 + +end subroutine read_radiag_data_nc + +subroutine read_radiag_data_bin(ftin,header_fix,retrieval,data_fix,data_chan,data_extra,iflag ) +! . . . . +! subprogram: read_radiag_dat read rad diag data +! prgmmr: tahara org: np20 date: 2003-01-01 +! +! abstract: This routine reads the data record from a radiance +! diagnostic file +! +! program history log: +! 2010-10-05 treadon - add this doc block +! 2011-02-22 kleist - changes related to memory allocation +! 2017-07-17 mccarty - rename binary-specific procedure +! +! input argument list: +! ftin - unit number connected to diagnostic file +! header_fix - header information structure +! +! output argument list: +! data_fix - spot header information structure +! data_chan - spot channel information structure +! data_extra - spot extra information +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + type(diag_header_fix_list ),intent(in) :: header_fix + logical,intent(in) :: retrieval + type(diag_data_fix_list) ,intent(out):: data_fix + type(diag_data_chan_list) ,allocatable :: data_chan(:) + type(diag_data_extra_list) ,allocatable :: data_extra(:,:) + integer(i_kind),intent(out) :: iflag + + integer(i_kind) :: ich,iang,i,j + real(r_single),dimension(:,:),allocatable :: data_tmp + real(r_single),dimension(:),allocatable :: fix_tmp + real(r_single),dimension(:,:),allocatable :: extra_tmp + + type(sparr2) :: dhx_dx + +! Allocate arrays as needed + if (allocated(data_chan)) deallocate(data_chan) + allocate(data_chan(header_fix%nchan)) + + do ich=1,header_fix%nchan + if (allocated(data_chan(ich)%bifix)) deallocate(data_chan(ich)%bifix) + allocate(data_chan(ich)%bifix(header_fix%angord+1)) + end do + + if (header_fix%iextra > 0) then + if (allocated(data_extra)) deallocate(data_extra) + allocate(data_extra(header_fix%iextra,header_fix%jextra)) + allocate(extra_tmp(header_fix%iextra,header_fix%jextra)) + end if + +! Allocate arrays to hold data record + allocate(data_tmp(header_fix%idiag,header_fix%nchan)) + + if (header_fix%iversion < iversion_radiag_2) then + allocate( fix_tmp( ireal_old_radiag ) ) + else + allocate( fix_tmp( ireal_radiag ) ) + end if + +! Read data record + + if (header_fix%iextra == 0) then + read(ftin,IOSTAT=iflag) fix_tmp, data_tmp + else + read(ftin,IOSTAT=iflag) fix_tmp, data_tmp, extra_tmp + endif + + if (iflag /= 0) return + +! Transfer fix_tmp record to output structure + data_fix%lat = fix_tmp(1) + data_fix%lon = fix_tmp(2) + data_fix%zsges = fix_tmp(3) + data_fix%obstime = fix_tmp(4) + data_fix%senscn_pos = fix_tmp(5) + data_fix%satzen_ang = fix_tmp(6) + data_fix%satazm_ang = fix_tmp(7) + data_fix%solzen_ang = fix_tmp(8) + data_fix%solazm_ang = fix_tmp(9) + data_fix%sungln_ang = fix_tmp(10) + data_fix%water_frac = fix_tmp(11) + data_fix%land_frac = fix_tmp(12) + data_fix%ice_frac = fix_tmp(13) + data_fix%snow_frac = fix_tmp(14) + data_fix%water_temp = fix_tmp(15) + data_fix%land_temp = fix_tmp(16) + data_fix%ice_temp = fix_tmp(17) + data_fix%snow_temp = fix_tmp(18) + data_fix%soil_temp = fix_tmp(19) + data_fix%soil_mois = fix_tmp(20) + data_fix%land_type = fix_tmp(21) + data_fix%veg_frac = fix_tmp(22) + data_fix%snow_depth = fix_tmp(23) + data_fix%sfc_wndspd = fix_tmp(24) + data_fix%qcdiag1 = fix_tmp(25) + data_fix%qcdiag2 = fix_tmp(26) + + if ( header_fix%iversion <= iversion_radiag_1 ) then + data_fix%tref = rmiss_radiag + data_fix%dtw = rmiss_radiag + data_fix%dtc = rmiss_radiag + data_fix%tz_tr = rmiss_radiag + else + data_fix%tref = fix_tmp(27) + data_fix%dtw = fix_tmp(28) + data_fix%dtc = fix_tmp(29) + data_fix%tz_tr = fix_tmp(30) + end if + + +! Transfer data record to output structure + do ich=1,header_fix%nchan + data_chan(ich)%tbobs =data_tmp(1,ich) + data_chan(ich)%omgbc =data_tmp(2,ich) + data_chan(ich)%omgnbc=data_tmp(3,ich) + data_chan(ich)%errinv=data_tmp(4,ich) + data_chan(ich)%qcmark=data_tmp(5,ich) + data_chan(ich)%emiss =data_tmp(6,ich) + data_chan(ich)%tlap =data_tmp(7,ich) + data_chan(ich)%tb_tz =data_tmp(8,ich) + end do + if (header_fix%iversion < iversion_radiag_1) then + do ich=1,header_fix%nchan + data_chan(ich)%bifix(1)=data_tmp(8,ich) + data_chan(ich)%bilap =data_tmp(9,ich) + data_chan(ich)%bilap2 =data_tmp(10,ich) + data_chan(ich)%bicons =data_tmp(11,ich) + data_chan(ich)%biang =data_tmp(12,ich) + data_chan(ich)%biclw =data_tmp(13,ich) + data_chan(ich)%bisst = rmiss_radiag + if (retrieval) then + data_chan(ich)%biclw =rmiss_radiag + data_chan(ich)%bisst =data_tmp(13,ich) + endif + end do + elseif ( header_fix%iversion < iversion_radiag_2 .and. header_fix%iversion >= iversion_radiag_1 ) then + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(8,ich) + data_chan(ich)%biang =data_tmp(9,ich) + data_chan(ich)%biclw =data_tmp(10,ich) + data_chan(ich)%bilap2=data_tmp(11,ich) + data_chan(ich)%bilap =data_tmp(12,ich) + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(12+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(12+header_fix%angord+2,ich) + end do + elseif ( header_fix%iversion < iversion_radiag_3 .and. header_fix%iversion >= iversion_radiag_2 ) then + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(9,ich) + data_chan(ich)%biang =data_tmp(10,ich) + data_chan(ich)%biclw =data_tmp(11,ich) + data_chan(ich)%bilap2=data_tmp(12,ich) + data_chan(ich)%bilap =data_tmp(13,ich) + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(13+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(13+header_fix%angord+2,ich) + end do + elseif ( header_fix%iversion < iversion_radiag_4 .and. header_fix%iversion >= iversion_radiag_3 ) then + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(9,ich) + data_chan(ich)%biang =data_tmp(10,ich) + data_chan(ich)%biclw =data_tmp(11,ich) + data_chan(ich)%bilap2=data_tmp(12,ich) + data_chan(ich)%bilap =data_tmp(13,ich) + data_chan(ich)%bicos =data_tmp(14,ich) ! 1st bias correction term node*cos(lat) for SSMIS + data_chan(ich)%bisin =data_tmp(15,ich) ! 2nd bias correction term sin(lat) for SSMI + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(15+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(15+header_fix%angord+2,ich) + end do + elseif ( header_fix%iversion < iversion_radiag_5 .and. header_fix%iversion >= iversion_radiag_4 ) then + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(9,ich) + data_chan(ich)%biang =data_tmp(10,ich) + data_chan(ich)%biclw =data_tmp(11,ich) + data_chan(ich)%bilap2=data_tmp(12,ich) + data_chan(ich)%bilap =data_tmp(13,ich) + data_chan(ich)%bicos =data_tmp(14,ich) + data_chan(ich)%bisin =data_tmp(15,ich) + data_chan(ich)%biemis=data_tmp(16,ich) + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(16+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(16+header_fix%angord+2,ich) + end do + else + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(9,ich) + data_chan(ich)%biang =data_tmp(10,ich) + data_chan(ich)%biclw =data_tmp(11,ich) + data_chan(ich)%bilap2=data_tmp(12,ich) + data_chan(ich)%bilap =data_tmp(13,ich) + data_chan(ich)%bicos =data_tmp(14,ich) + data_chan(ich)%bisin =data_tmp(15,ich) + data_chan(ich)%biemis=data_tmp(16,ich) + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(16+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(16+header_fix%angord+2,ich) + data_chan(ich)%sprd = data_tmp(16+header_fix%angord+3,ich) + end do + + do ich=1,header_fix%nchan + if (header_fix%ijacob==1) then + call readarray(dhx_dx, & !data_chan(ich)%dhx_dx, & + data_tmp(16+header_fix%angord+4:header_fix%idiag,ich)) + data_chan(ich)%dhx_dx = dhx_dx + call delete(dhx_dx) + endif + enddo + endif + + if (header_fix%iextra > 0) then + do j=1,header_fix%jextra + do i=1,header_fix%iextra + data_extra(i,j)%extra=extra_tmp(i,j) + end do + end do + endif + + deallocate(data_tmp, fix_tmp) + if (header_fix%iextra > 0) deallocate(extra_tmp) + +end subroutine read_radiag_data_bin + +end module read_diag + diff --git a/src/read_files.f90 b/src/gsi/read_files.f90 similarity index 84% rename from src/read_files.f90 rename to src/gsi/read_files.f90 index 73dee4789..5722ede1a 100644 --- a/src/read_files.f90 +++ b/src/gsi/read_files.f90 @@ -36,6 +36,7 @@ subroutine read_files(mype) ! to access needed sigf and sfcf w/ fcst_hr_sig and *_sfc. ! 2015-02-23 Rancic/Thomas - add l4densvar to time window logical ! 2017-09-08 li - add sfcnst_comb to get nfldnst and control when sfc & nst combined +! 2019-03-21 Wei/Martin - add capability to read in aerosol guess from NEMS ! ! input argument list: ! mype - mpi task id @@ -78,6 +79,7 @@ subroutine read_files(mype) use guess_grids, only: nfldsig,nfldsfc,nfldnst,ntguessig,ntguessfc,ntguesnst,& ifilesig,ifilesfc,ifilenst,hrdifsig,hrdifsfc,hrdifnst,create_gesfinfo use guess_grids, only: hrdifsig_all,hrdifsfc_all,hrdifnst_all + use guess_grids, only: nfldaer, ntguesaer, ifileaer, hrdifaer, hrdifaer_all !for aerosol use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,nhr_assimilation use hybrid_ensemble_parameters, only: ntlevs_ens use gridmod, only: nlat_sfc,nlon_sfc,lpl_gfs,dx_gfs,use_gfs_nemsio,sfcnst_comb @@ -94,6 +96,7 @@ subroutine read_files(mype) use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_getheadvar use read_obsmod, only: gsi_inquire use gsi_io, only: verbose + use chemmod, only: lread_ext_aerosol implicit none @@ -113,7 +116,7 @@ subroutine read_files(mype) character(6) filename integer(i_kind) i,j,iwan,npem1,iret integer(i_kind) nhr_half - integer(i_kind) iamana(3) + integer(i_kind) iamana(4) ! changed to 4 from 3 for aer files integer(i_kind) nminanl,nmings,nming2,ndiff integer(i_kind),dimension(4):: idateg integer(i_kind),dimension(2):: i_ges @@ -129,11 +132,12 @@ subroutine read_files(mype) real(r_kind),allocatable,dimension(:,:):: time_atm real(r_kind),allocatable,dimension(:,:):: time_sfc real(r_kind),allocatable,dimension(:,:):: time_nst + real(r_kind),allocatable,dimension(:,:):: time_aer type(sfcio_head):: sfc_head type(sigio_head):: sigatm_head type(nstio_head):: nst_head - type(nemsio_gfile) :: gfile_atm,gfile_sfc,gfile_nst + type(nemsio_gfile) :: gfile_atm,gfile_sfc,gfile_nst,gfile_aer logical :: print_verbose @@ -151,9 +155,9 @@ subroutine read_files(mype) nfldnst=0 iamana=0 -! Check for non-zero length atm, sfc, and nst files on single task +! Check for non-zero length atm, sfc, aer, and nst files on single task if(mype==npem1)then - allocate( irec(max_file,3) ) + allocate( irec(max_file,4) ) irec=i_missing ! Check for atm files with non-zero length @@ -255,7 +259,7 @@ subroutine read_files(mype) idate5(3)=idateg(3); idate5(4)=idateg(1); idate5(5)=0 call w3fs21(idate5,nmings) nming2=nmings+60*hourg - write(6,*)'READ_FILES: atm guess file',filename,hourg,idateg,nming2 + write(6,*)'READ_FILES: atm guess file ',filename,hourg,idateg,nming2 t4dv=real((nming2-iwinbgn),r_kind)*r60inv if (l4dvar.or.l4densvar) then if (t4dvwinlen) cycle @@ -426,6 +430,58 @@ subroutine read_files(mype) deallocate(nst_ges) endif ! if ( sfcnst_comb ) then endif ! if ( nst_gsi > 0 ) then + +! for external aerosol files only +! Check for consistency of times from aer guess files. + if ( lread_ext_aerosol ) then + iwan=0 + do i=1,nfldaer + write(filename,'(''aerf'',i2.2)')irec(i,4) + write(6,*)'READ_FILES: process ',trim(filename) + if ( .not. use_gfs_nemsio ) then + write(6,*)'READ_FILES: ***ERROR*** aerosol files only work with nemsio' + else + call nemsio_init(iret=iret) + call nemsio_open(gfile_aer,filename,'READ',iret=iret) + idate = i_missing + nfhour = i_missing; nfminute = i_missing + nfsecondn = i_missing; nfsecondd = i_missing + call nemsio_getfilehead(gfile_aer, nfhour=nfhour, nfminute=nfminute, & + nfsecondn=nfsecondn, nfsecondd=nfsecondd, idate=idate ) + call nemsio_close(gfile_aer,iret=iret) + if ( nfhour == i_missing .or. nfminute == i_missing .or. & + nfsecondn == i_missing .or. nfsecondd == i_missing ) then + write(6,*)'READ_FILES: ***ERROR*** some forecast hour info ', & + 'are not defined in ', trim(filename) + write(6,*)'READ_FILES: nfhour, nfminute, nfsecondn, and nfsecondd = ', & + nfhour, nfminute, nfsecondn, nfsecondd + call stop2(80) + endif + hourg4 = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + idateg(1) = idate(4) !hour + idateg(2) = idate(2) !month + idateg(3) = idate(3) !day + idateg(4) = idate(1) !year + endif + hourg = hourg4 + idate5(1)=idateg(4); idate5(2)=idateg(2) + idate5(3)=idateg(3); idate5(4)=idateg(1); idate5(5)=0 + call w3fs21(idate5,nmings) + nming2=nmings+60*hourg + write(6,*)'READ_FILES: aer guess file, hourg, idateg, nming2 ',hourg,idateg,nming2 + t4dv=real((nming2-iwinbgn),r_kind)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle + else + ndiff=nming2-nminanl + if(abs(ndiff) > 60*nhr_half ) cycle + endif + iwan=iwan+1 + if(nminanl==nming2) iamana(4)=iwan + time_aer(iwan,1) = t4dv + time_aer(iwan,2) = irec(i,4)+r0_001 + end do + endif ! if ( lread_ext_aerosol ) then deallocate( irec ) end if @@ -435,6 +491,8 @@ subroutine read_files(mype) print_verbose=.false. if(verbose)print_verbose=.true. if (nst_gsi > 0) call mpi_bcast(nfldnst,1,mpi_itype,npem1,mpi_comm_world,ierror) + if (lread_ext_aerosol) call mpi_bcast(nfldaer,1,mpi_itype,npem1,mpi_comm_world,ierror)! for external aerosol files + if(.not.allocated(time_atm)) allocate(time_atm(nfldsig,2)) if(.not.allocated(time_sfc)) allocate(time_sfc(nfldsfc,2)) @@ -443,6 +501,10 @@ subroutine read_files(mype) if(.not.allocated(time_nst)) allocate(time_nst(nfldnst,2)) if (nst_gsi > 0 ) call mpi_bcast(time_nst,2*nfldnst,mpi_rtype,npem1,mpi_comm_world,ierror) +! for external aerosol files + if(.not.allocated(time_aer)) allocate(time_aer(nfldaer,2)) + if (lread_ext_aerosol) call mpi_bcast(time_aer,2*nfldaer,mpi_rtype,npem1,mpi_comm_world,ierror) + call mpi_bcast(iamana,3,mpi_rtype,npem1,mpi_comm_world,ierror) call mpi_bcast(i_ges,2,mpi_itype,npem1,mpi_comm_world,ierror) nlon_sfc=i_ges(1) @@ -525,6 +587,27 @@ subroutine read_files(mype) deallocate(time_nst) endif +! for external aerosol files +! Load time information for aer guess field info into output arrays + ntguesaer = iamana(4) + if ( lread_ext_aerosol ) then + do i=1,nfldaer + hrdifaer(i) = time_aer(i,1) + ifileaer(i) = nint(time_aer(i,2)) + hrdifaer_all(i) = hrdifaer(i) + end do + if(mype == 0) write(6,*)'READ_FILES: aer fcst files used in analysis: ',& + (ifileaer(i),i=1,nfldaer),(hrdifaer(i),i=1,nfldaer),ntguesaer + if (ntguesaer==0) then + write(6,*)'READ_FILES: ***ERROR*** center aer fcst NOT AVAILABLE: PROGRAM STOPS' + call stop2(99) + endif + if (l4densvar .and. nfldaer/=ntlevs_ens) then + write(6,*)'READ_FILES: ***ERROR*** insufficient aer fcst for 4densvar: PROGRAM STOPS' + call stop2(99) + endif + deallocate(time_aer) + endif ! End of routine return end subroutine read_files diff --git a/src/read_fl_hdob.f90 b/src/gsi/read_fl_hdob.f90 similarity index 99% rename from src/read_fl_hdob.f90 rename to src/gsi/read_fl_hdob.f90 index 50042f540..83c7a82c2 100644 --- a/src/read_fl_hdob.f90 +++ b/src/gsi/read_fl_hdob.f90 @@ -204,7 +204,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si data mststr / 'QMDD TMDP REHU' / data wndstr / 'QMWN WDIR WSPD PKWDSP' / data prsstr / 'PRLC' / - data psfstr / '' / ! *emily: nor in the bufr yet + data psfstr / '' / ! nor in the bufr yet data g10str / 'GP10' / data qcmstr / 'QHDOP QHDOM'/ data lunin / 13 / @@ -971,8 +971,8 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si cdata_all( 2,iout)=dlon ! grid relative longitude cdata_all( 3,iout)=dlat ! grid relative latitude cdata_all( 4,iout)=exp(dlnpsob) ! pressure (in cb) - cdata_all( 5,iout)=zz ! surface height *emily:use model terrian elevation from model surface file - cdata_all( 6,iout)=bmiss ! surface temperature *emily:this is not provided + cdata_all( 5,iout)=zz ! surface height ! use model terrian elevation from model surface file + cdata_all( 6,iout)=bmiss ! surface temperature ! this is not provided cdata_all( 7,iout)=rstation_id ! station id cdata_all( 8,iout)=t4dv ! time cdata_all( 9,iout)=nc ! type @@ -1132,7 +1132,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si cdata_all( 7,iout)=rstation_id ! station id cdata_all( 8,iout)=t4dv ! time cdata_all( 9,iout)=nc ! type - cdata_all(10,iout)=r10 ! elevation of observation *emily:10-m wind + cdata_all(10,iout)=r10 ! elevation of observation ! 10-m wind cdata_all(11,iout)=qcm ! quality mark cdata_all(12,iout)=obserr ! original obs error cdata_all(13,iout)=usage ! usage parameter diff --git a/src/read_gfs_ozone_for_regional.f90 b/src/gsi/read_gfs_ozone_for_regional.f90 similarity index 100% rename from src/read_gfs_ozone_for_regional.f90 rename to src/gsi/read_gfs_ozone_for_regional.f90 diff --git a/src/read_gmi.f90 b/src/gsi/read_gmi.f90 similarity index 87% rename from src/read_gmi.f90 rename to src/gsi/read_gmi.f90 index 01edd3aa2..75b56b0e1 100644 --- a/src/read_gmi.f90 +++ b/src/gsi/read_gmi.f90 @@ -41,8 +41,20 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& ! 2016-07-25 ejones - increase maxobs, remove fov binning, make most arrays ! static ! 2016-03-11 guo - Refixed dlxx_earth_deg, for the new dlxx_earth_save(:). +! 2016-03-22 j.jin - Set a range (0-360 degree) for satellite and Sun azimuth +! angles. ! 2016-10-05 acollard -Fix interaction with NSST. ! 2017-01-03 todling - treat save arrays as allocatable +! 2017-08-03 j.jin - Re-implement the writing out geoinformation for GMI channel 10-13. +! The information is needed for the processing of 1CR data, and +! should not have beend taken out. Note: Use the same +! sun_zenith and sun_azimuth angles for ch10-13 as for ch1-9. +! - Check bufr formats while reading because of different formats +! at GMAO and NOAA. Eventually the research bufr data set will be +! the same at the operational one. +! 2017-08-10 j.jin - Bug fix: crit1 should not have been initialized as zero (when thin4d=True). +! 2017-08-19 j.jin - Keep the binning of ifov by 3 independent of adp_anglebc=True or False. +! 2018-05-21 j.jin - Added time-thinning. ! ! input argument list: ! mype - mpi task id @@ -76,23 +88,25 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& ! within a FOV. When it is equal to one, integrate ! model fields over a FOV. When it is not equal to one, bilinearly ! interpolate model fields at a FOV center.) +! !$$$ end documentation block use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & checkob,finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only: iuse_rad,jpch_rad,nusis,use_edges, & radedge1,radedge2,gmi_method use gridmod, only: diagnostic_reg,regional,rlats,rlons,nlat,nlon,& tll2xy,txy2ll use constants, only: deg2rad,rad2deg,zero,one,two,three,four,r60inv,rearth - use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar,thin4d - use deter_sfc_mod, only: deter_sfc + use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar + use deter_sfc_mod, only: deter_sfc,deter_sfc_gmi use gsi_nstcouplermod, only: nst_gsi,nstinfo use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter use ssmis_spatial_average_mod, only : ssmis_spatial_average use m_sortind use mpimod, only: npe -! use radiance_mod, only: rad_obs_type implicit none @@ -159,7 +173,6 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& real(r_kind) :: sfcr real(r_kind) :: sstime,tdiff real(r_kind) :: dist1 - real(r_kind) :: timedif real(r_kind),allocatable,dimension(:,:):: data_all integer(i_kind),allocatable,dimension(:)::nrec @@ -169,6 +182,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& integer(i_kind),dimension(5):: iobsdate integer(i_kind):: method,iobs,num_obs integer(i_kind),parameter :: maxobs=4000000 + !-- integer(i_kind),parameter :: nscan=74 ! after binning ifov, 221/3 + 1 integer(i_kind),parameter :: nscan=221 real(r_kind):: flgch @@ -194,6 +208,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& integer(i_kind),target,allocatable,dimension(:) :: iscan_save integer(i_kind),target,allocatable,dimension(:) :: iorbn_save integer(i_kind),target,allocatable,dimension(:) :: inode_save + integer(i_kind),target,allocatable,dimension(:) :: it_mesh_save real(r_kind),target,allocatable,dimension(:) :: dlon_earth_save real(r_kind),target,allocatable,dimension(:) :: dlat_earth_save real(r_kind),target,allocatable,dimension(:) :: sat_zen_ang_save,sat_azimuth_ang_save,sat_scan_ang_save @@ -213,11 +228,14 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& 31,31,30,31,30,31/ integer(i_kind) :: pos_max - integer(i_kind),dimension(nscan) :: pos_statis + integer(i_kind),allocatable :: pos_statis(:) integer(i_kind),allocatable :: npos_all(:,:) ! ---- skip some obs at the beginning and end of a scan ---- integer(i_kind):: radedge_min,radedge_max,iscan_pos,iedge_log,j2 + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin + integer(i_kind),pointer:: it_mesh => null() !************************************************************************** @@ -257,7 +275,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& if(jsatid == 'gpm')bufsat=288 ! Satellite ID (WMO as of 03Jun2014) tbmax = 320.0_r_kind ! one value for all tmi channels (see data document). - maxinfo=31 + maxinfo=37 if(dval_use) maxinfo = maxinfo+2 nchanl = 13 ! 13 channls nchanla = 9 ! first 9 channels @@ -292,8 +310,14 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& if (.not.assim) val_gmi=zero + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) inode_save = 0 @@ -302,21 +326,24 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& call openbf(lnbufr,'IN',lnbufr) call datelen(10) -! Extract satellite id from the 1st MG. If it is not the one we want, exit reading. - call readmg(lnbufr, subset, iret, idate) - rd_loop: do while (ireadsb(lnbufr)==0) - - call ufbint(lnbufr,satinfo_v,ninfo,1,iret,satinfo) - if(nint(satinfo_v(1)) /= bufsat) then - write(6,*) 'READ_GMI: Bufr satellie ID SAID', nint(satinfo_v(1)), & - ' does not match ', bufsat - go to 690 - endif - enddo rd_loop +!This block may be needed if used at GMAO, for its gmi data. +!Extract satellite id from the 1st MG. If it is not the one we want, exit reading. + call readmg(lnbufr, subset, iret, idate) + rd_loop: do while (ireadsb(lnbufr)==0) + + call ufbint(lnbufr,satinfo_v,ninfo,1,iret,satinfo) + if(nint(satinfo_v(1)) /= bufsat) then + write(6,*) 'READ_GMI: Bufr satellie ID SAID', nint(satinfo_v(1)), & + ' does not match ', bufsat + go to 690 ! skip to the end of read_subset block + endif + enddo rd_loop + ! Big loop to read data file next=0 irec=0 iobs=1 + nrec=999999 read_subset: do while(ireadmg(lnbufr,subset,idate)>=0) ! GMI scans irec=irec+1 @@ -325,10 +352,17 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& if(next /= mype_sub)cycle read_loop: do while (ireadsb(lnbufr)==0) ! GMI pixels + call ufbint(lnbufr,satinfo_v,ninfo,1,iret,satinfo) + if(nint(satinfo_v(1)) /= bufsat) then + write(6,*) 'READ_GMI: Bufr satellie ID SAID', nint(satinfo_v(1)), & + ' does not match ', bufsat + cycle read_loop + end if t4dv => t4dv_save(iobs) dlon_earth => dlon_earth_save(iobs) dlat_earth => dlat_earth_save(iobs) crit1 => crit1_save(iobs) + it_mesh => it_mesh_save(iobs) ifov => ifov_save(iobs) iscan => iscan_save(iobs) iorbn => iorbn_save(iobs) @@ -344,6 +378,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& call ufbrep(lnbufr,fovn,1, 1,iret, strfovn) call ufbrep(lnbufr,slnm,1, 1,iret, strslnm) ifov = nint(fovn) + !-- ifov = ifov/3_i_kind + 1.0_r_kind iscan = nint(slnm) if (.not. use_edges .and. & (ifov < radedge_min .OR. ifov > radedge_max )) then @@ -365,17 +400,19 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& if(abs(tdiff) > twind) then cycle read_loop endif - endif + crit0=0.01_r_kind + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) ! ----- Read header record to extract obs location information - call ufbint(lnbufr,midat,nloc,1,iret,'SCLAT SCLON HMSL') - call ufbrep(lnbufr,gmichq,1,nchanl,iret,'TPQC2') - call ufbrep(lnbufr,gmirfi,1,nchanl,iret,'VIIRSQ') - call ufbrep(lnbufr,pixelsaza,1,ngs,iret,strsaza) - call ufbrep(lnbufr,val_angls,n_angls,ngs,iret,str_angls) - call ufbint(lnbufr,pixelloc,2, 1,iret,strloc) + call ufbint(lnbufr,midat,nloc,1,iret,'SCLAT SCLON HMSL') + call ufbrep(lnbufr,gmichq,1,nchanl,iret,'GMICHQ') + call ufbrep(lnbufr,gmirfi,1,nchanl,iret,'GMIRFI') + call ufbrep(lnbufr,pixelsaza,1,ngs,iret,'SAZA') + call ufbrep(lnbufr,val_angls,n_angls,ngs,iret,'SAMA SZA SMA SGA') + call ufbint(lnbufr,pixelloc,2, 1,iret,'CLATH CLONH') !--- Extract brightness temperature data. Apply gross check to data. ! If obs fails gross check, reset to missing obs value. @@ -421,6 +458,10 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& ! output solar zenith angles are between -90 and 90 ! make sure solar zenith angles are between 0 and 180 sun_zenith = 90.0_r_kind-sun_zenith + ! Make sure satellite's and Sun's azimuth angles are within 0-360 degree. + if( sat_azimuth_ang < 0_r_kind ) sat_azimuth_ang = sat_azimuth_ang + 360_r_kind + if( sun_azimuth_ang < 0_r_kind ) sun_azimuth_ang = sun_azimuth_ang + 360_r_kind +! if( sat_azimuth_ang2< 0_r_kind ) sat_azimuth_ang2= sat_azimuth_ang2+ 360_r_kind ! If use_swath_edge is true, set missing ch10-13 TBs to 500, so they ! can be tossed in gross check while ch1-9 TBs go through. If @@ -454,12 +495,6 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& nread=nread + (nchanl - nchanla) flgch = 0 - if (thin4d) then - crit1 = zero - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - crit1 = timedif - endif iobs=iobs+1 end do read_loop @@ -468,7 +503,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& call closbf(lnbufr) num_obs=iobs-1 - + if( mype_sub==mype_root) write(6,*) 'READ_GMI: do_noise_reduction=', do_noise_reduction if (do_noise_reduction) then ! Sort time in ascending order and get sorted index @@ -485,6 +520,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& dlon_earth_save(1:num_obs) = dlon_earth_save(sorted_index) dlat_earth_save(1:num_obs) = dlat_earth_save(sorted_index) crit1_save(1:num_obs) = crit1_save(sorted_index) + it_mesh_save(1:num_obs) = it_mesh_save(sorted_index) ifov_save(1:num_obs) = ifov_save(sorted_index) iscan_save(1:num_obs) = iscan_save(sorted_index) iorbn_save(1:num_obs) = iorbn_save(sorted_index) @@ -533,6 +569,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& dlon_earth => dlon_earth_save(iobs) dlat_earth => dlat_earth_save(iobs) crit1 => crit1_save(iobs) + it_mesh => it_mesh_save(iobs) ifov => ifov_save(iobs) iscan => iscan_save(iobs) iorbn => iorbn_save(iobs) @@ -587,7 +624,8 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& endif ! Map obs to thinning grid - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) + if(.not. iuse) then cycle obsloop endif @@ -624,6 +662,8 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& call deter_sfc(dlat,dlon,dlat_earth,dlon_earth,t4dv,isflg,idomsfc,sfcpct, & ts,tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr) + call deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) + ! Only keep obs over ocean - ej if(isflg /= 0) cycle obsloop @@ -683,10 +723,16 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& data_all(29,itx)= ff10 ! ten meter wind factor data_all(30,itx)= dlon_earth_deg ! earth relative longitude (degrees) data_all(31,itx)= dlat_earth_deg ! earth relative latitude (degrees) + data_all(iedge_log,itx) = 0 ! =0, not to be obsoleted at scan edges + data_all(33,itx) = sat_zen_ang2 ! local (satellite) zenith angle (radians) + data_all(34,itx) = sat_azimuth_ang2 ! local (satellite) azimuth_ang angle (degrees) + data_all(35,itx) = sat_scan_ang2 ! scan(look) angle (rad) + data_all(36,itx) = sun_zenith ! solar zenith angle (deg) + data_all(37,itx) = sun_azimuth_ang ! solar azimuth_ang angle (deg) if(dval_use) then - data_all(32,itx)= val_gmi - data_all(33,itx)= itt + data_all(maxinfo-1,itx)= val_gmi + data_all(maxinfo,itx)= itt end if if(nst_gsi>0) then @@ -706,7 +752,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& ! information it retained and then let single task merge files together call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,& nele,itxmax,nread,ndata,data_all,score_crit,nrec) - write(6,*) 'READ_GMI: after combine_obs, nread,ndata is ',nread,ndata + if( mype_sub==mype_root) write(6,*) 'READ_GMI: after combine_obs, nread,ndata is ',nread,ndata !========================================================================================================= if( use_edges .and. (radedge_min > 1 .or. radedge_max < nscan).and. mype_sub==mype_root )then !nscan instead of ang_nn @@ -718,6 +764,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& ! JJJ, 2/12/2014 pos_max=ndata allocate(npos_all(pos_max,nscan)) + allocate(pos_statis(nscan)) npos_all = 0 pos_statis = 0 do n=1,ndata @@ -773,6 +820,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& enddo write(6,*) 'READ_', trim(obstype), ': after obsolete_obs near edges, ndata ', sum(pos_statis) deallocate(npos_all) + deallocate(pos_statis) endif ! use_edges, but flag part of obs at the scan edges with negative FOV values. !========================================================================================================= @@ -833,6 +881,7 @@ subroutine init_(maxchanl,maxobs) allocate(sat_zen_ang2_save(maxobs),sat_azimuth_ang2_save(maxobs),sat_scan_ang2_save(maxobs)) allocate(t4dv_save(maxobs)) allocate(crit1_save(maxobs)) + allocate(it_mesh_save(maxobs)) allocate(tbob_save(maxchanl,maxobs)) allocate(sun_zenith_save(maxobs),sun_azimuth_ang_save(maxobs)) end subroutine init_ @@ -840,6 +889,7 @@ subroutine clean_ deallocate(sun_zenith_save,sun_azimuth_ang_save) deallocate(tbob_save) deallocate(crit1_save) + deallocate(it_mesh_save) deallocate(t4dv_save) deallocate(sat_zen_ang2_save,sat_azimuth_ang2_save,sat_scan_ang2_save) deallocate(sat_zen_ang_save,sat_azimuth_ang_save,sat_scan_ang_save) diff --git a/src/gsi/read_goesglm.f90 b/src/gsi/read_goesglm.f90 new file mode 100644 index 000000000..f72e53623 --- /dev/null +++ b/src/gsi/read_goesglm.f90 @@ -0,0 +1,755 @@ +subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_goesglm reads lightning obs from a BUFR file +! prgmmr: k apodaca +! org: CSU/CIRA, Data Assimilation Group +! date: 2015-03-12 +! +! abstract: This routine reads lightning data (Earth-relative location, frequency) from +! file and prepares it for assimiliation in the form of lightning flash rate +! (#hits km-2 hr-1). +! +! Note: when running GSI in regional mode, the code only +! retains those observations that fall within the regional +! domain +! +! program history log: +! 2015-06-12 zupanski - include the convert_to_flash_rate subroutine to convert +! lightning strike observations into lightning flash rate +! (#hits km-2 hr-1). +! 2015-11-18 apodaca - include the convert_time subroutine to deal with computer +! precision dependencies. +! 2018-02-07 apodaca - add further documentation +! +! input argument list: +! infile - unit from which to read BUFR data +! obstype - observation type to process +! lunout - unit to which to write data for further processing +! +! output argument list: +! nread - number of type "obstype" observations read +! nodata - number of individual "obstype" observations read +! ndata - number of type "obstype" observations retained for further processing +! twindin - input group time window (hours) +! sis - satellite/instrument/sensor indicator +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ + use kinds, only: r_single,r_kind,r_double,i_kind + use constants, only: zero,one_tenth,one,deg2rad,& + three,rad2deg,& + r60inv,ten + use gridmod, only: diagnostic_reg,wrf_mass_regional,regional,nlon,nlat,& + tll2xy,txy2ll,& + rlats,rlons + use lightinfo, only: iuse_light,nlighttype + use obsmod, only: iadate + use obsmod, only: offtime_data + use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen + + implicit none + +! Declare passed variables + character(len=*) ,intent(in ) :: infile,obstype + character(len=*) ,intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: nread,ndata + real(r_kind) ,intent(in ) :: twindin + integer(i_kind) :: nodata + +! Declare local parameters + real(r_kind),parameter:: r6 = 6.0_r_kind + real(r_kind),parameter:: r90 = 90.0_r_kind + real(r_kind),parameter:: r180 = 180.0_r_kind + real(r_kind),parameter:: r360 = 360.0_r_kind + +!--- Declare local variables + logical lob + logical outside + + character(40) hdstr,oestr,qcstr + character(10) date + character(8) subset + character(1) sidchr(8) + + integer(i_kind) ireadmg,ireadsb,icntpnt,icount + integer(i_kind) lunin,i + integer(i_kind) itx + integer(i_kind) ihh,idd,idate,iret,im,iy,k + integer(i_kind) nchanl,nreal,ilat,ilon + integer(i_kind) lqm + integer(i_kind) iout + integer(i_kind) ntest,nvtest + integer(i_kind) minobs,minan + integer(i_kind) ntb + integer(i_kind) nmsg ! message index + integer(i_kind),parameter :: maxobs=2000000 + integer(i_kind),dimension(5):: idate5 + integer(i_kind),allocatable,dimension(:):: isort,iloc + + real(r_kind) time + real(r_kind) usage + real(r_kind) loe,lmerr + real(r_kind) time_correction + real(r_kind) dlat,dlon,dlat_earth,dlon_earth + real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00 + real(r_kind) vdisterrmax + real(r_kind) timex,timeobs,toff,t4dv,zeps + real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out +!--- flash rate + real(r_kind),allocatable,dimension(:,:):: cdata_flash,cdata_flash_h + integer(i_kind) :: ndata_flash,ndata_flash_h + + real(r_double) rstation_id + + real(r_double),dimension(3):: hdr + real(r_double),dimension(1,1):: qcmark,obserr + +! equivalence to handle character names + equivalence(rstation_id,sidchr) + +!--- data statements + data hdstr /'XOB YOB DHR'/ + data oestr /'LOE'/ + data qcstr /'LQM'/ + + data lunin / 13 / + + + nreal=13 + lob = obstype == 'goes_glm' + +! . . . . + +! Open, then read date from BUFR file + + + call closbf(lunin) + open(lunin,file=infile,form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + + +! Initialization + + ntb = 0 + nmsg = 0 + disterrmax=-9999.0_r_kind + + allocate(cdata_all(nreal,maxobs),isort(maxobs)) + isort = 0 + cdata_all=zero + nread=0 + ntest=0 + nvtest=0 + nchanl=0 + ilon=2 + ilat=3 + icntpnt=0 + +! . . . . +! Big loop over glmbufr file : READING THE BUFR FILE + + loop_msg: do while (ireadmg(lunin,subset,idate)== 0) + nmsg = nmsg+1 + write(*,'(3a,i10)') 'subset=',subset,' cycle time =',idate + + + loop_readsb: do while(ireadsb(lunin) == 0) +! use msg lookup table to decide which messages to skip +! use report id lookup table to only process matching reports + ntb = ntb+1 + + +! Extract location and date information + call ufbint(lunin,hdr,3,1,iret,hdstr) + + if(abs(hdr(2))>r90 .or. abs(hdr(1))>r360) cycle loop_readsb + if(hdr(1) > r180)hdr(1)=hdr(1)-r360 + if(hdr(1) < zero)hdr(1)=hdr(1)+r360 + dlon_earth=hdr(1)*deg2rad + dlat_earth=hdr(2)*deg2rad + + if (regional) then + +!-- WRF-ARW + + if (wrf_mass_regional) then + + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinates + if(diagnostic_reg) then + call txy2ll(dlon,dlat,rlon00,rlat00) + ntest=ntest+1 + cdist=sin(dlat_earth)*sin(rlat00)+cos(dlat_earth)*cos(rlat00)* & + (sin(dlon_earth)*sin(rlon00)+cos(dlon_earth)*cos(rlon00)) + cdist=max(-one,min(cdist,one)) + disterr=acos(cdist)*rad2deg + disterrmax=max(disterrmax,disterr) + end if + if(outside) cycle loop_readsb ! check to see if outside regional domain + + endif ! wrf_mass_regional + + endif !if (regional) then + +! Global + + if (.not. regional) then + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif ! end global block + + if (offtime_data) then + +! in time correction for observations to account for analysis +! time being different from obs file time. + write(date,'( i10)') idate + read (date,'(i4,3i2)') iy,im,idd,ihh + idate5(1)=iy + idate5(2)=im + idate5(3)=idd + idate5(4)=ihh + idate5(5)=0 + call w3fs21(idate5,minobs) ! obs ref time in seconds relative to historic date + idate5(1)=iadate(1) + idate5(2)=iadate(2) + idate5(3)=iadate(3) + idate5(4)=iadate(4) + idate5(5)=0 + call w3fs21(idate5,minan) ! analysis ref time in seconds relative to historic date + +! Add obs reference time, then subtract analysis time to get obs time relative to analysis + time_correction=float(minobs-minan)*r60inv + else + time_correction=zero + end if + + timeobs=real(real(hdr(3),r_single),r_double) + t4dv=timeobs + toff + zeps=1.0e-8_r_kind + if (t4dv -zeps) t4dv=zero + if (t4dv>winlen.and.t4dvwinlen) cycle loop_readsb ! outside time window + else + if((real(abs(time)) > real(twindin)))cycle loop_readsb ! outside time window + endif + + timex=time + + +! Note: An assessment of the GLM detection error is still a work in +! progress and at present, there are no clear metrics to assign a +! "quality mark" for an effective quality control procedure for +! lightning observations from this sensor. Nonetheless, the infrastructure +! for passing observations errors and quality control information to other +! routines within the GSI source code has been left in place. In addition, a +! temporarty undefined value (-.9999) has been assigned to the mnemonics +! corresponding to these variables in the lightning BUFR file. Developments +! for the calculation of observation errors and quality control (sanity checks) are +! expected in future upgrades to the "GOES/GLM variational lightning +! assimilation package." + +! Extract observation error informatiom + call ufbint(lunin,obserr,1,1,iret,oestr) + + loe=obserr(1,1) + lmerr=loe + +! Extract quality control information + call ufbint(lunin,qcmark,1,1,iret,qcstr) + + lqm=qcmark(1,1) + +! Data counter + + nread=nread+1 + icntpnt=icntpnt+1 + + ndata=ndata+1 + nodata=nodata+1 + iout=ndata + isort(icntpnt)=iout + + if (ndata > maxobs) then + write(6,*)'READ_GOESGLM: ***WARNING*** ndata > maxobs for ',obstype + ndata = maxobs + end if + + +! Set usage variable + usage = zero + + if (iuse_light(nlighttype) <= 0)usage=100._r_kind + if (lob) then + cdata_all(1,iout) =loe ! lightning observation error + cdata_all(2,iout) =dlon ! grid relative longitude + cdata_all(3,iout) =dlat ! grid relative latitude + cdata_all(4,iout) =iout ! lightning obs + cdata_all(5,iout) =rstation_id ! station id + cdata_all(6,iout) =t4dv ! analysis time + cdata_all(7,iout) =nlighttype ! type + cdata_all(8,iout) =lmerr ! lightning max error + cdata_all(9,iout) =lqm ! quality mark + cdata_all(10,iout)=loe ! original lightning obs error loe + cdata_all(11,iout)=usage ! usage parameter + cdata_all(12,iout)=dlon_earth*rad2deg ! earth relative lon (degrees) + cdata_all(13,iout)=dlat_earth*rad2deg ! earth relative lat (degrees) + end if + + +! end loop on read line BUFR + + end do loop_readsb + +! end of BUFR read loop + + enddo loop_msg !Uncomment if reading messeges in a loop + +! . . . . + +! Close unit to bufr file + + call closbf(lunin) + +! Write header record and data to output file for further processing + allocate(iloc(ndata)) + icount=0. + do i=1,maxobs + if(isort(i) > 0)then + icount=icount+1 + iloc(icount)=isort(i) + end if + end do + if(ndata /= icount)then + write(6,*) ' READ_GOESGLM: mix up in read_goesglm ,ndata,icount ',ndata,icount + call stop2(50) + end if + + allocate(cdata_out(nreal,ndata)) + do i=1,ndata + itx=iloc(i) + do k=1,nreal + cdata_out(k,i)=cdata_all(k,itx) + end do + end do + + deallocate(iloc,isort,cdata_all) + +! . . . . + +! Call to the subroutine that transforms lightning strikes into lightning flash rate + + + if(ndata /= 0) then + + !! count flash rate data and alocate temporary domain + !! begin with the current number of strikes as the theoretical upper limit + + ndata_flash_h=ndata + + allocate(cdata_flash_h(nreal,ndata_flash_h)) + + call convert_to_flash_rate & + (nreal,ndata,cdata_out,ndata_flash_h,cdata_flash_h,ndata_flash) + + deallocate(cdata_out) + ndata=ndata_flash + allocate(cdata_flash(nreal,ndata)) + + do i=1,ndata + do k=1,nreal + cdata_flash(k,i)=cdata_flash_h(k,i) + end do + end do + + deallocate(cdata_flash_h) + + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) cdata_flash + +!!!!!!!!! +!!! Write lat, lon, time, lightning flash rate "superobs" into a file: +!!! cdata_flash_h(2,iout),cdata_flash_h(3,iout),cdata_flash_h(4,iout), & +!!! cdata_flash_h(6,iout)cdata_flash(4,:) + + deallocate(cdata_flash) + + else ! ndata=0 + + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) cdata_out + deallocate(cdata_out) + + end if !! if(ndata =/ 0) then + + +900 continue + if(diagnostic_reg .and. ntest>0) write(6,*)'READ_GOESGLM: ',& + 'ntest,disterrmax=',ntest,disterrmax + if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_GOESGLM: ',& + 'nvtest,vdisterrmax=',ntest,vdisterrmax + + if (ndata == 0) then + call closbf(lunin) + write(6,*)'READ_GOESGLM: closbf(',lunin,')' + endif + + + close(lunin) + + close(55) + +! End of routine + return + +end subroutine read_goesglm + + +!!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + +subroutine convert_to_flash_rate & + (nreal,ndata_strike,cdata_strike,ndata_flash_h,cdata_flash_h,ndata_flash) + +!$$$ documentation block +! . . . . +! subroutine: convert_to_flash_rate converts geo-located lightning strikes into +! lightning flash rate (#hits km-2 hr-1) + +! prgmmr: zupanski +! org: CSU/CIRA, Data Assimilation group +! date: 2015-06-12 +! +! abstract: This subroutine does the following: +!---- +!- 1- counts the number of hits surrounding a GSI analysis grid point +!- 2- calculates the flash rate averaged over time and area (hr*km**2) +!- 3- finds the center of mass in terms of lon,lat and glon,glat +!- 4- assigns a center of mass to be the flash rate observation point +!---- +! +! program history log: +! 2015-07-01 apodaca - several updates in the calculation of lightning flashrate + + use kinds, only: r_single,r_kind,r_double,i_kind + use constants, only: zero,one_tenth,one,deg2rad,& + three,half,zero,& + r10,r100,ten, r1000, rearth + use gridmod, only: wrf_mass_regional,regional,nlon,nlat,& + tll2xy,txy2ll + use gridmod, only: lat2, lon2 + use wrf_mass_guess_mod, only: ges_xlon, ges_xlat + use gsi_4dvar, only: nhr_assimilation + + implicit none + + integer(i_kind),intent(in ) :: nreal,ndata_strike,ndata_flash_h + integer(i_kind),intent(inout) :: ndata_flash + real(r_kind),intent(inout),dimension(nreal,ndata_strike) :: cdata_strike + real(r_kind),intent(inout),dimension(nreal,ndata_flash_h) :: cdata_flash_h + + real(r_kind),allocatable,dimension(:) :: gtim_central + real(r_kind),allocatable,dimension(:) :: glon_central + real(r_kind),allocatable,dimension(:) :: glat_central + real(r_kind),allocatable,dimension(:) :: lon_central + real(r_kind),allocatable,dimension(:) :: lat_central + integer(i_kind),allocatable,dimension(:) :: ind_min + integer(i_kind),allocatable,dimension(:) :: lcount + + real(r_kind) :: rearth2 + real(r_kind) :: dtime,darea,cosine + real(r_kind) :: darea_sum + real(r_kind) :: delta_lon,delta_lat + real(r_kind) :: lat_ref + real(r_kind) :: xx,yy + real(r_kind) :: dist2,dist_min + integer(i_kind) :: ii0,jj0 + integer(i_kind) :: ngridh + integer(i_kind) :: index + integer(i_kind) :: iobs,usage + logical :: xflag,yflag + + real(r_kind) :: xbound,ybound + integer(i_kind) :: nxdim,nydim + integer(i_kind) :: icount + + ! Output files +!---- + + +!- unit grid lat-lon distances (Earth difference divided by grid difference) +!- calculated from all averaged grid areas +!!- note: this can be relaxed if the unit grid area (km) is known (i.e. darea) +!! darea = (r*cos(lat)*dlon)*(dlat) + + + rearth2=(rearth/r1000)**2 !! squared earth radius in km (need for darea calculation) + + if (ndata_strike>0) then + + darea_sum=0._r_kind + do iobs=1,ndata_strike + + ii0=INT(cdata_strike(2,iobs)) + jj0=INT(cdata_strike(3,iobs)) + + delta_lon=ges_xlon(jj0,ii0+1,1)-ges_xlon(jj0,ii0,1) + delta_lat=ges_xlat(jj0+1,ii0,1)-ges_xlat(jj0,ii0,1) + + lat_ref =half*(cdata_strike(13,iobs)+cdata_strike(13,iobs-1)) + + cosine=cos(lat_ref*deg2rad) + + darea_sum=darea_sum+rearth2*cos(lat_ref*deg2rad)*(abs(delta_lon)*deg2rad)*& + (abs(delta_lat)*deg2rad) + + end do !! do iobs=2,ndata_strike + + darea=darea_sum/float(ndata_strike) + else !! ndata_strike=0 + darea=zero + + end if !! if(ndata_strike>0) then + + dtime=float(nhr_assimilation) + + ! Regional + + if (regional) then + +!-- WRF-ARW + + if (wrf_mass_regional) then + + nxdim=lon2 + nydim=lat2 + + endif ! wrf_mass_regional + + endif !if (regional) then + +! Global + + if (.not. regional) then + + nxdim=nlon + nydim=nlat + + endif ! end global block + +!!! Allocate new var for flash rate here (nxdim,nydim) +! asign zero to all points +! update the relevant points in the loop + + ngridh=nxdim*nydim + + + allocate(gtim_central(1:ngridh)) + allocate(glon_central(1:ngridh)) + allocate(glat_central(1:ngridh)) + allocate( lon_central(1:ngridh)) + allocate( lat_central(1:ngridh)) + allocate( lcount(1:ngridh)) + + lcount(:)=0 + glon_central(:)=zero + glat_central(:)=zero + lon_central(:) =zero + lat_central(:) =zero + gtim_central(:)=zero + + do iobs=1,ndata_strike + + xx=cdata_strike(2,iobs) !! glon + yy=cdata_strike(3,iobs) !! glat + ii0=INT(cdata_strike(2,iobs)) + jj0=INT(cdata_strike(3,iobs)) + +!! find lightning strikes near the (ii0,jj0) point + + xbound=float(ii0) + ybound=float(jj0) + + xflag=(xx>xbound) .AND. (xxybound) .AND. (yy0) then + glon_central(index)=glon_central(index)/float(lcount(index)) + glat_central(index)=glat_central(index)/float(lcount(index)) + lon_central(index)= lon_central(index)/float(lcount(index)) + lat_central(index)= lat_central(index)/float(lcount(index)) + endif !! if(lcount(index)>0) then + enddo !! do index=1,ngridh + +!-- find the original index of the nearest strike (need for transfer of input obs) + + allocate(ind_min(1:ngridh)) + ind_min(:)=-99 + + dist_min=1.e10_r_kind + do iobs=1,ndata_strike + + xx=cdata_strike(2,iobs) !! glon + yy=cdata_strike(3,iobs) !! glat + ii0=INT(cdata_strike(2,iobs)) + jj0=INT(cdata_strike(3,iobs)) + index=(jj0-1)*nxdim+ii0 + + if (lcount(index)>0) then + dist2=(xx-glon_central(index))**2+(yy-glat_central(index))**2 + if (dist20) then + + enddo !! do iobs=1,ndata_strike + +!---- +!---- Output +!---- + +!-- count the non-zero flash rates and assign a temporary domain cdata_flash_h +!-- Note: it is assumed that only non-zero flash rates are true observations + + icount=0 + do index=1,ngridh + if (lcount(index)>0) then + icount=icount+1 + cdata_flash_h( 1,icount)=cdata_strike( 1,ind_min(index)) + cdata_flash_h( 2,icount)=glon_central(index) + cdata_flash_h( 3,icount)=glat_central(index) + + if (darea>0._r_kind) then + cdata_flash_h( 4,icount)=float(lcount(index))/(darea*dtime) + else + cdata_flash_h( 4,icount)=0. + end if + + cdata_flash_h( 5,icount)=cdata_strike( 5,ind_min(index)) + cdata_flash_h( 6,icount)=gtim_central(index) + cdata_flash_h( 7,icount)=cdata_strike( 7,ind_min(index)) + cdata_flash_h( 8,icount)=cdata_strike( 8,ind_min(index)) + cdata_flash_h( 9,icount)=cdata_strike( 9,ind_min(index)) + cdata_flash_h(10,icount)=cdata_strike(10,ind_min(index)) + cdata_flash_h(11,icount)=usage + cdata_flash_h(12,icount)=lon_central(index) + cdata_flash_h(13,icount)=lat_central(index) + + endif !! if(lcount(index)>0) then + + enddo !! do index=1,ngridh + + ndata_flash=icount + + deallocate(ind_min) + deallocate(lcount) + deallocate(gtim_central) + deallocate(glon_central) + deallocate(glat_central) + deallocate(lon_central) + deallocate(lat_central) + +!----- +! End of routine + return + +end subroutine convert_to_flash_rate + +!----- +subroutine convert_time (date_old,date_new,nmax) + +!$$$ documentation block +! . . . . +! subroutine: convert_time +! prgmmr: k apodaca date: 2015-11-18 +! +! abstract: This subroutine performs a date conversion to deal with +! computer precission dependencies associated with a 10-digit +! float for the analysis date/time. +!-- + use kinds, only: r_kind,i_kind + + implicit none + + integer(i_kind), intent(in) :: nmax + real(r_kind), intent(inout) :: date_old + real(r_kind), intent(in) :: date_new + integer(i_kind) :: i,sumidd + integer(i_kind) :: idd,jdd,kdd + real(r_kind), allocatable :: xdate(:) + real(r_kind) :: dd,hh,ysumidd,xsumidd + real(r_kind) :: xdd,xhh,ydate + real(r_kind) :: xccyy + + allocate(xdate(1:nmax)) + + xdate(1:nmax-1) = date_old + xdate(nmax) = date_new + + sumidd=0._r_kind + do i=1,nmax + xccyy = INT(1.0e-8_r_kind*xdate(i))*1.0e8_r_kind + xdate(i) = INT(xdate(i))-xccyy + + jdd=INT(0.0001_r_kind*xdate(i)) + idd=INT(xdate(i))-jdd*10000 + + ysumidd=float(idd) + dd=float(INT(0.01_r_kind*ysumidd)) + hh=ysumidd-dd*100._r_kind + + sumidd=sumidd+dd*24._r_kind+hh + + enddo !! do i=1,nmax + + xsumidd=float(sumidd)/nmax + ysumidd=float(INT(xsumidd)) + + kdd=INT(xsumidd/24._r_kind) + xdd=float(kdd) + xhh=ysumidd-float(kdd)*24._r_kind + + ydate=float(jdd)*10000._r_kind+xdd*100._r_kind+xhh+xccyy + + date_old=ydate + + deallocate(xdate) + +end subroutine convert_time + diff --git a/src/read_goesimg.f90 b/src/gsi/read_goesimg.f90 similarity index 95% rename from src/read_goesimg.f90 rename to src/gsi/read_goesimg.f90 index a11f134b2..e3ceaa792 100644 --- a/src/read_goesimg.f90 +++ b/src/gsi/read_goesimg.f90 @@ -45,6 +45,7 @@ subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,& ! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) ! 2015-02-23 Rancic/Thomas - add thin4d to time window logical ! 2015-10-01 guo - consolidate use of ob location (in deg) +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -74,10 +75,12 @@ subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & checkob,finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use gridmod, only: diagnostic_reg,regional,nlat,nlon,txy2ll,tll2xy,rlats,rlons use constants, only: deg2rad,zero,one,rad2deg,r60inv,r60 use radinfo, only: iuse_rad,jpch_rad,nusis - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use deter_sfc_mod, only: deter_sfc use gsi_nstcouplermod, only: nst_gsi,nstinfo use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter @@ -121,7 +124,7 @@ subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,& integer(i_kind),allocatable,dimension(:)::nrec real(r_kind) dg2ew,sstime,tdiff,t4dv,sfcr - real(r_kind) dlon,dlat,timedif,crit1,dist1 + real(r_kind) dlon,dlat,crit1,dist1 real(r_kind) dlon_earth,dlat_earth real(r_kind) dlon_earth_deg,dlat_earth_deg real(r_kind) pred @@ -137,11 +140,13 @@ subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,& real(r_kind) cdist,disterr,disterrmax,dlon00,dlat00 integer(i_kind) ntest + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh !************************************************************************** ! Initialize variables - maxinfo=35 + maxinfo=31 lnbufr = 10 disterrmax=zero ntest=0 @@ -183,8 +188,14 @@ subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,& if (.not.assim) val_img=zero + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Open bufr file. @@ -287,13 +298,10 @@ subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,& call grdcrd1(dlon,rlons,nlon,1) endif - if (thin4d) then - crit1=0.01_r_kind - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - crit1=0.01_r_kind+timedif - endif - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0 = 0.01_r_kind + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle read_loop @@ -381,8 +389,8 @@ subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,& data_all(31,itx)= dlat_earth_deg ! earth relative latitude (degrees) if(dval_use)then - data_all(36,itx) = val_img - data_all(37,itx) = itt + data_all(32,itx) = val_img + data_all(33,itx) = itt end if if ( nst_gsi > 0 ) then @@ -417,7 +425,7 @@ subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,& end do if(dval_use .and. assim)then do n=1,ndata - itt=nint(data_all(37,n)) + itt=nint(data_all(maxinfo,n)) super_val(itt)=super_val(itt)+val_img end do end if diff --git a/src/read_goesimgr_skycover.f90 b/src/gsi/read_goesimgr_skycover.f90 similarity index 100% rename from src/read_goesimgr_skycover.f90 rename to src/gsi/read_goesimgr_skycover.f90 diff --git a/src/read_goesndr.f90 b/src/gsi/read_goesndr.f90 similarity index 96% rename from src/read_goesndr.f90 rename to src/gsi/read_goesndr.f90 index 636d6acbc..8335b82d9 100644 --- a/src/read_goesndr.f90 +++ b/src/gsi/read_goesndr.f90 @@ -59,6 +59,7 @@ subroutine read_goesndr(mype,val_goes,ithin,rmesh,jsatid,infile,& ! 2013-12-30 sienkiewicz - use BUFR library function 'ibfms' to check for missing value of hdr(15) ! 2015-02-23 Rancic/Thomas - add thin4d to time window logical ! 2015-10-01 guo - consolidate use of ob location (in deg) +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -92,12 +93,14 @@ subroutine read_goesndr(mype,val_goes,ithin,rmesh,jsatid,infile,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & checkob,finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use obsmod, only: bmiss use radinfo, only: cbias,newchn,predx,iuse_rad,jpch_rad,nusis,ang_rad,air_rad,& newpc4pred use gridmod, only: diagnostic_reg,nlat,nlon,regional,tll2xy,txy2ll,rlats,rlons use constants, only: deg2rad,zero,rad2deg, r60inv,one,two - use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,iwinbgn,winlen use deter_sfc_mod, only: deter_sfc use gsi_nstcouplermod, only: nst_gsi,nstinfo use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter @@ -149,7 +152,7 @@ subroutine read_goesndr(mype,val_goes,ithin,rmesh,jsatid,infile,& integer(i_kind),allocatable,dimension(:)::nrec integer(i_kind) ibfms ! BUFR missing value function - real(r_kind) dlon,dlat,timedif,emiss,sfcr + real(r_kind) dlon,dlat,emiss,sfcr real(r_kind) dlon_earth,dlat_earth real(r_kind) dlon_earth_deg,dlat_earth_deg real(r_kind) ch8,sstime @@ -166,6 +169,8 @@ subroutine read_goesndr(mype,val_goes,ithin,rmesh,jsatid,infile,& real(r_double),dimension(15):: hdr real(r_double),dimension(18):: grad + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh !************************************************************************** @@ -209,8 +214,14 @@ subroutine read_goesndr(mype,val_goes,ithin,rmesh,jsatid,infile,& if (.not.assim) val_goes=zero + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! check to see if prepbufr file @@ -369,20 +380,12 @@ subroutine read_goesndr(mype,val_goes,ithin,rmesh,jsatid,infile,& ! Set common predictor parameters - if (thin4d) then - timedif = zero - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - endif - nread=nread+nchanl - - crit1=0.01_r_kind+timedif - if(ifov < mfov .and. ifov > 0)then - crit1=crit1+two*float(mfov-ifov) - end if - - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0=0.01_r_kind + if(ifov < mfov .and. ifov > 0) crit0 = crit0+two*float(mfov-ifov) + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle read_loop ! Increment goes sounder data counter diff --git a/src/read_gps.f90 b/src/gsi/read_gps.f90 similarity index 99% rename from src/read_gps.f90 rename to src/gsi/read_gps.f90 index c96e86d51..8951a9a0a 100644 --- a/src/read_gps.f90 +++ b/src/gsi/read_gps.f90 @@ -169,6 +169,18 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & return end if +! Open file for input, then read bufr data + open(lnbufr,file=trim(infile),form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + call datelen(10) + call readmg(lnbufr,subset,idate,iret) + if (iret/=0) then + call closbf(lnbufr) + write(6,*)' GPS file not read ' + write(6,1020)'READ_GPS: ref_obs,nprof_gps= ',ref_obs,nprof_gps + return + end if + ! Allocate and load arrays to contain gpsro types. ngpsro_type=ikx allocate(gpsro_ctype(ngpsro_type), gpsro_itype(ngpsro_type), & @@ -185,13 +197,6 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & end do -! Open file for input, then read bufr data - open(lnbufr,file=trim(infile),form='unformatted') - call openbf(lnbufr,'IN',lnbufr) - call datelen(10) - call readmg(lnbufr,subset,idate,iret) - if (iret/=0) goto 1010 - ! Allocate work array to hold observations allocate(cdata_all(nreal,maxobs)) @@ -450,7 +455,6 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & deallocate(cdata_all) ! Close unit to input file -1010 continue call closbf(lnbufr) nprof_gps = nmrecs diff --git a/src/read_guess.F90 b/src/gsi/read_guess.F90 similarity index 95% rename from src/read_guess.F90 rename to src/gsi/read_guess.F90 index 27f771266..e42f01a36 100644 --- a/src/read_guess.F90 +++ b/src/gsi/read_guess.F90 @@ -72,6 +72,7 @@ subroutine read_guess(iyear,month,idd,mype) ! 2015-01-14 Hu - add function gsd_gen_coast_prox to calculate coast ! proximity over full domain instead of subdomain ! 2016-03-02 s.liu/carley - remove use_reflectivity and use i_gsdcldanal_type +! 2017-10-10 Wu W - add code for FV3 netcdf guess input ! ! input argument list: ! mype - mpi task id @@ -87,12 +88,14 @@ subroutine read_guess(iyear,month,idd,mype) use kinds, only: r_kind,i_kind use jfunc, only: bcoption,clip_supersaturation use guess_grids, only: nfldsig,ges_tsen,load_prsges,load_geop_hgt,ges_prsl + use guess_grids, only: geop_hgti,ges_geopi use m_gsiBiases,only : bkg_bias_correction,nbc use m_gsiBiases, only: gsi_bkgbias_bundle use gsi_bias, only: read_bias use gridmod, only: lat2,lon2 use gridmod, only: nsig use gridmod, only: wrf_mass_regional,wrf_nmm_regional,cmaq_regional,& + fv3_regional,& twodvar_regional,netcdf,regional,nems_nmmb_regional,use_gfs_ozone use gridmod, only: use_gfs_nemsio use gfs_stratosphere, only: use_gfs_stratosphere @@ -105,6 +108,9 @@ subroutine read_guess(iyear,month,idd,mype) use gsd_update_mod, only: gsd_gen_coast_prox use read_wrf_mass_guess_mod, only: read_wrf_mass_guess_class use read_wrf_nmm_guess_mod, only: read_wrf_nmm_guess_class + use gsi_rfv3io_mod, only: read_fv3_netcdf_guess + use gsi_rfv3io_mod, only: bg_fv3regfilenameg + use mpimod, only: ierror,mpi_comm_world implicit none @@ -154,6 +160,9 @@ subroutine read_guess(iyear,month,idd,mype) call read_2d_guess(mype) else if (nems_nmmb_regional) then call nmm_binary_guess%read_nems_nmmb_guess(mype) + else if (fv3_regional ) then + call bg_fv3regfilenameg%init + call read_fv3_netcdf_guess(bg_fv3regfilenameg) else if (cmaq_regional) then call read_cmaq_guess(mype) end if @@ -241,6 +250,9 @@ subroutine read_guess(iyear,month,idd,mype) ! Compute 3d subdomain geopotential heights from the guess fields call load_geop_hgt +! Save guess geopotential height at level interface for use in write_atm + ges_geopi=geop_hgti + ! Compute the coast proximity call gsd_gen_coast_prox diff --git a/src/read_iasi.f90 b/src/gsi/read_iasi.f90 similarity index 97% rename from src/read_iasi.f90 rename to src/gsi/read_iasi.f90 index e03ffeb37..0079a2c23 100644 --- a/src/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -66,6 +66,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! 2015-02-23 Rancic/Thomas - add thin4d to time window logical ! 2015-10-22 Jung - added logic to allow subset changes based on the satinfo file ! 2016-04-28 jung - added logic for RARS and direct broadcast from NESDIS/UW +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -106,6 +107,8 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & finalcheck,checkob,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only:iuse_rad,nuchan,nusis,jpch_rad,crtm_coeffs_path,use_edges, & radedge1,radedge2,radstart,radstep use crtm_module, only: success, & @@ -115,9 +118,10 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& use gridmod, only: diagnostic_reg,regional,nlat,nlon,& tll2xy,txy2ll,rlats,rlons use constants, only: zero,deg2rad,rad2deg,r60inv,one,ten,r100 - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use calc_fov_crosstrk, only: instrument_init, fov_check, fov_cleanup use deter_sfc_mod, only: deter_sfc,deter_sfc_fov + use obsmod, only: bmiss use gsi_nstcouplermod, only:nst_gsi,nstinfo use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter use mpimod, only: npe @@ -187,7 +191,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind) :: rsat, dlon, dlat real(r_kind) :: dlon_earth,dlat_earth,dlon_earth_deg,dlat_earth_deg real(r_kind) :: lza, lzaest,sat_height_ratio - real(r_kind) :: timedif, pred, crit1, dist1 + real(r_kind) :: pred, crit1, dist1 real(r_kind) :: sat_zenang real(crtm_kind) :: radiance real(r_kind) :: tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr @@ -230,6 +234,8 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind),parameter:: earth_radius = 6371000._r_kind integer(i_kind),parameter :: ilon = 3 integer(i_kind),parameter :: ilat = 4 + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh logical print_verbose print_verbose=.false. @@ -371,8 +377,14 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& rlndsea(4) = 30._r_kind endif + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Allocate arrays to hold data ! The number of channels in obtained from the satinfo file being used. @@ -560,14 +572,12 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Increment nread counter by satinfo_nchan nread = nread + satinfo_nchan - if (thin4d) then - crit1 = 0.01_r_kind - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - crit1 = 0.01_r_kind+timedif - endif - if( llll > 1 ) crit1 = crit1 + r100 * float(llll) - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0 = 0.01_r_kind + if( llll > 1 ) crit0 = crit0 + r100 * float(llll) + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) + if(.not. iuse)cycle read_loop ! Observational info @@ -652,8 +662,12 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! In our case (616 channels) there are 10 groups of cscale (dimension :: cscale(3,10)) ! The units are W/m2..... you need to convert to mW/m2.... (subtract 5 from cscale(3) do i=1,10 ! convert exponent scale factor to int and change units - iexponent = -(nint(cscale(3,i)) - 5) - sscale(i)=ten**iexponent + if(cscale(3,i) < bmiss) then + iexponent = -(nint(cscale(3,i)) - 5) + sscale(i)=ten**iexponent + else + sscale(i)=0.0_r_kind + endif end do ! Read IASI channel number(CHNM) and radiance (SCRA) diff --git a/src/read_l2bufr_mod.f90 b/src/gsi/read_l2bufr_mod.f90 similarity index 75% rename from src/read_l2bufr_mod.f90 rename to src/gsi/read_l2bufr_mod.f90 index 01c328541..d5b34d53c 100644 --- a/src/read_l2bufr_mod.f90 +++ b/src/gsi/read_l2bufr_mod.f90 @@ -1,3 +1,17 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Ground-base Radar Observation (GRO) Assimilation Implmentation +!!! Xu Lu, Xuguang Wang +!!! POC: xuguang.wang@ou.edu +!!! Modifications: +!!! 1. Add options to superob the GRO: +!!! a. logical: radar_box (use homogeneous boxes instead of azimuthal/elevation during superobing) +!!! b. real: radar_rmesh,radar_zmesh (horizontal and vertical superobing box resolution, unit km for horizontal rmesh and m for vertical zmesh) +!!! c. logical: radar_sites (provide a list of specific radar sites to be assimilated) +!!! 2. Modify the radar_bufr_read_all based on the options in 1.: +!!! a. superob GRO with homogeneous boxes based on radar_box, radar_rmesh, radar_zmesh +!!! b. only read in certain radar sites based on radar_sites +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + module read_l2bufr_mod !$$$ module documentation block ! . . . . @@ -52,9 +66,11 @@ module read_l2bufr_mod public :: range_max,del_time,l2superob_only,elev_angle_max,del_azimuth public :: minnum,del_range,del_elev + public :: invtllv,radar_sites,radar_box,radar_rmesh,radar_zmesh!Xu + integer(i_kind) minnum - real(r_kind) del_azimuth,del_elev,del_range,del_time,elev_angle_max,range_max - logical l2superob_only + real(r_kind) del_azimuth,del_elev,del_range,del_time,elev_angle_max,range_max,radar_rmesh,radar_zmesh !Xu + logical l2superob_only,radar_sites,radar_box !Xu contains @@ -90,7 +106,10 @@ subroutine initialize_superob_radar minnum=50 range_max=100000._r_kind ! (100km) l2superob_only=.false. - + radar_sites=.false. !Xu + radar_box=.false. !Xu + radar_rmesh=10 !Xu + radar_zmesh=500 !Xu end subroutine initialize_superob_radar subroutine radar_bufr_read_all(npe,mype) @@ -131,12 +150,17 @@ subroutine radar_bufr_read_all(npe,mype) use qcmod, only: vadwnd_l2rw_qc use oneobmod, only: lsingleradar,singleradar use mpeu_util, only: IndexSet, IndexSort + use file_utility, only : get_lun !Xu + use constants, only: pi,rearth_equator !Xu + use mpeu_util, only: gettablesize,gettable !Xu + use gridmod, only: regional,nlat,nlon,txy2ll !Xu use gsi_io, only: verbose implicit none integer(i_kind),intent(in):: npe,mype integer(i_kind),parameter:: max_num_radars=150 + integer(i_kind),parameter:: maxobs=2e9 !Xu integer(i_kind),parameter:: n_gates_max=4000 real(r_kind),parameter:: four_thirds = 4.0_r_kind / 3.0_r_kind real(r_kind),parameter:: r8 = 8.0_r_kind @@ -161,6 +185,13 @@ subroutine radar_bufr_read_all(npe,mype) integer(i_kind) nsuper,nsuperall integer(i_kind) nthisrad,nthisbins integer(i_kind) idups,idups0 + integer(i_kind) outbufr,radar_count,radar_true,ntot,luin_mrms,nlevz,iout,iiout,ntmp,icntpnt,nodata,zflag,ndata !Xu + real(r_kind) xmesh,rmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11,zobs,crit1 !Xu + real(r_kind) halfpi,twopi,rkm2dg,delat,dgv,glatm,factor,delon,rlat_min,rlat_max,rlon_min,rlon_max,dlon_e,dlat_e,dlon_g,dlat_g,dlat_grid,dlon_grid !Xu + integer(i_kind) mlat,mlonx,mlonj,itxmax,ilev,ilat,ilon !Xu + integer(i_kind),allocatable,dimension(:):: mlon !Xu + real(r_kind),allocatable,dimension(:):: glat !Xu + real(r_kind),allocatable,dimension(:,:):: glon !Xu integer(i_kind) nradials_in,nradials_fail_angmax,nradials_fail_time,nradials_fail_elb integer(i_kind) nradials_in1,nradials_fail_angmax1,nradials_fail_time1,nradials_fail_elb1 integer(i_kind) nobs_in,nobs_badvr,nobs_badsr,nobs_lrbin,nobs_hrbin,nrange_max,irad @@ -225,13 +256,30 @@ subroutine radar_bufr_read_all(npe,mype) equivalence(master_stn_table(1),cmaster_stn_table) equivalence (chdr,hdr(1)) equivalence (chdr2,hdr2(1)) + character(len=*),parameter:: tbname='SUPEROB_RADAR::' !Xu logical rite,print_verbose - logical lradar - + logical lradar,file_exists,luse !Xu + character(len=256),allocatable,dimension(:):: rtable !Xu + character(4),allocatable,dimension(:):: rsite !Xu + integer,allocatable,dimension(:):: ruse,isort !Xu + real(r_kind), allocatable, dimension(:) :: zl_thin !Xu + real(r_kind):: relm,srlm,crlm,sph,cph,cc,anum,denom !Xu + print_verbose=.false. if(verbose) print_verbose=.true. - +!!!!!!!!!!!!!!!!!!!!!!! Xu !!!!!!!!!!!!!!!!!!!! + if (radar_sites) then + open(666,file=trim('gsiparm.anl'),form='formatted') + call gettablesize(tbname,666,ntot,radar_count) + allocate(rtable(radar_count),rsite(radar_count),ruse(radar_count)) + call gettable(tbname,666,ntot,radar_count,rtable) + do i=1,radar_count + read(rtable(i),*) rsite(i),ruse(i) + if (mype==0) write(*,'(A10,X,A4,X,I)'),"Radar sites usage: ",rsite(i),ruse(i) + end do + end if +!!!!!!!!!!!!!!!!!!!!!!! Xu !!!!!!!!!!!!!!!!!!!! ! define infile if using either option for radial winds. do i=1,ndat if(trim(dtype(i))=='rw'.and.trim(dsis(i))=='l2rw'.and.vadwnd_l2rw_qc)then @@ -261,7 +309,6 @@ subroutine radar_bufr_read_all(npe,mype) rdelaz=one/delaz rdelr =one/delr rdelel=one/delel - num_radars=0 do i=1,max_num_radars stn_id_table(i)='ZZZZ' @@ -343,6 +390,13 @@ subroutine radar_bufr_read_all(npe,mype) if(abs(t)>del_time) cycle nobs_in=nobs_in+n_gates stn_id=chdr2 + radar_true=0 !Xu + if (radar_sites) then !Xu + do i=1,radar_count !Xu + if (trim(stn_id) .eq. trim(rsite(i)) .and. ruse(i) .eq. 1 ) radar_true=1 !Xu + end do !Xu + if (radar_true == 0) cycle !Xu + end if !Xu ibyte=index(cstn_id_table,stn_id) if(ibyte==0) then num_radars=num_radars+1 @@ -383,7 +437,6 @@ subroutine radar_bufr_read_all(npe,mype) stn_lon_table_all,max_num_radars,mpi_real8,mpi_comm_world,ierror) call mpi_allgather(stn_hgt_table,max_num_radars,mpi_real8, & stn_hgt_table_all,max_num_radars,mpi_real8,mpi_comm_world,ierror) - ! Create unique master list of all radar names,lats,lons jj=0 do j=1,max_num_radars*npe @@ -450,13 +503,75 @@ subroutine radar_bufr_read_all(npe,mype) nrange_max=0 nthisrad=nrbin*nazbin*nelbin nthisbins=6*nthisrad +!!!!!!!!!!!!!!!!!!!!!!! Xu !!!!!!!!!!!!!!!!!!!! + if (radar_box) then +!!!! Xu derived from satthin !!!! + twopi = two*pi + rkm2dg = 360.0_r_kind/(twopi*rearth_equator)*1.e3_r_kind + rlat_min = 999.0_r_kind + rlat_max = -999.0_r_kind + rlon_min = 999.0_r_kind + rlon_max = -999.0_r_kind + do j=1,nlon + dlon_g=j + do i=1,nlat + dlat_g=i + call txy2ll(dlon_g,dlat_g,dlon_e,dlat_e) + dlat_e=dlat_e*rad2deg + dlon_e=dlon_e*rad2deg + if (dlon_e < zero) then + dlon_e = MOD(dlon_e,-r360) + r360 + else if (dlon_e > r360) then + dlon_e = MOD(dlon_e,r360) + endif + rlat_min = min(rlat_min,dlat_e) + rlat_max = max(rlat_max,dlat_e) + rlon_min = min(rlon_min,dlon_e) + rlon_max = max(rlon_max,dlon_e) + end do + end do + dlat_grid = rlat_max - rlat_min + dlon_grid = rlon_max - rlon_min +!!!! Xu derived from satthin !!!! +!!!! Xu derived from make3grids !!!! + halfpi = half*pi + dx=radar_rmesh*rkm2dg + dy=dx + mlat=dlat_grid/dy+half + mlonx=dlon_grid/dx+half + delat=dlat_grid/mlat + dgv=delat*half + mlat=max(2,mlat);mlonx=max(2,mlonx) + allocate(mlon(mlat),glat(mlat),glon(mlonx,mlat)) + itxmax=0 + do j = 1,mlat + glat(j) = rlat_min + (j-1)*delat + glat(j) = glat(j)*deg2rad + glatm = glat(j) + dgv*deg2rad + factor = abs(cos(abs(glatm))) + mlonj = nint(mlonx*factor) + mlon(j) = max(2,mlonj) + delon = dlon_grid/mlon(j) + glat(j) = min(max(-halfpi,glat(j)),halfpi) + do i = 1,mlon(j) + glon(i,j) = rlon_min + (i-1)*delon + glon(i,j) = glon(i,j)*deg2rad + if (glon(i,j) > twopi) glon(i,j) = glon(i,j) - twopi + if (glon(i,j) < zero) glon(i,j) = glon(i,j) + twopi + glon(i,j) = min(max(zero,glon(i,j)),twopi) + enddo + end do +!!!! Xu derived from make3grids end !!!! + nlevz=nint(15000.0_r_kind/radar_zmesh) + nthisrad=(nlevz+1)*sum(mlon) + nthisbins=6*nthisrad!9*nthisrad + end if +!!!!!!!!!!!!!!!!!!!!!!! Xu !!!!!!!!!!!!!!!!!!!! ! reopen and reread the file for data this time - call closbf(inbufr) open(inbufr,file=infile,form='unformatted') call openbf(inbufr,'IN',inbufr) - allocate(bins(6,nthisrad,num_radars_0),ibins(nthisrad,num_radars_0)) bins=zero_quad ibins=0 @@ -506,6 +621,15 @@ subroutine radar_bufr_read_all(npe,mype) end if stn_id=chdr ibyte=index(cmaster_stn_table,stn_id) + if (radar_sites) then !Xu + radar_true=0 !Xu + do i=1,radar_count !Xu + if (trim(stn_id) == trim(rsite(i)) .and. ruse(i).eq.1) radar_true=1 !Xu + end do !Xu + if (radar_true == 0) then !Xu + cycle !Xu + end if !Xu + end if !Xu if(ibyte==0) then write(6,*) ' index error in radar_bufr_read_all -- program stops -- ',ibyte,stn_id call stop2(99) @@ -537,6 +661,7 @@ subroutine radar_bufr_read_all(npe,mype) nobs_hrbin=nobs_hrbin+1 cycle end if + if (.not.radar_box) then !Xu iloc=nrbin*(nazbin*(ielbin-1)+(iazbin-1))+irbin bins(1,iloc,krad)=bins(1,iloc,krad)+range bins(2,iloc,krad)=bins(2,iloc,krad)+stn_az @@ -545,13 +670,79 @@ subroutine radar_bufr_read_all(npe,mype) bins(5,iloc,krad)=bins(5,iloc,krad)+rwnd(2,i)**2 bins(6,iloc,krad)=bins(6,iloc,krad)+t ibins(iloc,krad)=ibins(iloc,krad)+1 + else !Xu + this_stalat=master_lat_table(krad) + if(abs(this_stalat)>r89_5) cycle + this_stalon=master_lon_table(krad) + rlon0=deg2rad*this_stalon + this_stalatr=this_stalat*deg2rad + clat0=cos(this_stalatr) ; slat0=sin(this_stalatr) + this_staid=master_stn_table(krad) + this_stahgt=master_hgt_table(krad) + thisrange= range + thisazimuth=stn_az + thistilt=stn_el + thisvr=rwnd(2,i) + vrmax=max(vrmax,thisvr) + vrmin=min(vrmin,thisvr) + thisvr2=rwnd(2,i)**2 + thiserr=sqrt(abs(thisvr2-thisvr**2)) + errmax=max(errmax,thiserr) + errmin=min(errmin,thiserr) + thistime=t + aactual=erad+this_stahgt + a43=four_thirds*aactual + thistiltr=thistilt*deg2rad + selev0=sin(thistiltr) + celev0=cos(thistiltr) + b=thisrange*(thisrange+two*aactual*selev0) + c=sqrt(aactual*aactual+b) + ha=b/(aactual+c) + epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) + h=ha-epsh + thishgt=this_stahgt+h + celev=celev0 + selev=selev0 + if(thisrange>=one) then + celev=a43*celev0/(a43+h) + selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) + end if + corrected_tilt=atan2(selev,celev)*rad2deg + gamma=half*thisrange*(celev0+celev) +! Get earth lat lon of superob + thisazimuthr=thisazimuth*deg2rad + rlonloc=rad_per_meter*gamma*cos(thisazimuthr) + rlatloc=rad_per_meter*gamma*sin(thisazimuthr) + call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) + thislat=rlatglob*rad2deg + thislon=rlonglob*rad2deg + if(abs(thislat)>r89_5) cycle + clat1=cos(rlatglob) + caz0=cos(thisazimuthr) + saz0=sin(thisazimuthr) + cdlon=cos(rlonglob-rlon0) + sdlon=sin(rlonglob-rlon0) + caz1=clat0*caz0/clat1 + saz1=saz0*cdlon-caz0*sdlon*slat0 + corrected_azimuth=atan2(saz1,caz1)*rad2deg + ilev=ceiling(thishgt/radar_zmesh) + ilat=ceiling((thislat-rlat_min)/delat) + ilon=ceiling((thislon-rlon_min+360.0_r_kind)/(dlon_grid/mlon(ilat))) + iloc=mlat*(mlon(ilat)*(ilev-1)+ilon)+ilat + bins(1,iloc,krad)=bins(1,iloc,krad)+range + bins(2,iloc,krad)=bins(2,iloc,krad)+stn_az + bins(3,iloc,krad)=bins(3,iloc,krad)+stn_el + bins(4,iloc,krad)=bins(4,iloc,krad)+rwnd(2,i) + bins(5,iloc,krad)=bins(5,iloc,krad)+rwnd(2,i)**2 + bins(6,iloc,krad)=bins(6,iloc,krad)+t + ibins(iloc,krad)=ibins(iloc,krad)+1 + end if !Xu radar_box end end do - end do ! end do while end do ! loop over blocks call closbf(inbufr) - allocate(ibins2(nthisrad,num_radars_0)) + ibins2=0 call mpi_allreduce(ibins,ibins2,nthisrad*num_radars_0,mpi_integer4,mpi_sum,mpi_comm_world,ierror) deallocate(ibins) @@ -603,6 +794,21 @@ subroutine radar_bufr_read_all(npe,mype) end if ! Print out histogram of counts by ielbin to see where angles are + if (radar_box) then !Xu + do ilev=1,nlevz !Xu + histo_el=0 !Xu + do krad=1,num_radars_0 !Xu + do ilat=1,mlat !Xu + do ilon=1,mlon(ilat) !Xu + iloc=mlat*(mlon(ilat)*(ilev-1)+ilon)+ilat !Xu + histo_el=histo_el+ibins2(iloc,krad) !Xu + end do + end do + end do + if(rite)write(6,'(4I10)')mlat,mlon(mlat),iloc,nthisrad + if(rite)write(6,'(" ilev,histo_el=",i6,i20)')ilev,histo_el + end do !Xu + else !Xu do ielbin=1,nelbin histo_el=0 do krad=1,num_radars_0 @@ -615,7 +821,7 @@ subroutine radar_bufr_read_all(npe,mype) end do if(rite)write(6,'(" ielbin,histo_el=",i6,i20)')ielbin,histo_el end do - + end if !Xu ! Prepare to create superobs and write out. open(inbufr,file='radar_supobs_from_level2',form='unformatted',iostat=iret) rewind inbufr @@ -667,11 +873,35 @@ subroutine radar_bufr_read_all(npe,mype) if(lsingleradar) then if(this_staid /= singleradar) lradar=.false. end if - if(lradar) then ! Logical for when running single radar exp. if(ibins2(iii,krad) < minnum) cycle thiscount=one_quad/real(ibins2(iii,krad),r_quad) + if (radar_box) then !Xu + do i=1,6 + binsx(i)=bins_work(i,iii,1) + end do + do k=2,npe + do i=1,6 + binsx(i)=binsx(i)+bins_work(i,iii,k) + end do + end do + do i=1,6 + binsx(i)=binsx(i)*thiscount + end do + thisrange= binsx(1) + thisazimuth=binsx(2) + thistilt=binsx(3) + thisvr=binsx(4) + vrmax=max(vrmax,thisvr) + vrmin=min(vrmin,thisvr) + thisvr2=binsx(5) + thiserr=sqrt(abs(thisvr2-thisvr**2)) +! thiserr=2. !Xu observation error forced to be 2 + errmax=max(errmax,thiserr) + errmin=min(errmin,thiserr) + thistime=binsx(6) + else !Xu do i=1,6 binsx(i)=bins_work(i,iii,1) end do @@ -694,7 +924,7 @@ subroutine radar_bufr_read_all(npe,mype) errmax=max(errmax,thiserr) errmin=min(errmin,thiserr) thistime=binsx(6) - + end if !Xu ! Compute obs height here ! Use 4/3rds rule to get elevation of radar beam ! (if local temperature, moisture available, then vertical position @@ -733,7 +963,6 @@ subroutine radar_bufr_read_all(npe,mype) call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) thislat=rlatglob*rad2deg thislon=rlonglob*rad2deg - ! Keep away from poles, rather than properly deal with polar singularity if(abs(thislat)>r89_5) cycle @@ -751,7 +980,6 @@ subroutine radar_bufr_read_all(npe,mype) abs(corrected_azimuth-thisazimuth ),& abs(corrected_azimuth-thisazimuth+r360),& abs(corrected_azimuth-thisazimuth+r720)),delazmmax) - write(inbufr) this_staid,this_stalat,this_stalon,this_stahgt, & thistime,thislat,thislon,thishgt,thisvr,corrected_azimuth,& thiserr,corrected_tilt,gamma @@ -759,7 +987,7 @@ subroutine radar_bufr_read_all(npe,mype) end if end do if(nsuper > 0)then - write(6,*)' for radar ',this_staid,' nsuper=',nsuper,' delazmmax=',delazmmax + write(6,*)' for radar ',this_staid,' nsuper=',nsuper,' delazmmax=',delazmmax,lradar write(6,*)' vrmin,max=',vrmin,vrmax,' errmin,max=',errmin,errmax write(6,*)' deltiltmin,max=',deltiltmin,deltiltmax,' deldistmin,max=',deldistmin,deldistmax vrminall=min(vrminall,vrmin) @@ -791,10 +1019,10 @@ subroutine radar_bufr_read_all(npe,mype) call mpi_finalize(ierror) stop end if + if (radar_sites) deallocate(rtable,rsite,ruse) !Xu end subroutine radar_bufr_read_all -end module read_l2bufr_mod SUBROUTINE tllv(ALM,APH,TLMO,CTPH0,STPH0,TLM,TPH) !$$$ subprogram documentation block @@ -894,5 +1122,6 @@ SUBROUTINE invtllv(ALM,APH,TLMO,CTPH0,STPH0,TLM,TPH) DENOM=CTPH0*CC-STPH0*SPH TLM=tlmo+ATAN2(ANUM,DENOM) TPH=ASIN(CTPH0*SPH+STPH0*CC) - + return END SUBROUTINE invtllv +end module read_l2bufr_mod diff --git a/src/read_lag.f90 b/src/gsi/read_lag.f90 similarity index 100% rename from src/read_lag.f90 rename to src/gsi/read_lag.f90 diff --git a/src/gsi/read_lidar.f90 b/src/gsi/read_lidar.f90 new file mode 100644 index 000000000..3112606ee --- /dev/null +++ b/src/gsi/read_lidar.f90 @@ -0,0 +1,311 @@ +subroutine read_lidar(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_lidar read doppler lidar winds +! prgmmr: yang org: np20 date: 1998-05-15 +! +! abstract: This routine reads doppler lidar wind files. +! +! When running the gsi in regional mode, the code only +! retains those observations that fall within the regional +! domain +! +! program history log: +! 1998-05-15 yang, weiyu +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-16 treadon - update documentation +! 2004-07-29 treadon - add only to module use, add intent in/out +! 2005-08-02 derber - modify to use convinfo file +! 2005-09-08 derber - modify to use input group time window +! 2005-10-11 treadon - change convinfo read to free format +! 2005-10-17 treadon - add grid and earth relative obs location to output file +! 2005-10-18 treadon - remove array obs_load and call to sumload +! 2005-10-26 treadon - add routine tag to convinfo printout +! 2006-02-03 derber - add new obs control +! 2006-02-08 derber - modify to use new convinfo module +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-07-27 msq/terry - removed cosine factor for line of sight winds and obs err +! 2007-03-01 tremolet - measure time from beginning of assimilation window +! 2008-04-18 safford - rm unused vars +! 2010-08-01 woollen - change bufr table (denoted as jsw) +! 2010-08-01 woollen - change kx to ikx (bug) (denoted as jsw) +! 2010-09-01 masutani - remove statements related to old cos(lat) correction !msq +! 2010-10-06 masutani -- use ikx, ikx=999 for missing type Bufrtable was updated +! 2010-11-05 mccarty/woollen - add level to dwld +! 2010-11-30 masutani - add kx to cdata_all(21), change maxdat to 21 (denoted msq) +! 2011-04-15 mccarty - change maxdat back to 20, kx in setupdw taken from ictype +! 2011-05-05 mccarty - cleaned up unnecessary print statement +! 2011-05-26 mccarty - remove dwlerror logic (moved to setupdw) +! 2011-08-01 lueken - added module use deter_sfc_mod +! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) +! 2015-02-23 Rancic/Thomas - add l4densvar to time window logical +! 2015-10-01 guo - consolidate use of ob location (in deg +! +! input argument list: +! infile - unit from which to read BUFR data +! obstype - observation type to process +! lunout - unit to which to write data for further processing +! twind - input group time window (hours) +! +! output argument list: +! nread - number of doppler lidar wind observations read +! ndata - number of doppler lidar wind profiles retained for further processing +! nodata - number of doppler lidar wind observations retained for further processing +! sis - satellite/instrument/sensor indicator +! nobs - array of observations on each subdomain for each processor +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,r_double,i_kind + use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons + use convinfo, only: nconvtype,ctwind, & !added mccarty + ncmiter,ncgroup,ncnumgrp,icuse,ictype,ioctype !mccarty + use constants, only: deg2rad,zero,r60inv ! check the usage msq + use obsmod, only: iadate,offtime_data + use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen + use deter_sfc_mod, only: deter_sfc2 + use mpimod, only: npe + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype,infile + character(len=20),intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: nread,ndata,nodata + integer(i_kind),dimension(npe),intent(inout) :: nobs + real(r_kind) ,intent(in ) :: twind + +! Declare local parameters + integer(i_kind),parameter:: maxobs=2e6 + integer(i_kind),parameter:: maxdat=20 !wm change back to 20 + ! kx taken from ictype + real(r_double),parameter:: r360=360.0_r_double + +! Declare local variables + logical dwl,outside + + character(40) hdstr,hdstr2 ! msq add hdstr2 + character(44) dwstr,dwstr2 ! msq add dwstr2 + character(10) date + character(8) subset + + integer(i_kind) lunin,i,kx,ilat,ikx,idomsfc + integer(i_kind) jdate,ihh,idd,idate,iret,im,iy,k,levs + integer(i_kind) nmrecs,ilon,nreal,nchanl + + + real(r_kind) time,usage,dlat,dlon,dlat_earth,dlon_earth + real(r_kind) dlat_earth_deg,dlon_earth_deg + real(r_kind) hloswind,sfcr,tsavg,ff10,toff,t4dv ! msq changed to hloswind + real(r_kind),allocatable,dimension(:,:):: cdata_all + + real(r_double) rstation_id + real(r_double) rkx !msq + real(r_double),dimension(5):: hdr + real(r_double),dimension(8,24):: dwld + + integer(i_kind) idate5(5),minobs,minan + real(r_kind) time_correction + + + integer(i_kind):: ilev ! mccarty + + + data hdstr /'SID CLON CLAT DHR TYP'/ !msq jsw + data dwstr /'HEIT ELEV BEARAZ NOLS NOLC ADPL LOSC LOSCU'/ !msq jsw + data hdstr2 /'SID XOB YOB DHR TYP'/ !msq used for KNMI data prepared by GMAO + data dwstr2 /'ADWL ELEV BORA NOLS NOLC ADPL LOSC SDLE'/ !msq used for KNMI data prepared by GMAO + + data lunin / 10 / + + +!************************************************************************** +! Initialize variables + nmrecs=0 + nreal=maxdat + nchanl=0 + ilon=2 + ilat=3 + +! Open, then read date from bufr data + open(lunin,file=trim(infile),form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + call readmg(lunin,subset,idate,iret) + if(iret/=0) then + print*,' failed to dw read data from ',lunin ! msq + call closbf(lunin) + return + endif + + allocate(cdata_all(maxdat,maxobs)) + + +! Time offset + call time_4dvar(idate,toff) + +! If date in lidar file does not agree with analysis date, +! print message and stop program execution. + write(date,'( i10)') idate + read (date,'(i4,3i2)') iy,im,idd,ihh + if(offtime_data) then + +! in time correction for observations to account for analysis +! time being different from obs file time. + write(date,'( i10)') idate + read (date,'(i4,3i2)') iy,im,idd,ihh + idate5(1)=iy + idate5(2)=im + idate5(3)=idd + idate5(4)=ihh + idate5(5)=0 + call w3fs21(idate5,minobs) ! obs ref time in minutes relative to historic date + idate5(1)=iadate(1) + idate5(2)=iadate(2) + idate5(3)=iadate(3) + idate5(4)=iadate(4) + idate5(5)=0 + call w3fs21(idate5,minan) ! analysis ref time in minutes relative to historic date + +! add obs reference time, then subtract analysis time to get obs time relative to analysis + + time_correction=float(minobs-minan)*r60inv + + else + time_correction=zero + end if + + write(6,*)'READ_LIDAR: time offset is ',toff,' hours.' + +! Big loop over bufr file + + obsloop: do + call readsb(lunin,iret) + if(iret/=0) then + call readmg(lunin,subset,jdate,iret) + if(iret/=0) exit obsloop + cycle obsloop + end if + nmrecs=nmrecs+1 + +! Extract type, date, and location information +! + call ufbint(lunin,rkx,1,1,iret,'TYP') !msq + kx=nint(rkx) !msq + if (kx==100.or.kx==101) then +! ADM data + call ufbint(lunin,hdr,5,1,iret,hdstr2) + else if (kx==201.or.kx==202) then +! GWOS data + call ufbint(lunin,hdr,5,1,iret,hdstr) + else +! undefined dwl data + call ufbint(lunin,hdr,5,1,iret,hdstr) + kx=999 + endif + + + ikx=0 + do i=1,nconvtype + if(trim(obstype) == trim(ioctype(i)) .and. kx == ictype(i))ikx = i + end do +! Determine if this is doppler wind lidar report + dwl= (ikx /= 0) .and. (subset=='DWLDAT') ! jsw chenge kx to ikx (bug) + if(.not. dwl) then + cycle obsloop + endif + + nread=nread+1 + + t4dv = toff + hdr(4) + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle obsloop + else + time=hdr(4) + time_correction + if (abs(time) > ctwind(ikx) .or. abs(time) > twind) cycle obsloop + endif + + rstation_id=hdr(1) + + hdr(2)=mod(hdr(2),r360) ! msq + if (hdr(2) < zero) hdr(2)=hdr(2)+r360 + + + dlat_earth_deg = hdr(3) + dlon_earth_deg = hdr(2) + dlat_earth = hdr(3) * deg2rad + dlon_earth = hdr(2) * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if (outside) cycle obsloop + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + + if (kx==100.or.kx==101) then + call ufbint(lunin,dwld,8,24,levs,dwstr2) !mccarty, msq + else + call ufbint(lunin,dwld,8,24,levs,dwstr) !mccarty,msq + endif + + do ilev=1,levs !mccarty, jsw + +! If wind data, extract observation. + nodata=min(nodata+1,maxobs) + ndata=min(ndata+1,maxobs) + usage = zero + if(icuse(ikx) < 0)usage=100._r_kind + if(ncnumgrp(ikx) > 0 )then ! cross validation on + if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) + end if + + + hloswind=dwld(7,ilev)/(cos(dwld(2,ilev)*deg2rad)) ! obs wind (line of sight component) + call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr) + + cdata_all(1,ndata)=ikx ! obs type + cdata_all(2,ndata)=dlon ! grid relative longitude + cdata_all(3,ndata)=dlat ! grid relative latitude + cdata_all(4,ndata)=t4dv ! obs time (analyis relative hour) + cdata_all(5,ndata)=dwld(1,ilev) ! obs height (altitude) (m) + cdata_all(6,ndata)=dwld(2,ilev)*deg2rad ! elevation angle (radians) + cdata_all(7,ndata)=dwld(3,ilev)*deg2rad ! bearing or azimuth (radians) + cdata_all(8,ndata)=dwld(4,ilev) ! number of laser shots + cdata_all(9,ndata)=dwld(5,ilev) ! number of cloud laser shots + cdata_all(10,ndata)=dwld(6,ilev) ! atmospheric depth + cdata_all(11,ndata)=hloswind ! obs wind (line of sight component) msq + cdata_all(12,ndata)=dwld(8,ilev) ! standard deviation (obs error) msq + cdata_all(13,ndata)=rstation_id ! station id + cdata_all(14,ndata)=usage ! usage parameter + cdata_all(15,ndata)=idomsfc+0.001_r_kind ! dominate surface type + cdata_all(16,ndata)=tsavg ! skin temperature + cdata_all(17,ndata)=ff10 ! 10 meter wind factor + cdata_all(18,ndata)=sfcr ! surface roughness + cdata_all(19,ndata)=dlon_earth_deg ! earth relative longitude (degrees) + cdata_all(20,ndata)=dlat_earth_deg ! earth relative latitude (degrees) + enddo ! ilev + + +! End of bufr read loop + end do obsloop + +! Write observations to scratch file + call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) + + +! Close unit to bufr file + deallocate(cdata_all) + call closbf(lunin) + +! End of routine + return +end subroutine read_lidar diff --git a/src/read_mitm_mxtm.f90 b/src/gsi/read_mitm_mxtm.f90 similarity index 99% rename from src/read_mitm_mxtm.f90 rename to src/gsi/read_mitm_mxtm.f90 index 750c30cfc..fbfe310bd 100644 --- a/src/read_mitm_mxtm.f90 +++ b/src/gsi/read_mitm_mxtm.f90 @@ -180,12 +180,12 @@ subroutine read_mitm_mxtm(nread,ndata,nodata,infile,obstype,lunout,gstime,sis,no ! Find number of reports maxobs = 0 - 100 continue + readloop: do read(lunin,90,end=101) c_station_id,c_prvstg,c_sprvstg, & rkx,tank,rlat4,rlon4,stnelev4,itimeshift,obval4 maxobs=maxobs+1 - goto 100 - 101 continue + end do readloop +101 continue if(print_verbose)write(6,*)myname,': maxobs=',maxobs if (maxobs == 0) then diff --git a/src/read_modsbufr.f90 b/src/gsi/read_modsbufr.f90 similarity index 100% rename from src/read_modsbufr.f90 rename to src/gsi/read_modsbufr.f90 diff --git a/src/read_nasa_larc.f90 b/src/gsi/read_nasa_larc.f90 similarity index 100% rename from src/read_nasa_larc.f90 rename to src/gsi/read_nasa_larc.f90 diff --git a/src/read_nsstbufr.f90 b/src/gsi/read_nsstbufr.f90 similarity index 90% rename from src/read_nsstbufr.f90 rename to src/gsi/read_nsstbufr.f90 index ef2ed5e45..b13f32a2a 100644 --- a/src/read_nsstbufr.f90 +++ b/src/gsi/read_nsstbufr.f90 @@ -17,6 +17,7 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & ! 2015-05-30 Li - Modify to use deter_sfc instead of deter_sfc2 ! 2015-06-01 Li - Modify to make it work when nst_gsi = 0 and nsstbufr data file exists ! 2016-03-11 j. guo - Fixed {dlat,dlon}_earth_deg in the obs data stream +! 2019-01-15 Li - modify to handle dbuoyb (NC001102) and mbuoyb (NC001103) ! ! input argument list: ! infile - unit from which to read BUFR data @@ -44,7 +45,7 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & use convinfo, only: nconvtype,ctwind, & ncmiter,ncgroup,ncnumgrp,icuse,ictype use obsmod, only: oberrflg - use insitu_info, only: n_comps,n_scripps,n_triton,n_3mdiscus,cid_mbuoy,n_ship,ship + use insitu_info, only: n_comps,n_scripps,n_triton,n_3mdiscus,cid_mbuoy,cid_mbuoyb,n_ship,ship use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use deter_sfc_mod, only: deter_sfc,deter_sfc2 use gsi_nstcouplermod, only: nst_gsi,nstinfo @@ -74,6 +75,7 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & real(r_kind),parameter:: r1_5 = 1.50_r_kind real(r_kind),parameter:: r24 = 24.0_r_kind real(r_kind),parameter:: r60 = 60.0_r_kind + real(r_kind),parameter:: r90 = 90.0_r_kind real(r_kind),parameter:: r360 = 360.0_r_kind real(r_kind),parameter:: bmiss = 1.0E11_r_kind @@ -182,7 +184,9 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & ! case ( 'NC001001' ) ; ctyp='ships ' ! case ( 'NC001002' ) ; ctyp='dbuoy ' +! case ( 'NC001003' ) ; ctyp='dbuoyb ' ! case ( 'NC001003' ) ; ctyp='mbuoy ' +! case ( 'NC001103' ) ; ctyp='mbuoyb ' ! case ( 'NC001004' ) ; ctyp='lcman ' ! case ( 'NC001005' ) ; ctyp='tideg ' ! case ( 'NC001007' ) ; ctyp='cstgd ' @@ -215,9 +219,15 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & ( trim(subset) == 'NC001001' ) ) then ! SHIPS call ufbint(lunin,msst,1,1,iret,'MSST') ! for ships, fixed buoy and lcman call ufbint(lunin,sst,1,1,iret,'SST1') ! read SST + elseif ( trim(subset) == 'NC001103' ) then ! MBUOYB + msst = 0.0_r_kind ! for mbuoyb, assign to be 0 + call ufbint(lunin,sst,1,1,iret,'SST0') elseif ( trim(subset) == 'NC001002' ) then ! DBUOY msst = 11.0_r_kind ! for drifting buoy, assign to be 11 call ufbint(lunin,sst,1,1,iret,'SST1') + elseif ( trim(subset) == 'NC001102' ) then ! DBUOYB + msst = 11.0_r_kind ! for drifting buoyb, assign to be 11 + call ufbint(lunin,sst,1,1,iret,'SST0') elseif ( trim(subset) == 'NC031002' ) then ! TESAC msst = 12.0_r_kind ! for ARGO, assign to be 12 call ufbint(lunin,tpf2,2,65535,klev,'DBSS STMP') ! read T_Profile @@ -264,6 +274,10 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & if(clonh >= r360) clonh = clonh - r360 if(clonh < zero) clonh = clonh + r360 +! Check for valid latitude and longitude + if (abs(clonh) > r360) cycle read_loop + if (abs(clath) > r90 ) cycle read_loop + dlon_earth_deg = clonh dlat_earth_deg = clath dlon_earth=clonh*deg2rad @@ -295,7 +309,8 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & idate5(4) = nint(hdr(4)) !hour idate5(5) = nint(hdr(5)) !minute rsc = hdr(6) !second in real - + + if ( rsc > 60.0_r_kind .or. rsc < zero ) rsc = zero !second in real call w3fs21(idate5,nmind) sstime=float(nmind) @@ -394,6 +409,10 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & endif + elseif ( trim(subset) == 'NC001102' ) then ! DBUOYB + zob = r0_2 + kx = 190 + sstoe = r0_6 elseif ( trim(subset) == 'NC001003' ) then ! MBUOY cid_pos = 0 @@ -426,6 +445,38 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & sstoe = one endif + elseif ( trim(subset) == 'NC001103' ) then ! MBUOYB + + cid_pos = 0 + + do n = 1, n_3mdiscus + if ( cid == cid_mbuoyb(n) ) then + cid_pos = n + endif + enddo + + if ( cid_pos >= 1 .and. cid_pos <= n_comps ) then ! COMPS moored buoyb + zob = r1_2 + kx = 192 + sstoe = one + elseif ( cid_pos > n_comps .and. cid_pos <= n_scripps ) then ! SCRIPPS moored buoyb + zob = r0_45 + kx = 193 + sstoe = 1.5_r_kind + elseif ( cid_pos > n_scripps .and. cid_pos <= n_triton ) then ! Triton buoyb + zob = r1_5 + kx = 194 + sstoe = 0.4_r_kind + elseif ( cid_pos > n_triton .and. cid_pos <= n_3mdiscus ) then ! Moored buoyb with 3-m discus + zob = r0_6 + kx = 195 + sstoe = 1.5_r_kind + elseif ( cid_pos == 0 ) then ! All other moored buoysb (usually with 1-m observation depth) + zob = one + kx = 196 + sstoe = one + endif + elseif ( trim(subset) == 'NC001004' ) then ! LCMAN zob = one kx = 197 diff --git a/src/read_obs.F90 b/src/gsi/read_obs.F90 similarity index 91% rename from src/read_obs.F90 rename to src/gsi/read_obs.F90 index bab6d1620..178d61ed9 100644 --- a/src/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -11,6 +11,7 @@ module read_obsmod ! 2015-05-01 Liu Ling - Add call to read_rapidscat ! 2015-08-20 zhu - add flexibility for enabling all-sky and using aerosol info in radiance ! assimilation. Use radiance_obstype_search from radiance_mod. +! 2017-05-12 Y. Wang and X. Wang - add dbz to be read in, POC: xuguang.wang@ou.edu ! ! subroutines included: ! sub gsi_inquire - inquire statement supporting fortran earlier than 2003 @@ -131,6 +132,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) ! 2015-01-16 ejones - add saphir ! 2016-09-19 guo - properly initialized nread, in case of for quick-return cases. ! 2017-11-16 dutta - adding KOMPSAT5 bufr i.d for reading the data. +! 2019-03-27 h. liu - add abi ! ! ! input argument list: @@ -168,6 +170,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) integer(i_kind) :: ireadsb,ireadmg,kx,nc,said real(r_double) :: satid,rtype character(8) subset + logical,parameter:: GMAO_READ=.false. satid=1 ! debug executable wants default value ??? idate=0 @@ -178,9 +181,11 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) if(trim(dtype) == 'tcp' .or. trim(filename) == 'tldplrso')return if(trim(filename) == 'mitmdat' .or. trim(filename) == 'mxtmdat')return if(trim(filename) == 'satmar')return + if(trim(dtype) == 'dbz' )return ! Use routine as usual - if(lexist)then + + if(lexist .and. trim(dtype) /= 'tcp' )then lnbufr = 15 open(lnbufr,file=trim(filename),form='unformatted',status ='unknown') call openbf(lnbufr,'IN',lnbufr) @@ -220,6 +225,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) kidsat = 56 else if(jsatid == 'm10')then kidsat = 57 + else if(jsatid == 'm11')then + kidsat = 70 else if(jsatid == 'n08')then kidsat=200 else if(jsatid == 'n09')then @@ -286,6 +293,10 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) kidsat=258 else if(jsatid == 'g15' .or. jsatid == 'g15_prep')then kidsat=259 + else if(jsatid == 'g16' .or. jsatid == 'g16_prep')then + kidsat=270 + else if(jsatid == 'g17' .or. jsatid == 'g17_prep')then + kidsat=271 else if(jsatid == 'n05')then kidsat=705 else if(jsatid == 'n06')then @@ -344,6 +355,21 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) end do nread = nread + 1 end do fileloop + else if(trim(filename) == 'wcpbufr')then + lexist = .false. + file2loop: do while(ireadmg(lnbufr,subset,idate2) >= 0) + do while(ireadsb(lnbufr)>=0) + call ufbint(lnbufr,rtype,1,1,iret,'TYP') + kx=nint(rtype) + do nc=1,nconvtype + if(trim(ioctype(nc)) == trim(dtype) .and. kx == ictype(nc) .and. icuse(nc) > minuse)then + lexist = .true. + exit file2loop + end if + end do + end do + nread = nread + 1 + end do file2loop else if(trim(filename) == 'gps_ref' .or. trim(filename) == 'gps_bnd')then lexist = .false. gpsloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) @@ -354,6 +380,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) said=nint(satid) if(((said > 739) .and.(said < 746)).or.(said == 820) .or. (said == 825) .or. & (said == 786).or. (said == 4) .or.(said == 3).or. & + ( GMAO_READ .and. said == 5) .or. & (said == 421).or. (said == 440).or.(said == 821)) then lexist=.true. exit gpsloop @@ -629,13 +656,19 @@ subroutine read_obs(ndata,mype) ! 2016-04-28 J. Jung - added logic for RARS and direct broadcast data from NESDIS/UW. ! 2016-05-05 pondeca - add 10-m u-wind and v-wind (uwnd10m, vwnd10m) ! 2016-09-19 Guo - replaced open(obs_input_common) with "call unformatted_open(obs_input_common)" +! 2017-05-12 Y. Wang and X. Wang - add multi-interface to read in dBZ (nc) and radial velocity (ascii) ! 2016-12-14 lippi - Fixed bug of using observations twice when both ! l2rwbufr and radarbufr are in the OBS_INPUT table. ! Changed the dsis entries for l2rwbufr and radarbufr to ! l2rw and l3rw respectively. Also make use of nml ! option vadwnd_l2rw_qc. -! 2017-08-31 Li - move gsi_nstcoupler_init & gsi_nstcoupler_read to getsfc in sathin.F90 +! 2017-08-31 Li - move gsi_nstcoupler_init & gsi_nstcoupler_set to getsfc in sathin.F90 ! - move gsi_nstcoupler_final from create_sfc_grids to here +! 2017-12-05 Wargan - added OMPS ozone +! 2018-01-23 Apodaca - add GOES/GLM lightning data +! 2018-07-09 Todlng - move gsi_nstcoupler_final to destroy_sfc (consistency) +! 2019-01-15 Li - add to handle mbuoyb +! 2019-03-27 h. liu - add abi ! ! ! input argument list: @@ -658,8 +691,9 @@ subroutine read_obs(ndata,mype) use obsmod, only: iadate,ndat,time_window,dplat,dsfcalc,dfile,dthin, & dtype,dval,dmesh,obsfile_all,ref_obs,nprof_gps,dsis,ditype,& perturb_obs,lobserver,lread_obs_save,obs_input_common, & - reduce_diag,nobs_sub,dval_use - use gsi_nstcouplermod, only: nst_gsi,gsi_nstcoupler_final + reduce_diag,nobs_sub,dval_use,hurricane_radar,l2rwthin !Xu + use gsi_nstcouplermod, only: nst_gsi +! use gsi_nstcouplermod, only: gsi_nstcoupler_set use qcmod, only: njqc,vadwnd_l2rw_qc use gsi_4dvar, only: l4dvar use satthin, only: super_val,super_val1,superp,makegvals,getsfc,destroy_sfc @@ -678,12 +712,13 @@ subroutine read_obs(ndata,mype) use convb_uv,only:convb_uv_read use guess_grids, only: ges_prsl,geop_hgtl,ntguessig use radinfo, only: nusis,iuse_rad,jpch_rad,diag_rad - use insitu_info, only: mbuoy_info,read_ship_info + use insitu_info, only: mbuoy_info,mbuoyb_info,read_ship_info use aeroinfo, only: nusis_aero,iuse_aero,jpch_aero,diag_aero use ozinfo, only: nusis_oz,iuse_oz,jpch_oz,diag_ozone use pcpinfo, only: npcptype,nupcp,iusep,diag_pcp use convinfo, only: nconvtype,ioctype,icuse,diag_conv,ithin_conv use chemmod, only : oneobtest_chem,oneob_type_chem,oneobschem + use lightinfo, only: nlighttype,iuse_light,diag_light use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof,aircraft_t_bc_ext,mype_airobst use gsi_io, only: mype_io use rapidrefresh_cldsurf_mod, only: i_gsdcldanal_type @@ -693,6 +728,9 @@ subroutine read_obs(ndata,mype) use m_extOzone, only: extOzone_read use mpeu_util, only: warn use gsi_unformatted, only: unformatted_open + + use mrmsmod,only: l_mrms_sparse_netcdf + implicit none ! Declare passed variables @@ -704,18 +742,18 @@ subroutine read_obs(ndata,mype) ! Declare local variables logical :: lexist,ssmis,amsre,sndr,hirs,avhrr,lexistears,lexistdb,use_prsl_full,use_hgtl_full - logical :: use_sfc,nuse,use_prsl_full_proc,use_hgtl_full_proc,seviri,mls + logical :: use_sfc,nuse,use_prsl_full_proc,use_hgtl_full_proc,seviri,mls,abi logical,dimension(ndat):: belong,parallel_read,ears_possible,db_possible logical :: modis,use_sfc_any logical :: acft_profl_file character(10):: obstype,platid character(22):: string - character(15):: infile + character(120):: infile character(20):: sis integer(i_kind) i,j,k,ii,nmind,lunout,isfcalc,ithinx,ithin,nread,npuse,nouse integer(i_kind) nprof_gps1,npem1,krsize,len4file,npemax,ilarge,nlarge,npestart integer(i_llong) :: lenbytes - integer(i_kind):: npetot,npeextra,mmdat + integer(i_kind):: npetot,npeextra,mmdat,nodata integer(i_kind):: iworld,iworld_group,next_mype,mm1,iix integer(i_kind):: mype_root integer(i_kind):: minuse,lunsave,maxproc,minproc @@ -807,6 +845,7 @@ subroutine read_obs(ndata,mype) avhrr = index(obstype,'avhrr') /= 0 modis = index(obstype,'modis') /= 0 seviri = index(obstype,'seviri') /= 0 + abi = index(obstype,'abi') /= 0 mls = index(obstype,'mls') /= 0 if(obstype == 'mls20' ) nmls_type=nmls_type+1 if(obstype == 'mls22' ) nmls_type=nmls_type+1 @@ -830,9 +869,11 @@ subroutine read_obs(ndata,mype) obstype == 'mitm' .or. obstype=='pmsl' .or. & obstype == 'howv' .or. obstype=='tcamt' .or. & obstype=='lcbas' .or. obstype=='cldch' .or. obstype == 'larcglb' .or. & - obstype=='uwnd10m' .or. obstype=='vwnd10m') then + obstype=='uwnd10m' .or. obstype=='vwnd10m' .or. obstype=='dbz' ) then ditype(i) = 'conv' - else if( hirs .or. sndr .or. seviri .or. & + else if (obstype == 'swcp' .or. obstype == 'lwcp') then + ditype(i) = 'wcp' + else if( hirs .or. sndr .or. seviri .or. abi .or. & obstype == 'airs' .or. obstype == 'amsua' .or. & obstype == 'msu' .or. obstype == 'iasi' .or. & obstype == 'amsub' .or. obstype == 'mhs' .or. & @@ -848,7 +889,10 @@ subroutine read_obs(ndata,mype) ditype(i) = 'ozone' else if (obstype == 'sbuv2' & .or. obstype == 'omi' & + .or. obstype == 'ompstc8' & + .or. obstype == 'ompsnp' & .or. obstype == 'gome' & + .or. index(obstype, 'omps') /= 0 & .or. mls & ) then ditype(i) = 'ozone' @@ -860,6 +904,8 @@ subroutine read_obs(ndata,mype) ditype(i) = 'gps' else if ( index(obstype,'aod') /= 0 ) then ditype(i) = 'aero' + else if (obstype == 'goes_glm') then + ditype(i) = 'light' else write(6,*)'READ_OBS: ***ERROR*** - unknown ob type ',trim(obstype) end if @@ -897,6 +943,11 @@ subroutine read_obs(ndata,mype) do j=1,jpch_aero if(trim(dsis(i)) == trim(nusis_aero(j)) .and. iuse_aero(j) > minuse)nuse=.true. end do + else if(ditype(i) == 'light')then + if(diag_light .and. .not. reduce_diag)minuse=-2 + do j=1,nlighttype + if(iuse_light(j) > minuse) nuse=.true. + end do else nuse=.true. end if @@ -929,6 +980,8 @@ subroutine read_obs(ndata,mype) ! parallel_read(i)= .true. else if(seviri)then parallel_read(i)= .true. + else if(abi)then + parallel_read(i)= .true. else if(obstype == 'cris' .or. obstype == 'cris-fsr')then parallel_read(i)= .true. else if(avhrr)then @@ -1190,6 +1243,9 @@ subroutine read_obs(ndata,mype) if(obstype == 'rw')then use_hgtl_full=.true. if(belong(i))use_hgtl_full_proc=.true. + else if(obstype == 'dbz')then + use_hgtl_full=.true. + if(belong(i))use_hgtl_full_proc=.true. end if if(obstype == 'sst')then if(belong(i))use_sfc=.true. @@ -1268,6 +1324,9 @@ subroutine read_obs(ndata,mype) ! Create moored buoy station ID call mbuoy_info(mype) +! Create moored buoy station ID for mbuoyb with 7-digit station ID + call mbuoyb_info(mype) + ! Create ships info(ID, Depth & Instrument) call read_ship_info(mype) @@ -1433,7 +1492,8 @@ subroutine read_obs(ndata,mype) else if (obstype == 'lghtn' ) then if(i_gsdcldanal_type==2) then call read_lightning(nread,npuse,infile,obstype,lunout,twind,sis,nobs_sub1(1,i)) - else if( i_gsdcldanal_type==1 .or. i_gsdcldanal_type==6 ) then + else if(i_gsdcldanal_type==1 .or. i_gsdcldanal_type==6 & + .or. i_gsdcldanal_type==3 .or. i_gsdcldanal_type==7) then call read_lightning_grid(nread,npuse,infile,obstype,lunout,twind,sis,nobs_sub1(1,i)) endif string='READ_LIGHTNING' @@ -1443,7 +1503,8 @@ subroutine read_obs(ndata,mype) else if (obstype == 'larccld' ) then if(i_gsdcldanal_type==2) then call read_NASA_LaRC_cloud(nread,npuse,nouse,infile,obstype,lunout,sis,nobs_sub1(1,i)) - else if( i_gsdcldanal_type==1) then + else if(i_gsdcldanal_type==1 .or. i_gsdcldanal_type==6 & + .or. i_gsdcldanal_type==3 .or. i_gsdcldanal_type==7) then call read_nasa_larc(nread,npuse,infile,obstype,lunout,twind,sis,nobs_sub1(1,i)) end if string='READ_NASA_LaRC' @@ -1454,15 +1515,53 @@ subroutine read_obs(ndata,mype) ! Process radar winds else if (obstype == 'rw') then - if (vadwnd_l2rw_qc) then - write(6,*)'READ_OBS: radial wind,read_radar,dfile=',infile,',dsis=',sis - call read_radar(nread,npuse,nouse,infile,lunout,obstype,twind,sis,& + if( trim(infile) == 'vr_vol' )then + call read_radar_wind_ascii(nread,npuse,nouse,infile,lunout,obstype,sis,& + hgtl_full,nobs_sub1(1,i)) + string='READ_RADAR_WIND' + else if (hurricane_radar) then + if (sis == 'rw' ) then + write(6,*)'READ_OBS: radial wind,read_radar,dfile=',infile,',dsis=',sis + call read_radar(nread,npuse,nouse,infile,lunout,obstype,twind,sis,& hgtl_full,nobs_sub1(1,i)) - string='READ_RADAR' - else if (sis == 'l2rw') then - write(6,*)'READ_OBS: radial wind,read_radar_l2rw_novadqc,dfile=',infile,',dsis=',sis - call read_radar_l2rw_novadqc(npuse,nouse,lunout,obstype,sis,nobs_sub1(1,i)) - string='READ_RADAR_L2RW_NOVADQC' + string='READ_RADAR' + else if (sis == 'l2rw') then + if (l2rwthin)then !Xu + call read_radar_l2rw(npuse,nouse,lunout,obstype,sis,nobs_sub1(1,i),hgtl_full) !Xu + string='READ_RADAR_L2RW_NOVADQC' + else + write(6,*)'READ_OBS: radial wind,read_radar_l2rw_novadqc,dfile=',infile,',dsis=',sis + call read_radar_l2rw_novadqc(npuse,nouse,lunout,obstype,sis,nobs_sub1(1,i)) + string='READ_RADAR_L2RW_NOVADQC' + end if + end if + else + if (vadwnd_l2rw_qc) then + write(6,*)'READ_OBS: radial wind,read_radar,dfile=',infile,',dsis=',sis + call read_radar(nread,npuse,nouse,infile,lunout,obstype,twind,sis,& + hgtl_full,nobs_sub1(1,i)) + string='READ_RADAR' + else if (sis == 'l2rw') then + write(6,*)'READ_OBS: radial wind,read_radar_l2rw_novadqc,dfile=',infile,',dsis=',sis + call read_radar_l2rw_novadqc(npuse,nouse,lunout,obstype,sis,nobs_sub1(1,i)) + string='READ_RADAR_L2RW_NOVADQC' + end if + end if +! Process radar reflectivity from MRMS + else if (obstype == 'dbz' ) then + print *, "calling read_dbz" + if(trim(infile)=='dbzobs.nc')then + call read_dbz_nc(nread,npuse,nouse,infile,lunout,obstype,sis,hgtl_full,nobs_sub1(1,i)) + string='READ_dBZ' + else + call read_dbz_mrms_detect_format(infile,l_mrms_sparse_netcdf) + if(l_mrms_sparse_netcdf) then + call read_dbz_mrms_sparse_netcdf(nread,npuse,nouse,infile,obstype,lunout,sis,nobs_sub1(1,i)) + string='READ_dbz_mrms_sparse_netcdf' + else + call read_dbz_mrms_netcdf(nread,npuse,nouse,infile,obstype,lunout,sis,nobs_sub1(1,i)) + string='READ_dbz_mrms_netcdf' + endif end if ! Process lagrangian data @@ -1501,7 +1600,13 @@ subroutine read_obs(ndata,mype) nobs_sub1(1,i)) string='READ_PBLH' end if conv_obstype_select - +! Process swcp and lwcp + else if (ditype(i) == 'wcp') then + if ( obstype == 'swcp' .or. obstype == 'lwcp' ) then + call read_wcpbufr(nread,npuse,nouse,infile,obstype,lunout,twind,sis, & + prsl_full,nobs_sub1(1,i),read_rec(i)) + string='READ_WCPBUFR' + end if else if (ditype(i) == 'rad')then call radiance_obstype_search(obstype,radmod) @@ -1583,7 +1688,7 @@ subroutine read_obs(ndata,mype) ! Process amsre data else if ( obstype == 'amsre_low' .or. obstype == 'amsre_mid' .or. & obstype == 'amsre_hig' ) then - call read_amsre(mype,val_dat,ithin,isfcalc,rmesh,gstime,& + call read_amsre(mype,val_dat,ithin,isfcalc,rmesh,platid,gstime,& infile,lunout,obstype,nread,npuse,nouse,twind,sis,& mype_root,mype_sub(mm1,i),npe_sub(i),mpi_comm_sub(i), & nobs_sub1(1,i),read_rec(i),dval_use) @@ -1601,7 +1706,7 @@ subroutine read_obs(ndata,mype) ! Process AMSR2 data else if(obstype == 'amsr2')then - call read_amsr2(mype,val_dat,ithin,rmesh,gstime,& + call read_amsr2(mype,val_dat,ithin,rmesh,platid,gstime,& infile,lunout,obstype,nread,npuse,nouse,twind,sis,& mype_root,mype_sub(mm1,i),npe_sub(i),mpi_comm_sub(i), & nobs_sub1(1,i)) @@ -1630,13 +1735,20 @@ subroutine read_obs(ndata,mype) mype_root,mype_sub(mm1,i),npe_sub(i),mpi_comm_sub(i), & nobs_sub1(1,i),read_rec(i),dval_use) string='READ_SEVIRI' +! Process GOES-R ABI RADIANCE data + else if(obstype == 'abi') then + call read_abi(mype,val_dat,ithin,rmesh,platid,gstime,& + infile,lunout,obstype,nread,npuse,nouse,twind,sis, & + mype_root,mype_sub(mm1,i),npe_sub(i),mpi_comm_sub(i), & + nobs_sub1(1,i),read_rec(i),dval_use) + string='READ_ABI' ! Process Himawari-8 AHI RADIANCE data else if(obstype == 'ahi') then call read_ahi(mype,val_dat,ithin,rmesh,platid,gstime,& infile,lunout,obstype,nread,npuse,nouse,twind,sis, & mype_root,mype_sub(mm1,i),npe_sub(i),mpi_comm_sub(i), & - nobs_sub1(1,i)) + nobs_sub1(1,i),dval_use) string='READ_AHI' @@ -1703,7 +1815,14 @@ subroutine read_obs(ndata,mype) mype_root,mype_sub(mm1,i),npe_sub(i),mpi_comm_sub(i), & nobs_sub1(1,i)) string='READ_AEROSOL' - + +! Process satellite lightning observations (e.g. GOES/GLM) + else if(ditype(i) == 'light')then + if (obstype == 'goes_glm' ) then + call read_goesglm(nread,ndata,nodata,infile,obstype,lunout,sis) + string='READ_GOESGLM' + endif + end if ditype_select ! Close unit to data file @@ -1749,8 +1868,6 @@ subroutine read_obs(ndata,mype) ! Deallocate arrays containing full horizontal surface fields call destroy_sfc -! Deallocate arrays containing full horizontal nsst fields - if (nst_gsi > 0) call gsi_nstcoupler_final() ! Sum and distribute number of obs read and used for each input ob group call mpi_allreduce(ndata1,ndata,ndat*3,mpi_integer,mpi_sum,mpi_comm_world,& ierror) diff --git a/src/gsi/read_ozone.f90 b/src/gsi/read_ozone.f90 new file mode 100644 index 000000000..5e70667f1 --- /dev/null +++ b/src/gsi/read_ozone.f90 @@ -0,0 +1,1273 @@ +subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & + obstype,twind,sis,ithin,rmesh,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_ozone read ozone data +! prgmmr: yang org: np23 date: 1998-05-15 +! +! abstract: This routine reads SBUV/2 ozone observations. Both layer +! and total column values are read in. The routine has +! the ability to read both IEEE and BUFR format SBUV/2 +! ozone data files. OMI and GOME data is optionally thinned +! to a specific resolution using simple quality control checks. +! +! When running the gsi in regional mode, the code only +! retains those observations that fall within the regional +! domain +! +! program history log: +! 1998-05-15 yang, weiyu +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-16 treadon - update documentation +! 2004-07-29 treadon - add only to module use, add intent in/out +! 2004-09-17 todling - fixed intent of jsatid +! 2004-12-02 todling - compilation in OSF1 forces big_endian for bufr files; +! need to force little_endian for ieee files +! 2004-12-22 kokron - change cpp tokens to add support for ifort compiler +! efc does not have a convert option so it should use +! the other 'open' +! 2005-03-14 treadon - define numeric constants to r_kind precision +! 2005-05-12 wu - add OMI total ozone +! 2005-06-27 guo - bug fix: hour read from header was incorrect +! 2005-09-08 derber - modify to use input group time window +! 2005-09-19 treadon - add check on NOAA-17 sbuv data (toss bad data) +! 2005-10-17 treadon - add grid and earth relative obs location to output file +! 2005-10-18 treadon - remove array obs_load and call to sumload +! 2005-12-23 treadon - bound longitude to be less than 360.0 +! 2006-01-26 treadon - remove ieee sbuv option +! 2006-02-03 derber - modify for new obs control and obs count +! 2007-03-01 tremolet - measure time from beginning of assimilation window +! 2007-07-10 zhou - modify to read version 8 SBUV/2 BUFR data(keep +! option to read version 6 data), also add +! total ozone and ozone profile quality control. +! 2007-09-11 h.liu - add kidsat for nimbus-7, n09, n11, n14 +! 2007-10-16 zhou - organize ozone flag control for all satellites +! 2008-04-16 h.liu - thin OMI and read in GOME data +! 2008-05-27 safford - rm unused vars and uses +! 2008-05-30 treadon - accept version8 poq=7 obs for further processing +! 2008-06-01 treadon - adjust logic to correctly handle zero length BUFR files +! 2008-06-03 treadon - add use_poq7 flag +! 2008-09-08 lueken - merged ed's changes into q1fy09 code +! 2009-01-20 sienkiewicz - merge in changes for MLS ozone +! 2009-04-21 derber - add ithin to call to makegrids +! 2009-3-05 h.liu - read in OMI bufr, QC GOME2 and OMI +! 2009-7-02 h.liu - toss the OMI data with AFBO=3 (c-pair correction) and clean up codes +! 2010-05-26 treadon - add timedif=zero for l4dvar (used in thinning) +! 2010-06-02 sienkiewicz - care for closing bufr other than for o3lev +! 2011-07-04 todling - fixes to run either single or double precision +! 2011-08-01 lueken - replaced F90 with f90 (no machine logic) +! 2012-10-12 h.liu - read in MLS v2 Near Real Time (NRT) and v2.2 standard bufr data +! 2013-01-17 h.liu - read in MLS v3 Near Real Time (NRT) +! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) +! 2014-02-03 guo - removed unused "o3lev" handling, which can (and should) be +! implemented again in module m_extOzone, if ever needed. +! 2015-02-23 Rancic/Thomas - add thin4d to time window logical +! 2015-10-01 guo - consolidate use of ob location (in deg +! 2017-12-05 wargan - implement OMPS nadir capability +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. +! 2018-06-26 todling - total column nadir OMPS of Wargan and Liu handling redundant NM/TC8 names +! 2018-08-13 H. Liu - add capability to use OMPS nadir profiler and nadir mapper data +! +! input argument list: +! obstype - observation type to process +! jsatid - satellite id to read +! infile - unit from which to read ozone data +! gstime - analysis time in minutes from reference date +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! twind - input group time window (hours) +! sis - satellite/instrument/sensor indicator +! ithin - flag to thin data +! rmesh - thinning mesh size (km) +! +! output argument list: +! nread - number of sbuv/omi ozone observations read +! ndata - number of sbuv/omi ozone profiles retained for further processing +! nodata - number of sbuv/omi ozone observations retained for further processing +! nobs - array of observations on each subdomain for each processor +! +! remarks: +! NCEP stopped producing IEEE format sbuv ozone files in April 2004. +! Hence, the IEEE portion of this routine no future application. It +! is retained in the GSI package for use with retrospective runs. The +! IEEE portion of this routine may be removed from the GSI at a later date. +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,r_double,i_kind + use satthin, only: makegrids,map2tgrid,destroygrids, & + finalcheck,itxmax + use satthin, only: radthin_time_info,tdiff2crit + use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons + use constants, only: deg2rad,zero,one_tenth,r60inv,two + use obsmod, only: nloz_v6,nloz_v8 + use obsmod, only: time_window_max + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen + use radinfo, only: dec2bin + use qcmod, only: use_poq7 + use ozinfo, only: jpch_oz,nusis_oz,iuse_oz + use mpimod, only: npe + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype,infile,jsatid + character(len=20),intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout,ithin + integer(i_kind) ,intent(inout) :: nread + integer(i_kind),dimension(npe) ,intent(inout) :: nobs + integer(i_kind) ,intent(inout) :: ndata,nodata + real(r_kind) ,intent(in ) :: gstime,twind,rmesh + +! Declare local parameters + real(r_kind),parameter:: r6 = 6.0_r_kind + real(r_kind),parameter:: r76 = 76.0_r_kind + real(r_kind),parameter:: r84 = 84.0_r_kind + + real(r_kind),parameter:: r360 = 360.0_r_kind + real(r_kind),parameter:: rmiss = -9999.9_r_kind + real(r_kind),parameter:: badoz = 10000.0_r_kind + +! Declare local variables + logical outside,version6,version8,iuse + + character(2) version + character(8) subset,subset6,subset8,subset8_ompsnp + character(49) ozstr,ozostr + character(63) lozstr + character(51) ozgstr + character(27) ozgstr2 + character(42) ozostr2 + character(64) mlstr + character(14) mlstrl + + integer(i_kind) maxobs,nozdat,nloz + integer(i_kind) idate,jdate,ksatid,kk,iy,iret,im,ihh,idd,lunin + integer(i_kind) nmind,i,j + integer(i_kind) nmrecs,k,ilat,ilon,nreal,nchanl +! integer(i_kind) ithin,kidsat + integer(i_kind) kidsat + integer(i_kind) idate5(5) + integer(i_kind) JULIAN,IDAYYR,IDAYWK + integer(i_kind) ikx + integer(i_kind) decimal,binary(14),binary_mls(18) + + + integer(i_kind) itx,itt,ipoq7 + + real(r_kind) tdiff,sstime,dlon,dlat,t4dv,crit1,dist1 + real(r_kind) slons0,slats0,rsat,solzen,solzenp,dlat_earth,dlon_earth + real(r_kind) dlat_earth_deg,dlon_earth_deg + real(r_kind),allocatable,dimension(:):: poz + +! maximum number of observations set to + real(r_kind),allocatable,dimension(:,:):: ozout + real(r_double) toq,poq + real(r_double),dimension(nloz_v6):: ozone_v6 + real(r_double),dimension(29,nloz_v8):: ozone_v8 + real(r_double),dimension(10):: hdroz + real(r_double),dimension(10):: hdrozg + real(r_double),dimension(5):: hdrozg2 + real(r_double),dimension(10):: hdrozo + real(r_double),dimension(8) :: hdrozo2 + real(r_double),dimension(13):: hdrmls + real(r_double),allocatable,dimension(:,:) :: hdrmlsl + real(r_kind),allocatable,dimension(:):: mlspres,mlsoz,mlsozpc,usage1 + integer(i_kind),allocatable,dimension(:):: ipos + + real(r_double) totoz,hdrmls13 + integer(i_kind) :: k0 + logical :: first,read_success + + real(r_double),allocatable,dimension(:,:):: olpdtsq,lpsdvals + real(r_double),allocatable,dimension(:):: press,omr,omrstd + + real(r_double) said, lat, lon, year, month, day, hour, minu + real(r_double) soza + +! MLS data version: mlsv=22 is version 2.2 standard data; +! mlsv=20 is v2 near-real-time data +! mlsv=30 is v3 near-real-time data + integer(i_kind) :: mlsv + + data lozstr & + / 'OSP12 OSP11 OSP10 OSP9 OSP8 OSP7 OSP6 OSP5 OSP4 OSP3 OSP2 OSP1 ' / + data ozgstr & + / 'SAID CLAT CLON YEAR DOYR HOUR MINU SECO SOZA SOLAZI' / + data ozgstr2 & + / 'CLDMNT SNOC ACIDX STKO FOVN' / + data ozostr & + / 'SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SECO SOZA' / +! since 2009020412, the omi bufr contains fovn + data ozostr2 & + / 'CLDMNT ACIDX STKO VZAN TOQC TOQF FOVN AFBO' / + + data mlstr & + / 'SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SECO SOZA CONV MLST PCCF' / + data mlstrl & + / 'PRLC OZMX OZMP' / + + data lunin / 10 / + data subset6 / 'NC008010' / + data subset8 / 'NC008011' / + data subset8_ompsnp / 'NC008017'/ + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh + +!************************************************************************** +! Set constants. Initialize variables + rsat=999._r_kind + maxobs=1e6 + ilon=3 + ilat=4 + ipoq7=0 + if (use_poq7) ipoq7=7 + + +! Separately process sbuv or omi ozone + + if (obstype == 'sbuv2' .or. obstype == 'ompsnp') then + + nreal=9 + open(lunin,file=trim(infile),form='unformatted') + nmrecs=0 + call openbf(lunin,'IN',lunin) + call datelen(10) + call readmg(lunin,subset,idate,iret) + + version6 = .false. + version8 = .false. + if (subset == subset6) then + version6 = .true. + nloz = nloz_v6 + version = 'v6' + elseif (subset == subset8 .or. subset == subset8_ompsnp) then ! OMPS-NP processed with V8 algorithm + version8 = .true. + nloz = nloz_v8 + version = 'v8' + else + write(6,*)'READ_OZONE: *** WARNING: unknown layer ozone version type, subset=',subset + write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid + write(6,*)' SKIP PROCESSING OF THIS OZONE LAYER FILE' + call closbf(lunin) + close(lunin) + return + endif + +! Set dependent variables and allocate arrays + nchanl=nloz+1 + nozdat=nreal+nchanl + allocate (ozout(nozdat,maxobs)) + allocate ( poz(nloz+1)) + + +! Set BUFR string based on sbuv version + if (version6) then + ozstr='SAID CLAT CLON YEAR MNTH DAYS HOUR MINU OSZA OPSZ' + else if (version8) then + ozstr='SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SECO SOZA' + endif + + read_loop1: do + call readsb(lunin,iret) + if (iret/=0) then + call readmg(lunin,subset,jdate,iret) + if (iret/=0) exit read_loop1 + cycle read_loop1 + endif + +! extract header information +! BUFR code values for satellite identifiers are listed in +! Dennis Keyser's website, +! http://www.emc.ncep.noaa.gov/mmb/papers/keyser/Satellite_Historical.txt + + call ufbint(lunin,hdroz,10,1,iret,ozstr) + rsat = hdroz(1); ksatid=rsat + if(jsatid == 'nim07') kidsat = 767 + if(jsatid == 'n09') kidsat = 201 + if(jsatid == 'n11') kidsat = 203 + if(jsatid == 'n14') kidsat = 205 + if(jsatid == 'n16') kidsat = 207 + if(jsatid == 'n17') kidsat = 208 + if(jsatid == 'n18') kidsat = 209 + if(jsatid == 'n19') kidsat = 223 + if(jsatid == 'npp') kidsat = 224 + if(jsatid == 'n20') kidsat = 225 + if(jsatid == 'n21') kidsat = 226 + + if (ksatid /= kidsat) cycle read_loop1 + + nmrecs=nmrecs+nloz+1 + +! Convert observation location to radians + slats0= hdroz(2) + slons0= hdroz(3) + if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle read_loop1 + if(slons0< zero) slons0=slons0+r360 + if(slons0==r360) slons0=zero + dlat_earth_deg = slats0 + dlon_earth_deg = slons0 + dlat_earth = slats0 * deg2rad + dlon_earth = slons0 * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if(outside) cycle read_loop1 + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + +! Special check for NOAA-17 version 6 +! Before July 2007 NOAA-17 SBUV/2 has a stray light problem which produces +! erroneous ozone profile retrievals for a limited portion +! of its measurements. The contaminated signals only occur +! in the Southern Hemisphere and only for Solar Zenith +! Angles (SZA) greater than 76 Degrees. + + if (version6) then + solzen = hdroz(9) ! solar zenith angle + solzenp= hdroz(10) ! profile solar zenith angle + if (ksatid==208 .and. dlat_earth r76) cycle read_loop1 + else if(version8)then + solzen = hdroz(10) ! solar zenith angle + endif + +! Convert observation time to relative time + idate5(1) = hdroz(4) !year + idate5(2) = hdroz(5) !month + idate5(3) = hdroz(6) !day + idate5(4) = hdroz(7) !hour + idate5(5) = hdroz(8) !minute + call w3fs21(idate5,nmind) + t4dv=real((nmind-iwinbgn),r_kind)*r60inv + sstime=real(nmind,r_kind) + tdiff=(sstime-gstime)*r60inv + if (l4dvar.or.l4densvar) then + if(t4dvwinlen) cycle read_loop1 + else + if(abs(tdiff) > twind) cycle read_loop1 + end if + +! Extract layer ozone values and compute profile total ozone + if (version8) then + call ufbseq(lunin,ozone_v8,29,21,iret,'OZOPQLSQ') + totoz=zero + do k=1,nloz + kk=nloz-k+1 + poz(k) = ozone_v8(6,kk) + totoz=totoz+ozone_v8(6,k) + end do + poz(nloz+1) = totoz + endif + + if (version6) then + call ufbint(lunin,ozone_v6,nloz,1,iret,lozstr) + do k=1,nloz + kk=nloz-k+1 + poz(k) = ozone_v6(kk) + end do + +! extract total ozone + call ufbint(lunin,totoz,1,1,iret,'OTSP') + poz(nloz+1) = totoz + endif + + +! Extract and apply version 8 total and profile ozone quaility information +! Toss observations for which the total ozone error code is neither 0 nor 2 +! Toss observations for which the profile ozone error code is neither 0 nor 1 +! NOTES: +! 1) Profile ozone error code 0 identifies good data; 1 identifies good +! data with a solar zenith angle > 84 degrees; 7 identifies profile +! for which stray light correction applied +! 2) Total ozone error code 0 indentifies good data; 2 identifies good +! data with a solar zenith angle > 84 degrees. +! 3) We do not use the version 6 error flags. Thus, initialize toq and +! poq to 0 (use the data) + + toq=0._r_double + poq=0._r_double + if (version8) then + call ufbint(lunin,toq,1,1,iret,'SBUVTOQ') + call ufbint(lunin,poq,1,1,iret,'SBUVPOQ') + if (toq/=0 .and. toq/=2) cycle read_loop1 + if (poq/=0 .and. poq/=1 .and. poq/=ipoq7) cycle read_loop1 + endif + +! Check ozone layer values. If any layer value is bad, toss entire profile + do k=1,nloz + if (poz(k)>badoz) cycle read_loop1 + end do + +! Write ozone record to output file + ndata=min(ndata+1,maxobs) + nodata=nodata+nloz+1 + ozout(1,ndata)=rsat + ozout(2,ndata)=t4dv + ozout(3,ndata)=dlon ! grid relative longitude + ozout(4,ndata)=dlat ! grid relative latitude + ozout(5,ndata)=dlon_earth_deg ! earth relative longitude (degrees) + ozout(6,ndata)=dlat_earth_deg ! earth relative latitude (degrees) + ozout(7,ndata)=toq ! total ozone error flag + ozout(8,ndata)=poq ! profile ozone error flag + ozout(9,ndata)=solzen ! solar zenith angle + do k=1,nloz+1 + ozout(k+9,ndata)=poz(k) + end do + +! Loop back to read next profile + end do read_loop1 + +! End of bufr ozone block + +! Process GOME-2 data + + else if ( obstype == 'gome') then + + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif + + open(lunin,file=trim(infile),form='unformatted') + nmrecs=0 + call openbf(lunin,'IN',lunin) + call datelen(10) + call readmg(lunin,subset,idate,iret) + + if (subset == 'NC008012') then + write(6,*)'READ_OZONE: GOME-2 data type, subset=',subset + else + write(6,*)'READ_OZONE: *** WARNING: unknown ozone data type, subset=',subset + write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid + call closbf(lunin) + close(lunin) + return + endif + +! Make thinning grids + call makegrids(rmesh,ithin,n_tbin=n_tbin) + +! Set dependent variables and allocate arrays + nreal=14 + nloz=0 + nchanl=1 + nozdat=nreal+nchanl + allocate (ozout(nozdat,itxmax)) + do k=1,itxmax + do i=1,nozdat + ozout(i,k)=rmiss + end do + end do + + iy=0 + idd=0 + ihh=0 + + obsloop: do + call readsb(lunin,iret) + if (iret/=0) then + call readmg(lunin,subset,jdate,iret) + if (iret/=0) exit obsloop + cycle obsloop + endif + +! extract header information + call ufbint(lunin,hdrozg,10,1,iret,ozgstr) + call ufbint(lunin,hdrozg2,5,1,iret,ozgstr2) + rsat = hdrozg(1); ksatid=rsat + + if(jsatid == 'metop-a')kidsat = 4 + if(jsatid == 'metop-b')kidsat = 3 + if(jsatid == 'metop-c')kidsat = 5 + + if (ksatid /= kidsat) cycle obsloop + +! NESDIS does not put a flag for high SZA gome-2 data (SZA > 84 degree) + if ( hdrozg(9) > r84 ) cycle obsloop + + nmrecs=nmrecs+nloz+1 + +! Convert observation location to radians + slats0= hdrozg(2) + slons0= hdrozg(3) + if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle obsloop + if(slons0< zero) slons0=slons0+r360 + if(slons0==r360) slons0=zero + dlat_earth_deg = slats0 + dlon_earth_deg = slons0 + dlat_earth = slats0 * deg2rad + dlon_earth = slons0 * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if(outside) cycle obsloop + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + +! Convert observation time to relative time + idate5(1) = hdrozg(4) !year + IDAYYR = hdrozg(5) ! Day of year + JULIAN = -31739 + 1461 * (idate5(1) + 4799) /4 & + -3 * ((idate5(1) + 4899) / 100) / 4 + IDAYYR + call w3fs26(JULIAN,idate5(1),idate5(2),idate5(3),IDAYWK,IDAYYR) +! idate5(2) month +! idate5(3) day + idate5(4) = hdrozg(6) !hour + idate5(5) = hdrozg(7) !minute + call w3fs21(idate5,nmind) + t4dv=real((nmind-iwinbgn),r_kind)*r60inv + sstime=real(nmind,r_kind) + tdiff=(sstime-gstime)*r60inv + if (l4dvar.or.l4densvar) then + if(t4dvwinlen) cycle obsloop + else + if(abs(tdiff) > twind) cycle obsloop + end if + +! extract total ozone + call ufbint(lunin,totoz,1,1,iret,'OZON') + + if (totoz > badoz ) cycle obsloop + +! only accept flag 0 (good) data + toq=0._r_double + call ufbint(lunin,toq,1,1,iret,'GOMEEF') + if (toq/=0) cycle obsloop + +! only accept scan positions from 2 to 25 + if( hdrozg2(5) < two .or. hdrozg2(5) > 25.0_r_kind ) cycle obsloop + +! thin GOME data +! GOME data has bias when the satellite looks to the east. Consider QC out this data. + + crit0 = 0.01_r_kind + timeinflat=r6 + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) + if(.not. iuse) cycle obsloop + + call finalcheck(dist1,crit1,itx,iuse) + if(.not. iuse) cycle obsloop + + ndata=ndata+1 + nodata=ndata + + ozout(1,itx)=rsat + ozout(2,itx)=t4dv + ozout(3,itx)=dlon ! grid relative longitude + ozout(4,itx)=dlat ! grid relative latitude + ozout(5,itx)=dlon_earth_deg ! earth relative longitude (degrees) + ozout(6,itx)=dlat_earth_deg ! earth relative latitude (degrees) + ozout(7,itx)=toq ! total ozone error flag + ozout(8,itx)=hdrozg(9) ! solar zenith angle + ozout(9,itx)=hdrozg(10) ! solar azimuth angle + ozout(10,itx)=hdrozg2(1) ! CLOUD AMOUNT IN SEGMENT + ozout(11,itx)=hdrozg2(2) ! SNOW COVER + ozout(12,itx)=hdrozg2(3) ! AEROSOL CONTAMINATION INDEX + ozout(13,itx)=hdrozg2(4) ! ASCENDING/DESCENDING ORBIT QUALIFIER + ozout(14,itx)=hdrozg2(5) ! scan position (fovn) + ozout(15,itx)=totoz + + end do obsloop + +! End of GOME bufr block + + +! Process OMI/OMPS data without efficiency factors + else if ( obstype == 'omi' .or. obstype == 'ompsnm' .or. obstype == 'ompstc8') then + + + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif + + nmrecs=0 + open(lunin,file=trim(infile),form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + call readmg(lunin,subset,idate,iret) + + select case(subset) + case('NC008013') + write(6,*)'READ_OZONE: OMI data type, subset=',subset + case('NC008018') + write(6,*)'READ_OZONE: OMPS Nadir Mapper data type, subset=',subset + case default + write(6,*)'READ_OZONE: *** WARNING: unknown ozone data type, subset=',subset + write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid + call closbf(lunin) + close(lunin) + return + end select + +! Make thinning grids + call makegrids(rmesh,ithin,n_tbin=n_tbin) + +! Set dependent variables and allocate arrays + nreal=14 + nloz=0 + nchanl=1 + nozdat=nreal+nchanl + allocate (ozout(nozdat,itxmax)) + do k=1,itxmax + do i=1,nozdat + ozout(i,k)=rmiss + end do + end do + + iy=0 + im=0 + idd=0 + ihh=0 + + read_loop2: do + call readsb(lunin,iret) + if (iret/=0) then + call readmg(lunin,subset,jdate,iret) + if (iret/=0) exit read_loop2 + cycle read_loop2 + endif + +! extract header information + call ufbint(lunin,hdrozo,10,1,iret,ozostr) + call ufbint(lunin,hdrozo2,8,1,iret,ozostr2) + rsat = hdrozo(1); ksatid=rsat + + if(jsatid == 'aura')kidsat = 785 + if(jsatid == 'npp') kidsat = 224 + if(jsatid == 'n20') kidsat = 225 + if(jsatid == 'n21') kidsat = 226 + if (ksatid /= kidsat) cycle read_loop2 + + + nmrecs=nmrecs+nloz+1 + +! Convert observation location to radians + slats0= hdrozo(2) + slons0= hdrozo(3) + if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle read_loop2 + if(slons0< zero) slons0=slons0+r360 + if(slons0==r360) slons0=zero + dlat_earth_deg = slats0 + dlon_earth_deg = slons0 + dlat_earth = slats0 * deg2rad + dlon_earth = slons0 * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if(outside) cycle read_loop2 + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + +! convert observation time to relative time + idate5(1) = hdrozo(4) !year + idate5(2) = hdrozo(5) !month + idate5(3) = hdrozo(6) !day + idate5(4) = hdrozo(7) !hour + idate5(5) = hdrozo(8) !minute + call w3fs21(idate5,nmind) + + t4dv=real((nmind-iwinbgn),r_kind)*r60inv + sstime=real(nmind,r_kind) + tdiff=(sstime-gstime)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle read_loop2 + else + if(abs(tdiff) > twind) cycle read_loop2 + end if + +! extract total ozone + call ufbint(lunin,totoz,1,1,iret,'OZON') + if (totoz > badoz ) cycle read_loop2 + +! QC for omi_aura + if (obstype == 'omi') then + +! Bit 10 in TOQF represents row anomaly. + decimal=int(hdrozo2(6)) + call dec2bin(decimal,binary,14) + if (binary(10) == 1 ) cycle read_loop2 + +! remove the bad scan position data: fovn beyond 25 + if (hdrozo2(7) >=25.0_r_double) cycle read_loop2 + + end if +! only accept flag 0 1, flag 2 is high SZA data which is not used for now + toq=hdrozo2(5) + if (toq/=0 .and. toq/=1) cycle read_loop2 + +! remove the data in which the C-pair algorithm ((331 and 360 nm) is used. + if (hdrozo2(8) == 3_r_double .or. hdrozo2(8) == 13_r_double) cycle read_loop2 + +! thin OMI/OMPS-NM(or TC8) data + + crit0 = 0.01_r_kind + timeinflat=r6 + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) + if(.not. iuse)cycle read_loop2 + + call finalcheck(dist1,crit1,itx,iuse) + if(.not. iuse)cycle read_loop2 + + ndata=ndata+1 + nodata=ndata + + ozout(1,itx)=rsat + ozout(2,itx)=t4dv + ozout(3,itx)=dlon ! grid relative longitude + ozout(4,itx)=dlat ! grid relative latitude + ozout(5,itx)=dlon_earth_deg ! earth relative longitude (degrees) + ozout(6,itx)=dlat_earth_deg ! earth relative latitude (degrees) + ozout(7,itx)=hdrozo2(5) ! total ozone quality code + ozout(8,itx)=hdrozo(10) ! solar zenith angle + if (obstype == 'omi') then + ozout(9,itx)=binary(10) ! row anomaly flag + end if + ozout(10,itx)=hdrozo2(1) ! cloud amount + ozout(11,itx)=hdrozo2(4) ! vzan + ozout(12,itx)=hdrozo2(2) ! aerosol index + ozout(13,itx)=hdrozo2(3) ! ascending/descending + ozout(14,itx)=hdrozo2(7) ! scan position + ozout(15,itx)=totoz + +! End of loop over observations + end do read_loop2 + +! End of OMI/OMPS-NM(or TC8) block + +! Process MLS bufr data + else if ( index(obstype,'mls')/=0 ) then + + nmrecs=0 + + open(lunin,file=trim(infile),form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + call readmg(lunin,subset,idate,iret) + if (subset == 'NC008015') then + write(6,*)'READ_OZONE: MLS data type, subset=',subset + else + write(6,*)'READ_OZONE: *** WARNING: unknown ozone data type, subset=',subset + write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid + call closbf(lunin) + close(lunin) + return + endif + + read_success=.false. + if(iret==0) then + + call readsb(lunin,iret) + if (iret/=0) then + do + call readmg(lunin,subset,jdate,iret) + if (iret/=0) exit + call readsb(lunin,iret) + if(iret == 0)then + read_success=.true. + exit + end if + end do + endif + endif + + if(read_success)then +! Get # of vertical pressure levels nloz and MLS NRT data version which depends on nloz + allocate(hdrmlsl(3,100)) + call ufbrep(lunin,hdrmlsl,3,100,iret,mlstrl) + nloz=iret +! for NRT data, mlsv=20 or 30 depending on the nloz + mlsv=-999 + if(nloz==37) then + if(index(sis,'mls22')/=0 ) then !mls v2.2 data + mlsv=22 + else if(index(sis,'mls20')/=0 ) then !mls v2 nrt data + mlsv=20 + end if + else if (nloz==55) then !mls v3 nrt data + if (index(sis,'mls30')/=0 ) then + mlsv=30 + endif + else + write(6,*) 'invalid vertical level number: ', nloz + write(6,*) '******STOP*******: error reading MLS vertical levels in read_ozone.f90' + call stop2(338) + end if + deallocate(hdrmlsl) + + write(6,*) 'READ_OZONE: MLS data version=',mlsv + write(6,*) 'READ_OZONE: MLS vertical level number=',nloz + + if (mlsv<0) then + write(6,*) 'inconsistent MLS versions. bufr nloz=',nloz,' obsinput sis= ',trim(sis) + write(6,*) '******STOP*******: error bufr and specified MLS versions' + call stop2(338) + end if + +! Allocate arrays + allocate(hdrmlsl(3,nloz)) + allocate (mlspres(nloz)) + allocate (mlsoz(nloz)) + allocate (mlsozpc(nloz)) + allocate(ipos(nloz)) + allocate (usage1(nloz)) + +! Set dependent variables and allocate arrays + nreal=12 + nchanl=1 + nozdat=nreal+nchanl + allocate (ozout(nozdat,maxobs)) + + do k=1,maxobs + do i=1,nozdat + ozout(i,k)=rmiss + end do + end do + + ikx=0 + k0=0 + ipos=999 + first=.false. + do k=1,jpch_oz + if( (.not. first) .and. index(nusis_oz(k),sis)/=0 ) then + k0=k + first=.true. + end if + if(first .and. index(nusis_oz(k),sis)/=0 ) then + ikx=ikx+1 + ipos(ikx)=k0+ikx-1 + end if + end do + +! Reopen unit to bufr file + call closbf(lunin) + open(lunin,file=trim(infile),form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + call readmg(lunin,subset,idate,iret) + end if + + read_loop4: do + if(.not. read_success) exit + call readsb(lunin,iret) + if (iret/=0) then + call readmg(lunin,subset,jdate,iret) + if (iret/=0) exit read_loop4 + cycle read_loop4 + endif + + do k=1,nloz + if (iuse_oz(ipos(k)) < 0) then + usage1(k) = 100._r_kind + else + usage1(k) = zero + endif + end do + +! extract header information + call ufbint(lunin,hdrmls,13,1,iret,mlstr) + rsat = hdrmls(1); ksatid=rsat + + if(jsatid == 'aura')kidsat = 785 + if (ksatid /= kidsat) cycle read_loop4 + + nmrecs=nmrecs+nloz + +! Convert observation location to radians + slats0= hdrmls(2) + slons0= hdrmls(3) + if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle read_loop4 + if(slons0< zero) slons0=slons0+r360 + if(slons0==r360) slons0=zero + dlat_earth_deg = slats0 + dlon_earth_deg = slons0 + dlat_earth = slats0 * deg2rad + dlon_earth = slons0 * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if(outside) cycle read_loop4 + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + +! convert observation time to relative time + idate5(1) = hdrmls(4) !year + idate5(2) = hdrmls(5) !month + idate5(3) = hdrmls(6) !day + idate5(4) = hdrmls(7) !hour + idate5(5) = hdrmls(8) !minute + call w3fs21(idate5,nmind) + + t4dv=real((nmind-iwinbgn),r_kind)*r60inv + sstime=real(nmind,r_kind) + tdiff=(sstime-gstime)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle read_loop4 + else + if(abs(tdiff) > twind) cycle read_loop4 + end if + +! v2.2 data screening, only accept: +! Pressure range(PRLC): 215-0.02mb (lev5-27) +! Precision(OZMP): positive OZMP; +! Status flag(MLST): only use even number +! Quality(PCCF): use >1.2 for data at 215-100mb & low latitude, +! use >0.4 for data elsewhere +! Convergence(CONV): use <1.8 + +! v2 NRT data screening, only accept: +! Pressure range(PRLC): 68-0.2mb (lev8-23) +! Precision(OZMP): positive OZMP; +! Status flag(MLST): only use even number +! Quality(PCCF): do NOT use <1.2 or >3.0 + +! v3 NRT data screening, only accept: +! Pressure range(PRLC): 261-0.1mb (lev8-43) +! Precision(OZMP): positive OZMP; +! Status flag(MLST): only use even number +! Quality(PCCF): only use if >0.4 +! Convergence(CONV): use <1.2 + +! status: Bit 1 in MLST represents data should not be used +! Note: in BUFR bits are defined from left to right as: 123456789... +! whereas in HDF5 (and the nasa document) bits are defined from right to left as: ...876543210 + decimal=int(hdrmls(12)) + call dec2bin(decimal,binary_mls,18) + if (binary_mls(1) == 1 ) cycle read_loop4 + +! v2.2 data, remove data when convergence>1.8 +! v3 NRT data,remove data when convergence>1.2 + if(mlsv==22) then + if(hdrmls(11) >= 1.8_r_kind) cycle read_loop4 + else if(mlsv==30) then + if(hdrmls(11) >= 1.2_r_kind) cycle read_loop4 + end if + +! extract pressure, ozone mixing ratio and precision + call ufbrep(lunin,hdrmlsl,3,nloz,iret,mlstrl) + + do k=1,nloz + mlspres(k)=log(hdrmlsl(1,k)*0.001_r_kind) ! mls pressure in Pa, coverted to log(cb) + mlsoz(k)=hdrmlsl(2,k) ! ozone mixing ratio in ppmv + mlsozpc(k)=hdrmlsl(3,k) ! ozone mixing ratio precision in ppmv +! there is possibility that mlsoz in bufr is 0 or negative or larger than 100 which are not reasonable values. + if(mlsoz(k)<1.0e-8_r_kind .or. mlsoz(k)>100.0_r_kind ) then + usage1(k)=1000._r_kind +! for v2.2 data, if this unreasonable value happens between 215mb (lev5) and 0.02mb (lev27), throw the whole profile +! for v2 NRT data, if this unreasonable value happens between 68mb (lev8) and 0.2mb (lev23), throw the whole profile +! for v3 NRT data, if this unreasonable value happens between 261mb (lev8) and 0.1mb (lev43), throw the whole profile + if(mlsv==22 .and. (k<=27 .and. k>=5)) cycle read_loop4 + if(mlsv==20 .and. (k<=23 .and. k>=8)) cycle read_loop4 + if(mlsv==30 .and. (k<=43 .and. k>=8)) cycle read_loop4 + end if + end do + + do k=1,nloz +! pressure range + if(mlsv==22) then + if(hdrmlsl(1,k)>21700._r_kind .or. hdrmlsl(1,k)<1._r_kind) usage1(k)=1000._r_kind + else if(mlsv==20) then + if(hdrmlsl(1,k)>6900._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=1000._r_kind + else if(mlsv==30) then + if(hdrmlsl(1,k)>26500._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=1000._r_kind + end if +! only positive precision accepted + if(hdrmlsl(3,k)<=0._r_kind) usage1(k)=1000._r_kind + end do + +! status screening + hdrmls13=hdrmls(13)*0.1_r_kind + if(mlsv==22) then + if (abs(slats0)<30._r_kind) then + do k=1,nloz + if(hdrmlsl(1,k)>10100._r_kind .and. hdrmlsl(1,k)<21700._r_kind) then + if(hdrmls13 <= 1.2_r_kind) usage1(k)=1000._r_kind + else + if(hdrmls13 <= 0.4_r_kind) usage1(k)=1000._r_kind + endif + end do + else + if(hdrmls13 <= 0.4_r_kind) then + do k=1,nloz + usage1(k)=1000._r_kind + end do + end if + end if + else if(mlsv==20) then + if(hdrmls13 <= 1.2_r_kind .or. hdrmls13 >= 3.0_r_kind) then + do k=1,nloz + usage1(k)=1000._r_kind + end do + end if + else if(mlsv==30) then + if(hdrmls13 <= 0.4_r_kind) then + do k=1,nloz + usage1(k)=1000._r_kind + end do + end if + end if + + do k=1,nloz + + ndata=min(ndata+1,maxobs) + nodata=ndata +! if(ndata >= nloz) cycle read_loop4 + + ozout(1,ndata)=rsat + ozout(2,ndata)=t4dv + ozout(3,ndata)=dlon ! grid relative longitude + ozout(4,ndata)=dlat ! grid relative latitude + ozout(5,ndata)=dlon_earth_deg ! earth relative longitude (degrees) + ozout(6,ndata)=dlat_earth_deg ! earth relative latitude (degrees) + ozout(7,ndata)=hdrmls(10) ! solar zenith angle + + ozout(8,ndata)=usage1(k) ! + ozout(9,ndata)=mlspres(k) ! mls pressure in log(cb) + ozout(10,ndata)=mlsozpc(k) ! ozone mixing ratio precision in ppmv + ozout(11,ndata)=float(ipos(k)) ! pointer of obs level index in ozinfo.txt + ozout(12,ndata)=nloz ! # of mls vertical levels + ozout(nreal+1,ndata)=mlsoz(k) ! ozone mixing ratio in ppmv + end do + + end do read_loop4 + +! End of MLS bufr loop + +!Process OMPS LP data + elseif(index(obstype,'ompslp') /= 0 )then + + nloz = 81 + nreal=15 + nchanl=1 + nozdat=nreal+nchanl + read_success=.false. + + open(lunin,file=trim(infile),form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + call readmg(lunin,subset,idate,iret) + if (iret == 0 .and. subset == 'NC008019') then + read_success=.true. + else + write(6,*)'READ_OZONE: *** WARNING: unknown ozone data type, subset=',subset + write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid + call closbf(lunin) + close(lunin) + return + endif + + ! Allocate arrays + allocate(olpdtsq(12,81)) + allocate(lpsdvals(3,81)) + allocate(press(nloz)) + allocate(omr(nloz)) + allocate(omrstd(nloz)) + allocate(usage1(nloz)) + allocate(ipos(nloz)) + allocate(ozout(nozdat,maxobs)) + + do k=1,maxobs + do i=1,nozdat + ozout(i,k)=rmiss + enddo + enddo + + ikx=0 + k0=0 + ipos=999 + first=.false. + do k=1,jpch_oz + if( (.not. first) .and. index(nusis_oz(k),sis)/=0 ) then + k0=k + first=.true. + end if + if(first .and. index(nusis_oz(k),sis)/=0 ) then + ikx=ikx+1 + ipos(ikx)=k0+ikx-1 + endif + enddo + + read_loop5: do + if(.not. read_success) exit + call readsb(lunin,iret) + if (iret/=0) then + call readmg(lunin,subset,jdate,iret) + if (iret/=0) exit read_loop5 + cycle read_loop5 + endif + + call ufbint(lunin,said,1,1,iret,"SAID") + + !Convert observation location to radians + call ufbint(lunin,lat,1,1,iret,"CLATH") + call ufbint(lunin,lon,1,1,iret,"CLONH") + if(abs(lat)>90._r_kind .or. abs(lon)>r360) cycle read_loop5 + if(lon< zero) lon=lon+r360 + if(lon==r360) lon=zero + dlat_earth_deg = lat + dlon_earth_deg = lon + dlat_earth = lat * deg2rad + dlon_earth = lon * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if(outside) cycle read_loop5 + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + + !Convert observation time to relative time + call ufbint(lunin,year,1,1,iret,"YEAR") + call ufbint(lunin,month,1,1,iret,"MNTH") + call ufbint(lunin,day,1,1,iret,"DAYS") + call ufbint(lunin,hour,1,1,iret,"HOUR") + call ufbint(lunin,minu,1,1,iret,"MINU") + idate5(1) = year + idate5(2) = month + idate5(3) = day + idate5(4) = hour + idate5(5) = minu + call w3fs21(idate5,nmind) + + t4dv=real((nmind-iwinbgn),r_kind)*r60inv + sstime=real(nmind,r_kind) + tdiff=(sstime-gstime)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle read_loop5 + else + if(abs(tdiff) > twind) cycle read_loop5 + endif + + !Read solar zenith angle + call ufbint(lunin,soza,1,1,iret,"SOZA") + + !Read Pressure and Ozone Mixing Ratio + call ufbseq(lunin, olpdtsq, 12, 81, iret, "OLPDTSQ") + !Read Ozone Mixing Ratio Standard Deviation + call ufbseq(lunin, lpsdvals,3,81,iret,"LPSDVALS") + usage1(:) = 1000._r_kind + j = 0 + do k = 1, nloz + press(k) = olpdtsq(2,k)*0.001_r_double ! centibars + omr(k) = olpdtsq(11,k) ! ppmv + omrstd(k) = lpsdvals(3,k) !omr std + if(omr(k) > 0._r_double .and. omr(k) < 100._r_double) then + usage1(k) = zero + j = j + 1 + endif + enddo + + do k=1,nloz + + if(omr(k) > 0._r_double .and. omr(k) < 100._r_double)then + ndata=min(ndata+1,maxobs) + nodata=ndata + nmrecs= ndata + + ozout(1,ndata)=said + ozout(2,ndata)=t4dv + ozout(3,ndata)=dlon ! grid relative longitude + ozout(4,ndata)=dlat ! grid relative latitude + ozout(5,ndata)=dlon_earth_deg ! earth relative longitude (degrees) + ozout(6,ndata)=dlat_earth_deg ! earth relative latitude (degrees) + ozout(7,ndata)=soza ! solar zenith angle + + ozout(8,ndata)=usage1(k) ! + ozout(9,ndata)=log(press(k)) ! ompslp pressure in log(cb) + ozout(10,ndata)=omrstd(k) ! ozone mixing ratio precision in ppmv + ozout(11,ndata)=float(ipos(k)) ! pointer of obs level index in + ! ozinfo.txt + ozout(12,ndata)=j !nloz ! # of ompslp vertical levels + ozout(13,ndata)=omr(k) ! ozone mixing ratio in ppmv + ozout(14,ndata)=olpdtsq(3,k) ! log10 numberdensity of air + ozout(15,ndata)=olpdtsq(6,k) !log10 number density of ozone from UV + ozout(16,ndata)=olpdtsq(8,k) !log10 number density of ozone from VIS + endif + enddo + + enddo read_loop5 + + ! end of OMPS LP bufr loop + endif + + if(nmrecs > 0)then +! If gome, omps-nm/tc8 or omi data, compress ozout array to thinned data + if (obstype=='omi' .or. obstype=='gome' .or. obstype=='ompsnm' .or. obstype == 'ompstc8') then + kk=0 + do k=1,itxmax + if (ozout(1,k)>zero) then + kk=kk+1 + do i=1,nozdat + ozout(i,kk)=ozout(i,k) + end do + endif + end do + ndata=kk + nodata=ndata + endif + +! Write header record and data to output file for further processing + call count_obs(ndata,nozdat,ilat,ilon,ozout,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) ((ozout(k,i),k=1,nozdat),i=1,ndata) + nread=nmrecs + end if + +! Deallocate local arrays + if(allocated(ozout))deallocate(ozout) + if (obstype == 'sbuv2' .or. obstype == 'ompsnp') deallocate(poz) + if (index(obstype,'mls')/=0) then + if(allocated(hdrmlsl))deallocate(hdrmlsl) + if(allocated(mlspres))deallocate(mlspres) + if(allocated(mlsoz))deallocate(mlsoz) + if(allocated(mlsozpc))deallocate(mlsozpc) + if(allocated(ipos))deallocate(ipos) + if(allocated(usage1))deallocate(usage1) + end if + if(index(obstype,'ompslp')/=0) then + if(allocated(olpdtsq))deallocate(olpdtsq) + if(allocated(lpsdvals))deallocate(lpsdvals) + if(allocated(press))deallocate(press) + if(allocated(omr))deallocate(omr) + if(allocated(omrstd))deallocate(omrstd) + if(allocated(ipos))deallocate(ipos) + if(allocated(usage1))deallocate(usage1) + endif + +! Close unit to input data file + call closbf(lunin) + close(lunin) + +! Deallocate satthin arrays + if (obstype == 'omi' .or. obstype == 'gome' .or. obstype=='ompsnm' .or. obstype == 'ompstc8' )call destroygrids + + return + +end subroutine read_ozone diff --git a/src/read_pblh.f90 b/src/gsi/read_pblh.f90 similarity index 100% rename from src/read_pblh.f90 rename to src/gsi/read_pblh.f90 diff --git a/src/gsi/read_pcp.f90 b/src/gsi/read_pcp.f90 new file mode 100644 index 000000000..929a608ee --- /dev/null +++ b/src/gsi/read_pcp.f90 @@ -0,0 +1,360 @@ + subroutine read_pcp(nread,ndata,nodata,gstime,infile,lunout,obstype, & + twind,sis,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_pcp read pcp rate data +! prgmmr: treadon org: np23 date: 1998-05-15 +! +! abstract: This routine reads precipitation rate observations from +! various platforms/retrievals. Currently supported +! data sources include SSM/I, TMI, AMSU, and STAGE3 +! prepcipitation rates. Please note that only the SSM/I +! and TMI sections of the routine have been extensively +! tested. +! +! When running the gsi in regional mode, the code only +! retains those observations that fall within the regional +! domain +! +! program history log: +! 1998-05-15 yang, weiyu +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-16 treadon - update documentation +! 2004-07-29 treadon - add only to module use, add intent in/out +! 2004-09-17 todling - fix intent of jsatid +! 2004-10-28 treadon - replace parameter "tiny" with "tiny_r_kind" +! 2004-11-12 treadon - add code to read ssmi rain rates from prepbufr file +! 2005-01-27 treadon - change call to rdsfull +! 2005-04-22 treadon - correct ssmi read code to reflect mnemonic change from REQ6 to REQV +! 2005-08-16 guo - add gmao surface interface +! 2005-09-08 derber - modify to use input group time window +! 2005-09-28 derber - modify to produce consistent surface info +! 2005-10-06 treadon - allocate, load, and deallocate surface arrays needed by deter_sfc +! 2005-10-17 treadon - add grid and earth relative obs location to output file +! 2005-10-18 treadon - remove array obs_load and call to sumload +! 2005-11-29 parrish - modify getsfc to work for different regional options +! 2005-12-08 treadon - remove local land/sea/ice mask array since not used, remove +! gmao surface interface since not needed +! 2006-02-01 parrish - remove getsfc, destroy_sfc (different version called in read_obs) +! 2006-02-03 derber - modify for new obs control and obs count +! 2006-05-25 treadon - replace obstype "pcp_ssm/i" with "pcp_ssmi" +! 2007-03-01 tremolet - measure time from beginning of assimilation window +! 2008-04-18 safford - rm unused vars +! 2011-04-01 li - update argument list to deter_sfc +! 2011-08-01 lueken - added module use deter_sfc_mod +! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) +! 2015-02-23 Rancic/Thomas - add l4densvar to time window logical +! 2015-10-01 guo - consolidate use of ob location (in deg) +! +! input argument list: +! infile - unit from which to read BUFR data +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! twind - input group time window (hours) +! sis - satellite/instrument/sensor indicator +! +! output argument list: +! nread - number of precipitation rate observations read +! ndata - number of precipitation rate profiles retained for further processing +! nodata - number of precipitation rate observations retained for further processing +! nobs - array of observations on each subdomain for each processor +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use kinds, only: r_kind,r_double,i_kind + use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons + use constants, only: zero,deg2rad,tiny_r_kind,r60inv,r3600,r100 + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen + use deter_sfc_mod, only: deter_sfc_type + use obsmod, only: bmiss + use mpimod, only: npe + + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype,infile + character(len=20),intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: nread + integer(i_kind),dimension(npe) ,intent(inout) :: nobs + integer(i_kind) ,intent(inout) :: ndata,nodata + real(r_kind) ,intent(in ) :: gstime + real(r_kind) ,intent(in ) :: twind + +! Declare local parameters + real(r_kind),parameter:: r360=360.0_r_kind + +! Declare local variables + logical pcp_ssmi,pcp_tmi,pcp_amsu,pcp_stage3,outside + + character(6) ptype + character(8) subset + character(40) strhdr7,strsmi4,strsmi2_old,strsmi2,strtmi7,stramb5 + + integer(i_kind) imn,k,i,iyr,lnbufr,maxobs,isflg + integer(i_kind) ihh,idd,im,kx,jdate + integer(i_kind) ndatout,nreal,nchanl,iy,iret,idate,itype,ihr,idy,imo + integer(i_kind) minobs,lndsea,ilat,ilon + integer(i_kind) idate5(5) + + real(r_kind) scli,sclw,dlon,dlat,scnt + real(r_kind) dlat_earth,dlon_earth + real(r_kind) dlat_earth_deg,dlon_earth_deg + real(r_kind) scnv,stdv,spcp,tdiff,sstime,t4dv + real(r_kind) :: tsavg + real(r_kind),allocatable,dimension(:,:):: pcpdata + real(r_double) hdr7(7),pcpdat(7),pcpprd(2,2) + + data strhdr7 / 'RPID YEAR MNTH DAYS HOUR MINU SECO' / + data strsmi4 / 'CLAT CLON NMCT ACAV' / + data strsmi2_old / 'FOST REQ6' / + data strsmi2 / 'FOST REQV' / + data strtmi7 / 'CLAT CLON TRRT CRRT RCWA PCIA ACAV' / + data stramb5 / 'CLAT CLON REQV SNCV ICEP' / + + + data lnbufr /10/ + + +!************************************************************************** +! Initialize variables + maxobs=1e6 + nchanl = 0 + pcp_ssmi= obstype == 'pcp_ssmi' + pcp_tmi= obstype == 'pcp_tmi' + pcp_amsu= obstype == 'pcp_amsu' + pcp_stage3=obstype == 'pcp_stage3' + if (pcp_ssmi) then + nreal=10 + ptype='ssmi' + endif + if (pcp_tmi) then + nreal=12 + ptype='tmi' + endif + if (pcp_amsu) then + nreal=10 + ptype='amsu' + endif + if (pcp_stage3) then + nreal=10 + ptype='stage3' + endif + ndatout=nreal+nchanl + + +! Open and read the bufr data + call closbf(lnbufr) + open(lnbufr,file=trim(infile),form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + call datelen(10) + call readmg(lnbufr,subset,idate,iret) + if (iret/=0) then + call closbf(lnbufr) + return + end if + + iy=0; im=0; idd=0; ihh=0 + +! Write header record to pcp obs output file + ilon=3 + ilat=4 + + allocate(pcpdata(ndatout,maxobs)) + pcpdata=zero + +! Big loop over bufr file + obsloop: do + call readsb(lnbufr,iret) + if(iret/=0) then + call readmg(lnbufr,subset,jdate,iret) + if(iret/=0) exit obsloop + cycle obsloop + end if + + +! Extract satellite id and observation date/time + call ufbint(lnbufr,hdr7,7,1,iret,strhdr7) + + iyr = hdr7(2) + imo = hdr7(3) + idy = hdr7(4) + ihr = hdr7(5) + imn = hdr7(6) + + idate5(1) = iyr + idate5(2) = imo + idate5(3) = idy + idate5(4) = ihr + idate5(5) = imn + call w3fs21(idate5,minobs) + t4dv=real(minobs-iwinbgn,r_kind)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle obsloop + else + sstime=real(minobs,r_kind) + tdiff = (sstime-gstime)*r60inv + if (abs(tdiff) > twind) cycle obsloop + endif + + if (pcp_ssmi) kx = 264 + if (pcp_tmi) kx = 211 + if (pcp_amsu) kx = 258 + if (pcp_stage3) kx = 260 + + +! Extract observation location and value(s) + if (pcp_ssmi) then + + call ufbint(lnbufr,pcpdat,4,1,iret,strsmi4) + if (pcpdat(3)>99999.0_r_double) then + itype=99999 + else + itype = nint(pcpdat(3)) + endif + scnt = pcpdat(4) + if (itype/=66) cycle obsloop + +! Transition across PREPBUFR mnemonic change from REQ6 to REQV + + call ufbrep(lnbufr,pcpprd,2,2,iret,strsmi2_old) + if(min(pcpprd(2,1),pcpprd(2,2))>=bmiss) & + call ufbrep(lnbufr,pcpprd,2,2,iret,strsmi2) + spcp = bmiss + if (nint(pcpprd(1,1))==4) spcp=pcpprd(2,1)*r3600 + if (nint(pcpprd(1,2))==10) stdv=pcpprd(2,2)*r3600 + +! Check for negative, very large, or missing pcp. +! If any case is found, skip this observation. + if ( (spcpr100) .or. & + (abs(spcp-bmiss)r100) .or. & + (abs(spcp-bmiss)r100) .or. & + (abs(spcp-bmiss)r100) .or. & + (abs(spcp-bmiss)90._r_kind .or. abs(dlon_earth)>r360) cycle obsloop + if (dlon_earth< zero) dlon_earth=dlon_earth+r360 + if (dlon_earth==r360) dlon_earth=dlon_earth-r360 + dlat_earth_deg=dlat_earth + dlon_earth_deg=dlon_earth + dlat_earth=dlat_earth*deg2rad + dlon_earth=dlon_earth*deg2rad + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if (outside) cycle obsloop + +! Global case. Convert observation (lat,lon) to radians + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + +! +! Do we want to keep this observation? + nread = nread + 1 + ndata = min(ndata + 1,maxobs) + nodata = nodata + 1 +! + +! isflg - surface flag +! 0 sea +! 1 land +! 2 sea ice +! 3 snow +! 4 mixed + + call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg) + +! Load output array + + pcpdata(1,ndata) = kx ! satellite id + pcpdata(2,ndata) = t4dv ! time relative to cycle (hours) + pcpdata(3,ndata) = dlon ! grid relative longitude + pcpdata(4,ndata) = dlat ! grid relative latitude + pcpdata(5,ndata) = isflg + .001_r_kind ! surface tag + pcpdata(6,ndata) = spcp ! total precipitation (mm/hr) + if (pcp_ssmi) then + pcpdata(7,ndata) = stdv ! standard deviation of superobs + pcpdata(8,ndata) = scnt ! number of obs used to make superobs + pcpdata(9,ndata) = dlon_earth_deg ! earth relative longitude (degrees) + pcpdata(10,ndata)= dlat_earth_deg ! earth relative latitude (degrees) + elseif (pcp_tmi) then + pcpdata(7,ndata) = scnv ! convective precipitation (mm/hr) + pcpdata(8,ndata) = sclw ! cloud water (mm) + pcpdata(9,ndata) = scli ! cloud ice (mm) + pcpdata(10,ndata)= scnt ! number of obs used to make superobs + pcpdata(11,ndata)= dlon_earth_deg ! earth relative longitude (degrees) + pcpdata(12,ndata)= dlat_earth_deg ! earth relative latitude (degrees) + elseif (pcp_amsu) then + pcpdata(7,ndata) = zero ! standard deviation of superobs (not yet) + pcpdata(8,ndata) = itype ! type of algorithm + pcpdata(9,ndata) = dlon_earth_deg ! earth relative longitude (degrees) + pcpdata(10,ndata)= dlat_earth_deg ! earth relative latitude (degrees) + elseif (pcp_stage3) then + pcpdata(7,ndata) = stdv ! standard deviation of superobs + pcpdata(8,ndata) = scnt ! number of obs used to make superobs + pcpdata(9,ndata) = dlon_earth_deg ! earth relative longitude (degrees) + pcpdata(10,ndata)= dlat_earth_deg ! earth relative latitude (degrees) + endif +! +! End of big loop over bufr file. Process next observation. + end do obsloop + +! Write retained data to local file + call count_obs(ndata,ndatout,ilat,ilon,pcpdata,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) ((pcpdata(k,i),k=1,ndatout),i=1,ndata) + deallocate(pcpdata) + + +! Jump here if there is a problem opening the bufr file +110 continue + call closbf(lnbufr) + +! End of routine + return +end subroutine read_pcp diff --git a/src/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 similarity index 92% rename from src/read_prepbufr.f90 rename to src/gsi/read_prepbufr.f90 index da38b0be3..79280f2f8 100644 --- a/src/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -137,7 +137,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! is found in non linear qc error tables and b table ! 2016-05-05 pondeca - add 10-m u-wind and v-wind (uwnd10m, vwnd10m) ! 2016-06-01 zhu - use errormod_aircraft -! +! 2017-06-17 levine - add GLERL program code lookup +! 2017-03-21 Su - add option to thin conventional data in 4 dimension +! 2018-08-16 akella - explicit KX definition for ships (formerly ID'd by subtype 522/523) ! input argument list: ! infile - unit from which to read BUFR data @@ -168,9 +170,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& rlats,rlons,twodvar_regional use convinfo, only: nconvtype,ctwind, & ncmiter,ncgroup,ncnumgrp,icuse,ictype,icsubtype,ioctype, & - ithin_conv,rmesh_conv,pmesh_conv, & + ithin_conv,rmesh_conv,pmesh_conv,pmot_conv,ptime_conv, & use_prepb_satwnd - use convinfo, only: id_drifter + use convinfo, only: id_drifter,id_ship use obsmod, only: iadate,oberrflg,perturb_obs,perturb_fact,ran01dom,hilbert_curve use obsmod, only: blacklst,offtime_data,bmiss,ext_sonde @@ -187,8 +189,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use convb_t,only: btabl_t use convb_uv,only: btabl_uv use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen,thin4d + use convthin, only: make3grids,map3grids,map3grids_m,del3grids,use_all + use convthin_time, only: make3grids_tm,map3grids_tm,map3grids_m_tm,del3grids_tm,use_all_tm use qcmod, only: errormod,errormod_aircraft,noiqc,newvad,njqc - use convthin, only: make3grids,map3grids,del3grids,use_all + use qcmod, only: pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres + use nltransf, only: nltransf_forward use blacklist, only : blacklist_read,blacklist_destroy use blacklist, only : blkstns,blkkx,ibcnt use sfcobsqc,only: init_rjlists,get_usagerj,get_gustqm,destroy_rjlists @@ -204,7 +209,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& destroy_aircraft_rjlists use adjust_cloudobs_mod, only: adjust_convcldobs,adjust_goescldobs use mpimod, only: npe - use rapidrefresh_cldsurf_mod, only: i_gsdsfc_uselist,i_gsdqc + use rapidrefresh_cldsurf_mod, only: i_gsdsfc_uselist,i_gsdqc,i_ens_mean use gsi_io, only: verbose implicit none @@ -223,6 +228,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& real(r_kind),parameter:: r0_75 = 0.75_r_kind real(r_kind),parameter:: r0_7 = 0.7_r_kind real(r_kind),parameter:: r1_2 = 1.2_r_kind + real(r_kind),parameter:: r1_02 = 1.02_r_kind real(r_kind),parameter:: r3_33= three + one/three real(r_kind),parameter:: r6 = 6.0_r_kind real(r_kind),parameter:: r20 = 20.0_r_kind @@ -266,6 +272,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& character(8) stnid character(10) aircraftstr character(1) cb + character(1) cdummy logical lhilbert integer(i_kind) ireadmg,ireadsb,icntpnt,icntpnt2,icount,iiout @@ -279,7 +286,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& integer(i_kind) lim_tqm,lim_qqm integer(i_kind) nlevp ! vertical level for thinning integer(i_kind) ntmp,iout - integer(i_kind) pflag,irec + integer(i_kind) pflag,irec,zflag integer(i_kind) ntest,nvtest,iosub,ixsub,isubsub,iobsub integer(i_kind) kl,k1,k2,k1_ps,k1_q,k1_t,k1_uv,k1_pw,k2_q,k2_t,k2_uv,k2_pw,k2_ps integer(i_kind) itypex,itypey @@ -299,7 +306,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& integer(i_kind),allocatable,dimension(:,:):: tab integer(i_kind) ibfms,thisobtype_usage integer(i_kind) iwmo,ios + integer(i_kind) ntime,itime integer(i_kind) ierr_ps,ierr_q,ierr_t,ierr_uv,ierr_pw ! the position of error table collum + integer(i_kind) idummy1,idummy2,glret,lindx !glret>0 means GLERL code exists.Others are dummy variables real(r_kind) time,timex,time_drift,timeobs,toff,t4dv,zeps real(r_kind) qtflg,tdry,rmesh,ediff,usage,ediff_ps,ediff_q,ediff_t,ediff_uv,ediff_pw real(r_kind) u0,v0,uob,vob,dx,dy,dx1,dy1,w00,w10,w01,w11 @@ -313,7 +322,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& real(r_kind) del,terrmin,werrmin,perrmin,qerrmin,pwerrmin,del_ps,del_q,del_t,del_uv,del_pw real(r_kind) pjbmin,qjbmin,tjbmin,wjbmin real(r_kind) tsavg,ff10,sfcr,zz - real(r_kind) crit1,timedif,xmesh,pmesh + real(r_kind) crit1,timedif,xmesh,pmesh,pmot,ptime ! thinning parameter real(r_kind) time_correction real(r_kind) tcamt,lcbas,ceiling real(r_kind) tcamt_oe,lcbas_oe @@ -325,9 +334,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& real(r_kind),allocatable,dimension(:):: presl_thin real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out real(r_kind) :: zob,tref,dtw,dtc,tz_tr + real(r_kind) :: tempvis,visout + real(r_kind) :: tempcldch,cldchout real(r_double) rstation_id,qcmark_huge - real(r_double) vtcd + real(r_double) vtcd,glcd !virtual temp program code and GLERL program code real(r_double),dimension(8):: hdr,hdrtsb real(r_double),dimension(3,255):: hdr3 real(r_double),dimension(8,255):: drfdat,qcmark,obserr,var_jb @@ -409,7 +420,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Initialize variables vdisterrmax=zero - pflag=0 ! dparrish debug compile run flags pflag as not defined ??????????? + zflag=0 nreal=0 satqc=zero tob = obstype == 't' @@ -469,7 +480,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& else if(howvob) then nreal=23 else if(metarcldobs) then - nreal=25 + nreal=27 else if(goesctpobs) then nreal=8 else if(tcamtob) then @@ -636,19 +647,18 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& call ufbint(lunin,hdrtsb,1,1,iret,'TSB') if(hdrtsb(1)==2) then newvad=.true. - go to 288 - end if - call ufbint(lunin,obsdat,13,255,levs,obstr) - if(levs>1)then - do k=1, levs-1 - diffuu=abs(obsdat(4,k+1)-obsdat(4,k)) - if(diffuu==50.0) then + else + call ufbint(lunin,obsdat,13,255,levs,obstr) + if(levs>1)then + do k=1, levs-1 + diffuu=abs(obsdat(4,k+1)-obsdat(4,k)) + if(diffuu==50.0) then newvad=.true. - go to 288 - end if - end do + exit + end if + end do + end if end if -288 continue if(newvad)write(6,*)'new vad flag::', newvad end if !* END new vad wind @@ -665,6 +675,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if end if + if (id_ship .and. (kx==180) .and. (nint(hdr(3))==522 .or. nint(hdr(3))==523)) then + rstation_id=hdr(4) + kx = kx + 18 + end if + if(twodvar_regional)then ! If running in 2d-var (surface analysis) mode, check to see if observation ! is surface type or GOES cloud product(kx=151). If not, read next observation report from bufr file @@ -686,7 +701,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& endif endif ! Su suggested to keep both 289 and 290. But trunk only keep 290 -! ??? if(kx == 289 .or. kx == 290) iobsub=hdr(2) +! if(kx == 289 .or. kx == 290) iobsub=hdr(2) if(kx == 290) iobsub=hdr(2) if(use_prepb_satwnd .and. (kx >= 240 .and. kx <=260 )) iobsub = hdr(2) @@ -755,17 +770,33 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end do loop_report enddo msg_report - if (nmsg==0) goto 900 + if (nmsg==0) then + call closbf(lunin) + close(lunin) + if(print_verbose)write(6,*)'READ_PREPBUFR: no messages/reports ' + return + end if if(print_verbose)write(6,*)'READ_PREPBUFR: messages/reports = ',nmsg,'/',ntb,' ntread = ',ntread - if(tob .and. print_verbose) write(6,*)'READ_PREPBUFR: time offset is ',toff,' hours.' !------------------------------------------------------------------------ ! Obtain program code (VTCD) associated with "VIRTMP" step call ufbqcd(lunin,'VIRTMP',vtcd) +!see if file contains GLERL program code (GLCD) +!Obtain code if it exists. Otherwise set to missing (-999) + call status(lunin,lindx,idummy1,idummy2) + call nemtab(lindx,'GLERL',idummy1,cdummy,glret) + if (glret /= 0) then + call ufbqcd(lunin,'GLERL',glcd) + else + !warn that GLERL adjustment is not available. + print*, "WARNING: GLERL program code not in this file." + glcd=-999._r_double + endif + call init_rjlists call init_aircraft_rjlists if(i_gsdsfc_uselist==1) call init_gsd_sfcuselist @@ -785,8 +816,14 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& nchanl=0 ilon=2 ilat=3 + rmesh=zero + pmot=zero + pmesh=zero + ptime=zero + xmesh=zero + pflag=0 loop_convinfo: do nx=1, ntread - + use_all_tm = .true. use_all = .true. ithin=0 if(nx > 1) then @@ -795,29 +832,52 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (ithin > 0 ) then rmesh=rmesh_conv(nc) pmesh=pmesh_conv(nc) - use_all = .false. - if(pmesh > zero) then + pmot=pmot_conv(nc) + ptime=ptime_conv(nc) + if(pmesh > zero .and. ithin ==1) then pflag=1 + zflag=-1 nlevp=r1200/pmesh + else if(pmesh > zero .and. ithin ==2) then + pflag=1 + zflag=1 + nlevp=25000.00_r_kind/pmesh else + zflag=-1 pflag=0 nlevp=nsig endif xmesh=rmesh - - call make3grids(xmesh,nlevp) - - if (.not.use_all) then + if( ptime >zero) then + use_all_tm = .false. + ntime=6.0_r_kind/ptime !! 6 hour winddow + call make3grids_tm(xmesh,nlevp,ntime) + allocate(presl_thin(nlevp)) + if (zflag==-1 ) then + do k=1,nlevp + presl_thin(k)=(r1200-(k-1)*pmesh)*one_tenth + enddo + else if(zflag==1 ) then + do k=1,nlevp + presl_thin(k)=k*pmesh + enddo + endif + else + use_all = .false. + call make3grids(xmesh,nlevp) allocate(presl_thin(nlevp)) - if (pflag==1) then + if (zflag==-1 ) then do k=1,nlevp presl_thin(k)=(r1200-(k-1)*pmesh)*one_tenth enddo + else if(zflag==1 ) then + do k=1,nlevp + presl_thin(k)=k*pmesh + enddo endif endif - - if(print_verbose)write(6,*)'READ_PREPBUFR: at line 779: obstype,ictype(nc),rmesh,pflag,nlevp,pmesh=',& - trim(ioctype(nc)),ictype(nc),rmesh,pflag,nlevp,pmesh + if(print_verbose) write(6,*)'READ_PREPBUFR: at line 779: obstype,ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime=',& + trim(ioctype(nc)),ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime,ithin endif endif @@ -890,6 +950,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if end if + if (id_ship .and. (kx==180) .and. (nint(hdr(8))==522 .or. nint(hdr(8))==523) ) then + rstation_id=hdr(1) + kx = kx + 18 + end if +! ! check VAD subtype. 1--old, 2--new, other--old if(kx==224) then @@ -1101,9 +1166,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& var_jb(1,k)=(one-del_ps)*btabl_ps(itypex,k1_ps,ierr_ps)+del_ps*btabl_ps(itypex,k2_ps,ierr_ps) var_jb(1,k)=max(var_jb(1,k),pjbmin) if (var_jb(1,k) >=10.0_r_kind) var_jb(1,k)=zero - if(itypey==180 .and. ierr_ps == 0 .and. print_verbose) then - write(6,*) 'READ_PREPBUFR:180_ps,obserr,var_jb=',obserr(1,k),var_jb(1,k),ppb,k,hdr(2),hdr(3) - endif enddo endif if (tob) then @@ -1155,9 +1217,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& var_jb(3,k)=(one-del_t)*btabl_t(itypex,k1_t,ierr_t)+del_t*btabl_t(itypex,k2_t,ierr_t) var_jb(3,k)=max(var_jb(3,k),tjbmin) if (var_jb(3,k) >=10.0_r_kind) var_jb(3,k)=zero -! if(itypey==180) then -! write(6,*) 'READ_PREPBUFR:180_t,obserr,var_jb=',obserr(3,k),var_jb(3,k),ppb -! endif enddo endif if (qob) then @@ -1528,11 +1587,21 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (tpc(k,j)>=bmiss) exit ! end of stack end do end do - else !peel back events to store sensible temp in case temp is virtual + else + !look for GLERL-adjusted ob first in events stack. If not there, + !peel back events to store sensible temp in case temp is virtual call ufbevn(lunin,tobaux,2,255,20,levs,'TOB TQM') do k=1,levs tvflg(k)=one ! initialize as sensible do j=1,20 + if (glret /= 0) then !GLERL adjusted obs possible + if (tpc(k,j)==glcd) then !found GLERL ob - use that and jump out of events stack + obsdat(3,k)=tobaux(1,k,j) + qcmark(3,k)=min(tobaux(2,k,j),qcmark_huge) + tqm(k)=nint(qcmark(3,k)) + exit + endif + endif if (tpc(k,j)==vtcd) then obsdat(3,k)=tobaux(1,k,j+1) qcmark(3,k)=min(tobaux(2,k,j+1),qcmark_huge) @@ -1544,6 +1613,26 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if end if + if(i_gsdqc==2) then +! AMV acceptance for all obs (E. James) + if (kx >= 240 .and. kx <= 260) then + do k=1,levs + pqm(k)=2 + wqm(k)=2 + end do + end if +! END of the AMV acceptance section (E. James) +! USE q from 300-10 mb for aircraft and raobs (E. James) + if(qob .and. (kx==120 .or. kx==131 .or. kx==133 .or. kx==134)) then + do k=1,levs + if( plevs(k)<=30.0_r_kind .and. plevs(k)>=1.0_r_kind ) then + if(qqm(k) == 9) qqm(k)=2 + endif + end do + endif +! END use q from 300-10 mb + endif + stnelev=hdr(6) ithin=ithin_conv(nc) ithinp = ithin > 0 .and. pflag /= 0 @@ -1574,6 +1663,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& endif end if LOOP_K_LEVS: do k=1,levs + if( zflag ==-1) then + ppb=obsdat(1,k)*one_tenth + else if(zflag ==1) then + ppb=obsdat(4,k) + endif if(kx==224 .and. newvad)then if(mod(k,6)/=0) cycle LOOP_K_LEVS end if @@ -1607,7 +1701,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& else if(visob) then visqm=0 ! need to fix this later qm=visqm -!! RY: check this late when using tdob?? else if(tdob) then if(obsdat(12,k) > r0_01_bmiss)cycle loop_k_levs tdqm=qqm(k) @@ -1783,63 +1876,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Missing Values ==> Cycling! In this case for howv only. #ww3 if (howvob .and. owave(1,k) > r0_1_bmiss) cycle LOOP_K_LEVS -! Special block for data thinning - if requested - if (ithin > 0) then - ntmp=ndata ! counting moved to map3gridS - -! Set data quality index for thinning - if (thin4d) then - timedif = zero - else - timedif=abs(t4dv-toff) - endif - if(kx == 243 .or. kx == 253 .or. kx ==254) then - call ufbint(lunin,satqc,1,1,iret,satqcstr) - crit1 = timedif/r6+half + four*(one-satqc(1)/r100)*r3_33 - else - crit1 = timedif/r6+half - endif - - if (pflag==0) then - do kk=1,nsig - presl_thin(kk)=presl(kk) - end do - endif - - call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& - plevs(k),crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) - - if (.not. luse) then - if(k==levs) then - cycle loop_readsb - else - cycle LOOP_K_LEVS - endif - endif - if(iiout > 0) isort(iiout)=0 - if(ndata > ntmp)then - nodata=nodata+1 - if(uvob)nodata=nodata+1 - end if - isort(icntpnt)=iout - - else - ndata=ndata+1 - nodata=nodata+1 - if(uvob)nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout - endif - - if(ndata > maxobs) then - write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype - ndata = maxobs - end if - ! Set usage variable usage = zero - - if(icuse(nc) <= 0)usage=100._r_kind if(qm == 15 .or. qm == 12 .or. qm == 9)usage=100._r_kind if(qm >=lim_qm )usage=101._r_kind @@ -1896,10 +1934,83 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Get information from surface file necessary for conventional data here + +! Special block for data thinning - if requested + if (ithin > 0 .and. usage <100.0_r_kind) then +! if (ithin > 0 ) then + ntmp=ndata ! counting moved to map3gridS + +! Set data quality index for thinning + if (thin4d) then + timedif = zero + else + timedif=abs(t4dv-toff) + endif + if(kx == 243 .or. kx == 253 .or. kx ==254) then + call ufbint(lunin,satqc,1,1,iret,satqcstr) + crit1 = timedif/r6+half + four*(one-satqc(1)/r100)*r3_33 + else + crit1 = timedif/r6+half + endif + + if (pflag==0) then + do kk=1,nsig + presl_thin(kk)=presl(kk) + end do + endif + + if (ptime >zero ) then + itime=int((abs(timedif)+three)/ptime)+1 + if(itime >ntime) itime=ntime + call map3grids_tm(zflag,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& + ppb,itime,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) + if (.not. luse) then + if(k==levs) then + cycle loop_readsb + else + cycle LOOP_K_LEVS + endif + endif + if(iiout > 0) isort(iiout)=0 + if (ndata > ntmp) then + nodata=nodata+1 + if(uvob)nodata=nodata+1 + endif + isort(icntpnt)=iout + else + call map3grids(zflag,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& + ppb,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) + if (.not. luse) then + if(k==levs) then + cycle loop_readsb + else + cycle LOOP_K_LEVS + endif + endif + if(iiout > 0) isort(iiout)=0 + if (ndata > ntmp) then + nodata=nodata+1 + if(uvob)nodata=nodata+1 + endif + isort(icntpnt)=iout + endif + else + ndata=ndata+1 + nodata=nodata+1 + if(uvob)nodata=nodata+1 + iout=ndata + isort(icntpnt)=iout + endif + + if(ndata > maxobs) then + write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype + ndata = maxobs + end if + call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr,zz) if(lhilbert) & - call accum_hilbertcurve(usage,c_station_id,c_prvstg,c_sprvstg, & + call accum_hilbertcurve(usage,c_station_id,c_prvstg,c_sprvstg, & dlat_earth,dlon_earth,dlat,dlon,t4dv,toff,nc,kx,iout) @@ -2288,6 +2399,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if ((kx==280).or.(kx==180)) oelev=r20+selev if ((kx==299).or.(kx==199)) oelev=r20+selev if ((kx==282).or.(kx==182)) oelev=r20+selev + if (kx==198) oelev=r20+selev if ((kx==285).or.(kx==185)) then oelev=selev selev=zero @@ -2332,14 +2444,42 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Visibility else if(visob) then - visoe=4000.0 ! temporarily - if ((kx==283).or.(kx==183)) visoe=4500.0 - if (inflate_error) visoe=visoe*r1_2 +!...................................................................... +!NLTRCV: must setup as true +! visoe is in NLTR space, and is read in from the namelist. Is this OK? +!...................................................................... + visoe=estvisoe + if ((kx==283).or.(kx==183)) visoe=visoe*r1_02 + if (inflate_error) visoe=visoe*r1_02 cdata_all(1,iout)=visoe ! visibility error (cb) cdata_all(2,iout)=dlon ! grid relative longitude cdata_all(3,iout)=dlat ! grid relative latitude - cdata_all(4,iout)=obsdat(9,k) ! visibility obs +!...................................................................... +! simple QC check: if an observation vis is negative, assign it as bmiss +! if obs. = zero, reassign it as one_r_kind +! about bmiss: +! #ifdef ibm_sp ! real(r_kind), parameter:: bmiss = 1.0e11_r_kind !#else +! real(r_kind), parameter:: bmiss = 1.0e9_r_kind !#endif +! in setupvis: missing data is checked and assigned not use in muse +! visthres is much smaller than bmiss +! i.e: this holds: (obsdat(9,k)> zero .and. obsdat(9,k)<=vis_thres) +!...................................................................... + if(obsdat(9,k) < zero) then + cdata_all(4,iout)=bmiss + elseif(obsdat(9,k)> r0_1_bmiss)then + cdata_all(4,iout)=obsdat(9,k) + elseif(obsdat(9,k)> vis_thres .and. obsdat(9,k)<= r0_1_bmiss )then + obsdat(9,k)=vis_thres + else + obsdat(9,k)=max(obsdat(9,k),one) + endif + if(obsdat(9,k)> zero .and. obsdat(9,k)<=vis_thres)then + tempvis=obsdat(9,k) + call nltransf_forward(tempvis,visout,pvis,scale_cv) + cdata_all(4,iout) = visout + endif + cdata_all(5,iout)=rstation_id ! station id cdata_all(6,iout)=t4dv ! time cdata_all(7,iout)=nc ! type @@ -2544,7 +2684,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& cdata_all(17+kk,iout)= -99999.0_r_kind endif enddo - cdata_all(21,iout)=timeobs ! time observation + cdata_all(21,iout)=timeobs ! time observation cdata_all(22,iout)=usage if (lhilbert) thisobtype_usage=22 ! save INDEX of where usage is stored for hilbertcurve cross validation (if requested) cdata_all(23,iout)=0.0_r_kind ! reserved for distance between obs and grid @@ -2556,7 +2696,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& else cdata_all(24,iout)=-99999.0_r_kind ! temperature - dew point endif -! cdata_all(24,iout) and cdata_all(25,iout) will be used to save dlon and dlat + cdata_all(25,iout)=nc ! type + cdata_all(26,iout)=dlon_earth_deg ! earth relative longitude (degrees) + cdata_all(27,iout)=dlat_earth_deg ! earth relative latitude (degrees) ! NESDIS cloud products else if(goesctpobs) then cdata_all(1,iout)=rstation_id ! station ID @@ -2658,14 +2800,42 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Cloud ceiling height else if(cldchob) then - - cldchoe=4000.0 ! temporarily - if (inflate_error) cldchoe=cldchoe*r1_2 - - cdata_all(1,iout)=cldchoe ! cloud ceiling height error (m) +!...................................................................... +!NLTRCV: must setup as true +! cldchoe is in NLTR space, and is read in via the namelist. Is this OK? +!...................................................................... + cldchoe=estcldchoe + if (inflate_error) cldchoe=cldchoe*r1_02 + + cdata_all(1,iout)=cldchoe ! cloud ceiling height error cdata_all(2,iout)=dlon ! grid relative longitude cdata_all(3,iout)=dlat ! grid relative latitude - cdata_all(4,iout)=cldceilh(1,k) ! cloud ceiling height obs +!...................................................................... +! NLTRCV: +! simple QC check and designate bad observation. +! if obs. cldch < zero, assign it bmiss +! if obs/first cldch guess is zero, assigne it as one +! about bmiss: +! #ifdef ibm_sp ! real(r_kind), parameter:: bmiss = 1.0e11_r_kind !#else +! real(r_kind), parameter:: bmiss = 1.0e9_r_kind !#endif +! in setupcldch: missing data is checked and assigned as not-use +! cldchthres is much smaller than bmiss +! i.e: this holds: (obsdat(x,k)> zero .and. obsdat(x,k)<=cldch_thres) +!...................................................................... + if(cldceilh(1,k) < zero) then + cdata_all(4,iout)=bmiss + elseif (cldceilh(1,k)> r0_1_bmiss) then + cdata_all(4,iout)=cldceilh(1,k) + elseif (cldceilh(1,k)>=cldch_thres .and. cldceilh(1,k)<= r0_1_bmiss) then + cldceilh(1,k)=cldch_thres + else + cldceilh(1,k)=max(cldceilh(1,k),one) !consider cldceilh(1,k)=zero a valid data + endif + if (cldceilh(1,k)> zero .and. cldceilh(1,k)<=cldch_thres)then + tempcldch=cldceilh(1,k) + call nltransf_forward(tempcldch,cldchout,pcldch,scale_cv) + cdata_all(4,iout) = cldchout + endif ! ceiling height obs cdata_all(5,iout)=rstation_id ! station id cdata_all(6,iout)=t4dv ! time cdata_all(7,iout)=nc ! type @@ -2700,6 +2870,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& deallocate(presl_thin) call del3grids endif + if (.not.use_all_tm) then + deallocate(presl_thin) + call del3grids_tm + endif + ! Normal exit @@ -2736,18 +2911,20 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! define a closest METAR cloud observation for each grid point if(metarcldobs .and. ndata > 0) then - maxobs=2000000 - allocate(cdata_all(nreal,maxobs)) - call reorg_metar_cloud(cdata_out,nreal,ndata,cdata_all,maxobs,iout) - ndata=iout - deallocate(cdata_out) - allocate(cdata_out(nreal,ndata)) - do i=1,nreal - do j=1,ndata - cdata_out(i,j)=cdata_all(i,j) + if(i_ens_mean /= 1) then + maxobs=2000000 + allocate(cdata_all(nreal,maxobs)) + call reorg_metar_cloud(cdata_out,nreal,ndata,cdata_all,maxobs,iout) + ndata=iout + deallocate(cdata_out) + allocate(cdata_out(nreal,ndata)) + do i=1,nreal + do j=1,ndata + cdata_out(i,j)=cdata_all(i,j) + end do end do - end do - deallocate(cdata_all) + deallocate(cdata_all) + endif endif call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata @@ -2760,21 +2937,16 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (lhilbert) call destroy_hilbertcurve if (twodvar_regional) call destroy_ndfdgrid -900 continue if(diagnostic_reg .and. ntest>0) write(6,*)'READ_PREPBUFR: ',& 'ntest,disterrmax=',ntest,disterrmax if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_PREPBUFR: ',& 'nvtest,vdisterrmax=',ntest,vdisterrmax - if (ndata == 0) then - call closbf(lunin) - if(print_verbose)write(6,*)'READ_PREPBUFR: closbf(',lunin,')' - endif + call closbf(lunin) + if(print_verbose)write(6,*)'READ_PREPBUFR: closbf(',lunin,')' close(lunin) - close(55) - ! End of routine return diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90 new file mode 100644 index 000000000..ca12dc086 --- /dev/null +++ b/src/gsi/read_radar.f90 @@ -0,0 +1,3374 @@ +! SUBSET=NC006001 -- level 3 superobs +! SUBSET=NC006002 -- level 2.5 superobs +! SUBSET=NC006070 -- RADIAL WIND FROM P3 RADAR +subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_full,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_radar read radar radial winds +! prgmmr: yang org: np23 date: 1998-05-15 +! +! abstract: This routine reads radar radial wind files. +! +! When running the gsi in regional mode, the code only +! retains those observations that fall within the regional +! domain +! +! program history log: +! 1998-05-15 yang, weiyu +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-16 treadon - update documentation +! 2004-07-29 treadon - add only to module use, add intent in/out +! 2005-06-10 devenyi/treadon - correct subset declaration +! 2005-08-02 derber - modify to use convinfo file +! 2005-09-08 derber - modify to use input group time window +! 2005-10-11 treadon - change convinfo read to free format +! 2005-10-17 treadon - add grid and earth relative obs location to output file +! 2005-10-18 treadon - remove array obs_load and call to sumload +! 2005-10-26 treadon - add routine tag to convinfo printout +! 2006-02-03 derber - modify for new obs control and obs count +! 2006-02-08 derber - modify to use new convinfo module +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-04-21 parrish - modify to use level 2, 2.5, and/or 3 radar wind +! superobs, with qc based on vad wind data. +! 2006-05-23 parrish - interpolate model elevation to vad wind site +! 2006-07-28 derber - use r1000 from constants +! 2007-03-01 tremolet - measure time from beginning of assimilation window +! 2008-04-17 safford - rm unused vars and uses +! 2008-09-08 lueken - merged ed's changes into q1fy09 code +! 2009-06-08 parrish - remove erroneous call to cosd, sind +! 2009-05-08 tong - add reading NOAA P3 tail Dopple radar data +! 2010-09-08 parrish - remove subroutine check_rotate_wind. This was a debug routine introduced when +! the reference wind rotation angle was stored as an angle, beta_ref. This field +! had a discontinuity at the date line (180E), which resulted in erroneous wind +! rotation angles for a small number of winds whose rotation angle was interpolated +! from beta_ref values across the discontinuity. This was fixed by replacing the +! beta_ref field with cos_beta_ref, sin_beta_ref. +! 2011-03-28 s.liu - add subtype to radial wind observation and limit the use +! of level2.5 and level3 data in Conus domain for NMM and NMMB +! 2011-08-01 lueken - remove deter_zsfc_model (placed in deter_sfc_mod) and fix indentation +! 2012-01-11 m.Hu - add subtype to radial wind observation and limit the use +! of level2.5 and level3 data in Conus domain for ARW +! 2012-06-26 y.li/x.wang add TDR fore/aft sweep separation for thinning,xuguang.wang@ou.edu +! 2012-04-28 s.liu - use new VAD wind +! 2012-11-12 s.liu - add new VAD wind flag +! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) +! 2013-05-07 tong - add reading tdr superobs data +! 2013-05-22 tong - Modified the criteria of seperating fore and aft sweeps for TDR NOAA/FRENCH antenna +! 2015-02-23 Rancic/Thomas - add thin4d to time window logical +! 2015-10-01 guo - consolidate use of ob location (in deg) +! 2016-12-21 lippi/carley - add logic to run l2rw loop (==0) or run loop for l3rw and l2_5rw (==1,2) +! to help fix a multiple data read bug (when l2rwbufr and radarbufr were both +! listed in the OBS_INPUT table) and for added flexibility for experimental setups. +! 2018-02-15 wu - add code for fv3_regional option +! +! +! input argument list: +! infile - file from which to read BUFR data +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! twind - input group time window (hours) +! hgtl_full- 3d geopotential height on full domain grid +! +! output argument list: +! nread - number of doppler lidar wind observations read +! ndata - number of doppler lidar wind profiles retained for further processing +! nodata - number of doppler lidar wind observations retained for further processing +! sis - satellite/instrument/sensor indicator +! nobs - array of observations on each subdomain for each processor +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use kinds, only: r_kind,r_single,r_double,i_kind,i_byte + use constants, only: zero,zero_single,half,one,two,three,deg2rad,rearth,rad2deg, & + one_tenth,r10,r1000,r60inv,r100,r400,grav_equator, & + eccentricity,somigliana,grav_ratio,grav, & + semi_major_axis,flattening,two + use qcmod, only: erradar_inflate,vadfile,newvad + use obsmod, only: iadate,ianldate,l_foreaft_thin + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d + use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,nsig + use gridmod, only: wrf_nmm_regional,nems_nmmb_regional,cmaq_regional,wrf_mass_regional + use gridmod, only: fv3_regional + use convinfo, only: nconvtype,ctwind, & + ncmiter,ncgroup,ncnumgrp,icuse,ictype,ioctype,ithin_conv,rmesh_conv,pmesh_conv + use convthin, only: make3grids,map3grids,del3grids,use_all + use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model + use mpimod, only: npe + use gsi_io, only: verbose + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype,infile + character(len=20),intent(in ) :: sis + real(r_kind) ,intent(in ) :: twind + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: nread,ndata,nodata + integer(i_kind),dimension(npe) ,intent(inout) :: nobs + real(r_kind),dimension(nlat,nlon,nsig),intent(in):: hgtl_full + +! Declare local parameters + integer(i_kind),parameter:: maxlevs=1500 + integer(i_kind),parameter:: maxdat=22 + integer(i_kind),parameter:: maxvad=500 +! integer(i_kind),parameter:: maxvadbins=20 + integer(i_kind),parameter:: maxvadbins=15 + real(r_kind),parameter:: r4_r_kind = 4.0_r_kind + + real(r_kind),parameter:: dzvad=304.8_r_kind ! vad reports are every 1000 ft = 304.8 meters + real(r_kind),parameter:: r3_5 = 3.5_r_kind + real(r_kind),parameter:: r6 = 6.0_r_kind + real(r_kind),parameter:: r8 = 8.0_r_kind + real(r_kind),parameter:: r90 = 90.0_r_kind + real(r_kind),parameter:: r200 = 200.0_r_kind + real(r_kind),parameter:: r150 = 150.0_r_kind + real(r_kind),parameter:: r360=360.0_r_kind + real(r_kind),parameter:: r50000 = 50000.0_r_kind + real(r_kind),parameter:: r60 = 60.0_r_kind + real(r_kind),parameter:: r75 = 75.0_r_kind + real(r_kind),parameter:: r92 = 92.6e03_r_kind + real(r_kind),parameter:: r89_5 = 89.5_r_kind + real(r_kind),parameter:: r2 = 2.0_r_kind + real(r_kind),parameter:: r71 = 71.0_r_kind + real(r_kind),parameter:: four_thirds = 4.0_r_kind / 3.0_r_kind + +! Declare local variables + logical good,outside,good0,lexist1,lexist2 + + character(10) date + character(80) hdrstr(2),datstr(2) + character(8) subset,subset_check(3) + character(30) outmessage + character(255) filename + + integer(i_kind) lnbufr,i,j,k,maxobs,icntpnt,iiout,n,istop + integer(i_kind) nmrecs,ibadazm,ibadtilt,ibadrange,ibadwnd,ibaddist,ibadheight,ibadvad,kthin + integer(i_kind) iyr,imo,idy,ihr,imn,isc,ithin + integer(i_kind) ibadstaheight,ibaderror,notgood,idate,iheightbelowsta,ibadfit + integer(i_kind) notgood0 + integer(i_kind) novadmatch,ioutofvadrange + integer(i_kind) iy,im,idd,ihh,iret,levs,mincy,minobs,kx0,kxadd,kx + integer(i_kind) nreal,nchanl,ilat,ilon,ikx + integer(i_kind),dimension(5):: idate5 + integer(i_kind) ivad,ivadz,nvad,idomsfc + + real(r_kind) timeb,rmesh,usage,ff10,sfcr,skint,t4dv,t4dvo,toff + real(r_kind) eradkm,dlat_earth,dlon_earth + real(r_kind) dlat_earth_deg,dlon_earth_deg + real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat + real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist + real(r_kind) rwnd,azm,height,error,wqm + real(r_kind) azm_earth,cosazm_earth,sinazm_earth,cosazm,sinazm + real(r_kind):: zsges + + real(r_kind),dimension(maxdat):: cdata + real(r_kind),allocatable,dimension(:,:):: cdata_all + + real(r_double) rstation_id + real(r_double),dimension(12):: hdr + character(8) cstaid + character(4) this_staid + equivalence (this_staid,cstaid) + equivalence (cstaid,rstation_id) + real(r_double),dimension(7,maxlevs):: radar_obs + real(r_double),dimension(4,maxlevs):: vad_obs + real(r_double),dimension(2,maxlevs):: fcst_obs + + character(8) vadid(maxvad) + real(r_kind) vadlat(maxvad),vadlon(maxvad),vadqm(maxvad,maxvadbins) + real(r_kind) vadu(maxvad,maxvadbins),vadv(maxvad,maxvadbins) + real(r_kind) vadcount(maxvad,maxvadbins) + real(r_kind),dimension(maxvad,maxvadbins)::vadfit2,vadcount2,vadwgt2 + real(r_kind),dimension(maxvad,maxvadbins)::vadfit2_5,vadcount2_5,vadwgt2_5 + real(r_kind),dimension(maxvad,maxvadbins)::vadfit3,vadcount3,vadwgt3 + real(r_kind) zob,vadqmmin,vadqmmax + integer(i_kind) level2(maxvad),level2_5(maxvad),level3(maxvad),level3_tossed_by_2_5(maxvad) + integer(i_kind) loop,numcut + integer(i_kind) numhits(0:maxvad) + real(r_kind) timemax,timemin,errmax,errmin + real(r_kind) dlatmax,dlonmax,dlatmin,dlonmin + real(r_kind) xscale,xscalei + integer(i_kind) max_rrr,nboxmax + integer(i_kind) irrr,iaaa,iaaamax,iaaamin + integer(i_byte),allocatable::nobs_box(:,:,:,:) + real(r_kind) dlonvad,dlatvad,vadlon_earth,vadlat_earth + real(r_kind) this_stalat,this_stalon,this_stahgt,thistime,thislat,thislon + real(r_kind) azm0,elev0,range0,rotang + real(r_kind) thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt + integer(i_kind) nsuper2_in,nsuper2_kept + integer(i_kind) nsuper2_5_in,nsuper2_5_kept + integer(i_kind) nsuper3_in,nsuper3_kept + real(r_kind) errzmax + real(r_kind) thisfit,thisvadspd,thisfit2,uob,vob,thiswgt +! real(r_kind) dist2min,dist2max +! real(r_kind) dist2_5min,dist2_5max + real(r_kind) vad_leash + +! following variables are use for tdr rw data + real(r_double),dimension(4,maxlevs):: tdr_obs + integer(i_kind) :: ii,jjj,nmissing,nirrr,noutside,ntimeout,nsubzero,iimax + integer(i_kind) ntdrvr_in,ntdrvr_kept,ntdrvr_thin1,ntdrvr_thin2 + integer(i_kind) ntdrvr_thin2_foreswp,ntdrvr_thin2_aftswp + integer(i_kind) maxout,maxdata + integer(i_kind) kk,klon1,klat1,klonp1,klatp1 + integer(i_kind),allocatable,dimension(:):: isort + + real(r_single) elevmax,elevmin + real(r_single) thisrange,thisazimuth,thistilt + real(r_single), dimension(maxlevs) :: dopbin, z, elev, elat8, elon8, glob_azimuth8 + + real(r_kind) rlon0,this_stalatr,thistiltr + real(r_kind) clat0,slat0 + real(r_single) a43,aactual,selev0,celev0,erad + + real(r_kind) sin2,termg,termr,termrg,zobs + real(r_kind) xmesh,pmesh + real(r_kind),dimension(nsig):: zges,hges + real(r_kind) dx,dy,dx1,dy1,w00,w10,w01,w11 + logical luse + integer(i_kind) ntmp,iout + integer(i_kind):: zflag + integer(i_kind) nlevz ! vertical level for thinning + real(r_kind) crit1,timedif + real(r_kind),allocatable,dimension(:):: zl_thin + real(r_kind),parameter:: r16000 = 16000.0_r_kind + real(r_kind) diffuu,diffvv + +! following variables are for fore/aft separation + real(r_kind) tdrele1,tdrele2,tdrele3 + integer(i_kind) nswp,firstbeam,nforeswp,naftswp,nfore,naft,nswptype,irec + logical foreswp,aftswp + + data lnbufr/10/ + data hdrstr(1) / 'CLAT CLON SELV ANEL YEAR MNTH DAYS HOUR MINU MGPT' / + data hdrstr(2) / 'PTID YEAR MNTH DAYS HOUR MINU SECO CLAT CLON HSMSL ANAZ ANEL' / + data datstr(1) / 'STDM SUPLAT SUPLON HEIT RWND RWAZ RSTD' / + data datstr(2) / 'DIST HREF DMVR DVSW' / + + data ithin / -9 / + data rmesh / -99.999_r_kind / + logical print_verbose +!*********************************************************************************** + print_verbose=.false. + if(verbose)print_verbose=.true. + +! Check to see if radar wind files exist. If none exist, exit this routine. + inquire(file='radar_supobs_from_level2',exist=lexist1) + inquire(file=trim(infile),exist=lexist2) + if (.not.lexist1 .and. .not.lexist2) return + + eradkm=rearth*0.001_r_kind + maxobs=2e6 + nreal=maxdat + nchanl=0 + ilon=2 + ilat=3 + iaaamax=-huge(iaaamax) + iaaamin=huge(iaaamin) + dlatmax=-huge(dlatmax) + dlonmax=-huge(dlonmax) + dlatmin=huge(dlatmin) + dlonmin=huge(dlonmin) + + if(ianldate > 2016092000)then + hdrstr(2)='PTID YEAR MNTH DAYS HOUR MINU SECO CLAT CLON FLVLST ANAZ ANEL' + end if + + allocate(cdata_all(maxdat,maxobs),isort(maxobs)) + + isort = 0 + cdata_all=zero + + if (trim(infile) /= 'tldplrbufr' .and. trim(infile) /= 'tldplrso') then + +! Initialize variables +! vad_leash=.1_r_kind + vad_leash=.3_r_kind + ! xscale=5000._r_kind + ! xscale=10000._r_kind + xscale=20000._r_kind + if(print_verbose)then + write(6,*)'READ_RADAR: set vad_leash,xscale=',vad_leash,xscale + write(6,*)'READ_RADAR: set maxvadbins,maxbadbins*dzvad=',maxvadbins,& + maxvadbins*dzvad + end if + xscalei=one/xscale + max_rrr=nint(100000.0_r_kind*xscalei) + nboxmax=1 + + kx0=22500 + + nmrecs=0 + irec=0 + + errzmax=zero + nvad=0 + vadlon=zero + vadlat=zero + vadqm=-99999_r_kind + vadu=zero + vadv=zero + vadcount=zero + vadqmmax=-huge(vadqmmax) + vadqmmin=huge(vadqmmin) + +! First read in all vad winds so can use vad wind quality marks to decide +! which radar data to keep +! Open, then read bufr data + + open(lnbufr,file=vadfile,form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + call datelen(10) + + loop0: do + call readsb(lnbufr,iret) + if(iret/=0) then + call readmg(lnbufr,subset,idate,iret) + if(iret/=0) exit loop0 + cycle loop0 + end if + call ufbint(lnbufr,hdr,7,1,levs,'SID XOB YOB DHR TYP SAID TSB') + kx=nint(hdr(5)) + if(kx /= 224)cycle loop0 ! for now just hardwire vad wind type + if(kx==224 .and. .not.newvad) then + if(hdr(7)==2) then + newvad=.true. + exit loop0 + end if + end if +! End of bufr read loop + end do loop0 + + call closbf(lnbufr) + +! enddo msg_report + + open(lnbufr,file=vadfile,form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + call datelen(10) + call readmg(lnbufr,subset,idate,iret) + if(iret==0) then + +! Time offset + call time_4dvar(idate,toff) + + write(date,'( i10)') idate + read (date,'(i4,3i2)') iy,im,idd,ihh + if(print_verbose) & + write(6,*)'READ_RADAR: first read vad winds--use vad quality marks to qc 2.5/3 radar winds' + +! Big loop over vadwnd bufr file + loop1: do + call readsb(lnbufr,iret) + if(iret/=0) then + call readmg(lnbufr,subset,idate,iret) + if(iret/=0) exit loop1 + cycle loop1 + end if + nmrecs = nmrecs+1 + +! Read header. Extract station infomration + call ufbint(lnbufr,hdr,7,1,levs,'SID XOB YOB DHR TYP SAID TSB') + kx=nint(hdr(5)) + if(kx /= 224) cycle loop1 ! for now just hardwire vad wind type + +! write(6,*)'new vad::',newvad, hdr(7) + if(.not.newvad .and. hdr(7)==2) cycle loop1 + if(newvad .and. hdr(7)/=2) cycle loop1 + ! and don't worry about subtypes +! Is vadwnd in convinfo file + ikx=0 + do i=1,nconvtype + if(kx == ictype(i)) then + ikx=i + exit + end if + end do + if(ikx == 0) cycle loop1 + +! Time check + t4dv=toff+hdr(4) + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle loop1 ! outside time window + else + timeb=hdr(4) + if(abs(timeb) > ctwind(ikx) .or. abs(timeb) > half) cycle loop1 ! outside time window + endif + +! Create table of vad lat-lons and quality marks in 500m increments +! for cross-referencing bird qc against radar winds + rstation_id=hdr(1) !station id + dlon_earth=hdr(2) !station lat (degrees) + dlat_earth=hdr(3) !station lon (degrees) + + if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if (dlon_earth0) then + do i=1,nvad + if(modulo(rad2deg*abs(dlon_earth-vadlon(i)),r360)maxvad) then + write(6,*)'READ_RADAR: ***ERROR*** MORE THAN ',maxvad,' RADARS: PROGRAM STOPS' + call stop2(84) + end if + ivad=nvad + vadlon(ivad)=dlon_earth + vadlat(ivad)=dlat_earth + vadid(ivad)=cstaid + end if + +! Update vadqm table + call ufbint(lnbufr,vad_obs,4,maxlevs,levs,'ZOB WQM UOB VOB ') + call ufbint(lnbufr,fcst_obs,2,maxlevs,levs,'UFC VFC ') + if(levs>maxlevs) then + write(6,*)'READ_RADAR: ***ERROR*** need to increase read_radar bufr size since ',& + ' number of levs=',levs,' > maxlevs=',maxlevs + call stop2(84) + endif + + do k=1,levs + wqm=vad_obs(2,k) + zob=vad_obs(1,k) + uob=vad_obs(3,k) + vob=vad_obs(4,k) + if(newvad) then + diffuu=uob-fcst_obs(1,k) + diffvv=vob-fcst_obs(2,k) + if(sqrt(diffuu**2+diffvv**2)>10.0) cycle + if(abs(diffvv)>8.0) cycle + if(abs(diffvv)>5.0.and.zob<5000.0) cycle + if(zob>7000.0) cycle + end if + ivadz=nint(zob/dzvad) + if(ivadz<1.or.ivadz>maxvadbins) cycle + errzmax=max(abs(zob-ivadz*dzvad),errzmax) + vadqm(ivad,ivadz)=max(vadqm(ivad,ivadz),wqm) + vadqmmax=max(vadqmmax,wqm) + vadqmmin=min(vadqmmin,wqm) + vadu(ivad,ivadz)=vadu(ivad,ivadz)+uob + vadv(ivad,ivadz)=vadv(ivad,ivadz)+vob + vadcount(ivad,ivadz)=vadcount(ivad,ivadz)+one + end do + + +! End of bufr read loop + end do loop1 + +! Normal exit + end if + call closbf(lnbufr) + + +! Print vadwnd table + if(nvad>0) then + do ivad=1,nvad + do ivadz=1,maxvadbins + vadu(ivad,ivadz)=vadu(ivad,ivadz)/max(one,vadcount(ivad,ivadz)) + vadv(ivad,ivadz)=vadv(ivad,ivadz)/max(one,vadcount(ivad,ivadz)) + end do + if(print_verbose) & + write(6,'(" n,lat,lon,qm=",i3,2f8.2,2x,25i3)') & + ivad,vadlat(ivad)*rad2deg,vadlon(ivad)*rad2deg,(max(-9,nint(vadqm(ivad,k))),k=1,maxvadbins) + end do + end if + if(print_verbose)write(6,*)' errzmax=',errzmax + +! Allocate thinning grids around each radar +! space needed is nvad*max_rrr*max_rrr*8*max_zzz +! +! max_rrr=20 +! maxvadbins=20 +! nvad=150 +! space=150*20*20*8*20 = 64000*150=9600000 peanuts + + allocate(nobs_box(max_rrr,8*max_rrr,maxvadbins,nvad)) + nobs_box=0 + +! Set level2_5 to 0. Then loop over routine twice, first looking for +! level 2.5 data, and setting level2_5=count of 2.5 data for any 2.5 data +! available that passes the vad tests. The second pass puts in level 3 +! data where it is available and no level 2.5 data was saved/available +! (level2_5=0) + + vadfit2=zero + vadfit2_5=zero + vadfit3=zero + vadwgt2=zero + vadwgt2_5=zero + vadwgt3=zero + vadcount2=zero + vadcount2_5=zero + vadcount3=zero + level2=0 + level2_5=0 + level3=0 + level3_tossed_by_2_5=0 + subset_check(1)='NC006002' + subset_check(2)='NC006001' + +! First process any level 2 superobs. +! Initialize variables. + ikx=0 + do i=1,nconvtype + if(trim(ioctype(i)) == trim(obstype))ikx = i + end do + + timemax=-huge(timemax) + timemin=huge(timemin) + errmax=-huge(errmax) + errmin=huge(errmin) + loop=0 + + numhits=0 + ibadazm=0 + ibadwnd=0 + ibaddist=0 + ibadheight=0 + ibadstaheight=0 + iheightbelowsta=0 + ibaderror=0 + ibadvad=0 + ibadfit=0 + ioutofvadrange=0 + kthin=0 + novadmatch=0 + notgood=0 + notgood0=0 + nsuper2_in=0 + nsuper2_kept=0 + +! LEVEL_TWO_READ: if(loop==0 .and. sis=='l2rw') then + if(loop==0) outmessage='level 2 superobs:' + +! Open sequential file containing superobs + open(lnbufr,file='radar_supobs_from_level2',form='unformatted') + rewind lnbufr + + ! dist2max=-huge(dist2max) + ! dist2min=huge(dist2min) + +! Loop to read superobs data file + do + read(lnbufr,iostat=iret)this_staid,this_stalat,this_stalon,this_stahgt, & + thistime,thislat,thislon,thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt + if(iret/=0) exit + nsuper2_in=nsuper2_in+1 + + dlat_earth=this_stalat !station lat (degrees) + dlon_earth=this_stalon !station lon (degrees) + if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if (dlon_earthwinlen) cycle + else + timeo=thistime + if(abs(timeo)>half ) cycle + endif + +! Get observation (lon,lat). Compute distance from radar. + dlat_earth=thislat + dlon_earth=thislon + if(dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if(dlon_earthmax_rrr) cycle + +! Extract radial wind data + height= thishgt + rwnd = thisvr + azm_earth = corrected_azimuth + if(regional) then + cosazm_earth=cos(azm_earth*deg2rad) + sinazm_earth=sin(azm_earth*deg2rad) + call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) + azm=atan2(sinazm,cosazm)*rad2deg + else + azm=azm_earth + end if + iaaa=azm/(r360/(r8*irrr)) + iaaa=mod(iaaa,8*irrr) + if(iaaa<0) iaaa=iaaa+8*irrr + iaaa=iaaa+1 + iaaamax=max(iaaamax,iaaa) + iaaamin=min(iaaamin,iaaa) + + error = erradar_inflate*thiserr + errmax=max(error,errmax) + if(thiserr>zero) errmin=min(error,errmin) + +! Perform limited qc based on azimuth angle, radial wind +! speed, distance from radar site, elevation of radar, +! height of observation, observation error, and goodness of fit to vad wind + + good0=.true. + if(abs(azm)>r400) then + ibadazm=ibadazm+1; good0=.false. + end if + if(abs(rwnd)>r200) then + ibadwnd=ibadwnd+1; good0=.false. + end if + if(dist>r400) then + ibaddist=ibaddist+1; good0=.false. + end if + if(staheight<-r1000.or.staheight>r50000) then + ibadstaheight=ibadstaheight+1; good0=.false. + end if + if(height<-r1000.or.height>r50000) then + ibadheight=ibadheight+1; good0=.false. + end if + if(heightr6 .or. thiserr<=zero) then + ibaderror=ibaderror+1; good0=.false. + end if + good=.true. + if(.not.good0) then + notgood0=notgood0+1 + cycle + else + +! Check fit to vad wind and vad wind quality mark + ivadz=nint(thishgt/dzvad) + if(ivadz>maxvadbins.or.ivadz<1) then + ioutofvadrange=ioutofvadrange+1 + cycle + end if + thiswgt=one/max(r4_r_kind,thiserr**2) + thisfit2=(vadu(ivad,ivadz)*cos(azm_earth*deg2rad)+vadv(ivad,ivadz)*sin(azm_earth*deg2rad)-thisvr)**2 + thisfit=sqrt(thisfit2) + thisvadspd=sqrt(vadu(ivad,ivadz)**2+vadv(ivad,ivadz)**2) + vadfit2(ivad,ivadz)=vadfit2(ivad,ivadz)+thiswgt*thisfit2 + vadcount2(ivad,ivadz)=vadcount2(ivad,ivadz)+one + vadwgt2(ivad,ivadz)=vadwgt2(ivad,ivadz)+thiswgt + if(thisfit/max(one,thisvadspd)>vad_leash) then + ibadfit=ibadfit+1; good=.false. + end if + if(nobs_box(irrr,iaaa,ivadz,ivad)>nboxmax) then + kthin=kthin+1 + good=.false. + end if + if(vadqm(ivad,ivadz) > r3_5 .or. vadqm(ivad,ivadz) < -one) then + ibadvad=ibadvad+1 ; good=.false. + end if + end if + +! If data is good, load into output array + if(good) then + nsuper2_kept=nsuper2_kept+1 + level2(ivad)=level2(ivad)+1 + nobs_box(irrr,iaaa,ivadz,ivad)=nobs_box(irrr,iaaa,ivadz,ivad)+1 + ndata =min(ndata+1,maxobs) + nodata =min(nodata+1,maxobs) !number of obs not used (no meaning here) + usage = zero + if(icuse(ikx) < 0)usage=r100 + if(ncnumgrp(ikx) > 0 )then ! cross validation on + if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) + end if + + call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) + + LEVEL_TWO_READ: if(loop==0 .and. sis=='l2rw') then + cdata(1) = error ! wind obs error (m/s) + cdata(2) = dlon ! grid relative longitude + cdata(3) = dlat ! grid relative latitude + cdata(4) = height ! obs absolute height (m) + cdata(5) = rwnd ! wind obs (m/s) + cdata(6) = azm*deg2rad ! azimuth angle (radians) + cdata(7) = t4dv ! obs time (hour) + cdata(8) = ikx ! type + cdata(9) = tiltangle ! tilt angle (radians) + cdata(10)= staheight ! station elevation (m) + cdata(11)= rstation_id ! station id + cdata(12)= usage ! usage parameter + cdata(13)= idomsfc ! dominate surface type + cdata(14)= skint ! skin temperature + cdata(15)= ff10 ! 10 meter wind factor + cdata(16)= sfcr ! surface roughness + cdata(17)=dlon_earth_deg ! earth relative longitude (degrees) + cdata(18)=dlat_earth_deg ! earth relative latitude (degrees) + cdata(19)=dist ! range from radar in km (used to estimate beam spread) + cdata(20)=zsges ! model elevation at radar site + cdata(21)=thiserr + cdata(22)=two + +! if(vadid(ivad)=='0303LWX') then +! dist2max=max(dist2max,dist) +! dist2min=min(dist2min,dist) +! end if + + do i=1,maxdat + cdata_all(i,ndata)=cdata(i) + end do + END IF LEVEL_TWO_READ + + else + notgood = notgood + 1 + end if + + end do + + close(lnbufr) ! A simple unformatted fortran file should not be mixed with a bufr I/O + + LEVEL_TWO_READ_2: if(loop==0 .and. sis=='l2rw') then + write(6,*)'READ_RADAR: ',trim(outmessage),' reached eof on 2/2.5/3 superob radar file' + write(6,*)'READ_RADAR: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept + write(6,*)'READ_RADAR: # no vad match =',novadmatch + write(6,*)'READ_RADAR: # out of vadrange=',ioutofvadrange + write(6,*)'READ_RADAR: # bad azimuths=',ibadazm + write(6,*)'READ_RADAR: # bad winds =',ibadwnd + write(6,*)'READ_RADAR: # bad dists =',ibaddist + write(6,*)'READ_RADAR: # bad stahgts =',ibadstaheight + write(6,*)'READ_RADAR: # bad obshgts =',ibadheight + write(6,*)'READ_RADAR: # bad errors =',ibaderror + write(6,*)'READ_RADAR: # bad vadwnd =',ibadvad + write(6,*)'READ_RADAR: # bad fit =',ibadfit + write(6,*)'READ_RADAR: # num thinned =',kthin + write(6,*)'READ_RADAR: # notgood0 =',notgood0 + write(6,*)'READ_RADAR: # notgood =',notgood + write(6,*)'READ_RADAR: # hgt belowsta=',iheightbelowsta + write(6,*)'READ_RADAR: timemin,max =',timemin,timemax + write(6,*)'READ_RADAR: errmin,max =',errmin,errmax + write(6,*)'READ_RADAR: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax + write(6,*)'READ_RADAR: iaaamin,max,8*max_rrr =',iaaamin,iaaamax,8*max_rrr + END IF LEVEL_TWO_READ_2 + + LEVEL_THREE_READ: if(sis=='l3rw' .or. sis=='rw') then +! Next process level 2.5 and 3 superobs + +! Bigger loop over first level 2.5 data, and then level3 data + + timemax=-huge(timemax) + timemin=huge(timemin) + errmax=-huge(errmax) + errmin=huge(errmin) + nsuper2_5_in=0 + nsuper3_in=0 + nsuper2_5_kept=0 + nsuper3_kept=0 + do loop=1,2 + + numhits=0 + ibadazm=0 + ibadwnd=0 + ibaddist=0 + ibadheight=0 + ibadstaheight=0 + iheightbelowsta=0 + ibaderror=0 + ibadvad=0 + ibadfit=0 + ioutofvadrange=0 + kthin=0 + novadmatch=0 + notgood=0 + notgood0=0 +! dist2_5max=-huge(dist2_5max) +! dist2_5min=huge(dist2_5min) + + if(loop==1) outmessage='level 2.5 superobs:' + if(loop==2) outmessage='level 3 superobs:' + + idate5(1) = iy ! year + idate5(2) = im ! month + idate5(3) = idd ! day + idate5(4) = ihh ! hour + idate5(5) = 0 ! minute + call w3fs21(idate5,mincy) + + nmrecs=0 + +! Open, then read bufr data + open(lnbufr,file=trim(infile),form='unformatted') + + call openbf(lnbufr,'IN',lnbufr) + call datelen(10) + call readmg(lnbufr,subset,idate,iret) + if(iret==0) then + +! Big loop over bufr file + + loop2: do + call readsb(lnbufr,iret) + if(iret/=0) then + call readmg(lnbufr,subset,idate,iret) + if(iret/=0) exit loop2 + cycle loop2 + end if + if(subset/=subset_check(loop)) then + call readmg(lnbufr,subset,idate,iret) + if(iret/=0) exit loop2 + cycle loop2 + end if + nmrecs = nmrecs+1 + + +! Read header. Extract station infomration + call ufbint(lnbufr,hdr,10,1,levs,hdrstr(1)) + + ! rstation_id=hdr(1) !station id + write(cstaid,'(2i4)')idint(hdr(1)),idint(hdr(2)) + if(cstaid(1:1)==' ')cstaid(1:1)='S' + dlat_earth=hdr(1) !station lat (degrees) + dlon_earth=hdr(2) !station lon (degrees) + if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if (dlon_earth230.0_r_kind .and. & + dlat_earth <54.0_r_kind)then + cycle loop2 + end if + end if + end if + dlat_earth = dlat_earth * deg2rad + dlon_earth = dlon_earth * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if (outside) cycle loop2 + dlatmax=max(dlat,dlatmax) + dlonmax=max(dlon,dlonmax) + dlatmin=min(dlat,dlatmin) + dlonmin=min(dlon,dlonmin) + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + + clon=cos(dlon_earth) + slon=sin(dlon_earth) + clat=cos(dlat_earth) + slat=sin(dlat_earth) + staheight=hdr(3) !station elevation + tiltangle=hdr(4)*deg2rad + +! Find vad wind match + ivad=0 + do k=1,nvad + cdist=sin(vadlat(k))*slat+cos(vadlat(k))*clat* & + (sin(vadlon(k))*slon+cos(vadlon(k))*clon) + cdist=max(-one,min(cdist,one)) + dist=rad2deg*acos(cdist) + + if(dist < 0.2_r_kind) then + ivad=k + exit + end if + end do + numhits(ivad)=numhits(ivad)+1 + if(ivad==0) then + novadmatch=novadmatch+1 + cycle loop2 + end if + + vadlon_earth=vadlon(ivad) + vadlat_earth=vadlat(ivad) + if(regional)then + call tll2xy(vadlon_earth,vadlat_earth,dlonvad,dlatvad,outside) + if (outside) cycle loop2 + dlatmax=max(dlatvad,dlatmax) + dlonmax=max(dlonvad,dlonmax) + dlatmin=min(dlatvad,dlatmin) + dlonmin=min(dlonvad,dlonmin) + else + dlatvad = vadlat_earth + dlonvad = vadlon_earth + call grdcrd1(dlatvad,rlats,nlat,1) + call grdcrd1(dlonvad,rlons,nlon,1) + endif + +! Get model terrain at VAD wind location + call deter_zsfc_model(dlatvad,dlonvad,zsges) + + iyr = hdr(5) + imo = hdr(6) + idy = hdr(7) + ihr = hdr(8) + imn = hdr(9) + + idate5(1) = iyr + idate5(2) = imo + idate5(3) = idy + idate5(4) = ihr + idate5(5) = imn + ikx=0 + do i=1,nconvtype + if(trim(ioctype(i)) == trim(obstype))ikx = i + end do + if(ikx==0) cycle loop2 + call w3fs21(idate5,minobs) + t4dv=real(minobs-iwinbgn,r_kind)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle loop2 + else + timeb = real(minobs-mincy,r_kind)*r60inv +! if (abs(timeb)>twind .or. abs(timeb) > ctwind(ikx)) then + if (abs(timeb)>half .or. abs(timeb) > ctwind(ikx)) then +! write(6,*)'READ_RADAR: time outside window ',timeb,' skip this obs' + cycle loop2 + endif + endif + +! Go through the data levels + call ufbint(lnbufr,radar_obs,7,maxlevs,levs,datstr(1)) + if(levs>maxlevs) then + write(6,*)'READ_RADAR: ***ERROR*** increase read_radar bufr size since ',& + 'number of levs=',levs,' > maxlevs=',maxlevs + call stop2(84) + endif + + numcut=0 + do k=1,levs + if(loop==1) nsuper2_5_in=nsuper2_5_in+1 + if(loop==2) nsuper3_in=nsuper3_in+1 + nread=nread+1 + t4dvo=real(minobs+radar_obs(1,k)-iwinbgn,r_kind)*r60inv + timemax=max(timemax,t4dvo) + timemin=min(timemin,t4dvo) + if(loop==2 .and. ivad> 0 .and. level2_5(ivad)/=0) then + level3_tossed_by_2_5(ivad)=level3_tossed_by_2_5(ivad)+1 + numcut=numcut+1 + cycle + end if + +! Exclude data if it does not fall within time window + if (l4dvar.or.l4densvar) then + if (t4dvowinlen) cycle + timeo=t4dv + else + timeo=(real(minobs-mincy,r_kind)+real(radar_obs(1,k),r_kind))*r60inv + if(abs(timeo)>twind .or. abs(timeo) > ctwind(ikx)) then +! write(6,*)'READ_RADAR: time outside window ',timeo,& +! ' skip obs ',nread,' at lev=',k + cycle + end if + end if + +! Get observation (lon,lat). Compute distance from radar. + if(radar_obs(3,k)>=r360) radar_obs(3,k)=radar_obs(3,k)-r360 + if(radar_obs(3,k)max_rrr) cycle + +! Set observation "type" to be function of distance from radar + kxadd=nint(dist*one_tenth) + kx=kx0+kxadd + +! Extract radial wind data + height= radar_obs(4,k) + rwnd = radar_obs(5,k) + azm_earth = r90-radar_obs(6,k) + if(regional) then + cosazm_earth=cos(azm_earth*deg2rad) + sinazm_earth=sin(azm_earth*deg2rad) + call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) + azm=atan2(sinazm,cosazm)*rad2deg + else + azm=azm_earth + end if + iaaa=azm/(r360/(r8*irrr)) + iaaa=mod(iaaa,8*irrr) + if(iaaa<0) iaaa=iaaa+8*irrr + iaaa=iaaa+1 + iaaamax=max(iaaamax,iaaa) + iaaamin=min(iaaamin,iaaa) + + error = erradar_inflate*radar_obs(7,k) + +! Increase error for lev2.5 and lev3 + if (wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional.or.wrf_mass_regional & + .or. fv3_regional ) then + if(dlon_earth*rad2deg>230.0_r_kind .and. & + dlat_earth*rad2deg <54.0_r_kind)then + error = error+r10 + end if + end if + errmax=max(error,errmax) + if(radar_obs(7,k)>zero) errmin=min(error,errmin) + +! Perform limited qc based on azimuth angle, radial wind +! speed, distance from radar site, elevation of radar, +! height of observation, observation error. + + good0=.true. + if(abs(azm)>r400) then + ibadazm=ibadazm+1; good0=.false. + end if + if(abs(rwnd)>r200) then + ibadwnd=ibadwnd+1; good0=.false. + end if + if(dist>r400) then + ibaddist=ibaddist+1; good0=.false. + end if + if(staheight<-r1000 .or. staheight>r50000) then + ibadstaheight=ibadstaheight+1; good0=.false. + end if + if(height<-r1000 .or. height>r50000) then + ibadheight=ibadheight+1; good0=.false. + end if + if(heightr6 .or. radar_obs(7,k)<=zero) then + ibaderror=ibaderror+1; good0=.false. + end if + good=.true. + if(.not.good0) then + notgood0=notgood0+1 + cycle + else + +! Check against vad wind quality mark + ivadz=nint(height/dzvad) + if(ivadz>maxvadbins.or.ivadz<1) then + ioutofvadrange=ioutofvadrange+1 + cycle + end if + thiserr = radar_obs(7,k) + thiswgt=one/max(r4_r_kind,thiserr**2) + thisfit2=(vadu(ivad,ivadz)*cos(azm_earth*deg2rad)+vadv(ivad,ivadz)*sin(azm_earth*deg2rad)-rwnd)**2 + thisfit=sqrt(thisfit2) + thisvadspd=sqrt(vadu(ivad,ivadz)**2+vadv(ivad,ivadz)**2) + if(loop==1) then + vadfit2_5(ivad,ivadz)=vadfit2_5(ivad,ivadz)+thiswgt*thisfit2 + vadcount2_5(ivad,ivadz)=vadcount2_5(ivad,ivadz)+one + vadwgt2_5(ivad,ivadz)=vadwgt2_5(ivad,ivadz)+thiswgt + else + vadfit3(ivad,ivadz)=vadfit3(ivad,ivadz)+thiswgt*thisfit2 + vadcount3(ivad,ivadz)=vadcount3(ivad,ivadz)+one + vadwgt3(ivad,ivadz)=vadwgt3(ivad,ivadz)+thiswgt + end if + if(thisfit/max(one,thisvadspd)>vad_leash) then + ibadfit=ibadfit+1; good=.false. + end if + if(nobs_box(irrr,iaaa,ivadz,ivad)>nboxmax) then + kthin=kthin+1 + good=.false. + end if + if(vadqm(ivad,ivadz)>r3_5 .or. vadqm(ivad,ivadz)<-one) then + ibadvad=ibadvad+1 ; good=.false. + end if + end if + +! If data is good, load into output array + if(good) then + if(loop==1.and.ivad>0) then + nsuper2_5_kept=nsuper2_5_kept+1 + level2_5(ivad)=level2_5(ivad)+1 + end if + if(loop==2.and.ivad>0) then + nsuper3_kept=nsuper3_kept+1 + level3(ivad)=level3(ivad)+1 + end if + nobs_box(irrr,iaaa,ivadz,ivad)=nobs_box(irrr,iaaa,ivadz,ivad)+1 + ndata = min(ndata+1,maxobs) + nodata = min(nodata+1,maxobs) !number of obs not used (no meaning here) + usage = zero + if(icuse(ikx) < 0)usage=r100 + if(ncnumgrp(ikx) > 0 )then ! cross validation on + if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) + end if + + call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) + + cdata(1) = error ! wind obs error (m/s) + cdata(2) = dlon ! grid relative longitude + cdata(3) = dlat ! grid relative latitude + cdata(4) = height ! obs absolute height (m) + cdata(5) = rwnd ! wind obs (m/s) + cdata(6) = azm*deg2rad ! azimuth angle (radians) + cdata(7) = t4dvo ! obs time (hour) + cdata(8) = ikx ! type + cdata(9) = tiltangle ! tilt angle (radians) + cdata(10)= staheight ! station elevation (m) + cdata(11)= rstation_id ! station id + cdata(12)= usage ! usage parameter + cdata(13)= idomsfc ! dominate surface type + cdata(14)= skint ! skin temperature + cdata(15)= ff10 ! 10 meter wind factor + cdata(16)= sfcr ! surface roughness + cdata(17)=dlon_earth_deg ! earth relative longitude (degrees) + cdata(18)=dlat_earth_deg ! earth relative latitude (degrees) + cdata(19)=dist ! range from radar in km (used to estimate beam spread) + cdata(20)=zsges ! model elevation at radar site + cdata(21)=radar_obs(7,k) ! original error from bufr file + if(loop==1) then + cdata(22)=2.5_r_kind + else + cdata(22)=three + end if + + do i=1,maxdat + cdata_all(i,ndata)=cdata(i) + end do + + else + notgood = notgood + 1 + end if + +! End of k loop over levs + end do + +! End of bufr read loop + end do loop2 + end if + +! Normal exit + +! Close unit to bufr file + call closbf(lnbufr) + + + write(6,*)'READ_RADAR: ',trim(outmessage),' reached eof on 2.5/3 superob radar file.' + + if(loop==1) write(6,*)'READ_RADAR: nsuper2_5_in,nsuper2_5_kept=',nsuper2_5_in,nsuper2_5_kept + if(loop==2) write(6,*)'READ_RADAR: nsuper3_in,nsuper3_kept=',nsuper3_in,nsuper3_kept + write(6,*)'READ_RADAR: # no vad match =',novadmatch + write(6,*)'READ_RADAR: # out of vadrange=',ioutofvadrange + write(6,*)'READ_RADAR: # bad azimuths=',ibadazm + write(6,*)'READ_RADAR: # bad winds =',ibadwnd + write(6,*)'READ_RADAR: # bad dists =',ibaddist + write(6,*)'READ_RADAR: # bad stahgts =',ibadstaheight + write(6,*)'READ_RADAR: # bad obshgts =',ibadheight + write(6,*)'READ_RADAR: # bad errors =',ibaderror + write(6,*)'READ_RADAR: # bad vadwnd =',ibadvad + write(6,*)'READ_RADAR: # bad fit =',ibadfit + write(6,*)'READ_RADAR: # num thinned =',kthin + write(6,*)'READ_RADAR: # notgood0 =',notgood0 + write(6,*)'READ_RADAR: # notgood =',notgood + write(6,*)'READ_RADAR: # hgt belowsta=',iheightbelowsta + write(6,*)'READ_RADAR: timemin,max =',timemin,timemax + write(6,*)'READ_RADAR: errmin,max =',errmin,errmax + write(6,*)'READ_RADAR: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax + write(6,*)'READ_RADAR: iaaamin,max,8*max_rrr =',iaaamin,iaaamax,8*max_rrr + + end do ! end bigger loop over first level 2.5, then level 3 radar data + END IF LEVEL_THREE_READ + +! Write out vad statistics + do ivad=1,nvad + if(print_verbose)write(6,'(" fit of 2, 2.5, 3 data to vad station, lat, lon = ",a8,2f14.2)') & + vadid(ivad),vadlat(ivad)*rad2deg,vadlon(ivad)*rad2deg + do ivadz=1,maxvadbins + if(vadcount2(ivad,ivadz) > half .and. vadcount2_5(ivad,ivadz) > half & + .and. vadcount(ivad,ivadz) > half)then + if(vadcount2(ivad,ivadz)>half) then + vadfit2(ivad,ivadz)=sqrt(vadfit2(ivad,ivadz)/vadwgt2(ivad,ivadz)) + else + vadfit2(ivad,ivadz)=zero + end if + if(vadcount2_5(ivad,ivadz)>half) then + vadfit2_5(ivad,ivadz)=sqrt(vadfit2_5(ivad,ivadz)/vadwgt2_5(ivad,ivadz)) + else + vadfit2_5(ivad,ivadz)=zero + end if + if(vadcount3(ivad,ivadz)>half) then + vadfit3(ivad,ivadz)=sqrt(vadfit3(ivad,ivadz)/vadwgt3(ivad,ivadz)) + else + vadfit3(ivad,ivadz)=zero + end if + if(print_verbose)write(6,'(" h,f2,f2.5,f3=",i7,f10.2,"/",i5,f10.2,"/",i5,f10.2,"/",i5)')nint(ivadz*dzvad),& + vadfit2(ivad,ivadz),nint(vadcount2(ivad,ivadz)),& + vadfit2_5(ivad,ivadz),nint(vadcount2_5(ivad,ivadz)),& + vadfit3(ivad,ivadz),nint(vadcount3(ivad,ivadz)) + end if + end do + end do + + deallocate(nobs_box) + + end if + + erad = rearth + thiserr=5.0_r_kind + + timemax=-huge(timemax) + timemin=huge(timemin) + errmax=-huge(errmax) + errmin=huge(errmin) + elevmax=-huge(elevmax) + elevmin=huge(elevmin) + + loop=3 + + nirrr=0 + noutside=0 + ntimeout=0 + nsubzero=0 + ibadazm=0 + ibadwnd=0 + ibaddist=0 + ibadtilt=0 + ibadrange=0 + ibadheight=0 + ibadstaheight=0 + notgood=0 + notgood0=0 + nread=0 + ntdrvr_in=0 + ntdrvr_kept=0 + ntdrvr_thin1=0 + ntdrvr_thin2=0 + ntdrvr_thin2_foreswp=0 + ntdrvr_thin2_aftswp=0 + maxout=0 + maxdata=0 + nmissing=0 + subset_check(3)='NC006070' + icntpnt=0 + nswp=0 + nforeswp=0 + naftswp=0 + nfore=0 + naft=0 + + xscale=100._r_kind + xscalei=one/xscale + max_rrr=nint(100000.0_r_kind*xscalei) + jjj=0 + iimax=0 + + if(loop == 3) outmessage='tail Doppler radar obs:' + + use_all = .true. + do i=1,nconvtype + if(trim(ioctype(i)) == trim(obstype) .and. ictype(i) < 999 .and. icuse(i) > 0)then + ithin=ithin_conv(i) + if(ithin > 0)then + rmesh=rmesh_conv(i) + pmesh=pmesh_conv(i) + use_all = .false. + if(pmesh > zero) then ! Here pmesh is height in meters + zflag=1 + nlevz=r16000/pmesh + else + zflag=0 + nlevz=nsig + endif + xmesh=rmesh + call make3grids(xmesh,nlevz) + allocate(zl_thin(nlevz)) + if (zflag==1) then + do k=1,nlevz + zl_thin(k)=(k-1)*pmesh + enddo + endif + write(6,*)'READ_RADAR: obstype,ictype,rmesh,zflag,nlevz,pmesh=',& + trim(ioctype(i)),ictype(i),rmesh,zflag,nlevz,pmesh + exit + end if + end if + end do + + if(trim(infile) == 'tldplrso') then + +! Loop to read TDR superobs data + + ikx=0 + do i=1,nconvtype + if(trim(ioctype(i)) == trim(obstype))ikx = i + end do + if(ikx == 0) return + + call w3fs21(iadate,mincy) ! analysis time in minutes + + open(lnbufr,file=trim(infile),form='formatted',err=300) + rewind (lnbufr) + do n=1,10 + istop=0 + read(lnbufr,'(a)',err=200,end=1200)filename + print *,'filename=', trim(filename) + open(25,file=trim(filename),form='formatted',access='sequential') + loop3: do while (istop.eq.0) + ii=1 + READ(25,'(I4,4I2,8F10.3)',iostat=istop) iyr,imo,idy,ihr,imn,this_stalat, & + this_stalon,this_stahgt,azm0,elev0,range0,thisvr,rotang + + nread=nread+1 + + idate5(1) = iyr + idate5(2) = imo + idate5(3) = idy + idate5(4) = ihr + idate5(5) = imn + call w3fs21(idate5,minobs) + + t4dv=real(minobs-iwinbgn,r_kind)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) cycle loop3 + timeo=t4dv + else + timeo = real(minobs-mincy,r_kind)*r60inv + if (abs(timeo)>twind) cycle loop3 + endif + + timemax=max(timemax,timeo) + timemin=min(timemin,timeo) + + rlon0=deg2rad*this_stalon + this_stalatr=this_stalat*deg2rad + clat0=cos(this_stalatr) ; slat0=sin(this_stalatr) + thistilt=elev0 + elevmax=max(elevmax,thistilt) + elevmin=min(elevmin,thistilt) + thisazimuth=azm0 + thisrange=range0*r1000 + if(abs(thistilt)>r75)then + ibadtilt=ibadtilt+1; cycle loop3 + endif + + staheight=this_stahgt + if(staheight<-r1000.or.staheight>r50000) then + ibadstaheight=ibadstaheight+1; cycle loop3 + end if + + aactual=erad+this_stahgt + thistiltr=thistilt*deg2rad + selev0=sin(thistiltr) ; celev0=cos(thistiltr) + a43=four_thirds*aactual + + + call getvrlocalinfo(thisrange,thisazimuth,this_stahgt,aactual,a43,selev0,celev0, & + rlon0,clat0,slat0,r8,r89_5,nsubzero,ii,z(ii),elev(ii),elat8(ii), & + elon8(ii),glob_azimuth8(ii)) + + + dlat_earth=this_stalat !station lat (degrees) + dlon_earth=this_stalon !station lon (degrees) + if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if (dlon_earth=r360) dlon_earth=dlon_earth-r360 + if(dlon_earthmax_rrr)then + nirrr=nirrr+1 + cycle + endif + +! Extract radial wind data + height= z(ii) + rwnd = thisvr + azm_earth = glob_azimuth8(ii) + if(regional) then + cosazm_earth=cos(azm_earth*deg2rad) + sinazm_earth=sin(azm_earth*deg2rad) + call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) + azm=atan2(sinazm,cosazm)*rad2deg + else + azm=azm_earth + end if + iaaa=azm/(r360/(r8*irrr)) + iaaa=mod(iaaa,8*irrr) + if(iaaa<0) iaaa=iaaa+8*irrr + iaaa=iaaa+1 + iaaamax=max(iaaamax,iaaa) + iaaamin=min(iaaamin,iaaa) + error = erradar_inflate*thiserr + errmax=max(error,errmax) + if(thiserr>zero) errmin=min(error,errmin) + +! Perform limited qc based on azimuth angle, elevation angle, radial wind +! speed, range, distance from radar site + + good0=.true. + if(abs(azm)>r400) then + ibadazm=ibadazm+1; good0=.false. + end if + if(abs(rwnd) > r71) then + ibadwnd=ibadwnd+1; good0=.false. + end if + if(thisrange>r92) then + ibadrange=ibadrange+1; good0=.false. + end if + if(dist>r400) then + ibaddist=ibaddist+1; good0=.false. + end if + if(height<-r1000.or.height>r50000) then + ibadheight=ibadheight+1; good0=.false. + end if + good=.true. + if(.not.good0) then + notgood0=notgood0+1 + cycle + end if +! if data is good, load into output array + + if(good) then + ntdrvr_kept=ntdrvr_kept+1 +!#################### Data thinning ################### + + icntpnt=icntpnt+1 + + if(ithin > 0)then + if(zflag == 0)then + klon1= int(dlon); klat1= int(dlat) + dx = dlon-klon1; dy = dlat-klat1 + dx1 = one-dx; dy1 = one-dy + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) + if (klon1==0) klon1=nlon + klatp1=min(nlat,klat1+1); klonp1=klon1+1 + if (klonp1==nlon+1) klonp1=1 + do kk=1,nsig + hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + & + w10*hgtl_full(klatp1,klon1 ,kk) + & + w01*hgtl_full(klat1 ,klonp1,kk) + & + w11*hgtl_full(klatp1,klonp1,kk) + end do + sin2 = sin(dlat_earth)*sin(dlat_earth) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do k=1,nsig + zges(k) = (termr*hges(k)) / (termrg-hges(k)) + zl_thin(k)=zges(k) + end do + endif + + zobs = height + + ntmp=ndata ! counting moved to map3gridS + if (thin4d) then + timedif = zero + else + timedif=abs(t4dv-toff) + endif + crit1 = timedif/r6+half + + call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,& + zobs,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) + maxout=max(maxout,iout) + maxdata=max(maxdata,ndata) + + if (.not. luse) then + ntdrvr_thin2=ntdrvr_thin2+1 + cycle + endif + if(iiout > 0) isort(iiout)=0 + if (ndata > ntmp) then + nodata=nodata+1 + endif + isort(icntpnt)=iout + + else + ndata =ndata+1 + nodata=nodata+1 + iout=ndata + isort(icntpnt)=iout + endif + + if(ndata > maxobs) then + write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype + ndata = maxobs + end if + +! Set usage variable + usage = zero + + if(icuse(ikx) < 0)usage=r100 + if(ncnumgrp(ikx) > 0 )then ! cross validation on + if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) + end if + + call deter_zsfc_model(dlat,dlon,zsges) + +! Get information from surface file necessary for conventional data here + call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) + + + cdata(1) = error ! wind obs error (m/s) + cdata(2) = dlon ! grid relative longitude + cdata(3) = dlat ! grid relative latitude + cdata(4) = height ! obs absolute height (m) + cdata(5) = rwnd ! wind obs (m/s) + cdata(6) = azm*deg2rad ! azimuth angle (radians) + cdata(7) = t4dv ! obs time (hour) + cdata(8) = ikx ! type + cdata(9) = tiltangle ! tilt angle (radians) + cdata(10)= staheight ! station elevation (m) + cdata(11)= rstation_id ! station id + cdata(12)= usage ! usage parameter + cdata(13)= idomsfc ! dominate surface type + cdata(14)= skint ! skin temperature + cdata(15)= ff10 ! 10 meter wind factor + cdata(16)= sfcr ! surface roughness + cdata(17)=dlon_earth_deg ! earth relative longitude (degrees) + cdata(18)=dlat_earth_deg ! earth relative latitude (degrees) + cdata(19)=dist ! range from radar in km (used to estimate beam spread) + cdata(20)=zsges ! model elevation at radar site + cdata(21)=thiserr + cdata(22)=three+two ! tail Doppler radar + do j=1,maxdat + cdata_all(j,iout)=cdata(j) + end do + jjj=jjj+1 + else + notgood = notgood + 1 + end if ! if(good) + + end do loop3! end of loop, reading records of data + close(25) + + end do ! end of loop, reading TDR so data files + + else + + nswptype=0 + nmrecs=0 + irec=0 + +! Open data file + open(lnbufr,file=trim(infile),form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + call datelen(10) + call readmg(lnbufr,subset,idate,iret) + if(iret==0) then + +! Time offset + call time_4dvar(idate,toff) + + write(date,'( i10)') idate + read (date,'(i4,3i2)') iy,im,idd,ihh + write(6,*)'READ_RADAR: bufr file date is ',iy,im,idd,ihh + + idate5(1) = iy ! year + idate5(2) = im ! month + idate5(3) = idd ! day + idate5(4) = ihh ! hour + idate5(5) = 0 ! minute + call w3fs21(idate5,mincy) + + if(l_foreaft_thin)then + +! Read the first 500 records to deterine which criterion +! should be used to seperate fore/aft sweep + +! Big loop over bufr file + + loop5: do + call readsb(lnbufr,iret) + if(iret/=0) then + call readmg(lnbufr,subset,idate,iret) + if(iret/=0) exit loop5 + cycle loop5 + end if + if(subset/=subset_check(loop)) then + call readmg(lnbufr,subset,idate,iret) + if(iret/=0) exit loop5 + cycle loop5 + end if + nmrecs = nmrecs+1 + +! Read header. Extract elevation angle + call ufbint(lnbufr,hdr,12,1,levs,hdrstr(2)) + thistilt=hdr(12) + + if(nmrecs == 1)then + tdrele1 = hdr(12) + tdrele2 = hdr(12) + end if + + tdrele1 = tdrele2 + tdrele2 = hdr(12) + if(abs(tdrele2-tdrele1)>r100) then + print *,'tdrele2,tdrele1=',tdrele2,tdrele1 + nswptype=1 + exit loop5 + end if + + if(nmrecs <= 500)then + cycle loop5 + else + exit loop5 + end if + + end do loop5 + + firstbeam = 0 + foreswp = .true. + aftswp = .false. + nforeswp=1 + naftswp=0 + nswp=1 + + call closbf(lnbufr) + close(lnbufr) + + open(lnbufr,file=trim(infile),form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + call datelen(10) + call readmg(lnbufr,subset,idate,iret) + + else + foreswp = .false. + aftswp = .false. + end if + + print *,'nmrecs, nswptype=', nmrecs, nswptype + + nmrecs=0 + +! Big loop over bufr file + + loop4: do + call readsb(lnbufr,iret) + if(iret/=0) then + call readmg(lnbufr,subset,idate,iret) + if(iret/=0) exit loop4 + cycle loop4 + end if + if(subset/=subset_check(loop)) then + call readmg(lnbufr,subset,idate,iret) + if(iret/=0) exit loop4 + cycle loop4 + end if + nmrecs = nmrecs+1 + irec = irec+1 + +! Read header. Extract station infomration + call ufbint(lnbufr,hdr,12,1,levs,hdrstr(2)) + +! rstation_id=hdr(1) + if(hdr(1) == zero)then + cstaid='NOAA ' + else if(hdr(1) == one)then + cstaid='FRENCH ' + else if(hdr(1)== two)then + cstaid='G-IV ' + else if(hdr(1)== three)then + cstaid='AOC ' + else + cstaid='UNKNOWN ' + endif + + kx=990+nint(hdr(1)) + + if(nmrecs==1)print *,'Antenna ID:', hdr(1),cstaid + + iyr = hdr(2) + imo = hdr(3) + idy = hdr(4) + ihr = hdr(5) + imn = hdr(6) + isc = hdr(7) + + idate5(1) = iyr + idate5(2) = imo + idate5(3) = idy + idate5(4) = ihr + idate5(5) = imn + ikx=0 + do i=1,nconvtype + if(trim(ioctype(i)) == trim(obstype) .and. kx == ictype(i))ikx = i + end do + if(ikx == 0) cycle loop4 + call w3fs21(idate5,minobs) + + t4dv=real(minobs-iwinbgn,r_kind)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) then + ntimeout=ntimeout+1 + cycle loop4 + end if + timeo=t4dv + else + timeo = real(minobs-mincy,r_kind)*r60inv + if (abs(timeo) > twind .or. abs(timeo) > ctwind(ikx)) then + ntimeout=ntimeout+1 + cycle loop4 + end if + endif + + timemax=max(timemax,timeo) + timemin=min(timemin,timeo) + + this_stalat=hdr(8) + this_stalon=hdr(9) + + rlon0=deg2rad*this_stalon + this_stalatr=this_stalat*deg2rad + clat0=cos(this_stalatr) ; slat0=sin(this_stalatr) + this_stahgt=hdr(10) + thisazimuth=hdr(11) + thistilt=hdr(12) + elevmax=max(elevmax,thistilt) + elevmin=min(elevmin,thistilt) + +! define fore/aft sweeps for thinning (pseduo dual Doppler) + + if(l_foreaft_thin)then + if (firstbeam == 0) then + tdrele1 = hdr(12) + tdrele2 = hdr(12) + if(nswptype == 0)then + tdrele3 = hdr(12) + end if + firstbeam = 1 + endif + + if(nswptype == 0)then + tdrele1 = tdrele2 + tdrele2 = tdrele3 + tdrele3 = hdr(12) + + if(firstbeam > 0 .and. tdrele2>=tdrele1 .and. tdrele2>=tdrele3 .and. tdrele2 > r60 & + .and. irec > r150)then + if(foreswp) then + foreswp = .false. + aftswp = .true. + naftswp = naftswp+1 + irec=0 + else + aftswp = .false. + foreswp = .true. + nforeswp = nforeswp+1 + irec=0 + endif + + nswp = nswp+1 + endif + + else if(nswptype == 1)then + tdrele1 = tdrele2 + tdrele2 = hdr(12) + + if(abs(tdrele2-tdrele1)>r100) then + if(foreswp) then + foreswp = .false. + aftswp = .true. + naftswp = naftswp+1 + irec=0 + else + aftswp = .false. + foreswp = .true. + nforeswp = nforeswp+1 + irec=0 + endif + + nswp = nswp+1 + endif + else + foreswp = .false. + aftswp = .false. + end if + else + foreswp = .false. + aftswp = .false. + endif + + if(abs(thistilt)>r75)then + ibadtilt=ibadtilt+1; cycle loop4 + endif + + staheight=this_stahgt + if(staheight<-r1000.or.staheight>r50000) then + ibadstaheight=ibadstaheight+1; cycle loop4 + end if + +! Go through the data levels + call ufbint(lnbufr,tdr_obs,4,maxlevs,levs,datstr(2)) + if(levs>maxlevs) then + write(6,*)'READ_RADAR: ***ERROR*** increase read_radar bufr size since ',& + 'number of levs=',levs,' > maxlevs=',maxlevs + call stop2(84) + endif +! use local coordinate centered on this_stalat,this_stalon. note that global and local +! azimuth angle are the same at the origin (this_stalat,this_stalon) +! and azimuth angle is fixed in local coordinate along entire radial line. +! we convert back to global azimuth angle at each point along line +! at end of computation. that way we avoid worrying about where poles are. + + aactual=erad+this_stahgt + thistiltr=thistilt*deg2rad + selev0=sin(thistiltr) ; celev0=cos(thistiltr) + a43=four_thirds*aactual + ii=0 + do k=1,levs + nread=nread+1 +! Select data every 3 km along each beam + if(MOD(INT(tdr_obs(1,k)-tdr_obs(1,1)),3000) < 100)then + if(tdr_obs(3,k) >= 800.) nmissing=nmissing+1 !xx + if(tdr_obs(3,k) < 800.) then + ii=ii+1 + dopbin(ii)=tdr_obs(3,k) + thisrange=tdr_obs(1,k) + + call getvrlocalinfo(thisrange,thisazimuth,this_stahgt,aactual,a43,selev0,celev0, & + rlon0,clat0,slat0,r8,r89_5,nsubzero,ii,z(ii),elev(ii),elat8(ii), & + elon8(ii),glob_azimuth8(ii)) + end if + else + ntdrvr_thin1=ntdrvr_thin1+1 + endif + end do + +! Further process tail Doppler radar Vr data + iimax=max(iimax,ii) + + if( ii > 0 )then + dlat_earth=this_stalat !station lat (degrees) + dlon_earth=this_stalon !station lon (degrees) + if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if (dlon_earth=r360) dlon_earth=dlon_earth-r360 + if(dlon_earthmax_rrr)then + nirrr=nirrr+1 + cycle + endif + +! Extract radial wind data + height= z(i) + rwnd = dopbin(i) + azm_earth = glob_azimuth8(i) + if(regional) then + cosazm_earth=cos(azm_earth*deg2rad) + sinazm_earth=sin(azm_earth*deg2rad) + call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) + azm=atan2(sinazm,cosazm)*rad2deg + else + azm=azm_earth + end if + iaaa=azm/(r360/(r8*irrr)) + iaaa=mod(iaaa,8*irrr) + if(iaaa<0) iaaa=iaaa+8*irrr + iaaa=iaaa+1 + iaaamax=max(iaaamax,iaaa) + iaaamin=min(iaaamin,iaaa) + error = erradar_inflate*thiserr + errmax=max(error,errmax) + if(thiserr>zero) errmin=min(error,errmin) + +! Perform limited qc based on azimuth angle, elevation angle, radial wind +! speed, range, distance from radar site + + good0=.true. + if(abs(azm)>r400) then + ibadazm=ibadazm+1; good0=.false. + end if + if(abs(rwnd) > r71 .or. abs(rwnd) < r2 ) then + ibadwnd=ibadwnd+1; good0=.false. + end if + if(thisrange>r92) then + ibadrange=ibadrange+1; good0=.false. + end if + if(dist>r400) then + ibaddist=ibaddist+1; good0=.false. + end if + if(height<-r1000.or.height>r50000) then + ibadheight=ibadheight+1; good0=.false. + end if + good=.true. + if(.not.good0) then + notgood0=notgood0+1 + cycle + end if +! if data is good, load into output array + + if(good) then + ntdrvr_kept=ntdrvr_kept+1 +!#################### Data thinning ################### + + icntpnt=icntpnt+1 + + if(ithin > 0)then + if(zflag == 0)then + klon1= int(dlon); klat1= int(dlat) + dx = dlon-klon1; dy = dlat-klat1 + dx1 = one-dx; dy1 = one-dy + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) + if (klon1==0) klon1=nlon + klatp1=min(nlat,klat1+1); klonp1=klon1+1 + if (klonp1==nlon+1) klonp1=1 + do kk=1,nsig + hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + & + w10*hgtl_full(klatp1,klon1 ,kk) + & + w01*hgtl_full(klat1 ,klonp1,kk) + & + w11*hgtl_full(klatp1,klonp1,kk) + end do + sin2 = sin(dlat_earth)*sin(dlat_earth) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do k=1,nsig + zges(k) = (termr*hges(k)) / (termrg-hges(k)) + zl_thin(k)=zges(k) + end do + endif + + zobs = height + + ntmp=ndata ! counting moved to map3gridS + if (thin4d) then + timedif = zero + else + timedif=abs(t4dv-toff) + endif + crit1 = timedif/r6+half + + call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,& + zobs,crit1,ndata,iout,icntpnt,iiout,luse,foreswp,aftswp) + maxout=max(maxout,iout) + maxdata=max(maxdata,ndata) + + if (.not. luse) then + if (foreswp) then + ntdrvr_thin2_foreswp=ntdrvr_thin2_foreswp+1 + else if (aftswp) then + ntdrvr_thin2_aftswp=ntdrvr_thin2_aftswp+1 + end if + ntdrvr_thin2=ntdrvr_thin2+1 + cycle + endif + if(iiout > 0) isort(iiout)=0 + if (ndata > ntmp) then + nodata=nodata+1 + endif + isort(icntpnt)=iout + + else + ndata =ndata+1 + nodata=nodata+1 + iout=ndata + isort(icntpnt)=iout + endif + + if(ndata > maxobs) then + write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype + ndata = maxobs + end if + +! Set usage variable + usage = zero + + if(icuse(ikx) < 0)usage=r100 + if(ncnumgrp(ikx) > 0 )then ! cross validation on + if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) + end if + + call deter_zsfc_model(dlat,dlon,zsges) + +! Get information from surface file necessary for conventional data here + call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) + + + cdata(1) = error ! wind obs error (m/s) + cdata(2) = dlon ! grid relative longitude + cdata(3) = dlat ! grid relative latitude + cdata(4) = height ! obs absolute height (m) + cdata(5) = rwnd ! wind obs (m/s) + cdata(6) = azm*deg2rad ! azimuth angle (radians) + cdata(7) = t4dv ! obs time (hour) + cdata(8) = ikx ! type + cdata(9) = tiltangle ! tilt angle (radians) + cdata(10)= staheight ! station elevation (m) + cdata(11)= rstation_id ! station id + cdata(12)= usage ! usage parameter + cdata(13)= idomsfc ! dominate surface type + cdata(14)= skint ! skin temperature + cdata(15)= ff10 ! 10 meter wind factor + cdata(16)= sfcr ! surface roughness + cdata(17)=dlon_earth_deg ! earth relative longitude (degrees) + cdata(18)=dlat_earth_deg ! earth relative latitude (degrees) + cdata(19)=dist ! range from radar in km (used to estimate beam spread) + cdata(20)=zsges ! model elevation at radar site + cdata(21)=thiserr + cdata(22)=hdr(1)+three+one ! tail Doppler radar + do j=1,maxdat + cdata_all(j,iout)=cdata(j) + end do + if(foreswp)nfore=nfore+1 + if(aftswp)naft=naft+1 + jjj=jjj+1 + else + notgood = notgood + 1 + end if ! if(good) + + end do + + endif ! if(ii .gt. 0) + +! End of bufr read loop + end do loop4 + +! Normal exit + else + write(6,*)'READ_RADAR: problem reading tail Doppler radar bufr file tldplrbufr' + end if + call closbf(lnbufr) + + + end if + +1200 continue + close(lnbufr) + + if (.not. use_all) then + deallocate(zl_thin) + call del3grids + endif + + write(6,*)'READ_RADAR: # records(beams) read in nmrecs=', nmrecs + write(6,*)'READ_RADAR: # records out of time window =', ntimeout + write(6,*)'READ_RADAR: # records with bad tilt=',ibadtilt + write(6,*)'READ_RADAR: # records with bad station height =',ibadstaheight + write(6,*)'READ_RADAR: # data read in nread=', nread + write(6,*)'READ_RADAR: # data with missing value nmissing=', nmissing + write(6,*)'READ_RADAR: # data likely to be below sealevel nsubzero=', nsubzero + write(6,*)'READ_RADAR: # data removed by thinning along the beam ntdrvr_thin1=', ntdrvr_thin1 + write(6,*)'READ_RADAR: # data retained after thinning along the beam ntdrvr_in=', ntdrvr_in + write(6,*)'READ_RADAR: # out of domain =', noutside + write(6,*)'READ_RADAR: # out of range =', nirrr + write(6,*)'READ_RADAR: # bad azimuths =',ibadazm + write(6,*)'READ_RADAR: # bad winds (<2m/s or >71m/s) =',ibadwnd + write(6,*)'READ_RADAR: # bad ranges =',ibadrange + write(6,*)'READ_RADAR: # bad distance from radar =',ibaddist + write(6,*)'READ_RADAR: # bad obs height =',ibadheight + write(6,*)'READ_RADAR: # bad data =',notgood0 + write(6,*)'READ_RADAR: # data retained after QC ntdrvr_kept=', ntdrvr_kept + write(6,*)'READ_RADAR: # data removed by thinning mesh ntdrvr_thin2=', ntdrvr_thin2 + if(l_foreaft_thin)then + write(6,*)'READ_RADAR: nforeswp,naftswp,nswp=',nforeswp,naftswp,nswp + write(6,*)'READ_RADAR: ntdrvr_thin2_foreswp,ntdrvr_thin2_aftswp=',ntdrvr_thin2_foreswp,ntdrvr_thin2_aftswp + write(6,*)'READ_RADAR: data retained for further processing nfore,naft=',nfore,naft + end if + write(6,*)'READ_RADAR: data retained for further processing =', jjj + write(6,*)'READ_RADAR: timemin,max =',timemin,timemax + write(6,*)'READ_RADAR: elevmin,max =',elevmin,elevmax + write(6,*)'READ_RADAR: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax + write(6,*)'READ_RADAR: iaaamin,max,8*max_rrr =',iaaamin,iaaamax,8*max_rrr + write(6,*)'READ_RADAR: iimax =',iimax + +! Write observation to scratch file + call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) + deallocate(cdata_all) + + + return + +300 write(6,*) 'read_radar open TDR SO file list failed ' + call stop2(555) +200 write(6,*) 'read_radar read TDR SO data failed ' + call stop2(555) +end subroutine read_radar + +subroutine getvrlocalinfo(thisrange,thisazimuth,this_stahgt,aactual,a43,selev0,celev0, & + rlon0,clat0,slat0,r8,r89_5,nsubzero,ii,z,elev,elat8,elon8, & + glob_azimuth8) +!$$$ subprogram documentation block +! . . . . +! subprogram: getvrlocalinfo following subroutine radar_bufr_read_all +! prgmmr: tong org: np23 date: 2013-03-28 +! +! abstract: This routine calcuate radial wind elevation, elevation angle, +! earth lat lon and and azimuth angle at observation location +! +! program history log: +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: r_kind,r_single,i_kind + use constants, only: one,half,two,deg2rad,rad2deg,zero_single,rearth + use read_l2bufr_mod, only: invtllv + + implicit none + + real(r_single) ,intent(in ) :: thisrange,thisazimuth,a43,aactual,selev0,celev0 + real(r_kind) ,intent(in ) :: this_stahgt,rlon0,clat0,slat0,r8,r89_5 + integer(i_kind),intent(inout) :: nsubzero + integer(i_kind),intent(inout) :: ii + real(r_single) ,intent(out ) :: elev,z,elat8,elon8,glob_azimuth8 + +! local variables + real(r_single) b,c,epsh,h,ha,celev,selev,gamma + real(r_single) rad_per_meter + real(r_kind) thisazimuthr,rlonloc,rlatloc,rlonglob,rlatglob,thislat,thislon + real(r_kind) clat1,caz0,saz0,cdlon,sdlon,caz1,saz1 + + rad_per_meter= one/rearth + +! use 4/3rds rule to get elevation of radar beam +! (if local temperature available, then vertical position can be +! estimated with greater accuracy) + b=thisrange*(thisrange+two*aactual*selev0) + c=sqrt(aactual*aactual+b) + ha=b/(aactual+c) + epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) + h=ha-epsh + z=this_stahgt+h + if(z < zero_single)then ! don't use observation if it is likely to be below sealevel + nsubzero=nsubzero+1 + ii=ii-1 + else + +! Get elevation angle at obs location + celev=celev0 + selev=selev0 + if(thisrange>=one) then + celev=a43*celev0/(a43+h) + selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) + end if + elev=rad2deg*atan2(selev,celev) + gamma=half*thisrange*(celev0+celev) + +! Get earth lat lon at obs location + thisazimuthr=thisazimuth*deg2rad + rlonloc=rad_per_meter*gamma*cos(thisazimuthr) + rlatloc=rad_per_meter*gamma*sin(thisazimuthr) + call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) + thislat=rlatglob*rad2deg + thislon=rlonglob*rad2deg +! Keep away from poles + if(abs(thislat)>r89_5)then + ii=ii-1 + else + elat8=thislat + elon8=thislon +! Get corrected azimuth + clat1=cos(rlatglob) + caz0=cos(thisazimuthr) + saz0=sin(thisazimuthr) + cdlon=cos(rlonglob-rlon0) + sdlon=sin(rlonglob-rlon0) + caz1=clat0*caz0/clat1 + saz1=saz0*cdlon-caz0*sdlon*slat0 + glob_azimuth8=atan2(saz1,caz1)*rad2deg + end if + end if + + return +end subroutine getvrlocalinfo + +subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_radar_l2rw_novadqc read radar L2 radial winds no VAD QC +! prgmmr: yang org: np23 date: 1998-05-15 +! +! abstract: This routine reads radar radial wind files. +! +! When running the gsi in regional mode, the code only +! retains those observations that fall within the regional +! +! program history log: +! 2015-10-19 lippi - Modified from read_radar to only process level 2 radial +! wind obs. and skip vad wind checks. +! +! input argument list: +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! +! output argument list: +! ndata - number of doppler lidar wind profiles retained for further +! processing +! nodata - number of doppler lidar wind observations retained for further +! processing +! sis - satellite/instrument/sensor indicator +! nobs - array of observations on each subdomain for each processor! + + + use kinds, only: r_kind,r_single,r_double,i_kind,i_byte + use constants, only: zero,half,one,two,deg2rad,rearth,rad2deg,r1000,r100,r400 + use qcmod, only: erradar_inflate + use oneobmod, only: oneobtest,learthrel_rw + use gsi_4dvar, only: l4dvar,l4densvar,winlen,time_4dvar + use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy + use convinfo, only: nconvtype,ncmiter,ncgroup,ncnumgrp,icuse,ioctype + use deter_sfc_mod, only: deter_sfc2 + use mpimod, only: npe + + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype!,infile + character(len=20),intent(in ) :: sis +! real(r_kind) ,intent(in ) :: twind + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: ndata,nodata!,nread + integer(i_kind),dimension(npe) ,intent(inout) :: nobs + + +! Declare local parameters + integer(i_kind),parameter:: maxlevs=1500 + integer(i_kind),parameter:: maxdat=22 + real(r_kind),parameter:: r4_r_kind = 4.0_r_kind + + + real(r_kind),parameter:: r6 = 6.0_r_kind + real(r_kind),parameter:: r8 = 8.0_r_kind + real(r_kind),parameter:: r90 = 90.0_r_kind + real(r_kind),parameter:: r200 = 200.0_r_kind + real(r_kind),parameter:: r150 = 150.0_r_kind + real(r_kind),parameter:: r360 = 360.0_r_kind + real(r_kind),parameter:: r50000 = 50000.0_r_kind + real(r_kind),parameter:: r89_5 = 89.5_r_kind + real(r_kind),parameter:: four_thirds = 4.0_r_kind / 3.0_r_kind + +! Declare local variables + logical good,outside,good0 + + character(30) outmessage + + integer(i_kind) lnbufr,i,k,maxobs + integer(i_kind) nmrecs,ibadazm,ibadwnd,ibaddist,ibadheight,kthin + integer(i_kind) ibadstaheight,ibaderror,notgood,iheightbelowsta,ibadfit + integer(i_kind) notgood0 + integer(i_kind) iret,kx0 + integer(i_kind) nreal,nchanl,ilat,ilon,ikx + integer(i_kind) idomsfc + real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff + real(r_kind) eradkm,dlat_earth,dlon_earth + real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat + real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist + real(r_kind) rwnd,azm,height,error + real(r_kind) azm_earth,cosazm_earth,sinazm_earth,cosazm,sinazm + real(r_kind):: zsges + + real(r_kind),dimension(maxdat):: cdata + real(r_kind),allocatable,dimension(:,:):: cdata_all + + real(r_double) rstation_id + character(8) cstaid + character(4) this_staid + equivalence (this_staid,cstaid) + equivalence (cstaid,rstation_id) + + + integer(i_kind) loop + real(r_kind) timemax,timemin,errmax,errmin + real(r_kind) dlatmax,dlonmax,dlatmin,dlonmin + real(r_kind) xscale,xscalei + integer(i_kind) max_rrr,nboxmax + integer(i_kind) irrr,iaaa,iaaamax,iaaamin + real(r_kind) this_stalat,this_stalon,this_stahgt,thistime,thislat,thislon + real(r_kind) thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt + integer(i_kind) nsuper2_in,nsuper2_kept + real(r_kind) errzmax + + integer(i_kind),allocatable,dimension(:):: isort + +! following variables are for fore/aft separation + integer(i_kind) irec + + data lnbufr/10/ + +!*********************************************************************************** + + eradkm=rearth*0.001_r_kind + maxobs=2e6 + nreal=maxdat + nchanl=0 + ilon=2 + ilat=3 + iaaamax=-huge(iaaamax) + iaaamin=huge(iaaamin) + dlatmax=-huge(dlatmax) + dlonmax=-huge(dlonmax) + dlatmin=huge(dlatmin) + dlonmin=huge(dlonmin) + + allocate(cdata_all(maxdat,maxobs),isort(maxobs)) + + isort = 0 + cdata_all=zero + +! Initialize variables + xscale=1000._r_kind + xscalei=one/xscale + max_rrr=nint(100000.0_r_kind*xscalei) + nboxmax=1 + + kx0=22500 + + nmrecs=0 + irec=0 + + errzmax=zero + + +! First process any level 2 superobs. +! Initialize variables. + ikx=0 + do i=1,nconvtype + if(trim(ioctype(i)) == trim(obstype))ikx = i + end do + + timemax=-huge(timemax) + timemin=huge(timemin) + errmax=-huge(errmax) + errmin=huge(errmin) + loop=0 + + ibadazm=0 + ibadwnd=0 + ibaddist=0 + ibadheight=0 + ibadstaheight=0 + iheightbelowsta=0 + iheightbelowsta=0 + ibaderror=0 + ibadfit=0 + kthin=0 + notgood=0 + notgood0=0 + nsuper2_in=0 + nsuper2_kept=0 + + if(loop==0) outmessage='level 2 superobs:' + +! Open sequential file containing superobs + open(lnbufr,file='radar_supobs_from_level2',form='unformatted') + rewind lnbufr + +! Loop to read superobs data file + do + read(lnbufr,iostat=iret)this_staid,this_stalat,this_stalon,this_stahgt, & + thistime,thislat,thislon,thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt + if(iret/=0) exit + nsuper2_in=nsuper2_in+1 + + dlat_earth=this_stalat !station lat (degrees) + dlon_earth=this_stalon !station lon (degrees) + if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if (dlon_earthwinlen) cycle + else + timeo=thistime + if(abs(timeo)>half ) cycle + endif + +! Get observation (lon,lat). Compute distance from radar. + dlat_earth=thislat + dlon_earth=thislon + if(dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if(dlon_earthmax_rrr) cycle + end if +! Extract radial wind data + height= thishgt + rwnd = thisvr + azm_earth = corrected_azimuth + + if(regional) then + if(oneobtest .and. learthrel_rw) then ! for non rotated winds!!! + cosazm=cos(azm_earth*deg2rad) + sinazm=sin(azm_earth*deg2rad) + azm=atan2(sinazm,cosazm)*rad2deg + else + cosazm_earth=cos(azm_earth*deg2rad) + sinazm_earth=sin(azm_earth*deg2rad) + call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) + azm=atan2(sinazm,cosazm)*rad2deg + end if + + else + azm=azm_earth + end if + + if(.not. oneobtest) then + iaaa=azm/(r360/(r8*irrr)) + iaaa=mod(iaaa,8*irrr) + if(iaaa<0) iaaa=iaaa+8*irrr + iaaa=iaaa+1 + iaaamax=max(iaaamax,iaaa) + iaaamin=min(iaaamin,iaaa) + end if + + error = erradar_inflate*thiserr + errmax=max(error,errmax) + + if(thiserr>zero) errmin=min(error,errmin) +! Perform limited qc based on azimuth angle, radial wind +! speed, distance from radar site, elevation of radar, +! height of observation, and observation error + good0=.true. + if(abs(azm)>r400) then + ibadazm=ibadazm+1; good0=.false. + end if + if(abs(rwnd)>r200) then + ibadwnd=ibadwnd+1; good0=.false. + end if + if(dist>r400) then + ibaddist=ibaddist+1; good0=.false. + end if + if(staheight<-r1000.or.staheight>r50000) then + ibadstaheight=ibadstaheight+1; good0=.false. + end if + if(height<-r1000.or.height>r50000) then + ibadheight=ibadheight+1; good0=.false. + end if + if(heightr6 .or. thiserr<=zero) then + ibaderror=ibaderror+1; good0=.false. + end if + good=.true. + if(.not.good0) then + notgood0=notgood0+1 + cycle + else + + end if + +! If data is good, load into output array + if(good) then + nsuper2_kept=nsuper2_kept+1 + ndata =min(ndata+1,maxobs) + nodata =min(nodata+1,maxobs) !number of obs not used (no meaninghere) + usage = zero + if(icuse(ikx) < 0)usage=r100 + if(ncnumgrp(ikx) > 0 )then ! cross validation on + if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) + end if + + call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) + + cdata(1) = error ! wind obs error (m/s) + cdata(2) = dlon ! grid relative longitude + cdata(3) = dlat ! grid relative latitude + cdata(4) = height ! obs absolute height (m) + cdata(5) = rwnd ! wind obs (m/s) + cdata(6) = azm*deg2rad ! azimuth angle (radians) + cdata(7) = t4dv ! obs time (hour) + cdata(8) = ikx ! type + cdata(9) = tiltangle ! tilt angle (radians) + cdata(10)= staheight ! station elevation (m) + cdata(11)= rstation_id ! station id + cdata(12)= usage ! usage parameter + cdata(13)= idomsfc ! dominate surface type + cdata(14)= skint ! skin temperature + cdata(15)= ff10 ! 10 meter wind factor + cdata(16)= sfcr ! surface roughness + cdata(17)=dlon_earth*rad2deg ! earth relative longitude (degrees) + cdata(18)=dlat_earth*rad2deg ! earth relative latitude (degrees) + cdata(19)=dist ! range from radar in km (used to estimatebeam spread) + cdata(20)=zsges ! model elevation at radar site + cdata(21)=thiserr + cdata(22)=two + + do i=1,maxdat + cdata_all(i,ndata)=cdata(i) + end do + + else + notgood = notgood + 1 + end if + + end do + + close(lnbufr) ! A simple unformatted fortran file should not be mixed with bufr I/O + write(6,*)'READ_RADAR_L2RW_NOVADQC: ',trim(outmessage),' reached eof on 2 superob radar file' + write(6,*)'READ_RADAR_L2RW_NOVADQC: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept + write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad azimuths=',ibadazm + write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad winds =',ibadwnd + write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad dists =',ibaddist + write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad stahgts =',ibadstaheight + write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad obshgts =',ibadheight + write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad errors =',ibaderror + write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad fit =',ibadfit + write(6,*)'READ_RADAR_L2RW_NOVADQC: # num thinned =',kthin + write(6,*)'READ_RADAR_L2RW_NOVADQC: # notgood0 =',notgood0 + write(6,*)'READ_RADAR_L2RW_NOVADQC: # notgood =',notgood + write(6,*)'READ_RADAR_L2RW_NOVADQC: # hgt belowsta=',iheightbelowsta + write(6,*)'READ_RADAR_L2RW_NOVADQC: timemin,max =',timemin,timemax + write(6,*)'READ_RADAR_L2RW_NOVADQC: errmin,max =',errmin,errmax + write(6,*)'READ_RADAR_L2RW_NOVADQC: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax + write(6,*)'READ_RADAR_L2RW_NOVADQC: iaaamin,max,8*max_rrr=',iaaamin,iaaamax,8*max_rrr + +! Write observation to scratch file + call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) + deallocate(cdata_all) + + return + +end subroutine read_radar_l2rw_novadqc + +!!!!!!!!!!!!!!! Xu added for l2rw thinning !!!!!!!!!!!!!!! +subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) + use kinds, only: r_kind,r_single,r_double,i_kind,i_byte + use constants, only: zero,half,one,two,deg2rad,rearth,rad2deg,r1000,r100,r400 + use qcmod, only: erradar_inflate + use oneobmod, only: oneobtest,learthrel_rw + use gsi_4dvar, only: l4dvar,l4densvar,winlen,time_4dvar + use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,nsig !Xu + use obsmod, only: doradaroneob,oneoblat,oneoblon,oneobheight,oneobradid,time_offset !Xu + use mpeu_util, only: gettablesize,gettable !Xu + use convinfo, only: nconvtype,ncmiter,ncgroup,ncnumgrp,icuse,ioctype + use deter_sfc_mod, only: deter_sfc2 + use mpimod, only: npe + use read_l2bufr_mod !,only:radar_sites,elev_angle_max,del_time,range_max !Xu + use constants, only: eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening,grav_equator !Xu + use obsmod,only: radar_no_thinning,iadate !Xu + use convthin, only: make3grids,map3grids !Xu + + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype!,infile + character(len=20),intent(in ) :: sis +! real(r_kind) ,intent(in ) :: twind + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: ndata,nodata!,nread + integer(i_kind),dimension(npe) ,intent(inout) :: nobs + real(r_kind),dimension(nlat,nlon,nsig),intent(in):: hgtl_full !Xu + +! Declare local parameters + integer(i_kind),parameter:: maxlevs=1500 + integer(i_kind),parameter:: maxdat=22 + real(r_kind),parameter:: r4_r_kind = 4.0_r_kind + + + real(r_kind),parameter:: r6 = 6.0_r_kind + real(r_kind),parameter:: r8 = 8.0_r_kind + real(r_kind),parameter:: r90 = 90.0_r_kind + real(r_kind),parameter:: r200 = 200.0_r_kind + real(r_kind),parameter:: r150 = 150.0_r_kind + real(r_kind),parameter:: r360 = 360.0_r_kind + real(r_kind),parameter:: r50000 = 50000.0_r_kind + real(r_kind),parameter:: r89_5 = 89.5_r_kind + real(r_kind),parameter:: four_thirds = 4.0_r_kind / 3.0_r_kind + integer(i_kind),parameter:: n_gates_max=4000 !Xu + real(r_double),parameter:: r1e5_double = 1.0e5_r_double !Xu + real(r_kind),parameter:: rinv60 = 1.0_r_kind/60.0_r_kind !Xu + logical good,outside,good0 + + character(30) outmessage + integer(i_kind) lnbufr,i,k,maxobs + integer(i_kind) nmrecs,ibadazm,ibadwnd,ibaddist,ibadheight,kthin + integer(i_kind) ibadstaheight,ibaderror,notgood,iheightbelowsta,ibadfit + integer(i_kind) notgood0 + integer(i_kind) iret,kx0 + integer(i_kind) nreal,nchanl,ilat,ilon,ikx + integer(i_kind) idomsfc + real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff + real(r_kind) eradkm,dlat_earth,dlon_earth + real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat + real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist + real(r_kind) rwnd,azm,height,error + real(r_kind) azm_earth,cosazm_earth,sinazm_earth,cosazm,sinazm + real(r_kind):: zsges + + real(r_kind),dimension(maxdat):: cdata + real(r_kind),allocatable,dimension(:,:):: cdata_all + + real(r_double) rstation_id + character(8) cstaid + character(4) this_staid + equivalence (this_staid,cstaid) + equivalence (cstaid,rstation_id) + + + integer(i_kind) loop + real(r_kind) timemax,timemin,errmax,errmin + real(r_kind) dlatmax,dlonmax,dlatmin,dlonmin + real(r_kind) xscale,xscalei + integer(i_kind) max_rrr,nboxmax + integer(i_kind) irrr,iaaa,iaaamax,iaaamin + real(r_kind) this_stalat,this_stalon,this_stahgt,thistime,thislat,thislon + real(r_kind) thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt + integer(i_kind) nsuper2_in,nsuper2_kept + real(r_kind) errzmax,ddx,ddy,ddz !Xu + character(len=*),parameter:: tbname='SUPEROB_RADAR::' !Xu + integer(i_kind) ntot,radar_true,radar_count,inbufr,lundx,idups,idate,n_gates,levs !Xu + integer(i_kind) idate5(5) !Xu + integer(i_kind) nminref,nminthis,nrange_max !Xu + integer(i_kind) nobs_in,nradials_in,nradials_fail_angmax,nradials_fail_time,nradials_fail_elb,ireadmg,ireadsb +!Xu + integer(i_kind) nobs_badvr,nobs_badsr,j !Xu + real(r_kind) rlon0,clat0,slat0,this_stalatr,thisrange,thisazimuth,thistilt,thisvr2 !Xu + character(20) infile !Xu + real(r_kind) rad_per_meter,erad,ddiffmin,distfact !Xu + character(len=256),allocatable,dimension(:):: rtable !Xu + character(4),allocatable,dimension(:):: rsite !Xu + integer,allocatable,dimension(:):: ruse!Xu + character(8) chdr,chdr2,subset !Xu + real(r_double) rdisttest(n_gates_max),hdr(10),hdr2(12),rwnd0(3,n_gates_max) !Xu + character(4) stn_id !Xu + equivalence (chdr2,hdr2(1)) !Xu + real(r_kind) stn_lat,stn_lon,stn_hgt,stn_az,stn_el,t,range,vrmax,vrmin,aactual,a43,b,c,selev0,celev0,thistiltr,epsh,h,ha,rlonloc,rlatloc +!Xu + real(r_kind) celev,selev,gamma,thisazimuthr,rlonglob,rlatglob,clat1,caz0,saz0,cdlon,sdlon,caz1,saz1 !Xu + real(r_kind):: relm,srlm,crlm,sph,cph,cc,anum,denom !Xu + real(r_kind) :: rmesh,xmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11 !Xu + real(r_kind), allocatable, dimension(:) :: zl_thin !Xu + integer(i_kind) :: ithin,zflag,nlevz,icntpnt,klon1,klat1,kk,klatp1,klonp1 !Xu + real(r_kind),dimension(nsig):: hges,zges !Xu + real(r_kind) sin2,termg,termr,termrg,zobs !Xu + integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2 !Xu + real(r_kind) crit1,timedif !Xu + integer(i_kind) maxout,maxdata !Xu + logical :: luse !Xu + integer(i_kind) iyref,imref,idref,ihref,nout !Xu + + integer(i_kind),allocatable,dimension(:):: isort + +! following variables are for fore/aft separation + integer(i_kind) irec + + data lnbufr/10/ + if (radar_sites) then + open(666,file=trim('gsiparm.anl'),form='formatted') + call gettablesize(tbname,666,ntot,radar_count) + allocate(rtable(radar_count),rsite(radar_count),ruse(radar_count)) + call gettable(tbname,666,ntot,radar_count,rtable) + do i=1,radar_count + read(rtable(i),*) rsite(i),ruse(i) + write(*,'(A10,X,A4,X,I)'),"Radar Sites: ",rsite(i),ruse(i) + end do + end if + rad_per_meter= one/rearth + erad = rearth + + eradkm=rearth*0.001_r_kind + maxobs=2e7 + nreal=maxdat + nchanl=0 + ilon=2 + ilat=3 + ikx=0 + do j=1,nconvtype + if(trim(ioctype(j)) == trim(obstype))ikx = j + end do + iaaamax=-huge(iaaamax) + iaaamin=huge(iaaamin) + dlatmax=-huge(dlatmax) + dlonmax=-huge(dlonmax) + dlatmin=huge(dlatmin) + dlonmin=huge(dlonmin) + allocate(cdata_all(maxdat,maxobs),isort(maxobs)) + + isort = 0 + cdata_all=zero + xscale=1000._r_kind + xscalei=one/xscale + max_rrr=nint(1000000.0_r_kind*xscalei) !Xu + nboxmax=1 + kx0=22500 + nmrecs=0 + irec=0 + errzmax=zero + + timemax=-huge(timemax) + timemin=huge(timemin) + errmax=-huge(errmax) + errmin=huge(errmin) + loop=0 + + ibadazm=0 + ibadwnd=0 + ibaddist=0 + ibadheight=0 + ibadstaheight=0 + iheightbelowsta=0 + iheightbelowsta=0 + ibaderror=0 + ibadfit=0 + kthin=0 + notgood=0 + notgood0=0 + nsuper2_in=0 + nsuper2_kept=0 + ntdrvr_thin2=0 + maxout=0 + maxdata=0 + isort=0 + icntpnt=0 + nout=0 + if(loop==0) outmessage='level 2 superobs:' + rmesh=radar_rmesh + zmesh=radar_zmesh + nlevz=16000.0/zmesh + xmesh=rmesh + call make3grids(xmesh,nlevz) + allocate(zl_thin(nlevz)) + zflag=1 + if (zflag == 1) then + do k=1,nlevz + zl_thin(k)=k*zmesh + enddo + endif + inbufr=10 + open(inbufr,file="l2rwbufr",form='unformatted') + rewind inbufr + lundx=inbufr + call openbf(inbufr,'IN',lundx) + call datelen(10) + iyref=iadate(1) + imref=iadate(2) + idref=iadate(3) + ihref=iadate(4) + idate5(1)=iyref + idate5(2)=imref + idate5(3)=idref + idate5(4)=ihref + idate5(5)=0 ! minutes + call w3fs21(idate5,nminref) + idups=0 + nobs_in=0 + nradials_in=0 + nradials_fail_angmax=0 + nradials_fail_time=0 + nradials_fail_elb=0 + ddiffmin=huge(ddiffmin) + do while(ireadmg(inbufr,subset,idate)>=0) + do while (ireadsb(inbufr)==0) + call ufbint(inbufr,rdisttest,1,n_gates_max,n_gates,'DIST125M') + if(n_gates>1) then + do i=1,n_gates-1 + if(nint(abs(rdisttest(i+1)-rdisttest(i)))==0) then + idups=idups+1 + else + ddiffmin=min(abs(rdisttest(i+1)-rdisttest(i)),ddiffmin) + end if + end do + end if + distfact=zero + if(nint(ddiffmin)==1) distfact=250.0 + if(nint(ddiffmin)==2) distfact=125.0 + if(distfact==zero) then + write(6,*)'RADAR_BUFR_READ_ALL: problem with level 2 bufr file, gate distance scale factor undetermined, going with 125' + distfact=125.0 + end if + call ufbint(inbufr,hdr2,12,1,levs,'SSTN CLAT CLON HSMSL HSALG ANEL YEAR MNTH DAYS HOUR MINU SECO') + if(hdr2(6)>elev_angle_max) then + nradials_fail_angmax=nradials_fail_angmax+1 + cycle + end if + idate5(1)=nint(hdr2(7)) ; idate5(2)=nint(hdr2(8)) ; idate5(3)=nint(hdr2(9)) + idate5(4)=nint(hdr2(10)) ; idate5(5)=nint(hdr2(11)) + call w3fs21(idate5,nminthis) + t=(real(nminthis-nminref,r_kind)+real(nint(hdr2(12)),r_kind)*rinv60)*rinv60 + timemax=max(t,timemax) + timemin=min(t,timemin) + if(abs(t)>del_time) then + nradials_fail_time=nradials_fail_time+1 + cycle + end if + nobs_in=nobs_in+n_gates + stn_id=chdr2 + radar_true=0 !Xu + if (radar_sites) then !Xu + do i=1,radar_count !Xu + if (trim(stn_id) .eq. trim(rsite(i)) .and. ruse(i) .eq. 1 ) radar_true=1 !Xu + end do !Xu + if (radar_true == 0) cycle !Xu + end if !Xu + stn_lat=hdr2(2) + stn_lon=hdr2(3) + stn_hgt=hdr2(4)+hdr2(5) + call ufbint(inbufr,hdr,10,1,levs, & + 'SSTN YEAR MNTH DAYS HOUR MINU SECO ANAZ ANEL QCRW') + nradials_in=nradials_in+1 + stn_az=r90-hdr(8) + stn_el=hdr(9) + call ufbint(inbufr,rwnd0,3,n_gates_max,n_gates,'DIST125M DMVR DVSW') + do i=1,n_gates + range=distfact*rwnd0(1,i) + if(range>range_max) then + nrange_max=nrange_max+1 + cycle + end if + if(rwnd0(2,i)>r1e5_double) then + nobs_badvr=nobs_badvr+1 + cycle + end if + if(rwnd0(3,i)>r1e5_double) then + nobs_badsr=nobs_badsr+1 + cycle + end if + this_stalat=stn_lat + if(abs(this_stalat)>r89_5) cycle + this_stalon=stn_lon + rlon0=deg2rad*this_stalon + this_stalatr=this_stalat*deg2rad + clat0=cos(this_stalatr) ; slat0=sin(this_stalatr) + this_staid=stn_id + this_stahgt=stn_hgt + thisrange= range + thisazimuth=stn_az + thistilt=stn_el + thisvr=rwnd0(2,i) + vrmax=max(vrmax,thisvr) + vrmin=min(vrmin,thisvr) + thisvr2=rwnd0(2,i)**2 +! thiserr=sqrt(abs(thisvr2-thisvr**2)) + thiserr=5.0_r_kind ! Xu force all obs error to 2. + errmax=max(errmax,thiserr) + errmin=min(errmin,thiserr) + thistime=t + aactual=erad+this_stahgt + a43=four_thirds*aactual + thistiltr=thistilt*deg2rad + selev0=sin(thistiltr) + celev0=cos(thistiltr) + b=thisrange*(thisrange+two*aactual*selev0) + c=sqrt(aactual*aactual+b) + ha=b/(aactual+c) + epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) + h=ha-epsh + thishgt=this_stahgt+h + celev=celev0 + selev=selev0 + if(thisrange>=one) then + celev=a43*celev0/(a43+h) + selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) + end if + corrected_tilt=atan2(selev,celev)*rad2deg + gamma=half*thisrange*(celev0+celev) +! Get earth lat lon of superob + thisazimuthr=thisazimuth*deg2rad + rlonloc=rad_per_meter*gamma*cos(thisazimuthr) + rlatloc=rad_per_meter*gamma*sin(thisazimuthr) + RELM=rlonloc + SRLM=SIN(RELM) + CRLM=COS(RELM) + SPH=SIN(rlatloc) + CPH=COS(rlatloc) + CC=CPH*CRLM + ANUM=CPH*SRLM + DENOM=clat0*CC-slat0*SPH + rlonglob=rlon0+ATAN2(ANUM,DENOM) + rlatglob=ASIN(clat0*SPH+slat0*CC) + thislat=rlatglob*rad2deg + thislon=rlonglob*rad2deg + if(abs(thislat)>r89_5) cycle + clat1=cos(rlatglob) + caz0=cos(thisazimuthr) + saz0=sin(thisazimuthr) + cdlon=cos(rlonglob-rlon0) + sdlon=sin(rlonglob-rlon0) + caz1=clat0*caz0/clat1 + saz1=saz0*cdlon-caz0*sdlon*slat0 + corrected_azimuth=atan2(saz1,caz1)*rad2deg + + if (doradaroneob .and. (oneobradid /= this_staid)) cycle + if(iret/=0) exit + nsuper2_in=nsuper2_in+1 + dlat_earth=this_stalat !station lat (degrees) + dlon_earth=this_stalon !station lon (degrees) + if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if (dlon_earthwinlen) cycle + else + timeo=thistime + if(abs(timeo)>half ) cycle + endif +! Get observation (lon,lat). Compute distance from radar. + dlat_earth=thislat + dlon_earth=thislon + if(dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if(dlon_earthmax_rrr) cycle + end if +! Extract radial wind data + height= thishgt + rwnd = thisvr + azm_earth = corrected_azimuth + if(regional) then + if(oneobtest .and. learthrel_rw) then ! for non rotated winds!!! + cosazm=cos(azm_earth*deg2rad) + sinazm=sin(azm_earth*deg2rad) + azm=atan2(sinazm,cosazm)*rad2deg + else + cosazm_earth=cos(azm_earth*deg2rad) + sinazm_earth=sin(azm_earth*deg2rad) + call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) + azm=atan2(sinazm,cosazm)*rad2deg + end if + else + azm=azm_earth + end if +!#################### Data thinning ################### +! Xu from Yongming + icntpnt=icntpnt+1 + ithin=1 !number of obs to keep per grid box + if(radar_no_thinning) then + ithin=-1 + endif + if(ithin > 0)then + if(zflag == 0)then + klon1= int(dlon); klat1= int(dlat) + dx = dlon-klon1; dy = dlat-klat1 + dx1 = one-dx; dy1 = one-dy + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) + if (klon1==0) klon1=nlon + klatp1=min(nlat,klat1+1); klonp1=klon1+1 + if (klonp1==nlon+1) klonp1=1 + do kk=1,nsig + hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + & + w10*hgtl_full(klatp1,klon1 ,kk) + & + w01*hgtl_full(klat1 ,klonp1,kk) + & + w11*hgtl_full(klatp1,klonp1,kk) + end do + sin2 = sin(thislat)*sin(thislat) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do kk=1,nsig + zges(kk) = (termr*hges(kk)) / (termrg-hges(kk)) + zl_thin(kk)=zges(kk) + end do + endif + zobs = height + ntmp=ndata ! counting moved to map3gridS + if (l4dvar) then + timedif = zero + else + timedif=abs(t4dvo-toff) !don't know about this + endif + crit1 = timedif/r6+half + call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,& + zobs,crit1,ndata,iout,icntpnt,iiout,luse, .false., .false.) + maxout=max(maxout,iout) + maxdata=max(maxdata,ndata) + if (.not. luse) then + ntdrvr_thin2=ntdrvr_thin2+1 + cycle + endif + if(iiout > 0) isort(iiout)=0 + if (ndata > ntmp) then + nodata=nodata+1 + endif + isort(icntpnt)=iout + else + ndata =ndata+1 + nodata=nodata+1 + iout=ndata + isort(icntpnt)=iout + endif +!#################### Data thinning ################### + if(.not. oneobtest) then + iaaa=azm/(r360/(r8*irrr)) + iaaa=mod(iaaa,8*irrr) + if(iaaa<0) iaaa=iaaa+8*irrr + iaaa=iaaa+1 + iaaamax=max(iaaamax,iaaa) + iaaamin=min(iaaamin,iaaa) + end if + error = erradar_inflate*thiserr + errmax=max(error,errmax) + if(thiserr>zero) errmin=min(error,errmin) +! Perform limited qc based on azimuth angle, radial wind +! speed, distance from radar site, elevation of radar, +! height of observation, and observation error + good0=.true. + if(abs(azm)>r400) then + ibadazm=ibadazm+1; good0=.false. + end if + if(abs(rwnd)>r200) then + ibadwnd=ibadwnd+1; good0=.false. + end if + if(dist>r400) then + ibaddist=ibaddist+1; good0=.false. + end if + if(staheight<-r1000.or.staheight>r50000) then + ibadstaheight=ibadstaheight+1; good0=.false. + end if + if(height<-r1000.or.height>r50000) then + ibadheight=ibadheight+1; good0=.false. + end if + if(heightr6 .or. thiserr<=zero) then + ibaderror=ibaderror+1; good0=.false. + end if + good=.true. + if(.not.good0) then + notgood0=notgood0+1 + cycle + end if + +! If data is good, load into output array + if(good) then + nsuper2_kept=nsuper2_kept+1 + cdata(1) = error ! wind obs error (m/s) + cdata(2) = dlon ! grid relative longitude + cdata(3) = dlat ! grid relative latitude + cdata(4) = height ! obs absolute height (m) + cdata(5) = rwnd ! wind obs (m/s) + cdata(6) = azm*deg2rad ! azimuth angle (radians) + cdata(7) = t4dvo+time_offset ! obs time (hour) + cdata(8) = ikx ! type + cdata(9) = tiltangle ! tilt angle (radians) + cdata(10)= staheight ! station elevation (m) + cdata(11)= rstation_id ! station id + cdata(12)= icuse(ikx) ! usage parameter + cdata(13)= idomsfc ! dominate surface type + cdata(14)= skint ! skin temperature + cdata(15)= ff10 ! 10 meter wind factor + cdata(16)= sfcr ! surface roughness + cdata(17)=dlon_earth*rad2deg ! earth relative longitude (degrees) + cdata(18)=dlat_earth*rad2deg ! earth relative latitude (degrees) + cdata(19)=dist ! range from radar in km (used to estimatebeam spread) + cdata(20)=zsges ! model elevation at radar site + cdata(21)=thiserr + cdata(22)=two + do j=1,maxdat + cdata_all(j,iout)=cdata(j) + end do + else + notgood = notgood + 1 + end if + end do + end do + end do + close(lnbufr) ! A simple unformatted fortran file should not be mixed with bufr I/O + write(6,*)'READ_RADAR_L2RW_NOVADQC: ',trim(outmessage),' reached eof on 2 superob radar file' + write(6,*)'READ_RADAR_L2RW_NOVADQC: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept + write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad winds =',ibadwnd,nobs_badvr,nobs_badsr + write(6,*)'READ_RADAR_L2RW_NOVADQC: # num thinned =',kthin,ntdrvr_thin2 + write(6,*)'READ_RADAR_L2RW_NOVADQC: timemin,max =',timemin,timemax + write(6,*)'READ_RADAR_L2RW_NOVADQC: errmin,max =',errmin,errmax + write(6,*)'READ_RADAR_L2RW_NOVADQC: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax + +! Write observation to scratch file + call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon + write(6,*) shape(cdata_all) + write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) + deallocate(cdata_all) + if (radar_sites) deallocate(rtable,rsite,ruse) !Xu + deallocate(zl_thin) + deallocate(isort) + return + +end subroutine read_radar_l2rw +!!!!!!!!!!!!!!! Xu added for l2rw thinning !!!!!!!!!!!!!!! + diff --git a/src/gsi/read_radar_wind_ascii.f90 b/src/gsi/read_radar_wind_ascii.f90 new file mode 100644 index 000000000..02200a9d7 --- /dev/null +++ b/src/gsi/read_radar_wind_ascii.f90 @@ -0,0 +1,653 @@ +subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,nobs) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_dbz read level2 raw QC'd radial velocity data +! +! prgmmr: carley org: np22 date: 2011-05-24 +! +! abstract: Reads and processes level 2 horizontal radial velocity (m/s) by +! radar site. Data are on radar scan surafces. Processing includes +! finding the lat/lon and height of each observation. . +! +! program history log: +! 2011-08-12 carley - fix ob error to 2 m/s +! 2011-08-23 carley - use deter_sfc_mod +! 2011-12-08 carley - add wind rotation (earth to grid) +! +! input argument list: +! infile - file from which to read data +! lunout - unit to which to write data for further processing +! obstype - observation type to process +! +! output argument list: +! nread - number of radar reflectivity observations read +! ndata - number of radar reflectivity observations retained for further processing +! nodata - number of radar reflectivity observations retained for further processing +! sis - satellite/instrument/sensor indicator +! +! Variable Definitions: +! +! a43 - real - (4/3)*(earth radius) +! a,b,c,ha,epsh,h,aactual - real - used in computing radar observation height +! cdata_all - real - dim(maxdat,maxobs) - array holding all data for assimilation +! celev0,selev0 - real- cos and sin of elevation angle (raw) +! celev,selev - real - corrected cos and sin of elevation angle +! clat0 - real - cos of radar station latitude +! cstaid - char - radar station ide +! dbzerr - real - observation error (obtained from convinfo - dBZ) +! dlat - real - grid relative latitude of observation (grid units) +! dlon - real - grid relative longitude of observation (grid units) +! gamma - real - used in finding observation latlon +! lunrad - int - unit number for reading radar data from file +! maxobs - int - max number of obs converted to no precip observations +! num_m2nopcp -int - number of missing obs +! num_missing - int - number of missing observations +! num_noise - int - number of rejected noise observations +! num_nopcp - int - number of noise obs converted to no precip observations +! numbadtime - int - number of elevations outside time window +! num_badtilt - int - number of elevations outside specified interval +! num_badrange - int - number of obs outside specified range distance +! obdate - int - dim(5) - yyyy,mm,dd,hh,minmin of observation +! outside - logical - if observations are outside the domain -> true +! radartwindow - real - time window for radar observations (minutes) +! rlatglob - real - earth relative latitude of observation (radians) +! rlatloc - real - latitude of observation on radar-relative projection +! rlonglob - real - earth relative longitude of observation (radians) +! rlonloc - real - longitude of observation on radar-relative projection +! rlon0 - real - radar station longitude (radians) +! rmins_an - real - analysis time from reference date (minutes) +! rmins_ob - real - observation time from reference date (minutes) +! rstation_id - real - radar station id +! slat0 - real - sin of radar station latitude +! thisazimuthr - real - 90deg minues the actual azimuth and converted to radians +! thiserr - real - observation error +! thislat - real - latitude of observation +! thislon - real - longitude of observation +! thisrange - real - range of observation from radar +! thishgt - real - observation height +! this_stahgt - real - radar station height (meters about sea level) +! this_staid - char - radar station id +! thistilt - real - radar tilt angle (degrees) +! thistiltr - real- radar tilt angle (radians) +! timeb - real - obs time (analyis relative minutes) +! +! +! +! Derived data types +! +! radar - derived data type for containing volume scan information +! nelv- int - number of elevation angles +! radid - char*4 - radar ID (e.g. KAMA) +! vcpnum - int - volume coverage pattern number +! year - int - UTC +! day - int - UTC +! month - int - UTC +! hour - in - UTC +! minute - int - UTC +! second - int - UTC +! radhgt - real - elevation of the radar above sea level in meters (I believe +! this includes the height of the antenna as well) +! radlat - real - latitude location of the radar +! radlon - real - longitude location of the radar +! fstgatdis - real - first gate distance (meters) +! gatewidth - real - gate width (meters) +! elev_angle - real - radar elevation angle (degrees) +! num_beam - int - number of beams +! num_gate - int - number of gates +! nyq_vel - real - nyquist velocity +! azim - real - azimuth angles +! field - real - radar data variable (reflectivity or velocity) +! +! Defined radar types: +! strct_in_vel - radar - contains volume scan information related to +! radial velocity +! strct_in_dbz - radar - contains volume scan information related to +! radar reflectivity +! strct_in_rawvel - radar - contains volume scan information related to +! raw radial velocity +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: r_kind,r_double,i_kind + use constants, only: zero,half,one,two,deg2rad,rearth,rad2deg, & + one_tenth,r1000,r60,r60inv,r100,r400,grav_equator, & + eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening + use gridmod, only: regional,tll2xy,rotate_wind_ll2xy,nsig,nlat,nlon + use obsmod, only: iadate, & + mintiltvr,maxtiltvr,minobrangevr,maxobrangevr, rmesh_vr,zmesh_vr,& + doradaroneob,oneoblat,oneoblon,oneobheight,oneobradid + use obsmod,only: radar_no_thinning + use gsi_4dvar, only: l4dvar,time_4dvar + use convinfo, only: nconvtype,ctwind,icuse,ioctype + use convthin, only: make3grids,map3grids,del3grids,use_all + use read_l2bufr_mod, only: invtllv + use qcmod, only: erradar_inflate + use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model + use mpimod, only: npe + + implicit none + +! Declare passed variables + character(len=*),intent(in ) :: obstype,infile + character(len=*),intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout + integer(i_kind) ,intent(inout) :: nread,ndata,nodata + real(r_kind),dimension(nlat,nlon,nsig),intent(in):: hgtl_full + integer(i_kind),dimension(npe) ,intent(inout) :: nobs + +! Declare local parameters + real(r_kind),parameter :: four_thirds = 4.0_r_kind / 3.0_r_kind + real(r_kind),parameter :: r8 = 8.0_r_kind + real(r_kind),parameter:: r6 = 6.0_r_kind + real(r_kind),parameter:: r360=360.0_r_kind + integer(i_kind),parameter:: maxdat=22 ! Used in generating cdata array + +!--Derived data type declaration + + type :: radar + character(4) :: radid + integer(i_kind) :: vcpnum + integer(i_kind) :: year + integer(i_kind) :: month + integer(i_kind) :: day + integer(i_kind) :: hour + integer(i_kind) :: minute + integer(i_kind) :: second + real(r_kind) :: radlat + real(r_kind) :: radlon + real(r_kind) :: radhgt + real(r_kind) :: fstgatdis + real(r_kind) :: gateWidth + real(r_kind) :: elev_angle + integer(i_kind) :: num_beam + integer(i_kind) :: num_gate + real(r_kind) :: nyq_vel + real(r_kind),allocatable :: azim(:) !has dimension (num_beam) + real(r_kind),allocatable :: field(:,:) !has dimension (num_gate,num_beam) + end type radar + +!--Counters for diagnostics + integer(i_kind) :: num_missing=0,numbadtime=0, & !counts + num_badtilt=0,num_badrange=0, & + ibadazm=0 + +integer(i_kind) :: ithin,zflag,nlevz,icntpnt,klon1,klat1,kk,klatp1,klonp1 +real(r_kind) :: rmesh,xmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11 +real(r_kind), allocatable, dimension(:) :: zl_thin + real(r_kind),dimension(nsig):: hges,zges + real(r_kind) sin2,termg,termr,termrg,zobs,height + integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2 + real(r_kind) crit1,timedif + real(r_kind),parameter:: r16000 = 16000.0_r_kind +logical :: luse + integer(i_kind) maxout,maxdata + integer(i_kind),allocatable,dimension(:):: isort + +!--General declarations + integer(i_kind) :: ierror,lunrad,i,j,k,v,na,nb,nelv,nvol, & + ikx,mins_an,mins_ob + integer(i_kind) :: maxobs,nchanl,ilat,ilon,idomsfc + + integer(i_kind),dimension(5) :: obdate + + real(r_kind) :: b,c,ha,epsh,h,aactual,a43,thistilt,ff10,sfcr,skint,zsges, & + radar_lon,radar_lat,dlon_radar,dlat_radar,errmax,errmin,error + real(r_kind) :: thistiltr,selev0,celev0,thisrange,this_stahgt,thishgt + real(r_kind) :: celev,selev,gamma,thisazimuthr,rlon0,t4dv, & + clat0,slat0,dlat,dlon,thiserr,thislon,thislat, & + rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter + real(r_kind) :: azm,cosazm_earth,sinazm_earth,cosazm,sinazm + real(r_kind) :: radartwindow + real(r_kind) :: rmins_an,rmins_ob + real(r_kind),allocatable,dimension(:,:):: cdata_all + real(r_double) rstation_id + + character(8) cstaid + character(4) this_staid + equivalence (this_staid,cstaid) + equivalence (cstaid,rstation_id) + + logical :: outside + + type(radar),allocatable :: strct_in_vel(:,:) + +real(r_kind) :: mintilt,maxtilt,maxobrange,minobrange + + integer(i_kind) :: thin_freq=1 + + mintilt=mintiltvr + maxtilt=maxtiltvr + minobrange=minobrangevr + maxobrange=maxobrangevr + + !-Check if radial velocity is in the convinfo file and extract necessary attributes + + ithin=1 !number of obs to keep per grid box + if(radar_no_thinning) then + ithin=-1 + endif + + errmax=-huge(errmax) + errmin=huge(errmin) + + ikx=0 + do i=1,nconvtype + if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then + ikx=i + radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes + ! (default setting for dbz within convinfo is 0.05 hours) + thiserr= 2_r_kind !1.75_r_kind !2_r_kind !Ob error (m/s) to use for radial velocity + exit !Exit loop when finished with initial convinfo fields + else if ( i==nconvtype ) then + write(6,*) 'READ_RADAR_WIND_ASCII: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO' + write(6,*) 'READ_RADAR_WIND_ASCII: ABORTING read_radar_wind_ascii.f90 - NO VELOCITY OBS READ!' + return + endif + end do + + + if (minobrange >= maxobrange) then + write(6,*) 'MININMUM OB RANGE >= MAXIMUM OB RANGE FOR READING RADIAL VELOCITY - PROGRAM STOPPING FROM READ_RADAR_WIND_ASCII.F90' + call stop2(400) + end if + + !-next three values are dummy values for now + nchanl=0 + ilon=2 + ilat=3 + + maxobs=50000000 !value taken from read_radar.f90 + + !--Allocate cdata_all array + + allocate(cdata_all(maxdat,maxobs),isort(maxobs)) + + + rmesh=rmesh_vr + zmesh=zmesh_vr + + maxout=0 + maxdata=0 + isort=0 + ntdrvr_thin2=0 + icntpnt=0 + zflag=0 + + use_all=.true. + if (ithin > 0) then + write(6,*)'READ_RADAR: ithin,rmesh :',ithin,rmesh + use_all=.false. + if(zflag == 0)then + nlevz=nsig + else + nlevz=r16000/zmesh + endif + xmesh=rmesh + call make3grids(xmesh,nlevz) + + allocate(zl_thin(nlevz)) + if (zflag == 1) then + do k=1,nlevz + zl_thin(k)=k*zmesh + enddo + endif + write(6,*)'READ_RADAR: xmesh, zflag, nlevz =', xmesh, zflag, nlevz + endif + + + lunrad=31 + open(lunrad,file=trim(infile),status='old',action='read', & + iostat=ierror,form='formatted') + + + fileopen: if (ierror == 0) then + read(lunrad,'(2i8)') nelv,nvol !read number of elevations and number of volumes + + + !*************************IMPORTANT***************************! + ! ! + ! All data = 999.0 correspond to missing or bad data ! + ! ! + !*************************************************************! + + + !------Begin processing--------------------------! + + + !-Obtain analysis time in minutes since reference date + + call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978 + rmins_an=mins_an !convert to real number + + volumes: do v=1,nvol + + read(lunrad,'(i8)') nelv + allocate(strct_in_vel(1,nelv)) + tilts: do k=1,nelv + + read(lunrad,'(a4)') strct_in_vel(1,k)%radid + read(lunrad,'(i8)') strct_in_vel(1,k)%vcpnum + read(lunrad,'(6i8)') strct_in_vel(1,k)%year & + ,strct_in_vel(1,k)%month & + ,strct_in_vel(1,k)%day & + ,strct_in_vel(1,k)%hour & + ,strct_in_vel(1,k)%minute & + ,strct_in_vel(1,k)%second + read(lunrad,'(2f10.3,f10.1)') strct_in_vel(1,k)%radlat & + ,strct_in_vel(1,k)%radlon & + ,strct_in_vel(1,k)%radhgt + read(lunrad,'(2f8.1)') strct_in_vel(1,k)%fstgatdis & + ,strct_in_vel(1,k)%gateWidth + read(lunrad,'(f8.3)') strct_in_vel(1,k)%elev_angle + read(lunrad,'(2i8)') strct_in_vel(1,k)%num_beam & + ,strct_in_vel(1,k)%num_gate + na=strct_in_vel(1,k)%num_beam + nb=strct_in_vel(1,k)%num_gate + + !******allocate arrays within radar data type**********! + allocate(strct_in_vel(1,k)%azim(na)) + allocate(strct_in_vel(1,k)%field(nb,na)) + !******************************************************! + + read(lunrad,'(f8.3)') strct_in_vel(1,k)%nyq_vel + read(lunrad,'(15f6.1)') (strct_in_vel(1,k)%azim(j),j=1,na) + read(lunrad,'(20f6.1)') ((strct_in_vel(1,k)%field(i,j),i=1,nb),j=1,na) + + + obdate(1)=strct_in_vel(1,k)%year + obdate(2)=strct_in_vel(1,k)%month + obdate(3)=strct_in_vel(1,k)%day + obdate(4)=strct_in_vel(1,k)%hour + obdate(5)=strct_in_vel(1,k)%minute + call w3fs21(obdate,mins_ob) !mins_ob -integer number of mins snce 01/01/1978 + rmins_ob=mins_ob !convert to real number + rmins_ob=rmins_ob+(strct_in_vel(1,k)%second*r60inv) !convert seconds to minutes and add to ob time + + !-Comparison is done in units of minutes + + timeb = rmins_ob-rmins_an + + + if(doradaroneob .and. (oneobradid /= strct_in_vel(1,k)%radid)) cycle tilts + + if(abs(timeb) > abs(radartwindow)) then + numbadtime=numbadtime+1 + cycle tilts !If not in time window, cycle the loop + end if + !--Time window check complete--! + + thistilt=strct_in_vel(1,k)%elev_angle + if (thistilt <= maxtilt .and. thistilt >= mintilt) then + + gates: do i=1,strct_in_vel(1,k)%num_gate,thin_freq + thisrange=strct_in_vel(1,k)%fstgatdis + float(i-1)*strct_in_vel(1,k)%gateWidth + + !-Check to make sure observations are within specified range + + if (thisrange <= maxobrange .and. thisrange >= minobrange) then + + azms: do j=1,strct_in_vel(1,k)%num_beam + + !-Check to see if this is a missing observation) + nread=nread+1 + if ( strct_in_vel(1,k)%field(i,j) >= 999.0_r_kind ) then + num_missing=num_missing+1 + cycle azms !No reason to process the ob if it is missing + end if + + !--Find observation height using method from read_l2bufr_mod.f90 + + this_stahgt=strct_in_vel(1,k)%radhgt + aactual=rearth+this_stahgt + a43=four_thirds*aactual + thistiltr=thistilt*deg2rad + selev0=sin(thistiltr) + celev0=cos(thistiltr) + b=thisrange*(thisrange+two*aactual*selev0) + c=sqrt(aactual*aactual+b) + ha=b/(aactual+c) + epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) + h=ha-epsh + thishgt=this_stahgt+h + height=thishgt + !--Find observation location using method from read_l2bufr_mod.f90 + + !-Get corrected tilt angle + celev=celev0 + selev=selev0 + celev=a43*celev0/(a43+h) + selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) + + gamma=half*thisrange*(celev0+celev) + + !-Get earth lat lon of observation + + rlon0=deg2rad*strct_in_vel(1,k)%radlon + clat0=cos(deg2rad*strct_in_vel(1,k)%radlat) + slat0=sin(deg2rad*strct_in_vel(1,k)%radlat) + thisazimuthr=(90.0_r_kind-strct_in_vel(1,k)%azim(j))*deg2rad !Storing as 90-azm to + ! be consistent with + ! read_l2bufr_mod.f90 + rad_per_meter=one/rearth + rlonloc=rad_per_meter*gamma*cos(thisazimuthr) + rlatloc=rad_per_meter*gamma*sin(thisazimuthr) + + call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) + + thislat=rlatglob*rad2deg + thislon=rlonglob*rad2deg + + if(doradaroneob) then + thislat=oneoblat + thislon=oneoblon + thishgt=oneobheight + endif + + + if(thislon>=r360) thislon=thislon-r360 + if(thislonzero) errmin=min(error,errmin) + if(abs(azm)>r400) then + ibadazm=ibadazm+1 + cycle azms + end if + + this_staid=strct_in_vel(1,k)%radid !Via equivalence in declaration, value is propagated + ! to rstation_id used below. + + ! Get model terrain at radar station location + ! If radar station is outside of grid, does not mean the + ! radar obs are outside the grid - therefore no need to + ! cycle azms. + + radar_lon=deg2rad*strct_in_vel(1,k)%radlon + radar_lat=deg2rad*strct_in_vel(1,k)%radlat + call tll2xy(radar_lon,radar_lat,dlon_radar,dlat_radar,outside) + call deter_zsfc_model(dlat_radar,dlon_radar,zsges) + + ! Determines land surface type based on surrounding land + ! surface types + + t4dv=timeb*r60inv + + call deter_sfc2(thislat,thislon,t4dv,idomsfc,skint,ff10,sfcr) + + + +!#################### Data thinning ################### + + icntpnt=icntpnt+1 + + if(ithin > 0)then + if(zflag == 0)then + klon1= int(dlon); klat1= int(dlat) + dx = dlon-klon1; dy = dlat-klat1 + dx1 = one-dx; dy1 = one-dy + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) + if (klon1==0) klon1=nlon + klatp1=min(nlat,klat1+1); klonp1=klon1+1 + if (klonp1==nlon+1) klonp1=1 + do kk=1,nsig + hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + & + w10*hgtl_full(klatp1,klon1 ,kk) + & + w01*hgtl_full(klat1 ,klonp1,kk) + & + w11*hgtl_full(klatp1,klonp1,kk) + end do + sin2 = sin(thislat)*sin(thislat) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do kk=1,nsig + zges(kk) = (termr*hges(kk)) / (termrg-hges(kk)) + zl_thin(kk)=zges(kk) + end do + endif + + zobs = height + + ntmp=ndata ! counting moved to map3gridS + if (l4dvar) then + timedif = zero + else +! timedif=abs(t4dv-toff) + timedif=abs(t4dv) !don't know about this + endif + crit1 = timedif/r6+half + + call map3grids(1,zflag,zl_thin,nlevz,thislat,thislon,& + zobs,crit1,ndata,iout,icntpnt,iiout,luse, .false., .false.) + maxout=max(maxout,iout) + maxdata=max(maxdata,ndata) + + if (.not. luse) then + ntdrvr_thin2=ntdrvr_thin2+1 + cycle + endif + if(iiout > 0) isort(iiout)=0 + if (ndata > ntmp) then + nodata=nodata+1 + endif + isort(icntpnt)=iout + + else + ndata =ndata+1 + nodata=nodata+1 + iout=ndata + isort(icntpnt)=iout + endif + + cdata_all(1,iout) = error ! wind obs error (m/s) + cdata_all(2,iout) = dlon ! grid relative longitude + cdata_all(3,iout) = dlat ! grid relative latitude + cdata_all(4,iout) = thishgt ! obs absolute height (m) + cdata_all(5,iout) = strct_in_vel(1,k)%field(i,j) ! wind obs (m/s) + cdata_all(6,iout) = azm ! azimuth angle (radians) + cdata_all(7,iout) = t4dv ! obs time (hour) - analysis relative + cdata_all(8,iout) = ikx ! type + cdata_all(9,iout) = thistiltr ! tilt angle (radians) + cdata_all(10,iout)= this_stahgt ! station elevation (m) + cdata_all(11,iout)= rstation_id ! station id + cdata_all(12,iout)= icuse(ikx) ! usage parameter + cdata_all(13,iout)= idomsfc ! dominate surface type + cdata_all(14,iout)= skint ! skin temperature + cdata_all(15,iout)= ff10 ! 10 meter wind factor + cdata_all(16,iout)= sfcr ! surface roughness + cdata_all(17,iout)=thislon*rad2deg ! earth relative longitude (degrees) + cdata_all(18,iout)=thislat*rad2deg ! earth relative latitude (degrees) + cdata_all(19,iout)=thisrange/1000_r_kind ! range from radar in km (used to estimate beam spread) + cdata_all(20,iout)=zsges ! model elevation at radar site + cdata_all(21,iout)=thiserr + cdata_all(22,iout)=two ! Level 2 data + + if(doradaroneob .and. (cdata_all(5,iout) > -99_r_kind) ) exit volumes + + end do azms !j + else + num_badrange=num_badrange+1 !If outside acceptable range, increment + end if !Range check + + end do gates !i + + else + num_badtilt=num_badtilt+1 !If outside acceptable tilts, increment + end if !Tilt check + + end do tilts !k + + do k=1,nelv + deallocate(strct_in_vel(1,k)%azim) + deallocate(strct_in_vel(1,k)%field) + enddo + deallocate(strct_in_vel) + end do volumes !v + + close(lunrad) !modified to do one scan at a time + + if (.not. use_all) then + deallocate(zl_thin) + call del3grids + endif +!end modified for thinning + +!---all looping done now print diagnostic output + + write(6,*)'READ_RADAR_WIND_ASCII: Reached eof on radar wind ascii file' + write(6,*)'READ_RADAR_WIND_ASCII: # volumes in input file =',nvol + write(6,*)'READ_RADAR_WIND_ASCII: # elevations per volume =',nelv + write(6,*)'READ_RADAR_WIND_ASCII: # elevations outside time window =',numbadtime + write(6,*)'READ_RADAR_WIND_ASCII: # of missing data =',num_missing + write(6,*)'READ_RADAR_WIND_ASCII: # outside specif. range =',num_badrange + write(6,*)'READ_RADAR_WIND_ASCII: # outside specif. tilts =',num_badtilt + write(6,*)'READ_RADAR_WIND_ASCII: # bad azimuths =',ibadazm +!---Write observation to scratch file---! + + call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) + write(lunout) obstype,sis,maxdat,nchanl,ilat,ilon + write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) + + + !---------------DEALLOCATE ARRAYS-------------! + + deallocate(cdata_all) + + else !fileopen + write(6,*) 'READ_RADAR_WIND_ASCII: ERROR OPENING RADIAL VELOCITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...' + end if fileopen + + +end subroutine read_radar_wind_ascii + diff --git a/src/read_radarref_mosaic.f90 b/src/gsi/read_radarref_mosaic.f90 similarity index 100% rename from src/read_radarref_mosaic.f90 rename to src/gsi/read_radarref_mosaic.f90 diff --git a/src/read_rapidscat.f90 b/src/gsi/read_rapidscat.f90 similarity index 100% rename from src/read_rapidscat.f90 rename to src/gsi/read_rapidscat.f90 diff --git a/src/read_saphir.f90 b/src/gsi/read_saphir.f90 similarity index 95% rename from src/read_saphir.f90 rename to src/gsi/read_saphir.f90 index ac389492a..7330a86ad 100644 --- a/src/read_saphir.f90 +++ b/src/gsi/read_saphir.f90 @@ -20,6 +20,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& ! 2016-04-01 ejones - add binning of fovs for scan angle bias correction ! 2016-07-25 ejones - remove binning of fovs ! 2016-10-05 acollard -Fix interaction with NSST and missing zenith angle issue. +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -55,13 +56,15 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,destroygrids,checkob, & finalcheck,map2tgrid,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only: iuse_rad,nusis,jpch_rad, & use_edges,radedge1,radedge2,radstart,radstep use gridmod, only: diagnostic_reg,regional,nlat,nlon,tll2xy,txy2ll,rlats,rlons use constants, only: deg2rad,zero,one,two,three,rad2deg,r60inv use crtm_module, only : max_sensor_zenith_angle use calc_fov_crosstrk, only : instrument_init, fov_cleanup, fov_check - use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar,thin4d + use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar use deter_sfc_mod, only: deter_sfc_fov,deter_sfc use gsi_nstcouplermod, only: nst_gsi,nstinfo use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth,gsi_nstcoupler_deter @@ -136,6 +139,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& real(r_kind), POINTER :: dlon_earth,dlat_earth,satazi, lza integer(i_kind), ALLOCATABLE, TARGET :: ifov_save(:) + integer(i_kind), ALLOCATABLE, TARGET :: it_mesh_save(:) real(r_kind), ALLOCATABLE, TARGET :: rsat_save(:) real(r_kind), ALLOCATABLE, TARGET :: t4dv_save(:) real(r_kind), ALLOCATABLE, TARGET :: dlon_earth_save(:) @@ -154,6 +158,9 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& real(r_double),dimension(n2bhdr):: bfr2bhdr real(r_kind) :: disterr,disterrmax,dlon00,dlat00 + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin + integer(i_kind),pointer:: it_mesh => null() !************************************************************************** @@ -174,8 +181,14 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& call gsi_nstcoupler_skindepth(obstype,zob) endif + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Set nadir position nadir=65 @@ -261,6 +274,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& ALLOCATE(dlon_earth_save(maxobs)) ALLOCATE(dlat_earth_save(maxobs)) ALLOCATE(crit1_save(maxobs)) + ALLOCATE(it_mesh_save(maxobs)) ALLOCATE(lza_save(maxobs)) ALLOCATE(satazi_save(maxobs)) ALLOCATE(solzen_save(maxobs)) @@ -289,6 +303,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& dlon_earth => dlon_earth_save(iob) dlat_earth => dlat_earth_save(iob) crit1 => crit1_save(iob) + it_mesh => it_mesh_save(iob) ifov => ifov_save(iob) lza => lza_save(iob) satazi => satazi_save(iob) @@ -329,13 +344,10 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& if(abs(tdiff) > twind+one_minute) cycle read_loop endif - if (thin4d) then - crit1 = zero - else - crit1 = two*abs(tdiff) ! range: 0 to 6 - endif + crit0 = 0.00_r_kind ! forced to >= 0.01_r_kind in tdiff2crit() + timeinflat=two + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) - call ufbint(lnbufr,bfr2bhdr,n2bhdr,1,iret,hdr2b) satazi=bfr2bhdr(3) @@ -399,6 +411,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& dlon_earth => dlon_earth_save(iob) dlat_earth => dlat_earth_save(iob) crit1 => crit1_save(iob) + it_mesh => it_mesh_save(iob) ifov => ifov_save(iob) lza => lza_save(iob) satazi => satazi_save(iob) @@ -442,7 +455,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& endif ! Map obs to thinning grid - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle ObsLoop ! @@ -581,6 +594,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& DEALLOCATE(dlon_earth_save) DEALLOCATE(dlat_earth_save) DEALLOCATE(crit1_save) + DEALLOCATE(it_mesh_save) DEALLOCATE(lza_save) DEALLOCATE(satazi_save) DEALLOCATE(solzen_save) diff --git a/src/read_satmar.f90 b/src/gsi/read_satmar.f90 similarity index 81% rename from src/read_satmar.f90 rename to src/gsi/read_satmar.f90 index a5dddb385..3a7f349c2 100644 --- a/src/read_satmar.f90 +++ b/src/gsi/read_satmar.f90 @@ -1,32 +1,45 @@ -subroutine read_satmar (nread, ndata, nodata, & +subroutine read_satmar (nread, ndata, nodata, & infile, obstype, lunout, gstime, twind, sis, & nobs ) ! -! !subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,& ! infile,lunout,obstype,nread,ndata,nodata,twind,sis, & ! mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs, & ! nrec_start,dval_use) - ! *#* Documentation block - Start *#* ! ! => Subroutine read_satmar : Reads Hs from Altimeters ! => Coder : stelios flampouris - stylianos.flampouris@noaa.gov ! => Abstract : -! 1. This routine reads data from three different altimeters (Jason-2, -! Cryosat-2 and Saral/Altika. -! 2. It uses the provided flags for QC. +! 1. This routine reads data from CNES and OCEANAVO: +! OCEANAVO: xx114 (NC031114) // xx120 (NC031120) // xx121 (NC031121) // xx127 (NC031127) // xx130 (NC031130) +! CNES : xx115 (NC031115) // xx122 (NC031122) // xx123 (NC031123) // xx124 (NC031124) +! +! DATA SET | Corresponding Satellite +! xx114, xx115 | JASON-2 +! xx120, xx123 | CRYOSAT-2 +! xx121, xx122 | SARAL/ATK +! xx124, xx127 | JASON-3 +! xx130 | SENTINEL3a +! +! 2. It uses the provided flags for QC. ! 3. Observations only within the domain of interest are retained. ! ! For reading the data of interest, the "headers" (hdr_ variables) have to be ! modified accordingly; in this case, Significant Wave Height (howv or hs) data are -! imported. +! imported. ! ! => History log : ! 2016.03.07 : stelios flampouris ! 2017.05.03 : pondeca: add c_station_id and set station id to "SATMAR" ! for now -! +! 2017.08.07 : stelios: 1. The data from CNES and OCEANAVO can be used. +! : 2. The c_station_id is variable and gets the +! input from the "subset" according to the values given at the +! datasets when dumped at the tanks. +! 2017.08.12 : stelios: Imports Sentinel3a howv obs +! 2017.10.01 : jacob : Fix bug +! 2017.10.23 : stelios: Keep unique data ! ! input argument list: ! ithin - flag to thin data @@ -39,7 +52,7 @@ subroutine read_satmar (nread, ndata, nodata, & ! sis - satellite/instrument/sensor indicator ! ! output argument list: -! nread - number of obs read +! nread - number of obs read ! ndata - number of obs retained for further processing ! nodata - number of obs retained for further processing ! nobs - array of observations on each subdomain for each processor @@ -49,7 +62,7 @@ subroutine read_satmar (nread, ndata, nodata, & ! ! *#* Documentation block - End *#* ! -! *#* Variables Declaration - Start *#* +! *#* Variables Declaration - Start *#* use kinds, only: r_kind,r_double,i_kind use gsi_4dvar, only: l4dvar,l4densvar,winlen,iwinbgn,thin4d,time_4dvar use constants, only: zero, deg2rad,rad2deg,one,two,three,four,ten,half, & @@ -57,25 +70,25 @@ subroutine read_satmar (nread, ndata, nodata, & use gridmod, only: regional, rlats,rlons,nlat,nlon,txy2ll,tll2xy, & twodvar_regional use satthin, only: map2tgrid,destroygrids,makegrids - use convinfo, only: ithin_conv,rmesh_conv,nconvtype,icuse,ictype,ioctype + use convinfo, only: ithin_conv,rmesh_conv,nconvtype,icuse,ictype,ioctype,ctwind use convthin, only: make3grids,use_all,map3grids,del3grids use obsmod, only: bmiss,hilbert_curve use mpimod, only: npe - + implicit none ! !! %%% Declare passed variables IN integer(i_kind) , intent(in) :: lunout - character(len=*) , intent(in) :: infile, obstype + character(len=*) , intent(in) :: infile, obstype real(r_kind) , intent(in) :: gstime,twind -!! %%%% Declare Passed Variables INOUT +!! %%%% Declare Passed Variables INOUT integer(i_kind) , intent(inout) :: nread,ndata,nodata integer(i_kind),dimension(npe) , intent(inout) :: nobs !! %%% Declare local varables ! integer integer(i_kind) :: ithin integer(i_kind),parameter :: lun11 = 11 - integer(i_kind),parameter :: nosat = 4 + integer(i_kind),parameter :: nosat = 9 integer(i_kind),parameter :: n_tm = 6 integer(i_kind),parameter :: n_lc = 2 integer(i_kind),parameter :: n_howv= 2 @@ -87,7 +100,7 @@ subroutine read_satmar (nread, ndata, nodata, & ! integer(i_kind) :: tot,cnt,cnt1,k,ntmp,iout,iiout integer(i_kind) :: ireadmg,ireadsb,idate - integer(i_kind) :: iRec,ierr,nc,i1,ilat,ilon,nchanl,nlevp + integer(i_kind) :: iRec,ierr,nc,i1,ilat,ilon,nchanl,nlevp,indsat integer(i_kind) :: nmind, nrec integer(i_kind) :: thisobtype_usage, iuse ! real @@ -108,10 +121,10 @@ subroutine read_satmar (nread, ndata, nodata, & character(len=20) :: sis character(len=20) :: subset character(len=11), parameter :: myname='read_satmar ' - ! logical logical outside, luse logical lhilbert + logical, dimension(nosat) :: satuse !!!! ##### JS2 ##### !!!! integer(i_kind),parameter :: n_fltJS2 = 7 ! @@ -121,10 +134,10 @@ subroutine read_satmar (nread, ndata, nodata, & real(r_double), dimension (n_lc) :: loc_1d real(r_double), dimension (n_howv) :: howv_1d real(r_kind) :: t4dv - character(80),parameter:: hdr_fltJS2 = 'RSST AETP ASFL ADQF ALRF IPIN ODLE' character(80),parameter:: hdr_time = 'YEAR MNTH DAYS HOUR MINU SECW' - character(80),parameter:: hdr_loc = 'CLATH CLONH' +! character(80),parameter:: hdr_loc = 'CLATH CLONH' + character(80) :: hdr_loc character(80),parameter:: hdr_howvJS2 = 'KBSW RKSW ' !CBSW RCSW' !!!! ##### SARAL ##### !!!! integer(i_kind),parameter :: n_fltSAL = 5 @@ -134,25 +147,26 @@ subroutine read_satmar (nread, ndata, nodata, & character(80),parameter:: hdr_fltSAL = 'RSST BSADQF NVPSWH IPIN ODLE' character(80),parameter:: hdr_howvSAL = 'SBSWH RMSSWH' !!!! ##### CS2 ##### !!!! - integer(i_kind),parameter :: n_fltCS2 = 5 + integer(i_kind),parameter :: n_fltCS2 = 5 integer(i_kind),parameter :: n_howvCS2 = 4 ! real(r_double), dimension (n_fltCS2) :: flt_1dCS2 ! real(r_kind), dimension (n_howvCS2) :: howv_1dCS2 +! + integer(i_kind),parameter :: n_howvNO = 2 !NO ! character(80),parameter:: hdr_timeCS2 = 'YEAR MNTH DAYS HOUR MINU SECO' character(80),parameter:: hdr_fltCS2 = 'DSST ODLE L1PQ L1PF L2PF' character(80),parameter:: hdr_howvCS2 = 'KBSW NVPK2' ! character(80),parameter:: hdr_howvCS2 = 'KBSW NVPK2 SBSW SWHS ' + character(80),parameter:: hdr_howvNO = 'HOWV SDWH' !NO ! character(80),parameter::hdr_station = 'SAID' - real(r_double) :: rstation_id + real(r_double) :: rstation_id character(8) c_station_id ! - - equivalence(rstation_id,c_station_id) - -!!!!! Swords + equivalence(rstation_id,c_station_id) +! Swords integer(i_kind),parameter :: howvMax = 12 integer(i_kind),parameter :: howvRatMiuSigma = 3 integer(i_kind),parameter :: howvRathowvDpth = 2 @@ -160,16 +174,20 @@ subroutine read_satmar (nread, ndata, nodata, & ! ! call init_constants_derived lhilbert = twodvar_regional .and. hilbert_curve - namesat(1:nosat) = (/'NC031115','NC031122','NC031123','NC031124'/) - tot = 0 + namesat(1:nosat) = (/'NC031115','NC031122','NC031123','NC031127' & + ,'NC031114','NC031121','NC031120','NC031124' & + ,'NC031130' /) + + satuse(1:nosat) = .true. + tot = 0 cnt = 0 - irec = 0 + irec = 0 cnt1 = 0 nchanl=0 nread = 0 ilon=2 ilat=3 - nrec = 1 + nrec = 0 ! ithin=-9 nc=zero @@ -192,7 +210,6 @@ subroutine read_satmar (nread, ndata, nodata, & use_all = .false. nlevp=1 !Dummy for using make3grids allocate(DumForThin(nlevp)) !Dummy for using make3grids - xmesh=rmesh call make3grids(xmesh,nlevp) write(6,'(A,1x,A,1x,A,I4,1x,f8.2,1x,I3,1x,I3)')myname,': ioctype(nc),ictype(nc),rmesh,nlevp,nc ',& @@ -201,9 +218,8 @@ subroutine read_satmar (nread, ndata, nodata, & ! ! *#* Main - Start *#*! call closbf(lun11) - open(lun11,file=trim(infile),action='read',form='unformatted', iostat=ierr) - if (ierr/=0) then + if (ierr/=0) then print*, myname,' : ERROR : File ', trim(infile),' not existing. ' return end if @@ -211,31 +227,37 @@ subroutine read_satmar (nread, ndata, nodata, & call openbf(lun11,'IN',lun11) ! ! Counting all the data - do while(ireadmg(lun11,subset,idate) == 0) do while (ireadsb(lun11) == 0) cnt = cnt+1 if(cnt == 1) call time_4dvar(idate,toff) end do end do -! call closbf(lun11) ! ! Allocate Arrays for all the data allocate (data_all (nreal, cnt),isort(cnt)) isort = 0 -! +! ! Loop over file open(lun11,file=trim(infile),action='read',form='unformatted') call openbf(lun11,'IN',lun11) call datelen(dtLen) ! read_msg: do while(ireadmg(lun11,subset,idate) == 0) + do i1 = 1,nosat + if (index(trim(subset),trim(namesat(i1))) > 0) then + indsat=i1 + exit + end if + end do + if ( .not.satuse(indsat) ) cycle +! ! Read through each record read_loop: do while (ireadsb(lun11) == 0) nrec = nrec + 1 ! - time_1d = zero + time_1d = zero howv_1d = zero loc_1d = zero depth = -99999.0_r_kind @@ -253,41 +275,55 @@ subroutine read_satmar (nread, ndata, nodata, & (flt_1dJS2(6)/=0.0_r_double) ) cycle depth = abs(flt_1dJS2(7)) -! Time +! Time call ufbint(lun11,time_1d,n_tm,1,irec,hdr_time) ! Howv call ufbint(lun11,howv_1d,n_howv,1,irec,hdr_howvJS2) + hdr_loc = 'CLATH CLONH' ! else if (index(trim(subset),trim(namesat(2)))>0) then !SRLTK -! sis = namesat(2) +! sis = namesat(2) call ufbint(lun11,flt_1dSAL,n_fltSAL,1,irec,hdr_fltSAL) if ( (flt_1dSAL(1)>1.0_r_double ) .or. & (flt_1dSAL(2)/=0.0_r_double) .or. & (flt_1dSAL(3)<=30.0_r_double) .or. & - (flt_1dSAL(4)/=0.0_r_double ) ) cycle - + (flt_1dSAL(4)/=0.0_r_double ) ) cycle + depth = abs(flt_1dSAL(5)) -! Time +! Time call ufbint(lun11,time_1d,n_tm,1,irec,hdr_time) ! Howv call ufbint(lun11,howv_1d,n_howv,1,irec,hdr_howvSAL) ! + hdr_loc = 'CLATH CLONH' else if (index(trim(subset),trim(namesat(3)))>0) then !CS2 -! sis=namesat(3) +! sis=namesat(3) call ufbint(lun11,flt_1dCS2,n_fltCS2,1,irec,hdr_fltCS2) if ( (flt_1dCS2(1) > 1.0_r_double ) .or. & (flt_1dCS2(2) > 0.0_r_double ) .or. & (flt_1dCS2(3) < 90.0_r_double ) .or. & (flt_1dCS2(4) /= 0.0_r_double ) .or. & - (flt_1dCS2(5) /= 0.0_r_double ) ) cycle + (flt_1dCS2(5) /= 0.0_r_double ) ) cycle ! depth = abs(flt_1dCS2(2)) -! Time +! Time call ufbint(lun11,time_1d,n_tm,1,irec,hdr_timeCS2) ! Howv call ufbint(lun11,howv_1d,n_howv,1,irec,hdr_howvCS2) howv_1d(2)=zero ! + hdr_loc = 'CLATH CLONH' + else if( (index(trim(subset),trim(namesat(5))) > 0) & + .or.(index(trim(subset),trim(namesat(6))) > 0) & + .or.(index(trim(subset),trim(namesat(7))) > 0) & + .or.(index(trim(subset),trim(namesat(8))) > 0) & + .or.(index(trim(subset),trim(namesat(9))) > 0) ) then !NO +! Time + call ufbint(lun11,time_1d,n_tm,1,irec,hdr_timeCS2) +! Howv + call ufbint(lun11,howv_1d,n_howv,1,irec,hdr_howvNO) +! + hdr_loc = 'CLAT CLON ' end if ! Temporal space time_1dMN = int(time_1d(1:5)) @@ -299,11 +335,9 @@ subroutine read_satmar (nread, ndata, nodata, & tdiff=(rminobs-gstime)*r60inv ! if (l4dvar.or.l4densvar) then - if (t4dvwinlen) cycle + if (t4dvwinlen) cycle else - if (abs(tdiff) < twind) then - !t4dv = abs(tdiff) - else + if (abs(tdiff) > ctwind(nc) .or. (abs(tdiff) > twind) )then cycle end if endif @@ -314,14 +348,16 @@ subroutine read_satmar (nread, ndata, nodata, & ! if (loc_1d(2)>=360.0) loc_1d(2)=loc_1d(2)-360.0_r_kind if (loc_1d(2)< zero) loc_1d(2)=loc_1d(2)+360.0_r_kind -! +! dlon_earth=loc_1d(2)*deg2rad dlat_earth=loc_1d(1)*deg2rad - nread = nread + 1 + nread = nread + 1 ! - if(regional)then ! Regional + if(regional)then ! Regional + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! *Convert to rotated coordinate if(outside) cycle + else ! Global case dlon=dlon_earth dlat=dlat_earth @@ -349,14 +385,13 @@ subroutine read_satmar (nread, ndata, nodata, & ! if (abs(howv_1d(1)-howv_1d_m1(1))/(dt_sec)**two > grav/two ) cycle !qc5 ! end if ! nsec_m1 = nsec -! loc_1d_m1 = loc_1d +! loc_1d_m1 = loc_1d ! howv_1d_m1 = howv_1d(1) ! end if tot = tot+1 -! +! ! Dragon on Diet cnt = 0 - iuse=icuse(nc) if (ithin > 0 .and. iuse >=0) then ntmp=ndata @@ -369,8 +404,7 @@ subroutine read_satmar (nread, ndata, nodata, & ! call map3grids(-1,0,DumForThin,nlevp,dlat_earth,dlon_earth & ,one ,crit1,ndata,iout,nrec,iiout,luse,.false.,.false.) - - if (.not. luse) cycle + if (.not. luse) cycle if(iiout > 0) isort(iiout)=0 if (ndata > ntmp) then nodata=nodata+1 @@ -385,14 +419,24 @@ subroutine read_satmar (nread, ndata, nodata, & ! usage = zero !- Set usage variable :: practically useless if (howv_1d(2)<=tiny_r_kind) howv_1d(2)=dflt_err -! +! ! call ufbint(lun11,c_station_id,1,1,irec,hdr_station) - c_station_id='SATMAR' -! +! c_station_id='SATMAR' + c_station_id=trim(subset) +! + if (index(trim(subset),trim(namesat(1))) > 0) satuse(5)=.false. + if (index(trim(subset),trim(namesat(2))) > 0) satuse(6)=.false. + if (index(trim(subset),trim(namesat(3))) > 0) satuse(7)=.false. + if (index(trim(subset),trim(namesat(4))) > 0) satuse(8)=.false. + if (index(trim(subset),trim(namesat(5))) > 0) satuse(1)=.false. + if (index(trim(subset),trim(namesat(6))) > 0) satuse(2)=.false. + if (index(trim(subset),trim(namesat(7))) > 0) satuse(3)=.false. + if (index(trim(subset),trim(namesat(8))) > 0) satuse(4)=.false. + data_all(1,iout) = howv_1d(2) ! significant wave height error (m) data_all(2,iout) = dlon ! grid relative longitude data_all(3,iout) = dlat ! grid relative latitude - data_all(4,iout) = zero !105.0 ! pressure (in cb) + data_all(4,iout) = zero ! pressure (in cb) data_all(5,iout) = howv_1d(1) ! significant wave height (in m) data_all(6,iout) = rstation_id ! station id data_all(7,iout) = t4dv ! time @@ -400,7 +444,7 @@ subroutine read_satmar (nread, ndata, nodata, & data_all(9,iout) = 0_r_kind ! quality mark data_all(10,iout) = 0.2_r_kind ! original obs error (m) data_all(11,iout) = usage ! usage parameter - if (lhilbert) thisobtype_usage=11 ! save INDEX of where usage is stored for hilbertcurve cross validation (if requested) + if (lhilbert) thisobtype_usage=11 ! save INDEX of where usage is stored for hilbertcurve cross validation (if requested) data_all(12,iout) = zero ! dominate surface type data_all(13,iout) = 295_r_kind ! skin temperature data_all(14,iout) = 1.0 ! 10 meter wind factor @@ -412,7 +456,7 @@ subroutine read_satmar (nread, ndata, nodata, & data_all(20,iout) = -depth ! terrain height at ob location data_all(21,iout) = 100000000000.000_r_kind ! provider name !r_prvstg(1,1) data_all(22,iout) = 100000000000.000_r_kind ! subprovider name !r_sprvstg(1,1) - data_all(23,iout) = 0_r_kind ! cat + data_all(23,iout) = 0_r_kind ! cat ! enddo read_loop enddo read_msg @@ -432,7 +476,6 @@ subroutine read_satmar (nread, ndata, nodata, & end if ! allocate(data_out(nreal,ndata)) - do i1=1,ndata iout=iloc(i1) do k=1,nreal @@ -442,21 +485,20 @@ subroutine read_satmar (nread, ndata, nodata, & deallocate(iloc,isort,data_all) call count_obs(ndata,nreal,ilat,ilon,data_out,nobs) - + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata write(lunout) data_out deallocate(data_out) - - if (ndata == 0) then + + if (ndata == 0) then write(6,*)myname,': closbf(',lun11,')' endif - close(lun11) ! ! Deallocate local arrays if (ithin > 0 ) then deallocate(DumForThin) - call del3grids + call del3grids end if ! end subroutine read_satmar @@ -467,17 +509,16 @@ subroutine lldistm(latlon1,latlon2, Hdistm, Pdistm) ! => Subroutine lldistm : Calculates the distance in m between two points in ! spherical coordinates (Earth in this case). ! => Coder : stelios flampouris (stylianos.flampouris@noaa.gov) -! => Abstract : Fortran code for Haversine and Pythagorian distance +! => Abstract : Fortran code for Haversine and Pythagorian distance ! ! => History log : -! 2016.03.08 : stelios - Prototype +! 2016.03.08 : stelios - Prototype ! 2016.08.24 : stelios - Fully compatible with GSI ! ! => Input Arguments : latlon1 latitude & longtitude of point 1 ! : latlon1 latitude & longtitude of point 2 ! => Output Arguments : Hdistm Haversine distance between the point1 and point2 in meters(m) ! : Pdistm Pythagorian distance between the point1 and point2 in meters(m) - ! => Attributes : Machine Theia ! ! *#* Documentation block - End *#* @@ -486,7 +527,7 @@ subroutine lldistm(latlon1,latlon2, Hdistm, Pdistm) implicit none real(r_kind), dimension(2), intent(in) :: latlon1, latlon2 real(r_kind), intent(out):: Hdistm, Pdistm -!local variables +!local variables real(r_kind) :: lat1, lat2, lon1, lon2, dLat, dLon, dum1, dum2, x, y ! integer(i_kind), parameter :: rearth=6371000 !(m) ! @@ -515,7 +556,7 @@ subroutine datesec(idate, nsec) ! => Subroutine datenum : Calculates the number of seconds since 00:00:00, ! 1 January 1978 (RefDate : in days) ! => Coder : stelios flampouris (stylianos.flampouris@noaa.gov) -! => Abstract/FlowChart : +! => Abstract/FlowChart : ! ! [YYYY,MM,DD]-->Convert to Julian Days (JD)-->NDays=JD-Refdate-->Convert to ! Seconds (NDaysInSec)--> nsec=NDaysInSec+HH*3600+MN*60+SS @@ -523,7 +564,7 @@ subroutine datesec(idate, nsec) ! => History log : ! 2016.03.08 : stelios flampouris ! -! => Input Arguments : idate real array with size 6: +! => Input Arguments : idate real array with size 6: ! idate(1)=YYYY !Year ! idate(2)=MM !Month ! idate(3)=DD !Day @@ -531,7 +572,7 @@ subroutine datesec(idate, nsec) ! idate(5)=MN !Minute ! idate(6)=SS !Second ! -! => Output Arguments : nsec integer Number of seconds +! => Output Arguments : nsec integer Number of seconds ! ! => Attributes : Machine Theia ! @@ -541,7 +582,7 @@ subroutine datesec(idate, nsec) real(8), intent(in) :: idate(6) real(8), intent(out) :: nsec ! -! local parameters +! local parameters real(8), parameter :: ReFDate = 2443510. real(8) :: JD ! @@ -564,10 +605,10 @@ end subroutine datesec ! ! ! ### -! Unused Code but Useful +! Unused Code but Useful ! !! ### Not necessary but implemented + All the Variables are Declared -! ### Plug it in the "Regional Check" +! ### Plug it in the "Regional Check" ! if(diagnostic_reg) then ! call txy2ll(dlon,dlat,dlon00,dlat00) ! cnt1=cnt1+1 @@ -578,4 +619,3 @@ end subroutine datesec ! disterrmax=max(disterrmax,disterr) ! end if ! ### - diff --git a/src/read_satwnd.f90 b/src/gsi/read_satwnd.f90 similarity index 98% rename from src/read_satwnd.f90 rename to src/gsi/read_satwnd.f90 index 9f427a6a7..7eb0a7bb9 100644 --- a/src/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -67,8 +67,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! 2016-12-13 Lim - Addition of GOES SWIR, CAWV and VIS winds into HWRF ! 2017-08-22 Genkova - Testing Git / Add Goes-16 and JPSS SatID ! - Read WMO pre-approved new BUFR Goes-16 AMVs (Goes-R) +! 2018-06-13 Genkova - Goes-16 AMVs use ECMWF QC till new HAM late 2018 +! and OE/2 ! -! +! ! ! input argument list: ! ithin - flag to thin data @@ -108,7 +110,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis use convinfo, only: nconvtype, & icuse,ictype,icsubtype,ioctype, & ithin_conv,rmesh_conv,pmesh_conv,pmot_conv,ptime_conv, & - use_prepb_satwnd + use_prepb_satwnd, ec_amv_qc use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d use deter_sfc_mod, only: deter_sfc_type,deter_sfc2 @@ -876,6 +878,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Extra block for GOES-R winds: Start else if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. & !IR(LW) / CS WV / VIS GOES-R like winds trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039' ) then !CT WV / IR(SW) GOES-R like winds + if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDs ! The sample newBUFR has SAID=259 (GOES-15) ! When GOES-R SAID is assigned, pls check @@ -965,6 +968,18 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis endif endif +! GOES-16 additional QC addopting ECMWF's approach(Katie Lean,14IWW)-start + if (EC_AMV_QC) then + if (qifn < 90_r_kind .or. qifn > r100 ) qm=15 ! stricter QI + if (ppb < 150.0_r_kind) qm=15 ! all high level + if (itype==251 .and. ppb < 700.0_r_kind) qm=15 ! VIS + if (itype==246 .and. ppb > 300.0_r_kind) qm=15 ! WVCA + dlon_earth=hdrdat(3)*deg2rad + dlat_earth=hdrdat(2)*deg2rad + call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg) + if (isflg == 1 .and. ppb > 850.0_r_kind) qm=15 ! low over land + endif + ! winds rejected by qc dont get used if (qm == 15) usage=r100 if (qm == 3 .or. qm ==7) woe=woe*r1_2 @@ -1233,6 +1248,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis endif if (ptime >zero ) then itime=int((tdiff+three)/ptime)+1 + if (itime >ntime) itime=ntime if(pmot 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Open bufr file. call closbf(lnbufr) @@ -186,7 +200,7 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& if( iret/=0) then write(6,*) 'READ_SEVIRI: SKIP PROCESSING OF SEVIRI FILE' write(6,*) 'infile=', lnbufr, infile - go to 900 + return endif clrsky=.false. @@ -198,9 +212,12 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& else write(6,*) 'READ_SEVIRI: SKIP PROCESSING OF SEVIRI FILE' write(6,*) 'infile=', lnbufr, infile,' subset=', subset - go to 900 + return endif +! Make thinning grids + call makegrids(rmesh,ithin,n_tbin=n_tbin) + ! Set BUFR string based on seviri data set if (clrsky) then hdrsevi='SAID YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH SAZA SOZA' @@ -229,24 +246,39 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& ! Reopen unit to bufr file call closbf(lnbufr) - open(lnbufr,file=infile,form='unformatted') - call openbf(lnbufr,'IN',lnbufr) if(jsatid == 'm08') kidsat = 55 if(jsatid == 'm09') kidsat = 56 if(jsatid == 'm10') kidsat = 57 + if(jsatid == 'm11') kidsat = 70 + if( ithin_time == 5) then + call read_subset_nnsb + endif + open(lnbufr,file=infile,form='unformatted') + call openbf(lnbufr,'IN',lnbufr) nrec=999999 irec=0 next=0 + jrec=0 ! Big loop over bufr file read_msg: do while (ireadmg(lnbufr,subset,idate) >= 0) irec=irec+1 if(irec < nrec_start) cycle read_msg + if( ithin_time == 5) then + jrec=jrec+1 + if (allocated(rd_tdiffs)) deallocate(rd_tdiffs) + allocate(rd_tdiffs(subset_nnsb(jrec))) + call random_number(harvest=rd_tdiffs) + endif next=next+1 if(next == npe_sub)next=0 if(next /= mype_sub)cycle + nnsb=0 read_loop: do while (ireadsb(lnbufr) == 0) + if( ithin_time == 5) then + nnsb=nnsb+1 + endif ! Read through each record call ufbint(lnbufr,hdr,nhdr,1,iret,hdrsevi) @@ -311,14 +343,14 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& else if (abs(tdiff)>twind) cycle read_loop endif - if (thin4d) then - crit1=0.01_r_kind - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - crit1=0.01_r_kind+timedif - endif - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0=0.01_r_kind + timeinflat=6.0_r_kind + if( ithin_time == 5) then + tdiff = rd_tdiffs(nnsb) + endif + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle read_loop nread=nread+nchanl @@ -445,6 +477,7 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& ! End of satellite read block enddo read_loop + if(allocated(rd_tdiffs)) deallocate(rd_tdiffs) enddo read_msg call closbf(lnbufr) @@ -478,9 +511,10 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& ! Deallocate local arrays deallocate(data_all,nrec) deallocate(hdr,datasev2,datasev1) + if(allocated(subset_num)) deallocate(subset_num) + if(allocated(subset_nnsb)) deallocate(subset_nnsb) ! Deallocate satthin arrays -900 continue call destroygrids ! Print data counts @@ -494,5 +528,57 @@ subroutine read_seviri(mype,val_sev,ithin,rmesh,jsatid,& 'mype,ntest,disterrmax=',mype,ntest,disterrmax ! End of routine - return +! return + + contains + subroutine read_subset_nnsb + implicit none + open(lnbufr,file=infile,form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + call random_seed(size=sdsize) + allocate(randsd(sdsize)) + do i=1,sdsize + randsd(i)=int(gstime,i_kind)+kidsat + end do + call random_seed(put=randsd) + deallocate(randsd) + + nnmsg=0 + irec=0 + read_msg1: do while (ireadmg(lnbufr,subset,idate) >= 0) + irec=irec+1 + if(irec < nrec_start) cycle read_msg1 + nnmsg=nnmsg+1 + enddo read_msg1 + call closbf(lnbufr) + + allocate(subset_num(nnmsg)) + allocate(subset_nnsb(nnmsg)) + subset_num=0 + subset_nnsb=0 + open(lnbufr,file=infile,form='unformatted') + call openbf(lnbufr,'IN',lnbufr) + nnmsg=0 + irec=0 + next=0 + read_msg2: do while (ireadmg(lnbufr,subset,idate) >= 0) + irec=irec+1 + if(irec < nrec_start) cycle read_msg2 + nnmsg=nnmsg+1 + next=next+1 + if(next == npe_sub)next=0 + if(next /= mype_sub)cycle read_msg2 + nnsb=0 + read_loop2: do while (ireadsb(lnbufr) == 0) + nnsb=nnsb+1 + enddo read_loop2 + subset_num(nnmsg)=nnsb + enddo read_msg2 + call closbf(lnbufr) + if (npe_sub > 1 ) then + call mpi_allreduce(subset_num, subset_nnsb, nnmsg,mpi_itype,mpi_sum,mpi_comm_sub,ierror) + else + subset_nnsb = subset_num + endif + end subroutine read_subset_nnsb end subroutine read_seviri diff --git a/src/read_sfcwnd.f90 b/src/gsi/read_sfcwnd.f90 similarity index 100% rename from src/read_sfcwnd.f90 rename to src/gsi/read_sfcwnd.f90 diff --git a/src/read_ssmi.f90 b/src/gsi/read_ssmi.f90 old mode 100644 new mode 100755 similarity index 96% rename from src/read_ssmi.f90 rename to src/gsi/read_ssmi.f90 index 5eaa2457f..82c7c39ae --- a/src/read_ssmi.f90 +++ b/src/gsi/read_ssmi.f90 @@ -54,6 +54,7 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& ! ch6 data has been turned off - only toss if do85GHz is true ! 2015-02-23 Rancic/Thomas - add thin4d to time window logical ! 2015-10-01 guo - consolidate use of ob location (in deg) +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -87,12 +88,14 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & checkob,finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use obsmod, only: bmiss use radinfo, only: iuse_rad,jpch_rad,nusis,nuchan use gridmod, only: diagnostic_reg,regional,rlats,rlons,nlat,nlon,& tll2xy,txy2ll use constants, only: deg2rad,rad2deg,zero,one,two,three,four,r60inv - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use deter_sfc_mod, only: deter_sfc use gsi_nstcouplermod, only: nst_gsi,nstinfo use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter @@ -152,7 +155,6 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& real(r_kind) pred real(r_kind) sstime,tdiff,t4dv real(r_kind) crit1,dist1 - real(r_kind) timedif real(r_kind),allocatable,dimension(:,:):: data_all real(r_kind) disterr,disterrmax,dlon00,dlat00,cdist @@ -178,6 +180,8 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& real(r_kind):: dlon_earth_deg,dlat_earth_deg real(r_kind):: ssmi_def_ang,ssmi_zen_ang ! default and obs SSM/I zenith ang logical do85GHz, ch6, ch7 + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin,it_mesh !************************************************************************** ! Initialize variables @@ -242,8 +246,14 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& do85GHz = .not. assim .or. (ch6.and.ch7) + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Open unit to satellite bufr file open(lnbufr,file=trim(infile),form='unformatted') @@ -367,14 +377,11 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& if(iskip >= nchanl) cycle scan_loop !if all ch for any position is bad, skip flgch = iskip*two !used for thinning priority range 0-14 - if (thin4d) then - crit1 = 0.01_r_kind+ flgch - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 - crit1 = 0.01_r_kind+timedif + flgch - endif ! Map obs to thinning grid - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + crit0 = 0.01_r_kind + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle scan_loop diff --git a/src/read_ssmis.f90 b/src/gsi/read_ssmis.f90 old mode 100644 new mode 100755 similarity index 96% rename from src/read_ssmis.f90 rename to src/gsi/read_ssmis.f90 index e23d69eb3..fc5095dec --- a/src/read_ssmis.f90 +++ b/src/gsi/read_ssmis.f90 @@ -61,6 +61,7 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& ! 2013-01-26 parrish - WCOSS debug compile error--change mype from intent(inout) to intent(in) ! 2014-12-03 derber remove unused variables ! 2015-02-23 Rancic/Thomas - add thin4d to time window logical +! 2018-05-21 j.jin - added time-thinning. Moved the checking of thin4d into satthin.F90. ! ! input argument list: ! mype - mpi task id @@ -95,13 +96,15 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& use kinds, only: r_kind,r_double,i_kind use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, & checkob,finalcheck,score_crit + use satthin, only: radthin_time_info,tdiff2crit + use obsmod, only: time_window_max use radinfo, only: ssmis_method use radinfo, only: iuse_rad,newchn,nusis,jpch_rad,& use_edges,radedge1,radedge2 use gridmod, only: diagnostic_reg,regional,rlats,rlons,nlat,nlon,& tll2xy,txy2ll use constants, only: deg2rad,rad2deg,zero,half,one,two,four,r60inv - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d + use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use calc_fov_conical, only: instrument_init use deter_sfc_mod, only: deter_sfc,deter_sfc_fov use gsi_nstcouplermod, only: nst_gsi,nstinfo @@ -179,7 +182,7 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind) :: sfcr,r07 ! real(r_kind) :: pred - real(r_kind) :: tdiff,timedif,dist1 + real(r_kind) :: tdiff,dist1 ! real(r_kind) :: step,start real(r_kind) :: tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10 real(r_kind) :: zob,tref,dtw,dtc,tz_tr @@ -207,6 +210,7 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind),pointer :: bt_in(:) real(r_kind),pointer :: crit1,rsat,t4dv,solzen,solazi,dlon_earth,dlat_earth,satazi,lza + integer(i_kind),allocatable,target :: it_mesh_save(:) real(r_kind),allocatable,target :: rsat_save(:) real(r_kind),allocatable,target :: t4dv_save(:) real(r_kind),allocatable,target :: dlon_earth_save(:) @@ -220,6 +224,10 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind),allocatable :: relative_time_in_seconds(:) real(r_kind),allocatable :: data_all(:,:) + real(r_kind) :: ptime,timeinflat,crit0 + integer(i_kind) :: ithin_time,n_tbin + integer(i_kind),pointer:: it_mesh => null() + ! For solar zenith/azimuth angles calculation data mlen/31,28,31,30,31,30, & 31,31,30,31,30,31/ @@ -265,8 +273,14 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& end do search if (.not.assim) val_ssmis=zero + call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time) + if( ptime > 0.0_r_kind) then + n_tbin=nint(2*time_window_max/ptime) + else + n_tbin=1 + endif ! Make thinning grids - call makegrids(rmesh,ithin) + call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Set various variables depending on type of data to be read ssmis_uas= obstype == 'ssmis_uas' @@ -364,6 +378,7 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& allocate(dlon_earth_save(maxobs)) allocate(dlat_earth_save(maxobs)) allocate(crit1_save(maxobs)) + allocate(it_mesh_save(maxobs)) allocate(lza_save(maxobs)) allocate(satazi_save(maxobs)) allocate(solzen_save(maxobs)) @@ -392,6 +407,7 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& dlon_earth => dlon_earth_save(iobs) dlat_earth => dlat_earth_save(iobs) crit1 => crit1_save(iobs) + it_mesh => it_mesh_save(iobs) ifov => ifov_save(iobs) ! iscan => iscan_save(iobs) ! iorbn => iorbn_save(iobs) @@ -452,15 +468,10 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& else if(abs(tdiff) > twind+one_minute) cycle read_loop endif - if (thin4d) then -! Give score based on time in the window -! crit1 = 0.01_r_kind+ flgch - crit1 = zero - else - timedif = 6.0_r_kind*abs(tdiff) ! range: 0 to 18 -! crit1 = 0.01_r_kind+timedif + flgch - crit1 = timedif - endif + + crit0 = 0.00_r_kind ! forced to >= 0.01_r_kind in tdiff2crit() + timeinflat=6.0_r_kind + call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) ! Extract obs location, TBB, other information ! BUFR read 3/3 --- read in observation lat/lon @@ -535,6 +546,7 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& dlon_earth_save(1:num_obs) = dlon_earth_save(sorted_index) dlat_earth_save(1:num_obs) = dlat_earth_save(sorted_index) crit1_save(1:num_obs) = crit1_save(sorted_index) + it_mesh_save(1:num_obs) = it_mesh_save(sorted_index) ifov_save(1:num_obs) = ifov_save(sorted_index) ! iscan_save(1:num_obs) = iscan_save(sorted_index) ! iorbn_save(1:num_obs) = iorbn_save(sorted_index) @@ -603,6 +615,7 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& dlon_earth => dlon_earth_save(iobs) dlat_earth => dlat_earth_save(iobs) crit1 => crit1_save(iobs) + it_mesh => it_mesh_save(iobs) ifov => ifov_save(iobs) inode => inode_save(iobs) lza => lza_save(iobs) @@ -645,15 +658,15 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& endif ! Check time window + tdiff=t4dv+(iwinbgn-gstime)*r60inv if (l4dvar.or.l4densvar) then if (t4dvwinlen) cycle obsloop else - tdiff=t4dv+(iwinbgn-gstime)*r60inv if(abs(tdiff) > twind) cycle ObsLoop endif ! Map obs to thinning grid - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) if(.not. iuse)cycle obsloop @@ -791,6 +804,7 @@ subroutine read_ssmis(mype,val_ssmis,ithin,isfcalc,rmesh,jsatid,gstime,& deallocate(dlon_earth_save) deallocate(dlat_earth_save) deallocate(crit1_save) + deallocate(it_mesh_save) deallocate(lza_save) deallocate(satazi_save) deallocate(solzen_save) diff --git a/src/read_tcps.f90 b/src/gsi/read_tcps.f90 similarity index 99% rename from src/read_tcps.f90 rename to src/gsi/read_tcps.f90 index ac188b3fb..d50ab5788 100644 --- a/src/read_tcps.f90 +++ b/src/gsi/read_tcps.f90 @@ -108,7 +108,7 @@ subroutine read_tcps(nread,ndata,nodata,infile,obstype,lunout,sis,nobs) if (stormdattim(i)/=ianldate) then write(6,*) 'READ_TCPS: IGNORE TC_VITALS ENTRY # ',i write(6,*) 'READ_TCPS: MISMATCHED FROM ANALYSIS TIME, OBS / ANL DATES = ',stormdattim(i),ianldate - go to 990 + cycle end if ! Set center and storm id (only used in diagnostic file) @@ -169,8 +169,6 @@ subroutine read_tcps(nread,ndata,nodata,infile,obstype,lunout,sis,nobs) cdata_all(9,ndata)=usage ! usage parameter cdata_all(10,ndata)=rstation_id ! storm name (centerid_stormid) -990 continue - ! End of loop over number of storms end do diff --git a/src/gsi/read_wcpbufr.f90 b/src/gsi/read_wcpbufr.f90 new file mode 100644 index 000000000..7d94e7bd1 --- /dev/null +++ b/src/gsi/read_wcpbufr.f90 @@ -0,0 +1,725 @@ +subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& + prsl_full,nobs,nrec_start) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_wcpbufr: read obs from wcpbufr file +! prgmmr: parrish org: np22 date: 1990-10-07 +! +! abstract: This routine reads retrieved hydrometeor (water content) data in the wcpbufr file. +! Specific observation types read by this routine include: +! solid-water content path and liquid-water content path +! derived from Hurricane GPROF (see Wu et al. 2016, Brown et al. 2016) +! (they are called integrated solid-water content and integrated liquid-water content +! in Wu et al. 2016) +! +! When running the gsi in regional mode, the code only +! retains those observations that fall within the regional +! domain +! +! program history log: +! 2017-12-18 T.-C. Wu - adapted from read_prepbufr + +! input argument list: +! infile - unit from which to read BUFR data +! obstype - observation type to process +! lunout - unit to which to write data for further processing +! prsl_full- 3d pressure on full domain grid +! nrec_start - number of subsets without useful information +! +! output argument list: +! nread - number of type "obstype" observations read +! nodata - number of individual "obstype" observations read +! ndata - number of type "obstype" observations retained for further processing +! twindin - input group time window (hours) +! sis - satellite/instrument/sensor indicator +! nobs - array of observations on each subdomain for each processor +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_single,r_kind,r_double,i_kind + use constants, only: zero,one_tenth,one,deg2rad,half,& + rad2deg,tiny_r_kind,huge_r_kind,huge_i_kind,& + r60inv,r2000 + use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,& + tll2xy,txy2ll, rlats,rlons + use convinfo, only: nconvtype,ctwind, & + ncmiter,ncgroup,ncnumgrp,icuse,ictype,icsubtype,ioctype, & + ithin_conv,rmesh_conv,pmesh_conv + use converr,only: etabl + use obsmod, only: iadate, offtime_data, oberrflg + use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen,thin4d + use convthin, only: make3grids,map3grids,del3grids,use_all + use mpimod, only: npe + + implicit none + +! Declare passed variables + character(len=*) ,intent(in ) :: infile,obstype + character(len=20) ,intent(in ) :: sis + integer(i_kind) ,intent(in ) :: lunout,nrec_start + integer(i_kind) ,intent(inout) :: nread,ndata,nodata + integer(i_kind),dimension(npe) ,intent(inout) :: nobs + real(r_kind) ,intent(in ) :: twindin + real(r_kind),dimension(nlat,nlon,nsig),intent(in ) :: prsl_full + +! Declare local parameters + real(r_kind),parameter:: r6 = 6.0_r_kind + real(r_kind),parameter:: r90 = 90.0_r_kind + real(r_kind),parameter:: r360 = 360.0_r_kind + real(r_kind),parameter:: r1200= 1200.0_r_kind + real(r_kind),parameter:: convert= 1.0e-3_r_kind ! from g m^-2 to kg m^-2 + +! Declare local variables + logical swcpob, lwcpob + logical outside + logical luse,ithinp + logical,allocatable,dimension(:,:):: lmsg ! set true when convinfo entry id found in a message + + character(40) hdstr,qcstr,oestr,levstr,hdstr2 + character(80) obstr + character(10) date + character(8) subset + character(8) c_station_id + character(1) sidchr(8) + + integer(i_kind) ireadmg,ireadsb,icntpnt,icntpnt2,icount,iiout + integer(i_kind) lunin,i,maxobs,nmsgmax,mxtb + integer(i_kind) kk,klon1,klat1,klonp1,klatp1 + integer(i_kind) nc,nx,ntread,itx,ii,ncsave + integer(i_kind) ihh,idd,idate,iret,im,iy,k,levs + integer(i_kind) kx,nreal,nchanl,ilat,ilon,ithin + integer(i_kind) qm, swcpq, lwcpq + integer(i_kind) nlevp ! vertical level for thinning + integer(i_kind) ntmp,iout + integer(i_kind) pflag,irec + integer(i_kind) ntest,nvtest,iosub,ixsub,isubsub,iobsub + integer(i_kind) kl,k1,k2 + integer(i_kind) itypex + integer(i_kind) minobs,minan + integer(i_kind) ntb,ntmatch,ncx + integer(i_kind) nmsg ! message index + integer(i_kind),dimension(5):: idate5 + integer(i_kind),dimension(255):: pqm + integer(i_kind),dimension(nconvtype)::ntxall + integer(i_kind),dimension(nconvtype+1)::ntx + integer(i_kind),allocatable,dimension(:):: isort,iloc,nrep + integer(i_kind),allocatable,dimension(:,:):: tab + real(r_kind) time,timex,timeobs,toff,t4dv,zeps + real(r_kind) rmesh,ediff,usage + real(r_kind) dx,dy,dx1,dy1,w00,w10,w01,w11 + real(r_kind) dlnpob,ppb + real(r_kind) swcpoe, swcpmerr, lwcpoe, lwcpmerr + real(r_kind) dlat,dlon,dlat_earth,dlon_earth + real(r_kind) dlat_earth_deg,dlon_earth_deg + real(r_kind) stnelev + real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00 + real(r_kind) vdisterrmax + real(r_kind) del, swcperrmin, lwcperrmin + real(r_kind) crit1,timedif,xmesh,pmesh + real(r_kind) time_correction + real(r_kind) perrmin + real(r_kind),dimension(nsig):: presl + real(r_kind),dimension(nsig-1):: dpres + real(r_kind),dimension(255)::plevs + real(r_kind),allocatable,dimension(:):: presl_thin + real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out + + real(r_double) rstation_id,qcmark_huge + real(r_double),dimension(8):: hdr + real(r_double),dimension(4,255):: qcmark,obserr + real(r_double),dimension(5,255):: obsdat + real(r_double),dimension(1,255):: levdat + equivalence(rstation_id,c_station_id) + equivalence(rstation_id,sidchr) + +! data statements + data hdstr /'SID XOB YOB DHR TYP ELV SAID T29'/ + data hdstr2 /'TYP SAID T29 SID'/ + data obstr /'POB ZOB CWIO CWLO PRSS' / + data qcstr /'PQM ZQM CWIQ CWLQ '/ + data oestr /'POE NUL CWIE CWLE '/ + data levstr /'POB'/ + + data lunin / 15 / + data ithin / -9 / + data rmesh / -99.999_r_kind / + + +!------------------------------------------------------------------------ +! Initialize variables + + vdisterrmax=zero + pflag=0 ! dparrish debug compile run flags pflag as not defined ??????????? + + swcpob = obstype == 'swcp' + lwcpob = obstype == 'lwcp' + if(swcpob) then + nreal=16 + else if(lwcpob) then + nreal=16 + else + write(6,*) ' illegal obs type in READ_WCPBUFR ',obstype + call stop2(94) + end if + + qcmark_huge = huge_i_kind + + perrmin=0.3_r_kind + swcperrmin=one + lwcperrmin=one + +!------------------------------------------------------------------------ + ntread=1 + ntmatch=0 + ntx(ntread)=0 + ntxall=0 + do nc=1,nconvtype + if(trim(ioctype(nc)) == trim(obstype))then + ntmatch=ntmatch+1 + ntxall(ntmatch)=nc + end if + if(trim(ioctype(nc)) == trim(obstype) .and. abs(icuse(nc)) <= 1)then + ithin=ithin_conv(nc) + if(ithin > 0)then + ntread=ntread+1 + ntx(ntread)=nc + end if + end if + end do + if(ntmatch == 0)then + write(6,*) ' no matching obstype found in obsinfo ',obstype + return + end if + +!! get message and subset counts + + call getcount_bufr(infile,nmsgmax,mxtb) + allocate(lmsg(nmsgmax,ntread),tab(mxtb,3),nrep(nmsgmax)) + + lmsg = .false. + maxobs=0 + tab=0 + nmsg=0 + nrep=0 + ntb = 0 + irec = 0 + +! Open, then read date from bufr data + call closbf(lunin) + open(lunin,file=trim(infile),form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + + msg_report: do while (ireadmg(lunin,subset,idate) == 0) + irec = irec + 1 + if(irec < nrec_start) cycle msg_report + +! Time offset + if(nmsg == 0) call time_4dvar(idate,toff) + nmsg=nmsg+1 + if (nmsg>nmsgmax) then + write(6,*)'READ_WCPBUFR: messages exceed maximum ',nmsgmax + call stop2(50) + endif + loop_report: do while (ireadsb(lunin) == 0) + ntb = ntb+1 + nrep(nmsg)=nrep(nmsg)+1 + if (ntb>mxtb) then + write(6,*)'READ_WCPBUFR: reports exceed maximum ',mxtb + call stop2(50) + endif + +! Extract type information + call ufbint(lunin,hdr,4,1,iret,hdstr2) + kx=hdr(1) + +! temporary specify iobsub until put in bufr file + iobsub = 0 + +! Match ob to proper convinfo type + ncsave=0 + matchloop:do ncx=1,ntmatch + nc=ntxall(ncx) + if (kx /= ictype(nc))cycle + +! Find convtype which match ob type and subtype + if(icsubtype(nc) == iobsub) then + ncsave=nc + exit matchloop + else +! Find convtype which match ob type and subtype group (isubtype == ?*) +! where ? specifies the group and icsubtype = ?0) + ixsub=icsubtype(nc)/10 + iosub=iobsub/10 + isubsub=icsubtype(nc)-ixsub*10 + if(ixsub == iosub .and. isubsub == 0) then + ncsave=nc +! Find convtype which match ob type and subtype is all remaining +! (icsubtype(nc) = 0) + else if (ncsave == 0 .and. icsubtype(nc) == 0) then + ncsave=nc + end if + end if + end do matchloop + +! Save information for next read + if(ncsave /= 0) then + + call ufbint(lunin,levdat,1,255,levs,levstr) + maxobs=maxobs+max(1,levs) + nx=1 + if(ithin_conv(ncsave) > 0)then + do ii=2,ntread + if(ntx(ii) == ncsave)nx=ii + end do + end if + tab(ntb,1)=ncsave + tab(ntb,2)=nx + tab(ntb,3)=levs + lmsg(nmsg,nx) = .true. + end if + + end do loop_report + enddo msg_report + if (nmsg==0) then + write(6,*)'READ_WCPBUFR: no messages/reports ' + call closbf(lunin) + close(lunin) + return + end if + write(6,*)'READ_WCPBUFR: messages/reports = ',nmsg,'/',ntb,' ntread = ',ntread +!------------------------------------------------------------------------ + +! loop over convinfo file entries; operate on matches + + allocate(cdata_all(nreal,maxobs),isort(maxobs)) + isort = 0 + cdata_all=zero + nread=0 + ntest=0 + nvtest=0 + nchanl=0 + ilon=2 + ilat=3 + loop_convinfo: do nx=1, ntread + + use_all = .true. + ithin=0 + if(nx > 1) then + nc=ntx(nx) + ithin=ithin_conv(nc) + if (ithin > 0 ) then + rmesh=rmesh_conv(nc) + pmesh=pmesh_conv(nc) + use_all = .false. + if(pmesh > zero) then + pflag=1 + nlevp=r1200/pmesh + else + pflag=0 + nlevp=nsig + endif + xmesh=rmesh + + call make3grids(xmesh,nlevp) + + if (.not.use_all) then + allocate(presl_thin(nlevp)) + if (pflag==1) then + do k=1,nlevp + presl_thin(k)=(r1200-(k-1)*pmesh)*one_tenth + enddo + endif + endif + + write(6,*)'READ_WCPBUFR: obstype,ictype(nc),rmesh,pflag,nlevp,pmesh=',& + trim(ioctype(nc)),ictype(nc),rmesh,pflag,nlevp,pmesh + endif + endif + + + call closbf(lunin) + open(lunin,file=infile,form='unformatted') + call openbf(lunin,'IN',lunin) + call datelen(10) + +! Big loop over prepbufr file + + ntb = 0 + nmsg = 0 + icntpnt=0 + icntpnt2=0 + disterrmax=-9999.0_r_kind + irec = 0 + loop_msg: do while (ireadmg(lunin,subset,idate)== 0) + irec = irec + 1 + if(irec < nrec_start) cycle loop_msg + + nmsg = nmsg+1 + if(.not.lmsg(nmsg,nx)) then + do i=ntb+1,ntb+nrep(nmsg) + icntpnt2=icntpnt2+tab(i,3) + end do + ntb=ntb+nrep(nmsg) + cycle loop_msg ! no useable reports this mesage, skip ahead report count + end if + + loop_readsb: do while(ireadsb(lunin) == 0) +! use msg lookup table to decide which messages to skip +! use report id lookup table to only process matching reports + ntb = ntb+1 + if(icntpnt < icntpnt2)icntpnt=icntpnt2 + icntpnt2=icntpnt2+tab(ntb,3) + nc=tab(ntb,1) + if(nc <= 0 .or. tab(ntb,2) /= nx) cycle loop_readsb + +! Extract type, date, and location information + call ufbint(lunin,hdr,8,1,iret,hdstr) + kx=hdr(5) + + if(abs(hdr(3))>r90 .or. abs(hdr(2))>r360) cycle loop_readsb + if(hdr(2)== r360)hdr(2)=hdr(2)-r360 + if(hdr(2) < zero)hdr(2)=hdr(2)+r360 + dlon_earth_deg=hdr(2) + dlat_earth_deg=hdr(3) + dlon_earth=hdr(2)*deg2rad + dlat_earth=hdr(3)*deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinate + if(diagnostic_reg) then + call txy2ll(dlon,dlat,rlon00,rlat00) + ntest=ntest+1 + cdist=sin(dlat_earth)*sin(rlat00)+cos(dlat_earth)*cos(rlat00)* & + (sin(dlon_earth)*sin(rlon00)+cos(dlon_earth)*cos(rlon00)) + cdist=max(-one,min(cdist,one)) + disterr=acos(cdist)*rad2deg + disterrmax=max(disterrmax,disterr) + end if + if(outside) cycle loop_readsb ! check to see if outside regional domain + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + +!------------------------------------------------------------------------ + + if(offtime_data) then + +! in time correction for observations to account for analysis +! time being different from obs file time. + write(date,'( i10)') idate + read (date,'(i4,3i2)') iy,im,idd,ihh + idate5(1)=iy + idate5(2)=im + idate5(3)=idd + idate5(4)=ihh + idate5(5)=0 + call w3fs21(idate5,minobs) ! obs ref time in minutes relative to historic date + idate5(1)=iadate(1) + idate5(2)=iadate(2) + idate5(3)=iadate(3) + idate5(4)=iadate(4) + idate5(5)=0 + call w3fs21(idate5,minan) ! analysis ref time in minutes relative to historic date + +! Add obs reference time, then subtract analysis time to get obs time relative to analysis + + time_correction=float(minobs-minan)*r60inv + + else + time_correction=zero + end if + + timeobs=real(real(hdr(4),r_single),r_double) + t4dv=timeobs + toff + zeps=1.0e-8_r_kind + if (t4dv -zeps) t4dv=zero + if (t4dv>winlen.and.t4dvwinlen) cycle loop_readsb ! outside time window + else + if((real(abs(time)) > real(ctwind(nc)) .or. real(abs(time)) > real(twindin)))cycle loop_readsb ! outside time window + endif + + timex=time + +! Extract data information on levels + call ufbint(lunin,obsdat,5,255,levs,obstr) + call ufbint(lunin,qcmark,4,255,levs,qcstr) + call ufbint(lunin,obserr,4,255,levs,oestr) + + if(oberrflg)then + +! Set lower limits for observation errors + swcperrmin=one_tenth + lwcperrmin=one_tenth + do k=1,levs + itypex=kx + ppb=obsdat(1,k) + ppb=max(zero,min(ppb,r2000)) + if(ppb>=etabl(itypex,1,1)) k1=1 + do kl=1,32 + if(ppb>=etabl(itypex,kl+1,1).and.ppb<=etabl(itypex,kl,1)) k1=kl + end do + if(ppb<=etabl(itypex,33,1)) k1=5 + k2=k1+1 + ediff = etabl(itypex,k2,1)-etabl(itypex,k1,1) + if (abs(ediff) > tiny_r_kind) then + del = (ppb-etabl(itypex,k1,1))/ediff + else + del = huge_r_kind + endif + del=max(zero,min(del,one)) + obserr(1,k)=(one-del)*etabl(itypex,k1,5)+del*etabl(itypex,k2,5) + obserr(1,k)=max(obserr(1,k),perrmin) + obserr(3,k)=max(obserr(3,k),swcperrmin) + obserr(4,k)=max(obserr(3,k),lwcperrmin) + enddo + endif ! endif for oberrflg + + nread=nread+1 + +! Set station ID + rstation_id=hdr(1) + +! Loop over levels + do k=1,levs + do i=1,4 + qcmark(i,k) = min(qcmark(i,k),qcmark_huge) + end do + +! if (kx == id_bias_ps) then +! plevs(k)=one_tenth*obsdat(1,k)+conv_bias_ps ! convert mb to cb +! else + plevs(k)=one_tenth*obsdat(1,k) ! convert mb to cb +! endif + pqm(k)=nint(qcmark(1,k)) + end do + + stnelev=hdr(6) + ithin=ithin_conv(nc) + ithinp = ithin > 0 .and. pflag /= 0 + if(levs > 1 .or. ithinp)then +! Interpolate guess pressure profile to observation location + klon1= int(dlon); klat1= int(dlat) + dx = dlon-klon1; dy = dlat-klat1 + dx1 = one-dx; dy1 = one-dy + w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy + + klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) + if (klon1==0) klon1=nlon + klatp1=min(nlat,klat1+1); klonp1=klon1+1 + if (klonp1==nlon+1) klonp1=1 + do kk=1,nsig + presl(kk)=w00*prsl_full(klat1 ,klon1 ,kk) + & + w10*prsl_full(klatp1,klon1 ,kk) + & + w01*prsl_full(klat1 ,klonp1,kk) + & + w11*prsl_full(klatp1,klonp1,kk) + end do + +! Compute depth of guess pressure layersat observation location + if (levs > 1) then + do kk=1,nsig-1 + dpres(kk)=presl(kk)-presl(kk+1) + end do + endif + end if + LOOP_K_LEVS: do k=1,levs + icntpnt=icntpnt+1 + +! Extract quality marks + if(swcpob) then + swcpq=nint(qcmark(3,k)) + qm=swcpq + else if(lwcpob) then + lwcpq=nint(qcmark(4,k)) + qm=lwcpq + end if + +! Check qc marks to see if obs should be processed or skipped + + if(qm > 15 .or. qm < 0) cycle loop_k_levs + +! Special block for data thinning - if requested + if (ithin > 0) then + ntmp=ndata ! counting moved to map3gridS + +! Set data quality index for thinning + if (thin4d) then + timedif = zero + else + timedif=abs(t4dv-toff) + endif + crit1 = timedif/r6+half + + if (pflag==0) then + do kk=1,nsig + presl_thin(kk)=presl(kk) + end do + endif + + call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,& + plevs(k),crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) + + if (.not. luse) then + if(k==levs) then + cycle loop_readsb + else + cycle LOOP_K_LEVS + endif + endif + if(iiout > 0) isort(iiout)=0 + if(ndata > ntmp)then + nodata=nodata+1 + end if + isort(icntpnt)=iout + + else + ndata=ndata+1 + nodata=nodata+1 + iout=ndata + isort(icntpnt)=iout + endif + + if(ndata > maxobs) then + write(6,*)'READ_WCPBUFR: ***WARNING*** ndata > maxobs for ',obstype + ndata = maxobs + end if + +! Set usage variable + usage = zero + + + if(icuse(nc) <= 0)usage=100._r_kind + if(qm == 15 .or. qm == 12 .or. qm == 9)usage=100._r_kind + if(plevs(k) < 0.0001_r_kind) then + write(*,*) 'warning: obs pressure is too small:',kx,k,plevs(k) + cycle + endif + + if(ncnumgrp(nc)>0 )then ! default cross validation on + if(mod(ndata+1,ncnumgrp(nc))== ncgroup(nc)-1)usage=ncmiter(nc) + end if + +! Extract pressure level and quality marks + dlnpob=log(plevs(k)) ! ln(pressure in cb) + +! solid-water content path (Hurricane GPROF: TMI and GMI) + if(swcpob) then + + swcpoe=obserr(3,k)*convert + swcpmerr=swcpoe + cdata_all(1,iout)=swcpoe ! swcp error + cdata_all(2,iout)=dlon ! grid relative longitude + cdata_all(3,iout)=dlat ! grid relative latitude + cdata_all(4,iout)=obsdat(3,k)*convert ! swcp obs + cdata_all(5,iout)=rstation_id ! station id + cdata_all(6,iout)=t4dv ! time + cdata_all(7,iout)=nc ! type + cdata_all(8,iout)=swcpmerr ! swcp max error + cdata_all(9,iout)=swcpq ! quality mark + cdata_all(10,iout)=swcpoe ! original obs error + cdata_all(11,iout)=usage ! usage parameter + cdata_all(12,iout)=dlon_earth_deg ! earth relative longitude (degrees) + cdata_all(13,iout)=dlat_earth_deg ! earth relative latitude (degrees) + cdata_all(14,iout)=stnelev ! station elevation (m) + cdata_all(15,iout)=obsdat(1,k) ! observation pressure (hPa) + cdata_all(16,iout)=obsdat(2,k) ! observation height (m) + +! liquid-water content path (Hurricane GPROF: TMI and GMI) + else if(lwcpob) then + + lwcpoe=obserr(4,k)*convert + lwcpmerr=lwcpoe + cdata_all(1,iout)=lwcpoe ! lwcp error + cdata_all(2,iout)=dlon ! grid relative longitude + cdata_all(3,iout)=dlat ! grid relative latitude + cdata_all(4,iout)=obsdat(4,k)*convert ! lwcp obs + cdata_all(5,iout)=rstation_id ! station id + cdata_all(6,iout)=t4dv ! time + cdata_all(7,iout)=nc ! type + cdata_all(8,iout)=lwcpmerr ! lwcp max error + cdata_all(9,iout)=lwcpq ! quality mark + cdata_all(10,iout)=lwcpoe ! original obs error + cdata_all(11,iout)=usage ! usage parameter + cdata_all(12,iout)=dlon_earth_deg ! earth relative longitude (degrees) + cdata_all(13,iout)=dlat_earth_deg ! earth relative latitude (degrees) + cdata_all(14,iout)=stnelev ! station elevation (m) + cdata_all(15,iout)=obsdat(1,k) ! observation pressure (hPa) + cdata_all(16,iout)=obsdat(2,k) ! observation height (m) + + end if + + end do LOOP_K_LEVS ! End k loop over levs + end do loop_readsb ! End of bufr read loop + enddo loop_msg + +! Close unit to bufr file + call closbf(lunin) + +! Deallocate arrays used for thinning data + if (.not.use_all) then + deallocate(presl_thin) + call del3grids + endif + +! Normal exit + + enddo loop_convinfo! loops over convinfo entry matches + deallocate(lmsg,tab,nrep) + +! Write header record and data to output file for further processing + allocate(iloc(ndata)) + icount=0 + do i=1,maxobs + if(isort(i) > 0)then + icount=icount+1 + iloc(icount)=isort(i) + end if + end do + if(ndata /= icount)then + write(6,*) ' WCPBUFR: mix up in read_wcpbufr ,ndata,icount ',ndata,icount + call stop2(50) + end if + allocate(cdata_out(nreal,ndata)) + do i=1,ndata + itx=iloc(i) + do k=1,nreal + cdata_out(k,i)=cdata_all(k,itx) + end do + end do + deallocate(iloc,isort,cdata_all) + + call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata + write(lunout) cdata_out + + deallocate(cdata_out) + +900 continue + if(diagnostic_reg .and. ntest>0) write(6,*)'READ_WCPBUFR: ',& + 'ntest,disterrmax=',ntest,disterrmax + if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_WCPBUFR: ',& + 'nvtest,vdisterrmax=',ntest,vdisterrmax + + if (ndata == 0) then + call closbf(lunin) + write(6,*)'READ_WCPBUFR: closbf(',lunin,')' + endif + + close(lunin) + +! End of routine + return + +end subroutine read_wcpbufr diff --git a/src/reorg_metar_cloud.f90 b/src/gsi/reorg_metar_cloud.f90 similarity index 100% rename from src/reorg_metar_cloud.f90 rename to src/gsi/reorg_metar_cloud.f90 diff --git a/src/rfdpar.f90 b/src/gsi/rfdpar.f90 similarity index 99% rename from src/rfdpar.f90 rename to src/gsi/rfdpar.f90 index eec55dac1..79fa959bc 100644 --- a/src/rfdpar.f90 +++ b/src/gsi/rfdpar.f90 @@ -591,12 +591,13 @@ subroutine zroots(a,m,roots,polish) do j=2,m x=roots(j) do i=j-1,1,-1 - if(real(roots(i),r_kind)<=real(x,r_kind))go to 10 + if(real(roots(i),r_kind)<=real(x,r_kind))then + roots(i+1)=x + cycle + end if roots(i+1)=roots(i) end do - i=0 -10 continue - roots(i+1)=x + roots(1)=x end do return end subroutine zroots diff --git a/src/rsearch.F90 b/src/gsi/rsearch.F90 similarity index 100% rename from src/rsearch.F90 rename to src/gsi/rsearch.F90 diff --git a/src/rtlnmc_version3.f90 b/src/gsi/rtlnmc_version3.f90 similarity index 100% rename from src/rtlnmc_version3.f90 rename to src/gsi/rtlnmc_version3.f90 diff --git a/src/satthin.F90 b/src/gsi/satthin.F90 similarity index 77% rename from src/satthin.F90 rename to src/gsi/satthin.F90 index 5c72c1cd8..ffd8f561a 100644 --- a/src/satthin.F90 +++ b/src/gsi/satthin.F90 @@ -41,7 +41,11 @@ module satthin ! modify to use isli_anl ! determine sno2 with interpolate, accordingly ! use the modified 2d interpolation (sfc_interpolate to intrp22) - +! 2018-05-21 j.jin - add an option for time-thinning. Check time preference (including thin4d) here. +! +! 2019-07-09 todling - revisit Li''s shuffling of nst init, read and final routines +! 2019-08-08 j.jin - add a comment block for an example of dtype-wise time-thinning +! configuration through an -info file. ! ! Subroutines Included: ! sub makegvals - set up for superob weighting @@ -51,12 +55,16 @@ module satthin ! sub destroygrids - deallocate thinning grid arrays ! sub destroy_sfc - deallocate full horizontal surface arrays ! sub indexx - sort array into ascending order +! sub tdiff2crit - get time preference and time cell id in time-thinning +! sub radthin_time_info - read information for time-thinning. ! ! Usecase destription: ! read_obs --> read_airs, etc +! []_radthin_time_info - read time interval ! []_makegvals - set up for superob weighting ! []_getsfc - create full horizontal fields of surface arrays ! []_makegrids - set up thinning grids +! []_tdiff2crit - get time preference and time cell id in time-thinning ! []_map2tgrid - map observation to location on thinning grid ! []_checkob - intermediate ob checking to see if it should not be used ! []_finalcheck - the final criterion check for sat obs and increments counters @@ -88,6 +96,32 @@ module satthin ! def score_crit - "best" quality obs score in thinning grid box ! def use_all - parameter for turning satellite thinning algorithm off ! +! With new time-thinning mechanism, one can configure time-thinning to be device +! specific through an -info. file, in this form, +! +! > rad_time_thinning_options:: +! > ! ptime: Time interval (hour) for thinning radiance and ozone data. +! > ! It defines the number of time thinning bins (time_window/ptime). +! > ! 0, only one time thinning bin, by default. +! > ! ithin_time: Time preference is given +! > ! 1, (default) at the center time when thin4d=false, or +! > ! observation time is ignored when thin4d=true. ptime must be 0.0; +! > ! 2, at the center of time intervals (suppressing thin4d); +! > ! 3, at the end of time intervals (suppressing thin4d); +! > ! 4, at the beginning, middle, and end of the 1st, 2nd,and 3rd two-hour +! > ! time interval, respectively. ptime must be 2.0 (suppressing thin4d); +! > ! 5, select observations at random time, and ptime must be 0.0 +! > ! (Only applicable to seviri data, May 2018). +! > ! ptime=0.0 and ithin_time=1 by default if the observation type is not listed here. +! > !dtype dplat dsis ptime ithin_time +! > seviri m08 seviri_m08 2.0 4 +! > seviri m09 seviri_m09 2.0 4 +! > seviri m10 seviri_m10 2.0 4 +! > seviri m11 seviri_m11 2.0 4 +! > :: +! +! details through an info file. +! ! attributes: ! language: f90 ! machine: ibm RS/6000 SP @@ -96,6 +130,9 @@ module satthin use kinds, only: r_kind,i_kind,r_quad,r_single use mpeu_util, only: die, perr + use obsmod, only: time_window_max + use constants, only: deg2rad,rearth_equator,zero,two,pi,half,one,& + rad2deg,r1000 implicit none ! set default to private @@ -108,6 +145,8 @@ module satthin public :: destroygrids public :: destroy_sfc public :: indexx + public :: radthin_time_info + public :: tdiff2crit ! set passed variables to public public :: rlat_min,rlon_min,dlat_grid,dlon_grid,superp,super_val1,super_val public :: veg_type_full,soil_type_full,sfc_rough_full,sno_full,sst_full @@ -116,6 +155,7 @@ module satthin public :: checkob,score_crit,itxmax,finalcheck,zs_full_gfs,zs_full integer(i_kind) mlat,superp,maxthin,itxmax + integer(i_kind) itxmax0 integer(i_kind), save:: itx_all integer(i_kind),dimension(0:51):: istart_val @@ -180,6 +220,7 @@ subroutine makegvals use constants, only: deg2rad,rearth_equator,zero,two,pi,half,one,& rad2deg,r1000 use obsmod, only: dmesh,dthin,ndat + use obsmod, only: dtype,dplat,dsis use gridmod, only: regional,nlat,nlon,txy2ll use mpeu_util, only: die implicit none @@ -194,12 +235,27 @@ subroutine makegvals real(r_kind) twopi,dlon_g,dlat_g,dlon_e,dlat_e real(r_kind) factor,delon real(r_kind) rkm2dg,glatm,glatx + integer(i_kind), allocatable, dimension(:) :: n_tbin_m1 + integer(i_kind) :: n_tbin0 + real(r_kind) :: ptime + integer(i_kind) :: ithin_time ! Initialize variables, set constants maxthin=0 do i=1,ndat maxthin=max(maxthin,abs(dthin(i))) end do +! Check if there are any time-thinning + allocate(n_tbin_m1(0:maxthin)) + n_tbin_m1 = 0 + do i=1,ndat + call radthin_time_info( dtype(i), dplat(i), dsis(i), ptime, ithin_time) + if( ptime > 0.0_r_kind ) then + n_tbin0 = nint(2*time_window_max/ptime) - 1 + j=abs(dthin(i)) + n_tbin_m1(j)= max( n_tbin_m1(j), n_tbin0 ) + endif + end do istart_val=0 twopi = two*pi rkm2dg = r360/(twopi*rearth_equator)*r1000 @@ -270,6 +326,8 @@ subroutine makegvals enddo enddo + istart_val(ii+1) = istart_val(ii+1)+ & + (istart_val(ii+1)-istart_val(ii))*n_tbin_m1(ii) end if end do superp=istart_val(maxthin+1) @@ -279,12 +337,13 @@ subroutine makegvals do i=0,superp super_val(i)=zero end do + deallocate(n_tbin_m1) return end subroutine makegvals - subroutine makegrids(rmesh,ithin) + subroutine makegrids(rmesh,ithin,n_tbin) !$$$ subprogram documentation block ! . . . . ! subprogram: makegrids @@ -305,6 +364,7 @@ subroutine makegrids(rmesh,ithin) ! rmesh - mesh size (km) of thinning grid. If (rmesh <= one), ! then no thinning of the data will occur. Instead, ! all data will be used without thinning. +! n_tbin - (optional) number of time intervals. ! ! output argument list: ! @@ -319,6 +379,7 @@ subroutine makegrids(rmesh,ithin) real(r_kind) ,intent(in ) :: rmesh integer(i_kind),intent(in ) :: ithin + integer(i_kind),intent(in ), optional :: n_tbin real(r_kind),parameter:: r360 = 360.0_r_kind integer(i_kind) i,j integer(i_kind) mlonx,mlonj @@ -392,6 +453,10 @@ subroutine makegrids(rmesh,ithin) end do + if (present(n_tbin)) then + itxmax0 = itxmax + itxmax = itxmax0 * n_tbin + endif ! Allocate and initialize arrays allocate(icount(itxmax)) @@ -461,7 +526,7 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) use ncepnems_io, only: read_nemssfc,intrp22,read_nemssfc_anl use sfcio_module, only: sfcio_realfill use obsmod, only: lobserver - use gsi_nstcouplermod, only: nst_gsi,gsi_nstcoupler_init,gsi_nstcoupler_read + use gsi_nstcouplermod, only: nst_gsi,gsi_nstcoupler_read use gsi_nstcouplermod, only: tref_full,dt_cool_full,z_c_full,dt_warm_full,z_w_full,& c_0_full,c_d_full,w_0_full,w_d_full use gsi_metguess_mod, only: gsi_metguess_bundle @@ -503,23 +568,15 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) ! if(mype == 0)write(6,*)'GETSFC: set nlat_sfc,nlon_sfc=',nlat_sfc,nlon_sfc allocate(rlats_sfc(nlat_sfc),rlons_sfc(nlon_sfc)) - allocate(isli_full(nlat_sfc,nlon_sfc),fact10_full(nlat_sfc,nlon_sfc,nfldsfc)) - allocate(sst_full(nlat_sfc,nlon_sfc,nfldsfc),sno_full(nlat_sfc,nlon_sfc,nfldsfc)) - allocate(zs_full(nlat,nlon)) - allocate(sfc_rough_full(nlat_sfc,nlon_sfc,nfldsfc)) allocate(isli_anl(nlat,nlon)) allocate(sno_anl(nlat,nlon,nfldsfc)) - allocate(soil_moi_full(nlat_sfc,nlon_sfc,nfldsfc),soil_temp_full(nlat_sfc,nlon_sfc,nfldsfc)) - allocate(veg_frac_full(nlat_sfc,nlon_sfc,nfldsfc),soil_type_full(nlat_sfc,nlon_sfc)) - allocate(veg_type_full(nlat_sfc,nlon_sfc)) + call create_sfc do j=1,lon1*lat1 zsm(j)=zero end do -! Create full horizontal nst arrays - if (nst_gsi > 0) call gsi_nstcoupler_init() ! Global read #ifndef HAVE_ESMF @@ -545,8 +602,6 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) deallocate(slatx,wlatx) end if - allocate(zs_full_gfs(nlat_sfc,nlon_sfc)) - if ( use_gfs_nemsio ) then if ( sfcnst_comb .and. nst_gsi > 0 ) then @@ -621,6 +676,13 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) end if else ! for regional +#else /* HAVE_ESMF */ +! +! read NSST variables while .not. sfcnst_comb (in sigio or nemsio) +! + if (nst_gsi > 0 .and. .not. sfcnst_comb) then + call gsi_nstcoupler_read(mype_io) ! Read NST fields (each proc needs full NST fields) + endif #endif /* HAVE_ESMF */ it=ntguessfc @@ -866,7 +928,7 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) end subroutine getsfc - subroutine map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) + subroutine map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh) !$$$ subprogram documentation block ! . . . . ! subprogram: map2tgrid @@ -885,6 +947,7 @@ subroutine map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) ! crit1 - quality indicator for observation (smaller = better) ! ithin - number of obs to retain per thinning grid box ! sis - sensor/instrument/satellite +! it_mesh - time meth id ! ! output argument list: ! itx - combined (i,j) index of observation on thinning grid @@ -903,9 +966,11 @@ subroutine map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) logical ,intent( out) :: iuse integer(i_kind),intent(in ) :: ithin integer(i_kind),intent( out) :: itt,itx - real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1 + real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth + real(r_kind) ,intent(inout) :: crit1 real(r_kind) ,intent( out) :: dist1 character(20) ,intent(in ) :: sis + integer(i_kind),intent(in ), optional :: it_mesh integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,dx,dy,dxx,dyy @@ -945,6 +1010,10 @@ subroutine map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) dyy=half-min(dy,one-dy) dist1=dxx*dxx+dyy*dyy+half itx=hll(ix,iy) +! time mesh + if( present(it_mesh) ) then + itx=itx+it_mesh*itxmax0 + endif itt=istart_val(ithin)+itx if(ithin == 0) itt=0 @@ -1091,6 +1160,52 @@ subroutine destroygrids return end subroutine destroygrids + subroutine create_sfc +!$$$ subprogram documentation block +! . . . . +! subprogram: create_sfc +! prgmmr: todling org: np23 date: 2019-07-09 +! +! abstract: This deallocate surface arrays +! +! program history log: +! 2019=07-09 todling +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + use gridmod, only: nlat,nlon,nlat_sfc,nlon_sfc + use guess_grids, only: nfldsfc + use gsi_nstcouplermod, only: nst_gsi,gsi_nstcoupler_init,gsi_nstcoupler_read + implicit none + +#ifndef HAVE_ESMF + allocate(zs_full_gfs(nlat_sfc,nlon_sfc)) +#endif /* HAVE_ESMF */ + allocate(sfc_rough_full(nlat_sfc,nlon_sfc,nfldsfc)) + allocate(zs_full(nlat,nlon)) + allocate(soil_moi_full(nlat_sfc,nlon_sfc,nfldsfc)) + allocate(soil_temp_full(nlat_sfc,nlon_sfc,nfldsfc)) + allocate(veg_frac_full(nlat_sfc,nlon_sfc,nfldsfc)) + allocate(soil_type_full(nlat_sfc,nlon_sfc)) + allocate(veg_type_full(nlat_sfc,nlon_sfc)) + allocate(isli_full(nlat_sfc,nlon_sfc)) + allocate(fact10_full(nlat_sfc,nlon_sfc,nfldsfc)) + allocate(sno_full(nlat_sfc,nlon_sfc,nfldsfc)) + allocate(sst_full(nlat_sfc,nlon_sfc,nfldsfc)) + +! Create full horizontal nst arrays + if (nst_gsi > 0) call gsi_nstcoupler_init() + + return + end subroutine create_sfc + subroutine destroy_sfc !$$$ subprogram documentation block ! . . . . @@ -1111,8 +1226,11 @@ subroutine destroy_sfc ! machine: ibm rs/6000 sp ! !$$$ + use gsi_nstcouplermod, only: nst_gsi,gsi_nstcoupler_final implicit none + if (nst_gsi > 0) call gsi_nstcoupler_final() + if(allocated(sst_full))deallocate(sst_full) if(allocated(sno_full))deallocate(sno_full) if(allocated(fact10_full))deallocate(fact10_full) @@ -1124,7 +1242,9 @@ subroutine destroy_sfc if(allocated(soil_moi_full))deallocate(soil_moi_full) if(allocated(zs_full))deallocate(zs_full) if(allocated(sfc_rough_full))deallocate(sfc_rough_full) +#ifndef HAVE_ESMF if(allocated(zs_full_gfs)) deallocate(zs_full_gfs) +#endif /* HAVE_ESMF */ return end subroutine destroy_sfc @@ -1189,82 +1309,231 @@ subroutine indexx(n,arr,indx) l=1 ir=n -1 continue + loop0: do - if(ir-larr(indx(ir)))then - itemp=indx(l) - indx(l)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l+1))>arr(indx(ir)))then - itemp=indx(l+1) - indx(l+1)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l))>arr(indx(l+1)))then - itemp=indx(l) - indx(l)=indx(l+1) + if(ir-la)goto 4 - if(jarr(indx(ir)))then + itemp=indx(l) + indx(l)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l+1))>arr(indx(ir)))then + itemp=indx(l+1) + indx(l+1)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l))>arr(indx(l+1)))then + itemp=indx(l) + indx(l)=indx(l+1) + indx(l+1)=itemp + endif + i=l+1 + j=ir + indxt=indx(l+1) + a=arr(indxt) + loop1: do + i=i+1 + if(arr(indx(i))nstack)then - write(6,*)'INDEXX: nstack=',nstack,' too small in indexx' - call stop2(32) - endif - if(ir-i+1>=j-l)then - istack(jstack)=ir - istack(jstack-1)=i - ir=j-1 - else - istack(jstack)=j-1 - istack(jstack-1)=l - l=i + indx(l+1)=indx(j) + indx(j)=indxt + jstack=jstack+2 + if(jstack>nstack)then + write(6,*)'INDEXX: nstack=',nstack,' too small in indexx' + call stop2(32) + endif + if(ir-i+1>=j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif endif - endif - goto 1 + end do loop0 #endif end subroutine indexx + subroutine tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) + +!$$$ +! Abstract: Get time preference and time cell id in time-thinning. +! Program history log: +! 2018-05-18 j.jin - initial code. +! +!$$$ +!Inputs +! tdiff - observational time minus gsttime. +! ptime - thinning time interval +! ltin_time - id for time preference +! timeinflat - a factor to inflat time difference. +! crit0 - an added value to crit +!Outputs +! crit1 - thinning crit +! it_mesh - time cell id + + use constants, only: tiny_r_kind + use gsi_4dvar, only: thin4d + implicit none + integer(i_kind),intent(in ) :: ithin_time + real(r_kind) ,intent(in ) :: tdiff,ptime,timeinflat + real(r_kind) ,intent(in ) :: crit0 + real(r_kind) ,intent(out ) :: crit1 + integer(i_kind),intent(out ) :: it_mesh + + real(r_kind) :: crita, critb, ptimeb, crit0_ + + if( ptime > 0.0_r_kind) then + crita=min(tdiff, time_window_max-tiny_r_kind) + it_mesh=int((crita+time_window_max)/ptime) + ptimeb=ptime + else + it_mesh=0 + ptimeb=2*time_window_max + endif + critb=tdiff+time_window_max + + select case (ithin_time) + case (1) + if (thin4d) then + crit1=zero + else + crit1=abs(tdiff) ! .eqv. ithin_time==5 + endif + case (2) + crit1=abs(critb-(it_mesh+0.5_r_kind)*ptimeb) + case (3) + crit1=abs(critb-(it_mesh+1_r_kind)*ptimeb) + case (4) + crit1=abs(critb-it_mesh*time_window_max) + case (5) + crit1=abs(tdiff) ! .eqv. ithin_time==1 .and. .not.thin4d + end select + + crit0_=crit0 + crit0_=max(crit0_, 0.01_r_kind) ! This fixes a problem in some + ! obs-reader code, where a minimum + ! crit0 is set to 0, such that obs + ! thinning is limitted to a first- + ! come-first-serve situation. + crit1=crit0_+crit1*timeinflat + end subroutine tdiff2crit + + subroutine radthin_time_info(obstype, platid, sis, ptime, ithin_time) + +!$$$ +! Abstract: Read time-thinning options for radiance and ozone data. +! Program history log: +! 2018-05-10 j.jin - initial code. +! +!$$$ + +! Inputs +! obstype - observation type to process +! platid - satellite indicator +! sis - satellite_instrument/sensor indicator +! Outputs +! ptime - time interval +! ithin_time - indicator of time preference +! + use kinds, only: r_kind,i_kind + use file_utility, only: get_lun + use mpeu_util, only: gettablesize, gettable, die + + character(len=*),intent(in):: obstype,platid,sis + real(r_kind),intent(out) :: ptime + integer(i_kind),intent(out):: ithin_time + + character(len=*),parameter:: rcname='anavinfo' + character(len=*),parameter:: tbname='rad_time_thinning_options::' + integer(i_kind) luin,ii,ntot, nvars + character(len=256),allocatable,dimension(:):: utable + character(len=20) :: dtype_info, dplat_info, dsis_info + real(r_kind) :: ptime_info + integer(i_kind):: ithin_time_info + + +! default outputs + ptime=0.0_r_kind + ithin_time=1 + +! load file + luin=get_lun() + open(luin,file=rcname,form='formatted') +! Scan file for desired table first +! and get size of table + call gettablesize(tbname,luin,ntot,nvars) + if(nvars<=0) then + close(luin) + return + endif +! Get contents of table + allocate(utable(nvars)) + call gettable(tbname,luin,ntot,nvars,utable) +! release file unit + close(luin) + + do ii=1, nvars + read(utable(ii),*) dtype_info, dplat_info, dsis_info, ptime_info, ithin_time_info + if( obstype == trim(dtype_info) ) then + if( platid == trim(dplat_info) ) then + if( sis == trim(dsis_info) ) then + ptime = ptime_info + ithin_time = ithin_time_info + endif + endif + endif + enddo + deallocate(utable) + +! Check the settings + if( ithin_time == 1 .or. ithin_time == 5 ) then + if( ptime /= 0.0_r_kind ) then + call die("satthin.F90 (subroutine radthin_time_info)", & + "ithin_time=1 or 5 requires ptime=0.0" ) + endif + else if( ithin_time == 4) then + if( ptime /= 2.0_r_kind .or. time_window_max /= 3.0_r_kind ) then + call die("satthin.F90 (subroutine radthin_time_info)", & + "ithin_time=4 requires ptime=2.0 and time_window_max=3.0" ) + endif + endif + + end subroutine radthin_time_info + end module satthin diff --git a/src/gsi/set_crtm_aerosolmod.f90 b/src/gsi/set_crtm_aerosolmod.f90 new file mode 100644 index 000000000..1f91d7b4c --- /dev/null +++ b/src/gsi/set_crtm_aerosolmod.f90 @@ -0,0 +1,218 @@ +module set_crtm_aerosolmod +!$$$ module documentation block +! . . . . +! module: set_crtm_aerosolmod +! prgmmr: todling org: gmao date: 2011-06-01 +! +! abstract: module providing interface to set-crtm-aerosol procedures +! +! program history log: +! 2011-06-01 todling +! 2011-09-20 hclin - separate na and na_crtm for p25 handling +! 2019-03-21 martin - replaced blank subroutine here with that previously +! in stub_set_crtm_aerosol.f90; +! also moved eff rad for dust to size function +! +! subroutines included: +! sub Set_CRTM_Aerosol_ +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none + +private + +public Set_CRTM_Aerosol + +contains + + subroutine Set_CRTM_Aerosol ( km, na, na_crtm, aero_name, aero_conc, rh, aerosol) + +!$$$ subprogram documentation block +! . . . . +! subprogram: Set_CRTM_Aerosol +! prgmmr: hclin org: ncar/mmm date: 2011-09-20 +! +! abstract: Set the CRTM Aerosol object given GOCART aerosol properties. +! +! +! program history log: +! 2011-02-23 da Silva - Initial version, FORTRAN-77 interface for GSI. +! 2011-08-01 Lueken - Replaced F90 with f90 (no machine logic) +! 2011-09-20 HCLin - Coded based on the WRFCHEM implementation of GOCART. +! 2013-11-17 Todling - Brought HCLin implementation into stub - it live +! outside GSI, but to not break DTC usage it's placed +! here temporarily. +! 2019-03-21 Martin - Moved aerosol eff radius for dust to function GOCART_Aerosol_size +! +! input argument list: +! km : number of CRTM levels +! na : number of aerosols +! na_crtm : number of aerosols seen by CRTM +! aero_name : GOCART aerosol names +! aero_conc : aerosol concentration (Kg/m2) +! rh : relative humdity [0,1] +! aerosol : CRTM Aerosol object +! +! output argument list: +! aero_conc : aerosol concentration (Kg/m2) +! aerosol : CRTM Aerosol object +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! USES: + + use kinds, only: i_kind,r_kind + use constants, only: tiny_r_kind + use CRTM_Aerosol_Define, only: CRTM_Aerosol_type + use mpeu_util, only: getindex + use crtm_module, only: SULFATE_AEROSOL,BLACK_CARBON_AEROSOL,ORGANIC_CARBON_AEROSOL,& + DUST_AEROSOL,SEASALT_SSAM_AEROSOL,SEASALT_SSCM1_AEROSOL,SEASALT_SSCM2_AEROSOL,SEASALT_SSCM3_AEROSOL + + implicit none + +! !ARGUMENTS: + + integer(i_kind) , intent(in) :: km ! number of levels + integer(i_kind) , intent(in) :: na ! number of aerosols + integer(i_kind) , intent(in) :: na_crtm ! number of aerosols seen by CRTM + character(len=*), intent(in) :: aero_name(na) ! [na] GOCART aerosol names + real(r_kind), intent(inout) :: aero_conc(km,na) ! [km,na] aerosol concentration (Kg/m2) + real(r_kind), intent(in) :: rh(km) ! [km] relative humdity [0,1] + + type(CRTM_Aerosol_type), intent(inout) :: aerosol(na_crtm)! [na] CRTM Aerosol object + + integer(i_kind) :: i, k + integer(i_kind) :: indx_p25, indx_dust1, indx_dust2, indx_dust3, indx_dust4, indx_dust5 + integer(i_kind) :: indx_bc1, indx_oc1 + + indx_bc1=-1; indx_oc1=-1; indx_dust1=-1; indx_dust2=-1 + indx_dust3=-1; indx_dust4=-1; indx_dust5=-1; indx_p25=-1 + + indx_p25 = getindex(aero_name,'p25') + indx_dust1 = getindex(aero_name,'dust1') + indx_dust2 = getindex(aero_name,'dust2') + indx_dust3 = getindex(aero_name,'dust3') + indx_dust4 = getindex(aero_name,'dust4') + indx_dust5 = getindex(aero_name,'dust5') + indx_bc1 = getindex(aero_name,'bc1') + indx_oc1 = getindex(aero_name,'oc1') + + do i = 1, na + + if ( trim(aero_name(i)) == 'p25' ) cycle + + ! assign aerosol type + select case ( trim(aero_name(i)) ) + case ('sulf') + aerosol(i)%type = SULFATE_AEROSOL + case ('bc1','bc2') + aerosol(i)%type = BLACK_CARBON_AEROSOL + case ('oc1','oc2') + aerosol(i)%type = ORGANIC_CARBON_AEROSOL + case ('dust1','dust2','dust3','dust4','dust5') + aerosol(i)%type = DUST_AEROSOL + case ('seas1') + aerosol(i)%type = SEASALT_SSAM_AEROSOL + case ('seas2') + aerosol(i)%type = SEASALT_SSCM1_AEROSOL + case ('seas3') + aerosol(i)%type = SEASALT_SSCM2_AEROSOL + case ('seas4') + aerosol(i)%type = SEASALT_SSCM3_AEROSOL + end select + + if ( indx_p25 > 0 ) then + ! partition p25 to dust1 and dust2 + if ( i == indx_dust1 ) then + aero_conc(:,i) = aero_conc(:,i)+ 0.78_r_kind*aero_conc(:,indx_p25) + endif + if ( i == indx_dust2 ) then + aero_conc(:,i) = aero_conc(:,i)+ 0.22_r_kind*aero_conc(:,indx_p25) + endif + endif + + ! crtm aerosol structure + do k = 1, km + aerosol(i)%concentration(k) = max(tiny_r_kind, aero_conc(k,i)) + ! calculate effective radius + aerosol(i)%effective_radius(k) & + = GOCART_Aerosol_size(i, aerosol(i)%type, rh(k)) + enddo + + enddo ! na + + contains + + function GOCART_Aerosol_size( kk, itype, & ! Input + eh ) & ! Input in 0-1 + result( R_eff ) ! in micrometer + use crtm_aerosolcoeff, only: AeroC + implicit none +! +! modified from a function provided by Quanhua Liu +! + integer(i_kind) ,intent(in) :: kk, itype + real(r_kind) ,intent(in) :: eh + + integer(i_kind) :: j1,j2,k + real(r_kind) :: h1 + real(r_kind) :: R_eff + + if ( itype==DUST_AEROSOL ) then + if (kk==indx_dust1) then + R_eff = 0.55_r_kind + else if (kk==indx_dust2) then + R_eff = 1.4_r_kind + else if (kk==indx_dust3) then + R_eff = 2.4_r_kind + else if (kk==indx_dust4) then + R_eff = 4.5_r_kind + else if (kk==indx_dust5) then + R_eff = 8.0_r_kind + end if + return + else if ( itype==BLACK_CARBON_AEROSOL .and. kk==indx_bc1 ) then + R_eff = AeroC%Reff(1,itype ) + return + else if ( itype==ORGANIC_CARBON_AEROSOL .and. kk==indx_oc1 ) then + R_eff = AeroC%Reff(1,itype ) + return + endif + + j2 = 0 + if ( eh < AeroC%RH(1) ) then + j1 = 1 + else if ( eh > AeroC%RH(AeroC%n_RH) ) then + j1 = AeroC%n_RH + else + do k = 1, AeroC%n_RH-1 + if ( eh <= AeroC%RH(k+1) .and. eh > AeroC%RH(k) ) then + j1 = k + j2 = k+1 + h1 = (eh-AeroC%RH(k))/(AeroC%RH(k+1)-AeroC%RH(k)) + exit + endif + enddo + endif + + if ( j2 == 0 ) then + R_eff = AeroC%Reff(j1,itype ) + else + R_eff = (1.0_r_kind-h1)*AeroC%Reff(j1,itype ) + h1*AeroC%Reff(j2,itype ) + endif + + return + end function GOCART_Aerosol_size + + end subroutine Set_CRTM_Aerosol + +end module set_crtm_aerosolmod diff --git a/src/set_crtm_cloudmod.f90 b/src/gsi/set_crtm_cloudmod.f90 similarity index 78% rename from src/set_crtm_cloudmod.f90 rename to src/gsi/set_crtm_cloudmod.f90 index 5beb6fbeb..9e54bd73c 100644 --- a/src/set_crtm_cloudmod.f90 +++ b/src/gsi/set_crtm_cloudmod.f90 @@ -9,6 +9,7 @@ module set_crtm_cloudmod ! program history log: ! 2011-06-01 todling ! 2011-11-17 zhu --- merge set_crtm_cloudmod with crtm_cloud +! 2018-05-19 eliu --- add precipiation components (related to GFDL physics) ! ! subroutines included: ! sub Set_CRTM_Cloud @@ -25,7 +26,9 @@ module set_crtm_cloudmod use CRTM_Cloud_Define, only: WATER_CLOUD,ICE_CLOUD,RAIN_CLOUD, & SNOW_CLOUD,GRAUPEL_CLOUD,HAIL_CLOUD use mpeu_util, only: die - + use mpimod, only: mype + use radiance_mod, only: cw_cv + use ncepnems_io, only: imp_physics implicit none private @@ -33,7 +36,7 @@ module set_crtm_cloudmod CONTAINS - subroutine Set_CRTM_Cloud ( km, nac, cloud_name, icmask, nc, cloud_cont, cloud_efr,jcloud, dp, tp, pr, qh, cloud) + subroutine Set_CRTM_Cloud ( km, nac, cloud_name, icmask, nc, cloud_cont, cloud_efr,jcloud, dp, tp, pr, qh, cloud, lprecip) implicit none @@ -41,6 +44,7 @@ subroutine Set_CRTM_Cloud ( km, nac, cloud_name, icmask, nc, cloud_cont, cloud_e integer(i_kind) , intent(in) :: nac ! number of actual clouds character(len=*), intent(in) :: cloud_name(nac) ! [nac] Model cloud names: qi, ql, etc. logical, intent(in) :: icmask ! mask determining where to consider clouds + logical, intent(in) :: lprecip ! mask determining where to consider clouds integer(i_kind), intent(in) :: nc ! number of clouds integer(i_kind), intent(in) :: jcloud(nc) ! cloud index real(r_kind), intent(in) :: cloud_cont(km,nc) ! cloud content @@ -52,12 +56,12 @@ subroutine Set_CRTM_Cloud ( km, nac, cloud_name, icmask, nc, cloud_cont, cloud_e type(CRTM_Cloud_type), intent(inout) :: cloud(nc) ! [nc] CRTM Cloud object - call setCloud (cloud_name, icmask, cloud_cont, cloud_efr, jcloud, dp, tp, pr, qh, cloud) + call setCloud (cloud_name, icmask, cloud_cont, cloud_efr, jcloud, dp, tp, pr, qh, cloud, lprecip) end subroutine Set_CRTM_Cloud - subroutine setCloud (cloud_name, icmask, cloud_cont, cloud_efr,jcloud, dp, tp, pr, qh, cloud) + subroutine setCloud (cloud_name, icmask, cloud_cont, cloud_efr,jcloud, dp, tp, pr, qh, cloud, lprecip) use gridmod, only: regional,wrf_mass_regional use wrf_params_mod, only: cold_start @@ -67,6 +71,7 @@ subroutine setCloud (cloud_name, icmask, cloud_cont, cloud_efr,jcloud, dp, tp, p character(len=*), intent(in) :: cloud_name(:) ! [nc] Model cloud names: Water, Ice, etc. logical, intent(in) :: icmask ! mask for where to consider clouds + logical, intent(in) :: lprecip ! mask for where to consider clouds integer(i_kind), intent(in) :: jcloud(:) ! cloud order real(r_kind), intent(in) :: cloud_cont(:,:) ! [km,nc] cloud contents (kg/m2) real(r_kind), intent(in) :: cloud_efr (:,:) ! [km,nc] cloud effective radius (microns) @@ -98,8 +103,11 @@ subroutine setCloud (cloud_name, icmask, cloud_cont, cloud_efr,jcloud, dp, tp, p ! Handle hand-split case as particular case ! ----------------------------------------- - if (cold_start .or. (na /= nc .and. (.not. regional))) then + if (lprecip) cold_start=.false. + +! if (cold_start .or. (na /= nc .and. (.not. regional))) then + if (cold_start .or. cw_cv) then ! Initialize Loop over clouds ... do n = 1, nc Cloud(n)%Type = CloudType_(cloud_name(jcloud(n))) @@ -122,6 +130,7 @@ subroutine setCloud (cloud_name, icmask, cloud_cont, cloud_efr,jcloud, dp, tp, p do k=1,km ! liquid water cloud drop size tem4=max(zero,(t0c-tp(k))*r0_05) + if (cloud(1)%water_content(k) > 1.0e-6_r_kind) & cloud(1)%effective_radius(k) = five + five * min(one, tem4) ! ice water cloud particle size @@ -130,15 +139,17 @@ subroutine setCloud (cloud_name, icmask, cloud_cont, cloud_efr,jcloud, dp, tp, p tem3 = tem1 * cloud(2)%water_content(k) * (pr(k)/dp(k)) & /tp(k) * (one + fv * qh(k)) - if (tem2 < -50.0_r_kind ) then - cloud(2)%effective_radius(k) = (1250._r_kind/9.917_r_kind)*tem3**0.109_r_kind - elseif (tem2 < -40.0_r_kind ) then - cloud(2)%effective_radius(k) = (1250._r_kind/9.337_r_kind)*tem3**0.08_r_kind - elseif (tem2 < -30.0_r_kind ) then - cloud(2)%effective_radius(k) = (1250._r_kind/9.208_r_kind)*tem3**0.055_r_kind - else - cloud(2)%effective_radius(k) = (1250._r_kind/9.387_r_kind)*tem3**0.031_r_kind - endif + if (cloud(2)%water_content(k) > 1.0e-6_r_kind) then + if (tem2 < -50.0_r_kind ) then + cloud(2)%effective_radius(k) = (1250._r_kind/9.917_r_kind)*tem3**0.109_r_kind + elseif (tem2 < -40.0_r_kind ) then + cloud(2)%effective_radius(k) = (1250._r_kind/9.337_r_kind)*tem3**0.08_r_kind + elseif (tem2 < -30.0_r_kind ) then + cloud(2)%effective_radius(k) = (1250._r_kind/9.208_r_kind)*tem3**0.055_r_kind + else + cloud(2)%effective_radius(k) = (1250._r_kind/9.387_r_kind)*tem3**0.031_r_kind + endif + endif cloud(1)%effective_radius(k)=max(zero, cloud(1)%effective_radius(k)) cloud(2)%effective_radius(k)=max(zero, cloud(2)%effective_radius(k)) @@ -155,7 +166,6 @@ subroutine setCloud (cloud_name, icmask, cloud_cont, cloud_efr,jcloud, dp, tp, p endif else ! Handle general case with arbitray number of clouds ! -------------------------------------------------- - ! Loop over clouds ... ! -------------------- do n = 1, nc @@ -176,7 +186,15 @@ subroutine setCloud (cloud_name, icmask, cloud_cont, cloud_efr,jcloud, dp, tp, p if (regional .and. (.not. wrf_mass_regional)) then cloud(n)%Effective_Radius(:) = cloud_efr(:,n) else - cloud(n)%Effective_Radius(:) = EftSize_(cloud_name(jcloud(n))) + !cloud(n)%Effective_Radius(:) = EftSize_(cloud_name(jcloud(n))) + if ( imp_physics==11 .and. lprecip ) then + cloud(n)%Effective_Radius(:) = cloud_efr(:,n) + else + do k = 1, km + if (cloud(n)%water_content(k) > 1.0e-6_r_kind) & + cloud(n)%Effective_Radius(k) = EftSize_(cloud_name(jcloud(n))) + enddo + end if end if else cloud(n)%Effective_Radius(:) = zero @@ -185,7 +203,7 @@ subroutine setCloud (cloud_name, icmask, cloud_cont, cloud_efr,jcloud, dp, tp, p enddo - endif + endif end subroutine setCloud function CloudType_(name) Result(ctype) @@ -212,8 +230,8 @@ function CloudType_(name) Result(ctype) end function CloudType_ - function EftSize_(name) Result(csize) - character(len=*), parameter :: myname = 'EftSize_' + function EftSize_(name) Result(csize) + character(len=*), parameter :: myname = 'EftSize_' character(len=*) :: name ! Model cloud name real(r_kind) :: csize ! CRTM cloud type @@ -223,7 +241,8 @@ function EftSize_(name) Result(csize) else if ( trim(name) == 'qi' ) then csize = 30.0_r_kind else if ( trim(name) == 'qh' ) then - csize = zero ! RT: can somebody fill this in? + ! csize = zero ! RT: can somebody fill this in? + csize = 1000.0_r_kind else if ( trim(name) == 'qg' ) then csize = 600.0_r_kind else if ( trim(name) == 'qr' ) then @@ -235,6 +254,6 @@ function EftSize_(name) Result(csize) call die(myname,"cannot recognize cloud name <"//trim(name)//">") end if - end function EftSize_ + end function EftSize_ end module set_crtm_cloudmod diff --git a/src/gsi/setupaod.f90 b/src/gsi/setupaod.f90 new file mode 100644 index 000000000..a3041fa45 --- /dev/null +++ b/src/gsi/setupaod.f90 @@ -0,0 +1,934 @@ +module aero_setup + implicit none + private + public:: setup + interface setup; module procedure setupaod; end interface + +contains +subroutine setupaod(obsLL,odiagLL,lunin,mype,nchanl,nreal,nobs,& + obstype,isis,is,aero_diagsave,init_pass) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupaod compute rhs of oi equation for aod +! prgmmr: hclin org: ncar/mmm date: 2010-10-20 +! +! abstract: read in data, first guess, and obtain rhs of oi equation +! for aod. +! +! program history log: +! 2010-10-20 hclin - modified from setuprad for aod +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2015-09-10 zhu - generalize enabling all-sky and aerosol usage in radiance +! assimilation. Use radiance_obstype_search & type extentions +! 2016-02-20 pagowski - added NASA nnr AOD +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-05-19 eliu - updated crtm interface +! 2019-03-20 martin - added VIIRS AOD and ncdiag (from S-W Wei and M. Pagowski) +! +! input argument list: +! lunin - unit from which to read radiance (brightness temperature, tb) obs +! mype - mpi task id +! nchanl - number of channels per obs +! nreal - number of pieces of non-tb information per obs +! nobs - number of tb observations to process +! obstype - type of tb observation +! isis - sensor/instrument/satellite id ex.amsua_n15 +! is - integer counter for number of observation types to process +! aero_diagsave - logical to switch on diagnostic output (.false.=no output) +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + use radinfo, only: nsigradjac + use aeroinfo, only: nsigaerojac + use crtm_interface, only: init_crtm,call_crtm,destroy_crtm,sensorindex, & + isatid,itime,ilon,ilat,iszen_ang,isazi_ang + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,i_kind + use crtm_spccoeff, only: sc + use obsmod, only: ianldate,mype_diaghdr,nchan_total, & + dplat,lobsdiagsave,lobsdiag_allocated,& + dirname,time_offset,luse_obsdiag + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d, nc_diag_chaninfo_dim_set, nc_diag_chaninfo + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin + use gridmod, only: nsig,get_ij + use constants, only: tiny_r_kind,zero,one,three,r10,max_varname_length + use jfunc, only: jiter,miter + use m_dtime, only: dtime_setup, dtime_check + use chemmod, only: laeroana_gocart, l_aoderr_table + use aeroinfo, only: jpch_aero, nusis_aero, nuchan_aero, iuse_aero, & + error_aero, gross_aero + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use m_obsNode, only: obsNode + use m_aeroNode, only: aeroNode_appendto + use m_obsLList, only: obsLList + use m_aeroNode, only: aeroNode, aeroNode_typecast + use m_obsLList, only: obsLList_appendNode + use m_obsLlist, only: obsLList_tailNode + use obsmod, only: rmiss_single, netcdf_diag, binary_diag + use qcmod, only: ifail_crtm_qc + use radiance_mod, only: rad_obs_type,radiance_obstype_search + use radiance_mod, only: n_aerosols_fwd + use guess_grids, only: ntguessig,nfldsig + use gsi_chemguess_mod, only: gsi_chemguess_get + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + logical ,intent(in ) :: aero_diagsave + character(10) ,intent(in ) :: obstype + character(20) ,intent(in ) :: isis + integer(i_kind) ,intent(in ) :: lunin,mype,nchanl,nreal,nobs,is + logical ,intent(in ) :: init_pass ! state of "setup" processing + +! Declare external calls for code analysis + external:: stop2 + +! Declare local parameters + integer(i_kind),parameter:: ipchan=4 + integer(i_kind),parameter:: ireal=5 + integer(i_kind),parameter:: iversion_aerodiag=1 + + real(r_kind),parameter:: r1e10=1.0e10_r_kind + +! Declare local variables + character(128) diag_aero_file,guess_aero_file + integer(i_kind) :: nvars + + integer(i_kind) error_status + integer(i_kind) m,jc + integer(i_kind) icc + integer(i_kind) j,k,ncnt,i + integer(i_kind) mm1 + integer(i_kind) n,ibin,ioff,ioff0,iii + integer(i_kind) ii,jj,idiag + + real(r_single) freq4,pol4,wave4,varch4 + real(r_kind) errinv,useflag + real(r_kind) trop5,pangs + real(r_kind) cenlon,cenlat,slats,slons,dtime + real(r_kind) val_obs + +! Declare local arrays + + real(r_single),dimension(ireal):: diagbuf + real(r_single),allocatable,dimension(:,:):: diagbufchan + + real(r_kind),dimension(nchanl):: varinv,error0 + real(r_kind),dimension(nchanl):: tnoise,errmax + real(r_kind),dimension(nchanl):: var,ratio_aoderr,aodinv + real(r_kind),dimension(nreal+nchanl,nobs)::data_s + real(r_kind),dimension(nsig):: prsltmp + real(r_kind),dimension(nsig):: qsat,rh + real(r_kind),dimension(nsig):: qvp,tvp + real(r_kind),dimension(nsig+1):: prsitmp + real(r_kind) :: psfc + real(r_kind) dtsavg + + integer(i_kind),dimension(nchanl):: ich,id_qc + + real(r_kind), dimension(:,:), allocatable :: aerosols + character(len=max_varname_length), dimension(:), allocatable :: & + &aerosol_names + character(len=56), dimension(:), allocatable :: varnames + + + logical toss,l_may_be_passive + logical,dimension(nobs):: luse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + integer(i_kind):: nperobs ! No. of data points, in channels, levels, or components, per obs. + + logical:: in_curbin, in_anybin + type(aeroNode),pointer:: my_head + type(obs_diag),pointer:: my_diag, obsptr + type(obs_diags),pointer:: my_diagLL + type(rad_obs_type) :: radmod + character(len=*),parameter:: myname="setupaod" + + real(r_kind), dimension(nchanl) :: total_aod, aod_obs, aod + + integer(i_kind), parameter :: n_viirs_550nm=4 + integer(i_kind) :: istyp, idbcf, ilone, ilate + integer(i_kind) :: iqcall, ismask, nestat, istat + real(r_kind) :: qcall, smask + real(r_kind) :: styp, dbcf + + real(r_kind),dimension(nchanl):: emissivity,ts,emissivity_k + real(r_kind),dimension(nchanl):: tsim + real(r_kind),dimension(nsig,nchanl):: wmix,temp,ptau5 + real(r_kind),dimension(nsigradjac,nchanl):: jacobian + real(r_kind),dimension(nsigaerojac,nchanl):: jacobian_aero + real(r_kind),dimension(nsig,nchanl):: layer_od + real(r_kind) :: clw_guess, tzbgr, sfc_speed,ciw_guess,rain_guess,snow_guess + + type(obsLList),pointer,dimension(:):: aerohead + aerohead => obsLL(:) + + + if ( .not. laeroana_gocart ) then + return + endif + +!************************************************************************************** +! Initialize variables and constants. + mm1 = mype+1 + ncnt = 0 + icc = 0 + + isatid = 1 ! index of satellite id + itime = 2 ! index of analysis relative obs time + ilon = 3 ! index of grid relative obs location (x) + ilat = 4 ! index of grid relative obs location (y) + ilone = 5 ! index of earth relative longitude (degrees) + ilate = 6 ! index of earth relative latitude (degrees) + iszen_ang = 8 ! index of solar zenith angle (degrees) + isazi_ang = 9 ! index of solar azimuth angle (degrees) + istyp = 10 ! index of surface type + idbcf = 11 ! index of deep blue confidence flag + + if ( obstype == 'viirs_aod' .or. obstype == 'modis_aod' ) then + iqcall = 7 ! index of overall quality flag for AOD + ismask = 10 ! index of surface type mask + else ! obstype /= 'modis_aod' or 'viirs_aod' + write(6,*)'SETUP_AOD: *** WARNING: unknown aerosol input type, obstype=',obstype + end if + + +! Determine cloud & aerosol usages in radiance assimilation + call radiance_obstype_search(obstype,radmod) + +! Initialize channel related information + tnoise = r1e10 + errmax = r1e10 + l_may_be_passive = .false. + toss = .true. + jc=0 + + do j=1,jpch_aero + if(isis == nusis_aero(j))then + jc=jc+1 + if(jc > nchanl)then + write(6,*)'setupaod: ***ERROR*** in channel numbers, jc,nchanl=',jc,nchanl,& + ' ***STOP IN setupaod***' + call stop2(71) + end if + +! Load channel numbers into local array based on satellite type + + ich(jc)=j +! +! Set error instrument channels + tnoise(jc)=error_aero(j) + errmax(jc)=gross_aero(j) + if (iuse_aero(j)< -1 .or. (iuse_aero(j) == -1 .and. & + .not.aero_diagsave)) tnoise(jc)=r1e10 + if (iuse_aero(j)>-1) l_may_be_passive=.true. + if (tnoise(jc) < 1.e4_r_kind) toss = .false. + end if + end do + if ( mype == 0 .and. .not.l_may_be_passive) write(6,*)mype,'setupaod: passive obs',is,isis + if(nchanl > jc) write(6,*)'setupaod: channel number reduced for ', & + obstype,nchanl,' --> ',jc + if(jc == 0) then + if(mype == 0) write(6,*)'setupaod: No channels found for ', & + obstype,isis + if(nobs > 0)read(lunin) + return + end if + if (toss) then + if(mype == 0)write(6,*)'setupaod: all obs var > 1e4. do not use ',& + 'data from satellite is=',isis + if(nobs >0)read(lunin) + return + endif + + ioff0=0 + if (lobsdiagsave) then + if (l_may_be_passive) then + ioff0=4 + else + ioff0=5 + endif + endif + +! Initialize radiative transfer + call init_crtm(init_pass,mype_diaghdr(is),mype,nchanl,nreal,isis,obstype,radmod) + +! If diagnostic file requested, allocate arrays and init output file + if (aero_diagsave) then + allocate(aerosols(nsig,n_aerosols_fwd),aerosol_names(n_aerosols_fwd)) + nvars=5+n_aerosols_fwd + allocate(varnames(nvars)) + + call gsi_chemguess_get('aerosols::3d',aerosol_names,istat) + + varnames(1:5) = (/'air_temperature ','humidity_mixing_ratio', & + 'relative_humidity ','air_pressure ','air_pressure_levels '/) + varnames(6:) = aerosol_names + + if (binary_diag) call init_binary_diag_ + if (netcdf_diag) call init_netcdf_diag_ + end if + + + idiag=ipchan + if (lobsdiagsave) idiag=idiag+4*miter+1 + allocate(diagbufchan(idiag,nchanl)) + +! Load data array for current satellite + read(lunin) data_s,luse,ioid + + write(*,*) 'read in AOD data ',nobs +! Loop over data in this block + call dtime_setup() + do n = 1,nobs +! Extract analysis relative observation time. + dtime = data_s(itime,n) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + + id_qc = 0 + +! Extract lon and lat. + slons = data_s(ilon,n) ! grid relative longitude + slats = data_s(ilat,n) ! grid relative latitude + cenlon = data_s(ilone,n) ! earth relative longitude (degrees) + cenlat = data_s(ilate,n) ! earth relative latitude (degrees) + pangs = data_s(iszen_ang,n) + + if ( obstype == 'modis_aod' ) then + styp = data_s(istyp,n) + dbcf = data_s(idbcf,n) + else if ( obstype == 'viirs_aod' ) then + qcall = data_s(iqcall,n) + smask = data_s(ismask,n) + end if + +! Set relative weight value + val_obs=one + +! Load channel data into work array. + aod_obs = rmiss_single + do i = 1, nchanl +! fix channel issue for VIIRS except channel 4 + if (obstype == 'viirs_aod' .and. i /= n_viirs_550nm) cycle + aod_obs(i) = data_s(i+nreal,n) + end do + + if ( .not. l_aoderr_table ) then +! set observation error + if ( obstype == 'modis_aod' ) then + select case ( nint(styp) ) + case ( 0 ) ! water + tnoise = 0.03_r_kind+0.05_r_kind*aod_obs + case ( 1, 2, 3 ) ! coast, desert, land + tnoise = 0.05_r_kind+0.15_r_kind*aod_obs + case ( 4 ) ! deep blue + if ( nint(dbcf) >= 0 .and. nint(dbcf) <= 3 ) then + tnoise = 0.05_r_kind+0.15_r_kind*aod_obs+0.01_r_kind*(three-dbcf) + end if + case ( 5 ) ! nnr ocean + tnoise = 0.2_r_kind*(aod_obs+0.01_r_kind) + case ( 6 ) ! nnr land + tnoise = 0.2_r_kind*(aod_obs+0.01_r_kind) + end select + else if ( obstype == 'viirs_aod' ) then + nestat = nint(qcall)+nint(smask)*10 + select case (nestat) + case( 2 ) ! over water surface, medium-quality + tnoise = 0.0416146_r_kind+0.0808841_r_kind*aod_obs + case( 3 ) ! over water surface, high quality + tnoise = 0.00784394_r_kind+0.219923_r_kind*aod_obs + case( 12 ) ! over dark land surface, medium-quality + tnoise = 0.0374849_r_kind+0.266073_r_kind*aod_obs + case( 13 ) ! over dark land surface, high quality + tnoise = 0.111431_r_kind+0.128699_r_kind*aod_obs + case( 22 ) ! over bright land surface, medium-quality + tnoise = 0.0693246_r_kind+0.270070_r_kind*aod_obs + case( 23 ) ! over bright land surface, high quality + tnoise = 0.0550472_r_kind+ 0.299558_r_kind*aod_obs + end select + else + if (mype == 0) then + write(6,*),'unknown obstype = ',obstype + call stop2(283) + end if + end if ! end if obstype + end if ! end if not l_aoderr_table + +! Interpolate model fields to observation location, call crtm and create jacobians + call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & + tvp,qvp,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & + trop5,tzbgr,dtsavg,sfc_speed, & + tsim,emissivity,ptau5,ts,emissivity_k, & + temp,wmix,jacobian,error_status,layer_od=layer_od,jacobian_aero=jacobian_aero) + ! interpolate aerosols at observation locations for diag files here + if (aero_diagsave) then + call genqsat(qsat,tvp,prsltmp,1,1,nsig,.true.,0) + rh = qvp/qsat + call aero_guess_at_obs_locations(dtime,data_s(:,n),& + nchanl,nreal,nsig, n_aerosols_fwd, aerosols, aerosol_names) + end if + + +! If the CRTM returns an error flag, do not assimilate any channels for this ob +! and set the QC flag to ifail_crtm_qc. +! We currently go through the rest of the QC steps, ensuring that the diagnostic +! files are populated, but this could be changed if it causes problems. + if (error_status /=0) then + id_qc(1:nchanl) = ifail_crtm_qc + varinv(1:nchanl) = zero + endif + + total_aod = zero + do i = 1, nchanl + total_aod(i) =sum(layer_od(:,i)) + enddo + + do i = 1, nchanl + aod(i) = aod_obs(i) - total_aod(i) + error0(i) = tnoise(i) + if(aod_obs(i)>zero .and. tnoise(i) < 1.e4_r_kind .or. (iuse_aero(ich(i))==-1 & + .and. aero_diagsave))then + varinv(i) = val_obs/tnoise(i)**2 + else + if(id_qc(i) == 0)id_qc(i)=1 + varinv(i) = zero + endif + end do + + icc = 0 + do i = 1, nchanl + ! Only process observations to be assimilated + if (varinv(i) > tiny_r_kind ) then + m = ich(i) + ! Only "good" obs are included in J calculation. + if (iuse_aero(m) >= 1)then + icc = icc + 1 + aodinv(icc) = aod(i) ! obs-ges innovation + var(icc) = one/error0(i)**2 ! 1/(obs error)**2 (original uninflated error) + ratio_aoderr(icc)=error0(i)**2*varinv(i) ! (original error)/(inflated error) + endif + endif + end do + endif ! (in_curbin) + +! In principle, we want ALL obs in the diagnostics structure but for +! passive obs (monitoring), it is difficult to do if aero_diagsave +! is not on in the first outer loop. For now we use l_may_be_passive... + if (l_may_be_passive) then +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + if (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + + if (in_curbin) then +! Load data into output arrays + if (icc > 0) then + ncnt =ncnt+1 + nchan_total=nchan_total+icc + + allocate(my_head) + call aeroNode_appendto(my_head,aerohead(ibin)) + + my_head%idv = is + my_head%iob = ioid(n) + my_head%elat= data_s(ilate,n) + my_head%elon= data_s(ilone,n) + + allocate(my_head%res(icc),my_head%err2(icc), & + my_head%raterr2(icc), & + my_head%daod_dvar(nsigaerojac,icc), & + my_head%ich(icc),& + my_head%icx(icc)) + if(luse_obsdiag)allocate (my_head%diags(icc)) + + my_head%nlaero = icc ! profile observation count + call get_ij(mm1,slats,slons,my_head%ij,my_head%wij) + + my_head%time=dtime + my_head%luse=luse(n) + my_head%ich(:)=-1 + + iii=0 + do ii=1,nchanl + m=ich(ii) + if (varinv(ii)>tiny_r_kind .and. iuse_aero(m)>=1) then + iii=iii+1 + my_head%res(iii)=aodinv(iii) + my_head%err2(iii)=var(iii) + my_head%raterr2(iii)=ratio_aoderr(iii) + my_head%icx(iii)=m + do k = 1, nsigaerojac + my_head%daod_dvar(k,iii)=jacobian_aero(k,ii) + end do + my_head%ich(iii)=ii + end if + end do + + my_head => null() + end if ! icc + endif ! (in_curbin) + +! Link obs to diagnostics structure + if(luse_obsdiag) then + iii=0 + obsptr => null() + do ii=1,nchanl + nperobs=-99999; if(ii==1) nperobs=nchanl + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(n) ,& + ich = ii ,& + elat = data_s(ilate,n) ,& + elon = data_s(ilone,n) ,& + luse = luse(n) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname,'not associated(my_diag)') + + if (ii==1) obsptr => my_diag ! this is the lead node + + if (in_curbin.and.icc>0) then + my_head => tailNode_typecast_(aerohead(ibin)) + if(.not.associated(my_head)) & + call die(myname,'unexpected, associated(my_head) =',associated(my_head)) + + call obsdiagNode_set(my_diag, wgtjo=varinv(ii), jiter=jiter, nldepart=aod(ii) ) + +! Load data into output arrays + m=ich(ii) + if (varinv(ii)>tiny_r_kind .and. iuse_aero(m)>=1) then + iii=iii+1 + + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,my_head%ich(iii),myname,'my_diag:my_head error') + + call obsdiagNode_set(my_diag, jiter=jiter, muse=.true.) + + my_head%diags(iii)%ptr => my_diag + endif + + my_head => null() + endif ! (in_curbin) + enddo ! do ii=1,nchanl + if (in_curbin) then + if( iii/=icc ) then + write(6,*)'setupaod: error iii icc',iii,icc + call stop2(279) + endif + endif ! (in_curbin) + endif ! (luse_obsdiag) + +! End of l_may_be_passive block + endif + + if(in_curbin) then +! Write diagnostics to output file. + if (aero_diagsave .and. luse(n)) then + diagbuf(1) = cenlat ! observation latitude (degrees) + diagbuf(2) = cenlon ! observation longitude (degrees) + diagbuf(3) = dtime-time_offset ! observation time (hours relative to analysis time) + diagbuf(4) = pangs ! solar zenith angle (degrees) + diagbuf(5) = data_s(isazi_ang,n) ! solar azimuth angle (degrees) + + do i=1,nchanl + diagbufchan(1,i)=aod_obs(i) ! observed brightness temperature (K) +! diagbufchan(2,i)=total_aod(i) ! observed - simulated Tb with no bias corrrection (K) - this should be innovation + diagbufchan(2,i)=aod(i) ! innovation + errinv = sqrt(varinv(i)) + diagbufchan(3,i)=errinv ! inverse observation error + useflag=one + if (iuse_aero(ich(i)) < 1) useflag=-one + diagbufchan(4,i)= id_qc(i)*useflag! quality control mark or event indicator + end do + + if (lobsdiagsave) then + if (l_may_be_passive) then + do ii=1,nchanl + if (.not.associated(obsptr)) then + write(6,*)'setupaod: error obsptr' + call stop2(280) + end if + + ioff=ioff0 + do jj=1,miter + ioff=ioff+1 + if (obsptr%muse(jj)) then + diagbufchan(ioff,ii) = one + else + diagbufchan(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + diagbufchan(ioff,ii) = obsptr%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + diagbufchan(ioff,ii) = obsptr%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + diagbufchan(ioff,ii) = obsptr%obssen(jj) + enddo + + obsptr => obsptr%next + enddo + else + ioff=ioff0 + diagbufchan(ioff+1:ioff+4*miter+1,1:nchanl) = zero + endif + endif + + psfc=prsitmp(1)*r10 ! convert to hPa + write(4) psfc,diagbuf,diagbufchan + + if (binary_diag) call contents_binary_diag_ + if (netcdf_diag) call contents_netcdf_diag_ + end if + endif ! (in_curbin) + +100 continue + +! End of n-loop over obs + end do + +! Jump here when there is no data to process for current satellite +! Deallocate arrays + deallocate(diagbufchan) + + if (aero_diagsave) then + close(4) + if (binary_diag) call final_binary_diag_ + if (netcdf_diag) call nc_diag_write + endif + + call destroy_crtm + +! End of routine + + return + +contains + function tailNode_typecast_(oll) result(ptr_) +!> Cast the tailNode of oll to an aeroNode, as in +!> ptr_ => typecast_(tailNode_(oll)) + + use m_aeroNode, only: aeroNode, typecast_ => aeroNode_typecast + use m_obsLList, only: obsLList, tailNode_ => obsLList_tailNode + use m_obsNode , only: obsNode + implicit none + type(aeroNode),pointer:: ptr_ + type(obsLList),target ,intent(in):: oll + + class(obsNode),pointer:: inode_ + inode_ => tailNode_(oll) + ptr_ => typecast_(inode_) + end function tailNode_typecast_ + + subroutine init_binary_diag_ + ! subroutine to initialize binary diag files + ! original: pagowski + ! modified: 2019-03-20 - martin - cleaned up to fit GSI coding norms + implicit none + character(10) :: filex + character(12) :: string + + filex=obstype + write(string,1976) jiter +1976 format('_',i2.2) + diag_aero_file= trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // trim(string) + guess_aero_file= trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // '_vars' // trim(string) + + if(init_pass) then + open(4,file=trim(diag_aero_file),form='unformatted',status='unknown',position='rewind') + open(41,file=trim(guess_aero_file),form='unformatted',status='unknown',position='rewind') + else + open(4,file=trim(diag_aero_file),form='unformatted',status='old',position='append') + open(41,file=trim(guess_aero_file),form='unformatted',status='old',position='append') + endif + +! Initialize/write parameters for satellite diagnostic file on +! first outer iteration. + if (init_pass .and. mype==mype_diaghdr(is)) then + write(4)isis,dplat(is),obstype,jiter,nchanl,ianldate,ireal,ipchan,nsig,ioff0 + write(41)nsig,nvars,n_aerosols_fwd,ianldate + write(41)varnames + write(6,*)'setupaod: write header record for ',& + isis,ireal,' to file ',trim(diag_aero_file),' ',ianldate + do i=1,nchanl + n=ich(i) + if( iuse_aero(n) < 0 ) cycle + !if( n < 1 )cycle + varch4=error_aero(n) + freq4=sc(sensorindex)%frequency(i) + pol4=sc(sensorindex)%polarization(i) + wave4=sc(sensorindex)%wavenumber(i) + write(4)freq4,pol4,wave4,varch4,iuse_aero(n),& + nuchan_aero(n),ich(i) + end do + end if + end subroutine init_binary_diag_ + + subroutine init_netcdf_diag_ + ! subroutine to initialize netcdf diag files + ! original: pagowski + ! modified: 2019-03-21 - martin - cleaned up to fit GSI coding norms + implicit none + character(10) :: filex + character(12) :: string + filex=obstype + write(string,1976) jiter +1976 format('_',i2.2) + diag_aero_file= trim(dirname) // trim(filex) // '_' // trim(dplat(is)) //trim(string) // '.nc4' + if (init_pass .and. nobs > 0) then + call nc_diag_init(diag_aero_file) + call nc_diag_chaninfo_dim_set(nchanl) + end if + + if (init_pass) then + call nc_diag_header("Satellite_Sensor", isis ) + call nc_diag_header("Satellite", dplat(is) ) + call nc_diag_header("Observation_type", "aod" ) + call nc_diag_header("Number_of_channels", nchanl ) + call nc_diag_header("date_time", ianldate ) + do i=1,nchanl + n=ich(i) + if( iuse_aero(n) < 0 ) cycle + call nc_diag_chaninfo("frequency",sngl(sc(sensorindex)%frequency(i))) + call nc_diag_chaninfo("polarization",sc(sensorindex)%polarization(i)) + call nc_diag_chaninfo("wavenumber",sngl(sc(sensorindex)%wavenumber(i))) + call nc_diag_chaninfo("use_flag", iuse_aero(n)) + call nc_diag_chaninfo("sensor_chan", nuchan_aero(n)) + end do + end if + end subroutine init_netcdf_diag_ + + subroutine contents_binary_diag_ + ! subroutine to write contents to binary diag files + ! original: pagowski + ! modified: 2019-03-21 - martin - cleaned up to fit GSI coding norms + implicit none + diagbuf(1) = cenlat ! observation latitude (degrees) + diagbuf(2) = cenlon ! observation longitude (degrees) + + diagbuf(3) = dtime!-time_offset ! observation time (hours relative to analysis time) + diagbuf(4) = pangs ! solar zenith angle (degrees) + diagbuf(5) = data_s(isazi_ang,n) ! solar azimuth angle (degrees) + + do i=1,nchanl + diagbufchan(1,i)=aod_obs(i) ! observed brightness temperature (K) + diagbufchan(2,i)=aod(i) ! innovation + errinv = sqrt(varinv(i)) + diagbufchan(3,i)=errinv ! inverse observation error + useflag=one + if (iuse_aero(ich(i)) < 1) useflag=-one + diagbufchan(4,i)= id_qc(i)*useflag! quality control mark or event indicator + end do + + if (lobsdiagsave) then + if (l_may_be_passive) then + do ii=1,nchanl + if (.not.associated(obsptr)) then + write(6,*)'setupaod: error obsptr' + call stop2(280) + end if + ioff=ioff0 + do jj=1,miter + ioff=ioff+1 + if (obsptr%muse(jj)) then + diagbufchan(ioff,ii) = one + else + diagbufchan(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + diagbufchan(ioff,ii) = obsptr%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + diagbufchan(ioff,ii) = obsptr%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + diagbufchan(ioff,ii) = obsptr%obssen(jj) + enddo + obsptr => obsptr%next + enddo + else + ioff=ioff0 + diagbufchan(ioff+1:ioff+4*miter+1,1:nchanl) = zero + endif + endif + + write(4) diagbuf,diagbufchan + write(41)real(tvp,r_single),real(qvp/(one-qvp),r_single),& + &real(rh,r_single),& + &real(prsltmp,r_single),real(prsitmp,r_single) + write(41)real(aerosols,r_single) + + end subroutine contents_binary_diag_ + + subroutine contents_netcdf_diag_ + ! subroutine to write contents to netcdf diag files + ! original: pagowski + ! modified: 2019-03-21 - martin - cleaned up to fit GSI coding norms + implicit none + character(7),parameter :: obsclass = ' aod' + character(128) :: fieldname + + integer(i_kind) :: iaero,k,l + real(r_single), dimension(nsig+1) :: tmp + + real(r_single),parameter:: missing = -9.99e9_r_single + + do i=1,nchanl + l=ich(i) + if ( iuse_aero(l) < 0 ) cycle + call nc_diag_metadata("Channel_Index", i) + call nc_diag_metadata("Observation_Class", obsclass) + call nc_diag_metadata("Latitude", sngl(cenlat)) ! observation latitude (degrees) + call nc_diag_metadata("Longitude", sngl(cenlon)) ! observation longitude (degrees) + call nc_diag_metadata("Obs_Time", sngl(dtime))!-time_offset)) ! observation time (hours relative to analysis time) + call nc_diag_metadata("Sol_Zenith_Angle", sngl(pangs)) ! solar zenith angle (degrees) + call nc_diag_metadata("Sol_Azimuth_Angle", sngl(data_s(isazi_ang,n))) ! solar azimuth angle (degrees) + call nc_diag_metadata("Surface_type", nint(data_s(istyp,n))) + call nc_diag_metadata("MODIS_deep_blue_flag", nint(dbcf) ) + call nc_diag_metadata("Observation", sngl(diagbufchan(1,i)) ) ! observed aod + call nc_diag_metadata("Obs_Minus_Forecast_adjusted",sngl(diagbufchan(2,i))) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(diagbufchan(2,i)))! obs - sim aod with no bias correction + + if (diagbufchan(3,i) > tiny_r_kind) then + tmp(1)=one/diagbufchan(3,i) + else + tmp(1)=missing + end if + + call nc_diag_metadata("Observation_Error",tmp(1)) + call nc_diag_metadata("QC_Flag", sngl(diagbufchan(4,i))) !quality control mark or event indicator + tmp(1)=get_zsfc() + call nc_diag_metadata("sfc_height",tmp(1)) ! height in meters + + do k=1,nsig + tmp(k)=tvp(nsig-k+1) + end do + call nc_diag_data2d("air_temperature", tmp(1:nsig)) ! K + + do k=1,nsig + tmp(k)=qvp(nsig-k+1)/(1_r_kind-qvp(nsig-k+1)) + end do + call nc_diag_data2d("humidity_mixing_ratio", tmp(1:nsig)) ! kg/kg + + do k=1,nsig + tmp(k)=rh(nsig-k+1) + end do + call nc_diag_data2d("relative_humidity", tmp(1:nsig)) ! 0-1 + + do k=1,nsig + tmp(k)=1000_r_single*prsltmp(nsig-k+1) + end do + call nc_diag_data2d("air_pressure", tmp(1:nsig)) ! Pa + + do k=1,nsig+1 + tmp(k)=1000_r_single*prsitmp(nsig-k+2) + end do + call nc_diag_data2d("air_pressure_levels", tmp(1:nsig+1)) ! Pa + + do iaero = 1, n_aerosols_fwd + write (fieldname, "(A,I0.2)") aerosol_names(iaero) + do k=1,nsig + tmp(k)=aerosols(nsig-k+1,iaero) + end do + call nc_diag_data2d(trim(fieldname), tmp(1:nsig)) !mixing ratios in ug/kg + end do + + end do + + end subroutine contents_netcdf_diag_ + + subroutine final_binary_diag_ + ! subroutine to finalize binary diag files + ! original: pagowski + ! modified: 2019-03-21 - martin - cleaned up to fit GSI coding norms + close(4) + close(41) + end subroutine final_binary_diag_ + + ! nc_diag_write is a generic routine that takes care of finalizing the netcdf diag file + ! so no need for final_netcdf_diag_ subroutine + + function get_zsfc() RESULT(zsfc) + ! function to get surface height from GSI bundle + ! original: pagowski + ! modified: 2019-03-21 - martin - cleaned up to fit GSI coding norms + implicit none + + real(r_kind) :: zsfc + real(r_kind),dimension(:,: ),pointer:: rank2 + character(len=5) :: varname + integer(i_kind) :: istatus,ifld + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + + varname='z' + + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname)& + &,rank2,istatus) + + if (istatus==0) then + + if(allocated(ges_z)) then + write(6,*) trim(myname), ': ', trim(varname), ' already& + & incorrectly allocated ' + call stop2(111) + end if + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld)& + &,trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + end do + call intrp2a11(ges_z(1,1,ntguessig),zsfc,slats,slons,mype) + else + write(6,*) trim(myname),': ', trim(varname), ' not found in& + & met bundle, ier= ',istatus + call stop2(112) + end if + + end function get_zsfc + + +end subroutine setupaod +end module aero_setup diff --git a/src/setupbend.f90 b/src/gsi/setupbend.f90 similarity index 90% rename from src/setupbend.f90 rename to src/gsi/setupbend.f90 index 5f6832fa4..a1a36eec0 100644 --- a/src/setupbend.f90 +++ b/src/gsi/setupbend.f90 @@ -1,4 +1,12 @@ -subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pass) +module gpsbend_setup + implicit none + private + public:: setup + interface setup; module procedure setupbend; end interface + +contains +subroutine setupbend(obsLL,odiagLL, & + lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pass,conv_diagsave) !$$$ subprogram documentation block ! . . . . ! subprogram: setupbend compute rhs of oi for gps bending angle @@ -86,6 +94,9 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting ! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) ! . removed (%dlat,%dlon) debris. +! 2016-11-29 shlyaeva - save linearized H(x) for EnKF +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). ! ! input argument list: ! lunin - unit from which to read observations @@ -101,17 +112,26 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p ! machine: ibm RS/6000 SP ! !$$$ - use mpeu_util, only: die,perr,tell + use mpeu_util, only: die,perr,tell,getindex use kinds, only: r_kind,i_kind use m_gpsStats, only: gps_allhead,gps_alltail - use m_obsdiags, only: gpshead use obsmod , only: nprof_gps,grids_dim,lobsdiag_allocated,& - i_gps_ob_type,obsdiags,lobsdiagsave,nobskeep,& - time_offset + lobsdiagsave,nobskeep,& + time_offset,lobsdiag_forenkf use m_obsNode, only: obsNode use m_gpsNode , only: gpsNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag + use m_gpsNode , only: gpsNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_appendNode + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_init + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + use gsi_4dvar, only: nobs_bins,hr_obsbin use guess_grids, only: ges_lnprsi,hrdifsig,geop_hgti,nfldsig @@ -123,9 +143,9 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p grav_equator,somigliana,flattening,grav_ratio,grav,rd,eps,three,four,five use lagmod, only: setq, setq_TL use lagmod, only: slagdw, slagdw_TL - use jfunc, only: jiter,miter + use jfunc, only: jiter,miter,jiterstart use convinfo, only: cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use m_dtime, only: dtime_setup, dtime_check, dtime_show + use m_dtime, only: dtime_setup, dtime_check use m_gpsrhs, only: muse use m_gpsrhs, only: dbend_loc,xj @@ -142,12 +162,15 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p use m_gpsrhs, only: gpsrhs_aliases use m_gpsrhs, only: gpsrhs_unaliases + use state_vectors, only: levels, svars3d use gsi_bundlemod, only : gsi_bundlegetpointer use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - + use sparsearr, only: sparr2, new, size, writearray implicit none ! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork real(r_kind),dimension(max(1,nprof_gps)),intent(inout) :: toss_gps_sub @@ -155,6 +178,7 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p integer, intent(in):: is ! index to GPSbend buffer variables logical, intent(in):: init_pass ! flag the pass for the first background bin logical, intent(in):: last_pass ! flag the pass for the last background bin + logical, intent(in):: conv_diagsave ! save diagnostics file ! Declare local parameters real(r_kind),parameter:: r240 = 240.0_r_kind @@ -198,6 +222,9 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p integer(i_kind),dimension(4) :: gps_ij integer(i_kind):: satellite_id,transmitter_id + type(sparr2) :: dhx_dx + integer(i_kind) :: iz, t_ind, q_ind, p_ind, nnz, nind + real(r_kind),dimension(3,nsig+nsig_ext) :: q_w,q_w_tl real(r_kind),dimension(nsig) :: hges,irefges,zges,dhdt,dhdp real(r_kind),dimension(nsig+1) :: prsltmp @@ -215,17 +242,20 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID logical proceed - logical:: in_curbin, in_anybin, obs_check,qc_layer_SR - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node + logical:: in_curbin, in_anybin, obs_check,qc_layer_SR, save_jacobian type(gpsNode),pointer:: my_head type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL real(r_kind),allocatable,dimension(:,:,: ) :: ges_z real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + type(obsLList),pointer,dimension(:):: gpshead + gpshead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + !******************************************************************************* ! List of GPS RO satellites and corresponding BUFR id !740 => COSMIC FM1 @@ -290,10 +320,15 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p ! Allocate arrays for output to diagnostic file - mreal=21 + mreal=22 nreal=mreal if (lobsdiagsave) nreal=nreal+4*miter+1 - + if (save_jacobian) then + nnz = nsig * 3 ! number of non-zero elements in dH(x)/dx profile + nind = 3 ! number of dense subarrays + call new(dhx_dx, nnz, nind) + nreal = nreal + size(dhx_dx) + endif if(init_pass) call gpsrhs_alloc(is,'bend',nobs,nsig,nreal,grids_dim,nsig_ext) call gpsrhs_aliases(is) if(nreal/=size(rdiagbuf,1)) then @@ -501,6 +536,7 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p rdiagbuf(11,i) = data(iuse,i) ! data usage flag rdiagbuf(17,i) = data(igps,i) ! bending angle observation (radians) rdiagbuf(19,i) = hob ! model vertical grid (interface) if monotone grid + rdiagbuf(22,i) = 1.e+10_r_kind ! spread (filled in by EnKF) if(ratio_errors(i) > tiny_r_kind) then ! obs inside model grid @@ -655,7 +691,7 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p data(ier,i) = zero ratio_errors(i) = zero muse(i)=.false. - goto 3000 + cycle loopoverobs1 endif ! bending angle (radians) @@ -743,7 +779,6 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p end if ! obs above super-refraction and shadow layers end if ! obs inside the vertical grid -3000 continue end do loopoverobs1 ! end of loop over observations if (nobs_out>=1) then @@ -778,10 +813,7 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p end do endif ! (last_pass) - ! Loop to load arrays used in statistics output - n_alloc(:)=0 - m_alloc(:)=0 call dtime_setup() do i=1,nobs dtime=data(itime,i) @@ -838,67 +870,24 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p ibin = 1 endif IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins, ibin=',nobs_bins,ibin + if(luse_obsdiag) my_diagLL => odiagLL(ibin) ! Link obs to diagnostics structure if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_gps_ob_type,ibin)%head)) then - obsdiags(i_gps_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_gps_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupbend: failure to allocate obsdiags',istat - call stop2(250) - end if - obsdiags(i_gps_ob_type,ibin)%tail => obsdiags(i_gps_ob_type,ibin)%head - else - allocate(obsdiags(i_gps_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupbend: failure to allocate obsdiags',istat - call stop2(251) - end if - obsdiags(i_gps_ob_type,ibin)%tail => obsdiags(i_gps_ob_type,ibin)%tail%next - end if - obsdiags(i_gps_ob_type,ibin)%n_alloc = obsdiags(i_gps_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_gps_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_gps_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_gps_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_gps_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_gps_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_gps_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_gps_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_gps_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_gps_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_gps_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_gps_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_gps_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_gps_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_gps_ob_type,ibin)%tail)) then - obsdiags(i_gps_ob_type,ibin)%tail => obsdiags(i_gps_ob_type,ibin)%head - else - obsdiags(i_gps_ob_type,ibin)%tail => obsdiags(i_gps_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_gps_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_gps_ob_type,ibin)%tail)') - end if - if (obsdiags(i_gps_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupbend: index error' - call stop2(252) - end if - endif + my_diag => obsdiagLList_nextNode(my_diagLL, & + create=.not.lobsdiag_allocated, & ! either make-a-new or move-to-next + idv=is, & + iob=ioid(i), & + ich=1, & + elat=data(ilate,i), & + elon=data(ilone,i), & + luse=luse(i), & + miter=miter) + if (.not.associated(my_diag)) call die(myname,'a null obsdiagLList_nextNode, create =',.not.lobsdiag_allocated) endif if(last_pass) then - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_gps_ob_type,ibin)%tail%muse(nobskeep) + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) ! Save values needed for generate of statistics for all observations if(.not. associated(gps_allhead(ibin)%head))then @@ -936,17 +925,17 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p ! Fill obs diagnostics structure if (luse_obsdiag) then - obsdiags(i_gps_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_gps_ob_type,ibin)%tail%nldepart(jiter)=data(igps,i) - obsdiags(i_gps_ob_type,ibin)%tail%wgtjo=(data(ier,i)*ratio_errors(i))**2 + call obsdiagNode_set(my_diag,wgtjo=(data(ier,i)*ratio_errors(i))**2, & + jiter=jiter,muse=muse(i),nldepart=data(igps,i) ) endif ! Load additional obs diagnostic structure + ioff = mreal if (lobsdiagsave) then - ioff=mreal + associate(odiag => my_diag ) do jj=1,miter ioff=ioff+1 - if (obsdiags(i_gps_ob_type,ibin)%tail%muse(jj)) then + if (odiag%muse(jj)) then rdiagbuf(ioff,i) = one else rdiagbuf(ioff,i) = -one @@ -954,17 +943,18 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p enddo do jj=1,miter+1 ioff=ioff+1 - rdiagbuf(ioff,i) = obsdiags(i_gps_ob_type,ibin)%tail%nldepart(jj) + rdiagbuf(ioff,i) = odiag%nldepart(jj) enddo do jj=1,miter ioff=ioff+1 - rdiagbuf(ioff,i) = obsdiags(i_gps_ob_type,ibin)%tail%tldepart(jj) + rdiagbuf(ioff,i) = odiag%tldepart(jj) enddo do jj=1,miter ioff=ioff+1 - rdiagbuf(ioff,i) = obsdiags(i_gps_ob_type,ibin)%tail%obssen(jj) + rdiagbuf(ioff,i) = odiag%obssen(jj) enddo - endif + end associate ! odiag + endif do j=1,nreal gps_alltail(ibin)%head%rdiag(j)= rdiagbuf(j,i) @@ -976,10 +966,7 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p if (in_curbin .and. muse(i)) then allocate(my_head) - m_alloc(ibin) = m_alloc(ibin)+1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(gpshead(ibin),my_node) - my_node => null() + call gpsNode_appendto(my_head,gpshead(ibin)) my_head%idv = is my_head%iob = ioid(i) @@ -1106,6 +1093,46 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p end do end do + my_head%jac_p(nsig+1) = zero + + if (save_jacobian) then + t_ind = getindex(svars3d, 'tv') + if (t_ind < 0) then + print *, 'Error: no variable tv in state vector. Exiting.' + call stop2(1300) + endif + q_ind = getindex(svars3d, 'q') + if (q_ind < 0) then + print *, 'Error: no variable q in state vector. Exiting.' + call stop2(1300) + endif + p_ind = getindex(svars3d, 'prse') + if (p_ind < 0) then + print *, 'Error: no variable prse in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = sum(levels(1:t_ind-1)) + 1 + dhx_dx%end_ind(1) = sum(levels(1:t_ind-1)) + nsig + dhx_dx%st_ind(2) = sum(levels(1:q_ind-1)) + 1 + dhx_dx%end_ind(2) = sum(levels(1:q_ind-1)) + nsig + dhx_dx%st_ind(3) = sum(levels(1:p_ind-1)) + 1 + dhx_dx%end_ind(3) = sum(levels(1:p_ind-1)) + nsig + + do iz = 1, nsig + dhx_dx%val(iz) = my_head%jac_t(iz) + dhx_dx%val(iz+nsig) = my_head%jac_q(iz) + dhx_dx%val(iz+2*nsig) = my_head%jac_p(iz) + enddo + + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,i)) + ioff = ioff + size(dhx_dx) + endif + + do j=1,nreal + gps_alltail(ibin)%head%rdiag(j)= rdiagbuf(j,i) + end do + my_head%jac_p(nsig+1) = zero my_head%raterr2= ratio_errors(i)**2 my_head%res = data(igps,i) @@ -1116,17 +1143,8 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p my_head%luse = luse(i) if (luse_obsdiag) then - my_head%diags => obsdiags(i_gps_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,i,ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag endif my_head => null() @@ -1142,7 +1160,6 @@ subroutine setupbend(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_p data_ihgt(:)=data(ihgt,:) data_igps(:)=data(igps,:) - call dtime_show(myname,'diagsave:bend',i_gps_ob_type) call gpsrhs_unaliases(is) if(last_pass) call gpsrhs_dealloc(is) @@ -1238,3 +1255,4 @@ subroutine final_vars_ end subroutine final_vars_ end subroutine setupbend +end module gpsbend_setup diff --git a/src/gsi/setupcldch.f90 b/src/gsi/setupcldch.f90 new file mode 100644 index 000000000..cd3790016 --- /dev/null +++ b/src/gsi/setupcldch.f90 @@ -0,0 +1,746 @@ +module cldch_setup + implicit none + private + public:: setup + interface setup; module procedure setupcldch; end interface + +contains +subroutine setupcldch(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupcldch compute rhs for conventional surface cldch +! prgmmr: derber org: np23 date: 2004-07-20 +! +! abstract: For sea surface temperature observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2015-07-10 pondeca +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! before retuning to setuprhsall.f90 +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-03-01 yang - use module nltransf to cldch + +! 2018-03-22 pondeca/yang - for code consistency across all analyzed variables,replace +! the original "dup"-based implementation of the option to +! assimilate the closest ob to the analysis time only with +! Ming Hu's "muse"-based implementationusing. +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use m_obsNode , only: obsNode + use m_cldchNode, only: cldchNode + use m_cldchNode, only: cldchNode_appendto + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + use m_obsLList , only: obsLList + + use guess_grids, only: hrdifsig,nfldsig + use obsmod, only: rmiss_single,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,bmiss + use obsmod, only: luse_obsdiag,ianldate + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig + use gridmod, only: get_ij + use constants, only: zero,tiny_r_kind,one,half,one_tenth,wgtlim, & + two,cg_term,huge_single,r1000 + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use qcmod, only: pcldch,scale_cv + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use nltransf, only: nltransf_inverse + use rapidrefresh_cldsurf_mod, only: l_closeobs + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss + character(len=*),parameter:: myname='setupcldch' + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) cldchges,dlat,dlon,ddiff,dtime,error + real(r_kind) cldchgesout,cldchobout,tempcldch,cldchdiff + real(r_kind) cldch_errmax + real(r_kind) scale,val2,ratio,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,rwgt + real(r_kind) cg_cldch,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,icldch,id,itime,ikx,imaxerr,iqc + integer(i_kind) iuse,ilate,ilone,istnelv,iobshgt,izz,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + real(r_kind) :: hr_offset + + logical:: in_curbin, in_anybin + + type(cldchNode),pointer:: my_head + type(obs_diag ),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,:) :: ges_ps + real(r_kind),allocatable,dimension(:,:,:) :: ges_cldch + real(r_kind),allocatable,dimension(:,:,:) :: ges_z + + type(obsLList),pointer,dimension(:):: cldchhead + cldchhead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + + cldch_errmax=20.0_r_kind +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + icldch=4 ! index of cldch observation - background + id=5 ! index of station id + itime=6 ! index of observation time in data array + ikxx=7 ! index of ob type + imaxerr=8 ! index of cldch max error + iqc=9 ! index of quality mark + iuse=10 ! index of use parameter + idomsfc=11 ! index of dominant surface type + ilone=12 ! index of longitude (degrees) + ilate=13 ! index of latitude (degrees) + istnelv=14 ! index of station elevation (m) + iobshgt=15 ! index of observation height (m) + izz=16 ! index of surface height + iprvd=17 ! index of provider + isprvd=18 ! index of subprovider + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for missing data !need obs value and error + do i=1,nobs + if (data(icldch,i) > r0_1_bmiss) then + muse(i)=.false. + data(icldch,i)=rmiss_single ! for diag output + data(iobshgt,i)=rmiss_single ! for diag output + end if + end do + +! Check for duplicate observations at same location + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +!------------------------------------------------------------------------------ +! RTMA SO test-part one:check the interpolated fields at the selected station + +! rstation_id = data(id,i) +! if (trim(station_id) .ne. 'CYYY') then +! Interpolate to get cldch at obs location/time +! call tintrp2a11(ges_cldch,cldchges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) +! endif +! if (trim(station_id) .eq. 'CYYY') then +! write (6,*) 'CYYY trim(station_id=',trim(station_id) +! Interpolate to get cldch at obs location/time--print out the interplator's +! grid value +! call tintrp2so(ges_cldch,cldchges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) +! endif +! END RTMA SO test-part one +!------------------------------------------------------------------------------ + +! Interpolate to get cldch at obs location/time + call tintrp2a11(ges_cldch,cldchges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) + +! Adjust observation error + ratio_errors=error/data(ier,i) + error=one/error + + ddiff=data(icldch,i)-cldchges + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross check using innovation normalized by error + if (abs(data(icldch,i)-rmiss_single) >= tiny_r_kind ) then !MIGHT WANT TO IMPROVE THIS. MPondeca /17Jul2015 + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + ratio_errors=ratio_errors/sqrt(dup(i)) + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + end if + else ! missing data + error = zero + ratio_errors=zero + end if + +!------------------------------------------------------------------- +! RTMA SO test-part two: assign obs. error as zero at all stations +! except the selected station +! rstation_id = data(id,i) +! if (trim(station_id) .ne. 'CYYY') then +! write (6,*) 'trim(station_id=',trim(station_id) +! error = zero +! ratio_errors=zero +! else +! write (6,*) 'CYYY: trim(station_id=)',trim(station_id) +! endif +! END RTMA SO test part two +!------------------------------------------------------------------- + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_cldch=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_cldch*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 !rejected obs + if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs + end if +!......................................................................... +!NLTR: convert cldchges to physical space + call nltransf_inverse(cldchges,cldchgesout,pcldch,scale_cv) + + if (abs(data(icldch,i)-rmiss_single) >=tiny_r_kind) then + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count +!......................................................................... +!NLTR: convert cldchobs to physical space + call nltransf_inverse(cldchges,cldchgesout,pcldch,scale_cv) + tempcldch=data(icldch,i) + call nltransf_inverse(tempcldch,cldchobout,pcldch,scale_cv) +!values in cldch fits, fort.232, are in physical space + cldchdiff=(cldchobout-cldchgesout)*scale + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+cldchdiff ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+cldchdiff*cldchdiff ! (o-g)**2 +!END NLTR + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + else ! default value for cldchobout and cldchdiff + cldchobout=rmiss_single + cldchdiff=(cldchobout-cldchgesout)*scale + end if + endif + + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call cldchNode_appendto(my_head,cldchhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + + if (ratio_errors*error>tiny_r_kind) then + err_final = 4000.0_r_kind + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single +!--------------------------------------------------------------------------------- +!In diag file, write out cldch error statistics and field in physical space. +!NOTE: No linear conversion in error stats between physical space and NLTR +!space. +!NOTE: in RTMA post process only err_final is used +!------------------------------------------------------------------------- + err_input = 4000.0_r_kind + err_adjst = 4000.0_r_kind + + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'cei',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::cldch' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get cldch ... + varname='cldch' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_cldch))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_cldch(size(rank2,1),size(rank2,2),nfldsig)) + ges_cldch(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_cldch(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_cldch_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m**-1) + + rdiagbuf(17,ii) = cldchobout ! CLDCH observation (m) + rdiagbuf(18,ii) = cldchdiff ! obs-ges in physical space,for post process + rdiagbuf(19,ii) = ddiff ! obs-ges used in analysis in gspace + rdiagbuf(20,ii) = rmiss_single ! type of measurement + rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(22,ii) = data(izz,i) ! model terrain at observation location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' cldch' + real(r_kind),parameter:: missing = -9.99e9_r_kind + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", missing ) + call nc_diag_metadata("Height", data(iobshgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(icldch,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(icldch,i)-cldchges ) + + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_cldch)) deallocate(ges_cldch) + if(allocated(ges_ps )) deallocate(ges_ps ) + end subroutine final_vars_ + +end subroutine setupcldch +end module cldch_setup diff --git a/src/gsi/setupcldtot.F90 b/src/gsi/setupcldtot.F90 new file mode 100755 index 000000000..3f438ddd1 --- /dev/null +++ b/src/gsi/setupcldtot.F90 @@ -0,0 +1,1047 @@ +module cldtot_setup + implicit none + private + public:: setup + interface setup; module procedure setupcldtot; end interface + + character(len=*),parameter:: myname="cldtot_setup" +contains + +subroutine setupcldtot(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +!! . . . . +! subprogram: setupcldtot compute rhs of oi for pseudo moisture observations from +! METAR and Satellite cloud observations +! prgmmr: Ladwag org: GSD date: 2019-06-01 +! +! abstract: For moisture observations, this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2016-04-06 Ladwig new setup routine for METAR ceilometer obs +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: +! +! +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use obsmod, only: rmiss_single,time_offset + use m_obsNode, only: obsNode + use m_qNode, only: qNode + use m_qNode, only: qNode_appendto + use gsi_4dvar, only: nobs_bins,hr_obsbin + + use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate + use nc_diag_write_mod,only: nc_diag_init, nc_diag_header,nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init,nc_diag_read_get_dim, & + nc_diag_read_close + use state_vectors, only: nsdim + + use guess_grids, only: geop_hgtl,hrdifsig,nfldsig,ges_tsen,ges_prsl + use gridmod, only: nsig,get_ijk + use constants, only: zero,one,r1000,r10,r100 + use constants, only: huge_single,wgtlim,three + use constants, only: tiny_r_kind,five,half,two,r0_01 + use qcmod, only: npres_print + use jfunc, only: jiter + use convinfo, only: nconvtype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check, dtime_show + use rapidrefresh_cldsurf_mod, only: i_cloud_q_innovation, & + cld_bld_hgt,i_ens_mean + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + + use mpimod, only: mpi_comm_world + use constants, only: zero,one, h1000 + use gsdcloudlib_pseudoq_mod, only: cloudLWC_pseudo,cloudCover_Surface_col + + use m_obsLList, only: obsLList + use m_obsdiagNode, only: obs_diags + use obsmod, only: luse_obsdiag + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + logical ,intent(in ) :: conv_diagsave + +#ifdef RR_CLOUDANALYSIS +! Declare local parameters + real(r_single) :: cloudqvis + + real(r_kind),parameter:: small1=0.0001_r_kind + real(r_kind),parameter:: small2=0.0002_r_kind + real(r_kind),parameter:: r0_7=0.7_r_kind + real(r_kind),parameter:: r8=8.0_r_kind + real(r_kind),parameter:: r0_001 = 0.001_r_kind + real(r_kind),parameter:: r1e16=1.e16_r_kind + character(len=*),parameter:: myname='setupcldtot' + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: tintrp31,tintrp3 + external:: grdcrd1 + external:: genqsat + external:: stop2 + +! Declare local variables + + real(r_double) rstation_id + real(r_kind) qob,qges,qv_ob + real(r_kind) ratio_errors,dlat,dlon,dtime,dpres,error + real(r_kind) ddiff + real(r_kind) scale + real(r_kind) val,rwgt + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + real(r_single),allocatable,dimension(:,:)::rdiagbufp + + integer(i_kind) i,j,nchar,nreal,nrealcld,ii,iip,mm1 + integer(i_kind) itype,k,ibin,ioff0 + integer(i_kind) ikx + integer(i_kind) ilate,ilone,iobshgt + integer(i_kind) id,ilon,ilat,istnelv,ivis,icldhgt,icldamt,iwthr,itime,iuse,iddp + integer(i_kind) :: startwx, endwx + + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cdiagbufp + character(8),allocatable,dimension(:):: stationbuf + + logical proceed + logical,dimension(nobs):: luse,muse + + logical:: in_curbin, in_anybin + type(qNode),pointer:: my_headq + + equivalence(rstation_id,station_id) + + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_ql + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qi + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + + real(r_kind),allocatable:: dpres1d(:) + real(r_kind),allocatable:: t_bk(:) + real(r_kind),allocatable:: h_bk(:) + real(r_kind),allocatable:: p_bk(:) + real(r_kind),allocatable:: ql_bk(:) + real(r_kind),allocatable:: qi_bk(:) + real(r_kind) z_bk + real(r_kind),allocatable:: q_bk(:) + + !surface obs + integer(i_kind),allocatable :: ocld(:) + character*10 :: owx + real(r_single) :: oelvtn + real(r_single) :: ovis + character*3 :: mwx + integer(i_kind) :: nvarcld_p + parameter (nvarcld_p=13) + real(r_kind) :: cldamt,awx,cldhgt + + integer(i_kind),allocatable :: pcp_type_obs(:) ! precipitation type + integer(i_kind) :: wthr_type + !integer(i_kind),allocatable :: cloudlayers_i(:) ! 5 different layers + ! 1= the number of layers + ! 2,4,... bottom + ! 3,5,... top + real(r_single) :: vis2qc ! fog + real(r_single),external :: ruc_saturation ! an external function accesseed through + ! an implicit interface from GSD + + real(r_single), allocatable :: cld_cover_obs(:) ! cloud cover obs + + real(r_single),allocatable :: cldwater_obs(:) ! cloud water + real(r_single),allocatable :: cldice_obs(:) ! cloud ice + + real(r_single),allocatable :: all_qv_obs(:,:) ! to save obs from mean + + integer(i_kind) :: miss_obs_int + real(r_kind) :: miss_obs_real + real(r_single) :: miss_obs_single + real(r_single) :: pressure + parameter ( miss_obs_int = 99999999 ) + parameter ( miss_obs_real = 99999999.0_r_kind ) + parameter ( miss_obs_single = -9999.0_r_single ) + real(r_kind) :: spval_p + parameter (spval_p = 99999999._r_kind) + integer(i_kind) :: obzero,obcount,dontobcount + integer(i_kind) :: q_obcount,q_clear_count,q_build_count + integer(i_kind) :: q_clear0_count,q_build0_count + real(r_kind) :: zlev_clr + real(r_kind) :: qobmax,qobmin + integer(i_kind) :: firstob + real(r_kind) :: var_jb + real(r_kind) :: rh_clear_p + parameter (rh_clear_p = 0.8_r_kind) + character(len=14) :: myfile + logical:: lhere + integer(i_kind):: istat1,istat2,istat3 + + type(obsLList),pointer,dimension(:):: qhead + + if(luse_obsdiag) call die(myname,'not implemented for luse_obsdiag =',luse_obsdiag) + + qhead => obsLL(:) +! + awork=0.0_r_kind + bwork=0.0_r_kind +! + obcount=0 + q_obcount=0 + q_clear_count=0 + q_clear0_count=0 + q_build_count=0 + q_build0_count=0 + dontobcount=0 + qobmax = 0.0_r_kind + qobmin = 100.0_r_kind + firstob=0 + var_jb=zero + qv_ob=-7777.7_r_kind + cloudqvis=0._r_single + +! Check to see if cloud ob DA should be done + if (i_cloud_q_innovation == 0) return + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + + allocate(h_bk(nsig)) + allocate(t_bk(nsig)) + allocate(q_bk(nsig)) + allocate(p_bk(nsig)) + allocate(ql_bk(nsig)) + allocate(qi_bk(nsig)) + allocate(dpres1d(nsig)) + p_bk=miss_obs_real + q_bk=miss_obs_real + t_bk=miss_obs_real + qi_bk=miss_obs_real + ql_bk=miss_obs_real + h_bk=miss_obs_real + z_bk=miss_obs_real + + do k=1,nsig + dpres1d(k)=k + enddo + + ! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + nchar=1 + nreal=23 + if (i_cloud_q_innovation == 1 .or. i_cloud_q_innovation == 3) then + ii=0 + allocate(cdiagbuf(nobs*nsig),rdiagbuf(nreal,nobs*nsig)) + rdiagbuf=zero + endif + if (i_cloud_q_innovation == 2 .or. i_cloud_q_innovation == 3) then + iip=0 + allocate(cdiagbufp(nobs*nsig),rdiagbufp(nreal,nobs*nsig)) + cdiagbufp="EMPTY" + rdiagbufp=zero + if (i_ens_mean == 1) then + nrealcld=nreal+10 + allocate(all_qv_obs(nrealcld,nobs*nsig)) + all_qv_obs=miss_obs_real + endif + if (netcdf_diag) call init_netcdf_diag_ + endif + endif + + if (i_ens_mean == 2) then +! will read the observations from saved file for diag file of each ensemble member. +! so ship the moisture observation generation. + else +!******************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse + + id=1 ! index of station id + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + istnelv=4 ! index of station elevation (m) + ivis=5 ! index of visibility observation + icldamt=6 ! index of cloud amount from 6-11 + icldhgt=12 ! index of cloud base height from 12-17 + iwthr=18 ! index of weather 18-20 + itime=21 ! index of observation time in data array + iuse=22 ! index of use parameter + iddp=24 ! index of dewpoint depression from surface obs + itype=25 ! index of ob type + ilone=26 ! index of longitude (degrees) + ilate=27 ! index of latitude (degrees) + + allocate(ocld(nvarcld_p)) + allocate(cld_cover_obs(nsig)) + allocate(pcp_type_obs(nsig)) + zlev_clr = 3650._r_kind + allocate(cldwater_obs(nsig)) + allocate(cldice_obs(nsig)) + + scale=one + +! Prepare data + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin)then + write(*,*) "NOT_in_anybin" + cycle + endif + + oelvtn = data(istnelv,i) + dlat=data(ilat,i) + dlon=data(ilon,i) + + ikx=nint(data(itype,i)) + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin=',nobs_bins,ibin + +! Check Haze and Dust station + data(iuse,i)=0 + + if(data(iuse,i) > 50 ) cycle ! do not use this data + ovis = data(ivis,i) + + ocld=miss_obs_int + do j=1,3 + cldamt = data(icldamt+j-1,i) ! cloud amount + cldhgt = int(data(icldhgt+j-1,i)) ! cloud bottom height + if(cldamt < spval_p .and. cldhgt < spval_p) then + if(abs(cldamt-0._r_kind) < 0.0001_r_kind) then + ocld(j)=0 !msky='CLR' + cldhgt=spval_p + elseif(abs(cldamt-13._r_kind) < 0.0001_r_kind) then + ocld(j)=1 !msky='FEW' + elseif(abs(cldamt-11._r_kind) < 0.0001_r_kind) then + ocld(j)=2 !msky='SCT' + elseif(abs(cldamt-12._r_kind) < 0.0001_r_kind) then + ocld(j)=3 !msky='BKN' + elseif((abs(cldamt-8._r_kind) < 0.0001_r_kind) .or. & + (abs(cldamt-9._r_kind) < 0.0001_r_kind)) then + ocld(j)=4 ! msky='OVC' msky='VV ' + elseif(abs(cldamt-1._r_kind) < 0.0001_r_kind) then + ocld(j)=1 + elseif(abs(cldamt-2._r_kind) < 0.0001_r_kind .or. & + abs(cldamt-3._r_kind) < 0.0001_r_kind ) then + ocld(j)=2 + elseif(cldamt > 3.5_r_kind .and. cldamt < 6.5_r_kind ) then + ocld(j)=3 + elseif(abs(cldamt-7._r_kind) < 0.0001_r_kind ) then + ocld(j)=4 + else + ocld(j) = miss_obs_int ! wrong cloud observation type + cldhgt = spval_p + endif + if(cldhgt > 0.0_r_kind ) then + ocld(6+j) = cldhgt + else + ocld(j) = miss_obs_int + ocld(6+j) = miss_obs_int + endif + endif + enddo ! j + + owx='' + do j=1,3 + awx = data(iwthr+j-1,i) ! weather + mwx=' ' + if(awx>=10._r_kind .and.awx<=12._r_kind ) mwx='BR ' + if(awx>=110._r_kind.and.awx<=112._r_kind) mwx='BR ' + if(awx==5._r_kind .or. awx==105._r_kind) mwx='HZ ' + if(awx>=40._r_kind .and.awx<=49._r_kind ) mwx='FG ' + if(awx>=130._r_kind.and.awx<=135._r_kind) mwx='FG ' + if(awx>=50._r_kind .and.awx<=59._r_kind ) mwx='DZ ' + if(awx>=150._r_kind.and.awx<=159._r_kind) mwx='DZ ' + if(awx>=60._r_kind .and.awx<=69._r_kind ) mwx='RA ' + if(awx>=160._r_kind.and.awx<=169._r_kind) mwx='RA ' + if(awx>=70._r_kind .and.awx<=78._r_kind ) mwx='SN ' + if(awx>=170._r_kind.and.awx<=178._r_kind) mwx='SN ' + if(awx==79._r_kind .or. awx==179._r_kind) mwx='PE ' + + if(awx>=80._r_kind .and.awx<=90._r_kind ) mwx='SH ' + if(awx>=180._r_kind.and.awx<=187._r_kind) mwx='SH ' + if(awx>=91._r_kind .and.awx<=99._r_kind ) mwx='TH ' + if(awx>=190._r_kind.and.awx<=196._r_kind) mwx='TH ' + + if (j==1) startwx=1 + if (j==2) startwx=4 + if (j==3) startwx=7 + endwx=startwx+2 + owx(startwx:endwx)=mwx + enddo + + wthr_type=miss_obs_int + if ( owx=='SH' ) wthr_type=16 + if ( owx=='TH' ) wthr_type=1 + if ( owx=='RA' ) wthr_type=11 + if ( owx=='SN' ) wthr_type=12 + if ( owx=='PL' ) wthr_type=13 + if ( owx=='DZ' ) wthr_type=14 + if ( owx=='UP' ) wthr_type=15 + if ( owx=='BR' ) wthr_type=21 + if ( owx=='FG' ) wthr_type=22 + + if(data(ivis,i) >= spval_P) then + ocld(13)=miss_obs_int + else + if(data(ivis,i) > 100.0_r_kind ) then + ocld(13)=int(data(ivis,i)) + elseif(data(ivis,i) <=100.0_r_kind .and. data(ivis,i) > 0.0_r_kind ) then + ocld(13)=100 + write(6,*) 'setupcldtot, Warning: change visibility to 100 m !!!' + endif + endif + + ! background profiles in observation location and time + call tintrp3(ges_prsl,p_bk,dlat,dlon,dpres1d,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp3(ges_ql,ql_bk,dlat,dlon,dpres1d,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp3(ges_qi,qi_bk,dlat,dlon,dpres1d,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp3(ges_tsen,t_bk,dlat,dlon,dpres1d,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp3(ges_q,q_bk,dlat,dlon,dpres1d,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a11(ges_z,z_bk,dlat,dlon,dtime, & + hrdifsig,mype,nfldsig) + call tintrp2a1(geop_hgtl,h_bk,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + + cld_cover_obs=miss_obs_single + pcp_type_obs=miss_obs_int + if (ocld(1) > 999) then + cycle + endif + + call cloudCover_surface_col(mype,nsig,cld_bld_hgt,h_bk,z_bk, & + nvarcld_p,ocld,oelvtn,wthr_type,pcp_type_obs,vis2qc,cld_cover_obs) + + + cldwater_obs=miss_obs_single + cldice_obs=miss_obs_single + + + call cloudLWC_pseudo(nsig,q_bk,t_bk,p_bk, & + cld_cover_obs,cldwater_obs,cldice_obs) + + obzero =0 + do k=1,nsig + qob=miss_obs_real + if (cldwater_obs(k) > -0.000001_r_single) then + if (cldice_obs(k) > -0.000001_r_single) then + qob=cldwater_obs(k)+cldice_obs(k) + else + qob=cldwater_obs(k) + endif + else + if (cldice_obs(k) > -0.000001_r_single) then + qob=cldice_obs(k) + endif + endif + + ! make sure very small background values are set to 0 + if (ql_bk(k) < 0.000001_r_single) ql_bk(k)=0.0_r_single + if (qi_bk(k) < 0.000001_r_single) qi_bk(k)=0.0_r_single + + if (qob < 99._r_single) then + + qges=(ql_bk(k)+qi_bk(k))*1000._r_single + + if (qob > 0.0_r_single .and. qges > 0.0_r_single) then + if (qob < qges) then + dontobcount=dontobcount+1 + qob = qges + endif + endif + ! these are just for error checking + obcount=obcount+1 + if (qob < qobmin) qobmin=qob + if (qob > qobmax) qobmax=qob + + + ! Compute innovations + ddiff=(qob-qges) + !write(*,'(3I,5f15.4)') mype,i,k,cld_cover_obs(k),cldwater_obs(k),cldice_obs(k),qob,ddiff + + + luse(i)=.true. + muse(i)=.true. + + !******************************************************************************* + if (i_cloud_q_innovation /= 2) then + write(*,*) "Warning - setupcldtot: this code version is only designed for i_cloud_q_innovation == 2" + return + else + +!!!!!Warning you hard coded q values here + warning_your_hard_coded_values_here: associate(is=>4,ibin=>1) + !ibin = 1 ! q ob bin + !is = 4 ! q ob type number, these come from list in gsiparm + + ! Within an association construct, "is" and "ibin" as + ! associats, would be purely local, i.e. significant + ! only in this construct. + ! + ! On the other hand, %(idv,iob,ich) are sequential indices + ! referencing to the input observation stream. While in + ! principle, one can hard-wire these values as long as + ! values are unique, variable "is" itself is a higher level + ! looping index with an intent(in) attribute, thus should + ! not be modified within this routine. + + allocate(my_headq) + call qNode_appendto(my_headq,qhead(ibin)) + + my_headq%idv = is + my_headq%iob = i + my_headq%ich0= 0 + my_headq%elat= data(ilat,i) + my_headq%elon= data(ilon,i) + end associate warning_your_hard_coded_values_here + + ! Set (i,j,k) indices of guess gridpoint that bound obs location + mm1=mype+1 + dpres=k + call get_ijk(mm1,dlat,dlon,dpres,my_headq%ij,my_headq%wij) + + pressure=p_bk(k)*10.0_r_kind + cloudqvis= ruc_saturation(t_bk(k),pressure) + + if (qob > 0._r_single) then + + if (q_bk(k) < cloudqvis) then + qv_ob=cloudqvis + ddiff=qv_ob-q_bk(k) + q_build_count=q_build_count+1 + else + qv_ob=q_bk(k) + ddiff=qv_ob-q_bk(k) + q_build0_count=q_build0_count+1 + endif + + elseif (qob > -0.000001_r_single) then + + if( q_bk(k) > cloudqvis*rh_clear_p) then + qv_ob=cloudqvis*rh_clear_p + ddiff=qv_ob-q_bk(k) + q_clear_count=q_clear_count+1 + else + qv_ob=q_bk(k) + ddiff=qv_ob-q_bk(k) + q_clear0_count=q_clear0_count+1 + endif + else + cycle + endif + + q_obcount=q_obcount+1 + + error=one/(cloudqvis*3.E-01_r_kind) + ratio_errors=1.0_r_kind + val = error*ddiff + + my_headq%res = ddiff + my_headq%err2 = error**2 + my_headq%raterr2= ratio_errors**2 + my_headq%time = dtime + my_headq%b = 10.0_r_single !cvar_b(ikx) + my_headq%pg = 0.0_r_single !cvar_pg(ikx) + my_headq%jb = var_jb + my_headq%luse = luse(i) + + + ! Save select output for diagnostic file + if(conv_diagsave .and. luse(i))then + iip=iip+1 + + rstation_id = data(id,i) + + err_input = error ! data(ier2,i) + err_adjst = error ! data(ier,i) + + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if (binary_diag) call contents_binary_diag_ + if (netcdf_diag) call contents_netcdf_diag_ + + if (i_ens_mean == 1) then + + all_qv_obs(1:20,iip)=rdiagbufp(1:20,iip) + all_qv_obs(24,iip)=dlat + all_qv_obs(25,iip)=dlon + all_qv_obs(26,iip)=k + all_qv_obs(27,iip)=dtime + all_qv_obs(28,iip)=rstation_id + all_qv_obs(29,iip)=cloudqvis + + endif + endif !conv_diagsave .and. luse(i)) + + endif !i_cloud_q_innovation + + endif !end valid ob + enddo !end k loop + enddo ! end loop over obs + + write(*,'(A,7I12)') 'qobcount',mype,q_obcount,obcount,q_build_count, & + q_build0_count,q_clear_count,q_clear0_count + + deallocate(cld_cover_obs,pcp_type_obs) + deallocate(ocld) + deallocate(cldwater_obs,cldice_obs) + endif !i_ens_mem .ne. 2 + + write(myfile, "(A11,I3.3)") myname,mype + + if (i_ens_mean == 1) then + + open(33,file=myfile,form='UNFORMATTED') + write(33) q_obcount,iip,nrealcld + write(33) all_qv_obs(:,1:iip) + write(33) cdiagbufp(1:iip) + close(33) + + deallocate(all_qv_obs) + + elseif (i_ens_mean == 2) then + inquire(file=myfile,exist=lhere) + if (.not.lhere) then + write(*,*)'SETUPCLDTOT: **Warning** file ',& + trim(myfile),' does NOT exist.' + return + endif + + open(33,file=myfile,form='unformatted') + read(33,iostat=istat1) q_obcount,iip,nrealcld + allocate(all_qv_obs(nrealcld,q_obcount)) + allocate(stationbuf(q_obcount)) + read(33,iostat=istat2) all_qv_obs + read(33,iostat=istat3) stationbuf + if (istat1/=0 .or. istat2/=0 .or. istat3/=0) then + write(*,*)'SETUPCLDTOT: ***ERROR*** reading file ',& + trim(myfile),' istat1,istat2,istat3=',istat1,istat2,istat3,' Terminate execution' + call stop2(329) + endif + close(33) + + do i=1,q_obcount + + qv_ob=all_qv_obs(17,i) + dlat=all_qv_obs(24,i) + dlon=all_qv_obs(25,i) + k=all_qv_obs(26,i) + dtime=all_qv_obs(27,i) + rstation_id=all_qv_obs(28,i) + station_id=stationbuf(i) + + ! background profiles in observation location and time + call tintrp3(ges_q,q_bk,dlat,dlon,dpres1d,dtime, & + hrdifsig,nsig,mype,nfldsig) + + ddiff=qv_ob-q_bk(k) + + if(conv_diagsave)then + if (binary_diag) call contents_binary_diag_mem_ + if (netcdf_diag) call contents_netcdf_diag_mem_ + endif + enddo + + deallocate(all_qv_obs) + deallocate(stationbuf) + + endif !i_ens_mem + + !! Write information to diagnostic file + if(conv_diagsave)then + if (i_cloud_q_innovation == 2 .and. iip>0) then + if(netcdf_diag) call nc_diag_write + if(binary_diag)then + write(7)' q',nchar,nreal,iip,mype,ioff0 + write(7)cdiagbufp(1:iip),rdiagbufp(:,1:iip) + endif + deallocate(cdiagbufp,rdiagbufp) + elseif (i_cloud_q_innovation == 1 .and. ii>0) then + deallocate(cdiagbuf,rdiagbuf) + write(*,*) "Setupcldtot: DIAG not setup for i_cloud_q_innovation == 1!!!" + elseif (i_cloud_q_innovation == 3) then + deallocate(cdiagbuf,rdiagbuf) + deallocate(cdiagbufp,rdiagbufp) + write(*,*) "Setupcldtot: DIAG not setup for i_cloud_q_innovation == 3!!!" + endif + endif + + ! Release memory of local guess arrays + call final_vars_ + + deallocate(h_bk,t_bk,q_bk) + deallocate(p_bk,ql_bk,qi_bk,dpres1d) + + +!******************************************************************************* +! End of routine + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::ql', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qi', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::z', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::q', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ql ... + varname='ql' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_ql))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ql(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_ql(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_ql(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get qi ... + varname='qi' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qi))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qi(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qi(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qi(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get q ... + varname='q' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_q))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_q(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_q(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + + end subroutine init_vars_ + + subroutine final_vars_ + if(allocated(ges_ps)) deallocate(ges_ps) + if(allocated(ges_ql )) deallocate(ges_ql ) + if(allocated(ges_qi )) deallocate(ges_qi ) + if(allocated(ges_z)) deallocate(ges_z) + if(allocated(ges_tv)) deallocate(ges_tv) + if(allocated(ges_q)) deallocate(ges_q) + end subroutine final_vars_ + + subroutine init_netcdf_diag_ + + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + +! open netcdf diag file + write(string,900) jiter +900 format('conv_cldtot_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + + end subroutine init_netcdf_diag_ + + subroutine contents_binary_diag_ + + cdiagbufp(iip) = station_id ! station id +! force new ob type + rdiagbufp(1,iip) = 199 + rdiagbufp(2,iip) = icsubtype(ikx) ! observation subtype + + rdiagbufp(3,iip) = data(ilate,i) ! observation latitude (degrees) + rdiagbufp(4,iip) = data(ilone,i) ! observation longitude (degrees) + rdiagbufp(5,iip) = data(istnelv,i) ! station elevation (meters) + rdiagbufp(6,iip) = pressure ! observation pressure + rdiagbufp(7,iip) = data(icldhgt,i) ! observation height (meters) + rdiagbufp(8,iip) = dtime-time_offset ! obs time (hours relative to analysis time) + rdiagbufp(9,iip) = 1._r_single ! qc + rdiagbufp(10,iip) = var_jb ! non linear qc b parameter + rdiagbufp(11,iip) = data(iuse,i) ! read_prepbufr data usage flag + + if(muse(i)) then + rdiagbufp(12,iip) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbufp(12,iip) = -one + endif + + rdiagbufp(13,iip) = rwgt ! nonlinear qc relative weight + rdiagbufp(14,iip) = errinv_input ! prepbufr inverse observation error + rdiagbufp(15,iip) = errinv_adjst ! read_prepbufr inverse obs error + rdiagbufp(16,iip) = errinv_final ! final inverse observation error + + rdiagbufp(17,iip) = qv_ob ! observation + rdiagbufp(18,iip) = ddiff ! obs-ges used in analysis + rdiagbufp(19,iip) = ddiff !qob-qges !obs-ges w/o bias correction (future slot) + + rdiagbufp(20,iip) = q_bk(k) !qsges ! guess saturation specific humidity + + end subroutine contents_binary_diag_ + + subroutine contents_binary_diag_mem_ + + cdiagbufp(i) = station_id + rdiagbufp(1:17,i)=all_qv_obs(1:17,i) + rdiagbufp(18,i) = ddiff + rdiagbufp(19,i) = ddiff + rdiagbufp(20,i) = q_bk(k) +! rdiagbufp(21:29,i)=all_qv_obs(21:29,i) +! could be a bug, 1st index max is 23 + end subroutine contents_binary_diag_mem_ + + subroutine contents_netcdf_diag_ + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Type", icsubtype(ikx) ) + call nc_diag_metadata("Observation_Subtype", int(icsubtype(ikx)) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(pressure) ) + call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(1._r_single) ) + call nc_diag_metadata("Setup_QC_Mark", sngl(rmiss_single) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata("Observation", sngl(qv_ob) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(ddiff)) + + end subroutine contents_netcdf_diag_ + + subroutine contents_netcdf_diag_mem_ + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Type", int(all_qv_obs(1,iip)) ) + call nc_diag_metadata("Observation_Subtype", int(all_qv_obs(2,iip)) ) + call nc_diag_metadata("Latitude", sngl(all_qv_obs(3,iip)) ) + call nc_diag_metadata("Longitude", sngl(all_qv_obs(4,iip)) ) + call nc_diag_metadata("Station_Elevation", sngl(all_qv_obs(5,iip)) ) + call nc_diag_metadata("Pressure", sngl(all_qv_obs(6,iip)) ) + call nc_diag_metadata("Height", sngl(all_qv_obs(7,iip)) ) + call nc_diag_metadata("Time", sngl(all_qv_obs(8,iip)) ) + call nc_diag_metadata("Prep_QC_Mark", sngl(all_qv_obs(9,iip)) ) + call nc_diag_metadata("Setup_QC_Mark", sngl(rmiss_single) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(all_qv_obs(11,iip))) + call nc_diag_metadata("Analysis_Use_Flag", sngl(all_qv_obs(12,iip))) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(all_qv_obs(13,iip))) + call nc_diag_metadata("Errinv_Input", sngl(all_qv_obs(14,iip))) + call nc_diag_metadata("Errinv_Adjust", sngl(all_qv_obs(15,iip))) + call nc_diag_metadata("Errinv_Final", sngl(all_qv_obs(16,iip))) + call nc_diag_metadata("Observation", sngl(all_qv_obs(17,iip))) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(ddiff)) + + end subroutine contents_netcdf_diag_mem_ + +#else + + character(len=*),parameter:: myname_=myname//"::setupcldtot" + integer(i_kind):: ier + +! Skip the record, and does nothing + read(lunin,iostat=ier) + if(ier/=0) call die(myname_,'unexpected empty block, iostat =',ier) +#endif + +end subroutine setupcldtot +end module cldtot_setup diff --git a/src/setupco.f90 b/src/gsi/setupco.f90 similarity index 79% rename from src/setupco.f90 rename to src/gsi/setupco.f90 index 6a3e6d7cc..51ba2c0eb 100644 --- a/src/setupco.f90 +++ b/src/gsi/setupco.f90 @@ -1,4 +1,11 @@ -subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& +module colvk_setup + implicit none + private + public:: setup + interface setup; module procedure setupco; end interface + +contains +subroutine setupco(obsLL,odiagLL,lunin,mype,stats_co,nlevs,nreal,nobs,& obstype,isis,is,co_diagsave,init_pass) !$$$ subprogram documentation block @@ -29,6 +36,8 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting ! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) ! . removed (%dlat,%dlon) debris. +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). ! ! input argument list: ! lunin - unit from which to read observations @@ -61,16 +70,26 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& use constants, only : zero,half,one,two,tiny_r_kind use constants, only : cg_term,wgtlim,h300 ! AVT need to find value for co ! use the ozone values for the moment - - use m_obsdiags, only : colvkhead - use obsmod, only : i_colvk_ob_type,dplat,nobskeep + use m_obsdiagNode, only : obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + + use obsmod, only : dplat,nobskeep use obsmod, only : mype_diaghdr,dirname,time_offset,ianldate - use obsmod, only : obsdiags,lobsdiag_allocated,lobsdiagsave + use obsmod, only : lobsdiag_allocated,lobsdiagsave + use obsmod, only: dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use m_obsNode, only: obsNode - use m_colvkNode, only : colvkNode, colvkNode_typecast - use m_obsLList , only : obsLList_appendNode + use m_colvkNode, only : colvkNode + use m_colvkNode, only : colvkNode_appendto + use m_obsLList , only : obsLList use m_obsLList , only : obsLList_tailNode - use obsmod, only : obs_diag,luse_obsdiag + use obsmod, only : luse_obsdiag use gsi_4dvar, only: nobs_bins,hr_obsbin @@ -85,10 +104,12 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& use jfunc, only : jiter,last,miter - use m_dtime, only: dtime_setup, dtime_check, dtime_show + use m_dtime, only: dtime_setup, dtime_check implicit none ! !INPUT PARAMETERS: + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations integer(i_kind) , intent(in ) :: mype ! mpi task id @@ -137,7 +158,7 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& real(r_kind),allocatable,dimension(:,:,:,:):: ges_co - integer(i_kind) i,nlev,ii,jj,iextra,istat,ibin + integer(i_kind) i,nlev,ii,jj,iextra,ibin integer(i_kind) k,j,nz,jc,idia,irdim1,ier,istatus,k1,k2 integer(i_kind) ioff,itoss,ikeep,ierror_toq,ierror_poq integer(i_kind) isolz @@ -158,11 +179,12 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& logical:: l_may_be_passive,proceed logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node type(colvkNode),pointer:: my_head type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + type(obsLList),pointer,dimension(:):: colvkhead + colvkhead => obsLL(:) ! Check to see if required guess fields are available call check_vars_(proceed) @@ -171,11 +193,7 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& ! If require guess vars available, extract from bundle ... call init_vars_ - n_alloc(:)=0 - m_alloc(:)=0 - mm1=mype+1 - ! !********************************************************************************* @@ -188,11 +206,6 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& pobs(j)=1.e10_r_kind end do - if(co_diagsave)then - irdim1=3 - if(lobsdiagsave) irdim1=irdim1+4*miter+1 - allocate(rdiagbuf(irdim1,nlevs,nobs)) - end if ! Locate data for satellite in coinfo arrays itoss =1 @@ -244,18 +257,28 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& ! Handle error conditions if (nlevs>nlev) write(6,*)'SETUPCO: level number reduced for ',obstype,' ', & nlevs,' --> ',nlev - if (nlev == 0) then - if (mype==0) write(6,*)'SETUPCO: no levels found for ',isis - if (nobs>0) read(lunin) - goto 135 - endif - if (itoss==1) then - if (mype==0) write(6,*)'SETUPCO: all obs variances > 1.e4. Do not use ',& - 'data from satellite ',isis + if (nlev == 0 .or. itoss==1)then + if (nlev == 0) then + if (mype==0) write(6,*)'SETUPCO: no levels found for ',isis + end if + if (itoss==1) then + if (mype==0) write(6,*)'SETUPCO: all obs variances > 1.e4. Do not use ',& + 'data from satellite ',isis + end if if (nobs>0) read(lunin) - goto 135 + +! Release memory of local guess arrays + call final_vars_ + + return endif + if(co_diagsave)then + irdim1=3 + if(lobsdiagsave) irdim1=irdim1+4*miter+1 + allocate(rdiagbuf(irdim1,nlevs,nobs)) + end if + ! Read and transform co data read(lunin) data,luse,ioid @@ -462,15 +485,14 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& endif IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + if(in_curbin) then ! Process obs have at least one piece of information that passed qc checks if (.not. last .and. ikeep==1) then allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(colvkhead(ibin),my_node) - my_node => null() + call colvkNode_appendto(my_head,colvkhead(ibin)) my_head%idv = is my_head%iob = ioid(i) @@ -546,78 +568,33 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& ! Link obs to diagnostics structure do k=1,nlevs if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_colvk_ob_type,ibin)%head)) then - obsdiags(i_colvk_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_colvk_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupco: failure to allocate obsdiags',istat - call stop2(260) - end if - obsdiags(i_colvk_ob_type,ibin)%tail => obsdiags(i_colvk_ob_type,ibin)%head - else - allocate(obsdiags(i_colvk_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupco: failure to allocate obsdiags',istat - call stop2(261) - end if - obsdiags(i_colvk_ob_type,ibin)%tail => obsdiags(i_colvk_ob_type,ibin)%tail%next - end if - obsdiags(i_colvk_ob_type,ibin)%n_alloc = obsdiags(i_colvk_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_colvk_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_colvk_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_colvk_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_colvk_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_colvk_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_colvk_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_colvk_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_colvk_ob_type,ibin)%tail%muse(:)=.false. - - obsdiags(i_colvk_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_colvk_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_colvk_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_colvk_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_colvk_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = k - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_colvk_ob_type,ibin)%tail)) then - obsdiags(i_colvk_ob_type,ibin)%tail => obsdiags(i_colvk_ob_type,ibin)%head - else - obsdiags(i_colvk_ob_type,ibin)%tail => obsdiags(i_colvk_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_colvk_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_colvk_ob_type,ibin)%tail)') - end if - if (obsdiags(i_colvk_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupco: index error' - call stop2(262) - end if - endif + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = k ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) endif if(in_curbin) then if(luse_obsdiag)then - obsdiags(i_colvk_ob_type,ibin)%tail%muse(jiter)= (ikeep==1) - obsdiags(i_colvk_ob_type,ibin)%tail%nldepart(jiter)=co_inv(k) - obsdiags(i_colvk_ob_type,ibin)%tail%wgtjo= varinv3(k)*ratio_errors(k)**2 + call obsdiagNode_set(my_diag, wgtjo=varinv3(k)*ratio_errors(k)**2, & + jiter=jiter,muse=(ikeep==1), nldepart=co_inv(k) ) endif if (.not. last .and. ikeep==1) then - !my_head => colvkNode_typecast(obsLList_tailNode(colvkhead(ibin))) - my_node => obsLList_tailNode(colvkhead(ibin)) - if(.not.associated(my_node)) & - call die(myname,'unexpected, associated(my_node) =',associated(my_node)) - my_head => colvkNode_typecast(my_node) + my_head => tailNode_typecast_(colvkhead(ibin)) if(.not.associated(my_head)) & call die(myname,'unexpected, associated(my_head) =',associated(my_head)) - my_node => null() + + my_head%idv = is + my_head%iob = ioid(i) my_head%ipos(k) = ipos(k) my_head%res(k) = co_inv(k) @@ -625,27 +602,18 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& my_head%raterr2(k) = ratio_errors(k)**2 if(luse_obsdiag)then - my_head%diags(k)%ptr => obsdiags(i_colvk_ob_type,ibin)%tail - - my_diag => my_head%diags(k)%ptr - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob .or. & - k /= my_diag%ich ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ich,ibin) =', & - (/is,ioid(i),k,ibin/)) - call perr(myname,'my_head%(idv,iob,ich) =',(/my_head%idv,my_head%iob,k/)) - call perr(myname,'my_diag%(idv,iob,ich) =',(/my_diag%idv,my_diag%iob,my_diag%ich/)) - call die(myname) - endif + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,k,myname,'my_diag:my_head') + my_head%diags(k)%ptr => my_diag endif my_head => null() endif if (co_diagsave.and.lobsdiagsave) then + associate( odiag => my_diag ) idia=3 do jj=1,miter idia=idia+1 - if (obsdiags(i_colvk_ob_type,ibin)%tail%muse(jj)) then + if (odiag%muse(jj)) then rdiagbuf(idia,k,ii) = one else rdiagbuf(idia,k,ii) = -one @@ -653,16 +621,17 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& enddo do jj=1,miter+1 idia=idia+1 - rdiagbuf(idia,k,ii) = obsdiags(i_colvk_ob_type,ibin)%tail%nldepart(jj) + rdiagbuf(idia,k,ii) = odiag%nldepart(jj) enddo do jj=1,miter idia=idia+1 - rdiagbuf(idia,k,ii) = obsdiags(i_colvk_ob_type,ibin)%tail%tldepart(jj) + rdiagbuf(idia,k,ii) = odiag%tldepart(jj) enddo do jj=1,miter idia=idia+1 - rdiagbuf(idia,k,ii) = obsdiags(i_colvk_ob_type,ibin)%tail%obssen(jj) + rdiagbuf(idia,k,ii) = odiag%obssen(jj) enddo + end associate ! odiag endif endif ! (in_curbin) @@ -708,20 +677,31 @@ subroutine setupco(lunin,mype,stats_co,nlevs,nreal,nobs,& close(4) endif -! Jump to this line if problem with data -135 continue - ! Release memory of local guess arrays call final_vars_ ! clean up if(allocated(ges_co)) deallocate(ges_co) - call dtime_show('setupco','diagsave:co',i_colvk_ob_type) if(co_diagsave) deallocate(rdiagbuf) ! End of routine return contains + function tailNode_typecast_(oll) result(ptr_) +!> Cast the tailNode of oll to an colvkNode, as in +!> ptr_ => typecast_(tailNode_(oll)) + + use m_colvkNode, only: colvkNode, typecast_ => colvkNode_typecast + use m_obsLList , only: obsLList , tailNode_ => obsLList_tailNode + use m_obsNode , only: obsNode + implicit none + type(colvkNode),pointer:: ptr_ + type(obsLList ),target ,intent(in):: oll + + class(obsNode),pointer:: inode_ + inode_ => tailNode_(oll) + ptr_ => typecast_(inode_) + end function tailNode_typecast_ subroutine check_vars_ (proceed) logical,intent(inout) :: proceed @@ -761,8 +741,18 @@ subroutine init_vars_ endif end subroutine init_vars_ + subroutine init_netcdf_diag_ + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_ + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_ +! Observation class + character(7),parameter :: obsclass = ' co' + end subroutine contents_netcdf_diag_ + subroutine final_vars_ if(allocated(ges_co)) deallocate(ges_co) end subroutine final_vars_ end subroutine setupco +end module colvk_setup diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 new file mode 100644 index 000000000..a407c71d3 --- /dev/null +++ b/src/gsi/setupdbz.f90 @@ -0,0 +1,1004 @@ +module dbz_setup + implicit none + private + public:: setup + interface setup; module procedure setupdbz; end interface + +contains +subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_diagsave,init_pass) +! modified from setupdbz, now dbz is also a state variable +!$$$ subprogram documentation block +! . . . . +! subprogram: setupdbz compute rhs of oi for radar reflectivity (dBZ) +! prgmmr: carley org: np22 date: 2011-04-05 +! +! abstract: For radar reflectivity observations, this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2011-05-19 carley - Cleaned up fields loaded into dbzptr. +! Removed linearization from inner loop routines +! and placed it here (see jqr and jqli). +! 2011-08-11 carley - Turn on gross error checks. +! 2011-09-19 carley - Include temporary fix from setuprw to prevent out of +! bounds array references associated with dpres obsLL(:) + +!******************************************************************************* + ! Read and reformat observations in work arrays. + read(lunin)data,luse, ioid +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ihgt=4 ! index of obs elevation + idbzob=5 ! index of radar reflectivity observation (dBZ) + iazm=6 ! index of azimuth angle in data array + itime=7 ! index of observation time in data array (hour) ! Analysis relative time! + ikxx=8 ! index of obs type in data array ! from the convinfo file (order in the list) + itilt=9 ! index of tilt angle in data array + ielev=10 ! index of radar elevation + id=11 ! index of station id + iuse=12 ! index of use parameter + ilone=13 ! index of longitude (degrees) + ilate=14 ! index of latitude (degrees) + irange=15 ! index of range in m of obs from radar + ier2=16 ! index of original-original obs error + idbznoise=17 ! index of noise threshold for reflectivity (dBZ) + idmiss2opt=18 ! index of if it is converted from the missing value + + numequal=0 + numnotequal=0 + irefsmlobs=0 + irejrefsmlobs=0 + + +! +! If requested, save select data for output to diagnostic file + if(radardbz_diagsave)then + ii=0 + nchar=1 + ioff0=25 + nreal=27 + if (lobsdiagsave) nreal=nreal+4*miter+1 + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + end if + mm1=mype+1 + scale=one + rsig=nsig + + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! - Observation times are checked in read routine - comment out for now + +! call dtime_setup() + do i=1,nobs + debugging=.false. + if(doradaroneob) debugging=.true. + dtime=data(itime,i) + dlat=data(ilat,i) + dlon=data(ilon,i) + dbznoise=data(idbznoise,i) + dpres=data(ihgt,i) + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + slat=data(ilate,i)*deg2rad + wrange=data(irange,i) + if(debugging) then + print * , "=============" + print *, dlat,dlon,dpres + print *, data(ilate,i),data(ilone,i) + endif + + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + endif + + call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + dpres=dpres-zsges + if(dpres > 10000.0_r_kind) cycle !don't need obs above 10 km + if (dpres rsig)ratio_errors = zero + + +! Interpolate guess dbz to observation location and time. + if(if_model_dbz) then + call tintrp31(ges_dbz,dbzgesin,dlat,dlon,dpres,dtime,& !modified + hrdifsig,mype,nfldsig) + endif +! Interpolate guess qr, qli, and rho to observation location and time. + call tintrp31(ges_qr,qrgesin,dlat,dlon,dpres,dtime,& !modified + hrdifsig,mype,nfldsig) + if( wrf_mass_regional )then + call tintrp31(ges_qs,qsgesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + call tintrp31(ges_qg,qggesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + else if(nems_nmmb_regional) then + call tintrp31(ges_qli,qligesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + endif + call tintrp31(ges_rho,rhogesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + call tintrp31(ges_tsen,tempgesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + + + if( nems_nmmb_regional ) then + qrgesin1 = max(qrgesin,1.e-6_r_kind) + qligesin1 = max(qligesin,1.e-6_r_kind) + else if( wrf_mass_regional ) then + qrgesin1 = max(qrgesin,1.e-6_r_kind) + qsgesin1 = max(qsgesin,1.e-6_r_kind) + qggesin1 = max(qggesin,1.e-5_r_kind) + end if + + if(if_model_dbz) then + rDBZ=dbzgesin + else + if( wrf_mass_regional )then + call hx_dart(qrgesin,qggesin,qsgesin,rhogesin,tempgesin,rDBZ,debugging) + else if( nems_nmmb_regional ) then + write(6,*) "if_model_dbz should be set as .true." + STOP + endif + endif !if_model_dbz + + + if(miter == 0.or.l_hyb_ens) then !ie an enkf run +! DCD 1 March 2019: changed 0.0 to static_gsi_nopcp_dbz +! if(rDBZ < 0_r_kind) rDBZ=0.0_r_kind ! should be the same as in the read_dbz when nopcp=.true. + if(rDBZ < static_gsi_nopcp_dbz) rDBZ=static_gsi_nopcp_dbz ! should be the same as in the read_dbz when nopcp=.true. + endif + if(miter == 0.and.ens_hx_dbz_cut) then !ie an enkf run + if(rDBZ > 60_r_kind) rDBZ=60_r_kind + endif + + jqr = 0.0_r_kind + jqs = 0.0_r_kind + jqg = 0.0_r_kind + + if( .not. if_model_dbz )then + if( wrf_mass_regional ) then + call jqr_dart(qrgesin1,qsgesin1,qggesin1,rhogesin,tempgesin,jqr) + call jqs_dart(qrgesin1,qsgesin1,qggesin1,rhogesin,tempgesin,jqs) + call jqg_dart(qrgesin1,qsgesin1,qggesin1,rhogesin,tempgesin,jqg) + else if( nems_nmmb_regional ) then + write(6,*) "if_model_dbz should be set as .true." + STOP + endif + end if + + + if(rdBZ==data(idbzob,i)) then + numequal=numequal+1 + else + numnotequal=numnotequal+1 + end if + + !--------------Calculate departure from observation----------------! + + + ddiff = data(idbzob,i) - rdBZ + if(miter > 0.and..not.l_hyb_ens) ddiff = max(min(ddiff,20.0_r_kind),-20.0_r_kind) + + + if(debugging) print *, "DDIFF1: ",ddiff,data(idbzob,i),rdBZ + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff = maginnov + error=one/magoberr + ratio_errors=one + endif + + if (doradaroneob) then + if(oneobvalue > -900_r_kind) then + data(idbzob,i) = oneobvalue + ddiff = data(idbzob,i) - rdBZ + else + ddiff = oneobddiff + data(idbzob,i) = rdBZ+ddiff + endif + endif !oneob + if(rdBZ >= 5_r_kind) irefsmlobs=irefsmlobs+1 + + if(debugging) print *, "DDIFF2: ",ddiff,data(idbzob,i),rdBZ + +! Gross error checks + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + + residual = abs(ddiff) + ratio = residual/obserrlm + if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if ( inflate_obserr .and. (ratio-cgross(ikx)) <= cgross(ikx) .and. ratio_errors >= tiny_r_kind) then + ! Since radar reflectivity can be very different from the model background + ! good observations may be rejected during this QC step. However, if these observations + ! are allowed through, they can yield problems with convergence. Therefore the error + ! is inflated here up to twice the observation error in a manner that is + ! proportional to the residual. If this IF-TEST for this inflation fails, the + ! observation is subsequently rejected. + + obserror = residual/cgross(ikx) + error = one/obserror + + else + if (luse(i)) awork(4) = awork(4)+one + error = zero + ratio_errors = zero + + if(rdBZ <= 5_r_kind) irejrefsmlobs=irejrefsmlobs+1 + end if + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + !-- if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_dbz_ob_type,ibin)%tail%muse(nobskeep) + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + + val = error*ddiff + +! Compute penalty terms (linear & nonlinear qc). + if(luse(i))then + exp_arg = -half*val**2 + rat_err2 = ratio_errors**2 + val2=val*val + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_w=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_w*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + jsig = dpres + jsig=max(1,min(jsig,nsig)) + awork(6*nsig+jsig+100)=awork(6*nsig+jsig+100)+val2*rat_err2 + awork(5*nsig+jsig+100)=awork(5*nsig+jsig+100)+one + awork(3*nsig+jsig+100)=awork(3*nsig+jsig+100)+valqc + end if +! Loop over pressure level groupings and obs to accumulate +! statistics as a function of observation type. + ress = scale*ddiff + ressw = ress*ress + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + do k = 1,npres_print + if(presw >=ptop(k) .and. presw<=pbot(k))then + bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count + bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ddiff ! bias + bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 + bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + end do + end if + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + end if + + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if ( .not. last .and. muse(i)) then + + allocate(my_head) + call dbzNode_appendto(my_head,dbzhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j,k) indices of guess gridpoint that bound obs location + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) + + my_head%raterr2 = ratio_errors**2 + my_head%res = ddiff + my_head%err2 = error**2 + my_head%time = dtime + my_head%luse = luse(i) + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%jqr = jqr + if ( wrf_mass_regional ) then + my_head%jqs = jqs + my_head%jqg = jqg + end if + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif +! Save select output for diagnostic file + if(radardbz_diagsave .and. luse(i) )then + + + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + + end if + end do + +! Release memory of local guess arrays + call final_vars_ + + +! Write information to diagnostic file + if(radardbz_diagsave .and. ii>0 )then + + write(string,600) jiter +600 format('radardbz_',i2.2) + diag_file=trim(dirname) // trim(string) + if(init_pass) then + open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + else + inquire(file=trim(diag_file),exist=diagexist) + if (diagexist) then + open(lu_diag,file=trim(diag_file),form='unformatted',status='old',position='append') + else + open(lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + endif + endif + if(init_pass .and. mype == 0) then + write(lu_diag) ianldate + write(6,*)'SETUPDBZ: write time record to file ',& + trim(diag_file), ' ',ianldate + endif + + write(lu_diag)'dbz',nchar,nreal,ii,mype,ioff0 + write(lu_diag)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + close(lu_diag) + end if + write(6,*)'mype, irefsmlobs,irejrefsmlobs are ',mype,' ',irefsmlobs, ' ',irejrefsmlobs +! close(52) !simulated obs +! End of routine + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + if( if_model_dbz ) then + call gsi_metguess_get ('var::dbz', ivar, istatus ) + proceed=proceed.and.ivar>0 + end if + call gsi_metguess_get ('var::qr', ivar, istatus ) + proceed=proceed.and.ivar>0 + if(wrf_mass_regional)then + call gsi_metguess_get ('var::qs', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qg', ivar, istatus ) + proceed=proceed.and.ivar>0 + end if + if(nems_nmmb_regional)then + call gsi_metguess_get ('var::qli', ivar, istatus ) + proceed=proceed.and.ivar>0 + end if + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2 + real(r_kind),dimension(:,:,:),pointer:: rank3 + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + if(if_model_dbz)then + ! get dbz .... + varname='dbz' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_dbz))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_dbz(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_dbz(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_dbz(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + endif + +! get qr ... + varname='qr' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qr))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qr(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qr(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qr(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + if(wrf_mass_regional)then +! get qs ... + varname='qs' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qs))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qs(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qs(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qs(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + +! get qg ... + varname='qg' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qg))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qg(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qg(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qg(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + + end if + + if(nems_nmmb_regional)then +! get qli ... + varname='qli' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qli))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qli(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qli(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qli(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + end if + + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_dbz_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) + rdiagbuf(6,ii) = presw ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = (dtime*r60)-time_offset ! obs time (sec relative to analysis time) + rdiagbuf(9,ii) = rmiss_single ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use,-1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (dBZ)**-1 + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (dBZ)**-1 + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (dBZ)**-1 + rdiagbuf(17,ii) = data(idbzob,i) ! radar reflectivity observation (dBZ) + rdiagbuf(18,ii) = ddiff ! obs-ges (dBZ) + rdiagbuf(19,ii) = data(idbzob,i)-rdBZ ! obs-ges w/o bias correction (dBZ) (future slot) + rdiagbuf(20,ii)=data(iazm,i)*rad2deg ! azimuth angle + rdiagbuf(21,ii)=data(itilt,i)*rad2deg ! tilt angle + rdiagbuf(22,ii)=data(irange,i) ! the range in km + rdiagbuf(23,ii)=data(idmiss2opt,i) ! the range in km + + rdiagbuf(23,ii) = 1.e+10_r_single ! ges ensemble spread (filled in EnKF) + rdiagbuf(24,ii) = 1.e+10_r_single ! ges ensemble spread (filled in EnKF) + + if (lobsdiagsave) then + write(6,*)'wrong here, stop in setupdbz.f90 ' + stop + ioff=nreal + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' dbz' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(ielev,i)) ) + call nc_diag_metadata("Pressure", sngl(presw) ) + call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(zero) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ! ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(data(idbzob,i)) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(idbzob,i)-rdBZ) ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen" , odiag%obssen ) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps)) deallocate(ges_ps) + if(allocated(ges_qr)) deallocate(ges_qr) + if(allocated(ges_qs)) deallocate(ges_qs) + if(allocated(ges_qg)) deallocate(ges_qg) + if(allocated(ges_qli)) deallocate(ges_qli) + if(allocated(ges_dbz)) deallocate(ges_dbz) + end subroutine final_vars_ +end subroutine setupdbz +end module dbz_setup diff --git a/src/gsi/setupdbz_lib.f90 b/src/gsi/setupdbz_lib.f90 new file mode 100644 index 000000000..d70d0cffd --- /dev/null +++ b/src/gsi/setupdbz_lib.f90 @@ -0,0 +1,254 @@ +! History log + +! 2017-05-12 Johnson, Y. Wang and X. Wang - define reflectivity opeator and its adjoint for WSM6 scheme, POC: xuguang.wang@ou.edu + +module setupdbz_lib +public :: hx_dart,jqr_dart,jqs_dart,jqg_dart +contains +subroutine hx_dart(qrgesin0,qggesin0,qsgesin0,rhogesin,tempgesin,rDBZ,debugging) + use kinds, only: r_kind,r_double,i_kind + use obsmod, only: static_gsi_nopcp_dbz +implicit none +real(r_kind) :: qrgesin0,qsgesin0,qggesin0 +real(r_kind) :: qrgesin,qsgesin,qggesin,rhogesin,tempgesin,rDBZ +real(r_kind) :: zqr,zqg,zqs +logical :: debugging +real(r_kind) :: param_r,param_dry_g,param_wet_g,param_dry_s,param_wet_s +real(r_kind) ::n0r,n0s,n0g,rhor,rhos,rhog,dielectric,pi + + qrgesin=qrgesin0 + qsgesin=qsgesin0 + qggesin=qggesin0 + + +pi=3.14159_r_kind +dielectric=0.224_r_kind +n0r=8e6_r_kind +n0s=3e6_r_kind !(2e6) !*exp(0.12*(min(273.15,tempgesin)-273.15)) !this is n0s in WSM6 paper, dif. from DART constant of 3e6 +n0g=4e6_r_kind +rhos=100_r_kind +rhor=1000_r_kind +rhog=500_r_kind !this is rhog in WSM6 paper, dif. from DART 400 + +param_r=(7.2e20_r_kind)/(((pi*rhor)**1.75_r_kind)*(n0r**0.75_r_kind)) +param_dry_g=dielectric*(rhog/rhor)*(rhog/rhor)*(7.2e20_r_kind)/(((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind)) +param_wet_g=(7.2e20_r_kind)/((((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind))**0.95_r_kind) +param_wet_s=(7.2e20_r_kind)/(((pi*rhos)**1.75_r_kind)*(n0s**0.75_r_kind)) +param_dry_s=dielectric*(rhos/rhor)*(rhos/rhor)*param_wet_s + + +zqr=param_r*((rhogesin*qrgesin)**1.75_r_kind) +if (tempgesin < 273.15_r_kind) then + zqr=0_r_kind + zqg=param_dry_g*((rhogesin*qggesin)**1.75_r_kind) + zqs=param_dry_s*((rhogesin*qsgesin)**1.75_r_kind) +else if(tempgesin < 278.15_r_kind) then + zqg=param_wet_g*((rhogesin*qggesin)**1.6675_r_kind) + zqs=param_wet_s*((rhogesin*qsgesin)**1.75_r_kind) +else + zqg=0_r_kind + zqs=0_r_kind +endif +rDBZ=zqr+zqg+zqs +if (rdBZ > 1.0e-3_r_kind) then + rdBZ=10_r_kind*log10(rdBZ) +else + rdBZ=-30_r_kind +endif +if(rdBZ obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ikxx=1 ! index of ob type + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + itime=4 ! index of observation time in data array + ihgt=5 ! index of obs vertical coordinate in data array(height-m) + ielva=6 ! index of elevation angle(radians) + iazm=7 ! index of azimuth angle(radians) in data array + inls=8 ! index of number of laser shots + incls=9 ! index of number of cloud laser shots + iatd=10 ! index of atmospheric depth + ilob=11 ! index of lidar observation + ier=12 ! index of obs error + id=13 ! index of station id + iuse=14 ! index of use parameter + idomsfc=15 ! index of dominate surface type + iskint=16 ! index of skin temperature + iff10 = 17 ! index of 10 m wind factor + isfcr = 18 ! index of surface roughness + ilone=19 ! index of longitude (degrees) + ilate=20 ! index of latitude (degrees) + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ihgt,k) == data(ihgt,l) .and. & + data(iazm,k) == data(iazm,l) .and. & ! jsw check azmth angle + data(ielva,k) == data(ielva,l) .and. & ! jsw check eleveaiton angle + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + end do + end do + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + ii=0 + nchar=1 + ioff0=27 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (save_jacobian) then + nnz = 2 ! number of non-zero elements in dH(x)/dx profile + nind = 1 + call new(dhx_dx, nnz, nind) + nreal = nreal + size(dhx_dx) + endif + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + if(netcdf_diag) call init_netcdf_diag_ + end if + + scale=one + rsig=float(nsig) + mm1=mype+1 + + call dtime_setup() + do i=1,nobs +! Convert obs lats and lons to grid coordinates + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + dpres=data(ihgt,i) + + ikx=nint(data(ikxx,i)) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Save observation latitude. This is needed when converting +! geopotential to geometric height (hges --> zges below) + slat=data(ilate,i)*deg2rad + +! Interpolate log(surface pressure), model terrain, +! and log(pres) at mid-layers to observation location. + factw=data(iff10,i) + if(sfcmod_gfs .or. sfcmod_mm5) then + sfcr = data(isfcr,i) + skint = data(iskint,i) + isli = data(idomsfc,i) + call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) + end if + + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a1(geop_hgtl,hges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + + call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& ! jsw + mype,nfldsig) ! jsw + dpres=dpres-zsges !jsw need to adjust dpres by zsges + + +! Convert geopotential height at layer midpoints to geometric height using +! equations (17, 20, 23) in MJ Mahoney's note "A discussion of various +! measures of altitude" (2001). Available on the web at +! http://mtp.jpl.nasa.gov/notes/altitude/altitude.html +! +! termg = equation 17 +! termr = equation 21 +! termrg = first term in the denominator of equation 23 +! zges = equation 23 + + sin2 = sin(slat)*sin(slat) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do k=1,nsig + zges(k) = (termr*hges(k)) / (termrg-hges(k)) ! eq (23) + end do + +! Given observation height, (1) adjust 10 meter wind factor if +! necessary, (2) convert height to grid relative units, (3) compute +! compute observation pressure (for diagnostic purposes only), and +! (4) compute location of midpoint of first model layer above surface +! in grid relative units + +! Adjust 10m wind factor if necessary. Rarely do we have a +! lidar obs within 10 meters of the surface. Almost always, +! the code below resets the 10m wind factor to 1.0 (i.e., no +! reduction in wind speed due to surface friction). + +! adjust wind near surface jsw + if (dpres10)then + term = (zges(1)-dpres)/(zges(1)-ten) + term = min(max(term,zero),one) + if(zges(1)<10) term=1 + factw = one-term+factw*term + endif + else + factw=one + endif + + +! Convert observation height (in dpres) from meters to grid relative +! units. Save the observation height in zob for later use. + zob = dpres + call grdcrd1(dpres,zges,nsig,1) + +! Set indices of model levels below (k1) and above (k2) observation. +! wm - updated so {k1,k2} are at min {1,2} and at max {nsig-1,nsig} + k=dpres + k1=min(max(1,k),nsig-1) + k2=min(k1+1,nsig) +! k1=max(1,k) - old method +! k2=min(k+1,nsig) - old method + +! Compute observation pressure (only used for diagnostics) + dz = zges(k2)-zges(k1) + dlnp = prsltmp(k2)-prsltmp(k1) + pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1)) + presw = ten*exp(pobl) + +! Determine location in terms of grid units for midpoint of +! first layer above surface + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp,nsig,-1) + +! Check to see if observation is below midpoint of first +! above surface layer. If so, set rlow to that difference + + rlow=max(sfcchk-dpres,zero) + +! Check to see if observation is above midpoint of layer +! at the top of the model. If so, set rhgh to that difference. + rhgh=max(dpres-r0_001-nsig,zero) + +! Increment obs counter along with low and high obs counters + if(luse(i))then + awork(1)=awork(1)+one + if(rhgh/=zero) awork(2)=awork(2)+one + if(rlow/=zero) awork(3)=awork(3)+one + end if + +! Set initial obs error to that supplied in BUFR stream. + error = data(ier,i) +! Removed repe_dw, but retained the "+ one" for reproducibility +! for ikx=100 or 101 - wm + if (ictype(ikx)==100 .or. ictype(ikx)==101)error = error + one +! msq error change moved from read_lidar, wrapped to avoid changing +! ADM values + if (ictype(ikx)==200 .or. ictype(ikx)==201) then + if (data(ier,i) > dmiss) then + error = 3.0_r_kind + else + error = data(ier,i) / cos(data(ielva,i)) + endif + endif + + ratio_errors = error/abs(error + 1.0e6_r_kind*rhgh + r8*rlow) + error = one/error + + if(dpres < zero .or. dpres > rsig)ratio_errors = zero + +! Simulate dw wind from guess (forward model) +! First, interpolate u,v guess to observation location + call tintrp31(ges_u,ugesindw,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + call tintrp31(ges_v,vgesindw,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + + +! Next, convert wind components to line of sight value +!wm if (nint(data(isubtype,i))==100.or.nint(data(isubtype,i))==101) then + if (ictype(ikx)==100 .or. ictype(ikx)==101) then +! KNMI product msq + cosazm = -cos(data(iazm,i)) ! cos(azimuth) ! mccarty msq + sinazm = -sin(data(iazm,i)) ! sin(azimuth) ! mccarty msq + else + cosazm = cos(data(iazm,i)) ! cos(azimuth) + sinazm = sin(data(iazm,i)) ! sin(azimuth) + endif + + dwwind=(ugesindw*sinazm+vgesindw*cosazm)*factw + + iz = max(1, min( int(dpres), nsig)) + delz = max(zero, min(dpres - float(iz), one)) + + if (save_jacobian) then + u_ind = getindex(svars3d, 'u') + if (u_ind < 0) then + print *, 'Error: no variable u in state vector. Exiting.' + call stop2(1300) + endif + v_ind = getindex(svars3d, 'v') + if (v_ind < 0) then + print *, 'Error: no variable v in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = iz + sum(levels(1:u_ind-1)) + dhx_dx%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:u_ind-1)) + + dhx_dx%val(1) = (one - delz) * sinazm * factw + dhx_dx%val(2) = delz * sinazm * factw + + dhx_dx%st_ind(2) = iz + sum(levels(1:v_ind-1)) + dhx_dx%end_ind(2) = min(iz + 1,nsig) + sum(levels(1:v_ind-1)) + + dhx_dx%val(3) = (one - delz) * cosazm * factw + dhx_dx%val(4) = delz * cosazm * factw + endif + + ddiff = data(ilob,i) - dwwind + +! Gross check using innovation normalized by error + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if(luse(i))awork(4) = awork(4) + one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + endif + + if (ratio_errors*error <= tiny_r_kind) muse(i) = .false. + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_dw=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_dw*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + + +! Accumulate statistics for obs belonging to this task + if(muse(i))then + if(rwgt < one) awork(21) = awork(21)+one + jsig = dpres + jsig=max(1,min(jsig,nsig)) + awork(jsig+6*nsig+100)=awork(jsig+6*nsig+100)+val2*rat_err2 + awork(jsig+5*nsig+100)=awork(jsig+5*nsig+100)+one + awork(jsig+3*nsig+100)=awork(jsig+3*nsig+100)+valqc + endif + + +! Loop over pressure level groupings and obs to accumulate statistics +! as a function of observation type. + + do k = 1,npres_print + if(presw > ptop(k) .and. presw <= pbot(k)) then + ress =scale*ddiff + ressw=ress*ress + val2 =val*val + rat_err2 = ratio_errors**2 + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + + bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count + bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ddiff ! bias + bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 + bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty + end if + + end do + end if + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag,wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=ddiff) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call dwNode_appendto(my_head,dwhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j,k) indices of guess gridpoint that bound obs location + my_head%dlev = dpres + my_head%factw= factw + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) + + do j=1,8 + my_head%wij(j)=factw*my_head%wij(j) + end do + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2=ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%cosazm = cosazm ! v factor + my_head%sinazm = sinazm ! u factor + my_head%luse = luse(i) + + if(luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + my_head => null() + endif + +! Save select output for diagnostic file + if(conv_diagsave)then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input=one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst + if (err_final>tiny_r_kind) errinv_final=one/err_final + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)' dw',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::u', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::v', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get u ... + varname='u' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_u))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_u(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_u(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get v ... + varname='v' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_v))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_v(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_v(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_dw_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = rmiss_single ! station elevation (meters) + rdiagbuf(6,ii) = presw ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = rmiss_single ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error + rdiagbuf(16,ii) = errinv_final ! final inverse observation error + + rdiagbuf(17,ii) = data(ilob,i) ! observation + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis + rdiagbuf(19,ii) = data(ilob,i)-dwwind ! obs-ges w/o bias correction (future slot) + + rdiagbuf(20,ii) = factw ! 10m wind reduction factor + rdiagbuf(21,ii) = data(ielva,i)*rad2deg! elevation angle (degrees) + rdiagbuf(22,ii) = data(iazm,i)*rad2deg ! bearing or azimuth (degrees) + rdiagbuf(23,ii) = data(inls,i) ! number of laser shots + rdiagbuf(24,ii) = data(incls,i) ! number of cloud laser shots + rdiagbuf(25,ii) = data(iatd,i) ! atmospheric depth + rdiagbuf(26,ii) = data(ilob,i) ! line of sight component of wind orig. + + rdiagbuf(27,ii) = 1.e+10_r_single ! ges ensemble spread (filled in by EnKF) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' dw' + real(r_single),parameter:: missing = -9.99e9_r_single + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", missing ) + call nc_diag_metadata("Pressure", sngl(presw) ) + call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", missing ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(data(ilob,i))) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(ilob,i)-dwwind)) + +!_RT_NC4_TODO +!_RT rdiagbuf(20,ii) = factw ! 10m wind reduction factor +!_RT rdiagbuf(21,ii) = data(ielva,i)*rad2deg! elevation angle (degrees) +!_RT rdiagbuf(22,ii) = data(iazm,i)*rad2deg ! bearing or azimuth (degrees) +!_RT rdiagbuf(23,ii) = data(inls,i) ! number of laser shots +!_RT rdiagbuf(24,ii) = data(incls,i) ! number of cloud laser shots +!_RT rdiagbuf(25,ii) = data(iatd,i) ! atmospheric depth +!_RT rdiagbuf(26,ii) = data(ilob,i) ! line of sight component of wind orig. + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_v )) deallocate(ges_v ) + if(allocated(ges_u )) deallocate(ges_u ) + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps)) deallocate(ges_ps) + end subroutine final_vars_ + +end subroutine setupdw +end module dw_setup diff --git a/src/gsi/setupgust.f90 b/src/gsi/setupgust.f90 new file mode 100644 index 000000000..5a5f799ab --- /dev/null +++ b/src/gsi/setupgust.f90 @@ -0,0 +1,864 @@ +module gust_setup + implicit none + private + public:: setup + interface setup; module procedure setupgust; end interface + +contains +subroutine setupgust(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupgust compute rhs for conventional surface gust +! prgmmr: derber org: np23 date: 2004-07-20 +! +! abstract: For sea surface temperature observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2009-03-10 zhu +! 2011-02-18 zhu - update +! 2013-01-26 parrish - change from grdcrd to grdcrd1, +! tintrp2a to tintrp2a1, tintrp2a11 (to allow successful debug compile on WCOSS) +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-07-21 carley - ensure no division by 0 when calculating presw +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! before retuning to setuprhsall.f90 +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-01-08 pondeca - addd option l_closeobs to use closest obs to analysis +! time in analysis +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig,ges_lnprsl, & + geop_hgtl,sfcmod_gfs,sfcmod_mm5,comp_fact10 + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,ianldate + use m_obsNode, only: obsNode + use m_gustNode, only: gustNode + use m_gustNode, only: gustNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: bmiss,luse_obsdiag + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig + use gridmod, only: get_ij,twodvar_regional + use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,rd,grav,& + two,cg_term,three,four,huge_single,r1000,r3600,& + grav_ratio,flattening,grav,deg2rad,grav_equator,somigliana, & + semi_major_axis,eccentricity + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use rapidrefresh_cldsurf_mod, only: l_closeobs + + implicit none + + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + +! Declare passed variables + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss + character(len=*),parameter:: myname='setupgust' + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) gustges,dlat,dlon,ddiff,dtime,error,r0_001,thirty + real(r_kind) scale,val2,rsig,rsigp,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc,rlow,rhgh,drpx + real(r_kind) term,rwgt + real(r_kind) cg_gust,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 + real(r_kind) presw,factw,dpres,sfcchk + real(r_kind) ratio_errors,tfact,fact,wflate,ten,psges,goverrd,zsges + real(r_kind) slat,sin2,termg,termr,termrg,pobl + real(r_kind) dz,zob,z1,z2,p1,p2,dz21,dlnp21,dstn + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,skint,sfcr + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nsig)::prsltmp,zges + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,ihgt,igust,ipres,id,itime,ikx,imaxerr,iqc + integer(i_kind) iuse,ilate,ilone,istnelv,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,k1,k2,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc,iskint,iff10,isfcr + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin + type(gustNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + real(r_kind) :: hr_offset + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,:) :: ges_ps + real(r_kind),allocatable,dimension(:,:,:) :: ges_z + real(r_kind),allocatable,dimension(:,:,:) :: ges_gust + type(obsLList),pointer,dimension(:):: gusthead + gusthead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + ihgt=5 ! index of observation elevation + igust=6 ! index of gust observation + id=7 ! index of station id + itime=8 ! index of observation time in data array + ikxx=9 ! index of ob type + imaxerr=10 ! index of gust max error + iqc=11 ! index of qulaity mark + iuse=12 ! index of use parameter + idomsfc=13 ! index of dominant surface type + iskint=14 ! index of surface skin temperature + iff10=15 ! index of 10 meter wind factor + isfcr=16 ! index of surface roughness + ilone=17 ! index of longitude (degrees) + ilate=18 ! index of latitude (degrees) + istnelv=19 ! index of station elevation (m) + iprvd=20 ! index of provider + isprvd=21 ! index of subprovider + + mm1=mype+1 + scale=one + rsig=nsig + thirty = 30.0_r_kind + ten = 10.0_r_kind + r0_001=0.001_r_kind + rsigp=rsig+one + goverrd=grav/rd + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for missing data + if (.not. oneobtest) then + do i=1,nobs + if (data(igust,i) > r0_1_bmiss) then + muse(i)=.false. + data(igust,i)=rmiss_single ! for diag output + end if + end do + end if + +! Check for duplicate observations at same location + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Interpolate to get gust at obs location/time + call tintrp2a11(ges_gust,gustges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + +! Process observations with reported height + drpx = zero + dpres = data(ihgt,i) + dstn = data(istnelv,i) + +! Get guess surface elevation and geopotential height profile +! at observation location. + call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) +! Subtract off combination of surface station elevation and +! model elevation depending on how close to surface + fact = zero + if(dpres-dstn > 10._r_kind)then + if(dpres-dstn > 1000._r_kind)then + fact = one + else + fact=(dpres-dstn)/990._r_kind + end if + end if + dpres=dpres-(dstn+fact*(zsges-dstn)) + drpx=0.003*abs(dstn-zsges)*(one-fact) + + if (.not. twodvar_regional) then + call tintrp2a1(geop_hgtl,zges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) +! For observation reported with geometric height above sea level, +! convert geopotential to geometric height. +! Convert geopotential height at layer midpoints to geometric +! height using equations (17, 20, 23) in MJ Mahoney's note +! "A discussion of various measures of altitude" (2001). +! Available on the web at +! http://mtp.jpl.nasa.gov/notes/altitude/altitude.html +! +! termg = equation 17 +! termr = equation 21 +! termrg = first term in the denominator of equation 23 +! zges = equation 23 + + slat = data(ilate,i)*deg2rad + sin2 = sin(slat)*sin(slat) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do k=1,nsig + zges(k) = (termr*zges(k)) / (termrg-zges(k)) ! eq (23) + end do + else + zges(1) = ten + end if + +! Given observation height, (1) adjust 10 meter wind factor if +! necessary, (2) convert height to grid relative units, (3) compute +! compute observation pressure (for diagnostic purposes only), and +! (4) compute location of midpoint of first model layer above surface +! in grid relative units + +! Convert observation height (in dpres) from meters to grid relative +! units. Save the observation height in zob for later use. + zob = dpres + call grdcrd1(dpres,zges,nsig,1) + + if (zob >= zges(1)) then + factw=one + else + factw = data(iff10,i) + if(sfcmod_gfs .or. sfcmod_mm5) then + sfcr = data(isfcr,i) + skint = data(iskint,i) + call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) + end if + if (.not. twodvar_regional) then + if (zob <= ten) then + if(zob < ten)then + term = max(zob,zero)/ten + factw = term*factw + end if + else + term = (zges(1)-zob)/(zges(1)-ten) + factw = one-term+factw*term + end if + else + if(zob < ten)then + term = max(zob,zero)/ten + factw = term*factw + end if + end if + gustges=factw*gustges + endif + +! Compute observation pressure (only used for diagnostics & for type 2**) +! Get guess surface pressure and mid layer pressure +! at observation location. + if (ictype(ikx)>=280 .and. ictype(ikx)<290) then + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + if ((dpres-one) < tiny_r_kind) then + z1=zero; p1=log(psges) + z2=zges(1); p2=prsltmp(1) + elseif (dpres>nsig) then + z1=zges(nsig-1); p1=prsltmp(nsig-1) + z2=zges(nsig); p2=prsltmp(nsig) + drpx = 1.e6_r_kind + else + k=dpres + k1=min(max(1,k),nsig) + k2=max(1,min(k+1,nsig)) + z1=zges(k1); p1=prsltmp(k1) + z2=zges(k2); p2=prsltmp(k2) + endif + + dz21 = z2-z1 + if(dz21==zero)cycle + dlnp21 = p2-p1 + dz = zob-z1 + pobl = p1 + (dlnp21/dz21)*dz + presw = ten*exp(pobl) + else + presw = ten*exp(data(ipres,i)) + end if + + +! Determine location in terms of grid units for midpoint of +! first layer above surface + sfcchk=zero + call grdcrd1(sfcchk,zges,nsig,1) + +! Checks based on observation location relative to model surface and top + rlow=max(sfcchk-dpres,zero) + rhgh=max(dpres-r0_001-rsigp,zero) + if(luse(i))then + awork(1) = awork(1) + one + if(rlow/=zero) awork(2) = awork(2) + one + if(rhgh/=zero) awork(3) = awork(3) + one + end if + +! Adjust observation error +! ratio_errors=error/((data(ier,i)+adjustment)*sqrt(dup(i))) ! qc dependent adjustment + wflate=zero + if (ictype(ikx)==188 .or. ictype(ikx)==288 .or. ictype(ikx)==195 .or. ictype(ikx)==295) then !inflate Mesonet obs error for gusts<7.2m/s + if (data(igust,i)<7.2) then + wflate=4.0_r_kind*data(ier,i) + else + wflate=0.8_r_kind*data(ier,i) + end if + end if + ratio_errors=error/((data(ier,i)+drpx+wflate+1.0e6*rhgh+four*rlow)*sqrt(dup(i))) + error=one/error + +! Compute innovations + ddiff=data(igust,i)-gustges + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross check using innovation normalized by error + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + end if + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_gust=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_gust*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + end if + ress = ddiff*scale + ressw2 = ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + if (abs(data(igust,i)-rmiss_single) >=tiny_r_kind) then + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + end if + + endif + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call gustNode_appendto(my_head,gusthead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + if(luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'gst',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::gust' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get gust ... + varname='gust' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_gust))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_gust(size(rank2,1),size(rank2,2),nfldsig)) + ges_gust(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_gust(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_gust_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = presw ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(igust,i) ! GUST observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(igust,i)-gustges! obs-ges w/o bias correction (K) (future slot) + + rdiagbuf(20,ii) = factw ! 10m wind reduction factor + + rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(22,ii) = zsges ! model terrain at ob location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + + if (lobsdiagsave) then + ioff=ioff0 + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' gust' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", presw ) + call nc_diag_metadata("Height", data(ihgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(igust,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(igust,i)-gustges ) + + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", zsges ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps )) deallocate(ges_ps ) + if(allocated(ges_gust)) deallocate(ges_gust) + end subroutine final_vars_ + +end subroutine setupgust +end module gust_setup diff --git a/src/gsi/setuphowv.f90 b/src/gsi/setuphowv.f90 new file mode 100644 index 000000000..c2b1dfe3e --- /dev/null +++ b/src/gsi/setuphowv.f90 @@ -0,0 +1,700 @@ +module howv_setup + implicit none + private + public:: setup + interface setup; module procedure setuphowv; end interface + +contains +subroutine setuphowv(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuphowv compute rhs of oi for significant waver height +! prgmmr: pondeca org: np23 date: 2014-04-10 +! +! abstract: For significant waver height observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2014-04-10 pondeca +! 2015-03-11 pondeca - Modify for possibility of not using obsdiag +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-08-24 stelios - Added check for errors/=0.0 +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! before retuning to setuprhsall.f90 +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-01-08 pondeca - addd option l_closeobs to use closest obs to analysis +! time in analysis +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use m_obsNode , only: obsNode + use m_howvNode, only: howvNode + use m_howvNode, only: howvNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: rmiss_single, & + lobsdiagsave,nobskeep,lobsdiag_allocated, & + time_offset,bmiss,luse_obsdiag,ianldate + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig,get_ij,twodvar_regional + use constants, only: zero,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & + two,cg_term,huge_single,three + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use rapidrefresh_cldsurf_mod, only: l_closeobs + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_7=0.7_r_kind + + character(len=*),parameter:: myname='setuphowv' + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) howvges,dlat,dlon,ddiff,dtime,error + real(r_kind) scale,val2,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,rwgt + real(r_kind) cg_howv,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,ipres,ihowv,id,itime,ikx,iqc,iskint,iff10 + integer(i_kind) ier2,iuse,ilate,ilone,istnelv,isfcr,iobshgt,izz,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin + type(howvNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + real(r_kind) :: hr_offset + + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !might need at some point + real(r_kind),allocatable,dimension(:,:,:) :: ges_z !might need at some point + real(r_kind),allocatable,dimension(:,:,:) :: ges_howv + + type(obsLList),pointer,dimension(:):: howvhead + howvhead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + ihowv=5 ! index of howv observation + id=6 ! index of station id + itime=7 ! index of observation time in data array + ikxx=8 ! index of ob type + iqc=9 ! index of quality mark + ier2=10 ! index of original obs error + iuse=11 ! index of use parameter + idomsfc=12 ! index of dominant surface type + iskint=13 ! index of surface skin temperature + iff10=14 ! index of 10 meter wind factor + isfcr=15 ! index of surface roughness + ilone=16 ! index of longitude (degrees) + ilate=17 ! index of latitude (degrees) + istnelv=18 ! index of station elevation (m) + iobshgt=19 ! index of observation height (m) + izz=20 ! index of surface height + iprvd=21 ! index of observation provider + isprvd=22 ! index of observation subprovider + + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + end if + + if(.not.in_curbin) cycle + +! Interpolate guess howv to observation location and time + call tintrp2a11(ges_howv,howvges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + ddiff=data(ihowv,i)-howvges + +! Adjust observation error + if (error<=tiny_r_kind.and.data(ier,i)<=tiny_r_kind) cycle !#ww3 + ratio_errors=error/data(ier,i) + error=one/error + +! Gross error checks + + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + +! modify gross check limit for quality mark=3 + if(data(iqc,i) == three ) then + qcgross=r0_7*cgross(ikx) + else + qcgross=cgross(ikx) + endif + + if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + muse(i) = .true. + endif + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep,muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_howv=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_howv*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 !rejected obs + if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs + end if + + ress = ddiff*scale + ressw2 = ress*ress + + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + endif + +! Fill obs diagnostics structure + if(luse_obsdiag)then + call obsdiagNode_set(my_diag,wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call howvNode_appendto(my_head,howvhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + end if + + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'hwv',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::howv' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get howv ... + varname='howv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_howv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_howv(size(rank2,1),size(rank2,2),nfldsig)) + ges_howv(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_howv(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_howv_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = r10*data(ipres,i) ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(ihowv,i) ! HOWV observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(ihowv,i)-howvges! obs-ges w/o bias correction (K) (future slot) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' howv' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", r10*data(ipres,i) ) + call nc_diag_metadata("Height", data(iobshgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(ihowv,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(ihowv,i)-howvges ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps )) deallocate(ges_ps ) + if(allocated(ges_howv)) deallocate(ges_howv) + end subroutine final_vars_ + +end subroutine setuphowv +end module howv_setup diff --git a/src/setuplag.f90 b/src/gsi/setuplag.f90 similarity index 77% rename from src/setuplag.f90 rename to src/gsi/setuplag.f90 index 2dfc3779e..0bad754a0 100644 --- a/src/setuplag.f90 +++ b/src/gsi/setuplag.f90 @@ -1,4 +1,11 @@ -subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +module lag_setup + implicit none + private + public:: setup + interface setup; module procedure setuplag; end interface + +contains +subroutine setuplag(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) !$$$ subprogram documentation block ! . . . . ! subprogram: setuplag compute rhs of oi for lagrangian data @@ -17,6 +24,8 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting ! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) ! . removed (%dlat,%dlon) debris. +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). ! ! input argument list: ! lunin - unit from which to read observations @@ -35,15 +44,25 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) !$$$ use mpeu_util, only: die,perr use kinds, only: r_kind,r_single,r_double,i_kind - use m_obsdiags, only: laghead - use obsmod, only: i_lag_ob_type,obsdiags,& - obsptr,lobsdiagsave,nobskeep,lobsdiag_allocated,& + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: & + lobsdiagsave,nobskeep,lobsdiag_allocated,& time_offset use m_obsNode, only: obsNode use m_lagNode, only: lagNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag + use m_lagNode, only: lagNode_appendto + use m_obsLList,only: obsLLIst + use obsmod, only: luse_obsdiag + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use gsi_4dvar, only: nobs_bins,hr_obsbin,l4dvar use guess_grids, only: nfldsig,hrdifsig use gridmod, only: nsig @@ -55,7 +74,7 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype use convinfo, only: icsubtype,icuse - use m_dtime,only: dtime_setup,dtime_check,dtime_show + use m_dtime,only: dtime_setup,dtime_check use lag_fields, only: orig_lag_num,lag_kfirst use lag_fields, only: lag_nl_vec,lag_u_full,lag_v_full @@ -68,6 +87,9 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) implicit none ! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + logical ,intent(in ) :: conv_diagsave integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs real(r_kind),dimension(7*nsig+100) ,intent(inout) :: awork @@ -110,11 +132,12 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) logical,dimension(nobs):: luse,muse integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node type(lagNode),pointer :: my_head type(obs_diag),pointer :: my_diag + type(obs_diag),pointer :: my_diagLon,my_diagLat + type(obs_diags),pointer :: my_diagLL + type(obsLList),pointer,dimension(:):: laghead + laghead => obsLL(:) call die('setuplag','I don''t believe this code is working -- J.Guo') ! Problems include, data(ilone) and data(ilate) are expected to be in degrees @@ -122,8 +145,6 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) ! in read_lag(). In particular, they should have been set to in degrees to ! be correctly located on the grid. - n_alloc(:)=0 - m_alloc(:)=0 !****************************************************************************** ! Read and reformat observations in work arrays. read(lunin)data,luse,ioid @@ -193,54 +214,32 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) print '(A,I2.2,A,I4.4,A,I4)' ,'mype ',mype,' data ',i,' obsbin ',ibin end if + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + ! Link obs to diagnostics structure if (luse_obsdiag) then do jj=1,2 - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_lag_ob_type,ibin)%head)) then - obsdiags(i_lag_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_lag_ob_type,ibin)%head,stat=istat) - if (istat/=0) call die('setuplag: failure to allocate obsdiags') - obsdiags(i_lag_ob_type,ibin)%tail => obsdiags(i_lag_ob_type,ibin)%head - else - allocate(obsdiags(i_lag_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) call die('setuplag: failure to allocate obsdiags') - obsdiags(i_lag_ob_type,ibin)%tail => obsdiags(i_lag_ob_type,ibin)%tail%next - end if - obsdiags(i_lag_ob_type,ibin)%n_alloc = obsdiags(i_lag_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_lag_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_lag_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_lag_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_lag_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_lag_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_lag_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_lag_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_lag_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_lag_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_lag_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_lag_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_lag_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin)=n_alloc(ibin)+1 - my_diag => obsdiags(i_lag_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = jj - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_lag_ob_type,ibin)%tail)) then - obsdiags(i_lag_ob_type,ibin)%tail => obsdiags(i_lag_ob_type,ibin)%head - else - obsdiags(i_lag_ob_type,ibin)%tail => obsdiags(i_lag_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_lag_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_lag_ob_type,ibin)%tail)') - end if - if (obsdiags(i_lag_ob_type,ibin)%tail%indxglb/=ioid(i)) call die('setuplag: index error') - endif - if (jj==1) obsptr => obsdiags(i_lag_ob_type,ibin)%tail + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = jj ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) then + call perr(myname,'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + call perr(myname,' ich =', jj) + call die(myname) + endif + + select case(jj) + case(1); my_diagLon => my_diag + case(2); my_diagLat => my_diag + end select + my_diag => null() end do end if @@ -384,7 +383,7 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) if ((ratio_errors*error_lat <= tiny_r_kind) .or. & (ratio_errors*error_lon <= tiny_r_kind)) muse(i)=.false. - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_lag_ob_type,ibin)%tail%muse(nobskeep) + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diagLat, jiter=nobskeep, muse=muse(i)) if (iv_debug>=1) then print '(A,I2.2,A,I4.4,A,F12.6,F12.6)','mype ',mype,' data ',i,' ratios ',ratio_lon,ratio_lat @@ -444,15 +443,13 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) endif - ! lon - obsptr%muse(jiter)=muse(i) - obsptr%nldepart(jiter)=reslon - obsptr%wgtjo= (error_lon*ratio_errors)**2 - ! lat if (luse_obsdiag) then - obsdiags(i_lag_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_lag_ob_type,ibin)%tail%nldepart(jiter)=reslat - obsdiags(i_lag_ob_type,ibin)%tail%wgtjo= (error_lat*ratio_errors)**2 + ! lon + call obsdiagNode_set(my_diagLon,wgtjo=(error_lon*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=reslon) + ! lat + call obsdiagNode_set(my_diagLat,wgtjo=(error_lat*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=reslat) endif if (iv_debug>=1) then @@ -467,10 +464,7 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) if (.not. last .and. muse(i)) then allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(laghead(ibin),my_node) - my_node => null() + call lagNode_appendto(my_head,laghead(ibin)) my_head%idv = is my_head%iob = ioid(i) @@ -502,30 +496,11 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) my_head%diag_lat => null() if (luse_obsdiag) then - my_head%diag_lon => obsptr - my_head%diag_lat => obsdiags(i_lag_ob_type,ibin)%tail - - my_diag => my_head%diag_lon - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob .or. & - 1 /= my_diag%ich ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ich,ibin) =', & - (/is,ioid(i),1,ibin/)) - call perr(myname,'my_head%(idv,iob,ich) =',(/my_head%idv,my_head%iob,1/)) - call perr(myname,'my_diag%(idv,iob,ich) =',(/my_diag%idv,my_diag%iob,my_diag%ich/)) - call die(myname) - endif - - my_diag => my_head%diag_lat - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob .or. & - 2 /= my_diag%ich ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ich,ibin) =', & - (/is,ioid(i),2,ibin/)) - call perr(myname,'my_head%(idv,iob,ich) =',(/my_head%idv,my_head%iob,2/)) - call perr(myname,'my_diag%(idv,iob,ich) =',(/my_diag%idv,my_diag%iob,my_diag%ich/)) - call die(myname) - endif + call obsdiagNode_assert(my_diagLon, my_head%idv,my_head%iob,1,myname,'my_diagLon:my_head') + call obsdiagNode_assert(my_diagLat, my_head%idv,my_head%iob,2,myname,'my_diagLat:my_head') + + my_head%diag_lon => my_diagLon + my_head%diag_lat => my_diagLat endif my_head => null() @@ -534,7 +509,22 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) ! Save select output for diagnostic file if(conv_diagsave)then ii=ii+1 - rstation_id = orig_lag_num(dnum,1) + rstation_id = orig_lag_num(dnum,1) + err_input = data(ier,i) + if (ratio_errors*error_lon>tiny_r_kind .and. ratio_errors*error_lat>tiny_r_kind) then + err_final_lon = one/(ratio_errors*error_lon)*rad2deg + err_final_lat = one/(ratio_errors*error_lat)*rad2deg + else + err_final_lon = huge_single + err_final_lat = huge_single + endif + errinv_input = huge_single + errinv_final_lon = huge_single + errinv_final_lat = huge_single + if (err_input>tiny_r_kind) errinv_input=one/err_input + if (err_final_lon>tiny_r_kind) errinv_final_lon=one/err_final_lon + if (err_final_lat>tiny_r_kind) errinv_final_lat=one/err_final_lat + write(cdiagbuf(ii),fmt='(I5.5)') int(rstation_id) rdiagbuf(1,ii) = ictype(ikx) ! observation type @@ -552,21 +542,6 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) rdiagbuf(8,ii) = -one endif - err_input = data(ier,i) - if (ratio_errors*error_lon>tiny_r_kind .and. ratio_errors*error_lat>tiny_r_kind) then - err_final_lon = one/(ratio_errors*error_lon)*rad2deg - err_final_lat = one/(ratio_errors*error_lat)*rad2deg - else - err_final_lon = huge_single - err_final_lat = huge_single - endif - errinv_input = huge_single - errinv_final_lon = huge_single - errinv_final_lat = huge_single - if (err_input>tiny_r_kind) errinv_input=one/err_input - if (err_final_lon>tiny_r_kind) errinv_final_lon=one/err_final_lon - if (err_final_lat>tiny_r_kind) errinv_final_lat=one/err_final_lat - rdiagbuf(9,ii) = rwgt ! nonlinear qc relative weight rdiagbuf(10,ii)= errinv_input ! prepbufr inverse obs error rdiagbuf(11,ii)= errinv_final_lon ! final inverse observation error @@ -580,9 +555,13 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) ioff=ioff0 if (lobsdiagsave) then + associate(odiag => my_diagLat) + ! Logic here seems to be only for one of two diag components, + ! according to its original implementation, for my_diagLat only. + ! Is it the original intention, or just a bug? do jj=1,miter ioff=ioff+1 - if (obsdiags(i_lag_ob_type,ibin)%tail%muse(jj)) then + if (odiag%muse(jj)) then rdiagbuf(ioff,ii) = one else rdiagbuf(ioff,ii) = -one @@ -590,16 +569,17 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) enddo do jj=1,miter+1 ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_lag_ob_type,ibin)%tail%nldepart(jj) + rdiagbuf(ioff,ii) = odiag%nldepart(jj) enddo do jj=1,miter ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_lag_ob_type,ibin)%tail%tldepart(jj) + rdiagbuf(ioff,ii) = odiag%tldepart(jj) enddo do jj=1,miter ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_lag_ob_type,ibin)%tail%obssen(jj) + rdiagbuf(ioff,ii) = odiag%obssen(jj) enddo + end associate ! odiag endif end if @@ -608,11 +588,20 @@ subroutine setuplag(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) ! Write information to diagnostic file if(conv_diagsave .and. ii>0)then - call dtime_show('setuplag','diagsave:lag',i_lag_ob_type) write(7)'lag',nchar,nreal,ii,mype,ioff0 write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) deallocate(cdiagbuf,rdiagbuf) end if ! End of routine +contains + subroutine init_netcdf_diag_ + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_ + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_ +! Observation class + character(7),parameter :: obsclass = ' lag' + end subroutine contents_netcdf_diag_ end subroutine setuplag +end module lag_setup diff --git a/src/gsi/setuplcbas.f90 b/src/gsi/setuplcbas.f90 new file mode 100644 index 000000000..962abbeca --- /dev/null +++ b/src/gsi/setuplcbas.f90 @@ -0,0 +1,691 @@ +module lcbas_setup + implicit none + private + public:: setup + interface setup; module procedure setuplcbas; end interface + +contains +subroutine setuplcbas(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuplcbas compute rhs for cloud base height of lowest cloud seen +! prgmmr: derber org: np23 date: 2004-07-20 +! +! abstract: For sea surface temperature observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2012-01-29 zhu +! 2014-06-19 carley - update for metguess bundle, change tintrp2a to tintrp2a11 +! for debug compile on WCOSS, write sensitivity slot indicator +! (ioff) to header of diagfile, remove unused vars +! 2015-03-11 pondeca - Modify for possibility of not using obsdiag +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig,wgt_lcbas + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,ianldate,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use m_obsNode , only: obsNode + use m_lcbasNode, only: lcbasNode + use m_lcbasNode, only: lcbasNode_appendto + use m_obsLList , only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig + use gridmod, only: get_ij + use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,& + two,cg_term,huge_single,r1000 + use jfunc, only: jiter,last,miter,jiterstart,R_option + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local variables + real(r_kind), parameter:: miss_obs=10.e10_r_kind + + real(r_double) rstation_id + + real(r_kind) lcbasges,dlat,dlon,ddiff,dtime,error + real(r_kind) scale,val2,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc,drpx + real(r_kind) term,rwgt + real(r_kind) cg_lcbas,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 + real(r_kind) ratio_errors,tfact,zsges + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,izz,ihgt,ilcbas,id,itime,ikx,iqc,iceil + integer(i_kind) iuse,ilate,ilone,istnelv,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc,iskint,iff10,isfcr + integer(i_kind) jlat,jlon + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin,proceed + type(lcbasNode),pointer:: my_head + type(obs_diag ),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + character(len=*),parameter:: myname='setuplcbas' + + real(r_kind),allocatable,dimension(:,:,:) :: ges_lcbas + real(r_kind),allocatable,dimension(:,:,:) :: ges_z + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + type(obsLList),pointer,dimension(:):: lcbashead + lcbashead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + print *, 'Whoa! We have some missing metguess variables in setuplcbas.f90....returning to setuprhsall.f90 after advancing through input file' + read(lunin)data,luse,ioid + return ! not all vars available, simply return + end if + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ilcbas=4 ! index of lcbas observation + id=5 ! index of station id + itime=6 ! index of observation time in data array + ikxx=7 ! index of ob type + iqc=8 ! index of qulaity mark + iuse=9 ! index of use parameter + idomsfc=10 ! index of dominant surface type + iskint=11 ! index of surface skin temperature + iff10=12 ! index of 10 meter wind factor + isfcr=13 ! index of surface roughness + ilone=14 ! index of longitude (degrees) + ilate=15 ! index of latitude (degrees) + istnelv=16 ! index of station elevation (m) + ihgt=17 ! index of obs height (m) + izz=18 ! index of model terrain height at ob location + iceil=19 ! index of cloud ceiling obs + iprvd=22 ! index of provider + isprvd=23 ! index of subprovider + + mm1=mype+1 + scale=one + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for missing data + if (.not. oneobtest) then + do i=1,nobs + if (abs(data(ilcbas,i)-miss_obs)<100.0_r_kind) then + muse(i)=.false. + data(ilcbas,i)=rmiss_single ! for diag output + end if + end do + end if + +! Check for duplicate observations at same location + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < 2000.0_r_kind .and. data(ier,l) < 2000.0_r_kind .and. & + muse(k) .and. muse(l))then + + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + end do + end do + + + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + ii=0 + nchar=1 + nreal=23 + ioff0=nreal + if (lobsdiagsave) nreal=nreal+4*miter+1 + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + allocate(cprvstg(nobs),csprvstg(nobs)) + if(netcdf_diag) call init_netcdf_diag_ + end if + + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + ikx = nint(data(ikxx,i)) + error=data(ier,i) + isli=data(idomsfc,i) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + end if + + if(.not.in_curbin) cycle + +! Interpolate to get lcbas at obs location/time (MSL) + call tintrp2a11(ges_lcbas,lcbasges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + +! Get guess sfc hght at obs location + call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + if(luse(i))then + awork(1) = awork(1) + one + end if + +! Adjust observation error + drpx=0.05_r_kind*abs(data(istnelv,i)-zsges) + ratio_errors=error/((data(ier,i)+drpx)*sqrt(dup(i))) + error=one/error + +! Compute innovations + ddiff=data(ilcbas,i)-lcbasges + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross check using innovation normalized by error + if (abs(data(ilcbas,i)-rmiss_single) >= tiny_r_kind ) then + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + end if + else + error = zero + ratio_errors=zero + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_lcbas=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_lcbas*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + end if + ress = ddiff*scale + ressw2 = ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + if (abs(data(ilcbas,i)-rmiss_single) >=tiny_r_kind) then + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + end if + + endif + + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call lcbasNode_appendto(my_head,lcbashead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij,jlat,jlon) + + if (jiter==jiterstart .and. R_option) then + wgt_lcbas(jlat,jlon) =wgt_lcbas(jlat,jlon)+my_head%wij(1) + wgt_lcbas(jlat+1,jlon) =wgt_lcbas(jlat+1,jlon)+my_head%wij(2) + wgt_lcbas(jlat,jlon+1) =wgt_lcbas(jlat,jlon+1)+my_head%wij(3) + wgt_lcbas(jlat+1,jlon+1)=wgt_lcbas(jlat+1,jlon+1)+my_head%wij(4) + end if + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + end if + + my_head => null() + endif + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + end do + + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag) then + write(7)'lcb',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::lcbas', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get lcbas ... + varname='lcbas' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_lcbas))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_lcbas(size(rank2,1),size(rank2,2),nfldsig)) + ges_lcbas(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_lcbas(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_lcbas_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(ilcbas,i) ! lcbas observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(ilcbas,i)-lcbasges! obs-ges w/o bias correction (K) (future slot) + + rdiagbuf(20,ii) = rmiss_single ! type of measurement + + rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(22,ii) = data(izz,i) ! model terrain at observation location + if (abs(data(iceil,i)-miss_obs)<100.0_r_kind) then + rdiagbuf(23,ii) = data(iceil,i) ! cloud ceiling + else + rdiagbuf(23,ii) = rmiss_single + end if + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + + if (lobsdiagsave) then + ioff=ioff0 + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' lcbas' + real(r_kind),parameter:: missing = -9.99e9_r_kind + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", missing ) + call nc_diag_metadata("Height", data(ihgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(ilcbas,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(ilcbas,i)-lcbasges ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) +!_RT_NC4_TODO: is the following name ok? + if (abs(data(iceil,i)-miss_obs)<100.0_r_kind) then + call nc_diag_metadata("Cloud_Ceiling", data(iceil,i) ) + else + call nc_diag_metadata("Cloud_Ceiling", missing ) + end if + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_lcbas)) deallocate(ges_lcbas) + end subroutine final_vars_ +end subroutine setuplcbas +end module lcbas_setup diff --git a/src/gsi/setuplight.f90 b/src/gsi/setuplight.f90 new file mode 100644 index 000000000..e9ed19d3c --- /dev/null +++ b/src/gsi/setuplight.f90 @@ -0,0 +1,2158 @@ +module light_setup + use kinds, only: i_kind + implicit none + private + public:: setup + interface setup; module procedure setuplight; end interface + + integer(kind=i_kind),save:: lu_diag=55 ! no longer a fixed 55 +contains +subroutine setuplight(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,light_diagsave,init_pass) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuplight compute rhs of oi for lightning flash rate +! prgmmr: k apodaca +! org: CSU/CIRA, Data Assimilation Group +! date: 2015-07-06 +! +! abstract: For assimilation of lightning flash rate observations +! (GOES/GLM) +! this routine: +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2015-07-06 k apodaca - first version of setuplight: +! add lightflashrate, i.e., the subroutine including +! the nonlinear lightning flash rate operator +! 2015-07-08 m zupanski - few updates regarding subroutine calls +! 2015-07-08 m zupanski - original calls for online bias correction +! +! 2016-05-01 k apodaca - updates regarding compatibility with the GFS model +! 2017-02-28 k apodaca - updates for reading both, global and non-hydrostatic, +! cloud-resolving background fields +! 2018-02-07 k apodaca - replaced ob_type with polymorphic obsNode through type casting +! 2018-01-02 k apodaca - add bias correction for lightning flash rate based on +! optimal parameter estimation +! 2018-08-08 k apodaca - add mpi calls for online bias correction +! 2018-08-13 k apodaca - add netcdf_diag capability +! 2018-08-14 k apodaca - add lightning flash rate observation operator suitable +! for non-hydrostatic cloud-resolving models +! 2019-03-01 j guo - moved certain references to obsmod, to their new locations +! in m_obsdiagNode and m_obsdiags. +! . changed obsLList_appendNode() to lightNode_appendto() +! . changed refereces to obsdiags(i_light_ob_type,ibin) to my_diagLL +! . changed refereces to obsdiags(i_light_ob_type,ibin)%tail to my_diag +! . made my_diag an argument of contents_xxxxx_diag_() routines. +! +!--- +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + use guess_grids, only: hrdifsig,nfldsig + use gridmod, only: dx_gfs + use gridmod, only: region_dx,region_dy ! dx, dy (:,:) + use gridmod, only: wrf_mass_regional +!-- + use gridmod, only: lat2,lon2,get_ij,nlat_sfc,nlon_sfc + use gridmod, only: regional,nsig, & + eta1_ll,pt_ll,aeta1_ll + use gridmod, only: latlon11 +!-- + use gfs_stratosphere, only: nsig_save,deta1_save,aeta1_save + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,lobsdiagsave,& + nobskeep,lobsdiag_allocated + use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use obsmod, only: luse_obsdiag + use m_obsNode, only: obsNode + use m_lightNode, only: lightNode + use m_lightNode, only: lightNode_appendto + use m_obsLList , only: obsLList + use gsi_4dvar, only: nobs_bins,hr_obsbin + use constants, only: zero,one,r1000, & + tiny_r_kind,three,half,two,cg_term,huge_single,& + wgtlim, qcmin + use constants, only: one_tenth,qmin,ten,t0c,five,r0_05 + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use lightinfo, only: nlighttype,gross_light,glermax,& + glermin,b_light,pg_light + use m_dtime, only: dtime_setup, dtime_check +!-- + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_metguess_mod, only: gsi_metguess_get,gsi_metguess_bundle + + use mpimod, only: ierror,mpi_comm_world,mpi_rtype,mpi_itype,mpi_sum +!-- +!-- + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: light_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nlighttype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + logical ,intent(in ) :: init_pass + +! Declare local parameter + character(len=*),parameter:: myname="setuplight" + + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11,tintrp2a11_indx + external:: stop2 + +! Declare local variables + real(r_kind):: lightges0,lightges,grsmlt,dlat,dlon,dtime,obserror, & + obserrlm,residual,ratio,dlight + real(r_kind) error,ddiff + real(r_kind) ressw2,ress,scale,val2,val,valqc + real(r_kind) rat_err2,exp_arg,term,ratio_errors,rwgt + real(r_kind) cg_light,wgross,wnotgross,wgt,arg + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,tfact + real(r_kind),dimension(nsig_save) :: deltasigma !For GFS + real(r_kind),dimension(nsig_save) :: sigma !For GFS + real(r_kind),dimension(nobs)::dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::diagbuf +! Local variables + integer(i_kind) :: it,k,istatus,ier,nsig_read + real(r_kind), pointer :: flashrate (:,:,:) ! lightning flash rate + real(r_kind), pointer :: flashrate_h(:,:,:) ! lightning flash rate + real(r_kind), pointer :: htot_h (:,:,:) ! lightning flash rate, non-h, cloud-res + real(r_kind), pointer :: dx (:,:) ! + real(r_kind), pointer :: dy (:,:) ! + real(r_kind),allocatable :: sigmadot(:,:,:,:) !! vert. vel in sigma +!---- +! Coefficients for derivative calculations + + real(r_kind),allocatable :: jac_udx(:,:,:,:) + real(r_kind),allocatable :: jac_vdy(:,:,:,:) + real(r_kind),allocatable :: jac_zdx(:,:,:,:) + real(r_kind),allocatable :: jac_zdy(:,:,:,:) + real(r_kind),allocatable :: jac_frate(:,:,:) + real(r_kind),allocatable :: jac_vert(:) + real(r_kind),allocatable :: jac_vertt(:,:,:,:) + real(r_kind),allocatable :: jac_vertq(:,:,:,:) + + real(r_kind),allocatable :: jac_qgma(:,:,:,:) + real(r_kind),allocatable :: jac_qgmb(:,:,:,:) + real(r_kind),allocatable :: jac_ice(:,:,:,:) + real(r_kind),allocatable :: jac_zice(:,:,:,:) + + !integer(i_kind),allocatable :: kbot(:) + real(r_kind),allocatable :: kbot(:,:,:) + + real(r_kind),allocatable :: kvert(:,:,:) + real(r_kind) :: sum_loc,sum_gbl + real(r_kind) :: r0,w0 + real(r_kind) :: eps + real(r_kind) :: eps0 + real(r_kind),dimension(lat2,lon2,nsig,nfldsig) :: cwgues + + integer(i_kind),dimension(12) :: light_ij + integer(i_kind) :: ix,ixp,iy,iyp + integer(i_kind) :: jtime,jtimep +!--- + integer(i_kind) ikxx,nn,ibin,ioff + integer(i_kind) i,nchar,nreal,j,jj,ii,l,mm1,im,jm,km + integer(i_kind) ilon,ilat,ilight,itime,ikx,ilightmax,iqc + integer(i_kind) ier2,iuse,ilate,ilone + integer(i_kind) nobs_loc,nobs_gbl + + logical,allocatable :: wmaxflag(:,:,:) + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + +! Declare external calls for code analysis + external:: mpi_barrier + external:: mpi_allreduce + external:: mpi_finalize + external:: mpi_reduce + external:: sumslightbias + + +! File(s) for postprocessing + character :: post_file*40 + + logical:: in_curbin, in_anybin + integer(i_kind) :: istat + type(lightNode),pointer:: my_head + type(obs_diag ),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + +! Guess fields + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + +! Guess of cloud fields + +!-- Regional + + real(r_kind),allocatable,dimension(:,:,:,:):: ges_qv + real(r_kind),allocatable,dimension(:,:,:,:):: ges_ql + real(r_kind),allocatable,dimension(:,:,:,:):: ges_qr + real(r_kind),allocatable,dimension(:,:,:,:):: ges_qi + real(r_kind),allocatable,dimension(:,:,:,:):: ges_qs + real(r_kind),allocatable,dimension(:,:,:,:):: ges_qg + +!-- Global + + real(r_kind),allocatable,dimension(:,:,:,:):: ges_cwmr_it + + type(obsLList),pointer,dimension(:):: lighthead + lighthead => obsLL(:) +!-- + + grsmlt=three ! multiplier factor for gross check, an appropriate magnitude + ! is yet to be determined. + mm1=mype+1 + scale=one + +! Check to see if required guess fields are available + call check_vars_(proceed) + if (.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!-- +! Retrieve cloud guess_tracer fields for the cloud mask applied in the +! nonlinear lightning flash rate observation operator. +!-- + +! Regional + + if (regional) then + +!-- WRF-ARW + + if (wrf_mass_regional) then + nsig_read=nsig + + if (ier==zero) then + do jj=1,nfldsig + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + cwgues(i,j,k,jj)=ges_ql(i,j,k,jj)+ges_qi(i,j,k,jj)+& + ges_qr(i,j,k,jj)+ges_qs(i,j,k,jj)+& + ges_qg(i,j,k,jj) + enddo + enddo + enddo + enddo + end if + + do k=1,nsig_read + deltasigma(k)=eta1_ll(k)-eta1_ll(k+1) + sigma(k)=aeta1_ll(k) + enddo + + dx(:,:)=region_dx(:,:) + dy(:,:)=region_dy(:,:) + + endif ! wrf_mass_regional + + endif !if (regional) then + +! Global + + if (.not. regional) then + + nsig_read=nsig_save ! for GFS + + do jj=1,nfldsig + do j=1,lon2 + do i=1,lat2 + do k=1,nsig + cwgues(i,j,k,jj)=ges_cwmr_it(i,j,k,jj) + enddo + enddo + enddo + enddo + +!-- +! Define local indices +!-- + im=nlon_sfc + jm=nlat_sfc + km=nsig_read + +!-- +! Retrieve the model's sigma levels and the values for the difference between them +!-- + + do k=1,nsig_read + + deltasigma(k)=deta1_save(k) + sigma(k)=aeta1_save(k) + + enddo +!-- +! Resolution of the GFS grid in degrees for both, the latitudinal +! and longitudinal directions +!-- + allocate(dx(1:im,1:jm)) + allocate(dy(1:im,1:jm)) + + do j=2,nlat_sfc/2 + + dx(:,j)=dx_gfs(j) + dy(:,j)=dx_gfs(j) + + enddo + + + endif ! end global block + +!-- +! Allocate local variables +!-- + + allocate(flashrate (1:im,1:jm,1:nfldsig)) + allocate(flashrate_h(1:im,1:jm,1:nfldsig)) + allocate(htot_h (1:im,1:jm,1:nfldsig)) + + allocate(jac_frate (1:im,1:jm,1:nfldsig)) + allocate(kvert (1:im,1:jm,1:nfldsig)) + allocate(wmaxflag (1:im,1:jm,1:nfldsig)) + allocate(sigmadot (1:im,1:jm,1:km-1,1:nfldsig)) + allocate(jac_vert (1:km-1)) + allocate(jac_zdx (1:im,1:jm,1:km-1,1:nfldsig)) + allocate(jac_zdy (1:im,1:jm,1:km-1,1:nfldsig)) + allocate(jac_udx (1:im,1:jm,1:km-1,1:nfldsig)) + allocate(jac_vdy (1:im,1:jm,1:km-1,1:nfldsig)) + allocate(jac_vertt (1:im,1:jm,1:km-1,1:nfldsig)) + allocate(jac_vertq (1:im,1:jm,1:km-1,1:nfldsig)) + + allocate(jac_qgma (1:im,1:jm,1:km,1:nfldsig)) + allocate(jac_qgmb (1:im,1:jm,1:km,1:nfldsig)) + allocate(jac_ice (1:im,1:jm,1:km,1:nfldsig)) + allocate(jac_zice (1:im,1:jm,1:km,1:nfldsig)) + !allocate(kbot (1:km,1:nfldsig)) + allocate(kbot (1:im,1:jm,1:nfldsig)) + +!****************************************************************************** +! Read and reformat lightning observations in work arrays. +! Forward model for lightning flash rate +!-- loop over FGAT time + do it=1,nfldsig + call lightflashrate(im,jm,km-1,pt_ll,sigma(1:km-1),& + deltasigma(1:km-1),dx(:,:),dy(:,:),ges_ps(:,:,it),& + ges_z(:,:,it),cwgues(:,:,:,it),ges_tv(:,:,:,it),& + ges_q(:,:,:,it),ges_qi(:,:,:,it),ges_qs(:,:,:,it),& + ges_qg(:,:,:,it),ges_u(:,:,:,it),ges_v(:,:,:,it),& + jac_frate(:,:,it),jac_vert(:),jac_vertt(:,:,:,it),& + jac_vertq(:,:,:,it),jac_zdx(:,:,:,it),jac_zdy(:,:,:,it),& + jac_udx(:,:,:,it),jac_vdy(:,:,:,it),jac_qgma(:,:,:,it),& + jac_qgmb(:,:,:,it),jac_zice(:,:,:,it),jac_ice(:,:,:,it),& + sigmadot(:,:,:,it),kvert(:,:,it),& + kbot(:,:,it),wmaxflag(:,:,it),flashrate_h(:,:,it),htot_h(:,:,it)) + enddo + +!-- +! Prepare observed and modeled lightning flash rate at obs location +!-- + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ilight=4 ! index of lightning observations + itime=5 ! index of observation time in data array + ikxx=6 ! index of ob type + ilightmax=7 ! index of light max error + iqc=8 ! index of quality mark + ier2=9 ! index of original-original obs error ratio + iuse=10 ! index of use parameter + ilone=11 ! index of longitude (degrees) + ilate=12 ! index of latitude (degrees) + +! Initialize variables used for lightning bias correction + + r0=half + w0=half + eps0=one + sum_loc=zero + nobs_loc=zero + + do i=1,nobs + muse(i)=nint(data(11,i)) <= jiter + enddo + + dup=one + do k=1,nobs + do l=k+1,nobs + if (data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l)) then + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + enddo + enddo + +! If requested, save selected data output into a diagnostic file + if (light_diagsave) then + nchar=1 + nreal=16 + if (lobsdiagsave) nreal=nreal+4*miter+1 + allocate(diagbuf(nreal,nobs)) + ii=0 + if(binary_diag) call init_binary_diag_(lu_diag,init_pass) + if(netcdf_diag) call init_netcdf_diag_() + end if +!-- +! Save some lightning flash rate values (observed, guess, no. of obs.) +! to compute the local sums inside "sumlightbias.f90," These are used +! for bias correction. +!-- + write(post_file,199)mype +199 format('sums_lfr_',i3.3,'.bin') + open(unit=200,file=trim(post_file),form='formatted',action='write') +!-- +! Interpolation to obs location (for each observation) +!-- + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if (.not.in_anybin) cycle + + if (in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + dlight=data(ilight,i) + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + + ratio_errors=error/data(ier,i) + error=one/error + + endif ! (in_curbin) + + if (.not.in_curbin) cycle + + +! Interpolate (horizontally) model lightning flash rate to obs location +! (before bias correction) + +! Regional + + if (regional) then + +!--- WRF-ARW + + if (wrf_mass_regional) then + + flashrate_h=htot_h + + endif ! wrf_mass_regional + + endif !if (regional) then + +! Global + + if (.not.regional) then + + flashrate_h=flashrate_h + + endif ! end global block + + call tintrp2a11(flashrate_h,lightges0,dlat,dlon,dtime, & + hrdifsig,mype,nfldsig) + +! Write lightning output to a file for bias correction + + write(200,*)i,dlight,lightges0 +!-- +! Optimal Var bias correction parameter for the lightning flash rate. +!-- +! Collect information from all CPU's about the sums used in +! the online bias correction applied to the forward operator for +! lightning flash rate. + + call mpi_barrier(mpi_comm_world,ierror) + call sumslightbias(dlight,lightges0,mype,nobs,nobs_loc,sum_loc) + call mpi_allreduce(nobs_loc,nobs_gbl,1,mpi_itype,mpi_sum,& + mpi_comm_world,ierror) + call mpi_allreduce(sum_loc,sum_gbl,1,mpi_rtype,mpi_sum,& + mpi_comm_world,ierror) + +! Calculation of an optimal multiplicative bias correction parameter +! eps=eps0*exp[(1/nobs)*sum[log(y/(eps0*h(x)))]/(1+r0/w0)], as in +! Apodaca et al. (2014). +! r0=0.5 - diagonal element of an observation error covariance weight matrix associated +! with the logarithmic transformation diag(RL)=r0 +! w0=0.5 - diagonal element of an uncertainty weight matrix of the guess [diag(W)=w0] +! eps0 - guess value of lightning flash rate + + if(nobs_gbl > 0) then + eps=eps0*exp( (one/ float(nobs_gbl))*sum_gbl/(one+r0/w0) ) + else + eps=eps0 + endif !! if(nobs_gbl .gt. 0) then + + if (miter==1) then + eps0=1._r_kind + else + eps0=eps + endif + +!-- +! Bias-corrected flashrate: Use epsilon to adjust flash rate +! from the min/max values of the nonlinear lightning flash rate +! observation operator. +!-- + flashrate(:,:,:)=eps0*flashrate_h(:,:,:) + + enddo ! end loop over observations + +! Interpolation to obs location (for each observation) + + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if (.not.in_anybin) cycle + + if (in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + dlight=data(ilight,i) + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + + ratio_errors=error/data(ier,i) + error=one/error + endif ! (in_curbin) + + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,"Error nobs_bins,ibin= ",nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if (.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if (.not.in_curbin) cycle + +!-- Interpolate bias-corrected model Lightning flash rate to obs location + call tintrp2a11(flashrate,lightges,dlat,dlon,dtime,& + hrdifsig,mype,nfldsig) + +!------------------------------------------------------------------ +! Write information into a file for post-processing. +!------------------------------------------------------------------ +! post_file2='mod_lfr2.bin' +! write(post_file2,198)mype +! 198 format('mod_lfr2_ ',i3.3,'.bin') +! open(unit=201,file=trim(post_file2),form='formatted',action='write') +! write(201,*)dlat,dlon,lightges +! close(unit=201,status='keep') +!------------------------------------------------------------------ + +!-- +! Calculation of the innovation (OBS-GUESS) +!-- + ddiff = dlight - lightges + +!-- +! Gross checks using the innovation +!-- + residual = abs(ddiff) + if (residual>grsmlt*data(ilightmax,i)) then + error = zero + ratio_errors=zero + if (luse(i)) awork(7) = awork(7)+one + end if + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(glermin(ikx),min(glermax(ikx),obserror)) + ratio = residual/obserrlm + if (ratio > gross_light(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if +! + if (ratio_errors*error <= tiny_r_kind) muse(i)=.false. + !-- if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_light_ob_type,ibin)%tail%muse(nobskeep) + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + + val = error*ddiff + + if (luse(i)) then + +! Compute penalty terms (linear & nonlinear qc). + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (pg_light(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-pg_light(ikx) + cg_light=b_light(ikx) + wgross = cg_term*pg_light(ikx)/(cg_light*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics as a function of observation type + ress = ddiff*scale + ressw2= ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 +! Accumulate statistics for obs belonging to this task + if (muse(i) ) then + if(rwgt < one) awork(21) = awork(21)+one + awork(5) = awork(5)+val2*rat_err2 + awork(4) = awork(4)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + + +! Fill obs diagnostics structure + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + + if ( .not. last .and. muse(i)) then + + allocate(my_head) + call lightNode_appendto(my_head,lighthead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) +! . . . . + +! In the case of lightning observations (e.g., GOES/GLM), the schematic shown below is +! used for the bi-linear interpolation of background fields to the location of an +! observation (+) and for the finite-difference derivation method used in the calculation +! of the TL of the observation operator for lightning flash rate. Calculations are done +! at each quadrant, i.e., central, north, south, east, and west. +! +! i6-------i8 +! | | +! | | +! i10-----i2-------i4------i12 +! | | | | +! | | + | | +! i9------i1-------i3------i11 +! | | +! | | +! i5-------i7 +! + +! . . . . + +! Begin preparing information for intlight + + allocate(my_head%jac_z0i1, my_head%jac_z0i2, my_head%jac_z0i3, & + my_head%jac_z0i4, my_head%jac_z0i5, my_head%jac_z0i6, & + my_head%jac_z0i7, my_head%jac_z0i8, my_head%jac_z0i9, & + my_head%jac_z0i10,my_head%jac_z0i11,my_head%jac_z0i12,& + my_head%jac_vertqi1(nsig), my_head%jac_vertqi2(nsig), & + my_head%jac_vertqi3(nsig), my_head%jac_vertqi4(nsig), & + my_head%jac_vertqi5(nsig), my_head%jac_vertqi6(nsig), & + my_head%jac_vertqi7(nsig), my_head%jac_vertqi8(nsig), & + my_head%jac_vertqi9(nsig), my_head%jac_vertqi10(nsig),& + my_head%jac_vertqi11(nsig),my_head%jac_vertqi12(nsig),& + my_head%jac_vertti1(nsig), my_head%jac_vertti2(nsig), & + my_head%jac_vertti3(nsig), my_head%jac_vertti4(nsig), & + my_head%jac_vertti5(nsig), my_head%jac_vertti6(nsig), & + my_head%jac_vertti7(nsig), my_head%jac_vertti8(nsig), & + my_head%jac_vertti9(nsig), my_head%jac_vertti10(nsig),& + my_head%jac_vertti11(nsig),my_head%jac_vertti12(nsig),& + my_head%jac_zdxi1(nsig), my_head%jac_zdxi2(nsig), & + my_head%jac_zdxi3(nsig), my_head%jac_zdxi4(nsig), & + my_head%jac_zdyi1(nsig), my_head%jac_zdyi2(nsig), & + my_head%jac_zdyi3(nsig), my_head%jac_zdyi4(nsig), & + my_head%jac_udxi1(nsig), my_head%jac_udxi2(nsig), & + my_head%jac_udxi3(nsig), my_head%jac_udxi4(nsig), & + my_head%jac_vdyi1(nsig), my_head%jac_vdyi2(nsig), & + my_head%jac_vdyi3(nsig), my_head%jac_vdyi4(nsig), & + my_head%jac_vert(nsig), my_head%jac_sigdoti1(nsig),& + my_head%jac_sigdoti2(nsig),my_head%jac_sigdoti3(nsig),& + my_head%jac_sigdoti4(nsig),my_head%jac_qi1(nsig), & + my_head%jac_qi2(nsig), my_head%jac_qi3(nsig), & + my_head%jac_qi4(nsig), my_head%jac_ti1(nsig), & + my_head%jac_ti2(nsig), my_head%jac_ti3(nsig), & + my_head%jac_ti4(nsig), my_head%jac_kverti1, & + my_head%jac_kverti2, my_head%jac_kverti3, & + my_head%jac_kverti4, my_head%jac_fratei1, & + my_head%jac_fratei2, my_head%jac_fratei3, & + my_head%jac_fratei4, my_head%jac_wmaxflagi1, & + my_head%jac_wmaxflagi2, my_head%jac_wmaxflagi3, & + my_head%jac_wmaxflagi4, & + my_head%jac_qgmai1(nsig), my_head%jac_qgmai2(nsig), & + my_head%jac_qgmai3(nsig), my_head%jac_qgmai4(nsig), & + my_head%jac_qgmbi1(nsig), my_head%jac_qgmbi2(nsig), & + my_head%jac_qgmbi3(nsig), my_head%jac_qgmbi4(nsig), & + my_head%jac_icei1(nsig), my_head%jac_icei2(nsig), & + my_head%jac_icei3(nsig), my_head%jac_icei4(nsig), & + my_head%jac_zicei1(nsig), my_head%jac_zicei2(nsig), & + my_head%jac_zicei3(nsig), my_head%jac_zicei4(nsig), & + my_head%kboti1, my_head%kboti2, & + my_head%kboti3, my_head%kboti4, & + my_head%ij(12,nsig),stat=istat) + if (istatus/=0) write(6,*)" setuplight: failure to allocate lighttail_jacs, istat=",istat + +! Set (i,j) indices of guess gridpoint that bound obs location + + call get_ij(mm1,dlat,dlon,light_ij,my_head%wij) + + do k=1,nsig + my_head%ij(1,k)=light_ij(1)+(k-1)*latlon11 + my_head%ij(2,k)=light_ij(2)+(k-1)*latlon11 + my_head%ij(3,k)=light_ij(3)+(k-1)*latlon11 + my_head%ij(4,k)=light_ij(4)+(k-1)*latlon11 + enddo + + call get_ij(mm1,dlat-one,dlon,light_ij,my_head%wij) + + do k=1,nsig + my_head%ij(5,k)=light_ij(1)+(k-1)*latlon11 + my_head%ij(7,k)=light_ij(3)+(k-1)*latlon11 + enddo + + call get_ij(mm1,dlat+one,dlon,light_ij,my_head%wij) + + do k=1,nsig + my_head%ij(6,k)=light_ij(2)+(k-1)*latlon11 + my_head%ij(8,k)=light_ij(4)+(k-1)*latlon11 + enddo + + call get_ij(mm1,dlat,dlon-one,light_ij,my_head%wij) + + do k=1,nsig + my_head%ij(9,k)=light_ij(1)+(k-1)*latlon11 + my_head%ij(10,k)=light_ij(2)+(k-1)*latlon11 + enddo + + call get_ij(mm1,dlat,dlon+one,light_ij,my_head%wij) + + do k=1,nsig + my_head%ij(11,k)=light_ij(3)+(k-1)*latlon11 + my_head%ij(12,k)=light_ij(4)+(k-1)*latlon11 + enddo + +!-- Find indices at each quadrant surrounding each observation. +!-- Interpolate the "Jacobian" coefficients to any given observation +! location and for all quadrants. These are used in the tangent +! linear and adjoint calculations of observation operator +! for lightning flash rate +!---------------------- + +!-- (1) central quadrant + + call tintrp2a11_indx(dlat,dlon,dtime,hrdifsig,mype,& + nfldsig,ix,ixp,iy,iyp,jtime,jtimep) + +!-- save coefficients + + my_head%jac_vert(:)=zero + do k=1,nsig_read + my_head%jac_vert(k)=jac_vert(k) + enddo ! k=1,nsig_read + +!- the variables below are only needed at 4 central points + + my_head%jac_z0i1=ges_z(ix ,iy ,jtime) + my_head%jac_z0i2=ges_z(ix ,iyp,jtime) + my_head%jac_z0i3=ges_z(ixp,iy ,jtime) + my_head%jac_z0i4=ges_z(ixp,iyp,jtime) + + my_head%jac_wmaxflagi1=wmaxflag(ix ,iy ,jtime) + my_head%jac_wmaxflagi2=wmaxflag(ix ,iyp,jtime) + my_head%jac_wmaxflagi3=wmaxflag(ixp,iy ,jtime) + my_head%jac_wmaxflagi4=wmaxflag(ixp,iyp,jtime) + + my_head%jac_kverti1=kvert(ix ,iy ,jtime) + my_head%jac_kverti2=kvert(ix ,iyp,jtime) + my_head%jac_kverti3=kvert(ixp,iy ,jtime) + my_head%jac_kverti4=kvert(ixp,iyp,jtime) + + my_head%jac_fratei1=jac_frate(ix ,iy ,jtime) + my_head%jac_fratei2=jac_frate(ix ,iyp,jtime) + my_head%jac_fratei3=jac_frate(ixp,iy ,jtime) + my_head%jac_fratei4=jac_frate(ixp,iyp,jtime) + + my_head%kboti1=kbot(ix ,iy ,jtime) + my_head%kboti2=kbot(ix ,iyp,jtime) + my_head%kboti3=kbot(ixp,iy ,jtime) + my_head%kboti4=kbot(ixp,iyp,jtime) +!--- +!--- Initialize some variables + + my_head%jac_qi1(:)=zero + my_head%jac_qi2(:)=zero + my_head%jac_qi3(:)=zero + my_head%jac_qi4(:)=zero + + my_head%jac_ti1(:)=zero + my_head%jac_ti2(:)=zero + my_head%jac_ti3(:)=zero + my_head%jac_ti4(:)=zero + + my_head%jac_zdxi1(:)=zero + my_head%jac_zdxi2(:)=zero + my_head%jac_zdxi3(:)=zero + my_head%jac_zdxi4(:)=zero + + my_head%jac_zdyi1(:)=zero + my_head%jac_zdyi2(:)=zero + my_head%jac_zdyi3(:)=zero + my_head%jac_zdyi4(:)=zero + + my_head%jac_udxi1(:)=zero + my_head%jac_udxi2(:)=zero + my_head%jac_udxi3(:)=zero + my_head%jac_udxi4(:)=zero + + my_head%jac_vdyi1(:)=zero + my_head%jac_vdyi2(:)=zero + my_head%jac_vdyi3(:)=zero + my_head%jac_vdyi4(:)=zero + + my_head%jac_vertti1(:)=zero + my_head%jac_vertti2(:)=zero + my_head%jac_vertti3(:)=zero + my_head%jac_vertti4(:)=zero + + my_head%jac_vertqi1(:)=zero + my_head%jac_vertqi2(:)=zero + my_head%jac_vertqi3(:)=zero + my_head%jac_vertqi4(:)=zero + + my_head%jac_qgmai1(:)=zero + my_head%jac_qgmai2(:)=zero + my_head%jac_qgmai3(:)=zero + my_head%jac_qgmai4(:)=zero + + my_head%jac_qgmbi1(:)=zero + my_head%jac_qgmbi2(:)=zero + my_head%jac_qgmbi3(:)=zero + my_head%jac_qgmbi4(:)=zero + + my_head%jac_icei1(:)=zero + my_head%jac_icei2(:)=zero + my_head%jac_icei3(:)=zero + my_head%jac_icei4(:)=zero + + my_head%jac_zicei1(:)=zero + my_head%jac_zicei2(:)=zero + my_head%jac_zicei3(:)=zero + my_head%jac_zicei4(:)=zero + + do k=1,nsig_read + my_head%jac_qi1(k)=ges_q(ix ,iy ,k,jtime) + my_head%jac_qi2(k)=ges_q(ix ,iyp,k,jtime) + my_head%jac_qi3(k)=ges_q(ixp,iy ,k,jtime) + my_head%jac_qi4(k)=ges_q(ixp,iyp,k,jtime) + my_head%jac_ti1(k)=ges_tv(ix ,iy ,k,jtime) + my_head%jac_ti2(k)=ges_tv(ix ,iyp,k,jtime) + my_head%jac_ti3(k)=ges_tv(ixp,iy ,k,jtime) + my_head%jac_ti4(k)=ges_tv(ixp,iyp,k,jtime) + my_head%jac_sigdoti1(k)=sigmadot(ix ,iy ,k,jtime) + my_head%jac_sigdoti2(k)=sigmadot(ix ,iyp,k,jtime) + my_head%jac_sigdoti3(k)=sigmadot(ixp,iy ,k,jtime) + my_head%jac_sigdoti4(k)=sigmadot(ixp,iyp,k,jtime) + my_head%jac_zdxi1(k)=jac_zdx(ix ,iy ,k,jtime) + my_head%jac_zdxi2(k)=jac_zdx(ix ,iyp,k,jtime) + my_head%jac_zdxi3(k)=jac_zdx(ixp,iy ,k,jtime) + my_head%jac_zdxi4(k)=jac_zdx(ixp,iyp,k,jtime) + my_head%jac_zdyi1(k)=jac_zdy(ix ,iy ,k,jtime) + my_head%jac_zdyi2(k)=jac_zdy(ix ,iyp,k,jtime) + my_head%jac_zdyi3(k)=jac_zdy(ixp,iy ,k,jtime) + my_head%jac_zdyi4(k)=jac_zdy(ixp,iyp,k,jtime) + my_head%jac_udxi1(k)=jac_udx(ix ,iy ,k,jtime) + my_head%jac_udxi2(k)=jac_udx(ix ,iyp,k,jtime) + my_head%jac_udxi3(k)=jac_udx(ixp,iy ,k,jtime) + my_head%jac_udxi4(k)=jac_udx(ixp,iyp,k,jtime) + my_head%jac_vdyi1(k)=jac_vdy(ix ,iy ,k,jtime) + my_head%jac_vdyi2(k)=jac_vdy(ix ,iyp,k,jtime) + my_head%jac_vdyi3(k)=jac_vdy(ixp,iy ,k,jtime) + my_head%jac_vdyi4(k)=jac_vdy(ixp,iyp,k,jtime) + my_head%jac_vertti1(k)=jac_vertt(ix ,iy ,k,jtime) + my_head%jac_vertti2(k)=jac_vertt(ix ,iyp,k,jtime) + my_head%jac_vertti3(k)=jac_vertt(ixp,iy ,k,jtime) + my_head%jac_vertti4(k)=jac_vertt(ixp,iyp,k,jtime) + enddo ! k=1,nsig_read + + do k=1,nsig_read-1 + my_head%jac_vertqi1(k)=jac_vertq(ix ,iy ,k,jtime) + my_head%jac_vertqi2(k)=jac_vertq(ix ,iyp,k,jtime) + my_head%jac_vertqi3(k)=jac_vertq(ixp,iy ,k,jtime) + my_head%jac_vertqi4(k)=jac_vertq(ixp,iyp,k,jtime) + enddo ! k=1,nsig_read-1 + + do k=1,nsig_read-1 + my_head%jac_qgmai1(k)=jac_qgma(ix ,iy ,k,jtime) + my_head%jac_qgmai2(k)=jac_qgma(ix ,iyp,k,jtime) + my_head%jac_qgmai3(k)=jac_qgma(ixp,iy ,k,jtime) + my_head%jac_qgmai4(k)=jac_qgma(ixp,iyp,k,jtime) + my_head%jac_qgmbi1(k)=jac_qgmb(ix ,iy ,k,jtime) + my_head%jac_qgmbi2(k)=jac_qgmb(ix ,iyp,k,jtime) + my_head%jac_qgmbi3(k)=jac_qgmb(ixp,iy ,k,jtime) + my_head%jac_qgmbi4(k)=jac_qgmb(ixp,iyp,k,jtime) + my_head%jac_icei1(k)=jac_ice(ix ,iy ,k,jtime) + my_head%jac_icei2(k)=jac_ice(ix ,iyp,k,jtime) + my_head%jac_icei3(k)=jac_ice(ixp,iy ,k,jtime) + my_head%jac_icei4(k)=jac_ice(ixp,iyp,k,jtime) + my_head%jac_zicei1(k)=jac_zice(ix ,iy ,k,jtime) + my_head%jac_zicei2(k)=jac_zice(ix ,iyp,k,jtime) + my_head%jac_zicei3(k)=jac_zice(ixp,iy ,k,jtime) + my_head%jac_zicei4(k)=jac_zice(ixp,iyp,k,jtime) + enddo ! k=1,nsig_read-1 + +!-- (2) south quadrant + + call tintrp2a11_indx(dlat-one,dlon,dtime, & + hrdifsig,mype,nfldsig,ix,ixp,iy,iyp,jtime,jtimep) + + +!-- save coefficients + + do k=1,nsig_read-1 + my_head%jac_z0i5=ges_z(ix ,iy ,jtime) + my_head%jac_z0i7=ges_z(ixp,iyp ,jtime) + my_head%jac_vertti5(k)=jac_vertt(ix ,iy, k,jtime) + my_head%jac_vertti7(k)=jac_vertt(ixp ,iy, k,jtime) + my_head%jac_vertqi5(k)=jac_vertq(ix ,iy, k,jtime) + my_head%jac_vertqi7(k)=jac_vertq(ixp ,iy, k,jtime) + enddo ! k=1,nsig_read-1 + +!---------------------- +!-- (3) north quadrant + + call tintrp2a11_indx(dlat+one,dlon,dtime, & + hrdifsig,mype,nfldsig,ix,ixp,iy,iyp,jtime,jtimep) + + +!-- save coefficients + + do k=1,nsig_read-1 + my_head%jac_z0i6=ges_z(ix ,iyp,jtime) + my_head%jac_z0i8=ges_z(ixp,iyp,jtime) + my_head%jac_vertti6(k)=jac_vertt(ix ,iyp,k,jtime) + my_head%jac_vertti8(k)=jac_vertt(ixp,iyp,k,jtime) + my_head%jac_vertqi6(k)=jac_vertq(ix ,iyp,k,jtime) + my_head%jac_vertqi8(k)=jac_vertq(ixp,iyp,k,jtime) + enddo ! k=1,nsig_read-1 + +!---------------------- +!-- (4) west quadrant + + call tintrp2a11_indx(dlat,dlon-one,dtime, & + hrdifsig,mype,nfldsig,ix,ixp,iy,iyp,jtime,jtimep) + +!-- save coefficients + + do k=1,nsig_read-1 + my_head%jac_z0i9 =ges_z(ix ,iy ,jtime) + my_head%jac_z0i10=ges_z(ix ,iyp,jtime) + my_head%jac_vertti9(k)=jac_vertt(ix ,iy,k ,jtime) + my_head%jac_vertti10(k)=jac_vertt(ix ,iy,k ,jtime) + my_head%jac_vertqi9(k)=jac_vertq(ix ,iy,k ,jtime) + my_head%jac_vertqi10(k)=jac_vertq(ix ,iy,k ,jtime) + enddo ! k=1,nsig_read-1 + +!---------------------- +!-- (5) east quadrant + + call tintrp2a11_indx(dlat,dlon+one,dtime, & + hrdifsig,mype,nfldsig,ix,ixp,iy,iyp,jtime,jtimep) + +!-- save coefficients + + do k=1,nsig_read-1 + my_head%jac_z0i11=ges_z(ixp,iy ,jtime) + my_head%jac_z0i12=ges_z(ixp,iyp,jtime) + my_head%jac_vertti11(k)=jac_vertt(ixp,iy,k ,jtime) + my_head%jac_vertti12(k)=jac_vertt(ixp,iyp,k,jtime) + my_head%jac_vertqi11(k)=jac_vertq(ixp,iy,k ,jtime) + my_head%jac_vertqi12(k)=jac_vertq(ixp,iyp,k,jtime) + enddo ! k=1,nsig_read-1 + +!-------------------------------------------------- + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2= ratio_errors**2 + my_head%time = dtime + my_head%b = b_light(ikx) + my_head%pg = pg_light(ikx) + my_head%luse = luse(i) + +! End preparing observation information for intlight +! . . . . + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:myhead') + my_head%diags => my_diag + endif + + my_head => null() + endif !( .not. last .and. muse(i)) + +! Save selected output to a diagnostics file + if (light_diagsave .and. luse(i)) then + ii=ii+1 + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input=one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst + if (err_final>tiny_r_kind) errinv_final=one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + + ! End of loop over observations + end do !nobs + +! Release memory of local guess arrays + call final_vars_ + +! Close file with lightning information for bias correction + + close(unit=200,status='keep') + +! Write information to a diagnostics file + if(light_diagsave .and. ii>0)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(lu_diag)" light",nchar,nreal,ii,mype + write(lu_diag)diagbuf(:,1:ii) + deallocate(diagbuf) + close(lu_diag) + end if + end if + + deallocate(flashrate) + deallocate(flashrate_h) + deallocate(jac_frate) + deallocate(kvert) + deallocate(wmaxflag) + deallocate(sigmadot) + deallocate(dx) + deallocate(dy) + + deallocate(jac_vertt) + deallocate(jac_vertq) + deallocate(jac_zdx) + deallocate(jac_zdy) + deallocate(jac_udx) + deallocate(jac_vdy) + + deallocate(htot_h ) + deallocate(jac_qgma) + deallocate(jac_qgmb) + deallocate(jac_ice) + deallocate(jac_zice) + deallocate(kbot) + +! End of routine + + return + contains + +! . . . . + +subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::q', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::u' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::v' , ivar, istatus ) + proceed=proceed.and.ivar>0 + +!-- +! Retrieve cloud guess_tracer fields for the cloud mask applied in the +! nonlinear lightning flash rate observation operator. +!-- + +! Get the pointer to cloud mixing ratios from the guess at time index "it" + +! Regional, non-hydrostatic with 6-class hydrometeor microphysics + + ! Regional + + if (regional) then + +!-- WRF-ARW + + if (wrf_mass_regional) then + + call gsi_metguess_get ('var::qv' , ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::ql' , ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::qr', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qi' , ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::qs', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qg', ivar, istatus ) + proceed=proceed.and.ivar>0 + + endif ! wrf_mass_regional + + endif !if (regional) then + +! Global + + if (.not. regional) then + + call gsi_metguess_get ('var::cw', ivar, istatus ) + proceed=proceed.and.ivar>0 + + endif ! end global block + +end subroutine check_vars_ + +subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get q ... + varname='q' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_q))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_q(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_q(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get u ... + varname='u' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_u))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_u(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_u(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get v ... + varname='v' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_v))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_v(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_v(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + +! Regional, non-hydrostatic with 6-class hydrometeor microphysics + + if (regional) then + +!-- WRF-ARW + + if (wrf_mass_regional) then + + ! get qv ... + varname='qv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + ! get ql ... + varname='ql' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_ql))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ql(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_ql(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_ql(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + ! get qr ... + varname='qr' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qr))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qr(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qr(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qr(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + ! get qi ... + varname='qi' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qi))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qi(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qi(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qi(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + ! get qs ... + varname='qs' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qs))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qs(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qs(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qs(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + ! get qg ... + varname='qg' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qg))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qg(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qg(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qg(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + endif ! wrf_mass_regional + + endif !if (regional) then + +! Global + + if (.not. regional) then + + ! get cw ... + varname='cw' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_cwmr_it))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_cwmr_it(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_cwmr_it(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_cwmr_it(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + endif ! end global block + +end subroutine init_vars_ + +subroutine init_binary_diag_(nunit,init_pass) + use obsmod, only: dirname + use obsmod, only: iadate + use jfunc , only: jiter + implicit none + integer(i_kind),intent(out):: nunit + logical ,intent( in):: init_pass + + character(len=80) string + character(len=128) diag_light_file + integer(i_kind):: idate + +! If requested, create lightning diagnostic files + write(string,500) jiter +500 format('light_',i2.2) ! shouldn't it be "glm_light", in consistency with init_netcdf_diag_()? + diag_light_file=trim(dirname) // trim(string) + if(init_pass) then + open(newunit=nunit,file=trim(diag_light_file),form='unformatted',status='unknown',position='rewind') + else + open(newunit=nunit,file=trim(diag_light_file),form='unformatted',status='old',position='append') + endif + idate=iadate(4)+iadate(3)*100+iadate(2)*10000+iadate(1)*1000000 + if(init_pass .and. mype == 0)write(nunit)idate +end subroutine init_binary_diag_ + +! . . . . + +! Capability to write diagnostic-related information in NetCDF + +subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_light_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + + write(string,900) jiter +900 format('glm_light_',i2.2,'.nc4') + diag_light_file=trim(dirname) // trim(string) + + inquire(file=diag_light_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_light_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_light_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_light_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_light_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_light_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif +end subroutine init_netcdf_diag_ + +! . . . . + +subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + + diagbuf(1,ii) = data(ier,i) ! observation error + diagbuf(2,ii) = data(ilate,i) ! observation latitude (degrees) + diagbuf(3,ii) = data(ilone,i) ! observation longitude (degrees) + diagbuf(4,ii) = dlight ! total lightning obs (#hits/km**2*hr) + diagbuf(5,ii) = dtime ! observation time + diagbuf(6,ii) = data(iqc,i) ! input glmbufr qc or event mark + diagbuf(7,ii) = data(ier2,i) ! index of original-original obs error + diagbuf(8,ii) = data(iuse,i) ! read_glmbufr data usage flag + + if(muse(i)) then + diagbuf(9,ii) = one ! analysis usage flag (1=use, -1=not used) + else + diagbuf(9,ii) = -one + endif + + diagbuf(10,ii) = rwgt ! nonlinear qc relative weight + diagbuf(11,ii) = errinv_input ! glmbufr inverse obs error + diagbuf(12,ii) = errinv_adjst ! read_glmbufr inverse obs error + diagbuf(13,ii) = errinv_final ! final inverse observation error + + diagbuf(14,ii) = ddiff ! obs-ges used in analysis (#hits/km2*hr) + diagbuf(15,ii) = dlight-lightges0 ! obs-ges w/o bias correction (#hits/km2*hr) + + ioff=16 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + diagbuf(ioff,ii) = one + else + diagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + diagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + diagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + diagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif +end subroutine contents_binary_diag_ + +! . . . . + +subroutine contents_netcdf_diag_(odiag) +! Observation class + type(obs_diag),pointer,intent(in):: odiag + character(7),parameter :: obsclass = ' light' + real(r_single),parameter:: missing = -9.99e9_r_single + real(r_kind),dimension(miter) :: obsdiag_iuse + + call nc_diag_metadata("GLM_Detect_Err", sngl(data(ier,i)) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Lightning_FR_Obs", sngl(dlight ) ) + call nc_diag_metadata("Time", sngl(dtime) ) + call nc_diag_metadata("GLM_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("GLM_Orig_Detect_Err", sngl(data(ier2,i)) ) + call nc_diag_metadata("GLM_Use_Flag", sngl(data(iuse,i)) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", 1._r_single ) + else + call nc_diag_metadata("Analysis_Use_Flag", -1._r_single ) + endif + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata("Obs_Minus_Forecast_VarBC", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_NoVarBC", sngl(dlight-lightges0) ) + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + +end subroutine contents_netcdf_diag_ + +! . . . . + +subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_tv)) deallocate(ges_tv ) + if(allocated(ges_q )) deallocate(ges_q ) + if(allocated(ges_ps)) deallocate(ges_ps ) + if(allocated(ges_v )) deallocate(ges_v ) + if(allocated(ges_u )) deallocate(ges_u ) + if(allocated(ges_qv)) deallocate(ges_qv ) + if(allocated(ges_ql)) deallocate(ges_ql ) + if(allocated(ges_qr)) deallocate(ges_qr ) + if(allocated(ges_qi)) deallocate(ges_qi ) + if(allocated(ges_qs)) deallocate(ges_qs ) + if(allocated(ges_qv)) deallocate(ges_qv ) + if(allocated(ges_cwmr_it)) deallocate(ges_cwmr_it ) +end subroutine final_vars_ + +end subroutine setuplight + + +! . . . . + +subroutine lightflashrate(imax,jmax,kmax_q,pt_ll,sigma,deltasigma, & + dx,dy,ps,z0,cwm,t,q,qi,qs,qg,u,v,jac_frate,jac_vert,jac_vertt,& + jac_vertq,jac_zdi,jac_zdy,jac_udx,jac_vdy,jac_qgma,& + jac_qgmb,jac_zice,jac_ice,sigmadot,kvert,kbot,wmaxflag,& + flashrate,htot) + +!$$$ documentation block +! . . . . +! subroutine: lightflashrate nonlinear lightning flash rate model +! prgmmr: k apodaca +! org: CSU/CIRA, Data Assimilation Group +! date: 2015-07-06 +! +! abstract: Model for the calculation of lightning flash rate. +! The calculation starts with the derivation of vertical +! velocity from a modified version of the continuity equation +! (Janjic et al, 2010), as in Apodaca et al. (2014). +! Subsequently, there are two formulas for lightning flash rate for global +! and regional modes. +! +! In global mode, lightning flash rate is a function of maximum +! vertical velocity and it is based on a regression formaula in +! Barthe et al. (2010). +! +! In regional mode, lightning flash rate is a function of upward +! graupel flux and vertically integrated ice-phase species, as in +! McCaul et al. (2009). +! +! program history log: +! 2018-08-14 k apodaca - add lightning flash rate non-linear observation operator +! suitable for non-hydrostatic cloud-resolving models + + use kinds, only: r_kind,r_single,r_double,i_kind + use constants, only: zero,one,one_tenth,two,three,half + use constants, only: fv,rd,grav,qmin,ten,t0c,five,r0_05 + use gridmod, only: wrf_mass_regional,regional + + implicit none + +!------------------------------------------------------ +! Define constants, parameters, and variables +!------------------------------------------------------ + +!-- input + integer(i_kind) :: imax,jmax + integer(i_kind) :: kmax_q + real(r_kind),intent(out),dimension(1:imax,1:jmax) :: kvert + real(r_kind),intent(in),dimension(1:imax,1:jmax,1:kmax_q) :: cwm !! Total cloud condensate + real(r_kind),intent(in),dimension(1:imax,1:jmax,1:kmax_q) :: t !! Temperature + real(r_kind),intent(in),dimension(1:imax,1:jmax,1:kmax_q) :: q !! Specific humidity + real(r_kind),intent(in),dimension(1:imax,1:jmax,1:kmax_q) :: u !! U-component of the wind + real(r_kind),intent(in),dimension(1:imax,1:jmax,1:kmax_q) :: v !! V-component of the wind + +! Guess fields for nonlinear observation operator for +! lightning flash rate suitable for non-hydrostatic cloud-resolving models + + real(r_kind),intent(in),dimension(1:imax,1:jmax,1:kmax_q) :: qg ! Graupel mixing ratio (kg kg-1) + real(r_kind),intent(in),dimension(1:imax,1:jmax,1:kmax_q) :: qi ! Ice mixing ratio (kg kg-1) + real(r_kind),intent(in),dimension(1:imax,1:jmax,1:kmax_q) :: qs ! Snow mixing ratio (kg kg-1) + +!-- + real(r_kind),intent(in),dimension(1:imax,1:jmax) :: dx !! Latitudinal grid distance + real(r_kind),intent(in),dimension(1:imax,1:jmax) :: dy !! Longitudinal grid distance + real(r_kind),intent(in),dimension(1:imax,1:jmax) :: z0 !! surface height + real(r_kind),intent(in),dimension(1:imax,1:jmax) :: ps !! surface pressure + + real(r_kind),intent(in) :: pt_ll !! hydrostatic top pressure + real(r_kind),intent(in),dimension(1:kmax_q) :: sigma !! Sigma levels + real(r_kind),intent(in),dimension(1:kmax_q) :: deltasigma !! Difference between sigma levels + +!-- output + real(r_kind),intent(out),dimension(1:imax,1:jmax) :: flashrate !! Lightning flash rate + real(r_kind),dimension(1:imax,1:jmax) :: h1 !! LFR OO as fn. of graupel flux + real(r_kind),dimension(1:imax,1:jmax) :: h2 !! LFR OO as fn. of vert. int. hydrom. + real(r_kind),intent(out),dimension(1:imax,1:jmax) :: htot !! Total LFR + real(r_kind),dimension(1:imax,1:jmax) :: totice_colint !! Column integrated hydrom. + + real(r_kind),intent(out),dimension(1:imax,1:jmax,1:kmax_q) :: jac_udx + real(r_kind),intent(out),dimension(1:imax,1:jmax,1:kmax_q) :: jac_vdy + real(r_kind),intent(out),dimension(1:imax,1:jmax,1:kmax_q) :: jac_zdi + real(r_kind),intent(out),dimension(1:imax,1:jmax,1:kmax_q) :: jac_zdy + + + real(r_kind),intent(out),dimension(1:imax,1:jmax) :: jac_frate + real(r_kind),intent(out),dimension(1:kmax_q) :: jac_vert + real(r_kind),intent(out),dimension(1:imax,1:jmax,1:kmax_q) :: jac_vertt + real(r_kind),intent(out),dimension(1:imax,1:jmax,1:kmax_q) :: jac_vertq + + real(r_kind),intent(out),dimension(1:imax,1:jmax, 1:kmax_q) :: jac_qgma + real(r_kind),intent(out),dimension(1:imax,1:jmax, 1:kmax_q) :: jac_qgmb + real(r_kind),intent(out),dimension(1:imax,1:jmax, 1:kmax_q) :: jac_ice + real(r_kind),intent(out),dimension(1:imax,1:jmax, 1:kmax_q) :: jac_zice + + !integer(i_kind),intent(out),dimension(1:imax,1:jmax) :: kbot ! bottom level for graupel flux calculation + real(r_kind),intent(out),dimension(1:imax,1:jmax) :: kbot ! bottom level for graupel flux calculation + +!----------------------------------------------- + + real(r_kind),dimension(1:imax,1:jmax,1:kmax_q) :: horiz_adv !! Horizontal advection + real(r_kind),dimension(1:imax,1:jmax,1:kmax_q) :: vert_adv !! Vertical advection + real(r_kind),dimension(1:imax,1:jmax,1:kmax_q) :: z + real(r_kind),dimension(1:imax,1:jmax,1:kmax_q) :: w !! Vertical velocity + + real(r_kind),dimension(1:imax,1:jmax,1:kmax_q) :: sigmadot + + real(r_kind),dimension(1:imax,1:jmax) :: ddx + real(r_kind),dimension(1:imax,1:jmax) :: ddy + real(r_kind),dimension(1:imax,1:jmax,1:kmax_q) :: pu1 + real(r_kind),dimension(1:imax,1:jmax,1:kmax_q) :: pu2 + real(r_kind),dimension(1:imax,1:jmax,1:kmax_q) :: pv1 + real(r_kind),dimension(1:imax,1:jmax,1:kmax_q) :: pv2 + + real(r_kind) :: sum1 !! Integral1 in sigmadot + real(r_kind) :: sum2 !! Integral2 in sigmadot + + integer(i_kind) :: ismooth,jsmooth + integer(i_kind) :: istart,iend + integer(i_kind) :: jstart,jend +!------------------------------------------------------ +! Variable declaration for the cloud mask flag +!------------------------------------------------------ + + integer(i_kind) :: i,j,k + integer(i_kind) :: ii,jj,kk + +!-- parameters + + integer(i_kind), parameter :: idiff=2 !for avg and cloud detec. (=0=>no averaging) + integer(i_kind), parameter :: jdiff=2 !for avg and cloud detec. (=0=>no averaging) + +! Parameters used in McCaul et al. (2009) + + real(r_kind),parameter :: k1=0.042_r_kind !! Calibrated coefficient + real(r_kind),parameter :: k2=0.20_r_kind !! || + real(r_kind),parameter :: k3=0.95_r_kind !!From various weight choices + real(r_kind),parameter :: graupel_density=300._r_kind !! (kg/m**3)from McCaul et al. (2009) + + real(r_kind), parameter :: cwm_threshold=1.e-15_r_kind !threshold condition for cloud det. + logical,intent(out),dimension(1:imax,1:jmax) :: wmaxflag + integer(i_kind) :: numcld +!------------------------------------------------------ +! wmax, obs_ges + + real(r_kind),parameter :: wpower=4.5_r_kind !! regression power parameter + real(r_kind),parameter :: wcnst=5.e-6_r_kind !! regression multiplication parameter + real(r_kind) :: wmax + +! Optional output file(s) + +!-- prepare some coefficients + + do i=1,imax + do j=1,jmax + ddx(i,j)=one/(two*dx(i,j)) + ddy(i,j)=one/(two*dy(i,j)) + enddo !! do j=1,jmax + enddo !! do i=1,imax + + + jac_vert(:)=zero + + do k=1,kmax_q + jac_vert(k)=(rd/grav)*(deltasigma(k)/sigma(k)) + enddo !! do k=1,kmax_q + + jac_vertt(:,:,:)=zero + jac_vertq(:,:,:)=zero + + do i=1,imax + do j=1,jmax + do k=1,kmax_q + jac_vertt(i,j,k)=jac_vert(k)*(one+fv*q(i,j,k)) + jac_vertq(i,j,k)=jac_vert(k)*(fv*t(i,j,k)) + enddo !! do k=1,kmax_q + enddo !! do j=1,jmax + enddo !! do i=1,imax + +! Virtual Temperature (Tv) is given by: tv=t*(1+0.61*q) +! Discretization of the height derivative + + z(:,:,:)=zero + + do i=1,imax + do j=1,jmax + z(i,j,1) = z0(i,j) + do k=2,kmax_q + z(i,j,k) = z(i,j,k-1)+jac_vert(k)*t(i,j,k)*(one+fv*q(i,j,k)) + enddo + enddo !! do j=1,jmax + enddo !! do i=1,imax + + ismooth=1 + jsmooth=1 + istart=1+ismooth + iend=imax-ismooth + jstart=1+jsmooth + jend=jmax-jsmooth + +! Horizontal advection in the vertical velocity calculation + + horiz_adv(:,:,:)=zero + do i=istart,iend + do j=jstart,jend + do k=2,kmax_q + horiz_adv(i,j,k)=(u(i,j,k)*ddx(i,j))*(z(i+1,j,k)-z(i-1,j,k)) & + +(v(i,j,k)*ddy(i,j))*(z(i,j+1,k)-z(i,j-1,k)) + enddo !! do k=1,kmax_q + horiz_adv(i,j,1) = horiz_adv(i,j,2) + enddo !! do j=jstart,jend + enddo !! do i=istart,iend + horiz_adv(1,:,:) = horiz_adv(2,:,:) + horiz_adv(imax,:,:) = horiz_adv(imax-1,:,:) + horiz_adv(:,1,:) = horiz_adv(:,2,:) + horiz_adv(:,jmax,:) = horiz_adv(:,jmax-1,:) + +! Additional coefficients + + jac_zdi(:,:,:)=zero + jac_zdy(:,:,:)=zero + jac_udx(:,:,:)=zero + jac_vdy(:,:,:)=zero + + do i=istart,iend + do j=jstart,jend + do k=2,kmax_q + jac_zdi(i,j,k)=(z(i+1,j,k)-z(i-1,j,k))*ddx(i,j) + jac_zdy(i,j,k)=(z(i,j+1,k)-z(i,j-1,k))*ddy(i,j) + jac_udx(i,j,k)=u(i,j,k)*ddx(i,j) + jac_vdy(i,j,k)=v(i,j,k)*ddy(i,j) + jac_zdi(i,j,1)=jac_zdi(i,j,2) + jac_zdy(i,j,1)=jac_zdy(i,j,2) + jac_udx(i,j,1)=jac_udx(i,j,2) + jac_vdy(i,j,1)=jac_vdy(i,j,2) + enddo !! do k=1,kmax_q + enddo !! do j=jstart,jend + enddo !! do i=istart,iend + jac_zdi(1,:,:)=jac_zdi(2,:,:) + jac_zdi(imax,:,:)=jac_zdi(imax-1,:,:) + jac_zdi(:,1,:)=jac_zdi(:,2,:) + jac_zdi(:,jmax,:)=jac_zdi(:,jmax-1,:) + jac_zdy(1,:,:)=jac_zdy(2,:,:) + jac_zdy(imax,:,:)=jac_zdy(imax-1,:,:) + jac_zdy(:,1,:)=jac_zdy(:,2,:) + jac_zdy(:,jmax,:)=jac_zdy(:,jmax-1,:) + jac_udx(1,:,:)=jac_udx(2,:,:) + jac_udx(imax,:,:)=jac_udx(imax-1,:,:) + jac_udx(:,1,:)=jac_udx(:,2,:) + jac_udx(:,jmax,:)=jac_udx(:,jmax-1,:) + jac_vdy(1,:,:)=jac_vdy(2,:,:) + jac_vdy(imax,:,:)=jac_vdy(imax-1,:,:) + jac_vdy(:,1,:)=jac_vdy(:,2,:) + jac_vdy(:,jmax,:)=jac_vdy(:,jmax-1,:) + +! Sigmadot calculation: 2 integrals in Sigmadot + + do j=jstart,jend + do i=istart,iend + +!-- Sum 1 in sigmadot + + sum1=zero + do k=1,kmax_q + pu1(i,j,k)=((ps(i+1,j)*1000_r_kind)-(pt_ll*100_r_kind))*u(i+1,j,k) + pu2(i,j,k)=((ps(i-1,j)*1000_r_kind)-(pt_ll*100_r_kind))*u(i-1,j,k) + pv1(i,j,k)=((ps(i,j+1)*1000_r_kind)-(pt_ll*100_r_kind))*v(i,j+1,k) + pv2(i,j,k)=((ps(i,j-1)*1000_r_kind)-(pt_ll*100_r_kind))*v(i,j-1,k) + sum1=sum1+((((pu1(i,j,k)-pu2(i,j,k))*ddx(i,j))+& + ((pv1(i,j,k)-pv2(i,j,k))*ddy(i,j)))*deltasigma(k)) + enddo ! k=1,kmax_q loop + +!-- Sum 2 in sigmadot + + sum2=zero + do k=kmax_q,1,-1 + sum2=sum2+((((pu1(i,j,k)-pu2(i,j,k))*ddx(i,j))+& + ((pv1(i,j,k)-pv2(i,j,k))*ddy(i,j)))*deltasigma(k)) + enddo + + +!-- Sigmadot + + do k=1,kmax_q + sigmadot(i,j,k)=((sigma(k)/((ps(i,j)*1000_r_kind)-(pt_ll*100_r_kind)))*sum1)-& + ((1/((ps(i,j)*1000_r_kind)-(pt_ll*100_r_kind)))*sum2) + + sigmadot(i,j,1)=sigmadot(i,j,2) + enddo + sigmadot(1,:,:)=sigmadot(2,:,:) + sigmadot(imax,:,:)=sigmadot(imax-1,:,:) + sigmadot(:,1,:)=sigmadot(:,2,:) + sigmadot(:,jmax,:)=sigmadot(:,jmax-1,:) + + +! Vertical advection + + do k=1,kmax_q + vert_adv(i,j,k)=-sigmadot(i,j,k)*jac_vert(k)*t(i,j,k)*(one+fv*q(i,j,k)) + enddo ! k loop + vert_adv(i,j,1)=vert_adv(i,j,2) + + enddo !! do i=istart,iend + enddo ! do j=jstart,jend + vert_adv(1,:,:)=vert_adv(2,:,:) + vert_adv(imax,:,:)=vert_adv(imax-1,:,:) + vert_adv(:,1,:)=vert_adv(:,2,:) + vert_adv(:,jmax,:)=vert_adv(:,jmax-1,:) +!---- +! Vertical velocity calculation +!---- + + w(:,:,:)=zero + do i=istart,iend + do j=jstart,jend + do k=1,kmax_q + w(i,j,k)=horiz_adv(i,j,k)+vert_adv(i,j,k) + enddo + w(i,j,1)=w(i,j,2) + enddo !! do i=istart,iend + enddo ! do j=jstart,jend + w(1,:,:)=w(2,:,:) + w(imax,:,:)=w(imax-1,:,:) + w(:,1,:)=w(:,2,:) + w(:,jmax,:)=w(:,jmax-1,:) + +!------------------------------------------------------ +!------------------------------------------------------ +! Calculate lightning flash rate +!------------------------------------------------------ +!------------------------------------------------------ + +!------------------------------------------------------ +!-- Regional + +! WRF-ARW + +!- Initialize local variables + + h1(:,:)=zero + kbot(:,:)=zero + totice_colint(:,:)=zero + h2(:,:)=zero + htot(:,:)=zero + + if (regional) then + + if (wrf_mass_regional) then + +! Lightning flash rate as a function of vertical graupel flux +! within the mixed-phase region (-15 deg C) + + do i=1,imax + do j=1,jmax + +! Mixed-phase level + + loop_kbot: do k=1,kmax_q-1 + if ( half*(t(i,j,k)+t(i,j,k+1)) < 258.15_r_kind ) then + kbot(i,j)=k + exit loop_kbot + endif + enddo loop_kbot + + if (kbot(i,j) > zero) then + jac_qgma(i,j,kbot(i,j))=two*k1*k3*graupel_density*qg(i,j,kbot(i,j)) + jac_qgmb(i,j,kbot(i,j))=k1*k3*graupel_density*(half*(w(i,j,kbot(i,j))+w(i,j,kbot(i,j)+1))) + h1(i,j)=k1*k3*(half*(w(i,j,kbot(i,j))+w(i,j,kbot(i,j)+1)))*qg(i,j,kbot(i,j))*graupel_density + h1(i,j)=abs(h1(i,j)) + else + h1(i,j)=zero + endif + + enddo + enddo + + +! Lightning flash rate as a function of total column-integrated +! ice-phase hydrometeors + + do i=1,imax + do j=1,jmax + do k=1,kmax_q-1 + jac_ice(i,j,k)=k2*z(i,j,k) + jac_zice(i,j,k)=k2*(qi(i,j,k)+qs(i,j,k)+qg(i,j,k)) + totice_colint(i,j) = totice_colint(i,j)+k2*(qi(i,j,k) & + + qs(i,j,k) + qg(i,j,k))*z(i,j,k) + enddo + enddo + enddo + + do i=1,imax + do j=1,jmax + h2(i,j) = (1-k3)*totice_colint(i,j) + enddo + enddo + +! Total lightning flash rate + do i=1,imax + do j=1,jmax + htot(i,j)=h1(i,j)+h2(i,j) + enddo + enddo + + endif ! wrf_mass_regional + + endif !if (regional) then + +!------------------------------------------------------ +!- Global + + if (.not. regional) then + +!------------------------------------------------------ +! Cloud mask flag +!------------------------------------------------------ + + ismooth=1 + jsmooth=1 + istart=1+ismooth + iend=imax-ismooth + jstart=1+jsmooth + jend=jmax-jsmooth + + do j=jstart,jend + do i=istart,iend + wmaxflag(i,j)=.false. + numcld=zero + do ii=max(1,i-idiff),min(imax,i+idiff) + do jj=max(1,j-jdiff),min(jmax,j+jdiff) + do kk=1,kmax_q + if(cwm(ii,jj,kk) > cwm_threshold) then + numcld= numcld+1 + endif + enddo !! kk + enddo !! jj + enddo !! ii + if(numcld > one) then !! if clouds exist + wmaxflag(i,j)=.true. + else + wmaxflag(i,j)=.false. + endif + enddo !! do i=istart,iend + enddo !! do j=jstart,jend + + wmaxflag(1,:)=wmaxflag(2,:) + wmaxflag(imax,:)=wmaxflag(imax-1,:) + wmaxflag(:,1)=wmaxflag(:,2) + wmaxflag(:,jmax)=wmaxflag(:,jmax-1) + + do i=1,imax + do j=1,jmax + if (wmaxflag(i,j)) then + wmax=-1.e+10_r_kind + do k=1,kmax_q + if (w(i,j,k) > wmax) then + wmax=w(i,j,k) + kvert(i,j)=k + endif + if (wmax < zero) then + wmax=zero + endif + enddo ! k loop + jac_frate(i,j)=wcnst*wpower*(wmax**(wpower-1)) + flashrate(i,j)=wcnst*(wmax**wpower) + flashrate(i,j)=abs(flashrate(i,j)) + else ! wmaxflag + jac_frate(i,j)=zero + flashrate(i,j)=zero + endif ! wmaxflag + enddo ! j loop + enddo ! i loop + + + endif ! global block + + + +end subroutine lightflashrate +end module light_setup diff --git a/src/gsi/setuplwcp.f90 b/src/gsi/setuplwcp.f90 new file mode 100644 index 000000000..97acf36fc --- /dev/null +++ b/src/gsi/setuplwcp.f90 @@ -0,0 +1,901 @@ +module lwcp_setup + implicit none + private + public:: setup + interface setup; module procedure setuplwcp; end interface + +contains +subroutine setuplwcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave,& + nsig_saved) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuplwcp compute rhs of oi for liquid-water condensate path +! prgmmr: Ting-Chi Wu org: CIRA/CSU date: 2017-06-28 +! +! abstract: For solid-water condensate path (lwcp), this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2017-06-28 Ting-Chi Wu - mimic the structure in setuppw.f90 and setupbend.f90 +! - setuplwcp.f90 includes 2 operator options +! 1) when l_wcp_cwm = .false.: +! operator = f(T,P,q) +! 2) when l_wcp_cwm = .true. and CWM partition6: +! operator = f(ql,qr) partition6 +! 2018-05-10 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr,getindex + use kinds, only: r_kind,r_single,r_double,i_kind + use guess_grids, only: ges_prsi,ges_prsl,ges_tsen,hrdifsig,nfldsig + use gridmod, only: lat2,lon2,nsig,get_ij,latlon11 + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,lobsdiag_forenkf,ianldate,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset + use obsmod, only: l_wcp_cwm + use m_obsNode, only: obsNode + use m_lwcpNode, only: lwcpNode + use m_lwcpNode, only: lwcpNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin + + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header,nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim,nc_diag_read_close + use state_vectors, only: svars3d, levels, nsdim + + use constants, only: zero,one,tpwcon,r1000,r10, & + tiny_r_kind,three,half,two,cg_term,huge_single,& + wgtlim, ttp, tmix, psatk, xa, xai, xb, xbi + use jfunc, only: jiter,last,jiterstart,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle +!-- use gfs_stratosphere, only: use_gfs_stratosphere, nsig_save + + use sparsearr, only: sparr2, new, size, writearray, fullarray + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + + integer(i_kind),optional:: nsig_saved ! use a saved nsig value. This is currently + ! a patch to gradually remove the dependency on + ! GFS specific background grid. + +! Declare local parameter + character(len=*),parameter:: myname='setuplwcp' + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: stop2 + +! Declare local variables + real(r_double) rstation_id + real(r_kind):: lwcpges,grsmlt,dlat,dlon,dtime,obserror, & + obserrlm,residual,ratio,dlwcp + real(r_kind) error,ddiff + real(r_kind) ressw2,ress,scale,val2,val,valqc + real(r_kind) rat_err2,exp_arg,term,ratio_errors,rwgt + real(r_kind) cg_lwcp,wgross,wnotgross,wgt,arg + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,tfact + real(r_kind),dimension(nobs)::dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + integer(i_kind) ikxx,nn,istat,ibin,ioff,ioff0 + integer(i_kind) i,nchar,nreal,k,j,jj,ii,l,mm1 + integer(i_kind) ier,ilon,ilat,ilwcp,id,itime,ikx,ilwcpmax,iqc + integer(i_kind) ier2,iuse,ilate,ilone,istnelv,iobshgt,iobsprs + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + integer(i_kind) :: qi_ind, nind, nnz + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + + logical:: in_curbin, in_anybin,save_jacobian + type(lwcpNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + equivalence(rstation_id,station_id) + integer(i_kind),dimension(4) :: lwcp_ij + integer(i_kind) :: nsig_top + + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_ql + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qr + real(r_kind),dimension(lat2,lon2,nfldsig)::ges_lwcp + real(r_kind),dimension(nsig+1):: piges + real(r_kind),dimension(nsig):: qges, plges, tges + real(r_kind),dimension(nsig):: trges, wges, dwdt + real(r_kind),dimension(nsig):: esges, eslges, esiges + real(r_kind),dimension(nsig):: desdt, desldt, desidt + real(r_kind),dimension(nsig):: dssqdq, dssqdt, dssqdp + real(r_kind),dimension(nsig):: qvges, qvsges, ssqges + real(r_kind),dimension(nsig):: qlges, qrges + real(r_kind) :: tupper, tlower, tcenter + real(r_kind),dimension(lat2,lon2,nsig,nfldsig)::qv, esi, esl, es, qvsl, ssqvl + real(r_kind),dimension(lat2,lon2,nsig,nfldsig)::ges_tr, ges_w + + type(obsLList),pointer,dimension(:):: lwcphead + lwcphead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + + grsmlt=three ! multiplier factor for gross check + mm1=mype+1 + scale=one + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!****************************************************************************** +! Read and reformat observations in work arrays. + +!============================================================================================================= +! Operator for lwcp (liquid-water content path w.r.t ice forward model) + +!-- if (use_gfs_stratosphere) then +!-- nsig_top = nsig_save +!-- else +!-- nsig_top = nsig +!-- endif + + nsig_top = nsig + if(present(nsig_saved)) nsig_top=nsig_saved + + tupper = ttp + tlower = tmix + + if (.not.l_wcp_cwm) then + esi = zero; esl = zero; es = zero + qvsl = zero; ssqvl = zero + ges_lwcp = zero + + tcenter = 0.5_r_kind * (tupper + tlower) + ges_tr = ttp / ges_tsen + ges_w = 0.5_r_kind * (one + tanh((ges_tsen-tcenter)/((tupper-tlower)/4._r_kind))) ! hyperbolic tangent + esl = psatk * (ges_tr**xa) * exp(xb*(one-ges_tr)) + esi = psatk * (ges_tr**xai) * exp(xbi*(one-ges_tr)) + es = ges_w * esl + (one-ges_w) * esi + + + do jj=1,nfldsig + ! gues_q is acquired through gsi_bundlegetpointer in the init_vars_ call + qv(:,:,:,jj) = ges_q(:,:,:,jj) / (one - ges_q(:,:,:,jj)) ! kg/kg + + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + if (ges_tsen(i,j,k,jj) >= tlower .and. k <= nsig_top ) then + qvsl(i,j,k,jj) = 0.622_r_kind * es(i,j,k,jj) / (ges_prsl(i,j,k,jj)-es(i,j,k,jj)) ! ges_prsl in cbar + ssqvl(i,j,k,jj) = qv(i,j,k,jj) - qvsl(i,j,k,jj) ! kg/kg + if (ssqvl(i,j,k,jj) < zero) ssqvl(i,j,k,jj) = zero + ges_lwcp(i,j,jj) = ges_lwcp(i,j,jj) + ssqvl(i,j,k,jj) * & + tpwcon*r10*(ges_prsi(i,j,k,jj)-ges_prsi(i,j,k+1,jj)) ! kg/m^2 + endif + end do + end do + end do + end do + + else + + ! l_wcp_cwm = T and partition6: ql, qi, qr, qs, qg, and qh' + ges_lwcp = zero + + do jj=1,nfldsig + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + if (ges_tsen(i,j,k,jj) >= tlower .and. k <= nsig_top ) then + ges_lwcp(i,j,jj) = ges_lwcp(i,j,jj) + & + (ges_ql(i,j,k,jj)+ges_qr(i,j,k,jj)) * & + tpwcon*r10*(ges_prsi(i,j,k,jj)-ges_prsi(i,j,k+1,jj)) ! kg/m^2 + endif + enddo + enddo + enddo + enddo + + endif ! l_wcp_cwm + +!============================================================================================================= + + + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ilwcp = 4 ! index of lwcp observations + id=5 ! index of station id + itime=6 ! index of observation time in data array + ikxx=7 ! index of ob type + ilwcpmax=8 ! index of lwcp max error + iqc=9 ! index of quality mark + ier2=10 ! index of original-original obs error ratio + iuse=11 ! index of use parameter + ilone=12 ! index of longitude (degrees) + ilate=13 ! index of latitude (degrees) + istnelv=14 ! index of station elevation (m) + iobsprs=15 ! index of observation pressure (hPa) + iobshgt=16 ! index of observation height (m) + + do i=1,nobs + muse(i)=nint(data(11,i)) <= jiter + end do + + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l)) then + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + end do + end do + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + nchar=1 + ioff0=20 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (save_jacobian) then + nnz = nsig ! number of non-zero elements in dH(x)/dx profile + nind = 1 + call new(dhx_dx, nnz, nind) + nreal = nreal + size(dhx_dx) + endif + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + ii=0 + if(netcdf_diag) call init_netcdf_diag_ + end if + + +! Prepare total precipitable water data + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + + dlwcp=data(ilwcp,i) + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + + ratio_errors=error/data(ier,i) + error=one/error + endif ! (in_curbin) + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +!============================================================================================================= +! Interpolate ges_* to obs location + + ! Interpolate model lwcp to obs location + call tintrp2a11(ges_lwcp,lwcpges,dlat,dlon,dtime, & + hrdifsig,mype,nfldsig) + + ! Interpolate pressure at interface values to obs location + call tintrp2a1(ges_prsi,piges,dlat,dlon,dtime, & + hrdifsig,nsig+1,mype,nfldsig) + + if (.not.l_wcp_cwm) then + call tintrp2a1(ges_prsl,plges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_tsen,tges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_q,qges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + else + call tintrp2a1(ges_tsen,tges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_ql,qlges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_qr,qrges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + endif + + if (save_jacobian) then + qi_ind = getindex(svars3d, 'qi') + if (qi_ind < 0) then + print *, 'Error: no variable q in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = 1 + sum(levels(1:qi_ind-1)) + dhx_dx%end_ind(1) = nsig + sum(levels(1:qi_ind-1)) + + do k = 1, nsig + dhx_dx%val(k) = tpwcon*r10*(piges(k)-piges(k+1)) + enddo + endif +!============================================================================================================= + + ! Compute innovation + ddiff = dlwcp - lwcpges + + !if (l_limit_lwcp_innov) then + ! ! Limit size of lwcp innovation to a percent of the background value + ! ddiff = sign(min(abs(ddiff),max_innov_pct*lwcpges),ddiff) + !end if + +! Gross checks using innovation + + residual = abs(ddiff) + if (residual>grsmlt*data(ilwcpmax,i)) then + error = zero + ratio_errors=zero + if (luse(i)) awork(7) = awork(7)+one + end if + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + ratio = residual/obserrlm + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + if (ratio_errors*error <= tiny_r_kind) muse(i)=.false. + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + + val = error*ddiff + + if(luse(i))then +! Compute penalty terms (linear & nonlinear qc). + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_lwcp=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_lwcp*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics as a function of observation type. + ress = ddiff*scale + ressw2= ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 +! Accumulate statistics for obs belonging to this task + if (muse(i) ) then + if(rwgt < one) awork(21) = awork(21)+one + awork(5) = awork(5)+val2*rat_err2 + awork(4) = awork(4)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=ddiff) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if ( .not. last .and. muse(i)) then + + allocate(my_head) + call lwcpNode_appendto(my_head,lwcphead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + + allocate(my_head%ij(4, nsig), & + my_head%jac_t(nsig ), & + my_head%jac_p(nsig+1), & + my_head%jac_q(nsig ), & + my_head%jac_ql(nsig ), & + my_head%jac_qr(nsig ), stat=istat) + if (istat/=0) write(6,*)'MAKECOBS: allocate error for lwcphead, istat=',istat + + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,lwcp_ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2= ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + my_head%jac_t(:)=zero + my_head%jac_p(:)=zero + my_head%jac_q(:)=zero + my_head%jac_ql(:)=zero + my_head%jac_qr(:)=zero + +!============================================================================================================= +! Calculate Jacobians for lwcp + + eslges=zero; esiges=zero; esges=zero; + desldt=zero; desidt=zero; desdt=zero; dwdt=zero + dssqdq=zero; dssqdt=zero; dssqdp=zero + + do k=1,nsig + + my_head%ij(1,k)=lwcp_ij(1)+(k-1)*latlon11 + my_head%ij(2,k)=lwcp_ij(2)+(k-1)*latlon11 + my_head%ij(3,k)=lwcp_ij(3)+(k-1)*latlon11 + my_head%ij(4,k)=lwcp_ij(4)+(k-1)*latlon11 + + if (.not.l_wcp_cwm) then + + qvges(k) = qges(k)/(one-qges(k)) ! kg/kg + trges(k) = ttp/tges(k) + wges(k) = 0.5_r_kind*(one+tanh((tges(k)-tcenter)/((tupper-tlower)/4._r_kind))) ! hyperbolic tangent + + if ( tges(k) >= tlower .and. k <= nsig_top ) then + !psat is in Pa; psatk is in cbar + eslges(k) = psatk*(trges(k)**xa)*exp(xb*(one-trges(k))) ! cbar + esiges(k) = psatk*(trges(k)**xai)*exp(xbi*(one-trges(k))) !cbar + esges(k) = wges(k) * eslges(k) + (one-wges(k)) * esiges(k) ! cbar + qvsges(k) = 0.622_r_kind*esges(k)/(plges(k)-esges(k)) ! kg/kg + ssqges(k) = qvges(k)-qvsges(k) + if ( ssqges(k) < zero ) ssqges(k)=zero + !jacobian + desldt(k) = eslges(k)*(-xa/tges(k)) + eslges(k)*xb*ttp/(tges(k)**2) + desidt(k) = esiges(k)*(-xai/tges(k)) + esiges(k)*xbi*ttp/(tges(k)**2) + ! hyperbolic tangent + dwdt(k) = 0.5_r_kind*(one/cosh((tges(k)-tcenter)/((tupper-tlower)/4._r_kind))**2)*(4._r_kind/(tupper-tlower)) + desdt(k) = dwdt(k)*eslges(k) + wges(k)*desldt(k) & + + (-dwdt(K))*esiges(k) + (one-wges(k))*desidt(k) + + dssqdt(k) = -0.622_r_kind* ( desdt(k)/(plges(k)-esges(k)) & + + esges(k)*desdt(k)/((plges(k)-esges(k))**2) ) + dssqdq(k) = one/(one-qges(k)) + qges(k)/((one-qges(k))**2) + dssqdp(k) = 0.622_r_kind*esges(k)/(plges(k)-esges(k))**2 + + my_head%jac_t(k)=dssqdt(k)*(tpwcon*r10*(piges(k)-piges(k+1))) + my_head%jac_p(k)=dssqdp(k)*(tpwcon*r10*(piges(k)-piges(k+1))) + my_head%jac_q(k)=dssqdq(k)*(tpwcon*r10*(piges(k)-piges(k+1))) + endif + + else + + if ( tges(k) >= tlower .and. k <= nsig_top ) then + my_head%jac_ql(k)=tpwcon*r10*(piges(k)-piges(k+1)) + my_head%jac_qr(k)=tpwcon*r10*(piges(k)-piges(k+1)) + endif + + endif + end do + + my_head%jac_p(nsig+1) = zero +!============================================================================================================= + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + + +! Save select output for diagnostic file + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input=one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst + if (err_final>tiny_r_kind) errinv_final=one/err_final + + ioff=ioff0 + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + end if + + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag.and. ii>0)then + write(7)'lwc',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + use obsmod, only: l_wcp_cwm + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + if (.not.l_wcp_cwm) then + + call gsi_metguess_get ('var::q', ivar, istatus ) + proceed=ivar>0 + + else + + call gsi_metguess_get ('var::ql' , ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::qr', ivar, istatus ) + proceed=proceed.and.ivar>0 + + endif ! l_wcp_cwm + end subroutine check_vars_ + + subroutine init_vars_ + use obsmod, only: l_wcp_cwm + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then + + if (.not.l_wcp_cwm) then + + ! get q ... + varname='q' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_q))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_q(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_q(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + else + + ! get ql ... + varname='ql' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_ql))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ql(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_ql(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_ql(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + ! get qr ... + varname='qr' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qr))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qr(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qr(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qr(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + endif ! l_wcp_cwm + + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + +! open netcdf diag file + write(string,900) jiter +900 format('conv_lwcp_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + + end subroutine init_netcdf_diag_ + + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = data(iobsprs,i) ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error + rdiagbuf(16,ii) = errinv_final ! final inverse observation error + + rdiagbuf(17,ii) = dlwcp ! solid-water content path obs (kg/m**2) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (kg/m**2) + rdiagbuf(19,ii) = dlwcp-lwcpges ! obs-ges w/o bias correction (kg/m**2) (future slot) + rdiagbuf(20,ii) = 1.e10_r_single ! spread (filled in by EnKF) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' lwcp' + real(r_kind),parameter:: missing = -9.99e9_r_kind + + real(r_kind),dimension(miter) :: obsdiag_iuse + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(data(iobsprs,i)) ) + call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Setup_QC_Mark", sngl(rmiss_single) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata("Observation", sngl(dlwcp) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(dlwcp-lwcpges)) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_q )) deallocate(ges_q ) + if(allocated(ges_ql)) deallocate(ges_ql) + if(allocated(ges_qr)) deallocate(ges_qr) + end subroutine final_vars_ + +end subroutine setuplwcp +end module lwcp_setup diff --git a/src/gsi/setupmitm.f90 b/src/gsi/setupmitm.f90 new file mode 100644 index 000000000..89b01acbe --- /dev/null +++ b/src/gsi/setupmitm.f90 @@ -0,0 +1,706 @@ +module mitm_setup + implicit none + private + public:: setup + interface setup; module procedure setupmitm; end interface + +contains +subroutine setupmitm(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupmitm compute rhs of oi for conventional daily minimum temperature +! prgmmr: pondeca org: np23 date: 2014-04-10 +! +! abstract: For daily minimum temperature observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2014-04-10 pondeca +! 2015-03-11 pondeca - Modify for possibility of not using obsdiag +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! before retuning to setuprhsall.f90 +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-01-08 pondeca - addd option l_closeobs to use closest obs to analysis +! time in analysis +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + + use m_obsNode , only: obsNode + use m_mitmNode, only: mitmNode + use m_mitmNode, only: mitmNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: rmiss_single, & + lobsdiagsave,nobskeep,lobsdiag_allocated, & + time_offset,bmiss,luse_obsdiag,ianldate + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig,get_ij,twodvar_regional + use constants, only: zero,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & + two,cg_term,huge_single,three + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use rapidrefresh_cldsurf_mod, only: l_closeobs + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_7=0.7_r_kind + + character(len=*),parameter:: myname='setupmitm' + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) mitmges,dlat,dlon,ddiff,dtime,error + real(r_kind) scale,val2,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,rwgt + real(r_kind) cg_mitm,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,ipres,imitm,id,itime,ikx,iqt,iqc,iskint,iff10 + integer(i_kind) ier2,iuse,ilate,ilone,istnelv,isfcr,iobshgt,izz,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin + type(mitmNode), pointer:: my_head + type(obs_diag), pointer:: my_diag + type(obs_diags), pointer:: my_diagLL + real(r_kind) :: hr_offset + + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !will need at some point + real(r_kind),allocatable,dimension(:,:,:) :: ges_z !will probably need at some point + real(r_kind),allocatable,dimension(:,:,:) :: ges_mitm + + type(obsLList),pointer,dimension(:):: mitmhead + mitmhead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + imitm=5 ! index of mitm observation + id=6 ! index of station id + itime=7 ! index of observation time in data array + ikxx=8 ! index of ob type + iqt=9 ! index of flag indicating if moisture ob available + iqc=10 ! index of quality mark + ier2=11 ! index of original obs error + iuse=12 ! index of use parameter + idomsfc=13 ! index of dominant surface type + iskint=14 ! index of surface skin temperature + iff10=15 ! index of 10 meter wind factor + isfcr=16 ! index of surface roughness + ilone=17 ! index of longitude (degrees) + ilate=18 ! index of latitude (degrees) + istnelv=19 ! index of station elevation (m) + iobshgt=20 ! index of observation height (m) + izz=21 ! index of surface height + iprvd=22 ! index of observation provider + isprvd=23 ! index of observation subprovider + + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for duplicate observations at same location + dup=one + hr_offset=min_offset/60.0_r_kind + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + end if + + if(.not.in_curbin) cycle + +! Interpolate guess mitm to observation location and time + call tintrp2a11(ges_mitm,mitmges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + ddiff=data(imitm,i)-mitmges + +! Adjust observation error + ratio_errors=error/data(ier,i) + error=one/error + +! Gross error checks + + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + +! modify gross check limit for quality mark=3 + if(data(iqc,i) == three ) then + qcgross=r0_7*cgross(ikx) + else + qcgross=cgross(ikx) + endif + + if (twodvar_regional) then + if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) & + qcgross=three*cgross(ikx) + endif + + if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + muse(i) = .true. + endif + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag,jiter=nobskeep,muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_mitm=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_mitm*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 !rejected obs + if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs + end if + + ress = ddiff*scale + ressw2 = ress*ress + + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + endif + +! Fill obs diagnostics structure + if(luse_obsdiag)then + call obsdiagNode_set(my_diag,wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call mitmNode_appendto(my_head,mitmhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + end if + + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_binary_diag_(my_diag) + + end if + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'mit',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::mitm' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get mitm ... + varname='mitm' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_mitm))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_mitm(size(rank2,1),size(rank2,2),nfldsig)) + ges_mitm(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_mitm(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_mitm_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = r10*exp(data(ipres,i)) ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(imitm,i) ! MITM observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(imitm,i)-mitmges! obs-ges w/o bias correction (K) (future slot) + + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' mitm' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", data(ipres,i)*r10 ) + call nc_diag_metadata("Height", data(iobshgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(imitm,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(imitm,i)-mitmges ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps )) deallocate(ges_ps ) + if(allocated(ges_mitm)) deallocate(ges_mitm) + end subroutine final_vars_ + +end subroutine setupmitm +end module mitm_setup diff --git a/src/gsi/setupmxtm.f90 b/src/gsi/setupmxtm.f90 new file mode 100644 index 000000000..0c71415f8 --- /dev/null +++ b/src/gsi/setupmxtm.f90 @@ -0,0 +1,706 @@ +module mxtm_setup + implicit none + private + public:: setup + interface setup; module procedure setupmxtm; end interface + +contains +subroutine setupmxtm(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupmxtm compute rhs of oi for conventional daily maximum temperature +! prgmmr: pondeca org: np23 date: 2014-04-10 +! +! abstract: For daily maximum temperature observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2014-04-10 pondeca +! 2015-03-11 pondeca - Modify for possibility of not using obsdiag +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! before retuning to setuprhsall.f90 +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-01-08 pondeca - addd option l_closeobs to use closest obs to analysis +! time in analysis +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig + use m_obsdiagNode, only : obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + + use m_obsNode , only: obsNode + use m_mxtmNode, only: mxtmNode + use m_mxtmNode, only: mxtmNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: rmiss_single, & + lobsdiagsave,nobskeep,lobsdiag_allocated, & + time_offset,bmiss,luse_obsdiag,ianldate + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig,get_ij,twodvar_regional + use constants, only: zero,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & + two,cg_term,huge_single,three + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use rapidrefresh_cldsurf_mod, only: l_closeobs + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_7=0.7_r_kind + + character(len=*),parameter:: myname='setupmxtm' + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) mxtmges,dlat,dlon,ddiff,dtime,error + real(r_kind) scale,val2,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,rwgt + real(r_kind) cg_mxtm,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,ipres,imxtm,id,itime,ikx,iqt,iqc,iskint,iff10 + integer(i_kind) ier2,iuse,ilate,ilone,istnelv,isfcr,iobshgt,izz,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin + type(mxtmNode), pointer:: my_head + type(obs_diag), pointer:: my_diag + type(obs_diags), pointer:: my_diagLL + real(r_kind) :: hr_offset + + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !will need at some point + real(r_kind),allocatable,dimension(:,:,:) :: ges_z !will probably need at some point + real(r_kind),allocatable,dimension(:,:,:) :: ges_mxtm + + type(obsLList),pointer,dimension(:):: mxtmhead + mxtmhead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + imxtm=5 ! index of mxtm observation + id=6 ! index of station id + itime=7 ! index of observation time in data array + ikxx=8 ! index of ob type + iqt=9 ! index of flag indicating if moisture ob available + iqc=10 ! index of quality mark + ier2=11 ! index of original obs error + iuse=12 ! index of use parameter + idomsfc=13 ! index of dominant surface type + iskint=14 ! index of surface skin temperature + iff10=15 ! index of 10 meter wind factor + isfcr=16 ! index of surface roughness + ilone=17 ! index of longitude (degrees) + ilate=18 ! index of latitude (degrees) + istnelv=19 ! index of station elevation (m) + iobshgt=20 ! index of observation height (m) + izz=21 ! index of surface height + iprvd=22 ! index of observation provider + isprvd=23 ! index of observation subprovider + + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for duplicate observations at same location + dup=one + hr_offset=min_offset/60.0_r_kind + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + end if + + if(.not.in_curbin) cycle + +! Interpolate guess mxtm to observation location and time + call tintrp2a11(ges_mxtm,mxtmges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + ddiff=data(imxtm,i)-mxtmges + +! Adjust observation error + ratio_errors=error/data(ier,i) + error=one/error + +! Gross error checks + + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + +! modify gross check limit for quality mark=3 + if(data(iqc,i) == three ) then + qcgross=r0_7*cgross(ikx) + else + qcgross=cgross(ikx) + endif + + if (twodvar_regional) then + if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) & + qcgross=three*cgross(ikx) + endif + + if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + muse(i) = .true. + endif + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag,jiter=nobskeep,muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_mxtm=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_mxtm*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 !rejected obs + if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs + end if + + ress = ddiff*scale + ressw2 = ress*ress + + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + endif + +! Fill obs diagnostics structure + if(luse_obsdiag)then + call obsdiagNode_set(my_diag,wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call mxtmNode_appendto(my_head,mxtmhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + end if + + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'mxt',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::mxtm' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get mxtm ... + varname='mxtm' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_mxtm))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_mxtm(size(rank2,1),size(rank2,2),nfldsig)) + ges_mxtm(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_mxtm(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_mxtm_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = r10*exp(data(ipres,i)) ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(imxtm,i) ! MXTM observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(imxtm,i)-mxtmges! obs-ges w/o bias correction (K) (future slot) + + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' mxtm' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", data(ipres,i)*r10 ) + call nc_diag_metadata("Height", data(iobshgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(imxtm,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(imxtm,i)-mxtmges ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps )) deallocate(ges_ps ) + if(allocated(ges_mxtm)) deallocate(ges_mxtm) + end subroutine final_vars_ + +end subroutine setupmxtm +end module mxtm_setup diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 new file mode 100644 index 000000000..8e0f12086 --- /dev/null +++ b/src/gsi/setupoz.f90 @@ -0,0 +1,1659 @@ +module oz_setup + implicit none + private + public:: setup + interface setup; module procedure setupozlay; end interface + +contains +subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& + obstype,isis,is,ozone_diagsave,init_pass) + +!$$$ subprogram documentation block +! . . . +! subprogram: setupozlay --- Compute rhs of oi for sbuv ozone obs +! +! prgrmmr: parrish org: np22 date: 1990-10-06 +! +! abstract: For sbuv ozone observations (layer amounts and total +! column, this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 1990-10-06 parrish +! 1998-04-10 weiyu yang +! 1999-03-01 wu, ozone processing moved into setuprhs from setupoz +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2003-12-23 kleist - modify to use pressure as vertical coordinate +! 2004-05-28 kleist - subroutine call update +! 2004-06-17 treadon - update documentation +! 2004-07-08 todling - added only's; removed gridmod; bug fix in diag +! 2004-07-15 todling - protex-compliant prologue; added intent's +! 2004-10-06 parrish - increase size of stats_oz for nonlinear qc, +! add nonlin qc penalty calc and obs count +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-12-22 treadon - add outer loop number to name of diagnostic file +! 2005-03-02 dee - reorganize diagnostic file writes so that +! concatenated files are self-contained +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-03-16 derber - change call to sproz to save observation time +! 2005-04-11 treadon - add logical to toggle on/off nonlinear qc code +! 2005-05-18 wu - add use of OMI total ozone data +! 2005-09-22 derber - modify extensively - combine with sproz - no change +! 2005-09-28 derber - combine with prep,spr,remove tran and clean up +! 2005-10-07 treadon - fix bug in increment of ii +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2006-01-09 treadon - remove unused variables +! 2006-02-03 derber - modify for new obs control +! 2006-02-17 treadon - correct bug when processing data not assimilated +! 2006-03-21 treadon - add option to perturb observation +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - unify NL qc +! 2007-03-09 su - remove option to perturb observation +! 2007-03-19 tremolet - binning of observations +! 2007-05-30 h.liu - include rozcon with interpolation weights +! 2007-06-08 kleist/treadon - add prefix (task id or path) to diag_ozone_file +! 2007-06-05 tremolet - add observation diagnostics structure +! 2008-05-23 safford - add subprogram doc block, rm unused uses and vars +! 2008-01-20 todling - add obsdiag info to diag files +! 2009-01-08 todling - re-implemented obsdiag/tail +! 2009-10-19 guo - changed for multi-pass setup with dtime_check() and new +! arguments init_pass and last_pass. +! 2009-12-08 guo - cleaned diag output rewind with open(position='rewind') +! 2011-12-07 todling - bug fix: need luse check when saving obssens +! 2012-09-10 wargan/guo - add hooks for omieff" +! 2013-01-26 parrish - change from grdcrd to grdcrd1, tintrp2a to tintrp2a1, intrp2a to intrp2a1, +! intrp3oz to intrp3oz1. (to allow successful debug compile on WCOSS) +! 2013-09-10 guo - patched to take reference pressure from the observation +! 2013-10-19 todling - metguess now holds background +! 2013-11-26 guo - removed nkeep==0 escaping to allow more than one obstype sources. +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-11-29 shlyaeva - save linearized H(x) for EnKF. +! 2016-12-09 mccarty - add netcdf_diag capability +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2017-10-27 todling - revised netcdf output for lay case; obs-sens needs attention +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nlevs - number of levels (layer amounts + total column) per obs +! nreal - number of pieces of non-ozone info (location, time, etc) per obs +! nobs - number of observations +! isis - sensor/instrument/satellite id +! is - integer(i_kind) counter for number of obs types to process +! obstype - type of ozone obs +! ozone_diagsave - switch on diagnostic output (.false.=no output) +! stats_oz - sums for various statistics as a function of level +! +! output argument list: +! stats_oz - sums for various statistics as a function of level +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq HP +! +!$$$ end documentation block + +! !USES: + + use mpeu_util, only: die,perr,getindex + use kinds, only: r_kind,r_single,i_kind + + use state_vectors, only: svars3d, levels, nsdim + + use constants, only : zero,half,one,two,tiny_r_kind + use constants, only : rozcon,cg_term,wgtlim,h300,r10 + + use m_obsdiagNode, only : obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + + use obsmod, only : dplat,nobskeep + use obsmod, only : mype_diaghdr,dirname,time_offset,ianldate + use obsmod, only : lobsdiag_allocated,lobsdiagsave,lobsdiag_forenkf + use m_obsNode, only: obsNode + use m_ozNode, only : ozNode + use m_ozNode, only : ozNode_appendto + use m_obsLList, only : obsLList + use obsmod, only : nloz_omi + use obsmod, only : luse_obsdiag + + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + + use gsi_4dvar, only: nobs_bins,hr_obsbin + + use gridmod, only : get_ij,nsig + + use guess_grids, only : nfldsig,ges_prsi,ntguessig,hrdifsig + + use ozinfo, only : jpch_oz,error_oz,pob_oz,gross_oz,nusis_oz + use ozinfo, only : iuse_oz,b_oz,pg_oz + + use jfunc, only : jiter,last,miter,jiterstart + use sparsearr, only: sparr2, new, size, writearray, fullarray + + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + implicit none + +! !INPUT PARAMETERS: + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations + integer(i_kind) , intent(in ) :: mype ! mpi task id + integer(i_kind) , intent(in ) :: nlevs ! number of levels (layer amounts + total column) per obs + integer(i_kind) , intent(in ) :: nreal ! number of pieces of non-ozone info (location, time, etc) per obs + integer(i_kind) , intent(in ) :: nobs ! number of observations + character(20) , intent(in ) :: isis ! sensor/instrument/satellite id + integer(i_kind) , intent(in ) :: is ! integer(i_kind) counter for number of obs types to process + + character(10) , intent(in ) :: obstype ! type of ozone obs + logical , intent(in ) :: ozone_diagsave ! switch on diagnostic output (.false.=no output) + logical , intent(in ) :: init_pass ! state of "setup" processing + +! !INPUT/OUTPUT PARAMETERS: + + real(r_kind),dimension(9,jpch_oz), intent(inout) :: stats_oz ! sums for various statistics as + ! a function of level +!------------------------------------------------------------------------- + +! Declare local parameters + integer(i_kind),parameter:: iint=1 + integer(i_kind),parameter:: ireal=3 + real(r_kind),parameter:: rmiss = -9999.9_r_kind + character(len=*),parameter:: myname="setupozlay" + +! Declare external calls for code analysis + external:: intrp2a1 + external:: tintrp2a1 + external:: intrp3oz1 + external:: grdcrd1 + external:: stop2 + +! Declare local variables + + real(r_kind) omg,rat_err2,dlat,dtime,dlon + real(r_kind) cg_oz,wgross,wnotgross,wgt,arg,exp_arg,term + real(r_kind) psi,errorinv + real(r_kind),dimension(nlevs):: ozges,varinv3,ozone_inv,ozobs + real(r_kind),dimension(nlevs):: ratio_errors,error + real(r_kind),dimension(nlevs-1):: ozp + real(r_kind),dimension(nloz_omi) :: ozp_omi + real(r_kind),dimension(nlevs):: pobs,gross,tnoise + real(r_kind),dimension(nreal+nlevs,nobs):: data + real(r_kind),dimension(nsig+1)::prsitmp + real(r_single),dimension(nlevs):: pob4,grs4,err4 + real(r_single),dimension(ireal,nobs):: diagbuf + real(r_single),allocatable,dimension(:,:,:)::rdiagbuf + real(r_kind),dimension(nloz_omi):: apriori, efficiency,pob_oz_omi + real(r_kind),dimension(nloz_omi+1):: ozges1 + real(r_kind),dimension(miter) :: obsdiag_iuse + + real(r_kind),dimension(nsig,nlevs) :: doz_dz + real(r_kind),dimension(nsig,nloz_omi+1):: doz_dz1 + integer(i_kind) :: oz_ind, nind, nnz + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + + integer(i_kind) i,nlev,ii,jj,iextra,ibin, kk, nperobs + integer(i_kind) k,j,nz,jc,idia,irdim1,istatus,ioff0 + integer(i_kind) ioff,itoss,ikeep,ierror_toq,ierror_poq + integer(i_kind) isolz,ifovn,itoqf + integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,itoq,ipoq + integer(i_kind),dimension(iint,nobs):: idiagbuf + integer(i_kind),dimension(nlevs):: ipos,iouse,ikeepk + + real(r_kind),dimension(4):: tempwij + integer(i_kind) nlevp,nlayers + + character(12) string + character(10) filex + character(128) diag_ozone_file + + logical:: ozdiagexist + logical,dimension(nobs):: luse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical:: l_may_be_passive, proceed + + logical:: in_curbin, in_anybin, save_jacobian + type(ozNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_oz + type(obsLList),pointer,dimension(:):: ozhead + ozhead => obsLL(:) + + save_jacobian = ozone_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + + mm1=mype+1 +! +!********************************************************************************* +! Initialize arrays + do j=1,nlevs + ipos(j)=0 + iouse(j)=-2 + tnoise(j)=1.e10_r_kind + gross(j)=1.e10_r_kind + pobs(j)=1.e10_r_kind + end do + +! Locate data for satellite in ozinfo arrays + itoss =1 + l_may_be_passive=.false. + jc=0 + do j=1,jpch_oz + if (isis == nusis_oz(j)) then + jc=jc+1 + if (jc > nlevs) then + write(6,*)'SETUPOZLAY: ***ERROR*** in level numbers, jc,nlevs=',jc,nlevs,& + ' ***STOP IN SETUPOZLAY***' + call stop2(71) + endif + ipos(jc)=j + + iouse(jc)=iuse_oz(j) + tnoise(jc)=error_oz(j) + gross(jc)=min(r10*gross_oz(j),h300) + if (obstype == 'sbuv2' .or. obstype == 'ompsnp') then + pobs(jc)=pob_oz(j) * 1.01325_r_kind + else + pobs(jc)=pob_oz(j) + endif + + if (iouse(jc)<-1 .or. (iouse(jc)==-1 .and. & + .not.ozone_diagsave)) then + tnoise(jc)=1.e10_r_kind + gross(jc) =1.e10_r_kind + endif + if (iouse(jc)>-1) l_may_be_passive=.true. + if (tnoise(jc)<1.e4_r_kind) itoss=0 + endif + end do + nlev=jc + +! Handle error conditions + if (nlevs>nlev) write(6,*)'SETUPOZLAY: level number reduced for ',obstype,' ', & + nlevs,' --> ',nlev + if(nlev == 0 .or. itoss == 1)then + if (nlev == 0 .and. mype == 0) then + write(6,*)'SETUPOZLAY: no levels found for ',isis + endif + if (itoss==1 .and. mype == 0) then + if (mype==0) write(6,*)'SETUPOZLAY: all obs variances > 1.e4. Do not use ',& + 'data from satellite ',isis + endif + if (nobs>0) read(lunin) + +! Release memory of local guess arrays + call final_vars_ + + return + endif + if(ozone_diagsave)then + irdim1=7 + ioff0=irdim1 + if(lobsdiagsave) irdim1=irdim1+4*miter+1 + if (save_jacobian) then + nnz = nsig ! number of non-zero elements in dH(x)/dx profile + nind = 1 + call new(dhx_dx, nnz, nind) + irdim1 = irdim1 + size(dhx_dx) + endif + + allocate(rdiagbuf(irdim1,nlevs,nobs)) + if(netcdf_diag) call init_netcdf_diag_ + end if + + +! Read and transform ozone data + read(lunin) data,luse,ioid + +! index information for data array (see reading routine) + itime=2 ! index of analysis relative obs time + ilon=3 ! index of grid relative obs location (x) + ilat=4 ! index of grid relative obs location (y) + ilone=5 ! index of earth relative longitude (degrees) + ilate=6 ! index of earth relative latitude (degrees) + itoq=7 ! index of total ozone error flag (sbuv2 only) + ipoq=8 ! index of profile ozone error flag (sbuv2 only) + isolz=8 ! index of solar zenith angle (gome and omi only) + itoqf=9 ! index of row anomaly (omi only) + ifovn=14 ! index of scan position (gome and omi only) + + +! If requested, save data for diagnostic ouput + if(ozone_diagsave)ii=0 + +! Convert observation (lat,lon) from earth to grid relative values + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + dtime=data(itime,i) + + if (obstype == 'sbuv2' .or. obstype == 'ompsnp') then + if (nobskeep>0) then +! write(6,*)'setupozlay: nobskeep',nobskeep + call stop2(259) + end if + + ierror_toq = nint(data(itoq,i)) + ierror_poq = nint(data(ipoq,i)) + +! Note: ozp as log(pobs) + call intrp2a1(ges_prsi(1,1,1,ntguessig),prsitmp,dlat,& + dlon,nsig+1,mype) + +! Map observation pressure to guess vertical coordinate + psi=one/(prsitmp(1)*r10) ! factor of 10 converts to hPa + do nz=1,nlevs-1 + if ((pobs(nz)*psi) < one) then + ozp(nz) = pobs(nz)/r10 + else + ozp(nz) = prsitmp(1) + end if + call grdcrd1(ozp(nz),prsitmp,nsig+1,-1) + enddo + end if + + if (obstype == 'omieff' .or. obstype == 'tomseff') then + pob_oz_omi(nloz_omi) = 1000.0_r_kind* 1.01325_r_kind + do j=nloz_omi-1, 1, -1 + pob_oz_omi(j) = pob_oz_omi(j+1)/2.0 + enddo + call intrp2a1(ges_prsi(1,1,1,ntguessig),prsitmp,dlat,& + dlon,nsig+1,mype) + +! Map observation pressure to guess vertical coordinate + psi=one/(prsitmp(1)*r10) ! factor of 10 converts to hPa + do nz=1,nloz_omi - 1 + if ((pob_oz_omi(nz)*psi) < one) then + ozp_omi(nz) = pob_oz_omi(nz)/r10 + else + ozp_omi(nz) = prsitmp(1) + end if + call grdcrd1(ozp_omi(nz),prsitmp,nsig+1,-1) + enddo + ozp_omi(nloz_omi) = prsitmp(1) + call grdcrd1(ozp_omi(nloz_omi),prsitmp,nsig+1,-1) + end if + + if (obstype /= 'omieff' .and. obstype /= 'tomseff') then + call intrp3oz1(ges_oz,ozges,dlat,dlon,ozp,dtime,& + nlevs,mype,doz_dz) + endif + + + + if(ozone_diagsave .and. luse(i))then + ii=ii+1 + idiagbuf(1,ii)=mype ! mpi task number + diagbuf(1,ii) = data(ilate,i) ! lat (degree) + diagbuf(2,ii) = data(ilone,i) ! lon (degree) + diagbuf(3,ii) = data(itime,i)-time_offset ! time (hours relative to analysis) + endif + +! Interpolate interface pressure to obs location +! Calculate innovations, perform gross checks, and accumualte +! numbers for statistics + +! For OMI/GOME, nlev=1 + do k=1,nlev + j=ipos(k) + if (obstype == 'omieff' .or. obstype == 'tomseff' ) then + ioff=ifovn+1 ! + else + ioff=nreal+k ! SBUV and OMI w/o efficiency factors + endif + +! Compute innovation and load obs error into local array + ! KW OMI and TOMS have averaging kernels + if (obstype == 'omieff' .or. obstype == 'tomseff' ) then + ! everything in data is from top to bottom + nlayers = nloz_omi + 1 + apriori(1:nloz_omi) = data(ioff:ioff+nloz_omi -1, i) + ioff = ioff + nloz_omi + efficiency(1:nloz_omi) = data(ioff:ioff+nloz_omi -1, i) + ! Compute ozges + call intrp3oz1(ges_oz,ozges1,dlat,dlon,ozp_omi,dtime,& + nlayers,mype,doz_dz1) + ozges(k) = zero + doz_dz(:,k) = zero + do kk = 1, nloz_omi + ozges(k) = ozges(k) + apriori(kk) + efficiency(kk)*(ozges1(kk)-apriori(kk)) + doz_dz(:,k) = doz_dz(:,k) + efficiency(kk)*doz_dz1(:,kk) + end do + ioff = 37_i_kind + ozobs(k) = data(ioff,i) + else ! Applying averaging kernels for OMI + apriori(1:nloz_omi) = -99.99 ! this will identify non-OMIEFF data for intoz + ozobs(k) = data(ioff,i) + endif + + ozone_inv(k) = ozobs(k)-ozges(k) + error(k) = tnoise(k) + +! Set inverse obs error squared and ratio_errors + if (error(k)<1.e4_r_kind) then + varinv3(k) = one/(error(k)**2) + ratio_errors(k) = one + else + varinv3(k) = zero + ratio_errors(k) = zero + endif + +! Perform gross check + if(abs(ozone_inv(k)) > gross(k) .or. ozobs(k) > 1000._r_kind .or. & + ozges(k)1.e-10_r_kind) ikeepk(k)=1 + end do + ikeep=maxval(ikeepk) + endif ! (in_curbin) + +! In principle, we want ALL obs in the diagnostics structure but for +! passive obs (monitoring), it is difficult to do if rad_diagsave +! is not on in the first outer loop. For now we use l_may_be_passive... + if (l_may_be_passive) then +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)'SETUPOZLAY: ',mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + + if(in_curbin) then +! Process obs have at least one piece of information that passed qc checks + if (.not. last .and. ikeep==1) then + + allocate(my_head) + call ozNode_appendto(my_head,ozhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + + nlevp=max(nlev-1,1) + if (obstype == 'omieff' .or. obstype == 'tomseff' ) nlevp = nloz_omi + allocate(my_head%res(nlev), & + my_head%err2(nlev), & + my_head%raterr2(nlev), & + my_head%prs(nlevp), & + my_head%wij(4,nsig), & + my_head%dprsi(nsig), & + my_head%ipos(nlev), & + my_head%apriori(nloz_omi), & + my_head%efficiency(nloz_omi), stat=istatus) + if (istatus/=0) write(6,*)'SETUPOZLAY: allocate error for oz_point, istatus=',istatus + if(luse_obsdiag)allocate(my_head%diags(nlev)) + +! Set number of levels for this obs + my_head%nloz = nlev-1 ! NOTE: for OMI/GOME, nloz=0 + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,tempwij) + + call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime,hrdifsig,& + nsig+1,mype,nfldsig) + + my_head%rozcon = rozcon + do k = 1,nsig + my_head%dprsi(k) = prsitmp(k)-prsitmp(k+1) + my_head%wij(1,k)=tempwij(1)*rozcon*(prsitmp(k)-prsitmp(k+1)) + my_head%wij(2,k)=tempwij(2)*rozcon*(prsitmp(k)-prsitmp(k+1)) + my_head%wij(3,k)=tempwij(3)*rozcon*(prsitmp(k)-prsitmp(k+1)) + my_head%wij(4,k)=tempwij(4)*rozcon*(prsitmp(k)-prsitmp(k+1)) + end do + +! Increment data counter and save information used in +! inner loop minimization (int* and stp* routines) + + my_head%luse=luse(i) + my_head%time=dtime + + if (obstype == 'sbuv2'.or. obstype == 'ompsnp' ) then + do k=1,nlevs-1 + my_head%prs(k) = ozp(k) + enddo + else if (obstype == 'omieff' .or. obstype == 'tomseff') then + do k=1,nloz_omi + my_head%prs(k) = ozp_omi(k) + enddo + else ! GOME or OMI w/o efficiency factors + + my_head%prs(1) = zero ! any value is OK, never used + endif + + my_head => null() + endif ! < .not.last > + endif ! (in_curbin) + +! Link obs to diagnostics structure + do k=1,nlevs + if (luse_obsdiag) then + nperobs=-99999; if(k==1) nperobs=nlevs + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = k ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(in_curbin) then + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=varinv3(k)*ratio_errors(k)**2, & + jiter=jiter, muse=(ikeepk(k)==1), nldepart=ozone_inv(k) ) + endif + + if (.not. last .and. ikeep==1) then + my_head => tailNode_typecast_(ozhead(ibin)) + if(.not.associated(my_head)) & + call die(myname,'unexpected, associated(my_head) =',associated(my_head)) + + my_head%ipos(k) = ipos(k) + my_head%res(k) = ozone_inv(k) + my_head%err2(k) = varinv3(k) + my_head%raterr2(k) = ratio_errors(k)**2 + my_head%apriori(1:nloz_omi) = apriori(1:nloz_omi) + my_head%efficiency(1:nloz_omi) = efficiency(1:nloz_omi) + + if (luse_obsdiag) then + call obsdiagnode_assert(my_diag,my_head%idv,my_head%iob,k,myname,'my_diag:my_head') + my_head%diags(k)%ptr => my_diag + endif + + my_head => null() + endif + + if (ozone_diagsave.and.lobsdiagsave.and.luse(i)) then + associate(odiag => my_diag) + idia=6 + do jj=1,miter + idia=idia+1 + if (odiag%muse(jj)) then + rdiagbuf(idia,k,ii) = one + obsdiag_iuse(jj) = one + else + rdiagbuf(idia,k,ii) = -one + obsdiag_iuse(jj) = -one + endif + enddo + do jj=1,miter+1 + idia=idia+1 + rdiagbuf(idia,k,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,k,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,k,ii) = odiag%obssen(jj) + enddo + end associate ! odiag + + if (netcdf_diag) then +! TBD: Sensitivities must be written out in coordination w/ rest of obs +! associate(odiag => my_diagLL%tail) +! call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) +! call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) +! call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) +! call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) +! end associate ! odiag + endif + endif + endif ! (in_curbin) + + enddo ! < over nlevs > + + else + + if(in_curbin) then + if (ozone_diagsave.and.lobsdiagsave.and.luse(i)) then + rdiagbuf(7:irdim1,1:nlevs,ii) = zero + endif + endif ! (in_curbin) + + endif ! < l_may_be_passive > + + end do ! end do i=1,nobs + +! If requested, write to diagnostic file + if (ozone_diagsave) then + + if (netcdf_diag) call nc_diag_write + + if (binary_diag .and. ii>0) then + filex=obstype + write(string,100) jiter +100 format('_',i2.2) + diag_ozone_file = trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // (string) + if(init_pass) then + open(4,file=diag_ozone_file,form='unformatted',status='unknown',position='rewind') + else + inquire(file=diag_ozone_file,exist=ozdiagexist) + if (ozdiagexist) then + open(4,file=diag_ozone_file,form='unformatted',status='old',position='append') + else + open(4,file=diag_ozone_file,form='unformatted',status='unknown',position='rewind') + endif + endif + iextra=0 + if (init_pass .and. mype==mype_diaghdr(is)) then + write(4) isis,dplat(is),obstype,jiter,nlevs,ianldate,iint,ireal,irdim1,ioff0 + write(6,*)'SETUPOZLAY: write header record for ',& + isis,iint,ireal,irdim1,' to file ',trim(diag_ozone_file),' ',ianldate + do i=1,nlevs + pob4(i)=pobs(i) + grs4(i)=gross(i) + err4(i)=tnoise(i) + end do + write(4) pob4,grs4,err4,iouse + endif + write(4) ii + write(4) idiagbuf(:,1:ii),diagbuf(:,1:ii),rdiagbuf(:,:,1:ii) + close(4) + endif ! binary_diag + endif ! ozone_diagsave + +! Release memory of local guess arrays + call final_vars_ + +! clean up + if(ozone_diagsave) deallocate(rdiagbuf) + +! End of routine + return + + return + contains + function tailNode_typecast_(oll) result(ptr_) +!> Cast the tailNode of oll to an ozNode, as in +!> ptr_ => typecast_(tailNode_(oll)) + + use m_ozNode , only: ozNode , typecast_ => ozNode_typecast + use m_obsLList, only: obsLList, tailNode_ => obsLList_tailNode + use m_obsNode , only: obsNode + implicit none + type( ozNode),pointer:: ptr_ + type(obsLList),target ,intent(in):: oll + + class(obsNode),pointer:: inode_ + inode_ => tailNode_(oll) + ptr_ => typecast_(inode_) + end function tailNode_typecast_ + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::oz', ivar, istatus ) + proceed=ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get oz ... + varname='oz' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_oz))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_oz(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_oz(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_oz(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + + write(string,900) jiter +900 format('_',i2.2,'.nc4') + filex=obstype + diag_ozone_file = trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // (string) + + inquire(file=diag_ozone_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_ozone_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_ozone_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_ozone_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_ozone_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_ozone_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_ + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_ +! Observation class + character(7),parameter :: obsclass = ' ozlay' +! contents interleafed above should be moved here (RTodling) + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_oz)) deallocate(ges_oz) + end subroutine final_vars_ + +end subroutine setupozlay +end module oz_setup + +module o3l_setup + implicit none + private + public:: setup + interface setup; module procedure setupozlev; end interface + +contains +subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& + obstype,isis,is,ozone_diagsave,init_pass) + +!$$$ subprogram documentation block +! . . . +! subprogram: setupozlev --- Compute rhs of oi for mls ozone mixing ratio obs at pressure levels +! +! prgrmmr: H.Liu org: np22 date: 2010-10-18 +! +! abstract: For sbuv ozone observations (layer amounts and total +! column, this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2010-10-18 h.liu - subroutine for mls data: based on setupoz and Sienkiewicz's setupo3lv +! 2013-10-19 todling - metguess now holds background +! 2013-11-26 guo - removed nkeep==0 escaping to allow more than one obstype sources. +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2014-05-12 wargan - refine MLS gross check +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-12-09 mccarty - add netcdf_diag capability +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nlevs - number of levels (layer amounts + total column) per obs +! nreal - number of pieces of non-ozone info (location, time, etc) per obs +! nobs - number of observations +! isis - sensor/instrument/satellite id +! is - integer(i_kind) counter for number of obs types to process +! obstype - type of ozone obs +! ozone_diagsave - switch on diagnostic output (.false.=no output) +! stats_oz - sums for various statistics as a function of level +! +! output argument list: +! stats_oz - sums for various statistics as a function of level +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq HP +! +!$$$ end documentation block + +! !USES: + + use mpeu_util, only: die,perr,getindex + use kinds, only: r_kind,r_single,i_kind + + use state_vectors, only: svars3d, levels + use sparsearr, only : sparr2, new, size, writearray + + use m_obsdiagNode, only : obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + + use obsmod, only : dplat,nobskeep + use obsmod, only : mype_diaghdr,dirname,time_offset,ianldate + use obsmod, only : lobsdiag_allocated,lobsdiagsave,lobsdiag_forenkf + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use m_obsNode, only: obsNode + use m_o3lNode, only : o3lNode + use m_o3lNode, only : o3lNode_appendto + use m_obsLList, only: obsLList + use obsmod, only : luse_obsdiag + + use guess_grids, only : nfldsig,ges_lnprsl,hrdifsig + + use constants, only : zero,half,one,two,tiny_r_kind,four + use constants, only : cg_term,wgtlim,r10,constoz + + use gsi_4dvar, only: nobs_bins,hr_obsbin + + use gridmod, only : get_ijk,nsig + + use ozinfo, only : gross_oz, jpch_oz, nusis_oz + use ozinfo, only : b_oz,pg_oz + + use jfunc, only : jiter,last,miter,jiterstart + + use m_dtime, only: dtime_setup, dtime_check + + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + implicit none + +! !INPUT PARAMETERS: + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations + integer(i_kind) , intent(in ) :: mype ! mpi task id + integer(i_kind) , intent(in ) :: nlevs ! number of levels (layer amounts + total column) per obs + integer(i_kind) , intent(in ) :: nreal ! number of pieces of non-ozone info (location, time, etc) per obs + integer(i_kind) , intent(in ) :: nobs ! number of observations + character(20) , intent(in ) :: isis ! sensor/instrument/satellite id + integer(i_kind) , intent(in ) :: is ! integer(i_kind) counter for number of obs types to process + + character(10) , intent(in ) :: obstype ! type of ozone obs + logical , intent(in ) :: ozone_diagsave ! switch on diagnostic output (.false.=no output) + logical , intent(in ) :: init_pass ! state of "setup" processing + +! !INPUT/OUTPUT PARAMETERS: + + real(r_kind),dimension(9,jpch_oz), intent(inout) :: stats_oz ! sums for various statistics as + ! a function of level +!------------------------------------------------------------------------- + +! Declare local parameters + integer(i_kind),parameter:: iint=1 + integer(i_kind),parameter:: ireal=3 + real(r_kind),parameter:: rmiss = -9999.9_r_kind + character(len=*),parameter:: myname="setupozlev" + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: tintrp3 + external:: grdcrd1 + external:: stop2 + +! Declare local variables + real(r_kind) :: delz + integer(i_kind) :: iz, oz_ind, nind, nnz + type(sparr2) :: dhx_dx + + real(r_kind) o3ges, o3ppmv + real(r_kind) rlow,rhgh,sfcchk + real(r_kind) omg,rat_err2,dlat,dtime,dlon + real(r_kind) cg_oz,wgross,wnotgross,wgt,arg,exp_arg,term + real(r_kind) errorinv + real(r_kind) psges,ozlv,airnd,uvnd,visnd + + real(r_kind) varinv3,ratio_errors + real(r_kind) dpres,obserror,ozone_inv,preso3l + real(r_kind),dimension(nreal+nlevs,nobs):: data + real(r_kind),dimension(nsig):: prsltmp + real(r_single),dimension(ireal,nobs):: diagbuf + real(r_single),allocatable,dimension(:,:,:)::rdiagbuf + + integer(i_kind) i,ii,jj,iextra,ibin + integer(i_kind) k,j,idia,irdim1,ioff0 + integer(i_kind) isolz,iuse + integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,iozmr,ilev,ipres,iprcs,imls_levs + integer(i_kind),dimension(iint,nobs):: idiagbuf + integer(i_kind) iairnd,iuvnd,ivisnd + real(r_kind) gross + + character(12) string + character(10) filex + character(128) diag_ozone_file + + logical:: ozdiagexist + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + logical:: in_curbin, in_anybin, save_jacobian + type(o3lNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_oz + type(obsLList),pointer,dimension(:):: o3lhead + o3lhead => obsLL(:) + + save_jacobian = ozone_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +! Check to see if required guess fields are available +! Question: Should a message be produced before return, to inform the +! system what has been going on? + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + + mm1=mype+1 + + +! +!********************************************************************************* +! Initialize arrays + + if(ozone_diagsave)then + irdim1=10 + ioff0 = irdim1 + if(lobsdiagsave) irdim1=irdim1+4*miter+1 + if (save_jacobian) then + nnz = 2 ! number of non-zero elements in dH(x)/dx profile + nind = 1 + call new(dhx_dx, nnz, nind) + irdim1 = irdim1 + size(dhx_dx) + endif + allocate(rdiagbuf(irdim1,1,nobs)) + rdiagbuf=0._r_single + if(netcdf_diag) call init_netcdf_diag_ + end if + +! index information for data array (see reading routine) + itime=2 ! index of analysis relative obs time + ilon=3 ! index of grid relative obs location (x) + ilat=4 ! index of grid relative obs location (y) + ilone=5 ! index of earth relative longitude (degrees) + ilate=6 ! index of earth relative latitude (degrees) + isolz=7 ! index of solar zenith angle + iuse=8 ! index of usage flag + ipres=9 ! index of pressure in log(cb) + iprcs=10 ! index of mixing ratio precision in ppmv + ilev=11 ! index of obs level + imls_levs=12 ! index of mls nrt vertical levels + iozmr=13 ! index of ozone mixing ratio in ppmv + iairnd = 14 ! index of lg10 nunber density of air + iuvnd = 15 ! index of log10 number density ozone - uv + ivisnd = 16 ! index of log10 number density ozone - vis + +! Read and transform ozone data + read(lunin) data,luse,ioid + +! Set flag for obs use + do i=1,nobs + muse(i)=nint(data(iuse,i))<=jiter + end do + +! If requested, save data for diagnostic ouput + if(ozone_diagsave)ii=0 + +! Convert observation (lat,lon) from earth to grid relative values + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + dpres=data(ipres,i) !pressure in log(cb) + preso3l =r10*exp(dpres) + + dlat=data(ilat,i) + dlon=data(ilon,i) + dtime=data(itime,i) + obserror=data(iprcs,i) + + if (nobskeep>0) then + write(6,*)'setupozlev: nobskeep',nobskeep + call stop2(338) + end if + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*) 'SETUPOZLEV: ', mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Interpolate ps to obs locations/times + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig, & + mype,nfldsig) + +! Interpolate log(pres) at mid-layers to obs locations/times + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig, & + nsig,mype,nfldsig) + +! Get approximate k value of surface by using surface pressure +! for surface check. + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp,nsig,-1) + + if(ozone_diagsave .and. luse(i))then + ii=ii+1 + idiagbuf(1,ii)=mype ! mpi task number + diagbuf(1,ii) = data(ilate,i) ! lat (degree) + diagbuf(2,ii) = data(ilone,i) ! lon (degree) + diagbuf(3,ii) = data(itime,i)-time_offset ! time (hours relative to analysis) + endif + + ozlv=data(iozmr,i) ! ozone mixing ratio in ppmv at pressure level + if(obstype == "ompslp")then + airnd = data(iairnd,i) + uvnd = data(iuvnd,i) + visnd = data(ivisnd,i) + else + airnd = zero + uvnd = zero + visnd = zero + endif + +! Pressure level of data (dpres) converted to grid coordinate +! (wrt mid-layer pressure) + call grdcrd1(dpres,prsltmp,nsig,-1) + +! Check if observation above model top or below model surface + + rlow=max(sfcchk-dpres,zero) + rhgh=max(dpres-0.001_r_kind-float(nsig),zero) + +! calculate factor for error adjustment if too (high,low) + ratio_errors=obserror/(obserror+1.0e6_r_kind*rhgh+four*rlow) + +! Check to see if observations is above the top of the model + if (dpres > float(nsig)) then + ratio_errors=zero + obserror=1.0e6_r_kind + end if + +! Interpolate guess ozone to observation location and time + call tintrp31(ges_oz,o3ges,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + iz = max(1, min( int(dpres), nsig)) + delz = max(zero, min(dpres - float(iz), one)) + if (save_jacobian) then + oz_ind = getindex(svars3d, 'oz') + if (oz_ind < 0) then + print *, 'Error: no variable oz in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = iz + sum(levels(1:oz_ind-1)) + dhx_dx%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:oz_ind-1)) + + dhx_dx%val(1) = constoz * (one - delz) ! weight for iz's level + dhx_dx%val(2) = constoz * delz ! weight for iz+1's level + endif + + +! Compute innovations - background o3ges in g/g so adjust units +! Leave increment in ppmv for gross checks, etc. + + o3ppmv = o3ges * constoz + ozone_inv=ozlv - o3ppmv + +! Perform gross checks, and accumualte numbers for statistics + + j=nint(data(ilev,i)) !the entry # in ozinfo.txt + +! Set inverse obs error squared and ratio_errors + if (obserror>zero .and. obserror<1.e4_r_kind) then + varinv3 = one/(obserror**2) + ratio_errors = one*ratio_errors + else + varinv3 = zero + ratio_errors = zero + endif + +! toss the obs not recommended by the data provider + if (nint(data(iuse,i)) == 1000 ) then + varinv3=zero + ratio_errors=zero + endif + +! Perform gross check (smallness of O-F criterion added) + do jj=1,jpch_oz + if (isis == nusis_oz(jj) .and. jj == j) then + gross=gross_oz(jj) + endif + end do + + if( abs(ozone_inv)/obserror > gross .or.ozlv > 1.e+02_r_kind ) then + varinv3=zero + ratio_errors=zero + if(luse(i))stats_oz(2,j) = stats_oz(2,j) + one ! number of obs tossed + endif + +! check if gross check failed, mark failed obs for non-use + if (ratio_errors/obserror <=tiny_r_kind) then + muse(i)=.false. + end if + +! Accumulate numbers for statistics + rat_err2 = ratio_errors**2 + if (varinv3>tiny_r_kind .or. ozone_diagsave) then + if(luse(i))then + omg=ozone_inv + stats_oz(1,j) = stats_oz(1,j) + one ! # obs + stats_oz(3,j) = stats_oz(3,j) + omg ! (o-g) + stats_oz(4,j) = stats_oz(4,j) + omg*omg ! (o-g)**2 + stats_oz(5,j) = stats_oz(5,j) + omg*omg*varinv3*rat_err2 ! penalty + stats_oz(6,j) = stats_oz(6,j) + ozlv ! obs + + exp_arg = -half*varinv3*omg**2 + errorinv = sqrt(varinv3) + if (pg_oz(j) > tiny_r_kind .and. errorinv > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-pg_oz(j) + cg_oz=b_oz(j)*errorinv + wgross = cg_term*pg_oz(j)/(cg_oz*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + else + term = exp_arg + wgt = one + endif + + stats_oz(8,j) = stats_oz(8,j) -two*rat_err2*term + if(wgt < wgtlim) stats_oz(9,j)=stats_oz(9,j)+one + end if + endif + +! If not assimilating this observation, reset inverse variance to zero + if ( .not. muse(i)) then + varinv3=zero + ratio_errors=zero + rat_err2 = zero + end if + if (rat_err2*varinv3>tiny_r_kind .and. luse(i)) & + stats_oz(7,j) = stats_oz(7,j) + one + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag,wgtjo=varinv3*ratio_errors**2, & + jiter=jiter,muse=muse(i),nldepart=ozone_inv) + endif + + if (.not. last .and. muse(i) ) then + + allocate(my_head) + call o3lNode_appendto(my_head,o3lhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j,k) indices of guess gridpoint that bound obs location + my_head%dlev = dpres + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) + + do k=1,8 + my_head%wij(k)=my_head%wij(k)*constoz + end do + + my_head%res = ozone_inv + my_head%err2 = varinv3 + my_head%raterr2 = ratio_errors**2 + my_head%luse = luse(i) + my_head%time = dtime + my_head%b = b_oz(j) + my_head%pg = pg_oz(j) + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + +! Optionally save data for diagnostics + if (ozone_diagsave .and. luse(i)) then + errorinv = sqrt(varinv3*rat_err2) + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) + end if !end if(ozone_diagsave ) + + end do ! end do i=1,nobs + +! If requested, write to diagnostic file + if (ozone_diagsave) then + if (netcdf_diag) call nc_diag_write + if (binary_diag .and. ii>0) then + filex=obstype + write(string,100) jiter +100 format('_',i2.2) + diag_ozone_file = trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // (string) + if(init_pass) then + open(4,file=diag_ozone_file,form='unformatted',status='unknown',position='rewind') + else + inquire(file=diag_ozone_file,exist=ozdiagexist) + if (ozdiagexist) then + open(4,file=diag_ozone_file,form='unformatted',status='old',position='append') + else + open(4,file=diag_ozone_file,form='unformatted',status='unknown',position='rewind') + endif + endif + iextra=0 + if (init_pass .and. mype==mype_diaghdr(is)) then + write(4) isis,dplat(is),obstype,jiter,nlevs,ianldate,iint,ireal,irdim1,ioff0 + write(6,*)'SETUPOZLEV: write header record for ',& + isis,iint,ireal,irdim1,' to file ',trim(diag_ozone_file),' ',ianldate + endif + write(4) ii + write(4) idiagbuf(:,1:ii),diagbuf(:,1:ii),rdiagbuf(:,1,1:ii) + close(4) + endif ! binary_diag + endif ! ozone_diagsave + +! Release memory of local guess arrays + call final_vars_ + +! clean up + if(ozone_diagsave) deallocate(rdiagbuf) + +! End of routine + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::oz' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get oz ... + varname='oz' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_oz))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_oz(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_oz(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_oz(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('_',i2.2,'.nc4') + filex=obstype + diag_ozone_file = trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // (string) + + inquire(file=diag_ozone_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_ozone_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_ozone_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_ozone_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_ozone_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_ozone_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Satellite_Sensor", isis) + call nc_diag_header("Satellite", dplat(is)) + call nc_diag_header("Observation_type", obstype) + endif + + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + rdiagbuf(1,1,ii) = ozlv ! obs + rdiagbuf(2,1,ii) = ozone_inv ! obs-ges + rdiagbuf(3,1,ii) = errorinv ! inverse observation error + rdiagbuf(4,1,ii) = preso3l ! override solar zenith angle with a reference pressure (in hPa) + rdiagbuf(5,1,ii) = rmiss ! fovn + rdiagbuf(6,1,ii) = obserror ! ozone mixing ratio precision + rdiagbuf(7,1,ii) = 1.e+10_r_single ! spread (filled in by EnKF) + rdiagbuf(8,1,ii) = airnd ! log10 air number density + rdiagbuf(9,1,ii) = uvnd ! log10 ozone number density uv + rdiagbuf(10,1,ii) = visnd ! log10 ozone number density vis + + if (lobsdiagsave) then + idia=6 + do jj=1,miter + idia=idia+1 + if (odiag%muse(jj)) then + rdiagbuf(idia,1,ii) = one + else + rdiagbuf(idia,1,ii) = -one + endif + enddo + do jj=1,miter+1 + idia=idia+1 + rdiagbuf(idia,1,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,1,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,1,ii) = odiag%obssen(jj) + enddo + endif + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(idia+1:irdim1,1,ii)) + idia = idia + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' ozlev' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("MPI_Task_Number", mype ) + call nc_diag_metadata("Time", sngl(data(itime,i)-time_offset)) + call nc_diag_metadata("Inverse_Observation_Error", sngl(errorinv) ) + call nc_diag_metadata("Observation", sngl(ozlv) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ozone_inv) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(ozone_inv) ) + call nc_diag_metadata("Reference_Pressure", sngl(preso3l) ) + call nc_diag_metadata("Input_Observation_Error", sngl(obserror) ) + if(obstype =="omps_lp")then + call nc_diag_metadata("Log10 Air Number Density", sngl(airnd)) + call nc_diag_metadata("Log10 Ozone Number Density UV", sngl(uvnd)) + call nc_diag_metadata("Log10 Ozone Number Density VIS",sngl(visnd)) + endif + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_oz)) deallocate(ges_oz) + if(allocated(ges_ps)) deallocate(ges_ps) + end subroutine final_vars_ + +end subroutine setupozlev +end module o3l_setup diff --git a/src/gsi/setuppblh.f90 b/src/gsi/setuppblh.f90 new file mode 100644 index 000000000..6d2a56b9f --- /dev/null +++ b/src/gsi/setuppblh.f90 @@ -0,0 +1,658 @@ +module pblh_setup + implicit none + private + public:: setup + interface setup; module procedure setuppblh; end interface + +contains +subroutine setuppblh(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuppblh compute rhs for conventional surface pblh +! prgmmr: derber org: np23 date: 2004-07-20 +! +! abstract: For sea surface temperature observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2009-10-21 zhu +! 2011-02-19 zhu - update +! 2013-01-26 parrish - change from tintrp2a to tintrp2a11, tintrp2a11 (so debug compile on WCOSS works) +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! before retuning to setuprhsall.f90 +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig + use m_obsdiagNode, only : obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + + use obsmod, only: rmiss_single,ianldate,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use m_obsNode, only: obsNode + use m_pblhNode, only: pblhNode + use m_pblhNode, only: pblhNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: bmiss,luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig + use gridmod, only: get_ij + use constants, only: zero,tiny_r_kind,one,half,wgtlim, & + two,cg_term,pi,huge_single,r1000 + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) pblhges,dlat,dlon,ddiff,dtime,error + real(r_kind) scale,val2,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,halfpi,rwgt + real(r_kind) cg_pblh,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,ipblh,id,itime,ikx,imaxerr,iqc + integer(i_kind) iuse,ihgt,ilate,ilone,istnelv + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + + logical:: in_curbin, in_anybin + type(pblhNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + character(len=*),parameter:: myname='setuppblh' + + real(r_kind),allocatable,dimension(:,:,:) :: ges_ps + real(r_kind),allocatable,dimension(:,:,:) :: ges_z + real(r_kind),allocatable,dimension(:,:,:) :: ges_pblh + + equivalence(rstation_id,station_id) + + type(obsLList),pointer,dimension(:):: pblhhead + pblhhead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ihgt=4 ! index of observation elevation + ipblh=5 ! index of pblh observation + id=6 ! index of station id + itime=7 ! index of observation time in data array + ikxx=8 ! index of ob type + imaxerr=9 ! index of pblh max error + iqc=10 ! index of qulaity mark + iuse=11 ! index of use parameter + ilone=12 ! index of longitude (degrees) + ilate=13 ! index of latitude (degrees) + istnelv=14 ! index of station elevation (m) + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for missing data !need obs value and error + do i=1,nobs + if (abs(data(ipblh,i)-bmiss) .lt. 10.0_r_kind) then + muse(i)=.false. + data(ipblh,i)=rmiss_single ! for diag output + end if + end do + + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + end do + end do + + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + ii=0 + nchar=1 + ioff0=20 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + if(netcdf_diag) call init_netcdf_diag_ + end if + + halfpi = half*pi + mm1=mype+1 + scale=one + + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + ikx = nint(data(ikxx,i)) + error=data(ier,i) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Interpolate to get pblh at obs location/time + call tintrp2a11(ges_pblh,pblhges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + +! Adjust observation error + ratio_errors=error/data(ier,i) + error=one/error + + ddiff=data(ipblh,i)-pblhges + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross check using innovation normalized by error + if (abs(data(ipblh,i)-rmiss_single) >= tiny_r_kind ) then + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + else + error = zero + ratio_errors=zero + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag,jiter=nobskeep,muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_pblh=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_pblh*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + end if + ress = ddiff*scale + ressw2 = ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + if (abs(data(ipblh,i)-rmiss_single) >=tiny_r_kind) then + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + end if + + endif + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag,wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=ddiff) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call pblhNode_appendto(my_head,pblhhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'pbl',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::pblh' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get pblh ... + varname='pblh' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_pblh))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_pblh(size(rank2,1),size(rank2,2),nfldsig)) + ges_pblh(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_pblh(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_pblh_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(ipblh,i) ! PBLH observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(ipblh,i)-pblhges! obs-ges w/o bias correction (K) (future slot) + + rdiagbuf(20,ii) = rmiss_single ! type of measurement + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' pblh' + real(r_kind),parameter:: missing = -9.99e9_r_kind + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", missing ) + call nc_diag_metadata("Height", data(ihgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(ipblh,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(ipblh,i)-pblhges ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps )) deallocate(ges_ps ) + if(allocated(ges_pblh)) deallocate(ges_pblh) + end subroutine final_vars_ + +end subroutine setuppblh +end module pblh_setup diff --git a/src/setuppcp.f90 b/src/gsi/setuppcp.f90 similarity index 89% rename from src/setuppcp.f90 rename to src/gsi/setuppcp.f90 index 8137183c4..970bc5b9a 100644 --- a/src/setuppcp.f90 +++ b/src/gsi/setuppcp.f90 @@ -1,3 +1,10 @@ +module pcp_setup + implicit none + private + public:: setup + interface setup; module procedure setuppcp; end interface + +contains !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- @@ -7,7 +14,7 @@ ! ! !INTERFACE: ! -subroutine setuppcp(lunin,mype,aivals,nele,nobs,& +subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,& obstype,isis,is,pcp_diagsave,init_pass) ! !USES: @@ -46,14 +53,26 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& use tendsmod, only: gsi_tendency_bundle use obsmod, only: ndat,dplat,time_offset - use m_obsdiags, only: pcphead + + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + + use m_obsdiagNode, only : obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + use obsmod, only: time_offset - use obsmod, only: i_pcp_ob_type,obsdiags,lobsdiagsave,ianldate + use obsmod, only: lobsdiagsave,ianldate use obsmod, only: mype_diaghdr,nobskeep,lobsdiag_allocated,dirname use m_obsNode, only: obsNode use m_pcpNode, only: pcpNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag + use m_pcpNode, only: pcpNode_appendto + use m_obsLList,only: obsLList + use obsmod, only: luse_obsdiag use gsi_4dvar, only: nobs_bins,hr_obsbin,l4dvar,l4densvar use gsi_metguess_mod, only: gsi_metguess_bundle @@ -64,13 +83,15 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& use jfunc, only: jiter,miter - use m_dtime, only: dtime_setup, dtime_check, dtime_show + use m_dtime, only: dtime_setup, dtime_check use gsi_bundlemod, only : gsi_bundlegetpointer use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle implicit none ! Turn off implicit typing ! !INPUT PARAMETERS: + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL integer(i_kind) , intent(in ) :: lunin ! unit from which to read ! precpitation observations @@ -159,6 +180,8 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting ! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(n) ! . removed (%dlat,%dlon) debris. +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). ! ! ! !REMARKS: This routine is NOT correctly set up if running @@ -188,6 +211,7 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& integer(i_kind) isatid,itime,ilon,ilat,isfcflg,ipcp,isdv integer(i_kind) icnt,ilone,ilate,icnv,itype,iclw,icli integer(i_kind) itim,itimp,istat + integer(i_kind) icw,iql,iqi logical sea logical ssmi,amsu,tmi,stage3,muse @@ -247,6 +271,8 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& prsl0,del0,sl0,tsen_ten0,q_ten0,p_ten0 real(r_kind),dimension(nsig+1):: prsi0 real(r_kind),pointer,dimension(:,:,:)::ges_cwmr_im,ges_cwmr_ip + real(r_kind),pointer,dimension(:,:,:)::ges_qlmr_im,ges_qlmr_ip + real(r_kind),pointer,dimension(:,:,:)::ges_qimr_im,ges_qimr_ip real(r_kind),parameter:: zero_7 = 0.7_r_kind real(r_kind),parameter:: r1em6 = 0.000001_r_kind @@ -260,11 +286,9 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& logical:: in_curbin, in_anybin logical proceed - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node type(pcpNode),pointer:: my_head type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u @@ -280,6 +304,8 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& real(r_kind),allocatable,dimension(:,:,:) :: ges_ps_lat data rmiss / -999._r_kind / + type(obsLList),pointer,dimension(:):: pcphead + pcphead => obsLL(:) ! Check to see if required guess fields are available call check_vars_(proceed) @@ -295,8 +321,6 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& call die(myname) endif - n_alloc(:)=0 - m_alloc(:)=0 !********************************************************************************* ! ONE TIME, INITIAL SETUP PRIOR TO PROCESSING SATELLITE DATA ! @@ -521,61 +545,22 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& endif IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + ! Link obs to diagnostics structure if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_pcp_ob_type,ibin)%head)) then - obsdiags(i_pcp_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_pcp_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuppcp: failure to allocate obsdiags',istat - call stop2(263) - end if - obsdiags(i_pcp_ob_type,ibin)%tail => obsdiags(i_pcp_ob_type,ibin)%head - else - allocate(obsdiags(i_pcp_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuppcp: failure to allocate obsdiags',istat - call stop2(264) - end if - obsdiags(i_pcp_ob_type,ibin)%tail => obsdiags(i_pcp_ob_type,ibin)%tail%next - end if - obsdiags(i_pcp_ob_type,ibin)%n_alloc = obsdiags(i_pcp_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_pcp_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_pcp_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_pcp_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_pcp_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_pcp_ob_type,ibin)%tail%indxglb=ioid(n) - obsdiags(i_pcp_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_pcp_ob_type,ibin)%tail%luse=luse(n) - obsdiags(i_pcp_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_pcp_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_pcp_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_pcp_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_pcp_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_pcp_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(n) - my_diag%ich = 1 - my_diag%elat= data_p(ilate,n) - my_diag%elon= data_p(ilone,n) - else - if (.not.associated(obsdiags(i_pcp_ob_type,ibin)%tail)) then - obsdiags(i_pcp_ob_type,ibin)%tail => obsdiags(i_pcp_ob_type,ibin)%head - else - obsdiags(i_pcp_ob_type,ibin)%tail => obsdiags(i_pcp_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_pcp_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_pcp_ob_type,ibin)%tail)') - end if - if (obsdiags(i_pcp_ob_type,ibin)%tail%indxglb/=ioid(n)) then - write(6,*)'setuppcp: index error' - call stop2(265) - end if - endif + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(n) ,& + ich = 1 ,& + elat = data_p(ilate,n) ,& + elon = data_p(ilone,n) ,& + luse = luse(n) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) endif if(.not.in_curbin) cycle @@ -637,11 +622,24 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& end if deltp=one-delt -! Get pointer to could water mixing ratio - call gsi_bundlegetpointer (gsi_metguess_bundle(itim), 'cw',ges_cwmr_im,istatus) - if (istatus/=0) call die('setuppcp','cannot get pointer to cwmr(itim), istatus =',istatus) - call gsi_bundlegetpointer (gsi_metguess_bundle(itimp),'cw',ges_cwmr_ip,istatus) - if (istatus/=0) call die('setuppcp','cannot get pointer to cwmr(itimp), istatus =',istatus) + call gsi_metguess_get ('var::ql', iql, istatus ) + call gsi_metguess_get ('var::qi', iqi, istatus ) + call gsi_metguess_get ('var::cw', icw, istatus ) + if ( icw <= 0 .and. (iql > 0 .and. iqi > 0) ) then +! Get pointer to could water mixing ratio + call gsi_bundlegetpointer (gsi_metguess_bundle(itim), 'ql',ges_qlmr_im,istatus) + call gsi_bundlegetpointer (gsi_metguess_bundle(itimp),'ql',ges_qlmr_ip,istatus) + call gsi_bundlegetpointer (gsi_metguess_bundle(itim), 'qi',ges_qimr_im,istatus) + call gsi_bundlegetpointer (gsi_metguess_bundle(itimp),'qi',ges_qimr_ip,istatus) + ges_cwmr_im = ges_qlmr_im + ges_qimr_im + ges_cwmr_ip = ges_qlmr_ip + ges_qimr_ip + else +! Get pointer to could water mixing ratio + call gsi_bundlegetpointer (gsi_metguess_bundle(itim), 'cw',ges_cwmr_im,istatus) + if (istatus/=0) call die('setuppcp','cannot get pointer to cwmr(itim), istatus =',istatus) + call gsi_bundlegetpointer (gsi_metguess_bundle(itimp),'cw',ges_cwmr_ip,istatus) + if (istatus/=0) call die('setuppcp','cannot get pointer to cwmr(itimp), istatus =',istatus) + endif ! Set and save spatial interpolation indices and weights. call get_ij(mm1,slats,slons,jgrd,wgrd,jjlat=ixx,jjlon=iyy) @@ -961,12 +959,10 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& endif muse= (varinv>r1em6.and.iusep(kx)>=1) - if (nobskeep>0.and.luse_obsdiag) muse=obsdiags(i_pcp_ob_type,ibin)%tail%muse(nobskeep) if (luse_obsdiag) then - obsdiags(i_pcp_ob_type,ibin)%tail%muse(jiter)=muse - obsdiags(i_pcp_ob_type,ibin)%tail%nldepart(jiter)= drad - obsdiags(i_pcp_ob_type,ibin)%tail%wgtjo= varinv + if (nobskeep>0) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse) + call obsdiagNode_set(my_diag, wgtjo=varinv, jiter=jiter,muse=muse,nldepart=drad) endif @@ -980,10 +976,7 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& ncnt = ncnt+1 allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(pcphead(ibin),my_node) - my_node => null() + call pcpNode_appendto(my_head,pcphead(ibin)) my_head%idv = is my_head%iob = ioid(n) @@ -1019,17 +1012,8 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& my_head%luse=luse(n) if (luse_obsdiag) then - my_head%diags => obsdiags(i_pcp_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(n),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag endif my_head => null() end if @@ -1072,9 +1056,10 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& ioff=ioff0 if (lobsdiagsave) then + associate(odiag => my_diagLL%tail) do jj=1,miter ioff=ioff+1 - if (obsdiags(i_pcp_ob_type,ibin)%tail%muse(jj)) then + if (odiag%muse(jj)) then diagbuf(ioff) = one else diagbuf(ioff) = -one @@ -1082,16 +1067,17 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& enddo do jj=1,miter+1 ioff=ioff+1 - diagbuf(ioff) = obsdiags(i_pcp_ob_type,ibin)%tail%nldepart(jj) + diagbuf(ioff) = odiag%nldepart(jj) enddo do jj=1,miter ioff=ioff+1 - diagbuf(ioff) = obsdiags(i_pcp_ob_type,ibin)%tail%tldepart(jj) + diagbuf(ioff) = odiag%tldepart(jj) enddo do jj=1,miter ioff=ioff+1 - diagbuf(ioff) = obsdiags(i_pcp_ob_type,ibin)%tail%obssen(jj) + diagbuf(ioff) = odiag%obssen(jj) enddo + end associate ! (odiag => my_diagLL%tail) endif ! Write diagnostics to output file. @@ -1157,7 +1143,6 @@ subroutine setuppcp(lunin,mype,aivals,nele,nobs,& if (pcp_diagsave) then close(4) deallocate(diagbuf) - call dtime_show(myname,'diagsave:pcp',i_pcp_ob_type) endif ! End of routine @@ -1353,6 +1338,15 @@ subroutine init_vars_ endif end subroutine init_vars_ + subroutine init_netcdf_diag_ + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_ + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_ +! Observation class + character(7),parameter :: obsclass = ' pcp' + end subroutine contents_netcdf_diag_ + subroutine final_vars_ if(associated(ges_q_ten )) nullify(ges_q_ten ) if(associated(ges_tv_ten )) nullify(ges_tv_ten ) @@ -1366,3 +1360,4 @@ subroutine final_vars_ end subroutine final_vars_ end subroutine setuppcp +end module pcp_setup diff --git a/src/setuppm10.f90 b/src/gsi/setuppm10.f90 similarity index 75% rename from src/setuppm10.f90 rename to src/gsi/setuppm10.f90 index 84b878ea7..63a331d42 100644 --- a/src/setuppm10.f90 +++ b/src/gsi/setuppm10.f90 @@ -1,4 +1,11 @@ -subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) +module pm10_setup + implicit none + private + public:: setup + interface setup; module procedure setuppm10; end interface + +contains +subroutine setuppm10(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) !$$$ subprogram documentation block ! . . . @@ -20,6 +27,9 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting ! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) ! . removed (%dlat,%dlon) debris. +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). ! ! input argument list: ! lunin - unit from which to read observations @@ -47,13 +57,26 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) use constants, only: huge_single,r10 use constants, only: r1000,rd,max_varname_length - use m_obsdiags, only : pm10head + use m_obsdiagNode, only : obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + use m_obsNode , only : obsNode use m_pm10Node, only : pm10Node - use m_obsLList, only : obsLList_appendNode - use obsmod , only : i_pm10_ob_type,time_offset - use obsmod, only : obsdiags,lobsdiag_allocated,lobsdiagsave - use obsmod, only : obs_diag,luse_obsdiag + use m_pm10Node, only : pm10Node_appendto + use m_obsLList, only : obsLList + use obsmod , only : time_offset + use obsmod, only : lobsdiag_allocated,lobsdiagsave + use obsmod, only : luse_obsdiag + + use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use qcmod, only : dfact,dfact1 use gsi_4dvar, only: nobs_bins,hr_obsbin @@ -85,16 +108,19 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) implicit none + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + ! !input parameters: character(len=3) :: cvar='pm1' - integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations - integer(i_kind) , intent(in ) :: mype ! mpi task id - integer(i_kind) , intent(in ) :: nreal ! number of pieces of non-co info (location, time, etc) per obs - integer(i_kind) , intent(inout) :: nobs ! number of observations - character(20) , intent(in ) :: isis ! sensor/instrument/satellite id - integer(i_kind) , intent(in ) :: is - logical , intent(in ) :: conv_diagsave ! logical to save innovation dignostics + integer(i_kind) , intent(in) :: lunin ! unit from which to read observations + integer(i_kind) , intent(in) :: mype ! mpi task id + integer(i_kind) , intent(in) :: nreal ! number of pieces of non-co info (location, time, etc) per obs + integer(i_kind) , intent(in) :: nobs ! number of observations + character(20) , intent(in) :: isis ! sensor/instrument/satellite id + integer(i_kind) , intent(in) :: is + logical , intent(in) :: conv_diagsave ! logical to save innovation dignostics ! a function of level !------------------------------------------------------------------------- @@ -117,7 +143,7 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) real(r_kind) ,dimension(nreal,nobs):: data real(r_kind),pointer,dimension(:,:,:):: rank3 - INTEGER(i_kind) i,k,ier,ibin,l,istat,ikx,ii,jj,idia,ifld + INTEGER(i_kind) i,k,ier,ibin,l,ikx,ii,jj,idia,ifld integer(i_kind) mm1 integer(i_kind) :: nchar,nrealdiag @@ -134,11 +160,9 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) logical:: in_curbin, in_anybin logical proceed - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode), pointer:: my_node type(pm10Node), pointer:: my_head type(obs_diag), pointer:: my_diag + type(obs_diags), pointer:: my_diagLL real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps real(r_kind),allocatable,dimension(:,:,: ) :: ges_z @@ -148,6 +172,8 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) character(len=max_varname_length) :: aeroname integer(i_kind) :: ipm10,n_gocart_var + type(obsLList),pointer,dimension(:):: pm10head + pm10head => obsLL(:) ! Check to see if required guess fields are available @@ -157,9 +183,6 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) ! If require guess vars available, extract from bundle ... call init_vars_ - n_alloc(:)=0 - m_alloc(:)=0 - nchar=1 nrealdiag=19 mm1=mype+1 @@ -417,6 +440,7 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) ii=0 if (lobsdiagsave) nrealdiag=nrealdiag+4*miter+1 allocate(cdiagbuf(nobs),rdiagbuf(nrealdiag,nobs)) + if (netcdf_diag) call init_netcdf_diag_ end if mm1=mype+1 @@ -446,64 +470,23 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) if (ibin < 1 .or. ibin > nobs_bins) & write(6,*)mype,'error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) ! link obs to diagnostics structure if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_pm10_ob_type,ibin)%head)) then - obsdiags(i_pm10_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_pm10_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupq: failure to allocate obsdiags',istat - call stop2(421) - end if - obsdiags(i_pm10_ob_type,ibin)%tail => obsdiags(i_pm10_ob_type,ibin)%head - else - allocate(obsdiags(i_pm10_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupq: failure to allocate obsdiags',istat - call stop2(422) - end if - obsdiags(i_pm10_ob_type,ibin)%tail => obsdiags(i_pm10_ob_type,ibin)%tail%next - end if - obsdiags(i_pm10_ob_type,ibin)%n_alloc = obsdiags(i_pm10_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_pm10_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_pm10_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_pm10_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_pm10_ob_type,ibin)%tail%obssen(miter)) - - obsdiags(i_pm10_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_pm10_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_pm10_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_pm10_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_pm10_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_pm10_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_pm10_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_pm10_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_pm10_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_pm10_ob_type,ibin)%tail)) then - obsdiags(i_pm10_ob_type,ibin)%tail => obsdiags(i_pm10_ob_type,ibin)%head - else - obsdiags(i_pm10_ob_type,ibin)%tail => obsdiags(i_pm10_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_pm10_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_pm10_ob_type,ibin)%tail)') - end if - if (obsdiags(i_pm10_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuppm10: index error' - call stop2(423) - end if - endif + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) endif if(.not.in_curbin) cycle @@ -587,18 +570,14 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) endif if(luse_obsdiag)then - obsdiags(i_pm10_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_pm10_ob_type,ibin)%tail%nldepart(jiter)=innov - obsdiags(i_pm10_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 + call obsdiagNode_set(my_diag,wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=innov) end if if (.not. last .and. muse(i)) then allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head - call obsLList_appendNode(pm10head(ibin),my_node) - my_node => null() + call pm10Node_appendto(my_head,pm10head(ibin)) my_head%idv = is my_head%iob = ioid(i) @@ -620,18 +599,8 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) my_head%luse = luse(i) if(luse_obsdiag)then - my_head%diags => & - obsdiags(i_pm10_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =',& - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag end if my_head => null() @@ -649,31 +618,8 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) write(station_id,'(Z8)')nint(site_id) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) - rdiagbuf(6,ii) = ps_ges ! observation pressure (hpa) - rdiagbuf(7,ii) = data(ielev,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = zero !data(iqc,i) input prepbufr qc or event mark - rdiagbuf(10,ii) = zero !data(iqt,i) setup qc or event mark (currently qtflg only) - rdiagbuf(11,ii) = one ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - err_input = data(ierror,i) err_adjst = data(ierror,i) - if (ratio_errors*error>tiny_r_kind) then err_final = one/(ratio_errors*error) else @@ -687,42 +633,8 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst if (err_final>tiny_r_kind) errinv_final=one/err_final - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (k**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (k**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (k**-1) - - rdiagbuf(17,ii) = data(iconc,i) ! temperature observation (k) - rdiagbuf(18,ii) = innov ! obs-ges used in analysis (ugm^-3) - rdiagbuf(19,ii) = innov ! obs-ges w/o bias correction (ugm^-3) (future slot) - - idia=nrealdiag - if (lobsdiagsave) then - do jj=1,miter - idia=idia+1 - if (obsdiags(i_pm10_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(idia,ii) = one - else - rdiagbuf(idia,ii) = -one - endif - enddo - - do jj=1,miter+1 - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_pm10_ob_type,ibin)%tail%nldepart(jj) - enddo - - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_pm10_ob_type,ibin)%tail%tldepart(jj) - enddo - - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_pm10_ob_type,ibin)%tail%obssen(jj) - enddo - - endif + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) endif @@ -742,10 +654,13 @@ subroutine setuppm10(lunin,mype,nreal,nobs,isis,is,conv_diagsave) call final_vars_ !! write information to diagnostic file - if(conv_diagsave .and.ii>0) then - write(7)cvar,nchar,nrealdiag,ii,mype,nrealdiag - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and.ii>0) then + write(7)cvar,nchar,nrealdiag,ii,mype,nrealdiag + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if end if ! return @@ -843,6 +758,146 @@ subroutine init_vars_ endif end subroutine init_vars_ + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_pm10_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) + rdiagbuf(6,ii) = ps_ges ! observation pressure (hpa) + rdiagbuf(7,ii) = data(ielev,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = zero !data(iqc,i) input prepbufr qc or event mark + rdiagbuf(10,ii) = zero !data(iqt,i) setup qc or event mark (currently qtflg only) + rdiagbuf(11,ii) = one ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (k**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (k**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (k**-1) + + rdiagbuf(17,ii) = data(iconc,i) ! temperature observation (k) + rdiagbuf(18,ii) = innov ! obs-ges used in analysis (ugm^-3) + rdiagbuf(19,ii) = innov ! obs-ges w/o bias correction (ugm^-3) (future slot) + + idia=nrealdiag + if (lobsdiagsave) then + do jj=1,miter + idia=idia+1 + if (odiag%muse(jj)) then + rdiagbuf(idia,ii) = one + else + rdiagbuf(idia,ii) = -one + endif + enddo + + do jj=1,miter+1 + idia=idia+1 + rdiagbuf(idia,ii) = odiag%nldepart(jj) + enddo + + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,ii) = odiag%tldepart(jj) + enddo + + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,ii) = odiag%obssen(jj) + enddo + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' pm10' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(ielev,i) ) + call nc_diag_metadata("Pressure", ps_ges ) + call nc_diag_metadata("Height", data(ielev,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", zero ) + call nc_diag_metadata("Prep_Use_Flag", one ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(iconc,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", innov ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", innov ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + end subroutine contents_netcdf_diag_ + subroutine final_vars_ if(allocated(ges_tv)) deallocate(ges_tv) if(allocated(ges_pm10)) deallocate(ges_pm10) @@ -851,3 +906,4 @@ subroutine final_vars_ end subroutine final_vars_ end subroutine setuppm10 +end module pm10_setup diff --git a/src/setuppm2_5.f90 b/src/gsi/setuppm2_5.f90 similarity index 75% rename from src/setuppm2_5.f90 rename to src/gsi/setuppm2_5.f90 index a34bebb72..b43ddbd7b 100644 --- a/src/setuppm2_5.f90 +++ b/src/gsi/setuppm2_5.f90 @@ -1,4 +1,11 @@ -subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) +module pm2_5_setup + implicit none + private + public:: setup + interface setup; module procedure setuppm2_5; end interface + +contains +subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) !$$$ subprogram documentation block ! . . . @@ -27,6 +34,9 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting ! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) ! . removed (%dlat,%dlon) debris. +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). ! ! input argument list: ! lunin - unit from which to read observations @@ -54,13 +64,26 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) use constants, only: huge_single,r10 use constants, only: r1000,rd,max_varname_length - use m_obsdiags, only : pm2_5head + use m_obsdiagNode, only : obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + use m_obsNode, only: obsNode use m_pm2_5Node, only : pm2_5Node - use m_obsLList, only : obsLList_appendNode - use obsmod, only : i_pm2_5_ob_type,time_offset - use obsmod, only : obsdiags,lobsdiag_allocated,lobsdiagsave - use obsmod, only : obs_diag,luse_obsdiag + use m_pm2_5Node, only : pm2_5Node_appendto + use m_obsLList, only: obsLList + use obsmod, only : time_offset + use obsmod, only : lobsdiag_allocated,lobsdiagsave + use obsmod, only : luse_obsdiag,ianldate + + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use qcmod, only : dfact,dfact1 use gsi_4dvar, only: nobs_bins,hr_obsbin @@ -93,15 +116,17 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) implicit none ! !input parameters: + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL character(len=3) :: cvar='pm2' - integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations - integer(i_kind) , intent(in ) :: mype ! mpi task id - integer(i_kind) , intent(in ) :: nreal ! number of pieces of non-co info (location, time, etc) per obs - integer(i_kind) , intent(inout) :: nobs ! number of observations - character(20) , intent(in ) :: isis ! sensor/instrument/satellite id - integer(i_kind) , intent(in ) :: is - logical , intent(in ) :: conv_diagsave ! logical to save innovation dignostics + integer(i_kind) , intent(in) :: lunin ! unit from which to read observations + integer(i_kind) , intent(in) :: mype ! mpi task id + integer(i_kind) , intent(in) :: nreal ! number of pieces of non-co info (location, time, etc) per obs + integer(i_kind) , intent(in) :: nobs ! number of observations + character(20) , intent(in) :: isis ! sensor/instrument/satellite id + integer(i_kind) , intent(in) :: is + logical , intent(in) :: conv_diagsave ! logical to save innovation dignostics ! a function of level !------------------------------------------------------------------------- @@ -124,7 +149,7 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) real(r_kind) ,dimension(nreal,nobs):: data real(r_kind),pointer,dimension(:,:,:):: rank3 - integer(i_kind) i,k,ier,ibin,l,istat,ikx,ii,jj,idia,ifld + integer(i_kind) i,k,ier,ibin,l,ikx,ii,jj,idia,ifld integer(i_kind) mm1 integer(i_kind) :: nchar,nrealdiag @@ -141,11 +166,9 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) logical:: in_curbin, in_anybin logical proceed - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node type(pm2_5Node),pointer:: my_head type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps real(r_kind),allocatable,dimension(:,:,: ) :: ges_z @@ -155,6 +178,8 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) character(len=max_varname_length) :: aeroname integer(i_kind) :: ipm2_5,n_gocart_var + type(obsLList),pointer,dimension(:):: pm2_5head + pm2_5head => obsLL(:) ! Check to see if required guess fields are available @@ -164,9 +189,6 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) ! If require guess vars available, extract from bundle ... call init_vars_ - n_alloc(:)=0 - m_alloc(:)=0 - nchar=1 nrealdiag=19 mm1=mype+1 @@ -407,6 +429,7 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) ii=0 if (lobsdiagsave) nrealdiag=nrealdiag+4*miter+1 allocate(cdiagbuf(nobs),rdiagbuf(nrealdiag,nobs)) + if (netcdf_diag) call init_netcdf_diag_ end if mm1=mype+1 @@ -435,66 +458,26 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) ibin = 1 endif - if (ibin < 1 .or. ibin > nobs_bins) & - write(6,*)mype,'error nobs_bins,ibin= ',nobs_bins,ibin + if (ibin < 1 .or. ibin > nobs_bins) then + call die(myname,'unexpected index, (nobs_bins,ibin) =',(/nobs_bins,ibin/)) + endif + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) ! link obs to diagnostics structure if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_pm2_5_ob_type,ibin)%head)) then - obsdiags(i_pm2_5_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_pm2_5_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupq: failure to allocate obsdiags',istat - call stop2(421) - end if - obsdiags(i_pm2_5_ob_type,ibin)%tail => obsdiags(i_pm2_5_ob_type,ibin)%head - else - allocate(obsdiags(i_pm2_5_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupq: failure to allocate obsdiags',istat - call stop2(422) - end if - obsdiags(i_pm2_5_ob_type,ibin)%tail => obsdiags(i_pm2_5_ob_type,ibin)%tail%next - end if - obsdiags(i_pm2_5_ob_type,ibin)%n_alloc = obsdiags(i_pm2_5_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_pm2_5_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_pm2_5_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_pm2_5_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_pm2_5_ob_type,ibin)%tail%obssen(miter)) - - obsdiags(i_pm2_5_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_pm2_5_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_pm2_5_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_pm2_5_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_pm2_5_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_pm2_5_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_pm2_5_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_pm2_5_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_pm2_5_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_pm2_5_ob_type,ibin)%tail)) then - obsdiags(i_pm2_5_ob_type,ibin)%tail => obsdiags(i_pm2_5_ob_type,ibin)%head - else - obsdiags(i_pm2_5_ob_type,ibin)%tail => obsdiags(i_pm2_5_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_pm2_5_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_pm2_5_ob_type,ibin)%tail)') - end if - if (obsdiags(i_pm2_5_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuppm2_5: index error' - call stop2(423) - end if - endif + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) endif if(.not.in_curbin) cycle @@ -592,18 +575,14 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) endif if (luse_obsdiag) then - obsdiags(i_pm2_5_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_pm2_5_ob_type,ibin)%tail%nldepart(jiter)=innov - obsdiags(i_pm2_5_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=innov) endif if (.not. last .and. muse(i)) then allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(pm2_5head(ibin),my_node) - my_node => null() + call pm2_5Node_appendto(my_head,pm2_5head(ibin)) my_head%idv = is my_head%iob = ioid(i) @@ -625,17 +604,8 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) my_head%luse = luse(i) if (luse_obsdiag) then - my_head%diags => obsdiags(i_pm2_5_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =',& - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag endif my_head => null() @@ -653,31 +623,8 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) write(station_id,'(Z8)')nint(site_id) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) - rdiagbuf(6,ii) = ps_ges ! observation pressure (hpa) - rdiagbuf(7,ii) = data(ielev,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = zero !data(iqc,i) input prepbufr qc or event mark - rdiagbuf(10,ii) = zero !data(iqt,i) setup qc or event mark (currently qtflg only) - rdiagbuf(11,ii) = one ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - err_input = data(ierror,i) err_adjst = data(ierror,i) - if (ratio_errors*error>tiny_r_kind) then err_final = one/(ratio_errors*error) else @@ -690,43 +637,9 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) if (err_input>tiny_r_kind) errinv_input=one/err_input if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst if (err_final>tiny_r_kind) errinv_final=one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (k**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (k**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (k**-1) - - rdiagbuf(17,ii) = data(iconc,i) ! temperature observation (k) - rdiagbuf(18,ii) = innov ! obs-ges used in analysis (ugm^-3) - rdiagbuf(19,ii) = innov ! obs-ges w/o bias correction (ugm^-3) (future slot) - - idia=nrealdiag - if (lobsdiagsave) then - do jj=1,miter - idia=idia+1 - if (obsdiags(i_pm2_5_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(idia,ii) = one - else - rdiagbuf(idia,ii) = -one - endif - enddo - - do jj=1,miter+1 - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_pm2_5_ob_type,ibin)%tail%nldepart(jj) - enddo - - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_pm2_5_ob_type,ibin)%tail%tldepart(jj) - enddo - - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_pm2_5_ob_type,ibin)%tail%obssen(jj) - enddo - - endif + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) endif @@ -746,10 +659,13 @@ subroutine setuppm2_5(lunin,mype,nreal,nobs,isis,is,conv_diagsave) call final_vars_ !! write information to diagnostic file - if(conv_diagsave .and.ii>0) then - write(7)cvar,nchar,nrealdiag,ii,mype,nrealdiag - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and.ii>0) then + write(7)cvar,nchar,nrealdiag,ii,mype,nrealdiag + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if end if ! return @@ -849,6 +765,147 @@ subroutine init_vars_ endif end subroutine init_vars_ + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_pm2_5_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) + rdiagbuf(6,ii) = ps_ges ! observation pressure (hpa) + rdiagbuf(7,ii) = data(ielev,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = zero !data(iqc,i) input prepbufr qc or event mark + rdiagbuf(10,ii) = zero !data(iqt,i) setup qc or event mark (currently qtflg only) + rdiagbuf(11,ii) = one ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (k**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (k**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (k**-1) + + rdiagbuf(17,ii) = data(iconc,i) ! temperature observation (k) + rdiagbuf(18,ii) = innov ! obs-ges used in analysis (ugm^-3) + rdiagbuf(19,ii) = innov ! obs-ges w/o bias correction (ugm^-3) (future slot) + + idia=nrealdiag + if (lobsdiagsave) then + do jj=1,miter + idia=idia+1 + if (odiag%muse(jj)) then + rdiagbuf(idia,ii) = one + else + rdiagbuf(idia,ii) = -one + endif + enddo + + do jj=1,miter+1 + idia=idia+1 + rdiagbuf(idia,ii) = odiag%nldepart(jj) + enddo + + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,ii) = odiag%tldepart(jj) + enddo + + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,ii) = odiag%obssen(jj) + enddo + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' pm2_5' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(ielev,i) ) + call nc_diag_metadata("Pressure", ps_ges ) + call nc_diag_metadata("Height", data(ielev,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", zero ) + call nc_diag_metadata("Prep_Use_Flag", one ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(iconc,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", innov ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", innov ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + end subroutine contents_netcdf_diag_ + subroutine final_vars_ if(allocated(ges_tv)) deallocate(ges_tv) if(allocated(ges_pm2_5)) deallocate(ges_pm2_5) @@ -857,3 +914,4 @@ subroutine final_vars_ end subroutine final_vars_ end subroutine setuppm2_5 +end module pm2_5_setup diff --git a/src/gsi/setuppmsl.f90 b/src/gsi/setuppmsl.f90 new file mode 100644 index 000000000..d66a6f827 --- /dev/null +++ b/src/gsi/setuppmsl.f90 @@ -0,0 +1,688 @@ +module pmsl_setup + implicit none + private + public:: setup + interface setup; module procedure setuppmsl; end interface + +contains +subroutine setuppmsl(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuppmsl compute rhs of oi for conventional pmsl +! prgmmr: pondeca org: np23 date: 2014-04-10 +! +! abstract: For pmsl observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2014-04-10 pondeca +! 2015-03-11 pondeca - Modify for possibility of not using obsdiag +! before retuning to setuprhsall.f90 +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only : obs_diags + use m_obsdiagNode, only : obsdiagLList_nextNode + use m_obsdiagNode, only : obsdiagNode_set + use m_obsdiagNode, only : obsdiagNode_get + use m_obsdiagNode, only : obsdiagNode_assert + + use m_obsNode , only: obsNode + use m_pmslNode, only: pmslNode + use m_pmslNode, only: pmslNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: rmiss_single, & + lobsdiagsave,nobskeep,lobsdiag_allocated, & + time_offset,bmiss,luse_obsdiag,ianldate + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + + use gsi_4dvar, only: nobs_bins,hr_obsbin + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig,get_ij,twodvar_regional + use constants, only: zero,huge_r_kind,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & + two,cg_term,huge_single,three + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_7=0.7_r_kind + + character(len=*),parameter:: myname='setuppmsl' + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) pmslges,dlat,dlon,ddiff,dtime,error + real(r_kind) val2,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,rwgt + real(r_kind) cg_pmsl,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,ipres,ipmsl,ihgt,itemp,id,itime,ikx,iqc,iskint,iff10 + integer(i_kind) ier2,iuse,ilate,ilone,istnelv,isfcr,izz,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin + type(pmslNode), pointer:: my_head + type(obs_diag), pointer:: my_diag + type(obs_diags), pointer:: my_diagLL + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !will probably need at some point + real(r_kind),allocatable,dimension(:,:,:) :: ges_z !will probably need at some point + real(r_kind),allocatable,dimension(:,:,:) :: ges_pmsl + + type(obsLList),pointer,dimension(:):: pmslhead + pmslhead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + ipmsl=5 ! index of pmsl observation + ihgt=6 ! index of surface height + itemp=7 ! index of surface temperature observation + id=8 ! index of station id + itime=9 ! index of observation time in data array + ikxx=10 ! index of ob type + iqc=11 ! index of quality mark + ier2=12 ! index of original obs error + iuse=13 ! index of use parameter + idomsfc=14 ! index of dominant surface type + iskint=15 ! index of surface skin temperature + iff10=16 ! index of 10 meter wind factor + isfcr=17 ! index of surface roughness + ilone=18 ! index of longitude (degrees) + ilate=19 ! index of latitude (degrees) + istnelv=20 ! index of station elevation (m) + izz=21 ! index of surface height + iprvd=22 ! index of observation provider + isprvd=23 ! index of observation subprovider + + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + end do + end do + + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + ii=0 + nchar=1 + ioff0=19 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + if(netcdf_diag) call init_netcdf_diag_ + end if + + + mm1=mype+1 + + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) call die(myname, & + 'out-of-bound, (nobs_bins,ibin) = ',(/nobs_bins,ibin/)) + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + end if + + if(.not.in_curbin) cycle + +! Interpolate guess pmsl to observation location and time + call tintrp2a11(ges_pmsl,pmslges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + ddiff=data(ipmsl,i)-pmslges ! in cb + +! Adjust observation error + ratio_errors=error/data(ier,i) + error=one/error + +! Gross error checks + + obserror = min(r10/max(ratio_errors*error,tiny_r_kind),huge_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(r10*ddiff) + ratio = residual/obserrlm + +! modify gross check limit for quality mark=3 + if(data(iqc,i) == three ) then + qcgross=r0_7*cgross(ikx) + else + qcgross=cgross(ikx) + endif + + if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=one_tenth*maginnov + error=one/(one_tenth*magoberr) + ratio_errors=one + muse(i) = .true. + endif + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_pmsl=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_pmsl*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 !rejected obs + if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs + end if + + ress = ddiff*r10 + ressw2 = ress*ress + + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + endif + +! Fill obs diagnostics structure + if(luse_obsdiag)then + call obsdiagNode_set(my_diag,wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call pmslNode_appendto(my_head,pmslhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + end if + + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'psl',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::pmsl' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get pmsl ... + varname='pmsl' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_pmsl))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_pmsl(size(rank2,1),size(rank2,2),nfldsig)) + ges_pmsl(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_pmsl(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_pmsl_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = data(ipres,i)*r10 ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(ipmsl,i) ! PMSL observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(ipmsl,i)-pmslges! obs-ges w/o bias correction (K) (future slot) + + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' pmsl' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", data(ipres,i)*r10 ) + call nc_diag_metadata("Height", data(ihgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(ipmsl,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(ipmsl,i)-pmslges ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps )) deallocate(ges_ps ) + if(allocated(ges_pmsl)) deallocate(ges_pmsl) + end subroutine final_vars_ + +end subroutine setuppmsl +end module pmsl_setup diff --git a/src/gsi/setupps.f90 b/src/gsi/setupps.f90 new file mode 100644 index 000000000..93532e27d --- /dev/null +++ b/src/gsi/setupps.f90 @@ -0,0 +1,930 @@ +module ps_setup + implicit none + private + public:: setup + interface setup; module procedure setupps; end interface + +contains +subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupps compute rhs of oi for surface pressure +! prgmmr: parrish org: np22 date: 1990-10-06 +! +! abstract: For surface pressure observations, this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 1990-10-06 parrish +! 1998-04-10 weiyu yang +! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-17 treadon - update documentation +! 2004-08-02 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - increase size of pwork array for nonlinear qc +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list +! 2005-03-02 dee - remove garbage from diagnostic file +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-07-27 derber - add print of monitoring and reject data +! 2005-09-12 derber - rewrite and incorporate prep routine +! 2005-09-28 derber - combine with prep,spr,remove tran and clean up +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2005-10-21 su - modified variational quality control and diagnose output +! 2005-11-03 treadon - correct error in ilone,ilate data array indices +! 2005-11-22 wu - add option to perturb conventional obs +! 2005-11-29 derber - remove psfcg and use ges_lnps instead +! 2006-01-31 todling - storing wgt/wgtlim in diag file instead of wgt only +! 2006-02-02 treadon - rename lnprsl as ges_lnprsl +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-03-21 treadon - modify optional perturbation to observation +! 2006-05-30 su,derber,treadon - modify diagnostic output +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - modify handling of multiple data at same location +! 2006-07-31 kleist - change analysis variable to ps (cb) instead of lnps +! 2006-08-28 su - fix a bug in variational qc +! 2007-03-09 su - modify obs perturbation +! 2007-03-19 tremolet - binning of observations +! 2007-06-05 tremolet - add observation diagnostics structure +! 2007-08-28 su - modify the error used in gross check +! 2008-03-24 wu - oberror tuning and perturb obs +! 2008-05-23 safford - rm unused vars and uses +! 2008-12-03 todling - changed handle of tail%time +! 2009-02-06 pondeca - for each observation site, add the following to the +! diagnostic file: local terrain height, dominate surface +! type, station provider name and station subprovider name +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). +! 2011-05-06 Su - modify the observation gross check error +! 2011-08-09 pondeca - correct bug in qcgross use +! 2013-01-26 parrish - change grdcrd to grdcrd1, intrp2a to intrp2a11, +! tintrp2a to tintrp2a1, tintrp2a11, +! tintrp3 to tintrp31 (so debug compile works on WCOSS) +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-04-12 su - add non linear qc from Purser's scheme +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-11-29 shlyaeva - save linearized H(x) for EnKF +! 2016-12-09 mccarty - add netcdf_diag capability +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2017-03-31 Hu - addd option l_closeobs to use closest obs to analysis +! time in analysis +! +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr,getindex + use state_vectors, only: svars2d, levels, ns3d, nsdim + use kinds, only: r_kind,r_single,r_double,i_kind + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,perturb_obs,oberror_tune,& + lobsdiagsave,nobskeep,lobsdiag_allocated,& + time_offset,lobsdiag_forenkf,ianldate + use m_obsNode, only: obsNode + use m_psNode, only: psNode + use m_psNode, only: psNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gridmod, only: nsig,get_ij,twodvar_regional + use constants, only: zero,one_tenth,one,half,pi,g_over_rd, & + huge_r_kind,tiny_r_kind,two,cg_term,huge_single, & + r1000,wgtlim,tiny_single,r10,three + use jfunc, only: jiter,last,jiterstart,miter + use qcmod, only: dfact,dfact1,npres_print,njqc,vqc + use guess_grids, only: hrdifsig,ges_lnprsl,nfldsig,ntguessig + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,icsubtype + + use m_dtime, only: dtime_setup, dtime_check + + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use sparsearr, only: sparr2, new, size, writearray, fullarray + use rapidrefresh_cldsurf_mod, only: l_closeobs + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + integer(i_kind) ,intent(in ) :: is ! ndat index + logical ,intent(in ) :: conv_diagsave + +! Declare local parameters + character(len=*),parameter:: myname='setupps' + real(r_kind),parameter:: r0_7=0.7_r_kind + +! Declare external calls for code analysis + external:: intrp2a + external:: tintrp2a1 + external:: tintrp3 + external:: grdcrd1 + external:: stop2 + +! Declare local variables + real(r_double) rstation_id + real(r_kind) tges,tges2,drbx,pob,pges,psges,psges2,dlat,dlon,dtime,var_jb + real(r_kind) rdelz,rdp,halfpi,obserror,obserrlm,drdp,residual,ratio + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,tfact + real(r_kind) zsges,pgesorig,rwgt + real(r_kind) r0_005,r0_2,r2_5,tmin,tmax,half_tlapse + real(r_kind) ratio_errors,error,dhgt,ddiff,dtemp + real(r_kind) val2,ress,ressw2,val,valqc + real(r_kind) cg_ps,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2,qcgross + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nsig):: prsltmp + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + integer(i_kind) ier,ilon,ilat,ipres,ihgt,itemp,id,itime,ikx,iqc,iptrb,ijb + integer(i_kind) ier2,iuse,ilate,ilone,istnelv,idomsfc,izz,iprvd,isprvd + integer(i_kind) ikxx,nn,ibin,ioff,ioff0 + integer(i_kind) i,nchar,nreal,ii,jj,k,l,mm1 + integer(i_kind) itype,isubtype + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + real(r_kind) :: hr_offset + + logical:: in_curbin, in_anybin, save_jacobian + type(psNode),pointer:: my_head + type(obs_diag ),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + integer(i_kind) :: ps_ind, nnz, nind + + type(obsLList),pointer,dimension(:):: pshead + pshead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +!******************************************************************************* +! Read observations in work arrays. + + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + ihgt=5 ! index of surface height + itemp=6 ! index of surface temperature observation + id=7 ! index of station id + itime=8 ! index of observation time in data array + ikxx=9 ! index of ob type + iqc=10 ! index of quality mark + ier2=11 ! index of original-original obs error ratio + iuse=12 ! index of use parameter + idomsfc=13 ! index of dominant surface type + ilone=14 ! index of longitude (degrees) + ilate=15 ! index of latitude (degrees) + istnelv=16 ! index of station elevation (m) + izz=17 ! index of surface height + iprvd=18 ! index of observation provider + isprvd=19 ! index of observation subprovider + ijb=20 ! index of non linear qc parameter + iptrb=21 ! index of ps perturbation + +! Declare local constants + halfpi = half*pi + r0_005 = 0.005_r_kind + r0_2=0.2_r_kind + r2_5=2.5_r_kind + tmin=150.0_r_kind + tmax=350.0_r_kind + half_tlapse=0.00325_r_kind ! half of 6.5K/1km + mm1=mype+1 + var_jb=zero + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +! Check to see if observation should be used or monitored +! muse = true then used + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + hr_offset=min_offset/60.0_r_kind +! Check for duplicate observations at same location + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if (.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Load obs error into local variable + obserror = max(cermin(ikx)*one_tenth,& + min(cermax(ikx)*one_tenth,data(ier,i))) + +! Get guess sfc hght at obs location + + call intrp2a11(ges_z(1,1,ntguessig),zsges,dlat,dlon,mype) + +! Interpolate to get log(ps) and log(pres) at mid-layers +! at obs location/time + + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + +! Convert pressure to grid coordinates + + pgesorig = psges + +! Take log for vertical interpolation + psges = log(psges) + call grdcrd1(psges,prsltmp,nsig,-1) + +! Get guess temperature at observation location and surface + + call tintrp31(ges_tv,tges,dlat,dlon,psges,dtime, & + hrdifsig,mype,nfldsig) + +! Adjust observation error and obs value due to differences in surface height + + rdelz=dhgt-zsges + if(dtemp > tmin .and. dtemp < tmax) then + +! Case of observed surface temperature + + drbx = half*abs(tges-dtemp)+r0_2+r0_005*abs(rdelz) + tges = half*(tges+dtemp) + else + +! No observed temperature + psges2=log(data(ipres,i)) + call grdcrd1(psges2,prsltmp,nsig,-1) + call tintrp31(ges_tv,tges2,dlat,dlon,psges2,dtime, & + hrdifsig,mype,nfldsig) + + drbx = half*abs(tges-tges2)+r2_5+r0_005*abs(rdelz) + tges = half*(tges+tges2) + +! Extrapolate surface temperature below ground at 6.5 k/km +! note only extrapolating .5dz, if no surface temp available. + + if(rdelz < zero)then + tges=tges-half_tlapse*rdelz + drbx=drbx-half_tlapse*rdelz + end if + + end if + +! Adjust guess hydrostatically + + rdp = g_over_rd*rdelz/tges + +! Subtract off dlnp correction, then convert to pressure (cb) + pges = exp(log(pgesorig) - rdp) + + if (save_jacobian) then + ps_ind = getindex(svars2d,'ps') + if (ps_ind < 0) then + print *, 'Error: no variable ps in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = sum(levels(1:ns3d)) + ps_ind + dhx_dx%end_ind(1) = sum(levels(1:ns3d)) + ps_ind + dhx_dx%val(1) = one + endif + +! observational error adjustment + + drdp=zero + if (.not.twodvar_regional) then + drdp = pges*(g_over_rd*abs(rdelz)*drbx/(tges**2)) + endif + +! find adjustment to observational error (in terms of ratio) + ratio_errors=error/(data(ier,i)+drdp) + error=one/error + +! Compute innovations + ddiff=pob-pges ! in cb + +! Oberror Tuning and Perturb Obs + if(muse(i)) then + if(oberror_tune )then + if( jiter > jiterstart ) then + ddiff=ddiff+data(iptrb,i)/error/ratio_errors + endif + else if(perturb_obs )then + ddiff=ddiff+data(iptrb,i)/error/ratio_errors + endif + endif + +! Gross check using innovation normalized by error + + obserror = min(r10/max(ratio_errors*error,tiny_r_kind),huge_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(r10*ddiff) + ratio = residual/obserrlm + +! modify gross check limit for quality mark=3 + if(data(iqc,i) == three ) then + qcgross=r0_7*cgross(ikx) + else + qcgross=cgross(ikx) + endif + + if (ratio > qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors = zero + else + ratio_errors = ratio_errors/sqrt(dup(i)) + end if + + if (ratio_errors*error <= tiny_r_kind) muse(i)=.false. + +! If requested, setup for single obs test. + + if (oneobtest) then + maginnov=one_tenth*maginnov + magoberr=one_tenth*magoberr + ddiff=maginnov + error=one/magoberr + ratio_errors=one + muse(i) = .true. + endif + + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms, and accumulate statistics. + + val = error*ddiff + + if(luse(i))then + +! Compute penalty terms (linear & nonlinear qc). + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if(njqc .and. var_jb>tiny_r_kind .and. var_jb < 10.0_r_kind .and. error >tiny_r_kind) then + if(exp_arg == zero) then + wgt=one + else + wgt=ddiff*error/sqrt(two*var_jb) + wgt=tanh(wgt)/wgt + endif + term=-two*var_jb*rat_err2*log(cosh((val)/sqrt(two*var_jb))) + rwgt = wgt/wgtlim + valqc = -two*term + else if (vqc .and. (cvar_pg(ikx)> tiny_r_kind) .and. (error >tiny_r_kind)) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_ps=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_ps*wnotgross) + term =log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + valqc = -two*rat_err2*term + else + term = exp_arg + wgt = one + rwgt = wgt/wgtlim + valqc = -two*rat_err2*term + endif + if (muse(i)) then +! Accumulate statistics for obs used belonging to this task + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + nn=1 + else + +! rejected obs + nn=2 +! monitored obs + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + +! Accumulate statistics for each ob type + + ress = ddiff*r10 + ressw2 = ress*ress + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag,wgtjo=(error*ratio_errors)**2, & + jiter=jiter,muse=muse(i),nldepart=ddiff) + endif + + + if (.not. last .and. muse(i)) then +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) +! if no minimization (inner loop), do not load arrays + + allocate(my_head) + call psNode_appendto(my_head,pshead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%jb = var_jb + my_head%luse = luse(i) + if(oberror_tune) then + my_head%kx = ikx ! data type for oberror tuning + my_head%ppertb= data(iptrb,i)/error/ratio_errors ! obs perturbation + endif + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + + endif + +! Save obs and simulated surface pressure data for diagnostic output + + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + pob = pob*r10 + pges = pges*r10 + pgesorig = pgesorig*r10 + + err_input = data(ier2,i)*r10 ! r10 converts cb to mb + err_adjst = data(ier,i)*r10 + if (ratio_errors*error/r10>tiny_r_kind) then + err_final = r10/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_single) errinv_input = one/err_input + if (err_adjst>tiny_single) errinv_adjst = one/err_adjst + if (err_final>tiny_single) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + +! End of loop over observations + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)' ps',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if + end if + +! End of routine + return + + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2 + real(r_kind),dimension(:,:,:),pointer:: rank3 + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_ps_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = data(ipres,i)*r10 ! observation pressure (hPa) + rdiagbuf(7,ii) = dhgt ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = var_jb ! non linear qc parameter + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (hPa**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (hPa**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (hPa**-1) + + rdiagbuf(17,ii) = pob ! surface pressure observation (hPa) + rdiagbuf(18,ii) = pob-pges ! obs-ges used in analysis (coverted to hPa) + rdiagbuf(19,ii) = pob-pgesorig ! obs-ges w/o adjustment to guess surface pressure (hPa) + rdiagbuf(20,ii) = 1.e+10_r_single ! spread (filled in by EnKF) + + ioff=ioff0 + + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + ioff = ioff + 1 + rdiagbuf(ioff,ii) = data(idomsfc,i) ! dominate surface type + ioff = ioff + 1 + rdiagbuf(ioff,ii) = data(izz,i) ! model terrain at ob location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal, ii)) + ioff = ioff + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' ps' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(data(ipres,i)*r10)) + call nc_diag_metadata("Height", sngl(dhgt) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata("Nonlinear_QC_Var_Jb", sngl(var_jb) ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(pob) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(pob-pges) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(pob-pgesorig)) + + if (lobsdiagsave) then + + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_tv)) deallocate(ges_tv) + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps)) deallocate(ges_ps) + end subroutine final_vars_ + +end subroutine setupps +end module ps_setup diff --git a/src/gsi/setuppw.f90 b/src/gsi/setuppw.f90 new file mode 100644 index 000000000..c588aafb6 --- /dev/null +++ b/src/gsi/setuppw.f90 @@ -0,0 +1,772 @@ +module pw_setup + implicit none + private + public:: setup + interface setup; module procedure setuppw; end interface + +contains +subroutine setuppw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuppw compute rhs of oi for total column water +! prgmmr: parrish org: np22 date: 1990-10-06 +! +! abstract: For total column water, this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 1990-10-06 parrish +! 1998-04-10 weiyu yang +! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2003-12-23 kleist - modify to use delta(pressure) from guess fields +! 2004-06-17 treadon - update documentation +! 2004-08-02 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - increase size of pwwork array for nonlinear qc +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list +! 2005-02-10 treadon - move initialization of dp_pw into routine sprpw +! 2005-03-02 dee - remove garbage from diagnostic file +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-07-27 derber - add print of monitoring and reject data +! 2005-09-28 derber - combine with prep,spr,remove tran and clean up +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2005-11-03 treadon - correct error in ilone,ilate data array indices +! 2005-11-14 pondeca - correct error in diagnostic array index +! 2006-01-31 todling/treadon - store wgt/wgtlim in rdiagbuf(6,ii) +! 2006-02-02 treadon - rename prsi as ges_prsi +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-05-30 su,derber,treadon - modify diagnostic output +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - modify handling of multiple data at same location +! - unify NL qc +! 2006-08-28 su - fix a bug in variational qc +! 2007-03-19 tremolet - binning of observations +! 2007-06-05 tremolet - add observation diagnostics structure +! 2007-08-28 su - modify gross check error +! 2008-12-03 todling - changed handle of tail%time +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). +! 2011-11-19 Hofmann - doing precipitable water (PW) height adjustment +! based on obs vs. model height +! 2013-01-26 parrish - change tintrp2a to tintrp2a1, tintrp2a11 (so debug compile works on WCOSS) +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-12-09 mccarty - add netcdf_diag capability +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr,getindex + use kinds, only: r_kind,r_single,r_double,i_kind + use guess_grids, only: ges_prsi,hrdifsig,nfldsig + use gridmod, only: lat2,lon2,nsig,get_ij + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,lobsdiag_forenkf,ianldate,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use m_obsNode, only: obsNode + use m_pwNode, only: pwNode + use m_pwNode, only: pwNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin + use constants, only: zero,one,tpwcon,r1000,r10, & + tiny_r_kind,three,half,two,cg_term,huge_single,& + wgtlim, rd + use jfunc, only: jiter,last,miter,jiterstart + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use rapidrefresh_cldsurf_mod, only: l_pw_hgt_adjust, l_limit_pw_innov, max_innov_pct + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use state_vectors, only: svars3d, levels, nsdim + use sparsearr, only: sparr2, new, size, writearray, fullarray + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare local parameter + character(len=*),parameter:: myname='setuppw' + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: stop2 + +! Declare local variables + real(r_double) rstation_id + real(r_kind):: pwges,grsmlt,dlat,dlon,dtime,obserror, & + obserrlm,residual,ratio,dpw + real(r_kind) error,ddiff, pw_diff + real(r_kind) ressw2,ress,scale,val2,val,valqc + real(r_kind) rat_err2,exp_arg,term,ratio_errors,rwgt + real(r_kind) cg_pw,wgross,wnotgross,wgt,arg + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,tfact + real(r_kind),dimension(nobs)::dup + real(r_kind),dimension(nele,nobs):: data + real(r_kind),dimension(lat2,lon2,nfldsig)::rp2 + real(r_kind),dimension(nsig+1):: prsitmp + real(r_kind),dimension(nsig):: qges, tvges + real(r_single),allocatable,dimension(:,:)::rdiagbuf + real(r_kind) zges, prest + + integer(i_kind) ikxx,nn,istat,ibin,ioff,ioff0 + integer(i_kind) i,nchar,nreal,k,j,jj,ii,l,mm1 + integer(i_kind) ier,ilon,ilat,ipw,id,itime,ikx,ipwmax,iqc + integer(i_kind) ier2,iuse,ilate,ilone,istnelv,iobshgt,iobsprs + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + integer(i_kind) :: q_ind, nnz, nind + + logical:: in_curbin, in_anybin, save_jacobian + type(pwNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + equivalence(rstation_id,station_id) + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + type(obsLList),pointer,dimension(:):: pwhead + pwhead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + + grsmlt=three ! multiplier factor for gross check + mm1=mype+1 + scale=one + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!****************************************************************************** +! Read and reformat observations in work arrays. +! Simulate tpw from guess (forward model) + rp2=zero + do jj=1,nfldsig + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + rp2(i,j,jj)=rp2(i,j,jj) + ges_q(i,j,k,jj) * & + tpwcon*r10*(ges_prsi(i,j,k,jj)-ges_prsi(i,j,k+1,jj)) ! integrate q + end do + end do + end do + end do + + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipw = 4 ! index of pw observations + id=5 ! index of station id + itime=6 ! index of observation time in data array + ikxx=7 ! index of ob type + ipwmax=8 ! index of pw max error + iqc=9 ! index of quality mark + ier2=10 ! index of original-original obs error ratio + iuse=11 ! index of use parameter + ilone=12 ! index of longitude (degrees) + ilate=13 ! index of latitude (degrees) + istnelv=14 ! index of station elevation (m) + iobsprs=15 ! index of observation pressure (hPa) + iobshgt=16 ! index of observation height (m) + + do i=1,nobs + muse(i)=nint(data(11,i)) <= jiter + end do + + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l)) then + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + end do + end do + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + nchar=1 + ioff0=20 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (save_jacobian) then + nnz = nsig ! number of non-zero elements in dH(x)/dx profile + nind = 1 + call new(dhx_dx, nnz, nind) + nreal = nreal + size(dhx_dx) + endif + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + ii=0 + if(netcdf_diag) call init_netcdf_diag_ + end if + + +! Prepare total precipitable water data + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + + dpw=data(ipw,i) + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + + ratio_errors=error/data(ier,i) + error=one/error + endif ! (in_curbin) + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + + ! Interpolate model PW to obs location + call tintrp2a11(rp2,pwges,dlat,dlon,dtime, & + hrdifsig,mype,nfldsig) + +! Interpolate pressure at interface values to obs location + call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime, & + hrdifsig,nsig+1,mype,nfldsig) + prest=prsitmp(1)*r10 ! model surface pressure(mb) at obs loction + + if (save_jacobian) then + q_ind =getindex(svars3d,'q') + if (q_ind < 0) then + print *, 'Error: no variable q in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = 1 + sum(levels(1:q_ind-1)) + dhx_dx%end_ind(1) = nsig + sum(levels(1:q_ind-1)) + + do k = 1, nsig + dhx_dx%val(k) = tpwcon*r10*(prsitmp(k)-prsitmp(k+1)) + enddo + endif + + + if(.not.l_pw_hgt_adjust) then + ! Compute innovation + ddiff = dpw - pwges + else + + ! Interpolate model q to obs location + call tintrp2a1(ges_q,qges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + + ! Interpolate model T_v to obs location + call tintrp2a1(ges_tv,tvges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + + ! Interpolate model z to obs location + call tintrp2a11(ges_z,zges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + ! Calculate difference in PW from station elevation to model surface elevation + pw_diff = (zges - data(istnelv,i)) * (prsitmp(1)*r1000*qges(1)) / (rd*tvges(1)) + + ! Compute innovation + ddiff = dpw - pw_diff - pwges + end if + + if (l_limit_pw_innov) then + ! Limit size of PW innovation to a percent of the background value + ddiff = sign(min(abs(ddiff),max_innov_pct*pwges),ddiff) + end if + +! Gross checks using innovation + + residual = abs(ddiff) + if (residual>grsmlt*data(ipwmax,i)) then + error = zero + ratio_errors=zero + if (luse(i)) awork(7) = awork(7)+one + end if + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + ratio = residual/obserrlm + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + if (ratio_errors*error <= tiny_r_kind) muse(i)=.false. + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + + val = error*ddiff + + if(luse(i))then +! Compute penalty terms (linear & nonlinear qc). + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_pw=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_pw*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics as a function of observation type. + ress = ddiff*scale + ressw2= ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 +! Accumulate statistics for obs belonging to this task + if (muse(i) ) then + if(rwgt < one) awork(21) = awork(21)+one + awork(5) = awork(5)+val2*rat_err2 + awork(4) = awork(4)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if ( .not. last .and. muse(i)) then + + allocate(my_head) + call pwNode_appendto(my_head,pwhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + + allocate(my_head%dp(nsig),stat=istat) + if (istat/=0) write(6,*)'MAKECOBS: allocate error for pwhead_dp, istat=',istat + + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2= ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + +! Load the delta pressures at the obs location + do k=1,nsig + my_head%dp(k)=r10*(prsitmp(k)-prsitmp(k+1)) + end do + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1, myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + + +! Save select output for diagnostic file + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input=one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst + if (err_final>tiny_r_kind) errinv_final=one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)' pw',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::q', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get q ... + varname='q' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_q))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_q(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_q(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + + write(string,900) jiter +900 format('conv_pw_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = prest ! use model surface pressure (hPa) so PW + ! can be used in EnKF analysis + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error + rdiagbuf(16,ii) = errinv_final ! final inverse observation error + + rdiagbuf(17,ii) = dpw ! total precipitable water obs (kg/m**2) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (kg/m**2) + rdiagbuf(19,ii) = dpw-pwges ! obs-ges w/o bias correction (kg/m**2) (future slot) + rdiagbuf(20,ii) = 1.e+10_r_single ! ensemble ges spread (filled in by EnKF) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class +! use model surface pressure, so PW can be used in EnKF analysis + character(7),parameter :: obsclass = ' pw' + real(r_single),parameter:: missing = -9.99e9_r_single + real(r_kind),dimension(miter) :: obsdiag_iuse + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(prest) ) + call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset) ) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata("Setup_QC_Mark", missing ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", 1._r_single ) + else + call nc_diag_metadata("Analysis_Use_Flag", -1._r_single ) + endif + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata("Observation", sngl(dpw) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(dpw-pwges) ) + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_q )) deallocate(ges_q ) + if(allocated(ges_tv)) deallocate(ges_tv) + if(allocated(ges_z )) deallocate(ges_z ) + end subroutine final_vars_ + +end subroutine setuppw +end module pw_setup diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 new file mode 100755 index 000000000..aabf55005 --- /dev/null +++ b/src/gsi/setupq.f90 @@ -0,0 +1,1285 @@ +module q_setup + implicit none + private + public:: setup + interface setup; module procedure setupq; end interface + +contains +subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupq compute rhs of oi for moisture observations +! prgmmr: parrish org: np22 date: 1990-10-06 +! +! abstract: For moisture observations, this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 1990-10-06 parrish +! 1998-04-10 weiyu yang +! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-17 treadon - update documentation +! 2004-08-02 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - increase size of qwork array for nonlinear qc +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list +! 2005-03-02 dee - remove garbage from diagnostic file +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-05-27 derber - level output change +! 2005-07-27 derber - add print of monitoring and reject data +! 2005-09-28 derber - combine with prep,spr,remove tran and clean up +! 2005-10-06 treadon - lower huge_error to prevent overflow +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2005-10-21 su - modify variational qc and diagonose output +! 2005-11-03 treadon - correct error in ilone,ilate data array indices +! 2005-11-21 kleist - change to call to genqsat +! 2005-11-21 derber - correct error in use of qsges +! 2005-11-22 wu - add option to perturb conventional obs +! 2005-11-29 derber - remove psfcg and use ges_lnps instead +! 2006-01-31 todling - storing wgt/wgtlim in diag file instead of wgt only +! 2006-02-02 treadon - rename lnprsl as ges_lnprsl +! 2006-02-03 derber - fix bug in counting rlow and rhgh +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-03-21 treadon - modify optional perturbation to observation +! 2006-04-03 derber - eliminate unused arrays +! 2006-05-30 su,derber,treadon - modify diagnostic output +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - modify handling of multiple data at same location +! 2006-07-31 kleist - use ges_ps instead of ln(ps) +! 2006-08-28 su - fix a bug in variational qc +! 2007-03-09 su - modify obs perturbation +! 2007-03-19 tremolet - binning of observations +! 2007-06-05 tremolet - add observation diagnostics structure +! 2007-08-28 su - modify gross check error +! 2008-03-24 wu - oberror tuning and perturb obs +! 2008-05-23 safford - rm unused vars and uses +! 2008-12-03 todling - changed handle of tail%time +! 2009-02-06 pondeca - for each observation site, add the following to the +! diagnostic file: local terrain height, dominate surface +! type, station provider name, and station subprovider name +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). +! 2011-05-06 Su - modify the observation gross check error +! 2011-08-09 pondeca - correct bug in qcgross use +! 2011-10-14 Hu - add code for adjusting surface moisture observation error +! 2011-10-14 Hu - add code for producing pseudo-obs in PBL +! 2011-12-14 wu - add code for rawinsonde level enhancement ( ext_sonde ) +! layer based on surface obs Q +! 2013-01-26 parrish - change grdcrd to grdcrd1, tintrp2a to tintrp2a1, tintrp2a11, +! tintrp3 to tintrp31 (so debug compile works on WCOSS) +! 2013-05-24 wu - move rawinsonde level enhancement ( ext_sonde ) to read_prepbufr +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-03-24 Hu - Use 2/3 of 2m Q and 1/3 of 1st level Q as background +! to calculate O-B for the surface moisture observations +! 2014-04-04 todling - revist q2m implementation (slightly) +! 2014-04-12 su - add non linear qc from Purser's scheme +! 2014-11-30 Hu - more option on use 2-m Q as background +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-02-09 Sienkiewicz - handling new KX drifting buoys (formerly ID'd by subtype 562) +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-11-29 shlyaeva - save linearized H(x) for EnKF +! 2016-12-09 mccarty - add netcdf_diag capability +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2017-03-31 Hu - addd option l_closeobs to use closest obs to analysis +! time in analysis +! 2017-03-31 Hu - addd option i_coastline to use observation operater +! for coastline area +! 2018-04-09 pondeca - introduce duplogic to correctly handle the characterization of +! duplicate obs in twodvar_regional applications +! 2020-01-27 Winterbottom - moved the linear regression derived +! coefficients for the dynamic observation +! error (DOE) calculation to the namelist +! level; they are now loaded by +! aircraftinfo. +! +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr,getindex + use kinds, only: r_kind,r_single,r_double,i_kind + + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,perturb_obs,oberror_tune,& + lobsdiagsave,nobskeep,lobsdiag_allocated,& + time_offset,lobsdiag_forenkf,aircraft_recon + use m_obsNode, only: obsNode + use m_qNode, only: qNode + use m_qNode, only: qNode_appendto + use m_qNode, only: qNode_ich0, qNode_ich0_PBL_Pseudo + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag,ianldate + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: oneobtest,maginnov,magoberr + use guess_grids, only: ges_lnprsl,hrdifsig,nfldsig,ges_tsen,ges_prsl,pbl_height + use gridmod, only: lat2,lon2,nsig,get_ijk,twodvar_regional + use constants, only: zero,one,r1000,r10,r100 + use constants, only: huge_single,wgtlim,three + use constants, only: tiny_r_kind,five,half,two,huge_r_kind,cg_term,r0_01 + use qcmod, only: npres_print,ptopq,pbotq,dfact,dfact1,njqc,vqc + use jfunc, only: jiter,last,jiterstart,miter + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use converr_q, only: ptabl_q + use converr, only: ptabl + use m_dtime, only: dtime_setup, dtime_check + use rapidrefresh_cldsurf_mod, only: l_sfcobserror_ramp_q + use rapidrefresh_cldsurf_mod, only: l_pbl_pseudo_surfobsq,pblh_ration,pps_press_incr, & + i_use_2mq4b,l_closeobs,i_coastline + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use sparsearr, only: sparr2, new, size, writearray, fullarray + use state_vectors, only: svars3d, levels, nsdim + + ! The following variables are the coefficients that describe the + ! linear regression fits that are used to define the dynamic + ! observation error (DOE) specifications for all reconnissance + ! observations collected within hurricanes/tropical cyclones; these + ! apply only to the regional forecast models (e.g., HWRF); Henry + ! R. Winterbottom (henry.winterbottom@noaa.gov). + + use obsmod, only: q_doe_a_136,q_doe_a_137,q_doe_b_136,q_doe_b_137 + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare local parameters + real(r_kind),parameter:: small1=0.0001_r_kind + real(r_kind),parameter:: small2=0.0002_r_kind + real(r_kind),parameter:: r0_7=0.7_r_kind + real(r_kind),parameter:: r8=8.0_r_kind + real(r_kind),parameter:: r0_001 = 0.001_r_kind + real(r_kind),parameter:: r1e16=1.e16_r_kind + real(r_kind),parameter:: r3p5 = 3.5_r_kind + character(len=*),parameter:: myname='setupq' + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: tintrp31 + external:: grdcrd1 + external:: genqsat + external:: stop2 + +! Declare local variables + + real(r_double) rstation_id + real(r_kind) qob,qges,qsges,q2mges,q2mges_water + real(r_kind) ratio_errors,dlat,dlon,dtime,dpres,rmaxerr,error + real(r_kind) rsig,dprpx,rlow,rhgh,presq,tfact,ramp + real(r_kind) psges,sfcchk,ddiff,errorx + real(r_kind) cg_q,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2,qcgross + real(r_kind) grsmlt,ratio,val2,obserror + real(r_kind) obserrlm,residual,ressw2,scale,ress,huge_error,var_jb + real(r_kind) val,valqc,rwgt,prest + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nele,nobs):: data + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(lat2,lon2,nsig,nfldsig):: qg + real(r_kind),dimension(lat2,lon2,nfldsig):: qg2m + real(r_kind),dimension(nsig):: prsltmp + real(r_kind),dimension(34):: ptablq + real(r_single),allocatable,dimension(:,:)::rdiagbuf + real(r_single),allocatable,dimension(:,:)::rdiagbufp + + + integer(i_kind) i,nchar,nreal,ii,l,jj,mm1,itemp,iip + integer(i_kind) jsig,itype,k,nn,ikxx,iptrb,ibin,ioff,ioff0,icat,ijb + integer(i_kind) ier,ilon,ilat,ipres,iqob,id,itime,ikx,iqmax,iqc + integer(i_kind) ier2,iuse,ilate,ilone,istnelv,iobshgt,izz,iprvd,isprvd + integer(i_kind) idomsfc,iderivative + real(r_kind) :: delz + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + integer(i_kind) :: iz, q_ind, nind, nnz + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf,cdiagbufp + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical ice,proceed + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + + logical duplogic + + logical:: in_curbin, in_anybin, save_jacobian + type(qNode),pointer:: my_head + type(obs_diag),pointer:: jj_diag + type(obs_diag),pointer:: my_diag + type(obs_diag),pointer:: my_diag_pbl + type(obs_diags),pointer:: my_diagLL + + real(r_kind) :: thispbl_height,ratio_PBL_height,prestsfc,diffsfc + real(r_kind) :: hr_offset + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + real(r_kind),allocatable,dimension(:,:,: ) :: ges_q2m + + logical:: l_pbl_pseudo_itype + integer(i_kind):: ich0 + type(obsLList),pointer,dimension(:):: qhead + qhead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!******************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + iqob=5 ! index of q observation + id=6 ! index of station id + itime=7 ! index of observation time in data array + ikxx=8 ! index of ob type + iqmax=9 ! index of max error + itemp=10 ! index of dry temperature + iqc=11 ! index of quality mark + ier2=12 ! index of original-original obs error ratio + iuse=13 ! index of use parameter + idomsfc=14 ! index of dominant surface type + ilone=15 ! index of longitude (degrees) + ilate=16 ! index of latitude (degrees) + istnelv=17 ! index of station elevation (m) + iobshgt=18 ! index of observation height (m) + izz=19 ! index of surface height + iprvd=20 ! index of observation provider + isprvd=21 ! index of observation subprovider + icat =22 ! index of data level category + ijb =23 ! index of non linear qc parameter + iptrb=24 ! index of q perturbation + + var_jb=zero + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + var_jb=zero + +! choose only one observation--arbitrarily choose the one with positive time departure +! handle multiple-reported data at a station + + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if (twodvar_regional) then + duplogic=data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l) + else + duplogic=data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ipres,k) == data(ipres,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l) + end if + + if (duplogic) then + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => null() + my_diag_pbl => null() + + ich0=qNode_ich0; if(l_pbl_pseudo_itype) ich0=qNode_ich0_pbl_pseudo + do jj=1,ich0+1 + jj_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = jj ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(jj_diag)) then + call perr(myname,'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + call perr(myname,' ich =', jj) + call die(myname) + endif + + select case(jj) + case(1); my_diag => jj_diag + case(2); my_diag_pbl => jj_diag + end select + end do + endif + + if(.not.in_curbin) cycle + +! Interpolate log(ps) & log(pres) at mid-layers to obs locations/times + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + + presq=r10*exp(dpres) + itype=ictype(ikx) + dprpx=zero + if(((itype > 179 .and. itype < 190) .or. itype == 199) & + .and. .not.twodvar_regional)then + dprpx=abs(one-exp(dpres-log(psges)))*r10 + end if + +! Put obs pressure in correct units to get grid coord. number + call grdcrd1(dpres,prsltmp(1),nsig,-1) + +! Get approximate k value of surface by using surface pressure + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp(1),nsig,-1) + +! Check to see if observations is above the top of the model (regional mode) + if( dpres>=nsig+1)dprpx=1.e6_r_kind + if((itype > 179 .and. itype < 186) .or. itype == 199) dpres=one + +! Scale errors by guess saturation q + + call tintrp31(qg,qsges,dlat,dlon,dpres,dtime,hrdifsig,& + mype,nfldsig) + +! Interpolate 2-m qs to obs locations/times + if((i_use_2mq4b > 0) .and. ((itype > 179 .and. itype < 190) .or. itype == 199) & + .and. .not.twodvar_regional)then + call tintrp2a11(qg2m,qsges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) + endif + +! Load obs error and value into local variables + obserror = max(cermin(ikx)*r0_01,min(cermax(ikx)*r0_01,data(ier,i))) + qob = data(iqob,i) + + rmaxerr=rmaxerr*qsges + rmaxerr=max(small2,rmaxerr) + errorx =(data(ier,i)+dprpx)*qsges + +! Interpolate guess moisture to observation location and time + call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + + ddiff=qob-qges + +! Setup dynamic ob error specification for aircraft recon in hurricanes + + if (aircraft_recon) then + if (itype == 136 ) then + + errorx = q_doe_a_136*abs(ddiff)+q_doe_b_136 + + endif + + if (itype == 137 ) then + + errorx = q_doe_a_137*abs(ddiff)+q_doe_b_137 + + endif + endif + + errorx =max(small1,errorx) + + +! Adjust observation error to reflect the size of the residual. +! If extrapolation occurred, then further adjust error according to +! amount of extrapolation. + + rlow=max(sfcchk-dpres,zero) +! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] + if(l_sfcobserror_ramp_q) then + ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)*0.001_r_kind + else + ramp=rlow + endif + + rhgh=max(dpres-r0_001-rsig,zero) + + if(luse(i))then + awork(1) = awork(1) + one + if(rlow/=zero) awork(2) = awork(2) + one + if(rhgh/=zero) awork(3) = awork(3) + one + end if + + ratio_errors=error*qsges/(errorx+1.0e6_r_kind*rhgh+r8*ramp) + +! Check to see if observations is above the top of the model (regional mode) + if (dpres > rsig) ratio_errors=zero + error=one/(error*qsges) + + iz = max(1, min( int(dpres), nsig)) + delz = max(zero, min(dpres - float(iz), one)) + + + if (save_jacobian) then + q_ind =getindex(svars3d,'q') + if (q_ind < 0) then + print *, 'Error: no variable q in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = iz + sum(levels(1:q_ind-1)) + dhx_dx%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:q_ind-1)) + + dhx_dx%val(1) = one - delz ! weight for iz's level + dhx_dx%val(2) = delz ! weight for iz+1's level + endif + +! Interpolate 2-m q to obs locations/times + if(i_use_2mq4b>0 .and. itype > 179 .and. itype < 190 .and. .not.twodvar_regional)then + + if(i_coastline==2 .or. i_coastline==3) then +! Interpolate guess th 2m to observation location and time + call tintrp2a11_csln(ges_q2m,q2mges,q2mges_water,dlat,dlon,dtime,hrdifsig,mype,nfldsig) + if(abs(qob-q2mges) > abs(qob-q2mges_water)) q2mges=q2mges_water + else + call tintrp2a11(ges_q2m,q2mges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) + endif + + if(i_use_2mq4b==1)then + qges=0.33_r_single*qges+0.67_r_single*q2mges + elseif(i_use_2mq4b==2) then + if(q2mges >= qges) then + q2mges=min(q2mges, 1.15_r_single*qges) + else + q2mges=max(q2mges, 0.85_r_single*qges) + end if + qges=q2mges + else + write(6,*) 'Invalid i_use_2mq4b number=',i_use_2mq4b + call stop2(100) + endif + ddiff=qob-qges + endif + + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov*1.e-3_r_kind + error=one/(magoberr*1.e-3_r_kind) + ratio_errors=one + end if + +! Gross error checks + + if(abs(ddiff) > grsmlt*data(iqmax,i)) then + error=zero + ratio_errors=zero + + + if(luse(i))awork(5)=awork(5)+one + end if + obserror=min(one/max(ratio_errors*error,tiny_r_kind),huge_error) + obserror=obserror*r100/qsges + obserrlm=max(cermin(ikx),min(cermax(ikx),obserror)) + residual=abs(ddiff*r100/qsges) + ratio=residual/obserrlm + +! modify gross check limit for quality mark=3 + if(data(iqc,i) == three ) then + qcgross=r0_7*cgross(ikx) + else + qcgross=cgross(ikx) + endif + + if (twodvar_regional) then + if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) & + qcgross=r3p5*qcgross + endif + + if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then + if(luse(i))awork(4)=awork(4)+one + error=zero + ratio_errors=zero + + else + ratio_errors = ratio_errors/sqrt(dup(i)) + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Oberror Tuning and Perturb Obs + if(muse(i)) then + if(oberror_tune )then + if( jiter > jiterstart ) then + ddiff=ddiff+data(iptrb,i)/error/ratio_errors + endif + else if(perturb_obs )then + ddiff=ddiff+data(iptrb,i)/error/ratio_errors + endif + endif + + +! Compute penalty terms + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if(njqc .and. var_jb>tiny_r_kind .and. var_jb < 10.0_r_kind .and. error >tiny_r_kind) then + if(exp_arg == zero) then + wgt=one + else + wgt=ddiff*error/sqrt(two*var_jb) + wgt=tanh(wgt)/wgt + endif + term=-two*var_jb*rat_err2*log(cosh((val)/sqrt(two*var_jb))) + rwgt = wgt/wgtlim + valqc = -two*term + else if (vqc .and. cvar_pg(ikx)> tiny_r_kind .and. error >tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_q=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_q*wnotgross) + term =log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + valqc = -two*rat_err2*term + else + term = exp_arg + wgt =one + rwgt = wgt/wgtlim + valqc = -two*rat_err2*term + endif + +! Accumulate statistics for obs belonging to this task + if(muse(i))then + if(rwgt < one) awork(21) = awork(21)+one + jsig = dpres + jsig=max(1,min(jsig,nsig)) + awork(jsig+5*nsig+100)=awork(jsig+5*nsig+100)+val2*rat_err2 + awork(jsig+6*nsig+100)=awork(jsig+6*nsig+100)+one + awork(jsig+3*nsig+100)=awork(jsig+3*nsig+100)+valqc + end if +! Loop over pressure level groupings and obs to accumulate statistics +! as a function of observation type. + ress = scale*r100*ddiff/qsges + ressw2= ress*ress + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + do k = 1,npres_print + if(presq > ptopq(k) .and. presq <= pbotq(k))then + + bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count + bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ress ! (o-g) + bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty + end if + end do + end if + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call qNode_appendto(my_head,qhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%ich0= qNode_ich0 ! a marker of ordinary obs. + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j,k) indices of guess gridpoint that bound obs location + my_head%dlev= dpres + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2= ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%jb = var_jb + my_head%luse = luse(i) + + if(oberror_tune) then + my_head%qpertb=data(iptrb,i)/error/ratio_errors + my_head%kx=ikx + if (njqc) then + ptablq=ptabl_q + else + ptablq=ptabl + endif + if(presq > ptablq(2))then + my_head%k1=1 + else if( presq <= ptablq(33)) then + my_head%k1=33 + else + k_loop: do k=2,32 + if(presq > ptablq(k+1) .and. presq <= ptablq(k)) then + my_head%k1=k + exit k_loop + endif + enddo k_loop + endif + endif + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,my_head%ich0+1, myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + +! Save select output for diagnostic file + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i)*qsges ! convert rh to q + err_adjst = data(ier,i)*qsges ! convert rh to q + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + +!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!! + if( .not. last .and. l_pbl_pseudo_itype .and. & + muse(i) .and. dpres > -1.0_r_kind ) then + prestsfc=prest + diffsfc=ddiff + call tintrp2a11(pbl_height,thispbl_height,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + ratio_PBL_height = (prest - thispbl_height) * pblh_ration + if(ratio_PBL_height > zero) thispbl_height = prest - ratio_PBL_height + prest = prest - pps_press_incr + DO while (prest > thisPBL_height) + ratio_PBL_height=1.0_r_kind-(prestsfc-prest)/(prestsfc-thisPBL_height) + + allocate(my_head) + call qNode_appendto(my_head,qhead(ibin)) + my_head%idv = is + my_head%iob = ioid(i) + my_head%ich0= qNode_ich0_PBL_pseudo ! a marker of GSI created PBL_pseudo obs. + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +!!! find qob + qob = data(iqob,i) + +! Put obs pressure in correct units to get grid coord. number + dpres=log(prest/r10) + call grdcrd1(dpres,prsltmp(1),nsig,-1) + + +! Interpolate guess moisture to observation location and time + call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + call tintrp31(qg,qsges,dlat,dlon,dpres,dtime,hrdifsig,& + mype,nfldsig) + +!!! Set (i,j,k) indices of guess gridpoint that bound obs location + my_head%dlev= dpres + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) +!!! find ddiff + +! Compute innovations + ddiff=diffsfc*(0.3_r_kind + 0.7_r_kind*ratio_PBL_height) + + error=one/(data(ier2,i)*qsges) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%jb = var_jb + my_head%luse = luse(i) + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag_pbl, & + my_head%idv,my_head%iob,my_head%ich0+1,myname,'my_diag_pbl:my_head') + + call obsdiagNode_set(my_diag_pbl, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=.true., nldepart=my_head%res) + + my_head%diags => my_diag_pbl + endif + +! Save select output for diagnostic file + if(conv_diagsave .and. luse(i))then + iip=iip+1 + if(iip <= 3*nobs ) then + rstation_id = data(id,i) + + err_input = data(ier2,i)*qsges ! convert rh to q + err_adjst = data(ier,i)*qsges ! convert rh to q + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diagp_() + else + iip=3*nobs + endif + if(netcdf_diag) call contents_netcdf_diagp_() + endif !conv_diagsave .and. luse(i)) + + prest = prest - pps_press_incr + + my_head => null() + ENDDO + + endif ! 181,183,187 +!!!!!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!!!!!!!!! + +! End of loop over observations + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)' q',nchar,nreal,ii+iip,mype,ioff0 + if(l_pbl_pseudo_surfobsq .and. iip>0) then + write(7)cdiagbuf(1:ii),cdiagbufp(1:iip),rdiagbuf(:,1:ii),rdiagbufp(:,1:iip) + deallocate(cdiagbufp,rdiagbufp) + else + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + endif + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + endif + end if + +! End of routine + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::u' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::v' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get q2m ... + if (i_use_2mq4b>0) then + varname='q2m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_q2m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_q2m(size(rank2,1),size(rank2,2),nfldsig)) + ges_q2m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_q2m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + endif ! i_use_2mq4b +! get q ... + varname='q' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_q))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_q(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_q(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_q_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = presq ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = var_jb ! non linear qc b parameter + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse observation error + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error + rdiagbuf(16,ii) = errinv_final ! final inverse observation error + + rdiagbuf(17,ii) = data(iqob,i) ! observation + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis + rdiagbuf(19,ii) = qob-qges ! obs-ges w/o bias correction (future slot) + + rdiagbuf(20,ii) = qsges ! guess saturation specific humidity + rdiagbuf(21,ii) = 1e+10_r_single ! spread (filled in by EnKF) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + ioff = ioff + 1 + rdiagbuf(ioff,ii) = data(idomsfc,i) ! dominate surface type + ioff = ioff + 1 + rdiagbuf(ioff,ii) = data(izz,i) ! model terrain at ob location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + + subroutine contents_binary_diagp_ + + cdiagbufp(iip) = station_id ! station id + + rdiagbufp(1,iip) = ictype(ikx) ! observation type + rdiagbufp(2,iip) = icsubtype(ikx) ! observation subtype + + rdiagbufp(3,iip) = data(ilate,i) ! observation latitude (degrees) + rdiagbufp(4,iip) = data(ilone,i) ! observation longitude (degrees) + rdiagbufp(5,iip) = data(istnelv,i) ! station elevation (meters) + rdiagbufp(6,iip) = prest !presq ! observation pressure (hPa) + rdiagbufp(7,iip) = data(iobshgt,i) ! observation height (meters) + rdiagbufp(8,iip) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbufp(9,iip) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbufp(10,iip) = var_jb ! non linear qc b parameter + rdiagbufp(11,iip) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbufp(12,iip) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbufp(12,iip) = -one + endif + + rdiagbufp(13,iip) = rwgt ! nonlinear qc relative weight + rdiagbufp(14,iip) = errinv_input ! prepbufr inverse observation error + rdiagbufp(15,iip) = errinv_adjst ! read_prepbufr inverse obs error + rdiagbufp(16,iip) = errinv_final ! final inverse observation error + + rdiagbufp(17,iip) = data(iqob,i) ! observation + rdiagbufp(18,iip) = ddiff ! obs-ges used in analysis + rdiagbufp(19,iip) = ddiff !qob-qges ! obs-ges w/o bias correction (future slot) + + rdiagbufp(20,iip) = qsges ! guess saturation specific humidity + rdiagbufp(21,iip) = 1e+10_r_single ! spread (filled in by EnKF) + + ioff=ioff0 + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx) + endif + + end subroutine contents_binary_diagp_ + + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' q' + real(r_kind),dimension(miter) :: obsdiag_iuse + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(presq) ) + call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata("Nonlinear_QC_Var_Jb", sngl(var_jb) ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(data(iqob,i))) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(qob-qges) ) + call nc_diag_metadata("Forecast_Saturation_Spec_Hum", sngl(qsges) ) + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diag_ + + subroutine contents_netcdf_diagp_ +! Observation class + character(7),parameter :: obsclass = ' q' + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(presq) ) + call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata("Nonlinear_QC_Var_Jb", sngl(var_jb) ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(data(iqob,i))) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(ddiff) ) + call nc_diag_metadata("Forecast_Saturation_Spec_Hum", sngl(qsges) ) + + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + end subroutine contents_netcdf_diagp_ + + subroutine final_vars_ + if(allocated(ges_q2m)) deallocate(ges_q2m) + if(allocated(ges_q )) deallocate(ges_q ) + if(allocated(ges_ps)) deallocate(ges_ps) + end subroutine final_vars_ + +end subroutine setupq +end module q_setup diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 new file mode 100644 index 000000000..b693d668a --- /dev/null +++ b/src/gsi/setuprad.f90 @@ -0,0 +1,2671 @@ +module rad_setup + implicit none + private + public:: setup + interface setup; module procedure setuprad; end interface + +contains + subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& + obstype,isis,is,rad_diagsave,init_pass,last_pass) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuprad compute rhs of oi equation for radiances +! prgmmr: derber org: np23 date: 1995-07-06 +! +! abstract: read in data, first guess, and obtain rhs of oi equation +! for radiances. +! +! program history log: +! 1995-07-06 derber +! 1996-11-xx wu, data from prepbufr file +! 1996-12-xx mcnally, changes for diagnostic file and bugfix +! 1998-04-30 weiyu yang mpi version +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2003-12-23 kleist - remove sigma assumptions (use pressure) +! 2004-05-28 kleist - subroutine call update +! 2004-06-17 treadon - update documenation +! 2004-07-23 weng,yan,okamoto - incorporate MW land and snow/ice emissivity +! models for AMSU-A/B and SSM/I +! 2004-08-02 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - modifications for nonlinear qc +! 2004-10-15 derber - modify parts of IR quality control +! 2004-10-28 treadon - replace parameter tiny with tiny_r_kind +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-11-30 xu li - add SST physical retrieval algorithm +! 2004-12-22 treadon - add outer loop number to name of diagnostic file +! 2005-01-20 okamoto - add ssm/i radiance assimilation +! 2005-01-22 okamoto - add TB jacobian with respect to ocean surface wind +! through MW ocean emissivity model +! 2005-02-22 derber - alter surface determination and improve quality control +! 2005-02-28 treadon - increase size of character variable holding diagnostic +! file name +! 2005-03-02 derber - modify use of surface flages and quality control +! and adjoint of surface emissivity +! 2005-03-04 xu li - restructure code related to sst retrieval +! 2005-03-07 todling,treadon - place lower bound on sum2 +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-03-16 derber - save observation time +! 2005-04-11 treadon - add logical to toggle on/off nonlinear qc code +! 2005-04-18 treadon - modify sections of code related to sst retrieval +! 2005-06-01 treadon - add code to load/use extended vertical profile arrays in rtm +! 2005-07-06 derber - modify for mhs and hirs/4 +! 2005-07-29 treadon - modify tnoise initialization; add varinv_use +! 2005-09-20 xu,pawlak - modify sections of code related to ssmis +! 2005-09-28 derber - modify for new radinfo and surface info input from read routines +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2005-10-17 treadon - generalize accessing of elements from obs array +! 2005-10-20 kazumori - modify sections of code related to amsre +! 2005-11-04 derber - place lower bound (0.0) on computed clw +! 2005-11-14 li - modify avhrr related code +! 2005-11-18 treadon - correct thin snow test to apply to microwave +! 2005-11-18 kazumori - modify sections of amsre diagnostic file +! 2005-11-29 parrish - remove call to deter_sfc_reg (earlier patch for regional mode) +! 2005-12-16 derber - add check on skin temperature to clw bias correction +! 2005-12-20 derber - add transmittance qc check to mw sensors +! 2006-01-09 treadon - introduce get_ij +! 2006-01-12 treadon - replace pCRTM with CRTM +! 2006-01-31 todling - add obs time to output diag files +! 2006-02-01 liu - add ssu +! 2006-02-02 treadon - rename prsi(l) as ges_prsi(l) +! 2006-02-03 derber - add new obs control and change printed stats +! 2006-03-21 treadon - add optional perturbation to observation +! 2006-03-24 treadon - bug fix - add iuse_rad to microwave channel varinv check +! 2006-04-19 treadon - rename emisjac as dtbduv_on (accessible via obsmod) +! 2006-04-27 derber - remove rad_tran_k, process data one profile at a time +! write data in jppf chunks +! 2006-05-10 derber - add check on maximum number of levels for RT +! 2006-05-30 derber,treadon - modify diagnostic output +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-27 kazumori - modify factor of bc predictor(clw) for AMSR-E +! and input of qcssmi +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - unify NL qc and add satellite and solar azimuth angles +! 2006-07-31 kleist - change call to intrppx, no longer get ps at ob location +! 2006-12-21 sienkiewicz - add 'no85GHz' flag for F8 SSM/I +! 2007-01-24 kazumori- modify to qcssmi subroutine output and use ret_ssmis +! for ssmis_las only (assumed UKMO SSMIS data) +! 2007-03-09 su - remove the perturbation to the observation +! 2007-03-19 tremolet - binning of observations +! 2007-04-04 wu - do not load ozone jacobian if running regional mode +! 2007-05-30 h.liu - replace c1 with constoz in ozone jacobian +! 2007-06-05 tremolet - add observation diagnostics structure +! 2007-06-08 kleist/treadon - add prefix (task id or path) to diag_rad_file +! 2007-06-29 jung - update CRTM interface +! 2008-01-30 h.liu/treadon - add SSU cell pressure correction block +! 2008-05-21 safford - rm unused vars and uses +! 2008-12-03 todling - changed handle of tail%time +! 2009-12-07 b.yan - changed qc for channel 5 (relaxed) +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(), and +! new arguments init_pass and last_pass. +! 2009-12-08 guo - cleaned diag output rewind with open(position='rewind') +! - fixed a bug in diag header output while is not init_pass. +! 2010-03-01 gayno - allow assimilation of "mixed" amsua fovs +! 2010-03-30 collard - changes for interface with CRTM v2.0. +! 2010-03-30 collard - Add CO2 interface (fixed value for now). +! 2010-04-08 h.liu -add SEVIRI assimilation +! 2010-04-16 hou/kistler add interface to module ncepgfs_ghg +! 2010-04-29 zhu - add option newpc4pred for new preconditioning for predictors +! 2010-05-06 zhu - add option adp_anglebc variational angle bias correction +! 2010-05-13 zhu - add option passive_bc for bias correction of passive channels +! 2010-05-19 todling - revisit intrppx CO2 handle +! 2010-06-10 todling - reduce pointer check by getting CO2 pointer at this level +! - start adding hooks of aerosols influence on RTM +! 2010-07-15 kleist - reintroduce capability to write out predictor terms (not predicted bias) and +! pressure level that corresponds to peak of weighting function +! 2010-07-16 yan - update quality control of mw water vapor sounding channels (amsu-b and mhs) +! - add a new input (tbc) to in call qcssmi(..) and +! remove 'ssmis_uas,ssmis_las,ssmis_env,ssmis_img' in call qcssmi(..) +! Purpose: to keep the consistent changes with qcssmi.f90 +! 2010-08-10 wu - setup corresponding vegetation types (nmm_to_crtm) for IGBP in regional +! parameter nvege_type: old=24, IGBP=20 +! 2010-08-17 derber - move setup input and crtm call to crtm_interface (intrppx) to simplify routine +! 2010-09-30 zhu - re-order predterms and predbias +! 2010-12-16 treadon - move cbias update before calc_clw +! 2011-02-17 todling - add knob to turn off O3 Jacobian from IR instruments (per Emily Liu's work) +! 2011-03-13 li - (1) associate nst_gsi and nstinfo (use radinfo) to handle nst fields +! - (2) modify to save nst analysis related diagnostic variables +! 2011-04-07 todling - newpc4pred now in radinfo +! 2011-05-04 todling - partially merge in Min-Jeong Kim's cloud clear assimilation changes (connect to Metguess) +! 2011-05-16 todling - generalize handling of jacobian matrix entries +! 2011-05-20 mccarty - updated for ATMS +! 2011-06-08 zhu - move assignments of tnoise_cld values to satinfo file via varch_cld, use lcw4crtm +! 2011-06-09 sienkiewicz - call to qc_ssu needs tb_obs instead of tbc +! 2011-07-10 zhu - add jacobian assignments for regional cloudy radiance +! 2011-09-28 collard - Fix error trapping for CRTM failures. +! 2012-05-12 todling - revisit opts in gsi_metguess_get (4crtm) +! 2012-11-02 collard - Use cloud detection channel flag for IR. +! 2013-02-13 eliu - Add options for SSMIS instruments +! - Add two additional bias predictors for SSMIS radiances +! - Tighten up QC checks for SSMIS + +! 2013-02-19 sienkiewicz - add adjustable preweighting for SSMIS bias terms +! 2013-07-10 zhu - add upd_pred as an update indicator for bias correction coeficitient +! 2013-07-19 zhu - add emissivity sensitivity predictor for radiance bias correction +! 2013-11-19 sienkiewicz - merge back in changes for adjustable preweighting for SSMIS bias terms +! 2013-11-21 todling - inquire diag-file version using get_radiag +! 2013-12-10 zhu - apply bias correction to tb_obs for ret_amsua calculation +! 2013-12-21 eliu - add amsu-a obs errors for allsky condition +! 2013-12-21 eliu - add error handling for CLWP calculation for allsky +! 2014-01-17 zhu - add cld_rbc_idx for bias correction sample to handle cases with cloud +! inconsistency between obs and first guess for all-sky microwave radiance +! 2014-01-19 zhu - add scattering index calculation, add it as a predictor for allsky +! - calculate retrieved clw using bias-corrected tsim +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-01-31 mkim - Remove abs(60.0degree) boundary which existed for all-sky MW radiance DA +! 2014-02-01 mkim - Move all-sky mw obserr to subroutine obserr_allsky_mw +! 2014-02-05 todling - Remove overload of diagbufr slot (not allowed) +! 2014-04-17 todling - Implement inter-channel ob correlated covariance capability +! 2014-04-27 eliu - change qc_amsua/atms interface +! 2014-04-27 eliu - change call_crtm interface to output clear-sky Tb under all-sky condition (optional) +! 2014-04-27 eliu - add cloud effect calculation for AMSU-A/ATMS under all-sky condition +! 2014-05-29 thomas - add lsingleradob capability (originally of mccarty) +! 2014-08-01 zhu - remove scattering index predictor +! - add all-sky obs error adjustment based on scattering index, diff of clw, +! cloud mismatch info, and surface wind speed +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-01-15 zhu - change amsua quality control interface to apply emissivity sensitivity +! screen to all-sky AMSUA and ATMS radiance +! 2015-01-16 ejones - Added call to qc_gmi for gmi observations +! - Added saphir +! 2015-02-12 ejones - Write gwp to diag file for GMI +! 2015-03-11 ejones - Added call to qc_amsr2 for amsr2 observations +! 2015-03-23 ejones - Added call to qc_saphir for saphir observations +! 2015-03-23 zaizhong ma - add Himawari-8 ahi +! 2014-08-06 todling - Correlated obs now platform-instrument specific +! 2014-09-02 todling - Must protect NST-related diag out for when NST is on +! 2014-09-03 j.jin - Added GMI 1CR radiance, obstype=gmi. +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-03-31 zhu - move cloudy AMSUA radiance observation error adjustment to qcmod.f90; +! change quality control interface for AMSUA and ATMS. +! 2015-04-01 W. Gu - add isis to obs type +! 2015-08-18 W. Gu - include the dependence of the correlated obs errors on the surface types. +! 2015-09-04 J.Jung - Added mods for CrIS full spectral resolution (FSR). +! 2015-09-10 zhu - generalize enabling all-sky and aerosol usage in radiance assimilation. +! Use radiance_obstype_search & type extentions from radiance_mod. +! - special obs error & bias correction handlings are called from centralized module +! 2015-09-30 ejones - Pull AMSR2 sun azimuth and sun zenith angles for passing to quality control, +! modify qc_amsr2 function call +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-02-15 zhu - remove the code forcing zero Jacobians for qr,qs,qg,qh for regional, let users decide +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(n) +! . removed (%dlat,%dlon) debris. +! 2016-12-09 mccarty - add netcdf_diag capability +! 2016-07-19 W. Gu - add isis to obs type +! 2016-07-19 W. Gu - include the dependence of the correlated obs errors on the surface types +! 2016-07-19 kbathmann -move eigendecomposition for correlated obs here +! 2016-11-29 shlyaeva - save linearized H(x) for EnKF +! 2016-12-09 mccarty - add netcdf_diag capability +! 2016-03-02 mkim - Added all-sky GMI microwave radiance DA related interfaces +! 2016-03-02 mkim - Moved NCEP's AMSU-A all-sky obs error codes to a separate subroutine 'obserr_allsky_mw' +! to allow different obserror models(or coefficients) for different sensors +! while keeping setuprad.f90 compact. +! 2016-03-02 mkim - unified naming for retrieved cloud liquid water path as 'clw_obs' and obsolete +! 'clwp_amsua' and 'clw' to consider all-sky DA for other microwave sensors +! while keeping setuprad.f90 compact +! 2016-10-23 zhu - add cloudy radiance assimilation for ATMS +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2017-07-27 kbathmann/W. Gu -introduce rinvdiag into the rstats computation for correlated error +! 2018-04-04 zhu - add additional radiance_ex_obserr and radiance_ex_biascor calls for all-sky +! 2018-08-08 mkim - merging NCEP all-sky generalization stuff (radiance_mod, cloudy_radiance_info.txt...) +! 2018-07-24 W. Gu - Store the R-covariance matrix only needed for method=1 or 2 +! 2018-07-27 W. Gu - code changes to reduce the round-off errors +! 2019-03-13 eliu - add components to handle precipitation-affected radiances +! 2019-03-13 eliu - add calculation of scattering index for MHS/ATMS +! 2019-03-27 h. liu - add ABI assimilation +! +! input argument list: +! lunin - unit from which to read radiance (brightness temperature, tb) obs +! mype - mpi task id +! nchanl - number of channels per obs +! nreal - number of pieces of non-tb information per obs +! nobs - number of tb observations to process +! obstype - type of tb observation +! isis - sensor/instrument/satellite id ex.amsua_n15 +! is - integer counter for number of observation types to process +! rad_diagsave - logical to switch on diagnostic output (.false.=no output) +! channelinfo - structure containing satellite sensor information +! +! output argument list: +! aivals - array holding sums for various statistics as a function of obs type +! stats - array holding sums for various statistics as a function of channel +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + use mpeu_util, only: die,perr,getindex + use kinds, only: r_kind,r_single,i_kind + use crtm_spccoeff, only: sc + use radinfo, only: nuchan,tlapmean,predx,cbias,ermax_rad,tzr_qc,& + npred,jpch_rad,varch,varch_cld,iuse_rad,icld_det,nusis,fbias,retrieval,b_rad,pg_rad,& + air_rad,ang_rad,adp_anglebc,angord,ssmis_precond,emiss_bc,upd_pred, & + passive_bc,ostats,rstats,newpc4pred,radjacnames,radjacindxs,nsigradjac,nvarjac, & + varch_sea,varch_land,varch_ice,varch_snow,varch_mixed + use gsi_nstcouplermod, only: nstinfo + use read_diag, only: get_radiag,ireal_radiag,ipchan_radiag + use guess_grids, only: sfcmod_gfs,sfcmod_mm5,comp_fact10 + use m_prad, only: radheadm + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: fptr_obsdiagNode + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: ianldate,ndat,mype_diaghdr,nchan_total, & + dplat,dtbduv_on,lobsdiag_forenkf,& + lobsdiagsave,nobskeep,lobsdiag_allocated,& + dirname,time_offset,lwrite_predterms,lwrite_peakwt,reduce_diag + use m_obsNode, only: obsNode + use m_radNode, only: radNode + use m_radNode, only: radNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag,dval_use + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d, nc_diag_chaninfo_dim_set, nc_diag_chaninfo + use gsi_4dvar, only: nobs_bins,hr_obsbin,l4dvar + use gridmod, only: nsig,regional,get_ij + use satthin, only: super_val1 + use constants, only: quarter,half,tiny_r_kind,zero,one,deg2rad,rad2deg,one_tenth, & + two,three,cg_term,wgtlim,r100,r10,r0_01,r_missing + use jfunc, only: jiter,miter,jiterstart + use sst_retrieval, only: setup_sst_retrieval,avhrr_sst_retrieval,& + finish_sst_retrieval,spline_cub + use m_dtime, only: dtime_setup, dtime_check + use crtm_interface, only: init_crtm,call_crtm,destroy_crtm,sensorindex,surface, & + itime,ilon,ilat,ilzen_ang,ilazi_ang,iscan_ang,iscan_pos,iszen_ang,isazi_ang, & + ifrac_sea,ifrac_lnd,ifrac_ice,ifrac_sno,itsavg, & + izz,idomsfc,isfcr,iff10,ilone,ilate, & + isst_hires,isst_navy,idata_type,iclr_sky,itref,idtw,idtc,itz_tr + use crtm_interface, only: ilzen_ang2,iscan_ang2,iszen_ang2,isazi_ang2 + use clw_mod, only: calc_clw, ret_amsua, gmi_37pol_diff + use qcmod, only: qc_ssmi,qc_seviri,qc_abi,qc_ssu,qc_avhrr,qc_goesimg,qc_msu,qc_irsnd,qc_amsua,qc_mhs,qc_atms + use qcmod, only: igood_qc,ifail_gross_qc,ifail_interchan_qc,ifail_crtm_qc,ifail_satinfo_qc,qc_noirjaco3,ifail_cloud_qc + use qcmod, only: ifail_cao_qc,cao_check + use qcmod, only: ifail_iland_det, ifail_isnow_det, ifail_iice_det, ifail_iwater_det, ifail_imix_det, & + ifail_iomg_det, ifail_isst_det, ifail_itopo_det,ifail_iwndspeed_det + use qcmod, only: qc_gmi,qc_saphir,qc_amsr2 + use radinfo, only: iland_det, isnow_det, iwater_det, imix_det, iice_det, & + iomg_det, itopo_det, isst_det,iwndspeed_det + use qcmod, only: setup_tzr_qc,ifail_scanedge_qc,ifail_outside_range + use state_vectors, only: svars3d, levels, svars2d, ns3d, nsdim + use oneobmod, only: lsingleradob,obchan,oblat,oblon,oneob_type + use correlated_obsmod, only: corr_adjust_jacobian, idnames + use radiance_mod, only: rad_obs_type,radiance_obstype_search,radiance_ex_obserr,radiance_ex_biascor + use sparsearr, only: sparr2, new, writearray, size, fullarray + use radiance_mod, only: radiance_ex_obserr_gmi,radiance_ex_biascor_gmi + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + logical ,intent(in ) :: rad_diagsave + character(10) ,intent(in ) :: obstype + character(20) ,intent(in ) :: isis + integer(i_kind) ,intent(in ) :: lunin,mype,nchanl,nreal,nobs,is + real(r_kind),dimension(40,ndat) ,intent(inout) :: aivals + real(r_kind),dimension(7,jpch_rad),intent(inout) :: stats + logical ,intent(in ) :: init_pass,last_pass ! state of "setup" processing + +! Declare external calls for code analysis + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r1e10=1.0e10_r_kind + character(len=*),parameter:: myname="setuprad" + +! Declare local variables + character(128) diag_rad_file + + integer(i_kind) iextra,jextra,error_status + integer(i_kind) ich9,isli,icc,iccm,mm1,ixx + integer(i_kind) m,mm,jc,j,k,i + integer(i_kind) n,nlev,kval,ibin,ioff,ioff0,iii,ijacob + integer(i_kind) ii,jj,idiag,inewpc,nchanl_diag + integer(i_kind) nadir,kraintype,ierrret + integer(i_kind) ioz,ius,ivs,iwrmype + integer(i_kind) iversion_radiag, istatus + integer(i_kind) cor_opt,iinstr,chan_count + character(len=80) covtype + + real(r_single) freq4,pol4,wave4,varch4,tlap4 + real(r_kind) node + real(r_kind) term,tlap,tb_obsbc1,tb_obsbc16,tb_obsbc17 + real(r_kind) drad,dradnob,varrad,error,errinv,useflag + real(r_kind) cg_rad,wgross,wnotgross,wgt,arg,exp_arg + real(r_kind) tzbgr,tsavg5,trop5,pangs,cld,cldp + real(r_kind) cenlon,cenlat,slats,slons,zsges,zasat,dtime +! real(r_kind) wltm1,wltm2,wltm3 + real(r_kind) ys_bias_sst,cosza,val_obs + real(r_kind) sstnv,sstcu,sstph,dtp_avh,dta,dqa + real(r_kind) bearaz,sun_zenith,sun_azimuth +! real(r_kind) sfc_speed,frac_sea,clw,tpwc,sgagl,clwp_amsua,tpwc_guess_retrieval +! real(r_kind) sfc_speed,frac_sea,clw,tpwc,sgagl,tpwc_guess_retrieval + real(r_kind) sfc_speed,frac_sea,tpwc_obs,sgagl,tpwc_guess_retrieval + real(r_kind) gwp,clw_obs + real(r_kind) scat,scatp + real(r_kind) dtsavg,r90,coscon,sincon + real(r_kind) bias + real(r_kind) factch6 + real(r_kind) stability,tcwv,hwp_ratio + real(r_kind) si_obs,si_fg,si_mean + + logical cao_flag + logical hirs2,msu,goessndr,hirs3,hirs4,hirs,amsua,amsub,airs,hsb,goes_img,ahi,mhs,abi + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + logical avhrr,avhrr_navy,lextra,ssu,iasi,cris,seviri,atms + logical ssmi,ssmis,amsre,amsre_low,amsre_mid,amsre_hig,amsr2,gmi,saphir + logical ssmis_las,ssmis_uas,ssmis_env,ssmis_img + logical sea,mixed,land,ice,snow,toss,l_may_be_passive,eff_area + logical microwave, microwave_low + logical no85GHz + logical in_curbin, in_anybin, save_jacobian + logical account_for_corr_obs + logical,dimension(nobs):: zero_irjaco3_pole + +! Declare local arrays + + real(r_single),dimension(ireal_radiag):: diagbuf + real(r_single),allocatable,dimension(:,:):: diagbufex + real(r_single),allocatable,dimension(:,:):: diagbufchan + + real(r_kind),dimension(npred+2):: predterms + real(r_kind),dimension(npred+2,nchanl):: predbias + real(r_kind),dimension(npred,nchanl):: pred,predchan + real(r_kind),dimension(nchanl):: err2,tbc0,raterr2,wgtjo + real(r_kind),dimension(nchanl):: varinv0 + real(r_kind),dimension(nchanl):: varinv,varinv_use,error0,errf,errf0 + real(r_kind),dimension(nchanl):: tb_obs,tbc,tbcnob,tlapchn,tb_obs_sdv + real(r_kind),dimension(nchanl):: tnoise,tnoise_cld + real(r_kind),dimension(nchanl):: emissivity,ts,emissivity_k + real(r_kind),dimension(nchanl):: tsim,wavenumber,tsim_bc +! real(r_kind),dimension(nchanl):: tsim_clr,tsim_clr_bc,cldeff_obs,cldeff_sim + real(r_kind),dimension(nchanl):: tsim_clr,tsim_clr_bc,cldeff_obs,cldeff_fg + real(r_kind),dimension(nsig,nchanl):: wmix,temp,ptau5 + real(r_kind),dimension(nsigradjac,nchanl):: jacobian + real(r_kind),dimension(nreal+nchanl,nobs)::data_s + real(r_kind),dimension(nsig):: qvp,tvp + real(r_kind),dimension(nsig):: prsltmp + real(r_kind),dimension(nsig+1):: prsitmp + real(r_kind),dimension(nchanl):: weightmax + real(r_kind),dimension(nchanl):: cld_rbc_idx,cld_rbc_idx2 + real(r_kind),dimension(nchanl):: tcc + real(r_kind) :: ptau5deriv, ptau5derivmax + real(r_kind) :: clw_guess,clw_guess_retrieval,ciw_guess,rain_guess,snow_guess,clw_avg + real(r_kind) :: tnoise_save + real(r_kind),dimension(:), allocatable :: rsqrtinv + real(r_kind),dimension(:), allocatable :: rinvdiag + +!for GMI (dual scan angles) + real(r_kind),dimension(nchanl):: emissivity2,ts2, emissivity_k2,tsim2 + real(r_kind),dimension(nchanl):: tsim_clr2 + real(r_kind),dimension(5) :: gmi_low_angles + real(r_kind),dimension(nsig,nchanl):: wmix2,temp2,ptau52 + real(r_kind),dimension(nsigradjac,nchanl):: jacobian2 + real(r_kind) cosza2 + + integer(i_kind),dimension(nchanl):: ich,id_qc,ich_diag + integer(i_kind),dimension(nchanl):: kmax + integer(i_kind),allocatable,dimension(:) :: sc_index + integer(i_kind) :: state_ind, nind, nnz + + logical channel_passive + logical,dimension(nobs):: luse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + integer(i_kind):: nperobs + + character(10) filex + character(12) string + + type(radNode),pointer:: my_head,my_headm + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + type(rad_obs_type) :: radmod + + type(obsLList),pointer,dimension(:):: radhead + type(fptr_obsdiagNode),dimension(nchanl):: odiags + + logical:: muse_ii + +! Notations in use: for a single obs. or a single obs. type +! nchanl : a known channel count of a given type obs stream +! nchanl_diag : a subset of "iuse" +! icc, iii : a subset of "(varinv(i)>tiny_r_kind) .and. iuse)" or qc-passed + +! And for all instruments +! jpch_rad : sum(nchanl) +! nchanl_total : subset of jpch_rad, sum(icc) + + radhead => obsLL(:) + + save_jacobian = rad_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + + if (save_jacobian) then + ijacob = 1 ! flag to indicate jacobian saved in diagnostic file + else + ijacob = 0 + endif + +!************************************************************************************** +! Initialize variables and constants. + mm1 = mype+1 + r90 = 90._r_kind + coscon = cos( (r90-55.0_r_kind)*deg2rad ) + sincon = sin( (r90-55.0_r_kind)*deg2rad ) + + factch6 = zero + cld = zero + cldp = zero + tpwc_obs = zero + sgagl = zero + dtp_avh=zero + icc = 0 + iccm = 0 + ich9 = min(9,nchanl) + do i=1,nchanl + do j=1,npred + pred(j,i)=zero + end do + end do + + +! Initialize logical flags for satellite platform + + cao_flag = .false. + hirs2 = obstype == 'hirs2' + hirs3 = obstype == 'hirs3' + hirs4 = obstype == 'hirs4' + hirs = hirs2 .or. hirs3 .or. hirs4 + msu = obstype == 'msu' + ssu = obstype == 'ssu' + goessndr = obstype == 'sndr' .or. obstype == 'sndrd1' .or. & + obstype == 'sndrd2'.or. obstype == 'sndrd3' .or. & + obstype == 'sndrd4' + amsua = obstype == 'amsua' + amsub = obstype == 'amsub' + mhs = obstype == 'mhs' + airs = obstype == 'airs' + hsb = obstype == 'hsb' + goes_img = obstype == 'goes_img' + ahi = obstype == 'ahi' + avhrr = obstype == 'avhrr' + avhrr_navy = obstype == 'avhrr_navy' + ssmi = obstype == 'ssmi' + amsre_low = obstype == 'amsre_low' + amsre_mid = obstype == 'amsre_mid' + amsre_hig = obstype == 'amsre_hig' + amsre = amsre_low .or. amsre_mid .or. amsre_hig + amsr2 = obstype == 'amsr2' + gmi = obstype == 'gmi' + ssmis = obstype == 'ssmis' + ssmis_las = obstype == 'ssmis_las' + ssmis_uas = obstype == 'ssmis_uas' + ssmis_img = obstype == 'ssmis_img' + ssmis_env = obstype == 'ssmis_env' + iasi = obstype == 'iasi' + cris = obstype == 'cris' .or. obstype == 'cris-fsr' + seviri = obstype == 'seviri' + atms = obstype == 'atms' + saphir = obstype == 'saphir' + abi = obstype == 'abi' + + ssmis=ssmis_las.or.ssmis_uas.or.ssmis_img.or.ssmis_env.or.ssmis + + microwave=amsua .or. amsub .or. mhs .or. msu .or. hsb .or. & + ssmi .or. ssmis .or. amsre .or. atms .or. & + amsr2 .or. gmi .or. saphir + + microwave_low =amsua .or. msu .or. ssmi .or. ssmis .or. amsre + +! Determine cloud & aerosol usages in radiance assimilation + call radiance_obstype_search(obstype,radmod) + +! Initialize channel related information + tnoise = r1e10 + tnoise_cld = r1e10 + l_may_be_passive = .false. + toss = .true. + jc=0 + + do j=1,jpch_rad + if(isis == nusis(j))then + jc=jc+1 + if(jc > nchanl)then + write(6,*)'SETUPRAD: ***ERROR*** in channel numbers, jc,nchanl=',jc,nchanl,& + ' ***STOP IN SETUPRAD***' + call stop2(71) + end if + +! Load channel numbers into local array based on satellite type + + ich(jc)=j + do i=1,npred + predchan(i,jc)=predx(i,j) + end do +! +! Set error instrument channels + tnoise(jc)=varch(j) + channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0 + if (iuse_rad(j)< -1 .or. (channel_passive .and. & + .not.rad_diagsave)) tnoise(jc)=r1e10 + if (passive_bc .and. channel_passive) tnoise(jc)=varch(j) + if (iuse_rad(j)>0) l_may_be_passive=.true. + if (tnoise(jc) < 1.e4_r_kind) toss = .false. + + tnoise_cld(jc)=varch_cld(j) + if (iuse_rad(j)< -1 .or. (iuse_rad(j) == -1 .and. & + .not.rad_diagsave)) tnoise_cld(jc)=r1e10 + if (passive_bc .and. (iuse_rad(j)==-1)) tnoise_cld(jc)=varch_cld(j) + end if + end do + + if(nchanl > jc) write(6,*)'SETUPRAD: channel number reduced for ', & + obstype,nchanl,' --> ',jc + if(jc == 0 .or. toss)then + if(jc == 0 .and. mype == 0) then + write(6,*)'SETUPRAD: No channels found for ', obstype,isis + end if + if (toss .and. mype == 0) then + write(6,*)'SETUPRAD: all obs var > 1e4. do not use ',& + 'data from satellite is=',isis + endif + + if(nobs >0)read(lunin) + return + endif + + if ( mype == 0 .and. .not.l_may_be_passive) write(6,*)mype,'setuprad: passive obs',is,isis + +! Logic to turn off print of reading coefficients if not first interation or not mype_diaghdr or not init_pass + iwrmype=-99 + if(mype==mype_diaghdr(is) .and. init_pass .and. jiterstart == jiter)iwrmype = mype_diaghdr(is) + +! Initialize radiative transfer and pointers to values in data_s + call init_crtm(init_pass,iwrmype,mype,nchanl,nreal,isis,obstype,radmod) + +! Get indexes of variables in jacobian to handle exceptions down below + ioz =getindex(radjacnames,'oz') + if(ioz>0) then + ioz=radjacindxs(ioz) + endif + ius =getindex(radjacnames,'u') + ivs =getindex(radjacnames,'v') + if(ius>0.and.ivs>0) then + ius=radjacindxs(ius) + ivs=radjacindxs(ivs) + endif + +! Initialize ozone jacobian flags to .false. (retain ozone jacobian) + zero_irjaco3_pole = .false. + +! These variables are initialized in init_crtm +! isatid = 1 ! index of satellite id +! itime = 2 ! index of analysis relative obs time +! ilon = 3 ! index of grid relative obs location (x) +! ilat = 4 ! index of grid relative obs location (y) +! ilzen_ang = 5 ! index of local (satellite) zenith angle (radians) +! ilazi_ang = 6 ! index of local (satellite) azimuth angle (radians) +! iscan_ang = 7 ! index of scan (look) angle (radians) +! iscan_pos = 8 ! index of integer scan position +! iszen_ang = 9 ! index of solar zenith angle (degrees) +! isazi_ang = 10 ! index of solar azimuth angle (degrees) +! ifrac_sea = 11 ! index of ocean percentage +! ifrac_lnd = 12 ! index of land percentage +! ifrac_ice = 13 ! index of ice percentage +! ifrac_sno = 14 ! index of snow percentage +! its_sea = 15 ! index of ocean temperature +! its_lnd = 16 ! index of land temperature +! its_ice = 17 ! index of ice temperature +! its_sno = 18 ! index of snow temperature +! itsavg = 19 ! index of average temperature +! ivty = 20 ! index of vegetation type +! ivfr = 21 ! index of vegetation fraction +! isty = 22 ! index of soil type +! istp = 23 ! index of soil temperature +! ism = 24 ! index of soil moisture +! isn = 25 ! index of snow depth +! izz = 26 ! index of surface height +! idomsfc = 27 ! index of dominate surface type +! isfcr = 28 ! index of surface roughness +! iff10 = 29 ! index of ten meter wind factor +! ilone = 30 ! index of earth relative longitude (degrees) +! ilate = 31 ! index of earth relative latitude (degrees) +! itref = 34/36 ! index of foundation temperature: Tr +! idtw = 35/37 ! index of diurnal warming: d(Tw) at depth zob +! idtc = 36/38 ! index of sub-layer cooling: d(Tc) at depth zob +! itz_tr = 37/39 ! index of d(Tz)/d(Tr) + +! Initialize sensor specific array pointers +! if (goes_img) then +! iclr_sky = 7 ! index of clear sky amount +! elseif (avhrr_navy) then +! isst_navy = 7 ! index of navy sst (K) retrieval +! idata_type = 30 ! index of data type (151=day, 152=night) +! isst_hires = 31 ! index of interpolated hires sst (K) +! elseif (avhrr) then +! iclavr = 32 ! index CLAVR cloud flag with AVHRR data +! isst_hires = 33 ! index of interpolated hires sst (K) +! elseif (seviri) then +! iclr_sky = 7 ! index of clear sky amount +! endif +! Special setup for SST retrieval (output) + if (retrieval.and.init_pass) call setup_sst_retrieval(obstype,dplat(is),mype) + +! Special setup for Tz retrieval + if (tzr_qc>0) call setup_tzr_qc(obstype) + +! Get version of rad-diag file + call get_radiag ('version',iversion_radiag,istatus) + if(istatus/=0) then + write(6,*)'SETUPRAD: trouble getting version of diag file' + call stop2(999) + endif + +! If SSM/I, check for non-use of 85GHz channel, for QC workaround +! set no85GHz true if any 85GHz is not used, and other freq channel is used + no85GHz = .false. + if (ssmi) then + if (iuse_rad(ich(6)) < 1 .or. iuse_rad(ich(7)) < 1 ) then + do j = 1,5 + if (iuse_rad(ich(j)) >= 1) then + no85GHz = .true. + cycle + endif + enddo + if (no85GHz .and. mype == 0) write(6,*) & + 'SETUPRAD: using no85GHZ workaround for SSM/I ',isis + endif + endif + + + +! Find number of channels written to diag file + if(reduce_diag)then + nchanl_diag=0 + do i=1,nchanl + if(iuse_rad(ich(i)) >= 1)then + nchanl_diag=nchanl_diag+1 + ich_diag(nchanl_diag)=i + end if + end do + if(mype == mype_diaghdr(is))write(6,*)'SETUPRAD: reduced number of channels ',& + nchanl_diag,' of ',nchanl,' written to diag file ' + else + nchanl_diag=nchanl + do i=1,nchanl_diag + ich_diag(i)=i + end do + end if + +! Set number of extra pieces of information to write to diagnostic file +! For most satellite sensors there is no extra information. However, +! for GOES Imager data we write additional information. + iextra=0 + jextra=0 + if (goes_img .or. lwrite_peakwt) then + jextra=nchanl_diag + iextra=1 + end if +! If both, iextra=2 + if (goes_img .and. lwrite_peakwt) then + iextra=2 + end if + + lextra = (iextra>0) + + +! Allocate array to hold channel information for diagnostic file and/or lobsdiagsave option + idiag=ipchan_radiag+npred+3 + ioff0 = idiag + if (save_jacobian) then + nnz = nsigradjac + nind = nvarjac + call new(dhx_dx, nnz, nind) + idiag = idiag + size(dhx_dx) + endif + if (lobsdiagsave) idiag=idiag+4*miter+1 + allocate(diagbufchan(idiag,nchanl_diag)) + + allocate(sc_index(nchanl)) + sc_index(:) = 0 + satinfo_chan: do i=1, nchanl + n = ich(i) + spec_coef: do k=1, sc(1)%n_channels + if ( nuchan(n) == sc(1)%sensor_channel(k)) then + sc_index(i) = k + exit spec_coef + endif + end do spec_coef + end do satinfo_chan + + do i=1,nchanl + wavenumber(i)=sc(sensorindex)%wavenumber(sc_index(i)) + end do + +! If diagnostic file requested, open unit to file and write header. + if (rad_diagsave .and. nchanl_diag > 0) then + if (binary_diag) call init_binary_diag_ + if (netcdf_diag) call init_netcdf_diag_ + endif + +! Load data array for current satellite + read(lunin) data_s,luse,ioid + + if (nobskeep>0) then +! write(6,*)'setuprad: nobskeep',nobskeep + call stop2(275) + end if + +! PROCESSING OF SATELLITE DATA + +! Loop over data in this block + call dtime_setup() + do n = 1,nobs +! Extract analysis relative observation time. + dtime = data_s(itime,n) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + + id_qc = igood_qc + if(luse(n))aivals(1,is) = aivals(1,is) + one + +! Extract lon and lat. + slons = data_s(ilon,n) ! grid relative longitude + slats = data_s(ilat,n) ! grid relative latitude + cenlon = data_s(ilone,n) ! earth relative longitude (degrees) + cenlat = data_s(ilate,n) ! earth relative latitude (degrees) +! Extract angular information + zasat = data_s(ilzen_ang,n) + cosza = cos(zasat) + zsges=data_s(izz,n) + nadir = nint(data_s(iscan_pos,n)) + pangs = data_s(iszen_ang,n) +! Extract warm load temperatures +! wltm1 = data_s(isty,n) +! wltm2 = data_s(istp,n) +! wltm3 = data_s(ism,n) + +! If desired recompute 10meter wind factor + if(sfcmod_gfs .or. sfcmod_mm5) then + isli=nint(data_s(idomsfc,n)) + call comp_fact10(slats,slons,dtime,data_s(itsavg,n),data_s(isfcr,n), & + isli,mype,data_s(iff10,n)) + end if + + if(seviri .and. abs(data_s(iszen_ang,n)) > 180.0_r_kind) data_s(iszen_ang,n)=r100 + + +! Set land/sea, snow, ice percentages and flags (no time interpolation) + + sea = data_s(ifrac_sea,n) >= 0.99_r_kind + land = data_s(ifrac_lnd,n) >= 0.99_r_kind + ice = data_s(ifrac_ice,n) >= 0.99_r_kind + snow = data_s(ifrac_sno,n) >= 0.99_r_kind + mixed = .not. sea .and. .not. ice .and. & + .not. land .and. .not. snow + eff_area=.false. + if (radmod%lcloud_fwd) then + eff_area=(radmod%cld_sea_only .and. sea) .or. (.not. radmod%cld_sea_only) + end if + + iinstr=-1 + if(allocated(idnames)) then + if(sea)then + covtype = trim(isis)//':sea' + iinstr=getindex(idnames,trim(covtype)) + else if(land)then + covtype = trim(isis)//':land' + iinstr=getindex(idnames,trim(covtype)) + else if(ice)then + covtype = trim(isis)//':ice' + iinstr=getindex(idnames,trim(covtype)) + else if(snow)then + covtype = trim(isis)//':snow' + iinstr=getindex(idnames,trim(covtype)) + else if(mixed)then + covtype = trim(isis)//':mixed' + iinstr=getindex(idnames,trim(covtype)) + endif + endif + do jc=1,nchanl + j=ich(jc) + + tnoise(jc)=varch(j) + + if(sea .and. (varch_sea(j)>zero)) tnoise(jc)=varch_sea(j) + if(land .and. (varch_land(j)>zero)) tnoise(jc)=varch_land(j) + if(ice .and. (varch_ice(j)>zero)) tnoise(jc)=varch_ice(j) + if(snow .and. (varch_snow(j)>zero)) tnoise(jc)=varch_snow(j) + if(mixed .and. (varch_mixed(j)>zero)) tnoise(jc)=varch_mixed(j) + tnoise_save = tnoise(jc) + + channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0 + if (iuse_rad(j)< -1 .or. (channel_passive .and. & + .not.rad_diagsave)) tnoise(jc)=r1e10 + if (passive_bc .and. channel_passive) tnoise(jc)=tnoise_save + if (tnoise(jc) < 1.e4_r_kind) toss = .false. + end do + +! Count data of different surface types + if(luse(n))then + if (mixed) then + aivals(5,is) = aivals(5,is) + one + else if (ice .or. snow) then + aivals(4,is) = aivals(4,is) + one + else if (land) then + aivals(3,is) = aivals(3,is) + one + end if + end if + +! Set relative weight value + val_obs=one + if(dval_use)then + ixx=nint(data_s(nreal-nstinfo,n)) + if (ixx > 0 .and. super_val1(ixx) >= one) then + val_obs=data_s(nreal-nstinfo-1,n)/super_val1(ixx) + endif + endif + +! Load channel data into work array. + do i = 1,nchanl + tb_obs(i) = data_s(i+nreal,n) + end do + + +! Interpolate model fields to observation location, call crtm and create jacobians +! Output both tsim and tsim_clr for allsky + tsim_clr=zero + tcc=zero + if (radmod%lcloud_fwd) then + call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & + tvp,qvp,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & + trop5,tzbgr,dtsavg,sfc_speed, & + tsim,emissivity,ptau5,ts,emissivity_k, & + temp,wmix,jacobian,error_status,tsim_clr=tsim_clr,tcc=tcc, & + tcwv=tcwv,hwp_ratio=hwp_ratio,stability=stability) + if(gmi) then + gmi_low_angles(1:3)=data_s(ilzen_ang:iscan_ang,n) + gmi_low_angles(4:5)=data_s(iszen_ang:isazi_ang,n) + data_s(ilzen_ang:iscan_ang, n) = data_s(ilzen_ang2:iscan_ang2, n) + data_s(iszen_ang:isazi_ang, n) = data_s(iszen_ang2:isazi_ang2, n) + call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & + tvp,qvp,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & + trop5,tzbgr,dtsavg,sfc_speed, & + tsim2,emissivity2,ptau52,ts2,emissivity_k2, & + temp2,wmix2,jacobian2,error_status,tsim_clr2) + ! merge + emissivity(10:13) = emissivity2(10:13) + ts(10:13) = ts2(10:13) + emissivity_k(10:13)= emissivity_k2(10:13) + tsim(10:13) = tsim2(10:13) + wmix(:,10:13) = wmix2(:,10:13) + temp(:,10:13) = temp2(:,10:13) + ptau5(:,10:13) = ptau52(:,10:13) + jacobian(:,10:13) = jacobian2(:,10:13) +! ! output angles for channels 1-9 + data_s(ilzen_ang:iscan_ang, n) = gmi_low_angles(1:3) + data_s(iszen_ang:isazi_ang, n) = gmi_low_angles(4:5) + tsim_clr(10:13) = tsim_clr2(10:13) + cosza2 = cos(data_s(ilzen_ang2,n)) + endif + else + call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & + tvp,qvp,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & + trop5,tzbgr,dtsavg,sfc_speed, & + tsim,emissivity,ptau5,ts,emissivity_k, & + temp,wmix,jacobian,error_status) + if(gmi) then + gmi_low_angles(1:3)=data_s(ilzen_ang:iscan_ang,n) + gmi_low_angles(4:5)=data_s(iszen_ang:isazi_ang,n) + data_s(ilzen_ang:iscan_ang, n) = data_s(ilzen_ang2:iscan_ang2, n) + data_s(iszen_ang:isazi_ang, n) = data_s(iszen_ang2:isazi_ang2, n) + call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & + tvp,qvp,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & + trop5,tzbgr,dtsavg,sfc_speed, & + tsim2,emissivity2,ptau52,ts2,emissivity_k2, & + temp2,wmix2,jacobian2,error_status) + ! merge + emissivity(10:13) = emissivity2(10:13) + ts(10:13) = ts2(10:13) + emissivity_k(10:13)= emissivity_k2(10:13) + tsim(10:13) = tsim2(10:13) + wmix(:,10:13) = wmix2(:,10:13) + temp(:,10:13) = temp2(:,10:13) + ptau5(:,10:13) = ptau52(:,10:13) + jacobian(:,10:13) = jacobian2(:,10:13) +! ! output angles for channels 1-9 + data_s(ilzen_ang:iscan_ang, n) = gmi_low_angles(1:3) + data_s(iszen_ang:isazi_ang, n) = gmi_low_angles(4:5) + cosza2 = cos(data_s(ilzen_ang2,n)) + endif + endif + +! If the CRTM returns an error flag, do not assimilate any channels for this ob +! and set the QC flag to ifail_crtm_qc. +! We currently go through the rest of the QC steps, ensuring that the diagnostic +! files are populated, but this could be changed if it causes problems. + if (error_status == 0) then + varinv(1:nchanl) = val_obs + else + id_qc(1:nchanl) = ifail_crtm_qc + varinv(1:nchanl) = zero + endif + +! For SST retrieval, use interpolated NCEP SST analysis + if (retrieval) then + if( avhrr_navy )then + dtp_avh = data_s(idata_type,n) + sstcu=data_s(isst_hires,n) ! not available, assigned as interpolated sst + sstnv=data_s(isst_navy,n) + elseif ( avhrr) then + if ( pangs <= 89.0_r_kind) then ! day time + dtp_avh = 151.0_r_kind + else + dtp_avh = 152.0_r_kind + endif + sstcu=data_s(isst_hires,n) ! not available, assigned as interpolated sst + sstnv=data_s(isst_hires,n) ! not available, assigned as interpolated sst + endif + tsavg5 = data_s(isst_hires,n) + else + tsavg5=data_s(itsavg,n) + tsavg5=tsavg5+dtsavg + endif + +! If using adaptive angle dependent bias correction, update the predicctors +! for this part of bias correction. The AMSUA cloud liquid water algorithm +! uses total angle dependent bias correction for channels 1 and 2 + if (adp_anglebc) then + do i=1,nchanl + mm=ich(i) + if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then + pred(npred,i)=nadir*deg2rad + else + pred(npred,i)=data_s(iscan_ang,n) + end if + do j=2,angord + pred(npred-j+1,i)=pred(npred,i)**j + end do + cbias(nadir,mm)=zero + do j=1,angord + cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) + end do + end do + end if + +! Compute microwave cloud liquid water or graupel water path for bias correction and QC. + clw_obs=zero + clw_guess_retrieval=zero + gwp=zero + tpwc_guess_retrieval=zero + scatp=zero + scat=zero + ierrret=0 + tpwc_obs=zero + kraintype=0 + cldeff_obs=zero + cldeff_fg=zero + if(microwave .and. sea) then + if(radmod%lcloud_fwd .and. (amsua .or. atms)) then + call ret_amsua(tb_obs,nchanl,tsavg5,zasat,clw_obs,ierrret,scat) + scatp=scat + else + call calc_clw(nadir,tb_obs,tsim,ich,nchanl,no85GHz,amsua,ssmi,ssmis,amsre,atms, & + amsr2,gmi,saphir,tsavg5,sfc_speed,zasat,clw_obs,tpwc_obs,gwp,kraintype,ierrret) + end if + + if (ierrret /= 0) then + if (amsua) then + varinv(1:6)=zero + id_qc(1:6) = ifail_cloud_qc + varinv(15)=zero + id_qc(15) = ifail_cloud_qc + else if (atms) then + varinv(1:7)=zero + id_qc(1:7) = ifail_cloud_qc + varinv(16:22)=zero + id_qc(16:22) = ifail_cloud_qc + else + varinv(1:nchanl)=zero + id_qc(1:nchanl) = ifail_cloud_qc + endif + endif + endif + ! Screening for cold-air outbreak area (only applied to MW for now) + if (cao_check) then + if(microwave .and. sea) then + if(radmod%lcloud_fwd) then + cao_flag = (stability < 12.0_r_kind) .and. (hwp_ratio < half) .and. (tcwv < 8.0_r_kind) + if (cao_flag) then ! remove all tropospheric channels + if (amsua) then + varinv(1:6)=zero + id_qc(1:6) = ifail_cao_qc + varinv(15)=zero + id_qc(15) = ifail_cao_qc + else if (atms) then + varinv(1:7)=zero + id_qc(1:7) = ifail_cao_qc + varinv(16:22)=zero + id_qc(16) = ifail_cao_qc + else + varinv(1:nchanl)=zero + id_qc(1:nchanl) = ifail_cao_qc + endif + endif + endif + endif + endif + + predbias=zero + cld_rbc_idx2=zero + do i=1,nchanl + mm=ich(i) + + +!***** +! COMPUTE AND APPLY BIAS CORRECTION TO SIMULATED VALUES +!***** + +! Construct predictors for 1B radiance bias correction. + if (.not. newpc4pred) then + pred(1,i) = r0_01 + pred(2,i) = one_tenth*(one/cosza-one)**2-.015_r_kind + if(ssmi .or. ssmis .or. amsre .or. gmi .or. amsr2)pred(2,i)=zero + else + pred(1,i) = one + if (adp_anglebc) then + pred(2,i) = zero + else + pred(2,i) = (one/cosza-one)**2 + if(ssmi .or. ssmis .or. amsre .or. gmi .or. amsr2)pred(2,i)=zero + end if + end if + + pred(3,i) = zero + if (amsre) then + pred(3,i) = clw_obs + else + pred(3,i) = clw_obs*cosza*cosza + end if + if(radmod%lcloud_fwd .and. sea) pred(3,i ) = zero + + + + +! Apply bias correction + + kmax(i) = 0 + if (lwrite_peakwt .or. passive_bc) then + ptau5derivmax = -9.9e31_r_kind +! maximum of weighting function is level at which transmittance +! (ptau5) is changing the fastest. This is used for the level +! assignment (needed for vertical localization). + weightmax(i) = zero + do k=2,nsig + ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ & + (log(prsltmp(k-1))-log(prsltmp(k))) ) + if (ptau5deriv > ptau5derivmax) then + ptau5derivmax = ptau5deriv + kmax(i) = k + weightmax(i) = r10*prsitmp(k) ! cb to mb. + end if + enddo + end if + + tlapchn(i)= (ptau5(2,i)-ptau5(1,i))*(tsavg5-tvp(2)) + do k=2,nsig-1 + tlapchn(i)=tlapchn(i)+& + (ptau5(k+1,i)-ptau5(k,i))*(tvp(k-1)-tvp(k+1)) + end do + if (.not. newpc4pred) tlapchn(i) = r0_01*tlapchn(i) + tlap = tlapchn(i)-tlapmean(mm) + pred(4,i)=tlap*tlap + pred(5,i)=tlap + +! additional bias predictor (as/ds node) for SSMIS + pred(6,i)= zero + pred(7,i)= zero + node = data_s(ilazi_ang,n) + if (ssmis .and. node < 1000) then + if (.not. newpc4pred) then + pred(6,i)= ssmis_precond*node*cos(cenlat*deg2rad) + pred(7,i)= ssmis_precond*sin(cenlat*deg2rad) + else + pred(6,i)= node*cos(cenlat*deg2rad) + pred(7,i)= sin(cenlat*deg2rad) + endif + endif + +! emissivity sensitivity bias predictor + if (adp_anglebc .and. emiss_bc) then + pred(8,i)=zero + if (.not.sea .and. abs(emissivity_k(i))>0.001_r_kind) then + pred(8,i)=emissivity_k(i) + end if + end if + + do j=1, npred-angord + pred(j,i)=pred(j,i)*air_rad(mm) + end do + if (adp_anglebc) then + do j=npred-angord+1, npred + pred(j,i)=pred(j,i)*ang_rad(mm) + end do + end if + + do j = 1,npred + predbias(j,i) = predchan(j,i)*pred(j,i) + end do + predbias(npred+1,i) = cbias(nadir,mm)*ang_rad(mm) !global_satangbias + +! Apply SST dependent bias correction with cubic spline + if (retrieval) then + call spline_cub(fbias(:,mm),tsavg5,ys_bias_sst) + predbias(npred+2,i) = ys_bias_sst + endif + +! tbc = obs - guess after bias correction +! tbcnob = obs - guess before bias correction + tbcnob(i) = tb_obs(i) - tsim(i) + tbc(i) = tbcnob(i) + + do j=1, npred-angord + tbc(i)=tbc(i) - predbias(j,i) !obs-ges with bias correction + end do + tbc(i)=tbc(i) - predbias(npred+1,i) + tbc(i)=tbc(i) - predbias(npred+2,i) + +! Calculate cloud effect for QC + if (radmod%cld_effect .and. eff_area) then + cldeff_obs(i) = tb_obs(i)-tsim_clr(i) ! observed cloud delta (no bias correction) + cldeff_fg(i) = tsim(i)-tsim_clr(i) ! simulated cloud delta + ! need to apply bias correction ? need to think about this + bias = zero + do j=1, npred-angord + bias = bias+predbias(j,i) + end do + bias = bias+predbias(npred+1,i) + bias = bias+predbias(npred+2,i) + cldeff_obs(i)=cldeff_obs(i) - bias ! observed cloud delta (bias corrected) + endif + +! End of loop over channels + end do + +! Compute retrieved microwave cloud liquid water and +! assign cld_rbc_idx for bias correction in allsky conditions + cld_rbc_idx=one + if (radmod%lcloud_fwd .and. radmod%ex_biascor .and. eff_area) then + ierrret=0 + do i=1,nchanl + mm=ich(i) + tsim_bc(i)=tsim(i) + tsim_clr_bc(i)=tsim_clr(i) + + do j=1,npred-angord + tsim_bc(i)=tsim_bc(i)+predbias(j,i) + tsim_clr_bc(i)=tsim_clr_bc(i)+predbias(j,i) + end do + tsim_bc(i)=tsim_bc(i)+predbias(npred+1,i) + tsim_bc(i)=tsim_bc(i)+predbias(npred+2,i) + tsim_clr_bc(i)=tsim_clr_bc(i)+predbias(npred+1,i) + tsim_clr_bc(i)=tsim_clr_bc(i)+predbias(npred+2,i) + end do + + if(amsua) call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) + if(gmi) then + call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret) + call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret) + end if + if (radmod%ex_obserr=='ex_obserr1') then + call radiance_ex_biascor(radmod,nchanl,tsim_bc,tsavg5,zasat, & + clw_guess_retrieval,clw_obs,cld_rbc_idx,ierrret) + end if +! if (radmod%ex_obserr=='ex_obserr2') then ! comment out for now, need to be tested +! call radiance_ex_biascor(radmod,nchanl,cldeff_obs,cldeff_fg,cld_rbc_idx) +! end if + if (radmod%ex_obserr=='ex_obserr3') then + call radiance_ex_biascor_gmi(radmod,clw_obs,clw_guess_retrieval,nchanl,cld_rbc_idx) + end if + + if (ierrret /= 0) then + if (amsua) then + varinv(1:6)=zero + id_qc(1:6) = ifail_cloud_qc + varinv(15)=zero + id_qc(15) = ifail_cloud_qc + else if (atms) then + varinv(1:7)=zero + id_qc(1:7) = ifail_cloud_qc + varinv(16:22)=zero + id_qc(16:22) = ifail_cloud_qc + else + varinv(1:nchanl)=zero + id_qc(1:nchanl) = ifail_cloud_qc + endif + endif + +! additional bias predictor for all-sky GMI + if (gmi) then + do i=1,nchanl + pred(6,i) = zero + pred(7,i) = zero + clw_avg = half*(clw_obs+clw_guess_retrieval) + if (i > 3 .and. clw_obs > 0.05_r_kind .and. clw_guess_retrieval > 0.05_r_kind .and. & + abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = one + if (i < 5 .and. clw_obs > 0.2_r_kind .and. clw_guess_retrieval > 0.2_r_kind .and. & + abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = one + + if( i > 3 .and. clw_obs > 0.05_r_kind .and. clw_guess_retrieval > 0.05_r_kind .and. cld_rbc_idx(i) == zero) then + pred(6,i) = clw_avg*clw_avg + pred(7,i) = clw_avg + tbc(i)=tbc(i) - pred(6,i)*predchan(6,i) - pred(7,i)*predchan(7,i) !obs-ges with bias correction + else if( i < 5 .and. clw_obs > 0.2_r_kind .and. clw_guess_retrieval > 0.2_r_kind .and. cld_rbc_idx(i) == zero) then + pred(6,i) = clw_avg*clw_avg + pred(7,i) = clw_avg + tbc(i)=tbc(i) - pred(6,i)*predchan(6,i) - pred(7,i)*predchan(7,i) !obs-ges with bias correction + endif + enddo + endif + + end if !radmod%lcloud_fwd .and. radmod%ex_biascor + + do i=1,nchanl + error0(i) = tnoise(i) + errf0(i) = error0(i) + end do + +! Assign observation error for all-sky radiances + if (radmod%lcloud_fwd .and. eff_area) then + if (radmod%ex_obserr=='ex_obserr1') & + call radiance_ex_obserr(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0) + if (radmod%ex_obserr=='ex_obserr3') & + call radiance_ex_obserr_gmi(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0) + end if + + do i=1,nchanl + mm=ich(i) + channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 + if(tnoise(i) < 1.e4_r_kind .or. (channel_passive .and. rad_diagsave) & + .or. (passive_bc .and. channel_passive))then + varinv(i) = varinv(i)/error0(i)**2 + errf(i) = error0(i) + else + if(id_qc(i) == igood_qc) id_qc(i)=ifail_satinfo_qc + varinv(i) = zero + errf(i) = zero + endif +! End of loop over channels + end do + +!****** +! QC OBSERVATIONS BASED ON VARIOUS CRITERIA +! Separate blocks for various instruments. +!****** + +! ---------- IR ------------------- +! QC HIRS/2, GOES, HIRS/3 and AIRS sounder data +! + ObsQCs: if (hirs .or. goessndr .or. airs .or. iasi .or. cris) then + + frac_sea=data_s(ifrac_sea,n) + +! NOTE: The qc in qc_irsnd uses the inverse squared obs error. +! The loop below loads array varinv_use accounting for whether the +! cloud detection flag is set. Array +! varinv_use is then used in the qc calculations. +! For the case when all channels of a sensor are passive, all +! channels with iuse_rad=-1 or 0 are used in cloud detection. + + do i=1,nchanl + m=ich(i) + if (varinv(i) < tiny_r_kind) then + varinv_use(i) = zero + else + if ((icld_det(m)>0)) then + varinv_use(i) = varinv(i) + else + varinv_use(i) = zero + end if + end if + end do + call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr, & + cris,hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & + wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & + id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole(n)) + +! --------- MSU ------------------- +! QC MSU data + else if (msu) then + + call qc_msu(nchanl,is,ndat,nsig,sea,land,ice,snow,luse(n), & + zsges,cenlat,tbc,ptau5,emissivity_k,ts,id_qc,aivals,errf,varinv) + +! ---------- AMSU-A ------------------- +! QC AMSU-A data + else if (amsua) then + + if (adp_anglebc) then + tb_obsbc1=tb_obs(1)-cbias(nadir,ich(1))-predx(1,ich(1)) + else + tb_obsbc1=tb_obs(1)-cbias(nadir,ich(1)) + end if + + call qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse(n), & + zsges,cenlat,tb_obsbc1,si_mean,cosza,clw_obs,tbc,ptau5,emissivity_k,ts, & + pred,predchan,id_qc,aivals,errf,errf0,clw_obs,varinv,cldeff_obs,cldeff_fg,factch6, & + cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod) + +! If cloud impacted channels not used turn off predictor + + do i=1,nchanl + if ( (i <= 5 .or. i == 15) .and. (varinv(i)<1.e-9_r_kind) ) then + pred(3,i) = zero + end if + end do + + +! ---------- AMSU-B ------------------- +! QC AMSU-B and MHS data + + else if (amsub .or. hsb .or. mhs) then + + call qc_mhs(nchanl,ndat,nsig,is,sea,land,ice,snow,mhs,luse(n), & + zsges,tbc,tb_obs,ptau5,emissivity_k,ts, & + id_qc,aivals,errf,varinv,clw_obs,tpwc_obs) + +! ---------- ATMS ------------------- +! QC ATMS data + + else if (atms) then + + if (adp_anglebc) then + tb_obsbc1=tb_obs(1)-cbias(nadir,ich(1))-predx(1,ich(1)) + tb_obsbc16=tb_obs(16)-cbias(nadir,ich(16))-predx(1,ich(16)) + tb_obsbc17=tb_obs(17)-cbias(nadir,ich(17))-predx(1,ich(17)) + else + tb_obsbc1=tb_obs(1)-cbias(nadir,ich(1)) + tb_obsbc16=tb_obs(16)-cbias(nadir,ich(16)) + tb_obsbc17=tb_obs(17)-cbias(nadir,ich(17)) + end if + si_obs = (tb_obsbc16-tb_obsbc17) - (tsim_clr(16)-tsim_clr(17)) + si_fg = (tsim(16)-tsim(17)) - (tsim_clr(16)-tsim_clr(17)) + si_mean= half*(si_obs+si_fg) + + call qc_atms(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse(n), & + zsges,cenlat,tb_obsbc1,si_mean,cosza,clw_obs,tbc,ptau5,emissivity_k,ts, & + pred,predchan,id_qc,aivals,errf,errf0,clw_obs,varinv,cldeff_obs,cldeff_fg,factch6, & + cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod) + +! ---------- GOES imager -------------- +! GOES imager Q C +! + else if(goes_img)then + + + cld = data_s(iclr_sky,n) + do i = 1,nchanl + tb_obs_sdv(i) = data_s(i+29,n) + end do + call qc_goesimg(nchanl,is,ndat,nsig,ich,dplat(is),sea,land,ice,snow,luse(n), & + zsges,cld,tzbgr,tb_obs,tb_obs_sdv,tbc,tnoise,temp,wmix,emissivity_k,ts,id_qc, & + aivals,errf,varinv) + + +! ---------- SEVIRI ------------------- +! SEVIRI Q C + + else if (seviri) then + + cld = 100-data_s(iclr_sky,n) + + call qc_seviri(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n), & + zsges,tzbgr,tbc,tnoise,temp,wmix,emissivity_k,ts,id_qc,aivals,errf,varinv) +! +! ---------- ABI ------------------- +! ABI Q C + + else if (abi) then + do i=1,nchanl + m=ich(i) + if (varinv(i) < tiny_r_kind) then + varinv_use(i) = zero + else + if ((icld_det(m)>0)) then + varinv_use(i) = varinv(i) + else + varinv_use(i) = zero + end if + end if + end do + + do i = 1,nchanl + tb_obs_sdv(i) = data_s(i+32,n) + end do + + call qc_abi(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n), & + zsges,trop5,tzbgr,tsavg5,tb_obs_sdv,tbc,tb_obs,tnoise,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & + id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax) + + cld = 100-data_s(iclr_sky,n) + +! if rclrsky < 98%, toss data for lowest water-vapor and surface channels + if(data_s(iclr_sky,n)<98.0_r_kind) then + do i=1,nchanl + if(i/=2 .and. i/=3) then + varinv(i)=zero + varinv_use(i)=zero + end if + end do + end if + +! +! additional qc for surface and chn7.3: use split window chns to remove opaque clouds + do i = 1,nchanl + if(i/=2 .and. i/=3) then + if( varinv(i) > tiny_r_kind .and. & + (tb_obs(7)-tb_obs(8))-(tsim(7)-tsim(8)) <= -0.75_r_kind) then + varinv(i)=zero + varinv_use(i)=zero + end if + end if + end do +! + +! ---------- AVRHRR -------------- +! NAVY AVRHRR Q C + + else if (avhrr_navy .or. avhrr) then + + frac_sea=data_s(ifrac_sea,n) + +! NOTE: The qc in qc_avhrr uses the inverse squared obs error. +! The loop below loads array varinv_use accounting for whether the +! cloud detection flag is set. Array +! varinv_use is then used in the qc calculations. +! For the case when all channels of a sensor are passive, all +! channels with iuse_rad=-1 or 0 are used in cloud detection. + do i=1,nchanl + m=ich(i) + if (varinv(i) < tiny_r_kind) then + varinv_use(i) = zero + else + if ((icld_det(m)>0)) then + varinv_use(i) = varinv(i) + else + varinv_use(i) = zero + end if + end if + end do + + call qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n), & + zsges,cenlat,frac_sea,pangs,trop5,tzbgr,tsavg5,tbc,tb_obs,tnoise, & + wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & + id_qc,aivals,errf,varinv,varinv_use,cld,cldp) + + +! ---------- SSM/I , SSMIS, AMSRE ------------------- +! SSM/I, SSMIS, & AMSRE Q C + + else if( ssmi .or. amsre .or. ssmis )then + + frac_sea=data_s(ifrac_sea,n) + if(amsre)then + bearaz= (270._r_kind-data_s(ilazi_ang,n))*deg2rad + sun_zenith=data_s(iszen_ang,n)*deg2rad + sun_azimuth=(r90-data_s(isazi_ang,n))*deg2rad + sgagl = acos(coscon * cos( bearaz ) * cos( sun_zenith ) * cos( sun_azimuth ) + & + coscon * sin( bearaz ) * cos( sun_zenith ) * sin( sun_azimuth ) + & + sincon * sin( sun_zenith )) * rad2deg + end if + call qc_ssmi(nchanl,nsig,ich, & + zsges,luse(n),sea,mixed, & + temp,wmix,ts,emissivity_k,ierrret,kraintype,tpwc_obs,clw_obs,sgagl,tzbgr, & + tbc,tbcnob,tsim,tnoise,ssmi,amsre_low,amsre_mid,amsre_hig,ssmis, & + varinv,errf,aivals(1,is),id_qc) + +! ---------- AMSR2 ------------------- +! AMSR2 Q C + + else if (amsr2) then + + sun_azimuth=data_s(isazi_ang,n) + sun_zenith=data_s(iszen_ang,n) + + call qc_amsr2(nchanl,zsges,luse(n),sea,kraintype,clw_obs,tsavg5, & + tb_obs,sun_azimuth,sun_zenith,amsr2,varinv,aivals(1,is),id_qc) + +! ---------- GMI ------------------- +! GMI Q C + + else if (gmi) then + +! remove some data near the scan edge + if(data_s(32,n) > 0) then + id_qc(1:nchanl) = ifail_scanedge_qc + varinv=zero + endif + + call qc_gmi(nchanl,zsges,luse(n),sea,cenlat, cenlon, & + kraintype,clw_obs,tsavg5,tb_obs,gmi,varinv,aivals(1,is),id_qc,radmod%lcloud_fwd) + +! ---------- SAPHIR ----------------- +! SAPHIR Q C + + else if (saphir) then + + call qc_saphir(nchanl,zsges,luse(n),sea, & + kraintype,varinv,aivals(1,is),id_qc) + +! ---------- SSU ------------------- +! SSU Q C + + elseif (ssu) then + + call qc_ssu(nchanl,is,ndat,nsig,sea,land,ice,snow,luse(n), & + zsges,cenlat,tb_obs,ptau5,emissivity_k,ts,id_qc,aivals,errf,varinv) + + end if ObsQCs + +! Done with sensor qc blocks. Now make final qc decisions. + +! Apply gross check to observations. Toss obs failing test. + do i = 1,nchanl + if (varinv(i) > tiny_r_kind ) then + m=ich(i) + if(radmod%lcloud_fwd .and. eff_area) then + if(radmod%rtype == 'amsua' .and. (i <=5 .or. i==15) ) then + errf(i) = three*errf(i) + else if(radmod%rtype == 'atms' .and. (i <= 6 .or. i>=16) ) then + errf(i) = min(three*errf(i),10.0_r_kind) + else if(radmod%rtype == 'gmi') then + errf(i) = min(2.0_r_kind*errf(i),ermax_rad(m)) + else if (radmod%rtype/='amsua' .and. radmod%rtype/='atms' .and. radmod%rtype/='gmi' .and. radmod%lcloud4crtm(i)>=0) then + errf(i) = three*errf(i) + else + errf(i) = min(three*errf(i),ermax_rad(m)) + endif + else if (ssmis) then + errf(i) = min(1.5_r_kind*errf(i),ermax_rad(m)) ! tighten up gross check for SSMIS + else if (gmi .or. saphir .or. amsr2) then + errf(i) = ermax_rad(m) ! use ermax for GMI, SAPHIR, and AMSR2 gross check + else + errf(i) = min(three*errf(i),ermax_rad(m)) + endif + if (abs(tbc(i)) > errf(i)) then +! If mean obs-ges difference around observations +! location is too large and difference at the +! observation location is similarly large, then +! toss the observation. + if(id_qc(i) == igood_qc)id_qc(i)=ifail_gross_qc + varinv(i) = zero + if(luse(n))stats(2,m) = stats(2,m) + one + if(luse(n))aivals(7,is) = aivals(7,is) + one + end if + end if + end do + + if(amsua .or. atms .or. amsub .or. mhs .or. msu .or. hsb)then + if(amsua)nlev=6 + if(atms)nlev=7 + if(amsub .or. mhs)nlev=5 + if(hsb)nlev=4 + if(msu)nlev=4 + kval=0 + do i=2,nlev +! do i=1,nlev + channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 + if (varinv(i)=1) .or. & + (passive_bc .and. channel_passive))) then + kval=max(i-1,kval) + if(amsub .or. hsb .or. mhs)kval=nlev + if((amsua .or. atms) .and. i <= 3)kval = zero + end if + end do + if(kval > 0)then + do i=1,kval + varinv(i)=zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_interchan_qc + end do + if(amsua)then + varinv(15)=zero + if(id_qc(15) == igood_qc)id_qc(15)=ifail_interchan_qc + end if + if (atms) then + varinv(16:18)=zero + if(id_qc(16) == igood_qc)id_qc(16)=ifail_interchan_qc + if(id_qc(17) == igood_qc)id_qc(17)=ifail_interchan_qc + if(id_qc(18) == igood_qc)id_qc(18)=ifail_interchan_qc + end if + end if + end if + + if(mhs.or.amsub)then + do i = 1, nchanl + m = ich(i) + if(sea .and. isst_det(m) >0 .and. tsavg5 < 278.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_isst_det + endif + + if(sea .and. iwndspeed_det(m)>0 .and. tsavg5 < 285.0_r_kind .and. sfc_speed > 10.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwndspeed_det + endif + if(iomg_det(m) > 0 .and. abs(tbcnob(2)) > 5.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iomg_det + endif + + if(itopo_det(m) > 0 .and. zsges > 1000.0_r_kind ) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_itopo_det + endif + enddo + endif + +! Screen out land surface types by channel. Flags are set in satinfo file. + do i = 1, nchanl + m = ich(i) + if(iwater_det(m) > 0 .and. sea) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwater_det + endif + if(isnow_det(m) > 0 .and. snow) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_isnow_det + endif + if(mixed .and. imix_det(m) > 0) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_imix_det + endif + if(land .and. iland_det(m) > 0) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iland_det + endif + if(ice .and. iice_det(m) > 0) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iice_det + endif + enddo + +! If requested, generate SST retrieval (output) + if(retrieval) then + if(avhrr_navy .or. avhrr) then + call avhrr_sst_retrieval(dplat(is),nchanl,tnoise,& + varinv,tsavg5,sstph,temp,wmix,ts,tbc,cenlat,cenlon,& + dtime,dtp_avh,tb_obs,dta,dqa,luse(n)) + endif + endif + + do i = 1,nchanl + +! Reject radiances for single radiance test + if (lsingleradob) then + ! if the channels are beyond 0.01 of oblat/oblon, specified + ! in gsi namelist, or aren't of type 'oneob_type', reject + if ( (abs(cenlat - oblat) > one/r100 .or. & + abs(cenlon - oblon) > one/r100) .or. & + obstype /= oneob_type ) then + varinv(i) = zero + varinv_use(i) = zero + if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range + else + ! if obchan <= zero, keep all footprints, if obchan > zero, + ! keep only that which has channel obchan + if (i /= obchan .and. obchan > zero) then + varinv(i) = zero + varinv_use(i) = zero + if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range + endif + endif !cenlat/lon + endif !lsingleradob + + enddo + + tbc0=tbc + varinv0 = varinv + raterr2 = zero + err2 = one/error0**2 + wgtjo= varinv ! weight used in Jo term + account_for_corr_obs = .false. + if (l_may_be_passive .and. .not. retrieval) then + iii=0 + do ii=1,nchanl + m=ich(ii) + if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then + iii=iii+1 + raterr2(ii)=error0(ii)**2*varinv(ii) + endif + enddo + if(iii>0 .and. iinstr.ne.-1)then + chan_count=(iii*(iii+1))/2 + allocate(rsqrtinv(chan_count)) + allocate(rinvdiag(iii)) + rsqrtinv=zero + rinvdiag=zero + account_for_corr_obs = corr_adjust_jacobian(iinstr,nchanl,nsigradjac,ich,varinv,& + tbc,err2,raterr2,wgtjo,jacobian,cor_opt,iii,rsqrtinv,rinvdiag) + varinv = wgtjo + endif + endif + + icc = 0 + iccm= 0 + + do i = 1,nchanl + +! Only process observations to be assimilated + + if (varinv(i) > tiny_r_kind ) then + + m = ich(i) + if(luse(n))then + drad = tbc0(i) + dradnob = tbcnob(i) + varrad = tbc(i)*varinv(i) + stats(1,m) = stats(1,m) + one !number of obs +! stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor) +! stats(4,m) = stats(4,m) + tbc0(i)*drad !(obs-mod(w_biascor))**2 +! stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution +! stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor) + stats(3,m) = stats(3,m) + drad*cld_rbc_idx(i) !obs-mod(w_biascor) + stats(4,m) = stats(4,m) + tbc0(i)*drad*cld_rbc_idx(i)!(obs-mod(w_biascor))**2 + stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution + stats(6,m) = stats(6,m) + dradnob*cld_rbc_idx(i) !obs-mod(w/o_biascor) + + if (account_for_corr_obs .and. (cor_opt ==1 .or. cor_opt ==2) ) then + exp_arg = -half*tbc(i)**2 + else + exp_arg = -half*(tbc(i)/error0(i))**2 + endif + + error=sqrt(varinv(i)) + if (pg_rad(m) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-pg_rad(m) + cg_rad=b_rad(m)*error + wgross = cg_term*pg_rad(m)/(cg_rad*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + else + term = exp_arg + wgt = one + endif + stats(7,m) = stats(7,m) -two*raterr2(i)*term + end if + +! Only "good" obs are included in J calculation. + if (iuse_rad(m) >= 1)then + if(luse(n))then + aivals(40,is) = aivals(40,is) + tbc(i)*varrad + aivals(39,is) = aivals(39,is) -two*raterr2(i)*term + aivals(38,is) = aivals(38,is) +one + if(wgt < wgtlim) aivals(2,is)=aivals(2,is)+one + +! summation of observation number + if (newpc4pred) then + ostats(m) = ostats(m) + one*cld_rbc_idx(i) + end if + end if + + icc=icc+1 + +! End of use data block + end if + +! At the end of analysis, prepare for bias correction for monitored channels +! Only "good monitoring" obs are included in J_passive calculation. + channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 + if (passive_bc .and. (jiter>miter) .and. channel_passive) then +! summation of observation number, +! skip ostats accumulation for channels without coef. initialization + if (newpc4pred .and. luse(n) .and. any(predx(:,m)/=zero)) then + ostats(m) = ostats(m) + one*cld_rbc_idx(i) + end if + iccm=iccm+1 + end if + + +! End of varinv>tiny_r_kind block + endif + +! End loop over channels. + end do + + endif ! (in_curbin) + +! In principle, we want ALL obs in the diagnostics structure but for +! passive obs (monitoring), it is difficult to do if rad_diagsave +! is not on in the first outer loop. For now we use l_may_be_passive... +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (l_may_be_passive .and. .not. retrieval) then + + if(in_curbin) then +! Load data into output arrays + if(icc > 0)then + nchan_total=nchan_total+icc + + allocate(my_head) + call radNode_appendto(my_head,radhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(n) + my_head%elat= data_s(ilate,n) + my_head%elon= data_s(ilone,n) + my_head%isis = isis + my_head%covtype = covtype + + allocate(my_head%res(icc),my_head%err2(icc), & + my_head%raterr2(icc),my_head%pred(npred,icc), & + my_head%dtb_dvar(nsigradjac,icc), & + my_head%ich(icc),& + my_head%icx(icc)) + if(luse_obsdiag)allocate(my_head%diags(icc)) + + call get_ij(mm1,slats,slons,my_head%ij,my_head%wij) + my_head%time=dtime + my_head%luse=luse(n) + my_head%ich(:)=-1 + + + iii=0 + do ii=1,nchanl + m=ich(ii) + if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then + + iii=iii+1 + + my_head%res(iii)= tbc(ii) ! evecs(R)*[obs-ges innovation] + my_head%err2(iii)= err2(ii) ! 1/eigenvalue(R) + my_head%raterr2(iii)=raterr2(ii) ! inflation factor + my_head%icx(iii)= m ! channel index + + do k=1,npred + my_head%pred(k,iii)=pred(k,ii)*max(cld_rbc_idx(ii),cld_rbc_idx2(ii))*upd_pred(k) + end do + + do k=1,nsigradjac + my_head%dtb_dvar(k,iii)=jacobian(k,ii) + end do + +! Load jacobian for ozone (dTb/doz). For hirs and goes channel 9 +! (ozone channel) we do not let the observations change the ozone. +! There currently is no ozone analysis when running in the NCEP +! regional mode, therefore set ozone jacobian to 0.0 + if (ioz>=0) then + if (regional .or. qc_noirjaco3 .or. zero_irjaco3_pole(n) .or. & + ((hirs .or. goessndr).and.(varinv(ich9) < tiny_r_kind))) then + do k = 1,nsig + my_head%dtb_dvar(ioz+k,iii) = zero + end do + endif + endif + +! Load Jacobian for wind speed (dTb/du, dTb/dv) + if(ius>=0.and.ivs>=0) then + if( .not. dtbduv_on .or. .not. microwave) then + my_head%dtb_dvar(ius+1,iii) = zero + my_head%dtb_dvar(ivs+1,iii) = zero + endif + end if + + my_head%ich(iii)=ii + +! compute hessian contribution from Jo bias correction terms + if (newpc4pred .and. luse(n)) then + if (account_for_corr_obs .and. (cor_opt ==1 .or. cor_opt ==2)) then + do k=1,npred + rstats(k,m)=rstats(k,m)+my_head%pred(k,iii) & + *my_head%pred(k,iii)*rinvdiag(iii) + end do + else + do k=1,npred + rstats(k,m)=rstats(k,m)+my_head%pred(k,iii) & + *my_head%pred(k,iii)*varinv(ii) + end do + end if + end if ! end of newpc4pred loop + end if + end do + my_head%nchan = iii ! profile observation count + + my_head%use_corr_obs=.false. + if (account_for_corr_obs .and. (cor_opt ==1 .or. cor_opt ==2) ) then + chan_count=(my_head%nchan*(my_head%nchan+1))/2 + allocate(my_head%rsqrtinv(chan_count)) + my_head%rsqrtinv(1:chan_count)=rsqrtinv(1:chan_count) + my_head%use_corr_obs=.true. + end if + if(iinstr/=-1)then + if(allocated(rsqrtinv)) deallocate(rsqrtinv) + if(allocated(rinvdiag)) deallocate(rinvdiag) + endif + + my_head => null() + end if ! icc + endif ! (in_curbin) + +! Link obs to diagnostics structure + iii=0 + if (luse_obsdiag ) my_diagLL => odiagLL(ibin) + do ii=1,nchanl + m=ich(ii) + odiags(ii)%ptr => null() + + if (luse_obsdiag .and. (iuse_rad(m)>=1 .or. l4dvar .or. lobsdiagsave) )then + + nperobs=-99999; if(ii==1) nperobs=nchanl + my_diag => obsdiagLList_nextNode(my_diagLL, & + create = .not.lobsdiag_allocated, & + idv = is ,& + iob = ioid(n) ,& + ich = ii ,& + elat = data_s(ilate,n) ,& + elon = data_s(ilone,n) ,& + luse = luse(n) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + + odiags(ii)%ptr => my_diag ! track my_diag references + + ! Associate corresponding obs_diag pointer to the obsdiagLList structure + if(in_curbin.and.icc>0) then + my_head => tailNode_typecast_(radhead(ibin)) + if(.not.associated(my_head)) & + call die(myname,'unexpected, associated(my_head) =',associated(my_head)) + + muse_ii=varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1 + + call obsdiagNode_set(my_diag, wgtjo=wgtjo(ii), & + jiter=jiter, muse=muse_ii, nldepart=tbc0(ii) ) + +! Load data into output arrays + if (muse_ii) then + iii=iii+1 + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,ii,myname,'my_diag:my_head') + my_head%diags(iii)%ptr => my_diag + endif ! (varinv(ii)>tiny_r_kind) + + my_head => null() + endif ! (in_curbin.and.icc>0), for actual observations + endif ! (luse_obsdiag .and. (iuse_rad(m)>=1 .or. l4dvar .or. lobsdiagsave)) + enddo + if(in_curbin .and. luse_obsdiag) then + if(.not. retrieval.and.(iii/=icc)) then + write(6,*)'setuprad: error iii icc',iii,icc + call stop2(279) + endif + endif ! (in_curbin) + +! End of l_may_be_passive block + endif ! (l_may_by_passive) + + +! Load passive data into output arrays + if (passive_bc .and. (jiter>miter) .and. .not. retrieval) then + if(in_curbin) then + if(iccm > 0)then + allocate(my_headm) + call radNode_appendto(my_headm,radheadm(ibin)) + + my_headm%idv = is + my_headm%iob = ioid(n) + my_headm%elat= data_s(ilate,n) + my_headm%elon= data_s(ilone,n) + my_headm%isis = isis + !my_headm%isfctype = isfctype + my_headm%covtype = covtype + + allocate(my_headm%res(iccm),my_headm%err2(iccm), & + my_headm%raterr2(iccm),my_headm%pred(npred,iccm), & + my_headm%ich(iccm), & + my_headm%icx(iccm)) + + my_headm%nchan = iccm ! profile observation count + my_headm%time=dtime + my_headm%luse=luse(n) + my_headm%ich(:)=-1 + iii=0 + do ii=1,nchanl + m=ich(ii) + channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 + if (varinv(ii)>tiny_r_kind .and. channel_passive) then + + iii=iii+1 + my_headm%res(iii)=tbc(ii) ! obs-ges innovation + my_headm%err2(iii)=one/error0(ii)**2 ! 1/(obs error)**2 (original uninflated error) + my_headm%raterr2(iii)=error0(ii)**2*varinv(ii) ! (original error)/(inflated error) + my_headm%icx(iii)=m ! channel index + do k=1,npred + my_headm%pred(k,iii)=pred(k,ii)*upd_pred(k)*max(cld_rbc_idx(ii),cld_rbc_idx2(ii)) + end do + + my_headm%ich(iii)=ii + +! compute hessian contribution, +! skip rstats accumulation for channels without coef. initialization + if (newpc4pred .and. luse(n) .and. any(predx(:,m)/=zero)) then + do k=1,npred + rstats(k,m)=rstats(k,m)+my_headm%pred(k,iii) & + *my_headm%pred(k,iii)*varinv(ii) + end do + end if ! end of newpc4pred loop + + end if + end do + + if (iii /= iccm) then + write(6,*)'setuprad: error iii iccm',iii,iccm + call stop2(279) + endif + + my_headm%nchan = iii ! profile observation count + + my_headm => null() + end if ! + endif ! (in_curbin) + end if ! End of passive_bc block + + + if(in_curbin) then + +! Write diagnostics to output file. + if (rad_diagsave .and. luse(n) .and. nchanl_diag > 0) then + + if (binary_diag) call contents_binary_diag_(odiags(:),is,ioid(n)) + if (netcdf_diag) call contents_netcdf_diag_(odiags(:),is,ioid(n)) + + end if + endif ! (in_curbin) + + +! End of n-loop over obs + end do + +! If retrieval, close open bufr sst file (output) + if (retrieval.and.last_pass) call finish_sst_retrieval + +! Jump here when there is no data to process for current satellite +! Deallocate arrays + deallocate(diagbufchan) + deallocate(sc_index) + + if (rad_diagsave) then + if (netcdf_diag) call nc_diag_write + if(binary_diag) call final_binary_diag_ + if (lextra .and. allocated(diagbufex)) deallocate(diagbufex) + endif + + call destroy_crtm + +! End of routine + return + + contains + function tailNode_typecast_(oll) result(ptr_) +!> Cast the tailNode of oll to an radNode, as in +!> ptr_ => typecast_(tailNode_(oll)) + + use m_radNode , only: radNode , typecast_ => radNode_typecast + use m_obsLList, only: obsLList, tailNode_ => obsLList_tailNode + use m_obsNode , only: obsNode + implicit none + type(radNode ),pointer:: ptr_ + type(obsLList),target ,intent(in):: oll + + class(obsNode),pointer:: inode_ + inode_ => tailNode_(oll) + ptr_ => typecast_(inode_) + end function tailNode_typecast_ + + subroutine init_binary_diag_ + filex=obstype + write(string,1976) jiter +1976 format('_',i2.2) + diag_rad_file= trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // trim(string) + if(init_pass) then + open(4,file=trim(diag_rad_file),form='unformatted',status='unknown',position='rewind') + else + open(4,file=trim(diag_rad_file),form='unformatted',status='old',position='append') + endif + if (lextra) allocate(diagbufex(iextra,jextra)) + +! Initialize/write parameters for satellite diagnostic file on +! first outer iteration. + if (init_pass .and. mype==mype_diaghdr(is)) then + inewpc=0 + if (newpc4pred) inewpc=1 + write(4) isis,dplat(is),obstype,jiter,nchanl_diag,npred,ianldate,ireal_radiag,ipchan_radiag,iextra,jextra,& + idiag,angord,iversion_radiag,inewpc,ioff0,ijacob + write(6,*)'SETUPRAD: write header record for ',& + isis,npred,ireal_radiag,ipchan_radiag,iextra,jextra,idiag,angord,iversion_radiag,& + ' to file ',trim(diag_rad_file),' ',ianldate + do i=1,nchanl + n=ich(i) + if( n < 1 .or. (reduce_diag .and. iuse_rad(n) < 1))cycle + varch4=varch(n) + tlap4=tlapmean(n) + freq4=sc(sensorindex)%frequency(sc_index(i)) + pol4=sc(sensorindex)%polarization(sc_index(i)) + wave4=wavenumber(i) + write(4)freq4,pol4,wave4,varch4,tlap4,iuse_rad(n),& + nuchan(n),ich(i) + end do + endif + end subroutine init_binary_diag_ + subroutine init_netcdf_diag_ + character(len=80) string + filex=obstype + write(string,1976) jiter +1976 format('_',i2.2) + diag_rad_file= trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // trim(string) // '.nc4' + if(init_pass .and. nobs > 0) then +! open(4,file=trim(diag_rad_file),form='unformatted',status='unknown',position='rewind') + call nc_diag_init(diag_rad_file) + call nc_diag_chaninfo_dim_set(nchanl_diag) + else +! open(4,file=trim(diag_rad_file),form='unformatted',status='old',position='append') + endif + if (init_pass) then + inewpc=0 + if (newpc4pred) inewpc=1 + call nc_diag_header("Satellite_Sensor", isis ) + call nc_diag_header("Satellite", dplat(is) ) ! sat type + call nc_diag_header("Observation_type", obstype ) ! observation type + call nc_diag_header("Outer_Loop_Iteration", jiter) + call nc_diag_header("Number_of_channels", nchanl_diag ) ! number of channels in the sensor + call nc_diag_header("Number_of_Predictors", npred ) ! number of updating bias correction predictors + call nc_diag_header("date_time", ianldate ) ! time (yyyymmddhh) + call nc_diag_header("ireal_radiag", ireal_radiag ) + call nc_diag_header("ipchan_radiag", ipchan_radiag ) + call nc_diag_header("iextra", iextra ) + call nc_diag_header("jextra", jextra ) + call nc_diag_header("idiag", idiag ) + call nc_diag_header("angord", angord ) + call nc_diag_header("iversion_radiag", iversion_radiag) + call nc_diag_header("New_pc4pred", inewpc ) ! indicator of newpc4pred (1 on, 0 off) + call nc_diag_header("ioff0", ioff0 ) + call nc_diag_header("ijacob", ijacob ) +! call nc_diag_header("Number_of_state_vars", nsdim ) + call nc_diag_header("jac_nnz", nsigradjac) + call nc_diag_header("jac_nind", nvarjac) + +! call nc_diag_header("Outer_Loop_Iteration", headfix%jiter) +! call nc_diag_header("Satellite_Sensor", headfix%isis) +! call nc_diag_header("Satellite", headfix%id ) ! sat type +! call nc_diag_header("Observation_type", headfix%obstype ) ! observation type +! call nc_diag_header("Number_of_channels", headfix%nchan ) ! number of channels in the sensor +! call nc_diag_header("Number_of_Predictors", headfix%npred ) ! number of updating bias correction predictors +! call nc_diag_header("date_time", headfix%idate ) ! time (yyyymmddhh) + + ! channel block +! call nc_diag_chaninfo_dim_set(nchanl) + + + do i=1,nchanl + n=ich(i) + if( n < 1 .or. (reduce_diag .and. iuse_rad(n) < 1))cycle + varch4=varch(n) + tlap4=tlapmean(n) + freq4=sc(sensorindex)%frequency(i) + pol4=sc(sensorindex)%polarization(i) + wave4=wavenumber(i) + call nc_diag_chaninfo("chaninfoidx", i ) + call nc_diag_chaninfo("frequency", sc(sensorindex)%frequency(i) ) + call nc_diag_chaninfo("polarization", sc(sensorindex)%polarization(i) ) + call nc_diag_chaninfo("wavenumber", wavenumber(i) ) + call nc_diag_chaninfo("error_variance", varch(n) ) + call nc_diag_chaninfo("mean_lapse_rate", tlapmean(n) ) + call nc_diag_chaninfo("use_flag", iuse_rad(n) ) + call nc_diag_chaninfo("sensor_chan", nuchan(n) ) + call nc_diag_chaninfo("satinfo_chan", ich(i) ) + end do + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiags,idv,iob) + type(fptr_obsdiagNode),dimension(:):: odiags + integer(i_kind),intent(in):: idv,iob + + character(len=*),parameter:: myname_=myname//"::contents_binary_diag_" + type(obs_diag),pointer:: obsptr + + diagbuf(1) = cenlat ! observation latitude (degrees) + diagbuf(2) = cenlon ! observation longitude (degrees) + diagbuf(3) = zsges ! model (guess) elevation at observation location + + diagbuf(4) = dtime-time_offset ! observation time (hours relative to analysis time) + + diagbuf(5) = data_s(iscan_pos,n) ! sensor scan position + diagbuf(6) = zasat*rad2deg ! satellite zenith angle (degrees) + diagbuf(7) = data_s(ilazi_ang,n) ! satellite azimuth angle (degrees) + diagbuf(8) = pangs ! solar zenith angle (degrees) + diagbuf(9) = data_s(isazi_ang,n) ! solar azimuth angle (degrees) + diagbuf(10) = sgagl ! sun glint angle (degrees) (sgagl) + + diagbuf(11) = surface(1)%water_coverage ! fractional coverage by water + diagbuf(12) = surface(1)%land_coverage ! fractional coverage by land + diagbuf(13) = surface(1)%ice_coverage ! fractional coverage by ice + diagbuf(14) = surface(1)%snow_coverage ! fractional coverage by snow + if(.not. retrieval)then + diagbuf(15) = surface(1)%water_temperature ! surface temperature over water (K) + diagbuf(16) = surface(1)%land_temperature ! surface temperature over land (K) + diagbuf(17) = surface(1)%ice_temperature ! surface temperature over ice (K) + diagbuf(18) = surface(1)%snow_temperature ! surface temperature over snow (K) + diagbuf(19) = surface(1)%soil_temperature ! soil temperature (K) + if (gmi .or. saphir) then + diagbuf(20) = gwp ! graupel water path + else + diagbuf(20) = surface(1)%soil_moisture_content ! soil moisture + endif + +! For IR instruments NPOESS land types are applied. +! For microwave instruments the CRTM land_type field is not +! applied, but from a nomenclature standpoint land_type +! is interchangeable with vegetation_type. + diagbuf(21) = surface(1)%land_type ! surface land type + else + diagbuf(15) = tsavg5 ! SST first guess used for SST retrieval + diagbuf(16) = sstcu ! NCEP SST analysis at t + diagbuf(17) = sstph ! Physical SST retrieval + diagbuf(18) = sstnv ! Navy SST retrieval + diagbuf(19) = dta ! d(ta) corresponding to sstph + diagbuf(20) = dqa ! d(qa) corresponding to sstph + diagbuf(21) = dtp_avh ! data type + endif + if(radmod%lcloud_fwd .and. sea) then + diagbuf(22) = scat ! scattering index from AMSU-A + diagbuf(23) = clw_guess ! integrated CLWP (kg/m**2) from background + else + diagbuf(22) = surface(1)%vegetation_fraction ! vegetation fraction + diagbuf(23) = surface(1)%snow_depth ! snow depth + endif + diagbuf(24) = surface(1)%wind_speed ! surface wind speed (m/s) + +! Note: The following quantities are not computed for all sensors + if (.not.microwave) then + diagbuf(25) = cld ! cloud fraction (%) + diagbuf(26) = cldp ! cloud top pressure (hPa) + else + if((radmod%lcloud_fwd .and. sea) .or. gmi .or. amsr2) then + diagbuf(25) = clw_obs ! clw (kg/m**2) from retrievals + diagbuf(26) = clw_guess_retrieval ! retrieved CLWP (kg/m**2) from simulated BT + else + diagbuf(25) = clw_obs ! cloud liquid water (kg/m**2) + diagbuf(26) = tpwc_obs ! total column precip. water (km/m**2) + endif + endif + +! For NST + if (nstinfo==0) then + diagbuf(27) = r_missing + diagbuf(28) = r_missing + diagbuf(29) = r_missing + diagbuf(30) = r_missing + else + diagbuf(27) = data_s(itref,n) + diagbuf(28) = data_s(idtw,n) + diagbuf(29) = data_s(idtc,n) + diagbuf(30) = data_s(itz_tr,n) + endif + + if (lwrite_peakwt) then + do i=1,nchanl_diag + diagbufex(1,i)=weightmax(ich_diag(i)) ! press. at max of weighting fn (mb) + end do + if (goes_img) then + do i=1,nchanl_diag + diagbufex(2,i)=tb_obs_sdv(ich_diag(i)) + end do + end if + else if (goes_img .and. .not.lwrite_peakwt) then + do i=1,nchanl_diag + diagbufex(1,i)=tb_obs_sdv(ich_diag(i)) + end do + end if + + do i=1,nchanl_diag + diagbufchan(1,i)=tb_obs(ich_diag(i)) ! observed brightness temperature (K) + diagbufchan(2,i)=tbc0(ich_diag(i)) ! observed - simulated Tb with bias corrrection (K) + diagbufchan(3,i)=tbcnob(ich_diag(i)) ! observed - simulated Tb with no bias correction (K) + errinv = sqrt(varinv0(ich_diag(i))) + diagbufchan(4,i)=errinv ! inverse observation error + useflag=one + if (iuse_rad(ich(ich_diag(i))) < 1) useflag=-one + diagbufchan(5,i)= id_qc(ich_diag(i))*useflag ! quality control mark or event indicator + + if (radmod%lcloud_fwd) then + ! diagbufchan(6,i)=error0(ich_diag(i)) + diagbufchan(6,i)=tcc(ich_diag(i)) + else + diagbufchan(6,i)=emissivity(ich_diag(i)) ! surface emissivity + endif + if(abi) diagbufchan(6,i)=data_s(32+i,n) ! temporarily store BT stdev + diagbufchan(7,i)=tlapchn(ich_diag(i)) ! stability index + if (radmod%lcloud_fwd) then + if (radmod%lcloud_fwd .and. gmi .and. cld_rbc_idx(ich_diag(i)) == zero) then + diagbufchan(8,i)= -9999.0_r_kind ! index used in off-line scan angle B + else + diagbufchan(8,i)=cld_rbc_idx(ich_diag(i)) ! indicator of cloudy consistency + endif + else + diagbufchan(8,i)=ts(ich_diag(i)) ! d(Tb)/d(Ts) + end if + + if (lwrite_predterms) then + predterms=zero + do j = 1,npred + predterms(j) = pred(j,ich_diag(i)) + end do + predterms(npred+1) = cbias(nadir,ich(ich_diag(i))) + + do j=1,npred+2 + diagbufchan(ipchan_radiag+j,i)=predterms(j) ! Tb bias correction terms (K) + end do + else ! Default to write out predicted bias + do j=1,npred+2 + diagbufchan(ipchan_radiag+j,i)=predbias(j,ich_diag(i)) ! Tb bias correction terms (K) + end do + end if + diagbufchan(ipchan_radiag+npred+3,i) = 1.e+10_r_single ! spread (filled in by EnKF) + + ioff = ioff0 + if (save_jacobian) then + j = 1 + do ii = 1, nvarjac + state_ind = getindex(svars3d, radjacnames(ii)) + if (state_ind < 0) state_ind = getindex(svars2d,radjacnames(ii)) + if (state_ind < 0) then + print *, 'Error: no variable ', radjacnames(ii), ' in state vector. Exiting.' + call stop2(1300) + endif + if ( radjacnames(ii) == 'u' .or. radjacnames(ii) == 'v') then + dhx_dx%st_ind(ii) = sum(levels(1:state_ind-1)) + 1 + dhx_dx%end_ind(ii) = sum(levels(1:state_ind-1)) + 1 + dhx_dx%val(j) = jacobian( radjacindxs(ii) + 1, ich_diag(i)) + j = j + 1 + else if (radjacnames(ii) == 'sst') then + dhx_dx%st_ind(ii) = sum(levels(1:ns3d)) + state_ind + dhx_dx%end_ind(ii) = sum(levels(1:ns3d)) + state_ind + dhx_dx%val(j) = jacobian( radjacindxs(ii) + 1, ich_diag(i)) + j = j + 1 + else + dhx_dx%st_ind(ii) = sum(levels(1:state_ind-1)) + 1 + dhx_dx%end_ind(ii) = sum(levels(1:state_ind-1)) + nsig + do jj = 1, nsig + dhx_dx%val(j) = jacobian( radjacindxs(ii) + jj,ich_diag(i)) + j = j + 1 + enddo + endif + enddo + + call writearray(dhx_dx, diagbufchan(ioff+1:idiag,i)) + ioff = ioff+size(dhx_dx) + endif + + + end do + + if (luse_obsdiag .and. lobsdiagsave) then + if (l_may_be_passive) then + do ii=1,nchanl_diag + obsptr => odiags(ich_diag(ii))%ptr + + if (.not.associated(obsptr)) then + write(6,*)'setuprad: error of null obsptr',ii,ich_diag(ii) + call stop2(280) + end if + + ! double check + call obsdiagNode_assert(obsptr,idv,iob,ich_diag(ii), & + myname_,'obsptr::(idv,iob,ich_diag(ii)') + + do jj=1,miter + ioff=ioff+1 + if (obsptr%muse(jj)) then + diagbufchan(ioff,ich_diag(ii)) = one + else + diagbufchan(ioff,ich_diag(ii)) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + diagbufchan(ioff,ich_diag(ii)) = obsptr%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + diagbufchan(ioff,ich_diag(ii)) = obsptr%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + diagbufchan(ioff,ich_diag(ii)) = obsptr%obssen(jj) + enddo + + enddo + obsptr => null() + else + diagbufchan(ioff+1:ioff+4*miter+1,1:nchanl_diag) = zero + endif + endif + + if (.not.lextra) then + write(4) diagbuf,diagbufchan + else + write(4) diagbuf,diagbufchan,diagbufex + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiags,idv,iob) + type(fptr_obsdiagNode),dimension(:),intent(in):: odiags + integer(i_kind),intent(in):: idv,iob + + character(len=*),parameter:: myname_=myname//"::contents_netcdf_diag_" + type(obs_diag),pointer:: obsptr ! not yet in use + ! obsptr => odiags(ich_diag(i)); for i=1,nchanl_diag + +! Observation class + character(7),parameter :: obsclass = ' rad' + real(r_single),parameter:: missing = -9.99e9_r_single + integer(i_kind),parameter:: imissing = -999999 + real(r_kind),dimension(:),allocatable :: predbias_angord + + if (adp_anglebc) then + allocate(predbias_angord(angord) ) + predbias_angord = zero + endif + + do i=1,nchanl_diag + call nc_diag_metadata("Channel_Index", i ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Latitude", sngl(cenlat) ) ! observation latitude (degrees) + call nc_diag_metadata("Longitude", sngl(cenlon) ) ! observation longitude (degrees) + + call nc_diag_metadata("Elevation", sngl(zsges) ) ! model (guess) elevation at observation location + + call nc_diag_metadata("Obs_Time", sngl(dtime-time_offset) ) ! observation time (hours relative to analysis time) + + call nc_diag_metadata("Scan_Position", sngl(data_s(iscan_pos,n)) ) ! sensor scan position + call nc_diag_metadata("Sat_Zenith_Angle", sngl(zasat*rad2deg) ) ! satellite zenith angle (degrees) + call nc_diag_metadata("Sat_Azimuth_Angle", sngl(data_s(ilazi_ang,n)) ) ! satellite azimuth angle (degrees) + call nc_diag_metadata("Sol_Zenith_Angle", sngl(pangs) ) ! solar zenith angle (degrees) + call nc_diag_metadata("Sol_Azimuth_Angle", sngl(data_s(isazi_ang,n)) ) ! solar azimuth angle (degrees) + call nc_diag_metadata("Sun_Glint_Angle", sngl(sgagl) ) ! sun glint angle (degrees) (sgagl) + + call nc_diag_metadata("Water_Fraction", sngl(surface(1)%water_coverage) ) ! fractional coverage by water + call nc_diag_metadata("Land_Fraction", sngl(surface(1)%land_coverage) ) ! fractional coverage by land + call nc_diag_metadata("Ice_Fraction", sngl(surface(1)%ice_coverage) ) ! fractional coverage by ice + call nc_diag_metadata("Snow_Fraction", sngl(surface(1)%snow_coverage) ) ! fractional coverage by snow + + if(.not. retrieval)then + call nc_diag_metadata("Water_Temperature", sngl(surface(1)%water_temperature) ) ! surface temperature over water (K) + call nc_diag_metadata("Land_Temperature", sngl(surface(1)%land_temperature) ) ! surface temperature over land (K) + call nc_diag_metadata("Ice_Temperature", sngl(surface(1)%ice_temperature) ) ! surface temperature over ice (K) + call nc_diag_metadata("Snow_Temperature", sngl(surface(1)%snow_temperature) ) ! surface temperature over snow (K) + call nc_diag_metadata("Soil_Temperature", sngl(surface(1)%soil_temperature) ) ! soil temperature (K) + call nc_diag_metadata("Soil_Moisture", sngl(surface(1)%soil_moisture_content) ) ! soil moisture + call nc_diag_metadata("Land_Type_Index", surface(1)%land_type ) ! surface land type + call nc_diag_metadata("tsavg5", missing ) ! SST first guess used for SST retrieval + call nc_diag_metadata("sstcu", missing ) ! NCEP SST analysis at t + call nc_diag_metadata("sstph", missing ) ! Physical SST retrieval + call nc_diag_metadata("sstnv", missing ) ! Navy SST retrieval + call nc_diag_metadata("dta", missing ) ! d(ta) corresponding to sstph + call nc_diag_metadata("dqa", missing ) ! d(qa) corresponding to sstph + call nc_diag_metadata("dtp_avh", missing ) ! data type + else + call nc_diag_metadata("Water_Temperature", missing ) ! surface temperature over water (K) + call nc_diag_metadata("Land_Temperature", missing ) ! surface temperature over land (K) + call nc_diag_metadata("Ice_Temperature", missing ) ! surface temperature over ice (K) + call nc_diag_metadata("Snow_Temperature", missing ) ! surface temperature over snow (K) + call nc_diag_metadata("Soil_Temperature", missing ) ! soil temperature (K) + call nc_diag_metadata("Soil_Moisture", missing ) ! soil moisture + call nc_diag_metadata("Land_Type_Index", imissing ) ! surface land type + call nc_diag_metadata("tsavg5", sngl(tsavg5) ) ! SST first guess used for SST retrieval + call nc_diag_metadata("sstcu", sngl(sstcu) ) ! NCEP SST analysis at t + call nc_diag_metadata("sstph", sngl(sstph) ) ! Physical SST retrieval + call nc_diag_metadata("sstnv", sngl(sstnv) ) ! Navy SST retrieval + call nc_diag_metadata("dta", sngl(dta) ) ! d(ta) corresponding to sstph + call nc_diag_metadata("dqa", sngl(dqa) ) ! d(qa) corresponding to sstph + call nc_diag_metadata("dtp_avh", sngl(dtp_avh) ) ! data type + endif + + call nc_diag_metadata("Vegetation_Fraction", sngl(surface(1)%vegetation_fraction) ) + call nc_diag_metadata("Snow_Depth", sngl(surface(1)%snow_depth) ) + call nc_diag_metadata("tpwc", sngl(tpwc_obs) ) + call nc_diag_metadata("clw_guess_retrieval", sngl(clw_guess_retrieval) ) + + call nc_diag_metadata("Sfc_Wind_Speed", sngl(surface(1)%wind_speed) ) + call nc_diag_metadata("Cloud_Frac", sngl(cld) ) + call nc_diag_metadata("CTP", sngl(cldp) ) + call nc_diag_metadata("CLW", sngl(clw_obs) ) + call nc_diag_metadata("TPWC", sngl(tpwc_obs) ) + call nc_diag_metadata("clw_obs", sngl(clw_obs) ) + call nc_diag_metadata("clw_guess", sngl(clw_guess) ) + + if (nstinfo==0) then + data_s(itref,n) = missing + data_s(idtw,n) = missing + data_s(idtc,n) = missing + data_s(itz_tr,n) = missing + endif + + call nc_diag_metadata("Foundation_Temperature", sngl(data_s(itref,n)) ) ! reference temperature (Tr) in NSST + call nc_diag_metadata("SST_Warm_layer_dt", sngl(data_s(idtw,n)) ) ! dt_warm at zob + call nc_diag_metadata("SST_Cool_layer_tdrop", sngl(data_s(idtc,n)) ) ! dt_cool at zob + call nc_diag_metadata("SST_dTz_dTfound", sngl(data_s(itz_tr,n)) ) ! d(Tz)/d(Tr) + + call nc_diag_metadata("Observation", sngl(tb_obs(ich_diag(i))) ) ! observed brightness temperature (K) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(tbc0(ich_diag(i) )) ) ! observed - simulated Tb with bias corrrection (K) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(tbcnob(ich_diag(i))) ) ! observed - simulated Tb with no bias correction (K) + errinv = sqrt(varinv0(ich_diag(i))) + call nc_diag_metadata("Inverse_Observation_Error", sngl(errinv) ) + if (save_jacobian) then + j = 1 + do ii = 1, nvarjac + state_ind = getindex(svars3d, radjacnames(ii)) + if (state_ind < 0) state_ind = getindex(svars2d,radjacnames(ii)) + if (state_ind < 0) then + print *, 'Error: no variable ', radjacnames(ii), ' in state vector. Exiting.' + call stop2(1300) + endif + if ( radjacnames(ii) == 'u' .or. radjacnames(ii) == 'v') then + dhx_dx%st_ind(ii) = sum(levels(1:state_ind-1)) + 1 + dhx_dx%end_ind(ii) = sum(levels(1:state_ind-1)) + 1 + dhx_dx%val(j) = jacobian( radjacindxs(ii) + 1, ich_diag(i)) + j = j + 1 + else if (radjacnames(ii) == 'sst') then + dhx_dx%st_ind(ii) = sum(levels(1:ns3d)) + state_ind + dhx_dx%end_ind(ii) = sum(levels(1:ns3d)) + state_ind + dhx_dx%val(j) = jacobian( radjacindxs(ii) + 1, ich_diag(i)) + j = j + 1 + else + dhx_dx%st_ind(ii) = sum(levels(1:state_ind-1)) + 1 + dhx_dx%end_ind(ii) = sum(levels(1:state_ind-1)) + nsig + do jj = 1, nsig + dhx_dx%val(j) = jacobian( radjacindxs(ii) + jj,ich_diag(i)) + j = j + 1 + enddo + endif + enddo + + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind) + call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind) + call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val,r_single)) + endif + + useflag=one + if (iuse_rad(ich(ich_diag(i))) < 1) useflag=-one + + call nc_diag_metadata("QC_Flag", sngl(id_qc(ich_diag(i))*useflag) ) ! quality control mark or event indicator + + call nc_diag_metadata("Emissivity", sngl(emissivity(ich_diag(i))) ) ! surface emissivity + call nc_diag_metadata("Weighted_Lapse_Rate", sngl(tlapchn(ich_diag(i))) ) ! stability index + call nc_diag_metadata("dTb_dTs", sngl(ts(ich_diag(i))) ) ! d(Tb)/d(Ts) + + call nc_diag_metadata("BC_Constant", sngl(predbias(1,ich_diag(i))) ) ! constant bias correction term + call nc_diag_metadata("BC_Scan_Angle", sngl(predbias(2,ich_diag(i))) ) ! scan angle bias correction term + call nc_diag_metadata("BC_Cloud_Liquid_Water", sngl(predbias(3,ich_diag(i))) ) ! CLW bias correction term + call nc_diag_metadata("BC_Lapse_Rate_Squared", sngl(predbias(4,ich_diag(i))) ) ! square lapse rate bias correction term + call nc_diag_metadata("BC_Lapse_Rate", sngl(predbias(5,ich_diag(i))) ) ! lapse rate bias correction term + call nc_diag_metadata("BC_Cosine_Latitude_times_Node", sngl(predbias(6,ich_diag(i))) ) ! node*cos(lat) bias correction term + call nc_diag_metadata("BC_Sine_Latitude", sngl(predbias(7,ich_diag(i))) ) ! sin(lat) bias correction term + call nc_diag_metadata("BC_Emissivity", sngl(predbias(8,ich_diag(i))) ) ! emissivity sensitivity bias correction term + call nc_diag_metadata("BC_Fixed_Scan_Position", sngl(predbias(npred+1,ich_diag(i))) ) ! external scan angle + if (lwrite_predterms) then + call nc_diag_metadata("BCPred_Constant", sngl(pred(1,ich_diag(i))) ) ! constant bias correction term + call nc_diag_metadata("BCPred_Scan_Angle", sngl(pred(2,ich_diag(i))) ) ! scan angle bias correction term + call nc_diag_metadata("BCPred_Cloud_Liquid_Water", sngl(pred(3,ich_diag(i))) ) ! CLW bias correction term + call nc_diag_metadata("BCPred_Lapse_Rate_Squared", sngl(pred(4,ich_diag(i))) ) ! square lapse rate bias correction term + call nc_diag_metadata("BCPred_Lapse_Rate", sngl(pred(5,ich_diag(i))) ) ! lapse rate bias correction term + call nc_diag_metadata("BCPred_Cosine_Latitude_times_Node", sngl(pred(6,ich_diag(i))) ) ! node*cos(lat) bias correction term + call nc_diag_metadata("BCPred_Sine_Latitude", sngl(pred(7,ich_diag(i))) ) ! sin(lat) bias correction term + call nc_diag_metadata("BCPred_Emissivity", sngl(pred(8,ich_diag(i))) ) ! emissivity sensitivity bias correction term + endif + + if (lwrite_peakwt) then + call nc_diag_metadata("Press_Max_Weight_Function", sngl(weightmax(ich_diag(i))) ) + endif + if (adp_anglebc) then + do j=1, angord + predbias_angord(j) = predbias(npred-angord+j, ich_diag(i) ) + end do + call nc_diag_data2d("BC_angord", sngl(predbias_angord) ) + if (lwrite_predterms) then + do j=1, angord + predbias_angord(j) = pred(npred-angord+j, ich_diag(i) ) + end do + call nc_diag_data2d("BCPred_angord", sngl(predbias_angord) ) + endif + end if + + enddo +! if (adp_anglebc) then + if (.true.) then + deallocate(predbias_angord) + endif + end subroutine contents_netcdf_diag_ + + subroutine final_binary_diag_ + close(4) + end subroutine final_binary_diag_ + end subroutine setuprad +end module rad_setup diff --git a/src/setupref.f90 b/src/gsi/setupref.f90 similarity index 89% rename from src/setupref.f90 rename to src/gsi/setupref.f90 index dd6930442..b4d4265fc 100644 --- a/src/setupref.f90 +++ b/src/gsi/setupref.f90 @@ -1,4 +1,11 @@ -subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pass) +module gpsref_setup + implicit none + private + public:: setup + interface setup; module procedure setupref; end interface + +contains +subroutine setupref(obsLL,odiagLL,lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pass,conv_diagsave) !$$$ subprogram documentation block ! . . . . ! subprogram: setupref compute rhs of oi for gps refractivity @@ -102,6 +109,8 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting ! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) ! . removed (%dlat,%dlon) debris. +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). ! ! input argument list: ! lunin - unit from which to read observations @@ -117,17 +126,24 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa ! machine: ibm RS/6000 SP ! !$$$ - use mpeu_util, only: die,perr + use mpeu_util, only: die,perr,getindex use kinds, only: r_kind,i_kind use m_gpsStats, only: gps_allhead,gps_alltail - use m_obsdiags, only: gpshead + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + use obsmod, only: nprof_gps,& - i_gps_ob_type,obsdiags,lobsdiagsave,nobskeep,lobsdiag_allocated,& - time_offset + lobsdiagsave,nobskeep,lobsdiag_allocated,& + time_offset,lobsdiag_forenkf use m_obsNode, only: obsNode use m_gpsNode, only: gpsNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag + use m_gpsNode, only: gpsNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag use gsi_4dvar, only: nobs_bins,hr_obsbin use guess_grids, only: ges_lnprsi,hrdifsig,geop_hgti,geop_hgtl,nfldsig,& gpstop @@ -137,9 +153,9 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa use constants, only: zero,one,two,eccentricity,semi_major_axis,& grav_equator,somigliana,flattening,grav_ratio,grav,rd,eps,& three,four,five,half,r0_01 - use jfunc, only: jiter,miter + use jfunc, only: jiter,miter,jiterstart use convinfo, only: cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use m_dtime, only: dtime_setup, dtime_check, dtime_show + use m_dtime, only: dtime_setup, dtime_check use m_gpsrhs, only: muse use m_gpsrhs, only: termq use m_gpsrhs, only: termpk,termpl1,termpl2 @@ -155,8 +171,10 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa use m_gpsrhs, only: gpsrhs_aliases use m_gpsrhs, only: gpsrhs_unaliases + use state_vectors, only: levels, svars3d use gsi_bundlemod, only : gsi_bundlegetpointer use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use sparsearr, only: sparr2, new, size, writearray implicit none @@ -176,12 +194,16 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa real(r_kind),parameter:: crit_grad = 157.0_r_kind ! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork real(r_kind),dimension(max(1,nprof_gps)),intent(inout) :: toss_gps_sub integer(i_kind) ,intent(in ) :: is ! ndat index logical ,intent(in ) :: init_pass ! the pass with the first set of background bins logical ,intent(in ) :: last_pass ! the pass with all background bins processed + logical, intent(in):: conv_diagsave ! save diagnostics file ! Declare external calls for code analysis external:: tintrp2a1,tintrp2a11 @@ -211,23 +233,27 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa integer(i_kind),dimension(4):: gps_ij integer(i_kind):: satellite_id,transmitter_id + type(sparr2) :: dhx_dx + integer(i_kind) :: iz, t_ind, q_ind, p_ind, nnz, nind + logical,dimension(nobs):: luse integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed + logical proceed, save_jacobian logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node type(gpsNode),pointer:: my_head type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL real(r_kind),allocatable,dimension(:,:,: ) :: ges_z real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q - n_alloc(:)=0 - m_alloc(:)=0 + type(obsLList),pointer,dimension(:):: gpshead + gpshead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + !******************************************************************************* ! List of GPS RO satellites and corresponding BUFR id !740 => COSMIC FM1 @@ -285,9 +311,15 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa call init_vars_ ! Allocate arrays for output to diagnostic file - mreal=21 + mreal=22 nreal=mreal if (lobsdiagsave) nreal=nreal+4*miter+1 + if (save_jacobian) then + nnz = nsig * 3 ! number of non-zero elements in dH(x)/dx profile + nind = 3 ! number of dense subarrays + call new(dhx_dx, nnz, nind) + nreal = nreal + size(dhx_dx) + endif if(init_pass) call gpsrhs_alloc(is,'ref',nobs,nsig,nreal,-1,-1) call gpsrhs_aliases(is) @@ -492,6 +524,7 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa rdiagbuf(9,i) = elev-zsges ! height above model terrain (m) rdiagbuf(11,i) = data(iuse,i) ! data usage flag rdiagbuf(19,i) = hobl ! model vertical grid (midpoint) + rdiagbuf(22,i) = 1.e+10_r_kind ! spread (filled in by EnKF) if (ratio_errors(i) > tiny_r_kind) then ! obs inside vertical grid @@ -727,7 +760,6 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa end do endif ! (last_pass) - ! Loop to load arrays used in statistics output call dtime_setup() do i=1,nobs @@ -739,6 +771,7 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa if (ratio_errors(i)*data(ier,i) <= tiny_r_kind) muse(i) = .false. ikx=nint(data(ikxx,i)) dtime=data(itime,i) + ! flags for observations that failed qc checks ! zero = observation is good @@ -786,66 +819,26 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa endif IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + ! Link obs to diagnostics structure if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_gps_ob_type,ibin)%head)) then - obsdiags(i_gps_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_gps_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupref: failure to allocate obsdiags',istat - call stop2(282) - end if - obsdiags(i_gps_ob_type,ibin)%tail => obsdiags(i_gps_ob_type,ibin)%head - else - allocate(obsdiags(i_gps_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupref: failure to allocate obsdiags',istat - call stop2(283) - end if - obsdiags(i_gps_ob_type,ibin)%tail => obsdiags(i_gps_ob_type,ibin)%tail%next - end if - obsdiags(i_gps_ob_type,ibin)%n_alloc = obsdiags(i_gps_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_gps_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_gps_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_gps_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_gps_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_gps_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_gps_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_gps_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_gps_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_gps_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_gps_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_gps_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_gps_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_gps_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_gps_ob_type,ibin)%tail)) then - obsdiags(i_gps_ob_type,ibin)%tail => obsdiags(i_gps_ob_type,ibin)%head - else - obsdiags(i_gps_ob_type,ibin)%tail => obsdiags(i_gps_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_gps_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_gps_ob_type,ibin)%tail)') - end if - if (obsdiags(i_gps_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupref: index error' - call stop2(284) - end if - endif + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) endif if(last_pass) then - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_gps_ob_type,ibin)%tail%muse(nobskeep) + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) ! Save values needed for generation of statistics for all observations if(.not. associated(gps_allhead(ibin)%head))then @@ -883,17 +876,17 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa ! Fill obs diagnostics structure if (luse_obsdiag) then - obsdiags(i_gps_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_gps_ob_type,ibin)%tail%nldepart(jiter)=data(igps,i) - obsdiags(i_gps_ob_type,ibin)%tail%wgtjo=(data(ier,i)*ratio_errors(i))**2 + call obsdiagNode_set(my_diag, wgtjo=(data(ier,i)*ratio_errors(i))**2, & + jiter=jiter, muse=muse(i), nldepart=data(igps,i)) endif ! Load additional obs diagnostic structure ioff=mreal if (lobsdiagsave) then + associate(odiag => my_diag) do jj=1,miter ioff=ioff+1 - if (obsdiags(i_gps_ob_type,ibin)%tail%muse(jj)) then + if (odiag%muse(jj)) then rdiagbuf(ioff,i) = one else rdiagbuf(ioff,i) = -one @@ -901,16 +894,17 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa enddo do jj=1,miter+1 ioff=ioff+1 - rdiagbuf(ioff,i) = obsdiags(i_gps_ob_type,ibin)%tail%nldepart(jj) + rdiagbuf(ioff,i) = odiag%nldepart(jj) enddo do jj=1,miter ioff=ioff+1 - rdiagbuf(ioff,i) = obsdiags(i_gps_ob_type,ibin)%tail%tldepart(jj) + rdiagbuf(ioff,i) = odiag%tldepart(jj) enddo do jj=1,miter ioff=ioff+1 - rdiagbuf(ioff,i) = obsdiags(i_gps_ob_type,ibin)%tail%obssen(jj) + rdiagbuf(ioff,i) = odiag%obssen(jj) enddo + end associate ! (odiag => my_diag) endif do j=1,nreal @@ -923,10 +917,7 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa if ( in_curbin .and. muse(i) ) then allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(gpshead(ibin),my_node) - my_node => null() + call gpsNode_appendto(my_head,gpshead(ibin)) my_head%idv = is my_head%iob = ioid(i) @@ -971,6 +962,7 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa my_head%jac_p(j)=my_head%jac_p(j)-termpl2(j,i) end do end if + ! delz=dpres-float(k1) kl=dpresl(i) k1l=min(max(1,kl),nsig) @@ -989,18 +981,44 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa my_head%pg = cvar_pg(ikx) my_head%luse = luse(i) - if (luse_obsdiag) then - my_head%diags => obsdiags(i_gps_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) + if (save_jacobian) then + + t_ind = getindex(svars3d, 'tv') + q_ind = getindex(svars3d, 'q') + p_ind = getindex(svars3d, 'prse') + if (t_ind < 0) then + print *, 'Error: no variable tv in state vector. Exiting.' + call stop2(1300) + endif + if (q_ind < 0) then + print *, 'Error: no variable q in state vector. Exiting.' + call stop2(1300) endif + if (p_ind < 0) then + print *, 'Error: no variable prse in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = sum(levels(1:t_ind-1)) + 1 + dhx_dx%end_ind(1) = sum(levels(1:t_ind-1)) + nsig + dhx_dx%st_ind(2) = sum(levels(1:q_ind-1)) + 1 + dhx_dx%end_ind(2) = sum(levels(1:q_ind-1)) + nsig + dhx_dx%st_ind(3) = sum(levels(1:p_ind-1)) + 1 + dhx_dx%end_ind(3) = sum(levels(1:p_ind-1)) + nsig + + do iz = 1, nsig + dhx_dx%val(iz) = my_head%jac_t(iz) + dhx_dx%val(iz+nsig) = my_head%jac_q(iz) + dhx_dx%val(iz+2*nsig) = my_head%jac_p(iz) + enddo + + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal, i)) + ioff = ioff + size(dhx_dx) + endif + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1, myname,'my_diag:my_head') + my_head%diags => my_diag endif my_head => null() @@ -1016,7 +1034,6 @@ subroutine setupref(lunin,mype,awork,nele,nobs,toss_gps_sub,is,init_pass,last_pa data_ihgt(:)=data(ihgt,:) data_igps(:)=data(igps,:) - call dtime_show(myname,'diagsave:ref',i_gps_ob_type) call gpsrhs_unaliases(is) if(last_pass) call gpsrhs_dealloc(is) @@ -1114,3 +1131,4 @@ subroutine final_vars_ end subroutine final_vars_ end subroutine setupref +end module gpsref_setup diff --git a/src/gsi/setuprhsall.f90 b/src/gsi/setuprhsall.f90 new file mode 100644 index 000000000..2a06e9551 --- /dev/null +++ b/src/gsi/setuprhsall.f90 @@ -0,0 +1,658 @@ +subroutine setuprhsall(ndata,mype,init_pass,last_pass) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuprhsall sets up rhs of oi +! prgmmr: derber org: np23 date: 2003-05-22 +! +! abstract: This routine sets up the right hand side (rhs) of the +! analysis equation. Functions performed in this routine +! include: +! a) calculate increments between current solutions and obs, +! b) generate statistical summaries of quality control and innovations, +! c) generate diagnostic files (optional), and +! d) prepare/save information for use in inner minimization loop +! +! program history log: +! 2003-05-22 derber +! 2003-12-23 kleist - ozone calculation modified to use guess pressure +! 2004-06-17 treadon - update documentation +! 2004-07-23 derber - modify to include conventional sst +! 2004-07-29 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - increase dimension of work arrays for nonlin qc +! 2004-12-08 xu li - replace local logical flag retrieval with that in radinfo +! 2004-12-22 treadon - restructure code to compute and write out +! innovation information on select outer iterations +! 2005-01-20 okamoto - add ssmi/amsre/ssmis +! 2005-03-30 lpchang - statsoz call was passing ozmz var unnecessarily +! 2005-04-18 treadon - deallocate fbias +! 2005-05-27 derber - level output change +! 2005-07-06 derber - include mhs and hirs/4 +! 2005-06-14 wu - add OMI oz +! 2005-07-27 derber - add print of monitoring and reject data +! 2005-09-28 derber - simplify data file info handling +! 2005-10-20 kazumori - modify for real AMSR-E data process +! 2005-12-01 cucurull - add GPS bending angle +! 2005-12-21 treadon - modify processing of GPS data +! 2006-01-09 derber - move create/destroy array, compute_derived, q_diag +! from glbsoi outer loop into this routine +! 2006-01-12 treadon - add channelinfo +! 2006-02-03 derber - modify for new obs control and obs count- clean up! +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-03-21 treadon - add code to generate optional observation perturbations +! 2006-07-28 derber - modify code for new inner loop obs data structure +! 2006-07-29 treadon - remove create_atm_grids and destroy_atm_grids +! 2006-07-31 kleist - change call to atm arrays routines +! 2007-02-21 sienkiewicz - add MLS ozone changes +! 2007-03-01 treadon - add toss_gps and toss_gps_sub +! 2007-03-10 su - move the observation perturbation to each setup routine +! 2007-03-19 tremolet - Jo table +! 2007-06-05 tremolet - add observation diagnostics structure +! 2007-06-08 kleist/treadon - add prefix (task id or path) to diag_conv_file +! 2007-07-09 tremolet - observation sensitivity +! 2007-06-20 cucurull - changes related to gps diagnostics +! 2007-06-29 jung - change channelinfo to array +! 2007-09-30 todling - add timer +! 2007-10-03 todling - add observer split option +! 2007-12-15 todling - add prefix to diag filenames +! 2008-03-28 wu - move optional randon seed for perturb_obs to read_obs +! 2008-04-14 treadon - remove super_gps, toss_gps (moved into genstats_gps) +! 2008-05-23 safford - rm unused vars and uses +! 2008-12-08 todling - move 3dprs/geop-hght calculation from compute_derivate into here +! 2009-01-17 todling - update interface to intjo +! 2009-03-05 meunier - add call to lagragean operator +! 2009-08-19 guo - moved all rhs related statistics variables to m_rhs +! for multi-pass setuprhsall(); +! - added control arguments init_pass and last_pass for +! multi-pass setuprhsall(). +! 2009-09-14 guo - invoked compute_derived() even under lobserver. This is +! the right way to do it. It trigged moving of statments +! from glbsoi() to observer_init(). +! - cleaned up redandent calls to setupyobs() and inquire_obsdiags(). +! 2009-10-22 shen - add high_gps and high_gps_sub +! 2009-12-08 guo - fixed diag_conv output rewind while is not init_pass, with open(position='rewind') +! 2010-04-09 cucurull - remove high_gps and high_gps_sub +! 2010-04-01 tangborn - start adding call for carbon monoxide data. +! 2010-04-28 zhu - add ostats and rstats for additional precoditioner +! 2010-05-28 todling - obtain variable id's on the fly (add getindex) +! 2010-10-14 pagowski - added pm2_5 conventional obs +! 2010-10-20 hclin - added aod +! 2011-02-16 zhu - add gust,vis,pblh +! 2011-04-07 todling - newpc4pred now in radinfo +! 2011-09-17 todling - automatic sizes definition for mpi-reduce calls +! 2012-01-11 Hu - add load_gsdgeop_hgt to compute 2d subdomain pbl heights from the guess fields +! 2012-04-08 Hu - add code to skip the observations that are not used in minimization +! 2013-02-22 Carley - Add call to load_gsdgeop_hgt for NMMB/WRF-NMM if using +! PBL pseudo obs +! 2013-10-19 todling - metguess now holds background +! 2013-05-24 zhu - add ostats_t and rstats_t for aircraft temperature bias correction +! 2014-03-19 pondeca - add wspd10m +! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl +! 2014-05-07 pondeca - add howv +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2014-0?-16 carley/zhu - add tcamt and lcbas +! 2015-07-10 pondeca - add cldch +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-05 pondeca - add uwnd10m, vwund10m +! 2017-05-12 Y. Wang and X. Wang - add dbz for reflectivity DA. POC: xuguang.wang@ou.edu +! 2018-01-01 Apodaca - add GOES/GLM lightning +! 2018-02-15 wu - add code for fv3_regional +! 2018-08-10 guo - replaced type specific setupXYZ() calls with a looped +! polymorphic implementation using %setup(). +! 2019-03-15 Ladwig - add option for cloud analysis in observer +! 2019-03-28 Ladwig - add metar cloud obs as pseudo water vapor in var analysis +! +! input argument list: +! ndata(*,1)- number of prefiles retained for further processing +! ndata(*,2)- number of observations read +! ndata(*,3)- number of observations keep after read +! mype - mpi task id +! +! output argument list: +! +! +! comments: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_quad,r_single + use constants, only: zero,one,fv,zero_quad + use guess_grids, only: load_prsges,load_geop_hgt,load_gsdpbl_hgt + use guess_grids, only: ges_tsen,nfldsig + use obsmod, only: nsat1,iadate,& + ndat,obs_setup,& + dtype,& + dirname,write_diag,lobserver,& + destroyobs,lobskeep,nobskeep,lobsdiag_allocated, & + luse_obsdiag + use obsmod, only: lobsdiagsave + use obsmod, only: binary_diag + use obs_sensitivity, only: lobsensfc, lsensrecompute + use obs_sensitivity, only: obsensCounts_realloc + use radinfo, only: newpc4pred + use radinfo, only: mype_rad,jpch_rad,retrieval,fbias,npred,ostats,rstats + use aircraftinfo, only: aircraft_t_bc_pof,aircraft_t_bc,ostats_t,rstats_t,npredt,ntail + use ozinfo, only: mype_oz,jpch_oz,ihave_oz + use coinfo, only: mype_co,jpch_co,ihave_co + use lightinfo, only: mype_light + use mpimod, only: ierror,mpi_comm_world,mpi_rtype,mpi_sum + use gridmod, only: twodvar_regional,wrf_mass_regional,nems_nmmb_regional + use gridmod, only: cmaq_regional,fv3_regional + use gsi_4dvar, only: nobs_bins,l4dvar + use gsi_4dvar, only: mPEs_observer + use jfunc, only: jiter,jiterstart,miter,first,last + use qcmod, only: npres_print + use convinfo, only: nconvtype,diag_conv + use timermod, only: timer_ini,timer_fnl + use lag_fields, only: lag_presetup,lag_state_write,lag_state_read,lag_destroy_uv + use mpeu_util, only: getindex + use mpl_allreducemod, only: mpl_allreduce + use berror, only: reset_predictors_var + use rapidrefresh_cldsurf_mod, only: l_PBL_pseudo_SurfobsT,l_PBL_pseudo_SurfobsQ,& + l_PBL_pseudo_SurfobsUV,i_gsdcldanal_type,& + i_cloud_q_innovation + use m_rhs, only: rhs_alloc + use m_rhs, only: rhs_dealloc + use m_rhs, only: rhs_allocated + use m_rhs, only: awork => rhs_awork + use m_rhs, only: bwork => rhs_bwork + use m_rhs, only: aivals => rhs_aivals + use m_rhs, only: stats => rhs_stats + use m_rhs, only: stats_co => rhs_stats_co + use m_rhs, only: stats_oz => rhs_stats_oz + use m_rhs, only: toss_gps_sub => rhs_toss_gps + + use m_rhs, only: i_ps,i_uv,i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag, & + i_gust,i_vis,i_pblh,i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv, & + i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp + use m_rhs, only: i_dbz + use m_rhs, only: i_light + + use m_gpsStats, only: gpsStats_genstats ! was genstats_gps() + use m_gpsStats, only: gpsStats_destroy ! was done by genstats_gps() + + use gsi_bundlemod, only: GSI_BundleGetPointer + use gsi_metguess_mod, only: GSI_MetGuess_Bundle + use m_obsdiags, only: obsdiags + use m_obsdiags, only: obsdiags_reset + use m_obsdiags, only: obsdiags_read + use m_obsdiags, only: obsdiags_sort + use m_obsdiags, only: obsdiags_write + use m_obsdiags, only: inquire_obsdiags => obsdiags_inquire + + use gsi_obOperTypeManager, only: obOper_typeIndex + use gsi_obOperTypeManager, only: nobs_type => obOper_count + use gsi_obOper, only: obOper + use m_obsdiags, only: obOpers_config + use m_obsdiags, only: obOper_create + use m_obsdiags, only: obOper_destroy + use m_obsdiagNode, only: obsdiagLList_rewind + + use mpeu_util, only: die,warn,perr + use mpeu_util, only: basename + implicit none + +! Declare passed variables + integer(i_kind) ,intent(in ) :: mype + integer(i_kind),dimension(ndat,3),intent(in ) :: ndata + logical ,intent(in ) :: init_pass, last_pass ! state of "setup" processing + + +! Declare external calls for code analysis + external:: compute_derived + external:: evaljo + !external:: genstats_gps + external:: mpi_allreduce + external:: mpi_finalize + external:: mpi_reduce + !external:: read_obsdiags + external:: statsconv + external:: statsoz + external:: statspcp + external:: statsrad + external:: statslight + external:: stop2 + external:: w3tage + +! Delcare local variables + logical:: conv_diagsave,llouter,getodiag + + character(80):: string + character(10)::obstype + character(20)::isis + character(128):: diag_conv_file + character(len=12) :: clfile + + integer(i_kind):: lunin,is,idate + integer(i_kind):: iobs,nprt,ii,jj + integer(i_kind):: it,ier,istatus + integer(i_kind):: nreal,nchanl + + real(r_quad):: zjo + real(r_kind),dimension(40,ndat):: aivals1 + real(r_kind),dimension(7,jpch_rad):: stats1 + real(r_kind),dimension(9,jpch_oz):: stats_oz1 + real(r_kind),dimension(9,jpch_co):: stats_co1 + real(r_kind),dimension(npres_print,nconvtype,5,3):: bwork1 + real(r_kind),allocatable,dimension(:,:):: awork1 + + real(r_kind),dimension(:,:,:),pointer:: ges_tv_it=>NULL() + real(r_kind),dimension(:,:,:),pointer:: ges_q_it =>NULL() + character(len=*),parameter:: myname='setuprhsall' + + logical,parameter:: OBSDIAGS_RELOAD = .false. + !logical,parameter:: OBSDIAGS_RELOAD = .true. + logical:: opened + character(len=256):: tmpname,tmpaccess,tmpform + + class(obOper),pointer:: is_obOper + + if(.not.init_pass .and. .not.lobsdiag_allocated) call die('setuprhsall','multiple lobsdiag_allocated',lobsdiag_allocated) +!****************************************************************************** +! Initialize timer + call timer_ini('setuprhsall') + +! Because I have to make a test + luse_obsdiag = luse_obsdiag .or. OBSDIAGS_RELOAD + +! Initialize variables and constants. + first = jiter == jiterstart ! .true. on first outer iter + last = jiter == miter+1 ! .true. following last outer iter + llouter=.true. + +! Set diagnostic output flag + + conv_diagsave = write_diag(jiter) .and. diag_conv + + if(.not.rhs_allocated) call rhs_alloc() + allocate(awork1,mold=awork) + +! Reset observation pointers + if(init_pass) then + ! setuprhsall() has been implemented to allow multiple passes over the + ! same observation input steams, such that an outer loop can be used to + ! iterate through incrementally available forecast states at different + ! times. In each iteration ("pass"), only a subset of observations with + ! valid forecast states are computed for their innovations and linear + ! observation-operators. + ! + ! init_pass is a flag marking the first pass of setuprhsall() for a + ! given jiter (a single outloop interaction is assumed with an update- + ! to-date state, where some initialization code are involked. And + ! last_pass is a flag marking the last pass, where some summary code are + ! involked. + ! + ! This feature is needed in particular for high resolution background + ! states for non-linear observation operator calculations (setup-calls), + ! often refered as the "split-observer" mode. In this mode, preloading + ! of the forecast states of all time steps, is often not practical. + + call obOpers_config() + + call destroyobs() ! remaining object, obsmod::nobs_sub(:,:) + call obsensCounts_realloc(nobs_type,nobs_bins) + +!++ call obOpers_reset(jiter,luse_obsdiag=luse_obsdiag,obsdiags_keep=lobsdiagsave) ! replacing destroyobs() + call obsdiags_reset(obsdiags_keep=lobsdiagsave) ! replacing destroyobs() + +! Read observation diagnostics if available + if (l4dvar) then + getodiag=(.not.lobserver) .or. (lobserver.and.jiter>1) + clfile='obsdiags.ZZZ' + if (lobsensfc .and. .not.lsensrecompute) then + write(clfile(10:12),'(I3.3)') miter + call obsdiags_read(clfile,mPEs=mPEs_observer,jiter_expected=miter) ! replacing read_obsdiags() + call inquire_obsdiags(miter) + else if (getodiag) then + if (.not.lobserver) then + write(clfile(10:12),'(I3.3)') jiter + call obsdiags_read(clfile,mPEs=mPEs_observer,jiter_expected=jiter) ! replacing read_obsdiags() + call inquire_obsdiags(miter) + endif + endif + endif + + if (jiter>1.and.lobskeep) then + nobskeep=1 + else + nobskeep=0 + endif + endif ! + +! The 3d pressure and geopotential grids are initially loaded at +! the end of the call to read_guess. Thus, we don't need to call +! load_prsges and load_geop_hgt on the first outer loop. We need +! to update these 3d pressure arrays on all subsequent outer loops. +! Hence, the conditional call to load_prsges and load_geop_hgt + + if (lobserver .or. jiter>jiterstart) then + +! Get sensible temperature (after bias correction's been applied) + do it=1,nfldsig + ier=0 + call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'tv',ges_tv_it,istatus);ier=ier+istatus + call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'q' ,ges_q_it ,istatus);ier=ier+istatus + if(ier/=0) exit + ges_tsen(:,:,:,it)= ges_tv_it(:,:,:)/(one+fv*max(zero,ges_q_it(:,:,:))) + enddo + +! Load 3d subdomain pressure arrays from the guess fields + call load_prsges + +! Compute 3d subdomain geopotential heights from the guess fields + call load_geop_hgt + +! if (sfcmod_gfs .or. sfcmod_mm5) then +! if (mype==0) write(6,*)'COMPUTE_DERIVED: call load_fact10' +! call load_fact10 +! endif + endif + +! Compute 2d subdomain pbl heights from the guess fields + if (wrf_mass_regional) then + call load_gsdpbl_hgt(mype) + else if (nems_nmmb_regional .or. fv3_regional) then + if (l_PBL_pseudo_SurfobsT .or. l_PBL_pseudo_SurfobsQ .or. l_PBL_pseudo_SurfobsUV) then + call load_gsdpbl_hgt(mype) + end if + endif + + +! Compute derived quantities on grid + if(.not.cmaq_regional) call compute_derived(mype,init_pass) + + ! ------------------------------------------------------------------------ + + if ( (l4dvar.and.lobserver) .or. .not.l4dvar ) then + + ! Init for Lagrangian data assimilation (gather winds and NL integration) + call lag_presetup() + ! Save state for inner loop if in 4Dvar observer mode + if (l4dvar.and.lobserver) then + call lag_state_write() + end if + +! Reset observation pointers. This is assumed by setup*() routines. + do ii=1,size(obsdiags,2) + do jj=1,size(obsdiags,1) + call obsdiagLList_rewind(obsdiags(jj,ii)) + enddo + enddo + + lunin=1 + open(lunin,file=obs_setup,form='unformatted') + rewind lunin + + +! If requested, create conventional diagnostic files + if(conv_diagsave.and.binary_diag)then + write(string,900) jiter +900 format('conv_',i2.2) + diag_conv_file=trim(dirname) // trim(string) + if(init_pass) then + open(7,file=trim(diag_conv_file),form='unformatted',status='unknown',position='rewind') + + else + ! open(7,file=trim(diag_conv_file),form='unformatted',status='old',position='append') + + ! Without a close(7) until the last_pass=.true., the same file + ! is expected to remain open "asis", equivalent to an "append" + ! position through a re-open(). Therefore, a sequence of + ! verification steps are taken to replace the earlier open() + ! statement, to avoid re-open() without a close(). + + inquire(unit=7,opened=opened) + if(opened) then + inquire(unit=7,name=tmpname,form=tmpform,access=tmpaccess) + tmpname=basename(tmpname) + if(trim(tmpname)/=trim(diag_conv_file)) then + call perr(myname,'unexpectly occupied, unit =',7) + call perr(myname,' diag_conv_file =',trim(diag_conv_file)) + call perr(myname,' inquire(unit=7, name= )',trim(tmpname)) + call perr(myname,' inquire(unit=7, form= )',trim(tmpform)) + call perr(myname,' inquire(unit=7,access= )',trim(tmpaccess)) + call die(myname) + endif + + else + call perr(myname,'unexpectly closed, unit =',7) + call perr(myname,' diag_conv_file =',trim(diag_conv_file)) + call die(myname) + endif + endif + idate=iadate(4)+iadate(3)*100+iadate(2)*10000+iadate(1)*1000000 + if(init_pass .and. mype == 0)write(7)idate + end if + + if (newpc4pred) then + ostats=zero + rstats=zero_quad + end if + + if (aircraft_t_bc_pof .or. aircraft_t_bc) then + ostats_t=zero_quad + rstats_t=zero_quad + end if + +! Loop over data types to process (for polymorphic obOper%setup() calls) + do is=1,ndat + + ! Skip data streams where no obOper has been implemented for now. + ! These streams are handled in a "lazy" approach, to preserve its + ! current behavior of the program. + ! + ! (1) If present in distributed obs_setup streams, they will be + ! processed, by sequantially skipping corresponding records + ! with possible exceptions (error messages). + ! + ! (2) If not expected to be present in distributed obs_setup streams, + ! A warning message body for exceptions will be issued. And + ! the program will proceed as normal. + + select case(trim(dtype(is))) + case('gos_ctp', 'rad_ref', 'lghtn', 'larccld', 'larcglb') + ! Exception (1) (see above) + + if(nsat1(is)>0)then + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) then + call perr(myname,'unexpected obs_setup read(1), iostat =',ier) + call perr(myname,' is =',is) + call perr(myname,' ndat1(is) =',nsat1(is)) + call perr(myname,' dtype(is) =',trim(dtype(is))) + call die(myname) + endif + + read(lunin,iostat=ier) + if(ier/=0) then + call perr(myname,'unexpected obs_setup read(2), iostat =',ier) + call perr(myname,' is =',is) + call perr(myname,' ndat1(is) =',nsat1(is)) + call perr(myname,' dtype(is) =',trim(dtype(is))) + call perr(myname,' obstype =',trim(obstype)) + call perr(myname,' isis =',trim(isis)) + call perr(myname,' nreal =',nreal) + call perr(myname,' nchanl =',nchanl) + call die(myname) + endif + endif + + case default + + is_obOper => obOper_create(dtype(is)) + + if(associated(is_obOper)) then + call is_obOper%setup(lunin,mype, is, nsat1(is), init_pass,last_pass) + call obOper_destroy(is_obOper) + + else + ! Exception (2) (see above) + call warn(myname,'unexpected obOper, is =',is) + call warn(myname,' dtype =',trim(dtype(is))) + call warn(myname,' obOper_typeIndex =',obOper_typeIndex(dtype(is))) + endif + end select + + end do + close(lunin) + + ! run cloud analysis in observer + if(i_gsdcldanal_type==7) then + call gsdcloudanalysis(mype) + ! Write output analysis files + call write_all(-1,mype) + call prt_guess('analysis') + endif + + else + + ! Init for Lagrangian data assimilation (read saved parameters) + call lag_state_read() + + endif ! < lobserver > + lobsdiag_allocated=.true. + + if(.not.last_pass) then + call timer_fnl('setuprhsall') + return + ! So the rest code are for the last_pass only + endif + +! Deallocate wind field array for Lagrangian data assimilation + call lag_destroy_uv() + +! Finalize qc and accumulate statistics for GPSRO data + call gpsStats_genstats(bwork,awork(:,i_gps),toss_gps_sub,conv_diagsave,mype) + call gpsStats_destroy() ! replacing ... + ! -- call genstats_gps(bwork,awork(1,i_gps),toss_gps_sub,conv_diagsave,mype) + + if (conv_diagsave.and.binary_diag) close(7) + + ! Sorting with obsdiags_sort() would let the contents of obsdiags, including + ! linked-lists of obsNodes as well as obs_diags, to be sorted into + ! the same sequences, regardless their processing orders, number of + ! processors, or particular distributions. + ! + ! For ob. operators not implemented to support multi-setups using + ! luse_obsdiag, sorting could become a problem. Among them, cases of + ! l_PBL_pseudo_SurfobsT, l_PBL_pseudo_SurfobsQ, and l_PBL_pseudo_SurfobsUV + ! have been fixed since, but it might be better to keep it simple for + ! those applications. The case of i_cloud_q_innovation==2 is new. It is + ! not sure why it won't work even in case of .not.luse_obsdiag. + + if(.not.(l_PBL_pseudo_SurfobsT .or. l_PBL_pseudo_SurfobsQ .or. & + l_PBL_pseudo_SurfobsUV .or. (i_cloud_q_innovation==2)) ) then + call obsdiags_sort() + endif + +! for temporary testing purposes, _write and _read. + if(OBSDIAGS_RELOAD) then + call obsdiags_write('obsdiags.ttt',force=.true.) + ! call Barrier() before obsdiags_read(), to make sure all PEs have + ! finished their obsdiags_write(). + if(mPEs_observer>0) call MPI_Barrier(mpi_comm_world,ier) + + call obsdiags_read('obsdiags.ttt',mPEs=mPEs_observer,force=.true.) + call inquire_obsdiags(miter) + endif + +! call inquire_obsdiags(miter) + +! Collect information for preconditioning + if (newpc4pred) then + call mpl_allreduce(jpch_rad,rpvals=ostats) + call mpl_allreduce(npred,jpch_rad,rstats) + end if + +! Collect information for aircraft data + if (aircraft_t_bc_pof .or. aircraft_t_bc) then +! call mpl_allreduce(npredt,max_tail,ostats_t) +! call mpl_allreduce(npredt,max_tail,rstats_t) + call mpl_allreduce(npredt,ntail,ostats_t) + call mpl_allreduce(npredt,ntail,rstats_t) + end if + + if (newpc4pred .or. aircraft_t_bc_pof .or. aircraft_t_bc) then + call reset_predictors_var + end if + +! Collect satellite and precip. statistics + call mpi_reduce(aivals,aivals1,size(aivals1),mpi_rtype,mpi_sum,mype_rad, & + mpi_comm_world,ierror) + + call mpi_reduce(stats,stats1,size(stats1),mpi_rtype,mpi_sum,mype_rad, & + mpi_comm_world,ierror) + + if (ihave_oz) call mpi_reduce(stats_oz,stats_oz1,size(stats_oz1),mpi_rtype,mpi_sum,mype_oz, & + mpi_comm_world,ierror) + + if (ihave_co) call mpi_reduce(stats_co,stats_co1,size(stats_co1),mpi_rtype,mpi_sum,mype_co, & + mpi_comm_world,ierror) + +! Collect conventional data statistics + + call mpi_allreduce(bwork,bwork1,size(bwork1),mpi_rtype,mpi_sum,& + mpi_comm_world,ierror) + + call mpi_allreduce(awork,awork1,size(awork1),mpi_rtype,mpi_sum, & + mpi_comm_world,ierror) + +! Compute and print statistics for radiance, precipitation, and ozone data. +! These data types are NOT processed when running in 2dvar mode. Hence +! the check on the 2dvar flag below. + + if ( (l4dvar.and.lobserver) .or. .not.l4dvar ) then + + if (.not.twodvar_regional) then + +! Compute and print statistics for radiance data + if(mype==mype_rad) call statsrad(aivals1,stats1,ndata) + +! Compute and print statistics for precipitation data + if(mype==mype_rad) call statspcp(aivals1,ndata) + +! Compute and print statistics for ozone + if (mype==mype_oz .and. ihave_oz) call statsoz(stats_oz1,ndata) + +! Compute and print statistics for carbon monoxide +!???? if (mype==mype_co .and. ihave_co) call statsco(stats_co1,bwork1,awork1(1,i_co),ndata) + + endif + +! Compute and print statistics for "conventional" data + call statsconv(mype,& + i_ps,i_uv,i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag, & + i_gust,i_vis,i_pblh,i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv, & + i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp,i_dbz, & + size(awork1,2),bwork1,awork1,ndata) + +! Compute and print statistics for "lightning" data + if (mype==mype_light) call statslight(mype,i_light,bwork1,awork1,size(awork1,2),ndata) + + endif ! < .not. lobserver > + + deallocate(awork1) + call rhs_dealloc() ! destroy the workspace: awork, bwork, etc. +! Print Jo table + nprt=2 + llouter=.true. + if(luse_obsdiag)call evaljo(zjo,iobs,nprt,llouter) + +! If only performing sst retrieval, end program execution + if(retrieval)then + deallocate(fbias) + if(mype==0)then + write(6,*)'SETUPRHSALL: normal completion for retrieval' + call w3tage('GLOBAL_SSI') + end if + call mpi_finalize(ierror) + stop + end if + +! Finalize timer + call timer_fnl('setuprhsall') + + return +end subroutine setuprhsall diff --git a/src/gsi/setuprw.f90 b/src/gsi/setuprw.f90 new file mode 100644 index 000000000..88a9e9baa --- /dev/null +++ b/src/gsi/setuprw.f90 @@ -0,0 +1,1249 @@ +module rw_setup + implicit none + private + public:: setup + interface setup; module procedure setuprw; end interface + +contains +subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuprw compute rhs of oi for radar radial winds +! prgmmr: parrish org: np22 date: 1990-10-06 +! +! abstract: For radar radial wind observations, this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 1990-10-06 parrish +! 1998-04-10 weiyu yang +! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-17 treadon - update documentation +! 2004-08-02 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - increase size of rwork array for nonlinear qc +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list +! 2005-03-02 dee - remove garbage from diagnostic file +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-05-27 derber - level output change +! 2005-07-27 derber - add print of monitoring and reject data +! 2005-09-28 derber - combine with prep,spr,remove tran and clean up +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2005-11-03 treadon - correct error in index values for data array +! 2005-11-29 derber - remove psfcg and use ges_lnps instead +! 2006-01-31 todling/treadon - store wgt/wgtlim in rdiagbuf(6,ii) +! 2006-02-02 treadon - rename lnprsl as ges_lnprsl +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-04-21 parrish - new forward model based on beam vertical uncertainty +! 2006-05-23 parrish - use model terrain at station location for zsges +! 2006-05-30 su,derber,treadon - modify diagnostic output +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - unify NL qc +! 2006-07-31 kleist - use ges_ps instead of lnps +! 2006-08-28 su - fix a bug in variational qc +! 2008-05-23 safford - rm unused vars and uses +! 2008-12-03 todling - changed handle of tail%time +! 2009-02-17 tong - modifed to use airborne radar data +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). +! 2011-03-28 s.liu - add subtype to radial wind +! 2011-05-25 s.liu/parrish - correct error in height assigned to radial wind +! 2012-02-08 wu - bug fix to keep from using below ground radar obs, with extra printout +! added to identify which obs are below ground. +! 2013-01-22 parrish - change grdcrd to grdcrd1, tintrp2a to tintrp2a1, tintrp2a11, +! tintrp3 to tintrp31 (so debug compile works on WCOSS) +! 2013-01-22 parrish - WCOSS debug compile execution error rwgt not assigned a value. +! set rwgt = 1 at beginning of obs loop. +! 2013-02-15 parrish - WCOSS debug compile execution error, k1=k2 but data(iobs_type,i) <=3, causes 0./0. +! 2013-06-07 tong - add a factor to adjust tdr obs gross error and add an option to adjust +! tdr obs error +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-06-23 lippi - Add vertical velocity to observation operator. Now, +! costilt is multiplied here instead of factored into wij. +! nml option include_w is used. Add a conditional to use +! maginnov and magoberr parameters from single ob namelist. +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! 2016-02-15 Johnson, Y. Wang, X. Wang - Develop the radial velocity +! operator by including vetical velocity and +! considering the terminal velocity of +! target hydrometeors (Johnson et al. +! 2015 MWR; Wang and Wang 2016 MWR) +! POC: xuguang.wang@ou.edu +! 2019-07-11 todling - introduced wrf_vars_mod (though truly not needed) +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,lobsdiag_forenkf,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,& + if_vterminal, ens_hx_dbz_cut, if_model_dbz, & + doradaroneob,oneobddiff,oneobvalue, if_vrobs_raw + use obsmod, only: netcdf_diag, binary_diag, dirname,ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use m_obsNode, only: obsNode + use m_rwNode, only: rwNode + use m_rwNode, only: rwNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin + use qcmod, only: npres_print,ptop,pbot,tdrerr_inflate + use guess_grids, only: hrdifsig,geop_hgtl,nfldsig,& + ges_lnprsl,sfcmod_gfs,sfcmod_mm5,comp_fact10, ges_tsen, ges_rho + use gridmod, only: nsig,get_ijk + use constants, only: flattening,semi_major_axis,grav_ratio,zero,grav,wgtlim,& + half,one,two,grav_equator,eccentricity,somigliana,rad2deg,deg2rad + use constants, only: tiny_r_kind,cg_term,huge_single,r2000,three,one + use jfunc, only: jiter,last,miter,jiterstart + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use setupdbz_lib, only:hx_dart + use sparsearr, only: sparr2, new, size, writearray, fullarray + use state_vectors, only: nsdim + use obsmod, only: l2rwthin + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + + +! Declare local parameters + real(r_kind),parameter:: r0_001 = 0.001_r_kind + real(r_kind),parameter:: r8 = 8.0_r_kind + real(r_kind),parameter:: ten = 10.0_r_kind + real(r_kind),parameter:: r200 = 200.0_r_kind + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: tintrp31 + external:: grdcrd1 + external:: stop2 + +! Declare local variables + real(r_kind) rlow,rhgh,rsig + real(r_kind) dz,factelv,factdif + real(r_kind) dlnp,pobl,zob + real(r_kind) sin2,termg,termr,termrg + real(r_kind) psges,zsges,zsges0 + real(r_kind),dimension(nsig):: zges,hges,ugesprofile,vgesprofile + real(r_kind),dimension(nsig):: wgesprofile!,vTgesprofile,refgesprofile + real(r_kind) prsltmp(nsig) + real(r_kind) sfcchk + real(r_kind) residual,obserrlm,obserror,ratio,scale,val2 + real(r_kind) ress,ressw + real(r_kind) val,valqc,rwgt + real(r_kind) cg_w,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2 + real(r_double) rstation_id + real(r_kind) dlat,dlon,dtime,dpres,ddiff,error,slat + real(r_kind) qrgesin,qsgesin,qggesin,rhogesin,tempgesin, rhogesin0 + real(r_kind) rdBZ, vterminal,dbzgesin + real(r_kind) sinazm,cosazm,sintilt,costilt,cosazm_costilt,sinazm_costilt + real(r_kind) ratio_errors,qcgross + real(r_kind) ugesin,vgesin,wgesin,factw,skint,sfcr + real(r_kind) rwwind,presw + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + integer(i_kind) i,nchar,nreal,k,j,k1,ii + integer(i_kind) mm1,jj,k2,isli + integer(i_kind) jsig,ikxx,nn,ibin,ioff,ioff0 + integer(i_kind) ier,ilat,ilon,ihgt,irwob,ikx,itime,iuse + integer(i_kind):: ielev,id,itilt,iazm,ilone,ilate,irange + integer(i_kind):: izsges,ier2,idomsfc,isfcr,iskint,iff10,iobs_type + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical debugging + logical proceed + logical include_w + + equivalence(rstation_id,station_id) + real(r_kind) addelev,wrange,beamdepth,elevtop,elevbot + integer(i_kind) kbeambot,kbeamtop,kbeamdiffmax,kbeamdiffmin + real(r_kind) uminmin,umaxmax + integer(i_kind) numequal,numnotequal,kminmin,kmaxmax + real(r_kind) rwwindprofile + + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + integer(i_kind) :: nnz, nind + + logical:: in_curbin, in_anybin, save_jacobian + type(rwNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + character(len=*),parameter:: myname='setuprw' + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_w + + real(r_kind),allocatable,dimension(:,:,:,: ) :: ges_qr + real(r_kind),allocatable,dimension(:,:,:,: ) :: ges_qs + real(r_kind),allocatable,dimension(:,:,:,: ) :: ges_qg + real(r_kind),allocatable,dimension(:,:,:,: ) :: ges_dbz + + type(obsLList),pointer,dimension(:):: rwhead + rwhead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf +! Check to see if required guess fields are available + call check_vars_(proceed,include_w) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!******************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ihgt=4 ! index of obs elevation + irwob=5 ! index of radial wind observation + iazm=6 ! index of azimuth angle in data array + itime=7 ! index of observation time in data array + ikxx=8 ! index of obs type in data array + itilt=9 ! index of tilt angle in data array + ielev=10 ! index of radar elevation + id=11 ! index of station id + iuse=12 ! index of use parameter + idomsfc=13 ! index of dominant surface type + iskint=14 ! index of surface skin temperature + iff10=15 ! index of 10 meter wind factor + isfcr=16 ! index of surface roughness + ilone=17 ! index of longitude (degrees) + ilate=18 ! index of latitude (degrees) + irange=19 ! index of range in km of obs from radar + izsges=20 ! index of model (guess) elevation for radar associated with vad wind + ier2=21 ! index of original-original obs error + iobs_type=22 + + numequal=0 + numnotequal=0 + + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + ii=0 + nchar=1 + ioff0=24 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (save_jacobian) then + nnz = 0 + nind = 0 + call new(dhx_dx, nnz, nind) + nreal = nreal + size(dhx_dx) + endif + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + if(netcdf_diag) call init_netcdf_diag_ + end if + + mm1=mype+1 + scale=one + rsig=nsig + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + kbeamdiffmin=huge(kbeamdiffmin) + kbeamdiffmax=-huge(kbeamdiffmax) + + call dtime_setup() + do i=1,nobs + rwgt=one + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + dpres=data(ihgt,i) + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + slat=data(ilate,i)*deg2rad + wrange=data(irange,i) + zsges0=data(izsges,i) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Interpolate log(surface pressure), +! log(pres) at mid-layers, and geopotenital height to +! observation location. + + factw=data(iff10,i) + if(sfcmod_gfs .or. sfcmod_mm5) then + sfcr=data(isfcr,i) + skint=data(iskint,i) + isli=data(idomsfc,i) + call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) + end if + + call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + if(zsges>=dpres)then + write(6,*) 'SETUPRW: zsges = ',zsges,'is greater than dpres ',dpres,'. Rejecting ob.' + cycle + endif + dpres=dpres-zsges + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a1(geop_hgtl,hges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + +! Convert geopotential height at layer midpoints to geometric height using +! equations (17, 20, 23) in MJ Mahoney's note "A discussion of various +! measures of altitude" (2001). Available on the web at +! http://mtp.jpl.nasa.gov/notes/altitude/altitude.html +! +! termg = equation 17 +! termr = equation 21 +! termrg = first term in the denominator of equation 23 +! zges = equation 23 + sin2 = sin(slat)*sin(slat) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do k=1,nsig + zges(k) = (termr*hges(k)) / (termrg-hges(k)) ! eq (23) + end do + +! Given observation height, (1) adjust 10 meter wind factor if +! necessary, (2) convert height to grid relative units, (3) compute +! compute observation pressure (for diagnostic purposes only), and +! (4) compute location of midpoint of first model layer above surface +! in grid relative units + +! Adjust 10m wind factor if necessary. Rarely do we have a +! lidar obs within 10 meters of the surface. Almost always, +! the code below resets the 10m wind factor to 1.0 i.e., no +! reduction in wind speed due to surface friction). + if (dpresk1) then !???????????? to fix problem where k1=k2, which should only happen if k1=k2=nsig + dz = zges(k2)-zges(k1) + dlnp = prsltmp(k2)-prsltmp(k1) + pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1)) + else + write(6,*)' iobs_type,data(iobs_type,i),k,k1,k2,nsig,zob,zges(k1),prsltmp(k1)=',& ! diagnostic only?????????????? + iobs_type,data(iobs_type,i),k,k1,k2,nsig,zob,zges(k1),prsltmp(k1) + pobl = prsltmp(k1) + end if + + presw = ten*exp(pobl) + +! Determine location in terms of grid units for midpoint of +! first layer above surface + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp,nsig,-1) + +! Check to see if observation is below midpoint of first +! above surface layer. If so, set rlow to that difference + rlow=max(sfcchk-dpres,zero) + +! Check to see if observation is above midpoint of layer +! at the top of the model. If so, set rhgh to that difference. + rhgh=max(dpres-r0_001-nsig,zero) + +! Increment obs counter along with low and high obs counters + if(luse(i))then + awork(1)=awork(1)+one + if(rhgh/=zero) awork(2)=awork(2)+one + if(rlow/=zero) awork(3)=awork(3)+one + end if + +! Adjust observation error. + +! Increase error for observations over high topography + factelv=one + if (data(iobs_type,i) <= three) then + if (data(ielev,i) > r2000) then + factelv=(r2000/data(ielev,i))**2 + if(luse(i))awork(5) = awork(5) + one + endif + endif + +! Increase error if model and observation topography too different + factdif=one + if (data(iobs_type,i) <= three) then + if (abs(zsges0-data(ielev,i)) > r200) then + factdif= (r200/(abs(zsges0-data(ielev,i))))**2 + if(luse(i))awork(6) = awork(6) + one + endif + endif + +! Obtain estimated beam spread in vertical + if (data(iobs_type,i) <= three) then + addelev=max(half*abs(zsges0-data(ielev,i)),ten*wrange) + else + addelev=17.4*wrange ! TDR radar beam width is 1.9 to 2.0 degree + endif + beamdepth=two*addelev + elevtop=zob+addelev ! this is based on 100ft/Nm = 16.5m/km beam spread + elevbot=zob-addelev ! for .95 deg beam angle (multiplied by 1.2 to allow + ! for propagation uncertainty) + ! also, a minimum uncertainty based on difference between + ! model surface elevation and actual radar elevation + ! for TDR radars, beam width is 1.9 for NOAA Parabolic + ! and 2.0 degree for French dual-plate + + call grdcrd1(elevtop,zges,nsig,1) + call grdcrd1(elevbot,zges,nsig,1) + kbeamtop=ceiling(elevtop) + kbeambot=floor(elevbot) + kbeamtop=max(1,min(kbeamtop,nsig)) + kbeambot=max(1,min(kbeambot,nsig)) + kbeamdiffmax=max(kbeamtop-kbeambot,kbeamdiffmax) + kbeamdiffmin=min(kbeamtop-kbeambot,kbeamdiffmin) + + ratio_errors = factdif*factelv*error/(abs(data(ier,i) + 1.0e6_r_kind*rhgh + & + r8*rlow)) + error = one/error + + if(dpres < zero .or. dpres > rsig)ratio_errors = zero + +! Interpolate guess u, v, and w to observation location and time. + call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + if(include_w) then + call tintrp31(ges_w,wgesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + end if + + call tintrp2a1(ges_u,ugesprofile,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a1(ges_v,vgesprofile,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + + if( if_vterminal )then + + call tintrp31(ges_rho,rhogesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + ! === In order to obtain the surface air density: rhogesin0 + call tintrp31(ges_rho,rhogesin0,dlat,dlon,0.0,dtime,& + hrdifsig,mype,nfldsig) + + if( if_model_dbz ) then + ! Interpolate guess reflectivity to observation location and time. + call tintrp31(ges_dbz,dbzgesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + rdBZ = dbzgesin + else + + ! Interpolate guess qr, qs, qg, and rho to observation location and time. + call tintrp31(ges_qr,qrgesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + call tintrp31(ges_qs,qsgesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + call tintrp31(ges_qg,qggesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + call tintrp31(ges_tsen,tempgesin,dlat,dlon,dpres,dtime,& + hrdifsig,mype,nfldsig) + + qrgesin = max(qrgesin,1.e-6_r_kind) + qsgesin = max(qsgesin,1.e-8_r_kind) + qggesin = max(qggesin,1.e-9_r_kind) + debugging = .false. + + call hx_dart(qrgesin,qggesin,qsgesin,rhogesin,tempgesin,rdBZ,debugging) + + end if ! end if-block if_model_dbz + + if(miter == 0) then !ie an enkf run + if(rDBZ < 0.0_r_kind) rDBZ=0.0_r_kind ! should be the same as in the read_dbz when nopcp=.true. + endif + if(miter == 0 .and. ens_hx_dbz_cut) then !ie an enkf run + if(rDBZ > 60.0_r_kind) rDBZ=60.0_r_kind + endif + + ! === From (Atlas et al. 1973) + vterminal = 2.65_r_kind*(rhogesin0/rhogesin)*rdBZ**0.114_r_kind + else + vterminal = 0.0_r_kind + end if + + if(include_w) then + call tintrp2a1(ges_w,wgesprofile,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + end if + +! Convert guess u,v wind components to radial value consident with obs + cosazm = cos(data(iazm,i)) ! cos(azimuth angle) + sinazm = sin(data(iazm,i)) ! sin(azimuth angle) + + if( if_vrobs_raw ) then + costilt = cos(data(itilt,i)) + if(include_w) then + call dhdrange(data(itilt,i),data(irange,i),sintilt) + costilt=sqrt(1.0_r_kind-sintilt*sintilt) + rwwind = (ugesin*cosazm+vgesin*sinazm)*costilt*factw+(wgesin-vterminal)*sintilt*factw + endif + else ! if_vrobs_raw + + costilt = cos(data(itilt,i)) ! cos(tilt angle) + sintilt = sin(data(itilt,i)) ! sin(tilt angle) + cosazm_costilt = cosazm*costilt + sinazm_costilt = sinazm*costilt + !vTgesprofile= 5.40_r_kind*(exp((refgesprofile -43.1_r_kind)/17.5_r_kind)) +! rwwind = (ugesin*cosazm+vgesin*sinazm)*costilt*factw + umaxmax=-huge(umaxmax) + uminmin=huge(uminmin) + kminmin=kbeambot + kmaxmax=kbeamtop + do k=kbeambot,kbeamtop + rwwindprofile=ugesprofile(k)*cosazm_costilt+vgesprofile(k)*sinazm_costilt + if(include_w) then + rwwindprofile=rwwindprofile+wgesprofile(k)*sintilt + end if + + if(umaxmaxrwwindprofile) then + uminmin=rwwindprofile + kminmin=k + end if + end do + rwwind=data(irwob,i) + if(data(irwob,i)umaxmax) then + rwwind=umaxmax + dpres=kmaxmax + end if + if(rwwind==data(irwob,i)) then + numequal=numequal+1 + else + numnotequal=numnotequal+1 + end if + end if + + ddiff = data(irwob,i) - rwwind + + if (doradaroneob) then + if(oneobvalue > -900_r_kind) then + data(irwob,i) = oneobvalue + ddiff = data(irwob,i) - rwwind + else + ddiff = oneobddiff + data(irwob,i) = rwwind + ddiff + endif + endif + +! adjust obs error for TDR data + !if(data(iobs_type,i) > three .and. ratio_errors*error > tiny_r_kind & + if( ratio_errors*error > tiny_r_kind & + .and. tdrerr_inflate) then + ratio_errors = data(ier2,i)/abs(data(ier,i) + 1.0e6_r_kind*rhgh + & + r8*rlow + min(max((abs(ddiff)-ten),zero)/ten,one)*data(ier,i)) + if(data(iobs_type,i) <= three) then + ratio_errors = data(ier2,i)/(5.0_r_kind + abs( 1.0e6_r_kind*rhgh + & + r8*rlow + min(max((abs(ddiff)-ten),zero)/ten,one)*5.0_r_kind)) + if((.not. l2rwthin) .and. ( data(irange,i) <= 20.0_r_kind )) then + muse(i)=.false. + end if + end if + end if + +! Gross error checks + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + qcgross=cgross(ikx) + + if (ratio > qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(4) = awork(4)+one + error = zero + ratio_errors = zero + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + !-- if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_rw_ob_type,ibin)%tail%muse(nobskeep) + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + + val = error*ddiff + +! Compute penalty terms (linear & nonlinear qc). + if(luse(i))then + exp_arg = -half*val**2 + rat_err2 = ratio_errors**2 + val2=val*val + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_w=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_w*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + jsig = dpres + jsig=max(1,min(jsig,nsig)) + awork(6*nsig+jsig+100)=awork(6*nsig+jsig+100)+val2*rat_err2 + awork(5*nsig+jsig+100)=awork(5*nsig+jsig+100)+one + awork(3*nsig+jsig+100)=awork(3*nsig+jsig+100)+valqc + end if + +! Loop over pressure level groupings and obs to accumulate +! statistics as a function of observation type. + ress = scale*ddiff + ressw = ress*ress + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + do k = 1,npres_print + if(presw >ptop(k) .and. presw<=pbot(k))then + bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count + bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ddiff ! bias + bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 + bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + end do + end if + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if ( .not. last .and. muse(i)) then + + allocate(my_head) + call rwNode_appendto(my_head,rwhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j,k) indices of guess gridpoint that bound obs location + my_head%dlev = dpres + my_head%factw= factw + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) + + do j=1,8 + my_head%wij(j)=factw*my_head%wij(j) + end do + my_head%raterr2 = ratio_errors**2 + my_head%cosazm_costilt = cosazm_costilt + my_head%sinazm_costilt = sinazm_costilt + my_head%sintilt = sintilt + my_head%res = ddiff + my_head%err2 = error**2 + my_head%time = dtime + my_head%luse = luse(i) + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + +! Save select output for diagnostic file + if(conv_diagsave)then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)' rw',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed, include_w) + logical,intent(inout) :: proceed + logical,intent(inout) :: include_w + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::u' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::v' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::w' , ivar, istatus ) + if (ivar>0) then + include_w=.true. + if(if_vterminal)then + if( .not. if_model_dbz ) then + call gsi_metguess_get ('var::qr', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qs', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qg', ivar, istatus ) + proceed=proceed.and.ivar>0 + else + call gsi_metguess_get ('var::dbz', ivar, istatus ) + proceed=proceed.and.ivar>0 + endif + end if + else + include_w=.false. + endif + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get u ... + varname='u' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_u))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_u(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_u(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get v ... + varname='v' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_v))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_v(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_v(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + if(if_vterminal)then + if(if_model_dbz)then + ! get dbz .... + varname='dbz' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_dbz))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_dbz(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_dbz(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_dbz(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + ! get qr ... + varname='qr' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qr))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qr(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qr(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qr(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + ! get qs ... + varname='qs' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qs))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qs(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qs(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qs(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + ! get qg ... + varname='qg' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qg))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qg(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qg(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qg(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + + endif + endif + + +! get w ... + if(include_w) then + varname='w' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_w))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_w(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_w(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_w(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle,ier= ',istatus + call stop2(999) + endif + end if + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_rw_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) + rdiagbuf(6,ii) = presw ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + +! rdiagbuf(9,ii) = rmiss_single ! input prepbufr qc or event mark + rdiagbuf(9,ii) = data(iobs_type,i) ! observation subtype + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m/s)**-1 + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m/s)**-1 + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m/s)**-1 + + rdiagbuf(17,ii) = data(irwob,i) ! radial wind speed observation (m/s) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (m/s) + rdiagbuf(19,ii) = data(irwob,i)-rwwind ! obs-ges w/o bias correction (m/s) (future slot) + + + rdiagbuf(20,ii)=data(iazm,i)*rad2deg ! azimuth angle + rdiagbuf(21,ii)=data(itilt,i)*rad2deg! tilt angle + rdiagbuf(22,ii) = factw ! 10m wind reduction factor + + rdiagbuf(23,ii) = 1.e+10_r_single ! ges ensemble spread (filled in EnKF) + rdiagbuf(24,ii) = 1.e+10_r_single ! ges ensemble spread (filled in EnKF) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' rw' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", data(iobs_type,i) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(ielev,i)) ) + call nc_diag_metadata("Pressure", sngl(presw) ) + call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(zero) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(data(irwob,i)) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(irwob,i)-rwwind) ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_w )) deallocate(ges_w ) + if(allocated(ges_v )) deallocate(ges_v ) + if(allocated(ges_u )) deallocate(ges_u ) + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps)) deallocate(ges_ps) + if(allocated(ges_w )) deallocate(ges_w ) + if(allocated(ges_ps)) deallocate(ges_ps) + if(allocated(ges_qs)) deallocate(ges_qs) + if(allocated(ges_qr)) deallocate(ges_qr) + if(allocated(ges_qg)) deallocate(ges_qg) + if(allocated(ges_dbz)) deallocate(ges_dbz) + end subroutine final_vars_ + +SUBROUTINE dhdrange(elvang,range,dhdr) + use kinds, only: r_kind,r_single,r_double,i_kind + + IMPLICIT NONE + REAL(r_kind), INTENT(IN) :: range + REAL(r_kind), INTENT(IN) :: elvang + REAL(r_kind), INTENT(OUT) :: dhdr +! + DOUBLE PRECISION :: eradius,frthrde,eighthre,fthsq,deg2rad + PARAMETER (eradius=6371.0_r_kind, & + frthrde=(4._r_kind*eradius/3._r_kind), & + eighthre=(8._r_kind*eradius/3._r_kind), & + fthsq=(frthrde*frthrde), & + deg2rad=(3.14592654_r_kind/180._r_kind)) +! + DOUBLE PRECISION :: sinelv,dhdrdb,drange +! + drange=DBLE(range) + sinelv=SIN(DBLE(elvang)) + dhdrdb = (drange+frthrde*sinelv)/ & + SQRT(drange*drange + fthsq + eighthre*drange*sinelv) + dhdr = dhdrdb +! + RETURN +END SUBROUTINE dhdrange + + +end subroutine setuprw +end module rw_setup diff --git a/src/gsi/setupspd.f90 b/src/gsi/setupspd.f90 new file mode 100644 index 000000000..9f23ee289 --- /dev/null +++ b/src/gsi/setupspd.f90 @@ -0,0 +1,1006 @@ +module spd_setup + implicit none + private + public:: setup + interface setup; module procedure setupspd; end interface + +contains +subroutine setupspd(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupspd compute rhs of oi for wind speed obs +! prgmmr: parrish org: np22 date: 1990-10-06 +! +! abstract: For wind speed observations, this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 1990-10-06 parrish +! 1998-04-10 weiyu yang +! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-17 treadon - update documentation +! 2004-08-02 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - increase size of vwork array for nonlinear qc +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list +! 2005-03-02 dee - remove garbage from diagnostic file +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-05-27 derber - level output change +! 2005-07-27 derber - add print of monitoring and reject data +! 2005-09-28 derber - combine with prep,spr,remove tran and clean up +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2005-11-03 treadon - correct error in ilone,ilate data array indices +! 2005-11-29 derber - remove psfcg and use ges_lnps instead +! 2006-01-31 todling/treadon - store wgt/wgtlim in rdiagbuf(6,ii) +! 2006-02-02 treadon - rename lnprsl as ges_lnprsl +! 2006-02-08 treadon - correct vertical dimension (nsig) in call tintrp2a(ges_tv...) +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-03-21 treadon - add option to perturb observation +! 2006-05-30 su,derber,treadon - modify diagnostic output +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - modify handling of multiple data at same location +! - unify NL qc +! 2006-07-31 kleist - use ges_ps instead of lnps +! 2006-08-28 su - fix a bug in variational qc +! 2007-03-09 su - modify the observation perturbation +! 2007-03-19 tremolet - binning of observations +! 2007-06-05 tremolet - add observation diagnostics structure +! 2007-08-28 su - modify the observation gross check error +! 2008-05-23 safford - rm unused vars and uses +! 2008-12-03 todling - changed handling of ptr%time +! 2009-02-06 pondeca - for each observation site, add the following to the +! diagnostic file: local terrain height, dominate surface +! type, station provider name, and station subprovider name +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). +! 2012-01-12 hu - add code to get vertical grid coordinate ibased on height for +! 260 (nacelle) and 261 (tower) +! 2013-01-26 parrish - convert grdcrd to grdcrd1, tintrp2a to tintrp2a1, tintrp2a11, +! tintrp3 to tintrp31 (so debug compile works on WCOSS) +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-11-29 shlyaeva - save linearized H(x) for EnKF +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2020-01-27 Winterbottom - moved the linear regression derived +! coefficients for the dynamic observation +! error (DOE) calculation to the namelist +! level; they are now loaded by +! aircraftinfo. +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr,getindex + use kinds, only: r_kind,r_single,r_double,i_kind + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,& + lobsdiag_forenkf,aircraft_recon + use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use m_obsNode, only: obsNode + use m_spdNode, only: spdNode + use m_spdNode, only: spdNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin + use guess_grids, only: nfldsig,hrdifsig,ges_lnprsl, & + comp_fact10,sfcmod_gfs,sfcmod_mm5 + use guess_grids, only: geop_hgtl + use gridmod, only: nsig,get_ij,twodvar_regional + use qcmod, only: npres_print,ptop,pbot + use constants, only: one,grav,rd,zero,four,tiny_r_kind, & + half,two,cg_term,huge_single,r1000,wgtlim + use jfunc, only: jiter,last,miter,jiterstart + use state_vectors, only: svars3d, levels, nsdim + use qcmod, only: dfact,dfact1 + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use m_dtime, only: dtime_setup, dtime_check + use sparsearr, only: sparr2, new, size, writearray, fullarray + + ! The following variables are the coefficients that describe the + ! linear regression fits that are used to define the dynamic + ! observation error (DOE) specifications for all reconnissance + ! observations collected within hurricanes/tropical cyclones; these + ! apply only to the regional forecast models (e.g., HWRF); Henry + ! R. Winterbottom (henry.winterbottom@noaa.gov). + + use obsmod, only: uv_doe_a_292,uv_doe_b_292 + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare local variables + real(r_kind),parameter:: ten=10.0_r_kind + character(len=*),parameter:: myname='setupspd' + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: tintrp31 + external:: grdcrd1 + external:: stop2 + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) uob,vob,spdges,spdob,spdob0,goverrd,ratio_errors + real(r_kind) presw,factw,dpres,ugesin,vgesin,sfcr,skint + real(r_kind) scale + real(r_kind) val2,ressw,ress,error,ddiff,dx10,rhgh,prsfc,r0_001 + real(r_kind) sfcchk,prsln2,rwgt,tfact + real(r_kind) thirty,rsig,ratio,residual,obserrlm,obserror + real(r_kind) val,valqc,psges,drpx,dlat,dlon,dtime,dpresave,rlow + real(r_kind) cg_spd,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2 + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nele,nobs):: data + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nsig)::prsltmp,tges + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + integer(i_kind) mm1,ibin,ioff,ioff0 + integer(i_kind) ii,jj,i,nchar,nreal,k,j,l,nty,nn,ikxx + integer(i_kind) ier,ilon,ilat,ipres,iuob,ivob,id,itime,ikx + integer(i_kind) ihgt,iqc,ier2,iuse,ilate,ilone,istnelv,izz,iprvd,isprvd + integer(i_kind) idomsfc,iskint,iff10,isfcr,isli + + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + integer(i_kind) :: iz, u_ind, v_ind, nnz, nind + real(r_kind) :: delz + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin, save_jacobian + type(spdNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + logical z_height + real(r_kind) zsges,dstn + real(r_kind),dimension(nsig):: zges + real(r_kind) dz,zob,z1,z2,p1,p2,dz21,dlnp21,pobl + integer(i_kind) k1,k2 + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + + type(obsLList),pointer,dimension(:):: spdhead + spdhead => obsLL(:) + +!****************************************************************************** +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + iuob=5 ! index of u observation + ivob=6 ! index of v observation + id=7 ! index of station id + itime=8 ! index of observation time in data array + ikxx=9 ! index of ob type + ihgt=10 ! index of observation elevation + iqc=11 ! index of quality mark + ier2=12 ! index of original-original obs error ratio + iuse=13 ! index of use parameter + idomsfc=14 ! index of dominant surface type + iskint=15 ! index of surface skin temperature + iff10=16 ! index of 10 meter wind factor + isfcr=17 ! index of surface roughness + ilone=18 ! index of longitude (degrees) + ilate=19 ! index of latitude (degrees) + istnelv=20 ! index of station elevation (m) + izz=21 ! index of surface height + iprvd=22 ! index of observation provider + isprvd=23 ! index of observation subprovider + + mm1=mype+1 + scale=one + rsig=nsig + thirty = 30.0_r_kind + r0_001=0.001_r_kind + goverrd=grav/rd + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + ii=0 + nchar=1 + ioff0=21 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif + if (save_jacobian) then + nnz = 4 ! number of non-zero elements in dH(x)/dx profile + nind = 2 + call new(dhx_dx, nnz, nind) + nreal = nreal + size(dhx_dx) + endif + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + if(netcdf_diag) call init_netcdf_diag_ + end if + + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ipres,k)== data(ipres,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(l) .and. muse(k))then + + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + end do + end do + + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + dpres=data(ipres,i) + error=data(ier2,i) + ikx=nint(data(ikxx,i)) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Load obs error and u,v obs + obserror = max(cermin(ikx),min(cermax(ikx),data(ier,i))) + uob = data(iuob,i) + vob = data(ivob,i) + + + spdob=sqrt(uob*uob+vob*vob) + call tintrp2a1(ges_tv,tges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + + factw = data(iff10,i) + if(sfcmod_gfs .or. sfcmod_mm5)then + sfcr = data(isfcr,i) + skint = data(iskint,i) + isli=data(idomsfc,i) + call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) + end if + + nty=ictype(ikx) + + z_height = .false. +! if ( nty == 260 .or. nty == 261) z_height = .true. +! nty == 292 is temporarily assigned to SFMR retrieved wind speed from recon +! and is subjet to change in the future + if ( nty == 260 .or. nty == 261 .or. nty == 292) z_height = .true. + +! Process observations reported with height differently than those +! reported with pressure. Type 260=nacelle 261=tower wind spd are +! encoded in NCEP prepbufr files with geometric height above +! sea level. + + if (z_height) then + + drpx = zero + dpres = data(ihgt,i) + dstn = data(istnelv,i) + call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + +! Get guess surface elevation and geopotential height profile +! at observation location. + call tintrp2a1(geop_hgtl,zges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + +! Convert observation height (in dpres) from meters to grid relative +! units. Save the observation height in zob for later use. + zob = dpres + call grdcrd1(dpres,zges,nsig,1) + factw=one + rlow=zero + rhgh=zero + +! Compute observation pressure (only used for diagnostics) +! Set indices of model levels below (k1) and above (k2) observation. + if (dpresnsig) then + z1=zges(nsig-1); p1=prsltmp(nsig-1) + z2=zges(nsig); p2=prsltmp(nsig) + drpx = 1.e6_r_kind + else + k=dpres + k1=min(max(1,k),nsig) + k2=max(1,min(k+1,nsig)) + z1=zges(k1); p1=prsltmp(k1) + z2=zges(k2); p2=prsltmp(k2) + endif + + dz21 = z2-z1 + dlnp21 = p2-p1 + dz = zob-z1 + pobl = p1 + (dlnp21/dz21)*dz + presw = ten*exp(pobl) + +! Process observations with reported pressure + else + + presw = ten*exp(dpres) + dpres = dpres-log(psges) + drpx=zero + if(nty >= 280 .and. nty < 290)then + dpresave=dpres + dpres=-goverrd*data(ihgt,i)/tges(1) + if(nty < 283)drpx=abs(dpres-dpresave)*factw*thirty + end if + + prsfc=psges + prsln2=log(exp(prsltmp(1))/prsfc) + sfcchk=log(psges) + if(dpres <= prsln2)then + factw=one + else + dx10=-goverrd*ten/tges(1) + if (dpres < dx10)then + factw=(dpres-dx10+factw*(prsln2-dpres))/(prsln2-dx10) + end if + end if + +! Put obs pressure in correct units to get grid coord. number + dpres=log(exp(dpres)*prsfc) + call grdcrd1(dpres,prsltmp(1),nsig,-1) + +! Get approx k value of sfc by using surface pressure of 1st ob + call grdcrd1(sfcchk,prsltmp(1),nsig,-1) + + +! Check to see if observations is below what is seen to be the surface + rlow=max(sfcchk-dpres,zero) + + rhgh=max(dpres-r0_001-rsig,zero) + + endif ! end of process observations with reported pressure + + if(luse(i))then + awork(1) = awork(1) + one + if(rlow/=zero) awork(2) = awork(2) + one + if(rhgh/=zero) awork(3) = awork(3) + one + end if + + ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+four*rlow) + + +! Interpolate guess u and v to observation location and time. + call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + + +! Apply 10-meter wind reduction factor to guess winds. Compute +! guess wind speed. + ugesin=factw*ugesin + vgesin=factw*vgesin + spdges=sqrt(ugesin*ugesin+vgesin*vgesin) + + iz = max(1, min( int(dpres), nsig)) + delz = max(zero, min(dpres - float(iz), one)) + + if (save_jacobian) then + + u_ind = getindex(svars3d, 'u') + if (u_ind < 0) then + print *, 'Error: no variable u in state vector. Exiting.' + call stop2(1300) + endif + v_ind = getindex(svars3d, 'v') + if (v_ind < 0) then + print *, 'Error: no variable v in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = iz + sum(levels(1:u_ind-1)) + dhx_dx%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:u_ind-1)) + + dhx_dx%val(1) = (one - delz) * two * ugesin + dhx_dx%val(2) = delz * two * ugesin + + dhx_dx%st_ind(2) = iz + sum(levels(1:v_ind-1)) + dhx_dx%end_ind(2) = min(iz + 1,nsig) + sum(levels(1:v_ind-1)) + + dhx_dx%val(3) = (one - delz) * two * vgesin + dhx_dx%val(4) = delz * two * ugesin + endif + + + ddiff = spdob-spdges + + if (aircraft_recon) then + if ( nty == 292 ) then + ratio_errors=error/(uv_doe_a_292*abs(ddiff)+uv_doe_b_292) + if (spdob < 10._r_kind) ratio_errors=zero + endif + endif + + error=one/error + +! Check to see if observations is above the top of the model (regional mode) + if (dpres>rsig) ratio_errors=zero + + +! Gross error checks + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + if (ratio>cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(4) = awork(4)+one + error = zero + ratio_errors = zero + muse(i)=.false. + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_spd=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_spd*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + wgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + + +! Accumulate statistics for obs belonging to this task + if (luse(i) .and. muse(i)) then + if(rwgt < one) awork(61) = awork(61)+one + awork(5)=awork(5) + val2*rat_err2 + awork(6)=awork(6) + one + awork(22)=awork(22) + valqc + end if + +! Loop over pressure level groupings and obs to accumulate statistics +! as a function of observation type. + do k = 1,npres_print + if(luse(i) .and.presw >ptop(k) .and. presw<=pbot(k))then + ress = scale*ddiff + ressw = ress*ress + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count + bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ddiff ! bias + bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 + bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + end do + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=spdob-sqrt(ugesin*ugesin+vgesin*vgesin)) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call spdNode_appendto(my_head,spdhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%factw=factw + do j=1,4 + my_head%wij(j)=factw*my_head%wij(j) + end do + my_head%raterr2= ratio_errors**2 + my_head%res = spdob + my_head%uges = ugesin + my_head%vges = vgesin + my_head%err2 = error**2 + my_head%time = dtime + my_head%luse = luse(i) + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + end if +! Save select output for diagnostic file + if(conv_diagsave .and. luse(i))then + ii=ii+1 + spdob0 = sqrt(data(iuob,i)*data(iuob,i)+data(ivob,i)*data(ivob,i)) + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + +! End of loop over observations + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'spd',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::u' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::v' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get u ... + varname='u' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_u))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_u(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_u(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get v ... + varname='v' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_v))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_v(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_v(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_spd_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = presw ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m/s)**-1 + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m/s)**-1 + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m/s)**-1 + + rdiagbuf(17,ii) = spdob ! wind speed observation (m/s) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (m/s) + rdiagbuf(19,ii) = spdob0-spdges ! obs-ges w/o bias correction (m/s) (future slot) + + rdiagbuf(20,ii) = factw ! 10m wind reduction factor + + rdiagbuf(21,ii) = 1.e+10_r_single ! ges ensemble spread (filled in by EnKF) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + ioff = ioff + 1 + rdiagbuf(ioff,ii) = data(idomsfc,i) ! dominate surface type + ioff = ioff + 1 + rdiagbuf(ioff,ii) = data(izz,i) ! model terrain at ob location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' spd' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(presw) ) + call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(spdob) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(spdob0-spdges) ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_tv)) deallocate(ges_tv) + if(allocated(ges_v )) deallocate(ges_v ) + if(allocated(ges_u )) deallocate(ges_u ) + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps)) deallocate(ges_ps) + end subroutine final_vars_ + +end subroutine setupspd +end module spd_setup diff --git a/src/gsi/setupsst.f90 b/src/gsi/setupsst.f90 new file mode 100644 index 000000000..78b71837b --- /dev/null +++ b/src/gsi/setupsst.f90 @@ -0,0 +1,626 @@ +module sst_setup + implicit none + private + public:: setup + interface setup; module procedure setupsst; end interface + +contains +subroutine setupsst(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupsst compute rhs for conventional surface sst +! prgmmr: derber org: np23 date: 2004-07-20 +! +! abstract: For sea surface temperature observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2004-07-20 derber +! 2004-08-02 treadon - add only to module use, add intent in/out +! 2004-08-28 derber - fix some bugs +! 2004-10-06 parrish - increase size of sstwork array for nonlinear qc +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list +! 2005-03-02 dee - remove garbage from diagnostic file +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-07-27 derber - add print of monitoring and reject data +! 2005-09-28 derber - combine with prep,spr,remove tran and clean up +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2005-11-08 todling - bug fix: lat/lon arrays were inverted to diag file +! 2005-11-14 pondeca - correct error in diagnostic array index +! 2006-01-31 todling/treadon - store wgt/wgtlim in rdiagbuf(6,ii) +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-05-30 su,derber,treadon - modify diagnostic output +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - modify handling of multiple data at same location +! - unify NL qc +! 2006-08-28 su - fix a bug in variational qc +! 2007-03-19 tremolet - binning of observations +! 2007-06-05 tremolet - add observation diagnostics structure +! 2007-08-28 su - modify the gross check error +! 2008-05-21 safford - rm unused vars and uses +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). +! 2011-04-02 li - set up Tr analysis and modify to save nst analysis related diagnostic variables +! 2012-04-10 akella - sstges calculated for nst analysis using NST fields +! 2013-01-26 parrish - change intrp2a to intrp2a11 (so debug compile works on WCOSS) +! 2014-01-28 li - add ntguessfc to use guess_grids to apply intrp2a11 correctly +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-05-30 li - Modify to make it work when nst_gsi = 0 and nsstbufr data file exists +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: dsfct,ntguessfc + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset + use m_obsNode, only: obsNode + use m_sstNode, only: sstNode + use m_sstNode, only: sstNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use obsmod, only: netcdf_diag, binary_diag, dirname,ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig + use gridmod, only: get_ij + use constants, only: zero,tiny_r_kind,one,quarter,half,wgtlim, & + two,cg_term,pi,huge_single,r1000,tfrozen,r_missing + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use gsi_nstcouplermod, only: nst_gsi,nstinfo + use m_dtime, only: dtime_setup, dtime_check + implicit none + + integer(i_kind),parameter:: istyp=0,nprep=1 +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: intrp2a11 + external:: stop2 + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) sstges,dlat,dlon,ddiff,dtime,error,dsfct_obx,owpct + real(r_kind) scale,val2,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,halfpi,rwgt + real(r_kind) cg_sst,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + real(r_kind) :: tz_tr,zob,tref,dtw,dtc + + integer(i_kind) ier,ilon,ilat,isst,id,itime,ikx,itemp,ipct + integer(i_kind) ier2,iuse,izob,itref,idtw,idtc,itz_tr,iotype,ilate,ilone,istnelv + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) id_qc + integer(i_kind) idomsfc,itz + integer(i_kind) idatamax,nwsum,nfinal,nobs_qc + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + + logical:: in_curbin, in_anybin + type(sstNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + integer, parameter:: maxinfo = 20 + character(len=*),parameter:: myname='setupsst' + + + equivalence(rstation_id,station_id) + + type(obsLList),pointer,dimension(:):: ssthead + ssthead => obsLL(:) + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + isst=4 ! index of sst observation + id=5 ! index of station id + itime=6 ! index of observation time in data array + ikxx=7 ! index of ob type + itemp=8 ! index of open water temperature (background) + izob=9 ! index of flag indicating depth of observation + iotype=10 ! index of measurement type + ipct=11 ! index of open water percentage + ier2=12 ! index of original obs error + iuse=13 ! index of use parameter + idomsfc=14 ! index of dominant surface type + itz=15 ! index of temperature at depth z (Tz) + ilone=16 ! index of longitude (degrees) + ilate=17 ! index of latitude (degrees) + istnelv=18 ! index of station elevation (m) + itref=19 ! index of Tr + idtw=20 ! index of dtw + idtc=21 ! index of dtc + itz_tr=22 ! index of tz_tr + idatamax=22 ! set to largest value in list above + + if(nst_gsi>0) then + if(nele 0)then + tref = data(itref,i) + dtw = data(idtw,i) + dtc = data(idtc,i) + tz_tr = data(itz_tr,i) + else + tref = data(itz,i) + dtw = zero + dtc = zero + tz_tr = r_missing + end if + + if (in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + isli=data(idomsfc,i) + owpct=data(ipct,i) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Interpolate to get sst at obs location/time + if ( isli == 0 ) then + nobs_qc = nobs_qc + 1 + call intrp2a11(dsfct(1,1,ntguessfc),dsfct_obx,dlat,dlon,mype) + else + dsfct_obx = zero + endif + + if(nst_gsi > 1) then + sstges = max(tref+dtw-dtc+dsfct_obx, tfrozen) + else + sstges = max(data(itz,i)+dsfct_obx, tfrozen) + end if + +! Adjust observation error + ratio_errors=error/data(ier,i) + error=one/error + + if(owpct == 0 ) error = zero + + ddiff=data(isst,i)-sstges + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross check using innovation normalized by error + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + if( id_qc == 0 ) id_qc = 1 + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_sst=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_sst*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + end if + ress = ddiff*scale + ressw2 = ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + + endif + + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call sstNode_appendto(my_head,ssthead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%zob = zob + my_head%tz_tr = tz_tr + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1, myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) + end if + + end do ! do i=1,nobs + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'sst',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if + end if + +! End of routine + +contains + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_sst_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = data(itemp,i) ! background open water temperature (K) + rdiagbuf(7,ii) = data(izob,i) ! observation depth (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(ipct,i) ! open water percentage (0 to 1) + rdiagbuf(10,ii) = id_qc ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(isst,i) ! SST observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(isst,i)-sstges! obs-ges w/o bias correction (K) (future slot) + + rdiagbuf(20,ii) = data(iotype,i) ! type of measurement + + if (nst_gsi>0) then + rdiagbuf(maxinfo+1,ii) = data(itref,i) ! Tr + rdiagbuf(maxinfo+2,ii) = data(idtw,i) ! dt_warm at zob + rdiagbuf(maxinfo+3,ii) = data(idtc,i) ! dt_cool at zob + rdiagbuf(maxinfo+4,ii) = data(itz_tr,i) ! d(tz)/d(Tr) at zob + endif + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' sst' + real(r_single),parameter:: missing = -9.99e9_r_single + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", missing ) + call nc_diag_metadata("Height", sngl(data(izob,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(ipct,i)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(data(isst,i)) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(isst,i)-sstges) ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + end subroutine contents_netcdf_diag_ +end subroutine setupsst +end module sst_setup diff --git a/src/gsi/setupswcp.f90 b/src/gsi/setupswcp.f90 new file mode 100644 index 000000000..0a4152b82 --- /dev/null +++ b/src/gsi/setupswcp.f90 @@ -0,0 +1,948 @@ +module swcp_setup + implicit none + private + public:: setup + interface setup; module procedure setupswcp; end interface + +contains +subroutine setupswcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupswcp compute rhs of oi for solid-water condensate path +! prgmmr: Ting-Chi Wu org: CIRA/CSU date: 2017-06-28 +! +! abstract: For solid-water condensate path (swcp), this routine +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2017-06-28 Ting-Chi Wu - mimic the structure in setuppw.f90 and setupbend.f90 +! - setupswcp.f90 includes 2 operator options +! 1) when l_wcp_cwm = .false.: +! operator = f(T,P,q) +! 2) when l_wcp_cwm = .true. and CWM partition6: +! operator = f(qi,qs,qg,qh) partition6 +! 2018-05-10 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr,getindex + use kinds, only: r_kind,r_single,r_double,i_kind + use guess_grids, only: ges_prsi,ges_prsl,ges_tsen,hrdifsig,nfldsig + use gridmod, only: lat2,lon2,nsig,get_ij,latlon11 + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,lobsdiag_forenkf,ianldate,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset + use obsmod, only: l_wcp_cwm + use m_obsNode, only: obsNode + use m_swcpNode, only: swcpNode + use m_swcpNode, only: swcpNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin + + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header,nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init,nc_diag_read_get_dim,nc_diag_read_close + use state_vectors, only: svars3d, levels, nsdim + + use constants, only: zero,one,tpwcon,r1000,r10, & + tiny_r_kind,three,half,two,cg_term,huge_single,& + wgtlim, ttp, tmix, psatk, xa, xai, xb, xbi + use jfunc, only: jiter,last,jiterstart,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use gfs_stratosphere, only: use_gfs_stratosphere, nsig_save + + use sparsearr, only: sparr2, new, size, writearray, fullarray + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare local parameter + character(len=*),parameter:: myname='setupswcp' + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: stop2 + +! Declare local variables + real(r_double) rstation_id + real(r_kind):: swcpges,grsmlt,dlat,dlon,dtime,obserror, & + obserrlm,residual,ratio,dswcp + real(r_kind) error,ddiff + real(r_kind) ressw2,ress,scale,val2,val,valqc + real(r_kind) rat_err2,exp_arg,term,ratio_errors,rwgt + real(r_kind) cg_swcp,wgross,wnotgross,wgt,arg + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,tfact + real(r_kind),dimension(nobs)::dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + integer(i_kind) ikxx,nn,istat,ibin,ioff,ioff0 + integer(i_kind) i,nchar,nreal,k,j,jj,ii,l,mm1 + integer(i_kind) ier,ilon,ilat,iswcp,id,itime,ikx,iswcpmax,iqc + integer(i_kind) ier2,iuse,ilate,ilone,istnelv,iobshgt,iobsprs + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + integer(i_kind) :: qi_ind, nind, nnz + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + + logical:: in_curbin, in_anybin,save_jacobian + type(swcpNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + equivalence(rstation_id,station_id) + integer(i_kind),dimension(4) :: swcp_ij + integer(i_kind) :: nsig_top + + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qi + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qs + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qg + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qh + real(r_kind),dimension(lat2,lon2,nfldsig)::ges_swcp + real(r_kind),dimension(nsig+1):: piges + real(r_kind),dimension(nsig):: qges, plges, tges + real(r_kind),dimension(nsig):: trges, wges, dwdt + real(r_kind),dimension(nsig):: esges, eslges, esiges + real(r_kind),dimension(nsig):: desdt, desldt, desidt + real(r_kind),dimension(nsig):: dssqdq, dssqdt, dssqdp + real(r_kind),dimension(nsig):: qvges, qvsges, ssqges + real(r_kind),dimension(nsig):: qiges, qsges, qgges, qhges + real(r_kind) :: tupper, tlower, tcenter + real(r_kind),dimension(lat2,lon2,nsig,nfldsig)::qv, esi, esl, es, qvsi, ssqvi + real(r_kind),dimension(lat2,lon2,nsig,nfldsig)::ges_tr, ges_w + + type(obsLList),pointer,dimension(:):: swcphead + swcphead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + + grsmlt=three ! multiplier factor for gross check + mm1=mype+1 + scale=one + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!****************************************************************************** +! Read and reformat observations in work arrays. + +!============================================================================================================= +! Operator for swcp (solid-water content path w.r.t ice forward model) + + if (use_gfs_stratosphere) then + nsig_top = nsig_save + else + nsig_top = nsig + endif + + tupper = ttp + tlower = tmix + + if (.not.l_wcp_cwm) then + esi = zero; esl = zero; es = zero + qvsi = zero; ssqvi = zero + ges_swcp = zero + + tcenter = 0.5_r_kind * (tupper + tlower) + ges_tr = ttp / ges_tsen + ges_w = 0.5_r_kind * (one + tanh((ges_tsen-tcenter)/((tupper-tlower)/4._r_kind))) ! hyperbolic tangent + esl = psatk * (ges_tr**xa) * exp(xb*(one-ges_tr)) + esi = psatk * (ges_tr**xai) * exp(xbi*(one-ges_tr)) + es = ges_w * esl + (one-ges_w) * esi + + + do jj=1,nfldsig + ! gues_q is acquired through gsi_bundlegetpointer in the init_vars_ call + qv(:,:,:,jj) = ges_q(:,:,:,jj) / (one - ges_q(:,:,:,jj)) ! kg/kg + + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + if (ges_tsen(i,j,k,jj) < tupper .and. k <= nsig_top ) then + qvsi(i,j,k,jj) = 0.622_r_kind * es(i,j,k,jj) / (ges_prsl(i,j,k,jj)-es(i,j,k,jj)) ! ges_prsl in cbar + ssqvi(i,j,k,jj) = qv(i,j,k,jj) - qvsi(i,j,k,jj) ! kg/kg + if (ssqvi(i,j,k,jj) < zero) ssqvi(i,j,k,jj) = zero + ges_swcp(i,j,jj) = ges_swcp(i,j,jj) + ssqvi(i,j,k,jj) * & + tpwcon*r10*(ges_prsi(i,j,k,jj)-ges_prsi(i,j,k+1,jj)) ! kg/m^2 + endif + end do + end do + end do + end do + + else + + ! l_wcp_cwm = T and partition6: ql, qi, qr, qs, qg, and qh' + ges_swcp = zero + + do jj=1,nfldsig + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + if (ges_tsen(i,j,k,jj) < tupper .and. k <= nsig_top ) then + ges_swcp(i,j,jj) = ges_swcp(i,j,jj) + & + (ges_qi(i,j,k,jj)+ges_qs(i,j,k,jj)+ges_qg(i,j,k,jj)+ges_qh(i,j,k,jj)) * & + tpwcon*r10*(ges_prsi(i,j,k,jj)-ges_prsi(i,j,k+1,jj)) ! kg/m^2 + endif + enddo + enddo + enddo + enddo + + endif ! l_wcp_cwm + +!============================================================================================================= + + + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + iswcp = 4 ! index of swcp observations + id=5 ! index of station id + itime=6 ! index of observation time in data array + ikxx=7 ! index of ob type + iswcpmax=8 ! index of swcp max error + iqc=9 ! index of quality mark + ier2=10 ! index of original-original obs error ratio + iuse=11 ! index of use parameter + ilone=12 ! index of longitude (degrees) + ilate=13 ! index of latitude (degrees) + istnelv=14 ! index of station elevation (m) + iobsprs=15 ! index of observation pressure (hPa) + iobshgt=16 ! index of observation height (m) + + do i=1,nobs + muse(i)=nint(data(11,i)) <= jiter + end do + + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l)) then + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + end do + end do + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + nchar=1 + ioff0=20 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (save_jacobian) then + nnz = nsig ! number of non-zero elements in dH(x)/dx profile + nind = 1 + call new(dhx_dx, nnz, nind) + nreal = nreal + size(dhx_dx) + endif + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + ii=0 + if(netcdf_diag) call init_netcdf_diag_ + end if + + +! Prepare total precipitable water data + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + + dswcp=data(iswcp,i) + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + + ratio_errors=error/data(ier,i) + error=one/error + endif ! (in_curbin) + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +!============================================================================================================= +! Interpolate ges_* to obs location + + ! Interpolate model swcp to obs location + call tintrp2a11(ges_swcp,swcpges,dlat,dlon,dtime, & + hrdifsig,mype,nfldsig) + + ! Interpolate pressure at interface values to obs location + call tintrp2a1(ges_prsi,piges,dlat,dlon,dtime, & + hrdifsig,nsig+1,mype,nfldsig) + + if (.not.l_wcp_cwm) then + call tintrp2a1(ges_prsl,plges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_tsen,tges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_q,qges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + else + call tintrp2a1(ges_tsen,tges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_qi,qiges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_qs,qsges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_qg,qgges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + call tintrp2a1(ges_qh,qhges,dlat,dlon,dtime, & + hrdifsig,nsig,mype,nfldsig) + endif + + if (save_jacobian) then + qi_ind = getindex(svars3d, 'qi') + if (qi_ind < 0) then + print *, 'Error: no variable q in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = 1 + sum(levels(1:qi_ind-1)) + dhx_dx%end_ind(1) = nsig + sum(levels(1:qi_ind-1)) + + do k = 1, nsig + dhx_dx%val(k) = tpwcon*r10*(piges(k)-piges(k+1)) + enddo + endif + +!============================================================================================================= + + ! Compute innovation + ddiff = dswcp - swcpges + + !if (l_limit_swcp_innov) then + ! ! Limit size of swcp innovation to a percent of the background value + ! ddiff = sign(min(abs(ddiff),max_innov_pct*swcpges),ddiff) + !end if + +! Gross checks using innovation + + residual = abs(ddiff) + if (residual>grsmlt*data(iswcpmax,i)) then + error = zero + ratio_errors=zero + if (luse(i)) awork(7) = awork(7)+one + end if + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + ratio = residual/obserrlm + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + if (ratio_errors*error <= tiny_r_kind) muse(i)=.false. + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + + val = error*ddiff + + if(luse(i))then +! Compute penalty terms (linear & nonlinear qc). + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_swcp=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_swcp*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics as a function of observation type. + ress = ddiff*scale + ressw2= ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 +! Accumulate statistics for obs belonging to this task + if (muse(i) ) then + if(rwgt < one) awork(21) = awork(21)+one + awork(5) = awork(5)+val2*rat_err2 + awork(4) = awork(4)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if ( .not. last .and. muse(i)) then + + allocate(my_head) + call swcpNode_appendto(my_head,swcphead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + + allocate(my_head%ij(4, nsig), & + my_head%jac_t(nsig ), & + my_head%jac_p(nsig+1), & + my_head%jac_q(nsig ), & + my_head%jac_qi(nsig ), & + my_head%jac_qs(nsig ), & + my_head%jac_qg(nsig ), & + my_head%jac_qh(nsig ), stat=istat) + if (istat/=0) write(6,*)'MAKECOBS: allocate error for swcphead, istat=',istat + + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,swcp_ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2= ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + my_head%jac_t(:)=zero + my_head%jac_p(:)=zero + my_head%jac_q(:)=zero + my_head%jac_qi(:)=zero + my_head%jac_qs(:)=zero + my_head%jac_qg(:)=zero + my_head%jac_qh(:)=zero + +!============================================================================================================= +! Calculate Jacobians for swcp + + eslges=zero; esiges=zero; esges=zero; + desldt=zero; desidt=zero; desdt=zero; dwdt=zero + dssqdq=zero; dssqdt=zero; dssqdp=zero + + do k=1,nsig + + my_head%ij(1,k)=swcp_ij(1)+(k-1)*latlon11 + my_head%ij(2,k)=swcp_ij(2)+(k-1)*latlon11 + my_head%ij(3,k)=swcp_ij(3)+(k-1)*latlon11 + my_head%ij(4,k)=swcp_ij(4)+(k-1)*latlon11 + + if (.not.l_wcp_cwm) then + + qvges(k) = qges(k)/(one-qges(k)) ! kg/kg + trges(k) = ttp/tges(k) + wges(k) = 0.5_r_kind*(one+tanh((tges(k)-tcenter)/((tupper-tlower)/4._r_kind))) ! hyperbolic tangent + + if ( tges(k) < tupper .and. k <= nsig_top ) then + !psat is in Pa; psatk is in cbar + eslges(k) = psatk*(trges(k)**xa)*exp(xb*(one-trges(k))) ! cbar + esiges(k) = psatk*(trges(k)**xai)*exp(xbi*(one-trges(k))) !cbar + esges(k) = wges(k) * eslges(k) + (one-wges(k)) * esiges(k) ! cbar + qvsges(k) = 0.622_r_kind*esges(k)/(plges(k)-esges(k)) ! kg/kg + ssqges(k) = qvges(k)-qvsges(k) + if ( ssqges(k) < zero ) ssqges(k)=zero + !jacobian + desldt(k) = eslges(k)*(-xa/tges(k)) + eslges(k)*xb*ttp/(tges(k)**2) + desidt(k) = esiges(k)*(-xai/tges(k)) + esiges(k)*xbi*ttp/(tges(k)**2) + ! hyperbolic tangent + dwdt(k) = 0.5_r_kind*(one/cosh((tges(k)-tcenter)/((tupper-tlower)/4._r_kind))**2)*(4._r_kind/(tupper-tlower)) + desdt(k) = dwdt(k)*eslges(k) + wges(k)*desldt(k) & + + (-dwdt(K))*esiges(k) + (one-wges(k))*desidt(k) + + dssqdt(k) = -0.622_r_kind* ( desdt(k)/(plges(k)-esges(k)) & + + esges(k)*desdt(k)/((plges(k)-esges(k))**2) ) + dssqdq(k) = one/(one-qges(k)) + qges(k)/((one-qges(k))**2) + dssqdp(k) = 0.622_r_kind*esges(k)/(plges(k)-esges(k))**2 + + my_head%jac_t(k)=dssqdt(k)*(tpwcon*r10*(piges(k)-piges(k+1))) + my_head%jac_p(k)=dssqdp(k)*(tpwcon*r10*(piges(k)-piges(k+1))) + my_head%jac_q(k)=dssqdq(k)*(tpwcon*r10*(piges(k)-piges(k+1))) + endif + + else + + if ( tges(k) < tupper .and. k <= nsig_top ) then + my_head%jac_qi(k)=tpwcon*r10*(piges(k)-piges(k+1)) + my_head%jac_qs(k)=tpwcon*r10*(piges(k)-piges(k+1)) + my_head%jac_qg(k)=tpwcon*r10*(piges(k)-piges(k+1)) + my_head%jac_qh(k)=tpwcon*r10*(piges(k)-piges(k+1)) + endif + + endif + end do + + my_head%jac_p(nsig+1) = zero +!============================================================================================================= + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv, my_head%iob, 1, myname, 'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + + +! Save select output for diagnostic file + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input=one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst + if (err_final>tiny_r_kind) errinv_final=one/err_final + + ioff=ioff0 + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + end if + + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag.and. ii>0)then + write(7)'swc',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + use obsmod, only: l_wcp_cwm + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + if (.not.l_wcp_cwm) then + + call gsi_metguess_get ('var::q', ivar, istatus ) + proceed=ivar>0 + + else + + call gsi_metguess_get ('var::qi' , ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::qs', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qg', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qh', ivar, istatus ) + proceed=proceed.and.ivar>0 + + endif ! l_wcp_cwm + end subroutine check_vars_ + + subroutine init_vars_ + use obsmod, only: l_wcp_cwm + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then + + if (.not.l_wcp_cwm) then + + ! get q ... + varname='q' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_q))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_q(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_q(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + else + + ! get qi ... + varname='qi' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qi))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qi(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qi(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qi(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + ! get qs ... + varname='qs' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qs))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qs(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qs(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qs(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + ! get qg ... + varname='qg' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qg))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qg(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qg(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qg(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + ! get qh ... + varname='qh' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qh))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_qh(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_qh(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qh(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + endif ! l_wcp_cwm + + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + +! open netcdf diag file + write(string,900) jiter +900 format('conv_swcp_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + + end subroutine init_netcdf_diag_ + + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = data(iobsprs,i) ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error + rdiagbuf(16,ii) = errinv_final ! final inverse observation error + + rdiagbuf(17,ii) = dswcp ! solid-water content path obs (kg/m**2) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (kg/m**2) + rdiagbuf(19,ii) = dswcp-swcpges ! obs-ges w/o bias correction (kg/m**2) (future slot) + rdiagbuf(20,ii) = 1.e10_r_single ! spread (filled in by EnKF) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' swcp' + real(r_kind),parameter:: missing = -9.99e9_r_kind + + real(r_kind),dimension(miter) :: obsdiag_iuse + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(data(iobsprs,i)) ) + call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Setup_QC_Mark", sngl(rmiss_single) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata("Observation", sngl(dswcp) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(dswcp-swcpges)) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_q )) deallocate(ges_q ) + if(allocated(ges_qi)) deallocate(ges_qi) + if(allocated(ges_qs)) deallocate(ges_qs) + if(allocated(ges_qg)) deallocate(ges_qg) + if(allocated(ges_qh)) deallocate(ges_qh) + end subroutine final_vars_ + +end subroutine setupswcp +end module swcp_setup diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 new file mode 100755 index 000000000..ac5024116 --- /dev/null +++ b/src/gsi/setupt.f90 @@ -0,0 +1,1765 @@ +module t_setup + implicit none + private + public:: setup + interface setup; module procedure setupt; end interface + +contains +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI ! +!------------------------------------------------------------------------- +!BOP +! +! !ROUTINE: setupt --- Compute rhs of oi for temperature obs +! +! !INTERFACE: +! +subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) + +! !USES: + + use mpeu_util, only: die,perr,getindex + use kinds, only: r_kind,r_single,r_double,i_kind + + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: sfcmodel,perturb_obs,oberror_tune,lobsdiag_forenkf,ianldate,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,aircraft_recon + use m_obsNode, only: obsNode + use m_tNode, only: tNode + use m_tNode, only: tNode_appendto + use m_tNode, only: tNode_ich0 + use m_tNode, only: tNode_ich0_pbl_pseudo + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + + use qcmod, only: npres_print,dfact,dfact1,ptop,pbot,buddycheck_t + use qcmod, only: njqc,vqc + + use oneobmod, only: oneobtest + use oneobmod, only: maginnov + use oneobmod, only: magoberr + + use gridmod, only: nsig,twodvar_regional,regional + use gridmod, only: get_ijk,pt_ll + use jfunc, only: jiter,last,jiterstart,miter + + use guess_grids, only: nfldsig, hrdifsig,ges_lnprsl,& + geop_hgtl,ges_tsen,pbl_height + use state_vectors, only: svars3d, levels, nsdim + + use constants, only: zero, one, four,t0c,rd_over_cp,three,rd_over_cp_mass,ten + use constants, only: tiny_r_kind,half,two,cg_term + use constants, only: huge_single,r1000,wgtlim,r10,fv + use constants, only: one_quad + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,icsubtype + use converr_t, only: ptabl_t + use converr, only: ptabl + use rapidrefresh_cldsurf_mod, only: l_gsd_terrain_match_surftobs,l_sfcobserror_ramp_t + use rapidrefresh_cldsurf_mod, only: l_pbl_pseudo_surfobst, pblh_ration,pps_press_incr + use rapidrefresh_cldsurf_mod, only: i_use_2mt4b,i_sfct_gross,l_closeobs,i_coastline + + use aircraftinfo, only: npredt,predt,aircraft_t_bc_pof,aircraft_t_bc, & + aircraft_t_bc_ext,ostats_t,rstats_t,upd_pred_t + + use m_dtime, only: dtime_setup, dtime_check + + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use buddycheck_mod, only: buddy_check_t + + use sparsearr, only: sparr2, new, size, writearray, fullarray + + ! The following variables are the coefficients that describe the + ! linear regression fits that are used to define the dynamic + ! observation error (DOE) specifications for all reconnissance + ! observations collected within hurricanes/tropical cyclones; these + ! apply only to the regional forecast models (e.g., HWRF); Henry + ! R. Winterbottom (henry.winterbottom@noaa.gov). + + use obsmod, only: t_doe_a_136,t_doe_a_137,t_doe_b_136,t_doe_b_137 + + + implicit none + + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + +! !INPUT PARAMETERS: + + integer(i_kind) , intent(in ) :: lunin ! file unit from which to read observations + integer(i_kind) , intent(in ) :: mype ! mpi task id + integer(i_kind) , intent(in ) :: nele ! number of data elements per observation + integer(i_kind) , intent(in ) :: nobs ! number of observations + integer(i_kind) , intent(in ) :: is ! ndat index + logical , intent(in ) :: conv_diagsave ! logical to save innovation dignostics + + +! !INPUT/OUTPUT PARAMETERS: + + ! array containing information ... + real(r_kind),dimension(npres_print,nconvtype,5,3), intent(inout) :: bwork ! about o-g stats + real(r_kind),dimension(100+7*nsig) , intent(inout) :: awork ! for data counts and gross checks + +! !DESCRIPTION: For temperature observations, this routine +! \begin{enumerate} +! \item reads obs assigned to given mpi task (geographic region), +! \item simulates obs from guess, +! \item apply some quality control to obs, +! \item load weight and innovation arrays used in minimization +! \item collects statistics for runtime diagnostic output +! \item writes additional diagnostic information to output file +! \end{enumerate} +! +! !REVISION HISTORY: +! +! 1990-10-06 parrish +! 1998-04-10 weiyu yang +! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-17 treadon - update documentation +! 2004-07-15 todling - protex-compliant prologue; added intent/only's +! 2004-10-06 parrish - increase size of twork array for nonlinear qc +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list +! 2005-03-02 dee - remove garbage from diagnostic file +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-05-27 derber - level output change +! 2005-07-27 derber - add print of monitoring and reject data +! 2005-09-28 derber - combine with prep,spr,remove tran and clean up +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2005-10-21 su -modified variational qc and diagnostic output +! 2005-10-27 su - correct error in longitude index for diagnostic output +! 2005-11-03 treadon - correct error in ilone,ilate data array indices +! 2005-11-22 wu - add option to perturb conventional obs +! 2005-11-29 derber - remove psfcg and use ges_lnps instead +! 2005-12-20 parrish - add boundary layer forward model option +! 2005-12-20 parrish - correct dimension error in declaration of prsltmp +! 2006-01-31 todling - storing wgt/wgtlim in diag file instead of wgt only +! 2006-02-02 treadon - rename lnprsl as ges_lnprsl +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-03-21 treadon - modify optional perturbation to observation +! 2006-04-03 derber - optimize and fix bugs due to virtual temperature +! 2006-04-11 park - reset land mask for surface data based on observation type +! 2006-04-27 park - remove sensitivity test for surface TLM routine +! 2006-05-30 su,derber,treadon - modify diagnostic output +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - modify handling of multiple data at same location +! - unify NL qc for surface model +! 2006-07-31 kleist - use ges_ps instead of lnps +! 2006-08-28 su - fix a bug in variational qc +! 2006-09-28 treadon - add 10m wind factor to sfc_wtq_fwd call +! 2006-10-28 su - turn off rawinsonde Vqc at south hemisphere +! 2007-03-09 su - modify the observation perturbation +! 2007-03-19 tremolet - binning of observations +! 2007-06-05 tremolet - add observation diagnostics structure +! 2007-08-28 su - modify the observation gross check error +! 2008-03-24 wu - oberror tuning and perturb obs +! 2008-05-21 safford - rm unused vars +! 2008-09-08 lueken - merged ed's changes into q1fy09 code +! 2008-12-03 todling - changed handle of tail%time +! 2009-02-07 pondeca - for each observation site, add the following to the +! diagnostic file: local terrain height, dominate surface +! type, station provider name, and station subprovider name +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). +! 2010-06-10 Hu - add call for terrain match for surface T obs +! 2011-05-06 Su - modify the observation gross check error +! 2011-12-14 wu - add code for rawinsonde level enhancement ( ext_sonde ) +! 2011-10-14 Hu - add code for adjusting surface temperature observation error +! 2011-10-14 Hu - add code for producing pseudo-obs in PBL +! layer based on surface obs T +! 2011-10-14 Hu - add code for using 2-m temperature as background to +! calculate surface temperauture observation +! innovation +! 2013-01-26 parrish - change grdcrd to grdcrd1, tintrp2a to tintrp2a1, tintrp2a11, +! tintrp3 to tintrp31 (so debug compile works on WCOSS) +! 2013-05-17 zhu - add contribution from aircraft temperature bias correction +! - with option aircraft_t_bc_pof or aircraft_t_bc +! 2013-05-24 wu - move rawinsonde level enhancement ( ext_sonde ) to read_prepbufr +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (idia) to header of diagfile +! 2014-03-04 sienkiewicz - implementation of option aircraft_t_bc_ext (external table) +! 2014-04-12 su - add non linear qc from Purser's scheme +! 2014-10-01 zhu - apply aircraft temperature bias correction to kx=130 +! 2014-10-06 carley - add call to buddy check for twodvar_regional option +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-02-09 Sienkiewicz - handling new KX=199 drifting buoys +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2015-12-21 yang - Parrish's correction to the previous code in new +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-11-29 shlyaeva - save linearized H(x) for EnKF +! 2016-12-09 mccarty - add netcdf_diag capability +! 2017-03-31 Hu - addd option l_closeobs to use closest obs to analysis +! time in analysis +! 2017-03-31 Hu - addd option i_coastline to use observation operater +! for coastline area +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-04-09 pondeca - introduce duplogic to correctly handle the characterization of +! duplicate obs in twodvar_regional applications +! 2020-01-27 Winterbottom - moved the linear regression derived +! coefficients for the dynamic +! observation error (DOE) calculation to +! the namelist level; they are now +! loaded by obsmod. +! +! !REMARKS: +! language: f90 +! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq/HP +! +! !AUTHOR: +! parrish org: np22 date: 1990-10-06 +! +!EOP +!------------------------------------------------------------------------- + +! Declare local parameters + real(r_kind),parameter:: r0_001 = 0.001_r_kind + real(r_kind),parameter:: r0_7=0.7_r_kind + real(r_kind),parameter:: r8 = 8.0_r_kind + real(r_kind),parameter:: r3p5 = 3.5_r_kind + + character(len=*),parameter :: myname='setupt' + +! Declare external calls for code analysis + external:: SFC_WTQ_FWD + external:: get_tlm_tsfc + external:: tintrp2a1,tintrp2a11 + external:: tintrp31 + external:: grdcrd1 + external:: stop2 + +! Declare local variables + + real(r_kind) :: delz + + real(r_double) rstation_id + real(r_kind) rsig,drpx,rsigp + real(r_kind) psges,sfcchk,pres_diff,rlow,rhgh,ramp + real(r_kind) pof_idx,poaf,effective + real(r_kind) tges + real(r_kind) obserror,ratio,val2,obserrlm,ratiosfc + real(r_kind) residual,ressw2,scale,ress,ratio_errors,tob,ddiff + real(r_kind) val,valqc,dlon,dlat,dtime,dpres,error,prest,rwgt,var_jb + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,tfact + real(r_kind) cg_t,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2,qcgross + real(r_kind),dimension(nobs)::dup + real(r_kind),dimension(nsig):: prsltmp + real(r_kind),dimension(nele,nobs):: data + real(r_kind),dimension(npredt):: predbias + real(r_kind),dimension(npredt):: pred + real(r_kind),dimension(npredt):: predcoef + real(r_kind) tgges,roges + real(r_kind),dimension(nsig):: tvtmp,qtmp,utmp,vtmp,hsges + real(r_kind) u10ges,v10ges,t2ges,q2ges,psges2,f10ges + real(r_kind),dimension(34) :: ptablt + real(r_single),allocatable,dimension(:,:)::rdiagbuf + real(r_single),allocatable,dimension(:,:)::rdiagbufp + + + real(r_kind),dimension(nsig):: prsltmp2 + + integer(i_kind) i,j,nchar,nreal,k,ii,iip,jj,l,nn,ibin,idia,idia0,ix,ijb + integer(i_kind) mm1,jsig,iqt + integer(i_kind) itype,msges + integer(i_kind) ier,ilon,ilat,ipres,itob,id,itime,ikx,iqc,iptrb,icat,ipof,ivvlc,idx + integer(i_kind) ier2,iuse,ilate,ilone,ikxx,istnelv,iobshgt,izz,iprvd,isprvd + integer(i_kind) regime + integer(i_kind) idomsfc,iskint,iff10,isfcr + + integer(i_kind),dimension(nobs):: buddyuse + + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + + integer(i_kind) :: iz, t_ind, nind, nnz + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf,cdiagbufp + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical sfctype + logical iqtflg + logical aircraftobst + logical duplogic + + logical:: in_curbin, in_anybin, save_jacobian + logical proceed + type(tNode),pointer:: my_head + type(obs_diag),pointer:: jj_diag + type(obs_diag),pointer:: my_diag + type(obs_diag),pointer:: my_diag_pbl + type(obs_diags),pointer:: my_diagLL + + real(r_kind) :: thisPBL_height,ratio_PBL_height,prestsfc,diffsfc,dthetav + real(r_kind) :: tges2m,qges2m,tges2m_water,qges2m_water + real(r_kind) :: hr_offset + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + real(r_kind),allocatable,dimension(:,:,: ) :: ges_q2 + real(r_kind),allocatable,dimension(:,:,: ) :: ges_th2 + + logical:: l_pbl_pseudo_itype + integer(i_kind):: ich0 + + type(obsLList),pointer,dimension(:):: thead + thead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + +! call GSD terrain match for surface temperature observation + if(l_gsd_terrain_match_surftobs) then + call gsd_terrain_match_surfTobs(mype,nele,nobs,data) + endif + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + itob=5 ! index of t observation + id=6 ! index of station id + itime=7 ! index of observation time in data array + ikxx=8 ! index of ob type + iqt=9 ! index of flag indicating if moisture ob available + iqc=10 ! index of quality mark + ier2=11 ! index of original-original obs error ratio + iuse=12 ! index of use parameter + idomsfc=13 ! index of dominant surface type + iskint=14 ! index of surface skin temperature + iff10=15 ! index of 10 meter wind factor + isfcr=16 ! index of surface roughness + ilone=17 ! index of longitude (degrees) + ilate=18 ! index of latitude (degrees) + istnelv=19 ! index of station elevation (m) + iobshgt=20 ! index of observation height (m) + izz=21 ! index of surface height + iprvd=22 ! index of observation provider + isprvd=23 ! index of observation subprovider + icat=24 ! index of data level category + ijb=25 ! index of non linear qc parameter + if (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext) then + ipof=26 ! index of data pof + ivvlc=27 ! index of data vertical velocity + idx=28 ! index of tail number + iptrb=29 ! index of t perturbation + else + iptrb=26 ! index of t perturbation + end if + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + var_jb=zero + +! handle multiple reported data at a station + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if (twodvar_regional) then + duplogic=data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l) + else + duplogic=data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ipres,k) == data(ipres,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l) + end if + + if (duplogic) then + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)179.and.itype<190).or.(itype>=192.and.itype<=199) + + iqtflg=nint(data(iqt,i)) == 0 + var_jb=data(ijb,i) +! write(6,*) 'SETUPT:itype,var_jb,ijb=',itype,var_jb,ijb + +! Load observation value and observation error into local variables + tob=data(itob,i) + obserror = max(cermin(ikx),min(cermax(ikx),data(ier,i))) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => null() + my_diag_pbl => null() + + ich0=tNode_ich0; if(l_pbl_pseudo_itype) ich0=tNode_ich0_pbl_pseudo + do jj=1,ich0+1 + jj_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = jj ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(jj_diag)) then + call perr(myname,'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + call perr(myname,' ich =', jj) + call die(myname) + endif + + select case(jj) + case(1); my_diag => jj_diag + case(2); my_diag_pbl => jj_diag + end select + enddo + endif + + if(.not.in_curbin) cycle + +! Compute bias correction for aircraft data + if (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext) then + pof_idx = zero + do j = 1, npredt + pred(j) = zero + predbias(j) = zero + end do + end if + +! aircraftobst = itype>129.and.itype<140 + aircraftobst = (itype==131) .or. (itype>=133 .and. itype<=135) .or. (itype==130) !for currently known types + ix = 0 + if (aircraftobst .and. (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext)) then + ix = data(idx,i) + if (ix==0) then +! Inflate obs error for new tail number + if ( .not. aircraft_t_bc_ext ) & + data(ier,i) = 1.2_r_kind*data(ier,i) + else +! Bias for existing tail numbers + do j = 1, npredt + predcoef(j) = predt(j,ix) + end do + +! inflate obs error for any uninitialized tail number + if (all(predcoef==zero) .and. .not. aircraft_t_bc_ext) then + data(ier,i) = 1.2_r_kind*data(ier,i) + end if + +! define predictors + if (aircraft_t_bc) then + pof_idx = one + pred(1) = one + if (abs(data(ivvlc,i))>=50.0_r_kind) then + pred(2) = zero + pred(3) = zero + data(ier,i) = 1.2_r_kind*data(ier,i) + else + pred(2) = data(ivvlc,i) + pred(3) = data(ivvlc,i)*data(ivvlc,i) + end if + end if + if (aircraft_t_bc_pof) then +! data(ipof,i)==5 (ascending); 6 (descending); 3 (cruise level) + if (data(ipof,i) == 3.0_r_kind) then + pof_idx = one + pred(1) = one + pred(2) = zero + pred(3) = zero + else if (data(ipof,i) == 6.0_r_kind) then + pof_idx = one + pred(1) = zero + pred(2) = zero + pred(3) = one + else if (data(ipof,i) == 5.0_r_kind) then + pof_idx = one + pred(1) = zero + pred(2) = one + pred(3) = zero + else + pof_idx = zero + pred(1) = one + pred(2) = zero + pred(3) = zero + end if + end if + + if (aircraft_t_bc_ext) pred(1) = one + + do j = 1, npredt + predbias(j) = predcoef(j)*pred(j) + end do + end if + end if + +! Interpolate log(ps) & log(pres) at mid-layers to obs locations/times + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + + drpx=zero + if(sfctype .and. .not.twodvar_regional) then + drpx=abs(one-((one/exp(dpres-log(psges))))**rd_over_cp)*t0c + end if + +! Put obs pressure in correct units to get grid coord. number + call grdcrd1(dpres,prsltmp(1),nsig,-1) + +! Implementation of forward model ---------- + + if(sfctype.and.sfcmodel) then + tgges=data(iskint,i) + roges=data(isfcr,i) + + msges = 0 + if(itype == 180 .or. itype == 182 .or. itype == 183 .or. itype == 199) then !sea + msges=0 + elseif(itype == 181 .or. itype == 187 .or. itype == 188) then !land + msges=1 + endif + + call tintrp2a1(ges_tv,tvtmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a1(ges_q,qtmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a1(ges_u,utmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a1(ges_v,vtmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a1(geop_hgtl,hsges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + + psges2 = psges ! keep in cb + prsltmp2 = exp(prsltmp) ! convert from ln p to cb + call SFC_WTQ_FWD (psges2, tgges,& + prsltmp2(1), tvtmp(1), qtmp(1), utmp(1), vtmp(1), & + prsltmp2(2), tvtmp(2), qtmp(2), hsges(1), roges, msges, & + f10ges,u10ges,v10ges, t2ges, q2ges, regime, iqtflg) + tges = t2ges + + else + if(iqtflg)then +! Interpolate guess tv to observation location and time + call tintrp31(ges_tv,tges,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + + iz = max(1, min( int(dpres), nsig)) + delz = max(zero, min(dpres - float(iz), one)) + + if (save_jacobian) then + t_ind = getindex(svars3d, 'tv') + if (t_ind < 0) then + print *, 'Error: no variable tv in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = iz + sum(levels(1:t_ind-1)) + dhx_dx%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:t_ind-1)) + + dhx_dx%val(1) = one - delz ! weight for iz's level + dhx_dx%val(2) = delz ! weight for iz+1's level + endif + else +! Interpolate guess tsen to observation location and time + call tintrp31(ges_tsen,tges,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + + iz = max(1, min( int(dpres), nsig)) + delz = max(zero, min(dpres - float(iz), one)) + + if (save_jacobian) then + t_ind = getindex(svars3d, 'tsen') + if (t_ind < 0) then + print *, 'Error: no variable tsen in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = iz + sum(levels(1:t_ind-1)) + dhx_dx%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:t_ind-1)) + + dhx_dx%val(1) = one - delz ! weight for iz's level + dhx_dx%val(2) = delz ! weight for iz+1's level + endif + end if + + if(i_use_2mt4b>0 .and. sfctype) then + + if(i_coastline==1 .or. i_coastline==3) then + +! Interpolate guess th 2m to observation location and time + call tintrp2a11_csln(ges_th2,tges2m,tges2m_water,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + tges2m=tges2m*(r10*psges/r1000)**rd_over_cp_mass ! convert to sensible T + tges2m_water=tges2m_water*(r10*psges/r1000)**rd_over_cp_mass ! convert to sensible T + if(iqtflg)then + call tintrp2a11_csln(ges_q2,qges2m,qges2m_water,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + tges2m=tges2m*(one+fv*qges2m) ! convert to virtual T + tges2m_water=tges2m_water*(one+fv*qges2m_water) ! convert to virtual T + endif + if( abs(tob-tges2m) > abs(tob-tges2m_water)) tges2m=tges2m_water + else +! Interpolate guess th 2m to observation location and time + call tintrp2a11(ges_th2,tges2m,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + tges2m=tges2m*(r10*psges/r1000)**rd_over_cp_mass ! convert to sensible T + if(iqtflg)then + call tintrp2a11(ges_q2,qges2m,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + tges2m=tges2m*(one+fv*qges2m) ! convert to virtual T + endif + + endif + endif + + endif + +! Get approximate k value of surface by using surface pressure + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp(1),nsig,-1) + +! Check to see if observations is above the top of the model (regional mode) + if(sfctype)then + if(abs(dpres)>four) drpx=1.0e10_r_kind + pres_diff=prest-r10*psges + if (twodvar_regional .and. abs(pres_diff)>=r1000) drpx=1.0e10_r_kind + end if + rlow=max(sfcchk-dpres,zero) +! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] + if(l_sfcobserror_ramp_t) then + ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind) + else + ramp=rlow + endif + + rhgh=max(zero,dpres-rsigp-r0_001) + + if(sfctype.and.sfcmodel) dpres = one ! place sfc T obs at the model sfc + + if(luse(i))then + awork(1) = awork(1) + one + if(rlow/=zero) awork(2) = awork(2) + one + if(rhgh/=zero) awork(3) = awork(3) + one + end if + + ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+r8*ramp) + +! Compute innovation + if(i_use_2mt4b>0 .and. sfctype) then + ddiff = tob-tges2m + else + ddiff = tob-tges + endif + +! Setup dynamic error specification for aircraft recon in hurricanes + if (aircraft_recon) then + if ( itype == 136 ) then + ratio_errors=error/((t_doe_a_136*abs(ddiff)+t_doe_b_136)+1.0e6_r_kind*rhgh+r8*ramp) + endif + + if ( itype == 137 ) then + ratio_errors=error/((t_doe_a_137*abs(ddiff)+t_doe_b_137)+1.0e6_r_kind*rhgh+r8*ramp) + endif + endif + + error=one/error +! if (dpres > rsig) ratio_errors=zero + if (dpres > rsig )then + if( regional .and. prest > pt_ll )then + dpres=rsig + else + ratio_errors=zero + endif + endif + + +! Apply bias correction to innovation + if (aircraftobst .and. (aircraft_t_bc_pof .or. aircraft_t_bc .or. & + aircraft_t_bc_ext)) then + do j = 1, npredt + ddiff = ddiff - predbias(j) + end do + end if + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff = maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross error checks + + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + ratiosfc = ddiff/obserrlm + + ! modify gross check limit for quality mark=3 + if(data(iqc,i) == three ) then + qcgross=r0_7*cgross(ikx) + else + qcgross=cgross(ikx) + endif + + if (twodvar_regional) then + + ! Gross error relaxation for when buddycheck_t==.true. + if (buddycheck_t) then + if (buddyuse(i)==1) then + ! - Passed buddy check, relax gross qc + qcgross=r3p5*qcgross + data(iuse,i)=data(iuse,i)+0.50_r_kind ! So we can identify obs with relaxed gross qc + ! in diag files (will show as an extra 0.50 appended) + else if (buddyuse(i)==0) then + ! - Buddy check did not run (too few buddies, rusage >= 100, outside twindow, etc.) + ! - In the case of an isolated ob in complex terrain, see about relaxing the the gross qc + if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) then + qcgross=r3p5*qcgross ! Terrain aware modification + ! to gross error check + end if + else if (buddyuse(i)==-1) then + ! - Observation has failed the buddy check - reject. + ratio_errors = zero + end if + else if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) then + qcgross=r3p5*qcgross ! Terrain aware modification + ! to gross error check + end if + endif + + if (sfctype .and. i_sfct_gross==1) then +! extend the threshold for surface T + if(i_use_2mt4b<=0) tges2m=tges + if ( tges2m-273.15_r_single < 5.0_r_single) then + if (ratiosfc > 1.4_r_single*qcgross & + .or. ratiosfc < -2.4_r_single*qcgross & + .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(4) = awork(4)+one + error = zero + ratio_errors = zero + else + ratio_errors = ratio_errors/sqrt(dup(i)) + end if + else + if (ratiosfc > qcgross .or. ratiosfc < -1.4_r_single*qcgross & + .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(4) = awork(4)+one + error = zero + ratio_errors = zero + else + ratio_errors = ratio_errors/sqrt(dup(i)) + end if + endif + else + if (ratio > qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(4) = awork(4)+one + error = zero + ratio_errors = zero + else + ratio_errors = ratio_errors/sqrt(dup(i)) + end if + endif + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Oberror Tuning and Perturb Obs + if(muse(i)) then + if(oberror_tune )then + if( jiter > jiterstart ) then + ddiff=ddiff+data(iptrb,i)/error/ratio_errors + endif + else if(perturb_obs )then + ddiff=ddiff+data(iptrb,i)/error/ratio_errors + endif + endif + +! Compute penalty terms + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if(njqc .and. var_jb>tiny_r_kind .and. var_jb < 10.0_r_kind .and. error >tiny_r_kind) then + if(exp_arg == zero) then + wgt=one + else + wgt=ddiff*error/sqrt(two*var_jb) + wgt=tanh(wgt)/wgt + endif + term=-two*var_jb*rat_err2*log(cosh((val)/sqrt(two*var_jb))) + rwgt = wgt/wgtlim + valqc = -two*term + else if (vqc .and. cvar_pg(ikx)> tiny_r_kind .and. error >tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_t=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_t*wnotgross) + term =log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + valqc = -two*rat_err2*term + else + term = exp_arg + wgt = one + rwgt = wgt/wgtlim + valqc = -two*rat_err2*term + endif + +! Accumulate statistics for obs belonging to this task + if(muse(i))then + if(rwgt < one) awork(21) = awork(21)+one + jsig = dpres + jsig=max(1,min(jsig,nsig)) + awork(jsig+3*nsig+100)=awork(jsig+3*nsig+100)+valqc + awork(jsig+5*nsig+100)=awork(jsig+5*nsig+100)+one + awork(jsig+6*nsig+100)=awork(jsig+6*nsig+100)+val2*rat_err2 + end if + +! Loop over pressure level groupings and obs to accumulate statistics +! as a function of observation type. + ress = ddiff*scale + ressw2 = ress*ress + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + do k = 1,npres_print + if(prest >ptop(k) .and. prest <= pbot(k))then + bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count + bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ress ! (o-g) + bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + end do + end if + +! Fill obs diagnostics structure + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) +! if ( .not. last .and. muse(i)) then + if (muse(i)) then + + allocate(my_head) + call tNode_appendto(my_head,thead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%ich0= tNode_ich0 + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + + allocate(my_head%pred(npredt)) + +! Set (i,j,k) indices of guess gridpoint that bound obs location + my_head%dlev= dpres + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%jb = var_jb + my_head%use_sfc_model = sfctype.and.sfcmodel + if(my_head%use_sfc_model) then + call get_tlm_tsfc(my_head%tlm_tsfc(1), & + psges2,tgges,prsltmp2(1), & + tvtmp(1),qtmp(1),utmp(1),vtmp(1),hsges(1),roges,msges, & + regime,iqtflg) + else + my_head%tlm_tsfc = zero + endif + my_head%luse = luse(i) + my_head%tv_ob = iqtflg + + if (aircraft_t_bc_pof .or. aircraft_t_bc) then + effective=upd_pred_t*pof_idx + my_head%idx = data(idx,i) + do j=1,npredt + my_head%pred(j) = pred(j)*effective + end do + end if + + +! summation of observation number + if (luse(i) .and. aircraftobst .and. (aircraft_t_bc_pof .or. aircraft_t_bc) .and. ix/=0) then + do j=1,npredt + if (aircraft_t_bc_pof) then + poaf=data(ipof,i) + if (poaf==3.0_r_kind .or. poaf==5.0_r_kind .or. poaf==6.0_r_kind) then + if (j==1 .and. poaf == 3.0_r_kind) ostats_t(1,ix) = ostats_t(1,ix) + one_quad + if (j==2 .and. poaf == 5.0_r_kind) ostats_t(2,ix) = ostats_t(2,ix) + one_quad + if (j==3 .and. poaf == 6.0_r_kind) ostats_t(3,ix) = ostats_t(3,ix) + one_quad + rstats_t(j,ix)=rstats_t(j,ix)+my_head%pred(j) & + *my_head%pred(j)*(ratio_errors*error)**2*effective + end if + end if + + if (aircraft_t_bc) then + if (j==1) ostats_t(1,ix) = ostats_t(1,ix) + one_quad*effective + rstats_t(j,ix)=rstats_t(j,ix)+my_head%pred(j) & + *my_head%pred(j)*(ratio_errors*error)**2*effective + end if + + end do + end if + + if(oberror_tune) then + my_head%kx=ikx + my_head%tpertb=data(iptrb,i)/error/ratio_errors + if (njqc) then + ptablt=ptabl_t + else + ptablt=ptabl + endif + + if(prest > ptablt(2))then + my_head%k1=1 + else if( prest <= ptablt(33)) then + my_head%k1=33 + else + k_loop: do k=2,32 + if(prest > ptablt(k+1) .and. prest <= ptablt(k)) then + my_head%k1=k + exit k_loop + endif + enddo k_loop + endif + endif + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,my_head%ich0+1, myname,'my_diag:my_head') + my_head%diags => my_diag + + endif + + my_head => null() + endif + +! Save select output for diagnostic file + if (conv_diagsave .and. luse(i)) then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input=one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst + if (err_final>tiny_r_kind) errinv_final=one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + end if + + +!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!! + if( .not. last .and. l_pbl_pseudo_itype .and. & + muse(i) .and. dpres > -1.0_r_kind ) then + prestsfc=prest + diffsfc=ddiff + dthetav=ddiff*(r1000/prestsfc)**rd_over_cp_mass + + call tintrp2a11(pbl_height,thisPBL_height,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) +! + if (dthetav< -1.0_r_kind) then + call tune_pbl_height(mype,dlat,dlon,prestsfc,thisPBL_height,dthetav) + endif +! + ratio_PBL_height = (prest - thisPBL_height) * pblh_ration + if(ratio_PBL_height > zero) thisPBL_height = prest - ratio_PBL_height + prest = prest - pps_press_incr + DO while (prest > thisPBL_height) + ratio_PBL_height=1.0_r_kind-(prestsfc-prest)/(prestsfc-thisPBL_height) + + allocate(my_head) + call tNode_appendto(my_head,thead(ibin)) + + allocate(my_head%pred(npredt)) + +!!! find tob (tint) + tob=data(itob,i) + +! Put obs pressure in correct units to get grid coord. number + dpres=log(prest/r10) + call grdcrd1(dpres,prsltmp(1),nsig,-1) + +!!! find tges (tgint) + if(iqtflg)then +! Interpolate guess tv to observation location and time + call tintrp31(ges_tv,tges,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + + else +! Interpolate guess tsen to observation location and time + call tintrp31(ges_tsen,tges,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + endif + +!!! Set (i,j,k) indices of guess gridpoint that bound obs location + my_head%dlev= dpres + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) +!!! find ddiff + ddiff = diffsfc*(0.5_r_kind + 0.5_r_kind*ratio_PBL_height) + + error=one/data(ier2,i) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%ich0= tNode_ich0_pbl_pseudo + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%jb = var_jb + my_head%use_sfc_model = sfctype.and.sfcmodel + if(my_head%use_sfc_model) then + call get_tlm_tsfc(my_head%tlm_tsfc(1), & + psges2,tgges,prsltmp2(1), & + tvtmp(1),qtmp(1),utmp(1),vtmp(1),hsges(1),roges,msges, & + regime,iqtflg) + else + my_head%tlm_tsfc = zero + endif + my_head%luse = luse(i) + my_head%tv_ob = iqtflg + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag_pbl, my_head%idv,my_head%iob,my_head%ich0+1, myname,'my_diag_pbl:my_head') + + ! PBL pseudo T obs does not a separate QC (muse) + call obsdiagNode_set(my_diag_pbl, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=my_head%res) + + my_head%diags => my_diag_pbl + endif + +! Save select output for diagnostic file + if (conv_diagsave .and. luse(i)) then + iip=iip+1 + if(iip <= 3*nobs) then + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input=one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst + if (err_final>tiny_r_kind) errinv_final=one/err_final + + if(binary_diag) call contents_binary_diagp_ + + else + iip=nobs + endif + if(netcdf_diag) call contents_netcdf_diagp_ + end if + + prest = prest - pps_press_incr + + my_head => null() + + ENDDO + + endif ! 181,183,187 +!!!!!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!!!!!!!!! + +! End of loop over observations + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)' t',nchar,nreal,ii+iip,mype,idia0 + if(l_pbl_pseudo_surfobst .and. iip>0) then + write(7)cdiagbuf(1:ii),cdiagbufp(1:iip),rdiagbuf(:,1:ii),rdiagbufp(:,1:iip) + deallocate(cdiagbufp,rdiagbufp) + else + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + endif + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if + end if + + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::u' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::v' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::q', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get u ... + varname='u' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_u))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_u(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_u(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get v ... + varname='v' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_v))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_v(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_v(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get q ... + varname='q' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_q))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_q(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_q(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + if(i_use_2mt4b>0) then +! get th2m ... + varname='th2m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_th2(size(rank2,1),size(rank2,2),nfldsig)) + ges_th2(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_th2(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get q2m ... + varname='q2m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_q2(size(rank2,1),size(rank2,2),nfldsig)) + ges_q2(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_q2(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + +! open netcdf diag file + write(string,900) jiter +900 format('conv_t_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("Number_of_Predictors", npredt ) ! number of updating bias correction predictors + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + + end subroutine init_netcdf_diag_ + + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = prest ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = data(iqt,i) ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + +!rdiagbuf(13,ii) is the combination of var_jb and non-linear qc relative weight +! in the format of: var_jb*1.0e+6 + rwgt + rdiagbuf(13,ii) = var_jb*1.0e+6_r_single + rwgt ! combination of var_jb and rwgt + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(itob,i) ! temperature observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = tob-tges ! obs-ges w/o bias correction (K) (future slot) + rdiagbuf(20,ii) = 1.e10_r_single ! spread (filled in by EnKF) + if (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext) then + rdiagbuf(20,ii) = data(ipof,i) ! data pof + rdiagbuf(21,ii) = data(ivvlc,i) ! data vertical velocity + do j=1,npredt + rdiagbuf(21+j,ii) = predbias(j) + end do + end if + + idia=idia0 + if (lobsdiagsave) then + do jj=1,miter + idia=idia+1 + if (odiag%muse(jj)) then + rdiagbuf(idia,ii) = one + else + rdiagbuf(idia,ii) = -one + endif + enddo + do jj=1,miter+1 + idia=idia+1 + rdiagbuf(idia,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + idia = idia + 1 + rdiagbuf(idia,ii) = data(idomsfc,i) ! dominate surface type + idia = idia + 1 + rdiagbuf(idia,ii) = data(izz,i) ! model terrain at observation location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(idia+1:nreal,ii)) + idia = idia + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + + subroutine contents_binary_diagp_ + + cdiagbufp(iip) = station_id ! station id + + rdiagbufp(1,iip) = ictype(ikx) ! observation type + rdiagbufp(2,iip) = icsubtype(ikx) ! observation subtype + + rdiagbufp(3,iip) = data(ilate,i) ! observation latitude (degrees) + rdiagbufp(4,iip) = data(ilone,i) ! observation longitude (degrees) + rdiagbufp(5,iip) = data(istnelv,i) ! station elevation (meters) + rdiagbufp(6,iip) = prest ! observation pressure (hPa) + rdiagbufp(7,iip) = data(iobshgt,i) ! observation height (meters) + rdiagbufp(8,iip) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbufp(9,iip) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbufp(10,iip) = data(iqt,i) ! setup qc or event mark + rdiagbufp(11,iip) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbufp(12,iip) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbufp(12,iip) = -one + endif + + !rdiagbuf(13,ii) is the combination of var_jb and non-linear qc relative weight + ! in the format of: var_jb*1.0e+6 + rwgt + rdiagbufp(13,iip) = var_jb*1.0e+6_r_single + rwgt ! combination of var_jb and rwgt + rdiagbufp(14,iip) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbufp(15,iip) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbufp(16,iip) = errinv_final ! final inverse observation error (K**-1) + + rdiagbufp(17,iip) = data(itob,i) ! temperature observation (K) + rdiagbufp(18,iip) = ddiff ! obs-ges used in analysis (K) + rdiagbufp(19,iip) = ddiff ! tob-tges ! obs-ges w/o bias correction (K) (future slot) + rdiagbufp(20,iip) = 1.e10_r_single ! spread (filled in by EnKF) + + idia=idia0 + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(idia+1:nreal,ii)) + idia = idia + size(dhx_dx) + endif + + end subroutine contents_binary_diagp_ + + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' t' + real(r_single),parameter:: missing = -9.99e9_r_single + + real(r_kind),dimension(miter) :: obsdiag_iuse + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) +! call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(prest) ) + call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Setup_QC_Mark", sngl(data(iqt,i)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata("Observation", sngl(data(itob,i)) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(tob-tges) ) + if (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext) then + call nc_diag_metadata("Data_Pof", sngl(data(ipof,i)) ) + if (npredt .gt. one) then + call nc_diag_data2d("Bias_Correction_Terms", sngl(predbias) ) + else if (npredt .eq. one) then + call nc_diag_metadata("Bias_Correction_Terms", sngl(predbias(1)) ) + endif + else + call nc_diag_metadata("Data_Pof", missing ) + if (npredt .gt. one) then + do j=1,npredt + predbias(j) = missing + enddo + call nc_diag_data2d("Bias_Correction_Terms", sngl(predbias) ) + else if (npredt .eq. one) then + call nc_diag_metadata("Bias_Correction_Terms", missing ) + endif + endif + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diag_ + + subroutine contents_netcdf_diagp_ +! Observation class + character(7),parameter :: obsclass = ' t' + real(r_single),parameter:: missing = -9.99e9_r_single + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) +! call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(prest) ) + call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Setup_QC_Mark", sngl(data(iqt,i)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(var_jb*1.0e+6+rwgt)) + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata("Observation", sngl(data(itob,i)) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(ddiff) ) + + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diagp_ + + subroutine final_vars_ + if(allocated(ges_q )) deallocate(ges_q ) + if(allocated(ges_tv)) deallocate(ges_tv) + if(allocated(ges_v )) deallocate(ges_v ) + if(allocated(ges_u )) deallocate(ges_u ) + if(allocated(ges_ps)) deallocate(ges_ps) + end subroutine final_vars_ + +end subroutine setupt + + +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI ! +!------------------------------------------------------------------------- +!BOP +! +! !ROUTINE: ifind --- find character string in sorted list +! +! !INTERFACE: +integer(i_kind) function ifind (sid,xsid,nsid) + +! !USES: + use kinds, only: i_kind + implicit none + +! !INPUT PARAMETERS: + integer(i_kind) nsid + character(len=8) sid(nsid), xsid + +! !DESCRIPTION: Find character string in a sorted list - used to +! find aircraft tail id from list for bias correction +! +! !REVISION HISTORY: +! +! 2013-04-23 sienkiewicz Original routine +! +!EOP +!------------------------------------------------------------------------- + + +! Declare local variables + integer(i_kind) istart,iend,imid + + if (xsid > sid(nsid) .or. xsid < sid(1)) then + ifind = 0 + return + end if + istart=0 + iend=nsid+1 + do while (iend-istart > 1) + imid=(istart+iend)/2 + if (xsid == sid(imid)) then + ifind = imid + return + else if (xsid > sid(imid)) then + istart = imid + else + iend = imid + endif + end do + + if (xsid == sid(iend)) then + ifind = imid + else + ifind = 0 + end if + return +end function ifind +end module t_setup diff --git a/src/gsi/setuptcamt.f90 b/src/gsi/setuptcamt.f90 new file mode 100644 index 000000000..a20abb934 --- /dev/null +++ b/src/gsi/setuptcamt.f90 @@ -0,0 +1,655 @@ +module tcamt_setup + implicit none + private + public:: setup + interface setup; module procedure setuptcamt; end interface + +contains +subroutine setuptcamt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuptcamt compute rhs for total cloud amout +! prgmmr: derber org: np23 date: 2004-07-20 +! +! abstract: For sea surface temperature observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2012-01-29 zhu +! 2014-06-19 carley - update for metguess bundle, change tintrp2a to tintrp2a11 +! for debug compile on WCOSS, write sensitivity slot indicator +! (ioff) to header of diagfile, remove unused vars +! 2015-03-11 pondeca - Modify for possibility of not using obsdiag +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-01-08 pondeca - addd option l_closeobs to use closest obs to analysis +! time in analysis +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,ianldate,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset + use m_obsNode , only: obsNode + use m_tcamtNode, only: tcamtNode + use m_tcamtNode, only: tcamtNode_appendto + use m_obsLList , only: obsLList + use obsmod, only: luse_obsdiag + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig + use gridmod, only: get_ij + use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,& + two,cg_term,huge_single,r1000 + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use rapidrefresh_cldsurf_mod, only: l_closeobs + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local variables + real(r_kind), parameter:: miss_obs=10.e10_r_kind + + real(r_double) rstation_id + + real(r_kind) tcamtges,dlat,dlon,ddiff,dtime,error + real(r_kind) scale,val2,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,rwgt + real(r_kind) cg_tcamt,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,izz,itcamt,id,itime,ikx,iqc + integer(i_kind) iuse,ilate,ilone,istnelv,iobshgt,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc,iskint,iff10,isfcr + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin, proceed + type(tcamtNode),pointer:: my_head + type(obs_diag ),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + character(len=*),parameter:: myname='setuptcamt' + + real(r_kind),allocatable,dimension(:,:,:) :: ges_tcamt + + real(r_kind) :: hr_offset + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + type(obsLList),pointer,dimension(:):: tcamthead + tcamthead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + print *, 'Whoa! We have some missing metguess variables in setuptcamt.f90....returning to setuprhsall.f90 after advancing through input file' + read(lunin)data,luse,ioid + return ! not all vars available, simply return + end if + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + itcamt=4 ! index of tcamt observation + id=5 ! index of station id + itime=6 ! index of observation time in data array + ikxx=7 ! index of ob type + iqc=8 ! index of qulaity mark + iuse=9 ! index of use parameter + idomsfc=10 ! index of dominant surface type + iskint=11 ! index of surface skin temperature + iff10=12 ! index of 10 meter wind factor + isfcr=13 ! index of surface roughness + ilone=14 ! index of longitude (degrees) + ilate=15 ! index of latitude (degrees) + istnelv=16 ! index of station elevation (m) + iobshgt=17 ! index of observation height (m) + izz=18 ! index of model terrain height at ob location + iprvd=19 ! index of provider + isprvd=20 ! index of subprovider + + mm1=mype+1 + scale=one + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for missing data + if (.not. oneobtest) then + do i=1,nobs + if (abs(data(itcamt,i)-miss_obs)<100.0_r_kind) then + muse(i)=.false. + data(itcamt,i)=rmiss_single ! for diag output + end if + end do + end if + +! Check for duplicate observations at same location + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'null obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + end if + + if(.not.in_curbin) cycle + +! Interpolate to get tcamt at obs location/time + call tintrp2a11(ges_tcamt,tcamtges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + if(luse(i))then + awork(1) = awork(1) + one + end if + +! Adjust observation error + ratio_errors=error/(data(ier,i)*sqrt(dup(i))) + error=one/error + +! Compute innovations + ddiff=data(itcamt,i)-tcamtges + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross check using innovation normalized by error + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + end if + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_tcamt=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_tcamt*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + end if + ress = ddiff*scale + ressw2 = ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + if (abs(data(itcamt,i)-rmiss_single) >=tiny_r_kind) then + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + end if + + endif + + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call tcamtNode_appendto(my_head,tcamthead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1_i_kind,myname,'my_diag:my_head') + my_head%diags => my_diag + end if + + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag)then + write(7)'tca',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::tcamt' , ivar, istatus ) + proceed=ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get tcamt ... + varname='tcamt' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_tcamt))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tcamt(size(rank2,1),size(rank2,2),nfldsig)) + ges_tcamt(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_tcamt(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_tcamt_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! model terrain at ob location + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(itcamt,i) ! tcamt observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(itcamt,i)-tcamtges! obs-ges w/o bias correction (K) (future slot) + + rdiagbuf(20,ii) = rmiss_single ! type of measurement + + rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(22,ii) = data(izz,i) ! model terrain at observation location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + + if (lobsdiagsave) then + ioff=ioff0 + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' tcamt' + real(r_kind),parameter:: missing = -9.99e9_r_kind + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", missing ) + call nc_diag_metadata("Height", data(iobshgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(itcamt,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(itcamt,i)-tcamtges ) + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_tcamt)) deallocate(ges_tcamt) + end subroutine final_vars_ + +end subroutine setuptcamt +end module tcamt_setup diff --git a/src/gsi/setuptcp.f90 b/src/gsi/setuptcp.f90 new file mode 100644 index 000000000..c00daac84 --- /dev/null +++ b/src/gsi/setuptcp.f90 @@ -0,0 +1,714 @@ +module tcp_setup + implicit none + private + public:: setup + interface setup; module procedure setuptcp; end interface + +contains +subroutine setuptcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuptcp setup tcpel data +! prgmmr: kleist org: np20 date: 2009-02-02 +! +! abstract: Setup routine for TC MSLP data +! +! program history log: +! 2009-02-02 kleist +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). +! 2010-05-25 kleist - output tc_ps observations to conv diag file +! 2010-11-24 todling - add component to write obs sensitiviy to diag file +! 2013-01-26 parrish - change grdcrd to grdcrd1, intrp2a to intrp2a11, +! tintrp2a to tintrp2a1, tintrp2a11 (so debug compile works on WCOSS) +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (idia) to header of diagfile +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-11-29 shlyaeva - save linearized H(x) for EnKF +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr,getindex + use state_vectors, only: ns3d, svars2d, levels, nsdim + use sparsearr, only: sparr2, new, size, writearray, fullarray + use kinds, only: r_kind,i_kind,r_single,r_double + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: & + nobskeep,lobsdiag_allocated,oberror_tune,perturb_obs, & + time_offset,rmiss_single,lobsdiagsave,lobsdiag_forenkf,ianldate + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use m_obsNode, only: obsNode + use m_tcpNode, only: tcpNode + use m_tcpNode, only: tcpNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin + use qcmod, only: npres_print + use guess_grids, only: ges_lnprsl,nfldsig,hrdifsig, & + ntguessig + use gridmod, only: get_ij,nsig + use constants, only: zero,half,one,tiny_r_kind,two,cg_term, & + wgtlim,g_over_rd,huge_r_kind,pi,huge_single,tiny_single,r10 + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,& + icsubtype + use jfunc, only: jiter,last,jiterstart,miter + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + implicit none + + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + integer(i_kind) ,intent(in ) :: is ! ndat index + + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork ! obs-ges stats + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork ! data counts and gross checks + + logical ,intent(in) :: conv_diagsave + +! Declare external calls for code analysis + external:: intrp2a11,tintrp2a1,tintrp2a11 + external:: tintrp3 + external:: grdcrd1 + external:: stop2 + +! DECLARE LOCAL PARMS HERE + real(r_double) rstation_id + character(8) station_id + equivalence(rstation_id,station_id) + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + real(r_kind) err_input,err_adjst,err_final,errinv_input,errinv_adjst,errinv_final + real(r_kind) scale,ratio,obserror,obserrlm + real(r_kind) residual,ress,ressw2,val,val2 + real(r_kind) valqc,tges,tges2 + real(r_kind) wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2 + real(r_kind) rwgt,cg_ps,drbx + real(r_kind) error,dtime,dlon,dlat,r0_001,r2_5,r0_2,rsig + real(r_kind) ratio_errors,psges,zsges,rdp,drdp + real(r_kind) pob,pges,pgesorig,half_tlapse,ddiff,halfpi,r0_005,rdelz,psges2 + + real(r_kind),dimension(nele,nobs):: data + real(r_kind),dimension(nsig)::prsltmp + + type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array + integer(i_kind) :: ps_ind, nind, nnz + + integer(i_kind) i,jj + integer(i_kind) mm1,idia,idia0 + integer(i_kind) ikxx,nn,iuse,ibin,iptrb,id + integer(i_kind) ier,ilon,ilat,ipres,itime,ikx,ilate,ilone + + logical:: in_curbin, in_anybin, save_jacobian + type(tcpNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + character(len=*),parameter:: myname='setuptcp' + + character(8),allocatable,dimension(:):: cdiagbuf + real(r_single),allocatable,dimension(:,:)::rdiagbuf + integer(i_kind) nchar,nreal,ii + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + + type(obsLList),pointer,dimension(:):: tcphead + tcphead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!****************************************************************************** +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + itime=5 ! index of time observation + ikxx=6 ! index of observation type in data array + ilone=7 ! index of longitude (degrees) + ilate=8 ! index of latitude (degrees) + iuse=9 ! index of usage parameter + id=10 ! index of storm name + + mm1=mype+1 + scale=one + rsig=nsig + halfpi = half*pi + r0_005 = 0.005_r_kind + r0_2=0.2_r_kind + r2_5=2.5_r_kind + half_tlapse=0.00325_r_kind ! half of 6.5K/1km + r0_001=0.001_r_kind + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + if(conv_diagsave)then + nchar=1 + idia0=20 + nreal=idia0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (save_jacobian) then + nnz = 1 + nind = 1 + call new(dhx_dx, nnz, nind) + nreal = nreal + size(dhx_dx) + endif + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + ii=0 + if(netcdf_diag) call init_netcdf_diag_ + end if + + + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + pob=data(ipres,i) + + error=data(ier,i) + ikx=nint(data(ikxx,i)) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if ( luse_obsdiag ) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if ( luse_obsdiag ) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Get guess sfc hght at obs location + call intrp2a11(ges_z(1,1,ntguessig),zsges,dlat,dlon,mype) + +! Interpolate to get log(ps) and log(pres) at mid-layers +! at obs location/time + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + +! Convert pressure to grid coordinates + pgesorig = psges + +! Take log for vertical interpolation + psges = log(psges) + call grdcrd1(psges,prsltmp,nsig,-1) + +! Get guess temperature at observation location and surface + call tintrp31(ges_tv,tges,dlat,dlon,psges,dtime, & + hrdifsig,mype,nfldsig) + +! Adjust observation error and obs value due to differences in surface height + rdelz=-zsges + +! No observed temperature + psges2=data(ipres,i) + call grdcrd1(psges2,prsltmp,nsig,-1) + call tintrp31(ges_tv,tges2,dlat,dlon,psges2,dtime, & + hrdifsig,mype,nfldsig) + + drbx = half*abs(tges-tges2)+r2_5+r0_005*abs(rdelz) + tges = half*(tges+tges2) + +! Extrapolate surface temperature below ground at 6.5 k/km +! note only extrapolating .5dz, if no surface temp available. + if(rdelz < zero)then + tges=tges-half_tlapse*rdelz + drbx=drbx-half_tlapse*rdelz + end if + +! Adjust guess hydrostatically + rdp = g_over_rd*rdelz/tges + +! Subtract off dlnp correction, then convert to pressure (cb) + pges = exp(log(pgesorig) - rdp) + + if (save_jacobian) then + ps_ind = getindex(svars2d, 'ps') + if (ps_ind < 0) then + print *, 'Error: no variable ps in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx%st_ind(1) = sum(levels(1:ns3d)) + ps_ind + dhx_dx%end_ind(1) = sum(levels(1:ns3d)) + ps_ind + dhx_dx%val(1) = one + endif + +! Compute innovations + ddiff=pob-pges ! in cb + +! Oberror Tuning and Perturb Obs + if(muse(i)) then + if(oberror_tune )then + if( jiter > jiterstart ) then + ddiff=ddiff+data(iptrb,i)/error/ratio_errors + endif + else if(perturb_obs )then + ddiff=ddiff+data(iptrb,i)/error/ratio_errors + endif + endif + +! observational error adjustment + drdp = pges*(g_over_rd*abs(rdelz)*drbx/(tges**2)) + +! find adjustment to observational error (in terms of ratio) + ratio_errors=error/(error+drdp) + error=one/error + +! Gross error checks + obserror = min(r10/max(ratio_errors*error,tiny_r_kind),huge_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(r10*ddiff) + ratio = residual/obserrlm + if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors = zero + else +! No duplicate check + end if + + if (ratio_errors*error <= tiny_r_kind) muse(i)=.false. + + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + + val = error*ddiff + if(luse(i))then + +! Compute penalty terms (linear & nonlinear qc). + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error >tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_ps=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_ps*wnotgross) + term =log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + + + if (muse(i)) then +! Accumulate statistics for obs used belonging to this task + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + nn=1 + else + +! rejected obs + nn=2 +! monitored obs + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + + +! Accumulate statistics for each ob type + + ress = ddiff*r10 + ressw2 = ress*ress + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + endif + + if (.not. last .and. muse(i)) then + + allocate(my_head) + call tcpNode_appendto(my_head,tcphead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + if(oberror_tune) then + my_head%kx = ikx ! data type for oberror tuning + my_head%ppertb= data(iptrb,i)/error/ratio_errors ! obs perturbation + endif + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1, myname,'my_diag:my_head') + my_head%diags => my_diag + endif + + my_head => null() + endif + +! Save obs and simulated surface pressure data for diagnostic output + + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + pob = pob*r10 + pges = pges*r10 + pgesorig = pgesorig*r10 + err_input = data(ier,i)*r10 ! r10 converts cb to mb + err_adjst = data(ier,i)*r10 + if (ratio_errors*error/r10>tiny_r_kind) then + err_final = r10/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_single) errinv_input = one/err_input + if (err_adjst>tiny_single) errinv_adjst = one/err_adjst + if (err_final>tiny_single) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if ! conv_diagsave .true. and luse .true. + +! End of loop over observations + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'tcp',nchar,nreal,ii,mype,idia0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + end if + end if + + +! End of routine + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_tcp_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = 0 ! station elevation (meters) + rdiagbuf(6,ii) = data(ipres,i)*r10 ! observation pressure (hPa) + rdiagbuf(7,ii) = 0 ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = 1 ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = 1 ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (hPa**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (hPa**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (hPa**-1) + + rdiagbuf(17,ii) = pob ! surface pressure observation (hPa) + rdiagbuf(18,ii) = pob-pges ! obs-ges used in analysis (coverted to hPa) + rdiagbuf(19,ii) = pob-pgesorig ! obs-ges w/o adjustment to guess surface pressure (hPa) + rdiagbuf(20,ii) = 1.e+10_r_single ! spread (filled in by EnKF) + + idia=idia0 + if (lobsdiagsave) then + do jj=1,miter + idia=idia+1 + if (odiag%muse(jj)) then + rdiagbuf(idia,ii) = one + else + rdiagbuf(idia,ii) = -one + endif + enddo + do jj=1,miter+1 + idia=idia+1 + rdiagbuf(idia,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + idia=idia+1 + rdiagbuf(idia,ii) = odiag%obssen(jj) + enddo + endif + if (save_jacobian) then + call writearray(dhx_dx, rdiagbuf(idia+1:nreal,ii)) + idia = idia + size(dhx_dx) + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' tcp' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(zero) ) + call nc_diag_metadata("Pressure", sngl(data(ipres,i)*r10)) + call nc_diag_metadata("Height", sngl(zero) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(one) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(one) ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(pob) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(pob-pges) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(pob-pgesorig)) + + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (save_jacobian) then + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_tv)) deallocate(ges_tv) + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps)) deallocate(ges_ps) + end subroutine final_vars_ + +end subroutine setuptcp +end module tcp_setup diff --git a/src/gsi/setuptd2m.f90 b/src/gsi/setuptd2m.f90 new file mode 100644 index 000000000..9e54171bd --- /dev/null +++ b/src/gsi/setuptd2m.f90 @@ -0,0 +1,692 @@ +module td2m_setup + implicit none + private + public:: setup + interface setup; module procedure setuptd2m; end interface + +contains +subroutine setuptd2m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setuptd2m compute rhs of oi for conventional 2m dew point +! prgmmr: pondeca org: np23 date: 2014-04-10 +! +! abstract: For 2-m dew point observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2014-04-10 pondeca +! 2015-03-11 pondeca - Modify for possibility of not using obsdiag +! before retuning to setuprhsall.f90 +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! . removed (%dlat,%dlon) debris. +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use m_obsNode , only: obsNode + use m_td2mNode, only: td2mNode + use m_td2mNode, only: td2mNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: rmiss_single, & + lobsdiagsave,nobskeep,lobsdiag_allocated, & + time_offset,bmiss,luse_obsdiag,ianldate + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig,get_ij,twodvar_regional + use constants, only: zero,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & + two,cg_term,huge_single,three + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_7=0.7_r_kind + + character(len=*),parameter:: myname='setuptd2m' + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) td2mges,dlat,dlon,ddiff,dtime,error + real(r_kind) scale,val2,ratio,ressw2,ress,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,rwgt + real(r_kind) cg_td2m,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,ipres,itd2m,id,itime,ikx,imaxerr,iqc,iskint,iff10 + integer(i_kind) ier2,iuse,ilate,ilone,itemp,istnelv,isfcr,iobshgt,izz,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin + type(td2mnode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !will probably need at some poin + real(r_kind),allocatable,dimension(:,:,:) :: ges_z !will probably need at some poin + real(r_kind),allocatable,dimension(:,:,:) :: ges_td2m + + type(obsLList),pointer,dimension(:):: td2mhead + td2mhead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + itd2m=5 ! index of td2m observation + id=6 ! index of station id + itime=7 ! index of observation time in data array + ikxx=8 ! index of ob type + imaxerr=9 ! index of max error + itemp=10 ! index of dry temperature + iqc=11 ! index of quality mark + ier2=12 ! index of original obs error + iuse=13 ! index of use parameter + idomsfc=14 ! index of dominant surface type + iskint=15 ! index of surface skin temperature + iff10=16 ! index of 10 meter wind factor + isfcr=17 ! index of surface roughness + ilone=18 ! index of longitude (degrees) + ilate=19 ! index of latitude (degrees) + istnelv=20 ! index of station elevation (m) + iobshgt=21 ! index of observation height (m) + izz=22 ! index of surface height + iprvd=23 ! index of observation provider + isprvd=24 ! index of observation subprovider + + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) + dup(k)=dup(k)+one-tfact*tfact*(one-dfact) + dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + end if + end do + end do + + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + ii=0 + nchar=1 + ioff0=19 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + if(netcdf_diag) call init_netcdf_diag_ + end if + + + mm1=mype+1 + scale=one + + call dtime_setup() + do i=1,nobs + dtime=data(itime,i) + call dtime_check(dtime, in_curbin, in_anybin) + if(.not.in_anybin) cycle + + if(in_curbin) then + dlat=data(ilat,i) + dlon=data(ilon,i) + + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + +! Interpolate guess td2m to observation location and time + call tintrp2a11(ges_td2m,td2mges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + ddiff=data(itd2m,i)-td2mges + +! Adjust observation error + ratio_errors=error/data(ier,i) + error=one/error + +! Gross error checks + + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + +! modify gross check limit for quality mark=3 + if(data(iqc,i) == three ) then + qcgross=r0_7*cgross(ikx) + else + qcgross=cgross(ikx) + endif + + if (twodvar_regional) then + if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) & + qcgross=three*cgross(ikx) + endif + + if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors=ratio_errors/sqrt(dup(i)) + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + muse(i) = .true. + endif + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_td2m=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_td2m*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 !rejected obs + if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs + end if + + ress = ddiff*scale + ressw2 = ress*ress + + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + endif + +! Fill obs diagnostics structure + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call td2mNode_appendto(my_head,td2mhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + end if + + my_head => null() + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'td2',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::td2m' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get td2m ... + varname='td2m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_td2m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_td2m(size(rank2,1),size(rank2,2),nfldsig)) + ges_td2m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_td2m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_td2m_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = r10*exp(data(ipres,i)) ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) + + rdiagbuf(17,ii) = data(itd2m,i) ! TD2M observation (K) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) + rdiagbuf(19,ii) = data(itd2m,i)-td2mges! obs-ges w/o bias correction (K) (future slot) + + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' td2m' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", data(ipres,i)*r10 ) + call nc_diag_metadata("Height", data(iobshgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(itd2m,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(itd2m,i)-td2mges ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps )) deallocate(ges_ps ) + if(allocated(ges_td2m)) deallocate(ges_td2m) + end subroutine final_vars_ + +end subroutine setuptd2m +end module td2m_setup diff --git a/src/gsi/setupuwnd10m.f90 b/src/gsi/setupuwnd10m.f90 new file mode 100644 index 000000000..15a3f386c --- /dev/null +++ b/src/gsi/setupuwnd10m.f90 @@ -0,0 +1,1063 @@ +module uwnd10m_setup + implicit none + private + public:: setup + interface setup; module procedure setupuwnd10m; end interface + +contains +subroutine setupuwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupuwnd10m compute rhs for conventional 10 m u component +! prgmmr: pondeca org: np23 date: 2016-03-07 +! +! abstract: For 10-m uwind observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2016-03-07 pondeca +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! before retuning to setuprhsall.f90 +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2017-03-15 Yang - modify code to use polymorphic code. +! 2017-09-28 todling - add netcdf_diag capability; hidden as contained code +! 2018-01-08 pondeca - addd option l_closeobs to use closest obs to analysis +! time in analysis +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig,ges_lnprsl, & + sfcmod_gfs,sfcmod_mm5,comp_fact10 + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,bmiss + use m_obsNode , only: obsNode + use m_uwnd10mNode, only: uwnd10mNode + use m_uwnd10mNode, only: uwnd10mNode_appendto + use m_obsLList , only: obsLList + use obsmod, only: luse_obsdiag + use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + + use gridmod, only: nsig + use gridmod, only: get_ij,twodvar_regional,regional,rotate_wind_xy2ll,pt_ll + use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,rd,grav,& + two,cg_term,three,four,five,ten,huge_single,r1000,r3600,& + grav_ratio,flattening,grav,deg2rad,grav_equator,somigliana, & + semi_major_axis + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print,qc_satwnds + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use rapidrefresh_cldsurf_mod, only: l_closeobs + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_7=0.7_r_kind + real(r_kind),parameter:: r6=6.0_r_kind + real(r_kind),parameter:: r20=20.0_r_kind + real(r_kind),parameter:: r360=360.0_r_kind + real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss + character(len=*),parameter:: myname='setupuwnd10m' + +! Declare local variables + + integer(i_kind) num_bad_ikx + + real(r_double) rstation_id + + real(r_kind) spdges,dlat,dlon,ddiff,dtime,error,prsln2,r0_001,thirty + real(r_kind) scale,val2,rsig,rsigp,ratio,ressw2,ress,residual,dudiff,dvdiff + real(r_kind) obserrlm,obserror,val,valqc,dx10,rlow,rhgh,drpx,prsfc + real(r_kind) term,rwgt + real(r_kind) cg_uwnd10m,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross + real(r_kind) presw,factw,dpres,sfcchk,ugesin,vgesin,dpressave + real(r_kind) qcu,qcv + real(r_kind) ratio_errors,tfact,wflate,psges,goverrd,spdob + real(r_kind) uob,vob,spdb + real(r_kind) dudiff_opp, dvdiff_opp, vecdiff, vecdiff_opp + real(r_kind) ascat_vec + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,skint,sfcr + real(r_kind) uob_reg,vob_reg,uob_e,vob_e,dlon_e,uges_e,vges_e,dudiff_e,dvdiff_e + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nsig)::prsltmp,tges + real(r_kind) wdirob,wdirgesin,wdirdiffmax + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ier2,ilon,ilat,ihgt,iuob,ivob,ipres,id,itime,ikx,iqc + integer(i_kind) iuse,ilate,ilone,ielev,izz,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj,itype + integer(i_kind) l,mm1 + integer(i_kind) idomsfc,iskint,iff10,isfcr + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical lowlevelsat + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin + type(uwnd10mNode), pointer:: my_head + type(obs_diag ), pointer:: my_diag + type(obs_diags ), pointer:: my_diagLL + real(r_kind) :: hr_offset + + + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z !will probably need at some point + real(r_kind),allocatable,dimension(:,:,: ) :: ges_uwnd10m + real(r_kind),allocatable,dimension(:,:,: ) :: ges_vwnd10m + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + real(r_kind),allocatable,dimension(:,:,: ) :: ges_wspd10m + + type(obsLList),pointer,dimension(:):: uwnd10mhead + uwnd10mhead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + spdb=zero + + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + ihgt=5 ! index of observation elevation + iuob=6 ! index of u observation + ivob=7 ! index of v observation + id=8 ! index of station id + itime=9 ! index of observation time in data array + ikxx=10 ! index of ob type + ielev=11 ! index of station elevation (m) + iqc=12 ! index of quality mark + ier2=13 ! index of original-original obs error ratio + iuse=14 ! index of use parameter + idomsfc=15 ! index of dominant surface type + iskint=16 ! index of surface skin temperature + iff10=17 ! index of 10 meter wind factor + isfcr=18 ! index of surface roughness + ilone=19 ! index of longitude (degrees) + ilate=20 ! index of latitude (degrees) + izz=21 ! index of surface height + iprvd=22 ! index of provider + isprvd=23 ! index of subprovider + + mm1=mype+1 + scale=one + rsig=nsig + thirty = 30.0_r_kind + r0_001=0.001_r_kind + rsigp=rsig+one + goverrd=grav/rd + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for missing data + if (.not. oneobtest) then + do i=1,nobs + if (data(iuob,i) > r0_1_bmiss .or. data(ivob,i) > r0_1_bmiss) then + muse(i)=.false. + data(iuob,i)=rmiss_single ! for diag output + data(ivob,i)=rmiss_single ! for diag output + end if + end do + end if + +! Check for duplicate observations at same location + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset) nconvtype) then + num_bad_ikx=num_bad_ikx+1 + if(num_bad_ikx<=10) write(6,*)' in setupuwnd10m, bad ikx, ikx,i,nconvtype=',ikx,i,nconvtype + cycle + end if + + error=data(ier2,i) + isli=data(idomsfc,i) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + end if + + if(.not.in_curbin) cycle + +! Load observation error and values into local variables + uob = data(iuob,i) + vob = data(ivob,i) + spdob=sqrt(uob*uob+vob*vob) + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + +! Interpolate to get wspd10m at obs location/time + call tintrp2a11(ges_wspd10m,spdges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + itype=ictype(ikx) + +! Process observations with reported pressure + dpres = data(ipres,i) + presw = ten*exp(dpres) + dpres = dpres-log(psges) + drpx=zero + + prsfc=psges + prsln2=log(exp(prsltmp(1))/prsfc) + dpressave=dpres + +! Put obs pressure in correct units to get grid coord. number + dpres=log(exp(dpres)*prsfc) + call grdcrd1(dpres,prsltmp(1),nsig,-1) + +! Interpolate guess u and v to observation location and time. + + call tintrp2a11(ges_uwnd10m,ugesin,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a11(ges_vwnd10m,vgesin,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + if(dpressave <= prsln2)then + factw=one + else + factw = data(iff10,i) + if(sfcmod_gfs .or. sfcmod_mm5) then + sfcr = data(isfcr,i) + skint = data(iskint,i) + call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) + end if + + call tintrp2a1(ges_tv,tges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) +! Apply 10-meter wind reduction factor to guess winds + dx10=-goverrd*ten/tges(1) + if (dpressave < dx10)then + term=(prsln2-dpressave)/(prsln2-dx10) + factw=one-term+factw*term + end if + ugesin=factw*ugesin + vgesin=factw*vgesin + + end if + +! Get approx k value of sfc by using surface pressure + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp(1),nsig,-1) + +! Checks based on observation location relative to model surface and top + rlow=max(sfcchk-dpres,zero) + rhgh=max(dpres-r0_001-rsigp,zero) + if(luse(i))then + awork(1) = awork(1) + one + if(rlow/=zero) awork(2) = awork(2) + one + if(rhgh/=zero) awork(3) = awork(3) + one + end if + +! Adjust observation error + wflate=zero + if (ictype(ikx)==288 .or. ictype(ikx)==295) then + if (spdob=ten ) wflate=four*data(ier,i) ! Tyndall/Horel type QC + endif + + ratio_errors=error/(data(ier,i)+drpx+wflate+1.0e6_r_kind*rhgh+four*rlow) + +! Invert observation error + error=one/error + +! Check to see if observation below model surface or above model top. +! If so, don't use observation + if (dpres > rsig )then + if( regional .and. presw > pt_ll )then + dpres=rsig + else + ratio_errors=zero + endif + endif + +! Compute innovations + lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & + itype==247.or.itype==250.or.itype==251.or.itype==252.or. & + itype==253.or.itype==254.or.itype==257.or.itype==258.or. & + itype==259 + if (lowlevelsat .and. twodvar_regional) then + call windfactor(presw,factw) + data(iuob,i)=factw*data(iuob,i) + data(ivob,i)=factw*data(ivob,i) + uob = data(iuob,i) + vob = data(ivob,i) + endif + dudiff=uob-ugesin + dvdiff=vob-vgesin + spdb=sqrt(uob**2+vob**2)-sqrt(ugesin**2+vgesin**2) + + ddiff=dudiff + + if ( qc_satwnds ) then + if(itype >=240 .and. itype <=260) then + if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb + endif + if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top + if(presw >399.0_r_kind) error=zero + endif + if(itype ==258 .and. presw >600.0_r_kind) error=zero + if(itype ==259 .and. presw >600.0_r_kind) error=zero + endif ! qc_satwnds + +! QC WindSAT winds + if (itype==289) then + qcu = r6 + qcv = r6 + if ( spdob > r20 .or. & ! high wind speed check + abs(dudiff) > qcu .or. & ! u component check + abs(dvdiff) > qcv ) then ! v component check + error = zero + endif + endif + +! QC ASCAT winds + if (itype==290) then + qcu = five + qcv = five +! Compute innovations for opposite vectors + dudiff_opp = -uob - ugesin + dvdiff_opp = -vob - vgesin + vecdiff = sqrt(dudiff**2 + dvdiff**2) + vecdiff_opp = sqrt(dudiff_opp**2 + dvdiff_opp**2) + ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) + + if ( abs(dudiff) > qcu .or. & ! u component check + abs(dvdiff) > qcv .or. & ! v component check + vecdiff > vecdiff_opp ) then ! ambiguity check + + error = zero + endif + endif + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross check using innovation normalized by error + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + +! it's probably more robust to evalute gross-error in +! terms of magnitude of full-vector difference + +!! if ( abs(ugesin)>zero .or. abs(vgesin)>zero ) then +!! ugesin_scaled=(ugesin/sqrt(ugesin**2+vgesin**2))*spdges +!! vgesin_scaled=(vgesin/sqrt(ugesin**2+vgesin**2))*spdges +!! residual = sqrt((uob-ugesin_scaled)**2+(vob-vgesin_scaled)**2) +!! else +!! residual = sqrt(dudiff**2+dvdiff**2) +!! endif + +!! residual = sqrt(dudiff**2+dvdiff**2) + ratio = residual/obserrlm + +!! modify cgross depending on the quality mark, qcmark=3, cgross=0.7*cgross +!! apply asymetric gross check for satellite winds + qcgross=cgross(ikx) + if(data(iqc,i) == three) qcgross=r0_7*cgross(ikx) + + if(spdb <0 )then + if(itype ==244) then ! AVHRR, use same as MODIS + qcgross=r0_7*cgross(ikx) + endif + if(itype >=257 .and. itype <=259 ) then + qcgross=r0_7*cgross(ikx) + endif + endif + + if (ratio> qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors =ratio_errors/sqrt(dup(i)) + end if + + if (lowlevelsat .and. twodvar_regional) then + if (data(idomsfc,i) /= 0 .and. data(idomsfc,i) /= 3 ) then + error = zero + ratio_errors = zero + endif + endif + + if (twodvar_regional) then + if (lowlevelsat .or. itype==289 .or. itype==290) then + wdirdiffmax=45._r_kind + else + wdirdiffmax=100000._r_kind + endif + if (spdob > zero .and. (spdob-spdb) > zero) then + call getwdir(uob,vob,wdirob) + call getwdir(ugesin,vgesin,wdirgesin) + if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & + abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then + error = zero + ratio_errors = zero + endif + endif + endif + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_uwnd10m=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_uwnd10m*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + end if + ress = ddiff*scale + ressw2 = ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + if (abs(data(iuob,i)-rmiss_single) >=tiny_r_kind) then + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + end if + + endif + + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + allocate(my_head) + call uwnd10mNode_appendto(my_head,uwnd10mhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1, myname,'my_diag:my_head') + my_head%diags => my_diag + end if + my_head => null () + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave .and. ii>0)then + if(netcdf_diag) call nc_diag_write + if(binary_diag) then + write(7)'uwn',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + endif + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::uwnd10m', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::vwnd10m', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::wspd10m', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=10) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get uwnd10m ... + varname='uwnd10m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_uwnd10m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_uwnd10m(size(rank2,1),size(rank2,2),nfldsig)) + ges_uwnd10m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_uwnd10m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get vwnd10m ... + varname='vwnd10m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_vwnd10m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_vwnd10m(size(rank2,1),size(rank2,2),nfldsig)) + ges_vwnd10m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_vwnd10m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get wspd10m ... + varname='wspd10m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_wspd10m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_wspd10m(size(rank2,1),size(rank2,2),nfldsig)) + ges_wspd10m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_wspd10m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + + write(string,900) jiter +900 format('conv_u10m_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) + rdiagbuf(6,ii) = presw ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (ms**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (ms**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (ms**-1) + + rdiagbuf(17,ii) = data(iuob,i) ! 10m uwind observation (ms**-1) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (ms**-1) + rdiagbuf(19,ii) = data(iuob,i)-ugesin! obs-ges w/o bias correction (ms**-1) (future slot) + + rdiagbuf(20,ii) = data(ivob,i) ! 10m vwind observation (ms**-1) + rdiagbuf(21,ii) = dvdiff ! vob-ges (ms**-1) + rdiagbuf(22,ii) = data(ivob,i)-vgesin! vob-ges w/o bias correction (ms**-1) (future slot) + + if(regional) then + +! replace positions 17-22 with earth relative wind component information + + uob_reg=data(iuob,i) + vob_reg=data(ivob,i) + dlon_e=data(ilone,i)*deg2rad + call rotate_wind_xy2ll(uob_reg,vob_reg,uob_e,vob_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ddiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) + rdiagbuf(17,ii) = uob_e ! earth relative u wind component observation (m/s) + rdiagbuf(18,ii) = dudiff_e ! earth relative u obs-ges used in analysis (m/s) + rdiagbuf(19,ii) = uob_e-uges_e ! earth relative u obs-ges w/o bias correction (m/s) (future slot) + + rdiagbuf(20,ii) = vob_e ! earth relative v wind component observation (m/s) + rdiagbuf(21,ii) = dvdiff_e ! earth relative v obs-ges used in analysis (m/s) + rdiagbuf(22,ii) = vob_e-vges_e ! earth relative v obs-ges w/o bias correction (m/s) (future slot) + end if + + rdiagbuf(23,ii) = factw ! 10m wind reduction factor + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominant surface type + rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = 'uwnd10m' + real(r_kind),dimension(miter) :: obsdiag_iuse + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(ielev,i) ) + call nc_diag_metadata("Pressure", presw ) + call nc_diag_metadata("Height", data(ihgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Setup_QC_Mark", bmiss ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) + + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("u_Observation", data(iuob,i) ) + call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted",data(iuob,i)-ugesin) + + call nc_diag_metadata("v_Observation", data(ivob,i) ) + call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", dvdiff ) + call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", data(ivob,i)-vgesin) + + if(regional) then + +! replace positions 17-22 with earth relative wind component information + + uob_reg=data(iuob,i) + vob_reg=data(ivob,i) + dlon_e=data(ilone,i)*deg2rad + call rotate_wind_xy2ll(uob_reg,vob_reg,uob_e,vob_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ddiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) + rdiagbuf(17,ii) = uob_e ! earth relative u wind component observation (m/s) + rdiagbuf(18,ii) = dudiff_e ! earth relative u obs-ges used in analysis (m/s) + rdiagbuf(19,ii) = uob_e-uges_e ! earth relative u obs-ges w/o bias correction (m/s) (future slot) + + rdiagbuf(20,ii) = vob_e ! earth relative v wind component observation (m/s) + rdiagbuf(21,ii) = dvdiff_e ! earth relative v obs-ges used in analysis (m/s) + rdiagbuf(22,ii) = vob_e-vges_e ! earth relative v obs-ges w/o bias correction (m/s) (future slot) + call nc_diag_metadata("u_Observation", uob_e ) + call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", dudiff_e ) + call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted",uob_e-uges_e ) + + call nc_diag_metadata("v_Observation", vob_e ) + call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", dvdiff_e ) + call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", vob_e-vges_e ) + end if + + call nc_diag_metadata("Wind_Reduction_Factor_at_10m", factw ) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i)) + call nc_diag_metadata("Model_Terrain", data(izz,i)) + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps )) deallocate(ges_ps ) + if(allocated(ges_tv )) deallocate(ges_tv ) + if(allocated(ges_uwnd10m)) deallocate(ges_uwnd10m) + if(allocated(ges_vwnd10m)) deallocate(ges_vwnd10m) + if(allocated(ges_wspd10m)) deallocate(ges_wspd10m) + end subroutine final_vars_ + +end subroutine setupuwnd10m +end module uwnd10m_setup diff --git a/src/gsi/setupvis.f90 b/src/gsi/setupvis.f90 new file mode 100644 index 000000000..e395c4f7f --- /dev/null +++ b/src/gsi/setupvis.f90 @@ -0,0 +1,715 @@ +module vis_setup + implicit none + private + public:: setup + interface setup; module procedure setupvis; end interface + +contains +subroutine setupvis(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupvis compute rhs for conventional surface vis +! prgmmr: derber org: np23 date: 2004-07-20 +! +! abstract: For sea surface temperature observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2009-10-21 zhu +! 2011-02-19 zhu - update +! 2013-01-26 parrish - change tintrp2a to tintrp2a11 (so debug compile works on WCOSS) +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! before retuning to setuprhsall.f90 +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! +! 2018-03-01 yang - use module nltransf to convert vis +! 2018-03-21 pondeca/yang - for code consistency across all analyzed variables,replace +! the original "dup"-based implementation of the option to +! assimilate the closest ob to the analysis time only with +! Ming Hu's "muse"-based implementation. + +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,bmiss + use obsmod, only: netcdf_diag, binary_diag, dirname,ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use m_obsNode, only: obsNode + use m_visNode, only: visNode + use m_visNode, only: visNode_appendto + use m_obsLList, only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + use gridmod, only: nsig + use gridmod, only: get_ij + use constants, only: zero,tiny_r_kind,one,half,one_tenth,wgtlim, & + two,cg_term,huge_single,r1000 + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print + use qcmod, only: pvis,scale_cv + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use nltransf, only: nltransf_inverse + use rapidrefresh_cldsurf_mod, only: l_closeobs + + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss + character(len=*),parameter:: myname='setupvis' + +! Declare local variables + + real(r_double) rstation_id + + real(r_kind) visges,dlat,dlon,ddiff,dtime,error + real(r_kind) visgesout,visobout,tempvis,visdiff + real(r_kind) vis_errmax + real(r_kind) scale,val2,ratio,residual + real(r_kind) obserrlm,obserror,val,valqc + real(r_kind) term,rwgt + real(r_kind) cg_vis,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 + real(r_kind) ratio_errors,tfact + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ilon,ilat,ivis,id,itime,ikx,imaxerr,iqc + integer(i_kind) iuse,ilate,ilone,istnelv,iobshgt,izz,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj + integer(i_kind) l,mm1 + integer(i_kind) idomsfc + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + real(r_kind) :: hr_offset + + logical:: in_curbin, in_anybin + type(visNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,:) :: ges_ps + real(r_kind),allocatable,dimension(:,:,:) :: ges_vis + real(r_kind),allocatable,dimension(:,:,:) :: ges_z + + type(obsLList),pointer,dimension(:):: vishead + vishead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + + vis_errmax=20.0_r_kind +!********************************************************************************* +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ivis=4 ! index of vis observation - background + id=5 ! index of station id + itime=6 ! index of observation time in data array + ikxx=7 ! index of ob type + imaxerr=8 ! index of vis max error + iqc=9 ! index of quality mark + iuse=10 ! index of use parameter + idomsfc=11 ! index of dominant surface type + ilone=12 ! index of longitude (degrees) + ilate=13 ! index of latitude (degrees) + istnelv=14 ! index of station elevation (m) + iobshgt=15 ! index of observation height (m) + izz=16 ! index of surface height + iprvd=17 ! index of provider + isprvd=18 ! index of subprovider + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for missing data !need obs value and error + do i=1,nobs + if (data(ivis,i) > r0_1_bmiss) then + muse(i)=.false. + data(ivis,i)=rmiss_single ! for diag output + data(iobshgt,i)=rmiss_single ! for diag output + end if + end do + +! Check for duplicate observations at same location + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if (luse_obsdiag) then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =', .not.lobsdiag_allocated) + endif + + if(.not.in_curbin) cycle + call tintrp2a11(ges_vis,visges,dlat,dlon,dtime,hrdifsig, mype,nfldsig) + +! Adjust observation error + ratio_errors=error/data(ier,i) + error=one/error + ddiff=data(ivis,i)-visges + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross check using innovation normalized by error + if (abs(data(ivis,i)-rmiss_single) >= tiny_r_kind ) then + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + ratio = residual/obserrlm + ratio_errors=ratio_errors/sqrt(dup(i)) + if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + endif + else ! missing data + error = zero + ratio_errors=zero + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_vis=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_vis*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + nn=1 + else + nn=2 !rejected obs + if(ratio_errors*error >=tiny_r_kind) nn=3 !monitored obs + end if +!......................................................................... +!NLTR: convert visges to physical space +!......................................................................... + call nltransf_inverse(visges,visgesout,pvis,scale_cv) + if (abs(data(ivis,i)-rmiss_single) >=tiny_r_kind) then + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count +!......................................................................... +!convert visobs to physical space + + tempvis=data(ivis,i) + call nltransf_inverse(tempvis,visobout,pvis,scale_cv) +!values in vis fits, fort.219, are in physical space + visdiff=(visobout-visgesout)*scale + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+visdiff ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+visdiff*visdiff ! (o-g)**2 +!END NLTR +!......................................................................... + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + else ! default values for visobout and visdiff + visobout=rmiss_single + visdiff=(visobout-visgesout)*scale + end if + endif + + if (luse_obsdiag) then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff ) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + + allocate(my_head) + call visNode_appendto(my_head,vishead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag + endif ! (luse_obsdiag) + + my_head => null() + endif ! (.not. last .and. muse(i)) + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = 4000.0_r_kind + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single +!-------------------------------------------------------------------------------- +!For diag file, write out vis error statistics and the field in physical space. +!NOTE: No linear conversion in error stats between physical space and NLTR +!space. +!NOTE: in RTMA post process only err_final is used. +!-------------------------------------------------------------------------------- + err_input = 4000.0_r_kind + err_adjst = 4000.0_r_kind + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave) then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'vis',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + end if + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::vis' , ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get vis ... + varname='vis' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_vis))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_vis(size(rank2,1),size(rank2,2),nfldsig)) + ges_vis(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_vis(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_vis_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m**-1) + rdiagbuf(17,ii) = visobout ! VIS observation (m) + rdiagbuf(18,ii) = visdiff ! obs-ges in physical space(m), for post process + rdiagbuf(19,ii) = ddiff ! obs-ges used in analysis, g-space + rdiagbuf(20,ii) = rmiss_single ! type of measurement + rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type + rdiagbuf(22,ii) = data(izz,i) ! model terrain at observation location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' vis' + real(r_kind),parameter:: missing = -9.99e9_r_kind + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata("Pressure", missing ) + call nc_diag_metadata("Height", data(iobshgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", data(ivis,i) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", data(ivis,i)-visges ) + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i)) + call nc_diag_metadata("Model_Terrain", data(izz,i)) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg) + + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_vis)) deallocate(ges_vis) + if(allocated(ges_ps )) deallocate(ges_ps ) + end subroutine final_vars_ + +end subroutine setupvis +end module vis_setup diff --git a/src/gsi/setupvwnd10m.f90 b/src/gsi/setupvwnd10m.f90 new file mode 100644 index 000000000..7ebcb1c04 --- /dev/null +++ b/src/gsi/setupvwnd10m.f90 @@ -0,0 +1,1063 @@ +module vwnd10m_setup + implicit none + private + public:: setup + interface setup; module procedure setupvwnd10m; end interface + +contains +subroutine setupvwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupvwnd10m compute rhs for conventional 10 m vwind +! prgmmr: pondeca org: np23 date: 2016-03-07 +! +! abstract: For 10-m uwind observations +! a) reads obs assigned to given mpi task (geographic region), +! b) simulates obs from guess, +! c) apply some quality control to obs, +! d) load weight and innovation arrays used in minimization +! e) collects statistics for runtime diagnostic output +! f) writes additional diagnostic information to output file +! +! program history log: +! 2016-03-07 pondeca +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-10-07 pondeca - if(.not.proceed) advance through input file first +! before retuning to setuprhsall.f90 +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2017-03-15 Yang - modify code to use polymorphic code. +! 2017-09-28 todling - add netcdf_diag capability; hidden as contained code +! 2018-01-08 pondeca - addd option l_closeobs to use closest obs to analysis +! time in analysis +! +! input argument list: +! lunin - unit from which to read observations +! mype - mpi task id +! nele - number of data elements per observation +! nobs - number of observations +! +! output argument list: +! bwork - array containing information about obs-ges statistics +! awork - array containing information for data counts and gross checks +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + + use guess_grids, only: hrdifsig,nfldsig,ges_lnprsl, & + sfcmod_gfs,sfcmod_mm5,comp_fact10 + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,bmiss + use m_obsNode , only: obsNode + use m_vwnd10mNode, only: vwnd10mNode + use m_vwnd10mNode, only: vwnd10mNode_appendto + use m_obsLList , only: obsLList + use obsmod, only: luse_obsdiag + use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use oneobmod, only: magoberr,maginnov,oneobtest + + use gridmod, only: nsig + use gridmod, only: get_ij,twodvar_regional,regional,rotate_wind_xy2ll,pt_ll + use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,rd,grav,& + two,cg_term,three,four,five,ten,huge_single,r1000,r3600,& + grav_ratio,flattening,grav,deg2rad,grav_equator,somigliana, & + semi_major_axis + use jfunc, only: jiter,last,miter + use qcmod, only: dfact,dfact1,npres_print,qc_satwnds + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use m_dtime, only: dtime_setup, dtime_check + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use rapidrefresh_cldsurf_mod, only: l_closeobs + implicit none + +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: conv_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + +! Declare external calls for code analysis + external:: tintrp2a1,tintrp2a11 + external:: stop2 + +! Declare local parameters + real(r_kind),parameter:: r0_7=0.7_r_kind + real(r_kind),parameter:: r6=6.0_r_kind + real(r_kind),parameter:: r20=20.0_r_kind + real(r_kind),parameter:: r360=360.0_r_kind + real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss + character(len=*),parameter:: myname='setupvwnd10m' + +! Declare local variables + + integer(i_kind) num_bad_ikx + + real(r_double) rstation_id + + real(r_kind) spdges,dlat,dlon,ddiff,dtime,error,prsln2,r0_001,thirty + real(r_kind) scale,val2,rsig,rsigp,ratio,ressw2,ress,residual,dudiff,dvdiff + real(r_kind) obserrlm,obserror,val,valqc,dx10,rlow,rhgh,drpx,prsfc + real(r_kind) term,rwgt + real(r_kind) cg_vwnd10m,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross + real(r_kind) presw,factw,dpres,sfcchk,ugesin,vgesin,dpressave + real(r_kind) qcu,qcv + real(r_kind) ratio_errors,tfact,wflate,psges,goverrd,spdob + real(r_kind) uob,vob,spdb + real(r_kind) dudiff_opp, dvdiff_opp, vecdiff, vecdiff_opp + real(r_kind) ascat_vec + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,skint,sfcr + real(r_kind) uob_reg,vob_reg,uob_e,vob_e,dlon_e,uges_e,vges_e,dudiff_e,dvdiff_e + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nsig)::prsltmp,tges + real(r_kind) wdirob,wdirgesin,wdirdiffmax + real(r_kind),dimension(nele,nobs):: data + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + + integer(i_kind) ier,ier2,ilon,ilat,ihgt,iuob,ivob,ipres,id,itime,ikx,iqc + integer(i_kind) iuse,ilate,ilone,ielev,izz,iprvd,isprvd + integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj,itype + integer(i_kind) l,mm1 + integer(i_kind) idomsfc,iskint,iff10,isfcr + + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical lowlevelsat + logical proceed + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + logical:: in_curbin, in_anybin + type(vwnd10mNode), pointer:: my_head + type(obs_diag ), pointer:: my_diag + type(obs_diags ), pointer:: my_diagLL + real(r_kind) :: hr_offset + + + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z !will probably need at some point + real(r_kind),allocatable,dimension(:,:,: ) :: ges_uwnd10m + real(r_kind),allocatable,dimension(:,:,: ) :: ges_vwnd10m + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + real(r_kind),allocatable,dimension(:,:,: ) :: ges_wspd10m + + type(obsLList),pointer,dimension(:):: vwnd10mhead + vwnd10mhead => obsLL(:) + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) then + read(lunin)data,luse !advance through input file + return ! not all vars available, simply return + endif + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!********************************************************************************* +! Read and reformat observations in work arrays. + spdb=zero + + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + ihgt=5 ! index of observation elevation + iuob=6 ! index of u observation + ivob=7 ! index of v observation + id=8 ! index of station id + itime=9 ! index of observation time in data array + ikxx=10 ! index of ob type + ielev=11 ! index of station elevation (m) + iqc=12 ! index of quality mark + ier2=13 ! index of original-original obs error ratio + iuse=14 ! index of use parameter + idomsfc=15 ! index of dominant surface type + iskint=16 ! index of surface skin temperature + iff10=17 ! index of 10 meter wind factor + isfcr=18 ! index of surface roughness + ilone=19 ! index of longitude (degrees) + ilate=20 ! index of latitude (degrees) + izz=21 ! index of surface height + iprvd=22 ! index of provider + isprvd=23 ! index of subprovider + + mm1=mype+1 + scale=one + rsig=nsig + thirty = 30.0_r_kind + r0_001=0.001_r_kind + rsigp=rsig+one + goverrd=grav/rd + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! Check for missing data + if (.not. oneobtest) then + do i=1,nobs + if (data(iuob,i) > r0_1_bmiss .or. data(ivob,i) > r0_1_bmiss) then + muse(i)=.false. + data(iuob,i)=rmiss_single ! for diag output + data(ivob,i)=rmiss_single ! for diag output + end if + end do + end if + +! Check for duplicate observations at same location + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if(data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l))then + + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset) nconvtype) then + num_bad_ikx=num_bad_ikx+1 + if(num_bad_ikx<=10) write(6,*)' in setupvwnd10m, bad ikx, ikx,i,nconvtype=',ikx,i,nconvtype + cycle + end if + + error=data(ier2,i) + isli=data(idomsfc,i) + endif + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + end if + + if(.not.in_curbin) cycle + +! Load observation error and values into local variables + uob = data(iuob,i) + vob = data(ivob,i) + spdob=sqrt(uob*uob+vob*vob) + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + +! Interpolate to get wspd10m at obs location/time + call tintrp2a11(ges_wspd10m,spdges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + itype=ictype(ikx) + +! Process observations with reported pressure + dpres = data(ipres,i) + presw = ten*exp(dpres) + dpres = dpres-log(psges) + drpx=zero + + prsfc=psges + prsln2=log(exp(prsltmp(1))/prsfc) + dpressave=dpres + +! Put obs pressure in correct units to get grid coord. number + dpres=log(exp(dpres)*prsfc) + call grdcrd1(dpres,prsltmp(1),nsig,-1) + +! Interpolate guess u and v to observation location and time. + + call tintrp2a11(ges_uwnd10m,ugesin,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a11(ges_vwnd10m,vgesin,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + + if(dpressave <= prsln2)then + factw=one + else + factw = data(iff10,i) + if(sfcmod_gfs .or. sfcmod_mm5) then + sfcr = data(isfcr,i) + skint = data(iskint,i) + call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) + end if + + call tintrp2a1(ges_tv,tges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) +! Apply 10-meter wind reduction factor to guess winds + dx10=-goverrd*ten/tges(1) + if (dpressave < dx10)then + term=(prsln2-dpressave)/(prsln2-dx10) + factw=one-term+factw*term + end if + ugesin=factw*ugesin + vgesin=factw*vgesin + + end if + +! Get approx k value of sfc by using surface pressure + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp(1),nsig,-1) + +! Checks based on observation location relative to model surface and top + rlow=max(sfcchk-dpres,zero) + rhgh=max(dpres-r0_001-rsigp,zero) + if(luse(i))then + awork(1) = awork(1) + one + if(rlow/=zero) awork(2) = awork(2) + one + if(rhgh/=zero) awork(3) = awork(3) + one + end if + +! Adjust observation error + wflate=zero + if (ictype(ikx)==288 .or. ictype(ikx)==295) then + if (spdob=ten ) wflate=four*data(ier,i) ! Tyndall/Horel type QC + endif + + ratio_errors=error/(data(ier,i)+drpx+wflate+1.0e6_r_kind*rhgh+four*rlow) + +! Invert observation error + error=one/error + +! Check to see if observation below model surface or above model top. +! If so, don't use observation + if (dpres > rsig )then + if( regional .and. presw > pt_ll )then + dpres=rsig + else + ratio_errors=zero + endif + endif + +! Compute innovations + lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & + itype==247.or.itype==250.or.itype==251.or.itype==252.or. & + itype==253.or.itype==254.or.itype==257.or.itype==258.or. & + itype==259 + if (lowlevelsat .and. twodvar_regional) then + call windfactor(presw,factw) + data(iuob,i)=factw*data(iuob,i) + data(ivob,i)=factw*data(ivob,i) + uob = data(iuob,i) + vob = data(ivob,i) + endif + dudiff=uob-ugesin + dvdiff=vob-vgesin + spdb=sqrt(uob**2+vob**2)-sqrt(ugesin**2+vgesin**2) + + ddiff=dvdiff + + if ( qc_satwnds ) then + if(itype >=240 .and. itype <=260) then + if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb + endif + if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top + if(presw >399.0_r_kind) error=zero + endif + if(itype ==258 .and. presw >600.0_r_kind) error=zero + if(itype ==259 .and. presw >600.0_r_kind) error=zero + endif ! qc_satwnds + +! QC WindSAT winds + if (itype==289) then + qcu = r6 + qcv = r6 + if ( spdob > r20 .or. & ! high wind speed check + abs(dudiff) > qcu .or. & ! u component check + abs(dvdiff) > qcv ) then ! v component check + error = zero + endif + endif + +! QC ASCAT winds + if (itype==290) then + qcu = five + qcv = five +! Compute innovations for opposite vectors + dudiff_opp = -uob - ugesin + dvdiff_opp = -vob - vgesin + vecdiff = sqrt(dudiff**2 + dvdiff**2) + vecdiff_opp = sqrt(dudiff_opp**2 + dvdiff_opp**2) + ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) + + if ( abs(dudiff) > qcu .or. & ! u component check + abs(dvdiff) > qcv .or. & ! v component check + vecdiff > vecdiff_opp ) then ! ambiguity check + + error = zero + endif + endif + +! If requested, setup for single obs test. + if (oneobtest) then + ddiff=maginnov + error=one/magoberr + ratio_errors=one + endif + +! Gross check using innovation normalized by error + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = abs(ddiff) + +! it's probably more robust to evalute gross-error in +! terms of magnitude of full-vector difference + +!! if ( abs(ugesin)>zero .or. abs(vgesin)>zero ) then +!! ugesin_scaled=(ugesin/sqrt(ugesin**2+vgesin**2))*spdges +!! vgesin_scaled=(vgesin/sqrt(ugesin**2+vgesin**2))*spdges +!! residual = sqrt((uob-ugesin_scaled)**2+(vob-vgesin_scaled)**2) +!! else +!! residual = sqrt(dudiff**2+dvdiff**2) +!! endif + +!! residual = sqrt(dudiff**2+dvdiff**2) + ratio = residual/obserrlm + +!! modify cgross depending on the quality mark, qcmark=3, cgross=0.7*cgross +!! apply asymetric gross check for satellite winds + qcgross=cgross(ikx) + if(data(iqc,i) == three) qcgross=r0_7*cgross(ikx) + + if(spdb <0 )then + if(itype ==244) then ! AVHRR, use same as MODIS + qcgross=r0_7*cgross(ikx) + endif + if(itype >=257 .and. itype <=259 ) then + qcgross=r0_7*cgross(ikx) + endif + endif + + if (ratio> qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(6) = awork(6)+one + error = zero + ratio_errors=zero + else + ratio_errors =ratio_errors/sqrt(dup(i)) + end if + + if (lowlevelsat .and. twodvar_regional) then + if (data(idomsfc,i) /= 0 .and. data(idomsfc,i) /= 3 ) then + error = zero + ratio_errors = zero + endif + endif + + if (twodvar_regional) then + if (lowlevelsat .or. itype==289 .or. itype==290) then + wdirdiffmax=45._r_kind + else + wdirdiffmax=100000._r_kind + endif + if (spdob > zero .and. (spdob-spdb) > zero) then + call getwdir(uob,vob,wdirob) + call getwdir(ugesin,vgesin,wdirgesin) + if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & + abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then + error = zero + ratio_errors = zero + endif + endif + endif + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + +! Compute penalty terms (linear & nonlinear qc). + val = error*ddiff + if(luse(i))then + val2 = val*val + exp_arg = -half*val2 + rat_err2 = ratio_errors**2 + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_vwnd10m=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_vwnd10m*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + endif + valqc = -two*rat_err2*term + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + awork(4)=awork(4)+val2*rat_err2 + awork(5)=awork(5)+one + awork(22)=awork(22)+valqc + end if + ress = ddiff*scale + ressw2 = ress*ress + val2 = val*val + rat_err2 = ratio_errors**2 + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + if (abs(data(ivob,i)-rmiss_single) >=tiny_r_kind) then + bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count + bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) + bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 + bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty + end if + + endif + + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + end if + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + if (.not. last .and. muse(i)) then + allocate(my_head) + call vwnd10mNode_appendto(my_head,vwnd10mhead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +! Set (i,j) indices of guess gridpoint that bound obs location + call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) + + + + my_head%res = ddiff + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(luse_obsdiag)then + call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1, myname,'my_diag:my_head') + my_head%diags => my_diag + end if + my_head => null () + endif + + +! Save stuff for diagnostic output + if(conv_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if (binary_diag) call contents_binary_diag_(my_diag) + if (netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + + + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave .and. ii>0)then + if(netcdf_diag) call nc_diag_write + if(binary_diag) then + write(7)'uwn',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + endif + end if + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::uwnd10m', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::vwnd10m', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::wspd10m', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=10) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get uwnd10m ... + varname='uwnd10m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_uwnd10m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_uwnd10m(size(rank2,1),size(rank2,2),nfldsig)) + ges_uwnd10m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_uwnd10m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get vwnd10m ... + varname='vwnd10m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_vwnd10m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_vwnd10m(size(rank2,1),size(rank2,2),nfldsig)) + ges_vwnd10m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_vwnd10m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get wspd10m ... + varname='wspd10m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_wspd10m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_wspd10m(size(rank2,1),size(rank2,2),nfldsig)) + ges_wspd10m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_wspd10m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + + write(string,900) jiter +900 format('conv_v10m_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) + rdiagbuf(6,ii) = presw ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (ms**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (ms**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (ms**-1) + + rdiagbuf(17,ii) = data(ivob,i) ! 10m vwind observation (ms**-1) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (ms**-1) + rdiagbuf(19,ii) = data(ivob,i)-vgesin! obs-ges w/o bias correction (ms**-1) (future slot) + + rdiagbuf(20,ii) = data(iuob,i) ! 10m vwind observation (ms**-1) + rdiagbuf(21,ii) = dudiff ! uob-ges (ms**-1) + rdiagbuf(22,ii) = data(iuob,i)-ugesin! uob-ges w/o bias correction (ms**-1) (future slot) + + if(regional) then + +! replace positions 17-22 with earth relative wind component information + + uob_reg=data(iuob,i) + vob_reg=data(ivob,i) + dlon_e=data(ilone,i)*deg2rad + call rotate_wind_xy2ll(uob_reg,vob_reg,uob_e,vob_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ddiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) + rdiagbuf(17,ii) = uob_e ! earth relative u wind component observation (m/s) + rdiagbuf(18,ii) = dudiff_e ! earth relative u obs-ges used in analysis (m/s) + rdiagbuf(19,ii) = uob_e-uges_e ! earth relative u obs-ges w/o bias correction (m/s) (future slot) + + rdiagbuf(20,ii) = vob_e ! earth relative v wind component observation (m/s) + rdiagbuf(21,ii) = dvdiff_e ! earth relative v obs-ges used in analysis (m/s) + rdiagbuf(22,ii) = vob_e-vges_e ! earth relative v obs-ges w/o bias correction (m/s) (future slot) + end if + + rdiagbuf(23,ii) = factw ! 10m wind reduction factor + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominant surface type + rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = 'vwnd10m' + real(r_kind),dimension(miter) :: obsdiag_iuse + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(ielev,i) ) + call nc_diag_metadata("Pressure", presw ) + call nc_diag_metadata("Height", data(ihgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Setup_QC_Mark", bmiss ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) + + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("u_Observation", data(ivob,i) ) + call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted",data(ivob,i)-vgesin) + + call nc_diag_metadata("v_Observation", data(iuob,i) ) + call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", dudiff ) + call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", data(iuob,i)-ugesin) + + if(regional) then + +! replace positions 17-22 with earth relative wind component information + + uob_reg=data(iuob,i) + vob_reg=data(ivob,i) + dlon_e=data(ilone,i)*deg2rad + call rotate_wind_xy2ll(uob_reg,vob_reg,uob_e,vob_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ddiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) + rdiagbuf(17,ii) = uob_e ! earth relative u wind component observation (m/s) + rdiagbuf(18,ii) = dudiff_e ! earth relative u obs-ges used in analysis (m/s) + rdiagbuf(19,ii) = uob_e-uges_e ! earth relative u obs-ges w/o bias correction (m/s) (future slot) + + rdiagbuf(20,ii) = vob_e ! earth relative v wind component observation (m/s) + rdiagbuf(21,ii) = dvdiff_e ! earth relative v obs-ges used in analysis (m/s) + rdiagbuf(22,ii) = vob_e-vges_e ! earth relative v obs-ges w/o bias correction (m/s) (future slot) + call nc_diag_metadata("u_Observation", uob_e ) + call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", dudiff_e ) + call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted",uob_e-uges_e ) + + call nc_diag_metadata("v_Observation", vob_e ) + call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", dvdiff_e ) + call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", vob_e-vges_e ) + end if + + call nc_diag_metadata("Wind_Reduction_Factor_at_10m", factw ) + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i)) + call nc_diag_metadata("Model_Terrain", data(izz,i)) + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps )) deallocate(ges_ps ) + if(allocated(ges_tv )) deallocate(ges_tv ) + if(allocated(ges_uwnd10m)) deallocate(ges_uwnd10m) + if(allocated(ges_vwnd10m)) deallocate(ges_vwnd10m) + if(allocated(ges_wspd10m)) deallocate(ges_wspd10m) + end subroutine final_vars_ + +end subroutine setupvwnd10m +end module vwnd10m_setup diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 new file mode 100755 index 000000000..4afd3f79d --- /dev/null +++ b/src/gsi/setupw.f90 @@ -0,0 +1,1810 @@ +module w_setup + implicit none + private + public:: setup + interface setup; module procedure setupw; end interface + +contains +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI ! +!------------------------------------------------------------------------- +!BOP +! +! !ROUTINE: setupw --- Compute rhs of oi for wind component obs +! +! !INTERFACE: +! + +subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) + +! !USES: + + use mpeu_util, only: die,perr,getindex + use state_vectors, only: svars3d, levels, nsdim + use kinds, only: r_kind,r_single,r_double,i_kind + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,perturb_obs,oberror_tune,lobsdiag_forenkf,& + lobsdiagsave,nobskeep,lobsdiag_allocated,& + time_offset,bmiss,ianldate,aircraft_recon + use m_obsNode, only: obsNode + use m_wNode, only: wNode + use m_wNode, only: wNode_appendto + use m_wNode, only: wNode_ich0 + use m_wNode, only: wNode_ich0_PBL_pseudo + use m_obsLList, only: obsLList + + use obsmod, only: luse_obsdiag + use obsmod, only: netcdf_diag, binary_diag, dirname + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset + use qcmod, only: npres_print,ptop,pbot,dfact,dfact1,qc_satwnds,njqc,vqc + use oneobmod, only: oneobtest,oneob_type,magoberr,maginnov + use gridmod, only: get_ijk,nsig,twodvar_regional,regional,wrf_nmm_regional,& + rotate_wind_xy2ll,pt_ll + use guess_grids, only: nfldsig,hrdifsig,geop_hgtl,sfcmod_gfs + use guess_grids, only: tropprs,sfcmod_mm5 + use guess_grids, only: ges_lnprsl,comp_fact10,pbl_height + use constants, only: zero,half,one,tiny_r_kind,two,cg_term, & + three,rd,grav,four,five,huge_single,r1000,wgtlim,r10,r400 + use constants, only: grav_ratio,flattening,deg2rad, & + grav_equator,somigliana,semi_major_axis,eccentricity + use jfunc, only: jiter,last,jiterstart,miter + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use converr_uv, only: ptabl_uv + use converr, only: ptabl + use rapidrefresh_cldsurf_mod, only: l_PBL_pseudo_SurfobsUV, pblH_ration,pps_press_incr + use rapidrefresh_cldsurf_mod, only: l_closeobs, i_gsdqc + + use m_dtime, only: dtime_setup, dtime_check + + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use sparsearr, only: sparr2, new, size, writearray, fullarray + + ! The following variables are the coefficients that describe the + ! linear regression fits that are used to define the dynamic + ! observation error (DOE) specifications for all reconnissance + ! observations collected within hurricanes/tropical cyclones; these + ! apply only to the regional forecast models (e.g., HWRF); Henry + ! R. Winterbottom (henry.winterbottom@noaa.gov). + + use obsmod, only: uv_doe_a_236,uv_doe_a_237,uv_doe_b_236,uv_doe_b_237 + + implicit none + + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + +! !INPUT PARAMETERS: + + integer(i_kind) ,intent(in ) :: lunin ! unit from which to read observations + integer(i_kind) ,intent(in ) :: mype ! mpi task id + integer(i_kind) ,intent(in ) :: nele ! number of data elements per observation + integer(i_kind) ,intent(in ) :: nobs ! number of observations + integer(i_kind) ,intent(in ) :: is ! ndat index + logical ,intent(in ) :: conv_diagsave ! logical to save innovation dignostics + +! !INPUT/OUTPUT PARAMETERS: + + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork ! obs-ges stats + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork ! data counts and gross checks + +! +! !DESCRIPTION: For wind component observations, this routine +! \begin{enumerate} +! \item reads obs assigned to given mpi task (geographic region), +! \item simulates obs from guess, +! \item apply some quality control to obs, +! \item load weight and innovation arrays used in minimization +! \item collects statistics for runtime diagnostic output +! \item writes additional diagnostic information to output file +! \end{enumerate} +! +! !REVISION HISTORY: +! +! 1990-10-06 parrish +! 1998-04-10 weiyu yang +! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 2004-06-17 treadon - update documentation +! 2004-07-15 todling - protex-compliant prologue; added intent/only's +! 2004-10-06 parrish - increase size of vwork array for nonlinear qc +! 2004-11-22 derber - remove weight, add logical for boundary point +! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list +! 2005-03-02 dee - remove garbage from diagnostic file +! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error +! 2005-05-27 derber - level output change +! 2005-07-22 jung - add modis winds +! 2005-07-27 derber - add print of monitoring and reject data +! 2005-09-28 derber - combine with prep,spr,remove tran and clean up +! 2005-10-14 derber - input grid location and fix regional lat/lon +! 2005-10-21 su - modified variational qc and diagnose output +! 2005-11-03 treadon - correct error in ilone,ilate data array indices +! 2005-11-22 wu - add option to perturb conventional obs +! 2005-11-29 derber - remove psfcg and use ges_lnps instead +! 2006-01-13 treadon - correct bugs in modis wind qc +! 2006-01-31 todling - storing wgt/wgtlim in diag file instead of wgt only +! 2006-02-02 treadon - rename lnprsl as ges_lnprsl +! 2006-02-08 treadon - correct vertical dimension (nsig) in call tintrp2a(ges_tv...) +! 2006-02-15 treadon - use height when processing type 223, 224, 229 winds +! 2006-02-24 derber - modify to take advantage of convinfo module +! 2006-03-21 treadon - modify optional perturbation to observation +! 2006-04-03 derber - fix bugs and move all surface data to height calculation +! 2006-05-30 su,derber,treadon - modify diagnostic output +! 2006-06-06 su - move to wgtlim to constants module +! 2006-07-28 derber - modify to use new inner loop obs data structure +! - modify handling of multiple data at same location +! 2006-07-31 kleist - use ges_ps instead of ln(ps) +! 2006-08-28 su - fix a bug in variational qc +! 2006-11-30 jung/sienkiewicz - add type 259 for modis winds +! 2006-10-28 su - turn off rawinsonde Vqc at south hemisphere +! 2007-03-09 su - modify observation pertabation for adjusting obs error +! 2007-03-19 tremolet - binning of observations +! 2007-03-27 li.bi - add qc for type 289 windsat winds +! 2007-06-05 tremolet - add observation diagnostics structure +! 2007-08-28 su - modify observation gross check error +! 2008-03-24 wu - oberror tuning and perturb obs +! 2008-03-31 li.bi - add qc for type 290 ascat winds +! 2008-05-20 safford - rm unused vars +! 2008-09-08 lueken - merged ed's changes into q1fy09 code +! 2008-12-03 todling - changed handle of tail%time +! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). +! 2009-02-06 pondeca - for each observation site, add the following to the +! diagnostic file: local terrain height, dominate surface +! type, station provider name, and station subprovider name +! 2010-11-25 su - data items to hold quality mark for satellite wind +! 2011-03-08 parrish - for regional=.true., convert wind components in rdiagbuf from grid relative +! to earth relative, using subroutine rotate_wind_xy2ll. +! 2011-05-05 su - ome quality control for satellite satellite winds +! 2012-01-10 hu - add additional quality control for PBL profiler 223, 224, 227 +! 2011-12-14 wu - add code for rawinsonde level enhancement ( ext_sonde ) +! 2012-07-19 todling - add qc_satwnds flag to allow bypass QC-satwinds (QC not good for GMAO) +! 2011-10-14 Hu - add code for producing pseudo-obs in PBL +! layer based on surface obs UV +! 2013-01-08 Su -add more quality control for satellite winds and profiler winds +! 2013-01-26 parrish - change grdcrd to grdcrd1, intrp2a to intrp2a11, tintrp2a to tintrp2a1, tintrp2a11, +! tintrp3 to tintrp31 (so debug compile works on WCOSS) +! 2013-02-15 parrish - WCOSS debug runtime error--ikx outside range 1 to nconvtype. Add counter +! num_bad_ikx and print 1st 10 instances of ikx out of range +! and also print num_bad_ikx after all data processed if > 0 . +! 2013-05-24 wu - move rawinsonde level enhancement ( ext_sonde ) to read_prepbufr +! 2013-07-19 Hu/Olson/Carley - Add tall tower (type=261) winds +! 2013-10-19 todling - metguess now holds background +! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile +! 2014-04-12 su - add non linear qc from Purser's scheme +! 2014-12-30 derber - Modify for possibility of not using obsdiag +! 2015-05-01 Liu Ling - Added ISS Rapidscat wind (u,v) qc +! 2015-03-14 Nebuda - add departure check and near surface check for clear air WV AMV (WVCS) from GOES type 247 +! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags +! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. +! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) +! . removed (%dlat,%dlon) debris. +! 2016-11-29 shlyaeva - save linearized H(x) for EnKF +! 2016-12-09 mccarty - add netcdf_diag capability +! 2016-12-13 pondeca - add Tyndall & Horel QC for mesonet winds (WAF 2013, Vol. 8, pg. 285) to GSI's 2dvar option +! 2017-03-31 Hu - addd option l_closeobs to use closest obs to analysis +! time in analysis +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-04-09 pondeca - introduce duplogic to correctly handle the characterization of +! duplicate obs in twodvar_regional applications +! 2020-01-27 Winterbottom - moved the linear regression derived +! coefficients for the dynamic observation +! error (DOE) calculation to the namelist +! level; they are now loaded by +! aircraftinfo. +! +! REMARKS: +! language: f90 +! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq HP +! +! !AUTHOR: parrish org: np22 date: 1990-10-06 +! +!EOP +!------------------------------------------------------------------------- + +! Declare local parameters + real(r_kind),parameter:: r0_7=0.7_r_kind + real(r_kind),parameter:: r0_1=1.0_r_kind + real(r_kind),parameter:: r6=6.0_r_kind + real(r_kind),parameter:: r7=7.0_r_kind + real(r_kind),parameter:: r15=15.0_r_kind + real(r_kind),parameter:: r20=20.0_r_kind + real(r_kind),parameter:: r50=50.0_r_kind + real(r_kind),parameter:: r200=200.0_r_kind + real(r_kind),parameter:: r360=360.0_r_kind + real(r_kind),parameter:: r0_1_bmiss=0.1_r_kind*bmiss + + character(len=*),parameter:: myname='setupw' + +! Declare external calls for code analysis + external:: intrp2a11,tintrp2a1,tintrp2a11 + external:: tintrp31 + external:: grdcrd1 + external:: stop2 + +! Declare local variables + + real(r_double) rstation_id + real(r_kind) qcu,qcv,trop5,tfact,fact + real(r_kind) scale,ratio,obserror,obserrlm + real(r_kind) residual,ressw,ress,val,val2,valqc2,dudiff,dvdiff + real(r_kind) valqc,valu,valv,dx10,rlow,rhgh,drpx,prsfc,var_jb + real(r_kind) cg_w,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2,qcgross + real(r_kind) presw,factw,dpres,ugesin,vgesin,rwgt,dpressave + real(r_kind) sfcchk,prsln2,error,dtime,dlon,dlat,r0_001,rsig,thirty,rsigp + real(r_kind) ratio_errors,goverrd,spdges,spdob,ten,psges,zsges + real(r_kind) slat,sin2,termg,termr,termrg,pobl,uob,vob + real(r_kind) uob_reg,vob_reg,uob_e,vob_e,dlon_e,uges_e,vges_e,dudiff_e,dvdiff_e + real(r_kind) dz,zob,z1,z2,p1,p2,dz21,dlnp21,spdb,dstn + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final,skint,sfcr + real(r_kind) dudiff_opp, dvdiff_opp, vecdiff, vecdiff_opp + real(r_kind) dudiff_opp_rs, dvdiff_opp_rs, vecdiff_rs, vecdiff_opp_rs + real(r_kind) oscat_vec,ascat_vec,rapidscat_vec + real(r_kind),dimension(nele,nobs):: data + real(r_kind),dimension(nobs):: dup + real(r_kind),dimension(nsig)::prsltmp,tges,zges + real(r_kind) wdirob,wdirgesin,wdirdiffmax + real(r_kind),dimension(34)::ptabluv + real(r_single),allocatable,dimension(:,:)::rdiagbuf + + integer(i_kind) i,nchar,nreal,k,j,l,ii,itype,ijb +! Variables needed for new polar winds QC based on Log Normalized Vector Departure (LNVD) + real(r_kind) LNVD_wspd + real(r_kind) LNVD_omb + real(r_kind) LNVD_ratio + real(r_kind) LNVD_threshold + + integer(i_kind) jsig,mm1,iptrbu,iptrbv,jj,icat + integer(i_kind) k1,k2,ikxx,nn,isli,ibin,ioff,ioff0 + integer(i_kind) ier,ilon,ilat,ipres,iuob,ivob,id,itime,ikx,ielev,iqc + integer(i_kind) ihgt,ier2,iuse,ilate,ilone + integer(i_kind) izz,iprvd,isprvd + integer(i_kind) idomsfc,isfcr,iskint,iff10 + + integer(i_kind) num_bad_ikx + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(8),allocatable,dimension(:):: cprvstg,csprvstg + character(8) c_prvstg,c_sprvstg + real(r_double) r_prvstg,r_sprvstg + + type(sparr2) :: dhx_dx_u, dhx_dx_v + real(r_single), dimension(nsdim) :: dhx_dx_array + integer(i_kind) :: iz, u_ind, v_ind, nnz, nind + real(r_kind) :: delz + logical z_height,sfc_data + logical,dimension(nobs):: luse,muse + logical:: muse_u,muse_v + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical lowlevelsat,duplogic + logical proceed + + logical:: l_pbl_pseudo_itype + integer(i_kind):: ich0 + + logical:: in_curbin, in_anybin, save_jacobian + type(wNode),pointer :: my_head + type(obs_diag),pointer :: jj_diag + type(obs_diag),pointer :: my_diagu, my_diagu_pbl + type(obs_diag),pointer :: my_diagv, my_diagv_pbl + type(obs_diags),pointer :: my_diagLL + real(r_kind) :: thisPBL_height,ratio_PBL_height,prest,prestsfc,dudiffsfc,dvdiffsfc + real(r_kind) :: hr_offset + real(r_kind) :: magomb + + equivalence(rstation_id,station_id) + equivalence(r_prvstg,c_prvstg) + equivalence(r_sprvstg,c_sprvstg) + + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + + type(obsLList),pointer,dimension(:):: whead + whead => obsLL(:) + + save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf + +! Check to see if required guess fields are available + call check_vars_(proceed) + if(.not.proceed) return ! not all vars available, simply return + +! If require guess vars available, extract from bundle ... + call init_vars_ + +!****************************************************************************** +! Read and reformat observations in work arrays. + spdb=zero + + read(lunin)data,luse,ioid + +! index information for data array (see reading routine) + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + ihgt=5 ! index of height + iuob=6 ! index of u observation + ivob=7 ! index of v observation + id=8 ! index of station id + itime=9 ! index of observation time in data array + ikxx=10 ! index of ndex ob type in convinfo file + ielev=11 ! index of station elevation + iqc=12 ! index of quality mark + ier2=13 ! index of original-original obs error ratio + iuse=14 ! index of use parameter + idomsfc=15 ! index of dominant surface type + iskint=16 ! index of surface skin temperature + iff10=17 ! index of 10 meter wind factor + isfcr=18 ! index of surface roughness + ilone=19 ! index of longitude (degrees) + ilate=20 ! index of latitude (degrees) + izz=21 ! index of surface height + iprvd=22 ! index of observation provider + isprvd=23 ! index of observation subprovider + icat=24 ! index of data level category + ijb=25 ! index of non linear qc parameter + iptrbu=26 ! index of u perturbation + iptrbv=27 ! index of v perturbation + + mm1=mype+1 + scale=one + rsig=nsig + thirty = 30.0_r_kind + ten = 10.0_r_kind + r0_001=0.001_r_kind + rsigp=rsig+one + goverrd=grav/rd + var_jb=zero + +! If requested, save select data for output to diagnostic file + if(conv_diagsave)then + ii=0 + nchar=1 + ioff0=25 + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+7*miter+2 + if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif + if (save_jacobian) then + nnz = 2 ! number of non-zero elements in dH(x)/dx profile + nind = 1 + call new(dhx_dx_u, nnz, nind) + call new(dhx_dx_v, nnz, nind) + nreal = nreal + 2*size(dhx_dx_u) + endif + + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + if (netcdf_diag) call init_netcdf_diag_ + end if + + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + +! handle multiple-report observations at a station + hr_offset=min_offset/60.0_r_kind + dup=one + do k=1,nobs + do l=k+1,nobs + if (twodvar_regional) then + duplogic=data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l) + else + duplogic=data(ilat,k) == data(ilat,l) .and. & + data(ilon,k) == data(ilon,l) .and. & + data(ipres,k) == data(ipres,l) .and. & + data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & + muse(k) .and. muse(l) + end if + + if (duplogic) then + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset) nconvtype) then + num_bad_ikx=num_bad_ikx+1 + if(num_bad_ikx<=10) write(6,*)' in setupw, bad ikx, ikx,i,nconvtype=',ikx,i,nconvtype + cycle + end if + isli = data(idomsfc,i) + endif + + if(ikx < 1 .or. ikx > nconvtype) cycle + itype=ictype(ikx) + +! Link observation to appropriate observation bin + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + +! Link obs to diagnostics structure + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + + ! Flag static conditions to turn pbl_pseudo_surfobs on + l_pbl_pseudo_itype = l_PBL_pseudo_SurfobsUV .and. & + ( itype==281 .or. itype==283 .or.itype==287 ) + + if (luse_obsdiag) then + my_diagu => null() + my_diagv => null() + my_diagu_pbl => null() + my_diagv_pbl => null() + + ich0 = wNode_ich0 + if(l_pbl_pseudo_itype) ich0 = wNode_ich0_pbl_pseudo + + do jj=1,ich0+2 ! "2" for there are u and v components + jj_diag => obsdiagLList_nextNode(my_diagLL, & + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = jj ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(jj_diag)) then + call perr(myname,'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + call perr(myname,' ich0 =',ich0) + call perr(myname,' jj =',jj) + call die(myname) + endif + + select case(jj) + case(1); my_diagu => jj_diag + case(2); my_diagv => jj_diag + case(3); my_diagu_pbl => jj_diag + case(4); my_diagv_pbl => jj_diag + end select + enddo + endif + + if(.not.in_curbin) cycle + +! Load observation error and values into local variables + obserror = max(cermin(ikx),min(cermax(ikx),data(ier,i))) + uob = data(iuob,i) + vob = data(ivob,i) + spdob=sqrt(uob*uob+vob*vob) + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + +! Type 221=pibal winds contain a mixture of wind observations reported +! by pressure and others by height. Those levels only reported by +! pressure have a missing value (ie, large) value for the reported +! height. The logic below determines whether to process type 221 +! wind observations using height or pressure as the vertical coordinate. +! If height is not bad (less than r0_1_bmiss), we use height in the +! forward model. Otherwise, use reported pressure. + + z_height = .false. + if ((itype>=221 .and. itype <= 229) .and. (data(ihgt,i)=280 .and. itype < 300) .and. (.not.twodvar_regional) + if (z_height .or. sfc_data) then + + drpx = zero + dpres = data(ihgt,i) + dstn = data(ielev,i) + call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) +! Subtract off combination of surface station elevation and +! model elevation depending on how close to surface + fact = zero + if(dpres-dstn > 10._r_kind)then + if(dpres-dstn > r1000)then + fact = one + else + fact=(dpres-dstn)/990._r_kind + end if + end if + dpres=dpres-(dstn+fact*(zsges-dstn)) + if(itype==261) dpres = data(ihgt,i) + +! Get guess surface elevation and geopotential height profile +! at observation location. + call tintrp2a1(geop_hgtl,zges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + +! For observation reported with geometric height above sea level, +! convert geopotential to geometric height. + + if ((itype>=223 .and. itype<=228) .or. sfc_data) then +! Convert geopotential height at layer midpoints to geometric +! height using equations (17, 20, 23) in MJ Mahoney's note +! "A discussion of various measures of altitude" (2001). +! Available on the web at +! http://mtp.jpl.nasa.gov/notes/altitude/altitude.html +! +! termg = equation 17 +! termr = equation 21 +! termrg = first term in the denominator of equation 23 +! zges = equation 23 + + slat = data(ilate,i)*deg2rad + sin2 = sin(slat)*sin(slat) + termg = grav_equator * & + ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) + termr = semi_major_axis /(one + flattening + grav_ratio - & + two*flattening*sin2) + termrg = (termg/grav)*termr + do k=1,nsig + zges(k) = (termr*zges(k)) / (termrg-zges(k)) ! eq (23) + end do + + endif + +! Given observation height, (1) adjust 10 meter wind factor if +! necessary, (2) convert height to grid relative units, (3) compute +! compute observation pressure (for diagnostic purposes only), and +! (4) compute location of midpoint of first model layer above surface +! in grid relative units + +! Adjust 10m wind factor if necessary. Rarely do we have a +! profiler/vad obs within 10 meters of the surface. Almost always, +! the code below resets the 10m wind factor to 1.0 (i.e., no +! reduction in wind speed due to surface friction). + +! Convert observation height (in dpres) from meters to grid relative +! units. Save the observation height in zob for later use. + zob = dpres + call grdcrd1(dpres,zges,nsig,1) + +! Interpolate guess u and v to observation location and time. + + call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + + iz = max(1, min( int(dpres), nsig)) + delz = max(zero, min(dpres - float(iz), one)) + + if (save_jacobian) then + + u_ind = getindex(svars3d, 'u') + if (u_ind < 0) then + print *, 'Error: no variable u in state vector. Exiting.' + call stop2(1300) + endif + v_ind = getindex(svars3d, 'v') + if (v_ind < 0) then + print *, 'Error: no variable v in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx_u%st_ind(1) = iz + sum(levels(1:u_ind-1)) + dhx_dx_u%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:u_ind-1)) + dhx_dx_v%st_ind(1) = iz + sum(levels(1:v_ind-1)) + dhx_dx_v%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:v_ind-1)) + + dhx_dx_u%val(1) = one - delz + dhx_dx_u%val(2) = delz + dhx_dx_v%val = dhx_dx_u%val + endif + + + if (zob > zges(1)) then + factw=one + else + factw = data(iff10,i) + if(sfcmod_gfs .or. sfcmod_mm5) then + sfcr = data(isfcr,i) + skint = data(iskint,i) + call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) + end if + + if (zob <= ten) then + if(zob < ten)then + term = max(zob,zero)/ten + factw = term*factw + end if + else + term = (zges(1)-zob)/(zges(1)-ten) + factw = one-term+factw*term + end if + + ugesin=factw*ugesin + vgesin=factw*vgesin + + if (save_jacobian) then + dhx_dx_u%val = factw * dhx_dx_u%val + dhx_dx_v%val = factw * dhx_dx_v%val + endif + endif + + if(sfc_data .or. dpres < one) then + drpx=0.005_r_kind*abs(dstn-zsges)*(one-fact) + end if + +! Compute observation pressure (only used for diagnostics) + +! Set indices of model levels below (k1) and above (k2) observation. + if (dpresnsig) then + z1=zges(nsig-1); p1=prsltmp(nsig-1) + z2=zges(nsig); p2=prsltmp(nsig) + drpx = 1.e6_r_kind + else + k=dpres + k1=min(max(1,k),nsig) + k2=max(1,min(k+1,nsig)) + z1=zges(k1); p1=prsltmp(k1) + z2=zges(k2); p2=prsltmp(k2) + endif + + dz21 = z2-z1 + dlnp21 = p2-p1 + dz = zob-z1 + pobl = p1 + (dlnp21/dz21)*dz + presw = ten*exp(pobl) + +! Determine location in terms of grid units for midpoint of +! first layer above surface + sfcchk=zero +! call grdcrd1(sfcchk,zges,nsig,1) + + +! Process observations with reported pressure + else + dpres = data(ipres,i) + presw = ten*exp(dpres) + dpres = dpres-log(psges) + drpx=zero + + prsfc=psges + prsln2=log(exp(prsltmp(1))/prsfc) + dpressave=dpres + +! Put obs pressure in correct units to get grid coord. number + dpres=log(exp(dpres)*prsfc) + call grdcrd1(dpres,prsltmp(1),nsig,-1) + +! Interpolate guess u and v to observation location and time. + + call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + + iz = max(1, min( int(dpres), nsig)) + delz = max(zero, min(dpres - float(iz), one)) + + if (save_jacobian) then + u_ind = getindex(svars3d, 'u') + if (u_ind < 0) then + print *, 'Error: no variable u in state vector. Exiting.' + call stop2(1300) + endif + v_ind = getindex(svars3d, 'v') + if (v_ind < 0) then + print *, 'Error: no variable v in state vector. Exiting.' + call stop2(1300) + endif + + dhx_dx_u%st_ind(1) = iz + sum(levels(1:u_ind-1)) + dhx_dx_u%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:u_ind-1)) + dhx_dx_v%st_ind(1) = iz + sum(levels(1:v_ind-1)) + dhx_dx_v%end_ind(1) = min(iz + 1,nsig) + sum(levels(1:v_ind-1)) + + dhx_dx_u%val(1) = one - delz + dhx_dx_u%val(2) = delz + dhx_dx_v%val = dhx_dx_u%val + endif + + if(dpressave <= prsln2)then + factw=one + else + factw = data(iff10,i) + if(sfcmod_gfs .or. sfcmod_mm5) then + sfcr = data(isfcr,i) + skint = data(iskint,i) + call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) + end if + + call tintrp2a1(ges_tv,tges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) +! Apply 10-meter wind reduction factor to guess winds + dx10=-goverrd*ten/tges(1) + if (dpressave < dx10)then + term=(prsln2-dpressave)/(prsln2-dx10) + factw=one-term+factw*term + end if + ugesin=factw*ugesin + vgesin=factw*vgesin + + if (save_jacobian) then + dhx_dx_u%val = factw * dhx_dx_u%val + dhx_dx_v%val = factw * dhx_dx_v%val + endif + end if + +! Get approx k value of sfc by using surface pressure + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp(1),nsig,-1) + + endif + + +! Checks based on observation location relative to model surface and top + rlow=max(sfcchk-dpres,zero) + rhgh=max(dpres-r0_001-rsigp,zero) + if(luse(i))then + awork(1) = awork(1) + one + if(rlow/=zero) awork(2) = awork(2) + one + if(rhgh/=zero) awork(3) = awork(3) + one + end if + ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+four*rlow) + +! Compute innovations + lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & + itype==247.or.itype==250.or.itype==251.or.itype==252.or. & + itype==253.or.itype==254.or.itype==257.or.itype==258.or. & + itype==259 + if (lowlevelsat .and. twodvar_regional) then + call windfactor(presw,factw) + data(iuob,i)=factw*data(iuob,i) + data(ivob,i)=factw*data(ivob,i) + uob = data(iuob,i) + vob = data(ivob,i) + endif + dudiff=uob-ugesin + dvdiff=vob-vgesin + spdb=sqrt(uob**2+vob**2)-sqrt(ugesin**2+vgesin**2) + +! Setup dynamic ob error specification for aircraft recon in hurricanes + if (aircraft_recon) then + if (itype==236) then + magomb=sqrt(dudiff*dudiff+dvdiff*dvdiff) + ratio_errors=error/((uv_doe_a_236*magomb+uv_doe_b_236)+drpx+1.0e6_r_kind*rhgh+four*rlow) + endif + if (itype==237) then + magomb=sqrt(dudiff*dudiff+dvdiff*dvdiff) + ratio_errors=error/((uv_doe_a_237*magomb+uv_doe_b_237)+drpx+1.0e6_r_kind*rhgh+four*rlow) + endif + endif + +! Invert observation error + error=one/error + +! Check to see if observation below model surface or above model top. +! If so, don't use observation + if (dpres > rsig )then + if( regional .and. presw > pt_ll )then + dpres=rsig + else + ratio_errors=zero + endif + endif + + if ( (itype>=221 .and. itype<=229).and. (dpres=230 .and. itype <=239 .and. presw <126.0_r_kind ) then + error=zero + endif + +! Quality control for satellite winds + + if ( qc_satwnds ) then + if (itype >=240 .and. itype <=260) then + call intrp2a11(tropprs,trop5,dlat,dlon,mype) + if(presw < trop5-r50) error=zero ! tropopose check for all satellite winds + endif + + if(itype >=240 .and. itype <=260) then + if(i_gsdqc==2) then + prsfc = r10*psges + if( prsfc-presw < 100.0_r_kind) error =zero ! add check for obs within 100 hPa of sfc + else + if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb + endif + endif + if(itype ==242 .or. itype ==243 ) then ! visible winds from JMA and EUMETSAT + if(presw <700.0_r_kind) error=zero ! no visible winds above 700mb + endif + if(itype ==245 ) then + if( presw >399.0_r_kind .and. presw <801.0_r_kind) then !GOES IR winds + error=zero ! no data between 400-800mb + endif + endif + if(itype == 252 .and. presw >499.0_r_kind .and. presw <801.0_r_kind) then ! JMA IR winds + error=zero + endif + if(itype == 253 ) then + if(presw >401.0_r_kind .and. presw <801.0_r_kind) then ! EUMET IR winds + error=zero + endif + endif + if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top + if(presw >399.0_r_kind) error=zero + endif + if(itype ==257 .and. presw <249.0_r_kind) error=zero + if(itype ==258 .and. presw >600.0_r_kind) error=zero + if(itype ==259 .and. presw >600.0_r_kind) error=zero + if(itype ==259 .and. presw <249.0_r_kind) error=zero + endif ! qc_satwnds + +! QC GOES CAWV - some checks above as well + if (itype==247) then + prsfc = r10*psges ! surface pressure in hPa + +! Compute observed and guess wind speeds (m/s). + spdges = sqrt(ugesin* ugesin +vgesin* vgesin ) + +! Set and compute GOES CAWV specific departure parameters + LNVD_wspd = spdob + LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) + LNVD_ratio = LNVD_omb / log(LNVD_wspd) + LNVD_threshold = 3.0_r_kind + if( .not. wrf_nmm_regional) then ! LNVD check not use for CAWV winds in HWRF + if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check + (presw > prsfc-110.0_r_kind .and. isli /= 0))then ! near surface check 110 ~1km + error = zero + endif + endif +! check for direction departure gt 50 deg + wdirdiffmax=50._r_kind + call getwdir(uob,vob,wdirob) + call getwdir(ugesin,vgesin,wdirgesin) + if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & + abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then + error = zero + endif + endif + +! QC MODIS winds + if (itype==257 .or. itype==258 .or. itype==259 .or. itype ==260) then +! Get guess values of tropopause pressure and sea/land/ice +! mask at observation location + prsfc = r10*prsfc ! surface pressure in hPa + +! Compute observed and guess wind speeds (m/s). + spdges = sqrt(ugesin* ugesin +vgesin* vgesin ) + +! Set and computes modis specific qc parameters + LNVD_wspd = spdob + LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) + LNVD_ratio = LNVD_omb / log(LNVD_wspd) + LNVD_threshold = 3.0_r_kind + if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check + (presw > prsfc-r200 .and. isli /= 0))then ! near surface check + error = zero + endif + endif ! ??? + +! QC AVHRR winds + if (itype==244) then +! Get guess values of tropopause pressure and sea/land/ice +! mask at observation location + prsfc = r10*prsfc ! surface pressure in hPa + +! Set and computes modis specific qc parameters + LNVD_wspd = spdob + LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) + LNVD_ratio = LNVD_omb / log(LNVD_wspd) + LNVD_threshold = 3.0_r_kind + + if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check + (presw > prsfc-r200 .and. isli /= 0))then ! near surface check + error = zero + endif + endif ! end if all satellite winds + + +! QC WindSAT winds + if (itype==289) then + qcu = r6 + qcv = r6 + if ( spdob > r20 .or. & ! high wind speed check + abs(dudiff) > qcu .or. & ! u component check + abs(dvdiff) > qcv ) then ! v component check + error = zero + endif + endif + +! QC ASCAT winds + if (itype==290) then + qcu = five + qcv = five +! Compute innovations for opposite vectors + dudiff_opp = -uob - ugesin + dvdiff_opp = -vob - vgesin + vecdiff = sqrt(dudiff**2 + dvdiff**2) + vecdiff_opp = sqrt(dudiff_opp**2 + dvdiff_opp**2) + ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) + + if ( abs(dudiff) > qcu .or. & ! u component check + abs(dvdiff) > qcv .or. & ! v component check + vecdiff > vecdiff_opp ) then ! ambiguity check + + error = zero + endif + endif + +! QC RAPIDSCAT winds + if (itype==296) then + qcu = five + qcv = five +! Compute innovations for opposite vectors + dudiff_opp_rs = -uob - ugesin + dvdiff_opp_rs = -vob - vgesin + vecdiff_rs = sqrt(dudiff**2 + dvdiff**2) + vecdiff_opp_rs = sqrt(dudiff_opp_rs**2 + dvdiff_opp_rs**2) + rapidscat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) + if ( abs(dudiff) > qcu .or. & ! u component check + abs(dvdiff) > qcv .or. & ! v component check + vecdiff_rs > vecdiff_opp_rs ) then ! ambiguity check + error = zero + endif + endif + +! QC OSCAT winds + if (itype==291) then + qcu = r6 + qcv = r6 + oscat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) + +! if ( spdob > r20 .or. & ! high wind speed check +! abs(dudiff) > qcu .or. & ! u component check +! oscat_vec > r0_1 .or. & +! abs(dvdiff) > qcv ) then ! v component check +! error = zero +! else +! write(6,2000) "999291291", data(ilate,i), & +! data(ilone,i), uob, vob, ugesin, vgesin, & +! jiter +! endif + + if (spdob > r20 .or. & + abs(dudiff) > qcu .or. & + oscat_vec > r0_1 .or. & + abs(dvdiff) > qcv) then + error = zero + endif + endif + + +2000 format(a9,1x,2(f8.2,1x),4(f8.2,1x),3x,i3) +2001 format(a6,1x,2(f8.2,1x),4(f8.2,1x),3x,i3,3x,f8.2) + +! If requested, setup for single obs test. + if (oneobtest) then + if (oneob_type=='u') then + dudiff=maginnov + dvdiff=zero + elseif (oneob_type=='v') then + dudiff=zero + dvdiff=maginnov + endif + error=one/magoberr + ratio_errors=one + end if + +! Gross error checks + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + residual = sqrt(dudiff**2+dvdiff**2) + ratio = residual/obserrlm +!! modify cgross depending on the quality mark, qcmark=3, cgross=0.7*cgross +!! apply asymetric gross check for satellite winds + qcgross=cgross(ikx) + if(data(iqc,i) == three ) then + qcgross=r0_7*cgross(ikx) + endif + + if(spdb <0 )then + if(itype ==244) then ! AVHRR, use same as MODIS + qcgross=r0_7*cgross(ikx) + endif + if( itype == 245 .or. itype ==246) then + if(presw <400.0_r_kind .and. presw >300.0_r_kind ) qcgross=r0_7*cgross(ikx) + endif + if(itype == 253 .or. itype ==254) then + if( presw <400.0_r_kind .and. presw >200.0_r_kind) qcgross=r0_7*cgross(ikx) + endif + if(itype >=257 .and. itype <=259 ) then + qcgross=r0_7*cgross(ikx) + endif + endif + + if (ratio>qcgross .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(4) = awork(4)+one + error = zero + ratio_errors = zero + else + ratio_errors = ratio_errors/sqrt(dup(i)) + end if + + if (lowlevelsat .and. twodvar_regional) then + if (data(idomsfc,i) /= 0 .and. data(idomsfc,i) /= 3 ) then + error = zero + ratio_errors = zero + endif + endif + + if (twodvar_regional) then + if (lowlevelsat .or. itype==289 .or. itype==290) then + wdirdiffmax=45._r_kind + else + wdirdiffmax=100000._r_kind + endif + if (spdob > zero .and. (spdob-spdb) > zero) then + call getwdir(uob,vob,wdirob) + call getwdir(ugesin,vgesin,wdirgesin) + if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & + abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then + error = zero + ratio_errors = zero + endif + endif + if (itype==288 .or. itype==295) then !Tyndall & Horel QC for mesonet winds /(WAF 2013, Vol. 28, pg. 285) + if (spdob < one .and. (spdob-spdb) > five) then + error = zero + ratio_errors = zero + endif + endif + endif + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. + if ( (itype==261) .and. (ratio_errors*error <= 1.0E-100_r_kind) ) muse(i)=.false. + + ! As a 2-component observation, muse(i) is not the same as muse_u or muse_v in an obs_diag. + if (nobskeep>0 .and. luse_obsdiag) then + call obsdiagNode_get(my_diagu, jiter=nobskeep, muse=muse_u) + call obsdiagNode_get(my_diagv, jiter=nobskeep, muse=muse_v) + muse(i) = muse_u.and.muse_v + endif + +! Oberror Tuning and Perturb Obs + if(muse(i)) then + if(oberror_tune )then + if( jiter > jiterstart ) then + dudiff=dudiff+data(iptrbu,i)/error/ratio_errors + dvdiff=dvdiff+data(iptrbv,i)/error/ratio_errors + endif + else if(perturb_obs )then + dudiff=dudiff+data(iptrbu,i)/error/ratio_errors + dvdiff=dvdiff+data(iptrbv,i)/error/ratio_errors + endif + endif + + valu = error*dudiff + valv = error*dvdiff + +! Compute penalty terms (linear & nonlinear qc). + if(luse(i))then + val = valu*valu+valv*valv + exp_arg = -half*val + rat_err2 = ratio_errors**2 + if(njqc .and. var_jb>tiny_r_kind .and. var_jb<10.0_r_kind .and. error >tiny_r_kind) then + if(exp_arg == zero) then + wgt=one + else + wgt=sqrt(dudiff*dudiff+dvdiff*dvdiff)*error/sqrt(two*var_jb) + wgt=tanh(wgt)/wgt + endif + term=-two*var_jb*rat_err2*log(cosh((sqrt(val))/sqrt(two*var_jb))) + rwgt = wgt/wgtlim + valqc = -two*term + else if (vqc .and. cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_w=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_w*wnotgross) + term =log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + valqc = -two*rat_err2*term + else + term = exp_arg + wgt = one + rwgt = wgt/wgtlim + valqc = -two*rat_err2*term + endif + + +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + jsig = dpres + jsig=max(1,min(jsig,nsig)) + awork(4*nsig+jsig+100)=awork(4*nsig+jsig+100)+valu*valu*rat_err2 + awork(5*nsig+jsig+100)=awork(5*nsig+jsig+100)+valv*valv*rat_err2 + awork(6*nsig+jsig+100)=awork(6*nsig+jsig+100)+one + awork(3*nsig+jsig+100)=awork(3*nsig+jsig+100)+valqc + end if + +! Loop over pressure level groupings and obs to accumulate statistics +! as a function of observation type. + ress = scale*sqrt(dudiff**2+dvdiff**2) + ressw = ress*ress + val2 = half*(valu*valu+valv*valv) + valqc2 = half*valqc + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + do k = 1,npres_print + if(presw >ptop(k) .and. presw<=pbot(k))then + bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count + bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+spdb ! speed bias + bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 + bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc2 ! nonlin qc penalty + + end if + end do + end if + + +! Fill obs to diagnostics structure + if (luse_obsdiag) then + ! U + call obsdiagNode_set(my_diagu, wgtjo=(error*ratio_errors)**2 ,& + jiter=jiter, muse=muse(i), nldepart=dudiff ) + ! V + call obsdiagNode_set(my_diagv, wgtjo=(error*ratio_errors)**2 ,& + jiter=jiter, muse=muse(i), nldepart=dvdiff ) + endif + +! If obs is "acceptable", load array with obs info for use +! in inner loop minimization (int* and stp* routines) + + if (.not. last .and. muse(i)) then + + allocate(my_head) + call wNode_appendto(my_head,whead(ibin)) + + my_head%idv = is + my_head%iob = ioid(i) + my_head%ich0= wNode_ich0 ! Flagged as a normal obs. + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + + my_head%dlev = dpres + my_head%factw= factw + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) + + do j=1,8 + my_head%wij(j)=factw*my_head%wij(j) + end do + + my_head%ures=dudiff + my_head%vres=dvdiff + my_head%err2=error**2 + my_head%raterr2=ratio_errors **2 + my_head%time = dtime + my_head%b=cvar_b(ikx) + my_head%pg=cvar_pg(ikx) + my_head%jb=var_jb + my_head%luse=luse(i) + + if (luse_obsdiag) then + endif ! (luse_obsdiag) + + if(oberror_tune) then + my_head%upertb=data(iptrbu,i)/error/ratio_errors + my_head%vpertb=data(iptrbv,i)/error/ratio_errors + my_head%kx=ikx + if (njqc) then + ptabluv=ptabl_uv + else + ptabluv=ptabl + endif + if(presw > ptabluv(2))then + my_head%k1=1 + else if( presw <= ptabluv(33)) then + my_head%k1=33 + else + k_loop: do k=2,32 + if(presw > ptabluv(k+1) .and. presw <= ptabluv(k)) then + my_head%k1=k + exit k_loop + endif + enddo k_loop + endif + endif + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diagu, my_head%idv,my_head%iob,my_head%ich0+1_i_kind,myname,"my_diagu:my_head") + call obsdiagNode_assert(my_diagv, my_head%idv,my_head%iob,my_head%ich0+2_i_kind,myname,"my_diagv:my_head") + + my_head%diagu => my_diagu + my_head%diagv => my_diagv + endif ! (luse_obsdiag) + + my_head => null() + end if + +! Save select output for diagnostic file + if (conv_diagsave .and. luse(i)) then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + endif + + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if (binary_diag) call contents_binary_diag_(my_diagu,my_diagv) + if (netcdf_diag) call contents_netcdf_diag_(my_diagu,my_diagv) + + endif + +!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!! + if( .not. last .and. l_pbl_pseudo_itype .and. & + muse(i) .and. dpres > -1.0_r_kind ) then + prest=presw ! in mb + prestsfc=prest + dudiffsfc=dudiff + dvdiffsfc=dvdiff + call tintrp2a11(pbl_height,thisPBL_height,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + ratio_PBL_height = (prest - thisPBL_height) * pblH_ration + if(ratio_PBL_height > zero) thisPBL_height = prest - ratio_PBL_height + prest = prest - pps_press_incr + DO while (prest > thisPBL_height) + ratio_PBL_height=1.0_r_kind-(prestsfc-prest)/(prestsfc-thisPBL_height) + + allocate(my_head) + call wNode_appendto(my_head,whead(ibin)) + + my_head%idv = is ! information needed for re-distribution + my_head%iob = ioid(i) + my_head%ich0= wNode_ich0_PBL_pseudo ! Flagged as a PBL pseudo obs for %diag + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + +!!! find uob and vob + uob = data(iuob,i) + vob = data(ivob,i) + + +! Put obs pressure in correct units to get grid coord. number + dpres=log(prest/r10) + call grdcrd1(dpres,prsltmp(1),nsig,-1) + +! Interpolate guess u and v to observation location and time. + + call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + +!!! Set (i,j,k) indices of guess gridpoint that bound obs location + my_head%dlev = dpres + my_head%factw= 1._r_kind + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) +!!! find ddiff + + dudiff = dudiffsfc*(0.5_r_kind + 0.5_r_kind*ratio_PBL_height) + dvdiff = dvdiffsfc*(0.5_r_kind + 0.5_r_kind*ratio_PBL_height) + + error=one/data(ier2,i) + + my_head%ures=dudiff + my_head%vres=dvdiff + my_head%err2=error**2 + my_head%raterr2=ratio_errors **2 + my_head%time = dtime + my_head%b=cvar_b(ikx) + my_head%pg=cvar_pg(ikx) + my_head%jb=var_jb + my_head%luse=luse(i) + + if (luse_obsdiag) then + call obsdiagNode_assert(my_diagu_pbl, my_head%idv,my_head%iob,my_head%ich0+1_i_kind,myname,"my_diagu_pbl:my_head") + call obsdiagNode_assert(my_diagv_pbl, my_head%idv,my_head%iob,my_head%ich0+2_i_kind,myname,"my_diagv_pbl:my_head") + + !U_pbl_pseudo + call obsdiagNode_set(my_diagu_pbl, wgtjo=(error*ratio_errors)**2 ,& + jiter=jiter, muse=muse(i), nldepart=dudiff ) + !V_pbl_pseudo + call obsdiagNode_set(my_diagv_pbl, wgtjo=(error*ratio_errors)**2 ,& + jiter=jiter, muse=muse(i), nldepart=dvdiff ) + + my_head%diagu => my_diagu_pbl + my_head%diagv => my_diagv_pbl + endif + + prest = prest - pps_press_incr + + my_head => null() + ENDDO + + endif ! 281,283,287 +!!!!!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!!!!!!!!! + + end do loop_for_all_obs +! End of loop over observations + if(num_bad_ikx > 0) write(6,*)' in setupw, num_bad_ikx ( ikx<1 or ikx>nconvtype ) = ',num_bad_ikx + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)' uv',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if + end if + + +! End of routine + + return + contains + + subroutine check_vars_ (proceed) + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::u' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::v' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::tv', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + subroutine init_vars_ + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get u ... + varname='u' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_u))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_u(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_u(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get v ... + varname='v' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_v))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_v(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_v(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get tv ... + varname='tv' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_tv))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_tv(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_tv(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + + write(string,900) jiter +900 format('conv_uv_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(udiag,vdiag) + type(obs_diag),pointer,intent(in):: udiag,vdiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) + rdiagbuf(6,ii) = presw ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = var_jb ! non linear qc parameter + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m/s)**-1 + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m/s)**-1 + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m/s)**-1 + + rdiagbuf(17,ii) = data(iuob,i) ! u wind component observation (m/s) + rdiagbuf(18,ii) = dudiff ! u obs-ges used in analysis (m/s) + rdiagbuf(19,ii) = uob-ugesin ! u obs-ges w/o bias correction (m/s) (future slot) + + rdiagbuf(20,ii) = data(ivob,i) ! v wind component observation (m/s) + rdiagbuf(21,ii) = dvdiff ! v obs-ges used in analysis (m/s) + rdiagbuf(22,ii) = vob-vgesin ! v obs-ges w/o bias correction (m/s) (future slot) + + if(regional) then + +! replace positions 17-22 with earth relative wind component information + + uob_reg=data(iuob,i) + vob_reg=data(ivob,i) + dlon_e=data(ilone,i)*deg2rad + call rotate_wind_xy2ll(uob_reg,vob_reg,uob_e,vob_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(dudiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) + rdiagbuf(17,ii) = uob_e ! earth relative u wind component observation (m/s) + rdiagbuf(18,ii) = dudiff_e ! earth relative u obs-ges used in analysis (m/s) + rdiagbuf(19,ii) = uob_e-uges_e ! earth relative u obs-ges w/o bias correction (m/s) (future slot) + + rdiagbuf(20,ii) = vob_e ! earth relative v wind component observation (m/s) + rdiagbuf(21,ii) = dvdiff_e ! earth relative v obs-ges used in analysis (m/s) + rdiagbuf(22,ii) = vob_e-vges_e ! earth relative v obs-ges w/o bias correction (m/s) (future slot) + end if + + rdiagbuf(23,ii) = factw ! 10m wind reduction factor + rdiagbuf(24,ii) = 1.e+10_r_single ! u spread (filled in by EnKF) + rdiagbuf(25,ii) = 1.e+10_r_single ! v spread (filled in by EnKF) + + ioff=ioff0 + if (lobsdiagsave) then + !?? In this implmentation, only udiag%muse is used. Is this by design + !?? or an unexpected bug? + do jj=1,miter + ioff=ioff+1 + if (udiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + !?? Both u-diag and v-diag are implemented for binary diag output, + !?? but not so for netcdf diag output! See below in subroutine + !?? contents_netcdf_diag_() + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = udiag%nldepart(jj) + ioff=ioff+1 + rdiagbuf(ioff,ii) = vdiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = udiag%tldepart(jj) + ioff=ioff+1 + rdiagbuf(ioff,ii) = vdiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = udiag%obssen(jj) + ioff=ioff+1 + rdiagbuf(ioff,ii) = vdiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + ioff = ioff + 1 + rdiagbuf(ioff,ii) = data(idomsfc,i) ! dominate surface type + ioff = ioff + 1 + rdiagbuf(ioff,ii) = data(izz,i) ! model terrain at ob location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + + if (save_jacobian) then + call writearray(dhx_dx_u, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx_u) + call writearray(dhx_dx_v, rdiagbuf(ioff+1:nreal,ii)) + ioff = ioff + size(dhx_dx_v) + endif + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(udiag,vdiag) + type(obs_diag),pointer,intent(in):: udiag,vdiag +! Observation class + character(7),parameter :: obsclass = ' uv' + real(r_kind),dimension(miter) :: obsdiag_iuse + + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(ielev,i)) ) + call nc_diag_metadata("Pressure", sngl(presw) ) + call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) + call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) +! call nc_diag_metadata("Setup_QC_Mark", rmiss_single ) + call nc_diag_metadata("Setup_QC_Mark", sngl(bmiss) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + endif + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Wind_Reduction_Factor_at_10m", sngl(factw) ) + + if (.not. regional) then + call nc_diag_metadata("u_Observation", sngl(data(iuob,i)) ) + call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", sngl(dudiff) ) + call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted", sngl(uob-ugesin) ) + + call nc_diag_metadata("v_Observation", sngl(data(ivob,i)) ) + call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", sngl(dvdiff) ) + call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", sngl(vob-vgesin) ) + else ! (if regional) +! replace positions 17-22 with earth relative wind component information + + uob_reg=data(iuob,i) + vob_reg=data(ivob,i) + dlon_e=data(ilone,i)*deg2rad + call rotate_wind_xy2ll(uob_reg,vob_reg,uob_e,vob_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) + call rotate_wind_xy2ll(dudiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) + + call nc_diag_metadata("u_Observation", sngl(uob_e) ) + call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", sngl(dudiff_e) ) + call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted", sngl(uob_e-uges_e) ) + + call nc_diag_metadata("v_Observation", sngl(vob_e) ) + call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", sngl(dvdiff_e) ) + call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", sngl(vob_e-vges_e) ) + endif + + if (lobsdiagsave) then + !?? In current implmentation, only udiag is used. Is this by design + !?? or an unexpected bug? + do jj=1,miter + if (udiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", udiag%nldepart ) + !++ call nc_diag_data2d("ObsDiagSave_nldepart", vdiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", udiag%tldepart ) + !++ call nc_diag_data2d("ObsDiagSave_tldepart", vdiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", udiag%obssen ) + !++ call nc_diag_data2d("ObsDiagSave_obssen", vdiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + if (save_jacobian) then + call fullarray(dhx_dx_u, dhx_dx_array) + call nc_diag_data2d("u_Observation_Operator_Jacobian", dhx_dx_array) + call fullarray(dhx_dx_v, dhx_dx_array) + call nc_diag_data2d("v_Observation_Operator_Jacobian", dhx_dx_array) + endif + + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_tv)) deallocate(ges_tv) + if(allocated(ges_v )) deallocate(ges_v ) + if(allocated(ges_u )) deallocate(ges_u ) + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_ps)) deallocate(ges_ps) + end subroutine final_vars_ + +end subroutine setupw +end module w_setup diff --git a/src/setupwspd10m.f90 b/src/gsi/setupwspd10m.f90 similarity index 76% rename from src/setupwspd10m.f90 rename to src/gsi/setupwspd10m.f90 index 86bbb833f..f5a18d77c 100644 --- a/src/setupwspd10m.f90 +++ b/src/gsi/setupwspd10m.f90 @@ -1,4 +1,11 @@ -subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) +module wspd10m_setup + implicit none + private + public:: setup + interface setup; module procedure setupwspd10m; end interface + +contains +subroutine setupwspd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) !$$$ subprogram documentation block ! . . . . ! subprogram: setupwspd10m compute rhs for conventional 10 m wind speed @@ -21,6 +28,11 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) ! . removed (%dlat,%dlon) debris. ! 2016-10-07 pondeca - if(.not.proceed) advance through input file first ! before retuning to setuprhsall.f90 +! 2017-02-06 todling - add netcdf_diag capability; hidden as contained code +! 2017-02-09 guo - Remove m_alloc, n_alloc. +! . Remove my_node with corrected typecast(). +! 2018-01-08 pondeca - addd option l_closeobs to use closest obs to analysis +! time in analysis ! ! input argument list: ! lunin - unit from which to read observations @@ -41,18 +53,29 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) use kinds, only: r_kind,r_single,r_double,i_kind use guess_grids, only: hrdifsig,nfldsig,ges_lnprsl, & - sfcmod_gfs,sfcmod_mm5,comp_fact10,pt_ll - use m_obsdiags, only: wspd10mhead - use obsmod, only: rmiss_single,i_wspd10m_ob_type,obsdiags,& + sfcmod_gfs,sfcmod_mm5,comp_fact10 + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + + use obsmod, only: rmiss_single,& lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset + use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use m_obsNode , only: obsNode use m_wspd10mNode, only: wspd10mNode - use m_obsLList , only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin + use m_wspd10mNode, only: wspd10mNode_appendto + use m_obsLList , only: obsLList + use obsmod, only: luse_obsdiag + use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset use oneobmod, only: magoberr,maginnov,oneobtest use gridmod, only: nsig - use gridmod, only: get_ij,twodvar_regional,regional + use gridmod, only: get_ij,twodvar_regional,regional,pt_ll use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,rd,grav,& two,cg_term,three,four,five,ten,huge_single,r1000,r3600,& grav_ratio,flattening,grav,grav_equator,somigliana, & @@ -61,12 +84,16 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) use qcmod, only: dfact,dfact1,npres_print,qc_satwnds use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show + use m_dtime, only: dtime_setup, dtime_check use gsi_bundlemod, only : gsi_bundlegetpointer use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle + use rapidrefresh_cldsurf_mod, only: l_closeobs implicit none ! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + logical ,intent(in ) :: conv_diagsave integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork @@ -116,7 +143,6 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) integer(i_kind) iuse,ilate,ilone,ielev,izz,iprvd,isprvd integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj,itype integer(i_kind) l,mm1 - integer(i_kind) istat integer(i_kind) idomsfc,iskint,iff10,isfcr logical,dimension(nobs):: luse,muse @@ -131,11 +157,10 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) real(r_double) r_prvstg,r_sprvstg logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode ), pointer:: my_node type(wspd10mNode), pointer:: my_head type(obs_diag ), pointer:: my_diag + type(obs_diags ), pointer:: my_diagLL + real(r_kind) :: hr_offset equivalence(rstation_id,station_id) @@ -149,6 +174,9 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv real(r_kind),allocatable,dimension(:,:,: ) :: ges_wspd10m + type(obsLList),pointer,dimension(:):: wspd10mhead + wspd10mhead => obsLL(:) + ! Check to see if required guess fields are available call check_vars_(proceed) if(.not.proceed) then @@ -159,8 +187,6 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) ! If require guess vars available, extract from bundle ... call init_vars_ - n_alloc(:)=0 - m_alloc(:)=0 !********************************************************************************* ! Read and reformat observations in work arrays. spdb=zero @@ -205,18 +231,26 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) end do ! Check for duplicate observations at same location + hr_offset=min_offset/60.0_r_kind dup=one do k=1,nobs do l=k+1,nobs if(data(ilat,k) == data(ilat,l) .and. & data(ilon,k) == data(ilon,l) .and. & - data(ipres,k) == data(ipres,l) .and. & data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & muse(k) .and. muse(l))then - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) + if(l_closeobs) then + if(abs(data(itime,k)-hr_offset)nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + if(luse_obsdiag) my_diagLL => odiagLL(ibin) + ! Link obs to diagnostics structure if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_wspd10m_ob_type,ibin)%head)) then - obsdiags(i_wspd10m_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_wspd10m_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupwspd10m: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_wspd10m_ob_type,ibin)%tail => obsdiags(i_wspd10m_ob_type,ibin)%head - else - allocate(obsdiags(i_wspd10m_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupwspd10m: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_wspd10m_ob_type,ibin)%tail => obsdiags(i_wspd10m_ob_type,ibin)%tail%next - end if - obsdiags(i_wspd10m_ob_type,ibin)%n_alloc = obsdiags(i_wspd10m_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_wspd10m_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_wspd10m_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_wspd10m_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_wspd10m_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_wspd10m_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_wspd10m_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_wspd10m_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_wspd10m_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_wspd10m_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_wspd10m_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_wspd10m_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_wspd10m_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_wspd10m_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_wspd10m_ob_type,ibin)%tail)) then - obsdiags(i_wspd10m_ob_type,ibin)%tail => obsdiags(i_wspd10m_ob_type,ibin)%head - else - obsdiags(i_wspd10m_ob_type,ibin)%tail => obsdiags(i_wspd10m_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_wspd10m_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_wspd10m_ob_type,ibin)%tail)') - end if - if (obsdiags(i_wspd10m_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupwspd10m: index error' - call stop2(297) - end if - end if + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode, create =', .not.lobsdiag_allocated) end if if(.not.in_curbin) cycle @@ -543,7 +538,7 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_wspd10m_ob_type,ibin)%tail%muse(nobskeep) + if (nobskeep>0 .and. luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) ! Compute penalty terms (linear & nonlinear qc). val = error*ddiff @@ -593,9 +588,8 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) endif if(luse_obsdiag)then - obsdiags(i_wspd10m_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_wspd10m_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_wspd10m_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 + call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff ) end if ! If obs is "acceptable", load array with obs info for use @@ -603,10 +597,7 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) if (.not. last .and. muse(i)) then allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(wspd10mhead(ibin),my_node) - my_node => null() + call wspd10mNode_appendto(my_head,wspd10mhead(ibin)) my_head%idv = is my_head%iob = ioid(i) @@ -625,17 +616,8 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) my_head%luse = luse(i) if(luse_obsdiag)then - my_head%diags => obsdiags(i_wspd10m_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif + call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head') + my_head%diags => my_diag end if my_head => null() @@ -645,30 +627,9 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) ! Save stuff for diagnostic output if(conv_diagsave .and. luse(i))then ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) - rdiagbuf(6,ii) = presw ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) if (ratio_errors*error>tiny_r_kind) then err_final = one/(ratio_errors*error) else @@ -682,50 +643,8 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst if (err_final>tiny_r_kind) errinv_final = one/err_final - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (ms*-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (ms**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (ms**-1) - - rdiagbuf(17,ii) = spdob ! 10m wind speed observation (ms**-1) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (ms**-1) - rdiagbuf(19,ii) = spdob-spdges ! obs-ges w/o bias correction (ms**-1) (future slot) - - rdiagbuf(20,ii) = factw ! 10m wind reduction factor - - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_wspd10m_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_wspd10m_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_wspd10m_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_wspd10m_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominant surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) end if @@ -736,16 +655,18 @@ subroutine setupwspd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) call final_vars_ ! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:wspd10m',i_wspd10m_ob_type) - write(7)'wst',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) + if(conv_diagsave)then + if(netcdf_diag) call nc_diag_write + if(binary_diag .and. ii>0)then + write(7)'wst',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif + if (twodvar_regional) then + write(7)cprvstg(1:ii),csprvstg(1:ii) + deallocate(cprvstg,csprvstg) + endif + end if end if ! End of routine @@ -895,6 +816,163 @@ subroutine init_vars_ endif end subroutine init_vars_ + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_wspd10m_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + endif + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + endif + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) + rdiagbuf(6,ii) = presw ! observation pressure (hPa) + rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) + rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) + + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + endif + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (ms**-1) + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (ms**-1) + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (ms**-1) + + rdiagbuf(17,ii) = spdob ! 10m wind speed observation (ms**-1) + rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (ms**-1) + rdiagbuf(19,ii) = spdob-spdges ! obs-ges w/o bias correction (ms**-1) (future slot) + + rdiagbuf(20,ii) = factw ! 10m wind reduction factor + + + ioff=ioff0 + if (lobsdiagsave) then + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + if (twodvar_regional) then + rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominant surface type + rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location + r_prvstg = data(iprvd,i) + cprvstg(ii) = c_prvstg ! provider name + r_sprvstg = data(isprvd,i) + csprvstg(ii) = c_sprvstg ! subprovider name + endif + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = 'wspd10m' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", data(ilate,i) ) + call nc_diag_metadata("Longitude", data(ilone,i) ) + call nc_diag_metadata("Station_Elevation", data(ielev,i) ) + call nc_diag_metadata("Pressure", presw ) + call nc_diag_metadata("Height", data(ihgt,i) ) + call nc_diag_metadata("Time", dtime-time_offset ) + call nc_diag_metadata("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Prep_Use_Flag", data(iuse,i) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", rwgt ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif + + call nc_diag_metadata("Errinv_Input", errinv_input ) + call nc_diag_metadata("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata("Errinv_Final", errinv_final ) + + call nc_diag_metadata("Observation", spdob ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", ddiff ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", spdob-spdges ) + + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + endif + enddo + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + endif + + if (twodvar_regional) then + call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) + call nc_diag_metadata("Model_Terrain", data(izz,i) ) + r_prvstg = data(iprvd,i) + call nc_diag_metadata("Provider_Name", c_prvstg ) + r_sprvstg = data(isprvd,i) + call nc_diag_metadata("Subprovider_Name", c_sprvstg ) + endif + end subroutine contents_netcdf_diag_ + subroutine final_vars_ if(allocated(ges_z )) deallocate(ges_z ) if(allocated(ges_ps )) deallocate(ges_ps ) @@ -905,4 +983,4 @@ subroutine final_vars_ end subroutine final_vars_ end subroutine setupwspd10m - +end module wspd10m_setup diff --git a/src/sfc_model.f90 b/src/gsi/sfc_model.f90 similarity index 100% rename from src/sfc_model.f90 rename to src/gsi/sfc_model.f90 diff --git a/src/sfcobsqc.f90 b/src/gsi/sfcobsqc.f90 similarity index 92% rename from src/sfcobsqc.f90 rename to src/gsi/sfcobsqc.f90 index bd766f910..8327b532e 100644 --- a/src/sfcobsqc.f90 +++ b/src/gsi/sfcobsqc.f90 @@ -21,6 +21,7 @@ module sfcobsqc ! 2014-07-11 carley - add reject list for lcbas and tcamt ! 2014-10-01 Xue - add GSD surface data uselist ! 2015-07-10 pondeca - add reject list for cldch +! 2018-03-14 pondeca - add station accept list for mesonet visibility ! ! subroutines included: ! sub init_rjlists @@ -51,6 +52,7 @@ module sfcobsqc character(80),allocatable,dimension(:)::t_day_rjlist,t_night_rjlist character(80),allocatable,dimension(:)::q_day_rjlist,q_night_rjlist character(8),allocatable,dimension(:,:)::csta_windbin + character(80),allocatable,dimension(:)::csta_visuse integer(i_kind) sfcuselist_nt_use character(8),allocatable,dimension(:)::sfcuselist_use_id @@ -58,7 +60,7 @@ module sfcobsqc character(1),allocatable,dimension(:)::t_use_sfcuselist character(1),allocatable,dimension(:)::td_use_sfcuselist - integer(i_kind) nprov,nwrjs,ntrjs,nprjs,nqrjs,nsta_mesowind_use + integer(i_kind) nprov,nwrjs,ntrjs,nprjs,nqrjs,nsta_mesowind_use,nsta_mesovis_use integer(i_kind) ntdrjs,nmxtmrjs,nmitmrjs,npmslrjs,nhowvrjs,& nlcbasrjs,ntcamtrjs,ncldchrjs integer(i_kind) ntrjs_day,ntrjs_night @@ -87,6 +89,7 @@ module sfcobsqc logical q_day_listexist logical q_night_listexist logical wbinlistexist + logical vis_uselistexist public init_rjlists public get_usagerj @@ -149,22 +152,22 @@ subroutine init_gsd_sfcuselist if(gsdsfclistexist) then open (use_unit,file='gsd_sfcobs_uselist.txt',form='formatted') -7746 continue - read(use_unit,'(a150)',end=7745) cstring - if(cstring(1:1) == ';') goto 7746 ! skip comments marked as ; + read_use: do + read(use_unit,'(a150)',end=7745) cstring + if(cstring(1:1) == ';') cycle read_use ! skip comments marked as ; - sfcuselist_nt_use=sfcuselist_nt_use+1 - sfcuselist_use_id(sfcuselist_nt_use)= adjustl(cstring(1:10)) - w_use_sfcuselist(sfcuselist_nt_use)= adjustl(cstring(11:12)) - t_use_sfcuselist(sfcuselist_nt_use)= adjustl(cstring(13:14)) - td_use_sfcuselist(sfcuselist_nt_use)= adjustl(cstring(15:16)) - if(verbose) print*,'sfcuselist_use_id=',sfcuselist_nt_use,& + sfcuselist_nt_use=sfcuselist_nt_use+1 + sfcuselist_use_id(sfcuselist_nt_use)= adjustl(cstring(1:10)) + w_use_sfcuselist(sfcuselist_nt_use)= adjustl(cstring(11:12)) + t_use_sfcuselist(sfcuselist_nt_use)= adjustl(cstring(13:14)) + td_use_sfcuselist(sfcuselist_nt_use)= adjustl(cstring(15:16)) + if(verbose) print*,'sfcuselist_use_id=',sfcuselist_nt_use,& sfcuselist_use_id(sfcuselist_nt_use),& ",",w_use_sfcuselist(sfcuselist_nt_use),& ",",t_use_sfcuselist(sfcuselist_nt_use),& ",",t_use_sfcuselist(sfcuselist_nt_use) - goto 7746 + end do read_use 7745 continue endif close(use_unit) @@ -391,6 +394,7 @@ subroutine init_rjlists allocate(t_night_rjlist(nmax)) allocate(q_day_rjlist(nmax)) allocate(q_night_rjlist(nmax)) + allocate(csta_visuse(nmax)) !==> Read mesonet provider names from the uselist clistname='mesonetuselist' @@ -508,10 +512,10 @@ subroutine init_rjlists if(listexist2) then open (meso_unit,file='mesonet_stnuselist',form='formatted') ncount=0 -180 continue - ncount=ncount+1 - read(meso_unit,'(a5,a80)',end=181) csta_winduse(ncount),cstring - goto 180 + do + ncount=ncount+1 + read(meso_unit,'(a5,a80)',end=181) csta_winduse(ncount),cstring + end do 181 continue nsta_mesowind_use=ncount-1 if(verbose)& @@ -530,13 +534,13 @@ subroutine init_rjlists read(meso_unit,'(a16,i2)',end=191) ch16,nbins allocate(nwbaccpts(max(1,nbins))) nwbaccpts(:)=0 -190 continue - read(meso_unit,'(a8,3x,a8,3x,f7.4,2x,f9.4,3x,i2)',end=191) ach8,bch8,aa1,aa2,ibin - nwbaccpts(ibin)=nwbaccpts(ibin)+1 - goto 190 + do + read(meso_unit,'(a8,3x,a8,3x,f7.4,2x,f9.4,3x,i2)',end=191) ach8,bch8,aa1,aa2,ibin + nwbaccpts(ibin)=nwbaccpts(ibin)+1 + end do 191 continue if(verbose)then - print*,'wdirbinuselist: number of bins=',nbins + print*,'wdirbinuselist: number of bins=',nbins print*,'wdirbinuselist: (nwbaccpts(ibin),ibin=1,nbins)=',(nwbaccpts(ibin),ibin=1,nbins) endif @@ -549,15 +553,31 @@ subroutine init_rjlists rewind(meso_unit) read(meso_unit,'(a16,i2)',end=193) ch16,nbins nwbaccpts(:)=0 -192 continue - read(meso_unit,'(a8,3x,a8,3x,f7.4,2x,f9.4,3x,i2)',end=193) ach8,bch8,aa1,aa2,ibin - nwbaccpts(ibin)=nwbaccpts(ibin)+1 - csta_windbin(nwbaccpts(ibin),ibin)=ach8 - goto 192 + do + read(meso_unit,'(a8,3x,a8,3x,f7.4,2x,f9.4,3x,i2)',end=193) ach8,bch8,aa1,aa2,ibin + nwbaccpts(ibin)=nwbaccpts(ibin)+1 + csta_windbin(nwbaccpts(ibin),ibin)=ach8 + end do 193 continue endif close(meso_unit) +!==> Read in 'good' mesonet station names from the station uselist for visibility + inquire(file='mesonet_stnuselist_for_vis',exist=vis_uselistexist) + if(vis_uselistexist) then + open (meso_unit,file='mesonet_stnuselist_for_vis',form='formatted') + ncount=0 + do + ncount=ncount+1 + read(meso_unit,'(a5,a80)',end=194) csta_visuse(ncount),cstring + end do +194 continue + nsta_mesovis_use=ncount-1 +! if(verbose)& + print*,'mesonet_stnuselist_for_vis: nsta_mesovis_use=',nsta_mesovis_use + endif + close(meso_unit) + end subroutine init_rjlists subroutine get_usagerj(kx,obstype,c_station_id,c_prvstg,c_sprvstg, & @@ -823,9 +843,9 @@ subroutine get_usagerj(kx,obstype,c_station_id,c_prvstg,c_sprvstg, & usage_rj=r6000 if (listexist) then !note that uselists must precede the rejectlist do m=1,nprov -! if (trim(c_prvstg//c_sprvstg) == trim(cprovider(m))) then - if (c_prvstg(1:8) == cprovider(m)(1:8) .and. (c_sprvstg(1:8) == cprovider(m)(9:16) & - .or. cprovider(m)(9:16) == 'allsprvs') ) then + if (cprovider(m)(1:7)=='allprvs' .or. & + (c_prvstg(1:8) == cprovider(m)(1:8) .and. (c_sprvstg(1:8) == cprovider(m)(9:16) & + .or. cprovider(m)(9:16) == 'allsprvs')) ) then usage_rj=usage_rj0 exit endif @@ -873,9 +893,24 @@ subroutine get_usagerj(kx,obstype,c_station_id,c_prvstg,c_sprvstg, & end if +!==> station uselist for mesonet visibility + + if (obstype=='vis' .and.( kx==188.or.kx==288.or.kx==195.or.kx==295) )then + usage_rj=r6000 + if (vis_uselistexist .and. usage_rj/=usage_rj0) then !note that usage_rj could differ from usage_rj0 after the rejectlist application + do m=1,nsta_mesovis_use !which happens to be currently unavailable for vis + nlen=len_trim(csta_visuse(m)) + if (c_station_id(1:nlen) == csta_visuse(m)(1:nlen)) then + usage_rj=usage_rj0 + exit + endif + enddo + endif + end if + if (twodvar_regional) then call tll2xy(dlon,dlat,xob,yob,outside) - if (.not.outside) call valley_adjustment(xob,yob,usage_rj) + if ((obstype=='t' .or. obstype=='q') .and. .not.outside) call valley_adjustment(xob,yob,usage_rj) endif end subroutine get_usagerj @@ -902,9 +937,9 @@ subroutine get_gustqm(kx,c_station_id,c_prvstg,c_sprvstg,gustqm) gustqm=9 if (listexist) then do m=1,nprov -! if (trim(c_prvstg//c_sprvstg) == trim(cprovider(m))) then - if (c_prvstg(1:8) == cprovider(m)(1:8) .and. (c_sprvstg(1:8) == cprovider(m)(9:16) & - .or. cprovider(m)(9:16) == 'allsprvs') ) then + if (cprovider(m)(1:7)=='allprvs' .or. & + (c_prvstg(1:8) == cprovider(m)(1:8) .and. (c_sprvstg(1:8) == cprovider(m)(9:16) & + .or. cprovider(m)(9:16) == 'allsprvs')) ) then gustqm=0 exit endif @@ -987,12 +1022,13 @@ subroutine readin_rjlists(clistname,fexist,clist,ndim,ncount) read(meso_unit,*,end=131) cstring enddo n=0 -130 continue - n=n+1 - read(meso_unit,*,end=131) clist(n) - goto 130 + do + n=n+1 + read(meso_unit,*,end=131) clist(n) + end do 131 continue ncount=n-1 + close(meso_unit) endif end subroutine readin_rjlists @@ -1040,6 +1076,7 @@ subroutine destroy_rjlists deallocate(cldch_rjlist) if(wbinlistexist) deallocate(nwbaccpts) if(wbinlistexist) deallocate(csta_windbin) + deallocate(csta_visuse) end subroutine destroy_rjlists diff --git a/src/simpin1.f90 b/src/gsi/simpin1.f90 similarity index 100% rename from src/simpin1.f90 rename to src/gsi/simpin1.f90 diff --git a/src/simpin1_init.f90 b/src/gsi/simpin1_init.f90 similarity index 100% rename from src/simpin1_init.f90 rename to src/gsi/simpin1_init.f90 diff --git a/src/smooth_polcarf.f90 b/src/gsi/smooth_polcarf.f90 similarity index 100% rename from src/smooth_polcarf.f90 rename to src/gsi/smooth_polcarf.f90 diff --git a/src/smoothrf.f90 b/src/gsi/smoothrf.f90 similarity index 100% rename from src/smoothrf.f90 rename to src/gsi/smoothrf.f90 diff --git a/src/smoothwwrf.f90 b/src/gsi/smoothwwrf.f90 similarity index 100% rename from src/smoothwwrf.f90 rename to src/gsi/smoothwwrf.f90 diff --git a/src/smoothzrf.f90 b/src/gsi/smoothzrf.f90 similarity index 100% rename from src/smoothzrf.f90 rename to src/gsi/smoothzrf.f90 diff --git a/src/gsi/sparsearr.f90 b/src/gsi/sparsearr.f90 new file mode 100644 index 000000000..f8f9d41ec --- /dev/null +++ b/src/gsi/sparsearr.f90 @@ -0,0 +1,361 @@ +module sparsearr +!$$$ module documentation block +! . . . . +! module: sparsearr +! prgmmr: shlyaeva +! +! abstract: define sparse array (for saving the jacobian for EnKF) and basic routines +! +! program history log: +! 2016-11-29 shlyaeva - initial code +! +! subroutines included: +! sub new +! sub delete +! sub writearray +! sub readarray +! +! functions included: +! size +! +! attributes: +! language: f90 +! machine: +! +!$$$ + +use kinds, only: r_single, r_kind, i_kind +implicit none +private + +public sparr, sparr2 +public new, delete, size +public writearray, readarray, fullarray +public assignment(=) + +! general sparse array type +! saves all non-zero elements and their indices +type sparr + integer(i_kind) :: nnz ! number of non-zero elements + real(r_kind), dimension(:), allocatable :: val ! values of non-zero elements + integer(i_kind), dimension(:), allocatable :: ind ! indices of non-zero elements +end type sparr + +! sparse array with dense subarrays type +! saves all non-zero elements and start and end indices of the dense +! subarrays +! i.e. for array +! index 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 +! value 0 0 0 1 2 3 0 0 0 0 0 4 5 6 7 0 0 0 0 0 +! nind: 2 +! st_ind: 4, 12 +! end_ind: 6, 15 +! val: 1, 2, 3, 4, 5, 6, 7 +type sparr2 + integer(i_kind) :: nnz + integer(i_kind) :: nind ! number of indices + integer(i_kind), dimension(:), allocatable :: st_ind ! start indices for dense subarrays + integer(i_kind), dimension(:), allocatable :: end_ind ! end indices for dense subarrays + real(r_kind), dimension(:), allocatable :: val ! values of non-zero elements +end type sparr2 + +! interfaces +! constructor +interface new + module procedure init_sparr2 + module procedure init_sparr +end interface + +interface assignment(=) + module procedure sparr2_to_sparr + module procedure array_to_sparr +end interface + +! destructor +interface delete + module procedure cleanup_sparr2 + module procedure cleanup_sparr +end interface + +! writing out sparse array to array +interface writearray + module procedure writearray_sparr2 + module procedure writearray_r_sparr2 +end interface + +! reading sparse array from array +interface readarray + module procedure readarray_sparr2 + module procedure readarray_r_sparr2 +end interface + +! returns size of the sparse array +interface size + module procedure size_sparr2 + module procedure size_sparr +end interface + +! returns full array from sparse array +interface fullarray + module procedure fullarray_sparr2 +end interface + +contains +! private subroutines + +! constructor for sparr2 +subroutine init_sparr2(this, nnz, nind) + type(sparr2), intent(inout) :: this + integer(i_kind), intent(in) :: nnz, nind + + this%nnz = nnz + this%nind = nind + if (allocated(this%st_ind)) deallocate(this%st_ind) + if (allocated(this%end_ind)) deallocate(this%end_ind) + if (allocated(this%val)) deallocate(this%val) + + allocate(this%st_ind(nind), this%end_ind(nind), this%val(nnz)) + +end subroutine init_sparr2 + +! constructor for sparr +subroutine init_sparr(this, nnz) + type(sparr), intent(inout) :: this + integer(i_kind), intent(in) :: nnz + + this%nnz = nnz + if (allocated(this%ind)) deallocate(this%ind) + if (allocated(this%val)) deallocate(this%val) + + allocate(this%ind(nnz), this%val(nnz)) + +end subroutine init_sparr + +! copying constructor for sparr (from sparr2) +subroutine sparr2_to_sparr(this, sp2) + type(sparr), intent(inout) :: this + type(sparr2), intent(in) :: sp2 + + integer(i_kind) :: inz, nnz + integer(i_kind) :: i, j + real(r_kind), dimension(:), allocatable :: nzval ! values of non-zero elements + integer(i_kind), dimension(:), allocatable :: nzind ! indices of non-zero elements + + allocate(nzval(sp2%nnz), nzind(sp2%nnz)) + nnz = 0 + inz = 1 + do i = 1, sp2%nind + do j = sp2%st_ind(i), sp2%end_ind(i) + if (sp2%val(inz) /= 0) then + nnz = nnz + 1 + nzval(nnz) = sp2%val(inz) + nzind(nnz) = j + endif + inz = inz + 1 + enddo + enddo + + call init_sparr(this,nnz) + + this%ind = nzind(1:nnz) + this%val = nzval(1:nnz) + deallocate(nzval, nzind) + +end subroutine sparr2_to_sparr + +! copying constructor for sparr (from full array) +subroutine array_to_sparr(this, arr) + type(sparr), intent(inout) :: this + real(r_single), dimension(:), intent(in) :: arr + + integer(i_kind) :: i, nnz, n + real(r_kind), dimension(:), allocatable :: nzval ! values of non-zero elements + integer(i_kind), dimension(:), allocatable :: nzind ! indices of non-zero elements + + n = size(arr) + allocate(nzval(n), nzind(n)) + nnz = 0 + do i = 1, n + if (arr(i) /= 0) then + nnz = nnz + 1 + nzval(nnz) = arr(i) + nzind(nnz) = i + endif + enddo + call init_sparr(this, nnz) + this%ind = nzind(1:nnz) + this%val = nzval(1:nnz) + + deallocate(nzind, nzval) + +end subroutine array_to_sparr + +! destructor for sparr2 +subroutine cleanup_sparr2(this) + type(sparr2), intent(inout) :: this + + if (allocated(this%st_ind)) deallocate(this%st_ind) + if (allocated(this%end_ind)) deallocate(this%end_ind) + if (allocated(this%val)) deallocate(this%val) + this%nnz = 0 + this%nind = 0 +end subroutine cleanup_sparr2 + +! destructor for sparr +subroutine cleanup_sparr(this) + type(sparr), intent(inout) :: this + + if (allocated(this%ind)) deallocate(this%ind) + if (allocated(this%val)) deallocate(this%val) + this%nnz = 0 +end subroutine cleanup_sparr + + +! returns "size" (2 + 2*nind + nnz) of sparr2 +integer(i_kind) function size_sparr2(this) + type(sparr2), intent(in) :: this + + size_sparr2 = 2 + this%nnz + 2*this%nind +end function size_sparr2 + +! returns "size" (1 + 2*nnz) of sparr +integer(i_kind) function size_sparr(this) + type(sparr), intent(in) :: this + + size_sparr = 1 + 2*this%nnz +end function size_sparr + + +! writing out sparse array to array +subroutine writearray_sparr2(this, array, ierr) + type(sparr2), intent(in) :: this + real(r_single), dimension(:), intent(inout) :: array + integer(i_kind), optional, intent(out) :: ierr + + integer(i_kind) :: ind + + if (present(ierr)) ierr = 0 + if (size(array) < size_sparr2(this)) then + print *, 'Error writing sparse array to array: array size too small' + if (present(ierr)) ierr = -1 + return + endif + + ind = 1 + array(ind) = this%nnz + ind = ind + 1 + array(ind) = this%nind + ind = ind + 1 + array(ind:ind+this%nind-1) = this%st_ind + ind = ind + this%nind + array(ind:ind+this%nind-1) = this%end_ind + ind = ind + this%nind + array(ind:ind+this%nnz-1) = this%val + +end subroutine writearray_sparr2 + +! writing out sparse array to array +subroutine writearray_r_sparr2(this, array, ierr) + type(sparr2), intent(in) :: this + real(r_kind), dimension(:), intent(inout) :: array + integer(i_kind), optional, intent(out) :: ierr + + integer(i_kind) :: ind + + if (present(ierr)) ierr = 0 + if (size(array) < size_sparr2(this)) then + print *, 'Error writing sparse array to array: array size too small' + if (present(ierr)) ierr = -1 + return + endif + + ind = 1 + array(ind) = this%nnz + ind = ind + 1 + array(ind) = this%nind + ind = ind + 1 + array(ind:ind+this%nind-1) = this%st_ind + ind = ind + this%nind + array(ind:ind+this%nind-1) = this%end_ind + ind = ind + this%nind + array(ind:ind+this%nnz-1) = this%val + +end subroutine writearray_r_sparr2 + + +! reading sparse array from array +subroutine readarray_sparr2(this, array) + type(sparr2), intent(inout) :: this + real(r_single), dimension(:), intent(in) :: array + + integer(i_kind) :: ind, nnz, nind + + ind = 1 + nnz = array(ind) + ind = ind + 1 + nind = array(ind) + ind = ind + 1 + + call init_sparr2(this, nnz, nind) + + this%st_ind = array(ind:ind+nind-1) + ind = ind + nind + this%end_ind = array(ind:ind+nind-1) + ind = ind + nind + this%val = array(ind:ind+nnz-1) + +end subroutine readarray_sparr2 + +! reading sparse array from array +subroutine readarray_r_sparr2(this, array) + type(sparr2), intent(inout) :: this + real(r_kind), dimension(:), intent(in) :: array + + integer(i_kind) :: ind, nnz, nind + + ind = 1 + nnz = array(ind) + ind = ind + 1 + nind = array(ind) + ind = ind + 1 + + call init_sparr2(this, nnz, nind) + + this%st_ind = array(ind:ind+nind-1) + ind = ind + nind + this%end_ind = array(ind:ind+nind-1) + ind = ind + nind + this%val = array(ind:ind+nnz-1) + +end subroutine readarray_r_sparr2 + +! returns full array from sparse array +subroutine fullarray_sparr2(this, array, ierr) + type(sparr2), intent(in) :: this + real(r_single), dimension(:), intent(inout) :: array + integer(i_kind), optional, intent(out) :: ierr + + integer(i_kind) :: i, j, inz + + inz = 1 + array = 0._r_single + + ! check if array is appropriate size + if (present(ierr)) ierr = 0 + if ((size(array) < this%nnz) .or. & + (size(array) < maxval(this%end_ind))) then + print *, 'Error in saving full array from sparse array: array size too small' + if (present(ierr)) ierr = -1 + return + endif + + do i = 1, this%nind + do j = this%st_ind(i), this%end_ind(i) + array(j) = this%val(inz) + inz = inz + 1 + enddo + enddo + +end subroutine fullarray_sparr2 + +end module sparsearr diff --git a/src/sqrtmin.f90 b/src/gsi/sqrtmin.f90 similarity index 100% rename from src/sqrtmin.f90 rename to src/gsi/sqrtmin.f90 diff --git a/src/ssmis_spatial_average_mod.f90 b/src/gsi/ssmis_spatial_average_mod.f90 similarity index 92% rename from src/ssmis_spatial_average_mod.f90 rename to src/gsi/ssmis_spatial_average_mod.f90 index 86c4e187a..24ac91d3f 100644 --- a/src/ssmis_spatial_average_mod.f90 +++ b/src/gsi/ssmis_spatial_average_mod.f90 @@ -1274,67 +1274,72 @@ SUBROUTINE SFFTCF( X, N, M ) ! IF ( N .EQ. 1 ) RETURN ! - 100 J = 1 + J = 1 N1 = N - 1 - DO 104, I = 1, N1 - IF ( I .GE. J ) GOTO 101 - XT = X(J) - X(J) = X(I) - X(I) = XT - 101 K = N / 2 - 102 IF ( K .GE. J ) GOTO 103 + DO 104 I = 1, N1 + IF ( I < J ) THEN + XT = X(J) + X(J) = X(I) + X(I) = XT + END IF + K = N / 2 + DO WHILE ( K < J ) J = J - K K = K / 2 - GOTO 102 - 103 J = J + K + END DO + J = J + K 104 CONTINUE ! IS = 1 ID = 4 - 70 DO 60, I0 = IS, N, ID - I1 = I0 + 1 - R1 = X(I0) - X(I0) = R1 + X(I1) - X(I1) = R1 - X(I1) - 60 CONTINUE - IS = 2 * ID - 1 - ID = 4 * ID - IF ( IS .LT. N ) GOTO 70 + DO + DO 60 I0 = IS, N, ID + I1 = I0 + 1 + R1 = X(I0) + X(I0) = R1 + X(I1) + X(I1) = R1 - X(I1) + 60 CONTINUE + IS = 2 * ID - 1 + ID = 4 * ID + IF ( IS >= N ) EXIT + END DO ! N2 = 2 - DO 10, K = 2, M + DO 10 K = 2, M N2 = N2 * 2 N4 = N2 / 4 N8 = N2 / 8 E = TWOPI / N2 IS = 0 ID = N2 * 2 - 40 DO 38, I = IS, N-1, ID - I1 = I + 1 - I2 = I1 + N4 - I3 = I2 + N4 - I4 = I3 + N4 - T1 = X(I4) + X(I3) - X(I4) = X(I4) - X(I3) - X(I3) = X(I1) - T1 - X(I1) = X(I1) + T1 - IF ( N4 .EQ. 1 ) GOTO 38 - I1 = I1 + N8 - I2 = I2 + N8 - I3 = I3 + N8 - I4 = I4 + N8 - T1 = ( X(I3) + X(I4) ) / SQRT2 - T2 = ( X(I3) - X(I4) ) / SQRT2 - X(I4) = X(I2) - T1 - X(I3) = - X(I2) - T1 - X(I2) = X(I1) - T2 - X(I1) = X(I1) + T2 - 38 CONTINUE - IS = 2 * ID - N2 - ID = 4 * ID - IF ( IS .LT. N ) GOTO 40 + DO + DO 38 I = IS, N-1, ID + I1 = I + 1 + I2 = I1 + N4 + I3 = I2 + N4 + I4 = I3 + N4 + T1 = X(I4) + X(I3) + X(I4) = X(I4) - X(I3) + X(I3) = X(I1) - T1 + X(I1) = X(I1) + T1 + IF ( N4 == 1 ) CYCLE + I1 = I1 + N8 + I2 = I2 + N8 + I3 = I3 + N8 + I4 = I4 + N8 + T1 = ( X(I3) + X(I4) ) / SQRT2 + T2 = ( X(I3) - X(I4) ) / SQRT2 + X(I4) = X(I2) - T1 + X(I3) = - X(I2) - T1 + X(I2) = X(I1) - T2 + X(I1) = X(I1) + T2 + 38 CONTINUE + IS = 2 * ID - N2 + ID = 4 * ID + IF ( IS >= N ) EXIT + END DO A = E - DO 32, J = 2, N8 + DO 32 J = 2, N8 A3 = 3 * A CC1 = COS(A) SS1 = SIN(A) @@ -1343,39 +1348,41 @@ SUBROUTINE SFFTCF( X, N, M ) A = J * E IS = 0 ID = 2 * N2 - 36 DO 30, I = IS, N-1, ID - I1 = I + J - I2 = I1 + N4 - I3 = I2 + N4 - I4 = I3 + N4 - I5 = I + N4 - J + 2 - I6 = I5 + N4 - I7 = I6 + N4 - I8 = I7 + N4 - T1 = X(I3) * CC1 + X(I7) * SS1 - T2 = X(I7) * CC1 - X(I3) * SS1 - T3 = X(I4) * CC3 + X(I8) * SS3 - T4 = X(I8) * CC3 - X(I4) * SS3 - T5 = T1 + T3 - T6 = T2 + T4 - T3 = T1 - T3 - T4 = T2 - T4 - T2 = X(I6) + T6 - X(I3) = T6 - X(I6) - X(I8) = T2 - T2 = X(I2) - T3 - X(I7) = - X(I2) - T3 - X(I4) = T2 - T1 = X(I1) + T5 - X(I6) = X(I1) - T5 - X(I1) = T1 - T1 = X(I5) + T4 - X(I5) = X(I5) - T4 - X(I2) = T1 - 30 CONTINUE - IS = 2 * ID - N2 - ID = 4 * ID - IF ( IS .LT. N ) GOTO 36 + DO + DO 30 I = IS, N-1, ID + I1 = I + J + I2 = I1 + N4 + I3 = I2 + N4 + I4 = I3 + N4 + I5 = I + N4 - J + 2 + I6 = I5 + N4 + I7 = I6 + N4 + I8 = I7 + N4 + T1 = X(I3) * CC1 + X(I7) * SS1 + T2 = X(I7) * CC1 - X(I3) * SS1 + T3 = X(I4) * CC3 + X(I8) * SS3 + T4 = X(I8) * CC3 - X(I4) * SS3 + T5 = T1 + T3 + T6 = T2 + T4 + T3 = T1 - T3 + T4 = T2 - T4 + T2 = X(I6) + T6 + X(I3) = T6 - X(I6) + X(I8) = T2 + T2 = X(I2) - T3 + X(I7) = - X(I2) - T3 + X(I4) = T2 + T1 = X(I1) + T5 + X(I6) = X(I1) - T5 + X(I1) = T1 + T1 = X(I5) + T4 + X(I5) = X(I5) - T4 + X(I2) = T1 + 30 CONTINUE + IS = 2 * ID - N2 + ID = 4 * ID + IF ( IS >= N ) EXIT + END DO 32 CONTINUE 10 CONTINUE RETURN @@ -1437,40 +1444,42 @@ SUBROUTINE SFFTCB( X, N, M ) IF ( N .EQ. 1 ) RETURN ! N2 = 2 * N - DO 10, K = 1, M-1 + DO 10 K = 1, M-1 IS = 0 ID = N2 N2 = N2 / 2 N4 = N2 / 4 N8 = N4 / 2 E = TWOPI / N2 - 17 DO 15, I = IS, N-1, ID - I1 = I + 1 - I2 = I1 + N4 - I3 = I2 + N4 - I4 = I3 + N4 - T1 = X(I1) - X(I3) - X(I1) = X(I1) + X(I3) - X(I2) = 2 * X(I2) - X(I3) = T1 - 2 * X(I4) - X(I4) = T1 + 2 * X(I4) - IF ( N4 .EQ. 1 ) GOTO 15 - I1 = I1 + N8 - I2 = I2 + N8 - I3 = I3 + N8 - I4 = I4 + N8 - T1 = ( X(I2) - X(I1) ) / SQRT2 - T2 = ( X(I4) + X(I3) ) / SQRT2 - X(I1) = X(I1) + X(I2) - X(I2) = X(I4) - X(I3) - X(I3) = 2 * ( - T2 - T1 ) - X(I4) = 2 * ( -T2 + T1 ) - 15 CONTINUE - IS = 2 * ID - N2 - ID = 4 * ID - IF ( IS .LT. N-1 ) GOTO 17 + DO + 17 DO 15 I = IS, N-1, ID + I1 = I + 1 + I2 = I1 + N4 + I3 = I2 + N4 + I4 = I3 + N4 + T1 = X(I1) - X(I3) + X(I1) = X(I1) + X(I3) + X(I2) = 2 * X(I2) + X(I3) = T1 - 2 * X(I4) + X(I4) = T1 + 2 * X(I4) + IF ( N4 .EQ. 1 ) CYCLE + I1 = I1 + N8 + I2 = I2 + N8 + I3 = I3 + N8 + I4 = I4 + N8 + T1 = ( X(I2) - X(I1) ) / SQRT2 + T2 = ( X(I4) + X(I3) ) / SQRT2 + X(I1) = X(I1) + X(I2) + X(I2) = X(I4) - X(I3) + X(I3) = 2 * ( - T2 - T1 ) + X(I4) = 2 * ( -T2 + T1 ) + 15 CONTINUE + IS = 2 * ID - N2 + ID = 4 * ID + IF ( IS >= N-1 ) EXIT + END DO A = E - DO 20, J = 2, N8 + DO 20 J = 2, N8 A3 = 3 * A CC1 = COS(A) SS1 = SIN(A) @@ -1479,66 +1488,71 @@ SUBROUTINE SFFTCB( X, N, M ) A = J * E IS = 0 ID = 2 * N2 - 40 DO 30, I = IS, N-1, ID - I1 = I + J - I2 = I1 + N4 - I3 = I2 + N4 - I4 = I3 + N4 - I5 = I + N4 - J + 2 - I6 = I5 + N4 - I7 = I6 + N4 - I8 = I7 + N4 - T1 = X(I1) - X(I6) - X(I1) = X(I1) + X(I6) - T2 = X(I5) - X(I2) - X(I5) = X(I2) + X(I5) - T3 = X(I8) + X(I3) - X(I6) = X(I8) - X(I3) - T4 = X(I4) + X(I7) - X(I2) = X(I4) - X(I7) - T5 = T1 - T4 - T1 = T1 + T4 - T4 = T2 - T3 - T2 = T2 + T3 - X(I3) = T5 * CC1 + T4 * SS1 - X(I7) = - T4 * CC1 + T5 * SS1 - X(I4) = T1 * CC3 - T2 * SS3 - X(I8) = T2 * CC3 + T1 * SS3 - 30 CONTINUE - IS = 2 * ID - N2 - ID = 4 * ID - IF ( IS .LT. N-1 ) GOTO 40 + DO + DO 30 I = IS, N-1, ID + I1 = I + J + I2 = I1 + N4 + I3 = I2 + N4 + I4 = I3 + N4 + I5 = I + N4 - J + 2 + I6 = I5 + N4 + I7 = I6 + N4 + I8 = I7 + N4 + T1 = X(I1) - X(I6) + X(I1) = X(I1) + X(I6) + T2 = X(I5) - X(I2) + X(I5) = X(I2) + X(I5) + T3 = X(I8) + X(I3) + X(I6) = X(I8) - X(I3) + T4 = X(I4) + X(I7) + X(I2) = X(I4) - X(I7) + T5 = T1 - T4 + T1 = T1 + T4 + T4 = T2 - T3 + T2 = T2 + T3 + X(I3) = T5 * CC1 + T4 * SS1 + X(I7) = - T4 * CC1 + T5 * SS1 + X(I4) = T1 * CC3 - T2 * SS3 + X(I8) = T2 * CC3 + T1 * SS3 + 30 CONTINUE + IS = 2 * ID - N2 + ID = 4 * ID + IF ( IS >= N-1 ) EXIT + END DO 20 CONTINUE 10 CONTINUE ! IS = 1 ID = 4 - 70 DO 60, I0 = IS, N, ID - I1 = I0 + 1 - R1 = X(I0) - X(I0) = R1 + X(I1) - X(I1) = R1 - X(I1) - 60 CONTINUE - IS = 2 * ID - 1 - ID = 4 * ID - IF ( IS .LT. N ) GOTO 70 + DO + DO 60 I0 = IS, N, ID + I1 = I0 + 1 + R1 = X(I0) + X(I0) = R1 + X(I1) + X(I1) = R1 - X(I1) + 60 CONTINUE + IS = 2 * ID - 1 + ID = 4 * ID + IF ( IS >= N ) EXIT + END DO ! - 100 J = 1 + J = 1 N1 = N - 1 - DO 104, I = 1, N1 - IF ( I .GE. J ) GOTO 101 - XT = X(J) - X(J) = X(I) - X(I) = XT - 101 K = N / 2 - 102 IF ( K .GE. J ) GOTO 103 + DO 104 I = 1, N1 + IF ( I < J ) THEN + XT = X(J) + X(J) = X(I) + X(I) = XT + END IF + K = N / 2 + DO WHILE ( K < J ) J = J - K K = K / 2 - GOTO 102 - 103 J = J + K + END DO + J = J + K 104 CONTINUE XT = 1.0 / FLOAT( N ) - DO 99, I = 1, N + DO 99 I = 1, N X(I) = XT * X(I) 99 CONTINUE RETURN diff --git a/src/sst_retrieval.f90 b/src/gsi/sst_retrieval.f90 similarity index 100% rename from src/sst_retrieval.f90 rename to src/gsi/sst_retrieval.f90 diff --git a/src/state_vectors.f90 b/src/gsi/state_vectors.f90 similarity index 99% rename from src/state_vectors.f90 rename to src/gsi/state_vectors.f90 index 9a86402d1..711043fa5 100644 --- a/src/state_vectors.f90 +++ b/src/gsi/state_vectors.f90 @@ -82,7 +82,7 @@ module state_vectors public svars3d public svars public levels - public ns2d,ns3d + public ns2d,ns3d,nsdim ! State vector definition ! Could contain model state fields plus other fields required @@ -95,7 +95,7 @@ module state_vectors logical :: llinit = .false. integer(i_kind) :: m_st_alloc, max_st_alloc, m_allocs, m_deallocs -integer(i_kind) :: nvars,ns2d,ns3d +integer(i_kind) :: nvars,ns2d,ns3d,nsdim character(len=max_varname_length),allocatable,dimension(:) :: svars character(len=max_varname_length),allocatable,dimension(:) :: svars3d character(len=max_varname_length),allocatable,dimension(:) :: svars2d @@ -197,13 +197,15 @@ subroutine init_anasv ! variables participating in state vector ! Count variables first -ns3d=0; ns2d=0 +ns3d=0; ns2d=0; nsdim=0; do ii=1,nvars read(utable(ii),*) var, ilev, itracer, source, funcof if(ilev==1) then ns2d=ns2d+1 + nsdim=nsdim+1 else ns3d=ns3d+1 + nsdim=nsdim+ilev endif enddo diff --git a/src/statsco.f90 b/src/gsi/statsco.f90 similarity index 100% rename from src/statsco.f90 rename to src/gsi/statsco.f90 diff --git a/src/statsconv.f90 b/src/gsi/statsconv.f90 similarity index 89% rename from src/statsconv.f90 rename to src/gsi/statsconv.f90 index e8de00ea5..cd11ad4d5 100644 --- a/src/statsconv.f90 +++ b/src/gsi/statsconv.f90 @@ -1,7 +1,8 @@ subroutine statsconv(mype,& i_ps,i_uv,i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag, & i_gust,i_vis,i_pblh,i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv, & - i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,i_ref,bwork,awork,ndata) + i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,& + i_swcp,i_lwcp,i_dbz,i_ref,bwork,awork,ndata) !$$$ subprogram documentation block ! . . . . ! subprogram: statconv prints statistics for conventional data @@ -42,6 +43,7 @@ subroutine statsconv(mype,& ! 2014-06-06 carley/zhu - add tcamt and lcbas ! 2015-07-10 pondeca - add cldch ! 2016-05-05 pondeca - add uwnd10m, vwnd10m +! 2017-05-12 Y. Wang and X. Wang - add dbz, POC: xuguang.wang@ou.edu ! ! input argument list: ! mype - mpi task number @@ -70,6 +72,8 @@ subroutine statsconv(mype,& ! i_cldch - index in awork array holding cldch info ! i_uwnd10m- index in awork array holding uwnd10m info ! i_vwnd10m- index in awork array holding vwnd10m info +! i_swcp - index in awork array holding swcp info +! i_lwcp - index in awork array holding lwcp info ! i_ref - size of second dimension of awork array ! bwork - array containing information for statistics ! awork - array containing information for data counts and gross checks @@ -91,10 +95,12 @@ subroutine statsconv(mype,& iout_gust,iout_vis,iout_pblh,iout_wspd10m,iout_td2m,& iout_mxtm,iout_mitm,iout_pmsl,iout_howv,iout_tcamt,iout_lcbas,iout_cldch,& iout_uwnd10m,iout_vwnd10m,& + iout_dbz,iout_swcp,iout_lwcp,& mype_dw,mype_rw,mype_sst,mype_gps,mype_uv,mype_ps,& mype_t,mype_pw,mype_q,mype_tcp,ndat,dtype,mype_lag,mype_gust,& mype_vis,mype_pblh,mype_wspd10m,mype_td2m,mype_mxtm,mype_mitm,& - mype_pmsl,mype_howv,mype_tcamt,mype_lcbas,mype_cldch,mype_uwnd10m,mype_vwnd10m + mype_pmsl,mype_howv,mype_tcamt,mype_lcbas,mype_cldch,mype_uwnd10m,mype_vwnd10m,& + mype_dbz,mype_swcp,mype_lwcp use qcmod, only: npres_print,ptop,pbot,ptopq,pbotq use jfunc, only: first,jiter use gridmod, only: nsig @@ -105,7 +111,7 @@ subroutine statsconv(mype,& integer(i_kind) ,intent(in ) :: mype,i_ps,i_uv,& i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag,i_gust,i_vis,i_pblh,& i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv,i_tcamt,i_lcbas,& - i_cldch,i_uwnd10m,i_vwnd10m,i_ref + i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp,i_dbz,i_ref real(r_kind),dimension(7*nsig+100,i_ref) ,intent(in ) :: awork real(r_kind),dimension(npres_print,nconvtype,5,3),intent(in ) :: bwork integer(i_kind),dimension(ndat,3) ,intent(in ) :: ndata @@ -116,16 +122,19 @@ subroutine statsconv(mype,& integer(i_kind) numgrspw,numsst,nsuperp,nump,nhitopo,ntoodif integer(i_kind) numgrsq,numhgh,numgust,numvis,numpblh,numwspd10m,numuwnd10m,numvwnd10m integer(i_kind) numtd2m,nummxtm,nummitm,numpmsl,numhowv,numtcamt,numlcbas,numcldch + integer(i_kind) numgrsswcp,numgrslwcp integer(i_kind) ntot,numlow,k,numssm,i,j integer(i_kind) numgross,numfailqc,numfailqc_ssmi,nread,nkeep integer(i_kind) numfail1_gps,numfail2_gps,numfail3_gps,nreadspd,nkeepspd integer(i_kind),dimension(nsig)::num - real(r_kind) grsmlt,tq,pw,rat,tgps,qmplty,tpw,tdw,rwmplty,trw + real(r_kind) grsmlt,tq,pw,rat,tgps,qmplty,tpw,tdw,rwmplty,trw,dbzmplty,tdbz real(r_kind) tmplty,tt,dwmplty,gpsmplty,umplty,tssm,qctssm,tu,tv,tuv + real(r_kind) tswcp,tlwcp real(r_kind) vmplty,uvqcplty,rat1,rat2,rat3 real(r_kind) dwqcplty,tqcplty,qctt,qctrw,rwqcplty,qctdw,qqcplty,qctgps real(r_kind) gpsqcplty,tpw3,pw3,qctq + real(r_kind) tswcp3,tlwcp3,qctdbz,dbzqcplty real(r_kind),dimension(1):: pbotall,ptopall logical,dimension(nconvtype):: pflag @@ -1209,6 +1218,65 @@ subroutine statsconv(mype,& close(iout_rw) end if +! Summary report for radar reflectivity + if(mype==mype_dbz) then + if(first)then + open(iout_dbz) + else + open(iout_dbz,position='append') + end if + + dbzmplty=zero; dbzqcplty=zero ; ntot=0 + tdbz=zero ; qctdbz=zero + nread=0 + nkeep=0 + do i=1,ndat + if(dtype(i)== 'dbz')then + nread=nread+ndata(i,2) + nkeep=nkeep+ndata(i,3) + end if + end do + if(nkeep > 0)then + mesage='current vfit of radar reflectivity data, ranges in dBZ$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'dbz' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dbz,pflag) + + numgross=nint(awork(4,i_dbz)) + numfailqc=nint(awork(21,i_dbz)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_dbz)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_dbz)/float(num(k)) + rat3=awork(3*nsig+k+100,i_dbz)/float(num(k)) + end if + ntot=ntot+num(k) + dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz) + dbzqcplty=dbzqcplty+awork(3*nsig+k+100,i_dbz) + write(iout_dbz,240) 'r',num(k),k,awork(6*nsig+k+100,i_dbz), & + awork(3*nsig+k+100,i_dbz),rat,rat3 + end do + if(ntot > 0) then + tdbz=dbzmplty/float(ntot) + qctdbz=dbzqcplty/float(ntot) + end if + write(iout_dbz,925) 'dbz',numgross,numfailqc + numlow = nint(awork(2,i_dbz)) + numhgh = nint(awork(3,i_dbz)) + nhitopo = nint(awork(5,i_dbz)) + ntoodif = nint(awork(6,i_dbz)) + write(iout_dbz,900) 'dbz',numhgh,numlow + write(iout_dbz,905) 'dbz',nhitopo,ntoodif + end if + write(iout_dbz,950) 'dbz',jiter,nread,nkeep,ntot + write(iout_dbz,951) 'dbz',dbzmplty,dbzqcplty,tdbz,qctdbz + + close(iout_dbz) + end if + if(mype==mype_tcp) then if(first)then open(iout_tcp) @@ -1303,7 +1371,93 @@ subroutine statsconv(mype,& close(iout_lag) endif - +! Summary report for solid-water content path + if(mype==mype_swcp) then + if(first)then + open(iout_swcp) + else + open(iout_swcp,position='append') + end if + + nsuperp=nint(awork(4,i_swcp)) + + tswcp=zero ; tswcp3=zero + nread=0 + nkeep=0 + do i=1,ndat + if(dtype(i)== 'swcp')then + nread=nread+ndata(i,2) + nkeep=nkeep+ndata(i,3) + end if + end do + if(nkeep > 0)then + mesage='current fit of solid-water content path, ranges in kg/m^2$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'swcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_swcp,pflag) + + numgrsswcp=nint(awork(6,i_swcp)) + numfailqc=nint(awork(21,i_swcp)) + grsmlt=three + tswcp=zero + tswcp3=zero + if(nsuperp > 0)then + tswcp=awork(5,i_swcp)/nsuperp + tswcp3=awork(22,i_swcp)/nsuperp + end if + write(iout_swcp,925) 'swcp',numgrsswcp,numfailqc + write(iout_swcp,975) grsmlt,'swcp',awork(7,i_swcp) + end if + write(iout_swcp,950) 'swcp',jiter,nread,nkeep,nsuperp + write(iout_swcp,951) 'swcp',awork(5,i_swcp),awork(22,i_swcp),tswcp,tswcp3 + + close(iout_swcp) + end if + +! Summary report for liquid-water content path + if(mype==mype_lwcp) then + if(first)then + open(iout_lwcp) + else + open(iout_lwcp,position='append') + end if + + nsuperp=nint(awork(4,i_lwcp)) + + tlwcp=zero ; tlwcp3=zero + nread=0 + nkeep=0 + do i=1,ndat + if(dtype(i)== 'lwcp')then + nread=nread+ndata(i,2) + nkeep=nkeep+ndata(i,3) + end if + end do + if(nkeep > 0)then + mesage='current fit of liquid-water content path, ranges in kg/m^2$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lwcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lwcp,pflag) + + numgrslwcp=nint(awork(6,i_lwcp)) + numfailqc=nint(awork(21,i_lwcp)) + grsmlt=three + tlwcp=zero + tlwcp3=zero + if(nsuperp > 0)then + tlwcp=awork(5,i_lwcp)/nsuperp + tlwcp3=awork(22,i_lwcp)/nsuperp + end if + write(iout_lwcp,925) 'lwcp',numgrslwcp,numfailqc + write(iout_lwcp,975) grsmlt,'lwcp',awork(7,i_lwcp) + end if + write(iout_lwcp,950) 'lwcp',jiter,nread,nkeep,nsuperp + write(iout_lwcp,951) 'lwcp',awork(5,i_lwcp),awork(22,i_lwcp),tlwcp,tlwcp3 + + close(iout_lwcp) + end if ! Format statements used above diff --git a/src/gsi/statslight.f90 b/src/gsi/statslight.f90 new file mode 100644 index 000000000..ef0e633f9 --- /dev/null +++ b/src/gsi/statslight.f90 @@ -0,0 +1,139 @@ +subroutine statslight(mype,i_light,bwork,awork,i_ref,ndata) +!$$$ subprogram documentation block +! . . . . +! subprogram: statslight prints statistics for lightning data +! prgmmr: k apodaca +! org: CSU/CIRA, Data Assimilation Group +! date: 2016-04-06 +! +! abstract: The routine computes and prints statistics regarding the +! use of lightning observations. Printed information +! includes that about data counts, quality control decisions, +! statistics based on the innovations, and penalties. +! +! program history log: +! 2016-04-05 apodaca - +! +! input argument list: +! mype - mpi task number +! i_light - index in awork array holding lightning info +! bwork - array containing information for statistics +! awork - array containing information for data counts and gross checks +! ndata(*,1) - number of profiles retained for further processing +! ndata(*,2) - number of observations read +! ndata(*,3) - number of observations keep after read +! +! output argument list: +! +! attributes: +! language: Fortran 90 and/or higher +! machine: +! +!$$$ + use kinds, only: r_kind,i_kind + use constants, only: zero,three,five + use obsmod, only: iout_light,& + mype_light,& + ndat,dtype + use qcmod, only: npres_print,ptop,pbot + use jfunc, only: first,jiter + use gridmod, only: nsig + use lightinfo, only: nulight,nlighttype + implicit none + +! Declare passed variables + integer(i_kind) i_ref,numgrslight,nsuperl + integer(i_kind) ,intent(in ) :: mype,i_light + real(r_kind),dimension(7*nsig+100,i_ref) ,intent(in ) :: awork + real(r_kind),dimension(npres_print,nlighttype,5,3),intent(in ) :: bwork + integer(i_kind),dimension(ndat,3) ,intent(in ) :: ndata + +! Declare local variables + character(100) mesage + + integer(i_kind) i,j + integer(i_kind) numfailqc,nread,nkeep + + real(r_kind) grsmlt,tlight + real(r_kind) tlight3 + real(r_kind),dimension(1):: pbotall,ptopall + + logical,dimension(nlighttype):: pflag + +!********************************************************************************* +! Initialize constants and variables. + + ptopall(1)=zero; pbotall(1)=2000.0_r_kind + + +! Generate summary statistics + + pflag=.FALSE. + +! Summary report for lightning flash rate + + if(mype==mype_light) then + if(first)then + open(iout_light) + else + open(iout_light,position='append') + end if + + nsuperl=nint(awork(4,i_light)) + tlight=zero ; tlight3=zero + nread=0 + nkeep=0 + do i=1,ndat + if(dtype(i)== 'light')then + nread=nread+ndata(i,2) + nkeep=nkeep+ndata(i,3) + end if + end do + if(nkeep > 0)then + mesage='current fit of lightning data, range in #hits km-2 hr-1$' + do j=1,nlighttype + pflag(j)=trim(nulight(j)) == 'light' + enddo + + call dtast(bwork,1,pbot,ptop,mesage,jiter,iout_light,pflag) + + numgrslight=nint(awork(6,i_light)) + numfailqc=nint(awork(21,i_light)) + grsmlt=three + tlight=zero + if(nsuperl > 0)then + tlight=awork(5,i_light)/nsuperl + tlight3=awork(22,i_light)/nsuperl + end if + write(iout_light,925) 'light',numgrslight,numfailqc + write(iout_light,975) grsmlt,'light',awork(7,i_light) + end if + write(iout_light,950) 'light',jiter,nread,nkeep,nsuperl + write(iout_light,951) 'light',awork(5,i_light),awork(22,i_light),tlight,tlight3 + + close(iout_light) + end if + + + +! Format statements used above +111 format('obs lev num rms bias sumges sumobs cpen') +240 format(' num(',A1,') = ',i6,' at lev ',i4,' pen,qcpen,cpen,cqcpen = ',6(g12.5,1x)) +241 format(' num(',A1,') = ',i6,' at lev ',i4,' upen,vpen,cupen,cvpen = ',6(g12.5,1x)) +900 format(' number of ',a5,' obs extrapolated above',& + ' top sigma layer=',i8,/,10x,' number extrapolated below',& + ' bottom sigma layer=',i8) +920 format(a44,i7) +924 format(a50) +925 format(' number of ',a5,' obs that failed gross test = ',I5,' nonlin qc test = ',I5) +949 format(' number of ',a5,' obs = ',i6,' pen= ',e25.18,' cpen= ',g13.6) +950 format(' type ',a7,' jiter ',i3,' nread ',i7,' nkeep ',i7,' num ',i7) +951 format(' type ',a7,' pen= ',e25.18,' qcpen= ',e25.18,' r= ',g13.6,' qcr= ',g13.6) +952 format(t5,'it',t13,'sat',t21,'# read',t32,'# keep',t42,'# assim',& + t52,'penalty',t67,'cpen') +975 format(' grsmlt=',f7.1,' number of bad ',a5,' obs=',f8.0) + + return + + +end subroutine statslight diff --git a/src/statsoz.f90 b/src/gsi/statsoz.f90 similarity index 100% rename from src/statsoz.f90 rename to src/gsi/statsoz.f90 diff --git a/src/statspcp.f90 b/src/gsi/statspcp.f90 similarity index 100% rename from src/statspcp.f90 rename to src/gsi/statspcp.f90 diff --git a/src/statsrad.f90 b/src/gsi/statsrad.f90 similarity index 100% rename from src/statsrad.f90 rename to src/gsi/statsrad.f90 diff --git a/src/stop1.f90 b/src/gsi/stop1.f90 similarity index 100% rename from src/stop1.f90 rename to src/gsi/stop1.f90 diff --git a/src/stpaod.f90 b/src/gsi/stpaod.f90 similarity index 88% rename from src/stpaod.f90 rename to src/gsi/stpaod.f90 index f74b9f78d..3afd8b544 100644 --- a/src/stpaod.f90 +++ b/src/gsi/stpaod.f90 @@ -10,6 +10,8 @@ module stpaodmod ! program history log: ! 2016-02-20 pagowski - a module for aod ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting +! 2019-03-21 martin - changed if in stpaod from wrf_mass_regional to +! laeroana_gocart; modified code from S-W Wei (UAlbany) ! ! subroutines included: ! sub stpaod @@ -42,6 +44,8 @@ subroutine stpaod(aerohead,rval,sval,out,sges,nstep) ! ! program history log: ! 2016-01-15 pagowski - original routine +! 2019-03-21 martin - changed if in stpaod from wrf_mass_regional to +! laeroana_gocart; modified code from S-W Wei (UAlbany) ! ! input argument list: ! aerohead @@ -65,7 +69,8 @@ subroutine stpaod(aerohead,rval,sval,out,sges,nstep) use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,zero use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer - use gridmod, only: cmaq_regional,wrf_mass_regional,latlon11,nsig + use gridmod, only: cmaq_regional,latlon11,nsig + use chemmod, only: laeroana_gocart implicit none ! declare passed variables @@ -78,7 +83,7 @@ subroutine stpaod(aerohead,rval,sval,out,sges,nstep) ! declare local variables integer(i_kind) istatus,naero integer(i_kind) j1,j2,j3,j4,kk,k,ic,nn - real(r_kind) cg_aero,val,val2,wgross,wnotgross + real(r_kind) val,val2 integer(i_kind),dimension(nsig) :: j1n,j2n,j3n,j4n real(r_kind),dimension(max(1,nstep)):: term,rad real(r_kind) w1,w2,w3,w4 @@ -102,12 +107,11 @@ subroutine stpaod(aerohead,rval,sval,out,sges,nstep) endif - if (wrf_mass_regional) then + if (laeroana_gocart) then tdir=zero rdir=zero - !aeroptr => aerohead aeroptr => aeroNode_typecast(aerohead) do while (associated(aeroptr)) @@ -177,7 +181,7 @@ subroutine stpaod(aerohead,rval,sval,out,sges,nstep) end do else - rad(kk)= val2 + rad(1) = aeroptr%res(nn) end if ! calculate contribution to j @@ -188,17 +192,6 @@ subroutine stpaod(aerohead,rval,sval,out,sges,nstep) ! modify penalty term if nonlinear qc - if(nlnqc_iter .and. pg_aero(ic) > tiny_r_kind .and. & - b_aero(ic) > tiny_r_kind)then - cg_aero=cg_term/b_aero(ic) - wnotgross= one-pg_aero(ic)*varqc_iter - wgross = varqc_iter*pg_aero(ic)*cg_aero/wnotgross - do kk=1,max(1,nstep) - term(kk) = -two*log((exp(-half*term(kk) ) + wgross)/& - (one+wgross)) - end do - endif - out(1) = out(1) + term(1)*aeroptr%raterr2(nn) do kk=2,nstep @@ -209,7 +202,6 @@ subroutine stpaod(aerohead,rval,sval,out,sges,nstep) endif - !aeroptr => aeroptr%llpoint aeroptr => aeroNode_nextcast(aeroptr) end do diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 new file mode 100644 index 000000000..a3ea5e67b --- /dev/null +++ b/src/gsi/stpcalc.f90 @@ -0,0 +1,1040 @@ +module stpcalcmod + +!$$$ module documentation block +! . . . . +! module: stpcalcmod module for stpcalc +! prgmmr: +! +! abstract: module for stpcalc +! +! program history log: +! 2005-05-21 Yanqiu zhu - wrap stpcalc and its tangent linear stpcalc_tl into one module +! 2005-11-21 Derber - remove interfaces and clean up code +! 2008-12-02 Todling - remove stpcalc_tl +! 2009-08-12 lueken - updated documentation +! 2012-02-08 kleist - consolidate weak constaints into one module stpjcmod. +! 2015-09-03 guo - obsmod::yobs has been replaced with m_obsHeadBundle, +! where yobs is created and destroyed when and where it +! is needed. +! 2018-05-19 eliu - add precipitation component in moisture constraint +! 2018-08-10 guo - removed obsHeadBundle references. +! - replaced stpjo() with a new polymorphic stpjomod::stpjo(). +! 2019-08-06 guo - corrected ctype contents for new moisture constaints. +! . added n0 to the argument list of prnt_j() to separate +! the observation section from the leading section of +! pj, to help future pj content extension. +! +! subroutines included: +! sub stpcalc +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none + +PRIVATE +PUBLIC stpcalc + +contains + +subroutine stpcalc(stpinout,sval,sbias,xhat,dirx,dval,dbias, & + diry,penalty,penaltynew,pjcost,pjcostnew,end_iter) + +!$$$ subprogram documentation block +! . . . . +! subprogram: stpcalc calculate penalty and stepsize +! prgmmr: derber org: np23 date: 2003-12-18 +! +! abstract: calculate current penalty and estimate stepsize +! (nonlinear qc version) +! +! A description of nonlinear qc follows: +! +! The observation penalty Jo is defined as +! +! Jo = - (sum over obs) 2*log(Po) +! +! where, +! +! Po = Wnotgross*exp(-.5*(Hn(x+xb) - yo)**2 ) + Wgross +! with +! Hn = the forward model (possibly non-linear) normalized by +! observation error +! x = the current estimate of the analysis increment +! xb = the background state +! yo = the observation normalized by observation error +! +! Note: The factor 2 in definition of Jo is present because the +! penalty Jo as used in this code is 2*(usual definition +! of penalty) +! +! Wgross = Pgross*cg +! +! Wnotgross = 1 - Wgross +! +! Pgross = probability of gross error for observation (assumed +! here to have uniform distribution over the possible +! range of values) +! +! cg = sqrt(2*pi)/2b +! +! b = possible range of variable for gross errors, normalized by +! observation error +! +! The values for the above parameters that Bill Collins used in the +! eta 3dvar are: +! +! cg = cg_term/b, where cg_term = sqrt(2*pi)/2 +! +! b = 10. ! range for gross errors, normalized by obs error +! +! pg_q=.002 ! probability of gross error for specific humidity +! pg_pw=.002 ! probability of gross error for precipitable water +! pg_p=.002 ! probability of gross error for pressure +! pg_w=.005 ! probability of gross error for wind +! pg_t=.007 ! probability of gross error for temperature +! pg_rad=.002 ! probability of gross error for radiances +! +! +! Given the above Jo, the gradient of Jo is as follows: +! +! T +! gradx(Jo) = - (sum over observations) 2*H (Hn(x+xb)-yo)*(Po - Wgross)/Po +! +! where, +! +! H = tangent linear model of Hn about x+xb +! +! +! Note that if Pgross = 0.0, then Wnotgross=1.0 and Wgross=0.0. That is, +! the code runs as though nonlinear quality control were not present +! (which is indeed the case since the gross error probability is 0). +! +! As a result the same stp* routines may be used for use with or without +! nonlinear quality control. +! +! Please note, however, that using the nonlinear qc routines makes the +! stp* and int* operators nonlinear. Hence, the need to evaluate the +! step size operators each stepsize estimate for each observation type, +! given the current step size algorithm coded below. +! +! +! program history log: +! 2003-12-18 derber,j. +! 2004-07-23 derber - modify to include conventional sst +! 2004-07-28 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - add nonlinear qc option +! 2004-10-06 kleist - separate control vector for u,v, get search +! direction for u,v from dir for st,vp +! 2004-11-30 treadon - add brightness temperatures to nonlinear +! quality control +! 2005-01-20 okamoto - add u,v to stprad_qc +! 2005-01-26 cucurull- implement local GPS RO linear operator +! 2005-02-10 treadon - add u,v to stprad_qc (okamoto change not present) +! 2005-02-23 wu - add call to normal_rh_to_q to convert normalized +! RH to q +! 2005-04-11 treadon - rename stpcalc_qc as stpcalc +! 2005-05-21 yanqiu zhu - add 'use stp*mod', and modify call interfaces for using these modules +! 2005-05-27 derber - remove linear stepsize estimate +! 2005-06-03 parrish - add horizontal derivatives +! 2005-07-10 kleist - add dynamic constraint term (linear) +! 2005-09-29 kleist - expand Jc term, include time derivatives vector +! 2005-11-21 kleist - separate tendencies from Jc term, add call to calctends tlm +! 2005-12-01 cucurull - add code for GPS local bending angle, add use obsmod for ref_obs +! 2005-12-20 parrish - add arguments to call to stpt to enable boundary layer forward +! model option. +! 2006-04-18 derber - add explicit iteration over stepsize (rather than +! repeated calls) - clean up and simplify +! 2006-04-24 kleist - include both Jc formulations +! 2006-05-26 derber - modify to improve convergence checking +! 2007-03-19 tremolet - binning of observations +! 2007-04-13 tremolet - split Jo and 3dvar components into stpjo and stp3dvar +! 2006-07-26 parrish - correct inconsistency in computation of space and time derivatives of q +! currently, if derivatives computed, for q it is normalized q, but +! should be mixing ratio. +! 2006-08-04 parrish - add strong constraint initialization option +! 2006-09-18 derber - modify output from nonlinear operators to make same as linear operators +! 2006-09-20 derber - add sensible temperatures for conventional obs. +! 2006-10-12 treadon - replace virtual temperature with sensible in stppcp +! 2007-04-16 kleist - modified calls to tendency and constraint routines +! 2007-06-04 derber - use quad precision to get reproduceability over number of processors +! 2007-07-26 cucurull - update gps code to generalized vertical coordinate; +! get current solution for 3d pressure (xhat_3dp); +! move getprs_tl out of calctends_tl; add dirx3dp +! and remove ps in calctends_tl argument list; +! use getprs_tl +! 2007-08-08 derber - optimize, ensure that only necessary time derivatives are calculated +! 2007-10-01 todling - add timers +! 2008-11-28 todling - revisited Tremolet's split in light of changes from May08 version +! 2009-06-02 derber - modify the calculation of the b term for the background to increase accuracy +! 2010-06-01 treadon - accumulate pbcjo over nobs_bins +! 2010-08-19 lueken - add only to module use +! 2010-09-14 derber - clean up quad precision +! 2011-02-25 zhu - add gust,vis,pblh calls +! 2013-03-19 pondeca - add wspd10m call. introduce parameter n0 to make it easier to add +! more weak constraint contributions. update comment block to indicate +! the correct observation type associated with each pbc(*,j) term +! 2014-05-07 pondeca - add howv call +! 2014-06-17 carley/zhu - add tcamt and lcbas +! 2015-07-10 pondeca - add cldch +! 2016-02-03 derber - add code to search through all of the possible stepsizes tried, to find the +! one that minimizes the most and use that one. +! 2016-08-08 j guo - tried to edit some comments for a better description on pbc(*,:) elements +! reflecting jo terms. +! +! input argument list: +! stpinout - guess stepsize +! sval - current solution +! xhat - current solution +! dirx - search direction for x +! diry - search direction for y (B-1 dirx) +! end_iter - end iteration flag +! dval +! sbias,dbias +! +! output argument list: +! xhat +! stpinout - final estimate of stepsize +! penalty - penalty current solution +! penaltynew - estimate of penalty for new solution +! end_iter - end iteration flag false if stepsize successful +! pjcost - 4 major penalty terms current solution +! pjcostnew - 4 major penalty terms estimate new solution +! +! remarks: +! The part of xhat and dirx containing temps and psfc are values before strong initialization, +! xhatt, xhatp and dirxt, dirxp contain temps and psfc after strong initialization. +! If strong initialization is turned off, then xhatt, etc are equal to the corresponding +! fields in xhat, dirx. +! xhatuv, xhat_y, xhat_t and dirxuv, dirx_t are all after +! strong initialization if it is turned on. +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_quad,r_single + use mpimod, only: mype + use constants, only: zero,one_quad,zero_quad + use gsi_4dvar, only: nobs_bins,ltlint,ibin_anl + use jfunc, only: iout_iter,nclen,xhatsave,yhatsave,& + iter + use jcmod, only: ljcpdry,ljc4tlevs,ljcdfi,ljclimqc + use gsi_obOperTypeManager, only: nobs_type => obOper_count + use stpjcmod, only: stplimq,stplimg,stplimv,stplimp,stplimw10m,& + stplimhowv,stplimcldch,stpjcdfi,stpjcpdry,stpliml,stplimqc + use bias_predictors, only: predictors + use control_vectors, only: control_vector,qdot_prod_sub,cvars2d,cvars3d + use state_vectors, only: allocate_state,deallocate_state + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_bundlemod, only: assignment(=) + use guess_grids, only: ntguessig,nfldsig + use mpl_allreducemod, only: mpl_allreduce + use mpeu_util, only: getindex + use timermod, only: timer_ini,timer_fnl + use stpjomod, only: stpjo + use gsi_io, only: verbose + implicit none + +! Declare passed variables + real(r_kind) ,intent(inout) :: stpinout + logical ,intent(inout) :: end_iter + real(r_kind) ,intent( out) :: penalty,penaltynew + real(r_kind) ,intent( out) :: pjcost(4),pjcostnew(4) + + type(control_vector),intent(inout) :: xhat + type(control_vector),intent(in ) :: dirx,diry + type(gsi_bundle) ,intent(in ) :: sval(nobs_bins) + type(gsi_bundle) ,intent(in ) :: dval(nobs_bins) + type(predictors) ,intent(in ) :: sbias,dbias + + +! Declare local parameters + integer(i_kind),parameter:: n0 = 17 + integer(i_kind),parameter:: ipen = n0+nobs_type + integer(i_kind),parameter:: istp_iter = 5 + integer(i_kind),parameter:: ipenlin = 3 + integer(i_kind),parameter:: ioutpen = istp_iter*4 + real(r_quad),parameter:: one_tenth_quad = 0.1_r_quad + +! Declare local variables + integer(i_kind) i,j,mm1,ii,iis,ibin,ipenloc,it + integer(i_kind) istp_use,nstep,nsteptot,kprt + real(r_quad),dimension(4,ipen):: pbc + real(r_quad),dimension(4,nobs_type):: pbcjo + real(r_quad),dimension(4,nobs_type,nobs_bins):: pbcjoi + real(r_quad),dimension(4,nobs_bins):: pbcqmin,pbcqmax + real(r_quad),dimension(4,nobs_bins):: pbcql,pbcqi,pbcqr,pbcqs,pbcqg + real(r_quad),dimension(ipen):: pen_est + real(r_quad),dimension(3,ipenlin):: pstart + real(r_quad) bx,cx,ccoef,bcoef,dels,sges1,sgesj + real(r_quad),dimension(0:istp_iter):: stp + real(r_kind),dimension(istp_iter):: stprat + real(r_quad),dimension(ipen):: bsum,csum,bsum_save,csum_save,pen_save + real(r_quad),dimension(ipen,nobs_bins):: pj + real(r_kind) delpen + real(r_kind) outpensave + real(r_kind),dimension(4)::sges + real(r_kind),dimension(ioutpen):: outpen,outstp + logical :: cxterm,change_dels,ifound + logical :: print_verbose + + +!************************************************************************************ +! Initialize timer + call timer_ini('stpcalc') + +! Initialize variable + print_verbose=.false. + if(verbose)print_verbose=.true. + cxterm=.false. + mm1=mype+1 + stp(0)=stpinout + outpen = zero + nsteptot=0 + istp_use=0 + pj=zero_quad + +! Begin calculating contributions to penalty and stepsize for various terms +! +! stepsize = sum(b)/sum(c) +! +! Differences used for 2-4 to reduce round-off error +! +! pbc(1,*) - stepsize sges(1) penalty +! pbc(2,*) - stepsize sges(2) penalty - sges(1) penalty +! pbc(3,*) - stepsize sges(3) penalty - sges(1) penalty +! pbc(4,*) - stepsize sges(4) penalty - sges(1) penalty +! +! linear terms -> pbc(*,1:ipenlin=3) +! pbc(*,1) contribution from background, sat rad bias, and precip bias +! pbc(*,2) placeholder for future linear linear term +! pbc(*,3) contribution from dry pressure constraint term (Jc) +! +! nonlinear terms -> pbc(*,4:n0) +! pbc(*,4) contribution from negative moisture constraint term (Jl/Jq) +! pbc(*,5) contribution from excess moisture term (Jl/Jq) +! pbc(*,6) contribution from negative gust constraint term (Jo) +! pbc(*,7) contribution from negative vis constraint term (Jo) +! pbc(*,8) contribution from negative pblh constraint term (Jo) +! pbc(*,9) contribution from negative wspd10m constraint term (Jo) +! pbc(*,10) contribution from negative howv constraint term (Jo) +! pbc(*,11) contribution from negative lcbas constraint term (Jo) +! pbc(*,12) contribution from negative cldch constraint term (Jo) +! pbc(*,13) contribution from negative ql constraint term (Jl/Jg) +! pbc(*,14) contribution from negative qi constraint term (Jl/Jg) +! pbc(*,15) contribution from negative qr constraint term (Jl/Jg) +! pbc(*,16) contribution from negative qs constraint term (Jl/Jg) +! pbc(*,17) contribution from negative qg constraint term (Jl/Jg) +! +! Under polymorphism the following is the contents of pbs: +! linear terms => pbcjo(*,n0+1:n0+nobs_type), +! pbc (*,n0+j) := pbcjo(*,j); for j=1,nobs_type +! where, +! pbcjo(*, j) := sum( pbcjoi(*,j,1:nobs_bins) ) +! +! The original (wired) implementation of obs-types has +! the extra contents of pbc defined as: +! +! pbc(*,18) contribution from ps observation term (Jo) +! pbc(*,19) contribution from t observation term (Jo) +! pbc(*,20) contribution from w observation term (Jo) +! pbc(*,21) contribution from q observation term (Jo) +! pbc(*,22) contribution from spd observation term (Jo) +! pbc(*,23) contribution from rw observation term (Jo) +! pbc(*,24) contribution from dw observation term (Jo) +! pbc(*,25) contribution from sst observation term (Jo) +! pbc(*,26) contribution from pw observation term (Jo) +! pbc(*,27) contribution from pcp observation term (Jo) +! pbc(*,28) contribution from oz observation term (Jo) +! pbc(*,29) contribution from o3l observation term (Jo)(not used) +! pbc(*,30) contribution from gps bending angle observation term (Jo) +! pbc(*,31) contribution from gps refractivity observation term (Jo) +! pbc(*,32) contribution from rad observation term (Jo) +! pbc(*,33) contribution from tcp observation term (Jo) +! pbc(*,34) contribution from lag observation term (Jo) +! pbc(*,35) contribution from colvk observation term (Jo) +! pbc(*,36) contribution from aero observation term (Jo) +! pbc(*,37) contribution from aerol observation term (Jo) +! pbc(*,38) contribution from pm2_5 observation term (Jo) +! pbc(*,39) contribution from gust observation term (Jo) +! pbc(*,40) contribution from vis observation term (Jo) +! pbc(*,41) contribution from pblh observation term (Jo) +! pbc(*,42) contribution from wspd10m observation term (Jo) +! pbc(*,43) contribution from td2m observation term (Jo) +! pbc(*,44) contribution from mxtm observation term (Jo) +! pbc(*,45) contribution from mitm observation term (Jo) +! pbc(*,46) contribution from pmsl observation term (Jo) +! pbc(*,47) contribution from howv observation term (Jo) +! pbc(*,48) contribution from tcamt observation term (Jo) +! pbc(*,49) contribution from lcbas observation term (Jo) +! pbc(*,50) contribution from pm10 observation term (Jo) +! pbc(*,51) contribution from cldch observation term (Jo) +! pbc(*,52) contribution from uwnd10m observation term (Jo) +! pbc(*,53) contribution from vwnd10m observation term (Jo) +! +! Users should be awared that under polymorphism, obOper types are defined on +! the fly. Such that the second index of pbc(*,:) listed above for n0:1 and +! above, is no longer reflecting their actual location in arrays, e.g. pbc, +! pj, etc.. The actual indices for all obOper types are defined as +! enumerators in module gsi_obOperTypeManager, for any given build. These +! indices are referenceable as public iobOper_xxx integer parameters from +! there, if one has to know or to reference them explicitly. + + pstart=zero_quad + pbc=zero_quad + + +! penalty, b and c for background terms + + pstart(1,1) = qdot_prod_sub(xhatsave,yhatsave) + pj(1,1)=pstart(1,1) + +! two terms in next line should be the same, but roundoff makes average more accurate. + + pstart(2,1) =-0.5_r_quad*(qdot_prod_sub(dirx,yhatsave)+qdot_prod_sub(diry,xhatsave)) + + pstart(3,1) = qdot_prod_sub(dirx,diry) + + +! Contraints and 3dvar terms + +! Penalty, b, c for JcDFI + + if (ljcdfi .and. nobs_bins>1) then + call stpjcdfi(dval,sval,pstart(1,2),pstart(2,2),pstart(3,2)) + pj(2,1)=pstart(1,2) + end if + +! Penalty, b, c for dry pressure + if(ljcpdry)then + if (.not.ljc4tlevs) then + call stpjcpdry(dval(ibin_anl),sval(ibin_anl),pstart(1,3),pstart(2,3),pstart(3,3),1) + else + call stpjcpdry(dval,sval,pstart(1,3),pstart(2,3),pstart(3,3),nobs_bins) + end if + pj(3,1)=pstart(1,3) + end if + +! iterate over number of stepsize iterations (istp_iter - currently set to a maximum of 5) + dels = one_tenth_quad + stepsize: do ii=1,istp_iter + + iis=ii +! Delta stepsize + change_dels=.true. + + sges(1)= stp(ii-1) + sges(2)=(one_quad-dels)*stp(ii-1) + sges(3)=(one_quad+dels)*stp(ii-1) + + + if(ii == 1)then +! First stepsize iteration include current J calculation in position ipenloc + nstep=4 + sges(4)=zero + ipenloc=4 + else +! Later stepsize iteration include only stepsize and stepsize +/- dels + nstep=3 + end if + +! Calculate penalty values for linear terms + + do i=1,ipenlin + sges1=real(sges(1),r_quad) + pbc(1,i)=pstart(1,i)-(2.0_r_quad*pstart(2,i)-pstart(3,i)*sges1)*sges1 + do j=2,nstep + sgesj=real(sges(j),r_quad) + pbc(j,i)=(-2.0_r_quad*pstart(2,i)+pstart(3,i)*(sgesj+sges1))*(sgesj-sges1) + end do + end do + +! Do nonlinear terms + +! penalties for moisture constraint + if(.not. ltlint)then + if (ljclimqc) then + if (getindex(cvars3d,'ql')>0) then + if(.not.ljc4tlevs) then + call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,13),nstep,ntguessig,'ql') + if(ii == 1) pj(13,1)=pbc(1,13)+pbc(ipenloc,13) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcql(1,ibin),nstep,it,'ql') + end do + pbc(:,13)=zero_quad + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,13) = pbc(j,13)+pbcql(j,ibin) + end do + end do + if(ii == 1)then + do ibin=1,nobs_bins + pj(13,ibin)=pj(13,ibin)+pbcql(1,ibin)+pbcql(ipenloc,ibin) + end do + end if + end if + end if + if (getindex(cvars3d,'qi')>0) then + if(.not.ljc4tlevs) then + call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,14),nstep,ntguessig,'qi') + if(ii == 1) pj(14,1)=pbc(1,14)+pbc(ipenloc,14) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcqi(1,ibin),nstep,it,'qi') + end do + pbc(:,14)=zero_quad + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,14) = pbc(j,14)+pbcqi(j,ibin) + end do + end do + if(ii == 1)then + do ibin=1,nobs_bins + pj(14,ibin)=pj(14,ibin)+pbcqi(1,ibin)+pbcqi(ipenloc,ibin) + end do + end if + end if + end if + if (getindex(cvars3d,'qr')>0) then + if(.not.ljc4tlevs) then + call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,15),nstep,ntguessig,'qr') + if(ii == 1) pj(15,1)=pbc(1,15)+pbc(ipenloc,15) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcqr(1,ibin),nstep,it,'qr') + end do + pbc(:,15)=zero_quad + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,15) = pbc(j,15)+pbcqr(j,ibin) + end do + end do + if(ii == 1)then + do ibin=1,nobs_bins + pj(15,ibin)=pj(15,ibin)+pbcqr(1,ibin)+pbcqr(ipenloc,ibin) + end do + end if + end if + end if + if (getindex(cvars3d,'qs')>0) then + if(.not.ljc4tlevs) then + call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,16),nstep,ntguessig,'qs') + if(ii == 1) pj(16,1)=pbc(1,16)+pbc(ipenloc,16) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcqs(1,ibin),nstep,it,'qs') + end do + pbc(:,16)=zero_quad + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,16) = pbc(j,16)+pbcqs(j,ibin) + end do + end do + if(ii == 1)then + do ibin=1,nobs_bins + pj(16,ibin)=pj(16,ibin)+pbcqs(1,ibin)+pbcqs(ipenloc,ibin) + end do + end if + end if + end if + if (getindex(cvars3d,'qg')>0) then + if(.not.ljc4tlevs) then + call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,17),nstep,ntguessig,'qg') + if(ii == 1) pj(17,1)=pbc(1,17)+pbc(ipenloc,17) + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimqc(dval(ibin),sval(ibin),sges,pbcqg(1,ibin),nstep,it,'qg') + end do + pbc(:,17)=zero_quad + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,17) = pbc(j,17)+pbcqg(j,ibin) + end do + end do + if(ii == 1)then + do ibin=1,nobs_bins + pj(17,ibin)=pj(17,ibin)+pbcqg(1,ibin)+pbcqg(ipenloc,ibin) + end do + end if + end if + end if + end if ! ljclimqc + if(.not.ljc4tlevs) then + call stplimq(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,4),pbc(1,5),nstep,ntguessig) + if(ii == 1)then + pj(4,1)=pbc(1,4)+pbc(ipenloc,4) + pj(5,1)=pbc(1,5)+pbc(ipenloc,5) + end if + else + do ibin=1,nobs_bins + if (nobs_bins /= nfldsig) then + it=ntguessig + else + it=ibin + end if + call stplimq(dval(ibin),sval(ibin),sges,pbcqmin(1,ibin),pbcqmax(1,ibin),nstep,it) + end do + pbc(:,4)=zero_quad + pbc(:,5)=zero_quad + do ibin=1,nobs_bins + do j=1,nstep + pbc(j,4) = pbc(j,4)+pbcqmin(j,ibin) + pbc(j,5) = pbc(j,5)+pbcqmax(j,ibin) + end do + end do + if(ii == 1)then + do ibin=1,nobs_bins + pj(4,ibin)=pj(4,ibin)+pbcqmin(1,ibin)+pbcqmin(ipenloc,ibin) + pj(5,ibin)=pj(5,ibin)+pbcqmax(1,ibin)+pbcqmax(ipenloc,ibin) + end do + end if + end if +! penalties for gust constraint + if(getindex(cvars2d,'gust')>0) & + call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep) + if(ii == 1)pj(6,1)=pbc(1,6)+pbc(ipenloc,6) + +! penalties for vis constraint + if(getindex(cvars2d,'vis')>0) & + call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep) + if(ii == 1)pj(7,1)=pbc(1,7)+pbc(ipenloc,7) + +! penalties for pblh constraint + if(getindex(cvars2d,'pblh')>0) & + call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep) + if(ii == 1)pj(8,1)=pbc(1,8)+pbc(ipenloc,8) + +! penalties for wspd10m constraint + if(getindex(cvars2d,'wspd10m')>0) & + call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep) + if(ii == 1)pj(9,1)=pbc(1,9)+pbc(ipenloc,9) + +! penalties for howv constraint + if(getindex(cvars2d,'howv')>0) & + call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep) + if(ii == 1)pj(10,1)=pbc(1,10)+pbc(ipenloc,10) + +! penalties for lcbas constraint + if(getindex(cvars2d,'lcbas')>0) & + call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep) + if(ii == 1)pj(11,1)=pbc(1,11)+pbc(ipenloc,11) + +! penalties for cldch constraint + if(getindex(cvars2d,'cldch')>0) & + call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep) + if(ii == 1)pj(12,1)=pbc(1,12)+pbc(ipenloc,12) + end if + +! penalties for Jo + pbcjoi=zero_quad + call stpjo(dval,dbias,sval,sbias,sges,pbcjoi,nstep) + + pbcjo=zero_quad + do ibin=1,size(pbcjoi,3) ! == obs_bins + do j=1,size(pbcjoi,2) + do i=1,size(pbcjoi,1) + pbcjo(i,j)=pbcjo(i,j)+pbcjoi(i,j,ibin) + end do + end do + enddo + if(ii == 1)then + do ibin=1,size(pbcjoi,3) + do j=1,size(pbcjoi,2) + pj(n0+j,ibin)=pj(n0+j,ibin)+pbcjoi(ipenloc,j,ibin)+pbcjoi(1,j,ibin) + end do + enddo + endif + do j=1,size(pbcjo,2) + do i=1,size(pbcjo,1) + pbc(i,n0+j)=pbcjo(i,j) + end do + end do + +! Gather J contributions + call mpl_allreduce(4,ipen,pbc) + +! save penalty and stepsizes + nsteptot=nsteptot+1 + do j=1,ipen + outpen(nsteptot) = outpen(nsteptot)+pbc(1,j) + end do + outstp(nsteptot) = sges(1) + do i=2,nstep + nsteptot=nsteptot+1 + do j=1,ipen + outpen(nsteptot) = outpen(nsteptot)+pbc(i,j)+pbc(1,j) + end do + outstp(nsteptot) = sges(i) + end do + +! estimate and sum b and c +! estimate stepsize contributions for each term + bcoef=0.25_r_quad/(dels*stp(ii-1)) + ccoef=0.5_r_quad/(dels*dels*stp(ii-1)*stp(ii-1)) + bx=zero_quad + cx=zero_quad + do i=1,ipen + bsum(i)=bcoef*(pbc(2,i)-pbc(3,i)) + csum(i)=ccoef*(pbc(2,i)+pbc(3,i)) + bx=bx+bsum(i) + cx=cx+csum(i) + end do + +! estimate of stepsize + + stp(ii)=stp(ii-1) + if(cx > 1.e-20_r_kind) then + stp(ii)=stp(ii)+bx/cx ! step size estimate + else +! Check for cx <= 0. (probable error or large nonlinearity) + if(mype == 0) then + write(iout_iter,*) ' entering cx <=0 stepsize option',cx,stp(ii) + write(iout_iter,105) (bsum(i),i=1,ipen) + write(iout_iter,110) (csum(i),i=1,ipen) + end if + stp(ii)=outstp(ipenloc) + outpensave=outpen(ipenloc) + do i=1,nsteptot + if(outpen(i) < outpensave)then + stp(ii)=outstp(i) + outpensave=outpen(i) + end if + end do + if(outpensave < outpen(ipenloc))then + if(mype == 0)write(iout_iter,*) ' early termination due to cx <=0 ',cx,stp(ii) + cxterm=.true. + else +! Try different (better?) stepsize + stp(ii)=max(outstp(1),1.0e-20_r_kind) + do i=2,nsteptot + if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) + end do + stp(ii)=one_tenth_quad*stp(ii) + change_dels=.false. + end if + end if + + +! estimate various terms in penalty on first iteration + if(ii == 1)then + do i=1,ipen + pen_save(i)=pbc(1,i) + bsum_save(i)=bsum(i) + csum_save(i)=csum(i) + end do + pjcost(1) = pen_save(1)+pbc(ipenloc,1) ! Jb + pjcost(2) = zero_quad + do i=1,nobs_type + pjcost(2) = pjcost(2)+pen_save(n0+i)+pbc(ipenloc,n0+i) ! Jo + end do + pjcost(3) = pen_save(2) + pen_save(3)+pbc(ipenloc,3) ! Jc + pjcost(4) = zero_quad + do i=4,n0 + pjcost(4) = pjcost(4) + pen_save(i)+pbc(ipenloc,i) ! Jl + end do + + penalty=pjcost(1)+pjcost(2)+pjcost(3)+pjcost(4) ! J = Jb + Jo + Jc +Jl + +! Write out detailed results to iout_iter + if(mype == 0) then + write(iout_iter,100) (pen_save(i)+pbc(ipenloc,i),i=1,ipen) + if(print_verbose)then + write(iout_iter,105) (bsum(i),i=1,ipen) + write(iout_iter,110) (csum(i),i=1,ipen) + end if + end if + endif + +! estimate of change in penalty + delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx ) + +! If change in penalty is very small end stepsize calculation + if(abs(delpen/penalty) < 1.e-17_r_kind) then + if(mype == 0)then + write(iout_iter,*) ' minimization has converged ' + write(iout_iter,140) ii,delpen,bx,cx,stp(ii) + write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen) + if(print_verbose)then + write(iout_iter,105) (bsum(i),i=1,ipen) + write(iout_iter,110) (csum(i),i=1,ipen) + end if + end if + end_iter = .true. +! Finalize timer + call timer_fnl('stpcalc') + istp_use=ii + exit stepsize + end if + +! Check for negative stepsize (probable error or large nonlinearity) + if(stp(ii) <= zero_quad) then + if(mype == 0) then + write(iout_iter,*) ' entering negative stepsize option',stp(ii) + write(iout_iter,105) (bsum(i),i=1,ipen) + write(iout_iter,110) (csum(i),i=1,ipen) + end if + stp(ii)=outstp(ipenloc) + outpensave=outpen(ipenloc) + do i=1,nsteptot + if(outpen(i) < outpensave)then + stp(ii)=outstp(i) + outpensave=outpen(i) + end if + end do +! Try different (better?) stepsize + if(stp(ii) <= zero_quad .and. ii /= istp_iter)then + stp(ii)=max(outstp(1),1.0e-20_r_kind) + do i=2,nsteptot + if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) + end do + stp(ii)=one_tenth_quad*stp(ii) + change_dels=.false. + end if + end if + +100 format(' J=',3e25.18/,(3x,3e25.18)) +101 format('EJ=',3e25.18/,(3x,3e25.18)) +105 format(' b=',3e25.18/,(3x,3e25.18)) +110 format(' c=',3e25.18/,(3x,3e25.18)) +130 format('***WARNING*** negative or small cx inner', & + ' iteration terminated - probable error',i2,3e25.18) +140 format('***WARNING*** expected penalty reduction small ',/, & + ' inner iteration terminated - probable convergence',i2,4e25.18) +141 format('***WARNING*** reduced penalty not found in search direction',/, & + ' - probable error',(5e25.18)) + +! Check for convergence in stepsize estimation + istp_use=ii + if(cxterm) exit stepsize + stprat(ii)=zero + if(stp(ii) > zero)then + stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii)) + end if + if(stprat(ii) < 1.e-4_r_kind) exit stepsize + if(change_dels)dels = one_tenth_quad*dels +! If stepsize estimate has not converged use best stepsize estimate or zero + if( ii == istp_iter)then + stp(ii)=outstp(ipenloc) + outpensave=outpen(ipenloc) + ifound=.false. +! Find best stepsize to this point + do i=1,nsteptot + if(outpen(i) < outpensave)then + stp(ii)=outstp(i) + outpensave=outpen(i) + ifound=.true. + end if + end do + if(ifound)exit stepsize +! If no best stepsize set to zero and end minimization + if(mype == 0)then + write(iout_iter,141)(outpen(i),i=1,nsteptot) + end if + end_iter = .true. + stp(ii)=zero_quad + istp_use=ii + exit stepsize + end if + end do stepsize + kprt=3 + if(kprt >= 2 .and. iter == 0)then + call mpl_allreduce(ipen,nobs_bins,pj) + if(mype == 0)call prnt_j(pj,n0,ipen,kprt) + end if + + stpinout=stp(istp_use) +! Estimate terms in penalty + if(mype == 0 .and. print_verbose)then + do i=1,ipen + pen_est(i)=pen_save(i)-(stpinout-stp(0))*(2.0_r_quad*bsum_save(i)- & + (stpinout-stp(0))*csum_save(i)) + end do + write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) + end if + pjcostnew(1) = pbc(1,1) ! Jb + pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc + pjcostnew(4)=zero + do i=4,n0 + pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl + end do + pjcostnew(2) = zero + do i=1,nobs_type + pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo + end do + penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4) + + if(mype == 0 .and. print_verbose)then + write(iout_iter,200) (stp(i),i=0,istp_use) + write(iout_iter,199) (stprat(ii),ii=1,istp_use) + write(iout_iter,201) (outstp(i),i=1,nsteptot) + write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot) + end if +! Check for final stepsize negative (probable error) + if(stpinout <= zero)then + if(mype == 0)then + write(iout_iter,130) ii,bx,cx,stp(ii) + write(iout_iter,105) (bsum(i),i=1,ipen) + write(iout_iter,110) (csum(i),i=1,ipen) + write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) + end if + end_iter = .true. + end if +199 format(' stepsize stprat = ',6(e25.18,1x)) +200 format(' stepsize estimates = ',6(e25.18,1x)) +201 format(' stepsize guesses = ',(10(e13.6,1x))) +202 format(' penalties = ',(10(e13.6,1x))) + +! If convergence or failure of stepsize calculation return + if (end_iter) then + call timer_fnl('stpcalc') + return + endif + +! Update solution +!DIR$ IVDEP + do i=1,nclen + xhat%values(i)=xhat%values(i)+stpinout*dirx%values(i) + xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i) + yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i) + end do + + +! Finalize timer + call timer_fnl('stpcalc') + + return +end subroutine stpcalc + +subroutine prnt_j(pj,n0,ipen,kprt) +!$$$ subprogram documentation block +! . . . . +! subprogram: prnt_j +! prgmmr: derber +! +! abstract: prints J components +! +! program history log: +! 2015=03-06 derber +! +! input argument list: +! pj - array containing contributions to penalty +! ipen - number of penalty terms +! kprt - print type flag +! +! output argument list: +! +! attributes: +! language: f90 + use kinds, only: r_kind,i_kind,r_quad + use gsi_4dvar, only: nobs_bins + use constants, only: zero_quad + use jfunc, only: jiter,iter + use mpimod, only: mype + use gsi_obOperTypeManager, only: nobs_type => obOper_count + use gsi_obOperTypeManager, only: obOper_typeInfo + real(r_quad),dimension(ipen,nobs_bins),intent(in ) :: pj + integer(i_kind) ,intent(in ) :: n0,ipen,kprt + + ! pj( 1:n0 ): leading section for contributions from linear and nonlinear terms + ! pj(n0+1:ipen): remaining section for contributations from observation terms + + real(r_quad),dimension(ipen) :: zjt + real(r_quad) :: zj + integer(i_kind) :: ii,jj + character(len=20) :: ctype(ipen) + + if(kprt <=0 .or. mype /=0)return + ctype(:)=".unknown." + ctype(1)='background ' + ctype(2)=' ' + ctype(3)='dry mass constraint ' + ctype(4)='negative moisture ' + ctype(5)='excess moisture ' + ctype(6)='negative gust ' + ctype(7)='negative visability ' + ctype(8)='negative boundary Lr' + ctype(9)='negative 10m wind ssp' + ctype(10)='negative howv ' + ctype(11)='negative lcbas ' + ctype(12)='negative cldch ' + ctype(13)='negative ql ' + ctype(14)='negative qi ' + ctype(15)='negative qr ' + ctype(16)='negative qs ' + ctype(17)='negative qg ' + do ii=1,nobs_type + ctype(n0+ii)=obOper_typeInfo(ii) + end do + + zjt=zero_quad + do ii=1,nobs_bins + zjt(:)=zjt(:)+pj(:,ii) + end do + + zj=zero_quad + do ii=1,ipen + zj=zj+zjt(ii) + end do + +! Prints + if (kprt>=2) write(6,*)'Begin J table inner/outer loop',iter,jiter + + if (kprt>=3.and.nobs_bins>1) then + write(6,410)'J contribution ',(jj,jj=1,nobs_bins) + do ii=1,ipen + if (zjt(ii)>zero_quad) then + write(6,100)ctype(ii),(real(pj(ii,jj),r_kind),jj=1,nobs_bins) + endif + enddo + endif + write(6,400)' J term ',' ',' J ' + do ii=1,ipen + if (zjt(ii)>zero_quad) then + write(6,200)ctype(ii),real(zjt(ii),r_kind) + endif + enddo + + write(6,*)'----------------------------------------------------- ' + write(6,200)"J Global ",real(zj,r_kind) + + write(6,*)'End Jo table inner/outer loop',iter,jiter + +100 format(a20,2x,10es14.6) +410 format(a20,2x,10I14) +200 format(a20,2x,3x,2x,es24.16) +400 format(a20,2x,a3,2x,a24) + end subroutine prnt_j + +end module stpcalcmod diff --git a/src/stpcldch.f90 b/src/gsi/stpcldch.f90 similarity index 100% rename from src/stpcldch.f90 rename to src/gsi/stpcldch.f90 diff --git a/src/stpco.f90 b/src/gsi/stpco.f90 similarity index 100% rename from src/stpco.f90 rename to src/gsi/stpco.f90 diff --git a/src/gsi/stpdbz.f90 b/src/gsi/stpdbz.f90 new file mode 100644 index 000000000..013c89e46 --- /dev/null +++ b/src/gsi/stpdbz.f90 @@ -0,0 +1,201 @@ +module stpdbzmod + +!$$$ module documentation block +! . . . . +! module: stpdbzmod module for stpdbz and its tangent linear stpdbz_tl +! prgmmr: +! +! abstract: module for stpdbz and its tangent linear stpdbz_tl +! +! program history log: +! 2017-05-12 Y. Wang and X. Wang - add adjoint of reflectivity operator (Wang and Wang 2017 MWR), POC: xuguang.wang@ou.edu +! +! subroutines included: +! sub stpdbz +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none + +PRIVATE +PUBLIC stpdbz + +contains + +subroutine stpdbz(dbzhead,rval,sval,out,sges,nstep) +!$$$ subprogram documentation block +! . . . . +! subprogram: stpdbz calculate penalty and contribution to +! stepsize with nonlinear qc added. +! prgmmr: derber org: np23 date: 1991-02-26 +! +! abstract: calculate penalty and contribution to stepsize from radar winds +! +! program history log: +! 1991-02-26 derber +! 1999-11-22 yang +! 2004-07-29 treadon - add only to module use, add intent in/out +! 2004-10-07 parrish - add nonlinear qc option +! 2019-07-11 todling - introduced wrf_vars_mod +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_quad + use qcmod, only: nlnqc_iter,varqc_iter + use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600 + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gridmod, only: wrf_mass_regional + use wrf_vars_mod, only : dbz_exist + use m_obsNode, only: obsNode + use m_dbzNode , only: dbzNode + use m_dbzNode , only: dbzNode_typecast + use m_dbzNode , only: dbzNode_nextcast + + implicit none + +! Declare passed variables + class(obsNode), pointer ,intent(in ) :: dbzhead + integer(i_kind) ,intent(in ) :: nstep + real(r_quad),dimension(max(1,nstep)),intent(inout) :: out + type(gsi_bundle) ,intent(in ) :: rval,sval + real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges + +! Declare local variables + integer(i_kind) ier,istatus + integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,kk + real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8 + real(r_kind) valqr, valqs, valqg, valdbz + real(r_kind) qrcur, qscur, qgcur, dbzcur + real(r_kind) cg_dbz,dbz,wgross,wnotgross + real(r_kind),dimension(max(1,nstep))::pen + real(r_kind) pg_dbz + real(r_kind),pointer,dimension(:) :: sqr,sqs,sqg,sdbz + real(r_kind),pointer,dimension(:) :: rqr,rqs,rqg,rdbz + type(dbzNode), pointer :: dbzptr + + out=zero_quad + +! If no dbz data return + if(.not. associated(dbzhead))return + +! Retrieve pointers +! Simply return if any pointer not found + ier=0 + if(dbz_exist)then + call gsi_bundlegetpointer(sval,'dbz',sdbz,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'dbz',rdbz,istatus);ier=istatus+ier + else + call gsi_bundlegetpointer(sval,'qr',sqr,istatus);ier=istatus+ier + if (wrf_mass_regional) then + call gsi_bundlegetpointer(sval,'qs',sqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qg',sqg,istatus);ier=istatus+ier + end if + + call gsi_bundlegetpointer(rval,'qr',rqr,istatus);ier=istatus+ier + if (wrf_mass_regional) then + call gsi_bundlegetpointer(rval,'qs',rqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qg',rqg,istatus);ier=istatus+ier + end if + end if + if(ier/=0)return + + dbzptr => dbzNode_typecast(dbzhead) + do while (associated(dbzptr)) + if(dbzptr%luse)then + if(nstep > 0)then + j1=dbzptr%ij(1) + j2=dbzptr%ij(2) + j3=dbzptr%ij(3) + j4=dbzptr%ij(4) + j5=dbzptr%ij(5) + j6=dbzptr%ij(6) + j7=dbzptr%ij(7) + j8=dbzptr%ij(8) + w1=dbzptr%wij(1) + w2=dbzptr%wij(2) + w3=dbzptr%wij(3) + w4=dbzptr%wij(4) + w5=dbzptr%wij(5) + w6=dbzptr%wij(6) + w7=dbzptr%wij(7) + w8=dbzptr%wij(8) + + if( dbz_exist )then + valdbz= w1* rdbz(j1)+w2*rdbz(j2)+w3*rdbz(j3)+w4*rdbz(j4)+ & + w5* rdbz(j5)+w6*rdbz(j6)+w7*rdbz(j7)+w8*rdbz(j8) + + dbzcur= w1* sdbz(j1)+w2* sdbz(j2)+w3* sdbz(j3)+w4*sdbz(j4)+ & + w5* sdbz(j5)+w6* sdbz(j6)+w7* sdbz(j7)+w8* sdbz(j8)- & + dbzptr%res + + else + valqr=(w1* rqr(j1)+w2* rqr(j2)+w3* rqr(j3)+w4* rqr(j4)+ & + w5* rqr(j5)+w6* rqr(j6)+w7* rqr(j7)+w8* rqr(j8)) + + qrcur=(w1* sqr(j1)+w2* sqr(j2)+w3* sqr(j3)+w4* sqr(j4)+ & + w5* sqr(j5)+w6* sqr(j6)+w7* sqr(j7)+w8* sqr(j8)) + + if (wrf_mass_regional)then + valqs=(w1* rqs(j1)+w2* rqs(j2)+w3* rqs(j3)+w4* rqs(j4)+ & + w5* rqs(j5)+w6* rqs(j6)+w7* rqs(j7)+w8* rqs(j8)) + + qscur=(w1* sqs(j1)+w2* sqs(j2)+w3* sqs(j3)+w4* sqs(j4)+ & + w5* sqs(j5)+w6* sqs(j6)+w7* sqs(j7)+w8* sqs(j8)) + + valqg=(w1* rqg(j1)+w2* rqg(j2)+w3* rqg(j3)+w4* rqg(j4)+ & + w5* rqg(j5)+w6* rqg(j6)+w7* rqg(j7)+w8* rqg(j8)) + + qgcur=(w1* sqg(j1)+w2* sqg(j2)+w3* sqg(j3)+w4* sqg(j4)+ & + w5* sqg(j5)+w6* sqg(j6)+w7* sqg(j7)+w8* sqg(j8)) + + valdbz = valqr * dbzptr%jqr + valqs * dbzptr%jqs + & + valqg * dbzptr%jqg + + dbzcur = qrcur * dbzptr%jqr + qscur * dbzptr%jqs + & + qgcur * dbzptr%jqg - dbzptr%res + end if + + end if + + + do kk=1,nstep + dbz=dbzcur+sges(kk)*valdbz + pen(kk)=dbz*dbz*dbzptr%err2 + end do + else + pen(1)=dbzptr%res*dbzptr%res*dbzptr%err2 + end if + +! Modify penalty term if nonlinear QC + if (nlnqc_iter .and. dbzptr%pg > tiny_r_kind .and. & + dbzptr%b > tiny_r_kind) then + pg_dbz=dbzptr%pg*varqc_iter + cg_dbz=cg_term/dbzptr%b + wnotgross= one-pg_dbz + wgross = pg_dbz*cg_dbz/wnotgross + do kk=1,max(1,nstep) + pen(kk)= -two*log((exp(-half*pen(kk)) + wgross)/(one+wgross)) + end do + endif + + out(1) = out(1)+pen(1)*dbzptr%raterr2 + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*dbzptr%raterr2 + end do + end if + + dbzptr => dbzNode_nextcast(dbzptr) + + end do + return +end subroutine stpdbz + +end module stpdbzmod diff --git a/src/stpdw.f90 b/src/gsi/stpdw.f90 similarity index 100% rename from src/stpdw.f90 rename to src/gsi/stpdw.f90 diff --git a/src/stpgps.f90 b/src/gsi/stpgps.f90 similarity index 100% rename from src/stpgps.f90 rename to src/gsi/stpgps.f90 diff --git a/src/stpgust.f90 b/src/gsi/stpgust.f90 similarity index 100% rename from src/stpgust.f90 rename to src/gsi/stpgust.f90 diff --git a/src/stphowv.f90 b/src/gsi/stphowv.f90 similarity index 100% rename from src/stphowv.f90 rename to src/gsi/stphowv.f90 diff --git a/src/stpjcmod.f90 b/src/gsi/stpjcmod.f90 similarity index 77% rename from src/stpjcmod.f90 rename to src/gsi/stpjcmod.f90 index c21418b4f..289cc7672 100644 --- a/src/stpjcmod.f90 +++ b/src/gsi/stpjcmod.f90 @@ -12,6 +12,8 @@ module stpjcmod ! 2014-05-07 pondeca - add stepzise calculation for howv weak constraint term ! 2014-06-17 carley/zhu - add stepzise calculation for lcbas weak constraint term ! 2015-07-10 pondeca - add stepzise calculation for cldch weak constraint term +! 2019-03-05 martin - update stplimq to weight factqmin/max by latitude +! 2019-03-14 eliu - add stplimqc to constraint negative hydrometeors ! ! subroutines included: ! @@ -29,7 +31,7 @@ module stpjcmod implicit none PRIVATE -PUBLIC stplimq,stplimg,stplimp,stplimv,stplimw10m,stplimhowv,stplimcldch,stpliml,stpjcdfi,stpjcpdry +PUBLIC stplimqc,stplimq,stplimg,stplimp,stplimv,stplimw10m,stplimhowv,stplimcldch,stpliml,stpjcdfi,stpjcpdry contains @@ -56,6 +58,7 @@ subroutine stplimq(rval,sval,sges,outmin,outmax,nstep,itbin) ! 2010-05-13 todling - update to use gsi_bundle ! 2010-07-10 todling - merge w/ r8741 (trunk); qx(:)->qx (who made the change?) ! 2011-12-27 kleist - add bins for 4d capability (4densvar option) +! 2019-03-05 martin - update to weight factqmin/max by latitude ! ! input argument list: ! rq - search direction @@ -73,9 +76,10 @@ subroutine stplimq(rval,sval,sges,outmin,outmax,nstep,itbin) ! machine: ibm RS/6000 SP ! !$$$ - use gridmod, only: lat1,lon1,nsig + use gridmod, only: lat1,lon1,nsig,istart,wgtfactlats use jfunc, only: factqmin,factqmax use guess_grids, only: ges_qsat + use mpimod, only: mype implicit none ! Declare passed variables @@ -85,7 +89,7 @@ subroutine stplimq(rval,sval,sges,outmin,outmax,nstep,itbin) type(gsi_bundle) ,intent(in ) :: rval,sval ! Declare local variables - integer(i_kind) i,j,k,kk,ier,istatus + integer(i_kind) i,j,k,kk,ier,istatus,ii,mm1 real(r_kind) q,qx real(r_kind),pointer,dimension(:,:,:) :: rq,sq real(r_kind),pointer,dimension(:,:,:) :: ges_q_it=>NULL() @@ -94,6 +98,8 @@ subroutine stplimq(rval,sval,sges,outmin,outmax,nstep,itbin) if (factqmin==zero .and. factqmax==zero) return + mm1=mype+1 + ! Retrieve pointers ! Simply return if any pointer not found ier=0 @@ -109,16 +115,17 @@ subroutine stplimq(rval,sval,sges,outmin,outmax,nstep,itbin) do k = 1,nsig do j = 2,lon1+1 do i = 2,lat1+1 - + ii=istart(mm1)+i-2 ! Values for q using stepsizes q = ges_q_it(i,j,k) + sq(i,j,k) do kk=1,nstep qx = q + sges(kk)*rq(i,j,k) if(qx < zero)then - outmin(kk)=outmin(kk)+factqmin*qx*qx/(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) + outmin(kk)=outmin(kk)+(factqmin*wgtfactlats(ii))*qx*qx & + /(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) else if(qx > ges_qsat(i,j,k,itbin))then - outmax(kk)=outmax(kk)+factqmax*(qx-ges_qsat(i,j,k,itbin))* & + outmax(kk)=outmax(kk)+(factqmax*wgtfactlats(ii))*(qx-ges_qsat(i,j,k,itbin))* & (qx-ges_qsat(i,j,k,itbin))/(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) end if end if @@ -130,15 +137,15 @@ subroutine stplimq(rval,sval,sges,outmin,outmax,nstep,itbin) do k = 1,nsig do j = 2,lon1+1 do i = 2,lat1+1 - + ii=istart(mm1)+i-2 ! Values for q using stepsizes q = ges_q_it(i,j,k) if(q < zero)then - outmin(1)=outmin(1)+factqmin*q*q/(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) + outmin(1)=outmin(1)+(factqmin*wgtfactlats(ii))*q*q/(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) else if(q > ges_qsat(i,j,k,itbin))then - outmax(1)=outmax(1)+factqmax*(q-ges_qsat(i,j,k,itbin))*(q-ges_qsat(i,j,k,itbin))/ & - (ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) + outmax(1)=outmax(1)+(factqmax*wgtfactlats(ii))*(q-ges_qsat(i,j,k,itbin))*& + (q-ges_qsat(i,j,k,itbin))/(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) end if end if end do @@ -152,7 +159,129 @@ subroutine stplimq(rval,sval,sges,outmin,outmax,nstep,itbin) end do return end subroutine stplimq +subroutine stplimqc(rval,sval,sges,out,nstep,itbin,cldtype) +!$$$ subprogram documentation block +! . . . . +! subprogram: stplimqc calculate penalty and stepsize for limit of qc +! prgmmr: eliu org: np23 date: 2018-05-30 +! +! abstract: calculate stepsize contribution and penalty for limiting q +! +! program history log: +! 2018-05-30 eliu - based on stplimq +! +! input argument list: +! rqc - search direction +! sqc - increment in grid space +! sges - step size estimates (4) +! nstep - number of step size estimates if == 0 then just do outer loop +! itbin - observation bin number (time level) +! +! output argument list: +! outmin(1:nstep) - current penalty for negative q sges(1:nstep) +! outmax(1:nstep) - current penalty for excess q sges(1:nstep) +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpimod, only: mype + use gridmod, only: lat1,lon1,nsig + use jfunc, only: factql,factqi,factqr,factqs,factqg + use guess_grids, only: ges_qsat + implicit none + +! Declare passed variables + integer(i_kind) ,intent(in ) :: nstep,itbin + real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges + real(r_quad),dimension(max(1,nstep)),intent( out) :: out + type(gsi_bundle) ,intent(in ) :: rval,sval + character(2) ,intent(in ) :: cldtype +! Declare local variables + integer(i_kind) i,j,k,kk,ier,ier1,istatus + real(r_kind) qc,qx + real(r_kind) factqc + real(r_kind),pointer,dimension(:,:,:) :: rqc,sqc + real(r_kind),pointer,dimension(:,:,:) :: ges_qc_it=>NULL() + out=zero_quad + +! Retrieve pointers +! Simply return if any pointer not found + ier=0; ier1=0; istatus=0 + if (cldtype == 'ql') then + factqc =factql + call gsi_bundlegetpointer(sval,'ql',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'ql',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'ql',ges_qc_it,ier1) + endif + if (cldtype == 'qi') then + factqc =factqi + call gsi_bundlegetpointer(sval,'qi',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qi',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qi',ges_qc_it,ier1) + endif + if (cldtype == 'qr') then + factqc =factqr + call gsi_bundlegetpointer(sval,'qr',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qr',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qr',ges_qc_it,ier1) + endif + if (cldtype == 'qs') then + factqc =factqs + call gsi_bundlegetpointer(sval,'qs',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qs',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qs',ges_qc_it,ier1) + endif + if (cldtype == 'qg') then + factqc =factqg + call gsi_bundlegetpointer(sval,'qg',sqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qg',rqc,istatus);ier=istatus+ier + call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qg',ges_qc_it,ier1) + endif + if (mype==0) write(6,*)'stplimqc: factqc = ', factqc + if (mype==0) write(6,*)'stplimqc: ier ier1 = ', ier, ier1 + if ( factqc==0 ) return + if ( ier/=0 .or. ier1/=0 ) return + +! Loop over interior of subdomain + if(nstep > 0)then + do k = 1,nsig + do j = 2,lon1+1 + do i = 2,lat1+1 + +! Values for q using stepsizes + qc = ges_qc_it(i,j,k) + sqc(i,j,k) + do kk=1,nstep + qx = qc + sges(kk)*rqc(i,j,k) + if(qx < zero)then + out(kk)=out(kk)+factqc*qx*qx/(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) + end if + end do + end do + end do + end do + else + do k = 1,nsig + do j = 2,lon1+1 + do i = 2,lat1+1 + +! Values for q using stepsizes + qc = ges_qc_it(i,j,k) + if(qc < zero)then + out(1)=out(1)+factqc*qc*qc/(ges_qsat(i,j,k,itbin)*ges_qsat(i,j,k,itbin)) + end if + end do + end do + end do + end if + + do kk=2,nstep + out(kk)=out(kk)-out(1) + end do + return +end subroutine stplimqc subroutine stplimg(rval,sval,sges,out,nstep) !$$$ subprogram documentation block ! . . . . @@ -731,8 +860,9 @@ subroutine stpjcpdry(rval,sval,pen,b,c,nbins) ! Declare local variables real(r_quad),dimension(2*nbins):: dmass real(r_quad) :: rcon,con - integer(i_kind) i,j,k,it,mm1,ii,ier,icw,iql,iqi,istatus,n + integer(i_kind) i,j,k,it,mm1,ii,ier,icw,iql,iqi,iqr,iqs,iqg,istatus,n real(r_kind),pointer,dimension(:,:,:) :: rq,sq,rc,sc,rql,rqi,sql,sqi + real(r_kind),pointer,dimension(:,:,:) :: rqr,rqs,rqg,sqr,sqs,sqg real(r_kind),pointer,dimension(:,:) :: rp,sp logical return_now real(r_quad) :: dmn, dmn2 @@ -747,19 +877,27 @@ subroutine stpjcpdry(rval,sval,pen,b,c,nbins) do n=1,nbins ! Retrieve pointers ! Simply return if any pointer not found - ier=0; icw=0; iql=0; iqi=0 - call gsi_bundlegetpointer(sval(n),'q' ,sq, istatus);ier=istatus+ier - call gsi_bundlegetpointer(sval(n),'cw',sc, istatus);icw=istatus+icw - call gsi_bundlegetpointer(sval(n),'ql',sql,istatus);iql=istatus+iql - call gsi_bundlegetpointer(sval(n),'qi',sqi,istatus);iqi=istatus+iqi - call gsi_bundlegetpointer(sval(n),'ps',sp, istatus);ier=istatus+ier - call gsi_bundlegetpointer(rval(n),'q' ,rq, istatus);ier=istatus+ier - call gsi_bundlegetpointer(rval(n),'cw',rc, istatus);icw=istatus+icw - call gsi_bundlegetpointer(rval(n),'ql',rql,istatus);iql=istatus+iql - call gsi_bundlegetpointer(rval(n),'qi',rqi,istatus);iqi=istatus+iqi - call gsi_bundlegetpointer(rval(n),'ps',rp, istatus);ier=istatus+ier - if(ier+icw*(iql+iqi)/=0)then - if (mype==0) write(6,*)'stpjcpdry: checking ier+icw*(iql+iqi)=', ier+icw*(iql+iqi) + ier=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; istatus=0 + call gsi_bundlegetpointer(sval(n),'q' ,sq, istatus) ; ier=istatus+ier + call gsi_bundlegetpointer(sval(n),'cw',sc, istatus) ; icw=istatus+icw + call gsi_bundlegetpointer(sval(n),'ql',sql,istatus) ; iql=istatus+iql + call gsi_bundlegetpointer(sval(n),'qi',sqi,istatus) ; iqi=istatus+iqi + call gsi_bundlegetpointer(sval(n),'qr',sqr,istatus) ; iqr=istatus+iqr + call gsi_bundlegetpointer(sval(n),'qs',sqs,istatus) ; iqs=istatus+iqs + call gsi_bundlegetpointer(sval(n),'qg',sqg,istatus) ; iqg=istatus+iqg + call gsi_bundlegetpointer(sval(n),'ps',sp, istatus) ; ier=istatus+ier + + call gsi_bundlegetpointer(rval(n),'q' ,rq, istatus) ; ier=istatus+ier + call gsi_bundlegetpointer(rval(n),'cw',rc, istatus) ; icw=istatus+icw + call gsi_bundlegetpointer(rval(n),'ql',rql,istatus) ; iql=istatus+iql + call gsi_bundlegetpointer(rval(n),'qi',rqi,istatus) ; iqi=istatus+iqi + call gsi_bundlegetpointer(rval(n),'qr',rqr,istatus) ; iqr=istatus+iqr + call gsi_bundlegetpointer(rval(n),'qs',rqs,istatus) ; iqs=istatus+iqs + call gsi_bundlegetpointer(rval(n),'qg',rqg,istatus) ; iqg=istatus+iqg + call gsi_bundlegetpointer(rval(n),'ps',rp, istatus) ; ier=istatus+ier + if( ier/=0 .or. ((iql+iqi)/=0 .and. icw/=0) ) then + if (mype==0) write(6,*) 'stpjcpdry: warning - missing some required variables' + if (mype==0) write(6,*) 'stpjcpdry: dry mass constraint not performed' return end if @@ -793,6 +931,18 @@ subroutine stpjcpdry(rval,sval,pen,b,c,nbins) else dmn=dmn - (sql(i,j,k)+sqi(i,j,k))*con dmn2=dmn2 - (rql(i,j,k)+rqi(i,j,k))*con + if (iqr==0) then + dmn = dmn - sqr(i,j,k)*con + dmn2= dmn2- rqr(i,j,k)*con + endif + if (iqs==0) then + dmn = dmn - sqs(i,j,k)*con + dmn2= dmn2- rqs(i,j,k)*con + endif + if (iqg==0) then + dmn = dmn - sqg(i,j,k)*con + dmn2= dmn2- rqg(i,j,k)*con + endif endif end do end do diff --git a/src/gsi/stpjo.f90 b/src/gsi/stpjo.f90 new file mode 100644 index 000000000..b0ff73082 --- /dev/null +++ b/src/gsi/stpjo.f90 @@ -0,0 +1,420 @@ +module stpjomod + +!$$$ subprogram documentation block +! . . . . +! subprogram: stpjo calculate penalty and stepsize +! prgmmr: derber org: np23 date: 2003-12-18 +! +! abstract: calculate observation term to penalty and estimate stepsize +! (nonlinear qc version) +! +! program history log: +! 2003-12-18 derber,j. - +! 2016-08-22 guo, j. - Wrapped simple subroutines to a module, with +! private module variables from obsmod.F90 moved +! here. +! . For the earlier program history log, see the +! "program history log" blocks below, in +! individual subroutines/module-procedures. +! . Changed if/elseif/else blocks to select-case +! blocks, using enumerated i_ob_type to replace +! locally hard-wired index values (ll=1,2,3,..). +! This is a step moving toward using type-bound- +! procedures. +! 2018-08-10 guo - a new implementation replacing typs specific stpXYZ() +! calls to polymorphic %stpjo() calls. + + use kinds , only: i_kind + + implicit none + + private + + ! Usecase 1: as-is + ! call stpjo_setup(yobs,size(yobs)) + ! call stpjo(yobs,dval,dbias,xval,xbias,sges,pbcjo,nstep,size(yobs)) + public:: stpjo + public:: stpjo_setup + + ! Usecase 2: Renamed with the same functionalities but more explicit names + public:: stpjo_reset ! always re-set, either undefined or already defined. + interface stpjo_reset; module procedure stpjo_setup; end interface + public:: stpjo_calc ! + interface stpjo_calc ; module procedure stpjo ; end interface + +! Moved here from obsmod.F90 +! def stpcnt - number of non-zero obs types (including time domain) on +! processor - used for threading of stpjo +! def ll_jo - points at ob type for location in stpcnt - used for +! threading of stpjo +! def ib_jo - points at time bin for location in stpcnt - used for +! threading of stpjo + + integer(i_kind),save:: stpcnt ! count of stpjo threads + integer(i_kind),save,allocatable,dimension(:):: ll_jo ! enumerated iobtype of threads + integer(i_kind),save,allocatable,dimension(:):: ib_jo ! ob-bin index values of threads + logical:: omptasks_configured_ = .false. + + character(len=*),parameter:: myname="stpjomod" +contains + +subroutine init_(nobs_type,nobs_bins) +!> initialize a task distribution list (stpcnt, ll_jo(:),ib_jo(:)) + implicit none + integer(i_kind),intent(in):: nobs_type + integer(i_kind),intent(in):: nobs_bins + + if(omptasks_configured_) call final_() + + allocate(ll_jo(nobs_bins*nobs_type), & + ib_jo(nobs_bins*nobs_type) ) + + ll_jo(:)=0 + ib_jo(:)=0 + stpcnt =0 +end subroutine init_ + +subroutine final_() + implicit none + if(allocated(ll_jo)) deallocate(ll_jo) + if(allocated(ib_jo)) deallocate(ib_jo) + stpcnt=0 + omptasks_configured_=.false. +end subroutine final_ + +subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep) + +!$$$ subprogram documentation block +! . . . . +! subprogram: stpjo calculate penalty and stepsize +! prgmmr: derber org: np23 date: 2003-12-18 +! +! abstract: calculate observation term to penalty and estimate stepsize +! (nonlinear qc version) +! +! A description of nonlinear qc follows: +! +! The observation penalty Jo is defined as +! +! Jo = - (sum over obs) 2*log(Po) +! +! where, +! +! Po = Wnotgross*exp(-.5*(Hn(x+xb) - yo)**2 ) + Wgross +! with +! Hn = the forward model (possibly non-linear) normalized by +! observation error +! x = the current estimate of the analysis increment +! xb = the background state +! yo = the observation normalized by observation error +! +! Note: The factor 2 in definition of Jo is present because the +! penalty Jo as used in this code is 2*(usual definition +! of penalty) +! +! Wgross = Pgross*cg +! +! Wnotgross = 1 - Wgross +! +! Pgross = probability of gross error for observation (assumed +! here to have uniform distribution over the possible +! range of values) +! +! cg = sqrt(2*pi)/2b +! +! b = possible range of variable for gross errors, normalized by +! observation error +! +! The values for the above parameters that Bill Collins used in the +! eta 3dvar are: +! +! cg = cg_term/b, where cg_term = sqrt(2*pi)/2 +! +! b = 10. ! range for gross errors, normalized by obs error +! +! pg_q=.002 ! probability of gross error for specific humidity +! pg_pw=.002 ! probability of gross error for precipitable water +! pg_p=.002 ! probability of gross error for pressure +! pg_w=.005 ! probability of gross error for wind +! pg_t=.007 ! probability of gross error for temperature +! pg_rad=.002 ! probability of gross error for radiances +! +! +! Given the above Jo, the gradient of Jo is as follows: +! +! T +! gradx(Jo) = - (sum over observations) 2*H (Hn(x+xb)-yo)*(Po - Wgross)/Po +! +! where, +! +! H = tangent linear model of Hn about x+xb +! +! +! Note that if Pgross = 0.0, then Wnotgross=1.0 and Wgross=0.0. That is, +! the code runs as though nonlinear quality control were not present +! (which is indeed the case since the gross error probability is 0). +! +! As a result the same stp* routines may be used for use with or without +! nonlinear quality control. +! +! Please note, however, that using the nonlinear qc routines makes the +! stp* and int* operators nonlinear. Hence, the need to evaluate the +! step size operators twice for each observation type, give the current +! step size algorithm coded below. +! +! +! program history log: +! 2003-12-18 derber,j. +! 2004-07-23 derber - modify to include conventional sst +! 2004-07-28 treadon - add only to module use, add intent in/out +! 2004-10-06 parrish - add nonlinear qc option +! 2004-10-06 kleist - separate control vector for u,v, get search +! direction for u,v from dir for st,vp +! 2004-11-30 treadon - add brightness temperatures to nonlinear +! quality control +! 2005-01-20 okamoto - add u,v to stprad_qc +! 2005-01-26 cucurull- implement local GPS RO linear operator +! 2005-02-10 treadon - add u,v to stprad_qc (okamoto change not present) +! 2005-02-23 wu - add call to normal_rh_to_q to convert normalized +! RH to q +! 2005-04-11 treadon - rename stpcalc_qc as stpcalc +! 2005-05-21 yanqiu zhu - add 'use stp*mod', and modify call interfaces for using these modules +! 2005-05-27 derber - remove linear stepsize estimate +! 2005-06-03 parrish - add horizontal derivatives +! 2005-07-10 kleist - add dynamic constraint term (linear) +! 2005-09-29 kleist - expand Jc term, include time derivatives vector +! 2005-11-21 kleist - separate tendencies from Jc term, add call to calctends tlm +! 2005-12-01 cucurull - add code for GPS local bending angle, add use obsmod for ref_obs +! 2005-12-20 parrish - add arguments to call to stpt to enable boundary layer forward +! model option. +! 2006-04-18 derber - add explicit iteration over stepsize (rather than +! repeated calls) - clean up and simplify +! 2006-04-24 kleist - include both Jc formulations +! 2006-05-26 derber - modify to improve convergence checking +! 2006-07-26 parrish - correct inconsistency in computation of space and time derivatives of q +! currently, if derivatives computed, for q it is normalized q, but +! should be mixing ratio. +! 2006-08-04 parrish - add strong constraint initialization option +! 2006-09-18 derber - modify output from nonlinear operators to make same as linear operators +! 2006-09-20 derber - add sensible temperatures for conventional obs. +! 2006-10-12 treadon - replace virtual temperature with sensible in stppcp +! 2007-03-19 tremolet - binning of observations +! 2007-04-13 tremolet - split jo from other components of stpcalc +! 2007-04-16 kleist - modified calls to tendency and constraint routines +! 2007-06-04 derber - use quad precision to get reproduceability over number of processors +! 2007-07-26 cucurull - update gps code to generalized vertical coordinate; +! get current solution for 3d pressure (xhat_3dp); +! move getprs_tl out of calctends_tl; add dirx3dp +! and remove ps in calctends_tl argument list; +! use getprs_tl +! 2007-08-08 derber - optimize, ensure that only necessary time derivatives are calculated +! 2008-12-02 todling - revisited split of stpcalc in light of 4dvar merge with May08 version +! 2009-01-08 todling - remove reference to ozohead +! 2010-01-04 zhang,b - bug fix: accumulate penalty for multiple obs bins +! 2010-03-25 zhu - change the interfaces of stprad,stpt,stppcp;add nrf* conditions +! 2010-05-13 todling - harmonized all stp interfaces to use state vector; gsi_bundle use +! 2010-06-14 todling - add stpco call +! 2010-07-10 todling - somebody reordered calls to stpw, stpq, and stpoz - any reason? +! 2010-10-15 pagowski - add stppm2_5 call +! 2011-02-24 zhu - add gust,vis,pblh calls +! 2013-05-23 zhu - add bias correction contribution from aircraft T bias correction +! 2014-03-19 pondeca - add wspd10m +! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl +! 2014-05-07 pondeca - add howv +! 2014-06-17 carley/zhu - add lcbas and tcamt +! 2015-07-10 pondeca - add cldch +! 2016-05-05 pondeca - add uwnd10m, vwnd10m +! 2016-08-26 guo - separated a single stpoz() call into stpozlay() and +! stpozlev() calls. This is a next-step fix of the +! minimum fix in stpjo_setup() below, to let output +! pbcjo(:,:,:) to reflect individual ob-types correctly. +! 2018-01-01 apodaca - add lightning (light) call +! +! input argument list: +! yobs +! dval - current solution +! dbias - +! xval - +! xbias - +! sges +! nstep - number of steps +! +! output argument list: +! pbcjo +! +! +! remarks: +! 1. The part of xhat and dirx containing temps and psfc are values before strong initialization, +! xhatt, xhatp and dirxt, dirxp contain temps and psfc after strong initialization. +! If strong initialization is turned off, then xhatt, etc are equal to the corresponding +! fields in xhat, dirx. +! xhatuv, xhat_t and dirxuv, dirx_t are all after +! strong initialization if it is turned on. +! 2. Notice that now (2010-05-13) stp routines handle non-essential variables +! internally; also, when pointers non-existent, stp routines simply return. +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: i_kind,r_kind,r_quad + use bias_predictors, only: predictors + use gsi_bundlemod, only: gsi_bundle + + use gsi_obOper, only: obOper + use m_obsdiags, only: obOper_create + use m_obsdiags, only: obOper_destroy + use gsi_obOperTypeManager, only: obOper_typeInfo + + use intradmod, only: setrad + + use mpeu_util, only: perr,die + use mpeu_util, only: tell + use mpeu_mpif, only: MPI_comm_world + implicit none + +! Declare passed variables + type(gsi_bundle) ,dimension(:),intent(in ) :: dval ! (nobs_bins) + type(predictors) ,intent(in ) :: dbias + type(gsi_bundle) ,dimension(:),intent(in ) :: xval ! (nobs_bins) + type(predictors) ,intent(in ) :: xbias + integer(i_kind) ,intent(in ) :: nstep + real(r_kind),dimension(max(1,nstep)) ,intent(in ) :: sges + real(r_quad),dimension(:,:,:) ,intent(inout) :: pbcjo ! (:,obOper_count,nobs_bins) + +! Declare local variables + character(len=*),parameter:: myname_=myname//"::stpjo" + + integer(i_kind) :: ll,mm,ib + class(obOper),pointer:: it_obOper +!************************************************************************************ + + call setrad(xval(1)) + +!$omp parallel do schedule(dynamic,1) private(ll,mm,ib,it_obOper) + do mm=1,stpcnt + ll=ll_jo(mm) + ib=ib_jo(mm) + + it_obOper => obOper_create(ll) + + if(.not.associated(it_obOper)) then + call perr(myname_,'unexpected obOper, associated(it_obOper) =',associated(it_obOper)) + call perr(myname_,' obOper_typeInfo(ioper) =',obOper_typeInfo(ll)) + call perr(myname_,' iOper =',ll) + call perr(myname_,' ibin =',ib) + call perr(myname_,' mm =',mm) + call perr(myname_,' stpcnt =',stpcnt) + call die(myname_) + endif + + if(.not.associated(it_obOper%obsLL)) then + call perr(myname_,'unexpected components, associated(%obsLL) =',associated(it_obOper%obsLL)) + call perr(myname_,' obOper_typeInfo(ioper) =',obOper_typeInfo(ll)) + call perr(myname_,' iOper =',ll) + call perr(myname_,' ibin =',ib) + call perr(myname_,' mm =',mm) + call perr(myname_,' stpcnt =',stpcnt) + call die(myname_) + endif + + call it_obOper%stpjo(ib,dval(ib),xval(ib),pbcjo(:,ll,ib),sges,nstep,dbias,xbias) + call obOper_destroy(it_obOper) + enddo + +return +end subroutine stpjo + +subroutine stpjo_setup(nobs_bins) + +!$$$ subprogram documentation block +! . . . . +! subprogram: stpjo_setup setup loops for stpjo +! prgmmr: derber org: np23 date: 2003-12-18 +! +! abstract: setup parallel loops for stpjo +! +! program history log: +! 2015-01-18 derber,j. +! 2016-08-26 guo, j. - patched with ".or.associated(yobs%o3l)" checking at +! the checking of "associated(yobs%oz)", as a minimum +! bug fix. +! +! input argument list: +! yobs +! nobs_bins - number of obs bins +! +! output argument list: +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: i_kind,r_kind,r_quad + use gsi_bundlemod, only: gsi_bundle + use gsi_obOperTypeManager, only: obOper_count + use gsi_obOperTypeManager, only: obOper_typeInfo + use gsi_obOper, only: obOper + use m_obsdiags, only: obOper_create + use m_obsdiags, only: obOper_destroy + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use mpeu_util , only: perr, die + use mpeu_util , only: tell + implicit none + +! Declare passed variables + integer(i_kind),intent(in):: nobs_bins + +! Declare local variables + character(len=*),parameter:: myname_=myname//"::stpjo_setup" + + integer(i_kind) ll,ib + class(obsNode),pointer:: headNode + class(obOper ),pointer:: it_obOper +!************************************************************************************ + call init_(obOper_count,nobs_bins) + + stpcnt = 0 + do ll = 1, obOper_count ! Not nobs_type anymore + + it_obOper => obOper_create(ll) + + if(.not.associated(it_obOper)) then + call perr(myname_,'unexpected obOper, associated(it_obOper) =',associated(it_obOper)) + call perr(myname_,' obOper_typeInfo(ioper) =',obOper_typeInfo(ll)) + call perr(myname_,' ioper =',ll) + call perr(myname_,' obOper_count =',obOper_count) + call die(myname_) + endif + + if(.not.associated(it_obOper%obsLL)) then + call perr(myname_,'unexpected component, associated(%obsLL) =',associated(it_obOper%obsLL)) + call perr(myname_,' obOper_typeInfo(ioper) =',obOper_typeInfo(ll)) + call perr(myname_,' ioper =',ll) + call perr(myname_,' obOper_count =',obOper_count) + call die(myname_) + endif + + do ib = 1,size(it_obOper%obsLL) ! for all bins + headNode => obsLList_headNode(it_obOper%obsLL(ib)) + if(.not.associated(headNode)) cycle ! there is no observation node in this bin + + stpcnt = stpcnt +1 + ll_jo(stpcnt) = ll + ib_jo(stpcnt) = ib + + enddo ! ib + headNode => null() + call obOper_destroy(it_obOper) + enddo ! ll, i.e. ioper of 1:obOper_ubound + + omptasks_configured_ = .true. + + return +end subroutine stpjo_setup + +end module stpjomod diff --git a/src/stplcbas.f90 b/src/gsi/stplcbas.f90 similarity index 100% rename from src/stplcbas.f90 rename to src/gsi/stplcbas.f90 diff --git a/src/gsi/stplight.f90 b/src/gsi/stplight.f90 new file mode 100644 index 000000000..6976a9b43 --- /dev/null +++ b/src/gsi/stplight.f90 @@ -0,0 +1,892 @@ +module stplightmod + +!$$$ module documentation block +! . . . . +! module: stplightmod module for stplight and its tangent linear stplight_tl +! prgmmr: k apodaca +! org: CSU/CIRA, Data Assimilation Group +! date: 2016-05-19 +! +! abstract: module for calculating stplight and its tangent linear stplight_tl +! +! program history log: +! 2016-05-19 apodaca - original version +! +! subroutines included: +! sub stplight +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none + +PRIVATE +PUBLIC stplight + +contains + +subroutine stplight(lighthead,rval,sval,out,sges,nstep) +!$$$ subprogram documentation block +! . . . . +! subprogram: stplight compute contribution to penalty and stepsize +! from lightning, using nonlinear qc +! prgmmr: apodaca org: CSU/CIRA date: 2016-05-19 +! +! abstract: This routine applies the (linear) operator of the +! lightning flash rate model and finds an optimal estimate +! of step size as done in steepest descent or conjugate +! gradient algorithms. Note that in the case for lightning +! flash rate dk=-delJ(h(xk)) +! This version includes nonlinear qc. +! +! program history log: +! 2016-05-19 k apodaca +! 2016-06-21 k apodaca - update documentation +! 2018-03-07 k apodaca - replaced ob_type with polymorphic obsNode through type casting +! 2018-08-27 k apodaca - add TL-related components of a second oservation operator for +! lightning observations suitable for non-hydrostatic, +! cloud-resolving models with additional ice-phase hydrometeor +! control variables +! +! input argument list: +! lighthead +! rt - search direction (gradxJ) for virtual temperature +! rq - search direction (gradxJ) for specific humidity +! rqi - search direction (gradxJ) for cloud ice +! rqs - search direction (gradxJ) for snow +! rqg - search direction (gradxJ) for graupel +! ru - search direction (gradxJ) for the u-component of wind +! rv - search direction (gradxJ) for the v-component of wind +! st - analysis increment (correction) for virtual temperature +! sq - analysis increment (correction) for specific humidity +! sqi - analysis increment (correction) for cloud ice +! sqs - analysis increment (correction) for snow +! sqg - analysis increment (correction) for graupel +! su - analysis increment (correction) for u-component of wind +! sv - analysis increment (correction) for the v-component of wind +! sges - stepsize estimates (nstep) +! nstep - number of stepsize estimates (==0 means use outer iteration values) +! +! output argument list: +! out(1:nstep)- contribution to penalty from lightning - sges(1:nstep) +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ + use kinds, only: r_kind,i_kind,r_quad + use qcmod, only: nlnqc_iter,varqc_iter + use constants, only: zero,one,two,half,tiny_r_kind,cg_term,zero_quad,r3600,fv + use gridmod, only: nsig + use gridmod, only: wrf_mass_regional,regional + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use m_obsNode , only: obsNode + use m_lightNode , only: lightNode + use m_lightNode , only: lightNode_typecast + use m_lightNode , only: lightNode_nextcast + implicit none + +! Declare passed variables + class(obsNode ),pointer ,intent(in ) :: lighthead + integer(i_kind) ,intent(in ) :: nstep + real(r_quad),dimension(max(1,nstep)),intent(inout) :: out + type(gsi_bundle) ,intent(in ) :: rval,sval + real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges + +! Declare local variables + integer(i_kind) k,kk,ier,istatus + integer(i_kind),dimension(nsig) :: i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12 + real(r_kind) :: val,val2 + real(r_kind) :: w1,w2,w3,w4 + real(r_kind),pointer,dimension(:) :: st,sq,sqi,sqs,sqg,su,sv + real(r_kind),pointer,dimension(:) :: rt,rq,rqi,rqs,rqg,ru,rv + type(lightNode), pointer :: lightptr + ! Variables for TL and r_TL of lightning flash rate + real(r_kind),dimension(1:nsig) :: z_TL + real(r_kind),dimension(1:nsig) :: horiz_adv_TL + real(r_kind),dimension(1:nsig) :: vert_adv_TL + real(r_kind),dimension(1:nsig) :: w_TL + real(r_kind) :: wmaxi1_TL,wmaxi2_TL,wmaxi3_TL,wmaxi4_TL + real(r_kind) :: flashrate_TL,flashratei1_TL,flashratei2_TL + real(r_kind) :: flashratei3_TL,flashratei4_TL + real(r_kind) :: h1i1_TL,h1i2_TL,h1i3_TL,h1i4_TL + real(r_kind) :: h2i1_TL,h2i2_TL,h2i3_TL,h2i4_TL + real(r_kind) :: htot_TL + real(r_kind) :: htoti1_TL,htoti2_TL,htoti3_TL,htoti4_TL + real(r_kind) :: totice_colinti1_TL,totice_colinti2_TL,totice_colinti3_TL + real(r_kind) :: totice_colinti4_TL + real(r_kind) :: wmax + real(r_kind),parameter :: k3=0.95_r_kind + real(r_kind),dimension(1:nsig) :: rz_TL + real(r_kind),dimension(1:nsig) :: rhoriz_adv_TL + real(r_kind),dimension(1:nsig) :: rvert_adv_TL + real(r_kind),dimension(1:nsig) :: rw_TL + real(r_kind) :: rwmaxi1_tl,rwmaxi2_tl,rwmaxi3_tl,rwmaxi4_tl + real(r_kind) :: rflashrate_tl,rflashratei1_tl,rflashratei2_tl + real(r_kind) :: rflashratei3_tl,rflashratei4_tl + real(r_kind) :: rh1i1_TL,rh1i2_TL,rh1i3_TL,rh1i4_TL + real(r_kind) :: rh2i1_TL,rh2i2_TL,rh2i3_TL,rh2i4_TL + real(r_kind) :: rhtot_TL + real(r_kind) :: rhtoti1_TL,rhtoti2_TL,rhtoti3_TL,rhtoti4_TL + real(r_kind) :: rtotice_colinti1_TL,rtotice_colinti2_TL,rtotice_colinti3_TL + real(r_kind) :: rtotice_colinti4_TL + real(r_kind) cg_light,wgross,wnotgross + real(r_kind) pg_light,nref + real(r_kind),dimension(max(1,nstep))::pen + +! Initialize penalty, b1, and b3 to zero + out=zero_quad + +! If no light data return + if(.not. associated(lighthead))return + + +! Retrieve pointers +! Simply return if any pointer not found + ier=0 + call gsi_bundlegetpointer(sval,'tv', st,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'q', sq,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'u', su,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'v', sv,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'tv', rt,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'q', rq,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'u', ru,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'v', rv,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qi',sqi,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qi',rqi,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qg',sqg,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qg',rqg,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qs',sqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qs',rqs,istatus);ier=istatus+ier + if(ier/=0)return + +! Loop over observations + lightptr => lightNode_typecast(lighthead) + do while (associated(lightptr)) + if(lightptr%luse)then + + val2=-lightptr%res + if(nstep > 0)then + do k=1,nsig + i1(k)=lightptr%ij(1,k) + i2(k)=lightptr%ij(2,k) + i3(k)=lightptr%ij(3,k) + i4(k)=lightptr%ij(4,k) + i5(k)=lightptr%ij(5,k) + i6(k)=lightptr%ij(6,k) + i7(k)=lightptr%ij(7,k) + i8(k)=lightptr%ij(8,k) + i9(k)=lightptr%ij(9,k) + i10(k)=lightptr%ij(10,k) + i11(k)=lightptr%ij(11,k) + i12(k)=lightptr%ij(12,k) + end do + + w1=lightptr%wij(1) + w2=lightptr%wij(2) + w3=lightptr%wij(3) + w4=lightptr%wij(4) + + val=zero + +! . . . . + +! In the case of lightning observations (e.g. GOES/GLM), the schematic shown below is +! used for bi-linear interpolation of background fields to the location of an observation +! (+) and for the finite-difference derivation method used in the calculation of the TL of +! the observation operator for lightning flash rate. Calculations are done +! at each quadrant, i.e., central, north, south, east, and west. +! +! i6-------i8 +! | | +! | | +! i10-----i2-------i4------i12 +! | | | | +! | | + | | +! i9------i1-------i3------i11 +! | | +! | | +! i5-------i7 +! + +! . . . . + + +! In the following section, the tangent linear of the lightning flash rate observation +! operator is calculated by being broken into parts. + +! Tangent linear of height (z) + + + + z_TL(:)=zero + horiz_adv_TL(:)=zero + + do k=2,nsig-1 + + z_TL(i1(1))=lightptr%jac_z0i1 + z_TL(i2(1))=lightptr%jac_z0i2 + z_TL(i3(1))=lightptr%jac_z0i3 + z_TL(i4(1))=lightptr%jac_z0i4 + z_TL(i5(1))=lightptr%jac_z0i5 + z_TL(i6(1))=lightptr%jac_z0i6 + z_TL(i7(1))=lightptr%jac_z0i7 + z_TL(i8(1))=lightptr%jac_z0i8 + z_TL(i9(1))=lightptr%jac_z0i9 + z_TL(i10(1))=lightptr%jac_z0i10 + z_TL(i11(1))=lightptr%jac_z0i11 + z_TL(i12(1))=lightptr%jac_z0i12 + + + z_TL(i1(k))=z_TL(i1(k-1))+lightptr%jac_vertti1(k)*st(i1(k)) & + +lightptr%jac_vertqi1(k)*sq(i1(k)) + + z_TL(i2(k))=z_TL(i2(k-1))+lightptr%jac_vertti2(k)*st(i2(k)) & + +lightptr%jac_vertqi2(k)*sq(i2(k)) + + z_TL(i3(k))=z_TL(i3(k-1))+lightptr%jac_vertti3(k)*st(i3(k)) & + +lightptr%jac_vertqi3(k)*sq(i3(k)) + + z_TL(i4(k))=z_TL(i4(k-1))+lightptr%jac_vertti4(k)*st(i4(k)) & + +lightptr%jac_vertqi4(k)*sq(i4(k)) + + z_TL(i5(k))=z_TL(i5(k-1))+lightptr%jac_vertti5(k)*st(i5(k)) & + +lightptr%jac_vertqi5(k)*sq(i5(k)) + + z_TL(i6(k))=z_TL(i6(k-1))+lightptr%jac_vertti6(k)*st(i6(k)) & + +lightptr%jac_vertqi6(k)*sq(i6(k)) + + z_TL(i7(k))=z_TL(i7(k-1))+lightptr%jac_vertti7(k)*st(i7(k)) & + +lightptr%jac_vertqi7(k)*sq(i7(k)) + + z_TL(i8(k))=z_TL(i8(k-1))+lightptr%jac_vertti8(k)*st(i8(k)) & + +lightptr%jac_vertqi8(k)*sq(i8(k)) + + z_TL(i9(k))=z_TL(i9(k-1))+lightptr%jac_vertti9(k)*st(i9(k)) & + +lightptr%jac_vertqi9(k)*sq(i9(k)) + + z_TL(i10(k))=z_TL(i10(k-1))+lightptr%jac_vertti10(k)*st(i10(k)) & + +lightptr%jac_vertqi10(k)*sq(i10(k)) + + z_TL(i11(k))=z_TL(i11(k-1))+lightptr%jac_vertti11(k)*st(i11(k)) & + +lightptr%jac_vertqi11(k)*sq(i11(k)) + + z_TL(i12(k))=z_TL(i12(k-1))+lightptr%jac_vertti12(k)*st(i12(k)) & + +lightptr%jac_vertqi12(k)*sq(i12(k)) + + +! Tangent Linear of the Horizontal Advection Section + + + horiz_adv_TL(i1(k))=lightptr%jac_zdxi1(k)*su(i1(k)) & + +lightptr%jac_zdyi1(k)*sv(i1(k)) & + +lightptr%jac_udxi1(k)*(z_TL(i3(k))-z_TL(i9(k))) & + +lightptr%jac_vdyi1(k)*(z_TL(i2(k))-z_TL(i5(k))) + + horiz_adv_TL(i2(k))=lightptr%jac_zdxi2(k)*su(i2(k)) & + +lightptr%jac_zdyi2(k)*sv(i2(k)) & + +lightptr%jac_udxi2(k)*(z_TL(i4(k))-z_TL(i10(k))) & + +lightptr%jac_vdyi2(k)*(z_TL(i6(k))-z_TL(i1 (k))) + + horiz_adv_TL(i3(k))=lightptr%jac_zdxi3(k)*su(i3(k)) & + +lightptr%jac_zdyi3(k)*sv(i3(k)) & + +lightptr%jac_udxi3(k)*(z_TL(i11(k))-z_TL(i1(k))) & + +lightptr%jac_vdyi3(k)*(z_TL(i4 (k))-z_TL(i7(k))) + + horiz_adv_TL(i4(k))=lightptr%jac_zdxi4(k)*su(i4(k)) & + +lightptr%jac_zdyi4(k)*sv(i4(k)) & + +lightptr%jac_udxi4(k)*(z_TL(i12(k))-z_TL(i2(k))) & + +lightptr%jac_vdyi4(k)*(z_TL(i8 (k))-z_TL(i3(k))) + + enddo ! do k=2,nsig-1 + + +! Tangent Linear of the Vertical Advection Section + +! Variable Initialization + + vert_adv_TL(:)=zero + w_TL(:)=zero + + do k=1,nsig-1 + + vert_adv_TL(i1(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti1(k)* & + (((one+fv*lightptr%jac_qi1(k))*st(i1(k))) & + +(lightptr%jac_ti1(k)*fv*sq(i1(k)))) + + vert_adv_TL(i2(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti2(k)* & + (((one+fv*lightptr%jac_qi2(k))*st(i2(k))) & + +(lightptr%jac_ti2(k)*fv*sq(i2(k)))) + + vert_adv_TL(i3(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti3(k)* & + (((one+fv*lightptr%jac_qi3(k))*st(i3(k))) & + +(lightptr%jac_ti3(k)*fv*sq(i3(k)))) + + vert_adv_TL(i4(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti4(k)* & + (((one+fv*lightptr%jac_qi4(k))*st(i4(k))) & + +(lightptr%jac_ti4(k)*fv*sq(i4(k)))) + + + +! Tangent Linear of Vertical Velocity + + + w_TL(i1(k))=horiz_adv_TL(i1(k))+vert_adv_TL(i1(k)) + w_TL(i2(k))=horiz_adv_TL(i2(k))+vert_adv_TL(i2(k)) + w_TL(i3(k))=horiz_adv_TL(i3(k))+vert_adv_TL(i3(k)) + w_TL(i4(k))=horiz_adv_TL(i4(k))+vert_adv_TL(i4(k)) + + enddo !do k=1,nsig-1 +! . . . . + +! Tangent Linear of lightning flash rate + +! . . . . +! Regional + + if (regional) then + +! WRF-ARW + + if (wrf_mass_regional) then + + +! Tangent linear - Lightning flash rate as a function of +! vertical graupel flux within the mixed-phase region +! (-15 lightptr%jac_qgmbi1(lightptr%kboti) deg C) + + if (lightptr%kboti1 > zero) then + h1i1_TL=lightptr%jac_qgmai1(lightptr%kboti1)*sqg(i1(lightptr%kboti1))+& + lightptr%jac_qgmbi1(lightptr%kboti1)*& + (half*(w_TL(i1(lightptr%kboti1))+w_TL(i1(lightptr%kboti1+1)))) + h1i1_TL=h1i1_TL/(abs(h1i1_TL)) + else + h1i1_TL=zero + endif + + if (lightptr%kboti2 > zero) then + h1i2_TL=lightptr%jac_qgmai2(lightptr%kboti2)*sqg(i2(lightptr%kboti2))+& + lightptr%jac_qgmbi2(lightptr%kboti2)*& + (half*(w_TL(i2(lightptr%kboti2))+w_TL(i2(lightptr%kboti2+1)))) + h1i2_TL=h1i2_TL/(abs(h1i2_TL)) + else + h1i2_TL=zero + endif + + if (lightptr%kboti3 > zero) then + h1i3_TL=lightptr%jac_qgmai3(lightptr%kboti3)*sqg(i3(lightptr%kboti3))+& + lightptr%jac_qgmbi3(lightptr%kboti3)*& + (half*(w_TL(i3(lightptr%kboti3))+w_TL(i3(lightptr%kboti3+1)))) + h1i3_TL=h1i3_TL/(abs(h1i3_TL)) + else + h1i3_TL=zero + endif + + if (lightptr%kboti4 > zero) then + h1i4_TL=lightptr%jac_qgmai4(lightptr%kboti4)*sqg(i4(lightptr%kboti4))+& + lightptr%jac_qgmbi4(lightptr%kboti4)*& + (half*(w_TL(i4(lightptr%kboti4))+w_TL(i4(lightptr%kboti4+1)))) + h1i4_TL=h1i4_TL/(abs(h1i4_TL)) + else + h1i4_TL=zero + endif + + + +! Tangent Linear - Lightning flash rate as a function of total column-integrated +! ice-phase hydrometeors + + totice_colinti1_TL=zero + totice_colinti2_TL=zero + totice_colinti3_TL=zero + totice_colinti4_TL=zero + + do k=1,nsig-1 + + totice_colinti1_TL = totice_colinti1_TL+lightptr%jac_icei1(k) * & + (sqi(i1(k))+sqs(i1(k))+sqg(i1(k)))+& + lightptr%jac_zicei1(k)*z_TL(i1(k)) + + totice_colinti2_TL = totice_colinti2_TL+lightptr%jac_icei2(k) * & + (sqi(i2(k))+sqs(i2(k))+sqg(i2(k)))+& + lightptr%jac_zicei2(k)*z_TL(i2(k)) + + totice_colinti3_TL = totice_colinti3_TL+lightptr%jac_icei3(k) * & + (sqi(i3(k))+sqs(i3(k))+sqg(i3(k)))+& + lightptr%jac_zicei3(k)*z_TL(i3(k)) + + totice_colinti4_TL = totice_colinti4_TL+lightptr%jac_icei4(k) * & + (sqi(i4(k))+sqs(i4(k))+sqg(i4(k)))+& + lightptr%jac_zicei4(k)*z_TL(i4(k)) + + + enddo + + h2i1_TL=(1-k3)*totice_colinti1_TL + h2i2_TL=(1-k3)*totice_colinti2_TL + h2i3_TL=(1-k3)*totice_colinti3_TL + h2i4_TL=(1-k3)*totice_colinti4_TL + + + htoti1_TL= h1i1_TL+h2i1_TL + htoti2_TL= h1i2_TL+h2i2_TL + htoti3_TL= h1i3_TL+h2i3_TL + htoti4_TL= h1i4_TL+h2i4_TL + + +! Interpolation of lightning flash rate to observation location (2D field) +! Forward Model + + htot_TL = (w1*htoti1_TL + w2*htoti2_TL + & + w3*htoti3_TL + w4*htoti4_TL) + val2 = val2 + htot_TL + + endif ! wrf_mass_regional + + endif !if (regional) then +! . . . . +! Global + + if (.not. regional) then + + +! Cloud Mask + +! If clouds are present, find the maximum value of vertical velocity +! (wmax_TL) at four points sorounding an observation (+) +! and amongst all vertical levels, otherwise set wmax_TL to zero. + + wmaxi1_TL=zero + wmaxi2_TL=zero + wmaxi3_TL=zero + wmaxi4_TL=zero + + if (lightptr%jac_wmaxflagi1) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (w_TL(i1(k)) > wmax) then + lightptr%jac_kverti1=k + wmaxi1_TL=w_TL(i1(lightptr%jac_kverti1)) + endif + if (wmaxi1_TL < zero) then + wmaxi1_TL=zero + endif + enddo ! k loop + endif + + if (lightptr%jac_wmaxflagi2) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (w_TL(i2(k)) > wmax) then + lightptr%jac_kverti2=k + wmaxi2_TL=w_TL(i2(lightptr%jac_kverti2)) + endif + if (wmaxi2_TL < zero) then + wmaxi2_TL=zero + endif + enddo ! k loop + endif + + if (lightptr%jac_wmaxflagi3) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (w_TL(i3(k)) > wmax) then + lightptr%jac_kverti3=k + wmaxi3_TL=w_TL(i3(lightptr%jac_kverti3)) + endif + if (wmaxi3_TL < zero) then + wmaxi3_TL=zero + endif + enddo ! k loop + endif + + if (lightptr%jac_wmaxflagi4) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (w_TL(i4(k)) > wmax) then + lightptr%jac_kverti4=k + wmaxi4_TL=w_TL(i4(lightptr%jac_kverti4)) + endif + if (wmaxi4_TL < zero) then + wmaxi4_TL=zero + endif + enddo ! k loop + endif + +! Tangent Linear of Lightning Flash Rate + + flashratei1_TL=lightptr%jac_fratei1*wmaxi1_TL + flashratei2_TL=lightptr%jac_fratei1*wmaxi2_TL + flashratei3_TL=lightptr%jac_fratei1*wmaxi3_TL + flashratei4_TL=lightptr%jac_fratei1*wmaxi4_TL + +! Interpolation of lightning flash rate to observation location (2D field) +! Forward Model + + flashrate_TL = (w1*flashratei1_TL + w2*flashratei2_TL & + +w3*flashratei3_TL + w4*flashratei4_TL) + val2 = val2 + flashrate_TL + + endif ! end regional/global block + + +! . . . . + + + +! Search direction (gradxJ) for lightning flash rate observation +! operator + +! gradxJ: Tangent linear of height (z) + +! Variable Initialization + + rz_TL(:)=zero + rhoriz_adv_TL(:)=zero + + rvert_adv_TL(:)=zero + rw_TL(:)=zero + + do k=2,nsig-1 + + rz_TL(i1(1))=lightptr%jac_z0i1 + rz_TL(i2(1))=lightptr%jac_z0i2 + rz_TL(i3(1))=lightptr%jac_z0i3 + rz_TL(i4(1))=lightptr%jac_z0i4 + rz_TL(i5(1))=lightptr%jac_z0i5 + rz_TL(i6(1))=lightptr%jac_z0i6 + rz_TL(i7(1))=lightptr%jac_z0i7 + rz_TL(i8(1))=lightptr%jac_z0i8 + rz_TL(i9(1))=lightptr%jac_z0i9 + rz_TL(i10(1))=lightptr%jac_z0i10 + rz_TL(i11(1))=lightptr%jac_z0i11 + rz_TL(i12(1))=lightptr%jac_z0i12 + + rz_TL(i1(k))=rz_TL(i1(k-1))+lightptr%jac_vertti1(k)*rt(i1(k)) & + +lightptr%jac_vertqi1(k)*rq(i1(k)) + + rz_TL(i2(k))=rz_TL(i2(k-1))+lightptr%jac_vertti2(k)*rt(i2(k)) & + +lightptr%jac_vertqi2(k)*rq(i2(k)) + + rz_TL(i3(k))=rz_TL(i3(k-1))+lightptr%jac_vertti3(k)*rt(i3(k)) & + +lightptr%jac_vertqi3(k)*rq(i3(k)) + + rz_TL(i4(k))=rz_TL(i4(k-1))+lightptr%jac_vertti4(k)*rt(i4(k)) & + +lightptr%jac_vertqi4(k)*rq(i4(k)) + + rz_TL(i5(k))=rz_TL(i5(k-1))+lightptr%jac_vertti5(k)*rt(i5(k)) & + +lightptr%jac_vertqi5(k)*rq(i5(k)) + + rz_TL(i6(k))=rz_TL(i6(k-1))+lightptr%jac_vertti6(k)*rt(i6(k)) & + +lightptr%jac_vertqi6(k)*rq(i6(k)) + + rz_TL(i7(k))=rz_TL(i7(k-1))+lightptr%jac_vertti7(k)*rt(i7(k)) & + +lightptr%jac_vertqi7(k)*rq(i7(k)) + + rz_TL(i8(k))=rz_TL(i8(k-1))+lightptr%jac_vertti8(k)*rt(i8(k)) & + +lightptr%jac_vertqi8(k)*rq(i8(k)) + + rz_TL(i9(k))=rz_TL(i9(k-1))+lightptr%jac_vertti9(k)*rt(i9(k)) & + +lightptr%jac_vertqi9(k)*rq(i9(k)) + + rz_TL(i10(k))=rz_TL(i10(k-1))+lightptr%jac_vertti10(k)*rt(i10(k)) & + +lightptr%jac_vertqi10(k)*rq(i10(k)) + + rz_TL(i11(k))=rz_TL(i11(k-1))+lightptr%jac_vertti11(k)*rt(i11(k)) & + +lightptr%jac_vertqi11(k)*rq(i11(k)) + + rz_TL(i12(k))=rz_TL(i12(k-1))+lightptr%jac_vertti12(k)*rt(i12(k)) & + +lightptr%jac_vertqi12(k)*rq(i12(k)) + + + +! gradxJ: Tangent Linear of the Horizontal Advection Section + + + rhoriz_adv_TL(i1(k))=lightptr%jac_zdxi1(k)*ru(i1(k)) & + +lightptr%jac_zdyi1(k)*rv(i1(k)) & + +lightptr%jac_udxi1(k)*(rz_TL(i3(k))-rz_TL(i9(k))) & + +lightptr%jac_vdyi1(k)*(rz_TL(i2(k))-rz_TL(i5(k))) + + rhoriz_adv_TL(i2(k))=lightptr%jac_zdxi2(k)*ru(i2(k)) & + +lightptr%jac_zdyi2(k)*rv(i2(k)) & + +lightptr%jac_udxi2(k)*(rz_TL(i4(k))-rz_TL(i10(k)))& + +lightptr%jac_vdyi2(k)*(rz_TL(i6(k))-rz_TL(i1 (k))) + + rhoriz_adv_TL(i3(k))=lightptr%jac_zdxi3(k)*ru(i3(k)) & + +lightptr%jac_zdyi3(k)*rv(i3(k)) & + +lightptr%jac_udxi3(k)*(rz_TL(i11(k))-rz_TL(i1(k))) & + +lightptr%jac_vdyi3(k)*(rz_TL(i4 (k))-rz_TL(i7(k))) + + rhoriz_adv_TL(i4(k))=lightptr%jac_zdxi4(k)*ru(i4(k)) & + +lightptr%jac_zdyi4(k)*rv(i4(k)) & + +lightptr%jac_udxi4(k)*(rz_TL(i12(k))-rz_TL(i2(k))) & + +lightptr%jac_vdyi4(k)*(rz_TL(i8 (k))-rz_TL(i3(k))) + + enddo !do k=2,nsig-1 + +! gradxJ: Tangent Linear of the Vertical Advection Section + + do k=1,nsig-1 + + rvert_adv_TL(i1(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti1(k)* & + (((one+fv*lightptr%jac_qi1(k))*rt(i1(k))) & + +(lightptr%jac_ti1(k)*fv*rq(i1(k)))) + + rvert_adv_TL(i2(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti2(k)* & + (((one+fv*lightptr%jac_qi2(k))*rt(i2(k))) & + +(lightptr%jac_ti2(k)*fv*rq(i2(k)))) + + rvert_adv_TL(i3(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti3(k)* & + (((one+fv*lightptr%jac_qi3(k))*rt(i3(k))) & + +(lightptr%jac_ti3(k)*fv*rq(i3(k)))) + + rvert_adv_TL(i4(k))=-lightptr%jac_vert(k)*lightptr%jac_sigdoti4(k)* & + (((one+fv*lightptr%jac_qi4(k))*rt(i4(k))) & + +(lightptr%jac_ti4(k)*fv*rq(i4(k)))) + + +! gradxJ: Tangent Linear of Vertical Velocity + + + rw_TL(i1(k))=rhoriz_adv_TL(i1(k))+rvert_adv_TL(i1(k)) + rw_TL(i2(k))=rhoriz_adv_TL(i2(k))+rvert_adv_TL(i2(k)) + rw_TL(i3(k))=rhoriz_adv_TL(i3(k))+rvert_adv_TL(i3(k)) + rw_TL(i4(k))=rhoriz_adv_TL(i4(k))+rvert_adv_TL(i4(k)) + + enddo + +! . . . . +! gradxJ: Tangent Linear of lightning flash rate + +! . . . . + +! Regional + + if (regional) then + +! WRF-ARW + + if (wrf_mass_regional) then + +! gradxJ: Tangent linear - Lightning flash rate as a function of +! vertical graupel flux within the mixed-phase region +! (-15 lightptr%jac_qgmbi1(lightptr%kboti1(k)deg C) + + + if (lightptr%kboti1 > zero) then + rh1i1_TL=lightptr%jac_qgmai1(lightptr%kboti1)*rqg(i1(lightptr%kboti1))+& + lightptr%jac_qgmbi1(lightptr%kboti1)*& + (half*(rw_TL(i1(lightptr%kboti1))+rw_TL(i1(lightptr%kboti1+1)))) + rh1i1_TL=rh1i1_TL/(abs(rh1i1_TL)) + else + rh1i1_TL=zero + endif + + if (lightptr%kboti2 > 0) then + rh1i2_TL=lightptr%jac_qgmai2(lightptr%kboti2)*rqg(i2(lightptr%kboti2))+& + lightptr%jac_qgmbi2(lightptr%kboti2)*& + (half*(rw_TL(i2(lightptr%kboti2))+rw_TL(i2(lightptr%kboti2+1)))) + rh1i2_TL=rh1i2_TL/(abs(rh1i2_TL)) + else + rh1i2_TL=zero + endif + + if (lightptr%kboti3 > zero) then + rh1i3_TL=lightptr%jac_qgmai3(lightptr%kboti3)*rqg(i3(lightptr%kboti3))+& + lightptr%jac_qgmbi3(lightptr%kboti3)*& + (half*(rw_TL(i3(lightptr%kboti3))+rw_TL(i3(lightptr%kboti3+1)))) + rh1i3_TL=rh1i3_TL/(abs(rh1i3_TL)) + else + rh1i3_TL=zero + endif + + if (lightptr%kboti4 > zero) then + rh1i4_TL=lightptr%jac_qgmai4(lightptr%kboti4)*rqg(i4(lightptr%kboti4))+& + lightptr%jac_qgmbi4(lightptr%kboti4)*& + (half*(rw_TL(i4(lightptr%kboti4))+rw_TL(i4(lightptr%kboti4+1)))) + rh1i4_TL=rh1i4_TL/(abs(rh1i4_TL)) + else + rh1i4_TL=zero + endif + + + +! gradxJ: Tangent Linear - Lightning flash rate as a function of total column-integrated +! ice-phase hydrometeors + + do k=1,nsig-1 + + rtotice_colinti1_TL = rtotice_colinti1_TL+lightptr%jac_icei1(k) * & + (rqi(i1(k))+rqs(i1(k))+rqg(i1(k)))+& + lightptr%jac_zicei1(k)*rz_TL(i1(k)) + + rtotice_colinti2_TL = rtotice_colinti2_TL+lightptr%jac_icei2(k) * & + (rqi(i2(k))+rqs(i2(k))+rqg(i2(k)))+& + lightptr%jac_zicei2(k)*rz_TL(i2(k)) + + rtotice_colinti3_TL = rtotice_colinti3_TL+lightptr%jac_icei3(k) * & + (rqi(i3(k))+rqs(i3(k))+rqg(i3(k)))+& + lightptr%jac_zicei3(k)*rz_TL(i3(k)) + + rtotice_colinti4_TL = rtotice_colinti4_TL+lightptr%jac_icei4(k) * & + (rqi(i4(k))+rqs(i4(k))+rqg(i4(k)))+& + lightptr%jac_zicei4(k)*rz_TL(i4(k)) + + enddo + + rh2i1_TL=(1-k3)*rtotice_colinti1_TL + rh2i2_TL=(1-k3)*rtotice_colinti2_TL + rh2i3_TL=(1-k3)*rtotice_colinti3_TL + rh2i4_TL=(1-k3)*rtotice_colinti4_TL + + + rhtoti1_TL= rh1i1_TL+rh2i1_TL + rhtoti2_TL= rh1i2_TL+rh2i2_TL + rhtoti3_TL= rh1i3_TL+rh2i3_TL + rhtoti4_TL= rh1i4_TL+rh2i4_TL + +! Interpolation of lightning flash rate to observation location (2D field) +! Forward Model + + rhtot_TL = (w1*rhtoti1_TL + w2*rhtoti2_TL + & + w3*rhtoti3_TL + w4*rhtoti4_TL) + val = val + rhtot_TL + + endif ! wrf_mass_regional + + endif !if (regional) then +! . . . . +! Global + + if (.not. regional) then + +! Cloud Mask (gradxJ) + +! If clouds are present, find the maximum value of vertical velocity +! (wmax_TL) at four points sorounding an observation (+) +! and amongst all vertical levels, otherwise set wmax_TL to zero. + + rwmaxi1_TL=zero + rwmaxi2_TL=zero + rwmaxi3_TL=zero + rwmaxi4_TL=zero + + if (lightptr%jac_wmaxflagi1) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (rw_TL(i1(k)) > wmax) then + lightptr%jac_kverti1=k + rwmaxi1_TL=rw_TL(i1(lightptr%jac_kverti1)) + endif + if (rwmaxi1_TL < zero) then + rwmaxi1_TL=zero + endif + enddo ! k loop + endif + + if (lightptr%jac_wmaxflagi2) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (rw_TL(i2(k)) > wmax) then + lightptr%jac_kverti2=k + rwmaxi2_TL=rw_TL(i2(lightptr%jac_kverti2)) + endif + if (rwmaxi2_TL < zero) then + rwmaxi2_TL=zero + endif + enddo ! k loop + endif + + if (lightptr%jac_wmaxflagi3) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (rw_TL(i3(k)) > wmax) then + lightptr%jac_kverti3=k + rwmaxi3_TL=rw_TL(i3(lightptr%jac_kverti3)) + endif + if (rwmaxi3_TL < zero) then + rwmaxi3_TL=zero + endif + enddo ! k loop + endif + + if (lightptr%jac_wmaxflagi4) then + wmax=-1.e+10_r_kind + do k=1,nsig-1 + if (rw_TL(i4(k)) > wmax) then + lightptr%jac_kverti4=k + rwmaxi4_TL=rw_TL(i4(lightptr%jac_kverti4)) + endif + if (rwmaxi4_TL < zero) then + rwmaxi4_TL=zero + endif + enddo ! k loop + endif + + + +! gradxJ: Tangent Linear of Lightning Flash Rate + + rflashratei1_TL=lightptr%jac_fratei1*wmaxi1_TL + rflashratei2_TL=lightptr%jac_fratei1*wmaxi2_TL + rflashratei3_TL=lightptr%jac_fratei1*wmaxi3_TL + rflashratei4_TL=lightptr%jac_fratei1*wmaxi4_TL + +! Interpolation of lightning flash rate TL to observation location (2D field) +! Forward Model + + rflashrate_TL = (w1*rflashratei1_TL + w2*rflashratei2_TL & + +w3*rflashratei3_TL + w4*rflashratei4_TL) + val = val + rflashrate_TL + + endif ! end regional/global block + + +! . . . . + + +! penalty and gradient + + do kk=1,nstep + nref=val2+sges(kk)*val + pen(kk)=nref*nref*lightptr%err2 + end do + else + pen(1)=val2*val2*lightptr%err2 + end if !if(nstep > 0)then + +! Modify penalty term if nonlinear QC + if (nlnqc_iter .and. lightptr%pg > tiny_r_kind .and. lightptr%b > tiny_r_kind) then + pg_light=lightptr%pg*varqc_iter + cg_light=cg_term/lightptr%b + wnotgross= one-pg_light + wgross = pg_light*cg_light/wnotgross + do kk=1,max(1,nstep) + pen(kk) = -two*log((exp(-half*pen(kk)) + wgross)/(one+wgross)) + end do + endif + +! Cost function + out(1) = out(1)+pen(1)*lightptr%raterr2 + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*lightptr%raterr2 + end do + + endif ! if(lightptr%luse) then + + lightptr => lightNode_nextcast(lightptr) + + end do !do while (associated(lightptr)) + + + return +end subroutine stplight + + +end module stplightmod diff --git a/src/gsi/stplwcp.f90 b/src/gsi/stplwcp.f90 new file mode 100644 index 000000000..124d0279b --- /dev/null +++ b/src/gsi/stplwcp.f90 @@ -0,0 +1,217 @@ +module stplwcpmod + +!$$$ module documentation block +! . . . . +! module: stplwcpmod module for stplwcp and its tangent linear stplwcp_tl +! prgmmr: +! +! abstract: module for stplwcp and its tangent linear stplwcp_tl +! +! program history log: +! +! subroutines included: +! sub stplwcp +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none + +PRIVATE +PUBLIC stplwcp + +contains + +subroutine stplwcp(lwcphead,rval,sval,out,sges,nstep) +!$$$ subprogram documentation block +! . . . . +! subprogram: stplwcp calculate penalty and contribution to stepsize +! for lwcp using nonlinear qc +! prgmmr: Ting-Chi Wu org: CIRA/CSU date: 2017-06-28 +! +! abstract: calculate penalty and contribution to stepsize from lwcp +! using nonlinear qc. +! +! program history log: +! 2017-06-28 Ting-Chi Wu - mimic the structure in stppw.f90 and stpgps.f90 +! - stplwcp.f90 includes 2 stp options +! 1) when l_wcp_cwm = .false.: +! operator = f(T,P,q) +! 2) when l_wcp_cwm = .true. and CWM partition6: +! operator = f(ql,qr) partition6 +! +! input argument list: +! lwcphead +! rt - search direction for t +! rp - search direction for p +! rq - search direction for q +! rql - search direction for ql +! rqr - search direction for qr +! st - analysis increment for t +! sp - analysis increment for p +! sq - analysis increment for q +! sql - analysis increment for ql +! sqr - analysis increment for qr +! sges - stepsize estimates(4) +! nstep - number of stepsizes ( == 0 means use outer iteration values) +! +! output argument list: +! out(1:nstep) - contribution to penalty for precip. water sges(1:nstep) +! +! comments: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_quad + use qcmod, only: nlnqc_iter,varqc_iter + use constants, only: zero,half,one,two,tiny_r_kind,cg_term,zero_quad,& + r3600 + use gridmod, only: nsig + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use m_obsNode, only: obsNode + use m_lwcpNode , only: lwcpNode + use m_lwcpNode , only: lwcpNode_typecast + use m_lwcpNode , only: lwcpNode_nextcast + use obsmod, only: l_wcp_cwm + implicit none + +! Declare passed variables + class(obsNode), pointer ,intent(in ) :: lwcphead + integer(i_kind) ,intent(in ) :: nstep + real(r_quad),dimension(max(1,nstep)),intent(inout) :: out + type(gsi_bundle) ,intent(in ) :: rval,sval + real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges + +! Declare local variables + integer(i_kind) j,kk,ier,istatus + integer(i_kind),dimension(nsig):: i1,i2,i3,i4 + real(r_kind) val,val2,w1,w2,w3,w4,pg_lwcp + real(r_kind) cg_lwcp,wgross,wnotgross,lwcpx + real(r_kind),dimension(max(1,nstep))::pen + real(r_kind),pointer,dimension(:) :: st, sp, sq + real(r_kind),pointer,dimension(:) :: sql, sqr + real(r_kind),pointer,dimension(:) :: rt, rp, rq + real(r_kind),pointer,dimension(:) :: rql, rqr + real(r_kind) :: t_TL,p_TL,q_TL + real(r_kind) :: rt_TL,rp_TL,rq_TL + real(r_kind) :: ql_TL,qr_TL + real(r_kind) :: rql_TL,rqr_TL + + type(lwcpNode), pointer :: lwcpptr + + + out=zero_quad + +! If no lwcp data return + if(.not. associated(lwcphead))return + +! Retrieve pointers + ier=0 + + if (.not.l_wcp_cwm) then + + call gsi_bundlegetpointer(sval,'tsen',st,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'prse',sp,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'q' ,sq,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'tsen',rt,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'prse',rp,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'q' ,rq,istatus);ier=istatus+ier + !if (ier==0) write(6,*) 'STPLWCP (l_wcp_cwm = F)' + + else + + call gsi_bundlegetpointer(sval,'ql',sql,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qr',sqr,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'ql',rql,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qr',rqr,istatus);ier=istatus+ier + !if (ier==0) write(6,*) 'STPLWCP (l_wcp_cwm = T)' + + endif ! l_wcp_cwm + + if(ier/=0)return + + lwcpptr => lwcpNode_typecast(lwcphead) + do while (associated(lwcpptr)) + if(lwcpptr%luse)then + + val2=-lwcpptr%res + if(nstep > 0)then + w1 = lwcpptr%wij(1) + w2 = lwcpptr%wij(2) + w3 = lwcpptr%wij(3) + w4 = lwcpptr%wij(4) + + do j=1,nsig + i1(j)=lwcpptr%ij(1,j) + i2(j)=lwcpptr%ij(2,j) + i3(j)=lwcpptr%ij(3,j) + i4(j)=lwcpptr%ij(4,j) + enddo + + val=zero + +! Calculate liquid-water content path increment and delta lwcp increment + + if (.not.l_wcp_cwm) then + do j=1,nsig + t_TL =w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j)) + rt_TL=w1* rt(i1(j))+w2* rt(i2(j))+w3* rt(i3(j))+w4* rt(i4(j)) + p_TL =w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j)) + rp_TL=w1* rp(i1(j))+w2* rp(i2(j))+w3* rp(i3(j))+w4* rp(i4(j)) + q_TL =w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j)) + rq_TL=w1* rq(i1(j))+w2* rq(i2(j))+w3* rq(i3(j))+w4* rq(i4(j)) + val2 = val2 + t_tl*lwcpptr%jac_t(j)+ p_tl*lwcpptr%jac_p(j)+ q_tl*lwcpptr%jac_q(j) + val = val + rt_tl*lwcpptr%jac_t(j)+rp_tl*lwcpptr%jac_p(j)+rq_tl*lwcpptr%jac_q(j) + enddo + else + do j=1,nsig + ql_TL =w1* sql(i1(j))+w2* sql(i2(j))+w3* sql(i3(j))+w4* sql(i4(j)) + rql_TL=w1* rql(i1(j))+w2* rql(i2(j))+w3* rql(i3(j))+w4* rql(i4(j)) + qr_TL =w1* sqr(i1(j))+w2* sqr(i2(j))+w3* sqr(i3(j))+w4* sqr(i4(j)) + rqr_TL=w1* rqr(i1(j))+w2* rqr(i2(j))+w3* rqr(i3(j))+w4* rqr(i4(j)) + val2 = val2 + ql_tl*lwcpptr%jac_ql(j)+ qr_tl*lwcpptr%jac_qr(j) + val = val + rql_tl*lwcpptr%jac_ql(j)+ rqr_tl*lwcpptr%jac_qr(j) + enddo + endif ! l_wcp_cwm + + do kk=1,nstep + lwcpx=val2+sges(kk)*val + pen(kk)=lwcpx*lwcpx*lwcpptr%err2 + end do + + else + pen(1)=val2*val2*lwcpptr%err2 + end if + +! Modify penalty term if nonlinear QC + if (nlnqc_iter .and. lwcpptr%pg > tiny_r_kind .and. & + lwcpptr%b > tiny_r_kind) then + pg_lwcp=lwcpptr%pg*varqc_iter + cg_lwcp=cg_term/lwcpptr%b + wnotgross= one-pg_lwcp + wgross = pg_lwcp*cg_lwcp/wnotgross + do kk=1,max(1,nstep) + pen(kk) = -two*log((exp(-half*pen(kk)) + wgross)/(one+wgross)) + end do + endif + + out(1) = out(1)+pen(1)*lwcpptr%raterr2 + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*lwcpptr%raterr2 + end do + end if + + lwcpptr => lwcpNode_nextcast(lwcpptr) + + end do + return +end subroutine stplwcp + +end module stplwcpmod diff --git a/src/stpmitm.f90 b/src/gsi/stpmitm.f90 similarity index 100% rename from src/stpmitm.f90 rename to src/gsi/stpmitm.f90 diff --git a/src/stpmxtm.f90 b/src/gsi/stpmxtm.f90 similarity index 100% rename from src/stpmxtm.f90 rename to src/gsi/stpmxtm.f90 diff --git a/src/stpoz.f90 b/src/gsi/stpoz.f90 similarity index 83% rename from src/stpoz.f90 rename to src/gsi/stpoz.f90 index 89b344a08..010525c1c 100644 --- a/src/stpoz.f90 +++ b/src/gsi/stpoz.f90 @@ -16,11 +16,12 @@ module stpozmod ! 2010-05-13 todling - uniform interface across stp routines ! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting ! 2016-08-26 guo - added interfaces for individual obs-types (oz and o3l). +! 2018-07-27 guo - A single stpozmod module is splitted to stpozmod and stpo3lmod +! - Removed unused generic interfaces ! ! subroutines included: ! sub stpoz ! sub stpozlay_ -! sub stpozlev_ ! ! attributes: ! language: f90 @@ -31,78 +32,13 @@ module stpozmod implicit none PRIVATE -PUBLIC stpoz -public:: stpozlay_ ! Non-generic interfaces are needed for now, to allow -public:: stpozlev_ ! passing-by-reference involkations, such as - ! call stpoz(..,pbcjo(1,i_oz_ob_type,ib),..) - public:: stpozlay ! Generic interfaces are disirable, where full TKR -public:: stpozlev ! matching are required if they are involked, such as - ! call stpoz(..,pbcjo(:,i_oz_ob_type,ib),..) - - interface stpozlay; module procedure stpozlay_; end interface - interface stpozlev; module procedure stpozlev_; end interface + ! matching are required if they are involked, such as + ! call stpozlay(..,pbcjo(:,i_oz_ob_type,ib),..) contains -subroutine stpoz(ozhead,o3lhead,rval,sval,out,sges,nstep) -!$$$ subprogram documentation block -! . . . . -! subprogram: stpoz call components to calculate contrib. to -! penalty and stepsize for ozone -! prgmmr: sienkiewicz org: GMAO date: 2009-01-22 -! -! abstract: The routine calls individual components that calculate -! contribution to the penalty and step size from layer -! and level ozone measurements -! -! program history log: -! 2009-01-22 Sienkiewicz - incorporation of level ozone routine -! 2010-01-04 zhang,b - bug fix: accumulate penalty for multiple obs bins -! 2010-05-13 todling - udpate interface; gsi_bundle use -! -! input argument list: -! ozhead -! o3lhead -! roz - search direction for ozone -! soz - input ozone correction field -! sges - step size estimates (nstep) -! nstep- number of stepsize estimates (==0 means use outer iteration value) -! -! output argument list: -! out(1:nstep) - contribution of ozone data to penalty sges(1:nstep) -! -! attributes: -! language: f90 -! machine: -! -!$$$ - use kinds, only: r_kind,r_quad,i_kind - use m_obsNode, only: obsNode - use constants, only: zero_quad,zero - use gsi_bundlemod, only: gsi_bundle - implicit none - -! Declare passed variables - - class(obsNode), pointer ,intent(in ) :: ozhead - class(obsNode), pointer ,intent(in ) :: o3lhead - integer(i_kind) ,intent(in ) :: nstep - type(gsi_bundle) ,intent(in ) :: sval - type(gsi_bundle) ,intent(in ) :: rval - real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges - real(r_quad),dimension(max(1,nstep)),intent(inout) :: out - - out=zero_quad - - if(associated(ozhead))call stpozlay_(ozhead, rval,sval,out,sges,nstep) - if(associated(o3lhead))call stpozlev_(o3lhead,rval,sval,out,sges,nstep) - - return - -end subroutine stpoz - -subroutine stpozlay_(ozhead,rval,sval,out,sges,nstep) +subroutine stpozlay(ozhead,rval,sval,out,sges,nstep) !$$$ subprogram documentation block ! . . . . ! subprogram: stpoz compute contribution to penalty and @@ -349,9 +285,43 @@ subroutine stpozlay_(ozhead,rval,sval,out,sges,nstep) ! End of routine. return -end subroutine stpozlay_ +end subroutine stpozlay +end module stpozmod + +module stpo3lmod + +!$$$ module documentation block +! . . . . +! module: stpo3lmod module for stpoz and its tangent linear stpoz_tl +! prgmmr: +! +! abstract: module for stpoz and its tangent linear stpoz_tl +! +! program history log: +! 2018-07-13 J. Guo - splitted from original module stpozmod into this stpo3lmod +! with subroutine stpozlev(). See stpozmod for more +! about earlier history logs. +! +! subroutines included: +! sub stpoz +! sub stpozlev +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none + +PRIVATE +public:: stpozlev ! Generic interfaces are disirable, where full TKR + ! matching are required if they are involked, such as + ! call stpozlev(..,pbcjo(:,i_oz_ob_type,ib),..) + +contains -subroutine stpozlev_(o3lhead,rval,sval,out,sges,nstep) +subroutine stpozlev(o3lhead,rval,sval,out,sges,nstep) !$$$ subprogram documentation block ! . . . . ! subprogram: stpozlev compute contribution to penalty and @@ -469,6 +439,6 @@ subroutine stpozlev_(o3lhead,rval,sval,out,sges,nstep) ! End of routine. return -end subroutine stpozlev_ +end subroutine stpozlev -end module stpozmod +end module stpo3lmod diff --git a/src/stppblh.f90 b/src/gsi/stppblh.f90 similarity index 100% rename from src/stppblh.f90 rename to src/gsi/stppblh.f90 diff --git a/src/stppcp.f90 b/src/gsi/stppcp.f90 similarity index 100% rename from src/stppcp.f90 rename to src/gsi/stppcp.f90 diff --git a/src/stppm10.f90 b/src/gsi/stppm10.f90 similarity index 100% rename from src/stppm10.f90 rename to src/gsi/stppm10.f90 diff --git a/src/stppm2_5.f90 b/src/gsi/stppm2_5.f90 similarity index 100% rename from src/stppm2_5.f90 rename to src/gsi/stppm2_5.f90 diff --git a/src/stppmsl.f90 b/src/gsi/stppmsl.f90 similarity index 100% rename from src/stppmsl.f90 rename to src/gsi/stppmsl.f90 diff --git a/src/stpps.f90 b/src/gsi/stpps.f90 similarity index 100% rename from src/stpps.f90 rename to src/gsi/stpps.f90 diff --git a/src/stppw.f90 b/src/gsi/stppw.f90 similarity index 100% rename from src/stppw.f90 rename to src/gsi/stppw.f90 diff --git a/src/stpq.f90 b/src/gsi/stpq.f90 similarity index 100% rename from src/stpq.f90 rename to src/gsi/stpq.f90 diff --git a/src/stprad.f90 b/src/gsi/stprad.f90 similarity index 90% rename from src/stprad.f90 rename to src/gsi/stprad.f90 index c50d6613c..49046d09a 100644 --- a/src/stprad.f90 +++ b/src/gsi/stprad.f90 @@ -70,6 +70,7 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) ! 2011-05-16 todling - generalize entries in radiance jacobian ! 2011-05-17 augline/todling - add hydrometeors ! 2016-07-19 kbathmann- adjustment to bias correction when using correlated obs +! 2019-08-14 W. Gu/guo- speed up bias correction term in the case of the correlated obs ! ! input argument list: ! radhead @@ -128,18 +129,19 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) ! Declare local variables integer(i_kind) istatus - integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk, mm, ic1 + integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk, mm, ic1,ncr real(r_kind) val2,val,w1,w2,w3,w4 real(r_kind),dimension(nsigradjac):: tdir,rdir real(r_kind) cg_rad,wgross,wnotgross integer(i_kind),dimension(nsig) :: j1n,j2n,j3n,j4n real(r_kind),dimension(max(1,nstep)) :: term,rad type(radNode), pointer :: radptr - real(r_kind), dimension(:,:), allocatable:: rsqrtinv - integer(i_kind) :: chan_count, ii, jj + real(r_kind),allocatable,dimension(:) :: biasvects + real(r_kind),allocatable,dimension(:) :: biasvectr real(r_kind),pointer,dimension(:) :: rt,rq,rcw,roz,ru,rv,rqg,rqh,rqi,rql,rqr,rqs real(r_kind),pointer,dimension(:) :: st,sq,scw,soz,su,sv,sqg,sqh,sqi,sql,sqr,sqs real(r_kind),pointer,dimension(:) :: rst,sst + real(r_quad) :: valr_quad,vals_quad out=zero_quad @@ -194,17 +196,6 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) w3=radptr%wij(3) w4=radptr%wij(4) if(luseu)then - if (radptr%use_corr_obs) then - allocate(rsqrtinv(radptr%nchan,radptr%nchan)) - chan_count=0 - do ii=1,radptr%nchan - do jj=ii,radptr%nchan - chan_count=chan_count+1 - rsqrtinv(ii,jj)=radptr%rsqrtinv(chan_count) - rsqrtinv(jj,ii)=radptr%rsqrtinv(chan_count) - end do - end do - end if tdir(ius+1)=w1* su(j1) + w2* su(j2) + w3* su(j3) + w4* su(j4) rdir(ius+1)=w1* ru(j1) + w2* ru(j2) + w3* ru(j3) + w4* ru(j4) endif @@ -279,6 +270,24 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) end do end if + + if(nstep > 0)then + allocate(biasvects(radptr%nchan)) + allocate(biasvectr(radptr%nchan)) + do nn=1,radptr%nchan + ic1=radptr%icx(nn) + vals_quad = zero_quad + valr_quad = zero_quad + do nx=1,npred + vals_quad = vals_quad + spred(nx,ic1)*radptr%pred(nx,nn) + valr_quad = valr_quad + rpred(nx,ic1)*radptr%pred(nx,nn) + end do + biasvects(nn) = vals_quad + biasvectr(nn) = valr_quad + end do + endif + + ncr=0 do nn=1,radptr%nchan val2=-radptr%res(nn) @@ -287,18 +296,16 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) val = zero ! contribution from bias corection ic=radptr%icx(nn) - do nx=1,npred - if (radptr%use_corr_obs) then - do mm=1,radptr%nchan - ic1=radptr%icx(mm) - val2=val2+spred(nx,ic1)*rsqrtinv(nn,mm)*radptr%pred(nx,mm) - val=val+rpred(nx,ic1)*rsqrtinv(nn,mm)*radptr%pred(nx,mm) - end do - else - val2=val2+spred(nx,ic)*radptr%pred(nx,nn) - val =val +rpred(nx,ic)*radptr%pred(nx,nn) - end if - end do + if(radptr%use_corr_obs) then + do mm=1,nn + ncr=ncr+1 + val2=val2+radptr%rsqrtinv(ncr)*biasvects(mm) + val =val +radptr%rsqrtinv(ncr)*biasvectr(mm) + end do + else + val2=val2+biasvects(nn) + val =val +biasvectr(nn) + end if ! contribution from atmosphere do k=1,nsigradjac @@ -336,7 +343,8 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) end do end do - if (radptr%use_corr_obs) deallocate(rsqrtinv) + + if(nstep > 0) deallocate(biasvects, biasvectr) end if diff --git a/src/stprw.f90 b/src/gsi/stprw.f90 similarity index 97% rename from src/stprw.f90 rename to src/gsi/stprw.f90 index 7e031d12e..710d9baa2 100644 --- a/src/stprw.f90 +++ b/src/gsi/stprw.f90 @@ -51,11 +51,14 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep) ! 2007-03-19 tremolet - binning of observations ! 2007-07-28 derber - modify to use new inner loop obs data structure ! - unify NL qc +! 2007-02-15 rancic - add foto ! 2007-06-04 derber - use quad precision to get reproducability over number of processors ! 2008-06-02 safford - rm unused var and uses ! 2008-12-03 todling - changed handling of ptr%time ! 2010-01-04 zhang,b - bug fix: accumulate penalty for multiple obs bins ! 2010-05-13 todling - update to use gsi_bundle +! 2017-05-12 Y. Wang and X. Wang - include w into adjoint of rw operator, +! POC: xuguang.wang@ou.edu ! 2016-06-23 lippi - add terms for vertical velocity, uses include_w, and ! now multiplying by costilt here instead of being ! factored into the wij term. @@ -88,6 +91,7 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep) use m_rwNode , only: rwNode use m_rwNode , only: rwNode_typecast use m_rwNode , only: rwNode_nextcast + implicit none ! Declare passed variables diff --git a/src/stpspd.f90 b/src/gsi/stpspd.f90 similarity index 100% rename from src/stpspd.f90 rename to src/gsi/stpspd.f90 diff --git a/src/stpsst.f90 b/src/gsi/stpsst.f90 similarity index 100% rename from src/stpsst.f90 rename to src/gsi/stpsst.f90 diff --git a/src/gsi/stpswcp.f90 b/src/gsi/stpswcp.f90 new file mode 100644 index 000000000..18ac95134 --- /dev/null +++ b/src/gsi/stpswcp.f90 @@ -0,0 +1,231 @@ +module stpswcpmod + +!$$$ module documentation block +! . . . . +! module: stpswcpmod module for stpswcp and its tangent linear stpswcp_tl +! prgmmr: +! +! abstract: module for stpswcp and its tangent linear stpswcp_tl +! +! program history log: +! +! subroutines included: +! sub stpswcp +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none + +PRIVATE +PUBLIC stpswcp + +contains + +subroutine stpswcp(swcphead,rval,sval,out,sges,nstep) +!$$$ subprogram documentation block +! . . . . +! subprogram: stpswcp calculate penalty and contribution to stepsize +! for swcp using nonlinear qc +! prgmmr: Ting-Chi Wu org: CIRA/CSU date: 2017-06-28 +! +! abstract: calculate penalty and contribution to stepsize from swcp +! using nonlinear qc. +! +! program history log: +! 2017-06-28 Ting-Chi Wu - mimic the structure in stppw.f90 and stpgps.f90 +! - stpswcp.f90 includes 2 stp options +! 1) when l_wcp_cwm = .false.: +! operator = f(T,P,q) +! 2) when l_wcp_cwm = .true. and CWM partition6: +! operator = f(qi,qs,qg,qh) partition6 +! +! input argument list: +! swcphead +! rt - search direction for t +! rp - search direction for p +! rq - search direction for q +! rqi - search direction for qi +! rqs - search direction for qs +! rqg - search direction for qg +! rqh - search direction for qh +! st - analysis increment for t +! sp - analysis increment for p +! sq - analysis increment for q +! sqi - analysis increment for qi +! sqs - analysis increment for qs +! sqg - analysis increment for qg +! sqh - analysis increment for qh +! sges - stepsize estimates(4) +! nstep - number of stepsizes ( == 0 means use outer iteration values) +! +! output argument list: +! out(1:nstep) - contribution to penalty for precip. water sges(1:nstep) +! +! comments: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_quad + use qcmod, only: nlnqc_iter,varqc_iter + use constants, only: zero,half,one,two,tiny_r_kind,cg_term,zero_quad,& + r3600 + use gridmod, only: nsig + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use m_obsNode, only: obsNode + use m_swcpNode , only: swcpNode + use m_swcpNode , only: swcpNode_typecast + use m_swcpNode , only: swcpNode_nextcast + use obsmod, only: l_wcp_cwm + implicit none + +! Declare passed variables + class(obsNode), pointer ,intent(in ) :: swcphead + integer(i_kind) ,intent(in ) :: nstep + real(r_quad),dimension(max(1,nstep)),intent(inout) :: out + type(gsi_bundle) ,intent(in ) :: rval,sval + real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges + +! Declare local variables + integer(i_kind) j,kk,ier,istatus + integer(i_kind),dimension(nsig):: i1,i2,i3,i4 + real(r_kind) val,val2,w1,w2,w3,w4,pg_swcp + real(r_kind) cg_swcp,wgross,wnotgross,swcpx + real(r_kind),dimension(max(1,nstep))::pen + real(r_kind),pointer,dimension(:) :: st, sp, sq + real(r_kind),pointer,dimension(:) :: sqi, sqs, sqg, sqh + real(r_kind),pointer,dimension(:) :: rt, rp, rq + real(r_kind),pointer,dimension(:) :: rqi, rqs, rqg, rqh + real(r_kind) :: t_TL,p_TL,q_TL + real(r_kind) :: rt_TL,rp_TL,rq_TL + real(r_kind) :: qi_TL,qs_TL,qg_TL,qh_TL + real(r_kind) :: rqi_TL,rqs_TL,rqg_TL,rqh_TL + + type(swcpNode), pointer :: swcpptr + + + out=zero_quad + +! If no swcp data return + if(.not. associated(swcphead))return + +! Retrieve pointers + ier=0 + + if (.not.l_wcp_cwm) then + + call gsi_bundlegetpointer(sval,'tsen',st,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'prse',sp,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'q' ,sq,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'tsen',rt,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'prse',rp,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'q' ,rq,istatus);ier=istatus+ier + !if (ier==0) write(6,*) 'STPSWCP (l_wcp_cwm = F)' + + else + + call gsi_bundlegetpointer(sval,'qi',sqi,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qs',sqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qg',sqg,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'qh',sqh,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qi',rqi,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qs',rqs,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qg',rqg,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'qh',rqh,istatus);ier=istatus+ier + !if (ier==0) write(6,*) 'STPSWCP (l_wcp_cwm = T)' + + endif ! l_wcp_cwm + + if(ier/=0)return + + swcpptr => swcpNode_typecast(swcphead) + do while (associated(swcpptr)) + if(swcpptr%luse)then + + val2=-swcpptr%res + if(nstep > 0)then + + do j=1,nsig + i1(j)=swcpptr%ij(1,j) + i2(j)=swcpptr%ij(2,j) + i3(j)=swcpptr%ij(3,j) + i4(j)=swcpptr%ij(4,j) + enddo + w1 = swcpptr%wij(1) + w2 = swcpptr%wij(2) + w3 = swcpptr%wij(3) + w4 = swcpptr%wij(4) + + val=zero + +! Calculate solid-water content path increment and delta swcp increment + + if (.not.l_wcp_cwm) then + do j=1,nsig + t_TL =w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j)) + rt_TL =w1* rt(i1(j))+w2* rt(i2(j))+w3* rt(i3(j))+w4* rt(i4(j)) + p_TL =w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j)) + rp_TL =w1* rp(i1(j))+w2* rp(i2(j))+w3* rp(i3(j))+w4* rp(i4(j)) + q_TL =w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j)) + rq_TL =w1* rq(i1(j))+w2* rq(i2(j))+w3* rq(i3(j))+w4* rq(i4(j)) + val2 = val2 + t_tl*swcpptr%jac_t(j)+ p_tl*swcpptr%jac_p(j)+ q_tl*swcpptr%jac_q(j) + val = val + rt_tl*swcpptr%jac_t(j)+rp_tl*swcpptr%jac_p(j)+rq_tl*swcpptr%jac_q(j) + enddo + else + do j=1,nsig + qi_TL =w1* sqi(i1(j))+w2* sqi(i2(j))+w3* sqi(i3(j))+w4* sqi(i4(j)) + rqi_TL =w1* rqi(i1(j))+w2* rqi(i2(j))+w3* rqi(i3(j))+w4* rqi(i4(j)) + qs_TL =w1* sqs(i1(j))+w2* sqs(i2(j))+w3* sqs(i3(j))+w4* sqs(i4(j)) + rqs_TL =w1* rqs(i1(j))+w2* rqs(i2(j))+w3* rqs(i3(j))+w4* rqs(i4(j)) + qg_TL =w1* sqg(i1(j))+w2* sqg(i2(j))+w3* sqg(i3(j))+w4* sqg(i4(j)) + rqg_TL =w1* rqg(i1(j))+w2* rqg(i2(j))+w3* rqg(i3(j))+w4* rqg(i4(j)) + qh_TL =w1* sqh(i1(j))+w2* sqh(i2(j))+w3* sqh(i3(j))+w4* sqh(i4(j)) + rqh_TL =w1* rqh(i1(j))+w2* rqh(i2(j))+w3* rqh(i3(j))+w4* rqh(i4(j)) + val2 = val2 + qi_tl*swcpptr%jac_qi(j)+ qs_tl*swcpptr%jac_qs(j) & + + qg_tl*swcpptr%jac_qg(j)+ qh_tl*swcpptr%jac_qh(j) + val = val + rqi_tl*swcpptr%jac_qi(j)+ rqs_tl*swcpptr%jac_qs(j) & + + rqg_tl*swcpptr%jac_qg(j)+ rqh_tl*swcpptr%jac_qh(j) + enddo + endif ! l_wcp_cwm + + do kk=1,nstep + swcpx=val2+sges(kk)*val + pen(kk)=swcpx*swcpx*swcpptr%err2 + end do + + else + pen(1)=val2*val2*swcpptr%err2 + end if + +! Modify penalty term if nonlinear QC + if (nlnqc_iter .and. swcpptr%pg > tiny_r_kind .and. & + swcpptr%b > tiny_r_kind) then + pg_swcp=swcpptr%pg*varqc_iter + cg_swcp=cg_term/swcpptr%b + wnotgross= one-pg_swcp + wgross = pg_swcp*cg_swcp/wnotgross + do kk=1,max(1,nstep) + pen(kk) = -two*log((exp(-half*pen(kk)) + wgross)/(one+wgross)) + end do + endif + + out(1) = out(1)+pen(1)*swcpptr%raterr2 + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*swcpptr%raterr2 + end do + end if + + swcpptr => swcpNode_nextcast(swcpptr) + + end do + return +end subroutine stpswcp + +end module stpswcpmod diff --git a/src/stpt.f90 b/src/gsi/stpt.f90 similarity index 100% rename from src/stpt.f90 rename to src/gsi/stpt.f90 diff --git a/src/stptcamt.f90 b/src/gsi/stptcamt.f90 similarity index 100% rename from src/stptcamt.f90 rename to src/gsi/stptcamt.f90 diff --git a/src/stptcp.f90 b/src/gsi/stptcp.f90 similarity index 100% rename from src/stptcp.f90 rename to src/gsi/stptcp.f90 diff --git a/src/stptd2m.f90 b/src/gsi/stptd2m.f90 similarity index 100% rename from src/stptd2m.f90 rename to src/gsi/stptd2m.f90 diff --git a/src/stpuwnd10m.f90 b/src/gsi/stpuwnd10m.f90 similarity index 100% rename from src/stpuwnd10m.f90 rename to src/gsi/stpuwnd10m.f90 diff --git a/src/stpvis.f90 b/src/gsi/stpvis.f90 similarity index 100% rename from src/stpvis.f90 rename to src/gsi/stpvis.f90 diff --git a/src/stpvwnd10m.f90 b/src/gsi/stpvwnd10m.f90 similarity index 100% rename from src/stpvwnd10m.f90 rename to src/gsi/stpvwnd10m.f90 diff --git a/src/stpw.f90 b/src/gsi/stpw.f90 similarity index 100% rename from src/stpw.f90 rename to src/gsi/stpw.f90 diff --git a/src/stpwspd10m.f90 b/src/gsi/stpwspd10m.f90 similarity index 100% rename from src/stpwspd10m.f90 rename to src/gsi/stpwspd10m.f90 diff --git a/src/strong_bal_correction.f90 b/src/gsi/strong_bal_correction.f90 similarity index 100% rename from src/strong_bal_correction.f90 rename to src/gsi/strong_bal_correction.f90 diff --git a/src/strong_baldiag_inc.f90 b/src/gsi/strong_baldiag_inc.f90 similarity index 100% rename from src/strong_baldiag_inc.f90 rename to src/gsi/strong_baldiag_inc.f90 diff --git a/src/strong_fast_global_mod.f90 b/src/gsi/strong_fast_global_mod.f90 similarity index 100% rename from src/strong_fast_global_mod.f90 rename to src/gsi/strong_fast_global_mod.f90 diff --git a/src/gsi/stub_ensmod.f90 b/src/gsi/stub_ensmod.f90 new file mode 100644 index 000000000..d3b474e2e --- /dev/null +++ b/src/gsi/stub_ensmod.f90 @@ -0,0 +1,177 @@ +module stub_ensmod +!---------------------------------------------------------------------------- +!BOP +! +! !MODULE: GSI_EnsCouplerMod --- +! +! !DESCRIPTION: This stub provides the default interfaces to read an +! ensemble in GSI. +! +! !REVISION HISTORY: +! +! 19Sep2011 Todling - Initial code +! 01Dec2011 Todling - Add put_gsi_ens to allow write out of internal members +! 30Nov2014 Todling - Update interface to get (bundle passed in) +! 30Jun2019 Todling - Revamp in light of abstract layer +! +! !REMARKS: +! 1. Unlike the previous version of this stub, the correct version should +! always be loaded as part of the library - there is not need to remove +! this from the library. +! +!EOP +!------------------------------------------------------------------------- + + use abstract_ensmod, only: abstractEnsemble + implicit none + private + public :: ensemble + public :: ensemble_typemold + + type, extends(abstractEnsemble) :: ensemble + private + contains + procedure,nopass:: mytype + procedure :: get_user_ens + procedure :: get_user_Nens + procedure,nopass:: create_sub2grid_info + procedure,nopass:: destroy_sub2grid_info + procedure :: put_user_ens + procedure :: non_gaussian_ens_grid + end type ensemble + + character(len=*),parameter:: myname ="stub_ensmod" + type(ensemble),target:: mold_ + +contains + + function ensemble_typemold() result(typemold) +!-- return a mold for this application + implicit none + type(ensemble),pointer:: typemold + typemold => mold_ + end function ensemble_typemold + + function mytype() + implicit none + character(len=:), allocatable:: mytype + mytype="["//myname//"::ensemble]" + end function mytype + + subroutine get_user_ens(this,grd,member,ntindex,atm_bundle,iret) + + use kinds, only: i_kind + use general_sub2grid_mod, only: sub2grid_info + use gsi_bundlemod, only: gsi_bundle + + implicit none + + ! Declare passed variables + class(ensemble), intent(inout) :: this + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(in ) :: member + integer(i_kind), intent(in ) :: ntindex + type(gsi_bundle), intent(inout) :: atm_bundle + integer(i_kind), intent( out) :: iret +! associate( this => this ) ! eliminates warning for unused dummy argument needed for binding +! end associate + iret = 0 + + return + + end subroutine get_user_ens + + subroutine get_user_Nens(this,grd,members,ntindex,atm_bundle,iret) + + use kinds, only: i_kind + use general_sub2grid_mod, only: sub2grid_info + use gsi_bundlemod, only: gsi_bundle + + implicit none + + ! Declare passed variables + class(ensemble), intent(inout) :: this + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(in ) :: members + integer(i_kind), intent(in ) :: ntindex + type(gsi_bundle), intent(inout) :: atm_bundle(:) + integer(i_kind), intent( out) :: iret +!! associate( this => this ) ! eliminates warning for unused dummy argument needed for binding +!! end associate + iret = 0 + + return + + end subroutine get_user_Nens + + subroutine create_sub2grid_info(s2gi,nsig,npe,s2gi_ref) + use kinds, only: i_kind + use general_sub2grid_mod, only: sub2grid_info + implicit none + + ! Declare passed variables + type(sub2grid_info), intent(out ) :: s2gi + integer(i_kind), intent(in ) :: nsig + integer(i_kind), intent(in ) :: npe + type(sub2grid_info), intent(in ) :: s2gi_ref + + ! This is a simple copy + s2gi = s2gi_ref + + return + end subroutine create_sub2grid_info + + subroutine destroy_sub2grid_info(s2gi) + use general_sub2grid_mod, only: sub2grid_info + implicit none + + ! Declare passed variables + type(sub2grid_info), intent(inout) :: s2gi + + ! Reset the variable to a different memory location, so any original target + ! won't be accessed anymore. + + s2gi = sub2grid_info() + return + end subroutine destroy_sub2grid_info + + subroutine put_user_ens(this,grd,member,ntindex,pert,iret) + + use kinds, only: i_kind + use general_sub2grid_mod, only: sub2grid_info + use gsi_bundlemod, only: gsi_bundle + + implicit none + ! Declare passed variables + class(ensemble), intent(inout) :: this + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(in ) :: member + integer(i_kind), intent(in ) :: ntindex + type(gsi_bundle), intent(inout) :: pert + integer(i_kind), intent( out) :: iret + +! associate( this => this ) ! eliminates warning for unused dummy argument needed for binding +! end associate + iret = 0 + return + end subroutine put_user_ens + + subroutine non_gaussian_ens_grid(this,elats,elons) + + use kinds, only: r_kind + use hybrid_ensemble_parameters, only: sp_ens + implicit none + ! Declare passed variables + class(ensemble), intent(inout) :: this + real(r_kind), intent(out) :: elats(:),elons(:) +! real(r_kind), intent(out) :: elats(size(sp_ens%rlats)),elons(size(sp_ens%rlons)) + + elats=sp_ens%rlats + elons=sp_ens%rlons +!! associate( this => this ) ! eliminates warning for unused dummy argument needed for binding +!! end associate + + return + end subroutine non_gaussian_ens_grid + +end module stub_ensmod diff --git a/src/stub_get_pseudo_ensperts.f90 b/src/gsi/stub_get_pseudo_ensperts.f90 similarity index 100% rename from src/stub_get_pseudo_ensperts.f90 rename to src/gsi/stub_get_pseudo_ensperts.f90 diff --git a/src/stub_get_wrf_mass_ensperts.f90 b/src/gsi/stub_get_wrf_mass_ensperts.f90 similarity index 100% rename from src/stub_get_wrf_mass_ensperts.f90 rename to src/gsi/stub_get_wrf_mass_ensperts.f90 diff --git a/src/stub_get_wrf_nmm_ensperts.f90 b/src/gsi/stub_get_wrf_nmm_ensperts.f90 similarity index 100% rename from src/stub_get_wrf_nmm_ensperts.f90 rename to src/gsi/stub_get_wrf_nmm_ensperts.f90 diff --git a/src/stub_nstmod.f90 b/src/gsi/stub_nstmod.f90 similarity index 100% rename from src/stub_nstmod.f90 rename to src/gsi/stub_nstmod.f90 diff --git a/src/stub_pertmod.F90 b/src/gsi/stub_pertmod.F90 similarity index 100% rename from src/stub_pertmod.F90 rename to src/gsi/stub_pertmod.F90 diff --git a/src/stub_read_wrf_mass_files.f90 b/src/gsi/stub_read_wrf_mass_files.f90 similarity index 100% rename from src/stub_read_wrf_mass_files.f90 rename to src/gsi/stub_read_wrf_mass_files.f90 diff --git a/src/stub_read_wrf_mass_guess.f90 b/src/gsi/stub_read_wrf_mass_guess.f90 similarity index 100% rename from src/stub_read_wrf_mass_guess.f90 rename to src/gsi/stub_read_wrf_mass_guess.f90 diff --git a/src/stub_read_wrf_nmm_files.f90 b/src/gsi/stub_read_wrf_nmm_files.f90 similarity index 100% rename from src/stub_read_wrf_nmm_files.f90 rename to src/gsi/stub_read_wrf_nmm_files.f90 diff --git a/src/stub_read_wrf_nmm_guess.f90 b/src/gsi/stub_read_wrf_nmm_guess.f90 similarity index 100% rename from src/stub_read_wrf_nmm_guess.f90 rename to src/gsi/stub_read_wrf_nmm_guess.f90 diff --git a/src/stub_regional_io.f90 b/src/gsi/stub_regional_io.f90 similarity index 85% rename from src/stub_regional_io.f90 rename to src/gsi/stub_regional_io.f90 index c1bc9a451..64af45683 100644 --- a/src/stub_regional_io.f90 +++ b/src/gsi/stub_regional_io.f90 @@ -30,11 +30,13 @@ module regional_io_mod procedure, pass(this) :: convert_regional_guess => convert_regional_guess_dummy end type regional_io_class +logical,parameter:: VERBOSE=.false. +!logical,parameter:: VERBOSE=.true. contains subroutine init_regional_io_dummy(this) implicit none class(regional_io_class), intent(inout) :: this - write(6,*) 'DUMMY CALL to init_regional_io' + if(VERBOSE) write(6,*) 'DUMMY CALL to init_regional_io' return end subroutine init_regional_io_dummy @@ -43,7 +45,7 @@ subroutine write_regional_analysis_dummy(this,mype) implicit none class(regional_io_class), intent(inout) :: this integer(i_kind),intent(in):: mype - write(6,*) 'DUMMY CALL to write_regional_analysis' + if(VERBOSE) write(6,*) 'DUMMY CALL to write_regional_analysis' return end subroutine write_regional_analysis_dummy @@ -53,7 +55,10 @@ subroutine convert_regional_guess_dummy(this,mype,ctph0,stph0,tlm0) class(regional_io_class), intent(inout) :: this integer(i_kind),intent(in ) :: mype real(r_kind) ,intent( out) :: ctph0,stph0,tlm0 - write(6,*) 'DUMMY CALL to convert_regional_guess' + ctph0 = 0.0_r_kind + stph0 = 0.0_r_kind + tlm0 = 0.0_r_kind + if(VERBOSE) write(6,*) 'DUMMY CALL to convert_regional_guess' return end subroutine convert_regional_guess_dummy diff --git a/src/stub_wrf_binary_interface.f90 b/src/gsi/stub_wrf_binary_interface.f90 similarity index 100% rename from src/stub_wrf_binary_interface.f90 rename to src/gsi/stub_wrf_binary_interface.f90 diff --git a/src/stub_wrf_netcdf_interface.f90 b/src/gsi/stub_wrf_netcdf_interface.f90 similarity index 100% rename from src/stub_wrf_netcdf_interface.f90 rename to src/gsi/stub_wrf_netcdf_interface.f90 diff --git a/src/stub_wrwrfmassa.f90 b/src/gsi/stub_wrwrfmassa.f90 similarity index 100% rename from src/stub_wrwrfmassa.f90 rename to src/gsi/stub_wrwrfmassa.f90 diff --git a/src/stub_wrwrfnmma.f90 b/src/gsi/stub_wrwrfnmma.f90 similarity index 100% rename from src/stub_wrwrfnmma.f90 rename to src/gsi/stub_wrwrfnmma.f90 diff --git a/src/sub2fslab_mod.f90 b/src/gsi/sub2fslab_mod.f90 similarity index 100% rename from src/sub2fslab_mod.f90 rename to src/gsi/sub2fslab_mod.f90 diff --git a/src/gsi/sumslightbias.f90 b/src/gsi/sumslightbias.f90 new file mode 100644 index 000000000..80ea95216 --- /dev/null +++ b/src/gsi/sumslightbias.f90 @@ -0,0 +1,99 @@ +subroutine sumslightbias(dlight,lightges0,mype,nobs,nobs_loc,sum_loc) +!$$$ subprogram documentation block +! . . . . +! subprogram: sumslightbias calculation of variance in parallel (MPI). + +! prgmmr: k apodaca +! org: CSU/CIRA, Data Assimilation Group +! date: 2016-09-08 +! +! abstract: This subroutine computes a local summation and the number of +! observations assigned to a given mpi task (geographic region). +! +! The former calculations are used as input in the bias correction +! procedure applied to the nonlinear observation operator for +! lightning flash rate, which is included in the "setuprhsall.f90" +! subroutine. +! +! program history log: +! 2016-09-08 apodaca - first version of sumslightbias +! +!--- +! +! input argument list: +! eps0 - guess value of lightning flash rate +! mype - mpi task id +! +! output argument list: +! sum_loc - array containing the summation, over all observations, of +! the logarithmic transformation of the observed lightning +! flash rate, divided by the forward model of lightning +! flash rate. +! +! nobs_loc - number of observations per given mpi task (CPU) +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! + use kinds, only: r_kind,r_single,r_double,i_kind + use constants, only: zero + implicit none + +! Declare local variables + + real(r_kind) :: dlight + real(r_kind) :: eps0 + real(r_kind) :: lightges0 + integer(i_kind) :: i,nobs + integer(i_kind),intent(inout) :: nobs_loc,mype + real(r_kind),intent(out) :: sum_loc + +! File(s) for postprocessing + character :: post_file*40 + + +!--- +! Online bias correction, as in Apodaca et al. (2014); +! eps = eps0 * exp[ (1/nobs) * sum(log(y/(eps0*h(x)))) / (1+r0/w0)] + +! In this program, sum(log(y/(eps0*h(x)))) and the commulative count +! of lightning observations are calculated (nobs_loc). + + +!-- set initial bias parameter values + + eps0=1._r_kind + + sum_loc=zero + nobs_loc=zero + +!-- save sums here +!-- for each i there is an associated error(i), lightges0(i), and dlight(i) +!-- Step 1: Estimate sums + + +! Open file with lightning output for local sums + + write(post_file,199)mype +199 format('sums_lfr_',i3.3,'.bin') + open(unit=200,file=trim(post_file),form='formatted',action='read') + + do i=1,nobs + + read(200,*)nobs_loc,dlight,lightges0 + + nobs=nobs_loc + + if(((eps0*lightges0) > 0_r_kind).and.(lightges0 > 0_r_kind).and.(dlight >0_r_kind)) then + + nobs_loc=nobs_loc+1 + sum_loc=sum_loc+log(dlight/(eps0*lightges0)) + + endif + + enddo + +close(unit=200) + +end subroutine sumslightbias diff --git a/src/support_2dvar.f90 b/src/gsi/support_2dvar.f90 similarity index 90% rename from src/support_2dvar.f90 rename to src/gsi/support_2dvar.f90 index 057ba0476..a7506256c 100644 --- a/src/support_2dvar.f90 +++ b/src/gsi/support_2dvar.f90 @@ -43,6 +43,7 @@ subroutine convert_binary_2d use gsi_4dvar, only: nhr_assimilation use gsi_io, only: lendian_out,verbose use mpeu_util, only: die + use qcmod, only: vis_thres,cldch_thres implicit none ! Declare local parameters @@ -55,6 +56,7 @@ subroutine convert_binary_2d integer(i_kind) in_unit,status_hdr integer(i_kind) hdrbuf(512) integer(i_kind) n + integer(i_kind) i,j integer(i_kind) iyear,imonth,iday,ihour,iminute,isecond integer(i_kind) nlon_regional,nlat_regional,nsig_regional @@ -309,7 +311,18 @@ subroutine convert_binary_2d end if write(lendian_out)field2 +! read(in_unit)field2 ! VIS +!........................................................... +!NLTR: apply threshold vis_thres to visibility first guess +!........................................................... + + do j=1,nlon_regional + do i=1,nlat_regional + if (field2(j,i) <= 0.0_r_single) field2(j,i)=one_single + if (field2(j,i) >= vis_thres) field2(j,i)=vis_thres + enddo + enddo if(print_verbose)then write(6,*)' convert_binary_2d: max,min VIS=',maxval(field2),minval(field2) write(6,*)' convert_binary_2d: mid VIS=',field2(nlon_regional/2,nlat_regional/2) @@ -324,6 +337,15 @@ subroutine convert_binary_2d write(lendian_out)field2 read(in_unit)field2 ! CLDCH +!........................................................... +!NLTR: apply threshold cldch_thres to cldch first guess +!........................................................... + do j=1,nlon_regional + do i=1,nlat_regional + if (field2(j,i) <= 0.0_r_single) field2(j,i)=one_single + if (field2(j,i) > cldch_thres) field2(j,i)=cldch_thres + enddo + enddo if(print_verbose)then write(6,*)' convert_binary_2d: max,min CLDCH=',maxval(field2),minval(field2) write(6,*)' convert_binary_2d: mid CLDCH=',field2(nlon_regional/2,nlat_regional/2) @@ -513,12 +535,11 @@ subroutine read_2d_files(mype) nming2=nmings ndiff=nming2-nminanl write(6,*)'READ_2d_FILES: sigma guess file time in minutes',nming2 - if(abs(ndiff) > 60*nhr_half ) go to 110 + if(abs(ndiff) > 60*nhr_half ) cycle iwan=iwan+1 time_ges(iwan) = (nming2-nminanl)*r60inv + time_offset time_ges(iwan+100)=i+r0_001 end if -110 continue end do write(6,*)'READ_2d_FILES:iwan=',iwan,(time_ges(i),i=1,iwan) time_ges(201)=one @@ -621,6 +642,7 @@ subroutine read_2d_guess(mype) ! 2014-06-16 carley/zhu - add tcamt and ceiling ! 2015-07-10 pondeca - add cloud ceiling height ! 2016-05-03 pondeca - add uwnd10m, vwnd10m +! 2018-01-xx yang - test the method of nonlinear transform ! ! input argument list: ! mype - pe number @@ -643,6 +665,9 @@ subroutine read_2d_guess(mype) use gsi_bundlemod, only: gsi_bundlegetpointer use mpeu_util, only: die use gsi_io, only: verbose + use qcmod, only: pvis,pcldch,scale_cv + use nltransf, only: nltransf_forward + implicit none ! Declare passed variables @@ -653,6 +678,7 @@ subroutine read_2d_guess(mype) ! Declare local variables integer(i_kind) kt,kq,ku,kv + real(r_kind) dummy,dummyout ! 2D variable names stuck in here integer(i_kind) nfcst @@ -1013,7 +1039,7 @@ subroutine read_2d_guess(mype) end do do i=1,lon1+2 do j=1,lat1+2 - ges_z_it(j,i) = real(all_loc(j,i,i_0+i_fis))/grav ! surface elevation multiplied by g + ges_z_it(j,i) = real(all_loc(j,i,i_0+i_fis),r_kind)/grav ! surface elevation multiplied by g ! convert input psfc to psfc in mb, and then to cb @@ -1110,16 +1136,27 @@ subroutine read_2d_guess(mype) ges_gust(j,i)=real(all_loc(j,i,i_0+i_gust),r_kind) if (ihave_vis) then - ges_vis(j,i)=real(all_loc(j,i,i_0+i_vis),r_kind) - if (ges_vis(j,i)<=zero) ges_vis(j,i)=one_tenth - if (ges_vis(j,i)>20000.0_r_kind) ges_vis(j,i)=20000.0_r_kind +!.............................................................. +!NOTE: input data come from sigf06, already using vis_thres, +! min=1.0 m and max=vis_thres +!.............................................................. + dummy=real(all_loc(j,i,i_0+i_vis),r_kind) + call nltransf_forward(dummy,dummyout,pvis,scale_cv) + ges_vis(j,i)=dummyout endif if(ihave_pblh) & ges_pblh(j,i)=real(all_loc(j,i,i_0+i_pblh),r_kind) - if(ihave_cldch) & - ges_cldch(j,i)=max(min(real(all_loc(j,i,i_0+i_cldch),r_kind),20000.0_r_kind),one_tenth) + if(ihave_cldch) then +!.............................................................. +!NOTE: input data come from sigf06, already using cldch_thres, +! min=1.0 m and max=cldch_thres +!.............................................................. + dummy=real(all_loc(j,i,i_0+i_cldch),r_kind) + call nltransf_forward(dummy,dummyout,pcldch,scale_cv) + ges_cldch(j,i)=dummyout + endif if (ihave_wspd10m) & ges_wspd10m(j,i)=real(all_loc(j,i,i_0+i_wspd10m),r_kind) @@ -1156,8 +1193,6 @@ subroutine read_2d_guess(mype) end do deallocate(all_loc,jsig_skip,igtype,identity,temp1) - - return end subroutine read_2d_guess @@ -1205,6 +1240,8 @@ subroutine wr2d_binary(mype) ! !$$$ use kinds, only: r_kind,r_single,i_kind + use constants, only: one_tenth,one + use guess_grids, only: ntguessig,ifilesig,& ges_tsen use mpimod, only: mpi_comm_world,ierror,mpi_real4 @@ -1216,6 +1253,8 @@ subroutine wr2d_binary(mype) use jfunc, only: jiter,miter use gsi_metguess_mod, only: gsi_metguess_bundle use gsi_bundlemod, only: gsi_bundlegetpointer + use qcmod, only: pvis,pcldch,scale_cv,vis_thres,cldch_thres + use nltransf, only: nltransf_inverse use mpeu_util, only: die use gsi_io, only: verbose implicit none @@ -1245,6 +1284,7 @@ subroutine wr2d_binary(mype) real(r_single) glon0(nlon_regional,nlat_regional),glat0(nlon_regional,nlat_regional) real(r_single) dx_mc0(nlon_regional,nlat_regional),dy_mc0(nlon_regional,nlat_regional) real(r_single),allocatable::all_loc_qsatg(:,:,:),all_loc_prh(:,:,:),temp1_prh(:) + real(r_kind) tempvis,visout,tempcldch,cldchout integer(i_kind) iaux(100),kaux character(15) caux(100) @@ -1520,17 +1560,23 @@ subroutine wr2d_binary(mype) do k=1,kaux call gsi_bundlegetpointer (gsi_metguess_bundle(it),trim(caux(k)),ptr2d, ier) if (ier==0) then - do i=1,lon2 do j=1,lat2 if (trim(caux(k))=='pmsl') then all_loc(j,i,iaux(k))=r100*r10*ptr2d(j,i) - else + elseif(trim(caux(k))=='vis') then + tempvis=ptr2d(j,i) + call nltransf_inverse(tempvis,visout,pvis,scale_cv) + all_loc(j,i,iaux(k))=max(min(visout,vis_thres),one) + elseif(trim(caux(k))=='cldch') then + tempcldch=ptr2d(j,i) + call nltransf_inverse(tempcldch,cldchout,pcldch,scale_cv) + all_loc(j,i,iaux(k))=max(min(cldchout,cldch_thres),one) + else all_loc(j,i,iaux(k))=ptr2d(j,i) - endif + endif end do end do - if(mype==0) read(iog)temp1 call strip(all_loc(:,:,iaux(k)),strp) call mpi_gatherv(strp,ijn(mype+1),mpi_real4, & @@ -2075,12 +2121,11 @@ subroutine adjust_error(alon,alat,oberr,oberr2) if (rsign1*rsign2=1._r_single .and. valleys(i,j) < 1._r_single) then + rminsq=+huge(rminsq) + do jj=max(1,j-ijdel),min(ny,j+ijdel) + do ii=max(1,i-ijdel),min(nx,i+ijdel) + if (ii==i .and. jj==j) cycle + if (fldstd(ii,jj,1) < 1._r_single) then + rminsq0=float((i-ii)*(i-ii)) + float((j-jj)*(j-jj)) + if (rminsq0 < rminsq .and. rminsq0 <= float(ijdel*ijdel)) then + rminsq=rminsq0 + auxfld(i,j)=fldstd(ii,jj,1) !Note that you are changing auxfld, not fldstd + endif + endif + enddo + enddo + endif + enddo + enddo + valleys(:,:)=auxfld(:,:) + elseif (.not.smooth_composite) then + valleys(:,:)=min(valleys(:,:),auxfld(:,:)) + endif + + if (mype==0) then + open (55,file='valley_map_unsmoothed.dat',form='unformatted') + write(55) valleys + close(55) + endif + + call smther_one(valleys,1,nx,1,ny,npasscomposite) + if (print_verbose)print*,'in mkvalley_file: valleys,min,max=',minval(valleys),maxval(valleys) + + if (mype==0) then + open (55,file='valley_map.dat',form='unformatted') + write(55) valleys + close(55) + endif endif + + + if (std_based_valleymap) then + deallocate(fldstd) + deallocate(auxfld) + endif end subroutine mkvalley_file !**************************************************************** !**************************************************************** @@ -2484,7 +2701,7 @@ module hilbertcurve integer(i_kind) ngrps_vwnd10mob logical random_cvgrp - real(r_kind) usagecv + real(r_kind) usagecv,usage_dup contains @@ -2521,7 +2738,7 @@ subroutine init_hilbertcurve(maxobs) integer(i_kind) i,k logical fexist, print_verbose - namelist/parmcardhcurve/random_cvgrp,usagecv,ngrps_tob,ngrps_uvob, & + namelist/parmcardhcurve/random_cvgrp,usagecv,usage_dup,ngrps_tob,ngrps_uvob, & ngrps_spdob,ngrps_psob,ngrps_qob, & ngrps_pwob,ngrps_sstob,ngrps_gustob,ngrps_visob, & ngrps_td2mob, ngrps_mxtmob,ngrps_mitmob, & @@ -2531,6 +2748,7 @@ subroutine init_hilbertcurve(maxobs) random_cvgrp=.false. usagecv=3._r_kind + usage_dup=3._r_kind ngrps_tob=5 ngrps_uvob=8 ngrps_spdob=0 @@ -2551,6 +2769,7 @@ subroutine init_hilbertcurve(maxobs) print_verbose = .false. if(verbose)print_verbose=.true. + inquire(file='parmcard_input',exist=fexist) if (fexist) then open(55,file='parmcard_input',form='formatted') @@ -2567,6 +2786,7 @@ subroutine init_hilbertcurve(maxobs) if(print_verbose .and. mype == 0)then print*,'in init_hilbertcurve: random_cvgrp=',random_cvgrp print*,'in init_hilbertcurve: usagecv=',usagecv + print*,'in init_hilbertcurve: usage_dup=',usage_dup print*,'in init_hilbertcurve: ngrps_tob=',ngrps_tob print*,'in init_hilbertcurve: ngrps_uvob=',ngrps_uvob print*,'in init_hilbertcurve: ngrps_spdob=',ngrps_spdob @@ -2719,9 +2939,6 @@ subroutine apply_hilbertcurve(maxobs,obstype,cdata_usage) integer(i_kind),intent(in ) :: maxobs real(r_kind) ,intent(inout) :: cdata_usage(maxobs) -!Declare local parameter - real(r_kind),parameter::usage_dup=8. - !Declare local variables real(r_kind),parameter:: epsilon=1.e-03_r_kind integer(i_kind) i,j,n,nt,ncnumgrp0,ncgroup0 @@ -2736,7 +2953,8 @@ subroutine apply_hilbertcurve(maxobs,obstype,cdata_usage) logical print_verbose -! Turning on print_verbose will result in additional prints from this routine only. +! Turning on print_verbose will result in additional prints from this routine +! only. print_verbose = .false. if(verbose)print_verbose=.true. @@ -2846,13 +3064,13 @@ subroutine apply_hilbertcurve(maxobs,obstype,cdata_usage) !is the same group element for all ob subtypes !of a given ob type - if (i==1 .and. print_verbose) print*,'in apply_hilbertcurve: ncnumgrp0,ncgroup0=',ncnumgrp0,ncgroup0 + if (i==1 .and. print_verbose) print*,'in apply_hilbertcurve: obstype,ncnumgrp0,ncgroup0=',trim(obstype),ncnumgrp0,ncgroup0 if (test_set(i).eq.ncgroup0) then - if ( random_cvgrp) usage=usagecv !3. + if ( random_cvgrp) usage=usagecv if (.not.random_cvgrp) usage=ncmiter(hilikx(i)) - cdata_usage(hili(i))=usage + cdata_usage(hili(i))=usage + ( cdata_usage(hili(i))-real(int(cdata_usage(hili(i))),kind=r_kind) ) j=ipoint(i) do n=1,nt @@ -2860,7 +3078,7 @@ subroutine apply_hilbertcurve(maxobs,obstype,cdata_usage) ldup=abs(hil_dlon(j)-hil_dlon(n))>> +! | use timermod, only: timer_ini, timer_fnl +! | call timer_ini('setuprhsall') ! set timer:"setuprhsall" on +! | >>> +! | use timermod, only: timer_ini, timer_fnl +! | call timer_ini('setupoz') ! set timer:"setupoz" on +! | call timer_fnl('setupoz') ! set timer:"setupoz" off +! | <<< +! | call timer_fnl('setuprhsall') ! set timer:"setuprhsall" off +! | <<< +! | if(myPE==0) call timer_pri(6) ! summarize all timers + +! ..................... +! (1b) A new set of interfaces are also provided, which is similar but with +! different use-case in mind, which requires additional interfaces of +! extension management and supports some refined use-case steps for user's +! convinience. + + public:: timer_typedef ! call timer_typedef([my_timer_mold]) + ! - (re)types module variable -typemold_-. + public:: timer_typename ! timer_name=timer_typename() + ! - returns an allocatable char(*) for the + ! concrete type name of the user specified typemold_. + + interface timer_typedef ; module procedure typedef_ ; end interface + interface timer_typename; module procedure typename_; end interface + + public:: timer_on ! call timer_on ("proc-A") + public:: timer_off ! call timer_off("proc-A") + public:: timer_reset ! call timer_reset() + public:: timer_flush ! call timer_flush(lu=6) + public:: timer_allflush ! call timer_allflush(lu=6,root=0,comm=my_comm_world) + + interface timer_on ; module procedure tmon_ ; end interface + interface timer_off ; module procedure tmoff_ ; end interface + interface timer_reset ; module procedure reset_ ; end interface + interface timer_flush ; module procedure flush_ ; end interface + interface timer_allflush; module procedure allflush_; end interface + +! ..................... +! Use-Case 2: reduced parallel profiling, with distributed timers +! +! | use timermod , only: timer_typedef, timer_typename +! | use timermod , only: timer_flush, timer_allflush, timer_reset +! | use m_myTimer, only: myTimer_typemold +! | +! | call timer_typedef(myTimer_typemold()) ! use myTimer as the multi-timer +! | if(myPE==0) print*,'customized timer_typename =',timer_typename() +! | >>> +! | use timermod, only: timer_on, timer_off +! | call timer_on ('setuprhsall') ! set timer:"setuprhsall" on +! | >>> +! | use timermod, only: timer_on, timer_off +! | call timer_on ('setupoz') ! set timer:"setupoz" on +! | call timer_off('setupoz') ! set timer:"setupoz" off +! | <<< +! | call timer_off('setuprhsall') ! set timer:"setuprhsall" off +! | <<< +! | if(myPE==0) call timer_flush(6) ! summarize timers on PE=0 +! | call timer_allflush(6,comm=MPI_comm_world,root=0) ! reduce-summarize distributed timers +! | call timer_reset() ! reset all timers +! +! Note the use of extension management through timer_typedef(). + + +!------------------------------------------------------------------------------- +! (2) -timermod- manages a typemold_ variable to hold the user specified type +! definition through []_typedef(), as well as a concrete multi-timer +! variable this_timer_. Variable thie_timer_ is allocated based on +! typemold_, and initialized at the first timer_on() call, or at a +! timer_reset() call. + + class(abstractTimer),allocatable,target,save:: typemold_ + class(abstractTimer),allocatable,target,save:: this_timer_ + +! Given the single instance nature of -timermod- as a common service, there +! is no need to support an explicitly accessible multi-timer object to +! high-level users. + +!------------------------------------------------------------------------------- + character(len=*),parameter:: myname="timermod" + + ! This flag controls internal debugging messages. + logical,parameter:: verbose=.false. + !logical,parameter:: verbose=.true. + +contains +!------------------------------------------------------------------------------- +! Extension management routines + +subroutine typedef_(mold) +!-- A high-level interface type-define the concrete multi-timer to use. + + use m_stubTimer, only: stubTimer => timer + implicit none + class(abstractTimer),optional,target,intent(in):: mold + + character(len=*),parameter:: myname_=myname//'::typedef_' + class(abstractTimer),pointer:: pmold_ + + ! argument checking + pmold_ => null() + if(present(mold)) then + pmold_ => mold + if(.not.associated(pmold_)) & ! is argument _mold_ a null-object? + call warn(myname_,'a null argument (mold) is given. Will typedef to default') + endif + + ! reset current typemold + if(allocated(typemold_)) then + if(verbose) call tell(myname_,'deallocating, typemold_%mytype() = '//typemold_%mytype()) + call typemold_%reset() + deallocate(typemold_) + endif + + ! (re)allocate the new typemold_ + if(associated(pmold_)) then + allocate(typemold_,mold=pmold_) + pmold_ => null() + + else + allocate(stubTimer::typemold_) + endif + if(verbose) call tell(myname_,'allocated, typemold_%mytype() = '//typemold_%mytype()) +end subroutine typedef_ + +function typename_() result(name) +!-- Return the name of the current concrete multi-timer type. + + use m_abstractTimer, only: abstractTimer_typename + implicit none + character(len=:),allocatable:: name ! return the type name + name=abstractTimer_typename() + if(allocated(typemold_)) name=typemold_%mytype() + ! Note the use of typemold_, instead of this_timer_. +end function typename_ + +!------------------------------------------------------------------------------- +! Routines supporting timing activities +subroutine tmon_(name) +!-- Set a single named timer on +implicit none + character(len=*),intent(in):: name ! a timer name + + call ifn_alloc_() ! to ensure an allocated(this_timer_) + call this_timer_%on(name) +end subroutine tmon_ + +subroutine tmoff_(name) +!-- set a single named timer off + implicit none + character(len=*),intent(in):: name ! a timer name + + call ifn_alloc_() ! to ensure an allocated(this_timer_) + call this_timer_%off(name) +end subroutine tmoff_ + +subroutine ifn_alloc_() +!-- If-not-properly-allocated(this_timer_), do something + implicit none + class(abstractTimer),pointer:: pmold_ + + ! First, check to make sure typemold_ is type-defined, at least to a + ! default multi-timer type. + pmold_ => typemold_ + if(.not.associated(pmold_)) call typedef_() + pmold_ => null() + + ! Then, check and possibly instantiate this_timer_, which is must be + ! typed the same as typemold_ + + if(allocated(this_timer_)) then + if(same_type_as(typemold_,this_timer_)) return ! Everything seems good. + + ! Otherwise, this_timer_ must be re-intentiated with a different type. + + call this_timer_%reset() ! before deallocate -this_timer-, empty it. + deallocate(this_timer_) + endif + allocate(this_timer_,mold=typemold_) +end subroutine ifn_alloc_ + +subroutine reset_() +!-- Reset this_timer_ to its initialized state. + implicit none + call ifn_alloc_() ! to ensure an allocated(this_timer_) + call this_timer_%reset() +end subroutine reset_ + +subroutine flush_(lu) +!-- Make a summarized dump of the local multi-timer to unit=lu + implicit none + integer(kind=i_kind),intent(in):: lu ! output unit + + call ifn_alloc_() ! to ensure an allocated(this_timer_) + call this_timer_%flush(lu) +end subroutine flush_ + +subroutine allflush_(lu,comm,root) +!-- Make a reduced summary of distributed multi-timers to unit=lu on root PE. + use mpeu_mpif, only: my_comm => MPI_COMM_WORLD + implicit none + integer(kind=i_kind), intent(in):: lu ! output unit + integer(kind=i_kind),optional,intent(in):: comm ! communicator (MPI) + integer(kind=i_kind),optional,intent(in):: root ! root processor ID (MPI) + + integer(kind=i_kind):: comm_,root_ + + comm_=my_comm; if(present(comm)) comm_=comm ! default to MPI_COMM_WORLD + root_=0 ; if(present(root)) root_=root ! default to ROOT=0 + + call ifn_alloc_() ! to ensure an allocated(this_timer_) + call this_timer_%allflush(lu,comm=comm_,root=root_) +end subroutine allflush_ + +end module timermod diff --git a/src/tintrp2a.f90 b/src/gsi/tintrp2a.f90 similarity index 80% rename from src/tintrp2a.f90 rename to src/gsi/tintrp2a.f90 index a4d5e6509..f675ae8b3 100644 --- a/src/tintrp2a.f90 +++ b/src/gsi/tintrp2a.f90 @@ -358,3 +358,97 @@ subroutine tintrp2a11_csln(f,g,gw,dx,dy,obstime,gridtime, & return end subroutine tintrp2a11_csln + + +subroutine tintrp2a11_indx(dx,dy,obstime,gridtime, & + mype,nflds,ix,ixp,iy,iyp,itime,itimep) +!$$$ subprogram documentation block +! . . . . +! subprogram: tintrp2a11_indx +! prgmmr: zupanski org: CSU/CIRA/Data Assimilation group date: 2015-07-10 +! +! abstract: same as tintrp2a11 but for horizontal grid indexes surrounding +! an observation point +! +! program history log: +! 2015-07-10 zupanski: add output grid indexes +! 2018-01-01 apodaca: compatibility-related updates +! +! input argument list: +! dx,dy - input x,y,z-coords of interpolation points (grid units) +! obstime - time to interpolate to +! gridtime - grid guess times to interpolate from +! mype - mpi task id +! nflds - number of guess times available to interpolate from +! +! output argument list: +! ix,iy,ixp,iyp - horizontal grid indexes +! itime,itimep - time grid indexes +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind + use gridmod, only: istart,jstart,nlon,nlat,lon1 + use constants, only: zero,one + implicit none + +! Declare passed variables + integer(i_kind) ,intent(in ) :: mype,nflds + real(r_kind) ,intent(in ) :: dx,dy,obstime + real(r_kind),dimension(nflds) ,intent(in ) :: gridtime + integer(i_kind) ,intent(out ) :: ix,ixp + integer(i_kind) ,intent(out ) :: iy,iyp + integer(i_kind) ,intent(out ) :: itime,itimep + +! Declare local variables + integer(i_kind) m1,ix1,iy1 + integer(i_kind) j + real(r_kind) delx + real(r_kind) dely,delt + + m1=mype+1 + + ix1=int(dx) + iy1=int(dy) + ix1=max(1,min(ix1,nlat)) + delx=dx-float(ix1) + dely=dy-float(iy1) + delx=max(zero,min(delx,one)) + ix=ix1-istart(m1)+2 + iy=iy1-jstart(m1)+2 + if(iy<1) then + iy1=iy1+nlon + iy=iy1-jstart(m1)+2 + end if + if(iy>lon1+1) then + iy1=iy1-nlon + iy=iy1-jstart(m1)+2 + end if + ixp=ix+1; iyp=iy+1 + if(ix1==nlat) then + ixp=ix + end if + if(obstime > gridtime(1) .and. obstime < gridtime(nflds))then + do j=1,nflds-1 + if(obstime > gridtime(j) .and. obstime <= gridtime(j+1))then + itime=j + itimep=j+1 + delt=((gridtime(j+1)-obstime)/(gridtime(j+1)-gridtime(j))) + end if + end do + else if(obstime <=gridtime(1))then + itime=1 + itimep=1 + delt=one + else + itime=nflds + itimep=nflds + delt=one + end if + + return +end subroutine tintrp2a11_indx + diff --git a/src/tintrp3.f90 b/src/gsi/tintrp3.f90 similarity index 100% rename from src/tintrp3.f90 rename to src/gsi/tintrp3.f90 diff --git a/src/tpause.f90 b/src/gsi/tpause.f90 similarity index 100% rename from src/tpause.f90 rename to src/gsi/tpause.f90 diff --git a/src/tpause_t.F90 b/src/gsi/tpause_t.F90 similarity index 100% rename from src/tpause_t.F90 rename to src/gsi/tpause_t.F90 diff --git a/src/tune_pbl_height.f90 b/src/gsi/tune_pbl_height.f90 similarity index 100% rename from src/tune_pbl_height.f90 rename to src/gsi/tune_pbl_height.f90 diff --git a/src/turbl.f90 b/src/gsi/turbl.f90 similarity index 100% rename from src/turbl.f90 rename to src/gsi/turbl.f90 diff --git a/src/turbl_ad.f90 b/src/gsi/turbl_ad.f90 similarity index 100% rename from src/turbl_ad.f90 rename to src/gsi/turbl_ad.f90 diff --git a/src/turbl_tl.f90 b/src/gsi/turbl_tl.f90 similarity index 100% rename from src/turbl_tl.f90 rename to src/gsi/turbl_tl.f90 diff --git a/src/turblmod.f90 b/src/gsi/turblmod.f90 similarity index 100% rename from src/turblmod.f90 rename to src/gsi/turblmod.f90 diff --git a/src/tv_to_tsen.f90 b/src/gsi/tv_to_tsen.f90 similarity index 100% rename from src/tv_to_tsen.f90 rename to src/gsi/tv_to_tsen.f90 diff --git a/src/unfill_mass_grid2.f90 b/src/gsi/unfill_mass_grid2.f90 similarity index 81% rename from src/unfill_mass_grid2.f90 rename to src/gsi/unfill_mass_grid2.f90 index 389420a45..0bd02ad28 100644 --- a/src/unfill_mass_grid2.f90 +++ b/src/gsi/unfill_mass_grid2.f90 @@ -197,7 +197,7 @@ subroutine unfill_mass_grid2v(gout,nx,ny,gin) end subroutine unfill_mass_grid2v subroutine unfill_mass_grid2t_ldmk(gout,nx,ny,gin,landmask, & - snow,seaice,i_snowt_check) + snow,seaice,deltaT,i_snowt_check) !$$$ subprogram documentation block ! . . . . ! subprogram: unfill_mass_grid2t opposite of fill_mass_grid2 @@ -218,10 +218,13 @@ subroutine unfill_mass_grid2t_ldmk(gout,nx,ny,gin,landmask, & ! gout - input A-grid (reorganized for distibution to local domains) ! gin - preexisting input values to be added to on C-grid ! nx,ny - input grid dimensions +! deltaT - delta T between atmosphere and tsk/tslb(1) ! i_snowT_check - input option for snow Temperature adjustment ! =0: input gin is not temperature -! =1: make sure surface temperature onver snow is below 0C +! =1: tsk make sure surface temperature onver snow is below 0C ! =2: input gin is soil mositure, don't adjust over seaice +! =3: soil temperature +! =4: soilt1 ! ! output argument list: ! gin - output result on C grid @@ -236,6 +239,8 @@ subroutine unfill_mass_grid2t_ldmk(gout,nx,ny,gin,landmask, & use general_commvars_mod, only: ltosi,ltosj use mod_wrfmass_to_a, only: wrfmass_a_to_h4 use gridmod, only: nlon, nlat + use rapidrefresh_cldsurf_mod, only: DTsTmax + use constants, only: partialSnowThreshold implicit none @@ -246,6 +251,7 @@ subroutine unfill_mass_grid2t_ldmk(gout,nx,ny,gin,landmask, & real(r_single) , intent(in) :: landmask(nx,ny) real(r_single) , intent(in) :: snow(nx,ny) real(r_single) , intent(in) :: seaice(nx,ny) + real(r_single) , intent(in) :: deltaT(nx,ny) real(r_single) ba(nlon,nlat) real(r_single) b(nx,ny) @@ -261,37 +267,43 @@ subroutine unfill_mass_grid2t_ldmk(gout,nx,ny,gin,landmask, & call wrfmass_a_to_h4(ba,b) endif ! only add analysis increment over land -! if(nlon == nx .and. nlat == ny) then -! do nothing -! else - if(maxval(landmask) > 1.01_r_single .or. minval(landmask) < -0.01_r_single .or. & - maxval(seaice) > 1.01_r_single .or. minval(seaice) < -0.01_r_single) then - write(*,*) 'bad landmask or seaice, do not use landmask filter soil nudging field' - else - do j=1,ny - do i=1,nx - if(landmask(i,j) < 0.1_r_single) b(i,j)=0.0_r_single - if(i_snowt_check==2 .and. seaice(i,j) > 0.5_r_single) b(i,j)=0.0_r_single - end do + if(maxval(landmask) > 1.01_r_single .or. minval(landmask) < -0.01_r_single .or. & + maxval(seaice) > 1.01_r_single .or. minval(seaice) < -0.01_r_single) then + write(*,*) 'bad landmask or seaice, do not use landmask filter soil nudging field' + else + do j=1,ny + do i=1,nx + if(landmask(i,j) < 0.1_r_single) b(i,j)=0.0_r_single + if(i_snowT_check==2 .and. seaice(i,j) > 0.5_r_single) b(i,j)=0.0_r_single +! don't change soil T (TSBL) under thick snow (> partialSnowThreshold=32 mm) + if(i_snowT_check==3 .and. (snow(i,j) > partialSnowThreshold)) b(i,j)=0.0_r_single +! Limit application of soil temp nudging in fine grid as follows: +! - If cooling is indicated, apply locally only +! if deltaT = Tskin - T(k=1) > -20K. for TSK and SOILT1 +! if deltaT = TSLB(1) - T(k=1) > -20K. for TSLB +! Idea: If skin temp is already much colder than atmos temp, +! it's useless to cool off the soil any more +! As we also know, the repeated application will created +! unrealistic values. +! - Do similar for indicated soil warming, apply locally only: +! if deltaT = Tskin - T(k=1) < 20K. for TSK and SOILT1 +! if deltaT = TSLB(1) - T(k=1) < 20K. for TSLB +! + if( (i_snowT_check==1 .or. i_snowT_check==3 .or. i_snowT_check==4) ) then + if(deltaT(i,j) < -DTsTmax .and. b(i,j) < 0.0_r_single) & + b(i,j)=0.0_r_single + if(deltaT(i,j) > DTsTmax .and. b(i,j) > 0.0_r_single) & + b(i,j)=0.0_r_single + endif end do - endif -! endif + end do + endif ! Mass grids--just copy do j=1,ny do i=1,nx gin(i,j)=b(i,j)+gin(i,j) end do end do -! QC surface temperature over snow - if(i_snowT_check==1) then - do j=1,ny - do i=1,nx - if(snow(i,j) > 32.0_r_kind) then - gin(i,j) = min(gin(i,j), 273.15_r_kind) - endif - end do - end do - endif end subroutine unfill_mass_grid2t_ldmk diff --git a/src/unfill_nmm_grid2.f90 b/src/gsi/unfill_nmm_grid2.f90 similarity index 100% rename from src/unfill_nmm_grid2.f90 rename to src/gsi/unfill_nmm_grid2.f90 diff --git a/src/unhalf_nmm_grid2.f90 b/src/gsi/unhalf_nmm_grid2.f90 similarity index 100% rename from src/unhalf_nmm_grid2.f90 rename to src/gsi/unhalf_nmm_grid2.f90 diff --git a/src/update_guess.f90 b/src/gsi/update_guess.f90 similarity index 89% rename from src/update_guess.f90 rename to src/gsi/update_guess.f90 index 4d09df547..716ab71aa 100644 --- a/src/update_guess.f90 +++ b/src/gsi/update_guess.f90 @@ -86,6 +86,7 @@ subroutine update_guess(sval,sbias) ! 2015-07-10 pondeca - add cldch ! 2016-04-28 eliu - revise update for cloud water ! 2016-06-23 lippi - Add update for vertical velocity (w). +! 2018-05-01 yang - modify the constrains to C and V in g-space, or using NLTF transfermation to C/V ! ! input argument list: ! sval @@ -105,7 +106,7 @@ subroutine update_guess(sval,sbias) use kinds, only: r_kind,i_kind use mpimod, only: mype use constants, only: zero,one,fv,max_varname_length,qmin,qcmin,tgmin,& - r100,one_tenth + r100,one_tenth,tiny_r_kind use jfunc, only: iout_iter,bcoption,tsensible,clip_supersaturation use gridmod, only: lat2,lon2,nsig,& regional,twodvar_regional,regional_ozone @@ -128,6 +129,8 @@ subroutine update_guess(sval,sbias) use rapidrefresh_cldsurf_mod, only: i_use_2mq4b,i_use_2mt4b use gsd_update_mod, only: gsd_limit_ocean_q,gsd_update_soil_tq,& gsd_update_th2,gsd_update_q2 + use qcmod, only: pvis,pcldch,vis_thres,cldch_thres + use obsmod, only: l_wcp_cwm implicit none @@ -145,6 +148,8 @@ subroutine update_guess(sval,sbias) integer(i_kind) icloud,ncloud integer(i_kind) idq real(r_kind) :: zt + real(r_kind) :: glow,ghigh + real(r_kind),pointer,dimension(:,: ) :: ptr2dinc =>NULL() real(r_kind),pointer,dimension(:,: ) :: ptr2dges =>NULL() real(r_kind),pointer,dimension(:,:,:) :: ptr3dinc =>NULL() @@ -154,6 +159,10 @@ subroutine update_guess(sval,sbias) real(r_kind),pointer,dimension(:,:,:) :: ptr3daux =>NULL() real(r_kind),pointer,dimension(:,:,:) :: ges_ql =>NULL() real(r_kind),pointer,dimension(:,:,:) :: ges_qi =>NULL() + real(r_kind),pointer,dimension(:,:,:) :: ges_qr =>NULL() + real(r_kind),pointer,dimension(:,:,:) :: ges_qs =>NULL() + real(r_kind),pointer,dimension(:,:,:) :: ges_qg =>NULL() + real(r_kind),pointer,dimension(:,:,:) :: ges_qh =>NULL() real(r_kind),dimension(lat2,lon2) :: tinc_1st,qinc_1st @@ -177,6 +186,7 @@ subroutine update_guess(sval,sbias) endif ! Inquire about clouds + call gsi_metguess_get('clouds::3d',ncloud,istatus) if (ncloud>0) then allocate(cloud(ncloud)) @@ -265,7 +275,7 @@ subroutine update_guess(sval,sbias) endif icloud=getindex(cloud,guess(ic)) if(icloud>0) then - ptr3dges = max(ptr3dges+ptr3dinc,qcmin) + ptr3dges = max(ptr3dges+ptr3dinc,zero) cycle else ptr3dges = ptr3dges + ptr3dinc @@ -289,13 +299,36 @@ subroutine update_guess(sval,sbias) call gsi_bundlegetpointer (gsi_metguess_bundle(it),guess(ic),ptr2dges,istatus) ptr2dges = ptr2dges + ptr2dinc if (trim(guess(ic))=='gust') ptr2dges = max(ptr2dges,zero) - if (trim(guess(ic))=='vis') ptr2dges = max(min(ptr2dges,20000.0_r_kind),one_tenth) + if (trim(guess(ic))=='vis') then + if(abs(pvis) 100% or < 0% cloud amount + if (trim(guess(ic))=='tcamt') ptr2dges = max(min(ptr2dges,r100),zero) !Cannot have>100% or <0% cloud amount if (trim(guess(ic))=='lcbas') ptr2dges = max(min(ptr2dges,20000.0_r_kind),one_tenth) - if (trim(guess(ic))=='cldch') ptr2dges = max(min(ptr2dges,20000.0_r_kind),one_tenth) + cycle endif enddo @@ -307,6 +340,19 @@ subroutine update_guess(sval,sbias) if (ier==0) then ptr3dges = ges_ql + ges_qi endif + if ( l_wcp_cwm .and. & + getindex(svars3d,'qr')>0 .and. getindex(svars3d,'qs')>0 .and. & + getindex(svars3d,'qg')>0 .and. getindex(svars3d,'qh')>0) then + ier=0 + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qr',ges_qr, istatus) ; ier=istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qs',ges_qs, istatus) ; ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qg',ges_qg, istatus) ; ier=ier+istatus + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qh',ges_qh, istatus) ; ier=ier+istatus + if (ier==0) then + ptr3dges = ptr3dges + ges_qr + ges_qs + ges_qg + ges_qh + endif + endif + endif ! At this point, handle the Tv exception since by now Q has been updated ! NOTE 1: This exceptions is unnecessary: all we need to do is put tsens in the diff --git a/src/ut_gsibundle.F90 b/src/gsi/ut_gsibundle.F90 similarity index 100% rename from src/ut_gsibundle.F90 rename to src/gsi/ut_gsibundle.F90 diff --git a/src/wind_fft.f90 b/src/gsi/wind_fft.f90 similarity index 99% rename from src/wind_fft.f90 rename to src/gsi/wind_fft.f90 index d9fe1a643..449ceb120 100644 --- a/src/wind_fft.f90 +++ b/src/gsi/wind_fft.f90 @@ -825,10 +825,9 @@ SUBROUTINE FACTOR (N,NFAX,IFAX) IFAX(NFAX) = 3 NN = NN/3 ELSE - GO TO 20 + EXIT END IF 10 CONTINUE - 20 CONTINUE ! EXTRACT FACTORS OF 2 DO 30 II = NFAX+1,20 IF (NN==2*(NN/2)) THEN @@ -836,10 +835,9 @@ SUBROUTINE FACTOR (N,NFAX,IFAX) IFAX(NFAX) =2 NN = NN/2 ELSE - GO TO 40 + EXIT END IF 30 CONTINUE - 40 CONTINUE IF (NN/=1) THEN write(6,*) 'PORRA 4' STOP diff --git a/src/wrf_mass_guess_mod.f90 b/src/gsi/wrf_mass_guess_mod.f90 similarity index 100% rename from src/wrf_mass_guess_mod.f90 rename to src/gsi/wrf_mass_guess_mod.f90 diff --git a/src/wrf_params_mod.f90 b/src/gsi/wrf_params_mod.f90 similarity index 100% rename from src/wrf_params_mod.f90 rename to src/gsi/wrf_params_mod.f90 diff --git a/src/gsi/wrf_vars_mod.f90 b/src/gsi/wrf_vars_mod.f90 new file mode 100644 index 000000000..97c36c43c --- /dev/null +++ b/src/gsi/wrf_vars_mod.f90 @@ -0,0 +1,66 @@ +module wrf_vars_mod +!$$$ subprogram documentation block +! . . . +! subprogram: wrf_vars_mod +! +! prgrmmr: Todling +! +! abstract: +! +! program history log: +! 2019-07-11 Todling - add to replace incorrect placement of variables in +! control_vectors file. The fact is that a clean up on +! what has been done for w (dw) and dbz would not +! require this file not the variables defined here. +! ...>>> the is currently a major mix up (esp. in the WRF side of the code) +! between what is a control variable and a state variable. The +! latter is generally the guess field (and controlled by metguess) +! Therefore the read routines from WRF should NEVER refer to the CV +! variables as they do ... indeed there should never be a use +! statement in those codes related to CV. +! +! Things like +! use control_vectors, only: cvars3d +! should be replaced by +! use state_vectors, only: svars3d +! +! checks can done on the fly to avoid definition of variables +! such as the ones in this module. +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block +use mpimod, only: mype +use control_vectors, only: nc3d,cvars3d +use kinds, only: i_kind +implicit none +private +! public methods +public :: init_wrf_vars +! common block variables +public :: w_exist +public :: dbz_exist + +logical,save :: w_exist, dbz_exist +contains + +subroutine init_wrf_vars +integer(i_kind) ii + +w_exist=.false. +dbz_exist=.false. +do ii=1,nc3d + if(mype == 0 ) write(6,*)"anacv cvars3d is ",cvars3d(ii) + if(trim(cvars3d(ii)) == 'w'.or.trim(cvars3d(ii))=='W') w_exist=.true. + if(trim(cvars3d(ii))=='dbz'.or.trim(cvars3d(ii))=='DBZ') dbz_exist=.true. +enddo + +end subroutine init_wrf_vars + +end module wrf_vars_mod diff --git a/src/write_all.F90 b/src/gsi/write_all.F90 similarity index 93% rename from src/write_all.F90 rename to src/gsi/write_all.F90 index 4deef9b6e..0e7569232 100644 --- a/src/write_all.F90 +++ b/src/gsi/write_all.F90 @@ -20,7 +20,7 @@ subroutine write_all(increment) use jfunc, only: bcoption - use gridmod, only: regional + use gridmod, only: regional,fv3_regional use guess_grids, only: ntguessig @@ -31,6 +31,8 @@ subroutine write_all(increment) ! use regional_io, only: write_regional_analysis use regional_io_mod, only: regional_io_class + use gsi_rfv3io_mod, only: wrfv3_netcdf + use gsi_rfv3io_mod, only: bg_fv3regfilenameg use ncepgfs_io, only: write_gfs @@ -91,6 +93,7 @@ subroutine write_all(increment) ! 2010-10-18 hcHuang - add flag use_gfs_nemsio and link to read_nems and read_nems_chem ! 2013-10-19 todling - metguess holds ges fields now ! 2014-10-05 todling - background biases now held in bundle +! 2017-10-10 Wu W - add FV3 option for regional output ! ! !REMARKS: ! @@ -113,7 +116,14 @@ subroutine write_all(increment) ! Regional output - if (regional) call io%write_regional_analysis(mype) + if (regional) then + if (fv3_regional) then + call wrfv3_netcdf(bg_fv3regfilenameg) + else + call io%write_regional_analysis(mype) + endif + endif + ! Global output diff --git a/src/write_bkgvars_grid.f90 b/src/gsi/write_bkgvars_grid.f90 similarity index 82% rename from src/write_bkgvars_grid.f90 rename to src/gsi/write_bkgvars_grid.f90 index e3da07a6d..0e03d989d 100644 --- a/src/write_bkgvars_grid.f90 +++ b/src/gsi/write_bkgvars_grid.f90 @@ -102,6 +102,7 @@ subroutine write_bkgvars2_grid ! 2010-10-20 pagowski - add cmaq ! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS ! core +! 2018-02-15 wu - add code for fv3_regional ! ! input argument list: ! @@ -114,12 +115,13 @@ subroutine write_bkgvars2_grid !$$$ use kinds, only: r_kind,i_kind,r_single use mpimod, only: mype - use constants, only: zero,r1000,one_tenth + use constants, only: zero,r1000,one_tenth,r100 + use guess_grids, only: get_ref_gesprs use gridmod, only: nlat,nlon,nsig - use gridmod, only: ak5,bk5,idvc5,& - regional,wrf_nmm_regional,nems_nmmb_regional,wrf_mass_regional,& - cmaq_regional,pt_ll,& - eta2_ll,pdtop_ll,eta1_ll,twodvar_regional + !use gridmod, only: ak5,bk5,idvc5,& + !regional,wrf_nmm_regional,nems_nmmb_regional,wrf_mass_regional,& + !cmaq_regional,pt_ll,fv3_regional,& + !eta2_ll,pdtop_ll,eta1_ll,twodvar_regional use control_vectors, only: nc3d,nc2d,mvars use control_vectors, only: cvars3d,cvars2d,cvarsmd use berror, only: dssv,dssvs @@ -151,31 +153,34 @@ subroutine write_bkgvars2_grid end do ! get some reference-like pressure levels - do k=1,nsig+1 - if(regional) then - if (wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) & - prs(k)=one_tenth* & - (eta1_ll(k)*pdtop_ll + & - eta2_ll(k)*(r1000-pdtop_ll-pt_ll) + & - pt_ll) - if (twodvar_regional) & - prs(k)=one_tenth*(eta1_ll(k)*(r1000-pt_ll) + pt_ll) - if (wrf_mass_regional) & - prs(k)=one_tenth*(eta1_ll(k)*(r1000-pt_ll) + eta2_ll(k) + pt_ll) - else - if (idvc5==1 .or. idvc5==2) then - prs(k)=ak5(k)+(bk5(k)*r1000) - else if (idvc5==3) then - if (k==1) then - prs(k)=r1000 - else if (k==nsig+1) then - prs(k)=zero - else - prs(k)=ak5(k)+(bk5(k)*r1000)! +(ck5(k)*trk) - end if - end if - endif - enddo +! do k=1,nsig+1 +! if(regional) then +! if (wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) & +! prs(k)=one_tenth* & +! (eta1_ll(k)*pdtop_ll + & +! eta2_ll(k)*(r1000-pdtop_ll-pt_ll) + & +! pt_ll) +! if (twodvar_regional) & +! prs(k)=one_tenth*(eta1_ll(k)*(r1000-pt_ll) + pt_ll) +! if (fv3_regional ) & +! prs(k)=eta1_ll(k)+r100*eta2_ll(k) +! if (wrf_mass_regional) & +! prs(k)=one_tenth*(eta1_ll(k)*(r1000-pt_ll) + eta2_ll(k) + pt_ll) +! else +! if (idvc5==1 .or. idvc5==2) then +! prs(k)=ak5(k)+(bk5(k)*r1000) +! else if (idvc5==3) then +! if (k==1) then +! prs(k)=r1000 +! else if (k==nsig+1) then +! prs(k)=zero +! else +! prs(k)=ak5(k)+(bk5(k)*r1000)! +(ck5(k)*trk) +! end if +! end if +! endif +! enddo + call get_ref_gesprs(prs) if (mype==0) then write(6,*) 'WRITE OUT NEW VARIANCES' @@ -220,7 +225,7 @@ subroutine write_bkgvars2_grid write(lu,'(a,2x,e13.6)') 'UNDEF', 1.E+15 ! any other preference for this? write(lu,'(a,2x,i4,2x,a,2x,f5.1,2x,f9.6)') 'XDEF',nlon, 'LINEAR', 0.0, 360./nlon write(lu,'(a,2x,i4,2x,a,2x,f5.1,2x,f9.6)') 'YDEF',nlat, 'LINEAR', -90.0, 180./(nlat-1.) - write(lu,'(a,2x,i4,2x,a,100(1x,f10.5))') 'ZDEF',nsig, 'LEVELS', prs + write(lu,'(a,2x,i4,2x,a,100(1x,f10.5))') 'ZDEF',nsig, 'LEVELS', prs(1:nsig) write(lu,'(a,2x,i4,2x,a)') 'TDEF', 1, 'LINEAR 12:00Z04JUL1776 6hr' ! any date suffices write(lu,'(a,2x,i4)') 'VARS',nc3d+nc2d+mvars do n=1,nc3d diff --git a/src/xhat_vordivmod.f90 b/src/gsi/xhat_vordivmod.f90 similarity index 100% rename from src/xhat_vordivmod.f90 rename to src/gsi/xhat_vordivmod.f90 diff --git a/src/zrnmi_mod.f90 b/src/gsi/zrnmi_mod.f90 similarity index 100% rename from src/zrnmi_mod.f90 rename to src/gsi/zrnmi_mod.f90 diff --git a/src/gsi_enscouplermod.f90 b/src/gsi_enscouplermod.f90 deleted file mode 100644 index 7bc4835a9..000000000 --- a/src/gsi_enscouplermod.f90 +++ /dev/null @@ -1,75 +0,0 @@ -!---------------------------------------------------------------------------- -!BOP -! -! !MODULE: GSI_EnsCouplerMod --- -! -! !INTERFACE: - -module GSI_EnsCouplerMod - -! !USES: - -use gsi_bundlemod, only: gsi_bundle -implicit none -private - -! -! !PUBLIC MEMBER FUNCTIONS: -! -public GSI_EnsCoupler_localization_grid -public GSI_EnsCoupler_get_user_ens -public GSI_EnsCoupler_put_gsi_ens - - -interface gsi_enscoupler_localization_grid - subroutine non_gaussian_ens_grid_ (elats,elons) - use kinds, only: i_kind,r_kind - use gridmod, only: rlats,rlons - implicit none - real(r_kind),intent(out) :: elats(size(rlats)),elons(size(rlons)) ! worse hack ever - end subroutine non_gaussian_ens_grid_ -end interface - -interface gsi_enscoupler_get_user_ens - subroutine get_user_ens_(grd,member,ntindex,en_read,iret) - use kinds, only: i_kind,r_kind - use gsi_bundlemod, only: gsi_bundle - use general_sub2grid_mod, only: sub2grid_info - implicit none -! Declare passed variables - type(sub2grid_info) ,intent(in ) :: grd - integer(i_kind) ,intent(in ) :: member ! member index - integer(i_kind) ,intent(in ) :: ntindex ! time index - type(gsi_bundle) ,intent(inout) :: en_read - integer(i_kind) ,intent( out) :: iret - end subroutine get_user_ens_ -end interface - -interface gsi_enscoupler_put_gsi_ens - subroutine put_gsi_ens_(grd,member,nt,pert,iret) - use kinds, only: i_kind,r_kind - use general_sub2grid_mod, only: sub2grid_info - use gsi_bundlemod, only: gsi_bundle - implicit none -! Declare passed variables - integer(i_kind), intent(in ) :: member - integer(i_kind), intent(in ) :: nt - type(sub2grid_info),intent(in ) :: grd - type(gsi_bundle), intent(inout) :: pert - integer(i_kind), intent( out) :: iret - end subroutine put_gsi_ens_ -end interface - - - -! !DESCRIPTION: This module provides general interface for -! ensemble capability -! -! !REVISION HISTORY: -! -! 19Sep2011 Todling - Initial code -! 30Nov2014 Todling - Update interface to get (bundle passed in) -! -!EOP -!------------------------------------------------------------------------- -end module GSI_EnsCouplerMod diff --git a/src/gsi_nemsio_mod.f90 b/src/gsi_nemsio_mod.f90 deleted file mode 100644 index de929a4b3..000000000 --- a/src/gsi_nemsio_mod.f90 +++ /dev/null @@ -1,913 +0,0 @@ -module gsi_nemsio_mod -!$$$ module documentation block -! . . . . -! module: gsi_nemsio_mod -! prgmmr: -! -! abstract: -! -! program history log: -! 2009-08-04 lueken - added module doc block -! 2014-06-30 wu - remove debugging printout -! 2015_05_13 wu - output error flag of nemsio_open -! 2015-06-10 s.liu - add gsi_nemsio_read_fraction to handle NMMB f_rain and f_ice -! 2015-06-10 s.liu - add gsi_nemsio_write_fraction to handle NMMB f_rain and f_ice -! 2016-02-05 s.liu - add fraction2variable and variable2fraction to handle NMMB f_rain and f_ice -! -! subroutines included: -! sub gsi_nemsio_open -! sub gsi_nemsio_update -! sub gsi_nemsio_close -! sub gsi_nemsio_read -! sub gsi_nemsio_read_fraction -! sub gsi_nemsio_write -! sub gsi_nemsio_write_fraction -! sub fraction2variable -! sub variable2fraction -! -! variable definitions: -! -! attributes: -! langauge: f90 -! machine: -! -!$$$ end documentation block - - use kinds, only: r_kind,i_kind,r_single - use nemsio_module, only: nemsio_gfile - use gridmod, only: nlon_regional,nlat_regional - implicit none - - type(nemsio_gfile) :: gfile - save gfile - - real(r_single),allocatable::work_saved(:) - -! set default to private - private -! set subroutines to public - public :: gsi_nemsio_open - public :: gsi_nemsio_update - public :: gsi_nemsio_close - public :: gsi_nemsio_read - public :: gsi_nemsio_read_fraction - public :: gsi_nemsio_write - public :: gsi_nemsio_write_fraction - -contains - - subroutine gsi_nemsio_open(file_name,iostatus,message,mype,mype_io,ierr) -!$$$ subprogram documentation block -! . . . . -! subprogram: gsi_nemsio_open -! pgrmmr: -! -! abstract: -! -! program history log: -! 2009-08-04 lueken - added subprogram doc block -! -! input argument list: -! file_name -! iostatus -! message -! mype - mpi task id -! mype_io -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - use nemsio_module, only: nemsio_init,nemsio_open - implicit none - - character(*) ,intent(in ) :: file_name ! input file name - character(*) ,intent(in ) :: iostatus ! 'READ' for read only, 'rdwr' for read/write - character(*) ,intent(in ) :: message ! info to appear in write statement on status of file open - integer(i_kind),intent(in ) :: mype,mype_io - integer(i_kind),intent(out ) :: ierr - - integer(i_kind) iret - - if(mype==mype_io) then - call nemsio_init(iret=iret) - if(iret/=0) then - write(6,*)trim(message),' problem with nemsio_init, Status = ',iret - call stop2(74) - end if - ierr=0 - call nemsio_open(gfile,file_name,trim(iostatus),iret=iret) - if(iret/=0) then - write(6,*)trim(message),' problem opening file',trim(file_name),', Status = ',iret - ierr=1 - return - end if - end if - allocate(work_saved(nlon_regional*nlat_regional)) - - end subroutine gsi_nemsio_open - - subroutine gsi_nemsio_update(file_name,message,mype,mype_io) -!$$$ subprogram documentation block -! . . . . -! subprogram: gsi_nemsio_update -! pgrmmr: -! -! abstract: -! -! program history log: -! 2009-08-04 lueken - added subprogram doc block -! -! input argument list: -! file_name -! message -! mype - mpi task id -! mype_io -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - use nemsio_module, only: nemsio_init,nemsio_open,nemsio_getfilehead,nemsio_close,nemsio_setheadvar - use nemsio_module, only: nemsio_getheadvar - use constants, only: zero - use wrf_params_mod, only: preserve_restart_date - implicit none - - character(*) ,intent(in ) :: file_name ! input file name - character(*) ,intent(in ) :: message ! info to appear in write statement on status of file open - integer(i_kind),intent(in ) :: mype,mype_io - - integer(i_kind) iret,nrec - integer(i_kind) idate(7),jdate(7),nfhour,nfminute,nfsecondn,nfday,ihrst,idat(3) - integer(i_kind),dimension(8):: ida,jda - real(r_kind),dimension(5):: fha - integer(i_kind) im,jm,lm,nfsecondd,nframe,ntrac,nsoil,nmeta,ntimestep - logical extrameta - character(4) gdatatype,modelname - character(32) gtype - - if(mype==mype_io) then - call nemsio_init(iret=iret) - if(iret/=0) then - write(6,*)trim(message),' problem with nemsio_init, Status = ',iret - call stop2(74) - end if - call nemsio_open(gfile,file_name,'RDWR',iret=iret) - if(iret/=0) then - write(6,*)trim(message),' problem opening file',trim(file_name),', Status = ',iret - call stop2(74) - end if - call nemsio_getheadvar(gfile,'idat',idat,iret) - write(6,*)' check old idat after getheadvar, idat,iret=',idat,iret - call nemsio_getheadvar(gfile,'ihrst',ihrst,iret) - write(6,*)' check old ihrst after getheadvar, ihrst,iret=',ihrst,iret - call nemsio_getheadvar(gfile,'ntimestep',ntimestep,iret) - write(6,*)' check old ntimestep after getheadvar, ntimestep,iret=',ntimestep,iret - call nemsio_getfilehead(gfile,iret=iret,nrec=nrec,dimx=im,dimy=jm, & - dimz=lm,idate=idate,gdatatype=gdatatype,gtype=gtype,modelname=modelname, & - nfhour=nfhour,nfminute=nfminute,nfsecondn=nfsecondn,nfsecondd=nfsecondd, & - nfday=nfday, & - nframe=nframe,ntrac=ntrac,nsoil=nsoil,extrameta=extrameta,nmeta=nmeta) - - write(6,*)' in gsi_nemsio_update, guess yr,mn,dy,hr,fhr=',idate(1:4),nfhour - fha=zero ; ida=0 ; jda=0 - fha(2)=nfhour - ida(1)=idate(1) ! year - ida(2)=idate(2) ! month - ida(3)=idate(3) ! day - ida(4)=0 ! time zone - ida(5)=idate(4) ! hour - call w3movdat(fha,ida,jda) - jdate(1)=jda(1) ! new year - jdate(2)=jda(2) ! new month - jdate(3)=jda(3) ! new day - jdate(4)=jda(5) ! new hour - jdate(5)=0 ! new minute - jdate(6)=0 ! new scaled seconds - jdate(7)=idate(7) ! new seconds multiplier - nfhour=0 ! new forecast hour - nfminute=0 - nfsecondn=0 - ntimestep=0 - - if(.not.preserve_restart_date) then - - call nemsio_setheadvar(gfile,'idate',jdate,iret) - write(6,*)' after setheadvar, jdate,iret=',jdate,iret - call nemsio_setheadvar(gfile,'nfhour',nfhour,iret) - write(6,*)' after setheadvar, nfhour,iret=',nfhour,iret - call nemsio_setheadvar(gfile,'nfminute',nfminute,iret) - write(6,*)' after setheadvar, nfminute,iret=',nfminute,iret - call nemsio_setheadvar(gfile,'nfsecondn',nfsecondn,iret) - write(6,*)' after setheadvar, nfsecondn,iret=',nfsecondn,iret - -! - idat(3)=jdate(1) ! forecast starting year - idat(2)=jdate(2) ! forecast starting month - idat(1)=jdate(3) ! forecast starting day - ihrst=jdate(4) ! forecast starting hour (0-23) - call nemsio_setheadvar(gfile,'idat',idat,iret) - write(6,*)' after setheadvar, idat,iret=',idat,iret - call nemsio_setheadvar(gfile,'ihrst',ihrst,iret) - write(6,*)' after setheadvar, ihrst,iret=',ihrst,iret - call nemsio_setheadvar(gfile,'ntimestep',ntimestep,iret) - write(6,*)' after setheadvar, ntimestep,iret=',ntimestep,iret - - end if - - -! Following is diagnostic to check if date updated: - - call nemsio_getfilehead(gfile,iret=iret,nrec=nrec,dimx=im,dimy=jm, & - dimz=lm,idate=idate,gdatatype=gdatatype,gtype=gtype,modelname=modelname, & - nfhour=nfhour,nfminute=nfminute,nfsecondn=nfsecondn,nfsecondd=nfsecondd, & - nfday=nfday, & - nframe=nframe,ntrac=ntrac,nsoil=nsoil,extrameta=extrameta,nmeta=nmeta) - write(6,*)' in gsi_nemsio_update, analysis yr,mn,dy,hr,fhr=',idate(1:4),nfhour - call nemsio_getheadvar(gfile,'idat',idat,iret) - write(6,*)' check new idat after getheadvar, idat,iret=',idat,iret - call nemsio_getheadvar(gfile,'ihrst',ihrst,iret) - write(6,*)' check new ihrst after getheadvar, ihrst,iret=',ihrst,iret - call nemsio_getheadvar(gfile,'ntimestep',ntimestep,iret) - write(6,*)' check new ntimestep after getheadvar, ntimestep,iret=',ntimestep,iret - call nemsio_close(gfile,iret=iret) - if(preserve_restart_date) write(6,*)' RESTART DATE PRESERVED FOR SHORT FORECASTS' - if(iret/=0) then - write(6,*)trim(message),' problem closing file',trim(file_name),', Status = ',iret - call stop2(74) - end if - - end if - - end subroutine gsi_nemsio_update - - subroutine gsi_nemsio_close(file_name,message,mype,mype_io) -!$$$ subprogram documentation block -! . . . . -! subprogram: gsi_nemsio_close -! pgrmmr: -! -! abstract: -! -! program history log: -! 2009-08-04 lueken - added subprogram doc block -! -! input argument list: -! file_name -! message -! mype - mpi task id -! mype_io -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - - use nemsio_module, only: nemsio_close - implicit none - - character(*) ,intent(in ) :: file_name ! input file name - character(*) ,intent(in ) :: message ! info to appear in write statement on status of file open - integer(i_kind),intent(in ) :: mype,mype_io - - integer(i_kind) iret - - if(mype==mype_io) then - call nemsio_close(gfile,iret=iret) - if(iret/=0) then - write(6,*)trim(message),' problem closing file',trim(file_name),', Status = ',iret - call stop2(74) - end if - end if - deallocate(work_saved) - - end subroutine gsi_nemsio_close - - subroutine gsi_nemsio_read(varname,vartype,gridtype,lev,var,mype,mype_io,good_var) -!$$$ subprogram documentation block -! . . . . -! subprogram: gsi_nemsio_read -! pgrmmr: parrish -! -! abstract: intermediate level routine to read nmmb model fields using nems_io. -! the desired field is retrieved from the previously opened file as a -! full 2d horizontal field, then interpolated to the analysis grid -! from the nmmb model grid. finally, the 2d field is scattered from -! processor mype_io to subdomains in output array var. -! a copy of the original field on the nmmb grid is saved internally in array -! work_saved in case this field is to be updated by the analysis -! increment in a call to gsi_nemsio_write immediately after the call to -! gsi_nemsio_read. -! -! program history log: -! 2009-08-04 lueken - added subprogram doc block -! 2010-01-22 parrish - added optional variable good_var to detect read errors in calling program -! and have option to avoid program stop. -! 2013-10-25 todling - reposition ltosi and others to commvars -! -! input argument list: -! varname,vartype,gridtype - descriptors for variable to be retrieved from nmmb file -! lev - vertical level number -! mype - mpi task id -! mype_io - mpi task where field is read from disk -! good_var - optional, on input, set to .false. if present(good_var) then error stop is -! bypassed and good_var is returned .true. for successful read, .false. otherwise. -! -! output argument list: -! var - for successful read, contains desired variable on subdomains. -! good_var - see above -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - - use mpimod, only: mpi_rtype,mpi_comm_world,ierror,mpi_integer4 - use gridmod, only: lat2,lon2,nlon,nlat - use gridmod, only: ijn_s,displs_s,itotsub - use general_commvars_mod, only: ltosi_s,ltosj_s - use nemsio_module, only: nemsio_readrecv - use mod_nmmb_to_a, only: nmmb_h_to_a,nmmb_v_to_a - implicit none - - character(*) ,intent(in ) :: varname,vartype,gridtype ! gridtype='H' or 'V' - integer(i_kind),intent(in ) :: lev ! vertical level of desired variable - real(r_kind) ,intent( out) :: var(lat2*lon2) - integer(i_kind),intent(in ) :: mype,mype_io - logical,optional,intent(inout):: good_var - - integer(i_kind) i,iret,j,mm1,n - real(r_kind) work(itotsub) - real(r_kind) work_a(nlat,nlon) - real(r_single) work_b(nlon_regional*nlat_regional) - logical good_var_loc - - mm1=mype+1 - - if(mype==mype_io) then - -! read field from file with nemsio - - call nemsio_readrecv(gfile,trim(varname),trim(vartype),lev,work_b,iret=iret) - if(iret==0) then - work_saved=work_b - -! interpolate to analysis grid - - if(trim(gridtype)=='H') call nmmb_h_to_a(work_b,work_a) - if(trim(gridtype)=='V') call nmmb_v_to_a(work_b,work_a) - - -! scatter to subdomains - - do n=1,itotsub - i=ltosi_s(n) - j=ltosj_s(n) - work(n)=work_a(i,j) - end do - end if - end if - call mpi_bcast(iret,1,mpi_integer4,mype_io,mpi_comm_world,ierror) - good_var_loc=.true. - if(iret/=0) then - good_var_loc=.false. - if(mype==0) then - write(6,*)' problem reading varname=',trim(varname),', vartype=',trim(vartype),', Status = ',iret - if(.not.present(good_var)) call stop2(74) - end if - end if - if(present(good_var)) good_var=good_var_loc - - if(good_var_loc) & - call mpi_scatterv(work,ijn_s,displs_s,mpi_rtype, & - var,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) - - end subroutine gsi_nemsio_read - - subroutine gsi_nemsio_read_fraction(varname_frain,varname_fice,varname_clwmr,varname_t, & - vartype,lev,var_qi,var_qs,var_qr,var_qw,mype,mype_io,good_var) -!$$$ subprogram documentation block -! . . . . -! subprogram: gsi_nemsio_read_fraction -! pgrmmr: Shun Liu -! -! abstract: copy from gsi_nemsio_read. To read in NMMB f_rain, f_ice, f_rime and -! T together and then convert to rain water mixing ratio and snow -! mixing ratio -! -! program history log: - -! 2015-06-5 S.Liu - read in f_rain, f_ice, f_rimef and T -! 2016-02-10 S.Liu - remove gridtype if-test since all variables are in mass point -! -! input argument list: -! varname,vartype,gridtype - descriptors for variable to be retrieved from -! nmmb file -! lev - vertical level number -! mype - mpi task id -! mype_io - mpi task where field is read from disk -! good_var - optional, on input, set to .false. if present(good_var) then -! error stop is -! bypassed and good_var is returned .true. for successful read, -! .false. otherwise. -! -! output argument list: -! var - for successful read, contains desired variable on subdomains. -! good_var - see above -! -! attributes: -! language: f90 -! machine: -! - -!$$$ end documentation block - use mpimod, only: mpi_rtype,mpi_comm_world,ierror,mpi_integer4 - use gridmod, only: lat2,lon2,nlon,nlat - use gridmod, only: ijn_s,displs_s,itotsub - use general_commvars_mod, only: ltosi_s,ltosj_s - use nemsio_module, only: nemsio_readrecv - use mod_nmmb_to_a, only: nmmb_h_to_a,nmmb_v_to_a - implicit none - - character(*) ,intent(in ) :: vartype ! gridtype='H' or 'V' - character(*) ,intent(in ) :: varname_frain, varname_fice, varname_clwmr, varname_t ! gridtype='H' or 'V' - integer(i_kind),intent(in ) :: lev ! vertical level of desired variable - - real(r_kind) ,intent( out) :: var_qi(lat2*lon2) - real(r_kind) ,intent( out) :: var_qs(lat2*lon2) - real(r_kind) ,intent( out) :: var_qr(lat2*lon2) - real(r_kind) ,intent( out) :: var_qw(lat2*lon2) - - integer(i_kind),intent(in ) :: mype,mype_io - logical,optional,intent(inout):: good_var - - integer(i_kind) i,iret,j,mm1,n - - real(r_kind) work_qi(itotsub) - real(r_kind) work_qs(itotsub) - real(r_kind) work_qr(itotsub) - real(r_kind) work_qw(itotsub) - - real(r_kind) work_a_qi(nlat,nlon) - real(r_kind) work_a_qs(nlat,nlon) - real(r_kind) work_a_qr(nlat,nlon) - real(r_kind) work_a_qw(nlat,nlon) - - real(r_single) work_b_frain(nlon_regional*nlat_regional) - real(r_single) work_b_fice(nlon_regional*nlat_regional) - real(r_single) work_b_clwmr(nlon_regional*nlat_regional) - real(r_single) work_b_t(nlon_regional*nlat_regional) - - real(r_single) work_b_qi(nlon_regional*nlat_regional) - real(r_single) work_b_qs(nlon_regional*nlat_regional) - real(r_single) work_b_qr(nlon_regional*nlat_regional) - real(r_single) work_b_qw(nlon_regional*nlat_regional) - - real(r_single) :: t, f_ice, f_rain, wc, qi, qs, qr, qw - logical good_var_loc - - mm1=mype+1 - - if(mype==mype_io) then - -! read field from file with nemsio - - call nemsio_readrecv(gfile,trim(varname_frain),trim(vartype),lev,work_b_frain,iret=iret) - call nemsio_readrecv(gfile,trim(varname_fice),trim(vartype),lev,work_b_fice,iret=iret) - call nemsio_readrecv(gfile,trim(varname_clwmr),trim(vartype),lev,work_b_clwmr,iret=iret) - call nemsio_readrecv(gfile,trim(varname_t),trim(vartype),lev,work_b_t,iret=iret) - - do n=1,nlon_regional*nlat_regional - t=work_b_t(n) - f_rain=work_b_frain(n) - f_ice=work_b_fice(n) - wc=work_b_clwmr(n) - call fraction2variable(t,f_ice,f_rain,wc,qi,qs,qr,qw) - work_b_qi(n)=qi - work_b_qs(n)=qs - work_b_qr(n)=qr - work_b_qw(n)=qw - end do - - if(iret==0) then -! work_saved=work_b - -! interpolate to analysis grid - - call nmmb_h_to_a(work_b_qi,work_a_qi) - call nmmb_h_to_a(work_b_qs,work_a_qs) - call nmmb_h_to_a(work_b_qr,work_a_qr) - call nmmb_h_to_a(work_b_qw,work_a_qw) - - -! scatter to subdomains - - do n=1,itotsub - i=ltosi_s(n) - j=ltosj_s(n) - work_qi(n)=work_a_qi(i,j) - work_qs(n)=work_a_qs(i,j) - work_qr(n)=work_a_qr(i,j) - work_qw(n)=work_a_qw(i,j) - end do - end if - end if - - call mpi_bcast(iret,1,mpi_integer4,mype_io,mpi_comm_world,ierror) - good_var_loc=.true. - if(iret/=0) then - good_var_loc=.false. - if(mype==0) then - write(6,*)' problem reading varname=',trim(varname_frain),', vartype=',trim(vartype),', Status = ',iret - if(.not.present(good_var)) call stop2(74) - end if - end if - if(present(good_var)) good_var=good_var_loc - - if(good_var_loc) then - call mpi_scatterv(work_qi,ijn_s,displs_s,mpi_rtype, & - var_qi,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) - call mpi_scatterv(work_qs,ijn_s,displs_s,mpi_rtype, & - var_qs,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) - call mpi_scatterv(work_qr,ijn_s,displs_s,mpi_rtype, & - var_qr,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) - call mpi_scatterv(work_qw,ijn_s,displs_s,mpi_rtype, & - var_qw,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) - end if - - end subroutine gsi_nemsio_read_fraction - subroutine gsi_nemsio_write(varname,vartype,gridtype,lev,var,mype,mype_io,add_saved) -!$$$ subprogram documentation block -! . . . . -! subprogram: gsi_nemsio_write -! pgrmmr: -! -! abstract: -! -! program history log: -! 2009-08-04 lueken - added subprogram doc block -! 2013-10-25 todling - reposition ltosi and others to commvars -! -! input argument list: -! varname,vartype,gridtype -! lev -! add_saved -! mype - mpi task id -! mype_io -! -! output argument list: -! var -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - - use mpimod, only: mpi_rtype,mpi_comm_world,ierror - use gridmod, only: lat2,lon2,nlon,nlat,lat1,lon1 - use gridmod, only: ijn,displs_g,itotsub,iglobal - use general_commvars_mod, only: ltosi,ltosj - use nemsio_module, only: nemsio_writerecv - use mod_nmmb_to_a, only: nmmb_a_to_h,nmmb_a_to_v - implicit none - - character(*) ,intent(in ) :: varname,vartype,gridtype ! gridtype='H' or 'V' - integer(i_kind),intent(in ) :: lev ! vertical level of desired variable - real(r_kind) ,intent(in ) :: var(lat2,lon2) - integer(i_kind),intent(in ) :: mype,mype_io - logical ,intent(in ) :: add_saved - - integer(i_kind) i,iret,j,mm1,n - real(r_kind) work(itotsub),work_sub(lat1,lon1) - real(r_kind) work_a(nlat,nlon) - real(r_single) work_b(nlon_regional*nlat_regional) - - mm1=mype+1 - - do i=1,lon1 - do j=1,lat1 - work_sub(j,i)=var(j+1,i+1) - end do - end do - call mpi_gatherv(work_sub,ijn(mm1),mpi_rtype, & - work,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) - if(mype==mype_io) then - do n=1,iglobal - i=ltosi(n) - j=ltosj(n) - work_a(i,j)=work(n) - end do - if(trim(gridtype)=='H') call nmmb_a_to_h(work_a,work_b) - if(trim(gridtype)=='V') call nmmb_a_to_v(work_a,work_b) - if(add_saved) work_b=work_b+work_saved - call nemsio_writerecv(gfile,trim(varname),trim(vartype),lev,work_b,iret=iret) - if(iret/=0) then - write(6,*)' problem writing varname=',trim(varname),', vartype=',trim(vartype),', Status = ',iret - call stop2(74) - end if - end if - - end subroutine gsi_nemsio_write - - subroutine gsi_nemsio_write_fraction(varname_frain,varname_fice,vartype,lev,var_t,var_i,var_r,var_l,mype,mype_io) -!$$$ subprogram documentation block -! . . . . -! subprogram: gsi_nemsio_write_fraction -! pgrmmr: Shun Liu -! -! abstract: -! -! program history log: -! 2015-05-12 S.Liu - copy from gsi_nemsio_write and modify to handle NMMB hydrometor fraction variable -! -! input argument list: -! varname,vartype,gridtype -! lev -! add_saved -! mype - mpi task id -! mype_io -! -! output argument list: -! var_frain, var_fice -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - - use mpimod, only: mpi_rtype,mpi_comm_world,ierror - use gridmod, only: lat2,lon2,nlon,nlat,lat1,lon1 - use gridmod, only: ijn,displs_g,itotsub,iglobal - use general_commvars_mod, only: ltosi,ltosj - use nemsio_module, only: nemsio_writerecv - use mod_nmmb_to_a, only: nmmb_a_to_h,nmmb_a_to_v - implicit none - - character(*) ,intent(in ) :: varname_frain,varname_fice,vartype ! gridtype='H' or 'V' - integer(i_kind),intent(in ) :: lev ! vertical level of desired variable - real(r_kind) ,intent(in ) :: var_i(lat2,lon2), var_r(lat2,lon2), var_l(lat2,lon2), var_t(lat2,lon2) - integer(i_kind),intent(in ) :: mype,mype_io -! logical ,intent(in ) :: add_saved - - integer(i_kind) i,iret,j,mm1,n - real(r_kind) work_t(itotsub),work_sub_t(lat1,lon1) - real(r_kind) work_a_t(nlat,nlon) - real(r_single) work_b_t(nlon_regional*nlat_regional) - - real(r_kind) work_i(itotsub),work_sub_i(lat1,lon1) - real(r_kind) work_a_i(nlat,nlon) - real(r_single) work_b_i(nlon_regional*nlat_regional) - - real(r_kind) work_r(itotsub),work_sub_r(lat1,lon1) - real(r_kind) work_a_r(nlat,nlon) - real(r_single) work_b_r(nlon_regional*nlat_regional) - - real(r_kind) work_l(itotsub),work_sub_l(lat1,lon1) - real(r_kind) work_a_l(nlat,nlon) - real(r_single) work_b_l(nlon_regional*nlat_regional) - - real(r_single) work_b_frain(nlon_regional*nlat_regional) - real(r_single) work_b_fice(nlon_regional*nlat_regional) - real(r_single) t,qfi,qfr,qfw,f_rain,f_ice - - mm1=mype+1 - - do i=1,lon1 - do j=1,lat1 - work_sub_t(j,i)=var_t(j+1,i+1) - work_sub_i(j,i)=var_i(j+1,i+1) - work_sub_r(j,i)=var_r(j+1,i+1) - work_sub_l(j,i)=var_l(j+1,i+1) - end do - end do -! write(6,*)'writeout1', maxval(work_sub_t),maxval(work_sub_i),maxval(work_sub_r) - call mpi_gatherv(work_sub_t,ijn(mm1),mpi_rtype, & - work_t,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) - call mpi_gatherv(work_sub_i,ijn(mm1),mpi_rtype, & - work_i,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) - call mpi_gatherv(work_sub_r,ijn(mm1),mpi_rtype, & - work_r,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) - call mpi_gatherv(work_sub_l,ijn(mm1),mpi_rtype, & - work_l,ijn,displs_g,mpi_rtype,mype_io,mpi_comm_world,ierror) -! write(6,*)'writeout2', maxval(work_t),maxval(work_i),maxval(work_r) - if(mype==mype_io) then - do n=1,iglobal - i=ltosi(n) - j=ltosj(n) - work_a_t(i,j)=work_t(n) - work_a_i(i,j)=work_i(n) - work_a_r(i,j)=work_r(n) - work_a_l(i,j)=work_l(n) - end do -! write(6,*)'writeout3', maxval(work_a_r),maxval(work_a_l) - - call nmmb_a_to_h(work_a_t,work_b_t) - call nmmb_a_to_h(work_a_i,work_b_i) - call nmmb_a_to_h(work_a_r,work_b_r) - call nmmb_a_to_h(work_a_l,work_b_l) - -! if(trim(gridtype)=='V') call nmmb_a_to_v(work_a_t,work_b_i) -! if(trim(gridtype)=='V') call nmmb_a_to_v(work_a_i,work_b_i) -! if(trim(gridtype)=='V') call nmmb_a_to_v(work_a_r,work_b_r) -! if(trim(gridtype)=='V') call nmmb_a_to_v(work_a_l,work_b_l) - -! if(add_saved) work_b_t=work_b_t+work_saved_t -! if(add_saved) work_b_i=work_b_i+work_saved_i -! if(add_saved) work_b_r=work_b_r+work_saved_r -! if(add_saved) work_b_l=work_b_l+work_saved_l -! write(6,*)'writeout4', maxval(work_b_r),maxval(work_b_l) -! write(6,*)'writeout44',nlon_regional,nlat_regional,nlon,nlat - do n=1,nlon_regional*nlat_regional - t=work_b_t(n) - qfi=work_b_i(n) - qfr=work_b_r(n) - qfw=work_b_l(n) - call variable2fraction(t, qfi, qfr, qfw, f_ice, f_rain) - work_b_frain(n)=f_rain - work_b_fice(n)=f_ice -! work_b_frain(n)=qfr -! work_b_fice(n)=qfw - end do - - call nemsio_writerecv(gfile,trim(varname_frain),trim(vartype),lev,work_b_frain,iret=iret) - call nemsio_writerecv(gfile,trim(varname_fice),trim(vartype),lev,work_b_fice,iret=iret) -! write(6,*)'writeout5', maxval(work_b_frain),maxval(work_b_fice) - - if(iret/=0) then - write(6,*)' problem writing varname=',trim(varname_frain),', vartype=',trim(vartype),', Status = ',iret - call stop2(74) - end if - end if - - end subroutine gsi_nemsio_write_fraction - - Subroutine fraction2variable(t,f_ice,f_rain, wc, qi,qs,qr,qw) - -!$$$ subprogram documentation block -! . . . . -! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor -! analysis -! -! PRGMMR: Shun Liu ORG: EMC/NCEP DATE: 2015-05-28 -! -! ABSTRACT: -! This subroutine fraction to qi, qs, qr, qw -! -! PROGRAM HISTORY LOG: -! 2015-05-28 Shun Liu Add NCO document block -! 2016-06-21 Shun Liu give number precisio and remove f_rimef -! -! -! input argument list: -! mype - processor ID that does this IO -! -! output argument list: -! -! USAGE: -! INTPUT: -! t - sensible temperature -! f_ice - fraction of condensate in form of ice -! f_rain - fraction of liquid water in form of rain -! f_rimef - ratio of total ice growth to deposition groth -! OUTPUT -! qi - cloud ice mixing ratio -! qs - large ice mixing ratio -! qr - rain mixing ratio -! qw - cloud water mixing ratio -! -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: WCOSS at NOAA/ESRL - college park, DC -! -!$$$ - - use kinds, only: r_kind,r_single - - real(r_single) t, qi,qs, qr, qw, wc - real(r_single) f_ice, f_rain - real(r_single),parameter:: epsq=1.e-12_r_single - real(r_single),parameter:: tice=233.15_r_single,ticek=273.15_r_single - real(r_single),parameter:: tice_mix=243.15_r_single - real(r_single) ::t1,t2, coef1, coef2, coef - - - qi=0.0_r_single; qs=0.0_r_single; qr=0.0_r_single; qw=0.0_r_single - if(wc > 0.0_r_single) then - - if(f_ice>1.0_r_single) f_ice=1.0_r_single - if(f_ice<0.0_r_single) f_ice=0.0_r_single - if(f_rain>1.0_r_single) f_rain=1.0_r_single - if(f_rain<0.0_r_single) f_rain=0.0_r_single - - qi=0.05_r_single*wc*f_ice - qs=0.95_r_single*wc*f_ice - - if(t<=tice_mix)then - t1=tice_mix - t2=tice - coef1=0.05_r_single - coef2=0.10_r_single - coef=(t-t2)/(t1-t2)*coef1+(t-t1)/(t2-t1)*coef2 - qi=coef*wc*f_ice - qs=(1.0_r_single-coef)*wc*f_ice - end if - -!* do not consider frime at the moment - qr=wc*(1.0_r_single-f_ice)*f_rain - qw=wc*(1.0_r_single-f_ice)*(1.0_r_single-f_rain) - end if - - end subroutine fraction2variable - - - subroutine variable2fraction(t, qi, qr, qw, f_ice, f_rain) - -!$$$ subprogram documentation block -! . . . . -! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor analysis -! -! PRGMMR: Shun Liu ORG: EMC/NCEP DATE: 2012-10-24 -! -! ABSTRACT: -! This subroutine qi qr qw to fraction -! -! PROGRAM HISTORY LOG: -! 2013-10-18 Shun Liu Add NCO document block -! 2015-11-16 Shun Liu move from gsdcldanalysis4nmmb.F90 to this module -! 2016-06-21 Shun Liu give number precisio -! -! -! input argument list: -! mype - processor ID that does this IO -! -! output argument list: -! -! USAGE: -! INPUT -! qi - cloud ice mixing ratio -! qr - rain mixing ratio -! qw - cloud water mixing ratio -! OUTPUT: -! f_ice - fraction of condensate in form of ice -! f_rain - fraction of liquid water in form of rain -! f_rimef - ratio of total ice growth to deposition groth -! -! -! REMARKS: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: WCOSS at NOAA/ESRL - college park, DC -! -!$$$ - - use kinds, only: r_kind,r_single - - real(r_single) t, qi, qr, qw, wc, dum - real(r_single) f_ice, f_rain - real(r_single),parameter:: epsq=1.e-12_r_single - real(r_single),parameter:: tice=233.15_r_single,ticek=273.15_r_single - - wc=qi+qr+qw - if(wc > 0.0_r_single) then - if(qi rvaluv,svaluv -! in order to correctly pass wind variables. -! 2006-04-06 kleist - include both Jc formulations -! 2006-07-26 parrish - correct inconsistency in computation of space and time derivatives of q -! currently, if derivatives computed, for q it is normalized q, but -! should be mixing ratio. -! 2006-07-26 parrish - add strong constraint initialization option -! 2007-03-19 tremolet - binning of observations -! 2007-04-13 tremolet - split jo from other components of intall -! 2007-06-04 derber - use quad precision to get reproducibility over number of processors -! 2008-11-27 todling - add tendencies for FOTO support and new interface to int's -! 2009-01-08 todling - remove reference to ozohead -! 2009-03-23 meunier - Add call to intlag (lagrangian observations) -! 2010-01-11 zhang,b - Bug fix: bias predictors need to be accumulated over nbins -! 2010-03-24 zhu - change the interfaces of intt,intrad,intpcp for generalizing control variable -! 2010-05-13 todling - harmonized interfaces to int* routines when it comes to state_vector (add only's) -! 2010-06-13 todling - add intco call -! 2010-10-15 pagowski - add intpm2_5 call -! 2010-10-20 hclin - added aod -! 2011-02-20 zhu - add intgust,intvis,intpblh calls -! 2013-05-20 zhu - add codes related to aircraft temperature bias correction -! 2014-06-18 carley/zhu - add lcbas and tcamt -! 2014-03-19 pondeca - add intwspd10m -! 2014-04-10 pondeca - add inttd2m,intmxtm,intmitm,intpmsl -! 2014-05-07 pondeca - add inthowv -! 2015-07-10 pondeca - add intcldch -! 2016-03-07 pondeca - add intuwnd10m,intvwnd10m -! -! input argument list: -! ibin -! yobs -! sval - solution on grid -! sbias -! rval -! qpred -! -! output argument list: -! rval - RHS on grid -! qpred -! -! remarks: -! 1) if strong initialization, then svalt, svalp, svaluv -! are all grid fields after strong initialization. -! -! 2) The two interfaces to the int-routines should be temporary. -! In the framework of the 4dvar-code, foto can be re-implemented as -! an approximate M and M' to the model matrices in 4dvar. Once that -! is done, the int-routines should no longer need the time derivatives. -! (Todling) -! 3) Notice that now (2010-05-13) int routines handle non-essential -! variables internally; also, when pointers non-existent, int routines -! simply return (Todling). -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ -use kinds, only: r_kind,i_kind,r_quad -use jfunc, only: nrclen,nsclen,npclen,ntclen -use bias_predictors, only: predictors -use intaodmod, only: intaod -use inttmod, only: intt -use intwmod, only: intw -use intpsmod, only: intps -use intpwmod, only: intpw -use intqmod, only: intq -use intradmod, only: intrad -use inttcpmod, only: inttcp -use intgpsmod, only: intgps -use intrwmod, only: intrw -use intspdmod, only: intspd -use intsstmod, only: intsst -use intdwmod, only: intdw -use intpcpmod, only: intpcp -use intozmod, only: intozlay -use intozmod, only: intozlev -use intcomod, only: intco -use intpm2_5mod, only: intpm2_5 -use intpm10mod, only: intpm10 -use intlagmod, only: intlag -use intgustmod, only: intgust -use intvismod, only: intvis -use intpblhmod, only: intpblh -use intwspd10mmod, only: intwspd10m -use inttd2mmod, only: inttd2m -use intmxtmmod, only: intmxtm -use intmitmmod, only: intmitm -use intpmslmod, only: intpmsl -use inthowvmod, only: inthowv -use inttcamtmod, only: inttcamt -use intlcbasmod, only: intlcbas -use intcldchmod, only: intcldch -use intuwnd10mmod, only: intuwnd10m -use intvwnd10mmod, only: intvwnd10m -use gsi_bundlemod, only: gsi_bundle -use gsi_bundlemod, only: gsi_bundlegetpointer - -use m_obsHeadBundle, only: obsHeadBundle -implicit none - -! Declare passed variables -integer(i_kind) , intent(in) :: ibin -type(obsHeadBundle), intent(in) :: yobs -type(gsi_bundle), intent(in ) :: sval -type(predictors), intent(in ) :: sbias -type(gsi_bundle), intent(inout) :: rval -real(r_quad),dimension(max(1,nrclen)), intent(inout) :: qpred - -! Declare local variables - - -!****************************************************************************** - -! RHS for conventional temperatures - if (ntclen>0) then - call intt(yobs%t,rval,sval,qpred(nsclen+npclen+1:nrclen),sbias%predt) - else - call intt(yobs%t,rval,sval) - end if - -! RHS for precipitable water - call intpw(yobs%pw,rval,sval) - -! RHS for conventional moisture - call intq(yobs%q,rval,sval) - -! RHS for conventional winds - call intw(yobs%w,rval,sval) - -! RHS for lidar winds - call intdw(yobs%dw,rval,sval) - -! RHS for radar winds - call intrw(yobs%rw,rval,sval) - -! RHS for wind speed observations - call intspd(yobs%spd,rval,sval) - -! RHS for ozone observations - call intozlay(yobs%oz ,rval,sval) - call intozlev(yobs%o3l,rval,sval) - -! RHS for carbon monoxide - call intco(yobs%colvk,rval,sval) - -! RHS for pm2_5 - call intpm2_5(yobs%pm2_5,rval,sval) - -! RHS for pm10 - call intpm10(yobs%pm10,rval,sval) - -! RHS for surface pressure observations - call intps(yobs%ps,rval,sval) - -! RHS for MSLP obs for TCs - call inttcp(yobs%tcp,rval,sval) - -! RHS for conventional sst observations - call intsst(yobs%sst,rval,sval) - -! RHS for GPS local observations - call intgps(yobs%gps,rval,sval) - -! RHS for conventional lag observations - call intlag(yobs%lag,rval,sval,ibin) - -! RHS calculation for radiances - call intrad(yobs%rad,rval,sval,qpred(1:nsclen),sbias%predr) - -! RHS calculation for precipitation - call intpcp(yobs%pcp,rval,sval) - -! RHS calculation for AOD - call intaod(yobs%aero,rval,sval) - -! RHS for conventional gust observations - call intgust(yobs%gust,rval,sval) - -! RHS for conventional vis observations - call intvis(yobs%vis,rval,sval) - -! RHS for conventional pblh observations - call intpblh(yobs%pblh,rval,sval) - -! RHS for conventional wspd10m observations - call intwspd10m(yobs%wspd10m,rval,sval) - -! RHS for conventional td2m observations - call inttd2m(yobs%td2m,rval,sval) - -! RHS for conventional mxtm observations - call intmxtm(yobs%mxtm,rval,sval) - -! RHS for conventional mitm observations - call intmitm(yobs%mitm,rval,sval) - -! RHS for conventional pmsl observations - call intpmsl(yobs%pmsl,rval,sval) - -! RHS for conventional howv observations - call inthowv(yobs%howv,rval,sval) - -! RHS for tcamt observations - call inttcamt(yobs%tcamt,rval,sval) - -! RHS for lcbas observations - call intlcbas(yobs%lcbas,rval,sval) - -! RHS for cldch observations - call intcldch(yobs%cldch,rval,sval) - -! RHS for conventional uwnd10m observations - call intuwnd10m(yobs%uwnd10m,rval,sval) - -! RHS for conventional vwnd10m observations - call intvwnd10m(yobs%vwnd10m,rval,sval) - -! Take care of background error for bias correction terms - -return -end subroutine intjo_ - -end module intjomod diff --git a/src/m_obsHeadBundle.F90 b/src/m_obsHeadBundle.F90 deleted file mode 100644 index 56013d34b..000000000 --- a/src/m_obsHeadBundle.F90 +++ /dev/null @@ -1,362 +0,0 @@ -module m_obsHeadBundle -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_obsHeadBundle -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2015-08-27 -! -! abstract: obsHeadBundle replaces type::obs_handle and variable obsmod::yobs. -! -! program history log: -! 2015-08-27 j guo - added this document block -! 2015-09-03 j guo - moved "yobs", and its construction and destruction -! here, to use them when and where yobs is needed. -! . In particular, setupyobs.f90 is included here as a -! module procedure create_(). And a destroy_() has been -! added, to clean up after any use of create_(). -! 2015-09-03 j guo - changed create_() from a function to a subroutine. -! . removed internal dependency to nobs_bins. -! 2016-05-04 j guo - added 9 new obs-types, to a total of 33 obs-types -! 2016-07-26 j guo - merged in the earlier proram history log (setupyobs). -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! Earlier program history log: -! -! subprogram: setupyobs -! prgmmr: tremolet -! -! abstract: Setup observation vectors (ie the "y" the in "H(x)-y" ) -! In 3D-Var, it contains all observations, in 4D-Var, each -! y contains all the observations in a given time slot. -! -! program history log: -! 2007-04-17 tremolet - initial code -! 2009-01-08 todling - remove reference to ozohead -! 2009-03-05 meunier - add pointer to lagrangean data -! 2009-08-11 lueken - updated documentation -! 2010-04-22 tangborn - updated reference to co -! 2010-07-10 todling - add aerosols pointer -! 2010-10-15 pagowski - add pm2_5 pointer -! 2011-02-19 zhu - add gust,vis,pblh pointers -! 2014-03-19 pondeca - add wspd10m -! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl -! 2014-05-07 pondeca - add howv -! 2014-06-20 carley/zhu - add tcamt and lcbas pointers -! 2015-07-10 pondeca - add cldch -! 2016-03-17 pondeca - add uwnd10m and vwnd10m (see setupuwnd10m) - - -! module interface: - - use m_obsNode , only: obsNode - - use m_psNode , only: psNode ! 1 - use m_tNode , only: tNode ! 2 - use m_wNode , only: wNode ! 3 - use m_qNode , only: qNode ! 4 - use m_spdNode , only: spdNode ! 5 - use m_rwNode , only: rwNode ! 6 - use m_dwNode , only: dwNode ! 7 - use m_sstNode , only: sstNode ! 8 - use m_pwNode , only: pwNode ! 9 - use m_pcpNode , only: pcpNode ! 10 - use m_ozNode , only: ozNode ! 11 - use m_o3lNode , only: o3lNode ! 12 - use m_gpsNode , only: gpsNode ! 13 - use m_radNode , only: radNode ! 14 - use m_tcpNode , only: tcpNode ! 15 - use m_lagNode , only: lagNode ! 16 - use m_colvkNode, only: colvkNode ! 17 - use m_aeroNode , only: aeroNode ! 18 - use m_aerolNode, only: aerolNode ! 19 - use m_pm2_5Node, only: pm2_5Node ! 20 - use m_gustNode , only: gustNode ! 21 - use m_visNode , only: visNode ! 22 - use m_pblhNode , only: pblhNode ! 23 - - use m_wspd10mNode, only: wspd10mNode ! 24 - use m_td2mNode , only: td2mNode ! 25 - use m_mxtmNode , only: mxtmNode ! 26 - use m_mitmNode , only: mitmNode ! 27 - use m_pmslNode , only: pmslNode ! 28 - use m_howvNode , only: howvNode ! 29 - use m_tcamtNode, only: tcamtNode ! 30 - use m_lcbasNode, only: lcbasNode ! 31 - - use m_pm10Node , only: pm10Node ! 32 - use m_cldchNode, only: cldchNode ! 33 - use m_uwnd10mNode, only: uwnd10mNode ! 35 - use m_vwnd10mNode, only: vwnd10mNode ! 36 - - use m_obsLList , only: obsLList_headNode - - implicit none - private ! except - - public :: obsHeadBundle ! data structure - - ! Create()/Destroy() pair, for rank-1 pointers with alloc()/dealloc(). - public :: obsHeadBundle_create - public :: obsHeadBundle_destroy - - interface obsHeadBundle_create ; module procedure create_; end interface - interface obsHeadBundle_destroy; module procedure destroy_; end interface - - ! init()/clean() pair, for allocated scalar objects. - public :: obsHeadBundle_init - public :: obsHeadBundle_clean - - interface obsHeadBundle_init ; module procedure init_; end interface - interface obsHeadBundle_clean; module procedure clean_; end interface - - type obsHeadBundle - ! obsHeadBundle is a replacement of obs_handle. It is implemented as a - ! snap-shot projection of the actual objects managed by m_obsdiags, and - ! to be used on demands, closed to where and when a such bundle is - ! needed. - !private - class(obsNode),pointer:: ps => null() ! 1 - class(obsNode),pointer:: t => null() ! 2 - class(obsNode),pointer:: w => null() ! 3 - class(obsNode),pointer:: q => null() ! 4 - class(obsNode),pointer:: spd => null() ! 5 - class(obsNode),pointer:: rw => null() ! 6 - class(obsNode),pointer:: dw => null() ! 7 - class(obsNode),pointer:: sst => null() ! 8 - class(obsNode),pointer:: pw => null() ! 9 - class(obsNode),pointer:: pcp => null() ! 10 - class(obsNode),pointer:: oz => null() ! 11 - class(obsNode),pointer:: o3l => null() ! 12 - class(obsNode),pointer:: gps => null() ! 13 - class(obsNode),pointer:: rad => null() ! 14 - class(obsNode),pointer:: tcp => null() ! 15 - class(obsNode),pointer:: lag => null() ! 16 - class(obsNode),pointer:: colvk => null() ! 17 - class(obsNode),pointer:: aero => null() ! 18 - class(obsNode),pointer:: aerol => null() ! 19 - class(obsNode),pointer:: pm2_5 => null() ! 20 - class(obsNode),pointer:: gust => null() ! 21 - class(obsNode),pointer:: vis => null() ! 22 - class(obsNode),pointer:: pblh => null() ! 23 - class(obsNode),pointer:: wspd10m => null() ! 24 - class(obsNode),pointer:: td2m => null() ! 25 - class(obsNode),pointer:: mxtm => null() ! 26 - class(obsNode),pointer:: mitm => null() ! 27 - class(obsNode),pointer:: pmsl => null() ! 28 - class(obsNode),pointer:: howv => null() ! 29 - class(obsNode),pointer:: tcamt => null() ! 30 - class(obsNode),pointer:: lcbas => null() ! 31 - class(obsNode),pointer:: pm10 => null() ! 32 - class(obsNode),pointer:: cldch => null() ! 33 - class(obsNode),pointer:: uwnd10m => null() ! 35 - class(obsNode),pointer:: vwnd10m => null() ! 36 - - end type obsHeadBundle - -! Usecases: -! -! (1) yobs(1:nobs_bins) - an array of obsHeadBundle, as yobs(:) has been used -! so far. -! -! use gsi_4dvar, only: nobs_bins -! ... -! type(obsHeadBundle),pointer,dimension(:):: yobs ! declaration -! ... -! call obsHeadBundle_create(yobs,nobs_bins) -! ... -! call obsHeadBundle_destroy(yobs) ! clean() then deallocation -! -! (2) yobs of a given bin - initialized where it is needed. -! -! use gsi_4dvar, only: nobs_bins -! ... -! type(obsHeadBundle):: yobs_ibin ! declaration/instanciation -! ... -! do ibin=1,nobs_bins -! call obsHeadBundle_init(yobs_ibin,ibin) ! initialization -! ... -! call obsHeadBundle_clean(yobs_ibin) ! cleaning -! enddo -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='m_obsHeadBundle' - -#include "myassert.H" - -contains -!--------------------------------------------- -subroutine create_(yobs,nbins) - use kinds, only: i_kind - implicit none - type(obsHeadBundle),pointer,dimension(:):: yobs - integer(kind=i_kind),intent(in):: nbins - - integer(i_kind):: ibin - allocate(yobs(nbins)) - do ibin=1,size(yobs) - call init_(yobs(ibin),ibin) - enddo -return -end subroutine create_ - -!--------------------------------------------- -subroutine destroy_(yobs) - use kinds, only: i_kind - implicit none - type(obsHeadBundle),pointer,dimension(:),intent(inout):: yobs - - integer(i_kind):: ibin - do ibin=1,size(yobs) - call clean_(yobs(ibin)) - enddo - deallocate(yobs) -return -end subroutine destroy_ - -!--------------------------------------------- -subroutine init_(yobs,ibin) - !use m_obsdiags, only: ps_headNode - !use m_obsdiags, only: obsllist_ - !use m_obsLList, only: obsLList_head - !use m_psNode , only: psNode_typecast ! = 1 - - use m_obsdiags, only: pshead ! = 1 - use m_obsdiags, only: thead ! = 2 - use m_obsdiags, only: whead ! = 3 - use m_obsdiags, only: qhead ! = 4 - use m_obsdiags, only: spdhead ! = 5 - use m_obsdiags, only: rwhead ! = 6 - use m_obsdiags, only: dwhead ! = 7 - use m_obsdiags, only: ssthead ! = 8 - use m_obsdiags, only: pwhead ! = 9 - use m_obsdiags, only: pcphead ! =10 - use m_obsdiags, only: ozhead ! =11 - use m_obsdiags, only: o3lhead ! =12 - use m_obsdiags, only: gpshead ! =13 - use m_obsdiags, only: radhead ! =14 - use m_obsdiags, only: tcphead ! =15 - use m_obsdiags, only: laghead ! =16 - use m_obsdiags, only: colvkhead ! =17 - use m_obsdiags, only: aerohead ! =18 - use m_obsdiags, only: aerolhead ! =19 - use m_obsdiags, only: pm2_5head ! =20 - use m_obsdiags, only: gusthead ! =21 - use m_obsdiags, only: vishead ! =22 - use m_obsdiags, only: pblhhead ! =23 - - use m_obsdiags, only: wspd10mhead ! =24 - use m_obsdiags, only: td2mhead ! =25 - use m_obsdiags, only: mxtmhead ! =26 - use m_obsdiags, only: mitmhead ! =27 - use m_obsdiags, only: pmslhead ! =28 - use m_obsdiags, only: howvhead ! =29 - use m_obsdiags, only: tcamthead ! =30 - use m_obsdiags, only: lcbashead ! =31 - use m_obsdiags, only: pm10head ! =32 - use m_obsdiags, only: cldchhead ! =33 - use m_obsdiags, only: uwnd10mhead ! =35 - use m_obsdiags, only: vwnd10mhead ! =36 - - use kinds, only: i_kind - use mpeu_util, only: assert_ - implicit none - type(obsHeadBundle),intent(out):: yobs - integer(i_kind),intent(in ):: ibin - - ASSERT(1<=ibin) - ASSERT(ibin<=size( pshead)) ! = 1 - ASSERT(ibin<=size( thead)) ! = 2 - ASSERT(ibin<=size( whead)) ! = 3 - ASSERT(ibin<=size( qhead)) ! = 4 - ASSERT(ibin<=size( spdhead)) ! = 5 - ASSERT(ibin<=size( rwhead)) ! = 6 - ASSERT(ibin<=size( dwhead)) ! = 7 - ASSERT(ibin<=size( ssthead)) ! = 8 - ASSERT(ibin<=size( pwhead)) ! = 9 - ASSERT(ibin<=size( pcphead)) ! =10 - ASSERT(ibin<=size( ozhead)) ! =11 - ASSERT(ibin<=size( o3lhead)) ! =12 - ASSERT(ibin<=size( gpshead)) ! =13 - ASSERT(ibin<=size( radhead)) ! =14 - ASSERT(ibin<=size( tcphead)) ! =15 - ASSERT(ibin<=size( laghead)) ! =16 - ASSERT(ibin<=size(colvkhead)) ! =17 - ASSERT(ibin<=size( aerohead)) ! =18 - ASSERT(ibin<=size(aerolhead)) ! =19 - ASSERT(ibin<=size(pm2_5head)) ! =20 - ASSERT(ibin<=size( gusthead)) ! =21 - ASSERT(ibin<=size( vishead)) ! =22 - ASSERT(ibin<=size( pblhhead)) ! =23 - ASSERT(ibin<=size(wspd10mhead))! =24 - ASSERT(ibin<=size( td2mhead)) ! =25 - ASSERT(ibin<=size( mxtmhead)) ! =26 - ASSERT(ibin<=size( mitmhead)) ! =27 - ASSERT(ibin<=size( pmslhead)) ! =28 - ASSERT(ibin<=size( howvhead)) ! =29 - ASSERT(ibin<=size(tcamthead)) ! =30 - ASSERT(ibin<=size(lcbashead)) ! =31 - ASSERT(ibin<=size( pm10head)) ! =32 - ASSERT(ibin<=size(cldchhead)) ! =33 - ASSERT(ibin<=size(uwnd10mhead))! =35 - ASSERT(ibin<=size(vwnd10mhead))! =36 - - yobs%ps => obsLList_headNode( pshead(ibin)) ! = 1 - yobs%t => obsLList_headNode( thead(ibin)) ! = 2 - yobs%w => obsLList_headNode( whead(ibin)) ! = 3 - yobs%q => obsLList_headNode( qhead(ibin)) ! = 4 - yobs%spd => obsLList_headNode( spdhead(ibin)) ! = 5 - yobs%rw => obsLList_headNode( rwhead(ibin)) ! = 6 - yobs%dw => obsLList_headNode( dwhead(ibin)) ! = 7 - yobs%sst => obsLList_headNode( ssthead(ibin)) ! = 8 - yobs%pw => obsLList_headNode( pwhead(ibin)) ! = 9 - yobs%pcp => obsLList_headNode( pcphead(ibin)) ! =10 - yobs%oz => obsLList_headNode( ozhead(ibin)) ! =11 - yobs%o3l => obsLList_headNode( o3lhead(ibin)) ! =12 - yobs%gps => obsLList_headNode( gpshead(ibin)) ! =13 - yobs%rad => obsLList_headNode( radhead(ibin)) ! =14 - yobs%tcp => obsLList_headNode( tcphead(ibin)) ! =15 - yobs%lag => obsLList_headNode( laghead(ibin)) ! =16 - yobs%colvk => obsLList_headNode(colvkhead(ibin)) ! =17 - yobs%aero => obsLList_headNode( aerohead(ibin)) ! =18 - yobs%aerol => obsLList_headNode(aerolhead(ibin)) ! =19 - yobs%pm2_5 => obsLList_headNode(pm2_5head(ibin)) ! =20 - yobs%gust => obsLList_headNode( gusthead(ibin)) ! =21 - yobs%vis => obsLList_headNode( vishead(ibin)) ! =22 - yobs%pblh => obsLList_headNode( pblhhead(ibin)) ! =23 - - yobs%wspd10m => obsLList_headNode(wspd10mhead(ibin))! =24 - yobs%td2m => obsLList_headNode( td2mhead(ibin)) ! =25 - yobs%mxtm => obsLList_headNode( mxtmhead(ibin)) ! =26 - yobs%mitm => obsLList_headNode( mitmhead(ibin)) ! =27 - yobs%pmsl => obsLList_headNode( pmslhead(ibin)) ! =28 - yobs%howv => obsLList_headNode( howvhead(ibin)) ! =29 - yobs%tcamt => obsLList_headNode(tcamthead(ibin)) ! =30 - yobs%lcbas => obsLList_headNode(lcbashead(ibin)) ! =31 - - yobs%pm10 => obsLList_headNode( pm10head(ibin)) ! =32 - yobs%cldch => obsLList_headNode(cldchhead(ibin)) ! =33 - yobs%uwnd10m => obsLList_headNode(uwnd10mhead(ibin))! =35 - yobs%vwnd10m => obsLList_headNode(vwnd10mhead(ibin))! =36 -return -end subroutine init_ - -!--------------------------------------------- -subroutine clean_(yobs) - implicit none - type(obsHeadBundle),intent(out):: yobs - type(obsHeadBundle) tmpobs -! yobs=obsHeadBundle() - yobs = tmpobs -end subroutine clean_ - -end module m_obsHeadBundle diff --git a/src/m_obsNodeTypeManager.F90 b/src/m_obsNodeTypeManager.F90 deleted file mode 100644 index 85a194889..000000000 --- a/src/m_obsNodeTypeManager.F90 +++ /dev/null @@ -1,362 +0,0 @@ -module m_obsNodeTypeManager -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_obsNodeTypeManager -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2015-08-13 -! -! abstract: obsNode type manager, as an enumerated type molder. -! -! program history log: -! 2015-08-13 j guo - added this document block. -! 2016-05-18 j guo - finished its initial polymorphic implementation, -! with total 33 obs-types. -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - - use obsmod, only: nobs_type - - use obsmod, only: iobsType_ps => i_ps_ob_type - use obsmod, only: iobsType_t => i_t_ob_type - use obsmod, only: iobsType_w => i_w_ob_type - use obsmod, only: iobsType_q => i_q_ob_type - use obsmod, only: iobsType_spd => i_spd_ob_type - use obsmod, only: iobsType_rw => i_rw_ob_type - use obsmod, only: iobsType_dw => i_dw_ob_type - use obsmod, only: iobsType_sst => i_sst_ob_type - use obsmod, only: iobsType_pw => i_pw_ob_type - use obsmod, only: iobsType_pcp => i_pcp_ob_type - use obsmod, only: iobsType_oz => i_oz_ob_type - use obsmod, only: iobsType_o3l => i_o3l_ob_type - use obsmod, only: iobsType_gps => i_gps_ob_type - use obsmod, only: iobsType_rad => i_rad_ob_type - use obsmod, only: iobsType_tcp => i_tcp_ob_type - use obsmod, only: iobsType_lag => i_lag_ob_type - use obsmod, only: iobsType_colvk => i_colvk_ob_type - use obsmod, only: iobsType_aero => i_aero_ob_type - use obsmod, only: iobsType_aerol => i_aerol_ob_type - use obsmod, only: iobsType_pm2_5 => i_pm2_5_ob_type - use obsmod, only: iobsType_gust => i_gust_ob_type - use obsmod, only: iobsType_vis => i_vis_ob_type - use obsmod, only: iobsType_pblh => i_pblh_ob_type - - use obsmod, only: iobsType_wspd10m => i_wspd10m_ob_type - use obsmod, only: iobsType_uwnd10m => i_uwnd10m_ob_type - use obsmod, only: iobsType_vwnd10m => i_vwnd10m_ob_type - - use obsmod, only: iobsType_td2m => i_td2m_ob_type - use obsmod, only: iobsType_mxtm => i_mxtm_ob_type - use obsmod, only: iobsType_mitm => i_mitm_ob_type - use obsmod, only: iobsType_pmsl => i_pmsl_ob_type - use obsmod, only: iobsType_howv => i_howv_ob_type - use obsmod, only: iobsType_tcamt => i_tcamt_ob_type - use obsmod, only: iobsType_lcbas => i_lcbas_ob_type - - use obsmod, only: iobsType_pm10 => i_pm10_ob_type - use obsmod, only: iobsType_cldch => i_cldch_ob_type - - use m_psNode , only: psNode ! 1 - use m_tNode , only: tNode ! 2 - use m_wNode , only: wNode ! 3 - use m_qNode , only: qNode ! 4 - use m_spdNode , only: spdNode ! 5 - use m_rwNode , only: rwNode ! 6 - use m_dwNode , only: dwNode ! 7 - use m_sstNode , only: sstNode ! 8 - use m_pwNode , only: pwNode ! 9 - use m_pcpNode , only: pcpNode ! 10 - use m_ozNode , only: ozNode ! 11 - use m_o3lNode , only: o3lNode ! 12 - use m_gpsNode , only: gpsNode ! 13 - use m_radNode , only: radNode ! 14 - use m_tcpNode , only: tcpNode ! 15 - use m_lagNode , only: lagNode ! 16 - use m_colvkNode, only: colvkNode ! 17 - use m_aeroNode , only: aeroNode ! 18 - use m_aerolNode, only: aerolNode ! 19 - use m_pm2_5Node, only: pm2_5Node ! 20 - use m_gustNode , only: gustNode ! 21 - use m_visNode , only: visNode ! 22 - use m_pblhNode , only: pblhNode ! 23 - use m_wspd10mNode, only: wspd10mNode ! 24 - use m_uwnd10mNode, only: uwnd10mNode - use m_vwnd10mNode, only: vwnd10mNode - - use m_td2mNode , only: td2mNode ! 25 - use m_mxtmNode , only: mxtmNode ! 26 - use m_mitmNode , only: mitmNode ! 27 - use m_pmslNode , only: pmslNode ! 28 - use m_howvNode , only: howvNode ! 29 - use m_tcamtNode, only: tcamtNode ! 30 - use m_lcbasNode, only: lcbasNode ! 31 - use m_pm10Node , only: pm10Node ! 32 - use m_cldchNode, only: cldchNode ! 33 - - use kinds, only: i_kind - use m_obsNode, only: obsNode - use mpeu_util, only: perr,die - - implicit none - private ! except - public :: nobs_type - public :: obsNode_typeMold - public :: obsNode_typeIndex - - interface obsNode_typeMold; module procedure & - index2vmold_, & - vname2vmold_ - end interface - interface obsNode_typeIndex; module procedure & - vmold2index_, & - vname2index_ - end interface - - type(psNode ), target, save:: ps_mold ! 1 - type(tNode ), target, save:: t_mold ! 2 - type(wNode ), target, save:: w_mold ! 3 - type(qNode ), target, save:: q_mold ! 4 - type(spdNode ), target, save:: spd_mold ! 5 - type(rwNode ), target, save:: rw_mold ! 6 - type(dwNode ), target, save:: dw_mold ! 7 - type(sstNode ), target, save:: sst_mold ! 8 - type(pwNode ), target, save:: pw_mold ! 9 - type(pcpNode ), target, save:: pcp_mold ! 10 - type(ozNode ), target, save:: oz_mold ! 11 - type(o3lNode ), target, save:: o3l_mold ! 12 - type(gpsNode ), target, save:: gps_mold ! 13 - type(radNode ), target, save:: rad_mold ! 14 - type(tcpNode ), target, save:: tcp_mold ! 15 - type(lagNode ), target, save:: lag_mold ! 16 - type(colvkNode), target, save:: colvk_mold ! 17 - type(aeroNode ), target, save:: aero_mold ! 18 - type(aerolNode), target, save:: aerol_mold ! 19 - type(pm2_5Node), target, save:: pm2_5_mold ! 20 - type(gustNode ), target, save:: gust_mold ! 21 - type(visNode ), target, save:: vis_mold ! 22 - type(pblhNode ), target, save:: pblh_mold ! 23 - - type(wspd10mNode), target, save:: wspd10m_mold ! 24 - type(uwnd10mNode), target, save:: uwnd10m_mold - type(vwnd10mNode), target, save:: vwnd10m_mold - - type( td2mNode), target, save:: td2m_mold ! 25 - type( mxtmNode), target, save:: mxtm_mold ! 26 - type( mitmNode), target, save:: mitm_mold ! 27 - type( pmslNode), target, save:: pmsl_mold ! 28 - type( howvNode), target, save:: howv_mold ! 29 - type( tcamtNode), target, save:: tcamt_mold ! 30 - type( lcbasNode), target, save:: lcbas_mold ! 31 - type( pm10Node), target, save:: pm10_mold ! 32 - type( cldchNode), target, save:: cldch_mold ! 33 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='m_obsNodeTypeManager' - -! UseCase 1: configuration of a single mold -! -! use m_obsNodeTypeManager, only: obsNode_typeMold -! use m_psNode, only: i_psNode -! ... -! allocate(psLList%mold, source=obsNode_typeMold(i_psNode)) -! or, for Fortran 2008 ALLOCATE() with MOLD= specifier -! allocate(psLList%mold, mold=obsNode_typeMold(i_psNode)) -! -! UseCase 2: configuration of molds in an array -! -! use m_obsLList, only: obsLList_moldConfig -! use m_obsNodeTypeManager, only: obsNode_typeMold -! ... -! do jtype=lbound(obsdiags,2),ubound(obsdiags,2) -! do ibin=lbound(obsdiags,1),ubound(obsdiags,1) -! call obsLList_moldConfig(obsdiags(ibin,jtype),mold=obsNode_typeMold(jtype)) -! enddo -! enddo -! - -contains -function vname2index_(vname) result(index_) - use mpeu_util, only: lowercase - implicit none - integer(i_kind):: index_ - character(len=*),intent(in):: vname - character(len=len(vname)):: vname_ - vname_=lowercase(vname) - - index_=0 ! a default return value, if the given name is unknown. - select case(vname_) - case("ps" , "[psnode]"); index_ = iobsType_ps - case("t" , "[tnode]"); index_ = iobsType_t - case("w" , "[wnode]"); index_ = iobsType_w - case("q" , "[qnode]"); index_ = iobsType_q - case("spd" , "[spdnode]"); index_ = iobsType_spd - case("rw" , "[rwnode]"); index_ = iobsType_rw - case("dw" , "[dwnode]"); index_ = iobsType_dw - case("sst" , "[sstnode]"); index_ = iobsType_sst - case("pw" , "[pwnode]"); index_ = iobsType_pw - case("pcp" , "[pcpnode]"); index_ = iobsType_pcp - case("oz" , "[oznode]"); index_ = iobsType_oz - case("o3l" , "[o3lnode]"); index_ = iobsType_o3l - case("gps" , "[gpsnode]"); index_ = iobsType_gps - case("rad" , "[radnode]"); index_ = iobsType_rad - case("tcp" , "[tcpnode]"); index_ = iobsType_tcp - case("lag" , "[lagnode]"); index_ = iobsType_lag - case("colvk","[colvknode]"); index_ = iobsType_colvk - case("aero" , "[aeronode]"); index_ = iobsType_aero - case("aerol","[aerolnode]"); index_ = iobsType_aerol - case("pm2_5","[pm2_5node]"); index_ = iobsType_pm2_5 - case("gust" , "[gustnode]"); index_ = iobsType_gust - case("vis" , "[visnode]"); index_ = iobsType_vis - case("pblh" , "[pblhnode]"); index_ = iobsType_pblh - - case("wspd10m", & - "[wspd10mnode]"); index_ = iobsType_wspd10m - case("uwnd10m", & - "[uwnd10mnode]"); index_ = iobsType_uwnd10m - case("vwnd10m", & - "[vwnd10mnode]"); index_ = iobsType_vwnd10m - - case("td2m" , "[td2mnode]"); index_ = iobsType_td2m - case("mxtm" , "[mxtmnode]"); index_ = iobsType_mxtm - case("mitm" , "[mitmnode]"); index_ = iobsType_mitm - case("pmsl" , "[pmslnode]"); index_ = iobsType_pmsl - case("howv" , "[howvnode]"); index_ = iobsType_howv - case("tcamt","[tcamtnode]"); index_ = iobsType_tcamt - case("lcbas","[lcbasnode]"); index_ = iobsType_lcbas - - case("pm10" , "[pm10node]"); index_ = iobsType_pm10 - case("cldch","[cldchnode]"); index_ = iobsType_cldch - - end select -end function vname2index_ - -function vmold2index_(mold) result(index_) - implicit none - integer(i_kind):: index_ - class(obsNode),target,intent(in):: mold - - index_=vname2index_(mold%mytype()) -end function vmold2index_ - -function vmold2index_select_(mold) result(index_) - implicit none - integer(i_kind):: index_ - class(obsNode),target,intent(in):: mold - - index_=0 - select type(mold) - type is( psNode); index_ = iobsType_ps - type is( tNode); index_ = iobsType_t - type is( wNode); index_ = iobstype_w - type is( qNode); index_ = iobstype_q - type is( spdNode); index_ = iobstype_spd - type is( rwNode); index_ = iobstype_rw - type is( dwNode); index_ = iobstype_dw - type is( sstNode); index_ = iobstype_sst - type is( pwNode); index_ = iobstype_pw - type is( pcpNode); index_ = iobstype_pcp - type is( ozNode); index_ = iobstype_oz - type is( o3lNode); index_ = iobstype_o3l - type is( gpsNode); index_ = iobstype_gps - type is( radNode); index_ = iobstype_rad - type is( tcpNode); index_ = iobstype_tcp - type is( lagNode); index_ = iobstype_lag - type is(colvkNode); index_ = iobstype_colvk - type is( aeroNode); index_ = iobstype_aero - type is(aerolNode); index_ = iobstype_aerol - type is(pm2_5Node); index_ = iobstype_pm2_5 - type is( gustNode); index_ = iobstype_gust - type is( visNode); index_ = iobstype_vis - type is( pblhNode); index_ = iobstype_pblh - - type is(wspd10mNode); index_ = iobsType_wspd10m - type is(uwnd10mNode); index_ = iobsType_uwnd10m - type is(vwnd10mNode); index_ = iobsType_vwnd10m - - type is( td2mNode); index_ = iobsType_td2m - type is( mxtmNode); index_ = iobsType_mxtm - type is( mitmNode); index_ = iobsType_mitm - type is( pmslNode); index_ = iobsType_pmsl - type is( howvNode); index_ = iobsType_howv - type is(tcamtNode); index_ = iobsType_tcamt - type is(lcbasNode); index_ = iobsType_lcbas - - type is( pm10Node); index_ = iobsType_pm10 - type is(cldchNode); index_ = iobsType_cldch - - end select -end function vmold2index_select_ - -function index2vmold_(i_obType) result(obsmold_) - implicit none - class(obsNode),pointer:: obsmold_ - integer(kind=i_kind),intent(in):: i_obType - - character(len=*),parameter:: myname_=myname//"::index2vmold_" - - obsmold_ => null() - select case(i_obType) - case(iobsType_ps ); obsmold_ => ps_mold - case(iobsType_t ); obsmold_ => t_mold - case(iobsType_w ); obsmold_ => w_mold - case(iobsType_q ); obsmold_ => q_mold - case(iobsType_spd ); obsmold_ => spd_mold - case(iobsType_rw ); obsmold_ => rw_mold - case(iobsType_dw ); obsmold_ => dw_mold - case(iobsType_sst ); obsmold_ => sst_mold - case(iobsType_pw ); obsmold_ => pw_mold - case(iobsType_pcp ); obsmold_ => pcp_mold - case(iobsType_oz ); obsmold_ => oz_mold - case(iobsType_o3l ); obsmold_ => o3l_mold - case(iobsType_gps ); obsmold_ => gps_mold - case(iobsType_rad ); obsmold_ => rad_mold - case(iobsType_tcp ); obsmold_ => tcp_mold - case(iobsType_lag ); obsmold_ => lag_mold - case(iobsType_colvk); obsmold_ => colvk_mold - case(iobsType_aero ); obsmold_ => aero_mold - case(iobsType_aerol); obsmold_ => aerol_mold - case(iobsType_pm2_5); obsmold_ => pm2_5_mold - case(iobsType_gust ); obsmold_ => gust_mold - case(iobsType_vis ); obsmold_ => vis_mold - case(iobsType_pblh ); obsmold_ => pblh_mold - - case(iobsType_wspd10m); obsmold_ => wspd10m_mold - case(iobsType_uwnd10m); obsmold_ => uwnd10m_mold - case(iobsType_vwnd10m); obsmold_ => vwnd10m_mold - - case(iobsType_td2m ); obsmold_ => td2m_mold - case(iobsType_mxtm ); obsmold_ => mxtm_mold - case(iobsType_mitm ); obsmold_ => mitm_mold - case(iobsType_pmsl ); obsmold_ => pmsl_mold - case(iobsType_howv ); obsmold_ => howv_mold - case(iobsType_tcamt); obsmold_ => tcamt_mold - case(iobsType_lcbas); obsmold_ => lcbas_mold - - case(iobsType_pm10 ); obsmold_ => pm10_mold - case(iobsType_cldch); obsmold_ => cldch_mold - - end select -end function index2vmold_ - -function vname2vmold_(vname) result(obsmold_) - implicit none - class(obsNode),pointer:: obsmold_ - character(len=*),intent(in):: vname - - character(len=*),parameter:: myname_=myname//"::vname2vmold_" - integer(kind=i_kind):: i_obType - - i_obType=vname2index_(vname) - obsmold_ => index2vmold_(i_obType) -end function vname2vmold_ - -end module m_obsNodeTypeManager diff --git a/src/m_obsdiagNode.F90 b/src/m_obsdiagNode.F90 deleted file mode 100644 index 896528e04..000000000 --- a/src/m_obsdiagNode.F90 +++ /dev/null @@ -1,1267 +0,0 @@ -module m_obsdiagNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_obsdiagNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: module of node type obs_diag and linked-list type obs_diags. -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial implementation. -! 2016-06-24 j.guo - Added support of using m_latlonRange to find a cluster -! latlonRange from (elat,elon) values of observations. -! . cleaned out some components from obsdiagNode, which -! were put in for debugging purposes. (%dlat,%dlon). -! . removed some earlier routines for debuggings and -! testings. e.g. lmock_() and obsnode_mock_(). -! . use a fixed miter size for both write_() and read_(), -! for a simpler control in the future. -! . renamed lsize_() to lcount_(). Then reimplemented a -! new lsize_() to separate different functionalities. -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use kinds , only: i_kind,r_kind - use obsmod, only: obs_diag - use obsmod, only: obs_diags - use mpeu_util, only: assert_,tell,warn,perr,die -#define _obsNode_ obs_diag -#define _obsLList_ obs_diags - implicit none - - private - ! Primery behaviors: - public:: obsdiagLList_reset ! destructor + initializer - public:: obsdiagLList_read ! reader, for input - public:: obsdiagLList_write ! writer, for otuput - public:: obsdiagLList_lsize ! size inquiry - public:: obsdiagLList_lcount ! size inquiry with recount - public:: obsdiagLList_lsort ! sort nodes according to their keys - public:: obsdiagLList_checksum! size consistency checking - public:: obsdiagLList_summary ! status report - - interface obsdiagLList_reset; module procedure lreset_; end interface - interface obsdiagLList_read ; module procedure lread_; end interface - interface obsdiagLList_checksum; module procedure & - lchecksum_ , & - lchecksum1_ , & - lchecksum2_ ; end interface - interface obsdiagLList_lsize ; module procedure lsize_ ; end interface - interface obsdiagLList_lcount ; module procedure lcount_ ; end interface - interface obsdiagLList_lsort ; module procedure lsort_ ; end interface - interface obsdiagLList_write ; module procedure lwrite_ ; end interface - interface obsdiagLList_summary; module procedure lsummary_; end interface - - ! Node lookup, secondary function with its searching component - public:: obsdiagLookup_build ! setup, its searching component - public:: obsdiagLookup_locate ! node lookup, with the searching component - public:: obsdiagLookup_clean ! clean, its searching component - - interface obsdiagLookup_build ; module procedure lbuild_; end interface - interface obsdiagLookup_locate; module procedure locate_; end interface - interface obsdiagLookup_clean ; module procedure lclean_; end interface - - public:: obsdiagLList_dump - interface obsdiagLList_dump; module procedure ldump_; end interface - - public:: obsdiagNode_append - interface obsdiagNode_append; module procedure obsNode_append_; end interface - public:: obsdiagNode_first - interface obsdiagNode_first ; module procedure obsNode_first_; end interface - public:: obsdiagNode_next - interface obsdiagNode_next ; module procedure obsNode_next_; end interface - - !public:: fptr_obsdiagNode - - type fptr_obsdiagNode - type(obs_diag),pointer:: node - end type fptr_obsdiagNode - - -#include "myassert.H" -#include "mytrace.H" - - character(len=*),parameter:: myname="m_obsdiagNode" - -contains -subroutine lwrite_(diagLL,iunit,luseonly,jiter,miter,jj_type,ii_bin,luseRange) - use m_latlonRange , only: latlonRange - use m_latlonRange , only: latlonRange_enclose - use mpeu_util, only: stdout - use mpeu_util, only: stdout_lead - implicit none - type(_obsLList_) ,intent(inout):: diagLL ! the linked list of data - integer(kind=i_kind),intent(in ):: iunit ! the output unit - logical ,intent(in ):: luseonly ! write only if(luse) - integer(kind=i_kind),intent(in ):: jiter ! diag width for the IO (or this iter) - integer(kind=i_kind),intent(in ):: miter ! diag width of the memory - integer(kind=i_kind),intent(in ):: jj_type, ii_bin - type(latlonRange),optional,intent(inout):: luseRange - - character(len=*),parameter:: myname_=myname//"::lwrite_" - integer(kind=i_kind):: iobs,kobs,lobs,mobs - integer(kind=i_kind):: istat - type(_obsNode_), pointer:: iNode - logical:: isluse_ -_ENTRY_(myname_) -!_TIMER_ON_(myname_) - - lobs=obsdiagLList_lcount(diagLL,luseonly=luseonly) - mobs=lobs - if(.not.luseonly) mobs=obsdiagLList_lsize(diagLL) - - call obsHeader_write_(iunit,ii_bin,jj_type,lobs,jiter,miter,istat) - if(istat/=0) then - call perr(myname_,'obsHeader_write_(), istat =',istat) - call perr(myname_,' iunit =',iunit) - call perr(myname_,' ii_bin =',ii_bin) - call perr(myname_,' jtype =',jj_type) - call perr(myname_,' jiter =',jiter) - call perr(myname_,' miter =',miter) - call perr(myname_,' total-luse-node, lobs =',lobs) - call perr(myname_,' total-all-node, mobs =',mobs) - call perr(myname_,' luseonly =',luseonly) - call die(myname_) - endif - - _TRACE_(myname_,'looping through obshead pointers') - - if(lobs<=0) then - !_TIMER_OFF_(myname_) - _EXIT_(myname_) - return - endif - - iobs=0 - kobs=0 - iNode => obsNode_first_(diagLL) - do while(associated(iNode)) - iobs=iobs+1 - isluse_=obsNode_isluse_(iNode) - if(isluse_ .or. .not.luseonly) then - - ! Update luseRange with a luse observation, for the lat-lon- - ! range on the current PE. - - if(isluse_ .and. present(luseRange)) & - call latlonRange_enclose(luseRange,iNode%elat,iNode%elon) - - ! Count it, then write the node out. Use of miter suggests a - ! fixed output size. - kobs=kobs+1 - call obsNode_write_(iNode,iunit,miter,istat) - if(istat/=0) then - call perr(myname_,'obsNode_write_(), istat =',istat) - call perr(myname_,' iunit =',iunit) - call perr(myname_,' jiter =',jiter) - call perr(myname_,' miter =',miter) - call perr(myname_,' ii_bin =',ii_bin) - call perr(myname_,' jtype =',jj_type) - call perr(myname_,'current-luse-node, kobs =',kobs) - call perr(myname_,' current-all-node, iobs =',iobs) - call perr(myname_,' total-luse-node, lobs =',lobs) - call perr(myname_,' total-all-node, mobs =',mobs) - call perr(myname_,' luseonly =',luseonly) - call die(myname_) - endif - endif - iNode => obsNode_next_(diagLL) - enddo - - ASSERT(kobs==lobs) - ASSERT(iobs==mobs) - -!_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine lwrite_ - -subroutine ldump_(diagLL,jiter) - use mpeu_util, only: stdout - implicit none - type(_obsLList_), intent(inout):: diagLL ! the list to dump - integer(i_kind ),optional,intent(in ):: jiter ! jiter of diagLL - - character(len=*),parameter:: myname_=myname//"::ldump_" - integer(kind=i_kind):: iobs,lobs,mobs - integer(kind=i_kind):: jiter_ - type(_obsNode_), pointer:: iNode - logical:: isluse_,ismuse_ -_ENTRY_(myname_) -!_TIMER_ON_(myname_) - jiter_=0 - if(present(jiter)) jiter_=jiter - - call lbuild_(diagLL) ! create a pointer array %lookup, sorted by (idv,iob,ich) - - lobs=0 - mobs=0 - do iobs=1,size(diagLL%lookup(:)) - iNode => diagLL%lookup(iobs)%ptr - - isluse_=obsNode_isluse_(iNode) - if(isluse_) lobs=lobs+1 - - ismuse_=jiter_>=1.and.jiter_<=size(iNode%muse) - if(ismuse_) ismuse_=iNode%muse(jiter_) - if(ismuse_) mobs=mobs+1 - - write(stdout,'(2x,2l1,3i8,2x,2f12.4)') isluse_,ismuse_, & - iNode%idv,iNode%iob,iNode%ich, iNode%elat,iNode%elon - enddo - write(stdout,'(2x,a,4i8)') '***',jiter_,size(diagLL%lookup(:)),lobs,mobs - call lclean_(diagLL) ! destroy the pointer array %lookup. - -!_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine ldump_ - -subroutine lread_(diagLL,iunit,redistr,jiter,miter,jj_type,ii_bin,jread,leadNode,ignore_iter) -!_TIMER_USE_ - use obsmod, only: lobserver - use obs_sensitivity, only: lobsensfc, lsensrecompute - implicit none - type(_obsLList_),intent(inout):: diagLL - integer(kind=i_kind),intent(in ):: iunit - logical ,intent(in ):: redistr - integer(kind=i_kind),intent(in ):: jiter - integer(kind=i_kind),intent(in ):: miter - integer(kind=i_kind),intent(in ):: jj_type, ii_bin - integer(kind=i_kind),intent( out):: jread - type(_obsNode_), pointer, intent(out):: leadNode - logical ,optional,intent(in ):: ignore_iter - - character(len=*),parameter:: myname_=myname//"::lread_" - integer(kind=i_kind):: ki,kj,kobs,kiter,miter_read - integer(kind=i_kind):: kk,istat - type(_obsNode_), pointer:: aNode - logical:: ignore_iter_ -_ENTRY_(myname_) -!_TIMER_ON_(myname_) -!call timer_ini(myname_) - ignore_iter_=.false. - if(present(ignore_iter)) ignore_iter_=ignore_iter - - call obsHeader_read_(iunit,ki,kj,kobs,kiter,miter_read,istat) - if(istat/=0) then - call perr(myname_,'obsHeader_read_(), istat =',istat) - call perr(myname_,' iunit =',iunit) - call die(myname_) - endif - - if(ki/=ii_bin .or. kj/=jj_type .or. miter/=miter_read) then - call perr(myname_,'obsHeader_read_(), unexpected header values (ii,jj,miter)') - call perr(myname_,' expecting miter =',miter) - call perr(myname_,' actual miter =',miter_read) - call perr(myname_,' expecting ii =',ii_bin) - call perr(myname_,' actual ii =',ki) - call perr(myname_,' expecting jj =',jj_type) - call perr(myname_,' actual jj =',kj) - call die(myname_) - endif - - if(.not.ignore_iter_) then - if (lobsensfc.and..not.lsensrecompute) then ! a backward iter - if(kiter/=miter) then - call perr(myname_,'obsHeader_read_(), unexpected header value, kiter =',kiter) - call perr(myname_,' expecting miter =',miter) - call perr(myname_,' lobsensfc =',lobsensfc) - call perr(myname_,' lsensrecompute =',lsensrecompute) - call die(myname_) - endif - - else if (lobserver) then ! a forward iter - if(kiter/=jiter-1) then - call perr(myname_,'obsHeader_read_(), unexpected header value, kiter =',kiter) - call perr(myname_,' expecting jiter-1 =',jiter-1) - call perr(myname_,' lobserver =',lobserver) - call die(myname_) - endif - - else - if(kiter/=jiter) then ! the same iter - call perr(myname_,'obsHeader_read_(), unexpected header value, kiter =',kiter) - call perr(myname_,' expecting jiter =',jiter) - call perr(myname_,' lobserver =',lobserver) - call die(myname_) - endif - endif - endif - jread=kiter - - - !-- construct an an_obsNode - leadNode => null() - aNode => obsNode_alloc_(miter) - do kk=1,kobs - !-- initialize an_obsNode from a file (iunit). Use of miter suggests a - !-- fixed input size. - call obsNode_read_(aNode,iunit,miter,istat,redistr=redistr) - if(istat<0) then - call perr(myname_,'obsNode_read_(), istat =',istat) - call perr(myname_,' redistr =',redistr) - call die(myname_) - endif - - ! istat <0: a failed read(aNode) - ! ==0: passed, thus an incomplete aNode - ! >0: a good aNode to keep - if(istat==0) cycle - if(redistr) call obsNode_setluse_(aNode) - - ! keep this obsNode in its linked-list, diagLL := obsdiags(jj,ii) - call obsNode_append_(diagLL,aNode) - !-- mark the beginning of this linked-list segment - if(.not.associated(leadNode)) leadNode => aNode - - !-- drop this aNode, to construct a new. This _alloc_ - ! ensures an aNode is not in anyway referencible to - ! the one that has been appended to the linked-list. - ! Then, a deep-deallocation of aNode is alwasy safe. - aNode => obsNode_alloc_(miter) - enddo ! < kobs > - call obsNode_dealloc_(aNode,deep=.true.) ! Clean up the malloc of aNode - -! ---------------------------------------------------------- -!call timer_fnl(myname_) -!_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine lread_ - -subroutine lreset_(diagLL) - implicit none - type(_obsLList_), intent(inout):: diagLL - - character(len=*),parameter:: myname_=myname//"::lreset_" - type(_obsNode_),pointer:: l_obsNode - type(_obsNode_),pointer:: n_obsNode - integer(kind=i_kind):: ip -_ENTRY_(myname_) - - l_obsNode => obsNode_first_(diagLL) - ip=0 - do while(associated(l_obsNode)) - ip=ip+1 - !_TRACEV_(myname_,'deallocating at ip =',ip) - !call obsNode_check_(myname_,l_obsNode) - ! Steps of forward resetting, - ! (1) hold the %next node, - ! (2) clean (leaving the %next node untouched, - ! (3) deallocate the current node, - ! (4) point the starting point to the %next node. - n_obsNode => obsNode_next_(diagLL) - call obsNode_dealloc_(l_obsNode,deep=.true.) - l_obsNode => n_obsNode - enddo - !n_obsNode => null() - !l_obsNode => null() - - diagLL%n_alloc = 0 - diagLL%head => null() - diagLL%tail => null() - if(allocated(diagLL%lookup)) deallocate(diagLL%lookup) - -_EXIT_(myname_) -return -end subroutine lreset_ - -subroutine lchecksum_(diagLL,leadNode,itype,ibin,sorted) -!$$$ subprogram documentation block -! . . . . -! subprogram: lchecksum_ -! prgmmr: J. Guo -! -! abstract: check the size values against a known counts. -! -! program history log: -! 2015-06-26 guo - -! -! input argument list: (see Fortran declarations below) -! -! output argument list: (see Fortran declarations below) -! -! attributes: -! language: f90/f95/f2003/f2008 -! machine: -! -!$$$ end documentation block - use mpeu_util, only: stdout - use mpeu_util, only: stdout_lead - implicit none - type(_obsLList_), intent(in):: diagLL - type(_obsNode_ ), pointer, optional, intent(in):: leadNode - integer(kind=i_kind),optional,intent(in ):: itype - integer(kind=i_kind),optional,intent(in ):: ibin - logical ,optional,intent(out):: sorted - - character(len=*),parameter:: myname_=MYNAME//"::lchecksum_" - integer(kind=i_kind):: jtype,jbin - integer(kind=i_kind):: mcount - integer(kind=i_kind):: nuse,nooo,ndup - integer(kind=i_kind),dimension(3):: ksum -!jtest -! logical:: lasso,lhead - -_ENTRY_(myname_) -!jtest -! ASSERT(present(leadNode)) -! lasso=associated(leadNode) -! lhead=associated(diagLL%head,leadNode) - - mcount=lcount_(diagLL,recount=.true.,nuse=nuse,nooo=nooo,ndup=ndup,ksum=ksum,leadNode=leadNode) - if(present(sorted)) sorted = nooo==0.and.ndup==0 - -!jtest -! if(mcount/=diagLL%n_alloc) then -! call perr(myname_,'checksum failed, mcount =',mcount) -! call perr(myname_,' diagLList%n_alloc =',diagLL%n_alloc) -! if(present(itype)) & -! call perr(myname_,' itype =',itype) -! if(present(ibin)) & -! call perr(myname_,' ibin =',ibin) -! call die(myname_) -! endif - - if(present(itype)) jtype=itype - if(present(ibin)) jbin =ibin -_EXIT_(myname_) -return -end subroutine lchecksum_ -subroutine lchecksum1_(diagLL,leadNode,itype) -!$$$ subprogram documentation block -! . . . . -! subprogram: lchecksum_ -! prgmmr: J. Guo -! -! abstract: check the size values against a known counts. -! -! program history log: -! 2015-06-26 guo - -! -! input argument list: (see Fortran declarations below) -! -! output argument list: (see Fortran declarations below) -! -! attributes: -! language: f90/f95/f2003/f2008 -! machine: -! -!$$$ end documentation block - implicit none - type(_obsLList_), dimension(:),intent(in):: diagLL - integer(kind=i_kind),optional,intent(in):: itype - type(fptr_obsdiagNode),optional,dimension(:),intent(in):: leadNode - - character(len=*),parameter:: myname_=MYNAME//"::lchecksum1_" - integer(kind=i_kind):: i -_ENTRY_(myname_) - if(present(leadNode)) then - ASSERT(size(diagLL)==size(leadNode)) - do i=1,size(diagLL) - call lchecksum_(diagLL(i),itype=itype,ibin=i,leadNode=leadNode(i)%node) - enddo - else - do i=1,size(diagLL) - call lchecksum_(diagLL(i),itype=itype,ibin=i) - enddo - endif -_EXIT_(myname_) -return -end subroutine lchecksum1_ -subroutine lchecksum2_(diagLL) -!$$$ subprogram documentation block -! . . . . -! subprogram: lchecksum_ -! prgmmr: J. Guo -! -! abstract: check the size values against a known counts. -! -! program history log: -! 2015-06-26 guo - -! -! input argument list: (see Fortran declarations below) -! -! output argument list: (see Fortran declarations below) -! -! attributes: -! language: f90/f95/f2003/f2008 -! machine: -! -!$$$ end documentation block - implicit none - type(_obsLList_), dimension(:,:),intent(in):: diagLL - - character(len=*),parameter:: myname_=MYNAME//"::lchecksum2_" - integer(kind=i_kind):: it,ib -_ENTRY_(myname_) - do it=1,size(diagLL,1) - do ib=1,size(diagLL,2) - call lchecksum_(diagLL(it,ib),itype=it,ibin=ib) - enddo - enddo -_EXIT_(myname_) -return -end subroutine lchecksum2_ - -subroutine lsummary_(diagLL,verbose) - implicit none - type(_obsLList_), intent(in):: diagLL - logical,optional, intent(in):: verbose - - character(len=*),parameter:: myname_=MYNAME//"::lsummary_" - type(_obsNode_ ), pointer:: iNode - type(_obsLList_), target :: tempLL - integer(kind=i_kind):: iobs_ - logical:: verbose_ - verbose_=.false. - if(present(verbose)) verbose_=verbose -_ENTRY_(myname_) - - if(verbose_) then - tempLL = diagLL - iobs_ = 0 - iNode => obsNode_first_(tempLL) - do while(associated(iNode)) - iobs_=iobs_+1 - call obsNode_show_(iNode,iobs_) - iNode => obsNode_next_(tempLL) - enddo - endif -_EXIT_(myname_) -return -end subroutine lsummary_ - -function lsize_(diagLL) result(lobs_) - implicit none - integer(kind=i_kind):: lobs_ - type(_obsLList_), target, intent(in):: diagLL - lobs_=diagLL%n_alloc -end function lsize_ - -function lcount_(diagLL,luseonly,recount,nuse,nooo,ndup,ksum,leadNode) result(lobs_) - use mpeu_util, only: assert_ - implicit none - integer(kind=i_kind):: lobs_ - type(_obsLList_), target, intent(in):: diagLL - logical , optional, intent(in):: luseonly - logical , optional, intent(in):: recount - integer(kind=i_kind),optional,intent(out):: nuse ! no. of luse - integer(kind=i_kind),optional,intent(out):: nooo ! no. out-of-orders - integer(kind=i_kind),optional,intent(out):: ndup ! no. duplicates - integer(kind=i_kind),optional,dimension(:),intent(out):: ksum ! key value sum - type(_obsNode_ ), pointer, optional, intent(in):: leadNode - - character(len=*),parameter:: myname_=myname//"::lcount_" - type(_obsNode_ ), pointer:: iNode - type(_obsLList_), target :: tempLL - integer(kind=i_kind):: nuse_ - integer(kind=i_kind):: k - integer(kind=i_kind),dimension(3) :: kprev - logical:: luseonly_,recount_,checksum_ -_ENTRY_(myname_) - - luseonly_=.false. - if(present(luseonly)) luseonly_=luseonly - recount_ =.false. - if(present(recount )) recount_ =recount - if(present(leadNode)) recount_ =.true. - - checksum_= present(nuse).or.present(nooo).or.present(ndup).or.present(ksum) - recount_ = recount_ .or. checksum_ - !if(.not.recount_) recount_ = checksum_ - - if(present(ksum)) then - ALWAYS_ASSERT( size(ksum)==size(kprev) ) - endif - - if(.not.(luseonly_.or.recount_)) then - lobs_=diagLL%n_alloc - - else ! recount through the list - tempLL = diagLL ! A copy of diagLL, such that diagLL can remain intent(in) - - lobs_ = 0 - nuse_ = 0 - - if(checksum_) call checksum_init_(kprev,nooo=nooo,ndup=ndup,ksum=ksum) - - iNode => obsNode_first_(tempLL,atNode=leadNode) - do while(associated(iNode)) - if(obsNode_isluse_(iNode)) nuse_=nuse_+1 - if(.not.luseonly_ .or. obsNode_isluse_(iNode)) lobs_=lobs_+1 - - if(checksum_) call checksum_add_(kprev, & - (/iNode%idv,iNode%iob,iNode%ich/),nooo=nooo,ndup=ndup,ksum=ksum) - - iNode => obsNode_next_(tempLL) - enddo - if(present(nuse)) nuse=nuse_ - endif - -_EXIT_(myname_) -return -contains -subroutine checksum_init_(kprev,nooo,ndup,ksum) - implicit none - integer(kind=i_kind),dimension(:),intent(out):: kprev - integer(kind=i_kind),optional,intent(out):: nooo - integer(kind=i_kind),optional,intent(out):: ndup - integer(kind=i_kind),optional,dimension(:),intent(out):: ksum - - kprev(:)= 0 - if(present(nooo)) nooo=0 - if(present(ndup)) ndup=0 - if(present(ksum)) ksum(:)=0 -end subroutine checksum_init_ -subroutine checksum_add_(kprev,knext,nooo,ndup,ksum) - implicit none - integer(kind=i_kind),dimension(:),intent(inout):: kprev - integer(kind=i_kind),dimension(:),intent(in ):: knext - integer(kind=i_kind),optional,intent(inout):: nooo - integer(kind=i_kind),optional,intent(inout):: ndup - integer(kind=i_kind),optional,dimension(:),intent(inout):: ksum - - k=compare_(kprev,knext) - if(present(nooo).and.k> 0) nooo=nooo+1 - if(present(ndup).and.k==0) ndup=ndup+1 - if(present(ksum)) ksum(:)=ksum(:)+knext(:) - kprev(:)=knext(:) -end subroutine checksum_add_ -end function lcount_ - -function obsNode_first_(diagLL,atNode) result(here_) - implicit none - type(_obsNode_ ), pointer :: here_ - type(_obsLList_), target, intent(inout):: diagLL - type(_obsNode_ ), optional, pointer,intent(in):: atNode - - character(len=*),parameter:: myname_=myname//"::obsNode_first_" -_ENTRY_(myname_) - !_TRACEV_(myname_,'%n_alloc =',diagLL%n_alloc) - !_TRACEV_(myname_,'associated(%head) =',associated(diagLL%head)) - here_ => diagLL%head - if(present(atNode)) here_=>atNode - diagLL%tail => here_ ! update the tail-node - - if(associated(here_)) call obsNode_check_(myname_,here_) -_EXIT_(myname_) -return -end function obsNode_first_ - -function obsNode_next_(diagLL,atNode) result(next_) - implicit none - type(_obsNode_ ), pointer :: next_ - type(_obsLList_), target, intent(inout):: diagLL - type(_obsNode_ ), optional, pointer,intent(in):: atNode - - character(len=*),parameter:: myname_=myname//"::obsNode_next_" -_ENTRY_(myname_) - next_ => diagLL%tail%next - if(present(atNode)) next_=>atNode%next - diagLL%tail => next_ ! update the tail-node -_EXIT_(myname_) -return -end function obsNode_next_ - -subroutine obsNode_append_(diagLL,targetNode) - ! Link the next node of the list to the given targetNode. The return - ! result is a pointer associated to the same targetNode. - use jfunc, only: miter - implicit none - type(_obsLList_), intent(inout):: diagLL - type(_obsNode_ ), target, intent(in):: targetNode - - character(len=*),parameter:: myname_=myname//"::obsNode_append_" - type(_obsNode_ ),pointer:: aNode -_ENTRY_(myname_) - if(.not.associated(diagLL%head)) then - ! this is a fresh starting -node- for this linked-list ... - diagLL%n_alloc = 1 - diagLL%head => targetNode - diagLL%tail => diagLL%head - - else - ! this is for a new next -node- from here ... - diagLL%n_alloc = diagLL%n_alloc +1 - diagLL%tail%next => targetNode - diagLL%tail => diagLL%tail%next - - !diagLL%tail%append(next_) - ! append(t,next_) - ! t%next => next_ - ! t => t%next - endif - if(associated(diagLL%tail)) diagLL%tail%next => null() - - aNode => diagLL%tail - ASSERT(lbound(aNode%muse ,1)==1.and.ubound(aNode%muse ,1)==miter+1) - ASSERT(lbound(aNode%nldepart,1)==1.and.ubound(aNode%nldepart,1)==miter+1) - ASSERT(lbound(aNode%tldepart,1)==1.and.ubound(aNode%tldepart,1)==miter ) - ASSERT(lbound(aNode%obssen ,1)==1.and.ubound(aNode%obssen ,1)==miter ) - aNode => null() - -_EXIT_(myname_) -return -end subroutine obsNode_append_ - -subroutine lsort_(diagLL,itype,ibin) -! lsort_: node-sort diagLL, to line-up nodes according to their keys -!_TIMER_USE_ -! use timermod , only: timer_ini,timer_fnl - !use mpeu_util, only: IndexSet - !use mpeu_util, only: IndexSort - !use mpeu_util, only: die - implicit none - type(_obsLList_) , intent(inout):: diagLL - integer(kind=i_kind),optional,intent(in):: itype,ibin - - character(len=*),parameter:: myname_=myname//'::lsort_' - integer(kind=i_kind):: i,nobs,mobs - logical:: sorted -_ENTRY_(myname_) -!_TIMER_ON_(myname_) -! call timer_ini(myname_) - - call lchecksum_(diagLL,itype=itype,ibin=ibin,sorted=sorted) - if(sorted) then - _EXIT_(myname_) - return - endif - - ! created a sorted table - call lbuild_(diagLL) - - nobs = diagLL%n_alloc - mobs = size(diagLL%lookup(:)) - ASSERT(nobs==mobs) - - ! rebuild the linked-list - diagLL%n_alloc=0 - diagLL%head => null() - diagLL%tail => null() - - ! rebuild the list according to the sorted table - do i=1,mobs - call obsNode_append_(diagLL,diagLL%lookup(i)%ptr) - enddo - ASSERT(nobs==diagLL%n_alloc) - if(associated(diagLL%tail)) then - ASSERT(.not.associated(diagLL%tail%next)) - endif - - ! discard the sorted table - call lclean_(diagLL) - - call lchecksum_(diagLL,itype=itype,ibin=ibin,sorted=sorted) - if(.not.sorted) then - call perr(myname_,'failed post-sorting lchecksum_(diagLL), sorted =',sorted) - if(present(itype)) & - call perr(myname_,' itype =',itype) - if(present(ibin )) & - call perr(myname_,' ibin =',ibin ) - call die(myname_) - endif - -! call timer_fnl(myname_) -!_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine lsort_ - -subroutine lbuild_(diagLL,leadNode,jiter) -!_TIMER_USE_ -! use timermod , only: timer_ini,timer_fnl - use mpeu_util, only: IndexSet - use mpeu_util, only: IndexSort - !use mpeu_util, only: die - implicit none - type(_obsLList_), intent(inout):: diagLL - type(_obsNode_ ), pointer, optional, intent(in):: leadNode - integer(i_kind) , optional, intent(in):: jiter - - character(len=*),parameter:: myname_=myname//'::lbuild_' - type(_obsNode_),pointer:: iNode,pNode - integer(kind=i_kind),allocatable,dimension(:):: indx,idv_,iob_,ich_ - integer(kind=i_kind):: i,m,n - integer(kind=i_kind):: idum - logical:: good -_ENTRY_(myname_) -!_TIMER_ON_(myname_) -! call timer_ini(myname_) - if(present(jiter)) idum=jiter - - ! Mark the leading node - iNode => null() - if(present(leadNode)) iNode => leadNode - if(.not.associated(iNode)) iNode => diagLL%head - - m=diagLL%n_alloc - if(m<0) call die(myname_,'unexpected diagLL, %n_alloc =',m) - - ! Count, starting from the leading node - n=0 - pNode => iNode - do while(associated(pNode)) - n=n+1 - pNode => pNode%next - enddo - - if(n>diagLL%n_alloc) then - call perr(myname_,'unexpected diagLL, %n_alloc =',m) - call die(myname_,' actual count =',n) - endif - - allocate(diagLL%lookup(n)) - allocate(indx(n),idv_(n),iob_(n),ich_(n)) - - associate(lookup => diagLL%lookup(:)) - ! Loop over the linked-list, to get keys. - i=0 - pNode => iNode - do while(associated(pNode)) - i=i+1 - if(i<=n) then - lookup(i)%ptr => pNode - idv_(i) = pNode%idv - iob_(i) = pNode%iob - ich_(i) = pNode%ich - !call obsNode_get(idv=idv_(i),iob=iob_(i),ich=ich_(i)) - endif - pNode => pNode%next - enddo - end associate - - ! sort %lookup(1:n), by its (idv,iob,ich) values - call IndexSet (indx) - call IndexSort(indx,ich_) - call IndexSort(indx,iob_) - call IndexSort(indx,idv_) - - associate(lookup => diagLL%lookup(:)) - lookup(1:n) = lookup(indx(1:n)) - end associate - - idv_(1:n) = idv_(indx(1:n)) - iob_(1:n) = iob_(indx(1:n)) - ich_(1:n) = ich_(indx(1:n)) - - associate(lookup => diagLL%lookup(:)) - good = .true. - do i=1,n - good = lookup(i)%ptr%idv==idv_(i) .and. & - lookup(i)%ptr%iob==iob_(i) .and. & - lookup(i)%ptr%ich==ich_(i) - if(.not.good) exit - enddo - - if(.not.good) then - call perr(myname_,'verification failed at %lookup(i)%ptr, i =',i) - call perr(myname_,' %ptr%idv =',lookup(i)%ptr%idv) - call perr(myname_,' idv_=',idv_(i)) - call perr(myname_,' %ptr%iob =',lookup(i)%ptr%iob) - call perr(myname_,' iob_=',iob_(i)) - call perr(myname_,' %ptr%ich =',lookup(i)%ptr%ich) - call perr(myname_,' ich_=',ich_(i)) - call die(myname_) - endif - end associate - - deallocate(indx,idv_,iob_,ich_) - -! call timer_fnl(myname_) -!_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine lbuild_ - -subroutine lclean_(diagLL) - implicit none - type(_obsLList_), intent(inout):: diagLL - - character(len=*),parameter:: myname_=myname//'::lclean_' - integer(kind=i_kind):: ier,i -_ENTRY_(myname_) - associate(lookup => diagLL%lookup(:)) - do i=1,size(lookup) - lookup(i)%ptr => null() - end do - end associate - deallocate(diagLL%lookup,stat=ier) - if(ier/=0) call die(myname_,'deallocate(diagLL%lookup), stat =',ier) -_EXIT_(myname_) -return -end subroutine lclean_ - -function locate_(diagLL,idv,iob,ich) result(here_) - use timermod , only: timer_ini,timer_fnl - implicit none - type(_obsNode_ ), pointer:: here_ - type(_obsLList_), intent(in):: diagLL - integer(kind=i_kind), intent(in):: idv,iob,ich - - character(len=*),parameter:: myname_=myname//"::locate_" - type(_obsNode_ ),pointer:: idiag - integer(kind=i_kind):: m,i,lb,ub - logical:: done -_ENTRY_(myname_) - call timer_ini(myname_) - - here_ => null() ! return null() if the key is not located. - - associate(lookup => diagLL%lookup(:)) - lb=lbound(lookup,1) - ub=ubound(lookup,1) - done=.false. - do while(.not.done) - i=(lb+ub)/2 - idiag => lookup(i)%ptr - - m=compare_((/idiag%idv,idiag%iob,idiag%ich/),(/idv,iob,ich/)) - done = m==0 - if(done) exit - - ! We are searching for EQUAL, so skip the i-th point if not equal. - if(m<0) then - ! if idiag%(idv,iob,ich) < (/idv,iob,ich/), move the lower range (lb) up - ! to continue the search above i - lb=i+1 - else - ! if idiag%(idv,iob,ich) > (/idv,iob,ich/), move the upper range (ub) down - ! to continue the search below i. - ub=i-1 - endif - - if(ub idiag - endif - - call timer_fnl(myname_) -_EXIT_(myname_) -return -end function locate_ - -function compare_(key1,key2) result (m) - implicit none - integer(kind=i_kind):: m - integer(kind=i_kind),dimension(:),intent(in):: key1,key2 - - integer(kind=i_kind):: n,i - m=0 - n=min(size(key1),size(key2)) - do i=1,n - if (key1(i)key2(i)) then - m=+1; exit - endif - enddo -end function compare_ - -!------------------- -function obsNode_islocal_(aNode) result(islocal_) - use mpimod, only: myPE - use m_cvgridLookup, only: cvgridLookup_islocal - implicit none - logical:: islocal_ - type(_obsNode_),intent(in):: aNode - - character(len=*),parameter:: myname_=myname//"::obsNode_islocal_" -_ENTRY_(myname_) - islocal_=cvgridLookup_islocal(aNode%elat,aNode%elon,myPE) -_EXIT_(myname_) -return -end function obsNode_islocal_ - -function obsNode_isluse_(aNode) result(isluse_) - implicit none - logical:: isluse_ - type(_obsNode_),intent(in):: aNode - - character(len=*),parameter:: myname_=myname//"::obsNode_isluse_" -_ENTRY_(myname_) - isluse_=aNode%luse -_EXIT_(myname_) -return -end function obsNode_isluse_ - -subroutine obsNode_setluse_(aNode) - use mpimod, only: myPE - use m_cvgridLookup, only: cvgridLookup_isluse - implicit none - type(_obsNode_),intent(inout):: aNode - - character(len=*),parameter:: myname_=myname//"::obsNode_setluse_" -_ENTRY_(myname_) - aNode%luse=cvgridLookup_isluse(aNode%elat, aNode%elon, myPE) - ! call obstype_setluse(aNode%luse, aNode%elat, aNode%elon, myPE) -_EXIT_(myname_) -return -end subroutine obsNode_setluse_ - -subroutine obsHeader_read_(iunit,ii_bin,jj_type,lobs,jiter,miter,istat) - implicit none - integer(kind=i_kind),intent(in ):: iunit - integer(kind=i_kind),intent(out):: ii_bin,jj_type,lobs,jiter,miter - integer(kind=i_kind),intent(out):: istat - - character(len=*),parameter:: myname_=myname//"::obsHeader_read_" -_ENTRY_(myname_) - read(iunit,iostat=istat) ii_bin,jj_type,lobs,jiter,miter -_EXIT_(myname_) -return -end subroutine obsHeader_read_ - -subroutine obsHeader_write_(iunit,ii_bin,jj_type,lobs,jiter,miter,istat) - implicit none - integer(kind=i_kind),intent(in ):: iunit - integer(kind=i_kind),intent(in ):: ii_bin,jj_type,lobs,jiter,miter - integer(kind=i_kind),intent(out):: istat - - character(len=*),parameter:: myname_=myname//"::obsHeader_write_" -_ENTRY_(myname_) - write(iunit,iostat=istat) ii_bin,jj_type,lobs,jiter,miter -_EXIT_(myname_) -return -end subroutine obsHeader_write_ - -subroutine obsNode_check_(who,aNode) - use jfunc, only: miter ! for debugging - implicit none - character(len=*),intent(in):: who - type(_obsNode_),intent(in):: aNode - - logical:: equival - character(len=256)::mywho - - mywho=who - !_TRACEV_(who,'associated(aNode%muse ) =',associated(aNode%muse )) - !_TRACEV_(who,'associated(aNode%nldepart) =',associated(aNode%nldepart)) - !_TRACEV_(who,'associated(aNode%tldepart) =',associated(aNode%tldepart)) - !_TRACEV_(who,'associated(aNode%obssen ) =',associated(aNode%obssen )) - - equival = associated(aNode%nldepart) .eqv. associated(aNode%muse ) - if(equival) equival = associated(aNode%tldepart) .eqv. associated(aNode%nldepart) - if(equival) equival = associated(aNode%obssen ) .eqv. associated(aNode%tldepart) - if(equival) equival = associated(aNode%muse) - - ASSERT(equival) - - ASSERT(lbound(aNode%muse ,1)==1.and.ubound(aNode%muse ,1)==miter+1) - ASSERT(lbound(aNode%nldepart,1)==1.and.ubound(aNode%nldepart,1)==miter+1) - ASSERT(lbound(aNode%tldepart,1)==1.and.ubound(aNode%tldepart,1)==miter ) - ASSERT(lbound(aNode%obssen ,1)==1.and.ubound(aNode%obssen ,1)==miter ) - -return -end subroutine obsNode_check_ - -function obsNode_alloc_(miter) result(aNode_) - implicit none - type(_obsNode_), pointer :: aNode_ - integer(kind=i_kind), intent(in):: miter - - character(len=*),parameter:: myname_=myname//"::obsNode_alloc_" -_ENTRY_(myname_) - allocate(aNode_) - aNode_%next => null() - - allocate(aNode_%muse (miter+1), & - aNode_%nldepart(miter+1), & - aNode_%tldepart(miter ), & - aNode_%obssen (miter ) ) - - aNode_%luse = .false. - aNode_%elat = 0._r_kind - aNode_%elon = 0._r_kind - aNode_%idv =-1 - aNode_%iob =-1 - aNode_%ich =-1 - - aNode_%indxglb =-99999 - aNode_%nchnperobs =-99999 - aNode_%muse (:)= .false. - aNode_%nldepart(:)=-huge(0._r_kind) - aNode_%tldepart(:)= 0._r_kind - aNode_%wgtjo =-huge(0._r_kind) - aNode_%obssen (:)= 0._r_kind - - call obsNode_check_(myname_,aNode_) -_EXIT_(myname_) -return -end function obsNode_alloc_ - -subroutine obsNode_read_(aNode,iunit,kiter,istat,redistr) - implicit none - type(_obsNode_), intent(inout):: aNode - integer(kind=i_kind), intent(in ):: iunit - integer(kind=i_kind), intent(in ):: kiter ! input size - integer(kind=i_kind), intent(out ):: istat - logical , intent(in ):: redistr - - character(len=*),parameter:: myname_=myname//'::obsNode_read_' - integer(kind=i_kind):: ier - !real(kind=r_kind),dimension(1:kiter):: zobssen -_ENTRY_(myname_) - - istat=0 - read(iunit,iostat=ier) aNode%luse,aNode%elat,aNode%elon, & - aNode%idv ,aNode%iob ,aNode%ich - if(ier/=0) then - call perr(myname_,'read(%luse,%elat,%elon,...), iostat =',ier) - istat=-1 - _EXIT_(myname_) - return - endif - - istat=1 - if(redistr) then - istat=0 - if(aNode%luse) then - if(obsNode_islocal_(aNode)) istat=1 - endif - endif - - if(istat==0) then - read(iunit,iostat=ier) - if(ier/=0) then - call perr(myname_,'skipping read(%indxglb,%nchnperobs,%muse,...), iostat =',ier) - istat=-2 - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=ier) & - aNode%indxglb, & ! = kindx - aNode%nchnperobs, & ! = mchanl - aNode%muse (1:kiter+1), & ! = lmuse(1:kiter) - aNode%nldepart(1:kiter+1), & ! = znldepart(1:kiter) - aNode%tldepart(1:kiter), & ! = ztldepart(1:kiter) - aNode%wgtjo, & ! = zwgtjo - aNode%obssen (1:kiter) ! = zobssen(1:kiter) - if(ier/=0) then - call perr(myname_,'read(%indxglb,%nchnperobs,%muse,...), iostat =',ier) - istat=-3 - _EXIT_(myname_) - return - endif - -! if (lobsensfc.and..not.lsensrecompute) then -! aNode%obssen(jiter+1:miter )=zobssen(jiter+1:miter ) -! elseif(lobserver) then -! aNode%obssen( 1:jiter-1)=zobssen( 1:jiter-1) -! else -! aNode%obssen( 1:miter )=zobssen( 1:miter ) -! endif - endif - - call obsNode_check_(myname_,aNode) -_EXIT_(myname_) -return -end subroutine obsNode_read_ - -subroutine obsNode_write_(aNode,iunit,jiter,istat) - implicit none - type(_obsNode_), intent(in ):: aNode - integer(kind=i_kind), intent(in ):: iunit - integer(kind=i_kind), intent(in ):: jiter ! the output size - integer(kind=i_kind), intent(inout):: istat - - character(len=*),parameter:: myname_=myname//'::obsNode_write_' -_ENTRY_(myname_) - - write(iunit,iostat=istat) aNode%luse,aNode%elat,aNode%elon, & - aNode%idv,aNode%iob,aNode%ich - if(istat/=0) then - call perr(myname_,'write(%luse,%elat,%elon,...), iostat =',istat) - _EXIT_(myname_) - return - endif - - write(iunit,iostat=istat) & - aNode%indxglb, & - aNode%nchnperobs, & - aNode%muse (1:jiter+1),& - aNode%nldepart(1:jiter+1),& - aNode%tldepart(1:jiter),& - aNode%wgtjo, & - aNode%obssen(1:jiter) - - if(istat/=0) then - call perr(myname_,'write(%indxglb,%nchnperobs,%muse,...), iostat =',istat) - _EXIT_(myname_) - return - endif - call obsNode_check_(myname_,aNode) -_EXIT_(myname_) -return -end subroutine obsNode_write_ - -subroutine obsNode_dealloc_(aNode,deep) - implicit none - type(_obsNode_),pointer,intent(inout):: aNode - logical,optional,intent(in):: deep - - character(len=*),parameter:: myname_=myname//'::obsNode_dealloc_' - logical:: deep_ -_ENTRY_(myname_) - call obsNode_check_(myname_,aNode) - - deep_=.false. - if(present(deep)) deep_=deep - ASSERT(associated(aNode)) - -! _TRACEV_(myname_,'if(deep_), deep_ =',deep_) - if(deep_) then -! _TRACEV_(myname_,'associated(aNode%nldepart) =',associated(aNode%nldepart)) - if(associated(aNode%nldepart)) deallocate(aNode%nldepart) -! _TRACEV_(myname_,'associated(aNode%tldepart) =',associated(aNode%tldepart)) - if(associated(aNode%tldepart)) deallocate(aNode%tldepart) -! _TRACEV_(myname_,'associated(aNode%obssen ) =',associated(aNode%obssen )) - if(associated(aNode%obssen )) deallocate(aNode%obssen ) -! _TRACEV_(myname_,'associated(aNode%muse ) =',associated(aNode%muse )) - if(associated(aNode%muse )) deallocate(aNode%muse ) - endif - ! This is NOT a recursive dealloc_(). Therefore, the associated target of - ! %next is not deallocated, but only %next itself is nullified. -! _TRACEV_(myname_,'associated(%next) =',associated(aNode%next)) - aNode%next => null() -! _TRACEV_(myname_,'associated(%next) =',associated(aNode%next)) - deallocate(aNode) -! _TRACEV_(myname_,'associated(aNode) =',associated(aNode)) -_EXIT_(myname_) -return -end subroutine obsNode_dealloc_ - -subroutine obsNode_show_(aNode,iob) - use mpeu_util, only: stdout - implicit none - type(_obsNode_),intent(in):: aNode - integer(kind=i_kind),intent(in):: iob - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_show_' -_ENTRY_(myname_) - write(stdout,'(2a,5i4,l4,2f8.2)') myname,":: iob,ity,%(idv,iob,ich,luse,elat,elon) =", & - iob,0,aNode%idv,aNode%iob,aNode%ich,aNode%luse,aNode%elat,aNode%elon - call obsNode_check_(myname_,aNode) -_EXIT_(myname_) -return -end subroutine obsNode_show_ - -end module m_obsdiagNode diff --git a/src/m_obsdiags.F90 b/src/m_obsdiags.F90 deleted file mode 100644 index 9caba83b8..000000000 --- a/src/m_obsdiags.F90 +++ /dev/null @@ -1,1349 +0,0 @@ -module m_obsdiags -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_obsdiags -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2015-02-04 -! -! abstract: a bundle of GSI multiple obstypes and the obsdiags linked-lists -! -! program history log: -! 2015-02-04 j guo - Re-implemented read_obsdiags() and write_obsdiags(), -! to support reconfigurable observation operators. This -! implemenstation uses an obsLList template to support, -! in ceterian degree, static polymoprhism for different -! observation types. -! 2015-10-09 j guo - By using Fortran 2003 dynamic polymorphism, this -! version has removed many ugly type dispatching SELECT -! CASE constructs, by using an obsLList, a linked-list -! of dynamic polymorphic observation type (obsNode), -! which replaced the earlier obsLList template. -! 2016-06-22 j guo - Added latlonRange for selected file readings, to let -! []_mread() to skip unnecessary read() of some files -! containing no relevant observations. -! . Added obsdiags_alwaysLocal, as a user controlable -! switch to allow or to bypass selected file readings. -! . Added CHECK_SIZES_ outputs to allow size checkings. -! . Added #define SHOW_LLRANGE, for text-dumping of latlonRanges. -! . Added #define DEBUG_obsdiags, for text-dumping -! specific sections of obsdiags(:,:). -! . Locally renamed MPI_comm_world to gsi_comm_world. -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - - use kinds, only: i_kind - use mpeu_util, only: tell,warn,perr,die - use mpeu_util, only: assert_ - use mpeu_util, only: stdout_open,stdout_close,stdout - use mpeu_mpif, only: gsi_comm_world => MPI_comm_world - - use m_obsLList, only: obsLList - - use m_psNode , only: psNode ! 1 - use m_tNode , only: tNode ! 2 - use m_wNode , only: wNode ! 3 - use m_qNode , only: qNode ! 4 - use m_spdNode , only: spdNode ! 5 - use m_rwNode , only: rwNode ! 6 - use m_dwNode , only: dwNode ! 7 - use m_sstNode , only: sstNode ! 8 - use m_pwNode , only: pwNode ! 9 - use m_pcpNode , only: pcpNode ! 10 - use m_ozNode , only: ozNode ! 11 - use m_o3lNode , only: o3lNode ! 12 - use m_gpsNode , only: gpsNode ! 13 - use m_radNode , only: radNode ! 14 - use m_tcpNode , only: tcpNode ! 15 - use m_lagNode , only: lagNode ! 16 - use m_colvkNode, only: colvkNode ! 17 - use m_aeroNode , only: aeroNode ! 18 - use m_aerolNode, only: aerolNode ! 19 - use m_pm2_5Node, only: pm2_5Node ! 20 - use m_gustNode , only: gustNode ! 21 - use m_visNode , only: visNode ! 22 - use m_pblhNode , only: pblhNode ! 23 - use m_wspd10mNode , only: wspd10mNode ! 24 - use m_td2mNode , only: td2mNode ! 25 - use m_mxtmNode , only: mxtmNode ! 26 - use m_mitmNode , only: mitmNode ! 27 - use m_pmslNode , only: pmslNode ! 28 - use m_howvNode , only: howvNode ! 29 - use m_tcamtNode, only: tcamtNode ! 30 - use m_lcbasNode, only: lcbasNode ! 31 - use m_uwnd10mNode , only: uwnd10mNode - use m_vwnd10mNode , only: vwnd10mNode - - use m_pm10Node , only: pm10Node ! 32 - use m_cldchNode, only: cldchNode ! 33 - - use m_obsNodeTypeManager, only: nobs_type - use gsi_4dvar , only: nobs_bins - - use obsmod, only: obsdiags ! (nobs_type,nobs_bins) - implicit none - private ! except - - public:: obsdiags_reset - public:: obsdiags_write - public:: obsdiags_read - public:: obsdiags_sort - - interface obsdiags_reset; module procedure reset_; end interface - interface obsdiags_write; module procedure write_; end interface - interface obsdiags_read ; module procedure mread_; end interface - interface obsdiags_sort ; module procedure lsort_; end interface - - public:: obsdiags_create - public:: obsdiags_destroy - interface obsdiags_create ; module procedure create_obsmod_vars; end interface - interface obsdiags_destroy; module procedure destroy_obsmod_vars; end interface - - public:: obsdiags_summary - - interface obsdiags_summary ; module procedure summary_ ; end interface - - public:: obsdiags_alwaysLocal - logical,save:: obsdiags_alwaysLocal = .false. - -! Note: User configurables -! -! (1) obsdiags_mread(..,mPEs,..) via /SETUP/:mPEs_observer: -! -! mPEs==0, for reading "my own data"; -! mPEs=>0, reading "all data", from PE 0 to mPEs-1, but only up to the -! highest count of the actually accessible files. -! -! This value is configured through gsimod namelist/SETUP/:mPEs_observer, -! with the default value set to 0, to behave as it was ("my own data"). -! Otherwise, a simple usage is to let mPEs_observer=1024, or other large -! enough value, such that the solver-mode will try to determine how many -! files created by the observer-mode are actually there to read. -! -! (2) obsdiags_alwaysLocal via /SETUP/:alwaysLocal: -! -! obsdiags_alwaysLocal sets an alternative default value of the optional -! argument of obsdiags_mread(..,alwaysLocal). -! -! obsdiags_alwaysLocal==.false., its default value. -! It let obsdiags_mread() to check the locality of a file first, -! using latlonRange_islocal(iPE), to avoid unnecessary opening+ -! reading some files. -! obsdiags_alwaysLocal==.true., override latlonRange_islocal(iPE). -! It let obsdiags_mread() to always open+read all file. - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='m_obsdiags' - logical,save:: lobsdiags_allocated_ = .false. - logical,save:: lobstypes_allocated_ = .false. - - logical,parameter:: All_PEs =.false. ! report status on all PEs or root only - !logical,parameter:: All_PEs =.true. ! report status on all PEs or root only - logical,parameter:: DO_SUMMARY =.false. ! report status on all PEs or root only - !logical,parameter:: DO_SUMMARY =.true. ! report status on all PEs or root only - - ! SYNCH_MESSAGES is a flag to invoke MPI_Barrier() calls before some - ! status messages. These calls are otherwise not necessary for the - ! functionalities, but used here to ensure those messages mean what they - ! intent to mean, in case that only the root PE is used to report some - ! all PE status. - - !logical,parameter:: SYNCH_MESSAGES = .true. ! turn synch on - !logical,parameter:: SYNCH_MESSAGES = .not. All_PEs ! conditionally turn on - logical,parameter:: SYNCH_MESSAGES = .false. ! turn synch off - - public :: obsdiags - public :: obsLLists - - public :: pshead - public :: tcphead - public :: thead - public :: whead - public :: qhead - public :: spdhead - public :: rwhead - public :: dwhead - public :: ssthead - public :: pcphead - public :: pwhead - public :: ozhead - public :: o3lhead - public :: aerohead - public :: aerolhead - public :: pm2_5head - public :: gpshead - public :: radhead - public :: laghead - public :: colvkhead - public :: gusthead - public :: vishead - public :: pblhhead - - public :: wspd10mhead - public :: uwnd10mhead - public :: vwnd10mhead - - public :: td2mhead - public :: mxtmhead - public :: mitmhead - public :: pmslhead - public :: howvhead - public :: tcamthead - public :: lcbashead - - public :: pm10head - public :: cldchhead - - type(obsLList),dimension(:),pointer :: pshead => null() - type(obsLList),dimension(:),pointer :: tcphead => null() - type(obsLList),dimension(:),pointer :: thead => null() - type(obsLList),dimension(:),pointer :: whead => null() - type(obsLList),dimension(:),pointer :: qhead => null() - type(obsLList),dimension(:),pointer :: spdhead => null() - type(obsLList),dimension(:),pointer :: rwhead => null() - type(obsLList),dimension(:),pointer :: dwhead => null() - type(obsLList),dimension(:),pointer :: ssthead => null() - type(obsLList),dimension(:),pointer :: pcphead => null() - type(obsLList),dimension(:),pointer :: pwhead => null() - type(obsLList),dimension(:),pointer :: ozhead => null() - type(obsLList),dimension(:),pointer :: o3lhead => null() - type(obsLList),dimension(:),pointer :: aerohead => null() - type(obsLList),dimension(:),pointer :: aerolhead => null() - type(obsLList),dimension(:),pointer :: pm2_5head => null() - type(obsLList),dimension(:),pointer :: gpshead => null() - type(obsLList),dimension(:),pointer :: radhead => null() - type(obsLList),dimension(:),pointer :: laghead => null() - type(obsLList),dimension(:),pointer :: colvkhead => null() - type(obsLList),dimension(:),pointer :: gusthead => null() - type(obsLList),dimension(:),pointer :: vishead => null() - type(obsLList),dimension(:),pointer :: pblhhead => null() - - type(obsLList),dimension(:),pointer :: wspd10mhead => null() - type(obsLList),dimension(:),pointer :: uwnd10mhead => null() - type(obsLList),dimension(:),pointer :: vwnd10mhead => null() - - type(obsLList),dimension(:),pointer :: td2mhead => null() - type(obsLList),dimension(:),pointer :: mxtmhead => null() - type(obsLList),dimension(:),pointer :: mitmhead => null() - type(obsLList),dimension(:),pointer :: pmslhead => null() - type(obsLList),dimension(:),pointer :: howvhead => null() - type(obsLList),dimension(:),pointer :: tcamthead => null() - type(obsLList),dimension(:),pointer :: lcbashead => null() - - type(obsLList),dimension(:),pointer :: pm10head => null() - type(obsLList),dimension(:),pointer :: cldchhead => null() - - type(obsLList),dimension(:,:),pointer :: obsLLists => null() - - !type(obs_diags),dimension(:,:),pointer :: obsdiags => null() ! (nobs_type,nobs_bins) - - -!#define DEBUG_TRACE -#include "mytrace.H" -#include "myassert.H" - -#define _TIMER_ON_ -#ifdef _TIMER_ON_ -#undef _TIMER_ON_ -#undef _TIMER_OFF_ -#undef _TIMER_USE_ -#define _TIMER_ON_(id) call timer_ini(id) -#define _TIMER_OFF_(id) call timer_fnl(id) -#define _TIMER_USE_ use timermod, only: timer_ini,timer_fnl -#else -#define _TIMER_ON_(id) -#define _TIMER_OFF_(id) -#define _TIMER_USE_ -#endif - - logical,parameter:: CHECK_SIZES_=.false. - !logical,parameter:: CHECK_SIZES_=.true. - - !-- if(CHECK_SIZES_) then - !-- these size counters, - - integer(i_kind),allocatable,dimension(:),save:: lsize_type ! luse counts of ob_type - integer(i_kind),allocatable,dimension(:),save:: nsize_type ! total counts of ob_type - integer(i_kind),allocatable,dimension(:),save:: lsize_diag ! luse counts of obs_diags - integer(i_kind),allocatable,dimension(:),save:: msize_diag ! muse counts of obs_diags - integer(i_kind),allocatable,dimension(:),save:: nsize_diag ! total counts of obs_diags - - !-- will be used to generate extra log-information, reporting different - !-- size-counts of linked-lists, of all j-type, i-bin, on all PEs. Search - !-- "CHECK_SIZES_" here for details. - !-- endif - -contains -subroutine lobsdiags_statusCheck_(who,allocated) -!-- check the allocation status of basic obsdiags components. - use obsmod, only: luse_obsdiag - implicit none - character(len=*),intent(in):: who - logical,intent(in):: allocated - - if(.not.luse_obsdiag) return - if(allocated) then - if( .not.lobsdiags_allocated_ .or. & - .not.lobstypes_allocated_ ) then - if(.not.lobsdiags_allocated_) call perr(who,'.not.lobsdiags_allocated_') - if(.not.lobstypes_allocated_) call perr(who,'.not.lobstypes_allocated_') - call die(who) - endif - - else - if( lobsdiags_allocated_ .or. & - lobstypes_allocated_ ) then - if(lobsdiags_allocated_) call perr(who,'lobsdiags_allocated_ already') - if(lobstypes_allocated_) call perr(who,'lobstypes_allocated_ already') - call die(who) - endif - endif -end subroutine lobsdiags_statusCheck_ - -subroutine mread_(cdfile,mPEs,force,ignore_iter,alwaysLocal) -!$$$ subprogram documentation block -! . . . . -! subprogram: m_obdiags::mread_ -! prgmmr: tremolet -! -! abstract: Read obsdiags data structure from file. -! -! program history log: -! 2007-07-05 tremolet -! 2007-08-04 todling - using get_lun to determine file unit number -! 2007-10-03 todling - expanded to account for full observer -! 2009-01-08 todling - remove reference to ozohead -! 2009-01-23 todling - add read_gpshead -! 2009-04-02 meunier - add read_laghead -! 2010-04-27 tangborn - addded read_colvkhead -! 2010-05-26 treadon - add read_tcphead -! 2011-05-18 todling - aero, aerol, and pm2_5 -! 2011-09-20 hclin - 1d wij for aero -! 2015-02-04 j guo - Re-implemented to support re-configurable observation -! operators. read_() is split to read_() for a single -! file, and mread_() for one file only or all files for -! redistribution -! 2015-10-09 j guo - Now it uses Fortran 2003 dynamic polymorphism. -! -! input argument list: -! cdfile - filename to read data from -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - - use mpeu_util, only: tell,perr,die,stdout_open,stdout_close,stdout - _TIMER_USE_ - use kinds, only: r_kind,i_kind - - use obsmod, only: lobserver - use mpimod, only: myPE - use m_latlonRange, only: latlonRange - use m_latlonRange, only: latlonRange_reset - use m_latlonRange, only: latlonRange_islocal - use m_latlonRange, only: latlonRange_readBcast - use m_latlonRange, only: latlonRange_allDump - - use m_obsdiagNode, only: obsdiagLList_dump - implicit none - character(len=*), intent(in) :: cdfile ! prefix, "obsdiags." - integer(i_kind),optional,intent(in):: mPEs ! number of files, from 0 to mPEs-1 - logical ,optional,intent(in):: force ! force to read ob_types, regardless l4dvar etc. - logical ,optional,intent(in):: ignore_iter ! ignore iter checking - logical ,optional,intent(in):: alwaysLocal ! read all files - -! ---------------------------------------------------------- - character(len=*),parameter:: myname_=myname//"::mread_" - logical:: redistr,exist_ - integer(i_kind):: lPE,uPE,iPE,ier - integer(i_kind):: jtyp,jread - logical:: force_read - logical:: alwaysLocal_ - logical:: fileislocal - type(latlonRange),allocatable,dimension(:):: allRanges -_ENTRY_(myname_) -_TIMER_ON_(myname_) -!call stdout_open("obsdiags_mread") - force_read=.false. - if(present(force)) force_read=force - alwaysLocal_=obsdiags_alwaysLocal - if(present(alwaysLocal)) alwaysLocal_=alwaysLocal - - call lobsdiags_statusCheck_(myname_,allocated=.true.) - - ! Determine the configuration, either read-my-own-data-only, or - ! try-to-read-all-data-available. - - lPE=myPE - uPE=lPE - redistr=.false. - if(present(mPEs)) then - if(mPEs>0) then - redistr=.true. - lPE=0 - uPE=-1 - do iPE=lPE,mPEs-1 - inquire(file=trim(filename_(cdfile,iPE)), exist=exist_) - if(exist_) uPE=iPE - enddo - endif - endif - - ! Reset components of obsdiags, for their re-construction from files - call reset_() - - if(CHECK_SIZES_) then - allocate(lsize_type(nobs_type)) - allocate(nsize_type(nobs_type)) - allocate(lsize_diag(nobs_type)) - allocate(nsize_diag(nobs_type)) - allocate(msize_diag(nobs_type)) - - lsize_type(:)=0 - nsize_type(:)=0 - lsize_diag(:)=0 - nsize_diag(:)=0 - msize_diag(:)=0 - endif - - ! MPI_Barrier() calls are not necessary. They are used here to ensure - ! the log-messages mean what they really mean, if only the root is used to - ! report the all-PE status. - - if(SYNCH_MESSAGES) call MPI_Barrier(gsi_comm_world,ier) - - if(redistr) then - if(mype==0) then - call tell(myname_,'Reading obsdiags files for redistribution, nPEs =',uPE-lPE+1) - call tell(myname_,' prefix of the files, cdfile =',trim(cdfile)) - call tell(myname_,' lPE =',lPE) - call tell(myname_,' uPE =',uPE) - call tell(myname_,' alwaysLocal =',alwaysLocal_) - endif - - allocate(allRanges(0:uPE)) - call latlonRange_reset(allRanges) - call latlonRange_readBcast(hdfilename_(cdfile),allRanges,root=0,comm=gsi_comm_world) - -!#define SHOW_LLRANGE -#ifdef SHOW_LLRANGE - call latlonRange_alldump(allRanges,"obsLLRange") -#endif - - - jread=-1 ! checker of the input jiter values - do iPE=lPE,uPE - fileislocal=latlonRange_islocal(allRanges(iPE)) - if(alwaysLocal_.or.fileislocal) then - call read_(cdfile,iPE,redistr,fileislocal=fileislocal, & - force=force, & - ignore_iter=ignore_iter, & - verbose=.not.alwaysLocal_.or.myPE==0, & - jread=jread) - endif - enddo - -!#define DEBUG_obsdiags -#ifdef DEBUG_obsdiags - ! This is an example of dumping information for debugging, on selected - ! PEs, for specific jtyp and ibin. - ! - ! This example is on PE #1, for (jtype==3 .and. ibin==3). - - if(myPE==1) then - call tell(myname_) - call tell(myname_,'dumping obsdiags(), jtyp =',3) - call tell(myname_,' ibin =',3) - call tell(myname_,' jread =',jread) - call obsdiagLList_dump(obsdiags(3,3),jiter=jread) - endif -#endif - - ! Sort to ensure the ordering is unique. - call lsort_() - - call latlonRange_reset(allRanges) - deallocate(allRanges) - - else ! of if(redistr) - call read_(cdfile,myPE,redistr,fileislocal=.true., & - force=force, & - ignore_iter=ignore_iter, & - verbose=.true.) - - endif ! of if(redistr) - - if(myPE==0) then - call tell(myname_,'Finished reading of all obsdiags files, nPEs =',uPE-lPE+1) - endif - - if(CHECK_SIZES_) then - do jtyp=lbound(lsize_type,1),ubound(lsize_type,1) - if( msize_diag(jtyp)>0.or.lsize_diag(jtyp)>0.or.nsize_diag(jtyp)>0 .or. & - lsize_type(jtyp)>0.or.nsize_type(jtyp)>0 ) then - write(stdout,'(i5.3,i5,7x,5i8,2x,l1)') myPE,jtyp ,lsize_type(jtyp),nsize_type(jtyp), & - msize_diag(jtyp),lsize_diag(jtyp),nsize_diag(jtyp) - endif - enddo - - call iMPI_reduceSUM_(lsize_type,root=0,comm=gsi_comm_world) - call iMPI_reduceSUM_(nsize_type,root=0,comm=gsi_comm_world) - call iMPI_reduceSUM_(lsize_diag,root=0,comm=gsi_comm_world) - call iMPI_reduceSUM_(nsize_diag,root=0,comm=gsi_comm_world) - call iMPI_reduceSUM_(msize_diag,root=0,comm=gsi_comm_world) - - if(myPE==0) then - do jtyp=lbound(lsize_type,1),ubound(lsize_type,1) - if( msize_diag(jtyp)>0.or.lsize_diag(jtyp)>0.or.nsize_diag(jtyp)>0 .or. & - lsize_type(jtyp)>0.or.nsize_type(jtyp)>0 ) then - write(stdout,'(2x,a,i5,7x,5i8,2x,l1)') '***',jtyp ,lsize_type(jtyp),nsize_type(jtyp), & - msize_diag(jtyp),lsize_diag(jtyp),nsize_diag(jtyp) - endif - enddo - endif - - deallocate(lsize_type) - deallocate(nsize_type) - deallocate(lsize_diag) - deallocate(nsize_diag) - deallocate(msize_diag) - endif - - if(SYNCH_MESSAGES) call MPI_Barrier(gsi_comm_world,ier) - if(DO_SUMMARY) call summary_(myname_) - - if(lobserver) then - if(.not.force_read) then - !call destroyobs( skipit=.true.) - call reset_(obsdiags_keep=.true.) - endif - endif -!call stdout_close() -_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine mread_ - -subroutine reset_(obsdiags_keep) - use obsmod, only: obsdiags - use obsmod, only: luse_obsdiag - use obsmod, only: lobsdiag_allocated - - use m_obsdiagNode, only: obsdiagLList_reset - use m_obsLList, only: obsLList_reset - use m_obsNode , only: obsNode - use m_obsNodeTypeManager, only: obsNode_typeMold - -! use m_wspd10mNode, only: obsLList_reset -! use m_td2mNode, only: obsLList_reset -! use m_mxtmNode, only: obsLList_reset -! use m_mitmNode, only: obsLList_reset -! use m_pmslNode, only: obsLList_reset -! use m_howvNode, only: obsLList_reset -! use m_tcamtNode, only: obsLList_reset -! use m_lcbasNode, only: obsLList_reset -! use m_pm10Node, only: obsLList_reset -! use m_cldchNode, only: obsLList_reset - - _TIMER_USE_ - implicit none - logical,optional,intent(in):: obsdiags_keep - character(len=*),parameter:: myname_=myname//'::reset_' - integer(i_kind):: ii,jj - logical:: obsdiags_keep_ - integer(i_kind):: ier - class(obsNode),pointer:: mNode_ -_ENTRY_(myname_) -_TIMER_ON_(myname_) - -_TRACEV_(myname_,'lobsdiag_allocated =',lobsdiag_allocated) - -_TRACEV_(myname_,'lobsdiags_allocated_ =',lobsdiags_allocated_) - if(luse_obsdiag) then - if(.not.lobsdiags_allocated_) then - lobsdiags_allocated_=.true. - if(.not.associated(obsdiags)) then; call die(myname_,'associated(obsdiags)=',associated(obsdiags)); endif - !allocate( obsdiags(nobs_type,nobs_bins)) - endif - - ASSERT(all(shape(obsdiags)==shape(obsLLists))) - ASSERT(size(obsdiags,1)==size(obsLLists,1)) - ASSERT(size(obsdiags,2)==size(obsLLists,2)) - - endif - - if(.not.lobstypes_allocated_) then - lobstypes_allocated_=.true. - if(.not.associated(obsLLists)) call die(myname_,'.not.associated(obsLLists)') - endif - - obsdiags_keep_=.false. - if(present(obsdiags_keep)) obsdiags_keep_=obsdiags_keep - - do ii=1,size(obsLLists,2) ! nobs_bins - do jj=1,size(obsLLists,1) ! nobs_type - if(luse_obsdiag) then - if(.not.obsdiags_keep_) then - call obsdiagLList_reset(obsdiags(jj,ii)) - lobsdiag_allocated=.false. - endif - endif - - mNode_ => obsNode_typeMold(jj) ! get the ob_type of jj - if(.not.associated(mNode_)) then - call perr(myname_,'obsNode_typeMold(jtype) not associated, jtype =',jj) - call perr(myname_,' ubound(obsLLists,1) =',size(obsLLists,1)) - call perr(myname_,' ibin =',ii) - call perr(myname_,' ubound(obsLLists,2) =',size(obsLLists,2)) - call die(myname_) - endif - - call obsLList_reset(obsLLists(jj,ii),mold=mNode_, stat=ier) - if(ier/=0) then - call perr(myname_,'call obsLList_reset(), stat =',ier) - call perr(myname_,' ibin =',ii) - call perr(myname_,' jtype =',jj) - call perr(myname_,' mold%mytype() =',mNode_%mytype()) - call die(myname_) - endif - mNode_ => null() - enddo - enddo -_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine reset_ - -function ptr_obsbins_(oll,vname) result(ptr_) -!-- returns a pointer to the list of vname, from array oll. - use m_obsNodeTypeManager, only: obsNode_typeIndex - implicit none - type(obsLList),pointer,dimension(:):: ptr_ - type(obsLList),dimension(:,:),target, intent(in):: oll - character(len=*) , intent(in):: vname - - character(len=*),parameter:: myname_=myname//"::ptr_obsbins_" - integer(i_kind):: itype -_ENTRY_(myname_) - itype = obsNode_typeIndex(vname) ! e.g. vname="ps" - - ptr_ => null() ! e.g. if(.not.associated(ptr_)) ... - - ASSERT(itype>0) - ASSERT(itype<=size(oll,1)) - - ptr_ => oll(itype,:) - -_EXIT_(myname_) -return -end function ptr_obsbins_ - -subroutine aliasesCreate_() - implicit none - - character(len=*),parameter:: myname_=myname//"aliasesCreate_" -_ENTRY_(myname_) - - !! too much to declare, if use enumerated index value directly - ! pshead => obsllists(i_ps_ob_type,:) ! too much to declare - ! pshead => ptr_obsLList(obsllists,i_ps_ob_type) ! too much to declare - ! pshead => ptr_obsLList(obsllists,iobstype_ps) ! too much to declare - !! use a vname may be a balance - ! pshead => ptr_obsLList(obsllists,'ps') ! name is less explicit - ! pshead => ptr_psbins(obsllists) ! too many to implement - ! pshead => ptr_obsbins(obsllists,'ps') ! explicit and minimal-ism - !! an example of m_obsNodeTypeManager implementation - ! use m_obsNodeTypeManager, only: obsType_mold - ! ! index_mold(index=i_ps_ob_type) - ! ! vname_mold(vname="ps"|"[psNode]") - ! use m_obsNodeTypeManager, only: obsType_index - ! ! vname_index(vname='ps'|'[psNode]') - ! ! vmold_index(vmold=psNode()) - !! to implement ptr_obsbins() - ! function ptr_obsbins(obsllists,vname) result(ptr_) - ! use m_obsNodeTypeManager, only: obsType_index - ! iobstype = obsType_index(vname) ! e.g. vname="ps" - ! ptr_ => obsllists(iobstype,:) - - pshead => ptr_obsbins_(obsllists,'ps') - thead => ptr_obsbins_(obsllists,'t') - whead => ptr_obsbins_(obsllists,'w') - qhead => ptr_obsbins_(obsllists,'q') - spdhead => ptr_obsbins_(obsllists,'spd') - rwhead => ptr_obsbins_(obsllists,'rw') - dwhead => ptr_obsbins_(obsllists,'dw') - ssthead => ptr_obsbins_(obsllists,'sst') - pwhead => ptr_obsbins_(obsllists,'pw') - ozhead => ptr_obsbins_(obsllists,'oz') - o3lhead => ptr_obsbins_(obsllists,'o3l') - pcphead => ptr_obsbins_(obsllists,'pcp') - gpshead => ptr_obsbins_(obsllists,'gps') - radhead => ptr_obsbins_(obsllists,'rad') - tcphead => ptr_obsbins_(obsllists,'tcp') - laghead => ptr_obsbins_(obsllists,'lag') - colvkhead => ptr_obsbins_(obsllists,'colvk') - aerohead => ptr_obsbins_(obsllists,'aero') - aerolhead => ptr_obsbins_(obsllists,'aerol') - pm2_5head => ptr_obsbins_(obsllists,'pm2_5') - vishead => ptr_obsbins_(obsllists,'vis') - gusthead => ptr_obsbins_(obsllists,'gust') - pblhhead => ptr_obsbins_(obsllists,'pblh') - - wspd10mhead => ptr_obsbins_(obsllists,'wspd10m') - uwnd10mhead => ptr_obsbins_(obsllists,'uwnd10m') - vwnd10mhead => ptr_obsbins_(obsllists,'vwnd10m') - - td2mhead => ptr_obsbins_(obsllists,'td2m') - mxtmhead => ptr_obsbins_(obsllists,'mxtm') - mitmhead => ptr_obsbins_(obsllists,'mitm') - pmslhead => ptr_obsbins_(obsllists,'pmsl') - howvhead => ptr_obsbins_(obsllists,'howv') - tcamthead => ptr_obsbins_(obsllists,'tcamt') - lcbashead => ptr_obsbins_(obsllists,'lcbas') - - pm10head => ptr_obsbins_(obsllists,'pm10') - cldchhead => ptr_obsbins_(obsllists,'cldch') - -_EXIT_(myname_) -return -end subroutine aliasesCreate_ - -subroutine aliasesDestroy_() - implicit none - - character(len=*),parameter:: myname_=myname//"aliasesDestroy_" -_ENTRY_(myname_) - - pshead => null() - thead => null() - whead => null() - qhead => null() - spdhead => null() - rwhead => null() - dwhead => null() - ssthead => null() - pwhead => null() - ozhead => null() - o3lhead => null() - pcphead => null() - gpshead => null() - radhead => null() - tcphead => null() - laghead => null() - colvkhead => null() - aerohead => null() - aerolhead => null() - pm2_5head => null() - vishead => null() - gusthead => null() - pblhhead => null() - - wspd10mhead => null() - uwnd10mhead => null() - vwnd10mhead => null() - - td2mhead => null() - mxtmhead => null() - mitmhead => null() - pmslhead => null() - howvhead => null() - tcamthead => null() - lcbashead => null() - - pm10head => null() - cldchhead => null() - -_EXIT_(myname_) -return -end subroutine aliasesDestroy_ - -subroutine lsort_() -!$$$ subprogram documentation block -! -! abstract: sort entries of obsdiags(:,:) and obsLLists(:,:) -! -! program history log: -! -! input argument list: -! -!$$$ - - use gsi_unformatted, only: unformatted_open - use obsmod, only: luse_obsdiag - - use m_obsLList, only: obsLList_lsort - use m_obsdiagNode, only: obsdiagLList_lsize - use m_obsdiagNode, only: obsdiagLList_lsort - - _TIMER_USE_ - implicit none - - character(len=*), parameter :: myname_=myname//"::lsort_" - - integer(i_kind) :: ii,jj !,iobs,lobs,ierr -_ENTRY_(myname_) -_TIMER_ON_(myname_) -! ---------------------------------------------------------- - call lobsdiags_statusCheck_(myname_,allocated=.true.) - - if (luse_obsdiag) then - - ASSERT(all(shape(obsdiags)==shape(obsLLists))) - ASSERT(size(obsdiags,1)==size(obsLLists,1)) - ASSERT(size(obsdiags,2)==size(obsLLists,2)) - - endif - - do jj=1,size(obsdiags,1) - do ii=1,size(obsdiags,2) - call obsdiagLList_lsort(obsdiags(jj,ii),itype=jj,ibin=ii) - enddo - enddo - - do jj=1,size(obsLLists,1) - do ii=1,size(obsLLists,2) - call obsLList_lsort(obsLLists(jj,ii),itype=jj,ibin=ii) - enddo - enddo - -! ---------------------------------------------------------- -_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine lsort_ - -subroutine write_(cdfile,luseonly,force) -!$$$ subprogram documentation block -! -! abstract: Write obsdiags data structure to file. -! -! program history log: -! 2007-07-05 tremolet -! 2007-10-03 todling - expanded to account for full observer -! 2007-10-24 todling - add parameter nchnperobs to obsdiag -! 2009-01-08 todling - remove reference to ozohead -! 2009-01-27 todling - add gps write -! 2010-05-26 treadon - add write_tcphead -! 2010-06-03 todling - add write_colvkhead -! 2011-05-18 todling - aero, aerol, and pm2_5 -! 2015-02-04 j guo - Re-implemented to support re-configurable observation -! operators. -! 2015-10-09 j guo - Now it uses Fortran 2003 dynamic polymorphism. -! -! input argument list: -! cdfile - filename to write data -! -!$$$ - -use mpeu_util, only: tell,die,perr,stdout_open,stdout_close -_TIMER_USE_ - - use gsi_unformatted, only: unformatted_open - use mpimod, only: mype - use gsi_4dvar, only: nobs_bins,l4dvar - use jfunc, only: jiter, miter - - use m_obsLList, only: obsLList_write - use m_obsdiagNode, only: obsdiagLList_lsize - use m_obsdiagNode, only: obsdiagLList_write - - use m_latlonRange, only: latlonRange - use m_latlonRange, only: latlonRange_reset - use m_latlonRange, only: latlonRange_gatherWrite - use m_latlonRange, only: latlonRange_gatherDump - - implicit none - character(len=*), intent(in) :: cdfile ! := "obsdiags." - logical,optional, intent(in) :: luseonly ! output only if(%luse) - logical,optional, intent(in) :: force ! write all out regardlessly - - character(len=*), parameter :: myname_=myname//"::write_" - -integer(i_kind) :: iunit,istat -integer(i_kind) :: ii,jj,ier -logical :: luseonly_ -logical :: force_write -type(latlonRange):: luseRange -! ---------------------------------------------------------- -_ENTRY_(myname_) -_TIMER_ON_(myname_) -!call stdout_open("obsdiags_write") - force_write=.false. - if(present(force)) force_write=force - call lobsdiags_statusCheck_(myname_,allocated=.true.) - - ASSERT(all(shape(obsdiags)==shape(obsLLists))) - ASSERT(size(obsdiags,1)==size(obsLLists,1)) - ASSERT(size(obsdiags,2)==size(obsLLists,2)) - - luseonly_=.false. - if(present(luseonly)) luseonly_=luseonly - - call unformatted_open( unit=iunit, & - file=trim(filename_(cdfile,myPE)), & - class='.obsdiags.', & - action='write', & - status='unknown', & - newunit=.true., & ! with newunit=.true., unit returns a value assigned by Fortran. - iostat=istat,silent=.true.) - if(istat/=0) then - call perr(myname_,'unformatted_open(), file =',filename_(cdfile,myPE)) - call perr(myname_,' newunit =',iunit) - call perr(myname_,' iostat =',istat) - call die(myname_) - endif - - if(DO_SUMMARY) call summary_(myname_) - - do ii=1,nobs_bins - do jj=1,nobs_type - call obsdiagLList_write(obsdiags(jj,ii),iunit,luseonly_,jiter,miter,jj,ii,luseRange=luseRange) - - if (force_write .or. l4dvar) then - call obsLList_write(obsLLists(jj,ii),iunit,luseonly_,jj,luseRange=luseRange) - endif - - write(iunit)ii,jj ! a jj_obstype-block trailer - enddo - enddo - - close(iunit) - - ! latlonRange_gatherWrite() implies a mpi_barrier() action. - call latlonRange_gatherWrite(luseRange,hdfilename_(cdfile),root=0,comm=gsi_comm_world) - -#ifdef SHOW_LLRANGE - ! Text-dump to diagnose the values - call latlonRange_gatherDump( "cvgLLRange",root=0,comm=gsi_comm_world) - call latlonRange_gatherDump(luseRange,"obsLLRange",root=0,comm=gsi_comm_world) -#endif - - call latlonRange_reset(luseRange) - - if(SYNCH_MESSAGES) call MPI_Barrier(gsi_comm_world,ier) - if (mype==0) call tell(myname_,'Finish writing obsdiags to file ',filename_(cdfile,myPE)) - -! ---------------------------------------------------------- -!call stdout_close() -_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine write_ - -subroutine read_(cdfile,iPE,redistr,fileislocal,force,ignore_iter,verbose,jread) - use mpeu_util, only: tell,perr,die - use mpeu_util, only: stdout - use mpimod, only: mype - use gsi_4dvar, only: l4dvar - use gsi_unformatted, only: unformatted_open - use jfunc, only: jiter,miter - _TIMER_USE_ - - use obsmod, only: lobserver - use obsmod, only: obs_diag - - use m_obsLList, only: obsLList_read - use m_obsLList, only: obsLList_lsize - use m_obsLList, only: obsLList_lcount - - use m_obsdiagNode, only: obsdiagLList_read - use m_obsdiagNode, only: obsdiagLList_lsize - use m_obsdiagNode, only: obsdiagLList_lcount - use m_obsdiagNode, only: obsdiagLookup_build - use m_obsdiagNode, only: obsdiagLookup_clean - - implicit none - character(len=*), intent(in ):: cdfile ! prefix of the input file - integer(i_kind ), intent(in ):: iPE ! iPE of the input file - logical , intent(in ):: redistr ! data redistribution is expected - logical , intent(in ):: fileislocal ! the file to read, is known local - - logical,optional, intent(in ):: force ! (force to read ob_type data - logical,optional, intent(in ):: ignore_iter ! ignore checking of iter - logical,optional, intent(in ):: verbose ! report each reading - integer(i_kind ), optional, intent(inout):: jread ! jiter read from the input - - character(len=*),parameter:: myname_=myname//'::read_' - character(len=*),parameter:: diag_timer_=myname_//'.obsdiagLList_read' - character(len=*),parameter:: list_timer_=myname_//'.obsLList_read' - integer(i_kind):: ii,jj - integer(i_kind):: ki,kj - integer(i_kind):: iunit,istat - integer(i_kind):: jread_ - integer(i_kind):: lsize_type_,nsize_type_ - integer(i_kind):: lsize_diag_,nsize_diag_,msize_diag_ - type(obs_diag),pointer:: leadNode => NULL() - logical:: force_read - logical:: verbose_ -_ENTRY_(myname_) -_TIMER_ON_(myname_) - - call lobsdiags_statusCheck_(myname_,allocated=.true.) - force_read=.false. - if(present(force)) force_read=force - - verbose_=.false. - if(present(verbose)) verbose_=verbose - - ASSERT(all(shape(obsdiags)==shape(obsLLists))) - ASSERT(size(obsdiags,1)==size(obsLLists,1)) - ASSERT(size(obsdiags,2)==size(obsLLists,2)) - if(CHECK_SIZES_) then - ASSERT(size(obsdiags,1)==size(lsize_type )) - ASSERT(size(obsdiags,1)==size(nsize_type )) - ASSERT(size(obsdiags,1)==size(lsize_diag )) - ASSERT(size(obsdiags,1)==size(nsize_diag )) - endif - - call unformatted_open( unit=iunit, & - file=trim(filename_(cdfile,iPE)), & - class='.obsdiags.', & - action='read', & - status='old', & - newunit=.true., & ! with newunit=.true., unit returns a value assigned by Fortran. - iostat=istat,silent=.true.) - if(istat/=0) then - call perr(myname_,'unformatted_open(), file =',trim(filename_(cdfile,iPE))) - call perr(myname_,' myPE =',myPE) - call perr(myname_,' iPE =',iPE) - call perr(myname_,' miter =',miter) - call perr(myname_,' redistr =',redistr) - call perr(myname_,' newunit =',iunit) - call perr(myname_,' iostat =',istat) - call die(myname_) - endif - - if(verbose_) call tell(myname_,'Reading obsdiags, file =',trim(filename_(cdfile,iPE))) - - leadNode => null() - do ii=1,size(obsdiags,2) - do jj=1,size(obsdiags,1) - if(CHECK_SIZES_) then - lsize_type_= obsLList_lcount(obsLLists(jj,ii),luseonly=.true.,recount=.true.) - nsize_type_= obsLList_lsize (obsLLists(jj,ii) ) - - lsize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),luseonly=.true.,recount=.true.) - !msize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),museonly=.true.) - nsize_diag_= obsdiagLList_lsize (obsdiags(jj,ii) ) - endif - - call obsdiagLList_read(obsdiags(jj,ii),iunit,redistr,jiter,miter,jj,ii,jread_,leadNode=leadNode,ignore_iter=ignore_iter) - if(present(jread)) then - if(jread/=jread_) then - if(jread>0) then - call perr(myname_,'not the same iteration, jiter =',jiter) - call perr(myname_,' saved jread =',jread) - call perr(myname_,' current jread =',jread_) - call die(myname_) - endif - jread=jread_ - endif - endif - - call obsdiagLookup_build(obsdiags(jj,ii),leadNode=leadNode,jiter=jread) - leadNode => null() ! nullified after its use, to avoid leadNode dangling arround. - - if (force_read .or. l4dvar.and..not.(lobserver.and.jiter==1)) then - call obsLList_read(obsLLists(jj,ii),iunit,redistr,obsdiags(jj,ii),jj) - endif - - call obsdiagLookup_clean(obsdiags(jj,ii)) - - read(iunit)ki,kj - if(ki/=ii .or. kj/=jj) then - call perr(myname_,'mismatched block id, file =',filename_(cdfile,iPE)) - if(kj/=jj) then - call perr(myname_,' reading kj =',kj) - call perr(myname_,' expecting jj =',jj) - endif - if(ki/=ii) then - call perr(myname_,' reading ki =',ki) - call perr(myname_,' expecting ii =',ii) - endif - call perr(myname_,' file =',filename_(cdfile,iPE)) - call perr(myname_,' cdfile =',cdfile) - call perr(myname_,' myPE =',myPE) - call perr(myname_,' iPE =',iPE) - call perr(myname_,' miter =',miter) - call perr(myname_,' redistr =',redistr) - call perr(myname_,' newunit =',iunit) - call perr(myname_,' iostat =',istat) - call die(myname_) - endif - - ASSERT(1<=jj.and.jj<=nobs_type) - - if(CHECK_SIZES_) then - lsize_type_= obsLList_lcount(obsLLists(jj,ii),luseonly=.true.)-lsize_type_ - nsize_type_= obsLList_lsize (obsLLists(jj,ii) )-nsize_type_ - - lsize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),luseonly=.true.)-lsize_diag_ - !msize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),museonly=.true.)-msize_diag_ - nsize_diag_= obsdiagLList_lsize (obsdiags(jj,ii) )-nsize_diag_ - - if( fileislocal .or. lsize_type_>0.or.nsize_type_>0 .or. & - msize_diag_>0.or. lsize_diag_>0.or.nsize_diag_>0 ) then - write(stdout,'(i5.3,2i5,2x,5i6,2x,l1)') iPE,jj,ii,lsize_type_,nsize_type_, & - msize_diag_,lsize_diag_,nsize_diag_,fileislocal - endif - - lsize_type(jj)= lsize_type(jj) +lsize_type_ - nsize_type(jj)= nsize_type(jj) +nsize_type_ - - lsize_diag(jj)= lsize_diag(jj) +lsize_diag_ - !msize_diag(jj)= msize_diag(jj) +msize_diag_ - nsize_diag(jj)= nsize_diag(jj) +nsize_diag_ - endif - - enddo ! jj=1,nobs_type - enddo ! ii=1,nobs_bins - - close(iunit) -! ---------------------------------------------------------- -_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine read_ - -function filename_(prefix,iPE) - implicit none - character(len=:),allocatable:: filename_ - character(len=*) , intent(in ):: prefix - integer(kind=i_kind), intent(in ):: iPE - - character(len=4):: chPE - write(chPE,'(i4.4)') iPE - filename_=trim(adjustl(prefix))//'.'//trim(chPE) -end function filename_ - -function hdfilename_(prefix) - use kinds, only: i_kind - implicit none - character(len=:),allocatable:: hdfilename_ - character(len=*) , intent(in ):: prefix - hdfilename_=trim(adjustl(prefix))//'.headers' -end function hdfilename_ - -subroutine summary_(title) -!-- get a summary of obsdiags(:,:) and obsLLists(:,:) -use obsmod, only: luse_obsdiag -use mpeu_util, only: tell,die,perr,stdout_open,stdout_close -_TIMER_USE_ - - use gsi_unformatted, only: unformatted_open - use gsi_4dvar, only: nobs_bins - - use m_obsLList, only: obsLList_lsize => obsLList_lcount - use m_obsdiagNode, only: obsdiagLList_lsize => obsdiagLList_lcount - - implicit none - character(len=*), intent(in) :: title - - character(len=*), parameter :: myname_=myname//"::summary_" - - integer(i_kind) :: ii,jj - integer(i_kind),dimension(nobs_type,nobs_bins):: ldiag,ndiag - integer(i_kind),dimension(nobs_type,nobs_bins):: lobss,nobss -_ENTRY_(myname_) -_TIMER_ON_(myname_) -! ---------------------------------------------------------- - - call lobsdiags_statusCheck_(myname_,allocated=.true.) - - if (luse_obsdiag) then - ASSERT(all(shape(obsdiags)==shape(obsLLists))) - ASSERT(size(obsdiags,1)==size(obsLLists,1)) - ASSERT(size(obsdiags,2)==size(obsLLists,2)) - endif - - do ii=1,size(obsdiags,2) - do jj=1,size(obsdiags,1) - ldiag(jj,ii) = obsdiagLList_lsize(obsdiags(jj,ii),luseonly=.true. ,recount=.true.) - ndiag(jj,ii) = obsdiagLList_lsize(obsdiags(jj,ii),luseonly=.false.,recount=.true.) - enddo - enddo - - do ii=1,size(obsLLists,2) - do jj=1,size(obsLLists,1) - lobss(jj,ii) = obsLList_lsize(obsLLists(jj,ii),luseonly=.true. ,recount=.true.) - nobss(jj,ii) = obsLList_lsize(obsLLists(jj,ii),luseonly=.false.,recount=.true.) - enddo - enddo - - call gather_write_(title,lobss,ldiag,nobss,ndiag,root=0,comm=gsi_comm_world) - -! ---------------------------------------------------------- -_TIMER_OFF_(myname_) -_EXIT_(myname_) -return -end subroutine summary_ - -subroutine gather_write_(title,lobss,ldiag,nobss,ndiag,root,comm) - use mpimod , only: mype,nPE - use kinds , only: i_kind - use mpeu_mpif, only: MPI_ikind - _TIMER_USE_ - implicit none - character(len=*),intent(in):: title - integer(kind=i_kind),dimension(:,:),intent(in):: lobss,ldiag - integer(kind=i_kind),dimension(:,:),intent(in):: nobss,ndiag - integer(kind=MPI_ikind),intent(in):: root - integer(kind=MPI_ikind),intent(in):: comm - - character(len=*),parameter:: myname_=myname//'::gather_write_' - integer(kind=i_kind):: jj,ii,iPE - integer(kind=i_kind) :: mtyp,mbin,mPEs - integer(kind=i_kind),allocatable,dimension(:,:,:):: ldiagm,ndiagm - integer(kind=i_kind),allocatable,dimension(:,:,:):: lobssm,nobssm - -_ENTRY_(myname_) -_TIMER_ON_(myname_) - mtyp=size(lobss,1) - mbin=size(lobss,2) - ASSERT(mtyp==size(nobss,1)) - ASSERT(mbin==size(nobss,2)) - ASSERT(mtyp==size(ldiag,1)) - ASSERT(mbin==size(ldiag,2)) - ASSERT(mtyp==size(ndiag,1)) - ASSERT(mbin==size(ndiag,2)) - - mPEs=0 ! its value is significant only on root - if(myPE==root) mPEs=nPE - - allocate(lobssm(mtyp,mbin,0:mPEs-1)) - allocate(ldiagm(mtyp,mbin,0:mPEs-1)) - allocate(nobssm(mtyp,mbin,0:mPEs-1)) - allocate(ndiagm(mtyp,mbin,0:mPEs-1)) - - call iMPI_gather_(lobss,lobssm,root,comm) - call iMPI_gather_(nobss,nobssm,root,comm) - call iMPI_gather_(ldiag,ldiagm,root,comm) - call iMPI_gather_(ndiag,ndiagm,root,comm) - - if(myPE==root) then - do iPE=0,nPE-1 - write(stdout,'(2a,i6)' ) title,'(): local obs/diag counts, iPE =',iPE - write(stdout,'(2a,9(1x,a))') title,'(): typ', ('| -----lo -----ld -----no -----nd',ii=1,mbin) - do jj=1,mtyp - write(stdout,'(2a,i3,9(1x,a,2(1x,2i8)))') & - title,'(): ',jj , & - ("|",lobssm(jj,ii,iPE),ldiagm(jj,ii,iPE), & - nobssm(jj,ii,iPE),ndiagm(jj,ii,iPE), ii=1,mbin) - enddo - enddo - endif - - deallocate(lobssm) - deallocate(ldiagm) - deallocate(nobssm) - deallocate(ndiagm) -_TIMER_OFF_(myname_) -_EXIT_(myname_) -end subroutine gather_write_ - -subroutine iMPI_barrier_(comm) - use mpeu_mpif, only: MPI_ikind - use mpeu_util, only: die - implicit none - integer(kind=MPI_ikind),intent(in):: comm - - character(len=*),parameter:: myname_=myname//"::iMPI_barrier_" - integer(kind=MPI_ikind):: ier - - call MPI_barrier(comm,ier) - if(ier/=0) call die(myname_,'MPI_barrier() error, ierror =',ier) -end subroutine iMPI_barrier_ - -subroutine iMPI_gather_(isend,irecv,root,comm) - use mpeu_mpif,only: MPI_ikind,MPI_type - use mpeu_util, only: die - use kinds, only: i_kind - implicit none - integer(kind=i_kind),dimension(:,: ),intent(in ):: isend - integer(kind=i_kind),dimension(:,:,:),intent(out):: irecv - integer(kind=MPI_ikind),intent(in):: root - integer(kind=MPI_ikind),intent(in):: comm - - character(len=*),parameter:: myname_=myname//"::iMPI_gather_" - integer(kind=MPI_ikind):: itype,isize,ierr - - isize=size(isend) - itype=MPI_type(isend) - call MPI_gather(isend,isize,itype, & - irecv,isize,itype, root,comm,ierr) - if(ierr/=0) call die(myname_,'MPI_gather() error, ierror =',ierr) -end subroutine iMPI_gather_ - -subroutine iMPI_reduceSUM_(iredu,root,comm) - use mpeu_mpif,only: MPI_ikind,MPI_type,MPI_SUM - use mpeu_util, only: die - use kinds, only: i_kind - implicit none - integer(kind=i_kind),dimension(:),intent(inout):: iredu - integer(kind=MPI_ikind),intent(in):: root - integer(kind=MPI_ikind),intent(in):: comm - - character(len=*),parameter:: myname_=myname//"::iMPI_reduceSUM_" - integer(kind=MPI_ikind):: itype,isize,ierr - !integer(kind=kind(iredu)),dimension(size(iredu)):: irecv - - isize=size(iredu) - itype=MPI_type(iredu) - call MPI_reduce((iredu),iredu,isize,itype, MPI_SUM, root,comm,ierr) - if(ierr/=0) call die(myname_,'MPI_reduce(MPI_SUM) error, ierror =',ierr) - !iredu(:)=irecv(:) -end subroutine iMPI_reduceSUM_ - -subroutine create_obsmod_vars() -!$$$ subprogram documentation block -! . . . . -! subprogram: create_obsmod_vars -! prgmmr: derber org: np23 date: 2003-09-25 -! -! abstract: allocate arrays to hold observation related information -! -! program history log: -! 2003-09-25 derber -! 2004-05-13 treadon, documentation -! 2015-10-09 j guo - moved here from MODULE OBSMOD with modifcations -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ end documentation block - use gsi_4dvar, only: nobs_bins - implicit none - !ALLOCATE(obsdiags(nobs_type,nobs_bins)) - allocate(obsllists(nobs_type,nobs_bins)) - call aliasesCreate_() - return -end subroutine create_obsmod_vars - -subroutine destroy_obsmod_vars() -!-- Created to pair with create_obsmod_vars(). - implicit none - call aliasesDestroy_() - deallocate(obsllists) - !deallocate(obsdiags) - return -end subroutine destroy_obsmod_vars -end module m_obsdiags diff --git a/src/m_radNode.F90 b/src/m_radNode.F90 deleted file mode 100644 index 3898398aa..000000000 --- a/src/m_radNode.F90 +++ /dev/null @@ -1,373 +0,0 @@ -module m_radNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_radNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type radNode (radiances) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! 2016-07-19 kbathmann - add rsqrtinv and use_corr_obs to rad_ob_type -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use obsmod, only: obs_diag,aofp_obs_diag - use obsmod, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: radNode - - type,extends(obsNode):: radNode - !type(rad_ob_type),pointer :: llpoint => NULL() - type(aofp_obs_diag), dimension(:), pointer :: diags => NULL() - real(r_kind),dimension(:),pointer :: res => NULL() - ! obs-guess residual (nchan) - real(r_kind),dimension(:),pointer :: err2 => NULL() - ! error variances squared (nchan) - real(r_kind),dimension(:),pointer :: raterr2 => NULL() - ! ratio of error variances squared (nchan) - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: wij(4) ! horizontal interpolation weights - real(r_kind),dimension(:,:),pointer :: pred => NULL() - ! predictors (npred,nchan) - real(r_kind),dimension(:,:),pointer :: dtb_dvar => NULL() - ! radiance jacobian (nsigradjac,nchan) - - real(r_kind),dimension(:),pointer :: rsqrtinv => NULL() - ! square root of inverse of R, only used - ! if using correlated obs - integer(i_kind),dimension(:),pointer :: icx => NULL() - integer(i_kind),dimension(:),pointer :: ich => NULL() - integer(i_kind) :: nchan ! number of channels for this profile - integer(i_kind) :: ij(4) ! horizontal locations - logical :: use_corr_obs ! logical to indicate if using correlated obs - !logical :: luse ! flag indicating if ob is used in pen. - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - -!!! Is %isis or %isfctype ever being assigned somewhere in the code? -!!! They are used in intrad(). -!!! -!!! Now, they are not written to an obsdiags file, nor read from one. - - character(20) :: isis ! sensor/instrument/satellite id, e.g. amsua_n15 - integer(i_kind) :: isfctype ! surf mask: ocean=0,land=1,ice=2,snow=3,mixed=4 - !integer(i_kind),dimension(:),pointer :: ich => NULL() - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - procedure, nopass:: headerRead => obsHeader_read_ - procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ - end type radNode - - public:: radNode_typecast - public:: radNode_nextcast - interface radNode_typecast; module procedure typecast_ ; end interface - interface radNode_nextcast; module procedure nextcast_ ; end interface - - character(len=*),parameter:: MYNAME="m_radNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(radNode) - use m_obsNode, only: obsNode - implicit none - type(radNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//"::typecast_" - ptr_ => null() - if(.not.associated(aNode)) return - select type(aNode) - type is(radNode) - ptr_ => aNode - class default - call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(radNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(radNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - - class(obsNode),pointer:: anode_ - anode_ => obsNode_next(aNode) - ptr_ => typecast_(anode_) -return -end function nextcast_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[radNode]" -end function mytype - -subroutine obsHeader_read_(iunit,mobs,jread,istat) - use radinfo, only: npred,nsigradjac - implicit none - integer(i_kind),intent(in ):: iunit - integer(i_kind),intent(out):: mobs - integer(i_kind),intent(out):: jread - integer(i_kind),intent(out):: istat - - character(len=*),parameter:: myname_=myname//'.obsHeader_read_' - integer(i_kind):: mpred,msigradjac -_ENTRY_(myname_) - - read(iunit,iostat=istat) mobs,jread, mpred,msigradjac - if(istat==0 .and. (npred/=mpred .or. nsigradjac/=msigradjac)) then - call perr(myname_,'unmatched dimension information, npred or nsigradjac') - if(npred/=mpred) then - call perr(myname_,' expecting npred =',npred) - call perr(myname_,' but read mpred =',mpred) - endif - if(nsigradjac/=msigradjac) then - call perr(myname_,'expecting nsigradjac =',nsigradjac) - call perr(myname_,' but read msigradjac =',msigradjac) - endif - call die(myname_) - endif -_EXIT_(myname_) -return -end subroutine obsHeader_read_ - -subroutine obsHeader_write_(junit,mobs,jwrite,jstat) - use radinfo, only: npred,nsigradjac - implicit none - integer(i_kind),intent(in ):: junit - integer(i_kind),intent(in ):: mobs - integer(i_kind),intent(in ):: jwrite - integer(i_kind),intent(out):: jstat - - character(len=*),parameter:: myname_=myname//'.obsHeader_write_' -_ENTRY_(myname_) - write(junit,iostat=jstat) mobs,jwrite, npred,nsigradjac -_EXIT_(myname_) -return -end subroutine obsHeader_write_ - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - use radinfo, only: npred,nsigradjac - implicit none - class(radNode),intent(inout):: aNode - integer(i_kind),intent(in ):: iunit - integer(i_kind),intent( out):: istat - type(obs_diags),intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_' - integer(i_kind):: k,nchan - logical:: skip_ -_ENTRY_(myname_) - skip_=.false. - if(present(skip)) skip_=skip - - istat=0 - if(skip_) then - read(iunit,iostat=istat) - if (istat/=0) then - call perr(myname_,'skipping read(%nchan), iostat =',istat) - _EXIT_(myname_) - return - end if - - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=istat) aNode%nchan - if (istat/=0) then - call perr(myname_,'read(%nchan), iostat =',istat) - _EXIT_(myname_) - return - end if - - if(associated(aNode%diags )) deallocate(aNode%diags ) - if(associated(aNode%ich )) deallocate(aNode%ich ) - if(associated(aNode%res )) deallocate(aNode%res ) - if(associated(aNode%err2 )) deallocate(aNode%err2 ) - if(associated(aNode%raterr2 )) deallocate(aNode%raterr2 ) - if(associated(aNode%pred )) deallocate(aNode%pred ) - if(associated(aNode%dtb_dvar)) deallocate(aNode%dtb_dvar) - if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv) - if(associated(aNode%icx )) deallocate(aNode%icx ) - - nchan=aNode%nchan - allocate( aNode%diags(nchan), & - aNode%res (nchan), & - aNode%err2 (nchan), & - aNode%raterr2 (nchan), & - aNode%pred (npred,nchan), & - aNode%dtb_dvar(nsigradjac,nchan), & - aNode%ich (nchan), & - aNode%icx (nchan) ) - - if (aNode%use_corr_obs) then - deallocate(aNode%rsqrtinv, stat=istat) - if (istat/=0) write(6,*)'DESTROYOBS: deallocate error for rad rsqrtinv, istatus=',istat - endif - - read(iunit,iostat=istat) aNode%ich , & - aNode%res , & - aNode%err2 , & - aNode%raterr2 , & - aNode%pred , & - aNode%icx , & - aNode%dtb_dvar, & - aNode%wij , & - aNode%ij - if (istat/=0) then - call perr(myname_,'read(%(res,err2,...)), iostat =',istat) - _EXIT_(myname_) - return - end if - - if (aNode%use_corr_obs) then - read(iunit,iostat=istat) aNode%rsqrtinv - if (istat/=0) then - call perr(myname_,'read(%(rsqrtinv)), iostat =',istat) - _EXIT_(myname_) - return - end if - endif - - do k=1,nchan - aNode%diags(k)%ptr => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,aNode%ich(k)) - if(.not.associated(aNode%diags(k)%ptr)) then - call perr(myname_,'obsdiagLookup_locate(k), k =',k) - call perr(myname_,' %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call perr(myname_,' %ich(k) =',aNode%ich(k)) - call die(myname_) - endif - enddo - endif -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(radNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_' - integer(i_kind):: k -_ENTRY_(myname_) - - jstat=0 - write(junit,iostat=jstat) aNode%nchan - if (jstat/=0) then - call perr(myname_,'write(%nchan), iostat =',jstat) - _EXIT_(myname_) - return - end if - - write(junit,iostat=jstat) (/ (aNode%ich(k),k=1,aNode%nchan) /), & - aNode%res , & - aNode%err2 , & - aNode%raterr2 , & - aNode%pred , & - aNode%icx , & - aNode%dtb_dvar, & - aNode%wij , & - aNode%ij - if (jstat/=0) then - call perr(myname_,'write(%(ich,res,err2,...)), iostat =',jstat) - _EXIT_(myname_) - return - end if - if (aNode%use_corr_obs) then - write(junit,iostat=jstat) aNode%rsqrtinv - if (jstat/=0) then - call perr(myname_,'write(%(rsqrtinv)), iostat =',jstat) - _EXIT_(myname_) - return - end if - endif - -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(radNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) -_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(radNode),intent(in):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' - integer(i_kind):: k -_ENTRY_(myname_) - isvalid_=all( (/ (associated(aNode%diags(k)%ptr),k=1,aNode%nchan) /) ) -_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(radNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - integer(kind=i_kind):: k - do k=1,aNode%nchan - tlddp = tlddp + aNode%diags(k)%ptr%tldepart(jiter)*aNode%diags(k)%ptr%tldepart(jiter) - enddo - if(present(nob)) nob=nob+aNode%nchan -return -end subroutine gettlddp_ - -end module m_radNode diff --git a/src/m_rhs.F90 b/src/m_rhs.F90 deleted file mode 100644 index 3999d86a3..000000000 --- a/src/m_rhs.F90 +++ /dev/null @@ -1,159 +0,0 @@ -module m_rhs -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_rhs -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 900.3 -! date: 2010-03-22 -! -! abstract: defines persistant workspace for multiple-pass setuprhsall() -! -! program history log: -! 2010-03-22 j guo - added this document block -! 2010-04-22 tangborn- add co knobs -! 2010-05-27 j guo - cut off GPS related variables to m_gpsrhs -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -#include "mytrace.H" - -! module interface: - - use kinds, only: r_kind, i_kind, r_single - use mpeu_util, only: die,perr,tell - implicit none - private - public:: rhs_alloc ! interface for allocation - public:: rhs_dealloc ! interface for deallocation - public:: rhs_allocated ! state of all moduel variables - - public:: rhs_awork ! variables ... - public:: rhs_bwork - public:: rhs_aivals - public:: rhs_stats - public:: rhs_stats_oz - public:: rhs_stats_co - public:: rhs_toss_gps - -! Revision history: -! 2009-08-19 guo - created to support multi-pass setuprhsall(). -! This module contains all statistics variables -! defined for any single pass but all passes. - - !! usage: - !! use xyz_mod, only: npres_print,nconvtype,nsig - !! use m_rhs, only: rhs_alloc - !! use m_rhs, only: rhs_dealloc - !! use m_rhs, only: rhs_allocated - !! use m_rhs, only: awork => rhs_awork - !! use m_rhs, only: bwork => rhs_bwork - !! - !! if(.not.rhs_allocated) & - !! call rhs_alloc() - !! call xxxx(awork,bwork,...) - !! call rhs_dealloc() - - logical,save:: rhs_allocated=.false. - real(r_kind),allocatable,dimension(:,: ),save:: rhs_awork - real(r_kind),allocatable,dimension(:,:,:,:),save:: rhs_bwork - real(r_kind),allocatable,dimension(:,: ),save:: rhs_aivals - real(r_kind),allocatable,dimension(:,: ),save:: rhs_stats - real(r_kind),allocatable,dimension(:,: ),save:: rhs_stats_oz - real(r_kind),allocatable,dimension(:,: ),save:: rhs_stats_co - real(r_kind),allocatable,dimension(: ),save:: rhs_toss_gps - - character(len=*),parameter:: myname="m_rhs" - -contains -subroutine rhs_alloc(aworkdim2) - ! supporting information - use kinds, only: i_kind - use constants, only: zero - - ! run-time dimensional information - use obsmod , only: ndat - use obsmod , only: nprof_gps - use radinfo , only: jpch_rad - use ozinfo , only: jpch_oz - use coinfo , only: jpch_co - use qcmod , only: npres_print - use gridmod , only: nsig - use convinfo, only: nconvtype - - ! indirectly used counter - use obsmod , only: nchan_total - use gsi_io, only: verbose - implicit none - integer(i_kind),optional,intent(in):: aworkdim2 - character(len=*),parameter:: myname_=myname//'.alloc' - integer(i_kind):: aworkdim2_ - logical print_verbose -_ENTRY_(myname_) - print_verbose=.false. - if(verbose) print_verbose=.true. - if(rhs_allocated) call die(myname_,'already allocated') - aworkdim2_=25 - if(present(aworkdim2)) aworkdim2_=aworkdim2 - - if(print_verbose)then - call tell(myname_,'nsig =' ,nsig) - call tell(myname_,'npres_print =',npres_print) - call tell(myname_,'nconvtype =' ,nconvtype) - call tell(myname_,'ndat =' ,ndat) - call tell(myname_,'jpch_rad =' ,jpch_rad) - call tell(myname_,'jpch_co =' ,jpch_co) - call tell(myname_,'jpch_oz =' ,jpch_oz) - call tell(myname_,'nprof_gps =' ,nprof_gps) - call tell(myname_,'aworkdim2 =' ,aworkdim2_) - end if - - rhs_allocated=.true. - allocate(rhs_awork(7*nsig+100,aworkdim2_)) - allocate(rhs_bwork(npres_print,nconvtype,5,3)) - allocate(rhs_aivals(40,ndat)) - allocate(rhs_stats(7,jpch_rad)) - allocate(rhs_stats_co(9,jpch_co)) - allocate(rhs_stats_oz(9,jpch_oz)) - - allocate(rhs_toss_gps(max(1,nprof_gps))) - - rhs_awork =zero - rhs_bwork =zero - rhs_aivals =zero - rhs_stats =zero - rhs_stats_co =zero - rhs_stats_oz =zero - rhs_toss_gps =zero - - nchan_total =0 -_EXIT_(myname_) -end subroutine rhs_alloc - -subroutine rhs_dealloc() - use kinds, only: i_kind - implicit none - character(len=*),parameter:: myname_=myname//'.dealloc' -_ENTRY_(myname_) - if(.not.rhs_allocated) call die(myname_,'can not be deallocted') - - rhs_allocated=.false. - deallocate(rhs_awork) - deallocate(rhs_bwork) - deallocate(rhs_aivals) - deallocate(rhs_stats) - deallocate(rhs_stats_co) - deallocate(rhs_stats_oz) - - deallocate(rhs_toss_gps) -_EXIT_(myname_) -end subroutine rhs_dealloc - -end module m_rhs diff --git a/src/m_sortind.f90 b/src/m_sortind.f90 deleted file mode 100644 index 1f39fe845..000000000 --- a/src/m_sortind.f90 +++ /dev/null @@ -1,215 +0,0 @@ -module m_sortind - -!$$$ module documentation block -! . . . . -! module: m_sortind finds indices to sort an array in ascending order -! prgmmr: eliu -! -! abstract: module to find indices to sort an array in ascending order -! assimilation -! -! program history log: -! 1996-10-01 Joiner/Karki - initial coding from NASA/GMAO -! 2012-02-15 eliu - reformat to use in GSI -! -! subroutines included: -! -! variable definitions: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - - use kinds,only : i_kind, r_kind - interface sortind - module procedure r_sortind - module procedure i_sortind - end interface - - contains - - function r_sortind(arr) result(arr2) - implicit none - - !input parameters: - real(r_kind), dimension(:) :: arr ! input vector to sort - !output parameters: - integer(i_kind), dimension(size(arr)) :: arr2 - - call indexx(size(arr),arr, arr2) - - end function r_sortind - - function i_sortind(arr) result(arr2) - - implicit none - - integer(i_kind), dimension(:) :: arr - integer(i_kind), dimension(size(arr)) :: arr2 - - call iindexx(size(arr),arr, arr2) - - end function i_sortind - - SUBROUTINE indexx(n,arr,indx) - - INTEGER(i_kind):: n,indx(n),M,NSTACK - REAL(r_kind) :: arr(n) - PARAMETER (M=7,NSTACK=50) - INTEGER(i_kind):: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) - REAL(r_kind) :: a - do 11 j=1,n - indx(j)=j -11 continue - jstack=0 - l=1 - ir=n -1 if(ir-l.lt.M)then - do 13 j=l+1,ir - indxt=indx(j) - a=arr(indxt) - do 12 i=j-1,1,-1 - if(arr(indx(i)).le.a)goto 2 - indx(i+1)=indx(i) -12 continue - i=0 -2 indx(i+1)=indxt -13 continue - if(jstack.eq.0)return - ir=istack(jstack) - l=istack(jstack-1) - jstack=jstack-2 - else - k=(l+ir)/2 - itemp=indx(k) - indx(k)=indx(l+1) - indx(l+1)=itemp - if(arr(indx(l+1)).gt.arr(indx(ir)))then - itemp=indx(l+1) - indx(l+1)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l)).gt.arr(indx(ir)))then - itemp=indx(l) - indx(l)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l+1)).gt.arr(indx(l)))then - itemp=indx(l+1) - indx(l+1)=indx(l) - indx(l)=itemp - endif - i=l+1 - j=ir - indxt=indx(l) - a=arr(indxt) -3 continue - i=i+1 - if(arr(indx(i)).lt.a)goto 3 -4 continue - j=j-1 - if(arr(indx(j)).gt.a)goto 4 - if(j.lt.i)goto 5 - itemp=indx(i) - indx(i)=indx(j) - indx(j)=itemp - goto 3 -5 indx(l)=indx(j) - indx(j)=indxt - jstack=jstack+2 - if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' - if(ir-i+1.ge.j-l)then - istack(jstack)=ir - istack(jstack-1)=i - ir=j-1 - else - istack(jstack)=j-1 - istack(jstack-1)=l - l=i - endif - endif - goto 1 - END subroutine indexx - - SUBROUTINE iindexx(n,arr,indx) - INTEGER(i_kind):: n,indx(n),M,NSTACK - INTEGER(i_kind):: arr(n) - PARAMETER (M=7,NSTACK=50) - INTEGER(i_kind):: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) - INTEGER(i_kind):: a - do 11 j=1,n - indx(j)=j -11 continue - jstack=0 - l=1 - ir=n -1 if(ir-l.lt.M)then - do 13 j=l+1,ir - indxt=indx(j) - a=arr(indxt) - do 12 i=j-1,1,-1 - if(arr(indx(i)).le.a)goto 2 - indx(i+1)=indx(i) -12 continue - i=0 -2 indx(i+1)=indxt -13 continue - if(jstack.eq.0)return - ir=istack(jstack) - l=istack(jstack-1) - jstack=jstack-2 - else - k=(l+ir)/2 - itemp=indx(k) - indx(k)=indx(l+1) - indx(l+1)=itemp - if(arr(indx(l+1)).gt.arr(indx(ir)))then - itemp=indx(l+1) - indx(l+1)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l)).gt.arr(indx(ir)))then - itemp=indx(l) - indx(l)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l+1)).gt.arr(indx(l)))then - itemp=indx(l+1) - indx(l+1)=indx(l) - indx(l)=itemp - endif - i=l+1 - j=ir - indxt=indx(l) - a=arr(indxt) -3 continue - i=i+1 - if(arr(indx(i)).lt.a)goto 3 -4 continue - j=j-1 - if(arr(indx(j)).gt.a)goto 4 - if(j.lt.i)goto 5 - itemp=indx(i) - indx(i)=indx(j) - indx(j)=itemp - goto 3 -5 indx(l)=indx(j) - indx(j)=indxt - jstack=jstack+2 - if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' - if(ir-i+1.ge.j-l)then - istack(jstack)=ir - istack(jstack-1)=i - ir=j-1 - else - istack(jstack)=j-1 - istack(jstack-1)=l - l=i - endif - endif - goto 1 - END subroutine iindexx - -end module m_sortind diff --git a/src/makefile_DTC b/src/makefile_DTC deleted file mode 100644 index 078e0d66f..000000000 --- a/src/makefile_DTC +++ /dev/null @@ -1,112 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# DTC GSI Makefile -# -#============================================================================== - -#------------ -# Include machine dependent compile & load options -#------------ -include ../dtc/configure.gsi - -COREROOT = $(COREDIR) -COREBIN = $(COREROOT)/run -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc -EXE_FILE = gsi.exe - - -# --------- -# Libraries -# --------- -## LIBmpeu = -L$(CORELIB) -lmpeu -LIBbufr = -L$(CORELIB) -lbufr_i4r8 -LIBw3 = -L$(CORELIB) -lw3nco_i4r8 -lw3emc_i4r8 -LIBsp = -L$(CORELIB) -lsp_i4r8 -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio_i4r4 -LIBsigio = -L$(CORELIB) -lsigio_i4r4 -LIBcrtm = -L$(CORELIB) -lcrtm -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBnemsio = -L$(CORELIB) -lnemsio -LIBrrcld = -L$(CORELIB) -lgsdcloud -LIBprpdcdr = -L$(CORELIB) -lprepdecode_i4r8 - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -LIBnetcdf = -L$(NETCDFPATH)/lib $(NETCDFLIBS) -LIBwrf = $(WRF_LIB) - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -## LIBsys = -lessl_r -lmass -bdatapsize:64K -bstackpsize:64K -LIBsys = $(MYLIBsys) - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = $(COREBIN) - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - include ./Makefile.src - -# ---- - -LIB = libgsi.a - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : $(LIB) $(EXE_FILE) - - -$(LIB): $(OBJS) - echo $(OBJS) - $(AR) -ruv $(LIB) $(OBJS) - -$(EXE_FILE): $(OBJS) $(LIB) gsimain.o - $(F90) $(LDFLAGS) $(OMP) -o gsi.exe gsimain.o libgsi.a $(LIBcrtm) $(LIBsfcio) $(LIBsigio) $(LIBnemsio) $(LIBw3) $(LIBbacio) $(LIBbufr) $(LIBsp) $(LIBmpeu) $(LIBwrf) $(LIBnetcdf) $(LIBsys) $(LIBprpdcdr) - cp $(EXE_FILE) $(COREBIN) - -# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) - -include Makefile.dependency - -.SUFFIXES : .f90 .F90 .fpp .o - -.F90.o: - $(CPP) $(CPP_FLAGS) $(CPP_F90FLAGS) $*.F90 > $*.fpp - $(F90) $(FFLAGS) -c $*.fpp - $(RM) $*.fpp - - -%.o : %.mod - - -clean: - $(RM) -f *.o *.exe $(LIB) - diff --git a/src/ncdiag/CMakeLists.txt b/src/ncdiag/CMakeLists.txt new file mode 100644 index 000000000..154a098ed --- /dev/null +++ b/src/ncdiag/CMakeLists.txt @@ -0,0 +1,26 @@ +cmake_minimum_required(VERSION 2.8) +if(BUILD_NCDIAG) + if(BUILD_NCDIAG_SERIAL) + add_subdirectory(serial) + endif(BUILD_NCDIAG_SERIAL) + set(Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include") + + # NetCDF-4 library + include_directories( ${NETCDF_INCLUDES} ${NCDIAG_INCS} ) + + # 32-bit reals, for now + add_definitions(-D_REAL4_ -DUSE_MPI) + FILE(GLOB NCDIAG_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90 ) + set_source_files_properties( ${NCDIAG_SRC} PROPERTIES COMPILE_FLAGS ${NCDIAG_Fortran_FLAGS} ) + LIST(REMOVE_ITEM NCDIAG_SRC ${CMAKE_CURRENT_SOURCE_DIR}/test_nc_unlimdims.F90 ) + LIST(REMOVE_ITEM NCDIAG_SRC ${CMAKE_CURRENT_SOURCE_DIR}/nc_diag_cat.F90 ) + add_library(ncdiag STATIC ${NCDIAG_SRC}) + add_executable(test_nc_unlimdims.x ${CMAKE_CURRENT_SOURCE_DIR}/test_nc_unlimdims.F90 ) + add_executable(nc_diag_cat.x ${CMAKE_CURRENT_SOURCE_DIR}/nc_diag_cat.F90 ) + target_link_libraries(nc_diag_cat.x ncdiag ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${ZLIB_LIBRARIES} ${MPI_Fortran_LIBRARIES}) + target_link_libraries(test_nc_unlimdims.x ncdiag ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${ZLIB_LIBRARIES} ${MPI_Fortran_LIBRARIES}) +# set_target_properties(test_nc_unlimdims.x PROPERTIES Fortran_MODULE_DIRECTORY ${NCDIAG_INCS} ) +# set_target_properties(nc_diag_cat.x PROPERTIES Fortran_MODULE_DIRECTORY ${NCDIAG_INCS} ${MPI_Fortran_INCLUDE_PATH}) + +endif(BUILD_NCDIAG) + diff --git a/src/ncdiag/NCDIAG_SRC b/src/ncdiag/NCDIAG_SRC new file mode 100644 index 000000000..5a57f2c07 --- /dev/null +++ b/src/ncdiag/NCDIAG_SRC @@ -0,0 +1 @@ +../kinds.F90 \ No newline at end of file diff --git a/src/ncdiag/nc_diag_cat.F90 b/src/ncdiag/nc_diag_cat.F90 new file mode 100644 index 000000000..ce7492978 --- /dev/null +++ b/src/ncdiag/nc_diag_cat.F90 @@ -0,0 +1,138 @@ +program nc_diag_cat + use ncd_kinds, only: r_double + use ncdc_climsg, only: ncdc_info, ncdc_warning, ncdc_error, & + ncdc_check + use ncdc_cli_process, only: nc_diag_cat_process_args + +#ifdef USE_MPI + use ncdc_state, only: output_file, ncid_output, ierr, cur_proc, num_procs + use ncdc_data_mpi, only: nc_diag_cat_data_pass, nc_diag_cat_data_commit +#else + use ncdc_state, only: output_file, ncid_output + use ncdc_data, only: nc_diag_cat_data_pass, nc_diag_cat_data_commit +#endif + + use ncdc_metadata, only: nc_diag_cat_metadata_pass, & + nc_diag_cat_metadata_define, nc_diag_cat_metadata_alloc + + use netcdf, only: nf90_inq_libvers, nf90_create, nf90_close, & + NF90_NETCDF4, NF90_CLOBBER + + implicit none + +#ifdef USE_MPI + include "mpif.h" +#endif + + ! NCDC = Net CDF Diag Concatenation + character(len=300) :: info_str + + real(r_double) :: start_time, stop_time + +#ifdef USE_MPI + ! MPI is essentially a smarter fork()... but remember, we're still + ! forking! That means that there WILL be multiple processes! + + ! Do MPI things: + ! First, initialize it! + call MPI_INIT(ierr) + + ! Get the current processor (or really, the "PC") number + call MPI_COMM_RANK(MPI_COMM_WORLD, cur_proc, ierr) + + ! Get the total number of processors / PCs + call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr) + + if (num_procs < 2) & + call ncdc_error("At least 2 processors are required to use MPI features.") + + if (num_procs < 3) & + call ncdc_warning("3 processors or more is needed to best use MPI features.") + + if (cur_proc == 0) & + call ncdc_info("Using MPI for faster concatenation.") +#endif + + call ncdc_info('Initializing netcdf layer library, version ' // trim(nf90_inq_libvers()) // '...') + + ! nc_diag_cat steps: + ! 1) Do a quick pass to read metadata, then allocate space as + ! necessary. + ! 2) Define variables with metadata. Do NOT store attributes. + ! 3) Read all the files, and add data to the output file. + + call nc_diag_cat_process_args + +#ifdef USE_MPI + if (cur_proc == 0) then +#endif + call ncdc_info("Creating new NetCDF file: " // trim(output_file)) + call ncdc_check( nf90_create(output_file, OR(NF90_NETCDF4, NF90_CLOBBER), ncid_output, & + 0) ) +#ifdef USE_MPI + end if +#endif + + call cpu_time(start_time) + call nc_diag_cat_metadata_pass + call cpu_time(stop_time) + + write (info_str, "(A, F0.3, A)") "Metadata read took ", stop_time - start_time, " seconds!" + call ncdc_info(trim(info_str)) + +#ifdef USE_MPI + if (cur_proc == 0) then +#endif + call nc_diag_cat_metadata_define + +#ifdef DEBUG + print *, "MAIN: trigger data pass!" +#endif + + call cpu_time(start_time) + call nc_diag_cat_metadata_alloc + call cpu_time(stop_time) + + write (info_str, "(A, F0.3, A)") "Data preallocation took ", stop_time - start_time, " seconds!" + call ncdc_info(trim(info_str)) +#ifdef USE_MPI + end if +#endif + + call cpu_time(start_time) + call nc_diag_cat_data_pass + call cpu_time(stop_time) + + write (info_str, "(A, F0.3, A)") "Data read took ", stop_time - start_time, " seconds!" + call ncdc_info(trim(info_str)) + +#ifdef USE_MPI + if (cur_proc == 0) then +#endif + call cpu_time(start_time) + call nc_diag_cat_data_commit + call cpu_time(stop_time) + + write (info_str, "(A, F0.3, A)") "Data commit took ", stop_time - start_time, " seconds!" + call ncdc_info(trim(info_str)) + +#ifdef DEBUG + print *, "ALL DONE!" +#endif + + call ncdc_info("All data queued, letting NetCDF take over (and actually write)!") + + call cpu_time(start_time) + call ncdc_check(nf90_close(ncid_output)) + call cpu_time(stop_time) + + write (info_str, "(A, F0.3, A)") "Final data write took ", stop_time - start_time, " seconds!" + call ncdc_info(trim(info_str)) +#ifdef USE_MPI + endif + + call MPI_FINALIZE(ierr) +#endif + + call ncdc_info("All done!") +end program nc_diag_cat diff --git a/src/ncdiag/nc_diag_fson.f90 b/src/ncdiag/nc_diag_fson.f90 new file mode 100644 index 000000000..3130b5fc5 --- /dev/null +++ b/src/ncdiag/nc_diag_fson.f90 @@ -0,0 +1,563 @@ +! Copyright (c) 2012 Joseph A. Levin +! +! Permission is hereby granted, free of charge, to any person obtaining a copy of this +! software and associated documentation files (the "Software"), to deal in the Software +! without restriction, including without limitation the rights to use, copy, modify, merge, +! publish, distribute, sublicense, and/or sell copies of the Software, and to permit +! persons to whom the Software is furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in all copies or +! substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, +! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR +! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT +! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +! DEALINGS IN THE SOFTWARE. + + +! FSON MODULE +! +! File: nc_diag_fson.f95 +! Author: Joseph A. Levin +! +! Created on March 6, 2012, 7:48 PM +! + +module nc_diag_fson + use ncdf_value_m, ncdf_print => ncdf_value_print, ncdf_destroy => ncdf_value_destroy + use ncdf_string_m + use ncdf_path_m, ncdf_get => ncdf_path_get + + implicit none + + private + + public :: ncdf_parse, ncdf_value, ncdf_get, ncdf_print, ncdf_destroy + + ! FILE IOSTAT CODES + integer, parameter :: end_of_file = -1 + integer, parameter :: end_of_record = -2 + + ! PARSING STATES + integer, parameter :: STATE_LOOKING_FOR_VALUE = 1 + integer, parameter :: STATE_IN_OBJECT = 2 + + integer, parameter :: STATE_IN_PAIR_NAME = 3 + integer, parameter :: STATE_IN_PAIR_VALUE = 4 + + ! POP/PUSH CHARACTER + integer :: pushed_index = 0 + character (len = 10) :: pushed_char + +contains + + ! + ! FSON PARSE + ! + function ncdf_parse(file, unit, str) result(p) + type(ncdf_value), pointer :: p + integer, optional, intent(inout) :: unit + character(len = *), optional, intent(in) :: file + character(len = *), optional, intent(in) :: str + character(len=:),allocatable :: strBuffer + logical :: unit_available + integer :: u + ! init the pointer to null + nullify(p) + + ! select the file unit to use + if (present(unit) .and. present(file)) then + u = unit + elseif (present(file)) then + ! find the first available unit + unit_available = .false. + u = 20 + + do while (.not.unit_available) + inquire(unit = u, exist = unit_available) + u = u + 1 + end do + elseif (present(str)) then + strBuffer = str + u = 0 + else + print *, "ERROR: Need a file or a string" + call exit (1) + end if + + ! open the file + if (present(file)) then + open (unit = u, file = file, status = "old", action = "read", form = "formatted", position = "rewind") + end if + + ! create the value and associate the pointer + p => ncdf_value_create() + + ! parse as a value + call ncdf_parse_value(unit = u, value = p, str = strBuffer) + + ! close the file + if( .not. present(unit)) then + close (u) + end if + + if(allocated(strBuffer)) deallocate(strBuffer) + + end function ncdf_parse + + ! + ! PARSE_VALUE + ! + recursive subroutine ncdf_parse_value(unit, str, value) + integer, intent(inout) :: unit + character(*), intent(inout) :: str + type(ncdf_value), pointer :: value + logical :: eof + character :: c + + ! pop the next non whitespace character off the file + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .true.) + + if (eof) then + return + else + select case (c) + case ("{") + ! start object + value % value_type = TYPE_OBJECT + call ncdf_parse_object(unit, str, value) + case ("[") + ! start array + value % value_type = TYPE_ARRAY + call ncdf_parse_array(unit, str, value) + case ("]") + ! end an empty array + call ncdf_push_char(c) + nullify(value) + case ('"') + ! string + value % value_type = TYPE_STRING + value % value_string => ncdf_parse_string(unit, str) + case ("t") + !true + value % value_type = TYPE_LOGICAL + call ncdf_parse_for_chars(unit, str, "rue") + value % value_logical = .true. + case ("f") + !false + value % value_type = TYPE_LOGICAL + value % value_logical = .false. + call ncdf_parse_for_chars(unit, str, "alse") + case ("n") + value % value_type = TYPE_NULL + call ncdf_parse_for_chars(unit, str, "ull") + case("-", "0": "9") + call ncdf_push_char(c) + call ncdf_parse_number(unit, str, value) + case default + print *, "ERROR: Unexpected character while parsing value. '", c, "' ASCII=", iachar(c) + call exit (1) + end select + end if + + end subroutine ncdf_parse_value + + ! + ! PARSE OBJECT + ! + recursive subroutine ncdf_parse_object(unit, str, parent) + integer, intent(inout) :: unit + character(*), intent(inout) :: str + type(ncdf_value), pointer :: parent, pair + + + logical :: eof + character :: c + + ! pair name + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .true.) + if (eof) then + print *, "ERROR: Unexpected end of file while parsing start of object." + call exit (1) + else if ("}" == c) then + ! end of an empty object + return + else if ('"' == c) then + pair => ncdf_value_create() + pair % name => ncdf_parse_string(unit, str) + else + print *, "ERROR: Expecting string: '", c, "'" + call exit (1) + end if + + ! pair value + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .true.) + if (eof) then + print *, "ERROR: Unexpected end of file while parsing object member. 1" + call exit (1) + else if (":" == c) then + ! parse the value + call ncdf_parse_value(unit, str, pair) + call ncdf_value_add(parent, pair) + else + print *, "ERROR: Expecting : and then a value. ", c + call exit (1) + end if + + ! another possible pair + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .true.) + if (eof) then + return + else if ("," == c) then + ! read the next member + call ncdf_parse_object(unit = unit, str=str, parent = parent) + else if ("}" == c) then + return + else + print *, "ERROR: Expecting end of object.", c + call exit (1) + end if + + end subroutine ncdf_parse_object + + ! + ! PARSE ARRAY + ! + recursive subroutine ncdf_parse_array(unit, str, array) + + implicit none + integer, intent(inout) :: unit + character(*), intent(inout) :: str + type(ncdf_value), pointer :: array, element + + logical :: eof, finished + character :: c + + finished = .false. + do while (.not. finished) + + ! try to parse an element value + element => ncdf_value_create() + call ncdf_parse_value(unit, str, element) + + ! parse value will disassociate an empty array value + if (associated(element)) then + call ncdf_value_add(array, element) + end if + + ! pop the next character + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .true.) + + if (eof) then + finished = .true. + else if ("]" == c) then + ! end of array + finished = .true. + end if + + end do + + end subroutine ncdf_parse_array + + ! + ! PARSE STRING + ! + function ncdf_parse_string(unit, str) result(string) + integer, intent(inout) :: unit + character(*), intent(inout) :: str + type(ncdf_string), pointer :: string + + logical :: eof, escape + character :: c + + string => ncdf_string_create() + escape = .false. + + do + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .false.) + if (eof) then + print *, "Expecting end of string" + call exit(1) + else if (escape) then + call ncdf_string_append(string,c) + escape = .false. + else + if (c == '\\') then + escape = .true. + else if (c == '\"') then + exit + else + call ncdf_string_append(string,c) + end if + end if + end do + end function ncdf_parse_string + + ! + ! PARSE FOR CHARACTERS + ! + subroutine ncdf_parse_for_chars(unit, str, chars) + integer, intent(in) :: unit + character(*), intent(inout) :: str + character(len = *), intent(in) :: chars + integer :: i, length + logical :: eof + character :: c + + length = len_trim(chars) + + do i = 1, length + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .true.) + if (eof) then + print *, "ERROR: Unexpected end of file while parsing array." + call exit (1) + else if (c .ne. chars(i:i)) then + print *, "ERROR: Unexpected character.'", c,"'", chars(i:i) + call exit (1) + end if + end do + + end subroutine ncdf_parse_for_chars + + ! + ! PARSE NUMBER + ! + subroutine ncdf_parse_number(unit, str, value) + integer, intent(inout) :: unit + character(*), intent(inout) :: str + type(ncdf_value), pointer :: value + logical :: eof, negative, decimal, scientific + character :: c + integer :: integral, exp, digit_count + double precision :: frac + + + ! first character is either - or a digit + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .true.) + if (eof) then + print *, "ERROR: Unexpected end of file while parsing number." + call exit (1) + else if ("-" == c) then + negative = .true. + else + negative = .false. + call ncdf_push_char(c) + end if + + + ! parse the integral + integral = ncdf_parse_integer(unit, str) + + decimal = .false. + scientific = .false. + + do + ! first character is either - or a digit + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .true.) + if (eof) then + print *, "ERROR: Unexpected end of file while parsing number." + call exit (1) + else + select case (c) + case (".") + ! this is already fractional number + if (decimal) then + ! already found a decimal place + print *, "ERROR: Unexpected second decimal place while parsing number." + call exit(1) + end if + decimal = .true. + frac = ncdf_parse_integer(unit, str, digit_count) + frac = frac / (10.0d0 ** digit_count) + case ("e", "E") + ! this is already an exponent number + if (scientific) then + ! already found a e place + print *, "ERROR: Unexpected second exponent while parsing number." + call exit(1) + end if + scientific = .true. + ! this number has an exponent + exp = ncdf_parse_integer(unit, str) + if (exp < 0) then + decimal = .true. + end if + + case default + ! this is a integer + if (decimal) then + + ! add the integral + frac = frac + integral + + if (scientific) then + ! apply exponent + frac = frac * (10.0d0 ** exp) + end if + + ! apply negative + if (negative) then + frac = frac * (-1) + end if + + value % value_type = TYPE_REAL + value % value_real = frac + value % value_double = frac + + else + if (scientific) then + ! apply exponent + integral = integral * (10.0d0 ** exp) + end if + + ! apply negative + if (negative) then + integral = integral * (-1) + end if + + value % value_type = TYPE_INTEGER + value % value_integer = integral + end if + call ncdf_push_char(c) + exit + end select + end if + end do + + + + end subroutine + + ! + ! PARSE INTEGER + ! + integer(kind=8) function ncdf_parse_integer(unit, str, digit_count) result(integral) + integer, intent(in) :: unit + character(*), intent(inout) :: str + integer, optional, intent(inout) :: digit_count + logical :: eof, found_sign, found_digit + character :: c + integer :: tmp, icount, isign + integer, parameter :: max_integer_length = 18 + + + icount = 0 + integral = 0 + isign = 1 + found_sign = .false. + found_digit = .false. + do + c = ncdf_pop_char(unit, str, eof = eof, skip_ws = .true.) + if (eof) then + print *, "ERROR: Unexpected end of file while parsing digit." + call exit (1) + else + select case(c) + case ("+") + if (found_sign.or.found_digit) then + print *, "ERROR: Miss formatted number." + call exit(1) + end if + found_sign = .true. + case ("-") + if (found_sign.or.found_digit) then + print *, "ERROR: Miss formatted number." + call exit(1) + end if + found_sign = .true. + isign = -1 + case ("0":"9") + found_sign = .true. + if (icount > max_integer_length) then + print *, "ERROR: Too many digits for an integer." + call exit(1) + end if + ! digit + read (c, '(i1)') tmp + ! shift + if (icount > 0) then + integral = integral * 10 + end if + ! add + integral = integral + tmp + + ! increase the icount + icount = icount + 1 + case default + if (present(digit_count)) then + digit_count = icount + end if + call ncdf_push_char(c) + integral = isign * integral + return + end select + end if + end do + + end function ncdf_parse_integer + + ! + ! POP CHAR + ! + recursive character function ncdf_pop_char(unit, str, eof, skip_ws) result(popped) + integer, intent(in) :: unit + character(*), intent(inout) :: str + logical, intent(out) :: eof + logical, intent(in), optional :: skip_ws + + integer :: ios + character :: c + logical :: ignore + + eof = .false. + if (.not.present(skip_ws)) then + ignore = .false. + else + ignore = skip_ws + end if + + do + if (pushed_index > 0) then + ! there is a character pushed back on, most likely from the number parsing + c = pushed_char(pushed_index:pushed_index) + pushed_index = pushed_index - 1 + ios = 0 + else + if (unit .gt. 0) then + read (unit = unit, fmt = "(a)", advance = "no", iostat = ios) c + else + read (unit = str, fmt = "(a)", iostat = ios) c + str = str(2:) + endif + end if + if (ios == end_of_record) then + cycle + else if (ios == end_of_file) then + eof = .true. + exit + else if (iachar(c) <= 31) then + ! non printing ascii characters + cycle + else if (ignore .and. c == " ") then + cycle + else + popped = c + exit + end if + end do + + end function ncdf_pop_char + + ! + ! PUSH CHAR + ! + subroutine ncdf_push_char(c) + character, intent(inout) :: c + pushed_index = pushed_index + 1 + pushed_char(pushed_index:pushed_index) = c + + end subroutine ncdf_push_char + +end module nc_diag_fson diff --git a/src/ncdiag/nc_diag_read_mod.F90 b/src/ncdiag/nc_diag_read_mod.F90 new file mode 100644 index 000000000..7bba38613 --- /dev/null +++ b/src/ncdiag/nc_diag_read_mod.F90 @@ -0,0 +1,394 @@ +module nc_diag_read_mod + use ncd_kinds, only: i_long + use ncdr_state, only: ncdr_files, ncdr_file_count, & + ncdr_file_total, ncdr_file_highest, ncdr_id_stack, & + current_ncdr_id, ncdr_id_stack_count, ncdr_id_stack_size, & + NCDR_DEFAULT_ENT + use ncdr_check, only: nc_diag_read_get_index_from_filename, & + ncdr_check_ncdr_id, ncdr_check_ncid, ncdr_nc_check + use ncdr_climsg, only: ncdr_error + use ncdr_realloc_mod, only: ncdr_realloc + use netcdf, only: nf90_open, nf90_close, nf90_inquire, & + nf90_inq_libvers, NF90_NOWRITE + + !------------------------------------------------------------------ + ! API imports to expose API from this module + !------------------------------------------------------------------ + use ncdr_alloc_assert, only: & + nc_diag_read_assert_var, & + nc_diag_read_assert_attr, & + nc_diag_read_assert_global_attr, & + nc_diag_read_get_type_str + + use ncdr_attrs, only: & + nc_diag_read_check_attr, & + nc_diag_read_get_attr_type, & + nc_diag_read_ret_attr_len, & + nc_diag_read_get_attr_len, & + nc_diag_read_get_attr_names + + use ncdr_attrs_fetch, only: & + nc_diag_read_get_attr, & + nc_diag_read_id_get_attr_1d_string, & + nc_diag_read_noid_get_attr_1d_string + + use ncdr_dims, only: & + nc_diag_read_lookup_dim, & + nc_diag_read_assert_dim, & + nc_diag_read_check_dim, & + nc_diag_read_get_dim, & + nc_diag_read_check_dim_unlim, & + nc_diag_read_get_dim_names, & + nc_diag_read_parse_file_dims + + use ncdr_global_attrs, only: & + nc_diag_read_check_global_attr, & + nc_diag_read_get_global_attr_type, & + nc_diag_read_ret_global_attr_len, & + nc_diag_read_get_global_attr_len, & + nc_diag_read_get_global_attr_names + + use ncdr_global_attrs_fetch, only: & + nc_diag_read_get_global_attr, & + nc_diag_read_id_get_global_attr_1d_string, & + nc_diag_read_noid_get_global_attr_1d_string + + use ncdr_vars, only: & + nc_diag_read_lookup_var, & + nc_diag_read_check_var, & + nc_diag_read_get_var_ndims, & + nc_diag_read_get_var_type, & + nc_diag_read_ret_var_dims, & + nc_diag_read_get_var_dims, & + nc_diag_read_get_var_names, & + nc_diag_read_parse_file_vars + + use ncdr_vars_fetch, only: nc_diag_read_get_var + + implicit none + +#define INITIAL_SIZE 1024 +#define NCDR_MULTI_BASE 1 + + contains + ! NCID = NetCDF ID + ! NCDR_ID = NetCDF Diag Reader ID (relative indexing) + + ! NCID = NetCDF ID + ! NCDR_ID = NetCDF Diag Reader ID (relative indexing) + + ! Parses a given file for metadata, dimensions, and variables. + ! + ! Given the NetCDF file name and its NCID, create an entry in + ! the internal nc_diag_read file table and populate it with + ! file information and variable/dimension structure. + ! + ! This subroutine is meant to be called internally by + ! nc_diag_read_id_init, and is NOT meant for calling from + ! anywhere else. + ! + ! Args: + ! filename (character(len=*): NetCDF file name to store in + ! internal file table. + ! file_ncid (integer(i_long)): the corresponding NetCDF ID + ! (NCID) of the opened NetCDF file to store in the + ! internal file table and use for file reading. + ! file_ncdr_id (integer(i_long)): internal nc_diag_read ID + ! for use in other subroutines and functions. This is + ! essentially the index of the internal file table that + ! nc_diag_read uses for referencing the specified file. + ! + ! Returns: + ! file_ncdr_id (integer(i_long)): internal nc_diag_read ID + ! for use in other subroutines and functions. This is + ! essentially the index of the internal file table that + ! nc_diag_read uses for referencing the specified file. + ! + subroutine nc_diag_read_parse_file(filename, file_ncid, file_ncdr_id) + character(len=*),intent(in) :: filename + integer(i_long), intent(in) :: file_ncid + integer(i_long), intent(out) :: file_ncdr_id + + integer(i_long) :: input_ndims + integer(i_long) :: input_nvars + integer(i_long) :: input_nattrs + + ncdr_file_count = ncdr_file_count + 1 + + if (allocated(ncdr_files)) then + if (ncdr_file_count > ncdr_file_total) then + call ncdr_realloc(ncdr_files, ncdr_file_total * NCDR_MULTI_BASE) + end if + else + allocate(ncdr_files(NCDR_DEFAULT_ENT)) + end if + + ncdr_files(ncdr_file_count)%filename = filename + ncdr_files(ncdr_file_count)%ncid = file_ncid + + ! Get top level info about the file! + call ncdr_nc_check(nf90_inquire(file_ncid, nDimensions = input_ndims, & + nVariables = input_nvars, nAttributes = input_nattrs)) + + call nc_diag_read_parse_file_dims(file_ncid, ncdr_file_count, input_ndims) + call nc_diag_read_parse_file_vars(file_ncid, ncdr_file_count, input_nvars) + + ! Make sure file is now open! + ncdr_files(ncdr_file_count)%file_open = .TRUE. + + ! Update highest record - this will let us keep track and + ! help us clear memory when we can! + if (ncdr_file_count > ncdr_file_highest) then + ncdr_file_highest = ncdr_file_count + end if + + ! Set the NCDR ID - relative index! + file_ncdr_id = ncdr_file_count + end subroutine nc_diag_read_parse_file + + ! Opens a given file for reading. + ! + ! Given the NetCDF file name, open the file and set everything + ! up for reading the file. + ! + ! Args: + ! filename (character(len=*): NetCDF file name to store in + ! internal file table. + ! + ! Returns: + ! file_ncdr_id (integer(i_long)): internal nc_diag_read ID + ! for use in other subroutines and functions. + ! + function nc_diag_read_id_init(filename) result(file_ncdr_id) + character(len=*),intent(in) :: filename + integer(i_long) :: file_ncid + integer(i_long) :: file_ncdr_id + + if (nc_diag_read_get_index_from_filename(filename) /= -1) & + call ncdr_error("Can't open the same file more than once! (Opening, closing, and then opening again is allowed.)") + + call ncdr_nc_check( nf90_open(filename, NF90_NOWRITE, file_ncid) ) + + call nc_diag_read_parse_file(filename, file_ncid, file_ncdr_id) + end function nc_diag_read_id_init + + subroutine nc_diag_read_init(filename, file_ncdr_id, from_push) + character(len=*),intent(in) :: filename + integer(i_long), intent(out), optional :: file_ncdr_id + logical, intent(in), optional :: from_push + integer(i_long) :: f_ncdr_id + + if (ncdr_id_stack_count > 0) then + if (.NOT. (present(from_push) .AND. (from_push))) & + call ncdr_error("Can not initialize due to push/pop queue use! If you want to init without the stack, you must use nc_diag_read_id_init or clear the queue first!") + end if + + f_ncdr_id = nc_diag_read_id_init(filename) + + if (present(file_ncdr_id)) & + file_ncdr_id = f_ncdr_id + + ! Set current ncid + current_ncdr_id = f_ncdr_id + end subroutine nc_diag_read_init + + subroutine nc_diag_read_push(filename, file_ncdr_id) + character(len=*),intent(in) :: filename + integer(i_long), intent(out), optional :: file_ncdr_id + + if ((ncdr_id_stack_count == 0) .AND. (current_ncdr_id /= -1)) & + call ncdr_error("Can not initialize due to normal caching use! If you want to init with the stack, you must close the cached file first, then use nc_diag_read_push()!") + + ncdr_id_stack_count = ncdr_id_stack_count + 1 + + if (allocated(ncdr_id_stack)) then + if (ncdr_id_stack_count >= ncdr_id_stack_size) then + call ncdr_realloc(ncdr_id_stack, size(ncdr_id_stack)) + ncdr_id_stack_size = size(ncdr_id_stack) + end if + else + allocate(ncdr_id_stack(INITIAL_SIZE)) + ncdr_id_stack_size = size(ncdr_id_stack) + end if + + if (present(file_ncdr_id)) then + call nc_diag_read_init(filename, file_ncdr_id, .TRUE.) + else + call nc_diag_read_init(filename, from_push = .TRUE.) + end if + + ! Push new NCID to stack + ncdr_id_stack(ncdr_id_stack_count) = current_ncdr_id + end subroutine nc_diag_read_push + + subroutine nc_diag_read_close(filename, file_ncdr_id, from_pop) + character(len=*),intent(in), optional :: filename + integer(i_long), intent(in), optional :: file_ncdr_id + logical, intent(in), optional :: from_pop + + integer(i_long) :: f_ncdr_id, f_ncid, i + logical :: range_closed + + f_ncid = -1 + + if (ncdr_file_count == 0) & + call ncdr_error("No files are currently open!") + + if (ncdr_id_stack_count > 0) then + if ((any(ncdr_id_stack == file_ncdr_id)) .AND. (.NOT. (present(from_pop) .AND. (from_pop)))) & + call ncdr_error("Can not close due to push/pop queue use! If you want to use this without the stack, you must use nc_diag_read_id_init or clear the queue first!") + end if + + if (present(filename)) then + f_ncdr_id = nc_diag_read_get_index_from_filename(filename) + + if (f_ncdr_id == -1) & + call ncdr_error("The NetCDF file specified, " // filename // ", is not open and can't be closed.") + else if (present(file_ncdr_id)) then + ! Do... nothing. Just store the ncid. + f_ncdr_id = file_ncdr_id + else + ! Try to see if current_ncid is defined + if (current_ncdr_id == -1) & + call ncdr_error("No arguments specified for closing a file! (Also, no current NCIDs were found!)") + f_ncdr_id = current_ncdr_id + end if + + ! Sanity check + call ncdr_check_ncdr_id(f_ncdr_id) + + ! Fetch NCID + f_ncid = ncdr_files(f_ncdr_id)%ncid + + ! Sanity check for the NCID... + call ncdr_check_ncid(f_ncid) + + ! Close it! + call ncdr_nc_check(nf90_close(f_ncid)) + + ! Deactivate entry... + ncdr_files(f_ncdr_id)%file_open = .FALSE. + + ! Deallocate as much as possible! + deallocate(ncdr_files(f_ncdr_id)%dims) + deallocate(ncdr_files(f_ncdr_id)%vars) + + ! Set current_ncid to -1, as necessary: + if (current_ncdr_id == f_ncdr_id) then + current_ncdr_id = -1 + end if + + ! Update highest record - this will let us keep track and + ! help us clear memory when we can! + range_closed = .TRUE. + + if (f_ncdr_id < ncdr_file_highest) then + do i = f_ncdr_id, ncdr_file_highest + if (ncdr_files(i)%file_open) then + range_closed = .FALSE. + exit + end if + end do + + if (range_closed) then + ncdr_file_highest = f_ncdr_id + ncdr_file_count = f_ncdr_id + end if + else if (f_ncdr_id == ncdr_file_highest) then + ncdr_file_highest = f_ncdr_id - 1 + ncdr_file_count = f_ncdr_id - 1 + + do i = 1, ncdr_file_highest + if (ncdr_files(i)%file_open) then + range_closed = .FALSE. + exit + end if + end do + + if (range_closed) then + ncdr_file_highest = 0 + ncdr_file_count = 0 + end if + end if + end subroutine nc_diag_read_close + + ! Pop - we return the thing we just deleted, and push things up! + subroutine nc_diag_read_pop(filename, file_ncdr_id) + character(len=*),intent(out), optional :: filename + integer(i_long), intent(out), optional :: file_ncdr_id + + if (ncdr_id_stack_count == 0) & + call ncdr_error("No NetCDF files to pop!") + + if (current_ncdr_id /= ncdr_id_stack(ncdr_id_stack_count)) & + call ncdr_error("BUG - current NCID differs from the current queued NCID!") + + if (present(filename)) then + filename = ncdr_files(ncdr_id_stack(ncdr_id_stack_count))%filename + end if + + if (present(file_ncdr_id)) then + file_ncdr_id = ncdr_id_stack(ncdr_id_stack_count) + end if + + ! Close the file + call nc_diag_read_close(file_ncdr_id = ncdr_id_stack(ncdr_id_stack_count), from_pop = .TRUE.) + + ! Set the stack spot to -1... + ncdr_id_stack(ncdr_id_stack_count) = -1 + + ! ...and decrease the count, effectively "popping" it! + ncdr_id_stack_count = ncdr_id_stack_count - 1 + + ! If everything is gone, set current to -1. + if (ncdr_id_stack_count /= 0) then + current_ncdr_id = ncdr_id_stack(ncdr_id_stack_count) + else + current_ncdr_id = -1 + end if + end subroutine nc_diag_read_pop + + ! Get current file in queue + subroutine nc_diag_read_get_current_queue(filename, file_ncdr_id) + character(len=*),intent(out), optional :: filename + integer(i_long), intent(out), optional :: file_ncdr_id + + if (present(filename)) then + if (ncdr_id_stack_count > 0) then + filename = ncdr_files(ncdr_id_stack(ncdr_id_stack_count))%filename + else + filename = "(no file in queue at the moment)" + end if + end if + + if (present(file_ncdr_id)) then + if (ncdr_id_stack_count > 0) then + file_ncdr_id = ncdr_id_stack(ncdr_id_stack_count) + else + file_ncdr_id = -1 + end if + end if + end subroutine nc_diag_read_get_current_queue + + ! Get current file, disregarding queue + subroutine nc_diag_read_get_current(filename, file_ncdr_id) + character(len=*),intent(out), optional :: filename + integer(i_long), intent(out), optional :: file_ncdr_id + + if (present(filename)) then + if (current_ncdr_id /= -1) then + filename = ncdr_files(current_ncdr_id)%filename + else + filename = "(no file open at the moment)" + end if + end if + + if (present(file_ncdr_id)) then + if (current_ncdr_id /= -1) then + file_ncdr_id = current_ncdr_id + else + file_ncdr_id = -1 + end if + end if + end subroutine nc_diag_read_get_current +end module nc_diag_read_mod diff --git a/src/ncdiag/nc_diag_res.f90 b/src/ncdiag/nc_diag_res.f90 new file mode 100644 index 000000000..07b08e53f --- /dev/null +++ b/src/ncdiag/nc_diag_res.f90 @@ -0,0 +1,127 @@ +! NetCDF Diag Resource file library + +module nc_diag_res + ! Library to read a resource file and check if a variable is + ! enabled within the resource file. + ! + ! This library reads a JSON resource file with the following format: + ! { + ! "variables" : { + ! "some_var" : true, + ! "more_var" : false + ! } + ! } + ! + ! Based on this sample file, we can check whether a certain variable + ! is enabled or not using this library: + ! + ! call nc_diag_load_resource_file("resource.json") + ! ! This will return true: + ! if (nc_diag_load_check_variable("some_var")) then + ! print *, "This variable exists!" + ! ! Do some other things here + ! end if + ! ! This will return false: + ! if (nc_diag_load_check_variable("more_var")) then + ! print *, "This variable exists!" + ! ! Do some other things here + ! end if + ! ! Note that we can specify non-existent variables - these + ! ! will also return false. + ! if (nc_diag_load_check_variable("hmmm_var")) then + ! print *, "This variable exists!" + ! ! Do some other things here + ! end if + ! call nc_diag_close_resource_file + + use ncdres_climsg, only: ncdres_error + use nc_diag_fson, only: ncdf_value, ncdf_parse, & + ncdf_get, ncdf_destroy + + implicit none + + type(ncdf_value), pointer :: nc_diag_json => null() + + contains + ! Opens a given resource file for reading. + ! + ! Given the resource file name, open the file and set everything + ! up for reading the file. This includes any internal memory + ! allocation required for reading the resource file. + ! + ! In order for memory allocation to be freed, the + ! subroutine nc_diag_close_resource_file MUST be called. + ! + ! If a resource file is already open, this will raise an error + ! and the program will terminate. + ! + ! Args: + ! filename (character(len=*)): resource file name to load. + ! + ! Raises: + ! Resource file already open error if there is already a + ! resource file currently open. + ! + subroutine nc_diag_load_resource_file(filename) + character(len=*), intent(in) :: filename + + if (associated(nc_diag_json)) & + call ncdres_error("Resource file already open!") + + nc_diag_json => ncdf_parse(filename) + end subroutine nc_diag_load_resource_file + + ! Lookup a variable and check its status. + ! + ! Given the variable name, lookup its status within the JSON + ! resource file. + ! + ! If the variable is present in the JSON file, and it is + ! enabled, this will return true. Otherwise, if the variable + ! doesn't exist in the resource file, or it is disabled, + ! this will return false. + ! + ! Args: + ! var_name (character(len=*)): variable name to lookup + ! within the resource file. + ! + ! Returns: + ! var_enabled (logical): whether the variable is enabled or + ! not within the resource file. + ! + function nc_diag_load_check_variable(var_name) result(var_enabled) + character(len=*), intent(in) :: var_name + logical :: var_enabled + + character(len=1024) :: var_str + + write (var_str, "(A)") "variables." // var_name + + var_enabled = .FALSE. + + call ncdf_get(nc_diag_json, trim(var_str), var_enabled) + end function nc_diag_load_check_variable + + ! Closes the current resource file. + ! + ! Closes a previously opened resource file. This will free any + ! resources allocated towards the previous resource file, and + ! allow for opening a new resource file. + ! + ! If no file has been opened previously, or if the file is + ! already closed, this will raise an error and the program will + ! terminate. + ! + ! Raises: + ! No resource file open error will occur if there is no + ! resource file currently open. + ! + subroutine nc_diag_close_resource_file + if (associated(nc_diag_json)) then + call ncdf_destroy(nc_diag_json) + nullify(nc_diag_json) + else + call ncdres_error("No resource file open!") + end if + end subroutine nc_diag_close_resource_file +end module nc_diag_res diff --git a/src/ncdiag/nc_diag_write_mod.F90 b/src/ncdiag/nc_diag_write_mod.F90 new file mode 100644 index 000000000..2bdb22ec0 --- /dev/null +++ b/src/ncdiag/nc_diag_write_mod.F90 @@ -0,0 +1,813 @@ +! nc_diag_write - NetCDF Layer Diag Writing Module +! Copyright 2015 Albert Huang - SSAI/NASA for NASA GSFC GMAO (610.1). +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or +! implied. See the License for the specific language governing +! permissions and limitations under the License. +! +! Main module - nc_diag_write_mod +! + +module nc_diag_write_mod + ! Library that provides a high level interface for storing channel- + ! based and observation-based data. + ! + ! This library allows developers to easily store channel-based data + ! (e.g. chaninfo) and observation-based data (metadata and data2d) + ! to a NetCDF file via an easy to use API. + ! + ! Internally, the process for storing this data looks like this: + ! -> When the developer calls nc_diag_init, the NetCDF file is + ! opened internally. The corresponding NCID is stored, and + ! any memory allocation needed is done at this step. + ! => If the file was opened in append mode, nc_diag_write will + ! attempt to load any existing variable definitions for all + ! types of variables - chaninfo, metadata, and data2d. + ! Appropriate variable counters and data for each variable + ! type will be set during init, and data writing will start + ! at the end of the variable. + ! + ! -> Headers are essentially NetCDF global attributes, or + ! attributes that describe a file. These can be added at any + ! time during the writing session. + ! + ! -> varattr, or variable attributes, describe an associated + ! variable. (This is a NetCDF4 variable attribute!) These can + ! only be added after variable definitions have been locked. + ! + ! -> chaninfo variables: + ! => nc_diag_chaninfo_dim_set must be called first to set + ! the nchans dimension. If it isn't called, doing any + ! chaninfo operation will result in an error. + ! => chaninfo variables are 1D, with nchans number of elements. + ! + ! -> metadata and data2d variables: + ! => metadata and data2d variables do not require any initial + ! dimension setting - nc_diag_write will keep track of your + ! number of observations for you! + ! => metadata variables are 1D, with nobs number of elements. + ! nobs can increase infinitely to fit the number of + ! observations recorded. + ! => data2d variables are 2D, with dimensions of nobs by + ! another fixed dimension. + ! + ! -> Definition locking is sometimes necessary for certain + ! operations, such as defining variable attributes. They are + ! necessary due to needing information from NetCDF after + ! variables are defined, or needing to assert that certain + ! variable properties are constant. Locking uses the following + ! steps: + ! => nc_diag_*_write_def is called to send the variable + ! definitions to NetCDF. This include defining any + ! dimensions necessary, as well as defining the variables + ! stored as well. + ! => Once each nc_diag_*_write_def completes, their + ! corresponding def_lock state will be set to TRUE, locking + ! the definitions in place. + ! => Attempts to make repeated calls will result in an error, + ! due to the def_lock state being set to TRUE. + ! + ! -> Data calls will store the input data into memory. The + ! implementation and design of the variable storage is + ! dependent on the variable type being stored. chaninfo + ! variables have a certain storage format, and metadata/data2d + ! variables have another storage format. Note that metadata + ! and data2d code have a few similarities in data storage + ! since the variables themselves share common features, like + ! the nobs dimension. + ! + ! -> Sometimes, there is a significant amount of data that needs + ! to be processed and stored. Since nc_diag_write stores all + ! of the data into memory (RAM) before it is written out, + ! there may not be enough memory to store the entirety of the + ! data. To alleviate that, nc_diag_flush_buffer can be called + ! to flush the data from the memory and write them to disk. + ! In reality, this doesn't actually free any memory... but the + ! memory savings gained is still there. Calling the flushing + ! subroutine performs the following steps: + ! => It first checks to make sure that definitions are locked. + ! The NetCDF variable IDs are needed in order to actually + ! write (or "put") any data into the file. + ! => It also checks to see if the data has already been locked. + ! No more data can be written if the data has been locked. + ! => It then calls all of the nc_diag_*_write_data subroutines + ! with a special flag to indicate data flushing. When the + ! data flushing flag is set, each of the variable + ! subroutines will take measures to operate as a buffer + ! flush, and not as a finalized data write. + ! => When flushing within the variable subroutine, the + ! subroutine first writes out any data using the variable- + ! specific, memory-stored data. + ! => It then resets any internal data counters that it may use + ! to store and keep track of the data. + ! => As mentioned before, it does not actually free any memory + ! since deallocating and subsequently reallocating from + ! scratch will take a long time, and is inefficient. With + ! a counter reset, each variable type's internal data + ! storage will start at the beginning of the data array, + ! effectively avoiding any need to add any more memory, and + ! thus achieving the goal of not using any more memory. + ! => Finally, since the writing is in buffer flushing mode, + ! the data_lock flag for each variable type is NOT set. + ! This is so that more data can be written, either with + ! the flushing method or with the regular write. + ! + ! -> Once data is done being queued ("stored"), nc_diag_write can + ! be called. The variables will have their data re-read from + ! memory and actually written to the file. This is also very + ! much variable type independent, since every variable has its + ! own way of storing variable data. Again, metadata and data2d + ! have similar code, with the only difference being the + ! dimensionality. Note that this is where NetCDF calls are + ! made to define and "put" data. Once done, if we are NOT in + ! append mode, we call nf90_enddef to end define mode. + ! + ! -> Once all the data has been queued and/or written out, it is + ! safe to call nc_diag_finish. We call this from nc_diag_write. + ! => This will first write definitions and data, if applicable. + ! The calls will have a special flag set to ensure that no + ! errors are triggered for already having a lock set, since + ! this subroutine will be closing the file anyways. + ! => Once all of the data has been sent to NetCDF, this will + ! tell NetCDF to close the file being written. Note that + ! NetCDF also keeps a memory cache of the data being stored + ! as well, so actual I/O writing may not be completely done + ! until here. After the writing and closing on the NetCDF + ! side completes, everything will be completely deallocated, + ! and everything will be reset. + ! + ! -> Upon reset, nc_diag_write is again ready to write a new file + ! via nc_diag_create! + ! + ! Note that only ONE file is written as a time. This is due to the + ! nature of the library focusing and storing data for a single + ! file. Attempting to create another file without closing the + ! previous one will result in an error. + + ! Load state variables! We need to know: + ! init_done - ...whether a file is currently loaded or + ! not. + ! append_only - ...whether we are in append mode or not. + ! ncid - ...the current NCID of our file. + ! enable_trim - ...whether we need to automatically trim + ! our strings for chaninfo string storage or + ! not. + ! diag_chaninfo_store - ...chaninfo variable information. + ! Specifically, whether it's allocated or + ! not, and if it's allocated, whether the + ! definitions are locked or not. (def_lock) + ! diag_metadata_store - ...metadata variable information. + ! Specifically, whether it's allocated or + ! not, and if it's allocated, whether the + ! definitions are locked or not. (def_lock) + ! diag_data2d_store - ...data2d variable information. + ! Specifically, whether it's allocated or + ! not, and if it's allocated, whether the + ! definitions are locked or not. (def_lock) + use ncdw_state, only: init_done, append_only, ncid, & + enable_trim, cur_nc_file, & + diag_chaninfo_store, diag_metadata_store, diag_data2d_store, & + diag_varattr_store + + ! Load needed NetCDF functions and constants + use netcdf, only: nf90_inq_libvers, nf90_open, nf90_create, & + nf90_enddef, nf90_close, nf90_sync, & + NF90_WRITE, NF90_NETCDF4, NF90_CLOBBER + + !------------------------------------------------------------------ + ! API imports to expose API from this module + ! (Plus general imports for this module as well!) + !------------------------------------------------------------------ + + ! Load necessary command line message subroutines and state + ! variables + use ncdw_climsg, only: & +#ifdef ENABLE_ACTION_MSGS + nclayer_enable_action, nclayer_actionm, & +#endif + nclayer_error, nclayer_warning, nclayer_info, nclayer_check, & + nc_set_info_display, nc_set_action_display + + ! Load nc_diag_write specific types + use ncdw_types, only: NLAYER_BYTE, NLAYER_SHORT, NLAYER_LONG, & + NLAYER_FLOAT, NLAYER_DOUBLE, NLAYER_STRING + + ! Load header writing API + use ncdw_lheader, only: nc_diag_header + + ! Load chaninfo writing API + auxillary functions for our use + use ncdw_chaninfo, only: nc_diag_chaninfo_dim_set, & + nc_diag_chaninfo, & + nc_diag_chaninfo_load_def, nc_diag_chaninfo_write_def, & + nc_diag_chaninfo_write_data, & + nc_diag_chaninfo_set_strict, & + nc_diag_chaninfo_allocmulti, nc_diag_chaninfo_prealloc_vars, & + nc_diag_chaninfo_prealloc_vars_storage + + ! Load metadata writing API + auxillary functions for our use + use ncdw_metadata, only: nc_diag_metadata, & + nc_diag_metadata_load_def, nc_diag_metadata_write_def, & + nc_diag_metadata_write_data, & + nc_diag_metadata_set_strict, & + nc_diag_metadata_allocmulti, & + nc_diag_metadata_prealloc_vars, & + nc_diag_metadata_prealloc_vars_storage, & + nc_diag_metadata_prealloc_vars_storage_all + + ! Load data2d writing API + auxillary functions for our use + use ncdw_data2d, only: nc_diag_data2d, & + nc_diag_data2d_load_def, nc_diag_data2d_write_def, & + nc_diag_data2d_write_data, & + nc_diag_data2d_set_strict, & + nc_diag_data2d_allocmulti, & + nc_diag_data2d_prealloc_vars, & + nc_diag_data2d_prealloc_vars_storage, & + nc_diag_data2d_prealloc_vars_storage_all + + ! Load varattr (variable attribute) writing API + use ncdw_varattr, only: nc_diag_varattr + + implicit none + + contains + ! Creates or appends to a new NetCDF file for data writing. + ! + ! Given the target NetCDF file name, attempt to create or open + ! the file and set everything up for writing data to the file. + ! This includes any internal memory allocation required for + ! buffering any data sent to this file. + ! + ! If the file is opened in non-append mode (default), this will + ! attempt to create a new file and start data writing from + ! scratch. If the file already exists, it will be OVERWRITTEN + ! without any prompt. + ! + ! If the file is opened in append mode, this will attempt to + ! open the file specified, read the file's dimension and + ! variable storage information, and set things up so that + ! data writing starts at the end of the file's existing data. + ! Note that append mode only works for nc_diag_write NetCDF + ! files. Attempting to open a non-nc_diag_write file could + ! result in errors! + ! + ! In order for the file to be written to successfully, + ! nc_diag_finish MUST be called for all of the data to be + ! flushed, and the corresponding memory to be freed. + ! + ! nc_diag_write may only operate on one file at a time. This is + ! due to the nature of nc_diag_write focusing on a single file. + ! + ! If a NetCDF file is already open, this will raise an error + ! and the program will terminate. + ! + ! Args: + ! filename (character(len=*)): NetCDF file name to create or + ! append to. + ! append (logical, optional): whether to open the NetCDF + ! file in append mode or not. By default, if this is + ! not specified, the file will be opened regularly (not + ! in append mode). + ! + ! Raises: + ! If a file is already open, an error occurs and the program + ! will exit. + ! + ! If the file specified does not exist, or there are issues + ! with NetCDF creating/opening/using the file, an error + ! will occur with the corresponding NetCDF error. + ! + ! Issues with storage allocation are bugs, and will also + ! result in an error with an indication that a bug has + ! occurred. + ! + subroutine nc_diag_init(filename, append) + character(len=*),intent(in) :: filename + logical, intent(in), optional :: append + + ! Buffer size variable for NetCDF optimization settings + ! (Not sure if this helps much...) + integer :: bsize = 16777216; + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + if (present(append)) then + write(action_str, "(A, L, A)") "nc_diag_init(filename = " // trim(filename) // & + ", append = ", append, ")" + else + write(action_str, "(A)") "nc_diag_init(filename = " // trim(filename) // & + ", append = (not specified))" + end if + call nclayer_actionm(trim(action_str)) + end if +#endif + + ! Inform user about NetCDF version + call nclayer_info('Initializing netcdf layer library, version ' // trim(nf90_inq_libvers()) // '...') + + ! Make sure we haven't initialized yet. If we have, it + ! means that another file is open that hasn't been closed + ! yet! + if (.NOT. init_done) then + ! Special append mode - that means that we need to + ! assume that all definitions are set and locked. + if (present(append) .AND. (append .eqv. .TRUE.)) then + ! Open the file in append mode! + call nclayer_check( nf90_open(filename, NF90_WRITE, ncid, & + bsize, cache_nelems = 16777216) ) ! Optimization settings + + ! Set the append flag + append_only = .TRUE. + else + ! Create the file from scratch! + + ! nf90_create creates the NetCDF file, and initializes + ! everything needed to write a NetCDF file. + ! + ! NF90_CLOBBER forces overwriting the file, even if it already + ! exists. + ! + ! ncid is a special ID that the NetCDF library uses to keep + ! track of what file you're working on. We're returning that + ! here. + call nclayer_check( nf90_create(filename, OR(NF90_NETCDF4, NF90_CLOBBER), ncid, & + 0, bsize, cache_nelems = 16777216) ) ! Optimization settings + end if + + ! Allocation sanity checks... + ! These storage variables should NOT be allocated. + ! If they are, it indicate that we have a serious problem. + if (allocated(diag_chaninfo_store)) then + call nclayer_error("BUG! diag_chaninfo_store is allocated, but init_done is not set!") + end if + + if (allocated(diag_metadata_store)) then + call nclayer_error("BUG! diag_metadata_store is allocated, but init_done is not set!") + end if + + if (allocated(diag_data2d_store)) then + call nclayer_error("BUG! diag_data2d_store is allocated, but init_done is not set!") + end if + + if (allocated(diag_varattr_store)) then + call nclayer_error("BUG! diag_data2d_store is allocated, but init_done is not set!") + end if + + ! All good, allocate the storage variables! + allocate(diag_chaninfo_store) + allocate(diag_metadata_store) + allocate(diag_data2d_store) + allocate(diag_varattr_store) + + ! Set the current file being written to... + cur_nc_file = filename + + ! Set the flag state to indicate that a file is open, + ! and that initialization is done. + init_done = .TRUE. + + ! "Lock and load" the definitions... or simply ask + ! chaninfo/metadata/data2d to read the NetCDF files, + ! build a cache, and set up anything necessary to be + ! able to resume writing from before. + if (present(append) .AND. (append .eqv. .TRUE.)) then + call nclayer_info("Loading chaninfo variables/dimensions from file:") + call nc_diag_chaninfo_load_def + + call nclayer_info("Loading metadata variables/dimensions from file:") + call nc_diag_metadata_load_def + + call nclayer_info("Loading data2d variables/dimensions from file:") + call nc_diag_data2d_load_def + end if + else + ! Opening a new file while another file is still open is + ! bad... let's yell at the user/developer! + call nclayer_error("Attempted to initialize without closing previous nc_diag file!" & + // char(10) & + // " (Previous file: " // trim(cur_nc_file) & + // char(10) & + // " Attempted to open file: " // trim(filename) // ")") + end if + end subroutine nc_diag_init + + ! Lock and commit the variable definitions for the current + ! NetCDF file. + ! + ! Attempt to commit the currently stored variable definitions + ! to the NetCDF file via NetCDF API calls. Once done, this will + ! set the flag for locking the variable definitions, preventing + ! any additional variables from being created or changed. + ! + ! Locking the definitions here will enable functions that + ! require variable definition locking. This include + ! nc_diag_varattr and nc_diag_flush_buffer, both of which + ! require the variable definitions to be committed and locked. + ! + ! Definitions may not be locked more than once. In addition, + ! creating new variables after definitions are locked will + ! result in errors. + ! + ! Args: + ! None + ! + ! Raises: + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If definitions have already been locked, this will result + ! in an error. + ! + ! If there is no file open, this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_lock_def +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_lock_def()") + end if +#endif + call nclayer_info("Locking all variable definitions!") + + ! Call all of the variable write_def + call nclayer_info("Defining chaninfo:") + call nc_diag_chaninfo_write_def + + call nclayer_info("Defining metadata:") + call nc_diag_metadata_write_def + + call nclayer_info("Defining data2d:") + call nc_diag_data2d_write_def + + call nclayer_info("All variable definitions locked!") + end subroutine nc_diag_lock_def + + ! Write all of the variables to the NetCDF file, including the + ! variable definitions and data, and close the file. + ! + ! Attempt to write the currently stored variable definitions + ! and data to the NetCDF file via NetCDF API calls. + ! + ! Once done, this will lock both the definitions and the data, + ! preventing any new variables or new data from being written + ! after this call completes. + ! + ! Once data has been written and locked, the file itself will be + ! closed. NetCDF may internally cache/buffer variable data in + ! memory, so actual writing may occur at this time to let NetCDF + ! actually commit the data to disk. + ! + ! Finally, nc_diag_write state cleanup and memory deallocation + ! will occur via a call to nc_diag_finish. + ! + ! Writing may not occur more than once. In addition, writing any + ! new variables or adding any new data will result in an error. + ! (Not that you can write any more data after this, since the + ! file is closed and everything is reset...) + ! + ! Args: + ! None + ! + ! Raises: + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If the variable definitions have already been locked, this + ! will NOT result in an error. This is due to the fact that + ! we could've locked definitions earlier, and that we + ! can assume that with locked definitions, we are able to + ! write data. + ! + ! Data writing is the critical part. If the variable data + ! writing has already been locked, this will result in an + ! error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_write +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_write()") + end if +#endif + + ! Call all variable write_def, with an extra option to make + ! sure that no errors occur during write, even when locked! + ! (We could have previously locked, but here we're doing it + ! on purpose!) + call nclayer_info("Defining chaninfo:") + call nc_diag_chaninfo_write_def(.TRUE.) + + call nclayer_info("Defining metadata:") + call nc_diag_metadata_write_def(.TRUE.) + + call nclayer_info("Defining data2d:") + call nc_diag_data2d_write_def(.TRUE.) + + ! Lock definition writing! + if ((.NOT. append_only) .AND. ((.NOT. diag_chaninfo_store%def_lock) .OR. & + (.NOT. diag_metadata_store%def_lock) .OR. & + (.NOT. diag_data2d_store%def_lock))) & + call nclayer_check(nf90_enddef(ncid)) + + ! Call all variable write_data + call nclayer_info("Writing chaninfo:") + call nc_diag_chaninfo_write_data + + call nclayer_info("Writing metadata:") + call nc_diag_metadata_write_data + + call nclayer_info("Writing data2d:") + call nc_diag_data2d_write_data + + ! Call nf90_close to save everything to disk! + call nclayer_info("All done queuing in data, letting NetCDF take over!") + call nclayer_check(nf90_close(ncid)) + + call nclayer_info("All done!") + + ! Call our cleanup subroutine + call nc_diag_finish + end subroutine nc_diag_write + + ! Reset nc_diag_write state, and deallocate all of the variable + ! storage in preparation for another new NetCDF file write. + ! + ! Attempt to reset nc_diag_write state and deallocate all of + ! the variable storage. This frees up memory, and allows for + ! nc_diag_init to work again for a new file. + ! + ! This can only be called once per open. (You can't call this + ! without a nc_diag_init happening before it!) Calling this + ! without any file opened (or data stored) will result in an + ! error. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! None + ! + ! Raises: + ! If there is no file open, or if no data/state needs to be + ! cleaned up, this will result in an error. + ! + ! Issues with storage deallocation are bugs, and will also + ! result in an error with an indication that a bug has + ! occurred. + ! + subroutine nc_diag_finish +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_finish()") + end if +#endif + ! Make sure that we only deallocate if we have something + ! open/initialized! + if (init_done) then + call nclayer_info("Cleaning up...") + + ! Do some quick sanity checks! + if (.NOT. allocated(diag_chaninfo_store)) then + call nclayer_error("BUG! diag_chaninfo_store is not allocated, but init_done is set!") + end if + + if (.NOT. allocated(diag_metadata_store)) then + call nclayer_error("BUG! diag_metadata_store is not allocated, but init_done is set!") + end if + + if (.NOT. allocated(diag_data2d_store)) then + call nclayer_error("BUG! diag_data2d_store is not allocated, but init_done is set!") + end if + + if (.NOT. allocated(diag_varattr_store)) then + call nclayer_error("BUG! diag_data2d_store is not allocated, but init_done is set!") + end if + + ! Deallocate everything! Note that this deallocates + ! everything within the derived type as well. + ! (See? Fortran is better than C!) + deallocate(diag_chaninfo_store) + deallocate(diag_metadata_store) + deallocate(diag_data2d_store) + deallocate(diag_varattr_store) + + ! Clear initialization, append, and current file name + ! state. + init_done = .FALSE. + append_only = .FALSE. + cur_nc_file = "" + else + call nclayer_error("Attempted to deallocate without initializing!") + end if + end subroutine nc_diag_finish + + ! Flush all of the current variable data to NetCDF, and reset + ! all of the variable storage to an initial state. + ! + ! Attempt to write the currently stored variable definitions + ! and data to the NetCDF file via NetCDF API calls. + ! + ! Once done, this will effectively "flush" the data from the + ! current variable buffers. Internally, this sets a starting + ! counter and resets the buffer counter so that new data can + ! be stored sequentially without requiring more memory, at least + ! until memory runs out for the current buffer. + ! + ! Definitions MUST be locked in order for flushing to work. + ! Without definition locking, nc_diag_write is unable to make + ! calls to NetCDF due to the lack of variable IDs. + ! + ! If definitions are not locked, calling this will result in an + ! error. + ! + ! Data locking does NOT occur with flushing. As a result, this + ! subroutine may be called multiple times, and a final + ! nc_diag_write can be called once after this call. + ! + ! (Note that calling nc_diag_write will lock the data and close + ! the file, regardless of flushing the buffer here!) + ! + ! Args: + ! None + ! + ! Raises: + ! If definitions have not been locked, this will result in + ! an error. + ! + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If the variable data writing has already been locked, this + ! will result in an error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_flush_buffer +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_flush_buffer()") + end if +#endif + if (.NOT. init_done) & + call nclayer_error("Attempted to flush nc_diag_write buffers without initializing!") + + if ((.NOT. diag_chaninfo_store%def_lock) .OR. & + (.NOT. diag_metadata_store%def_lock) .OR. & + (.NOT. diag_data2d_store%def_lock)) & + call nclayer_error("Definitions must be locked in order to flush the buffer!") + + ! Perform writes with the buffer flag set! + call nclayer_info("Flushing chaninfo:") + call nc_diag_chaninfo_write_data(.TRUE.) + + call nclayer_info("Flushing metadata:") + call nc_diag_metadata_write_data(.TRUE.) + + call nclayer_info("Flushing data2d:") + call nc_diag_data2d_write_data(.TRUE.) + + call nclayer_info("Flushing done!") + end subroutine nc_diag_flush_buffer + + ! Force NetCDF to flush its buffers and write any data stored to + ! disk. + ! + ! Attempt to force the write of NetCDF's stored variable data to + ! the NetCDF file via NetCDF API calls. + ! + ! This does NOT flush nc_diag_write's buffers. It only attempts + ! to flush NetCDF's internal buffers to disk. + ! + ! If there is no file open, or the file is already closed, this + ! will result in an error. + ! + ! Args: + ! None + ! + ! Raises: + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from NetCDF errors. Any errors + ! from NetCDF are likely to occur if there are problems + ! writing to disk. Errors resulting from problems with + ! manipulating NetCDF memory or a glitch are unlikely, but + ! still possible. + ! + subroutine nc_diag_flush_to_file +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_flush_to_file()") + end if +#endif + ! Make sure we have something open + initialized + if (.NOT. init_done) & + call nclayer_error("Attempted to flush NetCDF buffers without initializing!") + + ! Call nf90_sync to try and commit the put'd data to disk + call nclayer_check(nf90_sync(ncid)) + end subroutine nc_diag_flush_to_file + + ! Toggle whether nc_diag_write should be strict about dimensions + ! and variable consistency. + ! + ! Set the strictness of nc_diag_write for checking dimensions + ! and stored variable consistency. + ! + ! If set to TRUE, nc_diag_write will error when consistency + ! checks fail. + ! + ! If set to FALSE, nc_diag_write will only display a warning + ! when these checks fail. + ! + ! To see more details about what checks are made, see the + ! corresponding called subroutine documentation for details. + ! + ! Args: + ! enable_strict (logical): whether to be strict with + ! consistency checks or not. + ! + ! Raises: + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! See the called subroutines' documentation for details. + ! + subroutine nc_diag_set_strict(enable_strict) + logical, intent(in) :: enable_strict + + ! Make sure we have something open + initialized + if (init_done) then + ! Call all of the variable set_strict subroutines + call nc_diag_chaninfo_set_strict(enable_strict) + call nc_diag_metadata_set_strict(enable_strict) + call nc_diag_data2d_set_strict(enable_strict) + else + call nclayer_error("Can't set strictness level - NetCDF4 layer not initialized yet!") + end if + end subroutine nc_diag_set_strict + + ! Toggle whether nc_diag_write should trim strings or keep their + ! original length. + ! + ! Set the option to trim strings automatically with string + ! variable data or not. + ! + ! If set to TRUE, nc_diag_write will automatically trim strings + ! to the minimum needed to hold the string. (Extra spaces at + ! the end will be trimmed off the largest string in an array, + ! and the result will be the bounds for that string array!) + ! + ! If set to FALSE, nc_diag_write will NOT trim any strings. The + ! given string length is assumed to be the bounds for holding + ! the string. However, nc_diag_write will enforce strict + ! checking of the input string length. If the length of the + ! string changes during subsequent storage, nc_diag_write + ! will error. + ! + ! Note that this only applies to variable string storage. + ! Attribute string storage is handled directly by NetCDF. + ! From testing, it seems that NetCDF will trim your string when + ! storing headers (global attributes). + ! + ! Args: + ! do_trim (logical): whether to automatically trim the + ! stored strings or not. + ! + ! Raises: + ! Nothing... at least here. See above for potential errors + ! outside of this subroutine. + ! + subroutine nc_diag_set_trim(do_trim) + logical, intent(in) :: do_trim + + enable_trim = do_trim + end subroutine nc_diag_set_trim +end module nc_diag_write_mod diff --git a/src/ncdiag/ncd_kinds.F90 b/src/ncdiag/ncd_kinds.F90 new file mode 100644 index 000000000..5f314bf64 --- /dev/null +++ b/src/ncdiag/ncd_kinds.F90 @@ -0,0 +1,112 @@ +module ncd_kinds +!$$$ module documentation block +! . . . . +! module: kinds +! prgmmr: treadon org: np23 date: 2004-08-15 +! +! abstract: Module to hold specification kinds for variable declaration. +! This module is based on (copied from) Paul vanDelst's +! type_kinds module found in the community radiative transfer +! model +! +! module history log: +! 2004-08-15 treadon +! 2011-07-04 todling - define main precision during compilation +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! The numerical data types defined in this module are: +! i_byte - specification kind for byte (1-byte) integer variable +! i_short - specification kind for short (2-byte) integer variable +! i_long - specification kind for long (4-byte) integer variable +! i_llong - specification kind for double long (8-byte) integer variable +! r_single - specification kind for single precision (4-byte) real variable +! r_double - specification kind for double precision (8-byte) real variable +! r_quad - specification kind for quad precision (16-byte) real variable +! +! i_kind - generic specification kind for default integer +! r_kind - generic specification kind for default floating point +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + implicit none + private + +! Integer type definitions below + +! Integer types + integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer + integer, parameter, public :: i_short = selected_int_kind(4) ! short integer + integer, parameter, public :: i_long = selected_int_kind(8) ! long integer + integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer + integer, parameter, public :: i_llong = max( llong_t, i_long ) + +! Expected 8-bit byte sizes of the integer kinds + integer, parameter, public :: num_bytes_for_i_byte = 1 + integer, parameter, public :: num_bytes_for_i_short = 2 + integer, parameter, public :: num_bytes_for_i_long = 4 + integer, parameter, public :: num_bytes_for_i_llong = 8 + +! Define arrays for default definition + integer, parameter, private :: num_i_kinds = 4 + integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & + i_byte, i_short, i_long, i_llong /) + integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & + num_bytes_for_i_byte, num_bytes_for_i_short, & + num_bytes_for_i_long, num_bytes_for_i_llong /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** + integer, parameter, private :: default_integer = 3 ! 1=byte, + ! 2=short, + ! 3=long, + ! 4=llong + integer, parameter, public :: i_kind = integer_types( default_integer ) + integer, parameter, public :: num_bytes_for_i_kind = & + integer_byte_sizes( default_integer ) + + +! Real definitions below + +! Real types + integer, parameter, public :: r_single = selected_real_kind(6) ! single precision + integer, parameter, public :: r_double = selected_real_kind(15) ! double precision + integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision + integer, parameter, public :: r_quad = max( quad_t, r_double ) + +! Expected 8-bit byte sizes of the real kinds + integer, parameter, public :: num_bytes_for_r_single = 4 + integer, parameter, public :: num_bytes_for_r_double = 8 + integer, parameter, public :: num_bytes_for_r_quad = 16 + +! Define arrays for default definition + integer, parameter, private :: num_r_kinds = 3 + integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & + r_single, r_double, r_quad /) + integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & + num_bytes_for_r_single, num_bytes_for_r_double, & + num_bytes_for_r_quad /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** +#ifdef _REAL4_ + integer, parameter, private :: default_real = 1 ! 1=single, +#endif +#ifdef _REAL8_ + integer, parameter, private :: default_real = 2 ! 2=double, +#endif +#ifdef _REAL16_ + integer, parameter, private :: default_real = 3 ! 3=quad +#endif + integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: num_bytes_for_r_kind = & + real_byte_sizes( default_real ) + +end module ncd_kinds diff --git a/src/ncdiag/ncdc_cli_process.F90 b/src/ncdiag/ncdc_cli_process.F90 new file mode 100644 index 000000000..c0f1b0ac9 --- /dev/null +++ b/src/ncdiag/ncdc_cli_process.F90 @@ -0,0 +1,64 @@ +module ncdc_cli_process + use ncdc_state, only: input_file, output_file, prgm_name, & + cli_arg_count, dummy_arg + + implicit none + + contains + subroutine ncdc_usage(err) + character(len=*), intent(in), optional :: err + + if (present(err)) then + write(*, "(A)") " ** ERROR: " // err + end if + + call get_command_argument(0, prgm_name) + write (*, "(A)") " nc_diag_cat v1.0" + write (*, "(A)") " NetCDF Diag File Concatenator" + write (*, "(A)") " Usage: " // trim(prgm_name) // " -o OUTPUT_FILE FILES..." + write (*, "(A)") " Concatenate the NetCDF files listed in FILES into OUTPUT_FILE." + write (*, "(A)") " At least 2 input files must be specified in order for this tool" + write (*, "(A)") " to run. The resulting file will be compressed." + stop + end subroutine ncdc_usage + + subroutine nc_diag_cat_process_args + cli_arg_count = command_argument_count() + + if (cli_arg_count < 4) then + call ncdc_usage + end if + + ! Check for -o. + ! We enforce this so that people really know what they're putting + ! into this program! + call get_command_argument(1, dummy_arg) + + if (trim(dummy_arg) /= "-o") then + call ncdc_usage("Invalid option - '-o' must be specified in the 1st argument.") + end if + + ! Grab output file argument + call get_command_argument(2, output_file) + + if (len_trim(output_file) <= 0) then + call ncdc_usage("Invalid output file name.") + end if + + ! Grab first input file argument + call get_command_argument(3, input_file) + + if (len_trim(input_file) <= 0) then + call ncdc_usage("Invalid first input file name.") + end if + + ! Grab second input file argument + call get_command_argument(4, input_file) + + if (len_trim(input_file) <= 0) then + call ncdc_usage("Invalid second input file name.") + end if + + ! Sanity checks done! + end subroutine nc_diag_cat_process_args +end module ncdc_cli_process diff --git a/src/ncdiag/ncdc_climsg.F90 b/src/ncdiag/ncdc_climsg.F90 new file mode 100644 index 000000000..888b79303 --- /dev/null +++ b/src/ncdiag/ncdc_climsg.F90 @@ -0,0 +1,91 @@ +module ncdc_climsg + use ncd_kinds, only: i_long + use netcdf, only: nf90_noerr, nf90_strerror + +#ifdef USE_MPI + use ncdc_state, only: cur_proc +#endif + + implicit none + +#ifdef QUIET + logical :: ncdc_enable_info = .FALSE. + logical :: ncdc_enable_warn = .FALSE. +#else + logical :: ncdc_enable_info = .TRUE. + logical :: ncdc_enable_warn = .TRUE. +#endif + + contains + subroutine ncdc_check(status) + integer(i_long), intent(in) :: status + + if(status /= nf90_noerr) then + call ncdc_error(trim(nf90_strerror(status))) + end if + end subroutine ncdc_check + + subroutine ncdc_error(err) + character(len=*), intent(in) :: err +#ifdef ERROR_TRACEBACK + integer(i_long) :: div0 +#endif +#ifdef USE_MPI + write(*, "(A, I0, A)") & +#else + write(*, "(A)") & +#endif +#ifdef USE_MPI + "[PROC ", cur_proc, "]" // & +#endif + " ** ERROR: " // err +#ifdef ERROR_TRACEBACK + write(*, "(A)") " ** Failed to concatenate NetCDF4." + write(*, "(A)") " (Traceback requested, triggering div0 error...)" + div0 = 1 / 0 + write(*, "(A)") " Couldn't trigger traceback, ending gracefully." + write(*, "(A)") " (Ensure floating point exceptions are enabled," + write(*, "(A)") " and that you have debugging (-g) and tracebacks" + write(*, "(A)") " compiler flags enabled!)" + stop 1 +#else + write(*,"(A)") " ** Failed to concatenate NetCDF4." + stop " ** Failed to concatenate NetCDF4." +#endif + end subroutine ncdc_error + + subroutine ncdc_warning(warn) + character(len=*), intent(in) :: warn + if (ncdc_enable_warn) & +#ifdef USE_MPI + write(*, "(A, I0, A)") & +#else + write(*, "(A)") & +#endif +#ifdef USE_MPI + "[PROC ", cur_proc, "]" // & +#endif + " ** WARNING: " // warn + end subroutine ncdc_warning + + subroutine ncdc_info(ifo) + character(len=*), intent(in) :: ifo + if (ncdc_enable_info) & +#ifdef USE_MPI + write(*, "(A, I0, A)") & +#else + write(*, "(A)") & +#endif +#ifdef USE_MPI + "[PROC ", cur_proc, "]" // & +#endif + " ** INFO: " // ifo + end subroutine ncdc_info + +#ifdef _DEBUG_MEM_ + subroutine ncdc_debug(dbg) + character(len=*), intent(in) :: dbg + write(*, "(A, A)") "D: ", dbg + end subroutine ncdc_debug +#endif +end module ncdc_climsg diff --git a/src/ncdiag/ncdc_data.F90 b/src/ncdiag/ncdc_data.F90 new file mode 100644 index 000000000..b97af0cd2 --- /dev/null +++ b/src/ncdiag/ncdc_data.F90 @@ -0,0 +1,487 @@ +module ncdc_data + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + + use ncdc_state, only: prgm_name, cli_arg_count, input_count, & + input_file, output_file, ncid_input, & + ncid_input, ncid_output, & + var_arr_total, var_names, var_dim_names, var_output_ids, & + var_types, var_counters, & + dim_sizes, dim_names, dim_output_ids, dim_arr_total, & + dim_counters, & + data_blobs + + use ncdc_climsg, only: ncdc_error, ncdc_warning, ncdc_info, & + ncdc_check + use ncdc_cli_process, only: ncdc_usage + + use ncdc_dims, only: nc_diag_cat_lookup_dim + use ncdc_vars, only: nc_diag_cat_lookup_var + + use netcdf, only: nf90_open, nf90_close, nf90_inquire, & + nf90_inquire_dimension, nf90_inquire_variable, nf90_get_var, & + nf90_put_var, nf90_inq_dimid, & + NF90_NOWRITE, NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, & + NF90_DOUBLE, NF90_CHAR, NF90_FILL_CHAR, NF90_MAX_NAME + + implicit none + + contains + subroutine nc_diag_cat_data_pass + integer(i_long) :: cur_dim_id, cur_dim_len + integer(i_long) :: cur_out_var_id, cur_out_var_ndims, cur_out_var_counter + integer(i_long) :: cur_out_dim_ind, cur_out_var_ind + integer(i_long) :: max_cur_pos + integer(i_long), dimension(:), allocatable :: cur_out_dim_ids, cur_dim_ids + integer(i_long), dimension(:), allocatable :: cur_out_dim_sizes + integer(i_long), dimension(:), allocatable :: cur_dim_sizes + + integer(i_long) :: tmp_dim_index + integer(i_long) :: input_ndims + integer(i_long) :: input_nvars + integer(i_long) :: input_nattrs + + character(len=NF90_MAX_NAME) :: tmp_var_name + integer(i_long) :: tmp_var_type, tmp_var_ndims + integer(i_long), dimension(:), allocatable :: tmp_var_dimids + character(len=NF90_MAX_NAME) , allocatable :: tmp_var_dim_names(:) + + integer(i_long), dimension(:), allocatable :: tmp_input_varids + + character(1) ,dimension(:,:), allocatable :: tmp_string_buffer + character(1),dimension(:,:,:),allocatable :: string_2d_buffer + + integer(i_long) :: arg_index, var_index, i + + character(len=NF90_MAX_NAME) , allocatable :: tmp_in_dim_names(:) + + character(len=1000) :: err_string + + character(:), allocatable :: input_file_cut + + if (.NOT. allocated(var_names)) then + call ncdc_warning("No variables found to concatenate.") + return + end if + + call ncdc_info("Reading in data from all files...") + +#ifdef DEBUG + print *, " !!! BEGINNING DATA PASS!!" +#endif + + input_count = cli_arg_count - 2 + + do arg_index = 1, input_count +#ifdef DEBUG + print *, " !!! INPUT FILE STAGE" +#endif + call get_command_argument(2 + arg_index, input_file) + + input_file_cut = trim(input_file) + + if (len(input_file_cut) <= 0) then + call ncdc_usage("Invalid input file name - likely blank!") + end if + + if (input_file_cut == output_file) then + ! No warning here - we've already shown it in metadata. + call ncdc_info(" -> Skipping " // input_file_cut // " since it is the output file...") + else +#ifndef QUIET + call ncdc_info(" -> Opening " // input_file_cut // " for reading...") +#endif + call ncdc_check(nf90_open(input_file, NF90_NOWRITE, ncid_input, & + cache_size = 2147483647)) + + ! Get top level info about the file! + call ncdc_check(nf90_inquire(ncid_input, nDimensions = input_ndims, & + nVariables = input_nvars, nAttributes = input_nattrs)) + + ! Dimensions + allocate(tmp_in_dim_names(input_ndims)) + do tmp_dim_index = 1, input_ndims + call ncdc_check(nf90_inquire_dimension(ncid_input, tmp_dim_index, & + tmp_in_dim_names(tmp_dim_index))) + end do + + ! Variables +#ifdef DEBUG + write (*, "(A, I0)") "Number of variables: ", input_nvars +#endif + + allocate(tmp_input_varids(input_nvars)) + + ! Loop through each variable! + do var_index = 1, input_nvars + ! Grab number of dimensions and attributes first + call ncdc_check(nf90_inquire_variable(ncid_input, var_index, name = tmp_var_name, ndims = tmp_var_ndims)) + +#ifdef DEBUG + print *, "** PROCESSING VARIABLE: " // trim(tmp_var_name) +#endif + + ! Allocate temporary variable dimids storage! + allocate(tmp_var_dimids(tmp_var_ndims)) + allocate(tmp_var_dim_names(tmp_var_ndims)) + allocate(cur_dim_ids(tmp_var_ndims)) + allocate(cur_dim_sizes(tmp_var_ndims)) + allocate(cur_out_dim_ids(tmp_var_ndims)) + allocate(cur_out_dim_sizes(tmp_var_ndims)) + +#ifdef DEBUG + print *, "** (ALLOC DONE)" +#endif + + ! Grab the actual dimension IDs and attributes + call ncdc_check(nf90_inquire_variable(ncid_input, var_index, dimids = tmp_var_dimids, & + xtype = tmp_var_type)) + +#ifdef DEBUG + write (*, "(A, I0, A, I0)") " => Variable #", var_index, ": " // & + trim(tmp_var_name) + write (*, "(A)", advance = "NO") " => Dimension IDs: " + + do i = 1, tmp_var_ndims + if (i /= 1) write (*, "(A)", advance = "NO") ", " + write (*, "(I0)", advance = "NO") tmp_var_dimids(i) + end do + + write (*, "(A)") "" + + write (*, "(A)", advance = "NO") " => Dimensions: " +#endif + + do i = 1, tmp_var_ndims +#ifdef DEBUG + if (i /= 1) write (*, "(A)", advance = "NO") ", " +#endif + call ncdc_check(nf90_inquire_dimension(ncid_input, tmp_var_dimids(i), tmp_var_dim_names(i), cur_dim_sizes(i))) +#ifdef DEBUG + write (*, "(A)", advance = "NO") trim(tmp_var_dim_names(i)) +#endif + cur_out_dim_ind = nc_diag_cat_lookup_dim(tmp_var_dim_names(i)) + cur_out_dim_ids(i) = dim_output_ids(cur_out_dim_ind) + cur_out_dim_sizes(i) = dim_sizes(cur_out_dim_ind) + end do + +#ifdef DEBUG + write (*, "(A)") "" +#endif + + ! Now, let's lookup everything and translate the result to our file. + cur_out_var_ind = nc_diag_cat_lookup_var(tmp_var_name) + cur_out_var_id = var_output_ids(cur_out_var_ind) + cur_out_var_ndims = var_dim_names(cur_out_var_ind)%num_names + cur_out_var_counter = var_counters(cur_out_var_ind) + +#ifdef DEBUG + print *, " (starting var write)" +#endif + + + ! Check for one-time only vars... + if (((.NOT. any(cur_out_dim_sizes == -1)) .AND. (cur_out_var_counter == 0)) & + .OR. (any(cur_out_dim_sizes == -1))) then + + if ((cur_out_var_ndims == 1) .OR. & + ((cur_out_var_ndims == 2) .AND. (tmp_var_type == NF90_CHAR))) then + if (tmp_var_type == NF90_BYTE) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%byte_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(1) - 1), & + start = (/ 1 /), & + count = (/ cur_dim_sizes(1) /) )) + else if (tmp_var_type == NF90_SHORT) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%short_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(1) - 1), & + start = (/ 1 /), & + count = (/ cur_dim_sizes(1) /) )) + else if (tmp_var_type == NF90_INT) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%long_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(1) - 1), & + start = (/ 1 /), & + count = (/ cur_dim_sizes(1) /) )) + else if (tmp_var_type == NF90_FLOAT) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%rsingle_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(1) - 1), & + start = (/ 1 /), & + count = (/ cur_dim_sizes(1) /) )) + else if (tmp_var_type == NF90_DOUBLE) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%rdouble_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(1) - 1), & + start = (/ 1 /), & + count = (/ cur_dim_sizes(1) /) )) + else if (tmp_var_type == NF90_CHAR) then + ! Strangely enough, NetCDF doesn't support storing strings to + ! an array splice. Even with defined bounds, the strings is not + ! stored properly, especially when the variable's dimensions + ! are smaller than the actual target's dimensions. The smaller + ! strings are stored contiguously within the array, going outside + ! the given bounds. + ! + ! For example, given [ '1234', '5678' ], placing it into a 5x2 array + ! yields [ '12345', '678**' ] instead of [ '1234 ', '5678 ' ]. + + allocate(tmp_string_buffer (cur_dim_sizes(1), cur_dim_sizes(2))) + tmp_string_buffer = NF90_FILL_CHAR + + call ncdc_check(nf90_get_var(ncid_input, var_index, tmp_string_buffer, & + start = (/ 1, 1 /), & + count = (/ cur_dim_sizes(1), cur_dim_sizes(2) /) )) + + data_blobs(cur_out_var_ind)%string_buffer & + (1 : cur_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(2) - 1) = & + tmp_string_buffer + + deallocate(tmp_string_buffer) + else + write (err_string, "(A, I0, A)") & + "Invalid type detected during write." // & + CHAR(10) // " " // & + "(Variable '" // trim(tmp_var_name) // "' has an type of ", & + tmp_var_type, "," // & + CHAR(10) // " " // & + "which is invalid!)" + call ncdc_error(trim(err_string)) + end if + else if ((cur_out_var_ndims == 2) .OR. & + ((cur_out_var_ndims == 3) .AND. (tmp_var_type == NF90_CHAR))) then + + if (tmp_var_type == NF90_BYTE) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%byte_2d_buffer & + (1 : cur_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(2) - 1))) + else if (tmp_var_type == NF90_SHORT) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%short_2d_buffer & + (1 : cur_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(2) - 1))) + else if (tmp_var_type == NF90_INT) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%long_2d_buffer & + (1 : cur_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(2) - 1))) +#ifdef DEBUG + print *, "Storage place: ", dim_counters(nc_diag_cat_lookup_dim(tmp_var_dim_names(2))) +#endif + else if (tmp_var_type == NF90_FLOAT) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%rsingle_2d_buffer & + (1 : cur_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(2) - 1), & + start = (/ 1, 1 /), & + count = (/ cur_dim_sizes(1), cur_dim_sizes(2) /) )) + else if (tmp_var_type == NF90_DOUBLE) then + call ncdc_check(nf90_get_var(ncid_input, var_index, & + data_blobs(cur_out_var_ind)%rdouble_2d_buffer & + (1 : cur_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(2) - 1), & + start = (/ 1, 1 /), & + count = (/ cur_dim_sizes(1), cur_dim_sizes(2) /) )) + else if (tmp_var_type == NF90_CHAR) then + ! Use string buffer variable - same issue as before with 1D strings! + allocate(string_2d_buffer (cur_dim_sizes(1), cur_dim_sizes(2), cur_dim_sizes(3))) + string_2d_buffer = NF90_FILL_CHAR + call ncdc_check(nf90_get_var(ncid_input, var_index, string_2d_buffer, & + start = (/ 1, 1, 1 /), & + count = (/ cur_dim_sizes(1), cur_dim_sizes(2), cur_dim_sizes(3) /) )) + print *, "CUR_POS COUNTER:", data_blobs(cur_out_var_ind)%cur_pos + data_blobs(cur_out_var_ind)%string_2d_buffer & + (1 : cur_dim_sizes(1), 1 : cur_dim_sizes(2), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(3) - 1) & + = string_2d_buffer(:,:,:) + deallocate(string_2d_buffer) + else + write (err_string, "(A, I0, A)") & + "Invalid type detected during write." // & + CHAR(10) // " " // & + "(Variable '" // trim(tmp_var_name) // "' has an type of ", & + tmp_var_type, "," // & + CHAR(10) // " " // & + "which is invalid!)" + call ncdc_error(trim(err_string)) + end if + end if + + if (any(cur_out_dim_sizes == -1)) & + data_blobs(cur_out_var_ind)%cur_pos = & + data_blobs(cur_out_var_ind)%cur_pos + cur_dim_sizes(cur_out_var_ndims) + + var_counters(cur_out_var_ind) = & + var_counters(cur_out_var_ind) + 1 + end if + +#ifdef DEBUG + print *, " (end var write / start dealloc)" +#endif + + ! Deallocate + deallocate(tmp_var_dimids) + deallocate(tmp_var_dim_names) + deallocate(cur_dim_ids) + deallocate(cur_dim_sizes) + deallocate(cur_out_dim_ids) + deallocate(cur_out_dim_sizes) + +#ifdef DEBUG + print *, " (end dealloc)" +#endif + end do + + ! For variables that we didn't cover - check for those, + ! and update to the latest nobs position. That way, we + ! can leave blanks for variables that didn't exist! + ! Basically, we can just set all cur_pos to nobs. + ! Latest nobs is max(all var cur_pos). + ! Therefore, for every var, var%cur_pos = max(all var cur_pos). + if (var_arr_total > 0) then + max_cur_pos = -9999 + do var_index = 1, var_arr_total + if (data_blobs(var_index)%cur_pos > max_cur_pos) & + max_cur_pos = data_blobs(var_index)%cur_pos + end do + + if (max_cur_pos > 0) then + do var_index = 1, var_arr_total + data_blobs(var_index)%cur_pos = max_cur_pos + end do + end if + end if + + ! Update any unlimited counters + if (any(dim_sizes == -1)) then + do i = 1, dim_arr_total + ! Check for -1 - unlimited indicator + if ((dim_sizes(i) == -1) .AND. (any(tmp_in_dim_names == dim_names(i)))) then + ! We got one! But... we need to find this dimension in the file. + ! First, lookup dimension name to get dimension ID. +#ifdef DEBUG + print *, "Unlimited dimension name: ", trim(dim_names(i)) +#endif + call ncdc_check(nf90_inq_dimid(ncid_input, dim_names(i), cur_dim_id)) + + ! Then, grab the current unlimited dimension length! + call ncdc_check(nf90_inquire_dimension(ncid_input, cur_dim_id, len = cur_dim_len)) + + ! Add the length to the counter! + dim_counters(i) = dim_counters(i) + cur_dim_len + end if + end do + end if + + call ncdc_check(nf90_close(ncid_input)) + + !deallocate(unlim_dims) + !deallocate(tmp_input_dimids) + deallocate(tmp_input_varids) + deallocate(tmp_in_dim_names) + end if + end do + end subroutine nc_diag_cat_data_pass + + subroutine nc_diag_cat_data_commit + integer(i_long) :: var_index + +#ifndef QUIET + call ncdc_info("Doing final data commit...") +#endif + + do var_index = 1, var_arr_total +#ifndef QUIET + call ncdc_info(" => Writing variable " // trim(var_names(var_index)) // "...") +#endif + if ((var_dim_names(var_index)%num_names == 1) .OR. & + ((var_dim_names(var_index)%num_names == 2) .AND. (var_types(var_index) == NF90_CHAR)) ) then + if (var_types(var_index) == NF90_BYTE) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%byte_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + if (var_types(var_index) == NF90_SHORT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%short_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + if (var_types(var_index) == NF90_INT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%long_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + if (var_types(var_index) == NF90_FLOAT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%rsingle_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + + if (var_types(var_index) == NF90_DOUBLE) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%rdouble_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + if (var_types(var_index) == NF90_CHAR) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%string_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + else if ((var_dim_names(var_index)%num_names == 2) .OR. & + ((var_dim_names(var_index)%num_names == 3) .AND. (var_types(var_index) == NF90_CHAR)) ) then + if (var_types(var_index) == NF90_BYTE) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%byte_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_SHORT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%short_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_INT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%long_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_FLOAT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%rsingle_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_DOUBLE) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%rdouble_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_CHAR) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%string_2d_buffer, & + start = (/ 1, 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2), & + data_blobs(var_index)%alloc_size(3) /) )) + end if + end do + end subroutine nc_diag_cat_data_commit +end module ncdc_data diff --git a/src/ncdiag/ncdc_data_MPI.F90 b/src/ncdiag/ncdc_data_MPI.F90 new file mode 100644 index 000000000..11ee0ad3e --- /dev/null +++ b/src/ncdiag/ncdc_data_MPI.F90 @@ -0,0 +1,1180 @@ +module ncdc_data_MPI + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + use ncdc_state, only: prgm_name, cli_arg_count, input_count, & + input_file, output_file, ncid_input, & + ncid_input, ncid_output, & + var_arr_total, var_names, var_dim_names, var_output_ids, & + var_types, var_counters, var_hasunlim, & + dim_sizes, dim_names, dim_output_ids, dim_arr_total, & + dim_counters, dim_unlim_sizes, & +#ifdef USE_MPI + data_blobs, cur_proc, num_procs, ierr +#else + data_blobs +#endif + use ncdc_dims, only: nc_diag_cat_lookup_dim + use ncdc_vars, only: nc_diag_cat_lookup_var + + use ncdc_climsg, only: ncdc_error, ncdc_warning, ncdc_info, & + ncdc_check + use ncdc_cli_process, only: ncdc_usage + + use netcdf, only: nf90_open, nf90_close, nf90_inquire, & + nf90_inquire_dimension, nf90_inquire_variable, nf90_get_var, & + nf90_put_var, nf90_inq_dimid, nf90_inq_varid, & + NF90_NOWRITE, NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, & + NF90_DOUBLE, NF90_CHAR, NF90_FILL_BYTE, NF90_FILL_SHORT, & + NF90_FILL_INT, NF90_FILL_FLOAT, NF90_FILL_DOUBLE, & + NF90_FILL_CHAR, NF90_MAX_NAME, & + NF90_EBADDIM, NF90_NOERR, NF90_ENOTVAR + + implicit none + +#ifdef USE_MPI + include "mpif.h" +#endif + + contains +#ifdef USE_MPI + subroutine nc_diag_cat_data_pass + integer(i_long) :: cur_dim_id, cur_dim_len + integer(i_long) :: cur_out_var_id, cur_out_var_ndims, cur_out_var_counter + integer(i_long) :: cur_out_dim_ind, cur_out_var_ind, cur_out_var_type + integer(i_long) :: var_index, arg_index, local_var_index + integer(i_long), dimension(:), allocatable :: cur_out_dim_ids, cur_dim_ids + integer(i_long), dimension(:), allocatable :: cur_out_dim_sizes + integer(i_long), dimension(:), allocatable :: cur_dim_sizes + + ! Error tracking, temporary dimension ID storage to fetch + ! the actual dimension value. + integer(i_long) :: nc_err, tmp_dim_id + + ! Did we find a blank? If true, send a blank variable... + ! and don't attempt to fetch any data! + logical :: found_blank + + integer(i_long) :: tmp_dim_index + integer(i_long) :: input_ndims + integer(i_long) :: input_nvars + integer(i_long) :: input_nattrs + + character(len=NF90_MAX_NAME) :: tmp_var_name + integer(i_long) :: tmp_var_type, tmp_var_ndims + integer(i_long), dimension(:), allocatable :: tmp_var_dimids + character(len=NF90_MAX_NAME) , allocatable :: tmp_var_dim_names(:) + + integer(i_long), dimension(:), allocatable :: tmp_input_varids + + integer(i_byte), dimension(:), allocatable :: byte_buffer + integer(i_short), dimension(:), allocatable :: short_buffer + integer(i_long), dimension(:), allocatable :: long_buffer + + real(r_single), dimension(:), allocatable :: rsingle_buffer + real(r_double), dimension(:), allocatable :: rdouble_buffer + + !character(len=1000),dimension(:), allocatable :: string_buffer + character(1) ,dimension(:,:), allocatable :: string_buffer + + integer(i_byte), dimension(:,:), allocatable :: byte_2d_buffer + integer(i_short), dimension(:,:), allocatable :: short_2d_buffer + integer(i_long), dimension(:,:), allocatable :: long_2d_buffer + + real(r_single), dimension(:,:), allocatable :: rsingle_2d_buffer + real(r_double), dimension(:,:), allocatable :: rdouble_2d_buffer + + character(1), dimension(:,:,:), allocatable :: string_2d_buffer + + type temp_storage + integer(i_byte), dimension(:), allocatable :: byte_buffer + integer(i_short), dimension(:), allocatable :: short_buffer + integer(i_long), dimension(:), allocatable :: long_buffer + + real(r_single), dimension(:), allocatable :: rsingle_buffer + real(r_double), dimension(:), allocatable :: rdouble_buffer + + !character(len=1000),dimension(:), allocatable :: string_buffer + character(1) ,dimension(:,:), allocatable :: string_buffer + character(1) ,dimension(:,:), allocatable :: string_expanded_buffer + character(1) ,dimension(:), allocatable :: string_1d_buffer + + integer(i_byte), dimension(:,:), allocatable :: byte_2d_buffer + integer(i_short), dimension(:,:), allocatable :: short_2d_buffer + integer(i_long), dimension(:,:), allocatable :: long_2d_buffer + + real(r_single), dimension(:,:), allocatable :: rsingle_2d_buffer + real(r_double), dimension(:,:), allocatable :: rdouble_2d_buffer + + character(1), dimension(:,:,:), allocatable :: string_2d_buffer + character(1), dimension(:,:,:), allocatable :: string_2d_expanded_buffer + end type temp_storage + + type(temp_storage), dimension(:), allocatable :: temp_storage_arr + + integer(i_long) :: i, i_proc, procs_done = 0, base_proc = 1 + integer(i_long) :: num_count, file_count = 0 + + integer(i_long), dimension(:), allocatable :: procs_done_arr + + logical :: mpi_read_flag = .FALSE. + + integer(i_long), dimension(:), allocatable :: read_var_count + + integer(i_long) :: mpi_status(MPI_STATUS_SIZE) + integer(i_long), dimension(:), allocatable :: mpi_requests + integer(i_long) :: mpi_requests_total = 0 + + integer(i_long) :: mpi_request_EOF + integer(i_long) :: mpi_request_EOP + + character(len=NF90_MAX_NAME) , allocatable :: tmp_in_dim_names(:) + + character(len=1000) :: err_string + + character(:), allocatable :: input_file_cut + + if (.NOT. allocated(var_names)) then + call ncdc_warning("No variables found to concatenate.") + return + end if + +#ifdef DEBUG + print *, " !!! BEGINNING DATA PASS!!" +#endif + + input_count = cli_arg_count - 2 + + if (cur_proc /= 0) then + call ncdc_info("Reading in data from all files...") + + ! Allocate the correct amount of requests needed for the + ! files and variables! + ! + ! We need (num of files * num of vars) space. + ! + ! Number of files is a bit tricky to determine, but not too bad! + ! -> If the total number of files divides evenly into the number + ! of processors handling files (num_procs - 1), then we just + ! divide and multiply. + ! -> If we have a remainder, and the current process is less + ! than or equal to (input_count % (num_procs - 1)), do the + ! same, but add 1 extra after dividing, THEN multiply. + ! -> If we have a remainder, but we are greater than that, + ! just do simple division and multiplication without adding + ! anything. + + if (mod(input_count, num_procs - 1) == 0) then + allocate(mpi_requests((input_count / (num_procs - 1)) * (var_arr_total + 1) + 1)) + allocate(temp_storage_arr((input_count / (num_procs - 1)) * (var_arr_total + 1) + 1)) + else + if (cur_proc <= mod(input_count, num_procs - 1)) then + allocate(mpi_requests(((input_count / (num_procs - 1)) + 1) * (var_arr_total + 1) + 1)) + allocate(temp_storage_arr(((input_count / (num_procs - 1)) + 1) * (var_arr_total + 1) + 1)) + else + allocate(mpi_requests((input_count / (num_procs - 1)) * (var_arr_total + 1) + 1)) + allocate(temp_storage_arr((input_count / (num_procs - 1)) * (var_arr_total + 1) + 1)) + end if + end if + + mpi_request_EOF = var_arr_total + 1000 + mpi_request_EOP = var_arr_total + 2000 + + ! For each processor 1 ... n, do every (n - proc + 1) task. + ! Example: + ! Total # of tasks: 20 + ! Total # of processors: 5 (so 0 root, 1-4) + ! Formula: (task # - 1) mod (# procs - 1) == (proc # - 1) + ! Zero Indexed | Fortran Indexed + ! processor 0: is collecting flowers and not doing anything + ! processor 1: (task # - 1) mod 4 == 0 | 0, 4, 8, 12, 16 | 1, 5, 9, 13, 17 + ! processor 2: (task # - 1) mod 4 == 1 | 1, 5, 9, 13, 17 | 2, 6, 10, 14, 18 + ! processor 3: (task # - 1) mod 4 == 2 | 2, 6, 10, 14, 18 | 3, 7, 11, 15, 19 + ! processor 4: (task # - 1) mod 4 == 3 | 3, 7, 11, 15, 19 | 4, 8, 12, 16, 20 + ! We could do an if statement using mod... but can we do better? YES! + ! Looking at the Fortran indexed tasks for each processor, we can set + ! our initial to (proc #), and then just add (num_procs - 1) after. + do arg_index = cur_proc, input_count, num_procs - 1 + call get_command_argument(2 + arg_index, input_file) + + input_file_cut = trim(input_file) + + if (len(input_file_cut) <= 0) then + call ncdc_usage("Invalid input file name - likely blank!") + end if + + if (input_file_cut == output_file) then + ! No warning here - we've already shown it in metadata. + call ncdc_info(" -> Skipping " // input_file_cut // " since it is the output file...") + else +#ifndef QUIET + call ncdc_info(" -> Reading data from " // input_file_cut // "...") +#endif + call ncdc_check(nf90_open(input_file, NF90_NOWRITE, ncid_input, & + cache_size = 2147483647)) + + ! Get top level info about the file! + call ncdc_check(nf90_inquire(ncid_input, nDimensions = input_ndims, & + nVariables = input_nvars, nAttributes = input_nattrs)) + + ! Dimensions + allocate(tmp_in_dim_names(input_ndims)) + do tmp_dim_index = 1, input_ndims + call ncdc_check(nf90_inquire_dimension(ncid_input, tmp_dim_index, & + tmp_in_dim_names(tmp_dim_index))) + end do + + ! Variables + allocate(tmp_input_varids(input_nvars)) + + ! Loop through each variable! + do local_var_index = 1, var_arr_total + var_index = -1 + + ! We iterate through our local variable storage + ! to keep things consistent, especially with the order + ! with which we send out variables to rank 0. + ! We also do this to detect "blank" variables, or + ! variables that don't exist in our input + ! file. Once we find out which files don't + ! exist, we set a blank flag to trigger a + ! few things to make this all work out! + nc_err = nf90_inq_varid(ncid_input, var_names(local_var_index), var_index) + + if (nc_err == NF90_ENOTVAR) then + ! We need to make a blank! + found_blank = .TRUE. + else if (nc_err /= NF90_NOERR) then + call ncdc_check(nc_err) + else + found_blank = .FALSE. + end if + + !do var_index = 1, input_nvars + + if (found_blank) then + tmp_var_ndims = var_dim_names(local_var_index)%num_names + tmp_var_name = var_names(local_var_index) + else + ! Grab number of dimensions and attributes first + call ncdc_check(nf90_inquire_variable(ncid_input, var_index, name = tmp_var_name, & + ndims = tmp_var_ndims)) + end if + + ! Allocate temporary variable dimids storage! + allocate(tmp_var_dimids(tmp_var_ndims)) + allocate(tmp_var_dim_names(tmp_var_ndims)) + allocate(cur_dim_ids(tmp_var_ndims)) + allocate(cur_dim_sizes(tmp_var_ndims)) + allocate(cur_out_dim_ids(tmp_var_ndims)) + allocate(cur_out_dim_sizes(tmp_var_ndims)) + +#ifdef DEBUG + write (*, "(A)") "*************************************" + write (*, "(A)") "NR0 DEBUG: file is " // input_file_cut + write (*, "(A)") "NR0 DEBUG: var is " // trim(var_names(local_var_index)) +#endif + + if (found_blank) then +#ifdef DEBUG + write (*, "(A)") "NR0 DEBUG: (in found_blank state)" +#endif + do i = 1, tmp_var_ndims + cur_out_dim_ind = nc_diag_cat_lookup_dim(var_dim_names(local_var_index)%dim_names(i)) + cur_out_dim_ids(i) = dim_output_ids(cur_out_dim_ind) + cur_out_dim_sizes(i) = dim_sizes(cur_out_dim_ind) + + nc_err = nf90_inq_dimid(ncid_input, var_dim_names(local_var_index)%dim_names(i), & + tmp_dim_id) + +#ifdef DEBUG + write (*, "(A, I0, A)") "NR0 DEBUG: dim is " // trim(var_dim_names(local_var_index)%dim_names(i)) // " (ID = ", i, ")" +#endif + + if (nc_err /= NF90_EBADDIM) then + if (nc_err /= NF90_NOERR) then + call ncdc_check(nc_err) + else + call ncdc_check( & + nf90_inquire_dimension(ncid_input, & + tmp_dim_id, len = cur_dim_sizes(i)) ) +#ifdef DEBUG + write (*, "(A)") "NR0 DEBUG: using file cur_dim_sizes" +#endif + end if + else + cur_dim_sizes(i) = cur_out_dim_sizes(i) +#ifdef DEBUG + write (*, "(A)") "NR0 DEBUG: using cur_dim_sizes = cur_out_dim_sizes" +#endif + end if +#ifdef DEBUG + write (*, "(A, I0)") "NR0 DEBUG: final cur_dim_sizes(i) = ", cur_dim_sizes(i) +#endif + end do + + ! Make sure to set the var type for the "blank" var! + tmp_var_type = var_types(local_var_index) + else + ! Grab the actual dimension IDs and attributes + call ncdc_check(nf90_inquire_variable(ncid_input, var_index, dimids = tmp_var_dimids, & + xtype = tmp_var_type)) + + do i = 1, tmp_var_ndims + call ncdc_check(nf90_inquire_dimension(ncid_input, tmp_var_dimids(i), & + tmp_var_dim_names(i), cur_dim_sizes(i))) + cur_out_dim_ind = nc_diag_cat_lookup_dim(tmp_var_dim_names(i)) + cur_out_dim_ids(i) = dim_output_ids(cur_out_dim_ind) + cur_out_dim_sizes(i) = dim_sizes(cur_out_dim_ind) +#ifdef DEBUG + write (*, "(A, I0)") "NR0 DEBUG: final cur_dim_sizes(i) = ", cur_dim_sizes(i) +#endif + end do + end if + + ! Now, let's lookup everything and translate the result to our file. + cur_out_var_ind = nc_diag_cat_lookup_var(tmp_var_name) + cur_out_var_id = var_output_ids(cur_out_var_ind) + cur_out_var_ndims = var_dim_names(cur_out_var_ind)%num_names + cur_out_var_counter = var_counters(cur_out_var_ind) + + ! One-time only vars - if we are blank, do NOTHING. + if ((.NOT. any(cur_out_dim_sizes == -1)) .AND. (cur_out_var_counter == 0) & + .AND. (found_blank)) then + cycle + end if + +#ifdef DEBUG + write (*, "(A, I0)") "NR0 DEBUG: cur_out_var_ndims = ", cur_out_var_ndims +#endif + + ! Check for one-time only vars... + if (((.NOT. any(cur_out_dim_sizes == -1)) .AND. (cur_out_var_counter == 0)) & + .OR. (any(cur_out_dim_sizes == -1))) then + if ((cur_out_var_ndims == 1) .OR. & + ((cur_out_var_ndims == 2) .AND. (tmp_var_type == NF90_CHAR))) then + mpi_requests_total = mpi_requests_total + 1 + + if (tmp_var_type == NF90_BYTE) then + allocate(temp_storage_arr(mpi_requests_total)%byte_buffer (cur_dim_sizes(1))) + ! EMPTY FILL GOES HERE + temp_storage_arr(mpi_requests_total)%byte_buffer = NF90_FILL_BYTE + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%byte_buffer)) + + ! Args: the variable, number of elements to send, + ! data type (in MPI land), destination process #, + ! numeric tag for extra info, and communicator. + call MPI_ISend(temp_storage_arr(mpi_requests_total)%byte_buffer, & + cur_dim_sizes(1), MPI_BYTE, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_SHORT) then + allocate(temp_storage_arr(mpi_requests_total)%short_buffer (cur_dim_sizes(1))) + temp_storage_arr(mpi_requests_total)%short_buffer = NF90_FILL_SHORT + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%short_buffer)) + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%short_buffer, & + cur_dim_sizes(1), MPI_SHORT, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_INT) then + allocate(temp_storage_arr(mpi_requests_total)%long_buffer (cur_dim_sizes(1))) + temp_storage_arr(mpi_requests_total)%long_buffer = NF90_FILL_INT + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%long_buffer)) + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%long_buffer, & + cur_dim_sizes(1), MPI_INT, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_FLOAT) then + allocate(temp_storage_arr(mpi_requests_total)%rsingle_buffer(cur_dim_sizes(1))) + temp_storage_arr(mpi_requests_total)%rsingle_buffer = NF90_FILL_FLOAT + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%rsingle_buffer, & + start = (/ 1 /), & + count = (/ cur_dim_sizes(1) /) )) + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%rsingle_buffer, & + cur_dim_sizes(1), MPI_FLOAT, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_DOUBLE) then + allocate(temp_storage_arr(mpi_requests_total)%rdouble_buffer(cur_dim_sizes(1))) + temp_storage_arr(mpi_requests_total)%rdouble_buffer = NF90_FILL_DOUBLE + !print *, cur_dim_sizes(1) + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%rdouble_buffer, & + start = (/ 1 /), & + count = (/ cur_dim_sizes(1) /) )) + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%rdouble_buffer, & + cur_dim_sizes(1), MPI_DOUBLE, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_CHAR) then + allocate(string_buffer (cur_dim_sizes(1), cur_dim_sizes(2))) + + ! NOTE: the 2nd dim is nobs, so this is the actual file size. + ! Other fields are the final sizes (maximum). + allocate(temp_storage_arr(mpi_requests_total)%string_expanded_buffer (cur_out_dim_sizes(1), cur_dim_sizes(2))) + + string_buffer = NF90_FILL_CHAR + temp_storage_arr(mpi_requests_total)%string_expanded_buffer = NF90_FILL_CHAR + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, string_buffer, & + start = (/ 1, 1 /), & + count = (/ cur_dim_sizes(1), cur_dim_sizes(2) /) )) + + temp_storage_arr(mpi_requests_total)%string_expanded_buffer(1:cur_dim_sizes(1), 1:cur_dim_sizes(2)) = & + string_buffer + +#ifdef DEBUG + write (*, "(A, I0)") "NR0 DEBUG: cur_out_dim_sizes(1)* cur_dim_sizes(2) = ", cur_out_dim_sizes(1)* cur_dim_sizes(2) +#endif + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%string_expanded_buffer, & + cur_out_dim_sizes(1)* cur_dim_sizes(2), MPI_BYTE, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + + deallocate(string_buffer) + else + write (err_string, "(A, I0, A)") & + "Invalid type detected during write." // & + CHAR(10) // " " // & + "(Variable '" // trim(tmp_var_name) // "' has an type of ", & + tmp_var_type, "," // & + CHAR(10) // " " // & + "which is invalid!)" + call ncdc_error(trim(err_string)) + end if + else if ((cur_out_var_ndims == 2) .OR. & + ((cur_out_var_ndims == 3) .AND. (tmp_var_type == NF90_CHAR))) then + + mpi_requests_total = mpi_requests_total + 1 + + if (tmp_var_type == NF90_BYTE) then + allocate(temp_storage_arr(mpi_requests_total)%byte_2d_buffer (cur_dim_sizes(1), cur_dim_sizes(2))) + + temp_storage_arr(mpi_requests_total)%byte_2d_buffer = NF90_FILL_BYTE + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%byte_2d_buffer)) + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%byte_2d_buffer, & + cur_dim_sizes(1)* cur_dim_sizes(2), MPI_BYTE, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_SHORT) then + allocate(temp_storage_arr(mpi_requests_total)%short_2d_buffer (cur_dim_sizes(1), cur_dim_sizes(2))) + + temp_storage_arr(mpi_requests_total)%short_2d_buffer = NF90_FILL_SHORT + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%short_2d_buffer)) + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%short_2d_buffer, & + cur_dim_sizes(1)* cur_dim_sizes(2), MPI_SHORT, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_INT) then + allocate(temp_storage_arr(mpi_requests_total)%long_2d_buffer (cur_dim_sizes(1), cur_dim_sizes(2))) + + temp_storage_arr(mpi_requests_total)%long_2d_buffer = NF90_FILL_INT + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%long_2d_buffer)) + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%long_2d_buffer, & + cur_dim_sizes(1)* cur_dim_sizes(2), MPI_INT, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_FLOAT) then + allocate(temp_storage_arr(mpi_requests_total)%rsingle_2d_buffer(cur_dim_sizes(1), cur_dim_sizes(2))) + + temp_storage_arr(mpi_requests_total)%rsingle_2d_buffer = NF90_FILL_FLOAT + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%rsingle_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ cur_dim_sizes(1), cur_dim_sizes(2) /) )) + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%rsingle_2d_buffer, & + cur_dim_sizes(1)* cur_dim_sizes(2), MPI_FLOAT, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_DOUBLE) then + allocate(temp_storage_arr(mpi_requests_total)%rdouble_2d_buffer(cur_dim_sizes(1), cur_dim_sizes(2))) + + temp_storage_arr(mpi_requests_total)%rdouble_2d_buffer = NF90_FILL_DOUBLE + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, & + temp_storage_arr(mpi_requests_total)%rdouble_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ cur_dim_sizes(1), cur_dim_sizes(2) /) )) + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%rdouble_2d_buffer, & + cur_dim_sizes(1)* cur_dim_sizes(2), MPI_DOUBLE, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + else if (tmp_var_type == NF90_CHAR) then + allocate(string_2d_buffer (cur_dim_sizes(1), cur_dim_sizes(2), cur_dim_sizes(3))) + + ! NOTE: the 3rd dim is nobs, so this is the actual file size. + ! Other fields are the final sizes (maximum). + allocate(temp_storage_arr(mpi_requests_total)%string_2d_expanded_buffer & + (cur_out_dim_sizes(1), cur_out_dim_sizes(2), cur_dim_sizes(3))) + + ! Same again, this time just multiplying... + string_2d_buffer = NF90_FILL_CHAR + temp_storage_arr(mpi_requests_total)%string_2d_expanded_buffer = NF90_FILL_CHAR + + if (.NOT. found_blank) & + call ncdc_check(nf90_get_var(ncid_input, var_index, string_2d_buffer, & + start = (/ 1, 1, 1 /), & + count = (/ cur_dim_sizes(1), cur_dim_sizes(2), cur_dim_sizes(3) /) )) + + temp_storage_arr(mpi_requests_total)%string_2d_expanded_buffer & + (1:cur_dim_sizes(1), 1:cur_dim_sizes(2), 1:cur_dim_sizes(3)) = & + string_2d_buffer + + call MPI_ISend(temp_storage_arr(mpi_requests_total)%string_2d_expanded_buffer, & + cur_out_dim_sizes(1)* cur_out_dim_sizes(2)* cur_dim_sizes(3), MPI_BYTE, & + 0, cur_out_var_ind, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + + deallocate(string_2d_buffer) + else + write (err_string, "(A, I0, A)") & + "Invalid type detected during write." // & + CHAR(10) // " " // & + "(Variable '" // trim(tmp_var_name) // "' has an type of ", & + tmp_var_type, "," // & + CHAR(10) // " " // & + "which is invalid!)" + call ncdc_error(trim(err_string)) + end if + end if + + var_counters(cur_out_var_ind) = & + var_counters(cur_out_var_ind) + 1 + end if + + ! Deallocate + deallocate(tmp_var_dimids) + deallocate(tmp_var_dim_names) + deallocate(cur_dim_ids) + deallocate(cur_dim_sizes) + deallocate(cur_out_dim_ids) + deallocate(cur_out_dim_sizes) + end do + + ! Update any unlimited counters + if (any(dim_sizes == -1)) then + do i = 1, dim_arr_total + ! Check for -1 - unlimited indicator + if ((dim_sizes(i) == -1) .AND. (any(tmp_in_dim_names == dim_names(i)))) then + ! We got one! But... we need to find this dimension in the file. + ! First, lookup dimension name to get dimension ID. + call ncdc_check(nf90_inq_dimid(ncid_input, dim_names(i), cur_dim_id)) + + ! Then, grab the current unlimited dimension length! + call ncdc_check(nf90_inquire_dimension(ncid_input, cur_dim_id, len = cur_dim_len)) + + ! Add the length to the counter! + dim_counters(i) = dim_counters(i) + cur_dim_len + end if + end do + end if + + call ncdc_check(nf90_close(ncid_input)) + + deallocate(tmp_input_varids) + deallocate(tmp_in_dim_names) + end if + + ! Send EOF notification + mpi_requests_total = mpi_requests_total + 1 + call MPI_ISend(0, 1, MPI_INT, 0, mpi_request_EOF, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + end do + + ! Send process competion notification + mpi_requests_total = mpi_requests_total + 1 + call MPI_ISend(0, 1, MPI_INT, 0, mpi_request_EOP, MPI_COMM_WORLD, & + mpi_requests(mpi_requests_total), ierr) + + ! Flush all MPI communications! + ! (Deallocate everything while we're at it!) + call ncdc_info(" -> Flushing all data...") + do i = 1, mpi_requests_total + call MPI_Wait(mpi_requests(i), mpi_status, ierr) + end do + + ! This will deallocate everything, including internal stuff + deallocate(temp_storage_arr) + else + ! Do collection! + ! We know how much we need to receive - but we don't know + ! when we will get our data. So we'll keep a tally of + ! what data we got, and once we reach our limit, we'll be + ! done! + + allocate(read_var_count(var_arr_total)) + read_var_count = 0 + + allocate(procs_done_arr(num_procs - 1)) + procs_done_arr = -1 + + procs_done = 0 + + call ncdc_info("Receiving data from other processes...") + + base_proc = 1 + + do while (file_count /= input_count) + do i_proc = 1, num_procs - 1 + ! Make sure this process isn't already done + if (any(procs_done_arr == i_proc)) & + cycle + + call MPI_Probe(i_proc, MPI_ANY_TAG, MPI_COMM_WORLD, mpi_status, ierr) + + if (ierr /= 0) & + call ncdc_error("MPI ERROR OCCURRED!") + + ! Within mpi_status, we get the following: + ! MPI_SOURCE - the source process # + ! MPI_TAG - the tag # for the index + ! MPI_ERROR - error code of the probe operation + ! + ! The above are also indexes to fetch said value, e.g. + ! mpi_status(MPI_SOURCE) will get the source process #, + ! mpi_status(MPI_TAG) will get the tag #, etc. + ! + ! We also have a hidden value that needs to be "decoded" + ! via MPI_GET_COUNT. This gives us the number of + ! elements we'll be fetching. + ! + ! Now we gotta decode all of this into something we can use! + ! Our MPI_TAG is a big helper for us. MPI_TAG contains the + ! relative variable index that we use in our database. + ! As a result, we can instantly figure out the dimensions + ! and type for the variable we are about to store. + ! + ! With this information, we can take the count and divide it + ! by the fixed dimensions we just got to get our unlimited + ! dimensions (if applicable). + ! + ! Now, with the fixed and unlimited dimensions, the types, + ! and the variable index from the tag, we can now reconstruct + ! the data. + ! + ! First and foremost, we need to allocate a temporary variable + ! to store all of our data. Once we've allocated, we'll fetch + ! the data given all the parameters we got, plus the allocated + ! temporary variable. + ! + ! Once everything's done, we'll go ahead and add it to the final + ! array, with the correct position pre-calculated! + ! + ! Note - strings WILL be expanded to the pre-computed size. + + ! Finished file tag + if (mpi_status(MPI_TAG) == var_arr_total + 1000) then + file_count = file_count + 1 + + call MPI_Recv(i, 1, MPI_INT, & + i_proc, var_arr_total + 1000, MPI_COMM_WORLD, mpi_status, ierr) + + cycle + end if + + ! Finished process tag + if (mpi_status(MPI_TAG) == var_arr_total + 2000) then + call MPI_Recv(i, 1, MPI_INT, & + i_proc, var_arr_total + 2000, MPI_COMM_WORLD, mpi_status, ierr) + procs_done = procs_done + 1 + procs_done_arr(procs_done) = i_proc + cycle + end if + + cur_out_var_ind = mpi_status(MPI_TAG) + cur_out_var_ndims = var_dim_names(cur_out_var_ind)%num_names + + allocate(cur_out_dim_sizes(cur_out_var_ndims)) + + cur_out_var_counter = var_counters(cur_out_var_ind) + cur_out_var_type = var_types(cur_out_var_ind) + + do i = 1, cur_out_var_ndims + cur_out_dim_ind = nc_diag_cat_lookup_dim(var_dim_names(cur_out_var_ind)%dim_names(i)) + cur_out_dim_sizes(i) = dim_sizes(cur_out_dim_ind) + end do + + if (cur_out_var_type == NF90_BYTE) call MPI_GET_COUNT(mpi_status, MPI_BYTE, num_count, ierr) + if (cur_out_var_type == NF90_SHORT) call MPI_GET_COUNT(mpi_status, MPI_SHORT, num_count, ierr) + if (cur_out_var_type == NF90_INT) call MPI_GET_COUNT(mpi_status, MPI_INT, num_count, ierr) + if (cur_out_var_type == NF90_FLOAT) call MPI_GET_COUNT(mpi_status, MPI_FLOAT, num_count, ierr) + if (cur_out_var_type == NF90_DOUBLE) call MPI_GET_COUNT(mpi_status, MPI_DOUBLE, num_count, ierr) + if (cur_out_var_type == NF90_CHAR) call MPI_GET_COUNT(mpi_status, MPI_BYTE, num_count, ierr) + + if (ierr /= 0) & + call ncdc_error("MPI ERROR OCCURRED!") + + ! Check for one-time only vars... + if (((.NOT. any(cur_out_dim_sizes == -1)) .AND. (cur_out_var_counter == 0)) & + .OR. (any(cur_out_dim_sizes == -1))) then + + if ((cur_out_var_ndims == 1) .OR. & + ((cur_out_var_ndims == 2) .AND. (cur_out_var_type == NF90_CHAR))) then + if (cur_out_var_type == NF90_BYTE) then + allocate(byte_buffer (num_count)) + byte_buffer = NF90_FILL_BYTE + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(byte_buffer, num_count, MPI_BYTE, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%byte_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + num_count - 1) & + = byte_buffer(:) + + deallocate(byte_buffer) + else if (cur_out_var_type == NF90_SHORT) then + allocate(short_buffer (num_count)) + short_buffer = NF90_FILL_SHORT + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(short_buffer, num_count, MPI_SHORT, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%short_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + num_count - 1) & + = short_buffer(:) + + deallocate(short_buffer) + else if (cur_out_var_type == NF90_INT) then + allocate(long_buffer (num_count)) + long_buffer = NF90_FILL_INT + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(long_buffer, num_count, MPI_INT, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%long_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + num_count - 1) & + = long_buffer(:) + + deallocate(long_buffer) + else if (cur_out_var_type == NF90_FLOAT) then + allocate(rsingle_buffer (num_count)) + rsingle_buffer = NF90_FILL_FLOAT + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(rsingle_buffer, num_count, MPI_FLOAT, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%rsingle_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + num_count - 1) & + = rsingle_buffer(:) + + deallocate(rsingle_buffer) + else if (cur_out_var_type == NF90_DOUBLE) then + allocate(rdouble_buffer(num_count)) + rdouble_buffer = NF90_FILL_DOUBLE + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(rdouble_buffer, num_count, MPI_DOUBLE, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%rdouble_buffer & + (data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + num_count - 1) & + = rdouble_buffer(:) + + deallocate(rdouble_buffer) + else if (cur_out_var_type == NF90_CHAR) then + allocate(string_buffer (cur_out_dim_sizes(1), num_count / cur_out_dim_sizes(1))) + + string_buffer = NF90_FILL_CHAR + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(string_buffer, num_count, MPI_BYTE, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) +#ifdef DEBUG + write (*, "(A)") "*****************************************************" + write (*, "(A)") "DEBUG: var_name = [" // trim(var_names(cur_out_var_ind)) // "]" + write (*, "(A, I0)") "DEBUG: num_count = ", num_count + if (num_count > 0) & + write (*, "(A)") "DEBUG: string_buffer = [" // string_buffer(1:cur_out_dim_sizes(1), 1) // "]" + write (*, "(A, I0)") "DEBUG: cur_out_dim_sizes(1) = ", cur_out_dim_sizes(1) + write (*, "(A, I0)") "DEBUG: (num_count / cur_out_dim_sizes(1)) = ", (num_count / cur_out_dim_sizes(1)) + write (*, "(A, I0)") "DEBUG: data_blobs(cur_out_var_ind)%cur_pos = ", data_blobs(cur_out_var_ind)%cur_pos +#endif + data_blobs(cur_out_var_ind)%string_buffer & + (1 : cur_out_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + (num_count / cur_out_dim_sizes(1)) - 1) & + = string_buffer(:,:) + + deallocate(string_buffer) + else + write (err_string, "(A, I0, A)") & + "Invalid type detected during write." // & + CHAR(10) // " " // & + "(Variable '" // trim(tmp_var_name) // "' has an type of ", & + cur_out_var_type, "," // & + CHAR(10) // " " // & + "which is invalid!)" + call ncdc_error(trim(err_string)) + end if + + if (any(cur_out_dim_sizes == -1)) then + if (cur_out_var_type == NF90_CHAR) then + data_blobs(cur_out_var_ind)%cur_pos = & + data_blobs(cur_out_var_ind)%cur_pos + & + (num_count / cur_out_dim_sizes(1)) + else + data_blobs(cur_out_var_ind)%cur_pos = & + data_blobs(cur_out_var_ind)%cur_pos + & + num_count + end if + end if + else if (((cur_out_var_ndims == 2) .AND. (cur_out_var_type /= NF90_CHAR)) .OR. & + ((cur_out_var_ndims == 3) .AND. (cur_out_var_type == NF90_CHAR))) then + + if (cur_out_var_type == NF90_BYTE) then + allocate(byte_2d_buffer (cur_out_dim_sizes(1), num_count / cur_out_dim_sizes(1))) + + byte_2d_buffer = NF90_FILL_BYTE + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(byte_2d_buffer, num_count, MPI_BYTE, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%byte_2d_buffer & + (1 : cur_out_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + (num_count / cur_out_dim_sizes(1)) - 1) & + = byte_2d_buffer(:,:) + + deallocate(byte_2d_buffer) + else if (cur_out_var_type == NF90_SHORT) then + allocate(short_2d_buffer (cur_out_dim_sizes(1), num_count / cur_out_dim_sizes(1))) + + short_2d_buffer = NF90_FILL_SHORT + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(short_2d_buffer, num_count, MPI_SHORT, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%short_2d_buffer & + (1 : cur_out_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + (num_count / cur_out_dim_sizes(1)) - 1) & + = short_2d_buffer(:,:) + + deallocate(short_2d_buffer) + else if (cur_out_var_type == NF90_INT) then + allocate(long_2d_buffer (cur_out_dim_sizes(1), num_count / cur_out_dim_sizes(1))) + + long_2d_buffer = NF90_FILL_INT + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(long_2d_buffer, num_count, MPI_INT, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%long_2d_buffer & + (1 : cur_out_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + (num_count / cur_out_dim_sizes(1)) - 1) & + = long_2d_buffer(:,:) + + deallocate(long_2d_buffer) + else if (cur_out_var_type == NF90_FLOAT) then + allocate(rsingle_2d_buffer(cur_out_dim_sizes(1), num_count / cur_out_dim_sizes(1))) + + rsingle_2d_buffer = NF90_FILL_FLOAT + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(rsingle_2d_buffer, num_count, MPI_FLOAT, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%rsingle_2d_buffer & + (1 : cur_out_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + (num_count / cur_out_dim_sizes(1)) - 1) & + = rsingle_2d_buffer(:,:) + + deallocate(rsingle_2d_buffer) + else if (cur_out_var_type == NF90_DOUBLE) then + allocate(rdouble_2d_buffer(cur_out_dim_sizes(1), num_count / cur_out_dim_sizes(1))) + + rdouble_2d_buffer = NF90_FILL_DOUBLE + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(rdouble_2d_buffer, num_count, MPI_DOUBLE, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%rdouble_2d_buffer & + (1 : cur_out_dim_sizes(1), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + (num_count / cur_out_dim_sizes(1)) - 1) & + = rdouble_2d_buffer(:,:) + + deallocate(rdouble_2d_buffer) + else if (cur_out_var_type == NF90_CHAR) then + allocate(string_2d_buffer (cur_out_dim_sizes(1), cur_out_dim_sizes(2), & + num_count / (cur_out_dim_sizes(1) * cur_out_dim_sizes(2)))) + + string_2d_buffer = NF90_FILL_CHAR + + ! Args: the target variable, number of elements to recv, + ! data type (in MPI land), source process #, + ! numeric tag for extra info, and communicator. + call MPI_Recv(string_2d_buffer, num_count, MPI_BYTE, & + i_proc, cur_out_var_ind, MPI_COMM_WORLD, mpi_status, ierr) + + data_blobs(cur_out_var_ind)%string_2d_buffer & + (1 : cur_out_dim_sizes(1), & + 1 : cur_out_dim_sizes(2), & + data_blobs(cur_out_var_ind)%cur_pos : & + data_blobs(cur_out_var_ind)%cur_pos + & + (num_count / (cur_out_dim_sizes(1) * cur_out_dim_sizes(2))) - 1) & + = string_2d_buffer(:,:,:) + + deallocate(string_2d_buffer) + else + write (err_string, "(A, I0, A)") & + "Invalid type detected during write." // & + CHAR(10) // " " // & + "(Variable '" // trim(tmp_var_name) // "' has an type of ", & + cur_out_var_type, "," // & + CHAR(10) // " " // & + "which is invalid!)" + call ncdc_error(trim(err_string)) + end if + + if (any(cur_out_dim_sizes == -1)) then + if (cur_out_var_type == NF90_CHAR) then + data_blobs(cur_out_var_ind)%cur_pos = & + data_blobs(cur_out_var_ind)%cur_pos + & + (num_count / (cur_out_dim_sizes(1) * cur_out_dim_sizes(2))) + else + data_blobs(cur_out_var_ind)%cur_pos = & + data_blobs(cur_out_var_ind)%cur_pos + & + (num_count / cur_out_dim_sizes(1)) + end if + end if + else + write (err_string, "(A, I0, A, I0, A)") & + "Invalid dimensions detected during write." // & + CHAR(10) // " " // & + "(Variable '" // trim(tmp_var_name) // "' has an type of ", & + cur_out_var_type, & + ", with ", & + cur_out_var_ndims, & + " dimensions," // & + CHAR(10) // " " // & + "which is invalid!)" + call ncdc_error(trim(err_string)) + end if + end if + + ! Don't increment until we read the first round of files + if (((.NOT. any(cur_out_dim_sizes == -1)) .AND. & + (read_var_count(cur_out_var_ind) > (num_procs - 1))) & + .OR. (any(cur_out_dim_sizes == -1))) & + var_counters(cur_out_var_ind) = & + var_counters(cur_out_var_ind) + 1 + + read_var_count(cur_out_var_ind) = read_var_count(cur_out_var_ind) + 1 + + deallocate(cur_out_dim_sizes) + end do + ! End of process loop! + end do + + ! Attempt to flush the MPI queue! + ! We need to make sure everything exited properly... + do i = 1, 1000 + if (procs_done == (num_procs - 1)) then + exit + end if + do i_proc = 1, num_procs - 1 + call MPI_Iprobe(i_proc, MPI_ANY_TAG, MPI_COMM_WORLD, mpi_read_flag, mpi_status, ierr) + + ! Skip the rest if we can't do anything! + if (.NOT. mpi_read_flag) & + cycle + + if (ierr /= 0) & + call ncdc_error("MPI ERROR OCCURRED!") + + ! Finished file tag + if (mpi_status(MPI_TAG) == var_arr_total + 1000) then + call ncdc_error("Inconsistency error - getting file completion after" & + // char(10) & + // " main data loop end. BUG!") + else if (mpi_status(MPI_TAG) == var_arr_total + 2000) then + ! Finished process tag + call MPI_Recv(i, 1, MPI_INT, & + i_proc, var_arr_total + 2000, MPI_COMM_WORLD, mpi_status, ierr) + + procs_done = procs_done + 1 + procs_done_arr(procs_done) = i_proc + + cycle + else + ! We got data... that's really bad! + ! This is a bug and we need to exit, ASAP. + call ncdc_error("Inconsistency error - getting variable data after" & + // char(10) & + // " main data loop end. BUG!") + end if + end do + end do + + if (procs_done /= (num_procs - 1)) then + call ncdc_error("Inconsistency error - not all processes completed" & + // char(10) & + // " before main data loop end. BUG!") + end if + + deallocate(read_var_count) + end if + end subroutine nc_diag_cat_data_pass + + subroutine nc_diag_cat_data_commit + integer(i_long) :: var_index + +#ifndef QUIET + call ncdc_info("Doing final data commit...") +#endif + + do var_index = 1, var_arr_total +#ifndef QUIET + call ncdc_info(" => Writing variable " // trim(var_names(var_index)) // "...") +#endif + if ((var_dim_names(var_index)%num_names == 1) .OR. & + ((var_dim_names(var_index)%num_names == 2) .AND. (var_types(var_index) == NF90_CHAR)) ) then + if (var_types(var_index) == NF90_BYTE) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%byte_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + if (var_types(var_index) == NF90_SHORT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%short_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + if (var_types(var_index) == NF90_INT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%long_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + if (var_types(var_index) == NF90_FLOAT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%rsingle_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + + if (var_types(var_index) == NF90_DOUBLE) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%rdouble_buffer, & + start = (/ 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1) /) )) + if (var_types(var_index) == NF90_CHAR) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%string_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + else if ((var_dim_names(var_index)%num_names == 2) .OR. & + ((var_dim_names(var_index)%num_names == 3) .AND. (var_types(var_index) == NF90_CHAR)) ) then + if (var_types(var_index) == NF90_BYTE) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%byte_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_SHORT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%short_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_INT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%long_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_FLOAT) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%rsingle_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_DOUBLE) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%rdouble_2d_buffer, & + start = (/ 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2) /) )) + if (var_types(var_index) == NF90_CHAR) & + call ncdc_check(nf90_put_var(ncid_output, var_output_ids(var_index), & + data_blobs(var_index)%string_2d_buffer, & + start = (/ 1, 1, 1 /), & + count = (/ data_blobs(var_index)%alloc_size(1), & + data_blobs(var_index)%alloc_size(2), & + data_blobs(var_index)%alloc_size(3) /) )) + end if + end do + end subroutine nc_diag_cat_data_commit +#endif +end module ncdc_data_MPI diff --git a/src/ncdiag/ncdc_dims.F90 b/src/ncdiag/ncdc_dims.F90 new file mode 100644 index 000000000..571ae2973 --- /dev/null +++ b/src/ncdiag/ncdc_dims.F90 @@ -0,0 +1,120 @@ +module ncdc_dims + use ncd_kinds, only: i_long + use ncdc_state, only: dim_names, dim_sizes, dim_unlim_sizes, & + dim_counters, dim_output_ids, dim_arr_total, dim_arr_size + use ncdc_realloc, only: nc_diag_realloc + use ncdc_climsg, only: ncdc_error, ncdc_warning + + implicit none + + integer(i_long), parameter :: DIM_START_SIZE = 256 + + contains + function nc_diag_cat_lookup_dim(dim_name) result(ind) + character(len=*), intent(in) :: dim_name + integer(i_long) :: i, ind + + ind = -1 + + if (allocated(dim_names)) then + do i = 1, dim_arr_total + if (dim_names(i) == dim_name) then + ind = i + exit + end if + end do + end if + end function nc_diag_cat_lookup_dim + + subroutine nc_diag_cat_metadata_add_dim(dim_name, dim_size, dim_ul_size) + character(len=*), intent(in) :: dim_name + integer(i_long) , intent(in) :: dim_size + integer(i_long),optional, intent(in) :: dim_ul_size + + integer(i_long) :: dim_index + character(len=1000) :: err_string + + dim_index = nc_diag_cat_lookup_dim(dim_name) + + ! If we can't find it, it's new! Make sure we have enough + ! space for it... + if (dim_index == -1) then +#ifdef DEBUG + print *, "NEW DIM!" +#endif + dim_arr_total = dim_arr_total + 1 + + if (dim_arr_total >= dim_arr_size) then + if (allocated(dim_names)) then + call nc_diag_realloc(dim_names, DIM_START_SIZE) + call nc_diag_realloc(dim_sizes, DIM_START_SIZE) + call nc_diag_realloc(dim_counters, DIM_START_SIZE) + call nc_diag_realloc(dim_output_ids, DIM_START_SIZE) + call nc_diag_realloc(dim_unlim_sizes, DIM_START_SIZE) + dim_arr_size = dim_arr_size + DIM_START_SIZE + else + allocate(dim_names(DIM_START_SIZE)) + allocate(dim_sizes(DIM_START_SIZE)) + allocate(dim_counters(DIM_START_SIZE)) + allocate(dim_output_ids(DIM_START_SIZE)) + allocate(dim_unlim_sizes(DIM_START_SIZE)) + dim_arr_size = DIM_START_SIZE + end if + end if + + dim_index = dim_arr_total + + ! Add name + dim_names(dim_index) = dim_name + dim_sizes(dim_index) = 0 + dim_unlim_sizes(dim_index) = 0 + + ! Set counter to 0 + dim_counters(dim_index) = 0 + dim_output_ids(dim_index) = -1 + end if + + if (dim_size /= -1) then + ! Add/update size + if ((index(dim_name, "_maxstrlen") /= 0) .OR. (index(dim_name, "_str_dim") /= 0)) then + ! Use the maximum as the new size... and skip the check. + if (dim_size > dim_sizes(dim_index)) dim_sizes(dim_index) = dim_size + else + if ((dim_sizes(dim_index) /= 0) .AND. (dim_size /= dim_sizes(dim_index))) then + write (err_string, "(A, I0, A, I0, A)") & + "Fixed dimension length changed between files!" // & + CHAR(10) // " " // & + "(Fixed dimension '" // dim_name // "' changed from length ", & + dim_sizes(dim_index), & + CHAR(10) // " " // & + "to ", & + dim_size, & + "!)" + call ncdc_error(trim(err_string)) + end if + dim_sizes(dim_index) = dim_size + end if + else + if ((dim_sizes(dim_index) /= -1) .AND. (dim_sizes(dim_index) /= 0)) then + write (err_string, "(A, I0, A)") & + "Changed from a fixed dimension length to unlimited" // & + CHAR(10) // " " // & + "dimension length. (Fixed dimension '" // & + trim(dim_name) // & + "' had a fixed" // & + CHAR(10) // " " // & + "length of ", & + dim_sizes(dim_index), & + "!)" + call ncdc_error(trim(err_string)) + end if + dim_sizes(dim_index) = -1 + + if (present(dim_ul_size)) then + dim_unlim_sizes(dim_index) = dim_unlim_sizes(dim_index) + dim_ul_size + else + call ncdc_warning("Call made for unlimited dimension without specifying unlimited size!") + end if + end if + end subroutine nc_diag_cat_metadata_add_dim +end module ncdc_dims diff --git a/src/ncdiag/ncdc_metadata.F90 b/src/ncdiag/ncdc_metadata.F90 new file mode 100644 index 000000000..ddda3d372 --- /dev/null +++ b/src/ncdiag/ncdc_metadata.F90 @@ -0,0 +1,520 @@ +module ncdc_metadata + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + use ncdc_state, only: ncid_input, input_count, input_file, & + ncid_output, output_file, & + num_unlims, & + dim_arr_total, dim_sizes, dim_names, dim_output_ids, & + dim_unlim_sizes, & + var_arr_total, var_dim_names, var_names, var_types, & + var_output_ids, var_hasunlim, & + cli_arg_count, & +#ifdef USE_MPI + data_blobs, & + cur_proc +#else + data_blobs +#endif + use ncdc_dims, only: nc_diag_cat_lookup_dim, & + nc_diag_cat_metadata_add_dim + use ncdc_vars, only: nc_diag_cat_metadata_add_var + use ncdc_types, only: NC_DIAG_CAT_CHUNK_SIZE, & + NC_DIAG_CAT_GZIP_COMPRESS + use ncdc_climsg, only: ncdc_error, ncdc_warning, ncdc_info, & + ncdc_check + use ncdc_cli_process, only: ncdc_usage + use netcdf, only: nf90_inquire_attribute, nf90_get_att, & + nf90_put_att, nf90_open, nf90_close, nf90_inquire, & + nf90_inq_attname, nf90_inquire_dimension, & + nf90_inquire_variable, nf90_def_dim, nf90_def_var, & + nf90_def_var_chunking, nf90_def_var_deflate, & + NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE, & + NF90_CHAR, NF90_FILL_BYTE, NF90_FILL_SHORT, NF90_FILL_INT, & + NF90_FILL_FLOAT, NF90_FILL_DOUBLE, NF90_FILL_CHAR, & + NF90_GLOBAL, NF90_NOWRITE, NF90_ENOTATT, & + NF90_NOERR, NF90_MAX_NAME, NF90_UNLIMITED, NF90_CHUNKED + use netcdf_unlimdims, only: pf_nf90_inq_unlimdims + + implicit none + + contains + subroutine nc_diag_cat_copy_attr(attr_name, var_id_in, var_id_out) + character(len=*), intent(in) :: attr_name + integer(i_long), intent(in) :: var_id_in + integer(i_long), intent(in), optional :: var_id_out + + integer(i_byte), dimension(:), allocatable :: byte_arr + integer(i_short),dimension(:), allocatable :: short_arr + integer(i_long), dimension(:), allocatable :: long_arr + real(r_single),dimension(:), allocatable :: rsingle_arr + real(r_double),dimension(:), allocatable :: rdouble_arr + character(len=:), allocatable :: string_arr + + integer(i_long) :: attr_type, attr_len, final_var_id_out + + call ncdc_check(nf90_inquire_attribute(ncid_input, var_id_in, attr_name, & + xtype = attr_type, len = attr_len)) + + if (.NOT. present(var_id_out)) then + if (var_id_in /= NF90_GLOBAL) & + call ncdc_error("BUG! var_id_out not specified even when var_id_in is var-specific!") + final_var_id_out = var_id_in + else + final_var_id_out = var_id_out + end if + + if (attr_type == NF90_BYTE) then + allocate(byte_arr(attr_len)) + call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, byte_arr)) + call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, byte_arr)) + deallocate(byte_arr) + else if (attr_type == NF90_SHORT) then + allocate(short_arr(attr_len)) + call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, short_arr)) + call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, short_arr)) + deallocate(short_arr) + else if (attr_type == NF90_INT) then + allocate(long_arr(attr_len)) + call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, long_arr)) + call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, long_arr)) + deallocate(long_arr) + else if (attr_type == NF90_FLOAT) then + allocate(rsingle_arr(attr_len)) + call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, rsingle_arr)) + call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, rsingle_arr)) + deallocate(rsingle_arr) + else if (attr_type == NF90_DOUBLE) then + allocate(rdouble_arr(attr_len)) + call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, rdouble_arr)) + call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, rdouble_arr)) + deallocate(rdouble_arr) + else if (attr_type == NF90_CHAR) then + allocate(character(len=attr_len) :: string_arr) + call ncdc_check(nf90_get_att(ncid_input, var_id_in, attr_name, string_arr)) + call ncdc_check(nf90_put_att(ncid_output, final_var_id_out, attr_name, string_arr)) + deallocate(string_arr) + else + call ncdc_error("Unable to copy attribute for unknown type!") + end if + end subroutine nc_diag_cat_copy_attr + + subroutine nc_diag_cat_metadata_pass + character(len=1000) :: err_string + integer(i_long) :: old_dim_arr_total = 0, old_var_arr_total = 0 + + integer(i_long) :: tmp_dim_index, tmp_attr_index + integer(i_long) :: input_ndims, cached_ndims = -1 + integer(i_long) :: input_nvars, cached_nvars = -1 + integer(i_long) :: input_nattrs + + character(len=NF90_MAX_NAME) :: tmp_var_name + integer(i_long) :: tmp_var_type, tmp_var_ndims + integer(i_long), dimension(:), allocatable :: tmp_var_dimids + character(len=NF90_MAX_NAME) , allocatable :: tmp_var_dim_names(:) + + integer(i_long), dimension(:), allocatable :: unlim_dims + logical :: is_unlim = .FALSE. + + character(len=NF90_MAX_NAME) :: tmp_dim_name, tmp_attr_name + integer(i_long) :: tmp_dim_size + + integer(i_long) :: arg_index, var_index, i + + integer(i_long) :: nc_err + + character(:), allocatable :: input_file_cut + + input_count = cli_arg_count - 2 + +#ifndef QUIET +#ifdef USE_MPI + if (cur_proc == 0) & +#endif + call ncdc_info("Scanning NetCDF files for dimensions and variables...") +#endif + + do arg_index = 1, input_count + call get_command_argument(2 + arg_index, input_file) + + input_file_cut = trim(input_file) + + if (len(input_file_cut) <= 0) then + call ncdc_usage("Invalid input file name - likely blank!") + end if + + if (input_file_cut == output_file) then + call ncdc_warning(" -> Ignoring output file in input file list.") + call ncdc_info(" -> Skipping " // input_file_cut // " since it is the output file...") + else +#ifndef QUIET +#ifdef USE_MPI + if (cur_proc == 0) & +#endif + call ncdc_info(" -> Opening " // input_file_cut // " for reading...") +#endif + + call ncdc_check(nf90_open(input_file, NF90_NOWRITE, ncid_input)) + + ! Get top level info about the file! + call ncdc_check(nf90_inquire(ncid_input, nDimensions = input_ndims, & + nVariables = input_nvars, nAttributes = input_nattrs)) + +#ifdef USE_MPI + if (cur_proc == 0) then +#endif + ! Fetch attributes and only add if they are NOT in the final file + do tmp_attr_index = 1, input_nattrs + call ncdc_check(nf90_inq_attname(ncid_input, NF90_GLOBAL, tmp_attr_index, tmp_attr_name)) + + nc_err = nf90_inquire_attribute(ncid_output, & + NF90_GLOBAL, trim(tmp_attr_name)) + + ! If attribute doesn't exist, add it! + if (nc_err == NF90_ENOTATT) then + call nc_diag_cat_copy_attr(trim(tmp_attr_name), NF90_GLOBAL) + else if (nc_err /= NF90_NOERR) then + ! Sanity check - could be another error! + call ncdc_check(nc_err) + end if + end do +#ifdef USE_MPI + end if +#endif +#ifdef DEBUG + write (*, "(A, I0)") "Number of dimensions: ", input_ndims +#endif + + if (cached_ndims == -1) & + cached_ndims = input_ndims + + + if (input_ndims == 0) then +#ifndef QUIET + call ncdc_warning("No dimensions found in file " // input_file_cut // "! Skipping file...") +#endif + call ncdc_check(nf90_close(ncid_input)) + cycle + end if + +#ifndef QUIET + if (input_nvars == 0) & + call ncdc_warning("No variables found in file " // input_file_cut // "!") + + if (cached_ndims /= input_ndims) & + call ncdc_warning("Number of dimensions in " // trim(input_file) // " does not match first input file.") +#endif + + ! Get unlimited dimension information + call ncdc_check(pf_nf90_inq_unlimdims(ncid_input, num_unlims)) + +#ifdef DEBUG + write (*, "(A, I0)") "Number of unlimited dimensions: ", num_unlims +#endif + + allocate(unlim_dims(num_unlims)) + + call ncdc_check(pf_nf90_inq_unlimdims(ncid_input, num_unlims, unlim_dims)) + + ! Loop through each dimension! + do tmp_dim_index = 1, input_ndims + call ncdc_check(nf90_inquire_dimension(ncid_input, tmp_dim_index, & + tmp_dim_name, tmp_dim_size)) + + is_unlim = .FALSE. + + do i = 1, num_unlims + if (tmp_dim_index == unlim_dims(i)) then + is_unlim = .TRUE. + exit + end if + end do + + if (is_unlim) then +#ifdef DEBUG + write (*, "(A, I0, A, I0, A)") " => Dimension #", tmp_dim_index, ": " // & + trim(tmp_dim_name) // " (size: ", & + tmp_dim_size, & + " - UNLIMITED)" +#endif + call nc_diag_cat_metadata_add_dim(tmp_dim_name, -1, tmp_dim_size) + else +#ifdef DEBUG + write (*, "(A, I0, A, I0, A)") " => Dimension #", tmp_dim_index, ": " // & + trim(tmp_dim_name) // " (size: ", & + tmp_dim_size, & + ")" +#endif + call nc_diag_cat_metadata_add_dim(trim(tmp_dim_name), tmp_dim_size) + end if + end do + + deallocate(unlim_dims) + + ! Variables +#ifdef DEBUG + write (*, "(A, I0)") "Number of variables: ", input_nvars +#endif + + if (cached_nvars == -1) cached_nvars = input_nvars +#ifndef QUIET + if (cached_nvars /= input_nvars) & + call ncdc_warning("Number of variables in " // trim(input_file) // " does not match first input file.") +#endif + + if (input_nvars == 0) then + call ncdc_check(nf90_close(ncid_input)) + cycle + end if + + ! Loop through each variable! + do var_index = 1, input_nvars + ! Grab number of dimensions and attributes first + call ncdc_check(nf90_inquire_variable(ncid_input, var_index, name = tmp_var_name, & + ndims = tmp_var_ndims, xtype = tmp_var_type)) + + ! Allocate temporary variable dimids storage! + allocate(tmp_var_dimids(tmp_var_ndims)) + allocate(tmp_var_dim_names(tmp_var_ndims)) + + ! Grab the actual dimension IDs and attributes + + call ncdc_check(nf90_inquire_variable(ncid_input, var_index, dimids = tmp_var_dimids, & + xtype = tmp_var_type)) + + if ((tmp_var_ndims <= 2) .OR. & + ((tmp_var_ndims == 3) .AND. (tmp_var_type == NF90_CHAR))) then + +#ifdef DEBUG + write (*, "(A, I0, A, I0)") " => Variable #", var_index, ": " // & + trim(tmp_var_name) + write (*, "(A)", advance = "NO") " => Dimension IDs: " + + do i = 1, tmp_var_ndims + if (i /= 1) write (*, "(A)", advance = "NO") ", " + write (*, "(I0)", advance = "NO") tmp_var_dimids(i) + end do + + write (*, "(A)") "" + + write (*, "(A)", advance = "NO") " => Dimensions: " +#endif + + do i = 1, tmp_var_ndims +#ifdef DEBUG + if (i /= 1) write (*, "(A)", advance = "NO") ", " +#endif + call ncdc_check(nf90_inquire_dimension(ncid_input, tmp_var_dimids(i), tmp_var_dim_names(i))) +#ifdef DEBUG + write (*, "(A)", advance = "NO") trim(tmp_var_dim_names(i)) +#endif + end do + +#ifdef DEBUG + write (*, "(A)") "" +#endif + + call nc_diag_cat_metadata_add_var(trim(tmp_var_name), tmp_var_type, tmp_var_ndims, tmp_var_dim_names) + else + write (err_string, "(A, I0, A)") & + "Variables with >2 dimensions NOT supported." // & + CHAR(10) // " " // & + "(Variable '" // trim(tmp_var_name) // "' has ", & + tmp_var_ndims, & + " dimensions!)" + call ncdc_error(trim(err_string)) + end if + ! Deallocate + deallocate(tmp_var_dimids) + deallocate(tmp_var_dim_names) + end do + +#ifdef DEBUG + write (*, "(A)") " => For all variables, the order of dimensions are INVERTED!" +#endif + + call ncdc_check(nf90_close(ncid_input)) + + old_dim_arr_total = dim_arr_total + old_var_arr_total = var_arr_total + end if + end do + end subroutine nc_diag_cat_metadata_pass + + subroutine nc_diag_cat_metadata_define + integer(i_long) :: i, j + + call ncdc_info("Creating new dimensions and variables for output file...") + + call ncdc_info(" -> Defining dimensions...") + + if (dim_arr_total == 0) & + call ncdc_warning("No dimensions found in input files, so not defining anything.") + + do i = 1, dim_arr_total + if (dim_sizes(i) == -1) then + call ncdc_check(nf90_def_dim(ncid_output, dim_names(i), & + NF90_UNLIMITED, dim_output_ids(i))) + else + call ncdc_check(nf90_def_dim(ncid_output, dim_names(i), & + dim_sizes(i), dim_output_ids(i))) + end if +#ifdef DEBUG + write(*, "(A, I0, A, I0)") "STORED DIMID for dim " // trim(dim_names(i)) // ": ", & + dim_output_ids(i), " | size: ", dim_sizes(i) +#endif + end do + + if (var_arr_total == 0) & + call ncdc_warning("No variables found in input files, so not defining anything.") + + call ncdc_info(" -> Defining variables...") + do i = 1, var_arr_total + do j = 1, var_dim_names(i)%num_names + var_dim_names(i)%output_dim_ids(j) = & + dim_output_ids(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(j))) +#ifdef DEBUG + write(*, "(A, I0)") "Paired ID for dim " // trim(var_dim_names(i)%dim_names(j)) // ": ", & + var_dim_names(i)%output_dim_ids(j) +#endif + end do + +#ifdef DEBUG + write (*, "(A, I0, A)") "Defining variable: " // trim(var_names(i)) // " (type = ", var_types(i), ")" + + print *, "var_dim_names(i)%output_dim_ids", var_dim_names(i)%output_dim_ids + print *, "LEN var_dim_names(i)%output_dim_ids", size(var_dim_names(i)%output_dim_ids) +#endif + + call ncdc_check(nf90_def_var(ncid_output, var_names(i), var_types(i), & + var_dim_names(i)%output_dim_ids, & + var_output_ids(i))) + +#ifdef DEBUG + if (var_dim_names(i)%num_names == 1) print *, "DIM #1", var_dim_names(i)%dim_names(1) + if (var_dim_names(i)%num_names == 2) print *, "DIM #2", var_dim_names(i)%dim_names(2) + if (var_dim_names(i)%num_names == 3) print *, "DIM #3", var_dim_names(i)%dim_names(3) +#endif + + if (var_hasunlim(i)) then + if (var_dim_names(i)%num_names == 1) then + call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & + NF90_CHUNKED, (/ NC_DIAG_CAT_CHUNK_SIZE /) )) + else if (var_dim_names(i)%num_names == 2) then + call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & + NF90_CHUNKED, (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & + NC_DIAG_CAT_CHUNK_SIZE /) )) + else if (var_dim_names(i)%num_names == 3) then + call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & + NF90_CHUNKED, & + (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))), & + NC_DIAG_CAT_CHUNK_SIZE /) )) + end if + else + if (var_dim_names(i)%num_names == 1) then + call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & + NF90_CHUNKED, (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))) /) )) + else if (var_dim_names(i)%num_names == 2) then + call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & + NF90_CHUNKED, (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))) /) )) + else if (var_dim_names(i)%num_names == 3) then + call ncdc_check(nf90_def_var_chunking(ncid_output, var_output_ids(i), & + NF90_CHUNKED, & + (/ dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))), & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(3))) /) )) + end if + end if + + call ncdc_check(nf90_def_var_deflate(ncid_output, var_output_ids(i), & + shuffle = 1, deflate = 1, deflate_level = NC_DIAG_CAT_GZIP_COMPRESS)) + end do + end subroutine nc_diag_cat_metadata_define + + subroutine nc_diag_cat_metadata_alloc + integer(i_long), dimension(3) :: alloc_dim_sizes = 0 + integer(i_long) :: i + + ! Next portion depends on defines/vars in ncdc_data_decl.F90 + call ncdc_info(" -> Allocating data storage for variables...") + + allocate(data_blobs(var_arr_total)) + + do i = 1, var_arr_total + if (var_dim_names(i)%num_names == 1) then + alloc_dim_sizes = (/ & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & + 0, & + 0 /) + + ! Check for unlimited sizes and replace them! + if (alloc_dim_sizes(1) == -1) & + alloc_dim_sizes(1) = & + dim_unlim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))) + + if (var_types(i) == NF90_BYTE) allocate(data_blobs(i)%byte_buffer(alloc_dim_sizes(1))) + if (var_types(i) == NF90_SHORT) allocate(data_blobs(i)%short_buffer(alloc_dim_sizes(1))) + if (var_types(i) == NF90_INT) allocate(data_blobs(i)%long_buffer(alloc_dim_sizes(1))) + if (var_types(i) == NF90_FLOAT) allocate(data_blobs(i)%rsingle_buffer(alloc_dim_sizes(1))) + if (var_types(i) == NF90_DOUBLE) allocate(data_blobs(i)%rdouble_buffer(alloc_dim_sizes(1))) + if (var_types(i) == NF90_CHAR) call ncdc_error("1D character variable type not supported!") + + if (var_types(i) == NF90_BYTE) data_blobs(i)%byte_buffer = NF90_FILL_BYTE + if (var_types(i) == NF90_SHORT) data_blobs(i)%short_buffer = NF90_FILL_SHORT + if (var_types(i) == NF90_INT) data_blobs(i)%long_buffer = NF90_FILL_INT + if (var_types(i) == NF90_FLOAT) data_blobs(i)%rsingle_buffer = NF90_FILL_FLOAT + if (var_types(i) == NF90_DOUBLE) data_blobs(i)%rdouble_buffer = NF90_FILL_DOUBLE + else if (var_dim_names(i)%num_names == 2) then + alloc_dim_sizes = (/ & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))), & + 0 /) + + ! Check for unlimited sizes and replace them! + if (alloc_dim_sizes(2) == -1) & + alloc_dim_sizes(2) = & + dim_unlim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))) + + if (var_types(i) == NF90_BYTE) allocate(data_blobs(i)%byte_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) + if (var_types(i) == NF90_SHORT) allocate(data_blobs(i)%short_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) + if (var_types(i) == NF90_INT) allocate(data_blobs(i)%long_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) + if (var_types(i) == NF90_FLOAT) allocate(data_blobs(i)%rsingle_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) + if (var_types(i) == NF90_DOUBLE) allocate(data_blobs(i)%rdouble_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) + if (var_types(i) == NF90_CHAR) allocate(data_blobs(i)%string_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2))) + + if (var_types(i) == NF90_BYTE) data_blobs(i)%byte_2d_buffer = NF90_FILL_BYTE + if (var_types(i) == NF90_SHORT) data_blobs(i)%short_2d_buffer = NF90_FILL_SHORT + if (var_types(i) == NF90_INT) data_blobs(i)%long_2d_buffer = NF90_FILL_INT + if (var_types(i) == NF90_FLOAT) data_blobs(i)%rsingle_2d_buffer = NF90_FILL_FLOAT + if (var_types(i) == NF90_DOUBLE) data_blobs(i)%rdouble_2d_buffer = NF90_FILL_DOUBLE + if (var_types(i) == NF90_CHAR) data_blobs(i)%string_buffer = NF90_FILL_CHAR + + else if (var_dim_names(i)%num_names == 3) then + alloc_dim_sizes = (/ & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(1))), & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(2))), & + dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(3))) /) + + ! Check for unlimited sizes and replace them! + ! (Though, this should always be the case...) + if (alloc_dim_sizes(3) == -1) & + alloc_dim_sizes(3) = & + dim_unlim_sizes(nc_diag_cat_lookup_dim(var_dim_names(i)%dim_names(3))) + + if (var_types(i) == NF90_CHAR) then + allocate(data_blobs(i)%string_2d_buffer(alloc_dim_sizes(1), alloc_dim_sizes(2), alloc_dim_sizes(3))) + data_blobs(i)%string_2d_buffer = NF90_FILL_CHAR + else + call ncdc_error("3D non-character variable type not supported!") + end if + end if + + data_blobs(i)%alloc_size = alloc_dim_sizes + !print *, trim(var_names(i)), data_blobs(i)%alloc_size + end do + +#ifdef DEBUG + print *, "!! END DEFINITION PASS" +#endif + end subroutine nc_diag_cat_metadata_alloc +end module ncdc_metadata diff --git a/src/ncdiag/ncdc_realloc.F90 b/src/ncdiag/ncdc_realloc.F90 new file mode 100644 index 000000000..6b6272633 --- /dev/null +++ b/src/ncdiag/ncdc_realloc.F90 @@ -0,0 +1,331 @@ +module ncdc_realloc + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + use ncdc_types, only: nc_diag_cat_dim_names + + implicit none + + !=============================================================== + ! nc_diag_realloc - reallocation support (declaration) + !=============================================================== + ! DO NOT COMPILE THIS DIRECTLY! THIS IS MEANT TO BE INCLUDED + ! INSIDE A LARGER F90 SOURCE! + ! If you compile this directly, you WILL face the WRATH of your + ! compiler! + !--------------------------------------------------------------- + ! Depends on: nothing + !--------------------------------------------------------------- + ! nc_diag_realloc subroutines provide reallocation functionality + ! for various inputs. + !--------------------------------------------------------------- + ! This file provides the interface wrapper for the array + ! reallocation subroutines. This is so that others can simply + ! call nc_diag_realloc with the necessary arguments, instead of + ! having to call the specific nc_diag_realloc_* subroutines. + + interface nc_diag_realloc + module procedure nc_diag_realloc_byte, & + nc_diag_realloc_short, nc_diag_realloc_long, & + nc_diag_realloc_rsingle, nc_diag_realloc_rdouble, & + nc_diag_realloc_string, nc_diag_realloc_logical, & + nc_diag_realloc_ncdcdn + end interface nc_diag_realloc + + contains + ! nc_diag_realloc_byte(arr, addl_num_entries) + ! input: + ! integer(i_byte), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_byte(arr, addl_num_entries) + integer(i_byte), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + integer(i_byte), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nc_diag_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_byte + + ! nc_diag_realloc_short(arr, addl_num_entries) + ! input: + ! integer(i_short), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_short(arr, addl_num_entries) + integer(i_short), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + integer(i_short), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nc_diag_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_short + + ! nc_diag_realloc_long(arr, addl_num_entries) + ! input: + ! integer(i_long), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_long(arr, addl_num_entries) + integer(i_long), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + integer(i_long), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + +#ifdef _DEBUG_MEM_ + call debug("Reallocating long array...") +#endif + + new_size = size(arr) + addl_num_entries + +#ifdef _DEBUG_MEM_ + print *, "REALLOCATOR: new_size is ", new_size +#endif + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nc_diag_realloc_error(trim(err_msg)) + end if + + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + +#ifdef _DEBUG_MEM_ + print *, "REALLOCATOR: final actual size is ", size(arr) + call debug("Realloc finished for long") +#endif + end subroutine nc_diag_realloc_long + + ! nc_diag_realloc_rsingle(arr, addl_num_entries) + ! input: + ! real(r_single), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_rsingle(arr, addl_num_entries) + real(r_single), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + real(r_single), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nc_diag_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_rsingle + + ! nc_diag_realloc_rdouble(arr, addl_num_entries) + ! input: + ! real(r_double), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_rdouble(arr, addl_num_entries) + real(r_double), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + real(r_double), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nc_diag_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_rdouble + + ! nc_diag_realloc_string(arr, addl_num_entries) + ! input: + ! character(len=*), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_string(arr, addl_num_entries) + character(len=*), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + character(len=len(arr(1))), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + +#ifdef _DEBUG_MEM_ + integer(i_long) :: string_len, string_arr_size + + string_len = len(arr(1)) + string_arr_size = size(arr) + + call debug("[string] Length of string to allocate to:") + print *, string_len + + call debug("[string] Allocating from...") + print *, string_arr_size + + call debug("[string] ...to size...") + print *, (string_arr_size + addl_num_entries) +#endif + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nc_diag_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_string + + ! nc_diag_realloc_logical(arr, addl_num_entries) + ! input: + ! logical, dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_logical(arr, addl_num_entries) + logical, dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + logical, dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_long) :: logical_arr_size + logical_arr_size = size(arr) + + new_size = logical_arr_size + addl_num_entries + +#ifdef _DEBUG_MEM_ + call debug("[logical] Allocating from...") + print *, logical_arr_size + + call debug("[logical] ...to size...") + print *, (logical_arr_size + addl_num_entries) +#endif + + allocate(tmp(new_size)) + tmp(1:logical_arr_size) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp +#ifdef _DEBUG_MEM_ + call debug("[logical] Final size:") + print *, size(arr) +#endif + end subroutine nc_diag_realloc_logical + + ! nc_diag_realloc_ncdcdn(arr, addl_num_entries) + ! input: + ! type(nc_diag_cat_dim_names), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_ncdcdn(arr, addl_num_entries) + type(nc_diag_cat_dim_names), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + type(nc_diag_cat_dim_names), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nc_diag_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_ncdcdn + + subroutine nc_diag_realloc_error(err) + character(len=*), intent(in) :: err +#ifdef ERROR_TRACEBACK + integer(i_long) :: div0 +#endif + write(*, "(A)") " ** ERROR: " // err +#ifdef ERROR_TRACEBACK + write(*, "(A)") " ** Failed to concatenate NetCDF4." + write(*, "(A)") " (Traceback requested, triggering div0 error...)" + div0 = 1 / 0 + write(*, "(A)") " Couldn't trigger traceback, ending gracefully." + write(*, "(A)") " (Ensure floating point exceptions are enabled," + write(*, "(A)") " and that you have debugging (-g) and tracebacks" + write(*, "(A)") " compiler flags enabled!)" + stop 1 +#else + stop " ** Failed to concatenate NetCDF4." +#endif + end subroutine nc_diag_realloc_error +end module ncdc_realloc diff --git a/src/ncdiag/ncdc_state.F90 b/src/ncdiag/ncdc_state.F90 new file mode 100644 index 000000000..0489cbea6 --- /dev/null +++ b/src/ncdiag/ncdc_state.F90 @@ -0,0 +1,49 @@ +module ncdc_state + use ncd_kinds, only: i_long + use ncdc_types, only: nc_diag_cat_dim_names, data_blob + + implicit none + +#ifdef USE_MPI + integer(i_long) :: cur_proc, num_procs, ierr +#endif + + character(len=10000000) :: prgm_name, dummy_arg, output_file, input_file + integer(i_long) :: cli_arg_count, input_count + + integer(i_long) :: ncid_output, ncid_input + + ! Dimension storage + character(len=100), dimension(:), allocatable :: dim_names + integer(i_long), dimension(:), allocatable :: dim_sizes + integer(i_long), dimension(:), allocatable :: dim_output_ids + integer(i_long), dimension(:), allocatable :: dim_counters + integer(i_long), dimension(:), allocatable :: dim_unlim_sizes + + ! Array storage info for dimension storage + integer(i_long) :: dim_arr_total = 0 + integer(i_long) :: dim_arr_size = 0 + + integer(i_long) :: num_unlims + + ! dim_sizes(i) of -1 designates an unlimited dimension + + ! Variable dimensions storage + ! See ncdc_realloc for nc_diag_cat_dim_names derived type def + + ! Variable storage + character(len=100), dimension(:), allocatable :: var_names + integer(i_long), dimension(:), allocatable :: var_types + type(nc_diag_cat_dim_names), dimension(:), allocatable :: var_dim_names + integer(i_long), dimension(:), allocatable :: var_output_ids + integer(i_long), dimension(:), allocatable :: var_counters + logical, dimension(:), allocatable :: var_hasunlim + + ! Array storage info for variable storage + integer(i_long) :: var_arr_total = 0 + integer(i_long) :: var_arr_size = 0 + + ! Data blob stores entire variable's data! + ! Indexing uses the metadata indexing system. + type(data_blob), dimension(:), allocatable :: data_blobs +end module ncdc_state diff --git a/src/ncdiag/ncdc_types.f90 b/src/ncdiag/ncdc_types.f90 new file mode 100644 index 000000000..081825c3f --- /dev/null +++ b/src/ncdiag/ncdc_types.f90 @@ -0,0 +1,38 @@ +module ncdc_types + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + + implicit none + + integer(i_long), parameter :: NC_DIAG_CAT_GZIP_COMPRESS = 6 + integer(i_long), parameter :: NC_DIAG_CAT_CHUNK_SIZE = 16384 + + ! Variable dimensions storage + type nc_diag_cat_dim_names + character(len=100), dimension(:), allocatable :: dim_names + integer(i_long), dimension(:), allocatable :: output_dim_ids + integer(i_long) :: num_names = 0 + end type nc_diag_cat_dim_names + + type data_blob + integer(i_byte), dimension(:), allocatable :: byte_buffer + integer(i_short), dimension(:), allocatable :: short_buffer + integer(i_long), dimension(:), allocatable :: long_buffer + + real(r_single), dimension(:), allocatable :: rsingle_buffer + real(r_double), dimension(:), allocatable :: rdouble_buffer + + character(1) ,dimension(:,:), allocatable :: string_buffer + + integer(i_byte), dimension(:,:), allocatable :: byte_2d_buffer + integer(i_short), dimension(:,:), allocatable :: short_2d_buffer + integer(i_long), dimension(:,:), allocatable :: long_2d_buffer + + real(r_single), dimension(:,:), allocatable :: rsingle_2d_buffer + real(r_double), dimension(:,:), allocatable :: rdouble_2d_buffer + + character(1), dimension(:,:,:), allocatable :: string_2d_buffer + + integer(i_long) :: cur_pos = 1 + integer(i_long), dimension(3) :: alloc_size + end type data_blob +end module ncdc_types diff --git a/src/ncdiag/ncdc_vars.F90 b/src/ncdiag/ncdc_vars.F90 new file mode 100644 index 000000000..cfb9d94c2 --- /dev/null +++ b/src/ncdiag/ncdc_vars.F90 @@ -0,0 +1,157 @@ +module ncdc_vars + use ncd_kinds, only: i_long + use ncdc_state, only: var_names, var_types, var_output_ids, & + var_counters, var_hasunlim, var_dim_names, var_arr_total, & + var_arr_size + use ncdc_dims, only: dim_sizes, nc_diag_cat_lookup_dim + use ncdc_realloc, only: nc_diag_realloc + use ncdc_climsg, only: ncdc_error + use netcdf, only: NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, & + NF90_DOUBLE, NF90_CHAR + + implicit none + + integer(i_long), parameter :: VAR_START_SIZE = 1024 + + contains + function nc_diag_cat_lookup_var(var_name) result(ind) + character(len=*), intent(in) :: var_name + integer(i_long) :: i, ind + + ind = -1 + + if (allocated(var_names)) then + do i = 1, var_arr_total + if (var_names(i) == var_name) then + ind = i + exit + end if + end do + end if + end function nc_diag_cat_lookup_var + + subroutine nc_diag_cat_metadata_add_var(var_name, var_type, var_ndims, var_dims) + character(len=*), intent(in) :: var_name + integer(i_long) , intent(in) :: var_type + integer(i_long) , intent(in) :: var_ndims + character(len=*), intent(in) :: var_dims(:) + + integer(i_long) :: var_index, i + character(len=1000) :: err_string + + var_index = nc_diag_cat_lookup_var(trim(var_name)) + + ! If we can't find it, it's new! Make sure we have enough + ! space for it... + if (var_index == -1) then +#ifdef DEBUG + print *, "NEW VAR! Var = " // trim(var_name) +#endif + + var_arr_total = var_arr_total + 1 + + if (var_arr_total >= var_arr_size) then + if (allocated(var_names)) then + call nc_diag_realloc(var_names, VAR_START_SIZE) + call nc_diag_realloc(var_types, VAR_START_SIZE) + call nc_diag_realloc(var_dim_names, VAR_START_SIZE) + call nc_diag_realloc(var_output_ids, VAR_START_SIZE) + call nc_diag_realloc(var_counters, VAR_START_SIZE) + call nc_diag_realloc(var_hasunlim, VAR_START_SIZE) + else + allocate(var_names(VAR_START_SIZE)) + allocate(var_types(VAR_START_SIZE)) + allocate(var_dim_names(VAR_START_SIZE)) + allocate(var_output_ids(VAR_START_SIZE)) + allocate(var_counters(VAR_START_SIZE)) + allocate(var_hasunlim(VAR_START_SIZE)) + var_arr_size = VAR_START_SIZE + end if + end if + +#ifdef DEBUG + write (*, "(A)", advance="NO") "DEBUG DUMP:" + + do i = 1, var_arr_total - 1 + if (i /= 1) write (*, "(A)", advance="NO") ", " + write (*, "(A)", advance="NO") var_names(i) + end do + + print *, "NEW var_index: ", var_arr_total +#endif + + var_index = var_arr_total + + ! Add name + var_names(var_index) = var_name + var_types(var_index) = var_type + var_counters(var_index) = 0 + end if + + if (allocated(var_dim_names(var_index)%dim_names)) then + ! Just do a sanity check! + if (var_types(var_index) /= var_type) & + call ncdc_error("Variable type changed!" // & + CHAR(10) // " " // & + "(Type of variable '" // var_name // "' changed from " // & + trim(nc_diag_cat_metadata_type_to_str(var_types(var_index))) // & + CHAR(10) // " " // & + "to " // & + trim(nc_diag_cat_metadata_type_to_str(var_type)) // & + "!)") + + if (var_dim_names(var_index)%num_names /= var_ndims) then + write (err_string, "(A, I0, A, I0, A)") & + "Variable ndims changed!" // & + CHAR(10) // " " // & + "(Variable '" // var_name // "' changed ndims from ", & + var_dim_names(var_index)%num_names, & + CHAR(10) // " " // & + "to ", & + var_ndims, & + "!)" + call ncdc_error(trim(err_string)) + end if + + do i = 1, var_ndims + if (var_dim_names(var_index)%dim_names(i) /= var_dims(i)) & + call ncdc_error("Variable dimensions changed!" // & + CHAR(10) // " " // & + "(Variable '" // var_name // "' changed dimension from " // & + trim(var_dim_names(var_index)%dim_names(i)) // & + CHAR(10) // " " // & + "to " // & + trim(var_dims(i)) // & + "!)") + end do + else + var_dim_names(var_index)%num_names = var_ndims + allocate(var_dim_names(var_index)%dim_names(var_ndims)) + allocate(var_dim_names(var_index)%output_dim_ids(var_ndims)) + var_dim_names(var_index)%dim_names(1:var_ndims) = var_dims(1:var_ndims) + var_hasunlim(var_index) = .FALSE. + + do i = 1, var_ndims + if (dim_sizes(nc_diag_cat_lookup_dim(var_dim_names(var_index)%dim_names(i))) == -1) then + var_hasunlim(var_index) = .TRUE. + exit + end if + end do + + end if + end subroutine nc_diag_cat_metadata_add_var + + function nc_diag_cat_metadata_type_to_str(var_type) result(nc_str) + integer(i_long) :: var_type + character(len=11) :: nc_str + + nc_str = "(invalid)" + + if (var_type == NF90_BYTE) nc_str = "NF90_BYTE" + if (var_type == NF90_SHORT) nc_str = "NF90_SHORT" + if (var_type == NF90_INT) nc_str = "NF90_INT (LONG)" + if (var_type == NF90_FLOAT) nc_str = "NF90_FLOAT" + if (var_type == NF90_DOUBLE) nc_str = "NF90_DOUBLE" + if (var_type == NF90_CHAR) nc_str = "NF90_CHAR" + end function nc_diag_cat_metadata_type_to_str +end module ncdc_vars diff --git a/src/ncdiag/ncdf_path_m.F90 b/src/ncdiag/ncdf_path_m.F90 new file mode 100644 index 000000000..467dff887 --- /dev/null +++ b/src/ncdiag/ncdf_path_m.F90 @@ -0,0 +1,697 @@ +! Copyright (c) 2012 Joseph A. Levin +! +! Permission is hereby granted, free of charge, to any person obtaining a copy of this +! software and associated documentation files (the "Software"), to deal in the Software +! without restriction, including without limitation the rights to use, copy, modify, merge, +! publish, distribute, sublicense, and/or sell copies of the Software, and to permit +! persons to whom the Software is furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in all copies or +! substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, +! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR +! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT +! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +! DEALINGS IN THE SOFTWARE. + +! +! File: ncdf_path_m.f95 +! Author: Joseph A. Levin +! +! Created on March 10, 2012, 11:01 PM +! + +module ncdf_path_m + + use ncdf_value_m + use ncdf_string_m + + private + + public :: ncdf_path_get + + interface ncdf_path_get + module procedure ncdf_get_by_path + module procedure ncdf_get_integer + module procedure ncdf_get_real + module procedure ncdf_get_double + module procedure ncdf_get_logical + module procedure ncdf_get_chars + module procedure ncdf_get_array_1d_integer + module procedure ncdf_get_array_2d_integer + module procedure ncdf_get_array_1d_real + module procedure ncdf_get_array_2d_real + module procedure ncdf_get_array_1d_double + module procedure ncdf_get_array_2d_double + module procedure ncdf_get_array_1d_logical + module procedure ncdf_get_array_2d_logical + end interface ncdf_path_get + + abstract interface + + subroutine ncdf_array_callback_1d(element, i, count) + use ncdf_value_m + implicit none + type(ncdf_value), pointer,intent(in) :: element + integer, intent(in) :: i ! index + integer, intent(in) :: count ! size of array + end subroutine ncdf_array_callback_1d + + subroutine ncdf_array_callback_2d(element, i1, i2, count1, count2) + use ncdf_value_m + implicit none + type(ncdf_value), pointer,intent(in) :: element + integer, intent(in) :: i1, i2 + integer, intent(in) :: count1, count2 + end subroutine ncdf_array_callback_2d + + end interface + +contains + ! + ! GET BY PATH + ! + ! $ = root + ! @ = this + ! . = child object member + ! [] = child array element + ! + recursive subroutine ncdf_get_by_path(this, path, p) + type(ncdf_value), pointer :: this, p + character(len=*) :: path + integer :: i, length, child_i + character :: c + logical :: array + + ! default to assuming relative to this + p => this + + child_i = 1 + + array = .false. + + length = len_trim(path) + + do i=1, length + c = path(i:i) + select case (c) + case ("$") + ! root + do while (associated (p % parent)) + p => p % parent + end do + child_i = i + 1 + case ("@") + ! this + p => this + child_i = i + 1 + case (".", "[") + ! get child member from p + if (child_i < i) then + p => ncdf_value_get(p, path(child_i:i-1)) + else + child_i = i + 1 + cycle + end if + + if(.not.associated(p)) then + return + end if + + child_i = i+1 + + ! check if this is an array + ! if so set the array flag + if (c == "[") then + ! start looking for the array element index + array = .true. + end if + case ("]") + if (.not.array) then + print *, "ERROR: Unexpected ], not missing preceding [" + call exit(1) + end if + array = .false. + child_i = parse_integer(path(child_i:i-1)) + p => ncdf_value_get(p, child_i) + + child_i= i + 1 + end select + end do + + ! grab the last child if present in the path + if (child_i <= length) then + p => ncdf_value_get(p, path(child_i:i-1)) + if(.not.associated(p)) then + return + else + end if + end if + + + end subroutine ncdf_get_by_path + + ! + ! PARSE INTEGER + ! + integer function parse_integer(chars) result(integral) + character(len=*) :: chars + character :: c + integer :: tmp, i + + integral = 0 + do i=1, len_trim(chars) + c = chars(i:i) + select case(c) + case ("0":"9") + ! digit + read (c, '(i1)') tmp + + ! shift + if(i > 1) then + integral = integral * 10 + end if + ! add + integral = integral + tmp + + case default + return + end select + end do + + end function parse_integer + + ! + ! GET INTEGER + ! + subroutine ncdf_get_integer(this, path, value) + type(ncdf_value), pointer :: this, p + character(len=*), optional :: path + integer :: value + + + nullify(p) + if(present(path)) then + call ncdf_get_by_path(this=this, path=path, p=p) + else + p => this + end if + + if(.not.associated(p)) then + print *, "Unable to resolve path: ", path + return + end if + + + if(p % value_type == TYPE_INTEGER) then + value = p % value_integer + else if (p % value_type == TYPE_REAL) then + value = p % value_real + else if (p % value_type == TYPE_LOGICAL) then + if (p % value_logical) then + value = 1 + else + value = 0 + end if + else + print *, "Unable to resolve value to integer: ", path + call exit(1) + end if + + end subroutine ncdf_get_integer + + ! + ! GET REAL + ! + subroutine ncdf_get_real(this, path, value) + type(ncdf_value), pointer :: this, p + character(len=*), optional :: path + real :: value + + + nullify(p) + + if(present(path)) then + call ncdf_get_by_path(this=this, path=path, p=p) + else + p => this + end if + + if(.not.associated(p)) then + print *, "Unable to resolve path: ", path + return + end if + + + if(p % value_type == TYPE_INTEGER) then + value = p % value_integer + else if (p % value_type == TYPE_REAL) then + value = p % value_real + else if (p % value_type == TYPE_LOGICAL) then + if (p % value_logical) then + value = 1 + else + value = 0 + end if + else + print *, "Unable to resolve value to real: ", path + call exit(1) + end if + + end subroutine ncdf_get_real + + ! + ! GET DOUBLE + ! + subroutine ncdf_get_double(this, path, value) + type(ncdf_value), pointer :: this, p + character(len=*), optional :: path + double precision :: value + + + nullify(p) + + if(present(path)) then + call ncdf_get_by_path(this=this, path=path, p=p) + else + p => this + end if + + if(.not.associated(p)) then + print *, "Unable to resolve path: ", path + return + end if + + + if(p % value_type == TYPE_INTEGER) then + value = p % value_integer + else if (p % value_type == TYPE_REAL) then + value = p % value_double + else if (p % value_type == TYPE_LOGICAL) then + if (p % value_logical) then + value = 1 + else + value = 0 + end if + else + print *, "Unable to resolve value to double: ", path + call exit(1) + end if + + end subroutine ncdf_get_double + + + ! + ! GET LOGICAL + ! + subroutine ncdf_get_logical(this, path, value) + type(ncdf_value), pointer :: this, p + character(len=*), optional :: path + logical :: value + + + nullify(p) + + if(present(path)) then + call ncdf_get_by_path(this=this, path=path, p=p) + else + p => this + end if + + if(.not.associated(p)) then + print *, "Unable to resolve path: ", path + return + end if + + + if(p % value_type == TYPE_INTEGER) then + value = (p % value_integer > 0) + else if (p % value_type == TYPE_LOGICAL) then + value = p % value_logical + else + print *, "Unable to resolve value to real: ", path + call exit(1) + end if + + end subroutine ncdf_get_logical + + ! + ! GET CHARS + ! + subroutine ncdf_get_chars(this, path, value) + type(ncdf_value), pointer :: this, p + character(len=*), optional :: path + character(len=*) :: value + + nullify(p) + + if(present(path)) then + call ncdf_get_by_path(this=this, path=path, p=p) + else + p => this + end if + + if(.not.associated(p)) then + print *, "Unable to resolve path: ", path + return + end if + + + if(p % value_type == TYPE_STRING) then + call ncdf_string_copy(p % value_string, value) + else + print *, "Unable to resolve value to characters: ", path + call exit(1) + end if + + end subroutine ncdf_get_chars + + ! + ! GET ARRAY 1D + ! + + subroutine ncdf_get_array_1d(this, path, array_callback) + type(ncdf_value), pointer :: this + character(len = *), optional :: path + procedure(ncdf_array_callback_1d) :: array_callback + + type(ncdf_value), pointer :: p, element + integer :: index, count + + nullify(p) + + ! resolve the path to the value + if(present(path)) then + call ncdf_get_by_path(this=this, path=path, p=p) + else + p => this + end if + + if(.not.associated(p)) then + print *, "Unable to resolve path: ", path + return + end if + + if(p % value_type == TYPE_ARRAY) then + count = ncdf_value_count(p) + element => p % children + do index = 1, count + call array_callback(element, index, count) + element => element % next + end do + else + print *, "Resolved value is not an array. ", path + call exit(1) + end if + + if (associated(p)) nullify(p) + + end subroutine ncdf_get_array_1d + +! +! GET ARRAY INTEGER 1D +! + subroutine ncdf_get_array_1d_integer(this, path, arr) + + implicit none + type(ncdf_value), pointer, intent(in) :: this + character(len=*), intent(in), optional :: path + integer, allocatable, intent(out) :: arr(:) + + if (allocated(arr)) deallocate(arr) +#ifdef OLDPGI +#else + call ncdf_get_array_1d(this, path, ncdf_array_callback_1d_integer) +#endif + + contains + + subroutine ncdf_array_callback_1d_integer(element, i, count) + implicit none + type(ncdf_value), pointer, intent(in) :: element + integer, intent(in) :: i, count + if (.not. allocated(arr)) allocate(arr(count)) + call ncdf_path_get(element, "", arr(i)) + end subroutine ncdf_array_callback_1d_integer + + end subroutine ncdf_get_array_1d_integer + +! +! GET ARRAY REAL 1D +! + subroutine ncdf_get_array_1d_real(this, path, arr) + + implicit none + type(ncdf_value), pointer, intent(in) :: this + character(len=*), intent(in), optional :: path + real, allocatable, intent(out) :: arr(:) + + if (allocated(arr)) deallocate(arr) +#ifdef OLDPGI +#else + call ncdf_get_array_1d(this, path, ncdf_array_callback_1d_real) +#endif + + contains + + subroutine ncdf_array_callback_1d_real(element, i, count) + implicit none + type(ncdf_value), pointer, intent(in) :: element + integer, intent(in) :: i, count + if (.not. allocated(arr)) allocate(arr(count)) + call ncdf_path_get(element, "", arr(i)) + end subroutine ncdf_array_callback_1d_real + + end subroutine ncdf_get_array_1d_real + +! +! GET ARRAY DOUBLE 1D +! + subroutine ncdf_get_array_1d_double(this, path, arr) + + implicit none + type(ncdf_value), pointer, intent(in) :: this + character(len=*), intent(in), optional :: path + double precision, allocatable, intent(out) :: arr(:) + + if (allocated(arr)) deallocate(arr) +#ifdef OLDPGI +#else + call ncdf_get_array_1d(this, path, ncdf_array_callback_1d_double) +#endif + + contains + + subroutine ncdf_array_callback_1d_double(element, i, count) + implicit none + type(ncdf_value), pointer, intent(in) :: element + integer, intent(in) :: i, count + if (.not. allocated(arr)) allocate(arr(count)) + call ncdf_path_get(element, "", arr(i)) + end subroutine ncdf_array_callback_1d_double + + end subroutine ncdf_get_array_1d_double + +! +! GET ARRAY LOGICAL 1D +! + subroutine ncdf_get_array_1d_logical(this, path, arr) + + implicit none + type(ncdf_value), pointer, intent(in) :: this + character(len=*), intent(in), optional :: path + logical, allocatable, intent(out) :: arr(:) + + if (allocated(arr)) deallocate(arr) +#ifdef OLDPGI +#else + call ncdf_get_array_1d(this, path, ncdf_array_callback_1d_logical) +#endif + + contains + + subroutine ncdf_array_callback_1d_logical(element, i, count) + implicit none + type(ncdf_value), pointer, intent(in) :: element + integer, intent(in) :: i, count + if (.not. allocated(arr)) allocate(arr(count)) + call ncdf_path_get(element, "", arr(i)) + end subroutine ncdf_array_callback_1d_logical + + end subroutine ncdf_get_array_1d_logical + + ! + ! GET ARRAY 2D + ! + + subroutine ncdf_get_array_2d(this, path, array_callback) + type(ncdf_value), pointer :: this + character(len = *), optional :: path + procedure(ncdf_array_callback_2d) :: array_callback + + type(ncdf_value), pointer :: p, element, item + integer :: i1, i2, count1, count2, c + + nullify(p) + + ! resolve the path to the value + if(present(path)) then + call ncdf_get_by_path(this=this, path=path, p=p) + else + p => this + end if + + if(.not.associated(p)) then + print *, "Unable to resolve path: ", path + return + end if + + if(p % value_type == TYPE_ARRAY) then + count1 = ncdf_value_count(p) + element => p % children + do i1 = 1, count1 + if (element % value_type == TYPE_ARRAY) then + c = ncdf_value_count(element) + if (i1 == 1) then + count2 = c + else if (c /= count2) then + print *, "Resolved value has the wrong number of elements. ", & + path, "[", i1, "]" + call exit(1) + end if + item => element % children + do i2 = 1, count2 + call array_callback(item, i1, i2, count1, count2) + item => item % next + end do + element => element % next + else + print *, "Resolved value is not an array. ", path, "[", i1, "]" + call exit(1) + end if + end do + else + print *, "Resolved value is not an array. ", path + call exit(1) + end if + + if (associated(p)) nullify(p) + + end subroutine ncdf_get_array_2d + +! +! GET ARRAY INTEGER 2D +! + subroutine ncdf_get_array_2d_integer(this, path, arr) + + implicit none + type(ncdf_value), pointer, intent(in) :: this + character(len=*), intent(in), optional :: path + integer, allocatable, intent(out) :: arr(:, :) + + if (allocated(arr)) deallocate(arr) +#ifdef OLDPGI +#else + call ncdf_get_array_2d(this, path, ncdf_array_callback_2d_integer) +#endif + + contains + + subroutine ncdf_array_callback_2d_integer(element, i1, i2, count1, count2) + implicit none + type(ncdf_value), pointer, intent(in) :: element + integer, intent(in) :: i1, i2, count1, count2 + if (.not. allocated(arr)) allocate(arr(count1, count2)) + call ncdf_path_get(element, "", arr(i1, i2)) + end subroutine ncdf_array_callback_2d_integer + + end subroutine ncdf_get_array_2d_integer + +! +! GET ARRAY REAL 2D +! + subroutine ncdf_get_array_2d_real(this, path, arr) + + implicit none + type(ncdf_value), pointer, intent(in) :: this + character(len=*), intent(in), optional :: path + real, allocatable, intent(out) :: arr(:, :) + + if (allocated(arr)) deallocate(arr) +#ifdef OLDPGI +#else + call ncdf_get_array_2d(this, path, ncdf_array_callback_2d_real) +#endif + + contains + + subroutine ncdf_array_callback_2d_real(element, i1, i2, count1, count2) + implicit none + type(ncdf_value), pointer, intent(in) :: element + integer, intent(in) :: i1, i2, count1, count2 + if (.not. allocated(arr)) allocate(arr(count1, count2)) + call ncdf_path_get(element, "", arr(i1, i2)) + end subroutine ncdf_array_callback_2d_real + + end subroutine ncdf_get_array_2d_real + +! +! GET ARRAY DOUBLE 2D +! + subroutine ncdf_get_array_2d_double(this, path, arr) + + implicit none + type(ncdf_value), pointer, intent(in) :: this + character(len=*), intent(in), optional :: path + double precision, allocatable, intent(out) :: arr(:, :) + + if (allocated(arr)) deallocate(arr) +#ifdef OLDPGI +#else + call ncdf_get_array_2d(this, path, ncdf_array_callback_2d_double) +#endif + + contains + + subroutine ncdf_array_callback_2d_double(element, i1, i2, count1, count2) + implicit none + type(ncdf_value), pointer, intent(in) :: element + integer, intent(in) :: i1, i2, count1, count2 + if (.not. allocated(arr)) allocate(arr(count1, count2)) + call ncdf_path_get(element, "", arr(i1, i2)) + end subroutine ncdf_array_callback_2d_double + + end subroutine ncdf_get_array_2d_double + +! +! GET ARRAY LOGICAL 2D +! + subroutine ncdf_get_array_2d_logical(this, path, arr) + + implicit none + type(ncdf_value), pointer, intent(in) :: this + character(len=*), intent(in), optional :: path + logical, allocatable, intent(out) :: arr(:, :) + + if (allocated(arr)) deallocate(arr) +#ifdef OLDPGI +#else + call ncdf_get_array_2d(this, path, ncdf_array_callback_2d_logical) +#endif + + contains + + subroutine ncdf_array_callback_2d_logical(element, i1, i2, count1, count2) + implicit none + type(ncdf_value), pointer, intent(in) :: element + integer, intent(in) :: i1, i2, count1, count2 + if (.not. allocated(arr)) allocate(arr(count1, count2)) + call ncdf_path_get(element, "", arr(i1, i2)) + end subroutine ncdf_array_callback_2d_logical + + end subroutine ncdf_get_array_2d_logical + + +end module ncdf_path_m diff --git a/src/ncdiag/ncdf_string_m.f90 b/src/ncdiag/ncdf_string_m.f90 new file mode 100644 index 000000000..8c6a4e139 --- /dev/null +++ b/src/ncdiag/ncdf_string_m.f90 @@ -0,0 +1,266 @@ +! Copyright (c) 2012 Joseph A. Levin +! +! Permission is hereby granted, free of charge, to any person obtaining a copy of this +! software and associated documentation files (the "Software"), to deal in the Software +! without restriction, including without limitation the rights to use, copy, modify, merge, +! publish, distribute, sublicense, and/or sell copies of the Software, and to permit +! persons to whom the Software is furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in all copies or +! substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, +! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR +! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT +! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +! DEALINGS IN THE SOFTWARE. + +! +! File: string.f95 +! Author: josephalevin +! +! Created on March 7, 2012, 7:40 PM +! + +module ncdf_string_m + + private + + public :: ncdf_string, ncdf_string_create, ncdf_string_destroy, ncdf_ncdf_string_length, ncdf_string_append,& + ncdf_ncdf_string_clear + public :: ncdf_string_equals, ncdf_string_copy + + integer, parameter :: BLOCK_SIZE = 32 + + type ncdf_string + character (len = BLOCK_SIZE) :: chars + integer :: index = 0 + type(ncdf_string), pointer :: next => null() + end type ncdf_string + + interface ncdf_string_append + module procedure ncdf_append_chars, ncdf_append_string + end interface ncdf_string_append + + interface ncdf_string_copy + module procedure ncdf_copy_chars + end interface ncdf_string_copy + + interface ncdf_string_equals + module procedure ncdf_equals_string + end interface ncdf_string_equals + + interface ncdf_ncdf_string_length + module procedure ncdf_string_length + end interface ncdf_ncdf_string_length + +contains + + ! + ! FSON STRING CREATE + ! + function ncdf_string_create(chars) result(new) + character(len=*), optional :: chars + type(ncdf_string), pointer :: new + + nullify(new) + allocate(new) + + ! append chars if available + if(present(chars)) then + call ncdf_append_chars(new, chars) + end if + + end function ncdf_string_create + + ! + ! FSON STRING CREATE + ! + recursive subroutine ncdf_string_destroy(this) + + implicit none + type(ncdf_string), pointer :: this + + if (associated(this)) then + + if(associated(this % next)) then + call ncdf_string_destroy(this % next) + end if + + deallocate(this) + nullify (this) + + end if + + end subroutine ncdf_string_destroy + + ! + ! ALLOCATE BLOCK + ! + subroutine ncdf_allocate_block(this) + + implicit none + type(ncdf_string), pointer :: this + type(ncdf_string), pointer :: new + + if (.not.associated(this % next)) then + nullify(new) + allocate(new) + this % next => new + end if + + end subroutine ncdf_allocate_block + + + ! + ! APPEND_STRING + ! + subroutine ncdf_append_string(str1, str2) + type(ncdf_string), pointer :: str1, str2 + integer length, i + + length = ncdf_string_length(str2) + + do i = 1, length + call ncdf_append_char(str1, ncdf_get_char_at(str2, i)) + end do + + + end subroutine ncdf_append_string + + ! + ! APPEND_CHARS + ! + subroutine ncdf_append_chars(str, c) + type(ncdf_string), pointer :: str + character (len = *), intent(in) :: c + integer length, i + + length = len(c) + + do i = 1, length + call ncdf_append_char(str, c(i:i)) + end do + + + end subroutine ncdf_append_chars + + ! + ! APPEND_CHAR + ! + recursive subroutine ncdf_append_char(str, c) + type(ncdf_string), pointer :: str + character, intent(in) :: c + + if (str % index .GE. BLOCK_SIZE) then + !set down the chain + call ncdf_allocate_block(str) + call ncdf_append_char(str % next, c) + + else + ! set local + str % index = str % index + 1 + str % chars(str % index:str % index) = c + end if + + end subroutine ncdf_append_char + + ! + ! COPY CHARS + ! + subroutine ncdf_copy_chars(this, to) + type(ncdf_string), pointer :: this + character(len = *), intent(inout) :: to + integer :: length + + length = min(ncdf_string_length(this), len(to)) + + do i = 1, length + to(i:i) = ncdf_get_char_at(this, i) + end do + + ! pad with nothing + do i = length + 1, len(to) + to(i:i) = "" + end do + + + end subroutine ncdf_copy_chars + + + + ! + ! CLEAR + ! + recursive subroutine ncdf_string_clear(this) + type(ncdf_string), pointer :: this + + if (associated(this % next)) then + call ncdf_string_clear(this % next) + deallocate(this % next) + nullify (this % next) + end if + + this % index = 0 + + end subroutine ncdf_string_clear + + ! + ! SIZE + ! + recursive integer function ncdf_string_length(str) result(count) + type(ncdf_string), pointer :: str + + count = str % index + + if (str % index == BLOCK_SIZE .AND. associated(str % next)) then + count = count + ncdf_string_length(str % next) + end if + + end function ncdf_string_length + + + ! + ! GET CHAR AT + ! + recursive character function ncdf_get_char_at(this, i) result(c) + type(ncdf_string), pointer :: this + integer, intent(in) :: i + + if (i .LE. this % index) then + c = this % chars(i:i) + else + c = ncdf_get_char_at(this % next, i - this % index) + end if + + end function ncdf_get_char_at + + ! + ! EQUALS STRING + ! + logical function ncdf_equals_string(this, other) result(equals) + type(ncdf_string), pointer :: this, other + integer :: i + equals = .false. + + if(ncdf_ncdf_string_length(this) .ne. ncdf_ncdf_string_length(other)) then + equals = .false. + return + else if(ncdf_ncdf_string_length(this) == 0) then + equals = .true. + return + end if + + do i=1, ncdf_string_length(this) + if(ncdf_get_char_at(this, i) .ne. ncdf_get_char_at(other, i)) then + equals = .false. + return + end if + end do + + equals = .true. + + end function ncdf_equals_string + +end module ncdf_string_m diff --git a/src/ncdiag/ncdf_value_m.f90 b/src/ncdiag/ncdf_value_m.f90 new file mode 100644 index 000000000..2277008f0 --- /dev/null +++ b/src/ncdiag/ncdf_value_m.f90 @@ -0,0 +1,313 @@ +! Copyright (c) 2012 Joseph A. Levin +! +! Permission is hereby granted, free of charge, to any person obtaining a copy of this +! software and associated documentation files (the "Software"), to deal in the Software +! without restriction, including without limitation the rights to use, copy, modify, merge, +! publish, distribute, sublicense, and/or sell copies of the Software, and to permit +! persons to whom the Software is furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in all copies or +! substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, +! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR +! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT +! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +! DEALINGS IN THE SOFTWARE. + +! +! File: value_m.f95 +! Author: josephalevin +! +! Created on March 7, 2012, 10:14 PM +! + +module ncdf_value_m + + use ncdf_string_m + + implicit none + + private + + public :: ncdf_value, ncdf_value_create, & + ncdf_value_destroy, ncdf_value_add, & + ncdf_value_get, ncdf_value_count, & + ncdf_value_print + + !constants for the value types + integer, public, parameter :: TYPE_UNKNOWN = -1 + integer, public, parameter :: TYPE_NULL = 0 + integer, public, parameter :: TYPE_OBJECT = 1 + integer, public, parameter :: TYPE_ARRAY = 2 + integer, public, parameter :: TYPE_STRING = 3 + integer, public, parameter :: TYPE_INTEGER = 4 + integer, public, parameter :: TYPE_REAL = 5 + integer, public, parameter :: TYPE_LOGICAL = 6 + + + ! + ! FSON VALUE + ! + type ncdf_value + type(ncdf_string), pointer :: name => null() + integer :: value_type = TYPE_UNKNOWN + logical :: value_logical + integer :: value_integer + real :: value_real + double precision :: value_double + integer, private :: count = 0 + type(ncdf_string), pointer :: value_string => null() + type(ncdf_value), pointer :: next => null() + type(ncdf_value), pointer :: parent => null() + type(ncdf_value), pointer :: children => null() + type(ncdf_value), pointer :: tail => null() + end type ncdf_value + + ! + ! FSON VALUE GET + ! + ! Use either a 1 based index or member name to get the value. + interface ncdf_value_get + module procedure ncdf_get_by_index + module procedure ncdf_get_by_name_chars + module procedure ncdf_get_by_name_string + end interface ncdf_value_get + +contains + + ! + ! FSON VALUE CREATE + ! + function ncdf_value_create() result(new) + type(ncdf_value), pointer :: new + + nullify(new) + allocate(new) + + end function ncdf_value_create + + ! + ! FSON VALUE DESTROY + ! + recursive subroutine ncdf_value_destroy(this, destroy_next) + + implicit none + type(ncdf_value), pointer :: this + logical, intent(in), optional :: destroy_next + + type(ncdf_value), pointer :: p + integer :: count + logical :: donext + + if (present(destroy_next)) then + donext = destroy_next + else + donext = .true. + end if + + if (associated(this)) then + + if(associated(this % name)) then + call ncdf_string_destroy(this % name) + nullify (this % name) + end if + + if(associated(this % value_string)) then + call ncdf_string_destroy(this % value_string) + nullify (this % value_string) + end if + + if(associated(this % children)) then + do while (this % count > 0) + p => this % children + this % children => this % children % next + this % count = this % count - 1 + call ncdf_value_destroy(p, .false.) + end do + nullify(this % children) + end if + + if ((associated(this % next)) .and. (donext)) then + call ncdf_value_destroy(this % next) + nullify (this % next) + end if + + if(associated(this % tail)) then + nullify (this % tail) + end if + + deallocate(this) + nullify(this) + + end if + + end subroutine ncdf_value_destroy + + ! + ! FSON VALUE ADD + ! + ! Adds the member to the linked list + + subroutine ncdf_value_add(this, member) + + implicit none + type(ncdf_value), pointer :: this, member + + ! associate the parent + member % parent => this + + ! add to linked list + if (associated(this % children)) then + this % tail % next => member + else + this % children => member + end if + + this % tail => member + this % count = this % count + 1 + + end subroutine ncdf_value_add + + ! + ! FSON_VALUE_COUNT + ! + integer function ncdf_value_count(this) result(count) + type(ncdf_value), pointer :: this, p + + count = this % count + + end function + + ! + ! GET BY INDEX + ! + function ncdf_get_by_index(this, index) result(p) + type(ncdf_value), pointer :: this, p + integer, intent(in) :: index + integer :: i + + p => this % children + + do i = 1, index - 1 + p => p % next + end do + + end function ncdf_get_by_index + + ! + ! GET BY NAME CHARS + ! + function ncdf_get_by_name_chars(this, name) result(p) + type(ncdf_value), pointer :: this, p + character(len=*), intent(in) :: name + + type(ncdf_string), pointer :: string + + ! convert the char array into a string + string => ncdf_string_create(name) + + p => ncdf_get_by_name_string(this, string) + + call ncdf_string_destroy(string) + + end function ncdf_get_by_name_chars + + ! + ! GET BY NAME STRING + ! + function ncdf_get_by_name_string(this, name) result(p) + type(ncdf_value), pointer :: this, p + type(ncdf_string), pointer :: name + integer :: i + + if(this % value_type .ne. TYPE_OBJECT) then + nullify(p) + return + end if + + do i=1, ncdf_value_count(this) + p => ncdf_value_get(this, i) + if (ncdf_string_equals(p%name, name)) then + return + end if + end do + + ! didn't find anything + nullify(p) + + + end function ncdf_get_by_name_string + + ! + ! FSON VALUE PRINT + ! + recursive subroutine ncdf_value_print(this, indent) + type(ncdf_value), pointer :: this, element + integer, optional, intent(in) :: indent + character (len = 1024) :: tmp_chars + integer :: tab, i, count, spaces + + if (present(indent)) then + tab = indent + else + tab = 0 + end if + + spaces = tab * 2 + + select case (this % value_type) + case(TYPE_OBJECT) + print *, repeat(" ", spaces), "{" + count = ncdf_value_count(this) + do i = 1, count + ! get the element + element => ncdf_value_get(this, i) + ! get the name + call ncdf_string_copy(element % name, tmp_chars) + ! print the name + print *, repeat(" ", spaces), '"', trim(tmp_chars), '":' + ! recursive print of the element + call ncdf_value_print(element, tab + 1) + ! print the separator if required + if (i < count) then + print *, repeat(" ", spaces), "," + end if + end do + + print *, repeat(" ", spaces), "}" + case (TYPE_ARRAY) + print *, repeat(" ", spaces), "[" + count = ncdf_value_count(this) + do i = 1, count + ! get the element + element => ncdf_value_get(this, i) + ! recursive print of the element + call ncdf_value_print(element, tab + 1) + ! print the separator if required + if (i < count) then + print *, "," + end if + end do + print *, repeat(" ", spaces), "]" + case (TYPE_NULL) + print *, repeat(" ", spaces), "null" + case (TYPE_STRING) + call ncdf_string_copy(this % value_string, tmp_chars) + print *, repeat(" ", spaces), '"', trim(tmp_chars), '"' + case (TYPE_LOGICAL) + if (this % value_logical) then + print *, repeat(" ", spaces), "true" + else + print *, repeat(" ", spaces), "false" + end if + case (TYPE_INTEGER) + print *, repeat(" ", spaces), this % value_integer + case (TYPE_REAL) + print *, repeat(" ", spaces), this % value_double + end select + end subroutine ncdf_value_print + + +end module ncdf_value_m diff --git a/src/ncdiag/ncdr_alloc_assert.f90 b/src/ncdiag/ncdr_alloc_assert.f90 new file mode 100644 index 000000000..cbe58d4f6 --- /dev/null +++ b/src/ncdiag/ncdr_alloc_assert.f90 @@ -0,0 +1,497 @@ +module ncdr_alloc_assert + ! Allocate if things aren't allocated, or assert that things are + ! all good to go. + ! + ! Other parts include just assertion functions (e.g. asserting + ! that a variable exists). + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + use ncdr_state, only: ncdr_files, current_ncdr_id + use ncdr_climsg, only: ncdr_error + use ncdr_check, only: ncdr_nc_check, ncdr_check_ncdr_id, & + ncdr_check_current_ncdr_id + use netcdf, only: nf90_inquire_attribute, NF90_GLOBAL, NF90_BYTE, & + NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE, NF90_CHAR + + implicit none + + interface nc_diag_read_assert_var + module procedure nc_diag_read_id_assert_var, & + nc_diag_read_noid_assert_var + end interface nc_diag_read_assert_var + + interface nc_diag_read_assert_attr + module procedure nc_diag_read_id_assert_attr, & + nc_diag_read_noid_assert_attr + end interface nc_diag_read_assert_attr + + interface nc_diag_read_assert_global_attr + module procedure nc_diag_read_id_assert_global_attr, & + nc_diag_read_noid_assert_global_attr + end interface nc_diag_read_assert_global_attr + + interface nc_diag_read_assert_dims + ! Note that nc_diag_read_assert_dims_alloc_string is seperate + ! since it is rare and conflicts with the non-alloc def. + module procedure & + nc_diag_read_assert_dims_single_byte, & + nc_diag_read_assert_dims_single_short, & + nc_diag_read_assert_dims_single_long, & + nc_diag_read_assert_dims_single_float, & + nc_diag_read_assert_dims_single_double, & + nc_diag_read_assert_dims_string, & + nc_diag_read_assert_dims_1d_byte, & + nc_diag_read_assert_dims_1d_short, & + nc_diag_read_assert_dims_1d_long, & + nc_diag_read_assert_dims_1d_float, & + nc_diag_read_assert_dims_1d_double, & + nc_diag_read_assert_dims_1d_string, & + nc_diag_read_assert_dims_2d_byte, & + nc_diag_read_assert_dims_2d_short, & + nc_diag_read_assert_dims_2d_long, & + nc_diag_read_assert_dims_2d_float, & + nc_diag_read_assert_dims_2d_double, & + nc_diag_read_assert_dims_2d_string + end interface nc_diag_read_assert_dims + + contains + function nc_diag_read_id_assert_var(file_ncdr_id, var_name) result(var_index) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + + integer(i_long) :: var_index + + call ncdr_check_ncdr_id(file_ncdr_id) + + do var_index = 1, ncdr_files(file_ncdr_id)%nvars + if (ncdr_files(file_ncdr_id)%vars(var_index)%var_name == var_name) & + return + end do + + ! If we didn't find anything, show an error! + call ncdr_error("The specified variable '" // var_name // "' does not exist!") + end function nc_diag_read_id_assert_var + + function nc_diag_read_noid_assert_var(var_name) result(var_index) + character(len=*), intent(in) :: var_name + + integer(i_long) :: var_index + + call ncdr_check_current_ncdr_id + + var_index = nc_diag_read_id_assert_var(current_ncdr_id, var_name) + end function nc_diag_read_noid_assert_var + + subroutine nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_type + integer(i_long), intent(out) :: attr_len + + integer(i_long) :: var_id + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_id = ncdr_files(file_ncdr_id)%vars( & + nc_diag_read_assert_var(file_ncdr_id, var_name) )%var_id + + call ncdr_nc_check(nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + var_id, & + attr_name, attr_type, attr_len)) + end subroutine nc_diag_read_id_assert_attr + + subroutine nc_diag_read_noid_assert_attr(var_name, attr_name, attr_type, attr_len) + character(*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_type + integer(i_long), intent(out) :: attr_len + + call ncdr_check_current_ncdr_id + + call nc_diag_read_id_assert_attr(current_ncdr_id, var_name, attr_name, attr_type, attr_len) + end subroutine nc_diag_read_noid_assert_attr + + subroutine nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_type + integer(i_long), intent(out) :: attr_len + + call ncdr_check_ncdr_id(file_ncdr_id) + + call ncdr_nc_check(nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + NF90_GLOBAL, & + attr_name, attr_type, attr_len)) + end subroutine nc_diag_read_id_assert_global_attr + + subroutine nc_diag_read_noid_assert_global_attr(attr_name, attr_type, attr_len) + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_type + integer(i_long), intent(out) :: attr_len + + call ncdr_check_current_ncdr_id + + call nc_diag_read_id_assert_global_attr(current_ncdr_id, attr_name, attr_type, attr_len) + end subroutine nc_diag_read_noid_assert_global_attr + + subroutine nc_diag_read_assert_var_type(var_type, correct_var_type) + integer(i_long) :: var_type + integer(i_long) :: correct_var_type + + if (var_type /= correct_var_type) & + call ncdr_error("Mismatched type for variable! Got " // & + nc_diag_read_get_type_str(var_type) // & + " when " // & + nc_diag_read_get_type_str(correct_var_type) // & + " was expected for the variable!") + end subroutine nc_diag_read_assert_var_type + + subroutine nc_diag_read_assert_attr_type(attr_type, correct_attr_type) + integer(i_long) :: attr_type + integer(i_long) :: correct_attr_type + + if (attr_type /= correct_attr_type) & + call ncdr_error("Mismatched type for attribute! Got " // & + nc_diag_read_get_type_str(attr_type) // & + " when " // & + nc_diag_read_get_type_str(correct_attr_type) // & + " was expected for the attribute!") + end subroutine nc_diag_read_assert_attr_type + + subroutine nc_diag_read_assert_global_attr_type(attr_type, correct_attr_type) + integer(i_long) :: attr_type + integer(i_long) :: correct_attr_type + + if (attr_type /= correct_attr_type) & + call ncdr_error("Mismatched type for global attribute! Got " // & + nc_diag_read_get_type_str(attr_type) // & + " when " // & + nc_diag_read_get_type_str(correct_attr_type) // & + " was expected for the global attribute!") + end subroutine nc_diag_read_assert_global_attr_type + + function nc_diag_read_get_type_str(var_type) result(type_str) + integer(i_long) :: var_type + character(len=:), allocatable :: type_str + + if (var_type == NF90_BYTE) then + type_str = "NF90_BYTE" + else if (var_type == NF90_SHORT) then + type_str = "NF90_SHORT" + else if (var_type == NF90_INT) then + type_str = "NF90_INT" + else if (var_type == NF90_FLOAT) then + type_str = "NF90_FLOAT" + else if (var_type == NF90_DOUBLE) then + type_str = "NF90_DOUBLE" + else if (var_type == NF90_CHAR) then + type_str = "NF90_CHAR" + else if (var_type == 12) then + type_str = "NF90_STRING (not supported)" + else + type_str = "(unknown type)" + end if + end function nc_diag_read_get_type_str + + subroutine nc_diag_read_assert_var_ndims(var_ndims, correct_var_ndims) + integer(i_long) :: var_ndims + integer(i_long) :: correct_var_ndims + + if (var_ndims /= correct_var_ndims) & + call ncdr_error("Mismatched dimensions for variable!") + end subroutine nc_diag_read_assert_var_ndims + + !------------------------------------------------------------- + ! Variable allocation and assertion subroutines + !------------------------------------------------------------- + subroutine nc_diag_read_assert_dims_string(var_stor, correct_dims) + character(len=*), intent(in) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (len(var_stor) < correct_dims(1)) & + call ncdr_error("Mismatched dimensions for variable storage!") + end subroutine nc_diag_read_assert_dims_string + + subroutine nc_diag_read_assert_dims_single_byte(var_stor, correct_dims) + integer(i_byte), intent(in) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (correct_dims(1) /= 1) & + call ncdr_error("Mismatched dimensions for variable storage!") + end subroutine nc_diag_read_assert_dims_single_byte + + subroutine nc_diag_read_assert_dims_single_short(var_stor, correct_dims) + integer(i_short), intent(in) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (correct_dims(1) /= 1) & + call ncdr_error("Mismatched dimensions for variable storage!") + end subroutine nc_diag_read_assert_dims_single_short + + subroutine nc_diag_read_assert_dims_single_long(var_stor, correct_dims) + integer(i_long), intent(in) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (correct_dims(1) /= 1) & + call ncdr_error("Mismatched dimensions for variable storage!") + end subroutine nc_diag_read_assert_dims_single_long + + subroutine nc_diag_read_assert_dims_single_float(var_stor, correct_dims) + real(r_single) , intent(in) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (correct_dims(1) /= 1) & + call ncdr_error("Mismatched dimensions for variable storage!") + end subroutine nc_diag_read_assert_dims_single_float + + subroutine nc_diag_read_assert_dims_single_double(var_stor, correct_dims) + real(r_double) , intent(in) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (correct_dims(1) /= 1) & + call ncdr_error("Mismatched dimensions for variable storage!") + end subroutine nc_diag_read_assert_dims_single_double + + subroutine nc_diag_read_assert_dims_alloc_string(var_stor, correct_dims) + character(len=:),allocatable,intent(inout) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (len(var_stor) /= correct_dims(1)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(character(len=correct_dims(1)) :: var_stor) + end if + end subroutine nc_diag_read_assert_dims_alloc_string + + subroutine nc_diag_read_assert_dims_1d_byte(var_stor, correct_dims) + integer(i_byte),dimension(:),allocatable,intent(inout) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1))) + end if + end subroutine nc_diag_read_assert_dims_1d_byte + + subroutine nc_diag_read_assert_dims_1d_short(var_stor, correct_dims) + integer(i_short),dimension(:),allocatable,intent(inout) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1))) + end if + end subroutine nc_diag_read_assert_dims_1d_short + + subroutine nc_diag_read_assert_dims_1d_long(var_stor, correct_dims) + integer(i_long),dimension(:),allocatable,intent(inout) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1))) + end if + end subroutine nc_diag_read_assert_dims_1d_long + + subroutine nc_diag_read_assert_dims_1d_float(var_stor, correct_dims) + real(r_single),dimension(:),allocatable,intent(inout) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1))) + end if + end subroutine nc_diag_read_assert_dims_1d_float + + subroutine nc_diag_read_assert_dims_1d_double(var_stor, correct_dims) + real(r_double),dimension(:),allocatable,intent(inout) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 1 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1))) + end if + end subroutine nc_diag_read_assert_dims_1d_double + + subroutine nc_diag_read_assert_dims_1d_string(var_stor, correct_dims) + character(len=:),dimension(:),allocatable,intent(inout) :: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 2 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (len(var_stor) /= correct_dims(1)) & + call ncdr_error("Mismatched dimensions for variable storage!") + if (size(var_stor) /= correct_dims(2)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(character(len=correct_dims(1)) :: var_stor(correct_dims(2))) + end if + end subroutine nc_diag_read_assert_dims_1d_string + + subroutine nc_diag_read_assert_dims_2d_byte(var_stor, correct_dims) + integer(i_byte),dimension(:,:),allocatable,intent(inout):: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 2 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1), correct_dims(2))) + end if + end subroutine nc_diag_read_assert_dims_2d_byte + + subroutine nc_diag_read_assert_dims_2d_short(var_stor, correct_dims) + integer(i_short),dimension(:,:),allocatable,intent(inout):: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 2 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1), correct_dims(2))) + end if + end subroutine nc_diag_read_assert_dims_2d_short + + subroutine nc_diag_read_assert_dims_2d_long(var_stor, correct_dims) + integer(i_long),dimension(:,:),allocatable,intent(inout):: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 2 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1), correct_dims(2))) + end if + end subroutine nc_diag_read_assert_dims_2d_long + + subroutine nc_diag_read_assert_dims_2d_float(var_stor, correct_dims) + real(r_single),dimension(:,:),allocatable,intent(inout):: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 2 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1), correct_dims(2))) + end if + end subroutine nc_diag_read_assert_dims_2d_float + + subroutine nc_diag_read_assert_dims_2d_double(var_stor, correct_dims) + real(r_double),dimension(:,:),allocatable,intent(inout):: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 2 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (any(shape(var_stor) /= correct_dims)) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(var_stor(correct_dims(1), correct_dims(2))) + end if + end subroutine nc_diag_read_assert_dims_2d_double + + subroutine nc_diag_read_assert_dims_2d_string(var_stor, correct_dims) + character(len=:),dimension(:,:),allocatable,intent(inout):: var_stor + integer(i_long), dimension(:), intent(in) :: correct_dims + integer(i_long), parameter :: correct_ndims = 3 + + ! If allocated, make sure the dimensions are correct. + ! If not, go ahead and allocate it ourselves. + if (allocated(var_stor)) then + if (size(correct_dims) /= correct_ndims) & + call ncdr_error("Invalid number of dimensions for variable!") + if (len(var_stor) /= correct_dims(1)) & + call ncdr_error("Mismatched dimensions for variable storage!") + if (any(shape(var_stor) /= correct_dims(2:3))) & + call ncdr_error("Mismatched dimensions for variable storage!") + else + allocate(character(len=correct_dims(1)) :: var_stor(correct_dims(2), correct_dims(3))) + end if + end subroutine nc_diag_read_assert_dims_2d_string +end module ncdr_alloc_assert diff --git a/src/ncdiag/ncdr_attrs.f90 b/src/ncdiag/ncdr_attrs.f90 new file mode 100644 index 000000000..f38ea872c --- /dev/null +++ b/src/ncdiag/ncdr_attrs.f90 @@ -0,0 +1,228 @@ +module ncdr_attrs + use ncd_kinds, only: i_long + use ncdr_state, only: ncdr_files, current_ncdr_id + use ncdr_climsg, only: ncdr_error + use ncdr_check, only: ncdr_nc_check, ncdr_check_ncdr_id, & + ncdr_check_current_ncdr_id + use ncdr_alloc_assert, only: nc_diag_read_assert_var + use netcdf, only: nf90_inquire_attribute, nf90_inquire_variable, & + nf90_inq_attname, NF90_ENOTATT, NF90_NOERR, NF90_MAX_NAME + + implicit none + + interface nc_diag_read_check_attr + module procedure nc_diag_read_id_check_attr, & + nc_diag_read_noid_check_attr + end interface nc_diag_read_check_attr + + interface nc_diag_read_get_attr_type + module procedure nc_diag_read_id_get_attr_type, & + nc_diag_read_noid_get_attr_type + end interface nc_diag_read_get_attr_type + + interface nc_diag_read_ret_attr_len + module procedure nc_diag_read_id_ret_attr_len, & + nc_diag_read_noid_ret_attr_len + end interface nc_diag_read_ret_attr_len + + interface nc_diag_read_get_attr_len + module procedure nc_diag_read_id_get_attr_len, & + nc_diag_read_noid_get_attr_len + end interface nc_diag_read_get_attr_len + + interface nc_diag_read_get_attr_names + module procedure nc_diag_read_id_get_attr_names, & + nc_diag_read_noid_get_attr_names + end interface nc_diag_read_get_attr_names + + contains + function nc_diag_read_id_check_attr(file_ncdr_id, var_name, attr_name) result(attr_exists) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + + integer(i_long) :: var_id, nc_err + + logical :: attr_exists + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_id = ncdr_files(file_ncdr_id)%vars( & + nc_diag_read_assert_var(file_ncdr_id, var_name) )%var_id + + nc_err = nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + var_id, attr_name) + + ! If attribute doesn't exist, return false. + if (nc_err == NF90_ENOTATT) then + attr_exists = .FALSE. + return + end if + + ! Sanity check - could be another error! + if (nc_err /= NF90_NOERR) then + call ncdr_nc_check(nc_err) + end if + + attr_exists = .TRUE. + end function nc_diag_read_id_check_attr + + function nc_diag_read_noid_check_attr(var_name, attr_name) result(attr_exists) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + + logical :: attr_exists + + call ncdr_check_current_ncdr_id + + attr_exists = nc_diag_read_id_check_attr(current_ncdr_id, var_name, attr_name) + end function nc_diag_read_noid_check_attr + + function nc_diag_read_id_get_attr_type(file_ncdr_id, var_name, attr_name) result(attr_type) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + + integer(i_long) :: var_id, attr_type + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_id = ncdr_files(file_ncdr_id)%vars( & + nc_diag_read_assert_var(file_ncdr_id, var_name) )%var_id + + call ncdr_nc_check(nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + var_id, attr_name, attr_type)) + end function nc_diag_read_id_get_attr_type + + function nc_diag_read_noid_get_attr_type(var_name, attr_name) result(attr_type) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + + integer(i_long) :: attr_type + + call ncdr_check_current_ncdr_id + + attr_type = nc_diag_read_id_get_attr_type(current_ncdr_id, var_name, attr_name) + end function nc_diag_read_noid_get_attr_type + + function nc_diag_read_id_ret_attr_len(file_ncdr_id, var_name, attr_name) result(attr_len) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + + integer(i_long) :: var_id + integer(i_long) :: attr_len + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_id = ncdr_files(file_ncdr_id)%vars( & + nc_diag_read_assert_var(file_ncdr_id, var_name) )%var_id + + call ncdr_nc_check(nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + var_id, attr_name, len = attr_len)) + end function nc_diag_read_id_ret_attr_len + + function nc_diag_read_noid_ret_attr_len(var_name, attr_name) result(attr_len) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long) :: attr_len + + call ncdr_check_current_ncdr_id + + attr_len = nc_diag_read_id_ret_attr_len(current_ncdr_id, var_name, attr_name) + end function nc_diag_read_noid_ret_attr_len + + subroutine nc_diag_read_id_get_attr_len(file_ncdr_id, var_name, attr_name, attr_len) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_len + + integer(i_long) :: var_id + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_id = ncdr_files(file_ncdr_id)%vars( & + nc_diag_read_assert_var(file_ncdr_id, var_name) )%var_id + + call ncdr_nc_check(nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + var_id, attr_name, len = attr_len)) + end subroutine nc_diag_read_id_get_attr_len + + subroutine nc_diag_read_noid_get_attr_len(var_name, attr_name, attr_len) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_len + + call ncdr_check_current_ncdr_id + + call nc_diag_read_id_get_attr_len(current_ncdr_id, var_name, attr_name, attr_len) + end subroutine nc_diag_read_noid_get_attr_len + + subroutine nc_diag_read_id_get_attr_names(file_ncdr_id, var_name, num_attrs, attr_name_mlen, attr_names) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + integer(i_long), intent(out), optional :: num_attrs + integer(i_long), intent(out), optional :: attr_name_mlen + character(len=:), intent(inout), dimension(:), allocatable, optional:: attr_names + + integer(i_long) :: var_id, nattrs, attr_index, max_attr_name_len + + character(len=NF90_MAX_NAME) :: attr_name + + max_attr_name_len = 0 + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_id = ncdr_files(file_ncdr_id)%vars( & + nc_diag_read_assert_var(file_ncdr_id, var_name) )%var_id + call ncdr_nc_check(nf90_inquire_variable(ncdr_files(file_ncdr_id)%ncid, & + var_id, nAtts = nattrs)) + + if (present(num_attrs)) & + num_attrs = nattrs + + ! Figure out character max length + do attr_index = 1, nattrs + call ncdr_nc_check(nf90_inq_attname(ncdr_files(file_ncdr_id)%ncid, & + var_id, & + attr_index, & + attr_name)) + + if (len_trim(attr_name) > max_attr_name_len) & + max_attr_name_len = len_trim(attr_name) + end do + + if (present(attr_name_mlen)) & + attr_name_mlen = max_attr_name_len + + if (present(attr_names)) then + if (.NOT. allocated(attr_names)) then + allocate(character(max_attr_name_len) :: attr_names(nattrs)) + else + if (size(attr_names) /= nattrs) & + call ncdr_error("Invalid allocated array size for attribute names storage!") + if (len(attr_names) < max_attr_name_len) & + call ncdr_error("Invalid allocated array size for attribute names storage! (String length does not match!)") + end if + + do attr_index = 1, nattrs + call ncdr_nc_check(nf90_inq_attname(ncdr_files(file_ncdr_id)%ncid, & + var_id, & + attr_index, & + attr_names(attr_index))) + end do + end if + end subroutine nc_diag_read_id_get_attr_names + + subroutine nc_diag_read_noid_get_attr_names(var_name, num_attrs, attr_name_mlen, attr_names) + character(len=*), intent(in) :: var_name + integer(i_long), intent(out), optional :: num_attrs + integer(i_long), intent(out), optional :: attr_name_mlen + character(len=:), intent(inout), dimension(:), allocatable, optional:: attr_names + + call ncdr_check_current_ncdr_id + + call nc_diag_read_id_get_attr_names(current_ncdr_id, var_name, num_attrs, attr_name_mlen, attr_names) + end subroutine nc_diag_read_noid_get_attr_names +end module ncdr_attrs diff --git a/src/ncdiag/ncdr_attrs_fetch.f90 b/src/ncdiag/ncdr_attrs_fetch.f90 new file mode 100644 index 000000000..96db7a2aa --- /dev/null +++ b/src/ncdiag/ncdr_attrs_fetch.f90 @@ -0,0 +1,462 @@ +module ncdr_attrs_fetch + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + use ncdr_state, only: ncdr_files, current_ncdr_id + use ncdr_check, only: ncdr_nc_check, ncdr_check_ncdr_id, & + ncdr_check_current_ncdr_id, ncdr_check_ncid + use ncdr_alloc_assert, only: nc_diag_read_id_assert_var, & + nc_diag_read_id_assert_attr, nc_diag_read_assert_attr_type, & + nc_diag_read_assert_dims, nc_diag_read_assert_dims_alloc_string + use netcdf, only: nf90_get_att, NF90_BYTE, NF90_SHORT, NF90_INT, & + NF90_FLOAT, NF90_DOUBLE, NF90_CHAR + + implicit none + + interface nc_diag_read_get_attr + ! Note that nc_diag_read_(no)id_get_attr_1d_string is not + ! included due to rare use + conflict with single_string. + module procedure & + nc_diag_read_id_get_attr_single_byte, & + nc_diag_read_id_get_attr_single_short, & + nc_diag_read_id_get_attr_single_long, & + nc_diag_read_id_get_attr_single_float, & + nc_diag_read_id_get_attr_single_double, & + nc_diag_read_id_get_attr_single_string, & + nc_diag_read_noid_get_attr_single_byte, & + nc_diag_read_noid_get_attr_single_short, & + nc_diag_read_noid_get_attr_single_long, & + nc_diag_read_noid_get_attr_single_float, & + nc_diag_read_noid_get_attr_single_double, & + nc_diag_read_noid_get_attr_single_string, & + nc_diag_read_id_get_attr_1d_byte, & + nc_diag_read_id_get_attr_1d_short, & + nc_diag_read_id_get_attr_1d_long, & + nc_diag_read_id_get_attr_1d_float, & + nc_diag_read_id_get_attr_1d_double, & + nc_diag_read_noid_get_attr_1d_byte, & + nc_diag_read_noid_get_attr_1d_short, & + nc_diag_read_noid_get_attr_1d_long, & + nc_diag_read_noid_get_attr_1d_float, & + nc_diag_read_noid_get_attr_1d_double + end interface nc_diag_read_get_attr + + contains + subroutine nc_diag_read_id_get_attr_single_byte(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_byte), intent(out) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncdr_id(file_ncdr_id) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_BYTE) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_single_byte + + subroutine nc_diag_read_noid_get_attr_single_byte(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_byte), intent(out) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_single_byte(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_single_byte + + subroutine nc_diag_read_id_get_attr_single_short(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_short), intent(out) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_SHORT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_single_short + + subroutine nc_diag_read_noid_get_attr_single_short(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_short), intent(out) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_single_short(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_single_short + + subroutine nc_diag_read_id_get_attr_single_long(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_INT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_single_long + + subroutine nc_diag_read_noid_get_attr_single_long(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_single_long(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_single_long + + subroutine nc_diag_read_id_get_attr_single_float(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_single), intent(out) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_FLOAT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_single_float + + subroutine nc_diag_read_noid_get_attr_single_float(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_single), intent(out) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_single_float(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_single_float + + subroutine nc_diag_read_id_get_attr_single_double(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_double), intent(out) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_DOUBLE) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_single_double + + subroutine nc_diag_read_noid_get_attr_single_double(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_double), intent(out) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_single_double(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_single_double + + subroutine nc_diag_read_id_get_attr_single_string(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + character(len=*), intent(out) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_CHAR) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_single_string + + subroutine nc_diag_read_noid_get_attr_single_string(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + character(len=*), intent(out) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_single_string(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_single_string + + subroutine nc_diag_read_id_get_attr_1d_byte(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_byte), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncdr_id(file_ncdr_id) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_BYTE) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_1d_byte + + subroutine nc_diag_read_noid_get_attr_1d_byte(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_byte), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_1d_byte(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_1d_byte + + subroutine nc_diag_read_id_get_attr_1d_short(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_short), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_SHORT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_1d_short + + subroutine nc_diag_read_noid_get_attr_1d_short(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_short), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_1d_short(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_1d_short + + subroutine nc_diag_read_id_get_attr_1d_long(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_INT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_1d_long + + subroutine nc_diag_read_noid_get_attr_1d_long(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_1d_long(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_1d_long + + subroutine nc_diag_read_id_get_attr_1d_float(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_single), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_FLOAT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_1d_float + + subroutine nc_diag_read_noid_get_attr_1d_float(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_single), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_1d_float(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_1d_float + + subroutine nc_diag_read_id_get_attr_1d_double(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_double), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_DOUBLE) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_1d_double + + subroutine nc_diag_read_noid_get_attr_1d_double(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_double), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_1d_double(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_1d_double + + subroutine nc_diag_read_id_get_attr_1d_string(file_ncdr_id, var_name, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + character(len=:),allocatable,intent(inout) :: attr_stor + + integer(i_long) :: var_index, attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + call nc_diag_read_id_assert_attr(file_ncdr_id, var_name, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_attr_type(attr_type, NF90_CHAR) + + call nc_diag_read_assert_dims_alloc_string(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_id, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_attr_1d_string + + subroutine nc_diag_read_noid_get_attr_1d_string(var_name, attr_name, attr_stor) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + character(len=:),allocatable,intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_attr_1d_string(current_ncdr_id, var_name, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_attr_1d_string +end module ncdr_attrs_fetch diff --git a/src/ncdiag/ncdr_check.f90 b/src/ncdiag/ncdr_check.f90 new file mode 100644 index 000000000..c37524fb8 --- /dev/null +++ b/src/ncdiag/ncdr_check.f90 @@ -0,0 +1,91 @@ +module ncdr_check + use ncd_kinds, only: i_long + use ncdr_climsg, only: ncdr_error + use ncdr_state, only: ncdr_files, current_ncdr_id, ncdr_file_count + use netcdf, only: nf90_noerr, nf90_strerror, nf90_inquire, & + nf90_ebadid + + implicit none + + contains + subroutine ncdr_check_ncdr_id(file_ncdr_id) + integer(i_long), intent(in) :: file_ncdr_id + + if (file_ncdr_id > ncdr_file_count) & + call ncdr_error("The specified NCDR ID does not exist and/or is already closed!") + + if (.NOT. ncdr_files(file_ncdr_id)%file_open) & + call ncdr_error("The specified NCDR ID does not exist or is already closed! (Still in DB, but closed!)") + end subroutine ncdr_check_ncdr_id + + subroutine ncdr_check_current_ncdr_id + if (current_ncdr_id == -1) & + call ncdr_error("Current NCDR ID indicates that no files are open.") + call ncdr_check_ncdr_id(current_ncdr_id) + end subroutine ncdr_check_current_ncdr_id + + subroutine ncdr_check_ncid(file_ncid) + integer(i_long), intent(in) :: file_ncid + integer(i_long) :: nc_err + + nc_err = nf90_inquire(file_ncid) + + if (nc_err == NF90_EBADID) & + call ncdr_error("The specified NCID does not exist and/or is already closed!") + + ! General error - something we can't handle! + if (nc_err /= NF90_NOERR) & + call ncdr_nc_check(nc_err) + end subroutine ncdr_check_ncid + + subroutine ncdr_check_current_ncid + call ncdr_check_current_ncdr_id + call ncdr_check_ncid(ncdr_files(current_ncdr_id)%ncid) + end subroutine ncdr_check_current_ncid + + function nc_diag_read_get_index_from_ncid(file_ncid) result(file_ind) + integer(i_long), intent(in) :: file_ncid + integer(i_long) :: i, file_ind + + if (ncdr_file_count == 0) then + file_ind = -1 + return + end if + + do i = 1, ncdr_file_count + if ((file_ncid == ncdr_files(i)%ncid) .AND. (ncdr_files(i)%file_open)) then + file_ind = i + return + end if + end do + + file_ind = -1 + end function nc_diag_read_get_index_from_ncid + + function nc_diag_read_get_index_from_filename(file_name) result(file_ind) + character(len=*), intent(in) :: file_name + integer(i_long) :: i, file_ind + + if (ncdr_file_count == 0) then + file_ind = -1 + return + end if + + do i = 1, ncdr_file_count + if ((file_name == ncdr_files(i)%filename) .AND. (ncdr_files(i)%file_open)) then + file_ind = i + return + end if + end do + + file_ind = -1 + end function nc_diag_read_get_index_from_filename + + subroutine ncdr_nc_check(status) + integer(i_long), intent ( in) :: status + + if(status /= nf90_noerr) then + call ncdr_error(trim(nf90_strerror(status))) + end if + end subroutine ncdr_nc_check +end module ncdr_check diff --git a/src/ncdiag/ncdr_climsg.F90 b/src/ncdiag/ncdr_climsg.F90 new file mode 100644 index 000000000..4eb5c2e73 --- /dev/null +++ b/src/ncdiag/ncdr_climsg.F90 @@ -0,0 +1,56 @@ +module ncdr_climsg + implicit none + + ! NetCDF Diag Reader - CLI Message portion + ! (Declarations) + logical :: ncdr_enable_info = .FALSE. + + contains + ! NetCDF Diag Reader - CLI Message portion + ! (Subroutine/Function implementation) + + subroutine ncdr_error(err) + character(len=*), intent(in) :: err +#ifdef ERROR_TRACEBACK + integer :: div0 +#endif + write(*, "(A)") " ** ERROR: " // err +#ifdef ERROR_TRACEBACK + write(*, "(A)") " ** Failed to read NetCDF4." + write(*, "(A)") " (Traceback requested, triggering div0 error...)" + div0 = 1 / 0 + write(*, "(A)") " Couldn't trigger traceback, ending gracefully." + write(*, "(A)") " (Ensure floating point exceptions are enabled," + write(*, "(A)") " and that you have debugging (-g) and tracebacks" + write(*, "(A)") " compiler flags enabled!)" + stop 1 +#else + write (*, "(A)") " ** Failed to read NetCDF4." + stop 1 +#endif + end subroutine ncdr_error + + subroutine ncdr_warning(warn) + character(len=*), intent(in) :: warn + write(*, "(A)") " ** WARNING: " // warn + end subroutine ncdr_warning + + subroutine ncdr_set_info_display(info_on_off) + logical :: info_on_off + ncdr_enable_info = info_on_off + end subroutine ncdr_set_info_display + + subroutine ncdr_info(ifo) + character(len=*), intent(in) :: ifo + if (ncdr_enable_info) & + write(*, "(A)") " ** INFO: " // ifo + end subroutine ncdr_info + +#ifdef _DEBUG_MEM_ + subroutine ncdr_debug(dbg) + character(len=*), intent(in) :: dbg + write(*, "(A, A)") "D: ", dbg + end subroutine ncdr_debug +#endif + +end module ncdr_climsg diff --git a/src/ncdiag/ncdr_dims.f90 b/src/ncdiag/ncdr_dims.f90 new file mode 100644 index 000000000..c9a66c6e1 --- /dev/null +++ b/src/ncdiag/ncdr_dims.f90 @@ -0,0 +1,298 @@ +module ncdr_dims + use ncd_kinds, only: i_long + use ncdr_state, only: ncdr_files, current_ncdr_id + use ncdr_climsg, only: ncdr_error + use ncdr_check, only: ncdr_nc_check, ncdr_check_ncdr_id, & + ncdr_check_current_ncdr_id + use netcdf, only: nf90_inquire_dimension, NF90_MAX_NAME + use netcdf_unlimdims, only: pf_nf90_inq_unlimdims + + implicit none + + interface nc_diag_read_lookup_dim + module procedure nc_diag_read_id_lookup_dim, & + nc_diag_read_noid_lookup_dim + end interface nc_diag_read_lookup_dim + + interface nc_diag_read_assert_dim + module procedure nc_diag_read_id_assert_dim, & + nc_diag_read_noid_assert_dim + end interface nc_diag_read_assert_dim + + interface nc_diag_read_check_dim + module procedure nc_diag_read_id_check_dim, & + nc_diag_read_noid_check_dim + end interface nc_diag_read_check_dim + + interface nc_diag_read_get_dim + module procedure nc_diag_read_id_get_dim, & + nc_diag_read_noid_get_dim + end interface nc_diag_read_get_dim + + interface nc_diag_read_check_dim_unlim + module procedure nc_diag_read_id_check_dim_unlim, & + nc_diag_read_noid_check_dim_unlim + end interface nc_diag_read_check_dim_unlim + + interface nc_diag_read_get_dim_names + module procedure nc_diag_read_id_get_dim_names + end interface nc_diag_read_get_dim_names + + interface nc_diag_read_noid_get_dim_names + module procedure nc_diag_read_noid_get_dim_names + end interface nc_diag_read_noid_get_dim_names + + contains + subroutine nc_diag_read_parse_file_dims(file_ncid, file_index, num_dims) + integer(i_long), intent(in) :: file_ncid + integer(i_long), intent(in) :: file_index + integer(i_long), intent(in) :: num_dims + + integer(i_long), dimension(:), allocatable :: unlim_dims + integer(i_long) :: num_unlims + integer(i_long) :: i, j + + character(len=NF90_MAX_NAME) :: dim_name + + ncdr_files(file_index)%ndims = num_dims + allocate(ncdr_files(file_index)%dims(num_dims)) + + ! Get unlimited dimension information + call ncdr_nc_check(pf_nf90_inq_unlimdims(file_ncid, num_unlims)) + + allocate(unlim_dims(num_unlims)) + + call ncdr_nc_check(pf_nf90_inq_unlimdims(file_ncid, num_unlims, unlim_dims)) + + do i = 1, num_dims + ncdr_files(file_index)%dims(i)%dim_id = i + + call ncdr_nc_check(nf90_inquire_dimension(file_ncid, i, & + dim_name, & + ncdr_files(file_index)%dims(i)%dim_size)) + + ncdr_files(file_index)%dims(i)%dim_name = trim(dim_name) + ncdr_files(file_index)%dims(i)%dim_unlim = .FALSE. + + do j = 1, num_unlims + if (i == unlim_dims(j)) then + ncdr_files(file_index)%dims(i)%dim_unlim = .TRUE. + exit + end if + end do + end do + end subroutine nc_diag_read_parse_file_dims + + function nc_diag_read_id_lookup_dim(file_ncdr_id, dim_name) result(dim_index) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: dim_name + + integer(i_long) :: dim_index + + call ncdr_check_ncdr_id(file_ncdr_id) + + do dim_index = 1, ncdr_files(file_ncdr_id)%ndims + if (ncdr_files(file_ncdr_id)%dims(dim_index)%dim_name == dim_name) & + return + end do + + ! Otherwise, return -1! + dim_index = -1 + end function nc_diag_read_id_lookup_dim + + function nc_diag_read_noid_lookup_dim(dim_name) result(dim_index) + character(len=*), intent(in) :: dim_name + + integer(i_long) :: dim_index + + call ncdr_check_current_ncdr_id + + dim_index = nc_diag_read_id_lookup_dim(current_ncdr_id, dim_name) + end function nc_diag_read_noid_lookup_dim + + function nc_diag_read_id_assert_dim(file_ncdr_id, dim_name) result(dim_index) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: dim_name + + integer(i_long) :: dim_index + + call ncdr_check_ncdr_id(file_ncdr_id) + + ! Otherwise, return -1! + dim_index = nc_diag_read_id_lookup_dim(file_ncdr_id, dim_name) + + ! ...except don't, since we're asserting! + if (dim_index == -1) & + call ncdr_error("The specified dimension '" // dim_name // "' does not exist!") + end function nc_diag_read_id_assert_dim + + function nc_diag_read_noid_assert_dim(dim_name) result(dim_index) + character(len=*), intent(in) :: dim_name + + integer(i_long) :: dim_index + + call ncdr_check_current_ncdr_id + + dim_index = nc_diag_read_id_assert_dim(current_ncdr_id, dim_name) + end function nc_diag_read_noid_assert_dim + + function nc_diag_read_id_check_dim(file_ncdr_id, dim_name) result(dim_exists) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: dim_name + + logical :: dim_exists + + call ncdr_check_ncdr_id(file_ncdr_id) + + if (nc_diag_read_id_lookup_dim(file_ncdr_id, dim_name) == -1) then + dim_exists = .FALSE. + return + end if + + dim_exists = .TRUE. + end function nc_diag_read_id_check_dim + + function nc_diag_read_noid_check_dim(dim_name) result(dim_exists) + character(len=*), intent(in) :: dim_name + + logical :: dim_exists + + call ncdr_check_current_ncdr_id + + if (nc_diag_read_lookup_dim(dim_name) == -1) then + dim_exists = .FALSE. + return + end if + + dim_exists = .TRUE. + end function nc_diag_read_noid_check_dim + + function nc_diag_read_id_get_dim(file_ncdr_id, dim_name) result(dim_size) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: dim_name + + integer(i_long) :: dim_index, dim_size + + call ncdr_check_ncdr_id(file_ncdr_id) + + dim_index = nc_diag_read_id_assert_dim(file_ncdr_id, dim_name) + + dim_size = ncdr_files(file_ncdr_id)%dims(dim_index)%dim_size + end function nc_diag_read_id_get_dim + + function nc_diag_read_noid_get_dim(dim_name) result(dim_size) + character(len=*), intent(in) :: dim_name + + integer(i_long) :: dim_size + + call ncdr_check_current_ncdr_id + + dim_size = nc_diag_read_id_get_dim(current_ncdr_id, dim_name) + end function nc_diag_read_noid_get_dim + + function nc_diag_read_id_check_dim_unlim(file_ncdr_id, dim_name) result(dim_isunlim) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: dim_name + + integer(i_long) :: dim_index + logical :: dim_isunlim + + call ncdr_check_ncdr_id(file_ncdr_id) + + dim_index = nc_diag_read_id_assert_dim(file_ncdr_id, dim_name) + + dim_isunlim = ncdr_files(file_ncdr_id)%dims(dim_index)%dim_unlim + end function nc_diag_read_id_check_dim_unlim + + function nc_diag_read_noid_check_dim_unlim(dim_name) result(dim_isunlim) + character(len=*), intent(in) :: dim_name + + logical :: dim_isunlim + + call ncdr_check_current_ncdr_id + + dim_isunlim = nc_diag_read_id_check_dim_unlim(current_ncdr_id, dim_name) + end function nc_diag_read_noid_check_dim_unlim + + subroutine nc_diag_read_id_get_dim_names(file_ncdr_id, num_dims, dim_name_mlen, dim_names) + integer(i_long), intent(in) :: file_ncdr_id + integer(i_long), intent(out), optional :: num_dims + integer(i_long), intent(out), optional :: dim_name_mlen + character(len=:), intent(inout), dimension(:), allocatable, optional:: dim_names + + integer(i_long) :: dim_index, ndims, max_dim_name_len + + max_dim_name_len = 0 + + call ncdr_check_ncdr_id(file_ncdr_id) + + ndims = ncdr_files(file_ncdr_id)%ndims + + if (present(num_dims)) & + num_dims = ndims + + ! Figure out character max length + do dim_index = 1, ndims + if (len(ncdr_files(file_ncdr_id)%dims(dim_index)%dim_name) > max_dim_name_len) & + max_dim_name_len = len(ncdr_files(file_ncdr_id)%dims(dim_index)%dim_name) + end do + + if (present(dim_name_mlen)) & + dim_name_mlen = max_dim_name_len + + if (present(dim_names)) then + if (.NOT. allocated(dim_names)) then + allocate(character(max_dim_name_len) :: dim_names(ndims)) + else + if (size(dim_names) /= ndims) & + call ncdr_error("Invalid allocated array size for dimension names storage!") + if (len(dim_names) < max_dim_name_len) & + call ncdr_error("Invalid allocated array size for dimension names storage! (String length does not match!)") + end if + + do dim_index = 1, ndims + dim_names(dim_index) = ncdr_files(file_ncdr_id)%dims(dim_index)%dim_name + end do + end if + end subroutine nc_diag_read_id_get_dim_names + + subroutine nc_diag_read_noid_get_dim_names(num_dims, dim_name_mlen, dim_names) + integer(i_long), intent(out), optional :: num_dims + integer(i_long), intent(out), optional :: dim_name_mlen + character(len=:), intent(inout), dimension(:), allocatable, optional:: dim_names + + call ncdr_check_current_ncdr_id + + if (present(num_dims)) then + if (present(dim_name_mlen)) then + if (present(dim_names)) then + call nc_diag_read_id_get_dim_names(current_ncdr_id, num_dims, dim_name_mlen, dim_names) + else + call nc_diag_read_id_get_dim_names(current_ncdr_id, num_dims, dim_name_mlen) + end if + else + if (present(dim_names)) then + call nc_diag_read_id_get_dim_names(current_ncdr_id, num_dims, dim_names = dim_names) + else + call nc_diag_read_id_get_dim_names(current_ncdr_id, num_dims) + end if + end if + else + if (present(dim_name_mlen)) then + if (present(dim_names)) then + call nc_diag_read_id_get_dim_names(current_ncdr_id, dim_name_mlen = dim_name_mlen, & + dim_names = dim_names) + else + call nc_diag_read_id_get_dim_names(current_ncdr_id, dim_name_mlen = dim_name_mlen) + end if + else + if (present(dim_names)) then + call nc_diag_read_id_get_dim_names(current_ncdr_id, dim_names = dim_names) + else + ! Why would you do this? + call nc_diag_read_id_get_dim_names(current_ncdr_id) + end if + end if + end if + end subroutine nc_diag_read_noid_get_dim_names +end module ncdr_dims diff --git a/src/ncdiag/ncdr_global_attrs.f90 b/src/ncdiag/ncdr_global_attrs.f90 new file mode 100644 index 000000000..00fa045b5 --- /dev/null +++ b/src/ncdiag/ncdr_global_attrs.f90 @@ -0,0 +1,203 @@ +module ncdr_global_attrs + use ncd_kinds, only: i_long + use ncdr_state, only: ncdr_files, current_ncdr_id + use ncdr_climsg, only: ncdr_error + use ncdr_check, only: ncdr_nc_check, ncdr_check_ncdr_id, & + ncdr_check_current_ncdr_id + use netcdf, only: nf90_inquire_attribute, nf90_inquire, & + nf90_inq_attname, NF90_GLOBAL, NF90_MAX_NAME, NF90_ENOTATT, & + NF90_NOERR + + implicit none + + interface nc_diag_read_check_global_attr + module procedure nc_diag_read_id_check_global_attr, & + nc_diag_read_noid_check_global_attr + end interface nc_diag_read_check_global_attr + + interface nc_diag_read_get_global_attr_type + module procedure nc_diag_read_id_get_global_attr_type, & + nc_diag_read_noid_get_global_attr_type + end interface nc_diag_read_get_global_attr_type + + interface nc_diag_read_ret_global_attr_len + module procedure nc_diag_read_id_ret_global_attr_len, & + nc_diag_read_noid_ret_global_attr_len + end interface nc_diag_read_ret_global_attr_len + + interface nc_diag_read_get_global_attr_len + module procedure nc_diag_read_id_get_global_attr_len, & + nc_diag_read_noid_get_global_attr_len + end interface nc_diag_read_get_global_attr_len + + interface nc_diag_read_get_global_attr_names + module procedure nc_diag_read_id_get_global_attr_names + end interface nc_diag_read_get_global_attr_names + + interface nc_diag_read_noid_get_global_attr_names + module procedure nc_diag_read_noid_get_global_attr_names + end interface nc_diag_read_noid_get_global_attr_names + + contains + function nc_diag_read_id_check_global_attr(file_ncdr_id, attr_name) result(attr_exists) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + + integer(i_long) :: nc_err + + logical :: attr_exists + + call ncdr_check_ncdr_id(file_ncdr_id) + + nc_err = nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + NF90_GLOBAL, attr_name) + + ! If attribute doesn't exist, return false. + if (nc_err == NF90_ENOTATT) then + attr_exists = .FALSE. + return + end if + + ! Sanity check - could be another error! + if (nc_err /= NF90_NOERR) then + call ncdr_nc_check(nc_err) + end if + + attr_exists = .TRUE. + end function nc_diag_read_id_check_global_attr + + function nc_diag_read_noid_check_global_attr(attr_name) result(attr_exists) + character(len=*), intent(in) :: attr_name + + logical :: attr_exists + + call ncdr_check_current_ncdr_id + + attr_exists = nc_diag_read_id_check_global_attr(current_ncdr_id, attr_name) + end function nc_diag_read_noid_check_global_attr + + function nc_diag_read_id_get_global_attr_type(file_ncdr_id, attr_name) result(attr_type) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + + integer(i_long) :: attr_type + + call ncdr_check_ncdr_id(file_ncdr_id) + + call ncdr_nc_check(nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + NF90_GLOBAL, attr_name, attr_type)) + end function nc_diag_read_id_get_global_attr_type + + function nc_diag_read_noid_get_global_attr_type(attr_name) result(attr_type) + character(len=*), intent(in) :: attr_name + + integer(i_long) :: attr_type + + call ncdr_check_current_ncdr_id + + attr_type = nc_diag_read_id_get_global_attr_type(current_ncdr_id, attr_name) + end function nc_diag_read_noid_get_global_attr_type + + function nc_diag_read_id_ret_global_attr_len(file_ncdr_id, attr_name) result(attr_len) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + + integer(i_long) :: attr_len + + call ncdr_check_ncdr_id(file_ncdr_id) + + call ncdr_nc_check(nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + NF90_GLOBAL, attr_name, len = attr_len)) + end function nc_diag_read_id_ret_global_attr_len + + function nc_diag_read_noid_ret_global_attr_len(attr_name) result(attr_len) + character(len=*), intent(in) :: attr_name + integer(i_long) :: attr_len + + call ncdr_check_current_ncdr_id + + attr_len = nc_diag_read_id_ret_global_attr_len(current_ncdr_id, attr_name) + end function nc_diag_read_noid_ret_global_attr_len + + subroutine nc_diag_read_id_get_global_attr_len(file_ncdr_id, attr_name, attr_len) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_len + + call ncdr_check_ncdr_id(file_ncdr_id) + + call ncdr_nc_check(nf90_inquire_attribute(ncdr_files(file_ncdr_id)%ncid, & + NF90_GLOBAL, attr_name, len = attr_len)) + end subroutine nc_diag_read_id_get_global_attr_len + + subroutine nc_diag_read_noid_get_global_attr_len(attr_name, attr_len) + character(len=*), intent(in) :: attr_name + integer(i_long), intent(out) :: attr_len + + call ncdr_check_current_ncdr_id + + call nc_diag_read_id_get_global_attr_len(current_ncdr_id, attr_name, attr_len) + end subroutine nc_diag_read_noid_get_global_attr_len + + subroutine nc_diag_read_id_get_global_attr_names(file_ncdr_id, num_global_attrs, attr_name_mlen, attr_names) + integer(i_long), intent(in) :: file_ncdr_id + integer(i_long), intent(out), optional :: num_global_attrs + integer(i_long), intent(out), optional :: attr_name_mlen + character(len=:), intent(inout), dimension(:), allocatable, optional:: attr_names + + integer(i_long) :: nattrs, attr_index, max_global_attr_name_len + + character(len=NF90_MAX_NAME) :: attr_name + + max_global_attr_name_len = 0 + + call ncdr_check_ncdr_id(file_ncdr_id) + + call ncdr_nc_check(nf90_inquire(ncdr_files(file_ncdr_id)%ncid, nAttributes = nattrs)) + + if (present(num_global_attrs)) & + num_global_attrs = nattrs + + ! Figure out character max length + do attr_index = 1, nattrs + call ncdr_nc_check(nf90_inq_attname(ncdr_files(file_ncdr_id)%ncid, & + NF90_GLOBAL, & + attr_index, & + attr_name)) + + if (len_trim(attr_name) > max_global_attr_name_len) & + max_global_attr_name_len = len_trim(attr_name) + end do + + if (present(attr_name_mlen)) & + attr_name_mlen = max_global_attr_name_len + + if (present(attr_names)) then + if (.NOT. allocated(attr_names)) then + allocate(character(max_global_attr_name_len) :: attr_names(nattrs)) + else + if (size(attr_names) /= nattrs) & + call ncdr_error("Invalid allocated array size for attribute names storage!") + if (len(attr_names) < max_global_attr_name_len) & + call ncdr_error("Invalid allocated array size for attribute names storage! (String length does not match!)") + end if + + do attr_index = 1, nattrs + call ncdr_nc_check(nf90_inq_attname(ncdr_files(file_ncdr_id)%ncid, & + NF90_GLOBAL, & + attr_index, & + attr_names(attr_index))) + end do + end if + end subroutine nc_diag_read_id_get_global_attr_names + + subroutine nc_diag_read_noid_get_global_attr_names(num_global_attrs, attr_name_mlen, attr_names) + integer(i_long), intent(out), optional :: num_global_attrs + integer(i_long), intent(out), optional :: attr_name_mlen + character(len=:), intent(inout), dimension(:), allocatable, optional:: attr_names + + call ncdr_check_current_ncdr_id + + call nc_diag_read_id_get_global_attr_names(current_ncdr_id, num_global_attrs, attr_name_mlen, attr_names) + end subroutine nc_diag_read_noid_get_global_attr_names +end module ncdr_global_attrs diff --git a/src/ncdiag/ncdr_global_attrs_fetch.f90 b/src/ncdiag/ncdr_global_attrs_fetch.f90 new file mode 100644 index 000000000..d7dce3fb2 --- /dev/null +++ b/src/ncdiag/ncdr_global_attrs_fetch.f90 @@ -0,0 +1,426 @@ +module ncdr_global_attrs_fetch + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + use ncdr_state, only: ncdr_files, current_ncdr_id + use ncdr_check, only: ncdr_nc_check, ncdr_check_ncdr_id, & + ncdr_check_current_ncdr_id, ncdr_check_ncid + use ncdr_alloc_assert, only: nc_diag_read_id_assert_global_attr, & + nc_diag_read_assert_global_attr_type, & + nc_diag_read_assert_dims, nc_diag_read_assert_dims_alloc_string + use netcdf, only: nf90_get_att, NF90_BYTE, NF90_SHORT, NF90_INT, & + NF90_FLOAT, NF90_DOUBLE, NF90_CHAR, NF90_GLOBAL + + implicit none + + interface nc_diag_read_get_global_attr + ! Note that nc_diag_read_(no)id_get_global_attr_1d_string is not + ! included due to rare use + conflicts with single_string. + module procedure & + nc_diag_read_id_get_global_attr_single_byte, & + nc_diag_read_id_get_global_attr_single_short, & + nc_diag_read_id_get_global_attr_single_long, & + nc_diag_read_id_get_global_attr_single_float, & + nc_diag_read_id_get_global_attr_single_double, & + nc_diag_read_id_get_global_attr_single_string, & + nc_diag_read_noid_get_global_attr_single_byte, & + nc_diag_read_noid_get_global_attr_single_short, & + nc_diag_read_noid_get_global_attr_single_long, & + nc_diag_read_noid_get_global_attr_single_float, & + nc_diag_read_noid_get_global_attr_single_double, & + nc_diag_read_noid_get_global_attr_single_string, & + nc_diag_read_id_get_global_attr_1d_byte, & + nc_diag_read_id_get_global_attr_1d_short, & + nc_diag_read_id_get_global_attr_1d_long, & + nc_diag_read_id_get_global_attr_1d_float, & + nc_diag_read_id_get_global_attr_1d_double, & + nc_diag_read_noid_get_global_attr_1d_byte, & + nc_diag_read_noid_get_global_attr_1d_short, & + nc_diag_read_noid_get_global_attr_1d_long, & + nc_diag_read_noid_get_global_attr_1d_float, & + nc_diag_read_noid_get_global_attr_1d_double + end interface nc_diag_read_get_global_attr + + contains + subroutine nc_diag_read_id_get_global_attr_1d_byte(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + integer(i_byte), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncdr_id(file_ncdr_id) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_BYTE) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_1d_byte + + subroutine nc_diag_read_noid_get_global_attr_1d_byte(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + integer(i_byte), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_1d_byte(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_1d_byte + + subroutine nc_diag_read_id_get_global_attr_1d_short(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + integer(i_short), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_SHORT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_1d_short + + subroutine nc_diag_read_noid_get_global_attr_1d_short(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + integer(i_short), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_1d_short(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_1d_short + + subroutine nc_diag_read_id_get_global_attr_1d_long(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + integer(i_long), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_INT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_1d_long + + subroutine nc_diag_read_noid_get_global_attr_1d_long(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + integer(i_long), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_1d_long(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_1d_long + + subroutine nc_diag_read_id_get_global_attr_1d_float(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + real(r_single), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_FLOAT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_1d_float + + subroutine nc_diag_read_noid_get_global_attr_1d_float(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + real(r_single), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_1d_float(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_1d_float + + subroutine nc_diag_read_id_get_global_attr_1d_double(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + real(r_double), dimension(:), allocatable, intent(inout) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_DOUBLE) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_1d_double + + subroutine nc_diag_read_noid_get_global_attr_1d_double(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + real(r_double), dimension(:), allocatable, intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_1d_double(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_1d_double + + subroutine nc_diag_read_id_get_global_attr_1d_string(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + character(len=:),allocatable,intent(inout) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_CHAR) + + call nc_diag_read_assert_dims_alloc_string(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_1d_string + + subroutine nc_diag_read_noid_get_global_attr_1d_string(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + character(len=:),allocatable,intent(inout) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_1d_string(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_1d_string + + subroutine nc_diag_read_id_get_global_attr_single_byte(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + integer(i_byte) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncdr_id(file_ncdr_id) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_BYTE) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_single_byte + + subroutine nc_diag_read_noid_get_global_attr_single_byte(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + integer(i_byte) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_single_byte(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_single_byte + + subroutine nc_diag_read_id_get_global_attr_single_short(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + integer(i_short) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_SHORT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_single_short + + subroutine nc_diag_read_noid_get_global_attr_single_short(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + integer(i_short) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_single_short(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_single_short + + subroutine nc_diag_read_id_get_global_attr_single_long(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + integer(i_long) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_INT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_single_long + + subroutine nc_diag_read_noid_get_global_attr_single_long(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + integer(i_long) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_single_long(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_single_long + + subroutine nc_diag_read_id_get_global_attr_single_float(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + real(r_single) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_FLOAT) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_single_float + + subroutine nc_diag_read_noid_get_global_attr_single_float(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + real(r_single) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_single_float(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_single_float + + subroutine nc_diag_read_id_get_global_attr_single_double(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + real(r_double) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_DOUBLE) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_single_double + + subroutine nc_diag_read_noid_get_global_attr_single_double(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + real(r_double) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_single_double(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_single_double + + subroutine nc_diag_read_id_get_global_attr_single_string(file_ncdr_id, attr_name, attr_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: attr_name + character(len=*) :: attr_stor + + integer(i_long) :: attr_len, attr_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + call nc_diag_read_id_assert_global_attr(file_ncdr_id, attr_name, attr_type, attr_len) + + call nc_diag_read_assert_global_attr_type(attr_type, NF90_CHAR) + + call nc_diag_read_assert_dims(attr_stor, (/ attr_len /)) + + call ncdr_nc_check(nf90_get_att(file_ncid, & + NF90_GLOBAL, & + attr_name, & + attr_stor)) + end subroutine nc_diag_read_id_get_global_attr_single_string + + subroutine nc_diag_read_noid_get_global_attr_single_string(attr_name, attr_stor) + character(len=*), intent(in) :: attr_name + character(len=*) :: attr_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_global_attr_single_string(current_ncdr_id, attr_name, attr_stor) + end subroutine nc_diag_read_noid_get_global_attr_single_string +end module ncdr_global_attrs_fetch diff --git a/src/ncdiag/ncdr_realloc_mod.F90 b/src/ncdiag/ncdr_realloc_mod.F90 new file mode 100644 index 000000000..f60f1b204 --- /dev/null +++ b/src/ncdiag/ncdr_realloc_mod.F90 @@ -0,0 +1,338 @@ +module ncdr_realloc_mod + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + use ncdr_types, only: ncdr_file + + implicit none + + !=============================================================== + ! ncdr_realloc - reallocation support (declaration) + !=============================================================== + ! DO NOT COMPILE THIS DIRECTLY! THIS IS MEANT TO BE INCLUDED + ! INSIDE A LARGER F90 SOURCE! + ! If you compile this directly, you WILL face the WRATH of your + ! compiler! + !--------------------------------------------------------------- + ! Depends on: nothing + !--------------------------------------------------------------- + ! ncdr_realloc subroutines provide reallocation functionality + ! for various inputs. + !--------------------------------------------------------------- + ! This file provides the interface wrapper for the array + ! reallocation subroutines. This is so that others can simply + ! call ncdr_realloc with the necessary arguments, instead of + ! having to call the specific ncdr_realloc_* subroutines. + + interface ncdr_realloc + module procedure ncdr_realloc_byte, & + ncdr_realloc_short, ncdr_realloc_long, & + ncdr_realloc_rsingle, ncdr_realloc_rdouble, & + ncdr_realloc_string, ncdr_realloc_logical, & + ncdr_realloc_file_type + end interface ncdr_realloc + + ! Variable dimensions storage + type ncdr_compress_dim_names + character(len=100), dimension(:), allocatable :: dim_names + integer(i_long), dimension(:), allocatable :: output_dim_ids + integer(i_long) :: num_names = 0 + end type ncdr_compress_dim_names + + contains + ! ncdr_realloc_byte(arr, addl_num_entries) + ! input: + ! integer(i_byte), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine ncdr_realloc_byte(arr, addl_num_entries) + integer(i_byte), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + integer(i_byte), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call ncdr_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine ncdr_realloc_byte + + ! ncdr_realloc_short(arr, addl_num_entries) + ! input: + ! integer(i_short), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine ncdr_realloc_short(arr, addl_num_entries) + integer(i_short), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + integer(i_short), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call ncdr_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine ncdr_realloc_short + + ! ncdr_realloc_long(arr, addl_num_entries) + ! input: + ! integer(i_long), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine ncdr_realloc_long(arr, addl_num_entries) + integer(i_long), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + integer(i_long), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + +#ifdef _DEBUG_MEM_ + call debug("Reallocating long array...") +#endif + + new_size = size(arr) + addl_num_entries + +#ifdef _DEBUG_MEM_ + print *, "REALLOCATOR: new_size is ", new_size +#endif + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call ncdr_realloc_error(trim(err_msg)) + end if + + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + +#ifdef _DEBUG_MEM_ + print *, "REALLOCATOR: final actual size is ", size(arr) + call debug("Realloc finished for long") +#endif + end subroutine ncdr_realloc_long + + ! ncdr_realloc_rsingle(arr, addl_num_entries) + ! input: + ! real(r_single), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine ncdr_realloc_rsingle(arr, addl_num_entries) + real(r_single), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + real(r_single), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call ncdr_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine ncdr_realloc_rsingle + + ! ncdr_realloc_rdouble(arr, addl_num_entries) + ! input: + ! real(r_double), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine ncdr_realloc_rdouble(arr, addl_num_entries) + real(r_double), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + real(r_double), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call ncdr_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine ncdr_realloc_rdouble + + ! ncdr_realloc_string(arr, addl_num_entries) + ! input: + ! character(len=*), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine ncdr_realloc_string(arr, addl_num_entries) + character(len=*), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + character(len=len(arr(1))), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + +#ifdef _DEBUG_MEM_ + integer(i_long) :: string_len, string_arr_size + + string_len = len(arr(1)) + string_arr_size = size(arr) + + call debug("[string] Length of string to allocate to:") + print *, string_len + + call debug("[string] Allocating from...") + print *, string_arr_size + + call debug("[string] ...to size...") + print *, (string_arr_size + addl_num_entries) +#endif + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call ncdr_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine ncdr_realloc_string + + ! ncdr_realloc_logical(arr, addl_num_entries) + ! input: + ! logical, dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine ncdr_realloc_logical(arr, addl_num_entries) + logical, dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + logical, dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_long) :: logical_arr_size + logical_arr_size = size(arr) + + new_size = logical_arr_size + addl_num_entries + +#ifdef _DEBUG_MEM_ + call debug("[logical] Allocating from...") + print *, logical_arr_size + + call debug("[logical] ...to size...") + print *, (logical_arr_size + addl_num_entries) +#endif + + allocate(tmp(new_size)) + tmp(1:logical_arr_size) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp +#ifdef _DEBUG_MEM_ + call debug("[logical] Final size:") + print *, size(arr) +#endif + end subroutine ncdr_realloc_logical + + ! ncdr_realloc_file_type(arr, addl_num_entries) + ! input: + ! type(ncdr_file), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine ncdr_realloc_file_type(arr, addl_num_entries) + type(ncdr_file), dimension(:), allocatable, intent(inout) :: arr + integer(i_long),intent(in) :: addl_num_entries + + type(ncdr_file), dimension(:), allocatable :: tmp + integer(i_long) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call ncdr_realloc_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine ncdr_realloc_file_type + + subroutine ncdr_realloc_error(err) + character(len=*), intent(in) :: err +#ifdef ERROR_TRACEBACK + integer :: div0 +#endif + write(*, "(A)") " ** ERROR: " // err +#ifdef ERROR_TRACEBACK + write(*, "(A)") " ** Failed to process data/write NetCDF4." + write(*, "(A)") " (Traceback requested, triggering div0 error...)" + div0 = 1 / 0 + write(*, "(A)") " Couldn't trigger traceback, ending gracefully." + write(*, "(A)") " (Ensure floating point exceptions are enabled," + write(*, "(A)") " and that you have debugging (-g) and tracebacks" + write(*, "(A)") " compiler flags enabled!)" + stop 1 +#else + stop " ** Failed to read data/write NetCDF4." +#endif + end subroutine ncdr_realloc_error +end module ncdr_realloc_mod diff --git a/src/ncdiag/ncdr_state.f90 b/src/ncdiag/ncdr_state.f90 new file mode 100644 index 000000000..ba80b4431 --- /dev/null +++ b/src/ncdiag/ncdr_state.f90 @@ -0,0 +1,24 @@ +module ncdr_state + use ncd_kinds, only: i_long, i_short + use ncdr_types, only: ncdr_file + + implicit none + + integer(i_long) :: current_ncdr_id = -1 + integer(i_long), dimension(:), allocatable :: ncdr_id_stack + integer(i_long) :: ncdr_id_stack_size = 0, ncdr_id_stack_count = 0 + logical :: init_done = .FALSE. + + character(len=200) :: cur_nc_file + + type(ncdr_file), dimension(:), allocatable :: ncdr_files + integer(i_long) :: ncdr_file_count = 0 + integer(i_long) :: ncdr_file_total = 0 + integer(i_long) :: ncdr_file_highest = 0 + + ! Default number of starting entries + integer(i_short), parameter :: NCDR_DEFAULT_ENT = 1024 + + ! NetCDF chunking size + integer(i_long), parameter :: NCDR_CHUNKING = 16384 +end module ncdr_state diff --git a/src/ncdiag/ncdr_types.f90 b/src/ncdiag/ncdr_types.f90 new file mode 100644 index 000000000..42a4d440e --- /dev/null +++ b/src/ncdiag/ncdr_types.f90 @@ -0,0 +1,53 @@ +module ncdr_types + use ncd_kinds, only: i_long + + implicit none + + ! Dimensions type - type for storing all of the dimensions in the + ! file + ! Allocates to the number of dimensions in the file + type ncdr_dim + ! Dimension names + character(len=:), allocatable :: dim_name + ! Dimension IDs + integer(i_long) :: dim_id + ! Dimension sizes + integer(i_long) :: dim_size + ! Boolean whether the dimension is unlimited or not! + logical :: dim_unlim + end type ncdr_dim + + ! Dimension indicies type - type for storing all of the dimension + ! indicies for a single variable + ! Allocates to the number of indicies within each variable + + ! Variables type - type for storing all variables in the file + ! Allocates to the number of variables in the file + type ncdr_var + ! Variable name + character(len=:), allocatable :: var_name + ! Variable ID + integer(i_long) :: var_id + ! Variable type + integer(i_long) :: var_type + ! Variable number of dimensions + integer(i_long) :: var_ndims + ! Dimension indexes - all of the dimension indicies for a + ! single variable + integer(i_long), dimension(:), allocatable :: var_dim_inds + ! Actual dimensions + integer(i_long), dimension(:), allocatable :: var_dim_sizes + end type ncdr_var + + ! File type - type for storing a single file's metadata + ! Allocates to the number of files + type ncdr_file + character(:), allocatable :: filename + integer(i_long) :: ncid + integer(i_long) :: ndims + type(ncdr_dim), dimension(:), allocatable :: dims + integer(i_long) :: nvars + type(ncdr_var), dimension(:), allocatable :: vars + logical :: file_open = .TRUE. + end type ncdr_file +end module ncdr_types diff --git a/src/ncdiag/ncdr_vars.f90 b/src/ncdiag/ncdr_vars.f90 new file mode 100644 index 000000000..dee14d012 --- /dev/null +++ b/src/ncdiag/ncdr_vars.f90 @@ -0,0 +1,376 @@ +module ncdr_vars + use ncd_kinds, only: i_long + use ncdr_state, only: ncdr_files, current_ncdr_id + use ncdr_climsg, only: ncdr_error + use ncdr_check, only: ncdr_nc_check, ncdr_check_ncdr_id, & + ncdr_check_current_ncdr_id + use ncdr_alloc_assert, only: nc_diag_read_id_assert_var + use netcdf, only: nf90_inquire_variable, NF90_MAX_NAME + + implicit none + + interface nc_diag_read_lookup_var + module procedure nc_diag_read_id_lookup_var, & + nc_diag_read_noid_lookup_var + end interface nc_diag_read_lookup_var + + interface nc_diag_read_check_var + module procedure nc_diag_read_id_check_var, & + nc_diag_read_noid_check_var + end interface nc_diag_read_check_var + + interface nc_diag_read_get_var_ndims + module procedure nc_diag_read_id_get_var_ndims, & + nc_diag_read_noid_get_var_ndims + end interface nc_diag_read_get_var_ndims + + interface nc_diag_read_get_var_type + module procedure nc_diag_read_id_get_var_type, & + nc_diag_read_noid_get_var_type + end interface nc_diag_read_get_var_type + + interface nc_diag_read_ret_var_dims + module procedure nc_diag_read_id_ret_var_dims, & + nc_diag_read_noid_ret_var_dims + end interface nc_diag_read_ret_var_dims + + interface nc_diag_read_get_var_dims + module procedure nc_diag_read_id_get_var_dims, & + nc_diag_read_noid_get_var_dims + end interface nc_diag_read_get_var_dims + + interface nc_diag_read_get_var_names + module procedure nc_diag_read_id_get_var_names + end interface nc_diag_read_get_var_names + + interface nc_diag_read_noid_get_var_names + module procedure nc_diag_read_noid_get_var_names + end interface nc_diag_read_noid_get_var_names + + contains + subroutine nc_diag_read_parse_file_vars(file_ncid, file_index, num_vars) + integer(i_long), intent(in) :: file_ncid + integer(i_long), intent(in) :: file_index + integer(i_long), intent(in) :: num_vars + + integer(i_long) :: i, j + + character(len=NF90_MAX_NAME) :: var_name + + ncdr_files(file_index)%nvars = num_vars + allocate(ncdr_files(file_index)%vars(num_vars)) + + do i = 1, num_vars + ncdr_files(file_index)%vars(i)%var_id = i + + call ncdr_nc_check(nf90_inquire_variable(file_ncid, i, & + name = var_name, & + ndims = ncdr_files(file_index)%vars(i)%var_ndims, & + xtype = ncdr_files(file_index)%vars(i)%var_type)) + + ncdr_files(file_index)%vars(i)%var_name = trim(var_name) + + allocate(ncdr_files(file_index)%vars(i)%var_dim_inds( & + ncdr_files(file_index)%vars(i)%var_ndims)) + + call ncdr_nc_check(nf90_inquire_variable(file_ncid, i, & + dimids = ncdr_files(file_index)%vars(i)%var_dim_inds)) + + ! Since the dimensions indicies are aligned to NetCDF's + ! indicies, we don't need to do any more analysis. + ! We're done with indices! + + ! Now, let's actually use them: + allocate(ncdr_files(file_index)%vars(i)%var_dim_sizes( & + ncdr_files(file_index)%vars(i)%var_ndims)) + + do j = 1, ncdr_files(file_index)%vars(i)%var_ndims + ncdr_files(file_index)%vars(i)%var_dim_sizes(j) = & + ncdr_files(file_index)%dims( & + ncdr_files(file_index)%vars(i)%var_dim_inds(j) & + )%dim_size + end do + end do + end subroutine nc_diag_read_parse_file_vars + + function nc_diag_read_id_lookup_var(file_ncdr_id, var_name) result(var_index) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + + integer(i_long) :: var_index + + call ncdr_check_ncdr_id(file_ncdr_id) + + do var_index = 1, ncdr_files(file_ncdr_id)%nvars + if (ncdr_files(file_ncdr_id)%vars(var_index)%var_name == var_name) & + return + end do + + ! Otherwise, return -1! + var_index = -1 + end function nc_diag_read_id_lookup_var + + function nc_diag_read_noid_lookup_var(var_name) result(var_index) + character(len=*), intent(in) :: var_name + + integer(i_long) :: var_index + + call ncdr_check_current_ncdr_id + + var_index = nc_diag_read_id_lookup_var(current_ncdr_id, var_name) + end function nc_diag_read_noid_lookup_var + + function nc_diag_read_id_check_var(file_ncdr_id, var_name) result(var_exists) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + + logical :: var_exists + + call ncdr_check_ncdr_id(file_ncdr_id) + + if (nc_diag_read_id_lookup_var(file_ncdr_id, var_name) == -1) then + var_exists = .FALSE. + return + end if + + var_exists = .TRUE. + end function nc_diag_read_id_check_var + + function nc_diag_read_noid_check_var(var_name) result(var_exists) + character(len=*), intent(in) :: var_name + + logical :: var_exists + + call ncdr_check_current_ncdr_id + + if (nc_diag_read_lookup_var(var_name) == -1) then + var_exists = .FALSE. + return + end if + + var_exists = .TRUE. + end function nc_diag_read_noid_check_var + + function nc_diag_read_id_get_var_ndims(file_ncdr_id, var_name) result(var_ndims) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + + integer(i_long) :: var_index, var_ndims + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + + var_ndims = ncdr_files(file_ncdr_id)%vars(var_index)%var_ndims + end function nc_diag_read_id_get_var_ndims + + function nc_diag_read_noid_get_var_ndims(var_name) result(var_ndims) + character(len=*), intent(in) :: var_name + + integer(i_long) :: var_ndims + + call ncdr_check_current_ncdr_id + + var_ndims = nc_diag_read_id_get_var_ndims(current_ncdr_id, var_name) + end function nc_diag_read_noid_get_var_ndims + + function nc_diag_read_id_get_var_type(file_ncdr_id, var_name) result(var_type) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + + integer(i_long) :: var_index, var_type + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + end function nc_diag_read_id_get_var_type + + function nc_diag_read_noid_get_var_type(var_name) result(var_type) + character(len=*), intent(in) :: var_name + + integer(i_long) :: var_type + + call ncdr_check_current_ncdr_id + + var_type = nc_diag_read_id_get_var_type(current_ncdr_id, var_name) + end function nc_diag_read_noid_get_var_type + + function nc_diag_read_id_ret_var_dims(file_ncdr_id, var_name) result(var_dims) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + + integer(i_long) :: var_index, var_ndims, i + integer(i_long), dimension(:), allocatable :: var_dims + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + + var_ndims = nc_diag_read_id_get_var_ndims(file_ncdr_id, var_name) + + allocate(var_dims(var_ndims)) + + do i = 1, var_ndims + var_dims(i) = & + ncdr_files(file_ncdr_id)%dims( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_inds(i) & + )%dim_size + end do + end function nc_diag_read_id_ret_var_dims + + function nc_diag_read_noid_ret_var_dims(var_name) result(var_dims) + character(len=*), intent(in) :: var_name + integer(i_long), dimension(:), allocatable :: var_dims + + integer(i_long) :: var_ndims + + call ncdr_check_current_ncdr_id + + var_ndims = nc_diag_read_id_get_var_ndims(current_ncdr_id, var_name) + + allocate(var_dims(var_ndims)) + + var_dims = nc_diag_read_id_ret_var_dims(current_ncdr_id, var_name) + end function nc_diag_read_noid_ret_var_dims + + subroutine nc_diag_read_id_get_var_dims(file_ncdr_id, var_name, var_ndims, var_dims) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + integer(i_long), intent(inout), optional :: var_ndims + integer(i_long), intent(inout), dimension(:), allocatable, optional :: var_dims + + integer(i_long) :: var_index, v_ndims, i + + call ncdr_check_ncdr_id(file_ncdr_id) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + + v_ndims = nc_diag_read_id_get_var_ndims(file_ncdr_id, var_name) + + if (present(var_ndims)) & + var_ndims = v_ndims + + if (present(var_dims)) then + if (.NOT. allocated(var_dims)) then + allocate(var_dims(v_ndims)) + else + if (size(var_dims) /= v_ndims) & + call ncdr_error("Invalid allocated array size for variable dimensions size storage!") + end if + + do i = 1, v_ndims + var_dims(i) = & + ncdr_files(file_ncdr_id)%dims( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_inds(i) & + )%dim_size + end do + end if + end subroutine nc_diag_read_id_get_var_dims + + subroutine nc_diag_read_noid_get_var_dims(var_name, var_ndims, var_dims) + character(len=*), intent(in) :: var_name + integer(i_long), intent(inout), optional :: var_ndims + integer(i_long), intent(inout), dimension(:), allocatable, optional :: var_dims + + call ncdr_check_current_ncdr_id + + if (present(var_ndims)) then + if (present(var_dims)) then + call nc_diag_read_id_get_var_dims(current_ncdr_id, var_name, var_ndims, var_dims) + else + call nc_diag_read_id_get_var_dims(current_ncdr_id, var_name, var_ndims) + end if + else + if (present(var_dims)) then + call nc_diag_read_id_get_var_dims(current_ncdr_id, var_name, var_dims = var_dims) + else + ! Why you want to do this, I dunno... + call nc_diag_read_id_get_var_dims(current_ncdr_id, var_name) + end if + end if + end subroutine nc_diag_read_noid_get_var_dims + + subroutine nc_diag_read_id_get_var_names(file_ncdr_id, num_vars, var_name_mlen, var_names) + integer(i_long), intent(in) :: file_ncdr_id + integer(i_long), intent(out), optional :: num_vars + integer(i_long), intent(out), optional :: var_name_mlen + character(len=:), intent(inout), dimension(:), allocatable, optional:: var_names + + integer(i_long) :: var_index, nvars, max_var_name_len + + max_var_name_len = 0 + + call ncdr_check_ncdr_id(file_ncdr_id) + + nvars = ncdr_files(file_ncdr_id)%nvars + + if (present(num_vars)) & + num_vars = nvars + + ! Figure out character max length + do var_index = 1, nvars + if (len(ncdr_files(file_ncdr_id)%vars(var_index)%var_name) > max_var_name_len) & + max_var_name_len = len(ncdr_files(file_ncdr_id)%vars(var_index)%var_name) + end do + + if (present(var_name_mlen)) & + var_name_mlen = max_var_name_len + + if (present(var_names)) then + if (.NOT. allocated(var_names)) then + allocate(character(max_var_name_len) :: var_names(nvars)) + else + if (size(var_names) /= nvars) & + call ncdr_error("Invalid allocated array size for variable names storage!") + if (len(var_names) < max_var_name_len) & + call ncdr_error("Invalid allocated array size for variable names storage! (String length does not match!)") + end if + + do var_index = 1, nvars + var_names(var_index) = ncdr_files(file_ncdr_id)%vars(var_index)%var_name + end do + end if + end subroutine nc_diag_read_id_get_var_names + + subroutine nc_diag_read_noid_get_var_names(num_vars, var_name_mlen, var_names) + integer(i_long), intent(out), optional :: num_vars + integer(i_long), intent(out), optional :: var_name_mlen + character(len=:), intent(inout), dimension(:), allocatable, optional:: var_names + + call ncdr_check_current_ncdr_id + + if (present(num_vars)) then + if (present(var_name_mlen)) then + if (present(var_names)) then + call nc_diag_read_id_get_var_names(current_ncdr_id, num_vars, var_name_mlen, var_names) + else + call nc_diag_read_id_get_var_names(current_ncdr_id, num_vars, var_name_mlen) + end if + else + if (present(var_names)) then + call nc_diag_read_id_get_var_names(current_ncdr_id, num_vars, var_names = var_names) + else + call nc_diag_read_id_get_var_names(current_ncdr_id, num_vars) + end if + end if + else + if (present(var_name_mlen)) then + if (present(var_names)) then + call nc_diag_read_id_get_var_names(current_ncdr_id, var_name_mlen = var_name_mlen, & + var_names = var_names) + else + call nc_diag_read_id_get_var_names(current_ncdr_id, var_name_mlen = var_name_mlen) + end if + else + if (present(var_names)) then + call nc_diag_read_id_get_var_names(current_ncdr_id, var_names = var_names) + else + ! Why would you do this? + call nc_diag_read_id_get_var_names(current_ncdr_id) + end if + end if + end if + end subroutine nc_diag_read_noid_get_var_names +end module ncdr_vars diff --git a/src/ncdiag/ncdr_vars_fetch.f90 b/src/ncdiag/ncdr_vars_fetch.f90 new file mode 100644 index 000000000..dcc085b40 --- /dev/null +++ b/src/ncdiag/ncdr_vars_fetch.f90 @@ -0,0 +1,482 @@ +module ncdr_vars_fetch + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + use ncdr_state, only: ncdr_files, current_ncdr_id + use ncdr_check, only: ncdr_nc_check, ncdr_check_ncdr_id, & + ncdr_check_current_ncdr_id, ncdr_check_ncid + use ncdr_alloc_assert, only: nc_diag_read_id_assert_var, & + nc_diag_read_assert_var_type, nc_diag_read_assert_var_ndims, & + nc_diag_read_assert_dims + use netcdf, only: nf90_get_var, NF90_BYTE, NF90_SHORT, NF90_INT, & + NF90_FLOAT, NF90_DOUBLE, NF90_CHAR + + implicit none + + interface nc_diag_read_get_var + module procedure & + nc_diag_read_id_get_var_1d_byte, & + nc_diag_read_id_get_var_1d_short, & + nc_diag_read_id_get_var_1d_long, & + nc_diag_read_id_get_var_1d_float, & + nc_diag_read_id_get_var_1d_double, & + nc_diag_read_id_get_var_1d_string, & + nc_diag_read_noid_get_var_1d_byte, & + nc_diag_read_noid_get_var_1d_short, & + nc_diag_read_noid_get_var_1d_long, & + nc_diag_read_noid_get_var_1d_float, & + nc_diag_read_noid_get_var_1d_double, & + nc_diag_read_noid_get_var_1d_string, & + nc_diag_read_id_get_var_2d_byte, & + nc_diag_read_id_get_var_2d_short, & + nc_diag_read_id_get_var_2d_long, & + nc_diag_read_id_get_var_2d_float, & + nc_diag_read_id_get_var_2d_double, & + nc_diag_read_id_get_var_2d_string, & + nc_diag_read_noid_get_var_2d_byte, & + nc_diag_read_noid_get_var_2d_short, & + nc_diag_read_noid_get_var_2d_long, & + nc_diag_read_noid_get_var_2d_float, & + nc_diag_read_noid_get_var_2d_double, & + nc_diag_read_noid_get_var_2d_string + end interface nc_diag_read_get_var + + contains + subroutine nc_diag_read_id_get_var_1d_byte(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + integer(i_byte), dimension(:), allocatable, intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncdr_id(file_ncdr_id) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_BYTE) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 1) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1) /) )) + end subroutine nc_diag_read_id_get_var_1d_byte + + subroutine nc_diag_read_noid_get_var_1d_byte(var_name, var_stor) + character(len=*), intent(in) :: var_name + integer(i_byte), dimension(:), allocatable, intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_1d_byte(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_1d_byte + + subroutine nc_diag_read_id_get_var_1d_short(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + integer(i_short), dimension(:), allocatable, intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_SHORT) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 1) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1) /) )) + end subroutine nc_diag_read_id_get_var_1d_short + + subroutine nc_diag_read_noid_get_var_1d_short(var_name, var_stor) + character(len=*), intent(in) :: var_name + integer(i_short), dimension(:), allocatable, intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_1d_short(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_1d_short + + subroutine nc_diag_read_id_get_var_1d_long(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + integer(i_long), dimension(:), allocatable, intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_INT) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 1) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1) /) )) + end subroutine nc_diag_read_id_get_var_1d_long + + subroutine nc_diag_read_noid_get_var_1d_long(var_name, var_stor) + character(len=*), intent(in) :: var_name + integer(i_long), dimension(:), allocatable, intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_1d_long(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_1d_long + + subroutine nc_diag_read_id_get_var_1d_float(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + real(r_single), dimension(:), allocatable, intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_FLOAT) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 1) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1) /) )) + end subroutine nc_diag_read_id_get_var_1d_float + + subroutine nc_diag_read_noid_get_var_1d_float(var_name, var_stor) + character(len=*), intent(in) :: var_name + real(r_single), dimension(:), allocatable, intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_1d_float(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_1d_float + + subroutine nc_diag_read_id_get_var_1d_double(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + real(r_double), dimension(:), allocatable, intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_DOUBLE) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 1) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1) /) )) + end subroutine nc_diag_read_id_get_var_1d_double + + subroutine nc_diag_read_noid_get_var_1d_double(var_name, var_stor) + character(len=*), intent(in) :: var_name + real(r_double), dimension(:), allocatable, intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_1d_double(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_1d_double + + subroutine nc_diag_read_id_get_var_1d_string(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=:), dimension(:), allocatable, intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_CHAR) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 2) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1, 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1), & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(2) /) )) + end subroutine nc_diag_read_id_get_var_1d_string + + subroutine nc_diag_read_noid_get_var_1d_string(var_name, var_stor) + character(len=*), intent(in) :: var_name + character(len=:), dimension(:), allocatable, intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_1d_string(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_1d_string + + subroutine nc_diag_read_id_get_var_2d_byte(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + integer(i_byte), dimension(:,:),allocatable,intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_BYTE) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 2) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1), & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(2) /) )) + end subroutine nc_diag_read_id_get_var_2d_byte + + subroutine nc_diag_read_noid_get_var_2d_byte(var_name, var_stor) + character(len=*), intent(in) :: var_name + integer(i_byte), dimension(:,:),allocatable,intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_2d_byte(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_2d_byte + + subroutine nc_diag_read_id_get_var_2d_short(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + integer(i_short), dimension(:,:),allocatable,intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_SHORT) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 2) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1), & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(2) /) )) + end subroutine nc_diag_read_id_get_var_2d_short + + subroutine nc_diag_read_noid_get_var_2d_short(var_name, var_stor) + character(len=*), intent(in) :: var_name + integer(i_short), dimension(:,:),allocatable,intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_2d_short(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_2d_short + + subroutine nc_diag_read_id_get_var_2d_long(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + integer(i_long), dimension(:,:),allocatable,intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_INT) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 2) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1), & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(2) /) )) + end subroutine nc_diag_read_id_get_var_2d_long + + subroutine nc_diag_read_noid_get_var_2d_long(var_name, var_stor) + character(len=*), intent(in) :: var_name + integer(i_long), dimension(:,:),allocatable,intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_2d_long(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_2d_long + + subroutine nc_diag_read_id_get_var_2d_float(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + real(r_single), dimension(:,:),allocatable,intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_FLOAT) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 2) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1), & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(2) /) )) + end subroutine nc_diag_read_id_get_var_2d_float + + subroutine nc_diag_read_noid_get_var_2d_float(var_name, var_stor) + character(len=*), intent(in) :: var_name + real(r_single), dimension(:,:),allocatable,intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_2d_float(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_2d_float + + subroutine nc_diag_read_id_get_var_2d_double(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + real(r_double), dimension(:,:),allocatable,intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_DOUBLE) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 2) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1), & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(2) /) )) + end subroutine nc_diag_read_id_get_var_2d_double + + subroutine nc_diag_read_noid_get_var_2d_double(var_name, var_stor) + character(len=*), intent(in) :: var_name + real(r_double), dimension(:,:),allocatable,intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_2d_double(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_2d_double + + subroutine nc_diag_read_id_get_var_2d_string(file_ncdr_id, var_name, var_stor) + integer(i_long), intent(in) :: file_ncdr_id + character(len=*), intent(in) :: var_name + character(len=:), dimension(:,:),allocatable,intent(inout) :: var_stor + + integer(i_long) :: var_index, var_type, file_ncid + + call ncdr_check_ncdr_id(file_ncdr_id) + + file_ncid = ncdr_files(file_ncdr_id)%ncid + call ncdr_check_ncid(file_ncid) + + var_index = nc_diag_read_id_assert_var(file_ncdr_id, var_name) + var_type = ncdr_files(file_ncdr_id)%vars(var_index)%var_type + + call nc_diag_read_assert_var_type(var_type, NF90_CHAR) + call nc_diag_read_assert_var_ndims(size( & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes), 3) + + call nc_diag_read_assert_dims(var_stor, & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes) + + call ncdr_nc_check(nf90_get_var(file_ncid, var_index, & + var_stor, & + start = (/ 1, 1, 1 /), & + count = (/ ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(1), & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(2), & + ncdr_files(file_ncdr_id)%vars(var_index)%var_dim_sizes(3) /) )) + end subroutine nc_diag_read_id_get_var_2d_string + + subroutine nc_diag_read_noid_get_var_2d_string(var_name, var_stor) + character(len=*), intent(in) :: var_name + character(len=:), dimension(:,:),allocatable,intent(inout) :: var_stor + + call ncdr_check_current_ncdr_id + call nc_diag_read_id_get_var_2d_string(current_ncdr_id, var_name, var_stor) + end subroutine nc_diag_read_noid_get_var_2d_string +end module ncdr_vars_fetch diff --git a/src/ncdiag/ncdres_climsg.F90 b/src/ncdiag/ncdres_climsg.F90 new file mode 100644 index 000000000..69c89f373 --- /dev/null +++ b/src/ncdiag/ncdres_climsg.F90 @@ -0,0 +1,55 @@ +module ncdres_climsg + ! NetCDF Diag Reader - CLI Message portion + implicit none + + logical :: ncdres_enable_info = .FALSE. + + contains + ! NetCDF Diag Reader - CLI Message portion + ! (Subroutine/Function implementation) + + subroutine ncdres_error(err) + character(len=*), intent(in) :: err +#ifdef ERROR_TRACEBACK + integer :: div0 +#endif + write(*, "(A)") " ** ERROR: " // err +#ifdef ERROR_TRACEBACK + write(*, "(A)") " ** Failed to read NetCDF4." + write(*, "(A)") " (Traceback requested, triggering div0 error...)" + div0 = 1 / 0 + write(*, "(A)") " Couldn't trigger traceback, ending gracefully." + write(*, "(A)") " (Ensure floating point exceptions are enabled," + write(*, "(A)") " and that you have debugging (-g) and tracebacks" + write(*, "(A)") " compiler flags enabled!)" + stop 1 +#else + write (*, "(A)") " ** Failed to read NetCDF4." + stop 1 +#endif + end subroutine ncdres_error + + subroutine ncdres_warning(warn) + character(len=*), intent(in) :: warn + write(*, "(A)") " ** WARNING: " // warn + end subroutine ncdres_warning + + subroutine ncdres_set_info_display(info_on_off) + logical :: info_on_off + ncdres_enable_info = info_on_off + end subroutine ncdres_set_info_display + + subroutine ncdres_info(ifo) + character(len=*), intent(in) :: ifo + if (ncdres_enable_info) & + write(*, "(A)") " ** INFO: " // ifo + end subroutine ncdres_info + +#ifdef _DEBUG_MEM_ + subroutine ncdres_debug(dbg) + character(len=*), intent(in) :: dbg + write(*, "(A, A)") "D: ", dbg + end subroutine ncdres_debug +#endif + +end module ncdres_climsg diff --git a/src/ncdiag/ncdw_chaninfo.F90 b/src/ncdiag/ncdw_chaninfo.F90 new file mode 100644 index 000000000..ec28f1d65 --- /dev/null +++ b/src/ncdiag/ncdw_chaninfo.F90 @@ -0,0 +1,2673 @@ +! nc_diag_write - NetCDF Layer Diag Writing Module +! Copyright 2015 Albert Huang - SSAI/NASA for NASA GSFC GMAO (610.1). +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or +! implied. See the License for the specific language governing +! permissions and limitations under the License. +! +! chaninfo module - ncdw_chaninfo +! +module ncdw_chaninfo + ! Module that provides chaninfo variable storage support. + ! + ! This module has all of the subroutines needed to store chaninfo + ! data. It includes the chaninfo storing subroutine + ! (nc_diag_chaninfo), subroutines for controlling chaninfo data + ! (dimension setting, loading definitions, saving definitions, + ! saving data, etc.), and preallocation subroutines. + ! + ! Background: + ! chaninfo is a fixed storage variable, with dimensions of + ! 1 x nchans, where nchans is a known integer. + ! + ! Because we can know nchans, we can constrain the dimensions and + ! make a few assumptions: + ! + ! -> nchans won't change for the duration of the file being open; + ! -> nchans will be the same for all chaninfo variables, for any + ! type involved; + ! -> because everything is fixed, we can store variables block + ! by block! + ! + ! Because Fortran is a strongly typed language, we can't do silly + ! tricks in C, like allocating some memory to a void pointer and + ! just storing our byte, short, int, long, float, or double + ! numeric data there, and later casting it back... + ! + ! (e.g. void **data_ref; data_ref = malloc(sizeof(void *) * 1000); + ! float *f = malloc(sizeof(float)); *f = 1.2345; + ! data_ref[0] = f; ...) + ! + ! No frets - we can work around this issue with some derived types + ! and arrays! We create an array for each type we want to support. + ! Since we're using kinds.F90, we support the following types: + ! i_byte, i_short, i_long, r_single, r_double, character(len=*) + ! + ! The derived type used, diag_chaninfo, has these variables to + ! help us keep track of everything: + ! + ! -> ci_* - these arrays have the types listed above, plus string + ! support! These arrays are simply arrays that we throw our + ! data in. However, don't mistaken "throw in" with + ! "disorganized" - chaninfo uses a very structured format for + ! these variables! Keep reading to find out how we structure + ! it... + ! + ! -> nchans - the number of channels to use. Remember that + ! chaninfo variables have dimensions 1 x nchans - basically, we + ! need to store nchans values. We'll need this a LOT to do + ! consistency checks, and to keep track of everything! + ! + ! -> names - all of the chaninfo variable names! We'll be using + ! this array to store and lookup chaninfo variables, as well as + ! storing them! + ! + ! -> types - all of the chaninfo variable types! These are byte + ! integers that get compared to our NLAYER_* type constants + ! (see: ncdw_types.F90). + ! + ! -> var_usage - the amount of entries we've stored in our + ! chaninfo variable! For instance, if we called + ! nc_diag_chaninfo("myvar", 1) three times, for that particular + ! var_usage(i), we would have an entry of 3. + ! + ! -> var_rel_pos - the star of the show! This is an abbreviation + ! of "variable relative positioning". Recall that we store + ! our variable data in ci_* specific type arrays. We know + ! the nchans amount, and we know the type. This variable stores + ! the "block" that our data is in within the type array. + ! + ! Therefore, we can use the equation to find our starting + ! position: 1 + [(REL_VAL - 1) * nchans] + ! + ! For instance, if var_rel_pos(1) for variable names(1) = "bla" + ! is set to 2, nchans is 10, and the type is NLAYER_FLOAT, we + ! can deduce that in ci_rsingle, our data can be found starting + ! at 1 + (1 * 10) = 11. This makes sense, as seen with our mini + ! diagram below: + ! + ! ci_rsingle: + ! / ci_rsingle index \ + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + ! [ x, x, x, x, x, x, x, x, x, x, y, y, y, y, y, y, y, y, y, y] + ! \ ci_rsingle array / + ! + ! Indeed, our second block does start at index 11! + ! As a bonus, since our data is in blocks, things can be super + ! fast since we're just cutting our big array into small ones! + ! + ! -> acount_v: Finally, we have dynamic allocation. We have in our + ! type a variable called acount_v. This tells us how many + ! variables are stored in each type. Using the same equation + ! above, and combining with var_usage, we can figure out where + ! to put our data! + ! + ! Assume var_usage(i) = 2, block starts at index 11 with the + ! equation above. + ! + ! Again, with our fun little diagram: + ! + ! ci_rsingle: + ! / ci_rsingle index \ + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + ! [ x, x, x, x, x, x, x, x, x, x, y, y, Y, y, y, y, y, y, y, y] + ! [ BLOCK 1 SEEK = 1->10->11 ][var_u=2|--block 2 area 11->20] + ! \ ci_rsingle array / + ! + ! The capital Y marks the place we store our data! + ! + ! For the non-data variables (e.g. variable names, types, etc.), + ! they are indexed by variable insertion order. This allows for + ! easy lookup by looking up the variable name, and using the + ! resulting index for fetching other information. + ! + ! Example: + ! names: [ 'asdf', 'ghjk', 'zxcv' ] + ! types: [ BYTE, FLOAT, BYTE ] + ! var_rel_pos: [ 1, 1, 2 ] + ! + ! Lookup: "ghjk", result index = 2 + ! + ! Therefore, the "ghjk" variable type is types(2) = FLOAT, and + ! the var_rel_pos for "ghjk" variable is var_rel_pos(2) = 1. + ! + ! These variables are allocated and reallocated, as needed. + ! + ! For the variable metadata fields (variable names, types, + ! relative indicies, etc.), these are reallocated incrementally + ! when a new variable is added. + ! + ! For the data storage fields, these are reallocated incrementally + ! when new data is added. + ! + ! Initial allocation and subsequent reallocation is done by + ! chunks. Allocating one element and/or reallocating and adding + ! just one element is inefficient, since it's likely that much + ! more data (and variables) will be added. Thus, allocation and + ! reallocation is done by (re-)allocating exponentially increasing + ! chunk sizes. See nc_diag_chaninfo_allocmulti help for more + ! details. + ! + ! Because (re-)allocation is done in chunks, we keep a count of + ! how much of the memory we're using so that we know when it's + ! time to (re-)allocate. Once we need to (re-)allocate, we + ! perform it, and then update our total memory counter to keep + ! track of the memory already allocated. + ! + ! With all of these variables (and a few more state variables), + ! we can reliably store our chaninfo data quickly and + ! efficiently! + ! + + ! Load our numerical types from kinds + ! Note that i_llong is not a type we store - it's just for keeping + ! track of numeric indexes. (Maybe this is too excessive...) + use ncd_kinds, only: i_byte, i_short, i_long, i_llong, r_single, & + r_double + + ! Load state variables! We need to know: + ! init_done - ...whether a file is currently loaded or + ! not. + ! ncid - ...the current NCID of our file. + ! append_only - ...whether we are in append mode or not. + ! enable_trim - ...whether we need to automatically trim + ! our strings for chaninfo string storage or + ! not. + ! diag_chaninfo_store - ...chaninfo variable information. + ! We pretty much do everything related to + ! chaninfo here, so we're using everything + ! inside this derived type! + use ncdw_state, only: init_done, ncid, append_only, & + enable_trim, & + diag_chaninfo_store + + ! Load types! We need: + ! NLAYER_* - nc_diag types. + ! NLAYER_FILL_* - nc_diag type fill. This is pretty much + ! equivalent to NF90_FILL_*. + ! NLAYER_COMPRESSION - zlib (a la gzip) compression level setting. + ! NLAYER_DEFAULT_ENT - default starting number of element entries. + ! This is for the initial allocation of + ! space for data storage arrays, e.g. + ! the ci_* data arrays within diag_chaninfo. + ! NLAYER_MULTI_BASE - the base number to use when exponentiating + ! to allocate or reallocate data storage + ! arrays. + use ncdw_types, only: NLAYER_BYTE, NLAYER_SHORT, NLAYER_LONG, & + NLAYER_FLOAT, NLAYER_DOUBLE, NLAYER_STRING, & + NLAYER_FILL_BYTE, NLAYER_FILL_SHORT, NLAYER_FILL_LONG, & + NLAYER_FILL_FLOAT, NLAYER_FILL_DOUBLE, NLAYER_FILL_CHAR, & + NLAYER_COMPRESSION, NLAYER_DEFAULT_ENT, NLAYER_MULTI_BASE + + ! Load our varattr adder! We need this to store our new shiny + ! variable in the varattr database so we can add variable attributes + ! to our variables. + use ncdw_varattr, only: nc_diag_varattr_add_var + + ! Load our function - given an array of strings, find + ! max(len_trim(str_array)) - aka the maximum for len_trim()s on each + ! variable. + use ncdw_strarrutils, only: max_len_string_array + + use ncdw_climsg, only: & +#ifdef ENABLE_ACTION_MSGS + nclayer_enable_action, nclayer_actionm, & +#endif + nclayer_error, nclayer_warning, nclayer_info, nclayer_check + + ! Load our fun reallocation subroutine - we need this to reallocate + ! a few things in our preallocation subroutines: + use ncdw_realloc, only: nc_diag_realloc + + ! Load our chaninfo resizing subroutines - these resize our data + ! storage arrays automatically when needed! + use ncdw_ciresize, only: nc_diag_chaninfo_resize_byte, & + nc_diag_chaninfo_resize_short, nc_diag_chaninfo_resize_long, & + nc_diag_chaninfo_resize_rsingle, & + nc_diag_chaninfo_resize_rdouble, nc_diag_chaninfo_resize_string + + use netcdf, only: nf90_inquire, nf90_inq_dimid, & + nf90_inquire_dimension, nf90_inquire_variable, nf90_def_dim, & + nf90_def_var, nf90_get_var, nf90_put_var, & + nf90_def_var_deflate, nf90_def_var_chunking, & + NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE, & + NF90_CHAR, & + NF90_EBADDIM, NF90_NOERR, NF90_MAX_NAME, NF90_CHUNKED + + implicit none + + ! Add a single chaninfo value to a new or existing chaninfo + ! variable. + ! + ! Given the chaninfo variable name and value, add or update the + ! variable with the corresponding value. + ! + ! If the variable doesn't already exist, this will automatically + ! create it and store the value into it. + ! + ! If the variable does exist, it will simply append to the + ! variable's existing values. + ! + ! Values are inserted in the order of the calls made. As such, + ! this subroutine is best designed to be used in a loop, where + ! for every channel iteration, a value is added using this + ! subroutine. + ! + ! chaninfo is stored element by element - no arrays are accepted, + ! only scalar values. The best way to call chaninfo is in a loop, + ! where each channel is being accessed and stored. + ! + ! Once a value has been added, it may not be removed. Make sure you + ! are certain that the value should be added! + ! + ! The number of values may not exceed the number of channels + ! (nchans). If more values are added and nchans is exceeded, an + ! error will occur. + ! + ! Data locking and definition locking will also affect adding + ! chaninfo variables and value. If data locking is in effect, any + ! variable or value adding will not work. If definition locking is + ! in effect, adding variable values to existing variables will still + ! work, but adding new variables will not. + ! + ! For strings, if the length of the string changes when trimming is + ! disabled, or when the definitions have been locked, an error will + ! occur as well. + ! + ! To see more details about what checks are made, see the + ! corresponding called subroutine documentation for details. + ! + ! Valid data types (represented below as data_types): + ! integer(i_byte), integer(i_short), integer(i_long), + ! real(r_single), real(r_double), character(len=*) + ! + ! Args: + ! name (character(len=*)): the name of the chaninfo variable to + ! add or update. + ! value (data_types): the value to add to chaninfo. + ! + ! Raises: + ! If data writing is locked, this will result in an error. + ! + ! If the variable doesn't exist yet, and definitions are locked, + ! this will result in an error. + ! + ! If the amount of data in the chaninfo variable is already at + ! or exceeding nchans, this will result in an error. + ! + ! For string data, if the string length changes and the + ! definitions have already been locked, this will result in an + ! error. + ! + ! Also, for string data, if the string length changes and + ! trimming is turned off, this will also result in an error. + ! + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If nchans has not been set yet, this will result in an error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + interface nc_diag_chaninfo + module procedure nc_diag_chaninfo_byte, & + nc_diag_chaninfo_short, nc_diag_chaninfo_long, & + nc_diag_chaninfo_rsingle, nc_diag_chaninfo_rdouble, & + nc_diag_chaninfo_string + end interface nc_diag_chaninfo + + contains + ! Set the number of channels (nchans) for chaninfo to use for + ! variable storage and configuration. + ! + ! This set the number of channels (nchans) for all of the future + ! chaninfo variables that will be added. nchans will be used + ! as the number of elements to use for every chaninfo variable + ! added. It will also be used as a bounds check for variable + ! data amounts. + ! + ! Args: + ! nchans (integer(i_long)): the number of channels to use + ! for chaninfo. + ! + ! Raises: + ! If nchans was already set, this will result in an error. + ! (You can't change nchans arbitarily - otherwise, variable + ! data amounts could become invalid!) + ! + ! If the nchans specified is invalid (<1), this will result + ! in an error. If you have no chaninfo variables to write, + ! don't call this subroutine at all. No chaninfo variables + ! will be processed or written if you don't set anything! + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! See the called subroutines' documentation for details. + ! + subroutine nc_diag_chaninfo_dim_set(nchans) + integer(i_long), intent(in) :: nchans +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_chaninfo_dim_set(nchans = ", nchans, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Check if everything is initialized / file is open + if (init_done .AND. allocated(diag_chaninfo_store)) then + ! nchans can't be less than 1! + if (nchans < 1) then + call nclayer_error("Critical error - specified a nchan < 1!") + end if + + ! Is nchans already set? + if (diag_chaninfo_store%nchans /= -1) & + call nclayer_error("nchans already set!") + + ! Set nchans + diag_chaninfo_store%nchans = nchans + else + call nclayer_error("NetCDF4 layer not initialized yet!") + end if + end subroutine nc_diag_chaninfo_dim_set + + ! Set the allocation multiplier for chaninfo variable storage + ! allocation and reallocation. + ! + ! This sets the allocation multiplier (exponentiator?) for + ! chaninfo variable storage allocation and reallocation. + ! + ! Reallocation looks like this: + ! new_size = old_size + addl_num_entries + + ! (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** + ! diag_chaninfo_store%alloc_multi)) + ! + ! NLAYER_DEFAULT_ENT and NLAYER_MULTI_BASE are constants defined + ! in ncdw_types. The alloc_multi part is set with this + ! subroutine. + ! + ! As reallocation occurs, the alloc_multi continues to increase + ! by one, causing subsequent reallocations to allocate + ! exponentially more memory. + ! + ! You can use this subroutine to increase the initial amount of + ! memory allocated/reallocated, or you can use it to prevent + ! the reallocating counter from increasing by calling this + ! every so often. + ! + ! If this is not set, it will be initially set to 0 and will + ! increase from there. + ! + ! Args: + ! multiplier (integer(i_long)): the multiplier to use when + ! allocating or reallocating. + ! + ! Raises: + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! See the called subroutines' documentation for details. + ! + subroutine nc_diag_chaninfo_allocmulti(multiplier) + integer(i_long), intent(in) :: multiplier +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_chaninfo_allocmulti(multiplier = ", multiplier, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + if (init_done) then + ! # of times we needed to realloc simple metadata + ! also the multiplier factor for allocation (2^x) + diag_chaninfo_store%alloc_multi = multiplier + end if + end subroutine nc_diag_chaninfo_allocmulti + + ! Load chaninfo variable definitions from an existing, already + ! open NetCDF file. + ! + ! This will scan the currently open NetCDF file for chaninfo + ! variables. If any exist, the metadata and last position will + ! get loaded into the chaninfo variable data buffer. + ! + ! Basically, this scans for the "nchans" dimension. If it + ! exists, we set our internal nchans to that dimension's value. + ! Then we fetch the dimension names for all variables, and try + ! to match them to "nchans". (This is slow... see TODO.txt for + ! a better idea!) + ! + ! Once we find our chaninfo variable(s), we scan them for NetCDF + ! fill bytes, starting at the end of the variable. When we find + ! a spot that does NOT have a fill byte, we set our relative + ! index at that spot, and set everything up to resume at that + ! position. + ! + ! For string data, we also our maximum string length constraint + ! so that we still keep additional variable data within bounds. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! None + ! + ! Raises: + ! If the chaninfo variable uses an unsupported type (e.g. + ! not one of the types listed above), this will result in + ! an error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. (NetCDF error here, since + ! init_done is not being checked... see TODO.txt) + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_load_def + integer(i_long) :: ndims, nvars, var_index, type_index + integer(i_long) :: rel_index, i, j + + ! Temporary variables used when scanning variables and dimensions + ! from our NetCDF file + character(len=NF90_MAX_NAME) :: tmp_var_name + integer(i_long) :: tmp_var_type, tmp_var_ndims + + integer(i_long), dimension(:), allocatable :: tmp_var_dimids, tmp_var_dim_sizes + character(len=NF90_MAX_NAME) , allocatable :: tmp_var_dim_names(:) + + ! Is this a nchans var? + logical :: is_nchans_var + + ! Data buffers - we need these to fetch our data and see where + ! we left off... + integer(i_byte), dimension(:), allocatable :: byte_buffer + integer(i_short), dimension(:), allocatable :: short_buffer + integer(i_long), dimension(:), allocatable :: long_buffer + + real(r_single), dimension(:), allocatable :: rsingle_buffer + real(r_double), dimension(:), allocatable :: rdouble_buffer + + character(1), dimension(:,:), allocatable :: string_buffer + + ! Dimension checking NetCDF error storage + integer(i_long) :: dim_nc_err + + ! Get top level info about the file! + call nclayer_check(nf90_inquire(ncid, nDimensions = ndims, & + nVariables = nvars)) + + ! Fetch nchans first! + dim_nc_err = nf90_inq_dimid(ncid, "nchans", diag_chaninfo_store%nchans_dimid) + + ! Check if we found anything! + ! If we got NF90_EBADDIM, then exit. + if (dim_nc_err == NF90_EBADDIM) then + return + else if (dim_nc_err /= NF90_NOERR) then + ! If an error besides not finding the dimension occurs, + ! raise an exception. + call nclayer_check(dim_nc_err) + end if + + ! Then grab nchans value... + call nclayer_check(nf90_inquire_dimension(ncid, diag_chaninfo_store%nchans_dimid, & + len = diag_chaninfo_store%nchans)) + + ! Now search for variables that use nchans! + ! Loop through each variable! + do var_index = 1, nvars + ! Grab number of dimensions and attributes first + call nclayer_check(nf90_inquire_variable(ncid, var_index, name = tmp_var_name, ndims = tmp_var_ndims)) + + ! Allocate temporary variable dimids storage! + allocate(tmp_var_dimids(tmp_var_ndims)) + allocate(tmp_var_dim_names(tmp_var_ndims)) + allocate(tmp_var_dim_sizes(tmp_var_ndims)) + + ! Grab the actual dimension IDs and attributes + call nclayer_check(nf90_inquire_variable(ncid, var_index, dimids = tmp_var_dimids, & + xtype = tmp_var_type)) + + if ((tmp_var_ndims == 1) .OR. & + ((tmp_var_ndims == 2) .AND. (tmp_var_type == NF90_CHAR))) then + ! Reset our is_nchans_var switch to FALSE! + is_nchans_var = .FALSE. + + ! Fetch all dimension names for the dimensions in the + ! variable, and check if the variable is a nchans + ! variable. We do so by (slowly) checking all + ! dimension names and seeing if they match "nchans". + ! If they do, is_nchans_var is set to TRUE. + do i = 1, tmp_var_ndims + call nclayer_check(nf90_inquire_dimension(ncid, tmp_var_dimids(i), tmp_var_dim_names(i), & + tmp_var_dim_sizes(i))) + + if (tmp_var_dim_names(i) == "nchans") is_nchans_var = .TRUE. + end do + + if (is_nchans_var) then + ! Expand variable metadata first! + ! Make sure we have enough variable metadata storage + ! (and if not, reallocate!) + call nc_diag_chaninfo_expand + + ! Add to the total! + diag_chaninfo_store%total = diag_chaninfo_store%total + 1 + + ! Store name and type! + diag_chaninfo_store%names(diag_chaninfo_store%total) = trim(tmp_var_name) + + ! Reset relative index to zero... + rel_index = 0 + + ! For the rest of the code, we basically do the following: + ! -> We allocate a temporary data storage variable. + ! -> We set the NLAYER variable type for the variable. + ! -> We fetch all of the data for the variable. + ! -> We search, starting at the end of the variable, for + ! fill bytes. We keep going if we see filler bytes, and + ! stop when we encounter a non-fill byte. + ! -> Since the place we stop is where we last stored a value, + ! we set our relative index to the stopped index variable. + ! -> We deallocate our temporary data storage variable. + ! -> We set our type_index to update our data storage array count. + + if (tmp_var_type == NF90_BYTE) then + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_BYTE + call nc_diag_chaninfo_resize_byte(int8(diag_chaninfo_store%nchans), .FALSE.) + allocate(byte_buffer(diag_chaninfo_store%nchans)) + call nclayer_check(nf90_get_var(ncid, var_index, byte_buffer)) + + do j = diag_chaninfo_store%nchans, 1, -1 + if (byte_buffer(j) /= NLAYER_FILL_BYTE) then + exit + end if + end do + + rel_index = j + + deallocate(byte_buffer) + + type_index = 1 + else if (tmp_var_type == NF90_SHORT) then + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_SHORT + call nc_diag_chaninfo_resize_short(int8(diag_chaninfo_store%nchans), .FALSE.) + allocate(short_buffer(diag_chaninfo_store%nchans)) + call nclayer_check(nf90_get_var(ncid, var_index, short_buffer)) + + do j = diag_chaninfo_store%nchans, 1, -1 + if (short_buffer(j) /= NLAYER_FILL_SHORT) then + exit + end if + end do + + rel_index = j + + deallocate(short_buffer) + + type_index = 2 + else if (tmp_var_type == NF90_INT) then + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_LONG + call nc_diag_chaninfo_resize_long(int8(diag_chaninfo_store%nchans), .FALSE.) + allocate(long_buffer(diag_chaninfo_store%nchans)) + call nclayer_check(nf90_get_var(ncid, var_index, long_buffer)) + + do j = diag_chaninfo_store%nchans, 1, -1 + if (long_buffer(j) /= NLAYER_FILL_LONG) then + exit + end if + end do + + rel_index = j + + deallocate(long_buffer) + + type_index = 3 + else if (tmp_var_type == NF90_FLOAT) then + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_FLOAT + call nc_diag_chaninfo_resize_rsingle(int8(diag_chaninfo_store%nchans), .FALSE.) + allocate(rsingle_buffer(diag_chaninfo_store%nchans)) + call nclayer_check(nf90_get_var(ncid, var_index, rsingle_buffer)) + + do j = diag_chaninfo_store%nchans, 1, -1 + if (rsingle_buffer(j) /= NLAYER_FILL_FLOAT) then + exit + end if + end do + + rel_index = j + + deallocate(rsingle_buffer) + + type_index = 4 + else if (tmp_var_type == NF90_DOUBLE) then + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_DOUBLE + call nc_diag_chaninfo_resize_rdouble(int8(diag_chaninfo_store%nchans), .FALSE.) + allocate(rdouble_buffer(diag_chaninfo_store%nchans)) + call nclayer_check(nf90_get_var(ncid, var_index, rdouble_buffer)) + + do j = diag_chaninfo_store%nchans, 1, -1 + if (rdouble_buffer(j) /= NLAYER_FILL_DOUBLE) then + exit + end if + end do + + rel_index = j + + deallocate(rdouble_buffer) + + type_index = 5 + else if (tmp_var_type == NF90_CHAR) then + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_STRING + call nc_diag_chaninfo_resize_string(int8(diag_chaninfo_store%nchans), .FALSE.) + allocate(string_buffer(diag_chaninfo_store%nchans, tmp_var_dim_sizes(1))) + call nclayer_check(nf90_get_var(ncid, var_index, string_buffer)) + + do j = diag_chaninfo_store%nchans, 1, -1 + if (string_buffer(j, 1) /= NLAYER_FILL_CHAR) then + exit + end if + end do + + rel_index = j + + deallocate(string_buffer) + + ! Set max string length constraint + diag_chaninfo_store%max_str_lens(diag_chaninfo_store%total) = tmp_var_dim_sizes(1) + + type_index = 6 + else + ! The type is not supported by chaninfo - error! + call nclayer_error("NetCDF4 type invalid!") + end if + + print *, trim(tmp_var_name), "rel index", rel_index + + ! Now add a relative position... based on the next position! + + ! First, increment the number of variables stored for this type: + diag_chaninfo_store%acount_v(type_index) = diag_chaninfo_store%acount_v(type_index) + 1 + + ! Then, set the next variable's relative positioning, + ! based on the number of variables stored for this type. + diag_chaninfo_store%var_rel_pos(diag_chaninfo_store%total) = diag_chaninfo_store%acount_v(type_index) + + ! Initialize the amount of memory used to 0. + diag_chaninfo_store%var_usage(diag_chaninfo_store%total) = 0 + + ! Set relative index! + diag_chaninfo_store%rel_indexes(diag_chaninfo_store%total) = rel_index + + ! Set variable ID! Note that var_index here is the actual variable ID. + diag_chaninfo_store%var_ids(diag_chaninfo_store%total) = var_index + end if + + !call nc_diag_cat_metadata_add_var(trim(tmp_var_name), tmp_var_type, tmp_var_ndims, tmp_var_dim_names) + end if + + ! Deallocate + deallocate(tmp_var_dimids) + deallocate(tmp_var_dim_names) + deallocate(tmp_var_dim_sizes) + end do + + ! Set our definition lock! + diag_chaninfo_store%def_lock = .TRUE. + end subroutine nc_diag_chaninfo_load_def + + ! Write out chaninfo variable dimensions and variable + ! definitions to NetCDF via the NetCDF API. + ! + ! Commit the current variables and make them known to NetCDF to + ! allow chaninfo variable data writing. If successfully written, + ! this will always set the definition lock flag to prevent any + ! further changes. + ! + ! Definitions are only written once for every file opened, and + ! can not be modified or written again within the opened file. + ! This is enforced with a definition lock (def_lock) that is + ! set here and checked everywhere. + ! + ! If definitions are already locked, no additional definitions + ! will be created. Depending on conditions, the following may + ! occur: + ! + ! -> If the internal argument is defined and set to TRUE, no + ! error will be triggered. This is used internally by + ! nc_diag_write to prevent errors from occuring when the + ! lock may have already been set elsewhere. + ! + ! -> Otherwise, an error will be triggered, since the + ! definition write occurred when the definitions were + ! already written and locked. + ! + ! The inner workings: + ! + ! -> First and foremost, it performs sanity checks to ensure + ! that we have a file loaded. If the check fails, an error + ! occurs. + ! + ! -> It then checks to make sure we have chaninfo variables to + ! write in the first place. If we don't have any, we simply + ! return. + ! + ! -> We then do another sanity check to ensure that nchans is + ! defined. We probably shouldn't have any variables in the + ! first place if nchans isn't defined, but it doesn't hurt + ! to check! (If this check fails, we probably have a + ! serious bug...) + ! + ! -> If necessary (aka not in append mode, where this might + ! already exist), define the nchans dimension in NetCDF. + ! + ! -> For every variable, fetch the type and name of the + ! variable. If the variable is a string type, we also + ! figure out the maximum string length, and create an + ! extra dimension for that as well. Finally, we can go and + ! define the variable itself to NetCDF, with the variable's + ! respective dimensions (and NetCDF dimension IDs). + ! + ! -> We then add the variable to the varattr list to allow + ! variable attributes for the chaninfo variable. + ! + ! -> If we're not in append mode, we set the appropriate + ! chunking and compression settings for the variable to + ! make storing the data more efficient. + ! + ! -> After we've gone through all of the chaninfo variables, + ! we lock the definitions. That's it! + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! internal (logical, optional): whether or not to disable + ! triggering an error when a definition lock is + ! detected. This flag is used internally for the final + ! nc_diag_write, where this flag is purposely set to + ! avoid any errors with definition locking, since the + ! lock could have already been set earlier by + ! nc_diag_lock_def or others. + ! + ! Raises: + ! If definitions are already locked, and the internal + ! argument is not set or is not TRUE, this will result in an + ! error. + ! + ! If the nchans dimension hasn't been defined yet, this will + ! result in an error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_write_def(internal) + logical, intent(in), optional :: internal + + ! Just write the definitions out! + integer(i_llong) :: curdatindex + integer(i_byte) :: data_type + integer(i_long) :: data_type_index + character(len=100) :: data_name + integer(i_long) :: nc_data_type + + integer(i_long) :: tmp_dim_id + character(len=120) :: data_dim_name + + character(len=:), allocatable :: string_arr(:) + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + if (present(internal)) then + write(action_str, "(A, L, A)") "nc_diag_chaninfo_write_def(internal = ", internal, ")" + else + write(action_str, "(A)") "nc_diag_chaninfo_write_def(internal = (not specified))" + end if + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Ensure that we have a file open and that things are loaded! + if (init_done .AND. allocated(diag_chaninfo_store)) then + ! Ensure that we have at least one variable to store! + ! Otherwise, just return and do nothing. + if (diag_chaninfo_store%total > 0) then + ! Make sure nchans is defined before doing anything! + if (diag_chaninfo_store%nchans /= -1) then + ! Finally, make sure definitions are not locked! + if (.NOT. diag_chaninfo_store%def_lock) then + ! First, set the dimensions... if necessary! + if (.NOT. append_only) & + call nclayer_check(nf90_def_dim(ncid, "nchans", diag_chaninfo_store%nchans, diag_chaninfo_store%nchans_dimid)) + + ! Once we have the dimension, we can start writing + ! variable definitions! + do curdatindex = 1, diag_chaninfo_store%total + ! Fetch variable name and type: + data_name = diag_chaninfo_store%names(curdatindex) + data_type = diag_chaninfo_store%types(curdatindex) + + ! Figure out where our data is stored, given var_rel_pos + ! and nchans... (see equation/discussion above for more + ! details!) + data_type_index = 1 + & + ((diag_chaninfo_store%var_rel_pos(curdatindex) - 1) * diag_chaninfo_store%nchans) + + call nclayer_info("chaninfo: defining " // trim(data_name)) + + ! Map our NLAYER type to the NF90 NetCDF native type! + if (data_type == NLAYER_BYTE) nc_data_type = NF90_BYTE + if (data_type == NLAYER_SHORT) nc_data_type = NF90_SHORT + if (data_type == NLAYER_LONG) nc_data_type = NF90_INT + if (data_type == NLAYER_FLOAT) nc_data_type = NF90_FLOAT + if (data_type == NLAYER_DOUBLE) nc_data_type = NF90_DOUBLE + if (data_type == NLAYER_STRING) nc_data_type = NF90_CHAR + +#ifdef _DEBUG_MEM_ + print *, "chaninfo part 1" +#endif + + ! If our variable type is a string, we need to compute the maximum + ! string length. + ! + ! If we're trimming, we take the maximum of the length of strings + ! in the variable, and use that as our maximum string length. + ! + ! Otherwise, we simply use the previously defined fixed length, + ! which is already stored as the maximum string length from the + ! initial string add. + ! + ! Once we know our maximum string length, we add that as a + ! dimension, and use it (along with our nchans dimension) to + ! create our string chaninfo variable! + + if (data_type == NLAYER_STRING) then + ! Figure out the dimension name for this chaninfo variable + write (data_dim_name, "(A, A)") trim(data_name), "_maxstrlen" + + ! Assume that the maximum string length is 10000 + ! Allocate an array of 10000, with a size of the + ! variable's var_usage + allocate(character(10000) :: string_arr(diag_chaninfo_store%var_usage(curdatindex))) + + ! Fetch the strings from our variable storage + string_arr = diag_chaninfo_store%ci_string(data_type_index:(data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1)) + + ! If trimming is enabled, we haven't found our max_str_len yet. + ! Go find it! + if (enable_trim) then + ! Save the max string len + diag_chaninfo_store%max_str_lens(curdatindex) = & + max_len_string_array(string_arr, diag_chaninfo_store%var_usage(curdatindex)) + end if + + ! Add our custom string dimension to NetCDF, if necessary + if (.NOT. append_only) & + call nclayer_check(nf90_def_dim(ncid, data_dim_name, & + diag_chaninfo_store%max_str_lens(curdatindex), & + tmp_dim_id)) +#ifdef _DEBUG_MEM_ + print *, "Defining char var type..." +#endif + ! Add our string variable to NetCDF! + if (.NOT. append_only) & + call nclayer_check(nf90_def_var(ncid, diag_chaninfo_store%names(curdatindex), & + nc_data_type, (/ tmp_dim_id, diag_chaninfo_store%nchans_dimid /), & + diag_chaninfo_store%var_ids(curdatindex))) +#ifdef _DEBUG_MEM_ + print *, "Done defining char var type..." +#endif + ! Deallocate temp string array + deallocate(string_arr) + else + ! Nothing fancy here! + ! Just add our non-string variable to NetCDF! + if (.NOT. append_only) & + call nclayer_check(nf90_def_var(ncid, diag_chaninfo_store%names(curdatindex), & + nc_data_type, diag_chaninfo_store%nchans_dimid, & + diag_chaninfo_store%var_ids(curdatindex))) + end if + +#ifdef _DEBUG_MEM_ + print *, "chaninfo part 2" +#endif + + ! Make our variable known to varattr - add it to the varattr database! + call nc_diag_varattr_add_var(diag_chaninfo_store%names(curdatindex), & + diag_chaninfo_store%types(curdatindex), & + diag_chaninfo_store%var_ids(curdatindex)) + + ! If we are not appending, make sure to also set chunking and + ! compression for efficiency + optimization! + if (.NOT. append_only) then + ! If we're storing a string, we need to specify both dimensions + ! for our chunking parameters. Otherwise, we just need to + ! specify nchans... + if (data_type == NLAYER_STRING) then + call nclayer_check(nf90_def_var_chunking(ncid, diag_chaninfo_store%var_ids(curdatindex), & + NF90_CHUNKED, (/ diag_chaninfo_store%max_str_lens(curdatindex), diag_chaninfo_store%nchans /))) + else + call nclayer_check(nf90_def_var_chunking(ncid, diag_chaninfo_store%var_ids(curdatindex), & + NF90_CHUNKED, (/ diag_chaninfo_store%nchans /))) + end if + + ! Enable zlib (gzip-like) compression based on our level settings + call nclayer_check(nf90_def_var_deflate(ncid, diag_chaninfo_store%var_ids(curdatindex), & + 1, 1, int(NLAYER_COMPRESSION))) + end if + end do + + ! Lock the definitions! + diag_chaninfo_store%def_lock = .TRUE. + else + ! Show an error message if we didn't suppress errors on purpose + if(.NOT. present(internal)) & + call nclayer_error("Can't write definitions - definitions have already been written and locked!") + end if + else + call nclayer_error("Can't write definitions - number of chans not set yet!") + end if + + ! End: if (diag_chaninfo_store%total > 0) + end if + else + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + end if + end subroutine nc_diag_chaninfo_write_def + + ! Write all of the currently stored chaninfo data to NetCDF via + ! the NetCDF APIs ("put"). + ! + ! This will go through all of the variables stored in chaninfo, + ! and write their data to NetCDF. + ! + ! Buffer flushing mode is enabled if flush_data_only is set and + ! is TRUE. Otherwise, this will operate normally. + ! + ! For buffer flushing mode, data locking will not be performed. + ! Instead, it "flushes" the variable storage buffer. For all + ! of the variables stored, it increments the relative index of + ! the variable with the amount of data currently stored in the + ! variable. + ! + ! (Essentially, new_rel_index = old_rel_index + var_data_count) + ! + ! Recall that the relative index stores the position of the last + ! data entered for the variable. This is set by write_data, as + ! well as load_def for the data append mode. In turn, write_data + ! also uses it to store at the correct position. + ! + ! We also reset the var_usage, or the variable memory usage + ! counter, back to zero to allow data storage to start at the + ! beginning again. We use var_usage in write_data and in the + ! storage subroutines to keep track of how much data we're + ! storing, and how much we need to "read" from the array to + ! store the data in NetCDF4 efficiently and within bounds. + ! + ! A quick example: + ! -> If we have 2 elements, var_usage (variable memory usage) + ! is initially 2, and rel_index (variable relative index, + ! or our starting position) is initially 0. + ! + ! -> We flush the buffer. Since we flushed our buffer, + ! var_usage is reset to 0, and rel_index is now 2 since + ! we stored 2 elements. + ! + ! -> If we add 3 elements, we get a var_usage of 3 (for 3 + ! elements stored), and rel_index stays the same (2). + ! + ! -> When we finally flush or write, this time we know to + ! start at element number 3 (rel_index), and we know to + ! write 3 elements from there (var_usage). + ! + ! -> We now have a total of 5 elements! Indicies 1-2 were + ! stored with the flush, and indicies 3-5 were stored + ! afterwards - all thanks to buffer flushing! + ! + ! Finally, if data flushing mode is enabled, the data_lock is + ! not set to allow additional data to be written in the future. + ! + ! However, if data flushing mode is not set, or it is disabled, + ! we assume that we are writing only one more time (or once, + ! depending on if buffer flushing was ever enabled or not). + ! Therefore, we set the data_lock (data writing lock) to TRUE + ! in this case, assuming data writing was successful. + ! + ! If data writing has already been locked, this will error. + ! + ! If data flushing mode is disabled, we will also check to see + ! if each variable's data fills up the nchans dimension. + ! + ! Depending on the strictness (strict_check), if the data is + ! not filled to the nchans dimension, it could either result in + ! an error (if strict_check is TRUE), or a warning (if + ! strict_check is FALSE). + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! flush_data_only (logical, optional): whether to only flush + ! the chaninfo data buffers or not. If we flush data, + ! data locking will not be set. + ! + ! Raises: + ! If data writing has already been locked, and the data + ! flushing argument is not set or is not TRUE, this will + ! result in an error. + ! + ! If the nchans dimension hasn't been defined yet, this will + ! result in an error. + ! + ! If strict checking (strict_check) is enabled, and a + ! variable's data doesn't fill to the nchans dimension, + ! this will result in an error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_write_data(flush_data_only) + ! Optional internal flag to only flush data - if this is + ! true, data flushing will be performed, and the data will + ! NOT be locked. + logical, intent(in), optional :: flush_data_only + + integer(i_byte) :: data_type + integer(i_long) :: data_type_index + character(len=100) :: data_name + + character(len=1000) :: nchan_empty_msg + + integer(i_llong) :: curdatindex, j + integer(i_long) :: string_arr_maxlen + + character(len=:), allocatable :: string_arr(:) + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + if (present(flush_data_only)) then + write(action_str, "(A, L, A)") "nc_diag_chaninfo_write_data(flush_data_only = ", flush_data_only, ")" + else + write(action_str, "(A)") "nc_diag_chaninfo_write_data(flush_data_only = (not specified))" + end if + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Check to make sure a file is open / things are loaded! + if (init_done .AND. allocated(diag_chaninfo_store)) then + ! Check to see if we have any variables to write in the + ! first place! + if (diag_chaninfo_store%total > 0) then + ! Check to make sure that we have nchans defined! + if (diag_chaninfo_store%nchans /= -1) then + ! Check if we can still write any data! + if (.NOT. diag_chaninfo_store%data_lock) then + ! Iterate through all of our variables! + do curdatindex = 1, diag_chaninfo_store%total + ! Fetch the variable's name and type! + data_name = diag_chaninfo_store%names(curdatindex) + data_type = diag_chaninfo_store%types(curdatindex) + + ! Figure out where our data is stored, given var_rel_pos + ! and nchans... (see equation/discussion above for more + ! details!) + data_type_index = 1 + & + ((diag_chaninfo_store%var_rel_pos(curdatindex) - 1) * diag_chaninfo_store%nchans) + + call nclayer_info("chaninfo: writing " // trim(data_name)) + + ! Warn about low data filling... but only if we are finishing + ! our data write (or writing once) - basically, we're NOT in + ! flushing data mode! + if ((.NOT. (present(flush_data_only) .AND. flush_data_only)) .AND. & + ((diag_chaninfo_store%var_usage(curdatindex) + & + diag_chaninfo_store%rel_indexes(curdatindex)) < diag_chaninfo_store%nchans)) then + ! NOTE - I0 and TRIM are Fortran 95 specs + write (nchan_empty_msg, "(A, A, A, I0, A, I0, A)") "Amount of data written in ", & + trim(data_name), " (", & + diag_chaninfo_store%var_usage(curdatindex) + & + diag_chaninfo_store%rel_indexes(curdatindex), & + ")" // char(10) // & + " is less than nchans (", diag_chaninfo_store%nchans, ")!" + + ! If we are set to strict checking mode, error. + ! Otherwise, just show a warning. + if (diag_chaninfo_store%strict_check) then + call nclayer_error(trim(nchan_empty_msg)) + else + call nclayer_warning(trim(nchan_empty_msg)) + end if + end if + +#ifdef _DEBUG_MEM_ + print *, "****** Processing ******" + print *, "data_name:" + print *, data_name + print *, "data_type:" + print *, data_type + print *, "data_type_index:" + print *, data_type_index + print *, "diag_chaninfo_store%var_ids(curdatindex):" + print *, diag_chaninfo_store%var_ids(curdatindex) + print *, "diag_chaninfo_store%var_usage(curdatindex):" + print *, diag_chaninfo_store%var_usage(curdatindex) + print *, "Upper range (data_type_index + &" + print *, " diag_chaninfo_store%var_usage(curdatindex) - 1):" + print *, (data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1) +#endif + ! Make sure we have variable data to write in the first place! + ! + ! If we do, we essentially: + ! + ! -> Find the right type to save to. + ! + ! -> If we are NOT storing a string, we just store a subsection + ! of our variable storage array at (1 + rel_index) in the + ! NetCDF variable. + ! + ! -> If we are storing a string, we create our own array to + ! store all of our strings in to standardize the length + ! (e.g. a 3, 4, and 5 character string is expanded to + ! a 5, 5, and 5 character string array). This is needed + ! to store all strings at once and match the NetCDF bounds. + ! Once done, the array is sent through the NetCDF API for + ! data storage. We deallocate the array once we're done! + ! + if (diag_chaninfo_store%var_usage(curdatindex) > 0) then + if (data_type == NLAYER_BYTE) then +#ifdef _DEBUG_MEM_ + print *, "Resulting data to be stored:" + print *, diag_chaninfo_store%ci_byte(data_type_index:(data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1)) +#endif + call nclayer_check(nf90_put_var(ncid, diag_chaninfo_store%var_ids(curdatindex), & + diag_chaninfo_store%ci_byte(data_type_index:(data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1)), & + start = (/ 1 + diag_chaninfo_store%rel_indexes(curdatindex) /) & + )) + else if (data_type == NLAYER_SHORT) then + call nclayer_check(nf90_put_var(ncid, diag_chaninfo_store%var_ids(curdatindex), & + diag_chaninfo_store%ci_short(data_type_index:(data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1)), & + start = (/ 1 + diag_chaninfo_store%rel_indexes(curdatindex) /) & + )) + else if (data_type == NLAYER_LONG) then +#ifdef _DEBUG_MEM_ + print *, "Resulting data to be stored:" + print *, diag_chaninfo_store%ci_long(data_type_index:(data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1)) + print *, "start index:" + print *, 1 + diag_chaninfo_store%rel_indexes(curdatindex) +#endif + call nclayer_check(nf90_put_var(ncid, diag_chaninfo_store%var_ids(curdatindex), & + diag_chaninfo_store%ci_long(data_type_index:(data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1)), & + start = (/ 1 + diag_chaninfo_store%rel_indexes(curdatindex) /) & + )) + else if (data_type == NLAYER_FLOAT) then + call nclayer_check(nf90_put_var(ncid, diag_chaninfo_store%var_ids(curdatindex), & + diag_chaninfo_store%ci_rsingle(data_type_index:(data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1)), & + start = (/ 1 + diag_chaninfo_store%rel_indexes(curdatindex) /) & + )) + else if (data_type == NLAYER_DOUBLE) then + call nclayer_check(nf90_put_var(ncid, diag_chaninfo_store%var_ids(curdatindex), & + diag_chaninfo_store%ci_rdouble(data_type_index:(data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1)), & + start = (/ 1 + diag_chaninfo_store%rel_indexes(curdatindex) /) & + )) + else if (data_type == NLAYER_STRING) then + ! Storing to another variable may seem silly, but it's necessary + ! to avoid "undefined variable" errors, thanks to the compiler's + ! super optimization insanity... + string_arr_maxlen = diag_chaninfo_store%max_str_lens(curdatindex) + allocate(character(string_arr_maxlen) :: & + string_arr(diag_chaninfo_store%var_usage(curdatindex))) + if (enable_trim) then + do j = data_type_index, data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1 + string_arr(j - data_type_index + 1) = & + trim(diag_chaninfo_store%ci_string(j)) + end do + +#ifdef _DEBUG_MEM_ + do j = 1, diag_chaninfo_store%var_usage(curdatindex) + write (*, "(A, A, A)") "String: '", string_arr(j), "'" + end do + + write (*, "(A, I0)") "string_arr_maxlen = ", string_arr_maxlen + write (*, "(A, I0)") "diag_chaninfo_store%var_usage(curdatindex) = ", diag_chaninfo_store%var_usage(curdatindex) +#endif + else + do j = data_type_index, data_type_index + & + diag_chaninfo_store%var_usage(curdatindex) - 1 + string_arr(j - data_type_index + 1) = & + diag_chaninfo_store%ci_string(j) + end do + end if + + call nclayer_check(nf90_put_var(ncid, diag_chaninfo_store%var_ids(curdatindex), & + string_arr, & + start = (/ 1, 1 + diag_chaninfo_store%rel_indexes(curdatindex) /), & + count = (/ string_arr_maxlen, & + diag_chaninfo_store%var_usage(curdatindex) /) )) + + deallocate(string_arr) + else + call nclayer_error("Critical error - unknown variable type!") + end if + + ! Check for data flushing, and if so, update the relative indexes + ! and set var_usage to 0. + if (present(flush_data_only) .AND. flush_data_only) then + diag_chaninfo_store%rel_indexes(curdatindex) = & + diag_chaninfo_store%rel_indexes(curdatindex) + & + diag_chaninfo_store%var_usage(curdatindex) + diag_chaninfo_store%var_usage(curdatindex) = 0 + +#ifdef _DEBUG_MEM_ + print *, "diag_chaninfo_store%rel_indexes(curdatindex) is now:" + print *, diag_chaninfo_store%rel_indexes(curdatindex) +#endif + end if + end if + end do + + ! If we're flushing data, don't do anything... + if (present(flush_data_only) .AND. flush_data_only) then +#ifdef _DEBUG_MEM_ + print *, "In buffer flush mode!" +#endif + else + ! Otherwise, lock data writing! Note that we do this, + ! even if we have no data! + diag_chaninfo_store%data_lock = .TRUE. +#ifdef _DEBUG_MEM_ + print *, "In data lock mode!" +#endif + end if + else + call nclayer_error("Can't write data - data have already been written and locked!") + end if + else + call nclayer_error("Can't write data - number of chans not set yet!") + end if + end if + else + call nclayer_error("Can't write data - NetCDF4 layer not initialized yet!") + end if + + end subroutine nc_diag_chaninfo_write_data + + ! Set the strict mode for chaninfo variables. + ! + ! This sets the mode that determines how strict chaninfo's + ! variable consistency checks will be. + ! + ! During the final data write (nc_diag_chaninfo_write_data, + ! without the buffering flag), chaninfo will check to see if all + ! of the variables are filled, e.g. all variables have been + ! stored up to nchans dimension. + ! + ! If there are any variables that are not completely filled to + ! the nchans dimension, one of the following may occur: + ! + ! -> If strict mode is enabled, a consistency check error will + ! occur and the program will exit. + ! + ! -> If strict mode is disabled, this will only result in a + ! consistency check warning. After the warning is + ! displayed, normal operation will occur, including data + ! writing. For values that are not in the variable (up to + ! the nchans dimension), missing values will be placed. + ! + ! By default, strict mode is disabled. + ! + ! Since the strict mode is bound to the chaninfo type, it can + ! only be set when a file is open and when diag_chaninfo_store + ! is initialized. (It should be initialized if a file is open!) + ! + ! If there isn't a file open / diag_chaninfo_store isn't + ! initialized, an error will occur. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! enable_strict (logical): boolean indicating whether to + ! enable strict mode or not. If set to TRUE, strict mode + ! will be enabled. Otherwise, it will be disabled. + ! + ! Raises: + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! See the called subroutines' documentation for details. + ! + subroutine nc_diag_chaninfo_set_strict(enable_strict) + logical, intent(in) :: enable_strict + + if (init_done .AND. allocated(diag_chaninfo_store)) then + diag_chaninfo_store%strict_check = enable_strict + else + call nclayer_error("Can't set strictness level for chaninfo - NetCDF4 layer not initialized yet!") + end if + end subroutine nc_diag_chaninfo_set_strict + + ! Preallocate variable metadata storage (names, types, etc.). + ! + ! This preallocates variable metadata storage for a given number + ! of variables. + ! + ! If properly defined, this can speed up chaninfo variable + ! creation since reallocation will (hopefully) not be necessary + ! for variable metadata storage, since it was preallocated here. + ! + ! Variable metadata includes storing the variables' names, + ! types, indicies, usage counts, etc. The metadata pre-allocated + ! here is essentially the variable indexed arrays within our + ! specific storage type! + ! + ! Args: + ! num_of_addl_vars (integer(i_llong)): the number of + ! additional variables to preallocate metadata storage + ! for. + ! + ! Raises: + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_prealloc_vars(num_of_addl_vars) + integer(i_llong), intent(in) :: num_of_addl_vars +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_chaninfo_prealloc_vars(num_of_addl_vars = ", num_of_addl_vars, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + if (init_done .AND. allocated(diag_chaninfo_store)) then + ! For all variable metadata fields: + ! -> Check if the field is allocated. + ! -> If not, allocate it with the default initial + ! size, plus the number of additional variables + ! specified in the argument. + ! -> If it's allocated, check to see if the total + ! number of variables exceeds our field's allocated + ! size. + ! -> If the size is exceeded, reallocate the field + ! with the number of additional variables specified + ! in the argument. + ! + if (allocated(diag_chaninfo_store%names)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%names)) then + call nc_diag_realloc(diag_chaninfo_store%names, num_of_addl_vars) + end if + else + allocate(diag_chaninfo_store%names(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + end if + + if (allocated(diag_chaninfo_store%types)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%types)) then + call nc_diag_realloc(diag_chaninfo_store%types, num_of_addl_vars) + end if + else + allocate(diag_chaninfo_store%types(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + end if + + if (allocated(diag_chaninfo_store%var_rel_pos)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%var_rel_pos)) then + call nc_diag_realloc(diag_chaninfo_store%var_rel_pos, num_of_addl_vars) + end if + else + allocate(diag_chaninfo_store%var_rel_pos(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_chaninfo_store%var_rel_pos = -1 + end if + + if (allocated(diag_chaninfo_store%var_usage)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%var_usage)) then + call nc_diag_realloc(diag_chaninfo_store%var_usage, num_of_addl_vars) + end if + else + allocate(diag_chaninfo_store%var_usage(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_chaninfo_store%var_usage = 0 + end if + + if (allocated(diag_chaninfo_store%var_ids)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%var_ids)) then + call nc_diag_realloc(diag_chaninfo_store%var_ids, num_of_addl_vars) + end if + else + allocate(diag_chaninfo_store%var_ids(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_chaninfo_store%var_ids = -1 + end if + + if (allocated(diag_chaninfo_store%max_str_lens)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%max_str_lens)) then + call nc_diag_realloc(diag_chaninfo_store%max_str_lens, num_of_addl_vars) + end if + else + allocate(diag_chaninfo_store%max_str_lens(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_chaninfo_store%max_str_lens = -1 + end if + + if (allocated(diag_chaninfo_store%rel_indexes)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%rel_indexes)) then + call nc_diag_realloc(diag_chaninfo_store%rel_indexes, num_of_addl_vars) + end if + else + allocate(diag_chaninfo_store%rel_indexes(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_chaninfo_store%rel_indexes = 0 + end if + else + call nclayer_error("NetCDF4 layer not initialized yet!") + endif + end subroutine nc_diag_chaninfo_prealloc_vars + + ! Preallocate actual variable data storage - the data itself. + ! + ! This preallocates the variable data storage for a given + ! variable type, and a given number of data elements or slots. + ! + ! If properly defined, this can speed up chaninfo variable + ! data insertion since reallocation will (hopefully) not be + ! necessary for variable data storage, since it was preallocated + ! here. + ! + ! For example, if you have 10 float chaninfo variables, and + ! nchans is 20, you can call: + ! + ! nc_diag_chaninfo_prealloc_vars_storage(NLAYER_FLOAT, 200) + ! + ! Assuming that no other float chaninfo variables get added, + ! no reallocations should occur, therefore speeding up the + ! variable data insertion process! + ! + ! Note that this is a state-based subroutine call - by design, + ! it preallocates the largest amount provided. For instance, if + ! you attempted to preallocate 10 floats, then 9000 floats, then + ! 5 floats, 20 floats will be preallocated. + ! + ! Specifically, it looks like this: + ! + ! -> Preallocate 10 floats - nothing allocated, so 10 floats + ! allocated. + ! + ! -> Preallocate 9000 floats - only 10 floats allocated, so + ! reallocating to 9000. + ! + ! -> Preallocate 20 floats - 9000 floats already allocated, so + ! no need to do anything. + ! + ! Args: + ! nclayer_type (integer(i_byte)): the type of variable to + ! preallocate data elements/slots for. + ! num_of_addl_slots (integer(i_llong)): the number of + ! additional variable data elements/slots to + ! preallocate. + ! + ! Raises: + ! If the variable type is invalid, this will result in an + ! error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_prealloc_vars_storage(nclayer_type, num_of_addl_slots) + integer(i_byte), intent(in) :: nclayer_type + integer(i_llong), intent(in) :: num_of_addl_slots + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A, I0, A)") "nc_diag_chaninfo_prealloc_vars_storage(nclayer_type = ", nclayer_type, ", num_of_addl_slots = ", num_of_addl_slots, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Find the type specified, and attempt to pre-allocate. + ! Note that FALSE is specified as an argument to ensure that + ! the actual variable data storage usage count isn't + ! incremented, since we're just preallocating here. + ! + if (nclayer_type == NLAYER_BYTE) then + call nc_diag_chaninfo_resize_byte(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_SHORT) then + call nc_diag_chaninfo_resize_short(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_LONG) then + call nc_diag_chaninfo_resize_long(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_FLOAT) then + call nc_diag_chaninfo_resize_rsingle(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_DOUBLE) then + call nc_diag_chaninfo_resize_rdouble(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_STRING) then + call nc_diag_chaninfo_resize_string(num_of_addl_slots, .FALSE.) + else + call nclayer_error("Invalid type specified for variable storage preallocation!") + end if + end subroutine nc_diag_chaninfo_prealloc_vars_storage + + ! Expand variable metadata storage (names, types, etc.) for one + ! single variable. + ! + ! This ensures that there is enough variable metadata storage to + ! add a single variable. If there isn't enough storage, it will + ! reallocate as necessary. See this module's header for more + ! information about how memory allocation works for variable + ! metadata storage. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! num_of_addl_vars (integer(i_llong)): the number of + ! additional variables to preallocate metadata storage + ! for. + ! + ! Raises: + ! If nchans has not been set yet, this will result in an + ! error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_expand + integer(i_llong) :: addl_fields + ! Did we realloc at all? + logical :: meta_realloc + meta_realloc = .FALSE. + + if (init_done .AND. allocated(diag_chaninfo_store)) then + addl_fields = 1 + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_chaninfo_store%alloc_multi)) + if (diag_chaninfo_store%nchans /= -1) then + + ! For all variable metadata fields: + ! -> Check if the field is allocated. + ! -> If not, allocate it with the default initial + ! size, and initialize it with blank values! + ! -> If it's allocated, check to see if the total + ! number of variables exceeds our field's + ! allocated size. + ! -> If the size is exceeded, reallocate the + ! field, and indicate that a reallocation has + ! occurred. + ! + if (allocated(diag_chaninfo_store%names)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%names)) then + call nc_diag_realloc(diag_chaninfo_store%names, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_chaninfo_store%names(NLAYER_DEFAULT_ENT)) + end if + + if (allocated(diag_chaninfo_store%types)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%types)) then + call nc_diag_realloc(diag_chaninfo_store%types, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_chaninfo_store%types(NLAYER_DEFAULT_ENT)) + end if + + if (allocated(diag_chaninfo_store%var_rel_pos)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%var_rel_pos)) then + call nc_diag_realloc(diag_chaninfo_store%var_rel_pos, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_chaninfo_store%var_rel_pos(NLAYER_DEFAULT_ENT)) + diag_chaninfo_store%var_rel_pos = -1 + end if + + if (allocated(diag_chaninfo_store%var_usage)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%var_usage)) then + call nc_diag_realloc(diag_chaninfo_store%var_usage, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_chaninfo_store%var_usage(NLAYER_DEFAULT_ENT)) + diag_chaninfo_store%var_usage = 0 + end if + + if (allocated(diag_chaninfo_store%var_ids)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%var_ids)) then + call nc_diag_realloc(diag_chaninfo_store%var_ids, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_chaninfo_store%var_ids(NLAYER_DEFAULT_ENT)) + diag_chaninfo_store%var_ids = -1 + end if + + if (allocated(diag_chaninfo_store%max_str_lens)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%max_str_lens)) then + call nc_diag_realloc(diag_chaninfo_store%max_str_lens, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_chaninfo_store%max_str_lens(NLAYER_DEFAULT_ENT)) + diag_chaninfo_store%max_str_lens = -1 + end if + + if (allocated(diag_chaninfo_store%rel_indexes)) then + if (diag_chaninfo_store%total >= size(diag_chaninfo_store%rel_indexes)) then + call nc_diag_realloc(diag_chaninfo_store%rel_indexes, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_chaninfo_store%rel_indexes(NLAYER_DEFAULT_ENT)) + diag_chaninfo_store%rel_indexes = 0 + end if + + ! If reallocation occurred, increment our multiplier + ! to allocate more and speed things up in the + ! future! + if (meta_realloc) then + diag_chaninfo_store%alloc_multi = diag_chaninfo_store%alloc_multi + 1 + end if + else + call nclayer_error("Number of chans not set yet!") + end if + else + call nclayer_error("NetCDF4 layer not initialized yet!") + end if + end subroutine nc_diag_chaninfo_expand + + ! Add a single scalar byte integer to the given chaninfo + ! variable. + ! + ! This adds a single value to the specified chaninfo variable. + ! + ! If the variable does not already exist, it will be created, + ! and the value will be inserted as the variable's first + ! element. + ! + ! Otherwise, the value will be inserted to the next empty spot. + ! + ! Values are inserted in the order of the calls made. As such, + ! this subroutine is best designed to be used in a loop, where + ! for every channel iteration, a value is added using this + ! subroutine. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! (You should use the generic nc_diag_chaninfo + ! instead!) + ! + ! Args: + ! chaninfo_name (character(len=*)): the chaninfo variable + ! to store to. + ! chaninfo_value (integer(i_byte)): the value to store. + ! + ! Raises: + ! If the data has already been locked, this will result in + ! an error. + ! + ! If definitions have already been locked, and a new + ! variable is being created, this will result in an error. + ! + ! If the variable is already full (e.g. it has nchans number + ! of elements), this will result in an error. + ! + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If nchans has not been set yet, this will result in an + ! error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_byte(chaninfo_name, chaninfo_value) + character(len=*), intent(in) :: chaninfo_name + integer(i_byte), intent(in) :: chaninfo_value + + integer(i_long) :: i, var_index, var_rel_index, type_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_chaninfo_byte(chaninfo_name = " // chaninfo_name // ", chaninfo_value = ", chaninfo_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Make sure that data hasn't been locked + if (diag_chaninfo_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + ! For byte, type index is 1 + type_index = 1 + + ! Default to -1 + var_index = -1 + + ! Attempt to match the variable name + fetch the variable + ! index first! + do i = 1, diag_chaninfo_store%total + if (diag_chaninfo_store%names(i) == chaninfo_name) then + var_rel_index = diag_chaninfo_store%var_rel_pos(i) + var_index = i + exit + end if + end do + + if (var_index == -1) then + ! Entry does not exist yet... + + ! First, check to make sure we can still define new variables. + if (diag_chaninfo_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + ! Expand variable metadata first! + ! Make sure we have enough variable metadata storage + ! (and if not, reallocate!) + call nc_diag_chaninfo_expand + + ! Add to the total! + diag_chaninfo_store%total = diag_chaninfo_store%total + 1 + + ! Store name and type! + diag_chaninfo_store%names(diag_chaninfo_store%total) = chaninfo_name + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_BYTE + + ! We just need to add one entry... + ! Call resize subroutine to ensure we have enough space + ! (and if not, realloc!) + call nc_diag_chaninfo_resize_byte(int8(diag_chaninfo_store%nchans)) + + ! Now add a relative position... based on the next position! + + ! First, increment the number of variables stored for this type: + diag_chaninfo_store%acount_v(type_index) = diag_chaninfo_store%acount_v(type_index) + 1 + + ! Then, set the next variable's relative positioning, + ! based on the number of variables stored for this type. + diag_chaninfo_store%var_rel_pos(diag_chaninfo_store%total) = diag_chaninfo_store%acount_v(type_index) + + ! Initialize the amount of memory used to 1. + diag_chaninfo_store%var_usage(diag_chaninfo_store%total) = 1 + + ! Set var_index to the total + var_index = diag_chaninfo_store%total + else + ! Variable already exists! + + ! Check to make sure we can fit more data! + ! (# data < nchans) + if (diag_chaninfo_store%var_usage(var_index) + & + diag_chaninfo_store%rel_indexes(var_index) >= diag_chaninfo_store%nchans) then + call nclayer_error("Can't add new data - data added is exceeding nchan! Data must fit within nchan constraint.") + endif + + ! Increment current variable count + diag_chaninfo_store%var_usage(var_index) = & + diag_chaninfo_store%var_usage(var_index) + 1 + end if + + ! Now add the actual entry! + diag_chaninfo_store%ci_byte(1 + & + ((diag_chaninfo_store%var_rel_pos(var_index) - 1) & + * diag_chaninfo_store%nchans) & + + (diag_chaninfo_store%var_usage(var_index) - 1)) = chaninfo_value + end subroutine nc_diag_chaninfo_byte + + ! Add a single scalar short integer to the given chaninfo + ! variable. + ! + ! This adds a single value to the specified chaninfo variable. + ! + ! If the variable does not already exist, it will be created, + ! and the value will be inserted as the variable's first + ! element. + ! + ! Otherwise, the value will be inserted to the next empty spot. + ! + ! Values are inserted in the order of the calls made. As such, + ! this subroutine is best designed to be used in a loop, where + ! for every channel iteration, a value is added using this + ! subroutine. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! (You should use the generic nc_diag_chaninfo + ! instead!) + ! + ! Args: + ! chaninfo_name (character(len=*)): the chaninfo variable + ! to store to. + ! chaninfo_value (integer(i_short)): the value to store. + ! + ! Raises: + ! If the data has already been locked, this will result in + ! an error. + ! + ! If definitions have already been locked, and a new + ! variable is being created, this will result in an error. + ! + ! If the variable is already full (e.g. it has nchans number + ! of elements), this will result in an error. + ! + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If nchans has not been set yet, this will result in an + ! error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_short(chaninfo_name, chaninfo_value) + character(len=*), intent(in) :: chaninfo_name + integer(i_short), intent(in) :: chaninfo_value + + integer(i_long) :: i, var_index, var_rel_index, type_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_chaninfo_short(chaninfo_name = " // chaninfo_name // ", chaninfo_value = ", chaninfo_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Make sure that data hasn't been locked + if (diag_chaninfo_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + ! For short, type index is 2 + type_index = 2 + + ! Default to -1 + var_index = -1 + + ! Attempt to match the variable name + fetch the variable + ! index first! + do i = 1, diag_chaninfo_store%total + if (diag_chaninfo_store%names(i) == chaninfo_name) then + var_rel_index = diag_chaninfo_store%var_rel_pos(i) + var_index = i + exit + end if + end do + + if (var_index == -1) then + ! Entry does not exist yet... + + ! First, check to make sure we can still define new variables. + if (diag_chaninfo_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + ! Expand variable metadata first! + ! Make sure we have enough variable metadata storage + ! (and if not, reallocate!) + call nc_diag_chaninfo_expand + + ! Add to the total! + diag_chaninfo_store%total = diag_chaninfo_store%total + 1 + + ! Store name and type! + diag_chaninfo_store%names(diag_chaninfo_store%total) = chaninfo_name + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_SHORT + + ! We just need to add one entry... + ! Call resize subroutine to ensure we have enough space + ! (and if not, realloc!) + call nc_diag_chaninfo_resize_short(int8(diag_chaninfo_store%nchans)) + + ! Now add a relative position... based on the next position! + + ! First, increment the number of variables stored for this type: + diag_chaninfo_store%acount_v(type_index) = diag_chaninfo_store%acount_v(type_index) + 1 + + ! Then, set the next variable's relative positioning, + ! based on the number of variables stored for this type. + diag_chaninfo_store%var_rel_pos(diag_chaninfo_store%total) = diag_chaninfo_store%acount_v(type_index) + + ! Initialize the amount of memory used to 1. + diag_chaninfo_store%var_usage(diag_chaninfo_store%total) = 1 + + ! Set var_index to the total + var_index = diag_chaninfo_store%total + else + ! Variable already exists! + + ! Check to make sure we can fit more data! + ! (# data < nchans) + if (diag_chaninfo_store%var_usage(var_index) + & + diag_chaninfo_store%rel_indexes(var_index) >= diag_chaninfo_store%nchans) then + call nclayer_error("Can't add new data - data added is exceeding nchan! Data must fit within nchan constraint.") + endif + + ! Increment current variable count + diag_chaninfo_store%var_usage(var_index) = & + diag_chaninfo_store%var_usage(var_index) + 1 + end if + + ! Now add the actual entry! + diag_chaninfo_store%ci_short(1 + & + ((diag_chaninfo_store%var_rel_pos(var_index) - 1) & + * diag_chaninfo_store%nchans) & + + (diag_chaninfo_store%var_usage(var_index) - 1)) = chaninfo_value + end subroutine nc_diag_chaninfo_short + + ! Add a single scalar long integer to the given chaninfo + ! variable. (This is NOT a NetCDF "long", just a NetCDF "int".) + ! + ! This adds a single value to the specified chaninfo variable. + ! + ! If the variable does not already exist, it will be created, + ! and the value will be inserted as the variable's first + ! element. + ! + ! Otherwise, the value will be inserted to the next empty spot. + ! + ! Values are inserted in the order of the calls made. As such, + ! this subroutine is best designed to be used in a loop, where + ! for every channel iteration, a value is added using this + ! subroutine. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! (You should use the generic nc_diag_chaninfo + ! instead!) + ! + ! Args: + ! chaninfo_name (character(len=*)): the chaninfo variable + ! to store to. + ! chaninfo_value (integer(i_long)): the value to store. + ! + ! Raises: + ! If the data has already been locked, this will result in + ! an error. + ! + ! If definitions have already been locked, and a new + ! variable is being created, this will result in an error. + ! + ! If the variable is already full (e.g. it has nchans number + ! of elements), this will result in an error. + ! + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If nchans has not been set yet, this will result in an + ! error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_long(chaninfo_name, chaninfo_value) + character(len=*), intent(in) :: chaninfo_name + integer(i_long), intent(in) :: chaninfo_value + + integer(i_long) :: i, var_index, var_rel_index, type_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_chaninfo_long(chaninfo_name = " // chaninfo_name // ", chaninfo_value = ", chaninfo_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Make sure that data hasn't been locked + if (diag_chaninfo_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + ! For long, type index is 3 + type_index = 3 + + ! Default to -1 + var_index = -1 + + ! Attempt to match the variable name + fetch the variable + ! index first! + do i = 1, diag_chaninfo_store%total + if (diag_chaninfo_store%names(i) == chaninfo_name) then + var_rel_index = diag_chaninfo_store%var_rel_pos(i) + var_index = i + exit + end if + end do + +#ifdef _DEBUG_MEM_ + print *, " *** chaninfo_name" + print *, chaninfo_name + print *, " *** var_index is set to:" + print *, var_index +#endif + + if (var_index == -1) then + ! Entry does not exist yet... + + ! First, check to make sure we can still define new variables. + if (diag_chaninfo_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + ! Expand variable metadata first! + ! Make sure we have enough variable metadata storage + ! (and if not, reallocate!) + call nc_diag_chaninfo_expand + + ! Add to the total! + diag_chaninfo_store%total = diag_chaninfo_store%total + 1 + + ! Store name and type! + diag_chaninfo_store%names(diag_chaninfo_store%total) = chaninfo_name + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_LONG + + ! We just need to add one entry... + ! Call resize subroutine to ensure we have enough space + ! (and if not, realloc!) + call nc_diag_chaninfo_resize_long(int8(diag_chaninfo_store%nchans)) + + ! Now add a relative position... based on the next position! + + ! First, increment the number of variables stored for this type: + diag_chaninfo_store%acount_v(type_index) = diag_chaninfo_store%acount_v(type_index) + 1 + + ! Then, set the next variable's relative positioning, + ! based on the number of variables stored for this type. + diag_chaninfo_store%var_rel_pos(diag_chaninfo_store%total) = diag_chaninfo_store%acount_v(type_index) + + ! Initialize the amount of memory used to 1. + diag_chaninfo_store%var_usage(diag_chaninfo_store%total) = 1 + + ! Set var_index to the total + var_index = diag_chaninfo_store%total + else + ! Variable already exists! + + ! Check to make sure we can fit more data! + ! (# data < nchans) + if (diag_chaninfo_store%var_usage(var_index) + & + diag_chaninfo_store%rel_indexes(var_index) >= diag_chaninfo_store%nchans) then +#ifdef _DEBUG_MEM_ + print *, "!!!! diag_chaninfo_store%var_usage(var_index)" + print *, diag_chaninfo_store%var_usage(var_index) +#endif + call nclayer_error("Can't add new data - data added is exceeding nchan! Data must fit within nchan constraint.") + endif + + ! Increment current variable count + diag_chaninfo_store%var_usage(var_index) = & + diag_chaninfo_store%var_usage(var_index) + 1 + end if + + ! Now add the actual entry! +#ifdef _DEBUG_MEM_ + print *, "====================================" + print *, "diag_chaninfo_store%total" + print *, diag_chaninfo_store%total + print *, "var_index" + print *, var_index + print *, "diag_chaninfo_store%var_rel_pos(var_index)" + print *, diag_chaninfo_store%var_rel_pos(var_index) + print *, "diag_chaninfo_store%nchans" + print *, diag_chaninfo_store%nchans + print *, "diag_chaninfo_store%var_usage(var_index)" + print *, diag_chaninfo_store%var_usage(var_index) + print *, "====================================" +#endif + + diag_chaninfo_store%ci_long(1 + & + ((diag_chaninfo_store%var_rel_pos(var_index) - 1) & + * diag_chaninfo_store%nchans) & + + (diag_chaninfo_store%var_usage(var_index) - 1)) = chaninfo_value + end subroutine nc_diag_chaninfo_long + + ! Add a single scalar float to the given chaninfo variable. + ! + ! This adds a single value to the specified chaninfo variable. + ! + ! If the variable does not already exist, it will be created, + ! and the value will be inserted as the variable's first + ! element. + ! + ! Otherwise, the value will be inserted to the next empty spot. + ! + ! Values are inserted in the order of the calls made. As such, + ! this subroutine is best designed to be used in a loop, where + ! for every channel iteration, a value is added using this + ! subroutine. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! (You should use the generic nc_diag_chaninfo + ! instead!) + ! + ! Args: + ! chaninfo_name (character(len=*)): the chaninfo variable + ! to store to. + ! chaninfo_value (real(r_single)): the value to store. + ! + ! Raises: + ! If the data has already been locked, this will result in + ! an error. + ! + ! If definitions have already been locked, and a new + ! variable is being created, this will result in an error. + ! + ! If the variable is already full (e.g. it has nchans number + ! of elements), this will result in an error. + ! + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If nchans has not been set yet, this will result in an + ! error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_rsingle(chaninfo_name, chaninfo_value) + character(len=*), intent(in) :: chaninfo_name + real(r_single), intent(in) :: chaninfo_value + + integer(i_long) :: i, var_index, var_rel_index, type_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, F0.5, A)") "nc_diag_chaninfo_rsingle(chaninfo_name = " // chaninfo_name // ", chaninfo_value = ", chaninfo_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Make sure that data hasn't been locked + if (diag_chaninfo_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + ! For rsingle, type index is 4 + type_index = 4 + + ! Default to -1 + var_index = -1 + + ! Attempt to match the variable name + fetch the variable + ! index first! + do i = 1, diag_chaninfo_store%total + if (diag_chaninfo_store%names(i) == chaninfo_name) then + var_rel_index = diag_chaninfo_store%var_rel_pos(i) + var_index = i + exit + end if + end do + +#ifdef _DEBUG_MEM_ + print *, " *** chaninfo_name" + print *, chaninfo_name + print *, " *** var_index is set to:" + print *, var_index +#endif + + if (var_index == -1) then + ! Entry does not exist yet... + + ! First, check to make sure we can still define new variables. + if (diag_chaninfo_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + ! Expand variable metadata first! + ! Make sure we have enough variable metadata storage + ! (and if not, reallocate!) + call nc_diag_chaninfo_expand + + ! Add to the total! + diag_chaninfo_store%total = diag_chaninfo_store%total + 1 + + ! Store name and type! + diag_chaninfo_store%names(diag_chaninfo_store%total) = chaninfo_name + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_FLOAT + + ! We just need to add one entry... + ! Call resize subroutine to ensure we have enough space + ! (and if not, realloc!) + call nc_diag_chaninfo_resize_rsingle(int8(diag_chaninfo_store%nchans)) + + ! Now add a relative position... based on the next position! + + ! First, increment the number of variables stored for this type: + diag_chaninfo_store%acount_v(type_index) = diag_chaninfo_store%acount_v(type_index) + 1 + + ! Then, set the next variable's relative positioning, + ! based on the number of variables stored for this type. + diag_chaninfo_store%var_rel_pos(diag_chaninfo_store%total) = diag_chaninfo_store%acount_v(type_index) + + ! Initialize the amount of memory used to 1. + diag_chaninfo_store%var_usage(diag_chaninfo_store%total) = 1 + + ! Set var_index to the total + var_index = diag_chaninfo_store%total + else + ! Variable already exists! + + ! Check to make sure we can fit more data! + ! (# data < nchans) + if (diag_chaninfo_store%var_usage(var_index) + & + diag_chaninfo_store%rel_indexes(var_index) >= diag_chaninfo_store%nchans) then + call nclayer_error("Can't add new data - data added is exceeding nchan! Data must fit within nchan constraint.") + endif + + ! Increment current variable count + diag_chaninfo_store%var_usage(var_index) = & + diag_chaninfo_store%var_usage(var_index) + 1 + end if + +#ifdef _DEBUG_MEM_ + print *, "====================================" + print *, "diag_chaninfo_store%total" + print *, diag_chaninfo_store%total + print *, "var_index" + print *, var_index + print *, "diag_chaninfo_store%var_rel_pos(var_index)" + print *, diag_chaninfo_store%var_rel_pos(var_index) + print *, "diag_chaninfo_store%nchans" + print *, diag_chaninfo_store%nchans + print *, "diag_chaninfo_store%var_usage(var_index)" + print *, diag_chaninfo_store%var_usage(var_index) + print *, "====================================" +#endif + + ! Now add the actual entry! + diag_chaninfo_store%ci_rsingle(1 + & + ((diag_chaninfo_store%var_rel_pos(var_index) - 1) & + * diag_chaninfo_store%nchans) & + + (diag_chaninfo_store%var_usage(var_index) - 1)) = chaninfo_value + end subroutine nc_diag_chaninfo_rsingle + + ! Add a single scalar double to the given chaninfo variable. + ! + ! This adds a single value to the specified chaninfo variable. + ! + ! If the variable does not already exist, it will be created, + ! and the value will be inserted as the variable's first + ! element. + ! + ! Otherwise, the value will be inserted to the next empty spot. + ! + ! Values are inserted in the order of the calls made. As such, + ! this subroutine is best designed to be used in a loop, where + ! for every channel iteration, a value is added using this + ! subroutine. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! (You should use the generic nc_diag_chaninfo + ! instead!) + ! + ! Args: + ! chaninfo_name (character(len=*)): the chaninfo variable + ! to store to. + ! chaninfo_value (real(r_double)): the value to store. + ! + ! Raises: + ! If the data has already been locked, this will result in + ! an error. + ! + ! If definitions have already been locked, and a new + ! variable is being created, this will result in an error. + ! + ! If the variable is already full (e.g. it has nchans number + ! of elements), this will result in an error. + ! + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If nchans has not been set yet, this will result in an + ! error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_rdouble(chaninfo_name, chaninfo_value) + character(len=*), intent(in) :: chaninfo_name + real(r_double), intent(in) :: chaninfo_value + + integer(i_long) :: i, var_index, var_rel_index, type_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, F0.5, A)") "nc_diag_chaninfo_rdouble(chaninfo_name = " // chaninfo_name // ", chaninfo_value = ", chaninfo_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Make sure that data hasn't been locked + if (diag_chaninfo_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + ! For rdouble, type index is 5 + type_index = 5 + + ! Default to -1 + var_index = -1 + + ! Attempt to match the variable name + fetch the variable + ! index first! + do i = 1, diag_chaninfo_store%total + if (diag_chaninfo_store%names(i) == chaninfo_name) then + var_rel_index = diag_chaninfo_store%var_rel_pos(i) + var_index = i + exit + end if + end do + + if (var_index == -1) then + ! Entry does not exist yet... + + ! First, check to make sure we can still define new variables. + if (diag_chaninfo_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + ! Expand variable metadata first! + ! Make sure we have enough variable metadata storage + ! (and if not, reallocate!) + call nc_diag_chaninfo_expand + + ! Add to the total! + diag_chaninfo_store%total = diag_chaninfo_store%total + 1 + + ! Store name and type! + diag_chaninfo_store%names(diag_chaninfo_store%total) = chaninfo_name + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_DOUBLE + + ! We just need to add one entry... + ! Call resize subroutine to ensure we have enough space + ! (and if not, realloc!) + call nc_diag_chaninfo_resize_rdouble(int8(diag_chaninfo_store%nchans)) + + ! Now add a relative position... based on the next position! + + ! First, increment the number of variables stored for this type: + diag_chaninfo_store%acount_v(type_index) = diag_chaninfo_store%acount_v(type_index) + 1 + + ! Then, set the next variable's relative positioning, + ! based on the number of variables stored for this type. + diag_chaninfo_store%var_rel_pos(diag_chaninfo_store%total) = diag_chaninfo_store%acount_v(type_index) + + ! Initialize the amount of memory used to 1. + diag_chaninfo_store%var_usage(diag_chaninfo_store%total) = 1 + + ! Set var_index to the total + var_index = diag_chaninfo_store%total + else + ! Variable already exists! + + ! Check to make sure we can fit more data! + ! (# data < nchans) + if (diag_chaninfo_store%var_usage(var_index) + & + diag_chaninfo_store%rel_indexes(var_index) >= diag_chaninfo_store%nchans) then + call nclayer_error("Can't add new data - data added is exceeding nchan! Data must fit within nchan constraint.") + endif + + ! Increment current variable count + diag_chaninfo_store%var_usage(var_index) = & + diag_chaninfo_store%var_usage(var_index) + 1 + end if + + ! Now add the actual entry! + diag_chaninfo_store%ci_rdouble(1 + & + ((diag_chaninfo_store%var_rel_pos(var_index) - 1) & + * diag_chaninfo_store%nchans) & + + (diag_chaninfo_store%var_usage(var_index) - 1)) = chaninfo_value + end subroutine nc_diag_chaninfo_rdouble + + ! Add a single scalar string to the given chaninfo variable. + ! (This uses the NetCDF char type, stored internally as a 2D + ! array of characters.) + ! + ! This adds a single value to the specified chaninfo variable. + ! + ! If the variable does not already exist, it will be created, + ! and the value will be inserted as the variable's first + ! element. + ! + ! Otherwise, the value will be inserted to the next empty spot. + ! + ! Values are inserted in the order of the calls made. As such, + ! this subroutine is best designed to be used in a loop, where + ! for every channel iteration, a value is added using this + ! subroutine. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! (You should use the generic nc_diag_chaninfo + ! instead!) + ! + ! Args: + ! chaninfo_name (character(len=*)): the chaninfo variable + ! to store to. + ! chaninfo_value (character(len=*)): the value to store. + ! + ! Raises: + ! If the data has already been locked, this will result in + ! an error. + ! + ! If definitions have already been locked, and a new + ! variable is being created, this will result in an error. + ! + ! If the variable is already full (e.g. it has nchans number + ! of elements), this will result in an error. + ! + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If nchans has not been set yet, this will result in an + ! error. + ! + ! If there is no file open (or the file is already closed), + ! this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_string(chaninfo_name, chaninfo_value) + character(len=*), intent(in) :: chaninfo_name + character(len=*), intent(in) :: chaninfo_value + + integer(i_long) :: i, var_index, var_rel_index, type_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A)") "nc_diag_chaninfo_string(chaninfo_name = " // chaninfo_name // ", chaninfo_value = " // trim(chaninfo_value) // ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Make sure that data hasn't been locked + if (diag_chaninfo_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + ! For string, type index is 6 + type_index = 6 + + ! Default to -1 + var_index = -1 + + ! Attempt to match the variable name + fetch the variable + ! index first! + do i = 1, diag_chaninfo_store%total + if (diag_chaninfo_store%names(i) == chaninfo_name) then + var_rel_index = diag_chaninfo_store%var_rel_pos(i) + var_index = i + exit + end if + end do + + if (var_index == -1) then + ! Entry does not exist yet... + + ! First, check to make sure we can still define new variables. + if (diag_chaninfo_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + ! Expand variable metadata first! + ! Make sure we have enough variable metadata storage + ! (and if not, reallocate!) + call nc_diag_chaninfo_expand + + ! Add to the total! + diag_chaninfo_store%total = diag_chaninfo_store%total + 1 + + ! Store name and type! + diag_chaninfo_store%names(diag_chaninfo_store%total) = chaninfo_name + diag_chaninfo_store%types(diag_chaninfo_store%total) = NLAYER_STRING + + ! We just need to add one entry... + ! Call resize subroutine to ensure we have enough space + ! (and if not, realloc!) + call nc_diag_chaninfo_resize_string(int8(diag_chaninfo_store%nchans)) + + ! Now add a relative position... based on the next position! + + ! First, increment the number of variables stored for this type: + diag_chaninfo_store%acount_v(type_index) = diag_chaninfo_store%acount_v(type_index) + 1 + + ! Then, set the next variable's relative positioning, + ! based on the number of variables stored for this type. + diag_chaninfo_store%var_rel_pos(diag_chaninfo_store%total) = diag_chaninfo_store%acount_v(type_index) + + ! Initialize the amount of memory used to 1. + diag_chaninfo_store%var_usage(diag_chaninfo_store%total) = 1 + + ! Set var_index to the total + var_index = diag_chaninfo_store%total + else + ! Variable already exists! + + ! Check to make sure we can fit more data! + ! (# data < nchans) + if (diag_chaninfo_store%var_usage(var_index) + & + diag_chaninfo_store%rel_indexes(var_index) >= diag_chaninfo_store%nchans) then + call nclayer_error("Can't add new data - data added is exceeding nchan! Data must fit within nchan constraint.") + endif + + ! Check max string length + if ((diag_chaninfo_store%def_lock) .AND. & + (len_trim(chaninfo_value) > diag_chaninfo_store%max_str_lens(var_index))) & + call nclayer_error("Cannot expand variable string length after locking variable definitions!") + + ! Increment current variable count + diag_chaninfo_store%var_usage(var_index) = & + diag_chaninfo_store%var_usage(var_index) + 1 + end if + + ! If trim isn't enabled, set our maximum string length here! + if (.NOT. enable_trim) then + if (diag_chaninfo_store%max_str_lens(var_index) == -1) then + diag_chaninfo_store%max_str_lens(var_index) = len(chaninfo_value) + else + ! Validate that our non-first value isn't different from + ! the initial string length + if (diag_chaninfo_store%max_str_lens(var_index) /= len(chaninfo_value)) & + call nclayer_error("Cannot change string size when trimming is disabled!") + end if + end if + + ! Now add the actual entry! + diag_chaninfo_store%ci_string(1 + & + ((diag_chaninfo_store%var_rel_pos(var_index) - 1) & + * diag_chaninfo_store%nchans) & + + (diag_chaninfo_store%var_usage(var_index) - 1)) = chaninfo_value + end subroutine nc_diag_chaninfo_string +end module ncdw_chaninfo diff --git a/src/ncdiag/ncdw_ciresize.F90 b/src/ncdiag/ncdw_ciresize.F90 new file mode 100644 index 000000000..c58fe49e5 --- /dev/null +++ b/src/ncdiag/ncdw_ciresize.F90 @@ -0,0 +1,718 @@ +! nc_diag_write - NetCDF Layer Diag Writing Module +! Copyright 2015 Albert Huang - SSAI/NASA for NASA GSFC GMAO (610.1). +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or +! implied. See the License for the specific language governing +! permissions and limitations under the License. +! +! chaninfo variable data storage resizing module - ncdw_ciresize +! +module ncdw_ciresize + ! Module that provides chaninfo variable data storage resizing. + ! + ! This module has all of the subroutines needed to resize chaninfo + ! variable data storage. It includes resizing subroutines for all + ! variable data storage types, including: + ! integer(i_byte) for byte integer storage + ! integer(i_short) for short integer storage + ! integer(i_long) for long integer storage + ! real(r_single) for float storage + ! real(r_double) for double storage + ! character(len=*) for string storage + ! + ! The subroutines here serve as "smart" wrappers for the real + ! reallocation subroutines in ncdw_realloc. + ! + ! For each subroutine: + ! + ! -> It first checks if the type-specific variable data storage + ! field (ci_*) has been allocated or not. + ! + ! -> If it hasn't been allocated: + ! -> If the storage count is to be updated, it is set to the + ! specified number of entries. + ! -> The field is then allocated with the specified number of + ! entries, plus the default initial number of entries. + ! + ! -> If it has been allocated: + ! -> If the storage count is to be updated, the number of fields + ! to allocate for are added to the count. + ! -> The (potentially updated) field storage count is checked + ! against the cached allocated size. + ! -> If the count is greater than or equal to the cached + ! allocated size, the proper reallocation subroutine from + ! nc_diag_realloc is called, the cached allocated size is + ! updated to the new size, and the allocation multiplier is + ! incremented. + ! -> Otherwise, nothing happens. + ! + + ! Load our numerical types from kinds + ! Note that i_llong is not a type we store - it's just for keeping + ! track of numeric indexes. (Maybe this is too excessive...) + use ncd_kinds, only: i_byte, i_short, i_long, i_llong, r_single, & + r_double + + ! Load state variables! We just need to know: + ! diag_chaninfo_store - ...chaninfo variable information. + ! We pretty much do everything related to + ! chaninfo here, so we're using everything + ! inside this derived type! (Especially the + ! variable data storage fields, ci_*!) + use ncdw_state, only: diag_chaninfo_store + + ! Load types! We need: + ! NLAYER_DEFAULT_ENT - default starting number of element entries. + ! This is for the initial allocation of + ! space for data storage arrays, e.g. + ! the ci_* data arrays within diag_chaninfo. + ! NLAYER_MULTI_BASE - the base number to use when exponentiating + ! to allocate or reallocate data storage + ! arrays. + use ncdw_types, only: NLAYER_DEFAULT_ENT, NLAYER_MULTI_BASE + + ! Load our fun reallocation subroutine - we need this to reallocate + ! within our "smart" chaninfo reallocation subroutines: + use ncdw_realloc, only: nc_diag_realloc + +#ifdef ENABLE_ACTION_MSGS + use ncdw_climsg, only: nclayer_enable_action, nclayer_actionm +#endif + + implicit none + + contains + ! Make enough space in the internal variable data storage field + ! for byte integer storage. + ! + ! This attempts to resize the internal variable data storage + ! field to accompany additional entries. If the size is already + ! big enough to fit the existing data plus the additional + ! entries, no actual memory reallocation will occur. + ! + ! The storage count for the type is also updated, unless + ! otherwise optionally disabled via an optional argument. + ! + ! Disabling the storage count update can be useful for + ! preallocation, where the preallocation can occur without + ! updating the count, since the count stores the amount of data + ! stored in the storage field. Since preallocation does not + ! store any data, the count updating should be disabled. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! addl_num_entries (integer(i_llong)): the number of entries + ! to make enough space for. + ! update_acount_in (logical, optional): whether to update + ! the internal variable data storage count or not. If + ! not specified, the count will be updated. + ! + ! Raises: + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If data reallocation fails, this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_resize_byte(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_BYTE is located at the first index, 1. + sc_index = 1 + + ! Check if the variable data storage field is allocated + if (allocated(diag_chaninfo_store%ci_byte)) then + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = diag_chaninfo_store%acount(sc_index) + addl_num_entries + + ! Check to see if we have enough memory space + if (diag_chaninfo_store%acount(sc_index) >= diag_chaninfo_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_chaninfo_resize_byte: doing reallocation!") + end if +#endif + ! Reallocate to grow the variable data storage array + call nc_diag_realloc(diag_chaninfo_store%ci_byte, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_chaninfo_store%alloc_multi)))) + + ! Update the variable storage size with the new + ! reallocated size + diag_chaninfo_store%asize(sc_index) = size(diag_chaninfo_store%ci_byte) + + ! Increment the allocation multiplier + diag_chaninfo_store%alloc_multi = diag_chaninfo_store%alloc_multi + 1 + end if + else + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = addl_num_entries + + ! Allocate the number of entries to add + default + ! initial size + allocate(diag_chaninfo_store%ci_byte(addl_num_entries + NLAYER_DEFAULT_ENT)) + + ! Set variable storage size to same amount + diag_chaninfo_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_chaninfo_resize_byte + + ! Make enough space in the internal variable data storage field + ! for short integer storage. + ! + ! This attempts to resize the internal variable data storage + ! field to accompany additional entries. If the size is already + ! big enough to fit the existing data plus the additional + ! entries, no actual memory reallocation will occur. + ! + ! The storage count for the type is also updated, unless + ! otherwise optionally disabled via an optional argument. + ! + ! Disabling the storage count update can be useful for + ! preallocation, where the preallocation can occur without + ! updating the count, since the count stores the amount of data + ! stored in the storage field. Since preallocation does not + ! store any data, the count updating should be disabled. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! addl_num_entries (integer(i_llong)): the number of entries + ! to make enough space for. + ! update_acount_in (logical, optional): whether to update + ! the internal variable data storage count or not. If + ! not specified, the count will be updated. + ! + ! Raises: + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If data reallocation fails, this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_resize_short(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_SHORT is located at the second index, 2. + sc_index = 2 + + ! Check if the variable data storage field is allocated + if (allocated(diag_chaninfo_store%ci_short)) then + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = diag_chaninfo_store%acount(sc_index) + addl_num_entries + + ! Check to see if we have enough memory space + if (diag_chaninfo_store%acount(sc_index) >= diag_chaninfo_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_chaninfo_resize_short: doing reallocation!") + end if +#endif + ! Reallocate to grow the variable data storage array + call nc_diag_realloc(diag_chaninfo_store%ci_short, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_chaninfo_store%alloc_multi)))) + + ! Update the variable storage size with the new + ! reallocated size + diag_chaninfo_store%asize(sc_index) = size(diag_chaninfo_store%ci_short) + + ! Increment the allocation multiplier + diag_chaninfo_store%alloc_multi = diag_chaninfo_store%alloc_multi + 1 + end if + else + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = addl_num_entries + + ! Allocate the number of entries to add + default + ! initial size + allocate(diag_chaninfo_store%ci_short(addl_num_entries + NLAYER_DEFAULT_ENT)) + + ! Set variable storage size to same amount + diag_chaninfo_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_chaninfo_resize_short + + ! Make enough space in the internal variable data storage field + ! for long integer storage. + ! + ! This attempts to resize the internal variable data storage + ! field to accompany additional entries. If the size is already + ! big enough to fit the existing data plus the additional + ! entries, no actual memory reallocation will occur. + ! + ! The storage count for the type is also updated, unless + ! otherwise optionally disabled via an optional argument. + ! + ! Disabling the storage count update can be useful for + ! preallocation, where the preallocation can occur without + ! updating the count, since the count stores the amount of data + ! stored in the storage field. Since preallocation does not + ! store any data, the count updating should be disabled. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! addl_num_entries (integer(i_llong)): the number of entries + ! to make enough space for. + ! update_acount_in (logical, optional): whether to update + ! the internal variable data storage count or not. If + ! not specified, the count will be updated. + ! + ! Raises: + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If data reallocation fails, this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_resize_long(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! Did we realloc at all? + !logical :: chaninfo_realloc + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_LONG is located at the third index, 3. + sc_index = 3 + + ! Check if the variable data storage field is allocated + if (allocated(diag_chaninfo_store%ci_long)) then + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = diag_chaninfo_store%acount(sc_index) + addl_num_entries + + + ! Check to see if we have enough memory space + if (diag_chaninfo_store%acount(sc_index) >= diag_chaninfo_store%asize(sc_index)) then +#ifdef _DEBUG_MEM_ + print *, "realloc needed for chaninfo long!" + write (*, "(A, I0, A, I0, A)") "(size needed / size available: ", diag_chaninfo_store%acount(sc_index), " / ", diag_chaninfo_store%asize(sc_index), ")" +#endif +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_chaninfo_resize_long: doing reallocation!") + end if +#endif + ! Reallocate to grow the variable data storage array + call nc_diag_realloc(diag_chaninfo_store%ci_long, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_chaninfo_store%alloc_multi)))) + + ! Update the variable storage size with the new + ! reallocated size + diag_chaninfo_store%asize(sc_index) = size(diag_chaninfo_store%ci_long) + + ! Increment the allocation multiplier + diag_chaninfo_store%alloc_multi = diag_chaninfo_store%alloc_multi + 1 + end if + else + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = addl_num_entries + + ! Allocate the number of entries to add + default + ! initial size + allocate(diag_chaninfo_store%ci_long(addl_num_entries + NLAYER_DEFAULT_ENT)) + + ! Set variable storage size to same amount + diag_chaninfo_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_chaninfo_resize_long + + ! Make enough space in the internal variable data storage field + ! for float storage. + ! + ! This attempts to resize the internal variable data storage + ! field to accompany additional entries. If the size is already + ! big enough to fit the existing data plus the additional + ! entries, no actual memory reallocation will occur. + ! + ! The storage count for the type is also updated, unless + ! otherwise optionally disabled via an optional argument. + ! + ! Disabling the storage count update can be useful for + ! preallocation, where the preallocation can occur without + ! updating the count, since the count stores the amount of data + ! stored in the storage field. Since preallocation does not + ! store any data, the count updating should be disabled. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! addl_num_entries (integer(i_llong)): the number of entries + ! to make enough space for. + ! update_acount_in (logical, optional): whether to update + ! the internal variable data storage count or not. If + ! not specified, the count will be updated. + ! + ! Raises: + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If data reallocation fails, this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_resize_rsingle(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_FLOAT is located at the fourth index, 4. + sc_index = 4 + + ! Check if the variable data storage field is allocated + if (allocated(diag_chaninfo_store%ci_rsingle)) then + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = diag_chaninfo_store%acount(sc_index) + addl_num_entries + + ! Check to see if we have enough memory space + if (diag_chaninfo_store%acount(sc_index) >= diag_chaninfo_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_chaninfo_resize_rsingle: doing reallocation!") + end if +#endif + ! Reallocate to grow the variable data storage array + call nc_diag_realloc(diag_chaninfo_store%ci_rsingle, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_chaninfo_store%alloc_multi)))) + + ! Update the variable storage size with the new + ! reallocated size + diag_chaninfo_store%asize(sc_index) = size(diag_chaninfo_store%ci_rsingle) + + ! Increment the allocation multiplier + diag_chaninfo_store%alloc_multi = diag_chaninfo_store%alloc_multi + 1 + end if + else + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = addl_num_entries + + ! Allocate the number of entries to add + default + ! initial size + allocate(diag_chaninfo_store%ci_rsingle(addl_num_entries + NLAYER_DEFAULT_ENT)) + + ! Set variable storage size to same amount + diag_chaninfo_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_chaninfo_resize_rsingle + + ! Make enough space in the internal variable data storage field + ! for double storage. + ! + ! This attempts to resize the internal variable data storage + ! field to accompany additional entries. If the size is already + ! big enough to fit the existing data plus the additional + ! entries, no actual memory reallocation will occur. + ! + ! The storage count for the type is also updated, unless + ! otherwise optionally disabled via an optional argument. + ! + ! Disabling the storage count update can be useful for + ! preallocation, where the preallocation can occur without + ! updating the count, since the count stores the amount of data + ! stored in the storage field. Since preallocation does not + ! store any data, the count updating should be disabled. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! addl_num_entries (integer(i_llong)): the number of entries + ! to make enough space for. + ! update_acount_in (logical, optional): whether to update + ! the internal variable data storage count or not. If + ! not specified, the count will be updated. + ! + ! Raises: + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If data reallocation fails, this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_resize_rdouble(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_DOUBLE is located at the fifth index, 5. + sc_index = 5 + + ! Check if the variable data storage field is allocated + if (allocated(diag_chaninfo_store%ci_rdouble)) then + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = diag_chaninfo_store%acount(sc_index) + addl_num_entries + + ! Check to see if we have enough memory space + if (diag_chaninfo_store%acount(sc_index) >= diag_chaninfo_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_chaninfo_resize_rdouble: doing reallocation!") + end if +#endif + ! Reallocate to grow the variable data storage array + call nc_diag_realloc(diag_chaninfo_store%ci_rdouble, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_chaninfo_store%alloc_multi)))) + + ! Update the variable storage size with the new + ! reallocated size + diag_chaninfo_store%asize(sc_index) = size(diag_chaninfo_store%ci_rdouble) + + ! Increment the allocation multiplier + diag_chaninfo_store%alloc_multi = diag_chaninfo_store%alloc_multi + 1 + end if + else + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = addl_num_entries + + ! Allocate the number of entries to add + default + ! initial size + allocate(diag_chaninfo_store%ci_rdouble(addl_num_entries + NLAYER_DEFAULT_ENT)) + + ! Set variable storage size to same amount + diag_chaninfo_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_chaninfo_resize_rdouble + + ! Make enough space in the internal variable data storage field + ! for string storage. + ! + ! This attempts to resize the internal variable data storage + ! field to accompany additional entries. If the size is already + ! big enough to fit the existing data plus the additional + ! entries, no actual memory reallocation will occur. + ! + ! The storage count for the type is also updated, unless + ! otherwise optionally disabled via an optional argument. + ! + ! Disabling the storage count update can be useful for + ! preallocation, where the preallocation can occur without + ! updating the count, since the count stores the amount of data + ! stored in the storage field. Since preallocation does not + ! store any data, the count updating should be disabled. + ! + ! This is an internal subroutine, and is NOT meant to be called + ! outside of nc_diag_write. Calling this subroutine in your + ! program may result in unexpected behavior and/or data + ! corruption! + ! + ! Args: + ! addl_num_entries (integer(i_llong)): the number of entries + ! to make enough space for. + ! update_acount_in (logical, optional): whether to update + ! the internal variable data storage count or not. If + ! not specified, the count will be updated. + ! + ! Raises: + ! The following errors will trigger indirectly from other + ! subroutines called here: + ! + ! If data reallocation fails, this will result in an error. + ! + ! Other errors may result from invalid data storage, NetCDF + ! errors, or even a bug. See the called subroutines' + ! documentation for details. + ! + subroutine nc_diag_chaninfo_resize_string(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_STRING is located at the sixth index, 6. + sc_index = 6 + + ! Check if the variable data storage field is allocated + if (allocated(diag_chaninfo_store%ci_string)) then + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = diag_chaninfo_store%acount(sc_index) + addl_num_entries + + ! Check to see if we have enough memory space + if (diag_chaninfo_store%acount(sc_index) >= diag_chaninfo_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_chaninfo_resize_string: doing reallocation!") + end if +#endif + ! Reallocate to grow the variable data storage array + call nc_diag_realloc(diag_chaninfo_store%ci_string, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_chaninfo_store%alloc_multi)))) + + ! Update the variable storage size with the new + ! reallocated size + diag_chaninfo_store%asize(sc_index) = size(diag_chaninfo_store%ci_string) + + ! Increment the allocation multiplier + diag_chaninfo_store%alloc_multi = diag_chaninfo_store%alloc_multi + 1 + end if + else + ! If necessary, update the variable data storage count + if (update_acount) diag_chaninfo_store%acount(sc_index) = addl_num_entries + + ! Allocate the number of entries to add + default + ! initial size + allocate(diag_chaninfo_store%ci_string(addl_num_entries + NLAYER_DEFAULT_ENT)) + + ! Set variable storage size to same amount + diag_chaninfo_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_chaninfo_resize_string +end module ncdw_ciresize diff --git a/src/ncdiag/ncdw_climsg.F90 b/src/ncdiag/ncdw_climsg.F90 new file mode 100644 index 000000000..c98bd3fdf --- /dev/null +++ b/src/ncdiag/ncdw_climsg.F90 @@ -0,0 +1,308 @@ +! nc_diag_write - NetCDF Layer Diag Writing Module +! Copyright 2015 Albert Huang - SSAI/NASA for NASA GSFC GMAO (610.1). +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or +! implied. See the License for the specific language governing +! permissions and limitations under the License. +! +! command line message printing module - ncdw_climsg +! +module ncdw_climsg + ! Module that provides command line message printing support. + ! + ! This module has all of the subroutines needed to print various + ! types of command line messages. + ! + ! Message types include: + ! -> Errors - errors that occur within the application. Errors + ! will always result in the program exiting (via stop). If + ! ANSI colors are enabled, this will show up in all red. + ! + ! -> Warnings - warnings that occur within the application. This + ! will show a warning, but allow the program to continue. If + ! ANSI colors are enabled, this will show up in yellow (or + ! orange, depending on your terminal colors). + ! + ! -> Info - information about the application's progress. These + ! tend to be verbose, hence the option to toggle them on and + ! off. By default, they are turned off. + ! + ! -> Action - debug information that displays key subroutines and + ! their arguments at the start of the subroutine. These are + ! very verbose, hence the option to toggle them on and off. + ! + ! In addition, since these are placed in front of subroutines, + ! they require a compile time flag to turn on, since they take + ! processing time. + ! + ! By default, due to the high verbosity, they are off. + ! + ! -> Debug - debug information about the application in general. + ! These are extremely verbose, and can only be turned on with + ! a compile time flag. + ! + + ! Load our numerical types from kinds - we just need our standard + ! integer type, i_long + use ncd_kinds, only: i_long + + use netcdf, only: nf90_noerr, nf90_strerror + + implicit none + + ! Whether to enable info message printing or not. + ! By default, this is set to FALSE. + logical :: nclayer_enable_info = .FALSE. + + ! Whether to enable action message printing or not. + ! By default, this is set to FALSE. + ! + ! Note that even if this is set to TRUE, action message support + ! must be enabled at compile time for messages to be printed. + logical :: nclayer_enable_action = .FALSE. + + contains + ! Display a given error message, and exit. + ! + ! Display a specified error message, and exit. + ! + ! If ANSI colors are enabled at compile time, the entire message + ! will be printed in red. + ! + ! If error tracebacks are enabled, this will attempt to generate + ! a traceback of the error before terminating. + ! + ! Args: + ! err (character(len=*)): the error to display. + ! + ! Raises: + ! This is the error subroutine that exits, so it is + ! basically... an error itself. So indeed, this WILL result + ! in an error, no matter what! + ! + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! These errors are likely to crash the program in unexpected + ! ways... + ! + subroutine nclayer_error(err) + character(len=*), intent(in) :: err +#ifdef ERROR_TRACEBACK + integer(i_long) :: div0 +#endif + write(*, "(A)") " ** ERROR: " // err +#ifdef ERROR_TRACEBACK + write(*, "(A)") " ** Failed to process data/write NetCDF4." + write(*, "(A)") " (Traceback requested, triggering div0 error...)" + div0 = 1 / 0 +#else + stop " ** Failed to process data/write NetCDF4." +#endif + end subroutine nclayer_error + + ! Display a given warning message. + ! + ! Display a specified warning message. + ! + ! If ANSI colors are enabled at compile time, the entire message + ! will be printed in yellow or orange, depending on how your + ! terminal displays colors. + ! + ! Args: + ! warn (character(len=*)): the warning to display. + ! + ! Raises: + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! These errors are likely to crash the program in unexpected + ! ways... + ! + subroutine nclayer_warning(warn) + character(len=*), intent(in) :: warn + write(*, "(A)") " ** WARNING: " // warn + end subroutine nclayer_warning + + ! Set whether to display action messages or not. + ! + ! This sets the flag on whether to display action messages or + ! not. + ! + ! If the provided argument is TRUE, action messages will be + ! displayed. Otherwise, they will be hidden, even if action + ! message calls are made. + ! + ! Args: + ! action_on_off (logical): boolean indicating whether to + ! display action messages or not. If TRUE, action + ! messages will be displayed. Otherwise, they will be + ! hidden. + ! + ! Raises: + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! These errors are likely to crash the program in unexpected + ! ways... + ! + subroutine nc_set_action_display(action_on_off) + logical :: action_on_off +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, L, A)") "nc_set_action_display(action_on_off = ", action_on_off, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + nclayer_enable_action = action_on_off + end subroutine nc_set_action_display + +#ifdef ENABLE_ACTION_MSGS + ! Display a given action message. + ! + ! Display a specified action message. + ! + ! The messages displayed here are intended to be debug messages + ! indicating the subroutine that was called, along with the + ! arguments provided for the subroutine, if any. + ! (Hence, the "action" message.) + ! + ! An example of such a message: + ! nc_set_action_display(action_on_off = T) + ! + ! Although other kinds of messages can be printed via action + ! messages, it's strongly recommended to only print subroutine + ! and/or function calls here. + ! + ! If ANSI colors are enabled at compile time, the entire message + ! will be printed in cyan (light blue). + ! + ! Args: + ! act (character(len=*)): the action message to display. + ! + ! Raises: + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! These errors are likely to crash the program in unexpected + ! ways... + ! + subroutine nclayer_actionm(act) + character(len=*), intent(in) :: act + if (nclayer_enable_action) & + write(*, "(A)") " ** ACTION: " // act + end subroutine nclayer_actionm +#endif + + ! Set whether to display informational messages or not. + ! + ! This sets the flag on whether to display information messages + ! or not. + ! + ! If the provided argument is TRUE, informational messages will + ! be displayed. Otherwise, they will be hidden, even if info + ! message calls are made. + ! + ! Args: + ! info_on_off (logical): boolean indicating whether to + ! display informational messages or not. If TRUE, + ! informational messages will be displayed. Otherwise, + ! they will be hidden. + ! + ! Raises: + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! These errors are likely to crash the program in unexpected + ! ways... + ! + subroutine nc_set_info_display(info_on_off) + logical :: info_on_off +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, L, A)") "nc_set_info_display(info_on_off = ", info_on_off, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + nclayer_enable_info = info_on_off + end subroutine nc_set_info_display + + ! Display a given information message. + ! + ! Display a specified information message. + ! + ! If ANSI colors are enabled at compile time, the entire message + ! will be printed in blue. + ! + ! Args: + ! ifo (character(len=*)): the information message to + ! display. + ! + ! Raises: + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! These errors are likely to crash the program in unexpected + ! ways... + ! + subroutine nclayer_info(ifo) + character(len=*), intent(in) :: ifo + if (nclayer_enable_info) & + write(*, "(A)") " ** INFO: " // ifo + end subroutine nclayer_info + +#ifdef _DEBUG_MEM_ + ! Display a given debug message. + ! + ! Display a specified debug message. This subroutine is only + ! enabled when _DEBUG_MEM_ is defined at compile time. + ! Otherwise, this subroutine will not exist. + ! + ! Therefore, any calls to this subroutine must have the + ! '#ifdef _DEBUG_MEM_' and #endif surrounding it. + ! + ! Args: + ! dbg (character(len=*)): the debug message to display. + ! + ! Raises: + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, or even a bug. + ! These errors are likely to crash the program in unexpected + ! ways... + ! + subroutine nclayer_debug(dbg) + character(len=*), intent(in) :: dbg + write(*, "(A, A)") "D: ", dbg + end subroutine nclayer_debug +#endif + + ! Check whether a NetCDF operation completed successfully or + ! not, and if not, display the corresponding error message. + ! + ! Given the NetCDF error code integer, determine whether the + ! corresponding NetCDF operation succeeded or not. If it failed, + ! display the corresponding error message and exit. + ! + ! Args: + ! status (integer(i_long)): NetCDF error code to check. + ! + ! Raises: + ! Although unlikely, other errors may indirectly occur. + ! They may be general storage errors, NetCDF errors, or even + ! a bug. See the called subroutines' documentation for + ! details. + ! + subroutine nclayer_check(status) + integer(i_long), intent(in) :: status + + if(status /= nf90_noerr) then + call nclayer_error(trim(nf90_strerror(status))) + end if + end subroutine nclayer_check +end module ncdw_climsg diff --git a/src/ncdiag/ncdw_data2d.F90 b/src/ncdiag/ncdw_data2d.F90 new file mode 100644 index 000000000..80aea4318 --- /dev/null +++ b/src/ncdiag/ncdw_data2d.F90 @@ -0,0 +1,1826 @@ +! nc_diag_write - NetCDF Layer Diag Writing Module +! Copyright 2015 Albert Huang - SSAI/NASA for NASA GSFC GMAO (610.1). +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or +! implied. See the License for the specific language governing +! permissions and limitations under the License. +! +! data2d module - ncdw_data2d +! +module ncdw_data2d + ! Module that provides chaninfo variable storage support. + ! + ! This module has all of the subroutines needed to store chaninfo + ! data. It includes the chaninfo storing subroutine + ! (nc_diag_chaninfo), subroutines for controlling chaninfo data + ! (dimension setting, loading definitions, saving definitions, + ! saving data, etc.), and preallocation subroutines. + ! + ! Background: + ! chaninfo is a fixed storage variable, with dimensions of + ! 1 x nchans, where nchans is a known integer. + ! + ! Because we can know nchans, we can constrain the dimensions and + ! make a few assumptions: + ! + ! -> nchans won't change for the duration of the file being open; + ! -> nchans will be the same for all chaninfo variables, for any + ! type involved; + ! -> because everything is fixed, we can store variables block + ! by block! + ! + ! Because Fortran is a strongly typed language, we can't do silly + ! tricks in C, like allocating some memory to a void pointer and + ! just storing our byte, short, int, long, float, or double numeric + ! data there, and later casting it back... + ! + ! (e.g. void **data_ref; data_ref = malloc(sizeof(void *) * 1000); + ! float *f = malloc(sizeof(float)); *f = 1.2345; + ! data_ref[0] = f; ...) + ! + ! No frets - we can work around this issue with some derived types + ! and arrays! We create an array for each type we want to support. + ! Since we're using kinds.F90, we support the following types: + ! i_byte, i_short, i_long, r_single, r_double + ! + ! The derived type used, diag_chaninfo, has these variables to help + ! us keep track of everything: + ! + ! -> ci_* - these arrays have the types listed above, plus string + ! support! These arrays are simply arrays that we throw our data + ! in. However, don't mistaken "throw in" with "disorganized" - + ! chaninfo uses a very structured format for these variables! + ! Keep reading to find out how we structure it... + ! + ! -> nchans - the number of channels to use. Remember that chaninfo + ! variables have dimensions 1 x nchans - basically, we need to + ! store nchans values. We'll need this a LOT to do consistency + ! checks, and to keep track of everything! + ! + ! -> names - all of the chaninfo variable names! We'll be using + ! this array to store and lookup chaninfo variables, as well as + ! storing them! + ! + ! -> types - all of the chaninfo variable types! These are byte + ! integers that get compared to our NLAYER_* type constants + ! (see: ncdw_types.F90). + ! + ! -> var_usage - the amount of entries we've stored in our chaninfo + ! variable! For instance, if we called + ! nc_diag_chaninfo("myvar", 1) three times, for that particular + ! var_usage(i), we would have an entry of 3. + ! + ! -> var_rel_pos - the star of the show! This is an abbreviation + ! of "variable relative positioning". Recall that we store + ! our variable data in ci_* specific type arrays. We know + ! the nchans amount, and we know the type. This variable stores + ! the "block" that our data is in within the type array. + ! + ! Therefore, we can use the equation to find our starting + ! position: 1 + [(REL_VAL - 1) * nchans] + ! + ! For instance, if var_rel_pos(1) for variable names(1) = "bla" + ! is set to 2, nchans is 10, and the type is NLAYER_FLOAT, we + ! can deduce that in ci_rsingle, our data can be found starting + ! at 1 + (1 * 10) = 11. This makes sense, as seen with our mini + ! diagram below: + ! + ! ci_rsingle: + ! / ci_rsingle index \ + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + ! [ x, x, x, x, x, x, x, x, x, x, y, y, y, y, y, y, y, y, y, y ] + ! \ ci_rsingle array / + ! + ! Indeed, our second block does start at index 11! + ! As a bonus, since our data is in blocks, things can be super + ! fast since we're just cutting our big array into small ones! + ! + ! -> acount_v: Finally, we have dynamic allocation. We have in our + ! type a variable called acount_v. This tells us how many + ! variables are stored in each type. Using the same equation + ! above, and combining with var_usage, we can figure out where + ! to put our data! + ! + ! Assume var_usage(i) = 2, block starts at index 11 with the + ! equation above. + ! + ! Again, with our fun little diagram: + ! + ! ci_rsingle: + ! / ci_rsingle index \ + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + ! [ x, x, x, x, x, x, x, x, x, x, y, y, Y, y, y, y, y, y, y, y ] + ! [ BLOCK 1 SEEK = 1->10->11 ][var_u=2|---block 2 area 11->20] + ! \ ci_rsingle array / + ! + ! The capital Y marks the place we store our data! + ! + ! For the non-data variables (e.g. variable names, types, etc.), + ! they are indexed by variable insertion order. This allows for + ! easy lookup by looking up the variable name, and using the + ! resulting index for fetching other information. + ! + ! Example: + ! names: [ 'asdf', 'ghjk', 'zxcv' ] + ! types: [ BYTE, FLOAT, BYTE ] + ! var_rel_pos: [ 1, 1, 2 ] + ! + ! Lookup: "ghjk", result index = 2 + ! + ! Therefore, the "ghjk" variable type is types(2) = FLOAT, and + ! the var_rel_pos for "ghjk" variable is var_rel_pos(2) = 1. + ! + ! These variables are allocated and reallocated, as needed. + ! + ! For the variable metadata fields (variable names, types, + ! relative indicies, etc.), these are reallocated incrementally + ! when a new variable is added. + ! + ! For the data storage fields, these are reallocated incrementally + ! when new data is added. + ! + ! Initial allocation and subsequent reallocation is done by + ! chunks. Allocating one element and/or reallocating and adding + ! just one element is inefficient, since it's likely that much + ! more data (and variables) will be added. Thus, allocation and + ! reallocation is done by (re-)allocating exponentially increasing + ! chunk sizes. See nc_diag_chaninfo_allocmulti help for more + ! details. + ! + ! Because (re-)allocation is done in chunks, we keep a count of + ! how much of the memory we're using so that we know when it's + ! time to (re-)allocate. Once we need to (re-)allocate, we + ! perform it, and then update our total memory counter to keep + ! track of the memory already allocated. + ! + ! With all of these variables (and a few more state variables), + ! we can reliably store our chaninfo data quickly and + ! efficiently! + ! + + use ncd_kinds, only: i_byte, i_short, i_long, i_llong, r_single, & + r_double + use ncdw_state, only: init_done, append_only, ncid, & + enable_trim, & + diag_data2d_store, diag_varattr_store + use ncdw_types, only: NLAYER_BYTE, NLAYER_SHORT, NLAYER_LONG, & + NLAYER_FLOAT, NLAYER_DOUBLE, NLAYER_STRING, NLAYER_CHUNKING, & + NLAYER_COMPRESSION, NLAYER_FILL_BYTE, NLAYER_FILL_SHORT, & + NLAYER_FILL_LONG, NLAYER_FILL_FLOAT, NLAYER_FILL_DOUBLE, & + NLAYER_FILL_CHAR, & + NLAYER_DEFAULT_ENT, NLAYER_MULTI_BASE + use ncdw_strarrutils, only: & +#ifdef _DEBUG_MEM_ + string_array_dump, & +#endif + max_len_string_array, max_len_notrim_string_array + use ncdw_varattr, only: nc_diag_varattr_make_nobs_dim, & + nc_diag_varattr_add_var + + use ncdw_dresize, only: nc_diag_data2d_resize_byte, & + nc_diag_data2d_resize_short, nc_diag_data2d_resize_long, & + nc_diag_data2d_resize_rsingle, nc_diag_data2d_resize_rdouble, & + nc_diag_data2d_resize_string, nc_diag_data2d_resize_iarr_type, & + nc_diag_data2d_resize_iarr + use ncdw_realloc, only: nc_diag_realloc + + use netcdf, only: nf90_inquire, nf90_inquire_variable, & + nf90_inquire_dimension, nf90_def_dim, nf90_def_var, & + nf90_def_var_deflate, nf90_def_var_chunking, nf90_put_var, & + NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE, & + NF90_CHAR, NF90_MAX_NAME, NF90_CHUNKED + + use ncdw_climsg, only: & +#ifdef ENABLE_ACTION_MSGS + nclayer_enable_action, nclayer_actionm, & +#endif +#ifdef _DEBUG_MEM_ + nclayer_debug, & +#endif + nclayer_error, nclayer_warning, nclayer_info, nclayer_check + + implicit none + + interface nc_diag_data2d + module procedure nc_diag_data2d_byte, & + nc_diag_data2d_short, nc_diag_data2d_long, & + nc_diag_data2d_rsingle, nc_diag_data2d_rdouble, & + nc_diag_data2d_string + end interface nc_diag_data2d + + contains + subroutine nc_diag_data2d_allocmulti(multiplier) + integer(i_long), intent(in) :: multiplier + if (init_done) then + ! # of times we needed to realloc simple data2d + ! also the multiplier factor for allocation (2^x) + diag_data2d_store%alloc_s_multi = multiplier + + ! # of times we needed to realloc data2d data storage + ! also the multiplier factor for allocation (2^x) + diag_data2d_store%alloc_m_multi = multiplier + + ! # of times we needed to realloc data2d INDEX data storage + ! also the multiplier factor for allocation (2^x) + diag_data2d_store%alloc_mi_multi = multiplier + end if + end subroutine nc_diag_data2d_allocmulti + + function nc_diag_data2d_max_len_var(var_index) result(max_len) + integer(i_llong), intent(in) :: var_index + + integer :: i, max_len + + character(len=1000) :: data_uneven_msg + + max_len = -1 + + do i = 1, diag_data2d_store%stor_i_arr(var_index)%icount + ! Only show a message if strict checking is enabled. + ! Otherwise, show the message later in data writing. + if (diag_data2d_store%strict_check .AND. & + (diag_data2d_store%stor_i_arr(var_index)%length_arr(i) /= max_len) .AND. & + (max_len /= -1)) then + ! Show message! + ! NOTE - I0 and TRIM are Fortran 95 specs + write (data_uneven_msg, "(A, I0, A, I0, A)") "Amount of data written in " // & + trim(diag_data2d_store%names(var_index)) // " (", & + diag_data2d_store%stor_i_arr(var_index)%length_arr(i), & + ")" // char(10) // & + " does not match the variable length" // & + " (", max_len, ")!" + + ! Probably not needed, since this only triggers on a + ! strict check... but just in case... + if (diag_data2d_store%strict_check) then + call nclayer_error(trim(data_uneven_msg)) + else + call nclayer_warning(trim(data_uneven_msg)) + end if + end if + + if (diag_data2d_store%stor_i_arr(var_index)%length_arr(i) > max_len) & + max_len = diag_data2d_store%stor_i_arr(var_index)%length_arr(i) + end do + end function nc_diag_data2d_max_len_var + + subroutine nc_diag_data2d_load_def + integer(i_long) :: ndims, nvars, var_index, type_index + integer(i_long) :: rel_index, i, nobs_size + + character(len=NF90_MAX_NAME) :: tmp_var_name + integer(i_long) :: tmp_var_type, tmp_var_ndims + + integer(i_long), dimension(:), allocatable :: tmp_var_dimids, tmp_var_dim_sizes + character(len=NF90_MAX_NAME) , allocatable :: tmp_var_dim_names(:) + + logical :: is_data2d_var + + ! Get top level info about the file! + call nclayer_check(nf90_inquire(ncid, nDimensions = ndims, & + nVariables = nvars)) + + ! Now search for variables that use data2d storage! + ! Loop through each variable! + do var_index = 1, nvars + ! Grab number of dimensions and attributes first + call nclayer_check(nf90_inquire_variable(ncid, var_index, name = tmp_var_name, ndims = tmp_var_ndims)) + + ! Allocate temporary variable dimids storage! + allocate(tmp_var_dimids(tmp_var_ndims)) + allocate(tmp_var_dim_names(tmp_var_ndims)) + allocate(tmp_var_dim_sizes(tmp_var_ndims)) + + ! Grab the actual dimension IDs and attributes + + call nclayer_check(nf90_inquire_variable(ncid, var_index, dimids = tmp_var_dimids, & + xtype = tmp_var_type)) + + if ((tmp_var_ndims == 2) .OR. & + ((tmp_var_ndims == 3) .AND. (tmp_var_type == NF90_CHAR))) then + is_data2d_var = .FALSE. + + do i = 1, tmp_var_ndims + call nclayer_check(nf90_inquire_dimension(ncid, tmp_var_dimids(i), tmp_var_dim_names(i), & + tmp_var_dim_sizes(i))) + + if (tmp_var_dim_names(i) == "nobs") then + nobs_size = tmp_var_dim_sizes(i) + if (tmp_var_type /= NF90_CHAR) then + is_data2d_var = .TRUE. + else if (tmp_var_type == NF90_CHAR) then + if (index(tmp_var_dim_names(1), "_str_dim") /= 0) & + is_data2d_var = .TRUE. + end if + end if + end do + + if (is_data2d_var) then + ! Expand things first! + call nc_diag_data2d_expand + + ! Add to the total! + diag_data2d_store%total = diag_data2d_store%total + 1 + + ! Store name and type! + diag_data2d_store%names(diag_data2d_store%total) = trim(tmp_var_name) + + ! The relative index is the total nobs + rel_index = nobs_size + + if (tmp_var_type == NF90_BYTE) then + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_BYTE + type_index = 1 + else if (tmp_var_type == NF90_SHORT) then + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_SHORT + type_index = 2 + else if (tmp_var_type == NF90_INT) then + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_LONG + type_index = 3 + else if (tmp_var_type == NF90_FLOAT) then + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_FLOAT + type_index = 4 + else if (tmp_var_type == NF90_DOUBLE) then + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_DOUBLE + type_index = 5 + else if (tmp_var_type == NF90_CHAR) then + diag_data2d_store%max_str_lens(diag_data2d_store%total) = tmp_var_dim_sizes(1) + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_STRING + type_index = 6 + else + call nclayer_error("NetCDF4 type invalid!") + end if + + if (tmp_var_type == NF90_CHAR) then + diag_data2d_store%max_lens(diag_data2d_store%total) = tmp_var_dim_sizes(2) + else + diag_data2d_store%max_lens(diag_data2d_store%total) = tmp_var_dim_sizes(1) + end if + + print *, trim(tmp_var_name), "rel index", rel_index + + ! Now add a relative position... based on the next position! + + ! Set relative index! + diag_data2d_store%rel_indexes(diag_data2d_store%total) = rel_index + + ! Set variable ID! Note that var_index here is the actual variable ID. + diag_data2d_store%var_ids(diag_data2d_store%total) = var_index + end if + end if + + ! Deallocate + deallocate(tmp_var_dimids) + deallocate(tmp_var_dim_names) + deallocate(tmp_var_dim_sizes) + end do + + diag_data2d_store%def_lock = .TRUE. + end subroutine nc_diag_data2d_load_def + + subroutine nc_diag_data2d_write_def(internal) + logical, intent(in), optional :: internal + + integer(i_byte) :: data_type + character(len=100) :: data2d_name + + integer(i_llong) :: curdatindex, j + integer(i_long) :: nc_data_type + integer(i_long) :: tmp_dim_id + character(len=120) :: data_dim_name + character(len=120) :: data_dim_str_name + integer(i_long) :: max_len + integer(i_long) :: max_str_len, msl_tmp + + character(len=:), allocatable :: string_arr(:) + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + if (present(internal)) then + write(action_str, "(A, L, A)") "nc_diag_data2d_write_def(internal = ", internal, ")" + else + write(action_str, "(A)") "nc_diag_data2d_write_def(internal = (not specified))" + end if + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (init_done) then + if (.NOT. diag_data2d_store%def_lock) then + ! Use global nobs ID! + ! Call subroutine to ensure the nobs dim is created already... + call nc_diag_varattr_make_nobs_dim + + do curdatindex = 1, diag_data2d_store%total + data2d_name = diag_data2d_store%names(curdatindex) + data_type = diag_data2d_store%types(curdatindex) + + call nclayer_info("data2d: defining " // trim(data2d_name)) + + if (data_type == NLAYER_BYTE) nc_data_type = NF90_BYTE + if (data_type == NLAYER_SHORT) nc_data_type = NF90_SHORT + if (data_type == NLAYER_LONG) nc_data_type = NF90_INT + if (data_type == NLAYER_FLOAT) nc_data_type = NF90_FLOAT + if (data_type == NLAYER_DOUBLE) nc_data_type = NF90_DOUBLE + if (data_type == NLAYER_STRING) nc_data_type = NF90_CHAR + +#ifdef _DEBUG_MEM_ + print *, "data2d part 1" +#endif + + ! We need to create a new dimension... + write (data_dim_name, "(A, A)") trim(data2d_name), "_arr_dim" + + ! Find the maximum array length of this variable! + max_len = nc_diag_data2d_max_len_var(curdatindex) + + ! Create this maximum array length dimension for this variable + if (.NOT. append_only) & + call nclayer_check(nf90_def_dim(ncid, data_dim_name, max_len, diag_data2d_store%var_dim_ids(curdatindex))) + + ! Store maximum length + diag_data2d_store%max_lens(curdatindex) = max_len; + + if (data_type == NLAYER_STRING) then + max_str_len = 0 + write (data_dim_name, "(A, A)") trim(data2d_name), "_maxstrlen" + + ! If trimming is enabled, we haven't found our max_str_len yet. + ! Go find it! + if (enable_trim) then + ! Dimension is # of chars by # of obs (unlimited) + do j = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + allocate(character(10000) :: string_arr(diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j))) + string_arr = & + diag_data2d_store%m_string(diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) & + : diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) + & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j)) + +#ifdef _DEBUG_MEM_ + write(*, "(A, I0)") "DEBUG DATA2D: tmp array size is: ", diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j) +#endif + + ! Now we can calculate the length! + msl_tmp = max_len_string_array(string_arr, & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j)) + + if (msl_tmp > max_str_len) max_str_len = msl_tmp + +#ifdef _DEBUG_MEM_ + write (*, "(A, A, A, I0, A, I0)") "DEBUG DATA2D DEF WRITE: at data2d_name ", trim(data2d_name), ", msl_tmp computes to ", msl_tmp, ", max_str_len computes to ", max_str_len + print *, "DEBUG DATA2D DEF WRITE: string array dump follows:" + call string_array_dump(string_arr) +#endif + + ! Deallocate right after we're done! + deallocate(string_arr) + end do +#ifdef _DEBUG_MEM_ + write (*, "(A, A, A, I0, A, I0)") "DEBUG DATA2D DEF WRITE: ** at data2d_name ", trim(data2d_name), ", FINAL max_str_len computes to ", max_str_len, ", max_len computes to ", max_len +#endif + + ! Save the max string len + diag_data2d_store%max_str_lens(curdatindex) = max_str_len + end if + + ! Create dimension needed! + write (data_dim_str_name, "(A, A)") trim(data2d_name), "_str_dim" + if (.NOT. append_only) & + call nclayer_check(nf90_def_dim(ncid, data_dim_str_name, & + diag_data2d_store%max_str_lens(curdatindex), tmp_dim_id)) + +#ifdef _DEBUG_MEM_ + print *, "Defining char var type..." +#endif + + if (.NOT. append_only) & + call nclayer_check(nf90_def_var(ncid, data2d_name, nc_data_type, & + (/ tmp_dim_id, diag_data2d_store%var_dim_ids(curdatindex), & + diag_varattr_store%nobs_dim_id /), & + diag_data2d_store%var_ids(curdatindex))) + +#ifdef _DEBUG_MEM_ + write (*, "(A, A, A, I0, A, I0)") "DEBUG DATA2D DEF WRITE: ** at data2d_name ", trim(data2d_name), ", result VID is ", diag_data2d_store%var_ids(curdatindex) + write (*, "(A, I0, A, I0)") "DEBUG DATA2D DEF WRITE: ** result dim is unlim x max_len = ", max_len, " x max_str_len = ", diag_data2d_store%max_str_lens(curdatindex) + print *, "data2d part 2" +#endif + +#ifdef _DEBUG_MEM_ + print *, "Done defining char var type..." +#endif + else +#ifdef _DEBUG_MEM_ + print *, "Definition for variable " // trim(data2d_name) // ":" + print *, diag_data2d_store%max_lens(curdatindex), "x unlimited (NetCDF order)" +#endif + if (.NOT. append_only) & + call nclayer_check(nf90_def_var(ncid, data2d_name, nc_data_type, & + (/ diag_data2d_store%var_dim_ids(curdatindex), diag_varattr_store%nobs_dim_id /), & + diag_data2d_store%var_ids(curdatindex))) + end if + + call nc_diag_varattr_add_var(diag_data2d_store%names(curdatindex), & + diag_data2d_store%types(curdatindex), & + diag_data2d_store%var_ids(curdatindex)) + + ! Enable compression + ! Args: ncid, varid, enable_shuffle (yes), enable_deflate (yes), deflate_level +#ifdef _DEBUG_MEM_ + print *, "Defining compression 1 (chunking)..." +#endif + + if (.NOT. append_only) then + if (data_type == NLAYER_STRING) then + call nclayer_check(nf90_def_var_chunking(ncid, diag_data2d_store%var_ids(curdatindex), & + NF90_CHUNKED, (/ diag_data2d_store%max_str_lens(curdatindex), & + diag_data2d_store%max_lens(curdatindex), NLAYER_CHUNKING /))) + else + call nclayer_check(nf90_def_var_chunking(ncid, diag_data2d_store%var_ids(curdatindex), & + NF90_CHUNKED, (/ diag_data2d_store%max_lens(curdatindex), NLAYER_CHUNKING /))) + end if + end if +#ifdef _DEBUG_MEM_ + print *, "Defining compression 2 (gzip)..." +#endif + if (.NOT. append_only) & + call nclayer_check(nf90_def_var_deflate(ncid, diag_data2d_store%var_ids(curdatindex), & + 1, 1, int(NLAYER_COMPRESSION))) + +#ifdef _DEBUG_MEM_ + print *, "Done defining compression..." +#endif + + ! Lock the definitions! + diag_data2d_store%def_lock = .TRUE. + end do + else + if(.NOT. present(internal)) & + call nclayer_error("Can't write definitions - definitions have already been written and locked!") + end if + end if + end subroutine nc_diag_data2d_write_def + + subroutine nc_diag_data2d_write_data(flush_data_only) + ! Optional internal flag to only flush data - if this is + ! true, data flushing will be performed, and the data will + ! NOT be locked. + logical, intent(in), optional :: flush_data_only + + integer(i_byte) :: data_type + character(len=100) :: data2d_name + + ! For some strange reason, curdatindex needs to be + ! initialized here to 1, otherwise a runtime error of using + ! an undefined variable occurs... even though it's set + ! by the DO loop... + integer(i_long) :: curdatindex = 1, j +#ifdef _DEBUG_MEM_ + ! Index counter for inner loop (intermediate) array debug + integer(i_long) :: i +#endif + + integer(i_byte), dimension(:, :), allocatable :: byte_arr + integer(i_short),dimension(:, :), allocatable :: short_arr + integer(i_long), dimension(:, :), allocatable :: long_arr + real(r_single), dimension(:, :), allocatable :: rsingle_arr + real(r_double), dimension(:, :), allocatable :: rdouble_arr + character(len=:),dimension(:, :), allocatable :: string_arr + + integer(i_long) :: max_str_len + + integer(i_llong) :: data_length_counter + character(len=100) :: counter_data_name + integer(i_llong) :: current_length_count + character(len=1000) :: data_uneven_msg + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + if (present(flush_data_only)) then + write(action_str, "(A, L, A)") "nc_diag_data2d_write_data(flush_data_only = ", flush_data_only, ")" + else + write(action_str, "(A)") "nc_diag_data2d_write_data(flush_data_only = (not specified))" + end if + call nclayer_actionm(trim(action_str)) + end if +#endif + + ! Initialization MUST occur here, not in decl... + ! Otherwise, it'll initialize once, and never again... + ! + ! This will cause scary issues in the future, where closing + ! and opening a new file shows strange errors about a file + ! opened in the past... + max_str_len = -1 + data_length_counter = -1 + current_length_count = -1 + + if (init_done .AND. allocated(diag_data2d_store)) then + if (.NOT. diag_data2d_store%data_lock) then + do curdatindex = 1, diag_data2d_store%total +#ifdef _DEBUG_MEM_ + print *, curdatindex +#endif + data2d_name = diag_data2d_store%names(curdatindex) + data_type = diag_data2d_store%types(curdatindex) + + call nclayer_info("data2d: writing " // trim(data2d_name)) + + ! Warn about data inconsistencies + if (.NOT. (present(flush_data_only) .AND. flush_data_only)) then + current_length_count = diag_data2d_store%stor_i_arr(curdatindex)%icount + & + diag_data2d_store%rel_indexes(curdatindex) + + if (data_length_counter == -1) then + data_length_counter = current_length_count + counter_data_name = data2d_name + else + if (data_length_counter /= current_length_count) then + ! Show message! + ! NOTE - I0 and TRIM are Fortran 95 specs + write (data_uneven_msg, "(A, I0, A, I0, A)") "Amount of data written in " // & + trim(data2d_name) // " (", & + current_length_count, & + ")" // char(10) // & + " differs from variable " // trim(counter_data_name) // & + " (", data_length_counter, ")!" + + if (diag_data2d_store%strict_check) then + call nclayer_error(trim(data_uneven_msg)) + else + call nclayer_warning(trim(data_uneven_msg)) + end if + end if + end if + end if + + ! Make sure we have data to write in the first place! + if (diag_data2d_store%stor_i_arr(curdatindex)%icount > 0) then + ! MAJOR GOTCHA: + ! Fortran is weird... and by weird, we mean Fortran's indexing + ! system! Fortran uses a column-major system, which means that + ! we MUST allocate and store in a column-major format! Each + ! column needs to store a single array of data. Before, with + ! single dimensions, this didn't matter since the data itself + ! was automatically stored into a column. With 2D data, + ! we MUST be aware of the reversed dimensions! + ! (NetCDF4 respects the Fortran way, and takes in a "row" of + ! data via columns!) + + if (data_type == NLAYER_BYTE) then + allocate(byte_arr(diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount)) + + byte_arr = NLAYER_FILL_BYTE + + do j = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + ! Just in case our definition checks failed... + if (diag_data2d_store%max_lens(curdatindex) /= & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j)) then + ! Show message! + ! NOTE - I0 and TRIM are Fortran 95 specs + write (data_uneven_msg, "(A, I0, A, I0, A)") "Amount of data written in " // & + trim(data2d_name) // " (", & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), & + ")" // char(10) // & + " does not match the variable length" // & + " (", diag_data2d_store%max_lens(curdatindex), ")!" + + if (diag_data2d_store%strict_check) then + call nclayer_error(trim(data_uneven_msg)) + else + call nclayer_warning(trim(data_uneven_msg)) + end if + end if + + byte_arr(1 : diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), j) = & + diag_data2d_store%m_byte( & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) : & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) + & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j) - 1) + end do + + call nclayer_check(nf90_put_var(& + ncid, diag_data2d_store%var_ids(curdatindex), & + byte_arr, & + (/ 1, 1 + diag_data2d_store%rel_indexes(curdatindex) /), & + (/ diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount /) & + )) + + deallocate(byte_arr) + else if (data_type == NLAYER_SHORT) then + allocate(short_arr(diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount)) + + short_arr = NLAYER_FILL_SHORT + + do j = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + ! Just in case our definition checks failed... + if (diag_data2d_store%max_lens(curdatindex) /= & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j)) then + ! Show message! + ! NOTE - I0 and TRIM are Fortran 95 specs + write (data_uneven_msg, "(A, I0, A, I0, A)") "Amount of data written in " // & + trim(data2d_name) // " (", & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), & + ")" // char(10) // & + " does not match the variable length" // & + " (", diag_data2d_store%max_lens(curdatindex), ")!" + + if (diag_data2d_store%strict_check) then + call nclayer_error(trim(data_uneven_msg)) + else + call nclayer_warning(trim(data_uneven_msg)) + end if + end if + + short_arr(1 : diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), j) = & + diag_data2d_store%m_short( & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) : & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) + & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j) - 1) + end do + + call nclayer_check(nf90_put_var(& + ncid, diag_data2d_store%var_ids(curdatindex), & + short_arr, & + (/ 1, 1 + diag_data2d_store%rel_indexes(curdatindex) /), & + (/ diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount /) & + )) + + deallocate(short_arr) + else if (data_type == NLAYER_LONG) then + !allocate(long_arr(diag_data2d_store%stor_i_arr(curdatindex)%icount, & + ! diag_data2d_store%max_lens(curdatindex))) + + allocate(long_arr(diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount)) + +#ifdef _DEBUG_MEM_ + write (*, "(A, I0)") "NLAYER_FILL_LONG = ", NLAYER_FILL_LONG +#endif + + long_arr = NLAYER_FILL_LONG + +#ifdef _DEBUG_MEM_ + write (*, "(A)") "************ DEBUG: INITIAL var array for " // trim(data2d_name) + do j = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + print *, long_arr(:, j) + end do +#endif + + do j = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + ! Just in case our definition checks failed... + if (diag_data2d_store%max_lens(curdatindex) /= & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j)) then + ! Show message! + ! NOTE - I0 and TRIM are Fortran 95 specs + write (data_uneven_msg, "(A, I0, A, I0, A)") "Amount of data written in " // & + trim(data2d_name) // " (", & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), & + ")" // char(10) // & + " does not match the variable length" // & + " (", diag_data2d_store%max_lens(curdatindex), ")!" + + if (diag_data2d_store%strict_check) then + call nclayer_error(trim(data_uneven_msg)) + else + call nclayer_warning(trim(data_uneven_msg)) + end if + end if + +#ifdef _DEBUG_MEM_ + write (*, "(A, I0, A)") "Adding to long_arr, index ", j, ":" + print *, diag_data2d_store%m_long( & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) : & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) + & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j) - 1) + write (*, "(A, I0)") " -> length of subarr: ", diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j) +#endif + + long_arr(1 : diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), j) = & + diag_data2d_store%m_long( & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) : & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) + & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j) - 1) + +#ifdef _DEBUG_MEM_ + write (*, "(A)") "************ DEBUG: INTERMEDIATE var array for " // trim(data2d_name) + do i = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + print *, long_arr(:, i) + end do +#endif + end do + +#ifdef _DEBUG_MEM_ + write (*, "(A, I0, A, I0, A, I0, A, I0, A)") & + "Writing long with start = (", 1, ", ", & + 1 + diag_data2d_store%rel_indexes(curdatindex), & + "), count = (", diag_data2d_store%stor_i_arr(curdatindex)%icount, & + ", ", 1, ")" + + write (*, "(A, I0, A, I0)") "************ DEBUG: dim for " // trim(data2d_name) // ": ", & + diag_data2d_store%stor_i_arr(curdatindex)%icount, " by ", & + diag_data2d_store%max_lens(curdatindex) + write (*, "(A)") "************ DEBUG: var array for " // trim(data2d_name) + + do j = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + print *, long_arr(:, j) + end do +#endif + + call nclayer_check(nf90_put_var(& + ncid, diag_data2d_store%var_ids(curdatindex), & + long_arr, & + (/ 1, 1 + diag_data2d_store%rel_indexes(curdatindex) /), & + (/ diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount /) & + )) + + deallocate(long_arr) + else if (data_type == NLAYER_FLOAT) then + allocate(rsingle_arr(diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount)) + + rsingle_arr = NLAYER_FILL_FLOAT + + do j = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + ! Just in case our definition checks failed... + if (diag_data2d_store%max_lens(curdatindex) /= & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j)) then + ! Show message! + ! NOTE - I0 and TRIM are Fortran 95 specs + write (data_uneven_msg, "(A, I0, A, I0, A)") "Amount of data written in " // & + trim(data2d_name) // " (", & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), & + ")" // char(10) // & + " does not match the variable length" // & + " (", diag_data2d_store%max_lens(curdatindex), ")!" + + if (diag_data2d_store%strict_check) then + call nclayer_error(trim(data_uneven_msg)) + else + call nclayer_warning(trim(data_uneven_msg)) + end if + end if + + rsingle_arr(1 : diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), j) = & + diag_data2d_store%m_rsingle( & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) : & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) + & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j) - 1) + end do + + !print *, "end queue / start put" + call nclayer_check(nf90_put_var(& + ncid, diag_data2d_store%var_ids(curdatindex), & + rsingle_arr, & + (/ 1, 1 + diag_data2d_store%rel_indexes(curdatindex) /), & + (/ diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount /) & + )) + !call nclayer_check(nf90_sync(ncid)) + deallocate(rsingle_arr) + !print *, "end put" + + else if (data_type == NLAYER_DOUBLE) then + allocate(rdouble_arr(diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount)) + + rdouble_arr = NLAYER_FILL_DOUBLE + + do j = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + ! Just in case our definition checks failed... + if (diag_data2d_store%max_lens(curdatindex) /= & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j)) then + ! Show message! + ! NOTE - I0 and TRIM are Fortran 95 specs + write (data_uneven_msg, "(A, I0, A, I0, A)") "Amount of data written in " // & + trim(data2d_name) // " (", & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), & + ")" // char(10) // & + " does not match the variable length" // & + " (", diag_data2d_store%max_lens(curdatindex), ")!" + + if (diag_data2d_store%strict_check) then + call nclayer_error(trim(data_uneven_msg)) + else + call nclayer_warning(trim(data_uneven_msg)) + end if + end if + + rdouble_arr(1 : diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), j) = & + diag_data2d_store%m_rdouble( & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) : & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) + & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j) - 1) + end do + + call nclayer_check(nf90_put_var(& + ncid, diag_data2d_store%var_ids(curdatindex), & + rdouble_arr, & + (/ 1, 1 + diag_data2d_store%rel_indexes(curdatindex) /), & + (/ diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount /) & + )) + deallocate(rdouble_arr) + else if (data_type == NLAYER_STRING) then + ! We need to seperate everything because the Intel Fortran compiler loves + ! to optimize... and then assume that I'll try to use an unallocated variable, + ! even with checks. + if (allocated(diag_data2d_store%max_str_lens)) then + max_str_len = diag_data2d_store%max_str_lens(curdatindex) + else + call nclayer_error("BUG: diag_data2d_store%max_str_lens not allocated yet!") + end if + + allocate(character(max_str_len) :: & + string_arr(diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount & + )) + + string_arr = NLAYER_FILL_CHAR + + do j = 1, diag_data2d_store%stor_i_arr(curdatindex)%icount + ! Just in case our definition checks failed... + if (diag_data2d_store%max_lens(curdatindex) /= & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j)) then + ! Show message! + ! NOTE - I0 and TRIM are Fortran 95 specs + write (data_uneven_msg, "(A, I0, A, I0, A)") "Amount of data written in " // & + trim(data2d_name) // " (", & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), & + ")" // char(10) // & + " does not match the variable length" // & + " (", diag_data2d_store%max_lens(curdatindex), ")!" + + if (diag_data2d_store%strict_check) then + call nclayer_error(trim(data_uneven_msg)) + else + call nclayer_warning(trim(data_uneven_msg)) + end if + end if + + string_arr(1 : diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j), j) = & + diag_data2d_store%m_string( & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) : & + diag_data2d_store%stor_i_arr(curdatindex)%index_arr(j) + & + diag_data2d_store%stor_i_arr(curdatindex)%length_arr(j) - 1) + end do + + if (allocated(diag_data2d_store%max_str_lens)) then + call nclayer_check(nf90_put_var(& + ncid, diag_data2d_store%var_ids(curdatindex), & + string_arr, & + (/ 1, 1, 1 + diag_data2d_store%rel_indexes(curdatindex) /), & + (/ diag_data2d_store%max_str_lens(curdatindex), & + diag_data2d_store%max_lens(curdatindex), & + diag_data2d_store%stor_i_arr(curdatindex)%icount /) & + )) + else + call nclayer_error("BUG: diag_data2d_store%max_str_lens not allocated yet!") + end if + + deallocate(string_arr) + end if + + ! Check for data flushing, and if so, update the relative indexes + ! and set icount to 0. + if (present(flush_data_only) .AND. flush_data_only) then + diag_data2d_store%rel_indexes(curdatindex) = & + diag_data2d_store%rel_indexes(curdatindex) + & + diag_data2d_store%stor_i_arr(curdatindex)%icount + diag_data2d_store%stor_i_arr(curdatindex)%icount = 0 + +#ifdef _DEBUG_MEM_ + print *, "diag_data2d_store%rel_indexes(curdatindex) is now:" + print *, diag_data2d_store%rel_indexes(curdatindex) +#endif + end if + + end if + end do + + if (present(flush_data_only) .AND. flush_data_only) then +#ifdef _DEBUG_MEM_ + print *, "In buffer flush mode!" +#endif + + ! We need to reset all array counts to zero! + diag_data2d_store%acount = 0 + else + ! Lock data writing + diag_data2d_store%data_lock = .TRUE. +#ifdef _DEBUG_MEM_ + print *, "In data lock mode!" +#endif + end if + else + call nclayer_error("Can't write data - data have already been written and locked!") + end if + else + call nclayer_error("Can't write data - NetCDF4 layer not initialized yet!") + end if + +#ifdef _DEBUG_MEM_ + print *, "All done writing data2d data" +#endif + end subroutine nc_diag_data2d_write_data + + ! Set strict checking + subroutine nc_diag_data2d_set_strict(enable_strict) + logical, intent(in) :: enable_strict + + if (init_done .AND. allocated(diag_data2d_store)) then + diag_data2d_store%strict_check = enable_strict + else + call nclayer_error("Can't set strictness level for data2d - NetCDF4 layer not initialized yet!") + end if + end subroutine nc_diag_data2d_set_strict + + ! Preallocate variable name/type/etc. storage. + subroutine nc_diag_data2d_prealloc_vars(num_of_addl_vars) + integer(i_llong), intent(in) :: num_of_addl_vars +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_data2d_prealloc_vars(num_of_addl_vars = ", num_of_addl_vars, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + if (init_done .AND. allocated(diag_data2d_store)) then + if (allocated(diag_data2d_store%names)) then + if (diag_data2d_store%total >= size(diag_data2d_store%names)) then + call nc_diag_realloc(diag_data2d_store%names, num_of_addl_vars) + end if + else + allocate(diag_data2d_store%names(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + end if + + if (allocated(diag_data2d_store%types)) then + if (diag_data2d_store%total >= size(diag_data2d_store%types)) then + call nc_diag_realloc(diag_data2d_store%types, num_of_addl_vars) + end if + else + allocate(diag_data2d_store%types(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + end if + + if (allocated(diag_data2d_store%stor_i_arr)) then + if (diag_data2d_store%total >= size(diag_data2d_store%stor_i_arr)) then + call nc_diag_data2d_resize_iarr_type(num_of_addl_vars) + end if + else + allocate(diag_data2d_store%stor_i_arr(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + end if + + if (allocated(diag_data2d_store%var_ids)) then + if (diag_data2d_store%total >= size(diag_data2d_store%var_ids)) then + call nc_diag_realloc(diag_data2d_store%var_ids, num_of_addl_vars) + end if + else + allocate(diag_data2d_store%var_ids(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_data2d_store%var_ids = -1 + end if + + if (allocated(diag_data2d_store%var_dim_ids)) then + if (diag_data2d_store%total >= size(diag_data2d_store%var_dim_ids)) then + call nc_diag_realloc(diag_data2d_store%var_dim_ids, num_of_addl_vars) + end if + else + allocate(diag_data2d_store%var_dim_ids(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_data2d_store%var_dim_ids = -1 + end if + + if (allocated(diag_data2d_store%alloc_sia_multi)) then + if (diag_data2d_store%total >= size(diag_data2d_store%alloc_sia_multi)) then + call nc_diag_realloc(diag_data2d_store%alloc_sia_multi, num_of_addl_vars) + end if + else + allocate(diag_data2d_store%alloc_sia_multi(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_data2d_store%alloc_sia_multi = 0 + end if + + if (allocated(diag_data2d_store%max_str_lens)) then + if (diag_data2d_store%total >= size(diag_data2d_store%max_str_lens)) then + call nc_diag_realloc(diag_data2d_store%max_str_lens, num_of_addl_vars) + end if + else + allocate(diag_data2d_store%max_str_lens(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_data2d_store%max_str_lens = -1 + end if + + if (allocated(diag_data2d_store%rel_indexes)) then + if (diag_data2d_store%total >= size(diag_data2d_store%rel_indexes)) then + call nc_diag_realloc(diag_data2d_store%rel_indexes, num_of_addl_vars) + end if + else + allocate(diag_data2d_store%rel_indexes(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_data2d_store%rel_indexes = 0 + end if + + if (allocated(diag_data2d_store%max_lens)) then + if (diag_data2d_store%total >= size(diag_data2d_store%max_lens)) then + call nc_diag_realloc(diag_data2d_store%max_lens, num_of_addl_vars) + end if + else + allocate(diag_data2d_store%max_lens(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_data2d_store%max_lens = 0 + end if + + diag_data2d_store%prealloc_total = diag_data2d_store%prealloc_total + num_of_addl_vars + else + call nclayer_error("NetCDF4 layer not initialized yet!") + endif + end subroutine nc_diag_data2d_prealloc_vars + + ! Preallocate actual variable data storage + subroutine nc_diag_data2d_prealloc_vars_storage(nclayer_type, num_of_addl_slots) + integer(i_byte), intent(in) :: nclayer_type + integer(i_llong), intent(in) :: num_of_addl_slots + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A, I0, A)") "nc_diag_data2d_prealloc_vars_storage(nclayer_type = ", nclayer_type, ", num_of_addl_slots = ", num_of_addl_slots, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (nclayer_type == NLAYER_BYTE) then + call nc_diag_data2d_resize_byte(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_SHORT) then + call nc_diag_data2d_resize_short(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_LONG) then + call nc_diag_data2d_resize_long(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_FLOAT) then + call nc_diag_data2d_resize_rsingle(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_DOUBLE) then + call nc_diag_data2d_resize_rdouble(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_STRING) then + call nc_diag_data2d_resize_string(num_of_addl_slots, .FALSE.) + else + call nclayer_error("Invalid type specified for variable storage preallocation!") + end if + end subroutine nc_diag_data2d_prealloc_vars_storage + + ! Preallocate index storage + subroutine nc_diag_data2d_prealloc_vars_storage_all(num_of_addl_slots) + integer(i_llong), intent(in) :: num_of_addl_slots + integer(i_long) :: i + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_data2d_prealloc_vars_storage_all(num_of_addl_slots = ", num_of_addl_slots, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + do i = 1, diag_data2d_store%prealloc_total + call nc_diag_data2d_resize_iarr(i, num_of_addl_slots, .FALSE.) + end do + end subroutine nc_diag_data2d_prealloc_vars_storage_all + + subroutine nc_diag_data2d_expand + integer(i_llong) :: addl_fields + + ! Did we realloc at all? + logical :: meta_realloc + + meta_realloc = .FALSE. + + if (init_done .AND. allocated(diag_data2d_store)) then + addl_fields = 1 + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_s_multi)) + +#ifdef _DEBUG_MEM_ + call nclayer_debug("INITIAL value of diag_data2d_store%alloc_s_multi:") + print *, diag_data2d_store%alloc_s_multi +#endif + + if (allocated(diag_data2d_store%names)) then + if (diag_data2d_store%total >= size(diag_data2d_store%names)) then +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocating diag_data2d_store%names...") + print *, (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_s_multi) + print *, addl_fields +#endif + call nc_diag_realloc(diag_data2d_store%names, addl_fields) +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocated diag_data2d_store%names. Size:") + print *, size(diag_data2d_store%names) +#endif + meta_realloc = .TRUE. + end if + else +#ifdef _DEBUG_MEM_ + call nclayer_debug("Allocating diag_data2d_store%names for first time...") + print *, NLAYER_DEFAULT_ENT +#endif + + allocate(diag_data2d_store%names(NLAYER_DEFAULT_ENT)) + +#ifdef _DEBUG_MEM_ + call nclayer_debug("Allocated diag_data2d_store%names. Size:") + print *, size(diag_data2d_store%names) +#endif + end if + + if (allocated(diag_data2d_store%types)) then + if (diag_data2d_store%total >= size(diag_data2d_store%types)) then +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocating diag_data2d_store%types...") + print *, (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_s_multi) + print *, addl_fields +#endif + call nc_diag_realloc(diag_data2d_store%types, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_data2d_store%types(NLAYER_DEFAULT_ENT)) + end if + + if (allocated(diag_data2d_store%stor_i_arr)) then + if (diag_data2d_store%total >= size(diag_data2d_store%stor_i_arr)) then +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocating diag_data2d_store%stor_i_arr...") + print *, (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_s_multi) + print *, (1 + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_s_multi))) +#endif + call nc_diag_data2d_resize_iarr_type(addl_fields) + + meta_realloc = .TRUE. + end if + else + allocate(diag_data2d_store%stor_i_arr(NLAYER_DEFAULT_ENT)) + end if + + if (allocated(diag_data2d_store%var_ids)) then + if (diag_data2d_store%total >= size(diag_data2d_store%var_ids)) then + call nc_diag_realloc(diag_data2d_store%var_ids, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_data2d_store%var_ids(NLAYER_DEFAULT_ENT)) + diag_data2d_store%var_ids = -1 + end if + + if (allocated(diag_data2d_store%var_dim_ids)) then + if (diag_data2d_store%total >= size(diag_data2d_store%var_dim_ids)) then + call nc_diag_realloc(diag_data2d_store%var_dim_ids, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_data2d_store%var_dim_ids(NLAYER_DEFAULT_ENT)) + diag_data2d_store%var_dim_ids = -1 + end if + + if (allocated(diag_data2d_store%alloc_sia_multi)) then + if (diag_data2d_store%total >= size(diag_data2d_store%alloc_sia_multi)) then + call nc_diag_realloc(diag_data2d_store%alloc_sia_multi, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_data2d_store%alloc_sia_multi(NLAYER_DEFAULT_ENT)) + diag_data2d_store%alloc_sia_multi = 0 + end if + + if (allocated(diag_data2d_store%max_str_lens)) then + if (diag_data2d_store%total >= size(diag_data2d_store%max_str_lens)) then + call nc_diag_realloc(diag_data2d_store%max_str_lens, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_data2d_store%max_str_lens(NLAYER_DEFAULT_ENT)) + diag_data2d_store%max_str_lens = -1 + end if + + if (allocated(diag_data2d_store%rel_indexes)) then + if (diag_data2d_store%total >= size(diag_data2d_store%rel_indexes)) then + call nc_diag_realloc(diag_data2d_store%rel_indexes, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_data2d_store%rel_indexes(NLAYER_DEFAULT_ENT)) + diag_data2d_store%rel_indexes = 0 + end if + + if (allocated(diag_data2d_store%max_lens)) then + if (diag_data2d_store%total >= size(diag_data2d_store%max_lens)) then + call nc_diag_realloc(diag_data2d_store%max_lens, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_data2d_store%max_lens(NLAYER_DEFAULT_ENT)) + diag_data2d_store%max_lens = 0 + end if + + if (meta_realloc) then + diag_data2d_store%alloc_s_multi = diag_data2d_store%alloc_s_multi + 1 +#ifdef _DEBUG_MEM_ + print *, "Incrementing alloc_s_multi... new value:" + print *, diag_data2d_store%alloc_s_multi +#endif + endif + else + call nclayer_error("NetCDF4 layer not initialized yet!") + endif + + end subroutine nc_diag_data2d_expand + + function nc_diag_data2d_lookup_var(data2d_name) result(ind) + character(len=*), intent(in) :: data2d_name + integer :: i, ind + + ind = -1 + + if (init_done .AND. allocated(diag_data2d_store)) then + do i = 1, diag_data2d_store%total + if (diag_data2d_store%names(i) == data2d_name) then + ind = i + exit + end if + end do + end if + end function nc_diag_data2d_lookup_var + + ! nc_diag_data2d - input integer(i_byte) + ! Corresponding NetCDF4 type: byte + subroutine nc_diag_data2d_byte(data2d_name, data2d_value) + character(len=*), intent(in) :: data2d_name + integer(i_byte), dimension(:), intent(in) :: data2d_value + + integer(i_long) :: var_index + integer(i_llong) :: input_size + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + integer(i_llong) :: data_value_size + + if (nclayer_enable_action) then + data_value_size = size(data2d_value) + write(action_str, "(A, I0, A, I0, A, I0, A, I0, A)") & + "nc_diag_data2d_byte(data2d_name = " // data2d_name // & + ", data2d_value = array with length of ", & + data_value_size, & + " [", & + data2d_value(1), & + " ... ", & + data2d_value(data_value_size), & + "]" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_data2d_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_data2d_lookup_var(data2d_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_data2d_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_data2d_expand + + diag_data2d_store%total = diag_data2d_store%total + 1 + + diag_data2d_store%names(diag_data2d_store%total) = data2d_name + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_BYTE + + var_index = diag_data2d_store%total + end if + + ! Get input size and do size checks! + input_size = size(data2d_value) + + if ((diag_data2d_store%def_lock) .AND. & + (size(data2d_value) > diag_data2d_store%max_lens(var_index))) then + call nclayer_error("Cannot expand variable size after locking variable definitions!") + end if + + ! We just need to add one entry... + call nc_diag_data2d_resize_iarr(var_index, 1_i_llong) + call nc_diag_data2d_resize_byte(input_size) + + ! Now add the actual entry! + diag_data2d_store%m_byte(diag_data2d_store%acount(1) - input_size + 1:diag_data2d_store%acount(1)) = & + data2d_value + diag_data2d_store%stor_i_arr(var_index)%index_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + diag_data2d_store%acount(1) - input_size + 1 + diag_data2d_store%stor_i_arr(var_index)%length_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + input_size + end subroutine nc_diag_data2d_byte + + ! nc_diag_data2d - input integer(i_short) + ! Corresponding NetCDF4 type: short + subroutine nc_diag_data2d_short(data2d_name, data2d_value) + character(len=*), intent(in) :: data2d_name + integer(i_short), dimension(:), intent(in) :: data2d_value + + integer(i_long) :: var_index + integer(i_llong) :: input_size + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + integer(i_llong) :: data_value_size + + if (nclayer_enable_action) then + data_value_size = size(data2d_value) + write(action_str, "(A, I0, A, I0, A, I0, A, I0, A)") & + "nc_diag_data2d_short(data2d_name = " // data2d_name // & + ", data2d_value = array with length of ", & + data_value_size, & + " [", & + data2d_value(1), & + " ... ", & + data2d_value(data_value_size), & + "]" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_data2d_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_data2d_lookup_var(data2d_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_data2d_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_data2d_expand + + diag_data2d_store%total = diag_data2d_store%total + 1 + + diag_data2d_store%names(diag_data2d_store%total) = data2d_name + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_SHORT + + var_index = diag_data2d_store%total + end if + + ! Get input size and do size checks! + input_size = size(data2d_value) + + if ((diag_data2d_store%def_lock) .AND. & + (size(data2d_value) > diag_data2d_store%max_lens(var_index))) then + call nclayer_error("Cannot expand variable size after locking variable definitions!") + end if + + ! We just need to add one entry... + call nc_diag_data2d_resize_iarr(var_index, 1_i_llong) + call nc_diag_data2d_resize_short(input_size) + + ! Now add the actual entry! + diag_data2d_store%m_short(diag_data2d_store%acount(2) - input_size + 1:diag_data2d_store%acount(2)) = & + data2d_value + diag_data2d_store%stor_i_arr(var_index)%index_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + diag_data2d_store%acount(2) - input_size + 1 + diag_data2d_store%stor_i_arr(var_index)%length_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + input_size + end subroutine nc_diag_data2d_short + + ! nc_diag_data2d - input integer(i_long) + ! Corresponding NetCDF4 type: int (old: long) + subroutine nc_diag_data2d_long(data2d_name, data2d_value) + character(len=*), intent(in) :: data2d_name + integer(i_long), dimension(:), intent(in) :: data2d_value + + integer(i_long) :: var_index + integer(i_llong) :: input_size + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + integer(i_llong) :: data_value_size + + if (nclayer_enable_action) then + data_value_size = size(data2d_value) + write(action_str, "(A, I0, A, I0, A, I0, A, I0, A)") & + "nc_diag_data2d_long(data2d_name = " // data2d_name // & + ", data2d_value = array with length of ", & + data_value_size, & + " [", & + data2d_value(1), & + " ... ", & + data2d_value(data_value_size), & + "]" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_data2d_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_data2d_lookup_var(data2d_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_data2d_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_data2d_expand + + diag_data2d_store%total = diag_data2d_store%total + 1 + + diag_data2d_store%names(diag_data2d_store%total) = data2d_name + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_LONG + + var_index = diag_data2d_store%total + end if + +#ifdef _DEBUG_MEM_ + call nclayer_debug("Current total:") + print *, diag_data2d_store%total +#endif + + ! Get input size and do size checks! + input_size = size(data2d_value) + + if ((diag_data2d_store%def_lock) .AND. & + (size(data2d_value) > diag_data2d_store%max_lens(var_index))) then + call nclayer_error("Cannot expand variable size after locking variable definitions!") + end if + + ! We just need to add one entry... + call nc_diag_data2d_resize_iarr(var_index, 1_i_llong) + call nc_diag_data2d_resize_long(input_size) + + ! Now add the actual entry! + diag_data2d_store%m_long(diag_data2d_store%acount(3) - input_size + 1:diag_data2d_store%acount(3)) = & + data2d_value + diag_data2d_store%stor_i_arr(var_index)%index_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + diag_data2d_store%acount(3) - input_size + 1 + diag_data2d_store%stor_i_arr(var_index)%length_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + input_size + end subroutine nc_diag_data2d_long + + ! nc_diag_data2d - input real(r_single) + ! Corresponding NetCDF4 type: float (or real) + subroutine nc_diag_data2d_rsingle(data2d_name, data2d_value) + character(len=*), intent(in) :: data2d_name + real(r_single), dimension(:), intent(in) :: data2d_value + + integer(i_long) :: var_index + integer(i_llong) :: input_size + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + integer(i_llong) :: data_value_size + + if (nclayer_enable_action) then + data_value_size = size(data2d_value) + write(action_str, "(A, I0, A, F0.5, A, F0.5, A)") & + "nc_diag_data2d_rsingle(data2d_name = " // data2d_name // & + ", data2d_value = array with length of ", & + data_value_size, & + " [", & + data2d_value(1), & + " ... ", & + data2d_value(data_value_size), & + "]" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_data2d_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_data2d_lookup_var(data2d_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_data2d_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if +#ifdef _DEBUG_MEM_ + write (*, "(A, A, A, F)") "NEW data2d: ", data2d_name, " | First value: ", data2d_value +#endif + call nc_diag_data2d_expand + + diag_data2d_store%total = diag_data2d_store%total + 1 + + diag_data2d_store%names(diag_data2d_store%total) = data2d_name + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_FLOAT + + var_index = diag_data2d_store%total + end if + + ! Get input size and do size checks! + input_size = size(data2d_value) + + if ((diag_data2d_store%def_lock) .AND. & + (size(data2d_value) > diag_data2d_store%max_lens(var_index))) then + call nclayer_error("Cannot expand variable size after locking variable definitions!") + end if + + ! We just need to add one entry... + call nc_diag_data2d_resize_iarr(var_index, 1_i_llong) + call nc_diag_data2d_resize_rsingle(input_size) + + ! Now add the actual entry! + diag_data2d_store%m_rsingle(diag_data2d_store%acount(4) - input_size + 1:diag_data2d_store%acount(4)) = & + data2d_value + diag_data2d_store%stor_i_arr(var_index)%index_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + diag_data2d_store%acount(4) - input_size + 1 + diag_data2d_store%stor_i_arr(var_index)%length_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + input_size + end subroutine nc_diag_data2d_rsingle + + ! nc_diag_data2d - input real(r_double) + ! Corresponding NetCDF4 type: double + subroutine nc_diag_data2d_rdouble(data2d_name, data2d_value) + character(len=*), intent(in) :: data2d_name + real(r_double), dimension(:), intent(in) :: data2d_value + + integer(i_long) :: var_index + integer(i_llong) :: input_size + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + integer(i_llong) :: data_value_size + + if (nclayer_enable_action) then + data_value_size = size(data2d_value) + write(action_str, "(A, I0, A, F0.5, A, F0.5, A)") & + "nc_diag_data2d_rdouble(data2d_name = " // data2d_name // & + ", data2d_value = array with length of ", & + data_value_size, & + " [", & + data2d_value(1), & + " ... ", & + data2d_value(data_value_size), & + "]" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_data2d_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_data2d_lookup_var(data2d_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_data2d_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_data2d_expand + + diag_data2d_store%total = diag_data2d_store%total + 1 + + diag_data2d_store%names(diag_data2d_store%total) = data2d_name + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_DOUBLE + + var_index = diag_data2d_store%total + end if + + ! Get input size and do size checks! + input_size = size(data2d_value) + + if ((diag_data2d_store%def_lock) .AND. & + (size(data2d_value) > diag_data2d_store%max_lens(var_index))) then + call nclayer_error("Cannot expand variable size after locking variable definitions!") + end if + + ! We just need to add one entry... + call nc_diag_data2d_resize_iarr(var_index, 1_i_llong) + call nc_diag_data2d_resize_rdouble(input_size) + + ! Now add the actual entry! + diag_data2d_store%m_rdouble(diag_data2d_store%acount(5) - input_size + 1:diag_data2d_store%acount(5)) = & + data2d_value + diag_data2d_store%stor_i_arr(var_index)%index_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + diag_data2d_store%acount(5) - input_size + 1 + diag_data2d_store%stor_i_arr(var_index)%length_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + input_size + end subroutine nc_diag_data2d_rdouble + + ! nc_diag_data2d - input character(len=*) + ! Corresponding NetCDF4 type: string? char? + subroutine nc_diag_data2d_string(data2d_name, data2d_value) + character(len=*), intent(in) :: data2d_name + character(len=*), dimension(:), intent(in) :: data2d_value + + integer(i_long) :: var_index + integer(i_long) :: max_str_len + integer(i_llong) :: input_size + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + integer(i_llong) :: data_value_size + + if (nclayer_enable_action) then + data_value_size = size(data2d_value) + write(action_str, "(A, I0, A, A)") & + "nc_diag_data2d_string(data2d_name = " // data2d_name // & + ", data2d_value = array with length of ", & + data_value_size, & + " [" // & + trim(data2d_value(1)) // & + " ... " // & + trim(data2d_value(data_value_size)) // & + "]" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_data2d_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_data2d_lookup_var(data2d_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_data2d_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_data2d_expand + + diag_data2d_store%total = diag_data2d_store%total + 1 + + diag_data2d_store%names(diag_data2d_store%total) = data2d_name + diag_data2d_store%types(diag_data2d_store%total) = NLAYER_STRING + + var_index = diag_data2d_store%total + else + ! Check max string length +#ifdef _DEBUG_MEM_ + print *, "len_trim(data2d_value) = ", len_trim(data2d_value) + print *, "diag_data2d_store%max_str_lens(var_index) = ", diag_data2d_store%max_str_lens(var_index) +#endif + end if + + ! Get input size and do size checks! + input_size = size(data2d_value) + + if (diag_data2d_store%def_lock) then + if (input_size > diag_data2d_store%max_lens(var_index)) & + call nclayer_error("Cannot expand variable size after locking variable definitions!") + + ! Check max string length + max_str_len = max_len_string_array(data2d_value, & + int(input_size)) + +#ifdef _DEBUG_MEM_ + print *, "max_str_len: ", max_str_len + print *, "diag_data2d_store%max_str_lens(var_index): ", diag_data2d_store%max_str_lens(var_index) +#endif + + if (max_str_len > diag_data2d_store%max_str_lens(var_index)) & + call nclayer_error("Cannot expand variable string length after locking variable definitions!") + end if + + ! We just need to add one entry... + call nc_diag_data2d_resize_iarr(var_index, 1_i_llong) + call nc_diag_data2d_resize_string(input_size) + + ! If trim isn't enabled, set our maximum string length here! + if (.NOT. enable_trim) then + if (diag_data2d_store%max_str_lens(var_index) == -1) then + diag_data2d_store%max_str_lens(var_index) = len(data2d_value(1)) + else + ! Validate that our non-first value isn't different from + ! the initial string length + if (max_len_notrim_string_array(data2d_value, int(input_size)) /= & + diag_data2d_store%max_str_lens(var_index)) & + call nclayer_error("Cannot change string size when trimming is disabled!") + end if + end if + + ! Now add the actual entry! + diag_data2d_store%m_string(diag_data2d_store%acount(6) - input_size + 1:diag_data2d_store%acount(6)) = & + data2d_value + diag_data2d_store%stor_i_arr(var_index)%index_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + diag_data2d_store%acount(6) - input_size + 1 + diag_data2d_store%stor_i_arr(var_index)%length_arr(diag_data2d_store%stor_i_arr(var_index)%icount) = & + input_size + end subroutine nc_diag_data2d_string +end module ncdw_data2d diff --git a/src/ncdiag/ncdw_dresize.F90 b/src/ncdiag/ncdw_dresize.F90 new file mode 100644 index 000000000..fba6fea1c --- /dev/null +++ b/src/ncdiag/ncdw_dresize.F90 @@ -0,0 +1,457 @@ +module ncdw_dresize + use ncd_kinds, only: i_byte, i_short, i_long, i_llong, r_single, & + r_double + use ncdw_state, only: diag_data2d_store + use ncdw_types, only: diag_d2d_iarr, NLAYER_DEFAULT_ENT, & + NLAYER_MULTI_BASE + use ncdw_realloc, only: nc_diag_realloc + use ncdw_climsg, only: & +#ifdef ENABLE_ACTION_MSGS + nclayer_enable_action, nclayer_actionm, & +#endif +#ifdef _DEBUG_MEM_ + nclayer_debug, & +#endif + nclayer_error + + implicit none + + contains + ! For all subroutines: update_acount_in specifies wheter to + ! update acount or not. By default, this is true. This is useful + ! for preallocation, when you aren't actually adding entries, + ! so you're just allocating ahead of time and NOT adding + ! elements, thus not adding to acount. + + ! nc_diag_data2d_resize - input integer(i_byte) + ! Corresponding NetCDF4 type: byte + subroutine nc_diag_data2d_resize_byte(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_BYTE is located at the first index, 1. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 1 + sc_index_vi = sc_index + 6 + + if (allocated(diag_data2d_store%m_byte)) then + if (update_acount) diag_data2d_store%acount(sc_index) = diag_data2d_store%acount(sc_index) + addl_num_entries + if (diag_data2d_store%acount(sc_index) >= diag_data2d_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_data2d_resize_byte: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_data2d_store%m_byte, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_m_multi(sc_index))))) + diag_data2d_store%asize(sc_index) = size(diag_data2d_store%m_byte) + + diag_data2d_store%alloc_m_multi(sc_index) = diag_data2d_store%alloc_m_multi(sc_index) + 1 + end if + else + if (update_acount) diag_data2d_store%acount(sc_index) = addl_num_entries + allocate(diag_data2d_store%m_byte(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_data2d_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_data2d_resize_byte + + ! nc_diag_data2d_resize - input integer(i_short) + ! Corresponding NetCDF4 type: short + subroutine nc_diag_data2d_resize_short(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_SHORT is located at the second index, 2. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 2 + sc_index_vi = sc_index + 6 + + if (allocated(diag_data2d_store%m_short)) then + if (update_acount) diag_data2d_store%acount(sc_index) = diag_data2d_store%acount(sc_index) + addl_num_entries + if (diag_data2d_store%acount(sc_index) >= diag_data2d_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_data2d_resize_short: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_data2d_store%m_short, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_m_multi(sc_index))))) + diag_data2d_store%asize(sc_index) = size(diag_data2d_store%m_short) + + diag_data2d_store%alloc_m_multi(sc_index) = diag_data2d_store%alloc_m_multi(sc_index) + 1 + end if + else +#ifdef _DEBUG_MEM_ + print *, "nc_diag_data2d_resize_short: allocate NEW m_short" +#endif + if (update_acount) diag_data2d_store%acount(sc_index) = addl_num_entries + allocate(diag_data2d_store%m_short(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_data2d_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_data2d_resize_short + + ! nc_diag_data2d_resize - input integer(i_long) + ! Corresponding NetCDF4 type: int (old: long) + subroutine nc_diag_data2d_resize_long(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! Did we realloc at all? + !logical :: data2d_realloc + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + +#ifdef _DEBUG_MEM_ + character(len=200) :: debugstr +#endif + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_LONG is located at the third index, 3. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 3 + sc_index_vi = sc_index + 6 + + if (allocated(diag_data2d_store%m_long)) then + if (update_acount) diag_data2d_store%acount(sc_index) = diag_data2d_store%acount(sc_index) + addl_num_entries + +#ifdef _DEBUG_MEM_ + write (debugstr, "(A, I1, A, I7, A, I7)") "In sc_index ", sc_index, ", the acount/asize is: ", diag_data2d_store%acount(sc_index), "/", diag_data2d_store%asize(sc_index) + call nclayer_debug(debugstr) +#endif + + if (diag_data2d_store%acount(sc_index) >= diag_data2d_store%asize(sc_index)) then +#ifdef _DEBUG_MEM_ + call nclayer_debug("acount < asize, reallocating.") + print *, "Start long realloc..." +#endif +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_data2d_resize_long: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_data2d_store%m_long, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_m_multi(sc_index))))) + diag_data2d_store%asize(sc_index) = size(diag_data2d_store%m_long) + + diag_data2d_store%alloc_m_multi(sc_index) = diag_data2d_store%alloc_m_multi(sc_index) + 1 + +#ifdef _DEBUG_MEM_ + print *, "alloc_m_multi increased to:" + print *, diag_data2d_store%alloc_m_multi(sc_index) +#endif + end if + else +#ifdef _DEBUG_MEM_ + print *, "nc_diag_data2d_resize_long: allocate NEW m_long" +#endif + if (update_acount) diag_data2d_store%acount(sc_index) = addl_num_entries + allocate(diag_data2d_store%m_long(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_data2d_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_data2d_resize_long + + ! nc_diag_data2d_resize - input real(r_single) + ! Corresponding NetCDF4 type: float (or real) + subroutine nc_diag_data2d_resize_rsingle(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_FLOAT is located at the fourth index, 4. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 4 + sc_index_vi = sc_index + 6 + + if (allocated(diag_data2d_store%m_rsingle)) then + if (update_acount) diag_data2d_store%acount(sc_index) = diag_data2d_store%acount(sc_index) + addl_num_entries + if (diag_data2d_store%acount(sc_index) >= diag_data2d_store%asize(sc_index)) then +#ifdef _DEBUG_MEM_ + print *, "realloc needed for data2d rsingle!" + write (*, "(A, I0, A, I0, A)") "(size needed / size available: ", diag_data2d_store%acount(sc_index), " / ", diag_data2d_store%asize(sc_index), ")" +#endif +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_data2d_resize_rsingle: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_data2d_store%m_rsingle, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_m_multi(sc_index))))) + diag_data2d_store%asize(sc_index) = size(diag_data2d_store%m_rsingle) + + diag_data2d_store%alloc_m_multi(sc_index) = diag_data2d_store%alloc_m_multi(sc_index) + 1 + end if + else + if (update_acount) diag_data2d_store%acount(sc_index) = addl_num_entries + allocate(diag_data2d_store%m_rsingle(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_data2d_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_data2d_resize_rsingle + + ! nc_diag_data2d_resize - input real(r_double) + ! Corresponding NetCDF4 type: double + subroutine nc_diag_data2d_resize_rdouble(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_DOUBLE is located at the fifth index, 5. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 5 + sc_index_vi = sc_index + 6 + + if (allocated(diag_data2d_store%m_rdouble)) then + if (update_acount) diag_data2d_store%acount(sc_index) = diag_data2d_store%acount(sc_index) + addl_num_entries + if (diag_data2d_store%acount(sc_index) >= diag_data2d_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_data2d_resize_rdouble: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_data2d_store%m_rdouble, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_m_multi(sc_index))))) + diag_data2d_store%asize(sc_index) = size(diag_data2d_store%m_rdouble) + + diag_data2d_store%alloc_m_multi(sc_index) = diag_data2d_store%alloc_m_multi(sc_index) + 1 + end if + else + if (update_acount) diag_data2d_store%acount(sc_index) = addl_num_entries + allocate(diag_data2d_store%m_rdouble(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_data2d_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_data2d_resize_rdouble + + ! nc_diag_data2d_resize - input character(len=*) + ! Corresponding NetCDF4 type: string? char? + subroutine nc_diag_data2d_resize_string(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_BYTE is located at the sixth index, 6. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 6 + sc_index_vi = sc_index + 6 + + if (allocated(diag_data2d_store%m_string)) then + if (update_acount) diag_data2d_store%acount(sc_index) = diag_data2d_store%acount(sc_index) + addl_num_entries + if (diag_data2d_store%acount(sc_index) >= diag_data2d_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_data2d_resize_string: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_data2d_store%m_string, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_data2d_store%alloc_m_multi(sc_index))))) + diag_data2d_store%asize(sc_index) = size(diag_data2d_store%m_string) + + diag_data2d_store%alloc_m_multi(sc_index) = diag_data2d_store%alloc_m_multi(sc_index) + 1 + end if + else + if (update_acount) diag_data2d_store%acount(sc_index) = addl_num_entries + allocate(diag_data2d_store%m_string(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_data2d_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_data2d_resize_string + + subroutine nc_diag_data2d_resize_iarr_type(addl_num_entries) + integer(i_llong), intent(in) :: addl_num_entries + + type(diag_d2d_iarr), dimension(:), allocatable :: tmp_stor_i_arr + +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_data2d_resize_iarr_type: doing reallocation!") + end if +#endif + + ! We need to realloc ourselves here... + allocate(tmp_stor_i_arr(size(diag_data2d_store%stor_i_arr) + addl_num_entries)) + tmp_stor_i_arr(1:size(diag_data2d_store%stor_i_arr)) = diag_data2d_store%stor_i_arr + deallocate(diag_data2d_store%stor_i_arr) + allocate(diag_data2d_store%stor_i_arr(size(tmp_stor_i_arr))) + diag_data2d_store%stor_i_arr = tmp_stor_i_arr + deallocate(tmp_stor_i_arr) + end subroutine nc_diag_data2d_resize_iarr_type + + subroutine nc_diag_data2d_resize_iarr(iarr_index, addl_num_entries, update_icount_in) + integer(i_long), intent(in) :: iarr_index + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_icount_in + + logical :: update_icount + + integer(i_llong) :: addl_num_entries_r + + ! Assume true by default + if (.NOT. present(update_icount_in)) then + update_icount = .TRUE. + else + update_icount = update_icount_in + end if + + if (allocated(diag_data2d_store%stor_i_arr(iarr_index)%index_arr)) then + if (update_icount) diag_data2d_store%stor_i_arr(iarr_index)%icount = & + diag_data2d_store%stor_i_arr(iarr_index)%icount + addl_num_entries + if (diag_data2d_store%stor_i_arr(iarr_index)%icount >= diag_data2d_store%stor_i_arr(iarr_index)%isize) then +#ifdef _DEBUG_MEM_ + print *, "realloc needed for data2d iarr!" + write (*, "(A, I0, A, I0, A)") "(size needed / size available: ", diag_data2d_store%stor_i_arr(iarr_index)%icount, " / ", diag_data2d_store%stor_i_arr(iarr_index)%isize, ")" + print *, diag_data2d_store%alloc_sia_multi(iarr_index) + print *, int8(NLAYER_MULTI_BASE ** int8(diag_data2d_store%alloc_sia_multi(iarr_index))) +#endif +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_data2d_resize_iarr: doing reallocation!") + end if +#endif + + if (update_icount) then + addl_num_entries_r = addl_num_entries + (int8(NLAYER_DEFAULT_ENT) * (NLAYER_MULTI_BASE ** int8(diag_data2d_store%alloc_sia_multi(iarr_index)))) + else + addl_num_entries_r = addl_num_entries + NLAYER_DEFAULT_ENT + end if +#ifdef _DEBUG_MEM_ + print *, " ** addl_num_entries_r = " + print *, addl_num_entries_r +#endif + call nc_diag_realloc(diag_data2d_store%stor_i_arr(iarr_index)%index_arr, addl_num_entries_r) + call nc_diag_realloc(diag_data2d_store%stor_i_arr(iarr_index)%length_arr, addl_num_entries_r) +#ifdef _DEBUG_MEM_ + print *, " ** realloc done" +#endif + diag_data2d_store%stor_i_arr(iarr_index)%isize = size(diag_data2d_store%stor_i_arr(iarr_index)%index_arr) + + if (update_icount) diag_data2d_store%alloc_sia_multi(iarr_index) = diag_data2d_store%alloc_sia_multi(iarr_index) + 1 + end if + else + if (update_icount) diag_data2d_store%stor_i_arr(iarr_index)%icount = addl_num_entries + allocate(diag_data2d_store%stor_i_arr(iarr_index)%index_arr(addl_num_entries + NLAYER_DEFAULT_ENT)) + allocate(diag_data2d_store%stor_i_arr(iarr_index)%length_arr(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_data2d_store%stor_i_arr(iarr_index)%isize = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_data2d_resize_iarr +end module ncdw_dresize diff --git a/src/ncdiag/ncdw_lheader.F90 b/src/ncdiag/ncdw_lheader.F90 new file mode 100644 index 000000000..210b84e12 --- /dev/null +++ b/src/ncdiag/ncdw_lheader.F90 @@ -0,0 +1,144 @@ +module ncdw_lheader + use ncd_kinds, only: i_byte, i_short, i_long, r_single, r_double + use ncdw_state, only: ncid, init_done + use ncdw_climsg, only: nclayer_error, nclayer_check + use netcdf, only: nf90_put_att, NF90_GLOBAL + + implicit none + + interface nc_diag_header + module procedure nc_diag_header_byte, & + nc_diag_header_short, nc_diag_header_long, & + nc_diag_header_rsingle, nc_diag_header_rdouble, & + nc_diag_header_string, nc_diag_header_byte_v, & + nc_diag_header_short_v, nc_diag_header_long_v, & + nc_diag_header_rsingle_v, nc_diag_header_rdouble_v + end interface nc_diag_header + + contains + ! nc_diag_header - input integer(i_byte) + ! Corresponding NetCDF4 type: byte + subroutine nc_diag_header_byte(header_name, header_value) + character(len=*), intent(in) :: header_name + integer(i_byte), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_byte + + ! nc_diag_header - input integer(i_short) + ! Corresponding NetCDF4 type: short + subroutine nc_diag_header_short(header_name, header_value) + character(len=*), intent(in) :: header_name + integer(i_short), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_short + + ! nc_diag_header - input integer(i_long) + ! Corresponding NetCDF4 type: int (old: long) + subroutine nc_diag_header_long(header_name, header_value) + character(len=*), intent(in) :: header_name + integer(i_long), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_long + + ! nc_diag_header - input real(r_single) + ! Corresponding NetCDF4 type: float (or real) + subroutine nc_diag_header_rsingle(header_name, header_value) + character(len=*), intent(in) :: header_name + real(r_single), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_rsingle + + ! nc_diag_header - input real(r_double) + ! Corresponding NetCDF4 type: double + subroutine nc_diag_header_rdouble(header_name, header_value) + character(len=*), intent(in) :: header_name + real(r_double), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_rdouble + + ! nc_diag_header - input character(len=*) + ! Corresponding NetCDF4 type: string? char? + subroutine nc_diag_header_string(header_name, header_value) + character(len=*), intent(in) :: header_name + character(len=*), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + ! Note: using F95 trim here! + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, trim(header_value))) + end subroutine nc_diag_header_string + + !============================================================= + ! VECTOR TYPES + !============================================================= + + ! nc_diag_header - input integer(i_byte), dimension(:) + ! Corresponding NetCDF4 type: byte + subroutine nc_diag_header_byte_v(header_name, header_value) + character(len=*), intent(in) :: header_name + integer(i_byte), dimension(:), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_byte_v + + ! nc_diag_header - input integer(i_short) + ! Corresponding NetCDF4 type: short + subroutine nc_diag_header_short_v(header_name, header_value) + character(len=*), intent(in) :: header_name + integer(i_short), dimension(:), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_short_v + + ! nc_diag_header - input integer(i_long) + ! Corresponding NetCDF4 type: int (old: long) + subroutine nc_diag_header_long_v(header_name, header_value) + character(len=*), intent(in) :: header_name + integer(i_long), dimension(:), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_long_v + + ! nc_diag_header - input real(r_single) + ! Corresponding NetCDF4 type: float (or real) + subroutine nc_diag_header_rsingle_v(header_name, header_value) + character(len=*), intent(in) :: header_name + real(r_single), dimension(:), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_rsingle_v + + ! nc_diag_header - input real(r_double) + ! Corresponding NetCDF4 type: double + subroutine nc_diag_header_rdouble_v(header_name, header_value) + character(len=*), intent(in) :: header_name + real(r_double), dimension(:), intent(in) :: header_value + + if (.NOT. init_done) & + call nclayer_error("Can't write definitions - NetCDF4 layer not initialized yet!") + call nclayer_check(nf90_put_att(ncid, NF90_GLOBAL, header_name, header_value)) + end subroutine nc_diag_header_rdouble_v +end module ncdw_lheader diff --git a/src/ncdiag/ncdw_metadata.F90 b/src/ncdiag/ncdw_metadata.F90 new file mode 100644 index 000000000..c04833293 --- /dev/null +++ b/src/ncdiag/ncdw_metadata.F90 @@ -0,0 +1,1266 @@ +! nc_diag_write - NetCDF Layer Diag Writing Module +! Copyright 2015 Albert Huang - SSAI/NASA for NASA GSFC GMAO (610.1). +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or +! implied. See the License for the specific language governing +! permissions and limitations under the License. +! +! metadata module - ncdw_metadata +! +module ncdw_metadata + ! Module that provides metadata variable storage support. + ! + ! This module has all of the subroutines needed to store metadata + ! data. It includes the metadata storing subroutine + ! (nc_diag_chaninfo), subroutines for controlling chaninfo data + ! (loading definitions, saving definitions, saving data, etc.), + ! and preallocation subroutines. + ! + ! Background: + ! metadata is an unlimited storage variable, with dimensions of + ! 1 x nobs, where nobs is an unlimited dimension. With unlimited + ! dimensions in this variable type, an unlimited amount of + ! metadata data can be stored in metadata variables. + ! + ! Unlike chaninfo, we can NOT make any assumptions, since the + ! dimensions are now unlimited instead of fixed. This time, the + ! variables will have to be stored differently! + ! + ! At the time of development, there were two ideas of approaching + ! this new type: + ! + ! -> Same variable metadata storage, but now storing data inside + ! a derived type array instead of in a giant variable data + ! storage. The derived type array is now filled with the + ! various type arrays. Only one type array is allocated and + ! filled so that the array itself has the complete data, and + ! the array can be written out directly to NetCDF. + ! + ! -> Same variable metadata storage, same variable data storage, + ! but with an addition of a derived type containing an array + ! of indicies referring to the location where the variable's + ! data is stored. + ! + ! In the end, the array of indicies option was chosen. This was + ! due to these reasons: + ! + ! -> Although writing the data would be rather quick (since the + ! data is already in a vector), several factors would make + ! the costs outweight this benefit. In particular... + ! + ! -> Writing to the array would require more time, since it has + ! to seek to the allocatable array, then seek to the position, + ! and then write. This is due to the many other non-allocated + ! types in the derived type. + ! + ! -> Reallocation would occur more often, since the arrays are + ! allocated by variable, and not allocated by type. Instead of + ! reallocating 6 times, it would reallocate (# of variables) + ! times, assuming all variables are appended to equally. + ! + ! -> More counters (specifically, (# of variables) amount of + ! counters) will have to be used to keep track of the total + ! and the amount of data used for the allocatable arrays, + ! making reallocation even more costly. + ! + ! -> With regards to the indicies option, appending and writing + ! times are equal. They essentially boil down to store index, + ! store value vs read index, read value. + ! + ! -> The indicies array is stored in a derived type, but since + ! it is the sole element within the derived type, the array + ! access is much quicker. + ! + ! -> Finally, the indicies array still uses the 6 type variable + ! data array storage, which just uses 6*2 counters and only + ! a maximum of 6 reallocations, which is much more efficient. + ! + ! That said, we can therefore apply this method to our metadata + ! data storage! + ! + ! Like with chaninfo, we support the following types: + ! i_byte, i_short, i_long, r_single, r_double, character(len=*) + ! + ! Again, we store everything within a derived type, diag_metadata: + ! + ! -> m_* - these arrays store the variable data for the types + ! listed above. This time, we organize the metadata using + ! array indicies for each variable, as mentionned above. More + ! details about the storage method to follow... + ! + ! -> names - all of the metadata variable names! We'll be using + ! this array to store and lookup metadata variables, as well as + ! storing them! + ! + ! -> types - all of the metadata variable types! These are byte + ! integers that get compared to our NLAYER_* type constants + ! (see: ncdw_types.F90). + ! + ! + ! + ! -> stor_i_arr - for metadata, this is the star of the show! This + ! is an abbreviation for "storage index array". This is the + ! implementation of our indicies array idea. Since this is a + ! array of "diag_md_iarr" derived types, let's peek at the + ! derived type itself: + ! + ! -> index_arr - the array of indicies. This stores all of the + ! variable data storage indicies, which indicate where our + ! data is stored within the variable type-specific data + ! storage. + ! + ! -> icount - the number of indicies stored within this derived + ! type. + ! + ! -> isize - the current indicies array size. Used for + ! reallocation when adding more elements. + ! + + use ncd_kinds, only: i_byte, i_short, i_long, i_llong, r_single, & + r_double + use ncdw_state, only: init_done, ncid, append_only, & + enable_trim, & + diag_metadata_store, diag_varattr_store + use ncdw_types, only: NLAYER_BYTE, NLAYER_SHORT, NLAYER_LONG, & + NLAYER_FLOAT, NLAYER_DOUBLE, NLAYER_STRING, & + NLAYER_DEFAULT_ENT, NLAYER_MULTI_BASE, NLAYER_CHUNKING, & + NLAYER_COMPRESSION + use ncdw_strarrutils, only: max_len_string_array + + use ncdw_realloc, only: nc_diag_realloc + use ncdw_mresize, only: & + nc_diag_metadata_resize_byte, nc_diag_metadata_resize_short, & + nc_diag_metadata_resize_long, nc_diag_metadata_resize_rsingle, & + nc_diag_metadata_resize_rdouble, & + nc_diag_metadata_resize_string, & + nc_diag_metadata_resize_iarr, nc_diag_metadata_resize_iarr_type + + use ncdw_varattr, only: nc_diag_varattr_make_nobs_dim, & + nc_diag_varattr_add_var + + use ncdw_climsg, only: & +#ifdef ENABLE_ACTION_MSGS + nclayer_enable_action, nclayer_actionm, & +#endif +#ifdef _DEBUG_MEM_ + nclayer_debug, & +#endif + nclayer_error, nclayer_warning, nclayer_info, nclayer_check + + use netcdf, only: nf90_inquire, nf90_inquire_variable, & + nf90_inquire_dimension, nf90_def_dim, nf90_def_var, & + nf90_put_var, nf90_def_var_chunking, nf90_def_var_deflate, & + NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE, & + NF90_CHAR, NF90_MAX_NAME, NF90_CHUNKED + + implicit none + + interface nc_diag_metadata + module procedure nc_diag_metadata_byte, & + nc_diag_metadata_short, nc_diag_metadata_long, & + nc_diag_metadata_rsingle, nc_diag_metadata_rdouble, & + nc_diag_metadata_string + end interface nc_diag_metadata + + contains + subroutine nc_diag_metadata_allocmulti(multiplier) + integer(i_long), intent(in) :: multiplier + if (init_done) then + ! # of times we needed to realloc simple metadata + ! also the multiplier factor for allocation (2^x) + diag_metadata_store%alloc_s_multi = multiplier + + ! # of times we needed to realloc metadata data storage + ! also the multiplier factor for allocation (2^x) + diag_metadata_store%alloc_m_multi = multiplier + + ! # of times we needed to realloc metadata INDEX data storage + ! also the multiplier factor for allocation (2^x) + diag_metadata_store%alloc_mi_multi = multiplier + end if + end subroutine nc_diag_metadata_allocmulti + + subroutine nc_diag_metadata_load_def + integer(i_long) :: ndims, nvars, var_index, type_index + integer(i_long) :: rel_index, i, nobs_size + + character(len=NF90_MAX_NAME) :: tmp_var_name + integer(i_long) :: tmp_var_type, tmp_var_ndims + + integer(i_long), dimension(:), allocatable :: tmp_var_dimids, tmp_var_dim_sizes + character(len=NF90_MAX_NAME) , allocatable :: tmp_var_dim_names(:) + + logical :: is_metadata_var + + ! Get top level info about the file! + call nclayer_check(nf90_inquire(ncid, nDimensions = ndims, & + nVariables = nvars)) + + ! Now search for variables that use metadata storage! + ! Loop through each variable! + do var_index = 1, nvars + ! Grab number of dimensions and attributes first + call nclayer_check(nf90_inquire_variable(ncid, var_index, name = tmp_var_name, ndims = tmp_var_ndims)) + + ! Allocate temporary variable dimids storage! + allocate(tmp_var_dimids(tmp_var_ndims)) + allocate(tmp_var_dim_names(tmp_var_ndims)) + allocate(tmp_var_dim_sizes(tmp_var_ndims)) + + ! Grab the actual dimension IDs and attributes + + call nclayer_check(nf90_inquire_variable(ncid, var_index, dimids = tmp_var_dimids, & + xtype = tmp_var_type)) + + if ((tmp_var_ndims == 1) .OR. & + ((tmp_var_ndims == 2) .AND. (tmp_var_type == NF90_CHAR))) then + is_metadata_var = .FALSE. + + do i = 1, tmp_var_ndims + call nclayer_check(nf90_inquire_dimension(ncid, tmp_var_dimids(i), tmp_var_dim_names(i), & + tmp_var_dim_sizes(i))) + + if (tmp_var_dim_names(i) == "nobs") then + nobs_size = tmp_var_dim_sizes(i) + if (tmp_var_type /= NF90_CHAR) then + is_metadata_var = .TRUE. + else if (tmp_var_type == NF90_CHAR) then + if (index(tmp_var_dim_names(1), "_maxstrlen") /= 0) & + is_metadata_var = .TRUE. + end if + end if + end do + + if (is_metadata_var) then + ! Expand things first! + call nc_diag_metadata_expand + + ! Add to the total! + diag_metadata_store%total = diag_metadata_store%total + 1 + + ! Store name and type! + diag_metadata_store%names(diag_metadata_store%total) = trim(tmp_var_name) + + ! The relative index is the total nobs + rel_index = nobs_size + + if (tmp_var_type == NF90_BYTE) then + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_BYTE + !call nc_diag_metadata_resize_byte(int8(diag_metadata_store%nchans), .FALSE.) + type_index = 1 + else if (tmp_var_type == NF90_SHORT) then + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_SHORT + !call nc_diag_metadata_resize_short(int8(diag_metadata_store%nchans), .FALSE.) + type_index = 2 + else if (tmp_var_type == NF90_INT) then + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_LONG + !call nc_diag_metadata_resize_long(int8(diag_metadata_store%nchans), .FALSE.) + type_index = 3 + else if (tmp_var_type == NF90_FLOAT) then + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_FLOAT + !call nc_diag_metadata_resize_rsingle(int8(diag_metadata_store%nchans), .FALSE.) + type_index = 4 + else if (tmp_var_type == NF90_DOUBLE) then + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_DOUBLE + !call nc_diag_metadata_resize_rdouble(int8(diag_metadata_store%nchans), .FALSE.) + type_index = 5 + else if (tmp_var_type == NF90_CHAR) then + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_STRING + diag_metadata_store%max_str_lens(diag_metadata_store%total) = tmp_var_dim_sizes(1) + !call nc_diag_metadata_resize_string(int8(diag_metadata_store%nchans), .FALSE.) + type_index = 6 + else + call nclayer_error("NetCDF4 type invalid!") + end if + +! print *, trim(tmp_var_name), "rel index", rel_index + + ! Now add a relative position... based on the next position! + + ! Set relative index! + diag_metadata_store%rel_indexes(diag_metadata_store%total) = rel_index + + ! Set variable ID! Note that var_index here is the actual variable ID. + diag_metadata_store%var_ids(diag_metadata_store%total) = var_index + +! print *, var_index +! print *, diag_metadata_store%var_ids(diag_metadata_store%total) + end if + end if + + ! Deallocate + deallocate(tmp_var_dimids) + deallocate(tmp_var_dim_names) + deallocate(tmp_var_dim_sizes) + end do + + diag_metadata_store%def_lock = .TRUE. + end subroutine nc_diag_metadata_load_def + + subroutine nc_diag_metadata_write_def(internal) + logical, intent(in), optional :: internal + + integer(i_byte) :: data_type + character(len=100) :: data_name + + integer(i_llong) :: curdatindex, j + integer(i_long) :: nc_data_type + integer(i_long) :: tmp_dim_id + character(len=120) :: data_dim_name + + character(len=:), allocatable :: string_arr(:) + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + if (present(internal)) then + write(action_str, "(A, L, A)") "nc_diag_metadata_write_def(internal = ", internal, ")" + else + write(action_str, "(A)") "nc_diag_metadata_write_def(internal = (not specified))" + end if + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (init_done) then + if (.NOT. diag_metadata_store%def_lock) then + ! Use global nobs ID! + ! Call subroutine to ensure the nobs dim is created already... + call nc_diag_varattr_make_nobs_dim + + do curdatindex = 1, diag_metadata_store%total + data_name = diag_metadata_store%names(curdatindex) + data_type = diag_metadata_store%types(curdatindex) + + call nclayer_info("metadata: defining " // trim(data_name)) + + if (data_type == NLAYER_BYTE) nc_data_type = NF90_BYTE + if (data_type == NLAYER_SHORT) nc_data_type = NF90_SHORT + if (data_type == NLAYER_LONG) nc_data_type = NF90_INT + if (data_type == NLAYER_FLOAT) nc_data_type = NF90_FLOAT + if (data_type == NLAYER_DOUBLE) nc_data_type = NF90_DOUBLE + if (data_type == NLAYER_STRING) nc_data_type = NF90_CHAR + +#ifdef _DEBUG_MEM_ + print *, "metadata part 1" +#endif + + if (data_type == NLAYER_STRING) then + write (data_dim_name, "(A, A)") trim(data_name), "_maxstrlen" + + ! If trimming is enabled, we haven't found our max_str_len yet. + ! Go find it! + if (enable_trim) then + ! Dimension is # of chars by # of obs (unlimited) + allocate(character(10000) :: string_arr(diag_metadata_store%stor_i_arr(curdatindex)%icount)) + do j = 1, diag_metadata_store%stor_i_arr(curdatindex)%icount + string_arr(j) = diag_metadata_store%m_string(diag_metadata_store%stor_i_arr(curdatindex)%index_arr(j)) + end do + + ! Save the max string len + diag_metadata_store%max_str_lens(curdatindex) = max_len_string_array(string_arr, & + diag_metadata_store%stor_i_arr(curdatindex)%icount) + + deallocate(string_arr) + end if + + if (.NOT. append_only) & + call nclayer_check(nf90_def_dim(ncid, data_dim_name, & + diag_metadata_store%max_str_lens(curdatindex), tmp_dim_id)) + +#ifdef _DEBUG_MEM_ + print *, "Defining char var type..." +#endif + + if (.NOT. append_only) & + call nclayer_check(nf90_def_var(ncid, data_name, nc_data_type, & + (/ tmp_dim_id, diag_varattr_store%nobs_dim_id /), & + diag_metadata_store%var_ids(curdatindex))) + +#ifdef _DEBUG_MEM_ + print *, "Done defining char var type..." +#endif + else + if (.NOT. append_only) & + call nclayer_check(nf90_def_var(ncid, data_name, nc_data_type, diag_varattr_store%nobs_dim_id, & + diag_metadata_store%var_ids(curdatindex))) + end if + +#ifdef _DEBUG_MEM_ + print *, "metadata part 2" +#endif + + call nc_diag_varattr_add_var(diag_metadata_store%names(curdatindex), & + diag_metadata_store%types(curdatindex), & + diag_metadata_store%var_ids(curdatindex)) + + ! Enable compression + ! Args: ncid, varid, enable_shuffle (yes), enable_deflate (yes), deflate_level +#ifdef _DEBUG_MEM_ + print *, "Defining compression 1 (chunking)..." +#endif + + if (.NOT. append_only) then + if (data_type == NLAYER_STRING) then + call nclayer_check(nf90_def_var_chunking(ncid, diag_metadata_store%var_ids(curdatindex), & + NF90_CHUNKED, (/ diag_metadata_store%max_str_lens(curdatindex), NLAYER_CHUNKING /))) + else + call nclayer_check(nf90_def_var_chunking(ncid, diag_metadata_store%var_ids(curdatindex), & + NF90_CHUNKED, (/ NLAYER_CHUNKING /))) + end if + +#ifdef _DEBUG_MEM_ + print *, "Defining compression 2 (gzip)..." +#endif + call nclayer_check(nf90_def_var_deflate(ncid, diag_metadata_store%var_ids(curdatindex), & + 1, 1, int(NLAYER_COMPRESSION))) + +#ifdef _DEBUG_MEM_ + print *, "Done defining compression..." +#endif + end if + + ! Lock the definitions! + diag_metadata_store%def_lock = .TRUE. + end do + else + if(.NOT. present(internal)) & + call nclayer_error("Can't write definitions - definitions have already been written and locked!") + end if + end if + end subroutine nc_diag_metadata_write_def + + subroutine nc_diag_metadata_write_data(flush_data_only) + ! Optional internal flag to only flush data - if this is + ! true, data flushing will be performed, and the data will + ! NOT be locked. + logical, intent(in), optional :: flush_data_only + + integer(i_byte) :: data_type + character(len=100) :: data_name + + integer(i_long) :: curdatindex, j + + integer(i_byte), dimension(:), allocatable :: byte_arr + integer(i_short),dimension(:), allocatable :: short_arr + integer(i_long), dimension(:), allocatable :: long_arr + real(r_single), dimension(:), allocatable :: rsingle_arr + real(r_double), dimension(:), allocatable :: rdouble_arr + character(len=:), allocatable :: string_arr(:) + + integer(i_llong) :: string_arr_maxlen + + integer(i_llong) :: data_length_counter + character(len=100) :: counter_data_name + integer(i_llong) :: current_length_count + character(len=1000) :: data_uneven_msg + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + if (present(flush_data_only)) then + write(action_str, "(A, L, A)") "nc_diag_metadata_write_data(flush_data_only = ", flush_data_only, ")" + else + write(action_str, "(A)") "nc_diag_metadata_write_data(flush_data_only = (not specified))" + end if + call nclayer_actionm(trim(action_str)) + end if +#endif + ! Initialization MUST occur here, not in decl... + ! Otherwise, it'll initialize once, and never again... + ! + ! This will cause scary issues in the future, where closing + ! and opening a new file shows strange errors about a file + ! opened in the past... + data_length_counter = -1 + current_length_count = -1 + + if (init_done .AND. allocated(diag_metadata_store)) then + if (.NOT. diag_metadata_store%data_lock) then + do curdatindex = 1, diag_metadata_store%total +#ifdef _DEBUG_MEM_ + print *, curdatindex +#endif + data_name = diag_metadata_store%names(curdatindex) + data_type = diag_metadata_store%types(curdatindex) + + call nclayer_info("metadata: writing " // trim(data_name)) + + ! Warn about data inconsistencies + if (.NOT. (present(flush_data_only) .AND. flush_data_only)) then + current_length_count = diag_metadata_store%stor_i_arr(curdatindex)%icount + & + diag_metadata_store%rel_indexes(curdatindex) + + if (data_length_counter == -1) then + data_length_counter = current_length_count + counter_data_name = data_name + else + if (data_length_counter /= current_length_count) then + ! Show message! + ! NOTE - I0 and TRIM are Fortran 95 specs + write (data_uneven_msg, "(A, I0, A, I0, A)") "Amount of data written in " // & + trim(data_name) // " (", & + current_length_count, & + ")" // char(10) // & + " differs from variable " // trim(counter_data_name) // & + " (", data_length_counter, ")!" + + if (diag_metadata_store%strict_check) then + call nclayer_error(trim(data_uneven_msg)) + else + call nclayer_warning(trim(data_uneven_msg)) + end if + end if + end if + end if + + ! Make sure we have data to write in the first place! + if (diag_metadata_store%stor_i_arr(curdatindex)%icount > 0) then + if (data_type == NLAYER_BYTE) then + allocate(byte_arr(diag_metadata_store%stor_i_arr(curdatindex)%icount)) + do j = 1, diag_metadata_store%stor_i_arr(curdatindex)%icount + byte_arr(j) = diag_metadata_store%m_byte(diag_metadata_store%stor_i_arr(curdatindex)%index_arr(j)) + end do + call nclayer_check(nf90_put_var(& + ncid, diag_metadata_store%var_ids(curdatindex), & + byte_arr, & + (/ 1 + diag_metadata_store%rel_indexes(curdatindex) /) & + )) + + deallocate(byte_arr) + else if (data_type == NLAYER_SHORT) then + allocate(short_arr(diag_metadata_store%stor_i_arr(curdatindex)%icount)) + do j = 1, diag_metadata_store%stor_i_arr(curdatindex)%icount + short_arr(j) = diag_metadata_store%m_short(diag_metadata_store%stor_i_arr(curdatindex)%index_arr(j)) + end do + call nclayer_check(nf90_put_var(& + ncid, diag_metadata_store%var_ids(curdatindex), & + short_arr, & + (/ 1 + diag_metadata_store%rel_indexes(curdatindex) /) & + )) + + deallocate(short_arr) + else if (data_type == NLAYER_LONG) then + allocate(long_arr(diag_metadata_store%stor_i_arr(curdatindex)%icount)) + do j = 1, diag_metadata_store%stor_i_arr(curdatindex)%icount + long_arr(j) = diag_metadata_store%m_long(diag_metadata_store%stor_i_arr(curdatindex)%index_arr(j)) + end do + + call nclayer_check(nf90_put_var(& + ncid, diag_metadata_store%var_ids(curdatindex), & + long_arr, & + (/ 1 + diag_metadata_store%rel_indexes(curdatindex) /) & + )) + + deallocate(long_arr) + else if (data_type == NLAYER_FLOAT) then + allocate(rsingle_arr(diag_metadata_store%stor_i_arr(curdatindex)%icount)) + do j = 1, diag_metadata_store%stor_i_arr(curdatindex)%icount + rsingle_arr(j) = diag_metadata_store%m_rsingle(diag_metadata_store%stor_i_arr(curdatindex)%index_arr(j)) + end do + + call nclayer_check(nf90_put_var(& + ncid, diag_metadata_store%var_ids(curdatindex), & + rsingle_arr, & + (/ 1 + diag_metadata_store%rel_indexes(curdatindex) /) & + )) + + deallocate(rsingle_arr) + else if (data_type == NLAYER_DOUBLE) then + allocate(rdouble_arr(diag_metadata_store%stor_i_arr(curdatindex)%icount)) + do j = 1, diag_metadata_store%stor_i_arr(curdatindex)%icount + rdouble_arr(j) = diag_metadata_store%m_rdouble(diag_metadata_store%stor_i_arr(curdatindex)%index_arr(j)) + end do + + call nclayer_check(nf90_put_var(& + ncid, diag_metadata_store%var_ids(curdatindex), & + rdouble_arr, & + (/ 1 + diag_metadata_store%rel_indexes(curdatindex) /) & + )) + deallocate(rdouble_arr) + else if (data_type == NLAYER_STRING) then + ! Only get maximum if we haven't already done that in the define step! + if (diag_metadata_store%max_str_lens(curdatindex) == -1) then + allocate(character(10000) :: string_arr(diag_metadata_store%stor_i_arr(curdatindex)%icount)) + do j = 1, diag_metadata_store%stor_i_arr(curdatindex)%icount + string_arr(j) = diag_metadata_store%m_string(diag_metadata_store%stor_i_arr(curdatindex)%index_arr(j)) + end do + + string_arr_maxlen = max_len_string_array(string_arr, & + diag_metadata_store%stor_i_arr(curdatindex)%icount) + + deallocate(string_arr) + else + string_arr_maxlen = diag_metadata_store%max_str_lens(curdatindex) + end if + + allocate(character(string_arr_maxlen) :: string_arr(diag_metadata_store%stor_i_arr(curdatindex)%icount)) + do j = 1, diag_metadata_store%stor_i_arr(curdatindex)%icount + string_arr(j) = diag_metadata_store%m_string(diag_metadata_store%stor_i_arr(curdatindex)%index_arr(j)) + end do + + call nclayer_check(nf90_put_var(& + ncid, diag_metadata_store%var_ids(curdatindex), & + string_arr, & + (/ 1, 1 + diag_metadata_store%rel_indexes(curdatindex) /) & + )) + deallocate(string_arr) + end if + + ! Check for data flushing, and if so, update the relative indexes + ! and set icount to 0. + if (present(flush_data_only) .AND. flush_data_only) then + diag_metadata_store%rel_indexes(curdatindex) = & + diag_metadata_store%rel_indexes(curdatindex) + & + diag_metadata_store%stor_i_arr(curdatindex)%icount + diag_metadata_store%stor_i_arr(curdatindex)%icount = 0 + +#ifdef _DEBUG_MEM_ + print *, "diag_metadata_store%rel_indexes(curdatindex) is now:" + print *, diag_metadata_store%rel_indexes(curdatindex) +#endif + end if + + end if + end do + + if (present(flush_data_only) .AND. flush_data_only) then +#ifdef _DEBUG_MEM_ + print *, "In buffer flush mode!" +#endif + + ! We need to reset all array counts to zero! + diag_metadata_store%acount = 0 + else + ! Lock data writing + diag_metadata_store%data_lock = .TRUE. +#ifdef _DEBUG_MEM_ + print *, "In data lock mode!" +#endif + end if + else + call nclayer_error("Can't write data - data have already been written and locked!") + end if + else + call nclayer_error("Can't write data - NetCDF4 layer not initialized yet!") + end if + +#ifdef _DEBUG_MEM_ + print *, "All done writing metadata data" +#endif + end subroutine nc_diag_metadata_write_data + + subroutine nc_diag_metadata_set_strict(enable_strict) + logical, intent(in) :: enable_strict + + if (init_done .AND. allocated(diag_metadata_store)) then + diag_metadata_store%strict_check = enable_strict + else + call nclayer_error("Can't set strictness level for metadata - NetCDF4 layer not initialized yet!") + end if + end subroutine nc_diag_metadata_set_strict + + ! Preallocate variable name/type/etc. storage. + subroutine nc_diag_metadata_prealloc_vars(num_of_addl_vars) + integer(i_llong), intent(in) :: num_of_addl_vars +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_metadata_prealloc_vars(num_of_addl_vars = ", num_of_addl_vars, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + if (init_done .AND. allocated(diag_metadata_store)) then + if (allocated(diag_metadata_store%names)) then + if (diag_metadata_store%total >= size(diag_metadata_store%names)) then + call nc_diag_realloc(diag_metadata_store%names, num_of_addl_vars) + end if + else + allocate(diag_metadata_store%names(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + end if + + if (allocated(diag_metadata_store%types)) then + if (diag_metadata_store%total >= size(diag_metadata_store%types)) then + call nc_diag_realloc(diag_metadata_store%types, num_of_addl_vars) + end if + else + allocate(diag_metadata_store%types(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + end if + + if (allocated(diag_metadata_store%stor_i_arr)) then + if (diag_metadata_store%total >= size(diag_metadata_store%stor_i_arr)) then + call nc_diag_metadata_resize_iarr_type(num_of_addl_vars) + end if + else + allocate(diag_metadata_store%stor_i_arr(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + end if + + if (allocated(diag_metadata_store%var_ids)) then + if (diag_metadata_store%total >= size(diag_metadata_store%var_ids)) then + call nc_diag_realloc(diag_metadata_store%var_ids, num_of_addl_vars) + end if + else + allocate(diag_metadata_store%var_ids(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_metadata_store%var_ids = -1 + end if + + if (allocated(diag_metadata_store%alloc_sia_multi)) then + if (diag_metadata_store%total >= size(diag_metadata_store%alloc_sia_multi)) then + call nc_diag_realloc(diag_metadata_store%alloc_sia_multi, num_of_addl_vars) + end if + else + allocate(diag_metadata_store%alloc_sia_multi(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_metadata_store%alloc_sia_multi = 0 + end if + + if (allocated(diag_metadata_store%max_str_lens)) then + if (diag_metadata_store%total >= size(diag_metadata_store%max_str_lens)) then + call nc_diag_realloc(diag_metadata_store%max_str_lens, num_of_addl_vars) + end if + else + allocate(diag_metadata_store%max_str_lens(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_metadata_store%max_str_lens = -1 + end if + + if (allocated(diag_metadata_store%rel_indexes)) then + if (diag_metadata_store%total >= size(diag_metadata_store%rel_indexes)) then + call nc_diag_realloc(diag_metadata_store%rel_indexes, num_of_addl_vars) + end if + else + allocate(diag_metadata_store%rel_indexes(NLAYER_DEFAULT_ENT + num_of_addl_vars)) + diag_metadata_store%rel_indexes = 0 + end if + + diag_metadata_store%prealloc_total = diag_metadata_store%prealloc_total + num_of_addl_vars + else + call nclayer_error("NetCDF4 layer not initialized yet!") + endif + end subroutine nc_diag_metadata_prealloc_vars + + ! Preallocate actual variable data storage + subroutine nc_diag_metadata_prealloc_vars_storage(nclayer_type, num_of_addl_slots) + integer(i_byte), intent(in) :: nclayer_type + integer(i_llong), intent(in) :: num_of_addl_slots + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A, I0, A)") "nc_diag_metadata_prealloc_vars_storage(nclayer_type = ", nclayer_type, ", num_of_addl_slots = ", num_of_addl_slots, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (nclayer_type == NLAYER_BYTE) then + call nc_diag_metadata_resize_byte(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_SHORT) then + call nc_diag_metadata_resize_short(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_LONG) then + call nc_diag_metadata_resize_long(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_FLOAT) then + call nc_diag_metadata_resize_rsingle(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_DOUBLE) then + call nc_diag_metadata_resize_rdouble(num_of_addl_slots, .FALSE.) + else if (nclayer_type == NLAYER_STRING) then + call nc_diag_metadata_resize_string(num_of_addl_slots, .FALSE.) + else + call nclayer_error("Invalid type specified for variable storage preallocation!") + end if + end subroutine nc_diag_metadata_prealloc_vars_storage + + ! Preallocate index storage + subroutine nc_diag_metadata_prealloc_vars_storage_all(num_of_addl_slots) + integer(i_llong), intent(in) :: num_of_addl_slots + integer(i_long) :: i + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_metadata_prealloc_vars_storage_all(num_of_addl_slots = ", num_of_addl_slots, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + do i = 1, diag_metadata_store%prealloc_total + call nc_diag_metadata_resize_iarr(i, num_of_addl_slots, .FALSE.) + end do + end subroutine nc_diag_metadata_prealloc_vars_storage_all + + subroutine nc_diag_metadata_expand + integer(i_llong) :: addl_fields + + ! Did we realloc at all? + logical :: meta_realloc + + meta_realloc = .FALSE. + + if (init_done .AND. allocated(diag_metadata_store)) then + addl_fields = 1 + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_s_multi)) + +#ifdef _DEBUG_MEM_ + call nclayer_debug("INITIAL value of diag_metadata_store%alloc_s_multi:") + print *, diag_metadata_store%alloc_s_multi +#endif + + if (allocated(diag_metadata_store%names)) then + if (diag_metadata_store%total >= size(diag_metadata_store%names)) then +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocating diag_metadata_store%names...") + print *, (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_s_multi) + print *, addl_fields +#endif + call nc_diag_realloc(diag_metadata_store%names, addl_fields) +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocated diag_metadata_store%names. Size:") + print *, size(diag_metadata_store%names) +#endif + meta_realloc = .TRUE. + end if + else +#ifdef _DEBUG_MEM_ + call nclayer_debug("Allocating diag_metadata_store%names for first time...") + print *, NLAYER_DEFAULT_ENT +#endif + + allocate(diag_metadata_store%names(NLAYER_DEFAULT_ENT)) + +#ifdef _DEBUG_MEM_ + call nclayer_debug("Allocated diag_metadata_store%names. Size:") + print *, size(diag_metadata_store%names) +#endif + end if + + if (allocated(diag_metadata_store%types)) then + if (diag_metadata_store%total >= size(diag_metadata_store%types)) then +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocating diag_metadata_store%types...") + print *, (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_s_multi) + print *, addl_fields +#endif + call nc_diag_realloc(diag_metadata_store%types, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_metadata_store%types(NLAYER_DEFAULT_ENT)) + end if + + if (allocated(diag_metadata_store%stor_i_arr)) then + if (diag_metadata_store%total >= size(diag_metadata_store%stor_i_arr)) then +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocating diag_metadata_store%stor_i_arr...") + print *, (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_s_multi) + print *, (1 + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_s_multi))) +#endif + call nc_diag_metadata_resize_iarr_type(addl_fields) + + meta_realloc = .TRUE. + end if + else + allocate(diag_metadata_store%stor_i_arr(NLAYER_DEFAULT_ENT)) + end if + + if (allocated(diag_metadata_store%var_ids)) then + if (diag_metadata_store%total >= size(diag_metadata_store%var_ids)) then + call nc_diag_realloc(diag_metadata_store%var_ids, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_metadata_store%var_ids(NLAYER_DEFAULT_ENT)) + diag_metadata_store%var_ids = -1 + end if + + if (allocated(diag_metadata_store%alloc_sia_multi)) then + if (diag_metadata_store%total >= size(diag_metadata_store%alloc_sia_multi)) then + call nc_diag_realloc(diag_metadata_store%alloc_sia_multi, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_metadata_store%alloc_sia_multi(NLAYER_DEFAULT_ENT)) + diag_metadata_store%alloc_sia_multi = 0 + end if + + if (allocated(diag_metadata_store%max_str_lens)) then + if (diag_metadata_store%total >= size(diag_metadata_store%max_str_lens)) then + call nc_diag_realloc(diag_metadata_store%max_str_lens, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_metadata_store%max_str_lens(NLAYER_DEFAULT_ENT)) + diag_metadata_store%max_str_lens = -1 + end if + + if (allocated(diag_metadata_store%rel_indexes)) then + if (diag_metadata_store%total >= size(diag_metadata_store%rel_indexes)) then + call nc_diag_realloc(diag_metadata_store%rel_indexes, addl_fields) + meta_realloc = .TRUE. + end if + else + allocate(diag_metadata_store%rel_indexes(NLAYER_DEFAULT_ENT)) + diag_metadata_store%rel_indexes = 0 + end if + + if (meta_realloc) then + diag_metadata_store%alloc_s_multi = diag_metadata_store%alloc_s_multi + 1 +#ifdef _DEBUG_MEM_ + print *, "Incrementing alloc_s_multi... new value:" + print *, diag_metadata_store%alloc_s_multi +#endif + endif + else + call nclayer_error("NetCDF4 layer not initialized yet!") + endif + + end subroutine nc_diag_metadata_expand + + function nc_diag_metadata_lookup_var(metadata_name) result(ind) + character(len=*), intent(in) :: metadata_name + integer :: i, ind + + ind = -1 + + if (init_done .AND. allocated(diag_metadata_store)) then + do i = 1, diag_metadata_store%total + if (diag_metadata_store%names(i) == metadata_name) then + ind = i + exit + end if + end do + end if + end function nc_diag_metadata_lookup_var + + ! nc_diag_metadata - input integer(i_byte) + ! Corresponding NetCDF4 type: byte + subroutine nc_diag_metadata_byte(metadata_name, metadata_value) + character(len=*), intent(in) :: metadata_name + integer(i_byte), intent(in) :: metadata_value + + integer(i_long) :: var_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_metadata_byte(metadata_name = " // metadata_name // ", metadata_value = ", metadata_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_metadata_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_metadata_lookup_var(metadata_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_metadata_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_metadata_expand + + diag_metadata_store%total = diag_metadata_store%total + 1 + + diag_metadata_store%names(diag_metadata_store%total) = metadata_name + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_BYTE + + var_index = diag_metadata_store%total + end if + + ! We just need to add one entry... + call nc_diag_metadata_resize_iarr(var_index, 1_i_llong) + call nc_diag_metadata_resize_byte(1_i_llong) + + ! Now add the actual entry! + diag_metadata_store%m_byte(diag_metadata_store%acount(1)) = metadata_value + diag_metadata_store%stor_i_arr(var_index)%index_arr(diag_metadata_store%stor_i_arr(var_index)%icount) = & + diag_metadata_store%acount(1) + end subroutine nc_diag_metadata_byte + + ! nc_diag_metadata - input integer(i_short) + ! Corresponding NetCDF4 type: short + subroutine nc_diag_metadata_short(metadata_name, metadata_value) + character(len=*), intent(in) :: metadata_name + integer(i_short), intent(in) :: metadata_value + + integer(i_long) :: var_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_metadata_short(metadata_name = " // metadata_name // ", metadata_value = ", metadata_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_metadata_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_metadata_lookup_var(metadata_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_metadata_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_metadata_expand + + diag_metadata_store%total = diag_metadata_store%total + 1 + + diag_metadata_store%names(diag_metadata_store%total) = metadata_name + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_SHORT + + var_index = diag_metadata_store%total + end if + + ! We just need to add one entry... + call nc_diag_metadata_resize_iarr(var_index, 1_i_llong) + call nc_diag_metadata_resize_short(1_i_llong) + + ! Now add the actual entry! + diag_metadata_store%m_short(diag_metadata_store%acount(2)) = metadata_value + diag_metadata_store%stor_i_arr(var_index)%index_arr(diag_metadata_store%stor_i_arr(var_index)%icount) = & + diag_metadata_store%acount(2) + end subroutine nc_diag_metadata_short + + ! nc_diag_metadata - input integer(i_long) + ! Corresponding NetCDF4 type: int (old: long) + subroutine nc_diag_metadata_long(metadata_name, metadata_value) + character(len=*), intent(in) :: metadata_name + integer(i_long), intent(in) :: metadata_value + + integer(i_long) :: var_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, I0, A)") "nc_diag_metadata_long(metadata_name = " // metadata_name // ", metadata_value = ", metadata_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_metadata_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_metadata_lookup_var(metadata_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_metadata_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_metadata_expand + + diag_metadata_store%total = diag_metadata_store%total + 1 + + diag_metadata_store%names(diag_metadata_store%total) = metadata_name + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_LONG + + var_index = diag_metadata_store%total + end if + +#ifdef _DEBUG_MEM_ + call nclayer_debug("Current total:") + print *, diag_metadata_store%total +#endif + + ! We just need to add one entry... + call nc_diag_metadata_resize_iarr(var_index, 1_i_llong) + call nc_diag_metadata_resize_long(1_i_llong) + + ! Now add the actual entry! + diag_metadata_store%m_long(diag_metadata_store%acount(3)) = metadata_value + diag_metadata_store%stor_i_arr(var_index)%index_arr(diag_metadata_store%stor_i_arr(var_index)%icount) = & + diag_metadata_store%acount(3) + end subroutine nc_diag_metadata_long + + ! nc_diag_metadata - input real(r_single) + ! Corresponding NetCDF4 type: float (or real) + subroutine nc_diag_metadata_rsingle(metadata_name, metadata_value) + character(len=*), intent(in) :: metadata_name + real(r_single), intent(in) :: metadata_value + + integer(i_long) :: var_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, F0.5, A)") "nc_diag_metadata_rsingle(metadata_name = " // metadata_name // ", metadata_value = ", metadata_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_metadata_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_metadata_lookup_var(metadata_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_metadata_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if +#ifdef _DEBUG_MEM_ + write (*, "(A, A, A, F)") "NEW METADATA: ", metadata_name, " | First value: ", metadata_value +#endif + call nc_diag_metadata_expand + + diag_metadata_store%total = diag_metadata_store%total + 1 + + diag_metadata_store%names(diag_metadata_store%total) = metadata_name + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_FLOAT + + var_index = diag_metadata_store%total + end if + + ! We just need to add one entry... + call nc_diag_metadata_resize_iarr(var_index, 1_i_llong) + call nc_diag_metadata_resize_rsingle(1_i_llong) + + ! Now add the actual entry! + diag_metadata_store%m_rsingle(diag_metadata_store%acount(4)) = metadata_value + diag_metadata_store%stor_i_arr(var_index)%index_arr(diag_metadata_store%stor_i_arr(var_index)%icount) = & + diag_metadata_store%acount(4) + end subroutine nc_diag_metadata_rsingle + + ! nc_diag_metadata - input real(r_double) + ! Corresponding NetCDF4 type: double + subroutine nc_diag_metadata_rdouble(metadata_name, metadata_value) + character(len=*), intent(in) :: metadata_name + real(r_double), intent(in) :: metadata_value + + integer(i_long) :: var_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A, F0.5, A)") "nc_diag_metadata_rdouble(metadata_name = " // metadata_name // ", metadata_value = ", metadata_value, ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_metadata_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_metadata_lookup_var(metadata_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_metadata_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_metadata_expand + + diag_metadata_store%total = diag_metadata_store%total + 1 + + diag_metadata_store%names(diag_metadata_store%total) = metadata_name + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_DOUBLE + + var_index = diag_metadata_store%total + end if + + ! We just need to add one entry... + call nc_diag_metadata_resize_iarr(var_index, 1_i_llong) + call nc_diag_metadata_resize_rdouble(1_i_llong) + + ! Now add the actual entry! + diag_metadata_store%m_rdouble(diag_metadata_store%acount(5)) = metadata_value + diag_metadata_store%stor_i_arr(var_index)%index_arr(diag_metadata_store%stor_i_arr(var_index)%icount) = & + diag_metadata_store%acount(5) + end subroutine nc_diag_metadata_rdouble + + ! nc_diag_metadata - input character(len=*) + ! Corresponding NetCDF4 type: string? char? + subroutine nc_diag_metadata_string(metadata_name, metadata_value) + character(len=*), intent(in) :: metadata_name + character(len=*), intent(in) :: metadata_value + + integer(i_long) :: var_index + +#ifdef ENABLE_ACTION_MSGS + character(len=1000) :: action_str + + if (nclayer_enable_action) then + write(action_str, "(A)") "nc_diag_metadata_string(metadata_name = " // metadata_name // ", metadata_value = " // trim(metadata_value) // ")" + call nclayer_actionm(trim(action_str)) + end if +#endif + + if (diag_metadata_store%data_lock) then + call nclayer_error("Can't add new data - data have already been written and locked!") + end if + + var_index = nc_diag_metadata_lookup_var(metadata_name) + + if (var_index == -1) then + ! First, check to make sure we can still define new variables. + if (diag_metadata_store%def_lock) then + call nclayer_error("Can't add new variable - definitions have already been written and locked!") + end if + + call nc_diag_metadata_expand + + diag_metadata_store%total = diag_metadata_store%total + 1 + + diag_metadata_store%names(diag_metadata_store%total) = metadata_name + diag_metadata_store%types(diag_metadata_store%total) = NLAYER_STRING + + var_index = diag_metadata_store%total + else + ! Check max string length +#ifdef _DEBUG_MEM_ + print *, "len_trim(metadata_value) = ", len_trim(metadata_value) + print *, "diag_metadata_store%max_str_lens(var_index) = ", diag_metadata_store%max_str_lens(var_index) +#endif + if ((diag_metadata_store%def_lock) .AND. & + (len_trim(metadata_value) > diag_metadata_store%max_str_lens(var_index))) & + call nclayer_error("Cannot expand variable string length after locking variable definitions!") + end if + + ! We just need to add one entry... + ! Strings can't be vectored (at least for attributes), so no 2nd argument + ! here. + call nc_diag_metadata_resize_iarr(var_index, 1_i_llong) + call nc_diag_metadata_resize_string(1_i_llong) + + ! If trim isn't enabled, set our maximum string length here! + if (.NOT. enable_trim) then + if (diag_metadata_store%max_str_lens(var_index) == -1) then + diag_metadata_store%max_str_lens(var_index) = len(metadata_value) + else + ! Validate that our non-first value isn't different from + ! the initial string length + if (diag_metadata_store%max_str_lens(var_index) /= len(metadata_value)) & + call nclayer_error("Cannot change string size when trimming is disabled!") + end if + end if + + ! Now add the actual entry! + diag_metadata_store%m_string(diag_metadata_store%acount(6)) = metadata_value + diag_metadata_store%stor_i_arr(var_index)%index_arr(diag_metadata_store%stor_i_arr(var_index)%icount) = & + diag_metadata_store%acount(6) + end subroutine nc_diag_metadata_string +end module ncdw_metadata diff --git a/src/ncdiag/ncdw_mresize.F90 b/src/ncdiag/ncdw_mresize.F90 new file mode 100644 index 000000000..2b83f254b --- /dev/null +++ b/src/ncdiag/ncdw_mresize.F90 @@ -0,0 +1,452 @@ +module ncdw_mresize + use ncd_kinds, only: i_byte, i_short, i_long, i_llong, r_single, & + r_double + use ncdw_state, only: diag_metadata_store + use ncdw_types, only: diag_md_iarr, NLAYER_DEFAULT_ENT, & + NLAYER_MULTI_BASE + use ncdw_realloc, only: nc_diag_realloc + use ncdw_climsg, only: & +#ifdef ENABLE_ACTION_MSGS + nclayer_enable_action, nclayer_actionm, & +#endif +#ifdef _DEBUG_MEM_ + nclayer_debug, & +#endif + nclayer_error + + implicit none + + contains + ! For all subroutines: update_acount_in specifies wheter to + ! update acount or not. By default, this is true. This is useful + ! for preallocation, when you aren't actually adding entries, + ! so you're just allocating ahead of time and NOT adding + ! elements, thus not adding to acount. + + ! nc_diag_metadata_resize - input integer(i_byte) + ! Corresponding NetCDF4 type: byte + subroutine nc_diag_metadata_resize_byte(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_BYTE is located at the first index, 1. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 1 + sc_index_vi = sc_index + 6 + + if (allocated(diag_metadata_store%m_byte)) then + if (update_acount) diag_metadata_store%acount(sc_index) = diag_metadata_store%acount(sc_index) + addl_num_entries + if (diag_metadata_store%acount(sc_index) >= diag_metadata_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_metadata_resize_byte: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_metadata_store%m_byte, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_m_multi(sc_index))))) + diag_metadata_store%asize(sc_index) = size(diag_metadata_store%m_byte) + + diag_metadata_store%alloc_m_multi(sc_index) = diag_metadata_store%alloc_m_multi(sc_index) + 1 + end if + else + if (update_acount) diag_metadata_store%acount(sc_index) = addl_num_entries + allocate(diag_metadata_store%m_byte(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_metadata_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_metadata_resize_byte + + ! nc_diag_metadata_resize - input integer(i_short) + ! Corresponding NetCDF4 type: short + subroutine nc_diag_metadata_resize_short(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_SHORT is located at the second index, 2. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 2 + sc_index_vi = sc_index + 6 + + if (allocated(diag_metadata_store%m_short)) then + if (update_acount) diag_metadata_store%acount(sc_index) = diag_metadata_store%acount(sc_index) + addl_num_entries + if (diag_metadata_store%acount(sc_index) >= diag_metadata_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_metadata_resize_short: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_metadata_store%m_short, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_m_multi(sc_index))))) + diag_metadata_store%asize(sc_index) = size(diag_metadata_store%m_short) + + diag_metadata_store%alloc_m_multi(sc_index) = diag_metadata_store%alloc_m_multi(sc_index) + 1 + end if + else + if (update_acount) diag_metadata_store%acount(sc_index) = addl_num_entries + allocate(diag_metadata_store%m_short(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_metadata_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_metadata_resize_short + + ! nc_diag_metadata_resize - input integer(i_long) + ! Corresponding NetCDF4 type: int (old: long) + subroutine nc_diag_metadata_resize_long(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! Did we realloc at all? + !logical :: metadata_realloc + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + +#ifdef _DEBUG_MEM_ + character(len=200) :: debugstr +#endif + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Default is false - no realloc done. + !metadata_realloc = .FALSE. + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_LONG is located at the third index, 3. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 3 + sc_index_vi = sc_index + 6 + + if (allocated(diag_metadata_store%m_long)) then + if (update_acount) diag_metadata_store%acount(sc_index) = diag_metadata_store%acount(sc_index) + addl_num_entries + +#ifdef _DEBUG_MEM_ + write (debugstr, "(A, I1, A, I7, A, I7)") "In sc_index ", sc_index, ", the acount/asize is: ", diag_metadata_store%acount(sc_index), "/", diag_metadata_store%asize(sc_index) + call nclayer_debug(debugstr) +#endif + + if (diag_metadata_store%acount(sc_index) >= diag_metadata_store%asize(sc_index)) then +#ifdef _DEBUG_MEM_ + call nclayer_debug("acount < asize, reallocating.") + print *, "Start long realloc..." +#endif +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_metadata_resize_long: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_metadata_store%m_long, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_m_multi(sc_index))))) + diag_metadata_store%asize(sc_index) = size(diag_metadata_store%m_long) + + diag_metadata_store%alloc_m_multi(sc_index) = diag_metadata_store%alloc_m_multi(sc_index) + 1 + +#ifdef _DEBUG_MEM_ + print *, "alloc_m_multi increased to:" + print *, diag_metadata_store%alloc_m_multi(sc_index) +#endif + end if + else + if (update_acount) diag_metadata_store%acount(sc_index) = addl_num_entries + allocate(diag_metadata_store%m_long(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_metadata_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_metadata_resize_long + + ! nc_diag_metadata_resize - input real(r_single) + ! Corresponding NetCDF4 type: float (or real) + subroutine nc_diag_metadata_resize_rsingle(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_FLOAT is located at the fourth index, 4. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 4 + sc_index_vi = sc_index + 6 + + if (allocated(diag_metadata_store%m_rsingle)) then + if (update_acount) diag_metadata_store%acount(sc_index) = diag_metadata_store%acount(sc_index) + addl_num_entries + if (diag_metadata_store%acount(sc_index) >= diag_metadata_store%asize(sc_index)) then +#ifdef _DEBUG_MEM_ + print *, "realloc needed for metadata rsingle!" + write (*, "(A, I0, A, I0, A)") "(size needed / size available: ", diag_metadata_store%acount(sc_index), " / ", diag_metadata_store%asize(sc_index), ")" +#endif +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_metadata_resize_rsingle: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_metadata_store%m_rsingle, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_m_multi(sc_index))))) + diag_metadata_store%asize(sc_index) = size(diag_metadata_store%m_rsingle) + + diag_metadata_store%alloc_m_multi(sc_index) = diag_metadata_store%alloc_m_multi(sc_index) + 1 + end if + else + if (update_acount) diag_metadata_store%acount(sc_index) = addl_num_entries + allocate(diag_metadata_store%m_rsingle(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_metadata_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_metadata_resize_rsingle + + ! nc_diag_metadata_resize - input real(r_double) + ! Corresponding NetCDF4 type: double + subroutine nc_diag_metadata_resize_rdouble(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_DOUBLE is located at the fifth index, 5. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 5 + sc_index_vi = sc_index + 6 + + if (allocated(diag_metadata_store%m_rdouble)) then + if (update_acount) diag_metadata_store%acount(sc_index) = diag_metadata_store%acount(sc_index) + addl_num_entries + if (diag_metadata_store%acount(sc_index) >= diag_metadata_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_metadata_resize_rdouble: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_metadata_store%m_rdouble, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_m_multi(sc_index))))) + diag_metadata_store%asize(sc_index) = size(diag_metadata_store%m_rdouble) + + diag_metadata_store%alloc_m_multi(sc_index) = diag_metadata_store%alloc_m_multi(sc_index) + 1 + end if + else + if (update_acount) diag_metadata_store%acount(sc_index) = addl_num_entries + allocate(diag_metadata_store%m_rdouble(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_metadata_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_metadata_resize_rdouble + + ! nc_diag_metadata_resize - input character(len=*) + ! Corresponding NetCDF4 type: string? char? + subroutine nc_diag_metadata_resize_string(addl_num_entries, update_acount_in) + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_acount_in + + ! This is the Size Count index (sc_index) - we'll just set + ! this and then just change the variable we're altering + ! every time. + integer(i_long) :: sc_index + integer(i_long) :: sc_index_vi + + logical :: update_acount + + ! Assume true by default + if (.NOT. present(update_acount_in)) then + update_acount = .TRUE. + else + update_acount = update_acount_in + end if + ! Here, we increment the count by the number of additional entries, + ! and the size by that amount as well. + ! + ! If we didn't allocate yet, we simply set the count to the number of + ! initial entries, and then allocate that number + our default + ! initialization amount. Our initial size is that number + the initial + ! amount. + + ! NLAYER_BYTE is located at the sixth index, 6. + ! sc_index_vi is just sc_index + 6, 6 being the number of single types + sc_index = 6 + sc_index_vi = sc_index + 6 + + if (allocated(diag_metadata_store%m_string)) then + if (update_acount) diag_metadata_store%acount(sc_index) = diag_metadata_store%acount(sc_index) + addl_num_entries + if (diag_metadata_store%acount(sc_index) >= diag_metadata_store%asize(sc_index)) then +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_metadata_resize_string: doing reallocation!") + end if +#endif + call nc_diag_realloc(diag_metadata_store%m_string, int8(addl_num_entries + (NLAYER_DEFAULT_ENT * (NLAYER_MULTI_BASE ** diag_metadata_store%alloc_m_multi(sc_index))))) + diag_metadata_store%asize(sc_index) = size(diag_metadata_store%m_string) + + diag_metadata_store%alloc_m_multi(sc_index) = diag_metadata_store%alloc_m_multi(sc_index) + 1 + end if + else + if (update_acount) diag_metadata_store%acount(sc_index) = addl_num_entries + allocate(diag_metadata_store%m_string(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_metadata_store%asize(sc_index) = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_metadata_resize_string + + subroutine nc_diag_metadata_resize_iarr_type(addl_num_entries) + integer(i_llong), intent(in) :: addl_num_entries + + type(diag_md_iarr), dimension(:), allocatable :: tmp_stor_i_arr + +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_metadata_resize_iarr_type: doing reallocation!") + end if +#endif + + ! We need to realloc ourselves here... + allocate(tmp_stor_i_arr(size(diag_metadata_store%stor_i_arr) + addl_num_entries)) + tmp_stor_i_arr(1:size(diag_metadata_store%stor_i_arr)) = diag_metadata_store%stor_i_arr + deallocate(diag_metadata_store%stor_i_arr) + allocate(diag_metadata_store%stor_i_arr(size(tmp_stor_i_arr))) + diag_metadata_store%stor_i_arr = tmp_stor_i_arr + deallocate(tmp_stor_i_arr) + end subroutine nc_diag_metadata_resize_iarr_type + + subroutine nc_diag_metadata_resize_iarr(iarr_index, addl_num_entries, update_icount_in) + integer(i_long), intent(in) :: iarr_index + integer(i_llong), intent(in) :: addl_num_entries + logical, intent(in), optional :: update_icount_in + + logical :: update_icount + + integer(i_llong) :: addl_num_entries_r + + ! Assume true by default + if (.NOT. present(update_icount_in)) then + update_icount = .TRUE. + else + update_icount = update_icount_in + end if + + if (allocated(diag_metadata_store%stor_i_arr(iarr_index)%index_arr)) then + if (update_icount) diag_metadata_store%stor_i_arr(iarr_index)%icount = & + diag_metadata_store%stor_i_arr(iarr_index)%icount + addl_num_entries + if (diag_metadata_store%stor_i_arr(iarr_index)%icount >= diag_metadata_store%stor_i_arr(iarr_index)%isize) then +#ifdef _DEBUG_MEM_ + print *, "realloc needed for metadata iarr!" + write (*, "(A, I0, A, I0, A)") "(size needed / size available: ", diag_metadata_store%stor_i_arr(iarr_index)%icount, " / ", diag_metadata_store%stor_i_arr(iarr_index)%isize, ")" + print *, diag_metadata_store%alloc_sia_multi(iarr_index) + print *, int8(NLAYER_MULTI_BASE ** int8(diag_metadata_store%alloc_sia_multi(iarr_index))) +#endif +#ifdef ENABLE_ACTION_MSGS + if (nclayer_enable_action) then + call nclayer_actionm("nc_diag_metadata_resize_iarr: doing reallocation!") + end if +#endif + if (update_icount) then + addl_num_entries_r = addl_num_entries + (int8(NLAYER_DEFAULT_ENT) * (NLAYER_MULTI_BASE ** int8(diag_metadata_store%alloc_sia_multi(iarr_index)))) + else + addl_num_entries_r = addl_num_entries + NLAYER_DEFAULT_ENT + end if +#ifdef _DEBUG_MEM_ + print *, " ** addl_num_entries_r = " + print *, addl_num_entries_r +#endif + call nc_diag_realloc(diag_metadata_store%stor_i_arr(iarr_index)%index_arr, addl_num_entries_r) + +#ifdef _DEBUG_MEM_ + print *, " ** realloc done" +#endif + diag_metadata_store%stor_i_arr(iarr_index)%isize = size(diag_metadata_store%stor_i_arr(iarr_index)%index_arr) + + if (update_icount) diag_metadata_store%alloc_sia_multi(iarr_index) = diag_metadata_store%alloc_sia_multi(iarr_index) + 1 + end if + else + if (update_icount) diag_metadata_store%stor_i_arr(iarr_index)%icount = addl_num_entries + allocate(diag_metadata_store%stor_i_arr(iarr_index)%index_arr(addl_num_entries + NLAYER_DEFAULT_ENT)) + diag_metadata_store%stor_i_arr(iarr_index)%isize = addl_num_entries + NLAYER_DEFAULT_ENT + end if + end subroutine nc_diag_metadata_resize_iarr +end module ncdw_mresize diff --git a/src/ncdiag/ncdw_realloc.F90 b/src/ncdiag/ncdw_realloc.F90 new file mode 100644 index 000000000..c183ec631 --- /dev/null +++ b/src/ncdiag/ncdw_realloc.F90 @@ -0,0 +1,311 @@ +module ncdw_realloc + use ncd_kinds, only: i_byte, i_short, i_long, i_llong, r_single, & + r_double + use ncdw_climsg, only: nclayer_error +#ifdef _DEBUG_MEM_ + use ncdw_climsg, only: nclayer_debug +#endif + + implicit none + + ! This file provides the interface wrapper for the array + ! reallocation subroutines. This is so that others can simply + ! call nc_diag_realloc with the necessary arguments, instead of + ! having to call the specific nc_diag_realloc_* subroutines. + + interface nc_diag_realloc + module procedure nc_diag_realloc_byte, & + nc_diag_realloc_short, nc_diag_realloc_long, & + nc_diag_realloc_llong, nc_diag_realloc_rsingle, & + nc_diag_realloc_rdouble, nc_diag_realloc_string, & + nc_diag_realloc_logical + end interface nc_diag_realloc + + contains + ! nc_diag_realloc_byte(arr, addl_num_entries) + ! input: + ! integer(i_byte), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_byte(arr, addl_num_entries) + integer(i_byte), dimension(:), allocatable, intent(inout) :: arr + integer(i_llong),intent(in) :: addl_num_entries + + integer(i_byte), dimension(:), allocatable :: tmp + integer(i_llong) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nclayer_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_byte + + ! nc_diag_realloc_short(arr, addl_num_entries) + ! input: + ! integer(i_short), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_short(arr, addl_num_entries) + integer(i_short), dimension(:), allocatable, intent(inout) :: arr + integer(i_llong),intent(in) :: addl_num_entries + + integer(i_short), dimension(:), allocatable :: tmp + integer(i_llong) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nclayer_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_short + + ! nc_diag_realloc_long(arr, addl_num_entries) + ! input: + ! integer(i_long), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_long(arr, addl_num_entries) + integer(i_long), dimension(:), allocatable, intent(inout) :: arr + integer(i_llong),intent(in) :: addl_num_entries + + integer(i_long), dimension(:), allocatable :: tmp + integer(i_llong) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocating long array...") +#endif + + new_size = size(arr) + addl_num_entries + +#ifdef _DEBUG_MEM_ + print *, "REALLOCATOR: new_size is ", new_size +#endif + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nclayer_error(trim(err_msg)) + end if + + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + +#ifdef _DEBUG_MEM_ + print *, "REALLOCATOR: final actual size is ", size(arr) + call nclayer_debug("Realloc finished for long") +#endif + end subroutine nc_diag_realloc_long + + ! nc_diag_realloc_llong(arr, addl_num_entries) + ! input: + ! integer(i_llong), dimension(:) :: arr + ! array to reallocate + ! integer(i_llong), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_llong(arr, addl_num_entries) + integer(i_llong), dimension(:), allocatable, intent(inout) :: arr + integer(i_llong),intent(in) :: addl_num_entries + + integer(i_llong), dimension(:), allocatable :: tmp + integer(i_llong) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + +#ifdef _DEBUG_MEM_ + call nclayer_debug("Reallocating long array...") +#endif + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nclayer_error(trim(err_msg)) + end if + + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + +#ifdef _DEBUG_MEM_ + call nclayer_debug("Realloc finished for long") +#endif + end subroutine nc_diag_realloc_llong + + ! nc_diag_realloc_rsingle(arr, addl_num_entries) + ! input: + ! real(r_single), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_rsingle(arr, addl_num_entries) + real(r_single), dimension(:), allocatable, intent(inout) :: arr + integer(i_llong),intent(in) :: addl_num_entries + + real(r_single), dimension(:), allocatable :: tmp + integer(i_llong) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nclayer_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_rsingle + + ! nc_diag_realloc_rdouble(arr, addl_num_entries) + ! input: + ! real(r_double), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_rdouble(arr, addl_num_entries) + real(r_double), dimension(:), allocatable, intent(inout) :: arr + integer(i_llong),intent(in) :: addl_num_entries + + real(r_double), dimension(:), allocatable :: tmp + integer(i_llong) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nclayer_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_rdouble + + ! nc_diag_realloc_string(arr, addl_num_entries) + ! input: + ! character(len=*), dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_string(arr, addl_num_entries) + character(len=*), dimension(:), allocatable, intent(inout) :: arr + integer(i_llong),intent(in) :: addl_num_entries + + character(len=len(arr(1))), dimension(:), allocatable :: tmp + integer(i_llong) :: new_size + + integer(i_byte) :: alloc_err + character(len=100) :: err_msg + +#ifdef _DEBUG_MEM_ + integer :: string_len, string_arr_size + + string_len = len(arr(1)) + string_arr_size = size(arr) + + call nclayer_debug("[string] Length of string to allocate to:") + print *, string_len + + call nclayer_debug("[string] Allocating from...") + print *, string_arr_size + + call nclayer_debug("[string] ...to size...") + print *, (string_arr_size + addl_num_entries) +#endif + + new_size = size(arr) + addl_num_entries + + allocate(tmp(new_size), STAT=alloc_err) + if (alloc_err /= 0) then + write(err_msg, "(A, I0)") "Reallocator was unable to reallocate memory! Error code: ", alloc_err + call nclayer_error(trim(err_msg)) + end if + tmp(1:size(arr)) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp + end subroutine nc_diag_realloc_string + + ! nc_diag_realloc_logical(arr, addl_num_entries) + ! input: + ! logical, dimension(:) :: arr + ! array to reallocate + ! integer(i_long), intent(in) :: addl_num_entries + ! additional number of elements to allocate to the + ! specified array + subroutine nc_diag_realloc_logical(arr, addl_num_entries) + logical, dimension(:), allocatable, intent(inout) :: arr + integer(i_llong),intent(in) :: addl_num_entries + + logical, dimension(:), allocatable :: tmp + integer(i_llong) :: new_size + + integer(i_llong) :: logical_arr_size + logical_arr_size = size(arr) + + new_size = logical_arr_size + addl_num_entries + +#ifdef _DEBUG_MEM_ + call nclayer_debug("[logical] Allocating from...") + print *, logical_arr_size + + call nclayer_debug("[logical] ...to size...") + print *, (logical_arr_size + addl_num_entries) +#endif + + allocate(tmp(new_size)) + tmp(1:logical_arr_size) = arr + deallocate(arr) + allocate(arr(new_size)) + arr = tmp +#ifdef _DEBUG_MEM_ + call nclayer_debug("[logical] Final size:") + print *, size(arr) +#endif + end subroutine nc_diag_realloc_logical +end module ncdw_realloc diff --git a/src/ncdiag/ncdw_state.f90 b/src/ncdiag/ncdw_state.f90 new file mode 100644 index 000000000..0302e8194 --- /dev/null +++ b/src/ncdiag/ncdw_state.f90 @@ -0,0 +1,20 @@ +module ncdw_state + use ncd_kinds, only: i_long + use ncdw_types, only: diag_chaninfo, diag_metadata, & + diag_data2d, diag_varattr + + implicit none + + integer(i_long) :: ncid + logical :: init_done = .FALSE. + logical :: append_only = .FALSE. + + logical :: enable_trim = .FALSE. + + character(len=200) :: cur_nc_file + + type(diag_chaninfo), allocatable :: diag_chaninfo_store + type(diag_metadata), allocatable :: diag_metadata_store + type(diag_data2d), allocatable :: diag_data2d_store + type(diag_varattr), allocatable :: diag_varattr_store +end module ncdw_state diff --git a/src/ncdiag/ncdw_strarrutils.F90 b/src/ncdiag/ncdw_strarrutils.F90 new file mode 100644 index 000000000..f4d297ee0 --- /dev/null +++ b/src/ncdiag/ncdw_strarrutils.F90 @@ -0,0 +1,232 @@ +! utils.f90 +! general utilities for Fortran programs +! Author: Albert Huang for SSAI/NASA GSFC GMAO + +module ncdw_strarrutils + implicit none + + contains + function lentrim(s) + character(len=*) :: s + integer lentrim + + do lentrim = len(s), 1, -1 + if (s(lentrim:lentrim) .ne. ' ') return + end do + end function lentrim + + function string_count_substr(s, substr) result(sub_count) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: substr + integer :: sub_count + + integer :: substr_len, i, jump + substr_len = len(substr) + sub_count = 0 + jump = 1 + i = 1 + + do while (i <= len(s) - len(substr)) + if (s(i:i+len(substr)-1) == substr) then + sub_count = sub_count + 1 + jump = len(substr) + else + jump = 1 + end if + + i = i + jump + end do + end function string_count_substr + + function string_get_max_split(s, substr) result(max_len) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: substr + integer :: sub_count + + integer :: substr_len, i, jump + integer :: max_len, tmp_len + + substr_len = len(substr) + sub_count = 0 + jump = 1 + i = 1 + + tmp_len = 0 + max_len = 0 + + do while (i <= len_trim(s) - len(substr) + 1) + if (s(i:i+len(substr)-1) == substr) then + sub_count = sub_count + 1 + if (tmp_len > max_len) max_len = tmp_len + tmp_len = 0 + jump = len(substr) + else + jump = 1 + tmp_len = tmp_len + 1 + end if + + i = i + jump + end do + + ! Do one more check to ensure we get the end! + if ((tmp_len + len(substr) - 1) > max_len) max_len = tmp_len + len(substr) - 1 + end function string_get_max_split + + function string_split_index(s, delimiter) result(split_strings) + character(len=*) :: s + character(len=*) :: delimiter + + integer :: substr_len, i, jump + integer :: tmp_idx, start_idx, total + integer :: split_length, item_length + + character(len=:), allocatable :: split_strings(:) + character(len=:), allocatable :: tmp_str + + ! Get lengths + split_length = string_count_substr(s, delimiter) + 1 + item_length = string_get_max_split(s, delimiter) + + allocate(character(item_length) :: split_strings(split_length)) + allocate(character(item_length) :: tmp_str) + + substr_len = len(delimiter) + jump = 1 + i = 1 + + tmp_idx = 1 + start_idx = 1 + total = 1 + + do while (i <= len_trim(s) - len(delimiter) + 1) + if (s(i:i+len(delimiter)-1) == delimiter) then + if (start_idx /= tmp_idx) then + split_strings(total) = s(start_idx:tmp_idx - 1) + else + split_strings(total) = "" + end if + + tmp_idx = tmp_idx + len(delimiter) + start_idx = tmp_idx + + total = total + 1 + + jump = len(delimiter) + else + jump = 1 + tmp_idx = tmp_idx + 1 + end if + + i = i + jump + end do + + ! Do one more check to ensure we get the end! + split_strings(total) = s(start_idx:tmp_idx - 1) + end function string_split_index + + ! asl = assumed shape length + subroutine string_array_dump(strings) + character(len=:), allocatable :: strings(:) + integer i + + write (*, "(A, I0)") "Length of strings array: ", size(strings(:)) + print *, " -> String array dump:" + + do i = 1, size(strings(:)) + if (strings(i) == "") then + write (*, "(A, I0, A, I0, A, I0, A)") " --> Position ", i, ": (empty) [Trim length = ", len_trim(strings(i)), ", Full length = ", len(strings(i)), "]" + else + write (*, "(A, I0, A, A, A, I0, A, I0, A)") " --> Position ", i, ": '", trim(strings(i)), "' [Trim length = ", len_trim(strings(i)), ", Full length = ", len(strings(i)), "]" + end if + end do + end subroutine string_array_dump + + function max_len_string_array(str_arr, arr_length) result(max_len) + character(len=*), intent(in) :: str_arr(:) + integer , intent(in) :: arr_length + + integer :: i, max_len + + max_len = -1 + +#ifdef _DEBUG_MEM_ + write (*, "(A, I0)") " ** max_len_string_array: size(str_arr) is ", size(str_arr) +#endif + + do i = 1, arr_length + if (len_trim(str_arr(i)) > max_len) max_len = len_trim(str_arr(i)) +#ifdef _DEBUG_MEM_ + write (*, "(A, I0, A, I0)") "max_len_string_array: str_arr(", i, ") is " // trim(str_arr(i)) // ", size is ", len_trim(str_arr(i)) + write (*, "(A, I0)") "max_len_string_array: max_len is ", max_len +#endif + end do + end function max_len_string_array + + function max_len_notrim_string_array(str_arr, arr_length) result(max_len) + character(len=*), intent(in) :: str_arr(:) + integer , intent(in) :: arr_length + + integer :: i, max_len + + max_len = -1 + +#ifdef _DEBUG_MEM_ + write (*, "(A, I0)") " ** max_len_notrim_string_array: size(str_arr) is ", size(str_arr) +#endif + + do i = 1, arr_length + if (len(str_arr(i)) > max_len) max_len = len(str_arr(i)) +#ifdef _DEBUG_MEM_ + write (*, "(A, I0, A, I0)") "max_len_notrim_string_array: str_arr(", i, ") is " // trim(str_arr(i)) // ", size is ", len_trim(str_arr(i)) + write (*, "(A, I0)") "max_len_notrim_string_array: max_len is ", max_len +#endif + end do + end function max_len_notrim_string_array + + subroutine string_before_delimiter(s, delimiter, string_part) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: delimiter + character(len=:), intent(inout), allocatable :: string_part + + integer :: substr_len, i, jump + integer :: tmp_idx, start_idx, total + + logical found + found = .FALSE. + + ! Get lengths + substr_len = len(delimiter) + jump = 1 + i = 1 + + tmp_idx = 1 + start_idx = 1 + total = 1 + + do while (i <= len_trim(s) - len(delimiter) + 1) + if (s(i:i+len(delimiter)-1) == delimiter) then + found = .TRUE. + exit + else + jump = 1 + tmp_idx = tmp_idx + 1 + end if + + i = i + jump + end do + + ! Do one more check to ensure we get the end! + if (found) then + if (start_idx == tmp_idx) then + allocate(character(0) :: string_part) + string_part = "" + else + allocate(character(tmp_idx - start_idx + 1) :: string_part) + string_part = s(start_idx:tmp_idx - 1) + end if + else + allocate(character(len(s)) :: string_part) + string_part = s + end if + end subroutine string_before_delimiter +end module ncdw_strarrutils diff --git a/src/ncdiag/ncdw_types.F90 b/src/ncdiag/ncdw_types.F90 new file mode 100644 index 000000000..9067656f5 --- /dev/null +++ b/src/ncdiag/ncdw_types.F90 @@ -0,0 +1,449 @@ +module ncdw_types + use ncd_kinds, only: i_byte, i_short, i_long, i_llong, & + r_single, r_double + use netcdf, only: NF90_FILL_BYTE, NF90_FILL_SHORT, NF90_FILL_INT, & + NF90_FILL_FLOAT, NF90_FILL_DOUBLE, NF90_FILL_CHAR + + implicit none + + ! NetCDF4 type struct constants + integer(i_byte), parameter :: NLAYER_BYTE = 1 + integer(i_byte), parameter :: NLAYER_SHORT = 2 + integer(i_byte), parameter :: NLAYER_LONG = 3 + integer(i_byte), parameter :: NLAYER_FLOAT = 4 + integer(i_byte), parameter :: NLAYER_DOUBLE = 5 + integer(i_byte), parameter :: NLAYER_STRING = 6 + + ! Default number of starting entries + integer(i_short), parameter :: NLAYER_DEFAULT_ENT = 1024 + + ! NetCDF zlib (/gzip) compression level + integer(i_byte), parameter :: NLAYER_COMPRESSION = 5 + + ! NetCDF chunking size + integer(i_long), parameter :: NLAYER_CHUNKING = 16384 + + ! Base used when exponentiated. + integer(i_long), parameter :: NLAYER_MULTI_BASE = 2 + + integer(i_byte), parameter :: NLAYER_FILL_BYTE = NF90_FILL_BYTE + integer(i_short),parameter :: NLAYER_FILL_SHORT = NF90_FILL_SHORT + integer(i_long), parameter :: NLAYER_FILL_LONG = NF90_FILL_INT + real(r_single), parameter :: NLAYER_FILL_FLOAT = NF90_FILL_FLOAT + real(r_double), parameter :: NLAYER_FILL_DOUBLE = NF90_FILL_DOUBLE + character, parameter :: NLAYER_FILL_CHAR = NF90_FILL_CHAR + + type diag_chaninfo + ! Number of channels to store + integer(i_long) :: nchans = -1 + + ! The NetCDF dimension ID for nchans + ! (This doesn't get set unless we do nc_diag_chaninfo_load_def, + ! or we write out the nchans dimension and fetch the ID with + ! nc_diag_chaninfo_write_def.) + integer(i_long) :: nchans_dimid + + ! # of times we needed to realloc chaninfo + ! also the multiplier factor for allocation (2^x) + integer(i_byte) :: alloc_multi + + ! Did we write anything out yet? + ! Definition writing lock and data writing lock + logical :: def_lock + logical :: data_lock + + ! Enable strict checking for bounds? + ! (Making sure that the sizes are consistent!) + ! If true, this makes inconsistency result in an error! + logical :: strict_check + + !----------------------------------------------------------- + ! Variable storage + !----------------------------------------------------------- + + ! Name array for each variable + ! Size: number of variables stored + character(len=100), dimension(:),allocatable :: names + + ! Type constants array for each variable + ! Size: number of variables stored + integer(i_byte), dimension(:),allocatable :: types + + ! Relative positioning for each variable - relative position + ! in groups of nchan within each type array. For instance, + ! if "asdf" has a relative value of 2, type of BYTE, and nchan + ! of 10, then variable "asdf" will start at 1 + [(2 - 1) * 10] = 11 + ! within the byte storage array. Eqn: 1 + [(REL_VAL - 1) * nchan] + ! + ! Size: number of variables stored + integer(i_long), dimension(:),allocatable :: var_rel_pos + + ! Current variable usage (which, for each element, + ! should be <= nchans) + ! Size: number of variables stored + integer(i_long), dimension(:),allocatable :: var_usage + + ! Variable IDs (for use with NetCDF API) + ! Size: number of variables stored + integer(i_long), dimension(:),allocatable :: var_ids + + ! Maximum string length - only used when the variable + ! definitions are locked. + ! Size: number of variables stored + integer(i_long), dimension(:), allocatable :: max_str_lens + + ! Relative indexes - for buffer flushing, keep track of the + ! relative indexes when we flush data. We store the + ! variable count here so that we can reference it when we + ! reset our variable counter to zero, allowing us to reuse + ! memory while still preserving data order! + ! + ! Note that the relative index follows Fortran order, e.g. we + ! start at 1. If it's 1, there's 1 element already stored for + ! that variable. We add 1 to the rel_indexes value to make + ! things work, since we start 1 after the last stored value. + ! + ! Size: number of variables stored + integer(i_long), dimension(:), allocatable :: rel_indexes + + !----------------------------------------------------------- + ! Type metadata storage + !----------------------------------------------------------- + + ! Type array variable usage count - number of variables + ! in each type array. For instance, if element 1 (ci_byte) has + ! a value of 3 here, it means it has 3 variables stored already. + ! (Hypothetically, if nchan = 10, then that particular type has + ! 30 stored values. + ! + ! That means I can start creating vars at 1 + [(4-1) * 10] = 31.) + ! 1 2 3 4 5 6 7 8 9 10 + ! 11 12 13 14 15 16 17 18 19 20 + ! 21 22 23 24 25 26 27 28 29 30 + ! 31 + ! + ! Size: number of types (currently 6) + integer(i_long), dimension(6) :: acount_v + + ! Total variables stored + integer(i_long) :: total = 0 + + ! Array size for each type array + ! Size: number of types (currently 6) + integer(i_long), dimension(6) :: asize + + ! Array count for each type array - used with the internal + ! resizing tool + ! (This is basically the number of elements stored in ci_*) + ! Size: number of types (currently 6) + integer(i_long), dimension(6) :: acount + + ! Storage arrays for specific types + ! + ! These store the actual data, and can be tracked using the + ! information and formula above! + ! + ! Size: variable (dynamically (re)-allocated) + integer(i_byte), dimension(:),allocatable :: ci_byte + integer(i_short), dimension(:),allocatable :: ci_short + integer(i_long), dimension(:),allocatable :: ci_long + real(r_single), dimension(:),allocatable :: ci_rsingle + real(r_double), dimension(:),allocatable :: ci_rdouble + character(len=1000), dimension(:),allocatable :: ci_string + end type diag_chaninfo + + ! diag_metadata struct + ! This is a super type to store information for the diag metadata, + ! to be stored in the NetCDF4 file. + ! + ! Storage works as follows: + ! = Add elements to the metadata structure through the subroutine + ! nc_diag_metadata(). + ! -> The element name is first added to the names variable + ! within diag_metadata. Allocation (and/or reallocation) + ! occurs if necessary. + ! -> The type of the element is stored into the types + ! variable within diag_metadata, using the constants + ! available above. Allocation (and/or reallocation) + ! occurs if necessary. + ! -> If the type of the element is a vector, the vectored + ! logical is set to true. Otherwise, it's left as false. + ! -> If the type of the element is a vector, the + ! corresponding index vector is set to the number of + ! elements in the vector. + ! -> Then the array size and count are validated for the + ! specific type. Allocation (and/or reallocation) for the + ! specific type array occurs if necessary. + ! -> Once ready, we add the actual data into diag_metadata. + ! If the type of the element is a vector, we simply + ! append the elements to the vector, since we can now + ! keep track. + ! -> Finally, we increment any counters as necessary, and + ! we call it a day! + ! = When everything is done, nc_diag_write() is called. This + ! will trigger nc_diag_metadata_write(), which will do the + ! following: + ! -> Fetch the total number of attributes. + ! -> Iterate through the names, types, and logical vectored + ! variables, using the total number of attributes. + ! -> Based on the types and logical vectored variable, + ! fetch the actual data from the right spot. + ! -> Write said data using the NetCDF4 subroutines. + ! -> Increment our own counters to keep track of how much + ! we read, especially for the individual variables and + ! types. + ! -> Not as tedious as queueing the data! + ! + ! Variables: + ! names - names of metadata information (attributes) to store. + ! This is a 1-D array of names - dimensions based on + ! the number of attributes stored. + ! types - types (specified as an integer constants located + ! above) for each attribute. This is a 1-D array of + ! integers - dimensions based on the number of + ! attributes stored. + ! vectored - whether the attribute stores a 1D vector or not. + ! This is a 1-D array of integers - dimensions based + ! on the number of attributes stored. + ! total - the total number of attributes in diag_metadata + ! asize - array size for each type. This is a 1-D array of + ! integers - dimensions based on the number of TYPES + ! available, including vectored types. In this case, + ! we have 6 single types, plus 5 "hidden" vectored + ! types (via m_***_vi), so the dimension is 11. + ! acount - array count for each type - this is the number of + ! elements already stored for each type, including + ! vectored types. The dimensions are the same as + ! asize - in this case, it's 11. + ! m_*** - data storage variables, single element array, + ! dimensions based on the number and type of + ! attributes stored. If I store one short, one float, + ! and one double from scratch, then m_short, m_float, + ! and m_double will have a length of 1 each. The rest + ! of the m_*** will be empty. + ! m_***_vi - length index storage for vectored data, dimensions + ! based on the number and type of vectored attributes + ! stored. If I store one short vector, one float + ! vector, and one double vector from scratch, then + ! m_short_vi, m_float_vi, and m_double_vi will have + ! a length of 1 vector each. The rest of the m_***_vi + ! will be empty. These are only populated when a + ! vector of data is added. + type diag_md_iarr + integer(i_long), dimension(:), allocatable :: index_arr + integer(i_long) :: icount + integer(i_long) :: isize + end type diag_md_iarr + + type diag_metadata + character(len=100), dimension(:), allocatable :: names + integer(i_byte), dimension(:), allocatable :: types + type(diag_md_iarr), dimension(:), allocatable :: stor_i_arr + integer(i_byte), dimension(:), allocatable :: alloc_sia_multi + + ! Maximum string length - only used when the variable + ! definitions are locked. + integer(i_long), dimension(:), allocatable :: max_str_lens + + ! Relative indexes - for buffer flushing, keep track of the + ! relative indexes when we flush data. We store the + ! variable count here so that we can reference it when we + ! reset our variable counter to zero, allowing us to reuse + ! memory while still preserving data order! + integer(i_long), dimension(:), allocatable :: rel_indexes + + ! Total variables + integer(i_long) :: total = 0 + integer(i_long) :: prealloc_total = 0 + + ! Array sizes + integer(i_long), dimension(6) :: asize + integer(i_long), dimension(6) :: acount + + ! # of times we needed to realloc simple metadata + ! also the multiplier factor for allocation (2^x) + integer(i_byte) :: alloc_s_multi + + ! # of times we needed to realloc metadata data storage + ! also the multiplier factor for allocation (2^x) + integer(i_byte), dimension(6) :: alloc_m_multi + + ! # of times we needed to realloc metadata INDEX data storage + ! also the multiplier factor for allocation (2^x) + integer(i_byte), dimension(6) :: alloc_mi_multi + + ! Did we write anything out yet? + logical :: def_lock + logical :: data_lock + + ! Strict checking for bounds? + ! (Making sure that the sizes are consistent!) + logical :: strict_check + + integer(i_byte), dimension(:),allocatable :: m_byte + integer(i_short), dimension(:),allocatable :: m_short + integer(i_long), dimension(:),allocatable :: m_long + real(r_single), dimension(:),allocatable :: m_rsingle + real(r_double), dimension(:),allocatable :: m_rdouble + character(len=1000), dimension(:),allocatable :: m_string + + integer(i_long), dimension(:), allocatable :: var_ids + end type diag_metadata + + ! diag_data2d struct + ! This is a super type to store information for the diag data2d, + ! to be stored in the NetCDF4 file. + ! + ! Storage works as follows: + ! = Add elements to the data2d structure through the subroutine + ! nc_diag_data2d(). + ! -> The element name is first added to the names variable + ! within diag_data2d. Allocation (and/or reallocation) + ! occurs if necessary. + ! -> The type of the element is stored into the types + ! variable within diag_data2d, using the constants + ! available above. Allocation (and/or reallocation) + ! occurs if necessary. + ! -> If the type of the element is a vector, the vectored + ! logical is set to true. Otherwise, it's left as false. + ! -> If the type of the element is a vector, the + ! corresponding index vector is set to the number of + ! elements in the vector. + ! -> Then the array size and count are validated for the + ! specific type. Allocation (and/or reallocation) for the + ! specific type array occurs if necessary. + ! -> Once ready, we add the actual data into diag_data2d. + ! If the type of the element is a vector, we simply + ! append the elements to the vector, since we can now + ! keep track. + ! -> Finally, we increment any counters as necessary, and + ! we call it a day! + ! = When everything is done, nc_diag_write() is called. This + ! will trigger nc_diag_data2d_write(), which will do the + ! following: + ! -> Fetch the total number of attributes. + ! -> Iterate through the names, types, and logical vectored + ! variables, using the total number of attributes. + ! -> Based on the types and logical vectored variable, + ! fetch the actual data from the right spot. + ! -> Write said data using the NetCDF4 subroutines. + ! -> Increment our own counters to keep track of how much + ! we read, especially for the individual variables and + ! types. + ! -> Not as tedious as queueing the data! + ! + ! Variables: + ! names - names of data2d information (attributes) to store. + ! This is a 1-D array of names - dimensions based on + ! the number of attributes stored. + ! types - types (specified as an integer constants located + ! above) for each attribute. This is a 1-D array of + ! integers - dimensions based on the number of + ! attributes stored. + ! vectored - whether the attribute stores a 1D vector or not. + ! This is a 1-D array of integers - dimensions based + ! on the number of attributes stored. + ! total - the total number of attributes in diag_data2d + ! asize - array size for each type. This is a 1-D array of + ! integers - dimensions based on the number of TYPES + ! available, including vectored types. In this case, + ! we have 6 single types, plus 5 "hidden" vectored + ! types (via m_***_vi), so the dimension is 11. + ! acount - array count for each type - this is the number of + ! elements already stored for each type, including + ! vectored types. The dimensions are the same as + ! asize - in this case, it's 11. + ! m_*** - data storage variables, single element array, + ! dimensions based on the number and type of + ! attributes stored. If I store one short, one float, + ! and one double from scratch, then m_short, m_float, + ! and m_double will have a length of 1 each. The rest + ! of the m_*** will be empty. + ! m_***_vi - length index storage for vectored data, dimensions + ! based on the number and type of vectored attributes + ! stored. If I store one short vector, one float + ! vector, and one double vector from scratch, then + ! m_short_vi, m_float_vi, and m_double_vi will have + ! a length of 1 vector each. The rest of the m_***_vi + ! will be empty. These are only populated when a + ! vector of data is added. + type diag_d2d_iarr + integer(i_long), dimension(:), allocatable :: index_arr + integer(i_long), dimension(:), allocatable :: length_arr + integer(i_long) :: icount + integer(i_long) :: isize + end type diag_d2d_iarr + + type diag_data2d + character(len=100), dimension(:), allocatable :: names + integer(i_byte), dimension(:), allocatable :: types + type(diag_d2d_iarr),dimension(:), allocatable :: stor_i_arr + integer(i_byte), dimension(:), allocatable :: alloc_sia_multi + + ! Maximum string length - only used when the variable + ! definitions are locked. + integer(i_long), dimension(:), allocatable :: max_str_lens + + ! Maximum variable length - only used when the variable + ! definitions are locked. + integer(i_long), dimension(:), allocatable :: max_lens + + ! Relative indexes - for buffer flushing, keep track of the + ! relative indexes when we flush data. We store the + ! variable count here so that we can reference it when we + ! reset our variable counter to zero, allowing us to reuse + ! memory while still preserving data order! + integer(i_long), dimension(:), allocatable :: rel_indexes + + ! Total variables + integer(i_long) :: total = 0 + integer(i_long) :: prealloc_total = 0 + + ! Array sizes + integer(i_long), dimension(6) :: asize + integer(i_long), dimension(6) :: acount + + ! # of times we needed to realloc simple data2d + ! also the multiplier factor for allocation (2^x) + integer(i_byte) :: alloc_s_multi + + ! # of times we needed to realloc data2d data storage + ! also the multiplier factor for allocation (2^x) + integer(i_byte), dimension(6) :: alloc_m_multi + + ! # of times we needed to realloc data2d INDEX data storage + ! also the multiplier factor for allocation (2^x) + integer(i_byte), dimension(6) :: alloc_mi_multi + + ! Did we write anything out yet? + logical :: def_lock + logical :: data_lock + + ! Strict checking for bounds? + ! (Making sure that the sizes are consistent!) + logical :: strict_check + + integer(i_byte), dimension(:),allocatable :: m_byte + integer(i_short), dimension(:),allocatable :: m_short + integer(i_long), dimension(:),allocatable :: m_long + real(r_single), dimension(:),allocatable :: m_rsingle + real(r_double), dimension(:),allocatable :: m_rdouble + character(len=1000), dimension(:),allocatable :: m_string + + integer(i_long), dimension(:), allocatable :: var_dim_ids + integer(i_long), dimension(:), allocatable :: var_ids + end type diag_data2d + + ! Variable type - this stores and handles all of the variables, + ! and includes the variable storage type. + type diag_varattr + character(len=100), dimension(:), allocatable :: names + integer(i_byte), dimension(:), allocatable :: types + integer(i_long), dimension(:), allocatable :: var_ids + + integer(i_llong) :: total + + ! Global nobs dimension ID + integer(i_long) :: nobs_dim_id = -1 + end type diag_varattr +end module ncdw_types diff --git a/src/ncdiag/ncdw_varattr.F90 b/src/ncdiag/ncdw_varattr.F90 new file mode 100644 index 000000000..acf6a1570 --- /dev/null +++ b/src/ncdiag/ncdw_varattr.F90 @@ -0,0 +1,380 @@ +module ncdw_varattr + use ncd_kinds, only: i_byte, i_short, i_long, i_llong, r_single, & + r_double + use ncdw_state, only: init_done, append_only, ncid, & + diag_varattr_store + use ncdw_types, only: NLAYER_DEFAULT_ENT + use ncdw_climsg, only: nclayer_error, nclayer_warning, & + nclayer_check + use ncdw_realloc, only: nc_diag_realloc + use netcdf, only: nf90_inq_dimid, nf90_def_dim, nf90_put_att, & + NF90_UNLIMITED + + implicit none + + interface nc_diag_varattr + module procedure nc_diag_varattr_byte, & + nc_diag_varattr_short, nc_diag_varattr_long, & + nc_diag_varattr_rsingle, nc_diag_varattr_rdouble, & + nc_diag_varattr_string, & + nc_diag_varattr_byte_v, nc_diag_varattr_short_v, & + nc_diag_varattr_long_v, nc_diag_varattr_rsingle_v, & + nc_diag_varattr_rdouble_v + end interface nc_diag_varattr + + contains + function nc_diag_varattr_check_var(var_name) result(found) + character(len=*), intent(in) :: var_name + integer :: i + logical :: found + found = .FALSE. + + if (init_done .AND. allocated(diag_varattr_store)) then + do i = 1, diag_varattr_store%total + if (diag_varattr_store%names(i) == var_name) then + found = .TRUE. + exit + end if + end do + end if + end function nc_diag_varattr_check_var + + function nc_diag_varattr_lookup_var(var_name) result(ind) + character(len=*), intent(in) :: var_name + integer :: i, ind + + ind = -1 + + if (init_done .AND. allocated(diag_varattr_store)) then + do i = 1, diag_varattr_store%total + if (diag_varattr_store%names(i) == var_name) then + ind = i + exit + end if + end do + end if + end function nc_diag_varattr_lookup_var + + subroutine nc_diag_varattr_make_nobs_dim + if (init_done .AND. allocated(diag_varattr_store)) then + if (diag_varattr_store%nobs_dim_id == -1) then + if (append_only) then + ! Fetch the nobs dimension ID instead! + call nclayer_check(nf90_inq_dimid(ncid, "nobs", diag_varattr_store%nobs_dim_id)) + else + call nclayer_check(nf90_def_dim(ncid, "nobs", NF90_UNLIMITED, diag_varattr_store%nobs_dim_id)) + end if + end if + else + call nclayer_error("NetCDF4 layer not initialized yet!") + end if + end subroutine nc_diag_varattr_make_nobs_dim + + subroutine nc_diag_varattr_expand(addl_fields) + integer(i_llong), intent(in) :: addl_fields + integer(i_llong) :: size_add + + if (init_done .AND. allocated(diag_varattr_store)) then + if (allocated(diag_varattr_store%names)) then + if (diag_varattr_store%total >= size(diag_varattr_store%names)) then + size_add = (size(diag_varattr_store%names) * 0.5) + addl_fields + call nc_diag_realloc(diag_varattr_store%names, addl_fields) + end if + else + allocate(diag_varattr_store%names(NLAYER_DEFAULT_ENT)) + end if + + if (allocated(diag_varattr_store%types)) then + if (diag_varattr_store%total >= size(diag_varattr_store%types)) then + size_add = (size(diag_varattr_store%types) * 0.5) + addl_fields + call nc_diag_realloc(diag_varattr_store%types, size_add) + end if + else + allocate(diag_varattr_store%types(NLAYER_DEFAULT_ENT)) + diag_varattr_store%types = -1 + end if + + if (allocated(diag_varattr_store%var_ids)) then + if (diag_varattr_store%total >= size(diag_varattr_store%var_ids)) then + size_add = (size(diag_varattr_store%var_ids) * 0.5) + addl_fields + call nc_diag_realloc(diag_varattr_store%var_ids, size_add) + end if + else + allocate(diag_varattr_store%var_ids(NLAYER_DEFAULT_ENT)) + diag_varattr_store%var_ids = -1 + end if + + else + call nclayer_error("NetCDF4 layer not initialized yet!") + endif + + end subroutine nc_diag_varattr_expand + + subroutine nc_diag_varattr_add_var(var_name, var_type, var_id) + character(len=*), intent(in) :: var_name + integer(i_byte), intent(in) :: var_type + integer(i_long) :: var_id + + if (nc_diag_varattr_check_var(var_name)) then + call nclayer_error("Variable already exists for variable attributes!") + else +#ifdef _DEBUG_MEM_ + print *, "adding var!" +#endif + call nc_diag_varattr_expand(1_i_llong) + diag_varattr_store%total = diag_varattr_store%total + 1 + diag_varattr_store%names(diag_varattr_store%total) = var_name + diag_varattr_store%types(diag_varattr_store%total) = var_type + diag_varattr_store%var_ids(diag_varattr_store%total) = var_id +#ifdef _DEBUG_MEM_ + print *, "done adding var!" +#endif + end if + end subroutine nc_diag_varattr_add_var + + ! nc_diag_varattr - input integer(i_byte) + ! Corresponding NetCDF4 type: byte + subroutine nc_diag_varattr_byte(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_byte), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_byte + + ! nc_diag_varattr - input integer(i_short) + ! Corresponding NetCDF4 type: short + subroutine nc_diag_varattr_short(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_short), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_short + + ! nc_diag_varattr - input integer(i_long) + ! Corresponding NetCDF4 type: int (old: long) + subroutine nc_diag_varattr_long(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_long + + ! nc_diag_varattr - input real(r_single) + ! Corresponding NetCDF4 type: float (or real) + subroutine nc_diag_varattr_rsingle(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_single), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_rsingle + + ! nc_diag_varattr - input real(r_double) + ! Corresponding NetCDF4 type: double + subroutine nc_diag_varattr_rdouble(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_double), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_rdouble + + ! nc_diag_varattr - input character(len=*) + ! Corresponding NetCDF4 type: string? char? + subroutine nc_diag_varattr_string(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + character(len=*), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_string + + !============================================================= + ! VECTOR TYPES + !============================================================= + + ! nc_diag_varattr - input integer(i_byte), dimension(:) + ! Corresponding NetCDF4 type: byte + subroutine nc_diag_varattr_byte_v(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_byte), dimension(:), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_byte_v + + ! nc_diag_varattr - input integer(i_short) + ! Corresponding NetCDF4 type: short + subroutine nc_diag_varattr_short_v(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_short), dimension(:), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_short_v + + ! nc_diag_varattr - input integer(i_long) + ! Corresponding NetCDF4 type: int (old: long) + subroutine nc_diag_varattr_long_v(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + integer(i_long), dimension(:), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_long_v + + ! nc_diag_varattr - input real(r_single) + ! Corresponding NetCDF4 type: float (or real) + subroutine nc_diag_varattr_rsingle_v(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_single), dimension(:), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_rsingle_v + + ! nc_diag_varattr - input real(r_double) + ! Corresponding NetCDF4 type: double + subroutine nc_diag_varattr_rdouble_v(var_name, attr_name, attr_value) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: attr_name + real(r_double), dimension(:), intent(in) :: attr_value + + integer(i_long) :: var_index + + if (nc_diag_varattr_check_var(var_name)) then + var_index = nc_diag_varattr_lookup_var(var_name) + if (var_index == -1) call nclayer_error("Bug! Variable exists but could not lookup index for attr!") + call nclayer_check(nf90_put_att(ncid, diag_varattr_store%var_ids(var_index), attr_name, attr_value)) + else + call nclayer_error("Can't set attribute for a non-existent variable!" & + // char(10) & + // " (If you did add the variable, make sure you lock" & + // char(10) & + // " the definitions before calling varattr!) ") + end if + end subroutine nc_diag_varattr_rdouble_v +end module ncdw_varattr diff --git a/src/ncdiag/netcdf_unlimdims.F90 b/src/ncdiag/netcdf_unlimdims.F90 new file mode 100644 index 000000000..d6608a22f --- /dev/null +++ b/src/ncdiag/netcdf_unlimdims.F90 @@ -0,0 +1,41 @@ +! polyfill for nc_inq_unlimdims +! (Polyfill = code that provides API support when API support is +! missing!) +! Needed to supplement Fortran API, since the NetCDF devs were a bit +! lazy with the Fortran side of things... + +module netcdf_unlimdims + use iso_c_binding + implicit none + + interface + integer (C_INT) function nc_inq_unlimdims(ncid, nunlimdimsp, unlimdimidsp) bind(c) + use iso_c_binding + integer(c_int), value :: ncid + type(c_ptr), value :: nunlimdimsp + type(c_ptr), value :: unlimdimidsp + end function + end interface + + contains + ! pf = polyfill + integer(c_int) function pf_nf90_inq_unlimdims(ncid, num_unlim_dims, unlim_dims) + integer(c_int), intent(in) :: ncid + integer(c_int), target, intent(inout) :: num_unlim_dims + integer(c_int), target, intent(out), optional :: unlim_dims(:) + + integer :: i + + if (present(unlim_dims)) then + ! Assume num_unlim_dims is set! + pf_nf90_inq_unlimdims = nc_inq_unlimdims(ncid, c_loc(num_unlim_dims), c_loc(unlim_dims)) + + do i = 1, num_unlim_dims + unlim_dims(i) = unlim_dims(i) + 1 + end do + else + pf_nf90_inq_unlimdims = nc_inq_unlimdims(ncid, c_loc(num_unlim_dims), c_null_ptr) + end if + end function pf_nf90_inq_unlimdims + +end module netcdf_unlimdims diff --git a/src/ncdiag/serial/CMakeLists.txt b/src/ncdiag/serial/CMakeLists.txt new file mode 100644 index 000000000..fa8a42103 --- /dev/null +++ b/src/ncdiag/serial/CMakeLists.txt @@ -0,0 +1,31 @@ +cmake_minimum_required(VERSION 2.8) +if(BUILD_NCDIAG) + + if( NOT USE_BASELIBS ) + if( BUILD_NCDIAG_SERIAL ) + set(NCDIAG_SERIAL_MODULE_DIR ${PROJECT_BINARY_DIR}/include/ncdiag_serial) + # NetCDF-4 library + set(NCDIAG_SERIAL_INCS "${PROJECT_BINARY_DIR}/include/ncdiag_serial") + + include_directories( ${NETCDF_INCLUDES} ${NCDIAG_SERIAL_INCS} ) + + # 32-bit reals, for now + add_definitions(-D_REAL4_) + + message("HEY!!! ncdiag flags are ${NCDIAG_Fortran_FLAGS}") + FILE(GLOB NCDIAG_SRC ${CMAKE_CURRENT_SOURCE_DIR}/../*90 ) + set_source_files_properties( ${NCDIAG_SRC} PROPERTIES COMPILE_FLAGS ${NCDIAG_Fortran_FLAGS} ) + LIST(REMOVE_ITEM NCDIAG_SRC ${CMAKE_CURRENT_SOURCE_DIR}/test_nc_unlimdims.F90 ) + LIST(REMOVE_ITEM NCDIAG_SRC ${CMAKE_CURRENT_SOURCE_DIR}/nc_diag_cat.F90 ) + add_library(ncdiag_serial STATIC ${NCDIAG_SRC}) + set_target_properties( ncdiag_serial PROPERTIES Fortran_MODULE_DIRECTORY ${NCDIAG_SERIAL_MODULE_DIR} ) + add_executable(nc_diag_cat_serial.x ${CMAKE_CURRENT_SOURCE_DIR}/../nc_diag_cat.F90 ) + set_target_properties( nc_diag_cat_serial.x PROPERTIES COMPILE_FLAGS ${NCDIAG_Fortran_FLAGS} ) + set_target_properties( nc_diag_cat_serial.x PROPERTIES Fortran_MODULE_DIRECTORY ${NCDIAG_SERIAL_MODULE_DIR} ) + target_link_libraries(nc_diag_cat_serial.x ncdiag_serial ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${ZLIB_LIBRARIES} ) + endif(BUILD_NCDIAG_SERIAL) + endif( NOT USE_BASELIBS ) +endif(BUILD_NCDIAG) + + + diff --git a/src/ncdiag/test_nc_unlimdims.F90 b/src/ncdiag/test_nc_unlimdims.F90 new file mode 100644 index 000000000..f60a44ff0 --- /dev/null +++ b/src/ncdiag/test_nc_unlimdims.F90 @@ -0,0 +1,50 @@ +program test_nc_unlimdims + use ncd_kinds, only: i_long + use ncdc_state, only: prgm_name, cli_arg_count, input_file, & + ncid_input, num_unlims + use ncdc_climsg, only: ncdc_error, ncdc_info, ncdc_check + use netcdf, only: nf90_open, nf90_inquire_dimension, nf90_close, & + NF90_MAX_NAME, NF90_NOWRITE + use netcdf_unlimdims, only: pf_nf90_inq_unlimdims + + implicit none + +#ifdef USE_MPI +! We don't use this option here, and setting it will cause problems +! with ncdc_util.F90, so let's unset it. +#undef USE_MPI +#endif + + integer(i_long) :: tmp_dim_size, i + character(len=NF90_MAX_NAME) :: tmp_dim_name + integer(i_long), dimension(:), allocatable :: unlim_dims + + call get_command_argument(0, prgm_name) + cli_arg_count = command_argument_count() + + if (cli_arg_count /= 1) & + call ncdc_error("Usage: " // trim(prgm_name) // " [input NetCDF4 file]") + + call get_command_argument(1, input_file) + + call ncdc_info("Opening NetCDF4 file: " // trim(input_file)) + + call ncdc_check(nf90_open(input_file, NF90_NOWRITE, ncid_input)) + + call ncdc_check(pf_nf90_inq_unlimdims(ncid_input, num_unlims)) + + write (*, "(A, I0)") "Number of unlimited dimensions: ", num_unlims + allocate(unlim_dims(num_unlims)) + + call ncdc_check(pf_nf90_inq_unlimdims(ncid_input, num_unlims, unlim_dims)) + + do i = 1, num_unlims + call ncdc_check(nf90_inquire_dimension(ncid_input, int(unlim_dims(i)), & + tmp_dim_name, tmp_dim_size)) + write (*, "(A, I0, A, I0, A)") " => Unlimited dimension | ID: ", unlim_dims(i), " | Size: ", tmp_dim_size, & + " | Name = " // trim(tmp_dim_name) + end do + + deallocate(unlim_dims) + call ncdc_check(nf90_close(ncid_input)) +end program test_nc_unlimdims diff --git a/src/ncepnems_io.f90 b/src/ncepnems_io.f90 deleted file mode 100644 index f5d27714f..000000000 --- a/src/ncepnems_io.f90 +++ /dev/null @@ -1,3545 +0,0 @@ -module ncepnems_io -!$$$ module documentation block -! . . . . -! module: ncepnems_io -! prgmmr: Huang org: np23 date: 2010-02-22 -! -! abstract: This module contains routines which handle input/output -! operations for NCEP NEMS global atmospheric and surface files. -! -! program history log: -! 2010-02-22 Huang Initial version. Based on ncepgfs_io -! 2010-10-18 Huang Remove subroutine reorder_gfsgrib for no longer been called in GSI -! For Now, subroutine sfc_interpolate is kept in ncepgfs_io.f90. -! When sigio and gfsio are both retired, i.e., remove ncepgfs_io.f90. -! move this routines back to this module -! 2011-03-03 Huang Changes has been made to adopt to high resolution GSI run (T382 & T574) -! both for CPU and memory issues. -! Future development of nemsio need to consider a mapping routine be -! inserted between read-in forecast field and GSI first guess field, -! as well as GSI analysis field and write-out data field for forecast -! model. Due to computation resource, GSI may not be able to run at -! the same resolution as that of forecast model, e.g., run GSI at T382 -! w/ T574 forecast model output. -! 2011-10-25 Huang (1) Add unified error message routine to make the code cleaner -! (2) To reduce the memory allocation as low as possible, remove all -! reference to sfc_head and re-used the same local arrays. -! Remove unneeded nemsio_data & gfsdata. -! (3) Add parallel IO code to read_atm_ -! 2011-11-01 Huang (1) add integer nst_gsi to control the mode of NSST -! (2) add read_nemsnst to read ncep nst file -! (3) add subroutine write_nemssfc_nst to save sfc and nst files -! 2016-01-01 Li (1) Move tran_gfssfc from ncepgfs_io.f90 to here -! (2) Modify write_sfc_nst_ to follows the update done in sfcio -! (3) Modify read_sfc_ to follows the update done in sfcio for more effective I/O -! 2016-04-20 Li Modify to handle the updated nemsio sig file (P, DP & DPDT removed) -! 2016-08-18 li - tic591: add read_sfc_anl & read_nemssfc_anl to read nemsio sfc file (isli only) with analysis resolution -! change/modify sfc_interpolate to be intrp22 to handle more general interpolation (2d to 2d) -! 2016-11-18 li - tic615: change nst mask name from slmsk to land -! 2017-08-30 li - tic659: modify read_nems_sfc_ and read_sfc_ to read sfc file in -! nemsio Gaussin grids generated by FV3 WriteComponent -! -! Subroutines Included: -! sub read_nems - driver to read ncep nems atmospheric and surface -! sub read_nems_chem -! sub read_nemsatm - read ncep nems atmospheric file, scatter -! on grid to analysis subdomains -! sub read_nemssfc - read ncep nems surface file, scatter on grid to -! analysis subdomains -! sub read_nemssfc_anl- read ncep EnKF nems surface file, scatter on grid to -! analysis subdomains -! sub write_nems - driver to write ncep nems atmospheric and surface -! analysis files -! sub write_nemsatm - gather on grid, write ncep nems atmospheric analysis file -! sub write_nemssfc - gather/write on grid ncep surface analysis file -! sub read_nemsnst - read ncep nst file, scatter on grid to analysis subdomains -! sub write_nems_sfc_nst - gather/write on grid ncep surface & nst analysis file -! sub intrp22 - interpolate from one grid to another grid (2D) -! sub read_nems_sfcnst - read sfc hist file, including sfc and nst vars, scatter on grid to analysis subdomains -! -! Variable Definitions: -! The difference of time Info between operational GFS IO (gfshead%, sfc_head%), -! analysis time (iadate), and NEMSIO (idate=) -! -! gfshead & sfc_head NEMSIO Header Analysis time (obsmod) -! =================== ============================ ========================== -! %idate(1) Hour idate(1) Year iadate(1) Year -! %idate(2) Month idate(2) Month iadate(2) Month -! %idate(3) Day idate(3) Day iadate(3) Day -! %idate(4) Year idate(4) Hour iadate(4) Hour -! idate(5) Minute iadate(5) Minute -! idate(6) Scaled seconds -! idate(7) Seconds multiplier -! -! The difference of header forecasting hour Info bewteen operational GFS IO -! (gfshead%, sfc_head%) and NEMSIO -! -! gfshead & sfc_head NEMSIO Header -! ========================== ============================ -! %fhour FCST Hour (r_kind) nfhour FCST Hour (i_kind) -! nfminute FCST Mins (i_kind) -! nfsecondn FCST Secs (i_kind) numerator -! nfsecondd FCST Secs (i_kind) denominator -! -! %fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 -! -! nframe - nframe is the number of grids extend outward from the -! edge of modeling domain. -! -! NEMSIO provides a more flexible read. User can get the -! size of record (1D) to be read from file header. The -! normal record size should be delx*dely, i.e., total model -! grid points. However, some regional models also ouput -! additional data of grids around the modeling domain -! (buffer zone). For this type of output, nframe needs to -! be know to calculate the size of record, i.e., -! array size = (delx+2*nframe) * (dely+2*nframe) -! -! However, nframe should always be zero for global model. -! To simplify the code for reading and writing global model -! files, we will not factor in the nframe for computing -! array size or array index shift (by nframe) between -! input/output array and internal GSI array. The normal -! size of I/O record remains as delx*dely. Add a checking -! routine to assure nframe=zero. -! -! attributes: -! language: f90 -! machine: -! -! NOTE: When global meteorology switched to NEMS/GFS, all routines and -! modules of old GFS (sigio) can be deactivated. To keep the code -! clean, all "nems" can be replaced by "gfs" for minimal changes -! of GSI code structure. For dual purpose, two distincit routine -! names are used to accomodiate old and new systems. It is now -! controled by a namelist argument "use_gfs_nemsio" -! -! -!$$$ end documentation block - - use constants, only: zero,one,fv,r60,r3600 - implicit none - - private - public read_nems - public read_nems_chem - public read_nemsatm - public read_nemssfc - public read_nemssfc_anl - public write_nemsatm - public write_nemssfc - public read_nemsnst - public write_nems_sfc_nst - public intrp22 - public tran_gfssfc - public error_msg - - interface read_nems - module procedure read_ - end interface - - interface read_nems_chem - module procedure read_chem_ - end interface - - interface read_nemsatm - module procedure read_atm_ - end interface - - interface read_nemssfc - module procedure read_nemssfc_ - end interface - - interface read_nemssfc_anl - module procedure read_nemssfc_anl_ - end interface - - interface read_nemsnst - module procedure read_nemsnst_ - end interface - - interface write_nemsatm - module procedure write_atm_ - end interface - - interface write_nemssfc - module procedure write_sfc_ - end interface - - interface write_nems_sfc_nst - module procedure write_sfc_nst_ - end interface - - interface error_msg - module procedure error_msg_ - end interface - - character(len=*),parameter::myname='ncepnems_io' - -contains - - subroutine read_ -!$$$ subprogram documentation block -! . . . -! subprogram: read_nems -! -! prgrmmr: Ho-Chun Huang -! -! abstract: -! -! program history log: -! 2010-03-31 Huang - create routine based on read_gfs -! 2010-10-19 Huang - remove spectral part for gridded NEMS/GFS -! 2011-05-01 todling - cwmr no longer in guess-grids; use metguess bundle now -! 2013-10-19 todling - metguess now holds background -! 2016-03-30 todling - update interface to general read (pass bundle) -! 2016-06-23 Li - Add cloud partitioning, which was missed (based on GFS -! ticket #239, comment 18) -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - - use kinds, only: i_kind,r_kind - use gridmod, only: sp_a,grd_a,lat2,lon2,nsig - use guess_grids, only: ifilesig,nfldsig - use gsi_metguess_mod, only: gsi_metguess_bundle - use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_bundlemod, only: gsi_bundlecreate - use gsi_bundlemod, only: gsi_grid - use gsi_bundlemod, only: gsi_gridcreate - use gsi_bundlemod, only: gsi_bundle - use gsi_bundlemod, only: gsi_bundledestroy - use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info - use mpimod, only: npe,mype - use cloud_efr_mod, only: cloud_calc_gfs,set_cloud_lower_bound - implicit none - - character(len=*),parameter::myname_=myname//'*read_' - character(24) filename - integer(i_kind):: it, istatus, inner_vars, num_fields - integer(i_kind):: iret_ql,iret_qi - - real(r_kind),pointer,dimension(:,: ):: ges_ps_it =>NULL() - real(r_kind),pointer,dimension(:,: ):: ges_z_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_u_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_v_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_div_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_vor_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_tv_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_q_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_oz_it =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_cwmr_it=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_ql_it => NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_qi_it => NULL() - - type(sub2grid_info) :: grd_t - logical regional - logical:: l_cld_derived,zflag,inithead - - type(gsi_bundle) :: atm_bundle - type(gsi_grid) :: atm_grid - integer(i_kind),parameter :: n2d=2 - integer(i_kind),parameter :: n3d=8 - character(len=4), parameter :: vars2d(n2d) = (/ 'z ', 'ps ' /) - character(len=4), parameter :: vars3d(n3d) = (/ 'u ', 'v ', & - 'vor ', 'div ', & - 'tv ', 'q ', & - 'cw ', 'oz ' /) - real(r_kind),pointer,dimension(:,:):: ptr2d =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ptr3d =>NULL() - - regional=.false. - inner_vars=1 - num_fields=min(8*grd_a%nsig+2,npe) -! Create temporary communication information fore read routines - call general_sub2grid_create_info(grd_t,inner_vars,grd_a%nlat,grd_a%nlon, & - grd_a%nsig,num_fields,regional) - -! Allocate bundle used for reading members - call gsi_gridcreate(atm_grid,lat2,lon2,nsig) - call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d) - if(istatus/=0) then - write(6,*) myname_,': trouble creating atm_bundle' - call stop2(999) - endif - - do it=1,nfldsig - - write(filename,'(''sigf'',i2.2)') ifilesig(it) - -! Read background fields into bundle - call general_read_gfsatm_nems(grd_t,sp_a,filename,.true.,.true.,.true.,& - atm_bundle,.true.,istatus) - - inithead=.false. - zflag=.false. - -! Set values to actual MetGuess fields - call set_guess_ - - l_cld_derived = associated(ges_cwmr_it).and.& - associated(ges_q_it) .and.& - associated(ges_ql_it) .and.& - associated(ges_qi_it) .and.& - associated(ges_tv_it) -! call set_cloud_lower_bound(ges_cwmr_it) - if (mype==0) write(6,*)'READ_GFS_NEMS: l_cld_derived = ', l_cld_derived - - if (l_cld_derived) then - call cloud_calc_gfs(ges_ql_it,ges_qi_it,ges_cwmr_it,ges_q_it,ges_tv_it,.true.) - end if - - end do - call general_sub2grid_destroy_info(grd_t) - call gsi_bundledestroy(atm_bundle,istatus) - - contains - - subroutine set_guess_ - - call gsi_bundlegetpointer (atm_bundle,'ps',ptr2d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'ps',ges_ps_it ,istatus) - if(istatus==0) ges_ps_it = ptr2d - endif - call gsi_bundlegetpointer (atm_bundle,'z',ptr2d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'z' ,ges_z_it ,istatus) - if(istatus==0) ges_z_it = ptr2d - endif - call gsi_bundlegetpointer (atm_bundle,'u',ptr3d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'u' ,ges_u_it ,istatus) - if(istatus==0) ges_u_it = ptr3d - endif - call gsi_bundlegetpointer (atm_bundle,'v',ptr3d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'v' ,ges_v_it ,istatus) - if(istatus==0) ges_v_it = ptr3d - endif - call gsi_bundlegetpointer (atm_bundle,'vor',ptr3d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'vor',ges_vor_it,istatus) - if(istatus==0) ges_vor_it = ptr3d - endif - call gsi_bundlegetpointer (atm_bundle,'div',ptr3d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'div',ges_div_it,istatus) - if(istatus==0) ges_div_it = ptr3d - endif - call gsi_bundlegetpointer (atm_bundle,'tv',ptr3d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'tv',ges_tv_it ,istatus) - if(istatus==0) ges_tv_it = ptr3d - endif - call gsi_bundlegetpointer (atm_bundle,'q',ptr3d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'q' ,ges_q_it ,istatus) - if(istatus==0) ges_q_it = ptr3d - endif - call gsi_bundlegetpointer (atm_bundle,'oz',ptr3d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'oz',ges_oz_it ,istatus) - if(istatus==0) ges_oz_it = ptr3d - endif - call gsi_bundlegetpointer (atm_bundle,'cw',ptr3d,istatus) - if (istatus==0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'cw',ges_cwmr_it,istatus) - if(istatus==0) ges_cwmr_it = ptr3d - endif - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'ql',ges_ql_it, iret_ql) - call gsi_bundlegetpointer (gsi_metguess_bundle(it),'qi',ges_qi_it, iret_qi) - if (iret_ql/=0) then - if (mype==0) write(6,*)'READ_ NEMSIO: cannot get pointer to ql,iret_ql=',iret_ql - endif - if (iret_qi/=0) then - if (mype==0) write(6,*)'READ_ NEMSIO: cannot get pointer to qi,iret_qi=',iret_qi - endif - - end subroutine set_guess_ - - end subroutine read_ - - subroutine read_chem_ ( iyear, month,idd ) -!$$$ subprogram documentation block -! . . . -! subprogram: read_nems_chem -! -! prgrmmr: todling -! -! abstract: fills chemguess_bundle with GFS chemistry. -! -! remarks: -! 1. Right now, only CO2 is done and even this is treated -! as constant througout the assimialation window. -! 2. iyear and month could come from obsmod, but logically -! this program should never depend on obsmod -! -! -! program history log: -! 2010-12-23 Huang - initial code, based on read_gfs_chem -! 2011-06-29 todling - no explict reference to internal bundle arrays -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - - use kinds, only: i_kind, r_kind - use mpimod, only: mype - use gridmod, only: lat2,lon2,nsig,nlat,rlats,istart - use ncepgfs_ghg, only: read_gfsco2 - use guess_grids, only: nfldsig - use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_chemguess_mod, only: gsi_chemguess_bundle - use gsi_chemguess_mod, only: gsi_chemguess_get - - implicit none - -! Declared argument list - integer(i_kind), intent(in):: iyear - integer(i_kind), intent(in):: month - integer(i_kind), intent(in):: idd - -! Declare local variables - integer(i_kind) :: igfsco2, i, j, n, iret - real(r_kind),dimension(lat2):: xlats - real(r_kind),pointer,dimension(:,:,:)::p_co2=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ptr3d=>NULL() - - if(.not.associated(gsi_chemguess_bundle)) return - call gsi_bundlegetpointer(gsi_chemguess_bundle(1),'co2',p_co2,iret) - if(iret /= 0) return - -! Get subdomain latitude array - j = mype + 1 - do i = 1, lat2 - n = min(max(1, istart(j)+i-2), nlat) - xlats(i) = rlats(n) - enddo - -! Read in CO2 - call gsi_chemguess_get ( 'i4crtm::co2', igfsco2, iret ) - call read_gfsco2 ( iyear,month,idd,igfsco2,xlats,& - lat2,lon2,nsig,mype, p_co2 ) - -! Approximation: setting all times co2 values equal to the daily co2 values - - do n = 2, nfldsig - call gsi_bundlegetpointer(gsi_chemguess_bundle(n),'co2',ptr3d,iret) - ptr3d = p_co2 - enddo - - end subroutine read_chem_ - - subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & - g_z,g_ps,g_vor,g_div,g_u,g_v,& - g_tv,g_q,g_cwmr,g_oz) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_nemsatm read nems atm and send to all mpi tasks -! prgmmr: Huang org: np23 date: 2010-02-22 -! -! abstract: read ncep nems/gfs atmospheric guess field and -! scatter to subdomains -! -! program history log: -! 2010-02-22 Huang Initial version. Based on sub read_gfsatm -! 2011-02-28 Huang Re-arrange the read sequence to be same as model -! write sequence. Alsom allocate and deallocate -! temporary working array immediatelt before and after -! the processing and scattering first guess field to reduce -! maximum resident memory size. Page fault can happen -! when running at high resolution GSI, e.g., T574. -! 2011-09-23 Huang Add NEMS parallel IO capability -! 2013-10-25 todling reposition fill_ns,filluv_ns to commvars -! -! input argument list: -! grd - structure variable containing information about grid -! (initialized by general_sub2grid_create_info, located in -! general_sub2grid_mod.f90) -! sp_a - structure variable containing spectral information for analysis -! (initialized by general_init_spec_vars, located in -! general_specmod.f90) -! uvflag - logical to use u,v (.true.) or st,vp (.false.) perturbations -! vordivflag - logical to determine if routine should output vorticity and -! divergence -! zflag - logical to determine if surface height field should be output -! -! output argument list: -! g_* - guess fields -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,i_kind - use gridmod, only: ntracer,ncloud,reload,itotsub - use general_commvars_mod, only: fill_ns,filluv_ns,fill2_ns,filluv2_ns,ltosj_s,ltosi_s - use general_specmod, only: spec_vars - use general_sub2grid_mod, only: sub2grid_info - use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype,mype - use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close - use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv - use egrid2agrid_mod,only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid - use constants, only: two,pi,half,deg2rad - use control_vectors, only: imp_physics - implicit none - -! Declare local parameters - real(r_kind),parameter:: r0_001 = 0.001_r_kind - -! Declare passed variables - type(sub2grid_info) ,intent(in ) :: grd - character(len=24) ,intent(in ) :: filename - logical ,intent(in ) :: uvflag,vordivflag,zflag - real(r_kind),dimension(grd%lat2,grd%lon2) ,intent( out) :: g_z,g_ps - real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent( out) :: g_u,g_v,& - g_vor,g_div,g_cwmr,g_q,g_oz,g_tv - type(spec_vars) ,intent(in ) :: sp_a - -! Declare local variables - character(len=120) :: my_name = 'READ_NEMSATM' - character(len=1) :: null = ' ' - integer(i_kind),dimension(7):: idate - integer(i_kind),dimension(4):: odate - integer(i_kind) :: iret,nlatm2,nflds - integer(i_kind) :: k,icount,icount_prev,mm1,i,j,kk - integer(i_kind) :: mype_hs, mype_ps,nord_int - integer(i_kind) :: latb, lonb, levs, nframe - integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd - integer(i_kind) :: istop = 101 - real(r_kind),allocatable,dimension(:,:) :: grid, grid_v, & - grid_vor, grid_div, grid_b, grid_b2 - real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid2, grid_c2 - real(r_kind),allocatable,dimension(:) :: work, work_vor, work_div, & - work_v - real(r_kind),allocatable,dimension(:,:) :: sub, sub_vor, sub_div, & - sub_v - real(r_kind),dimension(sp_a%nc):: spec_vor,spec_div - real(r_kind),allocatable,dimension(:) :: rwork1d0, rwork1d1, rwork1d2 - real(r_kind),allocatable,dimension(:) :: rlats,rlons,clons,slons - real(4),allocatable,dimension(:) :: r4lats,r4lons - real(r_kind) :: fhour - type(nemsio_gfile) :: gfile - logical diff_res,eqspace - logical,dimension(1) :: vector - type(egrid2agrid_parm) :: p_high - -!****************************************************************************** -! Initialize variables used below - mm1=mype+1 - mype_hs=min(1,npe-1) - mype_ps=0 - nlatm2=grd%nlat-2 - nflds=5*grd%nsig+1 - if(zflag) nflds=nflds+1 - if(vordivflag .or. .not. uvflag)nflds=nflds+2*grd%nsig -! nflds=npe - nflds=grd%nsig - levs=grd%nsig - - allocate( work(grd%itotsub),work_v(grd%itotsub) ) - work=zero - work_v=zero - allocate( sub(grd%lat2*grd%lon2,max(grd%nsig,npe)),sub_v(grd%lat2*grd%lon2,max(grd%nsig,npe)) ) - allocate( sub_div(grd%lat2*grd%lon2,max(grd%nsig,npe)),sub_vor(grd%lat2*grd%lon2,max(grd%nsig,npe)) ) - if(mype < nflds)then - - call nemsio_init(iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'init',istop,iret) - - call nemsio_open(gfile,filename,'READ',iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop+1,iret) - - call nemsio_getfilehead(gfile,iret=iret, nframe=nframe, & - nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & - idate=idate, dimx=lonb, dimy=latb,dimz=levs) - - if( nframe /= 0 ) then - if ( mype == 0 ) & - write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe - call stop2(101) - end if - - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 - odate(1) = idate(4) !hour - odate(2) = idate(2) !month - odate(3) = idate(3) !day - odate(4) = idate(1) !year -! -! g_* array already pre-allocate as (lat2,lon2,) => 2D and <3D> array -! - diff_res=.false. - if(latb /= nlatm2) then - diff_res=.true. - if ( mype == 0 ) write(6, & - '(a,'': different spatial dimension nlatm2 = '',i4,tr1,''latb = '',i4)') & - trim(my_name),nlatm2,latb - ! call stop2(101) - end if - if(lonb /= grd%nlon) then - diff_res=.true. - if ( mype == 0 ) write(6, & - '(a,'': different spatial dimension nlon = '',i4,tr1,''lonb = '',i4)') & - trim(my_name),grd%nlon,lonb - ! call stop2(101) - end if - if(levs /= grd%nsig)then - if ( mype == 0 ) write(6, & - '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & - trim(my_name),grd%nsig,levs - call stop2(101) - end if -! - allocate( grid(grd%nlon,nlatm2), grid_v(grd%nlon,nlatm2) ) - if(diff_res)then - allocate( grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid2(grd%nlat,grd%nlon,1)) - allocate( grid_b2(lonb,latb),grid_c2(latb+2,lonb,1)) - end if - allocate( rwork1d0(latb*lonb) ) - allocate( rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) - allocate(rwork1d1(latb*lonb)) - call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) - call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) - do j=1,latb - rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) - end do - do j=1,lonb - rlons(j)=deg2rad*r4lons(j) - end do - deallocate(r4lats,r4lons) - rlats(1)=-half*pi - rlats(latb+2)=half*pi - do j=1,lonb - clons(j)=cos(rlons(j)) - slons(j)=sin(rlons(j)) - end do - - nord_int=4 - eqspace=.false. - call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons, & - latb+2,rlats,lonb,rlons,& - nord_int,p_high,.true.,eqspace) - deallocate(rlats,rlons) - end if -! -! Load values into rows for south and north pole before scattering -! -! Terrain: scatter to all mpi tasks -! - if(zflag)then - if (mype==mype_hs) then - call nemsio_readrecv(gfile,'hgt', 'sfc',1,rwork1d0,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','read',istop+2,iret) - if(diff_res)then - grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) - end do - else - grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) - call fill_ns(grid,work) - end if - endif - call mpi_scatterv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& - g_z,grd%ijn_s(mm1),mpi_rtype,mype_hs,mpi_comm_world,ierror) - end if - -! Surface pressure: same procedure as terrain, but handled by task mype_ps -! - if (mype==mype_ps) then - call nemsio_readrecv(gfile,'pres','sfc',1,rwork1d0,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pres','read',istop+3,iret) - rwork1d1 = r0_001*rwork1d0 - if(diff_res)then - vector(1)=.false. - grid_b=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) - end do - else - grid=reshape(rwork1d1,(/size(grid,1),size(grid,2)/)) ! convert Pa to cb - call fill_ns(grid,work) - endif - endif - call mpi_scatterv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& - g_ps,grd%ijn_s(mm1),mpi_rtype,mype_ps,mpi_comm_world,ierror) - -! Divergence and voriticity. Compute u and v from div and vor - sub_vor=zero - sub_div=zero - sub =zero - sub_v =zero - icount =0 - icount_prev=1 - allocate( work_vor(grd%itotsub),work_div(grd%itotsub) ) - do k=1,levs - icount=icount+1 - if (mype==mod(icount-1,npe)) then - ! Convert grid u,v to div and vor - call nemsio_readrecv(gfile,'ugrd','mid layer',k,rwork1d0,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','read',istop+4,iret) - call nemsio_readrecv(gfile,'vgrd','mid layer',k,rwork1d1,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','read',istop+5,iret) - if(diff_res)then - grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) - grid_b2=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) - end do - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - end do - end do - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - end do - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - end do - end do - else - grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) - grid_v=reshape(rwork1d1,(/size(grid_v,1),size(grid_v,2)/)) - call filluv_ns(grid,grid_v,work,work_v) - end if - - if(vordivflag .or. .not. uvflag)then - - allocate( grid_vor(grd%nlon,nlatm2), grid_div(grd%nlon,nlatm2) ) - call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) - call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) - call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) - - ! Load values into rows for south and north pole - call fill_ns(grid_div,work_div) - call fill_ns(grid_vor,work_vor) - deallocate(grid_vor,grid_div) - end if - endif - ! Scatter to sub - if (mod(icount,npe)==0 .or. icount==levs) then - if(vordivflag .or. .not. uvflag)then - call mpi_alltoallv(work_vor,grd%ijn_s,grd%displs_s,mpi_rtype,& - sub_vor(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& - mpi_comm_world,ierror) - call mpi_alltoallv(work_div,grd%ijn_s,grd%displs_s,mpi_rtype,& - sub_div(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& - mpi_comm_world,ierror) - end if - if(uvflag)then - call mpi_alltoallv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& - sub(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& - mpi_comm_world,ierror) - call mpi_alltoallv(work_v,grd%ijn_s,grd%displs_s,mpi_rtype,& - sub_v(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& - mpi_comm_world,ierror) - end if - icount_prev=icount+1 - endif - end do - deallocate(work_vor,work_div) - - ! Transfer vor,div,u,v into real(r_kind) guess arrays - call reload(sub_vor,g_vor) - call reload(sub_div,g_div) - call reload(sub,g_u) - call reload(sub_v,g_v) - deallocate(sub_vor,sub_div) - -! Thermodynamic variable and Specific humidity: communicate to all tasks -! - sub=zero - icount=0 - icount_prev=1 - do k=1,levs - icount=icount+1 - if (mype==mod(icount-1,npe)) then - - call nemsio_readrecv(gfile,'spfh','mid layer',k,rwork1d0,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','read',istop+6,iret) - if(diff_res)then - grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) - end do - else - grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) - call fill_ns(grid,work) - end if - - call nemsio_readrecv(gfile,'tmp','mid layer',k,rwork1d1,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop+7,iret) - allocate(rwork1d2(latb*lonb)) - rwork1d2 = rwork1d1*(one+fv*rwork1d0) - if(diff_res)then - grid_b=reshape(rwork1d2,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - end do - else - grid_v=reshape(rwork1d2,(/size(grid_v,1),size(grid_v,2)/)) - call fill_ns(grid_v,work_v) - end if - - deallocate(rwork1d2) - endif - - if (mod(icount,npe)==0 .or. icount==levs) then - call mpi_alltoallv(work_v,grd%ijn_s,grd%displs_s,mpi_rtype,& - sub_v(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& - mpi_comm_world,ierror) - call mpi_alltoallv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& - sub(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& - mpi_comm_world,ierror) - icount_prev=icount+1 - endif - end do - call reload(sub_v,g_tv) - call reload(sub,g_q) - deallocate(sub_v,work_v) - - sub=zero - icount=0 - icount_prev=1 - do k=1,levs - icount=icount+1 - if (mype==mod(icount-1,npe)) then - call nemsio_readrecv(gfile,'o3mr','mid layer',k,rwork1d0,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','read',istop+8,iret) - if(diff_res)then - grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) - end do - else - grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) - call fill_ns(grid,work) - end if - endif - if (mod(icount,npe)==0 .or. icount==levs) then - call mpi_alltoallv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& - sub(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& - mpi_comm_world,ierror) - icount_prev=icount+1 - endif - end do - call reload(sub,g_oz) - -! Cloud condensate mixing ratio. - - if (ntracer>2 .or. ncloud>=1) then - sub=zero - icount=0 - icount_prev=1 - do k=1,levs - icount=icount+1 - if (mype==mod(icount-1,npe)) then - call nemsio_readrecv(gfile,'clwmr','mid layer',k,rwork1d0,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','read',istop+9,iret) - if (imp_physics == 11) then - call nemsio_readrecv(gfile,'icmr','mid layer',k,rwork1d1,iret=iret) - if (iret == 0) then - rwork1d0 = rwork1d0 + rwork1d1 - else - call error_msg(trim(my_name),trim(filename),'icmr','read',istop+10,iret) - endif - endif - if(diff_res)then - grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,itotsub - i=ltosi_s(kk) - j=ltosj_s(kk) - work(kk)=grid2(i,j,1) - end do - else - grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/)) - call fill_ns(grid,work) - end if - - endif - if (mod(icount,npe)==0 .or. icount==levs) then - call mpi_alltoallv(work,grd%ijn_s,grd%displs_s,mpi_rtype,& - sub(1,icount_prev),grd%irc_s,grd%ird_s,mpi_rtype,& - mpi_comm_world,ierror) - icount_prev=icount+1 - endif - end do - call reload(sub,g_cwmr) - else - g_cwmr = zero - endif - - if(mype < nflds)then - if(diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2) - call destroy_egrid2agrid(p_high) - deallocate(rwork1d1,clons,slons) - deallocate(rwork1d0) - deallocate(grid,grid_v) - call nemsio_close(gfile,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop+9,iret) - end if - deallocate(work,sub) - -! Print date/time stamp - if ( mype == 0 ) write(6, & - '(a,'': ges read/scatter,lonb,latb,levs= '',3i6,'',hour= '',f4.1,'',idate= '',4i5)') & - trim(my_name),lonb,latb,levs,fhour,odate - - end subroutine read_atm_ - - subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & - veg_type,soil_type,terrain,isli,use_sfc_any, & - tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_sfc_ read nems hist file -! prgmmr: Li org: np23 date: 2017-08-30 -! -! abstract: read nems sfc & nst combined file -! -! program history log: -! -! input argument list: -! use_sfc_any - true if any processor uses extra surface fields -! -! output argument list: -! sfct - surface temperature (skin temp) -! soil_moi - soil moisture of first layer -! sno - snow depth -! soil_temp - soil temperature of first layer -! veg_frac - vegetation fraction -! fact10 - 10 meter wind factor -! sfc_rough - surface roughness -! veg_type - vegetation type -! soil_type - soil type -! terrain - terrain height -! isli - sea/land/ice mask -! tref - optional, oceanic foundation temperature -! dt_cool - optional, sub-layer cooling amount at sub-skin layer -! z_c - optional, depth of sub-layer cooling layer -! dt_warm - optional, diurnal warming amount at sea surface -! z_w - optional, depth of diurnal warming layer -! c_0 - optional, coefficient to calculate d(Tz)/d(tr) in dimensionless -! c_d - optional, coefficient to calculate d(Tz)/d(tr) in m^-1 -! w_0 - optional, coefficient to calculate d(Tz)/d(tr) in dimensionless -! w_d - optional, coefficient to calculate d(Tz)/d(tr) in m^-1 - -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpimod, only: mype - use kinds, only: r_kind,i_kind,r_single - use gridmod, only: nlat_sfc,nlon_sfc - use guess_grids, only: nfldsfc,ifilesfc - use constants, only: zero,two - use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close - use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv - implicit none - -! Declare passed variables - logical, intent(in) :: use_sfc_any - real(r_single), dimension(nlat_sfc,nlon_sfc,nfldsfc), intent(out) :: sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough - real(r_single), dimension(nlat_sfc,nlon_sfc), intent(out) :: veg_type,soil_type,terrain - integer(i_kind), dimension(nlat_sfc,nlon_sfc), intent(out) :: isli - real(r_single), optional, dimension(nlat_sfc,nlon_sfc,nfldsfc), intent(out) :: tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d - -! Declare local parameters - integer(i_kind), parameter :: nsfc_all=11 - integer(i_kind),dimension(7):: idate - integer(i_kind),dimension(4):: odate -! Declare local variables - real(r_single), dimension(nlat_sfc,nlon_sfc,nfldsfc) :: xt - character(len=24) :: filename - character(len=120) :: my_name = 'READ_SFCNST' - character(len=1) :: null = ' ' - integer(i_kind) :: i,j,it,n,nsfc - integer(i_kind) :: iret, nframe, lonb, latb - integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd - real(r_single) :: fhour - integer(i_kind) :: istop = 102 - real(r_single), allocatable, dimension(:) :: rwork2d - real(r_single), allocatable, dimension(:,:) :: work,outtmp -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Define read variable property !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - type(nemsio_gfile) :: gfile -!----------------------------------------------------------------------------- - call nemsio_init(iret=iret) - if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) - - do it = 1, nfldsfc -! read a surface history file on the task - write(filename,200)ifilesfc(it) -200 format('sfcf',i2.2) - - call nemsio_open(gfile,filename,'READ',iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) - - call nemsio_getfilehead(gfile, idate=idate, iret=iret, nframe=nframe, & - nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & - dimx=lonb, dimy=latb ) - - if( nframe /= 0 ) then - if ( mype == 0 ) & - write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global sfc hist read, nframe = ', nframe - call stop2(102) - end if - - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 - odate(1) = idate(4) !hour - odate(2) = idate(2) !month - odate(3) = idate(3) !day - odate(4) = idate(1) !year - - if ( (latb /= nlat_sfc-2) .or. (lonb /= nlon_sfc) ) then - if ( mype == 0 ) write(6, & - '(a,'': inconsistent spatial dimension '',''nlon,nlatm2 = '',2(i4,tr1),''-vs- sfc file lonb,latb = '',i4)') & - trim(my_name),nlon_sfc,nlat_sfc-2,lonb,latb - call stop2(102) - endif -! -! Read the surface records (lonb, latb) and convert to GSI array pattern (nlat_sfc,nlon_sfc) -! Follow the read order sfcio in ncepgfs_io -! - allocate(work(lonb,latb)) - allocate(rwork2d(size(work,1)*size(work,2))) - work = zero - rwork2d = zero - - if(it == 1)then - nsfc=nsfc_all - else - nsfc=nsfc_all-4 - end if - - do n = 1, nsfc - - if (n == 1) then ! skin temperature - -! Tsea - call nemsio_readrecv(gfile, 'tmp', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,sfct(1,1,it),lonb,latb) - - elseif(n == 2 .and. use_sfc_any) then ! soil moisture - -! smc/soilw - call nemsio_readrecv(gfile, 'smc', 'soil layer', 1, rwork2d, iret=iret) - ! FV3 nemsio files use 'soilw 0-10cm down' insted of 'smc soil layer 1' - if (iret /= 0) then - if ( mype == 0 ) print *,'could not read smc, try to read soilw 0-10 cm down instead...' - call nemsio_readrecv(gfile,'soilw','0-10 cm down',1,rwork2d,iret=iret) - if (iret /= 0) & - call error_msg(trim(my_name),trim(filename),'smc/soilw','read',istop,iret) - endif - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,soil_moi(1,1,it),lonb,latb) - - elseif(n == 3) then ! snow depth - -! sheleg - call nemsio_readrecv(gfile, 'weasd','sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'weasd','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,sno(1,1,it),lonb,latb) - - elseif(n == 4 .and. use_sfc_any) then ! soil temperature - -! stc/tmp - call nemsio_readrecv(gfile, 'stc', 'soil layer', 1, rwork2d, iret=iret) - if (iret /= 0) then - ! FV3 nemsio files use 'tmp 0-10cm down' insted of 'stc soil layer 1' - if ( mype == 0 ) print *,'could not read stc, try to read tmp 0-10 cm down instead...' - call nemsio_readrecv(gfile,'tmp','0-10 cm down',1,rwork2d,iret=iret) - if (iret /= 0) & - call error_msg(trim(my_name),trim(filename),'stc/tmp','read',istop,iret) - endif - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,soil_temp(1,1,it),lonb,latb) - - elseif(n == 5 .and. use_sfc_any) then ! vegetation cover - -! vfrac - call nemsio_readrecv(gfile, 'veg', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'veg','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,veg_frac(1,1,it),lonb,latb) - - elseif(n == 6) then ! 10m wind factor - -! f10m - call nemsio_readrecv(gfile, 'f10m', '10 m above gnd', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'f10m','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,fact10(1,1,it),lonb,latb) - - elseif(n == 7) then ! suface roughness - -! zorl - call nemsio_readrecv(gfile, 'sfcr', 'sfc', 1, rwork2d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'sfcr','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,sfc_rough(1,1,it),lonb,latb) - - elseif(n == 8 .and. use_sfc_any) then ! vegetation type - -! vtype - call nemsio_readrecv(gfile, 'vtype','sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vtype','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,veg_type,lonb,latb) - - elseif(n == 9 .and. use_sfc_any) then ! soil type - -! stype - call nemsio_readrecv(gfile, 'sotyp','sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'sotyp','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,soil_type,lonb,latb) - - elseif(n == 10) then ! terrain - -! orog - call nemsio_readrecv(gfile, 'orog', 'sfc', 1, rwork2d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'orog','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,terrain,lonb,latb) - - elseif(n == 11) then ! sea/land/ice flag - -! slmsk - call nemsio_readrecv(gfile, 'land', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'land','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - allocate(outtmp(latb+2,lonb)) - call tran_gfssfc(work,outtmp,lonb,latb) - do j=1,lonb - do i=1,latb+2 - isli(i,j) = nint(outtmp(i,j)) - end do - end do - deallocate(outtmp) - - endif -! End of loop over data records - enddo - - if( present(tref) ) then - if ( mype == 0 ) write(6,*) ' read 9 optional NSST variables ' - - call nemsio_readrecv(gfile, 'tref', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tref','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,tref(1,1,it),lonb,latb) - - call nemsio_readrecv(gfile, 'dtcool','sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dtcool','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,dt_cool(1,1,it),lonb,latb) - - call nemsio_readrecv(gfile, 'zc', 'sfc', 1, rwork2d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'z_c','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,z_c(1,1,it),lonb,latb) - - call nemsio_readrecv(gfile, 'xt', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'xt','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,xt(1,1,it),lonb,latb) - - call nemsio_readrecv(gfile, 'xz', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'xz','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,z_w(1,1,it),lonb,latb) - - call nemsio_readrecv(gfile, 'c0', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'c0','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,c_0(1,1,it),lonb,latb) - - call nemsio_readrecv(gfile, 'cd', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'cd','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,c_d(1,1,it),lonb,latb) - - call nemsio_readrecv(gfile, 'w0', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'w0','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,w_0(1,1,it),lonb,latb) - - call nemsio_readrecv(gfile, 'wd', 'sfc', 1, rwork2d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'wd','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,w_d(1,1,it),lonb,latb) -! -! Get diurnal warming amout at z=0 -! - do j = 1,nlon_sfc - do i = 1,nlat_sfc - if (z_w(i,j,it) > zero) then - dt_warm(i,j,it) = two*xt(i,j,it)/z_w(i,j,it) - end if - end do - end do - endif -! Deallocate local work arrays - deallocate(work,rwork2d) - - call nemsio_close(gfile,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) -! -! Print date/time stamp - if ( mype == 0 ) write(6, & - '(a,'': sfc read,nlon,nlat= '',2i6,'',hour= '',f4.1,'',idate= '',4i5)') & - trim(my_name),lonb,latb,fhour,odate -! End of loop over time levels - end do - end subroutine read_sfc_ - - subroutine read_nemssfc_(iope,sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & - veg_type,soil_type,terrain,isli,use_sfc_any, & - tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_nemssfc_ read nems hist file -! prgmmr: xuli org: np23 date: 2017-08-30 -! -! abstract: read nems surface file -! -! program history log: -! 2017-08-30 li -! -! input argument list: -! iope - mpi task handling i/o -! use_sfc_any - true if any processor uses extra surface fields -! -! output argument list: -! sfct - surface temperature (skin temp) -! soil_moi - soil moisture of first layer -! sno - snow depth -! soil_temp - soil temperature of first layer -! veg_frac - vegetation fraction -! fact10 - 10 meter wind factor -! sfc_rough - surface roughness -! veg_type - vegetation type -! soil_type - soil type -! terrain - terrain height -! isli - sea/land/ice mask -! tref - oceanic foundation temperature -! dt_cool - optional, sub-layer cooling amount at sub-skin layer -! z_c - optional, depth of sub-layer cooling layer -! dt_warm - optional, diurnal warming amount at sea surface -! z_w - optional, depth of diurnal warming layer -! c_0 - optional, coefficient to calculate d(Tz)/d(tf) -! c_d - optional, coefficient to calculate d(Tz)/d(tf) -! w_0 - optional, coefficient to calculate d(Tz)/d(tf) -! w_d - optional, coefficient to calculate d(Tz)/d(tf) -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,i_kind,r_single - use gridmod, only: nlat_sfc,nlon_sfc - use guess_grids, only: nfldsfc,sfcmod_mm5,sfcmod_gfs - use gsi_nstcouplermod, only: nst_gsi - use mpimod, only: mpi_itype,mpi_rtype4,mpi_comm_world,mype - use constants, only: zero - implicit none - -! Declare passed variables - integer(i_kind), intent(in) :: iope - logical, intent(in) :: use_sfc_any - real(r_single), dimension(nlat_sfc,nlon_sfc,nfldsfc), intent(out) :: sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough - real(r_single), dimension(nlat_sfc,nlon_sfc), intent(out) :: veg_type,soil_type,terrain - integer(i_kind), dimension(nlat_sfc,nlon_sfc), intent(out) :: isli - real(r_single), optional, dimension(nlat_sfc,nlon_sfc,nfldsfc), intent(out) :: tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d - -! Declare local variables - integer(i_kind):: iret,npts,nptsall - -!----------------------------------------------------------------------------- -! Read surface history file on processor iope - if(mype == iope)then - if ( present(tref) ) then - call read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & - veg_type,soil_type,terrain,isli,use_sfc_any, & - tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) - write(*,*) 'read_sfc nemsio, with NSST variables' - else - call read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & - veg_type,soil_type,terrain,isli,use_sfc_any) - write(*,*) 'read_sfc nemsio, without NSST variables' - endif - endif - -! Load onto all processors - - npts=nlat_sfc*nlon_sfc - nptsall=npts*nfldsfc - - call mpi_bcast(sfct, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(fact10, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(sno, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - if(sfcmod_mm5 .or. sfcmod_gfs)then - call mpi_bcast(sfc_rough, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - else - sfc_rough = zero - endif - call mpi_bcast(terrain, npts, mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(isli, npts, mpi_itype, iope,mpi_comm_world,iret) - if(use_sfc_any)then - call mpi_bcast(veg_frac, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(soil_temp,nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(soil_moi, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(veg_type, npts, mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(soil_type,npts, mpi_rtype4,iope,mpi_comm_world,iret) - endif - if ( present(tref) ) then - call mpi_bcast(tref, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(dt_cool, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(z_c, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(dt_warm, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(z_w, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(c_0, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(c_d, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(w_0, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(w_d, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - endif - - end subroutine read_nemssfc_ - - subroutine read_sfc_anl_(isli_anl) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_sfc_anl_ read nems surface file with analysis resolution -! -! prgmmr: li org: np23 date: 2016-08-18 -! -! abstract: read nems surface file at analysis grids when nlon /= nlon_sfc or nlat /= nlat_sfc -! -! program history log: -! -! input argument list: -! -! output argument list: -! isli - sea/land/ice mask -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpimod, only: mype - use kinds, only: r_kind,i_kind,r_single - use gridmod, only: nlat,nlon - use constants, only: zero - use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close - use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv - implicit none - -! Declare passed variables - integer(i_kind), dimension(nlat,nlon), intent( out) :: isli_anl - -! Declare local parameters - integer(i_kind),dimension(7):: idate - integer(i_kind),dimension(4):: odate - - -! Declare local variables - character(len=24) :: filename - character(len=120) :: my_name = 'READ_NEMSSFC_ANL' - character(len=1) :: null = ' ' - integer(i_kind) :: i,j - integer(i_kind) :: iret, nframe, lonb, latb - integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd - real(r_single) :: fhour - integer(i_kind) :: istop = 102 - real(r_single), allocatable, dimension(:) :: rwork2d - real(r_single), allocatable, dimension(:,:) :: work,outtmp - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Define read variable property !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - type(nemsio_gfile) :: gfile -!----------------------------------------------------------------------------- - - call nemsio_init(iret=iret) - if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) - - - filename='sfcf06_anlgrid' - call nemsio_open(gfile,trim(filename),'READ',iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) - - call nemsio_getfilehead(gfile, idate=idate, iret=iret, nframe=nframe, & - nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & - dimx=lonb, dimy=latb ) - - if( nframe /= 0 ) then - if ( mype == 0 ) & - write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe - call stop2(102) - end if - - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 - odate(1) = idate(4) !hour - odate(2) = idate(2) !month - odate(3) = idate(3) !day - odate(4) = idate(1) !year - - if ( (latb /= nlat-2) .or. (lonb /= nlon) ) then - if ( mype == 0 ) write(6, & - '(a,'': inconsistent spatial dimension '',''nlon,nlatm2 = '',2(i4,tr1),''-vs- sfc file lonb,latb = '',i4)') & - trim(my_name),nlon,nlat-2,lonb,latb - call stop2(102) - endif -! -! Read the surface records (lonb, latb) and convert to GSI array pattern (nlat,nlon) -! Follow the read order sfcio in ncepgfs_io -! - allocate(work(lonb,latb)) - allocate(rwork2d(size(work,1)*size(work,2))) - work = zero - rwork2d = zero - -! slmsk - call nemsio_readrecv(gfile, 'land', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'land','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - allocate(outtmp(latb+2,lonb)) - call tran_gfssfc(work,outtmp,lonb,latb) - do j=1,lonb - do i=1,latb+2 - isli_anl(i,j) = nint(outtmp(i,j)) - end do - end do - deallocate(outtmp) - -! Deallocate local work arrays - deallocate(work,rwork2d) - - call nemsio_close(gfile,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) -! -! Print date/time stamp - if ( mype == 0 ) write(6, & - '(a,'': read_sfc_anl_ ,nlon,nlat= '',2i6,'',hour= '',f4.1,'',idate= '',4i5)') & - trim(my_name),lonb,latb,fhour,odate - end subroutine read_sfc_anl_ - - subroutine read_nemssfc_anl_(iope,isli_anl) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_nemssfc_anl read nems surface guess file with analysis resolution -! -! prgmmr: xuli org: np23 date: 2016-08-18 -! -! abstract: read nems surface file at analysis grids -! -! program history log: -! -! input argument list: -! iope - mpi task handling i/o -! -! output argument list: -! isli - sea/land/ice mask -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,i_kind,r_single - use gridmod, only: nlat,nlon - use mpimod, only: mpi_itype,mpi_comm_world,mype - implicit none - -! Declare passed variables - integer(i_kind), intent(in ) :: iope - integer(i_kind), dimension(nlat,nlon), intent( out) :: isli_anl - - -! Declare local variables - integer(i_kind):: iret,npts - -!----------------------------------------------------------------------------- -! Read surface file on processor iope - if(mype == iope)then - call read_sfc_anl_(isli_anl) - write(*,*) 'read_sfc nemsio' - end if - -! Load onto all processors - npts=nlat*nlon - call mpi_bcast(isli_anl,npts,mpi_itype,iope,mpi_comm_world,iret) - - end subroutine read_nemssfc_anl_ - - subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) - -!$$$ subprogram documentation block -! . . . . -! subprogram: read_nst_ read nems nst surface guess file (quadratic -! Gaussin grids) without scattering to tasks -! prgmmr: Huang org: np23 date: 2011-11-01 -! -! abstract: read nems surface NST file -! -! program history log: -! 2011-11-01 Huang Initial version based on sub read_gfsnst -! 2016-03-13 Li Modify for more effective I/O -! -! input argument list: -! -! output argument list: -! tref (:,:) ! oceanic foundation temperature -! dt_cool (:,:) ! sub-layer cooling amount at sub-skin layer -! z_c (:,:) ! depth of sub-layer cooling layer -! dt_warm (:,:) ! diurnal warming amount at sea surface (skin layer) -! z_w (:,:) ! depth of diurnal warming layer -! c_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) -! c_d (:,:) ! coefficient to calculate d(Tz)/d(tr) -! w_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) -! w_d (:,:) ! coefficient to calculate d(Tz)/d(tr) -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,i_kind,r_single - use mpimod, only: mype - use gridmod, only: nlat_sfc,nlon_sfc - use constants, only: zero,two - use guess_grids, only: nfldnst,ifilenst - use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close - use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv - implicit none - -! Declare passed variables - real(r_single) , dimension(nlat_sfc,nlon_sfc,nfldnst), intent( out) :: & - tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d -! Declare local parameters - integer(i_kind),parameter :: n_nst=9 - integer(i_kind),dimension(7) :: idate - integer(i_kind),dimension(4) :: odate - -! Declare local variables - character(len=6) :: filename - character(len=120) :: my_name = 'READ_NEMSNST' - character(len=1) :: null = ' ' - integer(i_kind) :: i,j,it,latb,lonb - integer(i_kind) :: iret, nframe - integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd - integer(i_kind) :: istop = 103 - real(r_single) :: fhour - real(r_single), dimension(nlat_sfc,nlon_sfc,nfldnst) :: xt - real(r_single), allocatable, dimension(:) :: rwork2d - real(r_single), allocatable, dimension(:,:) :: work - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Define read variable property !!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - type(nemsio_gfile) :: gfile -!----------------------------------------------------------------------------- - - call nemsio_init(iret=iret) - if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) - - - do it=1,nfldnst -! read a nst file on the task - write(filename,200)ifilenst(it) -200 format('nstf',i2.2) - call nemsio_open(gfile,trim(filename),'READ',iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) - - call nemsio_getfilehead(gfile, idate=idate, iret=iret, nframe=nframe, & - nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & - dimx=lonb, dimy=latb ) - - if( nframe /= 0 ) then - if ( mype == 0 ) & - write(6,*)trim(my_name),': ***ERROR*** nframe /= 0 for global model read, nframe = ', nframe - call stop2(istop) - end if - - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 - odate(1) = idate(4) !hour - odate(2) = idate(2) !month - odate(3) = idate(3) !day - odate(4) = idate(1) !year - - if ( (latb /= nlat_sfc-2) .or. (lonb /= nlon_sfc) ) then - if ( mype == 0 ) & - write(6,'(a,'': inconsistent spatial dimension nlon,nlatm2 = '',2(i4,tr1),''-vs- sfc file lonb,latb = '',i4)') & - trim(my_name),nlon_sfc,nlat_sfc-2,lonb,latb - call stop2(80) - endif -! -! Load surface fields into local work array -! Follow NEMS/GFS sfcf read order -! - allocate(work(lonb,latb)) - allocate(rwork2d(size(work,1)*size(work,2))) - work = zero - rwork2d = zero - -! Tref - call nemsio_readrecv(gfile, 'tref', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tref','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,tref(1,1,it),lonb,latb) - -! dt_cool - call nemsio_readrecv(gfile, 'dtcool','sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dt_cool','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,dt_cool(1,1,it),lonb,latb) - -! z_c - call nemsio_readrecv(gfile, 'zc', 'sfc', 1, rwork2d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'z_c','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,z_c(1,1,it),lonb,latb) - -! xt - call nemsio_readrecv(gfile, 'xt', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'xt','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,xt(1,1,it),lonb,latb) - -! xz - call nemsio_readrecv(gfile, 'xz', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'xz','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,z_w(1,1,it),lonb,latb) -! -! c_0 - call nemsio_readrecv(gfile, 'c0', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'c_0','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,c_0(1,1,it),lonb,latb) - -! c_d - call nemsio_readrecv(gfile, 'cd', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'c_d','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,c_d(1,1,it),lonb,latb) - -! w_0 - call nemsio_readrecv(gfile, 'w0', 'sfc', 1, rwork2d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'w_0','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,w_0(1,1,it),lonb,latb) - -! w_d - call nemsio_readrecv(gfile, 'wd', 'sfc', 1, rwork2d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'w_d','read',istop,iret) - work(:,:)=reshape(rwork2d(:),(/size(work,1),size(work,2)/)) - call tran_gfssfc(work,w_d(1,1,it),lonb,latb) - -! -! Get diurnal warming amout at z=0 -! - do j = 1,nlon_sfc - do i = 1,nlat_sfc - if (z_w(i,j,it) > zero) then - dt_warm(i,j,it) = two*xt(i,j,it)/z_w(i,j,it) - end if - end do - end do - -! Deallocate local work arrays - deallocate(work,rwork2d) - - call nemsio_close(gfile,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) -! End of loop over time levels - end do - end subroutine read_nst_ - - - subroutine read_nemsnst_ (iope,tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) - -!$$$ subprogram documentation block -! . . . . -! subprogram: read_nems_nst -! prgmmr: li org: np23 date: 2016-03-13 -! -! abstract: read nems nst fields from a specific task and then broadcast to others -! -! input argument list: -! iope - mpi task handling i/o -! -! output argument list: -! tref (:,:) ! oceanic foundation temperature -! dt_cool (:,:) ! sub-layer cooling amount at sub-skin layer -! z_c (:,:) ! depth of sub-layer cooling layer -! dt_warm (:,:) ! diurnal warming amount at sea surface -! z_w (:,:) ! depth of diurnal warming layer -! c_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) in dimensionless -! c_d (:,:) ! coefficient to calculate d(Tz)/d(tr) in m^-1 -! w_0 (:,:) ! coefficient to calculate d(Tz)/d(tr) in dimensionless -! w_d (:,:) ! coefficient to calculate d(Tz)/d(tr) in m^-1 -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,i_kind,r_single - use gridmod, only: nlat_sfc,nlon_sfc - use guess_grids, only: nfldnst - use mpimod, only: mpi_itype,mpi_rtype4,mpi_comm_world - use mpimod, only: mype - use constants, only: zero - implicit none - -! Declare passed variables - integer(i_kind), intent(in ) :: iope - real(r_single), dimension(nlat_sfc,nlon_sfc,nfldnst), intent( out) :: & - tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d - -! Declare local variables - integer(i_kind):: iret,npts,nptsall - -!----------------------------------------------------------------------------- -! Read nst file on processor iope - if(mype == iope)then - write(*,*) 'read_nst nemsio' - call read_nst_(tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) - end if - -! Load onto all processors - - npts=nlat_sfc*nlon_sfc - nptsall=npts*nfldnst - - call mpi_bcast(tref, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(dt_cool, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(z_c, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(dt_warm, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(z_w, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(c_0, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(c_d, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(w_0, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - call mpi_bcast(w_d, nptsall,mpi_rtype4,iope,mpi_comm_world,iret) - - end subroutine read_nemsnst_ - - - subroutine write_atm_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) - -!$$$ subprogram documentation block -! . . . -! subprogram: write_nemsatm --- Gather, transform, and write out -! -! prgmmr: Huang org: np23 date: 2010-02-22 -! -! abstract: This routine gathers fields needed for the GSI analysis -! file from subdomains and then transforms the fields from -! analysis grid to model guess grid, then written to an -! atmospheric analysis file. -! -! program history log: -! 2010-02-22 Huang Initial version. Based on write_gfsatm -! 2011-02-14 Huang Re-arrange the write sequence to be same as model -! read/rite sequence. -! 2013-10-25 todling reposition load_grid to commvars -! 2016-07-28 mahajan update with bundling ability -! -! input argument list: -! filename - file to open and write to -! mype_out - mpi task to write output file -! gfs_bundle - bundle containing fields on subdomains -! ibin - time bin -! -! output argument list: -! -! attributes: -! language: f90 -! machines: ibm RS/6000 SP; SGI Origin 2000; Compaq HP -! -!$$$ end documentation block - -! !USES: - use kinds, only: r_kind,i_kind - - use constants, only: r1000,fv,one,zero,qcmin,r0_05,t0c - - use mpimod, only: mpi_rtype - use mpimod, only: mpi_comm_world - use mpimod, only: ierror - use mpimod, only: mype - - use guess_grids, only: ifilesig - use guess_grids, only: ges_prsl,ges_prsi - use guess_grids, only: load_geop_hgt,geop_hgti - - use gridmod, only: ntracer - use gridmod, only: ncloud - use gridmod, only: strip,jcap_b,bk5 - - use general_commvars_mod, only: load_grid,fill2_ns,filluv2_ns - use general_specmod, only: spec_vars - - use obsmod, only: iadate - - use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_init,& - nemsio_getfilehead,nemsio_close,nemsio_writerecv,nemsio_readrecv - use gsi_4dvar, only: ibdate,nhr_obsbin,lwrite4danl - use general_sub2grid_mod, only: sub2grid_info - use egrid2agrid_mod,only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid - use constants, only: two,pi,half,deg2rad - use gsi_bundlemod, only: gsi_bundle - use gsi_bundlemod, only: gsi_bundlegetpointer - use control_vectors, only: imp_physics,lupp - use cloud_efr_mod, only: cloud_calc_gfs - - implicit none - -! !INPUT PARAMETERS: - - type(sub2grid_info), intent(in) :: grd - type(spec_vars), intent(in) :: sp_a - character(len=24), intent(in) :: filename ! file to open and write to - integer(i_kind), intent(in) :: mype_out ! mpi task to write output file - type(gsi_bundle), intent(in) :: gfs_bundle - integer(i_kind), intent(in) :: ibin ! time bin - -!------------------------------------------------------------------------- - - real(r_kind),parameter:: r0_001 = 0.001_r_kind - character(6):: fname_ges - character(len=120) :: my_name = 'WRITE_NEMSATM' - character(len=1) :: null = ' ' - integer(i_kind),dimension(7):: idate, jdate - integer(i_kind),dimension(4):: odate - integer(i_kind) :: k, mm1, nlatm2, nord_int, i, j, kk - integer(i_kind) :: iret, lonb, latb, levs, istatus - integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd - integer(i_kind) :: istop = 104 - integer(i_kind),dimension(5):: mydate - integer(i_kind),dimension(8) :: ida,jda - real(r_kind),dimension(5) :: fha - real(r_kind) :: fhour - - real(r_kind),pointer,dimension(:,:) :: sub_ps - real(r_kind),pointer,dimension(:,:,:) :: sub_u,sub_v,sub_tv - real(r_kind),pointer,dimension(:,:,:) :: sub_q,sub_oz,sub_cwmr - - !real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig) :: sub_cwl,sub_cwi - real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig) :: sub_dzb,sub_dza - real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig) :: sub_prsl - real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig+1) :: sub_prsi - real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig+1,ibin) :: ges_geopi - - real(r_kind),dimension(grd%lat1*grd%lon1) :: psm - real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig):: sub_dp - real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: tvsm,prslm, usm, vsm - real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: dpsm, qsm, ozsm - real(r_kind),dimension(grd%lat1*grd%lon1,grd%nsig):: cwsm, dzsm - real(r_kind),dimension(max(grd%iglobal,grd%itotsub)) :: work1,work2 - real(r_kind),dimension(grd%nlon,grd%nlat-2):: grid - real(r_kind),allocatable,dimension(:) :: rwork1d,rwork1d1,rlats,rlons,clons,slons - real(4),allocatable,dimension(:) :: r4lats,r4lons - real(r_kind),allocatable,dimension(:,:) :: grid_b,grid_b2 - real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid3, grid_c2, grid3b - - type(nemsio_gfile) :: gfile,gfileo - logical diff_res,eqspace - logical,dimension(1) :: vector - type(egrid2agrid_parm) :: p_low,p_high - -!************************************************************************* -! Initialize local variables - mm1=mype+1 - nlatm2=grd%nlat-2 - diff_res=.false. - - istatus=0 - call gsi_bundlegetpointer(gfs_bundle,'ps', sub_ps, iret); istatus=istatus+iret - call gsi_bundlegetpointer(gfs_bundle,'u', sub_u, iret); istatus=istatus+iret - call gsi_bundlegetpointer(gfs_bundle,'v', sub_v, iret); istatus=istatus+iret - call gsi_bundlegetpointer(gfs_bundle,'tv', sub_tv, iret); istatus=istatus+iret - call gsi_bundlegetpointer(gfs_bundle,'q', sub_q, iret); istatus=istatus+iret - call gsi_bundlegetpointer(gfs_bundle,'oz', sub_oz, iret); istatus=istatus+iret - call gsi_bundlegetpointer(gfs_bundle,'cw', sub_cwmr,iret); istatus=istatus+iret - if ( istatus /= 0 ) then - if ( mype == 0 ) then - write(6,*) 'write_atm_: ERROR' - write(6,*) 'Missing some of the required fields' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - - if ( sp_a%jcap /= jcap_b ) then - if ( mype == 0 ) write(6, & - '('' dual resolution for nems sp_a%jcap,jcap_b = '',2i6)') & - sp_a%jcap,jcap_b - diff_res = .true. - endif - - - ! Single task writes analysis data to analysis file - if ( mype == mype_out ) then - write(fname_ges,'(''sigf'',i2.2)') ifilesig(ibin) - - ! Read header information from first guess file. - call nemsio_init(iret) - if ( iret /= 0 ) call error_msg(trim(my_name),null,null,'init',istop,iret) - - call nemsio_open(gfile,trim(fname_ges),'read',iret) - if ( iret /= 0 ) call error_msg(trim(my_name),trim(fname_ges),null,'open',istop,iret) - - call nemsio_getfilehead(gfile, iret=iret, nfhour=nfhour, & - nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, & - idate=idate, dimx=lonb, dimy=latb, dimz=levs) - if ( iret /= 0 ) then - write(6,*) trim(my_name),': problem with nemsio_getfilehead, Status = ',iret - call stop2(103) - endif - if ( levs /= grd%nsig ) then - write(6,*) trim(my_name),': problem in data dimension background levs = ',levs,' nsig = ',grd%nsig - call stop2(103) - endif - - ! copy input header info to output header info - gfileo=gfile - - ! Update header information (with ibdate) and write it to analysis file (w/ _open statement). - mydate=ibdate - fha(:)=zero ; ida=0; jda=0 - fha(2)=real(nhr_obsbin*(ibin-1)) ! relative time interval in hours - ida(1)=mydate(1) ! year - ida(2)=mydate(2) ! month - ida(3)=mydate(3) ! day - ida(4)=0 ! time zone - ida(5)=mydate(4) ! hour - - ! Move date-time forward by nhr_assimilation hours - call w3movdat(fha,ida,jda) - - jdate(1) = jda(1) ! analysis year - jdate(2) = jda(2) ! analysis month - jdate(3) = jda(3) ! analysis day - jdate(4) = jda(5) ! analysis hour - jdate(5) = iadate(5) ! analysis minute - jdate(6) = 0 ! analysis scaled seconds - jdate(7) = idate(7) ! analysis seconds multiplier - - nfhour =0 ! new forecast hour, zero at analysis time - nfminute =0 - nfsecondn=0 - nfsecondd=100 ! default for denominator - - fhour = zero - odate(1) = jdate(4) !hour - odate(2) = jdate(2) !month - odate(3) = jdate(3) !day - odate(4) = jdate(1) !year - - ! open new output file with new header gfileo with "write" access. - ! Use this call to update header as well - - call nemsio_open(gfileo,trim(filename),'write',iret=iret, & - idate=jdate, nfhour=nfhour, nfminute=nfminute, & - nfsecondn=nfsecondn, nfsecondd=nfsecondd) - if ( iret /= 0 ) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) - - ! Allocate structure arrays to hold data - allocate(rwork1d(latb*lonb),rwork1d1(latb*lonb)) - if (imp_physics == 11) allocate(grid3b(grd%nlat,grd%nlon,1)) - if ( diff_res .or. imp_physics == 11 .or. lupp) then - allocate( grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid3(grd%nlat,grd%nlon,1)) - allocate( grid_b2(lonb,latb),grid_c2(latb+2,lonb,1)) - allocate( rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb)) - call nemsio_getfilehead(gfile,lat=r4lats,iret=iret) - call nemsio_getfilehead(gfile,lon=r4lons,iret=iret) - do j=1,latb - rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb) - enddo - rlats(1)=-half*pi - rlats(latb+2)=half*pi - do j=1,lonb - rlons(j)=deg2rad*r4lons(j) - enddo - do j=1,lonb - clons(j)=cos(rlons(j)) - slons(j)=sin(rlons(j)) - enddo - - nord_int=4 - eqspace=.false. - call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons, & - latb+2,rlats,lonb,rlons,& - nord_int,p_low,.false.,eqspace=eqspace) - call g_create_egrid2agrid(latb+2,rlats,lonb,rlons, & - grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons,& - nord_int,p_high,.false.,eqspace=eqspace) - - deallocate(rlats,rlons,r4lats,r4lons) - endif ! if ( diff_res ) - - ! Terrain - ! Write out input file surface height - - call nemsio_readrecv(gfile,'hgt', 'sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','writeread',istop,iret) - call nemsio_writerecv(gfileo,'hgt','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'hgt','write',istop,iret) - endif ! if ( mype == mype_out ) - - sub_prsl = ges_prsl(:,:,:,ibin) - sub_prsi = ges_prsi(:,:,:,ibin) - - do k=1,grd%nsig - sub_dp(:,:,k) = sub_prsi(:,:,k) - sub_prsi(:,:,k+1) - end do - - ! Calculate delz increment for UPP - if (lupp) then - if ((.not. lwrite4danl) .or. ibin == 1) ges_geopi = geop_hgti - do k=1,grd%nsig - sub_dzb(:,:,k) = ges_geopi(:,:,k+1,ibin) - ges_geopi(:,:,k,ibin) - enddo - - if ((.not. lwrite4danl) .or. ibin == 1) call load_geop_hgt - do k=1,grd%nsig - sub_dza(:,:,k) = geop_hgti(:,:,k+1,ibin) - geop_hgti(:,:,k,ibin) - enddo - - sub_dza = sub_dza - sub_dzb !sub_dza is increment - endif - - ! Strip off boundary points from subdomains - call strip(sub_ps ,psm) - call strip(sub_tv ,tvsm ,grd%nsig) - call strip(sub_q ,qsm ,grd%nsig) - call strip(sub_oz ,ozsm ,grd%nsig) - call strip(sub_cwmr,cwsm ,grd%nsig) - call strip(sub_dp ,dpsm ,grd%nsig) - call strip(sub_prsl,prslm ,grd%nsig) - call strip(sub_u ,usm ,grd%nsig) - call strip(sub_v ,vsm ,grd%nsig) - if (lupp) call strip(sub_dza ,dzsm ,grd%nsig) - - ! Thermodynamic variable - ! The GSI analysis variable is virtual temperature (Tv). For NEMSIO - ! output we need the sensible temperature. - - ! Convert Tv to T - tvsm = tvsm/(one+fv*qsm) - - ! Generate and write analysis fields - - ! Surface pressure. - call mpi_gatherv(psm,grd%ijn(mm1),mpi_rtype,& - work1,grd%ijn,grd%displs_g,mpi_rtype,& - mype_out,mpi_comm_world,ierror) - if (mype==mype_out) then - if(diff_res .or. lupp)then - call nemsio_readrecv(gfile,'pres','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'pres','read',istop,iret) - rwork1d1 = r0_001*rwork1d - grid_b=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work1(kk)-grid3(i,j,1) - if (lupp) work1(kk)=grid3(i,j,1) - end do - if (lupp) then - do k=1,grd%nsig - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work1(kk)*(bk5(k)-bk5(k+1)) - enddo - call g_egrid2agrid(p_high,grid3,grid_c2,1,1,vector) - call nemsio_readrecv(gfile,'dpres','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dpres','read',istop,iret) - grid_b2=reshape(rwork1d,(/size(grid_b2,1),size(grid_b2,2)/)) - do j=1,latb - do i=1,lonb - grid_b2(i,j)=grid_b2(i,j)+r1000*(grid_c2(latb-j+2,i,1)) - enddo - enddo - rwork1d = reshape(grid_b2,(/size(rwork1d)/)) - call nemsio_writerecv(gfileo,'dpres','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dpres','write',istop,iret) - enddo - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work1(kk) - enddo - endif - call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) - do j=1,latb - do i=1,lonb - grid_b(i,j)=r1000*(grid_b(i,j)+grid_c(latb-j+2,i,1)) - end do - end do - rwork1d = reshape(grid_b,(/size(rwork1d)/)) - else - call load_grid(work1,grid) - grid = grid*r1000 - rwork1d = reshape(grid,(/size(rwork1d)/)) - end if - call nemsio_writerecv(gfileo,'pres','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'psfc','write',istop,iret) - endif - -! u, v - do k=1,grd%nsig - call mpi_gatherv(usm(1,k),grd%ijn(mm1),mpi_rtype,& - work1,grd%ijn,grd%displs_g,mpi_rtype,& - mype_out,mpi_comm_world,ierror) - call mpi_gatherv(vsm(1,k),grd%ijn(mm1),mpi_rtype,& - work2,grd%ijn,grd%displs_g,mpi_rtype,& - mype_out,mpi_comm_world,ierror) - if (mype==mype_out) then - if(diff_res)then - call nemsio_readrecv(gfile,'ugrd','mid layer',k,rwork1d,iret=iret) - call nemsio_readrecv(gfile,'vgrd','mid layer',k,rwork1d1,iret=iret) - grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) - grid_b2=reshape(rwork1d1,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work1(kk)-grid3(i,j,1) - end do - call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) - do j=1,latb - do i=1,lonb - grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) - end do - end do - call g_egrid2agrid(p_low,grid_c2,grid3,1,1,vector) - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work2(kk)-grid3(i,j,1) - end do - call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) - do j=1,latb - do i=1,lonb - grid_b2(i,j)=grid_b2(i,j)+grid_c(latb-j+2,i,1) - end do - end do - rwork1d = reshape(grid_b,(/size(rwork1d)/)) - rwork1d1 = reshape(grid_b2,(/size(rwork1d1)/)) - - else - call load_grid(work1,grid) - rwork1d = reshape(grid,(/size(rwork1d)/)) - call load_grid(work2,grid) - rwork1d1 = reshape(grid,(/size(rwork1d1)/)) - end if - - ! Zonal wind - call nemsio_writerecv(gfileo,'ugrd','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'ugrd','write',istop,iret) - ! Meridional wind - call nemsio_writerecv(gfileo,'vgrd','mid layer',k,rwork1d1,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'vgrd','write',istop,iret) - endif - end do - -! Thermodynamic variable - do k=1,grd%nsig - call mpi_gatherv(tvsm(1,k),grd%ijn(mm1),mpi_rtype,& - work1,grd%ijn,grd%displs_g,mpi_rtype,& - mype_out,mpi_comm_world,ierror) - if (mype == mype_out) then - if(diff_res)then - call nemsio_readrecv(gfile,'tmp','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop,iret) - grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work1(kk)-grid3(i,j,1) - end do - call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) - do j=1,latb - do i=1,lonb - grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) - end do - end do - rwork1d = reshape(grid_b,(/size(rwork1d)/)) - else - call load_grid(work1,grid) - rwork1d = reshape(grid,(/size(rwork1d)/)) - end if - call nemsio_writerecv(gfileo,'tmp','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','write',istop,iret) - endif - end do - -! Specific humidity - do k=1,grd%nsig - call mpi_gatherv(qsm(1,k),grd%ijn(mm1),mpi_rtype,& - work1,grd%ijn,grd%displs_g,mpi_rtype,& - mype_out,mpi_comm_world,ierror) - if (mype == mype_out) then - if(diff_res)then - call nemsio_readrecv(gfile,'spfh','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','read',istop,iret) - grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work1(kk)-grid3(i,j,1) - end do - call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) - do j=1,latb - do i=1,lonb - grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) - end do - end do - rwork1d = reshape(grid_b,(/size(rwork1d)/)) - else - call load_grid(work1,grid) - rwork1d = reshape(grid,(/size(rwork1d)/)) - end if - call nemsio_writerecv(gfileo,'spfh','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'spfh','write',istop,iret) - endif - end do - -! Ozone - do k=1,grd%nsig - call mpi_gatherv(ozsm(1,k),grd%ijn(mm1),mpi_rtype,& - work1,grd%ijn,grd%displs_g,mpi_rtype,& - mype_out,mpi_comm_world,ierror) - if (mype == mype_out) then - if(diff_res)then - call nemsio_readrecv(gfile,'o3mr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','read',istop,iret) - grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work1(kk)-grid3(i,j,1) - end do - call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) - do j=1,latb - do i=1,lonb - grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) - end do - end do - rwork1d = reshape(grid_b,(/size(rwork1d)/)) - else - call load_grid(work1,grid) - rwork1d = reshape(grid,(/size(rwork1d)/)) - end if - call nemsio_writerecv(gfileo,'o3mr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'o3mr','write',istop,iret) - endif - end do - -! Cloud condensate mixing ratio - if (ntracer>2 .or. ncloud>=1) then - - do k=1,grd%nsig - call mpi_gatherv(cwsm(1,k),grd%ijn(mm1),mpi_rtype,& - work1,grd%ijn,grd%displs_g,mpi_rtype,& - mype_out,mpi_comm_world,ierror) - if (imp_physics == 11) then - call mpi_gatherv(tvsm(1,k),grd%ijn(mm1),mpi_rtype,& - work2,grd%ijn,grd%displs_g,mpi_rtype,& - mype_out,mpi_comm_world,ierror) - endif - if (mype == mype_out) then - if(diff_res .or. imp_physics == 11)then - call nemsio_readrecv(gfile,'clwmr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','read',istop,iret) - grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) - if (imp_physics == 11) then - call nemsio_readrecv(gfile,'icmr','mid layer',k,rwork1d1,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','read',istop,iret) - grid_b2=reshape(rwork1d1,(/size(grid_b2,1),size(grid_b2,2)/)) - grid_b = grid_b + grid_b2 - endif - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_low,grid_c,grid3,1,1,vector) - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work1(kk)-max(grid3(i,j,1),qcmin) - if (imp_physics == 11) then - work2(kk) = -r0_05*(work2(kk) - t0c) - work2(kk) = max(zero,work2(kk)) - work2(kk) = min(one,work2(kk)) - grid3b(i,j,1)=grid3(i,j,1) - grid3(i,j,1)=grid3b(i,j,1)*(one - work2(kk)) - endif - end do - call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) - if (imp_physics == 11) grid_b = grid_b - grid_b2 - do j=1,latb - do i=1,lonb - grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) - end do - end do - rwork1d = reshape(grid_b,(/size(rwork1d)/)) - if (imp_physics == 11) then - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=grid3b(i,j,1)*work2(kk) - end do - call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) - do j=1,latb - do i=1,lonb - grid_b2(i,j)=grid_b2(i,j)+grid_c(latb-j+2,i,1) - end do - end do - rwork1d1 = reshape(grid_b2,(/size(rwork1d1)/)) - endif - else - call load_grid(work1,grid) - rwork1d = reshape(grid,(/size(rwork1d)/)) - endif - call nemsio_writerecv(gfileo,'clwmr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'clwmr','write',istop,iret) - if (imp_physics == 11) then - call nemsio_writerecv(gfileo,'icmr','mid layer',k,rwork1d1,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'icmr','write',istop,iret) - - if (lupp) then - call nemsio_readrecv(gfile,'rwmr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','read',istop,iret) - call nemsio_writerecv(gfileo,'rwmr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'rwmr','write',istop,iret) - - call nemsio_readrecv(gfile,'snmr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','read',istop,iret) - call nemsio_writerecv(gfileo,'snmr','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'snmr','write',istop,iret) - - call nemsio_readrecv(gfile,'grle','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'grle','read',istop,iret) - call nemsio_writerecv(gfileo,'grle','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'grle','write',istop,iret) - endif - endif - endif !mype == mype_out - end do - endif !ntracer - -! Variables needed by the Unified Post Processor (dzdt, delz, delp) - if (lupp) then - if (mype == mype_out) then - do k=1,grd%nsig - call nemsio_readrecv(gfile,'dzdt','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dzdt','read',istop,iret) - call nemsio_writerecv(gfileo,'dzdt','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'dzdt','write',istop,iret) - enddo - endif - do k=1,grd%nsig - call mpi_gatherv(dzsm(1,k),grd%ijn(mm1),mpi_rtype,& - work1,grd%ijn,grd%displs_g,mpi_rtype,& - mype_out,mpi_comm_world,ierror) - if (mype == mype_out) then - call nemsio_readrecv(gfile,'delz','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'delz','read',istop,iret) - if(diff_res)then - grid_b=reshape(rwork1d,(/size(grid_b,1),size(grid_b,2)/)) - do kk=1,grd%iglobal - i=grd%ltosi(kk) - j=grd%ltosj(kk) - grid3(i,j,1)=work1(kk) - end do - call g_egrid2agrid(p_high,grid3,grid_c,1,1,vector) - do j=1,latb - do i=1,lonb - grid_b(i,j)=grid_b(i,j)+grid_c(latb-j+2,i,1) - end do - end do - rwork1d = reshape(grid_b,(/size(rwork1d)/)) - else - call load_grid(work1,grid) - rwork1d = rwork1d + reshape(grid,(/size(rwork1d)/)) - end if - call nemsio_writerecv(gfileo,'delz','mid layer',k,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'delz','write',istop,iret) - endif - end do - endif - -! -! Deallocate local array -! - if (mype==mype_out) then - if (diff_res .or. lupp .or. imp_physics == 11) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid3,clons,slons) - if (imp_physics == 11) deallocate(grid3b) - - call nemsio_close(gfile,iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),null,'close',istop,iret) - - call nemsio_close(gfileo,iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) -! -! Deallocate local array -! - deallocate(rwork1d,rwork1d1) -! - write(6,'(a,'': atm anal written for lonb,latb,levs= '',3i6,'',valid hour= '',f4.1,'',idate= '',4i5)') & - trim(my_name),lonb,latb,levs,fhour,odate - endif - - end subroutine write_atm_ - - subroutine write_sfc_ (filename,mype_sfc,dsfct) -!$$$ subprogram documentation block -! . . . -! subprogram: write_nemssfc --- Write surface analysis to file -! -! prgmmr: Huang org: np23 date: 2010-02-22 -! -! abstract: This routine writes the updated surface analysis. At -! this point (20101020) the only surface field update by -! the gsi is the skin temperature. The current (20101020) -! GDAS setup does use the updated surface file. Rather, -! the output from surface cycle is used as the surface -! analysis for subsequent NEMS/GFS runs. -! -! The routine gathers surface fields from subdomains, -! reformats the data records, and then writes each record -! to the output file. -! -! Since the gsi only update the skin temperature, all -! other surface fields are simply read from the guess -! surface file and written to the analysis file. -! -! program history log: -! 2010-02-22 Huang Initial version. Based on write_gfssfc -! 2011-04-01 Huang change type of buffer2, grid2 from single to r_kind -! 2013-10-25 todling - reposition ltosi and others to commvars -! -! input argument list: -! filename - file to open and write to -! dsfct - delta skin temperature -! mype_sfc - mpi task to write output file -! -! output argument list: -! -! attributes: -! language: f90 -! machines: ibm RS/6000 SP; SGI Origin 2000; Compaq HP -! -!$$$ end documentation block - -! !USES: - use kinds, only: r_kind,i_kind,r_single - - use mpimod, only: mpi_rtype - use mpimod, only: mpi_comm_world - use mpimod, only: ierror - use mpimod, only: mype - - use gridmod, only: nlat,nlon - use gridmod, only: lat1,lon1 - use gridmod, only: lat2,lon2 - use gridmod, only: iglobal - use gridmod, only: ijn - use gridmod, only: displs_g - use gridmod, only: itotsub - use gridmod, only: rlats,rlons,rlats_sfc,rlons_sfc - - use general_commvars_mod, only: ltosi,ltosj - - use obsmod, only: iadate - - use constants, only: zero - - use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close,nemsio_readrecv - use nemsio_module, only: nemsio_gfile,nemsio_getfilehead - use nemsio_module, only: nemsio_readrec, nemsio_writerec, nemsio_writerecv - - implicit none - -! !INPUT PARAMETERS: - character(24) ,intent(in ) :: filename ! file to open and write to - - real(r_kind),dimension(lat2,lon2),intent(in ) :: dsfct ! delta skin temperature - - integer(i_kind) ,intent(in ) :: mype_sfc ! mpi task to write output file - -! !OUTPUT PARAMETERS: - -!------------------------------------------------------------------------- - -! Declare local parameters - character( 6),parameter:: fname_ges='sfcf06' -! Declare local variables - character(len=120) :: my_name = 'WRITE_NEMSSFC' - character(len=1) :: null = ' ' - integer(i_kind),dimension(7):: idate, jdate - integer(i_kind),dimension(4):: odate - integer(i_kind) :: i, j, ip1, jp1, ilat, ilon, jj, mm1 - integer(i_kind) :: nlatm2, n, nrec, lonb, latb, iret - integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd - integer(i_kind) :: istop = 105 - real(r_kind) :: fhour - - real(r_kind),dimension(lat1,lon1):: sfcsub - real(r_kind),dimension(nlon,nlat):: grid - real(r_kind),dimension(max(iglobal,itotsub)):: sfcall - real(r_kind),allocatable,dimension(:,:) :: tsea - real(r_kind),allocatable,dimension(:) :: rwork1d - real(r_single),dimension(nlon,nlat):: buffer - real(r_single),allocatable,dimension(:,:) :: buffer2,grid2 - - type(nemsio_gfile) :: gfile, gfileo -!***************************************************************************** - -! Initialize local variables - mm1=mype+1 - nlatm2=nlat-2 - -! Gather skin temperature information from all tasks. - do j=1,lon1 - jp1 = j+1 - do i=1,lat1 - ip1 = i+1 - sfcsub(i,j)=dsfct(ip1,jp1) - end do - end do - call mpi_gatherv(sfcsub,ijn(mm1),mpi_rtype,& - sfcall,ijn,displs_g,mpi_rtype,mype_sfc,& - mpi_comm_world,ierror) - -! Only MPI task mype_sfc writes the surface file. - if (mype==mype_sfc) then - -! Reorder updated skin temperature to output format - do i=1,iglobal - ilon=ltosj(i) - ilat=ltosi(i) - grid(ilon,ilat)=sfcall(i) - end do - do j=1,nlat - jj=nlat-j+1 - do i=1,nlon - buffer(i,j)=grid(i,jj) - end do - end do - -! Read surface guess file - call nemsio_init(iret=iret) - if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) - - call nemsio_open(gfile,fname_ges,'read',iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),null,'open',istop,iret) -! - call nemsio_getfilehead(gfile, nrec=nrec, idate=idate, dimx=lonb, & - dimy=latb, nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, & - nfsecondd=nfsecondd, iret=iret) -! -! Replace header record date with analysis time from iadate -! - jdate(1) = iadate(1) ! analysis year - jdate(2) = iadate(2) ! analysis month - jdate(3) = iadate(3) ! analysis day - jdate(4) = iadate(4) ! analysis hour - jdate(5) = iadate(5) ! analysis minute - jdate(5) = 0 ! analysis minute - jdate(6) = 0 ! analysis scaled seconds - jdate(7) = idate(7) ! analysis seconds multiplier - - nfhour=0 ! new forecast hour, zero at analysis time - nfminute=0 - nfsecondn=0 - nfsecondd=100 ! default for denominator - - fhour = zero - odate(1) = jdate(4) !hour - odate(2) = jdate(2) !month - odate(3) = jdate(3) !day - odate(4) = jdate(1) !year -! -! Start to write output sfc file : filename -! open new output file with new header gfileo with "write" access. -! Use this call to update header as well -! -! - gfileo=gfile ! copy input header info to output header info - ! need to do this before nemsio_close(gfile) - call nemsio_open(gfileo,filename,'write',iret=iret, idate=jdate, nfhour=nfhour,& - nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd ) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop,iret) -! -! First copy entire data from fname_ges to filename, then do selective update -! - allocate(rwork1d(lonb*latb)) - allocate(buffer2(lonb,latb)) - allocate(grid2(lonb,latb)) - allocate(tsea(lonb,latb)) - - do n = 1, nrec - call nemsio_readrec (gfile, n,rwork1d,iret=iret) - if ( iret /= 0 ) write(6,*) 'readrec nrec = ', n, ' Status = ', iret - call nemsio_writerec(gfileo,n,rwork1d,iret=iret) - if ( iret /= 0 ) write(6,*) 'writerec nrec = ', n, ' Status = ', iret - end do -! -! Only sea surface temperature will be updated in the SFC files -! - - call nemsio_readrecv(gfile,'tmp','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),'tmp','read',istop,iret) - tsea=reshape(rwork1d,(/size(tsea,1),size(tsea,2)/)) - - if ( (latb /= nlatm2) .or. (lonb /= nlon) ) then - write(6,*)trim(my_name),': different grid dimensions analysis', & - ' vs sfc. interpolating sfc temperature nlon,nlat-2=',nlon, & - nlatm2,' -vs- sfc file lonb,latb=',lonb,latb - call intrp22(buffer, rlons,rlats,nlon,nlat, & - buffer2,rlons_sfc,rlats_sfc,lonb,latb) - else - do j=1,latb - do i=1,lonb - buffer2(i,j)=buffer(i,j+1) - end do - end do - endif - - grid2 = tsea + buffer2 - rwork1d = reshape( grid2,(/size(rwork1d)/) ) - - deallocate(buffer2) - -! update tsea record - call nemsio_writerecv(gfileo,'tmp','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','write',istop,iret) - deallocate(rwork1d) - - call nemsio_close(gfile, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_ges),null,'close',istop,iret) - - call nemsio_close(gfileo,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop,iret) - - write(6,'(a,'': sfc anal written for lonb,latb= '',2i6,'',valid hour= '',f4.1,'',idate= '',4i5)') & - trim(my_name),lonb,latb,fhour,odate - endif - end subroutine write_sfc_ - - subroutine write_sfc_nst_ (mype_so,dsfct) - -!$$$ subprogram documentation block -! . . . -! subprogram: write_sfc_nst --- Write both sfc and nst surface analysis to file -! -! prgmmr: Huang org: np23 date: 2011-11-01 -! -! abstract: This routine writes the sfc & nst analysis files and is nst_gsi dependent. -! Tr (foundation temperature), instead of skin temperature, is the analysis variable. -! nst_gsi > 2: Tr analysis is on -! nst_gsi <= 2: Tr analysis is off -! -! The routine gathers Tr field from subdomains, -! reformats the data records, and then writes each record -! to the output files. -! -! Since the gsi only update the Tr temperature, all -! other fields in surface are simply read from the guess -! files and written to the analysis file. -! -! program history log: -! 2011-11-01 Huang initial version based on routine write_gfs_sfc_nst -! 2013-10-25 todling - reposition ltosi and others to commvars -! 2016-01-01 li - update write_sfc_nst_ (nemsio) as for write_gfs_sfc_nst (sfcio) -! -! input argument list: -! dsfct - delta skin temperature -! mype_so - mpi task to write output file -! -! output argument list: -! -! attributes: -! language: f90 -! machines: ibm RS/6000 SP; SGI Origin 2000; Compaq HP -! -!$$$ end documentation block - -! !USES: - use kinds, only: r_kind,i_kind,r_single - - use mpimod, only: mpi_rtype,mpi_itype - use mpimod, only: mpi_comm_world - use mpimod, only: ierror - use mpimod, only: mype - - use gridmod, only: nlat,nlon - use gridmod, only: lat1,lon1 - use gridmod, only: lat2,lon2 - use gridmod, only: nlat_sfc,nlon_sfc - use gridmod, only: iglobal - use gridmod, only: ijn - use gridmod, only: displs_g - use gridmod, only: itotsub - - use general_commvars_mod, only: ltosi,ltosj - - use obsmod, only: iadate - - use constants, only: zero,two,tfrozen,z_w_max - use constants, only: zero_single - - use guess_grids, only: isli2 - use gsi_nstcouplermod, only: nst_gsi,zsea1,zsea2 - use gridmod, only: rlats,rlons,rlats_sfc,rlons_sfc - - use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close,nemsio_readrecv - use nemsio_module, only: nemsio_gfile,nemsio_getfilehead - use nemsio_module, only: nemsio_readrec, nemsio_writerec, nemsio_writerecv - - implicit none - -! !INPUT PARAMETERS: - - real(r_kind),dimension(lat2,lon2),intent(in ) :: dsfct ! delta skin temperature - integer(i_kind) ,intent(in ) :: mype_so ! mpi task to write output file - -! !OUTPUT PARAMETERS: - -!------------------------------------------------------------------------- - -! Declare local parameters - character(6), parameter:: fname_sfcges = 'sfcf06' - character(6), parameter:: fname_sfcgcy = 'sfcgcy' - character(6), parameter:: fname_sfctsk = 'sfctsk' - character(6), parameter:: fname_sfcanl = 'sfcanl' - character(6), parameter:: fname_nstges = 'nstf06' - character(6), parameter:: fname_nstanl = 'nstanl' - character(6), parameter:: fname_dtfanl = 'dtfanl' - -! Declare local variables - integer(i_kind), parameter:: io_dtfanl = 54 - integer(i_kind), parameter:: nprep=15 - real(r_kind),parameter :: houra = zero_single - character(len=120) :: my_name = 'WRITE_SFC_NST' - character(len=1) :: null = ' ' - integer(i_kind),dimension(7):: idate, jdate - integer(i_kind),dimension(4):: odate - integer(i_kind) :: i, j, ip1, jp1, ilat, ilon, mm1 - integer(i_kind) :: lonb, latb, nlatm2, n, nrec_sfc, nrec_nst, iret - integer(i_kind) :: lonb_nst, latb_nst - integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd - integer(i_kind) :: istop = 106 - real(r_kind) :: fhour - real(r_single) :: r_zsea1,r_zsea2 - - real(r_kind), dimension(lat1,lon1):: dsfct_sub - integer(i_kind), dimension(lat1,lon1):: isli_sub - - real(r_kind), dimension(max(iglobal,itotsub)):: dsfct_all - integer(i_kind), dimension(max(iglobal,itotsub)):: isli_all - - real(r_kind), dimension(nlat,nlon):: dsfct_glb,dsfct_tmp - integer(i_kind), dimension(nlat,nlon):: isli_glb,isli_tmp - - real(r_kind), dimension(nlat_sfc,nlon_sfc) :: dsfct_gsi - integer(i_kind), dimension(nlat_sfc,nlon_sfc) :: isli_gsi - - real(r_kind), dimension(nlon_sfc,nlat_sfc-2):: dsfct_anl - real(r_single), dimension(nlon_sfc,nlat_sfc-2):: dtzm - real(r_single), dimension(nlat_sfc,nlon_sfc) :: work - - real(r_single), allocatable, dimension(:,:) :: tsea,xt,xs,xu,xv,xz,zm,xtts,xzts,dt_cool,z_c, & - c_0,c_d,w_0,w_d,d_conv,ifd,tref,qrain - real(r_single), allocatable, dimension(:,:) :: slmsk_ges,slmsk_anl - real(r_single), allocatable, dimension(:) :: rwork1d - - type(nemsio_gfile) :: gfile_sfcges,gfile_sfcgcy,gfile_nstges,gfile_sfctsk,gfile_sfcanl,gfile_nstanl - -!***************************************************************************** - -! Initialize local variables - mm1=mype+1 - nlatm2=nlat-2 -! -! Extract the analysis increment and surface mask in subdomain without the buffer -! - do j=1,lon1 - jp1 = j+1 - do i=1,lat1 - ip1 = i+1 - dsfct_sub(i,j) = dsfct(ip1,jp1) - isli_sub (i,j) = isli2(ip1,jp1) - end do - end do -! -! Gather global analysis increment and surface mask info from subdomains -! - call mpi_gatherv(dsfct_sub,ijn(mm1),mpi_rtype,& - dsfct_all,ijn,displs_g,mpi_rtype,mype_so ,& - mpi_comm_world,ierror) - - call mpi_gatherv(isli_sub,ijn(mm1),mpi_itype,& - isli_all,ijn,displs_g,mpi_itype,mype_so ,& - mpi_comm_world,ierror) - -! Only MPI task mype_so writes the surface file. - if (mype==mype_so ) then - - write(*,'(a,5(1x,a6))') 'write_nems_sfc_nst:',fname_sfcges,fname_nstges,fname_sfctsk,fname_sfcanl,fname_nstanl -! -! get Tf analysis increment and surface mask at analysis (lower resolution) grids -! - do i=1,iglobal - ilon=ltosj(i) - ilat=ltosi(i) - dsfct_glb(ilat,ilon) = dsfct_all(i) - isli_glb (ilat,ilon) = isli_all (i) - end do -! -! write dsfct_anl to a data file for later use (at eupd step at present) -! - open(io_dtfanl,file=fname_dtfanl,form='unformatted') - write(io_dtfanl) nlon,nlat - write(io_dtfanl) dsfct_glb - write(io_dtfanl) isli_glb - -! Initiate nemsio - call nemsio_init(iret=iret) - if (iret /= 0) call error_msg(trim(my_name),null,null,'init',istop,iret) - -! open nsst guess file - call nemsio_open(gfile_nstges,trim(fname_nstges),'read',iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),null,'open',istop,iret) -! open surface guess file - call nemsio_open(gfile_sfcges,trim(fname_sfcges),'read',iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcges),null,'open',istop,iret) -! open surface gcycle file - call nemsio_open(gfile_sfcgcy,trim(fname_sfcgcy),'read',iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcgcy),null,'open',istop,iret) - -! read a few surface guess file header records - call nemsio_getfilehead(gfile_sfcges, nrec=nrec_sfc, idate=idate, & - dimx=lonb, dimy=latb, nfhour=nfhour, nfminute=nfminute, & - nfsecondn=nfsecondn, nfsecondd=nfsecondd, iret=iret) - -! read some nsst guess file header records (dimensions) - call nemsio_getfilehead(gfile_nstges, nrec=nrec_nst, dimx=lonb_nst,dimy=latb_nst,iret=iret) - - write(6,*) 'nrec_sfc, nrec_nst = ',nrec_sfc, nrec_nst - -! check the dimensions consistency in sfc, nst files and the used. - if ( latb /= latb_nst .or. lonb /= lonb_nst ) then - write(6,*) 'Inconsistent dimension for sfc & nst files. latb,lonb : ',latb,lonb, & - 'latb_nst,lonb_nst : ',latb_nst,lonb_nst - call stop2(80) - endif - - if ( nlat_sfc /= latb+2 .or. nlon_sfc /= lonb ) then - write(6,*) 'Inconsistent dimension for used and read. nlat_sfc,nlon_sfc : ',nlat_sfc,nlon_sfc, & - 'latb+2,lonb :',latb+2,lonb - call stop2(81) - endif -! - allocate(slmsk_ges(lonb,latb),slmsk_anl(lonb,latb)) - allocate(rwork1d(lonb*latb)) - -! read slmsk in fname_sfcges to get slmsk_ges - call nemsio_readrecv(gfile_sfcges, 'land', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcges),'land','read',istop,iret) - slmsk_ges=reshape(rwork1d,(/size(slmsk_ges,1),size(slmsk_ges,2)/)) - -! read slmsk in fname_sfcgcy to get slmsk_anl - call nemsio_readrecv(gfile_sfcgcy, 'land', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcgcy),'land','read',istop,iret) - slmsk_anl=reshape(rwork1d,(/size(slmsk_anl,1),size(slmsk_anl,2)/)) -! -! Replace header record date with analysis time from iadate -! - jdate(1) = iadate(1) ! analysis year - jdate(2) = iadate(2) ! analysis month - jdate(3) = iadate(3) ! analysis day - jdate(4) = iadate(4) ! analysis hour - jdate(5) = iadate(5) ! analysis minute - jdate(5) = 0 ! analysis minute - jdate(6) = 0 ! analysis scaled seconds - jdate(7) = idate(7) ! analysis seconds multiplier - - nfhour=0 ! new forecast hour, zero at analysis time - nfminute=0 - nfsecondn=0 - nfsecondd=100 ! default for denominator - - fhour = zero - odate(1) = jdate(4) !hour - odate(2) = jdate(2) !month - odate(3) = jdate(3) !day - odate(4) = jdate(1) !year - - if ( (latb /= nlatm2) .or. (lonb /= nlon) ) then - write(6,*)'WRITE_NEMSIO_SFC_NST: different grid dimensions analysis vs sfc. interpolating sfc temperature ',& - ', nlon,nlat-2=',nlon,nlatm2,' -vs- sfc file lonb,latb=',lonb,latb - write(6,*) ' WRITE_NEMSIO_SFC_NST, nlon_sfc,nlat_sfc : ', nlon_sfc,nlat_sfc -! -! Get the expanded values for a surface type (0 = water now) and the new mask -! - call int2_msk_glb_prep(dsfct_glb,isli_glb,dsfct_tmp,isli_tmp,nlat,nlon,0,nprep) -! -! Get updated/analysis surface mask info from sfcgcy file -! - call tran_gfssfc(slmsk_anl,work,lonb,latb) - do j=1,lonb - do i=1,latb+2 - isli_gsi(i,j) = nint(work(i,j)) - end do - end do -! -! Interpolate dsfct_tmp(nlat,nlon) to dsfct_gsi(nlat_sfc,nlon_sfc) with surface mask accounted -! - call int22_msk_glb(dsfct_tmp,isli_tmp,rlats,rlons,nlat,nlon, & - dsfct_gsi,isli_gsi,rlats_sfc,rlons_sfc,nlat_sfc,nlon_sfc,0) -! -! transform the dsfct_gsi(latb+2,lonb) to dsfct_anl(lonb,latb) for sfc file format -! - do j = 1, latb - do i = 1, lonb - dsfct_anl(i,j) = dsfct_gsi(latb+2-j,i) - end do - end do - - else -! -! transform the dsfct_glb(nlat,nlon) to dsfct_anl(lonb,latb) for sfc file -! format when nlat == latb-2 & nlon = lonb -! - do j=1,latb - do i=1,lonb - dsfct_anl(i,j)=dsfct_glb(latb+1-j,i) - end do - end do - endif ! if ( (latb /= nlatm2) .or. (lonb /= nlon) ) then - -! -! Start to write output sfc file : fname_sfcanl & fname_nstanl -! open new output file with new header gfile_sfcanl and gfile_nstanl with "write" access. -! Use this call to update header as well -! -! copy input header info to output header info for sfcanl, need to do this before nemsio_close(gfile) -! - gfile_sfcanl=gfile_sfcgcy -! open nemsio sfcanl - call nemsio_open(gfile_sfcanl,trim(fname_sfcanl),'write',iret=iret, idate=jdate, nfhour=nfhour,& - nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd ) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcanl),null,'open',istop,iret) - - gfile_sfctsk=gfile_sfcgcy -! open nemsio sfctsk - call nemsio_open(gfile_sfctsk,trim(fname_sfctsk),'write',iret=iret, idate=jdate, nfhour=nfhour,& - nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd ) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfctsk),null,'open',istop,iret) -! -! copy input header info to output header info for nstanl, need to do this before nemsio_close(gfile) -! - gfile_nstanl=gfile_nstges -! open nemsio nstanl - call nemsio_open(gfile_nstanl,trim(fname_nstanl),'write',iret=iret, idate=jdate, nfhour=nfhour,& - nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd ) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),null,'open',istop,iret) -! Allocate work array (rwork1d) and tsea in sfc file - allocate(tsea(lonb,latb)) - -! Allocate nsst variables - allocate(xt(lonb,latb)) - allocate(xs(lonb,latb)) - allocate(xu(lonb,latb)) - allocate(xv(lonb,latb)) - allocate(xz(lonb,latb)) - allocate(zm(lonb,latb)) - allocate(xtts(lonb,latb)) - allocate(xzts(lonb,latb)) - allocate(dt_cool(lonb,latb)) - allocate(z_c(lonb,latb)) - allocate(c_0(lonb,latb)) - allocate(c_d(lonb,latb)) - allocate(w_0(lonb,latb)) - allocate(w_d(lonb,latb)) - allocate(d_conv(lonb,latb)) - allocate(ifd(lonb,latb)) - allocate(tref(lonb,latb)) - allocate(qrain(lonb,latb)) -! -! First copy entire data from sfcgcy to fname_anl, then do selective update -! -! read the nrec_sfc variables from sfcgcy and then write then to sfcanl -! - do n = 1, nrec_sfc - call nemsio_readrec(gfile_sfcgcy,n,rwork1d,iret=iret) - if ( iret /= 0 ) write(6,*) 'readrec for gfile_sfcgcy, nrec_sfc = ', n, ' Status = ', iret - call nemsio_writerec(gfile_sfcanl,n,rwork1d,iret=iret) - if ( iret /= 0 ) write(6,*) 'writerec for gfile_sfcanl, nrec_sfc = ', n, ' Status = ', iret - call nemsio_writerec(gfile_sfctsk,n,rwork1d,iret=iret) - if ( iret /= 0 ) write(6,*) 'writerec for gfile_sfctsk, nrec_sfc = ', n, ' Status = ', iret - end do - - write(*,*) 'read gfile_sfcgcy, and the write to gfile_sfcanl, gfile_sfctsk' -! -! For sfcanl, Only tsea (sea surface temperature) will be updated in the SFC -! Need values from nstges for tref update -! read tsea from sfcges - call nemsio_readrecv(gfile_sfcges,'tmp','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcges),'tmp','read',istop,iret) - tsea=reshape(rwork1d,(/size(tsea,1),size(tsea,2)/)) - -! For nstanl, Only tref (foundation temperature) is updated by analysis -! others are updated for snow melting case -! read 18 nsst variables from nstges -! xt - call nemsio_readrecv(gfile_nstges, 'xt', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xt','read',istop,iret) - xt=reshape(rwork1d,(/size(xt,1),size(xt,2)/)) -! xs - call nemsio_readrecv(gfile_nstges, 'xs', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xs','read',istop,iret) - xs=reshape(rwork1d,(/size(xs,1),size(xs,2)/)) -! xu - call nemsio_readrecv(gfile_nstges, 'xu', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xu','read',istop,iret) - xu=reshape(rwork1d,(/size(xu,1),size(xu,2)/)) -! xv - call nemsio_readrecv(gfile_nstges, 'xv', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xv','read',istop,iret) - xv=reshape(rwork1d,(/size(xv,1),size(xv,2)/)) -! xz - call nemsio_readrecv(gfile_nstges, 'xz', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xz','read',istop,iret) - xz=reshape(rwork1d,(/size(xz,1),size(xz,2)/)) -! zm - call nemsio_readrecv(gfile_nstges, 'zm', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'zm','read',istop,iret) - zm=reshape(rwork1d,(/size(zm,1),size(zm,2)/)) -! xtts - call nemsio_readrecv(gfile_nstges, 'xtts', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xtts','read',istop,iret) - xtts=reshape(rwork1d,(/size(xtts,1),size(xtts,2)/)) -! xzts - call nemsio_readrecv(gfile_nstges, 'xzts', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'xzts','read',istop,iret) - xzts=reshape(rwork1d,(/size(xzts,1),size(xzts,2)/)) -! dt_cool - call nemsio_readrecv(gfile_nstges, 'dtcool','sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'dt_cool','read',istop,iret) - dt_cool=reshape(rwork1d,(/size(dt_cool,1),size(dt_cool,2)/)) -! z_c - call nemsio_readrecv(gfile_nstges, 'zc','sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'zc','read',istop,iret) - z_c=reshape(rwork1d,(/size(z_c,1),size(z_c,2)/)) -! c_0 - call nemsio_readrecv(gfile_nstges, 'c0','sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'c0','read',istop,iret) - c_0=reshape(rwork1d,(/size(c_0,1),size(c_0,2)/)) -! c_d - call nemsio_readrecv(gfile_nstges, 'cd','sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'cd','read',istop,iret) - c_d=reshape(rwork1d,(/size(c_d,1),size(c_d,2)/)) -! w_0 - call nemsio_readrecv(gfile_nstges, 'w0','sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'w0','read',istop,iret) - w_0=reshape(rwork1d,(/size(w_0,1),size(w_0,2)/)) -! w_d - call nemsio_readrecv(gfile_nstges, 'wd','sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'wd','read',istop,iret) - w_d=reshape(rwork1d,(/size(w_d,1),size(w_d,2)/)) -! tref - call nemsio_readrecv(gfile_nstges, 'tref', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'tref','read',istop,iret) - tref=reshape(rwork1d,(/size(tref,1),size(tref,2)/)) -! d_conv - call nemsio_readrecv(gfile_nstges, 'dconv', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'dconv','read',istop,iret) - d_conv=reshape(rwork1d,(/size(d_conv,1),size(d_conv,2)/)) -! ifd - call nemsio_readrecv(gfile_nstges, 'ifd', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'ifd','read',istop,iret) - ifd=reshape(rwork1d,(/size(ifd,1),size(ifd,2)/)) -! qrain - call nemsio_readrecv(gfile_nstges, 'qrain', 'sfc', 1, rwork1d, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),'qrain','read',istop,iret) - qrain=reshape(rwork1d,(/size(qrain,1),size(qrain,2)/)) -! -! update tref (in nst file) & tsea (in the surface file) when Tr analysis is on -! reset NSSTM variables for new open water grids -! - if ( nst_gsi > 2 ) then -! -! For the new open water (sea ice just melted) grids, (1) set dsfct_anl = zero; (2) reset the NSSTM variables -! -! Notes: slmsk_ges is the mask of the background -! slmsk_anl is the mask of the analysis -! - where ( slmsk_anl(:,:) == zero .and. slmsk_ges(:,:) == two ) - - dsfct_anl(:,:) = zero - - xt(:,:) = zero - xs(:,:) = zero - xu(:,:) = zero - xv(:,:) = zero - xz(:,:) = z_w_max - zm(:,:) = zero - xtts(:,:) = zero - xzts(:,:) = zero - dt_cool(:,:) = zero - z_c(:,:) = zero - c_0(:,:) = zero - c_d(:,:) = zero - w_0(:,:) = zero - w_d(:,:) = zero - d_conv(:,:) = zero - ifd(:,:) = zero - tref(:,:) = tfrozen - qrain(:,:) = zero - end where -! -! update analysis variable: Tref (foundation temperature) for nst file -! - where ( slmsk_anl(:,:) == zero ) - tref(:,:) = max(tref(:,:) + dsfct_anl(:,:),tfrozen) - elsewhere - tref(:,:) = tsea(:,:) - end where -! -! update SST: tsea for sfc file with NSST profile -! - r_zsea1 = 0.001_r_single*real(zsea1) - r_zsea2 = 0.001_r_single*real(zsea2) - call dtzm_2d(xt,xz,dt_cool,z_c,slmsk_anl,r_zsea1,r_zsea2,lonb,latb,dtzm) - - where ( slmsk_anl(:,:) == zero ) - tsea(:,:) = max(tref(:,:) + dtzm(:,:), tfrozen) - end where - - else ! when (nst_gsi <= 2) - - do j=1,latb - do i=1,lonb - tref(i,j) = tsea(i,j) ! keep tref as tsea before analysis - end do - end do -! -! For the new open water (sea ice just melted) grids, reset the NSSTM variables -! - where ( slmsk_anl(:,:) == zero .and. slmsk_ges(:,:) == two ) - - xt(:,:) = zero - xs(:,:) = zero - xu(:,:) = zero - xv(:,:) = zero - xz(:,:) = z_w_max - zm(:,:) = zero - xtts(:,:) = zero - xzts(:,:) = zero - dt_cool(:,:) = zero - z_c(:,:) = zero - c_0(:,:) = zero - c_d(:,:) = zero - w_0(:,:) = zero - w_d(:,:) = zero - d_conv(:,:) = zero - ifd(:,:) = zero - tref(:,:) = tfrozen - qrain(:,:) = zero - end where -! -! update tsea when NO Tf analysis -! - do j=1,latb - do i=1,lonb - tsea(i,j) = max(tsea(i,j) + dsfct_anl(i,j),tfrozen) - end do - end do - - endif ! if ( nst_gsi > 2 ) then -! -! update tsea record in sfcanl -! - rwork1d = reshape(tsea, (/size(rwork1d)/) ) - call nemsio_writerecv(gfile_sfcanl,'tmp','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcanl),'tmp','write',istop,iret) - write(6,100) fname_sfcanl,lonb,latb,houra,iadate(1:4),iret -100 format(' WRITE_NEMSIO_SFC_NST: update tsea in ',a6,2i6,1x,f4.1,4(i4,1x),' with iret=',i2) -! -! update tsea record in sfctsk -! - rwork1d = reshape(tsea, (/size(rwork1d)/) ) - call nemsio_writerecv(gfile_sfctsk,'tmp','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfctsk),'tmp','write',istop,iret) - write(6,101) fname_sfctsk,lonb,latb,houra,iadate(1:4),iret -101 format(' WRITE_NEMSIO_SFC_NST: update tsea in ',a6,2i6,1x,f4.1,4(i4,1x),' with iret=',i2) -! -! update nsst records in nstanl -! -! slmsk - rwork1d = reshape( slmsk_anl,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'land','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'land','write',istop,iret) -! xt - rwork1d = reshape( xt,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'xt','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xt','write',istop,iret) -! xs - rwork1d = reshape( xs,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'xs','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xs','write',istop,iret) -! xu - rwork1d = reshape( xu,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'xu','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xu','write',istop,iret) -! xv - rwork1d = reshape( xv,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'xv','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xv','write',istop,iret) -! xz - rwork1d = reshape( xz,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'xz','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xz','write',istop,iret) -! zm - rwork1d = reshape( zm,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'zm','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'zm','write',istop,iret) -! xtts - rwork1d = reshape( xtts,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'xtts','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xtts','write',istop,iret) -! xzts - rwork1d = reshape( xzts,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'xzts','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'xzts','write',istop,iret) -! z_0 - rwork1d = reshape( dt_cool,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'dtcool','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'dtcool','write',istop,iret) -! z_c - rwork1d = reshape( z_c,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'zc','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'zc','write',istop,iret) -! c_0 - rwork1d = reshape( c_0,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'c0','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'c0','write',istop,iret) -! c_d - rwork1d = reshape( c_d,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'cd','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'cd','write',istop,iret) -! w_0 - rwork1d = reshape( w_0,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'w0','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'w0','write',istop,iret) -! w_d - rwork1d = reshape( w_d,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'wd','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'wd','write',istop,iret) -! d_conv - rwork1d = reshape( d_conv,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'dconv','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'dconv','write',istop,iret) -! ifd - rwork1d = reshape( ifd,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'ifd','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'ifd','write',istop,iret) -! tref - rwork1d = reshape( tref,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'tref','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'tref','write',istop,iret) -! qrain - rwork1d = reshape( qrain,(/size(rwork1d)/) ) - call nemsio_writerecv(gfile_nstanl,'qrain','sfc',1,rwork1d,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),'qrain','write',istop,iret) - - write(6,200) fname_nstanl,lonb,latb,houra,iadate(1:4),iret -200 format(' WRITE_NEMSIO_SFC_NST: update variables in ',a6,2i6,1x,f4.1,4(i4,1x),' with iret=',i2) - - deallocate(xt,xs,xu,xv,xz,zm,xtts,xzts,dt_cool,z_c,c_0,c_d,w_0,w_d,d_conv,ifd,tref,qrain) - deallocate(rwork1d) - - call nemsio_close(gfile_sfcges, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcges),null,'close',istop,iret) - - call nemsio_close(gfile_sfcgcy, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcgcy),null,'close',istop,iret) - - call nemsio_close(gfile_nstges, iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstges),null,'close',istop,iret) - - call nemsio_close(gfile_sfcanl,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfcanl),null,'close',istop,iret) - - call nemsio_close(gfile_nstanl,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_nstanl),null,'close',istop,iret) - - call nemsio_close(gfile_sfctsk,iret=iret) - if (iret /= 0) call error_msg(trim(my_name),trim(fname_sfctsk),null,'close',istop,iret) - - write(6,'(a,'': nemsio sfc_nst anal written for lonb,latb= '',2i6,'',valid hour= '',f4.1,'',idate= '',4i5)') & - trim(my_name),lonb,latb,fhour,odate - endif - end subroutine write_sfc_nst_ - - subroutine error_msg_(sub_name,file_name,var_name,action,stop_code,error_code) - use mpimod, only: mype - use kinds, only: i_kind - implicit none - - character(len=*), intent(in) :: sub_name,file_name,var_name,action - integer(i_kind), intent(in) :: stop_code, error_code - - if ( mype == 0 ) then - select case (trim(action)) - case('init') - write(6,'(a,'': PROBLEM with nemsio_init, Status = '', i3)') & - trim(sub_name), error_code - case('open') - write(6,'(a,'': ***ERROR*** problem opening file '',a,'', Status = '', i3)') & - trim(sub_name), trim(file_name), error_code - case('close') - write(6,'(a,'': ***ERROR*** problem closing file '',a,'', Status = '', i3)') & - trim(sub_name), trim(file_name), error_code - case default - write(6,'(a,'': ***ERROR*** '',a,tr1,a,'',variable = '',a,'',Status = '',i3)') & - trim(sub_name),trim(action),trim(file_name),trim(var_name),error_code - end select - end if - if ( stop_code /= 0 ) call stop2(stop_code) - end subroutine error_msg_ - - subroutine intrp22(a,rlons_a,rlats_a,nlon_a,nlat_a, & - b,rlons_b,rlats_b,nlon_b,nlat_b) -!$$$ subprogram documentation block -! . . . -! subprogram: intrp22 --- interpolates from one 2-d grid to another 2-d grid -! like analysis to surface grid or vice versa -! prgrmmr: li - initial version; org: np2 -! -! abstract: This routine interpolates a grid to b grid -! -! program history log: -! -! input argument list: -! rlons_a - longitudes of input array -! rlats_a - latitudes of input array -! nlon_a - number of longitude of input array -! nlat_a - number of latitude of input array -! rlons_b - longitudes of output array -! rlats_b - latitudes of output array -! nlon_b - number of longitude of output array -! nlat_b - number of latitude of output array -! a - input values -! -! output argument list: -! b - output values -! -! attributes: -! language: f90 -! machines: ibm RS/6000 SP; SGI Origin 2000; Compaq HP -! -!$$$ end documentation block - -! !USES: - use kinds, only: r_kind,i_kind,r_single - use constants, only: zero,one - - implicit none - -! !INPUT PARAMETERS: - integer(i_kind) ,intent(in ) :: nlon_a,nlat_a,nlon_b,nlat_b - real(r_kind), dimension(nlon_a) ,intent(in ) :: rlons_a - real(r_kind), dimension(nlat_a) ,intent(in ) :: rlats_a - real(r_kind), dimension(nlon_b) ,intent(in ) :: rlons_b - real(r_kind), dimension(nlat_b) ,intent(in ) :: rlats_b - - real(r_single), dimension(nlon_a,nlat_a),intent(in ) :: a - -! !OUTPUT PARAMETERS: - real(r_single), dimension(nlon_b,nlat_b),intent( out) :: b - -! Declare local variables - integer(i_kind) i,j,ix,iy,ixp,iyp - real(r_kind) dx1,dy1,dx,dy,w00,w01,w10,w11,bout,dlat,dlon - -!***************************************************************************** - - b=zero -! Loop over all points to get interpolated value - do j=1,nlat_b - dlat=rlats_b(j) - call grdcrd1(dlat,rlats_a,nlat_a,1) - iy=int(dlat) - iy=min(max(1,iy),nlat_a) - dy =dlat-iy - dy1 =one-dy - iyp=min(nlat_a,iy+1) - - do i=1,nlon_b - dlon=rlons_b(i) - call grdcrd1(dlon,rlons_a,nlon_a,1) - ix=int(dlon) - dx =dlon-ix - dx=max(zero,min(dx,one)) - dx1 =one-dx - w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy - - ix=min(max(0,ix),nlon_a) - ixp=ix+1 - if(ix==0) ix=nlon_a - if(ixp==nlon_a+1) ixp=1 - bout=w00*a(ix,iy)+w01*a(ix,iyp)+w10*a(ixp,iy)+w11*a(ixp,iyp) - b(i,j)=bout - - end do - end do - - -! End of routine - return - end subroutine intrp22 - - subroutine tran_gfssfc(ain,aout,lonb,latb) -!$$$ subprogram documentation block -! . . . . -! subprogram: tran_gfssfc transform gfs surface file to analysis grid -! prgmmr: derber org: np2 date: 2003-04-10 -! -! abstract: transform gfs surface file to analysis grid -! -! program history log: -! 2012-31-38 derber - initial routine -! -! input argument list: -! ain - input surface record on processor iope -! lonb - input number of longitudes -! latb - input number of latitudes -! -! output argument list: -! aout - output transposed surface record -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,i_kind,r_single - use constants, only: zero - use sfcio_module, only: sfcio_realkind - implicit none - -! Declare passed variables - integer(i_kind) ,intent(in ) :: lonb,latb - real(sfcio_realkind),dimension(lonb,latb),intent(in ) :: ain - real(r_single),dimension(latb+2,lonb),intent(out) :: aout - -! Declare local variables - integer(i_kind) i,j - real(r_kind) sumn,sums -! of surface guess array - sumn = zero - sums = zero - do i=1,lonb - sumn = ain(i,1) + sumn - sums = ain(i,latb) + sums - end do - sumn = sumn/float(lonb) - sums = sums/float(lonb) -! Transfer from local work array to surface guess array - do j = 1,lonb - aout(1,j)=sums - do i=2,latb+1 - aout(i,j) = ain(j,latb+2-i) - end do - aout(latb+2,j)=sumn - end do - - return - end subroutine tran_gfssfc - -end module ncepnems_io - diff --git a/src/obs_sensitivity.f90 b/src/obs_sensitivity.f90 deleted file mode 100644 index 9738ae71f..000000000 --- a/src/obs_sensitivity.f90 +++ /dev/null @@ -1,461 +0,0 @@ -module obs_sensitivity -!$$$ module documentation block -! . . . . -! module: obs_sensitivity -! prgmmr: tremolet -! -! abstract: Contains variables and routines for computation of -! forecast sensitivity to observations. -! -! program history log: -! 2007-06-26 tremolet -! 2007-07-19 tremolet - increment sensitivity to observations -! 2009-08-07 lueken - updated documentation -! 2010-04-30 tangborn - add pointer to carbon monoxide -! 2010-05-27 todling - remove all user-specific TL-related references -! 2010-07-16 todling - add reference to aero and aerol -! 2010-08-19 lueken - add only to module use;no machine code, so use .f90 -! 2011-03-29 todling - add reference to pm2_5 -! 2012-04-15 todling - add reference to gust, vis, pblh -! 2015-07-10 pondeca - add reference to wspd10m, td2m ,mxtm ,mitm ,pmsl, -! howv ,tcamt, lcbas, cldch -! 2016-02-20 pagowski - add pm10 -! 2016-05-05 pondeca - add reference to uwnd10m, vwnd10m -! -! Subroutines Included: -! init_fc_sens - Initialize computations -! -! Variable Definitions: -! fcsens - forecast sensitivity gradient -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block -! ------------------------------------------------------------------------------ -use kinds, only: r_kind,i_kind,r_quad -use constants, only: zero, zero_quad, two -use gsi_4dvar, only: nobs_bins, l4dvar, lsqrtb, nsubwin -use jfunc, only: jiter, miter, niter, iter -use obsmod, only: cobstype, nobs_type, obscounts, & - i_ps_ob_type, i_t_ob_type, i_w_ob_type, i_q_ob_type, & - i_spd_ob_type, i_rw_ob_type, i_dw_ob_type, & - i_sst_ob_type, i_pw_ob_type, i_pcp_ob_type, i_oz_ob_type, & - i_o3l_ob_type, i_gps_ob_type, i_rad_ob_type, i_tcp_ob_type, & - i_lag_ob_type, i_colvk_ob_type, i_aero_ob_type, i_aerol_ob_type, & - i_pm2_5_ob_type, i_gust_ob_type, i_vis_ob_type, i_pblh_ob_type, & - i_wspd10m_ob_type, i_td2m_ob_type, i_mxtm_ob_type, i_mitm_ob_type, & - i_pmsl_ob_type, i_howv_ob_type, i_tcamt_ob_type, i_lcbas_ob_type, & - i_cldch_ob_type, i_uwnd10m_ob_type, i_vwnd10m_ob_type, i_pm10_ob_type - -use mpimod, only: mype -use control_vectors, only: control_vector,allocate_cv,read_cv,deallocate_cv, & - dot_product,assignment(=) -use state_vectors, only: allocate_state,deallocate_state -use gsi_bundlemod, only: assignment(=) -use gsi_bundlemod, only: gsi_bundle -use bias_predictors, only: predictors,allocate_preds,deallocate_preds, & - assignment(=) -use mpl_allreducemod, only: mpl_allreduce -use gsi_4dcouplermod, only: gsi_4dcoupler_getpert -use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens -! ------------------------------------------------------------------------------ -implicit none -save -private -public lobsensfc,lobsensjb,lobsensincr,lobsensadj,& - lobsensmin,iobsconv,llancdone,lsensrecompute, & - fcsens, sensincr, & - init_obsens, init_fc_sens, save_fc_sens, dot_prod_obs - -logical lobsensfc,lobsensjb,lobsensincr, & - lobsensadj,lobsensmin,llancdone,lsensrecompute -integer(i_kind) :: iobsconv - -! ------------------------------------------------------------------------------ -type(control_vector) :: fcsens -real(r_kind), allocatable :: sensincr(:,:,:) -character(len=5) :: cobtype(nobs_type) -integer(i_kind):: my_nobs_type=34 -! ------------------------------------------------------------------------------ -contains -! ------------------------------------------------------------------------------ -subroutine init_obsens -!$$$ subprogram documentation block -! . . . . -! subprogram: init_obsens -! prgmmr: -! -! abstract: -! -! program history log: -! 2009-08-07 lueken - added subprogram doc block -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block -implicit none - -lobsensfc=.false. -lobsensjb=.false. -lobsensincr=.false. -lobsensadj=.false. -lobsensmin=.false. -lsensrecompute=.false. -llancdone=.false. -iobsconv=0 - -end subroutine init_obsens -! ------------------------------------------------------------------------------ -subroutine init_fc_sens -!$$$ subprogram documentation block -! . . . . -! subprogram: init_fc_sens -! prgmmr: tremolet -! -! abstract: Read forecast sensitivity gradient -! -! program history log: -! 2007-06-26 tremolet - initial code -! 2009-08-07 lueken - added subprogram doc block -! 2010-05-27 todling - gsi_4dcoupler; remove dependence on GMAO specifics -! 2012-05-22 todling - update interface to getpert -! 2015-12-01 todling - add several obs-types that Pondeca forget to add here -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -implicit none - -character(len=12) :: clfile -type(gsi_bundle) :: fcgrad(nsubwin) -type(gsi_bundle) :: eval(ntlevs_ens) -type(predictors) :: zbias -type(control_vector) :: xwork -real(r_kind) :: zjx -integer(i_kind) :: ii -character(len=80),allocatable,dimension(:)::fname - -if(my_nobs_type/=nobs_type) then - write(6,*)'init_fc_sens: inconsistent nobs_types, code needs update' - call stop2(999) -endif -if (mype==0) then - write(6,*)'init_fc_sens: lobsensincr,lobsensfc,lobsensjb=', & - lobsensincr,lobsensfc,lobsensjb - write(6,*)'init_fc_sens: lobsensadj,lobsensmin,iobsconv=', & - lobsensadj,lobsensmin,iobsconv - write(6,*)'init_fc_sens: lsensrecompute=',lsensrecompute -endif - -call allocate_cv(fcsens) -fcsens=zero - -if (lobsensadj.and.lobsensmin) then - write(6,*)'init_fc_sens: unknown method',lobsensadj,lobsensmin - call stop2(155) -end if - -if (iobsconv>=2) then - allocate(sensincr(nobs_bins,nobs_type,niter(jiter))) -else - allocate(sensincr(nobs_bins,nobs_type,1)) -endif -sensincr=zero - -! Initialize fcsens -if (lobsensfc) then - if (lobsensincr) then - clfile='xhatsave.ZZZ' - write(clfile(10:12),'(I3.3)') jiter - call read_cv(fcsens,clfile) - if (jiter>1) then - clfile='xhatsave.ZZZ' - write(clfile(10:12),'(I3.3)') jiter-1 - call allocate_cv(xwork) - call read_cv(xwork,clfile) - do ii=1,fcsens%lencv - fcsens%values(ii) = fcsens%values(ii) - xwork%values(ii) - end do - call deallocate_cv(xwork) - endif - else - if (jiter==miter) then - if (lobsensjb) then - clfile='xhatsave.ZZZ' - write(clfile(10:12),'(I3.3)') miter - call read_cv(fcsens,clfile) - else -! read and convert output of GCM adjoint - allocate(fname(nsubwin)) - fname='NULL' - do ii=1,nsubwin - call allocate_state(fcgrad(ii)) - end do - call allocate_preds(zbias) - zbias=zero - call gsi_4dcoupler_getpert(fcgrad,nsubwin,'adm',fname) - if (lsqrtb) then - call control2model_ad(fcgrad,zbias,fcsens) - else - if (l_hyb_ens) then - do ii=1,ntlevs_ens - call allocate_state(eval(ii)) - end do - eval(1)=fcgrad(1) - fcgrad(1)=zero - call ensctl2state_ad(eval,fcgrad(1),fcsens) - call control2state_ad(fcgrad,zbias,fcsens) - do ii=1,ntlevs_ens - call deallocate_state(eval(ii)) - end do - else - call control2state_ad(fcgrad,zbias,fcsens) - end if - endif - do ii=1,nsubwin - call deallocate_state(fcgrad(ii)) - end do - call deallocate_preds(zbias) - deallocate(fname) - endif - else -! read gradient from outer loop jiter+1 - clfile='fgsens.ZZZ' - WRITE(clfile(8:10),'(I3.3)') jiter+1 - call read_cv(fcsens,clfile) - endif - endif - zjx=dot_product(fcsens,fcsens) - if (mype==0) write(6,888)'init_fc_sens: Norm fcsens=',sqrt(zjx) -endif -888 format(A,3(1X,ES25.18)) - -! Define short name for obs types -cobtype( i_ps_ob_type) ="spr " -cobtype( i_t_ob_type) ="tem " -cobtype( i_w_ob_type) ="uv " -cobtype( i_q_ob_type) ="hum " -cobtype(i_spd_ob_type) ="spd " -cobtype( i_rw_ob_type) ="rw " -cobtype( i_dw_ob_type) ="dw " -cobtype(i_sst_ob_type) ="sst " -cobtype( i_pw_ob_type) ="pw " -cobtype(i_pcp_ob_type) ="pcp " -cobtype( i_oz_ob_type) ="oz " -cobtype(i_o3l_ob_type) ="o3l " -cobtype(i_gps_ob_type) ="gps " -cobtype(i_rad_ob_type) ="rad " -cobtype(i_tcp_ob_type) ="tcp " -cobtype(i_lag_ob_type) ="lag " -cobtype(i_colvk_ob_type) ="colvk" -cobtype(i_aero_ob_type) ="aero " -cobtype(i_aerol_ob_type) ="aerol" -cobtype(i_pm2_5_ob_type) ="pm2_5" -cobtype(i_pm10_ob_type) ="pm10 " -cobtype(i_gust_ob_type) ="gust " -cobtype(i_vis_ob_type) ="vis " -cobtype(i_pblh_ob_type) ="pblh " -cobtype(i_wspd10m_ob_type) ="ws10m" -cobtype(i_td2m_ob_type) ="td2m " -cobtype(i_mxtm_ob_type) ="mxtm " -cobtype(i_mitm_ob_type) ="mitm " -cobtype(i_pmsl_ob_type) ="pmsl " -cobtype(i_howv_ob_type) ="howv " -cobtype(i_tcamt_ob_type) ="tcamt" -cobtype(i_lcbas_ob_type) ="lcbas" -cobtype(i_cldch_ob_type) ="cldch" -cobtype(i_uwnd10m_ob_type) ="u10m " -cobtype(i_vwnd10m_ob_type) ="v10m " - - -return -end subroutine init_fc_sens -! ------------------------------------------------------------------------------ -subroutine save_fc_sens -!$$$ subprogram documentation block -! . . . . -! subprogram: save_fc_sens -! prgmmr: tremolet -! -! abstract: Compute and save forecast sensitivity to observations -! -! program history log: -! 2007-06-26 tremolet - initial code -! 2009-08-07 lueken - added subprogram doc block -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block -implicit none - -real(r_kind) :: zz -integer(i_kind) :: ii,jj,kk - -! Save statistics -if (mype==0) then - -! Full stats - do jj=1,nobs_type - write(6,'(A,2X,I3,2X,A)')'Obs types:',jj,cobtype(jj) - enddo - write(6,'(A,2X,I4)')'Obs bins:',nobs_bins - write(6,*)'Obs Count Begin' - if (.not.allocated(obscounts)) then - write(6,*)'save_fc_sens: obscounts not allocated' - call stop2(156) - end if - do jj=1,nobs_type - write(6,'((1X,I12))')(obscounts(jj,ii),ii=1,nobs_bins) - enddo - write(6,*)'Obs Count End' - - write(6,*)'Obs Impact Begin' - do kk=1,SIZE(sensincr,3) - if (SIZE(sensincr,3)==1) then - write(6,'(A,I4)')'Obs Impact iteration= ',niter(jiter) - else - write(6,'(A,I4)')'Obs Impact iteration= ',kk - endif - do jj=1,nobs_type - write(6,'((1X,ES12.5))')(sensincr(ii,jj,kk),ii=1,nobs_bins) - enddo - enddo - write(6,*)'Obs Impact End' - - kk=SIZE(sensincr,3) -! Summary by obs type - do jj=1,nobs_type - zz=zero - do ii=1,nobs_bins - zz=zz+sensincr(ii,jj,kk) - enddo - if (zz/=zero) write(6,'(A,2X,A3,2X,ES12.5)')'Obs Impact type',cobtype(jj),zz - enddo - -! Summary by obs bins - do ii=1,nobs_bins - zz=zero - do jj=1,nobs_type - zz=zz+sensincr(ii,jj,kk) - enddo - if (zz/=zero) write(6,'(A,2X,I3,2X,ES12.5)')'Obs Impact bin',ii,zz - enddo - -endif - -deallocate(sensincr) -call deallocate_cv(fcsens) - -return -end subroutine save_fc_sens -! ------------------------------------------------------------------------------ -real(r_kind) function dot_prod_obs() -!$$$ subprogram documentation block -! . . . . -! subprogram: init_fc_sens -! prgmmr: tremolet -! -! abstract: Computes scalar product in observation space -! (based on evaljo) -! -! program history log: -! 2007-06-27 tremolet -! 2009-01-18 todling - carry summations in quad precision -! 2009-08-07 lueken - added subprogram doc block -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block -use obsmod, only: obs_diag -use obsmod, only: obsdiags -implicit none - -integer(i_kind) :: ii,jj,ij,it -real(r_quad) :: zzz -real(r_quad) :: zprods(nobs_type*nobs_bins) -type(obs_diag),pointer:: obsptr -! ---------------------------------------------------------- - -zprods(:)=zero_quad - -ij=0 -do ii=1,nobs_bins - do jj=1,nobs_type - ij=ij+1 - - obsptr => obsdiags(jj,ii)%head - do while (associated(obsptr)) - if (obsptr%luse.and.obsptr%muse(jiter)) then - zprods(ij) = zprods(ij) + obsptr%nldepart(jiter) * obsptr%obssen(jiter) - endif - obsptr => obsptr%next - enddo - - enddo -enddo - -! Gather contributions -call mpl_allreduce(nobs_type*nobs_bins,qpvals=zprods) - -! Save intermediate values -it=-1 -if (iobsconv>=2) then - if (iter>=1.and.iter<=niter(jiter)) it=iter -else - it=1 -endif - -if (it>0) then - ij=0 - do ii=1,nobs_bins - do jj=1,nobs_type - ij=ij+1 - sensincr(ii,jj,it)=zprods(ij) - enddo - enddo -endif - -! Sum -zzz=zero_quad - -ij=0 -do ii=1,nobs_bins - do jj=1,nobs_type - ij=ij+1 - zzz=zzz+zprods(ij) - enddo -enddo - -dot_prod_obs=zzz - -return -end function dot_prod_obs -! ------------------------------------------------------------------------------ -end module obs_sensitivity diff --git a/src/penal.f90 b/src/penal.f90 deleted file mode 100644 index fdcfd99d4..000000000 --- a/src/penal.f90 +++ /dev/null @@ -1,364 +0,0 @@ -subroutine penal(xhat) -!$$$ subprogram documentation block -! . . . . -! subprogram: penal oberror tuning -! prgmmr: wu org: np23 date: 2005-08-26 -! -! abstract: randomized estimation of Tr(KH) and Tr(HK) and -! adaptive tuning -! -! -! program history log: -! 2005-08-15 wu - oberror tuning -! 2008-03-24 wu - use convinfo ikx as index for oberr tune -! 2008-05-27 safford - rm unused vars -! 2008-12-03 todling - update in light of state vector and obs binning -! 2010-05-13 todling - update to use gsi_bundle -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! -! usage: intt(st,rt) -! input argument list: -! xhat - increment in grid space -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_single,r_kind,i_kind - use mpimod, only: ierror,mpi_comm_world,mpi_sum,mpi_rtype,mype - use constants, only: zero,one - use gsi_4dvar, only: nobs_bins - use m_obsNode, only: obsNode - use m_qNode , only: qNode, qNode_typecast, qNode_nextcast - use m_tNode , only: tNode, tNode_typecast, tNode_nextcast - use m_wNode , only: wNode, wNode_typecast, wNode_nextcast - use m_psNode, only: psNode,psNode_typecast,psNode_nextcast - use m_obsLList, only: obsLList_headNode - use m_obsdiags, only: qhead - use m_obsdiags, only: thead - use m_obsdiags, only: whead - use m_obsdiags, only: pshead - use jfunc, only: jiterstart,jiter - use convinfo, only: ictype,nconvtype,ioctype - use gsi_bundlemod, only: gsi_bundle - use gsi_bundlemod, only: gsi_bundlegetpointer - implicit none - -! Declare passed variables - - type(gsi_bundle),intent(in ) :: xhat - -! Declare passed variables - real(r_kind),save,dimension(33,200) :: penalty,trace - -! Declare local variables - real(r_kind) err2 - - integer(i_kind) i,n,k,ibin,ier,istatus - real(r_kind) tpenalty(33,nconvtype),ttrace(33,nconvtype) - real(r_kind) valu,valv,val,so(33,nconvtype),cat_num(33,nconvtype),sosum,tcat_num(33,nconvtype) - integer(i_kind) itype,ncat,k1 - real(r_kind),pointer,dimension(:):: xhat_u,xhat_v,xhat_q,xhat_t,xhat_p - - class(obsNode),pointer:: anode - type( qNode),pointer:: qptr - type( tNode),pointer:: tptr - type( wNode),pointer:: wptr - type(psNode),pointer:: psptr - -! Get pointers and return if not found - ier=0 - call gsi_bundlegetpointer(xhat,'u' ,xhat_u,istatus);ier=istatus+ier - call gsi_bundlegetpointer(xhat,'v' ,xhat_v,istatus);ier=istatus+ier - call gsi_bundlegetpointer(xhat,'q' ,xhat_q,istatus);ier=istatus+ier - call gsi_bundlegetpointer(xhat,'tv',xhat_t,istatus);ier=istatus+ier - call gsi_bundlegetpointer(xhat,'ps',xhat_p,istatus);ier=istatus+ier - if(ier/=0) return - - ncat=nconvtype*33 - - if(jiter==jiterstart)then - trace=zero - penalty=zero - - do ibin=1,nobs_bins - -! Moisture - !qptr => qNode_typecast(obsLList_headNode(qhead(ibin))) - anode => obsLList_headNode(qhead(ibin)) - qptr => qNode_typecast(anode) - anode => null() - do while (associated(qptr)) - n=qptr%kx - itype=ictype(n) - - if(itype==120)then - k1=qptr%k1 - else - k1=1 - endif - - err2=qptr%raterr2*qptr%err2 -! err=sqrt(err2) -! Forward model - val= qptr%wij(1)* xhat_q(qptr%ij(1))+qptr%wij(2)* xhat_q(qptr%ij(2))& - +qptr%wij(3)* xhat_q(qptr%ij(3))+qptr%wij(4)* xhat_q(qptr%ij(4))& - +qptr%wij(5)* xhat_q(qptr%ij(5))+qptr%wij(6)* xhat_q(qptr%ij(6))& - +qptr%wij(7)* xhat_q(qptr%ij(7))+qptr%wij(8)* xhat_q(qptr%ij(8)) - - trace(k1,n)=trace(k1,n)-qptr%qpertb*val*err2 - penalty(k1,n)=penalty(k1,n)+(val-qptr%res)**2*err2 - qptr => qNode_nextcast(qptr) - end do -! if(mype==29)write(0,*)'q2 trace,pen=',trace(k1,n),penalty(k1,n),k1,n - -! Temperature - !tptr => tNode_typecast(obsLList_headNode(thead(ibin))) - anode => obsLList_headNode(thead(ibin)) - tptr => tNode_typecast(anode) - anode => null() - do while (associated(tptr)) - n=tptr%kx - itype=ictype(n) - - if(itype==120)then - k1=tptr%k1 - else - k1=1 - endif - - err2=tptr%raterr2*tptr%err2 -! err=sqrt(err2) -! Forward model - val= tptr%wij(1)* xhat_t(tptr%ij(1))+tptr%wij(2)* xhat_t(tptr%ij(2))& - +tptr%wij(3)* xhat_t(tptr%ij(3))+tptr%wij(4)* xhat_t(tptr%ij(4))& - +tptr%wij(5)* xhat_t(tptr%ij(5))+tptr%wij(6)* xhat_t(tptr%ij(6))& - +tptr%wij(7)* xhat_t(tptr%ij(7))+tptr%wij(8)* xhat_t(tptr%ij(8)) - - trace(k1,n)=trace(k1,n)-tptr%tpertb*val*err2 - penalty(k1,n)=penalty(k1,n)+(val-tptr%res)**2*err2 - tptr => tNode_nextcast(tptr) - end do - -! Surface pressure - !psptr => psNode_typecast(obsLList_headNode(pshead(ibin))) - anode => obsLList_headNode(pshead(ibin)) - psptr => psNode_typecast(anode) - anode => null() - do while (associated(psptr)) - n=psptr%kx - itype=ictype(n) - k1=1 - - err2=psptr%raterr2*psptr%err2 -! err=sqrt(err2) -! Forward model - val= psptr%wij(1)* xhat_p(psptr%ij(1))+psptr%wij(2)* xhat_p(psptr%ij(2))& - +psptr%wij(3)* xhat_p(psptr%ij(3))+psptr%wij(4)* xhat_p(psptr%ij(4)) - - trace(k1,n)=trace(k1,n)-psptr%ppertb*val*err2 - penalty(k1,n)=penalty(k1,n)+(val-psptr%res)**2*err2 - psptr => psNode_nextcast(psptr) - end do - -! Winds - !wptr => wNode_typecast(obsLList_headNode(whead(ibin))) - anode => obsLList_headNode(whead(ibin)) - wptr => wNode_typecast(anode) - anode => null() - do while (associated(wptr)) - n=wptr%kx - itype=ictype(n) - - if(itype==220 .or. itype==223 .or. itype==233 .or. itype==245)then - k1=wptr%k1 - else - k1=1 - endif - - err2=wptr%raterr2*wptr%err2 -! err=sqrt(err2) -! Forward model - valu= wptr%wij(1)* xhat_u(wptr%ij(1))+wptr%wij(2)* xhat_u(wptr%ij(2))& - +wptr%wij(3)* xhat_u(wptr%ij(3))+wptr%wij(4)* xhat_u(wptr%ij(4))& - +wptr%wij(5)* xhat_u(wptr%ij(5))+wptr%wij(6)* xhat_u(wptr%ij(6))& - +wptr%wij(7)* xhat_u(wptr%ij(7))+wptr%wij(8)* xhat_u(wptr%ij(8)) - valv= wptr%wij(1)* xhat_v(wptr%ij(1))+wptr%wij(2)* xhat_v(wptr%ij(2))& - +wptr%wij(3)* xhat_v(wptr%ij(3))+wptr%wij(4)* xhat_v(wptr%ij(4))& - +wptr%wij(5)* xhat_v(wptr%ij(5))+wptr%wij(6)* xhat_v(wptr%ij(6))& - +wptr%wij(7)* xhat_v(wptr%ij(7))+wptr%wij(8)* xhat_v(wptr%ij(8)) - - trace(k1,n)=trace(k1,n)-(wptr%upertb*valu+wptr%vpertb*valv)*err2 - penalty(k1,n)=penalty(k1,n)+((valu-wptr%ures)**2+(valv-wptr%vres)**2)*err2 - wptr => wNode_nextcast(wptr) - end do - - end do ! ibin - - - else ! jiter - cat_num=zero - - do ibin=1,nobs_bins - -! Moisture -! ratiomin=one - !qptr => qNode_typecast(obsLList_headNode(qhead(ibin))) - anode => obsLList_headNode(qhead(ibin)) - qptr => qNode_typecast(anode) - anode => null() - do while (associated(qptr)) - n=qptr%kx - itype=ictype(n) - - if(itype==120)then - k1=qptr%k1 - else - k1=1 - endif - - err2=qptr%raterr2*qptr%err2 -! err=sqrt(err2) -! Forward model - val= qptr%wij(1)* xhat_q(qptr%ij(1))+qptr%wij(2)* xhat_q(qptr%ij(2))& - +qptr%wij(3)* xhat_q(qptr%ij(3))+qptr%wij(4)* xhat_q(qptr%ij(4))& - +qptr%wij(5)* xhat_q(qptr%ij(5))+qptr%wij(6)* xhat_q(qptr%ij(6))& - +qptr%wij(7)* xhat_q(qptr%ij(7))+qptr%wij(8)* xhat_q(qptr%ij(8)) - - cat_num(k1,n)=cat_num(k1,n)+one - trace(k1,n)=trace(k1,n)+qptr%qpertb*val*err2 - qptr => qNode_nextcast(qptr) - end do - -! if(mype==29)write(0,*)'q2 trace,pen=',trace(k1,n),cat_num(k1,n),k1,n -! Temperature - !tptr => tNode_typecast(obsLList_headNode(thead(ibin))) - anode => obsLList_headNode(thead(ibin)) - tptr => tNode_typecast(anode) - anode => null() - do while (associated(tptr)) - n=tptr%kx - itype=ictype(n) - - if(itype==120)then - k1=tptr%k1 - else - k1=1 - endif - - err2=tptr%raterr2*tptr%err2 -! err=sqrt(err2) -! Forward model - val= tptr%wij(1)* xhat_t(tptr%ij(1))+tptr%wij(2)* xhat_t(tptr%ij(2))& - +tptr%wij(3)* xhat_t(tptr%ij(3))+tptr%wij(4)* xhat_t(tptr%ij(4))& - +tptr%wij(5)* xhat_t(tptr%ij(5))+tptr%wij(6)* xhat_t(tptr%ij(6))& - +tptr%wij(7)* xhat_t(tptr%ij(7))+tptr%wij(8)* xhat_t(tptr%ij(8)) - - cat_num(k1,n)=cat_num(k1,n)+one - trace(k1,n)=trace(k1,n)+tptr%tpertb*val*err2 - tptr => tNode_nextcast(tptr) - end do -! Surface pressure - !psptr => psNode_typecast(obsLList_headNode(pshead(ibin))) - anode => obsLList_headNode(pshead(ibin)) - psptr => psNode_typecast(anode) - anode => null() - do while (associated(psptr)) - n=psptr%kx - itype=ictype(n) - k1=1 - - err2=psptr%raterr2*psptr%err2 -! err=sqrt(err2) -! Forward model - val= psptr%wij(1)* xhat_p(psptr%ij(1))+psptr%wij(2)* xhat_p(psptr%ij(2))& - +psptr%wij(3)* xhat_p(psptr%ij(3))+psptr%wij(4)* xhat_p(psptr%ij(4)) - - cat_num(k1,n)=cat_num(k1,n)+one - trace(k1,n)=trace(k1,n)+psptr%ppertb*val*err2 - psptr => psNode_nextcast(psptr) - end do -! Winds - !wptr => wNode_typecast(obsLList_headNode(whead(ibin))) - anode => obsLList_headNode(whead(ibin)) - wptr => wNode_typecast(anode) - anode => null() - do while (associated(wptr)) - n=wptr%kx - itype=ictype(n) - - if(itype==220 .or. itype==223 .or. itype==233 .or. itype==245)then - k1=wptr%k1 - else - k1=1 - endif - - err2=wptr%raterr2*wptr%err2 -! err=sqrt(err2) -! Forward model - valu= wptr%wij(1)* xhat_u(wptr%ij(1))+wptr%wij(2)* xhat_u(wptr%ij(2))& - +wptr%wij(3)* xhat_u(wptr%ij(3))+wptr%wij(4)* xhat_u(wptr%ij(4))& - +wptr%wij(5)* xhat_u(wptr%ij(5))+wptr%wij(6)* xhat_u(wptr%ij(6))& - +wptr%wij(7)* xhat_u(wptr%ij(7))+wptr%wij(8)* xhat_u(wptr%ij(8)) - valv= wptr%wij(1)* xhat_v(wptr%ij(1))+wptr%wij(2)* xhat_v(wptr%ij(2))& - +wptr%wij(3)* xhat_v(wptr%ij(3))+wptr%wij(4)* xhat_v(wptr%ij(4))& - +wptr%wij(5)* xhat_v(wptr%ij(5))+wptr%wij(6)* xhat_v(wptr%ij(6))& - +wptr%wij(7)* xhat_v(wptr%ij(7))+wptr%wij(8)* xhat_v(wptr%ij(8)) - - cat_num(k1,n)=cat_num(k1,n)+one - trace(k1,n)=trace(k1,n)+(wptr%upertb*valu+wptr%vpertb*valv)*err2 - wptr => wNode_nextcast(wptr) - end do - - do n=1,nconvtype - do k=1,33 - trace(k,n)=cat_num(k,n)-trace(k,n) - enddo - enddo - - end do ! ibin - - call mpi_allreduce(trace,ttrace,ncat,mpi_rtype,mpi_sum, & - mpi_comm_world,ierror) - call mpi_allreduce(penalty,tpenalty,ncat,mpi_rtype,mpi_sum, & - mpi_comm_world,ierror) - call mpi_allreduce(cat_num,tcat_num,ncat,mpi_rtype,mpi_sum, & - mpi_comm_world,ierror) - if(mype==0)then - do n=1,nconvtype - write(233,*)'obs type=',ictype(n),trim(ioctype(n)) - do k=1,33 - if(tcat_num(k,n)>zero .and. tcat_num(k,n)<10._r_kind)write(223,*)k,n,tcat_num(k,n) - write(233,*)k,n,tpenalty(k,n),ttrace(k,n),tcat_num(k,n) - enddo - enddo - - so=one - do n=1,nconvtype - do k=1,33 - if(ttrace(k,n) /= zero .and. tcat_num(k,n)>10._r_kind) then - so(k,n)=tpenalty(k,n)/ttrace(k,n) - write(234,*)k,n,ictype(n),trim(ioctype(n)),so(k,n) - endif - if(so(k,n) >= zero) then - so(k,n)=sqrt(so(k,n)) - else - so(k,n)=one - endif - enddo - enddo - sosum=zero - do i=1,ncat - sosum=sosum+(so(i,1)-one)**2 - enddo - write(235,*)'sosum=',sosum - endif ! mype - - call mpi_finalize(ierror) - stop - endif ! jiter - return -end subroutine penal diff --git a/src/prt_guess.f90 b/src/prt_guess.f90 deleted file mode 100644 index 5b44e7165..000000000 --- a/src/prt_guess.f90 +++ /dev/null @@ -1,456 +0,0 @@ -subroutine prt_guess(sgrep) -!$$$ subprogram documentation block -! . . . . -! subprogram: prt_guess -! prgmmr: tremolet -! -! abstract: Print some diagnostics about the guess arrays -! -! program history log: -! 2007-04-13 tremolet - initial code -! 2007-04-17 todling - time index to summarize; bound in arrays -! 2009-01-17 todling - update tv/tsen names -! 2011-05-01 todling - cwmr no longer in guess_grids -! 2011-08-01 zhu - use cwgues for regional if cw is not in guess table -! 2011-12-02 zhu - add safe-guard for the case when there is no entry in the metguess table -! 2013-10-19 todling - metguess now holds background -! 2013-04-15 zhu - account for aircraft bias correction -! -! input argument list: -! sgrep - prefix for write statement -! -! output argument list: -! -! remarks: -! -! 1. this routine needs generalization to handle met-guess and chem-bundle -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - use kinds, only: r_kind,i_kind - use mpimod, only: ierror,mpi_comm_world,mpi_rtype,npe,mype - use constants, only: zero - use gridmod, only: lat1,lon1,nsig - use gridmod, only: regional - use guess_grids, only: ges_tsen,ges_prsl,sfct - use guess_grids, only: ntguessig,ntguessfc - use radinfo, only: predx - use pcpinfo, only: predxp - use aircraftinfo, only: predt - use derivsmod, only: cwgues - use jfunc, only: npclen,nsclen,ntclen - use gsi_metguess_mod, only: gsi_metguess_get,gsi_metguess_bundle - use gsi_bundlemod, only: gsi_bundlegetpointer - use mpeu_util, only: die - - implicit none - -! Declare passed variables - character(len=*), intent(in ) :: sgrep - -! Declare local variables - integer(i_kind), parameter :: nvars=12 - integer(i_kind) ii,istatus,ier - integer(i_kind) ntsig - integer(i_kind) ntsfc - integer(i_kind) n_actual_clouds - real(r_kind) :: zloc(3*nvars+3),zall(3*nvars+3,npe),zz - real(r_kind) :: zmin(nvars+3),zmax(nvars+3),zavg(nvars+3) - real(r_kind),pointer,dimension(:,: )::ges_ps_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ges_u_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ges_v_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ges_div_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ges_vor_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ges_tv_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ges_q_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ges_oz_it=>NULL() - real(r_kind),pointer,dimension(:,:,:)::ges_cwmr_it=>NULL() - character(len=4) :: cvar(nvars+3) - -!******************************************************************************* - - ntsig = ntguessig - ntsfc = ntguessfc - - ier=0 - call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'ps',ges_ps_it,istatus) - ier=ier+istatus - call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'u',ges_u_it,istatus) - ier=ier+istatus - call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'v',ges_v_it,istatus) - ier=ier+istatus - call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'div',ges_div_it,istatus) - ier=ier+istatus - call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'vor',ges_vor_it,istatus) - ier=ier+istatus - call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'tv',ges_tv_it,istatus) - ier=ier+istatus - call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'q',ges_q_it,istatus) - ier=ier+istatus - call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'oz',ges_oz_it,istatus) - ier=ier+istatus - if (ier/=0) return ! this is a fundamental routine, when some not found just return - -! get pointer to cloud water condensate - call gsi_metguess_get('clouds::3d',n_actual_clouds,ier) - if (n_actual_clouds>0) then - call gsi_bundlegetpointer (gsi_metguess_bundle(ntsig),'cw',ges_cwmr_it,istatus) - if (istatus/=0) then - if (regional) then - ges_cwmr_it => cwgues - else - ier=99 - end if - end if - else - if(associated(ges_cwmr_it)) then - ges_cwmr_it => cwgues - else - ier=99 - endif - end if - if (ier/=0) return ! this is a fundamental routine, when some not found just return - - cvar( 1)='U ' - cvar( 2)='V ' - cvar( 3)='TV ' - cvar( 4)='Q ' - cvar( 5)='TSEN' - cvar( 6)='OZ ' - cvar( 7)='CW ' - cvar( 8)='DIV ' - cvar( 9)='VOR ' - cvar(10)='PRSL' - cvar(11)='PS ' - cvar(12)='SST ' - cvar(13)='radb' - cvar(14)='pcpb' - cvar(15)='aftb' - - zloc(1) = sum (ges_u_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(2) = sum (ges_v_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(3) = sum (ges_tv_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(4) = sum (ges_q_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(5) = sum (ges_tsen (2:lat1+1,2:lon1+1,1:nsig,ntsig)) - zloc(6) = sum (ges_oz_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(7) = sum (ges_cwmr_it(2:lat1+1,2:lon1+1,1:nsig)) - zloc(8) = sum (ges_div_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(9) = sum (ges_vor_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(10) = sum (ges_prsl (2:lat1+1,2:lon1+1,1:nsig,ntsig)) - zloc(11) = sum (ges_ps_it (2:lat1+1,2:lon1+1 )) - zloc(12) = sum (sfct (2:lat1+1,2:lon1+1, ntsfc)) - zloc(nvars+1) = minval(ges_u_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(nvars+2) = minval(ges_v_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(nvars+3) = minval(ges_tv_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(nvars+4) = minval(ges_q_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(nvars+5) = minval(ges_tsen (2:lat1+1,2:lon1+1,1:nsig,ntsig)) - zloc(nvars+6) = minval(ges_oz_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(nvars+7) = minval(ges_cwmr_it(2:lat1+1,2:lon1+1,1:nsig)) - zloc(nvars+8) = minval(ges_div_it(2:lat1+1,2:lon1+1,1:nsig)) - zloc(nvars+9) = minval(ges_vor_it(2:lat1+1,2:lon1+1,1:nsig)) - zloc(nvars+10) = minval(ges_prsl (2:lat1+1,2:lon1+1,1:nsig,ntsig)) - zloc(nvars+11) = minval(ges_ps_it (2:lat1+1,2:lon1+1 )) - zloc(nvars+12) = minval(sfct (2:lat1+1,2:lon1+1, ntsfc)) - zloc(2*nvars+1) = maxval(ges_u_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(2*nvars+2) = maxval(ges_v_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(2*nvars+3) = maxval(ges_tv_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(2*nvars+4) = maxval(ges_q_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(2*nvars+5) = maxval(ges_tsen (2:lat1+1,2:lon1+1,1:nsig,ntsig)) - zloc(2*nvars+6) = maxval(ges_oz_it (2:lat1+1,2:lon1+1,1:nsig)) - zloc(2*nvars+7) = maxval(ges_cwmr_it(2:lat1+1,2:lon1+1,1:nsig)) - zloc(2*nvars+8) = maxval(ges_div_it(2:lat1+1,2:lon1+1,1:nsig)) - zloc(2*nvars+9) = maxval(ges_vor_it(2:lat1+1,2:lon1+1,1:nsig)) - zloc(2*nvars+10) = maxval(ges_prsl (2:lat1+1,2:lon1+1,1:nsig,ntsig)) - zloc(2*nvars+11) = maxval(ges_ps_it (2:lat1+1,2:lon1+1 )) - zloc(2*nvars+12) = maxval(sfct (2:lat1+1,2:lon1+1, ntsfc)) - zloc(3*nvars+1) = real(lat1*lon1*nsig*ntsig,r_kind) - zloc(3*nvars+2) = real(lat1*lon1*ntsig,r_kind) - zloc(3*nvars+3) = real(lat1*lon1*nsig*ntsig,r_kind) - - -! Gather contributions - call mpi_allgather(zloc,3*nvars+3,mpi_rtype, & - & zall,3*nvars+3,mpi_rtype, mpi_comm_world,ierror) - - if (mype==0) then - zmin=zero - zmax=zero - zavg=zero - zz=SUM(zall(3*nvars+1,:)) - do ii=1,nvars-2 - zavg(ii)=SUM(zall(ii,:))/zz - enddo - zz=SUM(zall(3*nvars+2,:)) - do ii=nvars-1,nvars - zavg(ii)=SUM(zall(ii,:))/zz - enddo - do ii=1,nvars - zmin(ii)=MINVAL(zall( nvars+ii,:)) - zmax(ii)=MAXVAL(zall(2*nvars+ii,:)) - enddo - -! Duplicated part of vector - if (nsclen>0) then - zmin(nvars+1) = minval(predx(:,:)) - zmax(nvars+1) = maxval(predx(:,:)) - zavg(nvars+1) = sum(predx(:,:))/nsclen - endif - if (npclen>0) then - zmin(nvars+2) = minval(predxp(:,:)) - zmax(nvars+2) = maxval(predxp(:,:)) - zavg(nvars+2) = sum(predxp(:,:))/npclen - endif - if (ntclen>0) then - zmin(nvars+3) = minval(predt(:,:)) - zmax(nvars+3) = maxval(predt(:,:)) - zavg(nvars+3) = sum(predt(:,:))/ntclen - endif - - write(6,'(80a)') ('=',ii=1,80) - write(6,'(a,2x,a,10x,a,17x,a,20x,a)') 'Status ', 'Var', 'Mean', 'Min', 'Max' - do ii=1,nvars+3 - write(6,999)sgrep,cvar(ii),zavg(ii),zmin(ii),zmax(ii) - enddo - write(6,'(80a)') ('=',ii=1,80) - endif -999 format(A,1X,A,3(1X,ES20.12)) - - return -end subroutine prt_guess - -subroutine prt_guessfc2(sgrep,use_sfc) -!$$$ subprogram documentation block -! . . . . -! subprogram: prt_guessfc2 -! pgrmmr: todling -! -! abstract: Print some diagnostics about the guess arrays -! -! program history log: -! 2009-01-23 todling - create based on prt_guess -! -! input argument list: -! sgrep - prefix for write statement -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - use kinds, only: r_kind,i_kind - use satthin, only: isli_full,fact10_full,soil_moi_full,soil_temp_full,veg_frac_full,& - soil_type_full,veg_type_full,sfc_rough_full,sst_full,sno_full - use guess_grids, only: ntguessfc - use constants, only: zero - - implicit none - -! Declare passed variables - character(len=*), intent(in ) :: sgrep - logical, intent(in ) :: use_sfc - -! Declare local variables - integer(i_kind), parameter :: nvars=10 - integer(i_kind) ii - integer(i_kind) ntsfc - real(r_kind) :: zall(3*nvars+2),zz - real(r_kind) :: zmin(nvars+2),zmax(nvars+2),zavg(nvars+2) - character(len=4) :: cvar(nvars+2) - -!******************************************************************************* - - ntsfc = ntguessfc - - cvar( 1)='FC10' - cvar( 2)='SNOW' - cvar( 3)='VFRC' - cvar( 4)='SRGH' - cvar( 5)='STMP' - cvar( 6)='SMST' - cvar( 7)='SST ' - cvar( 8)='VTYP' - cvar( 9)='ISLI' - cvar(10)='STYP' - -! Default to -99999.9 if not used. - zall = -99999.9_r_kind ! missing flag - zavg = -99999.9_r_kind ! missing flag - zall(1) = sum (fact10_full ) - zall(2) = sum (sno_full ) - zall(4) = sum (sfc_rough_full) - zall(7) = sum (sst_full ) - zall(9) = sum (isli_full ) - zall(nvars+1) = minval(fact10_full ) - zall(nvars+2) = minval(sno_full ) - zall(nvars+4) = minval(sfc_rough_full) - zall(nvars+7) = minval(sst_full ) - zall(nvars+9) = minval(isli_full ) - zall(2*nvars+1) = maxval(fact10_full ) - zall(2*nvars+2) = maxval(sno_full ) - zall(2*nvars+4) = maxval(sfc_rough_full) - zall(2*nvars+7) = maxval(sst_full ) - zall(2*nvars+9) = maxval(isli_full ) - zall(3*nvars+1) = real(SIZE(fact10_full),r_kind) - zall(3*nvars+2) = real(SIZE(isli_full),r_kind) - - if(use_sfc)then - zall(3) = sum (veg_frac_full ) - zall(5) = sum (soil_temp_full) - zall(6) = sum (soil_moi_full ) - zall(8) = sum (veg_type_full ) - zall(10) = sum (soil_type_full) - zall(nvars+3) = minval(veg_frac_full ) - zall(nvars+5) = minval(soil_temp_full) - zall(nvars+6) = minval(soil_moi_full ) - zall(nvars+8) = minval(veg_type_full ) - zall(nvars+10) = minval(soil_type_full) - zall(2*nvars+3) = maxval(veg_frac_full ) - zall(2*nvars+5) = maxval(soil_temp_full) - zall(2*nvars+6) = maxval(soil_moi_full ) - zall(2*nvars+8) = maxval(veg_type_full ) - zall(2*nvars+10) = maxval(soil_type_full) - end if - - - zz=zall(3*nvars+1) - do ii=1,nvars-3 - if( zall(ii) > -99999.0_r_kind) zavg(ii)=zall(ii)/zz - enddo - zz=zall(3*nvars+2) - do ii=nvars-2,nvars - if( zall(ii) > -99999.0_r_kind) zavg(ii)=zall(ii)/zz - enddo - do ii=1,nvars - zmin(ii)=zall( nvars+ii) - zmax(ii)=zall(2*nvars+ii) - enddo - - write(6,'(80a)') ('=',ii=1,80) - write(6,'(a,2x,a,10x,a,17x,a,20x,a)') 'Status ', 'Var', 'Mean', 'Min', 'Max' - do ii=1,nvars - write(6,999)sgrep,cvar(ii),zavg(ii),zmin(ii),zmax(ii) - enddo - write(6,'(80a)') ('=',ii=1,80) -999 format(A,1X,A,3(1X,ES20.12)) - - - return -end subroutine prt_guessfc2 - -subroutine prt_guesschem(sgrep) -!$$$ subprogram documentation block -! . . . . -! subprogram: prt_guesschem -! prgmmr: hclin -! -! abstract: Print some diagnostics about the chem guess arrays -! -! program history log: -! 2011-09-20 hclin - -! 2013-11-16 todling - revisit return logic -! -! input argument list: -! sgrep - prefix for write statement -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - use kinds, only: r_kind,i_kind - use mpimod, only: ierror,mpi_comm_world,mpi_rtype,npe,mype - use constants, only: zero - use gridmod, only: lat1,lon1,nsig - use guess_grids, only: ntguessig - use gsi_chemguess_mod, only: gsi_chemguess_bundle, gsi_chemguess_get - use gsi_bundlemod, only: gsi_bundlegetpointer - - implicit none - -! Declare passed variables - character(len=*), intent(in ) :: sgrep - -! Declare local variables - integer(i_kind) nvars - integer(i_kind) ii - integer(i_kind) ntsig - real(r_kind),allocatable,dimension(:) :: zloc,zmin,zmax,zavg - real(r_kind),allocatable,dimension(:,:) :: zall - real(r_kind) zz - character(len=5),allocatable,dimension(:) :: cvar - real(r_kind), pointer, dimension(:,:,:) :: ptr3d=>NULL() - integer(i_kind) ier, istatus - -!******************************************************************************* - - ntsig = ntguessig - - call gsi_chemguess_get('aerosols::3d',nvars,istatus) - if(istatus/=0.or.nvars==0) return - - if ( nvars > 0 ) then - allocate(zloc(3*nvars+1)) - allocate(zall(3*nvars+1,npe)) - allocate(zmin(nvars)) - allocate(zmax(nvars)) - allocate(zavg(nvars)) - allocate(cvar(nvars)) - call gsi_chemguess_get ('aerosols::3d',cvar,ier) - endif - - ier = 0 - do ii = 1, nvars - call GSI_BundleGetPointer(GSI_ChemGuess_Bundle(ntsig),cvar(ii),ptr3d,istatus);ier=ier+istatus - if ( ier == 0 ) then - zloc(ii) = sum (ptr3d(2:lat1+1,2:lon1+1,1:nsig)) - zloc(nvars+ii) = minval(ptr3d(2:lat1+1,2:lon1+1,1:nsig)) - zloc(2*nvars+ii) = maxval(ptr3d(2:lat1+1,2:lon1+1,1:nsig)) - zloc(3*nvars+1) = real(lat1*lon1*nsig*ntsig,r_kind) - endif - enddo - -! Gather contributions - call mpi_allgather(zloc,3*nvars+1,mpi_rtype, & - & zall,3*nvars+1,mpi_rtype, mpi_comm_world,ierror) - - if (mype==0) then - zmin=zero - zmax=zero - zavg=zero - zz=SUM(zall(3*nvars+1,:)) - do ii=1,nvars - zavg(ii)=SUM(zall(ii,:))/zz - enddo - do ii=1,nvars - zmin(ii)=MINVAL(zall( nvars+ii,:)) - zmax(ii)=MAXVAL(zall(2*nvars+ii,:)) - enddo - - write(6,'(80a)') ('=',ii=1,80) - write(6,'(a,2x,a,10x,a,17x,a,20x,a)') 'Status ', 'Var', 'Mean', 'Min', 'Max' - do ii=1,nvars - write(6,999)sgrep,cvar(ii),zavg(ii),zmin(ii),zmax(ii) - enddo - write(6,'(80a)') ('=',ii=1,80) - endif -999 format(A,1X,A,3(1X,ES20.12)) - - if ( nvars > 0 ) then - deallocate(zloc) - deallocate(zall) - deallocate(zmin) - deallocate(zmax) - deallocate(zavg) - deallocate(cvar) - endif - - return -end subroutine prt_guesschem - diff --git a/src/radiance_mod.f90 b/src/radiance_mod.f90 deleted file mode 100644 index f1a11431b..000000000 --- a/src/radiance_mod.f90 +++ /dev/null @@ -1,982 +0,0 @@ -module radiance_mod -!$$$ module documentation block -! . . . . -! module: radiance_mod -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 -! -! abstract: This module contains variables and routines related -! to cloud and aerosol usages for radiance assimilation -! -! program history log: -! 2015-07-20 Yanqiu Zhu -! 2016-10-27 Yanqiu - add ATMS -! -! subroutines included: -! sub radiance_mode_init - guess init -! radiance_mode_destroy -! radiance_obstype_init -! radiance_obstype_search -! radiance_obstype_destroy -! radiance_parameter_cloudy_init -! radiance_parameter_aerosol_init -! radiance_ex_obserr -! radiance_ex_biascor -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - -! !USES: - - use kinds, only: r_kind,i_kind - use constants, only: zero,half - use mpimod, only: mype - implicit none - save - -! set subroutines to public - public :: radiance_mode_init - public :: radiance_mode_destroy - public :: radiance_obstype_init - public :: radiance_obstype_search - public :: radiance_obstype_destroy - public :: radiance_parameter_cloudy_init - public :: radiance_parameter_aerosol_init - public :: radiance_ex_obserr - public :: radiance_ex_biascor - - public :: icloud_fwd,icloud_cv,iallsky,cw_cv - public :: n_actual_clouds,n_clouds_fwd,n_clouds_jac - public :: cloud_names,cloud_names_jac,cloud_names_fwd - public :: idx_cw,idx_ql,idx_qi,idx_qr,idx_qs,idx_qg,idx_qh - - public :: iaerosol_fwd,iaerosol_cv,iaerosol - public :: n_actual_aerosols,n_aerosols_fwd,n_aerosols_jac - public :: aerosol_names,aerosol_names_fwd,aerosol_names_jac - - public :: total_rad_type - public :: rad_type_info - public :: cloudy_amsua - public :: cloudy_atms - - public :: rad_obs_type - public :: amsua_type - - interface radiance_ex_obserr - module procedure radiance_ex_obserr_1 - end interface - - interface radiance_ex_biascor - module procedure radiance_ex_biascor_1 - end interface - - character(len=20),save,allocatable,dimension(:) :: cloud_names - character(len=20),save,allocatable,dimension(:) :: cloud_names_fwd - character(len=20),save,allocatable,dimension(:) :: cloud_names_jac - character(len=20),save,allocatable,dimension(:) :: aerosol_names - character(len=20),save,allocatable,dimension(:) :: aerosol_names_fwd - character(len=20),save,allocatable,dimension(:) :: aerosol_names_jac - logical :: icloud_fwd,icloud_cv,iallsky,cw_cv - logical :: iaerosol_fwd,iaerosol_cv,iaerosol - integer(i_kind) :: n_actual_clouds,n_clouds_jac,n_clouds_fwd - integer(i_kind) :: n_actual_aerosols,n_aerosols_fwd,n_aerosols_jac - integer(i_kind) :: idx_cw,idx_ql,idx_qi,idx_qr,idx_qs,idx_qg,idx_qh - - integer(i_kind) :: total_rad_type - - type rad_obs_type - character(10) :: rtype ! instrument - integer(i_kind) :: nchannel ! total channel number -! character(8) :: cfoption ! cloud fraction option: gmao_lcf4crtm, emc_lcf4crtm - logical :: cld_sea_only ! .true. only perform all-sky over ocean - logical :: ex_obserr ! .true. for special obs error assignment - logical :: ex_biascor ! .true. for special bias correction - logical :: cld_effect ! .true. additional cloud effect quality control - logical :: lcloud_fwd,lallsky - integer(i_kind),pointer,dimension(:) :: lcloud4crtm=> NULL() ! -1 clear-sky; 0 forwad operator only; 1 iallsky - logical :: laerosol_fwd,laerosol - integer(i_kind),pointer,dimension(:) :: laerosol4crtm => NULL() ! -1 no aero used; 0 forwad operator only; 1 iaerosol - end type rad_obs_type - - type,EXTENDS(rad_obs_type) :: amsua_type - real(r_kind),allocatable,dimension(:) :: cclr - real(r_kind),allocatable,dimension(:) :: ccld - end type amsua_type - - type(rad_obs_type),save,dimension(:),allocatable :: rad_type_info - type(amsua_type),save :: cloudy_amsua - type(amsua_type),save :: cloudy_atms - -contains - - subroutine radiance_mode_init -!$$$ subprogram documentation block -! . . . -! subprogram: radiance_mode_init -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 -! -! abstract: This routine sets default values for variables used in -! the radiance processing routines. -! -! program history log: -! 2015-07-20 zhu -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - - use kinds, only: i_kind,r_kind - use gsi_metguess_mod, only: gsi_metguess_get - use gsi_chemguess_mod, only: gsi_chemguess_get - use mpeu_util, only: getindex - use control_vectors, only: cvars3d - implicit none - - integer(i_kind) icw_av,iql_av,iqi_av,iqtotal,ier - integer(i_kind) indx_p25,indx_dust1,indx_dust2,ip25_av,idust1_av,idust2_av - -! initialize variables - icloud_fwd=.false. - icloud_cv=.false. - iallsky=.false. - cw_cv=.false. - - n_actual_clouds=0 - n_clouds_fwd=0 - n_clouds_jac=0 - - iaerosol_fwd=.false. - iaerosol_cv=.false. - iaerosol=.false. - - n_actual_aerosols=0 - n_aerosols_fwd=0 - n_aerosols_jac=0 - -! inquire number of clouds - call gsi_metguess_get ( 'clouds::3d', n_actual_clouds, ier ) - if (n_actual_clouds>0) then - allocate(cloud_names(n_actual_clouds)) - call gsi_metguess_get ('clouds::3d', cloud_names, ier) - call gsi_metguess_get ('clouds_4crtm_fwd::3d', n_clouds_fwd, ier) - n_clouds_fwd=max(0,n_clouds_fwd) - if (n_clouds_fwd>0) then - icloud_fwd=.true. - allocate(cloud_names_fwd(max(n_clouds_fwd,1))) - call gsi_metguess_get ('clouds_4crtm_fwd::3d', cloud_names_fwd, ier) - - call gsi_metguess_get ('clouds_4crtm_jac::3d', n_clouds_jac, ier ) - n_clouds_jac=max(0,n_clouds_jac) - if (n_clouds_jac>0) then - allocate(cloud_names_jac(max(n_clouds_jac,1))) - call gsi_metguess_get ('clouds_4crtm_jac::3d', cloud_names_jac, ier) - end if - end if - -! inquire number of clouds to participate in CRTM calculations - call gsi_metguess_get ( 'i4crtm::ql', idx_ql, ier ) - call gsi_metguess_get ( 'i4crtm::qi', idx_qi, ier ) - call gsi_metguess_get ( 'i4crtm::qr', idx_qr, ier ) - call gsi_metguess_get ( 'i4crtm::qs', idx_qs, ier ) - call gsi_metguess_get ( 'i4crtm::qg', idx_qg, ier ) - call gsi_metguess_get ( 'i4crtm::qh', idx_qh, ier ) -! if (idx_ql>10 .or. idx_qi>10 .or. idx_qr>10 .or. idx_qs>10 & -! .or. idx_qg>10 .or. idx_qh>10) icloud_fwd=.true. - -! Determine whether or not cloud-condensate is the control variable -! (ges_cw=ges_ql+ges_qi) - icw_av=getindex(cvars3d,'cw') - iql_av=getindex(cvars3d,'ql') - iqi_av=getindex(cvars3d,'qi') - -! Determine whether or not total moisture (water vapor+total cloud -! condensate) is the control variable - iqtotal=getindex(cvars3d,'qt') - - if (icw_av>0) cw_cv=.true. - if (icw_av>0 .or. iql_av>0 .or. iqi_av>0 .or. iqtotal>0) icloud_cv=.true. - if (icloud_cv .and. icloud_fwd) iallsky=.true. - - end if ! end of (n_actual_clouds>0) - - -! inquire number of aerosols - call gsi_chemguess_get ( 'aerosols::3d', n_actual_aerosols, ier ) - if (n_actual_aerosols > 0) then - iaerosol_fwd=.true. - allocate(aerosol_names(n_actual_aerosols)) - call gsi_chemguess_get ('aerosols::3d',aerosol_names,ier) - indx_p25 = getindex(aerosol_names,'p25') - indx_dust1 = getindex(aerosol_names,'dust1') - indx_dust2 = getindex(aerosol_names,'dust2') - - call gsi_chemguess_get ( 'aerosols_4crtm::3d', n_aerosols_fwd, ier ) - if (n_aerosols_fwd >0) then - allocate(aerosol_names_fwd(n_aerosols_fwd)) - call gsi_chemguess_get ( 'aerosols_4crtm::3d', aerosol_names_fwd, ier) - end if - call gsi_chemguess_get ( 'aerosols_4crtm_jac::3d', n_aerosols_jac, ier ) - if (n_aerosols_jac >0) then - allocate(aerosol_names_jac(n_aerosols_jac)) - call gsi_chemguess_get ( 'aerosols_4crtm_jac::3d', aerosol_names_jac, ier) - end if - endif - -! Determine whether aerosols are control variables - ip25_av=getindex(cvars3d,'p25') - idust1_av=getindex(cvars3d,'dust1') - idust2_av=getindex(cvars3d,'dust2') - if (ip25_av>0 .or. idust1_av>0 .or. idust2_av>0) iaerosol_cv=.true. - - if (iaerosol_cv .and. iaerosol_fwd) iaerosol=.true. - - if (mype==0) then - write(6,*) 'radiance_mode_init: icloud_fwd=',icloud_fwd,' iallsky=',iallsky, & - ' cw_cv=',cw_cv,' iaerosol_fwd=',iaerosol_fwd,' iaerosol=',iaerosol - write(6,*) 'radiance_mode_init: n_actual_clouds=',n_actual_clouds - if (n_actual_clouds>0) write(6,*) 'radiance_mode_init: cloud_names=',cloud_names - write(6,*) 'radiance_mode_init: n_clouds_fwd=',n_clouds_fwd - if (n_clouds_fwd>0) write(6,*) 'radiance_mode_init: cloud_names_fwd=',cloud_names_fwd - write(6,*) 'radiance_mode_init: n_clouds_jac=',n_clouds_jac - if (n_clouds_jac>0) write(6,*) 'radiance_mode_init: cloud_names_jac=',cloud_names_jac - write(6,*) 'radiance_mode_init: n_actual_aerosols=',n_actual_aerosols - if (n_actual_aerosols>0) write(6,*) 'radiance_mode_init: aerosol_names=',aerosol_names - write(6,*) 'radiance_mode_init: n_aerosols_fwd=',n_aerosols_fwd - if (n_aerosols_fwd>0) write(6,*) 'radiance_mode_init: aerosol_names_fwd=',aerosol_names_fwd - write(6,*) 'radiance_mode_init: n_aerosols_jac=',n_aerosols_jac - if (n_aerosols_jac>0) write(6,*) 'radiance_mode_init: aerosol_names_jac=',aerosol_names_jac - end if - - end subroutine radiance_mode_init - - subroutine radiance_mode_destroy -!$$$ subprogram documentation block -! . . . -! subprogram: radiance_mode_destroy -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 -! -! abstract: This routine deallocate arrays -! -! program history log: -! 2015-07-20 zhu -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - - implicit none - - if(allocated(cloud_names)) deallocate(cloud_names) - if(allocated(cloud_names_fwd)) deallocate(cloud_names_fwd) - if(allocated(cloud_names_jac)) deallocate(cloud_names_jac) - - if(allocated(aerosol_names)) deallocate(aerosol_names) - if(allocated(aerosol_names_fwd)) deallocate(aerosol_names_fwd) - if(allocated(aerosol_names_jac)) deallocate(aerosol_names_jac) - - end subroutine radiance_mode_destroy - - subroutine radiance_obstype_init -!$$$ subprogram documentation block -! . . . -! subprogram: radiance_obstype_init -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 -! -! abstract: This routine sets default values for variables used in -! the cloudy/with aerosol radiance processing routines. -! -! program history log: -! 2015-07-20 zhu -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - - use kinds, only: i_kind,r_kind - use radinfo, only: nusis,jpch_rad,icloud4crtm,iaerosol4crtm - use obsmod, only: ndat,dtype,dsis - use gsi_io, only: verbose - implicit none - - logical :: first,diffistr,found - integer(i_kind) :: i,j,k,ii,nn1,nn2,nn - integer(i_kind),dimension(ndat) :: k2i - character(10),dimension(ndat) :: rtype,rrtype,drtype - logical print_verbose - - print_verbose=.false. - if(verbose)print_verbose=.true. -! Cross-check - do j=1,jpch_rad - if (icloud4crtm(j)>=0) then - if (.not. iallsky) icloud4crtm(j)=0 - if (.not. icloud_fwd) icloud4crtm(j)=-1 - end if - if (iaerosol4crtm(j)>=0) then - if (.not. iaerosol) iaerosol4crtm(j)=0 - if (.not. iaerosol_fwd) iaerosol4crtm(j)=-1 - end if - end do - - if (icloud_fwd .and. all(icloud4crtm<0)) then - icloud_fwd=.false. - iallsky=.false. - n_clouds_fwd=0 - n_clouds_jac=0 - cloud_names_fwd=' ' - cloud_names_jac=' ' - end if - - if (iaerosol_fwd .and. all(iaerosol4crtm<0)) then - iaerosol_fwd=.false. - iaerosol=.false. - n_aerosols_fwd=0 - n_aerosols_jac=0 - aerosol_names_fwd=' ' - aerosol_names_jac=' ' - end if - - if (iallsky .and. all(icloud4crtm<1)) then - iallsky=.false. - n_clouds_jac=0 - cloud_names_jac=' ' - end if - - if (iaerosol .and. all(iaerosol4crtm<1)) then - iaerosol=.false. - n_aerosols_jac=0 - aerosol_names_jac=' ' - end if - -! determine rads type - drtype='other' - do i=1,ndat - rtype(i)=dtype(i) ! rtype - observation types to process - if (index(dtype(i),'amsre') /= 0) rtype(i)='amsre' - if (index(dtype(i),'ssmis') /= 0) rtype(i)='ssmis' - if (index(dtype(i),'sndr') /= 0) rtype(i)='sndr' - if (index(dtype(i),'hirs') /= 0) rtype(i)='hirs' - if (index(dtype(i),'avhrr') /= 0) rtype(i)='avhrr' - if (index(dtype(i),'modis') /= 0) rtype(i)='modis' - if (index(dtype(i),'seviri') /= 0) rtype(i)='seviri' - - if(rtype(i) == 'hirs' .or. rtype(i) == 'sndr' .or. rtype(i) == 'seviri' .or. & - rtype(i) == 'airs' .or. rtype(i) == 'amsua' .or. rtype(i) == 'msu' .or. & - rtype(i) == 'iasi' .or. rtype(i) == 'amsub' .or. rtype(i) == 'mhs' .or. & - rtype(i) == 'hsb' .or. rtype(i) == 'goes_img' .or. rtype(i) == 'ahi' .or. & - rtype(i) == 'avhrr' .or. rtype(i) == 'amsre' .or. rtype(i) == 'ssmis' .or. & - rtype(i) == 'ssmi' .or. rtype(i) == 'atms' .or. rtype(i) == 'cris' .or. & - rtype(i) == 'amsr2' .or. rtype(i) == 'gmi' .or. rtype(i) == 'saphir' ) then - drtype(i)='rads' - end if - end do - -! Determine total rad types - k=0 - k2i=0 - first=.true. - rrtype='' - do i=1,ndat - if (drtype(i) /= 'rads') cycle - - found=.false. - if (first) then - k=k+1 - rrtype(k)=rtype(i) - k2i(k)=i - first=.false. - else - do j=1,k - if (trim(rtype(i)) == trim(rrtype(j))) then - found=.true. - exit - end if - end do - if (.not. found) then - k=k+1 - rrtype(k)=rtype(i) - k2i(k)=i - end if - end if - end do - total_rad_type=k - if (mype==0) write(6,*) 'radiance_obstype_init: total_rad_type=', k,' types are: ', rrtype(1:total_rad_type) - - if (total_rad_type<=0) return - - allocate(rad_type_info(total_rad_type)) - - do k=1, total_rad_type - rad_type_info(k)%rtype=rrtype(k) - rad_type_info(k)%cld_sea_only=.false. - rad_type_info(k)%ex_obserr=.false. - rad_type_info(k)%ex_biascor=.false. - rad_type_info(k)%cld_effect=.false. - rad_type_info(k)%lcloud_fwd=.false. - rad_type_info(k)%lallsky=.false. - rad_type_info(k)%laerosol_fwd=.false. - rad_type_info(k)%laerosol=.false. - - ii=k2i(k) - first=.true. - nn1=0 - nn2=0 - do j=1,jpch_rad - if (j==jpch_rad) then - diffistr = .true. - else - diffistr = trim(nusis(j))/=trim(nusis(j+1)) - end if - if (trim(dsis(ii))==trim(nusis(j))) then -! if (index(trim(nusis(j)),trim(rrtype(k))) /= 0) then - if (first) then - nn1=j - first=.false. - else - nn2=j - end if - if (diffistr) exit - end if - end do - if (nn1/=0 .and. nn2/=0) then - rad_type_info(k)%nchannel=nn2-nn1+1 - else - cycle - end if - -! determine usages of cloud and aerosol in each type - allocate(rad_type_info(k)%lcloud4crtm(rad_type_info(k)%nchannel)) - allocate(rad_type_info(k)%laerosol4crtm(rad_type_info(k)%nchannel)) - nn=0 - do j=nn1,nn2 - nn=nn+1 - rad_type_info(k)%lcloud4crtm(nn)=icloud4crtm(j) - rad_type_info(k)%laerosol4crtm(nn)=iaerosol4crtm(j) - - if (icloud4crtm(j)<0 .and. iaerosol4crtm(j)<0) cycle - if (.not. rad_type_info(k)%lallsky) then - if (icloud4crtm(j)==1) then - rad_type_info(k)%lallsky=.true. - rad_type_info(k)%lcloud_fwd=.true. - end if - end if - if (.not. rad_type_info(k)%lcloud_fwd) then - if (icloud4crtm(j)==0) rad_type_info(k)%lcloud_fwd=.true. - end if - if (.not. rad_type_info(k)%laerosol) then - if (iaerosol4crtm(j)==1) then - rad_type_info(k)%laerosol=.true. - rad_type_info(k)%laerosol_fwd=.true. - end if - end if - if (.not. rad_type_info(k)%laerosol_fwd) then - if (iaerosol4crtm(j)==0) rad_type_info(k)%laerosol_fwd=.true. - end if - end do - if (mype==0 .and. print_verbose) & - write(6,*) 'radiance_obstype_init: type=', rad_type_info(k)%rtype, & - ' nch=',rad_type_info(k)%nchannel, & - ' lcloud_fwd=',rad_type_info(k)%lcloud_fwd, & - ' lallsky=',rad_type_info(k)%lallsky, & - ' laerosol_fwd=',rad_type_info(k)%laerosol_fwd, & - ' laerosol=',rad_type_info(k)%laerosol - end do ! end total_rad_type - - end subroutine radiance_obstype_init - - subroutine radiance_obstype_search(obstype,radmod) -!$$$ subprogram documentation block -! . . . -! subprogram: radiance_obstype_search find the rad_type_info(i) that -! matches the input obstype -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-08-20 -! -! abstract: -! -! program history log: -! 2015-08-20 zhu -! -! input argument list: -! obstype -! -! output argument list: -! radmod -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - implicit none - character(10) :: obstype - type(rad_obs_type) :: radmod - logical match - integer(i_kind) i - - if (total_rad_type<=0) return - - match=.false. - do i=1,total_rad_type - if (trim(rad_type_info(i)%rtype)=='msu') then - match=trim(obstype)==trim(rad_type_info(i)%rtype) - else - match=index(trim(obstype),trim(rad_type_info(i)%rtype)) /= 0 - end if - if (match) then -! if (mype==0) write(6,*) 'radiance_obstype_search: obstype=',obstype, & -! ' rtype=',rad_type_info(i)%rtype - radmod%rtype = rad_type_info(i)%rtype - radmod%nchannel = rad_type_info(i)%nchannel - radmod%cld_sea_only = rad_type_info(i)%cld_sea_only - radmod%cld_effect = rad_type_info(i)%cld_effect - radmod%ex_obserr = rad_type_info(i)%ex_obserr - radmod%ex_biascor = rad_type_info(i)%ex_biascor - - radmod%lcloud_fwd = rad_type_info(i)%lcloud_fwd - radmod%lallsky = rad_type_info(i)%lallsky - radmod%lcloud4crtm => rad_type_info(i)%lcloud4crtm - - radmod%laerosol_fwd = rad_type_info(i)%laerosol_fwd - radmod%laerosol = rad_type_info(i)%laerosol - radmod%laerosol4crtm => rad_type_info(i)%laerosol4crtm - return - end if - end do - if (mype==0) write(6,*) 'radiance_obstype_search type not found: obstype=',obstype - - if (.not. match) then - if (mype==0) write(6,*) 'radiance_obstype_search: #WARNING# obstype=',obstype,' not found in rtype' - end if - end subroutine radiance_obstype_search - - - subroutine radiance_obstype_destroy -!$$$ subprogram documentation block -! . . . -! subprogram: radiance_obstype_destroy -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 -! -! abstract: -! -! program history log: -! 2015-07-20 zhu -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - implicit none - - integer(i_kind) :: k - - do k=1, total_rad_type - if(associated(rad_type_info(k)%lcloud4crtm)) deallocate(rad_type_info(k)%lcloud4crtm) - if(associated(rad_type_info(k)%laerosol4crtm)) deallocate(rad_type_info(k)%laerosol4crtm) - end do - if(allocated(rad_type_info)) deallocate(rad_type_info) - - end subroutine radiance_obstype_destroy - - - subroutine radiance_parameter_cloudy_init -!$$$ subprogram documentation block -! . . . -! subprogram: radiance_parameter_cloudy_init -! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 -! -! abstract: This routine sets default values for variables used in -! the cloudy radiance processing routines. -! -! program history log: -! 2015-07-20 zhu -! 2016-10-27 zhu - add ATMS -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - - use kinds, only: i_kind,r_kind - use mpeu_util, only: gettablesize, gettable - implicit none - - character(len=*),parameter:: fixfilename='cloudy_radiance_info.txt' - character(len=*),parameter:: toptablename='radiance_mod_instr_input' - integer(i_kind) :: lunin - character(len=20) :: tablename - character(len=10) :: obsname - character(len=8) :: obsloc ! global, sea, or, land ... - logical :: ex_obserr,ex_biascor,cld_effect - logical :: pcexist - logical :: obs_found - - integer(i_kind) i,ii,istr,ntot,nrows - character(len=256),allocatable,dimension(:):: utable - - if (.not. icloud_fwd .or. total_rad_type<=0) return - - inquire(file=fixfilename,exist=pcexist) - if (.not. pcexist) then - write(6,*)'radiance_parameter_cloudy_init: cloudy_radiance_info.txt is missing' - call stop2(79) - end if - lunin=11 - open(lunin,file=fixfilename,form='formatted') - -! Scan file for desired table first and get size of table - call gettablesize(toptablename,lunin,ntot,nrows) - if (mype==0) write(6,*) 'radiance_parameter_cloudy_init: ',toptablename, nrows - if(nrows==0) then - return - endif - -! Get contents of table - allocate(utable(nrows)) - call gettable(toptablename,lunin,ntot,nrows,utable) - - do ii=1,nrows -! read(utable(ii),*) obsname,obsloc,ex_obserr,ex_biascor,cld_effect,cfoption - read(utable(ii),*) obsname,obsloc,ex_obserr,ex_biascor,cld_effect - if (mype==0) write(6,*) obsname,obsloc,ex_obserr,ex_biascor,cld_effect - - obs_found=.false. - do i=1,total_rad_type - if (index(trim(rad_type_info(i)%rtype),trim(obsname)) /= 0) then - obs_found=.true. - istr=i - if (trim(obsloc)=='sea') rad_type_info(i)%cld_sea_only=.true. - rad_type_info(i)%ex_obserr=ex_obserr - rad_type_info(i)%ex_biascor=ex_biascor - rad_type_info(i)%cld_effect=cld_effect - - if (.not. rad_type_info(i)%lcloud_fwd) then - rad_type_info(i)%cld_sea_only=.false. - rad_type_info(i)%cld_effect=.false. - rad_type_info(i)%ex_obserr=.false. - rad_type_info(i)%ex_biascor=.false. - end if - - if (mype==0) write(6,*) 'cloudy_radiance_info for ', trim(obsname),& - ' cld_sea_only=', rad_type_info(i)%cld_sea_only, & - ' ex_obserr=', rad_type_info(i)%ex_obserr, & - ' ex_biascor=', rad_type_info(i)%ex_biascor - - if (trim(obsname)=='amsua') then - cloudy_amsua%nchannel=rad_type_info(i)%nchannel - cloudy_amsua%lcloud_fwd=rad_type_info(i)%lcloud_fwd - cloudy_amsua%lallsky=rad_type_info(i)%lallsky - cloudy_amsua%lcloud4crtm=>rad_type_info(i)%lcloud4crtm - cloudy_amsua%laerosol_fwd=rad_type_info(i)%laerosol_fwd - cloudy_amsua%laerosol=rad_type_info(i)%laerosol - cloudy_amsua%laerosol4crtm=>rad_type_info(i)%laerosol4crtm - end if - - if (trim(obsname)=='atms') then - cloudy_atms%nchannel=rad_type_info(i)%nchannel - cloudy_atms%lcloud_fwd=rad_type_info(i)%lcloud_fwd - cloudy_atms%lallsky=rad_type_info(i)%lallsky - cloudy_atms%lcloud4crtm=>rad_type_info(i)%lcloud4crtm - cloudy_atms%laerosol_fwd=rad_type_info(i)%laerosol_fwd - cloudy_atms%laerosol=rad_type_info(i)%laerosol - cloudy_atms%laerosol4crtm=>rad_type_info(i)%laerosol4crtm - end if - exit - end if - end do - if (.not. obs_found) cycle - -! allocate space for entries from table, Obtain table contents - tablename='obs_'//trim(obsname) - -! amsua - if (trim(obsname)=='amsua') then - allocate(cloudy_amsua%cclr(cloudy_amsua%nchannel), & - cloudy_amsua%ccld(cloudy_amsua%nchannel)) - call amsua_table(trim(tablename),lunin,cloudy_amsua%nchannel,cloudy_amsua%cclr,cloudy_amsua%ccld) - end if - -! atms - if (trim(obsname)=='atms') then - allocate(cloudy_atms%cclr(cloudy_atms%nchannel), & - cloudy_atms%ccld(cloudy_atms%nchannel)) - call amsua_table(trim(tablename),lunin,cloudy_atms%nchannel,cloudy_atms%cclr,cloudy_atms%ccld) - end if - - enddo ! end of nrows - deallocate(utable) - close(lunin) - end subroutine radiance_parameter_cloudy_init - - - subroutine amsua_table(filename,lunin,nchal,cclr,ccld) -!$$$ subprogram documentation block -! . . . -! subprogram: amsua_table -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-09-10 -! -! abstract: This routine retrieves parameters used for AMSUA all-sky radiance -! -! program history log: -! 2015-09-10 zhu -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - use kinds, only: i_kind,r_kind - use mpeu_util, only: gettablesize - use mpeu_util, only: gettable - use gsi_io, only: verbose - implicit none - - character(len=*), intent(in) :: filename - integer(i_kind) , intent(in) :: lunin - integer(i_kind) , intent(in) :: nchal - real(r_kind) , dimension(nchal), intent(inout) :: cclr,ccld - - integer(i_kind) ii,ntot,nrows,ich0 - real(r_kind) cclr0,ccld0 - character(len=256),allocatable,dimension(:):: utable - logical print_verbose - - print_verbose=.false. - if(verbose .and. mype == 0)print_verbose=.true. -! Initialize the arrays - cclr(:)=zero - ccld(:)=zero - -! Scan file for desired table first and get size of table - call gettablesize(filename,lunin,ntot,nrows) - if (print_verbose) write(6,*) 'amsua_table: ',filename, nrows - if(nrows==0) then - return - endif - -! Get contents of table - allocate(utable(nrows)) - call gettable(filename,lunin,ntot,nrows,utable) - -! Retrieve each token of interest from table - do ii=1,nrows - read(utable(ii),*) ich0,cclr0,ccld0 - cclr(ich0)=cclr0 - ccld(ich0)=ccld0 - enddo - deallocate(utable) - - if (print_verbose) then - write(6,*) 'amsua_table: ich cclr ccld ' - do ii=1,nchal - write(6,*) ii,cclr(ii),ccld(ii) - end do - end if - - end subroutine amsua_table - - subroutine radiance_parameter_cloudy_destroy -!$$$ subprogram documentation block -! . . . -! subprogram: radiance_parameter_cloudy_init -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-07-20 -! -! abstract: This routine sets default values for variables used in -! the cloudy radiance processing routines. -! -! program history log: -! 2015-07-20 zhu -! 2016-10-27 zhu - add ATMS -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - - if (allocated(cloudy_amsua%cclr)) deallocate(cloudy_amsua%cclr) - if (allocated(cloudy_amsua%ccld)) deallocate(cloudy_amsua%ccld) - if (allocated(cloudy_atms%cclr)) deallocate(cloudy_atms%cclr) - if (allocated(cloudy_atms%ccld)) deallocate(cloudy_atms%ccld) - - end subroutine radiance_parameter_cloudy_destroy - - subroutine radiance_parameter_aerosol_init - implicit none - - if (.not. iaerosol_fwd) return - end subroutine radiance_parameter_aerosol_init - - subroutine radiance_ex_obserr_1(radmod,nchanl,clwp_amsua,clw_guess_retrieval, & - tnoise,tnoise_cld,error0) -!$$$ subprogram documentation block -! . . . -! subprogram: radiance_ex_obserr_1 -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-09-10 -! -! abstract: This routine includes extra observation error assignment routines. -! -! program history log: -! 2015-09-10 zhu -! 2016-10-27 zhu - add ATMS -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - use kinds, only: i_kind,r_kind - implicit none - - integer(i_kind),intent(in) :: nchanl - real(r_kind),intent(in) :: clwp_amsua,clw_guess_retrieval - real(r_kind),dimension(nchanl),intent(in):: tnoise,tnoise_cld - real(r_kind),dimension(nchanl),intent(inout) :: error0 - type(rad_obs_type),intent(in) :: radmod - - integer(i_kind) :: i - real(r_kind) :: clwtmp - real(r_kind),dimension(nchanl) :: cclr,ccld - - if (.not. radmod%ex_obserr) return - - if (trim(radmod%rtype) =='amsua') then - do i=1,nchanl - cclr(i)=cloudy_amsua%cclr(i) - ccld(i)=cloudy_amsua%ccld(i) - end do - end if - if (trim(radmod%rtype) =='atms') then - do i=1,nchanl - cclr(i)=cloudy_atms%cclr(i) - ccld(i)=cloudy_atms%ccld(i) - end do - end if - - do i=1,nchanl - clwtmp=half*(clwp_amsua+clw_guess_retrieval) - if(clwtmp <= cclr(i)) then - error0(i) = tnoise(i) - else if(clwtmp > cclr(i) .and. clwtmp < ccld(i)) then - error0(i) = tnoise(i) + (clwtmp-cclr(i))* & - (tnoise_cld(i)-tnoise(i))/(ccld(i)-cclr(i)) - else - error0(i) = tnoise_cld(i) - endif - end do - return - - end subroutine radiance_ex_obserr_1 - - subroutine radiance_ex_biascor_1(radmod,nchanl,tsim_bc,tsavg5,zasat, & - clw_guess_retrieval,clwp_amsua,cld_rbc_idx,ierrret) -!$$$ subprogram documentation block -! . . . -! subprogram: radiance_ex_biascor_1 -! -! prgrmmr: yanqiu zhu org: np23 date: 2015-09-20 -! -! abstract: This routine include extra radiance bias correction routines. -! -! program history log: -! 2015-09-20 zhu -! 2016-10-27 zhu - add ATMS -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP -! -!$$$ end documentation block - use kinds, only: i_kind,r_kind - use clw_mod, only: ret_amsua - implicit none - - integer(i_kind) ,intent(in ) :: nchanl - real(r_kind),dimension(nchanl) ,intent(in ) :: tsim_bc - real(r_kind) ,intent(in ) :: tsavg5,zasat - real(r_kind),dimension(nchanl) ,intent(inout) :: cld_rbc_idx - real(r_kind) ,intent(inout) :: clwp_amsua - real(r_kind) ,intent(inout) :: clw_guess_retrieval - type(rad_obs_type) ,intent(in) :: radmod - integer(i_kind) ,intent( out) :: ierrret - - integer(i_kind) :: i - real(r_kind),dimension(nchanl) :: cclr - -! call ret_amsua(tb_obs,nchanl,tsavg5,zasat,clwp_amsua,ierrret) - call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) - - if (trim(radmod%rtype) =='amsua') then - do i=1,nchanl - cclr(i)=cloudy_amsua%cclr(i) - end do - end if - if (trim(radmod%rtype) =='atms') then - do i=1,nchanl - cclr(i)=cloudy_atms%cclr(i) - end do - end if - - do i=1,nchanl - if ((clwp_amsua-cclr(i))*(clw_guess_retrieval-cclr(i))=0.005_r_kind) cld_rbc_idx(i)=zero - end do - return - - end subroutine radiance_ex_biascor_1 -end module radiance_mod - diff --git a/src/read_aerosol.f90 b/src/read_aerosol.f90 deleted file mode 100644 index cfb5898de..000000000 --- a/src/read_aerosol.f90 +++ /dev/null @@ -1,370 +0,0 @@ -subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, & - obstype,twind,sis,ithin,rmesh, & - mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_aerosol read aerosol data -! prgmmr: hchuang org: np23 date: 2009-01-26 -! -! abstract: This routine reads MODIS aerosol total column AOD observations. -! ONLY total column values are read in. The routine has -! the ability to read both IEEE and BUFR format MODIS -! aerosol data files. -! -! When running the gsi in regional mode, the code only -! retains those observations that fall within the regional -! domain -! -! program history log: -! 2009-04-08 Huang - modified from read_ozone to read in MODIS AEROSOL data -! 2010-10-20 hclin - modified for total aod in channels -! 2011-01-05 hclin - added three more BUFR records (STYP DBCF QAOD) -! 2011-08-01 lueken - changed F90 to f90 (no machine logic) -! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) -! 2015-02-23 Rancic/Thomas - add thin4d to time window logical -! 2015-10-01 guo - calc ob location once in deg -! -! input argument list: -! obstype - observation type to process -! jsatid - satellite id to read -! infile - unit from which to read aerosol data -! gstime - analysis time in minutes from reference date -! lunout - unit to which to write data for further processing -! obstype - observation type to process -! twind - input group time window (hours) -! sis - satellite/instrument/sensor indicator -! ithin - flag to thin data -! rmesh - thinning mesh size (km) -! mype - mpi task id -! mype_root - "root" task for sub-communicator -! mype_sub - mpi task id within sub-communicator -! npe_sub - number of data read tasks -! mpi_comm_sub - sub-communicator for data read -! -! output argument list: -! nread - number of modis aerosol observations read -! ndata - number of modis aerosol profiles retained for further processing -! nodata - number of modis aerosol observations retained for further processing -! nobs - array of observations on each subdomain for each processor -! -! remarks: -! -! attributes: -! language: f90 -! machine: IBM AIX Cirrus -! -!$$$ - use kinds, only: r_kind, r_double, i_kind - use gridmod, only: nlat, nlon, regional, tll2xy, rlats, rlons - use chemmod, only: aod_qa_limit, luse_deepblue - use constants, only: deg2rad, zero, two, three, four, r60inv - use obsmod, only: rmiss_single - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d - use satthin, only: itxmax,makegrids,destroygrids,checkob, & - finalcheck,map2tgrid,score_crit - use mpimod, only: npe - implicit none -! -! Declare local parameters - real(r_kind), parameter :: r360 = 360.0_r_kind -! -! Declare passed variables -! - character(len=*),intent(in) :: obstype, infile, jsatid - character(len=20),intent(in) :: sis - integer(i_kind), intent(in) :: lunout, ithin - integer(i_kind), intent(inout) :: nread - integer(i_kind),dimension(npe), intent(inout) :: nobs - integer(i_kind), intent(inout) :: ndata, nodata - integer(i_kind) ,intent(in) :: mype_root - integer(i_kind) ,intent(in) :: mype_sub - integer(i_kind) ,intent(in) :: npe_sub - integer(i_kind) ,intent(in) :: mpi_comm_sub - real(r_kind), intent(in) :: gstime, twind, rmesh -! -! Declare local variables -! - logical :: outside, iuse - - character (len= 8) :: subset - character (len=10) :: date - - integer(i_kind) :: naerodat - integer(i_kind) :: idate, jdate, ksatid, iy, iret, im, ihh, idd - integer(i_kind) :: lunin = 10 - integer(i_kind) :: nmind, i, n - integer(i_kind) :: k, ilat, ilon, nreal, nchanl - integer(i_kind) :: kidsat - integer(i_kind), dimension(5) :: idate5 -! -!| NC008041 | SAID AEROSOL CLONH CLATH YYMMDD HHMMSS SOZA SOLAZI | -!| NC008041 | SCATTA OPTD AEROTP | -! -!| YYMMDD | YEAR MNTH DAYS | -!| | | -!| HHMMSS | HOUR MINU SECO | -! -! SAID Satellite identifier code table (eg, 783 == 'TERRA') -! AEROSOL Aerosol Optical Depth (AOD) source code table (eg, 5 == 'AATSR' ) -! YEAR Year -! MNTH Month -! DAYS Day -! HOUR Hour -! MINU Minute -! SECO Second -! CLATH Latitude (high accuracy) degree (5 decimal precision) -! CLONH Longitude (high accuracy) degree (5 decimal precision) -! SOLAZI Solar azimuth degree (2 decimal precision) -! SOZA Solar zenith angle degree (2 decimal precision) -! OPTD Optical depth numeric -! SCATTA Scattering angle degree (2 decimal precsion) -! AEROTP Aerosol type land code table (eg, 1 == 'DUST', 2 == 'SULFATE') -! -! 0-15-195 - AEROTP (Aerosol land type) -! -! CODE DESCRIPTION -! ==== =========== -! 0 Mixed -! 1 Dust -! 2 Sulfate -! 3 Smoke -! 4 Heavy absorbing smoke -! 5-14 Reserved -! 15 Missing value -! - character (len= 4) :: aerostr = 'OPTD' - character (len=53) :: aerogstr = & - 'SAID CLATH CLONH YEAR MNTH DAYS HOUR MINU SOZA SOLAZI' - character (len=14) :: flagstr = 'STYP DBCF QAOD' - - integer(i_kind) :: itx, itt, irec - - real(r_kind) :: tdiff, sstime, dlon, dlat, t4dv, timedif, crit1, dist1 - real(r_kind) :: slons0, slats0, rsat, solzen, azimuth, dlat_earth, dlon_earth - real(r_kind) :: dlat_earth_deg, dlon_earth_deg - real(r_kind) :: styp, dbcf, qaod - real(r_kind),dimension(0:6):: rlndsea - - real(r_kind), allocatable, dimension(:,:) :: aeroout - real(r_kind), allocatable, dimension(:) :: dataaod - integer(i_kind),allocatable,dimension(:) :: nrec - real(r_double), dimension( 10) :: hdraerog - real(r_double) :: aod_550 - real(r_double), dimension(3) :: aod_flags - -!************************************************************************** -! Set constants. Initialize variables - rsat=999._r_kind - ! output position of LON and LAT - ilon=3 - ilat=4 - nread = 0 - ndata = 0 - nodata = 0 - - ! Set rlndsea for types we would prefer selecting - rlndsea(0) = zero ! styp 0: water - rlndsea(1) = 15._r_kind ! styp 1: coast - rlndsea(2) = 20._r_kind ! styp 2: desert - rlndsea(3) = 10._r_kind ! styp 3: land - rlndsea(4) = 25._r_kind ! styp 4: deep blue - rlndsea(5) = 30._r_kind ! styp 5: nnr ocean - rlndsea(6) = 35._r_kind ! styp 6: nnr land - - -! Make thinning grids - call makegrids(rmesh,ithin) - - if ( obstype == 'modis_aod' ) then -! - open(lunin,file=trim(infile),form='unformatted') - call openbf(lunin,'IN',lunin) - call datelen(10) - call readmg(lunin,subset,idate,iret) - - if ( iret == 0 ) then -! - if (subset == 'NC008041') then - write(6,*)'READ_AEROSOL: MODIS data type, subset = ',subset - ! Set dependent variables and allocate arrays - nreal=11 !9 - nchanl=20 - naerodat=nreal+nchanl - allocate (aeroout(naerodat,itxmax),nrec(itxmax)) - allocate (dataaod(nchanl)) - - iy = 0 - im = 0 - idd= 0 - ihh= 0 - write(date,'( i10)') idate - read (date,'(i4,3i2)') iy,im,idd,ihh - write(6,'(''READ_AEROSOL: aerosol bufr file '',a,'' date is '',i4,4i2.2,a)')trim(infile),iy,im,idd,ihh - - nrec=999999 - irec=0 - read_modis: do - irec=irec+1 - call readsb(lunin,iret) - if (iret/=0) then - call readmg(lunin,subset,jdate,iret) - if (iret/=0) exit read_modis - cycle read_modis - endif - - ! extract header information - call ufbint(lunin,hdraerog,10,1,iret,aerogstr) - rsat = hdraerog(1); ksatid=rsat - - if ( jsatid == 'terra' ) kidsat = 783 - if ( jsatid == 'aqua' ) kidsat = 784 - - if ( ksatid /= kidsat ) cycle read_modis - - ! Convert observation location to radians - slats0= hdraerog(2) - slons0= hdraerog(3) - if(slons0< zero) slons0=slons0+r360 - if(slons0>=r360) slons0=slons0-r360 - dlat_earth_deg = slats0 - dlon_earth_deg = slons0 - dlat_earth = slats0 * deg2rad - dlon_earth = slons0 * deg2rad - - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if(outside) cycle read_modis - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif - - solzen = hdraerog(9) - azimuth = hdraerog(10) - - ! Convert observation time to relative time - idate5(1) = hdraerog(4) !year - idate5(2) = hdraerog(5) !month - idate5(3) = hdraerog(6) !day - idate5(4) = hdraerog(7) !hour - idate5(5) = hdraerog(8) !minute - - ! extract total column aod 1 value 'OPTD' as defined in aerostr - call ufbint(lunin,aod_550,1,1,iret,aerostr) - - call w3fs21(idate5,nmind) - t4dv=real((nmind-iwinbgn),r_kind)*r60inv - sstime=real(nmind,r_kind) - tdiff=(sstime-gstime)*r60inv - if (l4dvar.or.l4densvar) then - if(t4dvwinlen) cycle read_modis - else - if ( abs(tdiff) > twind ) cycle read_modis - end if - - nread = nread + 1 !nread = nread + nchanl - - if (thin4d) then - timedif = zero - else - timedif = two*abs(tdiff) ! range: 0 to 6 - endif - - crit1 = 0.01_r_kind + timedif - - if ( aod_550 > 1.0e+10_r_double ) cycle read_modis - - ! extract STYP, DBCF, and QAOD - call ufbint(lunin,aod_flags,3,1,iret,flagstr) - styp = rmiss_single - dbcf = rmiss_single - qaod = rmiss_single - if ( aod_flags(1) < 1.0e+10_r_double ) styp = aod_flags(1) - if ( aod_flags(2) < 1.0e+10_r_double ) dbcf = aod_flags(2) - if ( aod_flags(3) < 1.0e+10_r_double ) qaod = aod_flags(3) - - if ( .not. luse_deepblue .and. nint(styp)==4 ) cycle read_modis - if ( qaod < aod_qa_limit ) cycle read_modis - - ! Map obs to thinning grid - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) - if ( .not. iuse ) cycle read_modis - - if ( (styp > rmiss_single) .and. (styp >= zero .and. styp <= four) ) then - crit1 = crit1 + rlndsea(nint(styp)) - end if - !if ( (dbcf > rmiss_single) .and. (dbcf >= zero .and. dbcf <= three) ) then - ! crit1 = crit1 + 10.0_r_kind*(four-dbcf) - !end if - if ( (qaod > rmiss_single) .and. (qaod >= aod_qa_limit .and. qaod <= three) ) then - crit1 = crit1 + 10.0_r_kind*(four-qaod) - end if - call checkob(dist1,crit1,itx,iuse) - if ( .not. iuse ) cycle read_modis - - ! Compute "score" for observation. All scores>=0.0. Lowest score is "best" - call finalcheck(dist1,crit1,itx,iuse) - if ( .not. iuse ) cycle read_modis - - dataaod = rmiss_single - dataaod(4) = aod_550 - - aeroout( 1,itx) = rsat - aeroout( 2,itx) = tdiff - aeroout( 3,itx) = dlon ! grid relative longitude - aeroout( 4,itx) = dlat ! grid relative latitude - aeroout( 5,itx) = dlon_earth_deg ! earth relative longitude (degrees) - aeroout( 6,itx) = dlat_earth_deg ! earth relative latitude (degrees) - aeroout( 7,itx) = qaod ! total column AOD error flag - aeroout( 8,itx) = solzen ! solar zenith angle - aeroout( 9,itx) = azimuth ! solar azimuth angle - aeroout(10,itx) = styp ! surface type - aeroout(11,itx) = dbcf ! deep blue confidence flag - do i = 1, nchanl - aeroout(i+nreal,itx) = dataaod(i) - end do - nrec(itx)=irec - - end do read_modis - - call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,& - naerodat,itxmax,nread,ndata,aeroout,score_crit,nrec) - - if ( mype_sub == mype_root ) then - do n = 1, ndata - do i = 1, nchanl - if ( aeroout(i+nreal,n) > rmiss_single ) nodata = nodata + 1 - end do - end do - ! Write final set of "best" observations to output file - call count_obs(ndata,naerodat,ilat,ilon,aeroout,nobs) - write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) ((aeroout(k,n),k=1,naerodat),n=1,ndata) - end if - - ! Deallocate local arrays - deallocate(aeroout) - deallocate(dataaod) - - ! End of MODIS bufr block - else ! subset /= NC008041 - write(6,*)'READ_AEROSOL: *** WARNING: unknown aerosol data type, subset=',subset - write(6,*)' infile=',infile, ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid - write(6,*)' SKIP PROCESSING OF THIS MODIS FILE' - endif - - else ! read subset iret /= 0 - write(6,*)'READ_AEROSOL: *** WARNING: read subset error, obstype=',obstype,', iret=',iret - end if - call closbf(lunin) - close(lunin) - else ! obstype /= 'modis' - write(6,*)'READ_AEROSOL: *** WARNING: unknown aerosol input type, obstype=',obstype - endif - - ! Deallocate satthin arrays - call destroygrids - -end subroutine read_aerosol diff --git a/src/read_co.f90 b/src/read_co.f90 deleted file mode 100644 index 65f1d7303..000000000 --- a/src/read_co.f90 +++ /dev/null @@ -1,228 +0,0 @@ -subroutine read_co(nread,ndata,nodata,infile,gstime,lunout, & - obstype,sis,nobs) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_co read co data -! prgmmr: yang org: np23 date: 1998-05-15 -! -! abstract: This routine reads CO observations. The initial code is taken -! from read_ozone. - -! program history log: - -! 2010-03-30 Tangborn, initial code. -! 2011-08-01 Lueken - replaced F90 with f90 (no machine logic), fixed indentation -! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) -! -! input argument list: -! obstype - observation type to process -! infile - unit from which to read co data -! gstime - analysis time in minutes from reference date -! lunout - unit to which to write data for further processing -! obstype - observation type to process -! sis - satellite/instrument/sensor indicator -! -! output argument list: -! nread - number of co observations read -! ndata - number of co profiles retained for further processing -! nodata - number of co observations retained for further processing -! nobs - array of observations on each subdomain for each processor - - use kinds, only: r_kind,r_double,i_kind - use satthin, only: makegrids,map2tgrid,finalcheck - use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons - use constants, only: deg2rad,zero,one_tenth,r60inv,two - use obsmod, only: nlco - use gsi_4dvar, only: iwinbgn - use mpimod, only: npe - implicit none - -! Declare passed variables - character(len=*),intent(in ) :: obstype,infile - character(len=20),intent(in ) :: sis - integer(i_kind) ,intent(in ) :: lunout - integer(i_kind) ,intent(inout) :: nread - integer(i_kind),dimension(npe) ,intent(inout) :: nobs - integer(i_kind) ,intent(inout) :: ndata,nodata - real(r_kind) ,intent(in ) :: gstime - -! Declare local parameters - real(r_kind),parameter:: r360 = 360.0_r_kind - - real(r_kind),parameter:: badco = 10000.0_r_kind - -! Declare local variables - logical outside - logical lerror,leof,lmax - - - integer(i_kind) maxobs,ncodat - integer(i_kind) lunin - integer(i_kind) nmind,i,j - integer(i_kind) imin - integer(i_kind) k,ilat,ilon,nreal,nchanl -! integer(i_kind) ithin,kidsat - integer(i_kind) idate5(5) - integer(i_kind) inum,iyear,imonth,iday,ihour,iferror - - - integer(i_kind) ipoq7 - - real(r_kind) tdiff,sstime,dlon,dlat,t4dv,poq - real(r_kind) slons0,slats0,rsat,solzen,dlat_earth,dlon_earth - real(r_kind) dlat_earth_deg,dlon_earth_deg - real(r_kind) rlat,rlon,rpress,rsza - real(r_kind),allocatable,dimension(:):: pco - real(r_kind),allocatable,dimension(:):: apco - real(r_kind),allocatable,dimension(:,:):: aker - - -! maximum number of observations set to - real(r_kind),allocatable,dimension(:,:):: coout - - real(r_double),dimension(10):: hdrco - -! Set constants. Initialize variables - rsat=999._r_kind - maxobs=1e6 - ilon=3 - ilat=4 - ipoq7=0 - nreal=nlco*nlco+8+nlco - - if (obstype == 'mopitt' )then - -! Set dependent variables and allocate arrays -! nchanl=nlco+1 - nchanl=nlco - ncodat=nreal - allocate (coout(ncodat+nchanl,maxobs)) - allocate ( pco(nlco)) - allocate( apco(nlco)) - allocate( aker(nlco,nlco)) - - -! Read in observations from ascii file - -! Opening file for reading - open(lunin,file=trim(infile),form='formatted',iostat=iferror) - lerror = (iferror/=0) - -110 continue - -! Read the first line of the data file - if (.not.lerror) then - read(lunin,fmt=*,iostat=iferror) & - inum,iyear,imonth,iday,ihour,imin,rlat,rlon,rpress,rsza - if(iferror/=0) go to 150 - do i=1,nlco - read(lunin,fmt=*,iostat=iferror) (aker(i,j),j=1,nlco) - enddo - read(lunin,fmt=*,iostat=iferror) (apco(j),j=1,nlco) - read(lunin,fmt=*,iostat=iferror) (pco(j),j=1,nlco) - -! lerror=(iferror>0) - leof =(iferror<0) - lmax =.false. - end if - - - hdrco(2)=rlat - hdrco(3)=rlon - hdrco(4)=iyear - hdrco(5)=imonth - hdrco(6)=iday - hdrco(8)=ihour - hdrco(9)=imin - -! Convert observation location to radians - slats0= hdrco(2) - slons0= hdrco(3) - if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) go to 110 - if(slons0< zero) slons0=slons0+r360 - if(slons0>=r360) slons0=slons0-r360 - dlat_earth_deg = slats0 - dlon_earth_deg = slons0 - dlat_earth = slats0 * deg2rad - dlon_earth = slons0 * deg2rad - - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if(outside) go to 110 - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif - -! Convert observation time to relative time - idate5(1) = hdrco(4) !year - idate5(2) = hdrco(5) !month - idate5(3) = hdrco(6) !day - idate5(4) = hdrco(7) !hour - idate5(5) = hdrco(8) !minute - call w3fs21(idate5,nmind) - t4dv=real((nmind-iwinbgn),r_kind)*r60inv - sstime=real(nmind,r_kind) - tdiff=(sstime-gstime)*r60inv - -! Check co layer values. If any layer value is bad, toss entire profile -! do k=1,nlco -! if (pco(k)>badco) goto 110 -! end do - -! Write co record to output file - ndata=min(ndata+1,maxobs) - nodata=nodata+nlco - - coout(1,ndata)=rsat - coout(2,ndata)=t4dv - coout(3,ndata)=dlon ! grid relative longitude - coout(4,ndata)=dlat ! grid relative latitude - coout(5,ndata)=dlon_earth_deg ! earth relative longitude (degrees) - coout(6,ndata)=dlat_earth_deg ! earth relative latitude (degrees) - coout(7,ndata)=poq ! profile co error flag - coout(8,ndata)=solzen ! solar zenith angle - do k=1,nlco - coout(k+8,ndata)=apco(k) - enddo - do i=1,nlco - do j=1,nlco - coout(j+(i-1)*nlco+8+nlco,ndata)=aker(i,j) - enddo - enddo - do k=1,nlco - coout(k+8+nlco*nlco+nlco,ndata)=pco(k) - end do - -! Loop back to read next profile - goto 110 - - endif - -! Jump here when eof detected -150 continue - - -! Write header record and data to output file for further processing - call count_obs(ndata,ncodat+nchanl,ilat,ilon,coout,nobs) - write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) ((coout(k,i),k=1,ncodat+nchanl),i=1,ndata) - nread=ndata ! nmrecs - - -! Deallocate local arrays -160 continue - if (obstype == 'mopitt') then - deallocate(aker) - deallocate(apco) - deallocate(pco) - deallocate(coout) - endif - close(lunin) - - return - -end subroutine read_co - diff --git a/src/read_diag.f90 b/src/read_diag.f90 deleted file mode 100644 index 7a4d6cdc4..000000000 --- a/src/read_diag.f90 +++ /dev/null @@ -1,659 +0,0 @@ -!$$$ subprogram documentation block -! . . . . -! subprogram: read_raddiag read rad diag file -! prgmmr: tahara org: np20 date: 2003-01-01 -! -! abstract: This module contains code to process radiance -! diagnostic files. The module defines structures -! to contain information from the radiance -! diagnostic files and then provides two routines -! to access contents of the file. -! -! program history log: -! 2005-07-22 treadon - add this doc block -! 2010-10-05 treadon - refactor code to GSI standard -! 2010-10-08 zhu - use data_tmp to handle various npred values -! 2011-02-22 kleist - changes related to memory allocate/deallocate -! 2011-04-08 li - add tref, dtw, dtc to diag_data_fix_list, add tb_tz to diag_data_chan_list -! - correspondingly, change ireal_radiag (26 -> 30) and ipchan_radiag (7 -> 8) -! 2011-07-24 safford - make structure size for reading data_fix data version dependent -! 2013-11-21 todling - revisit how versions are set (add set/get_radiag) -! 2014-01-27 todling - add ob sensitivity index -! -! contains -! read_radiag_header - read radiance diagnostic file header -! read_radiag_data - read radiance diagnostic file data -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - -module read_diag - - use kinds, only: i_kind,r_single - implicit none - -! Declare public and private - private - - public :: diag_header_fix_list - public :: diag_header_chan_list - public :: diag_data_name_list - public :: diag_data_fix_list - public :: diag_data_chan_list - public :: diag_data_extra_list - public :: read_radiag_header - public :: read_radiag_data -! public :: iversion_radiag -! public :: iversion_radiag_1 -! public :: iversion_radiag_2 -! public :: iversion_radiag_3 -! public :: iversion_radiag_4 - public :: ireal_radiag - public :: ipchan_radiag - public :: set_radiag - public :: get_radiag - - interface set_radiag - module procedure set_radiag_int_ ! internal procedure for integers - end interface - interface get_radiag - module procedure get_radiag_int_ ! internal procedure for integers - end interface - - integer(i_kind),parameter :: ireal_radiag = 30 ! number of real entries per spot in radiance diagnostic file - integer(i_kind),parameter :: ireal_old_radiag = 26 ! number of real entries per spot in versions older than iversion_radiag_2 - integer(i_kind),parameter :: ipchan_radiag = 8 ! number of entries per channel per spot in radiance diagnostic file - -! Declare structures for radiance diagnostic file information - type diag_header_fix_list - character(len=20) :: isis ! sat and sensor type - character(len=10) :: id ! sat type - character(len=10) :: obstype ! observation type - integer(i_kind) :: jiter ! outer loop counter - integer(i_kind) :: nchan ! number of channels in the sensor - integer(i_kind) :: npred ! number of updating bias correction predictors - integer(i_kind) :: idate ! time (yyyymmddhh) - integer(i_kind) :: ireal ! # of real elements in the fix part of a data record - integer(i_kind) :: ipchan ! # of elements for each channel except for bias correction terms - integer(i_kind) :: iextra ! # of extra elements for each channel - integer(i_kind) :: jextra ! # of extra elements - integer(i_kind) :: idiag ! first dimension of diag_data_chan - integer(i_kind) :: angord ! order of polynomial for adp_anglebc option - integer(i_kind) :: iversion ! radiance diagnostic file version number - integer(i_kind) :: inewpc ! indicator of newpc4pred (1 on, 0 off) - integer(i_kind) :: isens ! sensitivity index - end type diag_header_fix_list - - type diag_data_name_list - character(len=10),dimension(ireal_radiag) :: fix - character(len=10),dimension(:),allocatable :: chn - end type diag_data_name_list - - type diag_header_chan_list - real(r_single) :: freq ! frequency (Hz) - real(r_single) :: polar ! polarization - real(r_single) :: wave ! wave number (cm^-1) - real(r_single) :: varch ! error variance (or SD error?) - real(r_single) :: tlapmean ! mean lapse rate - integer(i_kind):: iuse ! use flag - integer(i_kind):: nuchan ! sensor relative channel number - integer(i_kind):: iochan ! satinfo relative channel number - end type diag_header_chan_list - - type diag_data_fix_list - real(r_single) :: lat ! latitude (deg) - real(r_single) :: lon ! longitude (deg) - real(r_single) :: zsges ! guess elevation at obs location (m) - real(r_single) :: obstime ! observation time relative to analysis - real(r_single) :: senscn_pos ! sensor scan position (integer(i_kind)) - real(r_single) :: satzen_ang ! satellite zenith angle (deg) - real(r_single) :: satazm_ang ! satellite azimuth angle (deg) - real(r_single) :: solzen_ang ! solar zenith angle (deg) - real(r_single) :: solazm_ang ! solar azimumth angle (deg) - real(r_single) :: sungln_ang ! sun glint angle (deg) - real(r_single) :: water_frac ! fractional coverage by water - real(r_single) :: land_frac ! fractional coverage by land - real(r_single) :: ice_frac ! fractional coverage by ice - real(r_single) :: snow_frac ! fractional coverage by snow - real(r_single) :: water_temp ! surface temperature over water (K) - real(r_single) :: land_temp ! surface temperature over land (K) - real(r_single) :: ice_temp ! surface temperature over ice (K) - real(r_single) :: snow_temp ! surface temperature over snow (K) - real(r_single) :: soil_temp ! soil temperature (K) - real(r_single) :: soil_mois ! soil moisture - real(r_single) :: land_type ! land type (integer(i_kind)) - real(r_single) :: veg_frac ! vegetation fraction - real(r_single) :: snow_depth ! snow depth - real(r_single) :: sfc_wndspd ! surface wind speed - real(r_single) :: qcdiag1 ! ir=cloud fraction, mw=cloud liquid water - real(r_single) :: qcdiag2 ! ir=cloud top pressure, mw=total column water - real(r_single) :: tref ! reference temperature (Tr) in NSST - real(r_single) :: dtw ! dt_warm at zob - real(r_single) :: dtc ! dt_cool at zob - real(r_single) :: tz_tr ! d(Tz)/d(Tr) - end type diag_data_fix_list - - type diag_data_chan_list - real(r_single) :: tbobs ! Tb (obs) (K) - real(r_single) :: omgbc ! Tb_(obs) - Tb_(simulated w/ bc) (K) - real(r_single) :: omgnbc ! Tb_(obs) - Tb_(simulated_w/o bc) (K) - real(r_single) :: errinv ! inverse error (K**(-1)) - real(r_single) :: qcmark ! quality control mark - real(r_single) :: emiss ! surface emissivity - real(r_single) :: tlap ! temperature lapse rate - real(r_single) :: tb_tz ! d(Tb)/d(Tz) - real(r_single) :: bicons ! constant bias correction term - real(r_single) :: biang ! scan angle bias correction term - real(r_single) :: biclw ! CLW bias correction term - real(r_single) :: bilap2 ! square lapse rate bias correction term - real(r_single) :: bilap ! lapse rate bias correction term - real(r_single) :: bicos ! node*cos(lat) bias correction term - real(r_single) :: bisin ! sin(lat) bias correction term - real(r_single) :: biemis ! emissivity sensitivity bias correction term - real(r_single),dimension(:),allocatable :: bifix ! angle dependent bias - real(r_single) :: bisst ! SST bias correction term - end type diag_data_chan_list - - type diag_data_extra_list - real(r_single) :: extra ! extra information - end type diag_data_extra_list - - integer(i_kind),save :: iversion_radiag ! Current version (see set routine) - integer(i_kind),parameter:: iversion_radiag_1 = 11104 ! Version when bias-correction entries were modified - integer(i_kind),parameter:: iversion_radiag_2 = 13784 ! Version when NSST entries were added - integer(i_kind),parameter:: iversion_radiag_3 = 19180 ! Version when SSMIS added - integer(i_kind),parameter:: iversion_radiag_4 = 30303 ! Version when emissivity predictor added - - real(r_single),parameter:: rmiss_radiag = -9.9e11_r_single - -contains - -subroutine set_radiag_int_ (what,iv,ier) -character(len=*),intent(in) :: what -integer(i_kind),intent(in) :: iv -integer(i_kind),intent(out):: ier -ier=-1 -if(trim(what)=='version') then - iversion_radiag = iv - ier=0 -endif -end subroutine set_radiag_int_ - -subroutine get_radiag_int_ (what,iv,ier) -character(len=*),intent(in) :: what -integer(i_kind),intent(out):: iv -integer(i_kind),intent(out):: ier -ier=-1 -if(trim(what)=='version') then - iv = iversion_radiag - ier=0 -endif -end subroutine get_radiag_int_ - -subroutine read_radiag_header(ftin,npred_radiag,retrieval,header_fix,header_chan,data_name,iflag,lverbose) -! . . . . -! subprogram: read_diag_header read rad diag header -! prgmmr: tahara org: np20 date: 2003-01-01 -! -! abstract: This routine reads the header record from a radiance -! diagnostic file -! -! program history log: -! 2010-10-05 treadon - add this doc block -! 2011-02-22 kleist - changes related to memory allocation and standard output -! -! input argument list: -! ftin - unit number connected to diagnostic file -! npred_radiag - number of bias correction terms -! retrieval - .true. if sst retrieval -! -! output argument list: -! header_fix - header information structure -! header_chan - channel information structure -! data_name - diag file data names -! iflag - error code -! lverbose - optional flag to turn off default output to standard out -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - -! Declare passed arguments - integer(i_kind),intent(in) :: ftin - integer(i_kind),intent(in) :: npred_radiag - logical,intent(in) :: retrieval - type(diag_header_fix_list ),intent(out):: header_fix - type(diag_header_chan_list),allocatable :: header_chan(:) - type(diag_data_name_list) :: data_name - integer(i_kind),intent(out) :: iflag - logical,optional,intent(in) :: lverbose - -! Declare local variables - character(len=2):: string - character(len=10):: satid,sentype - character(len=20):: sensat - integer(i_kind) :: i,ich - integer(i_kind):: jiter,nchanl,npred,ianldate,ireal,ipchan,iextra,jextra - integer(i_kind):: idiag,angord,iversion,inewpc,isens - integer(i_kind):: iuse_tmp,nuchan_tmp,iochan_tmp - real(r_single) :: freq_tmp,polar_tmp,wave_tmp,varch_tmp,tlapmean_tmp - logical loutall - - loutall=.true. - if(present(lverbose)) loutall=lverbose - -! Read header (fixed_part). - read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& - ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc,isens - if (iflag/=0) then - rewind(ftin) - read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& - ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc - isens=0 - end if - - if (iflag/=0) then - rewind(ftin) - read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& - ireal,ipchan,iextra,jextra - idiag=ipchan+npred+1 - angord=0 - iversion=0 - inewpc=0 - isens=0 - if (iflag/=0) then - write(6,*)'READ_RADIAG_HEADER: ***ERROR*** Unknown file format. Cannot read' - return - endif - endif - - header_fix%isis = sensat - header_fix%id = satid - header_fix%obstype = sentype - header_fix%jiter = jiter - header_fix%nchan = nchanl - header_fix%npred = npred - header_fix%idate = ianldate - header_fix%ireal = ireal - header_fix%ipchan = ipchan - header_fix%iextra = iextra - header_fix%jextra = jextra - header_fix%idiag = idiag - header_fix%angord = angord - header_fix%iversion= iversion - header_fix%inewpc = inewpc - header_fix%isens = isens - - if (loutall) then - write(6,*)'READ_RADIAG_HEADER: isis=',header_fix%isis,& - ' nchan=',header_fix%nchan,& - ' npred=',header_fix%npred,& - ' angord=',header_fix%angord,& - ' idiag=',header_fix%idiag,& - ' iversion=',header_fix%iversion,& - ' inewpc=',header_fix%inewpc,& - ' isens=',header_fix%isens - - if ( header_fix%iextra /= 0) & - write(6,*)'READ_RADIAG_HEADER: extra diagnostic information available, ',& - 'iextra=',header_fix%iextra - end if - - if (header_fix%npred /= npred_radiag) & - write(6,*) 'READ_RADIAG_HEADER: **WARNING** header_fix%npred,npred=',& - header_fix%npred,npred_radiag - -! Allocate and initialize as needed - if (allocated(header_chan)) deallocate(header_chan) - if (allocated(data_name%chn)) deallocate(data_name%chn) - - allocate(header_chan( header_fix%nchan)) - allocate(data_name%chn(header_fix%idiag)) - - data_name%fix(1) ='lat ' - data_name%fix(2) ='lon ' - data_name%fix(3) ='zsges ' - data_name%fix(4) ='obstim ' - data_name%fix(5) ='scanpos ' - data_name%fix(6) ='satzen ' - data_name%fix(7) ='satazm ' - data_name%fix(8) ='solzen ' - data_name%fix(9) ='solazm ' - data_name%fix(10)='sungln ' - data_name%fix(11)='fwater ' - data_name%fix(12)='fland ' - data_name%fix(13)='fice ' - data_name%fix(14)='fsnow ' - data_name%fix(15)='twater ' - data_name%fix(16)='tland ' - data_name%fix(17)='tice ' - data_name%fix(18)='tsnow ' - data_name%fix(19)='tsoil ' - data_name%fix(20)='soilmoi ' - data_name%fix(21)='landtyp ' - data_name%fix(22)='vegfrac ' - data_name%fix(23)='snowdep ' - data_name%fix(24)='wndspd ' - data_name%fix(25)='qc1 ' - data_name%fix(26)='qc2 ' - data_name%fix(27)='tref ' - data_name%fix(28)='dtw ' - data_name%fix(29)='dtc ' - data_name%fix(30)='tz_tr ' - - data_name%chn(1)='obs ' - data_name%chn(2)='omgbc ' - data_name%chn(3)='omgnbc ' - data_name%chn(4)='errinv ' - data_name%chn(5)='qcmark ' - data_name%chn(6)='emiss ' - data_name%chn(7)='tlap ' - data_name%chn(8)='tb_tz ' - - if (header_fix%iversion < iversion_radiag_1) then - data_name%chn( 8)= 'bifix ' - data_name%chn( 9)= 'bilap ' - data_name%chn(10)= 'bilap2 ' - data_name%chn(11)= 'bicons ' - data_name%chn(12)= 'biang ' - data_name%chn(13)= 'biclw ' - if (retrieval) data_name%chn(13)= 'bisst ' - elseif ( header_fix%iversion < iversion_radiag_2 .and. header_fix%iversion >= iversion_radiag_1 ) then - data_name%chn( 8)= 'bicons ' - data_name%chn( 9)= 'biang ' - data_name%chn(10)= 'biclw ' - data_name%chn(11)= 'bilap2 ' - data_name%chn(12)= 'bilap ' - do i=1,header_fix%angord - write(string,'(i2.2)') header_fix%angord-i+1 - data_name%chn(12+i)= 'bifix' // string - end do - data_name%chn(12+header_fix%angord+1)= 'bifix ' - data_name%chn(12+header_fix%angord+2)= 'bisst ' - elseif ( header_fix%iversion < iversion_radiag_3 .and. header_fix%iversion >= iversion_radiag_2 ) then - data_name%chn( 9)= 'bicons ' - data_name%chn(10)= 'biang ' - data_name%chn(11)= 'biclw ' - data_name%chn(12)= 'bilap2 ' - data_name%chn(13)= 'bilap ' - do i=1,header_fix%angord - write(string,'(i2.2)') header_fix%angord-i+1 - data_name%chn(13+i)= 'bifix' // string - end do - data_name%chn(13+header_fix%angord+1)= 'bifix ' - data_name%chn(13+header_fix%angord+2)= 'bisst ' - elseif ( header_fix%iversion < iversion_radiag_4 .and. header_fix%iversion >= iversion_radiag_3 ) then - data_name%chn( 9)= 'bicons ' - data_name%chn(10)= 'biang ' - data_name%chn(11)= 'biclw ' - data_name%chn(12)= 'bilap2 ' - data_name%chn(13)= 'bilap ' - data_name%chn(14)= 'bicos ' - data_name%chn(15)= 'bisin ' - do i=1,header_fix%angord - write(string,'(i2.2)') header_fix%angord-i+1 - data_name%chn(15+i)= 'bifix' // string - end do - data_name%chn(15+header_fix%angord+1)= 'bifix ' - data_name%chn(15+header_fix%angord+2)= 'bisst ' - else - data_name%chn( 9)= 'bicons ' - data_name%chn(10)= 'biang ' - data_name%chn(11)= 'biclw ' - data_name%chn(12)= 'bilap2 ' - data_name%chn(13)= 'bilap ' - data_name%chn(14)= 'bicos ' - data_name%chn(15)= 'bisin ' - data_name%chn(16)= 'biemis ' - do i=1,header_fix%angord - write(string,'(i2.2)') header_fix%angord-i+1 - data_name%chn(16+i)= 'bifix' // string - end do - data_name%chn(16+header_fix%angord+1)= 'bifix ' - data_name%chn(16+header_fix%angord+2)= 'bisst ' - endif - -! Read header (channel part) - do ich=1, header_fix%nchan - read(ftin,IOSTAT=iflag) freq_tmp,polar_tmp,wave_tmp,varch_tmp,tlapmean_tmp,iuse_tmp,nuchan_tmp,iochan_tmp - header_chan(ich)%freq = freq_tmp - header_chan(ich)%polar = polar_tmp - header_chan(ich)%wave = wave_tmp - header_chan(ich)%varch = varch_tmp - header_chan(ich)%tlapmean = tlapmean_tmp - header_chan(ich)%iuse = iuse_tmp - header_chan(ich)%nuchan = nuchan_tmp - header_chan(ich)%iochan = iochan_tmp - if (iflag/=0) return - end do - -! Construct array containing menonics for data record entries - - -end subroutine read_radiag_header - -subroutine read_radiag_data(ftin,header_fix,retrieval,data_fix,data_chan,data_extra,iflag ) -! . . . . -! subprogram: read_radiag_dat read rad diag data -! prgmmr: tahara org: np20 date: 2003-01-01 -! -! abstract: This routine reads the data record from a radiance -! diagnostic file -! -! program history log: -! 2010-10-05 treadon - add this doc block -! 2011-02-22 kleist - changes related to memory allocation -! -! input argument list: -! ftin - unit number connected to diagnostic file -! header_fix - header information structure -! -! output argument list: -! data_fix - spot header information structure -! data_chan - spot channel information structure -! data_extra - spot extra information -! iflag - error code -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - - -! Declare passed arguments - integer(i_kind),intent(in) :: ftin - type(diag_header_fix_list ),intent(in) :: header_fix - logical,intent(in) :: retrieval - type(diag_data_fix_list) ,intent(out):: data_fix - type(diag_data_chan_list) ,allocatable :: data_chan(:) - type(diag_data_extra_list) ,allocatable :: data_extra(:,:) - integer(i_kind),intent(out) :: iflag - - integer(i_kind) :: ich,iang,i,j - real(r_single),dimension(:,:),allocatable :: data_tmp - real(r_single),dimension(:),allocatable :: fix_tmp - real(r_single),dimension(:,:),allocatable :: extra_tmp - -! Allocate arrays as needed - if (allocated(data_chan)) deallocate(data_chan) - allocate(data_chan(header_fix%nchan)) - - do ich=1,header_fix%nchan - if (allocated(data_chan(ich)%bifix)) deallocate(data_chan(ich)%bifix) - allocate(data_chan(ich)%bifix(header_fix%angord+1)) - end do - - if (header_fix%iextra > 0) then - if (allocated(data_extra)) deallocate(data_extra) - allocate(data_extra(header_fix%iextra,header_fix%jextra)) - allocate(extra_tmp(header_fix%iextra,header_fix%jextra)) - end if - -! Allocate arrays to hold data record - allocate(data_tmp(header_fix%idiag,header_fix%nchan)) - - if (header_fix%iversion < iversion_radiag_2) then - allocate( fix_tmp( ireal_old_radiag ) ) - else - allocate( fix_tmp( ireal_radiag ) ) - end if - -! Read data record - - if (header_fix%iextra == 0) then - read(ftin,IOSTAT=iflag) fix_tmp, data_tmp - else - read(ftin,IOSTAT=iflag) fix_tmp, data_tmp, extra_tmp - endif - - -! Transfer fix_tmp record to output structure - data_fix%lat = fix_tmp(1) - data_fix%lon = fix_tmp(2) - data_fix%zsges = fix_tmp(3) - data_fix%obstime = fix_tmp(4) - data_fix%senscn_pos = fix_tmp(5) - data_fix%satzen_ang = fix_tmp(6) - data_fix%satazm_ang = fix_tmp(7) - data_fix%solzen_ang = fix_tmp(8) - data_fix%solazm_ang = fix_tmp(9) - data_fix%sungln_ang = fix_tmp(10) - data_fix%water_frac = fix_tmp(11) - data_fix%land_frac = fix_tmp(12) - data_fix%ice_frac = fix_tmp(13) - data_fix%snow_frac = fix_tmp(14) - data_fix%water_temp = fix_tmp(15) - data_fix%land_temp = fix_tmp(16) - data_fix%ice_temp = fix_tmp(17) - data_fix%snow_temp = fix_tmp(18) - data_fix%soil_temp = fix_tmp(19) - data_fix%soil_mois = fix_tmp(20) - data_fix%land_type = fix_tmp(21) - data_fix%veg_frac = fix_tmp(22) - data_fix%snow_depth = fix_tmp(23) - data_fix%sfc_wndspd = fix_tmp(24) - data_fix%qcdiag1 = fix_tmp(25) - data_fix%qcdiag2 = fix_tmp(26) - - if ( header_fix%iversion <= iversion_radiag_1 ) then - data_fix%tref = rmiss_radiag - data_fix%dtw = rmiss_radiag - data_fix%dtc = rmiss_radiag - data_fix%tz_tr = rmiss_radiag - else - data_fix%tref = fix_tmp(27) - data_fix%dtw = fix_tmp(28) - data_fix%dtc = fix_tmp(29) - data_fix%tz_tr = fix_tmp(30) - end if - - -! Transfer data record to output structure - do ich=1,header_fix%nchan - data_chan(ich)%tbobs =data_tmp(1,ich) - data_chan(ich)%omgbc =data_tmp(2,ich) - data_chan(ich)%omgnbc=data_tmp(3,ich) - data_chan(ich)%errinv=data_tmp(4,ich) - data_chan(ich)%qcmark=data_tmp(5,ich) - data_chan(ich)%emiss =data_tmp(6,ich) - data_chan(ich)%tlap =data_tmp(7,ich) - data_chan(ich)%tb_tz =data_tmp(8,ich) - end do - if (header_fix%iversion < iversion_radiag_1) then - do ich=1,header_fix%nchan - data_chan(ich)%bifix(1)=data_tmp(8,ich) - data_chan(ich)%bilap =data_tmp(9,ich) - data_chan(ich)%bilap2 =data_tmp(10,ich) - data_chan(ich)%bicons =data_tmp(11,ich) - data_chan(ich)%biang =data_tmp(12,ich) - data_chan(ich)%biclw =data_tmp(13,ich) - data_chan(ich)%bisst = rmiss_radiag - if (retrieval) then - data_chan(ich)%biclw =rmiss_radiag - data_chan(ich)%bisst =data_tmp(13,ich) - endif - end do - elseif ( header_fix%iversion < iversion_radiag_2 .and. header_fix%iversion >= iversion_radiag_1 ) then - do ich=1,header_fix%nchan - data_chan(ich)%bicons=data_tmp(8,ich) - data_chan(ich)%biang =data_tmp(9,ich) - data_chan(ich)%biclw =data_tmp(10,ich) - data_chan(ich)%bilap2=data_tmp(11,ich) - data_chan(ich)%bilap =data_tmp(12,ich) - end do - do ich=1,header_fix%nchan - do iang=1,header_fix%angord+1 - data_chan(ich)%bifix(iang)=data_tmp(12+iang,ich) - end do - data_chan(ich)%bisst = data_tmp(12+header_fix%angord+2,ich) - end do - elseif ( header_fix%iversion < iversion_radiag_3 .and. header_fix%iversion >= iversion_radiag_2 ) then - do ich=1,header_fix%nchan - data_chan(ich)%bicons=data_tmp(9,ich) - data_chan(ich)%biang =data_tmp(10,ich) - data_chan(ich)%biclw =data_tmp(11,ich) - data_chan(ich)%bilap2=data_tmp(12,ich) - data_chan(ich)%bilap =data_tmp(13,ich) - end do - do ich=1,header_fix%nchan - do iang=1,header_fix%angord+1 - data_chan(ich)%bifix(iang)=data_tmp(13+iang,ich) - end do - data_chan(ich)%bisst = data_tmp(13+header_fix%angord+2,ich) - end do - elseif ( header_fix%iversion < iversion_radiag_4 .and. header_fix%iversion >= iversion_radiag_3 ) then - do ich=1,header_fix%nchan - data_chan(ich)%bicons=data_tmp(9,ich) - data_chan(ich)%biang =data_tmp(10,ich) - data_chan(ich)%biclw =data_tmp(11,ich) - data_chan(ich)%bilap2=data_tmp(12,ich) - data_chan(ich)%bilap =data_tmp(13,ich) - data_chan(ich)%bicos =data_tmp(14,ich) ! 1st bias correction term node*cos(lat) for SSMIS - data_chan(ich)%bisin =data_tmp(15,ich) ! 2nd bias correction term sin(lat) for SSMI - end do - do ich=1,header_fix%nchan - do iang=1,header_fix%angord+1 - data_chan(ich)%bifix(iang)=data_tmp(15+iang,ich) - end do - data_chan(ich)%bisst = data_tmp(15+header_fix%angord+2,ich) - end do - else - do ich=1,header_fix%nchan - data_chan(ich)%bicons=data_tmp(9,ich) - data_chan(ich)%biang =data_tmp(10,ich) - data_chan(ich)%biclw =data_tmp(11,ich) - data_chan(ich)%bilap2=data_tmp(12,ich) - data_chan(ich)%bilap =data_tmp(13,ich) - data_chan(ich)%bicos =data_tmp(14,ich) - data_chan(ich)%bisin =data_tmp(15,ich) - data_chan(ich)%biemis=data_tmp(16,ich) - end do - do ich=1,header_fix%nchan - do iang=1,header_fix%angord+1 - data_chan(ich)%bifix(iang)=data_tmp(16+iang,ich) - end do - data_chan(ich)%bisst = data_tmp(16+header_fix%angord+2,ich) - end do - endif - - if (header_fix%iextra > 0) then - do j=1,header_fix%jextra - do i=1,header_fix%iextra - data_extra(i,j)%extra=extra_tmp(i,j) - end do - end do - endif - - deallocate(data_tmp, fix_tmp) - if (header_fix%iextra > 0) deallocate(extra_tmp) - -end subroutine read_radiag_data - -end module read_diag - diff --git a/src/read_lidar.f90 b/src/read_lidar.f90 deleted file mode 100644 index 0563dc014..000000000 --- a/src/read_lidar.f90 +++ /dev/null @@ -1,316 +0,0 @@ -subroutine read_lidar(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_lidar read doppler lidar winds -! prgmmr: yang org: np20 date: 1998-05-15 -! -! abstract: This routine reads doppler lidar wind files. -! -! When running the gsi in regional mode, the code only -! retains those observations that fall within the regional -! domain -! -! program history log: -! 1998-05-15 yang, weiyu -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-16 treadon - update documentation -! 2004-07-29 treadon - add only to module use, add intent in/out -! 2005-08-02 derber - modify to use convinfo file -! 2005-09-08 derber - modify to use input group time window -! 2005-10-11 treadon - change convinfo read to free format -! 2005-10-17 treadon - add grid and earth relative obs location to output file -! 2005-10-18 treadon - remove array obs_load and call to sumload -! 2005-10-26 treadon - add routine tag to convinfo printout -! 2006-02-03 derber - add new obs control -! 2006-02-08 derber - modify to use new convinfo module -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-07-27 msq/terry - removed cosine factor for line of sight winds and obs err -! 2007-03-01 tremolet - measure time from beginning of assimilation window -! 2008-04-18 safford - rm unused vars -! 2010-08-01 woollen - change bufr table (denoted as jsw) -! 2010-08-01 woollen - change kx to ikx (bug) (denoted as jsw) -! 2010-09-01 masutani - remove statements related to old cos(lat) correction !msq -! 2010-10-06 masutani -- use ikx, ikx=999 for missing type Bufrtable was updated -! 2010-11-05 mccarty/woollen - add level to dwld -! 2010-11-30 masutani - add kx to cdata_all(21), change maxdat to 21 (denoted msq) -! 2011-04-15 mccarty - change maxdat back to 20, kx in setupdw taken from ictype -! 2011-05-05 mccarty - cleaned up unnecessary print statement -! 2011-05-26 mccarty - remove dwlerror logic (moved to setupdw) -! 2011-08-01 lueken - added module use deter_sfc_mod -! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) -! 2015-02-23 Rancic/Thomas - add l4densvar to time window logical -! 2015-10-01 guo - consolidate use of ob location (in deg -! -! input argument list: -! infile - unit from which to read BUFR data -! obstype - observation type to process -! lunout - unit to which to write data for further processing -! twind - input group time window (hours) -! -! output argument list: -! nread - number of doppler lidar wind observations read -! ndata - number of doppler lidar wind profiles retained for further processing -! nodata - number of doppler lidar wind observations retained for further processing -! sis - satellite/instrument/sensor indicator -! nobs - array of observations on each subdomain for each processor -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,r_double,i_kind - use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons - use convinfo, only: nconvtype,ctwind, & !added mccarty - ncmiter,ncgroup,ncnumgrp,icuse,ictype,ioctype !mccarty - use constants, only: deg2rad,zero,r60inv ! check the usage msq - use obsmod, only: iadate,offtime_data - use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen - use deter_sfc_mod, only: deter_sfc2 - use mpimod, only: npe - implicit none - -! Declare passed variables - character(len=*),intent(in ) :: obstype,infile - character(len=20),intent(in ) :: sis - integer(i_kind) ,intent(in ) :: lunout - integer(i_kind) ,intent(inout) :: nread,ndata,nodata - integer(i_kind),dimension(npe),intent(inout) :: nobs - real(r_kind) ,intent(in ) :: twind - -! Declare local parameters - integer(i_kind),parameter:: maxobs=2e6 - integer(i_kind),parameter:: maxdat=20 !wm change back to 20 - ! kx taken from ictype - real(r_double),parameter:: r360=360.0_r_double - -! Declare local variables - logical dwl,outside - - character(40) hdstr,hdstr2 ! msq add hdstr2 - character(44) dwstr,dwstr2 ! msq add dwstr2 - character(10) date - character(8) subset - - integer(i_kind) lunin,i,kx,ilat,ikx,idomsfc - integer(i_kind) jdate,ihh,idd,idate,iret,im,iy,k,levs - integer(i_kind) nmrecs,ilon,nreal,nchanl - - - real(r_kind) time,usage,dlat,dlon,dlat_earth,dlon_earth - real(r_kind) dlat_earth_deg,dlon_earth_deg - real(r_kind) hloswind,sfcr,tsavg,ff10,toff,t4dv ! msq changed to hloswind - real(r_kind),allocatable,dimension(:,:):: cdata_all - - real(r_double) rstation_id - real(r_double) rkx !msq - real(r_double),dimension(5):: hdr - real(r_double),dimension(8,24):: dwld - - integer(i_kind) idate5(5),minobs,minan - real(r_kind) time_correction - - - integer(i_kind):: ilev ! mccarty - - - data hdstr /'SID CLON CLAT DHR TYP'/ !msq jsw - data dwstr /'HEIT ELEV BEARAZ NOLS NOLC ADPL LOSC LOSCU'/ !msq jsw - data hdstr2 /'SID XOB YOB DHR TYP'/ !msq used for KNMI data prepared by GMAO - data dwstr2 /'ADWL ELEV BORA NOLS NOLC ADPL LOSC SDLE'/ !msq used for KNMI data prepared by GMAO - - data lunin / 10 / - - -!************************************************************************** -! Initialize variables - nmrecs=0 - nreal=maxdat - nchanl=0 - ilon=2 - ilat=3 - - allocate(cdata_all(maxdat,maxobs)) - - -! Open, then read date from bufr data - open(lunin,file=trim(infile),form='unformatted') - call openbf(lunin,'IN',lunin) - call datelen(10) - call readmg(lunin,subset,idate,iret) - if(iret/=0) then - print*,' failed to dw read data from ',lunin ! msq - goto 1010 - endif - - -! Time offset - call time_4dvar(idate,toff) - -! If date in lidar file does not agree with analysis date, -! print message and stop program execution. - write(date,'( i10)') idate - read (date,'(i4,3i2)') iy,im,idd,ihh - if(offtime_data) then - -! in time correction for observations to account for analysis -! time being different from obs file time. - write(date,'( i10)') idate - read (date,'(i4,3i2)') iy,im,idd,ihh - idate5(1)=iy - idate5(2)=im - idate5(3)=idd - idate5(4)=ihh - idate5(5)=0 - call w3fs21(idate5,minobs) ! obs ref time in minutes relative to historic date - idate5(1)=iadate(1) - idate5(2)=iadate(2) - idate5(3)=iadate(3) - idate5(4)=iadate(4) - idate5(5)=0 - call w3fs21(idate5,minan) ! analysis ref time in minutes relative to historic date - -! add obs reference time, then subtract analysis time to get obs time relative to analysis - - time_correction=float(minobs-minan)*r60inv - - else - time_correction=zero - end if - - write(6,*)'READ_LIDAR: time offset is ',toff,' hours.' - -! Big loop over bufr file - -10 call readsb(lunin,iret) - if(iret/=0) then - call readmg(lunin,subset,jdate,iret) - if(iret/=0) go to 1000 - go to 10 - end if - nmrecs=nmrecs+1 - -! Extract type, date, and location information -! - call ufbint(lunin,rkx,1,1,iret,'TYP') !msq - kx=nint(rkx) !msq - if (kx==100.or.kx==101) then -! ADM data - call ufbint(lunin,hdr,5,1,iret,hdstr2) - else if (kx==201.or.kx==202) then -! GWOS data - call ufbint(lunin,hdr,5,1,iret,hdstr) - else -! undefined dwl data - call ufbint(lunin,hdr,5,1,iret,hdstr) - kx=999 - endif - - - ikx=0 - do i=1,nconvtype - if(trim(obstype) == trim(ioctype(i)) .and. kx == ictype(i))ikx = i - end do -! Determine if this is doppler wind lidar report - dwl= (ikx /= 0) .and. (subset=='DWLDAT') ! jsw chenge kx to ikx (bug) - if(.not. dwl) then - go to 10 - endif - - nread=nread+1 - - t4dv = toff + hdr(4) - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) go to 10 - else - time=hdr(4) + time_correction - if (abs(time) > ctwind(ikx) .or. abs(time) > twind) go to 10 - endif - - rstation_id=hdr(1) - - hdr(2)=mod(hdr(2),r360) ! msq - if (hdr(2) < zero) hdr(2)=hdr(2)+r360 - - - dlat_earth_deg = hdr(3) - dlon_earth_deg = hdr(2) - dlat_earth = hdr(3) * deg2rad - dlon_earth = hdr(2) * deg2rad - - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if (outside) go to 10 - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif - - if (kx==100.or.kx==101) then - call ufbint(lunin,dwld,8,24,levs,dwstr2) !mccarty, msq - else - call ufbint(lunin,dwld,8,24,levs,dwstr) !mccarty,msq - endif - - do ilev=1,levs !mccarty, jsw - -! If wind data, extract observation. - nodata=min(nodata+1,maxobs) - ndata=min(ndata+1,maxobs) - usage = zero - if(icuse(ikx) < 0)usage=100._r_kind - if(ncnumgrp(ikx) > 0 )then ! cross validation on - if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) - end if - - - hloswind=dwld(7,ilev)/(cos(dwld(2,ilev)*deg2rad)) ! obs wind (line of sight component) - call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr) - - cdata_all(1,ndata)=ikx ! obs type - cdata_all(2,ndata)=dlon ! grid relative longitude - cdata_all(3,ndata)=dlat ! grid relative latitude - cdata_all(4,ndata)=t4dv ! obs time (analyis relative hour) - cdata_all(5,ndata)=dwld(1,ilev) ! obs height (altitude) (m) - cdata_all(6,ndata)=dwld(2,ilev)*deg2rad ! elevation angle (radians) - cdata_all(7,ndata)=dwld(3,ilev)*deg2rad ! bearing or azimuth (radians) - cdata_all(8,ndata)=dwld(4,ilev) ! number of laser shots - cdata_all(9,ndata)=dwld(5,ilev) ! number of cloud laser shots - cdata_all(10,ndata)=dwld(6,ilev) ! atmospheric depth - cdata_all(11,ndata)=hloswind ! obs wind (line of sight component) msq - cdata_all(12,ndata)=dwld(8,ilev) ! standard deviation (obs error) msq - cdata_all(13,ndata)=rstation_id ! station id - cdata_all(14,ndata)=usage ! usage parameter - cdata_all(15,ndata)=idomsfc+0.001_r_kind ! dominate surface type - cdata_all(16,ndata)=tsavg ! skin temperature - cdata_all(17,ndata)=ff10 ! 10 meter wind factor - cdata_all(18,ndata)=sfcr ! surface roughness - cdata_all(19,ndata)=dlon_earth_deg ! earth relative longitude (degrees) - cdata_all(20,ndata)=dlat_earth_deg ! earth relative latitude (degrees) - enddo ! ilev - - -! End of bufr read loop - go to 10 - - -! Normal exit -1000 continue - - -! Write observations to scratch file - call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) - write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) - - -! Close unit to bufr file -1010 continue - deallocate(cdata_all) - call closbf(lunin) - -! End of routine - return -end subroutine read_lidar diff --git a/src/read_ozone.f90 b/src/read_ozone.f90 deleted file mode 100644 index e5194a204..000000000 --- a/src/read_ozone.f90 +++ /dev/null @@ -1,1060 +0,0 @@ -subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & - obstype,twind,sis,ithin,rmesh,nobs) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_ozone read ozone data -! prgmmr: yang org: np23 date: 1998-05-15 -! -! abstract: This routine reads SBUV/2 ozone observations. Both layer -! and total column values are read in. The routine has -! the ability to read both IEEE and BUFR format SBUV/2 -! ozone data files. OMI and GOME data is optionally thinned -! to a specific resolution using simple quality control checks. -! -! When running the gsi in regional mode, the code only -! retains those observations that fall within the regional -! domain -! -! program history log: -! 1998-05-15 yang, weiyu -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-16 treadon - update documentation -! 2004-07-29 treadon - add only to module use, add intent in/out -! 2004-09-17 todling - fixed intent of jsatid -! 2004-12-02 todling - compilation in OSF1 forces big_endian for bufr files; -! need to force little_endian for ieee files -! 2004-12-22 kokron - change cpp tokens to add support for ifort compiler -! efc does not have a convert option so it should use -! the other 'open' -! 2005-03-14 treadon - define numeric constants to r_kind precision -! 2005-05-12 wu - add OMI total ozone -! 2005-06-27 guo - bug fix: hour read from header was incorrect -! 2005-09-08 derber - modify to use input group time window -! 2005-09-19 treadon - add check on NOAA-17 sbuv data (toss bad data) -! 2005-10-17 treadon - add grid and earth relative obs location to output file -! 2005-10-18 treadon - remove array obs_load and call to sumload -! 2005-12-23 treadon - bound longitude to be less than 360.0 -! 2006-01-26 treadon - remove ieee sbuv option -! 2006-02-03 derber - modify for new obs control and obs count -! 2007-03-01 tremolet - measure time from beginning of assimilation window -! 2007-07-10 zhou - modify to read version 8 SBUV/2 BUFR data(keep -! option to read version 6 data), also add -! total ozone and ozone profile quality control. -! 2007-09-11 h.liu - add kidsat for nimbus-7, n09, n11, n14 -! 2007-10-16 zhou - organize ozone flag control for all satellites -! 2008-04-16 h.liu - thin OMI and read in GOME data -! 2008-05-27 safford - rm unused vars and uses -! 2008-05-30 treadon - accept version8 poq=7 obs for further processing -! 2008-06-01 treadon - adjust logic to correctly handle zero length BUFR files -! 2008-06-03 treadon - add use_poq7 flag -! 2008-09-08 lueken - merged ed's changes into q1fy09 code -! 2009-01-20 sienkiewicz - merge in changes for MLS ozone -! 2009-04-21 derber - add ithin to call to makegrids -! 2009-3-05 h.liu - read in OMI bufr, QC GOME2 and OMI -! 2009-7-02 h.liu - toss the OMI data with AFBO=3 (c-pair correction) and clean up codes -! 2010-05-26 treadon - add timedif=zero for l4dvar (used in thinning) -! 2010-06-02 sienkiewicz - care for closing bufr other than for o3lev -! 2011-07-04 todling - fixes to run either single or double precision -! 2011-08-01 lueken - replaced F90 with f90 (no machine logic) -! 2012-10-12 h.liu - read in MLS v2 Near Real Time (NRT) and v2.2 standard bufr data -! 2013-01-17 h.liu - read in MLS v3 Near Real Time (NRT) -! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) -! 2014-02-03 guo - removed unused "o3lev" handling, which can (and should) be -! implemented again in module m_extOzone, if ever needed. -! 2015-02-23 Rancic/Thomas - add thin4d to time window logical -! 2015-10-01 guo - consolidate use of ob location (in deg -! -! input argument list: -! obstype - observation type to process -! jsatid - satellite id to read -! infile - unit from which to read ozone data -! gstime - analysis time in minutes from reference date -! lunout - unit to which to write data for further processing -! obstype - observation type to process -! twind - input group time window (hours) -! sis - satellite/instrument/sensor indicator -! ithin - flag to thin data -! rmesh - thinning mesh size (km) -! -! output argument list: -! nread - number of sbuv/omi ozone observations read -! ndata - number of sbuv/omi ozone profiles retained for further processing -! nodata - number of sbuv/omi ozone observations retained for further processing -! nobs - array of observations on each subdomain for each processor -! -! remarks: -! NCEP stopped producing IEEE format sbuv ozone files in April 2004. -! Hence, the IEEE portion of this routine no future application. It -! is retained in the GSI package for use with retrospective runs. The -! IEEE portion of this routine may be removed from the GSI at a later date. -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,r_double,i_kind - use satthin, only: makegrids,map2tgrid,destroygrids, & - finalcheck,itxmax - use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons - use constants, only: deg2rad,zero,one_tenth,r60inv,two - use obsmod, only: nloz_v6,nloz_v8 - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,thin4d - use radinfo, only: dec2bin - use qcmod, only: use_poq7 - use ozinfo, only: jpch_oz,nusis_oz,iuse_oz - use mpimod, only: npe - implicit none - -! Declare passed variables - character(len=*),intent(in ) :: obstype,infile,jsatid - character(len=20),intent(in ) :: sis - integer(i_kind) ,intent(in ) :: lunout,ithin - integer(i_kind) ,intent(inout) :: nread - integer(i_kind),dimension(npe) ,intent(inout) :: nobs - integer(i_kind) ,intent(inout) :: ndata,nodata - real(r_kind) ,intent(in ) :: gstime,twind,rmesh - -! Declare local parameters - real(r_kind),parameter:: r6 = 6.0_r_kind - real(r_kind),parameter:: r76 = 76.0_r_kind - real(r_kind),parameter:: r84 = 84.0_r_kind - - real(r_kind),parameter:: r360 = 360.0_r_kind - real(r_kind),parameter:: rmiss = -9999.9_r_kind - real(r_kind),parameter:: badoz = 10000.0_r_kind - -! Declare local variables - logical outside,version6,version8,iuse - - character(2) version - character(8) subset,subset6,subset8 - character(49) ozstr,ozostr - character(63) lozstr - character(51) ozgstr - character(27) ozgstr2 - character(42) ozostr2 - character(64) mlstr - character(14) mlstrl - - integer(i_kind) maxobs,nozdat,nloz - integer(i_kind) idate,jdate,ksatid,kk,iy,iret,im,ihh,idd,lunin - integer(i_kind) nmind,i - integer(i_kind) nmrecs,k,ilat,ilon,nreal,nchanl -! integer(i_kind) ithin,kidsat - integer(i_kind) kidsat - integer(i_kind) idate5(5) - integer(i_kind) JULIAN,IDAYYR,IDAYWK - integer(i_kind) ikx - integer(i_kind) decimal,binary(14),binary_mls(18) - - - integer(i_kind) itx,itt,ipoq7 - - real(r_kind) tdiff,sstime,dlon,dlat,t4dv,timedif,crit1,dist1 - real(r_kind) slons0,slats0,rsat,solzen,solzenp,dlat_earth,dlon_earth - real(r_kind) dlat_earth_deg,dlon_earth_deg - real(r_kind),allocatable,dimension(:):: poz - -! maximum number of observations set to - real(r_kind),allocatable,dimension(:,:):: ozout - real(r_double) toq,poq - real(r_double),dimension(nloz_v6):: ozone_v6 - real(r_double),dimension(29,nloz_v8):: ozone_v8 - real(r_double),dimension(10):: hdroz - real(r_double),dimension(10):: hdrozg - real(r_double),dimension(5):: hdrozg2 - real(r_double),dimension(10):: hdrozo - real(r_double),dimension(8) :: hdrozo2 - real(r_double),dimension(13):: hdrmls - real(r_double),allocatable,dimension(:,:) :: hdrmlsl - real(r_kind),allocatable,dimension(:):: mlspres,mlsoz,mlsozpc,usage1 - integer(i_kind),allocatable,dimension(:):: ipos - - real(r_double) totoz,hdrmls13 - integer(i_kind) :: k0 - logical :: first - -! MLS data version: mlsv=22 is version 2.2 standard data; -! mlsv=20 is v2 near-real-time data -! mlsv=30 is v3 near-real-time data - integer(i_kind) :: mlsv - - data lozstr & - / 'OSP12 OSP11 OSP10 OSP9 OSP8 OSP7 OSP6 OSP5 OSP4 OSP3 OSP2 OSP1 ' / - data ozgstr & - / 'SAID CLAT CLON YEAR DOYR HOUR MINU SECO SOZA SOLAZI' / - data ozgstr2 & - / 'CLDMNT SNOC ACIDX STKO FOVN' / - data ozostr & - / 'SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SECO SOZA' / -! since 2009020412, the omi bufr contains fovn - data ozostr2 & - / 'CLDMNT ACIDX STKO VZAN TOQC TOQF FOVN AFBO' / - - data mlstr & - / 'SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SECO SOZA CONV MLST PCCF' / - data mlstrl & - / 'PRLC OZMX OZMP' / - - data lunin / 10 / - data subset6 / 'NC008010' / - data subset8 / 'NC008011' / - -!************************************************************************** -! Set constants. Initialize variables - rsat=999._r_kind - maxobs=1e6 - ilon=3 - ilat=4 - ipoq7=0 - if (use_poq7) ipoq7=7 - - -! Separately process sbuv or omi ozone - - if (obstype == 'sbuv2' ) then - - nreal=9 - open(lunin,file=trim(infile),form='unformatted') - nmrecs=0 - call openbf(lunin,'IN',lunin) - call datelen(10) - call readmg(lunin,subset,idate,iret) - - version6 = .false. - version8 = .false. - if (subset == subset6) then - version6 = .true. - nloz = nloz_v6 - version = 'v6' - elseif (subset == subset8) then - version8 = .true. - nloz = nloz_v8 - version = 'v8' - else - write(6,*)'READ_OZONE: *** WARNING: unknown sbuv version type, subset=',subset - write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid - write(6,*)' SKIP PROCESSING OF THIS SBUV FILE' - goto 170 - endif - -! Set dependent variables and allocate arrays - nchanl=nloz+1 - nozdat=nreal+nchanl - allocate (ozout(nozdat,maxobs)) - allocate ( poz(nloz+1)) - - -! Set BUFR string based on sbuv version - if (version6) then - ozstr='SAID CLAT CLON YEAR MNTH DAYS HOUR MINU OSZA OPSZ' - else if (version8) then - ozstr='SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SECO SOZA' - endif - - if(iret/=0) goto 160 - -110 continue - call readsb(lunin,iret) - if (iret/=0) then - call readmg(lunin,subset,jdate,iret) - if (iret/=0) goto 150 - goto 110 - endif - -! extract header information -! BUFR code values for satellite identifiers are listed in -! Dennis Keyser's website, -! http://www.emc.ncep.noaa.gov/mmb/papers/keyser/Satellite_Historical.txt - - call ufbint(lunin,hdroz,10,1,iret,ozstr) - rsat = hdroz(1); ksatid=rsat - if(jsatid == 'nim07') kidsat = 767 - if(jsatid == 'n09') kidsat = 201 - if(jsatid == 'n11') kidsat = 203 - if(jsatid == 'n14') kidsat = 205 - if(jsatid == 'n16') kidsat = 207 - if(jsatid == 'n17') kidsat = 208 - if(jsatid == 'n18') kidsat = 209 - if(jsatid == 'n19') kidsat = 223 - - if (ksatid /= kidsat) go to 110 - - nmrecs=nmrecs+nloz+1 - -! Convert observation location to radians - slats0= hdroz(2) - slons0= hdroz(3) - if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) go to 110 - if(slons0< zero) slons0=slons0+r360 - if(slons0==r360) slons0=zero - dlat_earth_deg = slats0 - dlon_earth_deg = slons0 - dlat_earth = slats0 * deg2rad - dlon_earth = slons0 * deg2rad - - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if(outside) go to 110 - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif - -! Special check for NOAA-17 version 6 -! Before July 2007 NOAA-17 SBUV/2 has a stray light problem which produces -! erroneous ozone profile retrievals for a limited portion -! of its measurements. The contaminated signals only occur -! in the Southern Hemisphere and only for Solar Zenith -! Angles (SZA) greater than 76 Degrees. - - if (version6) then - solzen = hdroz(9) ! solar zenith angle - solzenp= hdroz(10) ! profile solar zenith angle - if (ksatid==208 .and. dlat_earth r76) goto 110 - else if(version8)then - solzen = hdroz(10) ! solar zenith angle - endif - -! Convert observation time to relative time - idate5(1) = hdroz(4) !year - idate5(2) = hdroz(5) !month - idate5(3) = hdroz(6) !day - idate5(4) = hdroz(7) !hour - idate5(5) = hdroz(8) !minute - call w3fs21(idate5,nmind) - t4dv=real((nmind-iwinbgn),r_kind)*r60inv - sstime=real(nmind,r_kind) - tdiff=(sstime-gstime)*r60inv - if (l4dvar.or.l4densvar) then - if(t4dvwinlen) goto 110 - else - if(abs(tdiff) > twind) goto 110 - end if - -! Extract layer ozone values and compute profile total ozone - if (version8) then - call ufbseq(lunin,ozone_v8,29,21,iret,'OZOPQLSQ') - totoz=zero - do k=1,nloz - kk=nloz-k+1 - poz(k) = ozone_v8(6,kk) - totoz=totoz+ozone_v8(6,k) - end do - poz(nloz+1) = totoz - endif - - if (version6) then - call ufbint(lunin,ozone_v6,nloz,1,iret,lozstr) - do k=1,nloz - kk=nloz-k+1 - poz(k) = ozone_v6(kk) - end do - -! extract total ozone - call ufbint(lunin,totoz,1,1,iret,'OTSP') - poz(nloz+1) = totoz - endif - - -! Extract and apply version 8 total and profile ozone quaility information -! Toss observations for which the total ozone error code is neither 0 nor 2 -! Toss observations for which the profile ozone error code is neither 0 nor 1 -! NOTES: -! 1) Profile ozone error code 0 identifies good data; 1 identifies good -! data with a solar zenith angle > 84 degrees; 7 identifies profile -! for which stray light correction applied -! 2) Total ozone error code 0 indentifies good data; 2 identifies good -! data with a solar zenith angle > 84 degrees. -! 3) We do not use the version 6 error flags. Thus, initialize toq and -! poq to 0 (use the data) - - toq=0._r_double - poq=0._r_double - if (version8) then - call ufbint(lunin,toq,1,1,iret,'SBUVTOQ') - call ufbint(lunin,poq,1,1,iret,'SBUVPOQ') - if (toq/=0 .and. toq/=2) goto 110 - if (poq/=0 .and. poq/=1 .and. poq/=ipoq7) goto 110 - endif - -! Check ozone layer values. If any layer value is bad, toss entire profile - do k=1,nloz - if (poz(k)>badoz) goto 110 - end do - -! Write ozone record to output file - ndata=min(ndata+1,maxobs) - nodata=nodata+nloz+1 - ozout(1,ndata)=rsat - ozout(2,ndata)=t4dv - ozout(3,ndata)=dlon ! grid relative longitude - ozout(4,ndata)=dlat ! grid relative latitude - ozout(5,ndata)=dlon_earth_deg ! earth relative longitude (degrees) - ozout(6,ndata)=dlat_earth_deg ! earth relative latitude (degrees) - ozout(7,ndata)=toq ! total ozone error flag - ozout(8,ndata)=poq ! profile ozone error flag - ozout(9,ndata)=solzen ! solar zenith angle - do k=1,nloz+1 - ozout(k+9,ndata)=poz(k) - end do - -! Loop back to read next profile - goto 110 - -! End of bufr ozone block - -! Process GOME-2 data - - else if ( obstype == 'gome') then - -! Make thinning grids - call makegrids(rmesh,ithin) - - open(lunin,file=trim(infile),form='unformatted') - nmrecs=0 - call openbf(lunin,'IN',lunin) - call datelen(10) - call readmg(lunin,subset,idate,iret) - - if (subset == 'NC008012') then -! write(6,*)'READ_OZONE: GOME-2 data type, subset=',subset - else - write(6,*)'READ_OZONE: *** WARNING: unknown ozone data type, subset=',subset - write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid - goto 170 - endif - -! Set dependent variables and allocate arrays - nreal=14 - nloz=0 - nchanl=1 - nozdat=nreal+nchanl - allocate (ozout(nozdat,itxmax)) - do k=1,itxmax - do i=1,nozdat - ozout(i,k)=rmiss - end do - end do - - iy=0 - idd=0 - ihh=0 - if(iret/=0) goto 160 - -120 continue - call readsb(lunin,iret) - if (iret/=0) then - call readmg(lunin,subset,jdate,iret) - if (iret/=0) goto 150 - goto 120 - endif - -! extract header information - call ufbint(lunin,hdrozg,10,1,iret,ozgstr) - call ufbint(lunin,hdrozg2,5,1,iret,ozgstr2) - rsat = hdrozg(1); ksatid=rsat - - if(jsatid == 'metop-a')kidsat = 4 - if(jsatid == 'metop-b')kidsat = 3 - if(jsatid == 'metop-c')kidsat = 5 - - if (ksatid /= kidsat) go to 120 - -! NESDIS does not put a flag for high SZA gome-2 data (SZA > 84 degree) - if ( hdrozg(9) > r84 ) go to 120 - - nmrecs=nmrecs+nloz+1 - -! Convert observation location to radians - slats0= hdrozg(2) - slons0= hdrozg(3) - if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) go to 120 - if(slons0< zero) slons0=slons0+r360 - if(slons0==r360) slons0=zero - dlat_earth_deg = slats0 - dlon_earth_deg = slons0 - dlat_earth = slats0 * deg2rad - dlon_earth = slons0 * deg2rad - - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if(outside) go to 120 - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif - -! Convert observation time to relative time - idate5(1) = hdrozg(4) !year - IDAYYR = hdrozg(5) ! Day of year - JULIAN = -31739 + 1461 * (idate5(1) + 4799) /4 & - -3 * ((idate5(1) + 4899) / 100) / 4 + IDAYYR - call w3fs26(JULIAN,idate5(1),idate5(2),idate5(3),IDAYWK,IDAYYR) -! idate5(2) month -! idate5(3) day - idate5(4) = hdrozg(6) !hour - idate5(5) = hdrozg(7) !minute - call w3fs21(idate5,nmind) - t4dv=real((nmind-iwinbgn),r_kind)*r60inv - sstime=real(nmind,r_kind) - tdiff=(sstime-gstime)*r60inv - if (l4dvar.or.l4densvar) then - if(t4dvwinlen) goto 120 - else - if(abs(tdiff) > twind) goto 120 - end if - -! extract total ozone - call ufbint(lunin,totoz,1,1,iret,'OZON') - - if (totoz > badoz ) goto 120 - -! only accept flag 0 (good) data - toq=0._r_double - call ufbint(lunin,toq,1,1,iret,'GOMEEF') - if (toq/=0) goto 120 - -! only accept scan positions from 2 to 25 - if( hdrozg2(5) < two .or. hdrozg2(5) > 25.0_r_kind ) goto 120 - -! thin GOME data -! GOME data has bias when the satellite looks to the east. Consider QC out this data. - - if (thin4d) then - timedif = zero - else - timedif = r6*abs(tdiff) ! range: 0 to 18 - endif - crit1 = 0.01_r_kind+timedif - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) - if(.not. iuse) goto 120 - - call finalcheck(dist1,crit1,itx,iuse) - if(.not. iuse) goto 120 - - ndata=ndata+1 - nodata=ndata - - ozout(1,itx)=rsat - ozout(2,itx)=t4dv - ozout(3,itx)=dlon ! grid relative longitude - ozout(4,itx)=dlat ! grid relative latitude - ozout(5,itx)=dlon_earth_deg ! earth relative longitude (degrees) - ozout(6,itx)=dlat_earth_deg ! earth relative latitude (degrees) - ozout(7,itx)=toq ! total ozone error flag - ozout(8,itx)=hdrozg(9) ! solar zenith angle - ozout(9,itx)=hdrozg(10) ! solar azimuth angle - ozout(10,itx)=hdrozg2(1) ! CLOUD AMOUNT IN SEGMENT - ozout(11,itx)=hdrozg2(2) ! SNOW COVER - ozout(12,itx)=hdrozg2(3) ! AEROSOL CONTAMINATION INDEX - ozout(13,itx)=hdrozg2(4) ! ASCENDING/DESCENDING ORBIT QUALIFIER - ozout(14,itx)=hdrozg2(5) ! scan position (fovn) - ozout(15,itx)=totoz - - goto 120 - -! End of GOME bufr block - - -! Process OMI data - else if ( obstype == 'omi') then - -! Make thinning grids - call makegrids(rmesh,ithin) - - nmrecs=0 - open(lunin,file=trim(infile),form='unformatted') - call openbf(lunin,'IN',lunin) - call datelen(10) - call readmg(lunin,subset,idate,iret) - if (subset == 'NC008013') then -! write(6,*)'READ_OZONE: OMI data type, subset=',subset - else - write(6,*)'READ_OZONE: *** WARNING: unknown ozone data type, subset=',subset - write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid - goto 170 - endif - -! Set dependent variables and allocate arraysn - nreal=14 - nloz=0 - nchanl=1 - nozdat=nreal+nchanl - allocate (ozout(nozdat,itxmax)) - do k=1,itxmax - do i=1,nozdat - ozout(i,k)=rmiss - end do - end do - - iy=0 - im=0 - idd=0 - ihh=0 - if(iret/=0) goto 160 - -130 continue - call readsb(lunin,iret) - if (iret/=0) then - call readmg(lunin,subset,jdate,iret) - if (iret/=0) goto 150 - goto 130 - endif - -! extract header information - call ufbint(lunin,hdrozo,10,1,iret,ozostr) - call ufbint(lunin,hdrozo2,8,1,iret,ozostr2) - rsat = hdrozo(1); ksatid=rsat - - if(jsatid == 'aura')kidsat = 785 - if (ksatid /= kidsat) go to 130 - - - nmrecs=nmrecs+nloz+1 - -! Convert observation location to radians - slats0= hdrozo(2) - slons0= hdrozo(3) - if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) go to 130 - if(slons0< zero) slons0=slons0+r360 - if(slons0==r360) slons0=zero - dlat_earth_deg = slats0 - dlon_earth_deg = slons0 - dlat_earth = slats0 * deg2rad - dlon_earth = slons0 * deg2rad - - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if(outside) go to 130 - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif - -! convert observation time to relative time - idate5(1) = hdrozo(4) !year - idate5(2) = hdrozo(5) !month - idate5(3) = hdrozo(6) !day - idate5(4) = hdrozo(7) !hour - idate5(5) = hdrozo(8) !minute - call w3fs21(idate5,nmind) - - t4dv=real((nmind-iwinbgn),r_kind)*r60inv - sstime=real(nmind,r_kind) - tdiff=(sstime-gstime)*r60inv - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) go to 130 - else - if(abs(tdiff) > twind) go to 130 - end if - -! extract total ozone - call ufbint(lunin,totoz,1,1,iret,'OZON') - if (totoz > badoz ) goto 130 - -! Bit 10 in TOQF represents row anomaly. - decimal=int(hdrozo2(6)) - call dec2bin(decimal,binary,14) - if (binary(10) == 1 ) then - goto 130 - endif - -! only accept flag 0 1, flag 2 is high SZA data which is not used for now - toq=hdrozo2(5) - if (toq/=0 .and. toq/=1) goto 130 - -! remove the bad scan position data: fovn beyond 25 - if (hdrozo2(7) >=25.0_r_double) goto 130 - -! remove the data in which the C-pair algorithm ((331 and 360 nm) is used. - if (hdrozo2(8) == 3_r_double .or. hdrozo2(8) == 13_r_double) goto 130 - - -! thin OMI data - - if (thin4d) then - timedif = zero - else - timedif = r6*abs(tdiff) ! range: 0 to 18 - endif - crit1 = 0.01_r_kind+timedif - call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis) - if(.not. iuse)go to 130 - - call finalcheck(dist1,crit1,itx,iuse) - if(.not. iuse)go to 130 - - ndata=ndata+1 - nodata=ndata - - - - ozout(1,itx)=rsat - ozout(2,itx)=t4dv - ozout(3,itx)=dlon ! grid relative longitude - ozout(4,itx)=dlat ! grid relative latitude - ozout(5,itx)=dlon_earth_deg ! earth relative longitude (degrees) - ozout(6,itx)=dlat_earth_deg ! earth relative latitude (degrees) - ozout(7,itx)=hdrozo2(5) ! total ozone quality code - ozout(8,itx)=hdrozo(10) ! solar zenith angle - ozout(9,itx)=binary(10) ! row anomaly flag - ozout(10,itx)=hdrozo2(1) ! cloud amount - ozout(11,itx)=hdrozo2(4) ! vzan - ozout(12,itx)=hdrozo2(2) ! aerosol index - ozout(13,itx)=hdrozo2(3) ! ascending/descending - ozout(14,itx)=hdrozo2(7) ! scan position - ozout(15,itx)=totoz - -! End of loop over observations - go to 130 - -! End of OMI block - -! Process MLS bufr data - else if ( index(obstype,'mls')/=0 ) then - - nmrecs=0 - - open(lunin,file=trim(infile),form='unformatted') - call openbf(lunin,'IN',lunin) - call datelen(10) - call readmg(lunin,subset,idate,iret) - if (subset == 'NC008015') then - write(6,*)'READ_OZONE: MLS data type, subset=',subset - else - write(6,*)'READ_OZONE: *** WARNING: unknown ozone data type, subset=',subset - write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid - goto 170 - endif - - if(iret/=0) goto 160 - -180 continue - call readsb(lunin,iret) - if (iret/=0) then - call readmg(lunin,subset,jdate,iret) - if (iret/=0) goto 150 - goto 180 - endif - -! Get # of vertical pressure levels nloz and MLS NRT data version which depends on nloz - allocate(hdrmlsl(3,100)) - call ufbrep(lunin,hdrmlsl,3,100,iret,mlstrl) - nloz=iret -! for NRT data, mlsv=20 or 30 depending on the nloz - mlsv=-999 - if(nloz==37) then - if(index(sis,'mls22')/=0 ) then !mls v2.2 data - mlsv=22 - else if(index(sis,'mls20')/=0 ) then !mls v2 nrt data - mlsv=20 - end if - else if (nloz==55) then !mls v3 nrt data - if (index(sis,'mls30')/=0 ) then - mlsv=30 - endif - else - write(6,*) 'invalid vertical level number: ', nloz - write(6,*) '******STOP*******: error reading MLS vertical levels in read_ozone.f90' - call stop2(338) - end if - deallocate(hdrmlsl) - - write(6,*) 'READ_OZONE: MLS data version=',mlsv - write(6,*) 'READ_OZONE: MLS vertical level number=',nloz - - if (mlsv<0) then - write(6,*) 'inconsistent MLS versions. bufr nloz=',nloz,' obsinput sis= ',trim(sis) - write(6,*) '******STOP*******: error bufr and specified MLS versions' - call stop2(338) - end if - -! Allocate arrays - allocate(hdrmlsl(3,nloz)) - allocate (mlspres(nloz)) - allocate (mlsoz(nloz)) - allocate (mlsozpc(nloz)) - allocate(ipos(nloz)) - allocate (usage1(nloz)) - -! Set dependent variables and allocate arrays - nreal=12 - nchanl=1 - nozdat=nreal+nchanl - allocate (ozout(nozdat,maxobs)) - - do k=1,maxobs - do i=1,nozdat - ozout(i,k)=rmiss - end do - end do - - ikx=0 - k0=0 - ipos=999 - first=.false. - do k=1,jpch_oz - if( (.not. first) .and. index(nusis_oz(k),sis)/=0 ) then - k0=k - first=.true. - end if - if(first .and. index(nusis_oz(k),sis)/=0 ) then - ikx=ikx+1 - ipos(ikx)=k0+ikx-1 - end if - end do - -! Reopen unit to bufr file - call closbf(lunin) - open(lunin,file=trim(infile),form='unformatted') - call openbf(lunin,'IN',lunin) - call datelen(10) - call readmg(lunin,subset,idate,iret) - -140 continue - call readsb(lunin,iret) - if (iret/=0) then - call readmg(lunin,subset,jdate,iret) - if (iret/=0) goto 150 - goto 140 - endif - - do k=1,nloz - if (iuse_oz(ipos(k)) < 0) then - usage1(k) = 100._r_kind - else - usage1(k) = zero - endif - end do - -! extract header information - call ufbint(lunin,hdrmls,13,1,iret,mlstr) - rsat = hdrmls(1); ksatid=rsat - - if(jsatid == 'aura')kidsat = 785 - if (ksatid /= kidsat) go to 140 - - nmrecs=nmrecs+nloz - -! Convert observation location to radians - slats0= hdrmls(2) - slons0= hdrmls(3) - if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) go to 140 - if(slons0< zero) slons0=slons0+r360 - if(slons0==r360) slons0=zero - dlat_earth_deg = slats0 - dlon_earth_deg = slons0 - dlat_earth = slats0 * deg2rad - dlon_earth = slons0 * deg2rad - - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if(outside) go to 140 - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif - -! convert observation time to relative time - idate5(1) = hdrmls(4) !year - idate5(2) = hdrmls(5) !month - idate5(3) = hdrmls(6) !day - idate5(4) = hdrmls(7) !hour - idate5(5) = hdrmls(8) !minute - call w3fs21(idate5,nmind) - - t4dv=real((nmind-iwinbgn),r_kind)*r60inv - sstime=real(nmind,r_kind) - tdiff=(sstime-gstime)*r60inv - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) go to 140 - else - if(abs(tdiff) > twind) go to 140 - end if - -! v2.2 data screening, only accept: -! Pressure range(PRLC): 215-0.02mb (lev5-27) -! Precision(OZMP): positive OZMP; -! Status flag(MLST): only use even number -! Quality(PCCF): use >1.2 for data at 215-100mb & low latitude, -! use >0.4 for data elsewhere -! Convergence(CONV): use <1.8 - -! v2 NRT data screening, only accept: -! Pressure range(PRLC): 68-0.2mb (lev8-23) -! Precision(OZMP): positive OZMP; -! Status flag(MLST): only use even number -! Quality(PCCF): do NOT use <1.2 or >3.0 - -! v3 NRT data screening, only accept: -! Pressure range(PRLC): 261-0.1mb (lev8-43) -! Precision(OZMP): positive OZMP; -! Status flag(MLST): only use even number -! Quality(PCCF): only use if >0.4 -! Convergence(CONV): use <1.2 - -! status: Bit 1 in MLST represents data should not be used -! Note: in BUFR bits are defined from left to right as: 123456789... -! whereas in HDF5 (and the nasa document) bits are defined from right to left as: ...876543210 - decimal=int(hdrmls(12)) - call dec2bin(decimal,binary_mls,18) - if (binary_mls(1) == 1 ) goto 140 - -! v2.2 data, remove data when convergence>1.8 -! v3 NRT data,remove data when convergence>1.2 - if(mlsv==22) then - if(hdrmls(11) >= 1.8_r_kind) go to 140 - else if(mlsv==30) then - if(hdrmls(11) >= 1.2_r_kind) go to 140 - end if - -! extract pressure, ozone mixing ratio and precision - call ufbrep(lunin,hdrmlsl,3,nloz,iret,mlstrl) - - do k=1,nloz - mlspres(k)=log(hdrmlsl(1,k)*0.001_r_kind) ! mls pressure in Pa, coverted to log(cb) - mlsoz(k)=hdrmlsl(2,k) ! ozone mixing ratio in ppmv - mlsozpc(k)=hdrmlsl(3,k) ! ozone mixing ratio precision in ppmv -! there is possibility that mlsoz in bufr is 0 or negative or larger than 100 which are not reasonable values. - if(mlsoz(k)<1.0e-8_r_kind .or. mlsoz(k)>100.0_r_kind ) then - usage1(k)=1000._r_kind -! for v2.2 data, if this unreasonable value happens between 215mb (lev5) and 0.02mb (lev27), throw the whole profile -! for v2 NRT data, if this unreasonable value happens between 68mb (lev8) and 0.2mb (lev23), throw the whole profile -! for v3 NRT data, if this unreasonable value happens between 261mb (lev8) and 0.1mb (lev43), throw the whole profile - if(mlsv==22 .and. (k<=27 .and. k>=5)) go to 140 - if(mlsv==20 .and. (k<=23 .and. k>=8)) go to 140 - if(mlsv==30 .and. (k<=43 .and. k>=8)) go to 140 - end if - end do - - do k=1,nloz -! pressure range - if(mlsv==22) then - if(hdrmlsl(1,k)>21700._r_kind .or. hdrmlsl(1,k)<1._r_kind) usage1(k)=1000._r_kind - else if(mlsv==20) then - if(hdrmlsl(1,k)>6900._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=1000._r_kind - else if(mlsv==30) then - if(hdrmlsl(1,k)>26500._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=1000._r_kind - end if -! only positive precision accepted - if(hdrmlsl(3,k)<=0._r_kind) usage1(k)=1000._r_kind - end do - -! status screening - hdrmls13=hdrmls(13)*0.1_r_kind - if(mlsv==22) then - if (abs(slats0)<30._r_kind) then - do k=1,nloz - if(hdrmlsl(1,k)>10100._r_kind .and. hdrmlsl(1,k)<21700._r_kind) then - if(hdrmls13 <= 1.2_r_kind) usage1(k)=1000._r_kind - else - if(hdrmls13 <= 0.4_r_kind) usage1(k)=1000._r_kind - endif - end do - else - if(hdrmls13 <= 0.4_r_kind) then - do k=1,nloz - usage1(k)=1000._r_kind - end do - end if - end if - else if(mlsv==20) then - if(hdrmls13 <= 1.2_r_kind .or. hdrmls13 >= 3.0_r_kind) then - do k=1,nloz - usage1(k)=1000._r_kind - end do - end if - else if(mlsv==30) then - if(hdrmls13 <= 0.4_r_kind) then - do k=1,nloz - usage1(k)=1000._r_kind - end do - end if - end if - - do k=1,nloz - - ndata=min(ndata+1,maxobs) - nodata=ndata -! if(ndata >= nloz) goto 140 - - ozout(1,ndata)=rsat - ozout(2,ndata)=t4dv - ozout(3,ndata)=dlon ! grid relative longitude - ozout(4,ndata)=dlat ! grid relative latitude - ozout(5,ndata)=dlon_earth_deg ! earth relative longitude (degrees) - ozout(6,ndata)=dlat_earth_deg ! earth relative latitude (degrees) - ozout(7,ndata)=hdrmls(10) ! solar zenith angle - - ozout(8,ndata)=usage1(k) ! - ozout(9,ndata)=mlspres(k) ! mls pressure in log(cb) - ozout(10,ndata)=mlsozpc(k) ! ozone mixing ratio precision in ppmv - ozout(11,ndata)=float(ipos(k)) ! pointer of obs level index in ozinfo.txt - ozout(12,ndata)=nloz ! # of mls vertical levels - ozout(nreal+1,ndata)=mlsoz(k) ! ozone mixing ratio in ppmv - end do - - go to 140 - -! End of MLS bufr loop - - endif - -! Jump here when eof detected -150 continue - -! If gome or omi data, compress ozout array to thinned data - if (obstype=='omi' .or. obstype=='gome') then - kk=0 - do k=1,itxmax - if (ozout(1,k)>zero) then - kk=kk+1 - do i=1,nozdat - ozout(i,kk)=ozout(i,k) - end do - endif - end do - ndata=kk - nodata=ndata - endif - -! Write header record and data to output file for further processing - call count_obs(ndata,nozdat,ilat,ilon,ozout,nobs) - write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) ((ozout(k,i),k=1,nozdat),i=1,ndata) - nread=nmrecs - -! Deallocate local arrays -160 continue - deallocate(ozout) - if (obstype == 'sbuv2') deallocate(poz) - if (index(obstype,'mls')/=0) then - deallocate(hdrmlsl) - deallocate(mlspres) - deallocate(mlsoz) - deallocate(mlsozpc) - deallocate(ipos) - deallocate(usage1) - end if - -! Close unit to input data file -170 continue - call closbf(lunin) - close(lunin) - -! Deallocate satthin arrays - if (obstype == 'omi' .or. obstype == 'gome')call destroygrids - - return - -end subroutine read_ozone diff --git a/src/read_pcp.f90 b/src/read_pcp.f90 deleted file mode 100644 index b8bb9550a..000000000 --- a/src/read_pcp.f90 +++ /dev/null @@ -1,362 +0,0 @@ - subroutine read_pcp(nread,ndata,nodata,gstime,infile,lunout,obstype, & - twind,sis,nobs) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_pcp read pcp rate data -! prgmmr: treadon org: np23 date: 1998-05-15 -! -! abstract: This routine reads precipitation rate observations from -! various platforms/retrievals. Currently supported -! data sources include SSM/I, TMI, AMSU, and STAGE3 -! prepcipitation rates. Please note that only the SSM/I -! and TMI sections of the routine have been extensively -! tested. -! -! When running the gsi in regional mode, the code only -! retains those observations that fall within the regional -! domain -! -! program history log: -! 1998-05-15 yang, weiyu -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-16 treadon - update documentation -! 2004-07-29 treadon - add only to module use, add intent in/out -! 2004-09-17 todling - fix intent of jsatid -! 2004-10-28 treadon - replace parameter "tiny" with "tiny_r_kind" -! 2004-11-12 treadon - add code to read ssmi rain rates from prepbufr file -! 2005-01-27 treadon - change call to rdsfull -! 2005-04-22 treadon - correct ssmi read code to reflect mnemonic change from REQ6 to REQV -! 2005-08-16 guo - add gmao surface interface -! 2005-09-08 derber - modify to use input group time window -! 2005-09-28 derber - modify to produce consistent surface info -! 2005-10-06 treadon - allocate, load, and deallocate surface arrays needed by deter_sfc -! 2005-10-17 treadon - add grid and earth relative obs location to output file -! 2005-10-18 treadon - remove array obs_load and call to sumload -! 2005-11-29 parrish - modify getsfc to work for different regional options -! 2005-12-08 treadon - remove local land/sea/ice mask array since not used, remove -! gmao surface interface since not needed -! 2006-02-01 parrish - remove getsfc, destroy_sfc (different version called in read_obs) -! 2006-02-03 derber - modify for new obs control and obs count -! 2006-05-25 treadon - replace obstype "pcp_ssm/i" with "pcp_ssmi" -! 2007-03-01 tremolet - measure time from beginning of assimilation window -! 2008-04-18 safford - rm unused vars -! 2011-04-01 li - update argument list to deter_sfc -! 2011-08-01 lueken - added module use deter_sfc_mod -! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) -! 2015-02-23 Rancic/Thomas - add l4densvar to time window logical -! 2015-10-01 guo - consolidate use of ob location (in deg) -! -! input argument list: -! infile - unit from which to read BUFR data -! lunout - unit to which to write data for further processing -! obstype - observation type to process -! twind - input group time window (hours) -! sis - satellite/instrument/sensor indicator -! -! output argument list: -! nread - number of precipitation rate observations read -! ndata - number of precipitation rate profiles retained for further processing -! nodata - number of precipitation rate observations retained for further processing -! nobs - array of observations on each subdomain for each processor -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - use kinds, only: r_kind,r_double,i_kind - use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons - use constants, only: zero,deg2rad,tiny_r_kind,r60inv,r3600,r100 - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen - use deter_sfc_mod, only: deter_sfc_type - use obsmod, only: bmiss - use mpimod, only: npe - - implicit none - -! Declare passed variables - character(len=*),intent(in ) :: obstype,infile - character(len=20),intent(in ) :: sis - integer(i_kind) ,intent(in ) :: lunout - integer(i_kind) ,intent(inout) :: nread - integer(i_kind),dimension(npe) ,intent(inout) :: nobs - integer(i_kind) ,intent(inout) :: ndata,nodata - real(r_kind) ,intent(in ) :: gstime - real(r_kind) ,intent(in ) :: twind - -! Declare local parameters - real(r_kind),parameter:: r360=360.0_r_kind - -! Declare local variables - logical pcp_ssmi,pcp_tmi,pcp_amsu,pcp_stage3,outside - - character(6) ptype - character(8) subset - character(40) strhdr7,strsmi4,strsmi2_old,strsmi2,strtmi7,stramb5 - - integer(i_kind) imn,k,i,iyr,lnbufr,maxobs,isflg - integer(i_kind) ihh,idd,im,kx,jdate - integer(i_kind) ndatout,nreal,nchanl,iy,iret,idate,itype,ihr,idy,imo - integer(i_kind) minobs,lndsea,ilat,ilon - integer(i_kind) idate5(5) - - real(r_kind) scli,sclw,dlon,dlat,scnt - real(r_kind) dlat_earth,dlon_earth - real(r_kind) dlat_earth_deg,dlon_earth_deg - real(r_kind) scnv,stdv,spcp,tdiff,sstime,t4dv - real(r_kind) :: tsavg - real(r_kind),allocatable,dimension(:,:):: pcpdata - real(r_double) hdr7(7),pcpdat(7),pcpprd(2,2) - - data strhdr7 / 'RPID YEAR MNTH DAYS HOUR MINU SECO' / - data strsmi4 / 'CLAT CLON NMCT ACAV' / - data strsmi2_old / 'FOST REQ6' / - data strsmi2 / 'FOST REQV' / - data strtmi7 / 'CLAT CLON TRRT CRRT RCWA PCIA ACAV' / - data stramb5 / 'CLAT CLON REQV SNCV ICEP' / - - - data lnbufr /10/ - - -!************************************************************************** -! Initialize variables - maxobs=1e6 - nchanl = 0 - pcp_ssmi= obstype == 'pcp_ssmi' - pcp_tmi= obstype == 'pcp_tmi' - pcp_amsu= obstype == 'pcp_amsu' - pcp_stage3=obstype == 'pcp_stage3' - if (pcp_ssmi) then - nreal=10 - ptype='ssmi' - endif - if (pcp_tmi) then - nreal=12 - ptype='tmi' - endif - if (pcp_amsu) then - nreal=10 - ptype='amsu' - endif - if (pcp_stage3) then - nreal=10 - ptype='stage3' - endif - ndatout=nreal+nchanl - - -! Open and read the bufr data - call closbf(lnbufr) - open(lnbufr,file=trim(infile),form='unformatted') - call openbf(lnbufr,'IN',lnbufr) - call datelen(10) - call readmg(lnbufr,subset,idate,iret) - if (iret/=0) goto 110 - - iy=0; im=0; idd=0; ihh=0 - -! Write header record to pcp obs output file - ilon=3 - ilat=4 - - allocate(pcpdata(ndatout,maxobs)) - pcpdata=zero - -! Big loop over bufr file -10 call readsb(lnbufr,iret) - if(iret/=0) then - call readmg(lnbufr,subset,jdate,iret) - if(iret/=0) go to 100 - go to 10 - end if - - -! Extract satellite id and observation date/time - call ufbint(lnbufr,hdr7,7,1,iret,strhdr7) - - iyr = hdr7(2) - imo = hdr7(3) - idy = hdr7(4) - ihr = hdr7(5) - imn = hdr7(6) - - idate5(1) = iyr - idate5(2) = imo - idate5(3) = idy - idate5(4) = ihr - idate5(5) = imn - call w3fs21(idate5,minobs) - t4dv=real(minobs-iwinbgn,r_kind)*r60inv - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) goto 10 - else - sstime=real(minobs,r_kind) - tdiff = (sstime-gstime)*r60inv - if (abs(tdiff) > twind) goto 10 - endif - - if (pcp_ssmi) kx = 264 - if (pcp_tmi) kx = 211 - if (pcp_amsu) kx = 258 - if (pcp_stage3) kx = 260 - - -! Extract observation location and value(s) - if (pcp_ssmi) then - - call ufbint(lnbufr,pcpdat,4,1,iret,strsmi4) - if (pcpdat(3)>99999.0_r_double) then - itype=99999 - else - itype = nint(pcpdat(3)) - endif - scnt = pcpdat(4) - if (itype/=66) goto 10 - -! Transition across PREPBUFR mnemonic change from REQ6 to REQV - - call ufbrep(lnbufr,pcpprd,2,2,iret,strsmi2_old) - if(min(pcpprd(2,1),pcpprd(2,2))>=bmiss) & - call ufbrep(lnbufr,pcpprd,2,2,iret,strsmi2) - spcp = bmiss - if (nint(pcpprd(1,1))==4) spcp=pcpprd(2,1)*r3600 - if (nint(pcpprd(1,2))==10) stdv=pcpprd(2,2)*r3600 - -! Check for negative, very large, or missing pcp. -! If any case is found, skip this observation. - if ( (spcpr100) .or. & - (abs(spcp-bmiss)r100) .or. & - (abs(spcp-bmiss)r100) .or. & - (abs(spcp-bmiss)r100) .or. & - (abs(spcp-bmiss)90._r_kind .or. abs(dlon_earth)>r360) goto 10 - if (dlon_earth< zero) dlon_earth=dlon_earth+r360 - if (dlon_earth==r360) dlon_earth=dlon_earth-r360 - dlat_earth_deg=dlat_earth - dlon_earth_deg=dlon_earth - dlat_earth=dlat_earth*deg2rad - dlon_earth=dlon_earth*deg2rad - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if (outside) go to 10 - -! Global case. Convert observation (lat,lon) to radians - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif - -! -! Do we want to keep this observation? - nread = nread + 1 - ndata = min(ndata + 1,maxobs) - nodata = nodata + 1 -! - -! isflg - surface flag -! 0 sea -! 1 land -! 2 sea ice -! 3 snow -! 4 mixed - - call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg) - -! Load output array - - pcpdata(1,ndata) = kx ! satellite id - pcpdata(2,ndata) = t4dv ! time relative to cycle (hours) - pcpdata(3,ndata) = dlon ! grid relative longitude - pcpdata(4,ndata) = dlat ! grid relative latitude - pcpdata(5,ndata) = isflg + .001_r_kind ! surface tag - pcpdata(6,ndata) = spcp ! total precipitation (mm/hr) - if (pcp_ssmi) then - pcpdata(7,ndata) = stdv ! standard deviation of superobs - pcpdata(8,ndata) = scnt ! number of obs used to make superobs - pcpdata(9,ndata) = dlon_earth_deg ! earth relative longitude (degrees) - pcpdata(10,ndata)= dlat_earth_deg ! earth relative latitude (degrees) - elseif (pcp_tmi) then - pcpdata(7,ndata) = scnv ! convective precipitation (mm/hr) - pcpdata(8,ndata) = sclw ! cloud water (mm) - pcpdata(9,ndata) = scli ! cloud ice (mm) - pcpdata(10,ndata)= scnt ! number of obs used to make superobs - pcpdata(11,ndata)= dlon_earth_deg ! earth relative longitude (degrees) - pcpdata(12,ndata)= dlat_earth_deg ! earth relative latitude (degrees) - elseif (pcp_amsu) then - pcpdata(7,ndata) = zero ! standard deviation of superobs (not yet) - pcpdata(8,ndata) = itype ! type of algorithm - pcpdata(9,ndata) = dlon_earth_deg ! earth relative longitude (degrees) - pcpdata(10,ndata)= dlat_earth_deg ! earth relative latitude (degrees) - elseif (pcp_stage3) then - pcpdata(7,ndata) = stdv ! standard deviation of superobs - pcpdata(8,ndata) = scnt ! number of obs used to make superobs - pcpdata(9,ndata) = dlon_earth_deg ! earth relative longitude (degrees) - pcpdata(10,ndata)= dlat_earth_deg ! earth relative latitude (degrees) - endif -! -! End of big loop over bufr file. Process next observation. - go to 10 - - -! Jump here when the end of the bufr file is reach or there -! is some other problem reading the bufr file -100 continue - - -! Write retained data to local file - call count_obs(ndata,ndatout,ilat,ilon,pcpdata,nobs) - write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) ((pcpdata(k,i),k=1,ndatout),i=1,ndata) - deallocate(pcpdata) - - -! Jump here if there is a problem opening the bufr file -110 continue - call closbf(lnbufr) - -! End of routine - return -end subroutine read_pcp diff --git a/src/read_radar.f90 b/src/read_radar.f90 deleted file mode 100644 index 7f6c1ab90..000000000 --- a/src/read_radar.f90 +++ /dev/null @@ -1,2778 +0,0 @@ -! SUBSET=NC006001 -- level 3 superobs -! SUBSET=NC006002 -- level 2.5 superobs -! SUBSET=NC006070 -- RADIAL WIND FROM P3 RADAR -subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_full,nobs) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_radar read radar radial winds -! prgmmr: yang org: np23 date: 1998-05-15 -! -! abstract: This routine reads radar radial wind files. -! -! When running the gsi in regional mode, the code only -! retains those observations that fall within the regional -! domain -! -! program history log: -! 1998-05-15 yang, weiyu -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-16 treadon - update documentation -! 2004-07-29 treadon - add only to module use, add intent in/out -! 2005-06-10 devenyi/treadon - correct subset declaration -! 2005-08-02 derber - modify to use convinfo file -! 2005-09-08 derber - modify to use input group time window -! 2005-10-11 treadon - change convinfo read to free format -! 2005-10-17 treadon - add grid and earth relative obs location to output file -! 2005-10-18 treadon - remove array obs_load and call to sumload -! 2005-10-26 treadon - add routine tag to convinfo printout -! 2006-02-03 derber - modify for new obs control and obs count -! 2006-02-08 derber - modify to use new convinfo module -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-04-21 parrish - modify to use level 2, 2.5, and/or 3 radar wind -! superobs, with qc based on vad wind data. -! 2006-05-23 parrish - interpolate model elevation to vad wind site -! 2006-07-28 derber - use r1000 from constants -! 2007-03-01 tremolet - measure time from beginning of assimilation window -! 2008-04-17 safford - rm unused vars and uses -! 2008-09-08 lueken - merged ed's changes into q1fy09 code -! 2009-06-08 parrish - remove erroneous call to cosd, sind -! 2009-05-08 tong - add reading NOAA P3 tail Dopple radar data -! 2010-09-08 parrish - remove subroutine check_rotate_wind. This was a debug routine introduced when -! the reference wind rotation angle was stored as an angle, beta_ref. This field -! had a discontinuity at the date line (180E), which resulted in erroneous wind -! rotation angles for a small number of winds whose rotation angle was interpolated -! from beta_ref values across the discontinuity. This was fixed by replacing the -! beta_ref field with cos_beta_ref, sin_beta_ref. -! 2011-03-28 s.liu - add subtype to radial wind observation and limit the use -! of level2.5 and level3 data in Conus domain for NMM and NMMB -! 2011-08-01 lueken - remove deter_zsfc_model (placed in deter_sfc_mod) and fix indentation -! 2012-01-11 m.Hu - add subtype to radial wind observation and limit the use -! of level2.5 and level3 data in Conus domain for ARW -! 2012-06-26 y.li/x.wang add TDR fore/aft sweep separation for thinning,xuguang.wang@ou.edu -! 2012-04-28 s.liu - use new VAD wind -! 2012-11-12 s.liu - add new VAD wind flag -! 2013-01-26 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) -! 2013-05-07 tong - add reading tdr superobs data -! 2013-05-22 tong - Modified the criteria of seperating fore and aft sweeps for TDR NOAA/FRENCH antenna -! 2015-02-23 Rancic/Thomas - add thin4d to time window logical -! 2015-10-01 guo - consolidate use of ob location (in deg) -! 2016-12-21 lippi/carley - add logic to run l2rw loop (==0) or run loop for l3rw and l2_5rw (==1,2) -! to help fix a multiple data read bug (when l2rwbufr and radarbufr were both -! listed in the OBS_INPUT table) and for added flexibility for experimental setups. -! -! -! input argument list: -! infile - file from which to read BUFR data -! lunout - unit to which to write data for further processing -! obstype - observation type to process -! twind - input group time window (hours) -! hgtl_full- 3d geopotential height on full domain grid -! -! output argument list: -! nread - number of doppler lidar wind observations read -! ndata - number of doppler lidar wind profiles retained for further processing -! nodata - number of doppler lidar wind observations retained for further processing -! sis - satellite/instrument/sensor indicator -! nobs - array of observations on each subdomain for each processor -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - use kinds, only: r_kind,r_single,r_double,i_kind,i_byte - use constants, only: zero,zero_single,half,one,two,three,deg2rad,rearth,rad2deg, & - one_tenth,r10,r1000,r60inv,r100,r400,grav_equator, & - eccentricity,somigliana,grav_ratio,grav, & - semi_major_axis,flattening,two - use qcmod, only: erradar_inflate,vadfile,newvad - use obsmod, only: iadate,ianldate,l_foreaft_thin - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d - use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,nsig - use gridmod, only: wrf_nmm_regional,nems_nmmb_regional,cmaq_regional,wrf_mass_regional - use convinfo, only: nconvtype,ctwind, & - ncmiter,ncgroup,ncnumgrp,icuse,ictype,ioctype,ithin_conv,rmesh_conv,pmesh_conv - use convthin, only: make3grids,map3grids,del3grids,use_all - use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model - use mpimod, only: npe - use gsi_io, only: verbose - implicit none - -! Declare passed variables - character(len=*),intent(in ) :: obstype,infile - character(len=20),intent(in ) :: sis - real(r_kind) ,intent(in ) :: twind - integer(i_kind) ,intent(in ) :: lunout - integer(i_kind) ,intent(inout) :: nread,ndata,nodata - integer(i_kind),dimension(npe) ,intent(inout) :: nobs - real(r_kind),dimension(nlat,nlon,nsig),intent(in):: hgtl_full - -! Declare local parameters - integer(i_kind),parameter:: maxlevs=1500 - integer(i_kind),parameter:: maxdat=22 - integer(i_kind),parameter:: maxvad=500 -! integer(i_kind),parameter:: maxvadbins=20 - integer(i_kind),parameter:: maxvadbins=15 - real(r_kind),parameter:: r4_r_kind = 4.0_r_kind - - real(r_kind),parameter:: dzvad=304.8_r_kind ! vad reports are every 1000 ft = 304.8 meters - real(r_kind),parameter:: r3_5 = 3.5_r_kind - real(r_kind),parameter:: r6 = 6.0_r_kind - real(r_kind),parameter:: r8 = 8.0_r_kind - real(r_kind),parameter:: r90 = 90.0_r_kind - real(r_kind),parameter:: r200 = 200.0_r_kind - real(r_kind),parameter:: r150 = 150.0_r_kind - real(r_kind),parameter:: r360=360.0_r_kind - real(r_kind),parameter:: r50000 = 50000.0_r_kind - real(r_kind),parameter:: r60 = 60.0_r_kind - real(r_kind),parameter:: r75 = 75.0_r_kind - real(r_kind),parameter:: r92 = 92.6e03_r_kind - real(r_kind),parameter:: r89_5 = 89.5_r_kind - real(r_kind),parameter:: r2 = 2.0_r_kind - real(r_kind),parameter:: r71 = 71.0_r_kind - real(r_kind),parameter:: four_thirds = 4.0_r_kind / 3.0_r_kind - -! Declare local variables - logical good,outside,good0,lexist1,lexist2 - - character(10) date - character(80) hdrstr(2),datstr(2) - character(8) subset,subset_check(3) - character(30) outmessage - character(255) filename - - integer(i_kind) lnbufr,i,j,k,maxobs,icntpnt,iiout,n,istop - integer(i_kind) nmrecs,ibadazm,ibadtilt,ibadrange,ibadwnd,ibaddist,ibadheight,ibadvad,kthin - integer(i_kind) iyr,imo,idy,ihr,imn,isc,ithin - integer(i_kind) ibadstaheight,ibaderror,notgood,idate,iheightbelowsta,ibadfit - integer(i_kind) notgood0 - integer(i_kind) novadmatch,ioutofvadrange - integer(i_kind) iy,im,idd,ihh,iret,levs,mincy,minobs,kx0,kxadd,kx - integer(i_kind) nreal,nchanl,ilat,ilon,ikx - integer(i_kind),dimension(5):: idate5 - integer(i_kind) ivad,ivadz,nvad,idomsfc - - real(r_kind) timeb,rmesh,usage,ff10,sfcr,skint,t4dv,t4dvo,toff - real(r_kind) eradkm,dlat_earth,dlon_earth - real(r_kind) dlat_earth_deg,dlon_earth_deg - real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat - real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist - real(r_kind) rwnd,azm,height,error,wqm - real(r_kind) azm_earth,cosazm_earth,sinazm_earth,cosazm,sinazm - real(r_kind):: zsges - - real(r_kind),dimension(maxdat):: cdata - real(r_kind),allocatable,dimension(:,:):: cdata_all - - real(r_double) rstation_id - real(r_double),dimension(12):: hdr - character(8) cstaid - character(4) this_staid - equivalence (this_staid,cstaid) - equivalence (cstaid,rstation_id) - real(r_double),dimension(7,maxlevs):: radar_obs - real(r_double),dimension(4,maxlevs):: vad_obs - real(r_double),dimension(2,maxlevs):: fcst_obs - - character(8) vadid(maxvad) - real(r_kind) vadlat(maxvad),vadlon(maxvad),vadqm(maxvad,maxvadbins) - real(r_kind) vadu(maxvad,maxvadbins),vadv(maxvad,maxvadbins) - real(r_kind) vadcount(maxvad,maxvadbins) - real(r_kind),dimension(maxvad,maxvadbins)::vadfit2,vadcount2,vadwgt2 - real(r_kind),dimension(maxvad,maxvadbins)::vadfit2_5,vadcount2_5,vadwgt2_5 - real(r_kind),dimension(maxvad,maxvadbins)::vadfit3,vadcount3,vadwgt3 - real(r_kind) zob,vadqmmin,vadqmmax - integer(i_kind) level2(maxvad),level2_5(maxvad),level3(maxvad),level3_tossed_by_2_5(maxvad) - integer(i_kind) loop,numcut - integer(i_kind) numhits(0:maxvad) - real(r_kind) timemax,timemin,errmax,errmin - real(r_kind) dlatmax,dlonmax,dlatmin,dlonmin - real(r_kind) xscale,xscalei - integer(i_kind) max_rrr,nboxmax - integer(i_kind) irrr,iaaa,iaaamax,iaaamin - integer(i_byte),allocatable::nobs_box(:,:,:,:) - real(r_kind) dlonvad,dlatvad,vadlon_earth,vadlat_earth - real(r_kind) this_stalat,this_stalon,this_stahgt,thistime,thislat,thislon - real(r_kind) azm0,elev0,range0,rotang - real(r_kind) thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt - integer(i_kind) nsuper2_in,nsuper2_kept - integer(i_kind) nsuper2_5_in,nsuper2_5_kept - integer(i_kind) nsuper3_in,nsuper3_kept - real(r_kind) errzmax - real(r_kind) thisfit,thisvadspd,thisfit2,uob,vob,thiswgt -! real(r_kind) dist2min,dist2max -! real(r_kind) dist2_5min,dist2_5max - real(r_kind) vad_leash - -! following variables are use for tdr rw data - real(r_double),dimension(4,maxlevs):: tdr_obs - integer(i_kind) :: ii,jjj,nmissing,nirrr,noutside,ntimeout,nsubzero,iimax - integer(i_kind) ntdrvr_in,ntdrvr_kept,ntdrvr_thin1,ntdrvr_thin2 - integer(i_kind) ntdrvr_thin2_foreswp,ntdrvr_thin2_aftswp - integer(i_kind) maxout,maxdata - integer(i_kind) kk,klon1,klat1,klonp1,klatp1 - integer(i_kind),allocatable,dimension(:):: isort - - real(r_single) elevmax,elevmin - real(r_single) thisrange,thisazimuth,thistilt - real(r_single), dimension(maxlevs) :: dopbin, z, elev, elat8, elon8, glob_azimuth8 - - real(r_kind) rlon0,this_stalatr,thistiltr - real(r_kind) clat0,slat0 - real(r_single) a43,aactual,selev0,celev0,erad - - real(r_kind) sin2,termg,termr,termrg,zobs - real(r_kind) xmesh,pmesh - real(r_kind),dimension(nsig):: zges,hges - real(r_kind) dx,dy,dx1,dy1,w00,w10,w01,w11 - logical luse - integer(i_kind) ntmp,iout - integer(i_kind):: zflag - integer(i_kind) nlevz ! vertical level for thinning - real(r_kind) crit1,timedif - real(r_kind),allocatable,dimension(:):: zl_thin - real(r_kind),parameter:: r16000 = 16000.0_r_kind - real(r_kind) diffuu,diffvv - -! following variables are for fore/aft separation - real(r_kind) tdrele1,tdrele2,tdrele3 - integer(i_kind) nswp,firstbeam,nforeswp,naftswp,nfore,naft,nswptype,irec - logical foreswp,aftswp - - data lnbufr/10/ - data hdrstr(1) / 'CLAT CLON SELV ANEL YEAR MNTH DAYS HOUR MINU MGPT' / - data hdrstr(2) / 'PTID YEAR MNTH DAYS HOUR MINU SECO CLAT CLON HSMSL ANAZ ANEL' / - data datstr(1) / 'STDM SUPLAT SUPLON HEIT RWND RWAZ RSTD' / - data datstr(2) / 'DIST HREF DMVR DVSW' / - - data ithin / -9 / - data rmesh / -99.999_r_kind / - logical print_verbose -!*********************************************************************************** - print_verbose=.false. - if(verbose)print_verbose=.true. - -! Check to see if radar wind files exist. If none exist, exit this routine. - inquire(file='radar_supobs_from_level2',exist=lexist1) - inquire(file=trim(infile),exist=lexist2) - if (.not.lexist1 .and. .not.lexist2) goto 900 - - eradkm=rearth*0.001_r_kind - maxobs=2e6 - nreal=maxdat - nchanl=0 - ilon=2 - ilat=3 - iaaamax=-huge(iaaamax) - iaaamin=huge(iaaamin) - dlatmax=-huge(dlatmax) - dlonmax=-huge(dlonmax) - dlatmin=huge(dlatmin) - dlonmin=huge(dlonmin) - - if(ianldate > 2016092000)then - hdrstr(2)='PTID YEAR MNTH DAYS HOUR MINU SECO CLAT CLON FLVLST ANAZ ANEL' - end if - - allocate(cdata_all(maxdat,maxobs),isort(maxobs)) - - isort = 0 - cdata_all=zero - - if (trim(infile) == 'tldplrbufr' .or. trim(infile) == 'tldplrso') goto 65 - -! Initialize variables -! vad_leash=.1_r_kind - vad_leash=.3_r_kind - !xscale=5000._r_kind - !xscale=10000._r_kind - xscale=20000._r_kind - if(print_verbose)then - write(6,*)'READ_RADAR: set vad_leash,xscale=',vad_leash,xscale - write(6,*)'READ_RADAR: set maxvadbins,maxbadbins*dzvad=',maxvadbins,& - maxvadbins*dzvad - end if - xscalei=one/xscale - max_rrr=nint(100000.0_r_kind*xscalei) - nboxmax=1 - - kx0=22500 - - nmrecs=0 - irec=0 - - errzmax=zero - nvad=0 - vadlon=zero - vadlat=zero - vadqm=-99999_r_kind - vadu=zero - vadv=zero - vadcount=zero - vadqmmax=-huge(vadqmmax) - vadqmmin=huge(vadqmmin) - -! First read in all vad winds so can use vad wind quality marks to decide -! which radar data to keep -! Open, then read bufr data - - open(lnbufr,file=vadfile,form='unformatted') - call openbf(lnbufr,'IN',lnbufr) - call datelen(10) - -11 call readsb(lnbufr,iret) - if(iret/=0) then - call readmg(lnbufr,subset,idate,iret) - if(iret/=0) go to 21 - go to 11 - end if - call ufbint(lnbufr,hdr,7,1,levs,'SID XOB YOB DHR TYP SAID TSB') - kx=nint(hdr(5)) - if(kx /= 224) go to 11 ! for now just hardwire vad wind type - if(kx==224 .and. .not.newvad) then - if(hdr(7)==2) then - newvad=.true. - go to 21 - end if - end if -! End of bufr read loop - go to 11 - -! Normal exit -21 continue - call closbf(lnbufr) - -! enddo msg_report - - open(lnbufr,file=vadfile,form='unformatted') - call openbf(lnbufr,'IN',lnbufr) - call datelen(10) - call readmg(lnbufr,subset,idate,iret) - if(iret/=0) go to 20 - -! Time offset - call time_4dvar(idate,toff) - - write(date,'( i10)') idate - read (date,'(i4,3i2)') iy,im,idd,ihh - if(print_verbose) & - write(6,*)'READ_RADAR: first read vad winds--use vad quality marks to qc 2.5/3 radar winds' - -! Big loop over vadwnd bufr file -10 call readsb(lnbufr,iret) - if(iret/=0) then - call readmg(lnbufr,subset,idate,iret) - if(iret/=0) go to 20 - go to 10 - end if - nmrecs = nmrecs+1 - -! Read header. Extract station infomration - call ufbint(lnbufr,hdr,7,1,levs,'SID XOB YOB DHR TYP SAID TSB') - kx=nint(hdr(5)) - if(kx /= 224) go to 10 ! for now just hardwire vad wind type - -! write(6,*)'new vad::',newvad, hdr(7) - if(.not.newvad .and. hdr(7)==2) go to 10 - if(newvad .and. hdr(7)/=2) go to 10 - ! and don't worry about subtypes -! Is vadwnd in convinfo file - ikx=0 - do i=1,nconvtype - if(kx == ictype(i)) then - ikx=i - exit - end if - end do - if(ikx == 0) go to 10 - -! Time check - t4dv=toff+hdr(4) - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) go to 10 ! outside time window - else - timeb=hdr(4) - if(abs(timeb) > ctwind(ikx) .or. abs(timeb) > half) go to 10 ! outside time window - endif - -! Create table of vad lat-lons and quality marks in 500m increments -! for cross-referencing bird qc against radar winds - rstation_id=hdr(1) !station id - dlon_earth=hdr(2) !station lat (degrees) - dlat_earth=hdr(3) !station lon (degrees) - - if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 - if (dlon_earth0) then - do i=1,nvad - if(modulo(rad2deg*abs(dlon_earth-vadlon(i)),r360)maxvad) then - write(6,*)'READ_RADAR: ***ERROR*** MORE THAN ',maxvad,' RADARS: PROGRAM STOPS' - call stop2(84) - end if - ivad=nvad - vadlon(ivad)=dlon_earth - vadlat(ivad)=dlat_earth - vadid(ivad)=cstaid - end if - -! Update vadqm table - call ufbint(lnbufr,vad_obs,4,maxlevs,levs,'ZOB WQM UOB VOB ') - call ufbint(lnbufr,fcst_obs,2,maxlevs,levs,'UFC VFC ') - if(levs>maxlevs) then - write(6,*)'READ_RADAR: ***ERROR*** need to increase read_radar bufr size since ',& - ' number of levs=',levs,' > maxlevs=',maxlevs - call stop2(84) - endif - - do k=1,levs - wqm=vad_obs(2,k) - zob=vad_obs(1,k) - uob=vad_obs(3,k) - vob=vad_obs(4,k) - if(newvad) then - diffuu=uob-fcst_obs(1,k) - diffvv=vob-fcst_obs(2,k) - if(sqrt(diffuu**2+diffvv**2)>10.0) cycle - if(abs(diffvv)>8.0) cycle - if(abs(diffvv)>5.0.and.zob<5000.0) cycle - if(zob>7000.0) cycle - end if - ivadz=nint(zob/dzvad) - if(ivadz<1.or.ivadz>maxvadbins) cycle - errzmax=max(abs(zob-ivadz*dzvad),errzmax) - vadqm(ivad,ivadz)=max(vadqm(ivad,ivadz),wqm) - vadqmmax=max(vadqmmax,wqm) - vadqmmin=min(vadqmmin,wqm) - vadu(ivad,ivadz)=vadu(ivad,ivadz)+uob - vadv(ivad,ivadz)=vadv(ivad,ivadz)+vob - vadcount(ivad,ivadz)=vadcount(ivad,ivadz)+one - end do - - -! End of bufr read loop - go to 10 - -! Normal exit -20 continue - call closbf(lnbufr) - - -! Print vadwnd table - if(nvad>0) then - do ivad=1,nvad - do ivadz=1,maxvadbins - vadu(ivad,ivadz)=vadu(ivad,ivadz)/max(one,vadcount(ivad,ivadz)) - vadv(ivad,ivadz)=vadv(ivad,ivadz)/max(one,vadcount(ivad,ivadz)) - end do - if(print_verbose) & - write(6,'(" n,lat,lon,qm=",i3,2f8.2,2x,25i3)') & - ivad,vadlat(ivad)*rad2deg,vadlon(ivad)*rad2deg,(max(-9,nint(vadqm(ivad,k))),k=1,maxvadbins) - end do - end if - if(print_verbose)write(6,*)' errzmax=',errzmax - -! Allocate thinning grids around each radar -! space needed is nvad*max_rrr*max_rrr*8*max_zzz -! -! max_rrr=20 -! maxvadbins=20 -! nvad=150 -! space=150*20*20*8*20 = 64000*150=9600000 peanuts - - allocate(nobs_box(max_rrr,8*max_rrr,maxvadbins,nvad)) - nobs_box=0 - -! Set level2_5 to 0. Then loop over routine twice, first looking for -! level 2.5 data, and setting level2_5=count of 2.5 data for any 2.5 data -! available that passes the vad tests. The second pass puts in level 3 -! data where it is available and no level 2.5 data was saved/available -! (level2_5=0) - - vadfit2=zero - vadfit2_5=zero - vadfit3=zero - vadwgt2=zero - vadwgt2_5=zero - vadwgt3=zero - vadcount2=zero - vadcount2_5=zero - vadcount3=zero - level2=0 - level2_5=0 - level3=0 - level3_tossed_by_2_5=0 - subset_check(1)='NC006002' - subset_check(2)='NC006001' - -! First process any level 2 superobs. -! Initialize variables. - ikx=0 - do i=1,nconvtype - if(trim(ioctype(i)) == trim(obstype))ikx = i - end do - - timemax=-huge(timemax) - timemin=huge(timemin) - errmax=-huge(errmax) - errmin=huge(errmin) - loop=0 - - numhits=0 - ibadazm=0 - ibadwnd=0 - ibaddist=0 - ibadheight=0 - ibadstaheight=0 - iheightbelowsta=0 - ibaderror=0 - ibadvad=0 - ibadfit=0 - ioutofvadrange=0 - kthin=0 - novadmatch=0 - notgood=0 - notgood0=0 - nsuper2_in=0 - nsuper2_kept=0 - -! LEVEL_TWO_READ: if(loop==0 .and. sis=='l2rw') then - if(loop==0) outmessage='level 2 superobs:' - -! Open sequential file containing superobs - open(lnbufr,file='radar_supobs_from_level2',form='unformatted') - rewind lnbufr - - ! dist2max=-huge(dist2max) - ! dist2min=huge(dist2min) - -! Loop to read superobs data file - do - read(lnbufr,iostat=iret)this_staid,this_stalat,this_stalon,this_stahgt, & - thistime,thislat,thislon,thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt - if(iret/=0) exit - nsuper2_in=nsuper2_in+1 - - dlat_earth=this_stalat !station lat (degrees) - dlon_earth=this_stalon !station lon (degrees) - if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 - if (dlon_earthwinlen) cycle - else - timeo=thistime - if(abs(timeo)>half ) cycle - endif - -! Get observation (lon,lat). Compute distance from radar. - dlat_earth=thislat - dlon_earth=thislon - if(dlon_earth>=r360) dlon_earth=dlon_earth-r360 - if(dlon_earthmax_rrr) cycle - -! Extract radial wind data - height= thishgt - rwnd = thisvr - azm_earth = corrected_azimuth - if(regional) then - cosazm_earth=cos(azm_earth*deg2rad) - sinazm_earth=sin(azm_earth*deg2rad) - call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) - azm=atan2(sinazm,cosazm)*rad2deg - else - azm=azm_earth - end if - iaaa=azm/(r360/(r8*irrr)) - iaaa=mod(iaaa,8*irrr) - if(iaaa<0) iaaa=iaaa+8*irrr - iaaa=iaaa+1 - iaaamax=max(iaaamax,iaaa) - iaaamin=min(iaaamin,iaaa) - - error = erradar_inflate*thiserr - errmax=max(error,errmax) - if(thiserr>zero) errmin=min(error,errmin) - -! Perform limited qc based on azimuth angle, radial wind -! speed, distance from radar site, elevation of radar, -! height of observation, observation error, and goodness of fit to vad wind - - good0=.true. - if(abs(azm)>r400) then - ibadazm=ibadazm+1; good0=.false. - end if - if(abs(rwnd)>r200) then - ibadwnd=ibadwnd+1; good0=.false. - end if - if(dist>r400) then - ibaddist=ibaddist+1; good0=.false. - end if - if(staheight<-r1000.or.staheight>r50000) then - ibadstaheight=ibadstaheight+1; good0=.false. - end if - if(height<-r1000.or.height>r50000) then - ibadheight=ibadheight+1; good0=.false. - end if - if(heightr6 .or. thiserr<=zero) then - ibaderror=ibaderror+1; good0=.false. - end if - good=.true. - if(.not.good0) then - notgood0=notgood0+1 - cycle - else - -! Check fit to vad wind and vad wind quality mark - ivadz=nint(thishgt/dzvad) - if(ivadz>maxvadbins.or.ivadz<1) then - ioutofvadrange=ioutofvadrange+1 - cycle - end if - thiswgt=one/max(r4_r_kind,thiserr**2) - thisfit2=(vadu(ivad,ivadz)*cos(azm_earth*deg2rad)+vadv(ivad,ivadz)*sin(azm_earth*deg2rad)-thisvr)**2 - thisfit=sqrt(thisfit2) - thisvadspd=sqrt(vadu(ivad,ivadz)**2+vadv(ivad,ivadz)**2) - vadfit2(ivad,ivadz)=vadfit2(ivad,ivadz)+thiswgt*thisfit2 - vadcount2(ivad,ivadz)=vadcount2(ivad,ivadz)+one - vadwgt2(ivad,ivadz)=vadwgt2(ivad,ivadz)+thiswgt - if(thisfit/max(one,thisvadspd)>vad_leash) then - ibadfit=ibadfit+1; good=.false. - end if - if(nobs_box(irrr,iaaa,ivadz,ivad)>nboxmax) then - kthin=kthin+1 - good=.false. - end if - if(vadqm(ivad,ivadz) > r3_5 .or. vadqm(ivad,ivadz) < -one) then - ibadvad=ibadvad+1 ; good=.false. - end if - end if - -! If data is good, load into output array - if(good) then - nsuper2_kept=nsuper2_kept+1 - level2(ivad)=level2(ivad)+1 - nobs_box(irrr,iaaa,ivadz,ivad)=nobs_box(irrr,iaaa,ivadz,ivad)+1 - ndata =min(ndata+1,maxobs) - nodata =min(nodata+1,maxobs) !number of obs not used (no meaning here) - usage = zero - if(icuse(ikx) < 0)usage=r100 - if(ncnumgrp(ikx) > 0 )then ! cross validation on - if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) - end if - - call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) - - LEVEL_TWO_READ: if(loop==0 .and. sis=='l2rw') then - cdata(1) = error ! wind obs error (m/s) - cdata(2) = dlon ! grid relative longitude - cdata(3) = dlat ! grid relative latitude - cdata(4) = height ! obs absolute height (m) - cdata(5) = rwnd ! wind obs (m/s) - cdata(6) = azm*deg2rad ! azimuth angle (radians) - cdata(7) = t4dv ! obs time (hour) - cdata(8) = ikx ! type - cdata(9) = tiltangle ! tilt angle (radians) - cdata(10)= staheight ! station elevation (m) - cdata(11)= rstation_id ! station id - cdata(12)= usage ! usage parameter - cdata(13)= idomsfc ! dominate surface type - cdata(14)= skint ! skin temperature - cdata(15)= ff10 ! 10 meter wind factor - cdata(16)= sfcr ! surface roughness - cdata(17)=dlon_earth_deg ! earth relative longitude (degrees) - cdata(18)=dlat_earth_deg ! earth relative latitude (degrees) - cdata(19)=dist ! range from radar in km (used to estimate beam spread) - cdata(20)=zsges ! model elevation at radar site - cdata(21)=thiserr - cdata(22)=two - -! if(vadid(ivad)=='0303LWX') then -! dist2max=max(dist2max,dist) -! dist2min=min(dist2min,dist) -! end if - - do i=1,maxdat - cdata_all(i,ndata)=cdata(i) - end do - END IF LEVEL_TWO_READ - - else - notgood = notgood + 1 - end if - - end do - - close(lnbufr) ! A simple unformatted fortran file should not be mixed with a bufr I/O - - LEVEL_TWO_READ_2: if(loop==0 .and. sis=='l2rw') then - write(6,*)'READ_RADAR: ',trim(outmessage),' reached eof on 2/2.5/3 superob radar file' - write(6,*)'READ_RADAR: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept - write(6,*)'READ_RADAR: # no vad match =',novadmatch - write(6,*)'READ_RADAR: # out of vadrange=',ioutofvadrange - write(6,*)'READ_RADAR: # bad azimuths=',ibadazm - write(6,*)'READ_RADAR: # bad winds =',ibadwnd - write(6,*)'READ_RADAR: # bad dists =',ibaddist - write(6,*)'READ_RADAR: # bad stahgts =',ibadstaheight - write(6,*)'READ_RADAR: # bad obshgts =',ibadheight - write(6,*)'READ_RADAR: # bad errors =',ibaderror - write(6,*)'READ_RADAR: # bad vadwnd =',ibadvad - write(6,*)'READ_RADAR: # bad fit =',ibadfit - write(6,*)'READ_RADAR: # num thinned =',kthin - write(6,*)'READ_RADAR: # notgood0 =',notgood0 - write(6,*)'READ_RADAR: # notgood =',notgood - write(6,*)'READ_RADAR: # hgt belowsta=',iheightbelowsta - write(6,*)'READ_RADAR: timemin,max =',timemin,timemax - write(6,*)'READ_RADAR: errmin,max =',errmin,errmax - write(6,*)'READ_RADAR: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax - write(6,*)'READ_RADAR: iaaamin,max,8*max_rrr =',iaaamin,iaaamax,8*max_rrr - END IF LEVEL_TWO_READ_2 - - LEVEL_THREE_READ: if(sis=='l3rw' .or. sis=='rw') then -! Next process level 2.5 and 3 superobs - -! Bigger loop over first level 2.5 data, and then level3 data - - timemax=-huge(timemax) - timemin=huge(timemin) - errmax=-huge(errmax) - errmin=huge(errmin) - nsuper2_5_in=0 - nsuper3_in=0 - nsuper2_5_kept=0 - nsuper3_kept=0 - do loop=1,2 - - numhits=0 - ibadazm=0 - ibadwnd=0 - ibaddist=0 - ibadheight=0 - ibadstaheight=0 - iheightbelowsta=0 - ibaderror=0 - ibadvad=0 - ibadfit=0 - ioutofvadrange=0 - kthin=0 - novadmatch=0 - notgood=0 - notgood0=0 -! dist2_5max=-huge(dist2_5max) -! dist2_5min=huge(dist2_5min) - - if(loop==1) outmessage='level 2.5 superobs:' - if(loop==2) outmessage='level 3 superobs:' - -! Open, then read bufr data - open(lnbufr,file=trim(infile),form='unformatted') - - call openbf(lnbufr,'IN',lnbufr) - call datelen(10) - call readmg(lnbufr,subset,idate,iret) - if(iret/=0) then - call closbf(lnbufr) - go to 1000 - end if - - idate5(1) = iy ! year - idate5(2) = im ! month - idate5(3) = idd ! day - idate5(4) = ihh ! hour - idate5(5) = 0 ! minute - call w3fs21(idate5,mincy) - - - nmrecs=0 -! Big loop over bufr file - - 50 call readsb(lnbufr,iret) - 60 continue - if(iret/=0) then - call readmg(lnbufr,subset,idate,iret) - if(iret/=0) go to 1000 - go to 50 - end if - if(subset/=subset_check(loop)) then - iret=99 - go to 60 - end if - nmrecs = nmrecs+1 - - -! Read header. Extract station infomration - call ufbint(lnbufr,hdr,10,1,levs,hdrstr(1)) - - ! rstation_id=hdr(1) !station id - write(cstaid,'(2i4)')idint(hdr(1)),idint(hdr(2)) - if(cstaid(1:1)==' ')cstaid(1:1)='S' - dlat_earth=hdr(1) !station lat (degrees) - dlon_earth=hdr(2) !station lon (degrees) - if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 - if (dlon_earth230.0_r_kind .and. & - dlat_earth <54.0_r_kind)then - go to 50 - end if - end if - end if - dlat_earth = dlat_earth * deg2rad - dlon_earth = dlon_earth * deg2rad - - if(regional)then - call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) - if (outside) go to 50 - dlatmax=max(dlat,dlatmax) - dlonmax=max(dlon,dlonmax) - dlatmin=min(dlat,dlatmin) - dlonmin=min(dlon,dlonmin) - else - dlat = dlat_earth - dlon = dlon_earth - call grdcrd1(dlat,rlats,nlat,1) - call grdcrd1(dlon,rlons,nlon,1) - endif - - clon=cos(dlon_earth) - slon=sin(dlon_earth) - clat=cos(dlat_earth) - slat=sin(dlat_earth) - staheight=hdr(3) !station elevation - tiltangle=hdr(4)*deg2rad - -! Find vad wind match - ivad=0 - do k=1,nvad - cdist=sin(vadlat(k))*slat+cos(vadlat(k))*clat* & - (sin(vadlon(k))*slon+cos(vadlon(k))*clon) - cdist=max(-one,min(cdist,one)) - dist=rad2deg*acos(cdist) - - if(dist < 0.2_r_kind) then - ivad=k - exit - end if - end do - numhits(ivad)=numhits(ivad)+1 - if(ivad==0) then - novadmatch=novadmatch+1 - go to 50 - end if - - vadlon_earth=vadlon(ivad) - vadlat_earth=vadlat(ivad) - if(regional)then - call tll2xy(vadlon_earth,vadlat_earth,dlonvad,dlatvad,outside) - if (outside) go to 50 - dlatmax=max(dlatvad,dlatmax) - dlonmax=max(dlonvad,dlonmax) - dlatmin=min(dlatvad,dlatmin) - dlonmin=min(dlonvad,dlonmin) - else - dlatvad = vadlat_earth - dlonvad = vadlon_earth - call grdcrd1(dlatvad,rlats,nlat,1) - call grdcrd1(dlonvad,rlons,nlon,1) - endif - -! Get model terrain at VAD wind location - call deter_zsfc_model(dlatvad,dlonvad,zsges) - - iyr = hdr(5) - imo = hdr(6) - idy = hdr(7) - ihr = hdr(8) - imn = hdr(9) - - idate5(1) = iyr - idate5(2) = imo - idate5(3) = idy - idate5(4) = ihr - idate5(5) = imn - ikx=0 - do i=1,nconvtype - if(trim(ioctype(i)) == trim(obstype))ikx = i - end do - if(ikx==0) go to 50 - call w3fs21(idate5,minobs) - t4dv=real(minobs-iwinbgn,r_kind)*r60inv - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) goto 50 - else - timeb = real(minobs-mincy,r_kind)*r60inv -! if (abs(timeb)>twind .or. abs(timeb) > ctwind(ikx)) then - if (abs(timeb)>half .or. abs(timeb) > ctwind(ikx)) then -! write(6,*)'READ_RADAR: time outside window ',timeb,' skip this obs' - goto 50 - endif - endif - -! Go through the data levels - call ufbint(lnbufr,radar_obs,7,maxlevs,levs,datstr(1)) - if(levs>maxlevs) then - write(6,*)'READ_RADAR: ***ERROR*** increase read_radar bufr size since ',& - 'number of levs=',levs,' > maxlevs=',maxlevs - call stop2(84) - endif - - numcut=0 - do k=1,levs - if(loop==1) nsuper2_5_in=nsuper2_5_in+1 - if(loop==2) nsuper3_in=nsuper3_in+1 - nread=nread+1 - t4dvo=real(minobs+radar_obs(1,k)-iwinbgn,r_kind)*r60inv - timemax=max(timemax,t4dvo) - timemin=min(timemin,t4dvo) - if(loop==2 .and. ivad> 0 .and. level2_5(ivad)/=0) then - level3_tossed_by_2_5(ivad)=level3_tossed_by_2_5(ivad)+1 - numcut=numcut+1 - cycle - end if - -! Exclude data if it does not fall within time window - if (l4dvar.or.l4densvar) then - if (t4dvowinlen) cycle - timeo=t4dv - else - timeo=(real(minobs-mincy,r_kind)+real(radar_obs(1,k),r_kind))*r60inv - if(abs(timeo)>twind .or. abs(timeo) > ctwind(ikx)) then -! write(6,*)'READ_RADAR: time outside window ',timeo,& -! ' skip obs ',nread,' at lev=',k - cycle - end if - end if - -! Get observation (lon,lat). Compute distance from radar. - if(radar_obs(3,k)>=r360) radar_obs(3,k)=radar_obs(3,k)-r360 - if(radar_obs(3,k)max_rrr) cycle - -! Set observation "type" to be function of distance from radar - kxadd=nint(dist*one_tenth) - kx=kx0+kxadd - -! Extract radial wind data - height= radar_obs(4,k) - rwnd = radar_obs(5,k) - azm_earth = r90-radar_obs(6,k) - if(regional) then - cosazm_earth=cos(azm_earth*deg2rad) - sinazm_earth=sin(azm_earth*deg2rad) - call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) - azm=atan2(sinazm,cosazm)*rad2deg - else - azm=azm_earth - end if - iaaa=azm/(r360/(r8*irrr)) - iaaa=mod(iaaa,8*irrr) - if(iaaa<0) iaaa=iaaa+8*irrr - iaaa=iaaa+1 - iaaamax=max(iaaamax,iaaa) - iaaamin=min(iaaamin,iaaa) - - error = erradar_inflate*radar_obs(7,k) - -! Increase error for lev2.5 and lev3 - if (wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional.or.wrf_mass_regional) then - if(dlon_earth*rad2deg>230.0_r_kind .and. & - dlat_earth*rad2deg <54.0_r_kind)then - error = error+r10 - end if - end if - errmax=max(error,errmax) - if(radar_obs(7,k)>zero) errmin=min(error,errmin) - -! Perform limited qc based on azimuth angle, radial wind -! speed, distance from radar site, elevation of radar, -! height of observation, observation error. - - good0=.true. - if(abs(azm)>r400) then - ibadazm=ibadazm+1; good0=.false. - end if - if(abs(rwnd)>r200) then - ibadwnd=ibadwnd+1; good0=.false. - end if - if(dist>r400) then - ibaddist=ibaddist+1; good0=.false. - end if - if(staheight<-r1000 .or. staheight>r50000) then - ibadstaheight=ibadstaheight+1; good0=.false. - end if - if(height<-r1000 .or. height>r50000) then - ibadheight=ibadheight+1; good0=.false. - end if - if(heightr6 .or. radar_obs(7,k)<=zero) then - ibaderror=ibaderror+1; good0=.false. - end if - good=.true. - if(.not.good0) then - notgood0=notgood0+1 - cycle - else - -! Check against vad wind quality mark - ivadz=nint(height/dzvad) - if(ivadz>maxvadbins.or.ivadz<1) then - ioutofvadrange=ioutofvadrange+1 - cycle - end if - thiserr = radar_obs(7,k) - thiswgt=one/max(r4_r_kind,thiserr**2) - thisfit2=(vadu(ivad,ivadz)*cos(azm_earth*deg2rad)+vadv(ivad,ivadz)*sin(azm_earth*deg2rad)-rwnd)**2 - thisfit=sqrt(thisfit2) - thisvadspd=sqrt(vadu(ivad,ivadz)**2+vadv(ivad,ivadz)**2) - if(loop==1) then - vadfit2_5(ivad,ivadz)=vadfit2_5(ivad,ivadz)+thiswgt*thisfit2 - vadcount2_5(ivad,ivadz)=vadcount2_5(ivad,ivadz)+one - vadwgt2_5(ivad,ivadz)=vadwgt2_5(ivad,ivadz)+thiswgt - else - vadfit3(ivad,ivadz)=vadfit3(ivad,ivadz)+thiswgt*thisfit2 - vadcount3(ivad,ivadz)=vadcount3(ivad,ivadz)+one - vadwgt3(ivad,ivadz)=vadwgt3(ivad,ivadz)+thiswgt - end if - if(thisfit/max(one,thisvadspd)>vad_leash) then - ibadfit=ibadfit+1; good=.false. - end if - if(nobs_box(irrr,iaaa,ivadz,ivad)>nboxmax) then - kthin=kthin+1 - good=.false. - end if - if(vadqm(ivad,ivadz)>r3_5 .or. vadqm(ivad,ivadz)<-one) then - ibadvad=ibadvad+1 ; good=.false. - end if - end if - -! If data is good, load into output array - if(good) then - if(loop==1.and.ivad>0) then - nsuper2_5_kept=nsuper2_5_kept+1 - level2_5(ivad)=level2_5(ivad)+1 - end if - if(loop==2.and.ivad>0) then - nsuper3_kept=nsuper3_kept+1 - level3(ivad)=level3(ivad)+1 - end if - nobs_box(irrr,iaaa,ivadz,ivad)=nobs_box(irrr,iaaa,ivadz,ivad)+1 - ndata = min(ndata+1,maxobs) - nodata = min(nodata+1,maxobs) !number of obs not used (no meaning here) - usage = zero - if(icuse(ikx) < 0)usage=r100 - if(ncnumgrp(ikx) > 0 )then ! cross validation on - if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) - end if - - call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) - - cdata(1) = error ! wind obs error (m/s) - cdata(2) = dlon ! grid relative longitude - cdata(3) = dlat ! grid relative latitude - cdata(4) = height ! obs absolute height (m) - cdata(5) = rwnd ! wind obs (m/s) - cdata(6) = azm*deg2rad ! azimuth angle (radians) - cdata(7) = t4dvo ! obs time (hour) - cdata(8) = ikx ! type - cdata(9) = tiltangle ! tilt angle (radians) - cdata(10)= staheight ! station elevation (m) - cdata(11)= rstation_id ! station id - cdata(12)= usage ! usage parameter - cdata(13)= idomsfc ! dominate surface type - cdata(14)= skint ! skin temperature - cdata(15)= ff10 ! 10 meter wind factor - cdata(16)= sfcr ! surface roughness - cdata(17)=dlon_earth_deg ! earth relative longitude (degrees) - cdata(18)=dlat_earth_deg ! earth relative latitude (degrees) - cdata(19)=dist ! range from radar in km (used to estimate beam spread) - cdata(20)=zsges ! model elevation at radar site - cdata(21)=radar_obs(7,k) ! original error from bufr file - if(loop==1) then - cdata(22)=2.5_r_kind - else - cdata(22)=three - end if - - do i=1,maxdat - cdata_all(i,ndata)=cdata(i) - end do - - else - notgood = notgood + 1 - end if - -! End of k loop over levs - end do - -! End of bufr read loop - go to 50 - -! Normal exit - 1000 continue - call closbf(lnbufr) - - -! Close unit to bufr file - write(6,*)'READ_RADAR: ',trim(outmessage),' reached eof on 2.5/3 superob radar file.' - - if(loop==1) write(6,*)'READ_RADAR: nsuper2_5_in,nsuper2_5_kept=',nsuper2_5_in,nsuper2_5_kept - if(loop==2) write(6,*)'READ_RADAR: nsuper3_in,nsuper3_kept=',nsuper3_in,nsuper3_kept - write(6,*)'READ_RADAR: # no vad match =',novadmatch - write(6,*)'READ_RADAR: # out of vadrange=',ioutofvadrange - write(6,*)'READ_RADAR: # bad azimuths=',ibadazm - write(6,*)'READ_RADAR: # bad winds =',ibadwnd - write(6,*)'READ_RADAR: # bad dists =',ibaddist - write(6,*)'READ_RADAR: # bad stahgts =',ibadstaheight - write(6,*)'READ_RADAR: # bad obshgts =',ibadheight - write(6,*)'READ_RADAR: # bad errors =',ibaderror - write(6,*)'READ_RADAR: # bad vadwnd =',ibadvad - write(6,*)'READ_RADAR: # bad fit =',ibadfit - write(6,*)'READ_RADAR: # num thinned =',kthin - write(6,*)'READ_RADAR: # notgood0 =',notgood0 - write(6,*)'READ_RADAR: # notgood =',notgood - write(6,*)'READ_RADAR: # hgt belowsta=',iheightbelowsta - write(6,*)'READ_RADAR: timemin,max =',timemin,timemax - write(6,*)'READ_RADAR: errmin,max =',errmin,errmax - write(6,*)'READ_RADAR: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax - write(6,*)'READ_RADAR: iaaamin,max,8*max_rrr =',iaaamin,iaaamax,8*max_rrr - - end do ! end bigger loop over first level 2.5, then level 3 radar data - END IF LEVEL_THREE_READ - -! Write out vad statistics - do ivad=1,nvad - if(print_verbose)write(6,'(" fit of 2, 2.5, 3 data to vad station, lat, lon = ",a8,2f14.2)') & - vadid(ivad),vadlat(ivad)*rad2deg,vadlon(ivad)*rad2deg - do ivadz=1,maxvadbins - if(vadcount2(ivad,ivadz) > half .and. vadcount2_5(ivad,ivadz) > half & - .and. vadcount(ivad,ivadz) > half)then - if(vadcount2(ivad,ivadz)>half) then - vadfit2(ivad,ivadz)=sqrt(vadfit2(ivad,ivadz)/vadwgt2(ivad,ivadz)) - else - vadfit2(ivad,ivadz)=zero - end if - if(vadcount2_5(ivad,ivadz)>half) then - vadfit2_5(ivad,ivadz)=sqrt(vadfit2_5(ivad,ivadz)/vadwgt2_5(ivad,ivadz)) - else - vadfit2_5(ivad,ivadz)=zero - end if - if(vadcount3(ivad,ivadz)>half) then - vadfit3(ivad,ivadz)=sqrt(vadfit3(ivad,ivadz)/vadwgt3(ivad,ivadz)) - else - vadfit3(ivad,ivadz)=zero - end if - if(print_verbose)write(6,'(" h,f2,f2.5,f3=",i7,f10.2,"/",i5,f10.2,"/",i5,f10.2,"/",i5)')nint(ivadz*dzvad),& - vadfit2(ivad,ivadz),nint(vadcount2(ivad,ivadz)),& - vadfit2_5(ivad,ivadz),nint(vadcount2_5(ivad,ivadz)),& - vadfit3(ivad,ivadz),nint(vadcount3(ivad,ivadz)) - end if - end do - end do - - deallocate(nobs_box) - -65 continue - - - - erad = rearth - thiserr=5.0_r_kind - - timemax=-huge(timemax) - timemin=huge(timemin) - errmax=-huge(errmax) - errmin=huge(errmin) - elevmax=-huge(elevmax) - elevmin=huge(elevmin) - - loop=3 - - nirrr=0 - noutside=0 - ntimeout=0 - nsubzero=0 - ibadazm=0 - ibadwnd=0 - ibaddist=0 - ibadtilt=0 - ibadrange=0 - ibadheight=0 - ibadstaheight=0 - notgood=0 - notgood0=0 - nread=0 - ntdrvr_in=0 - ntdrvr_kept=0 - ntdrvr_thin1=0 - ntdrvr_thin2=0 - ntdrvr_thin2_foreswp=0 - ntdrvr_thin2_aftswp=0 - maxout=0 - maxdata=0 - nmissing=0 - subset_check(3)='NC006070' - icntpnt=0 - nswp=0 - nforeswp=0 - naftswp=0 - nfore=0 - naft=0 - - xscale=100._r_kind - xscalei=one/xscale - max_rrr=nint(100000.0_r_kind*xscalei) - jjj=0 - iimax=0 - - if(loop == 3) outmessage='tail Doppler radar obs:' - - use_all = .true. - do i=1,nconvtype - if(trim(ioctype(i)) == trim(obstype) .and. ictype(i) < 999 .and. icuse(i) > 0)then - ithin=ithin_conv(i) - if(ithin > 0)then - rmesh=rmesh_conv(i) - pmesh=pmesh_conv(i) - use_all = .false. - if(pmesh > zero) then ! Here pmesh is height in meters - zflag=1 - nlevz=r16000/pmesh - else - zflag=0 - nlevz=nsig - endif - xmesh=rmesh - call make3grids(xmesh,nlevz) - allocate(zl_thin(nlevz)) - if (zflag==1) then - do k=1,nlevz - zl_thin(k)=(k-1)*pmesh - enddo - endif - write(6,*)'READ_RADAR: obstype,ictype,rmesh,zflag,nlevz,pmesh=',& - trim(ioctype(i)),ictype(i),rmesh,zflag,nlevz,pmesh - exit - end if - end if - end do - - if(trim(infile) == 'tldplrso') goto 75 - - nswptype=0 - nmrecs=0 - irec=0 - if(l_foreaft_thin)then -! read the first 500 records to deterine which criterion -! should be used to seperate fore/aft sweep - open(lnbufr,file=trim(infile),form='unformatted') - call openbf(lnbufr,'IN',lnbufr) - call datelen(10) - call readmg(lnbufr,subset,idate,iret) - if(iret/=0) then - write(6,*)'READ_RADAR: problem reading tail Doppler radar bufr file tldplrbufr' - call closbf(lnbufr) - go to 1100 - end if - -! Big loop over bufr file - -700 call readsb(lnbufr,iret) -800 continue - if(iret/=0) then - call readmg(lnbufr,subset,idate,iret) - if(iret/=0) go to 85 - go to 700 - end if - if(subset/=subset_check(loop)) then - iret=99 - go to 800 - end if - nmrecs = nmrecs+1 - -! Read header. Extract elevation angle - call ufbint(lnbufr,hdr,12,1,levs,hdrstr(2)) - thistilt=hdr(12) - - if(nmrecs == 1)then - tdrele1 = hdr(12) - tdrele2 = hdr(12) - end if - - tdrele1 = tdrele2 - tdrele2 = hdr(12) - if(abs(tdrele2-tdrele1)>r100) then - print *,'tdrele2,tdrele1=',tdrele2,tdrele1 - nswptype=1 - go to 85 - end if - - if(nmrecs <= 500)then - go to 700 - else - go to 85 - end if - -85 continue - call closbf(lnbufr) - close(lnbufr) - end if - - print *,'nmrecs, nswptype=', nmrecs, nswptype - -! Open, then read bufr data - open(lnbufr,file=trim(infile),form='unformatted') - call openbf(lnbufr,'IN',lnbufr) - call datelen(10) - call readmg(lnbufr,subset,idate,iret) - if(iret/=0) then - write(6,*)'READ_RADAR: problem reading tail Doppler radar bufr file tldplrbufr' - call closbf(lnbufr) - go to 1100 - end if - -! Time offset - call time_4dvar(idate,toff) - - write(date,'( i10)') idate - read (date,'(i4,3i2)') iy,im,idd,ihh - write(6,*)'READ_RADAR: bufr file date is ',iy,im,idd,ihh - - idate5(1) = iy ! year - idate5(2) = im ! month - idate5(3) = idd ! day - idate5(4) = ihh ! hour - idate5(5) = 0 ! minute - call w3fs21(idate5,mincy) - - nmrecs=0 -! Big loop over bufr file - - if(l_foreaft_thin) then - firstbeam = 0 - foreswp = .true. - aftswp = .false. - nforeswp=1 - naftswp=0 - nswp=1 - else - foreswp = .false. - aftswp = .false. - endif - -70 call readsb(lnbufr,iret) -80 continue - if(iret/=0) then - call readmg(lnbufr,subset,idate,iret) - if(iret/=0) go to 1100 - go to 70 - end if - if(subset/=subset_check(loop)) then - iret=99 - go to 80 - end if - nmrecs = nmrecs+1 - irec = irec+1 - -! Read header. Extract station infomration - call ufbint(lnbufr,hdr,12,1,levs,hdrstr(2)) - -! rstation_id=hdr(1) - if(hdr(1) == zero)then - cstaid='NOAA ' - else if(hdr(1) == one)then - cstaid='FRENCH ' - else if(hdr(1)== two)then - cstaid='G-IV ' - else if(hdr(1)== three)then - cstaid='AOC ' - else - cstaid='UNKNOWN ' - endif - - kx=990+nint(hdr(1)) - - if(nmrecs==1)print *,'Antenna ID:', hdr(1),cstaid - - iyr = hdr(2) - imo = hdr(3) - idy = hdr(4) - ihr = hdr(5) - imn = hdr(6) - isc = hdr(7) - - idate5(1) = iyr - idate5(2) = imo - idate5(3) = idy - idate5(4) = ihr - idate5(5) = imn - ikx=0 - do i=1,nconvtype - if(trim(ioctype(i)) == trim(obstype) .and. kx == ictype(i))ikx = i - end do - if(ikx == 0) go to 70 - call w3fs21(idate5,minobs) - - t4dv=real(minobs-iwinbgn,r_kind)*r60inv - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) then - ntimeout=ntimeout+1 - goto 70 - end if - timeo=t4dv - else - timeo = real(minobs-mincy,r_kind)*r60inv - if (abs(timeo) > twind .or. abs(timeo) > ctwind(ikx)) then - ntimeout=ntimeout+1 - goto 70 - end if - endif - - timemax=max(timemax,timeo) - timemin=min(timemin,timeo) - - this_stalat=hdr(8) - this_stalon=hdr(9) - - rlon0=deg2rad*this_stalon - this_stalatr=this_stalat*deg2rad - clat0=cos(this_stalatr) ; slat0=sin(this_stalatr) - this_stahgt=hdr(10) - thisazimuth=hdr(11) - thistilt=hdr(12) - elevmax=max(elevmax,thistilt) - elevmin=min(elevmin,thistilt) - -! define fore/aft sweeps for thinning (pseduo dual Doppler) - - if(l_foreaft_thin)then - if (firstbeam == 0) then - tdrele1 = hdr(12) - tdrele2 = hdr(12) - if(nswptype == 0)then - tdrele3 = hdr(12) - end if - firstbeam = 1 - endif - - if(nswptype == 0)then - tdrele1 = tdrele2 - tdrele2 = tdrele3 - tdrele3 = hdr(12) - - if(firstbeam > 0 .and. tdrele2>=tdrele1 .and. tdrele2>=tdrele3 .and. tdrele2 > r60 & - .and. irec > r150)then - if(foreswp) then - foreswp = .false. - aftswp = .true. - naftswp = naftswp+1 - irec=0 - else - aftswp = .false. - foreswp = .true. - nforeswp = nforeswp+1 - irec=0 - endif - - nswp = nswp+1 - endif - - else if(nswptype == 1)then - tdrele1 = tdrele2 - tdrele2 = hdr(12) - - if(abs(tdrele2-tdrele1)>r100) then - if(foreswp) then - foreswp = .false. - aftswp = .true. - naftswp = naftswp+1 - irec=0 - else - aftswp = .false. - foreswp = .true. - nforeswp = nforeswp+1 - irec=0 - endif - - nswp = nswp+1 - endif - else - foreswp = .false. - aftswp = .false. - end if - else - foreswp = .false. - aftswp = .false. - endif - - if(abs(thistilt)>r75)then - ibadtilt=ibadtilt+1; goto 70 - endif - - staheight=this_stahgt - if(staheight<-r1000.or.staheight>r50000) then - ibadstaheight=ibadstaheight+1; goto 70 - end if - -! Go through the data levels - call ufbint(lnbufr,tdr_obs,4,maxlevs,levs,datstr(2)) - if(levs>maxlevs) then - write(6,*)'READ_RADAR: ***ERROR*** increase read_radar bufr size since ',& - 'number of levs=',levs,' > maxlevs=',maxlevs - call stop2(84) - endif -! use local coordinate centered on this_stalat,this_stalon. note that global and local -! azimuth angle are the same at the origin (this_stalat,this_stalon) -! and azimuth angle is fixed in local coordinate along entire radial line. -! we convert back to global azimuth angle at each point along line -! at end of computation. that way we avoid worrying about where poles are. - - aactual=erad+this_stahgt - thistiltr=thistilt*deg2rad - selev0=sin(thistiltr) ; celev0=cos(thistiltr) - a43=four_thirds*aactual - ii=0 - do k=1,levs - nread=nread+1 -! Select data every 3 km along each beam - if(MOD(INT(tdr_obs(1,k)-tdr_obs(1,1)),3000) < 100)then - if(tdr_obs(3,k) >= 800.) nmissing=nmissing+1 !xx - if(tdr_obs(3,k) < 800.) then - ii=ii+1 - dopbin(ii)=tdr_obs(3,k) - thisrange=tdr_obs(1,k) - - call getvrlocalinfo(thisrange,thisazimuth,this_stahgt,aactual,a43,selev0,celev0, & - rlon0,clat0,slat0,r8,r89_5,nsubzero,ii,z(ii),elev(ii),elat8(ii), & - elon8(ii),glob_azimuth8(ii)) - end if - else - ntdrvr_thin1=ntdrvr_thin1+1 - endif - end do - -! Further process tail Doppler radar Vr data - iimax=max(iimax,ii) - - if( ii > 0 )then - dlat_earth=this_stalat !station lat (degrees) - dlon_earth=this_stalon !station lon (degrees) - if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 - if (dlon_earth=r360) dlon_earth=dlon_earth-r360 - if(dlon_earthmax_rrr)then - nirrr=nirrr+1 - cycle - endif - -! Extract radial wind data - height= z(i) - rwnd = dopbin(i) - azm_earth = glob_azimuth8(i) - if(regional) then - cosazm_earth=cos(azm_earth*deg2rad) - sinazm_earth=sin(azm_earth*deg2rad) - call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) - azm=atan2(sinazm,cosazm)*rad2deg - else - azm=azm_earth - end if - iaaa=azm/(r360/(r8*irrr)) - iaaa=mod(iaaa,8*irrr) - if(iaaa<0) iaaa=iaaa+8*irrr - iaaa=iaaa+1 - iaaamax=max(iaaamax,iaaa) - iaaamin=min(iaaamin,iaaa) - error = erradar_inflate*thiserr - errmax=max(error,errmax) - if(thiserr>zero) errmin=min(error,errmin) - -! Perform limited qc based on azimuth angle, elevation angle, radial wind -! speed, range, distance from radar site - - good0=.true. - if(abs(azm)>r400) then - ibadazm=ibadazm+1; good0=.false. - end if - if(abs(rwnd) > r71 .or. abs(rwnd) < r2 ) then - ibadwnd=ibadwnd+1; good0=.false. - end if - if(thisrange>r92) then - ibadrange=ibadrange+1; good0=.false. - end if - if(dist>r400) then - ibaddist=ibaddist+1; good0=.false. - end if - if(height<-r1000.or.height>r50000) then - ibadheight=ibadheight+1; good0=.false. - end if - good=.true. - if(.not.good0) then - notgood0=notgood0+1 - cycle - end if -! if data is good, load into output array - - if(good) then - ntdrvr_kept=ntdrvr_kept+1 -!#################### Data thinning ################### - - icntpnt=icntpnt+1 - - if(ithin > 0)then - if(zflag == 0)then - klon1= int(dlon); klat1= int(dlat) - dx = dlon-klon1; dy = dlat-klat1 - dx1 = one-dx; dy1 = one-dy - w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy - - klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) - if (klon1==0) klon1=nlon - klatp1=min(nlat,klat1+1); klonp1=klon1+1 - if (klonp1==nlon+1) klonp1=1 - do kk=1,nsig - hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + & - w10*hgtl_full(klatp1,klon1 ,kk) + & - w01*hgtl_full(klat1 ,klonp1,kk) + & - w11*hgtl_full(klatp1,klonp1,kk) - end do - sin2 = sin(dlat_earth)*sin(dlat_earth) - termg = grav_equator * & - ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) - termr = semi_major_axis /(one + flattening + grav_ratio - & - two*flattening*sin2) - termrg = (termg/grav)*termr - do k=1,nsig - zges(k) = (termr*hges(k)) / (termrg-hges(k)) - zl_thin(k)=zges(k) - end do - endif - - zobs = height - - ntmp=ndata ! counting moved to map3gridS - if (thin4d) then - timedif = zero - else - timedif=abs(t4dv-toff) - endif - crit1 = timedif/r6+half - - call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,& - zobs,crit1,ndata,iout,icntpnt,iiout,luse,foreswp,aftswp) - maxout=max(maxout,iout) - maxdata=max(maxdata,ndata) - - if (.not. luse) then - if (foreswp) then - ntdrvr_thin2_foreswp=ntdrvr_thin2_foreswp+1 - else if (aftswp) then - ntdrvr_thin2_aftswp=ntdrvr_thin2_aftswp+1 - end if - ntdrvr_thin2=ntdrvr_thin2+1 - cycle - endif - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - endif - isort(icntpnt)=iout - - else - ndata =ndata+1 - nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout - endif - - if(ndata > maxobs) then - write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype - ndata = maxobs - end if - -! Set usage variable - usage = zero - - if(icuse(ikx) < 0)usage=r100 - if(ncnumgrp(ikx) > 0 )then ! cross validation on - if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) - end if - - call deter_zsfc_model(dlat,dlon,zsges) - -! Get information from surface file necessary for conventional data here - call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) - - - cdata(1) = error ! wind obs error (m/s) - cdata(2) = dlon ! grid relative longitude - cdata(3) = dlat ! grid relative latitude - cdata(4) = height ! obs absolute height (m) - cdata(5) = rwnd ! wind obs (m/s) - cdata(6) = azm*deg2rad ! azimuth angle (radians) - cdata(7) = t4dv ! obs time (hour) - cdata(8) = ikx ! type - cdata(9) = tiltangle ! tilt angle (radians) - cdata(10)= staheight ! station elevation (m) - cdata(11)= rstation_id ! station id - cdata(12)= usage ! usage parameter - cdata(13)= idomsfc ! dominate surface type - cdata(14)= skint ! skin temperature - cdata(15)= ff10 ! 10 meter wind factor - cdata(16)= sfcr ! surface roughness - cdata(17)=dlon_earth_deg ! earth relative longitude (degrees) - cdata(18)=dlat_earth_deg ! earth relative latitude (degrees) - cdata(19)=dist ! range from radar in km (used to estimate beam spread) - cdata(20)=zsges ! model elevation at radar site - cdata(21)=thiserr - cdata(22)=hdr(1)+three+one ! tail Doppler radar - do j=1,maxdat - cdata_all(j,iout)=cdata(j) - end do - if(foreswp)nfore=nfore+1 - if(aftswp)naft=naft+1 - jjj=jjj+1 - else - notgood = notgood + 1 - end if ! if(good) - - end do - - endif ! if(ii .gt. 0) - -! End of bufr read loop - -69 continue - - go to 70 - -! Normal exit -1100 continue - call closbf(lnbufr) - - -! Close unit to bufr file - close(lnbufr) - - go to 1200 - -75 continue - -! Loop to read TDR superobs data - - ikx=0 - do i=1,nconvtype - if(trim(ioctype(i)) == trim(obstype))ikx = i - end do - if(ikx == 0) go to 900 - - call w3fs21(iadate,mincy) ! analysis time in minutes - - open(lnbufr,file=trim(infile),form='formatted',err=300) - rewind (lnbufr) - do n=1,10 - istop=0 - read(lnbufr,'(a)',err=200,end=1200)filename - print *,'filename=', trim(filename) - open(25,file=trim(filename),form='formatted',access='sequential') - do while (istop.eq.0) - ii=1 - READ(25,'(I4,4I2,8F10.3)',iostat=istop) iyr,imo,idy,ihr,imn,this_stalat, & - this_stalon,this_stahgt,azm0,elev0,range0,thisvr,rotang - - nread=nread+1 - - idate5(1) = iyr - idate5(2) = imo - idate5(3) = idy - idate5(4) = ihr - idate5(5) = imn - call w3fs21(idate5,minobs) - - t4dv=real(minobs-iwinbgn,r_kind)*r60inv - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) goto 90 - timeo=t4dv - else - timeo = real(minobs-mincy,r_kind)*r60inv - if (abs(timeo)>twind) goto 90 - endif - - timemax=max(timemax,timeo) - timemin=min(timemin,timeo) - - rlon0=deg2rad*this_stalon - this_stalatr=this_stalat*deg2rad - clat0=cos(this_stalatr) ; slat0=sin(this_stalatr) - thistilt=elev0 - elevmax=max(elevmax,thistilt) - elevmin=min(elevmin,thistilt) - thisazimuth=azm0 - thisrange=range0*r1000 - if(abs(thistilt)>r75)then - ibadtilt=ibadtilt+1; goto 90 - endif - - staheight=this_stahgt - if(staheight<-r1000.or.staheight>r50000) then - ibadstaheight=ibadstaheight+1; goto 90 - end if - - aactual=erad+this_stahgt - thistiltr=thistilt*deg2rad - selev0=sin(thistiltr) ; celev0=cos(thistiltr) - a43=four_thirds*aactual - - - call getvrlocalinfo(thisrange,thisazimuth,this_stahgt,aactual,a43,selev0,celev0, & - rlon0,clat0,slat0,r8,r89_5,nsubzero,ii,z(ii),elev(ii),elat8(ii), & - elon8(ii),glob_azimuth8(ii)) - - - dlat_earth=this_stalat !station lat (degrees) - dlon_earth=this_stalon !station lon (degrees) - if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 - if (dlon_earth=r360) dlon_earth=dlon_earth-r360 - if(dlon_earthmax_rrr)then - nirrr=nirrr+1 - cycle - endif - -! Extract radial wind data - height= z(ii) - rwnd = thisvr - azm_earth = glob_azimuth8(ii) - if(regional) then - cosazm_earth=cos(azm_earth*deg2rad) - sinazm_earth=sin(azm_earth*deg2rad) - call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) - azm=atan2(sinazm,cosazm)*rad2deg - else - azm=azm_earth - end if - iaaa=azm/(r360/(r8*irrr)) - iaaa=mod(iaaa,8*irrr) - if(iaaa<0) iaaa=iaaa+8*irrr - iaaa=iaaa+1 - iaaamax=max(iaaamax,iaaa) - iaaamin=min(iaaamin,iaaa) - error = erradar_inflate*thiserr - errmax=max(error,errmax) - if(thiserr>zero) errmin=min(error,errmin) - -! Perform limited qc based on azimuth angle, elevation angle, radial wind -! speed, range, distance from radar site - - good0=.true. - if(abs(azm)>r400) then - ibadazm=ibadazm+1; good0=.false. - end if - if(abs(rwnd) > r71) then - ibadwnd=ibadwnd+1; good0=.false. - end if - if(thisrange>r92) then - ibadrange=ibadrange+1; good0=.false. - end if - if(dist>r400) then - ibaddist=ibaddist+1; good0=.false. - end if - if(height<-r1000.or.height>r50000) then - ibadheight=ibadheight+1; good0=.false. - end if - good=.true. - if(.not.good0) then - notgood0=notgood0+1 - cycle - end if -! if data is good, load into output array - - if(good) then - ntdrvr_kept=ntdrvr_kept+1 -!#################### Data thinning ################### - - icntpnt=icntpnt+1 - - if(ithin > 0)then - if(zflag == 0)then - klon1= int(dlon); klat1= int(dlat) - dx = dlon-klon1; dy = dlat-klat1 - dx1 = one-dx; dy1 = one-dy - w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy - - klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon) - if (klon1==0) klon1=nlon - klatp1=min(nlat,klat1+1); klonp1=klon1+1 - if (klonp1==nlon+1) klonp1=1 - do kk=1,nsig - hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + & - w10*hgtl_full(klatp1,klon1 ,kk) + & - w01*hgtl_full(klat1 ,klonp1,kk) + & - w11*hgtl_full(klatp1,klonp1,kk) - end do - sin2 = sin(dlat_earth)*sin(dlat_earth) - termg = grav_equator * & - ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) - termr = semi_major_axis /(one + flattening + grav_ratio - & - two*flattening*sin2) - termrg = (termg/grav)*termr - do k=1,nsig - zges(k) = (termr*hges(k)) / (termrg-hges(k)) - zl_thin(k)=zges(k) - end do - endif - - zobs = height - - ntmp=ndata ! counting moved to map3gridS - if (thin4d) then - timedif = zero - else - timedif=abs(t4dv-toff) - endif - crit1 = timedif/r6+half - - call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,& - zobs,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.) - maxout=max(maxout,iout) - maxdata=max(maxdata,ndata) - - if (.not. luse) then - ntdrvr_thin2=ntdrvr_thin2+1 - cycle - endif - if(iiout > 0) isort(iiout)=0 - if (ndata > ntmp) then - nodata=nodata+1 - endif - isort(icntpnt)=iout - - else - ndata =ndata+1 - nodata=nodata+1 - iout=ndata - isort(icntpnt)=iout - endif - - if(ndata > maxobs) then - write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype - ndata = maxobs - end if - -! Set usage variable - usage = zero - - if(icuse(ikx) < 0)usage=r100 - if(ncnumgrp(ikx) > 0 )then ! cross validation on - if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) - end if - - call deter_zsfc_model(dlat,dlon,zsges) - -! Get information from surface file necessary for conventional data here - call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) - - - cdata(1) = error ! wind obs error (m/s) - cdata(2) = dlon ! grid relative longitude - cdata(3) = dlat ! grid relative latitude - cdata(4) = height ! obs absolute height (m) - cdata(5) = rwnd ! wind obs (m/s) - cdata(6) = azm*deg2rad ! azimuth angle (radians) - cdata(7) = t4dv ! obs time (hour) - cdata(8) = ikx ! type - cdata(9) = tiltangle ! tilt angle (radians) - cdata(10)= staheight ! station elevation (m) - cdata(11)= rstation_id ! station id - cdata(12)= usage ! usage parameter - cdata(13)= idomsfc ! dominate surface type - cdata(14)= skint ! skin temperature - cdata(15)= ff10 ! 10 meter wind factor - cdata(16)= sfcr ! surface roughness - cdata(17)=dlon_earth_deg ! earth relative longitude (degrees) - cdata(18)=dlat_earth_deg ! earth relative latitude (degrees) - cdata(19)=dist ! range from radar in km (used to estimate beam spread) - cdata(20)=zsges ! model elevation at radar site - cdata(21)=thiserr - cdata(22)=three+two ! tail Doppler radar - do j=1,maxdat - cdata_all(j,iout)=cdata(j) - end do - jjj=jjj+1 - else - notgood = notgood + 1 - end if ! if(good) - -90 continue - end do ! end of loop, reading records of data - close(25) - - end do ! end of loop, reading TDR so data files - -1200 continue - close(lnbufr) - - if (.not. use_all) then - deallocate(zl_thin) - call del3grids - endif - - write(6,*)'READ_RADAR: # records(beams) read in nmrecs=', nmrecs - write(6,*)'READ_RADAR: # records out of time window =', ntimeout - write(6,*)'READ_RADAR: # records with bad tilt=',ibadtilt - write(6,*)'READ_RADAR: # records with bad station height =',ibadstaheight - write(6,*)'READ_RADAR: # data read in nread=', nread - write(6,*)'READ_RADAR: # data with missing value nmissing=', nmissing - write(6,*)'READ_RADAR: # data likely to be below sealevel nsubzero=', nsubzero - write(6,*)'READ_RADAR: # data removed by thinning along the beam ntdrvr_thin1=', ntdrvr_thin1 - write(6,*)'READ_RADAR: # data retained after thinning along the beam ntdrvr_in=', ntdrvr_in - write(6,*)'READ_RADAR: # out of domain =', noutside - write(6,*)'READ_RADAR: # out of range =', nirrr - write(6,*)'READ_RADAR: # bad azimuths =',ibadazm - write(6,*)'READ_RADAR: # bad winds (<2m/s or >71m/s) =',ibadwnd - write(6,*)'READ_RADAR: # bad ranges =',ibadrange - write(6,*)'READ_RADAR: # bad distance from radar =',ibaddist - write(6,*)'READ_RADAR: # bad obs height =',ibadheight - write(6,*)'READ_RADAR: # bad data =',notgood0 - write(6,*)'READ_RADAR: # data retained after QC ntdrvr_kept=', ntdrvr_kept - write(6,*)'READ_RADAR: # data removed by thinning mesh ntdrvr_thin2=', ntdrvr_thin2 - if(l_foreaft_thin)then - write(6,*)'READ_RADAR: nforeswp,naftswp,nswp=',nforeswp,naftswp,nswp - write(6,*)'READ_RADAR: ntdrvr_thin2_foreswp,ntdrvr_thin2_aftswp=',ntdrvr_thin2_foreswp,ntdrvr_thin2_aftswp - write(6,*)'READ_RADAR: data retained for further processing nfore,naft=',nfore,naft - end if - write(6,*)'READ_RADAR: data retained for further processing =', jjj - write(6,*)'READ_RADAR: timemin,max =',timemin,timemax - write(6,*)'READ_RADAR: elevmin,max =',elevmin,elevmax - write(6,*)'READ_RADAR: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax - write(6,*)'READ_RADAR: iaaamin,max,8*max_rrr =',iaaamin,iaaamax,8*max_rrr - write(6,*)'READ_RADAR: iimax =',iimax - -! Write observation to scratch file - call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) - write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) - deallocate(cdata_all) - -900 continue - - return - -300 write(6,*) 'read_radar open TDR SO file list failed ' - call stop2(555) -200 write(6,*) 'read_radar read TDR SO data failed ' - call stop2(555) -end subroutine read_radar - -subroutine getvrlocalinfo(thisrange,thisazimuth,this_stahgt,aactual,a43,selev0,celev0, & - rlon0,clat0,slat0,r8,r89_5,nsubzero,ii,z,elev,elat8,elon8, & - glob_azimuth8) -!$$$ subprogram documentation block -! . . . . -! subprogram: getvrlocalinfo following subroutine radar_bufr_read_all -! prgmmr: tong org: np23 date: 2013-03-28 -! -! abstract: This routine calcuate radial wind elevation, elevation angle, -! earth lat lon and and azimuth angle at observation location -! -! program history log: -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - - use kinds, only: r_kind,r_single,i_kind - use constants, only: one,half,two,deg2rad,rad2deg,zero_single,rearth - - implicit none - - real(r_single) ,intent(in ) :: thisrange,thisazimuth,a43,aactual,selev0,celev0 - real(r_kind) ,intent(in ) :: this_stahgt,rlon0,clat0,slat0,r8,r89_5 - integer(i_kind),intent(inout) :: nsubzero - integer(i_kind),intent(inout) :: ii - real(r_single) ,intent(out ) :: elev,z,elat8,elon8,glob_azimuth8 - -! local variables - real(r_single) b,c,epsh,h,ha,celev,selev,gamma - real(r_single) rad_per_meter - real(r_kind) thisazimuthr,rlonloc,rlatloc,rlonglob,rlatglob,thislat,thislon - real(r_kind) clat1,caz0,saz0,cdlon,sdlon,caz1,saz1 - - rad_per_meter= one/rearth - -! use 4/3rds rule to get elevation of radar beam -! (if local temperature available, then vertical position can be -! estimated with greater accuracy) - b=thisrange*(thisrange+two*aactual*selev0) - c=sqrt(aactual*aactual+b) - ha=b/(aactual+c) - epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) - h=ha-epsh - z=this_stahgt+h - if(z < zero_single)then ! don't use observation if it is likely to be below sealevel - nsubzero=nsubzero+1 - ii=ii-1 - else - -! Get elevation angle at obs location - celev=celev0 - selev=selev0 - if(thisrange>=one) then - celev=a43*celev0/(a43+h) - selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) - end if - elev=rad2deg*atan2(selev,celev) - gamma=half*thisrange*(celev0+celev) - -! Get earth lat lon at obs location - thisazimuthr=thisazimuth*deg2rad - rlonloc=rad_per_meter*gamma*cos(thisazimuthr) - rlatloc=rad_per_meter*gamma*sin(thisazimuthr) - call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) - thislat=rlatglob*rad2deg - thislon=rlonglob*rad2deg -! Keep away from poles - if(abs(thislat)>r89_5)then - ii=ii-1 - else - elat8=thislat - elon8=thislon -! Get corrected azimuth - clat1=cos(rlatglob) - caz0=cos(thisazimuthr) - saz0=sin(thisazimuthr) - cdlon=cos(rlonglob-rlon0) - sdlon=sin(rlonglob-rlon0) - caz1=clat0*caz0/clat1 - saz1=saz0*cdlon-caz0*sdlon*slat0 - glob_azimuth8=atan2(saz1,caz1)*rad2deg - end if - end if - - return -end subroutine getvrlocalinfo - -subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_radar_l2rw_novadqc read radar L2 radial winds no VAD QC -! prgmmr: yang org: np23 date: 1998-05-15 -! -! abstract: This routine reads radar radial wind files. -! -! When running the gsi in regional mode, the code only -! retains those observations that fall within the regional -! -! program history log: -! 2015-10-19 lippi - Modified from read_radar to only process level 2 radial -! wind obs. and skip vad wind checks. -! -! input argument list: -! lunout - unit to which to write data for further processing -! obstype - observation type to process -! -! output argument list: -! ndata - number of doppler lidar wind profiles retained for further -! processing -! nodata - number of doppler lidar wind observations retained for further -! processing -! sis - satellite/instrument/sensor indicator -! nobs - array of observations on each subdomain for each processor! - - - use kinds, only: r_kind,r_single,r_double,i_kind,i_byte - use constants, only: zero,half,one,two,deg2rad,rearth,rad2deg,r1000,r100,r400 - use qcmod, only: erradar_inflate - use oneobmod, only: oneobtest,learthrel_rw - use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d - use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,nsig - use convinfo, only: nconvtype,ncmiter,ncgroup,ncnumgrp,icuse,ioctype - use deter_sfc_mod, only: deter_sfc2 - use mpimod, only: npe - - implicit none - -! Declare passed variables - character(len=*),intent(in ) :: obstype!,infile - character(len=20),intent(in ) :: sis -! real(r_kind) ,intent(in ) :: twind - integer(i_kind) ,intent(in ) :: lunout - integer(i_kind) ,intent(inout) :: ndata,nodata!,nread - integer(i_kind),dimension(npe) ,intent(inout) :: nobs -! real(r_kind),dimension(nlat,nlon,nsig),intent(in):: hgtl_full - -! Declare local parameters - integer(i_kind),parameter:: maxlevs=1500 - integer(i_kind),parameter:: maxdat=22 - real(r_kind),parameter:: r4_r_kind = 4.0_r_kind - - - real(r_kind),parameter:: r6 = 6.0_r_kind - real(r_kind),parameter:: r8 = 8.0_r_kind - real(r_kind),parameter:: r90 = 90.0_r_kind - real(r_kind),parameter:: r200 = 200.0_r_kind - real(r_kind),parameter:: r150 = 150.0_r_kind - real(r_kind),parameter:: r360 = 360.0_r_kind - real(r_kind),parameter:: r50000 = 50000.0_r_kind - real(r_kind),parameter:: r89_5 = 89.5_r_kind - real(r_kind),parameter:: four_thirds = 4.0_r_kind / 3.0_r_kind - -! Declare local variables - logical good,outside,good0 - - character(30) outmessage - - integer(i_kind) lnbufr,i,k,maxobs - integer(i_kind) nmrecs,ibadazm,ibadwnd,ibaddist,ibadheight,kthin - integer(i_kind) ibadstaheight,ibaderror,notgood,iheightbelowsta,ibadfit - integer(i_kind) notgood0 - integer(i_kind) iret,kx0 - integer(i_kind) nreal,nchanl,ilat,ilon,ikx - integer(i_kind) idomsfc - real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff - real(r_kind) eradkm,dlat_earth,dlon_earth - real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat - real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist - real(r_kind) rwnd,azm,height,error - real(r_kind) azm_earth,cosazm_earth,sinazm_earth,cosazm,sinazm - real(r_kind):: zsges - - real(r_kind),dimension(maxdat):: cdata - real(r_kind),allocatable,dimension(:,:):: cdata_all - - real(r_double) rstation_id - character(8) cstaid - character(4) this_staid - equivalence (this_staid,cstaid) - equivalence (cstaid,rstation_id) - - - integer(i_kind) loop - real(r_kind) timemax,timemin,errmax,errmin - real(r_kind) dlatmax,dlonmax,dlatmin,dlonmin - real(r_kind) xscale,xscalei - integer(i_kind) max_rrr,nboxmax - integer(i_kind) irrr,iaaa,iaaamax,iaaamin - real(r_kind) this_stalat,this_stalon,this_stahgt,thistime,thislat,thislon - real(r_kind) thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt - integer(i_kind) nsuper2_in,nsuper2_kept - real(r_kind) errzmax - - integer(i_kind),allocatable,dimension(:):: isort - -! following variables are for fore/aft separation - integer(i_kind) irec - - data lnbufr/10/ - -!*********************************************************************************** - - eradkm=rearth*0.001_r_kind - maxobs=2e6 - nreal=maxdat - nchanl=0 - ilon=2 - ilat=3 - iaaamax=-huge(iaaamax) - iaaamin=huge(iaaamin) - dlatmax=-huge(dlatmax) - dlonmax=-huge(dlonmax) - dlatmin=huge(dlatmin) - dlonmin=huge(dlonmin) - - allocate(cdata_all(maxdat,maxobs),isort(maxobs)) - - isort = 0 - cdata_all=zero - -! Initialize variables - xscale=1000._r_kind - xscalei=one/xscale - max_rrr=nint(100000.0_r_kind*xscalei) - nboxmax=1 - - kx0=22500 - - nmrecs=0 - irec=0 - - errzmax=zero - - -! First process any level 2 superobs. -! Initialize variables. - ikx=0 - do i=1,nconvtype - if(trim(ioctype(i)) == trim(obstype))ikx = i - end do - - timemax=-huge(timemax) - timemin=huge(timemin) - errmax=-huge(errmax) - errmin=huge(errmin) - loop=0 - - ibadazm=0 - ibadwnd=0 - ibaddist=0 - ibadheight=0 - ibadstaheight=0 - iheightbelowsta=0 - iheightbelowsta=0 - ibaderror=0 - ibadfit=0 - kthin=0 - notgood=0 - notgood0=0 - nsuper2_in=0 - nsuper2_kept=0 - - if(loop==0) outmessage='level 2 superobs:' - -! Open sequential file containing superobs - open(lnbufr,file='radar_supobs_from_level2',form='unformatted') - rewind lnbufr - -! Loop to read superobs data file - do - read(lnbufr,iostat=iret)this_staid,this_stalat,this_stalon,this_stahgt, & - thistime,thislat,thislon,thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt - if(iret/=0) exit - nsuper2_in=nsuper2_in+1 - - dlat_earth=this_stalat !station lat (degrees) - dlon_earth=this_stalon !station lon (degrees) - if (dlon_earth>=r360) dlon_earth=dlon_earth-r360 - if (dlon_earthwinlen) cycle - else - timeo=thistime - if(abs(timeo)>half ) cycle - endif - -! Get observation (lon,lat). Compute distance from radar. - dlat_earth=thislat - dlon_earth=thislon - if(dlon_earth>=r360) dlon_earth=dlon_earth-r360 - if(dlon_earthmax_rrr) cycle - end if -! Extract radial wind data - height= thishgt - rwnd = thisvr - azm_earth = corrected_azimuth - - if(regional) then - if(oneobtest .and. learthrel_rw) then ! for non rotated winds!!! - cosazm=cos(azm_earth*deg2rad) - sinazm=sin(azm_earth*deg2rad) - azm=atan2(sinazm,cosazm)*rad2deg - else - cosazm_earth=cos(azm_earth*deg2rad) - sinazm_earth=sin(azm_earth*deg2rad) - call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,dlon_earth,dlon,dlat) - azm=atan2(sinazm,cosazm)*rad2deg - end if - - else - azm=azm_earth - end if - - if(.not. oneobtest) then - iaaa=azm/(r360/(r8*irrr)) - iaaa=mod(iaaa,8*irrr) - if(iaaa<0) iaaa=iaaa+8*irrr - iaaa=iaaa+1 - iaaamax=max(iaaamax,iaaa) - iaaamin=min(iaaamin,iaaa) - end if - - error = erradar_inflate*thiserr - errmax=max(error,errmax) - - if(thiserr>zero) errmin=min(error,errmin) -! Perform limited qc based on azimuth angle, radial wind -! speed, distance from radar site, elevation of radar, -! height of observation, and observation error - good0=.true. - if(abs(azm)>r400) then - ibadazm=ibadazm+1; good0=.false. - end if - if(abs(rwnd)>r200) then - ibadwnd=ibadwnd+1; good0=.false. - end if - if(dist>r400) then - ibaddist=ibaddist+1; good0=.false. - end if - if(staheight<-r1000.or.staheight>r50000) then - ibadstaheight=ibadstaheight+1; good0=.false. - end if - if(height<-r1000.or.height>r50000) then - ibadheight=ibadheight+1; good0=.false. - end if - if(heightr6 .or. thiserr<=zero) then - ibaderror=ibaderror+1; good0=.false. - end if - good=.true. - if(.not.good0) then - notgood0=notgood0+1 - cycle - else - - end if - -! If data is good, load into output array - if(good) then - nsuper2_kept=nsuper2_kept+1 - ndata =min(ndata+1,maxobs) - nodata =min(nodata+1,maxobs) !number of obs not used (no meaninghere) - usage = zero - if(icuse(ikx) < 0)usage=r100 - if(ncnumgrp(ikx) > 0 )then ! cross validation on - if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx) - end if - - call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) - - cdata(1) = error ! wind obs error (m/s) - cdata(2) = dlon ! grid relative longitude - cdata(3) = dlat ! grid relative latitude - cdata(4) = height ! obs absolute height (m) - cdata(5) = rwnd ! wind obs (m/s) - cdata(6) = azm*deg2rad ! azimuth angle (radians) - cdata(7) = t4dv ! obs time (hour) - cdata(8) = ikx ! type - cdata(9) = tiltangle ! tilt angle (radians) - cdata(10)= staheight ! station elevation (m) - cdata(11)= rstation_id ! station id - cdata(12)= usage ! usage parameter - cdata(13)= idomsfc ! dominate surface type - cdata(14)= skint ! skin temperature - cdata(15)= ff10 ! 10 meter wind factor - cdata(16)= sfcr ! surface roughness - cdata(17)=dlon_earth*rad2deg ! earth relative longitude (degrees) - cdata(18)=dlat_earth*rad2deg ! earth relative latitude (degrees) - cdata(19)=dist ! range from radar in km (used to estimatebeam spread) - cdata(20)=zsges ! model elevation at radar site - cdata(21)=thiserr - cdata(22)=two - - do i=1,maxdat - cdata_all(i,ndata)=cdata(i) - end do - - else - notgood = notgood + 1 - end if - - end do - - close(lnbufr) ! A simple unformatted fortran file should not be mixed with bufr I/O - write(6,*)'READ_RADAR_L2RW_NOVADQC: ',trim(outmessage),' reached eof on 2 superob radar file' - write(6,*)'READ_RADAR_L2RW_NOVADQC: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept - write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad azimuths=',ibadazm - write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad winds =',ibadwnd - write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad dists =',ibaddist - write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad stahgts =',ibadstaheight - write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad obshgts =',ibadheight - write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad errors =',ibaderror - write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad fit =',ibadfit - write(6,*)'READ_RADAR_L2RW_NOVADQC: # num thinned =',kthin - write(6,*)'READ_RADAR_L2RW_NOVADQC: # notgood0 =',notgood0 - write(6,*)'READ_RADAR_L2RW_NOVADQC: # notgood =',notgood - write(6,*)'READ_RADAR_L2RW_NOVADQC: # hgt belowsta=',iheightbelowsta - write(6,*)'READ_RADAR_L2RW_NOVADQC: timemin,max =',timemin,timemax - write(6,*)'READ_RADAR_L2RW_NOVADQC: errmin,max =',errmin,errmax - write(6,*)'READ_RADAR_L2RW_NOVADQC: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax - write(6,*)'READ_RADAR_L2RW_NOVADQC: iaaamin,max,8*max_rrr=',iaaamin,iaaamax,8*max_rrr - -! Write observation to scratch file - call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs) - write(lunout) obstype,sis,nreal,nchanl,ilat,ilon - write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata) - deallocate(cdata_all) - -900 continue - - return - -end subroutine read_radar_l2rw_novadqc - diff --git a/src/set_crtm_aerosolmod.f90 b/src/set_crtm_aerosolmod.f90 deleted file mode 100644 index 9fe0aad0c..000000000 --- a/src/set_crtm_aerosolmod.f90 +++ /dev/null @@ -1,48 +0,0 @@ -module set_crtm_aerosolmod -!$$$ module documentation block -! . . . . -! module: set_crtm_aerosolmod -! prgmmr: todling org: gmao date: 2011-06-01 -! -! abstract: module providing interface to set-crtm-aerosol procedures -! -! program history log: -! 2011-06-01 todling -! 2011-09-20 hclin - separate na and na_crtm for p25 handling -! -! subroutines included: -! sub Set_CRTM_Aerosol_ -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -implicit none - -private - -public Set_CRTM_Aerosol - -interface Set_CRTM_Aerosol - subroutine Set_CRTM_Aerosol_ ( km, na, na_crtm, aero_name, aero_conc, rh, aerosol) - use kinds, only: i_kind,r_kind - use constants, only: tiny_r_kind - use mpimod, only: mype - use CRTM_Aerosol_Define, only: CRTM_Aerosol_type - use mpeu_util, only: getindex - use crtm_module, only: SULFATE_AEROSOL,BLACK_CARBON_AEROSOL,ORGANIC_CARBON_AEROSOL,& - DUST_AEROSOL,SEASALT_SSAM_AEROSOL,SEASALT_SSCM1_AEROSOL,SEASALT_SSCM2_AEROSOL,SEASALT_SSCM3_AEROSOL - implicit none - integer(i_kind) , intent(in) :: km ! number of levels - integer(i_kind) , intent(in) :: na ! number of aerosols - integer(i_kind) , intent(in) :: na_crtm ! number of aerosols seen by CRTM - character(len=*), intent(in) :: aero_name(na) ! [na] GOCART aerosol names: du0001, etc. - real(r_kind), intent(inout) :: aero_conc(km,na) ! [km,na] aerosol concentration (Kg/m2) - real(r_kind), intent(in) :: rh(km) ! [km] relative humdity [0,1] - type(CRTM_Aerosol_type), intent(inout) :: aerosol(na_crtm)! [na] CRTM Aerosol object - end subroutine Set_CRTM_Aerosol_ -end interface - -end module set_crtm_aerosolmod diff --git a/src/setupaod.f90 b/src/setupaod.f90 deleted file mode 100644 index 6175acf30..000000000 --- a/src/setupaod.f90 +++ /dev/null @@ -1,640 +0,0 @@ - subroutine setupaod(lunin,mype,nchanl,nreal,nobs,& - obstype,isis,is,aero_diagsave,init_pass) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupaod compute rhs of oi equation for aod -! prgmmr: hclin org: ncar/mmm date: 2010-10-20 -! -! abstract: read in data, first guess, and obtain rhs of oi equation -! for aod. -! -! program history log: -! 2010-10-20 hclin - modified from setuprad for aod -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2015-09-10 zhu - generalize enabling all-sky and aerosol usage in radiance -! assimilation. Use radiance_obstype_search & type extentions -! 2016-02-20 pagowski - added NASA nnr AOD -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read radiance (brightness temperature, tb) obs -! mype - mpi task id -! nchanl - number of channels per obs -! nreal - number of pieces of non-tb information per obs -! nobs - number of tb observations to process -! obstype - type of tb observation -! isis - sensor/instrument/satellite id ex.amsua_n15 -! is - integer counter for number of observation types to process -! aero_diagsave - logical to switch on diagnostic output (.false.=no output) -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - - use radinfo, only: nsigradjac - use aeroinfo, only: nsigaerojac - use crtm_interface, only: init_crtm,call_crtm,destroy_crtm,sensorindex, & - isatid,itime,ilon,ilat,iszen_ang,isazi_ang - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,i_kind - use crtm_spccoeff, only: sc - use obsmod, only: ianldate,mype_diaghdr,nchan_total, & - dplat,obsdiags,obsptr,lobsdiagsave,lobsdiag_allocated,& - dirname,time_offset - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use gridmod, only: nsig,get_ij - use constants, only: tiny_r_kind,zero,one,three,r10 - use jfunc, only: jiter,miter - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use chemmod, only: laeroana_gocart, l_aoderr_table - use aeroinfo, only: jpch_aero, nusis_aero, nuchan_aero, iuse_aero, & - error_aero, gross_aero - use obsmod, only: i_aero_ob_type - use m_obsdiags, only: aerohead - use m_obsNode, only: obsNode - use m_aeroNode, only: aeroNode, aeroNode_typecast - use m_obsLList, only: obsLList_appendNode - use m_obsLlist, only: obsLList_tailNode - use obsmod, only: rmiss_single - use qcmod, only: ifail_crtm_qc - use radiance_mod, only: rad_obs_type,radiance_obstype_search - - implicit none - -! Declare passed variables - logical ,intent(in ) :: aero_diagsave - character(10) ,intent(in ) :: obstype - character(20) ,intent(in ) :: isis - integer(i_kind) ,intent(in ) :: lunin,mype,nchanl,nreal,nobs,is - logical ,intent(in ) :: init_pass ! state of "setup" processing - -! Declare external calls for code analysis - external:: stop2 - -! Declare local parameters - integer(i_kind),parameter:: ipchan=4 - integer(i_kind),parameter:: ireal=5 - - real(r_kind),parameter:: r1e10=1.0e10_r_kind - -! Declare local variables - character(128) diag_aero_file - - integer(i_kind) error_status,istat - integer(i_kind) m,jc - integer(i_kind) icc - integer(i_kind) j,k,ncnt,i - integer(i_kind) mm1 - integer(i_kind) n,ibin,ioff,ioff0,iii - integer(i_kind) ii,jj,idiag - - real(r_single) freq4,pol4,wave4,varch4 - real(r_kind) errinv,useflag - real(r_kind) trop5,pangs - real(r_kind) cenlon,cenlat,slats,slons,dtime - real(r_kind) val_obs - -! Declare local arrays - - real(r_single),dimension(ireal):: diagbuf - real(r_single),allocatable,dimension(:,:):: diagbufchan - - real(r_kind),dimension(nchanl):: varinv,error0 - real(r_kind),dimension(nchanl):: tnoise,errmax - real(r_kind),dimension(nchanl):: var,ratio_aoderr,aodinv - real(r_kind),dimension(nreal+nchanl,nobs)::data_s - real(r_kind),dimension(nsig):: prsltmp - real(r_kind),dimension(nsig):: qvp,tvp - real(r_kind),dimension(nsig+1):: prsitmp - real(r_kind) dtsavg - real(r_single) :: psfc - - integer(i_kind),dimension(nchanl):: ich,id_qc - - character(10) filex - character(12) string - - logical toss,l_may_be_passive - logical,dimension(nobs):: luse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(aeroNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - type(rad_obs_type) :: radmod - character(len=*),parameter:: myname="setupaod" - - real(r_kind), dimension(nchanl) :: total_aod, aod_obs, aod - - integer(i_kind) :: istyp, idbcf, ilone, ilate - real(r_kind) :: styp, dbcf - - real(r_kind),dimension(nchanl):: emissivity,ts,emissivity_k - real(r_kind),dimension(nchanl):: tsim - real(r_kind),dimension(nsig,nchanl):: wmix,temp,ptau5 - real(r_kind),dimension(nsigradjac,nchanl):: jacobian - real(r_kind),dimension(nsigaerojac,nchanl):: jacobian_aero - real(r_kind),dimension(nsig,nchanl):: layer_od - real(r_kind) :: clw_guess, tzbgr, sfc_speed - - if ( .not. laeroana_gocart ) then - return - endif - - n_alloc(:)=0 - m_alloc(:)=0 -!************************************************************************************** -! Initialize variables and constants. - mm1 = mype+1 - ncnt = 0 - icc = 0 - - isatid = 1 ! index of satellite id - itime = 2 ! index of analysis relative obs time - ilon = 3 ! index of grid relative obs location (x) - ilat = 4 ! index of grid relative obs location (y) - ilone = 5 ! index of earth relative longitude (degrees) - ilate = 6 ! index of earth relative latitude (degrees) - iszen_ang = 8 ! index of solar zenith angle (degrees) - isazi_ang = 9 ! index of solar azimuth angle (degrees) - istyp = 10 ! index of surface type - idbcf = 11 ! index of deep blue confidence flag - -! Determine cloud & aerosol usages in radiance assimilation - call radiance_obstype_search(obstype,radmod) - -! Initialize channel related information - tnoise = r1e10 - errmax = r1e10 - l_may_be_passive = .false. - toss = .true. - jc=0 - do j=1,jpch_aero - if(isis == nusis_aero(j))then - jc=jc+1 - if(jc > nchanl)then - write(6,*)'setupaod: ***ERROR*** in channel numbers, jc,nchanl=',jc,nchanl,& - ' ***STOP IN setupaod***' - call stop2(71) - end if - -! Load channel numbers into local array based on satellite type - - ich(jc)=j -! -! Set error instrument channels - tnoise(jc)=error_aero(j) - errmax(jc)=gross_aero(j) - if (iuse_aero(j)< -1 .or. (iuse_aero(j) == -1 .and. & - .not.aero_diagsave)) tnoise(jc)=r1e10 - if (iuse_aero(j)>-1) l_may_be_passive=.true. - if (tnoise(jc) < 1.e4_r_kind) toss = .false. - end if - end do - if ( mype == 0 .and. .not.l_may_be_passive) write(6,*)mype,'setupaod: passive obs',is,isis - if(nchanl > jc) write(6,*)'setupaod: channel number reduced for ', & - obstype,nchanl,' --> ',jc - if(jc == 0) then - if(mype == 0) write(6,*)'setupaod: No channels found for ', & - obstype,isis - if(nobs > 0)read(lunin) - return - end if - if (toss) then - if(mype == 0)write(6,*)'setupaod: all obs var > 1e4. do not use ',& - 'data from satellite is=',isis - if(nobs >0)read(lunin) - return - endif - - ioff0=0 - if (lobsdiagsave) then - if (l_may_be_passive) then - ioff0=4 - else - ioff0=5 - endif - endif - -! Initialize radiative transfer - call init_crtm(init_pass,mype_diaghdr(is),mype,nchanl,isis,obstype,radmod) - -! If diagnostic file requested, open unit to file and write header. - if (aero_diagsave) then - filex=obstype - write(string,1976) jiter -1976 format('_',i2.2) - diag_aero_file= trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // trim(string) - if(init_pass) then - open(4,file=trim(diag_aero_file),form='unformatted',status='unknown',position='rewind') - else - open(4,file=trim(diag_aero_file),form='unformatted',status='old',position='append') - endif - -! Initialize/write parameters for satellite diagnostic file on -! first outer iteration. - if (init_pass .and. mype==mype_diaghdr(is)) then - write(4) isis,dplat(is),obstype,jiter,nchanl,ianldate,ireal,ipchan,nsig,ioff0 - write(6,*)'setupaod: write header record for ',& - isis,ireal,' to file ',trim(diag_aero_file),' ',ianldate - do i=1,nchanl - n=ich(i) - if( n < 1 )cycle - varch4=error_aero(n) - freq4=sc(sensorindex)%frequency(i) - pol4=sc(sensorindex)%polarization(i) - wave4=sc(sensorindex)%wavenumber(i) - write(4)freq4,pol4,wave4,varch4,iuse_aero(n),& - nuchan_aero(n),ich(i) - end do - endif - endif - - idiag=ipchan - if (lobsdiagsave) idiag=idiag+4*miter+1 - allocate(diagbufchan(idiag,nchanl)) - -! Load data array for current satellite - read(lunin) data_s,luse,ioid - - write(*,*) 'read in data',nobs -! Loop over data in this block - call dtime_setup() - do n = 1,nobs -! Extract analysis relative observation time. - dtime = data_s(itime,n) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - - id_qc = 0 - -! Extract lon and lat. - slons = data_s(ilon,n) ! grid relative longitude - slats = data_s(ilat,n) ! grid relative latitude - cenlon = data_s(ilone,n) ! earth relative longitude (degrees) - cenlat = data_s(ilate,n) ! earth relative latitude (degrees) - pangs = data_s(iszen_ang,n) - styp = data_s(istyp,n) - dbcf = data_s(idbcf,n) - -! Set relative weight value - val_obs=one - -! Load channel data into work array. - aod_obs = rmiss_single - do i = 1, nchanl - aod_obs(i) = data_s(i+nreal,n) - end do - - if ( .not. l_aoderr_table ) then -! set observation error - select case ( nint(styp) ) - case ( 0 ) ! water - tnoise = 0.03_r_kind+0.05_r_kind*aod_obs - case ( 1, 2, 3 ) ! coast, desert, land - tnoise = 0.05_r_kind+0.15_r_kind*aod_obs - case ( 4 ) ! deep blue - if ( nint(dbcf) >= 0 .and. nint(dbcf) <= 3 ) then - tnoise = 0.05_r_kind+0.15_r_kind*aod_obs+0.01_r_kind*(three-dbcf) - end if - case ( 5 ) ! nnr ocean - tnoise = 0.2_r_kind*(aod_obs+0.01_r_kind) - case ( 6 ) ! nnr land - tnoise = 0.2_r_kind*(aod_obs+0.01_r_kind) - - - end select - end if - -! Interpolate model fields to observation location, call crtm and create jacobians - call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & - tvp,qvp,clw_guess,prsltmp,prsitmp, & - trop5,tzbgr,dtsavg,sfc_speed, & - tsim,emissivity,ptau5,ts,emissivity_k, & - temp,wmix,jacobian,error_status,layer_od=layer_od,jacobian_aero=jacobian_aero) - - -! If the CRTM returns an error flag, do not assimilate any channels for this ob -! and set the QC flag to ifail_crtm_qc. -! We currently go through the rest of the QC steps, ensuring that the diagnostic -! files are populated, but this could be changed if it causes problems. - if (error_status /=0) then - id_qc(1:nchanl) = ifail_crtm_qc - varinv(1:nchanl) = zero - endif - - total_aod = zero - do i = 1, nchanl - total_aod(i) =sum(layer_od(:,i)) - enddo - - do i = 1, nchanl - aod(i) = aod_obs(i) - total_aod(i) - error0(i) = tnoise(i) - if(aod_obs(i)>zero .and. tnoise(i) < 1.e4_r_kind .or. (iuse_aero(ich(i))==-1 & - .and. aero_diagsave))then - varinv(i) = val_obs/tnoise(i)**2 - else - if(id_qc(i) == 0)id_qc(i)=1 - varinv(i) = zero - endif - end do - - !do i = 1, nchanl - ! if ( aod_obs(i) > zero ) then - ! write(6,'(A,3i6,4f8.3,2f8.2)') 'mype, iobs, ichan, aod_crtm, aod_obs, omb, err, lat, lon : ', & - ! mype, n, i, total_aod(i), aod_obs(i),aod(i), tnoise(i), cenlat, cenlon - ! end if - !end do - - icc = 0 - do i = 1, nchanl - ! Only process observations to be assimilated - if (varinv(i) > tiny_r_kind ) then - m = ich(i) - ! Only "good" obs are included in J calculation. - if (iuse_aero(m) >= 1)then - icc = icc + 1 - aodinv(icc) = aod(i) ! obs-ges innovation - var(icc) = one/error0(i)**2 ! 1/(obs error)**2 (original uninflated error) - ratio_aoderr(icc)=error0(i)**2*varinv(i) ! (original error)/(inflated error) - endif - endif - end do - endif ! (in_curbin) - -! In principle, we want ALL obs in the diagnostics structure but for -! passive obs (monitoring), it is difficult to do if aero_diagsave -! is not on in the first outer loop. For now we use l_may_be_passive... - if (l_may_be_passive) then -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - if (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - - if (in_curbin) then -! Load data into output arrays - if (icc > 0) then - ncnt =ncnt+1 - nchan_total=nchan_total+icc - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(aerohead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(n) - my_head%elat= data_s(ilate,n) - my_head%elon= data_s(ilone,n) - - allocate(my_head%res(icc),my_head%err2(icc), & - my_head%raterr2(icc), & - my_head%daod_dvar(nsigaerojac,icc), & - my_head%ich(icc),& - my_head%icx(icc)) - if(luse_obsdiag)allocate (my_head%diags(icc)) - - my_head%nlaero = icc ! profile observation count - call get_ij(mm1,slats,slons,my_head%ij(1),my_head%wij(1)) - - my_head%time=dtime - my_head%luse=luse(n) - my_head%ich(:)=-1 - - iii=0 - do ii=1,nchanl - m=ich(ii) - if (varinv(ii)>tiny_r_kind .and. iuse_aero(m)>=1) then - iii=iii+1 - my_head%res(iii)=aodinv(iii) - my_head%err2(iii)=var(iii) - my_head%raterr2(iii)=ratio_aoderr(iii) - my_head%icx(iii)=m - do k = 1, nsigaerojac - my_head%daod_dvar(k,iii)=jacobian_aero(k,ii) - end do - my_head%ich(iii)=ii - end if - end do - - my_head => null() - end if ! icc - endif ! (in_curbin) - -! Link obs to diagnostics structure - if(luse_obsdiag)then - iii=0 - do ii=1,nchanl - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_aero_ob_type,ibin)%head)) then - obsdiags(i_aero_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_aero_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupaod: failure to allocate obsdiags',istat - call stop2(276) - end if - obsdiags(i_aero_ob_type,ibin)%tail => obsdiags(i_aero_ob_type,ibin)%head - else - allocate(obsdiags(i_aero_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupaod: failure to allocate obsdiags',istat - call stop2(277) - end if - obsdiags(i_aero_ob_type,ibin)%tail => obsdiags(i_aero_ob_type,ibin)%tail%next - end if - obsdiags(i_aero_ob_type,ibin)%n_alloc = obsdiags(i_aero_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_aero_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_aero_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_aero_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_aero_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_aero_ob_type,ibin)%tail%indxglb=(ioid(n)-1)*nchanl+ii - obsdiags(i_aero_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_aero_ob_type,ibin)%tail%luse=luse(n) - obsdiags(i_aero_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_aero_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_aero_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_aero_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_aero_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_aero_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(n) - my_diag%ich = ii - my_diag%elat= data_s(ilate,n) - my_diag%elon= data_s(ilone,n) - else - if (.not.associated(obsdiags(i_aero_ob_type,ibin)%tail)) then - obsdiags(i_aero_ob_type,ibin)%tail => obsdiags(i_aero_ob_type,ibin)%head - else - obsdiags(i_aero_ob_type,ibin)%tail => obsdiags(i_aero_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_aero_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_aero_ob_type,ibin)%tail)') - end if - if (obsdiags(i_aero_ob_type,ibin)%tail%indxglb/=(ioid(n)-1)*nchanl+ii) then - write(6,*)'setupaod: index error' - call stop2(278) - endif - endif - - if (in_curbin.and.icc>0) then - !my_head => aeroNode_typecast(obsLList_tailNode(aerohead(ibin))) - my_node => obsLList_tailNode(aerohead(ibin)) - if(.not.associated(my_node)) & - call die(myname,'unexpected, associated(my_node) =',associated(my_node)) - my_head => aeroNode_typecast(my_node) - if(.not.associated(my_head)) & - call die(myname,'unexpected, associated(my_head) =',associated(my_head)) - my_node => null() - - if (ii==1) obsptr => obsdiags(i_aero_ob_type,ibin)%tail - if (ii==1) obsdiags(i_aero_ob_type,ibin)%tail%nchnperobs = nchanl - obsdiags(i_aero_ob_type,ibin)%tail%nldepart(jiter) = aod(ii) - obsdiags(i_aero_ob_type,ibin)%tail%wgtjo=varinv(ii) - -! Load data into output arrays - m=ich(ii) - if (varinv(ii)>tiny_r_kind .and. iuse_aero(m)>=1) then - iii=iii+1 - my_head%diags(iii)%ptr => obsdiags(i_aero_ob_type,ibin)%tail - obsdiags(i_aero_ob_type,ibin)%tail%muse(jiter) = .true. - - ! verify the pointer to obsdiags - - my_diag => my_head%diags(iii)%ptr - - if (my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob .or. & - my_head%ich(iii) /= my_diag%ich ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ich,ibin) =', & - (/is,ioid(n),ii,ibin/)) - call perr(myname,'my_head%(idv,iob,ich) =',(/my_head%idv,my_head%iob,my_head%ich(iii)/)) - call perr(myname,'my_diag%(idv,iob,ich) =',(/my_diag%idv,my_diag%iob,my_diag%ich/)) - call die(myname) - endif - endif - - my_head => null() - endif ! (in_curbin) - enddo ! do ii=1,nchanl - if (in_curbin) then - if( iii/=icc ) then - write(6,*)'setupaod: error iii icc',iii,icc - call stop2(279) - endif - endif ! (in_curbin) - endif ! (luse_obsdiag) - -! End of l_may_be_passive block - endif - - if(in_curbin) then -! Write diagnostics to output file. - if (aero_diagsave .and. luse(n)) then - diagbuf(1) = cenlat ! observation latitude (degrees) - diagbuf(2) = cenlon ! observation longitude (degrees) - diagbuf(3) = dtime-time_offset ! observation time (hours relative to analysis time) - diagbuf(4) = pangs ! solar zenith angle (degrees) - diagbuf(5) = data_s(isazi_ang,n) ! solar azimuth angle (degrees) - - do i=1,nchanl - diagbufchan(1,i)=aod_obs(i) ! observed brightness temperature (K) -! diagbufchan(2,i)=total_aod(i) ! observed - simulated Tb with no bias corrrection (K) - this should be innovation - diagbufchan(2,i)=aod(i) ! innovation - errinv = sqrt(varinv(i)) - diagbufchan(3,i)=errinv ! inverse observation error - useflag=one - if (iuse_aero(ich(i)) < 1) useflag=-one - diagbufchan(4,i)= id_qc(i)*useflag! quality control mark or event indicator - end do - - if (lobsdiagsave) then - if (l_may_be_passive) then - do ii=1,nchanl - if (.not.associated(obsptr)) then - write(6,*)'setupaod: error obsptr' - call stop2(280) - end if - if (obsptr%indxglb/=(ioid(n)-1)*nchanl+ii) then - write(6,*)'setupaod: error writing diagnostics' - call stop2(281) - end if - - ioff=ioff0 - do jj=1,miter - ioff=ioff+1 - if (obsptr%muse(jj)) then - diagbufchan(ioff,ii) = one - else - diagbufchan(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - diagbufchan(ioff,ii) = obsptr%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - diagbufchan(ioff,ii) = obsptr%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - diagbufchan(ioff,ii) = obsptr%obssen(jj) - enddo - - obsptr => obsptr%next - enddo - else - ioff=ioff0 - diagbufchan(ioff+1:ioff+4*miter+1,1:nchanl) = zero - endif - endif - - psfc=prsitmp(1)*r10 ! convert to hPa - write(4) psfc,diagbuf,diagbufchan - - end if - endif ! (in_curbin) - -100 continue - -! End of n-loop over obs - end do - -! Jump here when there is no data to process for current satellite -! Deallocate arrays - deallocate(diagbufchan) - - if (aero_diagsave) then - call dtime_show(myname,'diagsave:aero',i_aero_ob_type) - close(4) - endif - - call destroy_crtm - -! End of routine - - return - -end subroutine setupaod diff --git a/src/setupcldch.f90 b/src/setupcldch.f90 deleted file mode 100644 index 03e6063cf..000000000 --- a/src/setupcldch.f90 +++ /dev/null @@ -1,658 +0,0 @@ -subroutine setupcldch(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupcldch compute rhs for conventional surface cldch -! prgmmr: derber org: np23 date: 2004-07-20 -! -! abstract: For sea surface temperature observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2015-07-10 pondeca -! 2016-05-06 yang - add closest_obs to select only one obs. among the multi-reports. -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! before retuning to setuprhsall.f90 -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use m_obsNode , only: obsNode - use m_cldchNode, only: cldchNode - use m_obsdiags , only: cldchhead - use m_obsLList , only: obsLList_appendNode - - use guess_grids, only: hrdifsig,nfldsig - use obsmod, only: rmiss_single,i_cldch_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,bmiss - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig - use gridmod, only: get_ij - use constants, only: zero,tiny_r_kind,one,half,one_tenth,wgtlim, & - two,cg_term,huge_single - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print,closest_obs - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss - character(len=*),parameter:: myname='setupcldch' - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) cldchges,dlat,dlon,ddiff,dtime,error - real(r_kind) cldch_errmax,offtime_k,offtime_l - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,rwgt - real(r_kind) cg_cldch,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,icldch,id,itime,ikx,imaxerr,iqc - integer(i_kind) iuse,ilate,ilone,istnelv,iobshgt,izz,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - - class(obsNode ),pointer:: my_node - type(cldchNode),pointer:: my_head - type(obs_diag ),pointer:: my_diag - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,:) :: ges_ps - real(r_kind),allocatable,dimension(:,:,:) :: ges_cldch - real(r_kind),allocatable,dimension(:,:,:) :: ges_z - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 - cldch_errmax=10000.0_r_kind -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - icldch=4 ! index of cldch observation - background - id=5 ! index of station id - itime=6 ! index of observation time in data array - ikxx=7 ! index of ob type - imaxerr=8 ! index of cldch max error - iqc=9 ! index of quality mark - iuse=10 ! index of use parameter - idomsfc=11 ! index of dominant surface type - ilone=12 ! index of longitude (degrees) - ilate=13 ! index of latitude (degrees) - istnelv=14 ! index of station elevation (m) - iobshgt=15 ! index of observation height (m) - izz=16 ! index of surface height - iprvd=17 ! index of provider - isprvd=18 ! index of subprovider - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - -! Check for missing data !need obs value and error - do i=1,nobs - if (data(icldch,i) > r0_1_bmiss) then - muse(i)=.false. - data(icldch,i)=rmiss_single ! for diag output - data(iobshgt,i)=rmiss_single ! for diag output - end if - -! set any observations larger than 20000.0 to be 20000.0 - if (data(icldch,i) > 20000.0_r_kind) data(icldch,i)=20000.0_r_kind !REVISE VALUE / MPondeca , 17Jul2015 - end do - offtime_k=0.0_r_kind - offtime_l=0.0_r_kind - dup=one -! if closest_obs=.true., choose the timely closest observation among the multi-reports at a station. - if (closest_obs) then - dup=one - do k=1,nobs - if( dup(k) < tiny_r_kind .or. .not. muse(k) ) then - dup(k)=-99.0_r_kind - else - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < cldch_errmax .and. data(ier,l) abs(offtime_l)) then - dup(k)=-99.0_r_kind - endif - if(abs(offtime_k)==abs(offtime_l)) then - if (offtime_k >= 0.0_r_kind) dup(l)=-99.0_r_kind - if (offtime_l >= 0.0_r_kind) dup(k)=-99.0_r_kind - endif - endif - enddo - endif - enddo - else - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < cldch_errmax .and. data(ier,l) < cldch_errmax & - .and. muse(k) .and. muse(l)) then - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - endif - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=22 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - allocate(cprvstg(nobs),csprvstg(nobs)) - end if - - mm1=mype+1 - scale=one - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_cldch_ob_type,ibin)%head)) then - obsdiags(i_cldch_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_cldch_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupcldch: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_cldch_ob_type,ibin)%tail => obsdiags(i_cldch_ob_type,ibin)%head - else - allocate(obsdiags(i_cldch_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupcldch: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_cldch_ob_type,ibin)%tail => obsdiags(i_cldch_ob_type,ibin)%tail%next - end if - obsdiags(i_cldch_ob_type,ibin)%n_alloc = obsdiags(i_cldch_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_cldch_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_cldch_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_cldch_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_cldch_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_cldch_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_cldch_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_cldch_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_cldch_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_cldch_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_cldch_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_cldch_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_cldch_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_cldch_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_cldch_ob_type,ibin)%tail)) then - obsdiags(i_cldch_ob_type,ibin)%tail => obsdiags(i_cldch_ob_type,ibin)%head - else - obsdiags(i_cldch_ob_type,ibin)%tail => obsdiags(i_cldch_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_cldch_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_cldch_ob_type,ibin)%tail)') - end if - if (obsdiags(i_cldch_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupcldch: index error' - call stop2(297) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Interpolate to get cldch at obs location/time - call tintrp2a11(ges_cldch,cldchges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - -! Adjust observation error - ratio_errors=error/data(ier,i) - error=one/error - - ddiff=data(icldch,i)-cldchges - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross check using innovation normalized by error - if (abs(data(icldch,i)-rmiss_single) >= tiny_r_kind ) then !MIGHT WANT TO IMPROVE THIS. MPondeca /17Jul2015 - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else -! dup(i) < 0 means closest_obs =.true. - if(dup(i)> tiny_r_kind) then - ratio_errors=ratio_errors/sqrt(dup(i)) - else - ratio_errors=zero - endif - endif - else ! missing data - error = zero - ratio_errors=zero - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_cldch_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_cldch=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_cldch*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - nn=1 - else - nn=2 !rejected obs - if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs - end if - - ress = ddiff*scale - ressw2 = ress*ress - - if (abs(data(icldch,i)-rmiss_single) >=tiny_r_kind) then - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - end if - - endif - - if(luse_obsdiag)then - obsdiags(i_cldch_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_cldch_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_cldch_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(cldchhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_cldch_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m**-1) - - rdiagbuf(17,ii) = data(icldch,i) ! CLDCH observation (m) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (m) - rdiagbuf(19,ii) = data(icldch,i)-cldchges! obs-ges w/o bias correction (m) (future slot) - - rdiagbuf(20,ii) = rmiss_single ! type of measurement - - rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(22,ii) = data(izz,i) ! model terrain at observation location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_cldch_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_cldch_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_cldch_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_cldch_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - - - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:cldch',i_cldch_ob_type) - write(7)'cei',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::cldch' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get cldch ... - varname='cldch' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_cldch))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_cldch(size(rank2,1),size(rank2,2),nfldsig)) - ges_cldch(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_cldch(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_cldch)) deallocate(ges_cldch) - if(allocated(ges_ps )) deallocate(ges_ps ) - end subroutine final_vars_ - -end subroutine setupcldch - diff --git a/src/setupdw.f90 b/src/setupdw.f90 deleted file mode 100644 index e311af83e..000000000 --- a/src/setupdw.f90 +++ /dev/null @@ -1,842 +0,0 @@ -!------------------------------------------------------------------------- -! NOAA/NCEP, National Centers for Environmental Prediction GSI ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: setupdw --- Compute rhs of oi for doppler lidar winds -! -! !INTERFACE: -! -subroutine setupdw(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) - -! !USES: - - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - - use qcmod, only: dfact,dfact1,npres_print,ptop,pbot - - use gridmod, only: nsig,get_ijk - - use guess_grids, only: hrdifsig,geop_hgtl,ges_lnprsl,& - nfldsig,sfcmod_gfs,sfcmod_mm5,comp_fact10 - - use constants, only: grav_ratio,flattening,grav,zero,rad2deg,deg2rad, & - grav_equator,one,two,somigliana,semi_major_axis,eccentricity,r1000,& - wgtlim - use constants, only: tiny_r_kind,half,cg_term,huge_single - - use obsmod, only: rmiss_single,i_dw_ob_type,obsdiags - use m_obsdiags, only: dwhead - use obsmod, only: lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode, only: obsNode - use m_dwNode, only: dwNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - - use jfunc, only: last, jiter, miter - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - - use m_dtime, only: dtime_setup, dtime_check, dtime_show - - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - - implicit none - -! !INPUT PARAMETERS: - - integer(i_kind) ,intent(in ) :: lunin ! unit from which to read observations - integer(i_kind) ,intent(in ) :: mype ! mpi task id - integer(i_kind) ,intent(in ) :: nele ! number of data elements per observation - integer(i_kind) ,intent(in ) :: nobs ! number of observations - integer(i_kind) ,intent(in ) :: is ! ndat index - logical ,intent(in ) :: conv_diagsave ! logical to save innovation dignostics - -! !INPUT/OUTPUT PARAMETERS: - ! array containing information about ... - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork ! data counts and gross checks - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork ! obs-ges stats - -! !DESCRIPTION: For doppler lidar wind observations, this routine -! \begin{enumerate} -! \item reads obs assigned to given mpi task (geographic region), -! \item simulates obs from guess, -! \item apply some quality control to obs, -! \item load weight and innovation arrays used in minimization -! \item collects statistics for runtime diagnostic output -! \item writes additional diagnostic information to output file -! \end{enumerate} -! -! !REVISION HISTORY: -! 1998-05-15 yang, weiyu -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-17 treadon - update documentation -! 2004-07-15 todling - protex-compliant prologue; added intent/only's -! 2004-10-06 parrish - increase size of dwork array for nonlinear qc -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list -! 2005-03-02 dee - remove garbage from diagnostic file -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-05-27 derber - level output change -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-11-03 treadon - correct error in ilone,ilate data array indices -! 2005-11-29 derber - remove psfcg and use ges_lnps instead -! 2006-01-31 todling/treadon - store wgt/wgtlim in rdiagbuf(6,ii) -! 2006-02-02 treadon - rename lnprsl as ges_lnprsl -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-05-30 derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - unify NL qc -! 2006-07-31 kleist - use ges_ps -! 2006-08-28 su - fix a bug in variational qc -! 2007-03-19 tremolet - binning of observations -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-08-28 su - modify the gross check error -! 2008-05-23 safford - rm unused vars -! 2008-12-03 todling - changed handle of tail%time -! 2009-03-19 mccarty/brin - set initial obs error to that from bufr -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2010-08-01 woollen - add azmth and elevation angle check in duplication (denoted as jsw) -! 2010-09-01 masutani - remove repe_dw and get representativeness error from coninfo (msq) -! 2010-11-20 woollen - dpress is adjusted by zsges (denoted as jsw) -! 2010-12-03 woollen - fix low level adjust ment to factw (denoted as jsw) -! 2010-12-06 masutani - pass subtype kx to identify KNMI product (msq) -! 2011-04-18 mccarty - updated kx determination for ADM, modified presw calculation -! 2011-05-05 mccarty - re-removed repe_dw, added +1 conditional for reproducibility on ADM -! 2011-05-26 mccarty - moved MSQ error logic from read_lidar -! 2013-01-26 parrish - change from grdcrd to grdcrd1, tintrp2a to tintrp2a1, tintrp2a11, -! tintrp3 to tintrp31 (to allow successful debug compile on WCOSS) -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! !REMARKS: -! language: f90 -! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq/HP -! -! !AUTHOR: -! yang org: np20 date: 1998-05-15 -! -!EOP -!------------------------------------------------------------------------- - -! Declare external calls for code analysis - external:: tintrp3 - external:: grdcrd1 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_001 = 0.001_r_kind - real(r_kind),parameter:: r8 = 8.0_r_kind - real(r_kind),parameter:: ten = 10.0_r_kind - character(len=*),parameter:: myname="setupdw" - real(r_kind),parameter:: dmiss = 9.0e+10_r_kind !missing value for msq error adj - wm - -! Declare local variables - - real(r_double) rstation_id - real(r_kind) sinazm,cosazm,scale - real(r_kind) ratio_errors,dlat,dlon,dtime,error,dpres,zsges !jsw - real(r_kind) dlnp,pobl,rhgh,rsig,rlow - real(r_kind) zob,termrg,dz,termr,sin2,termg - real(r_kind) sfcchk,slat,psges,dwwind - real(r_kind) ugesindw,vgesindw,factw,presw - real(r_kind) residual,obserrlm,obserror,ratio,val2 - real(r_kind) ress,ressw - real(r_kind) val,valqc,ddiff,rwgt,sfcr,skint - real(r_kind) cg_dw,wgross,wnotgross,wgt,arg,term,exp_arg,rat_err2 - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final,tfact - real(r_kind),dimension(nele,nobs):: data - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nsig):: hges,zges,prsltmp - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - integer(i_kind) mm1,ikxx,nn,isli,ibin,ioff,ioff0 - integer(i_kind) jsig - integer(i_kind) i,nchar,nreal,k,j,k1,jj,l,ii,k2 - integer(i_kind) ier,ilon,ilat,ihgt,ilob,id,itime,ikx,iatd,inls,incls - integer(i_kind) iazm,ielva,iuse,ilate,ilone,istat - integer(i_kind) idomsfc,isfcr,iff10,iskint - - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - logical:: in_curbin,in_anybin - integer(i_kind),dimension(nobs_bins):: n_alloc - integer(i_kind),dimension(nobs_bins):: m_alloc - class(obsNode),pointer:: my_node - type(dwNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - equivalence(rstation_id,station_id) - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 - -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ikxx=1 ! index of ob type - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - itime=4 ! index of observation time in data array - ihgt=5 ! index of obs vertical coordinate in data array(height-m) - ielva=6 ! index of elevation angle(radians) - iazm=7 ! index of azimuth angle(radians) in data array - inls=8 ! index of number of laser shots - incls=9 ! index of number of cloud laser shots - iatd=10 ! index of atmospheric depth - ilob=11 ! index of lidar observation - ier=12 ! index of obs error - id=13 ! index of station id - iuse=14 ! index of use parameter - idomsfc=15 ! index of dominate surface type - iskint=16 ! index of skin temperature - iff10 = 17 ! index of 10 m wind factor - isfcr = 18 ! index of surface roughness - ilone=19 ! index of longitude (degrees) - ilate=20 ! index of latitude (degrees) - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ihgt,k) == data(ihgt,l) .and. & - data(iazm,k) == data(iazm,l) .and. & ! jsw check azmth angle - data(ielva,k) == data(ielva,l) .and. & ! jsw check eleveaiton angle - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=26 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - scale=one - rsig=float(nsig) - mm1=mype+1 - - call dtime_setup() - do i=1,nobs -! Convert obs lats and lons to grid coordinates - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - dpres=data(ihgt,i) - - ikx=nint(data(ikxx,i)) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_dw_ob_type,ibin)%head)) then - obsdiags(i_dw_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_dw_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupdw: failure to allocate obsdiags',istat - call stop2(253) - end if - obsdiags(i_dw_ob_type,ibin)%tail => obsdiags(i_dw_ob_type,ibin)%head - else - allocate(obsdiags(i_dw_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupdw: failure to allocate obsdiags',istat - call stop2(254) - end if - obsdiags(i_dw_ob_type,ibin)%tail => obsdiags(i_dw_ob_type,ibin)%tail%next - end if - obsdiags(i_dw_ob_type,ibin)%n_alloc = obsdiags(i_dw_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_dw_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_dw_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_dw_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_dw_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_dw_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_dw_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_dw_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_dw_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_dw_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_dw_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_dw_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_dw_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin)=n_alloc(ibin)+1 - my_diag => obsdiags(i_dw_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_dw_ob_type,ibin)%tail)) then - obsdiags(i_dw_ob_type,ibin)%tail => obsdiags(i_dw_ob_type,ibin)%head - else - obsdiags(i_dw_ob_type,ibin)%tail => obsdiags(i_dw_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_dw_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_dw_ob_type,ibin)%tail)') - end if - if (obsdiags(i_dw_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupdw: index error' - call stop2(255) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Save observation latitude. This is needed when converting -! geopotential to geometric height (hges --> zges below) - slat=data(ilate,i)*deg2rad - -! Interpolate log(surface pressure), model terrain, -! and log(pres) at mid-layers to observation location. - factw=data(iff10,i) - if(sfcmod_gfs .or. sfcmod_mm5) then - sfcr = data(isfcr,i) - skint = data(iskint,i) - isli = data(idomsfc,i) - call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) - end if - - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - call tintrp2a1(geop_hgtl,hges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - - call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& ! jsw - mype,nfldsig) ! jsw - dpres=dpres-zsges !jsw need to adjust dpres by zsges - - -! Convert geopotential height at layer midpoints to geometric height using -! equations (17, 20, 23) in MJ Mahoney's note "A discussion of various -! measures of altitude" (2001). Available on the web at -! http://mtp.jpl.nasa.gov/notes/altitude/altitude.html -! -! termg = equation 17 -! termr = equation 21 -! termrg = first term in the denominator of equation 23 -! zges = equation 23 - - sin2 = sin(slat)*sin(slat) - termg = grav_equator * & - ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) - termr = semi_major_axis /(one + flattening + grav_ratio - & - two*flattening*sin2) - termrg = (termg/grav)*termr - do k=1,nsig - zges(k) = (termr*hges(k)) / (termrg-hges(k)) ! eq (23) - end do - -! Given observation height, (1) adjust 10 meter wind factor if -! necessary, (2) convert height to grid relative units, (3) compute -! compute observation pressure (for diagnostic purposes only), and -! (4) compute location of midpoint of first model layer above surface -! in grid relative units - -! Adjust 10m wind factor if necessary. Rarely do we have a -! lidar obs within 10 meters of the surface. Almost always, -! the code below resets the 10m wind factor to 1.0 (i.e., no -! reduction in wind speed due to surface friction). - -! adjust wind near surface jsw - if (dpres10)then - term = (zges(1)-dpres)/(zges(1)-ten) - term = min(max(term,zero),one) - if(zges(1)<10) term=1 - factw = one-term+factw*term - endif - else - factw=one - endif - - -! Convert observation height (in dpres) from meters to grid relative -! units. Save the observation height in zob for later use. - zob = dpres - call grdcrd1(dpres,zges,nsig,1) - -! Set indices of model levels below (k1) and above (k2) observation. -! wm - updated so {k1,k2} are at min {1,2} and at max {nsig-1,nsig} - k=dpres - k1=min(max(1,k),nsig-1) - k2=min(k1+1,nsig) -! k1=max(1,k) - old method -! k2=min(k+1,nsig) - old method - -! Compute observation pressure (only used for diagnostics) - dz = zges(k2)-zges(k1) - dlnp = prsltmp(k2)-prsltmp(k1) - pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1)) - presw = ten*exp(pobl) - -! Determine location in terms of grid units for midpoint of -! first layer above surface - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp,nsig,-1) - -! Check to see if observation is below midpoint of first -! above surface layer. If so, set rlow to that difference - - rlow=max(sfcchk-dpres,zero) - -! Check to see if observation is above midpoint of layer -! at the top of the model. If so, set rhgh to that difference. - rhgh=max(dpres-r0_001-nsig,zero) - -! Increment obs counter along with low and high obs counters - if(luse(i))then - awork(1)=awork(1)+one - if(rhgh/=zero) awork(2)=awork(2)+one - if(rlow/=zero) awork(3)=awork(3)+one - end if - -! Set initial obs error to that supplied in BUFR stream. - error = data(ier,i) -! Removed repe_dw, but retained the "+ one" for reproducibility -! for ikx=100 or 101 - wm - if (ictype(ikx)==100 .or. ictype(ikx)==101)error = error + one -! msq error change moved from read_lidar, wrapped to avoid changing -! ADM values - if (ictype(ikx)==200 .or. ictype(ikx)==201) then - if (data(ier,i) > dmiss) then - error = 3.0_r_kind - else - error = data(ier,i) / cos(data(ielva,i)) - endif - endif - - ratio_errors = error/abs(error + 1.0e6_r_kind*rhgh + r8*rlow) - error = one/error - - if(dpres < zero .or. dpres > rsig)ratio_errors = zero - -! Simulate dw wind from guess (forward model) -! First, interpolate u,v guess to observation location - call tintrp31(ges_u,ugesindw,dlat,dlon,dpres,dtime,& - hrdifsig,mype,nfldsig) - call tintrp31(ges_v,vgesindw,dlat,dlon,dpres,dtime,& - hrdifsig,mype,nfldsig) - - -! Next, convert wind components to line of sight value -!wm if (nint(data(isubtype,i))==100.or.nint(data(isubtype,i))==101) then - if (ictype(ikx)==100 .or. ictype(ikx)==101) then -! KNMI product msq - cosazm = -cos(data(iazm,i)) ! cos(azimuth) ! mccarty msq - sinazm = -sin(data(iazm,i)) ! sin(azimuth) ! mccarty msq - else - cosazm = cos(data(iazm,i)) ! cos(azimuth) - sinazm = sin(data(iazm,i)) ! sin(azimuth) - endif - - dwwind=(ugesindw*sinazm+vgesindw*cosazm)*factw - - ddiff = data(ilob,i) - dwwind - -! Gross check using innovation normalized by error - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if(luse(i))awork(4) = awork(4) + one - error = zero - ratio_errors=zero - else - ratio_errors=ratio_errors/sqrt(dup(i)) - endif - - if (ratio_errors*error <= tiny_r_kind) muse(i) = .false. - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_dw_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_dw=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_dw*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - - -! Accumulate statistics for obs belonging to this task - if(muse(i))then - if(rwgt < one) awork(21) = awork(21)+one - jsig = dpres - jsig=max(1,min(jsig,nsig)) - awork(jsig+6*nsig+100)=awork(jsig+6*nsig+100)+val2*rat_err2 - awork(jsig+5*nsig+100)=awork(jsig+5*nsig+100)+one - awork(jsig+3*nsig+100)=awork(jsig+3*nsig+100)+valqc - endif - - -! Loop over pressure level groupings and obs to accumulate statistics -! as a function of observation type. - - do k = 1,npres_print - if(presw > ptop(k) .and. presw <= pbot(k)) then - ress =scale*ddiff - ressw=ress*ress - val2 =val*val - rat_err2 = ratio_errors**2 - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - - bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count - bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ddiff ! bias - bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 - bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty - end if - - end do - end if - - if (luse_obsdiag) then - obsdiags(i_dw_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_dw_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_dw_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(dwhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j,k) indices of guess gridpoint that bound obs location - my_head%dlev = dpres - my_head%factw= factw - call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) - - do j=1,8 - my_head%wij(j)=factw*my_head%wij(j) - end do - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2=ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%cosazm = cosazm ! v factor - my_head%sinazm = sinazm ! u factor - my_head%luse = luse(i) - - if(luse_obsdiag) then - my_head%diags => obsdiags(i_dw_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - my_head => null() - endif - -! Save select output for diagnostic file - if(conv_diagsave)then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = rmiss_single ! station elevation (meters) - rdiagbuf(6,ii) = presw ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = rmiss_single ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input=one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst - if (err_final>tiny_r_kind) errinv_final=one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error - rdiagbuf(16,ii) = errinv_final ! final inverse observation error - - rdiagbuf(17,ii) = data(ilob,i) ! observation - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis - rdiagbuf(19,ii) = data(ilob,i)-dwwind ! obs-ges w/o bias correction (future slot) - - rdiagbuf(20,ii) = factw ! 10m wind reduction factor - rdiagbuf(21,ii) = data(ielva,i)*rad2deg! elevation angle (degrees) - rdiagbuf(22,ii) = data(iazm,i)*rad2deg ! bearing or azimuth (degrees) - rdiagbuf(23,ii) = data(inls,i) ! number of laser shots - rdiagbuf(24,ii) = data(incls,i) ! number of cloud laser shots - rdiagbuf(25,ii) = data(iatd,i) ! atmospheric depth - rdiagbuf(26,ii) = data(ilob,i) ! line of sight component of wind orig. - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_dw_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_dw_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_dw_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_dw_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show('setupdw','diagsave:dw',i_dw_ob_type) - write(7)' dw',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::u', ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::v', ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get u ... - varname='u' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_u))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_u(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_u(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get v ... - varname='v' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_v))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_v(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_v(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_v )) deallocate(ges_v ) - if(allocated(ges_u )) deallocate(ges_u ) - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps)) deallocate(ges_ps) - end subroutine final_vars_ - -end subroutine setupdw diff --git a/src/setupgust.f90 b/src/setupgust.f90 deleted file mode 100644 index f59bc7577..000000000 --- a/src/setupgust.f90 +++ /dev/null @@ -1,787 +0,0 @@ -subroutine setupgust(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupgust compute rhs for conventional surface gust -! prgmmr: derber org: np23 date: 2004-07-20 -! -! abstract: For sea surface temperature observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2009-03-10 zhu -! 2011-02-18 zhu - update -! 2013-01-26 parrish - change from grdcrd to grdcrd1, -! tintrp2a to tintrp2a1, tintrp2a11 (to allow successful debug compile on WCOSS) -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-07-21 carley - ensure no division by 0 when calculating presw -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! before retuning to setuprhsall.f90 -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig,ges_lnprsl, & - geop_hgtl,sfcmod_gfs,sfcmod_mm5,comp_fact10 - use m_obsdiags, only: gusthead - use obsmod, only: rmiss_single,i_gust_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode, only: obsNode - use m_gustNode, only: gustNode - use m_obsLList, only: obsLlist_appendNode - use obsmod, only: obs_diag,bmiss,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig - use gridmod, only: get_ij,twodvar_regional - use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,rd,grav,& - two,cg_term,three,four,huge_single,r1000,r3600,& - grav_ratio,flattening,grav,deg2rad,grav_equator,somigliana, & - semi_major_axis,eccentricity - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a1,tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss - character(len=*),parameter:: myname='setupgust' - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) gustges,dlat,dlon,ddiff,dtime,error,r0_001,thirty - real(r_kind) scale,val2,rsig,rsigp,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc,rlow,rhgh,drpx - real(r_kind) term,rwgt - real(r_kind) cg_gust,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 - real(r_kind) presw,factw,dpres,sfcchk - real(r_kind) ratio_errors,tfact,fact,wflate,ten,psges,goverrd,zsges - real(r_kind) slat,sin2,termg,termr,termrg,pobl - real(r_kind) dz,zob,z1,z2,p1,p2,dz21,dlnp21,dstn - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final,skint,sfcr - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nsig)::prsltmp,zges - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,ihgt,igust,ipres,id,itime,ikx,imaxerr,iqc - integer(i_kind) iuse,ilate,ilone,istnelv,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,k1,k2,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc,iskint,iff10,isfcr - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(gustNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,:) :: ges_ps - real(r_kind),allocatable,dimension(:,:,:) :: ges_z - real(r_kind),allocatable,dimension(:,:,:) :: ges_gust - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - ihgt=5 ! index of observation elevation - igust=6 ! index of gust observation - id=7 ! index of station id - itime=8 ! index of observation time in data array - ikxx=9 ! index of ob type - imaxerr=10 ! index of gust max error - iqc=11 ! index of qulaity mark - iuse=12 ! index of use parameter - idomsfc=13 ! index of dominant surface type - iskint=14 ! index of surface skin temperature - iff10=15 ! index of 10 meter wind factor - isfcr=16 ! index of surface roughness - ilone=17 ! index of longitude (degrees) - ilate=18 ! index of latitude (degrees) - istnelv=19 ! index of station elevation (m) - iprvd=20 ! index of provider - isprvd=21 ! index of subprovider - - mm1=mype+1 - scale=one - rsig=nsig - thirty = 30.0_r_kind - ten = 10.0_r_kind - r0_001=0.001_r_kind - rsigp=rsig+one - goverrd=grav/rd - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - -! Check for missing data - if (.not. oneobtest) then - do i=1,nobs - if (data(igust,i) > r0_1_bmiss) then - muse(i)=.false. - data(igust,i)=rmiss_single ! for diag output - end if - end do - end if - -! Check for duplicate observations at same location - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=22 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - allocate(cprvstg(nobs),csprvstg(nobs)) - end if - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier,i) - isli=data(idomsfc,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_gust_ob_type,ibin)%head)) then - obsdiags(i_gust_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_gust_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupgust: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_gust_ob_type,ibin)%tail => obsdiags(i_gust_ob_type,ibin)%head - else - allocate(obsdiags(i_gust_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupgust: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_gust_ob_type,ibin)%tail => obsdiags(i_gust_ob_type,ibin)%tail%next - end if - obsdiags(i_gust_ob_type,ibin)%n_alloc = obsdiags(i_gust_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_gust_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_gust_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_gust_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_gust_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_gust_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_gust_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_gust_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_gust_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_gust_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_gust_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_gust_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_gust_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_gust_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_gust_ob_type,ibin)%tail)) then - obsdiags(i_gust_ob_type,ibin)%tail => obsdiags(i_gust_ob_type,ibin)%head - else - obsdiags(i_gust_ob_type,ibin)%tail => obsdiags(i_gust_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_gust_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_gust_ob_type,ibin)%tail)') - end if - if (obsdiags(i_gust_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupgust: index error' - call stop2(297) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Interpolate to get gust at obs location/time - call tintrp2a11(ges_gust,gustges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - -! Process observations with reported height - drpx = zero - dpres = data(ihgt,i) - dstn = data(istnelv,i) - -! Get guess surface elevation and geopotential height profile -! at observation location. - call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) -! Subtract off combination of surface station elevation and -! model elevation depending on how close to surface - fact = zero - if(dpres-dstn > 10._r_kind)then - if(dpres-dstn > 1000._r_kind)then - fact = one - else - fact=(dpres-dstn)/990._r_kind - end if - end if - dpres=dpres-(dstn+fact*(zsges-dstn)) - drpx=0.003*abs(dstn-zsges)*(one-fact) - - if (.not. twodvar_regional) then - call tintrp2a1(geop_hgtl,zges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) -! For observation reported with geometric height above sea level, -! convert geopotential to geometric height. -! Convert geopotential height at layer midpoints to geometric -! height using equations (17, 20, 23) in MJ Mahoney's note -! "A discussion of various measures of altitude" (2001). -! Available on the web at -! http://mtp.jpl.nasa.gov/notes/altitude/altitude.html -! -! termg = equation 17 -! termr = equation 21 -! termrg = first term in the denominator of equation 23 -! zges = equation 23 - - slat = data(ilate,i)*deg2rad - sin2 = sin(slat)*sin(slat) - termg = grav_equator * & - ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) - termr = semi_major_axis /(one + flattening + grav_ratio - & - two*flattening*sin2) - termrg = (termg/grav)*termr - do k=1,nsig - zges(k) = (termr*zges(k)) / (termrg-zges(k)) ! eq (23) - end do - else - zges(1) = ten - end if - -! Given observation height, (1) adjust 10 meter wind factor if -! necessary, (2) convert height to grid relative units, (3) compute -! compute observation pressure (for diagnostic purposes only), and -! (4) compute location of midpoint of first model layer above surface -! in grid relative units - -! Convert observation height (in dpres) from meters to grid relative -! units. Save the observation height in zob for later use. - zob = dpres - call grdcrd1(dpres,zges,nsig,1) - - if (zob >= zges(1)) then - factw=one - else - factw = data(iff10,i) - if(sfcmod_gfs .or. sfcmod_mm5) then - sfcr = data(isfcr,i) - skint = data(iskint,i) - call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) - end if - if (.not. twodvar_regional) then - if (zob <= ten) then - if(zob < ten)then - term = max(zob,zero)/ten - factw = term*factw - end if - else - term = (zges(1)-zob)/(zges(1)-ten) - factw = one-term+factw*term - end if - else - if(zob < ten)then - term = max(zob,zero)/ten - factw = term*factw - end if - end if - gustges=factw*gustges - endif - -! Compute observation pressure (only used for diagnostics & for type 2**) -! Get guess surface pressure and mid layer pressure -! at observation location. - if (ictype(ikx)>=280 .and. ictype(ikx)<290) then - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - if ((dpres-one) < tiny_r_kind) then - z1=zero; p1=log(psges) - z2=zges(1); p2=prsltmp(1) - elseif (dpres>nsig) then - z1=zges(nsig-1); p1=prsltmp(nsig-1) - z2=zges(nsig); p2=prsltmp(nsig) - drpx = 1.e6_r_kind - else - k=dpres - k1=min(max(1,k),nsig) - k2=max(1,min(k+1,nsig)) - z1=zges(k1); p1=prsltmp(k1) - z2=zges(k2); p2=prsltmp(k2) - endif - - dz21 = z2-z1 - if(dz21==zero)cycle - dlnp21 = p2-p1 - dz = zob-z1 - pobl = p1 + (dlnp21/dz21)*dz - presw = ten*exp(pobl) - else - presw = ten*exp(data(ipres,i)) - end if - - -! Determine location in terms of grid units for midpoint of -! first layer above surface - sfcchk=zero - call grdcrd1(sfcchk,zges,nsig,1) - -! Checks based on observation location relative to model surface and top - rlow=max(sfcchk-dpres,zero) - rhgh=max(dpres-r0_001-rsigp,zero) - if(luse(i))then - awork(1) = awork(1) + one - if(rlow/=zero) awork(2) = awork(2) + one - if(rhgh/=zero) awork(3) = awork(3) + one - end if - -! Adjust observation error -! ratio_errors=error/((data(ier,i)+adjustment)*sqrt(dup(i))) ! qc dependent adjustment - wflate=zero - if (ictype(ikx)==188 .or. ictype(ikx)==288 .or. ictype(ikx)==195 .or. ictype(ikx)==295) then !inflate Mesonet obs error for gusts<7.2m/s - if (data(igust,i)<7.2) then - wflate=4.0_r_kind*data(ier,i) - else - wflate=0.8_r_kind*data(ier,i) - end if - end if - ratio_errors=error/((data(ier,i)+drpx+wflate+1.0e6*rhgh+four*rlow)*sqrt(dup(i))) - error=one/error - -! Compute innovations - ddiff=data(igust,i)-gustges - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross check using innovation normalized by error - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - end if - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_gust_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_gust=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_gust*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - end if - ress = ddiff*scale - ressw2 = ress*ress - val2 = val*val - rat_err2 = ratio_errors**2 - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - if (abs(data(igust,i)-rmiss_single) >=tiny_r_kind) then - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - end if - - endif - - if (luse_obsdiag) then - obsdiags(i_gust_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_gust_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_gust_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(gusthead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - if(luse_obsdiag) then - my_head%diags => obsdiags(i_gust_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = presw ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(igust,i) ! GUST observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(igust,i)-gustges! obs-ges w/o bias correction (K) (future slot) - - rdiagbuf(20,ii) = factw ! 10m wind reduction factor - - rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(22,ii) = zsges ! model terrain at ob location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - - if (lobsdiagsave) then - ioff=ioff0 - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_gust_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_gust_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_gust_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_gust_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - - - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:gust',i_gust_ob_type) - write(7)'gst',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::gust' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get gust ... - varname='gust' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_gust))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_gust(size(rank2,1),size(rank2,2),nfldsig)) - ges_gust(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_gust(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps )) deallocate(ges_ps ) - if(allocated(ges_gust)) deallocate(ges_gust) - end subroutine final_vars_ - -end subroutine setupgust - diff --git a/src/setuphowv.f90 b/src/setuphowv.f90 deleted file mode 100644 index b93054f43..000000000 --- a/src/setuphowv.f90 +++ /dev/null @@ -1,620 +0,0 @@ -subroutine setuphowv(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuphowv compute rhs of oi for significant waver height -! prgmmr: pondeca org: np23 date: 2014-04-10 -! -! abstract: For significant waver height observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2014-04-10 pondeca -! 2015-03-11 pondeca - Modify for possibility of not using obsdiag -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2016-08-24 stelios - Added check for errors/=0.0 -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! before retuning to setuprhsall.f90 -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig - use m_obsdiags, only: howvhead - use m_obsNode , only: obsNode - use m_howvNode, only: howvNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: rmiss_single,i_howv_ob_type, & - obs_diag,obsdiags,lobsdiagsave,nobskeep,lobsdiag_allocated, & - time_offset,bmiss,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig,get_ij,twodvar_regional - use constants, only: zero,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & - two,cg_term,huge_single,three - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_7=0.7_r_kind - - character(len=*),parameter:: myname='setuphowv' - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) howvges,dlat,dlon,ddiff,dtime,error - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,rwgt - real(r_kind) cg_howv,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,ipres,ihowv,id,itime,ikx,iqc,iskint,iff10 - integer(i_kind) ier2,iuse,ilate,ilone,istnelv,isfcr,iobshgt,izz,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(howvNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !might need at some point - real(r_kind),allocatable,dimension(:,:,:) :: ges_z !might need at some point - real(r_kind),allocatable,dimension(:,:,:) :: ges_howv - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - ihowv=5 ! index of howv observation - id=6 ! index of station id - itime=7 ! index of observation time in data array - ikxx=8 ! index of ob type - iqc=9 ! index of quality mark - ier2=10 ! index of original obs error - iuse=11 ! index of use parameter - idomsfc=12 ! index of dominant surface type - iskint=13 ! index of surface skin temperature - iff10=14 ! index of 10 meter wind factor - isfcr=15 ! index of surface roughness - ilone=16 ! index of longitude (degrees) - ilate=17 ! index of latitude (degrees) - istnelv=18 ! index of station elevation (m) - iobshgt=19 ! index of observation height (m) - izz=20 ! index of surface height - iprvd=21 ! index of observation provider - isprvd=22 ! index of observation subprovider - - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=19 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - - mm1=mype+1 - scale=one - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier2,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_howv_ob_type,ibin)%head)) then - obsdiags(i_howv_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_howv_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuphowv: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_howv_ob_type,ibin)%tail => obsdiags(i_howv_ob_type,ibin)%head - else - allocate(obsdiags(i_howv_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuphowv: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_howv_ob_type,ibin)%tail => obsdiags(i_howv_ob_type,ibin)%tail%next - end if - obsdiags(i_howv_ob_type,ibin)%n_alloc = obsdiags(i_howv_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_howv_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_howv_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_howv_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_howv_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_howv_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_howv_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_howv_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_howv_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_howv_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_howv_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_howv_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_howv_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_howv_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_howv_ob_type,ibin)%tail)) then - obsdiags(i_howv_ob_type,ibin)%tail => obsdiags(i_howv_ob_type,ibin)%head - else - obsdiags(i_howv_ob_type,ibin)%tail => obsdiags(i_howv_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_howv_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_howv_ob_type,ibin)%tail)') - endif - if (obsdiags(i_howv_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuphowv: index error' - call stop2(297) - end if - end if - end if - - if(.not.in_curbin) cycle - -! Interpolate guess howv to observation location and time - call tintrp2a11(ges_howv,howvges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - ddiff=data(ihowv,i)-howvges - -! Adjust observation error - if (error<=tiny_r_kind.and.data(ier,i)<=tiny_r_kind) cycle !#ww3 - ratio_errors=error/data(ier,i) - error=one/error - -! Gross error checks - - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - -! modify gross check limit for quality mark=3 - if(data(iqc,i) == three ) then - qcgross=r0_7*cgross(ikx) - else - qcgross=cgross(ikx) - endif - - if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else - ratio_errors=ratio_errors/sqrt(dup(i)) - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - muse(i) = .true. - endif - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_howv_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_howv=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_howv*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - nn=1 - else - nn=2 !rejected obs - if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs - end if - - ress = ddiff*scale - ressw2 = ress*ress - - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - endif - -! Fill obs diagnostics structure - if(luse_obsdiag)then - obsdiags(i_howv_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_howv_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_howv_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(howvhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_howv_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - end if - - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = r10*data(ipres,i) ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(ihowv,i) ! HOWV observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(ihowv,i)-howvges! obs-ges w/o bias correction (K) (future slot) - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_howv_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_howv_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_howv_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_howv_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:howv',i_howv_ob_type) - write(7)'hwv',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::howv' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get howv ... - varname='howv' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_howv))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_howv(size(rank2,1),size(rank2,2),nfldsig)) - ges_howv(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_howv(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps )) deallocate(ges_ps ) - if(allocated(ges_howv)) deallocate(ges_howv) - end subroutine final_vars_ - -end subroutine setuphowv - diff --git a/src/setuplcbas.f90 b/src/setuplcbas.f90 deleted file mode 100644 index 570ad4533..000000000 --- a/src/setuplcbas.f90 +++ /dev/null @@ -1,620 +0,0 @@ -subroutine setuplcbas(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuplcbas compute rhs for cloud base height of lowest cloud seen -! prgmmr: derber org: np23 date: 2004-07-20 -! -! abstract: For sea surface temperature observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2012-01-29 zhu -! 2014-06-19 carley - update for metguess bundle, change tintrp2a to tintrp2a11 -! for debug compile on WCOSS, write sensitivity slot indicator -! (ioff) to header of diagfile, remove unused vars -! 2015-03-11 pondeca - Modify for possibility of not using obsdiag -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig,wgt_lcbas - use m_obsdiags, only: lcbashead - use obsmod, only: rmiss_single,i_lcbas_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode , only: obsNode - use m_lcbasNode, only: lcbasNode - use m_obsLList , only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig - use gridmod, only: get_ij - use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,& - two,cg_term,huge_single,r1000 - use jfunc, only: jiter,last,miter,jiterstart,R_option - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - - - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local variables - real(r_kind), parameter:: miss_obs=10.e10_r_kind - - real(r_double) rstation_id - - real(r_kind) lcbasges,dlat,dlon,ddiff,dtime,error - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc,drpx - real(r_kind) term,rwgt - real(r_kind) cg_lcbas,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 - real(r_kind) ratio_errors,tfact,zsges - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,izz,ihgt,ilcbas,id,itime,ikx,iqc,iceil - integer(i_kind) iuse,ilate,ilone,istnelv,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc,iskint,iff10,isfcr - integer(i_kind) jlat,jlon - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin,proceed - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode ),pointer:: my_node - type(lcbasNode),pointer:: my_head - type(obs_diag ),pointer:: my_diag - character(len=*),parameter:: myname='setuplcbas' - - real(r_kind),allocatable,dimension(:,:,:) :: ges_lcbas - real(r_kind),allocatable,dimension(:,:,:) :: ges_z - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - print *, 'Whoa! We have some missing metguess variables in setuplcbas.f90....returning to setuprhsall.f90 after advancing through input file' - read(lunin)data,luse,ioid - return ! not all vars available, simply return - end if - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ilcbas=4 ! index of lcbas observation - id=5 ! index of station id - itime=6 ! index of observation time in data array - ikxx=7 ! index of ob type - iqc=8 ! index of qulaity mark - iuse=9 ! index of use parameter - idomsfc=10 ! index of dominant surface type - iskint=11 ! index of surface skin temperature - iff10=12 ! index of 10 meter wind factor - isfcr=13 ! index of surface roughness - ilone=14 ! index of longitude (degrees) - ilate=15 ! index of latitude (degrees) - istnelv=16 ! index of station elevation (m) - ihgt=17 ! index of obs height (m) - izz=18 ! index of model terrain height at ob location - iceil=19 ! index of cloud ceiling obs - iprvd=22 ! index of provider - isprvd=23 ! index of subprovider - - mm1=mype+1 - scale=one - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - -! Check for missing data - if (.not. oneobtest) then - do i=1,nobs - if (abs(data(ilcbas,i)-miss_obs)<100.0_r_kind) then - muse(i)=.false. - data(ilcbas,i)=rmiss_single ! for diag output - end if - end do - end if - -! Check for duplicate observations at same location - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < 2000.0_r_kind .and. data(ier,l) < 2000.0_r_kind .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - nreal=23 - ioff0=nreal - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - allocate(cprvstg(nobs),csprvstg(nobs)) - end if - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier,i) - isli=data(idomsfc,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_lcbas_ob_type,ibin)%head)) then - obsdiags(i_lcbas_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_lcbas_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuplcbas: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_lcbas_ob_type,ibin)%tail => obsdiags(i_lcbas_ob_type,ibin)%head - else - allocate(obsdiags(i_lcbas_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuplcbas: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_lcbas_ob_type,ibin)%tail => obsdiags(i_lcbas_ob_type,ibin)%tail%next - end if - obsdiags(i_lcbas_ob_type,ibin)%n_alloc = obsdiags(i_lcbas_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_lcbas_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_lcbas_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_lcbas_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_lcbas_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_lcbas_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_lcbas_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_lcbas_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_lcbas_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_lcbas_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_lcbas_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_lcbas_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_lcbas_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_lcbas_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_lcbas_ob_type,ibin)%tail)) then - obsdiags(i_lcbas_ob_type,ibin)%tail => obsdiags(i_lcbas_ob_type,ibin)%head - else - obsdiags(i_lcbas_ob_type,ibin)%tail => obsdiags(i_lcbas_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_lcbas_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_lcbas_ob_type,ibin)%tail)') - end if - if (obsdiags(i_lcbas_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuplcbas: index error' - call stop2(297) - end if - end if - end if - - if(.not.in_curbin) cycle - -! Interpolate to get lcbas at obs location/time (MSL) - call tintrp2a11(ges_lcbas,lcbasges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - -! Get guess sfc hght at obs location - call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - if(luse(i))then - awork(1) = awork(1) + one - end if - -! Adjust observation error - drpx=0.05_r_kind*abs(data(istnelv,i)-zsges) - ratio_errors=error/((data(ier,i)+drpx)*sqrt(dup(i))) - error=one/error - -! Compute innovations - ddiff=data(ilcbas,i)-lcbasges - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross check using innovation normalized by error - if (abs(data(ilcbas,i)-rmiss_single) >= tiny_r_kind ) then - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - end if - else - error = zero - ratio_errors=zero - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_lcbas_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_lcbas=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_lcbas*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - end if - ress = ddiff*scale - ressw2 = ress*ress - val2 = val*val - rat_err2 = ratio_errors**2 - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - if (abs(data(ilcbas,i)-rmiss_single) >=tiny_r_kind) then - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - end if - - endif - - if(luse_obsdiag)then - obsdiags(i_lcbas_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_lcbas_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_lcbas_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(lcbashead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij,jlat,jlon) - - if (jiter==jiterstart .and. R_option) then - wgt_lcbas(jlat,jlon) =wgt_lcbas(jlat,jlon)+my_head%wij(1) - wgt_lcbas(jlat+1,jlon) =wgt_lcbas(jlat+1,jlon)+my_head%wij(2) - wgt_lcbas(jlat,jlon+1) =wgt_lcbas(jlat,jlon+1)+my_head%wij(3) - wgt_lcbas(jlat+1,jlon+1)=wgt_lcbas(jlat+1,jlon+1)+my_head%wij(4) - end if - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_lcbas_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - end if - - my_head => null() - endif - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(ilcbas,i) ! lcbas observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(ilcbas,i)-lcbasges! obs-ges w/o bias correction (K) (future slot) - - rdiagbuf(20,ii) = rmiss_single ! type of measurement - - rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(22,ii) = data(izz,i) ! model terrain at observation location - if (abs(data(iceil,i)-miss_obs)<100.0_r_kind) then - rdiagbuf(23,ii) = data(iceil,i) ! cloud ceiling - else - rdiagbuf(23,ii) = rmiss_single - end if - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - - if (lobsdiagsave) then - ioff=ioff0 - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_lcbas_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_lcbas_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_lcbas_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_lcbas_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - - end do - - -! Write information to diagnostic file - if(conv_diagsave)then - call dtime_show(myname,'diagsave:lcbas',i_lcbas_ob_type) - write(7)'lcb',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - end if -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::lcbas', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get lcbas ... - varname='lcbas' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_lcbas))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_lcbas(size(rank2,1),size(rank2,2),nfldsig)) - ges_lcbas(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_lcbas(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_lcbas)) deallocate(ges_lcbas) - end subroutine final_vars_ -end subroutine setuplcbas - diff --git a/src/setupmitm.f90 b/src/setupmitm.f90 deleted file mode 100644 index c43869a07..000000000 --- a/src/setupmitm.f90 +++ /dev/null @@ -1,625 +0,0 @@ -subroutine setupmitm(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupmitm compute rhs of oi for conventional daily minimum temperature -! prgmmr: pondeca org: np23 date: 2014-04-10 -! -! abstract: For daily minimum temperature observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2014-04-10 pondeca -! 2015-03-11 pondeca - Modify for possibility of not using obsdiag -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! before retuning to setuprhsall.f90 -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig - use m_obsdiags, only: mitmhead - use m_obsNode , only: obsNode - use m_mitmNode, only: mitmNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: rmiss_single,i_mitm_ob_type, & - obs_diag,obsdiags,lobsdiagsave,nobskeep,lobsdiag_allocated, & - time_offset,bmiss,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig,get_ij,twodvar_regional - use constants, only: zero,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & - two,cg_term,huge_single,three - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_7=0.7_r_kind - - character(len=*),parameter:: myname='setupmitm' - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) mitmges,dlat,dlon,ddiff,dtime,error - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,rwgt - real(r_kind) cg_mitm,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,ipres,imitm,id,itime,ikx,iqt,iqc,iskint,iff10 - integer(i_kind) ier2,iuse,ilate,ilone,istnelv,isfcr,iobshgt,izz,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode), pointer:: my_node - type(mitmNode), pointer:: my_head - type(obs_diag), pointer:: my_diag - - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !will need at some point - real(r_kind),allocatable,dimension(:,:,:) :: ges_z !will probably need at some point - real(r_kind),allocatable,dimension(:,:,:) :: ges_mitm - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - imitm=5 ! index of mitm observation - id=6 ! index of station id - itime=7 ! index of observation time in data array - ikxx=8 ! index of ob type - iqt=9 ! index of flag indicating if moisture ob available - iqc=10 ! index of quality mark - ier2=11 ! index of original obs error - iuse=12 ! index of use parameter - idomsfc=13 ! index of dominant surface type - iskint=14 ! index of surface skin temperature - iff10=15 ! index of 10 meter wind factor - isfcr=16 ! index of surface roughness - ilone=17 ! index of longitude (degrees) - ilate=18 ! index of latitude (degrees) - istnelv=19 ! index of station elevation (m) - iobshgt=20 ! index of observation height (m) - izz=21 ! index of surface height - iprvd=22 ! index of observation provider - isprvd=23 ! index of observation subprovider - - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=19 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - - mm1=mype+1 - scale=one - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier2,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_mitm_ob_type,ibin)%head)) then - obsdiags(i_mitm_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_mitm_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupmitm: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_mitm_ob_type,ibin)%tail => obsdiags(i_mitm_ob_type,ibin)%head - else - allocate(obsdiags(i_mitm_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupmitm: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_mitm_ob_type,ibin)%tail => obsdiags(i_mitm_ob_type,ibin)%tail%next - end if - obsdiags(i_mitm_ob_type,ibin)%n_alloc = obsdiags(i_mitm_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_mitm_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_mitm_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_mitm_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_mitm_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_mitm_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_mitm_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_mitm_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_mitm_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_mitm_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_mitm_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_mitm_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_mitm_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_mitm_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_mitm_ob_type,ibin)%tail)) then - obsdiags(i_mitm_ob_type,ibin)%tail => obsdiags(i_mitm_ob_type,ibin)%head - else - obsdiags(i_mitm_ob_type,ibin)%tail => obsdiags(i_mitm_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_mitm_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_mitm_ob_type,ibin)%tail)') - end if - if (obsdiags(i_mitm_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupmitm: index error' - call stop2(297) - end if - end if - end if - - if(.not.in_curbin) cycle - -! Interpolate guess mitm to observation location and time - call tintrp2a11(ges_mitm,mitmges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - ddiff=data(imitm,i)-mitmges - -! Adjust observation error - ratio_errors=error/data(ier,i) - error=one/error - -! Gross error checks - - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - -! modify gross check limit for quality mark=3 - if(data(iqc,i) == three ) then - qcgross=r0_7*cgross(ikx) - else - qcgross=cgross(ikx) - endif - - if (twodvar_regional) then - if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) & - qcgross=three*cgross(ikx) - endif - - if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else - ratio_errors=ratio_errors/sqrt(dup(i)) - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - muse(i) = .true. - endif - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_mitm_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_mitm=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_mitm*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - nn=1 - else - nn=2 !rejected obs - if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs - end if - - ress = ddiff*scale - ressw2 = ress*ress - - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - endif - -! Fill obs diagnostics structure - if(luse_obsdiag)then - obsdiags(i_mitm_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_mitm_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_mitm_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(mitmhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_mitm_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - end if - - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = r10*exp(data(ipres,i)) ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(imitm,i) ! MITM observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(imitm,i)-mitmges! obs-ges w/o bias correction (K) (future slot) - - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_mitm_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_mitm_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_mitm_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_mitm_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:mitm',i_mitm_ob_type) - write(7)'mit',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::mitm' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get mitm ... - varname='mitm' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_mitm))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_mitm(size(rank2,1),size(rank2,2),nfldsig)) - ges_mitm(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_mitm(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps )) deallocate(ges_ps ) - if(allocated(ges_mitm)) deallocate(ges_mitm) - end subroutine final_vars_ - -end subroutine setupmitm - diff --git a/src/setupmxtm.f90 b/src/setupmxtm.f90 deleted file mode 100644 index c57a4bb48..000000000 --- a/src/setupmxtm.f90 +++ /dev/null @@ -1,625 +0,0 @@ -subroutine setupmxtm(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupmxtm compute rhs of oi for conventional daily maximum temperature -! prgmmr: pondeca org: np23 date: 2014-04-10 -! -! abstract: For daily maximum temperature observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2014-04-10 pondeca -! 2015-03-11 pondeca - Modify for possibility of not using obsdiag -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! before retuning to setuprhsall.f90 -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig - use m_obsdiags, only: mxtmhead - use m_obsNode , only: obsNode - use m_mxtmNode, only: mxtmNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: rmiss_single,i_mxtm_ob_type, & - obs_diag,obsdiags,lobsdiagsave,nobskeep,lobsdiag_allocated, & - time_offset,bmiss,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig,get_ij,twodvar_regional - use constants, only: zero,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & - two,cg_term,huge_single,three - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_7=0.7_r_kind - - character(len=*),parameter:: myname='setupmxtm' - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) mxtmges,dlat,dlon,ddiff,dtime,error - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,rwgt - real(r_kind) cg_mxtm,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,ipres,imxtm,id,itime,ikx,iqt,iqc,iskint,iff10 - integer(i_kind) ier2,iuse,ilate,ilone,istnelv,isfcr,iobshgt,izz,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode), pointer:: my_node - type(mxtmNode), pointer:: my_head - type(obs_diag), pointer:: my_diag - - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !will need at some point - real(r_kind),allocatable,dimension(:,:,:) :: ges_z !will probably need at some point - real(r_kind),allocatable,dimension(:,:,:) :: ges_mxtm - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - imxtm=5 ! index of mxtm observation - id=6 ! index of station id - itime=7 ! index of observation time in data array - ikxx=8 ! index of ob type - iqt=9 ! index of flag indicating if moisture ob available - iqc=10 ! index of quality mark - ier2=11 ! index of original obs error - iuse=12 ! index of use parameter - idomsfc=13 ! index of dominant surface type - iskint=14 ! index of surface skin temperature - iff10=15 ! index of 10 meter wind factor - isfcr=16 ! index of surface roughness - ilone=17 ! index of longitude (degrees) - ilate=18 ! index of latitude (degrees) - istnelv=19 ! index of station elevation (m) - iobshgt=20 ! index of observation height (m) - izz=21 ! index of surface height - iprvd=22 ! index of observation provider - isprvd=23 ! index of observation subprovider - - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=19 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - - mm1=mype+1 - scale=one - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier2,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_mxtm_ob_type,ibin)%head)) then - obsdiags(i_mxtm_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_mxtm_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupmxtm: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_mxtm_ob_type,ibin)%tail => obsdiags(i_mxtm_ob_type,ibin)%head - else - allocate(obsdiags(i_mxtm_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupmxtm: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_mxtm_ob_type,ibin)%tail => obsdiags(i_mxtm_ob_type,ibin)%tail%next - end if - obsdiags(i_mxtm_ob_type,ibin)%n_alloc = obsdiags(i_mxtm_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_mxtm_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_mxtm_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_mxtm_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_mxtm_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_mxtm_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_mxtm_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_mxtm_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_mxtm_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_mxtm_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_mxtm_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_mxtm_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_mxtm_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_mxtm_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_mxtm_ob_type,ibin)%tail)) then - obsdiags(i_mxtm_ob_type,ibin)%tail => obsdiags(i_mxtm_ob_type,ibin)%head - else - obsdiags(i_mxtm_ob_type,ibin)%tail => obsdiags(i_mxtm_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_mxtm_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_mxtm_ob_type,ibin)%tail)') - end if - if (obsdiags(i_mxtm_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupmxtm: index error' - call stop2(297) - end if - end if - end if - - if(.not.in_curbin) cycle - -! Interpolate guess mxtm to observation location and time - call tintrp2a11(ges_mxtm,mxtmges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - ddiff=data(imxtm,i)-mxtmges - -! Adjust observation error - ratio_errors=error/data(ier,i) - error=one/error - -! Gross error checks - - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - -! modify gross check limit for quality mark=3 - if(data(iqc,i) == three ) then - qcgross=r0_7*cgross(ikx) - else - qcgross=cgross(ikx) - endif - - if (twodvar_regional) then - if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) & - qcgross=three*cgross(ikx) - endif - - if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else - ratio_errors=ratio_errors/sqrt(dup(i)) - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - muse(i) = .true. - endif - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_mxtm_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_mxtm=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_mxtm*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - nn=1 - else - nn=2 !rejected obs - if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs - end if - - ress = ddiff*scale - ressw2 = ress*ress - - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - endif - -! Fill obs diagnostics structure - if(luse_obsdiag)then - obsdiags(i_mxtm_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_mxtm_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_mxtm_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(mxtmhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_mxtm_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - end if - - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = r10*exp(data(ipres,i)) ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(imxtm,i) ! MXTM observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(imxtm,i)-mxtmges! obs-ges w/o bias correction (K) (future slot) - - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_mxtm_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_mxtm_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_mxtm_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_mxtm_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:mxtm',i_mxtm_ob_type) - write(7)'mxt',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::mxtm' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get mxtm ... - varname='mxtm' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_mxtm))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_mxtm(size(rank2,1),size(rank2,2),nfldsig)) - ges_mxtm(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_mxtm(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps )) deallocate(ges_ps ) - if(allocated(ges_mxtm)) deallocate(ges_mxtm) - end subroutine final_vars_ - -end subroutine setupmxtm - diff --git a/src/setupoz.f90 b/src/setupoz.f90 deleted file mode 100644 index ed393d0c1..000000000 --- a/src/setupoz.f90 +++ /dev/null @@ -1,1448 +0,0 @@ - -subroutine setupozlay(lunin,mype,stats_oz,nlevs,nreal,nobs,& - obstype,isis,is,ozone_diagsave,init_pass) - -!$$$ subprogram documentation block -! . . . -! subprogram: setupozlay --- Compute rhs of oi for sbuv ozone obs -! -! prgrmmr: parrish org: np22 date: 1990-10-06 -! -! abstract: For sbuv ozone observations (layer amounts and total -! column, this routine -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 1990-10-06 parrish -! 1998-04-10 weiyu yang -! 1999-03-01 wu, ozone processing moved into setuprhs from setupoz -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2003-12-23 kleist - modify to use pressure as vertical coordinate -! 2004-05-28 kleist - subroutine call update -! 2004-06-17 treadon - update documentation -! 2004-07-08 todling - added only's; removed gridmod; bug fix in diag -! 2004-07-15 todling - protex-compliant prologue; added intent's -! 2004-10-06 parrish - increase size of stats_oz for nonlinear qc, -! add nonlin qc penalty calc and obs count -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - add outer loop number to name of diagnostic file -! 2005-03-02 dee - reorganize diagnostic file writes so that -! concatenated files are self-contained -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-03-16 derber - change call to sproz to save observation time -! 2005-04-11 treadon - add logical to toggle on/off nonlinear qc code -! 2005-05-18 wu - add use of OMI total ozone data -! 2005-09-22 derber - modify extensively - combine with sproz - no change -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-07 treadon - fix bug in increment of ii -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2006-01-09 treadon - remove unused variables -! 2006-02-03 derber - modify for new obs control -! 2006-02-17 treadon - correct bug when processing data not assimilated -! 2006-03-21 treadon - add option to perturb observation -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - unify NL qc -! 2007-03-09 su - remove option to perturb observation -! 2007-03-19 tremolet - binning of observations -! 2007-05-30 h.liu - include rozcon with interpolation weights -! 2007-06-08 kleist/treadon - add prefix (task id or path) to diag_ozone_file -! 2007-06-05 tremolet - add observation diagnostics structure -! 2008-05-23 safford - add subprogram doc block, rm unused uses and vars -! 2008-01-20 todling - add obsdiag info to diag files -! 2009-01-08 todling - re-implemented obsdiag/tail -! 2009-10-19 guo - changed for multi-pass setup with dtime_check() and new -! arguments init_pass and last_pass. -! 2009-12-08 guo - cleaned diag output rewind with open(position='rewind') -! 2011-12-07 todling - bug fix: need luse check when saving obssens -! 2012-09-10 wargan/guo - add hooks for omieff" -! 2013-01-26 parrish - change from grdcrd to grdcrd1, tintrp2a to tintrp2a1, intrp2a to intrp2a1, -! intrp3oz to intrp3oz1. (to allow successful debug compile on WCOSS) -! 2013-09-10 guo - patched to take reference pressure from the observation -! 2013-10-19 todling - metguess now holds background -! 2013-11-26 guo - removed nkeep==0 escaping to allow more than one obstype sources. -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nlevs - number of levels (layer amounts + total column) per obs -! nreal - number of pieces of non-ozone info (location, time, etc) per obs -! nobs - number of observations -! isis - sensor/instrument/satellite id -! is - integer(i_kind) counter for number of obs types to process -! obstype - type of ozone obs -! ozone_diagsave - switch on diagnostic output (.false.=no output) -! stats_oz - sums for various statistics as a function of level -! -! output argument list: -! stats_oz - sums for various statistics as a function of level -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq HP -! -!$$$ end documentation block - -! !USES: - - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,i_kind - - use constants, only : zero,half,one,two,tiny_r_kind - use constants, only : rozcon,cg_term,wgtlim,h300,r10 - - use m_obsdiags, only : ozhead - use obsmod, only : i_oz_ob_type,dplat,nobskeep - use obsmod, only : mype_diaghdr,dirname,time_offset,ianldate - use obsmod, only : obsdiags,lobsdiag_allocated,lobsdiagsave - use m_obsNode, only: obsNode - use m_ozNode, only : ozNode, ozNode_typecast - use m_obsLList, only : obsLList_appendNode - use m_obsLList, only : obsLList_tailNode - use obsmod, only : nloz_omi - use obsmod, only : obs_diag,luse_obsdiag - - use gsi_4dvar, only: nobs_bins,hr_obsbin - - use gridmod, only : get_ij,nsig - - use guess_grids, only : nfldsig,ges_prsi,ntguessig,hrdifsig - - use ozinfo, only : jpch_oz,error_oz,pob_oz,gross_oz,nusis_oz - use ozinfo, only : iuse_oz,b_oz,pg_oz - - use jfunc, only : jiter,last,miter - - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! !INPUT PARAMETERS: - - integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations - integer(i_kind) , intent(in ) :: mype ! mpi task id - integer(i_kind) , intent(in ) :: nlevs ! number of levels (layer amounts + total column) per obs - integer(i_kind) , intent(in ) :: nreal ! number of pieces of non-ozone info (location, time, etc) per obs - integer(i_kind) , intent(in ) :: nobs ! number of observations - character(20) , intent(in ) :: isis ! sensor/instrument/satellite id - integer(i_kind) , intent(in ) :: is ! integer(i_kind) counter for number of obs types to process - - character(10) , intent(in ) :: obstype ! type of ozone obs - logical , intent(in ) :: ozone_diagsave ! switch on diagnostic output (.false.=no output) - logical , intent(in ) :: init_pass ! state of "setup" processing - -! !INPUT/OUTPUT PARAMETERS: - - real(r_kind),dimension(9,jpch_oz), intent(inout) :: stats_oz ! sums for various statistics as - ! a function of level -!------------------------------------------------------------------------- - -! Declare local parameters - integer(i_kind),parameter:: iint=1 - integer(i_kind),parameter:: ireal=3 - real(r_kind),parameter:: rmiss = -9999.9_r_kind - character(len=*),parameter:: myname="setupozlay" - -! Declare external calls for code analysis - external:: intrp2a1 - external:: tintrp2a1 - external:: intrp3oz1 - external:: grdcrd1 - external:: stop2 - -! Declare local variables - - real(r_kind) ozobs,omg,rat_err2,dlat,dtime,dlon - real(r_kind) cg_oz,wgross,wnotgross,wgt,arg,exp_arg,term - real(r_kind) psi,errorinv - real(r_kind),dimension(nlevs):: ozges,varinv3,ozone_inv - real(r_kind),dimension(nlevs):: ratio_errors,error - real(r_kind),dimension(nlevs-1):: ozp - real(r_kind),dimension(nloz_omi) :: ozp_omi - real(r_kind),dimension(nlevs):: pobs,gross,tnoise - real(r_kind),dimension(nreal+nlevs,nobs):: data - real(r_kind),dimension(nsig+1)::prsitmp - real(r_single),dimension(nlevs):: pob4,grs4,err4 - real(r_single),dimension(ireal,nobs):: diagbuf - real(r_single),allocatable,dimension(:,:,:)::rdiagbuf - real(r_kind),dimension(nloz_omi):: apriori, efficiency,pob_oz_omi - real(r_kind),dimension(nloz_omi+1):: ozges1 - - integer(i_kind) i,nlev,ii,jj,iextra,istat,ibin, kk - integer(i_kind) k,j,nz,jc,idia,irdim1,istatus - integer(i_kind) ioff,itoss,ikeep,ierror_toq,ierror_poq - integer(i_kind) isolz,ifovn,itoqf - integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,itoq,ipoq - integer(i_kind),dimension(iint,nobs):: idiagbuf - integer(i_kind),dimension(nlevs):: ipos,iouse,ikeepk - - real(r_kind),dimension(4):: tempwij - integer(i_kind) nlevp,nlayers - - character(12) string - character(10) filex - character(128) diag_ozone_file - - logical:: ozdiagexist - logical,dimension(nobs):: luse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical:: l_may_be_passive, proceed - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(ozNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_oz - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 - - mm1=mype+1 - - -! -!********************************************************************************* -! Initialize arrays - do j=1,nlevs - ipos(j)=0 - iouse(j)=-2 - tnoise(j)=1.e10_r_kind - gross(j)=1.e10_r_kind - pobs(j)=1.e10_r_kind - end do - - if(ozone_diagsave)then - irdim1=6 - if(lobsdiagsave) irdim1=irdim1+4*miter+1 - allocate(rdiagbuf(irdim1,nlevs,nobs)) - end if - -! Locate data for satellite in ozinfo arrays - itoss =1 - l_may_be_passive=.false. - jc=0 - do j=1,jpch_oz - if (isis == nusis_oz(j)) then - jc=jc+1 - if (jc > nlevs) then - write(6,*)'SETUPOZ: ***ERROR*** in level numbers, jc,nlevs=',jc,nlevs,& - ' ***STOP IN SETUPOZ***' - call stop2(71) - endif - ipos(jc)=j - - iouse(jc)=iuse_oz(j) - tnoise(jc)=error_oz(j) - gross(jc)=min(r10*gross_oz(j),h300) - if (obstype == 'sbuv2' ) then - pobs(jc)=pob_oz(j) * 1.01325_r_kind - else - pobs(jc)=pob_oz(j) - endif - - if (iouse(jc)<-1 .or. (iouse(jc)==-1 .and. & - .not.ozone_diagsave)) then - tnoise(jc)=1.e10_r_kind - gross(jc) =1.e10_r_kind - endif - if (iouse(jc)>-1) l_may_be_passive=.true. - if (tnoise(jc)<1.e4_r_kind) itoss=0 - endif - end do - nlev=jc - -! Handle error conditions - if (nlevs>nlev) write(6,*)'SETUPOZ: level number reduced for ',obstype,' ', & - nlevs,' --> ',nlev - if (nlev == 0) then - if (mype==0) write(6,*)'SETUPOZ: no levels found for ',isis - if (nobs>0) read(lunin) - goto 135 - endif - if (itoss==1) then - if (mype==0) write(6,*)'SETUPOZ: all obs variances > 1.e4. Do not use ',& - 'data from satellite ',isis - if (nobs>0) read(lunin) - goto 135 - endif - -! Read and transform ozone data - read(lunin) data,luse,ioid - -! index information for data array (see reading routine) - itime=2 ! index of analysis relative obs time - ilon=3 ! index of grid relative obs location (x) - ilat=4 ! index of grid relative obs location (y) - ilone=5 ! index of earth relative longitude (degrees) - ilate=6 ! index of earth relative latitude (degrees) - itoq=7 ! index of total ozone error flag (sbuv2 only) - ipoq=8 ! index of profile ozone error flag (sbuv2 only) - isolz=8 ! index of solar zenith angle (gome and omi only) - itoqf=9 ! index of row anomaly (omi only) - ifovn=14 ! index of scan position (gome and omi only) - - -! If requested, save data for diagnostic ouput - if(ozone_diagsave)ii=0 - -! Convert observation (lat,lon) from earth to grid relative values - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - dtime=data(itime,i) - - if (obstype == 'sbuv2' ) then - if (nobskeep>0) then -! write(6,*)'setupozlay: nobskeep',nobskeep - call stop2(259) - end if - - ierror_toq = nint(data(itoq,i)) - ierror_poq = nint(data(ipoq,i)) - -! Note: ozp as log(pobs) - call intrp2a1(ges_prsi(1,1,1,ntguessig),prsitmp,dlat,& - dlon,nsig+1,mype) - -! Map observation pressure to guess vertical coordinate - psi=one/(prsitmp(1)*r10) ! factor of 10 converts to hPa - do nz=1,nlevs-1 - if ((pobs(nz)*psi) < one) then - ozp(nz) = pobs(nz)/r10 - else - ozp(nz) = prsitmp(1) - end if - call grdcrd1(ozp(nz),prsitmp,nsig+1,-1) - enddo - end if - - if (obstype == 'omieff' .or. obstype == 'tomseff') then - pob_oz_omi(nloz_omi) = 1000.0_r_kind* 1.01325_r_kind - do j=nloz_omi-1, 1, -1 - pob_oz_omi(j) = pob_oz_omi(j+1)/2.0 - enddo - call intrp2a1(ges_prsi(1,1,1,ntguessig),prsitmp,dlat,& - dlon,nsig+1,mype) - -! Map observation pressure to guess vertical coordinate - psi=one/(prsitmp(1)*r10) ! factor of 10 converts to hPa - do nz=1,nloz_omi - 1 - if ((pob_oz_omi(nz)*psi) < one) then - ozp_omi(nz) = pob_oz_omi(nz)/r10 - else - ozp_omi(nz) = prsitmp(1) - end if - call grdcrd1(ozp_omi(nz),prsitmp,nsig+1,-1) - enddo - ozp_omi(nloz_omi) = prsitmp(1) - call grdcrd1(ozp_omi(nloz_omi),prsitmp,nsig+1,-1) - end if - - if (obstype /= 'omieff' .and. obstype /= 'tomseff') then - call intrp3oz1(ges_oz,ozges,dlat,dlon,ozp,dtime,& - nlevs,mype) - endif - - - - if(ozone_diagsave .and. luse(i))then - ii=ii+1 - idiagbuf(1,ii)=mype ! mpi task number - diagbuf(1,ii) = data(ilate,i) ! lat (degree) - diagbuf(2,ii) = data(ilone,i) ! lon (degree) - diagbuf(3,ii) = data(itime,i)-time_offset ! time (hours relative to analysis) - endif - -! Interpolate interface pressure to obs location -! Calculate innovations, perform gross checks, and accumualte -! numbers for statistics - -! For OMI/GOME, nlev=1 - do k=1,nlev - j=ipos(k) - if (obstype == 'omieff' .or. obstype == 'tomseff' ) then - ioff=ifovn+1 ! - else - ioff=nreal+k ! SBUV and OMI w/o efficiency factors - endif - -! Compute innovation and load obs error into local array - ! KW OMI and TOMS have averaging kernels - if (obstype == 'omieff' .or. obstype == 'tomseff' ) then - ! everything in data is from top to bottom - nlayers = nloz_omi + 1 - apriori(1:nloz_omi) = data(ioff:ioff+nloz_omi -1, i) - ioff = ioff + nloz_omi - efficiency(1:nloz_omi) = data(ioff:ioff+nloz_omi -1, i) - ! Compute ozges - call intrp3oz1(ges_oz,ozges1,dlat,dlon,ozp_omi,dtime,& - nlayers,mype) - ozges(k) = zero - do kk = 1, nloz_omi - ozges(k) = ozges(k) + apriori(kk) + efficiency(kk)*(ozges1(kk)-apriori(kk)) - end do - ioff = 37_i_kind - ozobs = data(ioff,i) - else ! Applying averaging kernels for OMI - apriori(1:nloz_omi) = -99.99 ! this will identify non-OMIEFF data for intoz - ozobs = data(ioff,i) - endif - - ozone_inv(k) = ozobs-ozges(k) - error(k) = tnoise(k) - -! Set inverse obs error squared and ratio_errors - if (error(k)<1.e4_r_kind) then - varinv3(k) = one/(error(k)**2) - ratio_errors(k) = one - else - varinv3(k) = zero - ratio_errors(k) = zero - endif - -! Perform gross check - if(abs(ozone_inv(k)) > gross(k) .or. ozobs > 1000._r_kind .or. & - ozges(k)1.e-10_r_kind) ikeepk(k)=1 - end do - ikeep=maxval(ikeepk) - endif ! (in_curbin) - -! In principle, we want ALL obs in the diagnostics structure but for -! passive obs (monitoring), it is difficult to do if rad_diagsave -! is not on in the first outer loop. For now we use l_may_be_passive... - if (l_may_be_passive) then -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)'SETUPOZLAY: ',mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - - if(in_curbin) then -! Process obs have at least one piece of information that passed qc checks - if (.not. last .and. ikeep==1) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(ozhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - - nlevp=max(nlev-1,1) - if (obstype == 'omieff' .or. obstype == 'tomseff' ) nlevp = nloz_omi - allocate(my_head%res(nlev), & - my_head%err2(nlev), & - my_head%raterr2(nlev), & - my_head%prs(nlevp), & - my_head%wij(4,nsig), & - my_head%dprsi(nsig), & - my_head%ipos(nlev), & - my_head%apriori(nloz_omi), & - my_head%efficiency(nloz_omi), stat=istatus) - if (istatus/=0) write(6,*)'SETUPOZ: allocate error for oz_point, istatus=',istatus - if(luse_obsdiag)allocate(my_head%diags(nlev)) - -! Set number of levels for this obs - my_head%nloz = nlev-1 ! NOTE: for OMI/GOME, nloz=0 - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,tempwij) - - call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime,hrdifsig,& - nsig+1,mype,nfldsig) - - my_head%rozcon = rozcon - do k = 1,nsig - my_head%dprsi(k) = prsitmp(k)-prsitmp(k+1) - my_head%wij(1,k)=tempwij(1)*rozcon*(prsitmp(k)-prsitmp(k+1)) - my_head%wij(2,k)=tempwij(2)*rozcon*(prsitmp(k)-prsitmp(k+1)) - my_head%wij(3,k)=tempwij(3)*rozcon*(prsitmp(k)-prsitmp(k+1)) - my_head%wij(4,k)=tempwij(4)*rozcon*(prsitmp(k)-prsitmp(k+1)) - end do - -! Increment data counter and save information used in -! inner loop minimization (int* and stp* routines) - - my_head%luse=luse(i) - my_head%time=dtime - - if (obstype == 'sbuv2' ) then - do k=1,nlevs-1 - my_head%prs(k) = ozp(k) - enddo - else if (obstype == 'omieff' .or. obstype == 'tomseff') then - do k=1,nloz_omi - my_head%prs(k) = ozp_omi(k) - enddo - else ! GOME or OMI w/o efficiency factors - - my_head%prs(1) = zero ! any value is OK, never used - endif - - my_head => null() - endif ! < .not.last > - endif ! (in_curbin) - -! Link obs to diagnostics structure - do k=1,nlevs - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_oz_ob_type,ibin)%head)) then - obsdiags(i_oz_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_oz_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupozlay: failure to allocate obsdiags',istat - call stop2(260) - end if - obsdiags(i_oz_ob_type,ibin)%tail => obsdiags(i_oz_ob_type,ibin)%head - else - allocate(obsdiags(i_oz_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupozlay: failure to allocate obsdiags',istat - call stop2(261) - end if - obsdiags(i_oz_ob_type,ibin)%tail => obsdiags(i_oz_ob_type,ibin)%tail%next - end if - obsdiags(i_oz_ob_type,ibin)%n_alloc = obsdiags(i_oz_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_oz_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_oz_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_oz_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_oz_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_oz_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_oz_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_oz_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_oz_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_oz_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_oz_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_oz_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_oz_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_oz_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = k - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_oz_ob_type,ibin)%tail)) then - obsdiags(i_oz_ob_type,ibin)%tail => obsdiags(i_oz_ob_type,ibin)%head - else - obsdiags(i_oz_ob_type,ibin)%tail => obsdiags(i_oz_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_oz_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_oz_ob_type,ibin)%tail)') - endif - if (obsdiags(i_oz_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupozlay: index error' - call stop2(262) - end if - endif - endif - - if(in_curbin) then - if (luse_obsdiag) then - obsdiags(i_oz_ob_type,ibin)%tail%muse(jiter)= (ikeepk(k)==1) - obsdiags(i_oz_ob_type,ibin)%tail%nldepart(jiter)=ozone_inv(k) - obsdiags(i_oz_ob_type,ibin)%tail%wgtjo= varinv3(k)*ratio_errors(k)**2 - endif - - if (.not. last .and. ikeep==1) then - !my_head => ozNode_typecast(obsLList_tailNode(ozhead(ibin))) - my_node => obsLList_tailNode(ozhead(ibin)) - if(.not.associated(my_node)) & - call die(myname,'unexpected, associated(my_node) =',associated(my_node)) - my_head => ozNode_typecast(my_node) - if(.not.associated(my_head)) & - call die(myname,'unexpected, associated(my_head) =',associated(my_head)) - my_node => my_head - - my_head%ipos(k) = ipos(k) - my_head%res(k) = ozone_inv(k) - my_head%err2(k) = varinv3(k) - my_head%raterr2(k) = ratio_errors(k)**2 - my_head%apriori(1:nloz_omi) = apriori(1:nloz_omi) - my_head%efficiency(1:nloz_omi) = efficiency(1:nloz_omi) - - if (luse_obsdiag) then - my_head%diags(k)%ptr => obsdiags(i_oz_ob_type,ibin)%tail - - my_diag => my_head%diags(k)%ptr - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob .or. & - k /= my_diag%ich ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ich,ibin) =', & - (/is,ioid(i),k,ibin/)) - call perr(myname,'my_head%(idv,iob,ich) =',(/my_head%idv,my_head%iob,k/)) - call perr(myname,'my_diag%(idv,iob,ich) =',(/my_diag%idv,my_diag%iob,my_diag%ich/)) - call die(myname) - endif - endif - - my_head => null() - endif - - if (ozone_diagsave.and.lobsdiagsave.and.luse(i)) then - idia=6 - do jj=1,miter - idia=idia+1 - if (obsdiags(i_oz_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(idia,k,ii) = one - else - rdiagbuf(idia,k,ii) = -one - endif - enddo - do jj=1,miter+1 - idia=idia+1 - rdiagbuf(idia,k,ii) = obsdiags(i_oz_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,k,ii) = obsdiags(i_oz_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,k,ii) = obsdiags(i_oz_ob_type,ibin)%tail%obssen(jj) - enddo - endif - endif ! (in_curbin) - - enddo ! < over nlevs > - - else - - if(in_curbin) then - if (ozone_diagsave.and.lobsdiagsave.and.luse(i)) then - rdiagbuf(7:irdim1,1:nlevs,ii) = zero - endif - endif ! (in_curbin) - - endif ! < l_may_be_passive > - - end do ! end do i=1,nobs - -! If requested, write to diagnostic file - if (ozone_diagsave .and. ii>0) then - filex=obstype - write(string,100) jiter -100 format('_',i2.2) - diag_ozone_file = trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // (string) - if(init_pass) then - open(4,file=diag_ozone_file,form='unformatted',status='unknown',position='rewind') - else - inquire(file=diag_ozone_file,exist=ozdiagexist) - if (ozdiagexist) then - open(4,file=diag_ozone_file,form='unformatted',status='old',position='append') - else - open(4,file=diag_ozone_file,form='unformatted',status='unknown',position='rewind') - endif - endif - iextra=0 - if (init_pass .and. mype==mype_diaghdr(is)) then - write(4) isis,dplat(is),obstype,jiter,nlevs,ianldate,iint,ireal,iextra -! write(6,*)'SETUPOZ: write header record for ',& -! isis,iint,ireal,iextra,' to file ',trim(diag_ozone_file),' ',ianldate - do i=1,nlevs - pob4(i)=pobs(i) - grs4(i)=gross(i) - err4(i)=tnoise(i) - end do - write(4) pob4,grs4,err4,iouse - endif - write(4) ii - write(4) idiagbuf(:,1:ii),diagbuf(:,1:ii),rdiagbuf(:,:,1:ii) - close(4) - endif - -! Jump to this line if problem with data -135 continue - -! Release memory of local guess arrays - call final_vars_ - -! clean up - call dtime_show('setupozlay','diagsave:oz',i_oz_ob_type) - if(ozone_diagsave) deallocate(rdiagbuf) - -! End of routine - return - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::oz', ivar, istatus ) - proceed=ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get oz ... - varname='oz' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_oz))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_oz(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_oz(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_oz(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_oz)) deallocate(ges_oz) - end subroutine final_vars_ - -end subroutine setupozlay - - -subroutine setupozlev(lunin,mype,stats_oz,nlevs,nreal,nobs,& - obstype,isis,is,ozone_diagsave,init_pass) - -!$$$ subprogram documentation block -! . . . -! subprogram: setupozlev --- Compute rhs of oi for mls ozone mixing ratio obs at pressure levels -! -! prgrmmr: H.Liu org: np22 date: 2010-10-18 -! -! abstract: For sbuv ozone observations (layer amounts and total -! column, this routine -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2010-10-18 h.liu - subroutine for mls data: based on setupoz and Sienkiewicz's setupo3lv -! 2013-10-19 todling - metguess now holds background -! 2013-11-26 guo - removed nkeep==0 escaping to allow more than one obstype sources. -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2014-05-12 wargan - refine MLS gross check -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nlevs - number of levels (layer amounts + total column) per obs -! nreal - number of pieces of non-ozone info (location, time, etc) per obs -! nobs - number of observations -! isis - sensor/instrument/satellite id -! is - integer(i_kind) counter for number of obs types to process -! obstype - type of ozone obs -! ozone_diagsave - switch on diagnostic output (.false.=no output) -! stats_oz - sums for various statistics as a function of level -! -! output argument list: -! stats_oz - sums for various statistics as a function of level -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq HP -! -!$$$ end documentation block - -! !USES: - - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,i_kind - - use m_obsdiags, only : o3lhead - use obsmod, only : i_o3l_ob_type,dplat,nobskeep - use obsmod, only : mype_diaghdr,dirname,time_offset,ianldate - use obsmod, only : obsdiags,lobsdiag_allocated,lobsdiagsave - use m_obsNode, only: obsNode - use m_o3lNode, only : o3lNode - use m_obsLList, only : obsLList_appendNode - use obsmod, only : obs_diag,luse_obsdiag - - use guess_grids, only : nfldsig,ges_lnprsl,hrdifsig - - use constants, only : zero,half,one,two,tiny_r_kind,four - use constants, only : cg_term,wgtlim,r10,constoz - - use gsi_4dvar, only: nobs_bins,hr_obsbin - - use gridmod, only : get_ijk,nsig - - use ozinfo, only : gross_oz, jpch_oz, nusis_oz - use ozinfo, only : b_oz,pg_oz - - use jfunc, only : jiter,last,miter - - use m_dtime, only: dtime_setup, dtime_check, dtime_show - - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! !INPUT PARAMETERS: - - integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations - integer(i_kind) , intent(in ) :: mype ! mpi task id - integer(i_kind) , intent(in ) :: nlevs ! number of levels (layer amounts + total column) per obs - integer(i_kind) , intent(in ) :: nreal ! number of pieces of non-ozone info (location, time, etc) per obs - integer(i_kind) , intent(in ) :: nobs ! number of observations - character(20) , intent(in ) :: isis ! sensor/instrument/satellite id - integer(i_kind) , intent(in ) :: is ! integer(i_kind) counter for number of obs types to process - - character(10) , intent(in ) :: obstype ! type of ozone obs - logical , intent(in ) :: ozone_diagsave ! switch on diagnostic output (.false.=no output) - logical , intent(in ) :: init_pass ! state of "setup" processing - -! !INPUT/OUTPUT PARAMETERS: - - real(r_kind),dimension(9,jpch_oz), intent(inout) :: stats_oz ! sums for various statistics as - ! a function of level -!------------------------------------------------------------------------- - -! Declare local parameters - integer(i_kind),parameter:: iint=1 - integer(i_kind),parameter:: ireal=3 - real(r_kind),parameter:: rmiss = -9999.9_r_kind - character(len=*),parameter:: myname="setupozlev" - -! Declare external calls for code analysis - external:: tintrp2a1,tintrp2a11 - external:: tintrp3 - external:: grdcrd1 - external:: stop2 - -! Declare local variables - - real(r_kind) o3ges, o3ppmv - real(r_kind) rlow,rhgh,sfcchk - real(r_kind) omg,rat_err2,dlat,dtime,dlon - real(r_kind) cg_oz,wgross,wnotgross,wgt,arg,exp_arg,term - real(r_kind) errorinv - real(r_kind) psges,ozlv - - real(r_kind) varinv3,ratio_errors - real(r_kind) dpres,obserror,ozone_inv,preso3l - real(r_kind),dimension(nreal+nlevs,nobs):: data - real(r_kind),dimension(nsig):: prsltmp - real(r_single),dimension(ireal,nobs):: diagbuf - real(r_single),allocatable,dimension(:,:,:)::rdiagbuf - - integer(i_kind) i,ii,jj,iextra,istat,ibin - integer(i_kind) k,j,idia,irdim1 - integer(i_kind) isolz,iuse - integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,iozmr,ilev,ipres,iprcs,imls_levs - integer(i_kind),dimension(iint,nobs):: idiagbuf - real(r_kind) gross - - character(12) string - character(10) filex - character(128) diag_ozone_file - - logical:: ozdiagexist - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(o3lNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_oz - -! Check to see if required guess fields are available -! Question: Should a message be produced before return, to inform the -! system what has been going on? - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 - - mm1=mype+1 - - -! -!********************************************************************************* -! Initialize arrays - - if(ozone_diagsave)then - irdim1=6 - if(lobsdiagsave) irdim1=irdim1+4*miter+1 - allocate(rdiagbuf(irdim1,1,nobs)) - rdiagbuf=0._r_single - end if - -! index information for data array (see reading routine) - itime=2 ! index of analysis relative obs time - ilon=3 ! index of grid relative obs location (x) - ilat=4 ! index of grid relative obs location (y) - ilone=5 ! index of earth relative longitude (degrees) - ilate=6 ! index of earth relative latitude (degrees) - isolz=7 ! index of solar zenith angle - iuse=8 ! index of usage flag - ipres=9 ! index of pressure in log(cb) - iprcs=10 ! index of mixing ratio precision in ppmv - ilev=11 ! index of obs level - imls_levs=12 ! index of mls nrt vertical levels - iozmr=13 ! index of ozone mixing ratio in ppmv - -! Read and transform ozone data - read(lunin) data,luse,ioid - -! Set flag for obs use - do i=1,nobs - muse(i)=nint(data(iuse,i))<=jiter - end do - -! If requested, save data for diagnostic ouput - if(ozone_diagsave)ii=0 - -! Convert observation (lat,lon) from earth to grid relative values - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - dpres=data(ipres,i) !pressure in log(cb) - preso3l =r10*exp(dpres) - - dlat=data(ilat,i) - dlon=data(ilon,i) - dtime=data(itime,i) - obserror=data(iprcs,i) - - if (nobskeep>0) then - write(6,*)'setupozlev: nobskeep',nobskeep - call stop2(338) - end if - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*) 'SETUPOZLEV: ', mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_o3l_ob_type,ibin)%head)) then - obsdiags(i_o3l_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_o3l_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupozlev: failure to allocate obsdiags',istat - call stop2(256) - end if - obsdiags(i_o3l_ob_type,ibin)%tail => obsdiags(i_o3l_ob_type,ibin)%head - else - allocate(obsdiags(i_o3l_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupozlev: failure to allocate obsdiags',istat - call stop2(257) - end if - obsdiags(i_o3l_ob_type,ibin)%tail => obsdiags(i_o3l_ob_type,ibin)%tail%next - end if - obsdiags(i_o3l_ob_type,ibin)%n_alloc = obsdiags(i_o3l_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_o3l_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_o3l_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_o3l_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_o3l_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_o3l_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_o3l_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_o3l_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_o3l_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_o3l_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_o3l_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_o3l_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_o3l_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_o3l_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_o3l_ob_type,ibin)%tail)) then - obsdiags(i_o3l_ob_type,ibin)%tail => obsdiags(i_o3l_ob_type,ibin)%head - else - obsdiags(i_o3l_ob_type,ibin)%tail => obsdiags(i_o3l_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_o3l_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_o3l_ob_type,ibin)%tail)') - endif - if (obsdiags(i_o3l_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupozlev: index error' - call stop2(258) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Interpolate ps to obs locations/times - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig, & - mype,nfldsig) - -! Interpolate log(pres) at mid-layers to obs locations/times - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig, & - nsig,mype,nfldsig) - -! Get approximate k value of surface by using surface pressure -! for surface check. - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp,nsig,-1) - - if(ozone_diagsave .and. luse(i))then - ii=ii+1 - idiagbuf(1,ii)=mype ! mpi task number - diagbuf(1,ii) = data(ilate,i) ! lat (degree) - diagbuf(2,ii) = data(ilone,i) ! lon (degree) - diagbuf(3,ii) = data(itime,i)-time_offset ! time (hours relative to analysis) - endif - - ozlv=data(iozmr,i) ! ozone mixing ratio in ppmv at pressure level - -! Pressure level of data (dpres) converted to grid coordinate -! (wrt mid-layer pressure) - call grdcrd1(dpres,prsltmp,nsig,-1) - -! Check if observation above model top or below model surface - - rlow=max(sfcchk-dpres,zero) - rhgh=max(dpres-0.001_r_kind-float(nsig),zero) - -! calculate factor for error adjustment if too (high,low) - ratio_errors=obserror/(obserror+1.0e6_r_kind*rhgh+four*rlow) - -! Check to see if observations is above the top of the model - if (dpres > float(nsig)) then - ratio_errors=zero - obserror=1.0e6_r_kind - end if - -! Interpolate guess ozone to observation location and time - call tintrp31(ges_oz,o3ges,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - -! Compute innovations - background o3ges in g/g so adjust units -! Leave increment in ppmv for gross checks, etc. - - o3ppmv = o3ges * constoz - ozone_inv=ozlv - o3ppmv - -! Perform gross checks, and accumualte numbers for statistics - - j=nint(data(ilev,i)) !the entry # in ozinfo.txt - -! Set inverse obs error squared and ratio_errors - if (obserror>zero .and. obserror<1.e4_r_kind) then - varinv3 = one/(obserror**2) - ratio_errors = one*ratio_errors - else - varinv3 = zero - ratio_errors = zero - endif - -! toss the obs not recommended by the data provider - if (nint(data(iuse,i)) == 1000 ) then - varinv3=zero - ratio_errors=zero - endif - -! Perform gross check (smallness of O-F criterion added) - do jj=1,jpch_oz - if (isis == nusis_oz(jj) .and. jj == j) then - gross=gross_oz(jj) - endif - end do - - if( abs(ozone_inv)/obserror > gross .or.ozlv > 1.e+02_r_kind ) then - varinv3=zero - ratio_errors=zero - if(luse(i))stats_oz(2,j) = stats_oz(2,j) + one ! number of obs tossed - endif - -! check if gross check failed, mark failed obs for non-use - if (ratio_errors/obserror <=tiny_r_kind) then - muse(i)=.false. - end if - -! Accumulate numbers for statistics - rat_err2 = ratio_errors**2 - if (varinv3>tiny_r_kind .or. ozone_diagsave) then - if(luse(i))then - omg=ozone_inv - stats_oz(1,j) = stats_oz(1,j) + one ! # obs - stats_oz(3,j) = stats_oz(3,j) + omg ! (o-g) - stats_oz(4,j) = stats_oz(4,j) + omg*omg ! (o-g)**2 - stats_oz(5,j) = stats_oz(5,j) + omg*omg*varinv3*rat_err2 ! penalty - stats_oz(6,j) = stats_oz(6,j) + ozlv ! obs - - exp_arg = -half*varinv3*omg**2 - errorinv = sqrt(varinv3) - if (pg_oz(j) > tiny_r_kind .and. errorinv > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-pg_oz(j) - cg_oz=b_oz(j)*errorinv - wgross = cg_term*pg_oz(j)/(cg_oz*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - else - term = exp_arg - wgt = one - endif - - stats_oz(8,j) = stats_oz(8,j) -two*rat_err2*term - if(wgt < wgtlim) stats_oz(9,j)=stats_oz(9,j)+one - end if - endif - -! If not assimilating this observation, reset inverse variance to zero - if ( .not. muse(i)) then - varinv3=zero - ratio_errors=zero - rat_err2 = zero - end if - if (rat_err2*varinv3>tiny_r_kind .and. luse(i)) & - stats_oz(7,j) = stats_oz(7,j) + one - - if (luse_obsdiag) then - obsdiags(i_o3l_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_o3l_ob_type,ibin)%tail%nldepart(jiter)=ozone_inv - obsdiags(i_o3l_ob_type,ibin)%tail%wgtjo= varinv3*ratio_errors**2 - endif - - if (.not. last .and. muse(i) ) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(o3lhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j,k) indices of guess gridpoint that bound obs location - my_head%dlev = dpres - call get_ijk(mm1,dlat,dlon,dpres,& - my_head%ij(1),my_head%wij(1)) - - do k=1,8 - my_head%wij(k)=my_head%wij(k)*constoz - end do - - my_head%res = ozone_inv - my_head%err2 = varinv3 - my_head%raterr2 = ratio_errors**2 - my_head%luse = luse(i) - my_head%time = dtime - my_head%b = b_oz(j) - my_head%pg = pg_oz(j) - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_o3l_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ich,ibin) =', & - (/is,ioid(i),k,ibin/)) - call perr(myname,'my_head%(idv,iob,ich) =',(/my_head%idv,my_head%iob,k/)) - call perr(myname,'my_diag%(idv,iob,ich) =',(/my_diag%idv,my_diag%iob,my_diag%ich/)) - call die(myname) - endif - endif - - my_head => null() - endif - -! Optionally save data for diagnostics - if (ozone_diagsave .and. luse(i)) then - rdiagbuf(1,1,ii) = ozlv ! obs - rdiagbuf(2,1,ii) = ozone_inv ! obs-ges - errorinv = sqrt(varinv3*rat_err2) - rdiagbuf(3,1,ii) = errorinv ! inverse observation error - rdiagbuf(4,1,ii) = preso3l ! override solar zenith angle with a reference pressure (in hPa) - rdiagbuf(5,1,ii) = rmiss ! fovn - rdiagbuf(6,1,ii) = obserror ! ozone mixing ratio precision - - if (lobsdiagsave) then - idia=6 - do jj=1,miter - idia=idia+1 - if (obsdiags(i_o3l_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(idia,1,ii) = one - else - rdiagbuf(idia,1,ii) = -one - endif - enddo - do jj=1,miter+1 - idia=idia+1 - rdiagbuf(idia,1,ii) = obsdiags(i_o3l_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,1,ii) = obsdiags(i_o3l_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,1,ii) = obsdiags(i_o3l_ob_type,ibin)%tail%obssen(jj) - enddo - endif - end if !end if(ozone_diagsave ) - - end do ! end do i=1,nobs - -! If requested, write to diagnostic file - if (ozone_diagsave .and. ii>0) then - filex=obstype - write(string,100) jiter -100 format('_',i2.2) - diag_ozone_file = trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // (string) - if(init_pass) then - open(4,file=diag_ozone_file,form='unformatted',status='unknown',position='rewind') - else - inquire(file=diag_ozone_file,exist=ozdiagexist) - if (ozdiagexist) then - open(4,file=diag_ozone_file,form='unformatted',status='old',position='append') - else - open(4,file=diag_ozone_file,form='unformatted',status='unknown',position='rewind') - endif - endif - iextra=0 - if (init_pass .and. mype==mype_diaghdr(is)) then - write(4) isis,dplat(is),obstype,jiter,nlevs,ianldate,iint,ireal,iextra - write(6,*)'SETUPOZLV: write header record for ',& - isis,iint,ireal,iextra,' to file ',trim(diag_ozone_file),' ',ianldate - endif - write(4) ii - write(4) idiagbuf(:,1:ii),diagbuf(:,1:ii),rdiagbuf(:,1,1:ii) - close(4) - endif - -! Release memory of local guess arrays - call final_vars_ - -! clean up - call dtime_show('setupozlev','diagsave:ozlv',i_o3l_ob_type) - if(ozone_diagsave) deallocate(rdiagbuf) - -! End of routine - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::oz' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get oz ... - varname='oz' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_oz))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_oz(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_oz(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_oz(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_oz)) deallocate(ges_oz) - if(allocated(ges_ps)) deallocate(ges_ps) - end subroutine final_vars_ - -end subroutine setupozlev diff --git a/src/setuppblh.f90 b/src/setuppblh.f90 deleted file mode 100644 index 6506fbeca..000000000 --- a/src/setuppblh.f90 +++ /dev/null @@ -1,599 +0,0 @@ -subroutine setuppblh(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuppblh compute rhs for conventional surface pblh -! prgmmr: derber org: np23 date: 2004-07-20 -! -! abstract: For sea surface temperature observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2009-10-21 zhu -! 2011-02-19 zhu - update -! 2013-01-26 parrish - change from tintrp2a to tintrp2a11, tintrp2a11 (so debug compile on WCOSS works) -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! before retuning to setuprhsall.f90 -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig - use m_obsdiags, only: pblhhead - use obsmod, only: rmiss_single,i_pblh_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode, only: obsNode - use m_pblhNode, only: pblhNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,bmiss,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig - use gridmod, only: get_ij - use constants, only: zero,tiny_r_kind,one,half,wgtlim, & - two,cg_term,pi,huge_single,r1000 - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) pblhges,dlat,dlon,ddiff,dtime,error - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,halfpi,rwgt - real(r_kind) cg_pblh,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,ipblh,id,itime,ikx,imaxerr,iqc - integer(i_kind) iuse,ihgt,ilate,ilone,istnelv - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(pblhNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - character(len=*),parameter:: myname='setuppblh' - - real(r_kind),allocatable,dimension(:,:,:) :: ges_ps - real(r_kind),allocatable,dimension(:,:,:) :: ges_z - real(r_kind),allocatable,dimension(:,:,:) :: ges_pblh - - equivalence(rstation_id,station_id) - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ihgt=4 ! index of observation elevation - ipblh=5 ! index of pblh observation - id=6 ! index of station id - itime=7 ! index of observation time in data array - ikxx=8 ! index of ob type - imaxerr=9 ! index of pblh max error - iqc=10 ! index of qulaity mark - iuse=11 ! index of use parameter - ilone=12 ! index of longitude (degrees) - ilate=13 ! index of latitude (degrees) - istnelv=14 ! index of station elevation (m) - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - -! Check for missing data !need obs value and error - do i=1,nobs - if (abs(data(ipblh,i)-bmiss) .lt. 10.0_r_kind) then - muse(i)=.false. - data(ipblh,i)=rmiss_single ! for diag output - end if - end do - - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=20 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - halfpi = half*pi - mm1=mype+1 - scale=one - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_pblh_ob_type,ibin)%head)) then - obsdiags(i_pblh_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_pblh_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuppblh: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_pblh_ob_type,ibin)%tail => obsdiags(i_pblh_ob_type,ibin)%head - else - allocate(obsdiags(i_pblh_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuppblh: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_pblh_ob_type,ibin)%tail => obsdiags(i_pblh_ob_type,ibin)%tail%next - end if - obsdiags(i_pblh_ob_type,ibin)%n_alloc = obsdiags(i_pblh_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_pblh_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_pblh_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_pblh_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_pblh_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_pblh_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_pblh_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_pblh_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_pblh_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_pblh_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_pblh_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_pblh_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_pblh_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_pblh_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_pblh_ob_type,ibin)%tail)) then - obsdiags(i_pblh_ob_type,ibin)%tail => obsdiags(i_pblh_ob_type,ibin)%head - else - obsdiags(i_pblh_ob_type,ibin)%tail => obsdiags(i_pblh_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_pblh_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_pblh_ob_type,ibin)%tail)') - endif - if (obsdiags(i_pblh_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuppblh: index error' - call stop2(297) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Interpolate to get pblh at obs location/time - call tintrp2a11(ges_pblh,pblhges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - -! Adjust observation error - ratio_errors=error/data(ier,i) - error=one/error - - ddiff=data(ipblh,i)-pblhges - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross check using innovation normalized by error - if (abs(data(ipblh,i)-rmiss_single) >= tiny_r_kind ) then - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else - ratio_errors=ratio_errors/sqrt(dup(i)) - end if - else - error = zero - ratio_errors=zero - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_pblh_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_pblh=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_pblh*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - end if - ress = ddiff*scale - ressw2 = ress*ress - val2 = val*val - rat_err2 = ratio_errors**2 - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - if (abs(data(ipblh,i)-rmiss_single) >=tiny_r_kind) then - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - end if - - endif - - if (luse_obsdiag) then - obsdiags(i_pblh_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_pblh_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_pblh_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(pblhhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_pblh_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(ipblh,i) ! PBLH observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(ipblh,i)-pblhges! obs-ges w/o bias correction (K) (future slot) - - rdiagbuf(20,ii) = rmiss_single ! type of measurement - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_pblh_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_pblh_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_pblh_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_pblh_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - - - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:pblh',i_pblh_ob_type) - write(7)'pbl',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::pblh' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get pblh ... - varname='pblh' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_pblh))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_pblh(size(rank2,1),size(rank2,2),nfldsig)) - ges_pblh(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_pblh(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps )) deallocate(ges_ps ) - if(allocated(ges_pblh)) deallocate(ges_pblh) - end subroutine final_vars_ - -end subroutine setuppblh - diff --git a/src/setuppmsl.f90 b/src/setuppmsl.f90 deleted file mode 100644 index 9977f3ec5..000000000 --- a/src/setuppmsl.f90 +++ /dev/null @@ -1,621 +0,0 @@ -subroutine setuppmsl(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuppmsl compute rhs of oi for conventional pmsl -! prgmmr: pondeca org: np23 date: 2014-04-10 -! -! abstract: For pmsl observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2014-04-10 pondeca -! 2015-03-11 pondeca - Modify for possibility of not using obsdiag -! before retuning to setuprhsall.f90 -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig - use m_obsdiags, only: pmslhead - use m_obsNode , only: obsNode - use m_pmslNode, only: pmslNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: rmiss_single,i_pmsl_ob_type, & - obs_diag,obsdiags,lobsdiagsave,nobskeep,lobsdiag_allocated, & - time_offset,bmiss,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig,get_ij,twodvar_regional - use constants, only: zero,huge_r_kind,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & - two,cg_term,huge_single,three - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_7=0.7_r_kind - - character(len=*),parameter:: myname='setuppmsl' - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) pmslges,dlat,dlon,ddiff,dtime,error - real(r_kind) val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,rwgt - real(r_kind) cg_pmsl,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,ipres,ipmsl,ihgt,itemp,id,itime,ikx,iqc,iskint,iff10 - integer(i_kind) ier2,iuse,ilate,ilone,istnelv,isfcr,izz,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode), pointer:: my_node - type(pmslNode), pointer:: my_head - type(obs_diag), pointer:: my_diag - - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !will probably need at some point - real(r_kind),allocatable,dimension(:,:,:) :: ges_z !will probably need at some point - real(r_kind),allocatable,dimension(:,:,:) :: ges_pmsl - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - ipmsl=5 ! index of pmsl observation - ihgt=6 ! index of surface height - itemp=7 ! index of surface temperature observation - id=8 ! index of station id - itime=9 ! index of observation time in data array - ikxx=10 ! index of ob type - iqc=11 ! index of quality mark - ier2=12 ! index of original obs error - iuse=13 ! index of use parameter - idomsfc=14 ! index of dominant surface type - iskint=15 ! index of surface skin temperature - iff10=16 ! index of 10 meter wind factor - isfcr=17 ! index of surface roughness - ilone=18 ! index of longitude (degrees) - ilate=19 ! index of latitude (degrees) - istnelv=20 ! index of station elevation (m) - izz=21 ! index of surface height - iprvd=22 ! index of observation provider - isprvd=23 ! index of observation subprovider - - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=19 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - - mm1=mype+1 - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier2,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_pmsl_ob_type,ibin)%head)) then - obsdiags(i_pmsl_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_pmsl_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuppmsl: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_pmsl_ob_type,ibin)%tail => obsdiags(i_pmsl_ob_type,ibin)%head - else - allocate(obsdiags(i_pmsl_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuppmsl: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_pmsl_ob_type,ibin)%tail => obsdiags(i_pmsl_ob_type,ibin)%tail%next - end if - obsdiags(i_pmsl_ob_type,ibin)%n_alloc = obsdiags(i_pmsl_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_pmsl_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_pmsl_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_pmsl_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_pmsl_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_pmsl_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_pmsl_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_pmsl_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_pmsl_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_pmsl_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_pmsl_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_pmsl_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_pmsl_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_pmsl_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_pmsl_ob_type,ibin)%tail)) then - obsdiags(i_pmsl_ob_type,ibin)%tail => obsdiags(i_pmsl_ob_type,ibin)%head - else - obsdiags(i_pmsl_ob_type,ibin)%tail => obsdiags(i_pmsl_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_pmsl_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_pmsl_ob_type,ibin)%tail)') - end if - if (obsdiags(i_pmsl_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuppmsl: index error' - call stop2(297) - end if - end if - end if - - if(.not.in_curbin) cycle - -! Interpolate guess pmsl to observation location and time - call tintrp2a11(ges_pmsl,pmslges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - ddiff=data(ipmsl,i)-pmslges ! in cb - -! Adjust observation error - ratio_errors=error/data(ier,i) - error=one/error - -! Gross error checks - - obserror = min(r10/max(ratio_errors*error,tiny_r_kind),huge_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(r10*ddiff) - ratio = residual/obserrlm - -! modify gross check limit for quality mark=3 - if(data(iqc,i) == three ) then - qcgross=r0_7*cgross(ikx) - else - qcgross=cgross(ikx) - endif - - if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else - ratio_errors=ratio_errors/sqrt(dup(i)) - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=one_tenth*maginnov - error=one/(one_tenth*magoberr) - ratio_errors=one - muse(i) = .true. - endif - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_pmsl_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_pmsl=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_pmsl*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - nn=1 - else - nn=2 !rejected obs - if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs - end if - - ress = ddiff*r10 - ressw2 = ress*ress - - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - endif - -! Fill obs diagnostics structure - if(luse_obsdiag)then - obsdiags(i_pmsl_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_pmsl_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_pmsl_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(pmslhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_pmsl_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - end if - - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = data(ipres,i)*r10 ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(ipmsl,i) ! PMSL observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(ipmsl,i)-pmslges! obs-ges w/o bias correction (K) (future slot) - - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_pmsl_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_pmsl_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_pmsl_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_pmsl_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:pmsl',i_pmsl_ob_type) - write(7)'psl',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::pmsl' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get pmsl ... - varname='pmsl' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_pmsl))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_pmsl(size(rank2,1),size(rank2,2),nfldsig)) - ges_pmsl(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_pmsl(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps )) deallocate(ges_ps ) - if(allocated(ges_pmsl)) deallocate(ges_pmsl) - end subroutine final_vars_ - -end subroutine setuppmsl - diff --git a/src/setupps.f90 b/src/setupps.f90 deleted file mode 100644 index e0ca4e350..000000000 --- a/src/setupps.f90 +++ /dev/null @@ -1,809 +0,0 @@ -subroutine setupps(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupps compute rhs of oi for surface pressure -! prgmmr: parrish org: np22 date: 1990-10-06 -! -! abstract: For surface pressure observations, this routine -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 1990-10-06 parrish -! 1998-04-10 weiyu yang -! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-17 treadon - update documentation -! 2004-08-02 treadon - add only to module use, add intent in/out -! 2004-10-06 parrish - increase size of pwork array for nonlinear qc -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list -! 2005-03-02 dee - remove garbage from diagnostic file -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-12 derber - rewrite and incorporate prep routine -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-10-21 su - modified variational quality control and diagnose output -! 2005-11-03 treadon - correct error in ilone,ilate data array indices -! 2005-11-22 wu - add option to perturb conventional obs -! 2005-11-29 derber - remove psfcg and use ges_lnps instead -! 2006-01-31 todling - storing wgt/wgtlim in diag file instead of wgt only -! 2006-02-02 treadon - rename lnprsl as ges_lnprsl -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-03-21 treadon - modify optional perturbation to observation -! 2006-05-30 su,derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - modify handling of multiple data at same location -! 2006-07-31 kleist - change analysis variable to ps (cb) instead of lnps -! 2006-08-28 su - fix a bug in variational qc -! 2007-03-09 su - modify obs perturbation -! 2007-03-19 tremolet - binning of observations -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-08-28 su - modify the error used in gross check -! 2008-03-24 wu - oberror tuning and perturb obs -! 2008-05-23 safford - rm unused vars and uses -! 2008-12-03 todling - changed handle of tail%time -! 2009-02-06 pondeca - for each observation site, add the following to the -! diagnostic file: local terrain height, dominate surface -! type, station provider name and station subprovider name -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2011-05-06 Su - modify the observation gross check error -! 2011-08-09 pondeca - correct bug in qcgross use -! 2013-01-26 parrish - change grdcrd to grdcrd1, intrp2a to intrp2a11, -! tintrp2a to tintrp2a1, tintrp2a11, -! tintrp3 to tintrp31 (so debug compile works on WCOSS) -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-04-12 su - add non linear qc from Purser's scheme -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2017-03-31 Hu - addd option l_closeobs to use closest obs to analysis -! time in analysis -! -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - use m_obsdiags, only: pshead - use obsmod, only: rmiss_single,perturb_obs,oberror_tune,& - i_ps_ob_type,obsdiags,lobsdiagsave,nobskeep,lobsdiag_allocated,& - time_offset - use m_obsNode, only: obsNode - use m_psNode, only: psNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig,get_ij,twodvar_regional - use constants, only: zero,one_tenth,one,half,pi,g_over_rd, & - huge_r_kind,tiny_r_kind,two,cg_term,huge_single, & - r1000,wgtlim,tiny_single,r10,three - use jfunc, only: jiter,last,jiterstart,miter - use qcmod, only: dfact,dfact1,npres_print,njqc,vqc - use guess_grids, only: hrdifsig,ges_lnprsl,nfldsig,ntguessig - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,icsubtype - - use m_dtime, only: dtime_setup, dtime_check, dtime_show - - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - use rapidrefresh_cldsurf_mod, only: l_closeobs - - implicit none - -! Declare passed variables - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - integer(i_kind) ,intent(in ) :: is ! ndat index - logical ,intent(in ) :: conv_diagsave - -! Declare local parameters - character(len=*),parameter:: myname='setupps' - real(r_kind),parameter:: r0_7=0.7_r_kind - -! Declare external calls for code analysis - external:: intrp2a - external:: tintrp2a1 - external:: tintrp3 - external:: grdcrd1 - external:: stop2 - -! Declare local variables - real(r_double) rstation_id - real(r_kind) tges,tges2,drbx,pob,pges,psges,psges2,dlat,dlon,dtime,var_jb - real(r_kind) rdelz,rdp,halfpi,obserror,obserrlm,drdp,residual,ratio - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final,tfact - real(r_kind) zsges,pgesorig,rwgt - real(r_kind) r0_005,r0_2,r2_5,tmin,tmax,half_tlapse - real(r_kind) ratio_errors,error,dhgt,ddiff,dtemp - real(r_kind) val2,ress,ressw2,val,valqc - real(r_kind) cg_ps,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2,qcgross - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nsig):: prsltmp - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - integer(i_kind) ier,ilon,ilat,ipres,ihgt,itemp,id,itime,ikx,iqc,iptrb,ijb - integer(i_kind) ier2,iuse,ilate,ilone,istnelv,idomsfc,izz,iprvd,isprvd - integer(i_kind) ikxx,nn,istat,ibin,ioff,ioff0 - integer(i_kind) i,nchar,nreal,ii,jj,k,l,mm1 - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - real(r_kind) :: hr_offset - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(psNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv - - n_alloc(:)=0 - m_alloc(:)=0 -!******************************************************************************* -! Read observations in work arrays. - - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - ihgt=5 ! index of surface height - itemp=6 ! index of surface temperature observation - id=7 ! index of station id - itime=8 ! index of observation time in data array - ikxx=9 ! index of ob type - iqc=10 ! index of quality mark - ier2=11 ! index of original-original obs error ratio - iuse=12 ! index of use parameter - idomsfc=13 ! index of dominant surface type - ilone=14 ! index of longitude (degrees) - ilate=15 ! index of latitude (degrees) - istnelv=16 ! index of station elevation (m) - izz=17 ! index of surface height - iprvd=18 ! index of observation provider - isprvd=19 ! index of observation subprovider - ijb=20 ! index of non linear qc parameter - iptrb=21 ! index of ps perturbation - -! Declare local constants - halfpi = half*pi - r0_005 = 0.005_r_kind - r0_2=0.2_r_kind - r2_5=2.5_r_kind - tmin=150.0_r_kind - tmax=350.0_r_kind - half_tlapse=0.00325_r_kind ! half of 6.5K/1km - mm1=mype+1 - var_jb=zero - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - -! Check to see if observation should be used or monitored -! muse = true then used - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - hr_offset=min_offset/60.0_r_kind -! Check for duplicate observations at same location - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - if(l_closeobs) then - if(abs(data(itime,k)-hr_offset)1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_ps_ob_type,ibin)%head)) then - obsdiags(i_ps_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_ps_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupps: failure to allocate obsdiags',istat - call stop2(266) - end if - obsdiags(i_ps_ob_type,ibin)%tail => obsdiags(i_ps_ob_type,ibin)%head - else - allocate(obsdiags(i_ps_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupps: failure to allocate obsdiags',istat - call stop2(267) - end if - obsdiags(i_ps_ob_type,ibin)%tail => obsdiags(i_ps_ob_type,ibin)%tail%next - end if - obsdiags(i_ps_ob_type,ibin)%n_alloc = obsdiags(i_ps_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_ps_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_ps_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_ps_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_ps_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_ps_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_ps_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_ps_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_ps_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_ps_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_ps_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_ps_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_ps_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_ps_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_ps_ob_type,ibin)%tail)) then - obsdiags(i_ps_ob_type,ibin)%tail => obsdiags(i_ps_ob_type,ibin)%head - else - obsdiags(i_ps_ob_type,ibin)%tail => obsdiags(i_ps_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_ps_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_ps_ob_type,ibin)%tail)') - end if - if (obsdiags(i_ps_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupps: index error' - call stop2(268) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Load obs error into local variable - obserror = max(cermin(ikx)*one_tenth,& - min(cermax(ikx)*one_tenth,data(ier,i))) - -! Get guess sfc hght at obs location - - call intrp2a11(ges_z(1,1,ntguessig),zsges,dlat,dlon,mype) - -! Interpolate to get log(ps) and log(pres) at mid-layers -! at obs location/time - - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - -! Convert pressure to grid coordinates - - pgesorig = psges - -! Take log for vertical interpolation - psges = log(psges) - call grdcrd1(psges,prsltmp,nsig,-1) - -! Get guess temperature at observation location and surface - - call tintrp31(ges_tv,tges,dlat,dlon,psges,dtime, & - hrdifsig,mype,nfldsig) - -! Adjust observation error and obs value due to differences in surface height - - rdelz=dhgt-zsges - if(dtemp > tmin .and. dtemp < tmax) then - -! Case of observed surface temperature - - drbx = half*abs(tges-dtemp)+r0_2+r0_005*abs(rdelz) - tges = half*(tges+dtemp) - else - -! No observed temperature - psges2=log(data(ipres,i)) - call grdcrd1(psges2,prsltmp,nsig,-1) - call tintrp31(ges_tv,tges2,dlat,dlon,psges2,dtime, & - hrdifsig,mype,nfldsig) - - drbx = half*abs(tges-tges2)+r2_5+r0_005*abs(rdelz) - tges = half*(tges+tges2) - -! Extrapolate surface temperature below ground at 6.5 k/km -! note only extrapolating .5dz, if no surface temp available. - - if(rdelz < zero)then - tges=tges-half_tlapse*rdelz - drbx=drbx-half_tlapse*rdelz - end if - - end if - -! Adjust guess hydrostatically - - rdp = g_over_rd*rdelz/tges - -! Subtract off dlnp correction, then convert to pressure (cb) - pges = exp(log(pgesorig) - rdp) - - -! observational error adjustment - - drdp=zero - if (.not.twodvar_regional) then - drdp = pges*(g_over_rd*abs(rdelz)*drbx/(tges**2)) - endif - -! find adjustment to observational error (in terms of ratio) - ratio_errors=error/(data(ier,i)+drdp) - error=one/error - -! Compute innovations - ddiff=pob-pges ! in cb - -! Oberror Tuning and Perturb Obs - if(muse(i)) then - if(oberror_tune )then - if( jiter > jiterstart ) then - ddiff=ddiff+data(iptrb,i)/error/ratio_errors - endif - else if(perturb_obs )then - ddiff=ddiff+data(iptrb,i)/error/ratio_errors - endif - endif - -! Gross check using innovation normalized by error - - obserror = min(r10/max(ratio_errors*error,tiny_r_kind),huge_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(r10*ddiff) - ratio = residual/obserrlm - -! modify gross check limit for quality mark=3 - if(data(iqc,i) == three ) then - qcgross=r0_7*cgross(ikx) - else - qcgross=cgross(ikx) - endif - - if (ratio > qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors = zero - else - ratio_errors = ratio_errors/sqrt(dup(i)) - end if - - if (ratio_errors*error <= tiny_r_kind) muse(i)=.false. - -! If requested, setup for single obs test. - - if (oneobtest) then - maginnov=one_tenth*maginnov - magoberr=one_tenth*magoberr - ddiff=maginnov - error=one/magoberr - ratio_errors=one - muse(i) = .true. - endif - - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_ps_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms, and accumulate statistics. - - val = error*ddiff - - if(luse(i))then - -! Compute penalty terms (linear & nonlinear qc). - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if(njqc .and. var_jb>tiny_r_kind .and. var_jb < 10.0_r_kind .and. error >tiny_r_kind) then - if(exp_arg == zero) then - wgt=one - else - wgt=ddiff*error/sqrt(two*var_jb) - wgt=tanh(wgt)/wgt - endif - term=-two*var_jb*rat_err2*log(cosh((val)/sqrt(two*var_jb))) - rwgt = wgt/wgtlim - valqc = -two*term - else if (vqc .and. (cvar_pg(ikx)> tiny_r_kind) .and. (error >tiny_r_kind)) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_ps=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_ps*wnotgross) - term =log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term - else - term = exp_arg - wgt = one - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term - endif - if (muse(i)) then -! Accumulate statistics for obs used belonging to this task - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - nn=1 - else - -! rejected obs - nn=2 -! monitored obs - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - -! Accumulate statistics for each ob type - - ress = ddiff*r10 - ressw2 = ress*ress - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - - end if - - if (luse_obsdiag) then - obsdiags(i_ps_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_ps_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_ps_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - - - if (.not. last .and. muse(i)) then -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) -! if no minimization (inner loop), do not load arrays - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(pshead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%jb = var_jb - my_head%luse = luse(i) - if(oberror_tune) then - my_head%kx = ikx ! data type for oberror tuning - my_head%ppertb= data(iptrb,i)/error/ratio_errors ! obs perturbation - endif - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_ps_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - - my_head => null() - - endif - -! Save obs and simulated surface pressure data for diagnostic output - - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = data(ipres,i)*r10 ! observation pressure (hPa) - rdiagbuf(7,ii) = dhgt ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = var_jb ! non linear qc parameter - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - pob = pob*r10 - pges = pges*r10 - pgesorig = pgesorig*r10 - - err_input = data(ier2,i)*r10 ! r10 converts cb to mb - err_adjst = data(ier,i)*r10 - if (ratio_errors*error/r10>tiny_r_kind) then - err_final = r10/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_single) errinv_input = one/err_input - if (err_adjst>tiny_single) errinv_adjst = one/err_adjst - if (err_final>tiny_single) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (hPa**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (hPa**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (hPa**-1) - - rdiagbuf(17,ii) = pob ! surface pressure observation (hPa) - rdiagbuf(18,ii) = pob-pges ! obs-ges used in analysis (coverted to hPa) - rdiagbuf(19,ii) = pob-pgesorig ! obs-ges w/o adjustment to guess surface pressure (hPa) - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_ps_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_ps_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_ps_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_ps_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - -! End of loop over observations - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:ps',i_ps_ob_type) - write(7)' ps',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - return - - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::tv', ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2 - real(r_kind),dimension(:,:,:),pointer:: rank3 - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get tv ... - varname='tv' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_tv))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_tv(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_tv(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_tv)) deallocate(ges_tv) - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps)) deallocate(ges_ps) - end subroutine final_vars_ - -end subroutine setupps diff --git a/src/setuppw.f90 b/src/setuppw.f90 deleted file mode 100644 index 359b9ba6c..000000000 --- a/src/setuppw.f90 +++ /dev/null @@ -1,667 +0,0 @@ -subroutine setuppw(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuppw compute rhs of oi for total column water -! prgmmr: parrish org: np22 date: 1990-10-06 -! -! abstract: For total column water, this routine -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 1990-10-06 parrish -! 1998-04-10 weiyu yang -! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2003-12-23 kleist - modify to use delta(pressure) from guess fields -! 2004-06-17 treadon - update documentation -! 2004-08-02 treadon - add only to module use, add intent in/out -! 2004-10-06 parrish - increase size of pwwork array for nonlinear qc -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list -! 2005-02-10 treadon - move initialization of dp_pw into routine sprpw -! 2005-03-02 dee - remove garbage from diagnostic file -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-11-03 treadon - correct error in ilone,ilate data array indices -! 2005-11-14 pondeca - correct error in diagnostic array index -! 2006-01-31 todling/treadon - store wgt/wgtlim in rdiagbuf(6,ii) -! 2006-02-02 treadon - rename prsi as ges_prsi -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-05-30 su,derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - modify handling of multiple data at same location -! - unify NL qc -! 2006-08-28 su - fix a bug in variational qc -! 2007-03-19 tremolet - binning of observations -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-08-28 su - modify gross check error -! 2008-12-03 todling - changed handle of tail%time -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2011-11-19 Hofmann - doing precipitable water (PW) height adjustment -! based on obs vs. model height -! 2013-01-26 parrish - change tintrp2a to tintrp2a1, tintrp2a11 (so debug compile works on WCOSS) -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - use guess_grids, only: ges_prsi,hrdifsig,nfldsig - use gridmod, only: lat2,lon2,nsig,get_ij - use m_obsdiags, only: pwhead - use obsmod, only: rmiss_single,i_pw_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode, only: obsNode - use m_pwNode, only: pwNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use constants, only: zero,one,tpwcon,r1000,r10, & - tiny_r_kind,three,half,two,cg_term,huge_single,& - wgtlim, rd - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use rapidrefresh_cldsurf_mod, only: l_pw_hgt_adjust, l_limit_pw_innov, max_innov_pct - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare local parameter - character(len=*),parameter:: myname='setuppw' - -! Declare external calls for code analysis - external:: tintrp2a1,tintrp2a11 - external:: stop2 - -! Declare local variables - real(r_double) rstation_id - real(r_kind):: pwges,grsmlt,dlat,dlon,dtime,obserror, & - obserrlm,residual,ratio,dpw - real(r_kind) error,ddiff, pw_diff - real(r_kind) ressw2,ress,scale,val2,val,valqc - real(r_kind) rat_err2,exp_arg,term,ratio_errors,rwgt - real(r_kind) cg_pw,wgross,wnotgross,wgt,arg - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final,tfact - real(r_kind),dimension(nobs)::dup - real(r_kind),dimension(nele,nobs):: data - real(r_kind),dimension(lat2,lon2,nfldsig)::rp2 - real(r_kind),dimension(nsig+1):: prsitmp - real(r_kind),dimension(nsig):: qges, tvges - real(r_single),allocatable,dimension(:,:)::rdiagbuf - real(r_kind) zges - - integer(i_kind) ikxx,nn,istat,ibin,ioff,ioff0 - integer(i_kind) i,nchar,nreal,k,j,jj,ii,l,mm1 - integer(i_kind) ier,ilon,ilat,ipw,id,itime,ikx,ipwmax,iqc - integer(i_kind) ier2,iuse,ilate,ilone,istnelv,iobshgt,iobsprs - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(pwNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - equivalence(rstation_id,station_id) - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q - - n_alloc(:)=0 - m_alloc(:)=0 - - grsmlt=three ! multiplier factor for gross check - mm1=mype+1 - scale=one - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - -!****************************************************************************** -! Read and reformat observations in work arrays. -! Simulate tpw from guess (forward model) - rp2=zero - do jj=1,nfldsig - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - rp2(i,j,jj)=rp2(i,j,jj) + ges_q(i,j,k,jj) * & - tpwcon*r10*(ges_prsi(i,j,k,jj)-ges_prsi(i,j,k+1,jj)) ! integrate q - end do - end do - end do - end do - - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipw = 4 ! index of pw observations - id=5 ! index of station id - itime=6 ! index of observation time in data array - ikxx=7 ! index of ob type - ipwmax=8 ! index of pw max error - iqc=9 ! index of quality mark - ier2=10 ! index of original-original obs error ratio - iuse=11 ! index of use parameter - ilone=12 ! index of longitude (degrees) - ilate=13 ! index of latitude (degrees) - istnelv=14 ! index of station elevation (m) - iobsprs=15 ! index of observation pressure (hPa) - iobshgt=16 ! index of observation height (m) - - do i=1,nobs - muse(i)=nint(data(11,i)) <= jiter - end do - - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l)) then - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - nchar=1 - ioff0=19 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - ii=0 - end if - - -! Prepare total precipitable water data - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - - dpw=data(ipw,i) - ikx = nint(data(ikxx,i)) - error=data(ier2,i) - - ratio_errors=error/data(ier,i) - error=one/error - endif ! (in_curbin) - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_pw_ob_type,ibin)%head)) then - obsdiags(i_pw_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_pw_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuppw: failure to allocate obsdiags',istat - call stop2(269) - end if - obsdiags(i_pw_ob_type,ibin)%tail => obsdiags(i_pw_ob_type,ibin)%head - else - allocate(obsdiags(i_pw_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuppw: failure to allocate obsdiags',istat - call stop2(270) - end if - obsdiags(i_pw_ob_type,ibin)%tail => obsdiags(i_pw_ob_type,ibin)%tail%next - end if - obsdiags(i_pw_ob_type,ibin)%n_alloc = obsdiags(i_pw_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_pw_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_pw_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_pw_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_pw_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_pw_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_pw_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_pw_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_pw_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_pw_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_pw_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_pw_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_pw_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_pw_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_pw_ob_type,ibin)%tail)) then - obsdiags(i_pw_ob_type,ibin)%tail => obsdiags(i_pw_ob_type,ibin)%head - else - obsdiags(i_pw_ob_type,ibin)%tail => obsdiags(i_pw_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_pw_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_pw_ob_type,ibin)%tail)') - end if - if (obsdiags(i_pw_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuppw: index error' - call stop2(271) - end if - endif - endif - - if(.not.in_curbin) cycle - - ! Interpolate model PW to obs location - call tintrp2a11(rp2,pwges,dlat,dlon,dtime, & - hrdifsig,mype,nfldsig) - -! Interpolate pressure at interface values to obs location - call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime, & - hrdifsig,nsig+1,mype,nfldsig) - - if(.not.l_pw_hgt_adjust) then - ! Compute innovation - ddiff = dpw - pwges - else - - ! Interpolate model q to obs location - call tintrp2a1(ges_q,qges,dlat,dlon,dtime, & - hrdifsig,nsig,mype,nfldsig) - - ! Interpolate model T_v to obs location - call tintrp2a1(ges_tv,tvges,dlat,dlon,dtime, & - hrdifsig,nsig,mype,nfldsig) - - ! Interpolate model z to obs location - call tintrp2a11(ges_z,zges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - ! Calculate difference in PW from station elevation to model surface elevation - pw_diff = (zges - data(istnelv,i)) * (prsitmp(1)*r1000*qges(1)) / (rd*tvges(1)) - - ! Compute innovation - ddiff = dpw - pw_diff - pwges - end if - - if (l_limit_pw_innov) then - ! Limit size of PW innovation to a percent of the background value - ddiff = sign(min(abs(ddiff),max_innov_pct*pwges),ddiff) - end if - -! Gross checks using innovation - - residual = abs(ddiff) - if (residual>grsmlt*data(ipwmax,i)) then - error = zero - ratio_errors=zero - if (luse(i)) awork(7) = awork(7)+one - end if - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - ratio = residual/obserrlm - if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else - ratio_errors=ratio_errors/sqrt(dup(i)) - end if - if (ratio_errors*error <= tiny_r_kind) muse(i)=.false. - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_pw_ob_type,ibin)%tail%muse(nobskeep) - - val = error*ddiff - - if(luse(i))then -! Compute penalty terms (linear & nonlinear qc). - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_pw=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_pw*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics as a function of observation type. - ress = ddiff*scale - ressw2= ress*ress - val2 = val*val - rat_err2 = ratio_errors**2 -! Accumulate statistics for obs belonging to this task - if (muse(i) ) then - if(rwgt < one) awork(21) = awork(21)+one - awork(5) = awork(5)+val2*rat_err2 - awork(4) = awork(4)+one - awork(22)=awork(22)+valqc - nn=1 - else - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - - end if - - if (luse_obsdiag) then - obsdiags(i_pw_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_pw_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_pw_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if ( .not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(pwhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - - allocate(my_head%dp(nsig),stat=istat) - if (istat/=0) write(6,*)'MAKECOBS: allocate error for pwhead_dp, istat=',istat - - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2= ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - -! Load the delta pressures at the obs location - do k=1,nsig - my_head%dp(k)=r10*(prsitmp(k)-prsitmp(k+1)) - end do - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_pw_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - - my_head => null() - endif - - -! Save select output for diagnostic file - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = data(iobsprs,i) ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input=one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst - if (err_final>tiny_r_kind) errinv_final=one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error - rdiagbuf(16,ii) = errinv_final ! final inverse observation error - - rdiagbuf(17,ii) = dpw ! total precipitable water obs (kg/m**2) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (kg/m**2) - rdiagbuf(19,ii) = dpw-pwges ! obs-ges w/o bias correction (kg/m**2) (future slot) - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_pw_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_pw_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_pw_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_pw_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - - - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:pw',i_pw_ob_type) - write(7)' pw',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::q', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::tv', ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get tv ... - varname='tv' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_tv))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_tv(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_tv(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get q ... - varname='q' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_q))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_q(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_q(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_q )) deallocate(ges_q ) - if(allocated(ges_tv)) deallocate(ges_tv) - if(allocated(ges_z )) deallocate(ges_z ) - end subroutine final_vars_ - -end subroutine setuppw diff --git a/src/setupq.f90 b/src/setupq.f90 deleted file mode 100755 index dea06d083..000000000 --- a/src/setupq.f90 +++ /dev/null @@ -1,1053 +0,0 @@ -subroutine setupq(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupq compute rhs of oi for moisture observations -! prgmmr: parrish org: np22 date: 1990-10-06 -! -! abstract: For moisture observations, this routine -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 1990-10-06 parrish -! 1998-04-10 weiyu yang -! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-17 treadon - update documentation -! 2004-08-02 treadon - add only to module use, add intent in/out -! 2004-10-06 parrish - increase size of qwork array for nonlinear qc -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list -! 2005-03-02 dee - remove garbage from diagnostic file -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-05-27 derber - level output change -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-06 treadon - lower huge_error to prevent overflow -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-10-21 su - modify variational qc and diagonose output -! 2005-11-03 treadon - correct error in ilone,ilate data array indices -! 2005-11-21 kleist - change to call to genqsat -! 2005-11-21 derber - correct error in use of qsges -! 2005-11-22 wu - add option to perturb conventional obs -! 2005-11-29 derber - remove psfcg and use ges_lnps instead -! 2006-01-31 todling - storing wgt/wgtlim in diag file instead of wgt only -! 2006-02-02 treadon - rename lnprsl as ges_lnprsl -! 2006-02-03 derber - fix bug in counting rlow and rhgh -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-03-21 treadon - modify optional perturbation to observation -! 2006-04-03 derber - eliminate unused arrays -! 2006-05-30 su,derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - modify handling of multiple data at same location -! 2006-07-31 kleist - use ges_ps instead of ln(ps) -! 2006-08-28 su - fix a bug in variational qc -! 2007-03-09 su - modify obs perturbation -! 2007-03-19 tremolet - binning of observations -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-08-28 su - modify gross check error -! 2008-03-24 wu - oberror tuning and perturb obs -! 2008-05-23 safford - rm unused vars and uses -! 2008-12-03 todling - changed handle of tail%time -! 2009-02-06 pondeca - for each observation site, add the following to the -! diagnostic file: local terrain height, dominate surface -! type, station provider name, and station subprovider name -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2011-05-06 Su - modify the observation gross check error -! 2011-08-09 pondeca - correct bug in qcgross use -! 2011-10-14 Hu - add code for adjusting surface moisture observation error -! 2011-10-14 Hu - add code for producing pseudo-obs in PBL -! 2011-12-14 wu - add code for rawinsonde level enhancement ( ext_sonde ) -! layer based on surface obs Q -! 2013-01-26 parrish - change grdcrd to grdcrd1, tintrp2a to tintrp2a1, tintrp2a11, -! tintrp3 to tintrp31 (so debug compile works on WCOSS) -! 2013-05-24 wu - move rawinsonde level enhancement ( ext_sonde ) to read_prepbufr -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-03-24 Hu - Use 2/3 of 2m Q and 1/3 of 1st level Q as background -! to calculate O-B for the surface moisture observations -! 2014-04-04 todling - revist q2m implementation (slightly) -! 2014-04-12 su - add non linear qc from Purser's scheme -! 2014-11-30 Hu - more option on use 2-m Q as background -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-02-09 Sienkiewicz - handling new KX drifting buoys (formerly ID'd by subtype 562) -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2017-03-31 Hu - addd option l_closeobs to use closest obs to analysis -! time in analysis -! 2017-03-31 Hu - addd option i_coastline to use observation operater -! for coastline area -! -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use m_obsdiags, only: qhead - use obsmod, only: rmiss_single,perturb_obs,oberror_tune,& - i_q_ob_type,obsdiags,lobsdiagsave,nobskeep,lobsdiag_allocated,& - time_offset - use m_obsNode, only: obsNode - use m_qNode, only: qNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset - use oneobmod, only: oneobtest,maginnov,magoberr - use guess_grids, only: ges_lnprsl,hrdifsig,nfldsig,ges_tsen,ges_prsl,pbl_height - use gridmod, only: lat2,lon2,nsig,get_ijk,twodvar_regional - use constants, only: zero,one,r1000,r10,r100 - use constants, only: huge_single,wgtlim,three - use constants, only: tiny_r_kind,five,half,two,huge_r_kind,cg_term,r0_01 - use qcmod, only: npres_print,ptopq,pbotq,dfact,dfact1,njqc,vqc - use jfunc, only: jiter,last,jiterstart,miter - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use converr_q, only: ptabl_q - use converr, only: ptabl - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use rapidrefresh_cldsurf_mod, only: l_sfcobserror_ramp_q - use rapidrefresh_cldsurf_mod, only: l_pbl_pseudo_surfobsq,pblh_ration,pps_press_incr, & - i_use_2mq4b,l_closeobs,i_coastline - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare local parameters - real(r_kind),parameter:: small1=0.0001_r_kind - real(r_kind),parameter:: small2=0.0002_r_kind - real(r_kind),parameter:: r0_7=0.7_r_kind - real(r_kind),parameter:: r8=8.0_r_kind - real(r_kind),parameter:: r0_001 = 0.001_r_kind - real(r_kind),parameter:: r1e16=1.e16_r_kind - character(len=*),parameter:: myname='setupq' - -! Declare external calls for code analysis - external:: tintrp2a1,tintrp2a11 - external:: tintrp31 - external:: grdcrd1 - external:: genqsat - external:: stop2 - -! Declare local variables - - real(r_double) rstation_id - real(r_kind) qob,qges,qsges,q2mges,q2mges_water - real(r_kind) ratio_errors,dlat,dlon,dtime,dpres,rmaxerr,error - real(r_kind) rsig,dprpx,rlow,rhgh,presq,tfact,ramp - real(r_kind) psges,sfcchk,ddiff,errorx - real(r_kind) cg_q,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2,qcgross - real(r_kind) grsmlt,ratio,val2,obserror - real(r_kind) obserrlm,residual,ressw2,scale,ress,huge_error,var_jb - real(r_kind) val,valqc,rwgt,prest - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nele,nobs):: data - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(lat2,lon2,nsig,nfldsig):: qg - real(r_kind),dimension(lat2,lon2,nfldsig):: qg2m - real(r_kind),dimension(nsig):: prsltmp - real(r_kind),dimension(34):: ptablq - real(r_single),allocatable,dimension(:,:)::rdiagbuf - real(r_single),allocatable,dimension(:,:)::rdiagbufp - - - integer(i_kind) i,nchar,nreal,ii,l,jj,mm1,itemp,iip - integer(i_kind) jsig,itype,k,nn,ikxx,iptrb,ibin,ioff,ioff0,icat,ijb - integer(i_kind) ier,ilon,ilat,ipres,iqob,id,itime,ikx,iqmax,iqc - integer(i_kind) ier2,iuse,ilate,ilone,istnelv,iobshgt,istat,izz,iprvd,isprvd - integer(i_kind) idomsfc,iderivative - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf,cdiagbufp - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical ice,proceed - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(qNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - real(r_kind) :: thispbl_height,ratio_PBL_height,prestsfc,diffsfc - real(r_kind) :: hr_offset - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q - real(r_kind),allocatable,dimension(:,:,: ) :: ges_q2m - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!******************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - iqob=5 ! index of q observation - id=6 ! index of station id - itime=7 ! index of observation time in data array - ikxx=8 ! index of ob type - iqmax=9 ! index of max error - itemp=10 ! index of dry temperature - iqc=11 ! index of quality mark - ier2=12 ! index of original-original obs error ratio - iuse=13 ! index of use parameter - idomsfc=14 ! index of dominant surface type - ilone=15 ! index of longitude (degrees) - ilate=16 ! index of latitude (degrees) - istnelv=17 ! index of station elevation (m) - iobshgt=18 ! index of observation height (m) - izz=19 ! index of surface height - iprvd=20 ! index of observation provider - isprvd=21 ! index of observation subprovider - icat =22 ! index of data level category - ijb =23 ! index of non linear qc parameter - iptrb=24 ! index of q perturbation - - var_jb=zero - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - var_jb=zero - -! choose only one observation--arbitrarily choose the one with positive time departure -! handle multiple-reported data at a station - - hr_offset=min_offset/60.0_r_kind - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ipres,k) == data(ipres,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - if(l_closeobs) then - if(abs(data(itime,k)-hr_offset)1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_q_ob_type,ibin)%head)) then - obsdiags(i_q_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_q_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupq: failure to allocate obsdiags',istat - call stop2(272) - end if - obsdiags(i_q_ob_type,ibin)%tail => obsdiags(i_q_ob_type,ibin)%head - else - allocate(obsdiags(i_q_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupq: failure to allocate obsdiags',istat - call stop2(273) - end if - obsdiags(i_q_ob_type,ibin)%tail => obsdiags(i_q_ob_type,ibin)%tail%next - end if - obsdiags(i_q_ob_type,ibin)%n_alloc = obsdiags(i_q_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_q_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_q_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_q_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_q_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_q_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_q_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_q_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_q_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_q_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_q_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_q_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_q_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_q_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_q_ob_type,ibin)%tail)) then - obsdiags(i_q_ob_type,ibin)%tail => obsdiags(i_q_ob_type,ibin)%head - else - obsdiags(i_q_ob_type,ibin)%tail => obsdiags(i_q_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_q_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_q_ob_type,ibin)%tail)') - end if - if (obsdiags(i_q_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupq: index error' - call stop2(274) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Interpolate log(ps) & log(pres) at mid-layers to obs locations/times - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - - presq=r10*exp(dpres) - itype=ictype(ikx) - dprpx=zero - if(((itype > 179 .and. itype < 190) .or. itype == 199) & - .and. .not.twodvar_regional)then - dprpx=abs(one-exp(dpres-log(psges)))*r10 - end if - -! Put obs pressure in correct units to get grid coord. number - call grdcrd1(dpres,prsltmp(1),nsig,-1) - -! Get approximate k value of surface by using surface pressure - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp(1),nsig,-1) - -! Check to see if observations is above the top of the model (regional mode) - if( dpres>=nsig+1)dprpx=1.e6_r_kind - if((itype > 179 .and. itype < 186) .or. itype == 199) dpres=one - -! Scale errors by guess saturation q - - call tintrp31(qg,qsges,dlat,dlon,dpres,dtime,hrdifsig,& - mype,nfldsig) - -! Interpolate 2-m qs to obs locations/times - if((i_use_2mq4b > 0) .and. ((itype > 179 .and. itype < 190) .or. itype == 199) & - .and. .not.twodvar_regional)then - call tintrp2a11(qg2m,qsges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) - endif - -! Load obs error and value into local variables - obserror = max(cermin(ikx)*r0_01,min(cermax(ikx)*r0_01,data(ier,i))) - qob = data(iqob,i) - - rmaxerr=rmaxerr*qsges - rmaxerr=max(small2,rmaxerr) - errorx =(data(ier,i)+dprpx)*qsges - -!JS - MOVED TO HERE -! Interpolate guess moisture to observation location and time - call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - - -! Setup dynamic ob error specification for aircraft recon in hurricanes - if (itype == 136 ) then - ddiff=qob-qges - errorx = 1.4_r_kind*abs(ddiff)+.0003_r_kind - endif - - if (itype == 137 ) then - ddiff=qob-qges - errorx = abs(ddiff)+0.0002_r_kind - endif - - errorx =max(small1,errorx) - - -! Adjust observation error to reflect the size of the residual. -! If extrapolation occurred, then further adjust error according to -! amount of extrapolation. - - rlow=max(sfcchk-dpres,zero) -! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] - if(l_sfcobserror_ramp_q) then - ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)*0.001_r_kind - else - ramp=rlow - endif - - rhgh=max(dpres-r0_001-rsig,zero) - - if(luse(i))then - awork(1) = awork(1) + one - if(rlow/=zero) awork(2) = awork(2) + one - if(rhgh/=zero) awork(3) = awork(3) + one - end if - - ratio_errors=error*qsges/(errorx+1.0e6_r_kind*rhgh+r8*ramp) - -! Check to see if observations is above the top of the model (regional mode) - if (dpres > rsig) ratio_errors=zero - error=one/(error*qsges) - -!JS - MOVING THIS UP A FEW LINES -! Interpolate guess moisture to observation location and time -! call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, & -! hrdifsig,mype,nfldsig) - -! Interpolate 2-m q to obs locations/times - if(i_use_2mq4b>0 .and. itype > 179 .and. itype < 190 .and. .not.twodvar_regional)then - - if(i_coastline==2 .or. i_coastline==3) then -! Interpolate guess th 2m to observation location and time - call tintrp2a11_csln(ges_q2m,q2mges,q2mges_water,dlat,dlon,dtime,hrdifsig,mype,nfldsig) - if(abs(qob-q2mges) > abs(qob-q2mges_water)) q2mges=q2mges_water - else - call tintrp2a11(ges_q2m,q2mges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) - endif - - if(i_use_2mq4b==1)then - qges=0.33_r_single*qges+0.67_r_single*q2mges - elseif(i_use_2mq4b==2) then - if(q2mges >= qges) then - q2mges=min(q2mges, 1.15_r_single*qges) - else - q2mges=max(q2mges, 0.85_r_single*qges) - end if - qges=q2mges - else - write(6,*) 'Invalid i_use_2mq4b number=',i_use_2mq4b - call stop2(100) - endif - endif - - ddiff=qob-qges - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov*1.e-3_r_kind - error=one/(magoberr*1.e-3_r_kind) - ratio_errors=one - end if - -! Gross error checks - - if(abs(ddiff) > grsmlt*data(iqmax,i)) then - error=zero - ratio_errors=zero - - - if(luse(i))awork(5)=awork(5)+one - end if - obserror=min(one/max(ratio_errors*error,tiny_r_kind),huge_error) - obserror=obserror*r100/qsges - obserrlm=max(cermin(ikx),min(cermax(ikx),obserror)) - residual=abs(ddiff*r100/qsges) - ratio=residual/obserrlm - -! modify gross check limit for quality mark=3 - if(data(iqc,i) == three ) then - qcgross=r0_7*cgross(ikx) - else - qcgross=cgross(ikx) - endif - - if (twodvar_regional) then - if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) & - qcgross=three*qcgross - endif - - if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then - if(luse(i))awork(4)=awork(4)+one - error=zero - ratio_errors=zero - - else - ratio_errors = ratio_errors/sqrt(dup(i)) - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_q_ob_type,ibin)%tail%muse(nobskeep) - -! Oberror Tuning and Perturb Obs - if(muse(i)) then - if(oberror_tune )then - if( jiter > jiterstart ) then - ddiff=ddiff+data(iptrb,i)/error/ratio_errors - endif - else if(perturb_obs )then - ddiff=ddiff+data(iptrb,i)/error/ratio_errors - endif - endif - - -! Compute penalty terms - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if(njqc .and. var_jb>tiny_r_kind .and. var_jb < 10.0_r_kind .and. error >tiny_r_kind) then - if(exp_arg == zero) then - wgt=one - else - wgt=ddiff*error/sqrt(two*var_jb) - wgt=tanh(wgt)/wgt - endif - term=-two*var_jb*rat_err2*log(cosh((val)/sqrt(two*var_jb))) - rwgt = wgt/wgtlim - valqc = -two*term - else if (vqc .and. cvar_pg(ikx)> tiny_r_kind .and. error >tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_q=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_q*wnotgross) - term =log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term - else - term = exp_arg - wgt =one - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term - endif - -! Accumulate statistics for obs belonging to this task - if(muse(i))then - if(rwgt < one) awork(21) = awork(21)+one - jsig = dpres - jsig=max(1,min(jsig,nsig)) - awork(jsig+5*nsig+100)=awork(jsig+5*nsig+100)+val2*rat_err2 - awork(jsig+6*nsig+100)=awork(jsig+6*nsig+100)+one - awork(jsig+3*nsig+100)=awork(jsig+3*nsig+100)+valqc - end if -! Loop over pressure level groupings and obs to accumulate statistics -! as a function of observation type. - ress = scale*r100*ddiff/qsges - ressw2= ress*ress - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - do k = 1,npres_print - if(presq > ptopq(k) .and. presq <= pbotq(k))then - - bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count - bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ress ! (o-g) - bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty - end if - end do - end if - - if (luse_obsdiag) then - obsdiags(i_q_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_q_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_q_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(qhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j,k) indices of guess gridpoint that bound obs location - my_head%dlev= dpres - call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2= ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%jb = var_jb - my_head%luse = luse(i) - - if(oberror_tune) then - my_head%qpertb=data(iptrb,i)/error/ratio_errors - my_head%kx=ikx - if (njqc) then - ptablq=ptabl_q - else - ptablq=ptabl - endif - if(presq > ptablq(2))then - my_head%k1=1 - else if( presq <= ptablq(33)) then - my_head%k1=33 - else - k_loop: do k=2,32 - if(presq > ptablq(k+1) .and. presq <= ptablq(k)) then - my_head%k1=k - exit k_loop - endif - enddo k_loop - endif - endif - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_q_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - - my_head => null() - endif - -! Save select output for diagnostic file - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = presq ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = var_jb ! non linear qc b parameter - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i)*qsges ! convert rh to q - err_adjst = data(ier,i)*qsges ! convert rh to q - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse observation error - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error - rdiagbuf(16,ii) = errinv_final ! final inverse observation error - - rdiagbuf(17,ii) = data(iqob,i) ! observation - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis - rdiagbuf(19,ii) = qob-qges ! obs-ges w/o bias correction (future slot) - - rdiagbuf(20,ii) = qsges ! guess saturation specific humidity - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_q_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_q_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_q_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_q_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - -!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!! - if( .not. last .and. l_pbl_pseudo_surfobsq .and. & - ( itype==181 .or. itype==183 .or.itype==187 ) .and. & - muse(i) .and. dpres > -1.0_r_kind ) then - prestsfc=prest - diffsfc=ddiff - call tintrp2a11(pbl_height,thispbl_height,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - ratio_PBL_height = (prest - thispbl_height) * pblh_ration - if(ratio_PBL_height > zero) thispbl_height = prest - ratio_PBL_height - prest = prest - pps_press_incr - DO while (prest > thisPBL_height) - ratio_PBL_height=1.0_r_kind-(prestsfc-prest)/(prestsfc-thisPBL_height) - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(qhead(ibin),my_node) - my_node => null() - -!!! find qob - qob = data(iqob,i) - -! Put obs pressure in correct units to get grid coord. number - dpres=log(prest/r10) - call grdcrd1(dpres,prsltmp(1),nsig,-1) - - -! Interpolate guess moisture to observation location and time - call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - call tintrp31(qg,qsges,dlat,dlon,dpres,dtime,hrdifsig,& - mype,nfldsig) - -!!! Set (i,j,k) indices of guess gridpoint that bound obs location - my_head%dlev= dpres - call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) -!!! find ddiff - -! Compute innovations - ddiff=diffsfc*(0.3_r_kind + 0.7_r_kind*ratio_PBL_height) - - error=one/(data(ier2,i)*qsges) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%jb = var_jb - my_head%luse = luse(i) - if (luse_obsdiag) & - my_head%diags => obsdiags(i_q_ob_type,ibin)%tail - -! Save select output for diagnostic file - if(conv_diagsave .and. luse(i))then - iip=iip+1 - if(iip <= 3*nobs ) then - rstation_id = data(id,i) - cdiagbufp(iip) = station_id ! station id - - rdiagbufp(1,iip) = ictype(ikx) ! observation type - rdiagbufp(2,iip) = icsubtype(ikx) ! observation subtype - - rdiagbufp(3,iip) = data(ilate,i) ! observation latitude (degrees) - rdiagbufp(4,iip) = data(ilone,i) ! observation longitude (degrees) - rdiagbufp(5,iip) = data(istnelv,i) ! station elevation (meters) - rdiagbufp(6,iip) = prest !presq ! observation pressure (hPa) - rdiagbufp(7,iip) = data(iobshgt,i) ! observation height (meters) - rdiagbufp(8,iip) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbufp(9,iip) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbufp(10,iip) = var_jb ! non linear qc b parameter - rdiagbufp(11,iip) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbufp(12,iip) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbufp(12,iip) = -one - endif - - err_input = data(ier2,i)*qsges ! convert rh to q - err_adjst = data(ier,i)*qsges ! convert rh to q - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbufp(13,iip) = rwgt ! nonlinear qc relative weight - rdiagbufp(14,iip) = errinv_input ! prepbufr inverse observation error - rdiagbufp(15,iip) = errinv_adjst ! read_prepbufr inverse obs error - rdiagbufp(16,iip) = errinv_final ! final inverse observation error - - rdiagbufp(17,iip) = data(iqob,i) ! observation - rdiagbufp(18,iip) = ddiff ! obs-ges used in analysis - rdiagbufp(19,iip) = ddiff !qob-qges ! obs-ges w/o bias correction (future slot) - - rdiagbufp(20,iip) = qsges ! guess saturation specific humidity - else - iip=3*nobs - endif - endif !conv_diagsave .and. luse(i)) - - prest = prest - pps_press_incr - - my_head => null() - ENDDO - - endif ! 181,183,187 -!!!!!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!!!!!!!!! - -! End of loop over observations - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:q',i_q_ob_type) - write(7)' q',nchar,nreal,ii+iip,mype,ioff0 - if(l_pbl_pseudo_surfobsq .and. iip>0) then - write(7)cdiagbuf(1:ii),cdiagbufp(1:iip),rdiagbuf(:,1:ii),rdiagbufp(:,1:iip) - deallocate(cdiagbufp,rdiagbufp) - else - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - endif - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::u' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::v' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::tv', ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get q2m ... - if (i_use_2mq4b>0) then - varname='q2m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_q2m))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_q2m(size(rank2,1),size(rank2,2),nfldsig)) - ges_q2m(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_q2m(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - endif ! i_use_2mq4b -! get q ... - varname='q' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_q))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_q(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_q(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_q2m)) deallocate(ges_q2m) - if(allocated(ges_q )) deallocate(ges_q ) - if(allocated(ges_ps)) deallocate(ges_ps) - end subroutine final_vars_ - -end subroutine setupq - diff --git a/src/setuprad.f90 b/src/setuprad.f90 deleted file mode 100644 index 1ca3f0e0c..000000000 --- a/src/setuprad.f90 +++ /dev/null @@ -1,2061 +0,0 @@ - subroutine setuprad(lunin,mype,aivals,stats,nchanl,nreal,nobs,& - obstype,isis,is,rad_diagsave,init_pass,last_pass) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuprad compute rhs of oi equation for radiances -! prgmmr: derber org: np23 date: 1995-07-06 -! -! abstract: read in data, first guess, and obtain rhs of oi equation -! for radiances. -! -! program history log: -! 1995-07-06 derber -! 1996-11-xx wu, data from prepbufr file -! 1996-12-xx mcnally, changes for diagnostic file and bugfix -! 1998-04-30 weiyu yang mpi version -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2003-12-23 kleist - remove sigma assumptions (use pressure) -! 2004-05-28 kleist - subroutine call update -! 2004-06-17 treadon - update documenation -! 2004-07-23 weng,yan,okamoto - incorporate MW land and snow/ice emissivity -! models for AMSU-A/B and SSM/I -! 2004-08-02 treadon - add only to module use, add intent in/out -! 2004-10-06 parrish - modifications for nonlinear qc -! 2004-10-15 derber - modify parts of IR quality control -! 2004-10-28 treadon - replace parameter tiny with tiny_r_kind -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-11-30 xu li - add SST physical retrieval algorithm -! 2004-12-22 treadon - add outer loop number to name of diagnostic file -! 2005-01-20 okamoto - add ssm/i radiance assimilation -! 2005-01-22 okamoto - add TB jacobian with respect to ocean surface wind -! through MW ocean emissivity model -! 2005-02-22 derber - alter surface determination and improve quality control -! 2005-02-28 treadon - increase size of character variable holding diagnostic -! file name -! 2005-03-02 derber - modify use of surface flages and quality control -! and adjoint of surface emissivity -! 2005-03-04 xu li - restructure code related to sst retrieval -! 2005-03-07 todling,treadon - place lower bound on sum2 -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-03-16 derber - save observation time -! 2005-04-11 treadon - add logical to toggle on/off nonlinear qc code -! 2005-04-18 treadon - modify sections of code related to sst retrieval -! 2005-06-01 treadon - add code to load/use extended vertical profile arrays in rtm -! 2005-07-06 derber - modify for mhs and hirs/4 -! 2005-07-29 treadon - modify tnoise initialization; add varinv_use -! 2005-09-20 xu,pawlak - modify sections of code related to ssmis -! 2005-09-28 derber - modify for new radinfo and surface info input from read routines -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-10-17 treadon - generalize accessing of elements from obs array -! 2005-10-20 kazumori - modify sections of code related to amsre -! 2005-11-04 derber - place lower bound (0.0) on computed clw -! 2005-11-14 li - modify avhrr related code -! 2005-11-18 treadon - correct thin snow test to apply to microwave -! 2005-11-18 kazumori - modify sections of amsre diagnostic file -! 2005-11-29 parrish - remove call to deter_sfc_reg (earlier patch for regional mode) -! 2005-12-16 derber - add check on skin temperature to clw bias correction -! 2005-12-20 derber - add transmittance qc check to mw sensors -! 2006-01-09 treadon - introduce get_ij -! 2006-01-12 treadon - replace pCRTM with CRTM -! 2006-01-31 todling - add obs time to output diag files -! 2006-02-01 liu - add ssu -! 2006-02-02 treadon - rename prsi(l) as ges_prsi(l) -! 2006-02-03 derber - add new obs control and change printed stats -! 2006-03-21 treadon - add optional perturbation to observation -! 2006-03-24 treadon - bug fix - add iuse_rad to microwave channel varinv check -! 2006-04-19 treadon - rename emisjac as dtbduv_on (accessible via obsmod) -! 2006-04-27 derber - remove rad_tran_k, process data one profile at a time -! write data in jppf chunks -! 2006-05-10 derber - add check on maximum number of levels for RT -! 2006-05-30 derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-27 kazumori - modify factor of bc predictor(clw) for AMSR-E -! and input of qcssmi -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - unify NL qc and add satellite and solar azimuth angles -! 2006-07-31 kleist - change call to intrppx, no longer get ps at ob location -! 2006-12-21 sienkiewicz - add 'no85GHz' flag for F8 SSM/I -! 2007-01-24 kazumori- modify to qcssmi subroutine output and use ret_ssmis -! for ssmis_las only (assumed UKMO SSMIS data) -! 2007-03-09 su - remove the perturbation to the observation -! 2007-03-19 tremolet - binning of observations -! 2007-04-04 wu - do not load ozone jacobian if running regional mode -! 2007-05-30 h.liu - replace c1 with constoz in ozone jacobian -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-06-08 kleist/treadon - add prefix (task id or path) to diag_rad_file -! 2007-06-29 jung - update CRTM interface -! 2008-01-30 h.liu/treadon - add SSU cell pressure correction block -! 2008-05-21 safford - rm unused vars and uses -! 2008-12-03 todling - changed handle of tail%time -! 2009-12-07 b.yan - changed qc for channel 5 (relaxed) -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(), and -! new arguments init_pass and last_pass. -! 2009-12-08 guo - cleaned diag output rewind with open(position='rewind') -! - fixed a bug in diag header output while is not init_pass. -! 2010-03-01 gayno - allow assimilation of "mixed" amsua fovs -! 2010-03-30 collard - changes for interface with CRTM v2.0. -! 2010-03-30 collard - Add CO2 interface (fixed value for now). -! 2010-04-08 h.liu -add SEVIRI assimilation -! 2010-04-16 hou/kistler add interface to module ncepgfs_ghg -! 2010-04-29 zhu - add option newpc4pred for new preconditioning for predictors -! 2010-05-06 zhu - add option adp_anglebc variational angle bias correction -! 2010-05-13 zhu - add option passive_bc for bias correction of passive channels -! 2010-05-19 todling - revisit intrppx CO2 handle -! 2010-06-10 todling - reduce pointer check by getting CO2 pointer at this level -! - start adding hooks of aerosols influence on RTM -! 2010-07-15 kleist - reintroduce capability to write out predictor terms (not predicted bias) and -! pressure level that corresponds to peak of weighting function -! 2010-07-16 yan - update quality control of mw water vapor sounding channels (amsu-b and mhs) -! - add a new input (tbc) to in call qcssmi(..) and -! remove 'ssmis_uas,ssmis_las,ssmis_env,ssmis_img' in call qcssmi(..) -! Purpose: to keep the consistent changes with qcssmi.f90 -! 2010-08-10 wu - setup corresponding vegetation types (nmm_to_crtm) for IGBP in regional -! parameter nvege_type: old=24, IGBP=20 -! 2010-08-17 derber - move setup input and crtm call to crtm_interface (intrppx) to simplify routine -! 2010-09-30 zhu - re-order predterms and predbias -! 2010-12-16 treadon - move cbias update before calc_clw -! 2011-02-17 todling - add knob to turn off O3 Jacobian from IR instruments (per Emily Liu's work) -! 2011-03-13 li - (1) associate nst_gsi and nstinfo (use radinfo) to handle nst fields -! - (2) modify to save nst analysis related diagnostic variables -! 2011-04-07 todling - newpc4pred now in radinfo -! 2011-05-04 todling - partially merge in Min-Jeong Kim's cloud clear assimilation changes (connect to Metguess) -! 2011-05-16 todling - generalize handling of jacobian matrix entries -! 2011-05-20 mccarty - updated for ATMS -! 2011-06-08 zhu - move assignments of tnoise_cld values to satinfo file via varch_cld, use lcw4crtm -! 2011-06-09 sienkiewicz - call to qc_ssu needs tb_obs instead of tbc -! 2011-07-10 zhu - add jacobian assignments for regional cloudy radiance -! 2011-09-28 collard - Fix error trapping for CRTM failures. -! 2012-05-12 todling - revisit opts in gsi_metguess_get (4crtm) -! 2012-11-02 collard - Use cloud detection channel flag for IR. -! 2013-02-13 eliu - Add options for SSMIS instruments -! - Add two additional bias predictors for SSMIS radiances -! - Tighten up QC checks for SSMIS - -! 2013-02-19 sienkiewicz - add adjustable preweighting for SSMIS bias terms -! 2013-07-10 zhu - add upd_pred as an update indicator for bias correction coeficitient -! 2013-07-19 zhu - add emissivity sensitivity predictor for radiance bias correction -! 2013-11-19 sienkiewicz - merge back in changes for adjustable preweighting for SSMIS bias terms -! 2013-11-21 todling - inquire diag-file version using get_radiag -! 2013-12-10 zhu - apply bias correction to tb_obs for ret_amsua calculation -! 2013-12-21 eliu - add amsu-a obs errors for allsky condition -! 2013-12-21 eliu - add error handling for CLWP calculation for allsky -! 2014-01-17 zhu - add cld_rbc_idx for bias correction sample to handle cases with cloud -! inconsistency between obs and first guess for all-sky microwave radiance -! 2014-01-19 zhu - add scattering index calculation, add it as a predictor for allsky -! - calculate retrieved clw using bias-corrected tsim -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-01-31 mkim - Remove abs(60.0degree) boundary which existed for all-sky MW radiance DA -! 2014-02-01 mkim - Move all-sky mw obserr to subroutine obserr_allsky_mw -! 2014-02-05 todling - Remove overload of diagbufr slot (not allowed) -! 2014-04-17 todling - Implement inter-channel ob correlated covariance capability -! 2014-04-27 eliu - change qc_amsua/atms interface -! 2014-04-27 eliu - change call_crtm interface to output clear-sky Tb under all-sky condition (optional) -! 2014-04-27 eliu - add cloud effect calculation for AMSU-A/ATMS under all-sky condition -! 2014-05-29 thomas - add lsingleradob capability (originally of mccarty) -! 2014-08-01 zhu - remove scattering index predictor -! - add all-sky obs error adjustment based on scattering index, diff of clw, -! cloud mismatch info, and surface wind speed -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-01-15 zhu - change amsua quality control interface to apply emissivity sensitivity -! screen to all-sky AMSUA and ATMS radiance -! 2015-01-16 ejones - Added call to qc_gmi for gmi observations -! - Added saphir -! 2015-02-12 ejones - Write gwp to diag file for GMI -! 2015-03-11 ejones - Added call to qc_amsr2 for amsr2 observations -! 2015-03-23 ejones - Added call to qc_saphir for saphir observations -! 2015-03-23 zaizhong ma - add Himawari-8 ahi -! 2014-08-06 todling - Correlated obs now platform-instrument specific -! 2014-09-02 todling - Must protect NST-related diag out for when NST is on -! 2014-09-03 j.jin - Added GMI 1CR radiance, obstype=gmi. -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-03-31 zhu - move cloudy AMSUA radiance observation error adjustment to qcmod.f90; -! change quality control interface for AMSUA and ATMS. -! 2015-04-01 W. Gu - add isis to obs type -! 2015-08-18 W. Gu - include the dependence of the correlated obs errors on the surface types. -! 2015-09-04 J.Jung - Added mods for CrIS full spectral resolution (FSR). -! 2015-09-10 zhu - generalize enabling all-sky and aerosol usage in radiance assimilation. -! Use radiance_obstype_search & type extentions from radiance_mod. -! - special obs error & bias correction handlings are called from centralized module -! 2015-09-30 ejones - Pull AMSR2 sun azimuth and sun zenith angles for passing to quality control, -! modify qc_amsr2 function call -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-02-15 zhu - remove the code forcing zero Jacobians for qr,qs,qg,qh for regional, let users decide -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(n) -! . removed (%dlat,%dlon) debris. -! 2016-07-19 W. Gu - add isis to obs type -! 2016-07-19 W. Gu - include the dependence of the correlated obs errors on the surface types -! 2016-07-19 kbathmann -move eigendecomposition for correlated obs here -! 2016-10-23 zhu - add cloudy radiance assimilation for ATMS -! -! input argument list: -! lunin - unit from which to read radiance (brightness temperature, tb) obs -! mype - mpi task id -! nchanl - number of channels per obs -! nreal - number of pieces of non-tb information per obs -! nobs - number of tb observations to process -! obstype - type of tb observation -! isis - sensor/instrument/satellite id ex.amsua_n15 -! is - integer counter for number of observation types to process -! rad_diagsave - logical to switch on diagnostic output (.false.=no output) -! channelinfo - structure containing satellite sensor information -! -! output argument list: -! aivals - array holding sums for various statistics as a function of obs type -! stats - array holding sums for various statistics as a function of channel -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - - use mpeu_util, only: die,perr,getindex - use kinds, only: r_kind,r_single,i_kind - use crtm_spccoeff, only: sc - use radinfo, only: nuchan,tlapmean,predx,cbias,ermax_rad,tzr_qc,& - npred,jpch_rad,varch,varch_cld,iuse_rad,icld_det,nusis,fbias,retrieval,b_rad,pg_rad,& - air_rad,ang_rad,adp_anglebc,angord,ssmis_precond,emiss_bc,upd_pred, & - passive_bc,ostats,rstats,newpc4pred,radjacnames,radjacindxs,nsigradjac - use gsi_nstcouplermod, only: nstinfo - use read_diag, only: get_radiag,ireal_radiag,ipchan_radiag - use guess_grids, only: sfcmod_gfs,sfcmod_mm5,comp_fact10 - use m_prad, only: radheadm - use m_obsdiags, only: radhead - use obsmod, only: ianldate,ndat,mype_diaghdr,nchan_total, & - dplat,dtbduv_on,& - i_rad_ob_type,obsdiags,obsptr,lobsdiagsave,nobskeep,lobsdiag_allocated,& - dirname,time_offset,lwrite_predterms,lwrite_peakwt,reduce_diag - use m_obsNode, only: obsNode - use m_radNode, only: radNode, radNode_typecast - use m_obsLList, only: obsLList_appendNode - use m_obsLList, only: obsLList_tailNode - use obsmod, only: obs_diag,luse_obsdiag,dval_use - use gsi_4dvar, only: nobs_bins,hr_obsbin,l4dvar - use gridmod, only: nsig,regional,get_ij - use satthin, only: super_val1 - use constants, only: quarter,half,tiny_r_kind,zero,one,deg2rad,rad2deg,one_tenth, & - two,three,cg_term,wgtlim,r100,r10,r0_01,r_missing - use jfunc, only: jiter,miter,jiterstart - use sst_retrieval, only: setup_sst_retrieval,avhrr_sst_retrieval,& - finish_sst_retrieval,spline_cub - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use crtm_interface, only: init_crtm,call_crtm,destroy_crtm,sensorindex,surface, & - itime,ilon,ilat,ilzen_ang,ilazi_ang,iscan_ang,iscan_pos,iszen_ang,isazi_ang, & - ifrac_sea,ifrac_lnd,ifrac_ice,ifrac_sno,itsavg, & - izz,idomsfc,isfcr,iff10,ilone,ilate, & - isst_hires,isst_navy,idata_type,iclr_sky,itref,idtw,idtc,itz_tr - use clw_mod, only: calc_clw, ret_amsua - use qcmod, only: qc_ssmi,qc_seviri,qc_ssu,qc_avhrr,qc_goesimg,qc_msu,qc_irsnd,qc_amsua,qc_mhs,qc_atms - use qcmod, only: igood_qc,ifail_gross_qc,ifail_interchan_qc,ifail_crtm_qc,ifail_satinfo_qc,qc_noirjaco3,ifail_cloud_qc - use qcmod, only: qc_gmi,qc_saphir,qc_amsr2 - use qcmod, only: setup_tzr_qc,ifail_scanedge_qc,ifail_outside_range - use oneobmod, only: lsingleradob,obchan,oblat,oblon,oneob_type - use radinfo, only: radinfo_adjust_jacobian,radinfo_get_rsqrtinv - use radiance_mod, only: rad_obs_type,radiance_obstype_search,radiance_ex_obserr,radiance_ex_biascor - - - - - - - implicit none - -! Declare passed variables - logical ,intent(in ) :: rad_diagsave - character(10) ,intent(in ) :: obstype - character(20) ,intent(in ) :: isis - integer(i_kind) ,intent(in ) :: lunin,mype,nchanl,nreal,nobs,is - real(r_kind),dimension(40,ndat) ,intent(inout) :: aivals - real(r_kind),dimension(7,jpch_rad),intent(inout) :: stats - logical ,intent(in ) :: init_pass,last_pass ! state of "setup" processing - -! Declare external calls for code analysis - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r1e10=1.0e10_r_kind - character(len=*),parameter:: myname="setuprad" - -! Declare local variables - character(128) diag_rad_file - - integer(i_kind) iextra,jextra,error_status,istat - integer(i_kind) ich9,isli,icc,iccm,mm1,ixx - integer(i_kind) m,mm,jc,j,k,i - integer(i_kind) n,nlev,kval,ibin,ioff,ioff0,iii - integer(i_kind) ii,jj,idiag,inewpc,nchanl_diag - integer(i_kind) ii_ptr - integer(i_kind) nadir,kraintype,ierrret - integer(i_kind) ioz,ius,ivs,iwrmype - integer(i_kind) iversion_radiag, istatus - integer(i_kind) isfctype - - real(r_single) freq4,pol4,wave4,varch4,tlap4 - real(r_kind) node - real(r_kind) term,tlap,tb_obsbc1 - real(r_kind) drad,dradnob,varrad,error,errinv,useflag - real(r_kind) cg_rad,wgross,wnotgross,wgt,arg,exp_arg - real(r_kind) tzbgr,tsavg5,trop5,pangs,cld,cldp - real(r_kind) cenlon,cenlat,slats,slons,zsges,zasat,dtime -! real(r_kind) wltm1,wltm2,wltm3 - real(r_kind) ys_bias_sst,cosza,val_obs - real(r_kind) sstnv,sstcu,sstph,dtp_avh,dta,dqa - real(r_kind) bearaz,sun_zenith,sun_azimuth - real(r_kind) sfc_speed,frac_sea,clw,tpwc,sgagl,clwp_amsua,tpwc_amsua,tpwc_guess_retrieval - real(r_kind) gwp,clw_obs - real(r_kind) scat,scatp - real(r_kind) dtsavg,r90,coscon,sincon - real(r_kind) bias - real(r_kind) factch6 - - logical hirs2,msu,goessndr,hirs3,hirs4,hirs,amsua,amsub,airs,hsb,goes_img,ahi,mhs - logical avhrr,avhrr_navy,lextra,ssu,iasi,cris,seviri,atms - logical ssmi,ssmis,amsre,amsre_low,amsre_mid,amsre_hig,amsr2,gmi,saphir - logical ssmis_las,ssmis_uas,ssmis_env,ssmis_img - logical sea,mixed,land,ice,snow,toss,l_may_be_passive,eff_area - logical microwave, microwave_low - logical no85GHz - logical in_curbin, in_anybin - logical account_for_corr_obs - logical,dimension(nobs):: zero_irjaco3_pole - -! Declare local arrays - - real(r_single),dimension(ireal_radiag):: diagbuf - real(r_single),allocatable,dimension(:,:):: diagbufex - real(r_single),allocatable,dimension(:,:):: diagbufchan - - real(r_kind),dimension(npred+2):: predterms - real(r_kind),dimension(npred+2,nchanl):: predbias - real(r_kind),dimension(npred,nchanl):: pred,predchan - real(r_kind),dimension(nchanl):: obvarinv,utbc,adaptinf,wgtjo - real(r_kind),dimension(nchanl):: varinv,varinv_use,error0,errf,errf0 - real(r_kind),dimension(nchanl):: tb_obs,tbc,tbcnob,tlapchn,tb_obs_sdv - real(r_kind),dimension(nchanl):: tnoise,tnoise_cld - real(r_kind),dimension(nchanl):: emissivity,ts,emissivity_k - real(r_kind),dimension(nchanl):: tsim,wavenumber,tsim_bc - real(r_kind),dimension(nchanl):: tsim_clr,cldeff_obs - real(r_kind),dimension(nsig,nchanl):: wmix,temp,ptau5 - real(r_kind),dimension(nsigradjac,nchanl):: jacobian - real(r_kind),dimension(nreal+nchanl,nobs)::data_s - real(r_kind),dimension(nsig):: qvp,tvp - real(r_kind),dimension(nsig):: prsltmp - real(r_kind),dimension(nsig+1):: prsitmp - real(r_kind),dimension(nchanl):: weightmax - real(r_kind),dimension(nchanl):: cld_rbc_idx - real(r_kind) :: ptau5deriv, ptau5derivmax - real(r_kind) :: clw_guess,clw_guess_retrieval -! real(r_kind) :: predchan6_save - real(r_kind),dimension(:,:), allocatable :: rsqrtinv - - integer(i_kind),dimension(nchanl):: ich,id_qc,ich_diag - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - integer(i_kind),dimension(nchanl):: kmax - integer(i_kind):: iinstr - integer(i_kind) :: chan_count - integer(i_kind),allocatable,dimension(:) :: sc_index - - logical channel_passive - logical,dimension(nobs):: luse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - - character(10) filex - character(12) string - - class(obsNode),pointer:: my_node - type(radNode),pointer:: my_head,my_headm - type(obs_diag),pointer:: my_diag - type(rad_obs_type) :: radmod - - n_alloc(:)=0 - m_alloc(:)=0 -!************************************************************************************** -! Initialize variables and constants. - mm1 = mype+1 - r90 = 90._r_kind - coscon = cos( (r90-55.0_r_kind)*deg2rad ) - sincon = sin( (r90-55.0_r_kind)*deg2rad ) - - factch6 = zero - cld = zero - cldp = zero - tpwc = zero - sgagl = zero - dtp_avh=zero - icc = 0 - iccm = 0 - ich9 = min(9,nchanl) - do i=1,nchanl - do j=1,npred - pred(j,i)=zero - end do - end do - -! Initialize logical flags for satellite platform - - hirs2 = obstype == 'hirs2' - hirs3 = obstype == 'hirs3' - hirs4 = obstype == 'hirs4' - hirs = hirs2 .or. hirs3 .or. hirs4 - msu = obstype == 'msu' - ssu = obstype == 'ssu' - goessndr = obstype == 'sndr' .or. obstype == 'sndrd1' .or. & - obstype == 'sndrd2'.or. obstype == 'sndrd3' .or. & - obstype == 'sndrd4' - amsua = obstype == 'amsua' - amsub = obstype == 'amsub' - mhs = obstype == 'mhs' - airs = obstype == 'airs' - hsb = obstype == 'hsb' - goes_img = obstype == 'goes_img' - ahi = obstype == 'ahi' - avhrr = obstype == 'avhrr' - avhrr_navy = obstype == 'avhrr_navy' - ssmi = obstype == 'ssmi' - amsre_low = obstype == 'amsre_low' - amsre_mid = obstype == 'amsre_mid' - amsre_hig = obstype == 'amsre_hig' - amsre = amsre_low .or. amsre_mid .or. amsre_hig - amsr2 = obstype == 'amsr2' - gmi = obstype == 'gmi' - ssmis = obstype == 'ssmis' - ssmis_las = obstype == 'ssmis_las' - ssmis_uas = obstype == 'ssmis_uas' - ssmis_img = obstype == 'ssmis_img' - ssmis_env = obstype == 'ssmis_env' - iasi = obstype == 'iasi' - cris = obstype == 'cris' .or. obstype == 'cris-fsr' - seviri = obstype == 'seviri' - atms = obstype == 'atms' - saphir = obstype == 'saphir' - - ssmis=ssmis_las.or.ssmis_uas.or.ssmis_img.or.ssmis_env.or.ssmis - - microwave=amsua .or. amsub .or. mhs .or. msu .or. hsb .or. & - ssmi .or. ssmis .or. amsre .or. atms .or. & - amsr2 .or. gmi .or. saphir - - microwave_low =amsua .or. msu .or. ssmi .or. ssmis .or. amsre - -! Determine cloud & aerosol usages in radiance assimilation - call radiance_obstype_search(obstype,radmod) - -! Initialize channel related information - tnoise = r1e10 - tnoise_cld = r1e10 - l_may_be_passive = .false. - toss = .true. - jc=0 - - do j=1,jpch_rad - if(isis == nusis(j))then - jc=jc+1 - if(jc > nchanl)then - write(6,*)'SETUPRAD: ***ERROR*** in channel numbers, jc,nchanl=',jc,nchanl,& - ' ***STOP IN SETUPRAD***' - call stop2(71) - end if - -! Load channel numbers into local array based on satellite type - - ich(jc)=j - do i=1,npred - predchan(i,jc)=predx(i,j) - end do -! -! Set error instrument channels - tnoise(jc)=varch(j) - channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0 - if (iuse_rad(j)< -1 .or. (channel_passive .and. & - .not.rad_diagsave)) tnoise(jc)=r1e10 - if (passive_bc .and. channel_passive) tnoise(jc)=varch(j) - if (iuse_rad(j)>0) l_may_be_passive=.true. - if (tnoise(jc) < 1.e4_r_kind) toss = .false. - - tnoise_cld(jc)=varch_cld(j) - if (iuse_rad(j)< -1 .or. (iuse_rad(j) == -1 .and. & - .not.rad_diagsave)) tnoise_cld(jc)=r1e10 - if (passive_bc .and. (iuse_rad(j)==-1)) tnoise_cld(jc)=varch_cld(j) - end if - end do - - if(nchanl > jc) write(6,*)'SETUPRAD: channel number reduced for ', & - obstype,nchanl,' --> ',jc - if(jc == 0) then - if(mype == 0) write(6,*)'SETUPRAD: No channels found for ', obstype,isis - if(nobs > 0)read(lunin) - go to 135 - end if - - if (toss) then - if(mype == 0)write(6,*)'SETUPRAD: all obs var > 1e4. do not use ',& - 'data from satellite is=',isis - if(nobs >0)read(lunin) - goto 135 - endif - - if ( mype == 0 .and. .not.l_may_be_passive) write(6,*)mype,'setuprad: passive obs',is,isis - -! Logic to turn off print of reading coefficients if not first interation or not mype_diaghdr or not init_pass - iwrmype=-99 - if(mype==mype_diaghdr(is) .and. init_pass .and. jiterstart == jiter)iwrmype = mype_diaghdr(is) - -! Initialize radiative transfer and pointers to values in data_s - call init_crtm(init_pass,iwrmype,mype,nchanl,isis,obstype,radmod) - -! Get indexes of variables in jacobian to handle exceptions down below - ioz =getindex(radjacnames,'oz') - if(ioz>0) then - ioz=radjacindxs(ioz) - endif - ius =getindex(radjacnames,'u') - ivs =getindex(radjacnames,'v') - if(ius>0.and.ivs>0) then - ius=radjacindxs(ius) - ivs=radjacindxs(ivs) - endif - -! Initialize ozone jacobian flags to .false. (retain ozone jacobian) - zero_irjaco3_pole = .false. - -! These variables are initialized in init_crtm -! isatid = 1 ! index of satellite id -! itime = 2 ! index of analysis relative obs time -! ilon = 3 ! index of grid relative obs location (x) -! ilat = 4 ! index of grid relative obs location (y) -! ilzen_ang = 5 ! index of local (satellite) zenith angle (radians) -! ilazi_ang = 6 ! index of local (satellite) azimuth angle (radians) -! iscan_ang = 7 ! index of scan (look) angle (radians) -! iscan_pos = 8 ! index of integer scan position -! iszen_ang = 9 ! index of solar zenith angle (degrees) -! isazi_ang = 10 ! index of solar azimuth angle (degrees) -! ifrac_sea = 11 ! index of ocean percentage -! ifrac_lnd = 12 ! index of land percentage -! ifrac_ice = 13 ! index of ice percentage -! ifrac_sno = 14 ! index of snow percentage -! its_sea = 15 ! index of ocean temperature -! its_lnd = 16 ! index of land temperature -! its_ice = 17 ! index of ice temperature -! its_sno = 18 ! index of snow temperature -! itsavg = 19 ! index of average temperature -! ivty = 20 ! index of vegetation type -! ivfr = 21 ! index of vegetation fraction -! isty = 22 ! index of soil type -! istp = 23 ! index of soil temperature -! ism = 24 ! index of soil moisture -! isn = 25 ! index of snow depth -! izz = 26 ! index of surface height -! idomsfc = 27 ! index of dominate surface type -! isfcr = 28 ! index of surface roughness -! iff10 = 29 ! index of ten meter wind factor -! ilone = 30 ! index of earth relative longitude (degrees) -! ilate = 31 ! index of earth relative latitude (degrees) -! itref = 34/36 ! index of foundation temperature: Tr -! idtw = 35/37 ! index of diurnal warming: d(Tw) at depth zob -! idtc = 36/38 ! index of sub-layer cooling: d(Tc) at depth zob -! itz_tr = 37/39 ! index of d(Tz)/d(Tr) - -! Initialize sensor specific array pointers -! if (goes_img) then -! iclr_sky = 7 ! index of clear sky amount -! elseif (avhrr_navy) then -! isst_navy = 7 ! index of navy sst (K) retrieval -! idata_type = 30 ! index of data type (151=day, 152=night) -! isst_hires = 31 ! index of interpolated hires sst (K) -! elseif (avhrr) then -! iclavr = 32 ! index CLAVR cloud flag with AVHRR data -! isst_hires = 33 ! index of interpolated hires sst (K) -! elseif (seviri) then -! iclr_sky = 7 ! index of clear sky amount -! endif -! Special setup for SST retrieval (output) - if (retrieval.and.init_pass) call setup_sst_retrieval(obstype,dplat(is),mype) - -! Special setup for Tz retrieval - if (tzr_qc>0) call setup_tzr_qc(obstype) - -! Get version of rad-diag file - call get_radiag ('version',iversion_radiag,istatus) - if(istatus/=0) then - write(6,*)'SETUPRAD: trouble getting version of diag file' - call stop2(999) - endif - -! If SSM/I, check for non-use of 85GHz channel, for QC workaround -! set no85GHz true if any 85GHz is not used, and other freq channel is used - no85GHz = .false. - if (ssmi) then - if (iuse_rad(ich(6)) < 1 .or. iuse_rad(ich(7)) < 1 ) then - do j = 1,5 - if (iuse_rad(ich(j)) >= 1) then - no85GHz = .true. - cycle - endif - enddo - if (no85GHz .and. mype == 0) write(6,*) & - 'SETUPRAD: using no85GHZ workaround for SSM/I ',isis - endif - endif - - - -! Find number of channels written to diag file - if(reduce_diag)then - nchanl_diag=0 - do i=1,nchanl - if(iuse_rad(ich(i)) >= 1)then - nchanl_diag=nchanl_diag+1 - ich_diag(nchanl_diag)=i - end if - end do - if(mype == mype_diaghdr(is))write(6,*)'SETUPRAD: reduced number of channels ',& - nchanl_diag,' of ',nchanl,' written to diag file ' - else - nchanl_diag=nchanl - do i=1,nchanl_diag - ich_diag(i)=i - end do - end if - -! Set number of extra pieces of information to write to diagnostic file -! For most satellite sensors there is no extra information. However, -! for GOES Imager data we write additional information. - iextra=0 - jextra=0 - if (goes_img .or. lwrite_peakwt) then - jextra=nchanl_diag - iextra=1 - end if -! If both, iextra=2 - if (goes_img .and. lwrite_peakwt) then - iextra=2 - end if - - lextra = (iextra>0) - - -! Allocate array to hold channel information for diagnostic file and/or lobsdiagsave option - idiag=ipchan_radiag+npred+2 - ioff0=idiag - if (lobsdiagsave) idiag=idiag+4*miter+1 - allocate(diagbufchan(idiag,nchanl_diag)) - - allocate(sc_index(nchanl)) - sc_index(:) = 0 - satinfo_chan: do i=1, nchanl - n = ich(i) - spec_coef: do k=1, sc(1)%n_channels - if ( nuchan(n) == sc(1)%sensor_channel(k)) then - sc_index(i) = k - exit spec_coef - endif - end do spec_coef - end do satinfo_chan - - do i=1,nchanl - wavenumber(i)=sc(sensorindex)%wavenumber(sc_index(i)) - end do - -! If diagnostic file requested, open unit to file and write header. - if (rad_diagsave .and. nchanl_diag > 0) then - filex=obstype - write(string,1976) jiter -1976 format('_',i2.2) - diag_rad_file= trim(dirname) // trim(filex) // '_' // trim(dplat(is)) // trim(string) - if(init_pass) then - open(4,file=trim(diag_rad_file),form='unformatted',status='unknown',position='rewind') - else - open(4,file=trim(diag_rad_file),form='unformatted',status='old',position='append') - endif - if (lextra) allocate(diagbufex(iextra,jextra)) - -! Initialize/write parameters for satellite diagnostic file on -! first outer iteration. - if (init_pass .and. mype==mype_diaghdr(is)) then - inewpc=0 - if (newpc4pred) inewpc=1 - write(4) isis,dplat(is),obstype,jiter,nchanl_diag,npred,ianldate,ireal_radiag,ipchan_radiag,iextra,jextra,& - idiag,angord,iversion_radiag,inewpc,ioff0 -! write(6,*)'SETUPRAD: write header record for ',& -! isis,npred,ireal_radiag,ipchan_radiag,iextra,jextra,idiag,angord,iversion_radiag,& -! ' to file ',trim(diag_rad_file),' ',ianldate - do i=1,nchanl - n=ich(i) - if( n < 1 .or. (reduce_diag .and. iuse_rad(n) < 1))cycle - varch4=varch(n) - tlap4=tlapmean(n) - freq4=sc(sensorindex)%frequency(sc_index(i)) - pol4=sc(sensorindex)%polarization(sc_index(i)) - wave4=wavenumber(i) - write(4)freq4,pol4,wave4,varch4,tlap4,iuse_rad(n),& - nuchan(n),ich(i) - end do - endif - endif - -! Load data array for current satellite - read(lunin) data_s,luse,ioid - - if (nobskeep>0) then -! write(6,*)'setuprad: nobskeep',nobskeep - call stop2(275) - end if - -! PROCESSING OF SATELLITE DATA - -! Loop over data in this block - call dtime_setup() - do n = 1,nobs -! Extract analysis relative observation time. - dtime = data_s(itime,n) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - - id_qc = igood_qc - if(luse(n))aivals(1,is) = aivals(1,is) + one - -! Extract lon and lat. - slons = data_s(ilon,n) ! grid relative longitude - slats = data_s(ilat,n) ! grid relative latitude - cenlon = data_s(ilone,n) ! earth relative longitude (degrees) - cenlat = data_s(ilate,n) ! earth relative latitude (degrees) -! Extract angular information - zasat = data_s(ilzen_ang,n) - cosza = cos(zasat) - zsges=data_s(izz,n) - nadir = nint(data_s(iscan_pos,n)) - pangs = data_s(iszen_ang,n) -! Extract warm load temperatures -! wltm1 = data_s(isty,n) -! wltm2 = data_s(istp,n) -! wltm3 = data_s(ism,n) - -! If desired recompute 10meter wind factor - if(sfcmod_gfs .or. sfcmod_mm5) then - isli=nint(data_s(idomsfc,n)) - call comp_fact10(slats,slons,dtime,data_s(itsavg,n),data_s(isfcr,n), & - isli,mype,data_s(iff10,n)) - end if - - if(seviri .and. abs(data_s(iszen_ang,n)) > 180.0_r_kind) data_s(iszen_ang,n)=r100 - - -! Set land/sea, snow, ice percentages and flags (no time interpolation) - - sea = data_s(ifrac_sea,n) >= 0.99_r_kind - land = data_s(ifrac_lnd,n) >= 0.99_r_kind - ice = data_s(ifrac_ice,n) >= 0.99_r_kind - snow = data_s(ifrac_sno,n) >= 0.99_r_kind - mixed = .not. sea .and. .not. ice .and. & - .not. land .and. .not. snow - eff_area=.false. - if (radmod%lcloud_fwd) then - eff_area=(radmod%cld_sea_only .and. sea) .or. (.not. radmod%cld_sea_only) - end if - - if(sea) then - isfctype=0 - else if(land) then - isfctype=1 - else if(ice) then - isfctype=2 - else if(snow) then - isfctype=3 - else if(mixed) then - isfctype=4 - endif - -! Count data of different surface types - if(luse(n))then - if (mixed) then - aivals(5,is) = aivals(5,is) + one - else if (ice .or. snow) then - aivals(4,is) = aivals(4,is) + one - else if (land) then - aivals(3,is) = aivals(3,is) + one - end if - end if - -! Set relative weight value - val_obs=one - if(dval_use)then - ixx=nint(data_s(nreal-nstinfo,n)) - if (ixx > 0 .and. super_val1(ixx) >= one) then - val_obs=data_s(nreal-nstinfo-1,n)/super_val1(ixx) - endif - endif - -! Load channel data into work array. - do i = 1,nchanl - tb_obs(i) = data_s(i+nreal,n) - end do - - -! Interpolate model fields to observation location, call crtm and create jacobians -! Output both tsim and tsim_clr for allsky - tsim_clr=zero - if (radmod%lcloud_fwd) then - call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & - tvp,qvp,clw_guess,prsltmp,prsitmp, & - trop5,tzbgr,dtsavg,sfc_speed, & - tsim,emissivity,ptau5,ts,emissivity_k, & - temp,wmix,jacobian,error_status,tsim_clr=tsim_clr) - else - call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & - tvp,qvp,clw_guess,prsltmp,prsitmp, & - trop5,tzbgr,dtsavg,sfc_speed, & - tsim,emissivity,ptau5,ts,emissivity_k, & - temp,wmix,jacobian,error_status) - endif -! If the CRTM returns an error flag, do not assimilate any channels for this ob -! and set the QC flag to ifail_crtm_qc. -! We currently go through the rest of the QC steps, ensuring that the diagnostic -! files are populated, but this could be changed if it causes problems. - if (error_status == 0) then - varinv(1:nchanl) = val_obs - else - id_qc(1:nchanl) = ifail_crtm_qc - varinv(1:nchanl) = zero - endif - -! For SST retrieval, use interpolated NCEP SST analysis - if (retrieval) then - if( avhrr_navy )then - dtp_avh = data_s(idata_type,n) - sstcu=data_s(isst_hires,n) ! not available, assigned as interpolated sst - sstnv=data_s(isst_navy,n) - elseif ( avhrr) then - if ( pangs <= 89.0_r_kind) then ! day time - dtp_avh = 151.0_r_kind - else - dtp_avh = 152.0_r_kind - endif - sstcu=data_s(isst_hires,n) ! not available, assigned as interpolated sst - sstnv=data_s(isst_hires,n) ! not available, assigned as interpolated sst - endif - tsavg5 = data_s(isst_hires,n) - else - tsavg5=data_s(itsavg,n) - tsavg5=tsavg5+dtsavg - endif - -! If using adaptive angle dependent bias correction, update the predicctors -! for this part of bias correction. The AMSUA cloud liquid water algorithm -! uses total angle dependent bias correction for channels 1 and 2 - if (adp_anglebc) then - do i=1,nchanl - mm=ich(i) - if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmis) then - pred(npred,i)=nadir*deg2rad - else - pred(npred,i)=data_s(iscan_ang,n) - end if - do j=2,angord - pred(npred-j+1,i)=pred(npred,i)**j - end do - cbias(nadir,mm)=zero - do j=1,angord - cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) - end do - end do - end if - -! Compute microwave cloud liquid water or graupel water path for bias correction and QC. - clw=zero - clwp_amsua=zero - clw_obs=zero - clw_guess_retrieval=zero - gwp=zero - tpwc_amsua=zero - tpwc_guess_retrieval=zero - scatp=zero - scat=zero - ierrret=0 - tpwc=zero - kraintype=0 - cldeff_obs=zero - if(microwave .and. sea) then - if(radmod%lcloud_fwd) then - call ret_amsua(tb_obs,nchanl,tsavg5,zasat,clwp_amsua,ierrret,scat) - scatp=scat - else - call calc_clw(nadir,tb_obs,tsim,ich,nchanl,no85GHz,amsua,ssmi,ssmis,amsre,atms, & - amsr2,gmi,saphir,tsavg5,sfc_speed,zasat,clw,tpwc,gwp,kraintype,ierrret) - if(gmi .or. amsr2) then ! set clw_obs for gmi and amsr2 - clw_obs = clw - endif - end if - if (ierrret /= 0) then - if (amsua) then - varinv(1:6)=zero - id_qc(1:6) = ifail_cloud_qc - varinv(15)=zero - id_qc(15) = ifail_cloud_qc - else if (atms) then - varinv(1:7)=zero - id_qc(1:7) = ifail_cloud_qc - varinv(16:22)=zero - id_qc(16) = ifail_cloud_qc - else - varinv(1:nchanl)=zero - id_qc(1:nchanl) = ifail_cloud_qc - endif - endif - endif - - predbias=zero - do i=1,nchanl - mm=ich(i) - - -!***** -! COMPUTE AND APPLY BIAS CORRECTION TO SIMULATED VALUES -!***** - -! Construct predictors for 1B radiance bias correction. - if (.not. newpc4pred) then - pred(1,i) = r0_01 - pred(2,i) = one_tenth*(one/cosza-one)**2-.015_r_kind - if(ssmi .or. ssmis .or. amsre .or. gmi .or. amsr2)pred(2,i)=zero - else - pred(1,i) = one - if (adp_anglebc) then - pred(2,i) = zero - else - pred(2,i) = (one/cosza-one)**2 - end if - end if - - pred(3,i) = zero - if (amsre) then - pred(3,i) = clw - else - pred(3,i) = clw*cosza*cosza - end if - if(radmod%lcloud_fwd .and. sea) pred(3,i ) = zero - - - - -! Apply bias correction - - kmax(i) = 0 - if (lwrite_peakwt .or. passive_bc) then - ptau5derivmax = -9.9e31_r_kind -! maximum of weighting function is level at which transmittance -! (ptau5) is changing the fastest. This is used for the level -! assignment (needed for vertical localization). - weightmax(i) = zero - do k=2,nsig - ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ & - (log(prsltmp(k-1))-log(prsltmp(k))) ) - if (ptau5deriv > ptau5derivmax) then - ptau5derivmax = ptau5deriv - kmax(i) = k - weightmax(i) = r10*prsitmp(k) ! cb to mb. - end if - enddo - end if - - tlapchn(i)= (ptau5(2,i)-ptau5(1,i))*(tsavg5-tvp(2)) - do k=2,nsig-1 - tlapchn(i)=tlapchn(i)+& - (ptau5(k+1,i)-ptau5(k,i))*(tvp(k-1)-tvp(k+1)) - end do - if (.not. newpc4pred) tlapchn(i) = r0_01*tlapchn(i) - tlap = tlapchn(i)-tlapmean(mm) - pred(4,i)=tlap*tlap - pred(5,i)=tlap - -! additional bias predictor (as/ds node) for SSMIS - pred(6,i)= zero - pred(7,i)= zero - node = data_s(ilazi_ang,n) - if (ssmis .and. node < 1000) then - if (.not. newpc4pred) then - pred(6,i)= ssmis_precond*node*cos(cenlat*deg2rad) - pred(7,i)= ssmis_precond*sin(cenlat*deg2rad) - else - pred(6,i)= node*cos(cenlat*deg2rad) - pred(7,i)= sin(cenlat*deg2rad) - endif - endif - -! emissivity sensitivity bias predictor - if (adp_anglebc .and. emiss_bc) then - pred(8,i)=zero - if (.not.sea .and. abs(emissivity_k(i))>0.001_r_kind) then - pred(8,i)=emissivity_k(i) - end if - end if - - do j=1, npred-angord - pred(j,i)=pred(j,i)*air_rad(mm) - end do - if (adp_anglebc) then - do j=npred-angord+1, npred - pred(j,i)=pred(j,i)*ang_rad(mm) - end do - end if - - do j = 1,npred - predbias(j,i) = predchan(j,i)*pred(j,i) - end do - predbias(npred+1,i) = cbias(nadir,mm)*ang_rad(mm) !global_satangbias - -! Apply SST dependent bias correction with cubic spline - if (retrieval) then - call spline_cub(fbias(:,mm),tsavg5,ys_bias_sst) - predbias(npred+2,i) = ys_bias_sst - endif - -! tbc = obs - guess after bias correction -! tbcnob = obs - guess before bias correction - tbcnob(i) = tb_obs(i) - tsim(i) - tbc(i) = tbcnob(i) - - do j=1, npred-angord - tbc(i)=tbc(i) - predbias(j,i) !obs-ges with bias correction - end do - tbc(i)=tbc(i) - predbias(npred+1,i) - tbc(i)=tbc(i) - predbias(npred+2,i) - -! Calculate cloud effect for QC - if (radmod%cld_effect .and. eff_area) then - cldeff_obs(i) = tb_obs(i)-tsim_clr(i) ! observed cloud delta (no bias correction) - ! need to apply bias correction ? need to think about this - bias = zero - do j=1, npred-angord - bias = bias+predbias(j,i) - end do - bias = bias+predbias(npred+1,i) - bias = bias+predbias(npred+2,i) - cldeff_obs(i)=cldeff_obs(i) - bias ! observed cloud delta (bias corrected) - endif - -! End of loop over channels - end do - -! Compute retrieved microwave cloud liquid water and -! assign cld_rbc_idx for bias correction in allsky conditions - cld_rbc_idx=one - if (radmod%lcloud_fwd .and. radmod%ex_biascor .and. eff_area) then - ierrret=0 - do i=1,nchanl - mm=ich(i) - tsim_bc(i)=tsim(i) - do j=1,npred-angord - tsim_bc(i)=tsim_bc(i)+predbias(j,i) - end do - tsim_bc(i)=tsim_bc(i)+predbias(npred+1,i) - tsim_bc(i)=tsim_bc(i)+predbias(npred+2,i) - end do - call radiance_ex_biascor(radmod,nchanl,tsim_bc,tsavg5,zasat, & - clw_guess_retrieval,clwp_amsua,cld_rbc_idx,ierrret) - - if (ierrret /= 0) then - if (amsua) then - varinv(1:6)=zero - id_qc(1:6) = ifail_cloud_qc - varinv(15)=zero - id_qc(15) = ifail_cloud_qc - else if (atms) then - varinv(1:7)=zero - id_qc(1:7) = ifail_cloud_qc - varinv(16:22)=zero - id_qc(16) = ifail_cloud_qc - else - varinv(1:nchanl)=zero - id_qc(1:nchanl) = ifail_cloud_qc - endif - endif - end if ! radmod%lcloud_fwd .and. radmod%ex_biascor - - do i=1,nchanl - error0(i) = tnoise(i) - errf0(i) = error0(i) - end do - -! Assign observation error for all-sky radiances - if (radmod%lcloud_fwd .and. radmod%ex_obserr .and. eff_area) then - call radiance_ex_obserr(radmod,nchanl,clwp_amsua,clw_guess_retrieval,tnoise,tnoise_cld,error0) - end if - - do i=1,nchanl - mm=ich(i) - channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 - if(tnoise(i) < 1.e4_r_kind .or. (channel_passive .and. rad_diagsave) & - .or. (passive_bc .and. channel_passive))then - varinv(i) = varinv(i)/error0(i)**2 - errf(i) = error0(i) - else - if(id_qc(i) == igood_qc) id_qc(i)=ifail_satinfo_qc - varinv(i) = zero - errf(i) = zero - endif -! End of loop over channels - end do - -!****** -! QC OBSERVATIONS BASED ON VARIOUS CRITERIA -! Separate blocks for various instruments. -!****** - -! ---------- IR ------------------- -! QC HIRS/2, GOES, HIRS/3 and AIRS sounder data -! - ObsQCs: if (hirs .or. goessndr .or. airs .or. iasi .or. cris) then - - frac_sea=data_s(ifrac_sea,n) - -! NOTE: The qc in qc_irsnd uses the inverse squared obs error. -! The loop below loads array varinv_use accounting for whether the -! cloud detection flag is set. Array -! varinv_use is then used in the qc calculations. -! For the case when all channels of a sensor are passive, all -! channels with iuse_rad=-1 or 0 are used in cloud detection. - - do i=1,nchanl - m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero - else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if - end if - end do - call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr, & - cris,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tnoise, & - wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & - id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole(n)) - -! --------- MSU ------------------- -! QC MSU data - else if (msu) then - - call qc_msu(nchanl,is,ndat,nsig,sea,land,ice,snow,luse(n), & - zsges,cenlat,tbc,ptau5,emissivity_k,ts,id_qc,aivals,errf,varinv) - -! ---------- AMSU-A ------------------- -! QC AMSU-A data - else if (amsua) then - - if (adp_anglebc) then - tb_obsbc1=tb_obs(1)-cbias(nadir,ich(1))-predx(1,ich(1)) - else - tb_obsbc1=tb_obs(1)-cbias(nadir,ich(1)) - end if - call qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse(n), & - zsges,cenlat,tb_obsbc1,cosza,clw,tbc,ptau5,emissivity_k,ts, & - pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,factch6, & - cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod) - -! If cloud impacted channels not used turn off predictor - - do i=1,nchanl - if ( (i <= 5 .or. i == 15) .and. (varinv(i)<1.e-9_r_kind) ) then - pred(3,i) = zero - end if - end do - - -! ---------- AMSU-B ------------------- -! QC AMSU-B and MHS data - - else if (amsub .or. hsb .or. mhs) then - - call qc_mhs(nchanl,ndat,nsig,is,sea,land,ice,snow,mhs,luse(n), & - zsges,tbc,tb_obs,ptau5,emissivity_k,ts, & - id_qc,aivals,errf,varinv,clw,tpwc) - -! ---------- ATMS ------------------- -! QC ATMS data - - else if (atms) then - - if (adp_anglebc) then - tb_obsbc1=tb_obs(1)-cbias(nadir,ich(1))-predx(1,ich(1)) - else - tb_obsbc1=tb_obs(1)-cbias(nadir,ich(1)) - end if - call qc_atms(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse(n), & - zsges,cenlat,tb_obsbc1,cosza,clw,tbc,ptau5,emissivity_k,ts, & - pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,factch6, & - cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod) - -! ---------- GOES imager -------------- -! GOES imager Q C -! - else if(goes_img)then - - - cld = data_s(iclr_sky,n) - do i = 1,nchanl - tb_obs_sdv(i) = data_s(i+29,n) - end do - call qc_goesimg(nchanl,is,ndat,nsig,ich,dplat(is),sea,land,ice,snow,luse(n), & - zsges,cld,tzbgr,tb_obs,tb_obs_sdv,tbc,tnoise,temp,wmix,emissivity_k,ts,id_qc, & - aivals,errf,varinv) - - -! ---------- SEVIRI ------------------- -! SEVIRI Q C - - else if (seviri) then - - cld = 100-data_s(iclr_sky,n) - - call qc_seviri(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n), & - zsges,tzbgr,tbc,tnoise,temp,wmix,emissivity_k,ts,id_qc,aivals,errf,varinv) -! - -! ---------- AVRHRR -------------- -! NAVY AVRHRR Q C - - else if (avhrr_navy .or. avhrr) then - - frac_sea=data_s(ifrac_sea,n) - -! NOTE: The qc in qc_avhrr uses the inverse squared obs error. -! The loop below loads array varinv_use accounting for whether the -! cloud detection flag is set. Array -! varinv_use is then used in the qc calculations. -! For the case when all channels of a sensor are passive, all -! channels with iuse_rad=-1 or 0 are used in cloud detection. - do i=1,nchanl - m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero - else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if - end if - end do - - call qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n), & - zsges,cenlat,frac_sea,pangs,trop5,tzbgr,tsavg5,tbc,tb_obs,tnoise, & - wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & - id_qc,aivals,errf,varinv,varinv_use,cld,cldp) - - -! ---------- SSM/I , SSMIS, AMSRE ------------------- -! SSM/I, SSMIS, & AMSRE Q C - - else if( ssmi .or. amsre .or. ssmis )then - - frac_sea=data_s(ifrac_sea,n) - if(amsre)then - bearaz= (270._r_kind-data_s(ilazi_ang,n))*deg2rad - sun_zenith=data_s(iszen_ang,n)*deg2rad - sun_azimuth=(r90-data_s(isazi_ang,n))*deg2rad - sgagl = acos(coscon * cos( bearaz ) * cos( sun_zenith ) * cos( sun_azimuth ) + & - coscon * sin( bearaz ) * cos( sun_zenith ) * sin( sun_azimuth ) + & - sincon * sin( sun_zenith )) * rad2deg - end if - call qc_ssmi(nchanl,nsig,ich, & - zsges,luse(n),sea,mixed, & - temp,wmix,ts,emissivity_k,ierrret,kraintype,tpwc,clw,sgagl,tzbgr, & - tbc,tbcnob,tsim,tnoise,ssmi,amsre_low,amsre_mid,amsre_hig,ssmis, & - varinv,errf,aivals(1,is),id_qc) - -! ---------- AMSR2 ------------------- -! AMSR2 Q C - - else if (amsr2) then - - sun_azimuth=data_s(isazi_ang,n) - sun_zenith=data_s(iszen_ang,n) - - call qc_amsr2(nchanl,zsges,luse(n),sea,kraintype,clw_obs,tsavg5, & - tb_obs,sun_azimuth,sun_zenith,amsr2,varinv,aivals(1,is),id_qc) - -! ---------- GMI ------------------- -! GMI Q C - - else if (gmi) then - - call qc_gmi(nchanl,zsges,luse(n),sea,cenlat, & - kraintype,clw_obs,tsavg5,tb_obs,gmi,varinv,aivals(1,is),id_qc) - -! ---------- SAPHIR ----------------- -! SAPHIR Q C - - else if (saphir) then - - call qc_saphir(nchanl,zsges,luse(n),sea, & - kraintype,varinv,aivals(1,is),id_qc) - -! ---------- SSU ------------------- -! SSU Q C - - elseif (ssu) then - - call qc_ssu(nchanl,is,ndat,nsig,sea,land,ice,snow,luse(n), & - zsges,cenlat,tb_obs,ptau5,emissivity_k,ts,id_qc,aivals,errf,varinv) - - end if ObsQCs - -! Done with sensor qc blocks. Now make final qc decisions. - -! Apply gross check to observations. Toss obs failing test. - do i = 1,nchanl - if (varinv(i) > tiny_r_kind ) then - m=ich(i) - if(radmod%lcloud_fwd .and. eff_area) then - if (radmod%rtype =='amsua' .and. (i <= 5 .or. i==15)) then - errf(i) = three*errf(i) - else if (radmod%rtype =='atms' .and. (i <= 6 .or. i>=16)) then - errf(i) = min(three*errf(i), 10.0_r_kind) - else - errf(i) = min(three*errf(i),ermax_rad(m)) - endif - else if (ssmis) then - errf(i) = min(1.5_r_kind*errf(i),ermax_rad(m)) ! tighten up gross check for SSMIS - else if (gmi .or. saphir .or. amsr2) then - errf(i) = ermax_rad(m) ! use ermax for GMI, SAPHIR, and AMSR2 gross check - else - errf(i) = min(three*errf(i),ermax_rad(m)) - endif - if (abs(tbc(i)) > errf(i)) then -! If mean obs-ges difference around observations -! location is too large and difference at the -! observation location is similarly large, then -! toss the observation. - if(id_qc(i) == igood_qc)id_qc(i)=ifail_gross_qc - varinv(i) = zero - if(luse(n))stats(2,m) = stats(2,m) + one - if(luse(n))aivals(7,is) = aivals(7,is) + one - end if - end if - end do - - if(amsua .or. atms .or. amsub .or. mhs .or. msu .or. hsb)then - if(amsua)nlev=6 - if(atms)nlev=7 - if(amsub .or. mhs)nlev=5 - if(hsb)nlev=4 - if(msu)nlev=4 - kval=0 - do i=2,nlev -! do i=1,nlev - channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 - if (varinv(i)=1) .or. & - (passive_bc .and. channel_passive))) then - kval=max(i-1,kval) - if(amsub .or. hsb .or. mhs)kval=nlev - if((amsua .or. atms) .and. i <= 3)kval = zero - end if - end do - if(kval > 0)then - do i=1,kval - varinv(i)=zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_interchan_qc - end do - if(amsua)then - varinv(15)=zero - if(id_qc(15) == igood_qc)id_qc(15)=ifail_interchan_qc - end if - if (atms) then - varinv(16:18)=zero - if(id_qc(16) == igood_qc)id_qc(16)=ifail_interchan_qc - if(id_qc(17) == igood_qc)id_qc(17)=ifail_interchan_qc - if(id_qc(18) == igood_qc)id_qc(18)=ifail_interchan_qc - end if - end if - end if - - -! If requested, generate SST retrieval (output) - if(retrieval) then - if(avhrr_navy .or. avhrr) then - call avhrr_sst_retrieval(dplat(is),nchanl,tnoise,& - varinv,tsavg5,sstph,temp,wmix,ts,tbc,cenlat,cenlon,& - dtime,dtp_avh,tb_obs,dta,dqa,luse(n)) - endif - endif - - icc = 0 - iccm= 0 - - do i = 1,nchanl - -! Reject radiances for single radiance test - if (lsingleradob) then - ! if the channels are beyond 0.01 of oblat/oblon, specified - ! in gsi namelist, or aren't of type 'oneob_type', reject - if ( (abs(cenlat - oblat) > one/r100 .or. & - abs(cenlon - oblon) > one/r100) .or. & - obstype /= oneob_type ) then - varinv(i) = zero - varinv_use(i) = zero - if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range - else - ! if obchan <= zero, keep all footprints, if obchan > zero, - ! keep only that which has channel obchan - if (i /= obchan .and. obchan > zero) then - varinv(i) = zero - varinv_use(i) = zero - if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range - endif - endif !cenlat/lon - endif !lsingleradob - -! Only process observations to be assimilated - - if (varinv(i) > tiny_r_kind ) then - - m = ich(i) - if(luse(n))then - drad = tbc(i) - dradnob = tbcnob(i) - varrad = drad*varinv(i) - stats(1,m) = stats(1,m) + one !number of obs -! stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor) -! stats(4,m) = stats(4,m) + tbc(i)*drad !(obs-mod(w_biascor))**2 -! stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution -! stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor) - stats(3,m) = stats(3,m) + drad*cld_rbc_idx(i) !obs-mod(w_biascor) - stats(4,m) = stats(4,m) + tbc(i)*drad*cld_rbc_idx(i) !(obs-mod(w_biascor))**2 - stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution - stats(6,m) = stats(6,m) + dradnob*cld_rbc_idx(i) !obs-mod(w/o_biascor) - - exp_arg = -half*(tbc(i)/error0(i))**2 - error=sqrt(varinv(i)) - if (pg_rad(m) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-pg_rad(m) - cg_rad=b_rad(m)*error - wgross = cg_term*pg_rad(m)/(cg_rad*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - else - term = exp_arg - wgt = one - endif - stats(7,m) = stats(7,m) -two*(error0(i)**2)*varinv(i)*term - end if - -! Only "good" obs are included in J calculation. - if (iuse_rad(m) >= 1)then - if(luse(n))then - aivals(40,is) = aivals(40,is) + tbc(i)*varrad - aivals(39,is) = aivals(39,is) -two*(error0(i)**2)*varinv(i)*term - aivals(38,is) = aivals(38,is) +one - if(wgt < wgtlim) aivals(2,is)=aivals(2,is)+one - -! summation of observation number - if (newpc4pred) then - ostats(m) = ostats(m) + one*cld_rbc_idx(i) - end if - end if - - icc=icc+1 - -! End of use data block - end if - -! At the end of analysis, prepare for bias correction for monitored channels -! Only "good monitoring" obs are included in J_passive calculation. - channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 - if (passive_bc .and. (jiter>miter) .and. channel_passive) then -! summation of observation number, -! skip ostats accumulation for channels without coef. initialization - if (newpc4pred .and. luse(n) .and. any(predx(:,m)/=zero)) then - ostats(m) = ostats(m) + one*cld_rbc_idx(i) - end if - iccm=iccm+1 - end if - - -! End of varinv>tiny_r_kind block - endif - -! End loop over channels. - end do - - endif ! (in_curbin) - -! In principle, we want ALL obs in the diagnostics structure but for -! passive obs (monitoring), it is difficult to do if rad_diagsave -! is not on in the first outer loop. For now we use l_may_be_passive... -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - - if (l_may_be_passive .and. .not. retrieval) then - - if(in_curbin) then -! Load data into output arrays - if(icc > 0)then - nchan_total=nchan_total+icc - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(radhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(n) - my_head%elat= data_s(ilate,n) - my_head%elon= data_s(ilone,n) - my_head%isis = isis - my_head%isfctype = isfctype - - allocate(my_head%res(icc),my_head%err2(icc), & - my_head%raterr2(icc),my_head%pred(npred,icc), & - my_head%dtb_dvar(nsigradjac,icc), & - my_head%ich(icc),& - my_head%icx(icc)) - if(luse_obsdiag)allocate(my_head%diags(icc)) - - call get_ij(mm1,slats,slons,my_head%ij,my_head%wij) - my_head%time=dtime - my_head%luse=luse(n) - my_head%ich(:)=-1 - - utbc=tbc - wgtjo= varinv ! weight used in Jo term - adaptinf = varinv ! on input - obvarinv = error0 ! on input - account_for_corr_obs = radinfo_adjust_jacobian (iinstr,isis,isfctype,nchanl,nsigradjac,ich,varinv,& - utbc,obvarinv,adaptinf,wgtjo,jacobian) - - iii=0 - do ii=1,nchanl - m=ich(ii) - if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then - - iii=iii+1 - - if(account_for_corr_obs) then - my_head%res(iii)= utbc(ii) ! evecs(R)*[obs-ges innovation] - my_head%err2(iii)= obvarinv(ii) ! 1/eigenvalue(R) - my_head%raterr2(iii)=adaptinf(ii) ! inflation factor - else - my_head%res(iii)= tbc(ii) ! obs-ges innovation - my_head%err2(iii)= one/error0(ii)**2 ! 1/(obs error)**2 (original uninflated error) - my_head%raterr2(iii)=error0(ii)**2*varinv(ii) ! (original error)/(inflated error) - endif - my_head%icx(iii)= m ! channel index - - do k=1,npred - my_head%pred(k,iii)=pred(k,ii)*cld_rbc_idx(ii)*upd_pred(k) - end do - - do k=1,nsigradjac - my_head%dtb_dvar(k,iii)=jacobian(k,ii) - end do - -! Load jacobian for ozone (dTb/doz). For hirs and goes channel 9 -! (ozone channel) we do not let the observations change the ozone. -! There currently is no ozone analysis when running in the NCEP -! regional mode, therefore set ozone jacobian to 0.0 - if (ioz>=0) then - if (regional .or. qc_noirjaco3 .or. zero_irjaco3_pole(n) .or. & - ((hirs .or. goessndr).and.(varinv(ich9) < tiny_r_kind))) then - do k = 1,nsig - my_head%dtb_dvar(ioz+k,iii) = zero - end do - endif - endif - -! Load Jacobian for wind speed (dTb/du, dTb/dv) - if(ius>=0.and.ivs>=0) then - if( .not. dtbduv_on .or. .not. microwave) then - my_head%dtb_dvar(ius+1,iii) = zero - my_head%dtb_dvar(ivs+1,iii) = zero - endif - end if - - my_head%ich(iii)=ii - -! compute hessian contribution from Jo bias correction terms - if (newpc4pred .and. luse(n)) then - do k=1,npred - rstats(k,m)=rstats(k,m)+my_head%pred(k,iii) & - *my_head%pred(k,iii)*varinv(ii) - end do - end if ! end of newpc4pred loop - - end if - end do - my_head%nchan = iii ! profile observation count - - my_head%use_corr_obs=.false. - if (account_for_corr_obs) then - chan_count=(my_head%nchan*(my_head%nchan+1))/2 - allocate(my_head%rsqrtinv(chan_count)) - allocate(rsqrtinv(my_head%nchan,my_head%nchan)) - my_head%rsqrtinv=zero - rsqrtinv=zero - call radinfo_get_rsqrtinv(nchanl,iinstr,my_head%nchan,my_head%icx,my_head%ich,& - my_head%err2,rsqrtinv) - chan_count=0 - do ii=1,my_head%nchan - do jj=ii,my_head%nchan - chan_count=chan_count+1 - my_head%rsqrtinv(chan_count)=rsqrtinv(ii,jj) - end do - end do - deallocate(rsqrtinv) - my_head%use_corr_obs=.true. - end if - - my_head => null() - end if ! icc - - endif ! (in_curbin) - -! Link obs to diagnostics structure - iii=0 - obsptr => null() - do ii=1,nchanl - m=ich(ii) - if (luse_obsdiag ) then - if (iuse_rad(m)>=1 .or. l4dvar .or. lobsdiagsave) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_rad_ob_type,ibin)%head)) then - obsdiags(i_rad_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_rad_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuprad: failure to allocate obsdiags',istat - call stop2(276) - end if - obsdiags(i_rad_ob_type,ibin)%tail => obsdiags(i_rad_ob_type,ibin)%head - else - allocate(obsdiags(i_rad_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuprad: failure to allocate obsdiags',istat - call stop2(277) - end if - obsdiags(i_rad_ob_type,ibin)%tail => obsdiags(i_rad_ob_type,ibin)%tail%next - end if - obsdiags(i_rad_ob_type,ibin)%n_alloc = obsdiags(i_rad_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_rad_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_rad_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_rad_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_rad_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_rad_ob_type,ibin)%tail%indxglb=(ioid(n)-1)*nchanl+ii - obsdiags(i_rad_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_rad_ob_type,ibin)%tail%luse=luse(n) - obsdiags(i_rad_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_rad_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_rad_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_rad_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_rad_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_rad_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(n) - my_diag%ich = ii - my_diag%elat= data_s(ilate,n) - my_diag%elon= data_s(ilone,n) - else - if (.not.associated(obsdiags(i_rad_ob_type,ibin)%tail)) then - obsdiags(i_rad_ob_type,ibin)%tail => obsdiags(i_rad_ob_type,ibin)%head - else - obsdiags(i_rad_ob_type,ibin)%tail => obsdiags(i_rad_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_rad_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_rad_ob_type,ibin)%tail)') - end if - if (obsdiags(i_rad_ob_type,ibin)%tail%indxglb/=(ioid(n)-1)*nchanl+ii) then - write(6,*)'setuprad: index error' - call stop2(278) - endif - endif ! (.not.lobsdiag_allocated) - ! Mark the pointer to the leading obsdiags node (ii==1) of the current - ! observation profile (n). - if (ii==1) obsptr => obsdiags(i_rad_ob_type,ibin)%tail - - if(in_curbin.and.icc>0) then - !my_head => radNode_typecast(obsLList_tailNode(radhead(ibin))) - my_node => obsLList_tailNode(radhead(ibin)) - if(.not.associated(my_node)) & - call die(myname,'unexpected, associated(my_node) =',associated(my_node)) - my_head => radNode_typecast(my_node) - if(.not.associated(my_head)) & - call die(myname,'unexpected, associated(my_head) =',associated(my_head)) - my_node => null() - - if (ii==1) obsdiags(i_rad_ob_type,ibin)%tail%nchnperobs = nchanl - obsdiags(i_rad_ob_type,ibin)%tail%nldepart(jiter) = utbc(ii) - obsdiags(i_rad_ob_type,ibin)%tail%wgtjo=wgtjo(ii) - -! Load data into output arrays - m=ich(ii) - if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then - iii=iii+1 - my_head%diags(iii)%ptr => obsdiags(i_rad_ob_type,ibin)%tail - obsdiags(i_rad_ob_type,ibin)%tail%muse(jiter) = .true. - - ! verify the pointer to obsdiags - - my_diag => my_head%diags(iii)%ptr - - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob .or. & - ii /= my_diag%ich ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ich,ibin) =', & - (/is,ioid(n),ii,ibin/)) - call perr(myname,'my_head%(idv,iob,ich) =',(/my_head%idv,my_head%iob, ii /)) - call perr(myname,'my_diag%(idv,iob,ich) =',(/my_diag%idv,my_diag%iob,my_diag%ich/)) - call die(myname) - endif - endif ! (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) - - my_head => null() - endif ! (in_curbin.and.icc>0) - endif ! (iuse_rad(m)>=1 .or. l4dvar .or. lobsdiagsave) - endif ! (luse_obsdiag) - enddo - if(in_curbin .and. luse_obsdiag) then - if(.not. retrieval.and.(iii/=icc)) then - write(6,*)'setuprad: error iii icc',iii,icc - call stop2(279) - endif - endif ! (in_curbin) - -! End of l_may_be_passive block - endif ! (l_may_by_passive) - - -! Load passive data into output arrays - if (passive_bc .and. (jiter>miter) .and. .not. retrieval) then - if(in_curbin) then - if(iccm > 0)then - allocate(my_headm) - my_node => my_headm ! this is a workaround - call obsLList_appendNode(radheadm(ibin),my_node) - my_node => null() - - my_headm%idv = is - my_headm%iob = ioid(n) - my_headm%elat= data_s(ilate,n) - my_headm%elon= data_s(ilone,n) - my_headm%isis = isis - my_headm%isfctype = isfctype - - allocate(my_headm%res(iccm),my_headm%err2(iccm), & - my_headm%raterr2(iccm),my_headm%pred(npred,iccm), & - my_headm%ich(iccm), & - my_headm%icx(iccm)) - - my_headm%nchan = iccm ! profile observation count - my_headm%time=dtime - my_headm%luse=luse(n) - my_headm%ich(:)=-1 - iii=0 - do ii=1,nchanl - m=ich(ii) - channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 - if (varinv(ii)>tiny_r_kind .and. channel_passive) then - - iii=iii+1 - my_headm%res(iii)=tbc(ii) ! obs-ges innovation - my_headm%err2(iii)=one/error0(ii)**2 ! 1/(obs error)**2 (original uninflated error) - my_headm%raterr2(iii)=error0(ii)**2*varinv(ii) ! (original error)/(inflated error) - my_headm%icx(iii)=m ! channel index - do k=1,npred - my_headm%pred(k,iii)=pred(k,ii)*upd_pred(k) - end do - - my_headm%ich(iii)=ii - -! compute hessian contribution, -! skip rstats accumulation for channels without coef. initialization - if (newpc4pred .and. luse(n) .and. any(predx(:,m)/=zero)) then - do k=1,npred - rstats(k,m)=rstats(k,m)+my_headm%pred(k,iii) & - *my_headm%pred(k,iii)*varinv(ii) - end do - end if ! end of newpc4pred loop - - end if - end do - - if (iii /= iccm) then - write(6,*)'setuprad: error iii iccm',iii,iccm - call stop2(279) - endif - - my_headm%nchan = iii ! profile observation count - - my_headm => null() - end if ! - endif ! (in_curbin) - end if ! End of passive_bc block - - - if(in_curbin) then -! Write diagnostics to output file. - if (rad_diagsave .and. luse(n) .and. nchanl_diag > 0) then - diagbuf(1) = cenlat ! observation latitude (degrees) - diagbuf(2) = cenlon ! observation longitude (degrees) - diagbuf(3) = zsges ! model (guess) elevation at observation location - - diagbuf(4) = dtime-time_offset ! observation time (hours relative to analysis time) - - diagbuf(5) = data_s(iscan_pos,n) ! sensor scan position - diagbuf(6) = zasat*rad2deg ! satellite zenith angle (degrees) - diagbuf(7) = data_s(ilazi_ang,n) ! satellite azimuth angle (degrees) - diagbuf(8) = pangs ! solar zenith angle (degrees) - diagbuf(9) = data_s(isazi_ang,n) ! solar azimuth angle (degrees) - diagbuf(10) = sgagl ! sun glint angle (degrees) (sgagl) - - diagbuf(11) = surface(1)%water_coverage ! fractional coverage by water - diagbuf(12) = surface(1)%land_coverage ! fractional coverage by land - diagbuf(13) = surface(1)%ice_coverage ! fractional coverage by ice - diagbuf(14) = surface(1)%snow_coverage ! fractional coverage by snow - if(.not. retrieval)then - diagbuf(15) = surface(1)%water_temperature ! surface temperature over water (K) - diagbuf(16) = surface(1)%land_temperature ! surface temperature over land (K) - diagbuf(17) = surface(1)%ice_temperature ! surface temperature over ice (K) - diagbuf(18) = surface(1)%snow_temperature ! surface temperature over snow (K) - diagbuf(19) = surface(1)%soil_temperature ! soil temperature (K) - if (gmi .or. saphir) then - diagbuf(20) = gwp ! graupel water path - else - diagbuf(20) = surface(1)%soil_moisture_content ! soil moisture - endif - -! For IR instruments NPOESS land types are applied. -! For microwave instruments the CRTM land_type field is not -! applied, but from a nomenclature standpoint land_type -! is interchangeable with vegetation_type. - diagbuf(21) = surface(1)%land_type ! surface land type - else - diagbuf(15) = tsavg5 ! SST first guess used for SST retrieval - diagbuf(16) = sstcu ! NCEP SST analysis at t - diagbuf(17) = sstph ! Physical SST retrieval - diagbuf(18) = sstnv ! Navy SST retrieval - diagbuf(19) = dta ! d(ta) corresponding to sstph - diagbuf(20) = dqa ! d(qa) corresponding to sstph - diagbuf(21) = dtp_avh ! data type - endif - if(radmod%lcloud_fwd .and. sea) then - ! diagbuf(22) = tpwc_amsua - diagbuf(22) = scat ! scattering index from AMSU-A - diagbuf(23) = clw_guess ! integrated CLWP (kg/m**2) from background - else - diagbuf(22) = surface(1)%vegetation_fraction ! vegetation fraction - diagbuf(23) = surface(1)%snow_depth ! snow depth - endif - diagbuf(24) = surface(1)%wind_speed ! surface wind speed (m/s) - -! Note: The following quantities are not computed for all sensors - if (.not.microwave) then - diagbuf(25) = cld ! cloud fraction (%) - diagbuf(26) = cldp ! cloud top pressure (hPa) - else - if((radmod%lcloud_fwd .and. sea) .or. gmi .or. amsr2) then - if (gmi .or. amsr2) then - diagbuf(25) = clw_obs ! clw (kg/m**2) from retrievals - else - diagbuf(25) = clwp_amsua ! cloud liquid water (kg/m**2) - endif - diagbuf(26) = clw_guess_retrieval ! retrieved CLWP (kg/m**2) from simulated BT - else - diagbuf(25) = clw ! cloud liquid water (kg/m**2) - diagbuf(26) = tpwc ! total column precip. water (km/m**2) - endif - endif - -! For NST - if (nstinfo==0) then - diagbuf(27) = r_missing - diagbuf(28) = r_missing - diagbuf(29) = r_missing - diagbuf(30) = r_missing - else - diagbuf(27) = data_s(itref,n) - diagbuf(28) = data_s(idtw,n) - diagbuf(29) = data_s(idtc,n) - diagbuf(30) = data_s(itz_tr,n) - endif - - if (lwrite_peakwt) then - do i=1,nchanl_diag - diagbufex(1,i)=weightmax(ich_diag(i)) ! press. at max of weighting fn (mb) - end do - if (goes_img) then - do i=1,nchanl_diag - diagbufex(2,i)=tb_obs_sdv(ich_diag(i)) - end do - end if - else if (goes_img .and. .not.lwrite_peakwt) then - do i=1,nchanl_diag - diagbufex(1,i)=tb_obs_sdv(ich_diag(i)) - end do - end if - - do i=1,nchanl_diag - diagbufchan(1,i)=tb_obs(ich_diag(i)) ! observed brightness temperature (K) - diagbufchan(2,i)=tbc(ich_diag(i)) ! observed - simulated Tb with bias corrrection (K) - diagbufchan(3,i)=tbcnob(ich_diag(i)) ! observed - simulated Tb with no bias correction (K) - errinv = sqrt(varinv(ich_diag(i))) - diagbufchan(4,i)=errinv ! inverse observation error - useflag=one - if (iuse_rad(ich(ich_diag(i))) < 1) useflag=-one - diagbufchan(5,i)= id_qc(ich_diag(i))*useflag ! quality control mark or event indicator - - if (radmod%lcloud_fwd) then - diagbufchan(6,i)=error0(ich_diag(i)) - else - diagbufchan(6,i)=emissivity(ich_diag(i)) ! surface emissivity - endif - diagbufchan(7,i)=tlapchn(ich_diag(i)) ! stability index - if (radmod%lcloud_fwd) then - diagbufchan(8,i)=cld_rbc_idx(ich_diag(i)) ! indicator of cloudy consistency - else - diagbufchan(8,i)=ts(ich_diag(i)) ! d(Tb)/d(Ts) - end if - - if (lwrite_predterms) then - predterms=zero - do j = 1,npred - predterms(j) = pred(j,ich_diag(i)) - end do - predterms(npred+1) = cbias(nadir,ich(ich_diag(i))) - - do j=1,npred+2 - diagbufchan(ipchan_radiag+j,i)=predterms(j) ! Tb bias correction terms (K) - end do - else ! Default to write out predicted bias - do j=1,npred+2 - diagbufchan(ipchan_radiag+j,i)=predbias(j,ich_diag(i)) ! Tb bias correction terms (K) - end do - end if - end do - - if (luse_obsdiag .and. lobsdiagsave) then - if (l_may_be_passive) then - ii_ptr=1 ! obsptr is currently associated with this node - do ii=1,nchanl_diag - if (.not.associated(obsptr)) then - write(6,*)'setuprad: error obsptr' - call stop2(280) - end if - - do jj=ii_ptr,ich_diag(ii)-1 ! move up to the current node at ich_diag(ii) - if(.not.associated(obsptr)) then - call perr('setuprad', '.not.associated(obsptr)') - call perr('setuprad', ' ii =',ii) - call perr('setuprad', ' ii_ptr =',ii_ptr) - call perr('setuprad', ' ich_diag(ii) =',ich_diag(ii)) - call perr('setuprad', ' jj =',jj) - call die('setuprad') - endif - - obsptr => obsptr%next - ii_ptr = ii_ptr+1 - enddo - - if(ii_ptr/=ich_diag(ii)) then - call perr('setuprad', 'ii_ptr /= ich_diag(ii), ii =',ii) - call perr('setuprad', ' ii_ptr =',ii_ptr) - call perr('setuprad', ' ich_diag(ii) =',ich_diag(ii)) - call die('setuprad') - endif - - if (obsptr%indxglb/=(ioid(n)-1)*nchanl+ich_diag(ii)) then - !!! This test will fail, if(reduce_diag)! - !write(6,*)'setuprad: error writing diagnostics' - !call stop2(281) - call perr('setuprad','failed on writing diagnostics, reduce_diag =',reduce_diag) - call perr('setuprad',' nchanl =',nchanl) - call perr('setuprad',' nchanl_diag =',nchanl_diag) - call perr('setuprad',' obsptr%indxglb =',obsptr%indxglb) - call perr('setuprad',' (ioid(n)-1)*nchanl+ich_diag(ii) =',(ioid(n)-1)*nchanl+ich_diag(ii)) - call perr('setuprad',' ioid(n) =',ioid(n)) - call perr('setuprad',' ii =',ii) - call perr('setuprad',' ich_diag(ii) =',ich_diag(ii)) - call perr('setuprad',' ii_ptr =',ii_ptr) - call perr('setuprad',' n =',n) - call die('setuprad') - end if - - ioff=ipchan_radiag+npred+2 - do jj=1,miter - ioff=ioff+1 - if (obsptr%muse(jj)) then - diagbufchan(ioff,ich_diag(ii)) = one - else - diagbufchan(ioff,ich_diag(ii)) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - diagbufchan(ioff,ich_diag(ii)) = obsptr%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - diagbufchan(ioff,ich_diag(ii)) = obsptr%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - diagbufchan(ioff,ich_diag(ii)) = obsptr%obssen(jj) - enddo - - obsptr => obsptr%next ! move up to the first node of the next profile - ii_ptr = ii_ptr+1 - enddo - else - ioff=ipchan_radiag+npred+2 - diagbufchan(ioff+1:ioff+4*miter+1,1:nchanl_diag) = zero - endif - endif - - if (.not.lextra) then - write(4) diagbuf,diagbufchan - else - write(4) diagbuf,diagbufchan,diagbufex - endif - - end if - endif ! (in_curbin) - - -! End of n-loop over obs - end do - -! If retrieval, close open bufr sst file (output) - if (retrieval.and.last_pass) call finish_sst_retrieval - -! Jump here when there is no data to process for current satellite -! Deallocate arrays - deallocate(diagbufchan) - deallocate(sc_index) - - if (rad_diagsave) then - call dtime_show(myname,'diagsave:rad',i_rad_ob_type) - close(4) - if (lextra .and. allocated(diagbufex)) deallocate(diagbufex) - endif - - call destroy_crtm - -135 continue - -! End of routine - return - - end subroutine setuprad - diff --git a/src/setuprhsall.f90 b/src/setuprhsall.f90 deleted file mode 100644 index 7fe95c1bb..000000000 --- a/src/setuprhsall.f90 +++ /dev/null @@ -1,782 +0,0 @@ -subroutine setuprhsall(ndata,mype,init_pass,last_pass) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuprhsall sets up rhs of oi -! prgmmr: derber org: np23 date: 2003-05-22 -! -! abstract: This routine sets up the right hand side (rhs) of the -! analysis equation. Functions performed in this routine -! include: -! a) calculate increments between current solutions and obs, -! b) generate statistical summaries of quality control and innovations, -! c) generate diagnostic files (optional), and -! d) prepare/save information for use in inner minimization loop -! -! program history log: -! 2003-05-22 derber -! 2003-12-23 kleist - ozone calculation modified to use guess pressure -! 2004-06-17 treadon - update documentation -! 2004-07-23 derber - modify to include conventional sst -! 2004-07-29 treadon - add only to module use, add intent in/out -! 2004-10-06 parrish - increase dimension of work arrays for nonlin qc -! 2004-12-08 xu li - replace local logical flag retrieval with that in radinfo -! 2004-12-22 treadon - restructure code to compute and write out -! innovation information on select outer iterations -! 2005-01-20 okamoto - add ssmi/amsre/ssmis -! 2005-03-30 lpchang - statsoz call was passing ozmz var unnecessarily -! 2005-04-18 treadon - deallocate fbias -! 2005-05-27 derber - level output change -! 2005-07-06 derber - include mhs and hirs/4 -! 2005-06-14 wu - add OMI oz -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-28 derber - simplify data file info handling -! 2005-10-20 kazumori - modify for real AMSR-E data process -! 2005-12-01 cucurull - add GPS bending angle -! 2005-12-21 treadon - modify processing of GPS data -! 2006-01-09 derber - move create/destroy array, compute_derived, q_diag -! from glbsoi outer loop into this routine -! 2006-01-12 treadon - add channelinfo -! 2006-02-03 derber - modify for new obs control and obs count- clean up! -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-03-21 treadon - add code to generate optional observation perturbations -! 2006-07-28 derber - modify code for new inner loop obs data structure -! 2006-07-29 treadon - remove create_atm_grids and destroy_atm_grids -! 2006-07-31 kleist - change call to atm arrays routines -! 2007-02-21 sienkiewicz - add MLS ozone changes -! 2007-03-01 treadon - add toss_gps and toss_gps_sub -! 2007-03-10 su - move the observation perturbation to each setup routine -! 2007-03-19 tremolet - Jo table -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-06-08 kleist/treadon - add prefix (task id or path) to diag_conv_file -! 2007-07-09 tremolet - observation sensitivity -! 2007-06-20 cucurull - changes related to gps diagnostics -! 2007-06-29 jung - change channelinfo to array -! 2007-09-30 todling - add timer -! 2007-10-03 todling - add observer split option -! 2007-12-15 todling - add prefix to diag filenames -! 2008-03-28 wu - move optional randon seed for perturb_obs to read_obs -! 2008-04-14 treadon - remove super_gps, toss_gps (moved into genstats_gps) -! 2008-05-23 safford - rm unused vars and uses -! 2008-12-08 todling - move 3dprs/geop-hght calculation from compute_derivate into here -! 2009-01-17 todling - update interface to intjo -! 2009-03-05 meunier - add call to lagragean operator -! 2009-08-19 guo - moved all rhs related statistics variables to m_rhs -! for multi-pass setuprhsall(); -! - added control arguments init_pass and last_pass for -! multi-pass setuprhsall(). -! 2009-09-14 guo - invoked compute_derived() even under lobserver. This is -! the right way to do it. It trigged moving of statments -! from glbsoi() to observer_init(). -! - cleaned up redandent calls to setupyobs() and inquire_obsdiags(). -! 2009-10-22 shen - add high_gps and high_gps_sub -! 2009-12-08 guo - fixed diag_conv output rewind while is not init_pass, with open(position='rewind') -! 2010-04-09 cucurull - remove high_gps and high_gps_sub -! 2010-04-01 tangborn - start adding call for carbon monoxide data. -! 2010-04-28 zhu - add ostats and rstats for additional precoditioner -! 2010-05-28 todling - obtain variable id's on the fly (add getindex) -! 2010-10-14 pagowski - added pm2_5 conventional obs -! 2010-10-20 hclin - added aod -! 2011-02-16 zhu - add gust,vis,pblh -! 2011-04-07 todling - newpc4pred now in radinfo -! 2011-09-17 todling - automatic sizes definition for mpi-reduce calls -! 2012-01-11 Hu - add load_gsdgeop_hgt to compute 2d subdomain pbl heights from the guess fields -! 2012-04-08 Hu - add code to skip the observations that are not used in minimization -! 2013-02-22 Carley - Add call to load_gsdgeop_hgt for NMMB/WRF-NMM if using -! PBL pseudo obs -! 2013-10-19 todling - metguess now holds background -! 2013-05-24 zhu - add ostats_t and rstats_t for aircraft temperature bias correction -! 2014-03-19 pondeca - add wspd10m -! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl -! 2014-05-07 pondeca - add howv -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2014-0?-16 carley/zhu - add tcamt and lcbas -! 2015-07-10 pondeca - add cldch -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-05 pondeca - add uwnd10m, vwund10m -! -! input argument list: -! ndata(*,1)- number of prefiles retained for further processing -! ndata(*,2)- number of observations read -! ndata(*,3)- number of observations keep after read -! mype - mpi task id -! -! output argument list: -! -! -! comments: -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,i_kind,r_quad,r_single - use constants, only: zero,one,fv,zero_quad - use guess_grids, only: load_prsges,load_geop_hgt,load_gsdpbl_hgt - use guess_grids, only: ges_tsen,nfldsig -! use obsmod, only: mype_diaghdr - use obsmod, only: nsat1,iadate,nobs_type,obscounts,& - ndat,obs_setup,& - dirname,write_diag,ditype,obsdiags,lobserver,& - destroyobs,inquire_obsdiags,lobskeep,nobskeep,lobsdiag_allocated, & - luse_obsdiag - use obsmod, only: lobsdiagsave - use obs_sensitivity, only: lobsensfc, lsensrecompute - use radinfo, only: newpc4pred - use radinfo, only: mype_rad,diag_rad,jpch_rad,retrieval,fbias,npred,ostats,rstats -! use aircraftinfo, only: aircraft_t_bc_pof,aircraft_t_bc,ostats_t,rstats_t,npredt,max_tail - use aircraftinfo, only: aircraft_t_bc_pof,aircraft_t_bc,ostats_t,rstats_t,npredt,ntail - use pcpinfo, only: diag_pcp - use ozinfo, only: diag_ozone,mype_oz,jpch_oz,ihave_oz - use coinfo, only: diag_co,mype_co,jpch_co,ihave_co - use mpimod, only: ierror,mpi_comm_world,mpi_rtype,mpi_sum - use gridmod, only: nsig,twodvar_regional,wrf_mass_regional,nems_nmmb_regional - use gridmod, only: cmaq_regional - use gsi_4dvar, only: nobs_bins,l4dvar - use gsi_4dvar, only: mPEs_observer - use jfunc, only: jiter,jiterstart,miter,first,last - use qcmod, only: npres_print - use convinfo, only: nconvtype,diag_conv - use timermod, only: timer_ini,timer_fnl - use lag_fields, only: lag_presetup,lag_state_write,lag_state_read,lag_destroy_uv - use state_vectors, only: svars2d - use mpeu_util, only: getindex - use mpl_allreducemod, only: mpl_allreduce - use aeroinfo, only: diag_aero - use berror, only: reset_predictors_var - use rapidrefresh_cldsurf_mod, only: l_PBL_pseudo_SurfobsT,l_PBL_pseudo_SurfobsQ,& - l_PBL_pseudo_SurfobsUV - use m_rhs, only: rhs_alloc - use m_rhs, only: rhs_dealloc - use m_rhs, only: rhs_allocated - use m_rhs, only: awork => rhs_awork - use m_rhs, only: bwork => rhs_bwork - use m_rhs, only: aivals => rhs_aivals - use m_rhs, only: stats => rhs_stats - use m_rhs, only: stats_co => rhs_stats_co - use m_rhs, only: stats_oz => rhs_stats_oz - use m_rhs, only: toss_gps_sub => rhs_toss_gps - - use m_gpsStats, only: gpsStats_genstats ! was genstats_gps() - use m_gpsStats, only: gpsStats_destroy ! was done by genstats_gps() - - use gsi_bundlemod, only: GSI_BundleGetPointer - use gsi_metguess_mod, only: GSI_MetGuess_Bundle - use m_obsdiags, only: obsdiags_reset - use m_obsdiags, only: obsdiags_read - use m_obsdiags, only: obsdiags_sort - use m_obsdiags, only: obsdiags_write - - use mpeu_util, only: die,warn,perr - use mpeu_util, only: basename - implicit none - -! Declare passed variables - integer(i_kind) ,intent(in ) :: mype - integer(i_kind),dimension(ndat,3),intent(in ) :: ndata - logical ,intent(in ) :: init_pass, last_pass ! state of "setup" processing - - -! Declare external calls for code analysis - external:: compute_derived - external:: evaljo - !external:: genstats_gps - external:: mpi_allreduce - external:: mpi_finalize - external:: mpi_reduce - !external:: read_obsdiags - external:: setupaod - external:: setupbend - external:: setupdw - external:: setuplag - external:: setupozlay - external:: setupozlev - external:: setuppcp - external:: setupps - external:: setuppw - external:: setupq - external:: setuprad - external:: setupref - external:: setuprw - external:: setupspd - external:: setupsst - external:: setupt - external:: setuptcp - external:: setupw - external:: setupgust - external:: setupvis - external:: setuppblh - external:: setupwspd10m - external:: setuptd2m - external:: setupmxtm - external:: setupmitm - external:: setuppmsl - external:: setuphowv - external:: setuptcamt - external:: setuplcbas - external:: setupcldch - external:: setupuwnd10m - external:: setupvwnd10m - external:: statsconv - external:: statsoz - external:: statspcp - external:: statsrad - external:: stop2 - external:: w3tage - -! Delcare local variables - logical rad_diagsave,ozone_diagsave,pcp_diagsave,conv_diagsave,llouter,getodiag,co_diagsave - logical aero_diagsave - - character(80):: string - character(10)::obstype - character(20)::isis - character(128):: diag_conv_file - character(len=12) :: clfile - - integer(i_kind) lunin,nobs,nchanl,nreal,nele,& - is,idate,i_dw,i_rw,i_sst,i_tcp,i_gps,i_uv,i_ps,i_lag,& - i_t,i_pw,i_q,i_co,i_gust,i_vis,i_ref,i_pblh,i_wspd10m,i_td2m,& - i_mxtm,i_mitm,i_pmsl,i_howv,i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,iobs,nprt,ii,jj - integer(i_kind) it,ier,istatus - - real(r_quad):: zjo - real(r_kind),dimension(40,ndat):: aivals1 - real(r_kind),dimension(7,jpch_rad):: stats1 - real(r_kind),dimension(9,jpch_oz):: stats_oz1 - real(r_kind),dimension(9,jpch_co):: stats_co1 - real(r_kind),dimension(npres_print,nconvtype,5,3):: bwork1 - real(r_kind),allocatable,dimension(:,:):: awork1 - - real(r_kind),dimension(:,:,:),pointer:: ges_tv_it=>NULL() - real(r_kind),dimension(:,:,:),pointer:: ges_q_it =>NULL() - character(len=*),parameter:: myname='setuprhsall' - - logical,parameter:: OBSDIAGS_RELOAD = .false. - !logical,parameter:: OBSDIAGS_RELOAD = .true. - logical:: opened - character(len=256):: tmpname,tmpaccess,tmpform - - if(.not.init_pass .and. .not.lobsdiag_allocated) call die('setuprhsall','multiple lobsdiag_allocated',lobsdiag_allocated) -!****************************************************************************** -! Initialize timer - call timer_ini('setuprhsall') - - - -! Initialize variables and constants. - first = jiter == jiterstart ! .true. on first outer iter - last = jiter == miter+1 ! .true. following last outer iter - llouter=.true. - -! Set diagnostic output flag - - rad_diagsave = write_diag(jiter) .and. diag_rad - pcp_diagsave = write_diag(jiter) .and. diag_pcp - conv_diagsave = write_diag(jiter) .and. diag_conv - ozone_diagsave= write_diag(jiter) .and. diag_ozone .and. ihave_oz - co_diagsave = write_diag(jiter) .and. diag_co .and. ihave_co - aero_diagsave = write_diag(jiter) .and. diag_aero - - i_ps = 1 - i_uv = 2 - i_t = 3 - i_q = 4 - i_pw = 5 - i_rw = 6 - i_dw = 7 - i_gps= 8 - i_sst= 9 - i_tcp= 10 - i_lag= 11 - i_co = 12 - i_gust=13 - i_vis =14 - i_pblh=15 - i_wspd10m=16 - i_td2m=17 - i_mxtm=18 - i_mitm=19 - i_pmsl=20 - i_howv=21 - i_tcamt=22 - i_lcbas=23 - i_cldch=24 - i_uwnd10m=26 - i_vwnd10m=27 - i_ref =i_vwnd10m - - allocate(awork1(7*nsig+100,i_ref)) - if(.not.rhs_allocated) call rhs_alloc(aworkdim2=size(awork1,2)) - -! Reset observation pointers - if(init_pass) call destroyobs - if(init_pass) call obsdiags_reset(obsdiags_keep=lobsdiagsave) ! replacing destroyobs() - -! Read observation diagnostics if available - if (l4dvar) then - getodiag=(.not.lobserver) .or. (lobserver.and.jiter>1) - clfile='obsdiags.ZZZ' - if (lobsensfc .and. .not.lsensrecompute) then - write(clfile(10:12),'(I3.3)') miter - !call read_obsdiags(clfile) - call obsdiags_read(clfile,mPEs=mPEs_observer) ! replacing read_obsdiags() - call inquire_obsdiags(miter) - else if (getodiag) then - if (.not.lobserver) then - write(clfile(10:12),'(I3.3)') jiter - !call read_obsdiags(clfile) - call obsdiags_read(clfile,mPEs=mPEs_observer) ! replacing read_obsdiags() - call inquire_obsdiags(miter) - endif - endif - endif - - if(init_pass) then - if (allocated(obscounts)) then - write(6,*)'setuprhsall: obscounts allocated' - call stop2(285) - end if - allocate(obscounts(nobs_type,nobs_bins)) - endif - - if (jiter>1.and.lobskeep) then - nobskeep=1 - else - nobskeep=0 - endif - -! The 3d pressure and geopotential grids are initially loaded at -! the end of the call to read_guess. Thus, we don't need to call -! load_prsges and load_geop_hgt on the first outer loop. We need -! to update these 3d pressure arrays on all subsequent outer loops. -! Hence, the conditional call to load_prsges and load_geop_hgt - - if (lobserver .or. jiter>jiterstart) then - -! Get sensible temperature (after bias correction's been applied) - do it=1,nfldsig - ier=0 - call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'tv',ges_tv_it,istatus);ier=ier+istatus - call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'q' ,ges_q_it ,istatus);ier=ier+istatus - if(ier/=0) exit - ges_tsen(:,:,:,it)= ges_tv_it(:,:,:)/(one+fv*max(zero,ges_q_it(:,:,:))) - enddo - -! Load 3d subdomain pressure arrays from the guess fields - call load_prsges - -! Compute 3d subdomain geopotential heights from the guess fields - call load_geop_hgt - -! if (sfcmod_gfs .or. sfcmod_mm5) then -! if (mype==0) write(6,*)'COMPUTE_DERIVED: call load_fact10' -! call load_fact10 -! endif - endif - -! Compute 2d subdomain pbl heights from the guess fields - if (wrf_mass_regional) then - call load_gsdpbl_hgt(mype) - else if (nems_nmmb_regional) then - if (l_PBL_pseudo_SurfobsT .or. l_PBL_pseudo_SurfobsQ .or. l_PBL_pseudo_SurfobsUV) then - call load_gsdpbl_hgt(mype) - end if - endif - - -! Compute derived quantities on grid - if(.not.cmaq_regional) call compute_derived(mype,init_pass) - - ! ------------------------------------------------------------------------ - - if ( (l4dvar.and.lobserver) .or. .not.l4dvar ) then - - - ! Init for Lagrangian data assimilation (gather winds and NL integration) - call lag_presetup() - ! Save state for inner loop if in 4Dvar observer mode - if (l4dvar.and.lobserver) then - call lag_state_write() - end if - -! Reset observation pointers. This is assumed by setup*() routines. - do ii=1,size(obsdiags,2) - do jj=1,size(obsdiags,1) - obsdiags(jj,ii)%tail => NULL() - enddo - enddo - - lunin=1 - open(lunin,file=obs_setup,form='unformatted') - rewind lunin - - -! If requested, create conventional diagnostic files - if(conv_diagsave)then - write(string,900) jiter -900 format('conv_',i2.2) - diag_conv_file=trim(dirname) // trim(string) - if(init_pass) then - open(7,file=trim(diag_conv_file),form='unformatted',status='unknown',position='rewind') - - else - ! open(7,file=trim(diag_conv_file),form='unformatted',status='old',position='append') - - ! Without a close(7) until the last_pass=.true., the same file - ! is expected to remain open "asis", equivalent to an "append" - ! position through a re-open(). Therefore, a sequence of - ! verification steps are taken to replace the earlier open() - ! statement, to avoid re-open() without a close(). - - inquire(unit=7,opened=opened) - if(opened) then - inquire(unit=7,name=tmpname,form=tmpform,access=tmpaccess) - tmpname=basename(tmpname) - if(trim(tmpname)/=trim(diag_conv_file)) then - call perr(myname,'unexpectly occupied, unit =',7) - call perr(myname,' diag_conv_file =',trim(diag_conv_file)) - call perr(myname,' inquire(unit=7, name= )',trim(tmpname)) - call perr(myname,' inquire(unit=7, form= )',trim(tmpform)) - call perr(myname,' inquire(unit=7,access= )',trim(tmpaccess)) - call die(myname) - endif - - else - call perr(myname,'unexpectly closed, unit =',7) - call perr(myname,' diag_conv_file =',trim(diag_conv_file)) - call die(myname) - endif - endif - idate=iadate(4)+iadate(3)*100+iadate(2)*10000+iadate(1)*1000000 - if(init_pass .and. mype == 0)write(7)idate - end if - - if (newpc4pred) then - ostats=zero - rstats=zero_quad - end if - - if (aircraft_t_bc_pof .or. aircraft_t_bc) then - ostats_t=zero_quad - rstats_t=zero_quad - end if - - -! Loop over data types to process - do is=1,ndat - nobs=nsat1(is) - - if(nobs > 0)then - - read(lunin,iostat=ier) obstype,isis,nreal,nchanl -! if(mype == mype_diaghdr(is)) then -! write(6,300) obstype,isis,nreal,nchanl -!300 format(' SETUPALL:,obstype,isis,nreal,nchanl=',a12,a20,i5,i5) -! endif - if(ier/=0) call die('setuprhsall','read(), iostat =',ier) - nele=nreal+nchanl - -! Set up for radiance data - if(ditype(is) == 'rad')then - - call setuprad(lunin,& - mype,aivals,stats,nchanl,nreal,nobs,& - obstype,isis,is,rad_diagsave,init_pass,last_pass) - -! Set up for aerosol data - else if(ditype(is) == 'aero')then - call setupaod(lunin,& - mype,nchanl,nreal,nobs,& - obstype,isis,is,aero_diagsave,init_pass) - -! Set up for precipitation data - else if(ditype(is) == 'pcp')then - call setuppcp(lunin,mype,& - aivals,nele,nobs,obstype,isis,is,pcp_diagsave,init_pass) - -! Set up conventional data - else if(ditype(is) == 'conv')then -! Set up temperature data - if(obstype=='t')then - call setupt(lunin,mype,bwork,awork(1,i_t),nele,nobs,is,conv_diagsave) - -! Set up uv wind data - else if(obstype=='uv')then - call setupw(lunin,mype,bwork,awork(1,i_uv),nele,nobs,is,conv_diagsave) - -! Set up wind speed data - else if(obstype=='spd')then - call setupspd(lunin,mype,bwork,awork(1,i_uv),nele,nobs,is,conv_diagsave) - -! Set up surface pressure data - else if(obstype=='ps')then - call setupps(lunin,mype,bwork,awork(1,i_ps),nele,nobs,is,conv_diagsave) - -! Set up tc-mslp data - else if(obstype=='tcp')then - call setuptcp(lunin,mype,bwork,awork(1,i_tcp),nele,nobs,is,conv_diagsave) - -! Set up moisture data - else if(obstype=='q') then - call setupq(lunin,mype,bwork,awork(1,i_q),nele,nobs,is,conv_diagsave) - -! Set up lidar wind data - else if(obstype=='dw')then - call setupdw(lunin,mype,bwork,awork(1,i_dw),nele,nobs,is,conv_diagsave) - -! Set up radar wind data - else if(obstype=='rw')then - call setuprw(lunin,mype,bwork,awork(1,i_rw),nele,nobs,is,conv_diagsave) - -! Set up total precipitable water (total column water) data - else if(obstype=='pw')then - call setuppw(lunin,mype,bwork,awork(1,i_pw),nele,nobs,is,conv_diagsave) - -! Set up conventional sst data - else if(obstype=='sst' .and. getindex(svars2d,'sst')>0) then - call setupsst(lunin,mype,bwork,awork(1,i_sst),nele,nobs,is,conv_diagsave) - -! Set up conventional lagrangian data - else if(obstype=='lag') then - call setuplag(lunin,mype,bwork,awork(1,i_lag),nele,nobs,is,conv_diagsave) - else if(obstype == 'pm2_5')then - call setuppm2_5(lunin,mype,nele,nobs,isis,is,conv_diagsave) - - else if(obstype == 'pm10')then - call setuppm10(lunin,mype,nele,nobs,isis,is,conv_diagsave) - -! Set up conventional wind gust data - else if(obstype=='gust' .and. getindex(svars2d,'gust')>0) then - call setupgust(lunin,mype,bwork,awork(1,i_gust),nele,nobs,is,conv_diagsave) - -! Set up conventional visibility data - else if(obstype=='vis' .and. getindex(svars2d,'vis')>0) then - call setupvis(lunin,mype,bwork,awork(1,i_vis),nele,nobs,is,conv_diagsave) - -! Set up conventional pbl height data - else if(obstype=='pblh' .and. getindex(svars2d,'pblh')>0) then - call setuppblh(lunin,mype,bwork,awork(1,i_pblh),nele,nobs,is,conv_diagsave) - -! Set up conventional wspd10m data - else if(obstype=='wspd10m' .and. getindex(svars2d,'wspd10m')>0) then - call setupwspd10m(lunin,mype,bwork,awork(1,i_wspd10m),nele,nobs,is,conv_diagsave) - -! Set up conventional td2m data - else if(obstype=='td2m' .and. getindex(svars2d,'td2m')>0) then - call setuptd2m(lunin,mype,bwork,awork(1,i_td2m),nele,nobs,is,conv_diagsave) - -! Set up conventional mxtm data - else if(obstype=='mxtm' .and. getindex(svars2d,'mxtm')>0) then - call setupmxtm(lunin,mype,bwork,awork(1,i_mxtm),nele,nobs,is,conv_diagsave) - -! Set up conventional mitm data - else if(obstype=='mitm' .and. getindex(svars2d,'mitm')>0) then - call setupmitm(lunin,mype,bwork,awork(1,i_mitm),nele,nobs,is,conv_diagsave) - -! Set up conventional pmsl data - else if(obstype=='pmsl' .and. getindex(svars2d,'pmsl')>0) then - call setuppmsl(lunin,mype,bwork,awork(1,i_pmsl),nele,nobs,is,conv_diagsave) - -! Set up conventional howv data - else if(obstype=='howv' .and. getindex(svars2d,'howv')>0) then - call setuphowv(lunin,mype,bwork,awork(1,i_howv),nele,nobs,is,conv_diagsave) - -! Set up total cloud amount data - else if(obstype=='tcamt' .and. getindex(svars2d,'tcamt')>0) then - call setuptcamt(lunin,mype,bwork,awork(1,i_tcamt),nele,nobs,is,conv_diagsave) - -! Set up base height of lowest cloud seen - else if(obstype=='lcbas' .and. getindex(svars2d,'lcbas')>0) then - call setuplcbas(lunin,mype,bwork,awork(1,i_lcbas),nele,nobs,is,conv_diagsave) - -! Set up conventional cldch data - else if(obstype=='cldch' .and. getindex(svars2d,'cldch')>0) then - call setupcldch(lunin,mype,bwork,awork(1,i_cldch),nele,nobs,is,conv_diagsave) - -! Set up conventional uwnd10m data - else if(obstype=='uwnd10m' .and. getindex(svars2d,'uwnd10m')>0) then - call setupuwnd10m(lunin,mype,bwork,awork(1,i_uwnd10m),nele,nobs,is,conv_diagsave) - -! Set up conventional vwnd10m data - else if(obstype=='vwnd10m' .and. getindex(svars2d,'vwnd10m')>0) then - call setupvwnd10m(lunin,mype,bwork,awork(1,i_vwnd10m),nele,nobs,is,conv_diagsave) - -! skip this kind of data because they are not used in the var analysis - else if(obstype == 'mta_cld' .or. obstype == 'gos_ctp' .or. & - obstype == 'rad_ref' .or. obstype=='lghtn' .or. & - obstype == 'larccld' .or. obstype == 'larcglb') then - read(lunin,iostat=ier) - if(ier/=0) call die('setuprhsall','read(), iostat =',ier) - -! - else - write(6,*) 'Warning, unknown data type in setuprhsall,', obstype - - end if - -! set up ozone (sbuv/omi/mls) data - else if(ditype(is) == 'ozone' .and. ihave_oz)then - if (obstype == 'o3lev' .or. index(obstype,'mls')/=0 ) then - call setupozlev(lunin,mype,stats_oz,nchanl,nreal,nobs,& - obstype,isis,is,ozone_diagsave,init_pass) - else - call setupozlay(lunin,mype,stats_oz,nchanl,nreal,nobs,& - obstype,isis,is,ozone_diagsave,init_pass) - end if - -! Set up co (mopitt) data - else if(ditype(is) == 'co')then - call setupco(lunin,mype,stats_co,nchanl,nreal,nobs,& - obstype,isis,is,co_diagsave,init_pass) - -! Set up GPS local refractivity data - else if(ditype(is) == 'gps')then - if(obstype=='gps_ref')then - call setupref(lunin,mype,awork(1,i_gps),nele,nobs,toss_gps_sub,is,init_pass,last_pass) - -! Set up GPS local bending angle data - else if(obstype=='gps_bnd')then - call setupbend(lunin,mype,awork(1,i_gps),nele,nobs,toss_gps_sub,is,init_pass,last_pass) - end if - end if - - end if - - end do - close(lunin) - - else - - ! Init for Lagrangian data assimilation (read saved parameters) - call lag_state_read() - - endif ! < lobserver > - lobsdiag_allocated=.true. - - if(.not.last_pass) then - call timer_fnl('setuprhsall') - return - endif - -! Deallocate wind field array for Lagrangian data assimilation - call lag_destroy_uv() - -! Finalize qc and accumulate statistics for GPSRO data - call gpsStats_genstats(bwork,awork(:,i_gps),toss_gps_sub,conv_diagsave,mype) - call gpsStats_destroy() ! replacing ... - ! -- call genstats_gps(bwork,awork(1,i_gps),toss_gps_sub,conv_diagsave,mype) - - if (conv_diagsave) close(7) - - if(l_PBL_pseudo_SurfobsT.or.l_PBL_pseudo_SurfobsQ.or.l_PBL_pseudo_SurfobsUV) then - else - call obsdiags_sort() - endif - -! for temporary testing purposes, _write and _read. - if(OBSDIAGS_RELOAD) then - call obsdiags_write('obsdiags.ttt',force=.true.) - ! call Barrier() before obsdiags_read(), to make sure all PEs have - ! finished their obsdiags_write(). - if(mPEs_observer>0) call MPI_Barrier(mpi_comm_world,ier) - - call obsdiags_read('obsdiags.ttt',mPEs=mPEs_observer,force=.true., & - ignore_iter=.true.) - call inquire_obsdiags(miter) - endif - -! call inquire_obsdiags(miter) - -! Collect information for preconditioning - if (newpc4pred) then - call mpl_allreduce(jpch_rad,rpvals=ostats) - call mpl_allreduce(npred,jpch_rad,rstats) - end if - -! Collect information for aircraft data - if (aircraft_t_bc_pof .or. aircraft_t_bc) then -! call mpl_allreduce(npredt,max_tail,ostats_t) -! call mpl_allreduce(npredt,max_tail,rstats_t) - call mpl_allreduce(npredt,ntail,ostats_t) - call mpl_allreduce(npredt,ntail,rstats_t) - end if - - if (newpc4pred .or. aircraft_t_bc_pof .or. aircraft_t_bc) then - call reset_predictors_var - end if - -! Collect satellite and precip. statistics - call mpi_reduce(aivals,aivals1,size(aivals1),mpi_rtype,mpi_sum,mype_rad, & - mpi_comm_world,ierror) - - call mpi_reduce(stats,stats1,size(stats1),mpi_rtype,mpi_sum,mype_rad, & - mpi_comm_world,ierror) - - if (ihave_oz) call mpi_reduce(stats_oz,stats_oz1,size(stats_oz1),mpi_rtype,mpi_sum,mype_oz, & - mpi_comm_world,ierror) - - if (ihave_co) call mpi_reduce(stats_co,stats_co1,size(stats_co1),mpi_rtype,mpi_sum,mype_co, & - mpi_comm_world,ierror) - -! Collect conventional data statistics - - call mpi_allreduce(bwork,bwork1,size(bwork1),mpi_rtype,mpi_sum,& - mpi_comm_world,ierror) - - call mpi_allreduce(awork,awork1,size(awork1),mpi_rtype,mpi_sum, & - mpi_comm_world,ierror) - -! Compute and print statistics for radiance, precipitation, and ozone data. -! These data types are NOT processed when running in 2dvar mode. Hence -! the check on the 2dvar flag below. - - if ( (l4dvar.and.lobserver) .or. .not.l4dvar ) then - - if (.not.twodvar_regional) then - -! Compute and print statistics for radiance data - if(mype==mype_rad) call statsrad(aivals1,stats1,ndata) - -! Compute and print statistics for precipitation data - if(mype==mype_rad) call statspcp(aivals1,ndata) - -! Compute and print statistics for ozone - if (mype==mype_oz .and. ihave_oz) call statsoz(stats_oz1,ndata) - -! Compute and print statistics for carbon monoxide -!???? if (mype==mype_co .and. ihave_co) call statsco(stats_co1,bwork1,awork1(1,i_co),ndata) - - endif - -! Compute and print statistics for "conventional" data - call statsconv(mype,& - i_ps,i_uv,i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag, & - i_gust,i_vis,i_pblh,i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv, & - i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,i_ref,bwork1,awork1,ndata) - - endif ! < .not. lobserver > - - deallocate(awork1) - call rhs_dealloc() ! destroy the workspace: awork, bwork, etc. -! Print Jo table - nprt=2 - llouter=.true. - if(luse_obsdiag)call evaljo(zjo,iobs,nprt,llouter) - -! If only performing sst retrieval, end program execution - if(retrieval)then - deallocate(fbias) - if(mype==0)then - write(6,*)'SETUPRHSALL: normal completion for retrieval' - call w3tage('GLOBAL_SSI') - end if - call mpi_finalize(ierror) - stop - end if - -! Finalize timer - call timer_fnl('setuprhsall') - - return -end subroutine setuprhsall diff --git a/src/setuprw.f90 b/src/setuprw.f90 deleted file mode 100644 index c1f2004e5..000000000 --- a/src/setuprw.f90 +++ /dev/null @@ -1,944 +0,0 @@ -subroutine setuprw(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuprw compute rhs of oi for radar radial winds -! prgmmr: parrish org: np22 date: 1990-10-06 -! -! abstract: For radar radial wind observations, this routine -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 1990-10-06 parrish -! 1998-04-10 weiyu yang -! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-17 treadon - update documentation -! 2004-08-02 treadon - add only to module use, add intent in/out -! 2004-10-06 parrish - increase size of rwork array for nonlinear qc -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list -! 2005-03-02 dee - remove garbage from diagnostic file -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-05-27 derber - level output change -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-11-03 treadon - correct error in index values for data array -! 2005-11-29 derber - remove psfcg and use ges_lnps instead -! 2006-01-31 todling/treadon - store wgt/wgtlim in rdiagbuf(6,ii) -! 2006-02-02 treadon - rename lnprsl as ges_lnprsl -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-04-21 parrish - new forward model based on beam vertical uncertainty -! 2006-05-23 parrish - use model terrain at station location for zsges -! 2006-05-30 su,derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - unify NL qc -! 2006-07-31 kleist - use ges_ps instead of lnps -! 2006-08-28 su - fix a bug in variational qc -! 2008-05-23 safford - rm unused vars and uses -! 2008-12-03 todling - changed handle of tail%time -! 2009-02-17 tong - modifed to use airborne radar data -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2011-03-28 s.liu - add subtype to radial wind -! 2011-05-25 s.liu/parrish - correct error in height assigned to radial wind -! 2012-02-08 wu - bug fix to keep from using below ground radar obs, with extra printout -! added to identify which obs are below ground. -! 2013-01-22 parrish - change grdcrd to grdcrd1, tintrp2a to tintrp2a1, tintrp2a11, -! tintrp3 to tintrp31 (so debug compile works on WCOSS) -! 2013-01-22 parrish - WCOSS debug compile execution error rwgt not assigned a value. -! set rwgt = 1 at beginning of obs loop. -! 2013-02-15 parrish - WCOSS debug compile execution error, k1=k2 but data(iobs_type,i) <=3, causes 0./0. -! 2013-06-07 tong - add a factor to adjust tdr obs gross error and add an option to adjust -! tdr obs error -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-06-23 lippi - Add vertical velocity to observation operator. Now, -! costilt is multiplied here instead of factored into wij. -! nml option include_w is used. Add a conditional to use -! maginnov and magoberr parameters from single ob namelist. -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use m_obsdiags, only: rwhead - use obsmod, only: rmiss_single,i_rw_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode, only: obsNode - use m_rwNode, only: rwNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use qcmod, only: npres_print,ptop,pbot,tdrerr_inflate - use guess_grids, only: hrdifsig,geop_hgtl,nfldsig,& - ges_lnprsl,sfcmod_gfs,sfcmod_mm5,comp_fact10 - use gridmod, only: nsig,get_ijk - use constants, only: flattening,semi_major_axis,grav_ratio,zero,grav,wgtlim,& - half,one,two,grav_equator,eccentricity,somigliana,rad2deg,deg2rad - use constants, only: tiny_r_kind,cg_term,huge_single,r2000,three,one - use jfunc, only: jiter,last,miter - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - - -! Declare local parameters - real(r_kind),parameter:: r0_001 = 0.001_r_kind - real(r_kind),parameter:: r8 = 8.0_r_kind - real(r_kind),parameter:: ten = 10.0_r_kind - real(r_kind),parameter:: r200 = 200.0_r_kind - -! Declare external calls for code analysis - external:: tintrp2a1,tintrp2a11 - external:: tintrp31 - external:: grdcrd1 - external:: stop2 - -! Declare local variables - real(r_kind) rlow,rhgh,rsig - real(r_kind) dz,factelv,factdif - real(r_kind) dlnp,pobl,zob - real(r_kind) sin2,termg,termr,termrg - real(r_kind) psges,zsges,zsges0 - real(r_kind),dimension(nsig):: zges,hges,ugesprofile,vgesprofile - real(r_kind),dimension(nsig):: wgesprofile!,vTgesprofile,refgesprofile - real(r_kind) prsltmp(nsig) - real(r_kind) sfcchk - real(r_kind) residual,obserrlm,obserror,ratio,scale,val2 - real(r_kind) ress,ressw - real(r_kind) val,valqc,rwgt - real(r_kind) cg_w,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2 - real(r_double) rstation_id - real(r_kind) dlat,dlon,dtime,dpres,ddiff,error,slat - real(r_kind) sinazm,cosazm,sintilt,costilt,cosazm_costilt,sinazm_costilt - real(r_kind) ratio_errors,qcgross - real(r_kind) ugesin,vgesin,wgesin,factw,skint,sfcr - real(r_kind) rwwind,presw,Vr - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - integer(i_kind) i,nchar,nreal,k,j,k1,ii - integer(i_kind) mm1,jj,k2,isli - integer(i_kind) jsig,ikxx,nn,ibin,ioff,ioff0 - integer(i_kind) ier,ilat,ilon,ihgt,irwob,ikx,itime,iuse - integer(i_kind):: ielev,id,itilt,iazm,ilone,ilate,irange - integer(i_kind):: izsges,ier2,idomsfc,isfcr,iskint,iff10,iobs_type - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - logical include_w - - equivalence(rstation_id,station_id) - real(r_kind) addelev,wrange,beamdepth,elevtop,elevbot - integer(i_kind) kbeambot,kbeamtop,kbeamdiffmax,kbeamdiffmin - real(r_kind) uminmin,umaxmax - integer(i_kind) numequal,numnotequal,kminmin,kmaxmax,istat - real(r_kind) rwwindprofile - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(rwNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - character(len=*),parameter:: myname='setuprw' - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_w - -! Check to see if required guess fields are available - call check_vars_(proceed,include_w) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!******************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ihgt=4 ! index of obs elevation - irwob=5 ! index of radial wind observation - iazm=6 ! index of azimuth angle in data array - itime=7 ! index of observation time in data array - ikxx=8 ! index of obs type in data array - itilt=9 ! index of tilt angle in data array - ielev=10 ! index of radar elevation - id=11 ! index of station id - iuse=12 ! index of use parameter - idomsfc=13 ! index of dominant surface type - iskint=14 ! index of surface skin temperature - iff10=15 ! index of 10 meter wind factor - isfcr=16 ! index of surface roughness - ilone=17 ! index of longitude (degrees) - ilate=18 ! index of latitude (degrees) - irange=19 ! index of range in km of obs from radar - izsges=20 ! index of model (guess) elevation for radar associated with vad wind - ier2=21 ! index of original-original obs error - iobs_type=22 - - numequal=0 - numnotequal=0 - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=22 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - mm1=mype+1 - scale=one - rsig=nsig - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - kbeamdiffmin=huge(kbeamdiffmin) - kbeamdiffmax=-huge(kbeamdiffmax) - - call dtime_setup() - do i=1,nobs - rwgt=one - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - dpres=data(ihgt,i) - ikx = nint(data(ikxx,i)) - error=data(ier2,i) - slat=data(ilate,i)*deg2rad - wrange=data(irange,i) - zsges0=data(izsges,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_rw_ob_type,ibin)%head)) then - obsdiags(i_rw_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_rw_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuprw: failure to allocate obsdiags',istat - call stop2(286) - end if - obsdiags(i_rw_ob_type,ibin)%tail => obsdiags(i_rw_ob_type,ibin)%head - else - allocate(obsdiags(i_rw_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuprw: failure to allocate obsdiags',istat - call stop2(286) - end if - obsdiags(i_rw_ob_type,ibin)%tail => obsdiags(i_rw_ob_type,ibin)%tail%next - end if - obsdiags(i_rw_ob_type,ibin)%n_alloc = obsdiags(i_rw_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_rw_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_rw_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_rw_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_rw_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_rw_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_rw_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_rw_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_rw_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_rw_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_rw_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_rw_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_rw_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_rw_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_rw_ob_type,ibin)%tail)) then - obsdiags(i_rw_ob_type,ibin)%tail => obsdiags(i_rw_ob_type,ibin)%head - else - obsdiags(i_rw_ob_type,ibin)%tail => obsdiags(i_rw_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_rw_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_rw_ob_type,ibin)%tail)') - end if - if (obsdiags(i_rw_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuprw: index error' - call stop2(288) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Interpolate log(surface pressure), -! log(pres) at mid-layers, and geopotenital height to -! observation location. - - factw=data(iff10,i) - if(sfcmod_gfs .or. sfcmod_mm5) then - sfcr=data(isfcr,i) - skint=data(iskint,i) - isli=data(idomsfc,i) - call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) - end if - - call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - if(zsges>=dpres)then - write(6,*) 'SETUPRW: zsges = ',zsges,'is greater than dpres ',dpres,'. Rejecting ob.' - cycle - endif - dpres=dpres-zsges - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - call tintrp2a1(geop_hgtl,hges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - -! Convert geopotential height at layer midpoints to geometric height using -! equations (17, 20, 23) in MJ Mahoney's note "A discussion of various -! measures of altitude" (2001). Available on the web at -! http://mtp.jpl.nasa.gov/notes/altitude/altitude.html -! -! termg = equation 17 -! termr = equation 21 -! termrg = first term in the denominator of equation 23 -! zges = equation 23 - sin2 = sin(slat)*sin(slat) - termg = grav_equator * & - ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) - termr = semi_major_axis /(one + flattening + grav_ratio - & - two*flattening*sin2) - termrg = (termg/grav)*termr - do k=1,nsig - zges(k) = (termr*hges(k)) / (termrg-hges(k)) ! eq (23) - end do - -! Given observation height, (1) adjust 10 meter wind factor if -! necessary, (2) convert height to grid relative units, (3) compute -! compute observation pressure (for diagnostic purposes only), and -! (4) compute location of midpoint of first model layer above surface -! in grid relative units - -! Adjust 10m wind factor if necessary. Rarely do we have a -! lidar obs within 10 meters of the surface. Almost always, -! the code below resets the 10m wind factor to 1.0 i.e., no -! reduction in wind speed due to surface friction). - if (dpresk1) then !???????????? to fix problem where k1=k2, which should only happen if k1=k2=nsig - dz = zges(k2)-zges(k1) - dlnp = prsltmp(k2)-prsltmp(k1) - pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1)) - else - write(6,*)' iobs_type,data(iobs_type,i),k,k1,k2,nsig,zob,zges(k1),prsltmp(k1)=',& ! diagnostic only?????????????? - iobs_type,data(iobs_type,i),k,k1,k2,nsig,zob,zges(k1),prsltmp(k1) - pobl = prsltmp(k1) - end if - - presw = ten*exp(pobl) - -! Determine location in terms of grid units for midpoint of -! first layer above surface - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp,nsig,-1) - -! Check to see if observation is below midpoint of first -! above surface layer. If so, set rlow to that difference - rlow=max(sfcchk-dpres,zero) - -! Check to see if observation is above midpoint of layer -! at the top of the model. If so, set rhgh to that difference. - rhgh=max(dpres-r0_001-nsig,zero) - -! Increment obs counter along with low and high obs counters - if(luse(i))then - awork(1)=awork(1)+one - if(rhgh/=zero) awork(2)=awork(2)+one - if(rlow/=zero) awork(3)=awork(3)+one - end if - -! Adjust observation error. - -! Increase error for observations over high topography - factelv=one - if (data(iobs_type,i) <= three) then - if (data(ielev,i) > r2000) then - factelv=(r2000/data(ielev,i))**2 - if(luse(i))awork(5) = awork(5) + one - endif - endif - -! Increase error if model and observation topography too different - factdif=one - if (data(iobs_type,i) <= three) then - if (abs(zsges0-data(ielev,i)) > r200) then - factdif= (r200/(abs(zsges0-data(ielev,i))))**2 - if(luse(i))awork(6) = awork(6) + one - endif - endif - -! Obtain estimated beam spread in vertical - if (data(iobs_type,i) <= three) then - addelev=max(half*abs(zsges0-data(ielev,i)),ten*wrange) - else - addelev=17.4*wrange ! TDR radar beam width is 1.9 to 2.0 degree - endif - beamdepth=two*addelev - elevtop=zob+addelev ! this is based on 100ft/Nm = 16.5m/km beam spread - elevbot=zob-addelev ! for .95 deg beam angle (multiplied by 1.2 to allow - ! for propagation uncertainty) - ! also, a minimum uncertainty based on difference between - ! model surface elevation and actual radar elevation - ! for TDR radars, beam width is 1.9 for NOAA Parabolic - ! and 2.0 degree for French dual-plate - - call grdcrd1(elevtop,zges,nsig,1) - call grdcrd1(elevbot,zges,nsig,1) - kbeamtop=ceiling(elevtop) - kbeambot=floor(elevbot) - kbeamtop=max(1,min(kbeamtop,nsig)) - kbeambot=max(1,min(kbeambot,nsig)) - kbeamdiffmax=max(kbeamtop-kbeambot,kbeamdiffmax) - kbeamdiffmin=min(kbeamtop-kbeambot,kbeamdiffmin) - - ratio_errors = factdif*factelv*error/(abs(data(ier,i) + 1.0e6_r_kind*rhgh + & - r8*rlow)) - error = one/error - - if(dpres < zero .or. dpres > rsig)ratio_errors = zero - -! Interpolate guess u, v, and w to observation location and time. - call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime,& - hrdifsig,mype,nfldsig) - call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime,& - hrdifsig,mype,nfldsig) - if(include_w) then - call tintrp31(ges_w,wgesin,dlat,dlon,dpres,dtime,& - hrdifsig,mype,nfldsig) - end if - - call tintrp2a1(ges_u,ugesprofile,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - call tintrp2a1(ges_v,vgesprofile,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - if(include_w) then - call tintrp2a1(ges_w,wgesprofile,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - end if - -! Convert guess u,v wind components to radial value consident with obs - cosazm = cos(data(iazm,i)) ! cos(azimuth angle) - sinazm = sin(data(iazm,i)) ! sin(azimuth angle) - costilt = cos(data(itilt,i)) ! cos(tilt angle) - sintilt = sin(data(itilt,i)) ! sin(tilt angle) - cosazm_costilt = cosazm*costilt - sinazm_costilt = sinazm*costilt - !vTgesprofile= 5.40_r_kind*(exp((refgesprofile -43.1_r_kind)/17.5_r_kind)) -! rwwind = (ugesin*cosazm+vgesin*sinazm)*costilt*factw - umaxmax=-huge(umaxmax) - uminmin=huge(uminmin) - kminmin=kbeambot - kmaxmax=kbeamtop - do k=kbeambot,kbeamtop - rwwindprofile=ugesprofile(k)*cosazm_costilt+vgesprofile(k)*sinazm_costilt - if(include_w) then - rwwindprofile=rwwindprofile+wgesprofile(k)*sintilt - end if - - if(umaxmaxrwwindprofile) then - uminmin=rwwindprofile - kminmin=k - end if - end do - rwwind=data(irwob,i) - if(data(irwob,i)umaxmax) then - rwwind=umaxmax - dpres=kmaxmax - end if - if(rwwind==data(irwob,i)) then - numequal=numequal+1 - else - numnotequal=numnotequal+1 - end if - - ddiff = data(irwob,i) - rwwind - -! If requested, setup for single obs test. - if(oneobtest) then - ddiff=maginnov - Vr=ddiff+rwwind - error=one/magoberr - ratio_errors=one - end if - - -! adjust obs error for TDR data - if(data(iobs_type,i) > three .and. ratio_errors*error > tiny_r_kind & - .and. tdrerr_inflate) then - ratio_errors = data(ier2,i)/abs(data(ier,i) + 1.0e6_r_kind*rhgh + & - r8*rlow + min(max((abs(ddiff)-ten),zero)/ten,one)*data(ier,i)) - end if - -! Gross error checks - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - qcgross=cgross(ikx) - - if (ratio > qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(4) = awork(4)+one - error = zero - ratio_errors = zero - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_rw_ob_type,ibin)%tail%muse(nobskeep) - - val = error*ddiff - -! Compute penalty terms (linear & nonlinear qc). - if(luse(i))then - exp_arg = -half*val**2 - rat_err2 = ratio_errors**2 - val2=val*val - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_w=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_w*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - jsig = dpres - jsig=max(1,min(jsig,nsig)) - awork(6*nsig+jsig+100)=awork(6*nsig+jsig+100)+val2*rat_err2 - awork(5*nsig+jsig+100)=awork(5*nsig+jsig+100)+one - awork(3*nsig+jsig+100)=awork(3*nsig+jsig+100)+valqc - end if - -! Loop over pressure level groupings and obs to accumulate -! statistics as a function of observation type. - ress = scale*ddiff - ressw = ress*ress - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - do k = 1,npres_print - if(presw >ptop(k) .and. presw<=pbot(k))then - bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count - bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ddiff ! bias - bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 - bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty - - end if - end do - end if - - if (luse_obsdiag) then - obsdiags(i_rw_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_rw_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_rw_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if ( .not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(rwhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j,k) indices of guess gridpoint that bound obs location - my_head%dlev = dpres - my_head%factw= factw - call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) - - do j=1,8 - my_head%wij(j)=factw*my_head%wij(j) - end do - my_head%raterr2 = ratio_errors**2 - my_head%cosazm_costilt = cosazm_costilt - my_head%sinazm_costilt = sinazm_costilt - my_head%sintilt = sintilt - my_head%res = ddiff - my_head%err2 = error**2 - my_head%time = dtime - my_head%luse = luse(i) - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_rw_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - - my_head => null() - endif - -! Save select output for diagnostic file - if(conv_diagsave)then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) - rdiagbuf(6,ii) = presw ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - -! rdiagbuf(9,ii) = rmiss_single ! input prepbufr qc or event mark - rdiagbuf(9,ii) = data(iobs_type,i) ! observation subtype - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m/s)**-1 - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m/s)**-1 - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m/s)**-1 - - rdiagbuf(17,ii) = data(irwob,i) ! radial wind speed observation (m/s) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (m/s) - rdiagbuf(19,ii) = data(irwob,i)-rwwind ! obs-ges w/o bias correction (m/s) (future slot) - - - rdiagbuf(20,ii)=data(iazm,i)*rad2deg ! azimuth angle - rdiagbuf(21,ii)=data(itilt,i)*rad2deg! tilt angle - rdiagbuf(22,ii) = factw ! 10m wind reduction factor - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_rw_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_rw_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_rw_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_rw_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:rw',i_rw_ob_type) - write(7)' rw',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed, include_w) - logical,intent(inout) :: proceed - logical,intent(inout) :: include_w - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::u' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::v' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::w' , ivar, istatus ) - if (ivar>0) then - include_w=.true. - else - include_w=.false. - endif - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get u ... - varname='u' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_u))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_u(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_u(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get v ... - varname='v' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_v))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_v(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_v(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get w ... - if(include_w) then - varname='w' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_w))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_w(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_w(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_w(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle,ier= ',istatus - call stop2(999) - endif - end if - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_w )) deallocate(ges_w ) - if(allocated(ges_v )) deallocate(ges_v ) - if(allocated(ges_u )) deallocate(ges_u ) - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps)) deallocate(ges_ps) - end subroutine final_vars_ - -end subroutine setuprw diff --git a/src/setupspd.f90 b/src/setupspd.f90 deleted file mode 100644 index 4eb73e68c..000000000 --- a/src/setupspd.f90 +++ /dev/null @@ -1,857 +0,0 @@ -subroutine setupspd(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupspd compute rhs of oi for wind speed obs -! prgmmr: parrish org: np22 date: 1990-10-06 -! -! abstract: For wind speed observations, this routine -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 1990-10-06 parrish -! 1998-04-10 weiyu yang -! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-17 treadon - update documentation -! 2004-08-02 treadon - add only to module use, add intent in/out -! 2004-10-06 parrish - increase size of vwork array for nonlinear qc -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list -! 2005-03-02 dee - remove garbage from diagnostic file -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-05-27 derber - level output change -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-11-03 treadon - correct error in ilone,ilate data array indices -! 2005-11-29 derber - remove psfcg and use ges_lnps instead -! 2006-01-31 todling/treadon - store wgt/wgtlim in rdiagbuf(6,ii) -! 2006-02-02 treadon - rename lnprsl as ges_lnprsl -! 2006-02-08 treadon - correct vertical dimension (nsig) in call tintrp2a(ges_tv...) -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-03-21 treadon - add option to perturb observation -! 2006-05-30 su,derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - modify handling of multiple data at same location -! - unify NL qc -! 2006-07-31 kleist - use ges_ps instead of lnps -! 2006-08-28 su - fix a bug in variational qc -! 2007-03-09 su - modify the observation perturbation -! 2007-03-19 tremolet - binning of observations -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-08-28 su - modify the observation gross check error -! 2008-05-23 safford - rm unused vars and uses -! 2008-12-03 todling - changed handling of ptr%time -! 2009-02-06 pondeca - for each observation site, add the following to the -! diagnostic file: local terrain height, dominate surface -! type, station provider name, and station subprovider name -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2012-01-12 hu - add code to get vertical grid coordinate ibased on height for -! 260 (nacelle) and 261 (tower) -! 2013-01-26 parrish - convert grdcrd to grdcrd1, tintrp2a to tintrp2a1, tintrp2a11, -! tintrp3 to tintrp31 (so debug compile works on WCOSS) -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - use m_obsdiags, only: spdhead - use obsmod, only: rmiss_single,i_spd_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode, only: obsNode - use m_spdNode, only: spdNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use guess_grids, only: nfldsig,hrdifsig,ges_lnprsl, & - comp_fact10,sfcmod_gfs,sfcmod_mm5 - use guess_grids, only: geop_hgtl - use gridmod, only: nsig,get_ij,twodvar_regional - use qcmod, only: npres_print,ptop,pbot - use constants, only: one,grav,rd,zero,four,tiny_r_kind, & - half,two,cg_term,huge_single,r1000,wgtlim - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1 - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - use m_dtime, only: dtime_setup, dtime_check, dtime_show - - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare local variables - real(r_kind),parameter:: ten=10.0_r_kind - character(len=*),parameter:: myname='setupspd' - -! Declare external calls for code analysis - external:: tintrp2a1,tintrp2a11 - external:: tintrp31 - external:: grdcrd1 - external:: stop2 - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) uob,vob,spdges,spdob,spdob0,goverrd,ratio_errors - real(r_kind) presw,factw,dpres,ugesin,vgesin,sfcr,skint - real(r_kind) scale - real(r_kind) val2,ressw,ress,error,ddiff,dx10,rhgh,prsfc,r0_001 - real(r_kind) sfcchk,prsln2,rwgt,tfact - real(r_kind) thirty,rsig,ratio,residual,obserrlm,obserror - real(r_kind) val,valqc,psges,drpx,dlat,dlon,dtime,dpresave,rlow - real(r_kind) cg_spd,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2 - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nele,nobs):: data - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nsig)::prsltmp,tges - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - integer(i_kind) mm1,ibin,ioff,ioff0 - integer(i_kind) ii,jj,i,nchar,nreal,k,j,l,nty,nn,ikxx - integer(i_kind) ier,ilon,ilat,ipres,iuob,ivob,id,itime,ikx - integer(i_kind) ihgt,iqc,ier2,iuse,ilate,ilone,istnelv,istat,izz,iprvd,isprvd - integer(i_kind) idomsfc,iskint,iff10,isfcr,isli - - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(spdNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - logical z_height - real(r_kind) zsges,dstn - real(r_kind),dimension(nsig):: zges - real(r_kind) dz,zob,z1,z2,p1,p2,dz21,dlnp21,pobl - integer(i_kind) k1,k2 - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv - - n_alloc(:)=0 - m_alloc(:)=0 -!****************************************************************************** -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - iuob=5 ! index of u observation - ivob=6 ! index of v observation - id=7 ! index of station id - itime=8 ! index of observation time in data array - ikxx=9 ! index of ob type - ihgt=10 ! index of observation elevation - iqc=11 ! index of quality mark - ier2=12 ! index of original-original obs error ratio - iuse=13 ! index of use parameter - idomsfc=14 ! index of dominant surface type - iskint=15 ! index of surface skin temperature - iff10=16 ! index of 10 meter wind factor - isfcr=17 ! index of surface roughness - ilone=18 ! index of longitude (degrees) - ilate=19 ! index of latitude (degrees) - istnelv=20 ! index of station elevation (m) - izz=21 ! index of surface height - iprvd=22 ! index of observation provider - isprvd=23 ! index of observation subprovider - - mm1=mype+1 - scale=one - rsig=nsig - thirty = 30.0_r_kind - r0_001=0.001_r_kind - goverrd=grav/rd - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=20 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ipres,k)== data(ipres,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(l) .and. muse(k))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - dpres=data(ipres,i) - error=data(ier2,i) - ikx=nint(data(ikxx,i)) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_spd_ob_type,ibin)%head)) then - obsdiags(i_spd_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_spd_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupspd: failure to allocate obsdiags',istat - call stop2(289) - end if - obsdiags(i_spd_ob_type,ibin)%tail => obsdiags(i_spd_ob_type,ibin)%head - else - allocate(obsdiags(i_spd_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupspd: failure to allocate obsdiags',istat - call stop2(290) - end if - obsdiags(i_spd_ob_type,ibin)%tail => obsdiags(i_spd_ob_type,ibin)%tail%next - end if - obsdiags(i_spd_ob_type,ibin)%n_alloc = obsdiags(i_spd_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_spd_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_spd_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_spd_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_spd_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_spd_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_spd_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_spd_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_spd_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_spd_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_spd_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_spd_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_spd_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_spd_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_spd_ob_type,ibin)%tail)) then - obsdiags(i_spd_ob_type,ibin)%tail => obsdiags(i_spd_ob_type,ibin)%head - else - obsdiags(i_spd_ob_type,ibin)%tail => obsdiags(i_spd_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_spd_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_spd_ob_type,ibin)%tail)') - end if - if (obsdiags(i_spd_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupspd: index error' - call stop2(291) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Load obs error and u,v obs - obserror = max(cermin(ikx),min(cermax(ikx),data(ier,i))) - uob = data(iuob,i) - vob = data(ivob,i) - - - spdob=sqrt(uob*uob+vob*vob) - call tintrp2a1(ges_tv,tges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - - factw = data(iff10,i) - if(sfcmod_gfs .or. sfcmod_mm5)then - sfcr = data(isfcr,i) - skint = data(iskint,i) - isli=data(idomsfc,i) - call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) - end if - - nty=ictype(ikx) - - z_height = .false. -! if ( nty == 260 .or. nty == 261) z_height = .true. -! nty == 292 is temporarily assigned to SFMR retrieved wind speed from recon -! and is subjet to change in the future - if ( nty == 260 .or. nty == 261 .or. nty == 292) z_height = .true. - -! Process observations reported with height differently than those -! reported with pressure. Type 260=nacelle 261=tower wind spd are -! encoded in NCEP prepbufr files with geometric height above -! sea level. - - if (z_height) then - - drpx = zero - dpres = data(ihgt,i) - dstn = data(istnelv,i) - call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - -! Get guess surface elevation and geopotential height profile -! at observation location. - call tintrp2a1(geop_hgtl,zges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - -! Convert observation height (in dpres) from meters to grid relative -! units. Save the observation height in zob for later use. - zob = dpres - call grdcrd1(dpres,zges,nsig,1) - factw=one - rlow=zero - rhgh=zero - -! Compute observation pressure (only used for diagnostics) -! Set indices of model levels below (k1) and above (k2) observation. - if (dpresnsig) then - z1=zges(nsig-1); p1=prsltmp(nsig-1) - z2=zges(nsig); p2=prsltmp(nsig) - drpx = 1.e6_r_kind - else - k=dpres - k1=min(max(1,k),nsig) - k2=max(1,min(k+1,nsig)) - z1=zges(k1); p1=prsltmp(k1) - z2=zges(k2); p2=prsltmp(k2) - endif - - dz21 = z2-z1 - dlnp21 = p2-p1 - dz = zob-z1 - pobl = p1 + (dlnp21/dz21)*dz - presw = ten*exp(pobl) - -! Process observations with reported pressure - else - - presw = ten*exp(dpres) - dpres = dpres-log(psges) - drpx=zero - if(nty >= 280 .and. nty < 290)then - dpresave=dpres - dpres=-goverrd*data(ihgt,i)/tges(1) - if(nty < 283)drpx=abs(dpres-dpresave)*factw*thirty - end if - - prsfc=psges - prsln2=log(exp(prsltmp(1))/prsfc) - sfcchk=log(psges) - if(dpres <= prsln2)then - factw=one - else - dx10=-goverrd*ten/tges(1) - if (dpres < dx10)then - factw=(dpres-dx10+factw*(prsln2-dpres))/(prsln2-dx10) - end if - end if - -! Put obs pressure in correct units to get grid coord. number - dpres=log(exp(dpres)*prsfc) - call grdcrd1(dpres,prsltmp(1),nsig,-1) - -! Get approx k value of sfc by using surface pressure of 1st ob - call grdcrd1(sfcchk,prsltmp(1),nsig,-1) - - -! Check to see if observations is below what is seen to be the surface - rlow=max(sfcchk-dpres,zero) - - rhgh=max(dpres-r0_001-rsig,zero) - - endif ! end of process observations with reported pressure - - if(luse(i))then - awork(1) = awork(1) + one - if(rlow/=zero) awork(2) = awork(2) + one - if(rhgh/=zero) awork(3) = awork(3) + one - end if - - ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+four*rlow) - - -! Interpolate guess u and v to observation location and time. - call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - - -! Apply 10-meter wind reduction factor to guess winds. Compute -! guess wind speed. - ugesin=factw*ugesin - vgesin=factw*vgesin - spdges=sqrt(ugesin*ugesin+vgesin*vgesin) - ddiff = spdob-spdges - - if ( nty == 292 ) then - ratio_errors=error/(abs(ddiff)+5.0_r_kind) - if (spdob < 10.) ratio_errors=zero - endif - - error=one/error - -! Check to see if observations is above the top of the model (regional mode) - if (dpres>rsig) ratio_errors=zero - - -! Gross error checks - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - if (ratio>cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(4) = awork(4)+one - error = zero - ratio_errors = zero - muse(i)=.false. - else - ratio_errors=ratio_errors/sqrt(dup(i)) - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_spd_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_spd=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_spd*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - wgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - - -! Accumulate statistics for obs belonging to this task - if (luse(i) .and. muse(i)) then - if(rwgt < one) awork(61) = awork(61)+one - awork(5)=awork(5) + val2*rat_err2 - awork(6)=awork(6) + one - awork(22)=awork(22) + valqc - end if - -! Loop over pressure level groupings and obs to accumulate statistics -! as a function of observation type. - do k = 1,npres_print - if(luse(i) .and.presw >ptop(k) .and. presw<=pbot(k))then - ress = scale*ddiff - ressw = ress*ress - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count - bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ddiff ! bias - bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 - bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty - - end if - end do - - if (luse_obsdiag) then - obsdiags(i_spd_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_spd_ob_type,ibin)%tail%nldepart(jiter)=spdob-sqrt(ugesin*ugesin+vgesin*vgesin) - obsdiags(i_spd_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(spdhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%factw=factw - do j=1,4 - my_head%wij(j)=factw*my_head%wij(j) - end do - my_head%raterr2= ratio_errors**2 - my_head%res = spdob - my_head%uges = ugesin - my_head%vges = vgesin - my_head%err2 = error**2 - my_head%time = dtime - my_head%luse = luse(i) - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_spd_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - my_head => null() - end if -! Save select output for diagnostic file - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = presw ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - spdob0 = sqrt(data(iuob,i)*data(iuob,i)+data(ivob,i)*data(ivob,i)) - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m/s)**-1 - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m/s)**-1 - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m/s)**-1 - - rdiagbuf(17,ii) = spdob ! wind speed observation (m/s) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (m/s) - rdiagbuf(19,ii) = spdob0-spdges ! obs-ges w/o bias correction (m/s) (future slot) - - rdiagbuf(20,ii) = factw ! 10m wind reduction factor - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_spd_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_spd_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_spd_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_spd_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - -! End of loop over observations - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:spd',i_spd_ob_type) - write(7)'spd',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::u' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::v' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::tv', ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get u ... - varname='u' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_u))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_u(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_u(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get v ... - varname='v' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_v))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_v(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_v(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get tv ... - varname='tv' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_tv))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_tv(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_tv(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_tv)) deallocate(ges_tv) - if(allocated(ges_v )) deallocate(ges_v ) - if(allocated(ges_u )) deallocate(ges_u ) - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps)) deallocate(ges_ps) - end subroutine final_vars_ - -end subroutine setupspd diff --git a/src/setupsst.f90 b/src/setupsst.f90 deleted file mode 100644 index c6e08e4c5..000000000 --- a/src/setupsst.f90 +++ /dev/null @@ -1,564 +0,0 @@ -subroutine setupsst(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupsst compute rhs for conventional surface sst -! prgmmr: derber org: np23 date: 2004-07-20 -! -! abstract: For sea surface temperature observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2004-07-20 derber -! 2004-08-02 treadon - add only to module use, add intent in/out -! 2004-08-28 derber - fix some bugs -! 2004-10-06 parrish - increase size of sstwork array for nonlinear qc -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list -! 2005-03-02 dee - remove garbage from diagnostic file -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-11-08 todling - bug fix: lat/lon arrays were inverted to diag file -! 2005-11-14 pondeca - correct error in diagnostic array index -! 2006-01-31 todling/treadon - store wgt/wgtlim in rdiagbuf(6,ii) -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-05-30 su,derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - modify handling of multiple data at same location -! - unify NL qc -! 2006-08-28 su - fix a bug in variational qc -! 2007-03-19 tremolet - binning of observations -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-08-28 su - modify the gross check error -! 2008-05-21 safford - rm unused vars and uses -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2011-04-02 li - set up Tr analysis and modify to save nst analysis related diagnostic variables -! 2012-04-10 akella - sstges calculated for nst analysis using NST fields -! 2013-01-26 parrish - change intrp2a to intrp2a11 (so debug compile works on WCOSS) -! 2014-01-28 li - add ntguessfc to use guess_grids to apply intrp2a11 correctly -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-05-30 li - Modify to make it work when nst_gsi = 0 and nsstbufr data file exists -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: dsfct,ntguessfc - use m_obsdiags, only: ssthead - use obsmod, only: rmiss_single,i_sst_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode, only: obsNode - use m_sstNode, only: sstNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig - use gridmod, only: get_ij - use constants, only: zero,tiny_r_kind,one,quarter,half,wgtlim, & - two,cg_term,pi,huge_single,r1000,tfrozen,r_missing - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use gsi_nstcouplermod, only: nst_gsi,nstinfo - use m_dtime, only: dtime_setup, dtime_check, dtime_show - implicit none - - integer(i_kind),parameter:: istyp=0,nprep=1 -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: intrp2a11 - external:: stop2 - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) sstges,dlat,dlon,ddiff,dtime,error,dsfct_obx,owpct - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,halfpi,rwgt - real(r_kind) cg_sst,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - real(r_kind) :: tz_tr,zob,tref,dtw,dtc - - integer(i_kind) ier,ilon,ilat,isst,id,itime,ikx,itemp,ipct - integer(i_kind) ier2,iuse,izob,itref,idtw,idtc,itz_tr,iotype,ilate,ilone,istnelv - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat,id_qc - integer(i_kind) idomsfc,itz - integer(i_kind) idatamax,nwsum,nfinal,nobs_qc - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(sstNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - integer, parameter:: maxinfo = 20 - character(len=*),parameter:: myname='setupsst' - - - equivalence(rstation_id,station_id) - - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - isst=4 ! index of sst observation - id=5 ! index of station id - itime=6 ! index of observation time in data array - ikxx=7 ! index of ob type - itemp=8 ! index of open water temperature (background) - izob=9 ! index of flag indicating depth of observation - iotype=10 ! index of measurement type - ipct=11 ! index of open water percentage - ier2=12 ! index of original obs error - iuse=13 ! index of use parameter - idomsfc=14 ! index of dominant surface type - itz=15 ! index of temperature at depth z (Tz) - ilone=16 ! index of longitude (degrees) - ilate=17 ! index of latitude (degrees) - istnelv=18 ! index of station elevation (m) - itref=19 ! index of Tr - idtw=20 ! index of dtw - idtc=21 ! index of dtc - itz_tr=22 ! index of tz_tr - idatamax=22 ! set to largest value in list above - - if(nst_gsi>0) then - if(nele 0)then - tref = data(itref,i) - dtw = data(idtw,i) - dtc = data(idtc,i) - tz_tr = data(itz_tr,i) - else - tref = data(itz,i) - dtw = zero - dtc = zero - tz_tr = r_missing - end if - - if (in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier2,i) - isli=data(idomsfc,i) - owpct=data(ipct,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_sst_ob_type,ibin)%head)) then - obsdiags(i_sst_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_sst_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupsst: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_sst_ob_type,ibin)%tail => obsdiags(i_sst_ob_type,ibin)%head - else - allocate(obsdiags(i_sst_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupsst: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_sst_ob_type,ibin)%tail => obsdiags(i_sst_ob_type,ibin)%tail%next - end if - obsdiags(i_sst_ob_type,ibin)%n_alloc = obsdiags(i_sst_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_sst_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_sst_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_sst_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_sst_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_sst_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_sst_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_sst_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_sst_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_sst_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_sst_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_sst_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_sst_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_sst_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_sst_ob_type,ibin)%tail)) then - obsdiags(i_sst_ob_type,ibin)%tail => obsdiags(i_sst_ob_type,ibin)%head - else - obsdiags(i_sst_ob_type,ibin)%tail => obsdiags(i_sst_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_sst_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_sst_ob_type,ibin)%tail)') - end if - if (obsdiags(i_sst_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupsst: index error' - call stop2(297) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Interpolate to get sst at obs location/time - if ( isli == 0 ) then - nobs_qc = nobs_qc + 1 - call intrp2a11(dsfct(1,1,ntguessfc),dsfct_obx,dlat,dlon,mype) - else - dsfct_obx = zero - endif - - if(nst_gsi > 1) then - sstges = max(tref+dtw-dtc+dsfct_obx, tfrozen) - else - sstges = max(data(itz,i)+dsfct_obx, tfrozen) - end if - -! Adjust observation error - ratio_errors=error/data(ier,i) - error=one/error - - if(owpct == 0 ) error = zero - - ddiff=data(isst,i)-sstges - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross check using innovation normalized by error - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - if( id_qc == 0 ) id_qc = 1 - else - ratio_errors=ratio_errors/sqrt(dup(i)) - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_sst_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_sst=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_sst*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - end if - ress = ddiff*scale - ressw2 = ress*ress - val2 = val*val - rat_err2 = ratio_errors**2 - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - - endif - - if(luse_obsdiag)then - obsdiags(i_sst_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_sst_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_sst_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(ssthead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%zob = zob - my_head%tz_tr = tz_tr - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_sst_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = data(itemp,i) ! background open water temperature (K) - rdiagbuf(7,ii) = data(izob,i) ! observation depth (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(ipct,i) ! open water percentage (0 to 1) - rdiagbuf(10,ii) = id_qc ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(isst,i) ! SST observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(isst,i)-sstges! obs-ges w/o bias correction (K) (future slot) - - rdiagbuf(20,ii) = data(iotype,i) ! type of measurement - - if (nst_gsi>0) then - rdiagbuf(maxinfo+1,ii) = data(itref,i) ! Tr - rdiagbuf(maxinfo+2,ii) = data(idtw,i) ! dt_warm at zob - rdiagbuf(maxinfo+3,ii) = data(idtc,i) ! dt_cool at zob - rdiagbuf(maxinfo+4,ii) = data(itz_tr,i) ! d(tz)/d(Tr) at zob - endif - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_sst_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_sst_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_sst_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_sst_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - - end do ! do i=1,nobs - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:sst',i_sst_ob_type) - write(7)'sst',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - end if - -! End of routine -end subroutine setupsst - diff --git a/src/setupt.f90 b/src/setupt.f90 deleted file mode 100755 index dc8b754c2..000000000 --- a/src/setupt.f90 +++ /dev/null @@ -1,1445 +0,0 @@ -!------------------------------------------------------------------------- -! NOAA/NCEP, National Centers for Environmental Prediction GSI ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: setupt --- Compute rhs of oi for temperature obs -! -! !INTERFACE: -! -subroutine setupt(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) - -! !USES: - - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use m_obsdiags, only: thead - use obsmod, only: sfcmodel,perturb_obs,oberror_tune,& - i_t_ob_type,obsdiags,lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode, only: obsNode - use m_tNode, only: tNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset - - use qcmod, only: npres_print,dfact,dfact1,ptop,pbot,buddycheck_t - use qcmod, only: njqc,vqc - - use oneobmod, only: oneobtest - use oneobmod, only: maginnov - use oneobmod, only: magoberr - - use gridmod, only: nsig,twodvar_regional,regional - use gridmod, only: get_ijk - use jfunc, only: jiter,last,jiterstart,miter - - use guess_grids, only: nfldsig, hrdifsig,ges_lnprsl,& - geop_hgtl,ges_tsen,pt_ll,pbl_height - - use constants, only: zero, one, four,t0c,rd_over_cp,three,rd_over_cp_mass,ten - use constants, only: tiny_r_kind,half,two,cg_term - use constants, only: huge_single,r1000,wgtlim,r10,fv - use constants, only: one_quad - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,icsubtype - use converr_t, only: ptabl_t - use converr, only: ptabl - use rapidrefresh_cldsurf_mod, only: l_gsd_terrain_match_surftobs,l_sfcobserror_ramp_t - use rapidrefresh_cldsurf_mod, only: l_pbl_pseudo_surfobst, pblh_ration,pps_press_incr - use rapidrefresh_cldsurf_mod, only: i_use_2mt4b,i_sfct_gross,l_closeobs,i_coastline - - use aircraftinfo, only: npredt,predt,aircraft_t_bc_pof,aircraft_t_bc, & - aircraft_t_bc_ext,ostats_t,rstats_t,upd_pred_t - - use m_dtime, only: dtime_setup, dtime_check, dtime_show - - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - use buddycheck_mod, only: buddy_check_t - - implicit none - -! !INPUT PARAMETERS: - - integer(i_kind) , intent(in ) :: lunin ! file unit from which to read observations - integer(i_kind) , intent(in ) :: mype ! mpi task id - integer(i_kind) , intent(in ) :: nele ! number of data elements per observation - integer(i_kind) , intent(in ) :: nobs ! number of observations - integer(i_kind) , intent(in ) :: is ! ndat index - logical , intent(in ) :: conv_diagsave ! logical to save innovation dignostics - - -! !INPUT/OUTPUT PARAMETERS: - - ! array containing information ... - real(r_kind),dimension(npres_print,nconvtype,5,3), intent(inout) :: bwork ! about o-g stats - real(r_kind),dimension(100+7*nsig) , intent(inout) :: awork ! for data counts and gross checks - -! !DESCRIPTION: For temperature observations, this routine -! \begin{enumerate} -! \item reads obs assigned to given mpi task (geographic region), -! \item simulates obs from guess, -! \item apply some quality control to obs, -! \item load weight and innovation arrays used in minimization -! \item collects statistics for runtime diagnostic output -! \item writes additional diagnostic information to output file -! \end{enumerate} -! -! !REVISION HISTORY: -! -! 1990-10-06 parrish -! 1998-04-10 weiyu yang -! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-17 treadon - update documentation -! 2004-07-15 todling - protex-compliant prologue; added intent/only's -! 2004-10-06 parrish - increase size of twork array for nonlinear qc -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list -! 2005-03-02 dee - remove garbage from diagnostic file -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-05-27 derber - level output change -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-10-21 su -modified variational qc and diagnostic output -! 2005-10-27 su - correct error in longitude index for diagnostic output -! 2005-11-03 treadon - correct error in ilone,ilate data array indices -! 2005-11-22 wu - add option to perturb conventional obs -! 2005-11-29 derber - remove psfcg and use ges_lnps instead -! 2005-12-20 parrish - add boundary layer forward model option -! 2005-12-20 parrish - correct dimension error in declaration of prsltmp -! 2006-01-31 todling - storing wgt/wgtlim in diag file instead of wgt only -! 2006-02-02 treadon - rename lnprsl as ges_lnprsl -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-03-21 treadon - modify optional perturbation to observation -! 2006-04-03 derber - optimize and fix bugs due to virtual temperature -! 2006-04-11 park - reset land mask for surface data based on observation type -! 2006-04-27 park - remove sensitivity test for surface TLM routine -! 2006-05-30 su,derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - modify handling of multiple data at same location -! - unify NL qc for surface model -! 2006-07-31 kleist - use ges_ps instead of lnps -! 2006-08-28 su - fix a bug in variational qc -! 2006-09-28 treadon - add 10m wind factor to sfc_wtq_fwd call -! 2006-10-28 su - turn off rawinsonde Vqc at south hemisphere -! 2007-03-09 su - modify the observation perturbation -! 2007-03-19 tremolet - binning of observations -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-08-28 su - modify the observation gross check error -! 2008-03-24 wu - oberror tuning and perturb obs -! 2008-05-21 safford - rm unused vars -! 2008-09-08 lueken - merged ed's changes into q1fy09 code -! 2008-12-03 todling - changed handle of tail%time -! 2009-02-07 pondeca - for each observation site, add the following to the -! diagnostic file: local terrain height, dominate surface -! type, station provider name, and station subprovider name -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2010-06-10 Hu - add call for terrain match for surface T obs -! 2011-05-06 Su - modify the observation gross check error -! 2011-12-14 wu - add code for rawinsonde level enhancement ( ext_sonde ) -! 2011-10-14 Hu - add code for adjusting surface temperature observation error -! 2011-10-14 Hu - add code for producing pseudo-obs in PBL -! layer based on surface obs T -! 2011-10-14 Hu - add code for using 2-m temperature as background to -! calculate surface temperauture observation -! innovation -! 2013-01-26 parrish - change grdcrd to grdcrd1, tintrp2a to tintrp2a1, tintrp2a11, -! tintrp3 to tintrp31 (so debug compile works on WCOSS) -! 2013-05-17 zhu - add contribution from aircraft temperature bias correction -! - with option aircraft_t_bc_pof or aircraft_t_bc -! 2013-05-24 wu - move rawinsonde level enhancement ( ext_sonde ) to read_prepbufr -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (idia) to header of diagfile -! 2014-03-04 sienkiewicz - implementation of option aircraft_t_bc_ext (external table) -! 2014-04-12 su - add non linear qc from Purser's scheme -! 2014-10-01 zhu - apply aircraft temperature bias correction to kx=130 -! 2014-10-06 carley - add call to buddy check for twodvar_regional option -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-02-09 Sienkiewicz - handling new KX=199 drifting buoys -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2015-12-21 yang - Parrish's correction to the previous code in new -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2017-03-31 Hu - addd option l_closeobs to use closest obs to analysis -! time in analysis -! 2017-03-31 Hu - addd option i_coastline to use observation operater -! for coastline area -! -! !REMARKS: -! language: f90 -! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq/HP -! -! !AUTHOR: -! parrish org: np22 date: 1990-10-06 -! -!EOP -!------------------------------------------------------------------------- - -! Declare local parameters - real(r_kind),parameter:: r0_001 = 0.001_r_kind - real(r_kind),parameter:: r0_7=0.7_r_kind - real(r_kind),parameter:: r8 = 8.0_r_kind - - character(len=*),parameter :: myname='setupt' - -! Declare external calls for code analysis - external:: SFC_WTQ_FWD - external:: get_tlm_tsfc - external:: tintrp2a1,tintrp2a11 - external:: tintrp31 - external:: grdcrd1 - external:: stop2 - -! Declare local variables - - - real(r_double) rstation_id - real(r_kind) rsig,drpx,rsigp - real(r_kind) psges,sfcchk,pres_diff,rlow,rhgh,ramp - real(r_kind) pof_idx,poaf,effective - real(r_kind) tges - real(r_kind) obserror,ratio,val2,obserrlm,ratiosfc - real(r_kind) residual,ressw2,scale,ress,ratio_errors,tob,ddiff - real(r_kind) val,valqc,dlon,dlat,dtime,dpres,error,prest,rwgt,var_jb - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final,tfact - real(r_kind) cg_t,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2,qcgross - real(r_kind),dimension(nobs)::dup - real(r_kind),dimension(nsig):: prsltmp - real(r_kind),dimension(nele,nobs):: data - real(r_kind),dimension(npredt):: predbias - real(r_kind),dimension(npredt):: pred - real(r_kind),dimension(npredt):: predcoef - real(r_kind) tgges,roges - real(r_kind),dimension(nsig):: tvtmp,qtmp,utmp,vtmp,hsges - real(r_kind) u10ges,v10ges,t2ges,q2ges,psges2,f10ges - real(r_kind),dimension(34) :: ptablt - real(r_single),allocatable,dimension(:,:)::rdiagbuf - real(r_single),allocatable,dimension(:,:)::rdiagbufp - - - real(r_kind),dimension(nsig):: prsltmp2 - - integer(i_kind) i,j,nchar,nreal,k,ii,iip,jj,l,nn,ibin,idia,idia0,ix,ijb - integer(i_kind) mm1,jsig,iqt - integer(i_kind) itype,msges - integer(i_kind) ier,ilon,ilat,ipres,itob,id,itime,ikx,iqc,iptrb,icat,ipof,ivvlc,idx - integer(i_kind) ier2,iuse,ilate,ilone,ikxx,istnelv,iobshgt,izz,iprvd,isprvd - integer(i_kind) regime,istat - integer(i_kind) idomsfc,iskint,iff10,isfcr - - integer(i_kind),dimension(nobs):: buddyuse - - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf,cdiagbufp - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical sfctype - logical iqtflg - logical aircraftobst - - logical:: in_curbin, in_anybin - logical proceed - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(tNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - real(r_kind) :: thisPBL_height,ratio_PBL_height,prestsfc,diffsfc,dthetav - real(r_kind) :: tges2m,qges2m,tges2m_water,qges2m_water - real(r_kind) :: hr_offset - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q - real(r_kind),allocatable,dimension(:,:,: ) :: ges_q2 - real(r_kind),allocatable,dimension(:,:,: ) :: ges_th2 - - n_alloc(:)=0 - m_alloc(:)=0 - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! call GSD terrain match for surface temperature observation - if(l_gsd_terrain_match_surftobs) then - call gsd_terrain_match_surfTobs(mype,nele,nobs,data) - endif - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - itob=5 ! index of t observation - id=6 ! index of station id - itime=7 ! index of observation time in data array - ikxx=8 ! index of ob type - iqt=9 ! index of flag indicating if moisture ob available - iqc=10 ! index of quality mark - ier2=11 ! index of original-original obs error ratio - iuse=12 ! index of use parameter - idomsfc=13 ! index of dominant surface type - iskint=14 ! index of surface skin temperature - iff10=15 ! index of 10 meter wind factor - isfcr=16 ! index of surface roughness - ilone=17 ! index of longitude (degrees) - ilate=18 ! index of latitude (degrees) - istnelv=19 ! index of station elevation (m) - iobshgt=20 ! index of observation height (m) - izz=21 ! index of surface height - iprvd=22 ! index of observation provider - isprvd=23 ! index of observation subprovider - icat=24 ! index of data level category - ijb=25 ! index of non linear qc parameter - if (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext) then - ipof=26 ! index of data pof - ivvlc=27 ! index of data vertical velocity - idx=28 ! index of tail number - iptrb=29 ! index of t perturbation - else - iptrb=26 ! index of t perturbation - end if - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - if (twodvar_regional .and. buddycheck_t) call buddy_check_t(is,data,luse,mype,nele,nobs,muse,buddyuse) - var_jb=zero - -! handle multiple reported data at a station - hr_offset=min_offset/60.0_r_kind - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ipres,k) == data(ipres,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - if(l_closeobs) then - if(abs(data(itime,k)-hr_offset)179.and.itype<190).or.(itype>=192.and.itype<=199) - - iqtflg=nint(data(iqt,i)) == 0 - var_jb=data(ijb,i) -! write(6,*) 'SETUPT:itype,var_jb,ijb=',itype,var_jb,ijb - -! Load observation value and observation error into local variables - tob=data(itob,i) - obserror = max(cermin(ikx),min(cermax(ikx),data(ier,i))) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_t_ob_type,ibin)%head)) then - obsdiags(i_t_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_t_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupt: failure to allocate obsdiags',istat - call stop2(298) - end if - obsdiags(i_t_ob_type,ibin)%tail => obsdiags(i_t_ob_type,ibin)%head - else - allocate(obsdiags(i_t_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupt: failure to allocate obsdiags',istat - call stop2(298) - end if - obsdiags(i_t_ob_type,ibin)%tail => obsdiags(i_t_ob_type,ibin)%tail%next - end if - obsdiags(i_t_ob_type,ibin)%n_alloc = obsdiags(i_t_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_t_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_t_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_t_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_t_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_t_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_t_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_t_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_t_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_t_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_t_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_t_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_t_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_t_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_t_ob_type,ibin)%tail)) then - obsdiags(i_t_ob_type,ibin)%tail => obsdiags(i_t_ob_type,ibin)%head - else - obsdiags(i_t_ob_type,ibin)%tail => obsdiags(i_t_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_t_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_t_ob_type,ibin)%tail)') - end if - if (obsdiags(i_t_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupt: index error' - call stop2(300) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Compute bias correction for aircraft data - if (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext) then - pof_idx = zero - do j = 1, npredt - pred(j) = zero - predbias(j) = zero - end do - end if - -! aircraftobst = itype>129.and.itype<140 - aircraftobst = (itype==131) .or. (itype>=133 .and. itype<=135) .or. (itype==130) !for currently known types - ix = 0 - if (aircraftobst .and. (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext)) then - ix = data(idx,i) - if (ix==0) then -! Inflate obs error for new tail number - if ( .not. aircraft_t_bc_ext ) & - data(ier,i) = 1.2_r_kind*data(ier,i) - else -! Bias for existing tail numbers - do j = 1, npredt - predcoef(j) = predt(j,ix) - end do - -! inflate obs error for any uninitialized tail number - if (all(predcoef==zero) .and. .not. aircraft_t_bc_ext) then - data(ier,i) = 1.2_r_kind*data(ier,i) - end if - -! define predictors - if (aircraft_t_bc) then - pof_idx = one - pred(1) = one - if (abs(data(ivvlc,i))>=50.0_r_kind) then - pred(2) = zero - pred(3) = zero - data(ier,i) = 1.2_r_kind*data(ier,i) - else - pred(2) = data(ivvlc,i) - pred(3) = data(ivvlc,i)*data(ivvlc,i) - end if - end if - if (aircraft_t_bc_pof) then -! data(ipof,i)==5 (ascending); 6 (descending); 3 (cruise level) - if (data(ipof,i) == 3.0_r_kind) then - pof_idx = one - pred(1) = one - pred(2) = zero - pred(3) = zero - else if (data(ipof,i) == 6.0_r_kind) then - pof_idx = one - pred(1) = zero - pred(2) = zero - pred(3) = one - else if (data(ipof,i) == 5.0_r_kind) then - pof_idx = one - pred(1) = zero - pred(2) = one - pred(3) = zero - else - pof_idx = zero - pred(1) = one - pred(2) = zero - pred(3) = zero - end if - end if - - if (aircraft_t_bc_ext) pred(1) = one - - do j = 1, npredt - predbias(j) = predcoef(j)*pred(j) - end do - end if - end if - -! Interpolate log(ps) & log(pres) at mid-layers to obs locations/times - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - - drpx=zero - if(sfctype .and. .not.twodvar_regional) then - drpx=abs(one-((one/exp(dpres-log(psges))))**rd_over_cp)*t0c - end if - -! Put obs pressure in correct units to get grid coord. number - call grdcrd1(dpres,prsltmp(1),nsig,-1) - -! Implementation of forward model ---------- - - if(sfctype.and.sfcmodel) then - tgges=data(iskint,i) - roges=data(isfcr,i) - - msges = 0 - if(itype == 180 .or. itype == 182 .or. itype == 183 .or. itype == 199) then !sea - msges=0 - elseif(itype == 181 .or. itype == 187 .or. itype == 188) then !land - msges=1 - endif - - call tintrp2a1(ges_tv,tvtmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - call tintrp2a1(ges_q,qtmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - call tintrp2a1(ges_u,utmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - call tintrp2a1(ges_v,vtmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - call tintrp2a1(geop_hgtl,hsges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - - psges2 = psges ! keep in cb - prsltmp2 = exp(prsltmp) ! convert from ln p to cb - call SFC_WTQ_FWD (psges2, tgges,& - prsltmp2(1), tvtmp(1), qtmp(1), utmp(1), vtmp(1), & - prsltmp2(2), tvtmp(2), qtmp(2), hsges(1), roges, msges, & - f10ges,u10ges,v10ges, t2ges, q2ges, regime, iqtflg) - tges = t2ges - - else - if(iqtflg)then -! Interpolate guess tv to observation location and time - call tintrp31(ges_tv,tges,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - - else -! Interpolate guess tsen to observation location and time - call tintrp31(ges_tsen,tges,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - end if - - if(i_use_2mt4b>0 .and. sfctype) then - - if(i_coastline==1 .or. i_coastline==3) then - -! Interpolate guess th 2m to observation location and time - call tintrp2a11_csln(ges_th2,tges2m,tges2m_water,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - tges2m=tges2m*(r10*psges/r1000)**rd_over_cp_mass ! convert to sensible T - tges2m_water=tges2m_water*(r10*psges/r1000)**rd_over_cp_mass ! convert to sensible T - if(iqtflg)then - call tintrp2a11_csln(ges_q2,qges2m,qges2m_water,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - tges2m=tges2m*(one+fv*qges2m) ! convert to virtual T - tges2m_water=tges2m_water*(one+fv*qges2m_water) ! convert to virtual T - endif - if( abs(tob-tges2m) > abs(tob-tges2m_water)) tges2m=tges2m_water - else -! Interpolate guess th 2m to observation location and time - call tintrp2a11(ges_th2,tges2m,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - tges2m=tges2m*(r10*psges/r1000)**rd_over_cp_mass ! convert to sensible T - if(iqtflg)then - call tintrp2a11(ges_q2,qges2m,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - tges2m=tges2m*(one+fv*qges2m) ! convert to virtual T - endif - - endif - endif - - endif - -! Get approximate k value of surface by using surface pressure - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp(1),nsig,-1) - -! Check to see if observations is above the top of the model (regional mode) - if(sfctype)then - if(abs(dpres)>four) drpx=1.0e10_r_kind - pres_diff=prest-r10*psges - if (twodvar_regional .and. abs(pres_diff)>=r1000) drpx=1.0e10_r_kind - end if - rlow=max(sfcchk-dpres,zero) -! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] - if(l_sfcobserror_ramp_t) then - ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind) - else - ramp=rlow - endif - - rhgh=max(zero,dpres-rsigp-r0_001) - - if(sfctype.and.sfcmodel) dpres = one ! place sfc T obs at the model sfc - - if(luse(i))then - awork(1) = awork(1) + one - if(rlow/=zero) awork(2) = awork(2) + one - if(rhgh/=zero) awork(3) = awork(3) + one - end if - - ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+r8*ramp) - -!JS MOVED THIS HERE -! Compute innovation - if(i_use_2mt4b>0 .and. sfctype) then - ddiff = tob-tges2m - else - ddiff = tob-tges - endif - -! Setup dynamic error specification for aircraft recon in hurricanes - - if ( itype == 136 ) then - ratio_errors=error/(1.15_r_kind*(abs(ddiff)+0.2_r_kind)+1.0e6_r_kind*rhgh+r8*ramp) - endif - - if ( itype == 137 ) then - ratio_errors=error/(abs(ddiff)+0.2_r_kind+1.0e6_r_kind*rhgh+r8*ramp) - endif - - error=one/error -! if (dpres > rsig) ratio_errors=zero - if (dpres > rsig )then - if( regional .and. prest > pt_ll )then - dpres=rsig - else - ratio_errors=zero - endif - endif - -!JS MOVED THIS UP A FEW LINES -! Compute innovation -! if(i_use_2mt4b>0 .and. sfctype) then -! ddiff = tob-tges2m -! else -! ddiff = tob-tges -! endif - -! Apply bias correction to innovation - if (aircraftobst .and. (aircraft_t_bc_pof .or. aircraft_t_bc .or. & - aircraft_t_bc_ext)) then - do j = 1, npredt - ddiff = ddiff - predbias(j) - end do - end if - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff = maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross error checks - - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - ratiosfc = ddiff/obserrlm - - ! modify gross check limit for quality mark=3 - if(data(iqc,i) == three ) then - qcgross=r0_7*cgross(ikx) - else - qcgross=cgross(ikx) - endif - - if (twodvar_regional) then - - ! Gross error relaxation for when buddycheck_t==.true. - if (buddycheck_t) then - if (buddyuse(i)==1) then - ! - Passed buddy check, relax gross qc - qcgross=three*qcgross - data(iuse,i)=data(iuse,i)+0.50_r_kind ! So we can identify obs with relaxed gross qc - ! in diag files (will show as an extra 0.50 appended) - else if (buddyuse(i)==0) then - ! - Buddy check did not run (too few buddies, rusage >= 100, outside twindow, etc.) - ! - In the case of an isolated ob in complex terrain, see about relaxing the the gross qc - if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) then - qcgross=three*qcgross ! Terrain aware modification - ! to gross error check - end if - else if (buddyuse(i)==-1) then - ! - Observation has failed the buddy check - reject. - ratio_errors = zero - end if - else if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) then - qcgross=three*qcgross ! Terrain aware modification - ! to gross error check - end if - endif - - if (sfctype .and. i_sfct_gross==1) then -! extend the threshold for surface T - if(i_use_2mt4b<=0) tges2m=tges - if ( tges2m-273.15_r_single < 5.0_r_single) then - if (ratiosfc > 1.4_r_single*qcgross & - .or. ratiosfc < -2.4_r_single*qcgross & - .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(4) = awork(4)+one - error = zero - ratio_errors = zero - else - ratio_errors = ratio_errors/sqrt(dup(i)) - end if - else - if (ratiosfc > qcgross .or. ratiosfc < -1.4_r_single*qcgross & - .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(4) = awork(4)+one - error = zero - ratio_errors = zero - else - ratio_errors = ratio_errors/sqrt(dup(i)) - end if - endif - else - if (ratio > qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(4) = awork(4)+one - error = zero - ratio_errors = zero - else - ratio_errors = ratio_errors/sqrt(dup(i)) - end if - endif - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_t_ob_type,ibin)%tail%muse(nobskeep) - -! Oberror Tuning and Perturb Obs - if(muse(i)) then - if(oberror_tune )then - if( jiter > jiterstart ) then - ddiff=ddiff+data(iptrb,i)/error/ratio_errors - endif - else if(perturb_obs )then - ddiff=ddiff+data(iptrb,i)/error/ratio_errors - endif - endif - -! Compute penalty terms - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if(njqc .and. var_jb>tiny_r_kind .and. var_jb < 10.0_r_kind .and. error >tiny_r_kind) then - if(exp_arg == zero) then - wgt=one - else - wgt=ddiff*error/sqrt(two*var_jb) - wgt=tanh(wgt)/wgt - endif - term=-two*var_jb*rat_err2*log(cosh((val)/sqrt(two*var_jb))) - rwgt = wgt/wgtlim - valqc = -two*term - else if (vqc .and. cvar_pg(ikx)> tiny_r_kind .and. error >tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_t=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_t*wnotgross) - term =log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term - else - term = exp_arg - wgt = one - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term - endif - -! Accumulate statistics for obs belonging to this task - if(muse(i))then - if(rwgt < one) awork(21) = awork(21)+one - jsig = dpres - jsig=max(1,min(jsig,nsig)) - awork(jsig+3*nsig+100)=awork(jsig+3*nsig+100)+valqc - awork(jsig+5*nsig+100)=awork(jsig+5*nsig+100)+one - awork(jsig+6*nsig+100)=awork(jsig+6*nsig+100)+val2*rat_err2 - end if - -! Loop over pressure level groupings and obs to accumulate statistics -! as a function of observation type. - ress = ddiff*scale - ressw2 = ress*ress - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - do k = 1,npres_print - if(prest >ptop(k) .and. prest <= pbot(k))then - bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count - bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ress ! (o-g) - bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty - - end if - end do - end if - -! Fill obs diagnostics structure - if(luse_obsdiag)then - obsdiags(i_t_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_t_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_t_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) -! if ( .not. last .and. muse(i)) then - if (muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(thead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - - allocate(my_head%pred(npredt)) - -! Set (i,j,k) indices of guess gridpoint that bound obs location - my_head%dlev= dpres - call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%jb = var_jb - my_head%use_sfc_model = sfctype.and.sfcmodel - if(my_head%use_sfc_model) then - call get_tlm_tsfc(my_head%tlm_tsfc(1), & - psges2,tgges,prsltmp2(1), & - tvtmp(1),qtmp(1),utmp(1),vtmp(1),hsges(1),roges,msges, & - regime,iqtflg) - else - my_head%tlm_tsfc = zero - endif - my_head%luse = luse(i) - my_head%tv_ob = iqtflg - - if (aircraft_t_bc_pof .or. aircraft_t_bc) then - effective=upd_pred_t*pof_idx - my_head%idx = data(idx,i) - do j=1,npredt - my_head%pred(j) = pred(j)*effective - end do - end if - - -! summation of observation number - if (luse(i) .and. aircraftobst .and. (aircraft_t_bc_pof .or. aircraft_t_bc) .and. ix/=0) then - do j=1,npredt - if (aircraft_t_bc_pof) then - poaf=data(ipof,i) - if (poaf==3.0_r_kind .or. poaf==5.0_r_kind .or. poaf==6.0_r_kind) then - if (j==1 .and. poaf == 3.0_r_kind) ostats_t(1,ix) = ostats_t(1,ix) + one_quad - if (j==2 .and. poaf == 5.0_r_kind) ostats_t(2,ix) = ostats_t(2,ix) + one_quad - if (j==3 .and. poaf == 6.0_r_kind) ostats_t(3,ix) = ostats_t(3,ix) + one_quad - rstats_t(j,ix)=rstats_t(j,ix)+my_head%pred(j) & - *my_head%pred(j)*(ratio_errors*error)**2*effective - end if - end if - - if (aircraft_t_bc) then - if (j==1) ostats_t(1,ix) = ostats_t(1,ix) + one_quad*effective - rstats_t(j,ix)=rstats_t(j,ix)+my_head%pred(j) & - *my_head%pred(j)*(ratio_errors*error)**2*effective - end if - - end do - end if - - if(oberror_tune) then - my_head%kx=ikx - my_head%tpertb=data(iptrb,i)/error/ratio_errors - if (njqc) then - ptablt=ptabl_t - else - ptablt=ptabl - endif - - if(prest > ptablt(2))then - my_head%k1=1 - else if( prest <= ptablt(33)) then - my_head%k1=33 - else - k_loop: do k=2,32 - if(prest > ptablt(k+1) .and. prest <= ptablt(k)) then - my_head%k1=k - exit k_loop - endif - enddo k_loop - endif - endif - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_t_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - - my_head => null() - endif - -! Save select output for diagnostic file - if (conv_diagsave .and. luse(i)) then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = prest ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = data(iqt,i) ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input=one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst - if (err_final>tiny_r_kind) errinv_final=one/err_final - -!rdiagbuf(13,ii) is the combination of var_jb and non-linear qc relative weight -! in the format of: var_jb*1.0e+6 + rwgt - rdiagbuf(13,ii) = var_jb*1.0e+6 + rwgt ! combination of var_jb and rwgt - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(itob,i) ! temperature observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = tob-tges ! obs-ges w/o bias correction (K) (future slot) - if (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext) then - rdiagbuf(20,ii) = data(ipof,i) ! data pof - rdiagbuf(21,ii) = data(ivvlc,i) ! data vertical velocity - do j=1,npredt - rdiagbuf(21+j,ii) = predbias(j) - end do - end if - idia=idia0 - if (lobsdiagsave) then - do jj=1,miter - idia=idia+1 - if (obsdiags(i_t_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(idia,ii) = one - else - rdiagbuf(idia,ii) = -one - endif - enddo - do jj=1,miter+1 - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_t_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_t_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_t_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(idia+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(idia+2,ii) = data(izz,i) ! model terrain at observation location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - - -!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!! - if( .not. last .and. l_pbl_pseudo_surfobst .and. & - ( itype==181 .or. itype==183 .or.itype==187 ) .and. & - muse(i) .and. dpres > -1.0_r_kind ) then - prestsfc=prest - diffsfc=ddiff - dthetav=ddiff*(r1000/prestsfc)**rd_over_cp_mass - - call tintrp2a11(pbl_height,thisPBL_height,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) -! - if (dthetav< -1.0_r_kind) then - call tune_pbl_height(mype,dlat,dlon,prestsfc,thisPBL_height,dthetav) - endif -! - ratio_PBL_height = (prest - thisPBL_height) * pblh_ration - if(ratio_PBL_height > zero) thisPBL_height = prest - ratio_PBL_height - prest = prest - pps_press_incr - DO while (prest > thisPBL_height) - ratio_PBL_height=1.0_r_kind-(prestsfc-prest)/(prestsfc-thisPBL_height) - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(thead(ibin),my_node) - my_node => null() - - allocate(my_head%pred(npredt)) - -!!! find tob (tint) - tob=data(itob,i) - -! Put obs pressure in correct units to get grid coord. number - dpres=log(prest/r10) - call grdcrd1(dpres,prsltmp(1),nsig,-1) - -!!! find tges (tgint) - if(iqtflg)then -! Interpolate guess tv to observation location and time - call tintrp31(ges_tv,tges,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - - else -! Interpolate guess tsen to observation location and time - call tintrp31(ges_tsen,tges,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - endif - -!!! Set (i,j,k) indices of guess gridpoint that bound obs location - my_head%dlev= dpres - call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) -!!! find ddiff - ddiff = diffsfc*(0.5_r_kind + 0.5_r_kind*ratio_PBL_height) - - error=one/data(ier2,i) - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%jb = var_jb - my_head%use_sfc_model = sfctype.and.sfcmodel - if(my_head%use_sfc_model) then - call get_tlm_tsfc(my_head%tlm_tsfc(1), & - psges2,tgges,prsltmp2(1), & - tvtmp(1),qtmp(1),utmp(1),vtmp(1),hsges(1),roges,msges, & - regime,iqtflg) - else - my_head%tlm_tsfc = zero - endif - my_head%luse = luse(i) - my_head%tv_ob = iqtflg - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_t_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,i,ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - -! Save select output for diagnostic file - if (conv_diagsave .and. luse(i)) then - iip=iip+1 - if(iip <= 3*nobs) then - rstation_id = data(id,i) - cdiagbufp(iip) = station_id ! station id - - rdiagbufp(1,iip) = ictype(ikx) ! observation type - rdiagbufp(2,iip) = icsubtype(ikx) ! observation subtype - - rdiagbufp(3,iip) = data(ilate,i) ! observation latitude (degrees) - rdiagbufp(4,iip) = data(ilone,i) ! observation longitude (degrees) - rdiagbufp(5,iip) = data(istnelv,i) ! station elevation (meters) - rdiagbufp(6,iip) = prest ! observation pressure (hPa) - rdiagbufp(7,iip) = data(iobshgt,i) ! observation height (meters) - rdiagbufp(8,iip) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbufp(9,iip) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbufp(10,iip) = data(iqt,i) ! setup qc or event mark - rdiagbufp(11,iip) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbufp(12,iip) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbufp(12,iip) = -one - endif - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input=one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst=one/err_adjst - if (err_final>tiny_r_kind) errinv_final=one/err_final - - !rdiagbuf(13,ii) is the combination of var_jb and non-linear qc relative weight - ! in the format of: var_jb*1.0e+6 + rwgt - rdiagbufp(13,iip) = var_jb*1.0e+6 + rwgt ! combination of var_jb and rwgt - rdiagbufp(14,iip) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbufp(15,iip) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbufp(16,iip) = errinv_final ! final inverse observation error (K**-1) - - rdiagbufp(17,iip) = data(itob,i) ! temperature observation (K) - rdiagbufp(18,iip) = ddiff ! obs-ges used in analysis (K) - rdiagbufp(19,iip) = ddiff ! tob-tges ! obs-ges w/o bias correction (K) (future slot) - else - iip=nobs - endif - end if - - prest = prest - pps_press_incr - - my_head => null() - - ENDDO - - endif ! 181,183,187 -!!!!!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!!!!!!!!! - -! End of loop over observations - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - write(7)' t',nchar,nreal,ii+iip,mype,idia0 - if(l_pbl_pseudo_surfobst .and. iip>0) then - write(7)cdiagbuf(1:ii),cdiagbufp(1:iip),rdiagbuf(:,1:ii),rdiagbufp(:,1:iip) - deallocate(cdiagbufp,rdiagbufp) - else - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - endif - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::u' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::v' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::tv', ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::q', ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get u ... - varname='u' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_u))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_u(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_u(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get v ... - varname='v' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_v))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_v(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_v(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get tv ... - varname='tv' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_tv))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_tv(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_tv(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get q ... - varname='q' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_q))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_q(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_q(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - if(i_use_2mt4b>0) then -! get th2m ... - varname='th2m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_th2(size(rank2,1),size(rank2,2),nfldsig)) - ges_th2(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_th2(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get q2m ... - varname='q2m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_q2(size(rank2,1),size(rank2,2),nfldsig)) - ges_q2(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_q2(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_q )) deallocate(ges_q ) - if(allocated(ges_tv)) deallocate(ges_tv) - if(allocated(ges_v )) deallocate(ges_v ) - if(allocated(ges_u )) deallocate(ges_u ) - if(allocated(ges_ps)) deallocate(ges_ps) - end subroutine final_vars_ - -end subroutine setupt - diff --git a/src/setuptcamt.f90 b/src/setuptcamt.f90 deleted file mode 100644 index 28fc23b41..000000000 --- a/src/setuptcamt.f90 +++ /dev/null @@ -1,577 +0,0 @@ -subroutine setuptcamt(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuptcamt compute rhs for total cloud amout -! prgmmr: derber org: np23 date: 2004-07-20 -! -! abstract: For sea surface temperature observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2012-01-29 zhu -! 2014-06-19 carley - update for metguess bundle, change tintrp2a to tintrp2a11 -! for debug compile on WCOSS, write sensitivity slot indicator -! (ioff) to header of diagfile, remove unused vars -! 2015-03-11 pondeca - Modify for possibility of not using obsdiag -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig - use m_obsdiags, only: tcamthead - use obsmod, only: rmiss_single,i_tcamt_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode , only: obsNode - use m_tcamtNode, only: tcamtNode - use m_obsLlist , only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig - use gridmod, only: get_ij - use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,& - two,cg_term,huge_single,r1000 - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local variables - real(r_kind), parameter:: miss_obs=10.e10_r_kind - - real(r_double) rstation_id - - real(r_kind) tcamtges,dlat,dlon,ddiff,dtime,error - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,rwgt - real(r_kind) cg_tcamt,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,izz,itcamt,id,itime,ikx,iqc - integer(i_kind) iuse,ilate,ilone,istnelv,iobshgt,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc,iskint,iff10,isfcr - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin, proceed - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode) ,pointer:: my_node - type(tcamtNode),pointer:: my_head - type(obs_diag ),pointer:: my_diag - character(len=*),parameter:: myname='setuptcamt' - - real(r_kind),allocatable,dimension(:,:,:) :: ges_tcamt - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - print *, 'Whoa! We have some missing metguess variables in setuptcamt.f90....returning to setuprhsall.f90 after advancing through input file' - read(lunin)data,luse,ioid - return ! not all vars available, simply return - end if - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - itcamt=4 ! index of tcamt observation - id=5 ! index of station id - itime=6 ! index of observation time in data array - ikxx=7 ! index of ob type - iqc=8 ! index of qulaity mark - iuse=9 ! index of use parameter - idomsfc=10 ! index of dominant surface type - iskint=11 ! index of surface skin temperature - iff10=12 ! index of 10 meter wind factor - isfcr=13 ! index of surface roughness - ilone=14 ! index of longitude (degrees) - ilate=15 ! index of latitude (degrees) - istnelv=16 ! index of station elevation (m) - iobshgt=17 ! index of observation height (m) - izz=18 ! index of model terrain height at ob location - iprvd=19 ! index of provider - isprvd=20 ! index of subprovider - - mm1=mype+1 - scale=one - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - -! Check for missing data - if (.not. oneobtest) then - do i=1,nobs - if (abs(data(itcamt,i)-miss_obs)<100.0_r_kind) then - muse(i)=.false. - data(itcamt,i)=rmiss_single ! for diag output - end if - end do - end if - -! Check for duplicate observations at same location - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - nreal=22 - ioff0=nreal - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - allocate(cprvstg(nobs),csprvstg(nobs)) - end if - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier,i) - isli=data(idomsfc,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_tcamt_ob_type,ibin)%head)) then - obsdiags(i_tcamt_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_tcamt_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuptcamt: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_tcamt_ob_type,ibin)%tail => obsdiags(i_tcamt_ob_type,ibin)%head - else - allocate(obsdiags(i_tcamt_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuptcamt: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_tcamt_ob_type,ibin)%tail => obsdiags(i_tcamt_ob_type,ibin)%tail%next - end if - obsdiags(i_tcamt_ob_type,ibin)%n_alloc = obsdiags(i_tcamt_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_tcamt_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_tcamt_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_tcamt_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_tcamt_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_tcamt_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_tcamt_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_tcamt_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_tcamt_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_tcamt_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_tcamt_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_tcamt_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_tcamt_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_tcamt_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_tcamt_ob_type,ibin)%tail)) then - obsdiags(i_tcamt_ob_type,ibin)%tail => obsdiags(i_tcamt_ob_type,ibin)%head - else - obsdiags(i_tcamt_ob_type,ibin)%tail => obsdiags(i_tcamt_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_tcamt_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_tcamt_ob_type,ibin)%tail)') - end if - if (obsdiags(i_tcamt_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuptcamt: index error' - call stop2(297) - end if - end if - end if - - if(.not.in_curbin) cycle - -! Interpolate to get tcamt at obs location/time - call tintrp2a11(ges_tcamt,tcamtges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - if(luse(i))then - awork(1) = awork(1) + one - end if - -! Adjust observation error - ratio_errors=error/(data(ier,i)*sqrt(dup(i))) - error=one/error - -! Compute innovations - ddiff=data(itcamt,i)-tcamtges - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross check using innovation normalized by error - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - end if - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_tcamt_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_tcamt=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_tcamt*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - end if - ress = ddiff*scale - ressw2 = ress*ress - val2 = val*val - rat_err2 = ratio_errors**2 - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - if (abs(data(itcamt,i)-rmiss_single) >=tiny_r_kind) then - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - end if - - endif - - if(luse_obsdiag)then - obsdiags(i_tcamt_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_tcamt_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_tcamt_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(tcamthead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_tcamt_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - end if - - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! model terrain at ob location - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(itcamt,i) ! tcamt observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(itcamt,i)-tcamtges! obs-ges w/o bias correction (K) (future slot) - - rdiagbuf(20,ii) = rmiss_single ! type of measurement - - rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(22,ii) = data(izz,i) ! model terrain at observation location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - - if (lobsdiagsave) then - ioff=ioff0 - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_tcamt_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_tcamt_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_tcamt_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_tcamt_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - - - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave)then - call dtime_show(myname,'diagsave:tcamt',i_tcamt_ob_type) - write(7)'tca',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::tcamt' , ivar, istatus ) - proceed=ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get tcamt ... - varname='tcamt' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_tcamt))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_tcamt(size(rank2,1),size(rank2,2),nfldsig)) - ges_tcamt(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_tcamt(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_tcamt)) deallocate(ges_tcamt) - end subroutine final_vars_ - -end subroutine setuptcamt - diff --git a/src/setuptcp.f90 b/src/setuptcp.f90 deleted file mode 100644 index 8f44e9d0d..000000000 --- a/src/setuptcp.f90 +++ /dev/null @@ -1,615 +0,0 @@ -subroutine setuptcp(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuptcp setup tcpel data -! prgmmr: kleist org: np20 date: 2009-02-02 -! -! abstract: Setup routine for TC MSLP data -! -! program history log: -! 2009-02-02 kleist -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2010-05-25 kleist - output tc_ps observations to conv diag file -! 2010-11-24 todling - add component to write obs sensitiviy to diag file -! 2013-01-26 parrish - change grdcrd to grdcrd1, intrp2a to intrp2a11, -! tintrp2a to tintrp2a1, tintrp2a11 (so debug compile works on WCOSS) -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (idia) to header of diagfile -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,i_kind,r_single,r_double - use m_obsdiags, only: tcphead - use obsmod, only: obsdiags,i_tcp_ob_type, & - nobskeep,lobsdiag_allocated,oberror_tune,perturb_obs, & - time_offset,rmiss_single,lobsdiagsave - use m_obsNode, only: obsNode - use m_tcpNode, only: tcpNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use qcmod, only: npres_print - use guess_grids, only: ges_lnprsl,nfldsig,hrdifsig, & - ntguessig - use gridmod, only: get_ij,nsig - use constants, only: zero,half,one,tiny_r_kind,two,cg_term, & - wgtlim,g_over_rd,huge_r_kind,pi,huge_single,tiny_single,r10 - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,& - icsubtype - use jfunc, only: jiter,last,jiterstart,miter - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - integer(i_kind) ,intent(in ) :: is ! ndat index - - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork ! obs-ges stats - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork ! data counts and gross checks - - logical ,intent(in) :: conv_diagsave - -! Declare external calls for code analysis - external:: intrp2a11,tintrp2a1,tintrp2a11 - external:: tintrp3 - external:: grdcrd1 - external:: stop2 - -! DECLARE LOCAL PARMS HERE - real(r_double) rstation_id - character(8) station_id - equivalence(rstation_id,station_id) - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - real(r_kind) err_input,err_adjst,err_final,errinv_input,errinv_adjst,errinv_final - real(r_kind) scale,ratio,obserror,obserrlm - real(r_kind) residual,ress,ressw2,val,val2 - real(r_kind) valqc,tges,tges2 - real(r_kind) wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2 - real(r_kind) rwgt,cg_ps,drbx - real(r_kind) error,dtime,dlon,dlat,r0_001,r2_5,r0_2,rsig - real(r_kind) ratio_errors,psges,zsges,rdp,drdp - real(r_kind) pob,pges,pgesorig,half_tlapse,ddiff,halfpi,r0_005,rdelz,psges2 - - real(r_kind),dimension(nele,nobs):: data - real(r_kind),dimension(nsig)::prsltmp - - integer(i_kind) i,jj - integer(i_kind) mm1,idia,idia0 - integer(i_kind) ikxx,nn,istat,iuse,ibin,iptrb,id - integer(i_kind) ier,ilon,ilat,ipres,itime,ikx,ilate,ilone - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(tcpNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - character(len=*),parameter:: myname='setuptcp' - - character(8),allocatable,dimension(:):: cdiagbuf - real(r_single),allocatable,dimension(:,:)::rdiagbuf - integer(i_kind) nchar,nreal,ii - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv - - n_alloc(:)=0 - m_alloc(:)=0 - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - -!****************************************************************************** -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - itime=5 ! index of time observation - ikxx=6 ! index of observation type in data array - ilone=7 ! index of longitude (degrees) - ilate=8 ! index of latitude (degrees) - iuse=9 ! index of usage parameter - id=10 ! index of storm name - - mm1=mype+1 - scale=one - rsig=nsig - halfpi = half*pi - r0_005 = 0.005_r_kind - r0_2=0.2_r_kind - r2_5=2.5_r_kind - half_tlapse=0.00325_r_kind ! half of 6.5K/1km - r0_001=0.001_r_kind - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - if(conv_diagsave)then - nchar=1 - idia0=19 - nreal=idia0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - ii=0 - end if - - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - pob=data(ipres,i) - - error=data(ier,i) - ikx=nint(data(ikxx,i)) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin -! Link obs to diagnostics structure - if ( luse_obsdiag ) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_tcp_ob_type,ibin)%head)) then - obsdiags(i_tcp_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_tcp_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuptcp: failure to allocate obsdiags',istat - call stop2(301) - end if - obsdiags(i_tcp_ob_type,ibin)%tail => obsdiags(i_tcp_ob_type,ibin)%head - else - allocate(obsdiags(i_tcp_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuptcp: failure to allocate obsdiags',istat - call stop2(302) - end if - obsdiags(i_tcp_ob_type,ibin)%tail => obsdiags(i_tcp_ob_type,ibin)%tail%next - end if - obsdiags(i_tcp_ob_type,ibin)%n_alloc = obsdiags(i_tcp_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_tcp_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_tcp_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_tcp_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_tcp_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_tcp_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_tcp_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_tcp_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_tcp_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_tcp_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_tcp_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_tcp_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_tcp_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_tcp_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_tcp_ob_type,ibin)%tail)) then - obsdiags(i_tcp_ob_type,ibin)%tail => obsdiags(i_tcp_ob_type,ibin)%head - else - obsdiags(i_tcp_ob_type,ibin)%tail => obsdiags(i_tcp_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_tcp_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_tcp_ob_type,ibin)%tail)') - end if - if (obsdiags(i_tcp_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuptcp: index error' - call stop2(303) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Get guess sfc hght at obs location - call intrp2a11(ges_z(1,1,ntguessig),zsges,dlat,dlon,mype) - -! Interpolate to get log(ps) and log(pres) at mid-layers -! at obs location/time - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - -! Convert pressure to grid coordinates - pgesorig = psges - -! Take log for vertical interpolation - psges = log(psges) - call grdcrd1(psges,prsltmp,nsig,-1) - -! Get guess temperature at observation location and surface - call tintrp31(ges_tv,tges,dlat,dlon,psges,dtime, & - hrdifsig,mype,nfldsig) - -! Adjust observation error and obs value due to differences in surface height - rdelz=-zsges - -! No observed temperature - psges2=data(ipres,i) - call grdcrd1(psges2,prsltmp,nsig,-1) - call tintrp31(ges_tv,tges2,dlat,dlon,psges2,dtime, & - hrdifsig,mype,nfldsig) - - drbx = half*abs(tges-tges2)+r2_5+r0_005*abs(rdelz) - tges = half*(tges+tges2) - -! Extrapolate surface temperature below ground at 6.5 k/km -! note only extrapolating .5dz, if no surface temp available. - if(rdelz < zero)then - tges=tges-half_tlapse*rdelz - drbx=drbx-half_tlapse*rdelz - end if - -! Adjust guess hydrostatically - rdp = g_over_rd*rdelz/tges - -! Subtract off dlnp correction, then convert to pressure (cb) - pges = exp(log(pgesorig) - rdp) - -! Compute innovations - ddiff=pob-pges ! in cb - -! Oberror Tuning and Perturb Obs - if(muse(i)) then - if(oberror_tune )then - if( jiter > jiterstart ) then - ddiff=ddiff+data(iptrb,i)/error/ratio_errors - endif - else if(perturb_obs )then - ddiff=ddiff+data(iptrb,i)/error/ratio_errors - endif - endif - -! observational error adjustment - drdp = pges*(g_over_rd*abs(rdelz)*drbx/(tges**2)) - -! find adjustment to observational error (in terms of ratio) - ratio_errors=error/(error+drdp) - error=one/error - -! Gross error checks - obserror = min(r10/max(ratio_errors*error,tiny_r_kind),huge_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(r10*ddiff) - ratio = residual/obserrlm - if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors = zero - else -! No duplicate check - end if - - if (ratio_errors*error <= tiny_r_kind) muse(i)=.false. - - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_tcp_ob_type,ibin)%tail%muse(nobskeep) - - val = error*ddiff - if(luse(i))then - -! Compute penalty terms (linear & nonlinear qc). - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error >tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_ps=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_ps*wnotgross) - term =log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - - - if (muse(i)) then -! Accumulate statistics for obs used belonging to this task - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - nn=1 - else - -! rejected obs - nn=2 -! monitored obs - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - - -! Accumulate statistics for each ob type - - ress = ddiff*r10 - ressw2 = ress*ress - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - - end if - - if (luse_obsdiag) then - obsdiags(i_tcp_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_tcp_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_tcp_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(tcphead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - if(oberror_tune) then - my_head%kx = ikx ! data type for oberror tuning - my_head%ppertb= data(iptrb,i)/error/ratio_errors ! obs perturbation - endif - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_tcp_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif - - my_head => null() - endif - -! Save obs and simulated surface pressure data for diagnostic output - - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = 0 ! station elevation (meters) - rdiagbuf(6,ii) = data(ipres,i)*r10 ! observation pressure (hPa) - rdiagbuf(7,ii) = 0 ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = 1 ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = 1 ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - pob = pob*r10 - pges = pges*r10 - pgesorig = pgesorig*r10 - err_input = data(ier,i)*r10 ! r10 converts cb to mb - err_adjst = data(ier,i)*r10 - if (ratio_errors*error/r10>tiny_r_kind) then - err_final = r10/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_single) errinv_input = one/err_input - if (err_adjst>tiny_single) errinv_adjst = one/err_adjst - if (err_final>tiny_single) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (hPa**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (hPa**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (hPa**-1) - - rdiagbuf(17,ii) = pob ! surface pressure observation (hPa) - rdiagbuf(18,ii) = pob-pges ! obs-ges used in analysis (coverted to hPa) - rdiagbuf(19,ii) = pob-pgesorig ! obs-ges w/o adjustment to guess surface pressure (hPa) - - idia=idia0 - if (lobsdiagsave) then - do jj=1,miter - idia=idia+1 - if (obsdiags(i_tcp_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(idia,ii) = one - else - rdiagbuf(idia,ii) = -one - endif - enddo - do jj=1,miter+1 - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_tcp_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_tcp_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - idia=idia+1 - rdiagbuf(idia,ii) = obsdiags(i_tcp_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if ! conv_diagsave .true. and luse .true. - -! End of loop over observations - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:tcp',i_tcp_ob_type) - write(7)'tcp',nchar,nreal,ii,mype,idia0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - end if - - -! End of routine - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::tv', ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get tv ... - varname='tv' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_tv))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_tv(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_tv(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_tv)) deallocate(ges_tv) - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps)) deallocate(ges_ps) - end subroutine final_vars_ - -end subroutine setuptcp diff --git a/src/setuptd2m.f90 b/src/setuptd2m.f90 deleted file mode 100644 index 80687a6f1..000000000 --- a/src/setuptd2m.f90 +++ /dev/null @@ -1,626 +0,0 @@ -subroutine setuptd2m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setuptd2m compute rhs of oi for conventional 2m dew point -! prgmmr: pondeca org: np23 date: 2014-04-10 -! -! abstract: For 2-m dew point observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2014-04-10 pondeca -! 2015-03-11 pondeca - Modify for possibility of not using obsdiag -! before retuning to setuprhsall.f90 -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! . removed (%dlat,%dlon) debris. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig - use m_obsdiags, only: td2mhead - use m_obsNode , only: obsNode - use m_td2mNode, only: td2mNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: rmiss_single,i_td2m_ob_type, & - obs_diag,obsdiags,lobsdiagsave,nobskeep,lobsdiag_allocated, & - time_offset,bmiss,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig,get_ij,twodvar_regional - use constants, only: zero,tiny_r_kind,one,half,one_tenth,r10,r1000,wgtlim, & - two,cg_term,huge_single,three - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_7=0.7_r_kind - - character(len=*),parameter:: myname='setuptd2m' - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) td2mges,dlat,dlon,ddiff,dtime,error - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,rwgt - real(r_kind) cg_td2m,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,ipres,itd2m,id,itime,ikx,imaxerr,iqc,iskint,iff10 - integer(i_kind) ier2,iuse,ilate,ilone,itemp,istnelv,isfcr,iobshgt,izz,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(td2mnode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,:) :: ges_ps !will probably need at some poin - real(r_kind),allocatable,dimension(:,:,:) :: ges_z !will probably need at some poin - real(r_kind),allocatable,dimension(:,:,:) :: ges_td2m - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - itd2m=5 ! index of td2m observation - id=6 ! index of station id - itime=7 ! index of observation time in data array - ikxx=8 ! index of ob type - imaxerr=9 ! index of max error - itemp=10 ! index of dry temperature - iqc=11 ! index of quality mark - ier2=12 ! index of original obs error - iuse=13 ! index of use parameter - idomsfc=14 ! index of dominant surface type - iskint=15 ! index of surface skin temperature - iff10=16 ! index of 10 meter wind factor - isfcr=17 ! index of surface roughness - ilone=18 ! index of longitude (degrees) - ilate=19 ! index of latitude (degrees) - istnelv=20 ! index of station elevation (m) - iobshgt=21 ! index of observation height (m) - izz=22 ! index of surface height - iprvd=23 ! index of observation provider - isprvd=24 ! index of observation subprovider - - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=19 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - - mm1=mype+1 - scale=one - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier2,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_td2m_ob_type,ibin)%head)) then - obsdiags(i_td2m_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_td2m_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setuptd2m: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_td2m_ob_type,ibin)%tail => obsdiags(i_td2m_ob_type,ibin)%head - else - allocate(obsdiags(i_td2m_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setuptd2m: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_td2m_ob_type,ibin)%tail => obsdiags(i_td2m_ob_type,ibin)%tail%next - end if - obsdiags(i_td2m_ob_type,ibin)%n_alloc = obsdiags(i_td2m_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_td2m_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_td2m_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_td2m_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_td2m_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_td2m_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_td2m_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_td2m_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_td2m_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_td2m_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_td2m_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_td2m_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_td2m_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_td2m_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_td2m_ob_type,ibin)%tail)) then - obsdiags(i_td2m_ob_type,ibin)%tail => obsdiags(i_td2m_ob_type,ibin)%head - else - obsdiags(i_td2m_ob_type,ibin)%tail => obsdiags(i_td2m_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_td2m_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_td2m_ob_type,ibin)%tail)') - end if - if (obsdiags(i_td2m_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setuptd2m: index error' - call stop2(297) - end if - end if - end if - - if(.not.in_curbin) cycle - -! Interpolate guess td2m to observation location and time - call tintrp2a11(ges_td2m,td2mges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - ddiff=data(itd2m,i)-td2mges - -! Adjust observation error - ratio_errors=error/data(ier,i) - error=one/error - -! Gross error checks - - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - -! modify gross check limit for quality mark=3 - if(data(iqc,i) == three ) then - qcgross=r0_7*cgross(ikx) - else - qcgross=cgross(ikx) - endif - - if (twodvar_regional) then - if ( (data(iuse,i)-real(int(data(iuse,i)),kind=r_kind)) == 0.25_r_kind) & - qcgross=three*cgross(ikx) - endif - - if(ratio > qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else - ratio_errors=ratio_errors/sqrt(dup(i)) - end if - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - muse(i) = .true. - endif - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_td2m_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_td2m=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_td2m*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - nn=1 - else - nn=2 !rejected obs - if(ratio_errors*error >=tiny_r_kind)nn=3 !monitored obs - end if - - ress = ddiff*scale - ressw2 = ress*ress - - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - endif - -! Fill obs diagnostics structure - if(luse_obsdiag)then - obsdiags(i_td2m_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_td2m_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_td2m_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(td2mhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if(luse_obsdiag)then - my_head%diags => obsdiags(i_td2m_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - end if - - my_head => null() - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = r10*exp(data(ipres,i)) ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(itd2m,i) ! TD2M observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(itd2m,i)-td2mges! obs-ges w/o bias correction (K) (future slot) - - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_td2m_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_td2m_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_td2m_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_td2m_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at observation location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:td2m',i_td2m_ob_type) - write(7)'td2',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::td2m' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get td2m ... - varname='td2m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_td2m))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_td2m(size(rank2,1),size(rank2,2),nfldsig)) - ges_td2m(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_td2m(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps )) deallocate(ges_ps ) - if(allocated(ges_td2m)) deallocate(ges_td2m) - end subroutine final_vars_ - -end subroutine setuptd2m diff --git a/src/setupuwnd10m.f90 b/src/setupuwnd10m.f90 deleted file mode 100644 index 6e2808ce5..000000000 --- a/src/setupuwnd10m.f90 +++ /dev/null @@ -1,944 +0,0 @@ -subroutine setupuwnd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupuwnd10m compute rhs for conventional 10 m u component -! prgmmr: pondeca org: np23 date: 2016-03-07 -! -! abstract: For 10-m uwind observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2016-03-07 pondeca -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! before retuning to setuprhsall.f90 -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2017-03-15 Yang - modify code to use polymorphic code. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig,ges_lnprsl, & - sfcmod_gfs,sfcmod_mm5,comp_fact10,pt_ll - use m_obsdiags, only: uwnd10mhead - use obsmod, only: rmiss_single,i_uwnd10m_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,bmiss - use m_obsNode , only: obsNode - use m_uwnd10mNode, only: uwnd10mNode - use m_obsLList , only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - - use gridmod, only: nsig - use gridmod, only: get_ij,twodvar_regional,regional,rotate_wind_xy2ll - use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,rd,grav,& - two,cg_term,three,four,five,ten,huge_single,r1000,r3600,& - grav_ratio,flattening,grav,deg2rad,grav_equator,somigliana, & - semi_major_axis - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print,qc_satwnds - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a1,tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_7=0.7_r_kind - real(r_kind),parameter:: r6=6.0_r_kind - real(r_kind),parameter:: r20=20.0_r_kind - real(r_kind),parameter:: r360=360.0_r_kind - real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss - character(len=*),parameter:: myname='setupuwnd10m' - -! Declare local variables - - integer(i_kind) num_bad_ikx - - real(r_double) rstation_id - - real(r_kind) spdges,dlat,dlon,ddiff,dtime,error,prsln2,r0_001,thirty - real(r_kind) scale,val2,rsig,rsigp,ratio,ressw2,ress,residual,dudiff,dvdiff - real(r_kind) obserrlm,obserror,val,valqc,dx10,rlow,rhgh,drpx,prsfc - real(r_kind) term,rwgt - real(r_kind) cg_uwnd10m,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross - real(r_kind) presw,factw,dpres,sfcchk,ugesin,vgesin,dpressave - real(r_kind) qcu,qcv - real(r_kind) ratio_errors,tfact,wflate,psges,goverrd,spdob - real(r_kind) uob,vob - real(r_kind) spdb - real(r_kind) dudiff_opp, dvdiff_opp, vecdiff, vecdiff_opp - real(r_kind) ascat_vec - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final,skint,sfcr - real(r_kind) uob_reg,vob_reg,uob_e,vob_e,dlon_e,uges_e,vges_e,dudiff_e,dvdiff_e - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nsig)::prsltmp,tges - real(r_kind) wdirob,wdirgesin,wdirdiffmax - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ier2,ilon,ilat,ihgt,iuob,ivob,ipres,id,itime,ikx,iqc - integer(i_kind) iuse,ilate,ilone,ielev,izz,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj,itype - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc,iskint,iff10,isfcr - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical lowlevelsat - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode ), pointer:: my_node - type(uwnd10mNode), pointer:: my_head - type(obs_diag ), pointer:: my_diag - - - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z !will probably need at some point - real(r_kind),allocatable,dimension(:,:,: ) :: ges_uwnd10m - real(r_kind),allocatable,dimension(:,:,: ) :: ges_vwnd10m - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv - real(r_kind),allocatable,dimension(:,:,: ) :: ges_wspd10m - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - spdb=zero - - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - ihgt=5 ! index of observation elevation - iuob=6 ! index of u observation - ivob=7 ! index of v observation - id=8 ! index of station id - itime=9 ! index of observation time in data array - ikxx=10 ! index of ob type - ielev=11 ! index of station elevation (m) - iqc=12 ! index of quality mark - ier2=13 ! index of original-original obs error ratio - iuse=14 ! index of use parameter - idomsfc=15 ! index of dominant surface type - iskint=16 ! index of surface skin temperature - iff10=17 ! index of 10 meter wind factor - isfcr=18 ! index of surface roughness - ilone=19 ! index of longitude (degrees) - ilate=20 ! index of latitude (degrees) - izz=21 ! index of surface height - iprvd=22 ! index of provider - isprvd=23 ! index of subprovider - - mm1=mype+1 - scale=one - rsig=nsig - thirty = 30.0_r_kind - r0_001=0.001_r_kind - rsigp=rsig+one - goverrd=grav/rd - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - -! Check for missing data - if (.not. oneobtest) then - do i=1,nobs - if (data(iuob,i) > r0_1_bmiss .or. data(ivob,i) > r0_1_bmiss) then - muse(i)=.false. - data(iuob,i)=rmiss_single ! for diag output - data(ivob,i)=rmiss_single ! for diag output - end if - end do - end if - -! Check for duplicate observations at same location - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ipres,k) == data(ipres,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=23 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - if(ikx < 1 .or. ikx > nconvtype) then - num_bad_ikx=num_bad_ikx+1 - if(num_bad_ikx<=10) write(6,*)' in setupuwnd10m, bad ikx, ikx,i,nconvtype=',ikx,i,nconvtype - cycle - end if - - error=data(ier2,i) - isli=data(idomsfc,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_uwnd10m_ob_type,ibin)%head)) then - obsdiags(i_uwnd10m_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_uwnd10m_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupuwnd10m: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_uwnd10m_ob_type,ibin)%tail => obsdiags(i_uwnd10m_ob_type,ibin)%head - else - allocate(obsdiags(i_uwnd10m_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupuwnd10m: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_uwnd10m_ob_type,ibin)%tail => obsdiags(i_uwnd10m_ob_type,ibin)%tail%next - end if - obsdiags(i_uwnd10m_ob_type,ibin)%n_alloc = obsdiags(i_uwnd10m_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_uwnd10m_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_uwnd10m_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_uwnd10m_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_uwnd10m_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_uwnd10m_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_uwnd10m_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_uwnd10m_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_uwnd10m_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_uwnd10m_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_uwnd10m_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_uwnd10m_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_uwnd10m_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_uwnd10m_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - else - if (.not.associated(obsdiags(i_uwnd10m_ob_type,ibin)%tail)) then - obsdiags(i_uwnd10m_ob_type,ibin)%tail => obsdiags(i_uwnd10m_ob_type,ibin)%head - else - obsdiags(i_uwnd10m_ob_type,ibin)%tail => obsdiags(i_uwnd10m_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_uwnd10m_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_uwnd10m_ob_type,ibin)%tail)') - end if - if (obsdiags(i_uwnd10m_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupuwnd10m: index error' - call stop2(297) - end if - end if - end if - - if(.not.in_curbin) cycle - -! Load observation error and values into local variables - uob = data(iuob,i) - vob = data(ivob,i) - spdob=sqrt(uob*uob+vob*vob) - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - -! Interpolate to get wspd10m at obs location/time - call tintrp2a11(ges_wspd10m,spdges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - itype=ictype(ikx) - -! Process observations with reported pressure - dpres = data(ipres,i) - presw = ten*exp(dpres) - dpres = dpres-log(psges) - drpx=zero - - prsfc=psges - prsln2=log(exp(prsltmp(1))/prsfc) - dpressave=dpres - -! Put obs pressure in correct units to get grid coord. number - dpres=log(exp(dpres)*prsfc) - call grdcrd1(dpres,prsltmp(1),nsig,-1) - -! Interpolate guess u and v to observation location and time. - - call tintrp2a11(ges_uwnd10m,ugesin,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a11(ges_vwnd10m,vgesin,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - if(dpressave <= prsln2)then - factw=one - else - factw = data(iff10,i) - if(sfcmod_gfs .or. sfcmod_mm5) then - sfcr = data(isfcr,i) - skint = data(iskint,i) - call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) - end if - - call tintrp2a1(ges_tv,tges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) -! Apply 10-meter wind reduction factor to guess winds - dx10=-goverrd*ten/tges(1) - if (dpressave < dx10)then - term=(prsln2-dpressave)/(prsln2-dx10) - factw=one-term+factw*term - end if - ugesin=factw*ugesin - vgesin=factw*vgesin - - end if - -! Get approx k value of sfc by using surface pressure - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp(1),nsig,-1) - -! Checks based on observation location relative to model surface and top - rlow=max(sfcchk-dpres,zero) - rhgh=max(dpres-r0_001-rsigp,zero) - if(luse(i))then - awork(1) = awork(1) + one - if(rlow/=zero) awork(2) = awork(2) + one - if(rhgh/=zero) awork(3) = awork(3) + one - end if - -! Adjust observation error - wflate=zero - if (ictype(ikx)==288 .or. ictype(ikx)==295) then - if (spdob=ten ) wflate=four*data(ier,i) ! Tyndall/Horel type QC - endif - - ratio_errors=error/(data(ier,i)+drpx+wflate+1.0e6_r_kind*rhgh+four*rlow) - -! Invert observation error - error=one/error - -! Check to see if observation below model surface or above model top. -! If so, don't use observation - if (dpres > rsig )then - if( regional .and. presw > pt_ll )then - dpres=rsig - else - ratio_errors=zero - endif - endif - -! Compute innovations - lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & - itype==247.or.itype==250.or.itype==251.or.itype==252.or. & - itype==253.or.itype==254.or.itype==257.or.itype==258.or. & - itype==259 - if (lowlevelsat .and. twodvar_regional) then - call windfactor(presw,factw) - data(iuob,i)=factw*data(iuob,i) - data(ivob,i)=factw*data(ivob,i) - uob = data(iuob,i) - vob = data(ivob,i) - endif - dudiff=uob-ugesin - dvdiff=vob-vgesin - spdb=sqrt(uob**2+vob**2)-sqrt(ugesin**2+vgesin**2) - - ddiff=dudiff - - if ( qc_satwnds ) then - if(itype >=240 .and. itype <=260) then - if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb - endif - if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top - if(presw >399.0_r_kind) error=zero - endif - if(itype ==258 .and. presw >600.0_r_kind) error=zero - if(itype ==259 .and. presw >600.0_r_kind) error=zero - endif ! qc_satwnds - -! QC WindSAT winds - if (itype==289) then - qcu = r6 - qcv = r6 - if ( spdob > r20 .or. & ! high wind speed check - abs(dudiff) > qcu .or. & ! u component check - abs(dvdiff) > qcv ) then ! v component check - error = zero - endif - endif - -! QC ASCAT winds - if (itype==290) then - qcu = five - qcv = five -! Compute innovations for opposite vectors - dudiff_opp = -uob - ugesin - dvdiff_opp = -vob - vgesin - vecdiff = sqrt(dudiff**2 + dvdiff**2) - vecdiff_opp = sqrt(dudiff_opp**2 + dvdiff_opp**2) - ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) - - if ( abs(dudiff) > qcu .or. & ! u component check - abs(dvdiff) > qcv .or. & ! v component check - vecdiff > vecdiff_opp ) then ! ambiguity check - - error = zero - endif - endif - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross check using innovation normalized by error - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - -! it's probably more robust to evalute gross-error in -! terms of magnitude of full-vector difference - -!! if ( abs(ugesin)>zero .or. abs(vgesin)>zero ) then -!! ugesin_scaled=(ugesin/sqrt(ugesin**2+vgesin**2))*spdges -!! vgesin_scaled=(vgesin/sqrt(ugesin**2+vgesin**2))*spdges -!! residual = sqrt((uob-ugesin_scaled)**2+(vob-vgesin_scaled)**2) -!! else -!! residual = sqrt(dudiff**2+dvdiff**2) -!! endif - -!! residual = sqrt(dudiff**2+dvdiff**2) - ratio = residual/obserrlm - -!! modify cgross depending on the quality mark, qcmark=3, cgross=0.7*cgross -!! apply asymetric gross check for satellite winds - qcgross=cgross(ikx) - if(data(iqc,i) == three) qcgross=r0_7*cgross(ikx) - - if(spdb <0 )then - if(itype ==244) then ! AVHRR, use same as MODIS - qcgross=r0_7*cgross(ikx) - endif - if(itype >=257 .and. itype <=259 ) then - qcgross=r0_7*cgross(ikx) - endif - endif - - if (ratio> qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else - ratio_errors =ratio_errors/sqrt(dup(i)) - end if - - if (lowlevelsat .and. twodvar_regional) then - if (data(idomsfc,i) /= 0 .and. data(idomsfc,i) /= 3 ) then - error = zero - ratio_errors = zero - endif - endif - - if (twodvar_regional) then - if (lowlevelsat .or. itype==289 .or. itype==290) then - wdirdiffmax=45._r_kind - else - wdirdiffmax=100000._r_kind - endif - if (spdob > zero .and. (spdob-spdb) > zero) then - call getwdir(uob,vob,wdirob) - call getwdir(ugesin,vgesin,wdirgesin) - if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & - abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then - error = zero - ratio_errors = zero - endif - endif - endif - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_uwnd10m_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_uwnd10m=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_uwnd10m*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - end if - ress = ddiff*scale - ressw2 = ress*ress - val2 = val*val - rat_err2 = ratio_errors**2 - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - if (abs(data(iuob,i)-rmiss_single) >=tiny_r_kind) then - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - end if - - endif - - if(luse_obsdiag)then - obsdiags(i_uwnd10m_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_uwnd10m_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_uwnd10m_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(uwnd10mhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - if(luse_obsdiag)then - my_head%diags => obsdiags(i_uwnd10m_ob_type,ibin)%tail - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - end if - my_head => null () - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) - rdiagbuf(6,ii) = presw ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (ms**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (ms**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (ms**-1) - - rdiagbuf(17,ii) = data(iuob,i) ! 10m uwind observation (ms**-1) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (ms**-1) - rdiagbuf(19,ii) = data(iuob,i)-ugesin! obs-ges w/o bias correction (ms**-1) (future slot) - - rdiagbuf(20,ii) = data(ivob,i) ! 10m vwind observation (ms**-1) - rdiagbuf(21,ii) = dvdiff ! vob-ges (ms**-1) - rdiagbuf(22,ii) = data(ivob,i)-vgesin! vob-ges w/o bias correction (ms**-1) (future slot) - - if(regional) then - -! replace positions 17-22 with earth relative wind component information - - uob_reg=data(iuob,i) - vob_reg=data(ivob,i) - dlon_e=data(ilone,i)*deg2rad - call rotate_wind_xy2ll(uob_reg,vob_reg,uob_e,vob_e,dlon_e,dlon,dlat) - call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) - call rotate_wind_xy2ll(ddiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) - rdiagbuf(17,ii) = uob_e ! earth relative u wind component observation (m/s) - rdiagbuf(18,ii) = dudiff_e ! earth relative u obs-ges used in analysis (m/s) - rdiagbuf(19,ii) = uob_e-uges_e ! earth relative u obs-ges w/o bias correction (m/s) (future slot) - - rdiagbuf(20,ii) = vob_e ! earth relative v wind component observation (m/s) - rdiagbuf(21,ii) = dvdiff_e ! earth relative v obs-ges used in analysis (m/s) - rdiagbuf(22,ii) = vob_e-vges_e ! earth relative v obs-ges w/o bias correction (m/s) (future slot) - end if - - rdiagbuf(23,ii) = factw ! 10m wind reduction factor - - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_uwnd10m_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_uwnd10m_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_uwnd10m_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_uwnd10m_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominant surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - - - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:uwnd10m',i_uwnd10m_ob_type) - write(7)'uwn',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::uwnd10m', ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::vwnd10m', ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::wspd10m', ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::tv', ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=10) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get uwnd10m ... - varname='uwnd10m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_uwnd10m))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_uwnd10m(size(rank2,1),size(rank2,2),nfldsig)) - ges_uwnd10m(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_uwnd10m(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get vwnd10m ... - varname='vwnd10m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_vwnd10m))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_vwnd10m(size(rank2,1),size(rank2,2),nfldsig)) - ges_vwnd10m(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_vwnd10m(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get wspd10m ... - varname='wspd10m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_wspd10m))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_wspd10m(size(rank2,1),size(rank2,2),nfldsig)) - ges_wspd10m(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_wspd10m(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get tv ... - varname='tv' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_tv))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_tv(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_tv(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps )) deallocate(ges_ps ) - if(allocated(ges_tv )) deallocate(ges_tv ) - if(allocated(ges_uwnd10m)) deallocate(ges_uwnd10m) - if(allocated(ges_vwnd10m)) deallocate(ges_vwnd10m) - if(allocated(ges_wspd10m)) deallocate(ges_wspd10m) - end subroutine final_vars_ - -end subroutine setupuwnd10m - diff --git a/src/setupvis.f90 b/src/setupvis.f90 deleted file mode 100644 index d1c4d0c8b..000000000 --- a/src/setupvis.f90 +++ /dev/null @@ -1,667 +0,0 @@ -subroutine setupvis(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupvis compute rhs for conventional surface vis -! prgmmr: derber org: np23 date: 2004-07-20 -! -! abstract: For sea surface temperature observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2009-10-21 zhu -! 2011-02-19 zhu - update -! 2013-01-26 parrish - change tintrp2a to tintrp2a11 (so debug compile works on WCOSS) -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2016-05-06 yang - add closest_obs to select only one obs. among the multi-reports. -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! before retuning to setuprhsall.f90 -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig - use m_obsdiags, only: vishead - use obsmod, only: rmiss_single,i_vis_ob_type,obsdiags,& - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,bmiss - use m_obsNode, only: obsNode - use m_visNode, only: visNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - use gridmod, only: nsig - use gridmod, only: get_ij - use constants, only: zero,tiny_r_kind,one,half,one_tenth,wgtlim, & - two,cg_term,pi,huge_single - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print,closest_obs - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss - character(len=*),parameter:: myname='setupvis' - -! Declare local variables - - real(r_double) rstation_id - - real(r_kind) visges,dlat,dlon,ddiff,dtime,error - real(r_kind) vis_errmax,offtime_k,offtime_l - real(r_kind) scale,val2,ratio,ressw2,ress,residual - real(r_kind) obserrlm,obserror,val,valqc - real(r_kind) term,halfpi,rwgt - real(r_kind) cg_vis,wgross,wnotgross,wgt,arg,exp_arg,rat_err2 - real(r_kind) ratio_errors,tfact - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ilon,ilat,ivis,id,itime,ikx,imaxerr,iqc - integer(i_kind) iuse,ilate,ilone,istnelv,iobshgt,izz,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,ibin,ioff,ioff0,jj - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(visNode),pointer:: my_head - type(obs_diag),pointer:: my_diag - - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,:) :: ges_ps - real(r_kind),allocatable,dimension(:,:,:) :: ges_vis - real(r_kind),allocatable,dimension(:,:,:) :: ges_z - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 - vis_errmax=5000.0_r_kind -!********************************************************************************* -! Read and reformat observations in work arrays. - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ivis=4 ! index of vis observation - background - id=5 ! index of station id - itime=6 ! index of observation time in data array - ikxx=7 ! index of ob type - imaxerr=8 ! index of vis max error - iqc=9 ! index of quality mark - iuse=10 ! index of use parameter - idomsfc=11 ! index of dominant surface type - ilone=12 ! index of longitude (degrees) - ilate=13 ! index of latitude (degrees) - istnelv=14 ! index of station elevation (m) - iobshgt=15 ! index of observation height (m) - izz=16 ! index of surface height - iprvd=17 ! index of provider - isprvd=18 ! index of subprovider - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - -! Check for missing data !need obs value and error - do i=1,nobs - if (data(ivis,i) > r0_1_bmiss) then - muse(i)=.false. - data(ivis,i)=rmiss_single ! for diag output - data(iobshgt,i)=rmiss_single! for diag output - end if - -! set any observations larger than 20000.0 to be 20000.0 - if (data(ivis,i) > 20000.0_r_kind) data(ivis,i)=20000.0_r_kind - end do - offtime_k=0.0_r_kind - offtime_l=0.0_r_kind - -! if closest_obs=.true., choose the timely closest obs. among the multi-reports -! at a station. - if (closest_obs) then - dup=one - do k=1,nobs - if( dup(k) < tiny_r_kind .or. .not. muse(k) ) then - dup(k)=-99.0_r_kind - else - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < vis_errmax .and. data(ier,l) abs(offtime_l)) then - dup(k)=-99.0_r_kind - endif - if(abs(offtime_k)==abs(offtime_l)) then - if (offtime_k >= 0.0_r_kind) dup(l)=-99.0_r_kind - if (offtime_l >= 0.0_r_kind) dup(k)=-99.0_r_kind - endif - endif - enddo - endif - enddo - else - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < vis_errmax .and. data(ier,l) < vis_errmax .and. & - muse(k) .and. muse(l))then - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - endif - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=22 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - allocate(cprvstg(nobs),csprvstg(nobs)) - end if - - halfpi = half*pi - mm1=mype+1 - scale=one - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - error=data(ier,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_vis_ob_type,ibin)%head)) then - obsdiags(i_vis_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_vis_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupvis: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_vis_ob_type,ibin)%tail => obsdiags(i_vis_ob_type,ibin)%head - else - allocate(obsdiags(i_vis_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupvis: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_vis_ob_type,ibin)%tail => obsdiags(i_vis_ob_type,ibin)%tail%next - end if - obsdiags(i_vis_ob_type,ibin)%n_alloc = obsdiags(i_vis_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_vis_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_vis_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_vis_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_vis_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_vis_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_vis_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_vis_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_vis_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_vis_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_vis_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_vis_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_vis_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_vis_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - else - if (.not.associated(obsdiags(i_vis_ob_type,ibin)%tail)) then - obsdiags(i_vis_ob_type,ibin)%tail => obsdiags(i_vis_ob_type,ibin)%head - else - obsdiags(i_vis_ob_type,ibin)%tail => obsdiags(i_vis_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_vis_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_vis_ob_type,ibin)%tail)') - end if - if (obsdiags(i_vis_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupvis: index error' - call stop2(297) - end if - endif - endif - - if(.not.in_curbin) cycle - -! Interpolate to get vis at obs location/time - call tintrp2a11(ges_vis,visges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - -! Adjust observation error - ratio_errors=error/data(ier,i) - error=one/error - - ddiff=data(ivis,i)-visges - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross check using innovation normalized by error - if (abs(data(ivis,i)-rmiss_single) >= tiny_r_kind ) then - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - ratio = residual/obserrlm - if (ratio> cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else -! dup(i) < 0 means closest_obs =.true. - if(dup(i)> tiny_r_kind) then - ratio_errors=ratio_errors/sqrt(dup(i)) - else - ratio_errors=zero - endif - endif - else ! missing data - error = zero - ratio_errors=zero - end if - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - if (nobskeep>0.and.luse_obsdiag) muse(i)=obsdiags(i_vis_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_vis=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_vis*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - end if - ress = ddiff*scale - ressw2 = ress*ress - val2 = val*val - rat_err2 = ratio_errors**2 - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - if (abs(data(ivis,i)-rmiss_single) >=tiny_r_kind) then - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - end if - - endif - - if (luse_obsdiag) then - obsdiags(i_vis_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_vis_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_vis_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(vishead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - - if (luse_obsdiag) then - my_head%diags => obsdiags(i_vis_ob_type,ibin)%tail - - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - endif ! (luse_obsdiag) - - my_head => null() - endif ! (.not. last .and. muse(i)) - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) - rdiagbuf(6,ii) = rmiss_single ! observation pressure (hPa) - rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (K**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (K**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (K**-1) - - rdiagbuf(17,ii) = data(ivis,i) ! VIS observation (K) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (K) - rdiagbuf(19,ii) = data(ivis,i)-visges! obs-ges w/o bias correction (K) (future slot) - - rdiagbuf(20,ii) = rmiss_single ! type of measurement - - rdiagbuf(21,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(22,ii) = data(izz,i) ! model terrain at observation location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_vis_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_vis_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_vis_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_vis_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - end if - - - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:vis',i_vis_ob_type) - write(7)'vis',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::vis' , ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get vis ... - varname='vis' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_vis))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_vis(size(rank2,1),size(rank2,2),nfldsig)) - ges_vis(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_vis(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_vis)) deallocate(ges_vis) - if(allocated(ges_ps )) deallocate(ges_ps ) - end subroutine final_vars_ - -end subroutine setupvis - diff --git a/src/setupvwnd10m.f90 b/src/setupvwnd10m.f90 deleted file mode 100644 index 3ced1a391..000000000 --- a/src/setupvwnd10m.f90 +++ /dev/null @@ -1,944 +0,0 @@ -subroutine setupvwnd10m(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) -!$$$ subprogram documentation block -! . . . . -! subprogram: setupvwnd10m compute rhs for conventional 10 m vwind -! prgmmr: pondeca org: np23 date: 2016-03-07 -! -! abstract: For 10-m uwind observations -! a) reads obs assigned to given mpi task (geographic region), -! b) simulates obs from guess, -! c) apply some quality control to obs, -! d) load weight and innovation arrays used in minimization -! e) collects statistics for runtime diagnostic output -! f) writes additional diagnostic information to output file -! -! program history log: -! 2016-03-07 pondeca -! 2016-10-07 pondeca - if(.not.proceed) advance through input file first -! before retuning to setuprhsall.f90 -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2017-03-15 Yang - modify code to use polymorphic code. -! -! input argument list: -! lunin - unit from which to read observations -! mype - mpi task id -! nele - number of data elements per observation -! nobs - number of observations -! -! output argument list: -! bwork - array containing information about obs-ges statistics -! awork - array containing information for data counts and gross checks -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - - use guess_grids, only: hrdifsig,nfldsig,ges_lnprsl, & - sfcmod_gfs,sfcmod_mm5,comp_fact10,pt_ll - use m_obsdiags, only: vwnd10mhead - use obsmod, only: rmiss_single,i_vwnd10m_ob_type,obsdiags, bmiss, & - lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset - use m_obsNode , only: obsNode - use m_vwnd10mNode, only: vwnd10mNode - use m_obsLList , only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin - use oneobmod, only: magoberr,maginnov,oneobtest - - use gridmod, only: nsig - use gridmod, only: get_ij,twodvar_regional,regional,rotate_wind_xy2ll - use constants, only: zero,tiny_r_kind,one,one_tenth,half,wgtlim,rd,grav,& - two,cg_term,three,four,five,ten,huge_single,r1000,r3600,& - grav_ratio,flattening,grav,deg2rad,grav_equator,somigliana, & - semi_major_axis - use jfunc, only: jiter,last,miter - use qcmod, only: dfact,dfact1,npres_print,qc_satwnds - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - implicit none - -! Declare passed variables - logical ,intent(in ) :: conv_diagsave - integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index - -! Declare external calls for code analysis - external:: tintrp2a1,tintrp2a11 - external:: stop2 - -! Declare local parameters - real(r_kind),parameter:: r0_7=0.7_r_kind - real(r_kind),parameter:: r6=6.0_r_kind - real(r_kind),parameter:: r20=20.0_r_kind - real(r_kind),parameter:: r360=360.0_r_kind - real(r_kind),parameter:: r0_1_bmiss=one_tenth*bmiss - character(len=*),parameter:: myname='setupvwnd10m' - -! Declare local variables - - integer(i_kind) num_bad_ikx - - real(r_double) rstation_id - - real(r_kind) spdges,dlat,dlon,ddiff,dtime,error,prsln2,r0_001,thirty - real(r_kind) scale,val2,rsig,rsigp,ratio,ressw2,ress,residual,dudiff,dvdiff - real(r_kind) obserrlm,obserror,val,valqc,dx10,rlow,rhgh,drpx,prsfc - real(r_kind) term,rwgt - real(r_kind) cg_vwnd10m,wgross,wnotgross,wgt,arg,exp_arg,rat_err2,qcgross - real(r_kind) presw,factw,dpres,sfcchk,ugesin,vgesin,dpressave - real(r_kind) qcu,qcv - real(r_kind) ratio_errors,tfact,wflate,psges,goverrd,spdob - real(r_kind) uob,vob,spdb - real(r_kind) dudiff_opp, dvdiff_opp, vecdiff, vecdiff_opp - real(r_kind) ascat_vec - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final,skint,sfcr - real(r_kind) uob_reg,vob_reg,uob_e,vob_e,dlon_e,uges_e,vges_e,dudiff_e,dvdiff_e - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nsig)::prsltmp,tges - real(r_kind) wdirob,wdirgesin,wdirdiffmax - real(r_kind),dimension(nele,nobs):: data - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - - integer(i_kind) ier,ier2,ilon,ilat,ihgt,iuob,ivob,ipres,id,itime,ikx,iqc - integer(i_kind) iuse,ilate,ilone,ielev,izz,iprvd,isprvd - integer(i_kind) i,nchar,nreal,k,ii,ikxx,nn,isli,ibin,ioff,ioff0,jj,itype - integer(i_kind) l,mm1 - integer(i_kind) istat - integer(i_kind) idomsfc,iskint,iff10,isfcr - - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical lowlevelsat - logical proceed - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode ), pointer:: my_node - type(vwnd10mNode), pointer:: my_head - type(obs_diag ), pointer:: my_diag - - - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z !will probably need at some point - real(r_kind),allocatable,dimension(:,:,: ) :: ges_uwnd10m - real(r_kind),allocatable,dimension(:,:,: ) :: ges_vwnd10m - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv - real(r_kind),allocatable,dimension(:,:,: ) :: ges_wspd10m - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) then - read(lunin)data,luse !advance through input file - return ! not all vars available, simply return - endif - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!********************************************************************************* -! Read and reformat observations in work arrays. - spdb=zero - - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - ihgt=5 ! index of observation elevation - iuob=6 ! index of u observation - ivob=7 ! index of v observation - id=8 ! index of station id - itime=9 ! index of observation time in data array - ikxx=10 ! index of ob type - ielev=11 ! index of station elevation (m) - iqc=12 ! index of quality mark - ier2=13 ! index of original-original obs error ratio - iuse=14 ! index of use parameter - idomsfc=15 ! index of dominant surface type - iskint=16 ! index of surface skin temperature - iff10=17 ! index of 10 meter wind factor - isfcr=18 ! index of surface roughness - ilone=19 ! index of longitude (degrees) - ilate=20 ! index of latitude (degrees) - izz=21 ! index of surface height - iprvd=22 ! index of provider - isprvd=23 ! index of subprovider - - mm1=mype+1 - scale=one - rsig=nsig - thirty = 30.0_r_kind - r0_001=0.001_r_kind - rsigp=rsig+one - goverrd=grav/rd - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - -! Check for missing data - if (.not. oneobtest) then - do i=1,nobs - if (data(iuob,i) > r0_1_bmiss .or. data(ivob,i) > r0_1_bmiss) then - muse(i)=.false. - data(iuob,i)=rmiss_single ! for diag output - data(ivob,i)=rmiss_single ! for diag output - end if - end do - end if - -! Check for duplicate observations at same location - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ipres,k) == data(ipres,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - tfact=min(one,abs(data(itime,k)-data(itime,l))/dfact1) - dup(k)=dup(k)+one-tfact*tfact*(one-dfact) - dup(l)=dup(l)+one-tfact*tfact*(one-dfact) - end if - end do - end do - - - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=23 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+4*miter+1 - if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - call dtime_setup() - do i=1,nobs - dtime=data(itime,i) - call dtime_check(dtime, in_curbin, in_anybin) - if(.not.in_anybin) cycle - - if(in_curbin) then - dlat=data(ilat,i) - dlon=data(ilon,i) - - ikx = nint(data(ikxx,i)) - if(ikx < 1 .or. ikx > nconvtype) then - num_bad_ikx=num_bad_ikx+1 - if(num_bad_ikx<=10) write(6,*)' in setupvwnd10m, bad ikx, ikx,i,nconvtype=',ikx,i,nconvtype - cycle - end if - - error=data(ier2,i) - isli=data(idomsfc,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - if(luse_obsdiag)then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_vwnd10m_ob_type,ibin)%head)) then - obsdiags(i_vwnd10m_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_vwnd10m_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupvwnd10m: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_vwnd10m_ob_type,ibin)%tail => obsdiags(i_vwnd10m_ob_type,ibin)%head - else - allocate(obsdiags(i_vwnd10m_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupvwnd10m: failure to allocate obsdiags',istat - call stop2(295) - end if - obsdiags(i_vwnd10m_ob_type,ibin)%tail => obsdiags(i_vwnd10m_ob_type,ibin)%tail%next - end if - obsdiags(i_vwnd10m_ob_type,ibin)%n_alloc = obsdiags(i_vwnd10m_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_vwnd10m_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_vwnd10m_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_vwnd10m_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_vwnd10m_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_vwnd10m_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_vwnd10m_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_vwnd10m_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_vwnd10m_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_vwnd10m_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_vwnd10m_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_vwnd10m_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_vwnd10m_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_vwnd10m_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = 1 - else - if (.not.associated(obsdiags(i_vwnd10m_ob_type,ibin)%tail)) then - obsdiags(i_vwnd10m_ob_type,ibin)%tail => obsdiags(i_vwnd10m_ob_type,ibin)%head - else - obsdiags(i_vwnd10m_ob_type,ibin)%tail => obsdiags(i_vwnd10m_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_vwnd10m_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_vwnd10m_ob_type,ibin)%tail)') - end if - if (obsdiags(i_vwnd10m_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupvwnd10m: index error' - call stop2(297) - end if - end if - end if - - if(.not.in_curbin) cycle - -! Load observation error and values into local variables - uob = data(iuob,i) - vob = data(ivob,i) - spdob=sqrt(uob*uob+vob*vob) - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - -! Interpolate to get wspd10m at obs location/time - call tintrp2a11(ges_wspd10m,spdges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - itype=ictype(ikx) - -! Process observations with reported pressure - dpres = data(ipres,i) - presw = ten*exp(dpres) - dpres = dpres-log(psges) - drpx=zero - - prsfc=psges - prsln2=log(exp(prsltmp(1))/prsfc) - dpressave=dpres - -! Put obs pressure in correct units to get grid coord. number - dpres=log(exp(dpres)*prsfc) - call grdcrd1(dpres,prsltmp(1),nsig,-1) - -! Interpolate guess u and v to observation location and time. - - call tintrp2a11(ges_uwnd10m,ugesin,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a11(ges_vwnd10m,vgesin,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - - if(dpressave <= prsln2)then - factw=one - else - factw = data(iff10,i) - if(sfcmod_gfs .or. sfcmod_mm5) then - sfcr = data(isfcr,i) - skint = data(iskint,i) - call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) - end if - - call tintrp2a1(ges_tv,tges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) -! Apply 10-meter wind reduction factor to guess winds - dx10=-goverrd*ten/tges(1) - if (dpressave < dx10)then - term=(prsln2-dpressave)/(prsln2-dx10) - factw=one-term+factw*term - end if - ugesin=factw*ugesin - vgesin=factw*vgesin - - end if - -! Get approx k value of sfc by using surface pressure - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp(1),nsig,-1) - -! Checks based on observation location relative to model surface and top - rlow=max(sfcchk-dpres,zero) - rhgh=max(dpres-r0_001-rsigp,zero) - if(luse(i))then - awork(1) = awork(1) + one - if(rlow/=zero) awork(2) = awork(2) + one - if(rhgh/=zero) awork(3) = awork(3) + one - end if - -! Adjust observation error - wflate=zero - if (ictype(ikx)==288 .or. ictype(ikx)==295) then - if (spdob=ten ) wflate=four*data(ier,i) ! Tyndall/Horel type QC - endif - - ratio_errors=error/(data(ier,i)+drpx+wflate+1.0e6_r_kind*rhgh+four*rlow) - -! Invert observation error - error=one/error - -! Check to see if observation below model surface or above model top. -! If so, don't use observation - if (dpres > rsig )then - if( regional .and. presw > pt_ll )then - dpres=rsig - else - ratio_errors=zero - endif - endif - -! Compute innovations - lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & - itype==247.or.itype==250.or.itype==251.or.itype==252.or. & - itype==253.or.itype==254.or.itype==257.or.itype==258.or. & - itype==259 - if (lowlevelsat .and. twodvar_regional) then - call windfactor(presw,factw) - data(iuob,i)=factw*data(iuob,i) - data(ivob,i)=factw*data(ivob,i) - uob = data(iuob,i) - vob = data(ivob,i) - endif - dudiff=uob-ugesin - dvdiff=vob-vgesin - spdb=sqrt(uob**2+vob**2)-sqrt(ugesin**2+vgesin**2) - - ddiff=dvdiff - - if ( qc_satwnds ) then - if(itype >=240 .and. itype <=260) then - if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb - endif - if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top - if(presw >399.0_r_kind) error=zero - endif - if(itype ==258 .and. presw >600.0_r_kind) error=zero - if(itype ==259 .and. presw >600.0_r_kind) error=zero - endif ! qc_satwnds - -! QC WindSAT winds - if (itype==289) then - qcu = r6 - qcv = r6 - if ( spdob > r20 .or. & ! high wind speed check - abs(dudiff) > qcu .or. & ! u component check - abs(dvdiff) > qcv ) then ! v component check - error = zero - endif - endif - -! QC ASCAT winds - if (itype==290) then - qcu = five - qcv = five -! Compute innovations for opposite vectors - dudiff_opp = -uob - ugesin - dvdiff_opp = -vob - vgesin - vecdiff = sqrt(dudiff**2 + dvdiff**2) - vecdiff_opp = sqrt(dudiff_opp**2 + dvdiff_opp**2) - ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) - - if ( abs(dudiff) > qcu .or. & ! u component check - abs(dvdiff) > qcv .or. & ! v component check - vecdiff > vecdiff_opp ) then ! ambiguity check - - error = zero - endif - endif - -! If requested, setup for single obs test. - if (oneobtest) then - ddiff=maginnov - error=one/magoberr - ratio_errors=one - endif - -! Gross check using innovation normalized by error - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) - -! it's probably more robust to evalute gross-error in -! terms of magnitude of full-vector difference - -!! if ( abs(ugesin)>zero .or. abs(vgesin)>zero ) then -!! ugesin_scaled=(ugesin/sqrt(ugesin**2+vgesin**2))*spdges -!! vgesin_scaled=(vgesin/sqrt(ugesin**2+vgesin**2))*spdges -!! residual = sqrt((uob-ugesin_scaled)**2+(vob-vgesin_scaled)**2) -!! else -!! residual = sqrt(dudiff**2+dvdiff**2) -!! endif - -!! residual = sqrt(dudiff**2+dvdiff**2) - ratio = residual/obserrlm - -!! modify cgross depending on the quality mark, qcmark=3, cgross=0.7*cgross -!! apply asymetric gross check for satellite winds - qcgross=cgross(ikx) - if(data(iqc,i) == three) qcgross=r0_7*cgross(ikx) - - if(spdb <0 )then - if(itype ==244) then ! AVHRR, use same as MODIS - qcgross=r0_7*cgross(ikx) - endif - if(itype >=257 .and. itype <=259 ) then - qcgross=r0_7*cgross(ikx) - endif - endif - - if (ratio> qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(6) = awork(6)+one - error = zero - ratio_errors=zero - else - ratio_errors =ratio_errors/sqrt(dup(i)) - end if - - if (lowlevelsat .and. twodvar_regional) then - if (data(idomsfc,i) /= 0 .and. data(idomsfc,i) /= 3 ) then - error = zero - ratio_errors = zero - endif - endif - - if (twodvar_regional) then - if (lowlevelsat .or. itype==289 .or. itype==290) then - wdirdiffmax=45._r_kind - else - wdirdiffmax=100000._r_kind - endif - if (spdob > zero .and. (spdob-spdb) > zero) then - call getwdir(uob,vob,wdirob) - call getwdir(ugesin,vgesin,wdirgesin) - if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & - abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then - error = zero - ratio_errors = zero - endif - endif - endif - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_vwnd10m_ob_type,ibin)%tail%muse(nobskeep) - -! Compute penalty terms (linear & nonlinear qc). - val = error*ddiff - if(luse(i))then - val2 = val*val - exp_arg = -half*val2 - rat_err2 = ratio_errors**2 - if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_vwnd10m=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_vwnd10m*wnotgross) - term = log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - else - term = exp_arg - wgt = wgtlim - rwgt = wgt/wgtlim - endif - valqc = -two*rat_err2*term - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - awork(4)=awork(4)+val2*rat_err2 - awork(5)=awork(5)+one - awork(22)=awork(22)+valqc - end if - ress = ddiff*scale - ressw2 = ress*ress - val2 = val*val - rat_err2 = ratio_errors**2 - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - if (abs(data(ivob,i)-rmiss_single) >=tiny_r_kind) then - bwork(1,ikx,1,nn) = bwork(1,ikx,1,nn)+one ! count - bwork(1,ikx,2,nn) = bwork(1,ikx,2,nn)+ress ! (o-g) - bwork(1,ikx,3,nn) = bwork(1,ikx,3,nn)+ressw2 ! (o-g)**2 - bwork(1,ikx,4,nn) = bwork(1,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(1,ikx,5,nn) = bwork(1,ikx,5,nn)+valqc ! nonlin qc penalty - end if - - endif - - if(luse_obsdiag)then - obsdiags(i_vwnd10m_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_vwnd10m_ob_type,ibin)%tail%nldepart(jiter)=ddiff - obsdiags(i_vwnd10m_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - end if - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - if (.not. last .and. muse(i)) then - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) + 1 - my_node => my_head - call obsLList_appendNode(vwnd10mhead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - -! Set (i,j) indices of guess gridpoint that bound obs location - call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij) - - - - my_head%res = ddiff - my_head%err2 = error**2 - my_head%raterr2 = ratio_errors**2 - my_head%time = dtime - my_head%b = cvar_b(ikx) - my_head%pg = cvar_pg(ikx) - my_head%luse = luse(i) - if(luse_obsdiag)then - my_head%diags => obsdiags(i_vwnd10m_ob_type,ibin)%tail - my_diag => my_head%diags - if(my_head%idv /= my_diag%idv .or. & - my_head%iob /= my_diag%iob ) then - call perr(myname,'mismatching %[head,diags]%(idv,iob,ibin) =', & - (/is,ioid(i),ibin/)) - call perr(myname,'my_head%(idv,iob) =',(/my_head%idv,my_head%iob/)) - call perr(myname,'my_diag%(idv,iob) =',(/my_diag%idv,my_diag%iob/)) - call die(myname) - endif - end if - my_head => null () - endif - - -! Save stuff for diagnostic output - if(conv_diagsave .and. luse(i))then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) - rdiagbuf(6,ii) = presw ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (ms**-1) - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (ms**-1) - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (ms**-1) - - rdiagbuf(17,ii) = data(ivob,i) ! 10m vwind observation (ms**-1) - rdiagbuf(18,ii) = ddiff ! obs-ges used in analysis (ms**-1) - rdiagbuf(19,ii) = data(ivob,i)-vgesin! obs-ges w/o bias correction (ms**-1) (future slot) - - rdiagbuf(20,ii) = data(iuob,i) ! 10m vwind observation (ms**-1) - rdiagbuf(21,ii) = dudiff ! uob-ges (ms**-1) - rdiagbuf(22,ii) = data(iuob,i)-ugesin! uob-ges w/o bias correction (ms**-1) (future slot) - - if(regional) then - -! replace positions 17-22 with earth relative wind component information - - uob_reg=data(iuob,i) - vob_reg=data(ivob,i) - dlon_e=data(ilone,i)*deg2rad - call rotate_wind_xy2ll(uob_reg,vob_reg,uob_e,vob_e,dlon_e,dlon,dlat) - call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) - call rotate_wind_xy2ll(ddiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) - rdiagbuf(17,ii) = uob_e ! earth relative u wind component observation (m/s) - rdiagbuf(18,ii) = dudiff_e ! earth relative u obs-ges used in analysis (m/s) - rdiagbuf(19,ii) = uob_e-uges_e ! earth relative u obs-ges w/o bias correction (m/s) (future slot) - - rdiagbuf(20,ii) = vob_e ! earth relative v wind component observation (m/s) - rdiagbuf(21,ii) = dvdiff_e ! earth relative v obs-ges used in analysis (m/s) - rdiagbuf(22,ii) = vob_e-vges_e ! earth relative v obs-ges w/o bias correction (m/s) (future slot) - end if - - rdiagbuf(23,ii) = factw ! 10m wind reduction factor - - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_vwnd10m_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_vwnd10m_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_vwnd10m_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_vwnd10m_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominant surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - end if - - - end do - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:vwnd10m',i_vwnd10m_ob_type) - write(7)'uwn',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::uwnd10m', ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::vwnd10m', ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::wspd10m', ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::tv', ivar, istatus ) - proceed=proceed.and.ivar>0 - - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=10) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get uwnd10m ... - varname='uwnd10m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_uwnd10m))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_uwnd10m(size(rank2,1),size(rank2,2),nfldsig)) - ges_uwnd10m(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_uwnd10m(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get vwnd10m ... - varname='vwnd10m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_vwnd10m))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_vwnd10m(size(rank2,1),size(rank2,2),nfldsig)) - ges_vwnd10m(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_vwnd10m(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get wspd10m ... - varname='wspd10m' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_wspd10m))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_wspd10m(size(rank2,1),size(rank2,2),nfldsig)) - ges_wspd10m(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_wspd10m(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get tv ... - varname='tv' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_tv))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_tv(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_tv(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps )) deallocate(ges_ps ) - if(allocated(ges_tv )) deallocate(ges_tv ) - if(allocated(ges_uwnd10m)) deallocate(ges_uwnd10m) - if(allocated(ges_vwnd10m)) deallocate(ges_vwnd10m) - if(allocated(ges_wspd10m)) deallocate(ges_wspd10m) - end subroutine final_vars_ - -end subroutine setupvwnd10m - diff --git a/src/setupw.f90 b/src/setupw.f90 deleted file mode 100755 index 0337adbea..000000000 --- a/src/setupw.f90 +++ /dev/null @@ -1,1554 +0,0 @@ -!------------------------------------------------------------------------- -! NOAA/NCEP, National Centers for Environmental Prediction GSI ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: setupw --- Compute rhs of oi for wind component obs -! -! !INTERFACE: -! - -subroutine setupw(lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave) - -! !USES: - - use mpeu_util, only: die,perr - use kinds, only: r_kind,r_single,r_double,i_kind - use m_obsdiags, only: whead - use obsmod, only: rmiss_single,perturb_obs,oberror_tune,& - i_w_ob_type,obsdiags,obsptr,lobsdiagsave,nobskeep,lobsdiag_allocated,& - time_offset,bmiss - use m_obsNode, only: obsNode - use m_wNode, only: wNode - use m_obsLList, only: obsLList_appendNode - use obsmod, only: obs_diag,luse_obsdiag - use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset - use qcmod, only: npres_print,ptop,pbot,dfact,dfact1,qc_satwnds,njqc,vqc - use oneobmod, only: oneobtest,oneob_type,magoberr,maginnov - use gridmod, only: get_ijk,nsig,twodvar_regional,regional,wrf_nmm_regional,& - rotate_wind_xy2ll - use guess_grids, only: nfldsig,hrdifsig,geop_hgtl,sfcmod_gfs - use guess_grids, only: tropprs,sfcmod_mm5 - use guess_grids, only: ges_lnprsl,comp_fact10,pt_ll,pbl_height - use constants, only: zero,half,one,tiny_r_kind,two,cg_term, & - three,rd,grav,four,five,huge_single,r1000,wgtlim,r10,r400 - use constants, only: grav_ratio,flattening,deg2rad, & - grav_equator,somigliana,semi_major_axis,eccentricity - use jfunc, only: jiter,last,jiterstart,miter - use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype - use convinfo, only: icsubtype - use converr_uv, only: ptabl_uv - use converr, only: ptabl - use rapidrefresh_cldsurf_mod, only: l_PBL_pseudo_SurfobsUV, pblH_ration,pps_press_incr - use rapidrefresh_cldsurf_mod, only: l_closeobs, i_gsdqc - - use m_dtime, only: dtime_setup, dtime_check, dtime_show - - use gsi_bundlemod, only : gsi_bundlegetpointer - use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle - - implicit none - -! !INPUT PARAMETERS: - - integer(i_kind) ,intent(in ) :: lunin ! unit from which to read observations - integer(i_kind) ,intent(in ) :: mype ! mpi task id - integer(i_kind) ,intent(in ) :: nele ! number of data elements per observation - integer(i_kind) ,intent(in ) :: nobs ! number of observations - integer(i_kind) ,intent(in ) :: is ! ndat index - logical ,intent(in ) :: conv_diagsave ! logical to save innovation dignostics - -! !INPUT/OUTPUT PARAMETERS: - - real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork ! obs-ges stats - real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork ! data counts and gross checks - -! -! !DESCRIPTION: For wind component observations, this routine -! \begin{enumerate} -! \item reads obs assigned to given mpi task (geographic region), -! \item simulates obs from guess, -! \item apply some quality control to obs, -! \item load weight and innovation arrays used in minimization -! \item collects statistics for runtime diagnostic output -! \item writes additional diagnostic information to output file -! \end{enumerate} -! -! !REVISION HISTORY: -! -! 1990-10-06 parrish -! 1998-04-10 weiyu yang -! 1999-03-01 wu - ozone processing moved into setuprhs from setupoz -! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version -! 2004-06-17 treadon - update documentation -! 2004-07-15 todling - protex-compliant prologue; added intent/only's -! 2004-10-06 parrish - increase size of vwork array for nonlinear qc -! 2004-11-22 derber - remove weight, add logical for boundary point -! 2004-12-22 treadon - move logical conv_diagsave from obsmod to argument list -! 2005-03-02 dee - remove garbage from diagnostic file -! 2005-03-09 parrish - nonlinear qc change to account for inflated obs error -! 2005-05-27 derber - level output change -! 2005-07-22 jung - add modis winds -! 2005-07-27 derber - add print of monitoring and reject data -! 2005-09-28 derber - combine with prep,spr,remove tran and clean up -! 2005-10-14 derber - input grid location and fix regional lat/lon -! 2005-10-21 su - modified variational qc and diagnose output -! 2005-11-03 treadon - correct error in ilone,ilate data array indices -! 2005-11-22 wu - add option to perturb conventional obs -! 2005-11-29 derber - remove psfcg and use ges_lnps instead -! 2006-01-13 treadon - correct bugs in modis wind qc -! 2006-01-31 todling - storing wgt/wgtlim in diag file instead of wgt only -! 2006-02-02 treadon - rename lnprsl as ges_lnprsl -! 2006-02-08 treadon - correct vertical dimension (nsig) in call tintrp2a(ges_tv...) -! 2006-02-15 treadon - use height when processing type 223, 224, 229 winds -! 2006-02-24 derber - modify to take advantage of convinfo module -! 2006-03-21 treadon - modify optional perturbation to observation -! 2006-04-03 derber - fix bugs and move all surface data to height calculation -! 2006-05-30 su,derber,treadon - modify diagnostic output -! 2006-06-06 su - move to wgtlim to constants module -! 2006-07-28 derber - modify to use new inner loop obs data structure -! - modify handling of multiple data at same location -! 2006-07-31 kleist - use ges_ps instead of ln(ps) -! 2006-08-28 su - fix a bug in variational qc -! 2006-11-30 jung/sienkiewicz - add type 259 for modis winds -! 2006-10-28 su - turn off rawinsonde Vqc at south hemisphere -! 2007-03-09 su - modify observation pertabation for adjusting obs error -! 2007-03-19 tremolet - binning of observations -! 2007-03-27 li.bi - add qc for type 289 windsat winds -! 2007-06-05 tremolet - add observation diagnostics structure -! 2007-08-28 su - modify observation gross check error -! 2008-03-24 wu - oberror tuning and perturb obs -! 2008-03-31 li.bi - add qc for type 290 ascat winds -! 2008-05-20 safford - rm unused vars -! 2008-09-08 lueken - merged ed's changes into q1fy09 code -! 2008-12-03 todling - changed handle of tail%time -! 2009-08-19 guo - changed for multi-pass setup with dtime_check(). -! 2009-02-06 pondeca - for each observation site, add the following to the -! diagnostic file: local terrain height, dominate surface -! type, station provider name, and station subprovider name -! 2010-11-25 su - data items to hold quality mark for satellite wind -! 2011-03-08 parrish - for regional=.true., convert wind components in rdiagbuf from grid relative -! to earth relative, using subroutine rotate_wind_xy2ll. -! 2011-05-05 su - ome quality control for satellite satellite winds -! 2012-01-10 hu - add additional quality control for PBL profiler 223, 224, 227 -! 2011-12-14 wu - add code for rawinsonde level enhancement ( ext_sonde ) -! 2012-07-19 todling - add qc_satwnds flag to allow bypass QC-satwinds (QC not good for GMAO) -! 2011-10-14 Hu - add code for producing pseudo-obs in PBL -! layer based on surface obs UV -! 2013-01-08 Su -add more quality control for satellite winds and profiler winds -! 2013-01-26 parrish - change grdcrd to grdcrd1, intrp2a to intrp2a11, tintrp2a to tintrp2a1, tintrp2a11, -! tintrp3 to tintrp31 (so debug compile works on WCOSS) -! 2013-02-15 parrish - WCOSS debug runtime error--ikx outside range 1 to nconvtype. Add counter -! num_bad_ikx and print 1st 10 instances of ikx out of range -! and also print num_bad_ikx after all data processed if > 0 . -! 2013-05-24 wu - move rawinsonde level enhancement ( ext_sonde ) to read_prepbufr -! 2013-07-19 Hu/Olson/Carley - Add tall tower (type=261) winds -! 2013-10-19 todling - metguess now holds background -! 2014-01-28 todling - write sensitivity slot indicator (ioff) to header of diagfile -! 2014-04-12 su - add non linear qc from Purser's scheme -! 2014-12-30 derber - Modify for possibility of not using obsdiag -! 2015-05-01 Liu Ling - Added ISS Rapidscat wind (u,v) qc -! 2015-03-14 Nebuda - add departure check and near surface check for clear air WV AMV (WVCS) from GOES type 247 -! 2015-10-01 guo - full res obvsr: index to allow redistribution of obsdiags -! 2015-12-21 yang - Parrish's correction to the previous code in new varqc. -! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting -! 2016-06-24 guo - fixed the default value of obsdiags(:,:)%tail%luse to luse(i) -! . removed (%dlat,%dlon) debris. -! 2016-12-13 pondeca - add Tyndall & Horel QC for mesonet winds (WAF 2013, Vol. 8, pg. 285) to GSI's 2dvar option -! 2017-03-31 Hu - addd option l_closeobs to use closest obs to analysis -! time in analysis -! -! -! REMARKS: -! language: f90 -! machine: ibm RS/6000 SP; SGI Origin 2000; Compaq HP -! -! !AUTHOR: parrish org: np22 date: 1990-10-06 -! -!EOP -!------------------------------------------------------------------------- - -! Declare local parameters - real(r_kind),parameter:: r0_7=0.7_r_kind - real(r_kind),parameter:: r0_1=1.0_r_kind - real(r_kind),parameter:: r6=6.0_r_kind - real(r_kind),parameter:: r7=7.0_r_kind - real(r_kind),parameter:: r15=15.0_r_kind - real(r_kind),parameter:: r20=20.0_r_kind - real(r_kind),parameter:: r50=50.0_r_kind - real(r_kind),parameter:: r200=200.0_r_kind - real(r_kind),parameter:: r360=360.0_r_kind - real(r_kind),parameter:: r0_1_bmiss=0.1_r_kind*bmiss - - character(len=*),parameter:: myname='setupw' - -! Declare external calls for code analysis - external:: intrp2a11,tintrp2a1,tintrp2a11 - external:: tintrp31 - external:: grdcrd1 - external:: stop2 - -! Declare local variables - - real(r_double) rstation_id - real(r_kind) qcu,qcv,trop5,tfact,fact - real(r_kind) scale,ratio,obserror,obserrlm - real(r_kind) residual,ressw,ress,val,val2,valqc2,dudiff,dvdiff - real(r_kind) valqc,valu,valv,dx10,rlow,rhgh,drpx,prsfc,var_jb - real(r_kind) cg_w,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2,qcgross - real(r_kind) presw,factw,dpres,ugesin,vgesin,rwgt,dpressave - real(r_kind) sfcchk,prsln2,error,dtime,dlon,dlat,r0_001,rsig,thirty,rsigp - real(r_kind) ratio_errors,goverrd,spdges,spdob,ten,psges,zsges - real(r_kind) slat,sin2,termg,termr,termrg,pobl,uob,vob - real(r_kind) uob_reg,vob_reg,uob_e,vob_e,dlon_e,uges_e,vges_e,dudiff_e,dvdiff_e - real(r_kind) dz,zob,z1,z2,p1,p2,dz21,dlnp21,spdb,dstn - real(r_kind) errinv_input,errinv_adjst,errinv_final - real(r_kind) err_input,err_adjst,err_final,skint,sfcr - real(r_kind) dudiff_opp, dvdiff_opp, vecdiff, vecdiff_opp - real(r_kind) dudiff_opp_rs, dvdiff_opp_rs, vecdiff_rs, vecdiff_opp_rs - real(r_kind) oscat_vec,ascat_vec,rapidscat_vec - real(r_kind),dimension(nele,nobs):: data - real(r_kind),dimension(nobs):: dup - real(r_kind),dimension(nsig)::prsltmp,tges,zges - real(r_kind) wdirob,wdirgesin,wdirdiffmax - real(r_kind),dimension(34)::ptabluv - real(r_single),allocatable,dimension(:,:)::rdiagbuf - - integer(i_kind) i,nchar,nreal,k,j,l,ii,itype,ijb -! Variables needed for new polar winds QC based on Log Normalized Vector Departure (LNVD) - real(r_kind) LNVD_wspd - real(r_kind) LNVD_omb - real(r_kind) LNVD_ratio - real(r_kind) LNVD_threshold - - integer(i_kind) jsig,mm1,iptrbu,iptrbv,jj,icat - integer(i_kind) k1,k2,ikxx,nn,isli,ibin,ioff,ioff0 - integer(i_kind) ier,ilon,ilat,ipres,iuob,ivob,id,itime,ikx,ielev,iqc - integer(i_kind) ihgt,ier2,iuse,ilate,ilone,istat - integer(i_kind) izz,iprvd,isprvd - integer(i_kind) idomsfc,isfcr,iskint,iff10 - - integer(i_kind) num_bad_ikx - - character(8) station_id - character(8),allocatable,dimension(:):: cdiagbuf - character(8),allocatable,dimension(:):: cprvstg,csprvstg - character(8) c_prvstg,c_sprvstg - real(r_double) r_prvstg,r_sprvstg - - logical z_height,sfc_data - logical,dimension(nobs):: luse,muse - integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical lowlevelsat - logical proceed - - logical:: in_curbin, in_anybin - integer(i_kind),dimension(nobs_bins) :: n_alloc - integer(i_kind),dimension(nobs_bins) :: m_alloc - class(obsNode),pointer:: my_node - type(wNode),pointer :: my_head - type(obs_diag),pointer :: my_diag - real(r_kind) :: thisPBL_height,ratio_PBL_height,prest,prestsfc,dudiffsfc,dvdiffsfc - real(r_kind) :: hr_offset - real(r_kind) :: magomb - - equivalence(rstation_id,station_id) - equivalence(r_prvstg,c_prvstg) - equivalence(r_sprvstg,c_sprvstg) - - real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps - real(r_kind),allocatable,dimension(:,:,: ) :: ges_z - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v - real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv - -! Check to see if required guess fields are available - call check_vars_(proceed) - if(.not.proceed) return ! not all vars available, simply return - -! If require guess vars available, extract from bundle ... - call init_vars_ - - n_alloc(:)=0 - m_alloc(:)=0 -!****************************************************************************** -! Read and reformat observations in work arrays. - spdb=zero - - read(lunin)data,luse,ioid - -! index information for data array (see reading routine) - ier=1 ! index of obs error - ilon=2 ! index of grid relative obs location (x) - ilat=3 ! index of grid relative obs location (y) - ipres=4 ! index of pressure - ihgt=5 ! index of height - iuob=6 ! index of u observation - ivob=7 ! index of v observation - id=8 ! index of station id - itime=9 ! index of observation time in data array - ikxx=10 ! index of ndex ob type in convinfo file - ielev=11 ! index of station elevation - iqc=12 ! index of quality mark - ier2=13 ! index of original-original obs error ratio - iuse=14 ! index of use parameter - idomsfc=15 ! index of dominant surface type - iskint=16 ! index of surface skin temperature - iff10=17 ! index of 10 meter wind factor - isfcr=18 ! index of surface roughness - ilone=19 ! index of longitude (degrees) - ilate=20 ! index of latitude (degrees) - izz=21 ! index of surface height - iprvd=22 ! index of observation provider - isprvd=23 ! index of observation subprovider - icat=24 ! index of data level category - ijb=25 ! index of non linear qc parameter - iptrbu=26 ! index of u perturbation - iptrbv=27 ! index of v perturbation - - mm1=mype+1 - scale=one - rsig=nsig - thirty = 30.0_r_kind - ten = 10.0_r_kind - r0_001=0.001_r_kind - rsigp=rsig+one - goverrd=grav/rd - var_jb=zero - -! If requested, save select data for output to diagnostic file - if(conv_diagsave)then - ii=0 - nchar=1 - ioff0=23 - nreal=ioff0 - if (lobsdiagsave) nreal=nreal+7*miter+2 - if (twodvar_regional) then; nreal=nreal+2; allocate(cprvstg(nobs),csprvstg(nobs)); endif - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - end if - - do i=1,nobs - muse(i)=nint(data(iuse,i)) <= jiter - end do - -! handle multiple-report observations at a station - hr_offset=min_offset/60.0_r_kind - dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ipres,k) == data(ipres,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - - if(l_closeobs) then - if(abs(data(itime,k)-hr_offset) nconvtype) then - num_bad_ikx=num_bad_ikx+1 - if(num_bad_ikx<=10) write(6,*)' in setupw, bad ikx, ikx,i,nconvtype=',ikx,i,nconvtype - cycle - end if - isli = data(idomsfc,i) - endif - -! Link observation to appropriate observation bin - if (nobs_bins>1) then - ibin = NINT( dtime/hr_obsbin ) + 1 - else - ibin = 1 - endif - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin - -! Link obs to diagnostics structure - do jj=1,2 - if (luse_obsdiag) then - if (.not.lobsdiag_allocated) then - if (.not.associated(obsdiags(i_w_ob_type,ibin)%head)) then - obsdiags(i_w_ob_type,ibin)%n_alloc = 0 - allocate(obsdiags(i_w_ob_type,ibin)%head,stat=istat) - if (istat/=0) then - write(6,*)'setupw: failure to allocate obsdiags',istat - call stop2(304) - end if - obsdiags(i_w_ob_type,ibin)%tail => obsdiags(i_w_ob_type,ibin)%head - else - allocate(obsdiags(i_w_ob_type,ibin)%tail%next,stat=istat) - if (istat/=0) then - write(6,*)'setupw: failure to allocate obsdiags',istat - call stop2(305) - end if - obsdiags(i_w_ob_type,ibin)%tail => obsdiags(i_w_ob_type,ibin)%tail%next - end if - obsdiags(i_w_ob_type,ibin)%n_alloc = obsdiags(i_w_ob_type,ibin)%n_alloc +1 - - allocate(obsdiags(i_w_ob_type,ibin)%tail%muse(miter+1)) - allocate(obsdiags(i_w_ob_type,ibin)%tail%nldepart(miter+1)) - allocate(obsdiags(i_w_ob_type,ibin)%tail%tldepart(miter)) - allocate(obsdiags(i_w_ob_type,ibin)%tail%obssen(miter)) - obsdiags(i_w_ob_type,ibin)%tail%indxglb=ioid(i) - obsdiags(i_w_ob_type,ibin)%tail%nchnperobs=-99999 - obsdiags(i_w_ob_type,ibin)%tail%luse=luse(i) - obsdiags(i_w_ob_type,ibin)%tail%muse(:)=.false. - obsdiags(i_w_ob_type,ibin)%tail%nldepart(:)=-huge(zero) - obsdiags(i_w_ob_type,ibin)%tail%tldepart(:)=zero - obsdiags(i_w_ob_type,ibin)%tail%wgtjo=-huge(zero) - obsdiags(i_w_ob_type,ibin)%tail%obssen(:)=zero - - n_alloc(ibin) = n_alloc(ibin) +1 - my_diag => obsdiags(i_w_ob_type,ibin)%tail - my_diag%idv = is - my_diag%iob = ioid(i) - my_diag%ich = jj - my_diag%elat= data(ilate,i) - my_diag%elon= data(ilone,i) - - else - if (.not.associated(obsdiags(i_w_ob_type,ibin)%tail)) then - obsdiags(i_w_ob_type,ibin)%tail => obsdiags(i_w_ob_type,ibin)%head - else - obsdiags(i_w_ob_type,ibin)%tail => obsdiags(i_w_ob_type,ibin)%tail%next - end if - if (.not.associated(obsdiags(i_w_ob_type,ibin)%tail)) then - call die(myname,'.not.associated(obsdiags(i_w_ob_type,ibin)%tail)') - end if - if (obsdiags(i_w_ob_type,ibin)%tail%indxglb/=ioid(i)) then - write(6,*)'setupw: index error' - call stop2(306) - end if - endif - if (jj==1) obsptr => obsdiags(i_w_ob_type,ibin)%tail - endif - enddo - - if(.not.in_curbin) cycle - -! Load observation error and values into local variables - obserror = max(cermin(ikx),min(cermax(ikx),data(ier,i))) - uob = data(iuob,i) - vob = data(ivob,i) - spdob=sqrt(uob*uob+vob*vob) - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - - itype=ictype(ikx) - -! Type 221=pibal winds contain a mixture of wind observations reported -! by pressure and others by height. Those levels only reported by -! pressure have a missing value (ie, large) value for the reported -! height. The logic below determines whether to process type 221 -! wind observations using height or pressure as the vertical coordinate. -! If height is not bad (less than r0_1_bmiss), we use height in the -! forward model. Otherwise, use reported pressure. - - z_height = .false. - if ((itype>=221 .and. itype <= 229) .and. (data(ihgt,i)=280 .and. itype < 300) .and. (.not.twodvar_regional) - if (z_height .or. sfc_data) then - - drpx = zero - dpres = data(ihgt,i) - dstn = data(ielev,i) - call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) -! Subtract off combination of surface station elevation and -! model elevation depending on how close to surface - fact = zero - if(dpres-dstn > 10._r_kind)then - if(dpres-dstn > r1000)then - fact = one - else - fact=(dpres-dstn)/990._r_kind - end if - end if - dpres=dpres-(dstn+fact*(zsges-dstn)) - if(itype==261) dpres = data(ihgt,i) - -! Get guess surface elevation and geopotential height profile -! at observation location. - call tintrp2a1(geop_hgtl,zges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - -! For observation reported with geometric height above sea level, -! convert geopotential to geometric height. - - if ((itype>=223 .and. itype<=228) .or. sfc_data) then -! Convert geopotential height at layer midpoints to geometric -! height using equations (17, 20, 23) in MJ Mahoney's note -! "A discussion of various measures of altitude" (2001). -! Available on the web at -! http://mtp.jpl.nasa.gov/notes/altitude/altitude.html -! -! termg = equation 17 -! termr = equation 21 -! termrg = first term in the denominator of equation 23 -! zges = equation 23 - - slat = data(ilate,i)*deg2rad - sin2 = sin(slat)*sin(slat) - termg = grav_equator * & - ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2)) - termr = semi_major_axis /(one + flattening + grav_ratio - & - two*flattening*sin2) - termrg = (termg/grav)*termr - do k=1,nsig - zges(k) = (termr*zges(k)) / (termrg-zges(k)) ! eq (23) - end do - - endif - -! Given observation height, (1) adjust 10 meter wind factor if -! necessary, (2) convert height to grid relative units, (3) compute -! compute observation pressure (for diagnostic purposes only), and -! (4) compute location of midpoint of first model layer above surface -! in grid relative units - -! Adjust 10m wind factor if necessary. Rarely do we have a -! profiler/vad obs within 10 meters of the surface. Almost always, -! the code below resets the 10m wind factor to 1.0 (i.e., no -! reduction in wind speed due to surface friction). - -! Convert observation height (in dpres) from meters to grid relative -! units. Save the observation height in zob for later use. - zob = dpres - call grdcrd1(dpres,zges,nsig,1) - -! Interpolate guess u and v to observation location and time. - - call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - - if (zob > zges(1)) then - factw=one - else - factw = data(iff10,i) - if(sfcmod_gfs .or. sfcmod_mm5) then - sfcr = data(isfcr,i) - skint = data(iskint,i) - call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) - end if - - if (zob <= ten) then - if(zob < ten)then - term = max(zob,zero)/ten - factw = term*factw - end if - else - term = (zges(1)-zob)/(zges(1)-ten) - factw = one-term+factw*term - end if - - ugesin=factw*ugesin - vgesin=factw*vgesin - - endif - - if(sfc_data .or. dpres < one) then - drpx=0.005_r_kind*abs(dstn-zsges)*(one-fact) - end if - -! Compute observation pressure (only used for diagnostics) - -! Set indices of model levels below (k1) and above (k2) observation. - if (dpresnsig) then - z1=zges(nsig-1); p1=prsltmp(nsig-1) - z2=zges(nsig); p2=prsltmp(nsig) - drpx = 1.e6_r_kind - else - k=dpres - k1=min(max(1,k),nsig) - k2=max(1,min(k+1,nsig)) - z1=zges(k1); p1=prsltmp(k1) - z2=zges(k2); p2=prsltmp(k2) - endif - - dz21 = z2-z1 - dlnp21 = p2-p1 - dz = zob-z1 - pobl = p1 + (dlnp21/dz21)*dz - presw = ten*exp(pobl) - -! Determine location in terms of grid units for midpoint of -! first layer above surface - sfcchk=zero -! call grdcrd1(sfcchk,zges,nsig,1) - - -! Process observations with reported pressure - else - dpres = data(ipres,i) - presw = ten*exp(dpres) - dpres = dpres-log(psges) - drpx=zero - - prsfc=psges - prsln2=log(exp(prsltmp(1))/prsfc) - dpressave=dpres - -! Put obs pressure in correct units to get grid coord. number - dpres=log(exp(dpres)*prsfc) - call grdcrd1(dpres,prsltmp(1),nsig,-1) - -! Interpolate guess u and v to observation location and time. - - call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - if(dpressave <= prsln2)then - factw=one - else - factw = data(iff10,i) - if(sfcmod_gfs .or. sfcmod_mm5) then - sfcr = data(isfcr,i) - skint = data(iskint,i) - call comp_fact10(dlat,dlon,dtime,skint,sfcr,isli,mype,factw) - end if - - call tintrp2a1(ges_tv,tges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) -! Apply 10-meter wind reduction factor to guess winds - dx10=-goverrd*ten/tges(1) - if (dpressave < dx10)then - term=(prsln2-dpressave)/(prsln2-dx10) - factw=one-term+factw*term - end if - ugesin=factw*ugesin - vgesin=factw*vgesin - - end if - -! Get approx k value of sfc by using surface pressure - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp(1),nsig,-1) - - endif - - -! Checks based on observation location relative to model surface and top - rlow=max(sfcchk-dpres,zero) - rhgh=max(dpres-r0_001-rsigp,zero) - if(luse(i))then - awork(1) = awork(1) + one - if(rlow/=zero) awork(2) = awork(2) + one - if(rhgh/=zero) awork(3) = awork(3) + one - end if - ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+four*rlow) - -!JS - MOVED THIS HERE -! Compute innovations - lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & - itype==247.or.itype==250.or.itype==251.or.itype==252.or. & - itype==253.or.itype==254.or.itype==257.or.itype==258.or. & - itype==259 - if (lowlevelsat .and. twodvar_regional) then - call windfactor(presw,factw) - data(iuob,i)=factw*data(iuob,i) - data(ivob,i)=factw*data(ivob,i) - uob = data(iuob,i) - vob = data(ivob,i) - endif - dudiff=uob-ugesin - dvdiff=vob-vgesin - spdb=sqrt(uob**2+vob**2)-sqrt(ugesin**2+vgesin**2) - -! Setup dynamic ob error specification for aircraft recon in hurricanes - if (itype==236) then - magomb=sqrt(dudiff*dudiff+dvdiff*dvdiff) - ratio_errors=error/((0.75_r_kind*magomb+0.5_r_kind)+drpx+1.0e6_r_kind*rhgh+four*rlow) - endif - if (itype==237) then - magomb=sqrt(dudiff*dudiff+dvdiff*dvdiff) - ratio_errors=error/((0.75_r_kind*magomb+0.3_r_kind)+drpx+1.0e6_r_kind*rhgh+four*rlow) - endif - -! Invert observation error - error=one/error - -! Check to see if observation below model surface or above model top. -! If so, don't use observation - if (dpres > rsig )then - if( regional .and. presw > pt_ll )then - dpres=rsig - else - ratio_errors=zero - endif - endif - - if ( (itype>=221 .and. itype<=229).and. (dpres=230 .and. itype <=239 .and. presw <126.0_r_kind ) then - error=zero - endif - -! Quality control for satellite winds - - if ( qc_satwnds ) then - if (itype >=240 .and. itype <=260) then - call intrp2a11(tropprs,trop5,dlat,dlon,mype) - if(presw < trop5-r50) error=zero ! tropopose check for all satellite winds - endif - - if(itype >=240 .and. itype <=260) then - if(i_gsdqc==2) then - prsfc = r10*psges - if( prsfc-presw < 100.0_r_kind) error =zero ! add check for obs within 100 hPa of sfc - else - if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb - endif - endif - if(itype ==242 .or. itype ==243 ) then ! visible winds from JMA and EUMETSAT - if(presw <700.0_r_kind) error=zero ! no visible winds above 700mb - endif - if(itype ==245 ) then - if( presw >399.0_r_kind .and. presw <801.0_r_kind) then !GOES IR winds - error=zero ! no data between 400-800mb - endif - endif - if(itype == 252 .and. presw >499.0_r_kind .and. presw <801.0_r_kind) then ! JMA IR winds - error=zero - endif - if(itype == 253 ) then - if(presw >401.0_r_kind .and. presw <801.0_r_kind) then ! EUMET IR winds - error=zero - endif - endif - if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top - if(presw >399.0_r_kind) error=zero - endif - if(itype ==257 .and. presw <249.0_r_kind) error=zero - if(itype ==258 .and. presw >600.0_r_kind) error=zero - if(itype ==259 .and. presw >600.0_r_kind) error=zero - if(itype ==259 .and. presw <249.0_r_kind) error=zero - endif ! qc_satwnds - -! QC GOES CAWV - some checks above as well - if (itype==247) then - prsfc = r10*psges ! surface pressure in hPa - -! Compute observed and guess wind speeds (m/s). - spdges = sqrt(ugesin* ugesin +vgesin* vgesin ) - -! Set and compute GOES CAWV specific departure parameters - LNVD_wspd = spdob - LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) - LNVD_ratio = LNVD_omb / log(LNVD_wspd) - LNVD_threshold = 3.0_r_kind - if( .not. wrf_nmm_regional) then ! LNVD check not use for CAWV winds in HWRF - if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check - (presw > prsfc-110.0_r_kind .and. isli /= 0))then ! near surface check 110 ~1km - error = zero - endif - endif -! check for direction departure gt 50 deg - wdirdiffmax=50._r_kind - call getwdir(uob,vob,wdirob) - call getwdir(ugesin,vgesin,wdirgesin) - if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & - abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then - error = zero - endif - endif - -! QC MODIS winds - if (itype==257 .or. itype==258 .or. itype==259 .or. itype ==260) then -! Get guess values of tropopause pressure and sea/land/ice -! mask at observation location - prsfc = r10*prsfc ! surface pressure in hPa - -! Compute observed and guess wind speeds (m/s). - spdges = sqrt(ugesin* ugesin +vgesin* vgesin ) - -! Set and computes modis specific qc parameters - LNVD_wspd = spdob - LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) - LNVD_ratio = LNVD_omb / log(LNVD_wspd) - LNVD_threshold = 3.0_r_kind - if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check - (presw > prsfc-r200 .and. isli /= 0))then ! near surface check - error = zero - endif - endif ! ??? - -! QC AVHRR winds - if (itype==244) then -! Get guess values of tropopause pressure and sea/land/ice -! mask at observation location - prsfc = r10*prsfc ! surface pressure in hPa - -! Set and computes modis specific qc parameters - LNVD_wspd = spdob - LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff) - LNVD_ratio = LNVD_omb / log(LNVD_wspd) - LNVD_threshold = 3.0_r_kind - - if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check - (presw > prsfc-r200 .and. isli /= 0))then ! near surface check - error = zero - endif - endif ! end if all satellite winds - - -! QC WindSAT winds - if (itype==289) then - qcu = r6 - qcv = r6 - if ( spdob > r20 .or. & ! high wind speed check - abs(dudiff) > qcu .or. & ! u component check - abs(dvdiff) > qcv ) then ! v component check - error = zero - endif - endif - -! QC ASCAT winds - if (itype==290) then - qcu = five - qcv = five -! Compute innovations for opposite vectors - dudiff_opp = -uob - ugesin - dvdiff_opp = -vob - vgesin - vecdiff = sqrt(dudiff**2 + dvdiff**2) - vecdiff_opp = sqrt(dudiff_opp**2 + dvdiff_opp**2) - ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) - - if ( abs(dudiff) > qcu .or. & ! u component check - abs(dvdiff) > qcv .or. & ! v component check - vecdiff > vecdiff_opp ) then ! ambiguity check - - error = zero - endif - endif - -! QC RAPIDSCAT winds - if (itype==296) then - qcu = five - qcv = five -! Compute innovations for opposite vectors - dudiff_opp_rs = -uob - ugesin - dvdiff_opp_rs = -vob - vgesin - vecdiff_rs = sqrt(dudiff**2 + dvdiff**2) - vecdiff_opp_rs = sqrt(dudiff_opp_rs**2 + dvdiff_opp_rs**2) - rapidscat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) - if ( abs(dudiff) > qcu .or. & ! u component check - abs(dvdiff) > qcv .or. & ! v component check - vecdiff_rs > vecdiff_opp_rs ) then ! ambiguity check - error = zero - endif - endif - -! QC OSCAT winds - if (itype==291) then - qcu = r6 - qcv = r6 - oscat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2) - -! if ( spdob > r20 .or. & ! high wind speed check -! abs(dudiff) > qcu .or. & ! u component check -! oscat_vec > r0_1 .or. & -! abs(dvdiff) > qcv ) then ! v component check -! error = zero -! else -! write(6,2000) "999291291", data(ilate,i), & -! data(ilone,i), uob, vob, ugesin, vgesin, & -! jiter -! endif - - if (spdob > r20 .or. & - abs(dudiff) > qcu .or. & - oscat_vec > r0_1 .or. & - abs(dvdiff) > qcv) then - error = zero - endif - endif - - -2000 format(a9,1x,2(f8.2,1x),4(f8.2,1x),3x,i3) -2001 format(a6,1x,2(f8.2,1x),4(f8.2,1x),3x,i3,3x,f8.2) - -! If requested, setup for single obs test. - if (oneobtest) then - if (oneob_type=='u') then - dudiff=maginnov - dvdiff=zero - elseif (oneob_type=='v') then - dudiff=zero - dvdiff=maginnov - endif - error=one/magoberr - ratio_errors=one - end if - -! Gross error checks - obserror = one/max(ratio_errors*error,tiny_r_kind) - obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = sqrt(dudiff**2+dvdiff**2) - ratio = residual/obserrlm -!! modify cgross depending on the quality mark, qcmark=3, cgross=0.7*cgross -!! apply asymetric gross check for satellite winds - qcgross=cgross(ikx) - if(data(iqc,i) == three ) then - qcgross=r0_7*cgross(ikx) - endif - - if(spdb <0 )then - if(itype ==244) then ! AVHRR, use same as MODIS - qcgross=r0_7*cgross(ikx) - endif - if( itype == 245 .or. itype ==246) then - if(presw <400.0_r_kind .and. presw >300.0_r_kind ) qcgross=r0_7*cgross(ikx) - endif - if(itype == 253 .or. itype ==254) then - if( presw <400.0_r_kind .and. presw >200.0_r_kind) qcgross=r0_7*cgross(ikx) - endif - if(itype >=257 .and. itype <=259 ) then - qcgross=r0_7*cgross(ikx) - endif - endif - - if (ratio>qcgross .or. ratio_errors < tiny_r_kind) then - if (luse(i)) awork(4) = awork(4)+one - error = zero - ratio_errors = zero - else - ratio_errors = ratio_errors/sqrt(dup(i)) - end if - - if (lowlevelsat .and. twodvar_regional) then - if (data(idomsfc,i) /= 0 .and. data(idomsfc,i) /= 3 ) then - error = zero - ratio_errors = zero - endif - endif - - if (twodvar_regional) then - if (lowlevelsat .or. itype==289 .or. itype==290) then - wdirdiffmax=45._r_kind - else - wdirdiffmax=100000._r_kind - endif - if (spdob > zero .and. (spdob-spdb) > zero) then - call getwdir(uob,vob,wdirob) - call getwdir(ugesin,vgesin,wdirgesin) - if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), & - abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then - error = zero - ratio_errors = zero - endif - endif - if (itype==288 .or. itype==295) then !Tyndall & Horel QC for mesonet winds /(WAF 2013, Vol. 28, pg. 285) - if (spdob < one .and. (spdob-spdb) > five) then - error = zero - ratio_errors = zero - endif - endif - endif - - if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. - if ( (itype==261) .and. (ratio_errors*error <= 1.0E-100_r_kind) ) muse(i)=.false. - - if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_w_ob_type,ibin)%tail%muse(nobskeep) - -! Oberror Tuning and Perturb Obs - if(muse(i)) then - if(oberror_tune )then - if( jiter > jiterstart ) then - dudiff=dudiff+data(iptrbu,i)/error/ratio_errors - dvdiff=dvdiff+data(iptrbv,i)/error/ratio_errors - endif - else if(perturb_obs )then - dudiff=dudiff+data(iptrbu,i)/error/ratio_errors - dvdiff=dvdiff+data(iptrbv,i)/error/ratio_errors - endif - endif - - valu = error*dudiff - valv = error*dvdiff - -! Compute penalty terms (linear & nonlinear qc). - if(luse(i))then - val = valu*valu+valv*valv - exp_arg = -half*val - rat_err2 = ratio_errors**2 - if(njqc .and. var_jb>tiny_r_kind .and. var_jb<10.0_r_kind .and. error >tiny_r_kind) then - if(exp_arg == zero) then - wgt=one - else - wgt=sqrt(dudiff*dudiff+dvdiff*dvdiff)*error/sqrt(two*var_jb) - wgt=tanh(wgt)/wgt - endif - term=-two*var_jb*rat_err2*log(cosh((sqrt(val))/sqrt(two*var_jb))) - rwgt = wgt/wgtlim - valqc = -two*term - else if (vqc .and. cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then - arg = exp(exp_arg) - wnotgross= one-cvar_pg(ikx) - cg_w=cvar_b(ikx) - wgross = cg_term*cvar_pg(ikx)/(cg_w*wnotgross) - term =log((arg+wgross)/(one+wgross)) - wgt = one-wgross/(arg+wgross) - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term - else - term = exp_arg - wgt = one - rwgt = wgt/wgtlim - valqc = -two*rat_err2*term - endif - - -! Accumulate statistics for obs belonging to this task - if (muse(i)) then - if(rwgt < one) awork(21) = awork(21)+one - jsig = dpres - jsig=max(1,min(jsig,nsig)) - awork(4*nsig+jsig+100)=awork(4*nsig+jsig+100)+valu*valu*rat_err2 - awork(5*nsig+jsig+100)=awork(5*nsig+jsig+100)+valv*valv*rat_err2 - awork(6*nsig+jsig+100)=awork(6*nsig+jsig+100)+one - awork(3*nsig+jsig+100)=awork(3*nsig+jsig+100)+valqc - end if - -! Loop over pressure level groupings and obs to accumulate statistics -! as a function of observation type. - ress = scale*sqrt(dudiff**2+dvdiff**2) - ressw = ress*ress - val2 = half*(valu*valu+valv*valv) - valqc2 = half*valqc - nn=1 - if (.not. muse(i)) then - nn=2 - if(ratio_errors*error >=tiny_r_kind)nn=3 - end if - do k = 1,npres_print - if(presw >ptop(k) .and. presw<=pbot(k))then - bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count - bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+spdb ! speed bias - bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 - bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty - bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc2 ! nonlin qc penalty - - end if - end do - end if - - -! Fill obs to diagnostics structure - if (luse_obsdiag) then -! U - obsptr%muse(jiter)=muse(i) - obsptr%nldepart(jiter)=dudiff - obsptr%wgtjo= (error*ratio_errors)**2 -! V - obsdiags(i_w_ob_type,ibin)%tail%muse(jiter)=muse(i) - obsdiags(i_w_ob_type,ibin)%tail%nldepart(jiter)=dvdiff - obsdiags(i_w_ob_type,ibin)%tail%wgtjo= (error*ratio_errors)**2 - endif - -! If obs is "acceptable", load array with obs info for use -! in inner loop minimization (int* and stp* routines) - - if (.not. last .and. muse(i)) then - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(whead(ibin),my_node) - my_node => null() - - my_head%idv = is - my_head%iob = ioid(i) - my_head%elat= data(ilate,i) - my_head%elon= data(ilone,i) - - my_head%dlev = dpres - my_head%factw= factw - call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) - - do j=1,8 - my_head%wij(j)=factw*my_head%wij(j) - end do - - my_head%ures=dudiff - my_head%vres=dvdiff - my_head%err2=error**2 - my_head%raterr2=ratio_errors **2 - my_head%time = dtime - my_head%b=cvar_b(ikx) - my_head%pg=cvar_pg(ikx) - my_head%jb=var_jb - my_head%luse=luse(i) - - if (luse_obsdiag) then - my_head%diagu => obsptr - - my_diag => my_head%diagu - if(my_head%idv/=my_diag%idv .or. & - my_head%iob/=my_diag%iob .or. & - 1/=my_diag%ich ) then - call perr(myname,'mismatched %[head,diag], (idv,iob,ich,ibin) =',& - (/is,ioid(i),1,ibin/)) - call perr(myname,'head%(idv,iob,ich) =',(/my_head%idv,my_head%iob,1/)) - call perr(myname,'diag%(idv,iob,ich) =',(/my_diag%idv,my_diag%iob,my_diag%ich/)) - call die(myname) - endif - endif ! (luse_obsdiag) - - if(oberror_tune) then - my_head%upertb=data(iptrbu,i)/error/ratio_errors - my_head%vpertb=data(iptrbv,i)/error/ratio_errors - my_head%kx=ikx - if (njqc) then - ptabluv=ptabl_uv - else - ptabluv=ptabl - endif - if(presw > ptabluv(2))then - my_head%k1=1 - else if( presw <= ptabluv(33)) then - my_head%k1=33 - else - k_loop: do k=2,32 - if(presw > ptabluv(k+1) .and. presw <= ptabluv(k)) then - my_head%k1=k - exit k_loop - endif - enddo k_loop - endif - endif - - if (luse_obsdiag) then - my_head%diagv => obsdiags(i_w_ob_type,ibin)%tail - - my_diag => my_head%diagv - if(my_head%idv/=my_diag%idv .or. & - my_head%iob/=my_diag%iob .or. & - 2/=my_diag%ich ) then - call perr(myname,'mismatched %[head,diag], (idv,iob,ich,ibin) =',& - (/is,ioid(i),2,ibin/)) - call perr(myname,'head%(idv,iob,ich) =',(/my_head%idv,my_head%iob,2/)) - call perr(myname,'diag%(idv,iob,ich) =',(/my_diag%idv,my_diag%iob,my_diag%ich/)) - call die(myname) - endif - endif ! (luse_obsdiag) - - my_head => null() - end if - -! Save select output for diagnostic file - if (conv_diagsave .and. luse(i)) then - ii=ii+1 - rstation_id = data(id,i) - cdiagbuf(ii) = station_id ! station id - - rdiagbuf(1,ii) = ictype(ikx) ! observation type - rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype - - rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) - rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) - rdiagbuf(5,ii) = data(ielev,i) ! station elevation (meters) - rdiagbuf(6,ii) = presw ! observation pressure (hPa) - rdiagbuf(7,ii) = data(ihgt,i) ! observation height (meters) - rdiagbuf(8,ii) = dtime-time_offset ! obs time (hours relative to analysis time) - - rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark - rdiagbuf(10,ii) = var_jb ! non linear qc parameter - rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag - if(muse(i)) then - rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) - else - rdiagbuf(12,ii) = -one - endif - - err_input = data(ier2,i) - err_adjst = data(ier,i) - if (ratio_errors*error>tiny_r_kind) then - err_final = one/(ratio_errors*error) - else - err_final = huge_single - endif - - errinv_input = huge_single - errinv_adjst = huge_single - errinv_final = huge_single - if (err_input>tiny_r_kind) errinv_input = one/err_input - if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst - if (err_final>tiny_r_kind) errinv_final = one/err_final - - rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight - rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (m/s)**-1 - rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (m/s)**-1 - rdiagbuf(16,ii) = errinv_final ! final inverse observation error (m/s)**-1 - - rdiagbuf(17,ii) = data(iuob,i) ! u wind component observation (m/s) - rdiagbuf(18,ii) = dudiff ! u obs-ges used in analysis (m/s) - rdiagbuf(19,ii) = uob-ugesin ! u obs-ges w/o bias correction (m/s) (future slot) - - rdiagbuf(20,ii) = data(ivob,i) ! v wind component observation (m/s) - rdiagbuf(21,ii) = dvdiff ! v obs-ges used in analysis (m/s) - rdiagbuf(22,ii) = vob-vgesin ! v obs-ges w/o bias correction (m/s) (future slot) - - if(regional) then - -! replace positions 17-22 with earth relative wind component information - - uob_reg=data(iuob,i) - vob_reg=data(ivob,i) - dlon_e=data(ilone,i)*deg2rad - call rotate_wind_xy2ll(uob_reg,vob_reg,uob_e,vob_e,dlon_e,dlon,dlat) - call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) - call rotate_wind_xy2ll(dudiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) - rdiagbuf(17,ii) = uob_e ! earth relative u wind component observation (m/s) - rdiagbuf(18,ii) = dudiff_e ! earth relative u obs-ges used in analysis (m/s) - rdiagbuf(19,ii) = uob_e-uges_e ! earth relative u obs-ges w/o bias correction (m/s) (future slot) - - rdiagbuf(20,ii) = vob_e ! earth relative v wind component observation (m/s) - rdiagbuf(21,ii) = dvdiff_e ! earth relative v obs-ges used in analysis (m/s) - rdiagbuf(22,ii) = vob_e-vges_e ! earth relative v obs-ges w/o bias correction (m/s) (future slot) - end if - - rdiagbuf(23,ii) = factw ! 10m wind reduction factor - - ioff=ioff0 - if (lobsdiagsave) then - do jj=1,miter - ioff=ioff+1 - if (obsdiags(i_w_ob_type,ibin)%tail%muse(jj)) then - rdiagbuf(ioff,ii) = one - else - rdiagbuf(ioff,ii) = -one - endif - enddo - do jj=1,miter+1 - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsptr%nldepart(jj) - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_w_ob_type,ibin)%tail%nldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsptr%tldepart(jj) - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_w_ob_type,ibin)%tail%tldepart(jj) - enddo - do jj=1,miter - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsptr%obssen(jj) - ioff=ioff+1 - rdiagbuf(ioff,ii) = obsdiags(i_w_ob_type,ibin)%tail%obssen(jj) - enddo - endif - - if (twodvar_regional) then - rdiagbuf(ioff+1,ii) = data(idomsfc,i) ! dominate surface type - rdiagbuf(ioff+2,ii) = data(izz,i) ! model terrain at ob location - r_prvstg = data(iprvd,i) - cprvstg(ii) = c_prvstg ! provider name - r_sprvstg = data(isprvd,i) - csprvstg(ii) = c_sprvstg ! subprovider name - endif - - endif - -!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!! - if( .not. last .and. l_PBL_pseudo_SurfobsUV .and. & - ( itype==281 .or. itype==283 .or.itype==287 ) .and. & - muse(i) .and. dpres > -1.0_r_kind ) then - prest=presw ! in mb - prestsfc=prest - dudiffsfc=dudiff - dvdiffsfc=dvdiff - call tintrp2a11(pbl_height,thisPBL_height,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - ratio_PBL_height = (prest - thisPBL_height) * pblH_ration - if(ratio_PBL_height > zero) thisPBL_height = prest - ratio_PBL_height - prest = prest - pps_press_incr - DO while (prest > thisPBL_height) - ratio_PBL_height=1.0_r_kind-(prestsfc-prest)/(prestsfc-thisPBL_height) - - allocate(my_head) - m_alloc(ibin) = m_alloc(ibin) +1 - my_node => my_head ! this is a workaround - call obsLList_appendNode(whead(ibin),my_node) - my_node => null() - -!!! find uob and vob - uob = data(iuob,i) - vob = data(ivob,i) - - -! Put obs pressure in correct units to get grid coord. number - dpres=log(prest/r10) - call grdcrd1(dpres,prsltmp(1),nsig,-1) - -! Interpolate guess u and v to observation location and time. - - call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - call tintrp31(ges_v,vgesin,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - -!!! Set (i,j,k) indices of guess gridpoint that bound obs location - my_head%dlev = dpres - my_head%factw= 1._r_kind - call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) -!!! find ddiff - - dudiff = dudiffsfc*(0.5_r_kind + 0.5_r_kind*ratio_PBL_height) - dvdiff = dvdiffsfc*(0.5_r_kind + 0.5_r_kind*ratio_PBL_height) - - error=one/data(ier2,i) - - my_head%ures=dudiff - my_head%vres=dvdiff - my_head%err2=error**2 - my_head%raterr2=ratio_errors **2 - my_head%time = dtime - my_head%b=cvar_b(ikx) - my_head%pg=cvar_pg(ikx) - my_head%jb=var_jb - my_head%luse=luse(i) - if (luse_obsdiag) then - my_head%diagu => obsptr - my_head%diagv => obsdiags(i_w_ob_type,ibin)%tail - endif - - prest = prest - pps_press_incr - - my_head => null() - ENDDO - - endif ! 281,283,287 -!!!!!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!!!!!!!!! - - end do -! End of loop over observations - if(num_bad_ikx > 0) write(6,*)' in setupw, num_bad_ikx ( ikx<1 or ikx>nconvtype ) = ',num_bad_ikx - -! Release memory of local guess arrays - call final_vars_ - -! Write information to diagnostic file - if(conv_diagsave .and. ii>0)then - call dtime_show(myname,'diagsave:w',i_w_ob_type) - write(7)' uv',nchar,nreal,ii,mype,ioff0 - write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - - if (twodvar_regional) then - write(7)cprvstg(1:ii),csprvstg(1:ii) - deallocate(cprvstg,csprvstg) - endif - end if - - -! End of routine - - return - contains - - subroutine check_vars_ (proceed) - logical,intent(inout) :: proceed - integer(i_kind) ivar, istatus -! Check to see if required guess fields are available - call gsi_metguess_get ('var::ps', ivar, istatus ) - proceed=ivar>0 - call gsi_metguess_get ('var::z' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::u' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::v' , ivar, istatus ) - proceed=proceed.and.ivar>0 - call gsi_metguess_get ('var::tv', ivar, istatus ) - proceed=proceed.and.ivar>0 - end subroutine check_vars_ - - subroutine init_vars_ - - real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() - real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() - character(len=5) :: varname - integer(i_kind) ifld, istatus - -! If require guess vars available, extract from bundle ... - if(size(gsi_metguess_bundle)==nfldsig) then -! get ps ... - varname='ps' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_ps))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) - ges_ps(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_ps(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get z ... - varname='z' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) - if (istatus==0) then - if(allocated(ges_z))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) - ges_z(:,:,1)=rank2 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) - ges_z(:,:,ifld)=rank2 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get u ... - varname='u' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_u))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_u(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_u(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get v ... - varname='v' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_v))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_v(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_v(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif -! get tv ... - varname='tv' - call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - if (istatus==0) then - if(allocated(ges_tv))then - write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' - call stop2(999) - endif - allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) - ges_tv(:,:,:,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) - ges_tv(:,:,:,ifld)=rank3 - enddo - else - write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus - call stop2(999) - endif - else - write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& - nfldsig,size(gsi_metguess_bundle) - call stop2(999) - endif - end subroutine init_vars_ - - subroutine final_vars_ - if(allocated(ges_tv)) deallocate(ges_tv) - if(allocated(ges_v )) deallocate(ges_v ) - if(allocated(ges_u )) deallocate(ges_u ) - if(allocated(ges_z )) deallocate(ges_z ) - if(allocated(ges_ps)) deallocate(ges_ps) - end subroutine final_vars_ - -end subroutine setupw diff --git a/src/stpcalc.f90 b/src/stpcalc.f90 deleted file mode 100644 index 8efd49626..000000000 --- a/src/stpcalc.f90 +++ /dev/null @@ -1,896 +0,0 @@ -module stpcalcmod - -!$$$ module documentation block -! . . . . -! module: stpcalcmod module for stpcalc -! prgmmr: -! -! abstract: module for stpcalc -! -! program history log: -! 2005-05-21 Yanqiu zhu - wrap stpcalc and its tangent linear stpcalc_tl into one module -! 2005-11-21 Derber - remove interfaces and clean up code -! 2008-12-02 Todling - remove stpcalc_tl -! 2009-08-12 lueken - updated documentation -! 2012-02-08 kleist - consolidate weak constaints into one module stpjcmod. -! 2015-09-03 guo - obsmod::yobs has been replaced with m_obsHeadBundle, -! where yobs is created and destroyed when and where it -! is needed. -! -! subroutines included: -! sub stpcalc -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -implicit none - -PRIVATE -PUBLIC stpcalc - -contains - -subroutine stpcalc(stpinout,sval,sbias,xhat,dirx,dval,dbias, & - diry,penalty,penaltynew,pjcost,pjcostnew,end_iter) - -!$$$ subprogram documentation block -! . . . . -! subprogram: stpcalc calculate penalty and stepsize -! prgmmr: derber org: np23 date: 2003-12-18 -! -! abstract: calculate current penalty and estimate stepsize -! (nonlinear qc version) -! -! A description of nonlinear qc follows: -! -! The observation penalty Jo is defined as -! -! Jo = - (sum over obs) 2*log(Po) -! -! where, -! -! Po = Wnotgross*exp(-.5*(Hn(x+xb) - yo)**2 ) + Wgross -! with -! Hn = the forward model (possibly non-linear) normalized by -! observation error -! x = the current estimate of the analysis increment -! xb = the background state -! yo = the observation normalized by observation error -! -! Note: The factor 2 in definition of Jo is present because the -! penalty Jo as used in this code is 2*(usual definition -! of penalty) -! -! Wgross = Pgross*cg -! -! Wnotgross = 1 - Wgross -! -! Pgross = probability of gross error for observation (assumed -! here to have uniform distribution over the possible -! range of values) -! -! cg = sqrt(2*pi)/2b -! -! b = possible range of variable for gross errors, normalized by -! observation error -! -! The values for the above parameters that Bill Collins used in the -! eta 3dvar are: -! -! cg = cg_term/b, where cg_term = sqrt(2*pi)/2 -! -! b = 10. ! range for gross errors, normalized by obs error -! -! pg_q=.002 ! probability of gross error for specific humidity -! pg_pw=.002 ! probability of gross error for precipitable water -! pg_p=.002 ! probability of gross error for pressure -! pg_w=.005 ! probability of gross error for wind -! pg_t=.007 ! probability of gross error for temperature -! pg_rad=.002 ! probability of gross error for radiances -! -! -! Given the above Jo, the gradient of Jo is as follows: -! -! T -! gradx(Jo) = - (sum over observations) 2*H (Hn(x+xb)-yo)*(Po - Wgross)/Po -! -! where, -! -! H = tangent linear model of Hn about x+xb -! -! -! Note that if Pgross = 0.0, then Wnotgross=1.0 and Wgross=0.0. That is, -! the code runs as though nonlinear quality control were not present -! (which is indeed the case since the gross error probability is 0). -! -! As a result the same stp* routines may be used for use with or without -! nonlinear quality control. -! -! Please note, however, that using the nonlinear qc routines makes the -! stp* and int* operators nonlinear. Hence, the need to evaluate the -! step size operators each stepsize estimate for each observation type, -! given the current step size algorithm coded below. -! -! -! program history log: -! 2003-12-18 derber,j. -! 2004-07-23 derber - modify to include conventional sst -! 2004-07-28 treadon - add only to module use, add intent in/out -! 2004-10-06 parrish - add nonlinear qc option -! 2004-10-06 kleist - separate control vector for u,v, get search -! direction for u,v from dir for st,vp -! 2004-11-30 treadon - add brightness temperatures to nonlinear -! quality control -! 2005-01-20 okamoto - add u,v to stprad_qc -! 2005-01-26 cucurull- implement local GPS RO linear operator -! 2005-02-10 treadon - add u,v to stprad_qc (okamoto change not present) -! 2005-02-23 wu - add call to normal_rh_to_q to convert normalized -! RH to q -! 2005-04-11 treadon - rename stpcalc_qc as stpcalc -! 2005-05-21 yanqiu zhu - add 'use stp*mod', and modify call interfaces for using these modules -! 2005-05-27 derber - remove linear stepsize estimate -! 2005-06-03 parrish - add horizontal derivatives -! 2005-07-10 kleist - add dynamic constraint term (linear) -! 2005-09-29 kleist - expand Jc term, include time derivatives vector -! 2005-11-21 kleist - separate tendencies from Jc term, add call to calctends tlm -! 2005-12-01 cucurull - add code for GPS local bending angle, add use obsmod for ref_obs -! 2005-12-20 parrish - add arguments to call to stpt to enable boundary layer forward -! model option. -! 2006-04-18 derber - add explicit iteration over stepsize (rather than -! repeated calls) - clean up and simplify -! 2006-04-24 kleist - include both Jc formulations -! 2006-05-26 derber - modify to improve convergence checking -! 2007-03-19 tremolet - binning of observations -! 2007-04-13 tremolet - split Jo and 3dvar components into stpjo and stp3dvar -! 2006-07-26 parrish - correct inconsistency in computation of space and time derivatives of q -! currently, if derivatives computed, for q it is normalized q, but -! should be mixing ratio. -! 2006-08-04 parrish - add strong constraint initialization option -! 2006-09-18 derber - modify output from nonlinear operators to make same as linear operators -! 2006-09-20 derber - add sensible temperatures for conventional obs. -! 2006-10-12 treadon - replace virtual temperature with sensible in stppcp -! 2007-04-16 kleist - modified calls to tendency and constraint routines -! 2007-06-04 derber - use quad precision to get reproduceability over number of processors -! 2007-07-26 cucurull - update gps code to generalized vertical coordinate; -! get current solution for 3d pressure (xhat_3dp); -! move getprs_tl out of calctends_tl; add dirx3dp -! and remove ps in calctends_tl argument list; -! use getprs_tl -! 2007-08-08 derber - optimize, ensure that only necessary time derivatives are calculated -! 2007-10-01 todling - add timers -! 2008-11-28 todling - revisited Tremolet's split in light of changes from May08 version -! 2009-06-02 derber - modify the calculation of the b term for the background to increase accuracy -! 2010-06-01 treadon - accumulate pbcjo over nobs_bins -! 2010-08-19 lueken - add only to module use -! 2010-09-14 derber - clean up quad precision -! 2011-02-25 zhu - add gust,vis,pblh calls -! 2013-03-19 pondeca - add wspd10m call. introduce parameter n0 to make it easier to add -! more weak constraint contributions. update comment block to indicate -! the correct observation type associated with each pbc(*,j) term -! 2014-05-07 pondeca - add howv call -! 2014-06-17 carley/zhu - add tcamt and lcbas -! 2015-07-10 pondeca - add cldch -! 2016-02-03 derber - add code to search through all of the possible stepsizes tried, to find the -! one that minimizes the most and use that one. -! 2016-08-08 j guo - tried to edit some comments for a better description on pbc(*,:) elements -! reflecting jo terms. -! -! input argument list: -! stpinout - guess stepsize -! sval - current solution -! xhat - current solution -! dirx - search direction for x -! diry - search direction for y (B-1 dirx) -! end_iter - end iteration flag -! dval -! sbias,dbias -! -! output argument list: -! xhat -! stpinout - final estimate of stepsize -! penalty - penalty current solution -! penaltynew - estimate of penalty for new solution -! end_iter - end iteration flag false if stepsize successful -! pjcost - 4 major penalty terms current solution -! pjcostnew - 4 major penalty terms estimate new solution -! -! remarks: -! The part of xhat and dirx containing temps and psfc are values before strong initialization, -! xhatt, xhatp and dirxt, dirxp contain temps and psfc after strong initialization. -! If strong initialization is turned off, then xhatt, etc are equal to the corresponding -! fields in xhat, dirx. -! xhatuv, xhat_y, xhat_t and dirxuv, dirx_t are all after -! strong initialization if it is turned on. -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_kind,i_kind,r_quad,r_single - use mpimod, only: mype - use constants, only: zero,one_quad,zero_quad - use gsi_4dvar, only: nobs_bins,ltlint,ibin_anl - use jfunc, only: iout_iter,nclen,xhatsave,yhatsave,& - iter - use jcmod, only: ljcpdry,ljc4tlevs,ljcdfi - use obsmod, only: nobs_type - use stpjcmod, only: stplimq,stplimg,stplimv,stplimp,stplimw10m,& - stplimhowv,stplimcldch,stpjcdfi,stpjcpdry,stpliml - use bias_predictors, only: predictors - use control_vectors, only: control_vector,qdot_prod_sub,cvars2d - use state_vectors, only: allocate_state,deallocate_state - use gsi_bundlemod, only: gsi_bundle - use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_bundlemod, only: assignment(=) - use guess_grids, only: ntguessig,nfldsig - use mpl_allreducemod, only: mpl_allreduce - use mpeu_util, only: getindex - use intradmod, only: setrad - use timermod, only: timer_ini,timer_fnl - use stpjomod, only: stpjo - use m_obsHeadBundle, only: obsHeadBundle - use m_obsHeadBundle, only: obsHeadBundle_create - use m_obsHeadBundle, only: obsHeadBundle_destroy - use gsi_io, only: verbose - implicit none - -! Declare passed variables - real(r_kind) ,intent(inout) :: stpinout - logical ,intent(inout) :: end_iter - real(r_kind) ,intent( out) :: penalty,penaltynew - real(r_kind) ,intent( out) :: pjcost(4),pjcostnew(4) - - type(control_vector),intent(inout) :: xhat - type(control_vector),intent(in ) :: dirx,diry - type(gsi_bundle) ,intent(in ) :: sval(nobs_bins) - type(gsi_bundle) ,intent(in ) :: dval(nobs_bins) - type(predictors) ,intent(in ) :: sbias,dbias - - -! Declare local parameters - integer(i_kind),parameter:: n0 = 12 - integer(i_kind),parameter:: ipen = n0+nobs_type - integer(i_kind),parameter:: istp_iter = 5 - integer(i_kind),parameter:: ipenlin = 3 - integer(i_kind),parameter:: ioutpen = istp_iter*4 - real(r_quad),parameter:: one_tenth_quad = 0.1_r_quad - -! Declare local variables - integer(i_kind) i,j,mm1,ii,iis,ibin,ipenloc,it - integer(i_kind) istp_use,nstep,nsteptot,kprt - real(r_quad),dimension(4,ipen):: pbc - real(r_quad),dimension(4,nobs_type):: pbcjo - real(r_quad),dimension(4,nobs_type,nobs_bins):: pbcjoi - real(r_quad),dimension(4,nobs_bins):: pbcqmin,pbcqmax - real(r_quad) :: pen_est(n0+nobs_type) - real(r_quad),dimension(3,ipenlin):: pstart - real(r_quad) bx,cx,ccoef,bcoef,dels,sges1,sgesj - real(r_quad),dimension(0:istp_iter):: stp - real(r_kind),dimension(istp_iter):: stprat - real(r_quad),dimension(ipen):: bsum,csum,bsum_save,csum_save,pen_save - real(r_quad),dimension(ipen,nobs_bins):: pj - real(r_kind) delpen - real(r_kind) outpensave - real(r_kind),dimension(4)::sges - real(r_kind),dimension(ioutpen):: outpen,outstp - logical :: cxterm,change_dels,ifound - logical :: print_verbose - - - type(obsHeadBundle),pointer,dimension(:):: yobs -!************************************************************************************ -! Initialize timer - call timer_ini('stpcalc') - -! Initialize variable - print_verbose=.false. - if(verbose)print_verbose=.true. - cxterm=.false. - mm1=mype+1 - stp(0)=stpinout - outpen = zero - nsteptot=0 - istp_use=0 - pj=zero_quad - -! Begin calculating contributions to penalty and stepsize for various terms -! -! stepsize = sum(b)/sum(c) -! -! Differences used for 2-4 to reduce round-off error -! -! pbc(1,*) - stepsize sges(1) penalty -! pbc(2,*) - stepsize sges(2) penalty - sges(1) penalty -! pbc(3,*) - stepsize sges(3) penalty - sges(1) penalty -! pbc(4,*) - stepsize sges(4) penalty - sges(1) penalty -! -! linear terms -> pbc(*,1:ipenlin=3) -! pbc(*,1) contribution from background, sat rad bias, and precip bias -! pbc(*,2) placeholder for future linear linear term -! pbc(*,3) contribution from dry pressure constraint term (Jc) -! -! nonlinear terms -> pbc(*,4:n0) -! pbc(*,4) contribution from negative moisture constraint term (Jl/Jq) -! pbc(*,5) contribution from excess moisture term (Jl/Jq) -! pbc(*,6) contribution from negative gust constraint term (Jo) -! pbc(*,7) contribution from negative vis constraint term (Jo) -! pbc(*,8) contribution from negative pblh constraint term (Jo) -! pbc(*,9) contribution from negative wspd10m constraint term (Jo) -! pbc(*,10) contribution from negative howv constraint term (Jo) -! pbc(*,11) contribution from negative lcbas constraint term (Jo) -! pbc(*,12) contribution from negative cldch constraint term (Jo) -! -! Under polymorphism the following is the contents of pbs: -! linear terms => pbcjo(*,n0+1:n0+nobs_type), -! pbc (*,n0+j) := pbcjo(*,j); for j=1,nobs_type -! where, -! pbcjo(*, j) := sum( pbcjoi(*,j,1:nobs_bins) ) -! -! The original (wired) implementation of obs-types has -! the extra contents of pbc defined as: -! -! pbc(*,13) contribution from ps observation term (Jo) -! pbc(*,14) contribution from t observation term (Jo) -! pbc(*,15) contribution from w observation term (Jo) -! pbc(*,16) contribution from q observation term (Jo) -! pbc(*,17) contribution from spd observation term (Jo) -! pbc(*,18) contribution from rw observation term (Jo) -! pbc(*,19) contribution from dw observation term (Jo) -! pbc(*,20) contribution from sst observation term (Jo) -! pbc(*,21) contribution from pw observation term (Jo) -! pbc(*,22) contribution from pcp observation term (Jo) -! pbc(*,23) contribution from oz observation term (Jo) -! pbc(*,24) contribution from o3l observation term (Jo)(not used) -! pbc(*,25) contribution from gps observation term (Jo) -! pbc(*,26) contribution from rad observation term (Jo) -! pbc(*,27) contribution from tcp observation term (Jo) -! pbc(*,28) contribution from lag observation term (Jo) -! pbc(*,29) contribution from colvk observation term (Jo) -! pbc(*,30) contribution from aero observation term (Jo) -! pbc(*,31) contribution from aerol observation term (Jo) -! pbc(*,32) contribution from pm2_5 observation term (Jo) -! pbc(*,33) contribution from gust observation term (Jo) -! pbc(*,34) contribution from vis observation term (Jo) -! pbc(*,35) contribution from pblh observation term (Jo) -! pbc(*,36) contribution from wspd10m observation term (Jo) -! pbc(*,37) contribution from td2m observation term (Jo) -! pbc(*,38) contribution from mxtm observation term (Jo) -! pbc(*,39) contribution from mitm observation term (Jo) -! pbc(*,40) contribution from pmsl observation term (Jo) -! pbc(*,41) contribution from howv observation term (Jo) -! pbc(*,42) contribution from tcamt observation term (Jo) -! pbc(*,43) contribution from lcbas observation term (Jo) -! pbc(*,44) contribution from pm10 observation term (Jo) -! pbc(*,45) contribution from cldch observation term (Jo) -! pbc(*,46) contribution from uwnd10m observation term (Jo) -! pbc(*,47) contribution from vwnd10m observation term (Jo) -! -! However, users should be aware that under full polymorphism -! the obs-types are defined on the fly, that is to say, e.g.,that -! when running the global option the code won''t know at -! all of the obs-types not used in the global; the simplest -! example would be an experiment only using AOD; only AOD would -! be in the obs-type - nothing else; unlike the original obsmod -! setting. - - - - pstart=zero_quad - pbc=zero_quad - - -! penalty, b and c for background terms - - pstart(1,1) = qdot_prod_sub(xhatsave,yhatsave) - pj(1,1)=pstart(1,1) - -! two terms in next line should be the same, but roundoff makes average more accurate. - - pstart(2,1) =-0.5_r_quad*(qdot_prod_sub(dirx,yhatsave)+qdot_prod_sub(diry,xhatsave)) - - pstart(3,1) = qdot_prod_sub(dirx,diry) - - -! Contraints and 3dvar terms - -! Penalty, b, c for JcDFI - - if (ljcdfi .and. nobs_bins>1) then - call stpjcdfi(dval,sval,pstart(1,2),pstart(2,2),pstart(3,2)) - pj(2,1)=pstart(1,2) - end if - -! Penalty, b, c for dry pressure - if(ljcpdry)then - if (.not.ljc4tlevs) then - call stpjcpdry(dval(ibin_anl),sval(ibin_anl),pstart(1,3),pstart(2,3),pstart(3,3),1) - else - call stpjcpdry(dval,sval,pstart(1,3),pstart(2,3),pstart(3,3),nobs_bins) - end if - pj(3,1)=pstart(1,3) - end if - -! iterate over number of stepsize iterations (istp_iter - currently set to a maximum of 5) - dels = one_tenth_quad - stepsize: do ii=1,istp_iter - - iis=ii -! Delta stepsize - change_dels=.true. - - sges(1)= stp(ii-1) - sges(2)=(one_quad-dels)*stp(ii-1) - sges(3)=(one_quad+dels)*stp(ii-1) - - - if(ii == 1)then -! First stepsize iteration include current J calculation in position ipenloc - nstep=4 - sges(4)=zero - ipenloc=4 - else -! Later stepsize iteration include only stepsize and stepsize +/- dels - nstep=3 - end if - -! Calculate penalty values for linear terms - - do i=1,ipenlin - sges1=real(sges(1),r_quad) - pbc(1,i)=pstart(1,i)-(2.0_r_quad*pstart(2,i)-pstart(3,i)*sges1)*sges1 - do j=2,nstep - sgesj=real(sges(j),r_quad) - pbc(j,i)=(-2.0_r_quad*pstart(2,i)+pstart(3,i)*(sgesj+sges1))*(sgesj-sges1) - end do - end do - -! Do nonlinear terms - -! penalties for moisture constraint - if(.not. ltlint)then - if(.not.ljc4tlevs) then - call stplimq(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,4),pbc(1,5),nstep,ntguessig) - if(ii == 1)then - pj(4,1)=pbc(1,4)+pbc(ipenloc,4) - pj(5,1)=pbc(1,5)+pbc(ipenloc,5) - end if - else - do ibin=1,nobs_bins - if (nobs_bins /= nfldsig) then - it=ntguessig - else - it=ibin - end if - call stplimq(dval(ibin),sval(ibin),sges,pbcqmin(1,ibin),pbcqmax(1,ibin),nstep,it) - end do - pbc(:,4)=zero_quad - pbc(:,5)=zero_quad - do ibin=1,nobs_bins - do j=1,nstep - pbc(j,4) = pbc(j,4)+pbcqmin(j,ibin) - pbc(j,5) = pbc(j,5)+pbcqmax(j,ibin) - end do - end do - if(ii == 1)then - do ibin=1,nobs_bins - pj(4,ibin)=pj(4,ibin)+pbcqmin(1,ibin)+pbcqmin(ipenloc,ibin) - pj(5,ibin)=pj(5,ibin)+pbcqmax(1,ibin)+pbcqmax(ipenloc,ibin) - end do - end if - end if - -! penalties for gust constraint - if(getindex(cvars2d,'gust')>0) & - call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep) - if(ii == 1)pj(6,1)=pbc(1,6)+pbc(ipenloc,6) - -! penalties for vis constraint - if(getindex(cvars2d,'vis')>0) & - call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep) - if(ii == 1)pj(7,1)=pbc(1,7)+pbc(ipenloc,7) - -! penalties for pblh constraint - if(getindex(cvars2d,'pblh')>0) & - call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep) - if(ii == 1)pj(8,1)=pbc(1,8)+pbc(ipenloc,8) - -! penalties for wspd10m constraint - if(getindex(cvars2d,'wspd10m')>0) & - call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep) - if(ii == 1)pj(9,1)=pbc(1,9)+pbc(ipenloc,9) - -! penalties for howv constraint - if(getindex(cvars2d,'howv')>0) & - call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep) - if(ii == 1)pj(10,1)=pbc(1,10)+pbc(ipenloc,10) - -! penalties for lcbas constraint - if(getindex(cvars2d,'lcbas')>0) & - call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep) - if(ii == 1)pj(11,1)=pbc(1,11)+pbc(ipenloc,11) - -! penalties for cldch constraint - if(getindex(cvars2d,'cldch')>0) & - call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep) - if(ii == 1)pj(12,1)=pbc(1,12)+pbc(ipenloc,12) - end if - - call setrad(sval(1)) - -! penalties for Jo - pbcjoi=zero_quad - call obsHeadBundle_create(yobs,nobs_bins) - call stpjo(yobs,dval,dbias,sval,sbias,sges,pbcjoi,nstep,nobs_bins) - call obsHeadBundle_destroy(yobs) - - pbcjo=zero_quad - do ibin=1,size(yobs) ! == obs_bins - do j=1,nobs_type - do i=1,nstep - pbcjo(i,j)=pbcjo(i,j)+pbcjoi(i,j,ibin) - end do - end do - enddo - if(ii == 1)then - do ibin=1,nobs_bins - do j=1,nobs_type - pj(n0+j,ibin)=pj(n0+j,ibin)+pbcjoi(ipenloc,j,ibin)+pbcjoi(1,j,ibin) - end do - enddo - endif - do j=1,nobs_type - do i=1,nstep - pbc(i,n0+j)=pbcjo(i,j) - end do - end do - -! Gather J contributions - call mpl_allreduce(4,ipen,pbc) - -! save penalty and stepsizes - nsteptot=nsteptot+1 - do j=1,ipen - outpen(nsteptot) = outpen(nsteptot)+pbc(1,j) - end do - outstp(nsteptot) = sges(1) - do i=2,nstep - nsteptot=nsteptot+1 - do j=1,ipen - outpen(nsteptot) = outpen(nsteptot)+pbc(i,j)+pbc(1,j) - end do - outstp(nsteptot) = sges(i) - end do - -! estimate and sum b and c -! estimate stepsize contributions for each term - bcoef=0.25_r_quad/(dels*stp(ii-1)) - ccoef=0.5_r_quad/(dels*dels*stp(ii-1)*stp(ii-1)) - bx=zero_quad - cx=zero_quad - do i=1,ipen - bsum(i)=bcoef*(pbc(2,i)-pbc(3,i)) - csum(i)=ccoef*(pbc(2,i)+pbc(3,i)) - bx=bx+bsum(i) - cx=cx+csum(i) - end do - -! estimate of stepsize - - stp(ii)=stp(ii-1) - if(cx > 1.e-20_r_kind) then - stp(ii)=stp(ii)+bx/cx ! step size estimate - else -! Check for cx <= 0. (probable error or large nonlinearity) - if(mype == 0) then - write(iout_iter,*) ' entering cx <=0 stepsize option',cx,stp(ii) - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - stp(ii)=outstp(ipenloc) - outpensave=outpen(ipenloc) - do i=1,nsteptot - if(outpen(i) < outpensave)then - stp(ii)=outstp(i) - outpensave=outpen(i) - end if - end do - if(outpensave < outpen(ipenloc))then - if(mype == 0)write(iout_iter,*) ' early termination due to cx <=0 ',cx,stp(ii) - cxterm=.true. - else -! Try different (better?) stepsize - stp(ii)=max(outstp(1),1.0e-20_r_kind) - do i=2,nsteptot - if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) - end do - stp(ii)=one_tenth_quad*stp(ii) - change_dels=.false. - end if - end if - - -! estimate various terms in penalty on first iteration - if(ii == 1)then - do i=1,ipen - pen_save(i)=pbc(1,i) - bsum_save(i)=bsum(i) - csum_save(i)=csum(i) - end do - pjcost(1) = pen_save(1)+pbc(ipenloc,1) ! Jb - pjcost(2) = zero_quad - do i=1,nobs_type - pjcost(2) = pjcost(2)+pen_save(n0+i)+pbc(ipenloc,n0+i) ! Jo - end do - pjcost(3) = pen_save(2) + pen_save(3)+pbc(ipenloc,3) ! Jc - pjcost(4) = zero_quad - do i=4,n0 - pjcost(4) = pjcost(4) + pen_save(i)+pbc(ipenloc,i) ! Jl - end do - - penalty=pjcost(1)+pjcost(2)+pjcost(3)+pjcost(4) ! J = Jb + Jo + Jc +Jl - -! Write out detailed results to iout_iter - if(mype == 0) then - write(iout_iter,100) (pen_save(i)+pbc(ipenloc,i),i=1,ipen) - if(print_verbose)then - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - end if - endif - -! estimate of change in penalty - delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx ) - -! If change in penalty is very small end stepsize calculation - if(abs(delpen/penalty) < 1.e-17_r_kind) then - if(mype == 0)then - write(iout_iter,*) ' minimization has converged ' - write(iout_iter,140) ii,delpen,bx,cx,stp(ii) - write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen) - if(print_verbose)then - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - end if - end_iter = .true. -! Finalize timer - call timer_fnl('stpcalc') - istp_use=ii - exit stepsize - end if - -! Check for negative stepsize (probable error or large nonlinearity) - if(stp(ii) <= zero_quad) then - if(mype == 0) then - write(iout_iter,*) ' entering negative stepsize option',stp(ii) - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - stp(ii)=outstp(ipenloc) - outpensave=outpen(ipenloc) - do i=1,nsteptot - if(outpen(i) < outpensave)then - stp(ii)=outstp(i) - outpensave=outpen(i) - end if - end do -! Try different (better?) stepsize - if(stp(ii) <= zero_quad .and. ii /= istp_iter)then - stp(ii)=max(outstp(1),1.0e-20_r_kind) - do i=2,nsteptot - if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) - end do - stp(ii)=one_tenth_quad*stp(ii) - change_dels=.false. - end if - end if - -100 format(' J=',3e25.18/,(3x,3e25.18)) -101 format('EJ=',3e25.18/,(3x,3e25.18)) -105 format(' b=',3e25.18/,(3x,3e25.18)) -110 format(' c=',3e25.18/,(3x,3e25.18)) -130 format('***WARNING*** negative or small cx inner', & - ' iteration terminated - probable error',i2,3e25.18) -140 format('***WARNING*** expected penalty reduction small ',/, & - ' inner iteration terminated - probable convergence',i2,4e25.18) -141 format('***WARNING*** reduced penalty not found in search direction',/, & - ' - probable error',(5e25.18)) - -! Check for convergence in stepsize estimation - istp_use=ii - if(cxterm) exit stepsize - stprat(ii)=zero - if(stp(ii) > zero)then - stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii)) - end if - if(stprat(ii) < 1.e-4_r_kind) exit stepsize - if(change_dels)dels = one_tenth_quad*dels -! If stepsize estimate has not converged use best stepsize estimate or zero - if( ii == istp_iter)then - stp(ii)=outstp(ipenloc) - outpensave=outpen(ipenloc) - ifound=.false. -! Find best stepsize to this point - do i=1,nsteptot - if(outpen(i) < outpensave)then - stp(ii)=outstp(i) - outpensave=outpen(i) - ifound=.true. - end if - end do - if(ifound)exit stepsize -! If no best stepsize set to zero and end minimization - if(mype == 0)then - write(iout_iter,141)(outpen(i),i=1,nsteptot) - end if - end_iter = .true. - stp(ii)=zero_quad - istp_use=ii - exit stepsize - end if - end do stepsize - kprt=3 - if(kprt >= 2 .and. iter == 0)then - call mpl_allreduce(ipen,nobs_bins,pj) - if(mype == 0)call prnt_j(pj,ipen,kprt) - end if - - stpinout=stp(istp_use) -! Estimate terms in penalty - if(mype == 0 .and. print_verbose)then - do i=1,ipen - pen_est(i)=pen_save(i)-(stpinout-stp(0))*(2.0_r_quad*bsum_save(i)- & - (stpinout-stp(0))*csum_save(i)) - end do - write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) - end if - pjcostnew(1) = pbc(1,1) ! Jb - pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc - pjcostnew(4)=zero - do i=4,n0 - pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl - end do - pjcostnew(2) = zero - do i=1,nobs_type - pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo - end do - penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4) - - if(mype == 0 .and. print_verbose)then - write(iout_iter,200) (stp(i),i=0,istp_use) - write(iout_iter,199) (stprat(ii),ii=1,istp_use) - write(iout_iter,201) (outstp(i),i=1,nsteptot) - write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot) - end if -! Check for final stepsize negative (probable error) - if(stpinout <= zero)then - if(mype == 0)then - write(iout_iter,130) ii,bx,cx,stp(ii) - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) - end if - end_iter = .true. - end if -199 format(' stepsize stprat = ',6(e25.18,1x)) -200 format(' stepsize estimates = ',6(e25.18,1x)) -201 format(' stepsize guesses = ',(10(e13.6,1x))) -202 format(' penalties = ',(10(e13.6,1x))) - -! If convergence or failure of stepsize calculation return - if (end_iter) then - call timer_fnl('stpcalc') - return - endif - -! Update solution -!DIR$ IVDEP - do i=1,nclen - xhat%values(i)=xhat%values(i)+stpinout*dirx%values(i) - xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i) - yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i) - end do - - -! Finalize timer - call timer_fnl('stpcalc') - - return -end subroutine stpcalc - -subroutine prnt_j(pj,ipen,kprt) -!$$$ subprogram documentation block -! . . . . -! subprogram: prnt_j -! prgmmr: derber -! -! abstract: prints J components -! -! program history log: -! 2015=03-06 derber -! -! input argument list: -! pj - array containing contributions to penalty -! ipen - number of penalty terms -! kprt - print type flag -! -! output argument list: -! -! attributes: -! language: f90 - use kinds, only: r_kind,i_kind,r_quad - use gsi_4dvar, only: nobs_bins - use constants, only: zero_quad - use jfunc, only: jiter,iter - use mpimod, only: mype - use obsmod, only: cobstype,nobs_type - real(r_quad),dimension(ipen,nobs_bins),intent(in ) :: pj - integer(i_kind) ,intent(in ) :: ipen,kprt - - real(r_quad),dimension(ipen) :: zjt - real(r_quad) :: zj - integer(i_kind) :: ii,jj - character(len=20) :: ctype(ipen) - - if(kprt <=0 .or. mype /=0)return - ctype(1)='background ' - ctype(2)=' ' - ctype(3)='dry mass constraint ' - ctype(4)='negative moisture ' - ctype(5)='excess moisture ' - ctype(6)='negative gust ' - ctype(7)='negative visability ' - ctype(8)='negative boundary Lr' - ctype(9)='negative 10m wind ssp' - ctype(10)='negative howv ' - ctype(11)='negative lcbas ' - ctype(12)='negative cldch ' - do ii=1,nobs_type - ctype(12+ii)=cobstype(ii) - end do - - zjt=zero_quad - do ii=1,nobs_bins - zjt(:)=zjt(:)+pj(:,ii) - end do - - zj=zero_quad - do ii=1,ipen - zj=zj+zjt(ii) - end do - -! Prints - if (kprt>=2) write(6,*)'Begin J table inner/outer loop',iter,jiter - - if (kprt>=3.and.nobs_bins>1) then - write(6,410)'J contribution ',(jj,jj=1,nobs_bins) - do ii=1,ipen - if (zjt(ii)>zero_quad) then - write(6,100)ctype(ii),(real(pj(ii,jj),r_kind),jj=1,nobs_bins) - endif - enddo - endif - write(6,400)' J term ',' ',' J ' - do ii=1,ipen - if (zjt(ii)>zero_quad) then - write(6,200)ctype(ii),real(zjt(ii),r_kind) - endif - enddo - - write(6,*)'----------------------------------------------------- ' - write(6,200)"J Global ",real(zj,r_kind) - - write(6,*)'End Jo table inner/outer loop',iter,jiter - -100 format(a20,2x,10es14.6) -410 format(a20,2x,10I14) -200 format(a20,2x,3x,2x,es24.16) -400 format(a20,2x,a3,2x,a24) - end subroutine prnt_j - -end module stpcalcmod diff --git a/src/stpjo.f90 b/src/stpjo.f90 deleted file mode 100644 index 029416a87..000000000 --- a/src/stpjo.f90 +++ /dev/null @@ -1,791 +0,0 @@ -module stpjomod - -!$$$ subprogram documentation block -! . . . . -! subprogram: stpjo calculate penalty and stepsize -! prgmmr: derber org: np23 date: 2003-12-18 -! -! abstract: calculate observation term to penalty and estimate stepsize -! (nonlinear qc version) -! -! program history log: -! 2003-12-18 derber,j. - -! 2016-08-22 guo, j. - Wrapped simple subroutines to a module, with -! private module variables from obsmod.F90 moved -! here. -! . For the earlier program history log, see the -! "program history log" blocks below, in -! individual subroutines/module-procedures. -! . Changed if/elseif/else blocks to select-case -! blocks, using enumerated i_ob_type to replace -! locally hard-wired index values (ll=1,2,3,..). -! This is a step moving toward using type-bound- -! procedures. - - use kinds , only: i_kind - use obsmod, only: nobs_type - use obsmod, only: & - & i_ps_ob_type, i_t_ob_type, i_w_ob_type, i_q_ob_type, & - & i_spd_ob_type, i_rw_ob_type, i_dw_ob_type, & - & i_sst_ob_type, i_pw_ob_type, i_oz_ob_type, i_o3l_ob_type, i_colvk_ob_type, & - & i_gps_ob_type, i_rad_ob_type, i_pcp_ob_type,i_tcp_ob_type, & - & i_pm2_5_ob_type, i_gust_ob_type, i_vis_ob_type, i_pblh_ob_type, & - & i_pm10_ob_type, & - & i_wspd10m_ob_type,i_uwnd10m_ob_type,i_vwnd10m_ob_type,i_td2m_ob_type,i_mxtm_ob_type,i_mitm_ob_type, & - i_pmsl_ob_type,i_howv_ob_type,i_tcamt_ob_type,i_lcbas_ob_type, & - i_aero_ob_type, i_cldch_ob_type - - implicit none - - private - - ! Usecase 1: as-is - ! call stpjo_setup(yobs,size(yobs)) - ! call stpjo(yobs,dval,dbias,xval,xbias,sges,pbcjo,nstep,size(yobs)) - public:: stpjo - public:: stpjo_setup - - ! Usecase 2: Renamed with the same functionalities but more explicit names - public:: stpjo_reset ! always re-set, either undefined or already defined. - interface stpjo_reset; module procedure stpjo_setup; end interface - public:: stpjo_calc ! - interface stpjo_calc ; module procedure stpjo ; end interface - -! Moved here from obsmod.F90 -! def stpcnt - number of non-zero obs types (including time domain) on -! processor - used for threading of stpjo -! def ll_jo - points at ob type for location in stpcnt - used for -! threading of stpjo -! def ib_jo - points at time bin for location in stpcnt - used for -! threading of stpjo - - integer(i_kind),save:: stpcnt ! count of stpjo threads - integer(i_kind),save,allocatable,dimension(:):: ll_jo ! enumerated iobtype of threads - integer(i_kind),save,allocatable,dimension(:):: ib_jo ! ob-bin index values of threads - -contains - -subroutine init_(nobs_bins) - implicit none - integer(i_kind),intent(in):: nobs_bins - - if(allocated(ll_jo)) deallocate(ll_jo) - if(allocated(ib_jo)) deallocate(ib_jo) - - allocate(ll_jo(nobs_bins*nobs_type), & - ib_jo(nobs_bins*nobs_type) ) - - ll_jo(:)=0 - ib_jo(:)=0 - stpcnt =0 -end subroutine init_ -subroutine final_() - implicit none - if(allocated(ll_jo)) deallocate(ll_jo) - if(allocated(ib_jo)) deallocate(ib_jo) - stpcnt=0 -end subroutine final_ - -subroutine stpjo(yobs,dval,dbias,xval,xbias,sges,pbcjo,nstep,nobs_bins) - -!$$$ subprogram documentation block -! . . . . -! subprogram: stpjo calculate penalty and stepsize -! prgmmr: derber org: np23 date: 2003-12-18 -! -! abstract: calculate observation term to penalty and estimate stepsize -! (nonlinear qc version) -! -! A description of nonlinear qc follows: -! -! The observation penalty Jo is defined as -! -! Jo = - (sum over obs) 2*log(Po) -! -! where, -! -! Po = Wnotgross*exp(-.5*(Hn(x+xb) - yo)**2 ) + Wgross -! with -! Hn = the forward model (possibly non-linear) normalized by -! observation error -! x = the current estimate of the analysis increment -! xb = the background state -! yo = the observation normalized by observation error -! -! Note: The factor 2 in definition of Jo is present because the -! penalty Jo as used in this code is 2*(usual definition -! of penalty) -! -! Wgross = Pgross*cg -! -! Wnotgross = 1 - Wgross -! -! Pgross = probability of gross error for observation (assumed -! here to have uniform distribution over the possible -! range of values) -! -! cg = sqrt(2*pi)/2b -! -! b = possible range of variable for gross errors, normalized by -! observation error -! -! The values for the above parameters that Bill Collins used in the -! eta 3dvar are: -! -! cg = cg_term/b, where cg_term = sqrt(2*pi)/2 -! -! b = 10. ! range for gross errors, normalized by obs error -! -! pg_q=.002 ! probability of gross error for specific humidity -! pg_pw=.002 ! probability of gross error for precipitable water -! pg_p=.002 ! probability of gross error for pressure -! pg_w=.005 ! probability of gross error for wind -! pg_t=.007 ! probability of gross error for temperature -! pg_rad=.002 ! probability of gross error for radiances -! -! -! Given the above Jo, the gradient of Jo is as follows: -! -! T -! gradx(Jo) = - (sum over observations) 2*H (Hn(x+xb)-yo)*(Po - Wgross)/Po -! -! where, -! -! H = tangent linear model of Hn about x+xb -! -! -! Note that if Pgross = 0.0, then Wnotgross=1.0 and Wgross=0.0. That is, -! the code runs as though nonlinear quality control were not present -! (which is indeed the case since the gross error probability is 0). -! -! As a result the same stp* routines may be used for use with or without -! nonlinear quality control. -! -! Please note, however, that using the nonlinear qc routines makes the -! stp* and int* operators nonlinear. Hence, the need to evaluate the -! step size operators twice for each observation type, give the current -! step size algorithm coded below. -! -! -! program history log: -! 2003-12-18 derber,j. -! 2004-07-23 derber - modify to include conventional sst -! 2004-07-28 treadon - add only to module use, add intent in/out -! 2004-10-06 parrish - add nonlinear qc option -! 2004-10-06 kleist - separate control vector for u,v, get search -! direction for u,v from dir for st,vp -! 2004-11-30 treadon - add brightness temperatures to nonlinear -! quality control -! 2005-01-20 okamoto - add u,v to stprad_qc -! 2005-01-26 cucurull- implement local GPS RO linear operator -! 2005-02-10 treadon - add u,v to stprad_qc (okamoto change not present) -! 2005-02-23 wu - add call to normal_rh_to_q to convert normalized -! RH to q -! 2005-04-11 treadon - rename stpcalc_qc as stpcalc -! 2005-05-21 yanqiu zhu - add 'use stp*mod', and modify call interfaces for using these modules -! 2005-05-27 derber - remove linear stepsize estimate -! 2005-06-03 parrish - add horizontal derivatives -! 2005-07-10 kleist - add dynamic constraint term (linear) -! 2005-09-29 kleist - expand Jc term, include time derivatives vector -! 2005-11-21 kleist - separate tendencies from Jc term, add call to calctends tlm -! 2005-12-01 cucurull - add code for GPS local bending angle, add use obsmod for ref_obs -! 2005-12-20 parrish - add arguments to call to stpt to enable boundary layer forward -! model option. -! 2006-04-18 derber - add explicit iteration over stepsize (rather than -! repeated calls) - clean up and simplify -! 2006-04-24 kleist - include both Jc formulations -! 2006-05-26 derber - modify to improve convergence checking -! 2006-07-26 parrish - correct inconsistency in computation of space and time derivatives of q -! currently, if derivatives computed, for q it is normalized q, but -! should be mixing ratio. -! 2006-08-04 parrish - add strong constraint initialization option -! 2006-09-18 derber - modify output from nonlinear operators to make same as linear operators -! 2006-09-20 derber - add sensible temperatures for conventional obs. -! 2006-10-12 treadon - replace virtual temperature with sensible in stppcp -! 2007-03-19 tremolet - binning of observations -! 2007-04-13 tremolet - split jo from other components of stpcalc -! 2007-04-16 kleist - modified calls to tendency and constraint routines -! 2007-06-04 derber - use quad precision to get reproduceability over number of processors -! 2007-07-26 cucurull - update gps code to generalized vertical coordinate; -! get current solution for 3d pressure (xhat_3dp); -! move getprs_tl out of calctends_tl; add dirx3dp -! and remove ps in calctends_tl argument list; -! use getprs_tl -! 2007-08-08 derber - optimize, ensure that only necessary time derivatives are calculated -! 2008-12-02 todling - revisited split of stpcalc in light of 4dvar merge with May08 version -! 2009-01-08 todling - remove reference to ozohead -! 2010-01-04 zhang,b - bug fix: accumulate penalty for multiple obs bins -! 2010-03-25 zhu - change the interfaces of stprad,stpt,stppcp;add nrf* conditions -! 2010-05-13 todling - harmonized all stp interfaces to use state vector; gsi_bundle use -! 2010-06-14 todling - add stpco call -! 2010-07-10 todling - somebody reordered calls to stpw, stpq, and stpoz - any reason? -! 2010-10-15 pagowski - add stppm2_5 call -! 2011-02-24 zhu - add gust,vis,pblh calls -! 2013-05-23 zhu - add bias correction contribution from aircraft T bias correction -! 2014-03-19 pondeca - add wspd10m -! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl -! 2014-05-07 pondeca - add howv -! 2014-06-17 carley/zhu - add lcbas and tcamt -! 2015-07-10 pondeca - add cldch -! 2016-05-05 pondeca - add uwnd10m, vwnd10m -! 2016-08-26 guo - separated a single stpoz() call into stpozlay() and -! stpozlev() calls. This is a next-step fix of the -! minimum fix in stpjo_setup() below, to let output -! pbcjo(:,:,:) to reflect individual ob-types correctly. -! -! input argument list: -! yobs -! dval - current solution -! dbias - -! xval - -! xbias - -! sges -! nstep - number of steps -! -! output argument list: -! pbcjo -! -! -! remarks: -! 1. The part of xhat and dirx containing temps and psfc are values before strong initialization, -! xhatt, xhatp and dirxt, dirxp contain temps and psfc after strong initialization. -! If strong initialization is turned off, then xhatt, etc are equal to the corresponding -! fields in xhat, dirx. -! xhatuv, xhat_t and dirxuv, dirx_t are all after -! strong initialization if it is turned on. -! 2. Notice that now (2010-05-13) stp routines handle non-essential variables -! internally; also, when pointers non-existent, stp routines simply return. -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: i_kind,r_kind,r_quad - use stptmod, only: stpt - use stpwmod, only: stpw - use stppsmod, only: stpps - use stppwmod, only: stppw - use stpqmod, only: stpq - use stpradmod, only: stprad - use stpgpsmod, only: stpgps - use stprwmod, only: stprw - use stpspdmod, only: stpspd - use stpsstmod, only: stpsst - use stptcpmod, only: stptcp - use stpdwmod, only: stpdw - use stppcpmod, only: stppcp - use stpozmod, only: stpozlay => stpozlay_ - use stpozmod, only: stpozlev => stpozlev_ - use stpcomod, only: stpco - use stppm2_5mod, only: stppm2_5 - use stppm10mod, only: stppm10 - use stpaodmod, only: stpaod - use stpgustmod, only: stpgust - use stpvismod, only: stpvis - use stppblhmod, only: stppblh - use stpwspd10mmod, only: stpwspd10m - use stptd2mmod, only: stptd2m - use stpmxtmmod, only: stpmxtm - use stpmitmmod, only: stpmitm - use stppmslmod, only: stppmsl - use stphowvmod, only: stphowv - use stptcamtmod, only: stptcamt - use stplcbasmod, only: stplcbas - use stpcldchmod, only: stpcldch - use stpuwnd10mmod, only: stpuwnd10m - use stpvwnd10mmod, only: stpvwnd10m - use bias_predictors, only: predictors - use aircraftinfo, only: aircraft_t_bc_pof,aircraft_t_bc - use gsi_bundlemod, only: gsi_bundle - use control_vectors, only: cvars2d - use mpeu_util, only: getindex - - use m_obsHeadBundle, only: obsHeadBundle - use mpeu_util, only: perr,die - implicit none - -! Declare passed variables - type(obsHeadBundle),dimension(:),intent(in ) :: yobs - type(gsi_bundle) ,dimension(:),intent(in ) :: dval - type(predictors) ,intent(in ) :: dbias - type(gsi_bundle) ,dimension(:),intent(in ) :: xval - type(predictors) ,intent(in ) :: xbias - integer(i_kind) ,intent(in ) :: nstep,nobs_bins - real(r_kind),dimension(max(1,nstep)) ,intent(in ) :: sges - real(r_quad),dimension(4,nobs_type,nobs_bins) ,intent(inout) :: pbcjo - -! Declare local variables - - integer(i_kind) :: ll,mm,ib -!************************************************************************************ - -!$omp parallel do schedule(dynamic,1) private(ll,mm,ib) - do mm=1,stpcnt - ll=ll_jo(mm) - ib=ib_jo(mm) - select case(ll) -! penalty, b, and c for radiances - case(i_rad_ob_type) - call stprad(yobs(ib)%rad,dval(ib),xval(ib),dbias%predr,xbias%predr,& - pbcjo(1,i_rad_ob_type,ib),sges,nstep) - -! penalty, b, and c for temperature - case(i_t_ob_type) - if (.not. (aircraft_t_bc_pof .or. aircraft_t_bc)) then - call stpt(yobs(ib)%t,dval(ib),xval(ib),pbcjo(1,i_t_ob_type,ib),sges,nstep) - else - call stpt(yobs(ib)%t,dval(ib),xval(ib),pbcjo(1,i_t_ob_type,ib),sges,nstep, & - dbias%predt,xbias%predt) - end if - -! penalty, b, and c for winds - case(i_w_ob_type) - call stpw(yobs(ib)%w,dval(ib),xval(ib),pbcjo(1,i_w_ob_type,ib),sges,nstep) - -! penalty, b, and c for precipitable water - case(i_pw_ob_type) - call stppw(yobs(ib)%pw,dval(ib),xval(ib),pbcjo(1,i_pw_ob_type,ib),sges,nstep) - -! penalty, b, and c for ozone - case(i_colvk_ob_type) - call stpco(yobs(ib)%colvk,dval(ib),xval(ib),pbcjo(1,i_colvk_ob_type,ib),sges,nstep) - -! penalty, b, and c for ozone - case(i_pm2_5_ob_type) - call stppm2_5(yobs(ib)%pm2_5,dval(ib),xval(ib),pbcjo(1,i_pm2_5_ob_type,ib),sges,nstep) - -! penalty, b, and c for wind lidar - case(i_dw_ob_type) - call stpdw(yobs(ib)%dw,dval(ib),xval(ib),pbcjo(1,i_dw_ob_type,ib),sges,nstep) - -! penalty, b, and c for radar - case(i_rw_ob_type) - call stprw(yobs(ib)%rw,dval(ib),xval(ib),pbcjo(1,i_rw_ob_type,ib),sges,nstep) - -! penalty, b, and c for moisture - case(i_q_ob_type) - call stpq(yobs(ib)%q,dval(ib),xval(ib),pbcjo(1,i_q_ob_type,ib),sges,nstep) - -! penalty, b, and c for ozone:oz - case(i_oz_ob_type) - call stpozlay(yobs(ib)%oz ,dval(ib),xval(ib),pbcjo(1, i_oz_ob_type,ib),sges,nstep) - -! penalty, b, and c for ozone:o3l - case(i_o3l_ob_type) - call stpozlev(yobs(ib)%o3l,dval(ib),xval(ib),pbcjo(1,i_o3l_ob_type,ib),sges,nstep) - -! penalty, b, and c for GPS local observation - case(i_gps_ob_type) - call stpgps(yobs(ib)%gps,dval(ib),xval(ib),pbcjo(1,i_gps_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional sst - case(i_sst_ob_type) - call stpsst(yobs(ib)%sst,dval(ib),xval(ib),pbcjo(1,i_sst_ob_type,ib),sges,nstep) - -! penalty, b, and c for wind speed - case(i_spd_ob_type) - call stpspd(yobs(ib)%spd,dval(ib),xval(ib),pbcjo(1,i_spd_ob_type,ib),sges,nstep) - -! penalty, b, and c for precipitation - case(i_pcp_ob_type) - call stppcp(yobs(ib)%pcp,dval(ib),xval(ib),pbcjo(1,i_pcp_ob_type,ib),sges,nstep) - -! penalty, b, and c for surface pressure - case(i_ps_ob_type) - call stpps(yobs(ib)%ps,dval(ib),xval(ib),pbcjo(1,i_ps_ob_type,ib),sges,nstep) - -! penalty, b, and c for MSLP TC obs - case(i_tcp_ob_type) - call stptcp(yobs(ib)%tcp,dval(ib),xval(ib),pbcjo(1,i_tcp_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional gust - case(i_gust_ob_type) - if (getindex(cvars2d,'gust')>0) & - call stpgust(yobs(ib)%gust,dval(ib),xval(ib),pbcjo(1,i_gust_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional vis - case(i_vis_ob_type) - if (getindex(cvars2d,'vis')>0) & - call stpvis(yobs(ib)%vis,dval(ib),xval(ib),pbcjo(1,i_vis_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional pblh - case(i_pblh_ob_type) - if (getindex(cvars2d,'pblh')>0) & - call stppblh(yobs(ib)%pblh,dval(ib),xval(ib),pbcjo(1,i_pblh_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional wspd10m - case(i_wspd10m_ob_type) - if (getindex(cvars2d,'wspd10m')>0) & - call stpwspd10m(yobs(ib)%wspd10m,dval(ib),xval(ib),pbcjo(1,i_wspd10m_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional td2m - case(i_td2m_ob_type) - if (getindex(cvars2d,'td2m')>0) & - call stptd2m(yobs(ib)%td2m,dval(ib),xval(ib),pbcjo(1,i_td2m_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional mxtm - case(i_mxtm_ob_type) - if (getindex(cvars2d,'mxtm')>0) & - call stpmxtm(yobs(ib)%mxtm,dval(ib),xval(ib),pbcjo(1,i_mxtm_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional mitm - case(i_mitm_ob_type) - if (getindex(cvars2d,'mitm')>0) & - call stpmitm(yobs(ib)%mitm,dval(ib),xval(ib),pbcjo(1,i_mitm_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional pmsl - case(i_pmsl_ob_type) - if (getindex(cvars2d,'pmsl')>0) & - call stppmsl(yobs(ib)%pmsl,dval(ib),xval(ib),pbcjo(1,i_pmsl_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional howv - case(i_howv_ob_type) - if (getindex(cvars2d,'howv')>0) & - call stphowv(yobs(ib)%howv,dval(ib),xval(ib),pbcjo(1,i_howv_ob_type,ib),sges,nstep) - -! penalty, b, and c for total cloud amount - case(i_tcamt_ob_type) - if (getindex(cvars2d,'tcamt')>0) & - call stptcamt(yobs(ib)%tcamt,dval(ib),xval(ib),pbcjo(1,i_tcamt_ob_type,ib),sges,nstep) - -! penalty, b, and c for cloud base of lowest cloud - case(i_lcbas_ob_type) - if (getindex(cvars2d,'lcbas')>0) & - call stplcbas(yobs(ib)%lcbas,dval(ib),xval(ib),pbcjo(1,i_lcbas_ob_type,ib),sges,nstep) - -! penalty, b, and c for aod - case(i_aero_ob_type) - call stpaod(yobs(ib)%aero,dval(ib),xval(ib),pbcjo(1,i_aero_ob_type,ib),sges,nstep) - -! penalty, b, and c for pm10 - case(i_pm10_ob_type) - call stppm10(yobs(ib)%pm10,dval(ib),xval(ib),pbcjo(1,i_pm10_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional cldch - case(i_cldch_ob_type) - if (getindex(cvars2d,'cldch')>0) & - call stpcldch(yobs(ib)%cldch,dval(ib),xval(ib),pbcjo(1,i_cldch_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional uwnd10m - case(i_uwnd10m_ob_type) - if (getindex(cvars2d,'uwnd10m')>0) & - call stpuwnd10m(yobs(ib)%uwnd10m,dval(ib),xval(ib),pbcjo(1,i_uwnd10m_ob_type,ib),sges,nstep) - -! penalty, b, and c for conventional vwnd10m - case(i_vwnd10m_ob_type) - if (getindex(cvars2d,'vwnd10m')>0) & - call stpvwnd10m(yobs(ib)%vwnd10m,dval(ib),xval(ib),pbcjo(1,i_vwnd10m_ob_type,ib),sges,nstep) - case default - call perr('stpjo','unexpected thread, ll_jo(mm) =',ll) - call perr('stpjo',' ib_jo(mm) =',ib) - call perr('stpjo',' mm =',mm) - call perr('stpjo',' stpcnt =',stpcnt) - call die('stpjo') - end select - end do ! mm=.. - - return -end subroutine stpjo - -subroutine stpjo_setup(yobs) - -!$$$ subprogram documentation block -! . . . . -! subprogram: stpjo_setup setup loops for stpjo -! prgmmr: derber org: np23 date: 2003-12-18 -! -! abstract: setup parallel loops for stpjo -! -! program history log: -! 2015-01-18 derber,j. -! 2016-08-26 guo, j. - patched with ".or.associated(yobs%o3l)" checking at -! the checking of "associated(yobs%oz)", as a minimum -! bug fix. -! -! input argument list: -! yobs -! nobs_bins - number of obs bins -! -! output argument list: -! -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: i_kind,r_kind,r_quad - use gsi_bundlemod, only: gsi_bundle - use m_obsHeadBundle, only: obsHeadBundle - implicit none - -! Declare passed variables - type(obsHeadBundle),dimension(:),intent(in ) :: yobs - -! Declare local variables - - integer(i_kind) ll,ib -!************************************************************************************ - call init_(size(yobs)) - stpcnt = 0 - do ll = 1, nobs_type - do ib = 1,size(yobs) - - select case(ll) - case(i_rad_ob_type) -! penalty, b, and c for radiances - if(associated(yobs(ib)%rad)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_rad_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_t_ob_type) -! penalty, b, and c for temperature - if(associated(yobs(ib)%t)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_t_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_w_ob_type) -! penalty, b, and c for winds - if(associated(yobs(ib)%w)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_w_ob_type - ib_jo(stpcnt) = ib - end if - case(i_pw_ob_type) -! penalty, b, and c for precipitable water - if(associated(yobs(ib)%pw)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_pw_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_colvk_ob_type) -! penalty, b, and c for ozone - if(associated(yobs(ib)%colvk)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_colvk_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_pm2_5_ob_type) -! penalty, b, and c for pm2_5 - if(associated(yobs(ib)%pm2_5)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_pm2_5_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_dw_ob_type) -! penalty, b, and c for wind lidar - if(associated(yobs(ib)%dw)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_dw_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_rw_ob_type) -! penalty, b, and c for radar - if(associated(yobs(ib)%rw)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_rw_ob_type - ib_jo(stpcnt) = ib - end if - case(i_q_ob_type) -! penalty, b, and c for moisture - if(associated(yobs(ib)%q)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_q_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_oz_ob_type) -! penalty, b, and c for ozone - if(associated(yobs(ib)%oz)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_oz_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_o3l_ob_type) -! penalty, b, and c for ozone - if(associated(yobs(ib)%o3l)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_o3l_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_gps_ob_type) -! penalty, b, and c for GPS local observation - if(associated(yobs(ib)%gps)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_gps_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_sst_ob_type) -! penalty, b, and c for conventional sst - if(associated(yobs(ib)%sst)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_sst_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_spd_ob_type) -! penalty, b, and c for wind speed - if(associated(yobs(ib)%spd)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_spd_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_pcp_ob_type) -! penalty, b, and c for precipitation - if(associated(yobs(ib)%pcp)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_pcp_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_ps_ob_type) -! penalty, b, and c for surface pressure - if(associated(yobs(ib)%ps)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_ps_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_tcp_ob_type) -! penalty, b, and c for MSLP TC obs - if(associated(yobs(ib)%tcp)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_tcp_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_gust_ob_type) -! penalty, b, and c for conventional gust - if(associated(yobs(ib)%gust)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_gust_ob_type - ib_jo(stpcnt) = ib - end if - case(i_vis_ob_type) -! penalty, b, and c for conventional vis - if(associated(yobs(ib)%vis)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_vis_ob_type - ib_jo(stpcnt) = ib - end if - case(i_pblh_ob_type) -! penalty, b, and c for conventional pblh - if(associated(yobs(ib)%pblh)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_pblh_ob_type - ib_jo(stpcnt) = ib - end if - - case(i_wspd10m_ob_type) -! penalty, b, and c for conventional wspd10m - if(associated(yobs(ib)%wspd10m)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_wspd10m_ob_type - ib_jo(stpcnt) = ib - end if - case(i_td2m_ob_type) -! penalty, b, and c for conventional td2m - if(associated(yobs(ib)%td2m)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_td2m_ob_type - ib_jo(stpcnt) = ib - end if - case(i_mxtm_ob_type) -! penalty, b, and c for conventional mxtm - if(associated(yobs(ib)%mxtm)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_mxtm_ob_type - ib_jo(stpcnt) = ib - end if - case(i_mitm_ob_type) -! penalty, b, and c for conventional mitm - if(associated(yobs(ib)%mitm)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_mitm_ob_type - ib_jo(stpcnt) = ib - end if - case(i_pmsl_ob_type) -! penalty, b, and c for conventional pmsl - if(associated(yobs(ib)%pmsl)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_pmsl_ob_type - ib_jo(stpcnt) = ib - end if - case(i_howv_ob_type) -! penalty, b, and c for conventional howv - if(associated(yobs(ib)%howv)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_howv_ob_type - ib_jo(stpcnt) = ib - end if - case(i_tcamt_ob_type) -! penalty, b, and c for conventional tcamt - if(associated(yobs(ib)%tcamt)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_tcamt_ob_type - ib_jo(stpcnt) = ib - end if - case(i_lcbas_ob_type) -! penalty, b, and c for conventional lcbas - if(associated(yobs(ib)%lcbas)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_lcbas_ob_type - ib_jo(stpcnt) = ib - end if - case(i_aero_ob_type) -! penalty, b, and c for aod - if(associated(yobs(ib)%aero)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_aero_ob_type - ib_jo(stpcnt) = ib - end if - case(i_pm10_ob_type) -! penalty, b, and c for pm10 - if(associated(yobs(ib)%pm10)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_pm10_ob_type - ib_jo(stpcnt) = ib - end if - case(i_cldch_ob_type) -! penalty, b, and c for conventional cldch - if(associated(yobs(ib)%cldch)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_cldch_ob_type - ib_jo(stpcnt) = ib - end if - case(i_uwnd10m_ob_type) -! penalty, b, and c for conventional uwnd10m - if(associated(yobs(ib)%uwnd10m)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_uwnd10m_ob_type - ib_jo(stpcnt) = ib - end if - case(i_vwnd10m_ob_type) -! penalty, b, and c for conventional vwnd10m - if(associated(yobs(ib)%vwnd10m)) then - stpcnt = stpcnt +1 - ll_jo(stpcnt) = i_vwnd10m_ob_type - ib_jo(stpcnt) = ib - end if - end select - end do ! ib - end do ! ll (i.e. i_ob_type) -! write(6,*) 'stpjo - stpcnt = ',stpcnt,size(yobs)*nobs_type - - return -end subroutine stpjo_setup - -end module stpjomod diff --git a/src/stub_ensmod.f90 b/src/stub_ensmod.f90 deleted file mode 100644 index ae3afddf5..000000000 --- a/src/stub_ensmod.f90 +++ /dev/null @@ -1,54 +0,0 @@ -!---------------------------------------------------------------------------- -!BOP -! -! !MODULE: GSI_EnsCouplerMod --- -! -! !DESCRIPTION: This stub provides the default interfaces to read an -! ensemble in GSI. -! -! !REVISION HISTORY: -! -! 19Sep2011 Todling - Initial code -! 01Dec2011 Todling - Add put_gsi_ens to allow write out of internal members -! 30Nov2014 Todling - Update interface to get (bundle passed in) -! -!EOP -!------------------------------------------------------------------------- - -subroutine non_gaussian_ens_grid_(elats,elons) - use kinds, only: r_kind - use hybrid_ensemble_parameters, only: sp_ens - implicit none - ! Declare passed variables - real(r_kind), intent(out) :: elats(size(sp_ens%rlats)),elons(size(sp_ens%rlons)) - elats=sp_ens%rlats - elons=sp_ens%rlons -end subroutine non_gaussian_ens_grid_ - -subroutine get_user_ens_(grd,member,ntindex,atm_bundle,iret) - use kinds, only: i_kind - use general_sub2grid_mod, only: sub2grid_info - use gsi_bundlemod, only: gsi_bundle - implicit none - ! Declare passed variables - type(sub2grid_info), intent(in ) :: grd - integer(i_kind), intent(in ) :: member - integer(i_kind), intent(in ) :: ntindex - type(gsi_bundle), intent(inout) :: atm_bundle - integer(i_kind), intent( out) :: iret - iret = 0 -end subroutine get_user_ens_ - -subroutine put_gsi_ens_(grd,member,ntindex,atm_bundle,iret) - use kinds, only: i_kind - use gsi_bundlemod, only: gsi_bundle - use general_sub2grid_mod, only: sub2grid_info - implicit none - ! Declare passed variables - type(sub2grid_info), intent(in ) :: grd - integer(i_kind), intent(in ) :: member - integer(i_kind), intent(in ) :: ntindex - type(gsi_bundle), intent(inout) :: atm_bundle - integer(i_kind), intent( out) :: iret - iret = 0 -end subroutine put_gsi_ens_ diff --git a/src/stub_gfs_ensmod.f90 b/src/stub_gfs_ensmod.f90 deleted file mode 100644 index dc3f25749..000000000 --- a/src/stub_gfs_ensmod.f90 +++ /dev/null @@ -1,69 +0,0 @@ -!---------------------------------------------------------------------------- -!BOP -! -! !MODULE: GSI_EnsCouplerMod --- -! -! !DESCRIPTION: This stub provides the default interfaces to read an -! ensemble in GSI. -! -! !REVISION HISTORY: -! -! 19Sep2011 Todling - Initial code -! 01Dec2011 Todling - Add put_gsi_ens to allow write out of internal members -! 30Nov2014 Todling - Update interface to get (bundle passed in) -! -!EOP -!------------------------------------------------------------------------- - -module get_gfs_ensmod_mod -use abstract_get_gfs_ensmod_mod - type, extends(abstract_get_gfs_ensmod_class) :: get_gfs_ensmod_class - contains - procedure, pass(this) :: get_user_ens_ => get_user_ens_dummy - procedure, pass(this) :: put_gsi_ens_ => put_gsi_ens_dummy - procedure, pass(this) :: non_gaussian_ens_grid_ => non_gaussian_ens_grid_dummy - end type get_gfs_ensmod_class -contains - - subroutine get_user_ens_dummy(this,grd,member,ntindex,atm_bundle,iret) - use kinds, only: i_kind - use general_sub2grid_mod, only: sub2grid_info - use gsi_bundlemod, only: gsi_bundle - implicit none - ! Declare passed variables - class(get_gfs_ensmod_class), intent(inout) :: this - type(sub2grid_info), intent(in ) :: grd - integer(i_kind), intent(in ) :: member - integer(i_kind), intent(in ) :: ntindex - type(gsi_bundle), intent(inout) :: atm_bundle - integer(i_kind), intent( out) :: iret - iret = 0 - end subroutine get_user_ens_dummy - - subroutine put_gsi_ens_dummy(this,grd,member,ntindex,atm_bundle,iret) - use kinds, only: i_kind - use gsi_bundlemod, only: gsi_bundle - use general_sub2grid_mod, only: sub2grid_info - implicit none - ! Declare passed variables - class(get_gfs_ensmod_class), intent(inout) :: this - type(sub2grid_info), intent(in ) :: grd - integer(i_kind), intent(in ) :: member - integer(i_kind), intent(in ) :: ntindex - type(gsi_bundle), intent(inout) :: atm_bundle - integer(i_kind), intent( out) :: iret - iret = 0 - end subroutine put_gsi_ens_dummy - - subroutine non_gaussian_ens_grid_dummy(this,elats,elons) - use kinds, only: r_kind - use hybrid_ensemble_parameters, only: sp_ens - implicit none - ! Declare passed variables - class(get_gfs_ensmod_class), intent(inout) :: this - real(r_kind), intent(out) :: elats(size(sp_ens%rlats)),elons(size(sp_ens%rlons)) - elats=sp_ens%rlats - elons=sp_ens%rlons - end subroutine non_gaussian_ens_grid_dummy - -end module get_gfs_ensmod_mod diff --git a/src/stub_set_crtm_aerosol.f90 b/src/stub_set_crtm_aerosol.f90 deleted file mode 100644 index 2cddd8593..000000000 --- a/src/stub_set_crtm_aerosol.f90 +++ /dev/null @@ -1,178 +0,0 @@ -subroutine Set_CRTM_Aerosol_ ( km, na, na_crtm, aero_name, aero_conc, rh, aerosol) - -!$$$ subprogram documentation block -! . . . . -! subprogram: Set_CRTM_Aerosol_ -! prgmmr: hclin org: ncar/mmm date: 2011-09-20 -! -! abstract: Set the CRTM Aerosol object given GOCART aerosol properties. -! -! -! program history log: -! 2011-02-23 da Silva - Initial version, FORTRAN-77 interface for GSI. -! 2011-08-01 Lueken - Replaced F90 with f90 (no machine logic) -! 2011-09-20 HCLin - Coded based on the WRFCHEM implementation of GOCART. -! 2013-11-17 Todling - Brought HCLin implementation into stub - it live -! outside GSI, but to not break DTC usage it's placed -! here temporarily. -! -! input argument list: -! km : number of CRTM levels -! na : number of aerosols -! na_crtm : number of aerosols seen by CRTM -! aero_name : GOCART aerosol names -! aero_conc : aerosol concentration (Kg/m2) -! rh : relative humdity [0,1] -! aerosol : CRTM Aerosol object -! -! output argument list: -! aero_conc : aerosol concentration (Kg/m2) -! aerosol : CRTM Aerosol object -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - -! USES: - - use kinds, only: i_kind,r_kind - use constants, only: tiny_r_kind - use CRTM_Aerosol_Define, only: CRTM_Aerosol_type - use mpeu_util, only: getindex - use crtm_module, only: SULFATE_AEROSOL,BLACK_CARBON_AEROSOL,ORGANIC_CARBON_AEROSOL,& - DUST_AEROSOL,SEASALT_SSAM_AEROSOL,SEASALT_SSCM1_AEROSOL,SEASALT_SSCM2_AEROSOL,SEASALT_SSCM3_AEROSOL - - implicit none - -! !ARGUMENTS: - - integer(i_kind) , intent(in) :: km ! number of levels - integer(i_kind) , intent(in) :: na ! number of aerosols - integer(i_kind) , intent(in) :: na_crtm ! number of aerosols seen by CRTM - character(len=*), intent(in) :: aero_name(na) ! [na] GOCART aerosol names - real(r_kind), intent(inout) :: aero_conc(km,na) ! [km,na] aerosol concentration (Kg/m2) - real(r_kind), intent(in) :: rh(km) ! [km] relative humdity [0,1] - - type(CRTM_Aerosol_type), intent(inout) :: aerosol(na_crtm)! [na] CRTM Aerosol object - - integer(i_kind) :: i, k - integer(i_kind) :: indx_p25, indx_dust1, indx_dust2, indx_dust3, indx_dust4, indx_dust5 - integer(i_kind) :: indx_bc1, indx_oc1 - - indx_bc1=-1; indx_oc1=-1; indx_dust1=-1; indx_dust2=-1 - indx_dust3=-1; indx_dust4=-1; indx_dust5=-1; indx_p25=-1 - - indx_p25 = getindex(aero_name,'p25') - indx_dust1 = getindex(aero_name,'dust1') - indx_dust2 = getindex(aero_name,'dust2') - indx_dust3 = getindex(aero_name,'dust3') - indx_dust4 = getindex(aero_name,'dust4') - indx_dust5 = getindex(aero_name,'dust5') - indx_bc1 = getindex(aero_name,'bc1') - indx_oc1 = getindex(aero_name,'oc1') - - do i = 1, na - - if ( trim(aero_name(i)) == 'p25' ) cycle - - ! assign aerosol type - select case ( trim(aero_name(i)) ) - case ('sulf') - aerosol(i)%type = SULFATE_AEROSOL - case ('bc1','bc2') - aerosol(i)%type = BLACK_CARBON_AEROSOL - case ('oc1','oc2') - aerosol(i)%type = ORGANIC_CARBON_AEROSOL - case ('dust1','dust2','dust3','dust4','dust5') - aerosol(i)%type = DUST_AEROSOL - case ('seas1') - aerosol(i)%type = SEASALT_SSAM_AEROSOL - case ('seas2') - aerosol(i)%type = SEASALT_SSCM1_AEROSOL - case ('seas3') - aerosol(i)%type = SEASALT_SSCM2_AEROSOL - case ('seas4') - aerosol(i)%type = SEASALT_SSCM3_AEROSOL - end select - - if ( indx_p25 > 0 ) then - ! partition p25 to dust1 and dust2 - if ( i == indx_dust1 ) then - aero_conc(:,i) = aero_conc(:,i)+ 0.78_r_kind*aero_conc(:,indx_p25) - endif - if ( i == indx_dust2 ) then - aero_conc(:,i) = aero_conc(:,i)+ 0.22_r_kind*aero_conc(:,indx_p25) - endif - endif - - ! crtm aerosol structure - do k = 1, km - aerosol(i)%concentration(k) = max(tiny_r_kind, aero_conc(k,i)) - ! calculate effective radius - aerosol(i)%effective_radius(k) & - = GOCART_Aerosol_size(i, aerosol(i)%type, rh(k)) - ! 5 dust bins - aerosol(indx_dust1)%effective_radius(k) = 0.55_r_kind - aerosol(indx_dust2)%effective_radius(k) = 1.4_r_kind - aerosol(indx_dust3)%effective_radius(k) = 2.4_r_kind - aerosol(indx_dust4)%effective_radius(k) = 4.5_r_kind - aerosol(indx_dust5)%effective_radius(k) = 8.0_r_kind - enddo - - enddo ! na - - contains - - function GOCART_Aerosol_size( kk, itype, & ! Input - eh ) & ! Input in 0-1 - result( R_eff ) ! in micrometer - use crtm_aerosolcoeff, only: AeroC - implicit none -! -! modified from a function provided by Quanhua Liu -! - integer(i_kind) ,intent(in) :: kk, itype - real(r_kind) ,intent(in) :: eh - - integer(i_kind) :: j1,j2,k - real(r_kind) :: h1 - real(r_kind) :: R_eff - - if ( itype==DUST_AEROSOL ) then - return - else if ( itype==BLACK_CARBON_AEROSOL .and. kk==indx_bc1 ) then - R_eff = AeroC%Reff(1,itype ) - return - else if ( itype==ORGANIC_CARBON_AEROSOL .and. kk==indx_oc1 ) then - R_eff = AeroC%Reff(1,itype ) - return - endif - - j2 = 0 - if ( eh < AeroC%RH(1) ) then - j1 = 1 - else if ( eh > AeroC%RH(AeroC%n_RH) ) then - j1 = AeroC%n_RH - else - do k = 1, AeroC%n_RH-1 - if ( eh <= AeroC%RH(k+1) .and. eh > AeroC%RH(k) ) then - j1 = k - j2 = k+1 - h1 = (eh-AeroC%RH(k))/(AeroC%RH(k+1)-AeroC%RH(k)) - exit - endif - enddo - endif - - if ( j2 == 0 ) then - R_eff = AeroC%Reff(j1,itype ) - else - R_eff = (1.0_r_kind-h1)*AeroC%Reff(j1,itype ) + h1*AeroC%Reff(j2,itype ) - endif - - return - end function GOCART_Aerosol_size - -end subroutine Set_CRTM_Aerosol_ diff --git a/src/stub_timermod.f90 b/src/stub_timermod.f90 deleted file mode 100644 index 738c04e40..000000000 --- a/src/stub_timermod.f90 +++ /dev/null @@ -1,107 +0,0 @@ -!$$$ module documentation block -! . . . . -! module: stub_timermod -! prgmmr: todling org: gmao date: 2007-10-01 -! -! abstract: module providing interface to timing procedures -! -! program history log: -! 2007-10-01 todling -! 2009-02-26 todling - if-def from GMAO_FVGSI to GEOS_PERT -! 2009-08-13 lueken - update documentation -! 2010-06-16 guo - separated stub implementation with implicit interfaces -! from module implementation with explicit interfaces. -! 2011-08-01 lueken - replaced F90 with f90 (no machine logic) -! -! subroutines included: -! sub timer_init_ -! sub timer_final_ -! sub timer_pri_ -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -subroutine timer_init_ (str) -!$$$ subprogram documentation block -! . . . . -! subprogram: timer_init_ initialize procedure timing -! -! prgmmr: todling org: gmao date: 2007-10-01 -! -! abstract: initializes timer -! -! program history log: -! 2007-10-01 todling -! -! input argument list: -! str - string designation for process to be timed -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -implicit none -character(len=*),intent(in ) :: str -end subroutine timer_init_ - -subroutine timer_final_ (str) -!$$$ subprogram documentation block -! . . . . -! subprogram: timer_final_ finalize procedure timing -! -! prgmmr: todling org: gmao date: 2007-10-01 -! -! abstract: finalize timer -! -! program history log: -! 2007-10-01 todling -! -! input argument list: -! str - string designation for process timed -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -implicit none -character(len=*),intent(in ) :: str -end subroutine timer_final_ - -subroutine timer_pri_ (lu) -!$$$ subprogram documentation block -! . . . . -! subprogram: timer_pri_ summarizes timing results -! -! prgmmr: todling org: gmao date: 2007-10-01 -! -! abstract: summary of timing results -! -! program history log: -! 2007-10-01 todling -! -! input argument list: -! str - string designation for process timed -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -use kinds, only : i_kind -implicit none -integer(i_kind),intent(in ) :: lu -end subroutine timer_pri_ diff --git a/src/timermod.f90 b/src/timermod.f90 deleted file mode 100644 index 359c05f58..000000000 --- a/src/timermod.f90 +++ /dev/null @@ -1,57 +0,0 @@ -module timermod - -!$$$ module documentation block -! . . . . -! module: timermod -! prgmmr: todling org: gmao date: 2007-10-01 -! -! abstract: module providing interface to timing procedures -! -! program history log: -! 2007-10-01 todling -! 2009-02-26 todling - if-def from GMAO_FVGSI to GEOS_PERT -! 2009-08-13 lueken - update documentation -! 2011-08-01 lueken - replaced F90 with f90 (no machine logic) -! -! subroutines included: -! sub timer_ini -! sub timer_fnl -! sub timer_pri -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - -implicit none - -private - -public timer_ini -public timer_fnl -public timer_pri - -interface timer_ini - subroutine timer_init_ (str) - implicit none - character(len=*),intent(in ) :: str - end subroutine timer_init_ -end interface - -interface timer_fnl - subroutine timer_final_ (str) - implicit none - character(len=*),intent(in ) :: str - end subroutine timer_final_ -end interface - -interface timer_pri - subroutine timer_pri_ (lu) - use kinds, only : i_kind - implicit none - integer(i_kind),intent(in ) :: lu - end subroutine timer_pri_ -end interface - -end module timermod diff --git a/ush/EnKF/current.enkfparms b/ush/EnKF/current.enkfparms index be53e08e9..160d38dc2 100755 --- a/ush/EnKF/current.enkfparms +++ b/ush/EnKF/current.enkfparms @@ -32,7 +32,7 @@ setenv enkfscripts "${basedir}/scripts/ncep" setenv enkfexec "${basedir}/src/" # name of enkf executable. -setenv enkfbin "${enkfexec}/global_enkf_gfs" +setenv enkfbin "${enkfexec}/global_enkf.x" # Set archive directories setenv archdiskdir ${datapath}/archive @@ -136,7 +136,7 @@ setenv FIXGLOBAL /nwprod/fix setenv FIXGSI /global/save/wx20kd/ensda/ersl/fixgsi setenv EXECGLOBAL /global/save/wx20kd/ensda/ersl/bin setenv SIGLEVEL ${FIXGLOBAL}/global_hyblev.l64.txt -setenv GSIEXEC /global/save/wx20kd/gsi/hybrid/src/global_gsi +setenv GSIEXEC /global/save/wx20kd/gsi/hybrid/src/global_gsi.x setenv CHGRESEXEC ${EXECGLOBAL}/global_chgres_thread_moorthi setenv USHGLOBAL $EXECGLOBAL setenv CHGRESSH ${enkfscripts}/global_chgres.sh diff --git a/ush/EnKF/enkfa5.parms b/ush/EnKF/enkfa5.parms index ad919e169..f6a94cfcc 100755 --- a/ush/EnKF/enkfa5.parms +++ b/ush/EnKF/enkfa5.parms @@ -32,7 +32,7 @@ setenv enkfscripts "${basedir}/scripts_ncep" setenv enkfexec "${basedir}/src/" # name of enkf executable. -setenv enkfbin "${enkfexec}/global_enkf_gfs" +setenv enkfbin "${enkfexec}/global_enkf.x" # Set archive directories setenv archdiskdir ${datapath}/archive @@ -136,7 +136,7 @@ setenv FIXGLOBAL /nwprod/fix setenv FIXGSI /global/save/wx20kd/ensda/ersl/fixgsi setenv EXECGLOBAL /global/save/wx20kd/ensda/ersl/bin setenv SIGLEVEL ${FIXGLOBAL}/global_hyblev.l64.txt -setenv GSIEXEC /global/save/wx20kd/gsi/hybrid/src/global_gsi +setenv GSIEXEC /global/save/wx20kd/gsi/hybrid/src/global_gsi.x setenv CHGRESEXEC ${EXECGLOBAL}/global_chgres_thread_moorthi setenv USHGLOBAL $EXECGLOBAL setenv CHGRESSH ${enkfscripts}/global_chgres.sh diff --git a/ush/EnKF/run_enkfupdate_convonly.sh b/ush/EnKF/run_enkfupdate_convonly.sh index d6e0db43b..b5b3ba139 100755 --- a/ush/EnKF/run_enkfupdate_convonly.sh +++ b/ush/EnKF/run_enkfupdate_convonly.sh @@ -61,7 +61,7 @@ exp=test_conv_prof_2thrds # Set path/file for enkf executable basedir=/global/save enkfpath=$basedir/wx20kd/enkf/work/src -enkfexec=$enkfpath/global_enkf_gfs +enkfexec=$enkfpath/global_enkf.x # directories for case dirges=/global/noscrub/wx20kd/CASES/$adate/ensges diff --git a/ush/EnKF/run_enkfupdate_testcase.sh b/ush/EnKF/run_enkfupdate_testcase.sh index 6c185eb95..040b6813f 100755 --- a/ush/EnKF/run_enkfupdate_testcase.sh +++ b/ush/EnKF/run_enkfupdate_testcase.sh @@ -61,7 +61,7 @@ exp=test # Set path/file for enkf executable basedir=/global/save enkfpath=$basedir/wx20kd/enkf/work/src -enkfexec=$enkfpath/global_enkf_gfs +enkfexec=$enkfpath/global_enkf.x # directories for case dirges=/global/noscrub/wx20kd/CASES/$adate/ensges diff --git a/ush/EnKF/run_gsi b/ush/EnKF/run_gsi index 60f05bebe..5b057185e 100755 --- a/ush/EnKF/run_gsi +++ b/ush/EnKF/run_gsi @@ -356,7 +356,7 @@ fi ###################### # For testing -JYZ ###################### -#export GSIEXEC=$EXECGLOBAL/global_gsi +#export GSIEXEC=$EXECGLOBAL/global_gsi.x #export ANGUPDATEXEC=$EXECGLOBAL/global_angupdate #export CHGRESEXEC=$EXECGLOBAL/global_chgres #export CHGRESSH=$USHGLOBAL/global_chgres.sh @@ -393,7 +393,7 @@ export NLAT=${NLAT:-$(($LATA+2))} export LEVS=${LEVS:-$($SIGHDR $SIGGES LEVS||echo 0)} export DELTIM=${DELTIM:-$((3600/($JCAP/20)))} export CYCLEXEC=${CYCLEXEC:-${EXECGLOBAL}/global_cycle$XC} -export GSIEXEC=${GSIEXEC:-${EXECGLOBAL}/global_gsi$XC} +export GSIEXEC=${GSIEXEC:-${EXECGLOBAL}/global_gsi.x} export ANGUPDATEXEC=${ANGUPDATEXEC:-${EXECGLOBAL}/global_angupdate$XC} ##export ANGUPDATEXEC=${ANGUPDATEXEC:-/nwprod/exec/global_angupdate} export CHGRESSH=${CHGRESSH:-${USHGLOBAL}/global_chgres.sh} diff --git a/ush/EnKF/runenkf_trunk.sh b/ush/EnKF/runenkf_trunk.sh index d03b7850b..92ffb77db 100755 --- a/ush/EnKF/runenkf_trunk.sh +++ b/ush/EnKF/runenkf_trunk.sh @@ -61,7 +61,7 @@ exp=test46trunk # Set path/file for enkf executable basedir=/global/save enkfpath=$basedir/wx23jd/trunk/src -enkfexec=$enkfpath/global_enkf_gfs +enkfexec=$enkfpath/global_enkf.x # directories for case dirges=/gpfs/t2c/global/noscrub/wx20kd/CASES/$adate/ensges diff --git a/ush/build.comgsi b/ush/build.comgsi new file mode 100755 index 000000000..a3bdc5ad4 --- /dev/null +++ b/ush/build.comgsi @@ -0,0 +1,77 @@ +#!/bin/sh +# common modules to compile GSI/EnKF: +# Jet: source /home/rtrr/PARM_EXEC/modulefiles/modulefile.jet.GSI_UPP_WRF +# Theia: source /home/rtrr/PARM_EXEC/modulefiles/modulefile.theia.GSI_UPP_WRF +# Cheyenne: source /glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF +# +# build commands: +# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON path_to_ProdGSI +# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_UTIL_COM=ON -DBUILD_ENKF_PREPROCESS_ARW=ON" +# make -j8 +# + +dir_root=$(pwd) + +source /etc/profile.d/modules.sh +if [[ "`grep -i "theia" /etc/hosts | head -n1`" != "" ]] ; then ###theia + modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.theia.GSI_UPP_WRF" +elif [[ "`grep -i "hera" /etc/hosts | head -n1`" != "" ]] ; then ###hera + modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.hera.GSI_UPP_WRF" +elif [[ -d /jetmon ]] ; then ### jet + modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.jet.GSI_UPP_WRF" +elif [[ -d /glade ]] ; then ### cheyenne + modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" +else + echo "unknown machine" + exit 9 +fi + +if [ ! -f $modulefile ]; then + echo "modulefiles $modulefile does not exist" + exit 10 +fi +source $modulefile + +## if NETCDF4 is set to 0 or 1, unset it +if [[ "$NETCDF4" == "1" ]] || [[ "$NETCDF4" == "0" ]]; then + unset NETCDF4 +fi + +set -x +rm -rf $dir_root/build +mkdir -p $dir_root/build +cd $dir_root/build +set +x + + +echo "compiled at the node:" >> output.log +hostname >> output.log +module list >> output.log +echo -e "\nThe branch name:" >> output.log +git branch | grep "*" >> output.log +echo -e "\nThe commit ID:" >> output.log +git log -1 | head -n1 >> output.log +echo -e "\ngit status:" >> output.log +git status >> output.log +echo -e "\nCompiling commands:" >> output.log +echo " cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON .." >> output.log +echo " make -j8" >> output.log +cat output.log + + +cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON .. 2>&1 | tee output.cmake +make -j 8 2>&1 | tee output.compile + +###aftermath +commitID=`git log -1 | head -n1 |cut -c8-15` +repoName=`git config --get remote.origin.url | cut -d: -f2` +datestamp=`date +%Y%m%d` +cd bin +ln -sf gsi.x gsi.x_${repoName}_${datestamp}_${commitID} +ln -sf enkf_wrf.x enkf_wrf.x_${repoName}_${datestamp}_${commitID} +ln -sf enspreproc.x enspreproc.x_${repoName}_${datestamp}_${commitID} +###mv $dir_root/build $dir_root/build_$commitID + +echo -e "\n\nAll build results are at ./build/ \n\n" + +exit diff --git a/ush/build_all.sh b/ush/build_all.sh deleted file mode 100755 index 87a546e4d..000000000 --- a/ush/build_all.sh +++ /dev/null @@ -1,61 +0,0 @@ -#!/bin/sh - -set -ex - -cd .. -pwd=$(pwd) - -target=$1 -dir_root=${2:-$pwd} - -BUILD_GSI=${BUILD_GSI:-"YES"} -BUILD_ENKF=${BUILD_ENKF:-"YES"} -BUILD_UTILS=${BUILD_UTILS:-"YES"} - -if [ $target = wcoss ]; then - . /usrx/local/Modules/3.2.10/init/sh - conf_target=nco -elif [ $target = cray -o $target = wcoss_c ]; then - . $MODULESHOME/init/sh - conf_target=nco -elif [ $target = theia ]; then - . /apps/lmod/lmod/init/sh - conf_target=theia -else - echo "unknown target = $target" - exit 9 -fi - -dir_modules=$dir_root/modulefiles -if [ ! -d $dir_modules ]; then - echo "modulefiles does not exist in $dir_modules" - exit 10 -fi -[ -d $dir_root/exec ] || mkdir -p $dir_root/exec - -# First build GSI -if [ $BUILD_GSI = "YES" -o $BUILD_ENKF = "YES" ]; then - - clean=YES - [[ $BUILD_ENKF = "YES" ]] && clean=NO - $dir_root/ush/build_gsi.sh $target $pwd $clean - -fi - -# Next build EnKF -if [ $BUILD_ENKF = "YES" ]; then - - clean=YES - $dir_root/ush/build_enkf.sh $target $pwd $clean - -fi - -# Next build EnKF utilities -if [ $BUILD_UTILS = "YES" ]; then - - clean=YES - $dir_root/ush/build_enkf_utils.sh $target $pwd $clean - -fi - -exit 0 diff --git a/ush/build_all_cmake.sh b/ush/build_all_cmake.sh index ab5889f4f..94f19eb16 100755 --- a/ush/build_all_cmake.sh +++ b/ush/build_all_cmake.sh @@ -5,18 +5,41 @@ set -ex cd .. pwd=$(pwd) -target=$1 +build_type=${1:-'PRODUCTION'} dir_root=${2:-$pwd} -if [ $target = wcoss ]; then +if [[ -d /dcom && -d /hwrf ]] ; then . /usrx/local/Modules/3.2.10/init/sh - conf_target=nco -elif [ $target = cray -o $target = wcoss_c ]; then + target=wcoss . $MODULESHOME/init/sh - conf_target=nco -elif [ $target = theia ]; then +elif [[ -d /cm ]] ; then + . $MODULESHOME/init/sh + target=wcoss_c +elif [[ -d /ioddev_dell ]]; then + . $MODULESHOME/init/sh + target=wcoss_d +elif [[ -d /scratch1 ]] ; then . /apps/lmod/lmod/init/sh - conf_target=theia + target=hera +elif [[ -d /carddata ]] ; then + . /opt/apps/lmod/3.1.9/init/sh + target=s4 +elif [[ -d /jetmon ]] ; then + . $MODULESHOME/init/sh + target=jet +elif [[ -d /glade ]] ; then + . $MODULESHOME/init/sh + target=cheyenne +elif [[ -d /sw/gaea ]] ; then + . /opt/cray/pe/modules/3.2.10.5/init/sh + target=gaea +elif [[ -d /discover ]] ; then +# . /opt/cray/pe/modules/3.2.10.5/init/sh + target=discover + build_type=0 + export SPACK_ROOT=/discover/nobackup/mapotts1/spack + export PATH=$PATH:$SPACK_ROOT/bin + . $SPACK_ROOT/share/spack/setup-env.sh else echo "unknown target = $target" exit 9 @@ -33,15 +56,31 @@ rm -rf $dir_root/build mkdir -p $dir_root/build cd $dir_root/build -module purge -if [ $target = wcoss -o $target = cray ]; then +if [ $target = wcoss_d ]; then + module purge + module use -a $dir_modules + module load modulefile.ProdGSI.$target +elif [ $target = wcoss -o $target = gaea ]; then + module purge module load $dir_modules/modulefile.ProdGSI.$target -else +elif [ $target = hera -o $target = cheyenne ]; then + module purge + source $dir_modules/modulefile.ProdGSI.$target +elif [ $target = wcoss_c ]; then + module purge + module load $dir_modules/modulefile.ProdGSI.$target +elif [ $target = discover ]; then + module load $dir_modules/modulefile.ProdGSI.$target +else + module purge source $dir_modules/modulefile.ProdGSI.$target fi -module list -cmake -DBUILD_UTIL=ON .. +if [ $build_type = PRODUCTION -o $build_type = DEBUG ] ; then + cmake -DBUILD_UTIL=ON -DMPI3FLAG=-DMPI3 -DMPI3=ON -DBUILD_NCDIAG_SERIAL=ON -DCMAKE_BUILD_TYPE=$build_type -DBUILD_CORELIBS=OFF -DENKF_MODE=WRF .. +else + cmake .. +fi make -j 8 diff --git a/ush/build_all_cmake_hwrf.sh b/ush/build_all_cmake_hwrf.sh new file mode 100755 index 000000000..48de0a0e9 --- /dev/null +++ b/ush/build_all_cmake_hwrf.sh @@ -0,0 +1,99 @@ +#!/bin/sh + +set -ex + +cd .. +pwd=$(pwd) + +build_type=${1:-'PRODUCTION'} +dir_root=${2:-$pwd} + +if [[ -d /dcom && -d /hwrf ]] ; then + . /usrx/local/Modules/3.2.10/init/sh + target=wcoss + . $MODULESHOME/init/sh +elif [[ -d /cm ]] ; then + . $MODULESHOME/init/sh + target=wcoss_c +elif [[ -d /ioddev_dell ]]; then + . $MODULESHOME/init/sh + target=wcoss_d +elif [[ -d /scratch1 ]] ; then + . /apps/lmod/lmod/init/sh + target=hera +elif [[ -d /carddata ]] ; then + . /opt/apps/lmod/3.1.9/init/sh + target=s4 +elif [[ -d /jetmon ]] ; then + . $MODULESHOME/init/sh + target=jet +elif [[ -d /glade ]] ; then + . $MODULESHOME/init/sh + target=cheyenne +elif [[ -d /sw/gaea ]] ; then + . /opt/cray/pe/modules/3.2.10.5/init/sh + target=gaea +elif [[ -d /discover ]] ; then +# . /opt/cray/pe/modules/3.2.10.5/init/sh + target=discover + build_type=0 + export SPACK_ROOT=/discover/nobackup/mapotts1/spack + export PATH=$PATH:$SPACK_ROOT/bin + . $SPACK_ROOT/share/spack/setup-env.sh +else + echo "unknown target = $target" + exit 9 +fi + +dir_modules=$dir_root/modulefiles +if [ ! -d $dir_modules ]; then + echo "modulefiles does not exist in $dir_modules" + exit 10 +fi +[ -d $dir_root/exec ] || mkdir -p $dir_root/exec + +rm -rf $dir_root/build +mkdir -p $dir_root/build +cd $dir_root/build + +if [ $target = wcoss_d ]; then + module purge + module use -a $dir_modules + module load modulefile.ProdGSI.$target +elif [ $target = wcoss -o $target = gaea ]; then + module purge + module load $dir_modules/modulefile.ProdGSI.$target +elif [ $target = hera -o $target = cheyenne ]; then + # commented out purge, since using modules already loaded + #by the HWRF build system. + # module purge + source $dir_modules/modulefile.ProdGSI_hwrf.$target + module list +elif [ $target = jet ]; then + # commented out purge, since using modules already loaded + # by the HWRF build system. + #module purge + source $dir_modules/modulefile.ProdGSI_hwrf.$target + module list +elif [ $target = wcoss_c ]; then + # commented out purge, since using modules already loaded + # by the HWRF build system. + #module purge + module load $dir_modules/modulefile.ProdGSI_hwrf.$target + module list +elif [ $target = discover ]; then + module load $dir_modules/modulefile.ProdGSI.$target +else + module purge + source $dir_modules/modulefile.ProdGSI.$target +fi + +if [ $build_type = PRODUCTION -o $build_type = DEBUG ] ; then + cmake -DBUILD_UTIL=ON -DMPI3FLAG=-DMPI3 -DMPI3=ON -DBUILD_NCDIAG_SERIAL=ON -DCMAKE_BUILD_TYPE=$build_type -DBUILD_CORELIBS=OFF -DENKF_MODE=WRF .. +else + cmake .. +fi + +make -j 8 + +exit diff --git a/ush/build_enkf.sh b/ush/build_enkf.sh deleted file mode 100755 index a14e57043..000000000 --- a/ush/build_enkf.sh +++ /dev/null @@ -1,57 +0,0 @@ -#!/bin/sh - -set -ex - -cd .. -pwd=$(pwd) - -target=${1:-cray} -dir_root=${2:-$pwd} -clean=${3:-"YES"} - -if [ $target = wcoss ]; then - . /usrx/local/Modules/3.2.10/init/sh - conf_target=nco -elif [ $target = cray -o $target = wcoss_c ]; then - . $MODULESHOME/init/sh - conf_target=nco -elif [ $target = theia ]; then - . /apps/lmod/lmod/init/sh - conf_target=theia -else - echo "unknown target = $target" - exit 9 -fi - -dir_modules=$dir_root/modulefiles -if [ ! -d $dir_modules ]; then - echo "modulefiles does not exist in $dir_modules" - exit 10 -fi -[ -d $dir_root/exec ] || mkdir -p $dir_root/exec - -module purge -if [ $target = wcoss -o $target = cray ]; then - module load $dir_modules/modulefile.gdas_enkf.$target -else - source $dir_modules/modulefile.gdas_enkf.$target -fi -module list - -cd $dir_root/src/enkf -./configure clean -./configure $conf_target -make -f Makefile clean -make -f Makefile -j 8 -cp -p global_enkf $dir_root/exec - -if [ $clean = YES ]; then - make -f Makefile clean - ./configure clean - # Now clean the GSI directory - cd .. - make -f Makefile clean - ./configure clean -fi - -exit 0 diff --git a/ush/build_enkf_utils.sh b/ush/build_enkf_utils.sh deleted file mode 100755 index 46b61d43d..000000000 --- a/ush/build_enkf_utils.sh +++ /dev/null @@ -1,59 +0,0 @@ -#!/bin/sh - -set -ex - -cd .. -pwd=$(pwd) - -target=${1:-cray} -dir_root=${2:-$pwd} -clean=${3:-"YES"} - -if [ $target = wcoss ]; then - . /usrx/local/Modules/3.2.10/init/sh - conf_target=nco -elif [ $target = cray -o $target = wcoss_c ]; then - . $MODULESHOME/init/sh - conf_target=nco -elif [ $target = theia ]; then - . /apps/lmod/lmod/init/sh - conf_target=theia -else - echo "unknown target = $target" - exit 9 -fi - -dir_modules=$dir_root/modulefiles -if [ ! -d $dir_modules ]; then - echo "modulefiles does not exist in $dir_modules" - exit 10 -fi -[ -d $dir_root/exec ] || mkdir -p $dir_root/exec - -module purge -if [ $target = wcoss -o $target = cray ]; then - module load $dir_modules/modulefile.gdas_enkf.$target -else - source $dir_modules/modulefile.gdas_enkf.$target -fi -module list - -dlist="adderrspec_nmcmeth_spec.fd getsfcensmeanp.fd getsigensstatp.fd getnstensmeanp.fd getsfcnstensupdp.fd getsigensmeanp_smooth_ncep.fd recentersigp.fd calc_increment_ens.fd gribmean.fd" - -for dir in $dlist; do - - cd $dir_root/util/EnKF/gfs/src/$dir - ./configure clean - ./configure $conf_target - make -f Makefile clean - make -f Makefile - cp -p *.x $dir_root/exec - if [ $clean = YES ]; then - rm -f $dir_root/exec/log*.x - make -f Makefile clean - ./configure clean - fi - -done - -exit 0 diff --git a/ush/build_gsi.sh b/ush/build_gsi.sh deleted file mode 100755 index c04df6799..000000000 --- a/ush/build_gsi.sh +++ /dev/null @@ -1,53 +0,0 @@ -#!/bin/sh - -set -ex - -cd .. -pwd=$(pwd) - -target=${1:-cray} -dir_root=${2:-$pwd} -clean=${3:-"YES"} - -if [ $target = wcoss ]; then - . /usrx/local/Modules/3.2.10/init/sh - conf_target=nco -elif [ $target = cray -o $target = wcoss_c ]; then - . $MODULESHOME/init/sh - conf_target=nco -elif [ $target = theia ]; then - . /apps/lmod/lmod/init/sh - conf_target=theia -else - echo "unknown target = $target" - exit 9 -fi - -dir_modules=$dir_root/modulefiles -if [ ! -d $dir_modules ]; then - echo "modulefiles does not exist in $dir_modules" - exit 10 -fi -[ -d $dir_root/exec ] || mkdir -p $dir_root/exec - -module purge -if [ $target = wcoss -o $target = cray ]; then - module load $dir_modules/modulefile.global_gsi.$target -else - source $dir_modules/modulefile.global_gsi.$target -fi -module list - -cd $dir_root/src -./configure clean -./configure $conf_target -make -f Makefile clean -make -f Makefile -j 8 -cp -p global_gsi $dir_root/exec - -if [ $clean = "YES" ]; then - make -f Makefile clean - ./configure clean -fi - -exit 0 diff --git a/ush/comenkf_namelist.sh b/ush/comenkf_namelist.sh new file mode 100755 index 000000000..405b0a0ab --- /dev/null +++ b/ush/comenkf_namelist.sh @@ -0,0 +1,131 @@ + +cat < enkf.nml + + &nam_enkf + datestring = '$ANAL_TIME', + datapath = './', + analpertwtnh = 0.9, + analpertwtsh = 0.9, + analpertwttr = 0.9, + lupd_satbiasc = .false., + zhuberleft = 1.e10, + zhuberright = 1.e10, + huber = .false., + varqc = .false., + covinflatemax = 1.e2, + covinflatemin = 1.0, + pseudo_rh = .true., + corrlengthnh = 500, + corrlengthsh = 500, + corrlengthtr = 500, + obtimelnh = 1.e30, + obtimelsh = 1.e30, + obtimeltr = 1.e30, + iassim_order = 0, + lnsigcutoffnh = 0.4, + lnsigcutoffsh = 0.4, + lnsigcutofftr = 0.4, + lnsigcutoffsatnh = 0.4, + lnsigcutoffsatsh = 0.4, + lnsigcutoffsattr = 0.4, + lnsigcutoffpsnh = 0.4, + lnsigcutoffpssh = 0.4, + lnsigcutoffpstr = 0.4, + simple_partition = .true., + nlons = $NLONS, + nlats = $NLATS, + smoothparm = -1, + readin_localization = .false., + saterrfact = 1.0, + numiter = 6, + sprd_tol = 1.e30, + paoverpb_thresh = 0.99, + reducedgrid = .false., + nlevs = $NLEVS, + nanals = $NMEM_ENKF, + nvars = 5, + deterministic = .true., + sortinc = .true., + univaroz = .true., + regional = .true., + adp_anglebc = .true., + angord = 4, + use_edges = .false., + emiss_bc = .true., + biasvar = -500 +/ + &satobs_enkf + sattypes_rad(1) = 'amsua_n15', dsis(1) = 'amsua_n15', + sattypes_rad(2) = 'amsua_n18', dsis(2) = 'amsua_n18', + sattypes_rad(3) = 'amsua_n19', dsis(3) = 'amsua_n19', + sattypes_rad(4) = 'amsub_n16', dsis(4) = 'amsub_n16', + sattypes_rad(5) = 'amsub_n17', dsis(5) = 'amsub_n17', + sattypes_rad(6) = 'amsua_aqua', dsis(6) = 'amsua_aqua', + sattypes_rad(7) = 'amsua_metop-a', dsis(7) = 'amsua_metop-a', + sattypes_rad(8) = 'airs_aqua', dsis(8) = 'airs281SUBSET_aqua', + sattypes_rad(9) = 'hirs3_n17', dsis(9) = 'hirs3_n17', + sattypes_rad(10) = 'hirs4_n19', dsis(10)= 'hirs4_n19', + sattypes_rad(11) = 'hirs4_metop-a', dsis(11)= 'hirs4_metop-a', + sattypes_rad(12) = 'mhs_n18', dsis(12)= 'mhs_n18', + sattypes_rad(13) = 'mhs_n19', dsis(13)= 'mhs_n19', + sattypes_rad(14) = 'mhs_metop-a', dsis(14)= 'mhs_metop-a', + sattypes_rad(15) = 'goes_img_g11', dsis(15)= 'imgr_g11', + sattypes_rad(16) = 'goes_img_g12', dsis(16)= 'imgr_g12', + sattypes_rad(17) = 'goes_img_g13', dsis(17)= 'imgr_g13', + sattypes_rad(18) = 'goes_img_g14', dsis(18)= 'imgr_g14', + sattypes_rad(19) = 'goes_img_g15', dsis(19)= 'imgr_g15', + sattypes_rad(20) = 'avhrr3_n18', dsis(20)= 'avhrr3_n18', + sattypes_rad(21) = 'avhrr3_metop-a',dsis(21)= 'avhrr3_metop-a', + sattypes_rad(22) = 'avhrr3_n19', dsis(22)= 'avhrr3_n19', + sattypes_rad(23) = 'amsre_aqua', dsis(23)= 'amsre_aqua', + sattypes_rad(24) = 'ssmis_f16', dsis(24)= 'ssmis_f16', + sattypes_rad(25) = 'ssmis_f17', dsis(25)= 'ssmis_f17', + sattypes_rad(26) = 'ssmis_f18', dsis(26)= 'ssmis_f18', + sattypes_rad(27) = 'ssmis_f19', dsis(27)= 'ssmis_f19', + sattypes_rad(28) = 'ssmis_f20', dsis(28)= 'ssmis_f20', + sattypes_rad(29) = 'sndrd1_g11', dsis(29)= 'sndrD1_g11', + sattypes_rad(30) = 'sndrd2_g11', dsis(30)= 'sndrD2_g11', + sattypes_rad(31) = 'sndrd3_g11', dsis(31)= 'sndrD3_g11', + sattypes_rad(32) = 'sndrd4_g11', dsis(32)= 'sndrD4_g11', + sattypes_rad(33) = 'sndrd1_g12', dsis(33)= 'sndrD1_g12', + sattypes_rad(34) = 'sndrd2_g12', dsis(34)= 'sndrD2_g12', + sattypes_rad(35) = 'sndrd3_g12', dsis(35)= 'sndrD3_g12', + sattypes_rad(36) = 'sndrd4_g12', dsis(36)= 'sndrD4_g12', + sattypes_rad(37) = 'sndrd1_g13', dsis(37)= 'sndrD1_g13', + sattypes_rad(38) = 'sndrd2_g13', dsis(38)= 'sndrD2_g13', + sattypes_rad(39) = 'sndrd3_g13', dsis(39)= 'sndrD3_g13', + sattypes_rad(40) = 'sndrd4_g13', dsis(40)= 'sndrD4_g13', + sattypes_rad(41) = 'sndrd1_g14', dsis(41)= 'sndrD1_g14', + sattypes_rad(42) = 'sndrd2_g14', dsis(42)= 'sndrD2_g14', + sattypes_rad(43) = 'sndrd3_g14', dsis(43)= 'sndrD3_g14', + sattypes_rad(44) = 'sndrd4_g14', dsis(44)= 'sndrD4_g14', + sattypes_rad(45) = 'sndrd1_g15', dsis(45)= 'sndrD1_g15', + sattypes_rad(46) = 'sndrd2_g15', dsis(46)= 'sndrD2_g15', + sattypes_rad(47) = 'sndrd3_g15', dsis(47)= 'sndrD3_g15', + sattypes_rad(48) = 'sndrd4_g15', dsis(48)= 'sndrD4_g15', + sattypes_rad(49) = 'iasi_metop-a', dsis(49)= 'iasi616_metop-a', + sattypes_rad(50) = 'seviri_m08', dsis(50)= 'seviri_m08', + sattypes_rad(51) = 'seviri_m09', dsis(51)= 'seviri_m09', + sattypes_rad(52) = 'seviri_m10', dsis(52)= 'seviri_m10', + sattypes_rad(53) = 'amsua_metop-b', dsis(53)= 'amsua_metop-b', + sattypes_rad(54) = 'hirs4_metop-b', dsis(54)= 'hirs4_metop-b', + sattypes_rad(55) = 'mhs_metop-b', dsis(15)= 'mhs_metop-b', + sattypes_rad(56) = 'iasi_metop-b', dsis(56)= 'iasi616_metop-b', + sattypes_rad(57) = 'avhrr3_metop-b',dsis(56)= 'avhrr3_metop-b', + sattypes_rad(58) = 'atms_npp', dsis(58)= 'atms_npp', + sattypes_rad(59) = 'cris_npp', dsis(59)= 'cris_npp', + / + &ozobs_enkf + sattypes_oz(1) = 'sbuv2_n16', + sattypes_oz(2) = 'sbuv2_n17', + sattypes_oz(3) = 'sbuv2_n18', + sattypes_oz(4) = 'sbuv2_n19', + sattypes_oz(5) = 'omi_aura', + sattypes_oz(6) = 'gome_metop-a', + sattypes_oz(7) = 'gome_metop-b', + / +&nam_wrf + arw = $IF_ARW, + nmm = $IF_NMM, + / +EOF diff --git a/ush/comenkf_namelist_gfs.sh b/ush/comenkf_namelist_gfs.sh new file mode 100755 index 000000000..9d83c2ead --- /dev/null +++ b/ush/comenkf_namelist_gfs.sh @@ -0,0 +1,127 @@ + +cat < enkf.nml + + &nam_enkf + datestring = '$ANAL_TIME', + datapath = './', + analpertwtnh = 0.85, + analpertwtsh = 0.85, + analpertwttr = 0.85, + lupd_satbiasc = .false., + zhuberleft = 1.e10, + zhuberright = 1.e10, + huber = .false., + varqc = .false., + covinflatemax = 1.e2, + covinflatemin = 1.0, + pseudo_rh = .true., + corrlengthnh = 2000, + corrlengthsh = 2000, + corrlengthtr = 2000, + obtimelnh = 1.e30, + obtimelsh = 1.e30, + obtimeltr = 1.e30, + iassim_order = 0, + lnsigcutoffnh = 2.0, + lnsigcutoffsh = 2.0, + lnsigcutofftr = 2.0, + lnsigcutoffsatnh = 2.0, + lnsigcutoffsatsh = 2.0, + lnsigcutoffsattr = 2.0, + lnsigcutoffpsnh = 2.0, + lnsigcutoffpssh = 2.0, + lnsigcutoffpstr = 2.0, + nlons = $LONA, + nlats = $LATA, + smoothparm = -1, + readin_localization = .true., + saterrfact = 1.0, + numiter = 3, + sprd_tol = 1.e30, + paoverpb_thresh = 0.98, + reducedgrid = .false., + nlevs = $LEVS, + nanals = $NMEM_ENKF, + nvars = $NVARS, + deterministic = .true., + sortinc = .true., + univaroz = .true., + regional = .false., + adp_anglebc = .true., + angord = 4, + nmmb = .false., + use_edges = .false., + emiss_bc = .true., + biasvar = -500 +/ + &satobs_enkf + sattypes_rad(1) = 'amsua_n15', dsis(1) = 'amsua_n15', + sattypes_rad(2) = 'amsua_n18', dsis(2) = 'amsua_n18', + sattypes_rad(3) = 'amsua_n19', dsis(3) = 'amsua_n19', + sattypes_rad(4) = 'amsub_n16', dsis(4) = 'amsub_n16', + sattypes_rad(5) = 'amsub_n17', dsis(5) = 'amsub_n17', + sattypes_rad(6) = 'amsua_aqua', dsis(6) = 'amsua_aqua', + sattypes_rad(7) = 'amsua_metop-a', dsis(7) = 'amsua_metop-a', + sattypes_rad(8) = 'airs_aqua', dsis(8) = 'airs281SUBSET_aqua', + sattypes_rad(9) = 'hirs3_n17', dsis(9) = 'hirs3_n17', + sattypes_rad(10) = 'hirs4_n19', dsis(10)= 'hirs4_n19', + sattypes_rad(11) = 'hirs4_metop-a', dsis(11)= 'hirs4_metop-a', + sattypes_rad(12) = 'mhs_n18', dsis(12)= 'mhs_n18', + sattypes_rad(13) = 'mhs_n19', dsis(13)= 'mhs_n19', + sattypes_rad(14) = 'mhs_metop-a', dsis(14)= 'mhs_metop-a', + sattypes_rad(15) = 'goes_img_g11', dsis(15)= 'imgr_g11', + sattypes_rad(16) = 'goes_img_g12', dsis(16)= 'imgr_g12', + sattypes_rad(17) = 'goes_img_g13', dsis(17)= 'imgr_g13', + sattypes_rad(18) = 'goes_img_g14', dsis(18)= 'imgr_g14', + sattypes_rad(19) = 'goes_img_g15', dsis(19)= 'imgr_g15', + sattypes_rad(20) = 'avhrr3_n18', dsis(20)= 'avhrr3_n18', + sattypes_rad(21) = 'avhrr3_metop-a',dsis(21)= 'avhrr3_metop-a', + sattypes_rad(22) = 'avhrr3_n19', dsis(22)= 'avhrr3_n19', + sattypes_rad(23) = 'amsre_aqua', dsis(23)= 'amsre_aqua', + sattypes_rad(24) = 'ssmis_f16', dsis(24)= 'ssmis_f16', + sattypes_rad(25) = 'ssmis_f17', dsis(25)= 'ssmis_f17', + sattypes_rad(26) = 'ssmis_f18', dsis(26)= 'ssmis_f18', + sattypes_rad(27) = 'ssmis_f19', dsis(27)= 'ssmis_f19', + sattypes_rad(28) = 'ssmis_f20', dsis(28)= 'ssmis_f20', + sattypes_rad(29) = 'sndrd1_g11', dsis(29)= 'sndrD1_g11', + sattypes_rad(30) = 'sndrd2_g11', dsis(30)= 'sndrD2_g11', + sattypes_rad(31) = 'sndrd3_g11', dsis(31)= 'sndrD3_g11', + sattypes_rad(32) = 'sndrd4_g11', dsis(32)= 'sndrD4_g11', + sattypes_rad(33) = 'sndrd1_g12', dsis(33)= 'sndrD1_g12', + sattypes_rad(34) = 'sndrd2_g12', dsis(34)= 'sndrD2_g12', + sattypes_rad(35) = 'sndrd3_g12', dsis(35)= 'sndrD3_g12', + sattypes_rad(36) = 'sndrd4_g12', dsis(36)= 'sndrD4_g12', + sattypes_rad(37) = 'sndrd1_g13', dsis(37)= 'sndrD1_g13', + sattypes_rad(38) = 'sndrd2_g13', dsis(38)= 'sndrD2_g13', + sattypes_rad(39) = 'sndrd3_g13', dsis(39)= 'sndrD3_g13', + sattypes_rad(40) = 'sndrd4_g13', dsis(40)= 'sndrD4_g13', + sattypes_rad(41) = 'sndrd1_g14', dsis(41)= 'sndrD1_g14', + sattypes_rad(42) = 'sndrd2_g14', dsis(42)= 'sndrD2_g14', + sattypes_rad(43) = 'sndrd3_g14', dsis(43)= 'sndrD3_g14', + sattypes_rad(44) = 'sndrd4_g14', dsis(44)= 'sndrD4_g14', + sattypes_rad(45) = 'sndrd1_g15', dsis(45)= 'sndrD1_g15', + sattypes_rad(46) = 'sndrd2_g15', dsis(46)= 'sndrD2_g15', + sattypes_rad(47) = 'sndrd3_g15', dsis(47)= 'sndrD3_g15', + sattypes_rad(48) = 'sndrd4_g15', dsis(48)= 'sndrD4_g15', + sattypes_rad(49) = 'iasi_metop-a', dsis(49)= 'iasi616_metop-a', + sattypes_rad(50) = 'seviri_m08', dsis(50)= 'seviri_m08', + sattypes_rad(51) = 'seviri_m09', dsis(51)= 'seviri_m09', + sattypes_rad(52) = 'seviri_m10', dsis(52)= 'seviri_m10', + sattypes_rad(53) = 'amsua_metop-b', dsis(53)= 'amsua_metop-b', + sattypes_rad(54) = 'hirs4_metop-b', dsis(54)= 'hirs4_metop-b', + sattypes_rad(55) = 'mhs_metop-b', dsis(15)= 'mhs_metop-b', + sattypes_rad(56) = 'iasi_metop-b', dsis(56)= 'iasi616_metop-b', + sattypes_rad(57) = 'avhrr3_metop-b',dsis(56)= 'avhrr3_metop-b', + sattypes_rad(58) = 'atms_npp', dsis(58)= 'atms_npp', + sattypes_rad(59) = 'cris_npp', dsis(59)= 'cris_npp', + / + &ozobs_enkf + sattypes_oz(1) = 'sbuv2_n16', + sattypes_oz(2) = 'sbuv2_n17', + sattypes_oz(3) = 'sbuv2_n18', + sattypes_oz(4) = 'sbuv2_n19', + sattypes_oz(5) = 'omi_aura', + sattypes_oz(6) = 'gome_metop-a', + sattypes_oz(7) = 'gome_metop-b', + / +EOF diff --git a/ush/comenkf_run_gfs.ksh b/ush/comenkf_run_gfs.ksh new file mode 100755 index 000000000..41dc12ec0 --- /dev/null +++ b/ush/comenkf_run_gfs.ksh @@ -0,0 +1,223 @@ +#!/bin/ksh +##################################################### +# machine set up (users should change this part) +##################################################### + +set -x + +#-------------------------------------------------- + GSIPROC=32 + ARCH='LINUX_LSF' + +##################################################### +##case set up (users should change this part) +##################################################### +# +# GFSCASE = cases used for DTC test +# T574, T254, T126, T62, enkf_glb_t254 +# ANAL_TIME= analysis time (YYYYMMDDHH) +# WORK_ROOT= working directory, where GSI runs +# PREPBURF = path of PreBUFR conventional obs +# BK_ROOT = path of background files +# OBS_ROOT = path of observations files +# FIX_ROOT = path of fix files +# ENKF_EXE = path and name of the EnKF executable + ANAL_TIME=2014092918 + GFSCASE=T62 + JOB_DIR=the_job_directory + #normally you put run scripts here and submit jobs form here, require a copy of enkf_gfs.x at this directory + RUN_NAME=a_descriptive_run_name_such_as_case05_3denvar_etc + OBS_ROOT=the_directory_where_observation_files_are_located + BK_ROOT=the_directory_where_background_files_are_located + GSI_ROOT=the_comgsi_main directory where src/ ush/ fix/ etc are located + CRTM_ROOT=the_CRTM_directory + diag_ROOT=the_observer_directory_where_diag_files_exist + WORK_ROOT=${JOB_DIR}/${RUN_NAME} + FIX_ROOT=${GSI_ROOT}/fix + ENKF_EXE=${JOB_DIR}/enkf_gfs.x + ENKF_NAMELIST=${GSI_ROOT}/ush/comenkf_namelist_gfs.sh + +# Note: number of pe >= NMEM_ENKF +NMEM_ENKF=10 +LEVS=64 +NVARS=5 + +# Set the JCAP resolution which you want. +# All resolutions use LEVS=64 +if [[ "$GFSCASE" = "T62" ]]; then + JCAP=62 + JCAP_B=62 +elif [[ "$GFSCASE" = "T126" ]]; then + JCAP=126 + JCAP_B=126 +elif [[ "$GFSCASE" = "enkf_glb_t254" ]]; then + JCAP=254 + JCAP_B=254 +elif [[ "$GFSCASE" = "T254" ]]; then + JCAP=254 + JCAP_B=574 +elif [[ "$GFSCASE" = "T574" ]]; then + JCAP=574 + JCAP_B=1534 +else + echo "INVALID case = $GFSCASE" + exit +fi + +# Given the requested resolution, set dependent resolution parameters +if [[ "$JCAP" = "382" ]]; then + LONA=768 + LATA=384 + DELTIM=180 + resol=1 +elif [[ "$JCAP" = "574" ]]; then + LONA=1152 + LATA=576 + DELTIM=1200 + resol=2 +elif [[ "$JCAP" = "254" ]]; then + LONA=512 + LATA=256 + DELTIM=1200 + resol=2 +elif [[ "$JCAP" = "126" ]]; then + LONA=256 + LATA=128 + DELTIM=1200 + resol=2 +elif [[ "$JCAP" = "62" ]]; then + LONA=192 + LATA=94 + DELTIM=1200 + resol=2 +else + echo "INVALID JCAP = $JCAP" + exit +fi +NLAT=` expr $LATA + 2 ` + +ncp=/bin/cp +##################################################### +# Users should NOT change script after this point +##################################################### +# +case $ARCH in + 'IBM_LSF') + ###### IBM LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX') + if [ $GSIPROC = 1 ]; then + #### Linux workstation - single processor + RUN_COMMAND="" + else + ###### Linux workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} " + fi ;; + + 'LINUX_LSF') + ###### LINUX LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX_PBS') + #### Linux cluster PBS (Portable Batch System) + RUN_COMMAND="mpirun -np ${GSIPROC} " ;; + + 'DARWIN_PGI') + ### Mac - mpi run + if [ $GSIPROC = 1 ]; then + #### Mac workstation - single processor + RUN_COMMAND="" + else + ###### Mac workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} -machinefile ~/mach " + fi ;; + + * ) + print "error: $ARCH is not a supported platform configuration." + exit 1 ;; +esac + +# Given the analysis date, compute the date from which the +# first guess comes. Extract cycle and set prefix and suffix +# for guess and observation data files +PDYa=`echo $ANAL_TIME | cut -c1-8` +cyca=`echo $ANAL_TIME | cut -c9-10` +gdate=`date -u -d "$PDYa $cyca -6 hour" +%Y%m%d%H` #6hr ago + +PDYg=`echo $gdate | cut -c1-8` +cycg=`echo $gdate | cut -c9-10` +prefix_tbc=gdas1.t${cycg}z + +# Directories for test case +dirtbc=$BK_ROOT + +# Fixed files +ANAVINFO=${diag_ROOT}/anavinfo +CONVINFO=${diag_ROOT}/convinfo +SATINFO=${diag_ROOT}/satinfo +SCANINFO=${diag_ROOT}/scaninfo +OZINFO=${diag_ROOT}/ozinfo +LOCINFO=${diag_ROOT}/hybens_info + +# Set up workdir +rm -rf $WORK_ROOT +mkdir -p $WORK_ROOT +cd $WORK_ROOT + +#Build EnKF namelist on-the-fly +. $ENKF_NAMELIST + +#$ncp $ENKF_EXE ./enkf.x +cp $ENKF_EXE enkf.x + +cp $ANAVINFO ./anavinfo +cp $CONVINFO ./convinfo +cp $SATINFO ./satinfo +cp $SCANINFO ./scaninfo +cp $OZINFO ./ozinfo +cp $LOCINFO ./hybens_info + +cp $diag_ROOT/satbias_in ./satbias_in +cp $diag_ROOT/satbias_pc ./satbias_pc +cp $diag_ROOT/satbias_angle ./satbias_angle + +# get mean +#ln -s $BK_ROOT/sfg_${gdate}_fhr06_ensmean ./sfg_${gdate}_fhr06_ensmean +ln -s $BK_ROOT/sfg_${gdate}_fhr06_ensmean ./sfg_${ANAL_TIME}_fhr06_ensmean #enkf_gfs requires sfg_ValidTime.fhr06_ensmean +list="conv amsua_metop-a amsua_n18 amsua_n15" +for type in $list; do + ln -s $diag_ROOT/diag_${type}_ges.ensmean . +done + +# get each member +imem=1 +while [[ $imem -le $NMEM_ENKF ]]; do + member="mem"`printf %03i $imem` + #ln -s $BK_ROOT/sfg_${gdate}_fhr06_${member} ./sfg_${gdate}_fhr06_${member} + ln -s $BK_ROOT/sfg_${gdate}_fhr06_${member} ./sfg_${ANAL_TIME}_fhr06_${member} ##enkf_gfs requires sfg_ValidTime.fhr06_MEMBER + list="conv amsua_metop-a amsua_n18 amsua_n15" + for type in $list; do + ln -s $diag_ROOT/diag_${type}_ges.${member} . + done + (( imem = $imem + 1 )) +done +# +################################################### +# run EnKF +################################################### +echo ' Run EnKF' + +${RUN_COMMAND} ./enkf.x < enkf.nml > stdout 2>&1 + +################################################################## +# run time error check +################################################################## +error=$? + +if [ ${error} -ne 0 ]; then + echo "ERROR: ${ENKF_EXE} crashed Exit status=${error}" + exit ${error} +fi + +exit diff --git a/ush/comenkf_run_regional.ksh b/ush/comenkf_run_regional.ksh new file mode 100755 index 000000000..9d16f26e4 --- /dev/null +++ b/ush/comenkf_run_regional.ksh @@ -0,0 +1,183 @@ +#!/bin/ksh +##################################################### +# machine set up (users should change this part) +##################################################### +# + +set -x + +# +# GSIPROC = processor number used for GSI analysis +#------------------------------------------------ + GSIPROC=32 + ARCH='LINUX_LSF' + +# Supported configurations: + # IBM_LSF, + # LINUX, LINUX_LSF, LINUX_PBS, + # DARWIN_PGI +# +##################################################### +# case set up (users should change this part) +##################################################### +# +# ANAL_TIME= analysis time (YYYYMMDDHH) +# WORK_ROOT= working directory, where GSI runs +# PREPBURF = path of PreBUFR conventional obs +# OBS_ROOT = path of observations files +# FIX_ROOT = path of fix files +# ENKF_EXE = path and name of the EnKF executable + ANAL_TIME=2014021300 #used by comenkf_namelist.sh + JOB_DIR=the_job_directory + #normally you put run scripts here and submit jobs form here, require a copy of enkf_wrf.x at this directory + RUN_NAME=a_descriptive_run_name_such_as_case05_3denvar_etc + OBS_ROOT=the_directory_where_observation_files_are_located + BK_ROOT=the_directory_where_background_files_are_located + GSI_ROOT=the_comgsi_main directory where src/ ush/ fix/ etc are located + CRTM_ROOT=the_CRTM_directory + diag_ROOT=the_observer_directory_where_diag_files_exist + ENKF_EXE=${JOB_DIR}/enkf_wrf.x + WORK_ROOT=${JOB_DIR}/${RUN_NAME} + FIX_ROOT=${GSI_ROOT}/fix + ENKF_NAMELIST=${GSI_ROOT}/ush/comenkf_namelist.sh + +# ensemble parameters +# + NMEM_ENKF=20 + BK_FILE_mem=${BK_ROOT}/wrfarw + NLONS=129 + NLATS=70 + NLEVS=50 + IF_ARW=.true. + IF_NMM=.false. + list="conv" +# list="conv amsua_n18 mhs_n18 hirs4_n19" +# +##################################################### +# Users should NOT change script after this point +##################################################### +# + +case $ARCH in + 'IBM_LSF') + ###### IBM LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX') + if [ $GSIPROC = 1 ]; then + #### Linux workstation - single processor + RUN_COMMAND="" + else + ###### Linux workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} " + fi ;; + + 'LINUX_LSF') + ###### LINUX LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX_PBS') + #### Linux cluster PBS (Portable Batch System) + RUN_COMMAND="mpirun -np ${GSIPROC} " ;; + + 'DARWIN_PGI') + ### Mac - mpi run + if [ $GSIPROC = 1 ]; then + #### Mac workstation - single processor + RUN_COMMAND="" + else + ###### Mac workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} -machinefile ~/mach " + fi ;; + + * ) + print "error: $ARCH is not a supported platform configuration." + exit 1 ;; +esac + +# Given the analysis date, compute the date from which the +# first guess comes. Extract cycle and set prefix and suffix +# for guess and observation data files +# gdate=`$ndate -06 $adate` +#gdate=$ANAL_TIME +#YYYYMMDD=`echo $adate | cut -c1-8` +#HH=`echo $adate | cut -c9-10` + +# Fixed files +# CONVINFO=${FIX_ROOT}/global_convinfo.txt +# SATINFO=${FIX_ROOT}/global_satinfo.txt +# SCANINFO=${FIX_ROOT}/global_scaninfo.txt +# OZINFO=${FIX_ROOT}/global_ozinfo.txt +ANAVINFO=${diag_ROOT}/anavinfo +CONVINFO=${diag_ROOT}/convinfo +SATINFO=${diag_ROOT}/satinfo +SCANINFO=${diag_ROOT}/scaninfo +OZINFO=${diag_ROOT}/ozinfo +# LOCINFO=${FIX_ROOT}/global_hybens_locinfo.l64.txt + +# Set up workdir +rm -rf $WORK_ROOT +mkdir -p $WORK_ROOT +cd $WORK_ROOT + +cp $ENKF_EXE enkf.x + +cp $ANAVINFO ./anavinfo +cp $CONVINFO ./convinfo +cp $SATINFO ./satinfo +cp $SCANINFO ./scaninfo +cp $OZINFO ./ozinfo +# cp $LOCINFO ./hybens_locinfo + +cp $diag_ROOT/satbias_in ./satbias_in +cp $diag_ROOT/satbias_pc ./satbias_pc + +# get mean +ln -s ${BK_FILE_mem}.ensmean ./firstguess.ensmean +for type in $list; do + ln -s $diag_ROOT/diag_${type}_ges.ensmean . +done + +# get each member +imem=1 +while [[ $imem -le $NMEM_ENKF ]]; do + member="mem"`printf %03i $imem` + ln -s ${BK_FILE_mem}.${member} ./firstguess.${member} + for type in $list; do + ln -s $diag_ROOT/diag_${type}_ges.${member} . + done + (( imem = $imem + 1 )) +done + +# Build the GSI namelist on-the-fly +. $ENKF_NAMELIST + +# make analysis files +cp firstguess.ensmean analysis.ensmean +# get each member +imem=1 +while [[ $imem -le $NMEM_ENKF ]]; do + member="mem"`printf %03i $imem` + cp firstguess.${member} analysis.${member} + (( imem = $imem + 1 )) +done + +# +################################################### +# run EnKF +################################################### +echo ' Run EnKF' + +${RUN_COMMAND} ./enkf.x < enkf.nml > stdout 2>&1 + +################################################################## +# run time error check +################################################################## +error=$? + +if [ ${error} -ne 0 ]; then + echo "ERROR: ${ENKF_EXE} crashed Exit status=${error}" + exit ${error} +fi + +exit diff --git a/ush/comgsi_namelist.sh b/ush/comgsi_namelist.sh new file mode 100755 index 000000000..ff09eea74 --- /dev/null +++ b/ush/comgsi_namelist.sh @@ -0,0 +1,157 @@ + +cat < gsiparm.anl + + &SETUP + miter=${nummiter},niter(1)=50,niter(2)=50, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + gencode=78,qoption=2, + factqmin=0.0,factqmax=0.0, + iguess=-1, + oneobtest=${if_oneobtest},retrieval=.false., + nhr_assimilation=2,l_foto=.false., + use_pbl=.false.,verbose=.true., + lread_obs_save=${if_read_obs_save},lread_obs_skip=${if_read_obs_skip}, + newpc4pred=.true.,adp_anglebc=.true.,angord=4, + passive_bc=.true.,use_edges=.false.,emiss_bc=.true., + diag_precon=.true.,step_start=1.e-3, + l4densvar=${if4d},nhr_obsbin=1,min_offset=60, + use_gfs_nemsio=${if_gfs_nemsio}, + / + &GRIDOPTS + JCAP=62,JCAP_B=62,NLAT=60,NLON=60,nsig=60,regional=.true., + wrf_nmm_regional=${bk_core_nmm},wrf_mass_regional=${bk_core_arw}, + nems_nmmb_regional=${bk_core_nmmb},nmmb_reference_grid='H',diagnostic_reg=.false., + filled_grid=.false.,half_grid=.true.,netcdf=${bk_if_netcdf}, + / + &BKGERR + vs=${vs_op} + hzscl=${hzscl_op} + bw=0.,fstat=.true., + / + &ANBKGERR + / + &JCOPTS + / + &STRONGOPTS + / + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.false.,c_varqc=0.02,vadfile='prepbufr', + / + &OBS_INPUT + dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=30,time_window_max=1.5,ext_sonde=.true., + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + prepbufr ps null ps 1.0 0 0 + prepbufr t null t 1.0 0 0 + prepbufr q null q 1.0 0 0 + prepbufr pw null pw 1.0 0 0 + satwndbufr uv null uv 1.0 0 0 + prepbufr uv null uv 1.0 0 0 + prepbufr spd null spd 1.0 0 0 + prepbufr dw null dw 1.0 0 0 + l2rwbufr rw null rw 1.0 0 0 + prepbufr sst null sst 1.0 0 0 + gpsrobufr gps_ref null gps 1.0 0 0 + ssmirrbufr pcp_ssmi dmsp pcp_ssmi 1.0 -1 0 + tmirrbufr pcp_tmi trmm pcp_tmi 1.0 -1 0 + sbuvbufr sbuv2 n16 sbuv8_n16 1.0 0 0 + sbuvbufr sbuv2 n17 sbuv8_n17 1.0 0 0 + sbuvbufr sbuv2 n18 sbuv8_n18 1.0 0 0 + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 + hirs3bufr hirs3 n17 hirs3_n17 6.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 6.0 2 0 + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 + hirs4bufr hirs4 n19 hirs4_n19 1.0 2 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 1.0 1 0 + gimgrbufr goes_img g11 imgr_g11 0.0 1 0 + gimgrbufr goes_img g12 imgr_g12 0.0 1 0 + airsbufr airs aqua airs281SUBSET_aqua 20.0 2 0 + amsuabufr amsua n15 amsua_n15 10.0 2 0 + amsuabufr amsua n18 amsua_n18 10.0 2 0 + amsuabufr amsua n19 amsua_n19 10.0 2 0 + amsuabufr amsua metop-a amsua_metop-a 10.0 2 0 + amsuabufr amsua metop-b amsua_metop-b 10.0 2 0 + airsbufr amsua aqua amsua_aqua 5.0 2 0 + amsubbufr amsub n17 amsub_n17 1.0 1 0 + mhsbufr mhs n18 mhs_n18 3.0 2 0 + mhsbufr mhs n19 mhs_n19 3.0 2 0 + mhsbufr mhs metop-a mhs_metop-a 3.0 2 0 + mhsbufr mhs metop-b mhs_metop-b 3.0 2 0 + ssmitbufr ssmi f13 ssmi_f13 0.0 2 0 + ssmitbufr ssmi f14 ssmi_f14 0.0 2 0 + ssmitbufr ssmi f15 ssmi_f15 0.0 2 0 + amsrebufr amsre_low aqua amsre_aqua 0.0 2 0 + amsrebufr amsre_mid aqua amsre_aqua 0.0 2 0 + amsrebufr amsre_hig aqua amsre_aqua 0.0 2 0 + ssmisbufr ssmis_las f16 ssmis_f16 0.0 2 0 + ssmisbufr ssmis_uas f16 ssmis_f16 0.0 2 0 + ssmisbufr ssmis_img f16 ssmis_f16 0.0 2 0 + ssmisbufr ssmis_env f16 ssmis_f16 0.0 2 0 + gsnd1bufr sndrd1 g12 sndrD1_g12 1.5 1 0 + gsnd1bufr sndrd2 g12 sndrD2_g12 1.5 1 0 + gsnd1bufr sndrd3 g12 sndrD3_g12 1.5 1 0 + gsnd1bufr sndrd4 g12 sndrD4_g12 1.5 1 0 + gsnd1bufr sndrd1 g11 sndrD1_g11 1.5 1 0 + gsnd1bufr sndrd2 g11 sndrD2_g11 1.5 1 0 + gsnd1bufr sndrd3 g11 sndrD3_g11 1.5 1 0 + gsnd1bufr sndrd4 g11 sndrD4_g11 1.5 1 0 + gsnd1bufr sndrd1 g13 sndrD1_g13 1.5 1 0 + gsnd1bufr sndrd2 g13 sndrD2_g13 1.5 1 0 + gsnd1bufr sndrd3 g13 sndrD3_g13 1.5 1 0 + gsnd1bufr sndrd4 g13 sndrD4_g13 1.5 1 0 + gsnd1bufr sndrd1 g15 sndrD1_g15 1.5 2 0 + gsnd1bufr sndrd2 g15 sndrD2_g15 1.5 2 0 + gsnd1bufr sndrd3 g15 sndrD3_g15 1.5 2 0 + gsnd1bufr sndrd4 g15 sndrD4_g15 1.5 2 0 + iasibufr iasi metop-a iasi616_metop-a 20.0 1 0 + gomebufr gome metop-a gome_metop-a 1.0 2 0 + omibufr omi aura omi_aura 1.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 1.0 0 0 + tcvitl tcp null tcp 1.0 0 0 + seviribufr seviri m08 seviri_m08 1.0 1 0 + seviribufr seviri m09 seviri_m09 1.0 1 0 + seviribufr seviri m10 seviri_m10 1.0 1 0 + iasibufr iasi metop-b iasi616_metop-b 0.0 1 0 + gomebufr gome metop-b gome_metop-b 0.0 2 0 + atmsbufr atms npp atms_npp 0.0 1 0 + crisbufr cris npp cris_npp 0.0 1 0 + mlsbufr mls30 aura mls30_aura 0.0 0 0 + oscatbufr uv null uv 0.0 0 0 + prepbufr mta_cld null mta_cld 1.0 0 0 + prepbufr gos_ctp null gos_ctp 1.0 0 0 + refInGSI rad_ref null rad_ref 1.0 0 0 + lghtInGSI lghtn null lghtn 1.0 0 0 + larcglb larcglb null larcglb 1.0 0 0 + glmbufr light g16 light 0.0 0 0 +:: + &SUPEROB_RADAR + del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., + l2superob_only=.false., + / + &LAG_DATA + / + &HYBRID_ENSEMBLE + l_hyb_ens=${ifhyb}, + uv_hyb_ens=.true., + aniso_a_en=.false.,generate_ens=.false., + n_ens=${nummem}, + beta_s0=0.5,s_ens_h=110,s_ens_v=3, + regional_ensemble_option=1, + pseudo_hybens = .false., + grid_ratio_ens = 1, + l_ens_in_diff_time=.true., + ensemble_path='', + / + &RAPIDREFRESH_CLDSURF + / + &CHEM + / + &NST + / + &SINGLEOB_TEST + maginnov=1.0,magoberr=0.8,oneob_type='t', + oblat=38.,oblon=279.,obpres=500.,obdattim=${ANAL_TIME}, + obhourset=0., + / +EOF diff --git a/ush/comgsi_namelist_chem.sh b/ush/comgsi_namelist_chem.sh new file mode 100755 index 000000000..1222d21cd --- /dev/null +++ b/ush/comgsi_namelist_chem.sh @@ -0,0 +1,79 @@ + +cat < gsiparm.anl + + &SETUP + miter=2,niter(1)=50,niter(2)=50, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + gencode=78,qoption=1, + factqmin=0.0,factqmax=0.0, + iguess=-1, + oneobtest=.false.,retrieval=.false., + nhr_assimilation=3,l_foto=.false., + use_pbl=.false.,verbose=.true., + offtime_data=.true.,diag_aero=.false., + newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true., + use_edges=.false.,diag_precon=.false., + / + &GRIDOPTS + JCAP=62,JCAP_B=62,NLAT=60,NLON=60,nsig=60,regional=.true., + wrf_nmm_regional=.false.,wrf_mass_regional=${bk_core_arw}, + nems_nmmb_regional=.false.,nmmb_reference_grid='H',diagnostic_reg=.false., + cmaq_regional=${bk_core_cmaq}, + filled_grid=.false.,half_grid=.true.,netcdf=${bk_if_netcdf}, + / + &BKGERR + vs=1.0, + hzscl=.373,.746,1.5, + bw=0.,fstat=.true., + / + &ANBKGERR + / + &JCOPTS + / + &STRONGOPTS + / + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.false.,c_varqc=0.02,vadfile='prepbufr', + / + &OBS_INPUT + dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=30,time_window_max=240.0,ext_sonde=.true., + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + modisbufr modis_aod terra v.modis_terra 1.0 2 0 + modisbufr modis_aod aqua v.modis_aqua 1.0 2 0 + pm25bufr pm2_5 null TEOM 1.0 0 0 +:: + &SUPEROB_RADAR + del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., + l2superob_only=.false., + / + &LAG_DATA + / + &HYBRID_ENSEMBLE + l_hyb_ens=.false., + / + &RAPIDREFRESH_CLDSURF + / + &CHEM + laeroana_gocart=${bk_laeroana_gocart}, + l_aoderr_table = .false., + aod_qa_limit = 3, + luse_deepblue = .false., + aero_ratios = .false., + tunable_error=0.5, + berror_chem=.true., + wrf_pm2_5=${bk_wrf_pm2_5}, + diag_incr=.true., + in_fname="cmaq_in.bin", + out_fname="cmaq_out.bin", + incr_fname="cmaq_increment.bin", + / + &NST + / + &SINGLEOB_TEST + maginnov=1.0,magoberr=0.8,oneob_type='t', + oblat=38.,oblon=279.,obpres=500.,obdattim=${ANAL_TIME}, + obhourset=0., + / +EOF diff --git a/ush/comgsi_namelist_gfs.sh b/ush/comgsi_namelist_gfs.sh new file mode 100755 index 000000000..69cc989d4 --- /dev/null +++ b/ush/comgsi_namelist_gfs.sh @@ -0,0 +1,136 @@ + +cat < gsiparm.anl + + &SETUP + miter=${nummiter},niter(1)=50,niter(2)=50, + niter_no_qc(1)=50,niter_no_qc(2)=0, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + gencode=82,qoption=2,cwoption=3, + factqmin=5.0,factqmax=5.0,deltim=1200, + iguess=-1, + oneobtest=.false.,retrieval=.false.,l_foto=.false.,verbose=.true., + use_pbl=.false.,use_compress=.true.,nsig_ext=12,gpstop=50., + use_gfs_nemsio=.false.,lrun_subdirs=.false., + newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false.,diag_precon=.true.,step_start=1.0e-3,emiss_bc=.true.,cwoption=3, + deltim=$DELTIM, + lread_obs_save=${if_read_obs_save},lread_obs_skip=${if_read_obs_skip}, + / + &GRIDOPTS + JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, + regional=.false.,nlayers(63)=3,nlayers(64)=6, + / + &BKGERR + vs=${vs_op} + hzscl=${hzscl_op} + hswgt=0.45,0.3,0.25, + bw=0.0,norsp=4, + bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, + / + &ANBKGERR + / + &JCOPTS + / + &STRONGOPTS + / + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.false.,c_varqc=0.02,vadfile='prepbufr', + / + &OBS_INPUT + dmesh(1)=1450.0,dmesh(2)=1500.0,time_window_max=0.5,ext_sonde=.true., + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + prepbufr ps null ps 0.0 0 0 + prepbufr t null t 0.0 0 0 + prepbufr q null q 0.0 0 0 + prepbufr pw null pw 0.0 0 0 + satwndbufr uv null uv 0.0 0 0 + prepbufr uv null uv 0.0 0 0 + prepbufr spd null spd 0.0 0 0 + prepbufr dw null dw 0.0 0 0 + radarbufr rw null l3rw 0.0 0 0 + l2rwbufr rw null l2rw 0.0 0 0 + prepbufr sst null sst 0.0 0 0 + gpsrobufr gps_bnd null gps 0.0 0 0 + ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 + tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 1 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 + gimgrbufr goes_img g11 imgr_g11 0.0 1 0 + gimgrbufr goes_img g12 imgr_g12 0.0 1 0 + airsbufr airs aqua airs_aqua 0.0 1 1 + amsuabufr amsua n15 amsua_n15 0.0 1 1 + amsuabufr amsua n18 amsua_n18 0.0 1 1 + amsuabufr amsua metop-a amsua_metop-a 0.0 1 1 + airsbufr amsua aqua amsua_aqua 0.0 1 1 + amsubbufr amsub n17 amsub_n17 0.0 1 1 + mhsbufr mhs n18 mhs_n18 0.0 1 1 + mhsbufr mhs metop-a mhs_metop-a 0.0 1 1 + ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 + amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 + amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 + ssmisbufr ssmis_las f16 ssmis_f16 0.0 1 0 + ssmisbufr ssmis_uas f16 ssmis_f16 0.0 1 0 + ssmisbufr ssmis_img f16 ssmis_f16 0.0 1 0 + ssmisbufr ssmis_env f16 ssmis_f16 0.0 1 0 + gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 + gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 + gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 + gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 + gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 + gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 + gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 + gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 + gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 + gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 + gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 + gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 + iasibufr iasi metop-a iasi_metop-a 0.0 1 1 + gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 + amsuabufr amsua n19 amsua_n19 0.0 1 1 + mhsbufr mhs n19 mhs_n19 0.0 1 1 + tcvitl tcp null tcp 0.0 0 0 + seviribufr seviri m08 seviri_m08 0.0 1 0 + seviribufr seviri m09 seviri_m09 0.0 1 0 + seviribufr seviri m10 seviri_m10 0.0 1 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 + amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 + mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 + iasibufr iasi metop-b iasi_metop-b 0.0 1 0 + gomebufr gome metop-b gome_metop-b 0.0 2 0 + atmsbufr atms npp atms_npp 0.0 1 0 + atmsbufr atms n20 atms_n20 0.0 1 0 + crisbufr cris npp cris_npp 0.0 1 0 + crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 + crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 + mlsbufr mls30 aura mls30_aura 0.0 0 0 + oscatbufr uv null uv 0.0 0 0 +:: + &SUPEROB_RADAR + del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., + l2superob_only=.false., + / + &LAG_DATA + / + &HYBRID_ENSEMBLE + l_hyb_ens=.false., + / + &RAPIDREFRESH_CLDSURF + / + &CHEM + / + &NST + / + &SINGLEOB_TEST + maginnov=1.0,magoberr=0.8,oneob_type='t', + oblat=38.,oblon=279.,obpres=500.,obdattim=${ANAL_TIME}, + obhourset=0., + / +EOF diff --git a/ush/comgsi_run_chem.ksh b/ush/comgsi_run_chem.ksh new file mode 100755 index 000000000..58f723bc5 --- /dev/null +++ b/ush/comgsi_run_chem.ksh @@ -0,0 +1,448 @@ +#!/bin/ksh +##################################################### +# machine set up (users should change this part) +##################################################### + +set -x +# +# GSIPROC = processor number used for GSI analysis +#------------------------------------------------ + GSIPROC=1 + ARCH='LINUX_LSF' + +# Supported configurations: + # IBM_LSF, + # LINUX, LINUX_LSF, LINUX_PBS, + # DARWIN_PGI +# this script can run 4 GSI chem cases +# 1. WRF-Chem GOCART with MODIS AOD observation +# bk_core=WRFCHEM_GOCART and obs_type=MODISAOD +# background= wrfinput_enkf_d01_2012-06-03_18:00:00 +# observations=Aqua_Terra_AOD_BUFR:2012-06-03_00:00:00 +# 2. WRF-Chem GOCART with PM25 observation +# bk_core=WRFCHEM_GOCART and obs_type=PM25 +# background= wrfinput_enkf_d01_2012-06-03_18:00:00 +# observations=anow.2012060318.bufr +# 3. WRF-Chem PM25 with MP25 observation +# bk_core=WRFCHEM_PM25 and obs_type=PM25 +# background= wrfinput_enkf_d01_2012-06-03_18:00:00 +# observations=anow.2012060318.bufr +# 4. CMAQ with MP25 observation +# bk_core=CMAQ and obs_type=PM25 +# background= cmaq2gsi_4.7_20130621_120000.bin +# observations=anow.2013062112.bufr +# +##################################################### +# case set up (users should change this part) +##################################################### +# +# ANAL_TIME= analysis time (YYYYMMDDHH) +# WORK_ROOT= working directory, where GSI runs +# PREPBURF = path of PreBUFR conventional obs +# BK_FILE = path and name of background file +# OBS_ROOT = path of observations files +# FIX_ROOT = path of fix files +# GSI_EXE = path and name of the gsi executable + ANAL_TIME=2012060318 + JOB_DIR=the_job_directory + #normally you put run scripts here and submit jobs form here, require a copy of gsi.x at this directory + RUN_NAME=a_descriptive_run_name_such_as_case05_3denvar_etc + OBS_ROOT=the_directory_where_observation_files_are_located + BK_ROOT=the_directory_where_background_files_are_located + GSI_ROOT=the_comgsi_main directory where src/ ush/ fix/ etc are located + CRTM_ROOT=the_CRTM_directory + GSI_EXE=${JOB_DIR}/gsi.x #assume you have a copy of gsi.x here + WORK_ROOT=${JOB_DIR}/${RUN_NAME} + FIX_ROOT=${GSI_ROOT}/fix + GSI_NAMELIST=${GSI_ROOT}/ush/comgsi_namelist_chem.sh + PREPBUFR=${OBS_ROOT}/anow.2012060318.bufr + BK_FILE=${BK_ROOT}/wrfinput_d01_2012-06-03_18:00:00 +# +#------------------------------------------------ +# bk_core= set background (WRFCHEM_GOCART WRFCHEM_PM25 or CMAQ) +# obs_type= set observation type (MODISAOD or PM25) +# if_clean = clean : delete temperal files in working directory (default) +# no : leave running directory as is (this is for debug only) + bk_core=WRFCHEM_GOCART + obs_type=PM25 + if_clean=clean +# +# +##################################################### +# Users should NOT make changes after this point +##################################################### +# +BYTE_ORDER=Big_Endian +# BYTE_ORDER=Little_Endian + +case $ARCH in + 'IBM_LSF') + ###### IBM LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX') + if [ $GSIPROC = 1 ]; then + #### Linux workstation - single processor + RUN_COMMAND="" + else + ###### Linux workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} " + fi ;; + + 'LINUX_LSF') + ###### LINUX LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX_PBS') + #### Linux cluster PBS (Portable Batch System) + RUN_COMMAND="mpirun -np ${GSIPROC} " ;; + + 'DARWIN_PGI') + ### Mac - mpi run + if [ $GSIPROC = 1 ]; then + #### Mac workstation - single processor + RUN_COMMAND="" + else + ###### Mac workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} -machinefile ~/mach " + fi ;; + + * ) + print "error: $ARCH is not a supported platform configuration." + exit 1 ;; +esac + + +################################################################################## +# Check GSI needed environment variables are defined and exist +# + +# Make sure ANAL_TIME is defined and in the correct format +if [ ! "${ANAL_TIME}" ]; then + echo "ERROR: \$ANAL_TIME is not defined!" + exit 1 +fi + +# Make sure WORK_ROOT is defined and exists +if [ ! "${WORK_ROOT}" ]; then + echo "ERROR: \$WORK_ROOT is not defined!" + exit 1 +fi + +# Make sure the background file exists +if [ ! -r "${BK_FILE}" ]; then + echo "ERROR: ${BK_FILE} does not exist!" + exit 1 +fi + +# Make sure OBS_ROOT is defined and exists +if [ ! "${OBS_ROOT}" ]; then + echo "ERROR: \$OBS_ROOT is not defined!" + exit 1 +fi +if [ ! -d "${OBS_ROOT}" ]; then + echo "ERROR: OBS_ROOT directory '${OBS_ROOT}' does not exist!" + exit 1 +fi + +# Set the path to the GSI static files +if [ ! "${FIX_ROOT}" ]; then + echo "ERROR: \$FIX_ROOT is not defined!" + exit 1 +fi +if [ ! -d "${FIX_ROOT}" ]; then + echo "ERROR: fix directory '${FIX_ROOT}' does not exist!" + exit 1 +fi + +# Set the path to the CRTM coefficients +if [ ! "${CRTM_ROOT}" ]; then + echo "ERROR: \$CRTM_ROOT is not defined!" + exit 1 +fi +if [ ! -d "${CRTM_ROOT}" ]; then + echo "ERROR: fix directory '${CRTM_ROOT}' does not exist!" + exit 1 +fi + + +# Make sure the GSI executable exists +if [ ! -x "${GSI_EXE}" ]; then + echo "ERROR: ${GSI_EXE} does not exist!" + exit 1 +fi + +# Check to make sure the number of processors for running GSI was specified +if [ -z "${GSIPROC}" ]; then + echo "ERROR: The variable $GSIPROC must be set to contain the number of processors to run GSI" + exit 1 +fi + +# +################################################################################## +# Create the ram work directory and cd into it + +workdir=${WORK_ROOT} +echo " Create working directory:" ${workdir} + +if [ -d "${workdir}" ]; then + rm -rf ${workdir} +fi +mkdir -p ${workdir} +cd ${workdir} + +# +################################################################################## + +echo " Copy GSI executable, background file, and link observation bufr to working directory" + +# Save a copy of the GSI executable in the workdir +cp ${GSI_EXE} gsi.x + +# Bring over background field (it's modified by GSI so we can't link to it) + +if [ ${bk_core} = WRFCHEM_GOCART ] ; then + cp ${BK_FILE} ./wrf_inout +fi +if [ ${bk_core} = WRFCHEM_PM25 ] ; then + cp ${BK_FILE} ./wrf_inout +fi +if [ ${bk_core} = CMAQ ] ; then + cp ${BK_FILE} ./cmaq_in.bin +fi + +# Link to the observation data +if [ ${obs_type} = MODISAOD ] ; then + ln -s ${PREPBUFR} ./modisbufr +fi +if [ ${obs_type} = PM25 ] ; then + ln -s ${PREPBUFR} ./pm25bufr +fi +# +################################################################################## + +echo " Copy fixed files and link CRTM coefficient files to working directory" + +# Set fixed files +# berror = forecast model background error statistics +# specoef = CRTM spectral coefficients +# trncoef = CRTM transmittance coefficients +# emiscoef = CRTM coefficients for IR sea surface emissivity model +# aerocoef = CRTM coefficients for aerosol effects +# cldcoef = CRTM coefficients for cloud effects +# satinfo = text file with information about assimilation of brightness temperatures +# satangl = angle dependent bias correction file (fixed in time) +# pcpinfo = text file with information about assimilation of prepcipitation rates +# ozinfo = text file with information about assimilation of ozone data +# errtable = text file with obs error for conventional data (regional only) +# convinfo = text file with information about assimilation of conventional data +# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.) +# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.) + +if [ ${bk_core} = WRFCHEM_GOCART ] ; then + BERROR=${FIX_ROOT}/${BYTE_ORDER}/wrf_chem_berror_big_endian + BERROR_CHEM=${FIX_ROOT}/${BYTE_ORDER}/wrf_chem_berror_big_endian + ANAVINFO=${FIX_ROOT}/anavinfo_wrfchem_gocart +fi +if [ ${bk_core} = WRFCHEM_PM25 ] ; then + BERROR=${FIX_ROOT}/${BYTE_ORDER}/wrf_chem_berror_big_endian + BERROR_CHEM=${FIX_ROOT}/${BYTE_ORDER}/wrf_chem_berror_big_endian + ANAVINFO=${FIX_ROOT}/anavinfo_wrfchem_pm25 +fi +if [ ${bk_core} = CMAQ ] ; then + BERROR=${FIX_ROOT}/${BYTE_ORDER}/cmaq_berror_big_endian + BERROR_CHEM=${FIX_ROOT}/${BYTE_ORDER}/cmaq_berror_big_endian + ANAVINFO=${FIX_ROOT}/anavinfo_cmaq_pm25 +fi + +AEROINFO=${FIX_ROOT}/aeroinfo_aod.txt +OBERROR=${FIX_ROOT}/nam_errtable.r3dv +SATANGL=${FIX_ROOT}/global_satangbias.txt +SATINFO=${FIX_ROOT}/global_satinfo.txt +CONVINFO=${FIX_ROOT}/global_convinfo.txt +OZINFO=${FIX_ROOT}/global_ozinfo.txt +PCPINFO=${FIX_ROOT}/global_pcpinfo.txt + +# copy Fixed fields to working directory + cp $ANAVINFO anavinfo + cp $BERROR berror_stats + cp $BERROR_CHEM berror_stats_chem + cp $SATANGL satbias_angle + cp $SATINFO satinfo + cp $CONVINFO convinfo + cp $OZINFO ozinfo + cp $PCPINFO pcpinfo + cp $OBERROR errtable + cp $AEROINFO aeroinfo +# +# # CRTM Spectral and Transmittance coefficients +CRTM_ROOT_ORDER=${CRTM_ROOT}/${BYTE_ORDER} +emiscoef_IRwater=${CRTM_ROOT_ORDER}/Nalli.IRwater.EmisCoeff.bin +emiscoef_IRice=${CRTM_ROOT_ORDER}/NPOESS.IRice.EmisCoeff.bin +emiscoef_IRland=${CRTM_ROOT_ORDER}/NPOESS.IRland.EmisCoeff.bin +emiscoef_IRsnow=${CRTM_ROOT_ORDER}/NPOESS.IRsnow.EmisCoeff.bin +emiscoef_VISice=${CRTM_ROOT_ORDER}/NPOESS.VISice.EmisCoeff.bin +emiscoef_VISland=${CRTM_ROOT_ORDER}/NPOESS.VISland.EmisCoeff.bin +emiscoef_VISsnow=${CRTM_ROOT_ORDER}/NPOESS.VISsnow.EmisCoeff.bin +emiscoef_VISwater=${CRTM_ROOT_ORDER}/NPOESS.VISwater.EmisCoeff.bin +emiscoef_MWwater=${CRTM_ROOT_ORDER}/FASTEM6.MWwater.EmisCoeff.bin +aercoef=${CRTM_ROOT_ORDER}/AerosolCoeff.bin +cldcoef=${CRTM_ROOT_ORDER}/CloudCoeff.bin + +ln -s $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin +ln -s $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin +ln -s $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin +ln -s $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin +ln -s $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin +ln -s $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin +ln -s $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin +ln -s $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin +ln -s $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin +ln -s $aercoef ./AerosolCoeff.bin +ln -s $cldcoef ./CloudCoeff.bin +# Copy CRTM coefficient files based on entries in satinfo file +for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do + ln -s ${CRTM_ROOT_ORDER}/${file}.SpcCoeff.bin ./ + ln -s ${CRTM_ROOT_ORDER}/${file}.TauCoeff.bin ./ +done + +for file in `awk '{if($1!~"!"){print $1}}' ./aeroinfo | sort | uniq` ;do + ln -s ${CRTM_ROOT_ORDER}/${file}.SpcCoeff.bin ./ + ln -s ${CRTM_ROOT_ORDER}/${file}.TauCoeff.bin ./ +done + +# Only need this file for single obs test + bufrtable=${FIX_ROOT}/prepobs_prep.bufrtable + cp $bufrtable ./prepobs_prep.bufrtable + +# for satellite bias correction +# Users may need to use their own satbias files for correct bias correction +cp ${GSI_ROOT}/fix/comgsi_satbias_in ./satbias_in +cp ${GSI_ROOT}/fix/comgsi_satbias_pc_in ./satbias_pc_in + +# +################################################################################## +# Set some parameters for use by the GSI executable and to build the namelist +echo " Build the namelist " + +if [ ${bk_core} = WRFCHEM_GOCART ] ; then + bk_core_arw='.true.' + bk_if_netcdf='.true.' + bk_core_cmaq='.false.' + bk_wrf_pm2_5='.false.' + bk_laeroana_gocart='.true.' +fi +if [ ${bk_core} = WRFCHEM_PM25 ] ; then + bk_core_arw='.true.' + bk_if_netcdf='.true.' + bk_core_cmaq='.false.' + bk_wrf_pm2_5='.true.' + bk_laeroana_gocart='.false.' +fi +if [ ${bk_core} = CMAQ ] ; then + bk_core_arw='.false.' + bk_if_netcdf='.false.' + bk_core_cmaq='.true.' + bk_wrf_pm2_5='.false.' + bk_laeroana_gocart='.false.' +fi + +# Build the GSI namelist on-the-fly +. $GSI_NAMELIST + +# +################################################### +# run GSI +################################################### +echo ' Run GSI with' ${bk_core} 'background' + +case $ARCH in + 'IBM_LSF') + ${RUN_COMMAND} ./gsi.x < gsiparm.anl > stdout 2>&1 ;; + + * ) + ${RUN_COMMAND} ./gsi.x > stdout 2>&1 ;; +esac + +################################################################## +# run time error check +################################################################## +error=$? + +if [ ${error} -ne 0 ]; then + echo "ERROR: ${GSI} crashed Exit status=${error}" + exit ${error} +fi + +# +################################################################## +# +# GSI updating satbias_in +# +# GSI updating satbias_in (only for cycling assimilation) + +# Copy the output to more understandable names +ln -s stdout stdout.anl.${ANAL_TIME} +ln -s wrf_inout wrfanl.${ANAL_TIME} +ln -s fort.201 fit_p1.${ANAL_TIME} +ln -s fort.202 fit_w1.${ANAL_TIME} +ln -s fort.203 fit_t1.${ANAL_TIME} +ln -s fort.204 fit_q1.${ANAL_TIME} +ln -s fort.207 fit_rad1.${ANAL_TIME} + +# Loop over first and last outer loops to generate innovation +# diagnostic files for indicated observation types (groups) +# +# NOTE: Since we set miter=2 in GSI namelist SETUP, outer +# loop 03 will contain innovations with respect to +# the analysis. Creation of o-a innovation files +# is triggered by write_diag(3)=.true. The setting +# write_diag(1)=.true. turns on creation of o-g +# innovation files. +# + +loops="01 03" +for loop in $loops; do + +case $loop in + 01) string=ges;; + 03) string=anl;; + *) string=$loop;; +esac + +# Collect diagnostic files for obs types (groups) below +# listall="conv amsua_metop-a mhs_metop-a hirs4_metop-a hirs2_n14 msu_n14 \ +# sndr_g08 sndr_g10 sndr_g12 sndr_g08_prep sndr_g10_prep sndr_g12_prep \ +# sndrd1_g08 sndrd2_g08 sndrd3_g08 sndrd4_g08 sndrd1_g10 sndrd2_g10 \ +# sndrd3_g10 sndrd4_g10 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 \ +# hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 \ +# amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua \ +# goes_img_g08 goes_img_g10 goes_img_g11 goes_img_g12 \ +# pcp_ssmi_dmsp pcp_tmi_trmm sbuv2_n16 sbuv2_n17 sbuv2_n18 \ +# omi_aura ssmi_f13 ssmi_f14 ssmi_f15 hirs4_n18 amsua_n18 mhs_n18 \ +# amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_las_f16 \ +# ssmis_uas_f16 ssmis_img_f16 ssmis_env_f16 mhs_metop_b \ +# hirs4_metop_b hirs4_n19 amusa_n19 mhs_n19" + listall=`ls pe* | cut -f2 -d"." | awk '{print substr($0, 0, length($0)-3)}' | sort | uniq ` + + for type in $listall; do + count=`ls pe*${type}_${loop}* | wc -l` + if [[ $count -gt 0 ]]; then + cat pe*${type}_${loop}* > diag_${type}_${string}.${ANAL_TIME} + fi + done +done + +# Clean working directory to save only important files +ls -l * > list_run_directory +if [[ ${if_clean} = clean ]]; then + echo ' Clean working directory after GSI run' + rm -f *Coeff.bin # all CRTM coefficient files + rm -f pe0* # diag files on each processor + rm -f obs_input.* # observation middle files + rm -f siganl sigf0? # background middle files + rm -f fsize_* # delete temperal file for bufr size +fi +# +# +exit 0 diff --git a/ush/comgsi_run_gfs.ksh b/ush/comgsi_run_gfs.ksh new file mode 100755 index 000000000..d3fda451a --- /dev/null +++ b/ush/comgsi_run_gfs.ksh @@ -0,0 +1,734 @@ +#!/bin/ksh +##################################################### +# machine set up (users should change this part) +##################################################### + + +set -x +# GSIPROC = processor number used for GSI analysis +#------------------------------------------------ + GSIPROC=1 + ARCH='LINUX_LSF' +# Supported configurations: + # IBM_LSF, + # LINUX, LINUX_LSF, LINUX_PBS, + # DARWIN_PGI +# +##################################################### +# case set up (users should change this part) +##################################################### +# +# GFSCASE = cases used for DTC test +# T574, T254, T126, T62, enkf_glb_t62 +# ANAL_TIME= analysis time (YYYYMMDDHH) +# WORK_ROOT= working directory, where GSI runs +# PREPBURF = path of PreBUFR conventional obs +# BK_ROOT = path of background files +# OBS_ROOT = path of observations files +# FIX_ROOT = path of fix files +# GSI_EXE = path and name of the gsi executable + ANAL_TIME=2014080400 + GFSCASE=T62 + JOB_DIR=the_job_directory + #normally you put run scripts here and submit jobs form here, require a copy of gsi.x at this directory + RUN_NAME=a_descriptive_run_name_such_as_case05_3denvar_etc + OBS_ROOT=the_directory_where_observation_files_are_located + BK_ROOT=the_directory_where_background_files_are_located + GSI_ROOT=the_comgsi_main directory where src/ ush/ fix/ etc are located + CRTM_ROOT=the_CRTM_directory + GSI_EXE=${JOB_DIR}/gsi.x #assume you have a copy of gsi.x here + WORK_ROOT=${JOB_DIR}/${RUN_NAME} + FIX_ROOT=${GSI_ROOT}/fix + GSI_NAMELIST=${GSI_ROOT}/ush/comgsi_namelist_gfs.sh + PREPBUFR=${OBS_ROOT}/prepbufr + FIX_ROOT=${GSI_ROOT}/fix +# +# ENS_ROOT=the_directory_where_ensemble_backgrounds_are_located +#------------------------------------------------ +# if_clean = clean : delete temperal files in working directory (default) +# no : leave running directory as is (this is for debug only) + if_clean=clean + +# if_observer = Yes : only used as observation operater for enkf +# no_member number of ensemble members +# BK_FILE_mem path and base for ensemble members + if_observer=No # Yes ,or, No -- case sensitive!!! + no_member=10 + PDYa=`echo $ANAL_TIME | cut -c1-8` + cyca=`echo $ANAL_TIME | cut -c9-10` + gdate=`date -u -d "$PDYa $cyca -6 hour" +%Y%m%d%H` #guess date is 6hr ago + BK_FILE_mem=${BK_ROOT}/sfg_${gdate} + +# +# Set the JCAP resolution which you want. +# All resolutions use LEVS=64 +if [[ "$GFSCASE" = "T62" ]]; then + JCAP=62 + JCAP_B=62 +elif [[ "$GFSCASE" = "T126" ]]; then + JCAP=126 + JCAP_B=126 +elif [[ "$GFSCASE" = "enkf_glb_t62" ]]; then + JCAP=62 + JCAP_B=62 +elif [[ "$GFSCASE" = "T254" ]]; then + JCAP=254 + JCAP_B=574 +elif [[ "$GFSCASE" = "T574" ]]; then + JCAP=574 + JCAP_B=1534 +else + echo "INVALID case = $GFSCASE" + exit +fi + LEVS=64 +# +# + BYTE_ORDER=Big_Endian +# +##################################################### +# Users should NOT change script after this point +##################################################### +# + +case $ARCH in + 'IBM_LSF') + ###### IBM LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX') + if [ $GSIPROC = 1 ]; then + #### Linux workstation - single processor + RUN_COMMAND="" + else + ###### Linux workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} " + fi ;; + + 'LINUX_LSF') + ###### LINUX LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX_PBS') + #### Linux cluster PBS (Portable Batch System) + RUN_COMMAND="mpirun -np ${GSIPROC} " ;; + + 'DARWIN_PGI') + ### Mac - mpi run + if [ $GSIPROC = 1 ]; then + #### Mac workstation - single processor + RUN_COMMAND="" + else + ###### Mac workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} -machinefile ~/mach " + fi ;; + + * ) + print "error: $ARCH is not a supported platform configuration." + exit 1 ;; +esac + + +################################################################################## +# Check GSI needed environment variables are defined and exist +# + +# Make sure ANAL_TIME is defined and in the correct format +if [ ! "${ANAL_TIME}" ]; then + echo "ERROR: \$ANAL_TIME is not defined!" + exit 1 +fi + +# Make sure WORK_ROOT is defined and exists +if [ ! "${WORK_ROOT}" ]; then + echo "ERROR: \$WORK_ROOT is not defined!" + exit 1 +fi + +# Make sure the background file exists +if [ ! -r "${BK_ROOT}" ]; then + echo "ERROR: ${BK_ROOT} does not exist!" + exit 1 +fi + +# Make sure OBS_ROOT is defined and exists +if [ ! "${OBS_ROOT}" ]; then + echo "ERROR: \$OBS_ROOT is not defined!" + exit 1 +fi +if [ ! -d "${OBS_ROOT}" ]; then + echo "ERROR: OBS_ROOT directory '${OBS_ROOT}' does not exist!" + exit 1 +fi + +# Set the path to the GSI static files +if [ ! "${FIX_ROOT}" ]; then + echo "ERROR: \$FIX_ROOT is not defined!" + exit 1 +fi +if [ ! -d "${FIX_ROOT}" ]; then + echo "ERROR: fix directory '${FIX_ROOT}' does not exist!" + exit 1 +fi + +# Set the path to the CRTM coefficients +if [ ! "${CRTM_ROOT}" ]; then + echo "ERROR: \$CRTM_ROOT is not defined!" + exit 1 +fi +if [ ! -d "${CRTM_ROOT}" ]; then + echo "ERROR: fix directory '${CRTM_ROOT}' does not exist!" + exit 1 +fi + + +# Make sure the GSI executable exists +if [ ! -x "${GSI_EXE}" ]; then + echo "ERROR: ${GSI_EXE} does not exist!" + exit 1 +fi + +# Check to make sure the number of processors for running GSI was specified +if [ -z "${GSIPROC}" ]; then + echo "ERROR: The variable $GSIPROC must be set to contain the number of processors to run GSI" + exit 1 +fi + +################################################################################ +## Given the analysis date, compute the date from which the +# first guess comes. Extract cycle and set prefix +# for guess and observation data files +#hha=`echo $ANAL_TIME | cut -c9-10` +#hhg=`echo $GUESS_TIME | cut -c9-10` + +# +################################################################################## +# Create the ram work directory and cd into it + +workdir=${WORK_ROOT} +echo " Create working directory:" ${workdir} + +if [ -d "${workdir}" ]; then + rm -rf ${workdir} +fi +mkdir -p ${workdir} +cd ${workdir} + +# +################################################################################## +# Set some parameters for use by the GSI executable and to build the namelist +echo " Build the namelist " + +# Given the requested resolution, set dependent resolution parameters +if [[ "$JCAP" = "382" ]]; then + LONA=768 + LATA=384 + DELTIM=180 + resol=1 +elif [[ "$JCAP" = "574" ]]; then + LONA=1152 + LATA=576 + DELTIM=1200 + resol=2 +elif [[ "$JCAP" = "254" ]]; then + LONA=512 + LATA=256 + DELTIM=1200 + resol=2 +elif [[ "$JCAP" = "126" ]]; then + LONA=256 + LATA=128 + DELTIM=1200 + resol=2 +elif [[ "$JCAP" = "62" ]]; then + LONA=192 + LATA=94 + DELTIM=1200 + resol=2 +else + echo "INVALID JCAP = $JCAP" + exit +fi +NLAT=` expr $LATA + 2 ` + +# CO2 namelist and file decisions +ICO2=${ICO2:-0} +if [ $ICO2 -gt 0 ] ; then + # Copy co2 files to $workdir + co2dir=${FIX_ROOT} + yyyy=`echo $ANAL_TIME | cut -c1-4` + rm ./global_co2_data.txt + co2=$co2dir/global_co2.gcmscl_$yyyy.txt + while [ ! -s $co2 ] ; do + ((yyyy-=1)) + co2=$co2dir/global_co2.gcmscl_$yyyy.txt + done + if [ -s $co2 ] ; then + cp $co2 ./global_co2_data.txt + fi + if [ ! -s ./global_co2_data.txt ] ; then + echo "\./global_co2_data.txt" not created + exit 1 + fi +fi +#CH4 file decision +ICH4=${ICH4:-0} +if [ $ICH4 -gt 0 ] ; then +# # Copy ch4 files to $workdir + ch4dir=${FIX_ROOT} + yyyy=`echo $ANAL_TIME | cut -c1-4` + rm ./ch4globaldata.txt + ch4=$ch4dir/global_ch4_esrlctm_$yyyy.txt + while [ ! -s $ch4 ] ; do + ((yyyy-=1)) + ch4=$ch4dir/global_ch4_esrlctm_$yyyy.txt + done + if [ -s $ch4 ] ; then + cp $ch4 ./ch4globaldata.txt + fi + if [ ! -s ./ch4globaldata.txt ] ; then + echo "\./ch4globaldata.txt" not created + exit 1 + fi +fi +IN2O=${IN2O:-0} +if [ $IN2O -gt 0 ] ; then +# # Copy ch4 files to $workdir + n2odir=${FIX_ROOT} + yyyy=`echo $ANAL_TIME | cut -c1-4` + rm ./n2oglobaldata.txt + n2o=$n2odir/global_n2o_esrlctm_$yyyy.txt + while [ ! -s $n2o ] ; do + ((yyyy-=1)) + n2o=$n2odir/global_n2o_esrlctm_$yyyy.txt + done + if [ -s $n2o ] ; then + cp $n2o ./n2oglobaldata.txt + fi + if [ ! -s ./n2oglobaldata.txt ] ; then + echo "\./n2oglobaldata.txt" not created + exit 1 + fi +fi +ICO=${ICO:-0} +if [ $ICO -gt 0 ] ; then +# # Copy CO files to $workdir + codir=${FIX_ROOT} + yyyy=`echo $ANAL_TIME | cut -c1-4` + rm ./coglobaldata.txt + co=$codir/global_co_esrlctm_$yyyy.txt + while [ ! -s $co ] ; do + ((yyyy-=1)) + co=$codir/global_co_esrlctm_$yyyy.txt + done + if [ -s $co ] ; then + cp $co ./coglobaldata.txt + fi + if [ ! -s ./coglobaldata.txt ] ; then + echo "\./coglobaldata.txt" not created + exit 1 + fi +fi + +################################################################################## +# Set some parameters for use by the GSI executable and to build the namelist +echo " Build the namelist " + +vs_op='0.7,' +hzscl_op='1.7,0.8,0.5,' + +if [ ${if_observer} = Yes ] ; then + nummiter=0 + if_read_obs_save='.true.' + if_read_obs_skip='.false.' +else + nummiter=2 + if_read_obs_save='.false.' + if_read_obs_skip='.false.' +fi + +# Build the GSI namelist on-the-fly +. $GSI_NAMELIST + +################################################################################## + +echo " Copy GSI executable, background file, and link observation bufr to working directory" + +# Save a copy of the GSI executable in the workdir +cp ${GSI_EXE} gsi.x + +# Bring over background field (it's modified by GSI so we can't link to it) +# Copy bias correction, atmospheric and surface files +if [[ "$GFSCASE" = "enkf_glb_t62" ]]; then + cp $BK_ROOT/bfg_${gdate}_fhr03_ensmean ./sfcf03 + cp $BK_ROOT/bfg_${gdate}_fhr06_ensmean ./sfcf06 + cp $BK_ROOT/bfg_${gdate}_fhr09_ensmean ./sfcf09 + + cp $BK_ROOT/sfg_${gdate}_fhr03_mem001 ./sigf03 + cp $BK_ROOT/sfg_${gdate}_fhr06_mem001 ./sigf06 + cp $BK_ROOT/sfg_${gdate}_fhr09_mem001 ./sigf09 +else + + cp $BK_ROOT/sfcf03 ./sfcf03 + cp $BK_ROOT/sfcf06 ./sfcf06 + cp $BK_ROOT/sfcf09 ./sfcf09 + + cp $BK_ROOT/sigf03 ./sigf03 + cp $BK_ROOT/sigf06 ./sigf06 + cp $BK_ROOT/sigf09 ./sigf09 +fi + +cp ${GSI_ROOT}/fix/comgsi_satbias_in ./satbias_in +cp ${GSI_ROOT}/fix/comgsi_satbias_pc_in ./satbias_pc_in + +# link GFS ensemble files +# ln -s $ENS_ROOT/sigf06_ens_mem* . +# link the localization file +# ln -s ${ENS_ROOT}/hybens_locinfo . +# Link to the prepbufr data +ln -s ${PREPBUFR} ./prepbufr + +# Link to the other observation data +if [ -r "${OBS_ROOT}/satwnd" ]; then + ln -s ${OBS_ROOT}/satwnd . +fi +if [ -r "${OBS_ROOT}/gpsrobufr" ]; then + ln -s ${OBS_ROOT}/gpsrobufr . +fi +if [ -r "${OBS_ROOT}/ssmirrbufr" ]; then + ln -s ${OBS_ROOT}/ssmirrbufr . +fi +if [ -r "${OBS_ROOT}/tmirrbufr" ]; then + ln -s ${OBS_ROOT}/tmirrbufr . +fi +if [ -r "${OBS_ROOT}/sbuvbufr" ]; then + ln -s ${OBS_ROOT}/sbuvbufr . +fi +if [ -r "${OBS_ROOT}/gsnd1bufr" ]; then + ln -s ${OBS_ROOT}/gsnd1bufr . +fi +if [ -r "${OBS_ROOT}/amsuabufr" ]; then + ln -s ${OBS_ROOT}/amsuabufr amsuabufr +fi +if [ -r "${OBS_ROOT}/amsubbufr" ]; then + ln -s ${OBS_ROOT}/amsubbufr amsubbufr +fi +if [ -r "${OBS_ROOT}/hirs2bufr" ]; then + ln -s ${OBS_ROOT}/hirs2bufr . +fi +if [ -r "${OBS_ROOT}/hirs3bufr" ]; then + ln -s ${OBS_ROOT}/hirs3bufr . +fi +if [ -r "${OBS_ROOT}/hirs4bufr" ]; then + ln -s ${OBS_ROOT}/hirs4bufr . +fi +if [ -r "${OBS_ROOT}/mhsbufr" ]; then + ln -s ${OBS_ROOT}/mhsbufr . +fi +if [ -r "${OBS_ROOT}//msubufr" ]; then + ln -s ${OBS_ROOT}/msubufr . +fi +if [ -r "${OBS_ROOT}//airsbufr" ]; then + ln -s ${OBS_ROOT}/airsbufr . +fi +if [ -r "${OBS_ROOT}//atmsbufr" ]; then + ln -s ${OBS_ROOT}/atmsbufr . +fi +if [ -r "${OBS_ROOT}//crisbufr" ]; then + ln -s ${OBS_ROOT}/crisbufr . +fi +if [ -r "${OBS_ROOT}//seviribufr" ]; then + ln -s ${OBS_ROOT}/seviribufr . +fi +if [ -r "${OBS_ROOT}//iasibufr" ]; then + ln -s ${OBS_ROOT}/iasibufr . +fi +if [ -r "${OBS_ROOT}//ssmitbufr" ]; then + ln -s ${OBS_ROOT}/ssmitbufr . +fi +if [ -r "${OBS_ROOT}//amsrebufr" ]; then + ln -s ${OBS_ROOT}/amsrebufr . +fi +if [ -r "${OBS_ROOT}//ssmisbufr" ]; then + ln -s ${OBS_ROOT}/ssmisbufr . +fi +if [ -r "${OBS_ROOT}//gomebufr" ]; then + ln -s ${OBS_ROOT}/gomebufr . +fi +if [ -r "${OBS_ROOT}//omibufr" ]; then + ln -s ${OBS_ROOT}/omibufr . +fi +if [ -r "${OBS_ROOT}/mlsbufr" ]; then + ln -s ${OBS_ROOT}/mlsbufr . +fi +if [ -r "${OBS_ROOT}/hirs3bufrears" ]; then + ln -s ${OBS_ROOT}/hirs3bufrears . +fi +if [ -r "${OBS_ROOT}/amsuabufrears" ]; then + ln -s ${OBS_ROOT}/amsuabufrears . +fi +if [ -r "${OBS_ROOT}/amsubbufrears" ]; then + ln -s ${OBS_ROOT}/amsubbufrears . +fi +if [ -r "${OBS_ROOT}/tcvitl" ]; then + ln -s ${OBS_ROOT}/tcvitl . +fi +if [ -r "${OBS_ROOT}/satwndbufr" ]; then + ln -s ${OBS_ROOT}/satwndbufr . +fi + + +# +################################################################################## + +echo " Copy fixed files and link CRTM coefficient files to working directory" + +# Set fixed files +# berror = forecast model background error statistics +# specoef = CRTM spectral coefficients +# trncoef = CRTM transmittance coefficients +# emiscoef = CRTM coefficients for IR sea surface emissivity model +# aerocoef = CRTM coefficients for aerosol effects +# cldcoef = CRTM coefficients for cloud effects +# satinfo = text file with information about assimilation of brightness temperatures +# satangl = angle dependent bias correction file (fixed in time) +# pcpinfo = text file with information about assimilation of prepcipitation rates +# ozinfo = text file with information about assimilation of ozone data +# errtable = text file with obs error for conventional data (regional only) +# convinfo = text file with information about assimilation of conventional data +# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.) +# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.) + +ANAVINFO=${FIX_ROOT}/global_anavinfo.l64.txt +BERROR=${FIX_ROOT}/${BYTE_ORDER}/global_berror.l${LEVS}y${NLAT}.f77 +SATINFO=${FIX_ROOT}/global_satinfo.txt +scaninfo=${FIX_ROOT}/global_scaninfo.txt +SATANGL=${FIX_ROOT}/global_satangbias.txt +atmsbeamdat=${FIX_ROOT}/atms_beamwidth.txt +CONVINFO=${FIX_ROOT}/global_convinfo_reg_test.txt +OZINFO=${FIX_ROOT}/global_ozinfo.txt +PCPINFO=${FIX_ROOT}/global_pcpinfo.txt +OBERROR=${FIX_ROOT}/prepobs_errtable.global +CLOUDYRADINFO=${FIX_ROOT}/cloudy_radiance_info.txt +HYBENSINFO=${FIX_ROOT}/global_hybens_info.l64.txt + +# Only need this file for single obs test +bufrtable=${FIX_ROOT}/prepobs_prep.bufrtable + +# Only need this file for sst retrieval +bftab_sst=${FIX_ROOT}/bufrtab.012 + +# copy Fixed fields to working directory + cp $ANAVINFO anavinfo + cp $BERROR berror_stats + cp $SATANGL satbias_angle + cp $atmsbeamdat atms_beamwidth.txt + cp $SATINFO satinfo + cp $scaninfo scaninfo + cp $CONVINFO convinfo + cp $OZINFO ozinfo + cp $PCPINFO pcpinfo + cp $OBERROR errtable + cp $CLOUDYRADINFO cloudy_radiance_info.txt + cp $HYBENSINFO hybens_info + + cp $bufrtable ./prepobs_prep.bufrtable + cp $bftab_sst ./bftab_sstphr + +# +# CRTM Spectral and Transmittance coefficients +RTMFIX=${CRTM_ROOT}/${BYTE_ORDER} +emiscoef_IRwater=${RTMFIX}/Nalli.IRwater.EmisCoeff.bin +emiscoef_IRice=${RTMFIX}/NPOESS.IRice.EmisCoeff.bin +emiscoef_IRland=${RTMFIX}/NPOESS.IRland.EmisCoeff.bin +emiscoef_IRsnow=${RTMFIX}/NPOESS.IRsnow.EmisCoeff.bin +emiscoef_VISice=${RTMFIX}/NPOESS.VISice.EmisCoeff.bin +emiscoef_VISland=${RTMFIX}/NPOESS.VISland.EmisCoeff.bin +emiscoef_VISsnow=${RTMFIX}/NPOESS.VISsnow.EmisCoeff.bin +emiscoef_VISwater=${RTMFIX}/NPOESS.VISwater.EmisCoeff.bin +emiscoef_MWwater=${RTMFIX}/FASTEM6.MWwater.EmisCoeff.bin +aercoef=${RTMFIX}/AerosolCoeff.bin +cldcoef=${RTMFIX}/CloudCoeff.bin + +ln -s $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin +ln -s $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin +ln -s $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin +ln -s $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin +ln -s $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin +ln -s $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin +ln -s $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin +ln -s $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin +ln -s $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin +ln -s $aercoef ./AerosolCoeff.bin +ln -s $cldcoef ./CloudCoeff.bin +# Copy CRTM coefficient files based on entries in satinfo file +for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do + ln -s ${RTMFIX}/${file}.SpcCoeff.bin ./ + ln -s ${RTMFIX}/${file}.TauCoeff.bin ./ +done + +# +################################################### +# run GSI +################################################### +echo ' Run GSI with' ${bk_core} 'background' + +case $ARCH in + 'IBM_LSF') + ${RUN_COMMAND} ./gsi.x < gsiparm.anl > stdout 2>&1 ;; + + * ) + ${RUN_COMMAND} ./gsi.x > stdout 2>&1 ;; +esac + +################################################################## +# run time error check +################################################################## +error=$? + +if [ ${error} -ne 0 ]; then + echo "ERROR: ${GSI} crashed Exit status=${error}" + exit ${error} +fi +# +################################################################## +# +# Copy the output to more understandable names +ln -s stdout stdout.anl.${ANAL_TIME} +ln -s fort.201 fit_p1.${ANAL_TIME} +ln -s fort.202 fit_w1.${ANAL_TIME} +ln -s fort.203 fit_t1.${ANAL_TIME} +ln -s fort.204 fit_q1.${ANAL_TIME} +ln -s fort.207 fit_rad1.${ANAL_TIME} + +# Loop over first and last outer loops to generate innovation +# diagnostic files for indicated observation types (groups) +# +# NOTE: Since we set miter=2 in GSI namelist SETUP, outer +# loop 03 will contain innovations with respect to +# the analysis. Creation of o-a innovation files +# is triggered by write_diag(3)=.true. The setting +# write_diag(1)=.true. turns on creation of o-g +# innovation files. +# + +echo "Time before diagnostic loop is `date` " +loops="01 03" +for loop in $loops; do + +case $loop in + 01) string=ges;; + 03) string=anl;; + *) string=$loop;; +esac + +# Collect diagnostic files for obs types (groups) below + listall=`ls pe* | cut -f2 -d"." | awk '{print substr($0, 0, length($0)-3)}' | sort | uniq ` + + for type in $listall; do + count=`ls pe*${type}_${loop}* | wc -l` + if [[ $count -gt 0 ]]; then + cat pe*${type}_${loop}* > diag_${type}_${string}.${ANAL_TIME} + fi + done +done + +# Clean working directory to save only important files +ls -l * > list_run_directory +if [[ ${if_clean} = clean && ${if_observer} != Yes ]]; then + echo ' Clean working directory after GSI run' + rm -f *Coeff.bin # all CRTM coefficient files + rm -fr pe0* # diag files on each processor + rm -f obs_input.* # observation middle files + rm -f sigf* sfcf* # background files + rm -f fsize_* # delete temperal file for bufr size +fi + +################################################# +# start to calculate diag files for each member +################################################# +# +if [ ${if_observer} = Yes ] ; then + string=ges + for type in $listall; do + count=0 + if [[ -f diag_${type}_${string}.${ANAL_TIME} ]]; then + mv diag_${type}_${string}.${ANAL_TIME} diag_${type}_${string}.ensmean + fi + done + +# Build the GSI namelist on-the-fly for each member + nummiter=0 + if_read_obs_save='.false.' + if_read_obs_skip='.true.' +. $GSI_NAMELIST + +# Loop through each member + loop="01" + ensmem=1 + while [[ $ensmem -le $no_member ]];do + + rm pe0* + + print "\$ensmem is $ensmem" + ensmemid=`printf %3.3i $ensmem` + +# get new background for each member + if [[ -f sigf03 ]]; then + rm sigf03 + fi + if [[ -f sigf06 ]]; then + rm sigf06 + fi + if [[ -f sigf09 ]]; then + rm sigf09 + fi + + BK_FILE03=${BK_FILE_mem}_fhr03_mem${ensmemid} + BK_FILE06=${BK_FILE_mem}_fhr06_mem${ensmemid} + BK_FILE09=${BK_FILE_mem}_fhr09_mem${ensmemid} + echo $BK_FILE06 + ln -s $BK_FILE03 ./sigf03 + ln -s $BK_FILE06 ./sigf06 + ln -s $BK_FILE09 ./sigf09 + +# run GSI + echo ' Run GSI with' ${bk_core} 'for member ', ${ensmemid} + + case $ARCH in + 'IBM_LSF') + ${RUN_COMMAND} ./gsi.x < gsiparm.anl > stdout_mem${ensmemid} 2>&1 ;; + + * ) + ${RUN_COMMAND} ./gsi.x > stdout_mem${ensmemid} 2>&1 ;; + esac + +# run time error check and save run time file status + error=$? + + if [ ${error} -ne 0 ]; then + echo "ERROR: ${GSI} crashed for member ${ensmemid} Exit status=${error}" + exit ${error} + fi + + ls -l * > list_run_directory_mem${ensmemid} + +# generate diag files + + for type in $listall; do + count=`ls pe*${type}_${loop}* | wc -l` + if [[ $count -gt 0 ]]; then + cat pe*${type}_${loop}* > diag_${type}_${string}.mem${ensmemid} + fi + done + +# next member + (( ensmem += 1 )) + + done + +fi + +exit 0 + +exit 0 diff --git a/ush/comgsi_run_regional.ksh b/ush/comgsi_run_regional.ksh new file mode 100755 index 000000000..b6cb7db64 --- /dev/null +++ b/ush/comgsi_run_regional.ksh @@ -0,0 +1,671 @@ +#!/bin/ksh +##################################################### +# machine set up (users should change this part) +##################################################### + +set -x +# +# GSIPROC = processor number used for GSI analysis +#------------------------------------------------ + GSIPROC=1 + ARCH='LINUX_LSF' + +# Supported configurations: + # IBM_LSF, + # LINUX, LINUX_LSF, LINUX_PBS, + # DARWIN_PGI +# +##################################################### +# case set up (users should change this part) +##################################################### +# +# ANAL_TIME= analysis time (YYYYMMDDHH) +# WORK_ROOT= working directory, where GSI runs +# PREPBURF = path of PreBUFR conventional obs +# BK_FILE = path and name of background file +# OBS_ROOT = path of observations files +# FIX_ROOT = path of fix files +# GSI_EXE = path and name of the gsi executable +# ENS_ROOT = path where ensemble background files exist + ANAL_TIME=2017051318 + JOB_DIR=the_job_directory + #normally you put run scripts here and submit jobs form here, require a copy of gsi.x at this directory + RUN_NAME=a_descriptive_run_name_such_as_case05_3denvar_etc + OBS_ROOT=the_directory_where_observation_files_are_located + BK_ROOT=the_directory_where_background_files_are_located + GSI_ROOT=the_comgsi_main directory where src/ ush/ fix/ etc are located + CRTM_ROOT=the_CRTM_directory + ENS_ROOT=the_directory_where_ensemble_backgrounds_are_located + #ENS_ROOT is not required if not running hybrid EnVAR + HH=`echo $ANAL_TIME | cut -c9-10` + GSI_EXE=${JOB_DIR}/gsi.x #assume you have a copy of gsi.x here + WORK_ROOT=${JOB_DIR}/${RUN_NAME} + FIX_ROOT=${GSI_ROOT}/fix + GSI_NAMELIST=${GSI_ROOT}/ush/comgsi_namelist.sh + PREPBUFR=${OBS_ROOT}/nam.t${HH}z.prepbufr.tm00 + BK_FILE=${BK_ROOT}/wrfinput_d01.${ANAL_TIME} +# +#------------------------------------------------ +# bk_core= which WRF core is used as background (NMM or ARW or NMMB) +# bkcv_option= which background error covariance and parameter will be used +# (GLOBAL or NAM) +# if_clean = clean : delete temperal files in working directory (default) +# no : leave running directory as is (this is for debug only) +# if_observer = Yes : only used as observation operater for enkf +# if_hybrid = Yes : Run GSI as 3D/4D EnVar +# if_4DEnVar = Yes : Run GSI as 4D EnVar +# if_nemsio = Yes : The GFS background files are in NEMSIO format +# if_oneob = Yes : Do single observation test + if_hybrid=No # Yes, or, No -- case sensitive ! + if_4DEnVar=No # Yes, or, No -- case sensitive (set if_hybrid=Yes first)! + if_observer=No # Yes, or, No -- case sensitive ! + if_nemsio=No # Yes, or, No -- case sensitive ! + if_oneob=No # Yes, or, No -- case sensitive ! + + bk_core=ARW + bkcv_option=NAM + if_clean=clean +# +# setup whether to do single obs test + if [ ${if_oneob} = Yes ]; then + if_oneobtest='.true.' + else + if_oneobtest='.false.' + fi +# +# setup for GSI 3D/4D EnVar hybrid + if [ ${if_hybrid} = Yes ] ; then + PDYa=`echo $ANAL_TIME | cut -c1-8` + cyca=`echo $ANAL_TIME | cut -c9-10` + gdate=`date -u -d "$PDYa $cyca -6 hour" +%Y%m%d%H` #guess date is 6hr ago + gHH=`echo $gdate |cut -c9-10` + datem1=`date -u -d "$PDYa $cyca -1 hour" +%Y-%m-%d_%H:%M:%S` #1hr ago + datep1=`date -u -d "$PDYa $cyca 1 hour" +%Y-%m-%d_%H:%M:%S` #1hr later + if [ ${if_nemsio} = Yes ]; then + if_gfs_nemsio='.true.' + ENSEMBLE_FILE_mem=${ENS_ROOT}/gdas.t${gHH}z.atmf006s.mem + else + if_gfs_nemsio='.false.' + ENSEMBLE_FILE_mem=${ENS_ROOT}/sfg_${gdate}_fhr06s_mem + fi + + if [ ${if_4DEnVar} = Yes ] ; then + BK_FILE_P1=${BK_ROOT}/wrfout_d01_${datep1} + BK_FILE_M1=${BK_ROOT}/wrfout_d01_${datem1} + + if [ ${if_nemsio} = Yes ]; then + ENSEMBLE_FILE_mem_p1=${ENS_ROOT}/gdas.t${gHH}z.atmf009s.mem + ENSEMBLE_FILE_mem_m1=${ENS_ROOT}/gdas.t${gHH}z.atmf003s.mem + else + ENSEMBLE_FILE_mem_p1=${ENS_ROOT}/sfg_${gdate}_fhr09s_mem + ENSEMBLE_FILE_mem_m1=${ENS_ROOT}/sfg_${gdate}_fhr03s_mem + fi + fi + fi + +# The following two only apply when if_observer = Yes, i.e. run observation operator for EnKF +# no_member number of ensemble members +# BK_FILE_mem path and base for ensemble members + no_member=20 + BK_FILE_mem=${BK_ROOT}/wrfarw.mem +# +# +##################################################### +# Users should NOT make changes after this point +##################################################### +# +BYTE_ORDER=Big_Endian +# BYTE_ORDER=Little_Endian + +case $ARCH in + 'IBM_LSF') + ###### IBM LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX') + if [ $GSIPROC = 1 ]; then + #### Linux workstation - single processor + RUN_COMMAND="" + else + ###### Linux workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} " + fi ;; + + 'LINUX_LSF') + ###### LINUX LSF (Load Sharing Facility) + RUN_COMMAND="mpirun.lsf " ;; + + 'LINUX_PBS') + #### Linux cluster PBS (Portable Batch System) + RUN_COMMAND="mpirun -np ${GSIPROC} " ;; + + 'DARWIN_PGI') + ### Mac - mpi run + if [ $GSIPROC = 1 ]; then + #### Mac workstation - single processor + RUN_COMMAND="" + else + ###### Mac workstation - mpi run + RUN_COMMAND="mpirun -np ${GSIPROC} -machinefile ~/mach " + fi ;; + + * ) + print "error: $ARCH is not a supported platform configuration." + exit 1 ;; +esac + + +################################################################################## +# Check GSI needed environment variables are defined and exist +# + +# Make sure ANAL_TIME is defined and in the correct format +if [ ! "${ANAL_TIME}" ]; then + echo "ERROR: \$ANAL_TIME is not defined!" + exit 1 +fi + +# Make sure WORK_ROOT is defined and exists +if [ ! "${WORK_ROOT}" ]; then + echo "ERROR: \$WORK_ROOT is not defined!" + exit 1 +fi + +# Make sure the background file exists +if [ ! -r "${BK_FILE}" ]; then + echo "ERROR: ${BK_FILE} does not exist!" + exit 1 +fi + +# Make sure OBS_ROOT is defined and exists +if [ ! "${OBS_ROOT}" ]; then + echo "ERROR: \$OBS_ROOT is not defined!" + exit 1 +fi +if [ ! -d "${OBS_ROOT}" ]; then + echo "ERROR: OBS_ROOT directory '${OBS_ROOT}' does not exist!" + exit 1 +fi + +# Set the path to the GSI static files +if [ ! "${FIX_ROOT}" ]; then + echo "ERROR: \$FIX_ROOT is not defined!" + exit 1 +fi +if [ ! -d "${FIX_ROOT}" ]; then + echo "ERROR: fix directory '${FIX_ROOT}' does not exist!" + exit 1 +fi + +# Set the path to the CRTM coefficients +if [ ! "${CRTM_ROOT}" ]; then + echo "ERROR: \$CRTM_ROOT is not defined!" + exit 1 +fi +if [ ! -d "${CRTM_ROOT}" ]; then + echo "ERROR: fix directory '${CRTM_ROOT}' does not exist!" + exit 1 +fi + + +# Make sure the GSI executable exists +if [ ! -x "${GSI_EXE}" ]; then + echo "ERROR: ${GSI_EXE} does not exist!" + exit 1 +fi + +# Check to make sure the number of processors for running GSI was specified +if [ -z "${GSIPROC}" ]; then + echo "ERROR: The variable $GSIPROC must be set to contain the number of processors to run GSI" + exit 1 +fi + +# +################################################################################## +# Create the ram work directory and cd into it + +workdir=${WORK_ROOT} +echo " Create working directory:" ${workdir} + +if [ -d "${workdir}" ]; then + rm -rf ${workdir} +fi +mkdir -p ${workdir} +cd ${workdir} + +# +################################################################################## + +echo " Copy GSI executable, background file, and link observation bufr to working directory" + +# Save a copy of the GSI executable in the workdir +cp ${GSI_EXE} gsi.x + +# Bring over background field (it's modified by GSI so we can't link to it) +cp ${BK_FILE} ./wrf_inout +if [ ${if_4DEnVar} = Yes ] ; then + cp ${BK_FILE_P1} ./wrf_inou3 + cp ${BK_FILE_M1} ./wrf_inou1 +fi + + +# Link to the prepbufr data +ln -s ${PREPBUFR} ./prepbufr + +# ln -s ${OBS_ROOT}/gdas1.t${HH}z.sptrmm.tm00.bufr_d tmirrbufr +# Link to the radiance data +srcobsfile[1]=${OBS_ROOT}/gdas1.t${HH}z.satwnd.tm00.bufr_d +gsiobsfile[1]=satwnd +srcobsfile[2]=${OBS_ROOT}/gdas1.t${HH}z.1bamua.tm00.bufr_d +gsiobsfile[2]=amsuabufr +srcobsfile[3]=${OBS_ROOT}/gdas1.t${HH}z.1bhrs4.tm00.bufr_d +gsiobsfile[3]=hirs4bufr +srcobsfile[4]=${OBS_ROOT}/gdas1.t${HH}z.1bmhs.tm00.bufr_d +gsiobsfile[4]=mhsbufr +srcobsfile[5]=${OBS_ROOT}/gdas1.t${HH}z.1bamub.tm00.bufr_d +gsiobsfile[5]=amsubbufr +srcobsfile[6]=${OBS_ROOT}/gdas1.t${HH}z.ssmisu.tm00.bufr_d +gsiobsfile[6]=ssmirrbufr +# srcobsfile[7]=${OBS_ROOT}/gdas1.t${HH}z.airsev.tm00.bufr_d +gsiobsfile[7]=airsbufr +srcobsfile[8]=${OBS_ROOT}/gdas1.t${HH}z.sevcsr.tm00.bufr_d +gsiobsfile[8]=seviribufr +srcobsfile[9]=${OBS_ROOT}/gdas1.t${HH}z.iasidb.tm00.bufr_d +gsiobsfile[9]=iasibufr +srcobsfile[10]=${OBS_ROOT}/gdas1.t${HH}z.gpsro.tm00.bufr_d +gsiobsfile[10]=gpsrobufr +srcobsfile[11]=${OBS_ROOT}/gdas1.t${HH}z.amsr2.tm00.bufr_d +gsiobsfile[11]=amsrebufr +srcobsfile[12]=${OBS_ROOT}/gdas1.t${HH}z.atms.tm00.bufr_d +gsiobsfile[12]=atmsbufr +srcobsfile[13]=${OBS_ROOT}/gdas1.t${HH}z.geoimr.tm00.bufr_d +gsiobsfile[13]=gimgrbufr +srcobsfile[14]=${OBS_ROOT}/gdas1.t${HH}z.gome.tm00.bufr_d +gsiobsfile[14]=gomebufr +srcobsfile[15]=${OBS_ROOT}/gdas1.t${HH}z.omi.tm00.bufr_d +gsiobsfile[15]=omibufr +srcobsfile[16]=${OBS_ROOT}/gdas1.t${HH}z.osbuv8.tm00.bufr_d +gsiobsfile[16]=sbuvbufr +srcobsfile[17]=${OBS_ROOT}/gdas1.t${HH}z.eshrs3.tm00.bufr_d +gsiobsfile[17]=hirs3bufrears +srcobsfile[18]=${OBS_ROOT}/gdas1.t${HH}z.esamua.tm00.bufr_d +gsiobsfile[18]=amsuabufrears +srcobsfile[19]=${OBS_ROOT}/gdas1.t${HH}z.esmhs.tm00.bufr_d +gsiobsfile[19]=mhsbufrears +srcobsfile[20]=${OBS_ROOT}/rap.t${HH}z.nexrad.tm00.bufr_d +gsiobsfile[20]=l2rwbufr +srcobsfile[21]=${OBS_ROOT}/rap.t${HH}z.lgycld.tm00.bufr_d +gsiobsfile[21]=larcglb +srcobsfile[22]=${OBS_ROOT}/gdas1.t${HH}z.glm.tm00.bufr_d +gsiobsfile[22]= +ii=1 +while [[ $ii -le 21 ]]; do + if [ -r "${srcobsfile[$ii]}" ]; then +# ln -s ${srcobsfile[$ii]} ${gsiobsfile[$ii]} + echo "link source obs file ${srcobsfile[$ii]}" + fi + (( ii = $ii + 1 )) +done + +# +################################################################################## + +ifhyb=.false. +if [ ${if_hybrid} = Yes ] ; then + ls ${ENSEMBLE_FILE_mem}* > filelist02 + if [ ${if_4DEnVar} = Yes ] ; then + ls ${ENSEMBLE_FILE_mem_p1}* > filelist03 + ls ${ENSEMBLE_FILE_mem_m1}* > filelist01 + fi + + nummem=`more filelist02 | wc -l` + nummem=$((nummem -3 )) + + if [[ ${nummem} -ge 5 ]]; then + ifhyb=.true. + ${ECHO} " GSI hybrid uses ${ENSEMBLE_FILE_mem} with n_ens=${nummem}" + fi +fi +if4d=.false. +if [[ ${ifhyb} = .true. && ${if_4DEnVar} = Yes ]] ; then + if4d=.true. +fi +# +################################################################################## + +echo " Copy fixed files and link CRTM coefficient files to working directory" + +# Set fixed files +# berror = forecast model background error statistics +# specoef = CRTM spectral coefficients +# trncoef = CRTM transmittance coefficients +# emiscoef = CRTM coefficients for IR sea surface emissivity model +# aerocoef = CRTM coefficients for aerosol effects +# cldcoef = CRTM coefficients for cloud effects +# satinfo = text file with information about assimilation of brightness temperatures +# satangl = angle dependent bias correction file (fixed in time) +# pcpinfo = text file with information about assimilation of prepcipitation rates +# ozinfo = text file with information about assimilation of ozone data +# errtable = text file with obs error for conventional data (regional only) +# convinfo = text file with information about assimilation of conventional data +# lightinfo= text file with information about assimilation of GLM lightning data +# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.) +# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.) + +if [ ${bkcv_option} = GLOBAL ] ; then + echo ' Use global background error covariance' + BERROR=${FIX_ROOT}/${BYTE_ORDER}/nam_glb_berror.f77.gcv + OBERROR=${FIX_ROOT}/prepobs_errtable.global + if [ ${bk_core} = NMM ] ; then + ANAVINFO=${FIX_ROOT}/anavinfo_ndas_netcdf_glbe + fi + if [ ${bk_core} = ARW ] ; then + ANAVINFO=${FIX_ROOT}/anavinfo_arw_netcdf_glbe + fi + if [ ${bk_core} = NMMB ] ; then + ANAVINFO=${FIX_ROOT}/anavinfo_nems_nmmb_glb + fi +else + echo ' Use NAM background error covariance' + BERROR=${FIX_ROOT}/${BYTE_ORDER}/nam_nmmstat_na.gcv + OBERROR=${FIX_ROOT}/nam_errtable.r3dv + if [ ${bk_core} = NMM ] ; then + ANAVINFO=${FIX_ROOT}/anavinfo_ndas_netcdf + fi + if [ ${bk_core} = ARW ] ; then + ANAVINFO=${FIX_ROOT}/anavinfo_arw_netcdf + fi + if [ ${bk_core} = NMMB ] ; then + ANAVINFO=${FIX_ROOT}/anavinfo_nems_nmmb + fi +fi + +SATANGL=${FIX_ROOT}/global_satangbias.txt +SATINFO=${FIX_ROOT}/global_satinfo.txt +CONVINFO=${FIX_ROOT}/global_convinfo.txt +OZINFO=${FIX_ROOT}/global_ozinfo.txt +PCPINFO=${FIX_ROOT}/global_pcpinfo.txt +LIGHTINFO=${FIX_ROOT}/global_lightinfo.txt + +# copy Fixed fields to working directory + cp $ANAVINFO anavinfo + cp $BERROR berror_stats + cp $SATANGL satbias_angle + cp $SATINFO satinfo + cp $CONVINFO convinfo + cp $OZINFO ozinfo + cp $PCPINFO pcpinfo + cp $LIGHTINFO lightinfo + cp $OBERROR errtable +# +# # CRTM Spectral and Transmittance coefficients +CRTM_ROOT_ORDER=${CRTM_ROOT}/${BYTE_ORDER} +emiscoef_IRwater=${CRTM_ROOT_ORDER}/Nalli.IRwater.EmisCoeff.bin +emiscoef_IRice=${CRTM_ROOT_ORDER}/NPOESS.IRice.EmisCoeff.bin +emiscoef_IRland=${CRTM_ROOT_ORDER}/NPOESS.IRland.EmisCoeff.bin +emiscoef_IRsnow=${CRTM_ROOT_ORDER}/NPOESS.IRsnow.EmisCoeff.bin +emiscoef_VISice=${CRTM_ROOT_ORDER}/NPOESS.VISice.EmisCoeff.bin +emiscoef_VISland=${CRTM_ROOT_ORDER}/NPOESS.VISland.EmisCoeff.bin +emiscoef_VISsnow=${CRTM_ROOT_ORDER}/NPOESS.VISsnow.EmisCoeff.bin +emiscoef_VISwater=${CRTM_ROOT_ORDER}/NPOESS.VISwater.EmisCoeff.bin +emiscoef_MWwater=${CRTM_ROOT_ORDER}/FASTEM6.MWwater.EmisCoeff.bin +aercoef=${CRTM_ROOT_ORDER}/AerosolCoeff.bin +cldcoef=${CRTM_ROOT_ORDER}/CloudCoeff.bin + +ln -s $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin +ln -s $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin +ln -s $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin +ln -s $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin +ln -s $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin +ln -s $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin +ln -s $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin +ln -s $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin +ln -s $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin +ln -s $aercoef ./AerosolCoeff.bin +ln -s $cldcoef ./CloudCoeff.bin +# Copy CRTM coefficient files based on entries in satinfo file +for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do + ln -s ${CRTM_ROOT_ORDER}/${file}.SpcCoeff.bin ./ + ln -s ${CRTM_ROOT_ORDER}/${file}.TauCoeff.bin ./ +done + +# Only need this file for single obs test + bufrtable=${FIX_ROOT}/prepobs_prep.bufrtable + cp $bufrtable ./prepobs_prep.bufrtable + +# for satellite bias correction +# Users may need to use their own satbias files for correct bias correction +cp ${GSI_ROOT}/fix/comgsi_satbias_in ./satbias_in +cp ${GSI_ROOT}/fix/comgsi_satbias_pc_in ./satbias_pc_in + +# +################################################################################## +# Set some parameters for use by the GSI executable and to build the namelist +echo " Build the namelist " + +# default is NAM +# as_op='1.0,1.0,0.5 ,0.7,0.7,0.5,1.0,1.0,' +vs_op='1.0,' +hzscl_op='0.373,0.746,1.50,' +if [ ${bkcv_option} = GLOBAL ] ; then +# as_op='0.6,0.6,0.75,0.75,0.75,0.75,1.0,1.0' + vs_op='0.7,' + hzscl_op='1.7,0.8,0.5,' +fi +if [ ${bk_core} = NMMB ] ; then + vs_op='0.6,' +fi + +# default is NMM + bk_core_arw='.false.' + bk_core_nmm='.true.' + bk_core_nmmb='.false.' + bk_if_netcdf='.true.' +if [ ${bk_core} = ARW ] ; then + bk_core_arw='.true.' + bk_core_nmm='.false.' + bk_core_nmmb='.false.' + bk_if_netcdf='.true.' +fi +if [ ${bk_core} = NMMB ] ; then + bk_core_arw='.false.' + bk_core_nmm='.false.' + bk_core_nmmb='.true.' + bk_if_netcdf='.false.' +fi + +if [ ${if_observer} = Yes ] ; then + nummiter=0 + if_read_obs_save='.true.' + if_read_obs_skip='.false.' +else + nummiter=2 + if_read_obs_save='.false.' + if_read_obs_skip='.false.' +fi + +# Build the GSI namelist on-the-fly +. $GSI_NAMELIST + +# modify the anavinfo vertical levels based on wrf_inout for WRF ARW and NMM +if [ ${bk_core} = ARW ] || [ ${bk_core} = NMM ] ; then +bklevels=`ncdump -h wrf_inout | grep "bottom_top =" | awk '{print $3}' ` +bklevels_stag=`ncdump -h wrf_inout | grep "bottom_top_stag =" | awk '{print $3}' ` +anavlevels=`cat anavinfo | grep ' sf ' | tail -1 | awk '{print $2}' ` # levels of sf, vp, u, v, t, etc +anavlevels_stag=`cat anavinfo | grep ' prse ' | tail -1 | awk '{print $2}' ` # levels of prse +sed -i 's/ '$anavlevels'/ '$bklevels'/g' anavinfo +sed -i 's/ '$anavlevels_stag'/ '$bklevels_stag'/g' anavinfo +fi + +# +################################################### +# run GSI +################################################### +echo ' Run GSI with' ${bk_core} 'background' + +case $ARCH in + 'IBM_LSF') + ${RUN_COMMAND} ./gsi.x < gsiparm.anl > stdout 2>&1 ;; + + * ) + ${RUN_COMMAND} ./gsi.x > stdout 2>&1 ;; +esac + +################################################################## +# run time error check +################################################################## +error=$? + +if [ ${error} -ne 0 ]; then + echo "ERROR: ${GSI} crashed Exit status=${error}" + exit ${error} +fi + +# +################################################################## +# +# GSI updating satbias_in +# +# GSI updating satbias_in (only for cycling assimilation) + +# Copy the output to more understandable names +ln -s stdout stdout.anl.${ANAL_TIME} +ln -s wrf_inout wrfanl.${ANAL_TIME} +ln -s fort.201 fit_p1.${ANAL_TIME} +ln -s fort.202 fit_w1.${ANAL_TIME} +ln -s fort.203 fit_t1.${ANAL_TIME} +ln -s fort.204 fit_q1.${ANAL_TIME} +ln -s fort.207 fit_rad1.${ANAL_TIME} + +# Loop over first and last outer loops to generate innovation +# diagnostic files for indicated observation types (groups) +# +# NOTE: Since we set miter=2 in GSI namelist SETUP, outer +# loop 03 will contain innovations with respect to +# the analysis. Creation of o-a innovation files +# is triggered by write_diag(3)=.true. The setting +# write_diag(1)=.true. turns on creation of o-g +# innovation files. +# + +loops="01 03" +for loop in $loops; do + +case $loop in + 01) string=ges;; + 03) string=anl;; + *) string=$loop;; +esac + +# Collect diagnostic files for obs types (groups) below +# listall="conv amsua_metop-a mhs_metop-a hirs4_metop-a hirs2_n14 msu_n14 \ +# sndr_g08 sndr_g10 sndr_g12 sndr_g08_prep sndr_g10_prep sndr_g12_prep \ +# sndrd1_g08 sndrd2_g08 sndrd3_g08 sndrd4_g08 sndrd1_g10 sndrd2_g10 \ +# sndrd3_g10 sndrd4_g10 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 \ +# hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 \ +# amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua \ +# goes_img_g08 goes_img_g10 goes_img_g11 goes_img_g12 \ +# pcp_ssmi_dmsp pcp_tmi_trmm sbuv2_n16 sbuv2_n17 sbuv2_n18 \ +# omi_aura ssmi_f13 ssmi_f14 ssmi_f15 hirs4_n18 amsua_n18 mhs_n18 \ +# amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_las_f16 \ +# ssmis_uas_f16 ssmis_img_f16 ssmis_env_f16 mhs_metop_b \ +# hirs4_metop_b hirs4_n19 amusa_n19 mhs_n19 goes_glm_16" + listall=`ls pe* | cut -f2 -d"." | awk '{print substr($0, 0, length($0)-3)}' | sort | uniq ` + + for type in $listall; do + count=`ls pe*${type}_${loop}* | wc -l` + if [[ $count -gt 0 ]]; then + cat pe*${type}_${loop}* > diag_${type}_${string}.${ANAL_TIME} + fi + done +done + +# Clean working directory to save only important files +ls -l * > list_run_directory +if [[ ${if_clean} = clean && ${if_observer} != Yes ]]; then + echo ' Clean working directory after GSI run' + rm -f *Coeff.bin # all CRTM coefficient files + rm -f pe0* # diag files on each processor + rm -f obs_input.* # observation middle files + rm -f siganl sigf0? # background middle files + rm -f fsize_* # delete temperal file for bufr size +fi +# +# +################################################# +# start to calculate diag files for each member +################################################# +# +if [ ${if_observer} = Yes ] ; then + string=ges + for type in $listall; do + count=0 + if [[ -f diag_${type}_${string}.${ANAL_TIME} ]]; then + mv diag_${type}_${string}.${ANAL_TIME} diag_${type}_${string}.ensmean + fi + done + mv wrf_inout wrf_inout_ensmean + +# Build the GSI namelist on-the-fly for each member + nummiter=0 + if_read_obs_save='.false.' + if_read_obs_skip='.true.' +. $GSI_NAMELIST + +# Loop through each member + loop="01" + ensmem=1 + while [[ $ensmem -le $no_member ]];do + + rm pe0* + + print "\$ensmem is $ensmem" + ensmemid=`printf %3.3i $ensmem` + +# get new background for each member + if [[ -f wrf_inout ]]; then + rm wrf_inout + fi + + BK_FILE=${BK_FILE_mem}${ensmemid} + echo $BK_FILE + ln -s $BK_FILE wrf_inout + +# run GSI + echo ' Run GSI with' ${bk_core} 'for member ', ${ensmemid} + + case $ARCH in + 'IBM_LSF') + ${RUN_COMMAND} ./gsi.x < gsiparm.anl > stdout_mem${ensmemid} 2>&1 ;; + + * ) + ${RUN_COMMAND} ./gsi.x > stdout_mem${ensmemid} 2>&1 ;; + esac + +# run time error check and save run time file status + error=$? + + if [ ${error} -ne 0 ]; then + echo "ERROR: ${GSI} crashed for member ${ensmemid} Exit status=${error}" + exit ${error} + fi + + ls -l * > list_run_directory_mem${ensmemid} + +# generate diag files + + for type in $listall; do + count=`ls pe*${type}_${loop}* | wc -l` + if [[ $count -gt 0 ]]; then + cat pe*${type}_${loop}* > diag_${type}_${string}.mem${ensmemid} + fi + done + +# next member + (( ensmem += 1 )) + + done + +fi + +exit 0 diff --git a/ush/rungsi_globalprod.sh b/ush/rungsi_globalprod.sh index f99d99bcc..8bb8862cd 100755 --- a/ush/rungsi_globalprod.sh +++ b/ush/rungsi_globalprod.sh @@ -52,7 +52,7 @@ exp=globalprod.$adate expid=${expnm}.$adate.wcoss # Set path/file for gsi executable -gsiexec=/da/save/$USER/trunk/src/global_gsi +gsiexec=/da/save/$USER/trunk/src/global_gsi.x # Specify GSI fixed field fixgsi=/da/save/$USER/trunk/fix diff --git a/ush/rungsi_nmmprod.sh b/ush/rungsi_nmmprod.sh index c1ad0c2f9..9725bf5aa 100755 --- a/ush/rungsi_nmmprod.sh +++ b/ush/rungsi_nmmprod.sh @@ -282,7 +282,7 @@ cp $mesonetuselist ./mesonetuselist # Copy executable and fixed files to $tmpdir -gsiexec=/u/wx20xs/home/gsi/xsu/src/global_gsi +gsiexec=/u/wx20xs/home/gsi/xsu/src/global_gsi.x cp $gsiexec ./gsi.x # Copy CRTM coefficient files based on entries in satinfo file diff --git a/ush/sub_discover b/ush/sub_discover new file mode 100755 index 000000000..84b410be6 --- /dev/null +++ b/ush/sub_discover @@ -0,0 +1,207 @@ +#!/bin/sh +set -x +usage="\ +Usage: $0 [options] executable [args] + where the options are: + -a account account (default: none) + -b binding run smt binding or not (default:NO) + -d dirin initial directory (default: cwd) + -e envars copy comma-separated environment variables + -g group group name + -i append standard input to command file + -j jobname specify jobname (default: executable basename) + -m machine machine on which to run (default: current) + -n write command file to stdout rather than submitting it + -o output specify output file (default: jobname.out) + -p procs[/nodes[/ppreq] + number of MPI tasks and optional nodes or Bblocking and + ppreq option (N or S) (defaults: serial, Bunlimited, S) + -q queue[/qpreq] queue name and optional requirement, e.g. dev/P + (defaults: 1 if serial or dev if parallel and none) + (queue 3 or 4 is dev or prod with twice tasks over ip) + (options: P=parallel, B=bigmem, b=batch) + -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) + -t timew wall time limit in [[hh:]mm:]ss format (default: 900) + -u userid userid to run under (default: self) + -v verbose mode + -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or + Thh[mm] (full, incremental, today or tomorrow) format + (default: now) +Function: This command submits a job to the batch queue." +subcmd="$*" +stdin=NO +nosub=NO +account="" +binding="NO" +dirin="" +envars="" +group="" +jobname="" +machine="" +output="" +procs=0 +nodes="" +ppreq="" +queue="" +qpreq="" +rmem="1024" +rcpu="1" +timew="900" +userid="" +verbose=NO +when="" +while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do + case $opt in + a) account="$OPTARG";; + b) binding="$OPTARG";; + d) dirin="$OPTARG";; + e) envars="$OPTARG";; + g) group="$OPTARG";; + i) stdin=YES;; + j) jobname=$OPTARG;; + m) machine="$OPTARG";; + n) nosub=YES;; + o) output=$OPTARG;; + p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; + q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; + r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; + t) timew=$OPTARG;; + u) userid=$OPTARG;; + v) verbose=YES;; + w) when=$OPTARG;; + \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; + esac +done +shift $(($OPTIND-1)) +if [[ $# -eq 0 ]];then + echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 +fi +exec=$1 +if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then + exec=$(which $exec) +fi +shift +args="$*" +bn=$(basename $exec) +export jobname=${jobname:-$bn} +output=${output:-$jobname.out} +myuser=$LOGNAME +myhost=$(hostname) + +DATA=$regdir/regtests/data +mkdir -p $DATA + +#partition=${partition:-c1ms} +queue=${queue:-batch} +timew=${timew:-01:20:00} +task_node=${task_node:-$procs} +size=$((nodes*task_node)) +envars=$envars +threads=${rcpu:-1} +#envars=$envars,mpi_tasks=$procs +#Options +###PBS -l partition=c1ms,size=0528,walltime=01:20:00 +##PBS -l partition=$queue,size=$size,walltime=$timew +##PBS -S /bin/sh + +export TZ=GMT +cfile=$DATA/sub$$ +> $cfile +echo "#!/bin/sh --login" >> $cfile +echo "" >> $cfile +echo "#SBATCH --output $output" >> $cfile +echo "#SBATCH --job-name $jobname" >> $cfile +echo "#SBATCH --time=$timew" >> $cfile +echo "#SBATCH --ntasks=$procs" >> $cfile +echo "#SBATCH --nodes=$nodes" >> $cfile +echo "#SBATCH --account=$accnt" >> $cfile +echo "#SBATCH --constraint=hasw" >> $cfile +#echo "#SBATCH --qos=advda" >> $cfile +echo "#SBATCH --export=ALL" >> $cfile +echo "#SBATCH --partition=$queue" >> $cfile +#. $exec >> $cfile +#echo "/bin/sh -x $exec" >> $cfile + +echo "" >>$cfile +echo "set -x" +echo "" >>$cfile +echo "export OMP_NUM_THREADS=$threads" >> $cfile +echo "" >>$cfile +echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile +echo "" >>$cfile +echo "module use -a $gsisrc/modulefiles" >> $cfile +echo "module load modulefile.ProdGSI.discover" >> $cfile +echo "" >>$cfile +echo "jobname=$jobname" >>$cfile +echo "" >>$cfile + +cat $exec >> $cfile + +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +#msub -I partition=$partition,size=$procs,walltime=$walltime $cfile + +#if [[ -n $when ]];then +# whena=$when +# if [[ $when = +* ]];then +# hr=$(echo $when|cut -c2-3) +# mn=$(echo $when|cut -c4-5) +# [[ -n $mn ]] || mn=00 +# now=$(date -u +"%Y%m%d%H%M") +# ((mn+=$(echo $now|cut -c11-12))) +# [[ $mn -ge 60 ]] && ((hr+=1)) && ((mn-=60)) +# [[ $mn -lt 10 ]] && mn=0$mn +# whena=$(/nwprod/util/exec/ndate +$hr $(echo $now|cut -c1-10))$mn +# elif [[ $when = t* ]];then +# hr=$(echo $when|cut -c2-3) +# mn=$(echo $when|cut -c4-5) +# [[ -n $mn ]] || mn=00 +# now=$(date -u +"%Y%m%d") +# whena=$now$hr$mn +# elif [[ $when = T* ]];then +# hr=$(echo $when|cut -c2-3) +# mn=$(echo $when|cut -c4-5) +# [[ -n $mn ]] || mn=00 +# now=$(date -u +"%Y%m%d%H") +# whena=$(/nwprod/util/exec/ndate +24 $now|cut -c1-8)$hr$mn +# fi +# yr=$(echo $whena|cut -c1-4) +# mo=$(echo $whena|cut -c5-6) +# dy=$(echo $whena|cut -c7-8) +# hr=$(echo $whena|cut -c9-10) +# mn=$(echo $whena|cut -c11-12) +# [[ -n $mn ]] || mn=00 +# echo "#@ startdate = $mo/$dy/$yr $hr:$mn" +#fi >>$cfile + + +if [[ $stdin = YES ]];then + cat +fi >>$cfile +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +qsub=${qsub:-qsub} + +ofile=$DATA/subout$$ +>$ofile +chmod 777 $ofile +$qsub -V $cfile >$ofile +rc=$? +cat $ofile +if [[ -w $SUBLOG ]];then + jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) + date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG +fi +#rm $cfile $ofile +#[[ $MKDATA = YES ]] && rmdir $DATA +exit $rc diff --git a/ush/sub_hera b/ush/sub_hera new file mode 100755 index 000000000..bbf4df222 --- /dev/null +++ b/ush/sub_hera @@ -0,0 +1,212 @@ +#!/bin/sh --login +set -x +usage="\ +Usage: $0 [options] executable [args] + where the options are: + -a account account (default: none) + -b binding run smt binding or not (default:NO) + -d dirin initial directory (default: cwd) + -e envars copy comma-separated environment variables + -g group group name + -i append standard input to command file + -j jobname specify jobname (default: executable basename) + -m machine machine on which to run (default: current) + -n write command file to stdout rather than submitting it + -o output specify output file (default: jobname.out) + -p procs[/nodes[/ppreq] + number of MPI tasks and optional nodes or Bblocking and + ppreq option (N or S) (defaults: serial, Bunlimited, S) + -q queue[/qpreq] queue name and optional requirement, e.g. dev/P + (defaults: 1 if serial or dev if parallel and none) + (queue 3 or 4 is dev or prod with twice tasks over ip) + (options: P=parallel, B=bigmem, b=batch) + -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) + -t timew wall time limit in [[hh:]mm:]ss format (default: 900) + -u userid userid to run under (default: self) + -v verbose mode + -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or + Thh[mm] (full, incremental, today or tomorrow) format + (default: now) +Function: This command submits a job to the batch queue." +subcmd="$*" +stdin=NO +nosub=NO +account="" +binding="NO" +dirin="" +envars="" +group="" +jobname="" +machine="" +output="" +procs=0 +nodes="" +ppreq="" +queue="" +qpreq="" +rmem="1024" +rcpu="1" +timew="900" +userid="" +verbose=NO +when="" +while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do + case $opt in + a) account="$OPTARG";; + b) binding="$OPTARG";; + d) dirin="$OPTARG";; + e) envars="$OPTARG";; + g) group="$OPTARG";; + i) stdin=YES;; + j) jobname=$OPTARG;; + m) machine="$OPTARG";; + n) nosub=YES;; + o) output=$OPTARG;; + p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; + q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; + r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; + t) timew=$OPTARG;; + u) userid=$OPTARG;; + v) verbose=YES;; + w) when=$OPTARG;; + \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; + esac +done +shift $(($OPTIND-1)) +if [[ $# -eq 0 ]];then + echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 +fi +exec=$1 +if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then + exec=$(which $exec) +fi +shift +args="$*" +bn=$(basename $exec) +export jobname=${jobname:-$bn} +output=${output:-$jobname.out} +myuser=$LOGNAME +myhost=$(hostname) + +if [ -d /scratch1/NCEPDEV/stmp4/$LOGNAME ]; then + DATA=/scratch1/NCEPDEV/stmp4/$LOGNAME/tmp +elif [ -d /scratch2/BMC/gsienkf/$LOGNAME ]; then + DATA=/scratch2/BMC/gsienkf/$LOGNAME/tmp/tmp +fi +DATA=${DATA:-$ptmp/tmp} + +mkdir -p $DATA + +#partition=${partition:-c1ms} +queue=${queue:-batch} +timew=${timew:-01:20:00} +task_node=${task_node:-$procs} +size=$((nodes*task_node)) +envars=$envars +threads=${rcpu:-1} +#envars=$envars,mpi_tasks=$procs +#Options +###PBS -l partition=c1ms,size=0528,walltime=01:20:00 +##PBS -l partition=$queue,size=$size,walltime=$timew +##PBS -S /bin/sh + +export TZ=GMT +cfile=$DATA/sub$$ +> $cfile +#echo "#PBS -S /bin/sh" >> $cfile +echo "#!/bin/sh --login" >> $cfile +echo "" >> $cfile +echo "#SBATCH --output=$output" >> $cfile +echo "#SBATCH --job-name=$jobname" >> $cfile +echo "#SBATCH --qos=$queue" >> $cfile +echo "#SBATCH --time=$timew" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +#echo "#SBATCH -j oe" >> $cfile +echo "#SBATCH --account=$accnt" >> $cfile +#echo "#SBATCH -V" >> $cfile +#echo "#PBS -d" >> $cfile +#. $exec >> $cfile +#echo "/bin/sh -x $exec" >> $cfile + +echo "" >>$cfile +echo "export OMP_NUM_THREADS=$threads" >> $cfile +echo "" >>$cfile +echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile +echo "" >>$cfile + +echo ". /apps/lmod/lmod/init/sh" >> $cfile +echo "module purge" >> $cfile +echo "source $gsisrc/modulefiles/modulefile.ProdGSI.hera" >> $cfile +echo "module list" >> $cfile +echo "" >>$cfile + +cat $exec >> $cfile + +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +#msub -I partition=$partition,size=$procs,walltime=$walltime $cfile + +#if [[ -n $when ]];then +# whena=$when +# if [[ $when = +* ]];then +# hr=$(echo $when|cut -c2-3) +# mn=$(echo $when|cut -c4-5) +# [[ -n $mn ]] || mn=00 +# now=$(date -u +"%Y%m%d%H%M") +# ((mn+=$(echo $now|cut -c11-12))) +# [[ $mn -ge 60 ]] && ((hr+=1)) && ((mn-=60)) +# [[ $mn -lt 10 ]] && mn=0$mn +# whena=$(/nwprod/util/exec/ndate +$hr $(echo $now|cut -c1-10))$mn +# elif [[ $when = t* ]];then +# hr=$(echo $when|cut -c2-3) +# mn=$(echo $when|cut -c4-5) +# [[ -n $mn ]] || mn=00 +# now=$(date -u +"%Y%m%d") +# whena=$now$hr$mn +# elif [[ $when = T* ]];then +# hr=$(echo $when|cut -c2-3) +# mn=$(echo $when|cut -c4-5) +# [[ -n $mn ]] || mn=00 +# now=$(date -u +"%Y%m%d%H") +# whena=$(/nwprod/util/exec/ndate +24 $now|cut -c1-8)$hr$mn +# fi +# yr=$(echo $whena|cut -c1-4) +# mo=$(echo $whena|cut -c5-6) +# dy=$(echo $whena|cut -c7-8) +# hr=$(echo $whena|cut -c9-10) +# mn=$(echo $whena|cut -c11-12) +# [[ -n $mn ]] || mn=00 +# echo "#@ startdate = $mo/$dy/$yr $hr:$mn" +#fi >>$cfile + + +if [[ $stdin = YES ]];then + cat +fi >>$cfile +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +sbatch=${sbatch:-sbatch} + +ofile=$DATA/subout$$ +>$ofile +chmod 777 $ofile +$sbatch $cfile >$ofile +rc=$? +cat $ofile +if [[ -w $SUBLOG ]];then + jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) + date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG +fi +rm $cfile $ofile +[[ $MKDATA = YES ]] && rmdir $DATA +exit $rc diff --git a/ush/sub_ncar b/ush/sub_ncar new file mode 100755 index 000000000..d2887dded --- /dev/null +++ b/ush/sub_ncar @@ -0,0 +1,202 @@ +#!/bin/sh --login +set -x +echo "starting sub_ncar" +usage="\ +Usage: $0 [options] executable [args] + where the options are: + -a account account (default: none) + -b binding run smt binding or not (default:NO) + -d dirin initial directory (default: cwd) + -e envars copy comma-separated environment variables + -g group group name + -i append standard input to command file + -j jobname specify jobname (default: executable basename) + -m machine machine on which to run (default: current) + -n write command file to stdout rather than submitting it + -o output specify output file (default: jobname.out) + -p procs[/nodes[/ppreq] + number of MPI tasks and optional nodes or Bblocking and + ppreq option (N or S) (defaults: serial, Bunlimited, S) + -q queue[/qpreq] queue name and optional requirement, e.g. dev/P + (defaults: 1 if serial or dev if parallel and none) + (queue 3 or 4 is dev or prod with twice tasks over ip) + (options: P=parallel, B=bigmem, b=batch) + -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) + -t timew wall time limit in [[hh:]mm:]ss format (default: 900) + -u userid userid to run under (default: self) + -v verbose mode + -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or + Thh[mm] (full, incremental, today or tomorrow) format + (default: now) +Function: This command submits a job to the batch queue." +subcmd="$*" +stdin=NO +nosub=NO +account="" +binding="NO" +dirin="" +envars="" +group="" +jobname="" +machine="" +output="" +procs=0 +nodes="" +ppreq="" +queue="" +qpreq="" +rmem="1024" +rcpu="1" +timew="900" +userid="" +verbose=NO +when="" +while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do + case $opt in + a) account="$OPTARG";; + b) binding="$OPTARG";; + d) dirin="$OPTARG";; + e) envars="$OPTARG";; + g) group="$OPTARG";; + i) stdin=YES;; + j) jobname=$OPTARG;; + m) machine="$OPTARG";; + n) nosub=YES;; + o) output=$OPTARG;; + p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; + q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; + r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; + t) timew=$OPTARG;; + u) userid=$OPTARG;; + v) verbose=YES;; + w) when=$OPTARG;; + \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; + esac +done +shift $(($OPTIND-1)) +if [[ $# -eq 0 ]];then + echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 +fi +exec=$1 +if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then + exec=$(which $exec) +fi +shift +args="$*" +bn=$(basename $exec) +export jobname=${jobname:-$bn} +output=${output:-$jobname.out} +myuser=$LOGNAME +myhost=$(hostname) + +DATA=/glade/scratch/$LOGNAME/tmp +mkdir -p $DATA + +#partition=${partition:-c1ms} +#queue=${queue:-batch} +timew=${timew:-01:20:00} +task_node=${task_node:-$procs} +size=$((nodes*task_node)) +envars=$envars +threads=${rcpu:-1} +#envars=$envars,mpi_tasks=$procs +#Options +###PBS -l partition=c1ms,size=0528,walltime=01:20:00 +##PBS -l partition=$queue,size=$size,walltime=$timew +##PBS -S /bin/sh + +export TZ=GMT +cfile=$DATA/sub$$ +> $cfile +#echo "#PBS -S /bin/sh" >> $cfile +echo "#!/bin/sh --login" >> $cfile +echo "" >> $cfile +echo "#PBS -o $output" >> $cfile +echo "#PBS -N $jobname" >> $cfile +echo "#PBS -q $queue" >> $cfile +echo "#PBS -l walltime=$timew" >> $cfile +echo "#PBS -l select=$nodes:ncpus=$procs:mpiprocs=$procs" >> $cfile +echo "#PBS -j oe" >> $cfile +echo "#PBS -A "$account >> $cfile +echo "#PBS -V" >> $cfile +#echo "#PBS -d" >> $cfile +#. $exec >> $cfile +#echo "/bin/sh -x $exec" >> $cfile + +echo "" >>$cfile +echo "export OMP_NUM_THREADS=$threads" >> $cfile +echo "" >>$cfile +echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile +echo "" >>$cfile + +cat $exec >> $cfile + +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +#msub -I partition=$partition,size=$procs,walltime=$walltime $cfile + +#if [[ -n $when ]];then +# whena=$when +# if [[ $when = +* ]];then +# hr=$(echo $when|cut -c2-3) +# mn=$(echo $when|cut -c4-5) +# [[ -n $mn ]] || mn=00 +# now=$(date -u +"%Y%m%d%H%M") +# ((mn+=$(echo $now|cut -c11-12))) +# [[ $mn -ge 60 ]] && ((hr+=1)) && ((mn-=60)) +# [[ $mn -lt 10 ]] && mn=0$mn +# whena=$(/nwprod/util/exec/ndate +$hr $(echo $now|cut -c1-10))$mn +# elif [[ $when = t* ]];then +# hr=$(echo $when|cut -c2-3) +# mn=$(echo $when|cut -c4-5) +# [[ -n $mn ]] || mn=00 +# now=$(date -u +"%Y%m%d") +# whena=$now$hr$mn +# elif [[ $when = T* ]];then +# hr=$(echo $when|cut -c2-3) +# mn=$(echo $when|cut -c4-5) +# [[ -n $mn ]] || mn=00 +# now=$(date -u +"%Y%m%d%H") +# whena=$(/nwprod/util/exec/ndate +24 $now|cut -c1-8)$hr$mn +# fi +# yr=$(echo $whena|cut -c1-4) +# mo=$(echo $whena|cut -c5-6) +# dy=$(echo $whena|cut -c7-8) +# hr=$(echo $whena|cut -c9-10) +# mn=$(echo $whena|cut -c11-12) +# [[ -n $mn ]] || mn=00 +# echo "#@ startdate = $mo/$dy/$yr $hr:$mn" +#fi >>$cfile + + +if [[ $stdin = YES ]];then + cat +fi >>$cfile +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +qsub=${qsub:-qsub} + +ofile=$DATA/subout$$ +>$ofile +chmod 777 $ofile +$qsub $cfile >$ofile +rc=$? +cat $ofile +if [[ -w $SUBLOG ]];then + jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) + date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG +fi +#rm $cfile $ofile +[[ $MKDATA = YES ]] && rmdir $DATA +echo "ending sub_ncar" +exit $rc diff --git a/ush/sub_wcoss b/ush/sub_wcoss index 17810f081..3fa4876c6 100755 --- a/ush/sub_wcoss +++ b/ush/sub_wcoss @@ -308,6 +308,12 @@ echo "" >>$cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >> $cfile echo "" >>$cfile +echo ". $MODULESHOME/init/ksh" >> $cfile +echo "module purge" >> $cfile +echo "module use -a $gsisrc/modulefiles" >> $cfile +echo "module load modulefile.ProdGSI.wcoss" >> $cfile +echo "module list" >> $cfile + echo "$exec" >> $cfile if [[ $stdin = YES ]];then diff --git a/ush/sub_wcoss_c b/ush/sub_wcoss_c index 700826214..d41dc7e78 100755 --- a/ush/sub_wcoss_c +++ b/ush/sub_wcoss_c @@ -256,6 +256,17 @@ for var in $(eval echo $envars | tr , ' ') ; do echo "export $var" >> $cfile done +if [ $INHERIT_ENV = YES ] ; then + echo ". $MODULESHOME/init/ksh" >> $cfile +else + echo ". $MODULESHOME/init/sh" >> $cfile +fi +echo "module purge" >> $cfile +echo "module use -a $gsisrc/modulefiles" >> $cfile +echo "module load modulefile.ProdGSI.wcoss_c" >> $cfile +echo "module list" >> $cfile +echo "" >>$cfile + APRUN="aprun -j1 -n $procs -N $pe_node -d $nthreads -cc depth" echo "export APRUN='$APRUN'" >> $cfile diff --git a/ush/sub_wcoss_d b/ush/sub_wcoss_d new file mode 100755 index 000000000..9390f971c --- /dev/null +++ b/ush/sub_wcoss_d @@ -0,0 +1,345 @@ +#!/bin/ksh +set -x +# +# May 28, 2013 - Shrinivas Moorthi :now updated for lsf9.1.1 - should handle coupled case also +# +usage="\ +Usage: $0 [options] executable [args] + where the options are: + -a account account (default: none) + -b binding run smt binding or not (default:NO) + -d dirin initial directory (default: cwd) + -e envars copy comma-separated environment variables + -g group group name + -i append standard input to command file + -j jobname specify jobname (default: executable basename) +# -m machine machine on which to run (default: current) + -m mpiver mpi version (poe or intelmpi) (default: poe) + -n write command file to stdout rather than submitting it + -o output specify output file (default: jobname.out) + -p procs[/nodes[/ppreq] + number of MPI tasks and optional nodes or Bblocking and + ppreq option (N or S) (defaults: serial, Bunlimited, S) + -q queue[/qpreq] queue name and optional requirement, e.g. dev/P + (defaults: 1 if serial or dev if parallel and none) + (queue 3 or 4 is dev or prod with twice tasks over ip) + (options: P=parallel, B=bigmem, b=batch) + -r rmem[/rcpu[/pe_node] resources memory and cpus/task and cores per node (default: '1024 mb', 1, and 16) + -t timew wall time limit in [[hh:]mm:]ss format (default: 900) + -u userid userid to run under (default: self) + -v verbose mode + -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or + Thh[mm] (full, incremental, today or tomorrow) format + (default: now) + + You can also export variables \"TASK_GEOMETRY\" (default:-\"NONE\") and + \"INHERIT_ENV\" (default:-\"YES\") - Set this variable to \"NO\" and + export it if you do not want the next job to inherit current job + environment. + + Other environmental variables which can be exported from outside are: + + \"KMP_STACKSIZE\" (default:-\"1024m\") + \"MP_EUIDEVELOP\" (default:-\"NULL\") + \"F_UFMTENDIAN\" (default:-\"NULL\") + \"MPICH_ALLTOALL_THROTTLE\" (default:-\"NULL\") + \"MP_SINGLE_THREAD\" (default:-\"NULL\") + \"MP_EAGER_LIMIT\" (default:-\"NULL\") + \"MP_USE_BULK_XFER\" (default:-\"NULL\") + \"MP_COLLECTIVE_OFFLOAD\" (default:-\"NULL\") + \"MP_SHARED_MEMORY\" (default:-\"NULL\") + \"MP_MPILIB\" (default:-\"NULL\") + \"MP_LABELIO\" (default:-\"NULL\") + \"MP_STDOUTMODE\" (default:-\"NULL\") + \"DATA\" (default:-\"/stmpp1/$LOGNAME/sub\" + - deleted at the end if created) + +Function: This command submits a job to the batch queue." +subcmd="$*" +stdin=NO +nosub=NO +account="" +binding="NO" +dirin="" +envars="" +group="" +jobname="" +machine="" +mpiver="" +output="" +procs=0 +nodes="" +ppreq="" +queue="" +qpreq="" +rmem="1024" +rcpu="1" +pe_node="16" +timew="900" +userid="" +verbose=NO +when="" +while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do + case $opt in + a) account="$OPTARG";; + b) binding="$OPTARG";; + d) dirin="$OPTARG";; + e) envars="$OPTARG";; + g) group="$OPTARG";; + i) stdin=YES;; + j) jobname=$OPTARG;; +# m) machine="$OPTARG";; + m) mpiver="$OPTARG";; + n) nosub=YES;; + o) output=$OPTARG;; + p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; + q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; + r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);pe_node=$(echo $OPTARG/|cut -d/ -f3);; + t) timew=$OPTARG;; + u) userid=$OPTARG;; + v) verbose=YES;; + w) when=$OPTARG;; + \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; + esac +done +shift $(($OPTIND-1)) +if [[ $# -eq 0 ]];then + echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 +fi +exec=$1 +if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then + exec=$(which $exec) +fi +shift +args="$*" +bn=$(basename $exec) +export jobname=${jobname:-$bn} +output=${output:-$jobname.out} +myuser=$LOGNAME +myhost=$(hostname) +#mpiver=${mpiver:-intelmpi} +envars=$envars + +#DATA=/lustre/fs/scratch/$LOGNAME/stmpp1 +DATA=${DATA:-/gpfs/dell2/ptmp/$LOGNAME/sub} +if [ -s $DATA ] ; then + MKDATA=NO +else + mkdir -p $DATA + MKDATA=YES +fi + +queue=${queue:-dev} +timew=${timew:-01:20} +timew=$(echo $timew |cut -d: -f1):$(echo $timew |cut -d: -f2) +threads=${rcpu:-1} + + +max_core=${max_core:-16} +task_node=${pe_node:-${task_node:-$max_core}} + +export INHERIT_ENV=${INHERIT_ENV:-YES} +export TASK_GEOMETRY=${TASK_GEOMETRY:-NONE} +if [ "$TASK_GEOMETRY" = NONE ] ; then + if [ $nodes -eq 1 ] ; then + task_node=$procs + fi + tot_size=$((procs*nodes)) +else + tot_size=$((task_node*nodes)) +fi +if [ $((task_node*threads)) -gt $max_core ]; then + core=cpu + echo "Hyper-threading is used - setting core=$core" +fi +export core=${core:-core} + +export KMP_STACKSIZE=${KMP_STACKSIZE:-1024m} + +export TZ=GMT +cfile=$DATA/sub$$ +> $cfile + +if [ $INHERIT_ENV = YES ] ; then + echo "#!/bin/bash" >> $cfile +else + echo "#!/bin/bash " >> $cfile + echo "#BSUB -L /bin/bash" >> $cfile +fi +#echo "#BSUB -a $mpiver" >> $cfile +echo "#BSUB -P $account" >> $cfile +echo "#BSUB -e $output" >> $cfile +echo "#BSUB -o $output" >> $cfile +echo "#BSUB -cwd $dirin" >> $cfile +##echo "#BSUB -o $output.%J" >> $cfile +echo "#BSUB -J $jobname" >> $cfile +#echo "#BSUB -network type=sn_all:mode=US" >> $cfile +echo "#BSUB -q $queue" >> $cfile +echo "#BSUB -n $tot_size" >> $cfile +if [ $mpiver = openmp ] ; then + echo "#BSUB -R span[ptile=$procs]" >> $cfile + echo "#BSUB -R affinity[$core]" >> $cfile + echo "#BSUB -R rusage[mem=$rmem]" >> $cfile +else + echo "#BSUB -R span[ptile=$procs]" >> $cfile +fi +if [ $threads -gt 1 ] ; then + if [ $core = core ] ; then + echo "#BSUB -R affinity[core($threads)]" >> $cfile + if [ $queue = shared -o $ppreq = S ] ; then + echo "#BSUB -R rusage[mem=$rmem]" >> $cfile + else + echo "#BSUB -x" >> $cfile + fi + else + if [ $queue = shared -o $ppreq = S ] ; then + echo "#BSUB -R affinity[cpu($threads):distribute=balance]" >> $cfile + echo "#BSUB -R rusage[mem=$rmem]" >> $cfile + else + echo "#BSUB -R affinity[cpu($threads):distribute=balance]" >> $cfile + echo "#BSUB -x" >> $cfile + fi + fi +else + if [ $core = core ] ; then + echo "#BSUB -R affinity[$core]" >> $cfile + if [ $queue = shared -o $ppreq = S ] ; then + echo "#BSUB -R rusage[mem=$rmem]" >> $cfile + else + echo "#BSUB -x" >> $cfile + fi + else + if [ $queue = shared -o $ppreq = S ] ; then + echo "#BSUB -R affinity[cpu:distribute=balance]" >> $cfile + echo "#BSUB -R rusage[mem=$rmem]" >> $cfile + else + echo "#BSUB -R affinity[cpu:distribute=balance]" >> $cfile + echo "#BSUB -x" >> $cfile + fi + fi +fi +echo "#BSUB -W $timew" >> $cfile + +if [[ -n $when ]];then + whena=$when + if [[ $when = +* ]];then + hr=$(echo $when|cut -c2-3) + mn=$(echo $when|cut -c4-5) + [[ -n $mn ]] || mn=00 + now=$(date -u +"%Y%m%d%H%M") + ((mn+=$(echo $now|cut -c11-12))) + [[ $mn -ge 60 ]] && ((hr+=1)) && ((mn-=60)) + [[ $mn -lt 10 ]] && mn=0$mn + whena=$(/nwprod/util/exec/ndate +$hr $(echo $now|cut -c1-10))$mn + elif [[ $when = t* ]];then + hr=$(echo $when|cut -c2-3) + mn=$(echo $when|cut -c4-5) + [[ -n $mn ]] || mn=00 + now=$(date -u +"%Y%m%d") + whena=$now$hr$mn + elif [[ $when = T* ]];then + hr=$(echo $when|cut -c2-3) + mn=$(echo $when|cut -c4-5) + [[ -n $mn ]] || mn=00 + now=$(date -u +"%Y%m%d%H") + whena=$(/nwprod/util/exec/ndate +24 $now|cut -c1-8)$hr$mn + fi + yr=$(echo $whena|cut -c1-4) + mo=$(echo $whena|cut -c5-6) + dy=$(echo $whena|cut -c7-8) + hr=$(echo $whena|cut -c9-10) + mn=$(echo $whena|cut -c11-12) + [[ -n $mn ]] || mn=00 + echo "#BSUB -b $yr:$mo:$dy:$hr:$mn" >> $cfile +fi + +#echo "source ~${LOGNAME}/.profile" >> $cfile +#echo "ulimit -s unlimited" >> $cfile +#if [ ${MP_EUIDEVICE:-NULL} = sn_all ] ; then +#echo "#BSUB -network \"type=sn_all:mode=US\" " >> $cfile +#fi +#if [ ${MP_EULIB:-NULL} != NULL ] ; then +#echo "export MP_EUILIB=$MP_EUILIB" >> $cfile +#fi + +if [ ${MP_EUIDEVELOP:-NULL} != NULL ] ; then + echo "export MP_EUIDEVELOP=$MP_EUIDEVELOP" >> $cfile +fi +echo "export KMP_STACKSIZE=$KMP_STACKSIZE" >> $cfile +if [ ${F_UFMTENDIAN:-NULL} != NULL ] ; then + echo "export F_UFMTENDIAN=$F_UFMTENDIAN" >> $cfile +fi +if [ ${MPICH_ALLTOALL_THROTTLE:-NULL} != NULL ] ; then + echo "export MPICH_ALLTOALL_THROTTLE=$MPICH_ALLTOALL_THROTTLE" >> $cfile +fi +if [ ${MP_SINGLE_THREAD:-NULL} != NULL ] ; then + echo "export MP_SINGLE_THREAD=$MP_SINGLE_THREAD" >> $cfile +fi +if [ ${MP_EAGER_LIMIT:-NULL} != NULL ] ; then + echo "export MP_EAGER_LIMIT=$MP_EAGER_LIMIT" >> $cfile +fi + +if [ ${MP_USE_BULK_XFER:-NULL} != NULL ] ; then + echo "export MP_USE_BULK_XFER=$MP_USE_BULK_XFER" >> $cfile +fi +if [ ${MP_COLLECTIVE_OFFLOAD:-NULL} != NULL ] ; then + echo "export MP_COLLECTIVE_OFFLOAD=$MP_COLLECTIVE_OFFLOAD" >> $cfile +fi +if [ ${MP_SHARED_MEMORY:-NULL} != NULL ] ; then + echo "export MP_SHARED_MEMORY=$MP_SHARED_MEMORY" >> $cfile +fi +if [ ${MP_MPILIB:-NULL} != NULL ] ; then + echo "export MP_MPILIB=$MP_MPILIB" >> $cfile +fi +if [ ${MP_LABELIO:-NULL} != NULL ] ; then + echo "export MP_LABELIO=$MP_LABELIO" >> $cfile +fi +if [ ${MP_STDOUTMODE:-NULL} != NULL ] ; then + echo "export MP_STDOUTMODE=$MP_STDOUTMODE " >> $cfile +fi +if [ "$TASK_GEOMETRY" != NONE ] ; then + echo "export LSB_PJL_TASK_GEOMETRY=\"$TASK_GEOMETRY\"" >> $cfile +fi +for var in $(eval echo $envars | tr , ' ') ; do + echo "export $var" >> $cfile +done + +echo "export OMP_NUM_THREADS=$threads" >> $cfile +echo "" >>$cfile +echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >> $cfile +echo "" >>$cfile + +echo ". $MODULESHOME/init/bash" >> $cfile +echo "module purge" >> $cfile +echo "module use -a $gsisrc/modulefiles" >> $cfile +echo "module load modulefile.ProdGSI.wcoss_d" >> $cfile +echo "module list" >> $cfile +echo "" >>$cfile + +echo "$exec" >> $cfile + +if [[ $stdin = YES ]];then + cat +fi >>$cfile +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +bsub=${bsub:-$LSF_BINDIR/bsub} + +ofile=subout$$ +>$ofile +chmod 777 $ofile +$bsub < $cfile +rc=$? +cat $ofile +if [[ -w $SUBLOG ]];then + jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) + date +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG +fi +rm $cfile $ofile +[[ $MKDATA = YES ]] && rmdir $DATA +exit $rc diff --git a/ush/sub_zeus b/ush/sub_zeus deleted file mode 100755 index 65ee64f9d..000000000 --- a/ush/sub_zeus +++ /dev/null @@ -1,200 +0,0 @@ -#!/bin/sh --login -set -x -usage="\ -Usage: $0 [options] executable [args] - where the options are: - -a account account (default: none) - -b binding run smt binding or not (default:NO) - -d dirin initial directory (default: cwd) - -e envars copy comma-separated environment variables - -g group group name - -i append standard input to command file - -j jobname specify jobname (default: executable basename) - -m machine machine on which to run (default: current) - -n write command file to stdout rather than submitting it - -o output specify output file (default: jobname.out) - -p procs[/nodes[/ppreq] - number of MPI tasks and optional nodes or Bblocking and - ppreq option (N or S) (defaults: serial, Bunlimited, S) - -q queue[/qpreq] queue name and optional requirement, e.g. dev/P - (defaults: 1 if serial or dev if parallel and none) - (queue 3 or 4 is dev or prod with twice tasks over ip) - (options: P=parallel, B=bigmem, b=batch) - -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) - -t timew wall time limit in [[hh:]mm:]ss format (default: 900) - -u userid userid to run under (default: self) - -v verbose mode - -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or - Thh[mm] (full, incremental, today or tomorrow) format - (default: now) -Function: This command submits a job to the batch queue." -subcmd="$*" -stdin=NO -nosub=NO -account="" -binding="NO" -dirin="" -envars="" -group="" -jobname="" -machine="" -output="" -procs=0 -nodes="" -ppreq="" -queue="" -qpreq="" -rmem="1024" -rcpu="1" -timew="900" -userid="" -verbose=NO -when="" -while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do - case $opt in - a) account="$OPTARG";; - b) binding="$OPTARG";; - d) dirin="$OPTARG";; - e) envars="$OPTARG";; - g) group="$OPTARG";; - i) stdin=YES;; - j) jobname=$OPTARG;; - m) machine="$OPTARG";; - n) nosub=YES;; - o) output=$OPTARG;; - p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; - q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; - r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; - t) timew=$OPTARG;; - u) userid=$OPTARG;; - v) verbose=YES;; - w) when=$OPTARG;; - \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; - esac -done -shift $(($OPTIND-1)) -if [[ $# -eq 0 ]];then - echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 -fi -exec=$1 -if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then - exec=$(which $exec) -fi -shift -args="$*" -bn=$(basename $exec) -export jobname=${jobname:-$bn} -output=${output:-$jobname.out} -myuser=$LOGNAME -myhost=$(hostname) - -DATA=/scratch4/NCEPDEV/stmp4/$LOGNAME/tmp -mkdir -p $DATA - -#partition=${partition:-c1ms} -queue=${queue:-batch} -timew=${timew:-01:20:00} -task_node=${task_node:-$procs} -size=$((nodes*task_node)) -envars=$envars -threads=${rcpu:-1} -#envars=$envars,mpi_tasks=$procs -#Options -###PBS -l partition=c1ms,size=0528,walltime=01:20:00 -##PBS -l partition=$queue,size=$size,walltime=$timew -##PBS -S /bin/sh - -export TZ=GMT -cfile=$DATA/sub$$ -> $cfile -#echo "#PBS -S /bin/sh" >> $cfile -echo "#!/bin/sh --login" >> $cfile -echo "" >> $cfile -echo "#PBS -o $output" >> $cfile -echo "#PBS -N $jobname" >> $cfile -echo "#PBS -q $queue" >> $cfile -echo "#PBS -l walltime=$timew" >> $cfile -echo "#PBS -l nodes=$nodes:ppn=$procs" >> $cfile -echo "#PBS -j oe" >> $cfile -echo "#PBS -A "$accnt >> $cfile -echo "#PBS -V" >> $cfile -#echo "#PBS -d" >> $cfile -#. $exec >> $cfile -#echo "/bin/sh -x $exec" >> $cfile - -echo "" >>$cfile -echo "export OMP_NUM_THREADS=$threads" >> $cfile -echo "" >>$cfile -echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile -echo "" >>$cfile - -cat $exec >> $cfile - -if [[ $nosub = YES ]];then - cat $cfile - exit -elif [[ $verbose = YES ]];then - set -x - cat $cfile -fi -#msub -I partition=$partition,size=$procs,walltime=$walltime $cfile - -#if [[ -n $when ]];then -# whena=$when -# if [[ $when = +* ]];then -# hr=$(echo $when|cut -c2-3) -# mn=$(echo $when|cut -c4-5) -# [[ -n $mn ]] || mn=00 -# now=$(date -u +"%Y%m%d%H%M") -# ((mn+=$(echo $now|cut -c11-12))) -# [[ $mn -ge 60 ]] && ((hr+=1)) && ((mn-=60)) -# [[ $mn -lt 10 ]] && mn=0$mn -# whena=$(/nwprod/util/exec/ndate +$hr $(echo $now|cut -c1-10))$mn -# elif [[ $when = t* ]];then -# hr=$(echo $when|cut -c2-3) -# mn=$(echo $when|cut -c4-5) -# [[ -n $mn ]] || mn=00 -# now=$(date -u +"%Y%m%d") -# whena=$now$hr$mn -# elif [[ $when = T* ]];then -# hr=$(echo $when|cut -c2-3) -# mn=$(echo $when|cut -c4-5) -# [[ -n $mn ]] || mn=00 -# now=$(date -u +"%Y%m%d%H") -# whena=$(/nwprod/util/exec/ndate +24 $now|cut -c1-8)$hr$mn -# fi -# yr=$(echo $whena|cut -c1-4) -# mo=$(echo $whena|cut -c5-6) -# dy=$(echo $whena|cut -c7-8) -# hr=$(echo $whena|cut -c9-10) -# mn=$(echo $whena|cut -c11-12) -# [[ -n $mn ]] || mn=00 -# echo "#@ startdate = $mo/$dy/$yr $hr:$mn" -#fi >>$cfile - - -if [[ $stdin = YES ]];then - cat -fi >>$cfile -if [[ $nosub = YES ]];then - cat $cfile - exit -elif [[ $verbose = YES ]];then - set -x - cat $cfile -fi -qsub=${qsub:-qsub} - -ofile=$DATA/subout$$ ->$ofile -chmod 777 $ofile -$qsub $cfile >$ofile -rc=$? -cat $ofile -if [[ -w $SUBLOG ]];then - jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) - date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG -fi -rm $cfile $ofile -[[ $MKDATA = YES ]] && rmdir $DATA -exit $rc diff --git a/util/AeroDA/calc_increment_ens.fd/CMakeLists.txt b/util/AeroDA/calc_increment_ens.fd/CMakeLists.txt new file mode 100644 index 000000000..7a11c1fd1 --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/CMakeLists.txt @@ -0,0 +1,14 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_UTIL_COM) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + list( REMOVE_ITEM LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/main.f90 ) + + set(Util_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/calc_increment_ens_aero") + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + add_executable(calc_increment_ens_aero.x ${LOCAL_SRC} ) + set_target_properties( calc_increment_ens_aero.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + set_target_properties( calc_increment_ens_aero.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIRECTORY} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${UTIL_INC} ${NEMSIOINC} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ) + target_link_libraries( calc_increment_ens_aero.x ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${MPI_Fortran_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${ZLIB_LIBRARIES} ${CURL_LIBRARIES} ) +endif() diff --git a/util/AeroDA/calc_increment_ens.fd/calc_increment_interface.f90 b/util/AeroDA/calc_increment_ens.fd/calc_increment_interface.f90 new file mode 100644 index 000000000..41c0ac59b --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/calc_increment_interface.f90 @@ -0,0 +1,75 @@ +! Copyright (C) 2015 Henry R. Winterbottom + +! Email: Henry.Winterbottom@noaa.gov + +! Snail-mail: + +! Henry R. Winterbottom +! NOAA/OAR/PSD R/PSD1 +! 325 Broadway +! Boulder, CO 80303-3328 + +! This file is part of global-model-py. + +! global-model-py is free software: you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation, either version 3 of +! the License, or (at your option) any later version. + +! global-model-py is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU General Public License for more details. + +! You should have received a copy of the GNU General Public License +! along with global-model-py. If not, see +! . + +module calc_increment_interface + + !======================================================================= + + ! Define associated modules and subroutines + + !----------------------------------------------------------------------- + + use fv3_interface + + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + + ! Define interfaces and attributes for module routines + + private + public :: calc_increment + + !----------------------------------------------------------------------- + +contains + + !======================================================================= + + ! calc_increment.f90: + + !----------------------------------------------------------------------- + + subroutine calc_increment(mype) + + integer,intent(in) :: mype + + !===================================================================== + + ! Check local variable and proceed accordingly + + call fv3_calc_increment(mype) + + !===================================================================== + + end subroutine calc_increment + + !======================================================================= + +end module calc_increment_interface diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/configure b/util/AeroDA/calc_increment_ens.fd/configure similarity index 100% rename from util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/configure rename to util/AeroDA/calc_increment_ens.fd/configure diff --git a/util/AeroDA/calc_increment_ens.fd/constants.f90 b/util/AeroDA/calc_increment_ens.fd/constants.f90 new file mode 100644 index 000000000..c0a066eec --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/constants.f90 @@ -0,0 +1,314 @@ +! this module was extracted from the GSI version operational +! at NCEP in Dec. 2007. +module constants +!$$$ module documentation block +! . . . . +! module: constants +! prgmmr: treadon org: np23 date: 2003-09-25 +! +! abstract: This module contains the definition of various constants +! used in the gsi code +! +! program history log: +! 2003-09-25 treadon - original code +! 2004-03-02 treadon - allow global and regional constants to differ +! 2004-06-16 treadon - update documentation +! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind +! and tiny_single +! 2004-11-16 treadon - add huge_single, huge_r_kind parameters +! 2005-01-27 cucurull - add ione +! 2005-08-24 derber - move cg_term to constants from qcmod +! 2006-03-07 treadon - add rd_over_cp_mass +! 2006-05-18 treadon - add huge_i_kind +! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) +! 2006-07-28 derber - add r1000 +! +! Subroutines Included: +! sub init_constants - compute derived constants, set regional/global constants +! +! Variable Definitions: +! see below +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_single,r_kind,i_kind + implicit none + +! Declare constants + integer(i_kind) izero,ione + real(r_kind) rearth,grav,omega,rd,rv,cp,cv,cvap,cliq + real(r_kind) csol,hvap,hfus,psat,t0c,ttp,jcal,cp_mass,cg_term + real(r_kind) fv,deg2rad,rad2deg,pi,tiny_r_kind,huge_r_kind,huge_i_kind + real(r_kind) ozcon,rozcon,tpwcon,rd_over_g,rd_over_cp,g_over_rd + real(r_kind) amsua_clw_d1,amsua_clw_d2,constoz,zero,one,two,four + real(r_kind) one_tenth,quarter,three,five,rd_over_cp_mass, gamma + real(r_kind) rearth_equator,stndrd_atmos_ps,r1000 + real(r_kind) semi_major_axis,semi_minor_axis,n_a,n_b + real(r_kind) eccentricity,grav_polar,grav_ratio + real(r_kind) grav_equator,earth_omega,grav_constant + real(r_kind) flattening,eccentricity_linear,somigliana + real(r_kind) dldt,dldti,hsub,psatk,tmix,xa,xai,xb,xbi + real(r_kind) eps,epsm1,omeps,wgtlim + real(r_kind) elocp,cpr,el2orc,cclimit,climit,epsq + real(r_kind) pcpeff0,pcpeff1,pcpeff2,pcpeff3,rcp,c0,delta + real(r_kind) h1000,factor1,factor2,rhcbot,rhctop,dx_max,dx_min,dx_inv + real(r_kind) h300,half,cmr,cws,ke2,row,rrow + real(r_single) zero_single,tiny_single,huge_single + real(r_single) rmw_mean_distance, roic_mean_distance + logical :: constants_initialized = .true. + + +! Define constants common to global and regional applications +! name value description units +! ---- ----- ----------- ----- + parameter(rearth_equator= 6.37813662e6_r_kind) ! equatorial earth radius (m) + parameter(omega = 7.2921e-5_r_kind) ! angular velocity of earth (1/s) + parameter(cp = 1.0046e+3_r_kind) ! specific heat of air @pressure (J/kg/K) + parameter(cvap = 1.8460e+3_r_kind) ! specific heat of h2o vapor (J/kg/K) + parameter(csol = 2.1060e+3_r_kind) ! specific heat of solid h2o (ice)(J/kg/K) + parameter(hvap = 2.5000e+6_r_kind) ! latent heat of h2o condensation (J/kg) + parameter(hfus = 3.3358e+5_r_kind) ! latent heat of h2o fusion (J/kg) + parameter(psat = 6.1078e+2_r_kind) ! pressure at h2o triple point (Pa) + parameter(t0c = 2.7315e+2_r_kind) ! temperature at zero celsius (K) + parameter(ttp = 2.7316e+2_r_kind) ! temperature at h2o triple point (K) + parameter(jcal = 4.1855e+0_r_kind) ! joules per calorie () + parameter(stndrd_atmos_ps = 1013.25e2_r_kind) ! 1976 US standard atmosphere ps (Pa) + +! Numeric constants + parameter(izero = 0) + parameter(ione = 1) + parameter(zero_single = 0.0_r_single) + parameter(zero = 0.0_r_kind) + parameter(one_tenth = 0.10_r_kind) + parameter(quarter= 0.25_r_kind) + parameter(one = 1.0_r_kind) + parameter(two = 2.0_r_kind) + parameter(three = 3.0_r_kind) + parameter(four = 4.0_r_kind) + parameter(five = 5.0_r_kind) + parameter(r1000 = 1000.0_r_kind) + +! Constants for gps refractivity + parameter(n_a=77.6_r_kind) !K/mb + parameter(n_b=3.73e+5_r_kind) !K^2/mb + +! Parameters below from WGS-84 model software inside GPS receivers. + parameter(semi_major_axis = 6378.1370e3_r_kind) ! (m) + parameter(semi_minor_axis = 6356.7523142e3_r_kind) ! (m) + parameter(grav_polar = 9.8321849378_r_kind) ! (m/s2) + parameter(grav_equator = 9.7803253359_r_kind) ! (m/s2) + parameter(earth_omega = 7.292115e-5_r_kind) ! (rad/s) + parameter(grav_constant = 3.986004418e14_r_kind) ! (m3/s2) + +! Derived geophysical constants + parameter(flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis)!() + parameter(somigliana = & + (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one)!() + parameter(grav_ratio = (earth_omega*earth_omega * & + semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant) !() + +! Derived thermodynamic constants + parameter ( dldti = cvap-csol ) + parameter ( hsub = hvap+hfus ) + parameter ( psatk = psat*0.001_r_kind ) + parameter ( tmix = ttp-20._r_kind ) + parameter ( elocp = hvap/cp ) + parameter ( rcp = one/cp ) + +! Constants used in GFS moist physics + parameter ( h300 = 300._r_kind ) + parameter ( half = 0.5_r_kind ) + parameter ( cclimit = 0.001_r_kind ) + parameter ( climit = 1.e-20_r_kind) + parameter ( epsq = 2.e-12_r_kind ) + parameter ( h1000 = 1000.0_r_kind) + parameter ( rhcbot=0.85_r_kind ) + parameter ( rhctop=0.85_r_kind ) + parameter ( dx_max=-8.8818363_r_kind ) + parameter ( dx_min=-5.2574954_r_kind ) + parameter ( dx_inv=one/(dx_max-dx_min) ) + parameter ( c0=0.002_r_kind ) + parameter ( delta=0.6077338_r_kind ) + parameter ( pcpeff0=1.591_r_kind ) + parameter ( pcpeff1=-0.639_r_kind ) + parameter ( pcpeff2=0.0953_r_kind ) + parameter ( pcpeff3=-0.00496_r_kind ) + parameter ( cmr = one/0.0003_r_kind ) + parameter ( cws = 0.025_r_kind ) + parameter ( ke2 = 0.00002_r_kind ) + parameter ( row = 1000._r_kind ) + parameter ( rrow = one/row ) + +! Constant used to process ozone + parameter ( constoz = 604229.0_r_kind) + +! Constants used in cloud liquid water correction for AMSU-A +! brightness temperatures + parameter ( amsua_clw_d1 = 0.754_r_kind ) + parameter ( amsua_clw_d2 = -2.265_r_kind ) + +! Constants used for variational qc + parameter ( wgtlim = 0.25_r_kind) ! Cutoff weight for concluding that obs has been + ! rejected by nonlinear qc. This limit is arbitrary + ! and DOES NOT affect nonlinear qc. It only affects + ! the printout which "counts" the number of obs that + ! "fail" nonlinear qc. Observations counted as failing + ! nonlinear qc are still assimilated. Their weight + ! relative to other observations is reduced. Changing + ! wgtlim does not alter the analysis, only + ! the nonlinear qc data "count" + +! Constants describing the Extended Best-Track Reanalysis [Demuth et +! al., 2008] tropical cyclone (TC) distance for regions relative to TC +! track position; units are in kilometers + + parameter (rmw_mean_distance = 64.5479412) + parameter (roic_mean_distance = 338.319656) + +contains + subroutine init_constants_derived +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants_derived set derived constants +! prgmmr: treadon org: np23 date: 2004-12-02 +! +! abstract: This routine sets derived constants +! +! program history log: +! 2004-12-02 treadon +! 2005-03-03 treadon - add implicit none +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + +! Trigonometric constants + pi = acos(-one) + deg2rad = pi/180.0_r_kind + rad2deg = one/deg2rad + cg_term = (sqrt(two*pi))/two ! constant for variational qc + tiny_r_kind = tiny(zero) + huge_r_kind = huge(zero) + tiny_single = tiny(zero_single) + huge_single = huge(zero_single) + huge_i_kind = huge(izero) + +! Geophysical parameters used in conversion of geopotential to +! geometric height + eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) + eccentricity = eccentricity_linear / semi_major_axis + constants_initialized = .true. + + return + end subroutine init_constants_derived + + subroutine init_constants(regional) +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants set regional or global constants +! prgmmr: treadon org: np23 date: 2004-03-02 +! +! abstract: This routine sets constants specific to regional or global +! applications of the gsi +! +! program history log: +! 2004-03-02 treadon +! 2004-06-16 treadon, documentation +! 2004-10-28 treadon - use intrinsic TINY function to set value +! for smallest machine representable positive +! number +! 2004-12-03 treadon - move derived constants to init_constants_derived +! 2005-03-03 treadon - add implicit none +! +! input argument list: +! regional - if .true., set regional gsi constants; +! otherwise (.false.), use global constants +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + logical regional + real(r_kind) reradius,g,r_d,r_v,cliq_wrf + + gamma = 0.0065 + +! Define regional constants here + if (regional) then + +! Name given to WRF constants + reradius = one/6370.e03_r_kind + g = 9.81_r_kind + r_d = 287.04_r_kind + r_v = 461.6_r_kind + cliq_wrf = 4190.0_r_kind + cp_mass = 1004.67_r_kind + +! Transfer WRF constants into unified GSI constants + rearth = one/reradius + grav = g + rd = r_d + rv = r_v + cv = cp-r_d + cliq = cliq_wrf + rd_over_cp_mass = rd / cp_mass + +! Define global constants here + else + rearth = 6.3712e+6_r_kind + grav = 9.80665e+0_r_kind + rd = 2.8705e+2_r_kind + rv = 4.6150e+2_r_kind + cv = 7.1760e+2_r_kind + cliq = 4.1855e+3_r_kind + cp_mass= zero + rd_over_cp_mass = zero + endif + + +! Now define derived constants which depend on constants +! which differ between global and regional applications. + +! Constants related to ozone assimilation + ozcon = grav*21.4e-9_r_kind + rozcon= one/ozcon + +! Constant used in vertical integral for precipitable water + tpwcon = 100.0_r_kind/grav + +! Derived atmospheric constants + fv = rv/rd-one ! used in virtual temperature equation + dldt = cvap-cliq + xa = -(dldt/rv) + xai = -(dldti/rv) + xb = xa+hvap/(rv*ttp) + xbi = xai+hsub/(rv*ttp) + eps = rd/rv + epsm1 = rd/rv-one + omeps = one-eps + factor1 = (cvap-cliq)/rv + factor2 = hvap/rv-factor1*t0c + cpr = cp*rd + el2orc = hvap*hvap/(rv*cp) + rd_over_g = rd/grav + rd_over_cp = rd/cp + g_over_rd = grav/rd + + return + end subroutine init_constants + +end module constants diff --git a/util/AeroDA/calc_increment_ens.fd/fv3_interface.f90 b/util/AeroDA/calc_increment_ens.fd/fv3_interface.f90 new file mode 100644 index 000000000..6ede5b09b --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/fv3_interface.f90 @@ -0,0 +1,786 @@ +! Copyright (C) 2015 Henry R. Winterbottom + +! Email: Henry.Winterbottom@noaa.gov + +! Snail-mail: + +! Henry R. Winterbottom +! NOAA/OAR/PSD R/PSD1 +! 325 Broadway +! Boulder, CO 80303-3328 + +! This file is part of global-model-py. + +! global-model-py is free software: you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation, either version 3 of +! the License, or (at your option) any later version. + +! global-model-py is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU General Public License for more details. + +! You should have received a copy of the GNU General Public License +! along with global-model-py. If not, see +! . + +module fv3_interface + + !======================================================================= + + ! Define associated modules and subroutines + + !----------------------------------------------------------------------- + + use constants + use kinds + + !----------------------------------------------------------------------- + + use gfs_nems_interface + use namelist_def + use netcdf + use variable_interface + + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + + ! Define all data and structure types for routine; these variables + ! are variables required by the subroutines within this module + + type analysis_grid + character(len=500) :: filename + real(r_kind), dimension(:,:,:), allocatable :: var3d + real(r_kind), dimension(:,:), allocatable :: psfc + real(r_kind), dimension(:), allocatable :: ak + real(r_kind), dimension(:), allocatable :: bk + real(r_kind), dimension(:), allocatable :: ck + real(r_kind), dimension(:), allocatable :: lon + real(r_kind), dimension(:), allocatable :: lat + real(r_kind), dimension(:), allocatable :: lev + real(r_kind), dimension(:), allocatable :: ilev + real(r_kind), dimension(:), allocatable :: pfull + real(r_kind), dimension(:), allocatable :: hyai + real(r_kind), dimension(:), allocatable :: hybi + integer :: nx = -1 + integer :: ny = -1 + integer :: nz = -1 + integer :: nzp1 = 0 + logical :: is_allocated = .false. + logical :: flip_lats = .true. + logical :: ldpres = .true. + end type analysis_grid ! type analysis_grid + + type increment_netcdf + integer :: dimid_lon = -1 + integer :: dimid_lat = -1 + integer :: dimid_lev = -1 + integer :: dimid_ilev = -1 + integer :: ncfileid = -1 + end type increment_netcdf + + integer, parameter :: n_inc_vars = 15 !! number of known variables + + ! Define global variables + + type(nemsio_meta) :: meta_nemsio !! nemsio metadata for the current file + type(analysis_grid) :: an_grid !! analysis grid data + type(analysis_grid) :: fg_grid !! first guess grid data + + !! All known output variables. These are the names in the output + !! NetCDF file. The input names are in input_vars. + character(len=11), dimension(n_inc_vars) :: output_vars=(/ & + 'sulf_inc ', 'bc1_inc ', 'bc2_inc ', 'oc1_inc ', & + 'oc2_inc ', 'dust1_inc ', 'dust2_inc ', 'dust3_inc ', & + 'dust4_inc ', 'dust5_inc ', 'seas1_inc ', 'seas2_inc ', & + 'seas3_inc ', 'seas4_inc ', 'seas5_inc ' /) + + !! Synonyms for output_vars needed to be backward-compatible with + !! bugs in the prior version of this script. These are used to + !! match to increments_to_zero. + character(len=11), dimension(n_inc_vars) :: var_zero_synonyms=(/ & + 'sulf_inc ', 'bc1_inc ', 'bc2_inc ', 'oc1_inc ', & + 'oc2_inc ', 'dust1_inc ', 'dust2_inc ', 'dust3_inc ', & + 'dust4_inc ', 'dust5_inc ', 'seas1_inc ', 'seas2_inc ', & + 'seas3_inc ', 'seas4_inc ', 'seas5_inc ' /) + + !! The input name from nemsio that matches each output filename from + !! output_vars. + character(len=11), dimension(n_inc_vars) :: input_vars=(/ & + 'sulf ', 'bc1 ', 'bc2 ', 'oc1 ', & + 'oc2 ', 'dust1 ', 'dust2 ', 'dust3 ', & + 'dust4 ', 'dust5 ', 'seas1 ', 'seas2 ', & + 'seas3 ', 'seas4 ', 'seas5 ' /) + + private + public :: fv3_calc_increment + + !======================================================================= + !======================================================================= + +contains + + !======================================================================= + !======================================================================= + + subroutine fv3_calc_increment(mype) + + integer,intent(in) :: mype + + type(gfs_grid) :: grid !! GFS analysis grid + + type(increment_netcdf) :: ncdat !! cached info about NetCDF output file + + integer :: i, j, k ! loop indices within a variable + integer :: ivar !! loop index over variables in input_vars & output_vars + + ! Formats for print statements: +100 format(A,': ',A) + + ! ------------------------------------------------------------------ + ! Initialize memory, read metadata, and read 1D arrays. + + ! Calculate constants + call init_constants_derived() + + ! Allocate grids for analysis and first guess + call fv3_grid_allocate(an_grid,fg_grid) + + ! Read the analysis and first guess non-increment vars and pressure: + an_grid%filename = analysis_filename + fg_grid%filename = firstguess_filename + call fv3_analysis_read_non_inc_vars(an_grid) + call fv3_analysis_read_non_inc_vars(fg_grid) + + ! ------------------------------------------------------------------ + ! Deal with everything that is NOT a 3D array: + + ! Copy horizontal dimensions from analysis grid + grid%nlons = an_grid%nx + grid%nlats = an_grid%ny + + ! Read the nemsio header + call gfs_nems_initialize(meta_nemsio, firstguess_filename) + call gfs_grid_initialize(grid, meta_nemsio) + + an_grid%lon = grid%rlon(:,1) + + ! reverse latitudes (so they are in increasing order, S to N) + if (grid%rlat(1,1) > grid%rlat(1,grid%nlats)) then + do j=1,grid%nlats + an_grid%lat(j) = grid%rlat(1,grid%nlats-j+1) + enddo + else + an_grid%lat = grid%rlat(1,:) + endif + + ! Fill 1D vertical arrays with level numbers: + + nz_init: do k = 1, an_grid%nz + an_grid%lev(k) = real(k) + an_grid%pfull(k) = real(k) + end do nz_init + + nzp1_init: do k = 1, an_grid%nzp1 + an_grid%ilev(k) = real(k) + an_grid%hyai(k) = real(k) + an_grid%hybi(k) = real(k) + end do nzp1_init + + ! Deallocate entire grid. + call gfs_grid_cleanup(grid) + call gfs_nems_finalize() + + ! ------------------------------------------------------------------ + ! Start the NetCDF file creation. Define vars and write + ! non-increment vars. + + call fv3_increment_def_start(an_grid,ncdat) + + var_def_loop: do ivar=1,n_inc_vars + call fv3_increment_def_var(ncdat,output_vars(ivar)) + if(trim(input_vars(ivar)) == 'icmr' .and. .not. do_icmr) then + if (mype==0) print 100, output_vars(ivar), 'do_icmr = F so var will not be in netcdf' + cycle var_def_loop + endif + enddo var_def_loop + + call fv3_increment_def_end(ncdat) + call fv3_increment_write_start(an_grid,ncdat) + + ! ------------------------------------------------------------------ + ! Deal with 3D arrays + + var_loop: do ivar=1,n_inc_vars + ! Skip this var if it is icmr and we're told not to do_icmr: + if(trim(input_vars(ivar)) == 'icmr' .and. .not. do_icmr) then + if (mype==0) print 100, trim(output_vars(ivar)), & + 'do_icmr = F so will not diff this var' + cycle var_loop + endif + + ! Skip this var if it is to be zero. No point in reading it... + zero_or_read: if(should_zero_increments_for(var_zero_synonyms(ivar))) then + if (mype==0) print 100, trim(output_vars(ivar)), & + 'is in incvars_to_zero; setting increments to zero' + an_grid%var3d = 0 + else + + ! This var should not be skipped. Let's get the analysis and + ! first guess from the input files. + if(trim(input_vars(ivar)) == 'dpres') then + ! Special case. We may have to calculate the 3D pressure + ! from the 2D surface pressure and coordinate system using + ! the hydrostatic approximation. + call fv3_analysis_read_or_calc_dpres(an_grid,mype) + call fv3_analysis_read_or_calc_dpres(fg_grid,mype) + else + ! Read the variable from the files directly. + if (mype==0) print 100, trim(output_vars(ivar)), 'read variable' + call fv3_analysis_read_var(an_grid,input_vars(ivar)) + call fv3_analysis_read_var(fg_grid,input_vars(ivar)) + endif + + ! Subtract and write + an_grid%var3d = an_grid%var3d - fg_grid%var3d + endif zero_or_read + + call fv3_netcdf_write_var3d(ncdat,output_vars(ivar),an_grid%var3d) + enddo var_loop + + call fv3_increment_write_end(ncdat) + + call fv3_grid_deallocate(an_grid,fg_grid) + + end subroutine fv3_calc_increment + + !======================================================================= + + !! Is this variable in incvars_to_zero? + logical function should_zero_increments_for(check_var) + + character(len=*), intent(in) :: check_var !! Variable to search for + + ! Local variables + + character(len=10) :: varname ! temporary string for storing variable names + integer :: i ! incvars_to_zero loop index + + should_zero_increments_for=.false. + + zeros_loop: do i=1,max_vars + varname = incvars_to_zero(i) + if ( trim(varname) == check_var ) then + should_zero_increments_for=.true. + return + endif + end do zeros_loop + + end function should_zero_increments_for + + !======================================================================= + !== BASIC NETCDF UTILITIES ============================================= + !======================================================================= + + subroutine fv3_netcdf_def_var(ncdat,varname,ncdimid,att1_name,& + att1_values,att2_name,att2_values) + + ! Define variables passed to routine + + type(increment_netcdf) :: ncdat !! NetCDF file ids + character(len=*) :: varname !! Name of the variable to define + integer, dimension(:) :: ncdimid !! IDs of the file dimensions + character(len=*), optional :: att1_name !! name of the first attribute + character(len=*), optional :: att1_values !! value of the first attribute + character(len=*), optional :: att2_name !! name of the second attribute + character(len=*), optional :: att2_values !! value of the second attribute + + ! Local variable + + integer :: ncvarid ! NetCDF variable ID of the variable we create. + + ! Define the variable in the NetCDF file. + call netcdf_check( & + nf90_def_var(ncdat%ncfileid,varname,nf90_float,ncdimid,ncvarid), & + 'nf90_def_var',context=varname) + + ! If attributes were given, define those too. + if(present(att1_name) .and. present(att1_values)) then + call netcdf_check( & + nf90_put_att(ncdat%ncfileid,ncvarid,att1_name,att1_values), & + 'nf90_def_var',context=varname // ' ' // att1_name) + end if + if(present(att2_name) .and. present(att2_values)) then + call netcdf_check( & + nf90_put_att(ncdat%ncfileid,ncvarid,att2_name,att2_values), & + 'nf90_def_var',context=varname // ' ' // att2_name) + end if + end subroutine fv3_netcdf_def_var + + !======================================================================= + + subroutine fv3_netcdf_write_var1d(ncdat,varname,values) + + ! Define variables passed to routine + + type(increment_netcdf) :: ncdat + character(len=*) :: varname + real(r_kind), intent(in), dimension(:) :: values + + ! Define variables computed within routine + + integer :: ncvarid + + call netcdf_check(nf90_inq_varid(ncdat%ncfileid,varname,ncvarid),& + 'nf90_inq_varid',context=varname) + call netcdf_check(nf90_put_var(ncdat%ncfileid,ncvarid,values),& + 'nf90_put_var',context=varname) + + end subroutine fv3_netcdf_write_var1d + + !======================================================================= + + subroutine fv3_netcdf_write_var3d(ncdat,varname,values) + + ! Define variables passed to routine + + type(increment_netcdf) :: ncdat + character(len=*),intent(in) :: varname + real(r_kind), intent(in), dimension(:,:,:) :: values + + ! Define variables computed within routine + + integer :: ncvarid + + call netcdf_check(nf90_inq_varid(ncdat%ncfileid,varname,ncvarid),& + 'nf90_inq_varid',context=varname) + call netcdf_check(nf90_put_var(ncdat%ncfileid,ncvarid,values),& + 'nf90_put_var',context=varname) + + end subroutine fv3_netcdf_write_var3d + + !======================================================================= + + integer function fv3_netcdf_def_dim(ncdat,dimname,dimlen) + ! Arguments to function + type(increment_netcdf) :: ncdat !! storage areas for some netcdf ids + character(len=*) :: dimname !! name of the new dimension + integer :: dimlen !! length of the new dimension + + call netcdf_check(& + nf90_def_dim(ncdat%ncfileid,dimname,dimlen,fv3_netcdf_def_dim),& + 'nf90_def_dim',context=dimname) + + end function fv3_netcdf_def_dim + + !======================================================================= + + subroutine netcdf_check(ncstatus, nf90_call, context) + use mpi + implicit none + + ! Arguments to subroutine + integer, intent(in) :: ncstatus !! return status from nf90 function + character(len=*), intent(in) :: nf90_call !! name of the called function + character(len=*), intent(in), optional :: context !! contextual info + + integer :: ierr + + ! Formats for print statements +100 format('error in: ',A,': ',A,': ',A) ! context was supplied +200 format('error in: ',A,': ',A) ! context was not supplied + + ! If the nf90 function returned an error status then... + if (ncstatus /= nf90_noerr) then + + ! send an informative message to stdout and stderr... + if ( present(context) ) then + write(0,100) trim(nf90_call), trim(context), trim(nf90_strerror(ncstatus)) + print 100, trim(nf90_call), trim(context), trim(nf90_strerror(ncstatus)) + else + write(0,200) trim(nf90_call), trim(nf90_strerror(ncstatus)) + print 200, trim(nf90_call), trim(nf90_strerror(ncstatus)) + endif + + ! ...and abort the whole program. + call MPI_Abort(MPI_COMM_WORLD,1,ierr) + endif + + end subroutine netcdf_check + + !======================================================================= + !== Increment File Output Utilities ==================================== + !======================================================================= + + subroutine fv3_increment_def_start(grid,ncdat) + + ! Define arguments to this subroutine + + type(analysis_grid) :: grid !! analysis grid data + type(increment_netcdf) :: ncdat !! netcdf file ids + + print *,'writing to ',trim(increment_filename) + + ! Create the NetCDF file. + + call netcdf_check(nf90_create(trim(increment_filename), & + cmode=ior(NF90_CLOBBER,NF90_64BIT_OFFSET),ncid=ncdat%ncfileid), & + & 'nf90_create') + + ! Define the dimensions. + + ncdat%dimid_lon=fv3_netcdf_def_dim(ncdat,'lon',grid%nx) + ncdat%dimid_lat=fv3_netcdf_def_dim(ncdat,'lat',grid%ny) + ncdat%dimid_lev=fv3_netcdf_def_dim(ncdat,'lev',grid%nz) + ncdat%dimid_ilev=fv3_netcdf_def_dim(ncdat,'ilev',grid%nzp1) + + if (debug) print *,'dims',grid%nx,grid%ny,grid%nz,grid%nzp1 + + ! Define the variables that are NOT increments: + + call fv3_netcdf_def_var(ncdat,'lon',(/ncdat%dimid_lon/),'units','degrees_east') + call fv3_netcdf_def_var(ncdat,'lat',(/ncdat%dimid_lat/),'units','degrees_north') + call fv3_netcdf_def_var(ncdat,'lev',(/ncdat%dimid_lev/)) + call fv3_netcdf_def_var(ncdat,'pfull',(/ncdat%dimid_lev/)) + call fv3_netcdf_def_var(ncdat,'ilev',(/ncdat%dimid_ilev/)) + call fv3_netcdf_def_var(ncdat,'hyai',(/ncdat%dimid_ilev/)) + call fv3_netcdf_def_var(ncdat,'hybi',(/ncdat%dimid_ilev/)) + + end subroutine fv3_increment_def_start + + !======================================================================= + + subroutine fv3_increment_def_var(ncdat,var) + + type(increment_netcdf) :: ncdat !! netcdf file ids + character(len=*) :: var !! Name of the variable to define + + ! Locals + integer, dimension(3) :: dimid_3d + + dimid_3d = (/ ncdat%dimid_lon, ncdat%dimid_lat, ncdat%dimid_lev /) + + call fv3_netcdf_def_var(ncdat,var,dimid_3d) + end subroutine fv3_increment_def_var + + !======================================================================= + + subroutine fv3_increment_def_end(ncdat) + !Arguments to routine + type(increment_netcdf) :: ncdat + + ! Write the global variables: source of this data and comment: + + call netcdf_check(nf90_put_att(ncdat%ncfileid,nf90_global,'source','GSI'), & + & 'nf90_put_att', context='source') + + call netcdf_check(nf90_put_att(ncdat%ncfileid,nf90_global, & + 'comment','global analysis increment from calc_increment.x'), & + 'nf90_put_att', context='comment') + + ! Terminate the definition phase of the NetCDF output: + call netcdf_check(nf90_enddef(ncdat%ncfileid),'nf90_enddef') + end subroutine fv3_increment_def_end + + !======================================================================= + + subroutine fv3_increment_write_start(grid,ncdat) + !Arguments to routine + type(analysis_grid) :: grid + type(increment_netcdf) :: ncdat + + ! Write the variables that are NOT incremented: + call fv3_netcdf_write_var1d(ncdat,'lon',grid%lon) + call fv3_netcdf_write_var1d(ncdat,'lat',grid%lat) + call fv3_netcdf_write_var1d(ncdat,'lev',grid%lev) + call fv3_netcdf_write_var1d(ncdat,'ilev',grid%ilev) + call fv3_netcdf_write_var1d(ncdat,'lon',grid%lon) + call fv3_netcdf_write_var1d(ncdat,'pfull',grid%pfull) + call fv3_netcdf_write_var1d(ncdat,'hyai',grid%hyai) + call fv3_netcdf_write_var1d(ncdat,'hybi',grid%hybi) + end subroutine fv3_increment_write_start + + !======================================================================= + + subroutine fv3_increment_write_end(ncdat) + !Arguments to routine + type(increment_netcdf) :: ncdat + + ! Close the NetCDF file. This also flushes buffers. + call netcdf_check(nf90_close(ncdat%ncfileid),'nf90_close',& + context=trim(increment_filename)) + end subroutine fv3_increment_write_end + + !======================================================================= + !== Analysis / First Guess Read Utilities ============================== + !======================================================================= + + !! Read one variable that is NOT pressure + subroutine fv3_analysis_read_var(grid,varname) + ! Arguments to function + + type(analysis_grid) :: grid !! the analysis or first guess grid + character(len=*) :: varname !! name of the variable to read + + ! local variables + + type(varinfo) :: var_info ! to request a variable from gfs_nems_read + real(r_kind), allocatable :: workgrid(:) ! for reordering data + integer :: k ! Vertical index loop when reading data level-by-level + + + ! Read the nemsio file header + call gfs_nems_initialize(meta_nemsio,filename=grid%filename) + + ! Allocate our local work array + allocate(workgrid(grid%nx*grid%ny)) + + ! Read in the variable, level-by-level: + do k = 1, grid%nz + var_info%var_name=varname + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + var_info%nems_levtyp,k) + + grid%var3d(:,:,grid%nz-k+1)=0 + grid%var3d(:,:,grid%nz-k+1)=reshape(workgrid,(/grid%nx,grid%ny/)) + if (grid%flip_lats) then + call gfs_nems_flip_xlat_axis( & + meta_nemsio,grid%var3d(:,:,grid%nz - k + 1)) + endif + end do + + ! Close the nemsio file + call gfs_nems_finalize() + + deallocate(workgrid) + + end subroutine fv3_analysis_read_var + + !======================================================================= + + !! Read or calculate 3D pressure + subroutine fv3_analysis_read_or_calc_dpres(grid,mype) + ! Arguments to function + + type(analysis_grid) :: grid !! the analysis or first guess grid + integer,intent(in) :: mype + + ! local variables + + type(varinfo) :: var_info ! to request a variable from gfs_nems_read + real(r_kind), allocatable :: workgrid(:) ! for reordering data + real(r_kind), allocatable :: pressi(:,:,:) ! interface pressure, 3D + real(r_kind), allocatable :: vcoord(:,:,:) ! a & b for hydro. approx. + integer :: k ! Vertical index loop when reading data level-by-level + +100 format(A,': ',A) + + ! Read the nemsio file header + call gfs_nems_initialize(meta_nemsio,filename=grid%filename) + + allocate(vcoord(meta_nemsio%dimz + 1,3,2)) + allocate(workgrid(meta_nemsio%dimx*meta_nemsio%dimy)) + + ! Is the 3D pressure in the file? + grid%ldpres = gfs_nems_variable_exist(meta_nemsio,'dpres') + + if ( .not. grid%ldpres ) then + ! The 3D pressure is NOT in the file. We need to calculate + ! pressure from the hydrostatic approximation and surface + ! pressure. + + if (mype==0) print 100,'dpres','calculate from 2D psfc and hydro. approx.' + + ! Allocate an array for the interface pressure. + if(.not. allocated(pressi)) then + allocate(pressi(meta_nemsio%dimx,meta_nemsio%dimy, & + meta_nemsio%dimz + 1)) + endif + + ! Read the A, B, and surface pressure + call gfs_nems_vcoord(meta_nemsio,trim(grid%filename),vcoord) + grid%ak = vcoord(:,1,1) + grid%bk = vcoord(:,2,1) + var_info%var_name = 'psfc' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name,var_info%nems_levtyp, & + & 1) + grid%psfc(:,:) = reshape(workgrid,(/meta_nemsio%dimx, & + & meta_nemsio%dimy/)) + + ! Apply the hydrostatic approximation to get 3D interface pressure: + do k = 1, meta_nemsio%dimz + 1 + pressi(:,:,k) = grid%ak(k) + grid%bk(k)*grid%psfc(:,:) + end do ! do k = 1, meta_nemsio%dimz + 1 + else + if (mype==0) print 100,'dpres','read from file; do not calculate' + endif + + ! Calculate or read the mid-level 3D pressure: + do k = 1, meta_nemsio%dimz + if ( grid%ldpres ) then + ! Pressure is already in the file. Read the 3D pressure array. + var_info%var_name = 'dpres' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + var_info%nems_levtyp,k) + grid%var3d(:,:,meta_nemsio%dimz - k + 1) = & + reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) + else + ! Convert interface pressure to mass level pressure, using + ! the 3D array generated in the prior loop: + grid%var3d(:,:,meta_nemsio%dimz - k + 1) = & + pressi(:,:,k) - pressi(:,:,k+1) + endif + + ! Flip the pressure in the latitude direction if needed + if (grid%flip_lats) then + call gfs_nems_flip_xlat_axis( & + meta_nemsio, grid%var3d(:,:,meta_nemsio%dimz - k + 1) ) + endif + enddo + + + ! Deallocate memory for work arrays + + if(allocated(pressi)) then + deallocate(pressi) ! only allocated if hydro. pres. is used + endif + deallocate(vcoord) + deallocate(workgrid) + + end subroutine fv3_analysis_read_or_calc_dpres + + !======================================================================= + + !! Read everything that is NOT incremented, plus the pressure + subroutine fv3_analysis_read_non_inc_vars(grid) + + type(analysis_grid) :: grid !! analysis or first guess to read + + ! Local variables + + type(varinfo) :: var_info ! to request a variable from gfs_nems_read + integer :: k ! Vertical index loop when reading data level-by-level + + ! Read the nemsio file header + call gfs_nems_initialize(meta_nemsio,filename=grid%filename) + + ! Allocate memory for work arrays + grid%nx=meta_nemsio%dimx + grid%ny=meta_nemsio%dimy + grid%nz=meta_nemsio%dimz + + ! Determine ordering of latitudes: + if (debug) then + print *,'lats',meta_nemsio%lat(1), meta_nemsio%lat( & + meta_nemsio%dimx*meta_nemsio%dimy) + endif + if (meta_nemsio%lat(1) > meta_nemsio%lat(meta_nemsio%dimx*meta_nemsio%dimy)) then + grid%flip_lats = .true. + else + grid%flip_lats = .false. + endif + if (debug) print *,'flip_lats',grid%flip_lats + + ! Close this nemsio file. + call gfs_nems_finalize() + + end subroutine fv3_analysis_read_non_inc_vars + + !======================================================================= + !== Memory Management ================================================== + !======================================================================= + + subroutine fv3_grid_allocate(an_grid,fg_grid) + + type(analysis_grid) :: an_grid !! analysis grid + type(analysis_grid) :: fg_grid !! first guess grid + + ! Get the grid dimensions from the analysis file + + call gfs_nems_initialize(meta_nemsio,filename=analysis_filename) + an_grid%nx = meta_nemsio%dimx + an_grid%ny = meta_nemsio%dimy + an_grid%nz = meta_nemsio%dimz + an_grid%nzp1 = an_grid%nz + 1 + call gfs_nems_finalize() + + ! Assume the first guess has the same dimensions. + + fg_grid%nx = an_grid%nx + fg_grid%ny = an_grid%ny + fg_grid%nz = an_grid%nz + fg_grid%nzp1 = an_grid%nzp1 + + if(.not.an_grid%is_allocated) then + allocate(an_grid%lon(an_grid%nx)) + allocate(an_grid%lat(an_grid%ny)) + allocate(an_grid%lev(an_grid%nz)) + allocate(an_grid%ilev(an_grid%nzp1)) + allocate(an_grid%pfull(an_grid%nz)) + allocate(an_grid%hyai(an_grid%nzp1)) + allocate(an_grid%hybi(an_grid%nzp1)) + + allocate(an_grid%var3d(an_grid%nx,an_grid%ny,an_grid%nz)) + allocate(an_grid%psfc(an_grid%nx,an_grid%ny)) + allocate(an_grid%ak(an_grid%nz+1)) + allocate(an_grid%bk(an_grid%nz+1)) + allocate(an_grid%ck(an_grid%nz+1)) + an_grid%is_allocated=.true. + endif + + if(.not.fg_grid%is_allocated) then + allocate(fg_grid%var3d(fg_grid%nx,fg_grid%ny,fg_grid%nz)) + allocate(fg_grid%psfc(fg_grid%nx,fg_grid%ny)) + allocate(fg_grid%ak(fg_grid%nz+1)) + allocate(fg_grid%bk(fg_grid%nz+1)) + allocate(fg_grid%ck(fg_grid%nz+1)) + fg_grid%is_allocated=.true. + endif + + end subroutine fv3_grid_allocate + + !======================================================================= + + subroutine fv3_grid_deallocate(an_grid,fg_grid) + + type(analysis_grid) :: an_grid !! analysis grid + type(analysis_grid) :: fg_grid !! first guess grid + + if(an_grid%is_allocated) then + deallocate(an_grid%lon) + deallocate(an_grid%lat) + deallocate(an_grid%lev) + deallocate(an_grid%ilev) + deallocate(an_grid%pfull) + deallocate(an_grid%hyai) + deallocate(an_grid%hybi) + + deallocate(an_grid%var3d) + deallocate(an_grid%psfc) + deallocate(an_grid%ak) + deallocate(an_grid%bk) + deallocate(an_grid%ck) + an_grid%is_allocated=.false. + endif + + if(fg_grid%is_allocated) then + deallocate(fg_grid%var3d) + deallocate(fg_grid%psfc) + deallocate(fg_grid%ak) + deallocate(fg_grid%bk) + deallocate(fg_grid%ck) + an_grid%is_allocated=.false. + endif + + end subroutine fv3_grid_deallocate + + !======================================================================= + +end module fv3_interface diff --git a/util/AeroDA/calc_increment_ens.fd/gfs_nems_interface.f90 b/util/AeroDA/calc_increment_ens.fd/gfs_nems_interface.f90 new file mode 100644 index 000000000..988bbb926 --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/gfs_nems_interface.f90 @@ -0,0 +1,513 @@ +! Copyright (C) 2015 Henry R. Winterbottom + +! Email: Henry.Winterbottom@noaa.gov + +! Snail-mail: + +! Henry R. Winterbottom +! NOAA/OAR/PSD R/PSD1 +! 325 Broadway +! Boulder, CO 80303-3328 + +! This file is part of global-model-py. + +! global-model-py is free software: you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation, either version 3 of +! the License, or (at your option) any later version. + +! global-model-py is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU General Public License for more details. + +! You should have received a copy of the GNU General Public License +! along with global-model-py. If not, see +! . + +module gfs_nems_interface + + !======================================================================= + + ! Define associated modules and subroutines + + !----------------------------------------------------------------------- + + use constants + use kinds + + !----------------------------------------------------------------------- + + use namelist_def + use nemsio_module + + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + + ! Define all data and structure types for routine; these variables + ! are variables required by the subroutines within this module + + type gfs_grid + real(r_kind), dimension(:,:), allocatable :: rlon + real(r_kind), dimension(:,:), allocatable :: rlat + real(r_kind) :: rlon_min + real(r_kind) :: rlon_max + real(r_kind) :: rlat_min + real(r_kind) :: rlat_max + real(r_kind) :: dx + real(r_kind) :: dy + integer :: ntrunc + integer :: ncoords + integer :: nlons + integer :: nlats + integer :: nz + end type gfs_grid ! type gfs_grid + + type nemsio_meta + character(nemsio_charkind), dimension(:), allocatable :: recname + character(nemsio_charkind), dimension(:), allocatable :: reclevtyp + character(16), dimension(:), allocatable :: variname + character(16), dimension(:), allocatable :: varr8name + character(16), dimension(:), allocatable :: aryiname + character(16), dimension(:), allocatable :: aryr8name + character(nemsio_charkind8) :: gdatatype + character(nemsio_charkind8) :: modelname + real(nemsio_realkind), dimension(:,:,:), allocatable :: vcoord + real(nemsio_realkind), dimension(:), allocatable :: lon + real(nemsio_realkind), dimension(:), allocatable :: lat + real(nemsio_realkind) :: rlon_min + real(nemsio_realkind) :: rlon_max + real(nemsio_realkind) :: rlat_min + real(nemsio_realkind) :: rlat_max + integer(nemsio_intkind), dimension(:,:), allocatable :: aryival + integer(nemsio_intkind), dimension(:), allocatable :: reclev + integer(nemsio_intkind), dimension(:), allocatable :: varival + integer(nemsio_intkind), dimension(:), allocatable :: aryilen + integer(nemsio_intkind), dimension(:), allocatable :: aryr8len + integer(nemsio_intkind) :: idate(7) + integer(nemsio_intkind) :: version + integer(nemsio_intkind) :: nreo_vc + integer(nemsio_intkind) :: nrec + integer(nemsio_intkind) :: nmeta + integer(nemsio_intkind) :: nmetavari + integer(nemsio_intkind) :: nmetaaryi + integer(nemsio_intkind) :: nfhour + integer(nemsio_intkind) :: nfminute + integer(nemsio_intkind) :: nfsecondn + integer(nemsio_intkind) :: nfsecondd + integer(nemsio_intkind) :: dimx + integer(nemsio_intkind) :: dimy + integer(nemsio_intkind) :: dimz + integer(nemsio_intkind) :: nframe + integer(nemsio_intkind) :: nsoil + integer(nemsio_intkind) :: ntrac + integer(nemsio_intkind) :: jcap + integer(nemsio_intkind) :: ncldt + integer(nemsio_intkind) :: idvc + integer(nemsio_intkind) :: idsl + integer(nemsio_intkind) :: idvm + integer(nemsio_intkind) :: idrt + integer(nemsio_intkind) :: fhour + end type nemsio_meta ! type nemsio_meta + + !----------------------------------------------------------------------- + + ! Define global variables + + type(nemsio_gfile) :: gfile + integer :: nemsio_iret + + !----------------------------------------------------------------------- + + ! Define interfaces and attributes for module routines + + private + public :: gfs_grid_initialize + public :: gfs_grid_cleanup + public :: gfs_grid + public :: gfs_nems_initialize + public :: gfs_nems_finalize + public :: gfs_nems_read + public :: gfs_nems_write + public :: gfs_nems_vcoord + public :: gfs_nems_flip_xlat_axis + public :: gfs_nems_variable_exist + public :: nemsio_meta + + !----------------------------------------------------------------------- + +contains + + !======================================================================= + + ! gfs_nems_initialize.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_initialize(meta_nemsio,filename) + + ! Define variables passed to routine + + type(nemsio_meta) :: meta_nemsio + character(len=500), optional, intent(inout) :: filename + + !===================================================================== + + ! Define local variables + + call nemsio_init(iret=nemsio_iret) + if ( nemsio_iret /= 0 ) stop 1 + + ! Check local variable and proceed accordingly + + + ! Define local variables + + call nemsio_open(gfile,trim(adjustl(filename)),'read', & + & iret=nemsio_iret) + if ( nemsio_iret /= 0 ) then + write(0,*) 'cannot open for read: ',trim(adjustl(filename)) + stop 2 + end if + call nemsio_getfilehead(gfile,iret=nemsio_iret, & + & dimx=meta_nemsio%dimx, & + & dimy=meta_nemsio%dimy, & + & dimz=meta_nemsio%dimz, & + & nrec=meta_nemsio%nrec) + if ( nemsio_iret /= 0 ) stop 3 + if (.not. allocated(meta_nemsio%lon)) & + allocate(meta_nemsio%lon(meta_nemsio%dimx*meta_nemsio%dimy)) + if (.not. allocated(meta_nemsio%lat)) & + allocate(meta_nemsio%lat(meta_nemsio%dimx*meta_nemsio%dimy)) + call nemsio_getfilehead(gfile,iret=nemsio_iret, & + & lat=meta_nemsio%lat, & + & lon=meta_nemsio%lon, & + & idate=meta_nemsio%idate, & + & nframe=meta_nemsio%nframe, & + & idrt=meta_nemsio%idrt, & + & ncldt=meta_nemsio%ncldt, & + & idvc=meta_nemsio%idvc, & + & nfhour=meta_nemsio%fhour, & + & nfminute=meta_nemsio%nfminute, & + & nfsecondn=meta_nemsio%nfsecondn, & + & nfsecondd=meta_nemsio%nfsecondd) + if ( nemsio_iret /= 0 ) stop 4 + if (.not. allocated(meta_nemsio%recname)) & + allocate(meta_nemsio%recname(meta_nemsio%nrec)) + call nemsio_getfilehead(gfile,iret=nemsio_iret, & + & recname=meta_nemsio%recname) + if ( nemsio_iret /= 0 ) stop 5 + if (.not. allocated(meta_nemsio%reclev)) & + allocate(meta_nemsio%reclev(meta_nemsio%nrec)) + call nemsio_getfilehead(gfile,iret=nemsio_iret, & + & reclev=meta_nemsio%reclev) + if ( nemsio_iret /= 0 ) stop 6 + + ! Define format statements + +500 format(a,'nemsio_fhr',i3.3) + + !===================================================================== + + end subroutine gfs_nems_initialize + + !======================================================================= + + ! gfs_nems_finalize.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_finalize() + + !===================================================================== + + ! Define local variables + + call nemsio_close(gfile,iret=nemsio_iret) + + !===================================================================== + + end subroutine gfs_nems_finalize + + !======================================================================= + + ! gfs_nems_variable_exist.f90: + + !----------------------------------------------------------------------- + + function gfs_nems_variable_exist(meta_nemsio,varname) result(var_exist) + + ! Define variables passed to routine + + type(nemsio_meta) :: meta_nemsio + character(len=*) :: varname + logical :: var_exist + + !===================================================================== + + ! Define local variables + + integer :: n + + var_exist = .false. + do n=1,meta_nemsio%nrec + if ( trim(meta_nemsio%recname(n)) == trim(varname) ) then + var_exist = .true. + return + endif + enddo + + !===================================================================== + + end function gfs_nems_variable_exist + + !======================================================================= + + ! gfs_nems_vcoord.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_vcoord(meta_nemsio,filename,vcoord) + + ! Define variables passed to routine + + type(nemsio_gfile) :: lgfile + type(nemsio_meta) :: meta_nemsio + character(len=500) :: filename + real(r_kind), dimension(meta_nemsio%dimz+1,3,2) :: vcoord + + !===================================================================== + + ! Define local variables + + call nemsio_open(lgfile,trim(adjustl(filename)),'read', & + & iret=nemsio_iret) + call nemsio_getfilehead(lgfile,iret=nemsio_iret,vcoord=vcoord) + call nemsio_close(lgfile,iret=nemsio_iret) + + !===================================================================== + + end subroutine gfs_nems_vcoord + + !======================================================================= + + ! gfs_nems_flip_xlat_axis.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_flip_xlat_axis(meta_nemsio,grid) + ! flip latitudes from N to S to S to N + + ! Define variables passed to routine + + type(nemsio_meta) :: meta_nemsio + real(nemsio_realkind), dimension(meta_nemsio%dimx,meta_nemsio%dimy) :: grid + + ! Define variables computed within routine + + real(nemsio_realkind), dimension(meta_nemsio%dimx,meta_nemsio%dimy) :: workgrid + + ! Define counting variables + + integer :: i, j, k + + !===================================================================== + + ! Define local variables + + workgrid = grid + + ! Loop through local variable + + do j = 1, meta_nemsio%dimy + + ! Loop through local variable + + do i = 1, meta_nemsio%dimx + + ! Define local variables + + grid(i,meta_nemsio%dimy - j + 1) = workgrid(i,j) + + end do ! do i = 1, meta_nemsio%dimx + + end do ! do j = 1, meta_nemsio%dimy + + !===================================================================== + + end subroutine gfs_nems_flip_xlat_axis + + !======================================================================= + + ! gfs_nems_read.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_read(nems_data,nems_varname,nems_levtyp,nems_lev) + + ! Define variables passed to routine + + character(nemsio_charkind) :: nems_varname + character(nemsio_charkind) :: nems_levtyp + real(nemsio_realkind) :: nems_data(:) + integer(nemsio_intkind) :: nems_lev + + ! Define counting variables + + integer :: i, j, k + + !===================================================================== + + ! Define local variables + + call nemsio_readrecv(gfile,trim(adjustl(nems_varname)),levtyp= & + & trim(adjustl(nems_levtyp)),lev=nems_lev,data=nems_data, & + & iret=nemsio_iret) + + ! Check local variable and proceed accordingly + + if(debug) write(6,500) trim(adjustl(nems_varname)), nemsio_iret, & + & nems_lev, minval(nems_data), maxval(nems_data) + + !===================================================================== + + ! Define format statements + +500 format('GFS_NEMS_READ: NEMS I/O name = ', a, '; readrecv return ', & + & 'code = ', i5,'; level = ', i3, '; (min,max) = (', f13.5,f13.5, & + & ').') + + !===================================================================== + + end subroutine gfs_nems_read + + !======================================================================= + + ! gfs_nems_write.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_write(nems_data,nems_varname,nems_levtyp,nems_lev) + + ! Define variables passed to routine + + character(nemsio_charkind) :: nems_varname + character(nemsio_charkind) :: nems_levtyp + real(nemsio_realkind) :: nems_data(:) + integer(nemsio_intkind) :: nems_lev + + !===================================================================== + + ! Define local variables + + call nemsio_writerecv(gfile,trim(adjustl(nems_varname)),levtyp= & + & trim(adjustl(nems_levtyp)),lev=nems_lev,data=nems_data, & + & iret=nemsio_iret) + + ! Check local variable and proceed accordingly + + if(debug) write(6,500) trim(adjustl(nems_varname)), nemsio_iret, & + & nems_lev, minval(nems_data), maxval(nems_data) + + !===================================================================== + + ! Define format statements + +500 format('GFS_NEMS_WRITE: NEMS I/O name = ', a, '; writerecv return ', & + & 'code = ', i5,'; level = ', i3, '; (min,max) = (', f13.5,f13.5, & + & ').') + + !===================================================================== + + end subroutine gfs_nems_write + + !======================================================================= + + ! gfs_grid_initialize.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_grid_initialize(grid,meta_nemsio) + + ! Define variables passed to routine + + type(gfs_grid) :: grid + type(nemsio_meta) :: meta_nemsio + + ! Define variables computed within routine + + real(r_kind), dimension(:), allocatable :: slat + real(r_kind), dimension(:), allocatable :: wlat + real(r_kind), dimension(:), allocatable :: workgrid + + ! Define counting variables + + integer :: i, j, k, n + + !===================================================================== + + ! Define local variables + + call init_constants_derived() + + ! Allocate memory for local variables + + if(.not. allocated(grid%rlon)) & + & allocate(grid%rlon(grid%nlons,grid%nlats)) + if(.not. allocated(grid%rlat)) & + & allocate(grid%rlat(grid%nlons,grid%nlats)) + if(.not. allocated(workgrid)) & + & allocate(workgrid(grid%nlats)) + + ! Compute local variables + + grid%ncoords = grid%nlons*grid%nlats + + n = 0 + do j=1,grid%nlats + do i=1,grid%nlons + n = n + 1 + grid%rlon(i,j) = meta_nemsio%lon(n) + grid%rlat(i,j) = meta_nemsio%lat(n) + enddo + enddo + + ! Deallocate memory for local variables + + if(allocated(slat)) deallocate(slat) + if(allocated(wlat)) deallocate(wlat) + if(allocated(workgrid)) deallocate(workgrid) + + !===================================================================== + + end subroutine gfs_grid_initialize + + !======================================================================= + + ! gfs_grid_cleanup.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_grid_cleanup(grid) + + ! Define variables passed to routine + + type(gfs_grid) :: grid + + !===================================================================== + + ! Deallocate memory for local variables + + if(allocated(grid%rlon)) deallocate(grid%rlon) + if(allocated(grid%rlat)) deallocate(grid%rlat) + + !===================================================================== + + end subroutine gfs_grid_cleanup + + !======================================================================= + +end module gfs_nems_interface diff --git a/util/AeroDA/calc_increment_ens.fd/kinds.f90 b/util/AeroDA/calc_increment_ens.fd/kinds.f90 new file mode 100644 index 000000000..b3378bfcc --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/kinds.f90 @@ -0,0 +1,107 @@ +! this module was extracted from the GSI version operational +! at NCEP in Dec. 2007. +module kinds +!$$$ module documentation block +! . . . . +! module: kinds +! prgmmr: treadon org: np23 date: 2004-08-15 +! +! abstract: Module to hold specification kinds for variable declaration. +! This module is based on (copied from) Paul vanDelst's +! type_kinds module found in the community radiative transfer +! model +! +! module history log: +! 2004-08-15 treadon +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! The numerical data types defined in this module are: +! i_byte - specification kind for byte (1-byte) integer variable +! i_short - specification kind for short (2-byte) integer variable +! i_long - specification kind for long (4-byte) integer variable +! i_llong - specification kind for double long (8-byte) integer variable +! r_single - specification kind for single precision (4-byte) real variable +! r_double - specification kind for double precision (8-byte) real variable +! r_quad - specification kind for quad precision (16-byte) real variable +! +! i_kind - generic specification kind for default integer +! r_kind - generic specification kind for default floating point +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + implicit none + private + +! Integer type definitions below + +! Integer types + integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer + integer, parameter, public :: i_short = selected_int_kind(4) ! short integer + integer, parameter, public :: i_long = selected_int_kind(8) ! long integer + integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer + integer, parameter, public :: i_llong = max( llong_t, i_long ) + +! Expected 8-bit byte sizes of the integer kinds + integer, parameter, public :: num_bytes_for_i_byte = 1 + integer, parameter, public :: num_bytes_for_i_short = 2 + integer, parameter, public :: num_bytes_for_i_long = 4 + integer, parameter, public :: num_bytes_for_i_llong = 8 + +! Define arrays for default definition + integer, parameter, private :: num_i_kinds = 4 + integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & + i_byte, i_short, i_long, i_llong /) + integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & + num_bytes_for_i_byte, num_bytes_for_i_short, & + num_bytes_for_i_long, num_bytes_for_i_llong /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** + integer, parameter, private :: default_integer = 3 ! 1=byte, + ! 2=short, + ! 3=long, + ! 4=llong + integer, parameter, public :: i_kind = integer_types( default_integer ) + integer, parameter, public :: num_bytes_for_i_kind = & + integer_byte_sizes( default_integer ) + + +! Real definitions below + +! Real types + integer, parameter, public :: r_single = selected_real_kind(6) ! single precision + integer, parameter, public :: r_double = selected_real_kind(15) ! double precision + integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision + integer, parameter, public :: r_quad = max( quad_t, r_double ) + +! Expected 8-bit byte sizes of the real kinds + integer, parameter, public :: num_bytes_for_r_single = 4 + integer, parameter, public :: num_bytes_for_r_double = 8 + integer, parameter, public :: num_bytes_for_r_quad = 16 + +! Define arrays for default definition + integer, parameter, private :: num_r_kinds = 3 + integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & + r_single, r_double, r_quad /) + integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & + num_bytes_for_r_single, num_bytes_for_r_double, & + num_bytes_for_r_quad /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** + integer, parameter, private :: default_real = 1 ! 1=single, + ! 2=double, + ! 3=quad + integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: num_bytes_for_r_kind = & + real_byte_sizes( default_real ) + +end module kinds diff --git a/util/AeroDA/calc_increment_ens.fd/main.f90 b/util/AeroDA/calc_increment_ens.fd/main.f90 new file mode 100644 index 000000000..69a70ab56 --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/main.f90 @@ -0,0 +1,37 @@ +program calc_increment_main + + use namelist_def, only : read_namelist, write_namelist + use namelist_def, only : analysis_filename, firstguess_filename, increment_filename + use namelist_def, only : datapath + use namelist_def, only : debug + use namelist_def, only : max_vars, incvars_to_zero + use calc_increment_interface, only: calc_increment + + implicit none + + integer :: i + + call read_namelist + call write_namelist + + analysis_filename = trim(adjustl(datapath)) // trim(adjustl(analysis_filename)) + firstguess_filename = trim(adjustl(datapath)) // trim(adjustl(firstguess_filename)) + increment_filename = trim(adjustl(datapath)) // trim(adjustl(increment_filename)) + + write(6,*) 'DATAPATH = ', trim(datapath) + write(6,*) 'ANALYSIS FILE = ', trim(analysis_filename) + write(6,*) 'FIRSTGUESS FILE = ', trim(firstguess_filename) + write(6,*) 'INCREMENT FILE = ', trim(increment_filename) + write(6,*) 'DEBUG = ', debug + + do i=1,max_vars + if ( trim(incvars_to_zero(i)) /= 'NONE' ) then + write(6,*) 'INCVARS_TO_ZERO = ', trim(incvars_to_zero(i)) + else + cycle + endif + enddo + + call calc_increment(0) + +end program calc_increment_main diff --git a/util/AeroDA/calc_increment_ens.fd/namelist_def.f90 b/util/AeroDA/calc_increment_ens.fd/namelist_def.f90 new file mode 100644 index 000000000..c67dcbb68 --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/namelist_def.f90 @@ -0,0 +1,81 @@ +module namelist_def + + implicit none + + private + + public :: max_vars, nens + public :: analysis_filename, firstguess_filename, increment_filename + public :: datapath + public :: debug + public :: do_icmr + public :: incvars_to_zero + public :: read_namelist + public :: write_namelist + + ! Define global variables + + integer, parameter :: max_vars = 99 + character(len=500) :: datapath = './' + character(len=500) :: analysis_filename = 'atmanl.nemsio' + character(len=500) :: firstguess_filename = 'atmbkg.nemsio' + character(len=500) :: increment_filename = 'atminc.nc' + integer :: nens = 1 + logical :: debug = .false. + integer :: imp_physics = 99 + character(len=10) :: incvars_to_zero(max_vars) = 'NONE' + + logical :: do_icmr = .false. + + namelist /setup/ datapath, analysis_filename, firstguess_filename, increment_filename, & + nens, debug, imp_physics + namelist /zeroinc/ incvars_to_zero + +contains + +subroutine read_namelist + + implicit none + + integer, parameter :: lunit = 10 + logical :: lexist = .false. + + inquire(file='calc_increment.nml', exist=lexist) + if ( lexist ) then + + open(file='calc_increment.nml', unit=lunit, status='old', & + form='formatted', action='read', access='sequential') + read(lunit,nml=setup) + read(lunit,nml=zeroinc) + close(lunit) + + else + write(6,*) 'calc_increment.nml does not exist and should, ABORT!' + stop 99 + endif + + ! Based on MP, process additional hydrometeor species + select case (imp_physics) + case (99) ! Zhao Carr MP + do_icmr = .false. + case (11) ! GFDL MP + do_icmr = .true. + case default + do_icmr = .false. + end select + + return +end subroutine read_namelist + +subroutine write_namelist + + implicit none + + write(6,setup) + write(6,zeroinc) + + return + +end subroutine write_namelist + +end module namelist_def diff --git a/util/AeroDA/calc_increment_ens.fd/pmain.f90 b/util/AeroDA/calc_increment_ens.fd/pmain.f90 new file mode 100644 index 000000000..9ef78eeb3 --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/pmain.f90 @@ -0,0 +1,80 @@ +program calc_increment_pmain + + use mpi + use namelist_def, only : read_namelist, write_namelist + use namelist_def, only : analysis_filename, firstguess_filename, increment_filename + use namelist_def, only : datapath + use namelist_def, only : debug + use namelist_def, only : max_vars, incvars_to_zero + use namelist_def, only : nens + use calc_increment_interface, only: calc_increment + + implicit none + + character(len=3) :: memchar + integer :: mype, mype1, npes, ierr + integer :: i + + call mpi_init(ierr) + + call mpi_comm_rank(mpi_comm_world, mype, ierr) + call mpi_comm_size(mpi_comm_world, npes, ierr) + + if (mype==0) call w3tagb('CALC_INCREMENT_ENS',2018,0177,0055,'NP20') + + call read_namelist + if ( mype == 0 ) call write_namelist + + if ( npes < nens ) then + if ( mype == 0 ) then + write(6,*) 'npes, nens = ', npes, nens + write(6,*) 'npes must be atleast equal to nens, ABORT!' + endif + call mpi_abort(mpi_comm_world, 99, ierr) + endif + + mype1 = mype + 1 + write(memchar,'(I3.3)') mype1 + + analysis_filename = trim(adjustl(datapath)) // trim(adjustl(analysis_filename)) // '_mem' // trim(adjustl(memchar)) + firstguess_filename = trim(adjustl(datapath)) // trim(adjustl(firstguess_filename)) // '_mem' // trim(adjustl(memchar)) + increment_filename = trim(adjustl(datapath)) // trim(adjustl(increment_filename)) // '_mem' // trim(adjustl(memchar)) + + if ( mype == 0 ) then + write(6,*) 'DATAPATH = ', trim(datapath) + write(6,*) 'ANALYSIS FILE = ', trim(analysis_filename) + write(6,*) 'FIRSTGUESS FILE = ', trim(firstguess_filename) + write(6,*) 'INCREMENT FILE = ', trim(increment_filename) + write(6,*) 'DEBUG = ', debug + write(6,*) 'NENS = ', nens + do i=1,max_vars + if ( trim(incvars_to_zero(i)) /= 'NONE' ) then + write(6,*) 'INCVARS_TO_ZERO = ', trim(incvars_to_zero(i)) + else + cycle + endif + enddo + endif + + call mpi_barrier(mpi_comm_world, ierr) + + if ( mype < nens ) then + + write(6,*) 'task mype = ', mype, ' process ', trim(increment_filename) + + call calc_increment(mype) + + else + + write(6,*) 'no files to process for mpi task = ', mype + + endif + + call mpi_barrier(mpi_comm_world, ierr) + + if (mype==0) call w3tage('CALC_INCREMENT_ENS') + + call mpi_finalize(ierr) + + stop +end program calc_increment_pmain diff --git a/util/AeroDA/calc_increment_ens.fd/variable_interface.f90 b/util/AeroDA/calc_increment_ens.fd/variable_interface.f90 new file mode 100644 index 000000000..a42dad79e --- /dev/null +++ b/util/AeroDA/calc_increment_ens.fd/variable_interface.f90 @@ -0,0 +1,231 @@ +! Copyright (C) 2015 Henry R. Winterbottom + +! Email: Henry.Winterbottom@noaa.gov + +! Snail-mail: + +! Henry R. Winterbottom +! NOAA/OAR/PSD R/PSD1 +! 325 Broadway +! Boulder, CO 80303-3328 + +! This file is part of global-model-py. + +! global-model-py is free software: you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation, either version 3 of +! the License, or (at your option) any later version. + +! global-model-py is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU General Public License for more details. + +! You should have received a copy of the GNU General Public License +! along with global-model-py. If not, see +! . + +module variable_interface + + !======================================================================= + + ! Define associated modules and subroutines + + !----------------------------------------------------------------------- + + use constants + use kinds + + !----------------------------------------------------------------------- + + use namelist_def + + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + + ! Define all data and structure types for routine; these variables + ! are variables required by the subroutines within this module + + type varinfo + character(len=20) :: var_name + character(len=20) :: nems_name + character(len=20) :: nems_levtyp + integer :: ndims + end type varinfo + + !----------------------------------------------------------------------- + + ! Define interfaces and attributes for module routines + + private + public :: varinfo + public :: variable_lookup + public :: variable_clip + + !----------------------------------------------------------------------- + +contains + + !======================================================================= + + ! variable_clip.f90: + + !----------------------------------------------------------------------- + + subroutine variable_clip(grid) + + ! Define variables passed to routine + + real(r_double) :: grid(:) + + ! Define variables computed within routine + + real(r_double) :: clip + + !===================================================================== + + ! Define local variables + + clip = tiny(grid(1)) + where(grid .le. dble(0.0)) grid = clip + + !===================================================================== + + end subroutine variable_clip + + !======================================================================= + + ! variable_lookup.f90: + + !----------------------------------------------------------------------- + + subroutine variable_lookup(grid) + + ! Define variables passed to routine + + type(varinfo) :: grid + + !===================================================================== + + ! default options so we do not have to explicitly do this for all aerosols... + grid%nems_name = trim(adjustl(grid%var_name)) + grid%nems_levtyp = 'mid layer' + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'psfc') then + + ! Define local variables + + grid%nems_name = 'pres' + grid%nems_levtyp = 'sfc' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'psfc') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'dpres') then + + ! Define local variables + + grid%nems_name = 'dpres' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'dpres') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'delz') then + + ! Define local variables + + grid%nems_name = 'delz' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'delz') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'ugrd') then + + ! Define local variables + + grid%nems_name = 'ugrd' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'ugrd') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'vgrd') then + + ! Define local variables + + grid%nems_name = 'vgrd' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'vgrd') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'spfh') then + + ! Define local variables + + grid%nems_name = 'spfh' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'spfh') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'tmp') then + + ! Define local variables + + grid%nems_name = 'tmp' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'tmp') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'clwmr') then + + ! Define local variables + + grid%nems_name = 'clwmr' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'clwmr') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'o3mr') then + + ! Define local variables + + grid%nems_name = 'o3mr' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'o3mr') + + if(trim(adjustl(grid%var_name)) .eq. 'icmr') then + + ! Define local variables + + grid%nems_name = 'icmr' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'icmr') + + !===================================================================== + + end subroutine variable_lookup + + !======================================================================= + +end module variable_interface diff --git a/util/Analysis_Utilities/read_diag/CMakeLists.txt b/util/Analysis_Utilities/read_diag/CMakeLists.txt new file mode 100644 index 000000000..0b2c61d48 --- /dev/null +++ b/util/Analysis_Utilities/read_diag/CMakeLists.txt @@ -0,0 +1,13 @@ +cmake_minimum_required(VERSION 2.6) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_COM_Fortran_FLAGS} ) + + add_executable(read_diag_conv.x read_diag_conv.f90 ) + set_target_properties( read_diag_conv.x PROPERTIES COMPILE_FLAGS ${UTIL_COM_Fortran_FLAGS} ) + target_link_libraries( read_diag_conv.x ${GSISHAREDLIB} ${GSILIB} ${GSISHAREDLIB} ) + add_dependencies(read_diag_conv.x ${GSILIB} ) + + add_executable(read_diag_rad.x read_diag_rad.f90 ) + set_target_properties( read_diag_rad.x PROPERTIES COMPILE_FLAGS ${UTIL_COM_Fortran_FLAGS} ) + target_link_libraries( read_diag_rad.x ${GSISHAREDLIB} ${GSILIB} ${GSISHAREDLIB} ) + add_dependencies(read_diag_rad.x ${GSILIB} ) diff --git a/util/Analysis_Utilities/read_diag/namelist.conv b/util/Analysis_Utilities/read_diag/namelist.conv index ebbe8ad93..5df7d6849 100644 --- a/util/Analysis_Utilities/read_diag/namelist.conv +++ b/util/Analysis_Utilities/read_diag/namelist.conv @@ -1,5 +1,5 @@ &iosetup - infilename='./diag_conv_anl', - outfilename='./results_conv_anl', + infilename='./diag_conv_ges', + outfilename='./results_conv_ges', / diff --git a/util/Analysis_Utilities/read_diag/read_diag_conv.f90 b/util/Analysis_Utilities/read_diag/read_diag_conv.f90 index 00752d9fc..b7c13f9b2 100644 --- a/util/Analysis_Utilities/read_diag/read_diag_conv.f90 +++ b/util/Analysis_Utilities/read_diag/read_diag_conv.f90 @@ -72,11 +72,6 @@ PROGRAM read_diag_conv integer :: i,j,k,ios integer :: ic, iflg - integer,dimension(300):: imap_ps,imap_t,imap_q,imap_pw,imap_sst,imap_uv -! -! tiny_r_kind = tiny(0) -! - call convinfo_read(imap_ps,imap_t,imap_q,imap_pw,imap_sst,imap_uv) ! outfilename='diag_results' open(11,file='namelist.conv') @@ -183,84 +178,3 @@ PROGRAM read_diag_conv stop 1234 END PROGRAM read_diag_conv - -subroutine convinfo_read(imap_ps,imap_t,imap_q,imap_pw,imap_sst,imap_uv) -!$$$ subprogram documentation block -! . . . . -! subprogram: convinfo_read read conventional information file -! - character(len=1)cflg - character(len=16) cob - character(len=7) iotype - character(len=120) crecord - integer lunin,i,n,nc,ier,istat - integer nlines,maxlines - - character(len=16),allocatable, dimension(:)::ioctype - integer,allocatable,dimension(:):: icuse,ictype,icsubtype - integer,dimension(300):: imap_ps,imap_t,imap_q,imap_pw,imap_sst,imap_uv - - imap_ps=-10 - imap_t=-10 - imap_q=-10 - imap_pw=-10 - imap_sst=-10 - imap_uv=-10 - lunin = 47 - open(lunin,file='convinfo',form='formatted') - rewind(lunin) - nconvtype=0 - nlines=0 - read1: do - read(lunin,1030,err=333, end=300)cflg,iotype -1030 format(a1,a7,2x,a120) - nlines=nlines+1 - if(cflg == '!')cycle - nconvtype=nconvtype+1 - enddo read1 - -300 continue - - if(nconvtype == 0) then - write(6,*) 'CONVINFO_READ: NO CONVENTIONAL DATA USED' - return - endif - - allocate(icuse(nconvtype),ictype(nconvtype),icsubtype(nconvtype), & - ioctype(nconvtype)) - - rewind(lunin) - do i=1,nlines - read(lunin,1030)cflg,iotype,crecord - if(cflg == '!')cycle - nc=nc+1 - ioctype(nc)=iotype - !otype type isub iuse - !ps 120 0 1 - !ioctype(nc), - ! ictype(nc), - ! icsubtype(nc), - ! icuse(nc), - - read(crecord,*)ictype(nc),icsubtype(nc),icuse(nc) -! write(6,1031)ioctype(nc),ictype(nc),icsubtype(nc),icuse(nc) -1031 format('READ_CONVINFO: ',a7,1x,i3,1x,i4,1x,i2,1x,g12.6) - if(trim(ioctype(nc)) == 'ps') imap_ps(ictype(nc))=icuse(nc) - if(trim(ioctype(nc)) == 't') imap_t(ictype(nc))=icuse(nc) - if(trim(ioctype(nc)) == 'q') imap_q(ictype(nc))=icuse(nc) - if(trim(ioctype(nc)) == 'pw') imap_pw(ictype(nc))=icuse(nc) - if(trim(ioctype(nc)) == 'sst') imap_sst(ictype(nc))=icuse(nc) - if(trim(ioctype(nc)) == 'uv') imap_uv(ictype(nc))=icuse(nc) - - enddo - - close(lunin) -! DO i =1, 300 -! write(*,'(10I4)') i, imap_t(i),imap_q(i),imap_pw(i),imap_sst(i),imap_uv(i) -! enddo - - return -333 continue - write(*,*) ' error in read' - stop 1234 - end subroutine convinfo_read diff --git a/util/Baseline/check_build.pl b/util/Baseline/check_build.pl new file mode 100755 index 000000000..7737d7d65 --- /dev/null +++ b/util/Baseline/check_build.pl @@ -0,0 +1,21 @@ +#!/usr/bin/perl + + $baselineDir = "$ENV{'NS'}/GSI-Baseline"; + chdir ($baselineDir); + $hashcmd = 'git log --pretty=oneline | head -1 | awk \'{print $1}\''; + $lasthash = `$hashcmd`; + chop($lasthash); + $updatecmd = "git remote update; git pull origin cmake-refactor"; + system("$updatecmd"); + $newhash = `$hashcmd`; + chop($newhash); + + if($newhash ne $lasthash) { + # rebuild new master + $buildcmd = "./ush/build_all_cmake.sh 0 $baselineDir"; + system($buildcmd); + chdir ("$baselineDir/build"); +# system("module load lsf; REND=2 ctest -V -I 1,1"); + } + + diff --git a/util/Conventional_Monitor/CMon_install.pl b/util/Conventional_Monitor/CMon_install.pl deleted file mode 100755 index 43bc0fd4c..000000000 --- a/util/Conventional_Monitor/CMon_install.pl +++ /dev/null @@ -1,291 +0,0 @@ -#! /usr/bin/perl - -#------------------------------------------------------------------- -# CMon_install.pl -# -# This script makes sets all necessary configuration definitions -# and calls the makeall.sh script to build all the necessary -# executables. This script works for wcoss, theia, and cray -# machines. -#------------------------------------------------------------------- - - use IO::File; - use File::Copy qw(move); - - print "--> CMon_install.sh\n"; - my $machine = `/usr/bin/perl ./get_hostname.pl`; - my $my_machine="export MY_MACHINE=$machine"; - - if( $machine ne "theia" && $machine ne "wcoss" && $machine ne "cray" ) { - die( "ERROR --- Unrecognized machine hostname, $machine. Exiting now...\n" ); - } - else { - print "machine = $machine\n"; - } - - #--------------------------------------------------------------------------------- - # All 3 currently supported platforms are little endian machines and linux OSes. - # I'm keeping these switches though because that will surely change at some - # point and I'll just have to re-introduce the same switches. - # - my $little_endian = "export LITTLE_ENDIAN=1"; - - my $os = "linux"; - my $my_os = "export MY_OS=$os"; - - - # - # Idenfity basedir location of package - # - print "\n"; - print "locating and saving CMon package location\n"; - my $cmondir; - $cmondir = `dirname $0`; - $cmondir =~ s/^\s+|\s+$//g; - - if( $cmondir eq "." ) { - $cmondir = `pwd`; - $cmondir =~ s/^\s+|\s+$//g; - } - my $my_cmon = "export MY_CMON=$cmondir"; - print "my_cmon = $my_cmon \n"; - print"\n\n"; - - sleep( 1 ); - - # - # TANKDIR location - # - my $user_name = $ENV{ 'USER' }; - if( $machine eq "theia" ) { - $tankdir = "/scratch4/NCEPDEV/da/save/$user_name/nbns"; - } - elsif( $machine eq "wcoss" ) { - $tankdir = "/global/save/$user_name/nbns"; - } - elsif( $machine eq "cray" ) { - $tankdir = "/gpfs/hps/emc/da/noscrub/$user_name" - } - - print "Please specify TANKDIR location for storage of data and image files.\n"; - print " Return to accept default location or enter new location now.\n"; - print "\n"; - print " Default TANKDIR: $tankdir \n"; - print " ?\n"; - my $new_tankdir = <>; - $new_tankdir =~ s/^\s+|\s+$//g; - - if( length($new_tankdir ) > 0 ) { - $tankdir = $new_tankdir; - } - my $my_tankdir="export CMON_TANKDIR=$tankdir"; - print "my_tankdir = $my_tankdir\n"; - print "\n\n"; - sleep( 1 ); - - - # - # Web sever name - # - my $server = "emcrzdm"; - print "Please specify web server name.\n"; - print " Return to accept default server name or enter new server name.\n"; - print " \n"; - print " Default web server: $server\n"; - print " ?\n"; - my $new_server =<>; - $new_server =~ s/^\s+|\s+$//g; - if( length($new_server ) > 0 ) { - $server = $new_server; - } - my $my_server="export WEBSVR=$server"; - print "my_server = $my_server\n"; - print "\n\n"; - sleep( 1 ); - - - # - # Web server user name - # - my $webuser = $ENV{ 'USER' }; - print "Please specify your user name on the $server server.\n"; - print " Return to accept default user name or enter new user name.\n"; - print " \n"; - print " Default user name on $server: $webuser\n"; - print " ?\n"; - my $new_webuser =<>; - $new_webuser =~ s/^\s+|\s+$//g; - if( length($new_webuser ) > 0 ) { - $webuser = $new_webuser; - } - my $my_webuser="export WEBUSER=$webuser"; - print "my_webuser = $my_webuser\n"; - print "\n\n"; - sleep( 1 ); - - - # - # Web directory - # - my $webdir = "/home/people/emc/www/htdocs/gmb/gdas/radiance/${webuser}"; - my $webdir = "/home/people/emc/www/htdocs/gmb/gdas"; - print "Please specify the top level web site directory $server.\n"; - print " Return to accept default directory location or enter new location.\n"; - print " \n"; - print " Default directory on $server: $webdir\n"; - print " ?\n"; - my $new_webdir =<>; - $new_webdir =~ s/^\s+|\s+$//g; - if( length($new_webdir ) > 0 ) { - $webdir = $new_webdir; - } - my $my_webdir="export WEBDIR=$webdir"; - print "my_webdir = $my_webdir\n"; - print "\n\n"; - sleep( 1 ); - - - # - # Set up ptmp and stmp locations according to $arch. - # - my $ptmp = "/ptmpd1"; - my $stmp = "/stmpd1"; - my $my_ptmp = "export C_PTMP=\${C_PTMP:-$ptmp}"; - my $my_stmp = "export C_STMP=\${C_STMP:-$stmp}"; - - if( $machine eq "theia" ) { - $my_ptmp="export C_PTMP=\${C_PTMP:-/scratch4/NCEPDEV/stmp4}"; - $my_stmp="export C_STMP=\${C_STMP:-/scratch4/NCEPDEV/stmp3}"; - } - elsif( $machine eq "cray" ) { - $my_ptmp="export C_PTMP=\${C_PTMP:-/gpfs/hps/ptmp/$user_name}"; - $my_stmp="export C_STMP=\${C_STMP:-/gpfs/hps/stmp/$user_name}"; - } - else { - print "Please specify PTMP location. This is used for temporary work space.\n"; - print " Available options are: \n"; - print " /ptmpd1 (default)\n"; - print " /ptmpd2\n"; - print " /ptmpd3\n"; - print " /ptmpp1\n"; - print " /ptmpp2\n"; - - print " Return to accept default location or enter new location now.\n"; - print "\n"; - print " Default PTMP: $ptmp \n"; - print " ?\n"; - my $new_ptmp = <>; - $new_ptmp =~ s/^\s+|\s+$//g; - - if( length($new_ptmp ) > 0 ) { - $ptmp = $new_ptmp; - } - my $my_ptmp="export C_PTMP=\${C_PTMP:-$ptmp}"; - print "\n\n"; - sleep( 1 ); - - print "Please specify STMP location. This is used for temporary work space.\n"; - print " Available options are: \n"; - print " /stmpd1 (default)\n"; - print " /stmpd2\n"; - print " /stmpd3\n"; - print " /stmpp1\n"; - print " /stmpp2\n"; - - print " Return to accept default location or enter new location now.\n"; - print "\n"; - print " Default STMP: $stmp \n"; - print " ?\n"; - my $new_stmp = <>; - $new_stmp =~ s/^\s+|\s+$//g; - - if( length($new_stmp ) > 0 ) { - $stmp = $new_stmp; - } - my $my_stmp="export C_STMP=\${C_STMP:-$stmp}"; - print "my_stmp = $my_stmp\n"; - print "\n\n"; - sleep( 1 ); - } - - print "my_ptmp = $my_ptmp\n"; - print "my_stmp = $my_stmp\n"; - print "\n"; - - - my $account = "export ACCOUNT=\${ACCOUNT:-fv3-cpu}"; - if( $machine ne "theia" ) { - $account = "export ACCOUNT=\${ACCOUNT:-}"; - } - - # - # Update the conv_conf with the configuration information - # - my $conv_conf = "parm/CMon_config"; - open my $in, '<', $conv_conf or die "Can't read $conv_conf: $!"; - open my $out, '>', "$conv_conf.new" or die "Can't write $conv_conf.new: $!"; - - while( <$in> ) { - if( $_ =~ "MY_CMON=" ) { - print $out "$my_cmon\n"; - } - elsif( $_ =~ "ACCOUNT=" ) { - print $out "$account\n"; - } - elsif( $_ =~ "CMON_TANKDIR=" ) { - print $out "$my_tankdir\n"; - } - elsif( $_ =~ "WEBSVR=" ) { - print $out "$my_server\n"; - } - elsif( $_ =~ "WEBUSER=" ) { - print $out "$my_webuser\n"; - } - elsif( $_ =~ "WEBDIR=" ) { - print $out "$my_webdir\n"; - } - elsif( $_ =~ "LITTLE_ENDIAN=" ) { - print $out "$little_endian\n"; - } - elsif( $_ =~ "MY_OS=" ) { - print $out "$my_os\n"; - } - elsif( $_ =~ "MY_MACHINE=" ) { - print $out "$my_machine\n"; - } - elsif( $_ =~ "C_PTMP=" ) { - print $out "$my_ptmp\n"; - } - elsif( $_ =~ "C_STMP=" ) { - print $out "$my_stmp\n"; - } - else { - print $out $_; - } - } - close $out; - close $in; - move "$conv_conf.new", $conv_conf; - - print "building executables\n"; - `./makeall.sh clean`; - `./makeall.sh`; - - # - # Update the default account settings in the data_map.xml file. - # -# print "updating defaults in data_map.xml \n"; -# my $glbl_account = "GDAS-MTN"; -# if( $machine eq "zeus" ) { -# $glbl_account = "ada"; -# } -# elsif( $machine eq "wcoss" ) { -# $glbl_account = "dev"; -# } - -# `/usr/bin/perl ./scripts/update_data_map.pl ./parm/data_map.xml global_default account $glbl_account`; - - - print "<-- CMon_install.sh\n"; - -exit 0; diff --git a/util/Conventional_Monitor/ConMon_install.pl b/util/Conventional_Monitor/ConMon_install.pl new file mode 100755 index 000000000..ab5c88e2e --- /dev/null +++ b/util/Conventional_Monitor/ConMon_install.pl @@ -0,0 +1,292 @@ +#! /usr/bin/perl + +#------------------------------------------------------------------- +# ConMon_install.pl +# +# This script makes sets all necessary configuration definitions +# and calls the makeall.sh script to build all the necessary +# executables. This script works for wcoss, theia, and cray +# machines. +#------------------------------------------------------------------- + + use IO::File; + use File::Copy qw(move); + + print "--> ConMon_install.sh\n"; + my $machine = `/usr/bin/perl ./get_hostname.pl`; + my $my_machine="export MY_MACHINE=$machine"; + + if( $machine ne "theia" && $machine ne "wcoss" && $machine ne "cray" ) { + die( "ERROR --- Unrecognized machine hostname, $machine. Exiting now...\n" ); + } + else { + print "machine = $machine\n"; + } + + #--------------------------------------------------------------------------------- + # All 3 currently supported platforms are little endian machines and linux OSes. + # I'm keeping these switches though because that will surely change at some + # point and I'll just have to re-introduce the same switches. + # + my $little_endian = "export LITTLE_ENDIAN=1"; + + my $os = "linux"; + my $my_os = "export MY_OS=$os"; + + + # + # Idenfity basedir location of package + # + print "\n"; + print "locating and saving ConMon package location\n"; + my $cmondir; + $cmondir = `dirname $0`; + $cmondir =~ s/^\s+|\s+$//g; + + if( $cmondir eq "." ) { + $cmondir = `pwd`; + $cmondir =~ s/^\s+|\s+$//g; + } + my $my_cmon = "export MY_CMON=$cmondir"; + print "my_cmon = $my_cmon \n"; + print"\n\n"; + + sleep( 1 ); + + # + # TANKDIR location + # + my $user_name = $ENV{ 'USER' }; + if( $machine eq "theia" ) { + $tankdir = "/scratch4/NCEPDEV/da/save/$user_name/nbns"; + } + elsif( $machine eq "wcoss" ) { + $tankdir = "/global/save/$user_name/nbns"; + } + elsif( $machine eq "cray" ) { + $tankdir = "/gpfs/hps/emc/da/noscrub/$user_name" + } + + print "Please specify TANKDIR location for storage of data and image files.\n"; + print " Return to accept default location or enter new location now.\n"; + print "\n"; + print " Default TANKDIR: $tankdir \n"; + print " ?\n"; + my $new_tankdir = <>; + $new_tankdir =~ s/^\s+|\s+$//g; + + if( length($new_tankdir ) > 0 ) { + $tankdir = $new_tankdir; + } + my $my_tankdir="export CMON_TANKDIR=$tankdir"; + print "my_tankdir = $my_tankdir\n"; + print "\n\n"; + sleep( 1 ); + + + # + # Web sever name + # + my $server = "emcrzdm"; + print "Please specify web server name.\n"; + print " Return to accept default server name or enter new server name.\n"; + print " \n"; + print " Default web server: $server\n"; + print " ?\n"; + my $new_server =<>; + $new_server =~ s/^\s+|\s+$//g; + if( length($new_server ) > 0 ) { + $server = $new_server; + } + my $my_server="export WEBSVR=$server"; + print "my_server = $my_server\n"; + print "\n\n"; + sleep( 1 ); + + + # + # Web server user name + # + my $webuser = $ENV{ 'USER' }; + print "Please specify your user name on the $server server.\n"; + print " Return to accept default user name or enter new user name.\n"; + print " \n"; + print " Default user name on $server: $webuser\n"; + print " ?\n"; + my $new_webuser =<>; + $new_webuser =~ s/^\s+|\s+$//g; + if( length($new_webuser ) > 0 ) { + $webuser = $new_webuser; + } + my $my_webuser="export WEBUSER=$webuser"; + print "my_webuser = $my_webuser\n"; + print "\n\n"; + sleep( 1 ); + + + # + # Web directory + # + my $webdir = "/home/people/emc/www/htdocs/gmb/gdas/radiance/${webuser}"; + my $webdir = "/home/people/emc/www/htdocs/gmb/gdas"; + print "Please specify the top level web site directory $server.\n"; + print " Return to accept default directory location or enter new location.\n"; + print " \n"; + print " Default directory on $server: $webdir\n"; + print " ?\n"; + my $new_webdir =<>; + $new_webdir =~ s/^\s+|\s+$//g; + if( length($new_webdir ) > 0 ) { + $webdir = $new_webdir; + } + my $my_webdir="export WEBDIR=$webdir"; + print "my_webdir = $my_webdir\n"; + print "\n\n"; + sleep( 1 ); + + + # + # Set up ptmp and stmp locations according to $arch. + # + my $ptmp = "/ptmpd1"; + my $stmp = "/stmpd1"; + my $my_ptmp = "export C_PTMP=\${C_PTMP:-$ptmp}"; + my $my_stmp = "export C_STMP=\${C_STMP:-$stmp}"; + + if( $machine eq "theia" ) { + $my_ptmp="export C_PTMP=\${C_PTMP:-/scratch4/NCEPDEV/stmp4}"; + $my_stmp="export C_STMP=\${C_STMP:-/scratch4/NCEPDEV/stmp3}"; + } + elsif( $machine eq "cray" ) { + $my_ptmp="export C_PTMP=\${C_PTMP:-/gpfs/hps/ptmp/$user_name}"; + $my_stmp="export C_STMP=\${C_STMP:-/gpfs/hps/stmp/$user_name}"; + } + else { + print "Please specify PTMP location. This is used for temporary work space.\n"; + print " Available options are: \n"; + print " /ptmpd1 (default)\n"; + print " /ptmpd2\n"; + print " /ptmpd3\n"; + print " /ptmpp1\n"; + print " /ptmpp2\n"; + + print " Return to accept default location or enter new location now.\n"; + print "\n"; + print " Default PTMP: $ptmp \n"; + print " ?\n"; + my $new_ptmp = <>; + $new_ptmp =~ s/^\s+|\s+$//g; + + if( length($new_ptmp ) > 0 ) { + $ptmp = $new_ptmp; + } + $my_ptmp="export C_PTMP=\${C_PTMP:-$ptmp}"; + print "\n\n"; + sleep( 1 ); + + + print "Please specify STMP location. This is used for temporary work space.\n"; + print " Available options are: \n"; + print " /stmpd1 (default)\n"; + print " /stmpd2\n"; + print " /stmpd3\n"; + print " /stmpp1\n"; + print " /stmpp2\n"; + + print " Return to accept default location or enter new location now.\n"; + print "\n"; + print " Default STMP: $stmp \n"; + print " ?\n"; + my $new_stmp = <>; + $new_stmp =~ s/^\s+|\s+$//g; + + if( length($new_stmp ) > 0 ) { + $stmp = $new_stmp; + } + $my_stmp="export C_STMP=\${C_STMP:-$stmp}"; + print "my_stmp = $my_stmp\n"; + print "\n\n"; + sleep( 1 ); + } + + print "my_ptmp = $my_ptmp\n"; + print "my_stmp = $my_stmp\n"; + print "\n"; + + + my $account = "export ACCOUNT=\${ACCOUNT:-fv3-cpu}"; + if( $machine ne "theia" ) { + $account = "export ACCOUNT=\${ACCOUNT:-}"; + } + + # + # Update the conv_conf with the configuration information + # + my $conv_conf = "parm/ConMon_config"; + open my $in, '<', $conv_conf or die "Can't read $conv_conf: $!"; + open my $out, '>', "$conv_conf.new" or die "Can't write $conv_conf.new: $!"; + + while( <$in> ) { + if( $_ =~ "MY_CMON=" ) { + print $out "$my_cmon\n"; + } + elsif( $_ =~ "ACCOUNT=" ) { + print $out "$account\n"; + } + elsif( $_ =~ "CMON_TANKDIR=" ) { + print $out "$my_tankdir\n"; + } + elsif( $_ =~ "WEBSVR=" ) { + print $out "$my_server\n"; + } + elsif( $_ =~ "WEBUSER=" ) { + print $out "$my_webuser\n"; + } + elsif( $_ =~ "WEBDIR=" ) { + print $out "$my_webdir\n"; + } + elsif( $_ =~ "LITTLE_ENDIAN=" ) { + print $out "$little_endian\n"; + } + elsif( $_ =~ "MY_OS=" ) { + print $out "$my_os\n"; + } + elsif( $_ =~ "MY_MACHINE=" ) { + print $out "$my_machine\n"; + } + elsif( $_ =~ "C_PTMP=" ) { + print $out "$my_ptmp\n"; + } + elsif( $_ =~ "C_STMP=" ) { + print $out "$my_stmp\n"; + } + else { + print $out $_; + } + } + close $out; + close $in; + move "$conv_conf.new", $conv_conf; + + print "building executables\n"; + `./makeall.sh clean`; + `./makeall.sh`; + + # + # Update the default account settings in the data_map.xml file. + # +# print "updating defaults in data_map.xml \n"; +# my $glbl_account = "GDAS-MTN"; +# if( $machine eq "zeus" ) { +# $glbl_account = "ada"; +# } +# elsif( $machine eq "wcoss" ) { +# $glbl_account = "dev"; +# } + +# `/usr/bin/perl ./scripts/update_data_map.pl ./parm/data_map.xml global_default account $glbl_account`; + + + print "<-- ConMon_install.sh\n"; + +exit 0; diff --git a/util/Conventional_Monitor/data_extract/ush/CMon_DE.sh b/util/Conventional_Monitor/data_extract/ush/CMon_DE.sh deleted file mode 100755 index ede3cd341..000000000 --- a/util/Conventional_Monitor/data_extract/ush/CMon_DE.sh +++ /dev/null @@ -1,226 +0,0 @@ -#!/bin/sh - -#-------------------------------------------------------------------- -# -# CMon_DE.sh (FKA: CheckCmon.sh) -# -# This is the top level data extractionscript for the Conventional -# Data Monitor (Cmon) package. -# -# C_DATDIR and C_GDATDIR (source directories for the cnvstat files) -# point to the operational data (GDAS). They can be overriden -# either in your interactive shell or in a script in order to point -# to another source. -#-------------------------------------------------------------------- -set -ax - -#-------------------------------------------------------------------- -# usage -#-------------------------------------------------------------------- -function usage { - echo "Usage: CMon_DE.sh suffix [pdate]" - echo " Suffix is the indentifier for this data source." - echo " Pdate is the full YYYYMMDDHH cycle to run. This - param is optional" -} - -#-------------------------------------------------------------------- -# CMon_DE.sh begins here -#-------------------------------------------------------------------- - -nargs=$# -if [[ $nargs -lt 1 || $nargs -gt 2 ]]; then - usage - exit 1 -fi - -echo "Begin CMon_DE.sh" - -this_file=`basename $0` -this_dir=`dirname $0` - - -export CMON_SUFFIX=$1 - -#-------------------------------------------------------------------- -# RUN_ENVIR: can be either "dev" or "para". -#-------------------------------------------------------------------- -#export RUN_ENVIR=$2 -export RUN_ENVIR=${RUN_ENVIR:-"dev"} - -#-------------------------------------------------------------------- -# load modules -#-------------------------------------------------------------------- -. /usrx/local/Modules/3.2.9/init/ksh -module use /nwprod2/modulefiles -module load grib_util -module load prod_util -module load util_shared - -if [[ $nargs -ge 1 ]]; then - export PDATE=$2; - echo "PDATE set to $PDATE" -fi - -echo CMON_SUFFIX = $CMON_SUFFIX -echo RUN_ENVIR = $RUN_ENVIR - -top_parm=${this_dir}/../../parm - -cmon_version_file=${cmon_version:-${top_parm}/CMon.ver} -if [[ -s ${cmon_version_file} ]]; then - . ${cmon_version_file} - echo "able to source ${cmon_version_file}" -else - echo "Unable to source ${cmon_version_file} file" - exit 2 -fi - -cmon_config=${cmon_config:-${top_parm}/CMon_config} -if [[ -s ${cmon_config} ]]; then - . ${cmon_config} - echo "able to source ${cmon_config}" -else - echo "Unable to source ${cmon_config} file" - exit 3 -fi - - -#minmon_user_settings=${minmon_user_settings:-${top_parm}/MinMon_user_settings} -#if [[ -s ${minmon_user_settings} ]]; then -# . ${minmon_user_settings} -# echo "able to source ${minmon_user_settings}" -#else -# echo "Unable to source ${minmon_user_settings} file" -# exit 4 -#fi - - - -jobname=CMon_de_${CMON_SUFFIX} - -#-------------------------------------------------------------------- -# Create any missing directories - -echo "C_TANKDIR = ${C_TANKDIR}" -echo "C_LOGDIR = ${C_LOGDIR}" -echo "C_IMGNDIR = ${C_IMGNDIR}" -if [[ ! -d ${C_TANKDIR} ]]; then - mkdir -p ${C_TANKDIR} -fi -if [[ ! -d ${C_LOGDIR} ]]; then - mkdir -p ${C_LOGDIR} -fi -if [[ ! -d ${C_IMGNDIR} ]]; then - mkdir -p ${C_IMGNDIR} -fi - - -tmpdir=${WORKverf_cmon}/de_cmon_${CMON_SUFFIX} -rm -rf $tmpdir -mkdir -p $tmpdir -cd $tmpdir - -#-------------------------------------------------------------------- -# Check status of monitoring job. Is it already running? If so, exit -# this script and wait for job to finish. - -if [[ $MY_MACHINE = "wcoss" ]]; then - count=`bjobs -u ${LOGNAME} -p -r -J "${jobname}" | wc -l` - if [[ $count -ne 0 ]] ; then - echo "Previous cmon jobs are still running for ${CMON_SUFFIX}" - exit 5 - fi -fi - -#-------------------------------------------------------------------- -# Get date of cycle to process and/or previous cycle processed. -# -if [[ $PDATE = "" ]]; then - GDATE=`${C_DE_SCRIPTS}/find_cycle.pl 1 ${C_TANKDIR}` - PDATE=`$NDATE +06 $GDATE` -else - GDATE=`$NDATE -06 $PDATE` -fi - -echo GDATE = $GDATE - -PDY=`echo $PDATE|cut -c1-8` -export CYC=`echo $PDATE|cut -c9-10` - -export GCYC=`echo $GDATE|cut -c9-10` -export PDYm6h=`echo $GDATE|cut -c1-8` -echo PDYm6h = $PDYm6h - - -export CNVSTAT_LOCATION=${CNVSTAT_LOCATION:-/com2/gfs/prod} -export C_DATDIR=${C_DATDIR:-${CNVSTAT_LOCATION}/gdas.$PDY} -export C_GDATDIR=${C_GDATDIR:-${CNVSTAT_LOCATION}/gdas.$PDYm6h} - -export C_COMIN=${C_DATDIR} -export C_COMINm6h=${C_GDATDIR} - -export DATA_IN=${WORKverf_cmon} -export CMON_WORK_DIR=${CMON_WORK_DIR:-${C_STMP_USER}/cmon_${CMON_SUFFIX}} -pid=$$ -export jobid=cmon_DE_${CMON_SUFFIX}.${pid} - -#-------------------------------------------------------------------- -# If data is available, export variables, and submit driver for -# plot jobs. -# -# Modification here is for prhw14 and prhs13 parallels which only -# generate grib2 files for the analysis and forecast files. The -# operational GDAS creates grib and grib2 files. The Cmon package -# was originally designed to use grib files, but it's clear that -# grib2 will be the only standard with the next major release of -# GSI. - -export grib2=${grib2:-0} -export cnvstat="${C_DATDIR}/gdas1.t${CYC}z.cnvstat" -if [[ ! -s ${cnvstat} ]]; then - export cnvstat=${C_DATDIR}/cnvstat.gdas.${PDATE} -fi - -export pgrbf00="${C_DATDIR}/gdas1.t${CYC}z.pgrbf00" -if [[ ! -s ${pgrbf00} ]]; then - export pgrbf00=${C_DATDIR}/pgbanl.gdas.${PDATE} -fi - -export pgrbf06="${C_GDATDIR}/gdas1.t${GCYC}z.pgrbf06" -if [[ ! -s ${pgrbf06} ]]; then - export pgrbf06=${C_DATDIR}/pgbf06.gdas.${GDATE} -fi - -exit_value=0 -if [ -s $cnvstat -a -s $pgrbf00 -a -s $pgrbf06 ]; then - #------------------------------------------------------------------ - # Submit data extraction job. - #------------------------------------------------------------------ - if [ -s $pgrbf06 ]; then - - if [[ $MY_MACHINE = "wcoss" ]]; then - $SUB -q $JOB_QUEUE -P $PROJECT -o $C_LOGDIR/DE.${PDY}.${CYC}.log -M 100 -R affinity[core] -W 0:25 -J ${jobname} -cwd $PWD ${HOMEgdascmon}/jobs/JGDAS_VCMON - - elif [[ $MY_MACHINE = "theia" ]]; then - $SUB -A $ACCOUNT -l procs=1,walltime=0:15:00 -N ${jobname} -V -o $C_LOGDIR/DE.${PDY}.${CYC}.log -e $C_LOGDIR/DE.${PDY}.${CYC}.err $HOMEgdascmon/jobs/JGDAS_VCMON - fi - - else - echo data not available, missing $pgrbf06 file - exit_value=6 - fi -else - echo data not available -- missing $cnvstat and/or $pgrbf00 files - exit_value=7 -fi - - -#-------------------------------------------------------------------- -# Clean up and exit -#cd $tmpdir -#cd ../ -#rm -rf $tmpdir - -echo "End CMon_DE.sh" -exit ${exit_value} diff --git a/util/Conventional_Monitor/data_extract/ush/ConMon_DE.sh b/util/Conventional_Monitor/data_extract/ush/ConMon_DE.sh new file mode 100755 index 000000000..d386e0ccd --- /dev/null +++ b/util/Conventional_Monitor/data_extract/ush/ConMon_DE.sh @@ -0,0 +1,218 @@ +#!/bin/sh + +#-------------------------------------------------------------------- +# +# ConMon_DE.sh +# +# This is the top level data extractionscript for the Conventional +# Data Monitor (ConMon) package. +# +# C_DATDIR and C_GDATDIR (source directories for the cnvstat files) +# point to the operational data (GDAS). They can be overriden +# either in your interactive shell or in a script in order to point +# to another source. +#-------------------------------------------------------------------- + +#-------------------------------------------------------------------- +# usage +#-------------------------------------------------------------------- +function usage { + echo "Usage: ConMon_DE.sh suffix [pdate]" + echo " Suffix is the indentifier for this data source." + echo " Pdate is the full YYYYMMDDHH cycle to run. This + param is optional" +} + +#-------------------------------------------------------------------- +# CMon_DE.sh begins here +#-------------------------------------------------------------------- + +nargs=$# +if [[ $nargs -lt 1 || $nargs -gt 2 ]]; then + usage + exit 1 +fi + +set -ax +echo "Begin ConMon_DE.sh" + +this_file=`basename $0` +this_dir=`dirname $0` + + +export CMON_SUFFIX=$1 + +#-------------------------------------------------------------------- +# RUN_ENVIR: can be either "dev" or "para". +#-------------------------------------------------------------------- +#export RUN_ENVIR=$2 +export RUN_ENVIR=${RUN_ENVIR:-"dev"} + +#-------------------------------------------------------------------- +# load modules +#-------------------------------------------------------------------- +#. /usrx/local/Modules/3.2.9/init/ksh +#module use /nwprod2/modulefiles +#module load grib_util +#module load prod_util +#module load util_shared + + +if [[ $nargs -ge 1 ]]; then + export PDATE=$2; + echo "PDATE set to $PDATE" +fi + +echo CMON_SUFFIX = $CMON_SUFFIX +echo RUN_ENVIR = $RUN_ENVIR + +top_parm=${this_dir}/../../parm + +cmon_version_file=${cmon_version:-${top_parm}/ConMon.ver} +if [[ -s ${cmon_version_file} ]]; then + . ${cmon_version_file} + echo "able to source ${cmon_version_file}" +else + echo "Unable to source ${cmon_version_file} file" + exit 2 +fi + +cmon_config=${cmon_config:-${top_parm}/ConMon_config} +if [[ -s ${cmon_config} ]]; then + . ${cmon_config} + echo "able to source ${cmon_config}" +else + echo "Unable to source ${cmon_config} file" + exit 3 +fi + + +jobname=ConMon_de_${CMON_SUFFIX} + +#-------------------------------------------------------------------- +# Create any missing directories + +echo "C_TANKDIR = ${C_TANKDIR}" +echo "C_LOGDIR = ${C_LOGDIR}" +echo "C_IMGNDIR = ${C_IMGNDIR}" +if [[ ! -d ${C_TANKDIR} ]]; then + mkdir -p ${C_TANKDIR} +fi +if [[ ! -d ${C_LOGDIR} ]]; then + mkdir -p ${C_LOGDIR} +fi +if [[ ! -d ${C_IMGNDIR} ]]; then + mkdir -p ${C_IMGNDIR} +fi + + +tmpdir=${WORKverf_cmon}/de_cmon_${CMON_SUFFIX} +rm -rf $tmpdir +mkdir -p $tmpdir +cd $tmpdir + +#-------------------------------------------------------------------- +# Check status of monitoring job. Is it already running? If so, exit +# this script and wait for job to finish. + +if [[ $MY_MACHINE = "wcoss" ]]; then + count=`bjobs -u ${LOGNAME} -p -r -J "${jobname}" | wc -l` + if [[ $count -ne 0 ]] ; then + echo "Previous cmon jobs are still running for ${CMON_SUFFIX}" + exit 5 + fi +fi + +#-------------------------------------------------------------------- +# Get date of cycle to process and/or previous cycle processed. +# +if [[ $PDATE = "" ]]; then + GDATE=`${C_DE_SCRIPTS}/find_cycle.pl 1 ${C_TANKDIR}` + PDATE=`$NDATE +06 $GDATE` +else + GDATE=`$NDATE -06 $PDATE` +fi + +echo GDATE = $GDATE + +PDY=`echo $PDATE|cut -c1-8` +export CYC=`echo $PDATE|cut -c9-10` + +export GCYC=`echo $GDATE|cut -c9-10` +export PDYm6h=`echo $GDATE|cut -c1-8` +echo PDYm6h = $PDYm6h + + +export CNVSTAT_LOCATION=${CNVSTAT_LOCATION:-/gpfs/hps/nco/ops/com/gfs/prod} +export C_DATDIR=${C_DATDIR:-${CNVSTAT_LOCATION}/gdas.$PDY} +export C_GDATDIR=${C_GDATDIR:-${CNVSTAT_LOCATION}/gdas.$PDYm6h} + +export C_COMIN=${C_DATDIR} +export C_COMINm6h=${C_GDATDIR} + +export DATA_IN=${WORKverf_cmon} +export CMON_WORK_DIR=${CMON_WORK_DIR:-${C_STMP_USER}/cmon_${CMON_SUFFIX}} +pid=$$ +export jobid=cmon_DE_${CMON_SUFFIX}.${pid} + +#-------------------------------------------------------------------- +# If data is available, export variables, and submit driver for +# plot jobs. +# +# Modification here is for prhw14 and prhs13 parallels which only +# generate grib2 files for the analysis and forecast files. The +# operational GDAS creates grib and grib2 files. The Cmon package +# was originally designed to use grib files, but it's clear that +# grib2 will be the only standard with the next major release of +# GSI. + +export grib2=${grib2:-0} +export cnvstat="${C_DATDIR}/gdas.t${CYC}z.cnvstat" +if [[ ! -s ${cnvstat} ]]; then + export cnvstat=${C_DATDIR}/cnvstat.gdas.${PDATE} +fi + +export pgrbf00="${C_DATDIR}/gdas.t${CYC}z.pgrbf00" +if [[ ! -s ${pgrbf00} ]]; then + export pgrbf00=${C_DATDIR}/pgbanl.gdas.${PDATE} +fi + +export pgrbf06="${C_GDATDIR}/gdas.t${GCYC}z.pgrbf06" +if [[ ! -s ${pgrbf06} ]]; then + export pgrbf06=${C_DATDIR}/pgbf06.gdas.${GDATE} +fi + +exit_value=0 +if [ -s $cnvstat -a -s $pgrbf00 -a -s $pgrbf06 ]; then + #------------------------------------------------------------------ + # Submit data extraction job. + #------------------------------------------------------------------ + if [ -s $pgrbf06 ]; then + + if [[ $MY_MACHINE = "wcoss" ]]; then + $SUB -q $JOB_QUEUE -P $PROJECT -o $C_LOGDIR/DE.${PDY}.${CYC}.log -M 500 -R affinity[core] -W 0:25 -J ${jobname} -cwd $PWD ${HOMEgdascmon}/jobs/JGDAS_VCMON + + elif [[ $MY_MACHINE = "theia" ]]; then + $SUB -A $ACCOUNT --ntasks=1 --time=00:20:00 \ + -p service -J ${jobname} -o $C_LOGDIR/DE.${PDY}.${CYC}.log \ + $HOMEgdascmon/jobs/JGDAS_VCMON + fi + + else + echo data not available, missing $pgrbf06 file + exit_value=6 + fi +else + echo data not available -- missing $cnvstat and/or $pgrbf00 files + exit_value=7 +fi + + +#-------------------------------------------------------------------- +# Clean up and exit +#cd $tmpdir +#cd ../ +#rm -rf $tmpdir + +echo "End ConMon_DE.sh" +exit ${exit_value} diff --git a/util/Conventional_Monitor/data_extract/ush/RunCMonDE.sh b/util/Conventional_Monitor/data_extract/ush/Run_ConMon_DE.sh similarity index 100% rename from util/Conventional_Monitor/data_extract/ush/RunCMonDE.sh rename to util/Conventional_Monitor/data_extract/ush/Run_ConMon_DE.sh diff --git a/util/Conventional_Monitor/data_extract/ush/find_cycle.pl b/util/Conventional_Monitor/data_extract/ush/find_cycle.pl index ba7d4d3da..b8f2c23de 100755 --- a/util/Conventional_Monitor/data_extract/ush/find_cycle.pl +++ b/util/Conventional_Monitor/data_extract/ush/find_cycle.pl @@ -99,22 +99,25 @@ my @times; my $idx = 0; - # Find the first string of 10 digits; that's the date. Use that $idx - # number to process all files. + # Find the first string of 10 digits; that's the date. Use that + # $idx nubmer to process all files. # - my @vals = split( '\.', $timefiles[0] ); - for ( my $ii=$#vals; $ii >= 0; $ii-- ) { - if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ - $idx = $ii; - } - } +# my @vals = split( '\.', $timefiles[0] ); +# for ( my $ii=$#vals; $ii >= 0; $ii-- ) { +# if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ +# $idx = $ii; +# } +# } for ( my $ii=$#sorttime; $ii >= 0; $ii-- ) { - my $teststr = $sorttime[$ii]; - my @values = split( '\.', $teststr ); - if( $values[$idx] ne "ctl" ){ - push( @times, $values[$idx] ); + my @vals = split( '\.', $sorttime[$ii] ); + for( my $jj=$#vals; $jj>=0; $jj-- ) { + if( looks_like_number( $vals[$jj] ) && length($vals[$jj] ) == 10) { + +# push( @times, $values[$idx] ); + push( @times, $vals[$jj] ); + } } } diff --git a/util/Conventional_Monitor/image_gen/exec/.gitignore b/util/Conventional_Monitor/image_gen/exec/.gitignore new file mode 100644 index 000000000..d6b7ef32c --- /dev/null +++ b/util/Conventional_Monitor/image_gen/exec/.gitignore @@ -0,0 +1,2 @@ +* +!.gitignore diff --git a/util/Conventional_Monitor/image_gen/gscripts/plot_uvsatwind_horz.gs b/util/Conventional_Monitor/image_gen/gscripts/plot_uvsatwind_horz.gs index 4441f796b..655876788 100644 --- a/util/Conventional_Monitor/image_gen/gscripts/plot_uvsatwind_horz.gs +++ b/util/Conventional_Monitor/image_gen/gscripts/plot_uvsatwind_horz.gs @@ -71,10 +71,10 @@ function uvsatwind (args) endwhile endif - if(plotfile = uv245 | plotfile = uv246 ) + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ) he=1 while(he <=13) - if(plotfile = uv245) + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ) plot_horz(plotfile,plotfile2,xsize,ysize,he,rdate,925,1,hint,u) plot_horz(plotfile,plotfile2,xsize,ysize,he,rdate,850,2,hint,u) plot_horz(plotfile,plotfile2,xsize,ysize,he,rdate,700,3,hint,u) @@ -83,7 +83,7 @@ function uvsatwind (args) plot_horz(plotfile,plotfile2,xsize,ysize,he,rdate,700,3,hint,v) endif - if(plotfile = uv245 | plotfile = uv246) + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ) plot_horz(plotfile,plotfile2,xsize,ysize,he,rdate,500,4,hint,u) plot_horz(plotfile,plotfile2,xsize,ysize,he,rdate,300,5,hint,u) plot_horz(plotfile,plotfile2,xsize,ysize,he,rdate,250,6,hint,u) @@ -270,59 +270,59 @@ function setmap(plotfile,he) if(he=2) if(plotfile = uv242 | plotfile = uv252 ); 'set lat 0 60';'set lon 100 210';endif if(plotfile = uv243); 'set lat 0 60';'set lon 0 120';endif - if(plotfile = uv245 | plotfile = uv246); 'set lat 0 30';'set lon 180 240';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat 0 30';'set lon 180 240';endif if(plotfile = uv253); 'set lat 0 60';'set lon 0 120';endif if(plotfile = uv257 | plotfile = uv258); 'set lat 60 90';'set lon 0 60';endif endif if(he=3) if(plotfile = uv242 | plotfile = uv252 ); 'set lat -60 0';'set lon 90 200';endif if(plotfile = uv243); 'set lat -60 0';'set lon 0 120';endif - if(plotfile = uv245 | plotfile = uv246); 'set lat 30 60';'set lon 180 240 ';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat 30 60';'set lon 180 240 ';endif if(plotfile = uv253); 'set lat -60 0';'set lon 0 120';endif if(plotfile = uv257 | plotfile = uv258); 'set lat 60 90';'set lon 60 120';endif endif if(he=4) if(plotfile = uv243); 'set lat 0 35';'set lon 300 360';endif - if(plotfile = uv245 | plotfile = uv246); 'set lat 0 30';'set lon 240 300';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat 0 30';'set lon 240 300';endif if(plotfile = uv253); 'set lat 0 60';'set lon 260 360';endif if(plotfile = uv257 | plotfile = uv258); 'set lat 60 90';'set lon 120 180';endif endif if(he=5) if(plotfile = uv243); 'set lat -35 0';'set lon 300 360';endif - if(plotfile = uv245 | plotfile = uv246); 'set lat 30 60';'set lon 240 300';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat 30 60';'set lon 240 300';endif if(plotfile = uv253); 'set lat -60 0';'set lon 260 360';endif if(plotfile = uv257 | plotfile = uv258); 'set lat 60 90';'set lon 180 240';endif endif if(he=6) - if(plotfile = uv245 | plotfile = uv246); 'set lat 0 30';'set lon 300 360';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat 0 30';'set lon 300 360';endif if(plotfile = uv257 | plotfile = uv258); 'set lat 60 90';'set lon 240 300';endif endif if(he=7) - if(plotfile = uv245 | plotfile = uv246); 'set lat 30 60';'set lon 300 360';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat 30 60';'set lon 300 360';endif if(plotfile = uv257 | plotfile = uv258); 'set lat 60 90';'set lon 300 360';endif endif if(he=8) - if(plotfile = uv245 | plotfile = uv246); 'set lat -30 0';'set lon 180 240';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat -30 0';'set lon 180 240';endif if(plotfile = uv257 | plotfile = uv258); 'set lat -90 -60';'set lon 0 60';endif endif if(he=9) - if(plotfile = uv245 | plotfile = uv246); 'set lat -60 -30';'set lon 180 240';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat -60 -30';'set lon 180 240';endif if(plotfile = uv257 | plotfile = uv258); 'set lat -90 -60';'set lon 60 120';endif endif if(he=10) - if(plotfile = uv245 | plotfile = uv246); 'set lat -30 0';'set lon 240 300';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat -30 0';'set lon 240 300';endif if(plotfile = uv257 | plotfile = uv258); 'set lat -90 -60';'set lon 120 180';endif endif if(he=11) - if(plotfile = uv245 | plotfile = uv246); 'set lat -60 -30';'set lon 240 300';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat -60 -30';'set lon 240 300';endif if(plotfile = uv257 | plotfile = uv258); 'set lat -90 -60';'set lon 180 240';endif endif if(he=12) - if(plotfile = uv245 | plotfile = uv246); 'set lat -30 0';'set lon 300 360';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat -30 0';'set lon 300 360';endif if(plotfile = uv257 | plotfile = uv258); 'set lat -90 -60';'set lon 240 300';endif endif if(he=13) - if(plotfile = uv245 | plotfile = uv246); 'set lat -60 -30';'set lon 300 360';endif + if(plotfile = uv245 | plotfile = uv246 | plotfile = uv247 ); 'set lat -60 -30';'set lon 300 360';endif if(plotfile = uv257 | plotfile = uv258); 'set lat -90 -60';'set lon 300 360';endif endif diff --git a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias.gs b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias.gs index 971fc8203..b80358e89 100644 --- a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias.gs +++ b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias.gs @@ -139,6 +139,10 @@ function plottime(ix,iy,iz,dtype,hh,dd,area,stype,subtype,iuse,dtype,levz,debug) title.3="o-g(monitored)" title.4="rms(monitored)" + 'set t 1' + 'query time' + fdmy=sublin(result,1) + fti=subwrd(fdmy,5) nf=1 while(nf <=nfield) @@ -150,6 +154,9 @@ function plottime(ix,iy,iz,dtype,hh,dd,area,stype,subtype,iuse,dtype,levz,debug) say ' ystring='ystring 'set t 1 last' 'query time' + dmy=sublin(result,1) + ti=subwrd(dmy,5) + 'set y 'iy 'set x 'ix 'set z 'iz @@ -213,7 +220,7 @@ function plottime(ix,iy,iz,dtype,hh,dd,area,stype,subtype,iuse,dtype,levz,debug) 'draw string 3.5 0.55 final outloop' * 'set line 3 1' * 'draw line 5.1 0.6 5.4 0.6' -* 'draw string 5.5 0.55 second outloop' + 'draw string 5.5 0.55 'fti'-'ti nf=nf+1 endwhile diff --git a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias2.gs b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias2.gs index 6bb72824f..a949cd2fd 100644 --- a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias2.gs +++ b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias2.gs @@ -136,6 +136,11 @@ function plottime(ix,iy,iz,dtype,hh,dd,area,stype,subtype,iuse,levz,debug) title.3="o-g for monitored" title.4="rms for monitored" + 'set t 1' + 'query time' + fdmy=sublin(result,1) + fti=subwrd(fdmy,5) + nf=1 while(nf <=nfield) y1=10.6-(nf-1)*2.5 @@ -146,6 +151,9 @@ function plottime(ix,iy,iz,dtype,hh,dd,area,stype,subtype,iuse,levz,debug) say ' ystring='ystring 'set t 1 last' 'query time' + dmy=sublin(result,1) + ti=subwrd(dmy,5) + 'set y 'iy 'set x 'ix 'set z 'iz @@ -212,7 +220,7 @@ function plottime(ix,iy,iz,dtype,hh,dd,area,stype,subtype,iuse,levz,debug) 'draw string 3.5 0.55 final outloop' 'set line 3 1' * 'draw line 5.1 0.6 5.4 0.6' -* 'draw string 5.5 0.55 second outloop' + 'draw string 5.5 0.55 'fti'-'ti nf=nf+1 endwhile diff --git a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias2_ps.gs b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias2_ps.gs index 5aaa938ff..c79677f20 100644 --- a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias2_ps.gs +++ b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias2_ps.gs @@ -92,6 +92,11 @@ function plottime(ix,iy,stype,hh,dd,area,stype,subtype,iuse,debug) title.3="o-g for monitored" title.4="rms for monitored" + 'set t 1' + 'query time' + fdmy=sublin(result,1) + fti=subwrd(fdmy,5) + nf=1 while(nf <=nfield) y1=10.6-(nf-1)*2.5 @@ -134,6 +139,9 @@ function plottime(ix,iy,stype,hh,dd,area,stype,subtype,iuse,debug) 'set parea 1.0 8.0 'y2' 'y1 'set gxout line' 'set t 1 last' + dmy=sublin(result,1) + ti=subwrd(dmy,5) + 'set datawarn off' 'set tlsupp year' 'set grads off' @@ -161,6 +169,8 @@ function plottime(ix,iy,stype,hh,dd,area,stype,subtype,iuse,debug) 'set line 2 1' 'draw line 3.1 0.6 3.4 0.6' 'draw string 3.5 0.55 final outloop' + 'draw string 5.5 0.55 'fti'-'ti + nf=nf+1 endwhile diff --git a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias_ps.gs b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias_ps.gs index 3ee44bfe3..cd778b419 100644 --- a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias_ps.gs +++ b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias_ps.gs @@ -103,6 +103,11 @@ function plottime(ix,iy,stype,hh,dd,area,stype,subtype,iuse,debug) title.3="o-g(monitored)" title.4="rms(monitored)" + 'set t 1' + 'query time' + fdmy=sublin(result,1) + fti=subwrd(fdmy,5) + nf=1 while(nf <=nfield) y1=10.6-(nf-1)*2.5 @@ -113,6 +118,9 @@ function plottime(ix,iy,stype,hh,dd,area,stype,subtype,iuse,debug) say ' ystring='ystring 'set t 1 last' 'query time' + dmy=sublin(result,1) + ti=subwrd(dmy,5) + 'set y 'iy 'set x 'ix 'set z 1' @@ -179,7 +187,7 @@ function plottime(ix,iy,stype,hh,dd,area,stype,subtype,iuse,debug) * 'set line 3 1' * 'draw line 5.1 0.6 5.4 0.6' -* 'draw string 5.5 0.55 second outloop' + 'draw string 5.5 0.55 'fti'-'ti nf=nf+1 endwhile diff --git a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias_pw.gs b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias_pw.gs index 52595894c..60ecef620 100644 --- a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias_pw.gs +++ b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_bias_pw.gs @@ -96,6 +96,11 @@ title.2="rms(used)" title.3="o-g(monitored)" title.4="rms(monitored)" +'set t 1' +'query time' +fdmy=sublin(result,1) +fti=subwrd(fdmy,5) + nf=1 while(nf <=nfield) y1=10.6-(nf-1)*2.5 @@ -135,6 +140,9 @@ say ' ystring='ystring 'set parea 1.0 8.0 'y2' 'y1 'set gxout line' 'set t 1 last' +dmy=sublin(result,1) +ti=subwrd(dmy,5) + 'set datawarn off' 'set tlsupp year' 'set grads off' @@ -170,7 +178,8 @@ say ' ystring='ystring 'draw string 3.5 0.55 final outloop' *'set line 3 1' *'draw line 5.1 0.6 5.4 0.6' -*'draw string 5.5 0.55 second outloop' +'draw string 5.5 0.55 'fti'-'ti + nf=nf+1 endwhile diff --git a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_count.gs b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_count.gs index 641dfbb5f..a5c3ca88e 100644 --- a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_count.gs +++ b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_count.gs @@ -19,7 +19,7 @@ function time_cnt_ps (args) say ti hh=substr(ti,1,2) dd=substr(ti,4,2) - + 'q file' size=sublin(result,5) ixc=subwrd(size,3) @@ -151,8 +151,17 @@ ystring=y1+0.1 say ' y1='y1 say ' y2='y2 say ' ystring='ystring + +'set t 1' +'query time' +fdmy=sublin(result,1) +fti=subwrd(fdmy,5) + 'set t 1 last' 'query time' +dmy=sublin(result,1) +ti=subwrd(dmy,5) + 'set y 'iy 'set x 'ix 'set z 'iz @@ -217,7 +226,7 @@ say ' ystring='ystring 'draw string 3.5 0.55 final outloop' *'set line 3 1' *'draw line 5.1 0.6 5.4 0.6' -*'draw string 5.5 0.55 second outloop' +'draw string 5.5 0.55 'fti'-'ti nf=nf+1 endwhile diff --git a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_count_ps.gs b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_count_ps.gs index 65e1b3185..692da6682 100644 --- a/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_count_ps.gs +++ b/util/Conventional_Monitor/image_gen/gscripts/plotstas_time_count_ps.gs @@ -112,6 +112,11 @@ function plottime(ix,iy,stype,hh,dd,area,stype,subtype,iuse,debug) title.3="no. rej. by GC" title.4="no. monitored" + 'set t 1' + 'query time' + fdmy=sublin(result,1) + fti=subwrd(fdmy,5) + nf=1 while(nf <=nfield) y1=10.6-(nf-1)*2.5 @@ -122,6 +127,9 @@ function plottime(ix,iy,stype,hh,dd,area,stype,subtype,iuse,debug) say ' ystring='ystring 'set t 1 last' 'query time' + dmy=sublin(result,1) + ti=subwrd(dmy,5) + 'set y 'iy 'set x 'ix 'set z 1' @@ -194,7 +202,7 @@ function plottime(ix,iy,stype,hh,dd,area,stype,subtype,iuse,debug) 'draw string 3.5 0.55 final outloop' * 'set line 3 1' * 'draw line 5.1 0.6 5.4 0.6' -* 'draw string 5.5 0.55 second outloop' + 'draw string 5.5 0.55 'fti'-'ti nf=nf+1 endwhile diff --git a/util/Conventional_Monitor/image_gen/sorc/read_uv/mainread_uv.f90 b/util/Conventional_Monitor/image_gen/sorc/read_uv/mainread_uv.f90 index a8bcbbced..f938defcd 100644 --- a/util/Conventional_Monitor/image_gen/sorc/read_uv/mainread_uv.f90 +++ b/util/Conventional_Monitor/image_gen/sorc/read_uv/mainread_uv.f90 @@ -23,7 +23,7 @@ namelist /input/nreal,mtype,fname,fileo,rlev,insubtype read (5,input) -! write(6,input) + write(6,input) ncount=0 rpress=rmiss diff --git a/util/Conventional_Monitor/image_gen/ush/CMon_IG.sh b/util/Conventional_Monitor/image_gen/ush/CMon_IG.sh deleted file mode 100755 index 836ede2fd..000000000 --- a/util/Conventional_Monitor/image_gen/ush/CMon_IG.sh +++ /dev/null @@ -1,191 +0,0 @@ -#!/bin/sh - -#-------------------------------------------------------------------- -# -# CMon_IG.sh -# -# This is the top level image generation script for the Conventional -# Data Monitor (Cmon) package. -# -#-------------------------------------------------------------------- - -#-------------------------------------------------------------------- -# usage -#-------------------------------------------------------------------- -function usage { - echo " " - echo "Usage: CMon_IG.sh suffix [plot_date]" - echo " Suffix is data source identifier that matches data in " - echo " the $C_TANKDIR/stats directory." - echo " Plot_date, format YYYYMMDDHH is optional. If included the plot" - echo " will be for the specified cycle, provided data files are available." - echo " If not included, the plot cycle will be for the latest cycle found" - echo " for this suffix." -} - - -#-------------------------------------------------------------------- -# CMon_IG.sh begins here -#-------------------------------------------------------------------- - -echo "Begin CMon_IG.sh" - -nargs=$# -if [[ $nargs -lt 1 || $nargs -gt 2 ]]; then - usage - exit 1 -fi - - -set -ax - -this_file=`basename $0` -this_dir=`dirname $0` - -export CMON_SUFFIX=$1 -echo "CMON_SUFFIX = $CMON_SUFFIX" - -export NUM_CYCLES=${NUM_CYCLES:-121} # number of cycles in plot -export JOBNAME=${JOBNAME:-CMon_plt_${CMON_SUFFIX}} -export grib2=${grib2:-0} # 1 = grib2 (true), 0 = grib - -export GRADS=/apps/grads/2.0.1a/bin/grads -#-------------------------------------------------------------------- -# Set plot_time if it's included as an argument -#-------------------------------------------------------------------- -plot_time= -if [[ $nargs -eq 2 ]]; then - export plot_time=$2; - echo "use plot_time = $plot_time" -fi - - -#-------------------------------------------------------------------- -# Run config files to load environment variables, -# set default plot conditions -#-------------------------------------------------------------------- -top_parm=${this_dir}/../../parm - -cmon_version_file=${cmon_version:-${top_parm}/CMon.ver} -if [[ -s ${cmon_version_file} ]]; then - . ${cmon_version_file} - echo "able to source ${cmon_version_file}" -else - echo "Unable to source ${cmon_version_file} file" - exit 2 -fi - -cmon_config=${cmon_config:-${top_parm}/CMon_config} -if [[ -s ${cmon_config} ]]; then - . ${cmon_config} - echo "able to source ${cmon_config}" -else - echo "Unable to source ${cmon_config} file" - exit 3 -fi - -#-------------------------------------------------------------------- -# Check for my monitoring use. Abort if running on prod machine. -#-------------------------------------------------------------------- - -if [[ RUN_ONLY_ON_DEV -eq 1 ]]; then - is_prod=`${C_IG_SCRIPTS}/onprod.sh` - if [[ $is_prod = 1 ]]; then - exit 10 - fi -fi - -jobname=CMon_ig_${CMON_SUFFIX} - - -#-------------------------------------------------------------------- -# Create LOGdir as needed -#-------------------------------------------------------------------- -if [[ ! -d ${C_LOGDIR} ]]; then - mkdir -p $C_LOGDIR -fi - - -#-------------------------------------------------------------------- -# Get date of cycle to process. Exit if available data has already -# been plotted ($PDATE -gt $PRODATE). -# -# If plot_time has been specified via command line argument, then -# set PDATE to it. Otherwise, determine the last cycle processed -# (into *.ieee_d files) and use that as the PDATE. -#-------------------------------------------------------------------- -export PRODATE=`${C_IG_SCRIPTS}/find_cycle.pl 1 ${C_TANKDIR}` - -if [[ $plot_time != "" ]]; then - export PDATE=$plot_time -else - export PDATE=$PRODATE -fi - -echo "PRODATE, PDATE = $PRODATE, $PDATE" - - -#-------------------------------------------------------------------- -# Check for running plot jobs and abort if found -#-------------------------------------------------------------------- - -if [[ $MY_MACHINE = "wcoss" ]]; then - running=`bjobs -l | grep ${jobname} | wc -l` -else - running=`showq -n -u ${LOGNAME} | grep ${jobname} | wc -l` -fi - -echo "running = $running" -if [[ $running -ne 0 ]]; then - echo "Plot jobs still running for $CMON_SUFFIX, must exit" - exit 9 -fi - - -#-------------------------------------------------------------------- -# Create workdir and cd to it -#-------------------------------------------------------------------- - -export C_PLOT_WORKDIR=${C_PLOT_WORKDIR:-${C_STMP_USER}/plot_cmon_${CMON_SUFFIX}} -rm -rf $C_PLOT_WORKDIR -mkdir -p $C_PLOT_WORKDIR -cd $C_PLOT_WORKDIR - - -#-------------------------------------------------------------------- -# Set the START_DATE for the plot -#-------------------------------------------------------------------- - -hrs=`expr $NUM_CYCLES \\* -6` -echo "hrs = $hrs" - -export START_DATE=`$NDATE ${hrs} $PDATE` -echo "start_date, prodate, pdate = $START_DATE $PRODATE $PDATE" - - - -#------------------------------------------------------------------ -# Start image plotting jobs. -#------------------------------------------------------------------ - -${C_IG_SCRIPTS}/mk_horz_hist.sh - -${C_IG_SCRIPTS}/mk_time_vert.sh - - -#------------------------------------------------------------------ -# Run the make_archive.sh script if $DO_ARCHIVE is switched on. -#------------------------------------------------------------------ -#if [[ $DO_ARCHIVE = 1 ]]; then -# ${IG_SCRIPTS}/make_archive.sh -#fi - - -#-------------------------------------------------------------------- -# Clean up and exit -#cd $tmpdir -#cd ../ -#rm -rf $tmpdir - -echo "End CMon_IG.sh" -exit diff --git a/util/Conventional_Monitor/image_gen/ush/ConMon_IG.sh b/util/Conventional_Monitor/image_gen/ush/ConMon_IG.sh new file mode 100755 index 000000000..198341f23 --- /dev/null +++ b/util/Conventional_Monitor/image_gen/ush/ConMon_IG.sh @@ -0,0 +1,193 @@ +#!/bin/sh + +#-------------------------------------------------------------------- +# +# ConMon_IG.sh +# +# This is the top level image generation script for the Conventional +# Data Monitor (ConMon) package. +# +#-------------------------------------------------------------------- + +#-------------------------------------------------------------------- +# usage +#-------------------------------------------------------------------- +function usage { + echo " " + echo "Usage: ConMon_IG.sh suffix [plot_date]" + echo " Suffix is data source identifier that matches data in " + echo " the $C_TANKDIR/stats directory." + echo " Plot_date, format YYYYMMDDHH is optional. If included the plot" + echo " will be for the specified cycle, provided data files are available." + echo " If not included, the plot cycle will be for the latest cycle found" + echo " for this suffix." +} + + +#-------------------------------------------------------------------- +# CMon_IG.sh begins here +#-------------------------------------------------------------------- + +echo "Begin ConMon_IG.sh" + +nargs=$# +if [[ $nargs -lt 1 || $nargs -gt 2 ]]; then + usage + exit 1 +fi + + +set -ax + +this_file=`basename $0` +this_dir=`dirname $0` + +export CMON_SUFFIX=$1 +echo "CMON_SUFFIX = $CMON_SUFFIX" + +export NUM_CYCLES=${NUM_CYCLES:-121} # number of cycles in plot +export JOBNAME=${JOBNAME:-CMon_plt_${CMON_SUFFIX}} +export grib2=${grib2:-0} # 1 = grib2 (true), 0 = grib + +export GRADS=/apps/grads/2.0.1a/bin/grads +#-------------------------------------------------------------------- +# Set plot_time if it's included as an argument +#-------------------------------------------------------------------- +plot_time= +if [[ $nargs -eq 2 ]]; then + export plot_time=$2; + echo "use plot_time = $plot_time" +fi + + +#-------------------------------------------------------------------- +# Run config files to load environment variables, +# set default plot conditions +#-------------------------------------------------------------------- +top_parm=${this_dir}/../../parm + +cmon_version_file=${cmon_version:-${top_parm}/ConMon.ver} +if [[ -s ${cmon_version_file} ]]; then + . ${cmon_version_file} + echo "able to source ${cmon_version_file}" +else + echo "Unable to source ${cmon_version_file} file" + exit 2 +fi + +cmon_config=${cmon_config:-${top_parm}/ConMon_config} +if [[ -s ${cmon_config} ]]; then + . ${cmon_config} + echo "able to source ${cmon_config}" +else + echo "Unable to source ${cmon_config} file" + exit 3 +fi + +#-------------------------------------------------------------------- +# Check for my monitoring use. Abort if running on prod machine. +#-------------------------------------------------------------------- + +if [[ RUN_ONLY_ON_DEV -eq 1 ]]; then + is_prod=`${C_IG_SCRIPTS}/onprod.sh` + if [[ $is_prod = 1 ]]; then + exit 10 + fi +fi + +jobname=CMon_ig_${CMON_SUFFIX} + + +#-------------------------------------------------------------------- +# Create LOGdir as needed +#-------------------------------------------------------------------- +if [[ ! -d ${C_LOGDIR} ]]; then + mkdir -p $C_LOGDIR +fi + + +#-------------------------------------------------------------------- +# Get date of cycle to process. Exit if available data has already +# been plotted ($PDATE -gt $PRODATE). +# +# If plot_time has been specified via command line argument, then +# set PDATE to it. Otherwise, determine the last cycle processed +# (into *.ieee_d files) and use that as the PDATE. +#-------------------------------------------------------------------- +export PRODATE=`${C_IG_SCRIPTS}/find_cycle.pl 1 ${C_TANKDIR}` + +if [[ $plot_time != "" ]]; then + export PDATE=$plot_time +else + export PDATE=$PRODATE +fi + +echo "PRODATE, PDATE = $PRODATE, $PDATE" + + +#-------------------------------------------------------------------- +# Check for running plot jobs and abort if found +#-------------------------------------------------------------------- + +if [[ $MY_MACHINE = "wcoss" ]]; then + running=`bjobs -l | grep ${jobname} | wc -l` +else + running=`showq -n -u ${LOGNAME} | grep ${jobname} | wc -l` +fi + +echo "running = $running" +if [[ $running -ne 0 ]]; then + echo "Plot jobs still running for $CMON_SUFFIX, must exit" + exit 9 +fi + + +#-------------------------------------------------------------------- +# Create workdir and cd to it +#-------------------------------------------------------------------- + +export C_PLOT_WORKDIR=${C_PLOT_WORKDIR:-${C_STMP_USER}/plot_cmon_${CMON_SUFFIX}} +rm -rf $C_PLOT_WORKDIR +mkdir -p $C_PLOT_WORKDIR +cd $C_PLOT_WORKDIR + + +#-------------------------------------------------------------------- +# Set the START_DATE for the plot +#-------------------------------------------------------------------- +ncycles=`expr $NUM_CYCLES - 1` + +#hrs=`expr $NUM_CYCLES \\* -6` +hrs=`expr $ncycles \\* -6` +echo "hrs = $hrs" + +export START_DATE=`$NDATE ${hrs} $PDATE` +echo "start_date, prodate, pdate = $START_DATE $PRODATE $PDATE" + + + +#------------------------------------------------------------------ +# Start image plotting jobs. +#------------------------------------------------------------------ + +${C_IG_SCRIPTS}/mk_horz_hist.sh + +${C_IG_SCRIPTS}/mk_time_vert.sh + + +#------------------------------------------------------------------ +# Run the make_archive.sh script if $DO_ARCHIVE is switched on. +#------------------------------------------------------------------ +#if [[ $DO_ARCHIVE = 1 ]]; then +# ${IG_SCRIPTS}/make_archive.sh +#fi + + +#-------------------------------------------------------------------- +# Clean up and exit +#cd $tmpdir +#cd ../ +#rm -rf $tmpdir + +echo "End ConMon_IG.sh" +exit diff --git a/util/Conventional_Monitor/image_gen/ush/Transfer.sh b/util/Conventional_Monitor/image_gen/ush/Transfer.sh index b6c59e29c..5c18ed850 100755 --- a/util/Conventional_Monitor/image_gen/ush/Transfer.sh +++ b/util/Conventional_Monitor/image_gen/ush/Transfer.sh @@ -20,8 +20,8 @@ this_file=`basename $0` this_dir=`dirname $0` top_parm=${this_dir}/../../parm -export CMON_CONFIG=${CMON_CONFIG:-${top_parm}/CMon_config} -export CMON_USER_SETTINGS=${CMON_USER_SETTINGS:-${top_parm}/CMon_user_settings} +export CMON_CONFIG=${CMON_CONFIG:-${top_parm}/ConMon_config} +export CMON_USER_SETTINGS=${CMON_USER_SETTINGS:-${top_parm}/ConMon_user_settings} if [[ -s ${CMON_CONFIG} ]]; then . ${CMON_CONFIG} diff --git a/util/Conventional_Monitor/image_gen/ush/mk_horz_hist.sh b/util/Conventional_Monitor/image_gen/ush/mk_horz_hist.sh index a919ac506..3f91818fd 100755 --- a/util/Conventional_Monitor/image_gen/ush/mk_horz_hist.sh +++ b/util/Conventional_Monitor/image_gen/ush/mk_horz_hist.sh @@ -30,7 +30,7 @@ set -ax export t_TYPE=" t120_00 t130_00 t131_00 t132_00 t133_00 t134_00 t135_00 t180_00 t181_00 t182_00 t183_00 t187_00 " - export uv_TYPE=" uv220_00 uv221_00 uv223_00 uv224_00 uv228_00 uv229_00 uv230_00 uv231_00 uv232_00 uv233_00 uv234_00 uv235_00 uv242_00 uv243_00 uv243_55 uv243_56 uv245_00 uv245_15 uv246_00 uv246_15 uv247_00 uv248_00 uv249_00 uv250_00 uv251_00 uv252_00 uv253_00 uv253_55 uv253_56 uv254_00 uv254_55 uv254_56 uv255_00 uv256_00 uv257_00 uv258_00 uv280_00 uv281_00 uv282_00 uv284_00 uv287_00" + export uv_TYPE=" uv220_00 uv221_00 uv223_00 uv224_00 uv228_00 uv229_00 uv230_00 uv231_00 uv232_00 uv233_00 uv234_00 uv235_00 uv242_00 uv243_00 uv243_55 uv243_56 uv245_257 uv245_259 uv245_270 uv246_257 uv246_257 uv246_270 uv247_257 uv247_259 uv247_270 uv248_00 uv249_00 uv250_00 uv251_00 uv252_00 uv253_00 uv253_55 uv253_56 uv254_00 uv254_55 uv254_56 uv255_00 uv256_00 uv257_00 uv258_00 uv280_00 uv281_00 uv282_00 uv284_00 uv287_00" export nreal_ps=${nreal_ps:-17} @@ -54,7 +54,8 @@ if [[ $MY_MACHINE = "wcoss" ]]; then $SUB -q $JOB_QUEUE -P $PROJECT -o ${logfile} -M 100 -R affinity[core] -W 0:20 -J ${jobname} -cwd ${PWD} ${plot_hist} elif [[ $MY_MACHINE = "theia" ]]; then - ${SUB} -A ${ACCOUNT} -l procs=1,walltime=0:15:00 -N ${jobname} -V -o ${logfile} -e ${errfile} ${plot_hist} + ${SUB} -A ${ACCOUNT} --ntasks=1 --time=00:15:00 \ + -p service -J ${jobname} -o ${logfile} ${plot_hist} fi @@ -73,7 +74,8 @@ if [[ $MY_MACHINE = "wcoss" ]]; then $SUB -q $JOB_QUEUE -P $PROJECT -o ${logfile} -M 100 -R affinity[core] -W 0:20 -J ${jobname} -cwd ${PWD} ${plot_horz} elif [[ $MY_MACHINE = "theia" ]]; then - ${SUB} -A ${ACCOUNT} -l procs=1,walltime=0:15:00 -N ${jobname} -V -o ${logfile} -e ${errfile} ${plot_horz} + ${SUB} -A ${ACCOUNT} --ntasks=1 --time=00:15:00 \ + -p service -J ${jobname} -o ${logfile} ${plot_horz} fi @@ -92,7 +94,8 @@ if [[ $MY_MACHINE = "wcoss" ]]; then $SUB -q $JOB_QUEUE -P $PROJECT -o ${logfile} -M 100 -R affinity[core] -W 0:20 -J ${jobname} ${plot_horz_uv} elif [[ $MY_MACHINE = "theia" ]]; then - ${SUB} -A ${ACCOUNT} -l procs=1,walltime=0:15:00 -N ${jobname} -V -o ${logfile} -e ${errfile} ${plot_horz_uv} + ${SUB} -A ${ACCOUNT} --ntasks=1 --time=00:15:00 \ + -p service -J ${jobname} -o ${logfile} ${plot_horz_uv} fi echo "<-- mk_horz_hist.sh" diff --git a/util/Conventional_Monitor/image_gen/ush/mk_time_vert.sh b/util/Conventional_Monitor/image_gen/ush/mk_time_vert.sh index d283d352a..96cacab2a 100755 --- a/util/Conventional_Monitor/image_gen/ush/mk_time_vert.sh +++ b/util/Conventional_Monitor/image_gen/ush/mk_time_vert.sh @@ -34,7 +34,8 @@ echo "--> mk_time_vert.sh" $SUB -q $JOB_QUEUE -P $PROJECT -o ${logfile} -R affinity[core] -M 100 -W 0:50 -J $jobname -cwd ${PWD} $pltfile elif [[ $MY_MACHINE == "theia" ]]; then - ${SUB} -A ${ACCOUNT} -l procs=1,walltime=0:15:00 -N ${jobname} -V -o ${logfile} -e ${errfile} ${pltfile} + ${SUB} -A ${ACCOUNT} --ntasks=1 --time=00:15:00 \ + -p service -J ${jobname} -o ${logfile} ${pltfile} fi #-------------------------------------------- @@ -54,12 +55,13 @@ echo "--> mk_time_vert.sh" elif [[ $MY_MACHINE == "theia" ]]; then if [[ ${type} == "uv" || ${type} == "u" || ${type} == "v" ]]; then - walltime="walltime=0:22:00" + walltime="00:22:00" else - walltime="walltime=0:10:00" + walltime="00:10:00" fi - ${SUB} -A ${ACCOUNT} -l procs=1,${walltime} -N ${jobname} -V -o ${logfile} -e ${errfile} ${pltfile} + ${SUB} -A ${ACCOUNT} --ntasks=1 --time=${walltime} \ + -p service -J ${jobname} -o ${logfile} ${pltfile} fi done @@ -82,12 +84,13 @@ echo "--> mk_time_vert.sh" elif [[ $MY_MACHINE == "theia" ]]; then if [[ ${type} == "uv" || ${type} == "u" || ${type} == "v" ]]; then - walltime="walltime=0:22:00" + walltime="00:22:00" else - walltime="walltime=0:10:00" + walltime="00:10:00" fi - ${SUB} -A ${ACCOUNT} -l procs=1,${walltime} -N ${jobname} -V -o ${logfile} -e ${errfile} ${pltfile} + ${SUB} -A ${ACCOUNT} --ntasks=1 --time=${walltime} \ + -p service -J ${jobname} -o ${logfile} ${pltfile} fi done diff --git a/util/Conventional_Monitor/image_gen/ush/plot_horz_uv.sh b/util/Conventional_Monitor/image_gen/ush/plot_horz_uv.sh index 8a7e433fd..3b266caf4 100755 --- a/util/Conventional_Monitor/image_gen/ush/plot_horz_uv.sh +++ b/util/Conventional_Monitor/image_gen/ush/plot_horz_uv.sh @@ -162,7 +162,7 @@ for type in uv; do mkdir -p ${C_IMGNDIR}/pngs/horz/${CYC} - ${NCP} -f *.png ${C_IMGNDIR}/pngs/horz/${CYC}/. + ${NCP} *.png ${C_IMGNDIR}/pngs/horz/${CYC}/. # rm *.png done ### dtype loop diff --git a/util/Conventional_Monitor/image_gen/ush/plot_time.sh b/util/Conventional_Monitor/image_gen/ush/plot_time.sh index 86876a881..174e0c028 100755 --- a/util/Conventional_Monitor/image_gen/ush/plot_time.sh +++ b/util/Conventional_Monitor/image_gen/ush/plot_time.sh @@ -55,7 +55,7 @@ export ysize=y600 for cycle in ges anl; do cp -f ${tv_tankdir}/${cycle}_${type}_stas.ctl tmp.ctl - new_dset=" dset ${cycle}_${type}_stas.%y4%m2%d2%h2" + new_dset="dset ${cycle}_${type}_stas.%y4%m2%d2%h2" tdef=`${C_IG_SCRIPTS}/make_tdef.sh ${START_DATE} ${NUM_CYCLES} 06` echo "tdef = $tdef" @@ -103,6 +103,10 @@ export ysize=y600 #------------------------- grads -bpc "run ./${local_plot_script}" cp -f *.png ${outdir}/. + + num_pngs=`ls -1 *.png | wc -l` + echo "num_pngs = ${num_pngs}" + rm -f ./*.png done diff --git a/util/Conventional_Monitor/image_gen/ush/plot_vert.sh b/util/Conventional_Monitor/image_gen/ush/plot_vert.sh index 27230b467..a2fdf0916 100755 --- a/util/Conventional_Monitor/image_gen/ush/plot_vert.sh +++ b/util/Conventional_Monitor/image_gen/ush/plot_vert.sh @@ -55,7 +55,8 @@ echo "--> plot_vert.sh " cp -f ${tv_tankdir}/${cycle}_${type}_stas.ctl tmp.ctl new_dset=" dset ${cycle}_${type}_stas.%y4%m2%d2%h2" - num_cycles=`expr ${NUM_CYCLES} + 1` +# num_cycles=`expr ${NUM_CYCLES} + 1` + num_cycles=${NUM_CYCLES} tdef=`${C_IG_SCRIPTS}/make_tdef.sh ${START_DATE} ${num_cycles} 06` echo "tdef = $tdef" diff --git a/util/Conventional_Monitor/image_gen/ush/query_data_map.pl b/util/Conventional_Monitor/image_gen/ush/query_data_map.pl new file mode 100755 index 000000000..1f5a13df2 --- /dev/null +++ b/util/Conventional_Monitor/image_gen/ush/query_data_map.pl @@ -0,0 +1,73 @@ +#! /usr/bin/perl + +#------------------------------------------------------------------- +# query_data_map.pl +# +# This script returns a requested field from the data_map.xml file. +# It takes three items as input: +# 1. data_map.xml file name (full or relative path) +# 2. suffix identifying the data source (an element in the +# data_map.xml file) +# 3. requested field, one of the xml child elements of the +# suffix element. +# +# If the xml element associated with the suffix does not have the +# requested field defined, then the default_global or +# default_regional element's corresponding field will be used. The +# default is default_global, but if the suffix contains an area of +# "rgn" then the regional_default element will be used. +# +# The contents of that field are echoed to stdout for the calling +# script to access. If the field is empty or missing nothing +# will be returned. The calling script should verify a value has +# been returned before use. +# +#------------------------------------------------------------------- + use strict; + use warnings; + use XML::LibXML; + + if( $#ARGV < 2 ) { + exit + } + + my $dmfile = $ARGV[0]; + my $source = $ARGV[1]; + my $field = $ARGV[2]; + my $default="global_default"; + use XML::LibXML; + + my $parser = XML::LibXML->new(); + my $doc = $parser->parse_file($dmfile); + +# Print the contents of the field if it's found in source. +# If the field is not found in source then use the default element +# and output it's value for the requested field. + + my @srcs = $doc->findnodes("/opt/$source"); + if( @srcs <= 0 ) { + @srcs = $doc->findnodes("/opt/$default"); + } + + if ( @srcs > 0 ) { + + my $src = $srcs[0]; + my($answer) = $src->findnodes("./$field"); + my($area) = $src->findnodes("./area"); + my $src_area = $area->to_literal; + + if( $answer ) { + print $answer->to_literal; + } + else { + if( $src_area eq "rgn" ) { + $default = "regional_default"; + } + my($def_src) = $src->findnodes("/opt/$default"); + my($def_answer) = $def_src->findnodes("./$field"); + if( $def_answer ) { + print $def_answer->to_literal; + } + } + } + diff --git a/util/Conventional_Monitor/image_gen/ush/run_plot_gdas.sh b/util/Conventional_Monitor/image_gen/ush/run_plot_gdas.sh index 9a169ffd4..a993f5595 100755 --- a/util/Conventional_Monitor/image_gen/ush/run_plot_gdas.sh +++ b/util/Conventional_Monitor/image_gen/ush/run_plot_gdas.sh @@ -1,10 +1,11 @@ #!/bin/sh -package=CMon_486 +package=ProdGSI idev=`cat /etc/dev | cut -c1` iprod=`cat /etc/prod | cut -c1` scripts=/gpfs/${idev}d2/emc/da/noscrub/${USER}/${package}/util/Conventional_Monitor/image_gen/ush +echo "scripts = $scripts" suffix=GDAS export DO_DATA_RPT=1 @@ -12,7 +13,8 @@ export DO_DIAG_RPT=1 export NDATE=/nwprod/util/exec/ndate export DO_ARCHIVE=1 export JOB_QUEUE=dev_shared -export NUM_CYCLES=120 +#export NUM_CYCLES=120 +export NUM_CYCLES=30 #export MAIL_CC="russ.treadon@noaa.gov, john.derber@noaa.gov, andrew.collard@noaa.gov" export MAIL_CC="edward.c.safford@gmail.com" @@ -29,8 +31,8 @@ prodate=`${scripts}/find_cycle.pl 1 ${tankdir}` echo "imgdate, prodate = $imgdate, $prodate" if [[ $idate -le $prodate ]]; then - echo " firing CMon_IG.err" - ${scripts}/CMon_IG.sh ${suffix} $idate 1>/ptmpp1/${USER}/logs/${suffix}/ConMon/CMon_IG.log 2>/ptmpp1/${USER}/logs/${suffix}/ConMon/CMon_IG.err + echo " firing ConMon_IG.err" + ${scripts}/ConMon_IG.sh ${suffix} $idate 1>/ptmpp1/${USER}/logs/${suffix}/ConMon/ConMon_IG.log 2>/ptmpp1/${USER}/logs/${suffix}/ConMon/ConMon_IG.err rc=`${scripts}/update_data_map.pl ${data_map} ${suffix} imgdate ${idate}` diff --git a/util/Conventional_Monitor/image_gen/ush/update_data_map.pl b/util/Conventional_Monitor/image_gen/ush/update_data_map.pl new file mode 100755 index 000000000..5a28cd309 --- /dev/null +++ b/util/Conventional_Monitor/image_gen/ush/update_data_map.pl @@ -0,0 +1,59 @@ +#! /usr/bin/perl + +#------------------------------------------------------------------- +# update_data_map.pl +# +# This script updates a requested field in the data_map.xml file. If +# the requested field does not exist in but the parent node (suffix) +# is found then the requested field and value are added to the +# data_map.xml file. +# +# Calling sequence: +# >> update_data_map.pl ./path/to/data_map.xml suffix req_field new_val +# +# 1. data_map.xml file (full or relative path) +# 2. suffix identifying the data source (an element in the +# data_map.xml file) +# 3. requested field, one of the xml child elements of the +# suffix element. +# 4. new value for the requested field +# +# Return codes (sent to stdout): +# 0 update was successful +# 1 the suffix and/or field was not found. +# +# Note: Calling scripts generally assign a variable value to +# output from this script. If diagnostic print messages +# are left uncommented then results will become undefined. +#------------------------------------------------------------------- + use strict; + use warnings; + use XML::LibXML; + + my $dmfile = $ARGV[0]; + my $source = $ARGV[1]; + my $field = $ARGV[2]; + my $value = $ARGV[3]; + my $rc = "1"; + + my $parser = XML::LibXML->new(); + my $doc = $parser->parse_file($dmfile); + + my $query = "//$source/$field/text()"; + + my($node) = $doc->findnodes($query); + + if( $node ) { + $node->setData("$value" ); + $doc->toFile( $dmfile ); + $rc = "0"; + } + else { + my $new_query = "//$source"; + my ($src_node) = $doc->findnodes($new_query); + $src_node->appendTextChild( "$field", "$value" ); + $doc->toFile( $dmfile ); + $rc = "0"; + } + + print "$rc"; diff --git a/util/Conventional_Monitor/lst b/util/Conventional_Monitor/lst deleted file mode 100644 index 559c43e57..000000000 --- a/util/Conventional_Monitor/lst +++ /dev/null @@ -1,873 +0,0 @@ -. -./lst -./makeall.sh -./get_hostname.pl -./CMon_install.pl -./nwprod -./nwprod/cmon_shared.v1.0.0 -./nwprod/cmon_shared.v1.0.0/modulefiles -./nwprod/cmon_shared.v1.0.0/modulefiles/theia -./nwprod/cmon_shared.v1.0.0/modulefiles/theia/CMonBuild -./nwprod/cmon_shared.v1.0.0/modulefiles/wcoss -./nwprod/cmon_shared.v1.0.0/modulefiles/wcoss/CMonBuild -./nwprod/cmon_shared.v1.0.0/modulefiles/cray -./nwprod/cmon_shared.v1.0.0/modulefiles/cray/CMonBuild -./nwprod/cmon_shared.v1.0.0/ush -./nwprod/cmon_shared.v1.0.0/ush/diag2grad_uv_case.sh -./nwprod/cmon_shared.v1.0.0/ush/grib2ctl.pl -./nwprod/cmon_shared.v1.0.0/ush/diag2grad_ps_case.sh -./nwprod/cmon_shared.v1.0.0/ush/time_vert.sh -./nwprod/cmon_shared.v1.0.0/ush/horz_hist.sh -./nwprod/cmon_shared.v1.0.0/ush/diag2grad_q_case.sh -./nwprod/cmon_shared.v1.0.0/ush/diag2grad_t_case.sh -./nwprod/cmon_shared.v1.0.0/ush/g2ctl.pl -./nwprod/cmon_shared.v1.0.0/sorc -./nwprod/cmon_shared.v1.0.0/sorc/read_pw -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/read_pw_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/makefile.read_pw -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/read_pw.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/mainread_pw.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/text-base/maingrads_mandlev.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/text-base/convinfo.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/text-base/read_conv2grads.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/text-base/generic_list.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/text-base/grads_mandlev.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/text-base/data_mod.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/text-base/rm_dups.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/text-base/makefile.grads_mandlev.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/prop-base/makefile.grads_mandlev.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/maingrads_mandlev.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/makefile.grads_mandlev -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/grads_mandlev.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/grads_sfc.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/makefile.grads_sfc -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/text-base/makefile.grads_sfc.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/text-base/convinfo.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/text-base/read_conv2grads.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/text-base/generic_list.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/text-base/data_mod.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/text-base/rm_dups.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/text-base/maingrads_sfc.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/text-base/grads_sfc.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/prop-base/makefile.grads_sfc.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/maingrads_sfc.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t -./nwprod/cmon_shared.v1.0.0/sorc/read_t/read_t_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/mainread_t.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/text-base/convinfo.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/text-base/histgram.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/text-base/read_t_mor.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/text-base/makefile.read_t.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/text-base/rm_dups.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/text-base/read_t.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/text-base/mainread_t.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/read_t/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/read_t/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/read_t.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/makefile.read_t -./nwprod/cmon_shared.v1.0.0/sorc/read_t/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/read_uv_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/mainread_uv.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/read_uv.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/makefile.read_uv -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/text-base/convinfo.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/text-base/histgram.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/text-base/read_uv.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/text-base/read_uv_mor.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/text-base/rm_dups.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/text-base/makefile.read_uv.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/text-base/histgramuv.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/text-base/mainread_uv.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/prop-base/makefile.read_uv.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/histgramuv.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/read_ps.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/makefile.read_ps -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/text-base/read_ps.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/text-base/convinfo.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/text-base/mainread_ps.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/text-base/histgram.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/text-base/read_ps_mor.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/text-base/rm_dups.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/text-base/makefile.read_ps.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/prop-base/makefile.read_ps.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/mainread_ps.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/read_ps_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q -./nwprod/cmon_shared.v1.0.0/sorc/read_q/mainread_q.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/read_q_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/read_q.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/text-base/convinfo.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/text-base/read_q.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/text-base/histgram.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/text-base/mainread_q.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/text-base/makefile.read_q.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/text-base/read_q_mor.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/text-base/rm_dups.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/prop-base/makefile.read_q.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/read_q/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/read_q/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/makefile.read_q -./nwprod/cmon_shared.v1.0.0/sorc/read_q/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/.svn -./nwprod/cmon_shared.v1.0.0/sorc/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/makefile.grads_sig -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/maingrads_sig.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/text-base/maingrads_sig.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/text-base/convinfo.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/text-base/read_conv2grads.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/text-base/generic_list.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/text-base/data_mod.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/text-base/rm_dups.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/text-base/grads_sig.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/text-base/makefile.grads_sig.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/prop-base/makefile.grads_sig.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/grads_sig.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/makefile.grads_lev -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/maingrads_lev.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/text-base/maingrads_lev.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/text-base/convinfo.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/text-base/read_conv2grads.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/text-base/grads_lev.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/text-base/generic_list.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/text-base/data_mod.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/text-base/makefile.grads_lev.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/text-base/rm_dups.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/prop-base/makefile.grads_lev.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/grads_lev.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/maingrads_sfctime.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/text-base/makefile.grads_sfctime.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/text-base/convinfo.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/text-base/grads_sfctime.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/text-base/read_conv2grads.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/text-base/generic_list.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/text-base/data_mod.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/text-base/rm_dups.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/text-base/maingrads_sfctime.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/prop-base/makefile.grads_sfctime.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/grads_sfctime.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/makefile.grads_sfctime -./nwprod/cmon_shared.v1.0.0/sorc/conv_time -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/stas2ctl.f90 -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/stas_time.f90 -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/convinfo2.f90 -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/tmp -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/props -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/text-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/text-base/mainconv_time.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/text-base/stas_time.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/text-base/makefile.conv_time.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/text-base/stas2ctl.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/text-base/read_conv.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/text-base/convinfo2.f90.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/prop-base/makefile.conv_time.svn-base -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/.svn/entries -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/read_conv.f90 -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/makefile.conv_time -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/mainconv_time.f90 -./nwprod/cmon_shared.v1.0.0/.svn -./nwprod/cmon_shared.v1.0.0/.svn/tmp -./nwprod/cmon_shared.v1.0.0/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/.svn/props -./nwprod/cmon_shared.v1.0.0/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/.svn/text-base -./nwprod/cmon_shared.v1.0.0/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/.svn/entries -./nwprod/cmon_shared.v1.0.0/exec -./nwprod/cmon_shared.v1.0.0/exec/.svn -./nwprod/cmon_shared.v1.0.0/exec/.svn/tmp -./nwprod/cmon_shared.v1.0.0/exec/.svn/tmp/props -./nwprod/cmon_shared.v1.0.0/exec/.svn/tmp/text-base -./nwprod/cmon_shared.v1.0.0/exec/.svn/tmp/prop-base -./nwprod/cmon_shared.v1.0.0/exec/.svn/props -./nwprod/cmon_shared.v1.0.0/exec/.svn/all-wcprops -./nwprod/cmon_shared.v1.0.0/exec/.svn/text-base -./nwprod/cmon_shared.v1.0.0/exec/.svn/prop-base -./nwprod/cmon_shared.v1.0.0/exec/.svn/entries -./nwprod/gdas_cmon.v1.0.0 -./nwprod/gdas_cmon.v1.0.0/scripts -./nwprod/gdas_cmon.v1.0.0/scripts/.svn -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/tmp -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/tmp/props -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/tmp/text-base -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/tmp/prop-base -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/props -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/all-wcprops -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/text-base -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/text-base/exgdas_vrfyconv.sh.ecf.svn-base -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/prop-base -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/prop-base/exgdas_vrfyconv.sh.ecf.svn-base -./nwprod/gdas_cmon.v1.0.0/scripts/.svn/entries -./nwprod/gdas_cmon.v1.0.0/scripts/exgdas_vrfyconv.sh.ecf -./nwprod/gdas_cmon.v1.0.0/.svn -./nwprod/gdas_cmon.v1.0.0/.svn/tmp -./nwprod/gdas_cmon.v1.0.0/.svn/tmp/props -./nwprod/gdas_cmon.v1.0.0/.svn/tmp/text-base -./nwprod/gdas_cmon.v1.0.0/.svn/tmp/prop-base -./nwprod/gdas_cmon.v1.0.0/.svn/props -./nwprod/gdas_cmon.v1.0.0/.svn/all-wcprops -./nwprod/gdas_cmon.v1.0.0/.svn/text-base -./nwprod/gdas_cmon.v1.0.0/.svn/prop-base -./nwprod/gdas_cmon.v1.0.0/.svn/entries -./nwprod/gdas_cmon.v1.0.0/driver -./nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_ibm.sh -./nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_theia.sh -./nwprod/gdas_cmon.v1.0.0/driver/.svn -./nwprod/gdas_cmon.v1.0.0/driver/.svn/tmp -./nwprod/gdas_cmon.v1.0.0/driver/.svn/tmp/props -./nwprod/gdas_cmon.v1.0.0/driver/.svn/tmp/text-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/tmp/prop-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/props -./nwprod/gdas_cmon.v1.0.0/driver/.svn/all-wcprops -./nwprod/gdas_cmon.v1.0.0/driver/.svn/text-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/text-base/test_jgdas_vcmon_cray.sh.svn-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/text-base/test_jgdas_vcmon_theia.sh.svn-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/text-base/test_jgdas_vcmon_ibm.sh.svn-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/prop-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/prop-base/test_jgdas_vcmon_cray.sh.svn-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/prop-base/test_jgdas_vcmon_theia.sh.svn-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/prop-base/test_jgdas_vcmon_ibm.sh.svn-base -./nwprod/gdas_cmon.v1.0.0/driver/.svn/entries -./nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_cray.sh -./nwprod/gdas_cmon.v1.0.0/jobs -./nwprod/gdas_cmon.v1.0.0/jobs/JGDAS_VCMON -./nwprod/gdas_cmon.v1.0.0/jobs/.svn -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/tmp -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/tmp/props -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/tmp/text-base -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/tmp/prop-base -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/props -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/all-wcprops -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/text-base -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/text-base/JGDAS_VCMON.svn-base -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/prop-base -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/prop-base/JGDAS_VCMON.svn-base -./nwprod/gdas_cmon.v1.0.0/jobs/.svn/entries -./nwprod/gdas_cmon.v1.0.0/fix -./nwprod/gdas_cmon.v1.0.0/fix/.svn -./nwprod/gdas_cmon.v1.0.0/fix/.svn/tmp -./nwprod/gdas_cmon.v1.0.0/fix/.svn/tmp/props -./nwprod/gdas_cmon.v1.0.0/fix/.svn/tmp/text-base -./nwprod/gdas_cmon.v1.0.0/fix/.svn/tmp/prop-base -./nwprod/gdas_cmon.v1.0.0/fix/.svn/props -./nwprod/gdas_cmon.v1.0.0/fix/.svn/all-wcprops -./nwprod/gdas_cmon.v1.0.0/fix/.svn/text-base -./nwprod/gdas_cmon.v1.0.0/fix/.svn/text-base/global_convinfo.txt.svn-base -./nwprod/gdas_cmon.v1.0.0/fix/.svn/prop-base -./nwprod/gdas_cmon.v1.0.0/fix/.svn/prop-base/global_convinfo.txt.svn-base -./nwprod/gdas_cmon.v1.0.0/fix/.svn/entries -./nwprod/gdas_cmon.v1.0.0/fix/global_convinfo.txt -./.svn -./.svn/tmp -./.svn/tmp/props -./.svn/tmp/text-base -./.svn/tmp/prop-base -./.svn/props -./.svn/all-wcprops -./.svn/text-base -./.svn/text-base/makeall.sh.svn-base -./.svn/text-base/CMon_install.pl.svn-base -./.svn/text-base/get_hostname.pl.svn-base -./.svn/prop-base -./.svn/prop-base/makeall.sh.svn-base -./.svn/prop-base/CMon_install.pl.svn-base -./.svn/prop-base/get_hostname.pl.svn-base -./.svn/entries -./parm -./parm/CMon_config -./parm/CMon.ver -./parm/.svn -./parm/.svn/tmp -./parm/.svn/tmp/props -./parm/.svn/tmp/text-base -./parm/.svn/tmp/prop-base -./parm/.svn/props -./parm/.svn/all-wcprops -./parm/.svn/text-base -./parm/.svn/text-base/CMon.ver.svn-base -./parm/.svn/text-base/CMon_user_settings.svn-base -./parm/.svn/text-base/CMon_config.svn-base -./parm/.svn/prop-base -./parm/.svn/entries -./parm/CMon_user_settings -./data_extract -./data_extract/ush -./data_extract/ush/find_cycle.pl -./data_extract/ush/onprod.sh -./data_extract/ush/.svn -./data_extract/ush/.svn/tmp -./data_extract/ush/.svn/tmp/props -./data_extract/ush/.svn/tmp/text-base -./data_extract/ush/.svn/tmp/prop-base -./data_extract/ush/.svn/props -./data_extract/ush/.svn/all-wcprops -./data_extract/ush/.svn/text-base -./data_extract/ush/.svn/text-base/CMon_DE.sh.svn-base -./data_extract/ush/.svn/text-base/onprod.sh.svn-base -./data_extract/ush/.svn/text-base/RunCMonDE.sh.svn-base -./data_extract/ush/.svn/text-base/find_cycle.pl.svn-base -./data_extract/ush/.svn/prop-base -./data_extract/ush/.svn/prop-base/CMon_DE.sh.svn-base -./data_extract/ush/.svn/prop-base/onprod.sh.svn-base -./data_extract/ush/.svn/prop-base/RunCMonDE.sh.svn-base -./data_extract/ush/.svn/prop-base/find_cycle.pl.svn-base -./data_extract/ush/.svn/entries -./data_extract/ush/CMon_DE.sh -./data_extract/ush/RunCMonDE.sh -./data_extract/.svn -./data_extract/.svn/tmp -./data_extract/.svn/tmp/props -./data_extract/.svn/tmp/text-base -./data_extract/.svn/tmp/prop-base -./data_extract/.svn/props -./data_extract/.svn/all-wcprops -./data_extract/.svn/text-base -./data_extract/.svn/prop-base -./data_extract/.svn/entries -./image_gen -./image_gen/gscripts -./image_gen/gscripts/plot_uvsatwind_horz.gs -./image_gen/gscripts/plotstas_time_bias2_ps.gs -./image_gen/gscripts/rgbset2.gs -./image_gen/gscripts/page.gs -./image_gen/gscripts/plot_pw_horz.gs -./image_gen/gscripts/plot_qallev_horz.gs -./image_gen/gscripts/plotstas_time_bias2.gs -./image_gen/gscripts/test.gs -./image_gen/gscripts/plotstas_vert_bias2.gs -./image_gen/gscripts/plotstas_vert_bias.gs -./image_gen/gscripts/plot_tallev_horz.gs -./image_gen/gscripts/plot_uvsfc_horz.gs -./image_gen/gscripts/plotstas_time_ps.gs -./image_gen/gscripts/setvpage.gs -./image_gen/gscripts/plotstas_time_bias_ps.gs -./image_gen/gscripts/plot_ps_horz.gs -./image_gen/gscripts/.svn -./image_gen/gscripts/.svn/tmp -./image_gen/gscripts/.svn/tmp/props -./image_gen/gscripts/.svn/tmp/text-base -./image_gen/gscripts/.svn/tmp/prop-base -./image_gen/gscripts/.svn/props -./image_gen/gscripts/.svn/all-wcprops -./image_gen/gscripts/.svn/text-base -./image_gen/gscripts/.svn/text-base/plot_uvallev_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/test.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_vert_count.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_tflex_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_time_bias2.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_time_ps.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_time_bias2_ps.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_tallev_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/setvpage.gs.svn-base -./image_gen/gscripts/.svn/text-base/setupmap.gs.svn-base -./image_gen/gscripts/.svn/text-base/rgbset2.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_ps_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/defint.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_time_bias_pw.gs.svn-base -./image_gen/gscripts/.svn/text-base/page.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_qallev_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_pw_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_tsfc_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_qsfc_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_uvsfc_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_time_bias_ps.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_hist.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_time_count_ps.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_time_bias.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_time_pw.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_vert_bias2.gs.svn-base -./image_gen/gscripts/.svn/text-base/plot_uvsatwind_horz.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_time_count.gs.svn-base -./image_gen/gscripts/.svn/text-base/plotstas_vert_bias.gs.svn-base -./image_gen/gscripts/.svn/prop-base -./image_gen/gscripts/.svn/prop-base/plot_hist.gs.svn-base -./image_gen/gscripts/.svn/entries -./image_gen/gscripts/plotstas_time_bias.gs -./image_gen/gscripts/plot_hist.gs -./image_gen/gscripts/plot_qsfc_horz.gs -./image_gen/gscripts/plot_uvallev_horz.gs -./image_gen/gscripts/plotstas_time_bias_pw.gs -./image_gen/gscripts/setupmap.gs -./image_gen/gscripts/plot_tflex_horz.gs -./image_gen/gscripts/plotstas_vert_count.gs -./image_gen/gscripts/plotstas_time_count_ps.gs -./image_gen/gscripts/plot_tsfc_horz.gs -./image_gen/gscripts/plotstas_time_count.gs -./image_gen/gscripts/defint.gs -./image_gen/gscripts/plotstas_time_pw.gs -./image_gen/ush -./image_gen/ush/plot_vert.sh -./image_gen/ush/find_cycle.pl -./image_gen/ush/Transfer.sh -./image_gen/ush/make_tdef.sh -./image_gen/ush/plot_time_ps.sh -./image_gen/ush/run_transfer_gdas.sh -./image_gen/ush/plot_horz.sh -./image_gen/ush/run_plot_gdas.sh -./image_gen/ush/grib2ctl.pl -./image_gen/ush/plot_time.sh -./image_gen/ush/onprod.sh -./image_gen/ush/.svn -./image_gen/ush/.svn/tmp -./image_gen/ush/.svn/tmp/props -./image_gen/ush/.svn/tmp/text-base -./image_gen/ush/.svn/tmp/prop-base -./image_gen/ush/.svn/props -./image_gen/ush/.svn/all-wcprops -./image_gen/ush/.svn/text-base -./image_gen/ush/.svn/text-base/make_tdef.sh.svn-base -./image_gen/ush/.svn/text-base/plot_horz.sh.svn-base -./image_gen/ush/.svn/text-base/plot_time_ps.sh.svn-base -./image_gen/ush/.svn/text-base/g2ctl.pl.svn-base -./image_gen/ush/.svn/text-base/mk_time_vert.sh.svn-base -./image_gen/ush/.svn/text-base/run_plot_gdas.sh.svn-base -./image_gen/ush/.svn/text-base/Transfer.sh.svn-base -./image_gen/ush/.svn/text-base/make_timesers_ctl.sh.svn-base -./image_gen/ush/.svn/text-base/plot_hist.sh.svn-base -./image_gen/ush/.svn/text-base/plot_horz_uv.sh.svn-base -./image_gen/ush/.svn/text-base/onprod.sh.svn-base -./image_gen/ush/.svn/text-base/CMon_IG.sh.svn-base -./image_gen/ush/.svn/text-base/grib2ctl.pl.svn-base -./image_gen/ush/.svn/text-base/find_cycle.pl.svn-base -./image_gen/ush/.svn/text-base/read_scatter.sh.svn-base -./image_gen/ush/.svn/text-base/mk_horz_hist.sh.svn-base -./image_gen/ush/.svn/text-base/plot_time.sh.svn-base -./image_gen/ush/.svn/text-base/plot_vert.sh.svn-base -./image_gen/ush/.svn/text-base/run_transfer_gdas.sh.svn-base -./image_gen/ush/.svn/prop-base -./image_gen/ush/.svn/prop-base/make_tdef.sh.svn-base -./image_gen/ush/.svn/prop-base/plot_horz.sh.svn-base -./image_gen/ush/.svn/prop-base/plot_time_ps.sh.svn-base -./image_gen/ush/.svn/prop-base/g2ctl.pl.svn-base -./image_gen/ush/.svn/prop-base/mk_time_vert.sh.svn-base -./image_gen/ush/.svn/prop-base/run_plot_gdas.sh.svn-base -./image_gen/ush/.svn/prop-base/Transfer.sh.svn-base -./image_gen/ush/.svn/prop-base/make_timesers_ctl.sh.svn-base -./image_gen/ush/.svn/prop-base/plot_hist.sh.svn-base -./image_gen/ush/.svn/prop-base/plot_horz_uv.sh.svn-base -./image_gen/ush/.svn/prop-base/onprod.sh.svn-base -./image_gen/ush/.svn/prop-base/CMon_IG.sh.svn-base -./image_gen/ush/.svn/prop-base/grib2ctl.pl.svn-base -./image_gen/ush/.svn/prop-base/find_cycle.pl.svn-base -./image_gen/ush/.svn/prop-base/read_scatter.sh.svn-base -./image_gen/ush/.svn/prop-base/mk_horz_hist.sh.svn-base -./image_gen/ush/.svn/prop-base/plot_time.sh.svn-base -./image_gen/ush/.svn/prop-base/plot_vert.sh.svn-base -./image_gen/ush/.svn/prop-base/run_transfer_gdas.sh.svn-base -./image_gen/ush/.svn/entries -./image_gen/ush/CMon_IG.sh -./image_gen/ush/make_timesers_ctl.sh -./image_gen/ush/plot_horz_uv.sh -./image_gen/ush/read_scatter.sh -./image_gen/ush/mk_horz_hist.sh -./image_gen/ush/plot_hist.sh -./image_gen/ush/g2ctl.pl -./image_gen/ush/mk_time_vert.sh -./image_gen/sorc -./image_gen/sorc/read_pw -./image_gen/sorc/read_pw/rm_dups.f90 -./image_gen/sorc/read_pw/read_pw_mor.f90 -./image_gen/sorc/read_pw/.svn -./image_gen/sorc/read_pw/.svn/tmp -./image_gen/sorc/read_pw/.svn/tmp/props -./image_gen/sorc/read_pw/.svn/tmp/text-base -./image_gen/sorc/read_pw/.svn/tmp/prop-base -./image_gen/sorc/read_pw/.svn/props -./image_gen/sorc/read_pw/.svn/all-wcprops -./image_gen/sorc/read_pw/.svn/text-base -./image_gen/sorc/read_pw/.svn/text-base/read_pw.f90.svn-base -./image_gen/sorc/read_pw/.svn/text-base/makefile.read_pw.svn-base -./image_gen/sorc/read_pw/.svn/text-base/convinfo.f90.svn-base -./image_gen/sorc/read_pw/.svn/text-base/histgram.f90.svn-base -./image_gen/sorc/read_pw/.svn/text-base/read_pw_mor.f90.svn-base -./image_gen/sorc/read_pw/.svn/text-base/mainread_pw.f90.svn-base -./image_gen/sorc/read_pw/.svn/text-base/rm_dups.f90.svn-base -./image_gen/sorc/read_pw/.svn/prop-base -./image_gen/sorc/read_pw/.svn/prop-base/makefile.read_pw.svn-base -./image_gen/sorc/read_pw/.svn/entries -./image_gen/sorc/read_pw/makefile.read_pw -./image_gen/sorc/read_pw/convinfo.f90 -./image_gen/sorc/read_pw/read_pw.f90 -./image_gen/sorc/read_pw/mainread_pw.f90 -./image_gen/sorc/read_pw/histgram.f90 -./image_gen/sorc/read_t -./image_gen/sorc/read_t/read_t_mor.f90 -./image_gen/sorc/read_t/mainread_t.f90 -./image_gen/sorc/read_t/rm_dups.f90 -./image_gen/sorc/read_t/.svn -./image_gen/sorc/read_t/.svn/tmp -./image_gen/sorc/read_t/.svn/tmp/props -./image_gen/sorc/read_t/.svn/tmp/text-base -./image_gen/sorc/read_t/.svn/tmp/prop-base -./image_gen/sorc/read_t/.svn/props -./image_gen/sorc/read_t/.svn/all-wcprops -./image_gen/sorc/read_t/.svn/text-base -./image_gen/sorc/read_t/.svn/text-base/convinfo.f90.svn-base -./image_gen/sorc/read_t/.svn/text-base/histgram.f90.svn-base -./image_gen/sorc/read_t/.svn/text-base/read_t_mor.f90.svn-base -./image_gen/sorc/read_t/.svn/text-base/makefile.read_t.svn-base -./image_gen/sorc/read_t/.svn/text-base/rm_dups.f90.svn-base -./image_gen/sorc/read_t/.svn/text-base/read_t.f90.svn-base -./image_gen/sorc/read_t/.svn/text-base/mainread_t.f90.svn-base -./image_gen/sorc/read_t/.svn/prop-base -./image_gen/sorc/read_t/.svn/entries -./image_gen/sorc/read_t/convinfo.f90 -./image_gen/sorc/read_t/read_t.f90 -./image_gen/sorc/read_t/makefile.read_t -./image_gen/sorc/read_t/histgram.f90 -./image_gen/sorc/read_uv -./image_gen/sorc/read_uv/read_uv_mor.f90 -./image_gen/sorc/read_uv/mainread_uv.f90 -./image_gen/sorc/read_uv/read_uv.f90 -./image_gen/sorc/read_uv/rm_dups.f90 -./image_gen/sorc/read_uv/makefile.read_uv -./image_gen/sorc/read_uv/.svn -./image_gen/sorc/read_uv/.svn/tmp -./image_gen/sorc/read_uv/.svn/tmp/props -./image_gen/sorc/read_uv/.svn/tmp/text-base -./image_gen/sorc/read_uv/.svn/tmp/prop-base -./image_gen/sorc/read_uv/.svn/props -./image_gen/sorc/read_uv/.svn/all-wcprops -./image_gen/sorc/read_uv/.svn/text-base -./image_gen/sorc/read_uv/.svn/text-base/convinfo.f90.svn-base -./image_gen/sorc/read_uv/.svn/text-base/histgram.f90.svn-base -./image_gen/sorc/read_uv/.svn/text-base/read_uv.f90.svn-base -./image_gen/sorc/read_uv/.svn/text-base/read_uv_mor.f90.svn-base -./image_gen/sorc/read_uv/.svn/text-base/rm_dups.f90.svn-base -./image_gen/sorc/read_uv/.svn/text-base/makefile.read_uv.svn-base -./image_gen/sorc/read_uv/.svn/text-base/histgramuv.f90.svn-base -./image_gen/sorc/read_uv/.svn/text-base/mainread_uv.f90.svn-base -./image_gen/sorc/read_uv/.svn/prop-base -./image_gen/sorc/read_uv/.svn/prop-base/makefile.read_uv.svn-base -./image_gen/sorc/read_uv/.svn/entries -./image_gen/sorc/read_uv/histgramuv.f90 -./image_gen/sorc/read_uv/convinfo.f90 -./image_gen/sorc/read_uv/histgram.f90 -./image_gen/sorc/read_ps -./image_gen/sorc/read_ps/read_ps.f90 -./image_gen/sorc/read_ps/makefile.read_ps -./image_gen/sorc/read_ps/rm_dups.f90 -./image_gen/sorc/read_ps/.svn -./image_gen/sorc/read_ps/.svn/tmp -./image_gen/sorc/read_ps/.svn/tmp/props -./image_gen/sorc/read_ps/.svn/tmp/text-base -./image_gen/sorc/read_ps/.svn/tmp/prop-base -./image_gen/sorc/read_ps/.svn/props -./image_gen/sorc/read_ps/.svn/all-wcprops -./image_gen/sorc/read_ps/.svn/text-base -./image_gen/sorc/read_ps/.svn/text-base/read_ps.f90.svn-base -./image_gen/sorc/read_ps/.svn/text-base/convinfo.f90.svn-base -./image_gen/sorc/read_ps/.svn/text-base/mainread_ps.f90.svn-base -./image_gen/sorc/read_ps/.svn/text-base/histgram.f90.svn-base -./image_gen/sorc/read_ps/.svn/text-base/read_ps_mor.f90.svn-base -./image_gen/sorc/read_ps/.svn/text-base/rm_dups.f90.svn-base -./image_gen/sorc/read_ps/.svn/text-base/makefile.read_ps.svn-base -./image_gen/sorc/read_ps/.svn/prop-base -./image_gen/sorc/read_ps/.svn/prop-base/makefile.read_ps.svn-base -./image_gen/sorc/read_ps/.svn/entries -./image_gen/sorc/read_ps/mainread_ps.f90 -./image_gen/sorc/read_ps/convinfo.f90 -./image_gen/sorc/read_ps/read_ps_mor.f90 -./image_gen/sorc/read_ps/histgram.f90 -./image_gen/sorc/read_q -./image_gen/sorc/read_q/mainread_q.f90 -./image_gen/sorc/read_q/rm_dups.f90 -./image_gen/sorc/read_q/read_q_mor.f90 -./image_gen/sorc/read_q/read_q.f90 -./image_gen/sorc/read_q/.svn -./image_gen/sorc/read_q/.svn/tmp -./image_gen/sorc/read_q/.svn/tmp/props -./image_gen/sorc/read_q/.svn/tmp/text-base -./image_gen/sorc/read_q/.svn/tmp/prop-base -./image_gen/sorc/read_q/.svn/props -./image_gen/sorc/read_q/.svn/all-wcprops -./image_gen/sorc/read_q/.svn/text-base -./image_gen/sorc/read_q/.svn/text-base/convinfo.f90.svn-base -./image_gen/sorc/read_q/.svn/text-base/read_q.f90.svn-base -./image_gen/sorc/read_q/.svn/text-base/histgram.f90.svn-base -./image_gen/sorc/read_q/.svn/text-base/mainread_q.f90.svn-base -./image_gen/sorc/read_q/.svn/text-base/makefile.read_q.svn-base -./image_gen/sorc/read_q/.svn/text-base/read_q_mor.f90.svn-base -./image_gen/sorc/read_q/.svn/text-base/rm_dups.f90.svn-base -./image_gen/sorc/read_q/.svn/prop-base -./image_gen/sorc/read_q/.svn/prop-base/makefile.read_q.svn-base -./image_gen/sorc/read_q/.svn/entries -./image_gen/sorc/read_q/convinfo.f90 -./image_gen/sorc/read_q/makefile.read_q -./image_gen/sorc/read_q/histgram.f90 -./image_gen/sorc/.svn -./image_gen/sorc/.svn/tmp -./image_gen/sorc/.svn/tmp/props -./image_gen/sorc/.svn/tmp/text-base -./image_gen/sorc/.svn/tmp/prop-base -./image_gen/sorc/.svn/props -./image_gen/sorc/.svn/all-wcprops -./image_gen/sorc/.svn/text-base -./image_gen/sorc/.svn/prop-base -./image_gen/sorc/.svn/entries -./image_gen/.svn -./image_gen/.svn/tmp -./image_gen/.svn/tmp/props -./image_gen/.svn/tmp/text-base -./image_gen/.svn/tmp/prop-base -./image_gen/.svn/props -./image_gen/.svn/all-wcprops -./image_gen/.svn/text-base -./image_gen/.svn/prop-base -./image_gen/.svn/entries -./image_gen/exec -./image_gen/exec/.svn -./image_gen/exec/.svn/tmp -./image_gen/exec/.svn/tmp/props -./image_gen/exec/.svn/tmp/text-base -./image_gen/exec/.svn/tmp/prop-base -./image_gen/exec/.svn/props -./image_gen/exec/.svn/all-wcprops -./image_gen/exec/.svn/text-base -./image_gen/exec/.svn/prop-base -./image_gen/exec/.svn/entries -./image_gen/fix -./image_gen/fix/uvsfc7.ctl -./image_gen/fix/uvmandlev.ctl -./image_gen/fix/hist_ps.ctl -./image_gen/fix/uvsfc11.ctl -./image_gen/fix/qsfc.ctl -./image_gen/fix/hist_uv.ctl -./image_gen/fix/uvallev.ctl -./image_gen/fix/tmandlev.ctl -./image_gen/fix/.svn -./image_gen/fix/.svn/tmp -./image_gen/fix/.svn/tmp/props -./image_gen/fix/.svn/tmp/text-base -./image_gen/fix/.svn/tmp/prop-base -./image_gen/fix/.svn/props -./image_gen/fix/.svn/all-wcprops -./image_gen/fix/.svn/text-base -./image_gen/fix/.svn/text-base/uvsig.ctl.svn-base -./image_gen/fix/.svn/text-base/qallev.ctl.svn-base -./image_gen/fix/.svn/text-base/uvmandlev.ctl.svn-base -./image_gen/fix/.svn/text-base/pssfc.ctl.svn-base -./image_gen/fix/.svn/text-base/tmandlev.ctl.svn-base -./image_gen/fix/.svn/text-base/uvallev.ctl.svn-base -./image_gen/fix/.svn/text-base/hist_q.ctl.svn-base -./image_gen/fix/.svn/text-base/hist_t.ctl.svn-base -./image_gen/fix/.svn/text-base/hist_ps.ctl.svn-base -./image_gen/fix/.svn/text-base/tallev.ctl.svn-base -./image_gen/fix/.svn/text-base/uvsfc7.ctl.svn-base -./image_gen/fix/.svn/text-base/hist_uv.ctl.svn-base -./image_gen/fix/.svn/text-base/qmandlev.ctl.svn-base -./image_gen/fix/.svn/text-base/tsfc.ctl.svn-base -./image_gen/fix/.svn/text-base/qsfc.ctl.svn-base -./image_gen/fix/.svn/text-base/pstime.ctl.svn-base -./image_gen/fix/.svn/text-base/uvsfc11.ctl.svn-base -./image_gen/fix/.svn/prop-base -./image_gen/fix/.svn/entries -./image_gen/fix/qmandlev.ctl -./image_gen/fix/tsfc.ctl -./image_gen/fix/uvsig.ctl -./image_gen/fix/qallev.ctl -./image_gen/fix/pssfc.ctl -./image_gen/fix/tallev.ctl -./image_gen/fix/pstime.ctl -./image_gen/fix/hist_q.ctl -./image_gen/fix/hist_t.ctl -./image_gen/html -./image_gen/html/index.html -./image_gen/html/vertbody.html -./image_gen/html/menu_hist.html -./image_gen/html/menu_vert.html -./image_gen/html/horzbody.html -./image_gen/html/histbody.html -./image_gen/html/intro_time.html -./image_gen/html/intro_vert.html -./image_gen/html/index_vert.html -./image_gen/html/CMon_Install_html.sh -./image_gen/html/intro_horz.html -./image_gen/html/.svn -./image_gen/html/.svn/tmp -./image_gen/html/.svn/tmp/props -./image_gen/html/.svn/tmp/text-base -./image_gen/html/.svn/tmp/prop-base -./image_gen/html/.svn/props -./image_gen/html/.svn/all-wcprops -./image_gen/html/.svn/text-base -./image_gen/html/.svn/text-base/index_horz.html.svn-base -./image_gen/html/.svn/text-base/intro_hist.html.svn-base -./image_gen/html/.svn/text-base/menu_time.html.svn-base -./image_gen/html/.svn/text-base/surf_horzbody.html.svn-base -./image_gen/html/.svn/text-base/timebody.html.svn-base -./image_gen/html/.svn/text-base/menu_hist.html.svn-base -./image_gen/html/.svn/text-base/index_hist.html.svn-base -./image_gen/html/.svn/text-base/menu_vert.html.svn-base -./image_gen/html/.svn/text-base/CMon_Install_html.sh.svn-base -./image_gen/html/.svn/text-base/surf_timebody.html.svn-base -./image_gen/html/.svn/text-base/histbody.html.svn-base -./image_gen/html/.svn/text-base/vertbody.html.svn-base -./image_gen/html/.svn/text-base/intro_horz.html.svn-base -./image_gen/html/.svn/text-base/intro_time.html.svn-base -./image_gen/html/.svn/text-base/menu_horz.html.svn-base -./image_gen/html/.svn/text-base/horzbody.html.svn-base -./image_gen/html/.svn/text-base/index_vert.html.svn-base -./image_gen/html/.svn/text-base/intro_vert.html.svn-base -./image_gen/html/.svn/text-base/index_time.html.svn-base -./image_gen/html/.svn/text-base/index.html.svn-base -./image_gen/html/.svn/prop-base -./image_gen/html/.svn/prop-base/CMon_Install_html.sh.svn-base -./image_gen/html/.svn/prop-base/intro_horz.html.svn-base -./image_gen/html/.svn/prop-base/index.html.svn-base -./image_gen/html/.svn/entries -./image_gen/html/surf_timebody.html -./image_gen/html/menu_time.html -./image_gen/html/index_hist.html -./image_gen/html/index_horz.html -./image_gen/html/index_time.html -./image_gen/html/timebody.html -./image_gen/html/menu_horz.html -./image_gen/html/surf_horzbody.html -./image_gen/html/intro_hist.html diff --git a/util/Conventional_Monitor/lst2 b/util/Conventional_Monitor/lst2 deleted file mode 100644 index c97879934..000000000 --- a/util/Conventional_Monitor/lst2 +++ /dev/null @@ -1,270 +0,0 @@ -./makeall.sh -./get_hostname.pl -./CMon_install.pl -./nwprod -./nwprod/cmon_shared.v1.0.0 -./nwprod/cmon_shared.v1.0.0/modulefiles -./nwprod/cmon_shared.v1.0.0/modulefiles/theia -./nwprod/cmon_shared.v1.0.0/modulefiles/theia/CMonBuild -./nwprod/cmon_shared.v1.0.0/modulefiles/wcoss -./nwprod/cmon_shared.v1.0.0/modulefiles/wcoss/CMonBuild -./nwprod/cmon_shared.v1.0.0/modulefiles/cray -./nwprod/cmon_shared.v1.0.0/modulefiles/cray/CMonBuild -./nwprod/cmon_shared.v1.0.0/ush -./nwprod/cmon_shared.v1.0.0/ush/diag2grad_uv_case.sh -./nwprod/cmon_shared.v1.0.0/ush/grib2ctl.pl -./nwprod/cmon_shared.v1.0.0/ush/diag2grad_ps_case.sh -./nwprod/cmon_shared.v1.0.0/ush/time_vert.sh -./nwprod/cmon_shared.v1.0.0/ush/horz_hist.sh -./nwprod/cmon_shared.v1.0.0/ush/diag2grad_q_case.sh -./nwprod/cmon_shared.v1.0.0/ush/diag2grad_t_case.sh -./nwprod/cmon_shared.v1.0.0/ush/g2ctl.pl -./nwprod/cmon_shared.v1.0.0/sorc -./nwprod/cmon_shared.v1.0.0/sorc/read_pw -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/read_pw_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/makefile.read_pw -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/read_pw.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/mainread_pw.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_pw/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/maingrads_mandlev.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/makefile.grads_mandlev -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/grads_mandlev.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/grads_sfc.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/makefile.grads_sfc -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/maingrads_sfc.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t -./nwprod/cmon_shared.v1.0.0/sorc/read_t/read_t_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/mainread_t.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/read_t.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_t/makefile.read_t -./nwprod/cmon_shared.v1.0.0/sorc/read_t/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/read_uv_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/mainread_uv.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/read_uv.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/makefile.read_uv -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/histgramuv.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_uv/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/read_ps.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/makefile.read_ps -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/mainread_ps.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/read_ps_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_ps/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q -./nwprod/cmon_shared.v1.0.0/sorc/read_q/mainread_q.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/read_q_mor.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/read_q.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/read_q/makefile.read_q -./nwprod/cmon_shared.v1.0.0/sorc/read_q/histgram.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/makefile.grads_sig -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/maingrads_sig.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sig/grads_sig.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/makefile.grads_lev -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/maingrads_lev.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_lev/grads_lev.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/generic_list.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/maingrads_sfctime.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/rm_dups.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/data_mod.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/read_conv2grads.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/grads_sfctime.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/convinfo.f90 -./nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/makefile.grads_sfctime -./nwprod/cmon_shared.v1.0.0/sorc/conv_time -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/stas2ctl.f90 -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/stas_time.f90 -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/convinfo2.f90 -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/read_conv.f90 -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/makefile.conv_time -./nwprod/cmon_shared.v1.0.0/sorc/conv_time/mainconv_time.f90 -./nwprod/cmon_shared.v1.0.0/exec -./nwprod/gdas_cmon.v1.0.0 -./nwprod/gdas_cmon.v1.0.0/scripts -./nwprod/gdas_cmon.v1.0.0/scripts/exgdas_vrfyconv.sh.ecf -./nwprod/gdas_cmon.v1.0.0/driver -./nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_ibm.sh -./nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_theia.sh -./nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_cray.sh -./nwprod/gdas_cmon.v1.0.0/jobs -./nwprod/gdas_cmon.v1.0.0/jobs/JGDAS_VCMON -./nwprod/gdas_cmon.v1.0.0/fix -./nwprod/gdas_cmon.v1.0.0/fix/global_convinfo.txt -./parm -./parm/CMon_config -./parm/CMon.ver -./parm/CMon_user_settings -./data_extract -./data_extract/ush -./data_extract/ush/find_cycle.pl -./data_extract/ush/onprod.sh -./data_extract/ush/CMon_DE.sh -./data_extract/ush/RunCMonDE.sh -./image_gen -./image_gen/gscripts -./image_gen/gscripts/plot_uvsatwind_horz.gs -./image_gen/gscripts/plotstas_time_bias2_ps.gs -./image_gen/gscripts/rgbset2.gs -./image_gen/gscripts/page.gs -./image_gen/gscripts/plot_pw_horz.gs -./image_gen/gscripts/plot_qallev_horz.gs -./image_gen/gscripts/plotstas_time_bias2.gs -./image_gen/gscripts/test.gs -./image_gen/gscripts/plotstas_vert_bias2.gs -./image_gen/gscripts/plotstas_vert_bias.gs -./image_gen/gscripts/plot_tallev_horz.gs -./image_gen/gscripts/plot_uvsfc_horz.gs -./image_gen/gscripts/plotstas_time_ps.gs -./image_gen/gscripts/setvpage.gs -./image_gen/gscripts/plotstas_time_bias_ps.gs -./image_gen/gscripts/plot_ps_horz.gs -./image_gen/gscripts/plotstas_time_bias.gs -./image_gen/gscripts/plot_hist.gs -./image_gen/gscripts/plot_qsfc_horz.gs -./image_gen/gscripts/plot_uvallev_horz.gs -./image_gen/gscripts/plotstas_time_bias_pw.gs -./image_gen/gscripts/setupmap.gs -./image_gen/gscripts/plot_tflex_horz.gs -./image_gen/gscripts/plotstas_vert_count.gs -./image_gen/gscripts/plotstas_time_count_ps.gs -./image_gen/gscripts/plot_tsfc_horz.gs -./image_gen/gscripts/plotstas_time_count.gs -./image_gen/gscripts/defint.gs -./image_gen/gscripts/plotstas_time_pw.gs -./image_gen/ush -./image_gen/ush/plot_vert.sh -./image_gen/ush/find_cycle.pl -./image_gen/ush/Transfer.sh -./image_gen/ush/make_tdef.sh -./image_gen/ush/plot_time_ps.sh -./image_gen/ush/run_transfer_gdas.sh -./image_gen/ush/plot_horz.sh -./image_gen/ush/run_plot_gdas.sh -./image_gen/ush/grib2ctl.pl -./image_gen/ush/plot_time.sh -./image_gen/ush/onprod.sh -./image_gen/ush/CMon_IG.sh -./image_gen/ush/make_timesers_ctl.sh -./image_gen/ush/plot_horz_uv.sh -./image_gen/ush/read_scatter.sh -./image_gen/ush/mk_horz_hist.sh -./image_gen/ush/plot_hist.sh -./image_gen/ush/g2ctl.pl -./image_gen/ush/mk_time_vert.sh -./image_gen/sorc -./image_gen/sorc/read_pw -./image_gen/sorc/read_pw/rm_dups.f90 -./image_gen/sorc/read_pw/read_pw_mor.f90 -./image_gen/sorc/read_pw/makefile.read_pw -./image_gen/sorc/read_pw/convinfo.f90 -./image_gen/sorc/read_pw/read_pw.f90 -./image_gen/sorc/read_pw/mainread_pw.f90 -./image_gen/sorc/read_pw/histgram.f90 -./image_gen/sorc/read_t -./image_gen/sorc/read_t/read_t_mor.f90 -./image_gen/sorc/read_t/mainread_t.f90 -./image_gen/sorc/read_t/rm_dups.f90 -./image_gen/sorc/read_t/convinfo.f90 -./image_gen/sorc/read_t/read_t.f90 -./image_gen/sorc/read_t/makefile.read_t -./image_gen/sorc/read_t/histgram.f90 -./image_gen/sorc/read_uv -./image_gen/sorc/read_uv/read_uv_mor.f90 -./image_gen/sorc/read_uv/mainread_uv.f90 -./image_gen/sorc/read_uv/read_uv.f90 -./image_gen/sorc/read_uv/rm_dups.f90 -./image_gen/sorc/read_uv/makefile.read_uv -./image_gen/sorc/read_uv/histgramuv.f90 -./image_gen/sorc/read_uv/convinfo.f90 -./image_gen/sorc/read_uv/histgram.f90 -./image_gen/sorc/read_ps -./image_gen/sorc/read_ps/read_ps.f90 -./image_gen/sorc/read_ps/makefile.read_ps -./image_gen/sorc/read_ps/rm_dups.f90 -./image_gen/sorc/read_ps/mainread_ps.f90 -./image_gen/sorc/read_ps/convinfo.f90 -./image_gen/sorc/read_ps/read_ps_mor.f90 -./image_gen/sorc/read_ps/histgram.f90 -./image_gen/sorc/read_q -./image_gen/sorc/read_q/mainread_q.f90 -./image_gen/sorc/read_q/rm_dups.f90 -./image_gen/sorc/read_q/read_q_mor.f90 -./image_gen/sorc/read_q/read_q.f90 -./image_gen/sorc/read_q/convinfo.f90 -./image_gen/sorc/read_q/makefile.read_q -./image_gen/sorc/read_q/histgram.f90 -./image_gen/exec -./image_gen/fix -./image_gen/fix/uvsfc7.ctl -./image_gen/fix/uvmandlev.ctl -./image_gen/fix/hist_ps.ctl -./image_gen/fix/uvsfc11.ctl -./image_gen/fix/qsfc.ctl -./image_gen/fix/hist_uv.ctl -./image_gen/fix/uvallev.ctl -./image_gen/fix/tmandlev.ctl -./image_gen/fix/qmandlev.ctl -./image_gen/fix/tsfc.ctl -./image_gen/fix/uvsig.ctl -./image_gen/fix/qallev.ctl -./image_gen/fix/pssfc.ctl -./image_gen/fix/tallev.ctl -./image_gen/fix/pstime.ctl -./image_gen/fix/hist_q.ctl -./image_gen/fix/hist_t.ctl -./image_gen/html -./image_gen/html/index.html -./image_gen/html/vertbody.html -./image_gen/html/menu_hist.html -./image_gen/html/menu_vert.html -./image_gen/html/horzbody.html -./image_gen/html/histbody.html -./image_gen/html/intro_time.html -./image_gen/html/intro_vert.html -./image_gen/html/index_vert.html -./image_gen/html/CMon_Install_html.sh -./image_gen/html/intro_horz.html -./image_gen/html/surf_timebody.html -./image_gen/html/menu_time.html -./image_gen/html/index_hist.html -./image_gen/html/index_horz.html -./image_gen/html/index_time.html -./image_gen/html/timebody.html -./image_gen/html/menu_horz.html -./image_gen/html/surf_horzbody.html -./image_gen/html/intro_hist.html diff --git a/util/Conventional_Monitor/makeall.sh b/util/Conventional_Monitor/makeall.sh index c582441a4..535dd0a0b 100755 --- a/util/Conventional_Monitor/makeall.sh +++ b/util/Conventional_Monitor/makeall.sh @@ -15,7 +15,7 @@ mode=${1:-all} top_level=`pwd` -cmon_version_file=${cmon_version_file:-${top_level}/parm/CMon.ver} +cmon_version_file=${cmon_version_file:-${top_level}/parm/ConMon.ver} if [[ -s ${cmon_version_file} ]]; then . ${cmon_version_file} echo "able to source ${cmon_version_file}" diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/exec/.gitignore b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/exec/.gitignore new file mode 100644 index 000000000..d6b7ef32c --- /dev/null +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/exec/.gitignore @@ -0,0 +1,2 @@ +* +!.gitignore diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/conv_time/convinfo2.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/conv_time/convinfo2.f90 index 06fbf2dbc..3eaf42a8c 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/conv_time/convinfo2.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/conv_time/convinfo2.f90 @@ -1,9 +1,9 @@ ! the subroutine to read convention information file -subroutine convinfo(iotype_ps,iotype_q,iotype_t,iotype_uv,ntype_ps,& - ntype_q,ntype_t,ntype_uv,varqc_ps,varqc_q,varqc_t,varqc_uv,& - ituse_ps,ituse_q,ituse_t,ituse_uv,& - iosubtype_ps,iosubtype_q,iosubtype_t,iosubtype_uv) + subroutine convinfo(iotype_ps,iotype_q,iotype_t,iotype_uv,ntype_ps,& + ntype_q,ntype_t,ntype_uv,varqc_ps,varqc_q,varqc_t,varqc_uv,& + ituse_ps,ituse_q,ituse_t,ituse_uv,& + iosubtype_ps,iosubtype_q,iosubtype_t,iosubtype_uv) implicit none @@ -13,9 +13,8 @@ subroutine convinfo(iotype_ps,iotype_q,iotype_t,iotype_uv,ntype_ps,& real(4),dimension(100,2) :: varqc_ps,varqc_q,varqc_t,varqc_uv integer ittype,ituse,ntumgrp,ntgroup,ntmiter,isubtype - integer lunin,ntype_ps,ntype_q,ntype_t,ntype_uv,ithin,npred - real(8) :: ttwind,gtross,etrmax,etrmin,vtar_b,vtar_pg,rmesh,pmesh - integer iflag + integer lunin,ntype_ps,ntype_q,ntype_t,ntype_uv,iflag + real(8) :: ttwind,gtross,etrmax,etrmin,vtar_b,vtar_pg character(120):: crecord character(7) :: ctype @@ -48,19 +47,21 @@ subroutine convinfo(iotype_ps,iotype_q,iotype_t,iotype_uv,ntype_ps,& loopd: do read(lunin,1030,IOSTAT=iflag)cflg,ctype,crecord if(cflg == '!')cycle + if( iflag /= 0 ) exit loopd read(crecord,*)ittype,isubtype,ituse,ttwind,ntumgrp,ntgroup,ntmiter,& - gtross,etrmax,etrmin,vtar_b,vtar_pg,ithin,rmesh,pmesh,npred -! print *,cflg,ctype,ittype,isubtype,ituse,ntype_ps,ntype_q,ntype_t,ntype_uv + gtross,etrmax,etrmin,vtar_b,vtar_pg + if(trim(ctype) == 'ps' ) then ntype_ps=ntype_ps+1 -! print *,ntype_ps iotype_ps(ntype_ps)=ittype iosubtype_ps(ntype_ps)=isubtype + varqc_ps(ntype_ps,1)=vtar_b varqc_ps(ntype_ps,2)=vtar_pg ituse_ps(ntype_ps)=ituse + else if(trim(ctype) == 'q') then ntype_q=ntype_q+1 iotype_q(ntype_q)=ittype @@ -68,25 +69,31 @@ subroutine convinfo(iotype_ps,iotype_q,iotype_t,iotype_uv,ntype_ps,& varqc_q(ntype_q,1)=vtar_b varqc_q(ntype_q,2)=vtar_pg ituse_q(ntype_q)=ituse + else if(trim(ctype) == 't') then ntype_t=ntype_t+1 iotype_t(ntype_t)=ittype iosubtype_t(ntype_t)=isubtype + varqc_t(ntype_t,1)=vtar_b varqc_t(ntype_t,2)=vtar_pg ituse_t(ntype_t)=ituse -! print *, 'ctype, ntype_t, iotype_t(ntype_t), iosubtype_t(ntype_t), ituse_t = ', ctype, ntype_t, iotype_t(ntype_t), iosubtype_t(ntype_t), ituse_t(ntype_t) + else if(trim(ctype) == 'uv') then ntype_uv=ntype_uv+1 iotype_uv(ntype_uv)=ittype iosubtype_uv(ntype_uv)=isubtype + varqc_uv(ntype_uv,1)=vtar_b varqc_uv(ntype_uv,2)=vtar_pg ituse_uv(ntype_uv)=ituse + endif + enddo loopd 1030 format(a1,a7,2x,a120) return + end diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/conv_time/read_conv.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/conv_time/read_conv.f90 index 3ed106888..026163bfb 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/conv_time/read_conv.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/conv_time/read_conv.f90 @@ -33,7 +33,7 @@ subroutine read_conv(filein,mregion,nregion,np,ptop,pbot,ptopq,pbotq,& integer nchar,nreal,ii,mype,idate,iflag,itype integer lunin,lunot,nreal1,nreal2,ldtype,intype integer ilat,ilon,ipress,iqc,iuse,imuse,iwgt,ierr1 - integer ierr2,ierr3,ipsobs,iqobs + integer ierr2,ierr3,ipsobs,iqobs,ioff02 integer i,j,k,np,nregion,ltype,iregion,ntype_uv integer iobg,iobgu,iobgv,ntype_ps,ntype_q,ntype_t @@ -62,7 +62,7 @@ subroutine read_conv(filein,mregion,nregion,np,ptop,pbot,ptopq,pbotq,& print *,pbot(1),pbot(5) loopd: do - read(lunin,IOSTAT=iflag) dtype,nchar,nreal,ii,mype + read(lunin,IOSTAT=iflag) dtype,nchar,nreal,ii,mype,ioff02 if( iflag /= 0 ) exit loopd ! print *, dtype,nchar,nreal,ii,mype allocate(cdiag(ii),rdiag(nreal,ii)) diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/grads_lev.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/grads_lev.f90 index a1789d6a3..19a2277e4 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/grads_lev.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/grads_lev.f90 @@ -24,7 +24,7 @@ subroutine grads_lev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& character(8),allocatable,dimension(:) :: cdiag real(4),dimension(nlev) :: plev,plev2 character(8) :: stid - character(2) :: subtype + character(3) :: subtype character(ifileo) :: fileo character(30) :: files,filegrad diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/maingrads_lev.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/maingrads_lev.f90 index 6b36c12f0..982ad1733 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/maingrads_lev.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/maingrads_lev.f90 @@ -24,7 +24,7 @@ subroutine read_conv2grads(ctype,stype,itype,nreal,nobs,isubtype,subtype,list) integer :: nreal integer :: nobs integer :: isubtype - character(2) :: subtype + character(3) :: subtype type(list_node_t),pointer :: list end subroutine read_conv2grads @@ -39,7 +39,7 @@ subroutine grads_lev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads, & real(4),dimension(nlev) :: plev character(10) :: levcard real*4 :: hint - character(2) subtype + character(3) :: subtype type(list_node_t), pointer :: list end subroutine grads_lev @@ -52,7 +52,7 @@ end subroutine grads_lev real(4),dimension(10) :: palllev character(10) :: levcard,fileo,stype character(3) :: intype - character(2) :: subtype + character(3) :: subtype integer nreal,iscater,igrads integer n_alllev,n_acft,n_lowlev,n_upair,nobs,lstype,intv,isubtype real hint @@ -73,6 +73,7 @@ end subroutine grads_lev + write(6,*) '----> BEGIN maingrads_lev' read(5,input) write(6,*)' User input:' write(6,input) @@ -103,6 +104,7 @@ end subroutine grads_lev end if call list_free( list ) + write(6,*) '<---- END maingrads_lev' stop end diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/read_conv2grads.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/read_conv2grads.f90 index 71ef192f6..3b7015650 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/read_conv2grads.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_lev/read_conv2grads.f90 @@ -28,18 +28,19 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype character(8),allocatable,dimension(:) :: cdiag character(3) :: dtype,ctype - character(2) :: subtype + character(3) :: subtype character(10) :: stype,otype character(15) :: fileo,fileo_subtyp integer nchar,file_nreal,i,ii,mype,idate,iflag,itype,iscater,igrads integer lunin,lunot,target_nreal,ldtype,intype,isubtype,jsubtype - integer nobs,idx + integer nobs,idx,ioff02 data lunin / 11 / nobs=0 print *, '--> read_conv2grads' + print *, ' itype, isubtype = ', itype, isubtype open(lunin,file='conv_diag',form='unformatted') rewind(lunin) @@ -49,7 +50,8 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype loopd: do - read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype + read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype,ioff02 +! print *, 'iflag from header read = ', iflag if( iflag /= 0 ) exit loopd if( trim(dtype) == trim(ctype) .and. file_nreal /= target_nreal ) then @@ -64,6 +66,7 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype allocate(cdiag(ii),rdiag(file_nreal,ii)) read(lunin,IOSTAT=iflag) cdiag,rdiag if( iflag /= 0 ) then +! print *, 'iflag from cdiag,rdiag read = ', iflag deallocate( cdiag,rdiag ) exit loopd end if @@ -72,16 +75,24 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype itype = int(rdiag(1,i)) jsubtype = int(rdiag(2,i)) -! print *, 'if itype == intype ', itype, intype -! print *, 'and jsubtype == isubtype ', itype, intype - - if(itype == intype .and. jsubtype ==isubtype) then + if( itype == intype .AND. itype == 245 ) then + print *, 'itype == intype ', itype, intype + print *, 'jsubtype == isubtype ', jsubtype, isubtype + end if + +! if( jsubtype == isubtype ) then +! print *, 'and jsubtype == isubtype ', itype, intype +! end if + + if(itype == intype .AND. jsubtype == isubtype) then +! if( itype == intype ) then nobs=nobs+1 !--------------------------------------------- ! Allocate a new data element and load ! ! print *, 'Allocating new data element' + allocate(ptr%p) ptr%p%stn_id = cdiag(i) do idx=1,max_rdiag_reals diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/grads_mandlev.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/grads_mandlev.f90 index d2d5626f8..169411a25 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/grads_mandlev.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/grads_mandlev.f90 @@ -26,7 +26,7 @@ subroutine grads_mandlev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& real(4),dimension(nlev) :: plev real(4) rlat,rlon,rp - character(2) subtype + character(3) subtype character(8) stid character(ifileo) :: fileo character(30) :: files,filegrads diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/maingrads_mandlev.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/maingrads_mandlev.f90 index 9187f5d7f..ebaac17d1 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/maingrads_mandlev.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/maingrads_mandlev.f90 @@ -22,7 +22,7 @@ subroutine read_conv2grads(ctype,stype,itype,nreal,nobs,isubtype,subtype,list) integer :: nreal integer :: nobs integer :: isubtype - character(2) :: subtype + character(3) :: subtype type(list_node_t),pointer :: list end subroutine read_conv2grads @@ -37,7 +37,7 @@ subroutine grads_mandlev(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,& integer :: nobs,nreal,nlev integer :: iscater,igrads,isubtype real(4),dimension(nlev) :: plev - character(2) :: subtype + character(3) :: subtype type(list_node_t), pointer :: list end subroutine grads_mandlev @@ -47,7 +47,7 @@ end subroutine grads_mandlev real(4),dimension(13) :: pmand character(10) :: fileo,stype character(3) :: intype - character(2) :: subtype + character(3) :: subtype integer nreal,nreal_m2,iscater,igrads,isubtype,itype integer n_alllev,n_acft,n_lowlev,n_upair,nobs,lstype diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/read_conv2grads.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/read_conv2grads.f90 index 19ff5762a..8d2bb1d2a 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/read_conv2grads.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_mandlev/read_conv2grads.f90 @@ -28,13 +28,13 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype character(8),allocatable,dimension(:) :: cdiag character(3) :: dtype,ctype - character(2) :: subtype + character(3) :: subtype character(10) :: stype,otype character(15) :: fileo,fileo_subtyp integer nchar,file_nreal,i,ii,mype,idate,iflag,itype,iscater,igrads integer lunin,lunot,target_nreal,ldtype,intype,isubtype,jsubtype - integer nobs,idx + integer nobs,idx,ioff02 data lunin / 11 / @@ -49,7 +49,7 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype loopd: do - read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype + read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype,ioff02 if( iflag /= 0 ) exit loopd if( trim(dtype) == trim(ctype) .and. file_nreal /= target_nreal ) then diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/grads_sfc.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/grads_sfc.f90 index ef0b9a93b..bc03f7006 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/grads_sfc.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/grads_sfc.f90 @@ -22,7 +22,7 @@ subroutine grads_sfc(fileo,ifileo,nobs,nreal,iscater,igrads,isubtype,subtype,lis character(8) :: stid character(ifileo) :: fileo character(30) :: files,filein,filegrads - character(2) :: subtype + character(3) :: subtype integer nobs,nreal,nlfag,nflg0,nlev,nlev0,iscater,igrads real(4) rtim,xlat0,xlon0,rlat,rlon @@ -40,7 +40,6 @@ subroutine grads_sfc(fileo,ifileo,nobs,nreal,iscater,igrads,isubtype,subtype,lis print *, 'nobs=',nobs print *, 'fileo=',fileo -! write(subtype,'(i2)') isubtype filein=trim(fileo)//'_'//trim(subtype)//'.tmp' allocate(cdiag(nobs)) diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/maingrads_sfc.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/maingrads_sfc.f90 index 5a2470894..d1a6d6277 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/maingrads_sfc.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/maingrads_sfc.f90 @@ -22,7 +22,7 @@ subroutine read_conv2grads(ctype,stype,itype,nreal,nobs,isubtype,subtype,list) integer :: nreal integer :: nobs integer :: isubtype - character(2) :: subtype + character(3) :: subtype type(list_node_t),pointer :: list end subroutine read_conv2grads @@ -34,7 +34,7 @@ subroutine grads_sfc(fileo,ifileo,nobs,nreal,iscater,igrads,& integer ifileo character(ifileo) :: fileo integer :: nobs,nreal,iscater,igrads,isubtype - character(2) :: subtype + character(3) :: subtype type(list_node_t), pointer :: list end subroutine grads_sfc @@ -43,7 +43,7 @@ end subroutine grads_sfc real(4),dimension(21) :: pmand character(10) :: fileo,stype character(3) :: intype - character(2) :: subtype + character(3) :: subtype integer nreal,nreal_m2,iscater,igrads,isubtype integer n_alllev,n_acft,n_lowlev,n_upair,nobs,lstype integer n_mand,itype diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/read_conv2grads.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/read_conv2grads.f90 index 19ff5762a..8d2bb1d2a 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/read_conv2grads.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfc/read_conv2grads.f90 @@ -28,13 +28,13 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype character(8),allocatable,dimension(:) :: cdiag character(3) :: dtype,ctype - character(2) :: subtype + character(3) :: subtype character(10) :: stype,otype character(15) :: fileo,fileo_subtyp integer nchar,file_nreal,i,ii,mype,idate,iflag,itype,iscater,igrads integer lunin,lunot,target_nreal,ldtype,intype,isubtype,jsubtype - integer nobs,idx + integer nobs,idx,ioff02 data lunin / 11 / @@ -49,7 +49,7 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype loopd: do - read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype + read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype,ioff02 if( iflag /= 0 ) exit loopd if( trim(dtype) == trim(ctype) .and. file_nreal /= target_nreal ) then diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/grads_sfctime.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/grads_sfctime.f90 index 7a2c0c931..b6caa99bf 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/grads_sfctime.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/grads_sfctime.f90 @@ -47,7 +47,7 @@ subroutine grads_sfctime(fileo,ifileo,nobs,nreal,nlev,plev,iscater,& character(8) :: stidend character(ifileo) :: fileo - character(2) :: subtype + character(3) :: subtype character(30) :: files,filein,filegrads integer :: nobs,nreal,nlfag,nflag0,nlev,nlev0,getlev,iscater,igrads real(4) :: rmiss,rtim,xlat0,xlon0,rtime diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/maingrads_sfctime.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/maingrads_sfctime.f90 index c8275009e..7be2f9d2d 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/maingrads_sfctime.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/maingrads_sfctime.f90 @@ -24,7 +24,7 @@ subroutine read_conv2grads(ctype,stype,itype,nreal,nobs,& integer :: nreal integer :: nobs integer :: isubtype - character(2) :: subtype + character(3) :: subtype type(list_node_t),pointer :: list end subroutine read_conv2grads @@ -37,7 +37,7 @@ subroutine grads_sfctime(fileo,ifileo,nobs,nreal,& integer :: ifileo,nobs,nreal,nlev real(4),dimension(nlev) :: plev integer :: iscater,igrdas,isubtype - character(2) :: subtype + character(3) :: subtype type(list_node_t),pointer :: list end subroutine grads_sfctime @@ -53,7 +53,7 @@ end subroutine grads_sfctime real(4),dimension(7) :: ptime7 character(10) :: fileo,stype,timecard character(3) :: intype - character(2) :: subtype + character(3) :: subtype integer nreal,iscater,igrads,isubtype integer nobs,lstype integer n_time7,n_time11,itype diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/read_conv2grads.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/read_conv2grads.f90 index 19ff5762a..8d2bb1d2a 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/read_conv2grads.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sfctime/read_conv2grads.f90 @@ -28,13 +28,13 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype character(8),allocatable,dimension(:) :: cdiag character(3) :: dtype,ctype - character(2) :: subtype + character(3) :: subtype character(10) :: stype,otype character(15) :: fileo,fileo_subtyp integer nchar,file_nreal,i,ii,mype,idate,iflag,itype,iscater,igrads integer lunin,lunot,target_nreal,ldtype,intype,isubtype,jsubtype - integer nobs,idx + integer nobs,idx,ioff02 data lunin / 11 / @@ -49,7 +49,7 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype loopd: do - read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype + read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype,ioff02 if( iflag /= 0 ) exit loopd if( trim(dtype) == trim(ctype) .and. file_nreal /= target_nreal ) then diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/grads_sig.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/grads_sig.f90 index d4bc7b1fd..1561b1d3e 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/grads_sig.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/grads_sig.f90 @@ -22,7 +22,7 @@ subroutine grads_sig(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,isubtype,s real(4),dimension(nlev) :: plev real(4) :: rlat,rlon - character(2) subtype + character(3) subtype character(8) :: stidend,stdid character(ifileo) :: fileo character(30) :: files,filegrads diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/maingrads_sig.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/maingrads_sig.f90 index 906aadc57..528c6f0e0 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/maingrads_sig.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/maingrads_sig.f90 @@ -23,7 +23,7 @@ subroutine read_conv2grads(ctype,stype,itype,nreal,nobs,isubtype,subtype,list) integer :: nreal integer :: nobs integer :: isubtype - character(2) :: subtype + character(3) :: subtype type(list_node_t),pointer :: list end subroutine read_conv2grads @@ -36,7 +36,7 @@ subroutine grads_sig(fileo,ifileo,nobs,nreal,nlev,plev,iscater,igrads,isubtype, character(ifileo) :: fileo integer :: nobs,nreal,nlev,igrads,isubtype real(4),dimension(nlev) :: plev - character(2) subtype + character(3) subtype type(list_node_t), pointer :: list end subroutine grads_sig @@ -46,7 +46,7 @@ end subroutine grads_sig real(4),dimension(46) :: psig character(10) :: fileo,stype,time character(3) :: intype - character(2) :: subtype + character(3) :: subtype integer nreal,nreal_m2,iscater,igrads,isubtype integer n_alllev,n_acft,n_lowlev,n_upair,nobs,lstype integer itype,n_sig,ii diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/read_conv2grads.f90 b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/read_conv2grads.f90 index 19ff5762a..8d2bb1d2a 100644 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/read_conv2grads.f90 +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/sorc/grads_sig/read_conv2grads.f90 @@ -28,13 +28,13 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype character(8),allocatable,dimension(:) :: cdiag character(3) :: dtype,ctype - character(2) :: subtype + character(3) :: subtype character(10) :: stype,otype character(15) :: fileo,fileo_subtyp integer nchar,file_nreal,i,ii,mype,idate,iflag,itype,iscater,igrads integer lunin,lunot,target_nreal,ldtype,intype,isubtype,jsubtype - integer nobs,idx + integer nobs,idx,ioff02 data lunin / 11 / @@ -49,7 +49,7 @@ subroutine read_conv2grads(ctype,stype,intype,target_nreal,nobs,isubtype,subtype loopd: do - read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype + read(lunin,IOSTAT=iflag) dtype,nchar,file_nreal,ii,mype,ioff02 if( iflag /= 0 ) exit loopd if( trim(dtype) == trim(ctype) .and. file_nreal /= target_nreal ) then diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_q_case.sh b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_q_case.sh index 775556c47..cf281f77e 100755 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_q_case.sh +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_q_case.sh @@ -33,7 +33,7 @@ echo "--> diag2grad_q_case.sh" ctype=`echo ${mtype} | cut -c2-4` - if [ "$mtype" = 'q130' -o "$mtype" = 'q132' -o "$mtype" = 'q133' -o "$mtype" = 'q134' -o "$mtype" = 'q135' ]; then + if [ "$mtype" = 'q130' -o "$mtype" = 'q131' -o "$mtype" = 'q132' -o "$mtype" = 'q133' -o "$mtype" = 'q134' -o "$mtype" = 'q135' ]; then rm -f diag2grads cp ${EXECcmon}/grads_lev.x ./diag2grads # eval card=\${${mtype}_card} @@ -52,7 +52,7 @@ EOF iscater=1,igrads=1,subtype='${subtype}',isubtype=${subtype}, / EOF - elif [ "$mtype" = 'q180' -o "$mtype" = 'q181' -o "$mtype" = 'q183' -o "$mtype" = 'q187' ]; then + elif [ "$mtype" = 'q180' -o "$mtype" = 'q181' -o "$mtype" = 'q182' -o "$mtype" = 'q183' -o "$mtype" = 'q187' ]; then rm -f diag2grads cp ${EXECcmon}/grads_sfctime.x ./diag2grads cat <input diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_t_case.sh b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_t_case.sh index 5833e2e9a..c5de8473a 100755 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_t_case.sh +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_t_case.sh @@ -58,7 +58,7 @@ EOF / EOF - elif [ "$mtype" = 't180' -o "$mtype" = 't181' -o "$mtype" = 't183' -o "$mtype" = 't187' ]; then + elif [ "$mtype" = 't180' -o "$mtype" = 't181' -o "$mtype" = 't182' -o "$mtype" = 't183' -o "$mtype" = 't187' ]; then cp $EXECcmon/grads_sfc.x ./diag2grads cat <input &input diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_uv_case.sh b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_uv_case.sh index 605b91c61..5a81a6231 100755 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_uv_case.sh +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/diag2grad_uv_case.sh @@ -32,9 +32,9 @@ echo "mtype = ", ${mtype} ctype=`echo ${mtype} | cut -c3-5` -if [ "$mtype" = 'uv221' -o "$mtype" = 'uv230' -o "$mtype" = 'uv231' -o "$mtype" = 'uv232' -o "$mtype" = 'uv233' -o "$mtype" = 'uv234' -o "$mtype" = 'uv235' -o "$mtype" = 'uv242' -o "$mtype" = 'uv243' -o "$mtype" = 'uv245' -o "$mtype" = 'uv246' -o "$mtype" = 'uv247' -o "$mtype" = 'uv248' -o "$mtype" = 'uv249' -o "$mtype" = 'uv250' -o "$mtype" = 'uv251' -o "$mtype" = 'uv252' -o "$mtype" = 'uv253' -o "$mtype" = 'uv254' -o "$mtype" = 'uv255' -o "$mtype" = 'uv256' -o "$mtype" = 'uv257' -o "$mtype" = 'uv258' ]; then +if [ "$mtype" = 'uv221' -o "$mtype" = 'uv224' -o "$mtype" = 'uv229' -o "$mtype" = 'uv230' -o "$mtype" = 'uv231' -o "$mtype" = 'uv232' -o "$mtype" = 'uv233' -o "$mtype" = 'uv234' -o "$mtype" = 'uv235' -o "$mtype" = 'uv242' -o "$mtype" = 'uv243' -o "$mtype" = 'uv245' -o "$mtype" = 'uv246' -o "$mtype" = 'uv247' -o "$mtype" = 'uv248' -o "$mtype" = 'uv249' -o "$mtype" = 'uv250' -o "$mtype" = 'uv251' -o "$mtype" = 'uv252' -o "$mtype" = 'uv253' -o "$mtype" = 'uv254' -o "$mtype" = 'uv255' -o "$mtype" = 'uv256' -o "$mtype" = 'uv257' -o "$mtype" = 'uv258' ]; then - echo "IN if condition 1" + echo "IN if condition 1, using GRADS_LEV.X" rm -f diag2grads cp ${EXECcmon}/grads_lev.x ./diag2grads @@ -60,7 +60,7 @@ if [ "$mtype" = 'uv221' -o "$mtype" = 'uv230' -o "$mtype" = 'uv231' -o "$mtype" EOF elif [ "$mtype" = 'uv223' -o "$mtype" = 'uv224' -o "$mtype" = 'uv228' ]; then - echo "IN if condition 2" + echo "IN if condition 2, using GRADS_SIG.X" rm -f diag2grads cp ${EXECcmon}/grads_sig.x ./diag2grads @@ -85,7 +85,7 @@ elif [ "$mtype" = 'uv223' -o "$mtype" = 'uv224' -o "$mtype" = 'uv228' ]; then EOF elif [ "$mtype" = 'uv220' ]; then - echo "IN if condition 3" + echo "IN if condition 3, using GRADS_MANDLEV.X" rm -f diag2grads cp ${EXECcmon}/grads_mandlev.x ./diag2grads @@ -98,7 +98,7 @@ elif [ "$mtype" = 'uv220' ]; then EOF elif [ "$mtype" = 'uv280' -o "$mtype" = 'uv281' -o "$mtype" = 'uv282' -o "$mtype" = 'uv284' -o "$mtype" = 'uv287' ]; then - echo "IN if condition 4" + echo "IN if condition 4, using GRADS_SFCTIME.X" rm -f diag2grads cp ${EXECcmon}/grads_sfctime.x ./diag2grads @@ -111,7 +111,7 @@ elif [ "$mtype" = 'uv280' -o "$mtype" = 'uv281' -o "$mtype" = 'uv282' -o "$mtype EOF elif [ "$mtype" = 'uv229' ]; then - echo "IN if condition 5" + echo "IN if condition 5, using GRADS_SFCTIME.X" rm -f diag2grads cp ${EXECcmon}/grads_sfctime.x ./diag2grads rm -f input @@ -144,11 +144,13 @@ mv stdout stdout_diag2grads_${mtype}_${subtype}.${cycle} dest_dir="${TANKDIR_cmon}/horz_hist/${cycle}" -for file in uv*grads; do +grads_list=`ls uv*grads` +for file in $grads_list; do mv ${file} ${dest_dir}/${file}.${PDATE} done -for file in uv*scater; do +scatter_list=`ls uv*scater` +for file in $scatter_list; do mv ${file} ${dest_dir}/${file}.${PDATE} done diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/get_typelist.pl b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/get_typelist.pl new file mode 100755 index 000000000..ea24c3fb8 --- /dev/null +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/get_typelist.pl @@ -0,0 +1,74 @@ +#! /usr/bin/perl + + +#------------------------------------------------------------------------ +# get_typelist.pl +# +# Given a conventional data type and a convinfo.txt +# file return a list of types and subtypes in the order +# of [type id]_[subtype]. +# +# Arguments: +# --file Required: convinfo.txt formatted file +# --type Required: conventional data type +# --mon Optional: include monitored data (if not +# specified only assimilated data types/subtypes +# will be returned +# +# +#------------------------------------------------------------------------ + + use strict; + use warnings; + use Getopt::Long; + + +# print "--> Begin get_typelist.pl\n"; + + my $convfile = ''; + my $type = ''; + my $use_mon = '0'; + + GetOptions( 'file:s' => \$convfile, + 'type:s' => \$type, + 'mon!' => \$use_mon); + +# print "Options: \n"; +# print " convfile = $convfile \n"; +# print " type = $type \n"; +# print " use_mon = $use_mon \n"; + + + my @results; + + open my $info, $convfile or die "Could not open $convfile: $!"; + + + #---------------------------------------------------------------- + # for each line split on white space, then check for a match on + # field 1 (type). If that matches and $use_mon is set to 1 or + # if field 3 (iuse flag) is 1 then format the subtype value and + # pack them together into a single string in the results array + #---------------------------------------------------------------- + while( my $line = <$info>) { + my @ln = split ' ', $line; + + if( $ln[0] eq $type ){ + + if( $use_mon == 1 || $ln[3] == 1 ){ + my $typenum = $ln[1]; + my $subtypenum = $ln[2]; + + if( length( $ln[2] ) < 2 ){ + $subtypenum = sprintf( "%02d", $ln[2] ); + } + my $entry = "${type}${typenum}_${subtypenum}"; + push @results, $entry; + } + } + } + close $info; + + print "@results"; + +# print "<-- End get_typelist.pl\n"; diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/horz_hist.sh b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/horz_hist.sh index 2817091f3..9bc87a2ce 100755 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/horz_hist.sh +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/horz_hist.sh @@ -18,10 +18,19 @@ #---------------------------------------------------------- # The list of data type, based on convinfo.txt file #---------------------------------------------------------- - ps_TYPE=" ps120_00 ps180_00 ps181_00 ps183_00 ps187_00 " - q_TYPE=" q120_00 q130_00 q132_00 q133_00 q134_00 q135_00 q180_00 q181_00 q183_00 q187_00 " - t_TYPE=" t120_00 t130_00 t131_00 t132_00 t133_00 t134_00 t135_00 t180_00 t181_00 t183_00 t187_00 " - uv_TYPE=" uv220_00 uv221_00 uv223_00 uv224_00 uv228_00 uv229_00 uv230_00 uv231_00 uv232_00 uv233_00 uv234_00 uv235_00 uv242_00 uv243_00 uv243_55 uv243_56 uv245_00 uv245_15 uv246_00 uv246_15 uv247_00 uv248_00 uv249_00 uv250_00 uv251_00 uv252_00 uv253_00 uv253_55 uv253_56 uv254_00 uv254_55 uv254_56 uv255_00 uv256_00 uv257_00 uv258_00 uv280_00 uv281_00 uv282_00 uv284_00 uv287_00" +# ps_TYPE=" ps120_00 ps180_00 ps181_00 ps183_00 ps187_00 " + ps_TYPE=`${USHcmon}/get_typelist.pl --file $convinfo --type ps --mon` + +# q_TYPE=" q120_00 q130_00 q132_00 q133_00 q134_00 q135_00 q180_00 q181_00 q183_00 q187_00 " + q_TYPE=`${USHcmon}/get_typelist.pl --file $convinfo --type q --mon` + +# t_TYPE=" t120_00 t130_00 t131_00 t132_00 t133_00 t134_00 t135_00 t180_00 t181_00 t183_00 t187_00 " + t_TYPE=`${USHcmon}/get_typelist.pl --file $convinfo --type t --mon` + +# uv_TYPE=" uv220_00 uv221_00 uv223_00 uv224_00 uv228_00 uv229_00 uv230_00 uv231_00 uv232_00 uv233_00 uv234_00 uv235_00 uv242_00 uv243_00 uv243_55 uv243_56 uv245_257 uv245_259 uv245_270 uv246_257 uv246_259 uv246_270 uv247_257 uv247_259 uv247_270 uv248_00 uv249_00 uv250_00 uv251_00 uv252_00 uv253_00 uv253_55 uv253_56 uv254_00 uv254_55 uv254_56 uv255_00 uv256_00 uv257_00 uv258_00 uv280_00 uv281_00 uv282_00 uv284_00 uv287_00" + + uv_TYPE=`${USHcmon}/get_typelist.pl --file $convinfo --type uv --mon` +# echo "uv_TYPE = $uv_TYPE" echo TANKDIR_cmon = $TANKDIR_cmon @@ -47,8 +56,8 @@ for dtype in ${stype}; do - mtype=`echo ${dtype} | cut -f1 -d_` - subtype=`echo ${dtype} | cut -f2 -d_` + mtype=`echo ${dtype} | cut -f1 -d_ | xargs` + subtype=`echo ${dtype} | cut -f2 -d_ | xargs` if [[ "$VERBOSE" = "YES" ]]; then echo "DEBUG: dtype = $dtype" diff --git a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/time_vert.sh b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/time_vert.sh index aba23b32d..b92660f1d 100755 --- a/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/time_vert.sh +++ b/util/Conventional_Monitor/nwprod/cmon_shared.v1.0.0/ush/time_vert.sh @@ -25,6 +25,7 @@ mkdir -p ${savedir} echo "convinfo = $convinfo" # defined in calling script +cp ${convinfo} ./convinfo export execfile=${EXECcmon}/conv_time.x cp ${execfile} ./execfile @@ -59,22 +60,11 @@ for cycle in ges anl;do EOF - ./execfile stdout 2>&1 + ./execfile ${cycle}_stdout 2>&1 echo " after execfile completed " - # ---------------------------------- - # pack stdout into 2 common files - # - if [[ ! -e ${cycle}_stdout ]]; then - mv stdout ${cycle}_stdout - else - cat stdout >> ${cycle}_stdout - rm -f stdout - fi - - cp uv_stas.ctl u_stas.ctl cp uv_stas.ctl v_stas.ctl diff --git a/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_ibm.sh b/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_ibm.sh index afe0dabe4..942740b64 100755 --- a/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_ibm.sh +++ b/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_ibm.sh @@ -6,14 +6,14 @@ #BSUB -q dev_shared #BSUB -n 1 #BSUB -R affinity[core] -#BSUB -M 80 -#BSUB -W 00:15 +#BSUB -M 160 +#BSUB -W 00:30 #BSUB -a poe #BSUB -P GFS-T2O set -x -export PDATE=${PDATE:-2017030600} +export PDATE=${PDATE:-2018041200} ############################################################# @@ -58,7 +58,8 @@ export POE=YES # Set user specific variables ############################################################# export CMON_SUFFIX=${CMON_SUFFIX:-testcmon} -export NWTEST=${NWTEST:-/gpfs/${ihost}d2/emc/da/noscrub/Edward.Safford/CMon_486/util/Conventional_Monitor/nwprod} +#export NWTEST=${NWTEST:-/gpfs/${ihost}d2/emc/da/noscrub/Edward.Safford/CMon_486/util/Conventional_Monitor/nwprod} +export NWTEST=${NWTEST:-/ptmpp1/Edward.Safford/ProdGSI/util/Conventional_Monitor/nwprod} export HOMEgdascmon=${HOMEgdascmon:-${NWTEST}/gdas_cmon.${gdas_cmon_ver}} export JOBGLOBAL=${JOBGLOBAL:-${HOMEgdascmon}/jobs} export HOMEcmon=${HOMEcmon:-${NWTEST}/cmon_shared.${cmon_shared_ver}} diff --git a/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_theia.sh b/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_theia.sh index 542a7944e..581d5e371 100755 --- a/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_theia.sh +++ b/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/driver/test_jgdas_vcmon_theia.sh @@ -1,15 +1,21 @@ #!/bin/ksh -#PBS -o gdas_vcmon.log -#PBS -e gdas_vcmon.err -#PBS -N gdas_vcmon -#PBS -A fv3-cpu -#PBS -l procs=1,walltime=0:15:00 -#PBS -V +#SBATCH -o %x.log +#SBATCH -J gdas_vcmon +#SBATCH --time=00:15:00 +#SBATCH --ntasks=1 -p service --mem=4g +#SBATCH -A fv3-cpu + +##PBS -o gdas_vcmon.log +##PBS -e gdas_vcmon.err +##PBS -N gdas_vcmon +##PBS -A fv3-cpu +##PBS -l procs=1,walltime=0:15:00 +##PBS -V set -x -export PDATE=${PDATE:-2017030606} +export PDATE=${PDATE:-2018070412} ############################################################# # Specify whether the run is production or development @@ -27,8 +33,8 @@ export COMROOT=${COMROOT:-/scratch4/NCEPDEV/stmp3/$LOGNAME/com} ############################################################# # Specify versions ############################################################# -export gdas_ver=v14.1.0 -export global_shared_ver=v14.1.0 +#export gdas_ver=v14.1.0 +#export global_shared_ver=v14.1.0 export gdas_cmon_ver=v1.0.0 export cmon_shared_ver=v1.0.0 @@ -46,7 +52,8 @@ export PATH=${PATH}:${NWPRODush}:${NWPRODexec} # Set user specific variables ############################################################# export CMON_SUFFIX=${CMON_SUFFIX:-testcmon} -export NWTEST=${NWTEST:-/scratch4/NCEPDEV/da/noscrub/${LOGNAME}/CMon_486/util/Conventional_Monitor/nwprod} +#export NWTEST=${NWTEST:-/scratch4/NCEPDEV/da/noscrub/${LOGNAME}/CMon_486/util/Conventional_Monitor/nwprod} +export NWTEST=${NWTEST:-/scratch4/NCEPDEV/da/noscrub/${LOGNAME}/ProdGSI/util/Conventional_Monitor/nwprod} export HOMEgdascmon=${HOMEgdascmon:-${NWTEST}/gdas_cmon.${gdas_cmon_ver}} export JOBGLOBAL=${JOBGLOBAL:-${HOMEgdascmon}/jobs} export HOMEcmon=${HOMEcmon:-${NWTEST}/cmon_shared.${cmon_shared_ver}} diff --git a/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/fix/global_convinfo.txt b/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/fix/global_convinfo.txt index 5fbc2e1ae..4221eb15e 100755 --- a/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/fix/global_convinfo.txt +++ b/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/fix/global_convinfo.txt @@ -14,146 +14,197 @@ ! ermin = gross error parameter - min error ! var_b = variational quality control parameter - b parameter ! var_pg ithin rmesh npred = variational quality control parameter - pg parameter -!otype type sub iuse twindow numgrp ngroup nmiter gross ermax ermin var_b var_pg ithin rmesh pmesh npred - tcp 112 0 1 3.0 0 0 0 75.0 5.0 1.0 75.0 0.000000 0 0. 0. 0 - ps 120 0 1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 - ps 132 0 -1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 - ps 180 0 1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 - ps 181 0 1 3.0 0 0 0 3.6 3.0 1.0 3.6 0.000300 0 0. 0. 0 - ps 182 0 1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 - ps 183 0 -1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 - ps 187 0 1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 - t 120 0 1 3.0 0 0 0 8.0 5.6 1.3 8.0 0.000001 0 0. 0. 0 - t 126 0 -1 3.0 0 0 0 8.0 5.6 1.3 8.0 0.001000 0 0. 0. 0 - t 130 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.001000 0 0. 0. 0 - t 131 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.001000 0 0. 0. 0 - t 132 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.001000 0 0. 0. 0 - t 133 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 - t 134 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 - t 135 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 - t 180 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 - t 181 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 - t 182 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 - t 183 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 - t 187 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 - q 120 0 1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000500 0 0. 0. 0 - q 130 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 - q 131 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 - q 132 0 1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 - q 133 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 - q 134 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 - q 135 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 - q 180 0 1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000500 0 0. 0. 0 - q 181 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000500 0 0. 0. 0 - q 182 0 1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 - q 183 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 - q 187 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 - pw 152 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 - pw 153 0 -1 3.0 0 0 0 5.0 5.0 2.0 5.0 0.000000 0 0. 0. 0 - pw 156 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 - pw 157 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 - pw 158 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 - pw 159 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 - sst 181 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 182 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 183 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 184 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 185 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 186 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 187 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 188 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 189 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 190 0 -1 3.0 0 0 0 2.5 2.0 0.2 2.5 0.000000 0 0. 0. 0 - sst 191 0 -1 3.0 0 0 0 3.0 2.0 0.2 3.0 0.000000 0 0. 0. 0 - sst 192 0 -1 3.0 0 0 0 3.0 2.0 0.2 3.0 0.000000 0 0. 0. 0 - sst 193 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 194 0 -1 3.0 0 0 0 3.0 2.0 0.2 3.0 0.000000 0 0. 0. 0 - sst 195 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 196 0 -1 3.0 0 0 0 2.5 2.0 0.2 2.5 0.000000 0 0. 0. 0 - sst 197 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 198 0 -1 3.0 0 0 0 2.5 2.0 0.2 2.5 0.000000 0 0. 0. 0 - sst 199 0 -1 3.0 0 0 0 1.5 2.0 0.2 1.5 0.000000 0 0. 0. 0 - sst 200 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 201 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - sst 202 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 - uv 210 0 1 3.0 0 0 0 8.0 6.1 1.4 8.0 0.000001 0 0. 0. 0 - uv 220 0 1 3.0 0 0 0 8.0 6.1 1.4 8.0 0.000001 0 0. 0. 0 - uv 221 0 1 3.0 0 0 0 8.0 6.1 1.4 8.0 0.000001 0 0. 0. 0 - uv 223 0 1 3.0 0 0 0 7.5 6.1 1.4 7.5 0.000001 0 0. 0. 0 - uv 224 0 1 3.0 0 0 0 6.5 6.1 1.4 6.5 0.000001 0 0. 0. 0 - uv 228 0 -1 3.0 0 0 0 6.5 6.1 1.4 6.5 0.000001 0 0. 0. 0 - uv 229 0 1 3.0 0 0 0 6.5 6.1 1.4 6.5 0.000001 0 0. 0. 0 - uv 230 0 1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.000100 0 0. 0. 0 - uv 231 0 1 3.0 0 0 0 6.5 6.1 1.4 6.5 0.000100 0 0. 0. 0 - uv 232 0 1 3.0 0 0 0 7.0 6.1 1.4 7.0 0.000100 0 0. 0. 0 - uv 233 0 1 3.0 0 0 0 7.5 6.1 1.4 7.5 0.000100 0 0. 0. 0 - uv 234 0 -1 3.0 0 0 0 7.5 6.1 1.4 7.5 0.000100 0 0. 0. 0 - uv 235 0 -1 3.0 0 0 0 7.5 6.1 1.4 7.5 0.000100 0 0. 0. 0 - uv 241 0 -1 3.0 0 0 0 7.5 6.1 1.4 7.5 0.000100 0 0. 0. 0 - uv 242 0 1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.005000 0 0. 0. 0 - uv 243 0 1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.005000 0 0. 0. 0 - uv 243 55 -1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.005000 1 200. 100. 0 - uv 243 56 1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.005000 1 200. 100. 0 - uv 243 57 1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.005000 1 200. 100. 0 - uv 244 0 -1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.005000 0 0. 0. 0 - uv 245 0 1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.005000 0 200. 100. 0 - uv 245 1 -1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.005000 0 200. 100. 0 - uv 245 15 1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.005000 0 200. 100. 0 - uv 246 0 1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.005000 0 200. 100. 0 - uv 246 15 1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.005000 0 200. 100. 0 - uv 247 0 -1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.005000 0 0. 0. 0 - uv 248 0 -1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.000500 0 0. 0. 0 - uv 249 0 -1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.000500 0 0. 0. 0 - uv 250 0 1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.000500 0 0. 0. 0 - uv 251 0 -1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.000050 0 0. 0. 0 - uv 251 15 -1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.000050 0 0. 0. 0 - uv 252 0 1 3.0 0 0 0 2.5 5.0 1.4 2.5 0.000050 0 0. 0. 0 - uv 253 0 1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.000500 0 0. 0. 0 - uv 253 55 -1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.000500 1 200. 100. 0 - uv 253 56 1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.000500 1 200. 100. 0 - uv 253 57 1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.000500 1 200. 100. 0 - uv 254 0 -1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.000500 0 0. 0. 0 - uv 254 55 -1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.000500 0 0. 0. 0 - uv 254 56 -1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.000500 0 0. 0. 0 - uv 254 57 -1 3.0 0 0 0 1.5 5.0 1.4 1.5 0.000500 0 0. 0. 0 - uv 256 0 -1 3.0 0 0 0 2.5 6.1 1.4 2.5 0.000500 0 0. 0. 0 - uv 257 0 1 3.0 0 0 0 2.5 6.1 1.4 2.5 0.000500 0 0. 0. 0 - uv 258 0 1 3.0 0 0 0 2.5 6.1 1.4 2.5 0.000500 0 0. 0. 0 - uv 259 0 1 3.0 0 0 0 2.5 6.1 1.4 2.5 0.000500 0 0. 0. 0 - uv 280 0 1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.000500 0 0. 0. 0 - uv 281 0 -1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.000500 0 0. 0. 0 - uv 282 0 1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.000500 0 0. 0. 0 - uv 284 0 -1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.000500 0 0. 0. 0 - uv 285 0 -1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 0 0. 0. 0 - uv 286 0 -1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.000500 0 0. 0. 0 - uv 287 0 -1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.000500 0 0. 0. 0 - uv 289 0 1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 0 0. 0. 0 - uv 290 4 1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 1 100. 1200. 0 - uv 290 3 -1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 1 100. 1200. 0 - uv 290 5 -1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 1 100. 1200. 0 - spd 283 0 -1 3.0 0 0 0 8.0 6.1 1.4 8.0 0.000000 0 0. 0. 0 - dw 999 0 -1 3.0 0 0 0 8.0 10.0 2.0 8.0 0.000000 0 0. 0. 0 - dw 201 0 -1 3.0 0 0 0 8.0 10.0 2.0 8.0 0.000001 0 0. 0. 0 - dw 202 0 -1 3.0 0 0 0 8.0 10.0 2.0 8.0 0.000001 0 0. 0. 0 - dw 100 0 -1 3.0 0 0 0 4.0 5.0 2.0 8.0 0.000001 0 0. 0. 0 - dw 101 0 -1 3.0 0 0 0 4.0 5.0 2.0 8.0 0.000001 0 0. 0. 0 - srw 999 0 -1 2.5 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - rw 999 0 -1 2.5 0 0 0 10.0 10.0 2.0 10.0 0.000000 0 0. 0. 0 - gps 004 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 041 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 722 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 723 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 740 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 741 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 742 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 743 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 744 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 745 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 820 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 042 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 786 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 421 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 003 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 821 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - gps 440 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 - pm2_5 102 0 -1 1.0 0 0 0 100.0 1.5 0.75 10.0 0.000000 0 0. 0. 0 +! pmot: the optione to keep thinned datai as monitored, 0: not to keep, other values: to keep +! ptime: time interval for thinning, 0, no temporal thinning, other values define time interval (less than 6) +!otype type sub iuse twindow numgrp ngroup nmiter gross ermax ermin var_b var_pg ithin rmesh pmesh npred pmot ptime + tcp 112 0 1 3.0 0 0 0 75.0 5.0 1.0 75.0 0.000000 0 0. 0. 0 0. 0. + ps 120 0 1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 0. 0. + ps 132 0 -1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 0. 0. + ps 180 0 1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 0. 0. + ps 181 0 1 3.0 0 0 0 3.6 3.0 1.0 3.6 0.000300 0 0. 0. 0 0. 0. + ps 182 0 1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 0. 0. + ps 183 0 -1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 0. 0. + ps 187 0 1 3.0 0 0 0 4.0 3.0 1.0 4.0 0.000300 0 0. 0. 0 0. 0. + t 120 0 1 3.0 0 0 0 8.0 5.6 1.3 8.0 0.000001 0 0. 0. 0 0. 0. + t 126 0 -1 3.0 0 0 0 8.0 5.6 1.3 8.0 0.001000 0 0. 0. 0 0. 0. + t 130 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.001000 0 0. 0. 0 0. 0. + t 131 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.001000 0 0. 0. 0 0. 0. + t 132 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.001000 0 0. 0. 0 0. 0. + t 133 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 0. 0. + t 134 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 0. 0. + t 135 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 0. 0. + t 180 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 0. 0. + t 181 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 0. 0. + t 182 0 1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 0. 0. + t 183 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 0. 0. + t 187 0 -1 3.0 0 0 0 7.0 5.6 1.3 7.0 0.004000 0 0. 0. 0 0. 0. + q 120 0 1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000500 0 0. 0. 0 0. 0. + q 130 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 0. 0. + q 131 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 0. 0. + q 132 0 1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 0. 0. + q 133 0 1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 0. 0. + q 134 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 0. 0. + q 135 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 0. 0. + q 180 0 1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000500 0 0. 0. 0 0. 0. + q 181 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000500 0 0. 0. 0 0. 0. + q 182 0 1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 0. 0. + q 183 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 0. 0. + q 187 0 -1 3.0 0 0 0 8.0 100.0 10.0 8.0 0.000600 0 0. 0. 0 0. 0. + pw 152 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 0. 0. + pw 153 0 -1 3.0 0 0 0 5.0 5.0 2.0 5.0 0.000000 0 0. 0. 0 0. 0. + pw 156 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 0. 0. + pw 157 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 0. 0. + pw 158 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 0. 0. + pw 159 0 -1 3.0 0 0 0 10.0 8.0 2.0 10.0 0.000000 0 0. 0. 0 0. 0. + sst 181 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 182 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 183 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 184 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 185 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 186 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 187 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 188 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 189 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 190 0 -1 3.0 0 0 0 2.5 2.0 0.2 2.5 0.000000 0 0. 0. 0 0. 0. + sst 191 0 -1 3.0 0 0 0 3.0 2.0 0.2 3.0 0.000000 0 0. 0. 0 0. 0. + sst 192 0 -1 3.0 0 0 0 3.0 2.0 0.2 3.0 0.000000 0 0. 0. 0 0. 0. + sst 193 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 194 0 -1 3.0 0 0 0 3.0 2.0 0.2 3.0 0.000000 0 0. 0. 0 0. 0. + sst 195 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 196 0 -1 3.0 0 0 0 2.5 2.0 0.2 2.5 0.000000 0 0. 0. 0 0. 0. + sst 197 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 198 0 -1 3.0 0 0 0 2.5 2.0 0.2 2.5 0.000000 0 0. 0. 0 0. 0. + sst 199 0 -1 3.0 0 0 0 1.5 2.0 0.2 1.5 0.000000 0 0. 0. 0 0. 0. + sst 200 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 201 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + sst 202 0 -1 3.0 0 0 0 2.0 2.0 0.2 2.0 0.000000 0 0. 0. 0 0. 0. + uv 210 0 1 3.0 0 0 0 8.0 6.1 1.4 8.0 0.000001 0 0. 0. 0 0. 0. + uv 220 0 1 3.0 0 0 0 8.0 6.1 1.4 8.0 0.000001 0 0. 0. 0 0. 0. + uv 221 0 1 3.0 0 0 0 8.0 6.1 1.4 8.0 0.000001 0 0. 0. 0 0. 0. + uv 223 0 1 3.0 0 0 0 7.5 6.1 1.4 7.5 0.000001 0 0. 0. 0 0. 0. + uv 224 0 1 3.0 0 0 0 6.5 6.1 1.4 6.5 0.000001 0 0. 0. 0 0. 0. + uv 228 0 -1 3.0 0 0 0 6.5 6.1 1.4 6.5 0.000001 0 0. 0. 0 0. 0. + uv 229 0 1 3.0 0 0 0 6.5 6.1 1.4 6.5 0.000001 0 0. 0. 0 0. 0. + uv 230 0 1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.000100 0 0. 0. 0 0. 0. + uv 231 0 1 3.0 0 0 0 6.5 6.1 1.4 6.5 0.000100 0 0. 0. 0 0. 0. + uv 232 0 1 3.0 0 0 0 7.0 6.1 1.4 7.0 0.000100 0 0. 0. 0 0. 0. + uv 233 0 1 3.0 0 0 0 7.5 6.1 1.4 7.5 0.000100 0 0. 0. 0 0. 0. + uv 234 0 -1 3.0 0 0 0 7.5 6.1 1.4 7.5 0.000100 0 0. 0. 0 0. 0. + uv 235 0 -1 3.0 0 0 0 7.5 6.1 1.4 7.5 0.000100 0 0. 0. 0 0. 0. + uv 240 0 -1 3.0 0 0 0 2.5 6.1 1.4 2.5 0.000100 0 0. 0. 0 0. 0. + uv 240 257 -1 3.0 0 0 0 2.5 6.1 1.4 2.5 0.000100 0 100. 50. 0 0. 0. + uv 240 259 -1 3.0 0 0 0 2.5 6.1 1.4 2.5 0.000100 0 100. 50. 0 0. 0. + uv 241 0 -1 3.0 0 0 0 2.5 6.1 1.4 2.5 0.000100 0 0. 0. 0 0. 0. + uv 242 0 -1 3.0 0 0 0 2.5 15.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 242 171 -1 3.0 0 0 0 2.5 15.0 1.4 2.5 0.055000 1 200. 100. 0 0. 2. + uv 242 172 -1 3.0 0 0 0 2.5 15.0 1.4 2.5 0.055000 1 200. 100. 0 0. 2. + uv 242 173 1 3.0 0 0 0 2.5 15.0 1.4 2.5 0.055000 1 200. 100. 0 0. 2. + uv 243 0 -1 3.0 0 0 0 1.5 15.0 1.4 1.5 0.055000 0 0. 0. 0 0. 0. + uv 243 54 -1 3.0 0 0 0 1.5 15.0 1.4 1.5 0.055000 1 200. 100. 0 0. 2. + uv 243 55 1 3.0 0 0 0 1.5 15.0 1.4 1.5 0.055000 1 200. 100. 0 0. 2. + uv 243 56 1 3.0 0 0 0 1.5 15.0 1.4 1.5 0.055000 1 200. 100. 0 0. 2. + uv 243 57 1 3.0 0 0 0 1.5 15.0 1.4 1.5 0.055000 1 200. 100. 0 0. 2. + uv 244 0 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 244 3 1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 244 4 1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 244 206 1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 244 207 1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 244 209 1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 244 223 1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 245 0 -1 3.0 0 0 0 1.3 20.0 1.4 1.3 0.005000 0 200. 100. 0 0. 0. + uv 245 257 1 3.0 0 0 0 1.3 20.0 1.4 1.3 0.005000 0 200. 100. 0 0. 0. + uv 245 259 1 3.0 0 0 0 1.3 20.0 1.4 1.3 0.005000 0 200. 100. 0 0. 0. + uv 246 0 -1 3.0 0 0 0 1.3 20.0 1.4 1.3 0.005000 0 200. 100. 0 0. 0. + uv 246 257 1 3.0 0 0 0 1.3 20.0 1.4 1.3 0.005000 0 200. 100. 0 0. 0. + uv 246 259 1 3.0 0 0 0 1.3 20.0 1.4 1.3 0.005000 0 200. 100. 0 0. 0. + uv 247 0 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 247 257 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 247 259 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.005000 0 0. 0. 0 0. 0. + uv 248 0 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.000500 0 0. 0. 0 0. 0. + uv 249 0 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.050500 0 0. 0. 0 0. 0. + uv 250 0 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.050500 0 0. 0. 0 0. 0. + uv 250 171 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.050500 1 200. 100. 0 0. 2. + uv 250 172 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.050500 1 200. 100. 0 0. 2. + uv 250 173 1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.050500 1 200. 100. 0 0. 2. + uv 251 0 -1 3.0 0 0 0 1.3 20.0 1.4 1.3 0.050500 0 0. 0. 0 0. 0. + uv 251 257 -1 3.0 0 0 0 1.3 20.0 1.4 1.3 0.050500 0 0. 0. 0 0. 0. + uv 251 259 -1 3.0 0 0 0 1.3 20.0 1.4 1.3 0.050050 0 0. 0. 0 0. 0. + uv 252 0 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.050050 0 0. 0. 0 0. 0. + uv 252 171 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.050050 1 200. 100. 0 0. 2. + uv 252 172 -1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.050050 1 200. 100. 0 0. 2. + uv 252 173 1 3.0 0 0 0 2.5 20.0 1.4 2.5 0.050050 1 200. 100. 0 0. 2. + uv 253 0 -1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 0 200. 100. 0 0. 2. + uv 253 54 -1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 1 200. 100. 0 0. 2. + uv 253 55 1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 1 200. 100. 0 0. 2. + uv 253 56 1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 1 200. 100. 0 0. 2. + uv 253 57 1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 1 200. 100. 0 0. 2. + uv 254 0 -1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 0 0. 0. 0 0. 0. + uv 254 54 -1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 1 200. 100. 0 0. 2. + uv 254 55 1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 1 200. 100. 0 0. 2. + uv 254 56 1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 0 200. 100. 0 0. 2. + uv 254 57 1 3.0 0 0 0 1.5 20.0 1.4 1.5 0.050500 1 200. 100. 0 0. 2. + uv 256 0 -1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.000500 0 0. 0. 0 0. 0. + uv 257 0 -1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.005500 0 0. 0. 0 0. 0. + uv 257 783 1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.005500 0 0. 0. 0 0. 0. + uv 257 784 1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.005500 0 0. 0. 0 0. 0. + uv 258 0 -1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.005500 0 0. 0. 0 0. 0. + uv 258 783 1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.005500 0 0. 0. 0 0. 0. + uv 258 784 1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.005500 0 0. 0. 0 0. 0. + uv 259 0 -1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.005500 0 0. 0. 0 0. 0. + uv 259 783 1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.005500 0 0. 0. 0 0. 0. + uv 259 784 1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.005500 0 0. 0. 0 0. 0. + uv 260 0 -1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.000500 0 0. 0. 0 0. 0. + uv 260 224 -1 3.0 0 0 0 2.5 20.1 1.4 2.5 0.000500 0 0. 0. 0 0. 0. + uv 280 0 1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.005500 0 0. 0. 0 0. 0. + uv 281 0 -1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.005500 0 0. 0. 0 0. 0. + uv 282 0 1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.005500 0 0. 0. 0 0. 0. + uv 284 0 -1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.005500 0 0. 0. 0 0. 0. + uv 285 0 -1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.005500 0 0. 0. 0 0. 0. + uv 286 0 -1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.005500 0 0. 0. 0 0. 0. + uv 287 0 -1 3.0 0 0 0 6.0 6.1 1.4 6.0 0.000500 0 0. 0. 0 0. 0. + uv 289 0 1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 0 0. 0. 0 0. 0. + uv 290 4 1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 1 100. 1200. 0 0. 0. + uv 290 3 -1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 1 100. 1200. 0 0. 0. + uv 290 5 -1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 1 100. 1200. 0 0. 0. + uv 291 0 -1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 1 100. 1200. 0 0. 0. + uv 296 0 -1 3.0 0 0 0 5.0 6.1 1.4 5.0 0.000500 0 100. 1200. 0 0. 0. + spd 283 0 -1 3.0 0 0 0 8.0 6.1 1.4 8.0 0.000000 0 0. 0. 0 0. 0. + dw 999 0 -1 3.0 0 0 0 8.0 10.0 2.0 8.0 0.000000 0 0. 0. 0 0. 0. + dw 201 0 -1 3.0 0 0 0 8.0 10.0 2.0 8.0 0.000001 0 0. 0. 0 0. 0. + dw 202 0 -1 3.0 0 0 0 8.0 10.0 2.0 8.0 0.000001 0 0. 0. 0 0. 0. + dw 100 0 -1 3.0 0 0 0 4.0 5.0 2.0 8.0 0.000001 0 0. 0. 0 0. 0. + dw 101 0 -1 3.0 0 0 0 4.0 5.0 2.0 8.0 0.000001 0 0. 0. 0 0. 0. + srw 999 0 -1 2.5 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + rw 999 0 -1 2.5 0 0 0 10.0 10.0 2.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 004 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 041 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 722 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 723 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 740 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 741 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 742 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 743 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 744 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 745 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 820 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 042 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 043 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 786 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 421 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 003 0 1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 821 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 440 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + pm2_5 102 0 -1 1.0 0 0 0 100.0 1.5 0.75 10.0 0.000000 0 0. 0. 0 0. 0. + gps 750 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 751 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 752 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 753 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 754 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 755 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 724 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 725 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 726 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 727 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 728 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 729 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. + gps 044 0 -1 3.0 0 0 0 10.0 10.0 1.0 10.0 0.000000 0 0. 0. 0 0. 0. diff --git a/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/jobs/JGDAS_VCMON b/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/jobs/JGDAS_VCMON index 8b785ca51..7adec0606 100755 --- a/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/jobs/JGDAS_VCMON +++ b/util/Conventional_Monitor/nwprod/gdas_cmon.v1.0.0/jobs/JGDAS_VCMON @@ -123,9 +123,9 @@ env ############################################################################# export CMON_AREA=${CMON_AREA:-glb} -export cnvstat=${cnvstat:-${COMIN}/gdas1.t${CYC}z.cnvstat} -export pgrbf00=${pgrbf00:-${COMIN}/gdas1.t${CYC}z.pgrbf00} -export pgrbf06=${pgrbf06:-${COMIN_m6h}/gdas1.t${CYC_m6h}z.pgrbf06} +export cnvstat=${cnvstat:-${COMIN}/gdas.t${CYC}z.cnvstat} +export pgrbf00=${pgrbf00:-${COMIN}/gdas.t${CYC}z.pgrbf00} +export pgrbf06=${pgrbf06:-${COMIN_m6h}/gdas.t${CYC_m6h}z.pgrbf06} echo "cnvstat = $cnvstat" diff --git a/util/Conventional_Monitor/parm/CMon_config b/util/Conventional_Monitor/parm/CMon_config deleted file mode 100644 index d982f6f54..000000000 --- a/util/Conventional_Monitor/parm/CMon_config +++ /dev/null @@ -1,121 +0,0 @@ -# -# Conventional Monitor package configuration file -# - -echo "begin CMon_config" - -export MY_MACHINE=wcoss - -# -# MY_CMON should point to your working directory which contains the -# top level directory to the CMon package. If you checked out the package -# as part of the GSI point to the GSI's util/Conventional_Monitor directory. -# if you checked out only the Radiance_Monitor portion of the branch then -# MY_CMON should point to that. -# - -export MY_CMON=/gpfs/gd2/emc/da/noscrub/Edward.Safford/CMon_486/util/Conventional_Monitor - -# -# The CMON_TANKDIR will be the location for the extracted data files and -# the control files used for image plotting. This is the base definition -# and the succedding scripts will construct and use subdirectories under -# this location. -# - -export CMON_TANKDIR=/u/${LOGNAME}/nbns -export C_TANKverf=${C_TANKverf:-${CMON_TANKDIR}} - -export C_TANKDIR=${CMON_TANKDIR}/stats/${CMON_SUFFIX} -export C_IMGNDIR=${CMON_TANKDIR}/imgn/${CMON_SUFFIX} - - -if [[ $MY_MACHINE = "wcoss" ]]; then - shell=sh - . /usrx/local/Modules/default/init/${shell} - module load lsf - module unload GrADS # version 2.0.1 is loaded automatically, but it's out of - module load GrADS # date -- curent default is 2.0.2 - export GRADS=grads - - export UTILS_BIN= - export LLQ= - export SUB="bsub" - export NCP=/bin/cp - export NWPROD=/nwprod - export FIXDIR=/nwprod/fix - export COMPRESS=gzip - export UNCOMPRESS="gunzip -f" - export Z="gz" - export TIMEX= - export PROJECT=${PROJECT:-GDAS-T2O} - export JOB_QUEUE=${JOB_QUEUE:-dev_shared} - -elif [[ $MY_MACHINE = "cray" ]]; then - module load prod_util # defines $NDATE among other things - module load prod_envir - - export SUB="bsub" - export NWPROD=${COMROOTp1} - export COMPRESS=gzip - export UNCOMPRESS="gunzip -f" - export PROJECT=${PROJECT:-GDAS-T2O} - export JOB_QUEUE=${JOB_QUEUE:-dev_shared} - export Z="gz" - -elif [[ $MY_MACHINE = "theia" ]]; then - export SUB=/apps/torque/default/bin/qsub - export NWPROD=/scratch4/NCEPDEV/da/save/Michael.Lueken/nwprod - export COMPRESS=gzip - export UNCOMPRESS="gunzip -f" - export Z="gz" -fi - -export NDATE=${NWPROD}/util/exec/ndate - -export ACCOUNT=${ACCOUNT:-} - -export C_STMP=${C_STMP:-/stmpp1} -export C_STMP_USER=${C_STMP_USER:-${C_STMP}/${LOGNAME}} -export C_PTMP=${C_PTMP:-/ptmpp1} -export C_PTMP_USER=${C_PTMP_USER:-${C_PTMP}/${LOGNAME}} - -export C_LOGDIR=${C_PTMP_USER}/logs/${CMON_SUFFIX}/ConMon/ -export LOGSverf_cmon=${LOGSverf_cmon:-${C_LOGDIR}} -export WORKverf_cmon=${WORKverf_cmon:-${C_STMP_USER}} - -export CONVINFO_FILE=${FIXDIR}/global_convinfo.txt # does this belong in this config file? IMG/parm? - - -# -# Web server resources include the sever name (WEB_SVR), the user name -# on the web server (WEB_USER), and location of the top level directory -# for the html on the web server (WEBDIR). -# -export WEBDIR=/home/people/emc/www/htdocs/gmb/gdas/es_conv -export WEBUSER=${LOGNAME} -export WEBSVR=emcrzdm - - -# -# Definitions for internal reference -# -export CMON_DATA_EXTRACT=${CMON_DATA_EXTRACT:-${MY_CMON}/data_extract} -export C_DE_EXEC=${C_DE_EXEC:-${CMON_DATA_EXTRACT}/exec} -export C_DE_PARM=${C_DE_PARM:-${CMON_DATA_EXTRACT}/parm} -export C_DE_SCRIPTS=${C_DE_SCRIPTS:-${CMON_DATA_EXTRACT}/ush} - -export CMON_IMAGE_GEN=${CMON_IMAGE_GEN:-${MY_CMON}/image_gen} -export C_IG_EXEC=${C_IG_EXEC:-${CMON_IMAGE_GEN}/exec} -export C_IG_GSCRIPTS=${C_IG_GSCRIPTS:-${CMON_IMAGE_GEN}/gscripts} -export C_IG_PARM=${C_IG_PARM:-${CMON_IMAGE_GEN}/parm} -export C_IG_SCRIPTS=${C_IG_SCRIPTS:-${CMON_IMAGE_GEN}/ush} -export C_IG_FIX=${C_IG_FIX:-${CMON_IMAGE_GEN}/fix} -export C_IG_HTML=${C_IG_HTML:-${CMON_IMAGE_GEN}/html} - -export CMON_PARM=${CMON_PARM:-${MY_CMON}/parm} -. $CMON_PARM/CMon.ver - -export HOMEgdascmon=${HOMEgdascmon:-${MY_CMON}/nwprod/gdas_cmon.v${gdas_cmon_ver}} -export HOMEcmon=${HOMEcmon:-${MY_CMON}/nwprod/cmon_shared.v${cmon_shared_ver}} - diff --git a/util/Conventional_Monitor/parm/CMon.ver b/util/Conventional_Monitor/parm/ConMon.ver similarity index 100% rename from util/Conventional_Monitor/parm/CMon.ver rename to util/Conventional_Monitor/parm/ConMon.ver diff --git a/util/Conventional_Monitor/parm/ConMon_config b/util/Conventional_Monitor/parm/ConMon_config new file mode 100644 index 000000000..f65289e9a --- /dev/null +++ b/util/Conventional_Monitor/parm/ConMon_config @@ -0,0 +1,127 @@ +# +# Conventional Monitor package configuration file +# + +echo "begin CMon_config" + +export MY_MACHINE=theia + +# +# MY_CMON should point to your working directory which contains the +# top level directory to the CMon package. If you checked out the package +# as part of the GSI point to the GSI's util/Conventional_Monitor directory. +# if you checked out only the Radiance_Monitor portion of the branch then +# MY_CMON should point to that. +# + +export MY_CMON=/scratch4/NCEPDEV/da/noscrub/Edward.Safford/ProdGSI/util/Conventional_Monitor + +# +# The CMON_TANKDIR will be the location for the extracted data files and +# the control files used for image plotting. This is the base definition +# and the succedding scripts will construct and use subdirectories under +# this location. +# + +export CMON_TANKDIR=/scratch4/NCEPDEV/da/save/Edward.Safford/nbns +export C_TANKverf=${C_TANKverf:-${CMON_TANKDIR}} + +export C_TANKDIR=${CMON_TANKDIR}/stats/${CMON_SUFFIX} +export C_IMGNDIR=${CMON_TANKDIR}/imgn/${CMON_SUFFIX} + + +if [[ $MY_MACHINE = "wcoss" ]]; then + shell=sh + . /usrx/local/Modules/default/init/${shell} + module load lsf + module unload GrADS # version 2.0.1 is loaded automatically, but it's out of + module load GrADS # date -- curent default is 2.0.2 + module load grib_util + module load prod_util + module load util_shared + + export GRADS=grads + + export UTILS_BIN= + export LLQ= + export SUB="bsub" + export NCP=/bin/cp + export NWPROD=/nwprod + export FIXDIR=/nwprod/fix + export COMPRESS=gzip + export UNCOMPRESS="gunzip -f" + export Z="gz" + export TIMEX= + export PROJECT=${PROJECT:-GDAS-T2O} + export JOB_QUEUE=${JOB_QUEUE:-dev_shared} + +elif [[ $MY_MACHINE = "cray" ]]; then + module load prod_util # defines $NDATE among other things + module load prod_envir + module load grib_util + module load util_shared + + export SUB="bsub" + export NWPROD=${COMROOTp1} + export COMPRESS=gzip + export UNCOMPRESS="gunzip -f" + export PROJECT=${PROJECT:-GDAS-T2O} + export JOB_QUEUE=${JOB_QUEUE:-dev_shared} + export Z="gz" + +elif [[ $MY_MACHINE = "theia" ]]; then + export SUB=sbatch + export NWPROD=/scratch4/NCEPDEV/da/save/Michael.Lueken/nwprod + export COMPRESS=gzip + export UNCOMPRESS="gunzip -f" + export Z="gz" +fi + +export NDATE=${NWPROD}/util/exec/ndate + +export ACCOUNT=${ACCOUNT:-fv3-cpu} + +export C_STMP=${C_STMP:-/scratch4/NCEPDEV/stmp3} +export C_STMP_USER=${C_STMP_USER:-${C_STMP}/${LOGNAME}} +export C_PTMP=${C_PTMP:-/scratch4/NCEPDEV/stmp4} +export C_PTMP_USER=${C_PTMP_USER:-${C_PTMP}/${LOGNAME}} + +export C_LOGDIR=${C_PTMP_USER}/logs/${CMON_SUFFIX}/ConMon +export LOGSverf_cmon=${LOGSverf_cmon:-${C_LOGDIR}} +export WORKverf_cmon=${WORKverf_cmon:-${C_STMP_USER}} + +export CONVINFO_FILE=${FIXDIR}/global_convinfo.txt # does this belong in this config file? IMG/parm? + + +# +# Web server resources include the sever name (WEB_SVR), the user name +# on the web server (WEB_USER), and location of the top level directory +# for the html on the web server (WEBDIR). +# +export WEBDIR=/home/people/emc/www/htdocs/gmb/gdas +export WEBUSER=esafford +export WEBSVR=emcrzdm + + +# +# Definitions for internal reference +# +export CMON_DATA_EXTRACT=${CMON_DATA_EXTRACT:-${MY_CMON}/data_extract} +export C_DE_EXEC=${C_DE_EXEC:-${CMON_DATA_EXTRACT}/exec} +export C_DE_PARM=${C_DE_PARM:-${CMON_DATA_EXTRACT}/parm} +export C_DE_SCRIPTS=${C_DE_SCRIPTS:-${CMON_DATA_EXTRACT}/ush} + +export CMON_IMAGE_GEN=${CMON_IMAGE_GEN:-${MY_CMON}/image_gen} +export C_IG_EXEC=${C_IG_EXEC:-${CMON_IMAGE_GEN}/exec} +export C_IG_GSCRIPTS=${C_IG_GSCRIPTS:-${CMON_IMAGE_GEN}/gscripts} +export C_IG_PARM=${C_IG_PARM:-${CMON_IMAGE_GEN}/parm} +export C_IG_SCRIPTS=${C_IG_SCRIPTS:-${CMON_IMAGE_GEN}/ush} +export C_IG_FIX=${C_IG_FIX:-${CMON_IMAGE_GEN}/fix} +export C_IG_HTML=${C_IG_HTML:-${CMON_IMAGE_GEN}/html} + +export CMON_PARM=${CMON_PARM:-${MY_CMON}/parm} +. $CMON_PARM/ConMon.ver + +export HOMEgdascmon=${HOMEgdascmon:-${MY_CMON}/nwprod/gdas_cmon.v${gdas_cmon_ver}} +export HOMEcmon=${HOMEcmon:-${MY_CMON}/nwprod/cmon_shared.v${cmon_shared_ver}} + diff --git a/util/Conventional_Monitor/parm/CMon_user_settings b/util/Conventional_Monitor/parm/ConMon_user_settings similarity index 100% rename from util/Conventional_Monitor/parm/CMon_user_settings rename to util/Conventional_Monitor/parm/ConMon_user_settings diff --git a/util/Correlated_Obs/CMakeLists.txt b/util/Correlated_Obs/CMakeLists.txt new file mode 100644 index 000000000..2252ff96a --- /dev/null +++ b/util/Correlated_Obs/CMakeLists.txt @@ -0,0 +1,93 @@ +cmake_minimum_required(VERSION 2.6) +if(CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) + # I am top-level project. + if( NOT DEFINED ENV{CC} ) + find_path( crayComp "ftn" ) + find_path( wcossIntel "mpfort" ) + find_path( intelComp "ifort" ) + find_path( pgiComp "pgf90" ) + if( crayComp ) + message("Setting CrayLinuxEnvironment") + set(CMAKE_SYSTEM_NAME "CrayLinuxEnvironment") + set(CMAKE_C_COMPILER "${crayComp}/cc") + set(CMAKE_CXX_COMPILER "${crayComp}/CC") + set(CMAKE_Fortran_COMPILER "${crayComp}/ftn") + endif() + if( intelComp ) + set(ENV{CC} "icc") + set(ENV{CXX} "icpc") + set(ENV{FC} "ifort") + endif() + if( wcossIntel ) + message("Setting env for wcoss intel") + set(ENV{CC} "mpcc") + set(ENV{CXX} "mpCC") + set(ENV{FC} "mpfort") + endif() + if( pgiComp ) + set(ENV{CC} "pgcc") + set(ENV{CXX} "pgCC") + set(ENV{FC} "pgf90") + endif() + endif() + project(COV_Calc) + enable_language (Fortran) + find_package(OpenMP) + set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/../../cmake/Modules/") + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setPlatformVariables.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setIntelFlags.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setGNUFlags.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setPGIFlags.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setHOST.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Cheyenne.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Discover.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Generic.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Gaea.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Jet.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/S4.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Theia.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/WCOSS-C.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/WCOSS-D.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/WCOSS.cmake) + if (NOT CMAKE_BUILD_TYPE) + set (CMAKE_BUILD_TYPE RELEASE CACHE STRING + "Choose the type of build, options are: PRODUCTION Debug Release." + FORCE) + endif (NOT CMAKE_BUILD_TYPE) + if (CMAKE_CXX_COMPILER_ID MATCHES "GNU*") + message("Setting GNU flags") + setGNU() + elseif(CMAKE_CXX_COMPILER_ID STREQUAL "Intel") + message("Setting Intel flags") + setIntel() + elseif(CMAKE_C_COMPILER MATCHES "pgc*") + message("Setting PGI flags") + setPGI() + endif() + find_package(MPI REQUIRED) + add_definitions(${MPI_Fortran_COMPILE_FLAGS}) + include_directories(${MPI_Fortran_INCLUDE_DIRS} ${MPI_INCLUDE_PATH} "./" ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}) + link_directories(${MPI_Fortran_LIBRARIES} ${ARCHIVE_OUTPUT_PATH} ) + find_package( NetCDF REQUIRED) + find_package(HDF5 COMPONENTS C HL Fortran_HL ) + set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/libsrc/ncdiag") + set(BUILD_NCDIAG ON) + add_subdirectory(${PROJECT_SOURCE_DIR}/../../src/ncdiag ${PROJECT_BINARY_DIR}/libsrc/ncdiag) + set(NCDIAG_LIBRARIES ncdiag ) +endif() + set(COV_CALC_SRC ${CMAKE_CURRENT_SOURCE_DIR}/cov_calc.f90 ${CMAKE_CURRENT_SOURCE_DIR}/cconstants.f90 ${CMAKE_CURRENT_SOURCE_DIR}/ckinds.f90 ${CMAKE_CURRENT_SOURCE_DIR}/matrix_tools.f90 ${CMAKE_CURRENT_SOURCE_DIR}/obs_tools.f90 ${CMAKE_CURRENT_SOURCE_DIR}/pairs.f90 ${CMAKE_CURRENT_SOURCE_DIR}/readsatobs.f90 ${CMAKE_CURRENT_SOURCE_DIR}/read_diag.f90 ) +message("HEY!! openmp flag is ${OpenMP_Fortran_FLAGS} and libraries are ${OpenMP_Fortran_LIBRARIES}") +#message("HEY!! coreincs is ${CORE_INCS}") +message("ncdiag is ${NCDIAG_LIBRARIES}") + set_source_files_properties( ${COV_CALC_SRC} PROPERTIES COMPILE_FLAGS ${COV_CALC_FLAGS} ) + add_executable(cov_calc ${COV_CALC_SRC} ) + add_dependencies(cov_calc ${NCDIAG_LIBRARIES}) + set_target_properties( cov_calc PROPERTIES COMPILE_FLAGS ${COV_CALC_FLAGS} ) + include_directories( ${CORE_INCS} ${NETCDF_INCLUDES} ${NCDIAG_INCS}) +# target_link_libraries( cov_calc ${W3NCO_LIBRARY} ) + target_link_libraries( cov_calc ${OpenMP_Fortran_LIBRARIES} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES}) + if(BUILD_COV_CALC) +# add_dependencies( cov_calc ${W3NCO_LIBRARY} ) +# add_dependencies( cov_calc ${OpenMP_Fortran_LIBRARIES} ) + endif() + diff --git a/util/Correlated_Obs/File_Utility.f90 b/util/Correlated_Obs/File_Utility.f90 deleted file mode 100644 index bb515608d..000000000 --- a/util/Correlated_Obs/File_Utility.f90 +++ /dev/null @@ -1,441 +0,0 @@ -! -! File_Utility -! -! Module containing generic file utility routines -! -! -! Written by: Paul van Delst, CIMSS/SSEC 12-Jul-2000 -! paul.vandelst@ssec.wisc.edu -! -! Copyright (C) 2000, 2006 Paul van Delst -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License -! as published by the Free Software Foundation; either version 2 -! of the License, or (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -MODULE File_Utility - - - ! --------------------------- - ! Disable all implicit typing - ! --------------------------- - - IMPLICIT NONE - - - ! ------------ - ! Visibilities - ! ------------ - - PRIVATE - PUBLIC :: Get_Lun - PUBLIC :: File_Exists - PUBLIC :: File_Open - PUBLIC :: Count_Lines_in_File - - - ! -------------------- - ! Function overloading - ! -------------------- - - INTERFACE File_Exists - MODULE PROCEDURE File_Unit_Exists - MODULE PROCEDURE File_Name_Exists - END INTERFACE File_Exists - - INTERFACE File_Open - MODULE PROCEDURE File_Open_by_Unit - MODULE PROCEDURE File_Open_by_Name - END INTERFACE File_Open - - -CONTAINS - - -! -! Get_Lun -! -! Function to obtain a free logical unit number for file access -! -! CALLING SEQUENCE: -! Lun = Get_Lun() -! -! FUNCTION RESULT: -! Lun: Logical unit number that may be used for file access. -! If Lun > 0 it can be used as a logical unit number to open -! and access a file. -! Lun < 0 a non-existant logical unit number was reached -! during the search. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! - - FUNCTION Get_Lun() RESULT( Lun ) - INTEGER :: Lun - - ! Initialise logical unit number - Lun = 9 - - ! Start open loop for Lun Search - Lun_Search: DO - Lun = Lun + 1 - IF ( .NOT. File_Exists( Lun ) ) THEN - Lun = -1 - EXIT Lun_Search - END IF - IF ( .NOT. File_Open( Lun ) ) EXIT Lun_Search - END DO Lun_Search - - END FUNCTION Get_Lun - - - -! -! File_Exists -! -! Function to determine if a file unit or a file exists. -! -! CALLING SEQUENCE: -! Result = File_Exists( FileID/Filename ) -! -! INPUT ARGUMENTS: -! Specify one of: -! -! FileID: The logical unit number for which the existence -! is to be determined. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT( IN ) -! or -! -! Filename: Name of the file the existence of which is to -! be determined. -! UNITS: N/A -! TYPE: CHARACTER( * ) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT( IN ) -! -! FUNCTION RESULT: -! Result: The return value is a logical result. -! If .TRUE. the file unit/file exists. -! .FALSE. the file unit/file does not exist. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! - - FUNCTION File_Unit_Exists( FileID ) RESULT ( Existence ) - INTEGER, INTENT( IN ) :: FileID - LOGICAL :: Existence - INQUIRE( UNIT = FileID, EXIST = Existence ) - END FUNCTION File_Unit_Exists - - - FUNCTION File_Name_Exists( Filename ) RESULT ( Existence ) - CHARACTER( * ), INTENT( IN ) :: Filename - LOGICAL :: Existence - INQUIRE( FILE = Filename, EXIST = Existence ) - END FUNCTION File_Name_Exists - - - -! -! File_Open -! -! Function to determine if a file is open for I/O. -! -! CALLING SEQUENCE: -! Result = File_Open( FileID/Filename ) -! -! INPUT ARGUMENTS: -! Specify one of: -! -! FileID: The logical unit number of the file. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT( IN ) -! or -! -! Filename: The name of the file. -! UNITS: N/A -! TYPE: CHARACTER( * ) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT( IN ) -! -! FUNCTION RESULT: -! Result: The return value is a logical result. -! If .TRUE. the file is open. -! .FALSE. the file is not open -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Scalar -! -! RESTRICTIONS: -! It is assumed the file unit or name exists. -! - - FUNCTION File_Open_by_Unit( FileID ) RESULT ( Is_Open ) - INTEGER, INTENT( IN ) :: FileID - LOGICAL :: Is_Open - INQUIRE( UNIT = FileID, OPENED = Is_Open ) - END FUNCTION File_Open_by_Unit - - - FUNCTION File_Open_by_Name( Filename ) RESULT ( Is_Open ) - CHARACTER( * ), INTENT( IN ) :: Filename - LOGICAL :: Is_Open - INQUIRE( FILE = Filename, OPENED = Is_Open ) - END FUNCTION File_Open_by_Name - - - -! -! Count_Lines_in_File -! -! Function to count the number of lines in an ASCII file -! -! CALLING SEQUENCE: -! nLines = Count_Lines_in_File( Filename, & -! NoComment=NoComment, & -! NoBlank=NoBlank ) -! -! INPUT ARGUMENTS: -! Filename: Character string specifying the name of the -! ASCII file -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! OPTIONAL INPUT ARGUMENTS: -! NoComment: Set this argument to a single character used to -! specify a comment line in the input file when the -! character is encountered in the first column. -! If specified, comment lines are NOT included -! in the line count. -! Default action to count ALL lines. -! ASCII file -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! NoBlank: Set this argument to a non-zero value to skip -! blank lines in the line count. -! If == 0, blank lines are counted [DEFAULT] -! /= 0, blank lines are NOT counted. -! Default action to count ALL lines. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! nLines: The number of lines in the file. If it equals -! zero, then the file line count could not be -! determined. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! - - FUNCTION Count_Lines_in_File( Filename, NoComment, NoBlank ) RESULT ( nLines ) - - ! Arguments - CHARACTER(*), INTENT(IN) :: Filename - CHARACTER(*), OPTIONAL, INTENT(IN) :: NoComment - INTEGER, OPTIONAL, INTENT(IN) :: NoBlank - - ! Function result - INTEGER :: nLines - - ! Local variables - CHARACTER(1) :: cChar - LOGICAL :: SkipComment - LOGICAL :: SkipBlank - CHARACTER(5000) :: Buffer - INTEGER :: IO_Status - INTEGER :: FileID - INTEGER :: n - - ! Set default return value - nLines = 0 - - ! Check arguments - IF ( .NOT. File_Exists( Filename ) ) RETURN - - SkipComment = .FALSE. - IF ( PRESENT(NoComment) ) THEN - IF ( LEN(NoComment) > 0 ) THEN - cChar = NoComment(1:1) - SkipComment = .TRUE. - END IF - END IF - - SkipBlank = .FALSE. - IF ( PRESENT(NoBlank) ) THEN - IF ( NoBlank /= 0 ) SkipBlank = .TRUE. - END IF - - ! Open the file for reading only - FileID = Get_Lun() - IF ( FileID < 0 ) RETURN - OPEN( FileID, FILE = Filename, & - STATUS = 'OLD', & - ACCESS = 'SEQUENTIAL', & - FORM = 'FORMATTED', & - ACTION = 'READ', & - IOSTAT = IO_Status ) - IF ( IO_Status /= 0 ) RETURN - - ! Initialise line counter - n = 0 - - ! Begin open loop - Count_Loop: DO - - ! Read a line of the file - READ( FileID, FMT = '( a )', & - IOSTAT = IO_Status ) Buffer - - ! Check for an error - IF ( IO_Status > 0 ) THEN - CLOSE( FileID ) - RETURN - END IF - - ! Check for end-of-file - IF ( IO_Status < 0 ) THEN - CLOSE( FileID ) - EXIT Count_Loop - END IF - - ! Check for comment - IF ( SkipComment ) THEN - IF ( Buffer(1:1) == cChar ) CYCLE Count_Loop - END IF - - ! Check for blank line - IF ( SkipBlank ) THEN - IF ( LEN_TRIM(Buffer) == 0 ) CYCLE Count_Loop - END IF - - ! Update line count - n = n + 1 - - END DO Count_Loop - - ! Assign the final count - nLines = n - - END FUNCTION Count_Lines_in_File - -END MODULE File_Utility - - -!------------------------------------------------------------------------------- -! -- MODIFICATION HISTORY -- -!------------------------------------------------------------------------------- -! -! $Id: File_Utility.f90 9040 2010-07-29 17:01:49Z Michael.Lueken@noaa.gov $ -! -! $Date: 2006/03/17 21:05:12 $ -! -! $Revision: 9040 $ -! -! $Name: $ -! -! $State: Exp $ -! -! $Log: File_Utility.f90,v $ -! Revision 1.15 2006/03/17 21:05:12 paulv -! - Stripped out the mod block. -! - Simplified header documentation. -! - Modified Count_Lines_in_File() function to handle comment and blank -! lines if required. -! -! Revision 1.14 2006/02/15 22:53:55 paulv -! - Added ASCII file line count function. -! -! Revision 1.13 2005/04/01 15:20:51 paulv -! - Uncommented END INTERFACE names. -! -! Revision 1.12 2004/08/11 20:34:41 paulv -! - Updated. -! -! Revision 1.11 2002/05/15 17:59:54 paulv -! - Overloaded FILE_EXISTS() functions from FILE_UNITS_EXISTS() and FILE_NAME_EXISTS() -! functions. -! - Added test for file unit existence to the GET_LUN() function. -! -! Revision 1.10 2001/10/24 17:36:18 paulv -! - Changed the way in which module subprograms are declared PUBLIC or PRIVATE -! so code would compile using pgf90 3.2-4a. The compiler has a bug, dammit. -! -! Revision 1.9 2001/09/28 19:33:36 paulv -! - Updated FILE_OPEN subprogram header documentation. -! -! Revision 1.8 2001/09/24 02:54:21 paulv -! - Overloaded FILE_OPEN function to allow inquiry by unit or file name. -! -! Revision 1.7 2001/09/23 19:49:54 paulv -! - Removed file_open logical variable from GET_LUN function. Argh. -! -! Revision 1.6 2001/09/23 19:38:17 paulv -! - Added CVS "Name" to modification history keyword list. -! -! Revision 1.5 2001/09/23 19:29:14 paulv -! - Corrected bug in FILE_OPEN argument type specification -! - Use FILE_OPEN() function in GET_LUN() -! - Updated header documentation -! -! Revision 1.4 2001/09/17 20:11:09 paulv -! - Module now resides in the UTILITY module directory. -! - Added FILE_OPEN function. -! -! Revision 1.3 2000/08/31 19:36:32 paulv -! - Added documentation delimiters. -! - Updated documentation headers. -! -! Revision 1.2 2000/08/24 15:33:42 paulv -! - In the GET_LUN subprogram, the loop to search for a free unit number -! was changed from: -! -! DO WHILE ( file_open ) -! ...search -! END DO -! -! to -! -! lun_search: DO -! ...search -! IF ( .NOT. file_open ) EXIT lun_search -! END DO lun_search -! -! The earlier version is a deprecated use of the DO with WHILE. -! -! - The subprogram FILE_EXISTS was added. Note that the INQUIRE statement -! required the FILE = keyword to work. Simply using the file name in -! the INQUIRE returned an error (compiler assumed it was an inquire by -! unit number?) -! - Updated module and subprogram documentation. -! -! Revision 1.1 2000/07/12 16:08:10 paulv -! Initial checked in version -! -! -! - diff --git a/util/Correlated_Obs/Makefile b/util/Correlated_Obs/Makefile deleted file mode 100644 index 8440fc073..000000000 --- a/util/Correlated_Obs/Makefile +++ /dev/null @@ -1,42 +0,0 @@ -#============================================================================== -# -# Makefile for Compute_RadDiag_Stats program -# -#============================================================================== - -# Define macros -include make.macros - -# This makefile -MAKE_FILE = Makefile - -# Executable file -EXE_FILE = cov_calc - -# Source files to link -SRC_FILES = kinds.f90 \ - constants.f90 \ - File_Utility.f90 \ - Message_Handler.f90 \ - RadDiag_Define.f90 RadDiag_Hdr_Define.f90 RadDiag_Data_Define.f90 \ - RadDiag_IO.f90 \ - pairs.f90 \ - obs_tools.f90 \ - matrix_tools.f90 - -# Obj files used in link phase -OBJ_FILES = $(SRC_FILES:.f90=.o) \ - $(EXE_FILE).o - - -# Define common make targets (all, build, clean, install) -include make.common_targets - -# Squeaky clean target -realclean: clean remove_links - -# Source dependency lists -include make.dependencies - -# Define default rules -include make.rules diff --git a/util/Correlated_Obs/Message_Handler.f90 b/util/Correlated_Obs/Message_Handler.f90 deleted file mode 100644 index cfaec942a..000000000 --- a/util/Correlated_Obs/Message_Handler.f90 +++ /dev/null @@ -1,218 +0,0 @@ -! Module to define simple error/exit codes -! and output messages. -! -MODULE Message_Handler - - ! Module use statements - USE File_Utility, ONLY: Get_Lun - - ! Disable all implicit typing - IMPLICIT NONE - - ! Visibilities - PRIVATE - ! Module parameters - PUBLIC :: SUCCESS - PUBLIC :: INFORMATION - PUBLIC :: WARNING - PUBLIC :: FAILURE - PUBLIC :: EOF - PUBLIC :: UNDEFINED - ! Module procedures - PUBLIC :: Program_Message - PUBLIC :: Display_Message - PUBLIC :: Open_Message_Log - - ! Integer values that define the error or exit state. - ! Note: These values are totally arbitrary. - INTEGER, PARAMETER :: SUCCESS = 0 - INTEGER, PARAMETER :: INFORMATION = 1 - INTEGER, PARAMETER :: WARNING = 2 - INTEGER, PARAMETER :: FAILURE = 3 - INTEGER, PARAMETER :: EOF = 4 - INTEGER, PARAMETER :: UNDEFINED = 5 - - ! Character descriptors of the error states - INTEGER, PARAMETER :: MAX_N_STATES = 5 - CHARACTER(*), PARAMETER, DIMENSION( 0:MAX_N_STATES ) :: & - STATE_DESCRIPTOR = (/ 'SUCCESS ', & - 'INFORMATION', & - 'WARNING ', & - 'FAILURE ', & - 'END-OF-FILE', & - 'UNDEFINED ' /) - - -CONTAINS - - - ! Subroutine to output a program header consisting of - ! the program name, description, and its revision - ! - SUBROUTINE Program_Message( Name, Description, Revision ) - ! Arguments - CHARACTER(*), INTENT(IN) :: Name - CHARACTER(*), INTENT(IN) :: Description - CHARACTER(*), INTENT(IN) :: Revision - ! Local parameters - CHARACTER(*), PARAMETER :: PROGRAM_HEADER = & - '**********************************************************' - CHARACTER(*), PARAMETER :: SPACE = ' ' - ! Local variables - INTEGER :: pn_pos - CHARACTER(80) :: pn_fmt - INTEGER :: phLen - INTEGER :: dLen - INTEGER :: i, i1, i2 - - ! Determine the format for outputing the name - pn_pos = ( LEN(PROGRAM_HEADER) / 2 ) - ( LEN_TRIM(ADJUSTL(Name)) / 2 ) - pn_pos = MAX( pn_pos, 0 ) + 5 - WRITE( pn_fmt, '( "( ",i2,"x, a, / )" )' ) pn_pos - - ! Write the program header and program name - WRITE(*,'(/5x, a )' ) PROGRAM_HEADER - WRITE(*,FMT=TRIM(pn_fmt)) TRIM(ADJUSTL(Name)) - - ! Write the program description splitting lines at spaces - phLen = LEN(PROGRAM_HEADER)-1 - dLen = LEN_TRIM(Description) - i1=1 - i2=phLen - - DO - IF ( dLen > phLen ) THEN - IF ( Description(i2:i2) /= SPACE .AND. i2 /= dLen) THEN - ! Search for a space character - i = INDEX( Description(i1:i2), SPACE, BACK=.TRUE. ) - IF ( i > 0 ) THEN - ! Found one. Update end-of-line - i2 = i1 + i - 1 - ELSE - ! No space. Output rest of description - i2 = dLen - END IF - END IF - ELSE - i2 = dLen - END IF - WRITE(*,'(6x, a )' ) Description(i1:i2) - i1 = i2+1 - i2 = MIN(i1+phLen-1,dLen) - IF ( i1 > dLen ) EXIT - END DO - - ! Write the program revision and end header - WRITE(*,'(/6x, a )' ) TRIM(Revision) - WRITE(*,'(5x, a, / )' ) PROGRAM_HEADER - - END SUBROUTINE Program_Message - - - ! Subroutine to display messages. - ! - ! This routine calls itself if the optional argument Message_Log - ! is passed and an error occurs opening the output log file. - ! - RECURSIVE SUBROUTINE Display_Message(Routine_Name, & - Message, & - Error_State, & - Message_Log ) - ! Arguments - CHARACTER(*), INTENT(IN) :: Routine_Name - CHARACTER(*), INTENT(IN) :: Message - INTEGER, INTENT(IN) :: Error_State - CHARACTER(*), INTENT(IN), OPTIONAL :: Message_Log - ! Local parameters - CHARACTER(*), PARAMETER :: THIS_ROUTINE_NAME = 'Display_Message' - CHARACTER(*), PARAMETER :: FMT_STRING = '( 1x, a, "(", a, ") : ", a )' - ! Local variables - INTEGER :: Error_State_To_Use - LOGICAL :: Log_To_StdOut - INTEGER :: File_ID - INTEGER :: Error_Status - - ! Check the input error state - Error_State_To_Use = Error_State - IF ( Error_State < 0 .OR. Error_State > MAX_N_STATES ) THEN - Error_State_To_Use = UNDEFINED - END IF - - ! Set the message log. Default is output to stdout - Log_To_StdOut = .TRUE. - IF ( PRESENT( Message_Log ) ) THEN - Log_To_StdOut = .FALSE. - Error_Status = Open_Message_Log( TRIM( Message_Log ), File_ID ) - IF ( Error_Status /= 0 ) THEN - CALL Display_Message( THIS_ROUTINE_NAME, & - 'Error opening message log file', & - FAILURE ) - Log_To_StdOut = .TRUE. - END IF - END IF - - ! Output the message - IF ( Log_To_StdOut ) THEN - WRITE( *, FMT = FMT_STRING ) & - TRIM( Routine_Name ), & - TRIM( STATE_DESCRIPTOR( Error_State_To_Use ) ), & - TRIM( Message ) - ELSE - WRITE( File_ID, FMT = FMT_STRING ) & - TRIM( Routine_Name ), & - TRIM( STATE_DESCRIPTOR( Error_State_To_Use ) ), & - TRIM( Message ) - CLOSE( File_ID ) - END IF - - END SUBROUTINE Display_Message - - - ! Function to open the message log file. - ! - ! SIDE EFFECTS: - ! The file is opened for SEQUENTIAL, FORMATTED access with - ! UNKNOWN status, position of APPEND, and action of READWRITE. - ! - ! Hopefully all of these options will not cause an existing file - ! to be inadvertantly overwritten. - ! - FUNCTION Open_Message_Log(Message_Log, File_ID) RESULT(Error_Status) - ! Arguments - CHARACTER(*), INTENT(IN) :: Message_Log - INTEGER, INTENT(OUT) :: File_ID - ! Function result - INTEGER :: Error_Status - ! Local variables - INTEGER :: Lun - INTEGER :: IO_Status - - ! Set successful return status - Error_Status = SUCCESS - - ! Get a file unit number - Lun = Get_Lun() - IF ( Lun < 0 ) THEN - Error_Status = FAILURE - RETURN - END IF - - ! Open the file - OPEN( Lun, FILE = TRIM( Message_Log ), & - ACCESS = 'SEQUENTIAL', & - FORM = 'FORMATTED', & - STATUS = 'UNKNOWN', & - POSITION = 'APPEND', & - ACTION = 'READWRITE', & - IOSTAT = IO_Status ) - IF ( IO_Status /= 0 ) THEN - Error_Status = FAILURE - RETURN - END IF - - ! Return the file ID - File_ID = Lun - - END FUNCTION Open_Message_Log - -END MODULE Message_Handler diff --git a/util/Correlated_Obs/README b/util/Correlated_Obs/README index 9877cd0cc..3e375d7e2 100644 --- a/util/Correlated_Obs/README +++ b/util/Correlated_Obs/README @@ -1,21 +1,21 @@ -cov_calc computes satellite IR observation error covariances. There are two methods available to compute inter-channel error covariances, namely Desroziers' method and the Hollingsworth-Lönnberg method. +cov_calc computes satellite observation error covariances. This utility does not yet handle all-sky instruments entirely correctly. There are two methods available to compute inter-channel error covariances, namely Desroziers' method and the Hollingsworth-Lönnberg method. See Desroziers, Gérald, et al. "Diagnosis of observation, background and analysi-error statistics in observation space." Quarterly Journal of the Royal Meteorological Society 131.613 (2005): 3385-3396. and -Hollingsworth, A., and P. Lönnberg. "The statistical structure of shor-range forecast errors as determined from radiosonde data. Part I: The wind field." Tellus A 38.2 (1986): 111-136. +Hollingsworth, A., and P. Lönnberg. "The statistical structure of short-range forecast errors as determined from radiosonde data. Part I: The wind field." Tellus A 38.2 (1986): 111-136. This program uses the radstat.gdas.$date files, and outputs up to four binary files. The first binary file contains the covariance matrix (plus extra information about the matrix), which can readily be used in the GSI. Outputting the other files is optional. They contain the wavenumbers of the satellite instrument, the assigned (satinfo) obs error, and the error correlation matrix. To use the computed covariance matrix in the GSI: -1. Add a table to the anavinfo file, following the comments in src/correlated_obsmod.F90. Note that, for method 1, the reconditioned correlation matrix has a condition number that is roughly twice what is specified in the anavinfo file. -2. Copy the covariance matrix into the data directory. For parallel GFS, this can be achieved by adding a line such as 'cp $ROTDIR/Rcov* $DATA' to exglobal_analysis.sh.ecf. For single runs of the GSI, add this line to rungsi_globalprod.sh. +1. Add a table to the anavinfo file, following the comments in src/correlated_obsmod.F90, or the corr_obs regression test anavinfo, fix/global_anavinfo_corrobs.txt +2. Copy the covariance matrix into the fix directory. Make sure the run script will copy the covariance file from the fix directory to the run directory. It should contain something like 'cp $FIXgsi/Rcov* $DATA' -Before running this program, compile it by typing 'make'. +This utility compiles with cmake. To compile, run ../../ush/build_all_cmake.sh. Thil will create the executable ../../exec/cov_calc -There are two ways to run cov_calc. The bottleneck of this program is in dealing with the radstat files. Using parallel_run.sh will process the radstat files in parallel. To use this script, edit its first few lines, and then simply run it. Both run.sh and parallel_run.sh contain options to specify which computational method to use (Desroziers or Hollingsworth-Lönnberg), and a choice to use only actively assimialted channels (recommended for Desroziers) or all channels. +There are two ways to run cov_calc. The bottleneck of this program is in dealing with the radstat files. The radstat files can be either binary or netcdf. Using parallel_run.sh will process the radstat files in parallel. To use this script, edit its first few lines, and then simply run it. Both run.sh and parallel_run.sh contain options to specify which computational method to use (Desroziers or Hollingsworth-Lönnberg), and a choice to use only actively assimialted channels (recommended for Desroziers) or all channels. -If the amount of radstat files is small, or they have already been processed (see below), then run.sh can be used. Edit its first few lines and submit submit_job.sh as a job. +If the amount of radstat files is small, or they have already been processed (see below), then run.sh can be used. Edit its first few lines and submit submit_theia.sh or submit_wcoss.sh as a job. cov_calc requires the files diag_$instr_anl.$date and diag and diag_$instr_ges.$date from the radstat files. The first analysis diag file must be renamed danl_0001, the second renamed danl_0002, etc, while the first background file must be renamed dges_0001 and so on. Even if a diag file is missing, the danl and dges files count up by one each time. The scripts parallel_run.sh and run.sh process the radstat files in this manner. diff --git a/util/Correlated_Obs/RadDiag_Data_Define.f90 b/util/Correlated_Obs/RadDiag_Data_Define.f90 deleted file mode 100644 index 69ec9c6d1..000000000 --- a/util/Correlated_Obs/RadDiag_Data_Define.f90 +++ /dev/null @@ -1,372 +0,0 @@ -! -! RadDiag_Data_Define -! -! Module defining the RadDiag data structure -! and containing routines to manipulate them -! -! -! CREATION HISTORY: -! Written by: Paul van Delst, 23-Mar-2006 -! paul.vandelst@noaa.gov -! - -MODULE RadDiag_Data_Define - - ! ----------------- - ! Environment setup - ! ----------------- - ! Module usage - USE Message_Handler, ONLY: FAILURE, SUCCESS, INFORMATION, Display_Message - USE kinds, only: sp=>r_kind - ! Disable implicit typing - IMPLICIT NONE - - - ! --------------------- - ! Explicit visibilities - ! --------------------- - PRIVATE - ! Parameters - PUBLIC :: RADDIAG_N_FPELEMENTS - PUBLIC :: RADDIAG_N_CHELEMENTS - PUBLIC :: RADDIAG_N_PRELEMENTS - ! Datatypes - PUBLIC :: RadDiag_Data_Scalar_type - PUBLIC :: RadDiag_Data_Channel_type - PUBLIC :: RadDiag_Data_type - ! Procedures - PUBLIC :: RadDiag_Data_Associated - PUBLIC :: RadDiag_Data_Destroy - PUBLIC :: RadDiag_Data_Create - PUBLIC :: RadDiag_Data_Inspect - PUBLIC :: RadDiag_Data_DefineVersion - - - ! ----------------- - ! Module parameters - ! ----------------- - INTEGER, PARAMETER :: RADDIAG_N_FPELEMENTS = 26 ! Number of floating point elements - INTEGER, PARAMETER :: RADDIAG_N_CHELEMENTS = 7 ! Number of channel elements - INTEGER, PARAMETER :: RADDIAG_N_PRELEMENTS = 5 ! Number of bias correction terms - ! Literal constants - REAL, PARAMETER :: ZERO = 0.0_sp - ! Version Id for the module - CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: RadDiag_Data_Define.f90 9040 2010-07-29 17:01:49Z Michael.Lueken@noaa.gov $' - - - ! ------------------------- - ! Data structure definition - ! ------------------------- - ! Scalar part of data - TYPE :: RadDiag_Data_Scalar_type - REAL(sp) :: lat = ZERO ! latitude (deg) - REAL(sp) :: lon = ZERO ! longitude (deg) - REAL(sp) :: zsges = ZERO ! guess elevation at obs location (m) - REAL(sp) :: obstime = ZERO ! observation time relative to analysis - REAL(sp) :: senscn_pos = ZERO ! sensor scan position (integer) - REAL(sp) :: satzen_ang = ZERO ! satellite zenith angle (deg) - REAL(sp) :: satazm_ang = ZERO ! satellite azimuth angle (deg) - REAL(sp) :: solzen_ang = ZERO ! solar zenith angle (deg) - REAL(sp) :: solazm_ang = ZERO ! solar azimumth angle (deg) - REAL(sp) :: sungln_ang = ZERO ! sun glint angle (deg) - REAL(sp) :: water_frac = ZERO ! fractional coverage by water - REAL(sp) :: land_frac = ZERO ! fractional coverage by land - REAL(sp) :: ice_frac = ZERO ! fractional coverage by ice - REAL(sp) :: snow_frac = ZERO ! fractional coverage by snow - REAL(sp) :: water_temp = ZERO ! surface temperature over water (K) - REAL(sp) :: land_temp = ZERO ! surface temperature over land (K) - REAL(sp) :: ice_temp = ZERO ! surface temperature over ice (K) - REAL(sp) :: snow_temp = ZERO ! surface temperature over snow (K) - REAL(sp) :: soil_temp = ZERO ! soil temperature (K) - REAL(sp) :: soil_mois = ZERO ! soil moisture - REAL(sp) :: land_type = ZERO ! land type (integer) - REAL(sp) :: veg_frac = ZERO ! vegetation fraction - REAL(sp) :: snow_depth = ZERO ! snow depth - REAL(sp) :: sfc_wndspd = ZERO ! surface wind speed - REAL(sp) :: qcdiag1 = ZERO ! ir=cloud fraction, mw=cloud liquid water - REAL(sp) :: qcdiag2 = ZERO ! ir=cloud top pressure, mw=total column water - REAL(sp) :: tref = ZERO ! reference temperature - REAL(sp) :: dtw = ZERO ! diurnal warming: d(Tw) at depth zob - REAL(sp) :: dtc = ZERO ! sub-layer cooling: d(Tc) at depth zob - REAL(sp) :: tz_tr = ZERO ! d(Tz)/d(Tr) - END TYPE RadDiag_Data_Scalar_type - - ! Channel dependent part of data - TYPE :: RadDiag_Data_Channel_type - REAL(sp) :: tbobs = ZERO ! Tb (obs) (K) - REAL(sp) :: omgbc = ZERO ! Tb_(obs) - Tb_(simulated w/ bc) (K) - REAL(sp) :: omgnbc = ZERO ! Tb_(obs) - Tb_(simulated_w/o bc) (K) - REAL(sp) :: errinv = ZERO ! inverse error (K**(-1)) - REAL(sp) :: qcmark = ZERO ! quality control mark - REAL(sp) :: emiss = ZERO ! surface emissivity - REAL(sp) :: tlap = ZERO ! temperature lapse rate - REAL(sp) :: tb_tz = ZERO ! sst temperature gradient - REAL(sp) :: bicons = ZERO ! bias constant term - REAL(sp) :: bicoss = ZERO ! bias cosine of scan angle term - REAL(sp) :: biclw = ZERO ! bias clw term - REAL(sp) :: bilap2 = ZERO ! bias lapse rate squared term - REAL(sp) :: bilap = ZERO ! bias lapse rate term - REAL(sp) :: bicos = ZERO ! bias cosine of solar zenith term - REAL(sp) :: bisin = ZERO ! bias sin of solar zenith term - REAL(sp) :: biem = ZERO ! bias emissivity term - REAL(sp) :: biang = ZERO ! bias scan angle terms - REAL(sp) :: biang2 = ZERO - REAL(sp) :: biang3 = ZERO - REAL(sp) :: biang4 = ZERO - REAL(sp) :: biang5 = ZERO - REAL(sp) :: bisst = ZERO ! bias sst term - END TYPE RadDiag_Data_Channel_type - - ! The complete data structure - TYPE :: RadDiag_Data_type - INTEGER :: n_Channels = 0 ! Structure dimensions - TYPE(RadDiag_Data_Scalar_type) :: Scalar - TYPE(RadDiag_Data_Channel_type), ALLOCATABLE :: Channel(:) - END TYPE RadDiag_Data_type - - -CONTAINS - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! NAME: -! RadDiag_Data_Associated -! -! PURPOSE: -! Elemental function to test the status of the allocatable components -! of a RadDiag_Data object. -! -! CALLING SEQUENCE: -! Status = RadDiag_Data_Associated( RadDiag_Data ) -! -! OBJECTS: -! RadDiag_Data: RadDiag_Data structure which is to have its -! member's status tested. -! UNITS: N/A -! TYPE: RadDiag_Data_type -! DIMENSION: Scalar or any rank -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! Status: The return value is a logical value indicating the -! status of the RadDiag_Data members. -! .TRUE. - if ANY of the RadDiag_Data allocatable or -! pointer members are in use. -! .FALSE. - if ALL of the RadDiag_Data allocatable or -! pointer members are not in use. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Same as input RadDiag_Data argument -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - ELEMENTAL FUNCTION RadDiag_Data_Associated( RadDiag_Data ) RESULT( Status ) - ! Arguments - TYPE(RadDiag_Data_type), INTENT(IN) :: RadDiag_Data - ! Function result - LOGICAL :: Status - - ! Test the structure members - Status = ALLOCATED( RadDiag_Data%Channel ) - - END FUNCTION RadDiag_Data_Associated - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_Data_Destroy -! -! PURPOSE: -! Elemental subroutine to re-initialize RadDiag_Data objects. -! -! CALLING SEQUENCE: -! CALL RadDiag_Data_Destroy( RadDiag_Data ) -! -! OBJECTS: -! RadDiag_Data: Re-initialized RadDiag_Data structure. -! UNITS: N/A -! TYPE: RadDiag_Data_type -! DIMENSION: Scalar OR any rank -! ATTRIBUTES: INTENT(OUT) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - ELEMENTAL SUBROUTINE RadDiag_Data_Destroy( RadDiag_Data ) - TYPE(RadDiag_Data_type), INTENT(OUT) :: RadDiag_Data - END SUBROUTINE RadDiag_Data_Destroy - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_Data_Create -! -! PURPOSE: -! Elemental subroutine to create an instance of the RadDiag_Data object. -! -! CALLING SEQUENCE: -! CALL RadDiag_Data_Create( RadDiag_Data, n_Channels ) -! -! OBJECTS: -! RadDiag_Data: RadDiag_Data structure. -! UNITS: N/A -! TYPE: RadDiag_Data_type -! DIMENSION: Scalar or any rank -! ATTRIBUTES: INTENT(OUT) -! -! INPUTS: -! n_Channels: Channel dimension of RadDiag_Data structure. -! Must be > 0. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Conformable with RadDiag_Data object -! ATTRIBUTES: INTENT(IN) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - ELEMENTAL SUBROUTINE RadDiag_Data_Create( & - RadDiag_Data, & ! Output - n_Channels ) ! Input - ! Arguments - TYPE(RadDiag_Data_type), INTENT(OUT) :: RadDiag_Data - INTEGER, INTENT(IN) :: n_Channels - ! Local variables - INTEGER :: alloc_stat - - ! Check input - IF ( n_Channels < 1 ) RETURN - - ! Perform the allocation - ALLOCATE( RadDiag_Data%Channel(n_Channels), & - STAT = alloc_stat ) - IF ( alloc_stat /= 0 ) RETURN - - ! Initialise dimensions - RadDiag_Data%n_Channels = n_Channels - - END SUBROUTINE RadDiag_Data_Create - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_Data_Inspect -! -! PURPOSE: -! Subroutine to print the contents of a RadDiag_Data object to stdout. -! -! CALLING SEQUENCE: -! CALL RadDiag_Data_Inspect( rdd ) -! -! INPUTS: -! rdd: RadDiag_Data object to display. -! UNITS: N/A -! TYPE: RadDiag_Data_type -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - SUBROUTINE RadDiag_Data_Inspect( rdd ) - TYPE(RadDiag_Data_type), INTENT(IN) :: rdd - INTEGER :: i - WRITE(*, '(1x,"RadDiag_Data OBJECT")') - ! Scalar object - CALL RadDiag_Data_Scalar_Inspect( rdd%Scalar ) - ! Channel object(s) - IF ( .NOT. RadDiag_Data_Associated(rdd) ) RETURN - DO i = 1, rdd%n_Channels - WRITE(*, '(3x,"Channel index: ",i0)') i - CALL RadDiag_Data_Channel_Inspect( rdd%Channel(i) ) - END DO - END SUBROUTINE RadDiag_Data_Inspect - - SUBROUTINE RadDiag_Data_Scalar_Inspect( rdds ) - TYPE(RadDiag_Data_Scalar_type), INTENT(IN) :: rdds - WRITE(*, '(3x,"Scalar Component")') - WRITE(*, '(5x,"lat :",1x,es13.6)') rdds%lat - WRITE(*, '(5x,"lon :",1x,es13.6)') rdds%lon - WRITE(*, '(5x,"zsges :",1x,es13.6)') rdds%zsges - WRITE(*, '(5x,"obstime :",1x,es13.6)') rdds%obstime - WRITE(*, '(5x,"senscn_pos :",1x,es13.6)') rdds%senscn_pos - WRITE(*, '(5x,"satzen_ang :",1x,es13.6)') rdds%satzen_ang - WRITE(*, '(5x,"satazm_ang :",1x,es13.6)') rdds%satazm_ang - WRITE(*, '(5x,"solzen_ang :",1x,es13.6)') rdds%solzen_ang - WRITE(*, '(5x,"solazm_ang :",1x,es13.6)') rdds%solazm_ang - WRITE(*, '(5x,"sungln_ang :",1x,es13.6)') rdds%sungln_ang - WRITE(*, '(5x,"water_frac :",1x,es13.6)') rdds%water_frac - WRITE(*, '(5x,"land_frac :",1x,es13.6)') rdds%land_frac - WRITE(*, '(5x,"ice_frac :",1x,es13.6)') rdds%ice_frac - WRITE(*, '(5x,"snow_frac :",1x,es13.6)') rdds%snow_frac - WRITE(*, '(5x,"water_temp :",1x,es13.6)') rdds%water_temp - WRITE(*, '(5x,"land_temp :",1x,es13.6)') rdds%land_temp - WRITE(*, '(5x,"ice_temp :",1x,es13.6)') rdds%ice_temp - WRITE(*, '(5x,"snow_temp :",1x,es13.6)') rdds%snow_temp - WRITE(*, '(5x,"soil_temp :",1x,es13.6)') rdds%soil_temp - WRITE(*, '(5x,"soil_mois :",1x,es13.6)') rdds%soil_mois - WRITE(*, '(5x,"land_type :",1x,es13.6)') rdds%land_type - WRITE(*, '(5x,"veg_frac :",1x,es13.6)') rdds%veg_frac - WRITE(*, '(5x,"snow_depth :",1x,es13.6)') rdds%snow_depth - WRITE(*, '(5x,"sfc_wndspd :",1x,es13.6)') rdds%sfc_wndspd - WRITE(*, '(5x,"qcdiag1 :",1x,es13.6)') rdds%qcdiag1 - WRITE(*, '(5x,"qcdiag2 :",1x,es13.6)') rdds%qcdiag2 - END SUBROUTINE RadDiag_Data_Scalar_Inspect - - SUBROUTINE RadDiag_Data_Channel_Inspect( rddc ) - TYPE(RadDiag_Data_Channel_type), INTENT(IN) :: rddc - WRITE(*, '(3x,"Channel Component")') - WRITE(*, '(5x,"tbobs :",1x,es13.6)') rddc%tbobs - WRITE(*, '(5x,"omgbc :",1x,es13.6)') rddc%omgbc - WRITE(*, '(5x,"omgnbc :",1x,es13.6)') rddc%omgnbc - WRITE(*, '(5x,"errinv :",1x,es13.6)') rddc%errinv - WRITE(*, '(5x,"qcmark :",1x,es13.6)') rddc%qcmark - WRITE(*, '(5x,"emiss :",1x,es13.6)') rddc%emiss - WRITE(*, '(5x,"tlap :",1x,es13.6)') rddc%tlap -! WRITE(*, '(5x,"bifix :",1x,es13.6)') rddc%bifix -! WRITE(*, '(5x,"bilap :",1x,es13.6)') rddc%bilap -! WRITE(*, '(5x,"bilap2 :",1x,es13.6)') rddc%bilap2 -! WRITE(*, '(5x,"bicons :",1x,es13.6)') rddc%bicons -! WRITE(*, '(5x,"biang :",1x,es13.6)') rddc%biang -! WRITE(*, '(5x,"biclw :",1x,es13.6)') rddc%biclw - END SUBROUTINE RadDiag_Data_Channel_Inspect - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_Data_DefineVersion -! -! PURPOSE: -! Subroutine to return the module version information. -! -! CALLING SEQUENCE: -! CALL RadDiag_Data_DefineVersion( Id ) -! -! OUTPUTS: -! Id: Character string containing the version Id information -! for the module. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - SUBROUTINE RadDiag_Data_DefineVersion( Id ) - CHARACTER(*), INTENT(OUT) :: Id - Id = MODULE_VERSION_ID - END SUBROUTINE RadDiag_Data_DefineVersion - -END MODULE RadDiag_Data_Define diff --git a/util/Correlated_Obs/RadDiag_Define.f90 b/util/Correlated_Obs/RadDiag_Define.f90 deleted file mode 100644 index 0f38e9877..000000000 --- a/util/Correlated_Obs/RadDiag_Define.f90 +++ /dev/null @@ -1,109 +0,0 @@ -! -! RadDiag_Define -! -! Container module for RadDiag objects -! - -MODULE RadDiag_Define - - ! ----------------- - ! Environment setup - ! ----------------- - ! Module usage - USE RadDiag_Hdr_Define , ONLY: RadDiag_Hdr_Scalar_type , & - RadDiag_Hdr_Channel_type , & - RadDiag_Hdr_type , & - RadDiag_Hdr_Associated , & - RadDiag_Hdr_Destroy , & - RadDiag_Hdr_Create , & - RadDiag_Hdr_Inspect , & - RadDiag_Hdr_DefineVersion - USE RadDiag_Data_Define, ONLY: RADDIAG_N_FPELEMENTS, & - RADDIAG_N_CHELEMENTS, & - RADDIAG_N_PRELEMENTS, & - RadDiag_Data_Scalar_type , & - RadDiag_Data_Channel_type , & - RadDiag_Data_type , & - RadDiag_Data_Associated , & - RadDiag_Data_Destroy , & - RadDiag_Data_Create , & - RadDiag_Data_Inspect , & - RadDiag_Data_DefineVersion - ! Disable implicit typing - IMPLICIT NONE - - - ! --------------------- - ! Explicit visibilities - ! --------------------- - ! Everything private by default - PRIVATE - ! RadDiag_Hdr entities - ! ...Datatypes - PUBLIC :: RadDiag_Hdr_Scalar_type - PUBLIC :: RadDiag_Hdr_Channel_type - PUBLIC :: RadDiag_Hdr_type - ! ...Procedures - PUBLIC :: RadDiag_Hdr_Associated - PUBLIC :: RadDiag_Hdr_Destroy - PUBLIC :: RadDiag_Hdr_Create - PUBLIC :: RadDiag_Hdr_Inspect - PUBLIC :: RadDiag_Hdr_DefineVersion - ! RadDiag_Data entities - ! ...Parameters - PUBLIC :: RADDIAG_N_FPELEMENTS - PUBLIC :: RADDIAG_N_CHELEMENTS - PUBLIC :: RADDIAG_N_PRELEMENTS - ! ...Datatypes - PUBLIC :: RadDiag_Data_Scalar_type - PUBLIC :: RadDiag_Data_Channel_type - PUBLIC :: RadDiag_Data_type - ! ...Procedures - PUBLIC :: RadDiag_Data_Associated - PUBLIC :: RadDiag_Data_Destroy - PUBLIC :: RadDiag_Data_Create - PUBLIC :: RadDiag_Data_Inspect - PUBLIC :: RadDiag_Data_DefineVersion - ! RadDiag entities - ! ...Procedures - PUBLIC :: RadDiag_DefineVersion - - ! ----------------- - ! Module parameters - ! ----------------- - CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: RadDiag_Define.f90 9040 2010-07-29 17:01:49Z Michael.Lueken@noaa.gov $' - - -CONTAINS - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_DefineVersion -! -! PURPOSE: -! Subroutine to return the module version information. -! -! CALLING SEQUENCE: -! CALL RadDiag_DefineVersion( Id ) -! -! OUTPUTS: -! Id: Character string containing the version Id information -! for the module. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - SUBROUTINE RadDiag_DefineVersion( Id ) - CHARACTER(*), INTENT(OUT) :: Id - Id = MODULE_VERSION_ID - END SUBROUTINE RadDiag_DefineVersion - -END MODULE RadDiag_Define diff --git a/util/Correlated_Obs/RadDiag_Hdr_Define.f90 b/util/Correlated_Obs/RadDiag_Hdr_Define.f90 deleted file mode 100644 index 86b4044b8..000000000 --- a/util/Correlated_Obs/RadDiag_Hdr_Define.f90 +++ /dev/null @@ -1,320 +0,0 @@ -! -! RadDiag_Hdr_Define -! -! Module defining the RadDiag header structures -! and containing routines to manipulate them -! -! -! CREATION HISTORY: -! Written by: Paul van Delst, 23-Mar-2006 -! paul.vandelst@noaa.gov -! - -MODULE RadDiag_Hdr_Define - - ! ----------------- - ! Environment setup - ! ----------------- - ! Module usage - - USE kinds, only: sp=>r_kind - USE Message_Handler, ONLY: FAILURE, SUCCESS, INFORMATION, Display_Message - ! Disable implicit typing - IMPLICIT NONE - - - ! --------------------- - ! Explicit visibilities - ! --------------------- - ! Everything private by default - PRIVATE - ! Datatypes - PUBLIC :: RadDiag_Hdr_Scalar_type - PUBLIC :: RadDiag_Hdr_Channel_type - PUBLIC :: RadDiag_Hdr_type - ! Module subprograms - PUBLIC :: RadDiag_Hdr_Associated - PUBLIC :: RadDiag_Hdr_Destroy - PUBLIC :: RadDiag_Hdr_Create - PUBLIC :: RadDiag_Hdr_Inspect - PUBLIC :: RadDiag_Hdr_DefineVersion - - - ! ----------------- - ! Module parameters - ! ----------------- - ! Literal constants - REAL, PARAMETER :: ZERO = 0.0_sp - ! Version Id for the module - CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: RadDiag_Hdr_Define.f90 9040 2010-07-29 17:01:49Z Michael.Lueken@noaa.gov $' - - - ! --------------------------- - ! Header structure definition - ! --------------------------- - ! Scalar part of header - TYPE :: RadDiag_Hdr_Scalar_type - CHARACTER(20) :: isis = ' ' ! sat and sensor type - CHARACTER(10) :: id = ' ' ! sat type - CHARACTER(10) :: obstype = ' ' ! observation type - INTEGER :: jiter = 0 ! outer loop counter - INTEGER :: nchan = 0 ! number of channels in the sensor - INTEGER :: npred = 0 ! number of updating bias correction predictors - INTEGER :: idate = 0 ! time (yyyymmddhh) - INTEGER :: ireal = 0 ! # of real elements in the fix part of a data record - INTEGER :: ipchan = 0 ! # of elements for each channel except for bias correction terms - INTEGER :: iextra = 0 ! # of extra elements for each channel - INTEGER :: jextra = 0 ! # of extra elements - INTEGER :: idiag = 0 - INTEGER :: angord = 0 - INTEGER :: iversion_raddiag = 0 - INTEGER :: inewpc = 0 - INTEGER :: ioff0 = 0 - END TYPE RadDiag_Hdr_Scalar_type - - ! Channel dependent part of header - TYPE :: RadDiag_Hdr_Channel_type - REAL(sp) :: freq = ZERO ! frequency (Hz) - REAL(sp) :: polar = ZERO ! polarization - REAL(sp) :: wave = ZERO ! wave number (cm^-1) - REAL(sp) :: varch = ZERO ! error variance (or SD error?) - REAL(sp) :: tlapmean = ZERO ! mean lapse rate - INTEGER :: iuse = -1 ! use flag - INTEGER :: nuchan = -1 ! sensor relative channel number - INTEGER :: iochan = -1 ! satinfo relative channel number - END TYPE RadDiag_Hdr_Channel_type - - ! The complete header - TYPE :: RadDiag_Hdr_type - INTEGER :: n_Channels = 0 ! Structure dimensions - TYPE(RadDiag_Hdr_Scalar_type) :: Scalar - TYPE(RadDiag_Hdr_Channel_type), ALLOCATABLE :: Channel(:) - END TYPE RadDiag_Hdr_type - - -CONTAINS - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! NAME: -! RadDiag_Hdr_Associated -! -! PURPOSE: -! Elemental function to test the status of the allocatable components -! of a RadDiag_Hdr object. -! -! CALLING SEQUENCE: -! Status = RadDiag_Hdr_Associated( RadDiag_Hdr ) -! -! OBJECTS: -! RadDiag_Hdr: RadDiag_Hdr structure which is to have its -! member's status tested. -! UNITS: N/A -! TYPE: RadDiag_Hdr_type -! DIMENSION: Scalar or any rank -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! Status: The return value is a logical value indicating the -! status of the RadDiag_Hdr members. -! .TRUE. - if ANY of the RadDiag_Hdr allocatable or -! pointer members are in use. -! .FALSE. - if ALL of the RadDiag_Hdr allocatable or -! pointer members are not in use. -! UNITS: N/A -! TYPE: LOGICAL -! DIMENSION: Same as input RadDiag_Hdr argument -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - ELEMENTAL FUNCTION RadDiag_Hdr_Associated( RadDiag_Hdr ) RESULT( Status ) - ! Arguments - TYPE(RadDiag_Hdr_type), INTENT(IN) :: RadDiag_Hdr - ! Function result - LOGICAL :: Status - - ! Test the structure members - Status = ALLOCATED( RadDiag_Hdr%Channel ) - - END FUNCTION RadDiag_Hdr_Associated - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_Hdr_Destroy -! -! PURPOSE: -! Elemental subroutine to re-initialize RadDiag_Hdr objects. -! -! CALLING SEQUENCE: -! CALL RadDiag_Hdr_Destroy( RadDiag_Hdr ) -! -! OBJECTS: -! RadDiag_Hdr: Re-initialized RadDiag_Hdr structure. -! UNITS: N/A -! TYPE: RadDiag_Hdr_type -! DIMENSION: Scalar OR any rank -! ATTRIBUTES: INTENT(OUT) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - ELEMENTAL SUBROUTINE RadDiag_Hdr_Destroy( RadDiag_Hdr ) - TYPE(RadDiag_Hdr_type), INTENT(OUT) :: RadDiag_Hdr - END SUBROUTINE RadDiag_Hdr_Destroy - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_Hdr_Create -! -! PURPOSE: -! Elemental subroutine to create an instance of the RadDiag_Hdr object. -! -! CALLING SEQUENCE: -! CALL RadDiag_Hdr_Create( RadDiag_Hdr, n_Channels ) -! -! OBJECTS: -! RadDiag_Hdr: RadDiag_Hdr structure. -! UNITS: N/A -! TYPE: RadDiag_Hdr_type -! DIMENSION: Scalar or any rank -! ATTRIBUTES: INTENT(OUT) -! -! INPUTS: -! n_Channels: Channel dimension of RadDiag_Hdr structure. -! Must be > 0. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Conformable with RadDiag_Hdr object -! ATTRIBUTES: INTENT(IN) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - ELEMENTAL SUBROUTINE RadDiag_Hdr_Create( & - RadDiag_Hdr, & ! Output - n_Channels ) ! Input - ! Arguments - TYPE(RadDiag_Hdr_type), INTENT(OUT) :: RadDiag_Hdr - INTEGER, INTENT(IN) :: n_Channels - ! Local variables - INTEGER :: alloc_stat - - ! Check input - IF ( n_Channels < 1 ) RETURN - - ! Perform the allocation - ALLOCATE( RadDiag_Hdr%Channel(n_Channels), & - STAT = alloc_stat ) - - IF ( alloc_stat /= 0 ) RETURN - - ! Initialise dimensions - RadDiag_Hdr%n_Channels = n_Channels - - END SUBROUTINE RadDiag_Hdr_Create - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_Hdr_Inspect -! -! PURPOSE: -! Subroutine to print the contents of a RadDiag_Hdr object to stdout. -! -! CALLING SEQUENCE: -! CALL RadDiag_Hdr_Inspect( rdh ) -! -! INPUTS: -! rdh: RadDiag_Hdr object to display. -! UNITS: N/A -! TYPE: RadDiag_Hdr_type -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - SUBROUTINE RadDiag_Hdr_Inspect( rdh ) - TYPE(RadDiag_Hdr_type), INTENT(IN) :: rdh - INTEGER :: i - WRITE(*, '(1x,"RADDIAG_HDR OBJECT")') - ! Scalar object - CALL RadDiag_Hdr_Scalar_Inspect( rdh%Scalar ) - ! Channel object(s) - IF ( .NOT. RadDiag_Hdr_Associated(rdh) ) RETURN - DO i = 1, rdh%n_Channels - WRITE(*, '(3x,"Channel index: ",i0)') i - CALL RadDiag_Hdr_Channel_Inspect( rdh%Channel(i) ) - END DO - END SUBROUTINE RadDiag_Hdr_Inspect - - SUBROUTINE RadDiag_Hdr_Scalar_Inspect( rdhs ) - TYPE(RadDiag_Hdr_Scalar_type), INTENT(IN) :: rdhs - WRITE(*, '(3x,"Scalar Component")') - WRITE(*, '(5x,"isis :",1x,a)') TRIM(rdhs%isis) - WRITE(*, '(5x,"id :",1x,a)') TRIM(rdhs%id) - WRITE(*, '(5x,"obstype :",1x,a)') TRIM(rdhs%obstype) - WRITE(*, '(5x,"jiter :",1x,i0)') rdhs%jiter - WRITE(*, '(5x,"nchan :",1x,i0)') rdhs%nchan - WRITE(*, '(5x,"npred :",1x,i0)') rdhs%npred - WRITE(*, '(5x,"idate :",1x,i0)') rdhs%idate - WRITE(*, '(5x,"ireal :",1x,i0)') rdhs%ireal - WRITE(*, '(5x,"ipchan :",1x,i0)') rdhs%ipchan - WRITE(*, '(5x,"iextra :",1x,i0)') rdhs%iextra - WRITE(*, '(5x,"jextra :",1x,i0)') rdhs%jextra - END SUBROUTINE RadDiag_Hdr_Scalar_Inspect - - SUBROUTINE RadDiag_Hdr_Channel_Inspect( rdhc ) - TYPE(RadDiag_Hdr_Channel_type), INTENT(IN) :: rdhc - WRITE(*, '(3x,"Channel Component")') - WRITE(*, '(5x,"freq :",1x,es13.6)') rdhc%freq - WRITE(*, '(5x,"polar :",1x,es13.6)') rdhc%polar - WRITE(*, '(5x,"wave :",1x,es13.6)') rdhc%wave - WRITE(*, '(5x,"varch :",1x,es13.6)') rdhc%varch - WRITE(*, '(5x,"tlapmean :",1x,es13.6)') rdhc%tlapmean - WRITE(*, '(5x,"iuse :",1x,i0)') rdhc%iuse - WRITE(*, '(5x,"nuchan :",1x,i0)') rdhc%nuchan - WRITE(*, '(5x,"iochan :",1x,i0)') rdhc%iochan - END SUBROUTINE RadDiag_Hdr_Channel_Inspect - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_Hdr_DefineVersion -! -! PURPOSE: -! Subroutine to return the module version information. -! -! CALLING SEQUENCE: -! CALL RadDiag_Hdr_DefineVersion( Id ) -! -! OUTPUTS: -! Id: Character string containing the version Id information -! for the module. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - SUBROUTINE RadDiag_Hdr_DefineVersion( Id ) - CHARACTER(*), INTENT(OUT) :: Id - Id = MODULE_VERSION_ID - END SUBROUTINE RadDiag_Hdr_DefineVersion - -END MODULE RadDiag_Hdr_Define diff --git a/util/Correlated_Obs/RadDiag_IO.f90 b/util/Correlated_Obs/RadDiag_IO.f90 deleted file mode 100644 index 4c862469e..000000000 --- a/util/Correlated_Obs/RadDiag_IO.f90 +++ /dev/null @@ -1,826 +0,0 @@ -! -! RadDiag_IO -! -! Module to read GSI radiance diagnostic files -! - -MODULE RadDiag_IO - - ! ----------------- - ! Environment setup - ! ----------------- - ! Module usage - USE kinds, only: sp=>r_kind - USE File_Utility, ONLY: Get_Lun, File_Open - USE Message_Handler, ONLY: SUCCESS, FAILURE, EOF, Display_Message - USE RadDiag_Define, ONLY: RadDiag_Hdr_Scalar_type , & - RadDiag_Hdr_Channel_type, & - RadDiag_Hdr_type , & - RadDiag_Hdr_Associated , & - RadDiag_Hdr_Destroy , & - RadDiag_Hdr_Create , & - RADDIAG_N_FPELEMENTS, & - RADDIAG_N_CHELEMENTS, & - RADDIAG_N_PRELEMENTS, & - RadDiag_Data_Scalar_type , & - RadDiag_Data_Channel_type, & - RadDiag_Data_type , & - RadDiag_Data_Associated , & - RadDiag_Data_Destroy , & - RadDiag_Data_Create - ! Disable implicit typing - IMPLICIT NONE - - - ! --------------------- - ! Explicit visibilities - ! --------------------- - PRIVATE - ! Inherited derived type definitions - PUBLIC :: RadDiag_Hdr_type - PUBLIC :: RadDiag_Data_type - ! Inherited module subprograms - PUBLIC :: RadDiag_Hdr_Associated - PUBLIC :: RadDiag_Hdr_Destroy - PUBLIC :: RadDiag_Hdr_Create - PUBLIC :: RadDiag_Data_Associated - PUBLIC :: RadDiag_Data_Destroy - PUBLIC :: RadDiag_Data_Create - ! Module parameters - PUBLIC :: RADDIAG_READMODE - PUBLIC :: RADDIAG_WRITEMODE - PUBLIC :: RADDIAG_APPENDMODE - ! Module subprograms - PUBLIC :: RadDiag_OpenFile - PUBLIC :: RadDiag_CloseFile - PUBLIC :: RadDiag_Hdr_ReadFile - PUBLIC :: RadDiag_Data_ReadFile - PUBLIC :: RadDiag_Hdr_WriteFile - PUBLIC :: RadDiag_Data_WriteFile - PUBLIC :: RadDiag_IOVersion - - - ! ----------------- - ! Module parameters - ! ----------------- - ! Defined file access modes - INTEGER, PARAMETER :: RADDIAG_READMODE = 1 - INTEGER, PARAMETER :: RADDIAG_WRITEMODE = 2 - INTEGER, PARAMETER :: RADDIAG_APPENDMODE = 3 - CHARACTER(*), PARAMETER :: RADDIAG_MODENAME(3) = (/'read ','write ','append'/) - ! Module version id - CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & - '$Id: RadDiag_IO.f90 9040 2010-07-29 17:01:49Z Michael.Lueken@noaa.gov $' - ! Default message length - INTEGER, PARAMETER :: ML = 256 - - -CONTAINS - - -!------------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! RadDiag_OpenFile -! -! PURPOSE: -! Function to open a GSI radiance diagnostic file for reading or writing. -! -! CALLING SEQUENCE: -! Error_Status = RadDiag_OpenFile( Filename, & ! Input -! FileID, & ! Output -! AccessMode = AccessMode ) ! Optional input -! -! INPUTS: -! Filename: Character string specifying the name of a -! GSI Radiance diagnostic data file to open. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! OUTPUTS: -! FileID: File logical unit number to be used for for subsequent -! file access. Value is set to zero if an error occurs. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT) -! -! OPTIONAL INPUTS: -! AccessMode: Integer flag specifying the type of file access required. -! Valid parameter values are: -! RADDIAG_READMODE: Open existing file for reading. [DEFAULT] -! RADDIAG_WRITEMODE: Open new file for writing. -! RADDIAG_APPENDMODE: Open existing file for writing. -! If not specified, RADDIAG_READMODE is the default. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN), OPTIONAL -! -! FUNCTION RESULT: -! Error_Status: The return value is an integer defining the error status. -! The error codes are defined in the Message_Handler module. -! If == SUCCESS, the file open was successful -! == FAILURE, an unrecoverable error occurred. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! -!:sdoc-: -!------------------------------------------------------------------------------------ - - FUNCTION RadDiag_OpenFile( & - Filename , & ! Input - FileID , & ! Output - AccessMode ) & ! Optional input - RESULT( err_stat ) - ! Arguments - CHARACTER(*), INTENT(IN) :: Filename - INTEGER, INTENT(OUT) :: FileID - INTEGER, OPTIONAL, INTENT(IN) :: AccessMode - ! Function result - INTEGER :: err_stat - ! Local Parameters - CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'RadDiag_OpenFile' - ! Local Variables - CHARACTER(ML) :: msg - INTEGER :: fid - INTEGER :: mode - INTEGER :: io_stat - CHARACTER(10) :: File_Status - CHARACTER(10) :: File_Position - CHARACTER(10) :: File_Action - - - ! Set up - err_stat = SUCCESS - FileID = 0 - ! ...Open the file for reading by default - Mode = RADDIAG_READMODE - IF ( PRESENT(AccessMode) ) Mode = AccessMode - - - ! Assign the OPEN specifiers - SELECT CASE ( Mode ) - CASE (RADDIAG_READMODE) - File_Status = 'OLD' - File_Position = 'ASIS' - File_Action = 'READ' - CASE (RADDIAG_WRITEMODE) - File_Status = 'REPLACE' - File_Position = 'ASIS' - File_Action = 'WRITE' - CASE (RADDIAG_APPENDMODE) - File_Status = 'UNKNOWN' - File_Position = 'APPEND' - File_Action = 'READWRITE' - CASE DEFAULT - err_stat = FAILURE - msg = 'Invalid RadDiag file access mode.' - CALL Display_Message( ROUTINE_NAME, msg, err_stat ) - RETURN - END SELECT - -!fid=FileID - ! Get a free unit number - fid = Get_Lun() - IF ( fid < 0 ) THEN - err_stat = FAILURE - msg = 'Error obtaining file unit number for '//TRIM(Filename) - CALL Display_Message( ROUTINE_NAME, msg, err_stat ) - RETURN - END IF - - - ! Open the file - OPEN( fid, FILE = Filename, & - STATUS = File_Status, & - POSITION = File_Position, & - ACTION = File_Action, & - ACCESS = 'SEQUENTIAL', & - FORM = 'UNFORMATTED', & - CONVERT = 'big_endian', & - IOSTAT = io_stat ) - IF ( io_stat /= 0 ) THEN - err_stat = FAILURE - WRITE( msg,'("Error opening ",a," for ",a," access. IOSTAT = ",i0)' ) & - TRIM(Filename), TRIM(RADDIAG_MODENAME(Mode)), io_stat - CALL Display_Message( ROUTINE_NAME, msg, err_stat ) - RETURN - END IF - - - ! Assign the output argument - FileID = fid - - END FUNCTION RadDiag_OpenFile -FUNCTION RadDiag_CloseFile( & - FileID ) & ! Input - RESULT( err_stat ) - ! Arguments - INTEGER, INTENT(IN) :: FileID - ! Function result - INTEGER :: err_stat - ! Local Parameters - CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'RadDiag_CloseFile' - ! Local Variables - CHARACTER(ML) :: msg -! INTEGER :: fid -! INTEGER :: mode - INTEGER :: io_stat -! CHARACTER(10) :: File_Status -! CHARACTER(10) :: File_Position -! CHARACTER(10) :: File_Action - msg='file close error' - Close(FileID,IOSTAT=io_stat) - IF ( io_stat /= 0 ) THEN - err_stat = FAILURE - CALL Display_Message( ROUTINE_NAME, msg, err_stat ) - RETURN - END IF - - END FUNCTION RadDiag_CloseFile - -!------------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! RadDiag_Hdr_ReadFile -! -! PURPOSE: -! Function to read header data from a GSI radiance diagnostic file -! -! CALLING SEQUENCE: -! Error_Status = RadDiag_Hdr_ReadFile( FileID, & ! Input -! RadDiag_Hdr ) ! Output -! -! INPUTS: -! FileID: File logical unit number of the radiance diagnostic file -! to read. Returned from call to RadDiag_OpenFile() function. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! OUTPUTS: -! RadDiag_Hdr: RadDiag header structure read from file. -! UNITS: N/A -! TYPE: TYPE(RadDiag_Hdr_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT) -! -! FUNCTION RESULT: -! Error_Status: The return value is an integer defining the error status. -! The error codes are defined in the ERROR_HANDLER module. -! If == SUCCESS the file read was successful. -! == FAILURE an error occurred reading the file. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! -!:sdoc-: -!------------------------------------------------------------------------------------ - - FUNCTION RadDiag_Hdr_ReadFile( & - FileID , & ! Input - RadDiag_Hdr ) & ! Output - RESULT( err_stat ) - ! Arguments - INTEGER, INTENT(IN) :: FileID - TYPE(RadDiag_Hdr_type), INTENT(OUT) :: RadDiag_Hdr - ! Function result - INTEGER :: err_stat - ! Local parameters - CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'RadDiag_Hdr_ReadFile' - ! Local variables - CHARACTER(ML) :: msg - CHARACTER(256) :: Filename - INTEGER :: io_stat - INTEGER :: i, reclen - TYPE(RadDiag_Hdr_Scalar_type) :: Scalar - - ! Set up - err_stat = SUCCESS - ! ...Make sure the file is open - IF ( .NOT. File_Open(FileId) ) THEN - msg = 'File is not open.' - CALL Hdr_Read_CleanUp(); RETURN - END IF - ! ...Get the filename - INQUIRE( UNIT=FileID, NAME=Filename) - inquire(iolength=reclen) Scalar%nchan - - ! Read the fixed part of the header - READ( FileID, IOSTAT=io_stat ) Scalar - IF ( io_stat /= 0 ) THEN - WRITE( msg,'("Error reading RadDiag header fixed portion from ",a,". IOSTAT = ",i0)' ) & - TRIM(Filename), io_stat - CALL Hdr_Read_CleanUp(); RETURN - END IF - ! Check the header format/dimensions -! IF( Scalar%ireal /= RADDIAG_N_FPELEMENTS .OR. & ! Number of floating point elements -! Scalar%ipchan /= RADDIAG_N_CHELEMENTS .OR. & ! Number of channel elements -! Scalar%npred /= RADDIAG_N_PRELEMENTS ) THEN ! Number of bias correction terms -! msg = 'Invalid RadDiag_Hdr dimension values.' -! CALL Hdr_Read_CleanUp(); RETURN -! END IF - - - ! Allocate the RadDiag_Hdr structure - CALL RadDiag_Hdr_Create( RadDiag_Hdr, Scalar%nchan ) - IF ( .NOT. RadDiag_Hdr_Associated(RadDiag_Hdr) ) THEN - msg = 'Error allocating RadDiag_Hdr structure' - CALL Hdr_Read_CleanUp(); RETURN - END IF - - ! Copy the fixed portion of the header - RadDiag_Hdr%Scalar = Scalar - - - ! Read the channel portion of the header - DO i = 1, RadDiag_Hdr%n_Channels - READ( FileID, IOSTAT=io_stat ) RadDiag_Hdr%Channel(i) -! READ( FileID, IOSTAT=io_stat ) RadDiag_Hdr%Channel(i)%freq , & -! RadDiag_Hdr%Channel(i)%polar , & -! RadDiag_Hdr%Channel(i)%wave , & -! RadDiag_Hdr%Channel(i)%varch , & -! RadDiag_Hdr%Channel(i)%tlapmean, & -! RadDiag_Hdr%Channel(i)%iuse , & -! RadDiag_Hdr%Channel(i)%nuchan , & -! RadDiag_Hdr%Channel(i)%iochan - IF ( io_stat /= 0 ) THEN - WRITE( msg,'("Error reading RadDiag header channel index ",i0,& - &" data from ",a,". IOSTAT = ",i0)' ) & - i, TRIM(Filename), io_stat - CALL Hdr_Read_CleanUp(); RETURN - END IF - END DO - - CONTAINS - - SUBROUTINE Hdr_Read_CleanUp() - IF ( File_Open(FileId) ) THEN - CLOSE( FileId,IOSTAT=io_stat ) - IF ( io_stat /= 0 ) msg = TRIM(msg)//'; Error closing input file during error cleanup.' - END IF - CALL RadDiag_Hdr_Destroy( RadDiag_Hdr ) - err_stat = FAILURE - CALL Display_Message( ROUTINE_NAME, msg, err_stat ) - END SUBROUTINE Hdr_Read_CleanUp - - END FUNCTION RadDiag_Hdr_ReadFile - - -!------------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! RadDiag_Data_ReadFile -! -! PURPOSE: -! Function to read data from a GSI radiance diagnostic file -! -! CALLING SEQUENCE: -! Error_Status = RadDiag_Data_ReadFile( FileID, & ! Input -! RadDiag_Hdr, & ! Input -! RadDiag_Data ) ! Output -! -! INPUTS: -! FileID: File unit number of the radiance diagnostic file to read. -! Returned from call to Open_RadDiag() function. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! RadDiag_Hdr: RadDiag header structure for the file. -! UNITS: N/A -! TYPE: TYPE(RadDiag_Hdr_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! OUTPUTS: -! RadDiag_Data: RadDiag data structure read from file. -! UNITS: N/A -! TYPE: TYPE(RadDiag_Data_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT) -! -! FUNCTION RESULT: -! Error_Status: The return value is an integer defining the error status. -! The error codes are defined in the ERROR_HANDLER module. -! If == SUCCESS the file read was successful. -! == EOF the end-of-file was reached -! == FAILURE an error occurred reading the file. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -!:sdoc-: -!------------------------------------------------------------------------------------ - - FUNCTION RadDiag_Data_ReadFile( & - FileID , & ! Input - RadDiag_Hdr , & ! Input - RadDiag_Data ) & ! Output - RESULT( err_stat ) - ! Arguments - INTEGER, INTENT(IN) :: FileID - TYPE(RadDiag_Hdr_type), INTENT(IN) :: RadDiag_Hdr - TYPE(RadDiag_Data_type), INTENT(OUT) :: RadDiag_Data - ! Function result - INTEGER :: err_stat - ! Local parameters - CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'RadDiag_Data_ReadFile' - ! Local variables - CHARACTER(ML) :: msg - CHARACTER(256) :: Filename - INTEGER :: io_stat - INTEGER :: i - REAL(sp), DIMENSION(RadDiag_Hdr%Scalar%iextra) :: Extra - - ! Set up - err_stat = SUCCESS - ! ...Make sure the file is open - IF ( .NOT. File_Open(FileId) ) THEN - msg = 'File is not open.' - CALL Data_Read_CleanUp(); RETURN - END IF - ! ...Get the filename - INQUIRE( UNIT=FileID, NAME=Filename ) - - - ! Allocate the RadDiag_Data structure - CALL RadDiag_Data_Create( RadDiag_Data, RadDiag_Hdr%n_Channels ) - IF ( .NOT. RadDiag_Data_Associated(RadDiag_Data) ) THEN - msg = 'Error allocating RadDiag_Data structure' - CALL Data_Read_CleanUp(); RETURN - END IF - - - ! Read all the data - READ( FileID, IOSTAT=io_stat ) & - RadDiag_Data%Scalar, & - (RadDiag_Data%Channel(i), i=1,RadDiag_Data%n_Channels), & - Extra -! RadDiag_Data%Scalar%lat , & -! RadDiag_Data%Scalar%lon , & -! RadDiag_Data%Scalar%zsges , & -! RadDiag_Data%Scalar%obstime , & -! RadDiag_Data%Scalar%senscn_pos, & -! RadDiag_Data%Scalar%satzen_ang, & -! RadDiag_Data%Scalar%satazm_ang, & -! RadDiag_Data%Scalar%solzen_ang, & -! RadDiag_Data%Scalar%solazm_ang, & -! RadDiag_Data%Scalar%sungln_ang, & -! RadDiag_Data%Scalar%water_frac, & -! RadDiag_Data%Scalar%land_frac , & -! RadDiag_Data%Scalar%ice_frac , & -! RadDiag_Data%Scalar%snow_frac , & -! RadDiag_Data%Scalar%water_temp, & -! RadDiag_Data%Scalar%land_temp , & -! RadDiag_Data%Scalar%ice_temp , & -! RadDiag_Data%Scalar%snow_temp , & -! RadDiag_Data%Scalar%soil_temp , & -! RadDiag_Data%Scalar%soil_mois , & -! RadDiag_Data%Scalar%land_type , & -! RadDiag_Data%Scalar%veg_frac , & -! RadDiag_Data%Scalar%snow_depth, & -! RadDiag_Data%Scalar%sfc_wndspd, & -! RadDiag_Data%Scalar%qcdiag1 , & -! RadDiag_Data%Scalar%qcdiag2 , ( RadDiag_Data%Channel(i)%tbobs , & -! RadDiag_Data%Channel(i)%omgbc , & -! RadDiag_Data%Channel(i)%omgnbc, & -! RadDiag_Data%Channel(i)%errinv, & -! RadDiag_Data%Channel(i)%qcmark, & -! RadDiag_Data%Channel(i)%emiss , & -! RadDiag_Data%Channel(i)%tlap , & -! RadDiag_Data%Channel(i)%bifix , & -! RadDiag_Data%Channel(i)%bilap , & -! RadDiag_Data%Channel(i)%bilap2, & -! RadDiag_Data%Channel(i)%bicons, & -! RadDiag_Data%Channel(i)%biang , & -! RadDiag_Data%Channel(i)%biclw , & -! i=1,RadDiag_Data%n_Channels ), Extra - ! ...Check for error - IF ( io_stat > 0 ) THEN - WRITE( msg,'("Error reading RadDiag Data from ",a,". IOSTAT = ",i0)' ) & - TRIM(Filename), io_stat - CALL Data_Read_CleanUp(); RETURN - END IF - - - ! Check for end of file - IF ( io_stat < 0 ) THEN - err_stat = EOF - WRITE( msg,'("End-of-file ",a," reached.")' ) TRIM(Filename) - CALL Display_Message( ROUTINE_NAME, msg, err_stat ) - END IF - - CONTAINS - - SUBROUTINE Data_Read_CleanUp() - IF ( File_Open(FileId) ) THEN - CLOSE( FileId,IOSTAT=io_stat ) - IF ( io_stat /= 0 ) msg = TRIM(msg)//'; Error closing input file during error cleanup.' - END IF - CALL RadDiag_Data_Destroy( RadDiag_Data ) - err_stat = FAILURE - CALL Display_Message( ROUTINE_NAME, msg, err_stat ) - END SUBROUTINE Data_Read_CleanUp - - END FUNCTION RadDiag_Data_ReadFile - - -!------------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! RadDiag_Hdr_WriteFile -! -! PURPOSE: -! Function to write header data to a GSI radiance diagnostic file -! -! CALLING SEQUENCE: -! Error_Status = RadDiag_Hdr_WriteFile( FileID, & ! Input -! RadDiag_Hdr ) ! Input -! -! INPUTS: -! FileID: File logical unit number of the radiance diagnostic file -! to write. Returned from call to RadDiag_OpenFile() function. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! RadDiag_Hdr: RadDiag header structure to write to file. -! UNITS: N/A -! TYPE: TYPE(RadDiag_Hdr_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! Error_Status: The return value is an integer defining the error status. -! The error codes are defined in the ERROR_HANDLER module. -! If == SUCCESS the file write was successful. -! == FAILURE an error occurred writing the file. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! -!:sdoc-: -!------------------------------------------------------------------------------------ - - FUNCTION RadDiag_Hdr_WriteFile( & - FileID , & ! Input - RadDiag_Hdr ) & ! Input - RESULT( err_stat ) - ! Arguments - INTEGER, INTENT(IN) :: FileID - TYPE(RadDiag_Hdr_type), INTENT(IN) :: RadDiag_Hdr - ! Function result - INTEGER :: err_stat - ! Local parameters - CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'RadDiag_Hdr_WriteFile' - ! Local variables - CHARACTER(ML) :: msg - CHARACTER(256) :: Filename - INTEGER :: io_stat - INTEGER :: i - - ! Set up - err_stat = SUCCESS - ! ...Make sure the file is open - IF ( .NOT. File_Open(FileId) ) THEN - msg = 'File is not open.' - CALL Hdr_Write_CleanUp(); RETURN - END IF - ! ...Get the filename - INQUIRE( UNIT=FileID, NAME=Filename ) - - - ! Write the fixed part of the header - WRITE( FileID, IOSTAT=io_stat ) RadDiag_Hdr%Scalar -! WRITE( FileID, IOSTAT=io_stat ) RadDiag_Hdr%Scalar%isis , & -! RadDiag_Hdr%Scalar%id , & -! RadDiag_Hdr%Scalar%obstype, & -! RadDiag_Hdr%Scalar%jiter , & -! RadDiag_Hdr%Scalar%nchan , & -! RadDiag_Hdr%Scalar%npred , & -! RadDiag_Hdr%Scalar%idate , & -! RadDiag_Hdr%Scalar%ireal , & -! RadDiag_Hdr%Scalar%ipchan , & -! RadDiag_Hdr%Scalar%iextra , & -! RadDiag_Hdr%Scalar%jextra - IF ( io_stat /= 0 ) THEN - WRITE( msg,'("Error writing RadDiag header fixed portion to ",a,". IOSTAT = ",i0)' ) & - TRIM(Filename), io_stat - CALL Hdr_Write_CleanUp(); RETURN - END IF - - - ! Write the channel portion of the header - DO i = 1, RadDiag_Hdr%n_Channels - WRITE( FileID, IOSTAT=io_stat ) RadDiag_Hdr%Channel(i) -! WRITE( FileID, IOSTAT=io_stat ) RadDiag_Hdr%Channel(i)%freq , & -! RadDiag_Hdr%Channel(i)%polar , & -! RadDiag_Hdr%Channel(i)%wave , & -! RadDiag_Hdr%Channel(i)%varch , & -! RadDiag_Hdr%Channel(i)%tlapmean, & -! RadDiag_Hdr%Channel(i)%iuse , & -! RadDiag_Hdr%Channel(i)%nuchan , & -! RadDiag_Hdr%Channel(i)%iochan - IF ( io_stat /= 0 ) THEN - WRITE( msg,'("Error writing RadDiag header channel index ",i0,& - &" data to ",a,". IOSTAT = ",i0)' ) & - i, TRIM(Filename), io_stat - CALL Hdr_Write_CleanUp(); RETURN - END IF - END DO - - CONTAINS - - SUBROUTINE Hdr_Write_CleanUp() - IF ( File_Open(FileId) ) THEN - CLOSE( FileId,IOSTAT=io_stat ) - IF ( io_stat /= 0 ) msg = TRIM(msg)//'; Error closing output file during error cleanup.' - END IF - err_stat = FAILURE - CALL Display_Message( ROUTINE_NAME, msg, err_stat ) - END SUBROUTINE Hdr_Write_CleanUp - - END FUNCTION RadDiag_Hdr_WriteFile - - -!------------------------------------------------------------------------------------ -!:sdoc+: -! -! NAME: -! RadDiag_Data_WriteFile -! -! PURPOSE: -! Function to write data to a GSI radiance diagnostic file -! -! CALLING SEQUENCE: -! Error_Status = RadDiag_Data_WriteFile( FileID, & ! Input -! RadDiag_Hdr, & ! Input -! RadDiag_Data ) ! Input -! -! INPUTS: -! FileID: File unit number of the radiance diagnostic file to write. -! Returned from call to Open_RadDiag() function. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! RadDiag_Hdr: RadDiag header structure for the file (already written). -! UNITS: N/A -! TYPE: TYPE(RadDiag_Hdr_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! RadDiag_Data: RadDiag data structure to write to file. -! UNITS: N/A -! TYPE: TYPE(RadDiag_Data_type) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(IN) -! -! FUNCTION RESULT: -! Error_Status: The return value is an integer defining the error status. -! The error codes are defined in the ERROR_HANDLER module. -! If == SUCCESS the file write was successful. -! == FAILURE an error occurred writing the file. -! UNITS: N/A -! TYPE: INTEGER -! DIMENSION: Scalar -!:sdoc-: -!------------------------------------------------------------------------------------ - - FUNCTION RadDiag_Data_WriteFile( & - FileID , & ! Input - RadDiag_Hdr , & ! Input - RadDiag_Data ) & ! Input - RESULT( err_stat ) - ! Arguments - INTEGER, INTENT(IN) :: FileID - TYPE(RadDiag_Hdr_type), INTENT(IN) :: RadDiag_Hdr - TYPE(RadDiag_Data_type), INTENT(IN) :: RadDiag_Data - ! Function result - INTEGER :: err_stat - ! Local parameters - CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'RadDiag_Data_WriteFile' - ! Local variables - CHARACTER(ML) :: msg - CHARACTER(256) :: Filename - INTEGER :: io_stat - INTEGER :: i - REAL(sp), DIMENSION(RadDiag_Hdr%Scalar%iextra) :: Extra - - ! Set up - err_stat = SUCCESS - ! ...Make sure the file is open - IF ( .NOT. File_Open(FileId) ) THEN - msg = 'File is not open.' - CALL Data_Write_CleanUp(); RETURN - END IF - ! ...Get the filename - INQUIRE( UNIT=FileID, NAME=Filename ) - - - ! Write all the data - Extra = 0.0_sp - WRITE( FileID, IOSTAT=io_stat ) & - RadDiag_Data%Scalar, & - (RadDiag_Data%Channel(i), i=1,RadDiag_Data%n_Channels), & - Extra -! RadDiag_Data%Scalar%lat , & -! RadDiag_Data%Scalar%lon , & -! RadDiag_Data%Scalar%zsges , & -! RadDiag_Data%Scalar%obstime , & -! RadDiag_Data%Scalar%senscn_pos, & -! RadDiag_Data%Scalar%satzen_ang, & -! RadDiag_Data%Scalar%satazm_ang, & -! RadDiag_Data%Scalar%solzen_ang, & -! RadDiag_Data%Scalar%solazm_ang, & -! RadDiag_Data%Scalar%sungln_ang, & -! RadDiag_Data%Scalar%water_frac, & -! RadDiag_Data%Scalar%land_frac , & -! RadDiag_Data%Scalar%ice_frac , & -! RadDiag_Data%Scalar%snow_frac , & -! RadDiag_Data%Scalar%water_temp, & -! RadDiag_Data%Scalar%land_temp , & -! RadDiag_Data%Scalar%ice_temp , & -! RadDiag_Data%Scalar%snow_temp , & -! RadDiag_Data%Scalar%soil_temp , & -! RadDiag_Data%Scalar%soil_mois , & -! RadDiag_Data%Scalar%land_type , & -! RadDiag_Data%Scalar%veg_frac , & -! RadDiag_Data%Scalar%snow_depth, & -! RadDiag_Data%Scalar%sfc_wndspd, & -! RadDiag_Data%Scalar%qcdiag1 , & -! RadDiag_Data%Scalar%qcdiag2 , ( RadDiag_Data%Channel(i)%tbobs , & -! RadDiag_Data%Channel(i)%omgbc , & -! RadDiag_Data%Channel(i)%omgnbc, & -! RadDiag_Data%Channel(i)%errinv, & -! RadDiag_Data%Channel(i)%qcmark, & -! RadDiag_Data%Channel(i)%emiss , & -! RadDiag_Data%Channel(i)%tlap , & -! RadDiag_Data%Channel(i)%bifix , & -! RadDiag_Data%Channel(i)%bilap , & -! RadDiag_Data%Channel(i)%bilap2, & -! RadDiag_Data%Channel(i)%bicons, & -! RadDiag_Data%Channel(i)%biang , & -! RadDiag_Data%Channel(i)%biclw , & -! i=1,RadDiag_Data%nChannels ), Extra - IF ( io_stat /= 0 ) THEN - WRITE( msg,'("Error writing RadDiag Data to ",a,". IOSTAT = ",i0)' ) & - TRIM(Filename), io_stat - CALL Data_Write_CleanUp(); RETURN - END IF - - CONTAINS - - SUBROUTINE Data_Write_CleanUp() - IF ( File_Open(FileId) ) THEN - CLOSE( FileId,IOSTAT=io_stat ) - IF ( io_stat /= 0 ) msg = TRIM(msg)//'; Error closing output file during error cleanup.' - END IF - err_stat = FAILURE - CALL Display_Message( ROUTINE_NAME, msg, err_stat ) - END SUBROUTINE Data_Write_CleanUp - - END FUNCTION RadDiag_Data_WriteFile - - -!-------------------------------------------------------------------------------- -!:sdoc+: -! -! NAME: -! RadDiag_IOVersion -! -! PURPOSE: -! Subroutine to return the module version information. -! -! CALLING SEQUENCE: -! CALL RadDiag_IOVersion( Id ) -! -! OUTPUTS: -! Id: Character string containing the version Id information -! for the module. -! UNITS: N/A -! TYPE: CHARACTER(*) -! DIMENSION: Scalar -! ATTRIBUTES: INTENT(OUT) -! -!:sdoc-: -!-------------------------------------------------------------------------------- - - SUBROUTINE RadDiag_IOVersion( Id ) - CHARACTER(*), INTENT(OUT) :: Id - Id = MODULE_VERSION_ID - END SUBROUTINE RadDiag_IOVersion - -END MODULE RadDiag_IO diff --git a/util/Correlated_Obs/cconstants.f90 b/util/Correlated_Obs/cconstants.f90 new file mode 100644 index 000000000..3a5c8b485 --- /dev/null +++ b/util/Correlated_Obs/cconstants.f90 @@ -0,0 +1,29 @@ +module cconstants +!This module contains the constants required for the cov_calc program +!Kristen Bathmann +!5-2015 + +use ckinds, only: r_kind, i_kind +implicit none +public:: zero, zero_int, small, one, one_int +public:: two, two_int, four_int, five, sixty, one_hundred, threesixty +public:: rad, pi + +!numbers +real(r_kind), parameter:: small=0.00001_r_kind +real(r_kind), parameter:: zero=0.0_r_kind +integer(i_kind), parameter:: zero_int=0 +real(r_kind), parameter:: one=1.0_r_kind +real(r_kind), parameter:: one_int=1 +real(r_kind), parameter:: two=2.0_r_kind +integer(i_kind), parameter:: two_int=2 +integer(i_kind), parameter:: four_int=4 +real(r_kind), parameter:: five=5.0_r_kind +real(r_kind), parameter:: sixty=60.0_r_kind +real(r_kind), parameter:: one_hundred=100.0_r_kind +real(r_kind), parameter:: threesixty=360.0_r_kind + +!other constants +real(r_kind), parameter:: rad=6378.137_r_kind !radius of the earth +real(r_kind), parameter:: pi=3.1415926535898_r_kind +end module cconstants diff --git a/util/Correlated_Obs/ckinds.f90 b/util/Correlated_Obs/ckinds.f90 new file mode 100644 index 000000000..3dcf04d40 --- /dev/null +++ b/util/Correlated_Obs/ckinds.f90 @@ -0,0 +1,110 @@ +module ckinds +!$$$ module documentation block +! . . . . +! module: kinds +! prgmmr: treadon org: np23 date: 2004-08-15 +! +! abstract: Module to hold specification kinds for variable declaration. +! This module is based on (copied from) Paul vanDelst's +! type_kinds module found in the community radiative transfer +! model +! +! module history log: +! 2004-08-15 treadon +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! The numerical data types defined in this module are: +! i_byte - specification kind for byte (1-byte) integer variable +! i_short - specification kind for short (2-byte) integer variable +! i_long - specification kind for long (4-byte) integer variable +! i_llong - specification kind for double long (8-byte) integer variable +! r_single - specification kind for single precision (4-byte) real variable +! r_double - specification kind for double precision (8-byte) real variable +! r_quad - specification kind for quad precision (16-byte) real variable +! +! i_kind - generic specification kind for default integer +! r_kind - generic specification kind for default floating point +! r_radstat - specification for precision within radstat files +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + implicit none + private + +! Integer type definitions below + +! Integer types + integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer + integer, parameter, public :: i_short = selected_int_kind(4) ! short integer + integer, parameter, public :: i_long = selected_int_kind(8) ! long integer + integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer + integer, parameter, public :: i_llong = max( llong_t, i_long ) + +! Expected 8-bit byte sizes of the integer kinds + integer, parameter, public :: num_bytes_for_i_byte = 1 + integer, parameter, public :: num_bytes_for_i_short = 2 + integer, parameter, public :: num_bytes_for_i_long = 4 + integer, parameter, public :: num_bytes_for_i_llong = 8 + +! Define arrays for default definition + integer, parameter, private :: num_i_kinds = 4 + integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & + i_byte, i_short, i_long, i_llong /) + integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & + num_bytes_for_i_byte, num_bytes_for_i_short, & + num_bytes_for_i_long, num_bytes_for_i_llong /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** + integer, parameter, private :: default_integer = 3 ! 1=byte, + ! 2=short, + ! 3=long, + ! 4=llong + integer, parameter, public :: i_kind = integer_types( default_integer ) + integer, parameter, public :: num_bytes_for_i_kind = & + integer_byte_sizes( default_integer ) + + +! Real definitions below + +! Real types + integer, parameter, public :: r_single = selected_real_kind(6) ! single precision + integer, parameter, public :: r_double = selected_real_kind(15) ! double precision + integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision + integer, parameter, public :: r_quad = max( quad_t, r_double ) + +! Expected 8-bit byte sizes of the real kinds + integer, parameter, public :: num_bytes_for_r_single = 4 + integer, parameter, public :: num_bytes_for_r_double = 8 + integer, parameter, public :: num_bytes_for_r_quad = 16 + +! Define arrays for default definition + integer, parameter, private :: num_r_kinds = 3 + integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & + r_single, r_double, r_quad /) + integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & + num_bytes_for_r_single, num_bytes_for_r_double, & + num_bytes_for_r_quad /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** + integer, parameter, private :: default_real = 1 ! 1=single, + ! 2=double, + ! 3=quad + integer, parameter, private :: default_radstat = 1 ! 1=single, + ! 2=double, + ! 3=quad + integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: r_radstat = real_kinds( default_radstat ) + integer, parameter, public :: num_bytes_for_r_kind = & + real_byte_sizes( default_real ) + +end module ckinds diff --git a/util/Correlated_Obs/constants.f90 b/util/Correlated_Obs/constants.f90 deleted file mode 100644 index 2902120d8..000000000 --- a/util/Correlated_Obs/constants.f90 +++ /dev/null @@ -1,31 +0,0 @@ -module constants -!This module contains the constants required for the cov_calc program -!Kristen Bathmann -!5-2015 - -use kinds, only: r_kind, i_kind -implicit none -public:: zero, zero_int, small, smaller, one, one_int -public:: two, two_int, four_int, five, sixty, one_hundred, threesixty -public:: rad, pi - -!numbers -real(r_kind), parameter:: small=0.00001_r_kind -real(r_kind), parameter:: smaller=0.00000001_r_kind -real(r_kind), parameter:: zero=0.0_r_kind -integer(i_kind), parameter:: zero_int=0 -real(r_kind), parameter:: one=1.0_r_kind -real(r_kind), parameter:: one_int=1 -real(r_kind), parameter:: two=2.0_r_kind -integer(i_kind), parameter:: two_int=2 -integer(i_kind), parameter:: four_int=4 -real(r_kind), parameter:: five=5.0_r_kind -real(r_kind), parameter:: sixty=60.0_r_kind -real(r_kind), parameter:: one_hundred=100.0_r_kind -real(r_kind), parameter:: threesixty=360.0_r_kind - -!other constants -real(r_kind), parameter:: rad=6378.137_r_kind !radius of the earth -real(r_kind), parameter:: pi=3.1415926535898_r_kind - -end module constants diff --git a/util/Correlated_Obs/cov_calc.f90 b/util/Correlated_Obs/cov_calc.f90 index 1402b6da6..87b741a92 100644 --- a/util/Correlated_Obs/cov_calc.f90 +++ b/util/Correlated_Obs/cov_calc.f90 @@ -5,25 +5,13 @@ program cov_calc !Kristen Bathmann !5-2015 -use kinds, only: r_kind, i_kind +use ckinds, only: r_kind, i_kind use matrix_tools use obs_tools use pairs -use constants, only: zero_int,zero,one,two,five, & - small, sixty, threesixty -use RadDiag_IO, only: RadDiag_Hdr_type, & - RadDiag_Data_type, & - RadDiag_ReadMode, & - RadDiag_WriteMode, & - RadDiag_AppendMode, & - RadDiag_OpenFile, & - RadDiag_CloseFile, & - RadDiag_Hdr_ReadFile, & - RadDiag_Data_ReadFile -use Message_Handler, only: success, warning, failure, eof, & - program_message, display_message -use RadDiag_Define, only: RadDiag_Data_Destroy, & - RadDiag_Hdr_Destroy +use cconstants, only: zero_int,zero,one,two,five, & + small, sixty, threesixty +use readsatobs implicit none @@ -31,11 +19,10 @@ program cov_calc character(*), parameter:: program_name='Compute_Covariance' !loop counters -integer:: i,j, r, c, jj,dd,dis -integer:: tim !time step -integer:: n_pair !number of pairs made for one analysis obs at one time step -integer:: ntimes !number of time steps to process -integer:: nc +integer(i_kind):: j,r, c, dd,dis,ka +integer(i_kind):: tim !time step +integer(i_kind):: n_pair !number of pairs made for one analysis obs at one time step +integer(i_kind):: ntimes !number of time steps to process !file variables character(5):: ges_stub, anl_stub @@ -45,71 +32,33 @@ program cov_calc character(256):: err_file !name of outputted file containing assumed obs errors character(256):: corr_file !name of outputted correlation file character(256):: instr -integer:: Error_Status, gesid, anlid -integer, parameter:: dsize=4500 !cap size on the number of omg's that can be stored at each time step -integer:: read_status, leninstr -integer:: lencov, lencorr, lenwave, lenerr -integer(i_kind):: reclen +integer(i_kind), parameter:: dsize=4500 !cap size on the number of omg's that can be stored at each time step +integer(i_kind):: lencov, lencorr, lenwave, lenerr +integer(i_kind):: reclen, leninstr logical:: out_wave !option to output channel wavenumbers logical:: out_err !option to output assigned obs errors logical:: out_corr !option to output correlation matrix !Diag data -integer:: no_chn !number of instrument channels available -type(RadDiag_Hdr_type):: RadDiag_Hdr !header info about the diag data -type(RadDiag_Data_type):: RadDiag_Data !diag data -real(r_kind), dimension(:,:), allocatable:: ges !background omg data for three files -real(r_kind),dimension(:),allocatable:: anl !analysis omg for one file -integer, dimension(:,:), allocatable:: gesuse !specifies whether a particular background omg should be used -integer, dimension(:), allocatable:: anluse !specifies whether a particular analysis omg should be used -real(r_kind), dimension(:), allocatable:: chaninfo !wavenumbers of assimilated channels -real(r_kind), dimension(:), allocatable:: errout !assumed obs errors of assimilated channels -integer(i_kind):: nch_active !number of assimilated channels for this instrument -integer(i_kind),dimension(:),allocatable:: indR !indices of the assimlated channels -integer:: ng !the number of background omg's for three time steps - -!FOV choice -integer:: Surface_Type, Cloud_Type -integer, parameter:: Sea=1 -integer, parameter:: Land =2 -integer, parameter:: Snow=3 -integer, parameter:: Mixed=4 -integer, parameter:: Ice=5 -integer, parameter:: Snow_and_Ice=6 -integer, parameter:: Clear_FOV=1 -integer, parameter:: Clear_Channel=2 -real(r_kind), parameter:: clear_threshold=0.01_r_kind !if using clear sky data, do not use if above this threshold -real(r_kind), parameter:: sea_threshold=0.99_r_kind !if using sea data, do not use if below this threshold -real(r_kind), parameter:: lower_sea_threshold=0.9_r_kind !if using mixed data, do not use if above this threshold -real(r_kind), parameter:: lower_land_threshold=0.9_r_kind !if using mixed data, do not use if above this threshold -real(r_kind), parameter:: lower_ice_threshold=0.9_r_kind !if using mixed data, do not use if above this threshold -real(r_kind), parameter:: lower_snow_threshold=0.9_r_kind !if using mixed data, do not use if above this threshold -real(r_kind), parameter:: land_threshold=0.99_r_kind !if using land data, do not use if above this threshold -real(r_kind), parameter:: ice_threshold=0.95_r_kind !if using ice data, do not use if below this threshold -real(r_kind), parameter:: snow_threshold=0.99_r_kind !if using snow data, do not use if below this threshold -real(r_kind):: satang - -!Data times -real(r_kind):: time_min !time of obs, relative to time of corresponding diag file -real(r_kind),dimension(:), allocatable:: ges_times !times of background obs, relative to time of first diag file +type(RadData):: Radges,Radanl !actual data from the radstats +integer(i_kind):: netcdf_in +logical:: netcdf +integer(i_kind):: ng, na !the number of omg's real(r_kind):: anl_time !time of analysis obs, relative ot time of first diag file - -!Data locations -real(r_kind), dimension(:,:), allocatable::gesloc !locations (lat,lon) of background obs real(r_kind), dimension(2):: anlloc !location (lat,lon) of analysis obs -integer:: num_bin,num_bins +integer(i_kind):: num_bin,num_bins real(r_kind):: bin_size, timeth real(r_kind),dimension(:),allocatable:: bin_dist real(r_kind)::bin_center !bin center, km, used for Hollingworth Lonnberg method !Covariance Definition -integer, parameter:: hl_method=1 -integer, parameter:: desroziers=2 -integer, parameter:: full_chan=1 -integer:: cov_method, chan_choice -integer,dimension(:), allocatable:: n_pair_hl -integer,dimension(:), allocatable:: obs_pairs -integer,dimension(:,:), allocatable:: obs_pairs_hl +integer(i_kind), parameter:: hl_method=1 +integer(i_kind), parameter:: desroziers=2 +integer(i_kind):: cov_method, chan_choice,Surface_Type,Cloud_Type +real(r_kind):: satang +integer(i_kind),dimension(:), allocatable:: n_pair_hl +integer(i_kind),dimension(:), allocatable:: obs_pairs +integer(i_kind),dimension(:,:), allocatable:: obs_pairs_hl real(r_kind), dimension(:,:), allocatable:: Rcov !the covariance matrix real(r_kind), dimension(:,:), allocatable:: Rcorr !the correlation matrix real(r_kind), dimension(:,:), allocatable:: anl_ave !average value of oma @@ -128,11 +77,14 @@ program cov_calc real(r_kind),dimension(:,:), allocatable:: eigv !Eigenvectors (if reconditioning) real(r_kind), dimension(:,:), allocatable:: Rout real(r_kind):: kreq, mx, mn -integer:: rec_method +integer(i_kind):: rec_method real(r_kind), parameter:: errt=0.0001_r_kind read(5,*) ntimes, Surface_Type, Cloud_Type, satang, instr, out_wave, out_err, & - out_corr, kreq, rec_method, cov_method, chan_choice, timeth, bin_size, bin_center + out_corr, kreq, rec_method, cov_method, chan_choice, timeth, bin_size, & + bin_center, netcdf_in +netcdf=.false. +if (netcdf_in>0) netcdf=.true. if (cov_method==desroziers) then allocate(bin_dist(1)) bin_dist(1)=bin_size @@ -146,6 +98,10 @@ program cov_calc end if leninstr=len_trim(instr) lencov=len_trim('Rcov_') +cov_file='' +corr_file='' +wave_file='' +err_file='' cov_file(1:lencov)='Rcov_' cov_file(lencov+1:lencov+leninstr)=instr lencorr=len_trim('Rcorr_') @@ -160,229 +116,70 @@ program cov_calc ges_stub(1:5)='dges_' anl_stub(1:5)='danl_' -allocate(gesloc(dsize,2)) -allocate(ges_times(dsize)) +tim=1 +call get_filename(tim,ges_stub,gesfile) +call get_chaninfo(trim(gesfile),netcdf,chan_choice) +allocate(Radges%omg(dsize,nch_active)) +allocate(Radges%latlon(dsize,2),Radges%timeobs(dsize)) +allocate(Rcov(nch_active,nch_active)) +allocate(divider(nch_active,nch_active)) +allocate(ges_ave(nch_active,nch_active)) +if (bin_sizezero) then + allocate(eigs(nch_active),eigv(nch_active,nch_active)) + allocate(Rout(nch_active,nch_active)) +end if +Rcov=zero +divider=zero_int +ges_ave=zero +!loop over the files do tim=1,ntimes call get_filename(tim,anl_stub,anlfile) - !we read in one analysis diag file at each time step. - !ges diag data is overwritten when no longer needed call get_filename(tim,ges_stub,gesfile) - !opening ges diag file - Error_Status=RadDiag_OpenFile(trim(gesfile),gesid) - if (Error_Status /= success ) then - call display_message(program_name,'Error opening '//trim(gesfile),failure) - stop - end if - !read ges header - Error_Status=RadDiag_Hdr_ReadFile(gesid,RadDiag_Hdr) - if (Error_Status /= success ) then - call display_message(program_name,'Error reading ges header',failure) - stop - end if - - !allocate - if ((tim==1)) then - no_chn=RadDiag_Hdr%Scalar%nchan - nch_active=0 - i=0 - if ((chan_choice==full_chan)) then - nch_active=no_chn - else - do j=1,no_chn - !only want to use actively assimilated channels - if (RadDiag_Hdr%Channel(j)%iuse.gt.zero) then - nch_active=nch_active+1 - end if - end do - end if - !indicies of the actively assimilated channels, needed - !by the GSI - allocate(indR(nch_active)) - i=0 - do j=1,no_chn - if (chan_choice==full_chan) then - indR(j)=j - else if (RadDiag_Hdr%Channel(j)%iuse.gt.zero) then - i=i+1 - indR(i)=j - end if - end do - allocate(ges(dsize,nch_active)) - allocate(gesuse(dsize,nch_active)) - allocate(Rcov(nch_active,nch_active)) - allocate(divider(nch_active,nch_active)) - allocate(ges_ave(nch_active,nch_active)) - allocate(chaninfo(nch_active),errout(nch_active)) - if (bin_sizezero) then - allocate(eigs(nch_active),eigv(nch_active,nch_active)) - allocate(Rout(nch_active,nch_active)) - end if - do r=1,nch_active - chaninfo(r)=RadDiag_Hdr%Channel(indR(r))%wave - errout(r)=RadDiag_Hdr%Channel(indR(r))%varch - end do - Rcov=zero - divider=zero_int - ges_ave=zero - end if !tim=1 - ng=0 - ges_read_loop: do - read_status=RadDiag_Data_ReadFile(gesid,RadDiag_Hdr,RadDiag_Data) - select case (read_status) - case(eof) - exit ges_read_loop - case(failure) - call display_message(program_name, 'Error reading ges data', warning) - exit ges_read_loop - case default - !do nothing - end select - !if doesnt meet criteria, dont save, cycle - if ((Surface_Type==Sea).and.(RadDiag_Data%Scalar%Water_Frac=lower_sea_threshold)) & - cycle ges_read_loop - if ((Surface_Type==Mixed).and.(RadDiag_Data%Scalar%Land_Frac>=lower_land_threshold)) & - cycle ges_read_loop - if ((Surface_Type==Mixed).and.(RadDiag_Data%Scalar%Ice_Frac>=lower_ice_threshold)) & - cycle ges_read_loop - if ((Surface_Type==Mixed).and.(RadDiag_Data%Scalar%Snow_Frac>=lower_snow_threshold)) & - cycle ges_read_loop - if ((Cloud_Type==Clear_FOV).and.(RadDiag_Data%Scalar%qcdiag1>clear_threshold)) & - cycle ges_read_loop - if (abs(RadDiag_Data%Scalar%satzen_ang)>satang) cycle ges_read_loop - nc=0 - ng=ng+1 - if (ng>dsize) then - ng=dsize - print *, 'Warning: Number of obs meeting criteria exceeds dsize. Consider increasing dsize' - cycle ges_read_loop - end if - ges_channel_loop: do jj=1,nch_active - j=indR(jj) - if (((abs(RadDiag_Data%Channel(j)%qcmark)errt)) then - ges(ng,jj)=RadDiag_Data%Channel(j)%omgbc - gesuse(ng,jj)=1 - nc=nc+1 - else - ges(ng,jj)=zero - gesuse(ng,jj)=0 - end if - end do ges_channel_loop - if (nc<1) then - cycle ges_read_loop - ng=ng-1 - end if - time_min=RadDiag_Data%Scalar%obstime - ges_times(ng)=(time_min*sixty)+(threesixty*(tim-1)) - gesloc(ng,1)=RadDiag_Data%Scalar%lat - gesloc(ng,2)=RadDiag_Data%Scalar%lon - end do ges_read_loop - close(gesid) + Radges%omg=zero + Radges%latlon=zero + Radges%timeobs=zero + call get_satobs_data(gesfile,netcdf,dsize,Surface_type,Cloud_Type,satang,Radges,ng) + do ka=1,ng + Radges%timeobs(ka)=(Radges%timeobs(ka)*sixty)+(threesixty*(tim-1)) + end do if (cov_method==desroziers) then !read anl data - Error_Status=RadDiag_OpenFile(trim(anlfile),anlid) - if (Error_Status /= success ) then - call display_message(program_name,'Error opening'//trim(anlfile),failure) - stop - end if - !read anl header - Error_Status=RadDiag_Hdr_ReadFile(anlid,RadDiag_Hdr) - if (Error_Status /= success ) then - call display_message(program_name,'Error reading anl header',failure) - stop - end if - anl_read_loop: do - read_status=RadDiag_Data_ReadFile(anlid,RadDiag_Hdr,RadDiag_Data) - select case (read_status) - case(eof) - exit anl_read_loop - case(failure) - call display_message(program_name, 'Error reading anl data', warning) - exit anl_read_loop - case default - !do nothing - end select - !if doesnt meet criteria, cycle - if ((Surface_Type==Sea).and.(RadDiag_Data%Scalar%Water_Frac=lower_sea_threshold)) & - cycle anl_read_loop - if ((Surface_Type==Mixed).and.(RadDiag_Data%Scalar%Land_Frac>=lower_land_threshold)) & - cycle anl_read_loop - if ((Surface_Type==Mixed).and.(RadDiag_Data%Scalar%Ice_Frac>=lower_ice_threshold)) & - cycle anl_read_loop - if ((Surface_Type==Mixed).and.(RadDiag_Data%Scalar%Snow_Frac>=lower_snow_threshold)) & - cycle anl_read_loop - if ((Cloud_Type==Clear_FOV).and.(RadDiag_Data%Scalar%qcdiag1>clear_threshold)) & - cycle anl_read_loop - if (abs(RadDiag_Data%Scalar%satzen_ang)>satang) cycle anl_read_loop - nc=0 - anl_channel_loop: do jj=1,nch_active - j=indR(jj) - if (((abs(RadDiag_Data%Channel(j)%qcmark)errt)) then - anl(jj)=RadDiag_Data%Channel(j)%omgbc - anluse(jj)=1 - nc=nc+1 - else - anl(jj)=zero - anluse(jj)=0 - end if - end do anl_channel_loop - if (nczero) then !$omp parallel do private(r,c,cov_sum,div,anl_sum,ges_sum,j) @@ -393,12 +190,12 @@ program cov_calc anl_sum=zero ges_sum=zero do j=1,n_pair - if ((anluse(r)>zero).and.(gesuse(obs_pairs(j),c)>zero)) then - cov_sum=cov_sum+(anl(r)*ges(obs_pairs(j),c)) - anl_sum=anl_sum+anl(r) - ges_sum=ges_sum+ges(obs_pairs(j),c) + if ((abs(Radanl%omg(ka,r))>zero).and.(abs(Radges%omg(obs_pairs(j),c))>zero)) then + cov_sum=cov_sum+(Radanl%omg(ka,r)*Radges%omg(obs_pairs(j),c)) + anl_sum=anl_sum+Radanl%omg(ka,r) + ges_sum=ges_sum+Radges%omg(obs_pairs(j),c) div=div+1 - end if + endif end do Rcov(r,c)=Rcov(r,c)+cov_sum anl_ave(r,c)=anl_ave(r,c)+anl_sum @@ -408,14 +205,13 @@ program cov_calc end do !c=1,nch_active !$omp end parallel do end if !npair>zero - end do anl_read_loop - close(anlid) + end do !ka else if (cov_method==hl_method) then !end of cov_method=desroziers do dd=1,ng - obs_pairs_hl=zero - n_pair_hl=zero - call make_pairs_hl(gesloc(:,:),gesloc(dd,:),ges_times(:), & - ges_times(dd),ng,bin_dist,timeth, num_bin, obs_pairs_hl,n_pair_hl) + obs_pairs_hl=zero_int + n_pair_hl=zero_int + call make_pairs_hl(Radges%latlon(:,:),Radges%latlon(dd,:),Radges%timeobs(:), & + Radges%timeobs(dd),ng,bin_dist,timeth, num_bin, obs_pairs_hl,n_pair_hl) do dis=1,num_bins if (n_pair_hl(dis)>zero) then !$omp parallel do private(r,c,j,cov_sum,div,ges_sum1,ges_sum2) @@ -426,12 +222,13 @@ program cov_calc ges_sum1=zero ges_sum2=zero do j=1,n_pair_hl(dis) - if ((gesuse(dd,r)>zero).and.(gesuse(obs_pairs_hl(j,dis),c)>zero)) then - cov_sum=cov_sum+(ges(dd,r)*ges(obs_pairs_hl(j,dis),c)) - ges_sum1=ges_sum1+ges(obs_pairs_hl(j,dis),c) - ges_sum2=ges_sum2+ges(dd,r) + if ((abs(Radges%omg(dd,r))>zero).and. & + (abs(Radges%omg(obs_pairs_hl(j,dis),c))>zero)) then + cov_sum=cov_sum+(Radges%omg(dd,r)*Radges%omg(obs_pairs_hl(j,dis),c)) + ges_sum1=ges_sum1+Radges%omg(obs_pairs_hl(j,dis),c) + ges_sum2=ges_sum2+Radges%omg(dd,r) div=div+1 - end if + endif end do Rcovbig(r,c,dis)=Rcovbig(r,c,dis)+cov_sum divbig(r,c,dis)=divbig(r,c,dis)+div @@ -528,35 +325,34 @@ program cov_calc end do Rcorr=(Rcorr+TRANSPOSE(Rcorr))/two end if -call RadDiag_Hdr_Destroy(RadDiag_Hdr) -call RadDiag_Data_Destroy(RadDiag_Data) -deallocate(ges_times,gesloc,ges,gesuse, ges_ave,bin_dist,obs_pairs) +deallocate(ges_ave,bin_dist,obs_pairs) if (cov_method==desroziers) then - deallocate(anl, anluse, anl_ave) + deallocate(anl_ave) else if (cov_method==hl_method) then deallocate(Rcovbig,divbig,ges_avebig1,ges_avebig2) deallocate(n_pair_hl, obs_pairs_hl) end if + !output -inquire(iolength=reclen) Rcov(1,1) +reclen=kind(Rcov(1,1)) open(26,file=trim(cov_file),form='unformatted') -write(26) nch_active, no_chn, reclen +write(26) nch_active, nctot, reclen write(26) indR write(26) Rcov close(26) if (out_wave) then - open(28,file=trim(wave_file),form='unformatted',access='direct',recl=nch_active*reclen) + open(28,file=trim(wave_file),form='unformatted',access='direct',recl=nch_active) write(28,rec=1) chaninfo close(28) end if if (out_err) then - open(29,file=trim(err_file),form='unformatted',access='direct',recl=nch_active*reclen) + open(29,file=trim(err_file),form='unformatted',access='direct',recl=nch_active) write(29,rec=1) errout close(29) end if if (out_corr) then - open(25,file=trim(corr_file),form='unformatted',access='direct',recl=nch_active*nch_active*reclen) + open(25,file=trim(corr_file),form='unformatted',access='direct',recl=nch_active*nch_active) write(25,rec=1) Rcorr close(25) end if diff --git a/util/Correlated_Obs/kinds.f90 b/util/Correlated_Obs/kinds.f90 deleted file mode 100644 index c1105931a..000000000 --- a/util/Correlated_Obs/kinds.f90 +++ /dev/null @@ -1,105 +0,0 @@ -module kinds -!$$$ module documentation block -! . . . . -! module: kinds -! prgmmr: treadon org: np23 date: 2004-08-15 -! -! abstract: Module to hold specification kinds for variable declaration. -! This module is based on (copied from) Paul vanDelst's -! type_kinds module found in the community radiative transfer -! model -! -! module history log: -! 2004-08-15 treadon -! -! Subroutines Included: -! -! Functions Included: -! -! remarks: -! The numerical data types defined in this module are: -! i_byte - specification kind for byte (1-byte) integer variable -! i_short - specification kind for short (2-byte) integer variable -! i_long - specification kind for long (4-byte) integer variable -! i_llong - specification kind for double long (8-byte) integer variable -! r_single - specification kind for single precision (4-byte) real variable -! r_double - specification kind for double precision (8-byte) real variable -! r_quad - specification kind for quad precision (16-byte) real variable -! -! i_kind - generic specification kind for default integer -! r_kind - generic specification kind for default floating point -! -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - implicit none - private - -! Integer type definitions below - -! Integer types - integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer - integer, parameter, public :: i_short = selected_int_kind(4) ! short integer - integer, parameter, public :: i_long = selected_int_kind(8) ! long integer - integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer - integer, parameter, public :: i_llong = max( llong_t, i_long ) - -! Expected 8-bit byte sizes of the integer kinds - integer, parameter, public :: num_bytes_for_i_byte = 1 - integer, parameter, public :: num_bytes_for_i_short = 2 - integer, parameter, public :: num_bytes_for_i_long = 4 - integer, parameter, public :: num_bytes_for_i_llong = 8 - -! Define arrays for default definition - integer, parameter, private :: num_i_kinds = 4 - integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & - i_byte, i_short, i_long, i_llong /) - integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & - num_bytes_for_i_byte, num_bytes_for_i_short, & - num_bytes_for_i_long, num_bytes_for_i_llong /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** - integer, parameter, private :: default_integer = 3 ! 1=byte, - ! 2=short, - ! 3=long, - ! 4=llong - integer, parameter, public :: i_kind = integer_types( default_integer ) - integer, parameter, public :: num_bytes_for_i_kind = & - integer_byte_sizes( default_integer ) - - -! Real definitions below - -! Real types - integer, parameter, public :: r_single = selected_real_kind(6) ! single precision - integer, parameter, public :: r_double = selected_real_kind(15) ! double precision - integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision - integer, parameter, public :: r_quad = max( quad_t, r_double ) - -! Expected 8-bit byte sizes of the real kinds - integer, parameter, public :: num_bytes_for_r_single = 4 - integer, parameter, public :: num_bytes_for_r_double = 8 - integer, parameter, public :: num_bytes_for_r_quad = 16 - -! Define arrays for default definition - integer, parameter, private :: num_r_kinds = 3 - integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & - r_single, r_double, r_quad /) - integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & - num_bytes_for_r_single, num_bytes_for_r_double, & - num_bytes_for_r_quad /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** - integer, parameter, private :: default_real = 1 ! 1=single, - ! 2=double, - ! 3=quad - integer, parameter, public :: r_kind = real_kinds( default_real ) - integer, parameter, public :: num_bytes_for_r_kind = & - real_byte_sizes( default_real ) - -end module kinds diff --git a/util/Correlated_Obs/make.common_targets b/util/Correlated_Obs/make.common_targets deleted file mode 100644 index 48f0c59b8..000000000 --- a/util/Correlated_Obs/make.common_targets +++ /dev/null @@ -1,148 +0,0 @@ -#------------------------------------------------------------------------------ -# -# NAME: -# make.common_targets -# -# PURPOSE: -# Unix make utility include file for common targets used for builds. -# Note that this include file is intended for use with the make.macros -# and make.rules include files also. -# -# LANGUAGE: -# Unix make -# -# CALLING SEQUENCE: -# include make.common_targets -# -# CREATION HISTORY: -# Written by: Paul van Delst, CIMSS/SSEC 30-Jun-2006 -# paul.vandelst@ssec.wisc.edu -# -# $Id: make.common_targets 9040 2010-07-29 17:01:49Z Michael.Lueken@noaa.gov $ -# -#------------------------------------------------------------------------------ - -# ------------------------------ -# Default build based on OS type -# ------------------------------ -all: - @echo "OS type detected: "`uname -s` - @case `uname -s` in \ - "SunOS") make -f $(MAKE_FILE) build $(SUNOS_FLAGS) ;; \ - "AIX") make -f $(MAKE_FILE) build $(AIX_FLAGS) ;; \ - "IRIX64") make -f $(MAKE_FILE) build $(IRIX64_FLAGS) ;; \ - "HP-UX") make -f $(MAKE_FILE) build $(HPUX_FLAGS) ;; \ - "Linux"|"Darwin") make -f $(MAKE_FILE) build $(LINUX_FLAGS) ;; \ - *) echo "This system is not supported" ;; \ - esac - - -# ---------------------- -# Specific build targets -# ---------------------- -# IBM AIX Compiler -# ---------------- -ibm_debug: - make -f $(MAKE_FILE) build $(AIX_FLAGS_DEBUG) - -ibm: - make -f $(MAKE_FILE) build $(AIX_FLAGS_PROD) - - -# HP-UX Compiler -# -------------- -hp_debug: - make -f $(MAKE_FILE) build $(HPUX_FLAGS_DEBUG) - -hp: - make -f $(MAKE_FILE) build $(HPUX_FLAGS_PROD) - - -# SGI MIPSpro Compiler -# -------------------- -sgi_debug: - make -f $(MAKE_FILE) build $(IRIX64_FLAGS_DEBUG) - -sgi: - make -f $(MAKE_FILE) build $(IRIX64_FLAGS_PROD) - - -# SunOS Compiler -# -------------- -sun_debug: - make -f $(MAKE_FILE) build $(SUNOS_FLAGS_DEBUG) - -sun: - make -f $(MAKE_FILE) build $(SUNOS_FLAGS_PROD) - - -# Linux compilers -# --------------- -mpif90_debug: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_GFORTRAN_DEBUG) - -mpif90: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_GFORTRAN_PROD) - - -intel_debug: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_INTEL_DEBUG) - -intel: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_INTEL_PROD) - - -lahey_debug: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_LAHEY_DEBUG) - -lahey: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_LAHEY_PROD) - - -pgi_debug: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_PGI_DEBUG) - -pgi: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_PGI_PROD) - - -g95_debug: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_G95_DEBUG) - -g95: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_G95_PROD) - - -absoft_debug: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_ABSOFT_DEBUG) - -absoft: - make -f $(MAKE_FILE) build $(LINUX_FLAGS_ABSOFT_PROD) - - -# ----------------- -# Build the program -# ----------------- -build: $(OBJ_FILES) - $(FL) $(OBJ_FILES) $(EXTRA_FL_FLAGS) $(FL_FLAGS) $(EXE_FILE) - - -# -------- -# Clean up -# -------- -clean: - $(REMOVE) $(OBJ_FILES) *.mod *.MOD gmon.out $(EXE_FILE) - -realclean: clean - -real_clean: clean - - -# ---------------------- -# Install the executable -# ---------------------- -install: - @if [ -d $(HOME)/bin ]; then \ - $(MOVE) $(EXE_FILE) $(HOME)/bin; \ - fi - diff --git a/util/Correlated_Obs/make.dependencies b/util/Correlated_Obs/make.dependencies deleted file mode 100644 index 568b36f65..000000000 --- a/util/Correlated_Obs/make.dependencies +++ /dev/null @@ -1,11 +0,0 @@ -cov_calc.o : cov_calc.f90 kinds.o constants.o obs_tools.o matrix_tools.o pairs.o RadDiag_IO.o Message_Handler.o RadDiag_Define.o -File_Utility.o : File_Utility.f90 -Message_Handler.o : Message_Handler.f90 File_Utility.o -RadDiag_Data_Define.o : RadDiag_Data_Define.f90 Message_Handler.o kinds.o -RadDiag_Define.o : RadDiag_Define.f90 RadDiag_Data_Define.o RadDiag_Hdr_Define.o -RadDiag_Hdr_Define.o : RadDiag_Hdr_Define.f90 Message_Handler.o kinds.o -RadDiag_IO.o : RadDiag_IO.f90 RadDiag_Define.o Message_Handler.o File_Utility.o kinds.o -obs_tools.o : obs_tools.f90 kinds.o constants.o -matrix_tools.o : matrix_tools.f90 kinds.o constants.o -pairs.o : pairs.f90 kinds.o obs_tools.o -kinds.o : kinds.f90 diff --git a/util/Correlated_Obs/make.macros b/util/Correlated_Obs/make.macros deleted file mode 100644 index 58f8ffb3e..000000000 --- a/util/Correlated_Obs/make.macros +++ /dev/null @@ -1,546 +0,0 @@ -#------------------------------------------------------------------------------ -# -# NAME: -# make.macros -# -# PURPOSE: -# Unix make utility include file for definition of common make -# macros used in building CRTM software -# -# LANGUAGE: -# Unix make -# -# CALLING SEQUENCE: -# include make.macros -# -# CREATION HISTORY: -# Written by: Paul van Delst, CIMSS/SSEC 08-Jun-2000 -# paul.vandelst@ssec.wisc.edu -# -# Copyright (C) 2000 Paul van Delst -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: make.macros 9040 2010-07-29 17:01:49Z Michael.Lueken@noaa.gov $ -# -#------------------------------------------------------------------------------ - -################################################################################# -# # -# GENERAL USE MACRO SPECIFICATION # -# # -################################################################################# - -# Define default shell -SHELL = /bin/sh - - -# Define link, copy and delete commands -LINK = ln -sf -COPY = cp -MOVE = mv -f -REMOVE = rm -f - - -# Define tarballer commands -TARBALLER = tar -TARBALL_CREATE = $(TARBALLER) cvhf -TARBALL_APPEND = $(TARBALLER) rvhf -TARBALL_EXTRACT = $(TARBALLER) xvhf - - -# Define archiver and flags -ARCHIVER = ar -ARCHIVER_FLAGS = crvs - - -# Define scripts used in makefiles -# ...Scripts to link and unlink files -LINK_SCRIPT = linkfiles.sh -UNLINK_SCRIPT = unlinkfiles - - -# CRTM library build definitions -# ...Library name -PACKAGE = CRTM -LIBRARY = lib$(PACKAGE).a -# ...Module file extension -EXT_MOD = mod -# ...Directory definitions -BUILD_DIR = Build -LIBSRC_DIR = libsrc -LIB_DIR = lib -INC_DIR = include -TEST_DIR = test -COEFF_DIR = coefficients - - - -################################################################################# -# # -# SPECIFIC PLATFORM FLAG SPECIFICATION # -# # -################################################################################# - -#-------------------------------------------------------------------------------# -# -- IBM AIX xlf95 compiler -- # -# # -# NOTE: There are two sets of AIX flags. # -# DEBUG and PRODUCTION. # -# See AIX_FLAGS definition for default. # -#-------------------------------------------------------------------------------# - -# The compiler and linker name -NAME_AIX = xlf95 - -# Compiler settings for DEBUG builds -AIX_COMMON_FLAGS_DEBUG = -pg -AIX_FLAGS_DEBUG = "FC=${NAME_AIX}" \ - "FL=${NAME_AIX}" \ - "FC_FLAGS= -c \ - -qcheck \ - -qdbg \ - -qextchk \ - -qfloat=nomaf:rndsngl:nans \ - -qflttrap=ov:zero:inv:en \ - -qinitauto \ - -qfree \ - -qhalt=W \ - -qlanglvl=2003pure \ - -qmaxmem=-1 \ - -qsuffix=f=f90:cpp=F90 \ - ${INCLUDES} \ - ${AIX_COMMON_FLAGS_DEBUG}" \ - "FL_FLAGS= ${AIX_COMMON_FLAGS_DEBUG} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Big_Endian" - -# Compiler settings for PRODUCTION builds -AIX_COMMON_FLAGS_PROD = -O3 -AIX_FLAGS_PROD = "FC=${NAME_AIX}" \ - "FL=${NAME_AIX}" \ - "FC_FLAGS= -c \ - -qdbg \ - -qarch=auto \ - -qfree \ - -qhalt=W \ - -qlanglvl=2003pure \ - -qsuffix=f=f90:cpp=F90 \ - -qstrict \ - -NS32768 \ - ${INCLUDES} \ - ${AIX_COMMON_FLAGS_PROD}" \ - "FL_FLAGS= ${AIX_COMMON_FLAGS_PROD} \ - -lmass -lm \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Big_Endian" - -# Here set the DEFAULT AIX compiler flags -#AIX_FLAGS = $(AIX_FLAGS_DEBUG) -AIX_FLAGS = $(AIX_FLAGS_PROD) - - - -#-------------------------------------------------------------------------------# -# -- Sun Fortran 95 -- # -#-------------------------------------------------------------------------------# - -# The compiler and linker name -NAME_SUNOS = f95 - -# Only one set of compiler flags -SUNOS_COMMON_FLAGS = -SUNOS_FLAGS = "FC=${NAME_SUNOS}" \ - "FL=${NAME_SUNOS}" \ - "FC_FLAGS= -ansi \ - -c \ - -C \ - -fsimple=0 \ - -ftrap=overflow,division \ - -g \ - -w3 \ - ${INCLUDES} \ - ${SUNOS_COMMON_FLAGS}" \ - "FL_FLAGS= ${SUNOS_COMMON_FLAGS} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Big_Endian" - -SUNOS_FLAGS_DEBUG = ${SUNOS_FLAGS) -SUNOS_FLAGS_PROD = ${SUNOS_FLAGS) - - - -#-------------------------------------------------------------------------------# -# -- SGI IRIX64 MIPSpro f90 compiler -- # -#-------------------------------------------------------------------------------# - -# The compiler and linker name -NAME_IRIX64 = f90 - -# Only one set of compiler flags for 64-bit build -IRIX64_COMMON_FLAGS = -64 -IRIX64_FLAGS = "FC=${NAME_IRIX64}" \ - "FL=${NAME_IRIX64}" \ - "FC_FLAGS= -ansi \ - -c \ - -C \ - -DEBUG:suppress=399,878 \ - -fullwarn \ - -g \ - -bytereclen \ - -u \ - ${INCLUDES} \ - ${IRIX64_COMMON_FLAGS}" \ - "FL_FLAGS= ${IRIX64_COMMON_FLAGS} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Big_Endian" - -IRIX64_FLAGS_DEBUG = ${IRIX64_FLAGS) -IRIX64_FLAGS_PROD = ${IRIX64_FLAGS) - - - -#-------------------------------------------------------------------------------# -# -- HP-UX Fortran 90 (95) -- # -#-------------------------------------------------------------------------------# - -# The compiler and linker name -NAME_HPUX = f90 - -# Compiler settings for DEBUG builds -HPUX_COMMON_FLAGS_DEBUG = -HPUX_FLAGS_DEBUG = "FC=${NAME_HPUX}" \ - "FL=${NAME_HPUX}" \ - "FC_FLAGS= +ppu -c +fltconst_strict \ - ${INCLUDES} \ - ${HPUX_COMMON_FLAGS_DEBUG}" \ - "FL_FLAGS= ${HPUX_COMMON_FLAGS_DEBUG} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Big_Endian" - - -# Compiler settings for PRODUCTION builds -HPUX_COMMON_FLAGS_PROD = -O3 -HPUX_FLAGS_PROD = "FC=${NAME_HPUX}" \ - "FL=${NAME_HPUX}" \ - "FC_FLAGS= +ppu -c +fltconst_strict \ - ${INCLUDES} \ - ${HPUX_COMMON_FLAGS_PROD}" \ - "FL_FLAGS= ${HPUX_COMMON_FLAGS_PROD} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Big_Endian" - - -# Here set the DEFAULT HPUX compiler flags -HPUX_FLAGS = $(HPUX_FLAGS_DEBUG) - - - -#-------------------------------------------------------------------------------# -# -- Linux compilers -- # -#-------------------------------------------------------------------------------# - -# --------------------------- -# gfortran compiler for linux -# --------------------------- - -# The compiler and linker name -NAME_GFORTRAN = gfortran - -# Compiler settings for DEBUG builds -LINUX_COMMON_FLAGS_GFORTRAN_DEBUG = -fopenmp -LINUX_FLAGS_GFORTRAN_DEBUG = "FC=${NAME_GFORTRAN}" \ - "FL=${NAME_GFORTRAN}" \ - "FC_FLAGS= -c \ - -fbounds-check \ - -fconvert=little-endian \ - -ffpe-trap=overflow,zero \ - -ffree-form \ - -fno-second-underscore \ - -frecord-marker=4 \ - -ggdb \ - -static \ - -Wall \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_GFORTRAN_DEBUG}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_GFORTRAN_DEBUG} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Little_Endian" - -# Compiler settings for DEBUG builds -LINUX_COMMON_FLAGS_GFORTRAN_PROD = -LINUX_FLAGS_GFORTRAN_PROD = "FC=${NAME_GFORTRAN}" \ - "FL=${NAME_GFORTRAN}" \ - "FC_FLAGS= -c \ - -O3 \ - -fconvert=little-endian \ - -ffast-math \ - -ffree-form \ - -fno-second-underscore \ - -frecord-marker=4 \ - -funroll-loops \ - -ggdb \ - -static \ - -Wall \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_GFORTRAN_PROD}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_GFORTRAN_PROD} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Little_Endian" - -# Here set the DEFAULT gfortran compiler flags -LINUX_FLAGS_GFORTRAN = $(LINUX_FLAGS_GFORTRAN_DEBUG) - - -# ------------------------------------- -# Portland Group f95 compiler for linux -# ------------------------------------- - -# The compiler and linker name -NAME_PGI = pgf95 - -# Compiler settings for DEBUG builds -LINUX_COMMON_FLAGS_PGI_DEBUG = -Kieee -pg -LINUX_FLAGS_PGI_DEBUG = "FC=${NAME_PGI}" \ - "FL=${NAME_PGI}" \ - "FC_FLAGS= -c \ - -g \ - -byteswapio \ - -Ktrap=ovf,divz \ - -Mbounds \ - -Mchkstk \ - -Mdclchk \ - -Minform,inform \ - -Mnosave \ - -Mref_externals \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_PGI_DEBUG}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_PGI_DEBUG} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Little_Endian" - -# Compiler settings for PRODUCTION builds -LINUX_COMMON_FLAGS_PGI_PROD = -LINUX_FLAGS_PGI_PROD = "FC=${NAME_PGI}" \ - "FL=${NAME_PGI}" \ - "FC_FLAGS= -c \ - -g \ - -fast \ - -byteswapio \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_PGI_PROD}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_PGI_PROD} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Little_Endian" - -# Here set the DEFAULT PGI compiler flags -LINUX_FLAGS_PGI = $(LINUX_FLAGS_PGI_DEBUG) - - - -# ---------------------------- -# Intel f95 compiler for linux -# ---------------------------- - -# The compiler and linker name -NAME_INTEL = ifort - -# Compiler settings for DEBUG builds -LINUX_COMMON_FLAGS_INTEL_DEBUG = -pg -LINUX_FLAGS_INTEL_DEBUG = "FC=${NAME_INTEL}" \ - "FL=${NAME_INTEL}" \ - "FC_FLAGS= -c \ - -g \ - -check bounds \ - -convert little_endian \ - -e03 \ - -traceback \ - -free \ - -assume byterecl \ - -fp-stack-check \ - -mieee-fp \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_DEBUG}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_DEBUG} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Little_Endian" - -# Compiler settings for PRODUCTION builds -LINUX_COMMON_FLAGS_INTEL_PROD = -LINUX_FLAGS_INTEL_PROD = "FC=${NAME_INTEL}" \ - "FL=${NAME_INTEL}" \ - "FC_FLAGS= -c \ - -O2 \ - -convert little_endian \ - -free \ - -assume byterecl \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_PROD}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_PROD} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Little_Endian" - -# Here set the DEFAULT Intel compiler flags -LINUX_FLAGS_INTEL = $(LINUX_FLAGS_INTEL_DEBUG) - - - -# ---------------------------- -# Lahey f95 compiler for linux -# ---------------------------- - -# The compiler and linker name -NAME_LAHEY = lf95 - -# Compiler settings for DEBUG builds -LINUX_COMMON_FLAGS_LAHEY_DEBUG = -LINUX_FLAGS_LAHEY_DEBUG = "FC=${NAME_LAHEY}" \ - "FL=${NAME_LAHEY}" \ - "FC_FLAGS= -c \ - -g \ - --chk aesu \ - --f95 \ - --trace \ - --trap \ - --ninfo --warn \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_LAHEY_DEBUG}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_LAHEY_DEBUG} \ - ${LIBRARIES} \ - --staticlink \ - -o" \ - "ENDIAN=Little_Endian" - -# Compiler settings for PRODUCTION builds -LINUX_COMMON_FLAGS_LAHEY_PROD = -LINUX_FLAGS_LAHEY_PROD = "FC=${NAME_LAHEY}" \ - "FL=${NAME_LAHEY}" \ - "FC_FLAGS= -c \ - --f95 \ - --o1 \ - --ninfo --warn \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_LAHEY_PROD}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_LAHEY_PROD} \ - ${LIBRARIES} \ - --staticlink \ - -o" \ - "ENDIAN=Little_Endian" - -# Here set the DEFAULT Lahey compiler flags -LINUX_FLAGS_LAHEY = $(LINUX_FLAGS_LAHEY_DEBUG) - - -# ---------------------- -# g95 compiler for linux -# ---------------------- - -# The compiler and linker name -NAME_G95 = g95 - -# Compiler settings for DEBUG builds -LINUX_COMMON_FLAGS_G95_DEBUG = -pg -LINUX_FLAGS_G95_DEBUG = "FC=${NAME_G95}" \ - "FL=${NAME_G95}" \ - "FC_FLAGS= -c \ - -fbounds-check \ - -fendian=little \ - -ffree-form \ - -fno-second-underscore \ - -ftrace=frame \ - -malign-double \ - -Wall \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_G95_DEBUG}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_G95_DEBUG} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Little_Endian" - -# Compiler settings for PRODUCTION builds -LINUX_COMMON_FLAGS_G95_PROD = -LINUX_FLAGS_G95_PROD = "FC=${NAME_G95}" \ - "FL=${NAME_G95}" \ - "FC_FLAGS= -c \ - -O2 \ - -fendian=little \ - -ffast-math \ - -ffree-form \ - -fno-second-underscore \ - -funroll-loops \ - -malign-double \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_G95_PROD}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_G95_PROD} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Little_Endian" - - -# Here set the DEFAULT g95 compiler flags -LINUX_FLAGS_G95 = $(LINUX_FLAGS_G95_DEBUG) - - -# ----------------------------- -# Absoft f90 compiler for linux -# ----------------------------- - -# The compiler and linker name -NAME_ABSOFT = f90 - -# Only one set of compiler flags -LINUX_COMMON_FLAGS_ABSOFT = -LINUX_FLAGS_ABSOFT = "FC=${NAME_ABSOFT}" \ - "FL=${NAME_ABSOFT}" \ - "FC_FLAGS= -c \ - -B80 \ - -en \ - -g \ - -m0 \ - ${INCLUDES} \ - ${LINUX_COMMON_FLAGS_ABSOFT}" \ - "FL_FLAGS= ${LINUX_COMMON_FLAGS_ABSOFT} \ - ${LIBRARIES} \ - -o" \ - "ENDIAN=Little_Endian" - -LINUX_FLAGS_ABSOFT_DEBUG = $(LINUX_FLAGS_ABSOFT) -LINUX_FLAGS_ABSOFT_PROD = $(LINUX_FLAGS_ABSOFT) - - -# --------------------------------------- -# Define the default Linux compiler flags -# --------------------------------------- - -LINUX_FLAGS = $(LINUX_FLAGS_GFORTRAN) - -#LINUX_FLAGS = $(LINUX_FLAGS_LAHEY) -#LINUX_FLAGS = $(LINUX_FLAGS_PGI) -#LINUX_FLAGS = $(LINUX_FLAGS_INTEL) -#LINUX_FLAGS = $(LINUX_FLAGS_G95) -#LINUX_FLAGS = $(LINUX_FLAGS_ABSOFT) - diff --git a/util/Correlated_Obs/make.rules b/util/Correlated_Obs/make.rules deleted file mode 100644 index b929353a7..000000000 --- a/util/Correlated_Obs/make.rules +++ /dev/null @@ -1,58 +0,0 @@ -#------------------------------------------------------------------------------ -# -# NAME: -# make.rules -# -# PURPOSE: -# Unix make utility include file for definition of suffix and -# compilation rules -# -# LANGUAGE: -# Unix make -# -# CALLING SEQUENCE: -# include make.rules -# -# CREATION HISTORY: -# Written by: Paul van Delst, CIMSS/SSEC 08-Jun-2000 -# paul.vandelst@ssec.wisc.edu -# -# Copyright (C) 2000 Paul van Delst -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: make.rules 9040 2010-07-29 17:01:49Z Michael.Lueken@noaa.gov $ -# -#------------------------------------------------------------------------------ - -# Fortran 90 suffix rules -# ----------------------- -.SUFFIXES: -.SUFFIXES: .F95 .f95 .F90 .f90 .f .o -.F95.o: - $(FC) $(EXTRA_FC_FLAGS) $(FC_FLAGS) $(FPP_FLAGS) $< - -.f95.o: - $(FC) $(EXTRA_FC_FLAGS) $(FC_FLAGS) $< - -.F90.o: - $(FC) $(EXTRA_FC_FLAGS) $(FC_FLAGS) $(FPP_FLAGS) $< - -.f90.o: - $(FC) $(EXTRA_FC_FLAGS) $(FC_FLAGS) $< - -.f.o: - $(FC) $(EXTRA_FC_FLAGS) -c $< - diff --git a/util/Correlated_Obs/matrix_tools.f90 b/util/Correlated_Obs/matrix_tools.f90 index ef5b7163f..07b39a44c 100644 --- a/util/Correlated_Obs/matrix_tools.f90 +++ b/util/Correlated_Obs/matrix_tools.f90 @@ -20,8 +20,8 @@ subroutine eigdecomp(Ain,n,D,Q) !Kristen Bathmann !8-2015 -use kinds, only: r_kind, i_kind -use constants, only: zero, one, four_int, one_hundred +use ckinds, only: r_kind, i_kind +use cconstants, only: zero, one, four_int, one_hundred implicit none integer(i_kind),intent(in):: n real(r_kind),dimension(n,n),intent(in):: Ain @@ -130,8 +130,8 @@ subroutine recondition(Q,D,n,kreq,A,method) !It is necessary to preform an eigendecompositon first !Kristen Bathmann !8-2015 -use kinds, only: r_kind, i_kind -use constants, only: zero +use ckinds, only: r_kind, i_kind +use cconstants, only: zero implicit none real(r_kind),dimension(:),intent(in):: D !eigenvalues real(r_kind),dimension(:,:),intent(in):: Q !eigenvectors @@ -139,12 +139,12 @@ subroutine recondition(Q,D,n,kreq,A,method) integer(i_kind),intent(in):: n !number of channels real(r_kind),dimension(:,:),allocatable:: Dn !new eigenvalues real(r_kind),dimension(:,:),intent(out):: A !reconditioned covariance -integer,intent(in)::method +integer(i_kind),intent(in)::method real(r_kind):: mx, mn, K real(r_kind):: laminc -integer:: i,coun, dw -integer,parameter:: trace=1 -integer,parameter:: weston2=2 +integer(i_kind):: i,coun, dw +integer(i_kind),parameter:: trace=1 +integer(i_kind),parameter:: weston2=2 allocate(Dn(n,n)) Dn=zero mn=D(1) diff --git a/util/Correlated_Obs/obs_tools.f90 b/util/Correlated_Obs/obs_tools.f90 index 518879037..ebac3ada7 100644 --- a/util/Correlated_Obs/obs_tools.f90 +++ b/util/Correlated_Obs/obs_tools.f90 @@ -4,21 +4,22 @@ module obs_tools -use kinds, only: r_kind +use ckinds, only: r_kind,i_kind implicit none -public:: dist +public:: cdist public:: get_filename contains -real function dist (po1, po2) +subroutine cdist(po1,po2,dist) !This function takes two points, whose positions are specified by a latitude and !longitude, and computes the distance, in km, between the two by converting to !cartesian coordinates -use constants, only: rad, pi +use cconstants, only: rad, pi implicit none real(r_kind),dimension(2),intent(in):: po1,po2 !the two points, given by (lat,lon) +real(r_kind), intent(out):: dist real(r_kind):: x1,y1,z1, x2, y2, z2 !cartesian coordinates real(r_kind)::d1 real(r_kind):: sinphi1, cosphi1, costhe1, sinthe1 !trig functions related to po1 @@ -26,10 +27,10 @@ real function dist (po1, po2) real(r_kind),dimension(2):: p1, p2 !manipulations on po1 and po2 -p1(1)=(90.0d0-po1(1))*pi/180.0d0 !phi -p2(1)=(90.0d0-po2(1))*pi/180.0d0 !phi -p1(2)=po1(2)*pi/180.0d0 !theta -p2(2)=po2(2)*pi/180.0d0 !theta +p1(1)=(90.0_r_kind-po1(1))*pi/180.0_r_kind !phi +p2(1)=(90.0_r_kind-po2(1))*pi/180.0_r_kind !phi +p1(2)=po1(2)*pi/180.0_r_kind !theta +p2(2)=po2(2)*pi/180.0_r_kind !theta sinphi1=sin(p1(1)) sinphi2=sin(p2(1)) @@ -49,7 +50,7 @@ real function dist (po1, po2) d1=(x1-x2)**2+(y1-y2)**2+(z1-z2)**2 dist=rad*sqrt(d1) -end function dist +end subroutine cdist subroutine get_filename(T,ext,filename) @@ -60,8 +61,8 @@ subroutine get_filename(T,ext,filename) integer,intent(in):: T !Time step of diag file to be read in character(5),intent(in)::ext !specifies either anl or ges diag file character(9),intent(out):: filename -real:: tem -integer:: t1i,t2i,t3i, t4i +real(r_kind):: tem +integer(i_kind):: t1i,t2i,t3i, t4i character(1)::t1,t2,t3, t4 tem=T/1000 diff --git a/util/Correlated_Obs/pairs.f90 b/util/Correlated_Obs/pairs.f90 index 18a4cd567..bf716c99c 100644 --- a/util/Correlated_Obs/pairs.f90 +++ b/util/Correlated_Obs/pairs.f90 @@ -4,9 +4,9 @@ !5-2015 module pairs -use kinds, only: r_kind -use obs_tools, only: dist -use constants, only: five +use ckinds, only: r_kind,i_kind +use obs_tools, only: cdist +use cconstants, only: five implicit none public :: make_pairs @@ -25,11 +25,11 @@ subroutine make_pairs(ges_locs,anl_loc,ges_times,anl_time,Tg,dist_threshold,time real(r_kind),dimension(:),intent(in):: ges_times !times of background omg's (minutes) real(r_kind), intent(in):: time_threshold !minutes, max time between the omg's real(r_kind), intent(in):: dist_threshold !km, max distance between the omg's -integer, dimension(:), intent(out):: obs_pairs !indicies of ges that correspond to pairs -integer,intent(in):: Tg !length of ges -integer,intent(out):: n_pair !number of pairs found +integer(i_kind), dimension(:), intent(out):: obs_pairs !indicies of ges that correspond to pairs +integer(i_kind),intent(in):: Tg !length of ges +integer(i_kind),intent(out):: n_pair !number of pairs found real(r_kind),dimension(2):: p1,p2 -integer:: g +integer(i_kind):: g real(r_kind):: d1 real(r_kind)::dt obs_pairs=0 @@ -39,7 +39,7 @@ subroutine make_pairs(ges_locs,anl_loc,ges_times,anl_time,Tg,dist_threshold,time if (dt<=time_threshold) then p1=ges_locs(g,:) p2=anl_loc(:) - d1=dist(p1,p2) + call cdist(p1,p2,d1) if (d1<=dist_threshold) then n_pair=n_pair+1 obs_pairs(n_pair)=g @@ -60,14 +60,14 @@ subroutine make_pairs_hl(ges_locs,current_loc,ges_times,current_time,Tg,dist_thr real(r_kind), dimension(:), intent(in):: current_loc real(r_kind), dimension(:), intent(in):: ges_times real(r_kind), intent(in):: current_time -integer, intent(in):: Tg +integer(i_kind), intent(in):: Tg real(r_kind), dimension(:), intent(in):: dist_threshold -integer, intent(in):: num_bins +integer(i_kind), intent(in):: num_bins real(r_kind), intent(in):: time_threshold !minutes, max time between the omg's -integer, dimension(:,:), intent(out):: obs_pairs -integer, dimension(:), intent(out):: n_pair +integer(i_kind), dimension(:,:), intent(out):: obs_pairs +integer(i_kind), dimension(:), intent(out):: n_pair real(r_kind),dimension(2):: p1,p2 -integer:: g, dis +integer(i_kind):: g, dis real(r_kind):: d1 real(r_kind)::dt @@ -78,7 +78,7 @@ subroutine make_pairs_hl(ges_locs,current_loc,ges_times,current_time,Tg,dist_thr if (dt<=time_threshold) then p1=ges_locs(g,:) p2=current_loc(:) - d1=dist(p1,p2) + call cdist(p1,p2,d1) do dis=1,num_bins,2 if (dis==1) then if((d1<=dist_threshold(dis))) then diff --git a/util/Correlated_Obs/par_run.sh b/util/Correlated_Obs/par_run.sh old mode 100644 new mode 100755 index 8681d33a8..4d155b7ad --- a/util/Correlated_Obs/par_run.sh +++ b/util/Correlated_Obs/par_run.sh @@ -27,7 +27,7 @@ while [[ $nt -le $ntot ]] ; do done ./cov_calc <> params.sh @@ -142,27 +151,27 @@ chmod +rwx jobchoice.sh if [ $machine = theia ] ; then cat << EOF > jobarray.sh #!/bin/sh -#PBS -A $account -#PBS -o unpack_out -#PBS -e unpack_err -#PBS -q batch -#PBS -l walltime=${unpack_walltime} -#PBS -l procs=1 -#PBS -N unpack -#PBS -t 1-${num_jobs} +#SBATCH -A $account +#SBATCH -o unpack_out +#SBATCH -e unpack_err +#SBATCH -q batch +#SBATCH --time=${unpack_walltime} +#SBATCH --ntasks=1 +#SBATCH -J unpack +#SBATCH --array 1-${num_jobs} cd $wrkdir -./jobchoice.sh \${PBS_ARRAYID} +./jobchoice.sh \${SLURM_ARRAY_TASK_ID} EOF -jobid=$(qsub jobarray.sh) +jobid=$(sbatch jobarray.sh) elif [ $machine = wcoss ] ; then cat << EOF > jobarray.sh #!/bin/sh #BSUB -o unpack_out #BSUB -e unpack_err #BSUB -q dev +#BSUB -M ${Umem} #BSUB -n 1 #BSUB -W ${unpack_walltime} -#BSUB -R affinity[core] #BSUB -R span[ptile=1] #BSUB -P ${project_code} #BSUB -J unpack[1-${num_jobs}] @@ -175,19 +184,18 @@ else echo cannot submit job, not on theia or wcoss exit 1 fi -echo $jobid #check if shifts are needed if [ $machine = theia ] ; then cat << EOF > params.sh #!/bin/sh -#PBS -A $account -#PBS -o sort_out -#PBS -e sort_err -#PBS -q batch -#PBS -l walltime=00:02:00 -#PBS -l procs=1 -#PBS -N sort_diag -#PBS -W depend=afteranyarray:${jobid} +#SBATCH -A $account +#SBATCH -o sort_out +#SBATCH -e sort_err +#SBATCH -q batch +#SBATCH --time=00:02:00 +#SBATCH --ntasks=1 +#SBATCH -J sort_diag +#SBATCH --dependency=afterany:${jobid##* } wrkdir=$wrkdir ntot=$dattot EOF @@ -195,17 +203,16 @@ chmod +rwx params.sh cat sort_diags.sh >> params.sh mv params.sh sort_diags.sh -jobid=$(qsub sort_diags.sh ) -echo $jobid +jobid=$(sbatch sort_diags.sh ) elif [ $machine = wcoss ] ; then cat << EOF > params.sh #!/bin/sh #BSUB -o sort_out #BSUB -e sort_err #BSUB -q dev +#BSUB -M 30 #BSUB -n 1 -#BSUB -W 02:00 -#BSUB -R affinity[core] +#BSUB -W 00:02 #BSUB -R span[ptile=1] #BSUB -P ${project_code} #BSUB -J sort_diag @@ -224,14 +231,15 @@ fi if [ $machine = theia ] ; then cat << EOF > params.sh #!/bin/sh -#PBS -A $account -#PBS -o comp_out -#PBS -e comp_err -#PBS -q batch -#PBS -l walltime=$wall_time -#PBS -l nodes=1:ppn=$NP -#PBS -N cov_calc -#PBS -W depend=afterany:${jobid} +#SBATCH -A $account +#SBATCH -o comp_out +#SBATCH -e comp_err +#SBATCH -q batch +#SBATCH --time=$wall_time +#SBATCH --nodes=1 +#SBATCH --ntasks-per-node=$NP +#SBATCH -J cov_calc +#SBATCH --dependency=after:${jobid##* } bdate=$bdate edate=$edate instr=$instr @@ -253,11 +261,12 @@ bcen=$bcen chan_set=$chan_set ntot=$dattot NP=$NP +netcdf=$netcdf EOF chmod +rwx params.sh cat par_run.sh >> params.sh mv params.sh par_run.sh -qsub par_run.sh +sbatch par_run.sh elif [ $machine = wcoss ] ; then cat << EOF > params.sh #!/bin/sh @@ -265,6 +274,7 @@ cat << EOF > params.sh #BSUB -e comp_err #BSUB -openmp #BSUB -q dev +#BSUB -M ${Mem} #BSUB -n $NP #BSUB -W $wall_time #BSUB -R span[ptile=$NP] @@ -287,6 +297,7 @@ method=$method cov_method=$cov_method time_sep=$time_sep bsize=$bsize +netcdf=$netcdf bcen=$bcen chan_set=$chan_set ntot=$dattot diff --git a/util/Correlated_Obs/read_diag.f90 b/util/Correlated_Obs/read_diag.f90 new file mode 100644 index 000000000..f41613a97 --- /dev/null +++ b/util/Correlated_Obs/read_diag.f90 @@ -0,0 +1,1413 @@ +!$$$ subprogram documentation block +! . . . . +! subprogram: read_raddiag read rad diag file +! prgmmr: tahara org: np20 date: 2003-01-01 +! +! abstract: This module contains code to process radiance +! diagnostic files. The module defines structures +! to contain information from the radiance +! diagnostic files and then provides two routines +! to access contents of the file. +! +! program history log: +! 2005-07-22 treadon - add this doc block +! 2010-10-05 treadon - refactor code to GSI standard +! 2010-10-08 zhu - use data_tmp to handle various npred values +! 2011-02-22 kleist - changes related to memory allocate/deallocate +! 2011-04-08 li - add tref, dtw, dtc to diag_data_fix_list, add tb_tz to diag_data_chan_list +! - correspondingly, change ireal_radiag (26 -> 30) and ipchan_radiag (7 -> 8) +! 2011-07-24 safford - make structure size for reading data_fix data version dependent +! 2013-11-21 todling - revisit how versions are set (add set/get_radiag) +! 2014-01-27 todling - add ob sensitivity index +! 2016-11-12 shlyaeva - add H(x) jacobian for EnKF +! 2017-07-13 mccarty - incorporate hooks for nc4/binary diag reading +! +! contains +! read_radiag_header - read radiance diagnostic file header +! read_radiag_data - read radiance diagnostic file data +! set_netcdf_read - call set_netcdf_read(.true.) to use nc4 hooks, otherwise read file as +! traditional binary format +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +module read_diag + + use ckinds, only: i_kind,r_radstat,r_kind + use nc_diag_read_mod, only: nc_diag_read_get_var, nc_diag_read_get_global_attr + use nc_diag_read_mod, only: nc_diag_read_get_dim + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + implicit none + +! Declare public and private + private + + public :: diag_header_fix_list + public :: diag_header_chan_list + public :: diag_data_name_list + public :: diag_data_fix_list + public :: diag_data_chan_list + public :: diag_data_extra_list + public :: open_radiag + public :: close_radiag + public :: read_radiag_header + public :: read_radiag_data + public :: iversion_radiag + public :: iversion_radiag_1 + public :: iversion_radiag_2 + public :: iversion_radiag_3 + public :: iversion_radiag_4 + public :: iversion_radiag_5 + public :: ireal_old_radiag + public :: set_netcdf_read +! public :: iversion_radiag +! public :: iversion_radiag_1 +! public :: iversion_radiag_2 +! public :: iversion_radiag_3 +! public :: iversion_radiag_4 + public :: ireal_radiag + public :: ipchan_radiag + public :: set_radiag + public :: get_radiag + + interface set_radiag + module procedure set_radiag_int_ ! internal procedure for integers + end interface + interface get_radiag + module procedure get_radiag_int_ ! internal procedure for integers + end interface + + integer(i_kind),parameter :: ireal_radiag = 30 ! number of real entries per spot in radiance diagnostic file + integer(i_kind),parameter :: ireal_old_radiag = 26 ! number of real entries per spot in versions older than iversion_radiag_2 + integer(i_kind),parameter :: ipchan_radiag = 8 ! number of entries per channel per spot in radiance diagnostic file + +! Declare structures for radiance diagnostic file information + type diag_header_fix_list + character(len=20) :: isis ! sat and sensor type + character(len=10) :: id ! sat type + character(len=10) :: obstype ! observation type + integer(i_kind) :: jiter ! outer loop counter + integer(i_kind) :: nchan ! number of channels in the sensor + integer(i_kind) :: npred ! number of updating bias correction predictors + integer(i_kind) :: idate ! time (yyyymmddhh) + integer(i_kind) :: ireal ! # of real elements in the fix part of a data record + integer(i_kind) :: ipchan ! # of elements for each channel except for bias correction terms + integer(i_kind) :: iextra ! # of extra elements for each channel + integer(i_kind) :: jextra ! # of extra elements + integer(i_kind) :: idiag ! first dimension of diag_data_chan + integer(i_kind) :: angord ! order of polynomial for adp_anglebc option + integer(i_kind) :: iversion ! radiance diagnostic file version number + integer(i_kind) :: inewpc ! indicator of newpc4pred (1 on, 0 off) + integer(i_kind) :: ijacob ! indicates whether jacobian included (1 yes, 0 no) + integer(i_kind) :: isens ! sensitivity index + end type diag_header_fix_list + + type diag_data_name_list + character(len=10),dimension(ireal_radiag) :: fix + character(len=10),dimension(:),allocatable :: chn + end type diag_data_name_list + + type diag_header_chan_list + real(r_radstat) :: freq ! frequency (Hz) + real(r_radstat) :: polar ! polarization + real(r_radstat) :: wave ! wave number (cm^-1) + real(r_radstat) :: varch ! error variance (or SD error?) + real(r_radstat) :: tlapmean ! mean lapse rate + integer(i_kind):: iuse ! use flag + integer(i_kind):: nuchan ! sensor relative channel number + integer(i_kind):: iochan ! satinfo relative channel number + end type diag_header_chan_list + + type diag_data_fix_list + real(r_radstat) :: lat ! latitude (deg) + real(r_radstat) :: lon ! longitude (deg) + real(r_radstat) :: zsges ! guess elevation at obs location (m) + real(r_radstat) :: obstime ! observation time relative to analysis + real(r_radstat) :: senscn_pos ! sensor scan position (integer(i_kind)) + real(r_radstat) :: satzen_ang ! satellite zenith angle (deg) + real(r_radstat) :: satazm_ang ! satellite azimuth angle (deg) + real(r_radstat) :: solzen_ang ! solar zenith angle (deg) + real(r_radstat) :: solazm_ang ! solar azimumth angle (deg) + real(r_radstat) :: sungln_ang ! sun glint angle (deg) + real(r_radstat) :: water_frac ! fractional coverage by water + real(r_radstat) :: land_frac ! fractional coverage by land + real(r_radstat) :: ice_frac ! fractional coverage by ice + real(r_radstat) :: snow_frac ! fractional coverage by snow + real(r_radstat) :: water_temp ! surface temperature over water (K) + real(r_radstat) :: land_temp ! surface temperature over land (K) + real(r_radstat) :: ice_temp ! surface temperature over ice (K) + real(r_radstat) :: snow_temp ! surface temperature over snow (K) + real(r_radstat) :: soil_temp ! soil temperature (K) + real(r_radstat) :: soil_mois ! soil moisture + real(r_radstat) :: land_type ! land type (integer(i_kind)) + real(r_radstat) :: veg_frac ! vegetation fraction + real(r_radstat) :: snow_depth ! snow depth + real(r_radstat) :: sfc_wndspd ! surface wind speed + real(r_radstat) :: qcdiag1 ! ir=cloud fraction, mw=cloud liquid water + real(r_radstat) :: qcdiag2 ! ir=cloud top pressure, mw=total column water + real(r_radstat) :: tref ! reference temperature (Tr) in NSST + real(r_radstat) :: dtw ! dt_warm at zob + real(r_radstat) :: dtc ! dt_cool at zob + real(r_radstat) :: tz_tr ! d(Tz)/d(Tr) + end type diag_data_fix_list + + type diag_data_chan_list + real(r_radstat) :: tbobs ! Tb (obs) (K) + real(r_radstat) :: omgbc ! Tb_(obs) - Tb_(simulated w/ bc) (K) + real(r_radstat) :: omgnbc ! Tb_(obs) - Tb_(simulated_w/o bc) (K) + real(r_radstat) :: sprd ! ensemble spread + real(r_radstat) :: errinv ! inverse error (K**(-1)) + real(r_radstat) :: qcmark ! quality control mark + real(r_radstat) :: emiss ! surface emissivity + real(r_radstat) :: tlap ! temperature lapse rate + real(r_radstat) :: tb_tz ! d(Tb)/d(Tz) + real(r_radstat) :: bicons ! constant bias correction term + real(r_radstat) :: biang ! scan angle bias correction term + real(r_radstat) :: biclw ! CLW bias correction term + real(r_radstat) :: bilap2 ! square lapse rate bias correction term + real(r_radstat) :: bilap ! lapse rate bias correction term + real(r_radstat) :: bicos ! node*cos(lat) bias correction term + real(r_radstat) :: bisin ! sin(lat) bias correction term + real(r_radstat) :: biemis ! emissivity sensitivity bias correction term + real(r_radstat),dimension(:),allocatable :: bifix ! angle dependent bias + real(r_radstat) :: bisst ! SST bias correction term + end type diag_data_chan_list + + type diag_data_extra_list + real(r_radstat) :: extra ! extra information + end type diag_data_extra_list + + integer(i_kind),save :: iversion_radiag ! Current version (see set routine) + integer(i_kind),parameter:: iversion_radiag_1 = 11104 ! Version when bias-correction entries were modified + integer(i_kind),parameter:: iversion_radiag_2 = 13784 ! Version when NSST entries were added + integer(i_kind),parameter:: iversion_radiag_3 = 19180 ! Version when SSMIS added + integer(i_kind),parameter:: iversion_radiag_4 = 30303 ! Version when emissivity predictor added + integer(i_kind),parameter:: iversion_radiag_5 = 40000 ! Version when ensemble spread (and optional jacobian) added + + real(r_radstat),parameter:: rmiss_radiag = -9.9e11_r_radstat + + logical,save :: netcdf = .false. + + type ncdiag_status + logical :: nc_read + integer(i_kind) :: cur_ob_idx + integer(i_kind) :: num_records + type(diag_data_fix_list), allocatable :: all_data_fix(:) + type(diag_data_chan_list), allocatable :: all_data_chan(:,:) + type(diag_data_extra_list), allocatable :: all_data_extra(:,:,:) + end type ncdiag_status + + integer(i_kind), parameter :: MAX_OPEN_NCDIAG = 2 + integer(i_kind), save :: nopen_ncdiag = 0 + integer(i_kind), dimension(MAX_OPEN_NCDIAG), save :: ncdiag_open_id = (/-1, -1/) + type(ncdiag_status), dimension(MAX_OPEN_NCDIAG), save :: ncdiag_open_status + +contains + +subroutine set_radiag_int_ (what,iv,ier) +character(len=*),intent(in) :: what +integer(i_kind),intent(in) :: iv +integer(i_kind),intent(out):: ier +ier=-1 +if(trim(what)=='version') then + iversion_radiag = iv + ier=0 +endif +end subroutine set_radiag_int_ + +subroutine get_radiag_int_ (what,iv,ier) +character(len=*),intent(in) :: what +integer(i_kind),intent(out):: iv +integer(i_kind),intent(out):: ier +ier=-1 +if(trim(what)=='version') then + iv = iversion_radiag + ier=0 +endif +end subroutine get_radiag_int_ + +subroutine set_netcdf_read(use_netcdf) +! . . . . +! subprogram: read_diag_header_bin read rad diag header +! prgmmr: mccarty org: gmao date: 2015-08-06 +! +! abstract: This routine sets the routines to read from a netcdf file. +! The default currently is to read binary files +! +! program history log: +! 2015-08-06 mccarty - created routine +! +! input argument list: +! use_netcdf - logical .true. tells routine to read netcdf diag +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + logical,intent(in) :: use_netcdf + + netcdf = use_netcdf +end subroutine set_netcdf_read + + +subroutine open_radiag(filename, ftin, istatus) + character*9, intent(in) :: filename + integer(i_kind), intent(inout) :: ftin + integer(i_kind), intent(out):: istatus + + integer(i_kind) :: i + + istatus = -999 + if (netcdf) then + if (nopen_ncdiag >= MAX_OPEN_NCDIAG) then + write(6,*) 'OPEN_RADIAG: ***ERROR*** Cannot open more than ', & + MAX_OPEN_NCDIAG, ' netcdf diag files.' + stop + endif + call nc_diag_read_init(filename,ftin) + istatus=0 + do i = 1, MAX_OPEN_NCDIAG + if (ncdiag_open_id(i) < 0) then + ncdiag_open_id(i) = ftin + ncdiag_open_status(i)%nc_read = .false. + ncdiag_open_status(i)%cur_ob_idx = -9999 + ncdiag_open_status(i)%num_records = -9999 + if (allocated(ncdiag_open_status(i)%all_data_fix)) then + deallocate(ncdiag_open_status(i)%all_data_fix) + endif + if (allocated(ncdiag_open_status(i)%all_data_chan)) then + deallocate(ncdiag_open_status(i)%all_data_chan) + endif + if (allocated(ncdiag_open_status(i)%all_data_extra)) then + deallocate(ncdiag_open_status(i)%all_data_extra) + endif + nopen_ncdiag = nopen_ncdiag + 1 + exit + endif + enddo + else + open(ftin,form="unformatted",file=filename,access="sequential",convert="big_endian",iostat=istatus) + rewind(ftin) + endif + +end subroutine open_radiag + +subroutine close_radiag(filename, ftin) + character*9, intent(in) :: filename + integer(i_kind), intent(inout) :: ftin + + integer(i_kind) :: id + if (netcdf) then + id = find_ncdiag_id(ftin) + if (id < 0) then + write(6,*) 'CLOSE_RADIAG: ***ERROR*** ncdiag file ', filename, & + ' was not opened' + stop + endif + call nc_diag_read_close(filename) + ncdiag_open_id(id) = -1 + ncdiag_open_status(id)%nc_read = .false. + ncdiag_open_status(id)%cur_ob_idx = -9999 + ncdiag_open_status(id)%num_records = -9999 + if (allocated(ncdiag_open_status(id)%all_data_fix)) then + deallocate(ncdiag_open_status(id)%all_data_fix) + endif + if (allocated(ncdiag_open_status(id)%all_data_chan)) then + deallocate(ncdiag_open_status(id)%all_data_chan) + endif + if (allocated(ncdiag_open_status(id)%all_data_extra)) then + deallocate(ncdiag_open_status(id)%all_data_extra) + endif + nopen_ncdiag = nopen_ncdiag - 1 + else + close(ftin) + endif +end subroutine close_radiag + +!subroutine read_radiag_header(ftin,npred_radiag,retrieval,header_fix,header_chan,data_name,iflag,lverbose) +subroutine read_radiag_header(ftin,retrieval,header_fix,header_chan,data_name,iflag,lverbose) +! . . . . +! subprogram: read_diag_header_bin read rad diag header +! prgmmr: mccarty org: gmao date: 2015-08-06 +! +! abstract: This routine reads the header record from a radiance +! diagnostic file +! +! program history log: +! 2015-08-06 mccarty - created routine w/ fork for ncdiag or binary +! +! input argument list: +! ftin - unit number connected to diagnostic file +! npred_radiag - number of bias correction terms +! retrieval - .true. if sst retrieval +! +! output argument list: +! header_fix - header information structure +! header_chan - channel information structure +! data_name - diag file data names +! iflag - error code +! lverbose - optional flag to turn off default output to standard out +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin +! integer(i_kind),intent(in) :: npred_radiag + logical,intent(in) :: retrieval + type(diag_header_fix_list ),intent(out):: header_fix + type(diag_header_chan_list),allocatable :: header_chan(:) + type(diag_data_name_list) :: data_name + integer(i_kind),intent(out) :: iflag + logical,optional,intent(in) :: lverbose + + iflag = 0 + if (netcdf) then + call read_radiag_header_nc(ftin,header_fix,header_chan,iflag) + else +! call read_radiag_header_bin(ftin,npred_radiag,retrieval,header_fix,header_chan,data_name,iflag,lverbose) + call read_radiag_header_bin(ftin,retrieval,header_fix,header_chan,data_name,iflag,lverbose) + + endif + +end subroutine read_radiag_header + +subroutine read_radiag_header_nc(ftin,header_fix,header_chan,iflag) +! . . . . +! subprogram: read_diag_header_nc read rad diag header +! prgmmr: mccarty org: gmao date: 2003-01-01 +! +! abstract: This routine reads the header record from a radiance +! diagnostic file +! +! program history log: +! 2015-08-06 mccarty - Created routine for ncdiag header reading +! +! input argument list: +! ftin - unit number connected to diagnostic file +! +! output argument list: +! header_fix - header information structure +! header_chan - channel information structure +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + type(diag_header_fix_list ),intent(out):: header_fix + type(diag_header_chan_list),allocatable :: header_chan(:) + integer(i_kind),intent(out) :: iflag + +! local variables + integer(i_kind) :: nchan_dim + real(r_kind),allocatable,dimension(:) :: r_var_stor + integer(i_kind),allocatable,dimension(:) :: i_var_stor + character(20) :: isis + character(10) :: id, obstype +! integer(i_kind),dimension(:),allocatable :: jiter, nchan_diag, npred, idate, & + integer(i_kind) :: jiter, nchan_diag, npred, idate, & + ireal, ipchan, iextra, jextra, & + idiag, angord, iversion, inewpc, & + isens, ijacob + + iflag = 0 +! allocate(nchan_diag(1) ) + nchan_dim = nc_diag_read_get_dim(ftin,'nchans') + header_fix%nchan = nchan_dim + + call nc_diag_read_get_global_attr(ftin, "Number_of_channels", nchan_diag) + + if (nchan_dim /= nchan_diag) then + write(*,*)'ERROR: Number of channels from dimension do not match those from header, aborting.' + stop + endif + + call nc_diag_read_get_global_attr(ftin, "Satellite_Sensor", isis) ; header_fix%isis = isis + call nc_diag_read_get_global_attr(ftin, "Satellite", id) ; header_fix%id = id + call nc_diag_read_get_global_attr(ftin, "Observation_type", obstype) ; header_fix%obstype = obstype + call nc_diag_read_get_global_attr(ftin, "Outer_Loop_Iteration", jiter) ; header_fix%jiter = jiter + call nc_diag_read_get_global_attr(ftin, "Number_of_Predictors", npred) ; header_fix%npred = npred + call nc_diag_read_get_global_attr(ftin, "date_time", idate) ; header_fix%idate = idate + call nc_diag_read_get_global_attr(ftin, "ireal_radiag", ireal) ; header_fix%ireal = ireal + call nc_diag_read_get_global_attr(ftin, "ipchan_radiag", ipchan) ; header_fix%ipchan = ipchan + call nc_diag_read_get_global_attr(ftin, "iextra", iextra) ; header_fix%iextra = iextra + call nc_diag_read_get_global_attr(ftin, "jextra", jextra) ; header_fix%jextra = jextra + call nc_diag_read_get_global_attr(ftin, "idiag", idiag) ; header_fix%idiag = idiag + call nc_diag_read_get_global_attr(ftin, "angord", angord) ; header_fix%angord = angord + call nc_diag_read_get_global_attr(ftin, "iversion_radiag", iversion) ; header_fix%iversion = iversion + call nc_diag_read_get_global_attr(ftin, "New_pc4pred", inewpc) ; header_fix%inewpc = inewpc + call nc_diag_read_get_global_attr(ftin, "ioff0", isens) ; header_fix%isens = isens + call nc_diag_read_get_global_attr(ftin, "ijacob", ijacob) ; header_fix%ijacob = ijacob + + + if (allocated(header_chan)) deallocate(header_chan) + allocate(header_chan(nchan_dim) ) + + if (allocated(r_var_stor)) deallocate(r_var_stor) + if (allocated(i_var_stor)) deallocate(i_var_stor) + allocate(r_var_stor(nchan_dim), & + i_var_stor(nchan_dim) ) +! call nc_diag_read_get_var('Var', var_stor) + call nc_diag_read_get_var(ftin, 'frequency',r_var_stor) ; header_chan%freq = r_var_stor + call nc_diag_read_get_var(ftin, 'polarization',i_var_stor) ; header_chan%polar = i_var_stor + call nc_diag_read_get_var(ftin, 'wavenumber',r_var_stor) ; header_chan%wave = r_var_stor + call nc_diag_read_get_var(ftin, 'error_variance',r_var_stor) ; header_chan%varch = r_var_stor + call nc_diag_read_get_var(ftin, 'mean_lapse_rate',r_var_stor); header_chan%tlapmean = r_var_stor + call nc_diag_read_get_var(ftin, 'use_flag',i_var_stor) ; header_chan%iuse = i_var_stor + call nc_diag_read_get_var(ftin, 'sensor_chan',i_var_stor) ; header_chan%nuchan = i_var_stor + call nc_diag_read_get_var(ftin, 'satinfo_chan',i_var_stor) ; header_chan%iochan = i_var_stor + + +end subroutine read_radiag_header_nc + +!subroutine read_radiag_header_bin(ftin,npred_radiag,retrieval,header_fix,header_chan,data_name,iflag,lverbose) +subroutine read_radiag_header_bin(ftin,retrieval,header_fix,header_chan,data_name,iflag,lverbose) + +! . . . . +! subprogram: read_diag_header_bin read rad diag header +! prgmmr: tahara org: np20 date: 2003-01-01 +! +! abstract: This routine reads the header record from a radiance +! diagnostic file +! +! program history log: +! 2010-10-05 treadon - add this doc block +! 2011-02-22 kleist - changes related to memory allocation and standard output +! 2014-07-25 sienkiewicz - supress warning if npred_radiag == 0 +! 2017-07-17 mccarty - renamed routine to _bin suffix for ncdiag +! +! input argument list: +! ftin - unit number connected to diagnostic file +! npred_radiag - number of bias correction terms +! retrieval - .true. if sst retrieval +! +! output argument list: +! header_fix - header information structure +! header_chan - channel information structure +! data_name - diag file data names +! iflag - error code +! lverbose - optional flag to turn off default output to standard out +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin +! integer(i_kind),intent(in) :: npred_radiag + logical,intent(in) :: retrieval + type(diag_header_fix_list ),intent(out):: header_fix + type(diag_header_chan_list),allocatable :: header_chan(:) + type(diag_data_name_list) :: data_name + integer(i_kind),intent(out) :: iflag + logical,optional,intent(in) :: lverbose + +! Declare local variables + character(len=2):: string + character(len=10):: satid,sentype + character(len=20):: sensat + integer(i_kind) :: i,ich + integer(i_kind):: jiter,nchanl,npred,ianldate,ireal,ipchan,iextra,jextra + integer(i_kind):: idiag,angord,iversion,inewpc,isens,ijacob + integer(i_kind):: iuse_tmp,nuchan_tmp,iochan_tmp + real(r_radstat) :: freq_tmp,polar_tmp,wave_tmp,varch_tmp,tlapmean_tmp + logical loutall + + loutall=.true. + if(present(lverbose)) loutall=lverbose + +! Read header (fixed_part). + read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc,isens,ijacob + if (iflag/=0) then + rewind(ftin) + read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc,isens + ijacob=0 + if (iflag/=0) then + rewind(ftin) + read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra,idiag,angord,iversion,inewpc + isens=0 + end if + end if + + if (iflag/=0) then + rewind(ftin) + read(ftin,IOSTAT=iflag) sensat,satid,sentype,jiter,nchanl,npred,ianldate,& + ireal,ipchan,iextra,jextra + idiag=ipchan+npred+1 + angord=0 + iversion=0 + inewpc=0 + isens=0 + if (iflag/=0) then + write(6,*)'READ_RADIAG_HEADER: ***ERROR*** Unknown file format. Cannot read' + return + endif + endif + + header_fix%isis = sensat + header_fix%id = satid + header_fix%obstype = sentype + header_fix%jiter = jiter + header_fix%nchan = nchanl + header_fix%npred = npred + header_fix%idate = ianldate + header_fix%ireal = ireal + header_fix%ipchan = ipchan + header_fix%iextra = iextra + header_fix%jextra = jextra + header_fix%idiag = idiag + header_fix%ijacob = ijacob + header_fix%angord = angord + header_fix%iversion= iversion + header_fix%inewpc = inewpc + header_fix%isens = isens + + if (loutall) then + write(6,*)'READ_RADIAG_HEADER: isis=',header_fix%isis,& + ' nchan=',header_fix%nchan,& + ' npred=',header_fix%npred,& + ' angord=',header_fix%angord,& + ' idiag=',header_fix%idiag,& + ' iversion=',header_fix%iversion,& + ' inewpc=',header_fix%inewpc,& + ' isens=',header_fix%isens,& + ' ijacob=',header_fix%ijacob + + if ( header_fix%iextra /= 0) & + write(6,*)'READ_RADIAG_HEADER: extra diagnostic information available, ',& + 'iextra=',header_fix%iextra + end if + +! if (header_fix%npred /= npred_radiag .and. npred_radiag /= 0) & +! write(6,*) 'READ_RADIAG_HEADER: **WARNING** header_fix%npred,npred=',& +! header_fix%npred,npred_radiag + +! Allocate and initialize as needed + if (allocated(header_chan)) deallocate(header_chan) + if (allocated(data_name%chn)) deallocate(data_name%chn) + + allocate(header_chan( header_fix%nchan)) + allocate(data_name%chn(header_fix%idiag)) + + data_name%fix(1) ='lat ' + data_name%fix(2) ='lon ' + data_name%fix(3) ='zsges ' + data_name%fix(4) ='obstim ' + data_name%fix(5) ='scanpos ' + data_name%fix(6) ='satzen ' + data_name%fix(7) ='satazm ' + data_name%fix(8) ='solzen ' + data_name%fix(9) ='solazm ' + data_name%fix(10)='sungln ' + data_name%fix(11)='fwater ' + data_name%fix(12)='fland ' + data_name%fix(13)='fice ' + data_name%fix(14)='fsnow ' + data_name%fix(15)='twater ' + data_name%fix(16)='tland ' + data_name%fix(17)='tice ' + data_name%fix(18)='tsnow ' + data_name%fix(19)='tsoil ' + data_name%fix(20)='soilmoi ' + data_name%fix(21)='landtyp ' + data_name%fix(22)='vegfrac ' + data_name%fix(23)='snowdep ' + data_name%fix(24)='wndspd ' + data_name%fix(25)='qc1 ' + data_name%fix(26)='qc2 ' + data_name%fix(27)='tref ' + data_name%fix(28)='dtw ' + data_name%fix(29)='dtc ' + data_name%fix(30)='tz_tr ' + + data_name%chn(1)='obs ' + data_name%chn(2)='omgbc ' + data_name%chn(3)='omgnbc ' + data_name%chn(4)='errinv ' + data_name%chn(5)='qcmark ' + data_name%chn(6)='emiss ' + data_name%chn(7)='tlap ' + data_name%chn(8)='tb_tz ' + + if (header_fix%iversion < iversion_radiag_1) then + data_name%chn( 8)= 'bifix ' + data_name%chn( 9)= 'bilap ' + data_name%chn(10)= 'bilap2 ' + data_name%chn(11)= 'bicons ' + data_name%chn(12)= 'biang ' + data_name%chn(13)= 'biclw ' + if (retrieval) data_name%chn(13)= 'bisst ' + elseif ( header_fix%iversion < iversion_radiag_2 .and. header_fix%iversion >= iversion_radiag_1 ) then + data_name%chn( 8)= 'bicons ' + data_name%chn( 9)= 'biang ' + data_name%chn(10)= 'biclw ' + data_name%chn(11)= 'bilap2 ' + data_name%chn(12)= 'bilap ' + do i=1,header_fix%angord + write(string,'(i2.2)') header_fix%angord-i+1 + data_name%chn(12+i)= 'bifix' // string + end do + data_name%chn(12+header_fix%angord+1)= 'bifix ' + data_name%chn(12+header_fix%angord+2)= 'bisst ' + elseif ( header_fix%iversion < iversion_radiag_3 .and. header_fix%iversion >= iversion_radiag_2 ) then + data_name%chn( 9)= 'bicons ' + data_name%chn(10)= 'biang ' + data_name%chn(11)= 'biclw ' + data_name%chn(12)= 'bilap2 ' + data_name%chn(13)= 'bilap ' + do i=1,header_fix%angord + write(string,'(i2.2)') header_fix%angord-i+1 + data_name%chn(13+i)= 'bifix' // string + end do + data_name%chn(13+header_fix%angord+1)= 'bifix ' + data_name%chn(13+header_fix%angord+2)= 'bisst ' + elseif ( header_fix%iversion < iversion_radiag_4 .and. header_fix%iversion >= iversion_radiag_3 ) then + data_name%chn( 9)= 'bicons ' + data_name%chn(10)= 'biang ' + data_name%chn(11)= 'biclw ' + data_name%chn(12)= 'bilap2 ' + data_name%chn(13)= 'bilap ' + data_name%chn(14)= 'bicos ' + data_name%chn(15)= 'bisin ' + do i=1,header_fix%angord + write(string,'(i2.2)') header_fix%angord-i+1 + data_name%chn(15+i)= 'bifix' // string + end do + data_name%chn(15+header_fix%angord+1)= 'bifix ' + data_name%chn(15+header_fix%angord+2)= 'bisst ' + else + data_name%chn( 9)= 'bicons ' + data_name%chn(10)= 'biang ' + data_name%chn(11)= 'biclw ' + data_name%chn(12)= 'bilap2 ' + data_name%chn(13)= 'bilap ' + data_name%chn(14)= 'bicos ' + data_name%chn(15)= 'bisin ' + data_name%chn(16)= 'biemis ' + do i=1,header_fix%angord + write(string,'(i2.2)') header_fix%angord-i+1 + data_name%chn(16+i)= 'bifix' // string + end do + data_name%chn(16+header_fix%angord+1)= 'bifix ' + data_name%chn(16+header_fix%angord+2)= 'bisst ' + endif + +! Read header (channel part) + do ich=1, header_fix%nchan + read(ftin,IOSTAT=iflag) freq_tmp,polar_tmp,wave_tmp,varch_tmp,tlapmean_tmp,iuse_tmp,nuchan_tmp,iochan_tmp + header_chan(ich)%freq = freq_tmp + header_chan(ich)%polar = polar_tmp + header_chan(ich)%wave = wave_tmp + header_chan(ich)%varch = varch_tmp + header_chan(ich)%tlapmean = tlapmean_tmp + header_chan(ich)%iuse = iuse_tmp + header_chan(ich)%nuchan = nuchan_tmp + header_chan(ich)%iochan = iochan_tmp + if (iflag/=0) return + end do + +! Construct array containing menonics for data record entries + + +end subroutine read_radiag_header_bin + +integer(i_kind) function find_ncdiag_id(ftin) + integer(i_kind), intent(in) :: ftin + + integer(i_kind) :: i + + find_ncdiag_id = -1 + do i = 1, MAX_OPEN_NCDIAG + if (ncdiag_open_id(i) == ftin) then + find_ncdiag_id = i + return + endif + enddo + return + +end function find_ncdiag_id + +subroutine read_radiag_data(ftin,header_fix,retrieval,data_fix,data_chan,data_extra,iflag ) +! . . . . +! subprogram: read_radiag_dat read rad diag data +! prgmmr: tahara org: np20 date: 2003-01-01 +! +! abstract: This routine reads the data record from a radiance +! diagnostic file +! +! program history log: +! 2010-10-05 treadon - add this doc block +! 2011-02-22 kleist - changes related to memory allocation +! 2017-07-17 mccarty - change routine to be generalized for bin/nc4 files +! +! input argument list: +! ftin - unit number connected to diagnostic file +! header_fix - header information structure +! +! output argument list: +! data_fix - spot header information structure +! data_chan - spot channel information structure +! data_extra - spot extra information +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + type(diag_header_fix_list ),intent(in) :: header_fix + logical,intent(in) :: retrieval + type(diag_data_fix_list) ,intent(out):: data_fix + type(diag_data_chan_list) ,allocatable :: data_chan(:) + type(diag_data_extra_list) ,allocatable :: data_extra(:,:) + integer(i_kind),intent(out) :: iflag + + integer(i_kind) :: id + + if (netcdf) then + + id = find_ncdiag_id(ftin) + if (id < 0) then + write(6,*) 'READ_RADIAG_DATA: ***ERROR*** netcdf diag file ', ftin, ' has not been opened yet.' + iflag = -2 + return + endif + + if (.not. ncdiag_open_status(id)%nc_read) then + call read_radiag_data_nc_init(ftin, ncdiag_open_status(id), header_fix, retrieval, iflag) + endif + + if (iflag /= 0) then + return + endif + + if (ncdiag_open_status(id)%cur_ob_idx == ncdiag_open_status(id)%num_records ) then + iflag = 0 + else if (ncdiag_open_status(id)%cur_ob_idx > ncdiag_open_status(id)%num_records) then + iflag = -1 + else + iflag = 1 + endif + + if (iflag >= 0) then + call read_radiag_data_nc(ncdiag_open_status(id),header_fix,data_fix,data_chan,data_extra,iflag) + endif + + else + call read_radiag_data_bin(ftin,header_fix,retrieval,data_fix,data_chan,data_extra,iflag ) + endif + +end subroutine read_radiag_data + +subroutine read_radiag_data_nc_init(ftin, diag_status, header_fix, retrieval, iflag) +! . . . . +! subprogram: read_radiag_data_nc_init read rad diag data +! prgmmr: mccarty org: np20 date: 2015-08-10 +! +! abstract: This routine reads the data record from a netcdf radiance +! diagnostic file +! +! program history log: +! 2015-06-10 mccarty - create routine +! +! input argument list: +! ftin - unit number connected to diagnostic file +! header_fix - header information structure +! +! output argument list: +! data_fix - spot header information structure +! data_chan - spot channel information structure +! data_extra - spot extra information +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + type(ncdiag_status), intent(inout) :: diag_status + type(diag_header_fix_list ),intent(in) :: header_fix + logical,intent(in) :: retrieval + integer(i_kind),intent(out) :: iflag + +! Declare local variables + integer(i_kind) :: nrecord, ndatum, nangord + integer(i_kind) :: cch, ic, ir, cdatum, nsdim + real(r_radstat), allocatable, dimension(:) :: Latitude, Longitude, Elevation, Obs_Time, Scan_Position, & + Sat_Zenith_Angle, Sat_Azimuth_Angle, Sol_Zenith_Angle, Sol_Azimuth_Angle, & + Sun_Glint_Angle, Water_Fraction, Land_Fraction, Ice_Fraction, & + Snow_Fraction, Water_Temperature, Land_Temperature, Ice_Temperature, & + Snow_Temperature, Soil_Temperature, Soil_Moisture, & + tsavg5, sstcu, sstph, sstnv, dta, dqa, dtp_avh, Vegetation_Fraction, & + Snow_Depth, tpwc_amsua, clw_guess_retrieval, Sfc_Wind_Speed, & + Cloud_Frac, CTP, CLW, TPWC, clw_obs, clw_guess, Foundation_Temperature, SST_Warm_layer_dt, & + SST_Cool_layer_tdrop, SST_dTz_dTfound, Observation, Obs_Minus_Forecast_adjusted, & + Obs_Minus_Forecast_unadjusted, Inverse_Observation_Error, QC_Flag, Emissivity, & + Weighted_Lapse_Rate, dTb_dTs, BC_Constant, BC_Scan_Angle, & + BC_Cloud_Liquid_Water, BC_Lapse_Rate_Squared, BC_Lapse_Rate, BC_Cosine_Latitude_times_Node, & + BC_Sine_Latitude,BC_Emissivity,BC_Fixed_Scan_Position, Press_Max_Weight_Function + integer(i_kind), allocatable, dimension(:) :: Channel_Index, Land_Type_Index + real(r_radstat), allocatable, dimension(:,:) :: BC_angord ! (nobs, BC_angord_arr_dim) ; + real(r_radstat), allocatable, dimension(:,:) :: Observation_Operator_Jacobian + + real(r_kind) :: clat, clon + + ndatum = nc_diag_read_get_dim(ftin,'nobs') + if (ndatum <= 0) then + iflag = -3 + return + endif + + if (header_fix%angord > 0) then + nangord = nc_diag_read_get_dim(ftin,'BC_angord_arr_dim') + end if + + nrecord = ndatum / header_fix%nchan + diag_status%num_records = nrecord + + allocate( Channel_Index(ndatum), & + Latitude(ndatum), Longitude(ndatum), Elevation(ndatum), & + Obs_Time(ndatum), Scan_Position(ndatum), Sat_Zenith_Angle(ndatum), & + Sat_Azimuth_Angle(ndatum), Sol_Zenith_Angle(ndatum), Sol_Azimuth_Angle(ndatum), & + Sun_Glint_Angle(ndatum), Water_Fraction(ndatum), Land_Fraction(ndatum), & + Ice_Fraction(ndatum), Snow_Fraction(ndatum), Water_Temperature(ndatum), & + Land_Temperature(ndatum), Ice_Temperature(ndatum), Snow_Temperature(ndatum), & + Soil_Temperature(ndatum), Soil_Moisture(ndatum), tsavg5(ndatum), & + sstcu(ndatum), sstph(ndatum), sstnv(ndatum), & + dta(ndatum), dqa(ndatum), dtp_avh(ndatum), & + Vegetation_Fraction(ndatum), Snow_Depth(ndatum), tpwc_amsua(ndatum), & + clw_guess_retrieval(ndatum), Sfc_Wind_Speed(ndatum), Cloud_Frac(ndatum), & + CTP(ndatum), CLW(ndatum), TPWC(ndatum), & + clw_obs(ndatum), clw_guess(ndatum), Foundation_Temperature(ndatum), & + SST_Warm_layer_dt(ndatum), SST_Cool_layer_tdrop(ndatum), SST_dTz_dTfound(ndatum), & + Observation(ndatum), Obs_Minus_Forecast_adjusted(ndatum),Obs_Minus_Forecast_unadjusted(ndatum), & + Inverse_Observation_Error(ndatum),QC_Flag(ndatum), Emissivity(ndatum), & + Weighted_Lapse_Rate(ndatum), dTb_dTs(ndatum), BC_Constant(ndatum), & + BC_Scan_Angle(ndatum), BC_Cloud_Liquid_Water(ndatum), BC_Lapse_Rate_Squared(ndatum), & + BC_Lapse_Rate(ndatum), BC_Cosine_Latitude_times_Node(ndatum), BC_Sine_Latitude(ndatum), & + BC_Emissivity(ndatum), BC_Fixed_Scan_Position(ndatum), Land_Type_Index(ndatum) ) + + if (header_fix%iextra > 0) then + allocate(Press_Max_Weight_Function(ndatum)) + endif + if (header_fix%angord > 0) then + allocate( BC_angord(nangord, ndatum) ) + end if + if (header_fix%ijacob > 0) then + call nc_diag_read_get_global_attr(ftin, "Number_of_state_vars", nsdim) + allocate(Observation_Operator_Jacobian(nsdim, ndatum)) + endif + + if (allocated(diag_status%all_data_fix)) deallocate(diag_status%all_data_fix) + if (allocated(diag_status%all_data_chan)) deallocate(diag_status%all_data_chan) + if (allocated(diag_status%all_data_extra)) deallocate(diag_status%all_data_extra) + allocate( diag_status%all_data_fix(nrecord) ) + allocate( diag_status%all_data_chan(nrecord, header_fix%nchan)) + allocate( diag_status%all_data_extra(nrecord, header_fix%iextra, header_fix%jextra) ) + + call nc_diag_read_get_var(ftin, 'Channel_Index', Channel_Index) + call nc_diag_read_get_var(ftin, 'Latitude', Latitude) + call nc_diag_read_get_var(ftin, 'Longitude', Longitude) + call nc_diag_read_get_var(ftin, 'Elevation', Elevation) + call nc_diag_read_get_var(ftin, 'Obs_Time', Obs_Time) + call nc_diag_read_get_var(ftin, 'Scan_Position', Scan_Position) + call nc_diag_read_get_var(ftin, 'Sat_Zenith_Angle', Sat_Zenith_Angle) + call nc_diag_read_get_var(ftin, 'Sat_Azimuth_Angle', Sat_Azimuth_Angle) + call nc_diag_read_get_var(ftin, 'Sol_Zenith_Angle', Sol_Zenith_Angle) + call nc_diag_read_get_var(ftin, 'Sol_Azimuth_Angle', Sol_Azimuth_Angle) + call nc_diag_read_get_var(ftin, 'Sun_Glint_Angle', Sun_Glint_Angle) + call nc_diag_read_get_var(ftin, 'Water_Fraction', Water_Fraction) + call nc_diag_read_get_var(ftin, 'Land_Fraction', Land_Fraction) + call nc_diag_read_get_var(ftin, 'Ice_Fraction', Ice_Fraction) + call nc_diag_read_get_var(ftin, 'Snow_Fraction', Snow_Fraction) + call nc_diag_read_get_var(ftin, 'Water_Temperature', Water_Temperature) + call nc_diag_read_get_var(ftin, 'Land_Temperature', Land_Temperature) + call nc_diag_read_get_var(ftin, 'Ice_Temperature', Ice_Temperature) + call nc_diag_read_get_var(ftin, 'Snow_Temperature', Snow_Temperature) + call nc_diag_read_get_var(ftin, 'Soil_Temperature', Soil_Temperature) + call nc_diag_read_get_var(ftin, 'Soil_Moisture', Soil_Moisture) + call nc_diag_read_get_var(ftin, 'tsavg5', tsavg5) + call nc_diag_read_get_var(ftin, 'sstcu', sstcu) + call nc_diag_read_get_var(ftin, 'sstph', sstph) + call nc_diag_read_get_var(ftin, 'sstnv', sstnv) + call nc_diag_read_get_var(ftin, 'dta', dta) + call nc_diag_read_get_var(ftin, 'dqa', dqa) + call nc_diag_read_get_var(ftin, 'dtp_avh', dtp_avh) + call nc_diag_read_get_var(ftin, 'Vegetation_Fraction', Vegetation_Fraction) + call nc_diag_read_get_var(ftin, 'Snow_Depth', Snow_Depth) + call nc_diag_read_get_var(ftin, 'tpwc_amsua', tpwc_amsua) + call nc_diag_read_get_var(ftin, 'clw_guess_retrieval', clw_guess_retrieval) + call nc_diag_read_get_var(ftin, 'Sfc_Wind_Speed', Sfc_Wind_Speed) + call nc_diag_read_get_var(ftin, 'Cloud_Frac', Cloud_Frac) + call nc_diag_read_get_var(ftin,'CTP', CTP) + call nc_diag_read_get_var(ftin, 'CLW', CLW) + call nc_diag_read_get_var(ftin, 'TPWC', TPWC) + call nc_diag_read_get_var(ftin, 'clw_obs', clw_obs) + call nc_diag_read_get_var(ftin, 'clw_guess', clw_guess) + call nc_diag_read_get_var(ftin, 'Foundation_Temperature', Foundation_Temperature) + call nc_diag_read_get_var(ftin, 'SST_Warm_layer_dt', SST_Warm_layer_dt) + call nc_diag_read_get_var(ftin, 'SST_Cool_layer_tdrop', SST_Cool_layer_tdrop) + call nc_diag_read_get_var(ftin, 'SST_dTz_dTfound', SST_dTz_dTfound) + call nc_diag_read_get_var(ftin, 'Observation', Observation) + call nc_diag_read_get_var(ftin, 'Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted) + call nc_diag_read_get_var(ftin, 'Obs_Minus_Forecast_unadjusted', Obs_Minus_Forecast_unadjusted) + call nc_diag_read_get_var(ftin, 'Inverse_Observation_Error', Inverse_Observation_Error) + call nc_diag_read_get_var(ftin, 'QC_Flag', QC_Flag) + call nc_diag_read_get_var(ftin, 'Emissivity', Emissivity) + call nc_diag_read_get_var(ftin, 'Weighted_Lapse_Rate', Weighted_Lapse_Rate) + call nc_diag_read_get_var(ftin, 'dTb_dTs', dTb_dTs) + call nc_diag_read_get_var(ftin, 'BC_Constant', BC_Constant) + call nc_diag_read_get_var(ftin, 'BC_Scan_Angle', BC_Scan_Angle) + call nc_diag_read_get_var(ftin, 'BC_Cloud_Liquid_Water', BC_Cloud_Liquid_Water) + call nc_diag_read_get_var(ftin, 'BC_Lapse_Rate_Squared', BC_Lapse_Rate_Squared) + call nc_diag_read_get_var(ftin, 'BC_Lapse_Rate', BC_Lapse_Rate) + call nc_diag_read_get_var(ftin, 'BC_Cosine_Latitude_times_Node', BC_Cosine_Latitude_times_Node) + call nc_diag_read_get_var(ftin, 'BC_Sine_Latitude', BC_Sine_Latitude) + call nc_diag_read_get_var(ftin, 'BC_Emissivity', BC_Emissivity) + call nc_diag_read_get_var(ftin, 'BC_Fixed_Scan_Position', BC_Fixed_Scan_Position) + call nc_diag_read_get_var(ftin, 'Land_Type_Index', Land_Type_Index) + if (header_fix%iextra > 0) then + call nc_diag_read_get_var(ftin, 'Press_Max_Weight_Function', Press_Max_Weight_Function) + endif + if (header_fix%angord > 0) then + call nc_diag_read_get_var(ftin, 'BC_angord ', BC_angord ) + end if + if (header_fix%ijacob > 0) then + call nc_diag_read_get_var(ftin, 'Observation_Operator_Jacobian', Observation_Operator_Jacobian) + endif + cdatum = 1 + +! allocate( all_data_fix(nrecord) ) +! allocate( all_data_chan(nrecord, nchan)) + + + do ir=1,nrecord + clat = Latitude(cdatum) + clon = Longitude(cdatum) + diag_status%all_data_fix(ir)%lat = Latitude(cdatum) + diag_status%all_data_fix(ir)%lon = Longitude(cdatum) + diag_status%all_data_fix(ir)%zsges = Elevation(cdatum) + diag_status%all_data_fix(ir)%obstime = Obs_Time(cdatum) + diag_status%all_data_fix(ir)%senscn_pos = Scan_Position(cdatum) + diag_status%all_data_fix(ir)%satzen_ang = Sat_Zenith_Angle(cdatum) + diag_status%all_data_fix(ir)%satazm_ang = Sat_Azimuth_Angle(cdatum) + diag_status%all_data_fix(ir)%solzen_ang = Sol_Zenith_Angle(cdatum) + diag_status%all_data_fix(ir)%solazm_ang = Sol_Azimuth_Angle(cdatum) + diag_status%all_data_fix(ir)%sungln_ang = Sun_Glint_Angle(cdatum) + diag_status%all_data_fix(ir)%water_frac = Water_Fraction(cdatum) + diag_status%all_data_fix(ir)%land_frac = Land_Fraction(cdatum) + diag_status%all_data_fix(ir)%ice_frac = Ice_Fraction(cdatum) + diag_status%all_data_fix(ir)%snow_frac = Snow_Fraction(cdatum) + diag_status%all_data_fix(ir)%water_temp = Water_Temperature(cdatum) + diag_status%all_data_fix(ir)%land_temp = Land_Temperature(cdatum) + diag_status%all_data_fix(ir)%ice_temp = Ice_Temperature(cdatum) + diag_status%all_data_fix(ir)%snow_temp = Snow_Temperature(cdatum) + diag_status%all_data_fix(ir)%soil_temp = Soil_Temperature(cdatum) + diag_status%all_data_fix(ir)%soil_mois = Soil_Moisture(cdatum) + diag_status%all_data_fix(ir)%land_type = Land_Type_Index(cdatum) + diag_status%all_data_fix(ir)%veg_frac = Vegetation_Fraction(cdatum) + diag_status%all_data_fix(ir)%snow_depth = Snow_Depth(cdatum) + diag_status%all_data_fix(ir)%sfc_wndspd = Sfc_Wind_Speed(cdatum) + diag_status%all_data_fix(ir)%qcdiag1 = Cloud_Frac(cdatum) + diag_status%all_data_fix(ir)%qcdiag2 = CTP(cdatum) + diag_status%all_data_fix(ir)%tref = Foundation_Temperature(cdatum) + diag_status%all_data_fix(ir)%dtw = SST_Warm_layer_dt(cdatum) + diag_status%all_data_fix(ir)%dtc = SST_Cool_layer_tdrop(cdatum) + diag_status%all_data_fix(ir)%tz_tr = SST_dTz_dTfound(cdatum) + + if (retrieval) then + diag_status%all_data_fix(ir)%water_temp = tsavg5(cdatum) + diag_status%all_data_fix(ir)%land_temp = sstcu(cdatum) + diag_status%all_data_fix(ir)%ice_temp = sstph(cdatum) + diag_status%all_data_fix(ir)%snow_temp = sstnv(cdatum) + diag_status%all_data_fix(ir)%soil_temp = dta(cdatum) + diag_status%all_data_fix(ir)%soil_mois = dqa(cdatum) + diag_status%all_data_fix(ir)%land_type = dtp_avh(cdatum) + endif + + do ic=1,header_fix%nchan + if (clat /= Latitude(cdatum) .or. clon /= Longitude(cdatum)) then + write(*,*) 'ERROR: Lats & Lons are mismatched. This is bad' + print *,'irecord=',ir + print *,'clat,clon=',clat,clon + print *,'lat/lon(datum)=',Latitude(cdatum), Longitude(cdatum) + call abort + endif + cch = Channel_Index(cdatum) + if (allocated(diag_status%all_data_chan(ir,cch)%bifix)) deallocate(diag_status%all_data_chan(ir,cch)%bifix ) + if (header_fix%angord > 0) then + allocate(diag_status%all_data_chan(ir,cch)%bifix(nangord)) + else + allocate(diag_status%all_data_chan(ir,cch)%bifix(1)) + end if + + diag_status%all_data_chan(ir,cch)%tbobs = Observation(cdatum) + diag_status%all_data_chan(ir,cch)%omgbc = Obs_Minus_Forecast_adjusted(cdatum) + diag_status%all_data_chan(ir,cch)%omgnbc= Obs_Minus_Forecast_unadjusted(cdatum) + diag_status%all_data_chan(ir,cch)%errinv= Inverse_Observation_Error(cdatum) + diag_status%all_data_chan(ir,cch)%qcmark= QC_Flag(cdatum) + diag_status%all_data_chan(ir,cch)%emiss = Emissivity(cdatum) + diag_status%all_data_chan(ir,cch)%tlap = Weighted_Lapse_Rate(cdatum) + diag_status%all_data_chan(ir,cch)%tb_tz = dTb_dTs(cdatum) + diag_status%all_data_chan(ir,cch)%bicons= BC_Constant(cdatum) + diag_status%all_data_chan(ir,cch)%biang = BC_Scan_Angle(cdatum) + diag_status%all_data_chan(ir,cch)%biclw = BC_Cloud_Liquid_Water(cdatum) + diag_status%all_data_chan(ir,cch)%bilap2= BC_Lapse_Rate_Squared(cdatum) + diag_status%all_data_chan(ir,cch)%bilap = BC_Lapse_Rate(cdatum) + diag_status%all_data_chan(ir,cch)%bicos = BC_Cosine_Latitude_times_Node(cdatum) + diag_status%all_data_chan(ir,cch)%bisin = BC_Sine_Latitude(cdatum) + diag_status%all_data_chan(ir,cch)%biemis= BC_Emissivity(cdatum) + if (header_fix%angord > 0) then + diag_status%all_data_chan(ir,cch)%bifix = BC_angord(1:nangord,cdatum) + else + diag_status%all_data_chan(ir,cch)%bifix(1) = BC_Fixed_Scan_Position(cdatum) + endif + ! placeholder for SST BC + if (header_fix%iextra > 0) then + diag_status%all_data_extra(ir,1,cch)%extra = Press_Max_Weight_Function(cdatum) + endif + cdatum = cdatum + 1 + enddo + enddo + + diag_status%nc_read = .true. + diag_status%cur_ob_idx = 1 + + + deallocate(Channel_Index, Latitude, Longitude, Elevation, Obs_Time, Scan_Position, & + Sat_Zenith_Angle, Sat_Azimuth_Angle, Sol_Zenith_Angle, Sol_Azimuth_Angle, & + Sun_Glint_Angle, Water_Fraction, Land_Fraction, Ice_Fraction, & + Snow_Fraction, Water_Temperature, Land_Temperature, Ice_Temperature, & + Snow_Temperature, Soil_Temperature, Soil_Moisture, tsavg5, sstcu, sstph, & + sstnv, dta, dqa, dtp_avh, Vegetation_Fraction, Snow_Depth, tpwc_amsua, & + clw_guess_retrieval, Sfc_Wind_Speed, Cloud_Frac, CTP, CLW, TPWC, clw_obs, & + clw_guess, Foundation_Temperature, SST_Warm_layer_dt, SST_Cool_layer_tdrop, & + SST_dTz_dTfound, Observation, Obs_Minus_Forecast_adjusted, & + Obs_Minus_Forecast_unadjusted, Inverse_Observation_Error, QC_Flag, & + Emissivity, Weighted_Lapse_Rate, dTb_dTs, BC_Constant, BC_Scan_Angle, & + BC_Cloud_Liquid_Water, BC_Lapse_Rate_Squared, BC_Lapse_Rate, & + BC_Cosine_Latitude_times_Node, BC_Sine_Latitude, BC_Emissivity, & + BC_Fixed_Scan_Position, Land_Type_Index) + + if (header_fix%iextra > 0) then + deallocate(Press_Max_Weight_Function) + endif + if (header_fix%angord > 0) then + deallocate(BC_angord) + end if + if (header_fix%ijacob > 0) then + deallocate(Observation_Operator_Jacobian) + endif + + +end subroutine read_radiag_data_nc_init + +subroutine read_radiag_data_nc(diag_status,header_fix,data_fix,data_chan,data_extra,iflag ) +! . . . . +! subprogram: read_radiag_dat read rad diag data +! prgmmr: tahara org: np20 date: 2015-08-10 +! +! abstract: This routine reads the data record from a netcdf radiance +! diagnostic file +! +! program history log: +! 2015-08-10 mccarty - create routine +! +! input argument list: +! header_fix - header information structure +! +! output argument list: +! data_fix - spot header information structure +! data_chan - spot channel information structure +! data_extra - spot extra information +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! Declare passed arguments + type(ncdiag_status), intent(inout) :: diag_status + type(diag_header_fix_list ),intent(in) :: header_fix + type(diag_data_fix_list) ,intent(out):: data_fix + type(diag_data_chan_list) ,allocatable :: data_chan(:) + type(diag_data_extra_list) ,allocatable :: data_extra(:,:) + integer(i_kind),intent(out) :: iflag + + iflag = 0 + if (.not. allocated(data_chan)) allocate(data_chan(header_fix%nchan) ) + if (.not. allocated(data_extra)) allocate(data_extra(header_fix%iextra, header_fix%nchan) ) + + data_fix = diag_status%all_data_fix(diag_status%cur_ob_idx) + data_chan(:) = diag_status%all_data_chan(diag_status%cur_ob_idx,:) + data_extra(:,:) = diag_status%all_data_extra(diag_status%cur_ob_idx,:,:) + + diag_status%cur_ob_idx = diag_status%cur_ob_idx + 1 + +end subroutine read_radiag_data_nc + +subroutine read_radiag_data_bin(ftin,header_fix,retrieval,data_fix,data_chan,data_extra,iflag ) +! . . . . +! subprogram: read_radiag_dat read rad diag data +! prgmmr: tahara org: np20 date: 2003-01-01 +! +! abstract: This routine reads the data record from a radiance +! diagnostic file +! +! program history log: +! 2010-10-05 treadon - add this doc block +! 2011-02-22 kleist - changes related to memory allocation +! 2017-07-17 mccarty - rename binary-specific procedure +! +! input argument list: +! ftin - unit number connected to diagnostic file +! header_fix - header information structure +! +! output argument list: +! data_fix - spot header information structure +! data_chan - spot channel information structure +! data_extra - spot extra information +! iflag - error code +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + +! Declare passed arguments + integer(i_kind),intent(in) :: ftin + type(diag_header_fix_list ),intent(in) :: header_fix + logical,intent(in) :: retrieval + type(diag_data_fix_list) ,intent(out):: data_fix + type(diag_data_chan_list) ,allocatable :: data_chan(:) + type(diag_data_extra_list) ,allocatable :: data_extra(:,:) + integer(i_kind),intent(out) :: iflag + + integer(i_kind) :: ich,iang,i,j + real(r_radstat),dimension(:,:),allocatable :: data_tmp + real(r_radstat),dimension(:),allocatable :: fix_tmp + real(r_radstat),dimension(:,:),allocatable :: extra_tmp + + +! Allocate arrays as needed + if (allocated(data_chan)) deallocate(data_chan) + allocate(data_chan(header_fix%nchan)) + + do ich=1,header_fix%nchan + if (allocated(data_chan(ich)%bifix)) deallocate(data_chan(ich)%bifix) + allocate(data_chan(ich)%bifix(header_fix%angord+1)) + end do + + if (header_fix%iextra > 0) then + if (allocated(data_extra)) deallocate(data_extra) + allocate(data_extra(header_fix%iextra,header_fix%jextra)) + allocate(extra_tmp(header_fix%iextra,header_fix%jextra)) + end if + +! Allocate arrays to hold data record + allocate(data_tmp(header_fix%idiag,header_fix%nchan)) + + if (header_fix%iversion < iversion_radiag_2) then + allocate( fix_tmp( ireal_old_radiag ) ) + else + allocate( fix_tmp( ireal_radiag ) ) + end if + +! Read data record + + if (header_fix%iextra == 0) then + read(ftin,IOSTAT=iflag) fix_tmp, data_tmp + else + read(ftin,IOSTAT=iflag) fix_tmp, data_tmp, extra_tmp + endif + + if (iflag /= 0) return + +! Transfer fix_tmp record to output structure + data_fix%lat = fix_tmp(1) + data_fix%lon = fix_tmp(2) + data_fix%zsges = fix_tmp(3) + data_fix%obstime = fix_tmp(4) + data_fix%senscn_pos = fix_tmp(5) + data_fix%satzen_ang = fix_tmp(6) + data_fix%satazm_ang = fix_tmp(7) + data_fix%solzen_ang = fix_tmp(8) + data_fix%solazm_ang = fix_tmp(9) + data_fix%sungln_ang = fix_tmp(10) + data_fix%water_frac = fix_tmp(11) + data_fix%land_frac = fix_tmp(12) + data_fix%ice_frac = fix_tmp(13) + data_fix%snow_frac = fix_tmp(14) + data_fix%water_temp = fix_tmp(15) + data_fix%land_temp = fix_tmp(16) + data_fix%ice_temp = fix_tmp(17) + data_fix%snow_temp = fix_tmp(18) + data_fix%soil_temp = fix_tmp(19) + data_fix%soil_mois = fix_tmp(20) + data_fix%land_type = fix_tmp(21) + data_fix%veg_frac = fix_tmp(22) + data_fix%snow_depth = fix_tmp(23) + data_fix%sfc_wndspd = fix_tmp(24) + data_fix%qcdiag1 = fix_tmp(25) + data_fix%qcdiag2 = fix_tmp(26) + + if ( header_fix%iversion <= iversion_radiag_1 ) then + data_fix%tref = rmiss_radiag + data_fix%dtw = rmiss_radiag + data_fix%dtc = rmiss_radiag + data_fix%tz_tr = rmiss_radiag + else + data_fix%tref = fix_tmp(27) + data_fix%dtw = fix_tmp(28) + data_fix%dtc = fix_tmp(29) + data_fix%tz_tr = fix_tmp(30) + end if + + +! Transfer data record to output structure + do ich=1,header_fix%nchan + data_chan(ich)%tbobs =data_tmp(1,ich) + data_chan(ich)%omgbc =data_tmp(2,ich) + data_chan(ich)%omgnbc=data_tmp(3,ich) + data_chan(ich)%errinv=data_tmp(4,ich) + data_chan(ich)%qcmark=data_tmp(5,ich) + data_chan(ich)%emiss =data_tmp(6,ich) + data_chan(ich)%tlap =data_tmp(7,ich) + data_chan(ich)%tb_tz =data_tmp(8,ich) + end do + if (header_fix%iversion < iversion_radiag_1) then + do ich=1,header_fix%nchan + data_chan(ich)%bifix(1)=data_tmp(8,ich) + data_chan(ich)%bilap =data_tmp(9,ich) + data_chan(ich)%bilap2 =data_tmp(10,ich) + data_chan(ich)%bicons =data_tmp(11,ich) + data_chan(ich)%biang =data_tmp(12,ich) + data_chan(ich)%biclw =data_tmp(13,ich) + data_chan(ich)%bisst = rmiss_radiag + if (retrieval) then + data_chan(ich)%biclw =rmiss_radiag + data_chan(ich)%bisst =data_tmp(13,ich) + endif + end do + elseif ( header_fix%iversion < iversion_radiag_2 .and. header_fix%iversion >= iversion_radiag_1 ) then + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(8,ich) + data_chan(ich)%biang =data_tmp(9,ich) + data_chan(ich)%biclw =data_tmp(10,ich) + data_chan(ich)%bilap2=data_tmp(11,ich) + data_chan(ich)%bilap =data_tmp(12,ich) + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(12+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(12+header_fix%angord+2,ich) + end do + elseif ( header_fix%iversion < iversion_radiag_3 .and. header_fix%iversion >= iversion_radiag_2 ) then + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(9,ich) + data_chan(ich)%biang =data_tmp(10,ich) + data_chan(ich)%biclw =data_tmp(11,ich) + data_chan(ich)%bilap2=data_tmp(12,ich) + data_chan(ich)%bilap =data_tmp(13,ich) + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(13+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(13+header_fix%angord+2,ich) + end do + elseif ( header_fix%iversion < iversion_radiag_4 .and. header_fix%iversion >= iversion_radiag_3 ) then + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(9,ich) + data_chan(ich)%biang =data_tmp(10,ich) + data_chan(ich)%biclw =data_tmp(11,ich) + data_chan(ich)%bilap2=data_tmp(12,ich) + data_chan(ich)%bilap =data_tmp(13,ich) + data_chan(ich)%bicos =data_tmp(14,ich) ! 1st bias correction term node*cos(lat) for SSMIS + data_chan(ich)%bisin =data_tmp(15,ich) ! 2nd bias correction term sin(lat) for SSMI + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(15+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(15+header_fix%angord+2,ich) + end do + elseif ( header_fix%iversion < iversion_radiag_5 .and. header_fix%iversion >= iversion_radiag_4 ) then + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(9,ich) + data_chan(ich)%biang =data_tmp(10,ich) + data_chan(ich)%biclw =data_tmp(11,ich) + data_chan(ich)%bilap2=data_tmp(12,ich) + data_chan(ich)%bilap =data_tmp(13,ich) + data_chan(ich)%bicos =data_tmp(14,ich) + data_chan(ich)%bisin =data_tmp(15,ich) + data_chan(ich)%biemis=data_tmp(16,ich) + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(16+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(16+header_fix%angord+2,ich) + end do + else + do ich=1,header_fix%nchan + data_chan(ich)%bicons=data_tmp(9,ich) + data_chan(ich)%biang =data_tmp(10,ich) + data_chan(ich)%biclw =data_tmp(11,ich) + data_chan(ich)%bilap2=data_tmp(12,ich) + data_chan(ich)%bilap =data_tmp(13,ich) + data_chan(ich)%bicos =data_tmp(14,ich) + data_chan(ich)%bisin =data_tmp(15,ich) + data_chan(ich)%biemis=data_tmp(16,ich) + end do + do ich=1,header_fix%nchan + do iang=1,header_fix%angord+1 + data_chan(ich)%bifix(iang)=data_tmp(16+iang,ich) + end do + data_chan(ich)%bisst = data_tmp(16+header_fix%angord+2,ich) + data_chan(ich)%sprd = data_tmp(16+header_fix%angord+3,ich) + end do + endif + + if (header_fix%iextra > 0) then + do j=1,header_fix%jextra + do i=1,header_fix%iextra + data_extra(i,j)%extra=extra_tmp(i,j) + end do + end do + endif + + deallocate(data_tmp, fix_tmp) + if (header_fix%iextra > 0) deallocate(extra_tmp) + +end subroutine read_radiag_data_bin + +end module read_diag + diff --git a/util/Correlated_Obs/readsatobs.f90 b/util/Correlated_Obs/readsatobs.f90 new file mode 100644 index 000000000..55ba064a9 --- /dev/null +++ b/util/Correlated_Obs/readsatobs.f90 @@ -0,0 +1,338 @@ +module readsatobs + +! This program contains modules to read data from satellite +! radiance diag files written out by GSI forward operator code. +! It is based on src/enkf/readsatobs.f90 +! Kristen Bathmann +! 2-2019 + +use ckinds, only: r_kind,r_radstat,i_kind,r_radstat,r_double +use read_diag +implicit none + +public :: get_satobs_data, get_chaninfo +public :: indR, chaninfo, errout +public :: nch_active,nctot +public :: RadData + +integer(i_kind),dimension(:),allocatable:: indR !indices of the assimlated channels +real(r_kind),dimension(:),allocatable:: chaninfo !wavenumbers of assimilated channels +real(r_kind),dimension(:),allocatable:: errout !satinfo obs errors of assimilated channels +integer(i_kind):: nch_active !number of actively assimilated channels +integer(i_kind):: nctot !total number of channels (passive+active) +integer(i_kind), parameter:: full_chan=1 +integer(i_kind), parameter:: Sea=1 +integer(i_kind), parameter:: Land =2 +integer(i_kind), parameter:: Snow=3 +integer(i_kind), parameter:: Mixed=4 +integer(i_kind), parameter:: Ice=5 +integer(i_kind), parameter:: Snow_and_Ice=6 +integer(i_kind), parameter:: Clear_FOV=1 +integer(i_kind), parameter:: Clear_Channel=2 +real(r_kind), parameter:: clear_threshold=0.01_r_kind !if using clear sky data, do not use if above this threshold +real(r_kind), parameter:: sea_threshold=0.99_r_kind !if using sea data, do not use if below this threshold +real(r_kind), parameter:: lower_sea_threshold=0.9_r_kind !if using mixed data, do not use if above this threshold +real(r_kind), parameter:: lower_land_threshold=0.9_r_kind !if using mixed data, do not use if above this threshold +real(r_kind), parameter:: lower_ice_threshold=0.9_r_kind !if using mixed data, do not use if above this threshold +real(r_kind), parameter:: lower_snow_threshold=0.9_r_kind !if using mixed data, do not use if above this threshold +real(r_kind), parameter:: land_threshold=0.99_r_kind !if using land data, do not use if above this threshold +real(r_kind), parameter:: ice_threshold=0.95_r_kind !if using ice data, do not use if below this threshold +real(r_kind), parameter:: snow_threshold=0.99_r_kind !if using snow data, do not use if below this threshold + +type:: RadData + real(r_radstat),dimension(:,:),allocatable:: omg + real(r_radstat),dimension(:,:),allocatable:: latlon + real(r_radstat),dimension(:),allocatable:: timeobs +end type RadData +contains + +!get information on the activley assimilated channels +subroutine get_chaninfo(filename,netcdf,chan_choice) + implicit none + + character(len=9), intent(in) :: filename + logical, intent(in) :: netcdf + integer(i_kind),intent(in):: chan_choice + + if (netcdf) then + call get_chaninfo_nc(filename,chan_choice) + else + call get_chaninfo_bin(filename,chan_choice) + endif +end subroutine get_chaninfo + +! get information on the actively assimilated channels from binary file +subroutine get_chaninfo_bin(filename,chan_choice) + use read_diag, only: diag_header_fix_list,diag_header_chan_list,diag_data_name_list + implicit none + + character(len=9), intent(in) :: filename + integer(i_kind), intent(in):: chan_choice + integer(i_kind) iunit, iflag, n, i,istatus + type(diag_header_fix_list ) :: header_fix0 + type(diag_header_chan_list),allocatable :: header_chan0(:) + type(diag_data_name_list) :: data_name0 + + iunit = 7 + call open_radiag(trim(filename),iunit,istatus) + call read_radiag_header(iunit,.false.,header_fix0,header_chan0,data_name0,iflag,.false.) + nctot=header_fix0%nchan + if (chan_choice==full_chan) then + nch_active=nctot + else + nch_active=0 + do n=1,header_fix0%nchan + if(header_chan0(n)%iuse<1) cycle + nch_active=nch_active+1 + end do + endif + allocate(indR(nch_active),chaninfo(nch_active),errout(nch_active)) + i=0 + do n=1,header_fix0%nchan + if (chan_choice==full_chan) then + indR(n)=n + else if (header_chan0(n)%iuse>0) then + i=i+1 + indR(i)=n + endif + end do + do n=1,nch_active + chaninfo(n)=header_chan0(indR(n))%wave + errout(n)=header_chan0(indR(n))%varch + end do + call close_radiag(filename,iunit) +end subroutine get_chaninfo_bin + +subroutine get_chaninfo_nc(filename,chan_choice) + use nc_diag_read_mod, only: nc_diag_read_get_var + use nc_diag_read_mod, only: nc_diag_read_get_dim + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + implicit none + + character(len=9), intent(in) :: filename + integer(i_kind), intent(in):: chan_choice + integer(i_kind) iunit, nobs, i,j + integer(i_kind), dimension(:), allocatable ::Use_Flag,chind + real(r_double), dimension(:), allocatable:: Waves,Inv_Errors + real(r_kind), dimension(:), allocatable:: Wave,Inv_Error + + iunit = 7 + call nc_diag_read_init(filename, iunit) + nobs = nc_diag_read_get_dim(iunit,'nobs') + if (nobs <= 0) call nc_diag_read_close(filename) + nctot = nc_diag_read_get_dim(iunit,'nchans') + allocate(Use_Flag(nctot),chind(nobs),Wave(nctot),Inv_Error(nctot)) + allocate(Waves(nctot),Inv_Errors(nctot)) + call nc_diag_read_get_var(iunit, 'use_flag', Use_Flag) + call nc_diag_read_get_var(iunit, 'Channel_Index', chind) + call nc_diag_read_get_var(iunit, 'wavenumber', Waves) + call nc_diag_read_get_var(iunit, 'error_variance', Inv_Errors) + Wave=real(Waves,r_kind) + Inv_Error=real(Inv_Errors,r_kind) + call nc_diag_read_close(filename) + if (chan_choice==full_chan) then + nch_active=nctot + else + nch_active=0 + do i=1,nctot + if(Use_Flag(chind(i)) < 1 ) cycle + nch_active=nch_active+1 + enddo + endif + allocate(indR(nch_active),chaninfo(nch_active),errout(nch_active)) + i=0 + do j=1,nctot + if (chan_choice==full_chan) then + indR(j)=j + else if (Use_Flag(chind(j))>0) then + i=i+1 + indR(i)=j + end if + end do + do j=1,nch_active + chaninfo(j)=Wave(chind(indR(j))) + errout(j)=Inv_Error(chind(indR(j))) + end do + deallocate(Use_flag,chind,Wave,Inv_Error,Waves,Inv_Errors) +end subroutine get_chaninfo_nc + +! read radiance data +subroutine get_satobs_data(filename,netcdf_diag,nobs_max,Surface_Type,Cloud_Type,satang,Rad,ng) + implicit none + + character*9, intent(in):: filename + integer(i_kind), intent(in):: nobs_max,Surface_Type,Cloud_Type + real(r_kind), intent(in)::satang + integer(i_kind), intent(out) :: ng + type(RadData),intent(inout):: Rad + logical,intent(in):: netcdf_diag + + if (netcdf_diag) then + call get_satobs_data_nc(filename,nobs_max,Surface_Type,Cloud_Type,satang,Rad,ng) + else + call get_satobs_data_bin(filename,nobs_max,Surface_Type,Cloud_Type,satang,Rad,ng) + endif +end subroutine get_satobs_data + +! read radiance data from binary file +subroutine get_satobs_data_bin(filename,nobs_max,Surface_Type,Cloud_Type,satang,Rad,ng) + implicit none + + character*9, intent(in):: filename + integer(i_kind), intent(in):: nobs_max,Surface_Type,Cloud_Type + real(r_kind), intent(in)::satang + type(RadData),intent(inout):: Rad + integer(i_kind), intent(out):: ng + integer(i_kind):: iunit, iflag,nob,n + integer(i_kind):: istatus,nc,nc2 + real(r_kind):: errorlimit + type(diag_header_fix_list):: header_fix + type(diag_header_chan_list),allocatable:: header_chan(:) + type(diag_data_fix_list):: data_fix + type(diag_data_chan_list),allocatable:: data_chan(:) + type(diag_data_extra_list) ,allocatable:: data_extra(:,:) + type(diag_data_name_list):: data_name + +! make consistent with screenobs + errorlimit=1._r_kind/sqrt(1.e9_r_kind) + iunit = 7 + nob = 0 + call open_radiag(filename,iunit,istatus) + call read_radiag_header(iunit,.false.,header_fix,header_chan,data_name,iflag,.false.) + allocate(data_chan(header_fix%nchan),data_extra(header_fix%iextra,header_fix%nchan)) + do + call read_radiag_data(iunit,header_fix,.false.,data_fix,data_chan,data_extra,iflag ) + if( iflag /= 0 ) exit + if ((Surface_Type==Sea).and.(data_fix%water_frac=lower_sea_threshold)) cycle + if ((Surface_Type==Mixed).and.(data_fix%land_frac>=lower_land_threshold)) cycle + if ((Surface_Type==Mixed).and.(data_fix%ice_frac>=lower_ice_threshold)) cycle + if ((Surface_Type==Mixed).and.(data_fix%snow_frac>=lower_snow_threshold)) cycle + if ((Cloud_Type==Clear_FOV).and.(data_fix%qcdiag1>clear_threshold)) cycle + if (abs(data_fix%satzen_ang)>satang) cycle + nc=0 + nc2=0 + nob=nob+1 + chan:do n=1,header_fix%nchan + if((header_chan(n)%iuse<1).and.(nch_active0).or.(data_chan(n)%errinv < errorlimit) ) cycle chan + Rad%omg(nob,nc)=data_chan(n)%omgbc + nc2=nc2+1 + enddo chan + if ((nc2<1).and.(nob>0)) then + nob=nob-1 + else + Rad%latlon(nob,1)=data_fix%lat + Rad%latlon(nob,2)=data_fix%lon + Rad%timeobs(nob)=data_fix%obstime + endif + if (nob==nobs_max) then + print *, 'Warning: Number of obs meeting criteria exceeds dsize. Consider increasing dsize' + exit + endif + enddo + ng=nob + call close_radiag(filename,iunit) + deallocate(data_chan,data_extra) + end subroutine get_satobs_data_bin + +! read radiance data from netcdf file +subroutine get_satobs_data_nc(filename,nobs_max,Surface_Type,Cloud_Type,satang,Rad,ng) + use nc_diag_read_mod, only: nc_diag_read_get_var + use nc_diag_read_mod, only: nc_diag_read_get_dim, nc_diag_read_get_global_attr + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close + + implicit none + + character*9, intent(in):: filename + integer(i_kind), intent(in):: nobs_max,Surface_Type,Cloud_Type + real(r_kind), intent(in)::satang + type(RadData), intent(inout):: Rad + integer(i_kind), intent(out):: ng + integer(i_kind):: iunit, nobs, i, nchans,nob,nc,nct,nc2 + real(r_kind) :: errorlimit + integer(i_kind), dimension(:), allocatable :: Use_Flag, chind + real(r_radstat), dimension(:), allocatable :: Inv_Error,QC_Flag + real(r_radstat), dimension(:), allocatable :: Latitude, Longitude, Time + real(r_radstat), dimension(:), allocatable :: Obs_Minus_Forecast_adjusted,satzen_ang + real(r_radstat), dimension(:), allocatable :: fwater,fland,fsnow,fice,cldfrac + +! make consistent with screenobs + errorlimit=1._r_kind/sqrt(1.e9_r_kind) + nob = 0 + call nc_diag_read_init(trim(filename), iunit) + nobs = nc_diag_read_get_dim(iunit,'nobs') + if (nobs <= 0) call nc_diag_read_close(trim(filename)) + nchans = nc_diag_read_get_dim(iunit,'nchans') + allocate(Use_Flag(nchans)) + allocate(QC_Flag(nobs), Inv_Error(nobs), Latitude(nobs), & + Longitude(nobs), Time(nobs), chind(nobs), & + Obs_Minus_Forecast_adjusted(nobs),fwater(nobs),fland(nobs),& + fice(nobs),fsnow(nobs),cldfrac(nobs),satzen_ang(nobs)) + call nc_diag_read_get_var(iunit, 'use_flag', Use_Flag) + call nc_diag_read_get_var(iunit, 'Channel_Index', chind) + call nc_diag_read_get_var(iunit, 'QC_Flag', QC_Flag) + call nc_diag_read_get_var(iunit, 'Inverse_Observation_Error', Inv_Error) + call nc_diag_read_get_var(iunit, 'Latitude', Latitude) + call nc_diag_read_get_var(iunit, 'Longitude', Longitude) + call nc_diag_read_get_var(iunit, 'Obs_Time', Time) + call nc_diag_read_get_var(iunit, 'Obs_Minus_Forecast_adjusted', Obs_Minus_Forecast_adjusted) + call nc_diag_read_get_var(iunit, 'Water_Fraction',fwater) + call nc_diag_read_get_var(iunit, 'Land_Fraction',fland) + call nc_diag_read_get_var(iunit, 'Snow_Fraction',fsnow) + call nc_diag_read_get_var(iunit, 'Ice_Fraction',fice) + call nc_diag_read_get_var(iunit, 'Cloud_Frac',cldfrac) + call nc_diag_read_get_var(iunit, 'Sat_Zenith_Angle',satzen_ang) + call nc_diag_read_close(filename) + + nct=0 !ranges from 0 to total number of channels (active+passive) + nc=0 !ranges from 0 to total number of active channels + nob=1 + nc2=0 !counts how many channels actually pass qc + do i=1,nobs + nct=nct+1 + if (nct>nchans) then + nct=1 + if (nc2>0) nob=nob+1 + nc=0 + nc2=0 + endif + if ((Surface_Type==Sea).and.(fwater(i)=lower_sea_threshold)) cycle + if ((Surface_Type==Mixed).and.(fland(i)>=lower_land_threshold)) cycle + if ((Surface_Type==Mixed).and.(fice(i)>=lower_ice_threshold)) cycle + if ((Surface_Type==Mixed).and.(fsnow(i)>=lower_snow_threshold)) cycle + if ((Cloud_Type==Clear_FOV).and.(cldfrac(i)>clear_threshold)) cycle + if (abs(satzen_ang(i))>satang) cycle + if ((Use_Flag(chind(i))<1).and.(nch_active < nchans)) cycle + nc=nc+1 + if ((abs(QC_Flag(i))>0).or.(Inv_Error(i)nobs_max)) then + print *, 'Warning: Number of obs meeting criteria exceeds dsize. Consider increasing dsize' + exit + endif + enddo + ng=nob + deallocate(QC_Flag, Inv_Error, Latitude, Longitude, Time, & + chind, Obs_Minus_Forecast_adjusted,Use_Flag, & + fwater,fland,fsnow,fice,cldfrac,satzen_ang) +end subroutine get_satobs_data_nc + +end module readsatobs diff --git a/util/Correlated_Obs/run.sh b/util/Correlated_Obs/run.sh index a2b0a9a1d..55372302e 100755 --- a/util/Correlated_Obs/run.sh +++ b/util/Correlated_Obs/run.sh @@ -43,14 +43,17 @@ bcen=80 chan_set=0 #Have the radstats already been processed? 1 for yes, 0 for no radstats_processed=1 - +#netcdf or binary diag files-0 for binary, 1 for netcdf +netcdf=0 ndate=/scratch4/NCEPDEV/da/save/Michael.Lueken/nwprod/util/exec/ndate +#ndate=/gpfs/dell2/emc/modeling/noscrub/Kristen.Bathmann/ndate + #################### cdate=$bdate [ ! -d ${wrkdir} ] && mkdir ${wrkdir} [ ! -d ${savdir} ] && mkdir ${savdir} -cp cov_calc $wrkdir +cp ../../exec/cov_calc $wrkdir nt=0 ntt=0 cd $wrkdir @@ -61,6 +64,11 @@ while [[ $cdate -le $edate ]] ; do break fi done + if [ $netcdf -gt 0 ] ; then + fil=${cdate}.nc4 + else + fil=${cdate} + fi nt=`expr $nt + 1` if [ $nt -lt 10 ] ; then fon=000$nt @@ -75,13 +83,13 @@ while [[ $cdate -le $edate ]] ; do if [ ! -f danl_${fon} ]; then cp $diagdir/radstat.gdas.$cdate . - tar --extract --file=radstat.gdas.${cdate} diag_${instr}_ges.${cdate}.gz diag_${instr}_anl.${cdate}.gz + tar --extract --file=radstat.gdas.${cdate} diag_${instr}_ges.${fil}.gz diag_${instr}_anl.${fil}.gz gunzip *.gz rm radstat.gdas.$cdate - if [ -f diag_${instr}_ges.${cdate} ]; + if [ -f diag_${instr}_ges.${fil} ]; then - mv diag_${instr}_anl.${cdate} danl_${fon} - mv diag_${instr}_ges.${cdate} dges_${fon} + mv diag_${instr}_anl.${fil} danl_${fon} + mv diag_${instr}_ges.${fil} dges_${fon} else nt=`expr $nt - 1` fi @@ -95,7 +103,7 @@ while [[ $cdate -le $edate ]] ; do cdate=`$ndate +06 $cdate` done ./cov_calc <>>') + #assert isinstance(ProdGSI, str) # native str on Py2 and Py3 + #os.system("ln -sf "+ProdGSI+" ProdGSI") + #print("\nDone! "+ProdGSI+" already linked as ./ProdGSI\n") + +print("\nIt is on "+hostname+" and python3 is found at:"+python3Location) +print("\nPlese create a file\n config.acct_queue\n to let MPMC know your project account and queue name") +print(" (account name in the first line and queue name in the second line)\n") +print("After that, do run.py and then report.py \n\n") + diff --git a/util/DTC/MPMC/.rocoto.template b/util/DTC/MPMC/.rocoto.template new file mode 100644 index 000000000..d71756e0c --- /dev/null +++ b/util/DTC/MPMC/.rocoto.template @@ -0,0 +1,131 @@ + + + + + + + + + + + + + + + + + + + + + +]> + + + + + + &BUILD_ROOT;/log.workflow + + + 00 08 28 08 2018 * + + + + + &build_ID; + &compiler; + &mpi; + + &case_ID; + &casenum; + + &WALLTIME; + &QUEUE; + &ACCOUNT; + &GSI_PROC; + &GSI_PROC; + &PARTITION; + #build_ID#-#case_ID# + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/run/out.#case_ID# + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/run/run.#case_ID# + + + + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/bin/gsi.x + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/bin/enkf_wrf.x + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/bin/enkf_gfs.x + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/done.compiling + + + + + + + + &build_ID; + &compiler; + &mpi; + + &enkf_ID; + &enkfnum; + &enkf_dependent; + + &WALLTIME; + &QUEUE; + &ACCOUNT; + &ENKF_PROC; + &ENKF_PROC; + &PARTITION; + #build_ID#-#enkf_ID# + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/run/out.#enkf_ID# + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/run/run.#enkf_ID# + + + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/bin/gsi.x + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/bin/enkf_wrf.x + &BUILD_ROOT;/#build_ID#.#compiler#.#mpi#/bin/enkf_gfs.x + + + + + + + + + 00:03:00 + &QUEUE; + &ACCOUNT; + 1 + 1 + &PARTITION; + report + &BUILD_ROOT;/out.report + &MPMC_ROOT;/report.py > &MPMC_ROOT;/report.txt + + + &MPMC_ROOT;/.force.report + + + + + + diff --git a/util/DTC/MPMC/CASE_config.py b/util/DTC/MPMC/CASE_config.py new file mode 100644 index 000000000..65678a98f --- /dev/null +++ b/util/DTC/MPMC/CASE_config.py @@ -0,0 +1,250 @@ +################################################### +# This script generates job scripts for MPMC test suite cases +# +# by Guoqing Ge, 2018/8/18, guoqing.ge@noaa.gov +# +################################################### +# +from MPMC_config import ProdGSI_root, build_root, project_acct, queue_name, hostname, rocoto_scheduler +import os + +SBATCH_extras="" +MPI_CMD_ORG=' RUN_COMMAND="mpirun -np ${GSIPROC} " ;;\n' +if hostname.startswith("Theia"): ## Theia + crtm_dir="/scratch4/BMC/comgsi/case_data/CRTM_v2.3.0" + data_root="/scratch4/BMC/comgsi/case_data" + myARCH=" ARCH='LINUX_PBS'\n" + few_cpu_res="--ntasks=4"; few_procs="4" + many_cpu_res="--ntasks=24"; many_procs="24" #24 cores/node + MPI_CMD_ORG=' RUN_COMMAND="srun " ;;\n' + +elif hostname.startswith("Hera"): ## Hera + crtm_dir="/scratch1/BMC/comgsi/case_data/CRTM_v2.3.0" + data_root="/scratch1/BMC/comgsi/case_data" + myARCH=" ARCH='LINUX_PBS'\n" + few_cpu_res="--ntasks=4"; few_procs="4" + many_cpu_res="--ntasks=24"; many_procs="24" #24 cores/node + MPI_CMD_ORG=' RUN_COMMAND="srun " ;;\n' + +elif hostname.startswith("Jet"): ## Jet + crtm_dir="/lfs1/projects/wrfruc/gge/MPMC/case_data/CRTM_v2.3.0" + data_root="/lfs1/projects/wrfruc/gge/MPMC/case_data" + myARCH=" ARCH='LINUX_PBS'\n" + few_cpu_res="--ntasks=4"; few_procs="4" + #SBATCH_extras="#SBATCH --partition=tjet\n" #12 cores/node + #SBATCH_extras="#SBATCH --partition=xjet\n" #24 cores/node + SBATCH_extras="#SBATCH --partition=kjet\n" #40 cores/node + many_cpu_res="--ntasks=40"; many_procs="40" + MPI_CMD_ORG=' RUN_COMMAND="srun " ;;\n' + +elif hostname.startswith("Cheyenne"): ## Cheyenne + crtm_dir="/glade/p/ral/jntp/DAtask/case_data/CRTM_v2.3.0" + data_root="/glade/p/ral/jntp/DAtask/case_data" + myARCH=" ARCH='LINUX_PBS'\n" + few_cpu_res="select=1:ncpus=4:mpiprocs=4"; few_procs="4" + many_cpu_res="select=2:ncpus=36:mpiprocs=36"; many_procs="36" #Dual-socket nodes, 18 cores per socket, 20 ensembles, need at least 20cores + +elif hostname.startswith("GSI_Docker"): ## GSI_Docker + crtm_dir="/tutorial/case_data/CRTM_v2.3.0" + data_root="/tutorial/case_data" + myARCH=" ARCH='LINUX'\n" + few_cpu_res="docker"; few_procs="1" + many_cpu_res="docker"; many_procs="1" + +######################### variables definition ####################################### +hybrid_yes=" if_hybrid=Yes # Yes, or, No -- case sensitive !\n" +EnVar4D_yes=" if_4DEnVar=Yes # Yes, or, No -- case sensitive (set if_hybrid=Yes first)!\n" +linkallobs =" ln -s ${srcobsfile[$ii]} ${gsiobsfile[$ii]}\n" +#---------------------- +#**** substitutions to be made in run scripts based on template scripts in ProdGSI/ush +jobproc_few=" GSIPROC="+few_procs+"\n" +jobproc_many=" GSIPROC="+many_procs+"\n" +# +com_obs=" OBS_ROOT="+data_root+"/com_2018081212/obs\n" +com_bkg=" BK_ROOT="+data_root+"/com_2018081212/bkg\n" +com_ens=" ENS_ROOT="+data_root+"/com_2018081212/gfsens\n" +# +nmmb_obs=" OBS_ROOT="+data_root+"/nmmb_2012062812/obs\n" +nmmb_bkg=" BK_ROOT="+data_root+"/nmmb_2012062812/bkg\n" +nmmb_ens=" ENS_ROOT="+data_root+"/nmmb_2012062812/gfsens\n" +# +chem_obs=" OBS_ROOT="+data_root+"/chemdata/obs\n" +chem_bkg=" BK_ROOT="+data_root+"/chemdata/bkg\n" +# +gfs_obs=" OBS_ROOT="+data_root+"/T62.gfs/obs\n" +gfs_bkg=" BK_ROOT="+data_root+"/T62.gfs/bkg\n" +# +case2124_obs=" OBS_ROOT="+data_root+"/enkf_arw_2014021300/obs\n" +case2124_bkg=" BK_ROOT="+data_root+"/enkf_arw_2014021300/bkg\n" +# +case2526_obs=" OBS_ROOT="+data_root+"/enkf_glb_T62/obs\n" +case2526_bkg=" BK_ROOT="+data_root+"/enkf_glb_T62/bkg\n" +# +cases={ \ + "case01-oneobs-glb":{" if_oneob=No":" if_oneob=Yes\n", " bkcv_option=NAM":" bkcv_option=GLOBAL\n", \ + "ln -s ${PREPBUFR} ./prepbufr":"#ln -s ${PREPBUFR} ./prepbufr\n", \ + " PREPBUFR=":" PREPBUFR=${OBS_ROOT}/rap.t${HH}z.prepbufr.tm00\n", \ + " ANAL_TIME=":" ANAL_TIME=2018081212\n", \ + " BK_FILE=${BK_ROOT}":" BK_FILE=${BK_ROOT}/wrfout_d01_2018-08-12_12:00:00\n", \ + " OBS_ROOT=":com_obs," BK_ROOT=":com_bkg," ENS_ROOT=":com_ens," GSIPROC=":jobproc_few } \ + ,"case02-oneobs-nam":{" if_oneob=No":" if_oneob=Yes\n", \ + "ln -s ${PREPBUFR} ./prepbufr":"#ln -s ${PREPBUFR} ./prepbufr\n", \ + " PREPBUFR=":" PREPBUFR=${OBS_ROOT}/rap.t${HH}z.prepbufr.tm00\n", \ + " ANAL_TIME=":" ANAL_TIME=2018081212\n", \ + " BK_FILE=${BK_ROOT}":" BK_FILE=${BK_ROOT}/wrfout_d01_2018-08-12_12:00:00\n", \ + " OBS_ROOT=":com_obs," BK_ROOT=":com_bkg," ENS_ROOT=":com_ens," GSIPROC=":jobproc_few} \ + ,"case03-conv":{" PREPBUFR=":" PREPBUFR=${OBS_ROOT}/rap.t${HH}z.prepbufr.tm00\n", \ + " BK_FILE=${BK_ROOT}":" BK_FILE=${BK_ROOT}/wrfout_d01_2018-08-12_12:00:00\n", \ + " ANAL_TIME=":" ANAL_TIME=2018081212\n", \ + " OBS_ROOT=":com_obs," BK_ROOT=":com_bkg," ENS_ROOT=":com_ens," GSIPROC=":jobproc_few} \ + ,"case04-allobs":{"# ln -s ${srcobsfile[$ii]} ${gsiobsfile[$ii]}":linkallobs, \ + " PREPBUFR=":" PREPBUFR=${OBS_ROOT}/rap.t${HH}z.prepbufr.tm00\n", \ + " ANAL_TIME=":" ANAL_TIME=2018081212\n", \ + " BK_FILE=${BK_ROOT}":" BK_FILE=${BK_ROOT}/wrfout_d01_2018-08-12_12:00:00\n", \ + " OBS_ROOT=":com_obs," BK_ROOT=":com_bkg," ENS_ROOT=":com_ens," GSIPROC=":jobproc_few} \ + ,"case05-3DEnVar":{" if_hybrid=":hybrid_yes," if_nemsio=No":" if_nemsio=Yes\n", \ + "# ln -s ${srcobsfile[$ii]} ${gsiobsfile[$ii]}":linkallobs, \ + " PREPBUFR=":" PREPBUFR=${OBS_ROOT}/rap.t${HH}z.prepbufr.tm00\n", \ + " ANAL_TIME=":" ANAL_TIME=2018081212\n", \ + " BK_FILE=${BK_ROOT}":" BK_FILE=${BK_ROOT}/wrfout_d01_2018-08-12_12:00:00\n", \ + " OBS_ROOT=":com_obs," BK_ROOT=":com_bkg," ENS_ROOT=":com_ens," GSIPROC=":jobproc_few} \ + ,"case07-4DEnVar":{" if_hybrid=":hybrid_yes," if_4DEnVar=":EnVar4D_yes, " if_nemsio=No":" if_nemsio=Yes\n", \ + " BK_FILE=${BK_ROOT}":" BK_FILE=${BK_ROOT}/wrfout_d01_2018-08-12_12:00:00\n", \ + " PREPBUFR=":" PREPBUFR=${OBS_ROOT}/rap.t${HH}z.prepbufr.tm00\n", \ + " ANAL_TIME=":" ANAL_TIME=2018081212\n", \ + " OBS_ROOT=":com_obs," BK_ROOT=":com_bkg," ENS_ROOT=":com_ens," GSIPROC=":jobproc_few} \ + ,"case08-nmmb":{" ANAL_TIME=":" ANAL_TIME=2012062812\n"," bk_core=ARW":" bk_core=NMMB\n", \ + " OBS_ROOT=":nmmb_obs," BK_ROOT=":nmmb_bkg," ENS_ROOT=":nmmb_ens," GSIPROC=":jobproc_few, + " BK_FILE=${BK_ROOT}":" BK_FILE=${BK_ROOT}/input_domain_01_nemsio\n", " PREPBUFR=":" PREPBUFR=${OBS_ROOT}/gfs.t${HH}z.prepbufr.nr\n"} \ + + ,"case09-wrfchem":{" OBS_ROOT=":chem_obs," BK_ROOT=":chem_bkg," GSIPROC=":jobproc_few } \ + ,"case10-cmaq":{" OBS_ROOT=":chem_obs," BK_ROOT=":chem_bkg," GSIPROC=":jobproc_few," ANAL_TIME=":" ANAL_TIME=2013062112\n"," bk_core=":" bk_core=CMAQ\n", \ + " BK_FILE=":" BK_FILE=${BK_ROOT}/cmaq2gsi_4.7_20130621_120000.bin\n"," PREPBUFR=":" PREPBUFR=${OBS_ROOT}/anow.2013062112.bufr\n"} \ + ,"case11-gfs":{" OBS_ROOT=":gfs_obs," BK_ROOT=":gfs_bkg," GSIPROC=":jobproc_few } \ + + ,"case21-observer-conv":{" OBS_ROOT=":case2124_obs," BK_ROOT=":case2124_bkg," GSIPROC=":jobproc_few, " ANAL_TIME=":" ANAL_TIME=2014021300\n", \ + " PREPBUFR=":" PREPBUFR=${OBS_ROOT}/gdas1.t${HH}z.prepbufr.nr\n", " BK_FILE=${BK_ROOT}":" BK_FILE=${BK_ROOT}/wrfarw.ensmean\n", \ + " if_observer":" if_observer=Yes\n"} \ + ,"case22-enkf-conv":{" OBS_ROOT=":case2124_obs," BK_ROOT=":case2124_bkg," GSIPROC=":jobproc_many, " diag_ROOT":" diag_ROOT=../case21-observer-conv\n" } \ + + ,"case23-observer-allobs":{" OBS_ROOT=":case2124_obs," BK_ROOT=":case2124_bkg," GSIPROC=":jobproc_few, " ANAL_TIME=":" ANAL_TIME=2014021300\n", \ + " PREPBUFR=":" PREPBUFR=${OBS_ROOT}/gdas1.t${HH}z.prepbufr.nr\n", " BK_FILE=${BK_ROOT}":" BK_FILE=${BK_ROOT}/wrfarw.ensmean\n", \ + " if_observer":" if_observer=Yes\n", "# ln -s ${srcobsfile[$ii]} ${gsiobsfile[$ii]}":linkallobs } \ + ,"case24-enkf-allobs":{" OBS_ROOT=":case2124_obs," BK_ROOT=":case2124_bkg," GSIPROC=":jobproc_many," diag_ROOT":" diag_ROOT=../case23-observer-allobs\n", \ + ' list="conv"':' list="conv amsua_n18 mhs_n18 hirs4_n19"\n' } \ + + ,"case25-observer-gfs":{" OBS_ROOT=":case2526_obs," BK_ROOT=":case2526_bkg," GSIPROC=":jobproc_few, " ANAL_TIME=":" ANAL_TIME=2014092918\n", \ + " PREPBUFR=":" PREPBUFR=${OBS_ROOT}/gdas1.t18z.prepbufr.nr\n"," if_observer":" if_observer=Yes\n", " GFSCASE=":" GFSCASE=enkf_glb_t62\n" } \ + ,"case26-enkf-gfs":{" OBS_ROOT=":case2526_obs," BK_ROOT=":case2526_bkg," GSIPROC=":jobproc_many," diag_ROOT":" diag_ROOT=../case25-observer-gfs\n" } \ + } + +allcases=[\ + "case01-oneobs-glb","case02-oneobs-nam", + "case03-conv","case04-allobs","case05-3DEnVar","case07-4DEnVar", \ +# "case08-nmmb", \ #remove case08 from test suite due to difficulties to fix bugs and nmmb is phasing away to fv3 + "case09-wrfchem","case10-cmaq","case11-gfs", \ +# "case12-fv3", "case13-cloudana" + "case21-observer-conv", "case22-enkf-conv", "case23-observer-allobs","case24-enkf-allobs","case25-observer-gfs","case26-enkf-gfs" ] + +fullLIST='1,2,3,4,5,7,9,10,11,21,22,23,24,25,26' +caselist=fullLIST.split(',') + +mycases=[] +for x in caselist: + k=int(x) + for i in range(len(allcases)): + if allcases[i].find("case{0:02d}".format(k)) >=0: + mycases.append(allcases[i]) + +##################### generate runing job scripts for a build option ######### +def create_run_scripts(build_ID, modules, job_dir): + if modules.find("module load mpt") >=0: + MPI_CMD=' RUN_COMMAND="mpiexec_mpt dplace -s 1 " ;;\n' + else: + MPI_CMD=MPI_CMD_ORG + + for x in mycases: + if (x.find("wrfchem")>=0 ) or (x.find("cmaq")>=0): + srcfname=ProdGSI_root+"/ush/comgsi_run_chem.ksh" + elif (x.find("enkf")>=0 and x.find("gfs")>=0): + srcfname=ProdGSI_root+"/ush/comenkf_run_gfs.ksh" + elif (x.find("enkf")>=0): #enkf regional + srcfname=ProdGSI_root+"/ush/comenkf_run_regional.ksh" + elif (x.find("gfs")>=0): + srcfname=ProdGSI_root+"/ush/comgsi_run_gfs.ksh" + else: + srcfname=ProdGSI_root+"/ush/comgsi_run_regional.ksh" + + jobfname=generateAjob(x,srcfname, build_ID, modules, job_dir, MPI_CMD) + +##################### generate a job script for a case ######### +def generateAjob(case_name, srcfname, build_ID, modules, job_dir, MPI_CMD): + global jobknt + if case_name.find('enkf')>=0: + cpu_res=many_cpu_res + else: + cpu_res=few_cpu_res + + if rocoto_scheduler.find('slurm')>=0: + PBScmds="#SBATCH --account "+project_acct+"\n" \ + +"#SBATCH -t 00:20:00\n" \ + +"#SBATCH --job-name "+build_ID+"-"+case_name+"\n" \ + +"#SBATCH "+cpu_res+"\n" \ + +"#SBATCH --qos "+queue_name+"\n" \ + +SBATCH_extras \ + +"#SBATCH -o out."+case_name+"\n" \ + +modules+"\n\n" \ + +"set -x\n" + else: + PBScmds="### in PBS, cannnot put comments after job decription commands\n" \ + +"#PBS -A "+project_acct+"\n" \ + +"#PBS -l walltime=00:20:00\n" \ + +"#PBS -N "+build_ID+"-"+case_name+"\n" \ + +"#PBS -l "+cpu_res+"\n" \ + +"#PBS -q "+queue_name+"\n" \ + +"#PBS -o out."+case_name+"\n" \ + +"#PBS -j oe\n\n" \ + +modules+"\n\n" \ + +"set -x\n" + + common={"set -x" :PBScmds \ + ,' RUN_COMMAND="mpirun -np ${GSIPROC} "' :MPI_CMD \ + ," ARCH=" :myARCH \ + ,"cp ${GSI_EXE} gsi.x" :"ln -sf ${GSI_EXE} gsi.x\n" #link to gsi to avoid unneccessary duplicates + ,"cp $ENKF_EXE enkf.x" :"ln -sf ${ENKF_EXE} enkf.x\n" #link to enkf to avoid unneccessary duplicates + ," JOB_DIR=" :" JOB_DIR="+job_dir+"\n" \ + ," RUN_NAME=" :" RUN_NAME="+case_name+"\n" \ + ," GSI_ROOT=" :" GSI_ROOT="+ProdGSI_root+"\n" \ + ," CRTM_ROOT=" :" CRTM_ROOT="+crtm_dir+"\n" \ + } + + jobfname=job_dir+'/run.'+case_name + jobfile = open(jobfname, "w") + mydict=cases[case_name] + + file1=open(srcfname, "r") + while True: + line=file1.readline() + if not line: + break + found=False + for key in common.keys(): + if line.startswith(key): + jobfile.write(common[key]) + found=True + break + for key in mydict.keys(): + if line.startswith(key): + jobfile.write(mydict[key]) + found=True + break + if not found: + jobfile.write(line) + + jobfile.close() + file1.close() + os.system("chmod +x "+jobfname) + + return jobfname +#-----------------------End of generateAjob(...)---------------| + diff --git a/util/DTC/MPMC/MPMC_config.py b/util/DTC/MPMC/MPMC_config.py new file mode 100755 index 000000000..e8baa5adf --- /dev/null +++ b/util/DTC/MPMC/MPMC_config.py @@ -0,0 +1,112 @@ +################################################### +# +# by Guoqing Ge, 2018/8/28, guoqing.ge@noaa.gov +# +# +import os, getpass, socket; hostnode=socket.gethostname() +from datetime import datetime +######### only make changes to project_acct and/or queue_name ############ +# +cheyenne=os.popen('grep -i "cheyenne" /etc/hosts | head -n1').read() +theia=os.popen('grep -i "theia" /etc/hosts | head -n1').read() +hera=os.popen('grep -i "hera" /etc/hosts | head -n1').read() +jet=os.popen('grep -i "jet" /etc/hosts | head -n1').read() + +if cheyenne: + project_acct="P48503002" #"P48500053" + queue_name = 'premium' + hostname="Cheyenne" ### Don't change hostname + +elif theia: + project_acct="comgsi" #wrfruc + queue_name = 'batch' + hostname="Theia" ### Don't change hostname + +elif hera: + project_acct="comgsi" #wrfruc + queue_name = 'batch' + hostname="Hera" ### Don't change hostname + +elif jet: + project_acct="wrfruc" + queue_name = 'windfall' #'batch' + hostname="Jet" ### Don't change hostname + +elif hostnode.startswith("GSI_Docker"): + project_acct="comgsi" + queue_name = 'batch' + hostname="GSI_Docker" ### Don't change hostname + +else: + print("\nI'm new to host: "+hostnode+"\nEmail gsi-help@ucar.edu for helps\n") + exit() + +########## Make changes to the following variable only if really necessary-------------- +ProdGSI_root = os.getcwd()+"/ProdGSI" #copy or link ProdGSI under MPMC_root or specifiy it here +# +MPMC_root = os.getcwd() # the MPMC scripts directory, i.e, current directory +branchName=os.popen('basename `git --git-dir '+ProdGSI_root+'/.git symbolic-ref HEAD`').read().strip() +commitID_full=os.popen('git --git-dir '+ProdGSI_root+'/.git log -1 |grep commit | head -1').read()[7:] +commitID=commitID_full[0:8] +if not commitID: #empty commitID + build_root = os.getcwd()+"/build" +else: + build_root = os.getcwd()+"/b_"+datetime.now().strftime("%Y%m%d")+"_"+branchName+"_"+commitID +# +username=getpass.getuser() +################# read project_acct and queue_name from config.acct_queue if it exists-------------- +if os.path.isfile("config.acct_queue"): + with open("config.acct_queue",'r') as f1: + project_acct=f1.readline().strip() + queue_name=f1.readline().strip() +# +################## Users usually don't make changes after this line ############ +# +module_pre = 'source /etc/profile.d/modules.sh\nmodule purge\n' +#construct PBS queue directives +q_directives = '#PBS -A ' + project_acct + '\n' +q_directives = q_directives+'#PBS -l walltime=00:30:00 \n' +q_directives = q_directives+'#PBS -q '+ queue_name+'\n' +q_directives = q_directives+'#PBS -j oe \n' +s_directives = '#SBATCH --account ' + project_acct + '\n' +s_directives = s_directives+'#SBATCH -t 00:45:00 \n' +s_directives = s_directives+'#SBATCH --qos '+ queue_name+'\n' +cmake_version = '' +comp_post='' +XML_native='' +serial_run=False +xml_set_nodesize=False +# +if hostname.startswith("Cheyenne"): ######################################### Cheyenne + xml_set_nodesize=True + rocoto_exe='/glade/u/home/geguo/rocoto/bin/rocotorun' + rocoto_scheduler='pbspro' + cmake_version = 'cmake/3.9.1' + q_directives = q_directives+'#PBS -l select=1:ncpus=8:mpiprocs=8\n' + q_directives = q_directives+'#PBS -l inception=login\n' + comp_post='ncarenv ncarcompilers' + +elif hostname.startswith("Theia"): ######################################### Theia + rocoto_exe='/apps/rocoto/default/bin/rocotorun' + rocoto_scheduler='slurm' + s_directives = s_directives+'#SBATCH --ntasks=8\n' + +elif hostname.startswith("Hera"): ######################################### Hera + rocoto_exe='/apps/rocoto/default/bin/rocotorun' + rocoto_scheduler='slurm' + s_directives = s_directives+'#SBATCH --ntasks=8\n' + +elif hostname.startswith("Jet"): ######################################### Jet + rocoto_exe='/apps/rocoto/default/bin/rocotorun' + rocoto_scheduler='slurm' + s_directives = s_directives+'#SBATCH --ntasks=8\n' + s_directives = s_directives+'#SBATCH --partition=kjet\n' + #module_pre=module_pre+"module load newdefaults\n" #specific for Jet + +elif hostname.startswith("GSI_Docker"): ######################################### GSI_Docker + rocoto_exe='/fake/rocotorun' + rocoto_scheduler='pbsfake' + q_directives = q_directives + serial_run=True + +#elif hostname.startswith("a_new_host"): diff --git a/util/DTC/MPMC/README.mpmc b/util/DTC/MPMC/README.mpmc new file mode 100644 index 000000000..bb7c45b2d --- /dev/null +++ b/util/DTC/MPMC/README.mpmc @@ -0,0 +1,57 @@ + + GSI/EnKF MPMC Test + (MPMC=Multiple Platforms Multiple Compilers) + +The MPMC test is a test suite developed by the DTC (Development Testbed Center) DA group +which builds and runs ProdGSI under different platforms (Hera, Theia, Cheyenne, Jet, Docker container +comgsi/docker, etc) under all available Fortran compliers in combination with different MPI libraries. + +At this time, 18 test cases are selected. They cover runs on single observation, 3DVAR, +Hybrid EnVAR 3D and 4D, NMMB, WRFCHEM, CMAQ, GFS, FV3, GSD cloud analysis and EnKF. + +Visit https://dtcenter.org/com-GSI/MPMC/ for more information. + +The ultimate goal is to test each major ProdGSI commit automatically so as to improve ProdGSI +compatibility and portability and facilitate R2O2R. + +**** how to run MPMC scripts **** + +1. Get latetest codes: + + (1) ProdGSI/util/DTC/MPMC +or + (2) git clone gerrit:MPMC + (you will need to contact gsi-help@ucar.edu for access to the MPMC project) + +Either (1) or (2) works. + +2. If this is the first time you run MPMC on a machine after getting the code, do this first + + ./initmpmc + + It will require a copy of ProdGSI under current directory (a link or a real copy) + +3. Create a file named "config.acct_queue", +put your project account name in the first line +put your queue name in the second line + +4. do GSI/EnKF compiling and running tests: + + ./run.py generate ----- generate compiling, running scripts, and rocoto xml files + ./run.py compile ----- generate compiling, running scripts and submit compiling jobs + ./run.py all ----- generate all required files, do compiling and case tests + + ***tips1: If you receive an error message similar as follows, it means you need to run "initmpmc" first. + ./run.py: Command not found. + +6. genereate a report of testing results: + + ./report.py ----- report both running and compiling results + +*********** +Be sure NOT to change to another branch of ProdGSI once started the MPMC test, wait until the test finished. +*********** + + +Contact gsi-help@ucar.edu for any questions. + diff --git a/util/DTC/MPMC/deinitmpmc b/util/DTC/MPMC/deinitmpmc new file mode 100755 index 000000000..234090867 --- /dev/null +++ b/util/DTC/MPMC/deinitmpmc @@ -0,0 +1 @@ +python .deinitMPMC.py diff --git a/util/DTC/MPMC/docker.runMPMCtest b/util/DTC/MPMC/docker.runMPMCtest new file mode 100755 index 000000000..113e6df6a --- /dev/null +++ b/util/DTC/MPMC/docker.runMPMCtest @@ -0,0 +1,12 @@ +#!/bin/bash +./generate.py mpmc +mpmc_dir=`pwd` +absdir=`cat list.all` +mybuild=`basename $absdir` +#compile +cd $absdir +./compile.sh +#run cases +cd $mpmc_dir +./run.py list.all submit 1,2,3,4,5,7 +echo "\n Done! \n" diff --git a/util/DTC/MPMC/initmpmc b/util/DTC/MPMC/initmpmc new file mode 100755 index 000000000..9f9de34e4 --- /dev/null +++ b/util/DTC/MPMC/initmpmc @@ -0,0 +1 @@ +python .initMPMC.py diff --git a/util/DTC/MPMC/option.full/optionlist.Cheyenne b/util/DTC/MPMC/option.full/optionlist.Cheyenne new file mode 100644 index 000000000..b4b32aabb --- /dev/null +++ b/util/DTC/MPMC/option.full/optionlist.Cheyenne @@ -0,0 +1,47 @@ +# Cheyenne build option list +# +# compiler, MPI, [lapack], NETCDF + intel/19.0.2, impi , mkl , netcdf + intel/19.0.2, mpt , mkl , netcdf + intel/19.0.2, openmpi , mkl , netcdf + intel/18.0.5, impi , mkl , netcdf + intel/18.0.5, mpt , mkl , netcdf + intel/18.0.5, openmpi , mkl , netcdf + intel/17.0.1, impi , mkl , netcdf + intel/17.0.1, mpt , mkl , netcdf + intel/17.0.1, openmpi , mkl , netcdf + + pgi/19.3, openmpi , , netcdf +# pgi/19.3, mpt , , netcdf + +# gnu/9.1.0, mpt , openblas, netcdf +# gnu/8.3.0, mpt , openblas, netcdf +# gnu/7.4.0, mpt , openblas, netcdf + gnu/9.1.0, openmpi , openblas, netcdf + gnu/8.3.0, openmpi , openblas, netcdf + gnu/7.4.0, openmpi , openblas, netcdf + +#Cheyenne is ot stable on maintaning lapack/3.7.0 --9/25/2018 +#known gnu/8.1.0, mvapich2/2.2, lapack/3.7.0, netcdf/4.6.1 +#known gnu/8.1.0, openmpi/3.1.0, lapack/3.7.0, netcdf/4.6.1 +#known gnu/7.3.0, mvapich2/2.2, lapack/3.7.0, netcdf/4.6.1 +#known gnu/7.3.0, openmpi/3.0.1, lapack/3.7.0, netcdf/4.6.1 +#known gnu/7.1.0, mvapich2/2.2, lapack/3.7.0, netcdf/4.6.1 +#known gnu/6.3.0, openmpi/3.0.0, lapack/3.7.0, netcdf/4.4.1.1 + +#known intel/16.0.1, mpt/2.19 , mkl , netcdf/4.5.0 +#known intel/16.0.1, openmpi/3.1.0 , mkl , netcdf/4.5.0 +#known pgi/17.9, mpt/2.19, , netcdf/4.4.1.1 +#known pgi/17.5, mpt/2.19, , netcdf/4.4.1.1 +#known pgi/16.5, mpt/2.19, , netcdf/4.5.0 +#known gnu/8.1.0, mpt/2.19, openblas/0.2.20, netcdf/4.6.1 +#known gnu/7.3.0, mpt/2.19, openblas/0.2.20, netcdf/4.6.1 +#known gnu/7.2.0, mpt/2.19, openblas/0.2.20, netcdf/4.4.1.1 +#known gnu/7.2.0, openmpi/3.0.1, openblas/0.2.20, netcdf/4.4.1.1 +#known gnu/7.1.0, mpt/2.19, openblas/0.2.20, netcdf/4.6.1 +#known gnu/7.1.0, openmpi/3.0.1, openblas/0.2.20, netcdf/4.6.1 +#known gnu/6.4.0, mpt/2.19, openblas/0.2.14, netcdf/4.4.1.1 +#known gnu/6.3.0, mpt/2.19, openblas/0.2.14, netcdf/4.4.1.1 +#known gnu/6.2.0, mpt/2.19, openblas/0.2.14, netcdf/4.4.1.1 +#known gnu/7.2.0, openmpi/3.0.1, lapack/3.7.0, netcdf/4.6.1 + diff --git a/util/DTC/MPMC/option.full/optionlist.GSI_Docker b/util/DTC/MPMC/option.full/optionlist.GSI_Docker new file mode 100644 index 000000000..cd7af4f6e --- /dev/null +++ b/util/DTC/MPMC/option.full/optionlist.GSI_Docker @@ -0,0 +1,3 @@ +# GSI_Docker build option list +# compiler, MPI, NETCDF, + gnu/7.3.0, openmpi/2.1.0, netcdf4/4.4.4 diff --git a/util/DTC/MPMC/option.full/optionlist.Hera b/util/DTC/MPMC/option.full/optionlist.Hera new file mode 100644 index 000000000..ff8c896bd --- /dev/null +++ b/util/DTC/MPMC/option.full/optionlist.Hera @@ -0,0 +1,14 @@ +# Hera build option list +# intel/17.0.5.239 intel/18.0.5.274 (D) intel/19.0.4.243 +# impi/2017.0.4 impi/2018.0.4 (D) impi/2019.0.4 +# netcdf/4.6.1 (D) netcdf/4.7.0 +# pgi/18.10 pgi/19.4 (L,D) +# +# compiler, MPI, NETCDF, + intel/19.0.4.243, impi/2019.0.4, netcdf/4.6.1 + intel/18.0.5.274, impi/2018.0.4, netcdf/4.6.1 + intel/17.0.5.239, impi/2017.0.4, netcdf/4.6.1 + +# theia, PGI can only use netcdf/4.4.0 and netcdf/3.6.3 + pgi/19.4, impi/2018.0.4, netcdf/4.6.1 + pgi/18.10, impi/2018.0.4, netcdf/4.6.1 diff --git a/util/DTC/MPMC/option.full/optionlist.Jet b/util/DTC/MPMC/option.full/optionlist.Jet new file mode 100644 index 000000000..c0d756a57 --- /dev/null +++ b/util/DTC/MPMC/option.full/optionlist.Jet @@ -0,0 +1,10 @@ +# Jet build option list +# compiler, MPI, NETCDF, + intel/19.0.1.144, impi , netcdf/4.2.1.1 + intel/18.0.5.274, impi , netcdf/4.2.1.1 + intel/15.0.3.187, impi , netcdf/4.2.1.1 + + intel/19.0.1.144, mvapich2/2.3, netcdf/4.2.1.1 + intel/18.0.5.274, mvapich2/2.3, netcdf/4.2.1.1 + + pgi/18.10 , mvapich2/2.3, netcdf/4.2.1.1 diff --git a/util/DTC/MPMC/option.full/optionlist.Theia b/util/DTC/MPMC/option.full/optionlist.Theia new file mode 100644 index 000000000..162180f26 --- /dev/null +++ b/util/DTC/MPMC/option.full/optionlist.Theia @@ -0,0 +1,47 @@ +# Theia build option list +# compiler, MPI, NETCDF, + intel/18.1.163, impi/5.1.2.150, netcdf/4.3.0 + intel/18.0.1.163, impi/5.1.2.150, netcdf/4.3.0 + intel/18.0.0.128, impi/5.1.2.150, netcdf/4.3.0 + intel/17.0.5.239, impi/5.1.2.150, netcdf/4.3.0 + intel/16.1.150, impi/5.1.2.150, netcdf/4.3.0 + intel/16.0.1.150, impi/5.1.2.150, netcdf/4.3.0 + intel/15.6.233, impi/5.1.2.150, netcdf/4.3.0 + intel/15.3.187, impi/5.1.2.150, netcdf/4.3.0 + intel/15.1.133, impi/5.1.2.150, netcdf/4.3.0 + intel/14.0.2, impi/5.1.2.150, netcdf/4.3.0 + + intel/18.1.163, mvapich2/2.1a, netcdf/4.3.0 + intel/18.0.1.163, mvapich2/2.1a, netcdf/4.3.0 + intel/18.0.0.128, mvapich2/2.1a, netcdf/4.3.0 + intel/17.0.5.239, mvapich2/2.1a, netcdf/4.3.0 + intel/16.1.150, mvapich2/2.1a, netcdf/4.3.0 + intel/16.0.1.150, mvapich2/2.1a, netcdf/4.3.0 + intel/15.6.233, mvapich2/2.1a, netcdf/4.3.0 + intel/15.3.187, mvapich2/2.1a, netcdf/4.3.0 + intel/15.1.133, mvapich2/2.1a, netcdf/4.3.0 + intel/14.0.2, mvapich2/2.1a, netcdf/4.3.0 + +# theia, PGI can only use netcdf/4.4.0 and netcdf/3.6.3 + pgi/18.5, mvapich2/2.1a, netcdf/4.4.0 + pgi/18.3, mvapich2/2.1a, netcdf/4.4.0 + pgi/18.1, mvapich2/2.1a, netcdf/4.4.0 + pgi/17.10, mvapich2/2.1a, netcdf/4.4.0 + pgi/17.7, mvapich2/2.1a, netcdf/4.4.0 + pgi/17.5, mvapich2/2.1a, netcdf/4.4.0 + pgi/17.3, mvapich2/2.1a, netcdf/4.4.0 + pgi/17.1, mvapich2/2.1a, netcdf/4.4.0 + pgi/16.10, mvapich2/2.1a, netcdf/4.4.0 + pgi/16.9, mvapich2/2.1a, netcdf/4.4.0 + pgi/16.7, mvapich2/2.1a, netcdf/4.4.0 + pgi/16.5, mvapich2/2.1a, netcdf/4.4.0 + +#known intel/15.0.0, impi/5.1.2.150, netcdf/4.3.0 +#known intel/13.1.3, impi/5.1.2.150, netcdf/4.3.0 +#known intel/12-12.0.4.191,impi/5.1.2.150, netcdf/4.3.0 +#known intel/15.0.0, mvapich2/2.1a, netcdf/4.3.0 +#known intel/13.1.3, mvapich2/2.1a, netcdf/4.3.0 +#known intel/12-12.0.4.191,mvapich2/2.1a, netcdf/4.3.0 +#known pgi/15.1, mvapich2/2.1a, netcdf/4.4.0 +#known pgi/14.10, mvapich2/2.1a, netcdf/4.4.0 +#known pgi/12.5, mvapich2/2.1a, netcdf/4.4.0 diff --git a/util/DTC/MPMC/option.short/optionlist.Cheyenne b/util/DTC/MPMC/option.short/optionlist.Cheyenne new file mode 100644 index 000000000..2a34fbf05 --- /dev/null +++ b/util/DTC/MPMC/option.short/optionlist.Cheyenne @@ -0,0 +1,4 @@ +# Cheyenne build option list +# +# compiler, MPI, [lapack], NETCDF + intel/17.0.1, mpt , mkl , netcdf diff --git a/util/DTC/MPMC/option.short/optionlist.GSI_Docker b/util/DTC/MPMC/option.short/optionlist.GSI_Docker new file mode 100644 index 000000000..cd7af4f6e --- /dev/null +++ b/util/DTC/MPMC/option.short/optionlist.GSI_Docker @@ -0,0 +1,3 @@ +# GSI_Docker build option list +# compiler, MPI, NETCDF, + gnu/7.3.0, openmpi/2.1.0, netcdf4/4.4.4 diff --git a/util/DTC/MPMC/option.short/optionlist.Hera b/util/DTC/MPMC/option.short/optionlist.Hera new file mode 100644 index 000000000..b63f899ea --- /dev/null +++ b/util/DTC/MPMC/option.short/optionlist.Hera @@ -0,0 +1,8 @@ +# Hera build option list +# intel/17.0.5.239 intel/18.0.5.274 (D) intel/19.0.4.243 +# impi/2017.0.4 impi/2018.0.4 (D) impi/2019.0.4 +# netcdf/4.6.1 (D) netcdf/4.7.0 +# pgi/18.10 pgi/19.4 (L,D) +# +# compiler, MPI, NETCDF, + intel/18.0.5.274, impi/2018.0.4, netcdf/4.6.1 diff --git a/util/DTC/MPMC/option.short/optionlist.Jet b/util/DTC/MPMC/option.short/optionlist.Jet new file mode 100644 index 000000000..fb57782f9 --- /dev/null +++ b/util/DTC/MPMC/option.short/optionlist.Jet @@ -0,0 +1,3 @@ +# Jet build option list +# compiler, MPI, NETCDF + intel/18.0.5.274, impi , netcdf/4.2.1.1 diff --git a/util/DTC/MPMC/option.short/optionlist.Theia b/util/DTC/MPMC/option.short/optionlist.Theia new file mode 100644 index 000000000..86d311ee1 --- /dev/null +++ b/util/DTC/MPMC/option.short/optionlist.Theia @@ -0,0 +1,3 @@ +# Theia build option list +# compiler, MPI, NETCDF + intel/18.1.163, impi/5.1.2.150, netcdf/4.3.0 diff --git a/util/DTC/MPMC/option.standard/optionlist.Cheyenne b/util/DTC/MPMC/option.standard/optionlist.Cheyenne new file mode 100644 index 000000000..5a6db1320 --- /dev/null +++ b/util/DTC/MPMC/option.standard/optionlist.Cheyenne @@ -0,0 +1,15 @@ +# Cheyenne build option list +# +# compiler, MPI, [lapack], NETCDF + intel/18.0.5, impi , mkl , netcdf + intel/17.0.1, impi , mkl , netcdf + + pgi/19.3, openmpi , , netcdf +# pgi/19.3, mpt , , netcdf + +# gnu/9.1.0, mpt , openblas, netcdf +# gnu/8.3.0, mpt , openblas, netcdf +# gnu/7.4.0, mpt , openblas, netcdf + gnu/9.1.0, openmpi , openblas, netcdf + gnu/8.3.0, openmpi , openblas, netcdf + gnu/7.4.0, openmpi , openblas, netcdf diff --git a/util/DTC/MPMC/option.standard/optionlist.GSI_Docker b/util/DTC/MPMC/option.standard/optionlist.GSI_Docker new file mode 100644 index 000000000..cd7af4f6e --- /dev/null +++ b/util/DTC/MPMC/option.standard/optionlist.GSI_Docker @@ -0,0 +1,3 @@ +# GSI_Docker build option list +# compiler, MPI, NETCDF, + gnu/7.3.0, openmpi/2.1.0, netcdf4/4.4.4 diff --git a/util/DTC/MPMC/option.standard/optionlist.Hera b/util/DTC/MPMC/option.standard/optionlist.Hera new file mode 100644 index 000000000..41379a501 --- /dev/null +++ b/util/DTC/MPMC/option.standard/optionlist.Hera @@ -0,0 +1,14 @@ +# Hera build option list +# intel/17.0.5.239 intel/18.0.5.274 (D) intel/19.0.4.243 +# impi/2017.0.4 impi/2018.0.4 (D) impi/2019.0.4 +# netcdf/4.6.1 (D) netcdf/4.7.0 +# pgi/18.10 pgi/19.4 (L,D) +# +# compiler, MPI, NETCDF, +# intel/19.0.4.243, impi/2019.0.4, netcdf/4.6.1 + intel/18.0.5.274, impi/2018.0.4, netcdf/4.6.1 + intel/17.0.5.239, impi/2017.0.4, netcdf/4.6.1 + +# theia, PGI can only use netcdf/4.4.0 and netcdf/3.6.3 +# pgi/19.4, impi/2018.0.4, netcdf/4.6.1 +# pgi/18.10, impi/2018.0.4, netcdf/4.6.1 diff --git a/util/DTC/MPMC/option.standard/optionlist.Jet b/util/DTC/MPMC/option.standard/optionlist.Jet new file mode 100644 index 000000000..f072d17f7 --- /dev/null +++ b/util/DTC/MPMC/option.standard/optionlist.Jet @@ -0,0 +1,9 @@ +# Jet build option list +# compiler, MPI, NETCDF, + intel/18.0.5.274, impi , netcdf/4.2.1.1 + intel/15.0.3.187, impi , netcdf/4.2.1.1 + + intel/18.0.5.274, mvapich2/2.3, netcdf/4.2.1.1 +# intel/15.0.3.187, mvapich2/2.3, netcdf/4.2.1.1 #known not working with mvapich2/2.3 + + pgi/18.10 , mvapich2/2.3, netcdf/4.2.1.1 diff --git a/util/DTC/MPMC/option.standard/optionlist.Theia b/util/DTC/MPMC/option.standard/optionlist.Theia new file mode 100644 index 000000000..233c2b549 --- /dev/null +++ b/util/DTC/MPMC/option.standard/optionlist.Theia @@ -0,0 +1,11 @@ +# Theia build option list +# compiler, MPI, NETCDF, + intel/18.1.163, impi/5.1.2.150, netcdf/4.3.0 + intel/14.0.2, impi/5.1.2.150, netcdf/4.3.0 + + intel/18.1.163, mvapich2/2.1a, netcdf/4.3.0 + intel/14.0.2, mvapich2/2.1a, netcdf/4.3.0 + +# theia, PGI can only use netcdf/4.4.0 and netcdf/3.6.3 + pgi/18.5, mvapich2/2.1a, netcdf/4.4.0 + pgi/16.5, mvapich2/2.1a, netcdf/4.4.0 diff --git a/util/DTC/MPMC/optionlist.Cheyenne b/util/DTC/MPMC/optionlist.Cheyenne new file mode 100644 index 000000000..5a6db1320 --- /dev/null +++ b/util/DTC/MPMC/optionlist.Cheyenne @@ -0,0 +1,15 @@ +# Cheyenne build option list +# +# compiler, MPI, [lapack], NETCDF + intel/18.0.5, impi , mkl , netcdf + intel/17.0.1, impi , mkl , netcdf + + pgi/19.3, openmpi , , netcdf +# pgi/19.3, mpt , , netcdf + +# gnu/9.1.0, mpt , openblas, netcdf +# gnu/8.3.0, mpt , openblas, netcdf +# gnu/7.4.0, mpt , openblas, netcdf + gnu/9.1.0, openmpi , openblas, netcdf + gnu/8.3.0, openmpi , openblas, netcdf + gnu/7.4.0, openmpi , openblas, netcdf diff --git a/util/DTC/MPMC/releases/fix.check b/util/DTC/MPMC/releases/fix.check new file mode 100755 index 000000000..122d16f26 --- /dev/null +++ b/util/DTC/MPMC/releases/fix.check @@ -0,0 +1,6 @@ +#!/bin/bash + +GSI=/glade/work/geguo/MPMC/ProdGSI +while read line; do + ls -l $GSI/fix/$line +done < fix.list diff --git a/util/DTC/MPMC/releases/fix.list b/util/DTC/MPMC/releases/fix.list new file mode 100644 index 000000000..d775bda16 --- /dev/null +++ b/util/DTC/MPMC/releases/fix.list @@ -0,0 +1,79 @@ +aeroinfo_aod.txt +anavinfo_aod_gocart +anavinfo_arw_binary +anavinfo_arw_netcdf +anavinfo_arw_netcdf_glbe +anavinfo_cmaq_binary +anavinfo_cmaq_pm25 +anavinfo_fv3 +anavinfo_gsdcld4nmmb +anavinfo_hwrf_L60 +anavinfo_hwrf_L60_nooz +anavinfo_hwrf_L75 +anavinfo_ndas_binary +anavinfo_ndas_netcdf +anavinfo_nems_nmmb +anavinfo_nems_nmmb_glb +anavinfo_wrfchem_gocart +anavinfo_wrfchem_pm25 +atms_beamwidth.txt +bufrtab.012 +convinfo_gsdcld4nmmb +example_unformatted_fileinfo.txt +global_aeroinfo.txt +global_anavinfo.l64.txt +global_convinfo.txt +global_hybens_info.l64.txt +global_hybens_info_variable.l64.txt +global_hybens_smoothinfo.l64.txt +global_insituinfo.txt +global_ozinfo.txt +global_pcpinfo.txt +global_satangbias.txt +global_satinfo.txt +global_scaninfo.txt +hwrf_basinscale_satinfo.txt +hwrf_convinfo.txt +hwrf_hybens_d01_info +hwrf_hybens_d2_info +hwrf_hybens_d3_info +hwrf_nam_errtable.r3dv +hwrf_satinfo.txt +nam_errtable.r3dv +nam_global_ozinfo.txt +nam_global_pcpinfo.txt +nam_global_satangbias.txt +nam_hybens_d01_info +nam_mesonet_stnuselist.txt +nam_mesonet_uselist.txt +nam_nmmstat_na +nam_regional_convinfo_reg_test.txt +nam_regional_convinfo.txt +nam_regional_satinfo.txt +prepobs_errtable.global +prepobs_errtable.global.3hr_satwnd +prepobs_errtable.hwrf +prepobs_errtable_ps.CTL +prepobs_errtable_ps.global_nqcf +prepobs_errtable_ps.rev2 +prepobs_errtable_pw.global +prepobs_errtable_q.CTL +prepobs_errtable_q.global_nqcf +prepobs_errtable_t.CTL +prepobs_errtable_t.global_nqcf +prepobs_errtable_uv.CTL +prepobs_errtable_uv.global_nqcf +prepobs_errtable_uv.rev3 +prepobs_prep.bufrtable +rap_anavinfo_arw_netcdf +rap_berror_stats_global +rap_current_bad_aircraft.txt +rap_global_ozinfo.txt +rap_global_pcpinfo.txt +rap_global_satangbias.txt +rap_global_satinfo.txt +rap_nam_errtable.r3dv +rap_nam_regional_convinfo +comgsi_satbias_in +comgsi_satbias_pc_in +cloudy_radiance_info.txt diff --git a/util/DTC/MPMC/releases/getGlobalFixTarball b/util/DTC/MPMC/releases/getGlobalFixTarball new file mode 100755 index 000000000..b893f4fb6 --- /dev/null +++ b/util/DTC/MPMC/releases/getGlobalFixTarball @@ -0,0 +1,43 @@ +#!/usr/bin/python3 +exlude=['rtma', 'urma', 'VLab', '.git'] +# +release="comGSIv3.7_EnKFv1.3_fix_global.tar.gz" +GSI="/glade/work/geguo/MPMC/ProdGSI" +basefixlist='/glade/work/geguo/MPMC/releases/fix.list' +# remove old tarball and its directory +import os +os.system("rm -rf "+release+" global; mkdir -p global") +os.chdir("global") +# get basic fix file list +with open(basefixlist) as f: + fixbasic = f.read().splitlines() +# get all fix file list +from os import walk +for (dirpath, dirnames, filenames) in walk(GSI+"/fix"): + fixglobal=filenames + break +# link fix files not exluded and not in fbasic +for x in fixglobal: + excluded=False + for y in exlude: + if x.find(y)>=0: + excluded=True + if not excluded and not (x in fixbasic): + os.system("ln -sf "+GSI+"/fix/"+x+" .") +# get Big_Endian file list +os.system("mkdir -p Big_Endian") +BigEdnBasic=['cmaq_berror_big_endian','cmaq_pm2_5_reg_berror_12z.bin', \ + 'global_berror.l64y96.f77','nam_glb_berror.f77.gcv','nam_nmmstat_na.gcv', \ + 'wrf_chem_berror_big_endian'] +for (dirpath, dirnames, filenames) in walk(GSI+"/fix/Big_Endian"): + fixBigEndian=filenames + break +for x in fixBigEndian: + excluded=False + for y in exlude: + if x.find(y)>=0: excluded=True + if not excluded and not (x in BigEdnBasic): + os.system("ln -sf "+GSI+"/fix/Big_Endian/"+x+" Big_Endian") +#make a tar ball +os.system("tar cvfzh ../"+release+" .") + diff --git a/util/DTC/MPMC/releases/makeRelease b/util/DTC/MPMC/releases/makeRelease new file mode 100755 index 000000000..877d5b788 --- /dev/null +++ b/util/DTC/MPMC/releases/makeRelease @@ -0,0 +1,85 @@ +#!/bin/bash +# by Guoqing Ge, 2018/9/19 +# +# Create a realease directory, link required components from ProdGSI +# and make a tar ball +# +release=comGSIv3.7_EnKFv1.3 +GSI="/glade/work/geguo/MPMC/git_ProdGSI" +fixlist="/glade/work/geguo/MPMC/releases/fix.list" +# +# remove old tarball and its direcotry +rm -rf $release +rm -rf ${release}.tar.gz +# +## declare an array variable +declare -a fROOT=("cmake" "CMakeLists.txt" "libsrc") +declare -a fUtil=("bufr_tools" "DTC/GEN_BE.comgsi" "gsienvreport.sh" + "radar_process" "ndate") +declare -a fBig_Endian=("cmaq_berror_big_endian" + "cmaq_pm2_5_reg_berror_12z.bin" "wrf_chem_berror_big_endian" + "nam_glb_berror.f77.gcv" "nam_nmmstat_na.gcv" "global_berror.l64y96.f77" + ) +# You can access them using echo "${arr[0]}", "${arr[1]}" + +mkdir -p $release; cd $release +## now loop through fROOT +for i in "${fROOT[@]}"; do + ln -sf $GSI/$i . +done +mkdir src +ln -sf $GSI/src/* src +rm src/enkf +mkdir src/enkf +ln -sf $GSI/src/enkf/* src/enkf + +#rm src/Make* src/enkf/Make* +rm src/make* + +ln -sf $GSI/util/DTC/README.comgsi . +ln -sf $GSI/util/DTC/README.GSI_Docker . +## link ush +mkdir -p ush +ln -sf $GSI/ush/com* ush + +## link util +mkdir -p util +for i in "${fUtil[@]}"; do + ln -sf $GSI/util/$i util +done +mkdir -p util/Analysis_Utilities +ln -sf $GSI/util/Analysis_Utilities/plot_cost_grad/ util/Analysis_Utilities +ln -sf $GSI/util/Analysis_Utilities/plots_ncl util/Analysis_Utilities +ln -sf $GSI/util/Analysis_Utilities/read_diag util/Analysis_Utilities +mkdir -p util/EnKF; ln -sf $GSI/util/EnKF/arw util/EnKF +ln -sf $GSI/util/DTC/GEN_BE.comgsi util + +## link basic fix files +mkdir -p fix fix/Big_Endian +for i in "${fBig_Endian[@]}"; do + ln -sf $GSI/fix/Big_Endian/$i fix/Big_Endian +done +### link fix files listed in "fix.list" +while read line; do + ln -sf $GSI/fix/$line fix/ +done < $fixlist + +## turn on BUILD_WRF and BUILD_CORE_LIBS by default +sed -e 's/ SET(ENKF_MODE "GFS" CACHE STRING "EnKF build mode: GFS, WRF, NMMB")/ SET(ENKF_MODE "WRF" CACHE STRING "EnKF build mode: GFS, WRF, NMMB")\n option(BUILD_CORELIBS "Build the Core libraries " ON)/' CMakeLists.txt > tmp.txt +rm CMakeLists.txt +mv tmp.txt CMakeLists.txt + +# make a tarball +cd .. +echo "making a release tarball based on ${GSI}" +tar hcvfz ${release}.tar.gz $release >/dev/null +echo "Done!" +set -x +mv ${release}.tar.gz /glade/work/geguo/misc +cd /glade/work/geguo/misc; +scp ${release}.tar.gz geguo@mohawk.rap.ucar.edu://d2/www/dtcenter/com-GSI/users/downloads/GSI_releases + +exit + + + diff --git a/util/DTC/MPMC/report.py b/util/DTC/MPMC/report.py new file mode 100755 index 000000000..369746258 --- /dev/null +++ b/util/DTC/MPMC/report.py @@ -0,0 +1,263 @@ +#!/usr/bin/python3 +# the first line does not matter, it will be replaced by running "initmpmc" +################################################### +# This python script will check compiling and running results and generate a report +# +# by Guoqing Ge, 2018/8/20, guoqing.ge@noaa.gov +# +# Usage: +# report.py [report_option] +# where report_option is either 1 (compiling results), or 2 (running results) +# if report_option is missing, do both 1 and 2 +# +################################################### +# +def empty_fun():pass +import sys,os +from MPMC_config import build_root, hostname +from CASE_config import allcases +from datetime import datetime +if hostname.startswith("Cheyenne"): Cheyenne=True +else: Cheyenne=False + +def compiling_check( mybuild ): +# 1-Makefile 2-gsi.x 3-enkf_gfs.x 4-enkf_wrf.x +# 5-ndate.x, nc_diag_cat.x and test_nc_unlimdims.x +# 6-community utilities (bufrtools, read_diag, etc) +# |1|2|3|4|5|6| +# |Y|Y|Y|Y|Y|Y|==> + exelist=[['Makefile'], ['gsi.x'], ['enkf_gfs.x'], ['enkf_wrf.x'] \ + ,['ndate.x', 'nc_diag_cat.x','test_nc_unlimdims.x'] \ + ,['bufr_append_sample.x', 'bufr_decode_l2rwbufr.x', 'bufr_decode_radiance.x', \ + 'bufr_decode_sample.x', 'bufr_encode_l2rwbufr.x', 'bufr_encode_radarbufr.x', \ + 'bufr_encode_sample.x', 'prepbufr_append_retrieve.x', 'prepbufr_append_surface.x', \ + 'prepbufr_append_upperair.x', 'prepbufr_decode_all.x', 'prepbufr_encode_surface.x', \ + 'prepbufr_encode_upperair.x', 'prepbufr_inventory.x','enspreproc.x', 'initialens.x', \ + 'process_NSSL_mosaic.x', 'read_diag_conv.x', 'read_diag_rad.x' ] \ + ] + results = "|" + + for x in exelist: + allyes=True + for y in x: + if y=="Makefile": + file1=mybuild+'/'+y + else: + file1=mybuild+'/bin/'+y + if not (os.path.isfile(file1) and os.access(file1, os.R_OK)): + print("NOT_FOUND: "+file1) + allyes=False + + if allyes: + results=results+"Y|" + else: + results=results+"N|" + + return results +#-------------------- end of function compiling_check +# +############## fucntion getModuleName: find the full module name in the src string +def getModuleName(src,target): + k1=src.find(target) + if k1>=0: + k2=src.find(' ',k1) + if k2<0: k2=len(src) + mname=src[k1:k2].strip() + return mname + else: + return '' +#--------------------- end of function of getModuleName(...) +# +row_results={} +for x in allcases: row_results[x]={} + +### parse the command line parameters +arguments = len(sys.argv) - 1 +if (arguments >=1): + cmdparam=sys.argv[1] +else: + cmdparam="list.all" + report_option="all" + +if cmdparam.find('help')>=0: + print("Usage: report.py [one_build_directory | list_file_name] [1|2]") + exit() + +report_option="all" +if (arguments >=2): + report_option=sys.argv[2] + +fullpath=build_root +"/"+cmdparam +cwd = os.getcwd() +if (os.path.isdir(fullpath)): + print("Check running results in the given directory: "+fullpath) + dir_list=[fullpath] +elif (os.path.isfile(cwd+"/"+cmdparam)): + print("Check running results in all directories listed in the file: "+cwd+"/"+cmdparam) + with open(cwd+"/"+cmdparam) as f: + dir_list = f.readlines() + if(len(dir_list)<=0): print("\nThe list file is empty, exit\n"); exit() + dir_list = [x.strip() for x in dir_list] #strip "\n" + if (dir_list[0][0]!= "/"): # if not absolute path, add the prefix based on "build_root" + for i in range(len(dir_list)): + dir_list[i]=build_root +"/"+dir_list[i] +else: + print("You don't run me correctly!") + print("Usage: report.py [1|2]") + exit() + +tot=len(dir_list) +if tot>1: + print("There are "+str(tot)+" directories in total") + +build_list=[]; compiler=[]; netcdf=[]; mpi=[]; lapack=[]; build_result=[] +case_matrix={} +for mybuild in dir_list: + #print("Now working on "+mybuild) + print(".",end='',flush=True) + if mybuild.endswith('/'): mybuild=mybuild[:-1] #remove trailing '/' + k=mybuild.rfind('/') + mybuild_short=mybuild[k+1:len(mybuild)] # get the relative path + mybuild_parent=mybuild[0:k] # get the parent directory + build_list.append(mybuild_short) + + if(report_option=='1' or report_option=='all'): #this step takes a little bit time, so only do it when necessary + build_result.append(compiling_check(mybuild)) + ### read module informatin from compile.sh + file1=open(mybuild+"/compile.sh", "r") + found_lapack=False + while True: + line=file1.readline() + if not line: + break + if line.startswith("module"): + tem1=getModuleName(line,"intel") + if tem1!='': compiler.append(tem1) + tem1=getModuleName(line,"pgi") + if tem1!='': compiler.append(tem1) + tem1=getModuleName(line,"gnu") + if tem1!='': compiler.append(tem1) + tem1=getModuleName(line,"netcdf") + if tem1!='': netcdf.append(tem1) + tem1=getModuleName(line,"impi") + if tem1!='': mpi.append(tem1) + tem1=getModuleName(line,"mvapich2") + if tem1!='': mpi.append(tem1) + tem1=getModuleName(line,"openmpi") + if tem1!='': mpi.append(tem1) + tem1=getModuleName(line,"mpt") + if tem1!='': mpi.append(tem1) + tem1=getModuleName(line,"lapack") + if tem1!='': lapack.append(tem1);found_lapack=True + tem1=getModuleName(line,"openblas") + if tem1!='': lapack.append(tem1);found_lapack=True + tem1=getModuleName(line,"mkl") + if tem1!='': lapack.append(tem1);found_lapack=True + file1.close() + if Cheyenne and (not found_lapack): + lapack.append(" ") + + row_results=row_results.fromkeys(row_results,'') #clear the values + at_lease_one_job_submitted=False + for x in allcases: + case_dir=mybuild+"/run/"+x + if os.path.isdir(case_dir): # directory created + at_lease_one_job_submitted=True + run_results=os.popen("grep 'PROGRAM GSI_ANL HAS ENDED' "+case_dir+"/stdout").read().strip() + if run_results=='': # if empty, it may be an EnKF case + run_results=os.popen("grep 'PROGRAM ENKF_ANL HAS ENDED' "+case_dir+"/stdout").read().strip() + if run_results=='': + row_results[x]='N' # 0 means failure + else: + row_results[x]='Y' # 1 means good + else: + row_results[x]='-' # - means case not genereate or submitted + + if (at_lease_one_job_submitted): + case_matrix[mybuild_short]=row_results + else: + case_matrix[mybuild_short]={} + +#read branchName and commitID from branch_commit.txt +file1=open(mybuild_parent+"/branch_commit.txt", "r") +branchName=file1.readline().strip() +commitID=file1.readline().strip() +file1.close() +print('\n\n'+datetime.now().strftime("%Y%m%d")+ ' Tested on commit: '+commitID+' branch: '+branchName, end='\n') +tem=max(build_list,key=len) +longest=(len(tem)) +# +###### generate reports of GSI/EnKF running results ########################################## +if(len(case_matrix)==0): print("No job has been submitted") +if (len(case_matrix)>0 and (report_option=='2' or report_option=='all')): + width_tot=len(allcases)*3+ longest +2 + print('') + ### write out case names for easy reference + myknt=1 + for x in allcases: + if (myknt%4==0):print(x+'\n',end=''); + else:print(x,end=', ') + myknt=myknt+1 + print('\n\n',end='') + + title='----- GSI/EnKF Running Tests' + print(title+'-'*(width_tot-len(title))) + first_time=True + for x in build_list: + if not any(case_matrix[x]): continue + MAX_CASES=40 ### maximum number of MPMC cases + one_row=[None] * MAX_CASES + ###if first_time: print('|'+'case#'.rjust(longest)+"|",end='') + if first_time: print('case#'.rjust(longest+1)+"|",end='') + for i in range(MAX_CASES): + sNumber=str(i+1).zfill(2) + for key,value in case_matrix[x].items(): + if key.startswith("case"+sNumber): + if first_time: print(sNumber,end='|') + one_row[i]=value + break + + if first_time: + print('\n',end='') + first_time=False + + ###print('+'+ '-'*longest+"+"+"--+"*15) ## comment out to save display space + + ###print('|'+x.ljust(longest),end='|') + print(x.ljust(longest+1),end='|') + for i in range(len(one_row)): + if (one_row[i]!=None): + print(one_row[i].ljust(2),end='|') + print('\n',end='') + + ###print('+'+ '-'*longest+"+"+"--+"*15) ## comment out to save display space + +##################### Generate report of GSI/EnKF Compiling test results ########################################## +if (report_option=="1" or report_option=='all'): + tem=max(compiler,key=len); max_compiler=len(tem) + tem=max(mpi,key=len); max_mpi=len(tem) + tem=max(netcdf,key=len); max_netcdf=len(tem) + if (len(lapack)>0): + tem=max(lapack,key=len); max_lapack=len(tem) + else: + max_lapack=0 + width_tot=8+max_compiler+2+max_mpi+2+max_netcdf+2+max_lapack+2+longest+2 + print('') + title='----- GSI/EnKF Compiling Tests' + print(title+'-'*(width_tot-len(title))) + print('1-Makefile 2-gsi.x 3-enkf_gfs.x 4-enkf_wrf.x 5-ndate.x, nc_diag_cat.x and test_nc_unlimdims.x \ + \n6-community utilities (read_diag, etc) \ + \n|1|2|3|4|5|6|') + for i in range(len(dir_list)): + print(build_result[i].ljust(8),end='=>|') + print(build_list[i][0:2].ljust(3),end='|') + print(compiler[i].ljust(max_compiler+1),end='|') + print(mpi[i].ljust(max_mpi+1),end='|') + print(netcdf[i].ljust(max_netcdf+1),end='|') + if (len(lapack)>0): + print(lapack[i].ljust(max_lapack+1),end='|') + print('>'+build_list[i].ljust(longest),end='') + print('\n',end='') + +print('\n',end='') + diff --git a/util/DTC/MPMC/run.py b/util/DTC/MPMC/run.py new file mode 100755 index 000000000..3c15ce0ee --- /dev/null +++ b/util/DTC/MPMC/run.py @@ -0,0 +1,309 @@ +#!/usr/bin/python3 +# the first line does not matter, it will be replaced by running "initmpmc" +################################################### +# This python script will generate GSI/EnKF compiling job scripts, +# case running job scripts and rocoto flow xml file +# +# by Guoqing Ge, 2018/8/28, guoqing.ge@noaa.gov +# +#mpmc.py [ command [full|short|debug] ] +# command = generate, compile, all +# where debug just use the optionlist under current directory +#report.py +# +# +from MPMC_config import MPMC_root, ProdGSI_root, build_root, module_pre, q_directives, \ + cmake_version, comp_post, hostname, project_acct, queue_name, s_directives, \ + XML_native, rocoto_exe, rocoto_scheduler, xml_set_nodesize, commitID, branchName +from CASE_config import create_run_scripts, allcases, many_procs +from datetime import datetime +import os, sys + +###### parse command line parameters +force=False #whether to force overwritting to skip user's choice of 1/2/3 +submit=False #whether to submit jobs after scripts were created +newlist=False #whether to write out a list file +rocoto=False #whether to generat a rocoto xml file +helpme=False #whether to show the help page +cmdline='' +options='standard' #use standard optionlist by default +for i in range(1,len(sys.argv)): + cmdline=cmdline+' '+sys.argv[i] +if cmdline.find("force")>=0: force=True +if cmdline.find("newlist")>=0: newlist=True +if cmdline.find("compile")>=0: submit=True +if cmdline.find("all")>=0: submit=True +if cmdline.find("generate")>=0: rocoto=True +if cmdline.find("all")>=0: rocoto=True +if cmdline.find("help")>=0: helpme=True +if cmdline.find("full")>=0: options='full' +if cmdline.find("short")>=0: options='short' +if cmdline.find("debug")>=0: options='debug' +if cmdline=='': helpme=True + +###### show the help page +if (helpme): + print('\n\ +Welcome to the DTC MPMC Test suite !\n\ +(https://dtcenter.org/com-GSI/MPMC)\n\ +The following is a brief description on how to use run.py, report.py:\n\ +\n\ +run.py ----- show this help\n\ +\n\ +run.py generate ----- generate compiling, running scripts, and rocoto xml files\n\ +run.py compile ----- generate compiling, running scripts and submit compiling jobs\n\ +run.py all ----- generate all required files, do compiling and case tests \n\ +\n\ +report.py ----- report both running and compiling results\n\ +\n\ +For further questions, contact gsi-help@ucar.edu.\n\ + ') + exit() + +#exit if project_acct and queue_name are not specified +if not project_acct or not queue_name: + print("\n\ + Project accout and queue name are empty!!!\n\ + Please set them in config.acct_queue\n\ + (account name in the 1st line and queue name in the 2nd line)\n") + exit() + +#-------- decide which optionlist to be used ------- +if options.startswith('full'): + os.system("cp "+MPMC_root+"/option.full/optionlist."+hostname+" "+MPMC_root) +elif options.startswith('short'): + os.system("cp "+MPMC_root+"/option.short/optionlist."+hostname+" "+MPMC_root) +elif options.startswith('standard'): + os.system("cp "+MPMC_root+"/option.standard/optionlist."+hostname+" "+MPMC_root) + +#--------------------------------- +#Read in build options +foptions=open("optionlist."+hostname, "r") +build_options=[] +while True: + line=foptions.readline() + if not line: + break; + if not (line.strip().startswith('#') or line.strip()==''): + build_options.append(line.strip()) + +#for x in build_options: +# print(x) + +### show the build_root to be created +relPath=os.popen("basename "+build_root).read() +print('\n The project account name: '+project_acct+'\n The queue name: '+queue_name+'\n') +print('The MPMC test will be conducted under the following direcotry(b_branchName_commitID or build):\n\n '+relPath) +choice=input("Input y to continue, n to exit >>>") +if choice=='n' or choice=='N': + exit() + +### check whether build_root exists, if yes, let user choose whether to do +if os.path.isdir(build_root) and not force: + print('\nbuild_root directory "'+build_root+'" already exists\n') + mtime=datetime.fromtimestamp(os.path.getmtime(build_root)).strftime("%Y%m%d_%H:%M:%S") + print("Please choose: 1. overwrite it") + print(' 2. rename it to "'+ build_root+'_'+mtime+'"') + print(" 3. exit the program") + choice=input("1, 2 or 3 ? >>>") + if choice=='2' or choice=='2': + os.rename(build_root, build_root+"_"+mtime) + os.system("mkdir -p "+build_root) + print('old directory is renamed to: '+build_root+"_"+mtime) + print('Now working on '+build_root) + elif choice=='1' or choice=='1': + print('overwrite '+build_root) + else: + print('\nPlease remove or rename the old build_root "'+build_root+'"\n') + exit() +else: + os.system("mkdir -p "+build_root) + +###write branchName and commitID to build_root +file1=open(build_root+'/branch_commit.txt', 'w') +file1.write(branchName+'\n') +file1.write(commitID) +file1.close() + +##### Genereate compiling and running scripts ------------------------ +flist_name="list."+datetime.now().strftime("%Y%m%d_%H:%M:%S") +flist=open("list.all","w") +sBuild=''; sCompiler=''; sMPI='' +knt=0 +for x in build_options: + if not submit: print('.',end='', flush=True) #if no submit, print out status dot + modlist=x.split(',') + compiler=modlist[0].strip().replace('/','_') #the first word is the compiler + mpi =modlist[1].strip().replace('/','_') #the second word is the MPI library + knt=knt+1 + build_ID="{0:02d}".format(knt) + sBuild=sBuild+build_ID+" " + sCompiler=sCompiler+compiler+" " + sMPI=sMPI+mpi+" " + + k=len(modlist) + #cc_name=modlist[k-2].strip() #the second last word is the CC name + #cxx_name=modlist[k-1].strip() #the last word is the CXX name + #2019/05/22: cc_name and cxx_name no longer needed + + modules=module_pre + #for i in range(0,k-2): + for i in range(0,k): + word=modlist[i].strip() + if word.find("intel")>=0 or word.find("pgi")>=0 or word.find("gnu")>=0: + word=word+" "+comp_post + if word.find("netcdf")>=0 and hostname.startswith("Jet"): + word="szip hdf5 "+word + modules=modules+"module load "+word+"\n" + + if cmake_version: + modules=modules+"module load "+cmake_version+"\n" + + bld_fullname=build_ID+'.'+compiler+'.'+mpi + if rocoto_scheduler.find('slurm')>=0: + q_ready="#!/bin/sh\n#SBATCH --job-name "+bld_fullname+"\n"+s_directives + q_ready=q_ready+"#SBATCH -o output."+build_ID+"\n" + else: + q_ready="#!/bin/sh\n#PBS -N "+bld_fullname+"\n"+q_directives + q_ready=q_ready+"#PBS -o output."+build_ID+"\n" + + rmfiles1="CMakeCache.txt CMakeFiles Makefile DartConfiguration.tcl src done.compiling" + rmfiles2="include lib libsrc util Testing regression_var.out cmake_install.cmake CTestTestfile.cmake" + cmake1="cmake -DENKF_MODE=GFS -DBUILD_CORELIBS=ON" + cmake2="cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_UTIL_COM=ON -DBUILD_ENKF_PREPROCESS_ARW=ON" + + job_script=q_ready+'\n'+modules+'\n' + job_script=job_script+"cd "+build_root+"/"+bld_fullname+'\n\n' + #### to build enkf_gfs.x, gsi.x + job_script=job_script+"rm -rf "+rmfiles1+' '+rmfiles2+" bin\n" #to get a clean start + job_script=job_script+cmake1+" "+ProdGSI_root+"\n" + job_script=job_script+"make -j8\n" + job_script=job_script+"make -j2\n\n" ### some build options require to do this to get enkf executables + #### to build enkf_arw.x, gsi.x and all community utilities + #job_script=job_script+"rm -rf CMakeCache.txt CMakeFiles\n" # don't remove bin/ directory at this step + job_script=job_script+"rm -rf "+rmfiles1+' '+rmfiles2+"\n" # don't remove bin/ directory at this step + job_script=job_script+cmake2+" "+ProdGSI_root+"\n" + job_script=job_script+"make -j8\n" + job_script=job_script+"make -j2\n\n" ### some build options require to do this to get enkf executables + ### link executables to get ready for case running test + job_script=job_script+"ln -sf ../bin/gsi.x run/gsi.x\n" + job_script=job_script+"ln -sf ../bin/enkf_wrf.x run/enkf_wrf.x\n" + job_script=job_script+"ln -sf ../bin/enkf_gfs.x run/enkf_gfs.x\n\n" #get ready for case running test + job_script=job_script+"touch done.compiling #Notify rocoto that compiling was done\n" + + #### create the directory and write out the compiling job script + os.system("mkdir -p "+build_root+"/"+bld_fullname) + os.system("mkdir -p "+build_root+"/"+bld_fullname+"/run") ## for case running + jobfile=build_root+"/"+bld_fullname+"/compile.sh" + fjob=open(jobfile,"w") + fjob.write(job_script) + fjob.close() + os.system("chmod +x "+jobfile) + if submit: + if rocoto_scheduler.find('slurm')>=0: + os.system("cd "+build_root+"/"+bld_fullname+"; sbatch "+jobfile) + else: + os.system("cd "+build_root+"/"+bld_fullname+"; qsub "+jobfile) + os.system("rm -f "+build_root+"/"+bld_fullname+"/done.compiling") + + #### create the case running job scripts + create_run_scripts(build_ID, modules, build_root+"/"+bld_fullname+"/run") + + #### write the build directory to a list file + flist.write(build_root+"/"+bld_fullname+"\n") +# +#---------- End of loop through build_options ---------| + +###################### generate the list file -------------- +### this list file records every build directory +flist.close() +os.system("/bin/cp list.all "+build_root) #save a copy in the build_root +if newlist: + os.system("/bin/cp list.all "+flist_name) +if submit: + print("\n\nJob scripts created and compiling jobs submitted!\n") + if newlist: print("The list file is: "+flist_name+"\n\n") +else: + print("\n\nJob scripts created! \n") + if newlist: print("The list file is: "+flist_name+"\n\n") + +#####################generate rocoto xml file -------------- +if rocoto: + GSIcases='01,02,03,04,05,07,09,10,11,21,23,25' #gge.debug + caselist=GSIcases.split(',') + sCase=''; sNum='' + for x in caselist: + for i in range(len(allcases)): + if allcases[i].find(x) >=0: + sCase=sCase+allcases[i]+' ' + sNum=sNum+"case"+x+' ' + + os.system("rm -f mpmc.db mpmc_lock.db") + file1=open('.rocoto.template', "r") + frocoto=open('mpmc.xml', 'w') + while True: + line=file1.readline() + if not line: + break + if line.startswith('\n') + elif line.startswith('\n') + elif line.startswith('\n') + elif line.startswith('\n') + elif line.startswith('\n') + elif line.startswith('\n') + elif line.startswith("\n') + elif line.startswith('\n') + elif line.startswith('\n') + elif line.startswith('\n') + elif line.startswith('\n') + elif line.startswith('\n') + elif line.find('')>=0: + if xml_set_nodesize: frocoto.write(line) + elif line.find('')>=0: + if hostname.startswith("Jet"): frocoto.write(line) + else: + frocoto.write(line) + file1.close(); frocoto.close() + + file1=open("myrocoto.ksh","w") + file1.write("#!/bin/ksh\n") + file1.write("dir="+MPMC_root+"\n") + file1.write(rocoto_exe+" -w ${dir}/mpmc.xml -d ${dir}/mpmc.db\n") + file1.close() + os.system("chmod +x myrocoto.ksh") + + ### add an entry to crontab to run myrocoto.ksh every 5 minutes + #if submit: + if True: + mpmcCron="*/5 * * * * "+MPMC_root+"/myrocoto.ksh" + ###check if there is already a line, just delete it + crontab=os.popen("crontab -l").read() + cronlist=crontab.split('\n') + f1=open('.tmp.crontab','w') + for x in cronlist: + if x.find(mpmcCron)<0 and x.find("no crontab")<0: + f1.write(x+'\n') + elif x.find(mpmcCron)>=0 and x.strip().startswith("#"): + f1.write(x+'\n') + f1.write(mpmcCron+'\n') + f1.close() + os.system('cat .tmp.crontab | crontab -') + #os.system("rm -f .tmp.crontab") + + print('Rocoto workflow files " mpmc.xml and myrocoto.ksh " generated\n') + if submit: print('An entry added into the crontab to run myrocoto.ksh every 5 minutes.\n') + print('') + + diff --git a/util/DTC/MPMC/stopcronMPMC.py b/util/DTC/MPMC/stopcronMPMC.py new file mode 100755 index 000000000..576793c85 --- /dev/null +++ b/util/DTC/MPMC/stopcronMPMC.py @@ -0,0 +1,28 @@ +#!/usr/bin/python3 +# the first line does not matter, it will be replaced by running "initmpmc" +####### This script is to remove the MPMC entry in the crontab +####### by Guoqing Ge, 2018/8/31 +# +import os +mpmcCron="*/5 * * * * "+os.getcwd()+"/myrocoto.ksh" +print(mpmcCron) +crontab=os.popen("crontab -l").read() +cronlist=crontab.split('\n') + +##this is to add a line to crontab +#k1=crontab.find(mpmcCron) +#if k1<0:os.system('(crontab -l;echo "'+mpmcCron+'") | crontab -') +#exit() + +##Now remove a line from crontab +yn=input("Are you sure to remove the above entry from the crontab? y/n>>>") +if yn=="n": exit() + +f1=open('.tmp.crontab','w') +for x in cronlist: + if x.find(mpmcCron)<0: + f1.write(x+'\n') +f1.close() +os.system('cat .tmp.crontab | crontab -') +print("Done!\n-----------Current crontab----------------") +os.system("rm -f .tmp.crontab; crontab -l") diff --git a/util/DTC/README.GSI_Docker b/util/DTC/README.GSI_Docker new file mode 100644 index 000000000..807f6038d --- /dev/null +++ b/util/DTC/README.GSI_Docker @@ -0,0 +1,151 @@ + + comgsi/docker + +A light-weighted GSI/EnKF-focused Docker Container (comgsi/docker) is available to community users. + +This is a brief guide on how to run GSI/EnKF tutorial cases using this comgsi/docker container. + +----------------------------------------------------------- +1. ** Prerequisites ** +----------------------------------------------------------- + + You must have the "docker" software installed on you computer. + Please visit https://www.docker.com on to download and install docker. + + We don't have resources to support the installation of the "docker" sofware. + Please seek helps from the Docker community on this issue. + + However, here we share some installation experiences on some platforms and hope they helps in some ways: + + (1). For MAC users, just download "docker" from its official website and install it. + You will need Administrator privildage to install docker on MAC. + + (2). For Debian/Ubuntu based Linux systems (recent releases), run the following command: + + curl -fsSL https://download.docker.com/linux/ubuntu/gpg | sudo apt-key add - + sudo add-apt-repository "deb [arch=amd64] https://download.docker.com/linux/ubuntu $(lsb_release -cs) stable" + sudo apt-get update + apt-cache policy docker-ce + sudo apt-get install -y docker-ce + + Note1: if curl is not avaialbe, use wget instead as follows: + wget https://download.docker.com/linux/ubuntu/gpg; cat gpg | apt-key add - + + Note2: You will need System Administrator priviledge to install docker. + + (3). For Windows users, it is highly remmended to install VirtualBox, and then setup an Ubuntu-based virtual machine +using VirtualBox. In this Ubuntu-based virtual machine, you can install docker following the above step (2). + + Download VirtualBox at: https://www.virtualbox.org + Download a pre-built XUbuntu virtual machine image at: https://www.osboxes.org/xubuntu/ + + Note: + -- Per our experiences, docker running inside VirtualBox has much better performance and user experiences than running +Docker on Windows directly. + -- We only tested this on Windows 10. + +----------------------------------------------------------- +2. ** Get and run comgsi/docker ** +----------------------------------------------------------- + + (1) On you computer, create a directory for running GSI/EnKF in docker, e.g: + + mkdir GSI-Docker; cd GSI-Docker + + Be sure you have enough free space in this directory (10GB is preferred) + + (2) Obtain the comgsi/docker image: + + There are two methods to get the comgsi/docker image: + a. run the command "docker pull comgsi/docker" + docker will download comgsi/docker from hub.docker.com automatically. + The comgsi/docker container is 695MB in size. + If you download speed from hub.docker.com is too slow, consider the method b + + b. download comgsi_docker.tar.gz (262MB) from DTC website + then "gunzip comgsi_docker.tar.gz" + and then "docker load -i comgsi_docker.tar" + + (3) start the comgsi/docker: + + First, run the following command to generate a run script "rungsidocker": + + echo 'docker run -h GSI_Docker -v "$(pwd)":/tutorial -ti --rm comgsi/docker' > rungsidocker; chmod +x rungsidocker + + Now, you can just type "./rungsidocker" to start the comgsi/docker each time + + (4) Once the comgsi/docker is started sucessfully, you will be in the docker and see outputs similar as: + + comgsi@GSI_Docker:/tutorial$ + + NOTE1: This /tutorail is a mapping of the directory under your host system where you execute the "rungsidocker" command. + This mapping enables you to access files inside docker from your host system and your works will not disappear + after you exit the docker. + + NOTE2: Three directories build/ case_data/ run/ will be created automatically under /tutorial. + + (5) Lauch more shells of comgsi/docker: + This step is not required, but very helpful if you want to open two or more shells of comgsi/docker. + + -- open a new shell window in your host system (NOT in docker), type "docker ps". This lists all running containers. + You will get outputs similar as follows: + + CONTAINER ID IMAGE COMMAND CREATED STATUS PORTS NAMES +f278376baef3 comgsi/docker "/bin/bash" 12 minutes ago Up 12 minutes suspicious_snyder + + -- Now you know that the comgsi/docker container ID is: f278376baef3, type: + + docker exec -it f278376baef3 bash + + and you are now in a new shell of comgsi/docker + +----------------------------------------------------------- +3. ** run GSI/EnKF in comgsi/docker ** +----------------------------------------------------------- + + All the following steps are done in the shell of the comgsi/docker container. + + (1) Download the GSI/EnKF release tarball from the DTC website and move it to the directory created in step 2.1: + + (2) In the docker, at the /tutorial directory, you should be able to "ls comGSIv3.7_EnKFv1.3.tar.gz" now + + tar xvfz comGSIv3.7_EnKFv1.3.tar.gz + + (2) Compile GSI/EnKF + + cd build + cmake ../comGSIv3.7_EnKFv1.3 + make + +Depends on your host computer, it takes up to 10~20 minutes to complete the compiling. + +If you don't want to compile from source codes, you can skip step (2) and download pre-compiled +executables from DTC website: + + wget http://dtcenter.org/com-GSI/MPMC/precompiled.tar.gz + tar xvfz precompiled.tar.gz + + (3) Link executables into run/ + + cd ../run + ln -sf ../build/bin/gsi.x . + ln -sf ../build/bin/enkf_wrf.x . + + (4) Now you can run all tutorial cases under the run/ directory following instructions on the DTC website + NOTE1: You can download all case data into /tutorial/case_data directory + NOTE2: On the comgsi/docker, you can run executables in MPI mode if it is assigned multiple cores + e.g.: mpirun -n 2 run.case03-conv.ksh + + +For any questions, contact us at gsi-help@ucar.edu. + + + by Guoqing Ge, 2018/9/20 + + + + + + + + diff --git a/util/DTC/README.comgsi b/util/DTC/README.comgsi new file mode 100644 index 000000000..1cd1ae1c5 --- /dev/null +++ b/util/DTC/README.comgsi @@ -0,0 +1,112 @@ + + Community GSIv3.7_EnKFv1.3 + +Supported Compilers: + +GNU: 8.1.0 7.3.0 7.1.0 6.3.0 +PGI: 18.5 18.3 18.1 17.10 17.9 17.7 17.1 16.10 16.9 16.7 16.5 +INTEL: 18.1.163 18.0.3.222 18.0.1.163 18.0.1 18.0.0.128 17.0.5.239 17.0.1 16.1.150 + 16.0.3 16.0.1 16.0.1.150 15.6.233 15.3.187 15.1.133 15.0.3.187 14.0.2 + +----------------------------------------------------------- +1. ** How to compile comGSIv3.7_EnKFv1.3 ? ** +----------------------------------------------------------- + +NOTE: WRF I/O interface is self-included in this release as a library. + Users no longer need to compile WRF separately. + +(1). Determine the directory to do compiling. This directory can be either inside +or outside the comGSIv3.7_EnKFv1.3 directory. +The following is an example to do compiling inside comGSIv3.7_EnKFv1.3: + + $ mkdir build; cd build + +(2). Run CMake using "cmake path_to_GSI" + If the build/ directory is inisde comGSIv3.7_EnKFv1.3, you can just do: + + $ cmake ../ + +If CMake succeeds, a "Makefile" will present at current directory. + +(3). Run make + + $ make +or + $ make -jn (n is how many processes you want to use, such as 2, 4, 6, 8, etc) + +If make succeeds, executables will present at the bin/ directory. + +@NOTE: It is suggested to do cmake in a fresh start each time. + Remove ./build and start from an empty build directory. + This will solve lots of cmake and compiling errros. + +----------------------------------------------------------- +2. ** How to compile global EnKF (enkf_gfs.x) ? ** +----------------------------------------------------------- + +By default, the above compiling will generate regional EnKF executable (enkf_wrf.x). +If you want to get global EnKF (enkf_gfs.x), do the following in the build directory: + + rm -rf CMake* + cmake -DENKF_MODE=GFS .. + make (or make -jn) as in step 1.3 + +----------------------------------------------------------- +3. ** How to compile GSI with cloud analysis library? ** +----------------------------------------------------------- + + GSD cloud analysis library only applies to regional GSI. + In step 1.2, use the following command instead: + cmake -DBUILD_GSDCLOUD_ARW=ON .. + +----------------------------------------------------------- +4. ** How to compile GSI/EnKF utilities ? ** +----------------------------------------------------------- + +(1). cmake -DBUILD_UTIL_COM path_to_GSI +(2). make (or make -jn) as in step 1.3 + +----------------------------------------------------------- +5. ** How to get more descriptive output in compiling? ** +----------------------------------------------------------- + + use "make VERBOSE=1" instead of "make" in the above steps. + +----------------------------------------------------------- +6. ** How to run comGSIv3.7_EnKFv1.3 ? ** +----------------------------------------------------------- + + It is always recommended to run DTC online tutorial cases first to make sure + everything is correct before doing your own experiments. + + comGSI/EnKF user guides provide detailed instruciton on how to run comGSI/EnKF. + +----------------------------------------------------------- +7. ** How to get helps from the GSI/EnKF help desk ? ** +----------------------------------------------------------- + +(1). Make sure you are a registerd GSI user. We are only allowed to support +registered users. + Register at: https://dtcenter.org/com-GSI/users/downloads/index.php + +(2). If your question involves runtime problems such as crash etc, be sure +to use the utility "gsienvreport.sh" to generate a report as follows: + + $ PATH_TO_GSI/util/gsienvreport.sh > report.txt + +Send us report.txt along with stdout, run_script. + +(3). One issue per ticket. Submit a new ticket for each issue. + +(4). Use a descriptive email title, + Explain your problem in detail as much as possible +to help us understand your sitatuion + +For more help desk tips, you may visit + https://dtcenter.org/com-GSI/users/docs/helpdesktips.pdf + + + gsi-help@ucar.edu + enkf-help@ucar.edu + + diff --git a/util/EnKF/arw/run/anavinfo b/util/EnKF/arw/run/anavinfo new file mode 100644 index 000000000..634f55676 --- /dev/null +++ b/util/EnKF/arw/run/anavinfo @@ -0,0 +1,77 @@ +met_guess:: +!var level crtm_use desc orig_name + ps 1 -1 surface_pressure ps + z 1 -1 geopotential_height phis + u 50 2 zonal_wind u + v 50 2 meridional_wind v + div 50 -1 zonal_wind div + vor 50 -1 meridional_wind vor + tv 50 2 virtual_temperature tv + q 50 2 specific_humidity sphu + oz 50 2 ozone ozone + cw 50 10 cloud_condensate cw + ql 50 10 cloud_liquid ql + qi 50 10 cloud_ice qi + qr 50 10 rain qr + qs 50 10 snow qs + qg 50 10 graupel qg + qnr 50 10 rain_noconc qnr + th2m 1 -1 2-m_T th2m + q2m 1 -1 2-m_Q q2m + tskn 1 -1 skin_T tskn + tsoil 1 -1 soil_T tsoil + smoist 9 -1 soilmoist smoist + tslb 9 -1 soilt tslb +:: + +state_derivatives:: +!var level src + ps 1 met_guess + u 50 met_guess + v 50 met_guess + tv 50 met_guess + q 50 met_guess + oz 50 met_guess + cw 50 met_guess + prse 51 met_guess +:: + +state_tendencies:: +!var levels source + u 50 met_guess + v 50 met_guess + tv 50 met_guess + q 50 met_guess + cw 50 met_guess + oz 50 met_guess + prse 51 met_guess +:: + +state_vector:: +!var level itracer source funcof + u 50 0 met_guess u + v 50 0 met_guess v + tv 50 0 met_guess tv + tsen 50 0 met_guess tv,q + q 50 1 met_guess q + oz 50 1 met_guess oz + cw 50 1 met_guess cw + prse 51 0 met_guess prse + ps 1 0 met_guess prse + sst 1 0 met_guess sst +:: + +control_vector:: +!var level itracer as/tsfc_sdv an_amp0 source funcof + sf 50 0 1.00 -1.0 state u,v + vp 50 0 1.00 -1.0 state u,v + ps 1 0 0.50 -1.0 state prse + t 50 0 0.70 -1.0 state tv + q 50 1 0.70 -1.0 state q + oz 50 1 0.50 -1.0 state oz + sst 1 0 1.00 -1.0 state sst + cw 50 1 1.00 -1.0 state cw + stl 1 0 1.00 -1.0 motley sst + sti 1 0 1.00 -1.0 motley sst +:: + diff --git a/util/EnKF/arw/run/namelist.input b/util/EnKF/arw/run/namelist.input new file mode 100644 index 000000000..cd2c4cf20 --- /dev/null +++ b/util/EnKF/arw/run/namelist.input @@ -0,0 +1,17 @@ + &SETUP + regional=.true. , + wrf_mass_regional=.true. , + diagnostic_reg=.true. , + switch_on_derivatives=.false. , + tendsflag=.false. , + nfldsig=1 , + grid_ratio_ens=1, + n_ens=80, + grid_ratio_ens = 1, + grid_ratio_wrfmass=1, + use_gfs_nemsio=.true., + jcap_ens=574, + enpert4arw=.true., + wrt_pert_sub=.false., + wrt_pert_mem=.false., + / diff --git a/util/EnKF/arw/run/run_init.ksh b/util/EnKF/arw/run/run_init.ksh new file mode 100755 index 000000000..addd61986 --- /dev/null +++ b/util/EnKF/arw/run/run_init.ksh @@ -0,0 +1,26 @@ +#!/bin/ksh +set -x + +cd /mnt/lfs3/projects/rtwbl/mhu/GSI_r1181/util/EnKF/enspreproc_regional.fd/run + +# Loop through each member + no_member=17 + ensmem=1 + while [[ $ensmem -le $no_member ]];do + + print "\$ensmem is $ensmem" + ensmemid=`printf %4.4i $ensmem` + +# get background for each member + cp wrf_inout wrfinput_d01.mem${ensmemid} + +# next member + (( ensmem += 1 )) + + done + +cp /mnt/lfs3/projects/rtwbl/mhu/GSI_r1181/util/EnKF/initialens_regional.fd/initialens.x . + +./initialens.x ${no_member} + +exit 0 diff --git a/util/EnKF/arw/run/run_pro.ksh b/util/EnKF/arw/run/run_pro.ksh new file mode 100755 index 000000000..9476882e5 --- /dev/null +++ b/util/EnKF/arw/run/run_pro.ksh @@ -0,0 +1,26 @@ +#!/bin/ksh --login + +# Set the queueing options +#PBS -l procs=120 +#PBS -l walltime=0:30:00 +#PBS -A rtwbl +#PBS -q debug +#PBS -N wrf_gsi +#PBS -l partition=tjet +#PBS -j oe + +set -x +np=$PBS_NP + +# Load modules +module load intel +module load mvapich2 +module load netcdf + +set -x + +cd /mnt/lfs3/projects/rtwbl/mhu/GSI_r1181/util/EnKF/enspreproc_regional.fd/run + +/usr/bin/time mpiexec -envall -np ${np} /mnt/lfs3/projects/rtwbl/mhu/GSI_r1181/util/EnKF/enspreproc_regional.fd/enspreproc.x + +exit 0 diff --git a/util/EnKF/arw/run/save_hrrre_perts.ksh b/util/EnKF/arw/run/save_hrrre_perts.ksh new file mode 100755 index 000000000..1932588cb --- /dev/null +++ b/util/EnKF/arw/run/save_hrrre_perts.ksh @@ -0,0 +1,73 @@ +#!/bin/ksh + +# set -x + +HRRRE_ORGPATH=/mnt/lfs1/projects/wrfruc/HRRRE/forecast +SAVEPATH=/mnt/lfs1/projects/rtwbl/mhu/test/gsi/hrrre/data +workdir=/mnt/lfs1/projects/rtwbl/mhu/test/gsi/hrrre/saveperts/work +execfile=/mnt/lfs1/projects/rtwbl/mhu/test/gsi/hrrre/saveperts/save_arw_ens.x + +if [ ! -d "${workdir}" ]; then + mkdir -p ${workdir} + echo ' create work directory ', ${workdir} + cd ${workdir} +else + cd ${workdir} +# rm filelist03* +# rm namelist_enspert* +# rm wrfout_d01_const +# rm fort.* + rm * +fi + +currentdate=`date -u +"%Y%m%d %H"` +starttime=`date -u +"%Y%m%d 00" -d "${currentdate}"` +YYYYMMDD00=`date -u +"%Y%m%d%H" -d "${starttime}"` + +ln -s ${SAVEPATH}/wrfout_d02_2018-07-17_09_00_00 wrfout_d01_const +cp ${execfile} . + +no_member=9 +fcsthh=12 +while [[ $fcsthh -le 36 ]];do + + time_str=`date "+%Y-%m-%d_%H_%M_%S" -d "${starttime} ${fcsthh} hours"` + + ensmem=1 + while [[ $ensmem -le $no_member ]];do + ensmemid=`printf %4.4i $ensmem` + filenow=${HRRRE_ORGPATH}/${YYYYMMDD00}/wrfprd_mem${ensmemid}/wrfout_d02_${time_str} + echo ${filenow} >> filelist03 + filenow=${HRRRE_ORGPATH}/${YYYYMMDD00}/postprd_mem${ensmemid}/wrfnat_mem${ensmemid}_${fcsthh}.grib2 + echo ${filenow} >> filelist03_grib2 + +# next member + (( ensmem += 1 )) + + done + +# got namelist ready +cat << EOF > namelist_enspert +&SETUP + n_ens=9, + initialtime=${YYYYMMDD00}, + fcsthh=${fcsthh}, +/ +EOF +# +# run + ./save_arw_ens.x > runlog_${YYYYMMDD00}f${fcsthh} 2>&1 + +# save those configure files + mv namelist_enspert namelist_enspert_${YYYYMMDD00}f${fcsthh} + mv filelist03 filelist03_${YYYYMMDD00}f${fcsthh} + mv filelist03_grib2 filelist03_grib2_${YYYYMMDD00}f${fcsthh} + + mv enspert_${YYYYMMDD00}* ${SAVEPATH}/. + mv ensmean_${YYYYMMDD00}* ${SAVEPATH}/. + rm fort.9* +# next ensemble forecast + (( fcsthh += 3 )) +done + +exit diff --git a/util/EnKF/arw/src/CMakeLists.txt b/util/EnKF/arw/src/CMakeLists.txt new file mode 100644 index 000000000..5fbc72f9a --- /dev/null +++ b/util/EnKF/arw/src/CMakeLists.txt @@ -0,0 +1,8 @@ +cmake_minimum_required(VERSION 2.6) + + set(CMAKE_Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/util/include") + set(UTIL_INC ${CMAKE_Fortran_MODULE_DIRECTORY}) + + add_subdirectory(enspreproc_regional.fd) + add_subdirectory(initialens_regional.fd) + diff --git a/util/EnKF/arw/src/enspreproc_arw/general_read_wrf_mass.f90 b/util/EnKF/arw/src/enspreproc_arw/general_read_wrf_mass.f90 new file mode 100644 index 000000000..6a08cb33b --- /dev/null +++ b/util/EnKF/arw/src/enspreproc_arw/general_read_wrf_mass.f90 @@ -0,0 +1,841 @@ +module general_read_wrf_mass +! +! +! + use kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one + + implicit none + + public general_read_wrf_mass_save + public general_read_wrf_mass_dim_eta + public cal_ensperts + + private + + integer :: nlat,nlon,nsig + real(r_kind),allocatable:: eta1_ll(:) ! + real(r_kind),allocatable:: aeta1_ll(:) ! + real(r_kind),allocatable:: eta2_ll(:) ! + real(r_kind),allocatable:: aeta2_ll(:) ! + real(r_kind) pt_ll + +contains + + subroutine general_read_wrf_mass_save(filename,q_hyb_ens,nnn) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: general_read_wrf_mass read arw model ensemble members + ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 + ! + ! abstract: read ensemble members from the arw model in "wrfout" netcdf format + ! for use with hybrid ensemble option. + ! + ! program history log: + ! 2010-08-11 parrish, initial documentation + ! 2010-09-10 parrish, modify so ensemble variables are read in the same way as in + ! subroutines convert_netcdf_mass and read_wrf_mass_binary_guess. + ! There were substantial differences due to different opinion about what + ! to use for surface pressure. This issue should be resolved by coordinating + ! with Ming Hu (ming.hu@noaa.gov). At the moment, these changes result in + ! agreement to single precision between this input method and the guess input + ! procedure when the same file is read by both methods. + ! 2012-03-12 whitaker: read data on root, distribute with scatterv. + ! remove call to general_reload. + ! simplify, fix memory leaks, reduce memory footprint. + ! use genqsat, remove genqsat2_regional. + ! replace bare 'stop' statements with call stop2(999). + ! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS core + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + + use netcdf, only: nf90_nowrite + use netcdf, only: nf90_open,nf90_close + use netcdf, only: nf90_inq_dimid,nf90_inquire_dimension + use netcdf, only: nf90_inq_varid,nf90_inquire_variable,nf90_get_var + use kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one,fv,zero_single,rd_over_cp_mass,one_tenth,h300 + use netcdf_mod, only: nc_check + + implicit none + ! + ! Declare passed variables + ! class(get_wrf_mass_ensperts_class), intent(inout) :: this + character(255),intent(in):: filename + logical, intent(in) :: q_hyb_ens + integer, intent(in) :: nnn + ! + ! Declare local parameters + real(r_kind),parameter:: r0_01 = 0.01_r_kind + real(r_kind),parameter:: r10 = 10.0_r_kind + real(r_kind),parameter:: r100 = 100.0_r_kind + ! + ! Declare local variables + real(r_single),allocatable,dimension(:):: temp_1d + real(r_single),allocatable,dimension(:,:):: temp_2d,temp_2d2 + real(r_single),allocatable,dimension(:,:,:):: temp_3d + real(r_kind),allocatable,dimension(:):: p_top + real(r_kind),allocatable,dimension(:,:):: q_integral,gg_ps,q_integralc4h + real(r_kind),allocatable,dimension(:,:,:):: tsn,qst,prsl,& + gg_u,gg_v,gg_tv,gg_rh + real(r_kind),allocatable,dimension(:):: wrk_fill_2d + integer(i_kind),allocatable,dimension(:):: dim,dim_id + + integer(i_kind):: nx,ny,nz,i,j,k,d_max,file_id,var_id,ndim,mype + integer(i_kind):: Time_id,s_n_id,w_e_id,b_t_id,s_n_stag_id,w_e_stag_id,b_t_stag_id + integer(i_kind):: Time_len,s_n_len,w_e_len,b_t_len,s_n_stag_len,w_e_stag_len,b_t_stag_len + integer(i_kind) iderivative + + real(r_kind):: deltasigma + real(r_kind) psfc_this_dry,psfc_this + real(r_kind) work_prslk,work_prsl + + logical :: ice + + character(len=24),parameter :: myname_ = 'general_read_wrf_mass' + + ! + ! OPEN ENSEMBLE MEMBER DATA FILE + if (mype==0) then ! only read data on root proc + allocate(gg_u(nlat,nlon,nsig)) + allocate(gg_v(nlat,nlon,nsig)) + allocate(gg_tv(nlat,nlon,nsig)) + allocate(gg_rh(nlat,nlon,nsig)) + allocate(gg_ps(nlat,nlon)) + call nc_check( nf90_open(trim(filename),nf90_nowrite,file_id),& + myname_,'open '//trim(filename) ) + ! + ! WRF FILE DIMENSIONS + call nc_check( nf90_inq_dimid(file_id,'Time',Time_id),& + myname_,'inq_dimid Time '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'south_north',s_n_id),& + myname_,'inq_dimid south_north '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'west_east',w_e_id),& + myname_,'inq_dimid west_east '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'bottom_top',b_t_id),& + myname_,'inq_dimid bottom_top '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'south_north_stag',s_n_stag_id),& + myname_,'inq_dimid south_north_stag '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'west_east_stag',w_e_stag_id),& + myname_,'inq_dimid west_east_stag '//trim(filename) ) + call nc_check( nf90_inq_dimid(file_id,'bottom_top_stag',b_t_stag_id),& + myname_,'inq_dimid bottom_top_stag '//trim(filename) ) + + d_max=max(Time_id, s_n_id, w_e_id, b_t_id, s_n_stag_id, w_e_stag_id, b_t_stag_id) + allocate(dim(d_max)) + dim(:)=-999 + + call nc_check( nf90_inquire_dimension(file_id,Time_id,len=Time_len),& + myname_,'inquire_dimension Time '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,s_n_id,len=s_n_len),& + myname_,'inquire_dimension south_north '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,w_e_id,len=w_e_len),& + myname_,'inquire_dimension west_east '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,b_t_id,len=b_t_len),& + myname_,'inquire_dimension bottom_top '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,s_n_stag_id,len=s_n_stag_len),& + myname_,'inquire_dimension south_north_stag '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,w_e_stag_id,len=w_e_stag_len),& + myname_,'inquire_dimension west_east_stag '//trim(filename) ) + call nc_check( nf90_inquire_dimension(file_id,b_t_stag_id,len=b_t_stag_len),& + myname_,'inquire_dimension bottom_top_stag '//trim(filename) ) + + nx=w_e_len + ny=s_n_len + nz=b_t_len + if (nx /= nlon .or. ny /= nlat .or. nz /= nsig) then + print *,'incorrect grid size in netcdf file' + print *,'nx,ny,nz,nlon,nlat,nsig',nx,ny,nz,nlon,nlat,nsig + call stop2(999) + endif + + dim(Time_id)=Time_len + dim(s_n_id)=s_n_len + dim(w_e_id)=w_e_len + dim(b_t_id)=b_t_len + dim(s_n_stag_id)=s_n_stag_len + dim(w_e_stag_id)=w_e_stag_len + dim(b_t_stag_id)=b_t_stag_len + ! + ! READ PERTURBATION POTENTIAL TEMPERATURE (K) + ! print *, 'read T ',filename + call nc_check( nf90_inq_varid(file_id,'T',var_id),& + myname_,'inq_varid T '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable T '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable T '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var T '//trim(filename) ) + allocate(tsn(dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3)))) + tsn = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id) + + ! READ MU, MUB, P_TOP (construct psfc as done in gsi--gives different result compared to PSFC) + + call nc_check( nf90_inq_varid(file_id,'P_TOP',var_id),& + myname_,'inq_varid P_TOP '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable P_TOP '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable P_TOP '//trim(filename) ) + allocate(temp_1d(dim(dim_id(1)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_1d),& + myname_,'get_var P_TOP '//trim(filename) ) + allocate(p_top(dim(dim_id(1)))) + do i=1,dim(dim_id(1)) + p_top(i)=temp_1d(i) + enddo + deallocate(dim_id) + + call nc_check( nf90_inq_varid(file_id,'MUB',var_id),& + myname_,'inq_varid MUB '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable MUB '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable MUB '//trim(filename) ) + allocate(temp_2d(dim(dim_id(1)),dim(dim_id(2)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_2d),& + myname_,'get_var MUB '//trim(filename) ) + deallocate(dim_id) + + call nc_check( nf90_inq_varid(file_id,'MU',var_id),& + myname_,'inq_varid MU '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable MU '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable MU '//trim(filename) ) + allocate(temp_2d2(dim(dim_id(1)),dim(dim_id(2)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_2d2),& + myname_,'get_var MU '//trim(filename) ) + + do j=1,dim(dim_id(2)) + do i=1,dim(dim_id(1)) + temp_2d2(i,j)=temp_2d(i,j)+temp_2d2(i,j)+temp_1d(1) + gg_ps(j,i)=temp_2d2(i,j) + enddo + enddo + print *,'min/max ps',minval(gg_ps),maxval(gg_ps) + deallocate(temp_2d,temp_2d2,temp_1d,dim_id) + + ! + ! READ U (m/s) + !print *, 'read U ',filename + call nc_check( nf90_inq_varid(file_id,'U',var_id),& + myname_,'inq_varid U '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable U '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable U '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var U '//trim(filename) ) + ! + ! INTERPOLATE TO MASS GRID + do k=1,dim(dim_id(3)) + do j=1,dim(dim_id(2)) + do i=1,dim(dim_id(1))-1 + gg_u(j,i,k)=.5*(temp_3d(i,j,k)+temp_3d(i+1,j,k)) + enddo + enddo + enddo + deallocate(temp_3d) + deallocate(dim_id) + ! + ! READ V (m/s) + !print *, 'read V ',filename + call nc_check( nf90_inq_varid(file_id,'V',var_id),& + myname_,'inq_varid V '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable V '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable V '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var V '//trim(filename) ) + ! + ! INTERPOLATE TO MASS GRID + do k=1,dim(dim_id(3)) + do j=1,dim(dim_id(2))-1 + do i=1,dim(dim_id(1)) + gg_v(j,i,k)=.5*(temp_3d(i,j,k)+temp_3d(i,j+1,k)) + enddo + enddo + enddo + deallocate(temp_3d) + deallocate(dim_id) + print *,'min/max u',minval(gg_u),maxval(gg_u) + print *,'min/max v',minval(gg_v),maxval(gg_v) + ! + ! READ QVAPOR (kg/kg) + !print *, 'read QVAPOR ',filename + call nc_check( nf90_inq_varid(file_id,'QVAPOR',var_id),& + myname_,'inq_varid QVAPOR '//trim(filename) ) + + call nc_check( nf90_inquire_variable(file_id,var_id,ndims=ndim),& + myname_,'inquire_variable QVAPOR '//trim(filename) ) + allocate(dim_id(ndim)) + + call nc_check( nf90_inquire_variable(file_id,var_id,dimids=dim_id),& + myname_,'inquire_variable QVAPOR '//trim(filename) ) + allocate(temp_3d(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + + call nc_check( nf90_get_var(file_id,var_id,temp_3d),& + myname_,'get_var QVAPOR '//trim(filename) ) + gg_rh = reshape(temp_3d,(/dim(dim_id(2)),dim(dim_id(1)),dim(dim_id(3))/),order=(/2,1,3/)) + deallocate(temp_3d) + deallocate(dim_id,dim) + + call nc_check( nf90_close(file_id),& + myname_,'close '//trim(filename) ) + ! + ! CALCULATE TOTAL POTENTIAL TEMPERATURE (K) + !print *, 'calculate total temperature ',filename + do i=1,nx + do j=1,ny + do k=1,nz + tsn(j,i,k)=tsn(j,i,k)+h300 + enddo + enddo + enddo + ! + ! INTEGRATE {1 + WATER VAPOR} TO CONVERT DRY AIR PRESSURE + !print *, 'integrate 1 + q vertically ',filename + allocate(q_integral(ny,nx)) + allocate(q_integralc4h(ny,nx)) + q_integral(:,:)=one + q_integralc4h=0.0_r_single + do i=1,nx + do j=1,ny + do k=1,nz + deltasigma=eta1_ll(k)-eta1_ll(k+1) + q_integral(j,i)=q_integral(j,i)+deltasigma*gg_rh(j,i,k) + q_integralc4h(j,i)=q_integralc4h(j,i)+(eta2_ll(k)-eta2_ll(k+1))*gg_rh(j,i,k) + enddo + enddo + enddo + ! + ! CONVERT WATER VAPOR MIXING RATIO TO SPECIFIC HUMIDITY + do i=1,nx + do j=1,ny + do k=1,nz + gg_rh(j,i,k)=gg_rh(j,i,k)/(one+gg_rh(j,i,k)) + enddo + enddo + enddo + + ! obtaining psfc as done in subroutine read_wrf_mass_netcdf_guess + do i=1,nx + do j=1,ny + psfc_this_dry=r0_01*gg_ps(j,i) + psfc_this=(psfc_this_dry-pt_ll)*q_integral(j,i)+pt_ll+q_integralc4h(j,i) + gg_ps(j,i)=one_tenth*psfc_this ! convert from mb to cb + end do + end do + ! + ! CONVERT POTENTIAL TEMPERATURE TO VIRTUAL TEMPERATURE + !print *, 'convert potential temp to virtual temp ',filename + allocate(prsl(ny,nx,nz)) + do k=1,nz + do i=1,nx + do j=1,ny + work_prsl = one_tenth*(aeta1_ll(k)*(r10*gg_ps(j,i)-pt_ll)+& + aeta2_ll(k) + pt_ll) + prsl(j,i,k)=work_prsl + work_prslk = (work_prsl/r100)**rd_over_cp_mass + ! sensible temp from pot temp + tsn(j,i,k) = tsn(j,i,k)*work_prslk + ! virtual temp from sensible temp + gg_tv(j,i,k) = tsn(j,i,k) * (one+fv*gg_rh(j,i,k)) + ! recompute sensible temp from virtual temp + tsn(j,i,k)= gg_tv(j,i,k)/(one+fv*max(zero,gg_rh(j,i,k))) + end do + end do + end do + print *,'min/max tv',minval(gg_tv),maxval(gg_tv) + + ! + ! CALCULATE PSEUDO RELATIVE HUMIDITY IF USING RH VARIABLE + if (.not.q_hyb_ens) then + allocate(qst(ny,nx,nz)) + ice=.true. + iderivative=0 + call genqsat(qst,tsn,prsl,ny,nx,nsig,ice,iderivative) + do k=1,nz + do i=1,nx + do j=1,ny + gg_rh(j,i,k)=gg_rh(j,i,k)/qst(j,i,k) + enddo + enddo + enddo + print *,'min/max rh',minval(gg_rh),maxval(gg_rh) + deallocate(qst) + else + print *,'min/max q',minval(gg_rh),maxval(gg_rh) + end if + + ! DEALLOCATE REMAINING TEMPORARY STORAGE + deallocate(tsn,prsl,q_integral,p_top) + + ! save the global grid results + write(900+nnn) nx,ny,nz + write(900+nnn) gg_ps + write(900+nnn) gg_tv + write(900+nnn) gg_u + write(900+nnn) gg_v + write(900+nnn) gg_rh + + endif ! done netcdf read on root + +! g_oz = 0.; g_cwmr = 0. + if (mype==0) deallocate(gg_u,gg_v,gg_tv,gg_rh,gg_ps) + + return + end subroutine general_read_wrf_mass_save + + + subroutine general_read_wrf_mass_dim_eta(filename) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: general_read_wrf_mass read arw model ensemble members + ! prgmmr: Hu org: GSD date: 2018-07-10 + ! + ! abstract: read hybrid vertical coodinate in WRF MASS core + ! + ! program history log: + ! 2018-07-10 Hu - add code to use hybrid vertical coodinate in WRF MASS core + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + + use kinds, only: r_kind,r_single,i_kind + + implicit none + ! + ! Declare passed variables + character(255),intent(in):: filename + ! + ! Declare local parameters + real(r_kind),parameter:: r0_01 = 0.01_r_kind + ! +! variables for NETCDF IO + real(r_single) pt_regional + real(r_single),allocatable::field1(:) + real(r_single),allocatable::field1a(:) +! +! variables for NETCDF IO + character(len=19) :: DateStr1 + integer(i_kind) :: dh1 + integer(i_kind) :: ndim1 + integer(i_kind) :: WrfType + integer(i_kind), dimension(4) :: start_index, end_index + character (len= 4) :: staggering=' N/A' + character (len= 3) :: ordering + + character (len=80), dimension(3) :: dimnames + character (len=80) :: SysDepInfo + character (len=31) :: rmse_var + + integer :: wrf_real +! + integer :: Status,Status_next_time,ierr + integer :: iyear,imonth,iday,ihour,iminute,isecond + logical :: print_verbose,wrf_mass_hybridcord +! + integer :: mype, k +! +! + print_verbose=.true. + wrf_real=104 + end_index=0 + start_index=0 + wrf_mass_hybridcord=.false. + mype=0 + ! + if (mype==0) then ! only read data on root proc + call ext_ncd_ioinit(sysdepinfo,status) + + call ext_ncd_open_for_read( trim(filename), 0, 0, "", dh1, Status) + + call ext_ncd_get_next_time(dh1, DateStr1, Status_next_time) + write(*,*) DateStr1 + write(*,*) trim(filename) + read(DateStr1,'(i4,1x,i2,1x,i2,1x,i2,1x,i2,1x,i2)') & + iyear,imonth,iday,ihour,iminute,isecond + write(6,*)' iy,m,d,h,m,s=',iyear,imonth,iday,ihour,iminute,isecond + + rmse_var='T' + + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering,& + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1 = ',ndim1,' dh1 =',dh1 + write(6,*)' WrfType = ',WrfType,'ierr = ',ierr + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + end if + + nlon=end_index(1) + nlat=end_index(2) + nsig=end_index(3) + if(print_verbose)write(6,*)'nlon,nlat,nsig=',nlon,nlat,nsig + allocate(field1(nsig)) + allocate(field1a(nsig+1)) + + rmse_var='P_TOP' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering,& + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + end if + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + pt_regional,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + if(print_verbose)write(6,*)' p_top=',pt_regional + pt_ll=r0_01*pt_regional + + allocate(aeta1_ll(nsig),eta1_ll(nsig+1)) + allocate(aeta2_ll(nsig),eta2_ll(nsig+1)) + + if(wrf_mass_hybridcord) then + rmse_var='C3H' + call ext_ncd_get_var_info(dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr =',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + end if + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + if(print_verbose)then + do k=1,nsig + write(6,*)' k,c3h(k)=',k,field1(k) + end do + end if + rmse_var='C4H' + call ext_ncd_get_var_info(dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr =',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + end if + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1a,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + if(print_verbose)then + do k=1,nsig + write(6,*)' k,c4h(k)=',k,field1a(k) + end do + end if + aeta1_ll=field1(1:nsig) !c3h + aeta2_ll=field1a(1:nsig)*r0_01 ! c4h + + rmse_var='C3F' + call ext_ncd_get_var_info(dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr =',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + end if + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + if(print_verbose)then + do k=1,nsig+1 + write(6,*)' k,c3f(k)=',k,field1(k) + end do + end if + rmse_var='C4F' + call ext_ncd_get_var_info(dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr =',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + end if + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1a,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + if(print_verbose)then + do k=1,nsig+1 + write(6,*)' k,c4f(k)=',k,field1a(k) + end do + end if + eta1_ll=field1(1:nsig+1) !c3f + eta2_ll=field1a(1:nsig+1)*r0_01 !c4f + else + + rmse_var='ZNU' + call ext_ncd_get_var_info(dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr =',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + end if + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + if(print_verbose)then + do k=1,nsig + write(6,*)' k,znu(k)=',k,field1(k) + end do + end if + aeta1_ll=field1 + aeta2_ll=0.0_r_kind + + rmse_var='ZNW' + call ext_ncd_get_var_info(dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + if(print_verbose)then + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr =',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + end if + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1a,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + if(print_verbose)then + do k=1,nsig+1 + write(6,*)' k,znw(k)=',k,field1a(k) + end do + end if + eta1_ll=field1a + eta2_ll=0.0_r_kind + endif + + deallocate(field1,field1a) + call ext_ncd_ioclose(dh1, Status) + endif + + end subroutine general_read_wrf_mass_dim_eta + + subroutine cal_ensperts(n_ens,initialtime,fcsthh) + + implicit none + integer, intent(in) :: n_ens + integer, intent(in) :: initialtime,fcsthh + + real(r_kind),allocatable,dimension(:,:,:) :: gg_tv_bar,gg_u_bar,gg_v_bar,gg_rh_bar + real(r_kind),allocatable,dimension(:,:) :: gg_ps_bar + integer :: ggnx,ggny,ggnz + integer :: nx,ny,nz +! + real(r_kind):: bar_norm,sig_norm +! + character(len=100) :: ensfile,perbfile + real(r_kind),allocatable :: fld3d(:,:,:),fld2d(:,:) + integer :: nnn,iunit,iunit_out +! +! +! + bar_norm = one/float(n_ens) + sig_norm=sqrt(one/max(one,n_ens-one)) +! + iunit=10 + do nnn=1,n_ens + write(ensfile,'(a,I3.3)') 'fort.',900+nnn + open(iunit,file=trim(ensfile),form='unformatted',convert='BIG_ENDIAN') + write(*,*) 'read in from file ',trim(ensfile) + + read(iunit) nx,ny,nz + if(nnn==1) then + ggnx=nx + ggny=ny + ggnz=nz + allocate(gg_u_bar(ny,nx,nz)) + allocate(gg_v_bar(ny,nx,nz)) + allocate(gg_tv_bar(ny,nx,nz)) + allocate(gg_rh_bar(ny,nx,nz)) + allocate(gg_ps_bar(ny,nx)) + gg_u_bar=zero + gg_v_bar=zero + gg_tv_bar=zero + gg_rh_bar=zero + gg_ps_bar=zero + endif + + if(nx==ggnx .and. ny==ggny .and. nz==ggnz) then + allocate(fld2d(ny,nx)) + read(iunit) fld2d ! ps + gg_ps_bar=gg_ps_bar+fld2d + deallocate(fld2d) + + allocate(fld3d(ny,nx,nz)) + read(iunit) fld3d ! tv + gg_tv_bar=gg_tv_bar+fld3d + read(iunit) fld3d ! u + gg_u_bar=gg_u_bar+fld3d + read(iunit) fld3d ! v + gg_v_bar=gg_v_bar+fld3d + read(iunit) fld3d ! rh + gg_rh_bar=gg_rh_bar+fld3d + deallocate(fld3d) + else + write(*,*) 'mismatch dimensions' + stop 123 + endif + close(iunit) + enddo ! nnn + +! CALCULATE ENSEMBLE MEAN + gg_ps_bar=gg_ps_bar*bar_norm + gg_tv_bar=gg_tv_bar*bar_norm + gg_u_bar=gg_u_bar*bar_norm + gg_v_bar=gg_v_bar*bar_norm + gg_rh_bar=gg_rh_bar*bar_norm +!save ensemble mean + write(perbfile,'(a,I10,a,I3.3)') 'ensmean_',initialtime,'f',fcsthh + open (iunit,file=trim(perbfile),form='unformatted',convert='BIG_ENDIAN') + write(iunit) nx,ny,nz + write(iunit) gg_ps_bar + write(iunit) gg_tv_bar + write(iunit) gg_u_bar + write(iunit) gg_v_bar + write(iunit) gg_rh_bar + close(iunit) + + write(*,*) nx,ny,nz + write(*,*) maxval(gg_ps_bar),minval(gg_ps_bar) + write(*,*) maxval(gg_tv_bar),minval(gg_tv_bar) + write(*,*) maxval(gg_u_bar),minval(gg_u_bar) + write(*,*) maxval(gg_v_bar),minval(gg_v_bar) + write(*,*) maxval(gg_rh_bar),minval(gg_rh_bar) + +! CALCULATE ENSEMBLE perturbations + iunit=10 + iunit_out=20 + do nnn=1,n_ens + write(ensfile,'(a,I3.3)') 'fort.',900+nnn + write(perbfile,'(a,I10,a,I3.3,a,I4.4)') 'enspert_',initialtime,'f',fcsthh,'_mem',nnn + open(iunit,file=trim(ensfile),form='unformatted',convert='BIG_ENDIAN') + open(iunit_out,file=trim(perbfile),form='unformatted',convert='BIG_ENDIAN') + write(*,*) 'save perturbation to ',trim(perbfile) + + read(iunit) nx,ny,nz + write(iunit_out) nx,ny,nz + + if(nx==ggnx .and. ny==ggny .and. nz==ggnz) then + allocate(fld2d(ny,nx)) + read(iunit) fld2d ! ps + fld2d=fld2d-gg_ps_bar + write(iunit_out) real(fld2d) + deallocate(fld2d) + + allocate(fld3d(ny,nx,nz)) + read(iunit) fld3d ! tv + fld3d=fld3d-gg_tv_bar + write(iunit_out) real(fld3d) + + read(iunit) fld3d ! u + fld3d=fld3d-gg_u_bar + write(iunit_out) real(fld3d) + + read(iunit) fld3d ! v + fld3d=fld3d-gg_v_bar + write(iunit_out) real(fld3d) + + read(iunit) fld3d ! rh + fld3d=fld3d-gg_rh_bar + write(iunit_out) real(fld3d) + + deallocate(fld3d) + else + write(*,*) 'mismatch dimensions' + stop 123 + endif + close(iunit) + close(iunit_out) + enddo ! nnn + + deallocate(gg_u_bar) + deallocate(gg_v_bar) + deallocate(gg_tv_bar) + deallocate(gg_rh_bar) + deallocate(gg_ps_bar) + + end subroutine cal_ensperts + +end module general_read_wrf_mass diff --git a/util/EnKF/arw/src/enspreproc_arw/save_wrf_mass_ensperts.f90 b/util/EnKF/arw/src/enspreproc_arw/save_wrf_mass_ensperts.f90 new file mode 100644 index 000000000..b26c7a21b --- /dev/null +++ b/util/EnKF/arw/src/enspreproc_arw/save_wrf_mass_ensperts.f90 @@ -0,0 +1,100 @@ + program save_wrf_mass_ensperts + !$$$ subprogram documentation block + ! . . . . + ! subprogram: get_wrf_mass_ensperts read arw model ensemble members + ! prgmmr: Ming Hu org: GSD date: 2018-07-11 + ! + ! abstract: read ensemble members from the arw model in netcdf format, for use + ! with hybrid ensemble option. ensemble spread is also written out as + ! a byproduct for diagnostic purposes. + ! + ! + ! program history log: + ! 2018-07-11 Ming Hu, initial documentation + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + + use kinds, only: r_kind,i_kind,r_single + use constants, only: init_constants + use general_read_wrf_mass, only: general_read_wrf_mass_save + use general_read_wrf_mass, only: general_read_wrf_mass_dim_eta + use general_read_wrf_mass, only: cal_ensperts + + implicit none + integer :: n_ens + integer :: initialtime,fcsthh + character(255) :: constfile + namelist/setup/ n_ens,initialtime,fcsthh,constfile + + integer(i_kind):: n + + character(255) filename + logical :: if_exist +! +! + call init_constants(.true.) +! + n_ens=9 + initialtime=2018052918 + fcsthh=18 + constfile='wrfout_d01_const' + + inquire(file='namelist_enspert', EXIST=if_exist ) + if(if_exist) then + open(10,file='namelist_enspert',status='old') + read(10,setup) + close(10) + write(*,*) 'Namelist setup are:' + write(*,setup) + else + write(*,*) 'No namelist file exist' + stop 123 + endif + +! + inquire(file=trim(constfile), EXIST=if_exist) + if(if_exist) then + call general_read_wrf_mass_dim_eta(constfile) + else + write(*,*) 'constant file does not exist ',trim(constfile) + stop 1234 + endif +! + open(10,file='filelist03',form='formatted',err=30) + + ! LOOP OVER ENSEMBLE MEMBERS + do n=1,n_ens + ! + ! DEFINE INPUT FILE NAME + read(10,'(a)',err=20,end=20) filename + ! READ ENEMBLE MEMBERS DATA + inquire(file=trim(filename), EXIST=if_exist) + if(if_exist) then + write(6,'(a,a)') 'CALL READ_WRF_MASS_ENSPERTS FOR ENS DATA : ',trim(filename) + call general_read_wrf_mass_save(filename,.false.,n) + else + write(*,*) 'ensemble file does not exist ',trim(filename) + stop 1234 + endif + + enddo + + close(10) + ! calculate perturbation and mean + call cal_ensperts(n_ens,initialtime,fcsthh) + + stop +30 write(6,*) 'get_wrf_mass_ensperts_netcdf: open filelist failed ' + call stop2(555) +20 write(6,*) 'get_wrf_mass_ensperts_netcdf: read WRF-ARW ens failed ',n + call stop2(555) + +end program diff --git a/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt b/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt new file mode 100644 index 000000000..663f6323f --- /dev/null +++ b/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt @@ -0,0 +1,13 @@ +cmake_minimum_required(VERSION 2.6) + set(GSI_Fortran_FLAGS_LOCAL "${GSI_Fortran_FLAGS} -DWRF") + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90 ${CMAKE_CURRENT_SOURCE_DIR}/*.F90) + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS_LOCAL} ) + include_directories( ${PROJECT_BINARY_DIR}/include ${CORE_INCS} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ) + + add_executable(enspreproc.x ${LOCAL_SRC} ) + set_target_properties( enspreproc.x PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS_LOCAL} ) + target_link_libraries(enspreproc.x ${GSISHAREDLIB} ${GSILIB} ${GSISHAREDLIB} ${WRF_LIBRARIES} + ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_LIBRARIES} + ${LAPACK_LIBRARIES} -L./ ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${CORE_LIBRARIES} ${CORE_BUILT} + ${GSI_LDFLAGS} ${NCDIAG_LIBRARIES} ${ZLIB_LIBRARIES} ${wrflib} ) + add_dependencies(enspreproc.x ${GSILIB}) diff --git a/util/EnKF/arw/src/enspreproc_regional.fd/get_gefs_for_regional_enspro.f90 b/util/EnKF/arw/src/enspreproc_regional.fd/get_gefs_for_regional_enspro.f90 new file mode 100644 index 000000000..90f89f692 --- /dev/null +++ b/util/EnKF/arw/src/enspreproc_regional.fd/get_gefs_for_regional_enspro.f90 @@ -0,0 +1,1373 @@ +subroutine get_gefs_for_regional_enspro(enpert4arw,wrt_pert_sub,wrt_pert_mem,jcap_ens) +!$$$ subprogram documentation block +! . . . . +! subprogram: get_gefs_for_regionl read gefsozone for regional +! prgmmr: parrish org: np22 date: 2010-09-26 +! +! abstract: read gefs and interpolate to regional ensemble grid. +! (adaptation of get_gefs_ensperts_dualres) +! +! +! program history log: +! 2010-09-26 parrish, initial documentation +! 2012-01-17 wu, clean up, add/setup option "full_ensemble" +! 2012-02-08 parrish - a little more cleanup +! 2012-10-11 wu - dual resolution for options of regional hybens +! 2013-02-21 wu - add call to general_destroy_spec_vars to fix memory problem +! 2013-10-19 todling - all guess variables in met-guess +! 2014-11-30 todling - update interface to general_read_gfs routines +! 2014-12-03 derber - changes to call for general_read_gfsatm +! 2015-05-12 wu - changes to read in multiple ensemble for 4DEnVar +! 2015-09-20 s.liu - use general sub2grid in grads1a +! 2016-05-19 Carley/s.liu - prevent the GSI from printing out erroneous error +! when using ensembles from different time +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use gridmod, only: idsl5,regional,use_gfs_nemsio + use gridmod, only: nlon,nlat,lat2,lon2,nsig,rotate_wind_ll2xy + use hybrid_ensemble_parameters, only: region_lat_ens,region_lon_ens + use hybrid_ensemble_parameters, only: ps_bar,nelen + use hybrid_ensemble_parameters, only: n_ens,grd_ens,grd_anl,grd_a1,grd_e1,p_e2a,uv_hyb_ens,dual_res + use hybrid_ensemble_parameters, only: full_ensemble,q_hyb_ens,l_ens_in_diff_time,write_ens_sprd + use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path + !use hybrid_ensemble_parameters, only: add_bias_perturbation + use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d + use gsi_bundlemod, only: gsi_bundlecreate + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_bundlemod, only: gsi_bundledestroy + use constants,only: zero,half,fv,rd_over_cp,one,h300,i_missing,r60,r3600 + use constants, only: rd,grav + use mpimod, only: mpi_comm_world,ierror,mype,mpi_rtype,mpi_min,mpi_max + use mpimod, only: mpi_info_null,mpi_offset_kind,mpi_mode_create + use mpimod, only: mpi_mode_wronly + use kinds, only: r_kind,i_kind,r_single + use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info + use general_sub2grid_mod, only: general_grid2sub,general_sub2grid + use general_sub2grid_mod, only: general_suba2sube,general_sube2suba + use general_sub2grid_mod, only: general_sub2grid_destroy_info + use general_sub2grid_mod, only: general_gather2grid + use general_specmod, only: spec_vars,general_init_spec_vars,general_destroy_spec_vars + use egrid2agrid_mod, only: g_create_egrid2points_slow,egrid2agrid_parm,g_egrid2points_faster + use sigio_module, only: sigio_intkind,sigio_head,sigio_srhead + use guess_grids, only: ges_prsl,ntguessig + use guess_grids, only: ges_tsen,ifilesig,hrdifsig + use aniso_ens_util, only: intp_spl + use obsmod, only: iadate + use mpimod, only: npe + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_bundlemod, only: gsi_bundlecreate + use gsi_bundlemod, only: gsi_grid + use gsi_bundlemod, only: gsi_gridcreate + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundledestroy + use gsi_metguess_mod, only: GSI_MetGuess_Bundle + use mpeu_util, only: die + use gsi_4dvar, only: nhr_assimilation + use get_wrf_mass_ensperts_mod, only: get_wrf_mass_ensperts_class + + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead + + implicit none + + logical, intent(in) :: enpert4arw,wrt_pert_sub,wrt_pert_mem + integer(i_kind),intent(in) :: jcap_ens + type(sub2grid_info) grd_gfs,grd_mix,grd_gfst,grd_arw + type(get_wrf_mass_ensperts_class) :: wrf_mass_ensperts + type(spec_vars) sp_gfs + real(r_kind),allocatable,dimension(:,:,:) :: pri,prsl,prsl1000 + real(r_kind),pointer,dimension(:,:,:) :: vor =>null() + real(r_kind),pointer,dimension(:,:,:) :: div =>null() + real(r_kind),pointer,dimension(:,:,:) :: u =>null() + real(r_kind),pointer,dimension(:,:,:) :: v =>null() + real(r_kind),pointer,dimension(:,:,:) :: tv =>null() + real(r_kind),pointer,dimension(:,:,:) :: q =>null() + real(r_kind),pointer,dimension(:,:,:) :: cwmr=>null() + real(r_kind),pointer,dimension(:,:,:) :: oz =>null() + real(r_kind),pointer,dimension(:,:) :: z =>null() + real(r_kind),pointer,dimension(:,:) :: ps=>null() + real(r_kind),allocatable,dimension(:) :: ak5,bk5,ck5,tref5 + real(r_kind),allocatable :: work_sub(:,:,:,:),work(:,:,:,:),work_reg(:,:,:,:) + real(r_kind),allocatable :: tmp_ens(:,:,:,:),tmp_anl(:,:,:,:),tmp_ens2(:,:,:,:) + real(r_kind),allocatable,dimension(:,:,:)::stbar,vpbar,tbar,rhbar,ozbar,cwbar + real(r_kind),allocatable,dimension(:,:):: pbar_nmmb + real(r_kind),allocatable,dimension(:,:,:,:)::st_eg,vp_eg,t_eg,rh_eg,oz_eg,cw_eg + real(r_kind),allocatable,dimension(:,:,:):: p_eg_nmmb + real(r_kind),allocatable,dimension(:,:,:,:):: ges_prsl_e + real(r_kind),allocatable,dimension(:,:,:)::tsen,qs + real(r_kind),allocatable,dimension(:,:,:)::ut,vt,tt,rht,ozt,cwt + real(r_single),allocatable,dimension(:,:,:):: w3 + real(r_single),allocatable,dimension(:,:):: w2 + real(r_single),allocatable,dimension(:,:,:,:)::en_perts + real(r_kind),dimension(:,:,:),allocatable:: workh + real(r_kind),dimension(:),allocatable:: z1 + + character(len=*),parameter::myname='get_gefs_for_regional' + real(r_kind) bar_norm,sig_norm,kapr,kap1,trk + integer(i_kind) iret,i,j,k,k2,n,mm1,iderivative + integer(i_kind) ic2,ic3,it + integer(i_kind) ku,kv,kt,kq,koz,kcw,kz,kps + character(255) filename,filelists(ntlevs_ens) + logical ice + integer(sigio_intkind):: lunges = 11 + type(sigio_head):: sighead + type(egrid2agrid_parm) :: p_g2r + integer(i_kind) inner_vars,num_fields,nlat_gfs,nlon_gfs,nsig_gfs,jcap_gfs,jcap_gfs_test + integer(i_kind) nord_g2r,num_fieldst + logical,allocatable :: vector(:) + real(r_kind),parameter:: zero_001=0.001_r_kind + real(r_kind),allocatable,dimension(:) :: xspli,yspli,xsplo,ysplo + integer(i_kind) iyr,ihourg + integer(i_kind),dimension(7):: idate + integer(i_kind),dimension(4):: idate4 + integer(i_kind),dimension(8) :: ida,jda + integer(i_kind),dimension(5) :: iadate_gfs + real(r_kind) hourg + real(r_kind),dimension(5):: fha + integer(i_kind) istatus + real(r_kind) rdog,h,dz + real(r_kind),allocatable::height(:),zbarl(:,:,:) + logical add_bias_perturbation,inithead + integer(i_kind) n_ens_temp + real(r_kind),allocatable::psfc_out(:,:) + integer(i_kind) ilook,jlook,ier + character(len=3) :: charfhr + character(len=7) charmem + + + real(r_kind) dlon,dlat,uob,vob,dlon_ens,dlat_ens + integer(i_kind) ii,jj,n1 + integer(i_kind) iimax,iimin,jjmax,jjmin + integer(i_kind) nming1,nming2 + integer(i_kind) its,ite + real(r_kind) ratio_x,ratio_y + + integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd + integer(i_kind) :: idvc,idsl,lonb,latb,levs,jcap,nvcoord + character(8) filetype, mdlname + real(r_single),allocatable,dimension(:,:,:) :: vcoord + integer(i_kind) iret2 + type(nemsio_gfile) :: gfile_atm + + type(gsi_bundle) :: atm_bundle + type(gsi_grid) :: atm_grid + integer(i_kind),parameter :: n2d=2 + integer(i_kind),parameter :: n3d=8 + character(len=4), parameter :: vars2d(n2d) = (/ 'z ', 'ps ' /) + character(len=4), parameter :: vars3d(n3d) = (/ 'u ', 'v ', & + 'vor ', 'div ', & + 'tv ', 'q ', & + 'cw ', 'oz ' /) + + real(r_kind), pointer :: ges_ps(:,: )=>NULL() + real(r_kind), pointer :: ges_z (:,: )=>NULL() + real(r_kind), pointer :: ges_u (:,:,:)=>NULL() + real(r_kind), pointer :: ges_v (:,:,:)=>NULL() + real(r_kind), pointer :: ges_tv(:,:,:)=>NULL() + real(r_kind), pointer :: ges_q (:,:,:)=>NULL() + + integer(i_kind) :: iunit,lunit,count + integer(mpi_offset_kind) :: disp + character(len=500) :: filenameout + + add_bias_perturbation=.false. ! not fully activated yet--testing new adjustment of ps perturbions 1st + + if(ntlevs_ens > 1) then + do i=1,ntlevs_ens + write(filelists(i),'("filelist",i2.2)')ifilesig(i) + enddo + its=1 + ite=ntlevs_ens + else + write(filelists(1),'("filelist",i2.2)')nhr_assimilation + its=ntguessig + ite=ntguessig + endif + + do it=its,ite +! get pointers for typical meteorological fields + ier=0 + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ps',ges_ps,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'z', ges_z, istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u', ges_u, istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v', ges_v, istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'tv',ges_tv,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q, istatus );ier=ier+istatus + if (ier/=0) call die(trim(myname),'cannot get pointers for met-fields, ier =',ier) + +! figure out what are acceptable dimensions for global grid, based on resolution of input spectral coefs +! need to inquire from file what is spectral truncation, then setup general spectral structure variable + + if(ntlevs_ens > 1) then + open(10,file=trim(filelists(it)),form='formatted',err=30) + else + open(10,file=trim(filelists(1)),form='formatted',err=30) + endif + rewind (10) + do n=1,200 + read(10,'(a)',err=20,end=40)filename + enddo +40 n_ens=n-1 + +! set n_ens_temp depending on if we want to add bias perturbation to the ensemble + + if(add_bias_perturbation) then + n_ens_temp=n_ens+1 + else + n_ens_temp=n_ens + end if + + rewind (10) + read(10,'(a)',err=20,end=20)filename +!=========== + if ( .not. use_gfs_nemsio ) then + + open(lunges,file=trim(filename),form='unformatted') + call sigio_srhead(lunges,sighead,iret) + close(lunges) + + hourg=sighead%fhour + idate4=sighead%idate + nvcoord=sighead%nvcoord + + if(mype == 0) then + write(6,*) ' sighead%fhour,sighead%idate=',sighead%fhour,sighead%idate + write(6,*) ' iadate(y,m,d,hr,min)=',iadate + write(6,*) ' sighead%jcap,sighead%levs=',sighead%jcap,sighead%levs + write(6,*) ' sighead%latf,sighead%lonf=',sighead%latf,sighead%lonf + write(6,*) ' sighead%idvc,sighead%nvcoord=',sighead%idvc,sighead%nvcoord + write(6,*) ' sighead%idsl=',sighead%idsl + do k=1,sighead%levs+1 + write(6,*)' k,vcoord=',k,sighead%vcoord(k,:) + end do + end if + + idsl=sighead%idsl + idvc=sighead%idvc + nlat_gfs=sighead%latf+2 + nlon_gfs=sighead%lonf + nsig_gfs=sighead%levs + if(sighead%jcap > 0)then + jcap_gfs=sighead%jcap + else if(jcap_ens > 0)then + jcap_gfs=jcap_ens + else + write(6,*)'ERROR jcap is undefined' + call stop2(555) + endif + + if (allocated(vcoord)) deallocate(vcoord) + allocate(vcoord(nsig_gfs+1,3,2)) + vcoord(1:nsig_gfs+1,1:sighead%nvcoord,1)=sighead%vcoord(1:nsig_gfs+1,1:sighead%nvcoord) + +! Extract header information +! hourg = sighead%fhour +! idate4(1)= sighead%idate(1) +! idate4(2)= sighead%idate(2) +! idate4(3)= sighead%idate(3) +! idate4(4)= sighead%idate(4) + + else !NEMSIO + + call nemsio_init(iret=iret) + call nemsio_open(gfile_atm,filename,'READ',iret=iret) + idate = i_missing + nfhour = i_missing; nfminute = i_missing + nfsecondn = i_missing; nfsecondd = i_missing + idsl = i_missing + call nemsio_getfilehead(gfile_atm, idate=idate, gtype=filetype, & + modelname=mdlname, nfhour=nfhour, nfminute=nfminute, & + nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + dimx=lonb, dimy=latb, dimz=levs, & + jcap=jcap, idvc=idvc, & + idsl=idsl, iret=iret2) + if ( nfhour == i_missing .or. nfminute == i_missing .or. & + nfsecondn == i_missing .or. nfsecondd == i_missing ) then + write(6,*)'READ_FILES: ***ERROR*** some forecast hour info ', & + 'are not defined in ', trim(filename) + write(6,*)'READ_FILES: nfhour = ', & + hourg + call stop2(80) + endif + + hourg = float(nfhour) + float(nfminute)/r60 + & + float(nfsecondn)/float(nfsecondd)/r3600 + idate4(1) = idate(4) !hour + idate4(2) = idate(2) !month + idate4(3) = idate(3) !day + idate4(4) = idate(1) !year + nlat_gfs=latb+2 + nlon_gfs=lonb + nsig_gfs=levs + if(jcap > 0)then + jcap_gfs=jcap + else if(jcap_ens > 0)then + jcap_gfs=jcap_ens + else + write(6,*)'ERROR jcap is undefined' + call stop2(555) + endif + + if (allocated(vcoord)) deallocate(vcoord) + allocate(vcoord(nsig_gfs+1,3,2)) + call nemsio_getfilehead(gfile_atm,iret=iret2,vcoord=vcoord) + if ( iret2 /= 0 ) then + write(6,*)' GESINFO: ***ERROR*** problem reading header ', & + 'vcoord, Status = ',iret2 + call stop2(99) + endif + + call nemsio_close(gfile_atm,iret=iret) +! Determine the type of vertical coordinate used by model because that +! nvcoord is no longer part of NEMSIO header output. + nvcoord=3 + if(maxval(vcoord(:,3,1))==zero .and. & + minval(vcoord(:,3,1))==zero ) then + nvcoord=2 + if(maxval(vcoord(:,2,1))==zero .and. & + minval(vcoord(:,2,1))==zero ) then + nvcoord=1 + end if + end if + if(mype == 0) then + write(6,*) 'fhour,idate=',hourg,idate4 + write(6,*) ' iadate(y,m,d,hr,min)=',iadate + write(6,*) ' jcap,levs=',jcap,levs + write(6,*) ' latf,lonf=',latb,lonb + write(6,*) ' idvc,nvcoord=',idvc,nvcoord + write(6,*) ' idsl=',idsl + do k=1,levs+1 + write(6,*)' k,vcoord=',k,vcoord(k,:,1) + end do + end if + + endif ! use_gfs_nemsio +!=========== +! Compute valid time from ensemble date and forecast length and compare to iadate, the analysis time + iyr=idate4(4) + ihourg=hourg + if(iyr>=0.and.iyr<=99) then + if(iyr>51) then + iyr=iyr+1900 + else + iyr=iyr+2000 + end if + end if + fha=zero ; ida=0; jda=0 + fha(2)=ihourg ! relative time interval in hours + ida(1)=iyr ! year + ida(2)=idate4(2) ! month + ida(3)=idate4(3) ! day + ida(4)=0 ! time zone + ida(5)=idate4(1) ! hour + call w3movdat(fha,ida,jda) + iadate_gfs(1)=jda(1) ! year + iadate_gfs(2)=jda(2) ! mon + iadate_gfs(3)=jda(3) ! day + if(ntlevs_ens > 1) then + iadate_gfs(4)=jda(5)+hrdifsig(ntguessig)-hrdifsig(it) ! hour + else + iadate_gfs(4)=jda(5) ! hour + endif + iadate_gfs(5)=0 ! minute + if(mype == 0) then + write(6,*)' in get_gefs_for_regional, iadate_gefs=',iadate_gfs + write(6,*)' in get_gefs_for_regional, iadate =',iadate + end if + call w3fs21(iadate,nming1) + call w3fs21(iadate_gfs,nming2) + if( (nming1/=nming2) .and. (.not.l_ens_in_diff_time) ) then + if(mype == 0) write(6,*)' GEFS ENSEMBLE MEMBER DATE NOT EQUAL TO ANALYSIS DATE, PROGRAM STOPS' +! call stop2(85) + end if + + +! set up ak5,bk5,ck5 for use in computing 3d pressure field (needed for vertical interp to regional) +! following is code segment from gesinfo.F90 + allocate(ak5(nsig_gfs+1)) + allocate(bk5(nsig_gfs+1)) + allocate(ck5(nsig_gfs+1)) + allocate(tref5(nsig_gfs)) + do k=1,nsig_gfs+1 + ak5(k)=zero + bk5(k)=zero + ck5(k)=zero + end do + if (nvcoord == 1) then + do k=1,nsig_gfs+1 + bk5(k) = vcoord(k,1,1) + end do + elseif (nvcoord == 2) then + do k = 1,nsig_gfs+1 + ak5(k) = vcoord(k,1,1)*zero_001 + bk5(k) = vcoord(k,2,1) + end do + elseif (nvcoord == 3) then + do k = 1,nsig_gfs+1 + ak5(k) = vcoord(k,1,1)*zero_001 + bk5(k) = vcoord(k,2,1) + ck5(k) = vcoord(k,3,1)*zero_001 + end do + else + write(6,*)'READ_GFS_OZONE_FOR_REGIONAL: ***ERROR*** INVALID value for nvcoord=',nvcoord + call stop2(85) + endif +! Load reference temperature array (used by general coordinate) + do k=1,nsig_gfs + tref5(k)=h300 + end do + + + inner_vars=1 + num_fields=6*nsig_gfs+2 ! want to transfer u,v,t,q,oz,cw,ps,z from gfs subdomain to slab + ! later go through this code, adapting gsibundlemod, since currently + ! hardwired. + num_fieldst=min(num_fields,npe) + allocate(vector(num_fields)) + vector=.false. + vector(1:2*nsig_gfs)=uv_hyb_ens + call general_sub2grid_create_info(grd_gfst,inner_vars,nlat_gfs,nlon_gfs,nsig_gfs,num_fieldst, & + .not.regional) + call general_sub2grid_create_info(grd_gfs,inner_vars,nlat_gfs,nlon_gfs,nsig_gfs,num_fields, & + .not.regional,vector) + jcap_gfs_test=jcap_gfs + call general_init_spec_vars(sp_gfs,jcap_gfs,jcap_gfs_test,grd_gfs%nlat,grd_gfs%nlon) + +! also want to set up regional grid structure variable grd_mix, which still has number of +! vertical levels set to nsig_gfs, but horizontal dimensions set to regional domain. + + call general_sub2grid_create_info(grd_mix,inner_vars,grd_ens%nlat,grd_ens%nlon,nsig_gfs, & + num_fields,regional,vector) + +! create interpolation information for global grid to regional ensemble grid + + nord_g2r=4 + call g_create_egrid2points_slow(grd_ens%nlat*grd_ens%nlon,region_lat_ens,region_lon_ens, & + grd_gfs%nlat,sp_gfs%rlats,grd_gfs%nlon,sp_gfs%rlons,nord_g2r,p_g2r) + +! allocate mix ensemble space--horizontal on regional domain, vertical still gefs + allocate(st_eg(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig,n_ens)) + allocate(vp_eg(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig,n_ens)) + allocate( t_eg(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig,n_ens)) + allocate(rh_eg(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig,n_ens)) + allocate(oz_eg(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig,n_ens)) + allocate(cw_eg(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig,n_ens)) + allocate( p_eg_nmmb(grd_mix%lat2,grd_mix%lon2,n_ens)) + st_eg=zero ; vp_eg=zero ; t_eg=zero ; rh_eg=zero ; oz_eg=zero ; cw_eg=zero + p_eg_nmmb=zero + +! begin loop over ensemble members + + rewind(10) + inithead=.true. + do n=1,n_ens + read(10,'(a)',err=20,end=20)filename + + +! allocate necessary space on global grid + call gsi_gridcreate(atm_grid,grd_gfs%lat2,grd_gfs%lon2,grd_gfs%nsig) + call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d) + if(istatus/=0) then + write(6,*)myname,': trouble creating atm_bundle' + call stop2(999) + endif + + if(use_gfs_nemsio)then + call general_read_gfsatm_nems(grd_gfst,sp_gfs,filename,uv_hyb_ens,.false.,.true., & + atm_bundle,.true.,iret) + else + call general_read_gfsatm(grd_gfst,sp_gfs,sp_gfs,filename,uv_hyb_ens,.false.,.true., & + atm_bundle,inithead,iret) + end if + inithead = .false. + + ier = 0 + call gsi_bundlegetpointer(atm_bundle,'vor' ,vor ,istatus) ; ier = ier + istatus + call gsi_bundlegetpointer(atm_bundle,'div' ,div ,istatus) ; ier = ier + istatus + call gsi_bundlegetpointer(atm_bundle,'u' ,u ,istatus) ; ier = ier + istatus + call gsi_bundlegetpointer(atm_bundle,'v' ,v ,istatus) ; ier = ier + istatus + call gsi_bundlegetpointer(atm_bundle,'tv' ,tv ,istatus) ; ier = ier + istatus + call gsi_bundlegetpointer(atm_bundle,'q' ,q ,istatus) ; ier = ier + istatus + call gsi_bundlegetpointer(atm_bundle,'oz' ,oz ,istatus) ; ier = ier + istatus + call gsi_bundlegetpointer(atm_bundle,'cw' ,cwmr,istatus) ; ier = ier + istatus + call gsi_bundlegetpointer(atm_bundle,'z' ,z ,istatus) ; ier = ier + istatus + call gsi_bundlegetpointer(atm_bundle,'ps' ,ps ,istatus) ; ier = ier + istatus + if ( ier /= 0 ) call die(myname,': missing atm_bundle vars, aborting ...',ier) + + allocate(work_sub(grd_gfs%inner_vars,grd_gfs%lat2,grd_gfs%lon2,num_fields)) + do k=1,grd_gfs%nsig + ku=k ; kv=k+grd_gfs%nsig ; kt=k+2*grd_gfs%nsig ; kq=k+3*grd_gfs%nsig ; koz=k+4*grd_gfs%nsig + kcw=k+5*grd_gfs%nsig + do j=1,grd_gfs%lon2 + do i=1,grd_gfs%lat2 + work_sub(1,i,j,ku)=u(i,j,k) + work_sub(1,i,j,kv)=v(i,j,k) + work_sub(1,i,j,kt)=tv(i,j,k) + work_sub(1,i,j,kq)=q(i,j,k) + work_sub(1,i,j,koz)=oz(i,j,k) + work_sub(1,i,j,kcw)=cwmr(i,j,k) + end do + end do + end do + kz=num_fields ; kps=kz-1 + do j=1,grd_gfs%lon2 + do i=1,grd_gfs%lat2 + work_sub(1,i,j,kz)=z(i,j) + work_sub(1,i,j,kps)=ps(i,j) + end do + end do + + call gsi_bundledestroy(atm_bundle,istatus) + + allocate(work(grd_gfs%inner_vars,grd_gfs%nlat,grd_gfs%nlon,grd_gfs%kbegin_loc:grd_gfs%kend_alloc)) + call general_sub2grid(grd_gfs,work_sub,work) + deallocate(work_sub) + +! then interpolate to regional analysis grid + allocate(work_reg(grd_mix%inner_vars,grd_mix%nlat,grd_mix%nlon,grd_gfs%kbegin_loc:grd_gfs%kend_alloc)) + do k=grd_gfs%kbegin_loc,grd_gfs%kend_loc + call g_egrid2points_faster(p_g2r,work(1,1,1,k),work_reg(1,1,1,k),vector(k)) + end do + deallocate(work) + +! next general_grid2sub to go to regional grid subdomains. + allocate(work_sub(grd_mix%inner_vars,grd_mix%lat2,grd_mix%lon2,num_fields)) + call general_grid2sub(grd_mix,work_reg,work_sub) + deallocate(work_reg) + allocate(pri(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig+1)) + kz=num_fields ; kps=kz-1 +! compute 3d pressure on interfaces + kap1=rd_over_cp+one + kapr=one/rd_over_cp + pri=zero + k=1 + k2=grd_mix%nsig+1 + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + pri(i,j,k)=work_sub(1,i,j,kps) + pri(i,j,k2)=zero + end do + end do + if (idvc /= 3) then + do k=2,grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + pri(i,j,k)=ak5(k)+bk5(k)*work_sub(1,i,j,kps) + end do + end do + end do + else + do k=2,grd_mix%nsig + kt=k+2*grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + trk=(half*(work_sub(1,i,j,kt-1)+work_sub(1,i,j,kt))/tref5(k))**kapr + pri(i,j,k)=ak5(k)+(bk5(k)*work_sub(1,i,j,kps))+(ck5(k)*trk) + end do + end do + end do + end if + +! Get 3d pressure field now on interfaces + allocate(prsl(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + if (idsl5/=2) then + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + do k=1,grd_mix%nsig + prsl(i,j,k)=((pri(i,j,k)**kap1-pri(i,j,k+1)**kap1)/& + (kap1*(pri(i,j,k)-pri(i,j,k+1))))**kapr + end do + end do + end do + else + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + do k=1,grd_mix%nsig + prsl(i,j,k)=(pri(i,j,k)+pri(i,j,k+1))*half + end do + end do + end do + end if +! !Compute geopotential height at interface between layers + allocate(zbarl(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + allocate(height(grd_mix%nsig)) + rdog=rd/grav + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + k = 1 + kt=k+2*grd_mix%nsig + h = rdog * work_sub(1,i,j,kt) + dz = h * log(pri(i,j,k)/prsl(i,j,k)) + height(k) = work_sub(1,i,j,kz)+dz + + do k=2,grd_mix%nsig + kt=k+2*grd_mix%nsig + h = rdog * half * (work_sub(1,i,j,kt-1)+work_sub(1,i,j,kt)) + dz = h * log(prsl(i,j,k-1)/prsl(i,j,k)) + height(k) = height(k-1) + dz + end do + do k=1,grd_mix%nsig + zbarl(i,j,k)=height(k) + end do + end do + end do + deallocate(pri,height) +!! recompute pbar using routine Wan-Shu obtained from Matt Pyle: + + allocate(tt(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + allocate(psfc_out(grd_mix%lat2,grd_mix%lon2)) + do k=1,grd_mix%nsig + kt=k+2*grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + tt(i,j,k)=work_sub(1,i,j,kt) + end do + end do + end do + mm1=mype+1 + ilook=-1 ; jlook=-1 + allocate(prsl1000(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + prsl1000=1000._r_kind*prsl + call compute_nmm_surfacep ( ges_z(:,:), zbarl,prsl1000, & + psfc_out,grd_mix%nsig,grd_mix%lat2,grd_mix%lon2, & + ilook,jlook) + deallocate(tt,zbarl,prsl1000) + psfc_out=.001_r_kind*psfc_out + +! If not using Q perturbations, convert to RH + if (.not.q_hyb_ens) then + allocate(tsen(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + allocate(qs(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) +! Compute RH and potential virtual temp +! First step is go get sensible temperature and 3d pressure + do k=1,grd_mix%nsig + kt=k+2*grd_mix%nsig ; kq=k+3*grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + tsen(i,j,k)= work_sub(1,i,j,kt)/(one+fv*max(zero,work_sub(1,i,j,kq))) + end do + end do + end do + + ice=.true. + iderivative=0 + call genqsat(qs,tsen,prsl,grd_mix%lat2,grd_mix%lon2,grd_mix%nsig,ice,iderivative) + + do k=1,grd_mix%nsig + kt=k+2*grd_mix%nsig ; kq=k+3*grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + if(enpert4arw) then + work_sub(1,i,j,kq) = work_sub(1,i,j,kq) + else + work_sub(1,i,j,kq) = work_sub(1,i,j,kq)/qs(i,j,k) + endif + end do + end do + end do + deallocate(qs,tsen) + end if + do k=1,grd_mix%nsig + kt=k+2*grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + if(enpert4arw) then + work_sub(1,i,j,kt)=work_sub(1,i,j,kt)/(one+fv*max(zero,work_sub(1,i,j,kq))) & + /(0.01_r_kind*prsl(i,j,k))**rd_over_cp + else + work_sub(1,i,j,kt)=work_sub(1,i,j,kt)/(0.01_r_kind*prsl(i,j,k))**rd_over_cp + endif + end do + end do + end do + + deallocate(prsl) + + iimax=0 + iimin=grd_mix%nlat + jjmax=0 + jjmin=grd_mix%nlon + ratio_x=(nlon-one)/(grd_mix%nlon-one) + ratio_y=(nlat-one)/(grd_mix%nlat-one) + do k=1,grd_mix%nsig + ku=k ; kv=ku+grd_mix%nsig ; kt=kv+grd_mix%nsig ; kq=kt+grd_mix%nsig ; koz=kq+grd_mix%nsig + kcw=koz+grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + + ii=i+grd_mix%istart(mm1)-2 + jj=j+grd_mix%jstart(mm1)-2 + ii=min(grd_mix%nlat,max(1,ii)) + jj=min(grd_mix%nlon,max(1,jj)) + iimax=max(ii,iimax) + iimin=min(ii,iimin) + jjmax=max(jj,jjmax) + jjmin=min(jj,jjmin) + dlon_ens=float(jj) + dlat_ens=float(ii) + dlon=one+(dlon_ens-one)*ratio_x + dlat=one+(dlat_ens-one)*ratio_y + + call rotate_wind_ll2xy(work_sub(1,i,j,ku),work_sub(1,i,j,kv), & + uob,vob,region_lon_ens(ii,jj),dlon,dlat) + st_eg(i,j,k,n)=uob + vp_eg(i,j,k,n)=vob + + t_eg(i,j,k,n)=work_sub(1,i,j,kt) ! now pot virtual temp + rh_eg(i,j,k,n)=work_sub(1,i,j,kq) ! now rh + oz_eg(i,j,k,n)=work_sub(1,i,j,koz) + cw_eg(i,j,k,n)=work_sub(1,i,j,kcw) + end do + end do + end do + kz=num_fields ; kps=kz-1 + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + p_eg_nmmb(i,j,n)=psfc_out(i,j) + end do + end do + deallocate(work_sub,psfc_out) + + end do ! end loop over ensemble members. + +! next, compute mean of ensembles. + + allocate(stbar(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + allocate(vpbar(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + allocate( tbar(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + allocate(rhbar(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + allocate(ozbar(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + allocate(cwbar(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + allocate(pbar_nmmb(grd_mix%lat2,grd_mix%lon2)) + +! compute mean state + stbar=zero ; vpbar=zero ; tbar=zero ; rhbar=zero ; ozbar=zero ; cwbar=zero + pbar_nmmb=zero + do n=1,n_ens + do k=1,grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + stbar(i,j,k)=stbar(i,j,k)+st_eg(i,j,k,n) + vpbar(i,j,k)=vpbar(i,j,k)+vp_eg(i,j,k,n) + tbar(i,j,k)= tbar(i,j,k)+ t_eg(i,j,k,n) + rhbar(i,j,k)=rhbar(i,j,k)+rh_eg(i,j,k,n) + ozbar(i,j,k)=ozbar(i,j,k)+oz_eg(i,j,k,n) + cwbar(i,j,k)=cwbar(i,j,k)+cw_eg(i,j,k,n) + end do + end do + end do + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + pbar_nmmb(i,j)=pbar_nmmb(i,j)+p_eg_nmmb(i,j,n) + end do + end do + end do + +! Convert to mean + bar_norm = one/float(n_ens) + do k=1,grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + stbar(i,j,k)=stbar(i,j,k)*bar_norm + vpbar(i,j,k)=vpbar(i,j,k)*bar_norm + tbar(i,j,k)= tbar(i,j,k)*bar_norm + rhbar(i,j,k)=rhbar(i,j,k)*bar_norm + ozbar(i,j,k)=ozbar(i,j,k)*bar_norm + cwbar(i,j,k)=cwbar(i,j,k)*bar_norm + end do + end do + end do + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + pbar_nmmb(i,j)=pbar_nmmb(i,j)*bar_norm +! also save pbar to module array ps_bar for possible use in vertical localization +! in terms of scale heights/normalized p/p + ps_bar(i,j,1)=pbar_nmmb(i,j) + end do + end do + +! Subtract mean from ensemble members, but save scaling by sqrt(1/(nens-1)) until after vertical interpolation + n1=1 +!www ensemble perturbation for all but the first member if full_ensemble + if(full_ensemble)n1=2 + + do n=n1,n_ens + do k=1,grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + st_eg(i,j,k,n)=st_eg(i,j,k,n)-stbar(i,j,k) + vp_eg(i,j,k,n)=vp_eg(i,j,k,n)-vpbar(i,j,k) + t_eg(i,j,k,n)= t_eg(i,j,k,n)- tbar(i,j,k) + rh_eg(i,j,k,n)=rh_eg(i,j,k,n)-rhbar(i,j,k) + oz_eg(i,j,k,n)=oz_eg(i,j,k,n)-ozbar(i,j,k) + cw_eg(i,j,k,n)=cw_eg(i,j,k,n)-cwbar(i,j,k) + end do + end do + end do + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + p_eg_nmmb(i,j,n)=p_eg_nmmb(i,j,n)-pbar_nmmb(i,j) + end do + end do + end do + deallocate(stbar,vpbar,rhbar,ozbar,cwbar) + +! now obtain mean pressure prsl +! compute 3d pressure on interfaces + kap1=rd_over_cp+one + kapr=one/rd_over_cp + allocate(pri(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig+1)) + pri=zero + k=1 + k2=grd_mix%nsig+1 + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + pri(i,j,k)=pbar_nmmb(i,j) + pri(i,j,k2)=zero + end do + end do + if (idvc /= 3) then + do k=2,grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + pri(i,j,k)=ak5(k)+bk5(k)*pbar_nmmb(i,j) + end do + end do + end do + else + do k=2,grd_mix%nsig + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + trk=(half*(tbar(i,j,k-1)+tbar(i,j,k))/tref5(k))**kapr + pri(i,j,k)=ak5(k)+(bk5(k)*pbar_nmmb(i,j))+(ck5(k)*trk) + end do + end do + end do + end if + +! Get 3d pressure field now at layer midpoints + allocate(prsl(grd_mix%lat2,grd_mix%lon2,grd_mix%nsig)) + if (idsl/=2) then + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + do k=1,grd_mix%nsig + prsl(i,j,k)=((pri(i,j,k)**kap1-pri(i,j,k+1)**kap1)/& + (kap1*(pri(i,j,k)-pri(i,j,k+1))))**kapr + end do + end do + end do + else + do j=1,grd_mix%lon2 + do i=1,grd_mix%lat2 + do k=1,grd_mix%nsig + prsl(i,j,k)=(pri(i,j,k)+pri(i,j,k+1))*half + end do + end do + end do + end if + deallocate(pri,pbar_nmmb,tbar) + deallocate(ak5,bk5,ck5,tref5) + +! interpolate/extrapolate in vertical using yoshi's spline code. + +! first need ges_prsl_e, the 3d pressure on the ensemble grid. + + allocate(ges_prsl_e(grd_ens%inner_vars,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)) + if(dual_res) then + call general_suba2sube(grd_a1,grd_e1,p_e2a,ges_prsl(:,1,1,it),ges_prsl_e(1,:,1,1),regional) ! x? + else + ges_prsl_e(1,:,:,:)=ges_prsl(:,:,:,it) + end if + + allocate(xspli(grd_mix%nsig),yspli(grd_mix%nsig),xsplo(grd_ens%nsig),ysplo(grd_ens%nsig)) + + allocate(ut(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)) + allocate(vt(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)) + allocate(tt(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)) + allocate(rht(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)) + allocate(ozt(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)) + allocate(cwt(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)) + + allocate(w3(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)) + allocate(w2(grd_ens%lat2,grd_ens%lon2)) + allocate(en_perts(n_ens,grd_ens%lat2,grd_ens%lon2,nc2d+nc3d*grd_ens%nsig)) + + do n=1,n_ens + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + do k=1,grd_mix%nsig + xspli(k)=log(prsl(i,j,k)*10.0_r_kind) + end do + do k=1,grd_ens%nsig + xsplo(k)=log(ges_prsl_e(1,i,j,k)*10._r_kind) + end do + +! u + do k=1,grd_mix%nsig + yspli(k)=st_eg(i,j,k,n) + end do + call intp_spl(xspli,yspli,xsplo,ysplo,grd_mix%nsig,grd_ens%nsig) +! following is to correct for bug in intp_spl + do k=1,grd_ens%nsig + if(xsplo(k) < xspli(grd_mix%nsig)) ysplo(k)=yspli(grd_mix%nsig) + if(xsplo(k) > xspli(1)) ysplo(k)=yspli(1) + end do + do k=1,grd_ens%nsig + ut(i,j,k)=ysplo(k) + end do +! v + do k=1,grd_mix%nsig + yspli(k)=vp_eg(i,j,k,n) + end do + call intp_spl(xspli,yspli,xsplo,ysplo,grd_mix%nsig,grd_ens%nsig) +! following is to correct for bug in intp_spl + do k=1,grd_ens%nsig + if(xsplo(k) < xspli(grd_mix%nsig)) ysplo(k)=yspli(grd_mix%nsig) + if(xsplo(k) > xspli(1)) ysplo(k)=yspli(1) + end do + do k=1,grd_ens%nsig + vt(i,j,k)=ysplo(k) + end do +! t + do k=1,grd_mix%nsig + yspli(k)=t_eg(i,j,k,n) + end do + call intp_spl(xspli,yspli,xsplo,ysplo,grd_mix%nsig,grd_ens%nsig) +! following is to correct for bug in intp_spl + do k=1,grd_ens%nsig + if(xsplo(k) < xspli(grd_mix%nsig)) ysplo(k)=yspli(grd_mix%nsig) + if(xsplo(k) > xspli(1)) ysplo(k)=yspli(1) + end do + do k=1,grd_ens%nsig + ysplo(k)=ysplo(k)*(0.01_r_kind*ges_prsl_e(1,i,j,k))**rd_over_cp ! converting from pot Tv to Tv + tt(i,j,k)=ysplo(k) + end do +! rh + do k=1,grd_mix%nsig + yspli(k)=rh_eg(i,j,k,n) + end do + call intp_spl(xspli,yspli,xsplo,ysplo,grd_mix%nsig,grd_ens%nsig) +! following is to correct for bug in intp_spl + do k=1,grd_ens%nsig + if(xsplo(k) < xspli(grd_mix%nsig)) ysplo(k)=yspli(grd_mix%nsig) + if(xsplo(k) > xspli(1)) ysplo(k)=yspli(1) + end do + do k=1,grd_ens%nsig + rht(i,j,k)=ysplo(k) + end do +! oz + do k=1,grd_mix%nsig + yspli(k)=oz_eg(i,j,k,n) + end do + call intp_spl(xspli,yspli,xsplo,ysplo,grd_mix%nsig,grd_ens%nsig) +! following is to correct for bug in intp_spl + do k=1,grd_ens%nsig + if(xsplo(k) < xspli(grd_mix%nsig)) ysplo(k)=yspli(grd_mix%nsig) + if(xsplo(k) > xspli(1)) ysplo(k)=yspli(1) + end do + do k=1,grd_ens%nsig + ozt(i,j,k)=ysplo(k) + end do +! cw + do k=1,grd_mix%nsig + yspli(k)=cw_eg(i,j,k,n) + end do + call intp_spl(xspli,yspli,xsplo,ysplo,grd_mix%nsig,grd_ens%nsig) +! following is to correct for bug in intp_spl + do k=1,grd_ens%nsig + if(xsplo(k) < xspli(grd_mix%nsig)) ysplo(k)=yspli(grd_mix%nsig) + if(xsplo(k) > xspli(1)) ysplo(k)=yspli(1) + end do + do k=1,grd_ens%nsig + cwt(i,j,k)=ysplo(k) + end do + + end do + end do + +!wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww + if(n==1 .and. full_ensemble)then + + allocate(qs(lat2,lon2,nsig)) + ice=.true. + iderivative=0 + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + qs(i,j,k)=ges_q(i,j,k) + end do + end do + end do + call genqsat(qs,ges_tsen(:,:,:,it),ges_prsl(:,:,:,it),lat2,lon2,nsig,ice,iderivative) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!! The first member is full perturbation based on regional first guess !!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! put fist guess in ensemble grid & Subtract guess from 1st ensemble member (ensemble mean) + + if (dual_res) then + allocate ( tmp_ens(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,1) ) + allocate ( tmp_ens2(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,1) ) + allocate ( tmp_anl(lat2,lon2,nsig,1) ) + + if (.not.q_hyb_ens) then + tmp_anl(:,:,:,1)=qs(:,:,:) + call general_suba2sube(grd_a1,grd_e1,p_e2a,tmp_anl,tmp_ens,regional) + tmp_anl(:,:,:,1)=ges_q(:,:,:) + call general_suba2sube(grd_a1,grd_e1,p_e2a,tmp_anl,tmp_ens2,regional) + rht(:,:,:) = rht(:,:,:)-tmp_ens2(:,:,:,1)/tmp_ens(:,:,:,1) + else + tmp_anl(:,:,:,1)=ges_q(:,:,:) + call general_suba2sube(grd_a1,grd_e1,p_e2a,tmp_anl,tmp_ens2,regional) + rht(:,:,:) = rht(:,:,:)-tmp_ens2(:,:,:,1) + end if + + tmp_anl(:,:,:,1)=ges_u(:,:,:) + call general_suba2sube(grd_a1,grd_e1,p_e2a,tmp_anl,tmp_ens,regional) + ut(:,:,:) = ut(:,:,:)-tmp_ens(:,:,:,1) + tmp_anl(:,:,:,1)=ges_v(:,:,:) + call general_suba2sube(grd_a1,grd_e1,p_e2a,tmp_anl,tmp_ens,regional) + vt(:,:,:) = vt(:,:,:)-tmp_ens(:,:,:,1) + tmp_anl(:,:,:,1)=ges_tv(:,:,:) + call general_suba2sube(grd_a1,grd_e1,p_e2a,tmp_anl,tmp_ens,regional) + tt(:,:,:) = tt(:,:,:)-tmp_ens(:,:,:,1) + tmp_anl(:,:,1,1)=ges_ps(:,:) + call general_suba2sube(grd_a1,grd_e1,p_e2a,tmp_anl,tmp_ens,regional) + p_eg_nmmb(:,:,n) = p_eg_nmmb(:,:,n)-tmp_ens(:,:,1,1) + deallocate(tmp_anl,tmp_ens,tmp_ens2) + else + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + ut(i,j,k) = ut(i,j,k)-ges_u(i,j,k) + vt(i,j,k) = vt(i,j,k)-ges_v(i,j,k) + tt(i,j,k) = tt(i,j,k)-ges_tv(i,j,k) + end do + end do + end do + + if (.not.q_hyb_ens) then + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + rht(i,j,k) = rht(i,j,k)-ges_q(i,j,k)/qs(i,j,k) + end do + end do + end do + else + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + rht(i,j,k) = rht(i,j,k)-ges_q(i,j,k) + end do + end do + end do + end if + + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + p_eg_nmmb(i,j,n) = p_eg_nmmb(i,j,n)-ges_ps(i,j) + end do + end do + endif + deallocate(qs) + + endif ! n==1 .and. full_ensemble + +!wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww + +! transfer from temporary arrays to perturbation arrays and normalize by sig_norm + +! sig_norm from the following +! 2*J_b = x^T * (beta1*B + beta2*P_ens)^(-1) * x +! where P_ens is the ensemble covariance which is the sum of outer products of the +! ensemble perturbations (unnormalized) divided by n_ens-1 (or n_ens, depending on who you read). + sig_norm=sqrt(one/max(one,n_ens_temp-one)) + + do ic3=1,nc3d + + select case (trim(cvars3d(ic3))) + + case('sf','SF') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = ut(i,j,k)*sig_norm + en_perts(n,i,j,(ic3-1)*grd_ens%nsig+k)=w3(i,j,k) + end do + end do + end do + + case('vp','VP') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = vt(i,j,k)*sig_norm + en_perts(n,i,j,(ic3-1)*grd_ens%nsig+k)=w3(i,j,k) + end do + end do + end do + + case('t','T') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = tt(i,j,k)*sig_norm + en_perts(n,i,j,(ic3-1)*grd_ens%nsig+k)=w3(i,j,k) + end do + end do + end do + + case('q','Q') + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k) = rht(i,j,k)*sig_norm + en_perts(n,i,j,(ic3-1)*grd_ens%nsig+k)=w3(i,j,k) + end do + end do + end do + + case('oz','OZ') +! temporarily ignore ozone perturbations + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + ! w3(i,j,k) = ozt(i,j,k)*sig_norm + w3(i,j,k) = zero + en_perts(n,i,j,(ic3-1)*grd_ens%nsig+k)=w3(i,j,k) + end do + end do + end do + + case('cw','CW') +! temporarily ignore cloud water perturbations + + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + ! w3(i,j,k) = cwt(i,j,k)*sig_norm + w3(i,j,k) = zero + en_perts(n,i,j,(ic3-1)*grd_ens%nsig+k)=w3(i,j,k) + end do + end do + end do + + end select + end do + do ic2=1,nc2d + + select case (trim(cvars2d(ic2))) + + case('ps','PS') + + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w2(i,j) = p_eg_nmmb(i,j,n)*sig_norm + en_perts(n,i,j,nc3d*grd_ens%nsig+ic2)=w2(i,j) + end do + end do + + case('sst','SST') + +! dtk: temporarily ignore sst perturbations in hybrid + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w2(i,j) = zero + en_perts(n,i,j,nc3d*grd_ens%nsig+ic2)=w2(i,j) + end do + end do + + end select + end do + end do + + call general_sub2grid_destroy_info(grd_gfs) + call general_sub2grid_destroy_info(grd_mix) + call general_sub2grid_destroy_info(grd_gfst) +! +! +! CALCULATE ENSEMBLE SPREAD Here + + call general_destroy_spec_vars(sp_gfs) + deallocate(vector) + deallocate(st_eg,vp_eg,t_eg,rh_eg) + deallocate(oz_eg,cw_eg,p_eg_nmmb) + deallocate(ges_prsl_e) + deallocate(xspli,yspli,xsplo,ysplo) + deallocate(prsl) + deallocate(ut,vt,tt,rht,ozt,cwt) + + enddo ! it=1,ntlevs_ens + + iunit=20 + if(wrt_pert_sub) then ! write perturbations in subdomain + write(filename,'(a,I4.4)') 'saved_en_perts.pe',mype + if(mype==0) write(*,*) 'save en_perts as ', trim(filename) + open(iunit,file=trim(filename),form='unformatted') + do n=1,n_ens +! + write(iunit) n + write(iunit) ps_bar(:,:,1) +! + do ic3=1,nc3d + + do k=1,grd_ens%nsig + w3(:,:,k)=en_perts(n,:,:,(ic3-1)*grd_ens%nsig+k) + enddo + write(iunit) cvars3d(ic3) + write(iunit) w3 + + end do + do ic2=1,nc2d + + w2(:,:)=en_perts(n,:,:,nc3d*grd_ens%nsig+ic2) + write(iunit) cvars2d(ic2) + write(iunit) w2 + end do + + end do + close(iunit) + deallocate(w3,w2) + endif + + if(wrt_pert_mem) then + inner_vars=1 + num_fields=nc3d*grd_ens%nsig+nc2d + allocate(vector(num_fields)) + vector=.false. + + if(mype==0) write(*,*) 'final==',inner_vars,grd_ens%nlat,grd_ens%nlon,grd_ens%nsig,num_fields,regional + call general_sub2grid_create_info(grd_arw,inner_vars, & + grd_ens%nlat,grd_ens%nlon,grd_ens%nsig, & + num_fields,regional,vector) + allocate(work_sub(inner_vars,grd_arw%lat2,grd_arw%lon2,grd_arw%num_fields)) + allocate(work(inner_vars,grd_arw%nlat,grd_arw%nlon,grd_arw%kbegin_loc:grd_arw%kend_alloc)) + do n = 1,n_ens + do k = 1,num_fields ; do j = 1,grd_arw%lon2 ; do i = 1,grd_arw%lat2 + work_sub(1,i,j,k) = en_perts(n,i,j,k) + enddo ; enddo ; enddo + + call general_sub2grid(grd_arw,work_sub,work) + + write(charmem,'("_mem",i3.3)') n + filenameout="enspreproc_arw" // trim(adjustl(charmem)) + + call mpi_file_open(mpi_comm_world,trim(adjustl(filenameout)), & + mpi_mode_wronly+mpi_mode_create, & + mpi_info_null,lunit,ierror) + if ( ierror /= 0 ) then + write(6,'(a,i5,a,i5,a)') '***ERROR*** MPI_FILE_OPEN failed on task =', & + mype ,' ierror = ',ierror,' aborting!' + goto 999 + endif + + disp = grd_arw%nlat * grd_arw%nlon * (grd_arw%kbegin_loc-1) * r_kind + + call mpi_file_set_view(lunit,disp,mpi_rtype,mpi_rtype,'native',mpi_info_null,ierror) + if ( ierror /= 0 ) then + write(6,'(a,i5,a,i5,a)') '***ERROR*** MPI_FILE_SET_VIEW failed on task = ',& + mype ,' ierror = ',ierror,' aborting!' + goto 999 + endif + + count = grd_arw%nlat * grd_arw%nlon * grd_arw%nlevs_alloc + + call mpi_file_write(lunit,work,count,mpi_rtype,istatus,ierror) + if ( ierror /= 0 ) then + write(6,'(a,i5,a,i5,a)') '***ERROR*** MPI_FILE_WRITE failed on task =', & + mype ,' ierror = ',ierror,' aborting!' + goto 999 + endif + + call mpi_file_close(lunit,ierror) + if ( ierror /= 0 ) then + write(6,'(a,i5,a,i5,a)') '***ERROR*** MPI_FILE_CLOSE failed on task =', & + mype ,' ierror = ',ierror,' aborting!' + goto 999 + endif + + enddo ! do i_ens = 1,n_ens + + deallocate(work_sub,work,vector) + endif + + if(enpert4arw) then + inner_vars=1 + num_fields=1 + allocate(vector(num_fields)) + vector=.false. + + if(mype==0) write(*,*) 'final==',inner_vars,grd_ens%nlat,grd_ens%nlon,grd_ens%nsig,num_fields,regional + call general_sub2grid_create_info(grd_arw,inner_vars, & + grd_ens%nlat,grd_ens%nlon,grd_ens%nsig, & + num_fields,regional,vector) + + allocate(z1(grd_arw%inner_vars*grd_arw%nlat*grd_arw%nlon)) + allocate(workh(grd_arw%inner_vars,grd_arw%nlat,grd_arw%nlon)) + + sig_norm=1.0_r_kind/sig_norm + do n=1,n_ens + if(mype==0) then + write(filename,'(a,I4.4)') 'en_perts4arw.mem',n + if(mype==0) then + write(*,*) 'save perturbations for ', trim(filename) + write(*,*) nc3d,nc2d,cvars3d,cvars2d + write(*,*) grd_arw%nlat,grd_arw%nlon,grd_arw%nsig + endif + open(iunit,file=trim(filename),form='unformatted') + write(iunit) nc3d,nc2d,cvars3d,cvars2d + write(iunit) grd_arw%nlat,grd_arw%nlon,grd_arw%nsig + endif + + do k=1,nc3d*grd_ens%nsig+nc2d + + ii=0 + do j=1,lon2 + do i=1,lat2 + ii=ii+1 + z1(ii)=en_perts(n,i,j,k)*sig_norm + end do + end do + if(k==nc3d*grd_ens%nsig+1) z1=z1*1000.0 ! change Ps from CB to Pa) + call general_gather2grid(grd_arw,z1,workh,0) + if(mype==0) then + write(*,*) k,maxval(workh),minval(workh) + write(iunit) workh + endif + + end do + + if(mype==0) close(iunit) + enddo ! n + + deallocate(z1,workh,vector) + endif + + deallocate(en_perts) + + return + +30 write(6,*) 'GET_GEFS+FOR_REGIONAL open filelist failed ' + call stop2(555) +20 write(6,*) 'GET_GEFS+FOR_REGIONAL read gfs ens failed ',n + call stop2(555) +999 write(6,*) 'GET_GEFS+FOR_REGIONAL create full field failed',n + call stop2(666) +end subroutine get_gefs_for_regional_enspro + diff --git a/util/EnKF/arw/src/enspreproc_regional.fd/gfsp2wrfg.f90 b/util/EnKF/arw/src/enspreproc_regional.fd/gfsp2wrfg.f90 new file mode 100644 index 000000000..6f2cd255f --- /dev/null +++ b/util/EnKF/arw/src/enspreproc_regional.fd/gfsp2wrfg.f90 @@ -0,0 +1,167 @@ +PROGRAM gfsp2wrfg +! +!$$$ main program documentation block +! . . . . +! main program: gfsp2wrfg +! PRGMMR: HU ORG: GSD DATE: 2014-12-18 +! +! abstract: This program reads in GFS forecast spectral coefficients +! and convert them to WRF grids +! +! program history log: +! 2014-12-18 Hu initial code based on GSI +! +!EOP +!------------------------------------------------------------------------- + +! !USES: + use mpimod, only: npe,mpi_comm_world,ierror,mype + use mpeu_util, only: die +! use initial, only: miterrr +! use initial, only: init_namelist + use gridmod, only: wrf_mass_regional,diagnostic_reg,regional,use_gfs_nemsio + use gridmod, only: init_grid,init_reg_glob_ll,init_grid_vars,final_grid_vars + use gridmod, only: grid_ratio_wrfmass + use constants, only: init_constants,init_constants_derived + use guess_grids, only:create_ges_grids,destroy_ges_grids,nfldsig + use gridmod, only: nlat,nlon,lat2,lon2,nsig,regional,nsig_soil + use gridmod, only: jcap,nlat_regional,nlon_regional + use control_vectors, only: cvars3d,cvars2d,nrf_var + use control_vectors, only: init_anacv,final_anacv + use guess_grids, only: load_prsges,ges_prsl + use guess_grids_enspro, only: load_prsges_enspro + use gsi_metguess_mod, only: gsi_metguess_init,gsi_metguess_final + use state_vectors, only: init_anasv,final_anasv + use guess_grids, only: create_metguess_grids, destroy_metguess_grids + use hybrid_ensemble_isotropic, only: hybens_grid_setup + use hybrid_ensemble_isotropic, only: create_ensemble,destroy_ensemble + use hybrid_ensemble_parameters, only: grid_ratio_ens,n_ens + use hybrid_ensemble_parameters, only: uv_hyb_ens,grid_ratio_ens + use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path + use guess_grids, only: ntguessig + use gridmod, only: wrf_mass_hybridcord + use gsi_4dvar, only: nhr_assimilation + + + implicit none + logical :: enpert4arw,wrt_pert_sub,wrt_pert_mem + integer :: jcap_ens +! +! Declare variables. +! + namelist/setup/ regional,wrf_mass_regional,diagnostic_reg, & + switch_on_derivatives,tendsflag,nfldsig, & + grid_ratio_ens,n_ens,grid_ratio_ens,grid_ratio_wrfmass,& + enpert4arw,wrt_pert_sub,wrt_pert_mem,wrf_mass_hybridcord,& + use_gfs_nemsio,jcap_ens +! +! +! + integer :: ios,k + character(len=80) :: myname_ + logical switch_on_derivatives,tendsflag +!EOC + +!--------------------------------------------------------------------------- +! NOAA/ESRL/GSD/EMB ! +!------------------------------------------------------------------------- +!BOP + +! MPI + call MPI_INIT(ierror) + call mpi_comm_size(mpi_comm_world,npe,ierror) + call mpi_comm_rank(mpi_comm_world,mype,ierror) +! +! + myname_='program gfsp2wrfg' + + if (mype==0) call w3tagb('GFSP2WRFG',1999,0232,0055,'GSD') +! +! +! intialization +! + call gsi_metguess_init + call init_anasv + call init_anacv + call init_constants_derived + call init_grid +! +! default namelist value +! + regional=.true. + wrf_mass_regional=.true. + diagnostic_reg=.true. + switch_on_derivatives=.false. + tendsflag=.false. + nfldsig=1 + grid_ratio_ens=1 + grid_ratio_wrfmass=1 + enpert4arw=.true. + wrt_pert_sub=.false. + wrt_pert_mem=.false. + wrf_mass_hybridcord=.false. + jcap_ens=574 + +! +! read in namelist +! + open(11,file='namelist.input') + read(11,setup,iostat=ios) + if(ios/=0) call die(myname_,'read(setup)',ios) + close(11) + +! Write namelist output to standard out + if(mype==0) then + write(6,200) +200 format(' calling gfsp2wrfg with following input parameters:',//) + write(6,setup) + endif + ntguessig=1 + ntlevs_ens=1 + uv_hyb_ens=.true. + nhr_assimilation=1 +! +! read in regional background and convert it to binary intermediate file +! + if (mype==0) call read_netcdf_mass4ens +! + call mpi_barrier(mpi_comm_world,ierror) +! + call init_constants(regional) + call init_reg_glob_ll(mype,21) + if(mype==0) write(*,*) size(cvars3d),size(cvars2d),size(nrf_var) + call init_grid_vars(jcap,npe,cvars3d,cvars2d,nrf_var,mype) +! +! + call create_metguess_grids(mype,ierror) + call create_ges_grids(switch_on_derivatives,tendsflag) + call mpi_barrier(mpi_comm_world,ierror) +! + call read_wrf_mass_netcdf_guess4ens(mype) + call mpi_barrier(mpi_comm_world,ierror) + call load_prsges +!mhu call load_prsges_enspro +! + call mpi_barrier(mpi_comm_world,ierror) + call hybens_grid_setup + call create_ensemble +! +!mhu call read_gfs_for_regional + call get_gefs_for_regional_enspro(enpert4arw,wrt_pert_sub,wrt_pert_mem,jcap_ens) + + +! release space + call destroy_ges_grids + call destroy_metguess_grids(mype,ierror) + + call final_grid_vars + call final_anacv + call final_anasv + call gsi_metguess_final + +! Done + if (mype==0) call w3tage('GFSP2WRFG') + + call mpi_finalize(ierror) + +END PROGRAM gfsp2wrfg diff --git a/util/EnKF/arw/src/enspreproc_regional.fd/guess_grids_enspro.f90 b/util/EnKF/arw/src/enspreproc_regional.fd/guess_grids_enspro.f90 new file mode 100644 index 000000000..fb3351c63 --- /dev/null +++ b/util/EnKF/arw/src/enspreproc_regional.fd/guess_grids_enspro.f90 @@ -0,0 +1,184 @@ +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI ! +!------------------------------------------------------------------------- +!BOP +! +! !MODULE: guess_grids --- Guess-related grid definitions +! +! !INTERFACE: +! + +module guess_grids_enspro + +! !USES: + + use kinds, only: r_single,r_kind,i_kind + use gridmod, only: regional + use gridmod, only: wrf_nmm_regional,nems_nmmb_regional + use gridmod, only: eta1_ll + use gridmod, only: eta2_ll + use gridmod, only: aeta1_ll + use gridmod, only: aeta2_ll + use gridmod, only: pdtop_ll + use gridmod, only: pt_ll + use guess_grids, only: ges_prsl,ges_prsi,ges_lnprsl,ges_lnprsi + use guess_grids, only: nfldsig,ntguessig + + use gsi_bundlemod, only : gsi_bundlegetpointer + use gsi_metguess_mod, only: gsi_metguess_bundle + + ! meteorological guess (beyond standard ones) + + use mpeu_util, only: die,tell + implicit none + +! !DESCRIPTION: module containing variables related to the guess fields +! +! !REVISION HISTORY: +! +!EOP +!------------------------------------------------------------------------- + +! set default to private + private +! set subroutines to public + public :: load_prsges_enspro + + character(len=*),parameter::myname='guess_grids' + +contains + +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: load_prsges --- Populate guess pressure arrays +! +! !INTERFACE: +! + subroutine load_prsges_enspro + +! !USES: + + use constants,only: zero,one,rd_over_cp,one_tenth,half,ten + use gridmod, only: lat2,lon2,nsig,ak5,bk5,ck5,tref5,idvc5,& + regional,wrf_nmm_regional,nems_nmmb_regional,wrf_mass_regional,& + cmaq_regional,pt_ll,aeta2_ll,& + aeta1_ll,eta2_ll,pdtop_ll,eta1_ll,twodvar_regional,idsl5 + implicit none + +! !DESCRIPTION: populate guess pressure arrays +! +! !REVISION HISTORY: +! 2003-10-15 kleist +! 2004-03-22 parrish, regional capability added +! 2004-05-14 kleist, documentation +! 2004-07-15 todling, protex-compliant prologue; added onlys +! 2004-07-28 treadon - remove subroutine call list, pass variables via modules +! 2005-05-24 pondeca - add regional surface analysis option +! 2006-04-14 treadon - unify global calculations to use ak5,bk5 +! 2006-04-17 treadon - add ges_psfcavg and ges_prslavg for regional +! 2006-07-31 kleist - use ges_ps instead of ln(ps) +! 2007-05-08 kleist - add fully generalized coordinate for pressure calculation +! 2011-07-07 todling - add cap for log(pressure) calculation +! +! !REMARKS: +! language: f90 +! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP +! +! !AUTHOR: +! kleist org: w/nmc20 date: 2003-10-15 +! +!EOP +!------------------------------------------------------------------------- + +! Declare local parameter + character(len=*),parameter::myname_=myname//'*load_prsges' + real(r_kind),parameter:: r1013=1013.0_r_kind + +! Declare local variables + real(r_kind) kap1,kapr,trk + real(r_kind),dimension(:,:) ,pointer::ges_ps=>NULL() + real(r_kind),dimension(:,:,:),pointer::ges_tv=>NULL() + integer(i_kind) i,j,k,jj,itv,ips + logical ihaveprs(nfldsig) + + kap1=rd_over_cp+one + kapr=one/rd_over_cp + + ihaveprs=.false. + do jj=1,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(jj),'ps' ,ges_ps,ips) + if(ips/=0) call die(myname_,': ps not available in guess, abort',ips) + call gsi_bundlegetpointer(gsi_metguess_bundle(jj),'tv' ,ges_tv,itv) + if(idvc5==3) then + if(itv/=0) call die(myname_,': tv must be present when idvc5=3, abort',itv) + endif + do k=1,nsig+1 + do j=1,lon2 + do i=1,lat2 + if(regional) then + if (wrf_nmm_regional.or.nems_nmmb_regional.or.& + cmaq_regional ) & + ges_prsi(i,j,k,jj)=one_tenth* & + (eta1_ll(k)*pdtop_ll + & + eta2_ll(k)*(ten*ges_ps(i,j)-pdtop_ll-pt_ll) + & + pt_ll) + + if (wrf_mass_regional .or. twodvar_regional) & + ges_prsi(i,j,k,jj)=one_tenth*(eta1_ll(k)*(ten*ges_ps(i,j)-pt_ll) + pt_ll) + endif + ges_prsi(i,j,k,jj)=max(ges_prsi(i,j,k,jj),zero) + ges_lnprsi(i,j,k,jj)=log(max(ges_prsi(i,j,k,jj),0.0001_r_kind)) + end do + end do + end do + ihaveprs(jj)=.true. + end do + + if(regional) then + if (wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) then +! load using aeta coefficients + do jj=1,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(jj),'ps' ,ges_ps ,ips) + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + ges_prsl(i,j,k,jj)=one_tenth* & + (aeta1_ll(k)*pdtop_ll + & + aeta2_ll(k)*(ten*ges_ps(i,j)-pdtop_ll-pt_ll) + & + pt_ll) + ges_lnprsl(i,j,k,jj)=log(ges_prsl(i,j,k,jj)) + + end do + end do + end do + end do + end if ! end if wrf_nmm regional block + if (wrf_mass_regional .or. twodvar_regional) then +! load using aeta coefficients + do jj=1,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(jj),'ps' ,ges_ps ,ips) + write(*,*) 'ps==',maxval(ges_ps),minval(ges_ps) + + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + ges_prsl(i,j,k,jj)=one_tenth*(aeta1_ll(k)*(ten*ges_ps(i,j)-pt_ll)+pt_ll) + ges_lnprsl(i,j,k,jj)=log(ges_prsl(i,j,k,jj)) + end do + end do + end do + end do + end if ! end if wrf_mass regional block + + else + + end if ! end regional/global block + + return + end subroutine load_prsges_enspro + + +end module guess_grids_enspro diff --git a/util/EnKF/arw/src/enspreproc_regional.fd/read_wrf_mass_guess4ens.F90 b/util/EnKF/arw/src/enspreproc_regional.fd/read_wrf_mass_guess4ens.F90 new file mode 100644 index 000000000..5e4b7f798 --- /dev/null +++ b/util/EnKF/arw/src/enspreproc_regional.fd/read_wrf_mass_guess4ens.F90 @@ -0,0 +1,254 @@ +#ifdef WRF + +subroutine read_wrf_mass_netcdf_guess4ens(mype) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_wrf_mass_guess read wrf_mass interface file +! prgmmr: parrish org: np22 date: 2003-09-05 +! +! abstract: in place of read_guess for global application, read guess +! from regional model, in this case the wrf mass core model. +! This version reads a binary file created +! in a previous step that interfaces with the wrf infrastructure. +! A later version will read directly from the wrf restart file. +! The guess is read in by complete horizontal fields, one field +! per processor, in parallel. Each horizontal input field is +! converted from the staggered c-grid to an unstaggered a-grid. +! On the c-grid, u is shifted 1/2 point in the negative x direction +! and v 1/2 point in the negative y direction, but otherwise the +! three grids are regular. When the fields are read in, nothing +! is done to mass variables, but wind variables are interpolated to +! mass points. +! +! program history log: +! 2014-12-23 Hu +! +! input argument list: +! mype - pe number +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,r_single,i_kind + use mpimod, only: mpi_sum,mpi_integer,mpi_real4,mpi_comm_world,npe,ierror + use mpimod, only: npe + use guess_grids, only: nfldsig,ifilesig,ntguessig + use gridmod, only: lat2,lon2,nlat_regional,nlon_regional,nlon, nlat,& + nsig,nsig_soil,ijn_s,displs_s,eta1_ll,pt_ll,itotsub,aeta1_ll + use constants, only: zero,one,grav,fv,zero_single,rd_over_cp_mass,one_tenth,r10,r100 + use constants, only: r0_01, tiny_r_kind + use gsi_io, only: lendian_in + use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info + use general_sub2grid_mod, only: general_grid2sub,general_sub2grid + use gsi_bundlemod, only: GSI_BundleGetPointer + use gsi_metguess_mod, only: gsi_metguess_get,GSI_MetGuess_Bundle + use mpeu_util, only: die + use mod_wrfmass_to_a, only: wrfmass_h_to_a4 + + implicit none + +! Declare passed variables + integer(i_kind),intent(in):: mype + +! Declare local parameters + real(r_kind),parameter:: rough_default=0.05_r_kind + character(len=*),parameter::myname='read_wrf_mass_netcdf_guess::' + +! Declare local variables + + real(r_kind), pointer :: ges_ps_it (:,: )=>NULL() + real(r_kind), pointer :: ges_z_it (:,: )=>NULL() + + real(r_kind) :: ges_vpt_it (lat2,lon2 ) + real(r_kind) :: ges_q_integralc4h_it(lat2,lon2 ) +! other internal variables + type(sub2grid_info) grd + real(r_single),allocatable::temp1(:,:) + character(6) filename + integer(i_kind) ifld,im,jm,lm,num_mass_fields + integer(i_kind) i,icount,icount_prev,it,j,k + real(r_kind) psfc_this,psfc_this_dry,sm_this,xice_this + real(r_kind),dimension(lat2,lon2):: q_integral + real(r_kind) deltasigma + real(r_kind):: work_prsl,work_prslk + integer(i_kind) ier, istatus + integer(i_kind) nguess + logical regional + logical,allocatable :: vector(:) + integer(i_kind) inner_vars,num_fields + real(r_kind),allocatable :: work_sub(:,:,:,:),work_reg(:,:,:,:) + real(r_single) :: ges_ps(lat2,lon2) + real(r_single) :: bb(nlon,nlat) + +! WRF MASS input grid dimensions in module gridmod +! These are the following: +! im -- number of x-points on C-grid +! jm -- number of y-points on C-grid +! lm -- number of vertical levels ( = nsig for now) + + if(mype==0) write(6,*)' at 0 in read_wrf_mass_guess4ens' + regional=.true. + +! Big section of operations done only on first outer iteration + + im=nlon_regional + jm=nlat_regional + lm=nsig + nfldsig=1 + + do it=1,nfldsig + write(filename,'("sigf",i2.2)') it + open(lendian_in,file=filename,form='unformatted') ; rewind lendian_in + write(6,*)'READ_WRF_MASS_GUESS: open lendian_in=',lendian_in,' to file=',filename + +! get pointers for typical meteorological fields + ier=0 + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it),'ps',ges_ps_it, & + istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it),'z', ges_z_it, & + istatus );ier=ier+istatus + if (ier/=0) call die(trim(myname),'cannot get pointers for met-fields,ier =',ier) +! +! skip some record + read(lendian_in) ! head + read(lendian_in) ! aeta1 + read(lendian_in) ! eta1 + read(lendian_in) ! glat,dx_mc + read(lendian_in) ! glon,dy_mc + + enddo +! + allocate(temp1(im,jm)) + + inner_vars=1 + num_fields=1 ! mu and qall + allocate(vector(num_fields)) + vector=.false. + call general_sub2grid_create_info(grd,inner_vars,nlat,nlon,1,num_fields,regional,vector) + allocate(work_reg(grd%nlat,grd%nlon,grd%kbegin_loc:grd%kend_alloc,1)) + allocate(work_sub(grd%lat2,grd%lon2,num_fields,1)) + +! read surface dry pressure: + read(lendian_in) ((temp1(i,j),i=1,im),j=1,jm) + if(nlon == nlon_regional .and. nlat == nlat_regional) then + bb=temp1 + else + call wrfmass_h_to_a4(temp1,bb) + endif + + do j=1,grd%nlat + do i=1,grd%nlon + work_reg(j,i,grd%kbegin_loc:grd%kend_alloc,1)=bb(i,j) + enddo + enddo +! next general_grid2sub to go to regional grid subdomains. + call general_grid2sub(grd,work_reg,work_sub) + ges_ps(:,:)=work_sub(:,:,1,1) + write(*,'(a,I5,2f15.7)') 'ges_ps=',mype,maxval(ges_ps_it), & + minval(ges_ps_it) + +! read qvapor total + read(lendian_in) ((temp1(i,j),i=1,im),j=1,jm) + if(nlon == nlon_regional .and. nlat == nlat_regional) then + bb=temp1 + else + call wrfmass_h_to_a4(temp1,bb) + endif + + do j=1,grd%nlat + do i=1,grd%nlon + work_reg(j,i,grd%kbegin_loc:grd%kend_alloc,1)=bb(i,j) + enddo + enddo +! next general_grid2sub to go to regional grid subdomains. + call general_grid2sub(grd,work_reg,work_sub) + ges_vpt_it(:,:)=real(work_sub(:,:,1,1),r_kind) + write(*,'(a,I5,2f15.7)') 'ges_vpt_it=',mype,maxval(ges_vpt_it), & + minval(ges_vpt_it) + +! read qvapor total: q_integralc4h + read(lendian_in) ((temp1(i,j),i=1,im),j=1,jm) + if(nlon == nlon_regional .and. nlat == nlat_regional) then + bb=temp1 + else + call wrfmass_h_to_a4(temp1,bb) + endif + + do j=1,grd%nlat + do i=1,grd%nlon + work_reg(j,i,grd%kbegin_loc:grd%kend_alloc,1)=bb(i,j) + enddo + enddo +! next general_grid2sub to go to regional grid subdomains. + call general_grid2sub(grd,work_reg,work_sub) + ges_q_integralc4h_it(:,:)=real(work_sub(:,:,1,1),r_kind) + write(*,'(a,I5,2f15.7)') 'ges_q_integralc4h_it=',mype, & + maxval(ges_q_integralc4h_it), minval(ges_q_integralc4h_it) + +! read topo + read(lendian_in) ((temp1(i,j),i=1,im),j=1,jm) + if(nlon == nlon_regional .and. nlat == nlat_regional) then + bb=temp1 + else + call wrfmass_h_to_a4(temp1,bb) + endif + + do j=1,grd%nlat + do i=1,grd%nlon + work_reg(j,i,grd%kbegin_loc:grd%kend_alloc,1)=bb(i,j) + enddo + enddo +! next general_grid2sub to go to regional grid subdomains. + call general_grid2sub(grd,work_reg,work_sub) + ges_z_it(:,:)=work_sub(:,:,1,1)/grav +! write(*,'(a,I5,2f15.7)') 'ges_z_it=',mype,maxval(ges_z_it), & +! minval(ges_z_it) + + close(lendian_in) + it=1 + do i=1,lon2 + do j=1,lat2 +! Convert psfc units of mb and then convert to log(psfc) in cb + psfc_this_dry=r0_01*ges_ps(j,i) + psfc_this=(psfc_this_dry-pt_ll)*ges_vpt_it(j,i)+pt_ll + & + ges_q_integralc4h_it(j,i) + ges_ps_it(j,i)=one_tenth*psfc_this ! convert from mb to cb + end do + end do +! write(*,*) 'final ps==',mype,maxval(ges_ps_it(:,:)),minval(ges_ps_it(:,:)) + + deallocate(work_reg) + deallocate(work_sub) + deallocate(temp1) + + return +end subroutine read_wrf_mass_netcdf_guess4ens +#else /* Start no WRF-library block */ +subroutine read_wrf_mass_netcdf_guess4ens(mype) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_wrf_mass_netcdf_guess +! prgmmr: +! +! abstract: +! +! program history log: +! 2009-12-07 lueken - added subprogram doc block and implicit none +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use kinds,only: i_kind + implicit none + integer(i_kind),intent(in)::mype + write(6,*)'READ_WRF_MASS_NETCDF_GUESS: dummy routine, does nothing!' +end subroutine read_wrf_mass_netcdf_guess4ens +#endif /* End no WRF-library block */ diff --git a/util/EnKF/arw/src/enspreproc_regional.fd/wrf_netcdf_interface4ens.F90 b/util/EnKF/arw/src/enspreproc_regional.fd/wrf_netcdf_interface4ens.F90 new file mode 100755 index 000000000..10fd65b3c --- /dev/null +++ b/util/EnKF/arw/src/enspreproc_regional.fd/wrf_netcdf_interface4ens.F90 @@ -0,0 +1,1283 @@ +#ifdef WRF +subroutine read_netcdf_mass4ens +!$$$ subprogram documentation block +! . . . . +! subprogram: read_netcdf_mass read wrf mass netcdf restart +! prgmmr: parrish org: np22 date: 2003-09-05 +! +! abstract: using wrf library routines, read a wrf mass core netcdf +! format restart file. write the result to temporary netcdf +! file expected by read_wrf_mass_guess. +! +! program history log: +! 2014-12-18 parrish +! +! input argument list: +! +! output argument list: +! +! NOTES: this is beginning of allowing direct connection of gsi to wrf files +! without seperate external interface. it is very inefficient, and +! later versions will be made to reduce the total i/o involved. +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + use kinds, only: r_single,i_kind, r_kind + use constants, only: h300,one,r0_01,zero + use gsi_4dvar, only: nhr_assimilation + use rapidrefresh_cldsurf_mod, only: l_hydrometeor_bkio,l_gsd_soilTQ_nudge + use gsi_metguess_mod, only: gsi_metguess_get + use gridmod, only: wrf_mass_hybridcord + + implicit none + +! Declare local parameters + real(r_single),parameter:: one_single = 1.0_r_single + real(r_single),parameter:: r45 = 45.0_r_single + + character(len=120) :: flnm1 + character(len=19) :: DateStr1 + character(len=6) :: filename + integer(i_kind) :: dh1 + + integer(i_kind) :: iunit + + integer(i_kind) :: i,j,k + integer(i_kind) :: ndim1 + integer(i_kind) :: WrfType + integer(i_kind), dimension(4) :: start_index, end_index + character (len= 4) :: staggering=' N/A' + character (len= 3) :: ordering + + character (len=80), dimension(3) :: dimnames + character (len=80) :: SysDepInfo + + integer(i_kind) :: nguess, ierr, Status, Status_next_time, n + +! binary stuff + +! rmse stuff + + character (len=31) :: rmse_var + integer(i_kind) iyear,imonth,iday,ihour,iminute,isecond + integer(i_kind) nlon_regional,nlat_regional,nsig_regional,nsig_soil_regional + real(r_single) pt_regional + real(r_single) rdx,rdy + real(r_single),allocatable::field3(:,:,:),field2(:,:),field1(:),field2b(:,:),field2c(:,:) + real(r_single),allocatable::field3u(:,:,:),field3v(:,:,:),field1a(:) + real(r_single),allocatable::eta2_ll(:) + integer(i_kind),allocatable::ifield2(:,:) + real(r_single) rad2deg_single + integer(i_kind) wrf_real + real(r_kind),allocatable :: q_integral(:,:) + real(r_kind),allocatable :: q_integralc4h(:,:) + real(r_kind) deltasigma + real(r_kind) deltasigmac4h + data iunit / 15 / + + wrf_real=104 + end_index=0 + start_index=0 + +! transfer code from diffwrf for converting netcdf wrf nmm restart file +! to temporary binary format + + call ext_ncd_ioinit(sysdepinfo,status) + call set_wrf_debug_level ( 5 ) + + nhr_assimilation=1 + n_loop: do n=1,1 ! loop over forecast hours in assim interval + + if(n==nhr_assimilation)then + flnm1 = 'wrf_inout' + else + write(flnm1,'("wrf_inou",i1.1)')n + endif + + call ext_ncd_open_for_read( trim(flnm1), 0, 0, "", dh1, Status) + if(n==nhr_assimilation)then + if ( Status /= 0 )then + write(6,*)'CONVERT_NETCDF_MASS: problem with flnm1 = ',& + trim(flnm1),', Status = ', Status + call stop2(74) + endif + else + if ( Status /= 0 )then + write(6,*)'CONVERT_NETCDF_MASS: problem with flnm1 = ',& + trim(flnm1),', Status = ', Status + cycle n_loop + endif + endif + + + write(filename,'("sigf",i2.2)') n + open(iunit,file=filename,form='unformatted') + + write(6,*)' dh1 = ',dh1 !DEDE + +!------------- get date info + + call ext_ncd_get_next_time(dh1, DateStr1, Status_next_time) + read(DateStr1,'(i4,1x,i2,1x,i2,1x,i2,1x,i2,1x,i2)') iyear,imonth,iday,ihour,iminute,isecond + write(6,*)' iy,m,d,h,m,s=',iyear,imonth,iday,ihour,iminute,isecond + +! write(6,*)' dh1 = ',dh1 !DEDE + +!------------- get grid info + rmse_var='SMOIS' + + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) !DEDE + + write(6,*)' dh1 = ',dh1 !DEDE + write(6,*)'rmse_var = ',trim(rmse_var) + write(6,*)'ndim1 = ',ndim1 + write(6,*)'ordering = ',trim(ordering) + write(6,*)'staggering = ',trim(staggering) + write(6,*)'start_index = ',start_index + write(6,*)'end_index = ',end_index + write(6,*)'WrfType = ',WrfType + write(6,*)'ierr = ',ierr !DEDE + + nlon_regional=end_index(1) + nlat_regional=end_index(2) + nsig_soil_regional=end_index(3) + + rmse_var='T' + + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) !DEDE + + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1 = ',ndim1,' dh1 = ',dh1 + write(6,*)' WrfType = ',WrfType,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + + nlon_regional=end_index(1) + nlat_regional=end_index(2) + nsig_regional=end_index(3) + write(6,*)' nlon,lat,sig_regional=',nlon_regional,nlat_regional,nsig_regional + allocate(field2(nlon_regional,nlat_regional),field3(nlon_regional,nlat_regional,nsig_regional+1)) + allocate(field2b(nlon_regional,nlat_regional),field2c(nlon_regional,nlat_regional)) + allocate(ifield2(nlon_regional,nlat_regional)) + allocate(q_integral(nlon_regional,nlat_regional)) + allocate(q_integralc4h(nlon_regional,nlat_regional)) + allocate(field1(max(nlon_regional,nlat_regional,nsig_regional))) + allocate(field1a(max(nlon_regional,nlat_regional,nsig_regional))) + allocate(eta2_ll(nsig_regional+1)) + + rmse_var='P_TOP' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + pt_regional,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + write(6,*)' p_top=',pt_regional + + write(iunit) iyear,imonth,iday,ihour,iminute,isecond, & + nlon_regional,nlat_regional,nsig_regional,pt_regional,nsig_soil_regional + + if(wrf_mass_hybridcord) then + rmse_var='C3H' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering,& + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + do k=1,nsig_regional + write(6,*)' k,c3h(k)=',k,field1(k) + end do + rmse_var='C4H' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering,& + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1a,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + do k=1,nsig_regional + write(6,*)' k,c4h(k)=',k,field1a(k) + end do + write(iunit)field1(1:nsig_regional),field1a(1:nsig_regional) ! c3h,c4h + + rmse_var='C3F' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering,& + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + do k=1,nsig_regional+1 + write(6,*)' k,c3f(k)=',k,field1(k) + end do + rmse_var='C4F' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering,& + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1a,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + do k=1,nsig_regional+1 + write(6,*)' k,c3f(k)=',k,field1a(k) + end do + write(iunit)field1(1:nsig_regional+1),field1a(1:nsig_regional+1) !c3f,c4f + eta2_ll=field1a(1:nsig_regional+1)*r0_01 + else + + rmse_var='ZNU' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering,& + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + do k=1,nsig_regional + write(6,*)' k,znu(k)=',k,field1(k) + end do + field1a=0.0_r_single + write(iunit)field1(1:nsig_regional),field1a(1:nsig_regional) ! ZNU + + rmse_var='ZNW' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering,& + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr + write(6,*)' ordering = ',trim(ordering),' staggering =',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field1,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + do k=1,nsig_regional+1 + write(6,*)' k,znw(k)=',k,field1(k) + end do + field1a=0.0_r_single + write(iunit)field1(1:nsig_regional+1),field1a(1:nsig_regional+1) ! ZNW + endif + + rmse_var='RDX' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + rdx,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + write(6,*)' 1/rdx=',one_single/rdx + + rmse_var='RDY' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + rdy,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + write(6,*)' 1/rdy=',one_single/rdy + + rmse_var='MAPFAC_M' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + write(6,*)' max,min mapfac_m=',maxval(field2),minval(field2) + write(6,*)' max,min MAPFAC_M(:,1)=',maxval(field2(:,1)),minval(field2(:,1)) + write(6,*)' max,min MAPFAC_M(1,:)=',maxval(field2(1,:)),minval(field2(1,:)) + write(6,*)' mapfac_m(1,1),mapfac_m(nlon,1)=',field2(1,1),field2(nlon_regional,1) + write(6,*)' mapfac_m(1,nlat),mapfac_m(nlon,nlat)=', & + field2(1,nlat_regional),field2(nlon_regional,nlat_regional) + field2b=one_single/(field2*rdx) !DX_MC + field2c=one_single/(field2*rdy) !DY_MC + + rad2deg_single=r45/atan(one_single) + rmse_var='XLAT' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + write(6,*)' max,min XLAT(:,1)=',maxval(field2(:,1)),minval(field2(:,1)) + write(6,*)' max,min XLAT(1,:)=',maxval(field2(1,:)),minval(field2(1,:)) + write(6,*)' xlat(1,1),xlat(nlon,1)=',field2(1,1),field2(nlon_regional,1) + write(6,*)' xlat(1,nlat),xlat(nlon,nlat)=', & + field2(1,nlat_regional),field2(nlon_regional,nlat_regional) + field2=field2/rad2deg_single + write(iunit)field2,field2b !XLAT,DX_MC + + rmse_var='XLONG' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + write(6,*)' max,min XLONG(:,1)=',maxval(field2(:,1)),minval(field2(:,1)) + write(6,*)' max,min XLONG(1,:)=',maxval(field2(1,:)),minval(field2(1,:)) + write(6,*)' xlong(1,1),xlong(nlon,1)=',field2(1,1),field2(nlon_regional,1) + write(6,*)' xlong(1,nlat),xlong(nlon,nlat)=', & + field2(1,nlat_regional),field2(nlon_regional,nlat_regional) + field2=field2/rad2deg_single + write(iunit)field2,field2c !XLONG,DY_MC + + rmse_var='MUB' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + write(6,*)' max,min MUB=',maxval(field2),minval(field2) + + rmse_var='MU' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field2b,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + write(6,*)' max,min MU=',maxval(field2b),minval(field2b) + field2=field2b+field2+pt_regional + write(6,*)' max,min psfc0=',maxval(field2),minval(field2) + write(iunit)field2 ! psfc0 + + rmse_var='QVAPOR' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + q_integral=one + q_integralc4h=zero + do k=1,nsig_regional + write(6,*)' k,max,min,mid q=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + if(wrf_mass_hybridcord) then + deltasigmac4h=eta2_ll(k)-eta2_ll(k+1) + do j=1,nlat_regional + do i=1,nlon_regional + q_integralc4h(i,j) = q_integralc4h(i,j)+deltasigmac4h*field3(i,j,k) + enddo + enddo + endif + deltasigma = field1(k)-field1(k+1) + do j=1,nlat_regional + do i=1,nlon_regional + q_integral(i,j)=q_integral(i,j) + deltasigma * field3(i,j,k) + enddo + enddo + enddo + field2=q_integral + write(6,*)' k,max,min,mid qall=',k,maxval(field2(:,:)),minval(field2(:,:)), & + field2(nlon_regional/2,nlat_regional/2) + write(iunit)((field2(i,j),i=1,nlon_regional),j=1,nlat_regional) + write(iunit)((real(q_integralc4h(i,j)),i=1,nlon_regional),j=1,nlat_regional) + + rmse_var='PHB' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + k=1 + write(6,*)' k,max,min,mid PHB=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + write(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) !PHB (zsfc*g) + + rmse_var='T' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(6,*)' rmse_var = ',trim(rmse_var),' ndim1=',ndim1 + write(6,*)' WrfType = ',WrfType,' WRF_REAL=',WRF_REAL,'ierr = ',ierr !DEDE + write(6,*)' ordering = ',trim(ordering),' staggering = ',trim(staggering) + write(6,*)' start_index = ',start_index,' end_index = ',end_index + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + field3=field3+h300 + do k=1,nsig_regional + write(6,*)' k,max,min,mid T=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + write(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! POT TEMP (sensible??) + end do + + deallocate(field1,field2,field2b,field2c,ifield2,field3) + close(iunit) + call ext_ncd_ioclose(dh1, Status) + + enddo n_loop + +end subroutine read_netcdf_mass4ens + +subroutine update_netcdf_mass4ens +!$$$ subprogram documentation block +! . . . . +! subprogram: update_netcdf_mass create netcdf format wrf restart file from internal binary file. +! prgmmr: +! +! abstract: create netcdf format wrf restart file from internal binary file +! +! program history log: +! 2004-11-05 treadon - add return code 75 for error stop +! 2004-12-15 treadon - remove get_lun, read guess from file "wrf_inout" +! 2005-12-09 middlecoff - initialize character variable staggering and removed staggering1,staggering2 +! 2006-04-06 middlecoff - added read of SM and SICE to match the writes in wrwrfmass.F90 +! and read in the rest of the fields to match the writes in wrwrfmass.F90 +! 2006-06-09 liu - bug fix: replace SM and SICE with SMOIS and XICE +! 2009-08-14 lueken - update documentation +! 2010-03-29 Hu - add code to update 5 cloud/hydrometeor variables for cloud analysis +! 2008-03-29 Hu - bug fix: replace XICE with SEAICE and +! comment out update for SMOIS (the actually +! variable is Landmask there). +! 2012-01-09 Hu - add code to update START_TIME to analysis time +! 2012-04-13 Whitaker - clip positive definite quantities to tiny_single +! 2014-03-12 hu - add code to read ges_q2 (2m Q), +! Qnr(rain number concentration), +! and nsoil (number of soil levels) +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_single,i_kind,r_kind + use constants, only: h300,tiny_single + use rapidrefresh_cldsurf_mod, only: l_hydrometeor_bkio,l_gsd_soilTQ_nudge + use gsi_metguess_mod, only: gsi_metguess_get,GSI_MetGuess_Bundle + use gsi_bundlemod, only: GSI_BundleGetPointer + use guess_grids, only: ntguessig + use obsmod, only: iadate + + implicit none + + include 'netcdf.inc' + +! Declare local parameters + + character(len=120) :: flnm1,flnm2 + character(len=19) :: DateStr1 + integer(i_kind) :: dh1,iw3jdn + + integer(i_kind) :: iunit + + integer(i_kind) :: i,j,k + integer(i_kind) :: ndim1 + integer(i_kind) :: WrfType + integer(i_kind), dimension(4) :: start_index, end_index1 + character (len= 4) :: staggering=' N/A' + character (len= 3) :: ordering + + character (len=80), dimension(3) :: dimnames + character (len=80) :: SysDepInfo + + + integer(i_kind) :: it, nguess, ierr, istatus, Status, Status_next_time + real(r_kind), pointer :: ges_qc(:,:,:) + real(r_kind), pointer :: ges_qi(:,:,:) + real(r_kind), pointer :: ges_qr(:,:,:) + real(r_kind), pointer :: ges_qs(:,:,:) + real(r_kind), pointer :: ges_qg(:,:,:) + +! binary stuff + +! rmse stuff + + character (len=31) :: rmse_var + + integer(i_kind) iyear,imonth,iday,ihour,iminute,isecond + integer(i_kind) nlon_regional,nlat_regional,nsig_regional,nsig_soil_regional + real(r_single) pt_regional,pdtop_regional,dy_nmm + real(r_single),allocatable::field3(:,:,:),field2(:,:),field1(:),field2b(:,:) + real(r_single),allocatable::field3u(:,:,:),field3v(:,:,:) + integer(i_kind),allocatable::ifield2(:,:) + integer(i_kind) wrf_real + data iunit / 15 / + wrf_real=104 + end_index1=0 + +! Inquire about guess fields + call gsi_metguess_get('dim',nguess,ierr) + if (nguess>0) then +! get pointer to relevant instance of cloud-related backgroud + it=ntguessig + ierr=0 + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql', ges_qc, istatus );ierr=ierr+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qi', ges_qi, istatus );ierr=ierr+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qr', ges_qr, istatus );ierr=ierr+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qs', ges_qs, istatus );ierr=ierr+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qg', ges_qg, istatus );ierr=ierr+istatus + if (ierr/=0) nguess=0 + end if + +! transfer code from diffwrf for converting netcdf wrf nmm restart file +! to temporary binary format + +! +! update mass core netcdf file with analysis variables from 3dvar +! + flnm1='wrf_inout' + call ext_ncd_open_for_update( trim(flnm1), 0, 0, "", dh1, Status) + if ( Status /= 0 )then + write(6,*)'UPDATE_NETCDF_MASS: problem with flnm1 = ',& + trim(flnm1),', Status = ', Status + call stop2(75) + endif + + + close(51) + flnm2='siganl' + open(iunit,file=flnm2,form='unformatted') + + +!------------- get date info + + call ext_ncd_get_next_time(dh1, DateStr1, Status_next_time) + read(DateStr1,'(i4,1x,i2,1x,i2,1x,i2,1x,i2,1x,i2)') iyear,imonth,iday,ihour,iminute,isecond + write(6,*)' iy,m,d,h,m,s=',iyear,imonth,iday,ihour,iminute,isecond + +!------------- get grid info + rmse_var='SMOIS' + call ext_ncd_get_var_info (dh1,rmse_var,ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + nlon_regional=end_index1(1) + nlat_regional=end_index1(2) + nsig_soil_regional=end_index1(3) + + rmse_var='T' + call ext_ncd_get_var_info (dh1,rmse_var,ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + nlon_regional=end_index1(1) + nlat_regional=end_index1(2) + nsig_regional=end_index1(3) + write(6,*)' nlon,lat,sig_regional=',nlon_regional,nlat_regional,nsig_regional + allocate(field2(nlon_regional,nlat_regional),field3(nlon_regional,nlat_regional,nsig_regional)) + allocate(field3u(nlon_regional+1,nlat_regional,nsig_regional)) + allocate(field3v(nlon_regional,nlat_regional+1,nsig_regional)) + allocate(field2b(nlon_regional,nlat_regional)) + allocate(ifield2(nlon_regional,nlat_regional)) + allocate(field1(max(nlon_regional,nlat_regional,nsig_regional))) + + rmse_var='P_TOP' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + pt_regional,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + write(6,*)' p_top=',pt_regional + read(iunit) ! iyear,imonth,iday,ihour,iminute,isecond, & +! nlon_regional,nlat_regional,nsig_regional,pt_regional + + read(iunit) ! field1(1:nsig_regional) ! AETA1 (ZNU) + + read(iunit) ! field1(1:nsig_regional+1) ! ETA1 (ZNW) + + read(iunit) ! field2 !XLAT,DX_MC + + read(iunit) ! field2 !XLONG,DY_MC + + rmse_var='MUB' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + write(6,*)' max,min MUB=',maxval(field2),minval(field2) + + read(iunit) field2b !psfc + write(6,*)' max,min psfc=',maxval(field2b),minval(field2b) + field2b=field2b-field2-pt_regional + write(6,*)' max,min MU=',maxval(field2b),minval(field2b) + rmse_var='MU' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field2b,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + read(iunit) ! field2 ! PHB (FIS) + + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! T + write(6,*)' k,max,min,mid T=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + field3=field3-h300 + rmse_var='T' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! Q + write(6,*)' k,max,min,mid Q=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='QVAPOR' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + where (field3 < tiny_single) field3 = tiny_single + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_regional + read(iunit)((field3u(i,j,k),i=1,nlon_regional+1),j=1,nlat_regional) ! U + write(6,*)' k,max,min,mid U=',k,maxval(field3u(:,:,k)),minval(field3u(:,:,k)), & + field3u(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='U' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3u,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_regional + read(iunit)((field3v(i,j,k),i=1,nlon_regional),j=1,nlat_regional+1) ! V + write(6,*)' k,max,min,mid V=',k,maxval(field3v(:,:,k)),minval(field3v(:,:,k)), & + field3v(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='V' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3v,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + read(iunit) field2 ! LANDMASK + write(6,*)'max,min LANDMASK=',maxval(field2),minval(field2) + + read(iunit) field2 ! SEAICE + write(6,*)'max,min SEAICE=',maxval(field2),minval(field2) + rmse_var='SEAICE' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + read(iunit) field2 !SST + write(6,*)' max,min SST=',maxval(field2),minval(field2) + rmse_var='SST' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + +! Read in the rest of the fields + if(l_gsd_soilTQ_nudge) then + do k=4,9 + read(iunit) field2 !Rest of the fields + write(6,*)'read max,min REST',k,maxval(field2),minval(field2) + end do + + do k=1,nsig_soil_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! smois + write(6,*)' k,max,min,mid SMOIS=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='SMOIS' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_soil_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! tslb + write(6,*)' k,max,min,mid TSLB=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='TSLB' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + else + do k=4,11 ! corrected according to Ming Hu's finding + + read(iunit) field2 !Rest of the fields + write(6,*)'read max,min REST',k,maxval(field2),minval(field2) + end do + endif + + read(iunit) field2 !TSK + write(6,*)' max,min TSK=',maxval(field2),minval(field2) + rmse_var='TSK' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + read(iunit) field2 !Q2 + write(6,*)' max,min Q2=',maxval(field2),minval(field2) + rmse_var='Q2' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + if(l_gsd_soilTQ_nudge) then + read(iunit) field2 !SOILT1 + write(6,*)' max,min SOILT1 d=',maxval(field2),minval(field2) + rmse_var='SOILT1' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + read(iunit) field2 !TH2 + write(6,*)' max,min TH2 d=',maxval(field2),minval(field2) + rmse_var='TH2' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field2,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + endif + + if (l_hydrometeor_bkio .or. nguess>0) then + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! Qc + write(6,*)' k,max,min,mid Qc=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='QCLOUD' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + where (field3 < tiny_single) field3 = tiny_single + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! Qr + write(6,*)' k,max,min,mid Qr=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='QRAIN' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + where (field3 < tiny_single) field3 = tiny_single + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! Qs + write(6,*)' k,max,min,mid Qs=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='QSNOW' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + where (field3 < tiny_single) field3 = tiny_single + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! Qi + write(6,*)' k,max,min,mid Qi=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='QICE' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + where (field3 < tiny_single) field3 = tiny_single + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! Qg + write(6,*)' k,max,min,mid Qg=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='QGRAUP' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + where (field3 < tiny_single) field3 = tiny_single + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! Qnr + write(6,*)' k,max,min,mid Qnr=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='QNRAIN' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + where (field3 < tiny_single) field3 = tiny_single + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + do k=1,nsig_regional + read(iunit)((field3(i,j,k),i=1,nlon_regional),j=1,nlat_regional) ! TTEN + write(6,*)' k,max,min,mid TTEN=',k,maxval(field3(:,:,k)),minval(field3(:,:,k)), & + field3(nlon_regional/2,nlat_regional/2,k) + end do + rmse_var='RAD_TTEN_DFI' + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index1, WrfType, ierr ) + write(6,*)' rmse_var=',trim(rmse_var) + write(6,*)' ordering=',ordering + write(6,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(6,*)' ndim1=',ndim1 + write(6,*)' staggering=',staggering + write(6,*)' start_index=',start_index + write(6,*)' end_index1=',end_index1 + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index1, & !dom + start_index,end_index1, & !mem + start_index,end_index1, & !pat + ierr ) + + endif ! l_hydrometeor_bkio + + deallocate(field1,field2,field2b,ifield2,field3,field3u,field3v) + call ext_ncd_ioclose(dh1, Status) + close(iunit) + ! + ! reopen, update global attributes. + ! + ierr = NF_OPEN(trim(flnm1), NF_WRITE, dh1) + IF (ierr .NE. NF_NOERR) print *, 'OPEN ',NF_STRERROR(ierr) + ierr = NF_PUT_ATT_TEXT(dh1,NF_GLOBAL,'START_DATE',len_trim(DateStr1),DateStr1) + IF (ierr .NE. NF_NOERR) print *,'PUT START_DATE', NF_STRERROR(ierr) + ierr = NF_PUT_ATT_TEXT(dh1,NF_GLOBAL,'SIMULATION_START_DATE',len_trim(DateStr1),DateStr1) + IF (ierr .NE. NF_NOERR) print *,'PUT SIMULATION_START_DATE', NF_STRERROR(ierr) + ierr = NF_PUT_ATT_REAL(dh1,NF_GLOBAL,'GMT',NF_FLOAT,1,float(iadate(4))) + IF (ierr .NE. NF_NOERR) print *,'PUT GMT', NF_STRERROR(ierr) + ierr = NF_PUT_ATT_INT(dh1,NF_GLOBAL,'JULYR',NF_INT,1,iadate(1)) + IF (ierr .NE. NF_NOERR) print *,'PUT JULYR', NF_STRERROR(ierr) + ierr=NF_PUT_ATT_INT(dh1,NF_GLOBAL,'JULDAY',NF_INT,1,iw3jdn(iyear,imonth,iday)-iw3jdn(iyear,1,1)+1) + IF (ierr .NE. NF_NOERR) print *,'PUT JULDAY', NF_STRERROR(ierr) + ierr = NF_CLOSE(dh1) + IF (ierr .NE. NF_NOERR) print *, 'CLOSE ',NF_STRERROR(ierr) + +end subroutine update_netcdf_mass4ens + +#else /* Start no WRF-library block */ + +subroutine read_netcdf_mass4ens +!$$$ subprogram documentation block +! . . . . +! subprogram: convert_netcdf_mass +! pgrmmr: +! +! abstract: dummy call... does nothing +! +! program history log: +! 2009-08-14 lueken - added subprogram doc block +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + implicit none + + write(6,*)'CONVERT_NETCDF_MASS: ***WARNING*** dummy call ... does nothing!' + return +end subroutine read_netcdf_mass4ens + +subroutine update_netcdf_mass4ens +!$$$ subprogram documentation block +! . . . . +! subprogram: update_netcdf_mass +! pgrmmr: +! +! abstract: dummy call... does nothing +! +! program history log: +! 2009-08-14 lueken - added subprogram doc block +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + implicit none + + write(6,*)'UPDATE_NETCDF_MASS: ***WARNING*** dummy call ... does nothing!' + return +end subroutine update_netcdf_mass4ens + +#endif /* end NO WRF-library block */ + diff --git a/util/EnKF/arw/src/initialens_regional.fd/CMakeLists.txt b/util/EnKF/arw/src/initialens_regional.fd/CMakeLists.txt new file mode 100644 index 000000000..f2064c73b --- /dev/null +++ b/util/EnKF/arw/src/initialens_regional.fd/CMakeLists.txt @@ -0,0 +1,12 @@ +cmake_minimum_required(VERSION 2.6) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) + include_directories( "${PROJECT_BINARY_DIR}/include" ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ) + + add_executable(initialens.x ${LOCAL_SRC} ) + set_target_properties( initialens.x PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) + target_link_libraries( initialens.x ${GSISHAREDLIB} ${GSILIB} ${GSISHAREDLIB} ${WRF_LIBRARIES} + ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_LIBRARIES} + ${LAPACK_LIBRARIES} -L./ ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${CORE_LIBRARIES} ${CORE_BUILT} + ${GSI_LDFLAGS} ${NCDIAG_LIBRARIES} ${ZLIB_LIBRARIES} ${wrflib} ) + add_dependencies(initialens.x ${GSILIB}) diff --git a/util/EnKF/arw/src/initialens_regional.fd/initial_arw_ens.f90 b/util/EnKF/arw/src/initialens_regional.fd/initial_arw_ens.f90 new file mode 100644 index 000000000..55aa44ac2 --- /dev/null +++ b/util/EnKF/arw/src/initialens_regional.fd/initial_arw_ens.f90 @@ -0,0 +1,322 @@ +program initial_arw_ens +!$$$ subprogram documentation block +! . . . . +! subprogram: initial_arw_ens +! prgmmr: Hu org: GSD date: 2015-03-24 +! +! abstract: read pertubations on ARW A grid and generate initial files for ARW +! ensembles +! +! +! program history log: +! 2015-03-23 Hu , initial documentation +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: zeus +! +!$$$ end documentation block + + use mpimod, only: npe,mpi_comm_world,ierror,mype + use mpeu_util, only: die + use kinds, only: r_kind,i_kind,r_single + use constants, only : half +! use constants, only : max_varname_length + implicit none + INCLUDE 'netcdf.inc' + + integer(i_kind),parameter :: max_varname_length=12 + integer :: n_ens + integer(i_kind),allocatable :: beginmem(:),endmem(:) + integer :: nlon,nlat,nsig,num_fields + integer(i_kind) :: nc2d,nc3d + character(len=max_varname_length),allocatable,dimension(:) :: cvars2d + character(len=max_varname_length),allocatable,dimension(:) :: cvars3d + + real(r_single),allocatable,dimension(:,:,:)::en_perts + real(r_kind),dimension(:,:),allocatable:: workh + + real(r_single),allocatable,dimension(:,:,:):: field3 + +! Declare netcdf parameters + + character(len=120) :: flnm1 + character(len=120) :: flnm_new + character(len=19) :: DateStr1 + integer(i_kind) :: dh1 + integer(i_kind) :: dh2 + + integer(i_kind) :: Status, Status_next_time + integer(i_kind) :: iyear,imonth,iday,ihour,iminute,isecond + integer(i_kind) :: iw3jdn,JDATE(8),IDATE(8) + real(r_single) :: rinc(5), timediff + + character (len=80) :: SysDepInfo + character (len=31) :: rmse_var +! +! inflation factor +! + integer, parameter :: infltlvl=100 + real(r_single) :: infltnfct_t(infltlvl),infltnfct_uv(infltlvl),infltnfct_q(infltlvl),infltnfct_ps + real(r_single) :: infltnfct(100) +! +! Declare variables. +! + logical :: ifinflt_column + namelist/setup/ n_ens,ifinflt_column +! +! +! + integer(i_kind) i,j,k,n + integer(i_kind) ic2,ic3 + character(255) filename + integer(i_kind),dimension(4):: idate4 + integer(i_kind) im,i0 + + integer(i_kind) :: iunit,iout + integer :: ios + character(len=80) :: myname_ + character(len=80) :: filestdout + logical :: lexist +! +! +! MPI + call MPI_INIT(ierror) + call mpi_comm_size(mpi_comm_world,npe,ierror) + call mpi_comm_rank(mpi_comm_world,mype,ierror) +! + ifinflt_column=.false. + n_ens=0 +! + allocate(beginmem(npe),endmem(npe)) +! + iout=13 + write(filestdout,'(a,I4.4)') 'stdout_pe',mype+1 + open(iout,file=trim(filestdout)) + open(11,file='namelist.input') + read(11,setup,iostat=ios) + if(ios/=0) call die(myname_,'read(setup)',ios) + close(11) + if(n_ens > 0) then + write(iout,*) 'the ensemble member number==',n_ens + write(iout,*) 'if turn on vertical inflation factor is ==',ifinflt_column + else + write(iout,*) 'wrong ensemble member number==',n_ens + stop + endif +! + infltnfct=1.0_r_single +! + if(ifinflt_column) then + inquire(file='vertical_inflate_factor.txt',exist=lexist) + if(lexist) then + i=1 + open(10,file='vertical_inflate_factor.txt') + read(10,*) +100 continue + read(10,'(I10,f10.4)',end=110) k,infltnfct(i) + i=i+1 + goto 100 +110 continue + close(10) + endif + endif + infltnfct_t=infltnfct + infltnfct_uv=infltnfct + infltnfct_q=infltnfct + infltnfct_ps=infltnfct(1) +! +! figure out the begin and end of member for each core +! + n=n_ens/npe + k=mod(n_ens,npe) + beginmem(1)=1 + do i=1,npe + if(i>1) beginmem(i)=endmem(i-1)+1 + if(i<=k) then + endmem(i)=beginmem(i)+n + else + endmem(i)=beginmem(i)+n-1 + endif + enddo + write(iout,*) 'beginmem=',mype+1,beginmem(mype+1) + write(iout,*) 'endmem=',mype+1,endmem(mype+1) +! open netcdf file to read + call ext_ncd_ioinit(sysdepinfo,status) +! + flnm1='wrf_inout' + call ext_ncd_open_for_read( trim(flnm1), 0, 0, "", dh1, Status) + if ( Status /= 0 )then + write(iout,*)'save_soil_netcdf_mass: cannot open flnm1 = ',& + trim(flnm1),', Status = ', Status + stop 74 + endif +! +!------------- get date info from file read in + + call ext_ncd_get_next_time(dh1, DateStr1, Status_next_time) + read(DateStr1,'(i4,1x,i2,1x,i2,1x,i2,1x,i2,1x,i2)') & + iyear,imonth,iday,ihour,iminute,isecond + write(iout,'(a,6I5)')' read data from file at time (y,m,d,h,m,s):' & + ,iyear,imonth,iday,ihour,iminute,isecond +! +! get dimensions + iunit=20 + write(filename,'(a,I4.4)') 'en_perts4arw.mem',1 + write(iout,*) 'read dimension from ', trim(filename) + open(iunit,file=trim(filename),form='unformatted') + read(iunit) nc3d,nc2d + write(*,*) 'dimension is =',nc3d,nc2d + allocate(cvars3d(nc3d),cvars2d(nc2d)) + rewind(iunit) + read(iunit) nc3d,nc2d,cvars3d,cvars2d + read(iunit) nlat,nlon,nsig + close(iunit) + write(iout,*) 'nlat,nlon,nsig=',nlat,nlon,nsig + write(iout,'(I5,A10,10A6)') nc3d,'cvars3d=',(trim(cvars3d(ic3)),ic3=1,nc3d) + write(iout,'(I5,A10,10A6)') nc2d,'cvars2d=',(trim(cvars2d(ic2)),ic2=1,nc2d) + + num_fields=nc3d*nsig+nc2d + allocate(workh(nlat,nlon)) + allocate(en_perts(nlat,nlon,num_fields)) + +! check inflate factor + write(*,*) 'inflate factor' + write(*,'(4a10)') 'level','T', 'UV','q' + do k=1, nsig + write(*,'(I10,3f10.4)') k,infltnfct_t(k),infltnfct_uv(k),infltnfct_q(k) + enddo + write(*,'(a,f10.4)') 'surface pressure inflate factor=',infltnfct_ps + +! +! read perturbations +! + do n=beginmem(mype+1),endmem(mype+1) + + write(filename,'(a,I4.4)') 'en_perts4arw.mem',n + write(iout,*) + write(iout,*) 'read perturbations for ', trim(filename) + open(iunit,file=trim(filename),form='unformatted') + read(iunit) + read(iunit) + + do k=1,num_fields + + read(iunit) workh +! write(*,*) k,maxval(workh),minval(workh) + do j=1,nlon + do i=1,nlat + en_perts(i,j,k)=workh(i,j) + end do + end do + + end do + + close(iunit) + + write(flnm_new,'(a,I4.4)') 'wrfinput_d01.mem',n + call ext_ncd_open_for_update( trim(flnm_new), 0, 0, "", dh2, Status) + if ( Status /= 0 )then + write(iout,*)'gen_initial_ensemble: cannot open flnm = ',& + trim(flnm_new),', Status = ', Status + stop 74 + endif + + rmse_var='T' + allocate(field3(nlon,nlat,nsig)) + call read_netcdf_mass(dh1,DateStr1,rmse_var,field3,nlon,nlat,nsig,iout) + do k=1,nsig + do j=1,nlon + do i=1,nlat + field3(j,i,k)=field3(j,i,k)+en_perts(i,j,k+2*nsig)*infltnfct_t(k) + end do + end do + end do + call update_netcdf_mass(dh2,DateStr1,rmse_var,field3,nlon,nlat,nsig,iout) + deallocate(field3) + + rmse_var='U' + allocate(field3(nlon+1,nlat,nsig)) + call read_netcdf_mass(dh1,DateStr1,rmse_var,field3,nlon+1,nlat,nsig,iout) + do k=1,nsig + do j=1,nlon+1 + do i=1,nlat + im=max(1,j-1) + i0=min(nlon,j) + field3(j,i,k)=field3(j,i,k)+& + half*(en_perts(i,im,k)+en_perts(i,i0,k))*infltnfct_uv(k) + end do + end do + end do + call update_netcdf_mass(dh2,DateStr1,rmse_var,field3,nlon+1,nlat,nsig,iout) + deallocate(field3) + + rmse_var='V' + allocate(field3(nlon,nlat+1,nsig)) + call read_netcdf_mass(dh1,DateStr1,rmse_var,field3,nlon,nlat+1,nsig,iout) + do k=1,nsig + do j=1,nlon + do i=1,nlat+1 + im=max(1,i-1) + i0=min(nlon,i) + field3(j,i,k)=field3(j,i,k)+& + half*(en_perts(im,j,k)+en_perts(i0,j,k))*infltnfct_uv(k) + end do + end do + end do + call update_netcdf_mass(dh2,DateStr1,rmse_var,field3,nlon,nlat+1,nsig,iout) + deallocate(field3) + + rmse_var='QVAPOR' + allocate(field3(nlon,nlat,nsig)) + call read_netcdf_mass(dh1,DateStr1,rmse_var,field3,nlon,nlat,nsig,iout) + do k=1,nsig + do j=1,nlon + do i=1,nlat + field3(j,i,k)=field3(j,i,k)+en_perts(i,j,k+3*nsig)*infltnfct_q(k) + end do + end do + end do + call update_netcdf_mass(dh2,DateStr1,rmse_var,field3,nlon,nlat,nsig,iout) + deallocate(field3) + + rmse_var='MU' + allocate(field3(nlon,nlat,1)) + call read_netcdf_mass(dh1,DateStr1,rmse_var,field3,nlon,nlat,1,iout) + do k=1,1 + do j=1,nlon + do i=1,nlat + field3(j,i,k)=field3(j,i,k)+en_perts(i,j,k+6*nsig)*infltnfct_ps + end do + end do + end do + call update_netcdf_mass(dh2,DateStr1,rmse_var,field3,nlon,nlat,1,iout) + deallocate(field3) + + call ext_ncd_ioclose(dh2, Status) + enddo ! n + + deallocate(workh) +! + call ext_ncd_ioclose(dh1, Status) + + call mpi_finalize(ierror) + +end program initial_arw_ens + +SUBROUTINE wrf_debug( level , str ) + IMPLICIT NONE + CHARACTER*(*) str + INTEGER , INTENT (IN) :: level + INTEGER :: debug_level + CHARACTER (LEN=256) :: time_str + CHARACTER (LEN=256) :: grid_str + CHARACTER (LEN=512) :: out_str + write(*,*) 'wrf_debug called !' + RETURN +END SUBROUTINE wrf_debug + diff --git a/util/EnKF/arw/src/initialens_regional.fd/namelist.input b/util/EnKF/arw/src/initialens_regional.fd/namelist.input new file mode 100644 index 000000000..f0fcb8809 --- /dev/null +++ b/util/EnKF/arw/src/initialens_regional.fd/namelist.input @@ -0,0 +1,3 @@ + &SETUP + n_ens=5, + / diff --git a/util/EnKF/arw/src/initialens_regional.fd/read_netcdf_mass.f90 b/util/EnKF/arw/src/initialens_regional.fd/read_netcdf_mass.f90 new file mode 100755 index 000000000..ae8656885 --- /dev/null +++ b/util/EnKF/arw/src/initialens_regional.fd/read_netcdf_mass.f90 @@ -0,0 +1,95 @@ +subroutine read_netcdf_mass(dh1,DateStr1,rmse_var,field3,nlon,nlat,nsig,iout) +!$$$ documentation block +! . . . . +! update_netcdf_mass: read one variable from netcdf file and +! and write it into another netcdf file +! +! prgmmr: Ming Hu date: 2009-01-16 +! +! program history log: +! +! input argument list: +! dh1 : handle of file read in +! DateStr1 : time string of file read in +! rmse_var : variable updated +! +! attributes: +! language: f90 +! +!$$$ + + use kinds, only: r_single,i_kind, r_kind + implicit none + +! + integer(i_kind), intent(in) :: iout + integer(i_kind), intent(in) :: dh1 + character (len=31),intent(in) :: rmse_var + character(len=19), intent(in) :: DateStr1 + integer(i_kind), intent(in) :: nlon,nlat,nsig + real(r_single), intent(out) :: field3(nlon,nlat,nsig) + +! rmse stuff + integer(i_kind) :: ndim1 + integer(i_kind) :: WrfType + integer(i_kind), dimension(4) :: start_index, end_index + character (len= 4) :: staggering + character (len= 3) :: ordering + + character (len=80), dimension(3) :: dimnames + integer(i_kind) wrf_real + +! Declare local parameters + integer(i_kind) nlon_regional,nlat_regional,nsig_regional + + integer(i_kind) :: k + integer(i_kind) :: ierr +! +! +! + write(iout,*) + write(iout,*) ' ================== ' + write(iout,*) ' Read variable ', trim(rmse_var) + write(iout,*) ' ================== ' + + wrf_real=104_i_kind +!------------- get grid info + + end_index=0 + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(iout,*)' <<<<<<<<<<<<<< Read in data from dh1 = ',dh1 + write(iout,*)' rmse_var=',trim(rmse_var) + write(iout,*)' ordering=',ordering + write(iout,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(iout,*)' ndim1=',ndim1 + write(iout,*)' staggering=',staggering + write(iout,*)' start_index=',start_index + write(iout,*)' end_index=',end_index + write(iout,*)'ierr = ',ierr !DEDE + nlon_regional=end_index(1) + nlat_regional=end_index(2) + nsig_regional=end_index(3) + if(ndim1 == 2) nsig_regional=1 + if( nlon_regional /= nlon .or. & + nlat_regional /= nlat .or. & + nsig_regional /= nsig) then + + write(iout,*) 'update_netcdf_mass: Wrong dimension ' + stop 123 + endif + + call ext_ncd_read_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + +! do k=1,nsig_regional +! write(6,*)' max,min =',k,maxval(field3(:,:,k)),minval(field3(:,:,k)) +! enddo + +end subroutine read_netcdf_mass + diff --git a/util/EnKF/arw/src/initialens_regional.fd/update_netcdf_mass.f90 b/util/EnKF/arw/src/initialens_regional.fd/update_netcdf_mass.f90 new file mode 100755 index 000000000..f088d8dc6 --- /dev/null +++ b/util/EnKF/arw/src/initialens_regional.fd/update_netcdf_mass.f90 @@ -0,0 +1,95 @@ +subroutine update_netcdf_mass(dh1,DateStr1,rmse_var,field3,nlon,nlat,nsig,iout) +!$$$ documentation block +! . . . . +! update_netcdf_mass: read one variable from netcdf file and +! and write it into another netcdf file +! +! prgmmr: Ming Hu date: 2009-01-16 +! +! program history log: +! +! input argument list: +! dh1 : handle of file read in +! DateStr1 : time string of file read in +! rmse_var : variable updated +! +! attributes: +! language: f90 +! +!$$$ + + use kinds, only: r_single,i_kind, r_kind + implicit none + +! + integer(i_kind), intent(in) :: dh1 + integer(i_kind), intent(in) :: iout + character (len=31),intent(in) :: rmse_var + character(len=19), intent(in) :: DateStr1 + integer(i_kind), intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: field3(nlon,nlat,nsig) + +! rmse stuff + integer(i_kind) :: ndim1 + integer(i_kind) :: WrfType + integer(i_kind), dimension(4) :: start_index, end_index + character (len= 4) :: staggering + character (len= 3) :: ordering + + character (len=80), dimension(3) :: dimnames + integer(i_kind) wrf_real + +! Declare local parameters + integer(i_kind) nlon_regional,nlat_regional,nsig_regional + + integer(i_kind) :: k + integer(i_kind) :: ierr +! +! +! + write(iout,*) + write(iout,*) ' ================== ' + write(iout,*) ' write variable ', trim(rmse_var) + write(iout,*) ' ================== ' + +! do k=1,nsig +! write(6,*)' max,min =',k,maxval(field3(:,:,k)),minval(field3(:,:,k)) +! enddo + + wrf_real=104_i_kind +!------------- get grid info + + end_index=0 + call ext_ncd_get_var_info (dh1,trim(rmse_var),ndim1,ordering,staggering, & + start_index,end_index, WrfType, ierr ) + write(iout,*)' <<<<<<<<<<<<<< write in data to dh1 = ',dh1 + write(iout,*)' rmse_var=',trim(rmse_var) + write(iout,*)' ordering=',ordering + write(iout,*)' WrfType,WRF_REAL=',WrfType,WRF_REAL + write(iout,*)' ndim1=',ndim1 + write(iout,*)' staggering=',staggering + write(iout,*)' start_index=',start_index + write(iout,*)' end_index=',end_index + write(iout,*)'ierr = ',ierr !DEDE + nlon_regional=end_index(1) + nlat_regional=end_index(2) + nsig_regional=end_index(3) + if(ndim1 == 2) nsig_regional=1 + if( nlon_regional /= nlon .or. & + nlat_regional /= nlat .or. & + nsig_regional /= nsig) then + + write(iout,*) 'update_netcdf_mass: Wrong dimension ' + stop 123 + endif + + call ext_ncd_write_field(dh1,DateStr1,TRIM(rmse_var), & + field3,WRF_REAL,0,0,0,ordering, & + staggering, dimnames , & + start_index,end_index, & !dom + start_index,end_index, & !mem + start_index,end_index, & !pat + ierr ) + +end subroutine update_netcdf_mass + diff --git a/util/EnKF/gfs/src/adderrspec.fd/CMakeLists.txt b/util/EnKF/gfs/src/adderrspec.fd/CMakeLists.txt new file mode 100644 index 000000000..842712da0 --- /dev/null +++ b/util/EnKF/gfs/src/adderrspec.fd/CMakeLists.txt @@ -0,0 +1,10 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_UTIL) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + add_executable(adderrspec.x ${LOCAL_SRC} ) + set_target_properties( adderrspec.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( adderrspec.x ${W3EMC4INC} ${SIGIOINC} ${NEMSIOINC} ) + target_link_libraries( adderrspec.x ${SP_4_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${SIGIO_LIBRARY} ${MPI_Fortran_LIBRARIES} ${W3EMC_4_LIBRARY} ${W3NCO_4_LIBRARY} ) +endif() diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/adderrspec_nmcmeth_ncep_spec.f90 b/util/EnKF/gfs/src/adderrspec.fd/adderrspec_nmcmeth_ncep_spec.f90 similarity index 100% rename from util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/adderrspec_nmcmeth_ncep_spec.f90 rename to util/EnKF/gfs/src/adderrspec.fd/adderrspec_nmcmeth_ncep_spec.f90 diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/CMakeLists.txt b/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/CMakeLists.txt deleted file mode 100644 index c89edfdc7..000000000 --- a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/CMakeLists.txt +++ /dev/null @@ -1,11 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -if(BUILD_UTIL) - file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) - set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - add_executable(adderspec.x ${LOCAL_SRC} ) - set_target_properties( adderspec.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OMPFLAG}" ) - include_directories( ${CORE_INCS} ) - target_link_libraries( adderspec.x ${CORE_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) - add_dependencies( adderspec.x enkfdeplib enkflib ) -endif() diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile b/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile deleted file mode 100644 index a9577f0d2..000000000 --- a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile +++ /dev/null @@ -1,308 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# EnKF utility Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a EnKF utility executable file, type -# > make or > make all -# -# 2) To make a EnKF utility executable file with debug options, type -# > make debug -# -# 3) To copy the EnKF utility load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# 5) To create a library, libgsi.a, in the lib directory, type -# > make library -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - EXE_FILE = adderrspec_nmcmeth_spec.x - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../../exec - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = adderrspec_nmcmeth_ncep_spec.f90 - - SRCSF77 = - - SRCSC = - - SRCS = $(SRCSF90C) $(SRCSF77) $(SRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) - $(LD) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -library : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== CREATING LIBRARY ========================================' - $(MAKE) lib - mv $(LIB) ../lib - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.AIX b/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.AIX deleted file mode 100644 index 1e6406943..000000000 --- a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.AIX +++ /dev/null @@ -1,98 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -COREINC = /nwprod/lib/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 -INCw3 = $(COREINC)/w3_4 - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpxlf95_r - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -qsmp=noauto - - FFLAGS_F90 = -qfree=f90 -qsuffix=f=f90:cpp=F90 - - FFLAGS_COM_N = -I $(INCsigio) -I $(INCw3) -qarch=auto -O3 -qfullpath -qdbg -qstrict -q64 $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - - - -#--- Debug mode options - FFLAGS_COM_D = $(FFLAGS_COM_N) \ - -O0 -qdbg -qfullpath \ - -qsigtrap=xl__trcedump \ - -qinitauto=7FF7FFFF \ - -qflttrap=overflow:zero:enable \ - -qcheck \ - -qwarn64 \ - -qflag=i:i - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = ncepcc - -#--- Normal mode options - - CFLAGS_N = -I ./ -O3 - -#--- Debug mode options - - CFLAGS_D = -I ./ -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = -L/nwprod/lib -lsigio_4 -lsp_4 -lw3_4 - - LDFLAGS_N = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) $(PROF) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) -lhmd - - LDFLAGS_D = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.cray b/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.cray deleted file mode 100644 index 03f5e449e..000000000 --- a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.cray +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Redefine variables for Cray on WCOSS -# ------------------------------------ - -# Set library versions -BACIO_VER = v2.0.1 -BUFR_VER = v11.0.1 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.2 -NETCDF_VER = 3.6.3 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.2.0 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/include/crtm_$(CRTM_VER) -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/include/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/$(COMPILER)/libbufr_$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/libcrtm_$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDFPATH = /usrx/local/prod/NetCDF/$(NETCDF_VER)/$(COMPILER)/haswell -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -WRFPATH = /gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-$(COMPILER) -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ -DWRF - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.nco b/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.nco deleted file mode 100644 index 5244a7632..000000000 --- a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.nco +++ /dev/null @@ -1,76 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(SIGIO_INC4) -I $(W3EMC_INC4) -I $(NEMSIO_INC) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SIGIO_INC4) -I $(W3EMC_INC4) -I $(NEMSIO_INC) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SP_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) $(W3EMC_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.theia b/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.theia deleted file mode 100644 index 8c9f7d106..000000000 --- a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.theia +++ /dev/null @@ -1,89 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -BACIO_VER = 2.0.1 -NEMSIO_VER = 2.2.1 -SIGIO_VER = 2.0.1 -SP_VER = 2.0.2 -W3EMC_VER = 2.0.5 -W3NCO_VER = 2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib - -INCsigio = $(CORELIB)/sigio/v$(SIGIO_VER)/incmod/sigio_v$(SIGIO_VER)_4 -INCnemsio= $(CORELIB)/nemsio/v$(NEMSIO_VER)/incmod/nemsio_v$(NEMSIO_VER) -INCw3 = $(CORELIB)/w3emc/v$(W3EMC_VER)/incmod/w3emc_v$(W3EMC_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/v$(BACIO_VER)/libbacio_v$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/v$(NEMSIO_VER)/libnemsio_v$(NEMSIO_VER).a -SIGIO_LIB4=$(CORELIB)/sigio/v$(SIGIO_VER)/libsigio_v$(SIGIO_VER)_4.a -SP_LIB4=$(CORELIB)/sp/v$(SP_VER)/libsp_v$(SP_VER)_4.a -W3EMC_LIB4=$(CORELIB)/w3emc/v$(W3EMC_VER)/libw3emc_v$(W3EMC_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_4.a - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsigio) -I $(INCw3) -I $(INCnemsio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) $(W3EMC_LIB4) $(SIGIO_LIB4) $(SP_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.wcoss b/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.wcoss deleted file mode 100644 index 1ddfd9364..000000000 --- a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.wcoss +++ /dev/null @@ -1,95 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.0.5 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/incmod/sigio_$(SIGIO_VER)_4 -W3EMC_INC4=$(CORELIB)/w3emc/$(W3EMC_VER)/incmod/w3emc_$(W3EMC_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/libsigio_$(SIGIO_VER)_4.a -SP_LIB4=$(CORELIB)/sp/$(SP_VER)/libsp_$(SP_VER)_4.a -W3EMC_LIB4=$(CORELIB)/w3emc/$(W3EMC_VER)/libw3emc_$(W3EMC_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(SIGIO_INC4) -I $(W3EMC_INC4) -I $(NEMSIO_INC) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SIGIO_INC4) -I $(W3EMC_INC4) -I $(NEMSIO_INC) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SP_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) $(W3EMC_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.zeus b/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.zeus deleted file mode 100644 index c9ea5eefe..000000000 --- a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.conf.zeus +++ /dev/null @@ -1,75 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /contrib/nceplibs/nwprod/lib/incmod -CORELIB = /contrib/nceplibs/nwprod/lib -INCsigio = $(COREINC)/sigio_4 -INCw3 = $(COREINC)/w3emc_4 -INCnemsio= $(COREINC)/nemsio - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsigio) -I $(INCw3) -I $(INCnemsio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lnemsio -lbacio_4 -lw3nco_4 -lw3emc_4 -lsigio_4 -lsp_4 - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.dependency b/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.dependency deleted file mode 100644 index e0b13ca3c..000000000 --- a/util/EnKF/gfs/src/adderrspec_nmcmeth_spec.fd/Makefile.dependency +++ /dev/null @@ -1 +0,0 @@ -adderrspec_nmcmeth_ncep_spec.o : adderrspec_nmcmeth_ncep_spec.f90 diff --git a/util/EnKF/gfs/src/adjustps.fd/CMakeLists.txt b/util/EnKF/gfs/src/adjustps.fd/CMakeLists.txt new file mode 100644 index 000000000..32f6b7dec --- /dev/null +++ b/util/EnKF/gfs/src/adjustps.fd/CMakeLists.txt @@ -0,0 +1,10 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_UTIL) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + add_executable(adjustps.x ${LOCAL_SRC} ) + set_target_properties( adjustps.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS}) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${NEMSIOINC} ) + target_link_libraries( adjustps.x ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ) +endif() diff --git a/util/EnKF/gfs/src/adjustps.fd/adjustps.f90 b/util/EnKF/gfs/src/adjustps.fd/adjustps.f90 new file mode 100644 index 000000000..7d907b945 --- /dev/null +++ b/util/EnKF/gfs/src/adjustps.fd/adjustps.f90 @@ -0,0 +1,937 @@ +program adjustps +! +!ifort -I${NEMSIO_INC} adjustps.f90 ${NEMSIO_LIB} ${W3NCO_LIB4} ${BACIO_LIB4} +! +!$$$ main program documentation block +! +! program: adjustps +! +! prgmmr: whitaker org: esrl/psd date: 2017-11-02 +! +! abstract: change orography in file 1 to match file 2, adjust ps +! to new orography, interpolate 3d fields to new pressures, +! write out updated file. +! +! program history log: +! 2017-11-02 Initial version. +! +! usage: adjustps.x +! nlevt is optional - sets level index for Benjamin and Miller temperature +! that is used in pressure adjustment. +! +! attributes: +! language: f95 +! +!$$$ + + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close,nemsio_charkind + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrec,& + nemsio_writerec,nemsio_readrecv,nemsio_writerecv,nemsio_getrechead + + implicit none + + real,parameter:: zero=0.0_4, one=1.0_4 + + character*500 filename_1,filename_2,filename_o + character*3 charnlev + integer iret,latb,lonb,nlevs,npts,k,n,nlevt,idsl + integer nrec,nrec2,latb2,lonb2,nlevs2,npts2 + integer krecdp,ndpres,krect,krecq,krecu,krecv,ntrac,kq,kt,krecoz,kreccwmr,krecicmr + real,allocatable,dimension(:,:,:) :: vcoord + real,allocatable,dimension(:,:) ::& + rwork_1,rwork_2,pressi,pressl,pressi_new,pressl_new + real,allocatable,dimension(:) :: delz,delps,ak,bk,t0 + character(len=nemsio_charkind),allocatable,dimension(:) :: recnam + character(len=nemsio_charkind) field + real tpress,tv,kap1,kapr,rd,cp,grav,rlapse,alpha,ps,preduced,zob,zmodel,rv,fv + type(nemsio_gfile) :: gfile_1,gfile_2,gfile_o + logical ldpres + +! constants. + grav = 9.8066 + rlapse = 0.0065 + rd = 287.05 + rv = 461.5 + fv = rv/(rd-one) + cp = 1004. + kap1 = (rd/cp)+1.0 + kapr = (cp/rd) + alpha = rd*rlapse/grav + + call w3tagb('ADJUSTPS',2011,0319,0055,'NP25') + +! read data from this file + call getarg(1,filename_1) + +! subtract this mean + call getarg(2,filename_2) + +! then add to this mean + call getarg(3,filename_o) + +! model level to use for Benjamin and Miller pressure adjustment + if (iargc() > 3) then + call getarg(4,charnlev) + read(charnlev,'(i3)') nlevt + else + nlevt = 1 ! default value + endif + + write(6,*)'ADJUSTPS:' + write(6,*)'filename_1=',trim(filename_1) + write(6,*)'filename_2=',trim(filename_2) + write(6,*)'filename_o=',trim(filename_o) + write(6,*)'nlevt=',nlevt + + call nemsio_open(gfile_1,trim(filename_1),'READ',iret=iret) + if (iret == 0 ) then + write(6,*)'Read nemsio ',trim(filename_1),' iret=',iret + call nemsio_getfilehead(gfile_1, nrec=nrec, dimx=lonb, dimy=latb, dimz=nlevs, idsl=idsl,iret=iret) + write(6,*)' lonb=',lonb,' latb=',latb,' levs=',nlevs,' nrec=',nrec + else + write(6,*)'***ERROR*** ',trim(filename_1),' contains unrecognized format. ABORT' + endif + ! is dpres in the file? + allocate(recnam(nrec)) + call nemsio_getfilehead(gfile_1,recname=recnam,iret=iret) + ldpres = .false. + ndpres = 0 + field = 'dpres' + do n=1,nrec + !print *,n,trim(field),' ',trim(recnam(n)) + if (trim(field) == trim(recnam(n))) then + ldpres = .true. + ndpres = 1 + exit + endif + enddo + print *,'ldpres = ',ldpres + + call nemsio_open(gfile_2,trim(filename_2),'READ',iret=iret) + if (iret /= 0) then + print *,'Error opening ',trim(filename_2) + stop + endif + call nemsio_getfilehead(gfile_2, nrec=nrec2, dimx=lonb2, dimy=latb2, dimz=nlevs2, iret=iret) + + npts=lonb*latb + npts2=lonb2*latb2 + ! assumes ps,zs are first two records, then u,v,t,optionally dpres,q,oz,cwmr and optionally icmr + if (nrec > 2 + (7+ndpres)*nlevs) then + print *,'cannot handle nrec > ',2 + 7*nlevs + stop + endif + ! q, oz, then microphys tracers are last (after u,v,T,dpres) + krecq = 2 + (3+ndpres)*nlevs + 1 + ntrac = (nrec-(krecq-1))/nlevs + print *,'ntrac,nrec,idsl',ntrac,nrec,idsl + if (npts .ne. npts2 .or. nlevs .ne. nlevs2) then + print *,'grid size in file not what is expected, aborting..' + stop + endif + allocate(rwork_1(npts,nrec)) + allocate(rwork_2(npts,nrec)) + allocate(delz(npts)) + allocate(delps(npts)) + allocate(t0(npts)) + allocate(pressi(npts,nlevs+1)) + allocate(pressi_new(npts,nlevs+1)) + allocate(pressl(npts,nlevs)) + allocate(pressl_new(npts,nlevs)) + allocate(ak(nlevs+1)) + allocate(bk(nlevs+1)) + rwork_1 = zero; rwork_2 = zero + allocate(vcoord(nlevs+1,3,2)) + call nemsio_getfilehead(gfile_1,vcoord=vcoord,iret=iret) + if (iret /= 0) then + print *,'Error reading vcoord from ',trim(filename_1) + stop + endif + ak = vcoord(:,1,1); bk = vcoord(:,2,1) + deallocate(vcoord) + + ! read ps,zs from filename_2 + call nemsio_readrecv(gfile_2,'pres','sfc',1,rwork_2(:,1),iret=iret) + if (iret /= 0) then + print *,'Error reading ps from ',trim(filename_2) + stop + endif + call nemsio_readrecv(gfile_2,'hgt','sfc',1,rwork_2(:,2),iret=iret) + if (iret /= 0) then + print *,'Error reading zs from ',trim(filename_1) + stop + endif + ! read all fields from filename_1 + call nemsio_readrecv(gfile_1,'pres','sfc',1,rwork_1(:,1),iret=iret) + if (iret /= 0) then + print *,'Error reading ps from ',trim(filename_1) + stop + endif + call nemsio_readrecv(gfile_1,'hgt','sfc',1,rwork_1(:,2),iret=iret) + if (iret /= 0) then + print *,'Error reading zs from ',trim(filename_1) + stop + endif + print *,minval(rwork_1(:,1)),maxval(rwork_1(:,1)) + print *,minval(rwork_2(:,1)),maxval(rwork_2(:,1)) + print *,minval(rwork_1(:,2)),maxval(rwork_1(:,2)) + print *,minval(rwork_2(:,2)),maxval(rwork_2(:,2)) + do k = 1,nlevs + krecu = 2 + 0*nlevs + k + krecv = 2 + 1*nlevs + k + krect = 2 + 2*nlevs + k + krecdp = 2 + 3*nlevs + k + krecq = 2 + (3+ndpres)*nlevs + k + krecoz = 2 + (4+ndpres)*nlevs + k + kreccwmr = 2 + (5+ndpres)*nlevs + k + if (nrec > 2 + (6+ndpres)*nlevs) then + krecicmr = 2 + (6+ndpres)*nlevs + k + endif + call nemsio_readrecv(gfile_1,'ugrd', 'mid layer',k,rwork_1(:,krecu), iret=iret) + if (iret /= 0) then + print *,'Error reading u from ',trim(filename_1),k + stop + endif + call nemsio_readrecv(gfile_1,'vgrd', 'mid layer',k,rwork_1(:,krecv), iret=iret) + if (iret /= 0) then + print *,'Error reading v from ',trim(filename_1),k + stop + endif + call nemsio_readrecv(gfile_1,'tmp', 'mid layer',k,rwork_1(:,krect), iret=iret) + if (iret /= 0) then + print *,'Error reading t from ',trim(filename_1),k + stop + endif + if (ldpres) then + call nemsio_readrecv(gfile_1,'dpres', 'mid layer',k,rwork_1(:,krecdp), iret=iret) + if (iret /= 0) then + print *,'Error reading dpres from ',trim(filename_1),k + stop + endif + !print *,k,minval(rwork_1(:,krecdp)),maxval(rwork_1(:,krecdp)) + endif + call nemsio_readrecv(gfile_1,'spfh', 'mid layer',k,rwork_1(:,krecq), iret=iret) + if (iret /= 0) then + print *,'Error reading q from ',trim(filename_1),k + stop + endif + call nemsio_readrecv(gfile_1,'o3mr', 'mid layer',k,rwork_1(:,krecoz), iret=iret) + if (iret /= 0) then + print *,'Error reading o3 from ',trim(filename_1),k + stop + endif + call nemsio_readrecv(gfile_1,'clwmr','mid layer',k,rwork_1(:,kreccwmr),iret=iret) + if (iret /= 0) then + print *,'Error reading cwmr from ',trim(filename_1),k + stop + endif + if (nrec > 2 + 6*nlevs) then + call nemsio_readrecv(gfile_1,'icmr','mid layer',k,rwork_1(:,krecicmr),iret=iret) + if (iret /= 0) then + print *,'Error reading icmr from ',trim(filename_1),k + stop + endif + endif + enddo + + delz = rwork_1(:,2) - rwork_2(:,2) + delps = rwork_1(:,1) - rwork_2(:,1) + print *,'min/max delz = ',minval(delz),maxval(delz) + print *,'min/max delps = ',minval(delps),maxval(delps) + if (iret /= 0) then + print *,'Error closing ',trim(filename_1) + stop + endif + + !==> pressure at layers and interfaces. + do k=1,nlevs+1 + pressi(:,k)=ak(k)+bk(k)*rwork_1(:,1) + enddo + if (idsl == 2) then +! IDSL: TYPE OF SIGMA STRUCTURE (1 FOR PHILLIPS OR 2 FOR MEAN) + do k=1,nlevs + pressl(:,k)=0.5*(pressi(:,k)+pressi(:,k+1)) + end do + else + do k=1,nlevs + ! "phillips" vertical interpolation + pressl(:,k)=((pressi(:,k)**kap1-pressi(:,k+1)**kap1)/& + (kap1*(pressi(:,k)-pressi(:,k+1))))**kapr + end do + endif + + ! adjust surface pressure. + ! update first two fields in output (rwork_2) + do n=1,npts +! compute MAPS pressure reduction from model to station elevation +! See Benjamin and Miller (1990, MWR, p. 2100) +! uses 'effective' surface temperature extrapolated +! from virtual temp (tv) at pressure tpress +! using standard atmosphere lapse rate. +! ps - surface pressure to reduce. +! t - virtual temp. at pressure tpress. +! zmodel - model orographic height. +! zob - station height + kt = 2 + 2*nlevs + nlevt + kq = 2 + (3+ndpres)*nlevs + nlevt + tv = (1.+fv*rwork_1(n,kq))*rwork_1(n,kt) + tpress = pressl(n,nlevt); ps = rwork_1(n,1) + zmodel = rwork_2(n,2); zob = rwork_1(n,2) + t0(n) = tv*(ps/tpress)**alpha ! eqn 4 from B&M + preduced = ps*((t0(n) + rlapse*(zob-zmodel))/t0(n))**(1./alpha) ! eqn 1 from B&M + delps(n) = ps-preduced + rwork_1(n,1) = rwork_2(n,1) ! save old ps + rwork_2(n,1) = preduced ! new surface pressure adjusted to new orography + enddo + print *,'min/max effective surface t',minval(t0),maxval(t0) + print *,'min/max ps adjustment',minval(delps),maxval(delps) + delps = rwork_1(:,1) - rwork_2(:,1) + print *,'min/max delps after adjustment = ',minval(delps),maxval(delps) + !==> new pressure at layers and interfaces. + do k=1,nlevs+1 + pressi_new(:,k)=ak(k)+bk(k)*rwork_2(:,1) ! updated ps + enddo + if (idsl == 2) then + do k=1,nlevs + pressl_new(:,k)=0.5*(pressi_new(:,k)+pressi_new(:,k+1)) + end do + else + do k=1,nlevs + pressl_new(:,k)=((pressi_new(:,k)**kap1-pressi_new(:,k+1)**kap1)/& + (kap1*(pressi_new(:,k)-pressi_new(:,k+1))))**kapr + end do + endif + gfile_o=gfile_1 + call nemsio_open(gfile_o,trim(filename_o),'WRITE',iret=iret) + if (iret /= 0) then + print *,'Error opening ',trim(filename_o) + stop + endif +! interpolate fields to new pressures (update rest of rwork_2). + krecu = 2 + 0*nlevs + 1 + krecv = 2 + 1*nlevs + 1 + krect = 2 + 2*nlevs + 1 + krecq = 2 + (3+ndpres)*nlevs + 1 + print *,'min/max pressi diff',minval(pressi-pressi_new),maxval(pressi-pressi_new) + print *,'min/max pressl diff',minval(pressl-pressl_new),maxval(pressl-pressl_new) + call vintg(npts,npts,nlevs,nlevs,ntrac,pressl,& + rwork_1(:,krecu:krecu+nlevs-1),rwork_1(:,krecv:krecv+nlevs-1),& + rwork_1(:,krect:krect+nlevs-1),rwork_1(:,krecq:nrec),& + pressl_new,& + rwork_2(:,krecu:krecu+nlevs-1),rwork_2(:,krecv:krecv+nlevs-1),& + rwork_2(:,krect:krect+nlevs-1),rwork_2(:,krecq:nrec)) + print *,'min/max u diff',minval(rwork_1(:,krecu:krecu+nlevs-1)-rwork_2(:,krecu:krecu+nlevs-1)),& + maxval(rwork_1(:,krecu:krecu+nlevs-1)-rwork_2(:,krecu:krecu+nlevs-1)) + print *,'min/max v diff',minval(rwork_1(:,krecv:krecv+nlevs-1)-rwork_2(:,krecv:krecv+nlevs-1)),& + maxval(rwork_1(:,krecv:krecv+nlevs-1)-rwork_2(:,krecv:krecv+nlevs-1)) + print *,'min/max t diff',minval(rwork_1(:,krect:krect+nlevs-1)-rwork_2(:,krect:krect+nlevs-1)),& + maxval(rwork_1(:,krect:krect+nlevs-1)-rwork_2(:,krect:krect+nlevs-1)) + print *,'min/max q diff',minval(rwork_1(:,krecq:krecq+nlevs-1)-rwork_2(:,krecq:krecq+nlevs-1)),& + maxval(rwork_1(:,krecq:krecq+nlevs-1)-rwork_2(:,krecq:krecq+nlevs-1)) + print *,'min/max tracer diff',minval(rwork_1(:,krecq+nlevs:nrec)-rwork_2(:,krecq+nlevs:nrec)),& + maxval(rwork_1(:,krecq+nlevs:nrec)-rwork_2(:,krecq+nlevs:nlevs)) + ! write out all fields to filename_o + call nemsio_writerecv(gfile_o,'pres','sfc',1,rwork_2(:,1),iret=iret) + if (iret /= 0) then + print *,'Error writing ps to ',trim(filename_o) + stop + else + print *,'wrote ps ',k,minval(rwork_2(:,1)),maxval(rwork_2(:,1)) + endif + call nemsio_writerecv(gfile_o,'hgt','sfc',1,rwork_2(:,2),iret=iret) + if (iret /= 0) then + print *,'Error writing zs to ',trim(filename_o) + stop + else + print *,'wrote zs ',k,minval(rwork_2(:,2)),maxval(rwork_2(:,2)) + endif + do k = 1,nlevs + krecu = 2 + 0*nlevs + k + krecv = 2 + 1*nlevs + k + krect = 2 + 2*nlevs + k + if (ldpres) then + ndpres = 1 + krecdp = 2 + 3*nlevs + k + else + ndpres = 0 + endif + krecq = 2 + (3+ndpres)*nlevs + k + krecoz = 2 + (4+ndpres)*nlevs + k + kreccwmr = 2 + (5+ndpres)*nlevs + k + if (nrec > 2 + (6+ndpres)*nlevs) then + krecicmr = 2 + (6+ndpres)*nlevs + k + endif + call nemsio_writerecv(gfile_o,'ugrd', 'mid layer',k,rwork_2(:,krecu), iret=iret) + if (iret /= 0) then + print *,'Error writing u to ',trim(filename_o),k + stop + else + print *,'wrote u level ',k,minval(rwork_2(:,krecu)),maxval(rwork_2(:,krecu)) + endif + call nemsio_writerecv(gfile_o,'vgrd', 'mid layer',k,rwork_2(:,krecv), iret=iret) + if (iret /= 0) then + print *,'Error writing v to ',trim(filename_o),k + stop + else + print *,'wrote v level ',k,minval(rwork_2(:,krecv)),maxval(rwork_2(:,krecv)) + endif + call nemsio_writerecv(gfile_o,'tmp', 'mid layer',k,rwork_2(:,krect), iret=iret) + if (iret /= 0) then + print *,'Error writing t to ',trim(filename_o),k + stop + else + print *,'wrote t level ',k,minval(rwork_2(:,krect)),maxval(rwork_2(:,krect)) + endif + if (ldpres) then + rwork_2(:,krecdp) = pressi_new(:,k)-pressi_new(:,k+1) + call nemsio_writerecv(gfile_o,'dpres', 'mid layer',k,rwork_2(:,krecdp), iret=iret) + if (iret /= 0) then + print *,'Error writing dpres to ',trim(filename_o),k + stop + else + print *,'wrote dpres level ',k,minval(rwork_2(:,krecdp)),maxval(rwork_2(:,krecdp)) + endif + endif + call nemsio_writerecv(gfile_o,'spfh', 'mid layer',k,rwork_2(:,krecq), iret=iret) + if (iret /= 0) then + print *,'Error writing q to ',trim(filename_o),k + stop + else + print *,'wrote q level ',k,minval(rwork_2(:,krecq)),maxval(rwork_2(:,krecq)) + endif + call nemsio_writerecv(gfile_o,'o3mr', 'mid layer',k,rwork_2(:,krecoz), iret=iret) + if (iret /= 0) then + print *,'Error writing o3 to ',trim(filename_o),k + stop + else + print *,'wrote o3 level ',k,minval(rwork_2(:,krecoz)),maxval(rwork_2(:,krecoz)) + endif + call nemsio_writerecv(gfile_o,'clwmr','mid layer',k,rwork_2(:,kreccwmr),iret=iret) + if (iret /= 0) then + print *,'Error writing cwmr to ',trim(filename_o),k + stop + else + print *,'wrote cwmr level ',k,minval(rwork_2(:,kreccwmr)),maxval(rwork_2(:,kreccwmr)) + endif + if (nrec > 2 + 6*nlevs) then + call nemsio_writerecv(gfile_o,'icmr','mid layer',k,rwork_2(:,krecicmr),iret=iret) + if (iret /= 0) then + print *,'Error writing icmr to ',trim(filename_o),k + stop + else + print *,'wrote icmr level ',k,minval(rwork_2(:,krecicmr)),maxval(rwork_2(:,krecicmr)) + endif + endif + enddo + deallocate(delps,delz,t0) + deallocate(rwork_1,rwork_2) + deallocate(ak,bk,pressi,pressl,pressi_new,pressl_new) + call nemsio_close(gfile_o,iret=iret) + if (iret /= 0) then + print *,'Error closing ',trim(filename_o) + stop + endif + call nemsio_close(gfile_1,iret=iret) + if (iret /= 0) then + print *,'Error closing ',trim(filename_1) + stop + endif + call nemsio_close(gfile_2,iret=iret) + if (iret /= 0) then + print *,'Error closing ',trim(filename_2) + stop + endif + + call w3tage('ADJUSTPS') + +END program adjustps + +! these routines copied from global_chgres with minor mods to VINTG + + SUBROUTINE VINTG(IM,IX,KM1,KM2,NT,P1,U1,V1,T1,Q1,P2, & + U2,V2,T2,Q2) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! +! SUBPROGRAM: VINTG VERTICALLY INTERPOLATE UPPER-AIR FIELDS +! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 +! +! ABSTRACT: VERTICALLY INTERPOLATE UPPER-AIR FIELDS. +! WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS ARE INTERPOLATED. +! THE INTERPOLATION IS CUBIC LAGRANGIAN IN LOG PRESSURE +! WITH A MONOTONIC CONSTRAINT IN THE CENTER OF THE DOMAIN. +! IN THE OUTER INTERVALS IT IS LINEAR IN LOG PRESSURE. +! OUTSIDE THE DOMAIN, FIELDS ARE GENERALLY HELD CONSTANT, +! EXCEPT FOR TEMPERATURE AND HUMIDITY BELOW THE INPUT DOMAIN, +! WHERE THE TEMPERATURE LAPSE RATE IS HELD FIXED AT -6.5 K/KM AND +! THE RELATIVE HUMIDITY IS HELD CONSTANT. +! +! PROGRAM HISTORY LOG: +! 91-10-31 MARK IREDELL +! +! USAGE: CALL VINTG(IM,IX,KM1,KM2,NT,P1,U1,V1,T1,Q1,P2, +! & U2,V2,T2,Q2) +! INPUT ARGUMENT LIST: +! IM INTEGER NUMBER OF POINTS TO COMPUTE +! IX INTEGER FIRST DIMENSION +! KM1 INTEGER NUMBER OF INPUT LEVELS +! KM2 INTEGER NUMBER OF OUTPUT LEVELS +! NT INTEGER NUMBER OF TRACERS +! P1 REAL (IX,KM1) INPUT PRESSURES +! ORDERED FROM BOTTOM TO TOP OF ATMOSPHERE +! U1 REAL (IX,KM1) INPUT ZONAL WIND +! V1 REAL (IX,KM1) INPUT MERIDIONAL WIND +! T1 REAL (IX,KM1) INPUT TEMPERATURE (K) +! Q1 REAL (IX,KM1,NT) INPUT TRACERS (HUMIDITY FIRST) +! P2 REAL (IX,KM2) OUTPUT PRESSURES +! OUTPUT ARGUMENT LIST: +! U2 REAL (IX,KM2) OUTPUT ZONAL WIND +! V2 REAL (IX,KM2) OUTPUT MERIDIONAL WIND +! T2 REAL (IX,KM2) OUTPUT TEMPERATURE (K) +! Q2 REAL (IX,KM2,NT) OUTPUT TRACERS (HUMIDITY FIRST) +! +! SUBPROGRAMS CALLED: +! TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN +! +!C$$$ + INTEGER, INTENT(IN) :: IX,KM1,KM2,NT + REAL, INTENT(IN) :: P1(IX,KM1),U1(IX,KM1),V1(IX,KM1),T1(IX,KM1),Q1(IX,NT*KM1) +! & ,W1(IX,KM1) + REAL, INTENT(IN) :: P2(IX,KM2) + REAL, INTENT(OUT) :: U2(IX,KM2),V2(IX,KM2),T2(IX,KM2),Q2(IX,NT*KM2) +! & ,W2(IX,KM2) + REAL, PARAMETER :: DLTDZ=-6.5E-3*287.05/9.80665 + REAL, PARAMETER :: DLPVDRT=-2.5E6/461.50 + + REAL,allocatable :: Z1(:,:),Z2(:,:) + REAL,allocatable :: C1(:,:,:),C2(:,:,:),J2(:,:,:) + real dz + integer :: im,k,i,n +! + allocate (Z1(IM+1,KM1),Z2(IM+1,KM2)) + allocate (C1(IM+1,KM1,4+NT),C2(IM+1,KM2,4+NT),J2(IM+1,KM2,4+NT)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! COMPUTE LOG PRESSURE INTERPOLATING COORDINATE +! AND COPY INPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS +!!$OMP PARALLEL DO DEFAULT(SHARED) +!!$OMP+ PRIVATE(K,I) + !print *,minval(u1),maxval(u1) + !print *,minval(t1),maxval(t1) + DO K=1,KM1 + DO I=1,IM + Z1(I,K) = -LOG(P1(I,K)) + C1(I,K,1) = U1(I,K) + C1(I,K,2) = V1(I,K) +! C1(I,K,3) = W1(I,K) + C1(I,K,4) = T1(I,K) + C1(I,K,5) = Q1(I,K) + ENDDO + ENDDO +!!$OMP END PARALLEL DO + DO N=2,NT + DO K=1,KM1 + DO I=1,IM + C1(I,K,4+N) = Q1(I,(N-1)*KM1+K) + ENDDO + ENDDO + ENDDO +! print *,' p2=',p2(1,:) +! print *,' im=',im,' km2=',km2,' ix=',ix,'nt=',nt +!!$OMP PARALLEL DO DEFAULT(SHARED) +!!$OMP+ PRIVATE(K,I) + DO K=1,KM2 + DO I=1,IM + Z2(I,K) = -LOG(P2(I,K)) + ENDDO + ENDDO +!!$OMP END PARALLEL DO +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! PERFORM LAGRANGIAN ONE-DIMENSIONAL INTERPOLATION +! THAT IS 4TH-ORDER IN INTERIOR, 2ND-ORDER IN OUTSIDE INTERVALS +! AND 1ST-ORDER FOR EXTRAPOLATION. + CALL TERP3(IM,1,1,1,1,4+NT,(IM+1)*KM1,(IM+1)*KM2,& + KM1,IM+1,IM+1,Z1,C1,KM2,IM+1,IM+1,Z2,C2,J2) +! print *,' c2=',maxval(c2(1,:,:)),minval(c2(1,:,:)) +! print *,' j2:=',j2(1,1,:) +! print *,' j2:=',j2(im,km2,:) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! COPY OUTPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS +! EXCEPT BELOW THE INPUT DOMAIN, LET TEMPERATURE INCREASE WITH A FIXED +! LAPSE RATE AND LET THE RELATIVE HUMIDITY REMAIN CONSTANT. + DO K=1,KM2 + DO I=1,IM + U2(I,K)=C2(I,K,1) + V2(I,K)=C2(I,K,2) +! W2(I,K)=C2(I,K,3) + DZ=Z2(I,K)-Z1(I,1) + IF(DZ.GE.0) THEN + T2(I,K)=C2(I,K,4) + Q2(I,K)=C2(I,K,5) + ELSE + T2(I,K)=T1(I,1)*EXP(DLTDZ*DZ) + Q2(I,K)=Q1(I,1)*EXP(DLPVDRT*(1/T2(I,K)-1/T1(I,1))-DZ) + ENDIF + ENDDO + ENDDO + DO N=2,NT + DO K=1,KM2 + DO I=1,IM + Q2(I,(N-1)*KM2+K)=C2(I,K,4+N) + ENDDO + ENDDO + ENDDO + !print *,minval(u2),maxval(u2) + !print *,minval(t2),maxval(t2) + deallocate (Z1,Z2,C1,C2,J2) + END + + SUBROUTINE TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, & + KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2,J2) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! +! SUBPROGRAM: TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION +! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 +! +! ABSTRACT: INTERPOLATE FIELD(S) IN ONE DIMENSION ALONG THE COLUMN(S). +! THE INTERPOLATION IS CUBIC LAGRANGIAN WITH A MONOTONIC CONSTRAINT +! IN THE CENTER OF THE DOMAIN. IN THE OUTER INTERVALS IT IS LINEAR. +! OUTSIDE THE DOMAIN, FIELDS ARE HELD CONSTANT. +! +! PROGRAM HISTORY LOG: +! 98-05-01 MARK IREDELL +! 1999-01-04 IREDELL USE ESSL SEARCH +! +! USAGE: CALL TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, +! & KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2,J2) +! INPUT ARGUMENT LIST: +! IM INTEGER NUMBER OF COLUMNS +! IXZ1 INTEGER COLUMN SKIP NUMBER FOR Z1 +! IXQ1 INTEGER COLUMN SKIP NUMBER FOR Q1 +! IXZ2 INTEGER COLUMN SKIP NUMBER FOR Z2 +! IXQ2 INTEGER COLUMN SKIP NUMBER FOR Q2 +! NM INTEGER NUMBER OF FIELDS PER COLUMN +! NXQ1 INTEGER FIELD SKIP NUMBER FOR Q1 +! NXQ2 INTEGER FIELD SKIP NUMBER FOR Q2 +! KM1 INTEGER NUMBER OF INPUT POINTS +! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 +! KXQ1 INTEGER POINT SKIP NUMBER FOR Q1 +! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) +! INPUT COORDINATE VALUES IN WHICH TO INTERPOLATE +! (Z1 MUST BE STRICTLY MONOTONIC IN EITHER DIRECTION) +! Q1 REAL (1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) +! INPUT FIELDS TO INTERPOLATE +! KM2 INTEGER NUMBER OF OUTPUT POINTS +! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 +! KXQ2 INTEGER POINT SKIP NUMBER FOR Q2 +! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) +! OUTPUT COORDINATE VALUES TO WHICH TO INTERPOLATE +! (Z2 NEED NOT BE MONOTONIC) +! +! OUTPUT ARGUMENT LIST: +! Q2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) +! OUTPUT INTERPOLATED FIELDS +! J2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) +! OUTPUT INTERPOLATED FIELDS CHANGE WRT Z2 +! +! SUBPROGRAMS CALLED: +! RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN +! +!C$$$ + IMPLICIT NONE + INTEGER IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2 + INTEGER KM1,KXZ1,KXQ1,KM2,KXZ2,KXQ2 + INTEGER I,K1,K2,N + REAL Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) + REAL Q1(1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) + REAL Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) + REAL Q2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) + REAL J2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) + REAL FFA(IM),FFB(IM),FFC(IM),FFD(IM) + REAL GGA(IM),GGB(IM),GGC(IM),GGD(IM) + INTEGER K1S(IM,KM2) + REAL Z1A,Z1B,Z1C,Z1D,Q1A,Q1B,Q1C,Q1D,Z2S,Q2S,J2S +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. + CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,1,IM,K1S) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! GENERALLY INTERPOLATE CUBICALLY WITH MONOTONIC CONSTRAINT +! FROM TWO NEAREST INPUT POINTS ON EITHER SIDE OF THE OUTPUT POINT, +! BUT WITHIN THE TWO EDGE INTERVALS INTERPOLATE LINEARLY. +! KEEP THE OUTPUT FIELDS CONSTANT OUTSIDE THE INPUT DOMAIN. + +!!$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(IM,IXZ1,IXQ1,IXZ2) +!!$OMP+ SHARED(IXQ2,NM,NXQ1,NXQ2,KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2) +!!$OMP+ SHARED(KXQ2,Z2,Q2,J2,K1S) + + DO K2=1,KM2 + DO I=1,IM + K1=K1S(I,K2) + IF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN + Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) + Z1A=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) + Z1B=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) + FFA(I)=(Z2S-Z1B)/(Z1A-Z1B) + FFB(I)=(Z2S-Z1A)/(Z1B-Z1A) + GGA(I)=1/(Z1A-Z1B) + GGB(I)=1/(Z1B-Z1A) + ELSEIF(K1.GT.1.AND.K1.LT.KM1-1) THEN + Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) + Z1A=Z1(1+(I-1)*IXZ1+(K1-2)*KXZ1) + Z1B=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) + Z1C=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) + Z1D=Z1(1+(I-1)*IXZ1+(K1+1)*KXZ1) + FFA(I)=(Z2S-Z1B)/(Z1A-Z1B)* & + (Z2S-Z1C)/(Z1A-Z1C)* & + (Z2S-Z1D)/(Z1A-Z1D) + FFB(I)=(Z2S-Z1A)/(Z1B-Z1A)* & + (Z2S-Z1C)/(Z1B-Z1C)* & + (Z2S-Z1D)/(Z1B-Z1D) + FFC(I)=(Z2S-Z1A)/(Z1C-Z1A)* & + (Z2S-Z1B)/(Z1C-Z1B)* & + (Z2S-Z1D)/(Z1C-Z1D) + FFD(I)=(Z2S-Z1A)/(Z1D-Z1A)* & + (Z2S-Z1B)/(Z1D-Z1B)* & + (Z2S-Z1C)/(Z1D-Z1C) + GGA(I)= 1/(Z1A-Z1B)* & + (Z2S-Z1C)/(Z1A-Z1C)* & + (Z2S-Z1D)/(Z1A-Z1D)+ & + (Z2S-Z1B)/(Z1A-Z1B)* & + 1/(Z1A-Z1C)* & + (Z2S-Z1D)/(Z1A-Z1D)+ & + (Z2S-Z1B)/(Z1A-Z1B)* & + (Z2S-Z1C)/(Z1A-Z1C)* & + 1/(Z1A-Z1D) + GGB(I)= 1/(Z1B-Z1A)* & + (Z2S-Z1C)/(Z1B-Z1C)* & + (Z2S-Z1D)/(Z1B-Z1D)+ & + (Z2S-Z1A)/(Z1B-Z1A)* & + 1/(Z1B-Z1C)* & + (Z2S-Z1D)/(Z1B-Z1D)+ & + (Z2S-Z1A)/(Z1B-Z1A)* & + (Z2S-Z1C)/(Z1B-Z1C)* & + 1/(Z1B-Z1D) + GGC(I)= 1/(Z1C-Z1A)* & + (Z2S-Z1B)/(Z1C-Z1B)* & + (Z2S-Z1D)/(Z1C-Z1D)+ & + (Z2S-Z1A)/(Z1C-Z1A)* & + 1/(Z1C-Z1B)* & + (Z2S-Z1D)/(Z1C-Z1D)+ & + (Z2S-Z1A)/(Z1C-Z1A)* & + (Z2S-Z1B)/(Z1C-Z1B)* & + 1/(Z1C-Z1D) + GGD(I)= 1/(Z1D-Z1A)* & + (Z2S-Z1B)/(Z1D-Z1B)* & + (Z2S-Z1C)/(Z1D-Z1C)+ & + (Z2S-Z1A)/(Z1D-Z1A)* & + 1/(Z1D-Z1B)* & + (Z2S-Z1C)/(Z1D-Z1C)+ & + (Z2S-Z1A)/(Z1D-Z1A)* & + (Z2S-Z1B)/(Z1D-Z1B)* & + 1/(Z1D-Z1C) + ENDIF + ENDDO +! INTERPOLATE. + DO N=1,NM + DO I=1,IM + K1=K1S(I,K2) + IF(K1.EQ.0) THEN + Q2S=Q1(1+(I-1)*IXQ1+(N-1)*NXQ1) + J2S=0 + ELSEIF(K1.EQ.KM1) THEN + Q2S=Q1(1+(I-1)*IXQ1+(KM1-1)*KXQ1+(N-1)*NXQ1) + J2S=0 + ELSEIF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN + Q1A=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) + Q1B=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) + Q2S=FFA(I)*Q1A+FFB(I)*Q1B + J2S=GGA(I)*Q1A+GGB(I)*Q1B + ELSE + Q1A=Q1(1+(I-1)*IXQ1+(K1-2)*KXQ1+(N-1)*NXQ1) + Q1B=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) + Q1C=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) + Q1D=Q1(1+(I-1)*IXQ1+(K1+1)*KXQ1+(N-1)*NXQ1) + Q2S=FFA(I)*Q1A+FFB(I)*Q1B+FFC(I)*Q1C+FFD(I)*Q1D + J2S=GGA(I)*Q1A+GGB(I)*Q1B+GGC(I)*Q1C+GGD(I)*Q1D + IF(Q2S.LT.MIN(Q1B,Q1C)) THEN + Q2S=MIN(Q1B,Q1C) + J2S=0 + ELSEIF(Q2S.GT.MAX(Q1B,Q1C)) THEN + Q2S=MAX(Q1B,Q1C) + J2S=0 + ENDIF + ENDIF + Q2(1+(I-1)*IXQ2+(K2-1)*KXQ2+(N-1)*NXQ2)=Q2S + J2(1+(I-1)*IXQ2+(K2-1)*KXQ2+(N-1)*NXQ2)=J2S + ENDDO + ENDDO + ENDDO +!!$OMP END PARALLEL DO +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +!----------------------------------------------------------------------- + SUBROUTINE RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2,& + L2) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! +! SUBPROGRAM: RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL +! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 +! +! ABSTRACT: THIS SUBPROGRAM SEARCHES MONOTONIC SEQUENCES OF REAL NUMBERS +! FOR INTERVALS THAT SURROUND A GIVEN SEARCH SET OF REAL NUMBERS. +! THE SEQUENCES MAY BE MONOTONIC IN EITHER DIRECTION; THE REAL NUMBERS +! MAY BE SINGLE OR DOUBLE PRECISION; THE INPUT SEQUENCES AND SETS +! AND THE OUTPUT LOCATIONS MAY BE ARBITRARILY DIMENSIONED. +! +! PROGRAM HISTORY LOG: +! 1999-01-05 MARK IREDELL +! +! USAGE: CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2, +! & L2) +! INPUT ARGUMENT LIST: +! IM INTEGER NUMBER OF SEQUENCES TO SEARCH +! KM1 INTEGER NUMBER OF POINTS IN EACH SEQUENCE +! IXZ1 INTEGER SEQUENCE SKIP NUMBER FOR Z1 +! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 +! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) +! SEQUENCE VALUES TO SEARCH +! (Z1 MUST BE MONOTONIC IN EITHER DIRECTION) +! KM2 INTEGER NUMBER OF POINTS TO SEARCH FOR +! IN EACH RESPECTIVE SEQUENCE +! IXZ2 INTEGER SEQUENCE SKIP NUMBER FOR Z2 +! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 +! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) +! SET OF VALUES TO SEARCH FOR +! (Z2 NEED NOT BE MONOTONIC) +! IXL2 INTEGER SEQUENCE SKIP NUMBER FOR L2 +! KXL2 INTEGER POINT SKIP NUMBER FOR L2 +! +! OUTPUT ARGUMENT LIST: +! L2 INTEGER (1+(IM-1)*IXL2+(KM2-1)*KXL2) +! INTERVAL LOCATIONS HAVING VALUES FROM 0 TO KM1 +! (Z2 WILL BE BETWEEN Z1(L2) AND Z1(L2+1)) +! +! SUBPROGRAMS CALLED: +! SBSRCH ESSL BINARY SEARCH +! DBSRCH ESSL BINARY SEARCH +! +! REMARKS: +! IF THE ARRAY Z1 IS DIMENSIONED (IM,KM1), THEN THE SKIP NUMBERS ARE +! IXZ1=1 AND KXZ1=IM; IF IT IS DIMENSIONED (KM1,IM), THEN THE SKIP +! NUMBERS ARE IXZ1=KM1 AND KXZ1=1; IF IT IS DIMENSIONED (IM,JM,KM1), +! THEN THE SKIP NUMBERS ARE IXZ1=1 AND KXZ1=IM*JM; ETCETERA. +! SIMILAR EXAMPLES APPLY TO THE SKIP NUMBERS FOR Z2 AND L2. +! +! RETURNED VALUES OF 0 OR KM1 INDICATE THAT THE GIVEN SEARCH VALUE +! IS OUTSIDE THE RANGE OF THE SEQUENCE. +! +! IF A SEARCH VALUE IS IDENTICAL TO ONE OF THE SEQUENCE VALUES +! THEN THE LOCATION RETURNED POINTS TO THE IDENTICAL VALUE. +! IF THE SEQUENCE IS NOT STRICTLY MONOTONIC AND A SEARCH VALUE IS +! IDENTICAL TO MORE THAN ONE OF THE SEQUENCE VALUES, THEN THE +! LOCATION RETURNED MAY POINT TO ANY OF THE IDENTICAL VALUES. +! +! TO BE EXACT, FOR EACH I FROM 1 TO IM AND FOR EACH K FROM 1 TO KM2, +! Z=Z2(1+(I-1)*IXZ2+(K-1)*KXZ2) IS THE SEARCH VALUE AND +! L=L2(1+(I-1)*IXL2+(K-1)*KXL2) IS THE LOCATION RETURNED. +! IF L=0, THEN Z IS LESS THAN THE START POINT Z1(1+(I-1)*IXZ1) +! FOR ASCENDING SEQUENCES (OR GREATER THAN FOR DESCENDING SEQUENCES). +! IF L=KM1, THEN Z IS GREATER THAN OR EQUAL TO THE END POINT +! Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1) FOR ASCENDING SEQUENCES +! (OR LESS THAN OR EQUAL TO FOR DESCENDING SEQUENCES). +! OTHERWISE Z IS BETWEEN THE VALUES Z1(1+(I-1)*IXZ1+(L-1)*KXZ1) AND +! Z1(1+(I-1)*IXZ1+(L-0)*KXZ1) AND MAY EQUAL THE FORMER. +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN +! +!C$$$ +! IMPLICIT NONE +! INTEGER,INTENT(IN):: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 +! REAL,INTENT(IN):: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) +! REAL,INTENT(IN):: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) +! INTEGER,INTENT(OUT):: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2) +! INTEGER(4) INCX,N,INCY,M,INDX(KM2),RC(KM2),IOPT +! INTEGER I,K2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. +! DO I=1,IM +! IF(Z1(1+(I-1)*IXZ1).LE.Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1)) THEN +! INPUT COORDINATE IS MONOTONICALLY ASCENDING. +! INCX=KXZ2 +! N=KM2 +! INCY=KXZ1 +! M=KM1 +! IOPT=1 +! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN +! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, +! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) +! ELSE +! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, +! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) +! ENDIF +! DO K2=1,KM2 +! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=INDX(K2)-RC(K2) +! ENDDO +! ELSE +! INPUT COORDINATE IS MONOTONICALLY DESCENDING. +! INCX=KXZ2 +! N=KM2 +! INCY=-KXZ1 +! M=KM1 +! IOPT=0 +! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN +! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, +! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) +! ELSE +! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, +! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) +! ENDIF +! DO K2=1,KM2 +! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=KM1+1-INDX(K2) +! ENDDO +! ENDIF +! ENDDO +! + IMPLICIT NONE + INTEGER,INTENT(IN):: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 + REAL,INTENT(IN):: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) + REAL,INTENT(IN):: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) + INTEGER,INTENT(OUT):: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2) + INTEGER I,K2,L + REAL Z +!C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!C FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. + DO I=1,IM + IF(Z1(1+(I-1)*IXZ1).LE.Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1)) THEN +!C INPUT COORDINATE IS MONOTONICALLY ASCENDING. + DO K2=1,KM2 + Z=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) + L=0 + DO + IF(Z.LT.Z1(1+(I-1)*IXZ1+L*KXZ1)) EXIT + L=L+1 + IF(L.EQ.KM1) EXIT + ENDDO + L2(1+(I-1)*IXL2+(K2-1)*KXL2)=L + ENDDO + ELSE +!C INPUT COORDINATE IS MONOTONICALLY DESCENDING. + DO K2=1,KM2 + Z=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) + L=0 + DO + IF(Z.GT.Z1(1+(I-1)*IXZ1+L*KXZ1)) EXIT + L=L+1 + IF(L.EQ.KM1) EXIT + ENDDO + L2(1+(I-1)*IXL2+(K2-1)*KXL2)=L + ENDDO + ENDIF + ENDDO + + END SUBROUTINE diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/CMakeLists.txt b/util/EnKF/gfs/src/calc_increment_ens.fd/CMakeLists.txt index cd9c8ce89..30e1925dc 100644 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/calc_increment_ens.fd/CMakeLists.txt @@ -3,11 +3,12 @@ if(BUILD_UTIL) file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) list( REMOVE_ITEM LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/main.f90 ) - set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) - add_executable(calc_inc.x ${LOCAL_SRC} ) - set_target_properties( calc_inc.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OMPFLAG}" ) - include_directories( ${UTIL_INC} ${CORE_INCS} ${NETCDF_INCLUDES} ) - target_link_libraries( calc_inc.x ${CORE_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) - add_dependencies( calc_inc.x enkfdeplib enkflib ) + set(Util_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/calc_increment_ens") + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + add_executable(calc_increment_ens.x ${LOCAL_SRC} ) + set_target_properties( calc_increment_ens.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + set_target_properties( calc_increment_ens.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIRECTORY} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${UTIL_INC} ${NEMSIOINC} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ) + target_link_libraries( calc_increment_ens.x ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${MPI_Fortran_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${ZLIB_LIBRARIES} ${CURL_LIBRARIES} ) endif() diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile b/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile deleted file mode 100644 index aed6851a1..000000000 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile +++ /dev/null @@ -1,167 +0,0 @@ -#============================================================================== -# -# Makefile -# -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ------------- -# General Rules -# ------------- - -SHELL=/bin/sh - -RM = /bin/rm -f -MKDIR = /bin/mkdir -p - -#------------ -# Include machine dependent compile & load options -#------------ - -MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - -# ------------- -# This makefile -# ------------- - -MAKE_FILE = Makefile - -# ----------- -# Load module -# ----------- - -EXE_FILE = calc_increment.x -PEXE_FILE = calc_increment_ens.x - -# -------------------- -# Installing directory -# -------------------- - -INSTALL_DIR = ../../exec/ - -# -------- -# Log file -# -------- - -LOG_FILE = log.make.$(EXE_FILE) -PLOG_FILE = log.make.$(PEXE_FILE) - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - cp $(PEXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(PEXE_FILE) - -#----------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) *.o *.mod - - $(RM) $(EXE_FILE) log.make.$(EXE_FILE) - - $(RM) $(PEXE_FILE) log.make.$(PEXE_FILE) - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# --------- -# Libraries -# --------- - -# ------------ -# Source files -# ------------ - -SRCSF90 = \ - kinds.f90 \ - constants.f90 \ - namelist_def.f90 \ - variable_interface.f90 \ - gfs_nems_interface.f90 \ - fv3_interface.f90 \ - calc_increment_interface.f90 - -SRCSF77 = - -SRCS = $(SRCSF77) $(SRCSF90) - -# ------------ -# Object files -# ------------ - -OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} - -# ------------ -# Dependencies -# ------------ -MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_N) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_N) -c $< - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all: CALC_INCREMENT CALC_INCREMENT_ENS - -CALC_INCREMENT: $(OBJS) - @echo - @echo '---> Linking $@' - $(LD) $(LDFLAGS_N) $(OBJS) main.f90 $(LIBS_N) -o $(EXE_FILE) > $(LOG_FILE) - -CALC_INCREMENT_ENS: $(OBJS) - @echo - @echo '---> Linking $@' - $(LD) $(LDFLAGS_N) $(OBJS) pmain.f90 $(LIBS_N) -o $(PEXE_FILE) > $(PLOG_FILE) - -help: - @ echo "Available targets:" - @ echo " make creates executable" - @ echo " make install creates exec & places it in bin" - @ echo " make clean cleans objects, exec, and alien files" diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.cray b/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.cray deleted file mode 100644 index 302f6ecc6..000000000 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.cray +++ /dev/null @@ -1,93 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Set library versions -# ------------------------------------ - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.2 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_4.a - -NETCDF_INC=$(NETCDF)/include -NETCDF_LIB=-L$(NETCDF)/lib -lnetcdf - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - - OMP = -openmp - - FFLAGS_INC = -I $(NEMSIO_INC) -I $(NETCDF_INC) - - FFLAGS_F90 = -convert big_endian -assume byterecl \ - -implicitnone -traceback - -#--- Normal mode options - FFLAGS_COM_N = -O3 -fp-model source - - FFLAGS_N = $(FFLAGS_INC) $(FFLAGS_COM_N) $(FFLAGS_F90) $(OMP) - -#--- Debug mode options - FFLAGS_COM_D = -O0 -fp-model strict -g -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn all - - FFLAGS_D = $(FFLAGS_INC) $(FFLAGS_COM_D) $(FFLAGS_F90) $(OMP) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) $(NETCDF_LIB) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.nco b/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.nco deleted file mode 100644 index 396f7c80a..000000000 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.nco +++ /dev/null @@ -1,81 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Define derived variables -# ---------------------------------- - -NETCDFPATH = $(NETCDF) -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - - OMP = -openmp - - FFLAGS_INC = -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) - - FFLAGS_F90 = -convert big_endian -assume byterecl \ - -implicitnone -traceback - -#--- Normal mode options - FFLAGS_COM_N = -O3 -fp-model source - - FFLAGS_N = $(FFLAGS_INC) $(FFLAGS_COM_N) $(FFLAGS_F90) $(OMP) - -#--- Debug mode options - FFLAGS_COM_D = -O0 -fp-model strict -g -warn all -debug all -check all - - FFLAGS_D = $(FFLAGS_INC) $(FFLAGS_COM_D) $(FFLAGS_F90) $(OMP) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) $(NETCDF_LDFLAGS_F) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.theia b/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.theia deleted file mode 100644 index ae1b74575..000000000 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.theia +++ /dev/null @@ -1,92 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Set library versions -# ------------------------------------ - -BACIO_VER = 2.0.1 -NEMSIO_VER = 2.2.1 -W3NCO_VER = 2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib - -NEMSIO_INC= $(CORELIB)/nemsio/v$(NEMSIO_VER)/incmod/nemsio_v$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/v$(BACIO_VER)/libbacio_v$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/v$(NEMSIO_VER)/libnemsio_v$(NEMSIO_VER).a -W3NCO_LIB4=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_4.a - -NETCDF_INC=$(NETCDF)/include -NETCDF_LIB=-L$(NETCDF)/lib -lnetcdf - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - - OMP = -openmp - - FFLAGS_INC = -I $(NEMSIO_INC) -I $(NETCDF_INC) - - FFLAGS_F90 = -convert big_endian -assume byterecl \ - -implicitnone -traceback - -#--- Normal mode options - FFLAGS_COM_N = -O3 -fp-model source - - FFLAGS_N = $(FFLAGS_INC) $(FFLAGS_COM_N) $(FFLAGS_F90) $(OMP) - -#--- Debug mode options - FFLAGS_COM_D = -O0 -fp-model strict -g -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn all - - FFLAGS_D = $(FFLAGS_INC) $(FFLAGS_COM_D) $(FFLAGS_F90) $(OMP) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) $(NETCDF_LIB) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.wcoss b/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.wcoss deleted file mode 100644 index 1a3a096fc..000000000 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.conf.wcoss +++ /dev/null @@ -1,91 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Set library versions -# ------------------------------------ - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a - -NETCDF_INC=$(NETCDF)/include -NETCDF_LIB=-L$(NETCDF)/lib -lnetcdf - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - - OMP = -openmp - - FFLAGS_INC = -I $(NEMSIO_INC) -I $(NETCDF_INC) - - FFLAGS_F90 = -convert big_endian -assume byterecl \ - -implicitnone -traceback - -#--- Normal mode options - FFLAGS_COM_N = -O3 -fp-model source - - FFLAGS_N = $(FFLAGS_INC) $(FFLAGS_COM_N) $(FFLAGS_F90) $(OMP) - -#--- Debug mode options - FFLAGS_COM_D = -O0 -fp-model strict -g -debug \ - -check all - - FFLAGS_D = $(FFLAGS_INC) $(FFLAGS_COM_D) $(FFLAGS_F90) $(OMP) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) $(NETCDF_LIB) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.dependency b/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.dependency deleted file mode 100644 index 36a2080cd..000000000 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/Makefile.dependency +++ /dev/null @@ -1,34 +0,0 @@ -# Copyright (C) 2015 Henry R. Winterbottom - -# Email: Henry.Winterbottom@noaa.gov - -# Snail-mail: - -# Henry R. Winterbottom -# NOAA/OAR/PSD R/PSD1 -# 325 Broadway -# Boulder, CO 80303-3328 - -# This file is part of global-model-py. - -# global-model-py is free software: you can redistribute it and/or -# modify it under the terms of the GNU General Public License as -# published by the Free Software Foundation, either version 3 of -# the License, or (at your option) any later version. - -# global-model-py is distributed in the hope that it will be -# useful, but WITHOUT ANY WARRANTY; without even the implied -# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -# See the GNU General Public License for more details. - -# You should have received a copy of the GNU General Public License -# along with global-model-py. If not, see -# . - -kinds.o: kinds.f90 -constants.o: constants.f90 kinds.o -namelist_def.o: namelist_def.f90 kinds.o -variable_interface.o: variable_interface.f90 constants.o kinds.o -gfs_nems_interface.o: gfs_nems_interface.f90 constants.o kinds.o namelist_def.o -fv3_interface.o: fv3_interface.f90 variable_interface.o constants.o kinds.o namelist_def.o gfs_nems_interface.o -calc_increment_interface.o: calc_increment_interface.f90 fv3_interface.o diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/calc_increment_interface.f90 b/util/EnKF/gfs/src/calc_increment_ens.fd/calc_increment_interface.f90 index bd208c43c..41c0ac59b 100644 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/calc_increment_interface.f90 +++ b/util/EnKF/gfs/src/calc_increment_ens.fd/calc_increment_interface.f90 @@ -56,13 +56,15 @@ module calc_increment_interface !----------------------------------------------------------------------- - subroutine calc_increment() + subroutine calc_increment(mype) + + integer,intent(in) :: mype !===================================================================== ! Check local variable and proceed accordingly - call fv3_calc_increment() + call fv3_calc_increment(mype) !===================================================================== diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/configure b/util/EnKF/gfs/src/calc_increment_ens.fd/configure deleted file mode 100755 index b169dfc97..000000000 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/configure +++ /dev/null @@ -1,94 +0,0 @@ -#!/bin/sh -# -# Creates configuration Makefile. Before attempting to make anything -# in this directory, enter -# -# ./configure -# -# !REVISION HISTORY -# -# 09oct97 da Silva Initial code. -# 19oct97 da Silva Simplified. -# 22oct97 Jing Guo Converted to libpsas.a environment -# - special configuration for CRAY -# - fool-prove configuration -# - additional information -# 23dec99 da Silva Modified error messages. -# -#..................................................................... - -c=`basename $0 .sh` - -type=${1:-"unknown"} -echo $type - - -# If type=clean, remove soft links and exit -# ----------------------------------------- -if [ "$type" = "clean" ]; then - if [ -r makefile ]; then - echo "$c: remove makefile" 1>&2 - rm makefile - fi - if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf - fi - exit -fi - - -# Node specific configuration -# --------------------------------------- -makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" - -# Machine specific -# ---------------- -if [ ! -r ${makeconf} ]; then - echo "$c: not using site specific ${makeconf} in `pwd`" 1>&2 - machine="`uname -m | awk '{print $1}'`" - machine=`echo $machine | tr "[a-z]" "[A-Z]"` - compiler=$F90 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - makeconf="${makeconf}.${machine}.${compiler}" -fi - -# Site specific configuration -# --------------------------- -if [ ! -r ${makeconf} ]; then -# echo "$c: cannot find site specific ${makeconf}" 1>&2 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - # if all are failed, make a simple one - # --------------------------------------- -# if [ `uname -s` = "AIX" ]; then -# echo "Linking Makefile to makefile" 1>&2 -# ln -sf Makefile makefile -# fi -fi - -# if the OS is UNICOS, it does not follow the convention -# ------------------------------------------------------ -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - mech="`uname -m | awk '{print $1}'`" - if [ "${mech}" = CRAY ]; then - makeconf="Makefile.conf.UNICOS" - fi -fi - -# if all are failed, make a simple one -# --------------------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd` " 1>&2 - makeconf="Makefile.conf.$type" - if [ ! -r ${makeconf} ]; then - touch ${makeconf} - fi -fi - -rm -f Makefile.conf -ln -s ${makeconf} Makefile.conf - -echo "$c: using ${makeconf} in `pwd`" 1>&2 - -#. diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/fv3_interface.f90 b/util/EnKF/gfs/src/calc_increment_ens.fd/fv3_interface.f90 index 8c2cbf660..9f602b02d 100644 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/fv3_interface.f90 +++ b/util/EnKF/gfs/src/calc_increment_ens.fd/fv3_interface.f90 @@ -54,31 +54,11 @@ module fv3_interface type analysis_grid character(len=500) :: filename - real(r_kind), dimension(:,:,:), allocatable :: dpres - real(r_kind), dimension(:,:,:), allocatable :: delz - real(r_kind), dimension(:,:,:), allocatable :: ugrd - real(r_kind), dimension(:,:,:), allocatable :: vgrd - real(r_kind), dimension(:,:,:), allocatable :: spfh - real(r_kind), dimension(:,:,:), allocatable :: tmp - real(r_kind), dimension(:,:,:), allocatable :: clwmr - real(r_kind), dimension(:,:,:), allocatable :: o3mr - real(r_kind), dimension(:,:,:), allocatable :: icmr + real(r_kind), dimension(:,:,:), allocatable :: var3d real(r_kind), dimension(:,:), allocatable :: psfc real(r_kind), dimension(:), allocatable :: ak real(r_kind), dimension(:), allocatable :: bk real(r_kind), dimension(:), allocatable :: ck - end type analysis_grid ! type analysis_grid - - type increment_grid - real(r_kind), dimension(:,:,:), allocatable :: delp_inc - real(r_kind), dimension(:,:,:), allocatable :: delz_inc - real(r_kind), dimension(:,:,:), allocatable :: u_inc - real(r_kind), dimension(:,:,:), allocatable :: v_inc - real(r_kind), dimension(:,:,:), allocatable :: sphum_inc - real(r_kind), dimension(:,:,:), allocatable :: temp_inc - real(r_kind), dimension(:,:,:), allocatable :: clwmr_inc - real(r_kind), dimension(:,:,:), allocatable :: o3mr_inc - real(r_kind), dimension(:,:,:), allocatable :: icmr_inc real(r_kind), dimension(:), allocatable :: lon real(r_kind), dimension(:), allocatable :: lat real(r_kind), dimension(:), allocatable :: lev @@ -86,455 +66,547 @@ module fv3_interface real(r_kind), dimension(:), allocatable :: pfull real(r_kind), dimension(:), allocatable :: hyai real(r_kind), dimension(:), allocatable :: hybi - integer :: nx - integer :: ny - integer :: nz - integer :: nzp1 - end type increment_grid ! type increment_grid + integer :: nx = -1 + integer :: ny = -1 + integer :: nz = -1 + integer :: nzp1 = 0 + logical :: is_allocated = .false. + logical :: flip_lats = .true. + logical :: ldpres = .true. + end type analysis_grid ! type analysis_grid - ! Define global variables + type increment_netcdf + integer :: dimid_lon = -1 + integer :: dimid_lat = -1 + integer :: dimid_lev = -1 + integer :: dimid_ilev = -1 + integer :: ncfileid = -1 + end type increment_netcdf - type(nemsio_meta) :: meta_nemsio - type(analysis_grid) :: an_grid - type(analysis_grid) :: fg_grid + integer, parameter :: n_inc_vars = 9 !! number of known variables - !----------------------------------------------------------------------- + ! Define global variables - ! Define interfaces and attributes for module routines + type(nemsio_meta) :: meta_nemsio !! nemsio metadata for the current file + type(analysis_grid) :: an_grid !! analysis grid data + type(analysis_grid) :: fg_grid !! first guess grid data + + !! All known output variables. These are the names in the output + !! NetCDF file. The input names are in input_vars. + character(len=11), dimension(n_inc_vars) :: output_vars=(/ & + 'u_inc ', 'v_inc ', 'delp_inc ', 'delz_inc ', & + 'T_inc ', 'sphum_inc ', 'liq_wat_inc', 'o3mr_inc ', & + 'icmr_inc ' /) + + !! Synonyms for output_vars needed to be backward-compatible with + !! bugs in the prior version of this script. These are used to + !! match to increments_to_zero. + character(len=11), dimension(n_inc_vars) :: var_zero_synonyms=(/ & + 'u_inc ', 'v_inc ', 'delp_inc ', 'delz_inc ', & + 'temp_inc ', 'sphum_inc ', 'clwmr_inc ', 'o3mwr_inc ', & + 'icmr_inc ' /) + + !! The input name from nemsio that matches each output filename from + !! output_vars. + character(len=11), dimension(n_inc_vars) :: input_vars=(/ & + 'ugrd ', 'vgrd ', 'dpres ', 'delz ', & + 'tmp ', 'spfh ', 'clwmr ', 'o3mr ', & + 'icmr ' /) private public :: fv3_calc_increment - !----------------------------------------------------------------------- + !======================================================================= + !======================================================================= contains !======================================================================= + !======================================================================= - ! fv3_calc_increment.f90: - - !----------------------------------------------------------------------- - - subroutine fv3_calc_increment() - - ! Define variables computed within routine - - type(increment_grid) :: grid - - !===================================================================== - - ! Compute local variables - - call fv3_increment_compute(grid) - - ! Define local variables - - call fv3_increment_write(grid) + subroutine fv3_calc_increment(mype) - ! Deallocate memory for local variables + integer,intent(in) :: mype - call fv3_increment_cleanup(grid) + type(gfs_grid) :: grid !! GFS analysis grid - !===================================================================== + type(increment_netcdf) :: ncdat !! cached info about NetCDF output file - end subroutine fv3_calc_increment + integer :: j, k ! loop indices within a variable + integer :: ivar !! loop index over variables in input_vars & output_vars - !======================================================================= + ! Formats for print statements: +100 format(A,': ',A) - ! fv3_increment_write.f90: + ! ------------------------------------------------------------------ + ! Initialize memory, read metadata, and read 1D arrays. - !----------------------------------------------------------------------- + ! Calculate constants + call init_constants_derived() - subroutine fv3_increment_write(grid) + ! Allocate grids for analysis and first guess + call fv3_grid_allocate(an_grid,fg_grid) - ! Define variables passed to routine + ! Read the analysis and first guess non-increment vars and pressure: + an_grid%filename = analysis_filename + fg_grid%filename = firstguess_filename + call fv3_analysis_read_non_inc_vars(an_grid) + call fv3_analysis_read_non_inc_vars(fg_grid) - type(increment_grid) :: grid + ! ------------------------------------------------------------------ + ! Deal with everything that is NOT a 3D array: - ! Define variables computed within routine + ! Copy horizontal dimensions from analysis grid + grid%nlons = an_grid%nx + grid%nlats = an_grid%ny - integer, dimension(3) :: dimid_3d - integer, dimension(1) :: dimid_1d - - integer :: varid_lon - integer :: varid_lat - integer :: varid_lev - integer :: varid_pfull - integer :: varid_ilev - integer :: varid_hyai - integer :: varid_hybi - integer :: varid_u_inc - integer :: varid_v_inc - integer :: varid_delp_inc - integer :: varid_delz_inc - integer :: varid_temp_inc - integer :: varid_sphum_inc - integer :: varid_clwmr_inc - integer :: varid_o3mr_inc - integer :: varid_icmr_inc - integer :: dimid_lon - integer :: dimid_lat - integer :: dimid_lev - integer :: dimid_ilev - integer :: ncfileid - integer :: ncvarid - integer :: ncdimid - - !===================================================================== + ! Read the nemsio header + call gfs_nems_initialize(meta_nemsio, firstguess_filename) + call gfs_grid_initialize(grid, meta_nemsio) - ! Define local variables + an_grid%lon = grid%rlon(:,1) - print *,'writing to ',trim(increment_filename) - call netcdf_check(nf90_create(trim(increment_filename), & - cmode=ior(NF90_CLOBBER,NF90_64BIT_OFFSET),ncid=ncfileid), & - & 'nf90_create') - - call netcdf_check(nf90_def_dim(ncfileid,'lon',grid%nx,dimid_lon), & - & 'nf90_def_dim', context='lon') + ! reverse latitudes (so they are in increasing order, S to N) + if (grid%rlat(1,1) > grid%rlat(1,grid%nlats)) then + do j=1,grid%nlats + an_grid%lat(j) = grid%rlat(1,grid%nlats-j+1) + enddo + else + an_grid%lat = grid%rlat(1,:) + endif - call netcdf_check(nf90_def_dim(ncfileid,'lat',grid%ny,dimid_lat), & - & 'nf90_def_dim', context='lat') + ! Fill 1D vertical arrays with level numbers: - call netcdf_check(nf90_def_dim(ncfileid,'lev',grid%nz,dimid_lev), & - & 'nf90_def_dim', context='lev') + nz_init: do k = 1, an_grid%nz + an_grid%lev(k) = real(k) + an_grid%pfull(k) = real(k) + end do nz_init - call netcdf_check(nf90_def_dim(ncfileid,'ilev',grid%nzp1,dimid_ilev), & - & 'nf90_def_dim', context='ilev') + nzp1_init: do k = 1, an_grid%nzp1 + an_grid%ilev(k) = real(k) + an_grid%hyai(k) = real(k) + an_grid%hybi(k) = real(k) + end do nzp1_init - if (debug) print *,'dims',grid%nx,grid%ny,grid%nz,grid%nzp1 + ! Deallocate entire grid. + call gfs_grid_cleanup(grid) + call gfs_nems_finalize() - dimid_1d(1) = dimid_lon - call netcdf_check(nf90_def_var(ncfileid,'lon',nf90_float,dimid_1d,varid_lon), & - & 'nf90_def_var lon') - call netcdf_check(nf90_put_att(ncfileid,varid_lon,'units','degrees_east'), & - & 'nf90_put_att', context='lon units') + ! ------------------------------------------------------------------ + ! Start the NetCDF file creation. Define vars and write + ! non-increment vars. - dimid_1d(1) = dimid_lat - call netcdf_check(nf90_def_var(ncfileid,'lat',nf90_float,dimid_1d,varid_lat), & - & 'nf90_def_var', context='lat') - call netcdf_check(nf90_put_att(ncfileid,varid_lat,'units','degrees_north'), & - & 'nf90_put_att', context='lat units') + call fv3_increment_def_start(an_grid,ncdat) - dimid_1d(1) = dimid_lev - call netcdf_check(nf90_def_var(ncfileid,'lev',nf90_float,dimid_1d,varid_lev), & - & 'nf90_def_var', context='lev') + var_def_loop: do ivar=1,n_inc_vars + call fv3_increment_def_var(ncdat,output_vars(ivar)) + if(trim(input_vars(ivar)) == 'icmr' .and. .not. do_icmr) then + if (mype==0) print 100, output_vars(ivar), 'do_icmr = F so var will not be in netcdf' + cycle var_def_loop + endif + enddo var_def_loop - call netcdf_check(nf90_def_var(ncfileid,'pfull',nf90_float,dimid_1d,varid_pfull), & - & 'nf90_def_var', context='pfull') + call fv3_increment_def_end(ncdat) + call fv3_increment_write_start(an_grid,ncdat) - dimid_1d(1) = dimid_ilev - call netcdf_check(nf90_def_var(ncfileid,'ilev',nf90_float,dimid_1d,varid_ilev), & - & 'nf90_def_var', context='ilev') + ! ------------------------------------------------------------------ + ! Deal with 3D arrays - call netcdf_check(nf90_def_var(ncfileid,'hyai',nf90_float,dimid_1d,varid_hyai), & - & 'nf90_def_var', context='hyai') + var_loop: do ivar=1,n_inc_vars + ! Skip this var if it is icmr and we're told not to do_icmr: + if(trim(input_vars(ivar)) == 'icmr' .and. .not. do_icmr) then + if (mype==0) print 100, trim(output_vars(ivar)), & + 'do_icmr = F so will not diff this var' + cycle var_loop + endif - call netcdf_check(nf90_def_var(ncfileid,'hybi',nf90_float,dimid_1d,varid_hybi), & - & 'nf90_def_var', context='hybi') + ! Skip this var if it is to be zero. No point in reading it... + zero_or_read: if(should_zero_increments_for(var_zero_synonyms(ivar))) then + if (mype==0) print 100, trim(output_vars(ivar)), & + 'is in incvars_to_zero; setting increments to zero' + an_grid%var3d = 0 + else - dimid_3d(1) = dimid_lon - dimid_3d(2) = dimid_lat - dimid_3d(3) = dimid_lev + ! This var should not be skipped. Let's get the analysis and + ! first guess from the input files. + if(trim(input_vars(ivar)) == 'dpres') then + ! Special case. We may have to calculate the 3D pressure + ! from the 2D surface pressure and coordinate system using + ! the hydrostatic approximation. + call fv3_analysis_read_or_calc_dpres(an_grid,mype) + call fv3_analysis_read_or_calc_dpres(fg_grid,mype) + else + ! Read the variable from the files directly. + if (mype==0) print 100, trim(output_vars(ivar)), 'read variable' + call fv3_analysis_read_var(an_grid,input_vars(ivar)) + call fv3_analysis_read_var(fg_grid,input_vars(ivar)) + endif + + ! Subtract and write + an_grid%var3d = an_grid%var3d - fg_grid%var3d + + ! Flip increment if the delz background is positive (GFSv15) + if(trim(input_vars(ivar)) == 'delz') then + if (sum(fg_grid%var3d) > 0.0_r_kind) then + an_grid%var3d = an_grid%var3d * -1.0_r_kind + endif + endif + endif zero_or_read + + call fv3_netcdf_write_var3d(ncdat,output_vars(ivar),an_grid%var3d) + enddo var_loop + + call fv3_increment_write_end(ncdat) + + call fv3_grid_deallocate(an_grid,fg_grid) + + end subroutine fv3_calc_increment - call netcdf_check(nf90_def_var(ncfileid,'u_inc',nf90_float,dimid_3d,varid_u_inc), & - & 'nf90_def_var', context='u_inc') + !======================================================================= - call netcdf_check(nf90_def_var(ncfileid,'v_inc',nf90_float,dimid_3d,varid_v_inc), & - & 'nf90_def_var', context='v_inc') + !! Is this variable in incvars_to_zero? + logical function should_zero_increments_for(check_var) - call netcdf_check(nf90_def_var(ncfileid,'delp_inc',nf90_float,dimid_3d,varid_delp_inc), & - & 'nf90_def_var', context='delp_inc') + character(len=*), intent(in) :: check_var !! Variable to search for - call netcdf_check(nf90_def_var(ncfileid,'delz_inc',nf90_float,dimid_3d,varid_delz_inc), & - & 'nf90_def_var', context='delz_inc') + ! Local variables - call netcdf_check(nf90_def_var(ncfileid,'T_inc',nf90_float,dimid_3d,varid_temp_inc), & - & 'nf90_def_var', context='temp_inc') + character(len=10) :: varname ! temporary string for storing variable names + integer :: i ! incvars_to_zero loop index - call netcdf_check(nf90_def_var(ncfileid,'sphum_inc',nf90_float,dimid_3d,varid_sphum_inc), & - & 'nf90_def_var', context='sphum_inc') + should_zero_increments_for=.false. - call netcdf_check(nf90_def_var(ncfileid,'liq_wat_inc',nf90_float,dimid_3d,varid_clwmr_inc), & - & 'nf90_def_var', context='clwmr_inc') + zeros_loop: do i=1,max_vars + varname = incvars_to_zero(i) + if ( trim(varname) == check_var ) then + should_zero_increments_for=.true. + return + endif + end do zeros_loop - call netcdf_check(nf90_def_var(ncfileid,'o3mr_inc',nf90_float,dimid_3d,varid_o3mr_inc), & - & 'nf90_def_var', context='o3mr_inc') + end function should_zero_increments_for - if ( do_icmr ) then - call netcdf_check(nf90_def_var(ncfileid,'icmr_inc',nf90_float,dimid_3d, varid_icmr_inc), & - & 'nf90_def_var', context='icmr_inc') - endif + !======================================================================= + !== BASIC NETCDF UTILITIES ============================================= + !======================================================================= - call netcdf_check(nf90_put_att(ncfileid,nf90_global,'source','GSI'), & - & 'nf90_put_att', context='source') + subroutine fv3_netcdf_def_var(ncdat,varname,ncdimid,att1_name,& + att1_values,att2_name,att2_values) - call netcdf_check(nf90_put_att(ncfileid,nf90_global,'comment','global analysis increment from calc_increment.x'), & - & 'nf90_put_att', context='comment') + ! Define variables passed to routine - call netcdf_check(nf90_enddef(ncfileid), & - & 'nf90_enddef') + type(increment_netcdf) :: ncdat !! NetCDF file ids + character(len=*) :: varname !! Name of the variable to define + integer, dimension(:) :: ncdimid !! IDs of the file dimensions + character(len=*), optional :: att1_name !! name of the first attribute + character(len=*), optional :: att1_values !! value of the first attribute + character(len=*), optional :: att2_name !! name of the second attribute + character(len=*), optional :: att2_values !! value of the second attribute + + ! Local variable + + integer :: ncvarid ! NetCDF variable ID of the variable we create. + + ! Define the variable in the NetCDF file. + call netcdf_check( & + nf90_def_var(ncdat%ncfileid,varname,nf90_float,ncdimid,ncvarid), & + 'nf90_def_var',context=varname) + + ! If attributes were given, define those too. + if(present(att1_name) .and. present(att1_values)) then + call netcdf_check( & + nf90_put_att(ncdat%ncfileid,ncvarid,att1_name,att1_values), & + 'nf90_def_var',context=varname // ' ' // att1_name) + end if + if(present(att2_name) .and. present(att2_values)) then + call netcdf_check( & + nf90_put_att(ncdat%ncfileid,ncvarid,att2_name,att2_values), & + 'nf90_def_var',context=varname // ' ' // att2_name) + end if + end subroutine fv3_netcdf_def_var - call netcdf_check(nf90_put_var(ncfileid,varid_lon,grid%lon), & - & 'nf90_put_var', context='lon') + !======================================================================= - call netcdf_check(nf90_put_var(ncfileid,varid_lat,grid%lat), & - & 'nf90_put_var', context='lat') + subroutine fv3_netcdf_write_var1d(ncdat,varname,values) - call netcdf_check(nf90_put_var(ncfileid,varid_lev,grid%lev), & - & 'nf90_put_var', context='lev') + ! Define variables passed to routine - call netcdf_check(nf90_put_var(ncfileid,varid_ilev,grid%ilev), & - & 'nf90_put_var', context='ilev') + type(increment_netcdf) :: ncdat + character(len=*) :: varname + real(r_kind), intent(in), dimension(:) :: values - call netcdf_check(nf90_put_var(ncfileid,varid_pfull,grid%pfull), & - & 'nf90_put_var', context='pfull') + ! Define variables computed within routine - call netcdf_check(nf90_put_var(ncfileid,varid_hyai,grid%hyai), & - & 'nf90_put_var', context='hyai') + integer :: ncvarid - call netcdf_check(nf90_put_var(ncfileid,varid_hybi,grid%hybi), & - & 'nf90_put_var', context='hybi') + call netcdf_check(nf90_inq_varid(ncdat%ncfileid,varname,ncvarid),& + 'nf90_inq_varid',context=varname) + call netcdf_check(nf90_put_var(ncdat%ncfileid,ncvarid,values),& + 'nf90_put_var',context=varname) - if (debug) print*, 'writing u_inc min/max =', minval(grid%u_inc),maxval(grid%u_inc) - call netcdf_check(nf90_put_var(ncfileid,varid_u_inc,grid%u_inc), & - & 'nf90_put_var', context='u_inc') + end subroutine fv3_netcdf_write_var1d - if (debug) print*, 'writing v_inc min/max =', minval(grid%v_inc),maxval(grid%v_inc) - call netcdf_check(nf90_put_var(ncfileid,varid_v_inc,grid%v_inc), & - & 'nf90_put_var', context='v_inc') + !======================================================================= - if (debug) print*, 'writing delp_inc min/max =', minval(grid%delp_inc),maxval(grid%delp_inc) - call netcdf_check(nf90_put_var(ncfileid,varid_delp_inc,grid%delp_inc), & - & 'nf90_put_var', context='delp_inc') + subroutine fv3_netcdf_write_var3d(ncdat,varname,values) - if (debug) print*, 'writing delz_inc min/max =', minval(grid%delz_inc),maxval(grid%delz_inc) - call netcdf_check(nf90_put_var(ncfileid,varid_delz_inc,grid%delz_inc), & - & 'nf90_put_var', context='delz_inc') + ! Define variables passed to routine - if (debug) print*, 'writing temp_inc min/max =', minval(grid%temp_inc),maxval(grid%temp_inc) - call netcdf_check(nf90_put_var(ncfileid,varid_temp_inc,grid%temp_inc), & - & 'nf90_put_var', context='temp_inc') + type(increment_netcdf) :: ncdat + character(len=*),intent(in) :: varname + real(r_kind), intent(in), dimension(:,:,:) :: values - if (debug) print*, 'writing sphum_inc min/max =', minval(grid%sphum_inc),maxval(grid%sphum_inc) - call netcdf_check(nf90_put_var(ncfileid,varid_sphum_inc,grid%sphum_inc), & - & 'nf90_put_var', context='sphum_inc') + ! Define variables computed within routine - if (debug) print*, 'writing clwmr_inc min/max =', minval(grid%clwmr_inc),maxval(grid%clwmr_inc) - call netcdf_check(nf90_put_var(ncfileid,varid_clwmr_inc,grid%clwmr_inc), & - & 'nf90_put_var', context='clwmr_inc') + integer :: ncvarid - if (debug) print*, 'writing o3mr_inc min/max =', minval(grid%o3mr_inc),maxval(grid%o3mr_inc) - call netcdf_check(nf90_put_var(ncfileid,varid_o3mr_inc,grid%o3mr_inc), & - & 'nf90_put_var', context='o3mr_inc') + call netcdf_check(nf90_inq_varid(ncdat%ncfileid,varname,ncvarid),& + 'nf90_inq_varid',context=varname) + call netcdf_check(nf90_put_var(ncdat%ncfileid,ncvarid,values),& + 'nf90_put_var',context=varname) - if ( do_icmr ) then - if (debug) print*, 'writing icmr_inc min/max =', minval(grid%icmr_inc),maxval(grid%icmr_inc) - call netcdf_check(nf90_put_var(ncfileid,varid_icmr_inc,grid%icmr_inc), & - & 'nf90_put_var', context='icmr_inc') - endif + end subroutine fv3_netcdf_write_var3d - call netcdf_check(nf90_close(ncfileid), & - & 'nf90_close') + !======================================================================= - !===================================================================== + integer function fv3_netcdf_def_dim(ncdat,dimname,dimlen) + ! Arguments to function + type(increment_netcdf) :: ncdat !! storage areas for some netcdf ids + character(len=*) :: dimname !! name of the new dimension + integer :: dimlen !! length of the new dimension - end subroutine fv3_increment_write + call netcdf_check(& + nf90_def_dim(ncdat%ncfileid,dimname,dimlen,fv3_netcdf_def_dim),& + 'nf90_def_dim',context=dimname) - !======================================================================= + end function fv3_netcdf_def_dim !======================================================================= subroutine netcdf_check(ncstatus, nf90_call, context) - + use mpi implicit none - integer, intent(in) :: ncstatus - character(len=*), intent(in) :: nf90_call - character(len=*), intent(in), optional :: context + ! Arguments to subroutine + integer, intent(in) :: ncstatus !! return status from nf90 function + character(len=*), intent(in) :: nf90_call !! name of the called function + character(len=*), intent(in), optional :: context !! contextual info + + integer :: ierr - character(len=500) :: error_msg + ! Formats for print statements +100 format('error in: ',A,': ',A,': ',A) ! context was supplied +200 format('error in: ',A,': ',A) ! context was not supplied + ! If the nf90 function returned an error status then... if (ncstatus /= nf90_noerr) then + + ! send an informative message to stdout and stderr... if ( present(context) ) then - error_msg = 'error in: ' // trim(nf90_call) // ': ' // trim(context) // ': '//trim(nf90_strerror(ncstatus)) + write(0,100) trim(nf90_call), trim(context), trim(nf90_strerror(ncstatus)) + print 100, trim(nf90_call), trim(context), trim(nf90_strerror(ncstatus)) else - error_msg = 'error in: ' // trim(nf90_call) // ': ' // trim(nf90_strerror(ncstatus)) + write(0,200) trim(nf90_call), trim(nf90_strerror(ncstatus)) + print 200, trim(nf90_call), trim(nf90_strerror(ncstatus)) endif - print*, trim(error_msg) - stop 1 + + ! ...and abort the whole program. + call MPI_Abort(MPI_COMM_WORLD,1,ierr) endif end subroutine netcdf_check + !======================================================================= + !== Increment File Output Utilities ==================================== !======================================================================= - ! fv3_increment_compute.f90: + subroutine fv3_increment_def_start(grid,ncdat) - !----------------------------------------------------------------------- + ! Define arguments to this subroutine - subroutine fv3_increment_compute(incr_grid) + type(analysis_grid) :: grid !! analysis grid data + type(increment_netcdf) :: ncdat !! netcdf file ids - ! Define variables passed to routine + print *,'writing to ',trim(increment_filename) - type(increment_grid) :: incr_grid + ! Create the NetCDF file. + + call netcdf_check(nf90_create(trim(increment_filename), & + cmode=ior(NF90_CLOBBER,NF90_64BIT_OFFSET),ncid=ncdat%ncfileid), & + & 'nf90_create') - ! Define variables computed within routine + ! Define the dimensions. - type(gfs_grid) :: grid + ncdat%dimid_lon=fv3_netcdf_def_dim(ncdat,'lon',grid%nx) + ncdat%dimid_lat=fv3_netcdf_def_dim(ncdat,'lat',grid%ny) + ncdat%dimid_lev=fv3_netcdf_def_dim(ncdat,'lev',grid%nz) + ncdat%dimid_ilev=fv3_netcdf_def_dim(ncdat,'ilev',grid%nzp1) - ! Define counting variables + if (debug) print *,'dims',grid%nx,grid%ny,grid%nz,grid%nzp1 - integer :: i, j, k + ! Define the variables that are NOT increments: - ! Define variable name string + call fv3_netcdf_def_var(ncdat,'lon',(/ncdat%dimid_lon/),'units','degrees_east') + call fv3_netcdf_def_var(ncdat,'lat',(/ncdat%dimid_lat/),'units','degrees_north') + call fv3_netcdf_def_var(ncdat,'lev',(/ncdat%dimid_lev/)) + call fv3_netcdf_def_var(ncdat,'pfull',(/ncdat%dimid_lev/)) + call fv3_netcdf_def_var(ncdat,'ilev',(/ncdat%dimid_ilev/)) + call fv3_netcdf_def_var(ncdat,'hyai',(/ncdat%dimid_ilev/)) + call fv3_netcdf_def_var(ncdat,'hybi',(/ncdat%dimid_ilev/)) - character(len=10) :: varname + end subroutine fv3_increment_def_start - !===================================================================== + !======================================================================= - ! Define local variables + subroutine fv3_increment_def_var(ncdat,var) - call init_constants_derived() - call fv3_increment_initialize(incr_grid) - an_grid%filename = analysis_filename - fg_grid%filename = firstguess_filename - call fv3_increment_define_analysis(an_grid) - call fv3_increment_define_analysis(fg_grid) - - ! Compute local variables - - incr_grid%u_inc = an_grid%ugrd - fg_grid%ugrd - incr_grid%v_inc = an_grid%vgrd - fg_grid%vgrd - incr_grid%delp_inc = an_grid%dpres - fg_grid%dpres - incr_grid%delz_inc = an_grid%delz - fg_grid%delz - incr_grid%temp_inc = an_grid%tmp - fg_grid%tmp - incr_grid%sphum_inc = an_grid%spfh - fg_grid%spfh - incr_grid%clwmr_inc = an_grid%clwmr - fg_grid%clwmr - incr_grid%o3mr_inc = an_grid%o3mr - fg_grid%o3mr - if ( do_icmr ) incr_grid%icmr_inc = an_grid%icmr - fg_grid%icmr - - do i=1,max_vars - varname = incvars_to_zero(i) - if ( trim(varname) /= 'NONE' ) then - if ( trim(varname) == 'u_inc' ) incr_grid%u_inc = zero - if ( trim(varname) == 'v_inc' ) incr_grid%v_inc = zero - if ( trim(varname) == 'delp_inc' ) incr_grid%delp_inc = zero - if ( trim(varname) == 'delz_inc' ) incr_grid%delz_inc = zero - if ( trim(varname) == 'temp_inc' ) incr_grid%temp_inc = zero - if ( trim(varname) == 'sphum_inc' ) incr_grid%sphum_inc = zero - if ( trim(varname) == 'clwmr_inc' ) incr_grid%clwmr_inc = zero - if ( trim(varname) == 'o3mwr_inc' ) incr_grid%o3mr_inc = zero - if ( do_icmr .and. trim(varname) == 'icmr_inc' ) incr_grid%icmr_inc = zero - else - cycle - endif - enddo + type(increment_netcdf) :: ncdat !! netcdf file ids + character(len=*) :: var !! Name of the variable to define - ! Define local variables + ! Locals + integer, dimension(3) :: dimid_3d - grid%nlons = meta_nemsio%dimx - grid%nlats = meta_nemsio%dimy - call gfs_grid_initialize(grid, meta_nemsio) - !incr_grid%lon = grid%rlon(:,1)*rad2deg - !incr_grid%lat = grid%rlat(1,:)*rad2deg - incr_grid%lon = grid%rlon(:,1) - ! reverse latitudes (so they are in increasing order, S to N) - if (grid%rlat(1,1) > grid%rlat(1,grid%nlats)) then - do j=1,grid%nlats - incr_grid%lat(j) = grid%rlat(1,grid%nlats-j+1) - enddo - else - incr_grid%lat = grid%rlat(1,:) - endif + dimid_3d = (/ ncdat%dimid_lon, ncdat%dimid_lat, ncdat%dimid_lev /) - ! Loop through local variable + call fv3_netcdf_def_var(ncdat,var,dimid_3d) + end subroutine fv3_increment_def_var - do k = 1, incr_grid%nz + !======================================================================= + + subroutine fv3_increment_def_end(ncdat) + !Arguments to routine + type(increment_netcdf) :: ncdat + + ! Write the global variables: source of this data and comment: + + call netcdf_check(nf90_put_att(ncdat%ncfileid,nf90_global,'source','GSI'), & + & 'nf90_put_att', context='source') - ! Define local variables + call netcdf_check(nf90_put_att(ncdat%ncfileid,nf90_global, & + 'comment','global analysis increment from calc_increment.x'), & + 'nf90_put_att', context='comment') - incr_grid%lev(k) = real(k) - incr_grid%pfull(k) = real(k) + ! Terminate the definition phase of the NetCDF output: + call netcdf_check(nf90_enddef(ncdat%ncfileid),'nf90_enddef') + end subroutine fv3_increment_def_end - end do ! do k = 1, incr_grid%nz + !======================================================================= - ! Loop through local variable + subroutine fv3_increment_write_start(grid,ncdat) + !Arguments to routine + type(analysis_grid) :: grid + type(increment_netcdf) :: ncdat + + ! Write the variables that are NOT incremented: + call fv3_netcdf_write_var1d(ncdat,'lon',grid%lon) + call fv3_netcdf_write_var1d(ncdat,'lat',grid%lat) + call fv3_netcdf_write_var1d(ncdat,'lev',grid%lev) + call fv3_netcdf_write_var1d(ncdat,'ilev',grid%ilev) + call fv3_netcdf_write_var1d(ncdat,'lon',grid%lon) + call fv3_netcdf_write_var1d(ncdat,'pfull',grid%pfull) + call fv3_netcdf_write_var1d(ncdat,'hyai',grid%hyai) + call fv3_netcdf_write_var1d(ncdat,'hybi',grid%hybi) + end subroutine fv3_increment_write_start - do k = 1, incr_grid%nzp1 + !======================================================================= - ! Define local variables + subroutine fv3_increment_write_end(ncdat) + !Arguments to routine + type(increment_netcdf) :: ncdat - incr_grid%ilev(k) = real(k) - incr_grid%hyai(k) = real(k) - incr_grid%hybi(k) = real(k) + ! Close the NetCDF file. This also flushes buffers. + call netcdf_check(nf90_close(ncdat%ncfileid),'nf90_close',& + context=trim(increment_filename)) + end subroutine fv3_increment_write_end - end do ! do k = 1, incr_grid%nzp1 + !======================================================================= + !== Analysis / First Guess Read Utilities ============================== + !======================================================================= - ! Deallocate memory for local variables + !! Read one variable that is NOT pressure + subroutine fv3_analysis_read_var(grid,varname) + ! Arguments to function - call gfs_grid_cleanup(grid) + type(analysis_grid) :: grid !! the analysis or first guess grid + character(len=*) :: varname !! name of the variable to read - !===================================================================== + ! local variables - end subroutine fv3_increment_compute + type(varinfo) :: var_info ! to request a variable from gfs_nems_read + real(r_kind), allocatable :: workgrid(:) ! for reordering data + integer :: k ! Vertical index loop when reading data level-by-level - !======================================================================= - ! fv3_increment_define_analysis.f90: + ! Read the nemsio file header + call gfs_nems_initialize(meta_nemsio,filename=grid%filename) - !----------------------------------------------------------------------- + ! Allocate our local work array + allocate(workgrid(grid%nx*grid%ny)) - subroutine fv3_increment_define_analysis(grid) + ! Read in the variable, level-by-level: + do k = 1, grid%nz + var_info%var_name=varname + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + var_info%nems_levtyp,k) - ! Define variables passed to routine + grid%var3d(:,:,grid%nz-k+1)=reshape(workgrid,(/grid%nx,grid%ny/)) + if (grid%flip_lats) then + call gfs_nems_flip_xlat_axis( & + meta_nemsio,grid%var3d(:,:,grid%nz - k + 1)) + endif + end do - type(analysis_grid) :: grid + ! Close the nemsio file + call gfs_nems_finalize() - ! Define variables computed within routine + deallocate(workgrid) - type(varinfo) :: var_info + end subroutine fv3_analysis_read_var - real(r_kind), dimension(:,:,:), allocatable :: pressi - real(r_kind), dimension(:,:,:), allocatable :: vcoord - real(r_kind), dimension(:), allocatable :: workgrid + !======================================================================= - logical :: flip_lats - logical :: ldpres = .false. + !! Read or calculate 3D pressure + subroutine fv3_analysis_read_or_calc_dpres(grid,mype) + ! Arguments to function - ! Define counting variables + type(analysis_grid) :: grid !! the analysis or first guess grid + integer,intent(in) :: mype - integer :: i, j, k + ! local variables - !===================================================================== + type(varinfo) :: var_info ! to request a variable from gfs_nems_read + real(r_kind), allocatable :: workgrid(:) ! for reordering data + real(r_kind), allocatable :: pressi(:,:,:) ! interface pressure, 3D + real(r_kind), allocatable :: vcoord(:,:,:) ! a & b for hydro. approx. + integer :: k ! Vertical index loop when reading data level-by-level - ! Define local variables +100 format(A,': ',A) + ! Read the nemsio file header call gfs_nems_initialize(meta_nemsio,filename=grid%filename) - ! Allocate memory for local variables - if(.not. allocated(pressi)) & - & allocate(pressi(meta_nemsio%dimx,meta_nemsio%dimy, & - & meta_nemsio%dimz + 1)) - if(.not. allocated(vcoord)) & - & allocate(vcoord(meta_nemsio%dimz + 1,3,2)) - if(.not. allocated(workgrid)) & - & allocate(workgrid(meta_nemsio%dimx*meta_nemsio%dimy)) + allocate(vcoord(meta_nemsio%dimz + 1,3,2)) + allocate(workgrid(meta_nemsio%dimx*meta_nemsio%dimy)) - ! Define local variables + ! Is the 3D pressure in the file? + grid%ldpres = gfs_nems_variable_exist(meta_nemsio,'dpres') - if (debug) print *,'lats',meta_nemsio%lat(1), meta_nemsio%lat(meta_nemsio%dimx*meta_nemsio%dimy) - if (meta_nemsio%lat(1) > meta_nemsio%lat(meta_nemsio%dimx*meta_nemsio%dimy)) then - flip_lats = .true. - else - flip_lats = .false. - endif - if (debug) print *,'flip_lats',flip_lats + if ( .not. grid%ldpres ) then + ! The 3D pressure is NOT in the file. We need to calculate + ! pressure from the hydrostatic approximation and surface + ! pressure. - ldpres = gfs_nems_variable_exist(meta_nemsio,'dpres') + if (mype==0) print 100,'dpres','calculate from 2D psfc and hydro. approx.' - if ( .not. ldpres ) then + ! Allocate an array for the interface pressure. + if(.not. allocated(pressi)) then + allocate(pressi(meta_nemsio%dimx,meta_nemsio%dimy, & + meta_nemsio%dimz + 1)) + endif - call gfs_nems_vcoord(meta_nemsio,grid%filename,vcoord) + ! Read the A, B, and surface pressure + call gfs_nems_vcoord(meta_nemsio,trim(grid%filename),vcoord) grid%ak = vcoord(:,1,1) grid%bk = vcoord(:,2,1) var_info%var_name = 'psfc' @@ -544,290 +616,170 @@ subroutine fv3_increment_define_analysis(grid) grid%psfc(:,:) = reshape(workgrid,(/meta_nemsio%dimx, & & meta_nemsio%dimy/)) + ! Apply the hydrostatic approximation to get 3D interface pressure: do k = 1, meta_nemsio%dimz + 1 pressi(:,:,k) = grid%ak(k) + grid%bk(k)*grid%psfc(:,:) end do ! do k = 1, meta_nemsio%dimz + 1 - + else + if (mype==0) print 100,'dpres','read from file; do not calculate' endif + ! Calculate or read the mid-level 3D pressure: do k = 1, meta_nemsio%dimz - - ! Define local variables - - if ( ldpres ) then - var_info%var_name = 'dpres' + if ( grid%ldpres ) then + ! Pressure is already in the file. Read the 3D pressure array. + var_info%var_name = 'dpres' call variable_lookup(var_info) - call gfs_nems_read(workgrid,var_info%nems_name, & - & var_info%nems_levtyp,k) - grid%dpres(:,:,meta_nemsio%dimz - k + 1) = & - & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) + call gfs_nems_read(workgrid,var_info%nems_name, & + var_info%nems_levtyp,k) + grid%var3d(:,:,meta_nemsio%dimz - k + 1) = & + reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) else - grid%dpres(:,:,meta_nemsio%dimz - k + 1) = pressi(:,:,k) - & - & pressi(:,:,k+1) + ! Convert interface pressure to mass level pressure, using + ! the 3D array generated in the prior loop: + grid%var3d(:,:,meta_nemsio%dimz - k + 1) = & + pressi(:,:,k) - pressi(:,:,k+1) endif - !if (debug) print *,'dpres',k,minval(grid%dpres(:,:,meta_nemsio%dimz - k + 1)),& - !maxval(grid%dpres(:,:,meta_nemsio%dimz - k + 1)) - if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & - & grid%dpres(:,:,meta_nemsio%dimz - k + 1)) - var_info%var_name = 'delz' - call variable_lookup(var_info) - call gfs_nems_read(workgrid,var_info%nems_name, & - & var_info%nems_levtyp,k) - grid%delz(:,:,meta_nemsio%dimz - k + 1) = & - & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) - if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & - & grid%delz(:,:,meta_nemsio%dimz - k + 1)) - var_info%var_name = 'ugrd' - call variable_lookup(var_info) - call gfs_nems_read(workgrid,var_info%nems_name, & - & var_info%nems_levtyp,k) - grid%ugrd(:,:,meta_nemsio%dimz - k + 1) = & - & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) - if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & - & grid%ugrd(:,:,meta_nemsio%dimz - k + 1)) - var_info%var_name = 'vgrd' - call variable_lookup(var_info) - call gfs_nems_read(workgrid,var_info%nems_name, & - & var_info%nems_levtyp,k) - grid%vgrd(:,:,meta_nemsio%dimz - k + 1) = & - & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) - if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & - & grid%vgrd(:,:,meta_nemsio%dimz - k + 1)) - var_info%var_name = 'spfh' - call variable_lookup(var_info) - call gfs_nems_read(workgrid,var_info%nems_name, & - & var_info%nems_levtyp,k) - grid%spfh(:,:,meta_nemsio%dimz - k + 1) = & - & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) - if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & - & grid%spfh(:,:,meta_nemsio%dimz - k + 1)) - var_info%var_name = 'tmp' - call variable_lookup(var_info) - call gfs_nems_read(workgrid,var_info%nems_name, & - & var_info%nems_levtyp,k) - grid%tmp(:,:,meta_nemsio%dimz - k + 1) = & - & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) - if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & - & grid%tmp(:,:,meta_nemsio%dimz - k + 1)) - var_info%var_name = 'clwmr' - call variable_lookup(var_info) - call gfs_nems_read(workgrid,var_info%nems_name, & - & var_info%nems_levtyp,k) - grid%clwmr(:,:,meta_nemsio%dimz - k + 1) = & - & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) - if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & - & grid%clwmr(:,:,meta_nemsio%dimz - k + 1)) - var_info%var_name = 'o3mr' - call variable_lookup(var_info) - call gfs_nems_read(workgrid,var_info%nems_name, & - & var_info%nems_levtyp,k) - grid%o3mr(:,:,meta_nemsio%dimz - k + 1) = & - & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) - if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & - & grid%o3mr(:,:,meta_nemsio%dimz - k + 1)) - if ( do_icmr ) then - var_info%var_name = 'icmr' - call variable_lookup(var_info) - call gfs_nems_read(workgrid,var_info%nems_name, & - & var_info%nems_levtyp,k) - grid%icmr(:,:,meta_nemsio%dimz - k + 1) = & - & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) - if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & - & grid%icmr(:,:,meta_nemsio%dimz - k + 1)) + + ! Flip the pressure in the latitude direction if needed + if (grid%flip_lats) then + call gfs_nems_flip_xlat_axis( & + meta_nemsio, grid%var3d(:,:,meta_nemsio%dimz - k + 1) ) endif + enddo - end do ! do k = 1, meta_nemsio%dimz - ! Deallocate memory for local variables + ! Deallocate memory for work arrays - if(allocated(pressi)) deallocate(pressi) - if(allocated(vcoord)) deallocate(vcoord) - if(allocated(workgrid)) deallocate(workgrid) + if(allocated(pressi)) then + deallocate(pressi) ! only allocated if hydro. pres. is used + endif + deallocate(vcoord) + deallocate(workgrid) - ! Define local variables + end subroutine fv3_analysis_read_or_calc_dpres - call gfs_nems_finalize() + !======================================================================= - !===================================================================== + !! Read everything that is NOT incremented, plus the pressure + subroutine fv3_analysis_read_non_inc_vars(grid) - end subroutine fv3_increment_define_analysis + type(analysis_grid) :: grid !! analysis or first guess to read - !======================================================================= + ! Local variables + + ! Read the nemsio file header + call gfs_nems_initialize(meta_nemsio,filename=grid%filename) - ! fv3_increment_initialize.f90: + ! Allocate memory for work arrays + grid%nx=meta_nemsio%dimx + grid%ny=meta_nemsio%dimy + grid%nz=meta_nemsio%dimz - !----------------------------------------------------------------------- + ! Determine ordering of latitudes: + if (debug) then + print *,'lats',meta_nemsio%lat(1), meta_nemsio%lat( & + meta_nemsio%dimx*meta_nemsio%dimy) + endif + if (meta_nemsio%lat(1) > meta_nemsio%lat(meta_nemsio%dimx*meta_nemsio%dimy)) then + grid%flip_lats = .true. + else + grid%flip_lats = .false. + endif + if (debug) print *,'flip_lats',grid%flip_lats - subroutine fv3_increment_initialize(grid) + ! Close this nemsio file. + call gfs_nems_finalize() - ! Define variables passed to routine + end subroutine fv3_analysis_read_non_inc_vars - type(increment_grid) :: grid + !======================================================================= + !== Memory Management ================================================== + !======================================================================= - !===================================================================== + subroutine fv3_grid_allocate(an_grid,fg_grid) - ! Define local variables + type(analysis_grid) :: an_grid !! analysis grid + type(analysis_grid) :: fg_grid !! first guess grid + + ! Get the grid dimensions from the analysis file call gfs_nems_initialize(meta_nemsio,filename=analysis_filename) - grid%nx = meta_nemsio%dimx - grid%ny = meta_nemsio%dimy - grid%nz = meta_nemsio%dimz - grid%nzp1 = grid%nz + 1 + an_grid%nx = meta_nemsio%dimx + an_grid%ny = meta_nemsio%dimy + an_grid%nz = meta_nemsio%dimz + an_grid%nzp1 = an_grid%nz + 1 call gfs_nems_finalize() - ! Allocate memory for local variables - - if(.not. allocated(grid%delp_inc)) & - & allocate(grid%delp_inc(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(grid%delz_inc)) & - & allocate(grid%delz_inc(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(grid%u_inc)) & - & allocate(grid%u_inc(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(grid%v_inc)) & - & allocate(grid%v_inc(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(grid%sphum_inc)) & - & allocate(grid%sphum_inc(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(grid%temp_inc)) & - & allocate(grid%temp_inc(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(grid%clwmr_inc)) & - & allocate(grid%clwmr_inc(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(grid%o3mr_inc)) & - & allocate(grid%o3mr_inc(grid%nx,grid%ny,grid%nz)) - if(do_icmr .and. .not. allocated(grid%icmr_inc)) & - & allocate(grid%icmr_inc(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(grid%lon)) & - & allocate(grid%lon(grid%nx)) - if(.not. allocated(grid%lat)) & - & allocate(grid%lat(grid%ny)) - if(.not. allocated(grid%lev)) & - & allocate(grid%lev(grid%nz)) - if(.not. allocated(grid%ilev)) & - & allocate(grid%ilev(grid%nzp1)) - if(.not. allocated(grid%pfull)) & - & allocate(grid%pfull(grid%nz)) - if(.not. allocated(grid%hyai)) & - & allocate(grid%hyai(grid%nzp1)) - if(.not. allocated(grid%hybi)) & - & allocate(grid%hybi(grid%nzp1)) - if(.not. allocated(an_grid%dpres)) & - & allocate(an_grid%dpres(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(an_grid%delz)) & - & allocate(an_grid%delz(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(an_grid%ugrd)) & - & allocate(an_grid%ugrd(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(an_grid%vgrd)) & - & allocate(an_grid%vgrd(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(an_grid%spfh)) & - & allocate(an_grid%spfh(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(an_grid%tmp)) & - & allocate(an_grid%tmp(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(an_grid%clwmr)) & - & allocate(an_grid%clwmr(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(an_grid%o3mr)) & - & allocate(an_grid%o3mr(grid%nx,grid%ny,grid%nz)) - if(do_icmr .and. .not. allocated(an_grid%icmr)) & - & allocate(an_grid%icmr(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(an_grid%psfc)) & - & allocate(an_grid%psfc(grid%nx,grid%ny)) - if(.not. allocated(an_grid%ak)) & - & allocate(an_grid%ak(grid%nz+1)) - if(.not. allocated(an_grid%bk)) & - & allocate(an_grid%bk(grid%nz+1)) - if(.not. allocated(an_grid%ck)) & - & allocate(an_grid%ck(grid%nz+1)) - if(.not. allocated(fg_grid%dpres)) & - & allocate(fg_grid%dpres(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(fg_grid%delz)) & - & allocate(fg_grid%delz(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(fg_grid%ugrd)) & - & allocate(fg_grid%ugrd(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(fg_grid%vgrd)) & - & allocate(fg_grid%vgrd(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(fg_grid%spfh)) & - & allocate(fg_grid%spfh(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(fg_grid%tmp)) & - & allocate(fg_grid%tmp(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(fg_grid%clwmr)) & - & allocate(fg_grid%clwmr(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(fg_grid%o3mr)) & - & allocate(fg_grid%o3mr(grid%nx,grid%ny,grid%nz)) - if(do_icmr .and. .not. allocated(fg_grid%icmr)) & - & allocate(fg_grid%icmr(grid%nx,grid%ny,grid%nz)) - if(.not. allocated(fg_grid%psfc)) & - & allocate(fg_grid%psfc(grid%nx,grid%ny)) - if(.not. allocated(fg_grid%ak)) & - & allocate(fg_grid%ak(grid%nz+1)) - if(.not. allocated(fg_grid%bk)) & - & allocate(fg_grid%bk(grid%nz+1)) - if(.not. allocated(fg_grid%ck)) & - & allocate(fg_grid%ck(grid%nz+1)) - - !===================================================================== - - end subroutine fv3_increment_initialize + ! Assume the first guess has the same dimensions. + + fg_grid%nx = an_grid%nx + fg_grid%ny = an_grid%ny + fg_grid%nz = an_grid%nz + fg_grid%nzp1 = an_grid%nzp1 + + if(.not.an_grid%is_allocated) then + allocate(an_grid%lon(an_grid%nx)) + allocate(an_grid%lat(an_grid%ny)) + allocate(an_grid%lev(an_grid%nz)) + allocate(an_grid%ilev(an_grid%nzp1)) + allocate(an_grid%pfull(an_grid%nz)) + allocate(an_grid%hyai(an_grid%nzp1)) + allocate(an_grid%hybi(an_grid%nzp1)) + + allocate(an_grid%var3d(an_grid%nx,an_grid%ny,an_grid%nz)) + allocate(an_grid%psfc(an_grid%nx,an_grid%ny)) + allocate(an_grid%ak(an_grid%nz+1)) + allocate(an_grid%bk(an_grid%nz+1)) + allocate(an_grid%ck(an_grid%nz+1)) + an_grid%is_allocated=.true. + endif - !======================================================================= + if(.not.fg_grid%is_allocated) then + allocate(fg_grid%var3d(fg_grid%nx,fg_grid%ny,fg_grid%nz)) + allocate(fg_grid%psfc(fg_grid%nx,fg_grid%ny)) + allocate(fg_grid%ak(fg_grid%nz+1)) + allocate(fg_grid%bk(fg_grid%nz+1)) + allocate(fg_grid%ck(fg_grid%nz+1)) + fg_grid%is_allocated=.true. + endif - ! fv3_increment_cleanup.f90: + end subroutine fv3_grid_allocate - !----------------------------------------------------------------------- + !======================================================================= - subroutine fv3_increment_cleanup(grid) + subroutine fv3_grid_deallocate(an_grid,fg_grid) + + type(analysis_grid) :: an_grid !! analysis grid + type(analysis_grid) :: fg_grid !! first guess grid + + if(an_grid%is_allocated) then + deallocate(an_grid%lon) + deallocate(an_grid%lat) + deallocate(an_grid%lev) + deallocate(an_grid%ilev) + deallocate(an_grid%pfull) + deallocate(an_grid%hyai) + deallocate(an_grid%hybi) + + deallocate(an_grid%var3d) + deallocate(an_grid%psfc) + deallocate(an_grid%ak) + deallocate(an_grid%bk) + deallocate(an_grid%ck) + an_grid%is_allocated=.false. + endif - ! Define variables passed to routine + if(fg_grid%is_allocated) then + deallocate(fg_grid%var3d) + deallocate(fg_grid%psfc) + deallocate(fg_grid%ak) + deallocate(fg_grid%bk) + deallocate(fg_grid%ck) + an_grid%is_allocated=.false. + endif - type(increment_grid) :: grid - - !===================================================================== - - ! Deallocate memory for local variables - - if(allocated(grid%delp_inc)) deallocate(grid%delp_inc) - if(allocated(grid%delz_inc)) deallocate(grid%delz_inc) - if(allocated(grid%u_inc)) deallocate(grid%u_inc) - if(allocated(grid%v_inc)) deallocate(grid%v_inc) - if(allocated(grid%sphum_inc)) deallocate(grid%sphum_inc) - if(allocated(grid%temp_inc)) deallocate(grid%temp_inc) - if(allocated(grid%clwmr_inc)) deallocate(grid%clwmr_inc) - if(allocated(grid%o3mr_inc)) deallocate(grid%o3mr_inc) - if(allocated(grid%icmr_inc)) deallocate(grid%icmr_inc) - if(allocated(grid%lon)) deallocate(grid%lon) - if(allocated(grid%lat)) deallocate(grid%lat) - if(allocated(grid%lev)) deallocate(grid%lev) - if(allocated(grid%ilev)) deallocate(grid%ilev) - if(allocated(grid%pfull)) deallocate(grid%pfull) - if(allocated(grid%hyai)) deallocate(grid%hyai) - if(allocated(grid%hybi)) deallocate(grid%hybi) - if(allocated(an_grid%dpres)) deallocate(an_grid%dpres) - if(allocated(an_grid%delz)) deallocate(an_grid%delz) - if(allocated(an_grid%ugrd)) deallocate(an_grid%ugrd) - if(allocated(an_grid%vgrd)) deallocate(an_grid%vgrd) - if(allocated(an_grid%spfh)) deallocate(an_grid%spfh) - if(allocated(an_grid%tmp)) deallocate(an_grid%tmp) - if(allocated(an_grid%clwmr)) deallocate(an_grid%clwmr) - if(allocated(an_grid%o3mr)) deallocate(an_grid%o3mr) - if(allocated(an_grid%icmr)) deallocate(an_grid%icmr) - if(allocated(an_grid%psfc)) deallocate(an_grid%psfc) - if(allocated(an_grid%ak)) deallocate(an_grid%ak) - if(allocated(an_grid%bk)) deallocate(an_grid%bk) - if(allocated(fg_grid%ck)) deallocate(an_grid%ck) - if(allocated(fg_grid%dpres)) deallocate(fg_grid%dpres) - if(allocated(fg_grid%delz)) deallocate(fg_grid%delz) - if(allocated(fg_grid%ugrd)) deallocate(fg_grid%ugrd) - if(allocated(fg_grid%vgrd)) deallocate(fg_grid%vgrd) - if(allocated(fg_grid%spfh)) deallocate(fg_grid%spfh) - if(allocated(fg_grid%tmp)) deallocate(fg_grid%tmp) - if(allocated(fg_grid%clwmr)) deallocate(fg_grid%clwmr) - if(allocated(fg_grid%o3mr)) deallocate(fg_grid%o3mr) - if(allocated(fg_grid%icmr)) deallocate(fg_grid%icmr) - if(allocated(fg_grid%psfc)) deallocate(fg_grid%psfc) - if(allocated(fg_grid%ak)) deallocate(fg_grid%ak) - if(allocated(fg_grid%bk)) deallocate(fg_grid%bk) - if(allocated(fg_grid%ck)) deallocate(fg_grid%ck) - - !===================================================================== - - end subroutine fv3_increment_cleanup + end subroutine fv3_grid_deallocate !======================================================================= diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/gfs_nems_interface.f90 b/util/EnKF/gfs/src/calc_increment_ens.fd/gfs_nems_interface.f90 index a034fe5b7..858577bce 100644 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/gfs_nems_interface.f90 +++ b/util/EnKF/gfs/src/calc_increment_ens.fd/gfs_nems_interface.f90 @@ -168,7 +168,10 @@ subroutine gfs_nems_initialize(meta_nemsio,filename) call nemsio_open(gfile,trim(adjustl(filename)),'read', & & iret=nemsio_iret) - if ( nemsio_iret /= 0 ) stop 2 + if ( nemsio_iret /= 0 ) then + write(0,*) 'cannot open for read: ',trim(adjustl(filename)) + stop 2 + end if call nemsio_getfilehead(gfile,iret=nemsio_iret, & & dimx=meta_nemsio%dimx, & & dimy=meta_nemsio%dimy, & @@ -309,7 +312,7 @@ subroutine gfs_nems_flip_xlat_axis(meta_nemsio,grid) ! Define counting variables - integer :: i, j, k + integer :: i, j !===================================================================== @@ -352,10 +355,6 @@ subroutine gfs_nems_read(nems_data,nems_varname,nems_levtyp,nems_lev) real(nemsio_realkind) :: nems_data(:) integer(nemsio_intkind) :: nems_lev - ! Define counting variables - - integer :: i, j, k - !===================================================================== ! Define local variables @@ -442,7 +441,7 @@ subroutine gfs_grid_initialize(grid,meta_nemsio) ! Define counting variables - integer :: i, j, k, n + integer :: i, j, n !===================================================================== diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/main.f90 b/util/EnKF/gfs/src/calc_increment_ens.fd/main.f90 index 20ee33836..69a70ab56 100644 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/main.f90 +++ b/util/EnKF/gfs/src/calc_increment_ens.fd/main.f90 @@ -32,6 +32,6 @@ program calc_increment_main endif enddo - call calc_increment() + call calc_increment(0) end program calc_increment_main diff --git a/util/EnKF/gfs/src/calc_increment_ens.fd/pmain.f90 b/util/EnKF/gfs/src/calc_increment_ens.fd/pmain.f90 index b16fcde43..9ef78eeb3 100644 --- a/util/EnKF/gfs/src/calc_increment_ens.fd/pmain.f90 +++ b/util/EnKF/gfs/src/calc_increment_ens.fd/pmain.f90 @@ -20,6 +20,8 @@ program calc_increment_pmain call mpi_comm_rank(mpi_comm_world, mype, ierr) call mpi_comm_size(mpi_comm_world, npes, ierr) + if (mype==0) call w3tagb('CALC_INCREMENT_ENS',2018,0177,0055,'NP20') + call read_namelist if ( mype == 0 ) call write_namelist @@ -60,7 +62,7 @@ program calc_increment_pmain write(6,*) 'task mype = ', mype, ' process ', trim(increment_filename) - call calc_increment() + call calc_increment(mype) else @@ -69,6 +71,9 @@ program calc_increment_pmain endif call mpi_barrier(mpi_comm_world, ierr) + + if (mype==0) call w3tage('CALC_INCREMENT_ENS') + call mpi_finalize(ierr) stop diff --git a/util/EnKF/gfs/src/calc_increment_serial.fd/CMakeLists.txt b/util/EnKF/gfs/src/calc_increment_serial.fd/CMakeLists.txt new file mode 100644 index 000000000..d9c40e8a4 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_serial.fd/CMakeLists.txt @@ -0,0 +1,13 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_UTIL) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + list( REMOVE_ITEM LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/main.f90 ) + + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) + add_executable(calc_increment_serial.x ${LOCAL_SRC} ) + set_target_properties( calc_increment_serial.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${UTIL_INC} ${CORE_INCS} ${NETCDF_INCLUDES} ) + target_link_libraries( calc_increment_serial.x ${CORE_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${MPI_Fortran_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ) + add_dependencies( calc_increment_serial.x enkfdeplib enkflib ) +endif() diff --git a/util/EnKF/gfs/src/calc_increment_serial.fd/calc_increment.f90 b/util/EnKF/gfs/src/calc_increment_serial.fd/calc_increment.f90 new file mode 100644 index 000000000..3d1804803 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_serial.fd/calc_increment.f90 @@ -0,0 +1,32 @@ +program calc_increment + + use kinds +!!use namelist_def, only : datapath + use namelist_def, only : analysis_filename, firstguess_filename, increment_filename, debug,& + zero_mpinc, imp_physics + use calc_increment_interface + + implicit none + + character(len=10) :: bufchar + + call getarg(1, analysis_filename) + call getarg(2, firstguess_filename) + call getarg(3, increment_filename) + call getarg(4, bufchar) + read(bufchar,'(L)') debug + call getarg(5, bufchar) + read(bufchar,'(L)') zero_mpinc + call getarg(6, bufchar) + read(bufchar,'(i5)') imp_physics + +!!write(6,*) 'DATAPATH = ', trim(datapath) + write(6,*) 'ANALYSIS FILENAME = ', trim(analysis_filename) + write(6,*) 'FIRSTGUESS FILENAME = ', trim(firstguess_filename) + write(6,*) 'INCREMENT FILENAME = ', trim(increment_filename) + write(6,*) 'DEBUG = ', debug + write(6,*) 'ZERO_MPINC = ', zero_mpinc + write(6,*) 'IMP_PHYSICS = ', imp_physics + call calculate_increment() + +end program calc_increment diff --git a/util/EnKF/gfs/src/calc_increment_serial.fd/calc_increment_interface.f90 b/util/EnKF/gfs/src/calc_increment_serial.fd/calc_increment_interface.f90 new file mode 100644 index 000000000..716d4c9af --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_serial.fd/calc_increment_interface.f90 @@ -0,0 +1,73 @@ +! Copyright (C) 2015 Henry R. Winterbottom + +! Email: Henry.Winterbottom@noaa.gov + +! Snail-mail: + +! Henry R. Winterbottom +! NOAA/OAR/PSD R/PSD1 +! 325 Broadway +! Boulder, CO 80303-3328 + +! This file is part of global-model-py. + +! global-model-py is free software: you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation, either version 3 of +! the License, or (at your option) any later version. + +! global-model-py is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU General Public License for more details. + +! You should have received a copy of the GNU General Public License +! along with global-model-py. If not, see +! . + +module calc_increment_interface + + !======================================================================= + + ! Define associated modules and subroutines + + !----------------------------------------------------------------------- + + use fv3_interface + + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + + ! Define interfaces and attributes for module routines + + private + public :: calculate_increment + + !----------------------------------------------------------------------- + +contains + + !======================================================================= + + ! calc_increment.f90: + + !----------------------------------------------------------------------- + + subroutine calculate_increment() + + !===================================================================== + + ! Check local variable and proceed accordingly + + call fv3_calc_increment() + + !===================================================================== + + end subroutine calculate_increment + + !======================================================================= + +end module calc_increment_interface diff --git a/util/EnKF/gfs/src/calc_increment_serial.fd/constants.f90 b/util/EnKF/gfs/src/calc_increment_serial.fd/constants.f90 new file mode 100644 index 000000000..137c08162 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_serial.fd/constants.f90 @@ -0,0 +1,316 @@ +! this module was extracted from the GSI version operational +! at NCEP in Dec. 2007. +module constants +!$$$ module documentation block +! . . . . +! module: constants +! prgmmr: treadon org: np23 date: 2003-09-25 +! +! abstract: This module contains the definition of various constants +! used in the gsi code +! +! program history log: +! 2003-09-25 treadon - original code +! 2004-03-02 treadon - allow global and regional constants to differ +! 2004-06-16 treadon - update documentation +! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind +! and tiny_single +! 2004-11-16 treadon - add huge_single, huge_r_kind parameters +! 2005-01-27 cucurull - add ione +! 2005-08-24 derber - move cg_term to constants from qcmod +! 2006-03-07 treadon - add rd_over_cp_mass +! 2006-05-18 treadon - add huge_i_kind +! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) +! 2006-07-28 derber - add r1000 +! +! Subroutines Included: +! sub init_constants - compute derived constants, set regional/global constants +! +! Variable Definitions: +! see below +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_single,r_kind,i_kind + implicit none + +! Declare constants + integer(i_kind) izero,ione + real(r_kind) rearth,grav,omega,rd,rv,cp,cv,cvap,cliq,rgas,rvap + real(r_kind) csol,hvap,hfus,psat,t0c,ttp,jcal,cp_mass,cg_term + real(r_kind) fv,deg2rad,rad2deg,pi,tiny_r_kind,huge_r_kind,huge_i_kind + real(r_kind) ozcon,rozcon,tpwcon,rd_over_g,rd_over_cp,g_over_rd + real(r_kind) amsua_clw_d1,amsua_clw_d2,constoz,zero,one,two,four + real(r_kind) one_tenth,quarter,three,five,rd_over_cp_mass, gamma + real(r_kind) rearth_equator,stndrd_atmos_ps,r1000 + real(r_kind) semi_major_axis,semi_minor_axis,n_a,n_b + real(r_kind) eccentricity,grav_polar,grav_ratio + real(r_kind) grav_equator,earth_omega,grav_constant + real(r_kind) flattening,eccentricity_linear,somigliana + real(r_kind) dldt,dldti,hsub,psatk,tmix,xa,xai,xb,xbi + real(r_kind) eps,epsm1,omeps,wgtlim + real(r_kind) elocp,cpr,el2orc,cclimit,climit,epsq + real(r_kind) pcpeff0,pcpeff1,pcpeff2,pcpeff3,rcp,c0,delta + real(r_kind) h1000,factor1,factor2,rhcbot,rhctop,dx_max,dx_min,dx_inv + real(r_kind) h300,half,cmr,cws,ke2,row,rrow + real(r_single) zero_single,tiny_single,huge_single + real(r_single) rmw_mean_distance, roic_mean_distance + logical :: constants_initialized = .true. + + +! Define constants common to global and regional applications +! name value description units +! ---- ----- ----------- ----- + parameter(rearth_equator= 6.37813662e6_r_kind) ! equatorial earth radius (m) + parameter(omega = 7.2921e-5_r_kind) ! angular velocity of earth (1/s) + parameter(rgas = 2.8705e+2_r_kind) + parameter(rvap = 4.6150e+2_r_kind) + parameter(cp = 1.0046e+3_r_kind) ! specific heat of air @pressure (J/kg/K) + parameter(cvap = 1.8460e+3_r_kind) ! specific heat of h2o vapor (J/kg/K) + parameter(csol = 2.1060e+3_r_kind) ! specific heat of solid h2o (ice)(J/kg/K) + parameter(hvap = 2.5000e+6_r_kind) ! latent heat of h2o condensation (J/kg) + parameter(hfus = 3.3358e+5_r_kind) ! latent heat of h2o fusion (J/kg) + parameter(psat = 6.1078e+2_r_kind) ! pressure at h2o triple point (Pa) + parameter(t0c = 2.7315e+2_r_kind) ! temperature at zero celsius (K) + parameter(ttp = 2.7316e+2_r_kind) ! temperature at h2o triple point (K) + parameter(jcal = 4.1855e+0_r_kind) ! joules per calorie () + parameter(stndrd_atmos_ps = 1013.25e2_r_kind) ! 1976 US standard atmosphere ps (Pa) + +! Numeric constants + parameter(izero = 0) + parameter(ione = 1) + parameter(zero_single = 0.0_r_single) + parameter(zero = 0.0_r_kind) + parameter(one_tenth = 0.10_r_kind) + parameter(quarter= 0.25_r_kind) + parameter(one = 1.0_r_kind) + parameter(two = 2.0_r_kind) + parameter(three = 3.0_r_kind) + parameter(four = 4.0_r_kind) + parameter(five = 5.0_r_kind) + parameter(r1000 = 1000.0_r_kind) + +! Constants for gps refractivity + parameter(n_a=77.6_r_kind) !K/mb + parameter(n_b=3.73e+5_r_kind) !K^2/mb + +! Parameters below from WGS-84 model software inside GPS receivers. + parameter(semi_major_axis = 6378.1370e3_r_kind) ! (m) + parameter(semi_minor_axis = 6356.7523142e3_r_kind) ! (m) + parameter(grav_polar = 9.8321849378_r_kind) ! (m/s2) + parameter(grav_equator = 9.7803253359_r_kind) ! (m/s2) + parameter(earth_omega = 7.292115e-5_r_kind) ! (rad/s) + parameter(grav_constant = 3.986004418e14_r_kind) ! (m3/s2) + +! Derived geophysical constants + parameter(flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis)!() + parameter(somigliana = & + (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one)!() + parameter(grav_ratio = (earth_omega*earth_omega * & + semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant) !() + +! Derived thermodynamic constants + parameter ( dldti = cvap-csol ) + parameter ( hsub = hvap+hfus ) + parameter ( psatk = psat*0.001_r_kind ) + parameter ( tmix = ttp-20._r_kind ) + parameter ( elocp = hvap/cp ) + parameter ( rcp = one/cp ) + +! Constants used in GFS moist physics + parameter ( h300 = 300._r_kind ) + parameter ( half = 0.5_r_kind ) + parameter ( cclimit = 0.001_r_kind ) + parameter ( climit = 1.e-20_r_kind) + parameter ( epsq = 2.e-12_r_kind ) + parameter ( h1000 = 1000.0_r_kind) + parameter ( rhcbot=0.85_r_kind ) + parameter ( rhctop=0.85_r_kind ) + parameter ( dx_max=-8.8818363_r_kind ) + parameter ( dx_min=-5.2574954_r_kind ) + parameter ( dx_inv=one/(dx_max-dx_min) ) + parameter ( c0=0.002_r_kind ) + parameter ( delta=0.6077338_r_kind ) + parameter ( pcpeff0=1.591_r_kind ) + parameter ( pcpeff1=-0.639_r_kind ) + parameter ( pcpeff2=0.0953_r_kind ) + parameter ( pcpeff3=-0.00496_r_kind ) + parameter ( cmr = one/0.0003_r_kind ) + parameter ( cws = 0.025_r_kind ) + parameter ( ke2 = 0.00002_r_kind ) + parameter ( row = 1000._r_kind ) + parameter ( rrow = one/row ) + +! Constant used to process ozone + parameter ( constoz = 604229.0_r_kind) + +! Constants used in cloud liquid water correction for AMSU-A +! brightness temperatures + parameter ( amsua_clw_d1 = 0.754_r_kind ) + parameter ( amsua_clw_d2 = -2.265_r_kind ) + +! Constants used for variational qc + parameter ( wgtlim = 0.25_r_kind) ! Cutoff weight for concluding that obs has been + ! rejected by nonlinear qc. This limit is arbitrary + ! and DOES NOT affect nonlinear qc. It only affects + ! the printout which "counts" the number of obs that + ! "fail" nonlinear qc. Observations counted as failing + ! nonlinear qc are still assimilated. Their weight + ! relative to other observations is reduced. Changing + ! wgtlim does not alter the analysis, only + ! the nonlinear qc data "count" + +! Constants describing the Extended Best-Track Reanalysis [Demuth et +! al., 2008] tropical cyclone (TC) distance for regions relative to TC +! track position; units are in kilometers + + parameter (rmw_mean_distance = 64.5479412) + parameter (roic_mean_distance = 338.319656) + +contains + subroutine init_constants_derived +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants_derived set derived constants +! prgmmr: treadon org: np23 date: 2004-12-02 +! +! abstract: This routine sets derived constants +! +! program history log: +! 2004-12-02 treadon +! 2005-03-03 treadon - add implicit none +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + +! Trigonometric constants + pi = acos(-one) + deg2rad = pi/180.0_r_kind + rad2deg = one/deg2rad + cg_term = (sqrt(two*pi))/two ! constant for variational qc + tiny_r_kind = tiny(zero) + huge_r_kind = huge(zero) + tiny_single = tiny(zero_single) + huge_single = huge(zero_single) + huge_i_kind = huge(izero) + +! Geophysical parameters used in conversion of geopotential to +! geometric height + eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) + eccentricity = eccentricity_linear / semi_major_axis + constants_initialized = .true. + + return + end subroutine init_constants_derived + + subroutine init_constants(regional) +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants set regional or global constants +! prgmmr: treadon org: np23 date: 2004-03-02 +! +! abstract: This routine sets constants specific to regional or global +! applications of the gsi +! +! program history log: +! 2004-03-02 treadon +! 2004-06-16 treadon, documentation +! 2004-10-28 treadon - use intrinsic TINY function to set value +! for smallest machine representable positive +! number +! 2004-12-03 treadon - move derived constants to init_constants_derived +! 2005-03-03 treadon - add implicit none +! +! input argument list: +! regional - if .true., set regional gsi constants; +! otherwise (.false.), use global constants +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + logical regional + real(r_kind) reradius,g,r_d,r_v,cliq_wrf + + gamma = 0.0065 + +! Define regional constants here + if (regional) then + +! Name given to WRF constants + reradius = one/6370.e03_r_kind + g = 9.81_r_kind + r_d = 287.04_r_kind + r_v = 461.6_r_kind + cliq_wrf = 4190.0_r_kind + cp_mass = 1004.67_r_kind + +! Transfer WRF constants into unified GSI constants + rearth = one/reradius + grav = g + rd = r_d + rv = r_v + cv = cp-r_d + cliq = cliq_wrf + rd_over_cp_mass = rd / cp_mass + +! Define global constants here + else + rearth = 6.3712e+6_r_kind + grav = 9.80665e+0_r_kind + rd = 2.8705e+2_r_kind + rv = 4.6150e+2_r_kind + cv = 7.1760e+2_r_kind + cliq = 4.1855e+3_r_kind + cp_mass= zero + rd_over_cp_mass = zero + endif + + +! Now define derived constants which depend on constants +! which differ between global and regional applications. + +! Constants related to ozone assimilation + ozcon = grav*21.4e-9_r_kind + rozcon= one/ozcon + +! Constant used in vertical integral for precipitable water + tpwcon = 100.0_r_kind/grav + +! Derived atmospheric constants + fv = rv/rd-one ! used in virtual temperature equation + dldt = cvap-cliq + xa = -(dldt/rv) + xai = -(dldti/rv) + xb = xa+hvap/(rv*ttp) + xbi = xai+hsub/(rv*ttp) + eps = rd/rv + epsm1 = rd/rv-one + omeps = one-eps + factor1 = (cvap-cliq)/rv + factor2 = hvap/rv-factor1*t0c + cpr = cp*rd + el2orc = hvap*hvap/(rv*cp) + rd_over_g = rd/grav + rd_over_cp = rd/cp + g_over_rd = grav/rd + + return + end subroutine init_constants + +end module constants diff --git a/util/EnKF/gfs/src/calc_increment_serial.fd/fv3_interface.f90 b/util/EnKF/gfs/src/calc_increment_serial.fd/fv3_interface.f90 new file mode 100644 index 000000000..337d80357 --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_serial.fd/fv3_interface.f90 @@ -0,0 +1,907 @@ +! Copyright (C) 2015 Henry R. Winterbottom + +! Email: Henry.Winterbottom@noaa.gov + +! Snail-mail: + +! Henry R. Winterbottom +! NOAA/OAR/PSD R/PSD1 +! 325 Broadway +! Boulder, CO 80303-3328 + +! This file is part of global-model-py. + +! global-model-py is free software: you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation, either version 3 of +! the License, or (at your option) any later version. + +! global-model-py is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU General Public License for more details. + +! You should have received a copy of the GNU General Public License +! along with global-model-py. If not, see +! . + +module fv3_interface + + !======================================================================= + + ! Define associated modules and subroutines + + !----------------------------------------------------------------------- + + use constants + use kinds + + !----------------------------------------------------------------------- + + use gfs_nems_interface + use namelist_def + use netcdf + use variable_interface + + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + + ! Define all data and structure types for routine; these variables + ! are variables required by the subroutines within this module + + type analysis_grid + character(len=500) :: filename + real(r_kind), dimension(:,:,:), allocatable :: dpres + real(r_kind), dimension(:,:,:), allocatable :: dlnp + real(r_kind), dimension(:,:,:), allocatable :: ugrd + real(r_kind), dimension(:,:,:), allocatable :: vgrd + real(r_kind), dimension(:,:,:), allocatable :: spfh + real(r_kind), dimension(:,:,:), allocatable :: tmp + real(r_kind), dimension(:,:,:), allocatable :: clwmr + real(r_kind), dimension(:,:,:), allocatable :: icmr + real(r_kind), dimension(:,:,:), allocatable :: o3mr + real(r_kind), dimension(:,:), allocatable :: psfc + real(r_kind), dimension(:), allocatable :: ak + real(r_kind), dimension(:), allocatable :: bk + real(r_kind), dimension(:), allocatable :: ck + end type analysis_grid ! type analysis_grid + + type increment_grid + real(r_kind), dimension(:,:,:), allocatable :: delp_inc + real(r_kind), dimension(:,:,:), allocatable :: delz_inc + real(r_kind), dimension(:,:,:), allocatable :: u_inc + real(r_kind), dimension(:,:,:), allocatable :: v_inc + real(r_kind), dimension(:,:,:), allocatable :: sphum_inc + real(r_kind), dimension(:,:,:), allocatable :: temp_inc + real(r_kind), dimension(:,:,:), allocatable :: clwmr_inc + real(r_kind), dimension(:,:,:), allocatable :: icmr_inc + real(r_kind), dimension(:,:,:), allocatable :: o3mr_inc + real(r_kind), dimension(:), allocatable :: lon + real(r_kind), dimension(:), allocatable :: lat + real(r_kind), dimension(:), allocatable :: lev + real(r_kind), dimension(:), allocatable :: ilev + real(r_kind), dimension(:), allocatable :: pfull + real(r_kind), dimension(:), allocatable :: hyai + real(r_kind), dimension(:), allocatable :: hybi + integer :: nx + integer :: ny + integer :: nz + integer :: nzp1 + end type increment_grid ! type increment_grid + + ! Define global variables + + type(nemsio_meta) :: meta_nemsio + type(analysis_grid) :: an_grid + type(analysis_grid) :: fg_grid + + !----------------------------------------------------------------------- + + ! Define interfaces and attributes for module routines + + private + public :: fv3_calc_increment + + !----------------------------------------------------------------------- + +contains + + !======================================================================= + + ! fv3_calc_increment.f90: + + !----------------------------------------------------------------------- + + subroutine fv3_calc_increment() + + ! Define variables computed within routine + + type(increment_grid) :: grid + + !===================================================================== + + ! Compute local variables + + call fv3_increment_compute(grid) + + ! Define local variables + + call fv3_increment_write(grid) + + ! Deallocate memory for local variables + + call fv3_increment_cleanup(grid) + + !===================================================================== + + end subroutine fv3_calc_increment + + !======================================================================= + + ! fv3_increment_write.f90: + + !----------------------------------------------------------------------- + + subroutine fv3_increment_write(grid) + + ! Define variables passed to routine + + type(increment_grid) :: grid + + ! Define variables computed within routine + + integer, dimension(3) :: dimid_3d + integer, dimension(1) :: dimid_1d + integer :: varid_lon + integer :: varid_lat + integer :: varid_lev + integer :: varid_pfull + integer :: varid_ilev + integer :: varid_hyai + integer :: varid_hybi + integer :: varid_u_inc + integer :: varid_v_inc + integer :: varid_delp_inc + integer :: varid_delz_inc + integer :: varid_t_inc + integer :: varid_sphum_inc + integer :: varid_liq_wat_inc + integer :: varid_ice_wat_inc + integer :: varid_o3mr_inc + integer :: dimid_lon + integer :: dimid_lat + integer :: dimid_lev + integer :: dimid_ilev + integer :: ncfileid + integer :: ncstatus + + !===================================================================== + + ! Define local variables + + if (debug) print *,'writing to ',trim(increment_filename) + ncstatus = nf90_create(trim(increment_filename), & + cmode=ior(NF90_CLOBBER,NF90_64BIT_OFFSET),ncid=ncfileid) + if (ncstatus /= nf90_noerr) then + print *, 'error opening file ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_dim(ncfileid,'lon',grid%nx,dimid_lon) + if (ncstatus /= nf90_noerr) then + print *, 'error creating lon dim ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_dim(ncfileid,'lat',grid%ny,dimid_lat) + if (ncstatus /= nf90_noerr) then + print *, 'error creating lat dim ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_dim(ncfileid,'lev',grid%nz,dimid_lev) + if (ncstatus /= nf90_noerr) then + print *, 'error creating lev dim ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_dim(ncfileid,'ilev',grid%nzp1,dimid_ilev) + if (ncstatus /= nf90_noerr) then + print *, 'error creating ilev dim ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + dimid_1d(1) = dimid_lon + ncstatus = nf90_def_var(ncfileid,'lon',nf90_float,dimid_1d, & + & varid_lon) + if (debug) print *,'dims',grid%nx,grid%ny,grid%nz,grid%nzp1 + if (ncstatus /= nf90_noerr) then + print *, 'error creating lon ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_att(ncfileid,varid_lon,'units','degrees_east') + if (ncstatus /= nf90_noerr) then + print *, 'error creating lon units ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + dimid_1d(1) = dimid_lat + ncstatus = nf90_def_var(ncfileid,'lat',nf90_float,dimid_1d, & + & varid_lat) + if (ncstatus /= nf90_noerr) then + print *, 'error creating lat ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_att(ncfileid,varid_lat,'units','degrees_north') + if (ncstatus /= nf90_noerr) then + print *, 'error creating lat units ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + dimid_1d(1) = dimid_lev + ncstatus = nf90_def_var(ncfileid,'lev',nf90_float,dimid_1d, & + & varid_lev) + if (ncstatus /= nf90_noerr) then + print *, 'error creating lev ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_var(ncfileid,'pfull',nf90_float,dimid_1d, & + & varid_pfull) + if (ncstatus /= nf90_noerr) then + print *, 'error creating pfull ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + dimid_1d(1) = dimid_ilev + ncstatus = nf90_def_var(ncfileid,'ilev',nf90_float,dimid_1d, & + & varid_ilev) + if (ncstatus /= nf90_noerr) then + print *, 'error creating ilev ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_var(ncfileid,'hyai',nf90_float,dimid_1d, & + & varid_hyai) + if (ncstatus /= nf90_noerr) then + print *, 'error creating hyai ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_var(ncfileid,'hybi',nf90_float,dimid_1d, & + & varid_hybi) + if (ncstatus /= nf90_noerr) then + print *, 'error creating hybi ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + dimid_3d(1) = dimid_lon + dimid_3d(2) = dimid_lat + dimid_3d(3) = dimid_lev + ncstatus = nf90_def_var(ncfileid,'u_inc',nf90_float,dimid_3d, & + & varid_u_inc) + if (ncstatus /= nf90_noerr) then + print *, 'error creating u_inc ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_var(ncfileid,'v_inc',nf90_float,dimid_3d, & + & varid_v_inc) + if (ncstatus /= nf90_noerr) then + print *, 'error creating v_inc ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_var(ncfileid,'delp_inc',nf90_float,dimid_3d, & + & varid_delp_inc) + if (ncstatus /= nf90_noerr) then + print *, 'error creating delp_inc ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (write_delz_inc) then + ncstatus = nf90_def_var(ncfileid,'delz_inc',nf90_float,dimid_3d, & + & varid_delz_inc) + if (ncstatus /= nf90_noerr) then + print *, 'error creating delz_inc ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + endif + ncstatus = nf90_def_var(ncfileid,'T_inc',nf90_float,dimid_3d, & + & varid_t_inc) + if (ncstatus /= nf90_noerr) then + print *, 'error creating T_inc ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_def_var(ncfileid,'sphum_inc',nf90_float,dimid_3d, & + & varid_sphum_inc) + if (ncstatus /= nf90_noerr) then + print *, 'error creating sphum_inc ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (imp_physics .gt. 0) then + ncstatus = nf90_def_var(ncfileid,'liq_wat_inc',nf90_float,dimid_3d, & + & varid_liq_wat_inc) + if (ncstatus /= nf90_noerr) then + print *, 'error creating liq_wat_inc ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (imp_physics .ne. 99) then + ncstatus = nf90_def_var(ncfileid,'ice_wat_inc',nf90_float,dimid_3d, & + & varid_ice_wat_inc) + if (ncstatus /= nf90_noerr) then + print *, 'error creating ice_wat_inc ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + endif + endif + ncstatus = nf90_def_var(ncfileid,'o3mr_inc',nf90_float,dimid_3d, & + & varid_o3mr_inc) + if (ncstatus /= nf90_noerr) then + print *, 'error creating o3mr_inc ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_att(ncfileid,nf90_global,'source','GSI') + if (ncstatus /= nf90_noerr) then + print *, 'error creating global attribute source',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_att(ncfileid,nf90_global,'comment','global analysis increment from calc_increment.x') + if (ncstatus /= nf90_noerr) then + print *, 'error creating global attribute comment',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_enddef(ncfileid) + if (ncstatus /= nf90_noerr) then + print *,'enddef error ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_var(ncfileid,varid_lon,grid%lon) + if (ncstatus /= nf90_noerr) then + print *, 'error writing lon ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_var(ncfileid,varid_lat,grid%lat) + if (ncstatus /= nf90_noerr) then + print *, 'error writing lat ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_var(ncfileid,varid_lev,grid%lev) + if (ncstatus /= nf90_noerr) then + print *, 'error writing lev ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_var(ncfileid,varid_pfull,grid%pfull) + if (ncstatus /= nf90_noerr) then + print *, 'error writing pfull ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_var(ncfileid,varid_ilev,grid%ilev) + if (ncstatus /= nf90_noerr) then + print *, 'error writing ilev ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_var(ncfileid,varid_hyai,grid%hyai) + if (ncstatus /= nf90_noerr) then + print *, 'error writing hyai ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_put_var(ncfileid,varid_hybi,grid%hybi) + if (ncstatus /= nf90_noerr) then + print *, 'error writing hybi ',trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (debug) print *,'writing u_inc, min/max =',& + minval(grid%u_inc),maxval(grid%u_inc) + ncstatus = nf90_put_var(ncfileid,varid_u_inc,grid%u_inc) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (debug) print *,'writing v_inc, min/max =',& + minval(grid%v_inc),maxval(grid%v_inc) + ncstatus = nf90_put_var(ncfileid,varid_v_inc,grid%v_inc) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (debug) print *,'writing delp_inc, min/max =',& + minval(grid%delp_inc),maxval(grid%delp_inc) + ncstatus = nf90_put_var(ncfileid,varid_delp_inc,grid%delp_inc) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (write_delz_inc) then + if (debug) print *,'writing delz_inc, min/max =',& + minval(grid%delz_inc),maxval(grid%delz_inc) + ncstatus = nf90_put_var(ncfileid,varid_delz_inc,grid%delz_inc) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop 1 + endif + endif + if (debug) print *,'writing temp_inc, min/max =',& + minval(grid%temp_inc),maxval(grid%temp_inc) + ncstatus = nf90_put_var(ncfileid,varid_t_inc,grid%temp_inc) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (debug) print *,'writing sphum_inc, min/max =',& + minval(grid%sphum_inc),maxval(grid%sphum_inc) + ncstatus = nf90_put_var(ncfileid,varid_sphum_inc,grid%sphum_inc) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (imp_physics .gt. 0) then + if (zero_mpinc) grid%clwmr_inc=0 + if (debug) print *,'writing clwmr_inc, min/max =',& + minval(grid%clwmr_inc),maxval(grid%clwmr_inc) + ncstatus = nf90_put_var(ncfileid,varid_liq_wat_inc,grid%clwmr_inc) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop 1 + endif + if (imp_physics .ne. 99) then + if (zero_mpinc) grid%icmr_inc=0 + if (debug) print *,'writing icmr_inc, min/max =',& + minval(grid%icmr_inc),maxval(grid%icmr_inc) + ncstatus = nf90_put_var(ncfileid,varid_ice_wat_inc,grid%icmr_inc) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop 1 + endif + endif + endif + if (debug) print *,'writing o3mr_inc, min/max =',& + minval(grid%o3mr_inc),maxval(grid%o3mr_inc) + ncstatus = nf90_put_var(ncfileid,varid_o3mr_inc,grid%o3mr_inc) + if (ncstatus /= nf90_noerr) then + print *, trim(nf90_strerror(ncstatus)) + stop 1 + endif + ncstatus = nf90_close(ncfileid) + if (ncstatus /= nf90_noerr) then + print *, 'error closing file:',trim(nf90_strerror(ncstatus)) + stop 1 + endif + + !===================================================================== + + end subroutine fv3_increment_write + + !======================================================================= + + ! fv3_increment_compute.f90: + + !----------------------------------------------------------------------- + + subroutine fv3_increment_compute(incr_grid) + + ! Define variables passed to routine + + type(increment_grid) :: incr_grid + + ! Define variables computed within routine + + type(gfs_grid) :: grid + + ! Define counting variables + + integer :: j, k + real(r_kind), allocatable, dimension(:,:,:) :: fg_dz, an_dz + + !===================================================================== + + ! Define local variables + + call init_constants_derived() + call fv3_increment_initialize(incr_grid) + an_grid%filename = analysis_filename + fg_grid%filename = firstguess_filename + call fv3_increment_define_analysis(an_grid) + call fv3_increment_define_analysis(fg_grid) + + ! Compute local variables + + incr_grid%u_inc = an_grid%ugrd - fg_grid%ugrd + incr_grid%v_inc = an_grid%vgrd - fg_grid%vgrd + incr_grid%delp_inc = an_grid%dpres - fg_grid%dpres + ! compute hydrostatic delz increment + allocate(fg_dz(incr_grid%nx,incr_grid%ny,incr_grid%nz)) + allocate(an_dz(incr_grid%nx,incr_grid%ny,incr_grid%nz)) + !print *,'rgas,rvap,cp',rgas,rvap,cp,rvap/rgas-1. +! hydrostatic equation g*dz = -R_d*T_v*dlnp + fg_dz = -rgas*fg_grid%tmp*(1.+(rvap/rgas-1.)*fg_grid%spfh)*fg_grid%dlnp/9.8066 + an_dz = -rgas*an_grid%tmp*(1.+(rvap/rgas-1.)*an_grid%spfh)*an_grid%dlnp/9.8066 + incr_grid%delz_inc = an_dz - fg_dz + deallocate(fg_dz, an_dz) + + incr_grid%temp_inc = an_grid%tmp - fg_grid%tmp + incr_grid%sphum_inc = an_grid%spfh - fg_grid%spfh + if (imp_physics .gt. 0) then + incr_grid%clwmr_inc = an_grid%clwmr - fg_grid%clwmr + if (imp_physics .ne. 99) incr_grid%icmr_inc = an_grid%icmr - fg_grid%icmr + endif + incr_grid%o3mr_inc = an_grid%o3mr - fg_grid%o3mr + + ! Define local variables + + grid%nlons = meta_nemsio%dimx + grid%nlats = meta_nemsio%dimy + call gfs_grid_initialize(grid, meta_nemsio) + !incr_grid%lon = grid%rlon(:,1)*rad2deg + !incr_grid%lat = grid%rlat(1,:)*rad2deg + incr_grid%lon = grid%rlon(:,1) + ! reverse latitudes (so they are in increasing order, S to N) + if (grid%rlat(1,1) > grid%rlat(1,grid%nlats)) then + do j=1,grid%nlats + incr_grid%lat(j) = grid%rlat(1,grid%nlats-j+1) + enddo + else + incr_grid%lat = grid%rlat(1,:) + endif + + ! Loop through local variable + + do k = 1, incr_grid%nz + + ! Define local variables + + incr_grid%lev(k) = real(k) + incr_grid%pfull(k) = real(k) + + end do ! do k = 1, incr_grid%nz + + ! Loop through local variable + + do k = 1, incr_grid%nzp1 + + ! Define local variables + + incr_grid%ilev(k) = real(k) + incr_grid%hyai(k) = real(k) + incr_grid%hybi(k) = real(k) + + end do ! do k = 1, incr_grid%nzp1 + + ! Deallocate memory for local variables + + call gfs_grid_cleanup(grid) + + !===================================================================== + + end subroutine fv3_increment_compute + + !======================================================================= + + ! fv3_increment_define_analysis.f90: + + !----------------------------------------------------------------------- + + subroutine fv3_increment_define_analysis(grid) + + ! Define variables passed to routine + + type(analysis_grid) :: grid + + ! Define variables computed within routine + + type(varinfo) :: var_info + real(r_kind), dimension(:,:,:), allocatable :: pressi + real(r_kind), dimension(:,:,:), allocatable :: vcoord + real(r_kind), dimension(:), allocatable :: workgrid + logical flip_lats + + ! Define counting variables + + integer :: k + + !===================================================================== + + + ! Define local variables + + call gfs_nems_initialize(meta_nemsio,filename=grid%filename) + ! Allocate memory for local variables + + if(.not. allocated(pressi)) & + & allocate(pressi(meta_nemsio%dimx,meta_nemsio%dimy, & + & meta_nemsio%dimz + 1)) + if(.not. allocated(vcoord)) & + & allocate(vcoord(meta_nemsio%dimz + 1,3,2)) + if(.not. allocated(workgrid)) & + & allocate(workgrid(meta_nemsio%dimx*meta_nemsio%dimy)) + + ! Define local variables + + if (debug) print *,'lats',meta_nemsio%lat(1), meta_nemsio%lat(meta_nemsio%dimx*meta_nemsio%dimy) + if (meta_nemsio%lat(1) > meta_nemsio%lat(meta_nemsio%dimx*meta_nemsio%dimy)) then + flip_lats = .true. + else + flip_lats = .false. + endif + if (debug) print *,'flip_lats',flip_lats + call gfs_nems_vcoord(meta_nemsio,grid%filename,vcoord) + grid%ak = vcoord(:,1,1) + grid%bk = vcoord(:,2,1) + var_info%var_name = 'psfc' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name,var_info%nems_levtyp, & + & 1) + grid%psfc(:,:) = reshape(workgrid,(/meta_nemsio%dimx, & + & meta_nemsio%dimy/)) + + do k = 1, meta_nemsio%dimz + + ! Define local variables + + var_info%var_name = 'ugrd' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + & var_info%nems_levtyp,k) + grid%ugrd(:,:,meta_nemsio%dimz - k + 1) = & + & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) + if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & + & grid%ugrd(:,:,meta_nemsio%dimz - k + 1)) + var_info%var_name = 'vgrd' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + & var_info%nems_levtyp,k) + grid%vgrd(:,:,meta_nemsio%dimz - k + 1) = & + & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) + if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & + & grid%vgrd(:,:,meta_nemsio%dimz - k + 1)) + var_info%var_name = 'spfh' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + & var_info%nems_levtyp,k) + grid%spfh(:,:,meta_nemsio%dimz - k + 1) = & + & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) + if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & + & grid%spfh(:,:,meta_nemsio%dimz - k + 1)) + var_info%var_name = 'tmp' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + & var_info%nems_levtyp,k) + grid%tmp(:,:,meta_nemsio%dimz - k + 1) = & + & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) + if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & + & grid%tmp(:,:,meta_nemsio%dimz - k + 1)) + if (imp_physics .gt. 0) then + var_info%var_name = 'clwmr' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + & var_info%nems_levtyp,k) + grid%clwmr(:,:,meta_nemsio%dimz - k + 1) = & + & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) + if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & + & grid%clwmr(:,:,meta_nemsio%dimz - k + 1)) + if (imp_physics .ne. 99) then + var_info%var_name = 'icmr' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + & var_info%nems_levtyp,k) + grid%icmr(:,:,meta_nemsio%dimz - k + 1) = & + & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) + if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & + & grid%icmr(:,:,meta_nemsio%dimz - k + 1)) + endif + endif + var_info%var_name = 'o3mr' + call variable_lookup(var_info) + call gfs_nems_read(workgrid,var_info%nems_name, & + & var_info%nems_levtyp,k) + grid%o3mr(:,:,meta_nemsio%dimz - k + 1) = & + & reshape(workgrid,(/meta_nemsio%dimx,meta_nemsio%dimy/)) + if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & + & grid%o3mr(:,:,meta_nemsio%dimz - k + 1)) + + end do ! do k = 1, meta_nemsio%dimz + + do k = 1, meta_nemsio%dimz + 1 + pressi(:,:,k) = grid%ak(k) + grid%bk(k)*grid%psfc(:,:) + end do ! do k = 1, meta_nemsio%dimz + 1 + + do k = 1, meta_nemsio%dimz + ! defined as higher pressure minus lower pressure + grid%dpres(:,:,meta_nemsio%dimz - k + 1) = pressi(:,:,k) - & + & pressi(:,:,k+1) + grid%dlnp(:,:,meta_nemsio%dimz - k + 1) = log(pressi(:,:,k))- & + & log(pressi(:,:,k+1)) + if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & + & grid%dpres(:,:,meta_nemsio%dimz - k + 1)) + if (flip_lats) call gfs_nems_flip_xlat_axis(meta_nemsio, & + & grid%dlnp(:,:,meta_nemsio%dimz - k + 1)) + end do ! do k = 1, meta_nemsio%dimz + + ! Deallocate memory for local variables + + if(allocated(pressi)) deallocate(pressi) + if(allocated(vcoord)) deallocate(vcoord) + if(allocated(workgrid)) deallocate(workgrid) + + ! Define local variables + + call gfs_nems_finalize() + + !===================================================================== + + end subroutine fv3_increment_define_analysis + + !======================================================================= + + ! fv3_increment_initialize.f90: + + !----------------------------------------------------------------------- + + subroutine fv3_increment_initialize(grid) + + ! Define variables passed to routine + + type(increment_grid) :: grid + + !===================================================================== + + ! Define local variables + + call gfs_nems_initialize(meta_nemsio,filename=analysis_filename) + grid%nx = meta_nemsio%dimx + grid%ny = meta_nemsio%dimy + grid%nz = meta_nemsio%dimz + grid%nzp1 = grid%nz + 1 + call gfs_nems_finalize() + + ! Allocate memory for local variables + + if(.not. allocated(grid%delp_inc)) & + & allocate(grid%delp_inc(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(grid%delz_inc)) & + & allocate(grid%delz_inc(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(grid%u_inc)) & + & allocate(grid%u_inc(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(grid%v_inc)) & + & allocate(grid%v_inc(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(grid%sphum_inc)) & + & allocate(grid%sphum_inc(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(grid%temp_inc)) & + & allocate(grid%temp_inc(grid%nx,grid%ny,grid%nz)) + if (imp_physics .gt. 0) then + if(.not. allocated(grid%clwmr_inc)) & + & allocate(grid%clwmr_inc(grid%nx,grid%ny,grid%nz)) + if(imp_physics .ne. 99 .and. .not. allocated(grid%icmr_inc)) & + & allocate(grid%icmr_inc(grid%nx,grid%ny,grid%nz)) + endif + if(.not. allocated(grid%o3mr_inc)) & + & allocate(grid%o3mr_inc(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(grid%lon)) & + & allocate(grid%lon(grid%nx)) + if(.not. allocated(grid%lat)) & + & allocate(grid%lat(grid%ny)) + if(.not. allocated(grid%lev)) & + & allocate(grid%lev(grid%nz)) + if(.not. allocated(grid%ilev)) & + & allocate(grid%ilev(grid%nzp1)) + if(.not. allocated(grid%pfull)) & + & allocate(grid%pfull(grid%nz)) + if(.not. allocated(grid%hyai)) & + & allocate(grid%hyai(grid%nzp1)) + if(.not. allocated(grid%hybi)) & + & allocate(grid%hybi(grid%nzp1)) + if(.not. allocated(an_grid%dpres)) & + & allocate(an_grid%dpres(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(an_grid%dlnp)) & + & allocate(an_grid%dlnp(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(an_grid%ugrd)) & + & allocate(an_grid%ugrd(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(an_grid%vgrd)) & + & allocate(an_grid%vgrd(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(an_grid%spfh)) & + & allocate(an_grid%spfh(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(an_grid%tmp)) & + & allocate(an_grid%tmp(grid%nx,grid%ny,grid%nz)) + if (imp_physics .gt. 0) then + if(.not. allocated(an_grid%clwmr)) & + & allocate(an_grid%clwmr(grid%nx,grid%ny,grid%nz)) + if(imp_physics .ne. 99 .and. .not. allocated(an_grid%icmr)) & + & allocate(an_grid%icmr(grid%nx,grid%ny,grid%nz)) + endif + if(.not. allocated(an_grid%o3mr)) & + & allocate(an_grid%o3mr(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(an_grid%psfc)) & + & allocate(an_grid%psfc(grid%nx,grid%ny)) + if(.not. allocated(an_grid%ak)) & + & allocate(an_grid%ak(grid%nz+1)) + if(.not. allocated(an_grid%bk)) & + & allocate(an_grid%bk(grid%nz+1)) + if(.not. allocated(an_grid%ck)) & + & allocate(an_grid%ck(grid%nz+1)) + if(.not. allocated(fg_grid%dpres)) & + & allocate(fg_grid%dpres(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(fg_grid%dlnp)) & + & allocate(fg_grid%dlnp(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(fg_grid%ugrd)) & + & allocate(fg_grid%ugrd(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(fg_grid%vgrd)) & + & allocate(fg_grid%vgrd(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(fg_grid%spfh)) & + & allocate(fg_grid%spfh(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(fg_grid%tmp)) & + & allocate(fg_grid%tmp(grid%nx,grid%ny,grid%nz)) + if (imp_physics .gt. 0) then + if(.not. allocated(fg_grid%clwmr)) & + & allocate(fg_grid%clwmr(grid%nx,grid%ny,grid%nz)) + if(imp_physics .ne. 99 .and. .not. allocated(fg_grid%icmr)) & + & allocate(fg_grid%icmr(grid%nx,grid%ny,grid%nz)) + endif + if(.not. allocated(fg_grid%o3mr)) & + & allocate(fg_grid%o3mr(grid%nx,grid%ny,grid%nz)) + if(.not. allocated(fg_grid%psfc)) & + & allocate(fg_grid%psfc(grid%nx,grid%ny)) + if(.not. allocated(fg_grid%ak)) & + & allocate(fg_grid%ak(grid%nz+1)) + if(.not. allocated(fg_grid%bk)) & + & allocate(fg_grid%bk(grid%nz+1)) + if(.not. allocated(fg_grid%ck)) & + & allocate(fg_grid%ck(grid%nz+1)) + + !===================================================================== + + end subroutine fv3_increment_initialize + + !======================================================================= + + ! fv3_increment_cleanup.f90: + + !----------------------------------------------------------------------- + + subroutine fv3_increment_cleanup(grid) + + ! Define variables passed to routine + + type(increment_grid) :: grid + + !===================================================================== + + ! Deallocate memory for local variables + + if(allocated(grid%delp_inc)) deallocate(grid%delp_inc) + if(allocated(grid%delz_inc)) deallocate(grid%delz_inc) + if(allocated(grid%u_inc)) deallocate(grid%u_inc) + if(allocated(grid%v_inc)) deallocate(grid%v_inc) + if(allocated(grid%sphum_inc)) deallocate(grid%sphum_inc) + if(allocated(grid%temp_inc)) deallocate(grid%temp_inc) + if(allocated(grid%clwmr_inc)) deallocate(grid%clwmr_inc) + if(allocated(grid%icmr_inc)) deallocate(grid%icmr_inc) + if(allocated(grid%o3mr_inc)) deallocate(grid%o3mr_inc) + if(allocated(grid%lon)) deallocate(grid%lon) + if(allocated(grid%lat)) deallocate(grid%lat) + if(allocated(grid%lev)) deallocate(grid%lev) + if(allocated(grid%ilev)) deallocate(grid%ilev) + if(allocated(grid%pfull)) deallocate(grid%pfull) + if(allocated(grid%hyai)) deallocate(grid%hyai) + if(allocated(grid%hybi)) deallocate(grid%hybi) + if(allocated(an_grid%dpres)) deallocate(an_grid%dpres) + if(allocated(an_grid%dlnp)) deallocate(an_grid%dlnp) + if(allocated(an_grid%ugrd)) deallocate(an_grid%ugrd) + if(allocated(an_grid%vgrd)) deallocate(an_grid%vgrd) + if(allocated(an_grid%spfh)) deallocate(an_grid%spfh) + if(allocated(an_grid%tmp)) deallocate(an_grid%tmp) + if(allocated(an_grid%clwmr)) deallocate(an_grid%clwmr) + if(allocated(an_grid%icmr)) deallocate(an_grid%icmr) + if(allocated(an_grid%o3mr)) deallocate(an_grid%o3mr) + if(allocated(an_grid%psfc)) deallocate(an_grid%psfc) + if(allocated(an_grid%ak)) deallocate(an_grid%ak) + if(allocated(an_grid%bk)) deallocate(an_grid%bk) + if(allocated(fg_grid%ck)) deallocate(an_grid%ck) + if(allocated(fg_grid%dpres)) deallocate(fg_grid%dpres) + if(allocated(fg_grid%dlnp)) deallocate(fg_grid%dlnp) + if(allocated(fg_grid%ugrd)) deallocate(fg_grid%ugrd) + if(allocated(fg_grid%vgrd)) deallocate(fg_grid%vgrd) + if(allocated(fg_grid%spfh)) deallocate(fg_grid%spfh) + if(allocated(fg_grid%tmp)) deallocate(fg_grid%tmp) + if(allocated(fg_grid%clwmr)) deallocate(fg_grid%clwmr) + if(allocated(fg_grid%icmr)) deallocate(fg_grid%icmr) + if(allocated(fg_grid%o3mr)) deallocate(fg_grid%o3mr) + if(allocated(fg_grid%psfc)) deallocate(fg_grid%psfc) + if(allocated(fg_grid%ak)) deallocate(fg_grid%ak) + if(allocated(fg_grid%bk)) deallocate(fg_grid%bk) + if(allocated(fg_grid%ck)) deallocate(fg_grid%ck) + + !===================================================================== + + end subroutine fv3_increment_cleanup + + !======================================================================= + +end module fv3_interface diff --git a/util/EnKF/gfs/src/calc_increment_serial.fd/gfs_nems_interface.f90 b/util/EnKF/gfs/src/calc_increment_serial.fd/gfs_nems_interface.f90 new file mode 100644 index 000000000..f3664ad5d --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_serial.fd/gfs_nems_interface.f90 @@ -0,0 +1,506 @@ +! Copyright (C) 2015 Henry R. Winterbottom + +! Email: Henry.Winterbottom@noaa.gov + +! Snail-mail: + +! Henry R. Winterbottom +! NOAA/OAR/PSD R/PSD1 +! 325 Broadway +! Boulder, CO 80303-3328 + +! This file is part of global-model-py. + +! global-model-py is free software: you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation, either version 3 of +! the License, or (at your option) any later version. + +! global-model-py is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU General Public License for more details. + +! You should have received a copy of the GNU General Public License +! along with global-model-py. If not, see +! . + +module gfs_nems_interface + + !======================================================================= + + ! Define associated modules and subroutines + + !----------------------------------------------------------------------- + + use constants + use kinds + + !----------------------------------------------------------------------- + + use namelist_def + use nemsio_module + + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + + ! Define all data and structure types for routine; these variables + ! are variables required by the subroutines within this module + + type gfs_grid + real(r_kind), dimension(:,:), allocatable :: rlon + real(r_kind), dimension(:,:), allocatable :: rlat + real(r_kind) :: rlon_min + real(r_kind) :: rlon_max + real(r_kind) :: rlat_min + real(r_kind) :: rlat_max + real(r_kind) :: dx + real(r_kind) :: dy + integer :: ntrunc + integer :: ncoords + integer :: nlons + integer :: nlats + integer :: nz + end type gfs_grid ! type gfs_grid + + type nemsio_meta + character(nemsio_charkind), dimension(:), allocatable :: recname + character(nemsio_charkind), dimension(:), allocatable :: reclevtyp + character(16), dimension(:), allocatable :: variname + character(16), dimension(:), allocatable :: varr8name + character(16), dimension(:), allocatable :: aryiname + character(16), dimension(:), allocatable :: aryr8name + character(nemsio_charkind8) :: gdatatype + character(nemsio_charkind8) :: modelname + real(nemsio_realkind), dimension(:,:,:), allocatable :: vcoord + real(nemsio_realkind), dimension(:), allocatable :: lon + real(nemsio_realkind), dimension(:), allocatable :: lat + real(nemsio_realkind) :: rlon_min + real(nemsio_realkind) :: rlon_max + real(nemsio_realkind) :: rlat_min + real(nemsio_realkind) :: rlat_max + integer(nemsio_intkind), dimension(:,:), allocatable :: aryival + integer(nemsio_intkind), dimension(:), allocatable :: reclev + integer(nemsio_intkind), dimension(:), allocatable :: varival + integer(nemsio_intkind), dimension(:), allocatable :: aryilen + integer(nemsio_intkind), dimension(:), allocatable :: aryr8len + integer(nemsio_intkind) :: idate(7) + integer(nemsio_intkind) :: version + integer(nemsio_intkind) :: nreo_vc + integer(nemsio_intkind) :: nrec + integer(nemsio_intkind) :: nmeta + integer(nemsio_intkind) :: nmetavari + integer(nemsio_intkind) :: nmetaaryi + integer(nemsio_intkind) :: nfhour + integer(nemsio_intkind) :: nfminute + integer(nemsio_intkind) :: nfsecondn + integer(nemsio_intkind) :: nfsecondd + integer(nemsio_intkind) :: dimx + integer(nemsio_intkind) :: dimy + integer(nemsio_intkind) :: dimz + integer(nemsio_intkind) :: nframe + integer(nemsio_intkind) :: nsoil + integer(nemsio_intkind) :: ntrac + integer(nemsio_intkind) :: jcap + integer(nemsio_intkind) :: ncldt + integer(nemsio_intkind) :: idvc + integer(nemsio_intkind) :: idsl + integer(nemsio_intkind) :: idvm + integer(nemsio_intkind) :: idrt + integer(nemsio_intkind) :: fhour + end type nemsio_meta ! type nemsio_meta + + !----------------------------------------------------------------------- + + ! Define global variables + + type(nemsio_gfile) :: gfile + integer :: nemsio_iret + + !----------------------------------------------------------------------- + + ! Define interfaces and attributes for module routines + + private + public :: gfs_grid_initialize + public :: gfs_grid_cleanup + public :: gfs_grid + public :: gfs_nems_initialize + public :: gfs_nems_finalize + public :: gfs_nems_read + public :: gfs_nems_write + public :: gfs_nems_vcoord + public :: gfs_nems_flip_xlat_axis + public :: nemsio_meta + + !----------------------------------------------------------------------- + +contains + + !======================================================================= + + ! gfs_nems_initialize.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_initialize(meta_nemsio,filename) + + ! Define variables passed to routine + + type(nemsio_meta) :: meta_nemsio + character(len=500), optional, intent(inout) :: filename + + !===================================================================== + + ! Define local variables + + call nemsio_init(iret=nemsio_iret) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_iinit, iret=', nemsio_iret + stop 2 + endif + + ! Check local variable and proceed accordingly + + + ! Define local variables + + call nemsio_open(gfile,trim(adjustl(filename)),'read', & + & iret=nemsio_iret) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_open, iret=', nemsio_iret + stop 3 + endif + + call nemsio_getfilehead(gfile,iret=nemsio_iret, & + & dimx=meta_nemsio%dimx, & + & nrec=meta_nemsio%nrec, & + & dimy=meta_nemsio%dimy) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_getfilehead, iret=', nemsio_iret + stop 3 + endif + + if (.not. allocated(meta_nemsio%lon)) & + allocate(meta_nemsio%lon(meta_nemsio%dimx*meta_nemsio%dimy)) + if (.not. allocated(meta_nemsio%lat)) & + allocate(meta_nemsio%lat(meta_nemsio%dimx*meta_nemsio%dimy)) + call nemsio_getfilehead(gfile,iret=nemsio_iret, & + & dimz=meta_nemsio%dimz, & + & lat=meta_nemsio%lat, & + & lon=meta_nemsio%lon, & + & idate=meta_nemsio%idate, & + & nframe=meta_nemsio%nframe, & + & idrt=meta_nemsio%idrt, & + & ncldt=meta_nemsio%ncldt, & + & idvc=meta_nemsio%idvc, & + & nfhour=meta_nemsio%fhour, & + & nfminute=meta_nemsio%nfminute, & + & nfsecondn=meta_nemsio%nfsecondn, & + & nfsecondd=meta_nemsio%nfsecondd) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_getfilehead, iret=', nemsio_iret + stop 3 + endif + + ! Define format statements + +500 format(a,'nemsio_fhr',i3.3) + + !===================================================================== + + end subroutine gfs_nems_initialize + + !======================================================================= + + ! gfs_nems_finalize.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_finalize() + + !===================================================================== + + ! Define local variables + + call nemsio_close(gfile,iret=nemsio_iret) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_close, iret=', nemsio_iret + stop 4 + endif + + + !===================================================================== + + end subroutine gfs_nems_finalize + + !======================================================================= + + ! gfs_nems_vcoord.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_vcoord(meta_nemsio,filename,vcoord) + + ! Define variables passed to routine + + type(nemsio_gfile) :: lgfile + type(nemsio_meta) :: meta_nemsio + character(len=500) :: filename + real(r_kind), dimension(meta_nemsio%dimz+1,3,2) :: vcoord + + !===================================================================== + + ! Define local variables + + call nemsio_open(lgfile,trim(adjustl(filename)),'read', & + & iret=nemsio_iret) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_open, iret=', nemsio_iret + stop 3 + endif + call nemsio_getfilehead(lgfile,iret=nemsio_iret,vcoord=vcoord) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_getfilehead, iret=', nemsio_iret + stop 3 + endif + call nemsio_close(lgfile,iret=nemsio_iret) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_close, iret=', nemsio_iret + stop 4 + endif + + !===================================================================== + + end subroutine gfs_nems_vcoord + + !======================================================================= + + ! gfs_nems_flip_xlat_axis.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_flip_xlat_axis(meta_nemsio,grid) + ! flip latitudes from N to S to S to N + + ! Define variables passed to routine + + type(nemsio_meta) :: meta_nemsio + real(nemsio_realkind), dimension(meta_nemsio%dimx,meta_nemsio%dimy) :: grid + + ! Define variables computed within routine + + real(nemsio_realkind), dimension(meta_nemsio%dimx,meta_nemsio%dimy) :: workgrid + + ! Define counting variables + + integer :: i, j + + !===================================================================== + + ! Define local variables + + workgrid = grid + + ! Loop through local variable + + do j = 1, meta_nemsio%dimy + + ! Loop through local variable + + do i = 1, meta_nemsio%dimx + + ! Define local variables + + grid(i,meta_nemsio%dimy - j + 1) = workgrid(i,j) + + end do ! do i = 1, meta_nemsio%dimx + + end do ! do j = 1, meta_nemsio%dimy + + !===================================================================== + + end subroutine gfs_nems_flip_xlat_axis + + !======================================================================= + + ! gfs_nems_read.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_read(nems_data,nems_varname,nems_levtyp,nems_lev) + + ! Define variables passed to routine + + character(nemsio_charkind) :: nems_varname + character(nemsio_charkind) :: nems_levtyp + real(nemsio_realkind) :: nems_data(:) + integer(nemsio_intkind) :: nems_lev + + !===================================================================== + + ! Define local variables + + call nemsio_readrecv(gfile,trim(adjustl(nems_varname)),levtyp= & + & trim(adjustl(nems_levtyp)),lev=nems_lev,data=nems_data, & + & iret=nemsio_iret) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_readrecv var ', trim(adjustl(nems_varname)), & + ', iret=', nemsio_iret + stop 5 + endif + + + ! Check local variable and proceed accordingly + + if(debug) write(6,500) trim(adjustl(nems_varname)), nemsio_iret, & + & nems_lev, minval(nems_data), maxval(nems_data) + + !===================================================================== + + ! Define format statements + +500 format('GFS_NEMS_READ: NEMS I/O name = ', a, '; readrecv return ', & + & 'code = ', i5,'; level = ', i3, '; (min,max) = (', f13.5,f13.5, & + & ').') + + !===================================================================== + + end subroutine gfs_nems_read + + !======================================================================= + + ! gfs_nems_write.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_nems_write(nems_data,nems_varname,nems_levtyp,nems_lev) + + ! Define variables passed to routine + + character(nemsio_charkind) :: nems_varname + character(nemsio_charkind) :: nems_levtyp + real(nemsio_realkind) :: nems_data(:) + integer(nemsio_intkind) :: nems_lev + + !===================================================================== + + ! Define local variables + + call nemsio_writerecv(gfile,trim(adjustl(nems_varname)),levtyp= & + & trim(adjustl(nems_levtyp)),lev=nems_lev,data=nems_data, & + & iret=nemsio_iret) + if (nemsio_iret /= 0) then + print *, 'problem with nemsio_writerecv var ', trim(adjustl(nems_varname)), & + ', iret=', nemsio_iret + stop 6 + endif + + + ! Check local variable and proceed accordingly + + if(debug) write(6,500) trim(adjustl(nems_varname)), nemsio_iret, & + & nems_lev, minval(nems_data), maxval(nems_data) + + !===================================================================== + + ! Define format statements + +500 format('GFS_NEMS_WRITE: NEMS I/O name = ', a, '; writerecv return ', & + & 'code = ', i5,'; level = ', i3, '; (min,max) = (', f13.5,f13.5, & + & ').') + + !===================================================================== + + end subroutine gfs_nems_write + + !======================================================================= + + ! gfs_grid_initialize.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_grid_initialize(grid,meta_nemsio) + + ! Define variables passed to routine + + type(gfs_grid) :: grid + type(nemsio_meta) :: meta_nemsio + + ! Define variables computed within routine + + real(r_kind), dimension(:), allocatable :: slat + real(r_kind), dimension(:), allocatable :: wlat + real(r_kind), dimension(:), allocatable :: workgrid + + ! Define counting variables + + integer :: i, j, n + + !===================================================================== + + ! Define local variables + + call init_constants_derived() + + ! Allocate memory for local variables + + if(.not. allocated(grid%rlon)) & + & allocate(grid%rlon(grid%nlons,grid%nlats)) + if(.not. allocated(grid%rlat)) & + & allocate(grid%rlat(grid%nlons,grid%nlats)) + if(.not. allocated(workgrid)) & + & allocate(workgrid(grid%nlats)) + + ! Compute local variables + + grid%ncoords = grid%nlons*grid%nlats + + n = 0 + do j=1,grid%nlats + do i=1,grid%nlons + n = n + 1 + grid%rlon(i,j) = meta_nemsio%lon(n) + grid%rlat(i,j) = meta_nemsio%lat(n) + enddo + enddo + + ! Deallocate memory for local variables + + if(allocated(slat)) deallocate(slat) + if(allocated(wlat)) deallocate(wlat) + if(allocated(workgrid)) deallocate(workgrid) + + !===================================================================== + + end subroutine gfs_grid_initialize + + !======================================================================= + + ! gfs_grid_cleanup.f90: + + !----------------------------------------------------------------------- + + subroutine gfs_grid_cleanup(grid) + + ! Define variables passed to routine + + type(gfs_grid) :: grid + + !===================================================================== + + ! Deallocate memory for local variables + + if(allocated(grid%rlon)) deallocate(grid%rlon) + if(allocated(grid%rlat)) deallocate(grid%rlat) + + !===================================================================== + + end subroutine gfs_grid_cleanup + + !======================================================================= + +end module gfs_nems_interface diff --git a/util/EnKF/gfs/src/calc_increment_serial.fd/kinds.f90 b/util/EnKF/gfs/src/calc_increment_serial.fd/kinds.f90 new file mode 100644 index 000000000..b3378bfcc --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_serial.fd/kinds.f90 @@ -0,0 +1,107 @@ +! this module was extracted from the GSI version operational +! at NCEP in Dec. 2007. +module kinds +!$$$ module documentation block +! . . . . +! module: kinds +! prgmmr: treadon org: np23 date: 2004-08-15 +! +! abstract: Module to hold specification kinds for variable declaration. +! This module is based on (copied from) Paul vanDelst's +! type_kinds module found in the community radiative transfer +! model +! +! module history log: +! 2004-08-15 treadon +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! The numerical data types defined in this module are: +! i_byte - specification kind for byte (1-byte) integer variable +! i_short - specification kind for short (2-byte) integer variable +! i_long - specification kind for long (4-byte) integer variable +! i_llong - specification kind for double long (8-byte) integer variable +! r_single - specification kind for single precision (4-byte) real variable +! r_double - specification kind for double precision (8-byte) real variable +! r_quad - specification kind for quad precision (16-byte) real variable +! +! i_kind - generic specification kind for default integer +! r_kind - generic specification kind for default floating point +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + implicit none + private + +! Integer type definitions below + +! Integer types + integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer + integer, parameter, public :: i_short = selected_int_kind(4) ! short integer + integer, parameter, public :: i_long = selected_int_kind(8) ! long integer + integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer + integer, parameter, public :: i_llong = max( llong_t, i_long ) + +! Expected 8-bit byte sizes of the integer kinds + integer, parameter, public :: num_bytes_for_i_byte = 1 + integer, parameter, public :: num_bytes_for_i_short = 2 + integer, parameter, public :: num_bytes_for_i_long = 4 + integer, parameter, public :: num_bytes_for_i_llong = 8 + +! Define arrays for default definition + integer, parameter, private :: num_i_kinds = 4 + integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & + i_byte, i_short, i_long, i_llong /) + integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & + num_bytes_for_i_byte, num_bytes_for_i_short, & + num_bytes_for_i_long, num_bytes_for_i_llong /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** + integer, parameter, private :: default_integer = 3 ! 1=byte, + ! 2=short, + ! 3=long, + ! 4=llong + integer, parameter, public :: i_kind = integer_types( default_integer ) + integer, parameter, public :: num_bytes_for_i_kind = & + integer_byte_sizes( default_integer ) + + +! Real definitions below + +! Real types + integer, parameter, public :: r_single = selected_real_kind(6) ! single precision + integer, parameter, public :: r_double = selected_real_kind(15) ! double precision + integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision + integer, parameter, public :: r_quad = max( quad_t, r_double ) + +! Expected 8-bit byte sizes of the real kinds + integer, parameter, public :: num_bytes_for_r_single = 4 + integer, parameter, public :: num_bytes_for_r_double = 8 + integer, parameter, public :: num_bytes_for_r_quad = 16 + +! Define arrays for default definition + integer, parameter, private :: num_r_kinds = 3 + integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & + r_single, r_double, r_quad /) + integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & + num_bytes_for_r_single, num_bytes_for_r_double, & + num_bytes_for_r_quad /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** + integer, parameter, private :: default_real = 1 ! 1=single, + ! 2=double, + ! 3=quad + integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: num_bytes_for_r_kind = & + real_byte_sizes( default_real ) + +end module kinds diff --git a/util/EnKF/gfs/src/calc_increment_serial.fd/namelist_def.f90 b/util/EnKF/gfs/src/calc_increment_serial.fd/namelist_def.f90 new file mode 100644 index 000000000..0179faa7e --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_serial.fd/namelist_def.f90 @@ -0,0 +1,18 @@ +module namelist_def + + use kinds + + implicit none + + ! Define global variables + + character(len=500) :: analysis_filename = 'NOT USED' + character(len=500) :: firstguess_filename = 'NOT USED' + character(len=500) :: increment_filename = 'fv3_increment.nc' + character(len=500) :: datapath = './' + logical :: debug,zero_mpinc = .false. + logical :: write_delz_inc = .false. +! 11 GFDLMP, 99 ZCMP, < 0 no microphysics vars in increment file + integer :: imp_physics = 11 + +end module namelist_def diff --git a/util/EnKF/gfs/src/calc_increment_serial.fd/variable_interface.f90 b/util/EnKF/gfs/src/calc_increment_serial.fd/variable_interface.f90 new file mode 100644 index 000000000..7506253be --- /dev/null +++ b/util/EnKF/gfs/src/calc_increment_serial.fd/variable_interface.f90 @@ -0,0 +1,216 @@ +! Copyright (C) 2015 Henry R. Winterbottom + +! Email: Henry.Winterbottom@noaa.gov + +! Snail-mail: + +! Henry R. Winterbottom +! NOAA/OAR/PSD R/PSD1 +! 325 Broadway +! Boulder, CO 80303-3328 + +! This file is part of global-model-py. + +! global-model-py is free software: you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation, either version 3 of +! the License, or (at your option) any later version. + +! global-model-py is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU General Public License for more details. + +! You should have received a copy of the GNU General Public License +! along with global-model-py. If not, see +! . + +module variable_interface + + !======================================================================= + + ! Define associated modules and subroutines + + !----------------------------------------------------------------------- + + use constants + use kinds + + !----------------------------------------------------------------------- + + use namelist_def + + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + + ! Define all data and structure types for routine; these variables + ! are variables required by the subroutines within this module + + type varinfo + character(len=20) :: var_name + character(len=20) :: nems_name + character(len=20) :: nems_levtyp + integer :: ndims + end type varinfo + + !----------------------------------------------------------------------- + + ! Define interfaces and attributes for module routines + + private + public :: varinfo + public :: variable_lookup + public :: variable_clip + + !----------------------------------------------------------------------- + +contains + + !======================================================================= + + ! variable_clip.f90: + + !----------------------------------------------------------------------- + + subroutine variable_clip(grid) + + ! Define variables passed to routine + + real(r_double) :: grid(:) + + ! Define variables computed within routine + + real(r_double) :: clip + + !===================================================================== + + ! Define local variables + + clip = tiny(grid(1)) + where(grid .le. dble(0.0)) grid = clip + + !===================================================================== + + end subroutine variable_clip + + !======================================================================= + + ! variable_lookup.f90: + + !----------------------------------------------------------------------- + + subroutine variable_lookup(grid) + + ! Define variables passed to routine + + type(varinfo) :: grid + + !===================================================================== + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'psfc') then + + ! Define local variables + + grid%nems_name = 'pres' + grid%nems_levtyp = 'sfc' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'psfc') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'dpres') then + + ! Define local variables + + grid%nems_name = 'dpres' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'dpres') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'ugrd') then + + ! Define local variables + + grid%nems_name = 'ugrd' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'ugrd') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'vgrd') then + + ! Define local variables + + grid%nems_name = 'vgrd' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'vgrd') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'spfh') then + + ! Define local variables + + grid%nems_name = 'spfh' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'spfh') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'tmp') then + + ! Define local variables + + grid%nems_name = 'tmp' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'tmp') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'clwmr') then + + ! Define local variables + + grid%nems_name = 'clwmr' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'clwmr') + + if(trim(adjustl(grid%var_name)) .eq. 'icmr') then + + ! Define local variables + + grid%nems_name = 'icmr' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'icmr') + + ! Check local variable and proceed accordingly + + if(trim(adjustl(grid%var_name)) .eq. 'o3mr') then + + ! Define local variables + + grid%nems_name = 'o3mr' + grid%nems_levtyp = 'mid layer' + + end if ! if(trim(adjustl(grid%var_name)) .eq. 'o3mr') + + !===================================================================== + + end subroutine variable_lookup + + !======================================================================= + +end module variable_interface diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/CMakeLists.txt b/util/EnKF/gfs/src/getnstensmeanp.fd/CMakeLists.txt index 2443a3e52..5bdfe3299 100644 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/getnstensmeanp.fd/CMakeLists.txt @@ -3,9 +3,10 @@ if(BUILD_UTIL) file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) add_executable(getnstensmeanp.x ${LOCAL_SRC} ) + set(Util_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/getnstensmeanp") set_target_properties( getnstensmeanp.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OMPFLAG}" ) - include_directories( ${CORE_INCS} ) - target_link_libraries( getnstensmeanp.x ${CORE_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) - add_dependencies( getnstensmeanp.x enkfdeplib enkflib ) + set_target_properties( getnstensmeanp.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIRECTORY} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${NEMSIOINC} ) + target_link_libraries( getnstensmeanp.x ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ) endif() diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile b/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile deleted file mode 100644 index 9bb5800cd..000000000 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile +++ /dev/null @@ -1,310 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# EnKF utility Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a EnKF utility executable file, type -# > make or > make all -# -# 2) To make a EnKF utility executable file with debug options, type -# > make debug -# -# 3) To copy the EnKF utility load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# 5) To create a library, libgsi.a, in the lib directory, type -# > make library -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - EXE_FILE = getnstensmeanp.x - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../../exec - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = \ - getnstensmeanp.f90 \ - nstio_module.f90 - - SRCSF77 = - - SRCSC = - - SRCS = $(SRCSF90C) $(SRCSF77) $(SRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) - $(LD) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -library : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== CREATING LIBRARY ========================================' - $(MAKE) lib - mv $(LIB) ../lib - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.AIX b/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.AIX deleted file mode 100644 index 4f539e542..000000000 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.AIX +++ /dev/null @@ -1,97 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -COREINC = /nwprod/lib/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = xlf95_r - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -qsmp=noauto - - FFLAGS_F90 = -qfree=f90 -qsuffix=f=f90:cpp=F90 - - FFLAGS_COM_N = -I $(INCsfcio) -qarch=auto -O3 -qfullpath -qdbg -qstrict -q64 $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - - - -#--- Debug mode options - FFLAGS_COM_D = $(FFLAGS_COM_N) \ - -O0 -qdbg -qfullpath \ - -qsigtrap=xl__trcedump \ - -qinitauto=7FF7FFFF \ - -qflttrap=overflow:zero:enable \ - -qcheck \ - -qwarn64 \ - -qflag=i:i - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = ncepcc - -#--- Normal mode options - - CFLAGS_N = -I ./ -O3 - -#--- Debug mode options - - CFLAGS_D = -I ./ -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = -L/nwprod/lib -lsfcio_4 -lw3_4 - - LDFLAGS_N = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) $(PROF) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) -lhmd - - LDFLAGS_D = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.cray b/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.cray deleted file mode 100644 index 03f5e449e..000000000 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.cray +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Redefine variables for Cray on WCOSS -# ------------------------------------ - -# Set library versions -BACIO_VER = v2.0.1 -BUFR_VER = v11.0.1 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.2 -NETCDF_VER = 3.6.3 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.2.0 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/include/crtm_$(CRTM_VER) -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/include/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/$(COMPILER)/libbufr_$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/libcrtm_$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDFPATH = /usrx/local/prod/NetCDF/$(NETCDF_VER)/$(COMPILER)/haswell -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -WRFPATH = /gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-$(COMPILER) -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ -DWRF - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.nco b/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.nco deleted file mode 100644 index ce2e33fa9..000000000 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.nco +++ /dev/null @@ -1,74 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(NEMSIO_INC) -O3 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(NEMSIO_INC) -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.theia b/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.theia deleted file mode 100644 index 8599c8022..000000000 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.theia +++ /dev/null @@ -1,81 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -W3NCO_VER = v2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -convert big_endian -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I ./ -I $(NEMSIO_INC) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(NEMSIO_INC) -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.wcoss b/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.wcoss deleted file mode 100644 index ed1dbb5be..000000000 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.wcoss +++ /dev/null @@ -1,83 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(NEMSIO_INC) -O3 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(NEMSIO_INC) -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.zeus b/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.zeus deleted file mode 100644 index fb9972493..000000000 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.conf.zeus +++ /dev/null @@ -1,73 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/nwprod/incmod -CORELIB = /scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/nwprod/lib -INCsfcio = $(COREINC)/sfcio_4 - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -convert big_endian -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsfcio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lw3lib-2.0_4 -lsfcio_4 -lmpi - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.dependency b/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.dependency deleted file mode 100644 index 352cbdb27..000000000 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/Makefile.dependency +++ /dev/null @@ -1,2 +0,0 @@ -getnstensmeanp.o : getnstensmeanp.f90 nstio_module.o -nstio_module.o : nstio_module.f90 diff --git a/util/EnKF/gfs/src/getnstensmeanp.fd/configure b/util/EnKF/gfs/src/getnstensmeanp.fd/configure deleted file mode 100755 index b169dfc97..000000000 --- a/util/EnKF/gfs/src/getnstensmeanp.fd/configure +++ /dev/null @@ -1,94 +0,0 @@ -#!/bin/sh -# -# Creates configuration Makefile. Before attempting to make anything -# in this directory, enter -# -# ./configure -# -# !REVISION HISTORY -# -# 09oct97 da Silva Initial code. -# 19oct97 da Silva Simplified. -# 22oct97 Jing Guo Converted to libpsas.a environment -# - special configuration for CRAY -# - fool-prove configuration -# - additional information -# 23dec99 da Silva Modified error messages. -# -#..................................................................... - -c=`basename $0 .sh` - -type=${1:-"unknown"} -echo $type - - -# If type=clean, remove soft links and exit -# ----------------------------------------- -if [ "$type" = "clean" ]; then - if [ -r makefile ]; then - echo "$c: remove makefile" 1>&2 - rm makefile - fi - if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf - fi - exit -fi - - -# Node specific configuration -# --------------------------------------- -makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" - -# Machine specific -# ---------------- -if [ ! -r ${makeconf} ]; then - echo "$c: not using site specific ${makeconf} in `pwd`" 1>&2 - machine="`uname -m | awk '{print $1}'`" - machine=`echo $machine | tr "[a-z]" "[A-Z]"` - compiler=$F90 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - makeconf="${makeconf}.${machine}.${compiler}" -fi - -# Site specific configuration -# --------------------------- -if [ ! -r ${makeconf} ]; then -# echo "$c: cannot find site specific ${makeconf}" 1>&2 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - # if all are failed, make a simple one - # --------------------------------------- -# if [ `uname -s` = "AIX" ]; then -# echo "Linking Makefile to makefile" 1>&2 -# ln -sf Makefile makefile -# fi -fi - -# if the OS is UNICOS, it does not follow the convention -# ------------------------------------------------------ -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - mech="`uname -m | awk '{print $1}'`" - if [ "${mech}" = CRAY ]; then - makeconf="Makefile.conf.UNICOS" - fi -fi - -# if all are failed, make a simple one -# --------------------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd` " 1>&2 - makeconf="Makefile.conf.$type" - if [ ! -r ${makeconf} ]; then - touch ${makeconf} - fi -fi - -rm -f Makefile.conf -ln -s ${makeconf} Makefile.conf - -echo "$c: using ${makeconf} in `pwd`" 1>&2 - -#. diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/CMakeLists.txt b/util/EnKF/gfs/src/getsfcensmeanp.fd/CMakeLists.txt index be32e825c..41c01b026 100644 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/getsfcensmeanp.fd/CMakeLists.txt @@ -4,8 +4,7 @@ if(BUILD_UTIL) set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) add_executable( getsfcensmeanp.x ${LOCAL_SRC} ) set_target_properties( getsfcensmeanp.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OMPFLAG}" ) - include_directories( ${CORE_INCS} ) - target_link_libraries( getsfcensmeanp.x ${CORE_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) - add_dependencies( getsfcensmeanp.x enkfdeplib enkflib ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${SFCIOINC} ${NEMSIOINC} ) + target_link_libraries( getsfcensmeanp.x ${SFCIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ) endif() diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile b/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile deleted file mode 100644 index 1bff8d371..000000000 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile +++ /dev/null @@ -1,308 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# EnKF utility Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a EnKF utility executable file, type -# > make or > make all -# -# 2) To make a EnKF utility executable file with debug options, type -# > make debug -# -# 3) To copy the EnKF utility load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# 5) To create a library, libgsi.a, in the lib directory, type -# > make library -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - EXE_FILE = getsfcensmeanp.x - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../../exec - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = getsfcensmeanp.f90 - - SRCSF77 = - - SRCSC = - - SRCS = $(SRCSF90C) $(SRCSF77) $(SRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) - $(LD) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -library : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== CREATING LIBRARY ========================================' - $(MAKE) lib - mv $(LIB) ../lib - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.AIX b/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.AIX deleted file mode 100644 index 4f539e542..000000000 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.AIX +++ /dev/null @@ -1,97 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -COREINC = /nwprod/lib/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = xlf95_r - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -qsmp=noauto - - FFLAGS_F90 = -qfree=f90 -qsuffix=f=f90:cpp=F90 - - FFLAGS_COM_N = -I $(INCsfcio) -qarch=auto -O3 -qfullpath -qdbg -qstrict -q64 $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - - - -#--- Debug mode options - FFLAGS_COM_D = $(FFLAGS_COM_N) \ - -O0 -qdbg -qfullpath \ - -qsigtrap=xl__trcedump \ - -qinitauto=7FF7FFFF \ - -qflttrap=overflow:zero:enable \ - -qcheck \ - -qwarn64 \ - -qflag=i:i - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = ncepcc - -#--- Normal mode options - - CFLAGS_N = -I ./ -O3 - -#--- Debug mode options - - CFLAGS_D = -I ./ -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = -L/nwprod/lib -lsfcio_4 -lw3_4 - - LDFLAGS_N = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) $(PROF) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) -lhmd - - LDFLAGS_D = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.cray b/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.cray deleted file mode 100644 index 03f5e449e..000000000 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.cray +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Redefine variables for Cray on WCOSS -# ------------------------------------ - -# Set library versions -BACIO_VER = v2.0.1 -BUFR_VER = v11.0.1 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.2 -NETCDF_VER = 3.6.3 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.2.0 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/include/crtm_$(CRTM_VER) -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/include/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/$(COMPILER)/libbufr_$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/libcrtm_$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDFPATH = /usrx/local/prod/NetCDF/$(NETCDF_VER)/$(COMPILER)/haswell -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -WRFPATH = /gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-$(COMPILER) -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ -DWRF - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.nco b/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.nco deleted file mode 100644 index ba64d4882..000000000 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.nco +++ /dev/null @@ -1,75 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(SFCIO_INC4) -I $(NEMSIO_INC) -O3 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SFCIO_INC4) -I $(NEMSIO_INC) -O0 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone -traceback \ - -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SFCIO_LIB4) $(W3NCO_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.theia b/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.theia deleted file mode 100644 index ec5121ff4..000000000 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.theia +++ /dev/null @@ -1,84 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -BACIO_VER = 2.0.1 -NEMSIO_VER = 2.2.1 -SFCIO_VER = 1.0.0 -W3NCO_VER = 2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib - -INCsfcio = $(CORELIB)/sfcio/v$(SFCIO_VER)/incmod/sfcio_v$(SFCIO_VER)_4 -INCnemsio= $(CORELIB)/nemsio/v$(NEMSIO_VER)/incmod/nemsio_v$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/v$(BACIO_VER)/libbacio_v$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/v$(NEMSIO_VER)/libnemsio_v$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/v$(SFCIO_VER)/libsfcio_v$(SFCIO_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_4.a - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsfcio) -I $(INCnemsio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) $(SFCIO_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.wcoss b/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.wcoss deleted file mode 100644 index 88c46794f..000000000 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.wcoss +++ /dev/null @@ -1,88 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -SFCIO_VER = v1.0.0 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/incmod/sfcio_$(SFCIO_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/libsfcio_$(SFCIO_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(SFCIO_INC4) -I $(NEMSIO_INC) -O3 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SFCIO_INC4) -I $(NEMSIO_INC) -O0 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone -traceback \ - -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SFCIO_LIB4) $(W3NCO_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.zeus b/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.zeus deleted file mode 100644 index 8a79e5a8c..000000000 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.conf.zeus +++ /dev/null @@ -1,75 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /contrib/nceplibs/nwprod/lib/incmod -CORELIB = /contrib/nceplibs/nwprod/lib -INCsfcio = $(COREINC)/sfcio_4 -INCnemsio= $(COREINC)/nemsio - -# --------------------------- - -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsfcio) -I $(INCnemsio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lnemsio -lbacio_4 -lsfcio_4 -lw3nco_4 - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.dependency b/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.dependency deleted file mode 100644 index a1d3b2cf0..000000000 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/Makefile.dependency +++ /dev/null @@ -1 +0,0 @@ -getsfcensmeanp.o : getsfcensmeanp.f90 diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/configure b/util/EnKF/gfs/src/getsfcensmeanp.fd/configure deleted file mode 100755 index b169dfc97..000000000 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/configure +++ /dev/null @@ -1,94 +0,0 @@ -#!/bin/sh -# -# Creates configuration Makefile. Before attempting to make anything -# in this directory, enter -# -# ./configure -# -# !REVISION HISTORY -# -# 09oct97 da Silva Initial code. -# 19oct97 da Silva Simplified. -# 22oct97 Jing Guo Converted to libpsas.a environment -# - special configuration for CRAY -# - fool-prove configuration -# - additional information -# 23dec99 da Silva Modified error messages. -# -#..................................................................... - -c=`basename $0 .sh` - -type=${1:-"unknown"} -echo $type - - -# If type=clean, remove soft links and exit -# ----------------------------------------- -if [ "$type" = "clean" ]; then - if [ -r makefile ]; then - echo "$c: remove makefile" 1>&2 - rm makefile - fi - if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf - fi - exit -fi - - -# Node specific configuration -# --------------------------------------- -makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" - -# Machine specific -# ---------------- -if [ ! -r ${makeconf} ]; then - echo "$c: not using site specific ${makeconf} in `pwd`" 1>&2 - machine="`uname -m | awk '{print $1}'`" - machine=`echo $machine | tr "[a-z]" "[A-Z]"` - compiler=$F90 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - makeconf="${makeconf}.${machine}.${compiler}" -fi - -# Site specific configuration -# --------------------------- -if [ ! -r ${makeconf} ]; then -# echo "$c: cannot find site specific ${makeconf}" 1>&2 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - # if all are failed, make a simple one - # --------------------------------------- -# if [ `uname -s` = "AIX" ]; then -# echo "Linking Makefile to makefile" 1>&2 -# ln -sf Makefile makefile -# fi -fi - -# if the OS is UNICOS, it does not follow the convention -# ------------------------------------------------------ -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - mech="`uname -m | awk '{print $1}'`" - if [ "${mech}" = CRAY ]; then - makeconf="Makefile.conf.UNICOS" - fi -fi - -# if all are failed, make a simple one -# --------------------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd` " 1>&2 - makeconf="Makefile.conf.$type" - if [ ! -r ${makeconf} ]; then - touch ${makeconf} - fi -fi - -rm -f Makefile.conf -ln -s ${makeconf} Makefile.conf - -echo "$c: using ${makeconf} in `pwd`" 1>&2 - -#. diff --git a/util/EnKF/gfs/src/getsfcensmeanp.fd/getsfcensmeanp.f90 b/util/EnKF/gfs/src/getsfcensmeanp.fd/getsfcensmeanp.f90 index 1f0ad5506..ad4aefa6d 100644 --- a/util/EnKF/gfs/src/getsfcensmeanp.fd/getsfcensmeanp.f90 +++ b/util/EnKF/gfs/src/getsfcensmeanp.fd/getsfcensmeanp.f90 @@ -65,7 +65,7 @@ program getsfcensmeanp call getarg(2,filenameout) call getarg(3,fileprefix) call getarg(4,charnanal) - read(charnanal,'(i2)') nanals + read(charnanal,'(i3)') nanals rnanals=nanals rnanals=1.0_8/rnanals filenameout = trim(adjustl(datapath))//filenameout diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/CMakeLists.txt b/util/EnKF/gfs/src/getsfcnstensupdp.fd/CMakeLists.txt index 475c8ad51..4955df6e7 100644 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/getsfcnstensupdp.fd/CMakeLists.txt @@ -1,13 +1,15 @@ cmake_minimum_required(VERSION 2.6) if(BUILD_UTIL) - file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) - set(CMAKE_Fortran_MODULE_DIRECTORY "${UTIL_INC}/getsfcnstensupdp/") + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.F90 ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + set(Util_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/getsfcnstensupdp") set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) add_executable(getsfcnstensupdp.x ${LOCAL_SRC} ) set_target_properties( getsfcnstensupdp.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OMPFLAG}" ) - include_directories( ${UTIL_INC}/getsfcnstensupdp ${CORE_INCS} ) - target_link_libraries( getsfcnstensupdp.x ${CORE_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) - add_dependencies( getsfcnstensupdp.x enkfdeplib enkflib ) + set_target_properties( getsfcnstensupdp.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIRECTORY} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${UTIL_INC}/getsfcnstensupdp ${SFCIOINC} ${NEMSIOINC} ${MPI_Fortran_INCLUDE_PATH} ) + target_link_libraries( getsfcnstensupdp.x ${SFCIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${SP_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ) + target_link_libraries( getsfcnstensupdp.x ${GSILIB} ${GSISHAREDLIB} ) + add_dependencies( getsfcnstensupdp.x ${GSISHAREDLIB} ) endif() diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile b/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile deleted file mode 100644 index 50bfa9585..000000000 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile +++ /dev/null @@ -1,314 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# EnKF utility Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a EnKF utility executable file, type -# > make or > make all -# -# 2) To make a EnKF utility executable file with debug options, type -# > make debug -# -# 3) To copy the EnKF utility load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# 5) To create a library, libgsi.a, in the lib directory, type -# > make library -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - EXE_FILE = getsfcnstensupdp.x - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../../exec - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = \ - kinds.F90 \ - constants.f90 \ - intrp_msk.f90 \ - nstio_module.f90 \ - grdcrd.f90 \ - getsfcnstensupdp.f90 \ - - - SRCSF77 = - - SRCSC = - - SRCS = $(SRCSF90C) $(SRCSF77) $(SRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) - $(LD) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -library : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== CREATING LIBRARY ========================================' - $(MAKE) lib - mv $(LIB) ../lib - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.AIX b/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.AIX deleted file mode 100644 index c091e49c3..000000000 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.AIX +++ /dev/null @@ -1,97 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -COREINC = /nwprod/lib/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = xlf95_r - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -qsmp=noauto - - FFLAGS_F90 = -qfree=f90 -qsuffix=f=f90:cpp=F90 - - FFLAGS_COM_N = -I $(INCsfcio) -qarch=auto -O3 -qfullpath -qdbg -qstrict -q64 $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - - - -#--- Debug mode options - FFLAGS_COM_D = $(FFLAGS_COM_N) \ - -O0 -qdbg -qfullpath \ - -qsigtrap=xl__trcedump \ - -qinitauto=7FF7FFFF \ - -qflttrap=overflow:zero:enable \ - -qcheck \ - -qwarn64 \ - -qflag=i:i - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = ncepcc - -#--- Normal mode options - - CFLAGS_N = -I ./ -O3 - -#--- Debug mode options - - CFLAGS_D = -I ./ -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - - LIBS_N = -L/nwprod/lib -lsfcio_4 -lw3_4 - - LDFLAGS_N = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) $(PROF) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) -lhmd - - LDFLAGS_D = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.cray b/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.cray deleted file mode 100644 index 03f5e449e..000000000 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.cray +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Redefine variables for Cray on WCOSS -# ------------------------------------ - -# Set library versions -BACIO_VER = v2.0.1 -BUFR_VER = v11.0.1 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.2 -NETCDF_VER = 3.6.3 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.2.0 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/include/crtm_$(CRTM_VER) -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/include/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/$(COMPILER)/libbufr_$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/libcrtm_$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDFPATH = /usrx/local/prod/NetCDF/$(NETCDF_VER)/$(COMPILER)/haswell -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -WRFPATH = /gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-$(COMPILER) -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ -DWRF - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.nco b/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.nco deleted file mode 100644 index e7d2baabe..000000000 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.nco +++ /dev/null @@ -1,74 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = -D_REAL8_ - FFLAGS_COM_N = -I ./ -I $(SFCIO_INC4) -I $(NEMSIO_INC) -O3 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SFCIO_INC4) -I $(NEMSIO_INC) -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SFCIO_LIB4) $(W3NCO_LIB4) $(SP_LIBd) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.theia b/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.theia deleted file mode 100644 index 4336d4e58..000000000 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.theia +++ /dev/null @@ -1,86 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -SFCIO_VER = v1.0.0 -SP_VER = v2.0.2 -W3NCO_VER = v2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/incmod/sfcio_$(SFCIO_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/libsfcio_$(SFCIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/libsp_$(SP_VER)_d.a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -D_REAL8_ -convert big_endian -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(SFCIO_INC4) -I $(NEMSIO_INC) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SFCIO_INC4) -I $(NEMSIO_INC) -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SFCIO_LIB4) $(W3NCO_LIB4) $(SP_LIBd) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.wcoss b/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.wcoss deleted file mode 100644 index e3e386868..000000000 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.wcoss +++ /dev/null @@ -1,89 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -SFCIO_VER = v1.0.0 -SP_VER = v2.0.2 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/incmod/sfcio_$(SFCIO_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/libsfcio_$(SFCIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/libsp_$(SP_VER)_d.a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = -D_REAL8_ - FFLAGS_COM_N = -I ./ -I $(SFCIO_INC4) -I $(NEMSIO_INC) -O3 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SFCIO_INC4) -I $(NEMSIO_INC) -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SFCIO_LIB4) $(W3NCO_LIB4) $(SP_LIBd) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.zeus b/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.zeus deleted file mode 100644 index 0cbe8c040..000000000 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.conf.zeus +++ /dev/null @@ -1,73 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/nwprod/incmod -CORELIB = /scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/nwprod/lib -INCsfcio = $(COREINC)/sfcio_4 - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -D_REAL8_ -convert big_endian -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsfcio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lsp_d -lw3lib-2.0_4 -lsfcio_4 -lmpi - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.dependency b/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.dependency deleted file mode 100644 index b36d286ec..000000000 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/Makefile.dependency +++ /dev/null @@ -1,2 +0,0 @@ -getsfcnstensupdp.o : getsfcnstensupdp.f90 nstio_module.o -nstio_module.o : nstio_module.f90 diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/configure b/util/EnKF/gfs/src/getsfcnstensupdp.fd/configure deleted file mode 100755 index b169dfc97..000000000 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/configure +++ /dev/null @@ -1,94 +0,0 @@ -#!/bin/sh -# -# Creates configuration Makefile. Before attempting to make anything -# in this directory, enter -# -# ./configure -# -# !REVISION HISTORY -# -# 09oct97 da Silva Initial code. -# 19oct97 da Silva Simplified. -# 22oct97 Jing Guo Converted to libpsas.a environment -# - special configuration for CRAY -# - fool-prove configuration -# - additional information -# 23dec99 da Silva Modified error messages. -# -#..................................................................... - -c=`basename $0 .sh` - -type=${1:-"unknown"} -echo $type - - -# If type=clean, remove soft links and exit -# ----------------------------------------- -if [ "$type" = "clean" ]; then - if [ -r makefile ]; then - echo "$c: remove makefile" 1>&2 - rm makefile - fi - if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf - fi - exit -fi - - -# Node specific configuration -# --------------------------------------- -makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" - -# Machine specific -# ---------------- -if [ ! -r ${makeconf} ]; then - echo "$c: not using site specific ${makeconf} in `pwd`" 1>&2 - machine="`uname -m | awk '{print $1}'`" - machine=`echo $machine | tr "[a-z]" "[A-Z]"` - compiler=$F90 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - makeconf="${makeconf}.${machine}.${compiler}" -fi - -# Site specific configuration -# --------------------------- -if [ ! -r ${makeconf} ]; then -# echo "$c: cannot find site specific ${makeconf}" 1>&2 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - # if all are failed, make a simple one - # --------------------------------------- -# if [ `uname -s` = "AIX" ]; then -# echo "Linking Makefile to makefile" 1>&2 -# ln -sf Makefile makefile -# fi -fi - -# if the OS is UNICOS, it does not follow the convention -# ------------------------------------------------------ -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - mech="`uname -m | awk '{print $1}'`" - if [ "${mech}" = CRAY ]; then - makeconf="Makefile.conf.UNICOS" - fi -fi - -# if all are failed, make a simple one -# --------------------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd` " 1>&2 - makeconf="Makefile.conf.$type" - if [ ! -r ${makeconf} ]; then - touch ${makeconf} - fi -fi - -rm -f Makefile.conf -ln -s ${makeconf} Makefile.conf - -echo "$c: using ${makeconf} in `pwd`" 1>&2 - -#. diff --git a/util/EnKF/gfs/src/getsfcnstensupdp.fd/getsfcnstensupdp.f90 b/util/EnKF/gfs/src/getsfcnstensupdp.fd/getsfcnstensupdp.f90 index be6348f90..955e88d85 100644 --- a/util/EnKF/gfs/src/getsfcnstensupdp.fd/getsfcnstensupdp.f90 +++ b/util/EnKF/gfs/src/getsfcnstensupdp.fd/getsfcnstensupdp.f90 @@ -43,14 +43,14 @@ program getsfcnstensupdp lun_sfcgcy=23,lun_nstanl=61,lun_sfcanl=62 integer(i_kind), parameter :: idrt=4 - character(len=80) :: fname_dtfanl,fname_nstges,fname_sfcges,fname_sfcgcy,fname_nstanl,fname_sfcanl + character(len=80) :: fname_dtfanl,fname_nstges,fname_sfcgcy,fname_nstanl,fname_sfcanl character(len=3) :: charnanal character(len=8) :: charbuf character(len=60) :: my_name = 'getsfcnstensupdp' character(len=1) :: null = ' ' integer(i_kind) :: mype,mype1,npe,nproc,iret - integer nrec_sfc, lonb, latb, n, npts + integer nrec_sfc, lonb, latb, n integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd integer,dimension(7):: idate integer(i_kind) :: n_new_water,n_new_seaice diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/CMakeLists.txt b/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/CMakeLists.txt new file mode 100644 index 000000000..0b169f411 --- /dev/null +++ b/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/CMakeLists.txt @@ -0,0 +1,12 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_UTIL) + + set(LOCAL_Fortran_FLAGS "-O3 -fp-model source -convert big_endian -assume byterecl -implicitnone ${OpenMP_Fortran_FLAGS}" ) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${LOCAL_Fortran_FLAGS} ) + add_executable(getsigensmeanp_smooth.x ${LOCAL_SRC} ) + set_target_properties( getsigensmeanp_smooth.x PROPERTIES COMPILE_FLAGS ${LOCAL_Fortran_FLAGS} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${NEMSIOINC} ${SIGIOINC} ) + target_link_libraries( getsigensmeanp_smooth.x ${BACIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${SIGIO_LIBRARY} ${W3NCO_4_LIBRARY} ${SP_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ) +endif() diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/getsigensmeanp_smooth_ncep.f90 b/util/EnKF/gfs/src/getsigensmeanp_smooth.fd/getsigensmeanp_smooth_ncep.f90 similarity index 100% rename from util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/getsigensmeanp_smooth_ncep.f90 rename to util/EnKF/gfs/src/getsigensmeanp_smooth.fd/getsigensmeanp_smooth_ncep.f90 diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/CMakeLists.txt b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/CMakeLists.txt deleted file mode 100644 index f25ccd432..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/CMakeLists.txt +++ /dev/null @@ -1,11 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -if(BUILD_UTIL) - file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) - set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - add_executable(getsigensmeanp_smooth_ncep.x ${LOCAL_SRC} ) - set_target_properties( getsigensmeanp_smooth_ncep.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OMPFLAG}" ) - include_directories( ${CORE_INCS} ) - target_link_libraries( getsigensmeanp_smooth_ncep.x ${CORE_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) - add_dependencies( getsigensmeanp_smooth_ncep.x enkfdeplib enkflib ) -endif() diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile deleted file mode 100644 index 89fac9001..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile +++ /dev/null @@ -1,308 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# EnKF utility Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a EnKF utility executable file, type -# > make or > make all -# -# 2) To make a EnKF utility executable file with debug options, type -# > make debug -# -# 3) To copy the EnKF utility load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# 5) To create a library, libgsi.a, in the lib directory, type -# > make library -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - EXE_FILE = getsigensmeanp_smooth.x - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../../exec - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = getsigensmeanp_smooth_ncep.f90 - - SRCSF77 = - - SRCSC = - - SRCS = $(SRCSF90C) $(SRCSF77) $(SRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) - $(LD) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -library : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== CREATING LIBRARY ========================================' - $(MAKE) lib - mv $(LIB) ../lib - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.AIX b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.AIX deleted file mode 100644 index 5b5d7cd04..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.AIX +++ /dev/null @@ -1,97 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -COREINC = /nwprod/lib/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = xlf95_r - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -qsmp=noauto - - FFLAGS_F90 = -qfree=f90 -qsuffix=f=f90:cpp=F90 - - FFLAGS_COM_N = -I $(INCsigio) -qarch=auto -O3 -qfullpath -qdbg -qstrict -q64 $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - - - -#--- Debug mode options - FFLAGS_COM_D = $(FFLAGS_COM_N) \ - -O0 -qdbg -qfullpath \ - -qsigtrap=xl__trcedump \ - -qinitauto=7FF7FFFF \ - -qflttrap=overflow:zero:enable \ - -qcheck \ - -qwarn64 \ - -qflag=i:i - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = ncepcc - -#--- Normal mode options - - CFLAGS_N = -I ./ -O3 - -#--- Debug mode options - - CFLAGS_D = -I ./ -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = -L/nwprod/lib -lsigio_4 -lw3_4 - - LDFLAGS_N = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) $(PROF) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) -lhmd - - LDFLAGS_D = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.cray b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.cray deleted file mode 100644 index 03f5e449e..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.cray +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Redefine variables for Cray on WCOSS -# ------------------------------------ - -# Set library versions -BACIO_VER = v2.0.1 -BUFR_VER = v11.0.1 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.2 -NETCDF_VER = 3.6.3 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.2.0 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/include/crtm_$(CRTM_VER) -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/include/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/$(COMPILER)/libbufr_$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/libcrtm_$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDFPATH = /usrx/local/prod/NetCDF/$(NETCDF_VER)/$(COMPILER)/haswell -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -WRFPATH = /gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-$(COMPILER) -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ -DWRF - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.nco b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.nco deleted file mode 100644 index a85f9c215..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.nco +++ /dev/null @@ -1,75 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = -openmp - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(SIGIO_INC4) -I $(NEMSIO_INC) -O3 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone $(OMP) - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SIGIO_INC4) -I $(NEMSIO_INC) -O0 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone -traceback \ - -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) $(SP_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) $(LDFLAGS_COM) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.theia b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.theia deleted file mode 100644 index 4a1a660ad..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.theia +++ /dev/null @@ -1,86 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -BACIO_VER = 2.0.1 -NEMSIO_VER = 2.2.1 -SIGIO_VER = 2.0.1 -SP_VER = 2.0.2 -W3NCO_VER = 2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib - -INCsigio = $(CORELIB)/sigio/v$(SIGIO_VER)/incmod/sigio_v$(SIGIO_VER)_4 -INCnemsio= $(CORELIB)/nemsio/v$(NEMSIO_VER)/incmod/nemsio_v$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/v$(BACIO_VER)/libbacio_v$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/v$(NEMSIO_VER)/libnemsio_v$(NEMSIO_VER).a -SIGIO_LIB4=$(CORELIB)/sigio/v$(SIGIO_VER)/libsigio_v$(SIGIO_VER)_4.a -SP_LIB4=$(CORELIB)/sp/v$(SP_VER)/libsp_v$(SP_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_4.a - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsigio) -I $(INCnemsio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) $(SP_LIB4) - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.wcoss b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.wcoss deleted file mode 100644 index 5e016c74b..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.wcoss +++ /dev/null @@ -1,91 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/incmod/sigio_$(SIGIO_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/libsigio_$(SIGIO_VER)_4.a -SP_LIB4=$(CORELIB)/sp/$(SP_VER)/libsp_$(SP_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = -openmp - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(SIGIO_INC4) -I $(NEMSIO_INC) -O3 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone $(OMP) - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SIGIO_INC4) -I $(NEMSIO_INC) -O0 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone -traceback \ - -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) $(SP_LIB4) - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.zeus b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.zeus deleted file mode 100644 index a23490054..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.conf.zeus +++ /dev/null @@ -1,75 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /contrib/nceplibs/nwprod/lib/incmod -CORELIB = /contrib/nceplibs/nwprod/lib -INCsigio = $(COREINC)/sigio_4 -INCnemsio= $(COREINC)/nemsio - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsigio) -I $(INCnemsio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -mkl -lmpi - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lnemsio -lbacio_4 -lsigio_4 -lw3nco_4 -lsp_4 - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.dependency b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.dependency deleted file mode 100644 index ba2eef829..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/Makefile.dependency +++ /dev/null @@ -1 +0,0 @@ -getsigensmean_smooth_ncep.o : getsigensmean_smooth_ncep.f90 diff --git a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/configure b/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/configure deleted file mode 100755 index b169dfc97..000000000 --- a/util/EnKF/gfs/src/getsigensmeanp_smooth_ncep.fd/configure +++ /dev/null @@ -1,94 +0,0 @@ -#!/bin/sh -# -# Creates configuration Makefile. Before attempting to make anything -# in this directory, enter -# -# ./configure -# -# !REVISION HISTORY -# -# 09oct97 da Silva Initial code. -# 19oct97 da Silva Simplified. -# 22oct97 Jing Guo Converted to libpsas.a environment -# - special configuration for CRAY -# - fool-prove configuration -# - additional information -# 23dec99 da Silva Modified error messages. -# -#..................................................................... - -c=`basename $0 .sh` - -type=${1:-"unknown"} -echo $type - - -# If type=clean, remove soft links and exit -# ----------------------------------------- -if [ "$type" = "clean" ]; then - if [ -r makefile ]; then - echo "$c: remove makefile" 1>&2 - rm makefile - fi - if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf - fi - exit -fi - - -# Node specific configuration -# --------------------------------------- -makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" - -# Machine specific -# ---------------- -if [ ! -r ${makeconf} ]; then - echo "$c: not using site specific ${makeconf} in `pwd`" 1>&2 - machine="`uname -m | awk '{print $1}'`" - machine=`echo $machine | tr "[a-z]" "[A-Z]"` - compiler=$F90 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - makeconf="${makeconf}.${machine}.${compiler}" -fi - -# Site specific configuration -# --------------------------- -if [ ! -r ${makeconf} ]; then -# echo "$c: cannot find site specific ${makeconf}" 1>&2 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - # if all are failed, make a simple one - # --------------------------------------- -# if [ `uname -s` = "AIX" ]; then -# echo "Linking Makefile to makefile" 1>&2 -# ln -sf Makefile makefile -# fi -fi - -# if the OS is UNICOS, it does not follow the convention -# ------------------------------------------------------ -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - mech="`uname -m | awk '{print $1}'`" - if [ "${mech}" = CRAY ]; then - makeconf="Makefile.conf.UNICOS" - fi -fi - -# if all are failed, make a simple one -# --------------------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd` " 1>&2 - makeconf="Makefile.conf.$type" - if [ ! -r ${makeconf} ]; then - touch ${makeconf} - fi -fi - -rm -f Makefile.conf -ln -s ${makeconf} Makefile.conf - -echo "$c: using ${makeconf} in `pwd`" 1>&2 - -#. diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/CMakeLists.txt b/util/EnKF/gfs/src/getsigensstatp.fd/CMakeLists.txt index 2d895ab86..bc7e3fbb1 100644 --- a/util/EnKF/gfs/src/getsigensstatp.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/getsigensstatp.fd/CMakeLists.txt @@ -4,8 +4,8 @@ if(BUILD_UTIL) set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) add_executable(getsigensstatp.x ${LOCAL_SRC} ) set_target_properties( getsigensstatp.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OMPFLAG}" ) - include_directories( ${CORE_INCS} ${NETCDF_INCLUDES} ) - target_link_libraries( getsigensstatp.x ${CORE_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) - add_dependencies( getsigensstatp.x enkfdeplib enkflib ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + message(" hey, incl dirs are ${MPI_Fortran_INCLUDE_PATH} ") + include_directories( ${NETCDF_INCLUDES} ${SIGIOINC} ${NEMSIOINC} ${MPI_Fortran_INCLUDE_PATH} ) + target_link_libraries( getsigensstatp.x ${SIGIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${SP_4_LIBRARY} ${W3NCO_4_LIBRARY} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${MPI_Fortran_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ${ZLIB_LIBRARIES} ${CURL_LIBRARIES} ) endif() diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile b/util/EnKF/gfs/src/getsigensstatp.fd/Makefile deleted file mode 100644 index 8ffe5d606..000000000 --- a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile +++ /dev/null @@ -1,307 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# EnKF utility Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a EnKF utility executable file, type -# > make or > make all -# -# 2) To make a EnKF utility executable file with debug options, type -# > make debug -# -# 3) To copy the EnKF utility load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# 5) To create a library, libgsi.a, in the lib directory, type -# > make library -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - EXE_FILE = getsigensstatp.x - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../../exec - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = getsigensstatp.f90 - - SRCSF77 = - - SRCSC = - - SRCS = $(SRCSF90C) $(SRCSF77) $(SRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) - $(LD) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -library : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== CREATING LIBRARY ========================================' - $(MAKE) lib - mv $(LIB) ../lib - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.AIX b/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.AIX deleted file mode 100644 index a72477bd0..000000000 --- a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.AIX +++ /dev/null @@ -1,119 +0,0 @@ -# This config file contains the compile options for compilation -# of the EnKF code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -COREINC = /nwprod/lib/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 -INCnetcdf = /nwprod/lib/sorc/netcdf/netcdf-3.5.0/include - -# Empty out definition of libs use by GMAO EnKF building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpxlf95_r - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -qsmp=noauto - - FFLAGS_F90 = -qfree=f90 -qsuffix=f=f90:cpp=F90 -WF,-DGFS -D_REAL4_ - EXE_FILE = global_enkf - - FFLAGS_COM_N = -I ./ \ - -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -qarch=auto -O3 \ - -qarch=pwr6 -qmaxmem=-1 -qfullpath -qstrict -q64 $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ \ - -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) -qarch=auto -O3 \ - -qarch=pwr6 -qmaxmem=-1 -qfullpath -qstrict -q64 $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = -qfixed $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - - -#--- Debug mode options -# -qflttrap=overflow:zero:enable \ is ok -# -qflttrap=overflow:zero:underflow:enable \ fails -# -qsave=all \ fails, so removing from option list - FFLAGS_COM_D = -I ./ \ - -I $(INCsfcio) -I $(INCsigio) -I $(INCnetcdf) \ - -qarch=auto -qmaxmem=-1 -qfullpath -qdbg -qstrict -q64 \ - -O0 \ - -qsigtrap=xl__trcedump \ - -qflttrap=overflow:zero:enable \ - -qinitauto=7FF7FFFF \ - -qcheck \ - -qwarn64 \ - -qflag=i:u \ - -qlistopt \ - -qsource - - FFLAGS_COM_NOSWAP_D = $(FFLAGS_COM_D) - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = /usr/vac/bin/cc_r - -#--- Normal mode options - - CFLAGS_N = -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -DIBM4 -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -DIBM4 -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = -L/nwprod/lib -lsp_d -lw3_4 -lsigio_4 -lsfcio_4 -lbacio_4 \ - -lmpitrace -lnetcdf_64 - - LDFLAGS_N = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) $(PROF) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) -lhmd - - LDFLAGS_D = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.cray b/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.cray deleted file mode 100644 index 3e39385e3..000000000 --- a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.cray +++ /dev/null @@ -1,98 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Set library versions -# ------------------------------------ - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.2 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIB4=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_4.a - -NETCDF_INC=$(NETCDF)/include -NETCDF_LIB=-L$(NETCDF)/lib -lnetcdf - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - - OMP = -openmp - - FFLAGS_INC = -I $(SIGIO_INC4) -I $(NEMSIO_INC) -I $(NETCDF_INC) - - FFLAGS_F90 = -convert big_endian -assume byterecl \ - -implicitnone -traceback - -#--- Normal mode options - FFLAGS_COM_N = -O3 -fp-model source - - FFLAGS_N = $(FFLAGS_INC) $(FFLAGS_COM_N) $(FFLAGS_F90) $(OMP) - -#--- Debug mode options - FFLAGS_COM_D = -O0 -fp-model strict -g -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn all - - FFLAGS_D = $(FFLAGS_INC) $(FFLAGS_COM_D) $(FFLAGS_F90) $(OMP) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIB4) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) $(NETCDF_LIB) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.nco b/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.nco deleted file mode 100644 index 1c2ec1215..000000000 --- a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.nco +++ /dev/null @@ -1,81 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Define derived variables -# ---------------------------------- - -NETCDFPATH = $(NETCDF) -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - - OMP = -openmp - - FFLAGS_INC = -I $(SIGIO_INC4) -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) - - FFLAGS_F90 = -convert big_endian -assume byterecl \ - -implicitnone -traceback - -#--- Normal mode options - FFLAGS_COM_N = -O3 -fp-model source - - FFLAGS_N = $(FFLAGS_INC) $(FFLAGS_COM_N) $(FFLAGS_F90) $(OMP) - -#--- Debug mode options - FFLAGS_COM_D = -O0 -fp-model strict -g -warn all -debug all -check all - - FFLAGS_D = $(FFLAGS_INC) $(FFLAGS_COM_D) $(FFLAGS_F90) $(OMP) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) $(SP_LIB4) $(NETCDF_LDFLAGS_F) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.theia b/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.theia deleted file mode 100644 index 0cc30abcc..000000000 --- a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.theia +++ /dev/null @@ -1,97 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Set library versions -# ------------------------------------ - -BACIO_VER = 2.0.1 -NEMSIO_VER = 2.2.1 -SIGIO_VER = 2.0.1 -SP_VER = 2.0.2 -W3NCO_VER = 2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib - -SIGIO_INC4 = $(CORELIB)/sigio/v$(SIGIO_VER)/incmod/sigio_v$(SIGIO_VER)_4 -NEMSIO_INC= $(CORELIB)/nemsio/v$(NEMSIO_VER)/incmod/nemsio_v$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/v$(BACIO_VER)/libbacio_v$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/v$(NEMSIO_VER)/libnemsio_v$(NEMSIO_VER).a -SIGIO_LIB4=$(CORELIB)/sigio/v$(SIGIO_VER)/libsigio_v$(SIGIO_VER)_4.a -SP_LIB4=$(CORELIB)/sp/v$(SP_VER)/libsp_v$(SP_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_4.a - -NETCDF_INC=$(NETCDF)/include -NETCDF_LIB=-L$(NETCDF)/lib -lnetcdf - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - - OMP = -openmp - - FFLAGS_INC = -I $(SIGIO_INC4) -I $(NEMSIO_INC) -I $(NETCDF_INC) - - FFLAGS_F90 = -convert big_endian -assume byterecl \ - -implicitnone -traceback - -#--- Normal mode options - FFLAGS_COM_N = -O3 -fp-model source - - FFLAGS_N = $(FFLAGS_INC) $(FFLAGS_COM_N) $(FFLAGS_F90) $(OMP) - -#--- Debug mode options - FFLAGS_COM_D = -O0 -fp-model strict -g -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn all - - FFLAGS_D = $(FFLAGS_INC) $(FFLAGS_COM_D) $(FFLAGS_F90) $(OMP) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) $(SP_LIB4) $(NETCDF_LIB) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.wcoss b/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.wcoss deleted file mode 100644 index 63710145e..000000000 --- a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.conf.wcoss +++ /dev/null @@ -1,96 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Set library versions -# ------------------------------------ - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/incmod/sigio_$(SIGIO_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/libsigio_$(SIGIO_VER)_4.a -SP_LIB4=$(CORELIB)/sp/$(SP_VER)/libsp_$(SP_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a - -NETCDF_INC=$(NETCDF)/include -NETCDF_LIB=-L$(NETCDF)/lib -lnetcdf - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - - OMP = -openmp - - FFLAGS_INC = -I $(SIGIO_INC4) -I $(NEMSIO_INC) -I $(NETCDF_INC) - - FFLAGS_F90 = -convert big_endian -assume byterecl \ - -implicitnone -traceback - -#--- Normal mode options - FFLAGS_COM_N = -O3 -fp-model source - - FFLAGS_N = $(FFLAGS_INC) $(FFLAGS_COM_N) $(FFLAGS_F90) $(OMP) - -#--- Debug mode options - FFLAGS_COM_D = -O0 -fp-model strict -g -debug \ - -check all - - FFLAGS_D = $(FFLAGS_INC) $(FFLAGS_COM_D) $(FFLAGS_F90) $(OMP) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) $(SP_LIB4) $(NETCDF_LIB) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.dependency b/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.dependency deleted file mode 100644 index 922b27f1e..000000000 --- a/util/EnKF/gfs/src/getsigensstatp.fd/Makefile.dependency +++ /dev/null @@ -1,3 +0,0 @@ -kinds.o : kinds.F90 -specmod.o : specmod.f90 -getsigensstatp.o : getsigensstatp.f90 diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/configure b/util/EnKF/gfs/src/getsigensstatp.fd/configure deleted file mode 100755 index b169dfc97..000000000 --- a/util/EnKF/gfs/src/getsigensstatp.fd/configure +++ /dev/null @@ -1,94 +0,0 @@ -#!/bin/sh -# -# Creates configuration Makefile. Before attempting to make anything -# in this directory, enter -# -# ./configure -# -# !REVISION HISTORY -# -# 09oct97 da Silva Initial code. -# 19oct97 da Silva Simplified. -# 22oct97 Jing Guo Converted to libpsas.a environment -# - special configuration for CRAY -# - fool-prove configuration -# - additional information -# 23dec99 da Silva Modified error messages. -# -#..................................................................... - -c=`basename $0 .sh` - -type=${1:-"unknown"} -echo $type - - -# If type=clean, remove soft links and exit -# ----------------------------------------- -if [ "$type" = "clean" ]; then - if [ -r makefile ]; then - echo "$c: remove makefile" 1>&2 - rm makefile - fi - if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf - fi - exit -fi - - -# Node specific configuration -# --------------------------------------- -makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" - -# Machine specific -# ---------------- -if [ ! -r ${makeconf} ]; then - echo "$c: not using site specific ${makeconf} in `pwd`" 1>&2 - machine="`uname -m | awk '{print $1}'`" - machine=`echo $machine | tr "[a-z]" "[A-Z]"` - compiler=$F90 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - makeconf="${makeconf}.${machine}.${compiler}" -fi - -# Site specific configuration -# --------------------------- -if [ ! -r ${makeconf} ]; then -# echo "$c: cannot find site specific ${makeconf}" 1>&2 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - # if all are failed, make a simple one - # --------------------------------------- -# if [ `uname -s` = "AIX" ]; then -# echo "Linking Makefile to makefile" 1>&2 -# ln -sf Makefile makefile -# fi -fi - -# if the OS is UNICOS, it does not follow the convention -# ------------------------------------------------------ -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - mech="`uname -m | awk '{print $1}'`" - if [ "${mech}" = CRAY ]; then - makeconf="Makefile.conf.UNICOS" - fi -fi - -# if all are failed, make a simple one -# --------------------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd` " 1>&2 - makeconf="Makefile.conf.$type" - if [ ! -r ${makeconf} ]; then - touch ${makeconf} - fi -fi - -rm -f Makefile.conf -ln -s ${makeconf} Makefile.conf - -echo "$c: using ${makeconf} in `pwd`" 1>&2 - -#. diff --git a/util/EnKF/gfs/src/getsigensstatp.fd/getsigensstatp.f90 b/util/EnKF/gfs/src/getsigensstatp.fd/getsigensstatp.f90 index 97b48338b..773609bef 100644 --- a/util/EnKF/gfs/src/getsigensstatp.fd/getsigensstatp.f90 +++ b/util/EnKF/gfs/src/getsigensstatp.fd/getsigensstatp.f90 @@ -15,6 +15,7 @@ program getsigensstatp ! ! program history log: ! 2014-08-23 Initial version. +! 2018-07-21 Add hydrometeor (optional) ! ! usage: ! input files: @@ -43,7 +44,8 @@ program getsigensstatp character(len=3) :: charnanal character(len=500) :: filenamein,datapath,filepref integer :: nanals,nlevs,ntrac,ntrunc,latb,lonb,iret - integer :: k,krecu,krecv,krect,krecq,krecoz,kreccwmr + integer :: k,krecu,krecv,krect,krecq,krecoz,kreccwmr,krecicmr + integer :: krecsnmr,krecrwmr,krecgrle integer :: nsize,npts,nrec,nflds real(r_double) :: rnanals,rnanalsm1 character(len=16),allocatable,dimension(:) :: recnam @@ -52,6 +54,8 @@ program getsigensstatp real(r_single),allocatable,dimension(:,:) :: rwork_mem,rwork_avg real(r_single),allocatable,dimension(:) :: glats,gwts logical :: sigio,nemsio + logical :: do_icmr = .false. + logical :: do_hydro = .false. type(sigio_head) :: sigheadi type(sigio_data) :: sigdatai @@ -149,6 +153,8 @@ program getsigensstatp call mpi_abort(mpi_comm_world,99,iret) stop endif + ! do_icmr = variable_exist('icmr') + do_hydro = .false. ! set to false to keep the file size small endif if ( mype == 0 ) then @@ -170,6 +176,7 @@ program getsigensstatp npts = latb*lonb nflds = 1 + 6*nlevs + if (do_hydro) nflds = 1 + 10*nlevs nsize = npts*nflds if ( mype == 0 ) then @@ -216,12 +223,27 @@ program getsigensstatp krecq = 1 + 3*nlevs + k krecoz = 1 + 4*nlevs + k kreccwmr = 1 + 5*nlevs + k + ! if ( do_icmr ) krecicmr = 1 + 6*nlevs + k + if ( do_hydro ) then + krecicmr = 1 + 6*nlevs + k + krecrwmr = 1 + 7*nlevs + k + krecsnmr = 1 + 8*nlevs + k + krecgrle = 1 + 9*nlevs + k + endif call nemsio_readrecv(gfile,'ugrd', 'mid layer',k,rwork_mem(:,krecu), iret=iret) call nemsio_readrecv(gfile,'vgrd', 'mid layer',k,rwork_mem(:,krecv), iret=iret) call nemsio_readrecv(gfile,'tmp', 'mid layer',k,rwork_mem(:,krect), iret=iret) call nemsio_readrecv(gfile,'spfh', 'mid layer',k,rwork_mem(:,krecq), iret=iret) call nemsio_readrecv(gfile,'o3mr', 'mid layer',k,rwork_mem(:,krecoz), iret=iret) call nemsio_readrecv(gfile,'clwmr','mid layer',k,rwork_mem(:,kreccwmr),iret=iret) + ! if ( do_icmr ) call nemsio_readrecv(gfile,'icmr', 'mid layer',k,rwork_mem(:,krecicmr),iret=iret) + if ( do_hydro ) then + call nemsio_readrecv(gfile,'icmr', 'mid layer',k,rwork_mem(:,krecicmr), iret=iret) + call nemsio_readrecv(gfile,'rwmr', 'mid layer',k,rwork_mem(:,krecrwmr), iret=iret) + call nemsio_readrecv(gfile,'snmr', 'mid layer',k,rwork_mem(:,krecsnmr), iret=iret) + call nemsio_readrecv(gfile,'grle', 'mid layer',k,rwork_mem(:,krecgrle), iret=iret) + endif + enddo call nemsio_close(gfile,iret=iret) @@ -324,6 +346,20 @@ subroutine write_to_disk(statstr) call nc_check( nf90_def_var(ncid,'cw',nf90_float,vardim,varid),myname,'def_var cw '//trim(filenameout) ) call nc_check( nf90_put_att(ncid, varid, 'long_name','cloud-water mixing ratio'),myname, 'put_att, long_name cw '//trim(filenameout) ) call nc_check( nf90_put_att(ncid, varid, 'units','kg/kg'),myname, 'put_att, units cw '//trim(filenameout) ) + if (do_hydro) then + call nc_check( nf90_def_var(ncid,'qi',nf90_float,vardim,varid),myname,'def_var qi '//trim(filenameout) ) + call nc_check( nf90_put_att(ncid, varid, 'long_name','cloud-ice mixing ratio'),myname, 'put_att, long_name qi '//trim(filenameout) ) + call nc_check( nf90_put_att(ncid, varid, 'units','kg/kg'),myname, 'put_att, units qi '//trim(filenameout) ) + call nc_check( nf90_def_var(ncid,'qr',nf90_float,vardim,varid),myname,'def_var qr '//trim(filenameout) ) + call nc_check( nf90_put_att(ncid, varid, 'long_name','rain water mixing ratio'),myname, 'put_att, long_name qr '//trim(filenameout) ) + call nc_check( nf90_put_att(ncid, varid, 'units','kg/kg'),myname, 'put_att, units qr '//trim(filenameout) ) + call nc_check( nf90_def_var(ncid,'qs',nf90_float,vardim,varid),myname,'def_var qs '//trim(filenameout) ) + call nc_check( nf90_put_att(ncid, varid, 'long_name','snow water mixing ratio'),myname, 'put_att, long_name qs '//trim(filenameout) ) + call nc_check( nf90_put_att(ncid, varid, 'units','kg/kg'),myname, 'put_att, units qs '//trim(filenameout) ) + call nc_check( nf90_def_var(ncid,'qg',nf90_float,vardim,varid),myname,'def_var qg '//trim(filenameout) ) + call nc_check( nf90_put_att(ncid, varid, 'long_name','graupel water mixing ratio'),myname, 'put_att, long_name qg '//trim(filenameout) ) + call nc_check( nf90_put_att(ncid, varid, 'units','kg/kg'),myname, 'put_att, units qg '//trim(filenameout) ) + endif call nc_check( nf90_enddef(ncid),myname,'enddef, '//trim(filenameout) ) call nc_check( nf90_close(ncid),myname,'close, '//trim(filenameout) ) @@ -369,6 +405,28 @@ subroutine write_to_disk(statstr) var3d = var3d(:,latb:1:-1,:) call nc_check( nf90_inq_varid(ncid,'cw',varid),myname,'inq_varid, cw '// trim(filenameout) ) call nc_check( nf90_put_var(ncid,varid,var3d,(/1,1,1/),(/lonb,latb,nlevs/)),myname, 'put_var, cw '//trim(filenameout) ) + if (do_hydro) then + kbeg = kend + 1 ; kend = kend + nlevs + var3d = reshape(rwork_avg(:,kbeg:kend),(/lonb,latb,nlevs/)) + var3d = var3d(:,latb:1:-1,:) + call nc_check( nf90_inq_varid(ncid,'qi',varid),myname,'inq_varid, qi '// trim(filenameout) ) + call nc_check( nf90_put_var(ncid,varid,var3d,(/1,1,1/),(/lonb,latb,nlevs/)),myname, 'put_var, qi '//trim(filenameout) ) + kbeg = kend + 1 ; kend = kend + nlevs + var3d = reshape(rwork_avg(:,kbeg:kend),(/lonb,latb,nlevs/)) + var3d = var3d(:,latb:1:-1,:) + call nc_check( nf90_inq_varid(ncid,'qr',varid),myname,'inq_varid, qr '// trim(filenameout) ) + call nc_check( nf90_put_var(ncid,varid,var3d,(/1,1,1/),(/lonb,latb,nlevs/)),myname, 'put_var, qr '//trim(filenameout) ) + kbeg = kend + 1 ; kend = kend + nlevs + var3d = reshape(rwork_avg(:,kbeg:kend),(/lonb,latb,nlevs/)) + var3d = var3d(:,latb:1:-1,:) + call nc_check( nf90_inq_varid(ncid,'qs',varid),myname,'inq_varid, qs '// trim(filenameout) ) + call nc_check( nf90_put_var(ncid,varid,var3d,(/1,1,1/),(/lonb,latb,nlevs/)),myname, 'put_var, qs '//trim(filenameout) ) + kbeg = kend + 1 ; kend = kend + nlevs + var3d = reshape(rwork_avg(:,kbeg:kend),(/lonb,latb,nlevs/)) + var3d = var3d(:,latb:1:-1,:) + call nc_check( nf90_inq_varid(ncid,'qg',varid),myname,'inq_varid, qg '// trim(filenameout) ) + call nc_check( nf90_put_var(ncid,varid,var3d,(/1,1,1/),(/lonb,latb,nlevs/)),myname, 'put_var, qg '//trim(filenameout) ) + endif call nc_check( nf90_close(ncid),myname,'close, '//trim(filenameout) ) write(6,'(3a,i5)')'Wrote netcdf4 ',trim(filenameout) @@ -397,4 +455,21 @@ SUBROUTINE nc_check(ierr,subr_name,context) return END SUBROUTINE nc_check +function variable_exist(varname) result(varexist) + + character(len=*) :: varname + logical :: varexist + + integer :: n + + varexist = .false. + do n=1,nrec + if ( trim(recnam(n)) == trim(varname) ) then + varexist = .true. + return + endif + enddo + +end function variable_exist + end program getsigensstatp diff --git a/util/EnKF/gfs/src/gribmean.fd/CMakeLists.txt b/util/EnKF/gfs/src/gribmean.fd/CMakeLists.txt index 11e15cb20..2b3a51f4c 100644 --- a/util/EnKF/gfs/src/gribmean.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/gribmean.fd/CMakeLists.txt @@ -4,8 +4,6 @@ if(BUILD_UTIL) set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) add_executable(gribmean.x ${LOCAL_SRC} ) set_target_properties( gribmean.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OMPFLAG}" ) - include_directories( ${CORE_INCS} ) - target_link_libraries( gribmean.x ${CORE_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) - add_dependencies( gribmean.x enkflib enkfdeplib ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + target_link_libraries( gribmean.x ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ) endif() diff --git a/util/EnKF/gfs/src/gribmean.fd/Makefile b/util/EnKF/gfs/src/gribmean.fd/Makefile deleted file mode 100644 index b54a8de67..000000000 --- a/util/EnKF/gfs/src/gribmean.fd/Makefile +++ /dev/null @@ -1,308 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# EnKF utility Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a EnKF utility executable file, type -# > make or > make all -# -# 2) To make a EnKF utility executable file with debug options, type -# > make debug -# -# 3) To copy the EnKF utility load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# 5) To create a library, libgsi.a, in the lib directory, type -# > make library -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - EXE_FILE = gribmean.x - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../../exec - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = gribmean.f90 - - SRCSF77 = - - SRCSC = - - SRCS = $(SRCSF90C) $(SRCSF77) $(SRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) - $(LD) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -library : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== CREATING LIBRARY ========================================' - $(MAKE) lib - mv $(LIB) ../lib - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - diff --git a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.AIX b/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.AIX deleted file mode 100644 index 52bb88f96..000000000 --- a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.AIX +++ /dev/null @@ -1,95 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -COREINC = /nwprod/lib/incmod - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = xlf95_r - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -qsmp=noauto - - FFLAGS_F90 = -qfree=f90 -qsuffix=f=f90:cpp=F90 - - FFLAGS_COM_N = -qarch=auto -O3 -qfullpath -qdbg -qstrict -q64 $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - - - -#--- Debug mode options - FFLAGS_COM_D = $(FFLAGS_COM_N) \ - -O0 -qdbg -qfullpath \ - -qsigtrap=xl__trcedump \ - -qinitauto=7FF7FFFF \ - -qflttrap=overflow:zero:enable \ - -qcheck \ - -qwarn64 \ - -qflag=i:i - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = ncepcc - -#--- Normal mode options - - CFLAGS_N = -I ./ -O3 - -#--- Debug mode options - - CFLAGS_D = -I ./ -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = -L/nwprod/lib -lw3_4 -lbacio_4 - - LDFLAGS_N = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) $(PROF) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) -lhmd - - LDFLAGS_D = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.cray b/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.cray deleted file mode 100644 index 03f5e449e..000000000 --- a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.cray +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Redefine variables for Cray on WCOSS -# ------------------------------------ - -# Set library versions -BACIO_VER = v2.0.1 -BUFR_VER = v11.0.1 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.2 -NETCDF_VER = 3.6.3 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.2.0 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/include/crtm_$(CRTM_VER) -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/include/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/$(COMPILER)/libbufr_$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/libcrtm_$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDFPATH = /usrx/local/prod/NetCDF/$(NETCDF_VER)/$(COMPILER)/haswell -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -WRFPATH = /gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-$(COMPILER) -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ -DWRF - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.nco b/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.nco deleted file mode 100644 index bb5f69b6a..000000000 --- a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.nco +++ /dev/null @@ -1,73 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - -#--- Normal mode options - PROF= -##OMP = -openmp - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -O3 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(W3NCO_LIB4) $(BACIO_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.theia b/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.theia deleted file mode 100644 index 435d1f90b..000000000 --- a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.theia +++ /dev/null @@ -1,77 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -BACIO_VER = 2.0.1 -W3NCO_VER = 2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib - -BACIO_LIB4=$(CORELIB)/bacio/v$(BACIO_VER)/libbacio_v$(BACIO_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_4.a - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = $(BACIO_LIB4) $(W3NCO_LIB4) - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.wcoss b/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.wcoss deleted file mode 100644 index f49a24fbb..000000000 --- a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.wcoss +++ /dev/null @@ -1,78 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - -W3NCO_VERSION = 2.0.6 - -COREINC = /nwprod/lib/incmod -CORELIB = /nwprod/lib - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - -#--- Normal mode options - PROF= -##OMP = -openmp - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -O3 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -fp-model strict -convert big_endian -assume byterecl \ - -implicitnone -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lw3nco_v$(W3NCO_VERSION)_4 -lbacio_4 - - LDFLAGS_N = -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.zeus b/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.zeus deleted file mode 100644 index d5e022f7d..000000000 --- a/util/EnKF/gfs/src/gribmean.fd/Makefile.conf.zeus +++ /dev/null @@ -1,72 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/nwprod/incmod -CORELIB = /scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/nwprod/lib - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lw3lib-2.0_4 -lbacio_4 - - LDFLAGS_N = - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/gribmean.fd/Makefile.dependency b/util/EnKF/gfs/src/gribmean.fd/Makefile.dependency deleted file mode 100644 index 3fed772f0..000000000 --- a/util/EnKF/gfs/src/gribmean.fd/Makefile.dependency +++ /dev/null @@ -1 +0,0 @@ -gribmean.o : gribmean.f90 diff --git a/util/EnKF/gfs/src/gribmean.fd/configure b/util/EnKF/gfs/src/gribmean.fd/configure deleted file mode 100755 index b169dfc97..000000000 --- a/util/EnKF/gfs/src/gribmean.fd/configure +++ /dev/null @@ -1,94 +0,0 @@ -#!/bin/sh -# -# Creates configuration Makefile. Before attempting to make anything -# in this directory, enter -# -# ./configure -# -# !REVISION HISTORY -# -# 09oct97 da Silva Initial code. -# 19oct97 da Silva Simplified. -# 22oct97 Jing Guo Converted to libpsas.a environment -# - special configuration for CRAY -# - fool-prove configuration -# - additional information -# 23dec99 da Silva Modified error messages. -# -#..................................................................... - -c=`basename $0 .sh` - -type=${1:-"unknown"} -echo $type - - -# If type=clean, remove soft links and exit -# ----------------------------------------- -if [ "$type" = "clean" ]; then - if [ -r makefile ]; then - echo "$c: remove makefile" 1>&2 - rm makefile - fi - if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf - fi - exit -fi - - -# Node specific configuration -# --------------------------------------- -makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" - -# Machine specific -# ---------------- -if [ ! -r ${makeconf} ]; then - echo "$c: not using site specific ${makeconf} in `pwd`" 1>&2 - machine="`uname -m | awk '{print $1}'`" - machine=`echo $machine | tr "[a-z]" "[A-Z]"` - compiler=$F90 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - makeconf="${makeconf}.${machine}.${compiler}" -fi - -# Site specific configuration -# --------------------------- -if [ ! -r ${makeconf} ]; then -# echo "$c: cannot find site specific ${makeconf}" 1>&2 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - # if all are failed, make a simple one - # --------------------------------------- -# if [ `uname -s` = "AIX" ]; then -# echo "Linking Makefile to makefile" 1>&2 -# ln -sf Makefile makefile -# fi -fi - -# if the OS is UNICOS, it does not follow the convention -# ------------------------------------------------------ -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - mech="`uname -m | awk '{print $1}'`" - if [ "${mech}" = CRAY ]; then - makeconf="Makefile.conf.UNICOS" - fi -fi - -# if all are failed, make a simple one -# --------------------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd` " 1>&2 - makeconf="Makefile.conf.$type" - if [ ! -r ${makeconf} ]; then - touch ${makeconf} - fi -fi - -rm -f Makefile.conf -ln -s ${makeconf} Makefile.conf - -echo "$c: using ${makeconf} in `pwd`" 1>&2 - -#. diff --git a/util/EnKF/gfs/src/preproc/CMakeLists.txt b/util/EnKF/gfs/src/preproc/CMakeLists.txt index 2a08d6fd1..6ae2f24f9 100644 --- a/util/EnKF/gfs/src/preproc/CMakeLists.txt +++ b/util/EnKF/gfs/src/preproc/CMakeLists.txt @@ -1,8 +1,11 @@ cmake_minimum_required(VERSION 2.6) if(BUILD_UTIL) file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) - set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS} ) + set(Util_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include/preproc") add_executable(preproc.x ${LOCAL_SRC} ) - include_directories( ${CORE_INCS} ) - add_dependencies( preproc.x enkflib enkfdeplib ) + set_target_properties( preproc.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + set_target_properties( preproc.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIRECTORY} ) + include_directories( ${SIGIOINC} ) + target_link_libraries( preproc.x ${SIGIO_LIBRARY} ) + endif() diff --git a/util/EnKF/gfs/src/recenternemsiop_hybgain.fd/CMakeLists.txt b/util/EnKF/gfs/src/recenternemsiop_hybgain.fd/CMakeLists.txt new file mode 100644 index 000000000..1566b60fb --- /dev/null +++ b/util/EnKF/gfs/src/recenternemsiop_hybgain.fd/CMakeLists.txt @@ -0,0 +1,10 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_UTIL) + file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) + set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + add_executable(recenternemsiop_hybgain.x ${LOCAL_SRC} ) + set_target_properties( recenternemsiop_hybgain.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${SIGIOINC} ${NEMSIOINC} ) + target_link_libraries( recenternemsiop_hybgain.x ${SIGIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ) +endif() diff --git a/util/EnKF/gfs/src/recenternemsiop_hybgain.fd/recenternemsiop_hybgain.f90 b/util/EnKF/gfs/src/recenternemsiop_hybgain.fd/recenternemsiop_hybgain.f90 new file mode 100644 index 000000000..442605933 --- /dev/null +++ b/util/EnKF/gfs/src/recenternemsiop_hybgain.fd/recenternemsiop_hybgain.f90 @@ -0,0 +1,310 @@ +program recenternemsiop_hybgain +!$$$ main program documentation block +! +! program: recenternemsiop_hybgain recenter +! +! prgmmr: whitaker org: esrl/psd date: 2009-02-23 +! +! abstract: Recenter ensemble analysis files about new +! mean, computed from blended 3DVar and EnKF increments. +! +! program history log: +! 2019-02-10 Initial version. +! +! usage: +! input files: +! +! output files: +! +! attributes: +! language: f95 +! +! +!$$$ + + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrec,& + nemsio_writerec,nemsio_readrecv,nemsio_writerecv,nemsio_getrechead + + implicit none + + include "mpif.h" + + character*500 filename_fg,filename_anal1,filename_anal2,filenamein,& + filenameout,filename_anal,filename + character*3 charnanal + character(len=4) charnin + character(16),dimension(:),allocatable:: fieldname_anal1,fieldname_anal2,fieldname_fg + character(16),dimension(:),allocatable:: fieldlevtyp_anal1,fieldlevtyp_anal2,fieldlevtyp_fg + integer,dimension(:),allocatable:: fieldlevel_anal1,fieldlevel_anal2,fieldlevel_fg,order_anal1,order_anal2 + integer mype,mype1,npe,nanals,iret,ialpha,ibeta + integer:: nrec,nlats,nlons,nlevs,npts,n,i + real alpha,beta + real,allocatable,dimension(:,:) :: rwork_anal1,rwork_anal2,rwork_fg,rwork_anal + + type(nemsio_gfile) :: gfilei, gfileo, gfile_anal, gfile_fg, gfile_anal1, gfile_anal2 + +! Initialize mpi + call MPI_Init(iret) + +! mype is process number, npe is total number of processes. + call MPI_Comm_rank(MPI_COMM_WORLD,mype,iret) + call MPI_Comm_size(MPI_COMM_WORLD,npe,iret) + + if (mype==0) call w3tagb('RECENTERSIGP_HYBGAIN',2011,0319,0055,'NP25') + + call getarg(1,filename_fg) ! first guess ensmean background nemsio file + call getarg(2,filename_anal1) ! 3dvar analysis + call getarg(3,filename_anal2) ! enkf mean analysis + call getarg(4,filename_anal) ! blended analysis (to recenter ensemble around) + call getarg(5,filenamein) ! prefix for input ens member files (append _mem###) + call getarg(6,filenameout) ! prefix for output ens member files (append _mem###) +! blending coefficients + call getarg(7,charnin) + read(charnin,'(i4)') ialpha ! wt for anal1 (3dvar) + alpha = ialpha/1000. + call getarg(8,charnin) + read(charnin,'(i4)') ibeta ! wt for anal2 (enkf) + beta = ibeta/1000. +! new_anal = fg + alpha*(anal1-fg) + beta(anal2-fg) +! = (1.-alpha-beta)*fg + alpha*anal1 + beta*anal2 +! how many ensemble members to process + call getarg(9,charnin) + read(charnin,'(i4)') nanals + + if (mype==0) then + write(6,*)'RECENTERSIGP_HYBGAIN: PROCESS ',nanals,' ENSEMBLE MEMBERS' + write(6,*)'ens mean background in ',trim(filename_fg) + write(6,*)'3dvar analysis in ',trim(filename_anal1) + write(6,*)'EnKF mean analysis in ',trim(filename_anal2) + write(6,*)'Blended mean analysis to be written to ',trim(filename_anal) + write(6,*)'Prefix for member input files ',trim(filenamein) + write(6,*)'Prefix for member output files ',trim(filenameout) + write(6,*)'3dvar weight, EnKF weight =',alpha,beta + endif + + mype1 = mype+1 + if (mype1 <= nanals) then + call nemsio_init(iret=iret) + call nemsio_open(gfile_fg,trim(filename_fg),'READ',iret=iret) + if (iret == 0 ) then + if (mype == 0) write(6,*)'Read nemsio ',trim(filename_fg),' iret=',iret + call nemsio_getfilehead(gfile_fg, nrec=nrec, dimx=nlons, dimy=nlats, dimz=nlevs, iret=iret) + if (mype == 0) write(6,*)' nlons=',nlons,' nlats=',nlats,' nlevs=',nlevs,' nrec=',nrec + else + write(6,*) 'error opening ',trim(filename_fg) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + + ! readin in 3dvar, enkf analyses, plus ens mean background, blend + call nemsio_open(gfile_anal1,trim(filename_anal1),'READ',iret=iret) + if (iret /= 0) then + print *,'error opening ',trim(filename_anal1) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + else + call checkheader(gfile_anal1,filename_anal1,nrec,nlons,nlats,nlevs) + endif + call nemsio_open(gfile_anal2,trim(filename_anal2),'READ',iret=iret) + if (iret /= 0) then + print *,'error opening ',trim(filename_anal2) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + else + call checkheader(gfile_anal2,filename_anal2,nrec,nlons,nlats,nlevs) + endif + gfile_anal=gfile_anal2 ! use header for enkf analysis + if (mype == 0) then + call nemsio_open(gfile_anal,trim(filename_anal),'WRITE',iret=iret) + if (iret /= 0) then + print *,'error opening ',trim(filename_anal) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + endif + + npts=nlons*nlats + allocate(rwork_anal1(npts,nrec),rwork_anal2(npts,nrec),rwork_fg(npts,nrec),rwork_anal(npts,nrec)) + + allocate(fieldname_anal1(nrec), fieldlevtyp_anal1(nrec),fieldlevel_anal1(nrec)) + allocate(fieldname_anal2(nrec), fieldlevtyp_anal2(nrec),fieldlevel_anal2(nrec)) + allocate(fieldname_fg(nrec), fieldlevtyp_fg(nrec),fieldlevel_fg(nrec)) + allocate(order_anal1(nrec)) + allocate(order_anal2(nrec)) + + do n=1,nrec + call nemsio_readrec(gfile_fg,n,rwork_fg(:,n),iret=iret) ! ens mean background + if (iret /= 0) then + print *,'error reading rec ',n,trim(filename_fg) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + call nemsio_getrechead(gfile_fg,n,fieldname_fg(n),fieldlevtyp_fg(n),fieldlevel_fg(n),iret=iret) + end do + do n=1,nrec + call nemsio_readrec(gfile_anal1,n,rwork_anal1(:,n),iret=iret) ! 3dvar analysis + if (iret /= 0) then + print *,'error reading rec ',n,trim(filename_anal1) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + call nemsio_getrechead(gfile_anal1,n,fieldname_anal1(n),fieldlevtyp_anal1(n),fieldlevel_anal1(n),iret=iret) + end do + do n=1,nrec + call nemsio_readrec(gfile_anal2,n,rwork_anal2(:,n),iret=iret) ! EnKF analysis + if (iret /= 0) then + print *,'error reading rec ',n,trim(filename_anal2) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + call nemsio_getrechead(gfile_anal2,n,fieldname_anal2(n),fieldlevtyp_anal2(n),fieldlevel_anal2(n),iret=iret) + end do + call getorder(fieldname_fg,fieldname_anal1,fieldlevtyp_fg,fieldlevtyp_anal1,fieldlevel_fg,fieldlevel_anal1,nrec,order_anal1) + call getorder(fieldname_fg,fieldname_anal2,fieldlevtyp_fg,fieldlevtyp_anal2,fieldlevel_fg,fieldlevel_anal2,nrec,order_anal2) + + do n=1,nrec +! print *,n,order_anal1(n),order_anal2(n),minval(rwork_anal1(:,order_anal1(n))),& +! maxval(rwork_anal1(:,order_anal1(n))),minval(rwork_anal2(:,order_anal2(n))),& +! maxval(rwork_anal2(:,order_anal2(n))) + do i=1,npts + rwork_anal(i,n) = (1.-alpha-beta)*rwork_fg(i,n) + & + alpha*rwork_anal1(i,order_anal1(n)) + & + beta*rwork_anal2(i,order_anal2(n)) + end do + end do + + ! write out blended analysis on root task. + if (mype == 0) then + do n=1,nrec + call nemsio_writerec(gfile_anal,n,rwork_anal(:,n),iret=iret) + if (iret /= 0) then + print *,'error writing rec ',n,trim(filename_anal) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + end do + endif + + call nemsio_close(gfile_fg,iret=iret) + call nemsio_close(gfile_anal1,iret=iret) + call nemsio_close(gfile_anal2,iret=iret) + + if (iret /= 0) then + print *,'error getting header info from ',trim(filename_fg) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + + + write(charnanal,'(i3.3)') mype1 + filename = trim(filenamein)//"_mem"//charnanal + call nemsio_open(gfilei,filename,'READ',iret=iret) + if (iret /= 0) then + print *,'error opening ',trim(filename) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + else + call checkheader(gfilei,filename,nrec,nlons,nlats,nlevs) + endif + gfileo=gfile_anal + filename = trim(filenameout)//"_mem"//charnanal + call nemsio_open(gfileo,trim(filename),'WRITE',iret=iret) + + ! fill *_anal1 with 'old' ens members + do n=1,nrec ! read member analyses + call nemsio_readrec(gfilei, n,rwork_anal1(:,n),iret=iret) ! member analysis + call nemsio_getrechead(gfilei,n,fieldname_anal1(n),fieldlevtyp_anal1(n),fieldlevel_anal1(n),iret=iret) + end do + call getorder(fieldname_fg,fieldname_anal1,fieldlevtyp_fg,fieldlevtyp_anal1,fieldlevel_fg,fieldlevel_anal1,nrec,order_anal1) + ! *_anal2 already contains old enkf mean + ! *_anal contains new enkf mean + ! use ordering of fields from ens mean background + +! Recenter ensemble member about new mean + do n=1,nrec + do i=1,npts + rwork_fg(i,n) = rwork_anal1(i,order_anal1(n)) - rwork_anal2(i,order_anal2(n)) + rwork_anal(i,n) + end do + end do + +! Write recentered member analysies using ordering of first guess ensmean fields. + do n=1,nrec + call nemsio_writerec(gfileo,n,rwork_fg(:,n),iret=iret) + if (iret /= 0) then + print *,'error writing rec ',n,trim(filename_anal) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + end do + deallocate(rwork_anal1,rwork_anal2,rwork_fg,rwork_anal) + deallocate(fieldname_anal1, fieldlevtyp_anal1,fieldlevel_anal1) + deallocate(fieldname_anal2, fieldlevtyp_anal2,fieldlevel_anal2) + deallocate(fieldname_fg, fieldlevtyp_fg,fieldlevel_fg) + deallocate(order_anal1,order_anal2) + + if (mype == 0) call nemsio_close(gfile_anal,iret=iret) + call nemsio_close(gfilei,iret=iret) + call nemsio_close(gfileo,iret=iret) + write(6,*)'task mype=',mype,' process ',trim(filenameout)//"_mem"//charnanal,' iret=',iret + +! Jump here if more mpi processors than files to process + else + write (6,*) 'no files to process for mpi task = ',mype + end if ! end if mype + +100 continue + call MPI_Barrier(MPI_COMM_WORLD,iret) + + if (mype==0) call w3tage('RECENTERSIGP_HYBGAIN') + + call MPI_Finalize(iret) + if (mype == 0 .and. iret /= 0) then + print *, 'MPI_Finalize error status = ',iret + end if + +END program recenternemsiop_hybgain + +subroutine getorder(flnm1,flnm2,fllevtyp1,fllevtyp2,fllev1,fllev2,nrec,order) + implicit none + integer nrec + character(16):: flnm1(nrec),flnm2(nrec),fllevtyp1(nrec),fllevtyp2(nrec) + integer :: fllev1(nrec),fllev2(nrec) + integer, intent(out) :: order(nrec) + + integer i,j + + order=0 + do i=1,nrec + doloopj: do j=1,nrec + if(flnm1(i)==flnm2(j).and.fllevtyp1(i)==fllevtyp2(j).and.fllev1(i)==fllev2(j)) then + order(i)=j + exit doloopj + endif + enddo doloopj + enddo +end subroutine getorder + +subroutine checkheader(gfile,filename,nrec,nlons,nlats,nlevs) + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead + implicit none + include "mpif.h" + integer, intent(in) :: nrec,nlons,nlats,nlevs + integer nrec2,nlons2,nlats2,nlevs2,iret + character*500, intent(in) :: filename + type(nemsio_gfile) :: gfile + call nemsio_getfilehead(gfile, nrec=nrec2, dimx=nlons2, dimy=nlats2, dimz=nlevs2, iret=iret) + if (iret /= 0) then + print *,'error getting header from ',trim(filename) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif + if (nrec /= nrec2 .or. nlons /= nlons2 .or. nlats /= nlats2 .or. & + nlevs /= nlevs2) then + print *,'expecting nrec,nlons,nlats,nlevs =',nrec,nlons,nlats,nlevs + print *,'got nrec,nlons,nlats,nlevs =',nrec2,nlons2,nlats2,nlevs2 + print *,'header does not match in ',trim(filename) + call MPI_Abort(MPI_COMM_WORLD,98,iret) + stop + endif +end subroutine checkheader diff --git a/util/EnKF/gfs/src/recentersigp.fd/CMakeLists.txt b/util/EnKF/gfs/src/recentersigp.fd/CMakeLists.txt index e1a497abd..e6ff32d29 100644 --- a/util/EnKF/gfs/src/recentersigp.fd/CMakeLists.txt +++ b/util/EnKF/gfs/src/recentersigp.fd/CMakeLists.txt @@ -2,10 +2,9 @@ cmake_minimum_required(VERSION 2.6) if(BUILD_UTIL) file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90) set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - add_executable(rcentersigp.x ${LOCAL_SRC} ) - set_target_properties( rcentersigp.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) - SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OMPFLAG}" ) - include_directories( ${CORE_INCS} ) - target_link_libraries( rcentersigp.x ${CORE_LIBRARIES} ${MPI_Fortran_LIBRARIES} ) - add_dependencies( rcentersigp.x enkflib enkfdeplib ) + add_executable(recentersigp.x ${LOCAL_SRC} ) + set_target_properties( recentersigp.x PROPERTIES COMPILE_FLAGS ${UTIL_Fortran_FLAGS} ) + SET( CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}" ) + include_directories( ${SIGIOINC} ${NEMSIOINC} ) + target_link_libraries( recentersigp.x ${SIGIO_LIBRARY} ${NEMSIO_LIBRARY} ${BACIO_LIBRARY} ${W3NCO_4_LIBRARY} ${MPI_Fortran_LIBRARIES} ) endif() diff --git a/util/EnKF/gfs/src/recentersigp.fd/Makefile b/util/EnKF/gfs/src/recentersigp.fd/Makefile deleted file mode 100644 index a2d29ec04..000000000 --- a/util/EnKF/gfs/src/recentersigp.fd/Makefile +++ /dev/null @@ -1,308 +0,0 @@ -SHELL=/bin/sh - -#============================================================================== -# -# EnKF utility Makefile -# -# -# 0) Export this makefile name to a variable 'MAKE_FILE' as -# export MAKE_FILE = makefile -# If this file is named neither 'makefile' nor 'Makefile' but -# 'makeairs' for instance, then call this makefile by typing -# 'make -f makeairs' instead of 'make'. -# -# 0a) Modify the include link to either use compile.config.ibm -# or compile.config.sgi for compilation on the ibm sp or sgi -# -# 1) To make a EnKF utility executable file, type -# > make or > make all -# -# 2) To make a EnKF utility executable file with debug options, type -# > make debug -# -# 3) To copy the EnKF utility load module to installing directory, type -# > make install -# . Specify the directory to a variable 'INSTALL_DIR' below. -# -# 4) To crean up files created by make, type -# > make clean -# -# 5) To create a library, libgsi.a, in the lib directory, type -# > make library -# -# -# Created by Y.Tahara in May,2002 -# Edited by D.Kleist Oct. 2003 -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ----------------------------------------------------------- -# Default configuration, possibily redefined in Makefile.conf -# ----------------------------------------------------------- - -ARCH = `uname -s` -SED = sed -DASPERL = /usr/bin/perl -COREROOT = ../../.. -COREBIN = $(COREROOT)/bin -CORELIB = $(COREROOT)/lib -COREINC = $(COREROOT)/include -COREETC = $(COREROOT)/etc - - -# ------------- -# General Rules -# ------------- - -CP = /bin/cp -p -RM = /bin/rm -f -MKDIR = /bin/mkdir -p -AR = ar cq -PROTEX = protex -f # -l -ProTexMake = protex -S # -l -LATEX = pdflatex -DVIPS = dvips - -# Preprocessing -# ------------- -_DDEBUG = -_D = $(_DDEBUG) - -# --------- -# Libraries -# --------- -LIBmpeu = -L$(CORELIB) -lmpeu -LIBbfr = -L$(CORELIB) -lbfr -LIBw3 = -L$(CORELIB) -lw3 -LIBsp = -L$(CORELIB) -lsp -LIBbacio = -L$(CORELIB) -lbacio -LIBsfcio = -L$(CORELIB) -lsfcio -LIBsigio = -L$(CORELIB) -lsigio -LIBtransf = -L$(CORELIB) -ltransf -LIBhermes = -L$(CORELIB) -lhermes -LIBgfio = -L$(CORELIB) -lgfio - -# -------------------------- -# Default Baselibs Libraries -# -------------------------- -INChdf = -I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = -L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz -LIBnetcdf = -L$(BASEDIR)/$(ARCH)/lib -lnetcdf -LIBwrf = -L$(BASEDIR)/$(ARCH)/lib -lwrflib -LIBwrfio_int = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_int -LIBwrfio_netcdf = -L$(BASEDIR)/$(ARCH)/lib -lwrfio_nf - -# ------------------------ -# Default System Libraries -# ------------------------ -LIBmpi = -lmpi -LIBsys = - - -#------------ -# Include machine dependent compile & load options -#------------ - MAKE_CONF = Makefile.conf -include $(MAKE_CONF) - - -# ------------- -# This makefile -# ------------- - - MAKE_FILE = Makefile - - -# ----------- -# Load module -# ----------- - - EXE_FILE = recentersigp.x - - -# -------------------- -# Installing directory -# -------------------- - - INSTALL_DIR = ../../exec - - -# -------- -# Log file -# -------- - - LOG_FILE = log.make.$(EXE_FILE) - - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - - -# ---------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod *.MOD *.lst *.a *.x - - $(RM) loadmap.txt log.make.$(EXE_FILE) - - $(MAKE) -f ${MAKE_FILE} doclean - - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# ------------ -# Source files -# ------------ - - SRCSF90C = recentersigp.f90 - - SRCSF77 = - - SRCSC = - - SRCS = $(SRCSF90C) $(SRCSF77) $(SRCSC) - - DOCSRCS = *.f90 *.F90 - -# ------------ -# Object files -# ------------ - - SRCSF90 = ${SRCSF90C:.F90=.f90} - - OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} - - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.F90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) $(_D) -c $< - -.f90.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(CF) $(FFLAGS_f) -c $< - -.c.o : - @echo - @echo '---> Compiling $<' - $(CC) $(CFLAGS) -c $< - -# ------------ -# Dependencies -# ------------ - MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ---- - -$(EXE_FILE) : $(OBJS) - $(LD) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) - - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ - $(EXE_FILE) - -library : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_N)" \ - "CFLAGS=$(CFLAGS_N)" \ - $(OBJS) - @echo - @echo '==== CREATING LIBRARY ========================================' - $(MAKE) lib - mv $(LIB) ../lib - -debug : - @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode - @echo - @echo '==== COMPILE =================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "FFLAGS=$(FFLAGS_D)" \ - "CFLAGS=$(CFLAGS_D)" \ - $(OBJS) - @echo - @echo '==== LINK ====================================================' - @$(MAKE) -f $(MAKE_FILE) \ - "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_D)" \ - $(EXE_FILE) - -check_mode : - @if [ -e $(LOG_FILE) ]; then \ - if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ - echo ;\ - echo "### COMPILE MODE WAS CHANGED ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi ;\ - else \ - echo ;\ - echo "### NO LOG FILE ###" ;\ - $(MAKE) -f $(MAKE_FILE) clean ;\ - fi - @echo $(COMP_MODE) > $(LOG_FILE) - -doclean: - - $(RM) *.tex *.dvi *.aux *.toc *.log *.ps *.pdf - diff --git a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.AIX b/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.AIX deleted file mode 100644 index 69c1f4236..000000000 --- a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.AIX +++ /dev/null @@ -1,97 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NCEP IBM SP. All production builds -# on NCEP IBM SP are 64-bit - -# ---------------------------------- -# Redefine variables for NCEP IBM SP -# ---------------------------------- -COREINC = /nwprod/lib/incmod -INCsfcio = $(COREINC)/sfcio_4 -INCsigio = $(COREINC)/sigio_4 - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -X64 -v -q - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpxlf95_r - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -qsmp=noauto - - FFLAGS_F90 = -qfree=f90 -qsuffix=f=f90:cpp=F90 - - FFLAGS_COM_N = -I $(INCsigio) -qarch=auto -O3 -qfullpath -qdbg -qstrict -q64 $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - - - -#--- Debug mode options - FFLAGS_COM_D = $(FFLAGS_COM_N) \ - -O0 -qdbg -qfullpath \ - -qsigtrap=xl__trcedump \ - -qinitauto=7FF7FFFF \ - -qflttrap=overflow:zero:enable \ - -qcheck \ - -qwarn64 \ - -qflag=i:i - - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = ncepcc - -#--- Normal mode options - - CFLAGS_N = -I ./ -O3 - -#--- Debug mode options - - CFLAGS_D = -I ./ -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = -L/nwprod/lib -lsigio_4 -lw3_4 - - LDFLAGS_N = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K $(OMP) $(PROF) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) -lhmd - - LDFLAGS_D = -lessl_r -lmass -bloadmap:loadmap.txt \ - -bdatapsize:64K -bstackpsize:64K - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.cray b/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.cray deleted file mode 100644 index 03f5e449e..000000000 --- a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.cray +++ /dev/null @@ -1,152 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ------------------------------------ -# Redefine variables for Cray on WCOSS -# ------------------------------------ - -# Set library versions -BACIO_VER = v2.0.1 -BUFR_VER = v11.0.1 -CRTM_VER = v2.2.3 -NEMSIO_VER = v2.2.2 -NETCDF_VER = 3.6.3 -SFCIO_VER = v1.0.0 -SIGIO_VER = v2.0.1 -SP_VER = v2.0.2 -W3EMC_VER = v2.2.0 -W3NCO_VER = v2.0.6 - -CORELIB = /gpfs/hps/nco/ops/nwprod/lib -COMPILER = intel - -CRTM_INC=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/include/crtm_$(CRTM_VER) -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/include/nemsio_$(NEMSIO_VER) -SFCIO_INC4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/include/sfcio_$(SFCIO_VER)_4 -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/include/sigio_$(SIGIO_VER)_4 -W3EMC_INCd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/w3emc_$(W3EMC_VER)_d - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/$(COMPILER)/libbacio_$(BACIO_VER)_4.a -BUFR_LIBd=$(CORELIB)/bufr/$(BUFR_VER)/$(COMPILER)/libbufr_$(BUFR_VER)_d_64.a -CRTM_LIB=$(CORELIB)/crtm/$(CRTM_VER)/$(COMPILER)/libcrtm_$(CRTM_VER).a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/$(COMPILER)/libnemsio_$(NEMSIO_VER).a -SFCIO_LIB4=$(CORELIB)/sfcio/$(SFCIO_VER)/$(COMPILER)/libsfcio_$(SFCIO_VER)_4.a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/$(COMPILER)/libsigio_$(SIGIO_VER)_4.a -SP_LIBd=$(CORELIB)/sp/$(SP_VER)/$(COMPILER)/libsp_$(SP_VER)_d.a -W3EMC_LIBd=$(CORELIB)/w3emc/$(W3EMC_VER)/$(COMPILER)/libw3emc_$(W3EMC_VER)_d.a -W3NCO_LIBd=$(CORELIB)/w3nco/$(W3NCO_VER)/$(COMPILER)/libw3nco_$(W3NCO_VER)_d.a - -NETCDFPATH = /usrx/local/prod/NetCDF/$(NETCDF_VER)/$(COMPILER)/haswell -NETCDF_INCLUDE = $(NETCDFPATH)/include -NETCDF_LDFLAGS_F = -L$(NETCDFPATH)/lib -lnetcdf - - -# WRF locations -WRFPATH = /gpfs/hps/nco/ops/nwprod/wrf_shared.v1.1.0-$(COMPILER) -LIBwrfio_int = $(WRFPATH)/external/io_int/libwrfio_int.a -LIBwrfio_netcdf = $(WRFPATH)/external/io_netcdf/libwrfio_nf.a -OBJwrf_frame_pk = $(WRFPATH)/frame/pack_utils.o -OBJwrf_sizeof_int = $(WRFPATH)/frame/module_machine.o -WRFLIB = $(LIBwrfio_int) $(LIBwrfio_netcdf) $(OBJwrf_frame_pk) $(OBJwrf_sizeof_int) - - -# Empty out definition of libs use by GMAO GSI building structure -LIBtransf = #-L$(CORELIB) -ltransf -LIBhermes = #-L$(CORELIB) -lhermes -LIBgfio = #-L$(CORELIB) -lgfio -INChdf = #-I$(BASEDIR)/$(ARCH)/include/hdf -LIBhdf = #-L$(BASEDIR)/$(ARCH)/lib -lmfhdf -ldf -lhdfjpeg -lhdfz -lsz - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -rv - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ftn - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = -openmp - - FFLAGS_F90 = -D_REAL8_ -DWRF - - FFLAGS_COM_N = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_COM_N_NOSWAP = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O3 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone $(OMP) - - FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) - FFLAGS_NOSWAP_N = $(FFLAGS_F90) $(FFLAGS_COM_N_NOSWAP) $(PROF) - FFLAGS_f = $(FFLAGS_COM_N) $(PROF) - FFLAGS = $(FFLAGS_N) $(PROF) - - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_COM_NOSWAP_D = -I ./ -I $(CRTM_INC) -I $(SFCIO_INC4) -I $(SIGIO_INC4) \ - -I $(NEMSIO_INC) -I $(NETCDF_INCLUDE) -I $(W3EMC_INCd) \ - -O0 -fp-model source -convert big_endian -assume byterecl \ - -implicitnone -g -traceback -debug \ - -ftrapuv -check all -fp-stack-check -fstack-protector -warn - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - FFLAGS_NOSWAP_D = $(FFLAGS_F90) $(FFLAGS_COM_NOSWAP_D) - - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = cc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(OMP) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - - LIBS_N = $(SP_LIBd) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) \ - $(SFCIO_LIB4) $(BUFR_LIBd) $(W3NCO_LIBd) $(W3EMC_LIBd) \ - $(CRTM_LIB) $(WRFLIB) $(NETCDF_LDFLAGS_F) -# -L../lib/GSD/gsdcloud4nmmb -lgsdcloud - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt $(OMP) - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = -mkl -Wl,-Map,loadmap.txt - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.nco b/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.nco deleted file mode 100644 index b8fcfc233..000000000 --- a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.nco +++ /dev/null @@ -1,74 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = $(COMP_MP) - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(SIGIO_INC4) -I $(NEMSIO_INC) -O3 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SIGIO_INC4) -I $(NEMSIO_INC) -O0 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone \ - -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = $(C_COMP_MP) - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.theia b/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.theia deleted file mode 100644 index 92045ef60..000000000 --- a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.theia +++ /dev/null @@ -1,84 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -BACIO_VER = 2.0.1 -NEMSIO_VER = 2.2.1 -SIGIO_VER = 2.0.1 -W3NCO_VER = 2.0.6 - -CORELIB = /scratch3/NCEPDEV/nwprod/lib - -INCsigio = $(CORELIB)/sigio/v$(SIGIO_VER)/incmod/sigio_v$(SIGIO_VER)_4 -INCnemsio= $(CORELIB)/nemsio/v$(NEMSIO_VER)/incmod/nemsio_v$(NEMSIO_VER) - -BACIO_LIB4=$(CORELIB)/bacio/v$(BACIO_VER)/libbacio_v$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/v$(NEMSIO_VER)/libnemsio_v$(NEMSIO_VER).a -SIGIO_LIB4=$(CORELIB)/sigio/v$(SIGIO_VER)/libsigio_v$(SIGIO_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_4.a - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpif90 -f90=ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsigio) -I $(INCnemsio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) - - LDFLAGS_N = -mkl -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.wcoss b/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.wcoss deleted file mode 100644 index ad0bebf6c..000000000 --- a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.wcoss +++ /dev/null @@ -1,89 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Set library versions -# ---------------------------------- - -BACIO_VER = v2.0.1 -NEMSIO_VER = v2.2.1 -SIGIO_VER = v2.0.1 -W3NCO_VER = v2.0.6 - -CORELIB = /nwprod/lib - -NEMSIO_INC=$(CORELIB)/nemsio/$(NEMSIO_VER)/incmod/nemsio_$(NEMSIO_VER) -SIGIO_INC4=$(CORELIB)/sigio/$(SIGIO_VER)/incmod/sigio_$(SIGIO_VER)_4 - -BACIO_LIB4=$(CORELIB)/bacio/$(BACIO_VER)/libbacio_$(BACIO_VER)_4.a -NEMSIO_LIB=$(CORELIB)/nemsio/$(NEMSIO_VER)/libnemsio_$(NEMSIO_VER).a -SIGIO_LIB4=$(CORELIB)/sigio/$(SIGIO_VER)/libsigio_$(SIGIO_VER)_4.a -W3NCO_LIB4=$(CORELIB)/w3nco/$(W3NCO_VER)/libw3nco_$(W3NCO_VER)_4.a - - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = mpfort - FC = $(CF) - -#--- Normal mode options - PROF= - OMP = - - FFLAGS_F90 = - FFLAGS_COM_N = -I ./ -I $(SIGIO_INC4) -I $(NEMSIO_INC) -O3 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(SIGIO_INC4) -I $(NEMSIO_INC) -O0 -fp-model source \ - -convert big_endian -assume byterecl -implicitnone \ - -traceback -g -warn all -debug all -check all - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = mpcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) - -#--- Normal mode options - LIBS_N = $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIB4) - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = $(LDFLAGS_N) - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.zeus b/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.zeus deleted file mode 100644 index eb01f3c83..000000000 --- a/util/EnKF/gfs/src/recentersigp.fd/Makefile.conf.zeus +++ /dev/null @@ -1,74 +0,0 @@ -# This config file contains the compile options for compilation -# of the GSI code on the NOAA HPCS. - -# ---------------------------------- -# Redefine variables for NOAA HPCS -# ---------------------------------- -COREINC = /contrib/nceplibs/nwprod/lib/incmod -CORELIB = /contrib/nceplibs/nwprod/lib -INCsigio = $(COREINC)/sigio_4 -INCnemsio= $(COREINC)/nemsio - -# --------------------------- -# General targets/definitions -# --------------------------- - - AR = ar -v - -# ---------------------------- -# Fortran compiler and options -# ---------------------------- - - CF = ifort - FC = $(CF) - -#--- Normal mode options - PROF= #-pg - OMP = #-qsmp=noauto - - FFLAGS_F90 = -assume byterecl -warn all -implicitnone -g -traceback -fp-model strict - FFLAGS_COM_N = -I $(INCsigio) -I $(INCnemsio) - FFLAGS_N = -O3 $(FFLAGS_F90) $(FFLAGS_COM_N) - -#--- Debug mode options - FFLAGS_COM_D = -I ./ -O0 -xHOST -traceback -assume byterecl -debug full -g - FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) $(FFLAGS_COM_N) - - -# ---------------------- -# C Compiler and options -# ---------------------- - - CC = gcc - -#--- Normal mode options - - CFLAGS_N = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O3 $(PROF) - -#--- Debug mode options - - CFLAGS_D = -DLINUX -Dfunder -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g - - -# ------------------ -# Linker and options -# ------------------ - - LD = $(CF) -lmpi - -#--- Normal mode options - LIBS_N = -L$(CORELIB) -lnemsio -lbacio_4 -lsigio_4 -lw3nco_4 - - LDFLAGS_N = -Wl,-Map,loadmap.txt - - LDFLAGS = $(LDFLAGS_N) - -#--- Debug mode options - - LIBS_D = $(LIBS_N) - - LDFLAGS_D = - -#--- Empty out mpi library definition: embedded in compiler - - LIBmpi = diff --git a/util/EnKF/gfs/src/recentersigp.fd/Makefile.dependency b/util/EnKF/gfs/src/recentersigp.fd/Makefile.dependency deleted file mode 100644 index 7c90b672c..000000000 --- a/util/EnKF/gfs/src/recentersigp.fd/Makefile.dependency +++ /dev/null @@ -1 +0,0 @@ -recentersigp.o : recentersigp.f90 diff --git a/util/EnKF/gfs/src/recentersigp.fd/configure b/util/EnKF/gfs/src/recentersigp.fd/configure deleted file mode 100755 index b169dfc97..000000000 --- a/util/EnKF/gfs/src/recentersigp.fd/configure +++ /dev/null @@ -1,94 +0,0 @@ -#!/bin/sh -# -# Creates configuration Makefile. Before attempting to make anything -# in this directory, enter -# -# ./configure -# -# !REVISION HISTORY -# -# 09oct97 da Silva Initial code. -# 19oct97 da Silva Simplified. -# 22oct97 Jing Guo Converted to libpsas.a environment -# - special configuration for CRAY -# - fool-prove configuration -# - additional information -# 23dec99 da Silva Modified error messages. -# -#..................................................................... - -c=`basename $0 .sh` - -type=${1:-"unknown"} -echo $type - - -# If type=clean, remove soft links and exit -# ----------------------------------------- -if [ "$type" = "clean" ]; then - if [ -r makefile ]; then - echo "$c: remove makefile" 1>&2 - rm makefile - fi - if [ -r Makefile.conf ]; then - echo "$c: remove Makefile.conf" 1>&2 - rm Makefile.conf - fi - exit -fi - - -# Node specific configuration -# --------------------------------------- -makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" - -# Machine specific -# ---------------- -if [ ! -r ${makeconf} ]; then - echo "$c: not using site specific ${makeconf} in `pwd`" 1>&2 - machine="`uname -m | awk '{print $1}'`" - machine=`echo $machine | tr "[a-z]" "[A-Z]"` - compiler=$F90 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - makeconf="${makeconf}.${machine}.${compiler}" -fi - -# Site specific configuration -# --------------------------- -if [ ! -r ${makeconf} ]; then -# echo "$c: cannot find site specific ${makeconf}" 1>&2 - makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" - # if all are failed, make a simple one - # --------------------------------------- -# if [ `uname -s` = "AIX" ]; then -# echo "Linking Makefile to makefile" 1>&2 -# ln -sf Makefile makefile -# fi -fi - -# if the OS is UNICOS, it does not follow the convention -# ------------------------------------------------------ -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 - mech="`uname -m | awk '{print $1}'`" - if [ "${mech}" = CRAY ]; then - makeconf="Makefile.conf.UNICOS" - fi -fi - -# if all are failed, make a simple one -# --------------------------------------- -if [ ! -r ${makeconf} ]; then - echo "$c: cannot find ${makeconf} in `pwd` " 1>&2 - makeconf="Makefile.conf.$type" - if [ ! -r ${makeconf} ]; then - touch ${makeconf} - fi -fi - -rm -f Makefile.conf -ln -s ${makeconf} Makefile.conf - -echo "$c: using ${makeconf} in `pwd`" 1>&2 - -#. diff --git a/util/EnKF/gfs/src/recentersigp.fd/recentersigp.f90 b/util/EnKF/gfs/src/recentersigp.fd/recentersigp.f90 index e0dff6bb5..c8eda7981 100644 --- a/util/EnKF/gfs/src/recentersigp.fd/recentersigp.f90 +++ b/util/EnKF/gfs/src/recentersigp.fd/recentersigp.f90 @@ -45,7 +45,7 @@ program recentersigp character(16),dimension(:),allocatable:: fieldlevtyp_di,fieldlevtyp_mi,fieldlevtyp_mo integer,dimension(:),allocatable:: fieldlevel_di,fieldlevel_mi,fieldlevel_mo,orderdi,ordermi integer nsigi,nsigo,iret,mype,mype1,npe,nanals,ierr - integer:: nrec,latb,lonb,levs,npts,n,i,k,nn + integer:: nrec,latb,lonb,levs,npts,n,i real,allocatable,dimension(:):: rwork1d real,allocatable,dimension(:,:) :: rwork1di,rwork1do,rwork1dmi,rwork1dmo diff --git a/util/EnKF/python_utilities/create_vlocal_eig.py b/util/EnKF/python_utilities/create_vlocal_eig.py new file mode 100644 index 000000000..3ff895b14 --- /dev/null +++ b/util/EnKF/python_utilities/create_vlocal_eig.py @@ -0,0 +1,156 @@ +import numpy as np +import sys + +# utility to create vlocal_eig.dat for modulated ensemble model-space +# vertical localization in EnKF + +if len(sys.argv) < 4: + sys.stdout.write('python create_vlocal_eig.py \n') + sys.stdout.write(' is vertical localization cutoff in scale heights\n') + sys.stdout.write(' is percent variance explained threshold\n') + sys.stdout.write(' is global_hyblev.l##.txt file\n') + sys.stdout.write('eigenvectors written to vlocal_eig.dat\n') + raise SystemExit + +# read in localization cutoff distance in (units on lnp) +cutoff = float(sys.argv[1]) +# read in threshold for truncating eigenspace of localization matrix (95 = 95% var explained) +thresh = 0.01*float(sys.argv[2]) +# read in hybrid levels (hyblevs file from fix/fix_am) +siglev = sys.argv[3] + +# get ak,bk from hyblevs file +siglev_data = np.loadtxt(siglev) +nlevs = int(siglev_data[0,1]-1) +ak = siglev_data[1:nlevs+2,0] +bk = siglev_data[1:nlevs+2,1] + +# constants +rd = 2.8705e+2 +cp = 1.0046e+3 +kap = rd/cp +kapr = cp/rd +kap1 = kap + 1.0 + +# localization functions. +def localization(r): + r = np.clip(r,1.e-13,1.) + twor = 2.*r + # Gaspari-Cohn polynomial. + taper1 = np.where(r <= 0.5, -(1./4.)*twor**5+(1./2.)*twor**4+(5./8.)*twor**3-(5./3.)*twor**2+1, 0.) + cond1 = r > 0.5; cond2 = r < 1.0 + taper = np.where(np.logical_and(cond1,cond2), + (1./12.)*twor**5-(1./2.)*twor**4+(5./8.)*twor**3+(5./3.)*twor**2-5.*twor+4.-(2./3.)*(1./twor), taper1) + # Gaussian approx to GC + #taper = np.exp(-(r**2/0.15)) # Gaussian + return taper + +# set mean surface pressure (has to be a global constant) +psgmean = 1.e5 + +pressimn = np.empty((nlevs+1),'d') # interface pressure +presslmn = np.empty((nlevs),'d') # mid-layer pressure +for k in range(nlevs+1): + pressimn[k] = ak[k] + bk[k]*psgmean +for k in range(nlevs): + # phillips vertical interpolation from guess_grids.F90 in GSI (used for global model) + presslmn[k] = ((pressimn[k]**kap1-pressimn[k+1]**kap1)/(kap1*(pressimn[k]-pressimn[k+1])))**kapr + # simple average of interface pressures (used by fv3_regional in GSI) + #presslmn[k] = 0.5*(pressimn[k]+pressimn[k+1]) + # linear in logp interpolation from interface pressures + #presslmn[k] = np.exp(0.5*(np.log(pressimn[k])+np.log(pressimn[k+1]))) + print k,presslmn[k] +logp = -np.log(presslmn) # (ranges from -2 to -11) + + +covlocal = np.zeros((nlevs,nlevs),'d') +for j in range(nlevs): + covlocal[j,:] = localization(abs(logp-logp[j])/cutoff) + +#import matplotlib.pyplot as plt +#plt.figure(1) +#imgplot=plt.imshow(covlocal) +#plt.colorbar() + +evals,eigs=np.linalg.eigh(covlocal) +evalsum = evals.sum(); neig = 0 +evals = np.where(evals > 1.e-10, evals, 1.e-10) +frac = 0.0 +while frac < thresh: + frac = evals[nlevs-neig-1:nlevs].sum()/evalsum + neig += 1 +print 'neig = ',neig +zz = (eigs*np.sqrt(evals/frac)).T +#print evals +f = open('vlocal_eig.dat','w') +f.write('%s %s %s\n' % (neig,thresh,cutoff)) +print 'rescaled eigenvalues' +eigsum = 0. +for j in range(neig): + f.write('%s\n' % evals[nlevs-j-1]) + print j+1,evals[nlevs-j-1]/frac + eigsum += evals[nlevs-j-1]/frac + for k in range(nlevs): + f.write('%s\n' % zz[nlevs-j-1,k]) +f.close() +print 'sum of scaled truncated eigvals should equal sum of original evals' +print '(difference below should be nearly zero)' +print np.abs(eigsum-evals.sum()) + +# check data +f = open('vlocal_eig.dat','r') +evals2 = np.zeros(neig,np.float) +evecs2 = np.zeros((neig,nlevs),np.float) +f.readline() +for j in range(neig): + evals2[j] = float(f.readline()) +# print j,evals2[j]/frac + for k in range(nlevs): + evecs2[j,k] = float(f.readline()) +# this should be a diagonal matrix with eigvals on diagonal +covlocal2 = np.dot(evecs2,evecs2.T) +print 'diagonal elements of scaled dot(E,E^T), should be scaled evals' +print np.diag(covlocal2) +mask = np.ones(covlocal2.shape, dtype=bool) +np.fill_diagonal(mask, 0) +print 'max/min off diagonal elements (should be zero)',covlocal2[mask].max(),covlocal2[mask].min() +# this should be the (truncated) localization matrix +covlocal2 = np.dot(evecs2.T,evecs2) +#print covlocal2.shape +print 'diagonal of localization matrix (should be ones)' +print np.diag(covlocal2) +#print covlocal2[nlevs/2,:] + +#plt.figure(2) +#plt.plot(covlocal2[nlevs/2,:],'r') +#plt.plot(covlocal[nlevs/2,:],'k') +#plt.xlim(0,nlevs-1) + +#z = zz[nlevs-neig:nlevs,:] +#print z[-1].min(), z[-1].max() + +#plt.figure(3) +#imgplot=plt.imshow(zz) +#plt.colorbar() + +# plot the 1st eig vector +#plt.figure(4) +##plt.plot(-z[-1],np.arange(nlevs)) +#plt.plot(-z[-1],0.01*presslmn) +##plt.semilogy(-z[-1],0.01*presslmn,basey=2) +##plt.ylim([0,nlevs]) +#plt.ylim(1000,0) +##yticks = [1000,850,700,500,300,200,100,70,50,30,10] +##yticklabels = ['%s' % p for p in yticks] +##plt.yticks(yticks,yticklabels) +#plt.xlim(-0.25,1.25) +#plt.ylabel('Pressure (hPa)') +#plt.xlabel('Eigenvector') +#plt.axvline(0,color='k') +#for k in range(nlevs): +# plt.axhline(0.01*presslmn[k],color='k',linestyle='dotted') +#plt.title('First Eigenvector of Vertical Localization Matrix') +##plt.grid(True) +#plt.savefig('eig1.png') +# +#plt.show() diff --git a/util/GMI_BUFR_gen/gmi/etc/.#Prep_Config.GET-GMI-01.1.2 b/util/GMI_BUFR_gen/gmi/etc/.#Prep_Config.GET-GMI-01.1.2 new file mode 100644 index 000000000..3152a367d --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/etc/.#Prep_Config.GET-GMI-01.1.2 @@ -0,0 +1,12 @@ +#GMI TEMPERATURE processing +GMI_WORK_DIR = /discover/nobackup/dao_ops/intermediate/flk/work/gmi +GMI_STAGE_DIR = /discover/nobackup/dao_ops/intermediate/flk/stage/gmi +GMI_TABLE_DIR = /home/dao_ops/operations/pre_proc/src/gmi/etc/ +GMI_ARCHIVE_LOC = /archive/input/dao_ops/ +GMI_ACQUIRE_MACH = jianjun.jin@nasa.gov@jsimpson.pps.eosdis.nasa.gov +GMI_ACQUIRE_PATH_1B = /data/GMI1B/1B.GPM.GMI.TB2014.%y4%m2%d2*H5 +GMI_ACQUIRE_PATH_1B = /data/GMI1B/1B.GPM.GMI.TB*.%y4%m2%d2*H5 +GMI_ACQUIRE_PATH_1CR = /data/1CR/1C-R.GPM.GMI.XCAL2014-N.%y4%m2%d2*H5 +GMI_ACQUIRE_PATH_1CR = /data/1CR/1C-R.GPM.GMI.XCAL*.%y4%m2%d2*H5 +GMI_BUFR = gmi_L1CR.%y4%m2%d2.t%h2z.bufr +#END GMI TEMPERATURE processing diff --git a/util/GMI_BUFR_gen/gmi/etc/GMI_bufr_table_1CR b/util/GMI_BUFR_gen/gmi/etc/GMI_bufr_table_1CR new file mode 100644 index 000000000..f6681f220 --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/etc/GMI_bufr_table_1CR @@ -0,0 +1,112 @@ +.------------------------------------------------------------------------------. +| ------------ USER DEFINITIONS FOR TABLE-A TABLE-B TABLE D -------------- | +|------------------------------------------------------------------------------| +| MNEMONIC | NUMBER | DESCRIPTION | +|----------|--------|----------------------------------------------------------| +| | | | +| NC021200 | A10061 | MSG TYPE 021-204 GPM GMI file head and channel info. | +| NC021204 | A10062 | MSG TYPE 021-204 GPM GMI radiance data | +| | | | +| CHINFO | 350202 | GPM GMI channel information | +| YYMMDD | 301011 | Date -- year, month, day | +| HHMM | 301012 | Time -- hour, minute | +| LTLONH | 301021 | High accuracy latitude/longitude position | +| PIXELS | 350205 | GPM GMI pixels information | +| GMICH | 350206 | GPM GMI brightness temperature data | +| GMIANGL | 350207 | GPM GMI geolocation | +| | | | +| SAID | 001007 | Satellite identifier | +| OGCE | 001033 | Identification of originating/generating center | +| GSES | 001034 | Identification of originating/generating sub-center | +| SIID | 002019 | Satellite instruments | +| ANPO | 002104 | Antenna polarization (0, horizontal; 1, vertical) | +| SCCF | 002153 | Satellite channel center frequency | +| SCBW | 002154 | Satellite channel band width | +| YEAR | 004001 | Year | +| MNTH | 004002 | Month | +| DAYS | 004003 | Day | +| HOUR | 004004 | Hour | +| MINU | 004005 | Minute | +| SECO | 004006 | Second | +| CLATH | 005001 | Latitude (high accuracy) | +| ORBN | 005040 | Orbit number | +| SLNM | 005041 | Scan line number | +| CHNM | 005042 | Channel number | +| FOVN | 005043 | Field of view number | +| CLONH | 006001 | Longitude (high accuracy) | +| SCLON | 006002 | geodedic latitude of the spacecraft | +| SCLAT | 005002 | geodedic longitude of the spacecraft | +| HMSL | 007002 | Height or altitude | +| SAZA | 007024 | Satellite zenith angle (Incidence angle) | +| SAMA | 005021 | Satellite azimuth angle | +| SZA | 007025 | Solar zenith angle | +| SMA | 005022 | Solar azimuth angle | +| SGA | 007192 | Satellite-sun glint angle | +| TMANT | 012066 | Antenna temperature | +| TMBR | 012163 | Brightness temperature | +| SACV | 025075 | Satellite antenna corrections version number | +| NGQI | 033078 | Geolocation quality | +| GMIGQ | 033079 | GMI granule level quality flags | +| GMISQ | 033080 | GMI scan level quality flags | +| GMICHQ | 033081 | GMI channel data quality flags | +| GMIRFI | 033112 | GMI channel frequency RFI flags | +| | | | +|------------------------------------------------------------------------------| +| MNEMONIC | SEQUENCE | +|----------|-------------------------------------------------------------------| +* | 13 channels | +| NC021200 | SAID SIID OGCE GSES SACV "CHINFO"13 | +| CHINFO | CHNM SCCF SCBW ANPO | +| | | +| NC021204 | ORBN SLNM SCLAT SCLON | +| NC021204 | YYMMDD HHMM 207003 SECO 207000 | +| NC021204 | 201129 HMSL 201000 (PIXELS) | +| YYMMDD | YEAR MNTH DAYS | +| HHMM | HOUR MINU | +| PIXELS | LTLONH FOVN "GMIANGL"2 "GMICH"13 | +| LTLONH | CLATH CLONH | +| GMIANGL | SAZA SAMA SZA SMA SGA | +| GMICH | CHNM GMICHQ TMBR GMIRFI | +| | | +|------------------------------------------------------------------------------| +| MNEMONIC | SCAL | REFERENCE | BIT | UNITS |-------------| +|----------|------|-------------|-----|--------------------------|-------------| +| | | | | |-------------| +| SAID | 0 | 0 | 10 | Code table |-------------| +| OGCE | 0 | 0 | 8 | Code table |-------------| +| GSES | 0 | 0 | 8 | Code table |-------------| +| SIID | 0 | 0 | 11 | Code table |-------------| +| ANPO | 0 | 0 | 4 | Code table |-------------| +| SCCF | -8 | 0 | 16 | Hz |-------------| +| SCBW | -8 | 0 | 16 | Hz |-------------| +| YEAR | 0 | 0 | 12 | Year |-------------| +| MNTH | 0 | 0 | 4 | Month |-------------| +| DAYS | 0 | 0 | 6 | Day |-------------| +| HOUR | 0 | 0 | 5 | Hour |-------------| +| MINU | 0 | 0 | 6 | Minute |-------------| +| SECO | 0 | 0 | 6 | Second |-------------| +| CLATH | 5 | -9000000 | 25 | Degree |-------------| +| ORBN | 0 | 0 | 24 | Numeric |-------------| +| SLNM | 0 | 0 | 24 | Numeric |-------------| +| CHNM | 0 | 0 | 6 | Numeric |-------------| +| FOVN | 0 | 0 | 8 | Numeric |-------------| +| CLONH | 5 | -18000000 | 26 | Degree |-------------| +| SCLAT | 5 | -9000000 | 25 | Degree |-------------| +| SCLON | 5 | -18000000 | 26 | Degree |-------------| +| HMSL | -1 | -40 | 16 | m |-------------| +| SAZA | 2 | 0 | 16 | Degree |-------------| +| SAMA | 2 | -18000 | 16 | Degree |-------------| +| SZA | 2 | 0 | 16 | Degree |-------------| +| SMA | 2 | -18000 | 16 | Degree |-------------| +| SGA | 1 | -1800 | 16 | Degree |-------------| +| TMANT | 2 | 0 | 16 | K |-------------| +| TMBR | 2 | 0 | 16 | K |-------------| +| SACV | 0 | 0 | 5 | Numeric |-------------| +| NGQI | 0 | 0 | 4 | Code table |-------------| +| GMIGQ | 0 | 0 | 16 | Flag table |-------------| +| GMISQ | 0 | 0 | 20 | Flag table |-------------| +| GMICHQ | 0 | 0 | 12 | Flag table |-------------| +| GMIRFI | 0 | 0 | 12 | Flag table |-------------| +| | | | | |-------------| +'------------------------------------------------------------------------------' + diff --git a/util/GMI_BUFR_gen/gmi/etc/Prep_Config.GET-GMI-01 b/util/GMI_BUFR_gen/gmi/etc/Prep_Config.GET-GMI-01 new file mode 100644 index 000000000..057b8112b --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/etc/Prep_Config.GET-GMI-01 @@ -0,0 +1,10 @@ +#GMI TEMPERATURE processing +GMI_WORK_DIR = /discover/nobackup/dao_ops/intermediate/flk/work/gmi +GMI_STAGE_DIR = /discover/nobackup/dao_ops/intermediate/flk/stage/gmi +GMI_TABLE_DIR = /home/dao_ops/operations/pre_proc/src/gmi/etc/ +GMI_ARCHIVE_LOC = /archive/input/dao_ops/ +GMI_ACQUIRE_MACH = jianjun.jin@nasa.gov@jsimpson.pps.eosdis.nasa.gov +GMI_ACQUIRE_PATH_1B = /data/GMI1B/1B.GPM.GMI.TB*.%y4%m2%d2*H5 +GMI_ACQUIRE_PATH_1CR = /data/1CR/1C-R.GPM.GMI.XCAL*.%y4%m2%d2*H5 +GMI_BUFR = gmi_L1CR.%y4%m2%d2.t%h2z.bufr +#END GMI TEMPERATURE processing diff --git a/util/GMI_BUFR_gen/gmi/etc/Prep_Config.GET-GMI-01.karki b/util/GMI_BUFR_gen/gmi/etc/Prep_Config.GET-GMI-01.karki new file mode 100644 index 000000000..acbe20b62 --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/etc/Prep_Config.GET-GMI-01.karki @@ -0,0 +1,10 @@ +#GMI TEMPERATURE processing +GMI_WORK_DIR = /discover/nobackup/dao_ops/intermediate/flk/work/gmi +GMI_STAGE_DIR = /discover/nobackup/dao_ops/intermediate/flk/stage/gmi +GMI_TABLE_DIR = /home/dao_ops/operations/pre_proc/src/gmi/etc/ +GMI_ARCHIVE_LOC = /archive/input/dao_ops/ +GMI_ACQUIRE_MACH = MISS +GMI_ACQUIRE_PATH_1B = /nfs3m/archive/sfa_cache05/projects/verification/mkarki/s1/GMI/1B/%y4%m2/1B.GPM.GMI.TB*.%y4%m2%d2*H5 +GMI_ACQUIRE_PATH_1CR = /nfs3m/archive/sfa_cache05/projects/verification/mkarki/s1/GMI/1CR/%y4%m2/1C-R.GPM.GMI.XCAL*.%y4%m2%d2*H5 +GMI_BUFR = gmi_L1CR.%y4%m2%d2.t%h2z.bufr +#END GMI TEMPERATURE processing diff --git a/util/GMI_BUFR_gen/gmi/perl/.#get_gmi.pl.1.3 b/util/GMI_BUFR_gen/gmi/perl/.#get_gmi.pl.1.3 new file mode 100755 index 000000000..2bc5c6e3d --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/perl/.#get_gmi.pl.1.3 @@ -0,0 +1,1706 @@ +#!/usr/bin/perl +# +# PROGRAM:get_gmi.pl - +# (1) acquires the GMI 1B and 1CR raw data ( about ~ 288 per day each ) +# (2) run gmi1cr_bufr.x +# (3) archives the BUFR files ( 1 per synoptic time) +# (4) "tar" the raw GMI files for one day "tar" files( 1B and 1CR) +# ( current day and pervious day) and archive them. + +# From Jianjun Jin Wargan - gmi1cr_bufr.x +# Utilities to write GMI(1CR) data into BUFR files + +# + +# +# +# 14 Octover 2014 Y. Kondratyeva + +# The setting of the options and the module lookup paths will +# be done first using the BEGIN subroutine. This section of the +# program executes before the rest of the program is even compiled. +# This way, a new path set via the -P option can be used to locate +# the modules to include at compile time while the remainder of the +# program is compiled. + + +BEGIN { + +# Keep track of errors within BEGIN block. + + $die_away = 0; +# Initialize output listing location + + $opt_O = 0; +# make env vars readily available +#-------------------------------- +use Env qw( FORT_CONVERT20 ); + + +# This module contains the getopts() subroutine. + + use Getopt::Std; + use Getopt::Long; + +# Get options and arguments + +# getopts('e:E:P:R:O:L:t:fab'); + + GetOptions ( 'e=s',\$opt_e, + 'E=s',\$opt_E, + 'P=s',\$opt_P, + 'R=s',\$opt_R, + 'O=s',\$opt_O, + 'L=s',\$opt_L, + 't=s',\$opt_t, + 'f',\$opt_f, + 'a',\$opt_a, + 'b',\$opt_b, + 'sched_cnfg=s',\$sched_cnfg, + 'sched_id=s',\$sched_id, + 'sched_synp=s',\$sched_synp, + 'sched_c_dt=s',\$sched_c_dt, + 'sched_dir=s',\$sched_dir, + 'sched_sts_fl=s',\$sched_sts_fl, + 'sched_hs=s',\$sched_hs ); +#If get_gmi is initiated by the scheduler, construct table +# info. for "task_state" table of scheduler + + if ( defined( $sched_id ) ) + { + $tab_status = 1; + $tab_argv = "$sched_cnfg, $sched_id, $sched_synp, $sched_c_dt"; + $fl_name = "get_gmi"; + $comd_wrt = "$sched_dir/utility/status"; + $args = "$fl_name COMPLETE $tab_argv $sched_dir"; + } + + + +# Processing environment + + if ( defined( $opt_e ) ) { + $env = $opt_e; + } else { + $env = "ops"; + } + +# The pre-processing configuration file. + + if ( defined( $opt_E ) ) { + $PREP_CONFIG_FILE = $opt_E; + } else { + $PREP_CONFIG_FILE = "DEFAULT"; + } + + print "INPUT PREP_CONFIG_FILE = $PREP_CONFIG_FILE\n"; + +# Lag time for real-time processing (for llk mode only) + + if ( defined( $opt_L ) ) { + $LAG_TIME = $opt_L; + } else { + $LAG_TIME = 3; + } + +# Path to directory containing other GEOS DAS programs. +# Directory $GEOSDAS_PATH/bin will be searched for these +# programs. + + if ( defined( $opt_P ) ) { + $GEOSDAS_PATH = $opt_P; + } else { + $GEOSDAS_PATH = "DEFAULT"; + } + +# Location of run-time configuration file. + + if ( defined( $opt_R ) ) { + $RUN_CONFIG_FILE = $opt_R; + } else { + $RUN_CONFIG_FILE = "DEFAULT"; + } + +# Location of run-time configuration file. + + if ( defined( $opt_t ) ) { + $syntime = $opt_t; + } else { + $syntime = "hd"; + } + + if ($syntime eq '0') { + $syntime = '00' ; + } + + + if ($syntime eq '6') { + $syntime = '06' ; + } + + + print + + + + +# ID for the preprocessing run. +# We only run for 'flk' + + +$prep_ID=flk; + + +# print "INPUT prep_ID = $prep_ID\n"; + + +# Location for output listings + + if ( $opt_O ) { + system ("mkdir -p $opt_O"); + if ( -w "$opt_O" ) { + $listing_file = "$opt_O/gmi_${prep_ID}.$$.listing"; + $listing_file_gz = "$opt_O/gmi_${prep_ID}.$$.listing_gz"; + + print "Standard output redirecting to $listing_file\n"; + open (STDOUT, ">$listing_file"); + open (STDERR, ">&" . STDOUT); + } + else { + print "$0: WARNING: $opt_O is not writable for listing.\n"; + } + }else{ + $listing_file = "STDOUT" + } + + +# Set usage flag. it is expected that +# llk will have no synoptic time in it's argument list. + + $u_flag = 0; + + + + if ( $#ARGV < 0 || $ARGV[0] eq 'help' ) { + + $u_flag = 1; + } + + if ( $u_flag == 1 ) { + print STDERR <<'ENDOFHELP'; +Usage: + + get_gmi.pl [-e] [-E Prep_Config] [-P GEOSDAS_Path] [-R Run_Config] [ -O output_location ] [-L lag_time ] [-t synoptic time] [ process_date ] + + Normal options and arguments: + + -e Processing environment (default = ops) + + -f Force flag.If no NETCDF data for a synoptic time, issue error, + but keep on processing.If no data on remote machine(rget) for + a synoptic time,or No input data for converter, - issue error, + but keep on processing. + + -d Force flag. If "wget" exit with error ,or no files(or size=0) + for yesterday or today day on remote machine(wget) + --> continue processing. + + -a ARCHIVE flag.If there is option "a",then we GZIP and ARCHIVE INPUT ORBIT FILES + + -b REBLOCK flag.If there is option "b",then we REBLOCK BUFR files before archive. + + + -O output_location + This is the full path to the output listings (both STDERR and STDOUT). + + -E Prep_Config + The full path to the preprocessing configuration file. This file contains + parameters needed by the preprocessing control programs. If not given, a + file named $HOME/$prep_ID/Prep_Config is used. get_gmi.pl exits with an + error if neither of these files exist. + + The parameters set from this file are + -t synoptic time + This is the synoptic time to process. + + + WORK_DIR + The top level working directory in which to run the preprocessing. A + subdirectory with the name of the preprocessing ID is made in this + directory (i.e., $WORK_DIR/$prep_ID/$process_date), and the work is done + there. + + + GMI_STAGE_DIR + The location in which to stage the BFR files for use by the DAS. + + GMI_ARCHIVE_LOC + The location in which to archive the BUFR and GMI input files. Files will be + stored in subdirectories according to their Sat_ID and valid date. As an + + GMI_ACQUIRE_MACH + This is ftp location for the raw native GMI + data. + + + GMI_ACQUIRE_PATH_1B + This is the file path template for the raw native GMI 1B + data. + + GMI_ACQUIRE_PATH_1CR + This is the file path template for the raw native GMI 1CR + data. + + + GMI_BUFR + This is the output BUFR filename template. + + + GMI_TABLE_DIR + Directory where bufr tables and other resource files used by the + processing are stored. + + Satellite identification tag for this run of the GMI pre-processing. + + prep_ID + Identification tag for this run of the GMI pre-processing. + + process_date + Date in YYYYMMDD format to process. If not given, then today's date (in + terms of GMT) will be processed. + + synoptic time + Synoptic time in hh format to process (00,06,12,18 or 0,6,12,18). If not given, then the whole day is processed ( $process date) + + Options useful in development mode. These are not necessary (and should not be + used) when running this program in the usual operational environment. + + -P GEOSDAS_Path + Path to directory containing other GEOS DAS programs. The path is + $GEOSDAS_PATH, where $GEOSDAS_PATH/bin is the directory containing these + programs. If -P GEOSDAS_Path is given, then other required programs not + found in the directory where this program resides will be obtained from + subdirectories in GEOSDAS_Path - the subdirectory structure is assumed + to be the same as the operational subdirectory structure. The default is + to use the path to the subdirectory containing this program, which is what + should be used in the operational environment. + + -R Run_Config + Name of file (with path name, if necessary) to read to obtain the + run-time (execution) configuration parameters. get_gmi.pl reads this + file to obtain configuration information at run time. + + If given, get_gmi.pl uses this file. Otherwise, get_gmi.pl looks for a + file named "Run_Config" in the user's home directory, then the + $GEOSDAS_PATH/bin directory. $GEOSDAS_PATH is given by the -P option if + set, or it is taken to be the parent directory of the directory in which this + script resides. It is an error if get_gmi.pl does not find this file, + but in the GEOS DAS production environment, a default Run_Config file is always + present in the bin directory. + + -L Lag Time + This option is to be used in llk real time mode only. This is the lag time, in + days, before the today date. + +ENDOFHELP + $die_away = 1; + } + + +# This module locates the full path name to the location of this file. Variable +# $FindBin::Bin will contain that value. + + use FindBin; + +# This module contains the dirname() subroutine. + + use File::Basename; + +# If default GEOS DAS path, set path to parent directory of directory where this +# script resides. + + if ( $GEOSDAS_PATH eq "DEFAULT" ) { + $GEOSDAS_PATH = dirname( $FindBin::Bin ); + } + +# Set name of the bin directory to search for other programs needed by this one. + + $BIN_DIR = "$GEOSDAS_PATH/bin"; + +# Get the name of the directory where this script resides. If it is different +# than BIN_DIR, then this directory will also be included in the list of +# directories to search for modules and programs. + + $PROGRAM_PATH = $FindBin::Bin; + +# Now allow use of any modules in the bin directory, and (if not the same) the +# directory where this program resides. (The search order is set so that +# the program's directory is searched first, then the bin directory.) + + if ( $PROGRAM_PATH ne $BIN_DIR ) { + @SEARCH_PATH = ( $PROGRAM_PATH, $BIN_DIR ); + } else { + @SEARCH_PATH = ( $BIN_DIR ); + } + +} # End BEGIN + +# Any reason to exit found during the BEGIN block? + +if ( $die_away == 1 ) { + exit 1; +} + +# Include the directories to be searched for required modules. + +use lib ( @SEARCH_PATH ); + +# Set the path to be searched for required programs. + +$ENV{'PATH'} = join( ':', @SEARCH_PATH, $ENV{'PATH'} ); + +# This module contains the extract_config() subroutine. +use Extract_config; + +# Archive utilities: gen_archive +use Arch_utils; + +# This module contains the z_time(), dec_time() and date8() subroutines. +use Manipulate_time; + +# Error logging utilities. +use Err_Log; + +# Record FAILED to schedule status file. +use Recd_State; + +# This module contains the mkpath() subroutine. + +use File::Path; +use File::Copy; + +# This module contains the rget() routine. + +use Remote_utils; + +# This module contains the julian_day subroutine. + +use Time::JulianDay; + +#Initialize exit status + +$exit_stat = 0; + +# Write start message to Event Log + +err_log (0, "get_gmi.pl", "$prep_ID","$env","-1", + {'err_desc' => "$prep_ID get_gmi.pl job running for has started - Standard output redirecting to $listing_file"}); + +# Use Prep_Config file under the preprocessing run's directory in the user's home directory +# as the default. + +if ( "$PREP_CONFIG_FILE" eq "DEFAULT" ) { + $PREP_CONFIG_FILE = "$ENV{'HOME'}/$prep_ID/Prep_Config"; +} + +# Does the Prep_Config file exist? If not, die. +if ( ! -e "$PREP_CONFIG_FILE" ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "error $PREP_CONFIG_FILE not found while running for ."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "error $PREP_CONFIG_FILE not found."; +} + +# If date given, use that, +# otherwise use today's date (GMT). + + + if ( $#ARGV >= 0 ) { + $process_date = date8( $ARGV[0] ); + } else { + +# Get current date (YYYYMMDD) in GMT, and set the process date to be +# $LAG_TIME days prior. + + $process_date = ( z_time() )[0]; + ($process_date, $process_time) = inc_time ($process_date, 0, -$LAG_TIME, 0); + } + +# The date strings in the error messages and on the listing files is a function of +# the mode we're running. + + $err_time = "${process_date}"; + + if ( $syntime eq 'hd') { + $err_time = "${process_date}"; + } else { + $err_time = "${process_date}.${syntime}z"; + } + + + + + +# Find the locations in which to stage and archive the BUFR files. +( $GMI_STAGE_DIR = extract_config( "GMI_STAGE_DIR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_STAGE_DIR configuration value\n"; + +# Get the location to archive GMI data( BUFR and INPUT) + +( $GMI_ARCHIVE_LOC = extract_config( "GMI_ARCHIVE_LOC", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_ARCHIVE_LOC configuration value\n"; + + +# Get the location, directory, and file names for the Input GMI data. + + ( $GMI_ACQUIRE_MACH = extract_config( "GMI_ACQUIRE_MACH", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_ACQUIRE_MACH configuration value\n"; + + +( $GMI_ACQUIRE_PATH_1B = extract_config( "GMI_ACQUIRE_PATH_1B", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_ACQUIRE_PATH_1B configuration value\n"; + +$template_path_1B=$GMI_ACQUIRE_PATH_1B ; + +( $GMI_ACQUIRE_PATH_1CR = extract_config( "GMI_ACQUIRE_PATH_1CR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_ACQUIRE_PATH_1CR configuration value\n"; + +$template_path_1CR=$GMI_ACQUIRE_PATH_1CR ; + + +# Get the name of the working directory for the observation preprocessing. + +( $GMI_WORK_DIR = extract_config( "GMI_WORK_DIR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_WORK_DIR configuration value\n"; + + +# Get the template name of TABLES + + ( $GMI_TABLE_DIR = extract_config( "GMI_TABLE_DIR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_TABLE_DIR configuration value\n"; + + +# Get the template for the output GMI bufr file. + +( $GMI_BUFR = extract_config( "GMI_BUFR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_BUFR configuration value\n"; + +$template_BUFR=$GMI_BUFR ; + + +# -------------------------------------- +# Assign - assigns file name to Fortran units. + +sub Assign { + + my ( $fname, $lu ) = @_; + + $f77name = "fort.$lu"; + unlink($f77name) if ( -e $f77name ) ; + symlink("$fname","$f77name"); + + } +# ------------------------------------- + + +#!/usr/bin/perl + +#-- SUBROUTINE GET GMI BY SYNOPTIC --------------------- +# Subroutine go through list of GMI files and sort them by synoptic time +# Write lists of files by synoptic time . +# Create array from names of files by synoptic time +# Return list of files,arrays of file's names and count of files by synoptic time + + +sub get_bysyn_gmi { + my ( $date_yesterday,$date_today ) = @_; + +# $date_yesterday,$date_today are in FORM YYYYMMDD + $k00= 0; + $k06= 0; + $k12= 0; + $k18= 0; + $list00 =' '; + $list06 =' '; + $list12 =' '; + $list18 =' '; + + + @lst_file00=''; + @lst_file06=''; + @lst_file12=''; + @lst_file18=''; + + +# Files for GMI 1B can be like + +# 0123456789012345678901234567890123456789012345678901 +# 1B.GPM.GMI.TB2014.20141006-S195647-E200145.V03B.RT-H5 + +# Files for GMI 1CR can be like + +# 0123456789012345678901234567890123456789012345678901 +# 1C-R.GPM.GMI.XCAL2014-N.20141006-S200147-E200645.V03B.RT-H5 +# ????????????????????// + +# FOR GMI 1B +# 0123456789012345678901234567890123456789012345678901 +# 1B.GPM.GMI.TB2014.20141006-S195647-E200145.V03B.RT-H5 + +# $date_current= =substr( $gos,18,8) ; +# $gap_stime=substr( $gos,28,2) ; +# $gap_etime=substr( $gos,36,2) ; + +# FOR GMI 1C-R +# 0123456789012345678901234567890123456789012345678901 +# 1C-R.GPM.GMI.XCAL2014-N.20141006-S200147-E200645.V03B.RT-H5 + +# $date_current= =substr( $gos,24,8) ; +# $gap_stime=substr( $gos,34,2) ; +# $gap_etime=substr( $gos,42,2) ; + + + + while ( defined($nextname = <1C-R.GPM.GMI.XCAL*>)) { + + $nextname =~s#.*/##; # remove part before last slash + + $gos ="$nextname"; + +#=================================== +# FOR GMI 1C-R +# 0123456789012345678901234567890123456789012345678901 +# 1C-R.GPM.GMI.XCAL2014-N.20141006-S200147-E200645.V03B.RT-H5 + + $date_current =substr( $gos,24,8) ; + $gap_time=substr( $gos,34,3) ; + + + + if ( $date_current == $date_yesterday) { + +# S200147 ==> $gap_time = 200 +# S030147 ==> $gap_time = 030 +# 0z Yesterday Current time >= 205 +# TODAY Current time < 30 ( time < 030) + + if ($gap_time >= 205 ) { + + $list00='$list00 $nextname'; + $lst_file00 [$k00] = $nextname ; + $k00= $k00 +1; + + } + +# end of date_yesterday + } + + if ( $date_current == $date_today) { + + if ( $gap_time < 30) { + $list00='$list00 $nextname'; + $lst_file00 [$k00] = $nextname ; + $k00= $k00 +1; + } + + +# 6z Current time >= 25 ( time = 025) +# Current time < 90 ( time < 090) + + if ( $gap_time < 90 && $gap_time >= 25 ) { + + $list06="$list06 $nextname"; + $lst_file06 [$k06] = $nextname ; + $k06= $k06 +1; + } + +# 12z Current time >= 085( time =085) +# Current time < 150 + + + if ( $gap_time < 150 && $gap_time >= 85) { + + + $list12="$list12 $nextname"; + $lst_file12 [$k12] = $nextname ; + $k12= $k12 +1; + } + +# 12z Current time >= 145 +# Current time < 210 + + if ( $gap_time < 210 && $gap_time >= 145) { + $list18="$list18 $nextname"; + $lst_file18 [$k18] = $nextname ; + $k18= $k18 +1; + } + +# end of today +} + +# END LOOP BY inlist ( input files) + } + + + return ($k00,$k06,$k12,$k18,$lst_file00,$lst_file06,$lst_file12,$lst_file18,$list00,$list06,$list12,$list18); + + } + +#--END OF SUBROUTINE GET BY SYNOPTIC --------------------- +# --------------------------------------- + + +# --------------------------------------- + +############################################ +# MAKE WORK_DIR +################################################################ +# Get the work path and Make it. (mkpath default mode is 0777, which is what we want.) + + +# Change into WORK directory it. and clean it + + + +# ********************************************************** + + $gmi_work="$GMI_WORK_DIR/$prep_ID/${process_date}"; + +if ( ! -d ${gmi_work} ) { + + unless (defined eval {mkpath( "${gmi_work}" )}) + { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "Fatal Error: Unable to make directory ${gmi_work}."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Cannot make ${gmi_work}"; + } +} + + +# Change into WORK directory it. + + chdir "${gmi_work}" or die "Cannot cd to ${gmi_work}: $!\n"; + + + $rc=system("rm -f * "); + +# ********************************************************** +# Make STAGE directories if they don't already exist. + + + + +if ( ! -d "$GMI_STAGE_DIR" ) { +# mkpath( "$STAGE_DIR" ) or die "Cannot make $STAGE_DIR"; + + unless (defined eval {mkpath( "${GMI_STAGE_DIR}" )}) + { + err_log (4, "get_gmi.pl", "$err_time","-1", + {'err_desc' => "Fatal Error: Unable to make directory ${GMI_STAGE_DIR}."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Cannot make ${GMI_STAGE_DIR}"; + } + +} + + + +################################################################ + + +# ----------------------------------------------- +# Started to ftp input GMI 1B files , run +# ----------------------------------------------- + +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). +# First we'll get the list of today's file. + + + ( $process_date_m1, $current_time ) = inc_time ($process_date, $current_time, -1, 0); + +# ----------------------------------------------- +# Started to ftp input GMI 1B files , run +# ----------------------------------------------- + +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). +# First we'll get the list of today's file. + +###################################################### +# GMI 1B +# Get files GMI 1B for TODAY +################################################## + $GMI_ACQUIRE_PATH=$template_path_1B; + $GMI_ACQUIRE_PATH =token_resolve("${GMI_ACQUIRE_PATH}",$process_date); + print "POPALI INPUT GMI_ACQUIRE_PATH = $GMI_ACQUIRE_PATH \n"; + + +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + +# Paste the array back together into a string leaving off the filename. + +${GMI_ACQUIRE_DIR} = join('/',@list[0 .. $list_len-2]); + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + + $filename="${GMI_ACQUIRE_FILE}"; + $filename_today_1B = $filename ; + print "POPALI INPUT LIST filename = $filename\n"; +# pppppppppppppppppppppppppppppppppppppppppppppppppppppppp + +# Check - from where to take Input files. + + if ($GMI_ACQUIRE_MACH eq 'MISS' ) { + + ${need_file_1B} = '1B.GPM.GMI.TB2015' ; +# Copy Input files from Karki's directory. + $rc=system("cp $GMI_ACQUIRE_PATH . "); + + } + else { + + # Copy (rget) Input files from ftp site . + + # Get the list of files available on the remote server and then grab those files. + #- for current day - can be 288 files + + + + + print "Calling rflist: $GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename\n"; + chomp(@remote_list_today=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename")); + + # print " remote_list_today = @remote_list_today .\n"; + + $remote_list_today_len=@remote_list_today; + print " LENGHT remote_list_today = $remote_list_today_len .\n"; + + + #Check to see if there is file to grab + if ($remote_list_today_len > 0){ + + + $i=0; + + $need_file_1B = $remote_list_today[$i]; + + print " NADONADO 1-i FILE remote_list_today = $remote_list_today[i] \n"; + + +# print $remote_list_today[$i] + while ($i < $remote_list_today_len ){ + + $remote_namepath="$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$remote_list_today[$i]"; + + + $remote_list_today_len=@remote_list_today; + + $rget_retcode = rget("$remote_namepath", "$remote_list_today[$i]", + {'debug' => "1",'run_config' => "$RUN_CONFIG_FILE" }); + + if( $rget_retcode != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "Error: rget ftp failed trying to get $remote_list_today[$i] from $remote_namepath."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: rget ftp failed trying to get $remote_list_today[$i] from $remote_namepath. "; + } + + #--VOTVOT------------------------ + + # end if $i < $remote_list_today_len + $i=$i+1; + } + + } + # If NO FILE for today , $remote_list_today_len <= 0 + else { + + # if ($remote_list_today_len <= 0) + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "NON-Fatal Warning: There are no files available on the remote machine for processing GMI 1B on $process_date."}); + $archive_err ++; + + print "POPALI UJAS 10 remote_list_today_len = $remote_list_today_len\n"; + if ( ! $opt_f ) { + # print "STOP : NO OPTION F \n"; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: There be no INPUT data available for date: $process_date . This error occurred while processing GMI 1B data ."; + } + + } + +# END of Check - from where to take Input files. + } +# pppppppppppppppppppppppppppppppppppp +################################################################ + + +# ----------------------------------------------- +# Started to cp input GMI 1CR files +# ----------------------------------------------- + +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). +# First we'll get the list of today's file. + +###################################################### +# GMI 1CR +# Get files GMI 1CR for TODAY +################################################## + $GMI_ACQUIRE_PATH=$template_path_1CR; + $GMI_ACQUIRE_PATH =token_resolve("${GMI_ACQUIRE_PATH}",$process_date); + + +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + +# Paste the array back together into a string leaving off the filename. + +${GMI_ACQUIRE_DIR} = join('/',@list[0 .. $list_len-2]); + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + + $filename="${GMI_ACQUIRE_FILE}"; + $filename_today_1CR = $filename ; + + print "POPALI INPUT LIST filename = $filename\n"; + +# pppppppppppppppppppppppppppppppppppppppppppppppppppppppp + +# Check - from where to take Input files. + + if ($GMI_ACQUIRE_MACH eq 'MISS' ) { + +# Copy Input files from Karki's directory. + $rc=system("cp $GMI_ACQUIRE_PATH . "); + + } + else { + +# Copy (rget) Input files from ftp site . + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + + + print "Calling rflist: $GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename\n"; + chomp(@remote_list_today=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename")); + +# print " remote_list_today = @remote_list_today .\n"; + +$remote_list_today_len=@remote_list_today; + print " LENGHT remote_list_today = $remote_list_today_len .\n"; + + +#Check to see if there is file to grab +if ($remote_list_today_len > 0){ + +$i=0; + $need_file_1CR = $remote_list_today[$i]; + while ($i < $remote_list_today_len ){ + + $remote_namepath="$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$remote_list_today[$i]"; + + +$remote_list_today_len=@remote_list_today; + + $rget_retcode = rget("$remote_namepath", "$remote_list_today[$i]", + {'debug' => "1",'run_config' => "$RUN_CONFIG_FILE" }); + + if( $rget_retcode != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "Error: rget ftp failed trying to get $remote_list_today[$i] from $remote_namepath."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: rget ftp failed trying to get $remote_list_today[$i] from $remote_namepath. "; + } + + +# end if $i < $remote_list_today_len + $i=$i+1; + } + +} +# If NO FILE for today , $remote_list_today_len <= 0 + else { + +# if ($remote_list_today_len <= 0) + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "NON-Fatal Warning: There are no files available on the remote machine for processing GMI 1CR on $process_date."}); + $archive_err ++; + + print "POPALI UJAS 10 remote_list_today_len = $remote_list_today_len\n"; + if ( ! $opt_f ) { + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: There be no INPUT data available for date: $process_date . This error occurred while processing GMI 1CR data ."; + } + + } + +# END of Check - from where to take Input files. +# ????? + } +# ========================================== + + ( $process_date_m1, $current_time ) = inc_time ($process_date, $current_time, -1, 0); + +# 444444444444444444444444444444444444444444444444444444444444444 + if ( ($syntime eq '00') or ($syntime eq 'hd')) { +# If we have to get 0z , or the whole day ( syntime='00',or='0', or syntime = 'hd') +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). + + +################################################################ + + +# THEN we'll get the list of yesterday's file. + +###################################################### +# GMI 1B +# Get files GMI 1B for YESTERDAY +################################################## +( $process_date_m1, $current_time ) = inc_time ($process_date, $current_time, -1, 0); + + + $GMI_ACQUIRE_PATH=$template_path_1B; + $GMI_ACQUIRE_PATH =token_resolve("${GMI_ACQUIRE_PATH}",$process_date_m1); + + +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + +# Paste the array back together into a string leaving off the filename. + +${GMI_ACQUIRE_DIR} = join('/',@list[0 .. $list_len-2]); + +# Get the list of files available on the remote server and then grab those files. +#- for a day - can be 288 files + + $filename="${GMI_ACQUIRE_FILE}"; + $filename_yesterday_1B = $filename ; + print "POPALI INPUT LIST filename = $filename\n"; + +# pppppppppppppppppppppppppppppppppppppppppppppppppppppppp + +# Check - from where to take Input files. + + if ($GMI_ACQUIRE_MACH eq 'MISS' ) { + +# Copy Input files from Karki's directory. + + $rc=system("cp $GMI_ACQUIRE_PATH . "); + + } + else { +# Copy (rget) Input files from ftp site . + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + + + print "POPALI GMI_ACQUIRE_DIR = $GMI_ACQUIRE_DIR \n"; + + print "Calling rflist: $GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename\n"; + chomp(@remote_list_yesterday=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename")); + +# print " remote_list_yesterday = @remote_list_yesterday .\n"; + +$remote_list_yesterday_len=@remote_list_yesterday; + print " LENGHT remote_list_yesterday = $remote_list_yesterday_len .\n"; + + +#Check to see if there is file to grab +if ($remote_list_yesterday_len > 0){ + +$i=0; + $need_file_1B = $remote_list_yesterday[$i]; + while ($i < $remote_list_yesterday_len ){ + + $remote_namepath="$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$remote_list_yesterday[$i]"; + + +$remote_list_yesterday_len=@remote_list_yesterday; + + $rget_retcode = rget("$remote_namepath", "$remote_list_yesterday[$i]", + {'debug' => "1",'run_config' => "$RUN_CONFIG_FILE" }); + + if( $rget_retcode != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "Error: rget ftp failed trying to get $remote_list_yesterday[$i] from $remote_namepath."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: rget ftp failed trying to get $remote_list_yesterday[$i] from $remote_namepath. "; + } + + +# end if $i < $remote_list_yesterday_len + $i=$i+1; + } + +} +# If NO FILE for yesterday , $remote_list_yesterday_len <= 0 + else { + +# if ($remote_list_yesterday_len <= 0) + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "NON-Fatal Warning: There are no files available on the remote machine for processing GMI 1B on $process_date_m1."}); + $archive_err ++; + + print "POPALI UJAS 10 remote_list_yesterday_len = $remote_list_yesterday_len\n"; + if ( ! $opt_f ) { + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: There be no INPUT data available for date: $process_date_m1 . This error occurred while processing GMI 1B data ."; + } + + } + +# END of Check - from where to take Input files. +# ????? + } + + + +#44444444444444444444444444444444444444444444444444444444444 + + +# 444444444444444444444444444444444444444444444444444444444444444 +# If we have to get 0z , or the whole day ( syntime = '00', or syntime = 'hd') +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). + + +################################################################ + + +# THEN we'll get the list of yesterday's file. + +###################################################### +# GMI 1CR +# Get files GMI 1CR for YESTERDAY +################################################## + $GMI_ACQUIRE_PATH=$template_path_1CR; + $GMI_ACQUIRE_PATH =token_resolve("${GMI_ACQUIRE_PATH}",$process_date_m1); + + +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + +# Paste the array back together into a string leaving off the filename. + +${GMI_ACQUIRE_DIR} = join('/',@list[0 .. $list_len-2]); + +# Get the list of files available on the remote server and then grab those files. +#- for a day - can be 288 files + + $filename="${GMI_ACQUIRE_FILE}"; + $filename_yesterday_1CR = $filename ; + print "POPALI INPUT LIST filename = $filename\n"; +# pppppppppppppppppppppppppppppppppppppppppppppppppppppppp + +# Check - from where to take Input files. + + if ($GMI_ACQUIRE_MACH eq 'MISS' ) { + +# Copy Input files from Karki's directory. + + $rc=system("cp $GMI_ACQUIRE_PATH . "); + + } + else { +# Copy (rget) Input files from ftp site . + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + + + print "Calling rflist: $GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename\n"; + chomp(@remote_list_yesterday=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename")); + +# print " remote_list_yesterday = @remote_list_yesterday .\n"; + +$remote_list_yesterday_len=@remote_list_yesterday; + print " LENGHT remote_list_yesterday 1CR = $remote_list_yesterday_len .\n"; + + +#Check to see if there is file to grab +if ($remote_list_yesterday_len > 0){ + +$i=0; + $need_file_1CR = $remote_list_yesterday[$i]; + while ($i < $remote_list_yesterday_len ){ + + $remote_namepath="$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$remote_list_yesterday[$i]"; + + +$remote_list_yesterday_len=@remote_list_yesterday; +# print "POPALI UJAS 4 remote_list_yesterday_len = $remote_list_yesterday_len\n"; + + $rget_retcode = rget("$remote_namepath", "$remote_list_yesterday[$i]", + {'debug' => "1",'run_config' => "$RUN_CONFIG_FILE" }); + + if( $rget_retcode != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "Error: rget ftp failed trying to get $remote_list_yesterday[$i] from $remote_namepath."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: rget ftp failed trying to get $remote_list_yesterday[$i] from $remote_namepath. "; + } + +# end if $i < $remote_list_yesterday_len + $i=$i+1; + } + +} +# If NO FILE for yesterday , $remote_list_yesterday_len <= 0 + else { + +# if ($remote_list_yesterday_len <= 0) + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "NON-Fatal Warning: There are no files available on the remote machine for processing GMI 1CR on $process_date_m1."}); + $archive_err ++; + + print "POPALI UJAS 10 remote_list_yesterday_len = $remote_list_yesterday_len\n"; + if ( ! $opt_f ) { +# print "STOP : NO OPTION F \n"; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: There be no INPUT data available for date: $process_date_m1 . This error occurred while processing GMI 1CR data ."; + } + + } +# END of Check - from where to take Input files. + } +# ppppppppppppppppppppppppppppppppppppppppppppp + +# End if we need the yesterday files + + } +#44444444444444444444444444444444444444444444444444444444444 + +# ======================================================= + +# $date_today = $process_date ; +# $date_yesterday = $process_date_m1 ; + + get_bysyn_gmi ( $process_date_m1,$process_date); + +# print "KONEZ m= is $m\n"; + + print "AFTER get_bysyn k00= is $k00\n"; + print "AFTER get_bysyn k06= is $k06\n"; + + print "AFTER get_bysyn k12= is $k12\n"; + print "AFTER get_bysyn k18= is $k18\n"; + + +# print "AFTER get_bysyn list00= is $list00\n"; +# print "AFTER get_bysyn lst_file06 = @lst_file06 \n"; + +# print "AFTER get_bysyn lst_file06 (0) = @lst_file06[$kk0]\n"; +# print "AFTER get_bysyn lst_file06 (1) = @lst_file06[$kk1]\n"; +# print "AFTER get_bysyn lst_file06 (2) = @lst_file06[$kk2]\n"; +# print " \n"; +# print "AFTER get_bysyn lst_file06 (3) = @lst_file06[$kk3]\n"; + + + +########################## +# Copy BUFR TABLE for GMI +########################### + $rc=system("cp $GMI_TABLE_DIR/GMI_bufr_table_1CR ${gmi_work} "); +########################## + + + + if ( $syntime eq 'hd') { + + @synlist = ( '00', '06', '12', '18') ; + + + } else { + @synlist = ($syntime) ; + + } + + print "synlist = $synlist\n"; + + + + $synlist_len=@synlist; +if ($synlist_len > 0){ +$i=0; + while ($i < $synlist_len ){ + + $synhour = $synlist[$i] ; + + print "synhour = $synhour\n"; + + +# gmi_L1CR.20140918.t12z.bufr + $daily_bufr=token_resolve("$template_BUFR",$process_date,$synhour ); + print " POSCHITALI daily_bufr = $daily_bufr\n"; + + + if ( $synhour eq '00') { + $knum = $k00; + $clist =$list00; + @lst_file = @lst_file00 ; + } + + if ( $synhour eq '06') { + $knum = $k06; + $clist =$list06; + @lst_file = @lst_file06 ; + } + + + if ( $synhour eq '12') { + $knum = $k12; + $clist =$list12; + @lst_file = @lst_file12 ; + } + + + if ( $synhour eq '18') { + $knum = $k18; + $clist =$list18; + @lst_file = @lst_file18 ; + } + +# print "NADO knum= is $knum\n"; + $nol = 0; + + + if ( $knum > $nol ) { +$inum=0; + + while ($inum < $knum ){ + +# $need_file = $lst_file[$inum] ; +# $rc=system("gmi1cr_bufr.x -d $process_date -t $synhour -f $need_file"); + + $rc=system("gmi1cr_bufr.x -d $process_date -t $synhour -f $lst_file[$inum]"); + + + + +if ($rc != 0) { + + print " WARNING:error running gmi1cr_bufr.x for $process_date synoptic $synhour. \n"; + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "WARNING :error running gmi1cr_bufr.x for $process_date synoptic $synhour"}); + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + + + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "error running gmi1cr_bufr.x for $process_date synoptic $synhour"}); + + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: error running gmi1cr_bufr.x data for date: $process_date and for time: $synhour . This error occurred while processing GMI data ."; + } + + } + + + + + $inum = $inum + 1; +# end for number of files + } +# if knum >0 + } + else { + + print " WARNING: NO input GMI data for $process_date synoptic $synhour. \n"; + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "WARNING :NO input GMI data for $process_date synoptic $synhour"}); + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "NO input GMI data for $process_date synoptic $synhour"}); + + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: NO input GMI data for date: $process_date and for time: $synhour . This error occurred while processing GMI data ."; + } + + } + + +#----------------------------------------------------------------------------- +# BEGIN copy and archive daily_bufr copy and archive daily_bufr copy and archive daily_bufr +# for $process_date , $synhour +#----------------------------------------------------------------------------- + +# From Jianjun +# if ( $size == 1654 || $size == 1697 || $size == 1840 || $size == 1883 || $size == 1926 ) + + $min_size = 2000 ; +# if (! -e "$daily_bufr" || -z "$daily_bufr") + $filesize = -s $daily_bufr ; + if (! -e "$daily_bufr" || -z "$daily_bufr" || "$filesize" < $min_size ) { + print "$daily_bufr DOES NOT EXIST\n"; + + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "WARNING: $daily_bufr was NOT created,or is zero bytes,or size less than min size. There may be no data available for date: $process_date and for times: $synhour . This error occurred while processing GMI data ."}); + + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "Error: $daily_bufr was NOT created,or is zero bytes,or size less than min size. There may be no data available for date: $process_date and for times: $synhour . This error occurred while processing GMI data ."}); + + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: $daily_bufr was NOT created or is small size while running for GMI . "; + } + + } + else { + print "$daily_bufr exists. Will copy\n"; +# Copy into STAGE_DIR + $rc=system("cp $daily_bufr $GMI_STAGE_DIR"); + + if ($rc != 0) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "error copying daily_bufr file $daily_bufr."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "error copying daily_bufr file $daily_bufr."; + } + +# --------------------------------------------- +# Archive $daily_bufr +#--------------------------------------------------- + + +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/bufr/Y%y4/M%m2/",$process_date); +# $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'bufr', "$process_date", +# "$archive_dir", "$daily_bufr", { 'verbose' => "$verbose" ,'exp_path' => "1" } ); + + + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'bufr', "$process_date", + "${GMI_ARCHIVE_LOC}", "$daily_bufr", { 'verbose' => "$verbose" } ); + + + + if ($rc != 1) { + print " WARNING: Could not archive $daily_bufr . \n"; + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "WARNING :could not archive $daily_bufr"}); + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "could not archive $daily_bufr"}); + + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: could not archive $daily_bufr for date: $process_date and for time: $synhour . This error occurred while processing GMI data ."; + } + } + +#----------------------------------------------------------------------------- +# END copy and archive daily_bufr copy and archive daily_bufr copy and archive daily_bufr +#----------------------------------------------------------------------------- + +# end for else daily_bufr exist + } + + + +############################### + +# end for foreach $synhour + $i=$i+1; + } +# if synlist > 0 + } + + + + +######################## +# create TAR files from raw GMI 1B files for $process date and previous date +# and archive them +######################## +# 01234567890123456789012345 +# 1B.GPM.GMI.TB2014.20140416-S113146-E113644.V01D.RT-H5 +# 1C-R.GPM.GMI.XCAL2014-N.20140416-S113146-E113644.V01D.RT-H5 + +# 03/17/2016 New name for HDF files +# 1C-R.GPM.GMI.XCAL2015-C.20160308-S235640-E000138.V04A.RT-H5 NEW HDF NAME +# 1B.GPM.GMI.TB2015.20160313-S000140-E000638.V04A.RT-H5 - NEW HDF Name + + + +# $tar_name_1B=substr( ${filename_today_1B},0,18) ; +# $tar_name_1CR=substr( ${filename_today_1CR},0,24) ; +#--------------------------------------------------------- + + if (( $k00 + $k06 + $k12 +$k18) > 0 ) { + + $inum = 0; + if ( $k00 >0) { + $need_name_1CR = $lst_file00[$inum]; + } + if ( $k06 >0) { + $need_name_1CR = $lst_file06[$inum]; + } + + if ( $k12 >0) { + $need_name_1CR = $lst_file00[$inum]; + } + if ( $k18 >0) { + $need_name_1CR = $lst_file06[$inum]; + } + + + } + + +# if ( $synhour eq '18') +# $knum = $k18; +# $clist =$list18; +# @lst_file = @lst_file18 ; +# + +# $need_file_1CR = $lst_file[$inum] ; + + $tar_name_1CR=substr( ${need_name_1CR},0,24) ; + + print " POBEDA: need_file_1CR $need_file_1CR . \n"; + + print " POBEDA: need__name_1CR $need_name_1CR . \n"; + print " POBEDA: tar_name_1CR $tar_name_1CR . \n"; + + + $tar_name_1B=substr( ${need_file_1B},0,18) ; + print " POBEDA: need_file_1B $need_file_1B . \n"; + print " POBEDA: tar_name_1B $tar_name_1B . \n"; + + +#----------------------------------------------------------- + +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/native/1B/Y%y4/M%m2/",$process_date); + + $tar_name =token_resolve("${tar_name_1B}%y4%m2%d2.he5.tar",$process_date); + + print " iCHTORAT archive_dir = $archive_dir \n"; + print " iCHTORAT tar_name = $tar_name \n"; + print " iCHTORAT filename_today_1B = ${filename_today_1B} \n"; + +# TAR Input Raw files for current day + $rc=system(" tar -cvf ${tar_name} ${filename_today_1B} "); +# Archive TAr file for current day + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'native', "$process_date", + "$GMI_ARCHIVE_LOC", "$tar_name", { 'subtype' => "1B", 'verbose' => "$verbose" } ); + + if ($rc != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "could not archive $tar_name while running for GMI "}); + print "WARNING: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "could not archive $tar_name while running for GMI"}); + print "ERROR: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + + + die "Error: could not archive $tar_name for date: $process_date . This error occurred while processing GMI data ."; + } + } + + + +######################## +# create TAR files from raw GMI 1CR files for $process date and previous date +# and archive them +######################## + +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/native/1CR/Y%y4/M%m2/",$process_date); +# 1C-R.GPM.GMI.XCAL2014-N.20140924-S085646-E090144.V03B.RT-H5 +# $tar_name =token_resolve("1C-R.GPM.GMI.XCAL_%y4m%m2%d2.he5.tar",$process_date); + $tar_name =token_resolve("${tar_name_1CR}%y4%m2%d2.he5.tar",$process_date); + + print " iCHTORAT archive_dir = $archive_dir \n"; + print " iCHTORAT tar_name = $tar_name \n"; + print " iCHTORAT filename_today_1CR = ${filename_today_1CR} \n"; + +# TAR Input Raw files for current day + $rc=system(" tar -cvf ${tar_name} ${filename_today_1CR} "); +# Archive TAr file for current day + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'native', "$process_date", + "$GMI_ARCHIVE_LOC", "$tar_name", { 'subtype' => "1CR",'verbose' => "$verbose" } ); + + if ($rc != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "could not archive $tar_name while running for GMI "}); + print "WARNING: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "could not archive $tar_name while running for GMI"}); + print "ERROR: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + + + die "Error: could not archive $tar_name for date: $process_date . This error occurred while processing GMI data ."; + } + } + +# 444444444444444444444444444444444444444444444444444444444444444 + if ( ($syntime eq '00') or ($syntime eq 'hd')) { +# If we have to get 0z , or the whole day ( syntime = '00', or syntime = 'hd') +# then we have files from the previous day to create TAR file for yesterday +# $tar_name_1B=substr( ${filename_yesterday_1B},0,18) ; +# $tar_name_1CR=substr( ${filename_yesterday_1CR},0,24) ; + + +################################## +# Tar files fot 1B for yesterday +################################## + +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/native/1B/Y%y4/M%m2/",$process_date_m1); +# $tar_name =token_resolve("1B.GMI-Aura_L2-OMTO3_%y4m%m2%d2.he5.tar",$process_date_m1); + + $tar_name =token_resolve("${tar_name_1B}%y4%m2%d2.he5.tar",$process_date_m1); + + print " aCHTORAT archive_dir = $archive_dir \n"; + print " aCHTORAT tar_name = $tar_name \n"; + print " aCHTORAT filename_yesterday_1B = ${filename_yesterday_1B} \n"; + + +# TAR Input Raw files for previous day + $rc=system(" tar -cvf ${tar_name} ${filename_yesterday_1B} "); +# Archive TAR file for previous day + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'native', "$process_date_m1", + "$GMI_ARCHIVE_LOC", "$tar_name", { 'subtype' => "1B", 'verbose' => "$verbose" } ); + + if ($rc != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "could not archive $tar_name while running for GMI "}); + print "WARNING: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "could not archive $tar_name while running for GMI"}); + print "ERROR: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + + + die "Error: could not archive $tar_name for date: $process_date_m1 . This error occurred while processing GMI data ."; + } + } + + + +##################################### +# Tar files 1CR for yesterday +##################################### +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/native/1CR/Y%y4/M%m2/",$process_date_m1); + $tar_name=token_resolve("${tar_name_1CR}%y4%m2%d2.he5.tar",$process_date_m1); + + print " aCHTORAT archive_dir = $archive_dir \n"; + print " aCHTORAT tar_name = $tar_name \n"; + print " aCHTORAT filename_yesterday_1CR = ${filename_yesterday_1CR} \n"; + + +# TAR Input Raw files for previous day + $rc=system(" tar -cvf ${tar_name} ${filename_yesterday_1CR} "); +# Archive TAR file for previous day + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'native', "$process_date_m1", + "$GMI_ARCHIVE_LOC", "$tar_name", { 'subtype' => "1CR", 'verbose' => "$verbose" } ); + + if ($rc != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "could not archive $tar_name while running for GMI "}); + print "WARNING: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "could not archive $tar_name while running for GMI"}); + print "ERROR: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + + + die "Error: could not archive $tar_name for date: $process_date_m1 . This error occurred while processing GMI data ."; + } + + } + + } + + + +######################## +# Rename output listings +######################## + +if ( $opt_O ) { + + print "THERE ARE OPTION O. Will copy Listing\n"; + + unlink<"$listing_file_gz">; + system ( "gzip -c $listing_file > $listing_file_gz" ); + + $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/listing/Y%y4/M%m2/",$process_date); + $rc=gen_archive ( "$env","$prep_ID",'gmi','listing', "$process_date", + "$GMI_ARCHIVE_LOC", $listing_file_gz, + { 'remote_name' => "gmi_${prep_ID}.$err_time.listing.gz", + 'delete' => "1", + 'verbose' => "1" } ); + + if ( $rc != 1 ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", {'err_desc' => "could not archive listing file gmi_${prep_ID}.$err_time.listing.gz"}); + print "WARNING: could not archive listing file gmi_${prep_ID}.$err_time.listing.gz \n"; + $archive_err ++; + } + +} +if ( $archive_err ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "get_gmi.pl: exiting with errors"}); +}else{ + err_log (0, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "get_gmi.pl: exiting normally"}); +} +if ( $opt_O ) { + system ("mv $listing_file $opt_O/gmi_${prep_ID}.${err_time}.listing"); +} +############################ +# Clean up working directory +############################ + + $rc=system("/bin/rm -rf ${gmi_work}"); + + + if ($rc != 0) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "WARNING: could not remove ${gmi_work}"}); + print "WARNING: could not remove ${gmi_work}\n"; + } + + + + + recd_state( $fl_name, "COMPLETE", $tab_argv, $sched_dir, $sched_sts_fl ); +exit 0; + + diff --git a/util/GMI_BUFR_gen/gmi/perl/get_gmi.pl b/util/GMI_BUFR_gen/gmi/perl/get_gmi.pl new file mode 100755 index 000000000..b6571f0d3 --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/perl/get_gmi.pl @@ -0,0 +1,1837 @@ +#!/usr/bin/perl +# +# PROGRAM:get_gmi.pl - +# (1) acquires the GMI 1B and 1CR raw data ( about ~ 288 per day each ) +# (2) run gmi1cr_bufr.x +# (3) archives the BUFR files ( 1 per synoptic time) +# (4) "tar" the raw GMI files for one day "tar" files( 1B and 1CR) +# ( current day and pervious day) and archive them. + +# From Jianjun Jin Wargan - gmi1cr_bufr.x +# Utilities to write GMI(1CR) data into BUFR files + +# + +# +# +# 14 Octover 2014 Y. Kondratyeva + +# The setting of the options and the module lookup paths will +# be done first using the BEGIN subroutine. This section of the +# program executes before the rest of the program is even compiled. +# This way, a new path set via the -P option can be used to locate +# the modules to include at compile time while the remainder of the +# program is compiled. + +# 14 December 2015 Y. Kondratyeva +# If 'GMI_ACQUIRE_MACH' = MISS in Prep_Config.GET-GMI file , then we cp Input data +# from Karki's directory. + + +# 4 April 2016 Y. Kondratyeva +# New Option "-g" added. +# if defined $opt_g --> $passive = 0 and transferred into Remote_utils.pm +# in order go ahead if No Input data found. + + +BEGIN { + +# Keep track of errors within BEGIN block. + + $die_away = 0; +# Initialize output listing location + + $opt_O = 0; +# make env vars readily available +#-------------------------------- +use Env qw( FORT_CONVERT20 ); + + +# This module contains the getopts() subroutine. + + use Getopt::Std; + use Getopt::Long; + +# Get options and arguments + +# getopts('e:E:P:R:O:L:t:fab'); + + GetOptions ( 'e=s',\$opt_e, + 'E=s',\$opt_E, + 'P=s',\$opt_P, + 'R=s',\$opt_R, + 'O=s',\$opt_O, + 'L=s',\$opt_L, + 't=s',\$opt_t, + 'f',\$opt_f, + 'a',\$opt_a, + 'b',\$opt_b, + 'g',\$opt_g, + 'sched_cnfg=s',\$sched_cnfg, + 'sched_id=s',\$sched_id, + 'sched_synp=s',\$sched_synp, + 'sched_c_dt=s',\$sched_c_dt, + 'sched_dir=s',\$sched_dir, + 'sched_sts_fl=s',\$sched_sts_fl, + 'sched_hs=s',\$sched_hs ); +#If get_gmi is initiated by the scheduler, construct table +# info. for "task_state" table of scheduler + + if ( defined( $sched_id ) ) + { + $tab_status = 1; + $tab_argv = "$sched_cnfg, $sched_id, $sched_synp, $sched_c_dt"; + $fl_name = "get_gmi"; + $comd_wrt = "$sched_dir/utility/status"; + $args = "$fl_name COMPLETE $tab_argv $sched_dir"; + } + + + +# Processing environment + + if ( defined( $opt_e ) ) { + $env = $opt_e; + } else { + $env = "ops"; + } + +# The pre-processing configuration file. + + if ( defined( $opt_E ) ) { + $PREP_CONFIG_FILE = $opt_E; + } else { + $PREP_CONFIG_FILE = "DEFAULT"; + } + + print "INPUT PREP_CONFIG_FILE = $PREP_CONFIG_FILE\n"; + +# Lag time for real-time processing (for llk mode only) + + if ( defined( $opt_L ) ) { + $LAG_TIME = $opt_L; + } else { + $LAG_TIME = 3; + } + +# Path to directory containing other GEOS DAS programs. +# Directory $GEOSDAS_PATH/bin will be searched for these +# programs. + + if ( defined( $opt_P ) ) { + $GEOSDAS_PATH = $opt_P; + } else { + $GEOSDAS_PATH = "DEFAULT"; + } + +# Location of run-time configuration file. + + if ( defined( $opt_R ) ) { + $RUN_CONFIG_FILE = $opt_R; + } else { + $RUN_CONFIG_FILE = "DEFAULT"; + } + +# Location of run-time configuration file. + + if ( defined( $opt_t ) ) { + $syntime = $opt_t; + } else { + $syntime = "hd"; + } + + if ($syntime eq '0') { + $syntime = '00' ; + } + + + if ($syntime eq '6') { + $syntime = '06' ; + } + + + +# Processing environment + + if ( defined( $opt_g ) ) { + $passive = 0 ; + } else { + $passive = 1 ; + } + + + + +# ID for the preprocessing run. +# We only run for 'flk' + + +$prep_ID=flk; + + +# print "INPUT prep_ID = $prep_ID\n"; + + +# Location for output listings + + if ( $opt_O ) { + system ("mkdir -p $opt_O"); + if ( -w "$opt_O" ) { + $listing_file = "$opt_O/gmi_${prep_ID}.$$.listing"; + $listing_file_gz = "$opt_O/gmi_${prep_ID}.$$.listing_gz"; + + print "Standard output redirecting to $listing_file\n"; + open (STDOUT, ">$listing_file"); + open (STDERR, ">&" . STDOUT); + } + else { + print "$0: WARNING: $opt_O is not writable for listing.\n"; + } + }else{ + $listing_file = "STDOUT" + } + + +# Set usage flag. it is expected that +# llk will have no synoptic time in it's argument list. + + $u_flag = 0; + + + + if ( $#ARGV < 0 || $ARGV[0] eq 'help' ) { + + $u_flag = 1; + } + + if ( $u_flag == 1 ) { + print STDERR <<'ENDOFHELP'; +Usage: + + get_gmi.pl [-e] [-E Prep_Config] [-P GEOSDAS_Path] [-R Run_Config] [ -O output_location ] [-L lag_time ] [-t synoptic time] [ process_date ] + + Normal options and arguments: + + -e Processing environment (default = ops) + + -f Force flag.If no NETCDF data for a synoptic time, issue error, + but keep on processing.If no data on remote machine(rget) for + a synoptic time,or No input data for converter, - issue error, + but keep on processing. + + -d Force flag. If "wget" exit with error ,or no files(or size=0) + for yesterday or today day on remote machine(wget) + --> continue processing. + + -a ARCHIVE flag.If there is option "a",then we GZIP and ARCHIVE INPUT ORBIT FILES + + -b REBLOCK flag.If there is option "b",then we REBLOCK BUFR files before archive. + + + -O output_location + This is the full path to the output listings (both STDERR and STDOUT). + + -E Prep_Config + The full path to the preprocessing configuration file. This file contains + parameters needed by the preprocessing control programs. If not given, a + file named $HOME/$prep_ID/Prep_Config is used. get_gmi.pl exits with an + error if neither of these files exist. + + The parameters set from this file are + -t synoptic time + This is the synoptic time to process. + + + WORK_DIR + The top level working directory in which to run the preprocessing. A + subdirectory with the name of the preprocessing ID is made in this + directory (i.e., $WORK_DIR/$prep_ID/$process_date), and the work is done + there. + + + GMI_STAGE_DIR + The location in which to stage the BFR files for use by the DAS. + + GMI_ARCHIVE_LOC + The location in which to archive the BUFR and GMI input files. Files will be + stored in subdirectories according to their Sat_ID and valid date. As an + + GMI_ACQUIRE_MACH + This is ftp location for the raw native GMI + data. + + + GMI_ACQUIRE_PATH_1B + This is the file path template for the raw native GMI 1B + data. + + GMI_ACQUIRE_PATH_1CR + This is the file path template for the raw native GMI 1CR + data. + + + GMI_BUFR + This is the output BUFR filename template. + + + GMI_TABLE_DIR + Directory where bufr tables and other resource files used by the + processing are stored. + + Satellite identification tag for this run of the GMI pre-processing. + + prep_ID + Identification tag for this run of the GMI pre-processing. + + process_date + Date in YYYYMMDD format to process. If not given, then today's date (in + terms of GMT) will be processed. + + synoptic time + Synoptic time in hh format to process (00,06,12,18 or 0,6,12,18). If not given, then the whole day is processed ( $process date) + + Options useful in development mode. These are not necessary (and should not be + used) when running this program in the usual operational environment. + + -P GEOSDAS_Path + Path to directory containing other GEOS DAS programs. The path is + $GEOSDAS_PATH, where $GEOSDAS_PATH/bin is the directory containing these + programs. If -P GEOSDAS_Path is given, then other required programs not + found in the directory where this program resides will be obtained from + subdirectories in GEOSDAS_Path - the subdirectory structure is assumed + to be the same as the operational subdirectory structure. The default is + to use the path to the subdirectory containing this program, which is what + should be used in the operational environment. + + -R Run_Config + Name of file (with path name, if necessary) to read to obtain the + run-time (execution) configuration parameters. get_gmi.pl reads this + file to obtain configuration information at run time. + + If given, get_gmi.pl uses this file. Otherwise, get_gmi.pl looks for a + file named "Run_Config" in the user's home directory, then the + $GEOSDAS_PATH/bin directory. $GEOSDAS_PATH is given by the -P option if + set, or it is taken to be the parent directory of the directory in which this + script resides. It is an error if get_gmi.pl does not find this file, + but in the GEOS DAS production environment, a default Run_Config file is always + present in the bin directory. + + -L Lag Time + This option is to be used in llk real time mode only. This is the lag time, in + days, before the today date. + +ENDOFHELP + $die_away = 1; + } + + +# This module locates the full path name to the location of this file. Variable +# $FindBin::Bin will contain that value. + + use FindBin; + +# This module contains the dirname() subroutine. + + use File::Basename; + +# If default GEOS DAS path, set path to parent directory of directory where this +# script resides. + + if ( $GEOSDAS_PATH eq "DEFAULT" ) { + $GEOSDAS_PATH = dirname( $FindBin::Bin ); + } + +# Set name of the bin directory to search for other programs needed by this one. + + $BIN_DIR = "$GEOSDAS_PATH/bin"; + +# Get the name of the directory where this script resides. If it is different +# than BIN_DIR, then this directory will also be included in the list of +# directories to search for modules and programs. + + $PROGRAM_PATH = $FindBin::Bin; + +# Now allow use of any modules in the bin directory, and (if not the same) the +# directory where this program resides. (The search order is set so that +# the program's directory is searched first, then the bin directory.) + + if ( $PROGRAM_PATH ne $BIN_DIR ) { + @SEARCH_PATH = ( $PROGRAM_PATH, $BIN_DIR ); + } else { + @SEARCH_PATH = ( $BIN_DIR ); + } + +# Set module environment for Fortran executable. + + print "source g5_modules.\n"; + do "${BIN_DIR}/g5_modules_perl_wrapper"; + +} # End BEGIN + +# Any reason to exit found during the BEGIN block? + +if ( $die_away == 1 ) { + exit 1; +} + +# Include the directories to be searched for required modules. + +use lib ( @SEARCH_PATH ); + +# Set the path to be searched for required programs. + +$ENV{'PATH'} = join( ':', @SEARCH_PATH, $ENV{'PATH'} ); + +# This module contains the extract_config() subroutine. +use Extract_config; + +# Archive utilities: gen_archive +use Arch_utils; + +# This module contains the z_time(), dec_time() and date8() subroutines. +use Manipulate_time; + +# Error logging utilities. +use Err_Log; + +# Record FAILED to schedule status file. +use Recd_State; + +# This module contains the mkpath() subroutine. + +use File::Path; +use File::Copy; + +# This module contains the rget() routine. + +use Remote_utils; + +# This module contains the julian_day subroutine. + +use Time::JulianDay; + +#Initialize exit status + +$exit_stat = 0; + +# Set Event/Error log message prefix. + + if ( defined( $sched_id ) ) { + $err_pref="$sched_id"; + } + elsif ( ( ${opt_n} ) ) { + $err_pref="get_gmi_${opt_n}"; + } + else { + $err_pref="get_gmi"; + } + + +# Write start message to Event Log + +err_log (0, "get_gmi.pl", "$prep_ID","$env","-1", + {'err_desc' => "${err_pref}: prep_ID get_gmi.pl job running for has started - Standard output redirecting to $listing_file"}); + +# Use Prep_Config file under the preprocessing run's directory in the user's home directory +# as the default. + +if ( "$PREP_CONFIG_FILE" eq "DEFAULT" ) { + $PREP_CONFIG_FILE = "$ENV{'HOME'}/$prep_ID/Prep_Config"; +} + +# Does the Prep_Config file exist? If not, die. +if ( ! -e "$PREP_CONFIG_FILE" ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: error $PREP_CONFIG_FILE not found while running for ."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "error $PREP_CONFIG_FILE not found."; +} + +# If date given, use that, +# otherwise use today's date (GMT). + + + if ( $#ARGV >= 0 ) { + $process_date = date8( $ARGV[0] ); + } else { + +# Get current date (YYYYMMDD) in GMT, and set the process date to be +# $LAG_TIME days prior. + + $process_date = ( z_time() )[0]; + ($process_date, $process_time) = inc_time ($process_date, 0, -$LAG_TIME, 0); + } + +# The date strings in the error messages and on the listing files is a function of +# the mode we're running. + + $err_time = "${process_date}"; + + if ( $syntime eq 'hd') { + $err_time = "${process_date}"; + } else { + $err_time = "${process_date}.${syntime}z"; + } + + + + + +# Find the locations in which to stage and archive the BUFR files. +( $GMI_STAGE_DIR = extract_config( "GMI_STAGE_DIR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_STAGE_DIR configuration value\n"; + +# Get the location to archive GMI data( BUFR and INPUT) + +( $GMI_ARCHIVE_LOC = extract_config( "GMI_ARCHIVE_LOC", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_ARCHIVE_LOC configuration value\n"; + + +# Get the location, directory, and file names for the Input GMI data. + + ( $GMI_ACQUIRE_MACH = extract_config( "GMI_ACQUIRE_MACH", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_ACQUIRE_MACH configuration value\n"; + + +( $GMI_ACQUIRE_PATH_1B = extract_config( "GMI_ACQUIRE_PATH_1B", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_ACQUIRE_PATH_1B configuration value\n"; + +$template_path_1B=$GMI_ACQUIRE_PATH_1B ; + +( $GMI_ACQUIRE_PATH_1CR = extract_config( "GMI_ACQUIRE_PATH_1CR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_ACQUIRE_PATH_1CR configuration value\n"; + +$template_path_1CR=$GMI_ACQUIRE_PATH_1CR ; + + +# Get the name of the working directory for the observation preprocessing. + +( $GMI_WORK_DIR = extract_config( "GMI_WORK_DIR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_WORK_DIR configuration value\n"; + + +# Get the template name of TABLES + + ( $GMI_TABLE_DIR = extract_config( "GMI_TABLE_DIR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_TABLE_DIR configuration value\n"; + + +# Get the template for the output GMI bufr file. + +( $GMI_BUFR = extract_config( "GMI_BUFR", $PREP_CONFIG_FILE, "NONE" ) ) ne "NONE" + or die "(get_gmi.pl) ERROR - can not set GMI_BUFR configuration value\n"; + +$template_BUFR=$GMI_BUFR ; + + +# -------------------------------------- +# Assign - assigns file name to Fortran units. + +sub Assign { + + my ( $fname, $lu ) = @_; + + $f77name = "fort.$lu"; + unlink($f77name) if ( -e $f77name ) ; + symlink("$fname","$f77name"); + + } +# ------------------------------------- + + +#!/usr/bin/perl + +#-- SUBROUTINE GET GMI BY SYNOPTIC --------------------- +# Subroutine go through list of GMI files and sort them by synoptic time +# Write lists of files by synoptic time . +# Create array from names of files by synoptic time +# Return list of files,arrays of file's names and count of files by synoptic time + + +sub get_bysyn_gmi { + my ( $date_yesterday,$date_today ) = @_; + +# $date_yesterday,$date_today are in FORM YYYYMMDD + $k00= 0; + $k06= 0; + $k12= 0; + $k18= 0; + $list00 =' '; + $list06 =' '; + $list12 =' '; + $list18 =' '; + + + @lst_file00=''; + @lst_file06=''; + @lst_file12=''; + @lst_file18=''; + + +# Files for GMI 1B can be like + +# 0123456789012345678901234567890123456789012345678901 +# 1B.GPM.GMI.TB2014.20141006-S195647-E200145.V03B.RT-H5 + +# Files for GMI 1CR can be like + +# 0123456789012345678901234567890123456789012345678901 +# 1C-R.GPM.GMI.XCAL2014-N.20141006-S200147-E200645.V03B.RT-H5 +# ????????????????????// + +# FOR GMI 1B +# 0123456789012345678901234567890123456789012345678901 +# 1B.GPM.GMI.TB2014.20141006-S195647-E200145.V03B.RT-H5 + +# $date_current= =substr( $gos,18,8) ; +# $gap_stime=substr( $gos,28,2) ; +# $gap_etime=substr( $gos,36,2) ; + +# FOR GMI 1C-R +# 0123456789012345678901234567890123456789012345678901 +# 1C-R.GPM.GMI.XCAL2014-N.20141006-S200147-E200645.V03B.RT-H5 + +# $date_current= =substr( $gos,24,8) ; +# $gap_stime=substr( $gos,34,2) ; +# $gap_etime=substr( $gos,42,2) ; + + + + while ( defined($nextname = <1C-R.GPM.GMI.XCAL*>)) { + + $nextname =~s#.*/##; # remove part before last slash + + $gos ="$nextname"; + +#=================================== +# FOR GMI 1C-R +# 0123456789012345678901234567890123456789012345678901 +# 1C-R.GPM.GMI.XCAL2014-N.20141006-S200147-E200645.V03B.RT-H5 + + $date_current =substr( $gos,24,8) ; + $gap_time=substr( $gos,34,3) ; + + + + if ( $date_current == $date_yesterday) { + +# S200147 ==> $gap_time = 200 +# S030147 ==> $gap_time = 030 +# 0z Yesterday Current time >= 205 +# TODAY Current time < 30 ( time < 030) + + if ($gap_time >= 205 ) { + + $list00='$list00 $nextname'; + $lst_file00 [$k00] = $nextname ; + $k00= $k00 +1; + + } + +# end of date_yesterday + } + + if ( $date_current == $date_today) { + + if ( $gap_time < 30) { + $list00='$list00 $nextname'; + $lst_file00 [$k00] = $nextname ; + $k00= $k00 +1; + } + + +# 6z Current time >= 25 ( time = 025) +# Current time < 90 ( time < 090) + + if ( $gap_time < 90 && $gap_time >= 25 ) { + + $list06="$list06 $nextname"; + $lst_file06 [$k06] = $nextname ; + $k06= $k06 +1; + } + +# 12z Current time >= 085( time =085) +# Current time < 150 + + + if ( $gap_time < 150 && $gap_time >= 85) { + + + $list12="$list12 $nextname"; + $lst_file12 [$k12] = $nextname ; + $k12= $k12 +1; + } + +# 12z Current time >= 145 +# Current time < 210 + + if ( $gap_time < 210 && $gap_time >= 145) { + $list18="$list18 $nextname"; + $lst_file18 [$k18] = $nextname ; + $k18= $k18 +1; + } + +# end of today +} + +# END LOOP BY inlist ( input files) + } + + + return ($k00,$k06,$k12,$k18,$lst_file00,$lst_file06,$lst_file12,$lst_file18,$list00,$list06,$list12,$list18); + + } + +#--END OF SUBROUTINE GET BY SYNOPTIC --------------------- +# --------------------------------------- + +# ===================================================================== +# SUBROUTINE: CREATE LIST of input FILES by day . Return lengh of list. +# ===================================================================== + sub get_native { + + my (${filename_beg}, $date) = @_; + $real_len_full=0 ; + +# Name is 1B.GPM.GMI.TB.%y4%m2%d2*H5 for 1B files +# Name is 1C-R.GPM.GMI.XCAL.%y4%m2%d2*H5 for 1CR files +# while ( defined($nextname = <1B.GPM.GMI.TB*$date*H5>)) +# or +# while ( defined($nextname = <1C-R.GPM.GMI.XCAL*$date*H5>)) + + + while ( defined($nextname = <${filename_beg}*${date}*H5>)) { + + $nextname =~s#.*/##; # remove part before last slash + $full_list[$real_len_full] =$nextname; +# print "VNUTRI full_list = $full_list[$real_len_full] \n"; + + + $real_len_full=${real_len_full} +1; + + +# END LOOP BY input files + } + print " real_len_full = $real_len_full\n"; + + return ($real_len_full,@full_list); + + } + +# ========================================= +# END of SUBROUTINE get_native +# ========================================= + + +# --------------------------------------- + +############################################ +# MAKE WORK_DIR +################################################################ +# Get the work path and Make it. (mkpath default mode is 0777, which is what we want.) + + +# Change into WORK directory it. and clean it + + + +# ********************************************************** + + $gmi_work="$GMI_WORK_DIR/$prep_ID/${process_date}"; + +if ( ! -d ${gmi_work} ) { + + unless (defined eval {mkpath( "${gmi_work}" )}) + { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: Fatal Error: Unable to make directory ${gmi_work}."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Cannot make ${gmi_work}"; + } +} + + +# Change into WORK directory it. + + chdir "${gmi_work}" or die "Cannot cd to ${gmi_work}: $!\n"; + + + $rc=system("rm -f * "); + +# ********************************************************** +# Make STAGE directories if they don't already exist. + + +$GMI_STAGE_DIR = token_resolve( "$GMI_STAGE_DIR", $process_date, $synhour ); + +if ( ! -d "$GMI_STAGE_DIR" ) { +# mkpath( "$STAGE_DIR" ) or die "Cannot make $STAGE_DIR"; + + unless (defined eval {mkpath( "${GMI_STAGE_DIR}" )}) + { + err_log (4, "get_gmi.pl", "$err_time","-1", + {'err_desc' => "${err_pref}: Fatal Error: Unable to make directory ${GMI_STAGE_DIR}."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Cannot make ${GMI_STAGE_DIR}"; + } + +} + + + +################################################################ + + +# ----------------------------------------------- +# Started to ftp input GMI 1B files , run +# ----------------------------------------------- + +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). +# First we'll get the list of today's file. + + + ( $process_date_m1, $current_time ) = inc_time ($process_date, $current_time, -1, 0); + +# ----------------------------------------------- +# Started to ftp input GMI 1B files , run +# ----------------------------------------------- + +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). +# First we'll get the list of today's file. + +###################################################### +# GMI 1B +# Get files GMI 1B for TODAY +################################################## + $GMI_ACQUIRE_PATH=$template_path_1B; + $GMI_ACQUIRE_PATH =token_resolve("${GMI_ACQUIRE_PATH}",$process_date); + print "POPALI INPUT GMI_ACQUIRE_PATH = $GMI_ACQUIRE_PATH \n"; + + +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + +# Paste the array back together into a string leaving off the filename. + +${GMI_ACQUIRE_DIR} = join('/',@list[0 .. $list_len-2]); + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + + $filename="${GMI_ACQUIRE_FILE}"; + $filename_today_1B = $filename ; + print "POPALI INPUT LIST filename = $filename\n"; +# pppppppppppppppppppppppppppppppppppppppppppppppppppppppp + +# Check - from where to take Input files. + + if ($GMI_ACQUIRE_MACH eq 'MISS' ) { + +# Copy Input files from Karki's directory. + $rc=system("cp $GMI_ACQUIRE_PATH . "); + + } + else { + + # Copy (rget) Input files from ftp site . + + # Get the list of files available on the remote server and then grab those files. + #- for current day - can be 288 files + +# $passive = 0; + print "PERED VAJNO passive = $passive \n"; + + + +# %options = $passive ; # ne rabotaet + + %options = ('passive' => $passive) ; + print "Calling rflist: $GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename\n"; +# chomp(@remote_list_today=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename")); + + chomp(@remote_list_today=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename",\%options)); + + + # print " remote_list_today = @remote_list_today .\n"; + + $remote_list_today_len=@remote_list_today; + print " LENGHT remote_list_today = $remote_list_today_len .\n"; + + + #Check to see if there is file to grab + if ($remote_list_today_len > 0){ + + + $i=0; + + $need_file_1B = $remote_list_today[$i]; + + print " NADONADO 1-i FILE remote_list_today = $remote_list_today[i] \n"; + + +# print $remote_list_today[$i] + while ($i < $remote_list_today_len ){ + + $remote_namepath="$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$remote_list_today[$i]"; + + + $remote_list_today_len=@remote_list_today; + + $rget_retcode = rget("$remote_namepath", "$remote_list_today[$i]", + {'debug' => "1",'run_config' => "$RUN_CONFIG_FILE" }); + + if( $rget_retcode != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: Error: rget ftp failed trying to get $remote_list_today[$i] from $remote_namepath."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: rget ftp failed trying to get $remote_list_today[$i] from $remote_namepath. "; + } + +#--VOTVOT------------------------ + +# end if $i < $remote_list_today_len + $i=$i+1; + } + + } + # If NO FILE for today , $remote_list_today_len <= 0 + else { + +# if ($remote_list_today_len <= 0) + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: NON-Fatal Warning: There are no files available on the remote machine for processing GMI 1B on $process_date."}); + $archive_err ++; + + print "POPALI UJAS 10 remote_list_today_len = $remote_list_today_len\n"; + if ( ! $opt_f ) { +# print "STOP : NO OPTION F \n"; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: There be no INPUT data available for date: $process_date . This error occurred while processing GMI 1B data ."; + } + + } + +# END of Check - from where to take Input files. + } +# pppppppppppppppppppppppppppppppppppp +################################################################ + + +# ----------------------------------------------- +# Started to cp input GMI 1CR files +# ----------------------------------------------- + +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). +# First we'll get the list of today's file. + +###################################################### +# GMI 1CR +# Get files GMI 1CR for TODAY +################################################## + $GMI_ACQUIRE_PATH=$template_path_1CR; + $GMI_ACQUIRE_PATH =token_resolve("${GMI_ACQUIRE_PATH}",$process_date); + + +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + +# Paste the array back together into a string leaving off the filename. + +${GMI_ACQUIRE_DIR} = join('/',@list[0 .. $list_len-2]); + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + + $filename="${GMI_ACQUIRE_FILE}"; + $filename_today_1CR = $filename ; + + print "POPALI INPUT LIST filename = $filename\n"; + +# pppppppppppppppppppppppppppppppppppppppppppppppppppppppp + +# Check - from where to take Input files. + + if ($GMI_ACQUIRE_MACH eq 'MISS' ) { + +# Copy Input files from Karki's directory. + $rc=system("cp $GMI_ACQUIRE_PATH . "); + + } + else { + +# Copy (rget) Input files from ftp site . + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + +# %options = $passive ; +# %options = ('passive' => 0) ; + print "PERED VAJNO passive = $passive \n"; + %options = ('passive' => $passive) ; + + + print "Calling rflist: $GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename\n"; +# chomp(@remote_list_today=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename")); + + chomp(@remote_list_today=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename",\%options)); + + +# print " remote_list_today = @remote_list_today .\n"; + +$remote_list_today_len=@remote_list_today; + print " LENGHT remote_list_today = $remote_list_today_len .\n"; + + +#Check to see if there is file to grab +if ($remote_list_today_len > 0){ + +$i=0; + $need_file_1CR = $remote_list_today[$i]; + while ($i < $remote_list_today_len ){ + + $remote_namepath="$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$remote_list_today[$i]"; + + +$remote_list_today_len=@remote_list_today; + + $rget_retcode = rget("$remote_namepath", "$remote_list_today[$i]", + {'debug' => "1",'run_config' => "$RUN_CONFIG_FILE" }); + + if( $rget_retcode != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: Error: rget ftp failed trying to get $remote_list_today[$i] from $remote_namepath."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: rget ftp failed trying to get $remote_list_today[$i] from $remote_namepath. "; + } + + +# end if $i < $remote_list_today_len + $i=$i+1; + } + +} +# If NO FILE for today , $remote_list_today_len <= 0 + else { + +# if ($remote_list_today_len <= 0) + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: NON-Fatal Warning: There are no files available on the remote machine for processing GMI 1CR on $process_date."}); + $archive_err ++; + + print "POPALI UJAS 10 remote_list_today_len = $remote_list_today_len\n"; + if ( ! $opt_f ) { + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: There be no INPUT data available for date: $process_date . This error occurred while processing GMI 1CR data ."; + } + + } + +# END of Check - from where to take Input files. +# ????? + } +# ========================================== + + ( $process_date_m1, $current_time ) = inc_time ($process_date, $current_time, -1, 0); + +# 444444444444444444444444444444444444444444444444444444444444444 + if ( ($syntime eq '00') or ($syntime eq 'hd')) { +# If we have to get 0z , or the whole day ( syntime='00',or='0', or syntime = 'hd') +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). + + +################################################################ + + +# THEN we'll get the list of yesterday's file. + +###################################################### +# GMI 1B +# Get files GMI 1B for YESTERDAY +################################################## +( $process_date_m1, $current_time ) = inc_time ($process_date, $current_time, -1, 0); + + + $GMI_ACQUIRE_PATH=$template_path_1B; + $GMI_ACQUIRE_PATH =token_resolve("${GMI_ACQUIRE_PATH}",$process_date_m1); + + +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + +# Paste the array back together into a string leaving off the filename. + +${GMI_ACQUIRE_DIR} = join('/',@list[0 .. $list_len-2]); + +# Get the list of files available on the remote server and then grab those files. +#- for a day - can be 288 files + + $filename="${GMI_ACQUIRE_FILE}"; + $filename_yesterday_1B = $filename ; + print "POPALI INPUT LIST filename = $filename\n"; + +# pppppppppppppppppppppppppppppppppppppppppppppppppppppppp + +# Check - from where to take Input files. + + if ($GMI_ACQUIRE_MACH eq 'MISS' ) { + +# Copy Input files from Karki's directory. + + $rc=system("cp $GMI_ACQUIRE_PATH . "); + + } + else { +# Copy (rget) Input files from ftp site . + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + +# %options = $passive ; + print "PERED VAJNO passive 3 = $passive \n"; + + %options = ('passive' => $passive) ; + + + print "POPALI GMI_ACQUIRE_DIR = $GMI_ACQUIRE_DIR \n"; + + print "Calling rflist: $GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename\n"; +# chomp(@remote_list_yesterday=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename")); + + chomp(@remote_list_yesterday=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename",\%options)); + + +# print " remote_list_yesterday = @remote_list_yesterday .\n"; + +$remote_list_yesterday_len=@remote_list_yesterday; + print " LENGHT remote_list_yesterday = $remote_list_yesterday_len .\n"; + + +#Check to see if there is file to grab +if ($remote_list_yesterday_len > 0){ + +$i=0; + $need_file_1B = $remote_list_yesterday[$i]; + while ($i < $remote_list_yesterday_len ){ + + $remote_namepath="$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$remote_list_yesterday[$i]"; + + +$remote_list_yesterday_len=@remote_list_yesterday; + + $rget_retcode = rget("$remote_namepath", "$remote_list_yesterday[$i]", + {'debug' => "1",'run_config' => "$RUN_CONFIG_FILE" }); + + if( $rget_retcode != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: Error: rget ftp failed trying to get $remote_list_yesterday[$i] from $remote_namepath."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: rget ftp failed trying to get $remote_list_yesterday[$i] from $remote_namepath. "; + } + + +# end if $i < $remote_list_yesterday_len + $i=$i+1; + } + +} +# If NO FILE for yesterday , $remote_list_yesterday_len <= 0 + else { + +# if ($remote_list_yesterday_len <= 0) + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: NON-Fatal Warning: There are no files available on the remote machine for processing GMI 1B on $process_date_m1."}); + $archive_err ++; + + print "POPALI UJAS 10 remote_list_yesterday_len = $remote_list_yesterday_len\n"; + if ( ! $opt_f ) { + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: There be no INPUT data available for date: $process_date_m1 . This error occurred while processing GMI 1B data ."; + } + + } + +# END of Check - from where to take Input files. +# ????? + } + + + +#44444444444444444444444444444444444444444444444444444444444 + + +# 444444444444444444444444444444444444444444444444444444444444444 +# If we have to get 0z , or the whole day ( syntime = '00', or syntime = 'hd') +# We need files from the current and the previous day to create BUFR file +# (4 synoptic times of GMI data). + + +################################################################ + + +# THEN we'll get the list of yesterday's file. + +###################################################### +# GMI 1CR +# Get files GMI 1CR for YESTERDAY +################################################## + $GMI_ACQUIRE_PATH=$template_path_1CR; + $GMI_ACQUIRE_PATH =token_resolve("${GMI_ACQUIRE_PATH}",$process_date_m1); + + +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + +# Paste the array back together into a string leaving off the filename. + +${GMI_ACQUIRE_DIR} = join('/',@list[0 .. $list_len-2]); + +# Get the list of files available on the remote server and then grab those files. +#- for a day - can be 288 files + + $filename="${GMI_ACQUIRE_FILE}"; + $filename_yesterday_1CR = $filename ; + print "POPALI INPUT LIST filename = $filename\n"; +# pppppppppppppppppppppppppppppppppppppppppppppppppppppppp + +# Check - from where to take Input files. + + if ($GMI_ACQUIRE_MACH eq 'MISS' ) { + +# Copy Input files from Karki's directory. + + $rc=system("cp $GMI_ACQUIRE_PATH . "); + + } + else { +# Copy (rget) Input files from ftp site . + +# Get the list of files available on the remote server and then grab those files. +#- for current day - can be 288 files + +# %options = $passive ; + + print "PERED VAJNO passive 4 = $passive \n"; + + + + %options = ('passive' => $passive) ; + + + print "Calling rflist: $GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename\n"; +# chomp(@remote_list_yesterday=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename")); + chomp(@remote_list_yesterday=rflist("$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$filename",\%options)); + +# print " remote_list_yesterday = @remote_list_yesterday .\n"; + +$remote_list_yesterday_len=@remote_list_yesterday; + print " LENGHT remote_list_yesterday 1CR = $remote_list_yesterday_len .\n"; + + +#Check to see if there is file to grab +if ($remote_list_yesterday_len > 0){ + +$i=0; + $need_file_1CR = $remote_list_yesterday[$i]; + while ($i < $remote_list_yesterday_len ){ + + $remote_namepath="$GMI_ACQUIRE_MACH:$GMI_ACQUIRE_DIR/$remote_list_yesterday[$i]"; + + +$remote_list_yesterday_len=@remote_list_yesterday; +# print "POPALI UJAS 4 remote_list_yesterday_len = $remote_list_yesterday_len\n"; + + $rget_retcode = rget("$remote_namepath", "$remote_list_yesterday[$i]", + {'debug' => "1",'run_config' => "$RUN_CONFIG_FILE" }); + + if( $rget_retcode != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: Error: rget ftp failed trying to get $remote_list_yesterday[$i] from $remote_namepath."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: rget ftp failed trying to get $remote_list_yesterday[$i] from $remote_namepath. "; + } + +# end if $i < $remote_list_yesterday_len + $i=$i+1; + } + +} +# If NO FILE for yesterday , $remote_list_yesterday_len <= 0 + else { + +# if ($remote_list_yesterday_len <= 0) + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: NON-Fatal Warning: There are no files available on the remote machine for processing GMI 1CR on $process_date_m1."}); + $archive_err ++; + + print "POPALI UJAS 10 remote_list_yesterday_len = $remote_list_yesterday_len\n"; + if ( ! $opt_f ) { +# print "STOP : NO OPTION F \n"; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: There be no INPUT data available for date: $process_date_m1 . This error occurred while processing GMI 1CR data ."; + } + + } +# END of Check - from where to take Input files. + } +# ppppppppppppppppppppppppppppppppppppppppppppp + +# End if we need the yesterday files + + } +#44444444444444444444444444444444444444444444444444444444444 + +# ======================================================= + +# $date_today = $process_date ; +# $date_yesterday = $process_date_m1 ; + + get_bysyn_gmi ( $process_date_m1,$process_date); + +# print "KONEZ m= is $m\n"; + + print "AFTER get_bysyn k00= is $k00\n"; + print "AFTER get_bysyn k06= is $k06\n"; + + print "AFTER get_bysyn k12= is $k12\n"; + print "AFTER get_bysyn k18= is $k18\n"; + + +# print "AFTER get_bysyn list00= is $list00\n"; +# print "AFTER get_bysyn lst_file06 = @lst_file06 \n"; + +# print "AFTER get_bysyn lst_file06 (0) = @lst_file06[$kk0]\n"; +# print "AFTER get_bysyn lst_file06 (1) = @lst_file06[$kk1]\n"; +# print "AFTER get_bysyn lst_file06 (2) = @lst_file06[$kk2]\n"; +# print " \n"; +# print "AFTER get_bysyn lst_file06 (3) = @lst_file06[$kk3]\n"; + + + +########################## +# Copy BUFR TABLE for GMI +########################### + $rc=system("cp $GMI_TABLE_DIR/GMI_bufr_table_1CR ${gmi_work} "); +########################## + + + + if ( $syntime eq 'hd') { + + @synlist = ( '00', '06', '12', '18') ; + + + } else { + @synlist = ($syntime) ; + + } + + print "synlist = $synlist\n"; + + + + $synlist_len=@synlist; +if ($synlist_len > 0){ +$i=0; + while ($i < $synlist_len ){ + + $synhour = $synlist[$i] ; + + print "synhour = $synhour\n"; + + +# gmi_L1CR.20140918.t12z.bufr + $daily_bufr=token_resolve("$template_BUFR",$process_date,$synhour ); + print " POSCHITALI daily_bufr = $daily_bufr\n"; + + + if ( $synhour eq '00') { + $knum = $k00; + $clist =$list00; + @lst_file = @lst_file00 ; + } + + if ( $synhour eq '06') { + $knum = $k06; + $clist =$list06; + @lst_file = @lst_file06 ; + } + + + if ( $synhour eq '12') { + $knum = $k12; + $clist =$list12; + @lst_file = @lst_file12 ; + } + + + if ( $synhour eq '18') { + $knum = $k18; + $clist =$list18; + @lst_file = @lst_file18 ; + } + +# print "NADO knum= is $knum\n"; + $nol = 0; + + + if ( $knum > $nol ) { +$inum=0; + + while ($inum < $knum ){ + +# $need_file = $lst_file[$inum] ; +# $rc=system("gmi1cr_bufr.x -d $process_date -t $synhour -f $need_file"); + + $rc=system("gmi1cr_bufr.x -d $process_date -t $synhour -f $lst_file[$inum]"); + + + + +if ($rc != 0) { + + print " WARNING:error running gmi1cr_bufr.x for $process_date synoptic $synhour. \n"; + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: WARNING :error running gmi1cr_bufr.x for $process_date synoptic $synhour"}); + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + + + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: error running gmi1cr_bufr.x for $process_date synoptic $synhour"}); + + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: error running gmi1cr_bufr.x data for date: $process_date and for time: $synhour . This error occurred while processing GMI data ."; + } + + } + + + + + $inum = $inum + 1; +# end for number of files + } +# if knum >0 + } + else { + + print " WARNING: NO input GMI data for $process_date synoptic $synhour. \n"; + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: WARNING :NO input GMI data for $process_date synoptic $synhour"}); + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: NO input GMI data for $process_date synoptic $synhour"}); + + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: NO input GMI data for date: $process_date and for time: $synhour . This error occurred while processing GMI data ."; + } + + } + + +#----------------------------------------------------------------------------- +# BEGIN copy and archive daily_bufr copy and archive daily_bufr copy and archive daily_bufr +# for $process_date , $synhour +#----------------------------------------------------------------------------- + +# From Jianjun +# if ( $size == 1654 || $size == 1697 || $size == 1840 || $size == 1883 || $size == 1926 ) + + $min_size = 2000 ; +# if (! -e "$daily_bufr" || -z "$daily_bufr") + $filesize = -s $daily_bufr ; + if (! -e "$daily_bufr" || -z "$daily_bufr" || "$filesize" < $min_size ) { + print "$daily_bufr DOES NOT EXIST\n"; + + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: WARNING: $daily_bufr was NOT created,or is zero bytes,or size less than min size. There may be no data available for date: $process_date and for times: $synhour . This error occurred while processing GMI data ."}); + + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: Error: $daily_bufr was NOT created,or is zero bytes,or size less than min size. There may be no data available for date: $process_date and for times: $synhour . This error occurred while processing GMI data ."}); + + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: $daily_bufr was NOT created or is small size while running for GMI . "; + } + + } + else { + print "$daily_bufr exists. Will copy\n"; +# Copy into STAGE_DIR + $rc=system("cp $daily_bufr $GMI_STAGE_DIR"); + + if ($rc != 0) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: error copying daily_bufr file $daily_bufr."}); + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "error copying daily_bufr file $daily_bufr."; + } + +# --------------------------------------------- +# Archive $daily_bufr +#--------------------------------------------------- + + +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/bufr/Y%y4/M%m2/",$process_date); +# $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'bufr', "$process_date", +# "$archive_dir", "$daily_bufr", { 'verbose' => "$verbose" ,'exp_path' => "1" } ); + + + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'bufr', "$process_date", + "${GMI_ARCHIVE_LOC}", "$daily_bufr", { 'verbose' => "$verbose" } ); + + + + if ($rc != 1) { + print " WARNING: Could not archive $daily_bufr . \n"; + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: WARNING :could not archive $daily_bufr"}); + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: could not archive $daily_bufr"}); + + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + die "Error: could not archive $daily_bufr for date: $process_date and for time: $synhour . This error occurred while processing GMI data ."; + } + } + +#----------------------------------------------------------------------------- +# END copy and archive daily_bufr copy and archive daily_bufr copy and archive daily_bufr +#----------------------------------------------------------------------------- + +# end for else daily_bufr exist + } + + + +############################### + +# end for foreach $synhour + $i=$i+1; + } +# if synlist > 0 + } + +######################## +# create TAR files from raw GMI 1B nd 1CR files for $process date and +# previous (if needed) date and archive them +######################## + +# Get filename_beg_1CR and filename_beg_1B first + $GMI_ACQUIRE_PATH=$template_path_1B; +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + + ${filename_beg_1B} = substr( ${GMI_ACQUIRE_FILE},0,12) ; + +$template_path_1CR=$GMI_ACQUIRE_PATH_1CR ; + + $GMI_ACQUIRE_PATH=$template_path_1CR; +@list = split('/',${GMI_ACQUIRE_PATH}); +$list_len = @list; +${GMI_ACQUIRE_FILE} = $list[$list_len-1]; + + ${filename_beg_1CR} = substr( ${GMI_ACQUIRE_FILE},0,16) ; + + + $nol = 0; + +######################## +# create TAR files from raw GMI 1B files for $process date and previous(if needed) +# date and archive them +######################## +# 01234567890123456789012345 +# 1B.GPM.GMI.TB2014.20140416-S113146-E113644.V01D.RT-H5 +# 1C-R.GPM.GMI.XCAL2014-N.20140416-S113146-E113644.V01D.RT-H5 + +# 03/17/2016 New name for HDF files +# 1C-R.GPM.GMI.XCAL2015-C.20160308-S235640-E000138.V04A.RT-H5 NEW HDF NAME +# 1B.GPM.GMI.TB2015.20160313-S000140-E000638.V04A.RT-H5 - NEW HDF Name + + + +# $tar_name_1B=substr( ${filename_today_1B},0,18) ; +# $tar_name_1CR=substr( ${filename_today_1CR},0,24) ; +#--------------------------------------------------------- +#----------------------------------------------------------- +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/native/1B/Y%y4/M%m2/",$process_date); + + + get_native (${filename_beg_1B},$process_date) ; + $len1B_today = $real_len_full ; + print " len1B_today = $real_len_full\n"; + + if ($len1B_today >0) { + ${need_name_1B} = $full_list[$nol]; + $tar_name_1B=substr( ${need_name_1B},0,18) ; + + + $tar_name =token_resolve("${tar_name_1B}%y4%m2%d2.he5.tar",$process_date); + + print " iCHTORAT archive_dir = $archive_dir \n"; + print " iCHTORAT tar_name = $tar_name \n"; + print " iCHTORAT filename_today_1B = ${filename_today_1B} \n"; + +# TAR Input Raw files for current day + $rc=system(" tar -cvf ${tar_name} ${filename_today_1B} "); +# Archive TAr file for current day + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'native', "$process_date", + "$GMI_ARCHIVE_LOC", "$tar_name", { 'subtype' => "1B", 'verbose' => "$verbose" } ); + + if ($rc != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: could not archive $tar_name while running for GMI "}); + print "WARNING: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: could not archive $tar_name while running for GMI"}); + print "ERROR: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + + + die "Error: could not archive $tar_name for date: $process_date . This error occurred while processing GMI data ."; + } + } + +# End if ($len1B_today >0) + } + + +######################## +# create TAR files from raw GMI 1CR files for $process date and previous date +# and archive them +######################## + +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/native/1CR/Y%y4/M%m2/",$process_date); +# 1C-R.GPM.GMI.XCAL2014-N.20140924-S085646-E090144.V03B.RT-H5 +# $tar_name =token_resolve("1C-R.GPM.GMI.XCAL_%y4m%m2%d2.he5.tar",$process_date); + + get_native (${filename_beg_1CR},$process_date) ; + $len1CR_today = $real_len_full ; + print " len1CR_today = $real_len_full\n"; + if ($len1CR_today >0) { + ${need_name_1CR} = $full_list[$nol]; + $tar_name_1CR=substr( ${need_name_1CR},0,24) ; + + + $tar_name =token_resolve("${tar_name_1CR}%y4%m2%d2.he5.tar",$process_date); + + print " iCHTORAT archive_dir = $archive_dir \n"; + print " iCHTORAT tar_name = $tar_name \n"; + print " iCHTORAT filename_today_1CR = ${filename_today_1CR} \n"; + +# TAR Input Raw files for current day + $rc=system(" tar -cvf ${tar_name} ${filename_today_1CR} "); +# Archive TAr file for current day + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'native', "$process_date", + "$GMI_ARCHIVE_LOC", "$tar_name", { 'subtype' => "1CR",'verbose' => "$verbose" } ); + + if ($rc != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: could not archive $tar_name while running for GMI "}); + print "WARNING: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: could not archive $tar_name while running for GMI"}); + print "ERROR: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + + + die "Error: could not archive $tar_name for date: $process_date . This error occurred while processing GMI data ."; + } + } + +# if ($len1CR_today >0) + } + +# 444444444444444444444444444444444444444444444444444444444444444 + if ( ($syntime eq '00') or ($syntime eq 'hd')) { +# If we have to get 0z , or the whole day ( syntime = '00', or syntime = 'hd') +# then we have files from the previous day to create TAR file for yesterday +# $tar_name_1B=substr( ${filename_yesterday_1B},0,18) ; +# $tar_name_1CR=substr( ${filename_yesterday_1CR},0,24) ; + + +################################## +# Tar files fot 1B for yesterday +################################## + +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/native/1B/Y%y4/M%m2/",$process_date_m1); +# $tar_name =token_resolve("1B.GMI-Aura_L2-OMTO3_%y4m%m2%d2.he5.tar",$process_date_m1); + + + get_native (${filename_beg_1B},$process_date_m1) ; + $len1B_yesterday = $real_len_full ; + print " len1B_yesterday = $real_len_full\n"; + if ($len1B_yesterday >0) { + ${need_name_1B} = $full_list[$nol]; + $tar_name_1B=substr( ${need_name_1B},0,18) ; + + + $tar_name =token_resolve("${tar_name_1B}%y4%m2%d2.he5.tar",$process_date_m1); + + print " aCHTORAT archive_dir = $archive_dir \n"; + print " aCHTORAT tar_name = $tar_name \n"; + print " aCHTORAT filename_yesterday_1B = ${filename_yesterday_1B} \n"; + + +# TAR Input Raw files for previous day + $rc=system(" tar -cvf ${tar_name} ${filename_yesterday_1B} "); +# Archive TAR file for previous day + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'native', "$process_date_m1", + "$GMI_ARCHIVE_LOC", "$tar_name", { 'subtype' => "1B", 'verbose' => "$verbose" } ); + + if ($rc != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: could not archive $tar_name while running for GMI "}); + print "WARNING: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: could not archive $tar_name while running for GMI"}); + print "ERROR: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + + + die "Error: could not archive $tar_name for date: $process_date_m1 . This error occurred while processing GMI data ."; + } + } +# if ($len1B_yesterday >0) + } + + +##################################### +# Tar files 1CR for yesterday +##################################### +# $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/gmi/native/1CR/Y%y4/M%m2/",$process_date_m1); + + get_native (${filename_beg_1CR},$process_date_m1) ; + $len1CR_yesterday = $real_len_full ; + print " len1CR_yesterday = $real_len_full\n"; + if ($len1CR_yesterday >0) { + ${need_name_1CR} = $full_list[$nol]; + $tar_name_1CR=substr( ${need_name_1CR},0,24) ; + + + + $tar_name=token_resolve("${tar_name_1CR}%y4%m2%d2.he5.tar",$process_date_m1); + + print " aCHTORAT archive_dir = $archive_dir \n"; + print " aCHTORAT tar_name = $tar_name \n"; + print " aCHTORAT filename_yesterday_1CR = ${filename_yesterday_1CR} \n"; + + +# TAR Input Raw files for previous day + $rc=system(" tar -cvf ${tar_name} ${filename_yesterday_1CR} "); +# Archive TAR file for previous day + $rc = gen_archive ( "$env", "$prep_ID", 'gmi', 'native', "$process_date_m1", + "$GMI_ARCHIVE_LOC", "$tar_name", { 'subtype' => "1CR", 'verbose' => "$verbose" } ); + + if ($rc != 1) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: could not archive $tar_name while running for GMI "}); + print "WARNING: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, WARNING, $tab_argv, $sched_dir, $sched_sts_fl); + if ( ! $opt_f ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: could not archive $tar_name while running for GMI"}); + print "ERROR: could not archive $tar_name \n"; + $archive_err ++; + recd_state($fl_name, FAILED, $tab_argv, $sched_dir, $sched_sts_fl); + + + die "Error: could not archive $tar_name for date: $process_date_m1 . This error occurred while processing GMI data ."; + } + + } + +# END if ($len1CR_yesterday >0) + } + +# END if ( ($syntime eq '00') or ($syntime eq 'hd')) + } + + + +######################## +# Rename output listings +######################## + +if ( $opt_O ) { + + print "THERE ARE OPTION O. Will copy Listing\n"; + + unlink<"$listing_file_gz">; + system ( "gzip -c $listing_file > $listing_file_gz" ); + + $archive_dir = token_resolve("${GMI_ARCHIVE_LOC}/listing/Y%y4/M%m2/",$process_date); + $rc=gen_archive ( "$env","$prep_ID",'gmi','listing', "$process_date", + "$GMI_ARCHIVE_LOC", $listing_file_gz, + { 'remote_name' => "gmi_${prep_ID}.$err_time.listing.gz", + 'delete' => "1", + 'verbose' => "1" } ); + + if ( $rc != 1 ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", {'err_desc' => "${err_pref}: could not archive listing file gmi_${prep_ID}.$err_time.listing.gz"}); + print "WARNING: could not archive listing file gmi_${prep_ID}.$err_time.listing.gz \n"; + $archive_err ++; + } + +} +if ( $archive_err ) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: get_gmi.pl: exiting with errors"}); +}else{ + err_log (0, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: get_gmi.pl: exiting normally"}); +} +if ( $opt_O ) { + system ("mv $listing_file $opt_O/gmi_${prep_ID}.${err_time}.listing"); +} +############################ +# Clean up working directory +############################ + + $rc=system("/bin/rm -rf ${gmi_work}"); + + + if ($rc != 0) { + err_log (4, "get_gmi.pl", "$err_time","$prep_ID","-1", + {'err_desc' => "${err_pref}: WARNING: could not remove ${gmi_work}"}); + print "WARNING: could not remove ${gmi_work}\n"; + } + + + + + recd_state( $fl_name, "COMPLETE", $tab_argv, $sched_dir, $sched_sts_fl ); +exit 0; + + diff --git a/util/GMI_BUFR_gen/gmi/src/Make b/util/GMI_BUFR_gen/gmi/src/Make new file mode 100755 index 000000000..71cf801e5 --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/src/Make @@ -0,0 +1,44 @@ +#!/bin/csh -x + +# +set Basedir = /discover/nobackup/projects/gmao/share/dao_ops/Baselibs/v3.2.0_build3 +set GEOSDAS = /home/dao_ops/GEOSadas-5_13_1_sp3/GEOSadas/ +set GEOSDAS = /home/dao_ops/GEOSadas-5_17/GEOSadas/ +#set BufrLib = /discover/nobackup/jjin3/G590_jj/GEOSadas-5_9_1_p2_cloud/Linux/lib/libNCEP_bufr_r8i4.a +# set BufrLib = /discover/nobackup/jjin3/geos_adas/GEOSadas/Linux/lib/libNCEP_bufr_r8i4.a +# set BufrLib = /gpfsm/dhome/dao_ops/GEOSdas-2_1_4/GEOSadas/Linux/lib +# set BufrLib = /gpfsm/dhome/dao_ops/GEOSdas-2_1_4-m3/GEOSadas/Linux/lib/libNCEP_bufr_r8i4.a + +set BufrLib = ${GEOSDAS}/Linux/lib/libNCEP_bufr_r8i4.a +#set HDFincdir = /usr/local/other/SLES11/hdf5/1.8.7/intel-11.1.038/include +#set HDFlibdir = /usr/local/other/SLES11/hdf5/1.8.7/intel-11.1.038/lib +set HDFincdir = $Basedir/Linux/include/hdf5 +set HDFlibdir = $Basedir/Linux/lib + +set _Ihdf5 = "-I$HDFincdir" +#set _Lhdf5 = "-lhdf5_fortran" +#set _Lhdf5 = "-lhdf5_hl" + + +# +# +ifort -c $_Ihdf5 gmi1cr_hdf2bufr.f90 \ + hdf5rd_mod.f90 \ + wr_gmi_bufr_1cr.f90 \ + ymd_thhz.f90 \ + ymdhms2tim13.f90 +#---------------------------------------------------------------- +ifort -o gmi1cr_bufr.x gmi1cr_hdf2bufr.o \ + hdf5rd_mod.o \ + wr_gmi_bufr_1cr.o \ + ymd_thhz.o \ + ymdhms2tim13.o \ + -L/$Basedir/Linux/lib/ \ + -lnetcdf \ + -lhdf5_hl \ + -lhdf5_fortran \ + -lhdf5 \ + -lz -lmfhdf -ldf -lsz -ljpeg -lcurl -lrt $BufrLib + +# +/bin/rm -f *.o diff --git a/util/GMI_BUFR_gen/gmi/src/gmi1cr_hdf2bufr.f90 b/util/GMI_BUFR_gen/gmi/src/gmi1cr_hdf2bufr.f90 new file mode 100644 index 000000000..d317328a1 --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/src/gmi1cr_hdf2bufr.f90 @@ -0,0 +1,617 @@ +!########################################################################### +! Program history log: +! 2014-02-24 J.Jin -- READ GMI 1B/1C proxy data in HDF5 format +! 2014-06-10 ejones -- Read GMI 1CR data in HDF5 format +! 2014-06-23 J.Jin -- Reorganize the GMI HDF reading subroutine. +! The new code also reads level 1B data, which requires +! GMI 1B HDF files are in the same directory as 1C-R +! files are. +! 2014-07-11 J.Jin -- read all geo-information about angles for both swaths +! and save them in 2-element arrays +! 10/10/2014 Yelena Add 'need_date,need_syn' as Input --> to write +! Bufr only for needed date,synoptic +! +! 2014-11-06 J.Jin -- Revise version number. For example, V03A was saved as V3. +! Now it is saved as V3.01. The bufr tabl is also revised. +! 2014-11-08 J.Jin -- Check scan number in HDF files. Stop if it is zero which +! means no data are actually stored in the HDF file. + +! +! 2015-08-20 J.Jin** -- Merges Erin Jones's code read and write RFIflag. + +! 2016-03-11 J.Jin -- Read GMI V04 data which is based XCAL2015. +! 2016-03-15 J.Jin -- Enable it to read data with general 1C-R name format +! "1C-R.GPM.GMI.XCALyyyy...". + + +! +! Usage: +! +! Input files: inputFileName +! +! Output files: +! +! Subprograms called: +! Library: +! BUFRLIB - OPENBF CLOSBF OPENMB WRITSB UFBSEQ +! HDF5 - h5open_f h5close_f h5fopen_f h5fclose_f +! h5gopen_f h5gclose_f +! h5aopen_f h5aget_space_f h5aget_info_f h5aget_type_f +! h5aread_f h5aclose_f +! h5dopen_f h5dread_f h5dclose_f +! +!########################################################################### + +PROGRAM ONECR_HDF_to_BUFR + USE HDF5 + USE hdf5rd_mod, only: hdf5rd_i, hdf5rd_f +!--------------------------------------------------------------------------- + IMPLICIT NONE + + CHARACTER (LEN = 80) :: inputBuffer,prefix_sub,argv + CHARACTER (LEN = 80) :: inputFileName, groupname, subgroupname, swathheader,& + dsetname, timename, SCstatname, qname,tmbrname + CHARACTER (LEN = 80) :: outputPrefix + CHARACTER (LEN = 80) :: inputFileName1b +! CHARACTER (LEN = 80), PARAMETER :: hdf1cr_prefix='1C-R.GPM.GMI.XCAL2014-N', hdf1b_prefix='1B.GPM.GMI.TB2014' +# JJJ + CHARACTER (LEN = 80), PARAMETER :: hdf1cr_prefix='1C-R.GPM.GMI.XCAL', hdf1b_prefix='1B.GPM.GMI.TB' + + CHARACTER (LEN = 80), PARAMETER :: prefix='gmi_L1CR.' +# JJJ + CHARACTER (LEN = 4) :: xcalyear + CHARACTER (LEN = 4), PARAMETER :: xcal='XCAL' + + + INTEGER(HID_T) :: file_id, group_id, dset_id, attr_id, space_id, memtype_id, type_id, error, subgroup_id, subdset_id + INTEGER(HSIZE_T),DIMENSION(:), allocatable :: data_dims + INTEGER(HSIZE_T),DIMENSION(1) :: attr_dims + CHARACTER (LEN=1000) :: attr_data + + INTEGER :: ng, nscan, npixel, nchanl, nmd, nmds, ntd, nsc, nqd + +! 11/02/2015 Added JJJ + INTEGER :: nfreq + + INTEGER :: str1,str2 + INTEGER :: iscan + INTEGER :: ntds=5 + INTEGER :: nscs=3 + INTEGER :: nqds=3 + INTEGER, PARAMETER :: ngs=2, nchanlall=13 + CHARACTER(LEN=40),DIMENSION(2):: groupnames=(/'S1','S2'/) + CHARACTER(LEN=40),DIMENSION(2):: gswathheaders=(/'S1_SwathHeader','S2_SwathHeader'/) + integer, dimension(2) :: nchanls=(/9,4/) + + INTEGER, ALLOCATABLE :: year(:) +! INTEGER :: month1, day1, hour1, minute1, second1 + + INTEGER, ALLOCATABLE :: time(:), month(:), day(:), hour(:), & + minute(:), second(:) + +! CHARACTER(LEN=5), ALLOCATABLE :: time(:), month(:), day(:), hour(:), & +! minute(:), second(:) + +! CHARACTER(LEN=5) :: mn, dd, hh, mm, ss + + +! INTEGER, ALLOCATABLE :: qual(:), dataQuality(:), geoWarning(:), geoError(:) +! INTEGER, ALLOCATABLE :: Quality(:,:),Quality1cr(:,:,:) + +! 11/02/2015 Added JJJ + INTEGER, ALLOCATABLE :: Quality(:,:),Quality1cr(:,:,:), RFIflag(:,:,:), RFIflag1cr(:,:,:) + + + + REAL, ALLOCATABLE :: scStats(:), scLatitude(:), scLongitude(:), scAltitude(:) + + REAL, ALLOCATABLE :: data_set(:,:), Latitude(:,:), Longitude(:,:), & + incidenceAngle(:,:), satAzimuthAngle(:,:), & + solarAzimuthAngle(:,:),solarZenAngle(:,:), & + satLocZenAngle(:,:), incidenceAngle1cr(:,:,:), & + satAzimuthAngle1cr(:,:,:), & + solarAzimuthAngle1cr(:,:,:), & + solarZenAngle1cr(:,:,:) + CHARACTER(LEN=80),dimension(6):: dsetnames = (/'Latitude','Longitude', & + 'incidenceAngle','satAzimuthAngle', & + 'solarAzimuthAngle','solarZenAngle'/) + + CHARACTER(LEN=80),dimension(3):: qnames = (/'dataQuality', 'geoError', 'geoWarning'/) + + CHARACTER(LEN=80),dimension(5):: timenames =(/'Month', 'DayOfMonth', 'Hour', & + 'Minute', 'Second'/) + + CHARACTER(LEN=80),dimension(3):: SCstatnamesC =(/'SCaltitude', 'SClatitude',& + 'SClongitude'/) + CHARACTER(LEN=80),dimension(3):: SCstatnamesB =(/'scAlt', 'scLat', 'scLon'/) + + CHARACTER(LEN=80),dimension(3):: SCstatnames + +! INTEGER, DIMENSION(:), ALLOCATABLE :: monthint, dayint, hrint, minint, secint + + REAL, ALLOCATABLE :: Tb(:, :, :),Tb1cr(:,:,:) + + INTEGER :: GranuleNumber, NumberScansBeforeGranule, & + NumberScansGranule, NumberScansAfterGranule, & + MissingData + + INTEGER :: exitStatus + + LOGICAL :: f_corder_valid ! Indicates whether the creation order + ! data is valid for this attribute + INTEGER :: corder ! Is a positive integer containing the + ! creation order of the attribute + INTEGER :: cset ! Indicates the character set used for + ! the ! attribute’s name + INTEGER(HSIZE_T) :: data_size + ! Indicates the size, in the number + ! of characters, of the attribute + INTEGER :: hdferr ! Error code: + ! 0 on success and -1 on failure + + REAL, ALLOCATABLE :: sunGlintAngle1b(:,:) + INTEGER, ALLOCATABLE :: sunGlintAngle1c(:,:),sunGlintAngle1cr(:,:,:) + LOGICAL :: gmi1b, gmi1c,gmi1cr +! INTEGER :: l,n,dim1,dim2,dim3,version + +! New 11/06/2014 + INTEGER :: l,n,dim1,dim2,dim3,version, ichar_v + CHARACTER(LEN=1) :: version_a + REAL*4 :: gmi_version + + +! YELENA + integer :: need_date,need_syn,ier + integer :: argc, iargc, iarg + logical :: ffound + CHARACTER (LEN = 8 ) :: wanted_date + CHARACTER (LEN = 2) :: wanted_syn + + + + need_date = 0 + need_syn = 0 + ffound = .false. + argc = iargc() + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Get HDF file name +! CALL getarg(1,inputBuffer) + +! print *,'argc = ',argc + + +! YELENA Get DATE and SYNOPTIC needed, and HDF file name + if (argc < 1 .or. argc > 6) then + call usage() + endif +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + iarg = 0 + + wanted_date =' ' + wanted_syn =' ' + do while (iarg < argc) + iarg = iarg + 1 + call getarg( iarg, argv ) + if (index(argv,'-d') > 0) then + if ( iarg+1 > argc ) call usage() + iarg = iarg + 1 + call getarg( iarg,wanted_date ) + + else if (index( argv, '-t') > 0) then + if ( iarg+1 > argc ) call usage() + iarg = iarg + 1 + call getarg( iarg, wanted_syn ) + else if (index( argv, '-f') > 0) then + if ( iarg+1 > argc ) call usage() + iarg = iarg + 1 + call getarg( iarg, inputFileName ) + endif + end do + + + print *, ' wanted date = ',wanted_date,' wanted synoptic= ',wanted_syn + print *, ' inputFileName = ',inputFileName + +! READ(inputBuffer, *) inputFileName + print *, ' ' + print *, '------ new HDF file -------', trim(inputFileName) + + + read(wanted_date,'(i8)',iostat=ier) need_date + read(wanted_syn,'(i2)',iostat=ier) need_syn + + print *, ' need date = ',need_date,' needed synoptic= ',need_syn + if ( wanted_date .eq.' ') then + print *,'NO WANTED_DATE : stop' + stop + endif + if ( wanted_syn .eq.' ') then + print *,'NO WANTED SYNOPTIC TIME : stop' + stop + endif + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + gmi1cr = index(inputFileName, '1C-R.GPM.GMI.') > 0 + if (gmi1cr) then + nmds=3 + tmbrname='Tc' + outputPrefix=inputFileName(0:54) + else + print *, '------ new HDF file -------', trim(inputFileName) + print*, 'File = ',trim(inputFileName),' is not a GMI 1CR file.' + stop + endif + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Initialize FORTRAN interface. + CALL h5open_f(error) + ! Open file to read VD (table) information + call h5fopen_f(inputFileName, H5F_ACC_RDONLY_F, file_id, error) + if(error/=0) then + print*, 'Error. Cannot open the HDF file. Program stop' + stop + endif + + ! --------------------------------------------------------------------------- + ! --------------------------------------------------------------------- + !get the file header info + call h5aopen_f(file_id, 'FileHeader', attr_id, error) + call h5aget_type_f(attr_id, type_id, error) + attr_dims(1)=0 + call h5aread_f(attr_id, type_id, attr_data, attr_dims, error) + GranuleNumber = inquire_attr_sub(attr_data, 'GranuleNumber') + MissingData = inquire_attr_sub(attr_data, 'MissingData') + print *, 'GranuleNumber, MissingData' + print *, GranuleNumber, MissingData + call h5aclose_f(attr_id, error) + +!----------------------------------------------------------------------- + ! open group1 to pull most information + groupname = trim(groupnames(1)) + print *, '-------' + print *, 'group:', trim(groupnames(1)) + call h5gopen_f(file_id, trim(groupname), group_id, error) +!----------------------------------------------------------------------- + !get the swath header information for S1 + swathheader = trim(gswathheaders(1)) + call h5aopen_f(group_id, trim(swathheader), attr_id, error) + call h5aget_type_f(attr_id, type_id, hdferr) + + attr_dims(1)=1 + call h5aread_f(attr_id,type_id, attr_data, attr_dims, error) + NumberScansBeforeGranule = inquire_attr_sub(attr_data, 'NumberScansBeforeGranule') + NumberScansAfterGranule = inquire_attr_sub(attr_data, 'NumberScansAfterGranule' ) + !nscan = inquire_attr_sub(attr_data, 'MaximumNumberScansTotal') + nscan = inquire_attr_sub(attr_data, 'NumberScansGranule') + npixel = inquire_attr_sub(attr_data, 'NumberPixels' ) + print *, 'NumberScansBeforeGranule, NumberScansAfterGranule, nscan, npixel' + print *, NumberScansBeforeGranule, NumberScansAfterGranule, nscan, npixel + call h5aclose_f(attr_id, error) + ! Terminate access to the SD interface and close the file. + call h5fclose_f(file_id, error) + ! Close FORTRAN interface. + CALL h5close_f(error) + if (nscan < 1 ) then + print*, 'Number of scans in the HDF file =', nscan + print*, 'Error. Data are missing in HDF file. Program stopped.' + stop + endif +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + allocate (year(nScan),month(nScan),day(nScan),hour(nScan),minute(nScan),second(nScan)) + groupname='S1' + subgroupname='ScanTime' + dim1=nScan; dim2=1; dim3=1 + dsetname='Year' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,year) + dsetname='Month' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,month) + dsetname='DayOfMonth' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,day) + dsetname='Hour' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,hour) + dsetname='Minute' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,minute) + dsetname='Second' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,second) +!----------------------------------------------------------------------- + allocate (Tb1cr(nchanlall, npixel, nscan)) + groupname='S1' + subgroupname='' + dsetname='Tc' + dim1=nchanls(1); dim2=npixel; dim3=nscan + allocate (Tb(dim1, dim2,dim3)) + call hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,Tb) + Tb1cr(1:9, :,:) = Tb(:,:,:) + deallocate (Tb) + + groupname='S2' + dim1=nchanls(2); dim2=npixel; dim3=nscan + allocate (Tb(dim1, dim2,dim3)) + call hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,Tb) + Tb1cr(10:nchanlall, :,:) = Tb(:,:,:) + deallocate (Tb) +!----------------------------------------------------------------------- + allocate (Quality1cr(nchanlall, npixel, nscan)) + allocate (incidenceAngle1cr(ngs,npixel, nscan)) + allocate (sunGlintAngle1cr(ngs,npixel, nscan)) + + groupname='S1' + subgroupname='' + dim1=npixel; dim2=nscan; dim3=1 + allocate (Quality(dim1,dim2), incidenceAngle(dim1,dim2), sunGlintAngle1c(dim1,dim2) ) + dsetname='Quality' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,Quality) + dsetname='incidenceAngle' + call hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,incidenceAngle) + dsetname='sunGlintAngle' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,sunGlintAngle1c) + do l=1,9 + Quality1cr(l,:,:) = Quality(:,:) + enddo + incidenceAngle1cr(1,:,:) = incidenceAngle(:,:) + sunGlintAngle1cr(1,:,:) = sunGlintAngle1c(:,:) + deallocate (Quality,incidenceAngle, sunGlintAngle1c) + + groupname='S2' + allocate (Quality(dim1,dim2), incidenceAngle(dim1,dim2), sunGlintAngle1c(dim1,dim2) ) + dsetname='Quality' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,Quality) + dsetname='incidenceAngle' + call hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,incidenceAngle) + dsetname='sunGlintAngle' + call hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,sunGlintAngle1c) + do l=10,nchanlall + Quality1cr(l,:,:) = Quality(:,:) + enddo + incidenceAngle1cr(2,:,:) = incidenceAngle(:,:) + sunGlintAngle1cr(2,:,:) = sunGlintAngle1c(:,:) + deallocate (Quality,incidenceAngle, sunGlintAngle1c) + +!----------------------------------------------------------------------- + allocate (SClatitude(nScan),SClongitude(nScan),SCaltitude(nScan)) + groupname='S1' + subgroupname='SCstatus' + dim1=nScan; dim2=1; dim3=1 + dsetname='SClatitude' + call hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,SClatitude) + dsetname='SClongitude' + call hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,SClongitude) + dsetname='SCaltitude' + call hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,SCaltitude) + +!----------------------------------------------------------------------- + allocate (Latitude(npixel, nscan), Longitude(npixel, nscan) ) + groupname='S1' + subgroupname='' + dim1=npixel; dim2=nscan; dim3=1 + dsetname='Latitude' + call hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,Latitude) + dsetname='Longitude' + call hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,Longitude) + +!----------------------------------------------------------------------- + ! read these from level 1B data files. +! JJJ + str1 = index(inputFileName,xcal) + if (str1 == 0 ) then + print*, "The input 1C-R file's name does not have the format like 1C-R.GPM.GMI.XCAL2015-C...." + print*, "The program cannot construct 1B file's name accordingly. Prog Stop 4." + stop + endif + xcalyear= inputFileName((str1+4):(str1+7)) + + str1 = 0 +! end JJJ 16 Mar 2016 + + str1 = index(inputFileName, trim(hdf1cr_prefix)) + str2 = len_trim(inputFileName) + if(str1 > 1) then +! inputFileName1b = inputFileName(1:(str1-1))//trim(hdf1b_prefix)//inputFileName((str1+len_trim(hdf1cr_prefix)):str2) +! else +! inputFileName1b = trim(hdf1b_prefix)//inputFileName(len_trim(hdf1cr_prefix)+1:str2) +! JJJ 16 Mar 2016 + inputFileName1b = inputFileName(1:(str1-1))//trim(hdf1b_prefix)//xcalyear//inputFileName((str1+len_trim(hdf1cr_prefix)+6) :str2) + else + inputFileName1b = trim(hdf1b_prefix)//xcalyear//inputFileName((len_trim(hdf1cr_prefix)+7):str2) +! End JJJ 16 Mar 2016 + endif + print *, inputFileName1b + allocate (satAzimuthAngle(npixel, nscan), solarAzimuthAngle(npixel, nscan), & + solarZenAngle(npixel, nscan)) + allocate (satAzimuthAngle1cr(ngs, npixel, nscan), solarAzimuthAngle1cr(ngs,npixel,nscan),& + solarZenAngle1cr(ngs, npixel, nscan)) + +! 11/02/2015 JJJ + allocate (RFIflag(5,npixel, nscan), RFIflag1cr(13,npixel,nscan)) + + + groupname='S1' + subgroupname='' + dim1=npixel; dim2=nscan; dim3=1 +! JJJ 16 March 2016 + nfreq=5 + + dsetname='satAzimuthAngle' + call hdf5rd_f(inputFileName1b,groupname,subgroupname,dsetname,dim1,dim2,dim3,satAzimuthAngle) + dsetname='solarAzimuthAngle' + call hdf5rd_f(inputFileName1b,groupname,subgroupname,dsetname,dim1,dim2,dim3,solarAzimuthAngle) + dsetname='solarZenAngle' + call hdf5rd_f(inputFileName1b,groupname,subgroupname,dsetname,dim1,dim2,dim3,solarZenAngle) + +! 11/02/2015 JJJ + dsetname='RFIFlag' + call hdf5rd_i(inputFileName1b,groupname,subgroupname,dsetname,nfreq,dim1,dim2,RFIflag) + + satAzimuthAngle1cr(1,:,:) = satAzimuthAngle(:,:) + solarAzimuthAngle1cr(1,:,:) = solarAzimuthAngle(:,:) + solarZenAngle1cr(1,:,:) = solarZenAngle(:,:) + +! JIANJUN - YELENA November 2015 +! DEFINE RFIflag1cr + + RFIflag1cr(1,:,:) = RFIflag(1,:,:) + RFIflag1cr(2,:,:) = RFIflag(1,:,:) + RFIflag1cr(3,:,:) = RFIflag(2,:,:) + RFIflag1cr(4,:,:) = RFIflag(2,:,:) + RFIflag1cr(5,:,:) = RFIflag(3,:,:) + RFIflag1cr(6,:,:) = RFIflag(4,:,:) + RFIflag1cr(7,:,:) = RFIflag(4,:,:) + RFIflag1cr(8,:,:) = RFIflag(5,:,:) + RFIflag1cr(9,:,:) = RFIflag(5,:,:) + + + + groupname='S2' + subgroupname='' + dim1=npixel; dim2=nscan; dim3=1 + +! JIANJUN - YELENA November 2015 +! DEFINE nfreq + nfreq=2 + + dsetname='satAzimuthAngle' + call hdf5rd_f(inputFileName1b,groupname,subgroupname,dsetname,dim1,dim2,dim3,satAzimuthAngle) + dsetname='solarAzimuthAngle' + call hdf5rd_f(inputFileName1b,groupname,subgroupname,dsetname,dim1,dim2,dim3,solarAzimuthAngle) + dsetname='solarZenAngle' + call hdf5rd_f(inputFileName1b,groupname,subgroupname,dsetname,dim1,dim2,dim3,solarZenAngle) + +! JIANJUN - YELENA November 2015 +! DEFINE RFIflag1cr + dsetname='RFIFlag' + call hdf5rd_i(inputFileName1b,groupname,subgroupname,dsetname,nfreq,dim1,dim2,RFIflag) + + satAzimuthAngle1cr(2,:,:) = satAzimuthAngle(:,:) + solarAzimuthAngle1cr(2,:,:) = solarAzimuthAngle(:,:) + solarZenAngle1cr(2,:,:) = solarZenAngle(:,:) + +! JIANJUN - YELENA November 2015 +! DEFINE RFIflag1cr + + RFIflag1cr(10,:,:) = RFIflag(1,:,:) + RFIflag1cr(11,:,:) = RFIflag(1,:,:) + RFIflag1cr(12,:,:) = RFIflag(2,:,:) + RFIflag1cr(13,:,:) = RFIflag(2,:,:) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !write BUFR file + !str1=index(inputFileName,'.RT-H5') + !prefix_sub=inputFileName(1:(str1-1)) + !prefix = trim(prefix_sub) + str1=index(inputFileName,'.V') + read( inputFileName((str1+2) : (str1+3)), '(i)') version + print *, 'version=', version + +! JIANJUN - YELENA November 2015 +! READ VERSION_a + + read( inputFileName((str1+4) : (str1+4)), '(a)') version_a + print *, 'version=', version, version_a + +!****************************************************** + read( inputFileName((str1+4) : (str1+4)), '(a)') version_a + print *, 'version=', version, version_a + ichar_v = ichar(version_a) ! ANSI code + if( ichar_v >= 65 .and. ichar_v <=90) then + gmi_version = version + (float(ichar_v)-64)/100 + else if(ichar_v >= 97 .and. ichar_v <=122) then + gmi_version = version + (float(ichar_v)-96)/100 + else + print*, 'Error, file name format like *.V03A* has been changed. This program cannot get the version number correctly.' + print*, 'Program stopped.' + stop + endif + + +!****************************************************** + ! do n=1,nscan + ! do l=1,npixel + ! write(106,1061) l,Latitude(l,n), Longitude(l,n),int(Quality1cr(1:13,l,n)) + ! enddo + ! enddo + !1061 format(2x,i5,2f8.2,3x,13i4) + +! CALL write_gmi_bufr_1cr(prefix, version, nscan, npixel, nchanlall, year, month, day, hour, minute, second, Latitude, Longitude, Quality1cr, scLatitude, scLongitude, scAltitude,satAzimuthAngle1cr, solarAzimuthAngle1cr, solarZenAngle1cr, incidenceAngle1cr, Tb1cr, GranuleNumber, NumberScansBeforeGranule,NumberScansGranule, NumberScansAfterGranule, sunGlintAngle1cr, MissingData, exitStatus) + +! YELENA +! need_date,need_syn - additional argument + +! CALL write_gmi_bufr_1cr(prefix, version, nscan, npixel, nchanlall, year, month, day, hour, minute, second, Latitude, Longitude, Quality1cr, scLatitude, scLongitude, scAltitude,satAzimuthAngle1cr, solarAzimuthAngle1cr, solarZenAngle1cr, incidenceAngle1cr, Tb1cr, GranuleNumber, NumberScansBeforeGranule,NumberScansGranule, NumberScansAfterGranule, sunGlintAngle1cr, MissingData,need_date,need_syn,exitStatus) + + +! CALL write_gmi_bufr_1cr(prefix, gmi_version, nscan, npixel, nchanlall, year, month, day, hour, minute, second,& +! Latitude, Longitude, Quality1cr, scLatitude, scLongitude, scAltitude,satAzimuthAngle1cr,& +! solarAzimuthAngle1cr, solarZenAngle1cr, incidenceAngle1cr, & +! Tb1cr, GranuleNumber, NumberScansBeforeGranule,NumberScansGranule, NumberScansAfterGranule, & +! sunGlintAngle1cr, MissingData,need_date,need_syn,exitStatus) + + +! JIANJUN - YELENA November 2015 +! RFIflag1cr - additional argument + + + + CALL write_gmi_bufr_1cr(prefix, gmi_version, nscan, npixel, nchanlall, year, month, day, hour, minute, second,& + Latitude, Longitude, Quality1cr, scLatitude, scLongitude, scAltitude,satAzimuthAngle1cr,& + solarAzimuthAngle1cr, solarZenAngle1cr, incidenceAngle1cr, & + Tb1cr, GranuleNumber, NumberScansBeforeGranule,NumberScansGranule, NumberScansAfterGranule, & + sunGlintAngle1cr,RFIflag1cr, MissingData,need_date,need_syn,exitStatus) + + deallocate (year,month,day,hour,minute,second) + deallocate (Tb1cr) + deallocate (Quality1cr,incidenceAngle1cr, sunGlintAngle1cr) + deallocate (SClatitude,SClongitude,SCaltitude) + deallocate (Latitude, Longitude) + deallocate (satAzimuthAngle, solarAzimuthAngle, & + solarZenAngle) + deallocate (satAzimuthAngle1cr, solarAzimuthAngle1cr, & + solarZenAngle1cr) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +Contains + subroutine usage() + print *, 'Usage: gmi1cr_bufr.x [-d yyyymmdd] [-t synoptic] \ ' + print *, ' h5filename ' + print *, ' -d need_date optional: date to process ' + print *, ' -t need_syn optional: synoptic to process ' + print *, ' h5filename name of input HDF5 file ' + stop + + end subroutine usage + + + Function inquire_attr_sub(attr_buffer, attrsub_name) result(attrsub_ival) +! find the substring attrsub_name. +!--------------------------------------------------------------------------- + IMPLICIT NONE + CHARACTER (LEN =*),INTENT(IN) :: attr_buffer + character (len=*), INTENT(IN) :: attrsub_name + integer*8 :: attrsub_ival + character(len=100) :: attrsub_cval + integer :: str_id0, str_ida, str_id1, str_id2,& + str_idx, str_idy + + str_id0 = index(attr_buffer, attrsub_name) + if (str_id0 <= 0) then + print *, attrsub_name, ' is not found in ' + print *, attr_buffer + attrsub_ival = -999 + print *, ' attrsub_ival = -999 ' + return + endif + str_ida = len(attr_buffer) + str_id1 = index( attr_buffer(str_id0:str_ida),'=') + str_id2 = index( attr_buffer(str_id0:str_ida),';') + str_idx = str_id0 + str_id1 + str_idy = str_id0 + str_id2 - 2 + attrsub_cval = attr_buffer(str_idx:str_idy) + read(attrsub_cval,'(I10)') attrsub_ival + + END function inquire_attr_sub + +END PROGRAM ONECR_HDF_to_BUFR +! + + diff --git a/util/GMI_BUFR_gen/gmi/src/hdf5rd_mod.f90 b/util/GMI_BUFR_gen/gmi/src/hdf5rd_mod.f90 new file mode 100644 index 000000000..2a0c3e717 --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/src/hdf5rd_mod.f90 @@ -0,0 +1,184 @@ +!########################################################################### +! Program history log: +! 2014-02-24 J.Jin -- READ GMI 1B/1C proxy data in HDF5 format +! 2014-06-10 ejones -- Read GMI 1CR data in HDF5 format +! 2014-06-23 J.Jin -- Made this general HDF5 reading module for integer and +! real type datasets in order to reorganize the GMI HDF +! reading subroutine. +! +! +! Subprograms called: +! Library: +! HDF5 - h5open_f h5close_f h5fopen_f h5fclose_f +! h5gopen_f h5gclose_f +! h5aopen_f h5aget_space_f h5aget_info_f h5aget_type_f +! h5aread_f h5aclose_f +! h5dopen_f h5dread_f h5dclose_f +! +!########################################################################### + +module hdf5rd_mod + + USE HDF5 +!--------------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(HID_T) :: file_id, group_id, dset_id, attr_id, space_id, memtype_id,& + type_id, error, subgroup_id, subdset_id + + +contains + + + subroutine hdf5rd_i(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,dataset) +! +! read hdf5 integer dataset + +! input: inputFileName,groupname,dsetname,dim1,dim2,dim3 +! output: dataset + + CHARACTER (LEN = 80),intent(in) :: inputFileName, groupname, subgroupname, dsetname + integer, intent(in) :: dim1,dim2,dim3 + integer, intent(out) :: dataset(dim1,dim2,dim3) + INTEGER(HSIZE_T),DIMENSION(:), allocatable :: data_dims + + + if (dim1 > 1 .and. dim2 > 1 .and. dim3 > 1) then + allocate( data_dims(3) ) + data_dims(1)=dim1 + data_dims(2)=dim2 + data_dims(3)=dim3 + else if (dim1 > 1 .and. dim2 > 1 .and. dim3 ==1) then + allocate( data_dims(2) ) + data_dims(1)=dim1 + data_dims(2)=dim2 + else if (dim1 > 1 .and. dim2 ==1 .and. dim3 ==1) then + allocate( data_dims(1) ) + data_dims(1)=dim1 + else + write(6,*) 'dim1, dim2, dim3 must >=1. ' + write(6,*) 'stop at hdf5rd_i' + return + endif + + ! Initialize FORTRAN interface. + CALL h5open_f(error) + ! Open file to read VD (table) information + call h5fopen_f(trim(inputFileName), H5F_ACC_RDONLY_F, file_id, error) + if(error /=0) call error_message(1, inputFileName) + call h5gopen_f(file_id, trim(groupname), group_id, error) + if(error /=0) call error_message(2, groupname) + if( len(trim(subgroupname)) > 0 ) then + call h5gopen_f(group_id, trim(subgroupname), subgroup_id, error) + if(error /=0) call error_message(3, subgroupname) + call h5dopen_f(subgroup_id, trim(dsetname), dset_id, error) + if(error /=0) call error_message(4, dsetname) + call h5dget_type_f(dset_id, type_id, error) + !call h5dread_f(dset_id, type_id, dataset, data_dims, error) + call h5dread_f(dset_id, H5T_NATIVE_INTEGER, dataset, data_dims, error) + print *, 'read: ', trim(groupname),'/',trim(subgroupname), '/', trim(dsetname) + call h5dclose_f(dset_id, error) + call h5gclose_f(subgroup_id, error) + else + call h5dopen_f(group_id, trim(dsetname), dset_id, error) + if(error /=0) call error_message(4, dsetname) + call h5dget_type_f(dset_id, type_id, error) + !call h5dread_f(dset_id, type_id, dataset, data_dims, error) + call h5dread_f(dset_id, H5T_NATIVE_INTEGER, dataset, data_dims, error) + print *, 'read: ', trim(groupname), '/', trim(dsetname) + call h5dclose_f(dset_id, error) + endif + call h5gclose_f(group_id, error) + call h5fclose_f(file_id, error) + IF( error == -1) THEN + PRINT *, 'FAILED TO Close: ', inputFileName + STOP + ELSE + END IF + call h5close_f(error) + deallocate(data_dims) + end subroutine hdf5rd_i + + + subroutine hdf5rd_f(inputFileName,groupname,subgroupname,dsetname,dim1,dim2,dim3,dataset) +! +! read hdf5 real type dataset + +! input: inputFileName,groupname,dsetname,dim1,dim2,dim3 +! output: dataset + + CHARACTER (LEN = 80),intent(in) :: inputFileName, groupname, subgroupname, dsetname + integer, intent(in) :: dim1,dim2,dim3 + real, intent(out) :: dataset(dim1,dim2,dim3) + INTEGER(HSIZE_T),DIMENSION(:), allocatable :: data_dims + + + if (dim1 > 1 .and. dim2 > 1 .and. dim3 > 1) then + allocate( data_dims(3) ) + data_dims(1)=dim1 + data_dims(2)=dim2 + data_dims(3)=dim3 + else if (dim1 > 1 .and. dim2 > 1 .and. dim3 ==1) then + allocate( data_dims(2) ) + data_dims(1)=dim1 + data_dims(2)=dim2 + else if (dim1 > 1 .and. dim2 ==1 .and. dim3 ==1) then + allocate( data_dims(1) ) + data_dims(1)=dim1 + else + write(6,*) 'dim1, dim2, dim3 must >=1. ' + write(6,*) 'stop at hdf5rd_f' + return + endif + + ! Initialize FORTRAN interface. + CALL h5open_f(error) + ! Open file to read VD (table) information + call h5fopen_f(trim(inputFileName), H5F_ACC_RDONLY_F, file_id, error) + if(error /=0) call error_message(1, inputFileName) + call h5gopen_f(file_id, trim(groupname), group_id, error) + if(error /=0) call error_message(2, groupname) + if( len(trim(subgroupname)) > 0 ) then + call h5gopen_f(group_id, trim(subgroupname), subgroup_id, error) + if(error /=0) call error_message(3, subgroupname) + call h5dopen_f(subgroup_id, trim(dsetname), dset_id, error) + if(error /=0) call error_message(4, dsetname) + call h5dget_type_f(dset_id, type_id, error) + !call h5dread_f(dset_id, type_id, dataset, data_dims, error) + call h5dread_f(dset_id, H5T_NATIVE_REAL, dataset, data_dims, error) + print *, 'read: ', trim(groupname),'/',trim(subgroupname), '/', trim(dsetname) + call h5dclose_f(dset_id, error) + call h5gclose_f(subgroup_id, error) + else + call h5dopen_f(group_id, trim(dsetname), dset_id, error) + if(error /=0) call error_message(4, dsetname) + call h5dget_type_f(dset_id, type_id, error) + !call h5dread_f(dset_id, type_id, dataset, data_dims, error) + call h5dread_f(dset_id, H5T_NATIVE_REAL, dataset, data_dims, error) + print *, 'read: ', trim(groupname),'/', trim(dsetname) + call h5dclose_f(dset_id, error) + endif + call h5gclose_f(group_id, error) + call h5fclose_f(file_id, error) + IF( error == -1) THEN + PRINT *, 'FAILED TO Close: ', inputFileName + STOP + END IF + call h5close_f(error) + deallocate(data_dims) + end subroutine hdf5rd_f + + subroutine error_message(errnumber, varname) + CHARACTER (LEN = 80),intent(in) :: varname + integer, intent(in) :: errnumber + if (errnumber ==1) then + print *, 'file is not found: ', trim(varname) + else if (errnumber ==2) then + print *, 'group is not found: ', trim(varname) + else if (errnumber ==3) then + print *, 'subgroup is not found: ', trim(varname) + else if (errnumber ==4) then + print *, 'dataset is not found: ', trim(varname) + endif + stop + end subroutine error_message +end module hdf5rd_mod diff --git a/util/GMI_BUFR_gen/gmi/src/info_compile b/util/GMI_BUFR_gen/gmi/src/info_compile new file mode 100644 index 000000000..33bf185db --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/src/info_compile @@ -0,0 +1,15 @@ + +1. Set GEOSDAS variable in Make. +2. Use that setting in the command below. + + > rm hdf5rd_mod.mod + module purge + source $GEOSDAS/Linux/bin/g5_modules + +========================================= + + Do MAKE twice. + + > Make --> creates hdf5rd_mod.mod + issued error messages + > Make creates executable diff --git a/util/GMI_BUFR_gen/gmi/src/wr_gmi_bufr_1cr.f90 b/util/GMI_BUFR_gen/gmi/src/wr_gmi_bufr_1cr.f90 new file mode 100644 index 000000000..61d8a6f70 --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/src/wr_gmi_bufr_1cr.f90 @@ -0,0 +1,441 @@ +SUBROUTINE write_gmi_bufr_1cr(prefix, version, nscan, npixel, nchan, & + year, mon, day, hour, minu, seco, & + lat, lon, Quality, & + scLat, scLon, scAlt, & + satAzimuthAngle, solarAzimuthAngle, solarZenAngle, incidenceAngle, & + Tb, & + GranuleNumber, NumberScansBeforeGranule,NumberScansGranule, & + NumberScansAfterGranule, sunGlintAngle1c, RFIflag,MissingData,& + need_date,need_syn, & + exitCode) +! 08/20/2015 J.Jin-Yelena Add NEW ARGUMENT - RFIflag. + +! 12-10-2012 J.Jin Modified from Santha's code. +! output to tmi.%y4%m2%d2.t%h2z.bufr. +! 01-26-2014 J.Jin (1) Re-orgnize the bufr table and the output procedure. +! Now the bufr file has a MG containing TMI general information +! and channel information at the beginning, and other MGs containing +! scans which has 208 SB for the pixcels. +! (2) Added a check of the existing bufr file to which obs are being +! appended. If these data are in the existing bufr file, these obs +! are not written out. Only new obs are appended to the bufr file. +! 03-00-2014 E.Jones Modifications for GMI +! +! 03-25-2014 J.Jin Modify the check process. Now it checks time (seconds from 00:00z Jan 01, 2013) +! in the existing bufr in order to avoid overlap output. +! Merger all subroutines for L1B_S1, L1B_S2, L1C_S1 and L1C_S2 into +! one subroutine through adding an input variable prefix. +! clean up. +! 03-27-2014 J.Jin Separate subroutines for 1B and 1C. Couldn't get all integer inputs +! correctly when they in one subroutine. +! +! 06-11-2014 ejones modified for GMI L1CR data. +! 06-24-2014 J.Jin revise outputs according to a new BUFR table. +! 10/10/2014 Yelena Add 'need_date,need_syn' as Input subroutine ymd_thhz.f90 +! --> to write Bufr only for needed date,needed synoptic +! and get back tak(2) , means: +! tak(i) = 0 , do not take file "i" +! tak(i) = 1 , take file "i" + +! 11-06-2014 J.Jin Revise the saving of data version. V03A which was saved as V3, but +! now is saved as V3.01. + +! 20-08-2015 J.Jin Merge Erin Jones's code to write out RFIflag. +! 27-10-2015 J.Jin Write satellite altitude (HMSL) values in unit meter. It is in km in 1C-R HDF files, +! but should be saved in meter in BUFR files. (Note, it is in me ter in 1B HDF files.) + +!--------------------------------------------------------------------------- + IMPLICIT NONE + EXTERNAL :: ymdhms2tim13 + + INTEGER, PARAMETER :: ngs=2 +! INTEGER, INTENT(IN) :: version, nscan, npixel, nchan ! npixello, nchanlo, nchanhi + +! 11/06/2014 J. Jin + INTEGER, INTENT(IN) :: nscan, npixel, nchan ! npixello, nchanlo, nchanhi + REAL*4, INTENT(IN) :: version + + INTEGER*4, INTENT(IN) :: year(nscan) + INTEGER*4, INTENT(IN) :: mon(nscan), day(nscan), & + hour(nscan), minu(nscan), seco(nscan) + INTEGER*4, INTENT(IN) :: Quality(nchan, npixel, nscan),sunGlintAngle1c(ngs,npixel,nscan) + +! 20-08-2015 J.Jin +! ADDED RFIflag(nchan, npixel, nscan) + INTEGER*4, INTENT(IN) :: RFIflag(nchan, npixel, nscan) + + REAL*4, INTENT(IN) :: lat(npixel,nscan), lon(npixel,nscan), & + satAzimuthAngle(ngs, npixel,nscan), & + solarAzimuthAngle(ngs, npixel,nscan), & + solarZenAngle(ngs, npixel,nscan), & + incidenceAngle(ngs, npixel,nscan) + INTEGER, INTENT(IN) :: GranuleNumber, NumberScansBeforeGranule, & + NumberScansGranule, NumberScansAfterGranule, & + MissingData + + REAL*4, INTENT(IN) :: scLon(nscan), scLat(nscan), scAlt(nscan) + + REAL*4, INTENT(IN) :: Tb(nchan, npixel, nscan) + character(len=80),INTENT(IN) :: prefix + integer, INTENT(IN) :: need_date,need_syn + + + INTEGER, INTENT(OUT) :: exitCode + + INTEGER :: unit_table = 20 + INTEGER :: unit_out = 10 + + + INTEGER :: nObs, nBad, nGood + INTEGER*8 :: iScan, iPixel, iChan, iDate, & + IRET, iBad, iGood + + REAL :: XTEMP = 999 + + + INTEGER :: npxllo, npxl + CHARACTER (LEN = 8) :: subset = 'NC021204' + CHARACTER (LEN = 8) :: subset0 = 'NC021200' + CHARACTER (LEN = 80) :: subset_ex + CHARACTER(len=80) :: scaninfo, gmiinfo ! scan message + REAL*8 :: scaninfo_v(11) ! scan message + REAL*8 :: gmiinfo_v(5) + + INTEGER :: nch +! REAL*8 :: gmichq(nchan,nscan), gmichq_v(nchan) ! qulity for chanels + + +! 10/03/2015 +! 20-08-2015 J.Jin +! Added gmi_rfi(nchan ) + REAL*8 :: gmichq(nchan,nscan), gmichq_v(nchan), gmi_rfi(nchan) ! qulity for chanels + + + REAL*8 :: geoloc(2), tmbr_v(nchan),iang_v(ngs),sga_v(ngs) + real*8 :: fov(nchan), gmi_ina(ngs) + + character(len=80) :: outfile, bufrtbfile, frmt + character(len=13) :: ymdthrz(2) + integer :: id_oa(2), id_ob(2), nfile, iScan_x1, iScan_x2 + integer :: tak(2) + logical :: ex, ex_obit, new_scan + + real*8 :: orbn_v, scan_v, jdate + integer*8, parameter :: nsc_max = 50000 ! a large number of scans in the obit in an existing bufr file. + integer :: ireadmg, ireadsb, img, nsb, nsc, scan_old0(nsc_max) + integer, allocatable :: scan_old(:) + REAl*8 :: ymdhms(6) + integer*8 :: tim13_old0(nsc_max),tim13 + integer*8, allocatable :: tim13_old(:) + + INTEGER, PARAMETER :: nch1=9,nch2=4,nch3=13 +! real*8 :: SCCF1(nch1),SCBW1(nch1),ANPO1(nch1),CHNM1(nch1) +! real*8 :: SCCF2(nch2),SCBW2(nch2),ANPO2(nch2),CHNM2(nch2) +! real*8, allocatable :: SCCF(:),SCBW(:),ANPO(:),CHNM(:) + real*8 :: SCCF(13),SCBW(13),ANPO(13),CHNM(13) + real*4 :: scAlt_meter(nscan) + + + !GHz +! data SCCF1 /10.65,10.65, 18.70,18.70, 23.80, 36.50,36.50, 89.00,89.00/ + !MHz +! data SCBW1 /100,100, 200,200, 400, 1000,1000, 6000,6000/ +! data ANPO1 /1,0, 1,0, 1, 1,0, 1,0/ ! (1, vertical; 0, horizontal) polarization +! data CHNM1 /1,2,3,4,5,6,7,8,9/ +! data SCCF2 /166.0,166.0, 183.31, 183.31/ +! data SCBW2 /3400, 3400, 2000, 2000/ +! data ANPO2 /1, 0, 1, 1/ ! (1, vertical; 0, horizontal) polarization +! data CHNM2 /10,11,12,13/ + data SCCF /10.65,10.65,18.70,18.70,23.80,36.50,36.50,89.00,89.00,166.0,166.0,183.31,183.31/ + !MHz + data SCBW /100,100, 200,200,400,1000,1000,6000,6000,3400,3400,2000,2000/ + data ANPO /1,0, 1,0, 1, 1,0, 1,0, 1, 0, 1, 1/ ! (1, vertical; 0, horizontal) polarization + data CHNM /1,2,3,4,5,6,7,8,9,10,11,12,13/ +! nch=nchan +! allocate( SCCF(nch),SCBW(nch),ANPO(nch),CHNM(nch) ) +! if(nch==9) then +! bufrtbfile = 'GMI_bufr_table_S1' +! SCCF = SCCF1 +! SCBW = SCBW1 +! ANPO = ANPO1 +! CHNM = CHNM1 +! elseif(nch==4) then +! bufrtbfile = 'GMI_bufr_table_S2' +! SCCF = SCCF2 +! SCBW = SCBW2 +! ANPO = ANPO2 +! CHNM = CHNM2 +! elseif(nch==13) then + + bufrtbfile = 'GMI_bufr_table_1CR' +! SCCF = SCCF1cr +! SCBW = SCBW1cr +! ANPO = ANPO1cr +! CHNM = CHNM1cr +! endif + !change unit: => Hz + SCCF = SCCF*1e+9 + SCBW = SCBW*1e+6 + nch=13 +! + +! +! 20-08-2015 J.Jin +! In meter ( not km ) + + scAlt_meter=scAlt*1000 ! unit change, km => meter +!--------------------------------------------------------------------------- + +!--------------------------------------------------------------------------- +! Initialize +!--------------------------------------------------------------------------- + nObs = 0; nBad = 0; nGood = 0 + + gmiinfo='SAID SIID OGCE GSES SACV' + gmiinfo_v(1) = 288 ! SAID -satellite id + gmiinfo_v(2) = 519 ! SIID -Satellite instruments + gmiinfo_v(3) = 173 ! OGCE -implies that NASA is the originator of this bufr data + gmiinfo_v(4) = 0 ! GSES -no sub-center + gmiinfo_v(5) = version ! SACV - version of source GMI data + + scaninfo='ORBN SLNM SCLON SCLAT HMSL & + YEAR MNTH DAYS HOUR MINU SECO' + scaninfo_v( :) = XTEMP ! missing data. (JJJ) 999 exceeds the limit for some data + ! (i.e., TMBR*(10^2): 0-2^(16-1). Therefore, TMBR is the default missing data 1e+12 in bufr). + print*, 'Writing data into a bufr file.' +!--------------------------------------------------------------------------- + iScan_x1 = NumberScansBeforeGranule+1 + iScan_x2 = nscan-NumberScansAfterGranule + print*, ' iScan_x1, iScan_x2', iScan_x1, iScan_x2 + print*, ' Fist scan ddhhmmss', day(iScan_x1), hour(iScan_x1), minu(iScan_x1),seco(iScan_x1) + print*, ' Last scan ddhhmmss', day(iScan_x2), hour(iScan_x2), minu(iScan_x2),seco(iScan_x2) + +! stop + call ymd_thhz(nscan, iScan_x1, iScan_x2, & + year, mon, day, hour, & + need_date,need_syn, & + ymdthrz, id_oa, id_ob,tak) + print*, 'id_oa = ', id_oa + print*, 'id_ob = ', id_ob + print*, 'ymdthrz = ', ymdthrz + print*, 'tak = ', tak + +! stop + + bufrfile: do nfile=1, 2 ! no more than 2 files for one orbit. + print*, '================================================================' +! YELENA tak(nfile) =0 means file is not for need_date or need_syn +! we skip it + if (id_oa(nfile)< 0.or.tak(nfile).eq.0) cycle bufrfile + outfile = trim(prefix) // ymdthrz(nfile) // '.bufr' +!--------------------------------------------------------------------------- + OPEN(unit_table, FILE = bufrtbfile, ACTION = 'read') +! Check the status of the output file. + ! check if the file exists. + inquire(file=outfile,exist=ex) + if (ex) then + !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + ! check the existing bufr file. + ex_obit=.FALSE. + OPEN(unit_out, FILE = outfile, status='old', FORM='unformatted') + call openbf(unit_out,'IN',unit_out) + call datelen(10) + img =1 + nsb = 0 + nsc = 1 + msg_report: do while (ireadmg(unit_out, subset_ex,jdate) == 0) + sb_report: do while (ireadsb(unit_out) == 0) + if(img==1) exit sb_report + call ufbint(unit_out, orbn_v, 1, 1, iret, 'ORBN') + if(abs(orbn_v - GranuleNumber) < 1e-10) then + ex_obit=.TRUE. + call ufbint(unit_out, scan_v, 1, 1, iret, 'SLNM') !scan number + call ufbint(unit_out, ymdhms, 6, 1, iret, 'YEAR MNTH DAYS HOUR MINU SECO') + call ymdhms2tim13(tim13,ymdhms) + nsb=nsb +1 + if(nsb ==1) then + scan_old0(nsc) = int(scan_v) + tim13_old0(nsc) = tim13 + endif + if (int(scan_v) /= scan_old0(nsc) )then + nsc = nsc + 1 + scan_old0(nsc) = int(scan_v) + call ymdhms2tim13(tim13,ymdhms) + tim13_old0(nsc) = tim13 + endif + endif + exit sb_report ! only check the fist pixel for the scan number. + enddo sb_report + img = img + 1 + enddo msg_report + call closbf(unit_out) + close(unit_out) + if( nsc > nsc_max ) then + print*, 'existing obit, nsc=',nsc + print*, 'Therefore, need increase nsc_max in sub wr_gmi_bufr.' + print*, 'ERROR.Program stopped at sub wr_gmi_bufr.' +! J.Jin 11/06/2014 + stop + endif + new_scan=.TRUE. + if(ex_obit) then + if( allocated(scan_old) ) deallocate(scan_old) + if( allocated(tim13_old) ) deallocate(tim13_old) + allocate(scan_old(nsc)) + allocate(tim13_old(nsc)) + scan_old(1:nsc) = scan_old0(1:nsc) + tim13_old(1:nsc) = tim13_old0(1:nsc) + new_scan=.false. + isck_loop: DO iScan = id_oa(nfile), id_ob(nfile) + !nsb = iScan-NumberScansBeforeGranule + !if( minval(abs(scan_old - nsb)) > 0 ) then + ! new_scan=.TRUE. !a new obs is not in the existing file. + ! exit isck_loop + !endif + ymdhms(1) = REAL( year(iScan)) ! YEAR + ymdhms(2) = REAL( mon (iScan)) ! MONTH + ymdhms(3) = REAL( day (iScan)) ! DAY + ymdhms(4) = REAL( hour(iScan)) ! HOUR + ymdhms(5) = REAL( minu(iScan)) ! Minute + ymdhms(6) = REAL( seco(iScan)) ! Second + call ymdhms2tim13(tim13,ymdhms) + if( minval(abs(tim13_old - tim13)) > 0 ) then + new_scan=.TRUE. !a new obs is not in the existing file. + exit isck_loop + endif + ENDDO isck_loop + if(.not. new_scan) then + write(*,*) 'OBS data for orib ', GranuleNumber, ' and scans between' + write(*,*) id_oa(nfile), 'and ', id_ob(nfile), 'are already in file ' + write(*,*) trim(outfile) + write(*,*) 'Therefore, OBS data are not written in the bufr file.' + cycle bufrfile + endif + endif ! ex_obit + !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + + if(new_scan) then + print *,'Append to the output file ',trim(outfile) + OPEN(unit_out, FILE = outfile, status='old', FORM='unformatted') + endif + else + print *,'Create new an output file ',trim(outfile) + OPEN(unit_out, FILE = outfile, ACTION = 'write', FORM='unformatted') + endif + + ! Specify date format: YYYYMMDDHH + CALL datelen(10) + + ! Connect bufrtable, bufr file to bufr lib + !--------------------------------------------------------------------------- + if (ex) then + CALL openbf(unit_out, 'APN', unit_table) + else + CALL openbf(unit_out, 'OUT', unit_table) + endif + ! .......................................................................... + print*, ' output scans: ', id_oa(nfile), id_ob(nfile) + print*, ' start ddhhmmss', day(id_oa(nfile)), hour(id_oa(nfile)), minu(id_oa(nfile)),seco(id_oa(nfile)) + print*, ' end ddhhmmss', day(id_ob(nfile)), hour(id_ob(nfile)), minu(id_ob(nfile)),seco(id_ob(nfile)) + DO iScan = id_oa(nfile), id_ob(nfile) ! write whole or a part of the obit + nsb = iScan-NumberScansBeforeGranule + scaninfo_v( 1) = GranuleNumber ! ORBN -Orbit number-- has to be extracted from hdf file name + scaninfo_v( 2) = nsb ! SLNM -Scan line number-- +! scaninfo_v( 3) = REAL( geoQuality (iScan)) ! NGQI -Geolocation quality + scaninfo_v( 3) = scLon(iScan) ! SCLON -geodedic longitude of the spacecraft, scLon in HDF file. + scaninfo_v( 4) = scLat(iScan) ! SCLAT -geodedic latitude of the spacecraft, scLat in HDF file. +! scaninfo_v( 5) = scAlt(iScan) ! HMSL -Height or altitude- comes from scAlt in HDF file + +! 20-08-2015 J.Jin +! In meter ( not km) + scaninfo_v( 5) = scAlt_meter(iScan) ! HMSL -Height or altitude- comes from scAlt_meter in HDF file + + ! YYMMDD + scaninfo_v( 6) = REAL( year(iScan)) ! YEAR + scaninfo_v( 7) = REAL( mon (iScan)) ! MONTH + scaninfo_v( 8) = REAL( day (iScan)) ! DAY + ! HHMMSS + scaninfo_v( 9) = REAL( hour(iScan)) ! HOUR + scaninfo_v(10) = REAL( minu(iScan)) ! Minute + scaninfo_v(11) = REAL( seco(iScan)) ! Second + iDate = year(iScan)*1000000+mon(iScan)*10000+day(iScan)*100+hour(iScan) + call ymdhms2tim13(tim13,scaninfo_v(6:11)) + !if( ex .and. ex_obit .and. minval(abs(scan_old - nsb)) == 0 .and. & + ! minval(abs(tim13_old - tim13)) == 0 ) cycle ! not to write out this iScan + if( ex .and. ex_obit .and. & + minval(abs(tim13_old - tim13)) == 0 ) cycle ! not to write out this iScan + + + if( iScan == id_oa(nfile) ) then + if (.not. ex) then ! only write out in a new bufr file. + call openmb(unit_out,subset0,iDate) + call ufbint(unit_out,gmiinfo_v,5,1,iret, gmiinfo) + call ufbrep(unit_out,CHNM,1,nch,iret,'CHNM') + call ufbrep(unit_out,SCCF,1, nch, iret, 'SCCF') + call ufbrep(unit_out,SCBW,1, nch, iret, 'SCBW') + call ufbrep(unit_out,ANPO,1, nch, iret, 'ANPO') + CALL WRITSB(unit_out) ! write the above data subset to the current message type + CALL CLOSMG(unit_out) + endif + endif + + call openmb(unit_out,subset,iDate) + do iPixel = 1, nPixel + call ufbint(unit_out,scaninfo_v(1:11),11,1,iret, scaninfo) + !call ufbint(unit_out,geoQuality(iScan),1,1,iret, 'NGQI') +! print *, 'GMISQ, NGQI', scaninfo_v( 3), geoQuality(iScan) + ! for the pixels in each scan. + geoloc(1) = lat(iPixel, iScan) + geoloc(2) = lon(iPixel, iScan) + fov(1:nch)=iPixel + ! for TMBR, SAZA, SGA + tmbr_v(1:nchan) = Tb(:, iPixel, iScan) + gmichq_v(:) = real(Quality(:, iPixel, iScan)) + +! 20-08-2015 J.Jin + gmi_rfi(:) = real(RFIflag(:, iPixel, iScan)) + + call ufbint(unit_out,geoloc,2,1,iret,'CLATH CLONH') + call ufbint(unit_out,fov(1),1,1,iret,'FOVN') + call ufbrep(unit_out,CHNM,1,nch,iret,'CHNM') + call ufbrep(unit_out,gmichq_v, 1, nch, iret, 'GMICHQ') + +! 20-08-2015 J.Jin + call ufbrep(unit_out,gmi_rfi, 1, nch, iret, 'GMIRFI') + + call ufbrep(unit_out,tmbr_v, 1, nch, iret, 'TMBR') + + iang_v(1:ngs) = incidenceAngle(:, iPixel, iScan) + call ufbrep(unit_out,iang_v, 1, ngs, iret, 'SAZA') + gmi_ina(1:ngs) = satAzimuthAngle(:,iPixel,iScan) + call ufbrep(unit_out,gmi_ina,1, ngs, iret,'SAMA') + gmi_ina(1:ngs) = solarAzimuthAngle(:,iPixel,iScan) + call ufbrep(unit_out,gmi_ina,1, ngs, iret,'SMA') + gmi_ina(1:ngs) = solarZenAngle(:,iPixel,iScan) + call ufbrep(unit_out,gmi_ina,1, ngs, iret,'SZA') + sga_v(1:ngs) = sunGlintAngle1c(:, iPixel, iScan) + call ufbrep(unit_out,sga_v, 1, ngs, iret, 'SGA') + + CALL WRITSB(unit_out) ! write the above data subset to the current message type + enddo + CALL CLOSMG(unit_out) + ! end of the pixels + END DO ! iScan = 1, nscan +! .......................................................................... + +! Close bufr file +!--------------------------------------------------------------------------- + CALL closbf(unit_out) + + CLOSE(unit_table) + CLOSE(unit_out) + + exitCode = IRET + +!--------------------------------------------------------------------------- + enddo bufrfile + !deallocate( SCCF,SCBW,ANPO,CHNM ) + print*, '================================================================' + print*, 'done' +END SUBROUTINE write_gmi_bufr_1cr +! diff --git a/util/GMI_BUFR_gen/gmi/src/ymd_thhz.f90 b/util/GMI_BUFR_gen/gmi/src/ymd_thhz.f90 new file mode 100644 index 000000000..8a147af0e --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/src/ymd_thhz.f90 @@ -0,0 +1,173 @@ +! 12-10-2012 J.Jin assign scans to different 6-hr periods (max=2). +! so that scans can be saved in different files +! output format: %y4%m2%d2_t%h2z +! 10/10/2014 Yelena Add 'need_date,need_syn' as Input --> to write +! Bufr only for needed date,synoptic +! Add output tak(2) +! tak(i) = 0 , do not take file "i" +! tak(i) = 1 , take file "i" + +!======================================================================= + subroutine ymd_thhz(nscan, iScan_x1, iScan_x2, & + year, mon, day, hour, & + need_date,need_syn, & + ymdthrz, id_oa, id_ob,tak) + implicit none + INTEGER, INTENT(IN) :: year(nscan) + INTEGER, INTENT(IN) :: mon(nscan), day(nscan), & + hour(nscan) + integer, INTENT(IN) :: nScan + integer, INTENT(IN) :: iScan_x1,iScan_x2 + integer, INTENT(IN) :: need_date,need_syn + integer :: iof, iScan_x1b, n,ii + character(len=13),INTENT(out):: ymdthrz(2) + integer, INTENT(OUT) :: id_oa(2), id_ob(2) + character(len=8) :: want_date + + character(len=13) :: need_yymmddhr, want_yymmddhr + + character(len=13) :: yymmddhr, yymmddhr0 + integer :: mm,dd,mm_day(12),mm_dayb(12),hr + integer :: yy,ntak(2) + integer, INTENT(OUT) :: tak(2) + data mm_day /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ + data mm_dayb /31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ + + tak(1) = 0 + tak(2) = 0 + ntak(1) = 0 + ntak(2) = 0 + + write(want_date,'(i8.4)') need_date + + + write(need_yymmddhr,'(i8.4,''.t'',i2.2,''z'')') & + need_date,need_syn + + write(want_yymmddhr,'(A8,''.t'',i2.2,''z'')') & + want_date,need_syn + + + ! the first ymdthrz + iof = 1 + n = iScan_x1 + yy = year(n) + mm = mon(n) + dd = day(n) + + if ( hour(n) < 3 ) then + hr = 0 + elseif ( hour(n) < 9 ) then + hr = 6 + elseif ( hour(n) < 15 ) then + hr = 12 + elseif ( hour(n) < 21 ) then + hr = 18 + else + hr = 0 + dd = dd + 1 + if ( mod(yy,4) /= 0 ) then + if ( dd > mm_day(mm) ) then + dd = 1 + mm = mm +1 + if (mm > 12) then + mm = 1 + yy = yy + 1 + endif + endif + else + if ( dd > mm_dayb(mm) ) then + dd = 1 + mm = mm +1 + if (mm > 12) then + mm = 1 + yy = yy + 1 + endif + endif + endif + endif + + write(yymmddhr0,'(i4.4,i2.2,i2.2,''.t'',i2.2,''z'')') & + yy,mm,dd,hr + + ymdthrz(iof) = yymmddhr0 + id_oa(iof) = iScan_x1 + id_ob(iof) = iScan_x2 + id_oa(2) = -999 + id_ob(2) = -999 + + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + iScan_x1b = iScan_x1+1 + do n = iScan_x1b, iScan_x2 + yy = year(n) + mm = mon(n) + dd = day(n) + if ( hour(n) < 3 ) then + hr = 0 + elseif ( hour(n) < 9 ) then + hr = 6 + elseif ( hour(n) < 15 ) then + hr = 12 + elseif ( hour(n) < 21 ) then + hr = 18 + else + hr = 0 + dd = dd + 1 + if ( mod(yy,4) /= 0 ) then + if ( dd > mm_day(mm) )then + dd = 1 + mm = mm +1 + if (mm > 12) then + mm = 1 + yy = yy + 1 + endif + endif + else + if ( dd > mm_dayb(mm) ) then + dd = 1 + mm = mm +1 + if (mm > 12) then + mm = 1 + yy = yy + 1 + endif + endif + endif + + endif + + write(yymmddhr,'(i4.4,i2.2,i2.2,''.t'',i2.2,''z'')') & + yy,mm,dd,hr + if (yymmddhr .ne. yymmddhr0 ) then + yymmddhr0 = yymmddhr + iof = iof + 1 + if ( iof > 2 ) then + print *, 'The obit expands over 6 hours! check the HDF file' + print *, 'Stop at ymd_thhz.f90' + stop + endif + ymdthrz(iof) = yymmddhr + id_ob(iof-1) = n-1 + id_oa(iof) = n + endif + enddo + id_ob(iof) = iScan_x2 + ! no 2nd file + if ( id_oa(iof) < 0 ) id_ob(iof) = id_oa(iof) - 1 + + + do ii = 1,2 + if (ymdthrz(ii) .eq. want_yymmddhr) tak(ii) = 1 + enddo + + do ii = 1,2 + if (ymdthrz(ii) .eq. need_yymmddhr) ntak(ii) = 1 + enddo + + print *,' VNUTRI tak = ', tak + + print *,' VNUTRI ntak = ', ntak + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + end subroutine ymd_thhz diff --git a/util/GMI_BUFR_gen/gmi/src/ymdhms2tim13.f90 b/util/GMI_BUFR_gen/gmi/src/ymdhms2tim13.f90 new file mode 100644 index 000000000..155edea1e --- /dev/null +++ b/util/GMI_BUFR_gen/gmi/src/ymdhms2tim13.f90 @@ -0,0 +1,43 @@ + !subroutine ymdhms2tim13(tim13,yy,mo,dd,hh,mm,ss) + subroutine ymdhms2tim13(tim13, ymdhms) +! +! Derive seconds from from 00Z00 Jan 1, 2013. + +! input: +! yy,mo,dd,hh,mm,ss +! output: +! tim13, seconds from 00Z00 Jan 1, 2013 +! +! 2014-03-25 j.jin debut + + implicit none + REAl*8, intent(in) :: ymdhms(6) + integer*8, intent(out) :: tim13 + integer*4 :: yy,mo,dd,hh,mm,ss + integer*8 :: yrss,ddss,days + integer*4 :: mlen0(12),mlen(12) + integer*4 :: xyr,im + data mlen0/0, 31,28,31,30,31,30, & + 31,31,30,31,30/ + yy=int(ymdhms(1)) + mo=int(ymdhms(2)) + dd=int(ymdhms(3)) + hh=int(ymdhms(4)) + mm=int(ymdhms(5)) + ss=int(ymdhms(6)) + + mlen = mlen0 + if( mod(yy,4) == 0) mlen(3) = mlen(3) + 1 + yrss = 365*24*3600 + ddss = 24*3600 + + days =0 + do im = 1,mo + days = days + mlen(im) + enddo + days = days + dd - 1 + xyr = (yy-2013)/4 + tim13 = days * ddss + (yy-2013)*yrss + xyr*ddss & + + hh*3600 + mm*60 + ss + + end subroutine ymdhms2tim13 diff --git a/util/Minimization_Monitor/MinMon_install.pl b/util/Minimization_Monitor/MinMon_install.pl index dadfff2bf..d4d35597b 100755 --- a/util/Minimization_Monitor/MinMon_install.pl +++ b/util/Minimization_Monitor/MinMon_install.pl @@ -5,7 +5,8 @@ # # This script makes sets all configuration definitions # and calls the makeall.sh script to build all the necessary -# executables. This script works for wcoss, cray, and theia. +# executables. This script works for wcoss, wcoss_d, cray, and +# hera. # #------------------------------------------------------------------- @@ -15,7 +16,8 @@ my $machine = `/usr/bin/perl get_hostname.pl`; my $my_machine="export MY_MACHINE=$machine"; - if( $machine ne "theia" && $machine ne "wcoss" && $machine ne "cray" ) { + if( $machine ne "hera" && $machine ne "wcoss" && + $machine ne "wcoss_d" && $machine ne "cray" ) { die( "ERROR --- Unrecognized machine hostname, $machine. Exiting now...\n" ); } else { @@ -50,12 +52,15 @@ # TANKDIR location # my $user_name = $ENV{ 'USER' }; - if( $machine eq "theia" ) { - $tankdir = "/scratch2/portfolios/NCEPDEV/global/save/$user_name/nbns"; + if( $machine eq "hera" ) { + $tankdir = "/scratch1/NCEPDEV/da/$user_name/nbns"; } elsif( $machine eq "cray" ){ $tankdir = "/gpfs/hps/emc/da/save/$user_name/nbns"; } + elsif( $machine eq "wcoss_d" ){ + $tankdir = "/gpfs/dell2/emc/modeling/noscrub/$user_name/nbns"; + } else { $tankdir = "/global/save/$user_name/nbns"; } @@ -85,8 +90,8 @@ my $my_stmp=""; if( $machine eq "cray" ) { - $my_ptmp="export MY_PTMP=\${MY_PTMP:-/gpfs/hps2/ptmp}"; - $my_stmp="export MY_STMP=\${MY_STMP:-/gpfs/hps2/stmp}"; + $my_ptmp="export MY_PTMP=\${MY_PTMP:-/gpfs/hps2/ptmp/$user_name}"; + $my_stmp="export MY_STMP=\${MY_STMP:-/gpfs/hps2/stmp/$user_name}"; } elsif( $machine eq "wcoss" ) { @@ -139,6 +144,50 @@ print "\n\n"; sleep( 1 ); } + elsif( $machine eq "wcoss_d" ) { + $my_ptmp="export MY_PTMP=\${MY_PTMP:-/gpfs/dell2/ptmp/$user_name}"; + $my_stmp="export MY_STMP=\${MY_STMP:-/gpfs/dell2/stmp/$user_name}"; + } + elsif( $machine eq "hera" ) { + $ptmp = "/scratch2/NCEPDEV/stmp3/${user_name}"; + print "Please specify PTMP location. This is used for temporary work space.\n"; + print "\n"; + print " Return to accept default location or enter new location now.\n"; + print "\n"; + print " Default PTMP: $ptmp \n"; + print " ?\n"; + my $new_ptmp = <>; + $new_ptmp =~ s/^\s+|\s+$//g; + + if( length($new_ptmp ) > 0 ) { + $ptmp = $new_ptmp; + } + $my_ptmp="export MY_PTMP=\${MY_PTMP:-$ptmp}"; + print "my_ptmp = $my_ptmp\n"; + print "\n\n"; + sleep( 1 ); + + $stmp = "/scratch2/NCEPDEV/stmp3/${user_name}"; + print "Please specify STMP location. This is used for temporary work space.\n"; + print "\n"; + print " Return to accept default location or enter new location now.\n"; + print "\n"; + print " Default STMP: $stmp \n"; + print " ?\n"; + my $new_stmp = <>; + $new_stmp =~ s/^\s+|\s+$//g; + + if( length($new_stmp ) > 0 ) { + $stmp = $new_stmp; + } + $my_stmp="export MY_STMP=\${MY_STMP:-$stmp}"; + print "my_stmp = $my_stmp\n"; + print "\n\n"; + sleep( 1 ); + +# $my_ptmp="export MY_PTMP=\${MY_PTMP:-/scratch2/NCEPDEV/stmp3/${user_name}}"; +# $my_stmp="export MY_STMP=\${MY_STMP:-/scratch2/NCEPDEV/stmp1/${user_name}}"; + } # # Web sever name @@ -249,8 +298,8 @@ print "\n"; print "\n"; sleep( 2 ); - my $account = "export ACCOUNT=\${ACCOUNT:-glbss}"; - if( $machine ne "theia" ) { + my $account = "export ACCOUNT=\${ACCOUNT:-fv3-cpu}"; + if( $machine ne "hera" ) { $account = "export ACCOUNT=\${ACCOUNT:-}"; } @@ -260,8 +309,8 @@ my $project = "GDAS-T2O"; my $my_project = ""; - if( $machine ne "wcoss" && $machine ne "cray" ) { - $project="export PROJECT="; + if( $machine eq "hera" ) { + $my_project="export PROJECT=\${PROJECT:-}"; } else { print "Please specify the PROJECT setting for job submissions from this package.\n"; print " Return to accept default PROJECT or enter new project.\n"; @@ -286,7 +335,7 @@ my $job_queue = "dev_shared"; my $my_job_queue = ""; - if( $machine eq "theia" ) { + if( $machine eq "hera" ) { $job_queue="export JOB_QUEUE="; } else { print "Please specify the JOB_QUEUE for job submissions from this package.\n"; diff --git a/util/Minimization_Monitor/README b/util/Minimization_Monitor/README new file mode 100644 index 000000000..c1cdb9e41 --- /dev/null +++ b/util/Minimization_Monitor/README @@ -0,0 +1,51 @@ + +The Minimization Monitor (MinMon) provides a means to regularly +track and report the peformance of the GSI minimization function. +It can be configured to send automated warnings to report irregular +events, such as resets, premature halts, and abnormally large, +final results. + +The MinMon routinely plots the operational GFS results for both +runs (gfs,gdas). See http://www.emc.ncep.noaa.gov/gmb/gdas/index.html +and click on the "GSI Minimization Stats" in the left-most +column at bottom (you may need to scroll down to see it). + +--- ------------------------------------------------------ --- +--- These are placeholder instructions. --- +--- automated configuration scripts are not yet available. --- +--- ------------------------------------------------------ --- + +## Note to self: need to add automatic set-up of the LOGdir ## +## to the install script. ## + +To set up the MinMon with an experimental parallel, first run the +MinMon_install.pl script (in the same directory as this README file). +That will configure your copy of the MinMon for your local use. You +will need to designate the location of your TANKdir, or extracted +data repository. Normally this will be space in a noscrub area. + +When you have produced gsistat files from your experimental run +use the [MinMon_package_location]/data_xtrc/ush/MinMon_DE.sh script +to perform the necessay data extraction on the gsistat file(s). The +default values within the MinMon_DE.sh and subsequent scripts are +configured to process gsistat files from the operational GFS/gfs or +GFS/gdas. You will need to override values such as the location of +your gsistat files in order to run the MinMon. You can do this in +your shell or (recommended) you may adapt one of the +run_[gdas|gfs|fv3rt1]_DE.sh scripts to your use. + +The MinMon_DE.sh script will produce output files in your $TANKdir +directory in the structure of suffix/$run.$pdy/$cyc/minmon/[data files]. +Once you have data here you can run the +[MinMon_package_location]/image_gen/html/[install script] to configure +a web site for your experiment. + +The last step is to run the image generation script +[MinMon_package_location]/image_gen/ush/MinMon_Plt.sh. Here too there +are several plot_[gfs|gdas|fv3rt1]_IG.sh scripts which can be adapted +to override the default values used by MinMon_Plt.sh. + + + + + diff --git a/util/Minimization_Monitor/data_xtrct/ush/MinMon_DE.sh b/util/Minimization_Monitor/data_xtrct/ush/MinMon_DE.sh index 20ec1452c..fbf82bc5b 100755 --- a/util/Minimization_Monitor/data_xtrct/ush/MinMon_DE.sh +++ b/util/Minimization_Monitor/data_xtrct/ush/MinMon_DE.sh @@ -6,9 +6,13 @@ # usage #-------------------------------------------------------------------- function usage { - echo "Usage: MinMonDE.sh suffix [pdate]" + echo "Usage: MinMon_DE.sh suffix [-p|--pdate pdate -r|--run gdas|gfs]" echo " Suffix is the indentifier for this data source." - echo " Pdate is the full YYYYMMDDHH cycle to run. This param is optional" + echo " -p | --pdate yyyymmddcc to specify the cycle to be processed" + echo " if unspecified the last available date will be processed" + echo " -r | --run the gdas|gfs run to be processed" + echo " use only if data in TANKdir stores both runs" + echo " " } #-------------------------------------------------------------------- @@ -18,21 +22,44 @@ function usage { set -x nargs=$# -if [[ $nargs -lt 1 || $nargs -gt 2 ]]; then +if [[ $nargs -lt 1 || $nargs -gt 5 ]]; then usage exit 1 fi -this_file=`basename $0` -this_dir=`dirname $0` -export MINMON_SUFFIX=$1 -echo "TANK_USE_RUN = $TANK_USE_RUN" +#----------------------------------------------- +# Process command line arguments +# +RUN=gdas + +while [[ $# -ge 1 ]] +do + key="$1" + echo $key + + case $key in + -p|--pdate) + export PDATE="$2" + shift # past argument + ;; + -r|--run) + RUN="$2" + shift # past argument + ;; + *) + #any unspecified key is MINMON_SUFFIX + export MINMON_SUFFIX=$key + ;; + esac + + shift +done + +export RUN=$RUN + +this_dir=`dirname $0` -if [[ $nargs -ge 2 ]]; then - export PDATE=$2; - echo "PDATE set to $PDATE" -fi if [[ $COMOUT = "" ]]; then export RUN_ENVIR="dev" @@ -54,6 +81,7 @@ else exit 2 fi +echo "MINMON_CONFIG = $MINMON_CONFIG" minmon_config=${minmon_config:-${top_parm}/MinMon_config} if [[ -s ${minmon_config} ]]; then . ${minmon_config} @@ -73,6 +101,24 @@ else exit 4 fi + +#-------------------------------------------------------------------- +# Check setting of RUN_ONLY_ON_DEV and possible abort if on prod and +# not permitted to run there. +#-------------------------------------------------------------------- + +if [[ RUN_ONLY_ON_DEV -eq 1 ]]; then + is_prod=`${M_DE_SCRIPTS}/onprod.sh` + if [[ $is_prod = 1 ]]; then + exit 10 + fi +fi + + +if [[ ${RUN} = "gdas" ]]; then + export HOMEgfs=${HOMEgdas} +fi + ########################################## # expand M_TANKverf for this MINMON_SUFFIX ########################################## @@ -90,10 +136,12 @@ echo "M_TANKverf = $M_TANKverf" # If PDATE wasn't an argument then call find_cycle.pl # to determine the last processed cycle, and set PDATE to # the next cycle +# +# NOTE: Need to make gdas the default value to $run ############################################################## if [[ ${#PDATE} -le 0 ]]; then echo "PDATE not specified: setting PDATE using last cycle" - date=`${M_DE_SCRIPTS}/find_cycle.pl GDAS 1 ${M_TANKverf}` + date=`${M_DE_SCRIPTS}/find_cycle.pl --run gdas --cyc 1 --dir ${M_TANKverf}` export PDATE=`$NDATE +6 $date` else echo "PDATE was specified: $PDATE" @@ -103,12 +151,10 @@ export PDY=`echo $PDATE|cut -c1-8` export cyc=`echo $PDATE|cut -c9-10` echo "PDY, cyc = $PDY, $cyc " -mdate=`$NDATE -24 $PDATE` -m1=`echo $mdate|cut -c1-8` - -#export M_TANKverfM0=${M_TANKverf}/minmon.${PDY} -#export M_TANKverfM1=${M_TANKverf}/minmon.${m1} +if [[ ! -d ${LOGdir} ]]; then + mkdir -p ${LOGdir} +fi lfile=${LOGdir}/DE.${PDY}.${cyc} export pid=${pid:-$$} @@ -117,57 +163,19 @@ export m_jlogfile="${lfile}.log" echo "m_jlogfile = $m_jlogfile" ############################################################# -export job=${job:-${MINMON_SUFFIX}_vminmon} -export jobid=${jobid:-${job}.${cyc}.${pid}} + +export job=${job:-DE.${RUN}} +export jobid=${jobid:-${job}.${PDY}.${pid}} export envir=prod -export DATAROOT=${DATA_IN:-${STMP_USER}} +export DATAROOT=${DATA_IN:-${WORKDIR}} export COMROOT=${COMROOT:-/com2} echo "MY_MACHINE = $MY_MACHINE" -# -# Note: J-job's default location for the gsistat file is -# /com2/gfs/prod/gdas.yyyymmdd/gdas1.hhz.gsistat -# The directory containing the gsistat file can overriden or -# the gsistat file can be directly overriden by exporting -# value for $gsistat -#export COMIN=${COMIN:-${COMROOT}/gfs/${envir}}/${MINMON_SUFFIX}.${PDY} -#export gsistat= -############################################################# -# Load modules -############################################################# -#if [[ $MY_MACHINE = "wcoss" ]]; then -# . /usrx/local/Modules/3.2.9/init/ksh -# -# module use /nwprod2/modulefiles -# module load grib_util -# module load prod_util -# module load util_shared -# -# module unload ics/12.1 -# module load ics/15.0.3 -# -#if [[ $MY_MACHINE = "cray" ]]; then -# . $MODULESHOME/init/ksh - -# module use -a /gpfs/hps/nco/ops/nwprod/modulefiles -# module use /usrx/local/prod/modulefiles -# module use -a /opt/modulefiles -# -# module load prod_util -# module load prod_envir -# module load pm5/5.10.0 -# module load xt-lsfhpc -# -#fi - -module list - jobname=minmon_de_${MINMON_SUFFIX} rm -f $m_jlogfile -#rm -rf $DATA_IN echo "SUB = $SUB" echo "JOB_QUEUE = $JOB_QUEUE" @@ -177,15 +185,25 @@ echo "jobname = $jobname" if [[ $GLB_AREA -eq 0 ]]; then jobfile=${jobfile:-${HOMEnam}/jobs/JNAM_VMINMON} else - jobfile=${jobfile:-${HOMEgdas}/jobs/JGDAS_VMINMON} + if [[ $RUN = "gfs" ]]; then + jobfile=${jobfile:-${HOMEgfs}/jobs/JGFS_VMINMON} + else + jobfile=${jobfile:-${HOMEgdas}/jobs/JGDAS_VMINMON} + fi fi -if [[ $MY_MACHINE = "wcoss" ]]; then - $SUB -q $JOB_QUEUE -P $PROJECT -o ${m_jlogfile} -M 50 -R affinity[core] -W 0:10 -J ${jobname} $jobfile +if [[ $MY_MACHINE = "wcoss" || $MY_MACHINE = "wcoss_d" ]]; then + $SUB -P $PROJECT -q $JOB_QUEUE -o ${m_jlogfile} -M 50 -R affinity[core] -W 0:10 -J ${jobname} $jobfile + elif [[ $MY_MACHINE = "cray" ]]; then $SUB -q $JOB_QUEUE -P $PROJECT -o ${m_jlogfile} -M 80 -R "select[mem>80] rusage[mem=80]" -W 0:10 -J ${jobname} $jobfile -elif [[ $MY_MACHINE = "theia" ]]; then - echo "theia job sumission goes here" + +elif [[ $MY_MACHINE = "hera" ]]; then + $SUB --account=${ACCOUNT} --time=05 -J ${job} -D . \ + -o ${LOGdir}/DE.${PDY}.${cyc}.log \ + --ntasks=1 --mem=5g \ + ${jobfile} + fi diff --git a/util/Minimization_Monitor/data_xtrct/ush/RunMM_DE.sh b/util/Minimization_Monitor/data_xtrct/ush/RunMM_DE.sh index 3e4cca647..f043214cd 100755 --- a/util/Minimization_Monitor/data_xtrct/ush/RunMM_DE.sh +++ b/util/Minimization_Monitor/data_xtrct/ush/RunMM_DE.sh @@ -113,10 +113,10 @@ fi # determine the last date processed. #-------------------------------------------------------------------- start_len=`echo ${#START_DATE}` -verf_dir="${TANKverf}/stats/${SUFFIX}/gsistat" +verf_dir="${TANKverf}/stats/${SUFFIX}" if [[ ${start_len} -le 0 ]]; then - pdate=`${M_DE_SCRIPTS}/find_cycle.pl ${SUFFIX} 1 ${verf_dir}` + pdate=`${M_DE_SCRIPTS}/find_cycle.pl --run gdas --cyc 1 --dir ${verf_dir}` pdate_len=`echo ${#pdate}` if [[ ${pdate_len} -ne 10 ]]; then exit 12 @@ -139,9 +139,9 @@ while [[ $done -eq 0 ]]; do #-------------------------------------------------------------------- # Check for running jobs #-------------------------------------------------------------------- - if [[ $MY_MACHINE = "wcoss" ]]; then + if [[ $MY_MACHINE = "wcoss" || $MY_MACHINE = "wcoss_d" ]]; then running=`bjobs -l | grep minmon_de_${SUFFIX} | wc -l` - elif [[ $MY_MACHINE = "zeus" ]]; then + elif [[ $MY_MACHINE = "hera" ]]; then running=`qstat -u $LOGNAME | grep minmon_de_${SUFFIX} | wc -l` fi diff --git a/util/Minimization_Monitor/data_xtrct/ush/find_cycle.pl b/util/Minimization_Monitor/data_xtrct/ush/find_cycle.pl index ebe46035d..46ace9315 100755 --- a/util/Minimization_Monitor/data_xtrct/ush/find_cycle.pl +++ b/util/Minimization_Monitor/data_xtrct/ush/find_cycle.pl @@ -3,23 +3,28 @@ #----------------------------------------------------------------------- # find_cycle.pl # -# Given a directory containing ${SUFFIX}_minmon.YYYYMMDDHH -# subdirectories, determine the first or last cycle for which ieee_d -# data files exist. +# Arguments: +# --dir : Required string value containing $TANKdir/$SUFFIX. +# --cyc : Optional integer value: +# 1 = last cycle (default) +# 0 = first cycle +# --run : Run name, generally 'gdas' or 'gfs'. +# If not specified 'gdas' will be used. # # Return that first/last cycle as a text string in YYYYMMDDHH format, # or return nothing if none of the expected data files are found. # -# NOTE: This has been updated to work with TANK_USE_DIR configuration -# of ~/nbns/stats/$suffix, but with the 0 option (first) it's -# returning first+1 for some reason. I'll have to worry about -# that later. +# Note that this is designed to be used by a shell script which will +# pick up the returned cycle string. If debug statements are left +# in this perl script then the calling shell script will have +# problems. #----------------------------------------------------------------------- - use strict; - use warnings; + use strict; + use warnings; + use Getopt::Long; + use Scalar::Util qw(looks_like_number); - use Scalar::Util qw(looks_like_number); #------------------------------------------------------------------- # @@ -42,18 +47,22 @@ ##------------------------------------------------------------------ ##------------------------------------------------------------------ - if ($#ARGV != 2 ) { - print "usage: find_cycle.pl suffix 0/1 /path_to_directory/containing/minmon.YYYYMMDDHH subdirectories. \n"; - print " 0 = first, 1 = last \n"; - exit; - } - my $suffix = $ARGV[0]; - my $target = $ARGV[1]; - my $dirpath = $ARGV[2]; + my $run = 'gdas'; + my $dir = ''; + my $lcm = 'minmon'; + my $cyc = '1'; + + GetOptions( 'cyc:i' => \$cyc, + 'run:s' => \$run, + 'dir=s' => \$dir, + 'lcm:s' => \$lcm ); + + my @alldirs; + my $dirpath = $dir; - - # Get list of minmon.* sub-directories + #-------------------------------------------------------------------- + # Get list of $run.* directories which contain minmon subdirectories # opendir(DIR, $dirpath) or die "Cannot open directory $!"; while (my $file = readdir(DIR)) { @@ -61,144 +70,143 @@ push( @alldirs, $file ); } closedir DIR; - my @mmdirs = grep { /minmon/ } @alldirs; - if( $#mmdirs < 0 ) { - @mmdirs = grep { /gdas/ } @alldirs; + + my $search_string; + + if( length($run) == 0 ){ + $search_string = $lcm; + } else { + $search_string = $run; } - - # If there are no minmon* subdirectories, then exit without + + my @mmdirs = grep { /$search_string/ } @alldirs; + + #----------------------------------------------------------------------- + # If there are no $run.yyyymmdd subdirectories, then exit without # returning any date string. # if( $#mmdirs < 0 ) { print "exiting with 0 mmdirs\n"; exit; } - + + + #----------------------------------------------------------------------- # Sort the mmdirs array and loop through it from end to beginning # - if( $target == 1 ){ # search is for latest date/time - my @sortmm = sort( @mmdirs ); - my $ctr = $#sortmm + 1; + my @sortmm = sort( @mmdirs ); - my $found_cycle = 0; + my $ctr; + my $incr; + my $end_ctr; + my @hrs; - # Start with the latest directory and attempt to locate the - # gnorm_data.txt file. The last line will contain the - # latest cycle processed. - do { - - $ctr--; - - - # In each subdirectory attempt to locate the last - # and parse out all unique date values. The oldest is the answer - # we're looking for. - # - # If there are no time.*ieee_d* files, step to the next iteration. - # - my $newdir; - - if( -d "${dirpath}/${sortmm[$ctr]}/minmon" ){ - $newdir = "${dirpath}/${sortmm[$ctr]}/minmon"; - } - elsif( -d "${dirpath}/${sortmm[$ctr]}" ){ - $newdir = "${dirpath}/${sortmm[$ctr]}"; - } - - - opendir DIR, $newdir or die "Cannot open the current directory: $!"; - - my @timefiles = grep { /costs.txt/ } readdir DIR; - - if( $#timefiles >= 0 ) { - my @sorttime = sort( @timefiles ); - my @times; - my $idx = 0; - - # Find the first string of 10 digits; that's the date. Use that $idx - # number to process all files. - # - my @vals = split( '\.', $timefiles[0] ); - for ( my $ii=$#vals; $ii >= 0; $ii-- ) { - if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ - $idx = $ii; - } - } - - for ( my $ii=$#sorttime; $ii >= 0; $ii-- ) { - my $teststr = $sorttime[$ii]; + #----------------------------------------------------------------------- + # Arrange the logic here for accessing either the first or last + # cycle. If we're after the first cycle the directories will be + # processed from 0 to max. Note below the cycle hours are processed + # from max to 0, so the cycle order is reversed (18..00) when looking + # for the first cycle. + # + if( $cyc == 0 ){ + $ctr = -1; + $incr = 1; + $end_ctr = $#sortmm; + @hrs = qw( 18 12 06 00 ); + } else { + $ctr = $#sortmm + 1; + $incr = -1; + @hrs = qw( 00 06 12 18 ); + $end_ctr = 0; + } - my @values = split( '\.', $teststr ); - push( @times, $values[$idx] ); - } + my $found_cycle = 0; - if ( $#times >= 0 ) { - $found_cycle = 1; - my @utimes = sort( uniq( @times ) ); - print "$utimes[$#utimes]"; - } - } + # Start with the latest directory and attempt to locate monitor + # subdirectories. + # - } while $found_cycle == 0 && $ctr > 0; - } - else { # search is for earliest date/time + my $exit_flag = 0; + + do { + $ctr = $ctr + $incr; + + # In each subdirectory attempt to locate all *ieee_d files + # and parse out all unique date values. The latest is the answer + # we're looking for. + # + # If there are no time.*ieee_d* files, step to the next iteration. + # - my @sortmm = sort( @mmdirs ); - my $ctr = -1; + my $newdir; + my $hr_ctr = $#hrs + 1; - my $found_cycle = 0; do { - - $ctr++; - - - # In each subdirectory build a list of time.*ieee_d* files - # and parse out all unique date values. The oldest is the answer - # we're looking for. - # - # If there are no time.*ieee_d* files, step to the next iteration. - # - my $newdir; - - if( -d "${dirpath}/${sortmm[$ctr]}/minmon" ){ - $newdir = "${dirpath}/${sortmm[$ctr]}/minmon"; - } - elsif( -d "${dirpath}/${sortmm[$ctr]}" ){ - $newdir = "${dirpath}/${sortmm[$ctr]}"; - } - - opendir DIR, $newdir or die "Cannot open the current directory: $!"; - - my @timefiles = grep { /costs.txt/ } readdir DIR; - - if( $#timefiles >= 0 ) { - my @sorttime = sort( @timefiles ); - my @times; - - for ( my $ii=0; $ii <= $#sorttime; $ii++ ) { - my $teststr = $sorttime[$ii]; + + $hr_ctr = $hr_ctr - 1; + + $newdir = "${dirpath}/${sortmm[$ctr]}/${hrs[$hr_ctr]}/${lcm}"; +# print " newdir = $newdir \n"; - # Find the first string of 10 digits; that's the date. + + if( -d $newdir ) { + opendir DIR, $newdir or die "Cannot open the current directory: $!"; + + my @timefiles = grep { /ieee_d/ } readdir DIR; + + if( $#timefiles >= 0 ) { + my @sorttime = sort( @timefiles ); + my @times; + my $idx = 0; + + # Find the first string of 10 digits; that's the date. Use that + # $idx number to process all files. # - my @vals = split( '\.', $sorttime[$ii] ); -# my @vals = split( '\.', $timefiles[0] ); + my @vals = split( '\.', $timefiles[0] ); for ( my $ii=$#vals; $ii >= 0; $ii-- ) { - if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ - push( @times, $vals[$ii] ); + if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ + $idx = $ii; } } - } - if ( $#times >= 0 ) { - $found_cycle = 1; - my @utimes = sort( uniq( @times ) ); - print "$utimes[0]"; + for ( my $ii=$#sorttime; $ii >= 0; $ii-- ) { + my $teststr = $sorttime[$ii]; + + my @values = split( '\.', $teststr ); + push( @times, $values[$idx] ); + + } + if ( $#times >= 0 ) { + my @utimes = sort( uniq( @times ) ); + if( $cyc == 1 ) { + print "$utimes[$#utimes]"; + $found_cycle = 1; + } elsif( $cyc == 2 && $#utimes >= 1 ) { + print "$utimes[$#utimes-1]"; + $found_cycle = 1; + } else { + print "$utimes[0]"; + $found_cycle = 1; + } + } } - } - } while $found_cycle == 0 && $ctr < $#sortmm ; - } + } + + } while $hr_ctr > 0 && $found_cycle == 0; + +# print " found_cycle, ctr, end_ctr = $found_cycle, $ctr, $end_ctr \n"; + if( $cyc == 0 && $ctr >= $end_ctr ){ +# print " exiting from if\n"; + $exit_flag = 1; + } elsif( $cyc == 1 && $ctr <= $end_ctr ){ +# print " exiting from elsif\n"; + $exit_flag = 1; + } + + } while $found_cycle == 0 && $exit_flag == 0; + diff --git a/util/Minimization_Monitor/data_xtrct/ush/run_cp_v16rt1.sh b/util/Minimization_Monitor/data_xtrct/ush/run_cp_v16rt1.sh new file mode 100755 index 000000000..ca5b2e0d7 --- /dev/null +++ b/util/Minimization_Monitor/data_xtrct/ush/run_cp_v16rt1.sh @@ -0,0 +1,54 @@ +#!/bin/bash + +#package=MinMon +package=ProdGSI/util/Minimization_Monitor + +net=v16rt1 +run=gdas + +echo "user = $USER" + +export KEEPDATA=YES +export DO_ERROR_RPT=1 +export MAIL_TO="" +export MAIL_CC="" + +scripts=/gpfs/dell2/emc/modeling/noscrub/${USER}/${package}/data_xtrct/ush +echo "scripts = $scripts" + +shell=bash +source /usrx/local/prod/lmod/lmod/init/${shell} + +MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core:/usrx/local/prod/modulefiles/core_third:/usrx/local/prod/modulefiles/defs:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod:/usrx/local/dev/modulefiles + +module purge +module load ips/18.0.1.163 +module load metplus/2.1 +module load prod_util/1.1.2 + +echo NDATE = $NDATE + + + +tank=~/nbns/stats/${net} + +ldate=`${scripts}/find_cycle.pl --cyc 1 --dir ${tank} --run ${run}` +echo ldate = $ldate +pdate=`${NDATE} +06 $ldate` +#pdate=2019070100 + +echo pdate = $pdate + +pdy=`echo $pdate|cut -c1-8` +cyc=`echo $pdate|cut -c9-10` + +data_loc=/gpfs/dell2/emc/modeling/noscrub/emc.glopara/monitor/minmon/stats/${net}/${run}.${pdy} +#echo data_loc = $data_loc + +tank=${tank}/${run}.${pdy}/${cyc}/minmon +mkdir -p ${tank} + +cp ${data_loc}/*${pdate}* ${tank}/. +cp ${data_loc}/gnorm_data.txt ${tank}/. + + diff --git a/util/Minimization_Monitor/data_xtrct/ush/run_gdas_DE.sh b/util/Minimization_Monitor/data_xtrct/ush/run_gdas_DE.sh new file mode 100755 index 000000000..faf309c80 --- /dev/null +++ b/util/Minimization_Monitor/data_xtrct/ush/run_gdas_DE.sh @@ -0,0 +1,37 @@ +#!/bin/sh + +ch=`hostname | cut -c1` + +#package=MinMon +package=ProdGSI/util/Minimization_Monitor + +suffix=GFS +net=gfs +export RUN=gdas + +scripts=/gpfs/dell2/emc/modeling/noscrub/${USER}/${package}/data_xtrct/ush +export jobfile=/gpfs/dell2/emc/modeling/noscrub/${USER}/${package}/nwprod/gdas.v1.0.0/jobs/JGDAS_VMINMON + + +NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.0/exec/ips/ndate + +tank=~/nbns/stats/${suffix} +ldate=`${scripts}/find_cycle.pl ${suffix} --cyc 1 --dir ${tank} --run ${RUN}` + +export PDATE=`${NDATE} +06 $ldate` +#export PDATE=2019083018 + +export PDY=`echo $PDATE|cut -c1-8` +export cyc=`echo $PDATE|cut -c9-10` + + +export COMIN=/gpfs/dell1/nco/ops/com/${net}/prod/${RUN}.${PDY}/${cyc} +export gsistat=${COMIN}/${RUN}.t${cyc}z.gsistat + +tank=~/nbns/stats/${suffix} +logdir=/gpfs/dell2/ptmp/Edward.Safford/logs/${suffix}/${RUN}/minmon + +echo PDATE = $PDATE +echo gsistat = $gsistat + +${scripts}/MinMon_DE.sh ${suffix} --pdate ${PDATE} --run ${RUN} 1>$logdir/MinMon_DE.log 2>$logdir/MinMon_DE.err diff --git a/util/Minimization_Monitor/data_xtrct/ush/run_gfs_DE.sh b/util/Minimization_Monitor/data_xtrct/ush/run_gfs_DE.sh new file mode 100755 index 000000000..dfe7fb6ea --- /dev/null +++ b/util/Minimization_Monitor/data_xtrct/ush/run_gfs_DE.sh @@ -0,0 +1,36 @@ +#!/bin/sh + + +#package=MinMon +package=ProdGSI/util/Minimization_Monitor + +suffix=GFS +net=gfs +export RUN=gfs + +scripts=/gpfs/dell2/emc/modeling/noscrub/${USER}/${package}/data_xtrct/ush +export jobfile=/gpfs/dell2/emc/modeling/noscrub/${USER}/${package}/nwprod/gfs.v1.0.0/jobs/JGFS_VMINMON + + +NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.0/exec/ips/ndate + +tank=~/nbns/stats/${suffix} +ldate=`${scripts}/find_cycle.pl ${suffix} --cyc 1 --dir ${tank} --run ${RUN}` + +export PDATE=`${NDATE} +06 $ldate` +#export PDATE=2019083018 + +export PDY=`echo $PDATE|cut -c1-8` +export cyc=`echo $PDATE|cut -c9-10` + + +export COMIN=/gpfs/dell1/nco/ops/com/${net}/prod/${RUN}.${PDY}/${cyc} +export gsistat=${COMIN}/${RUN}.t${cyc}z.gsistat + +tank=~/nbns/stats/${suffix} +logdir=/gpfs/dell2/ptmp/Edward.Safford/logs/${suffix}/${RUN}/minmon + +echo PDATE = $PDATE +echo gsistat = $gsistat + +${scripts}/MinMon_DE.sh ${suffix} --pdate ${PDATE} --run ${RUN} 1>$logdir/MinMon_DE.log 2>$logdir/MinMon_DE.err diff --git a/util/Minimization_Monitor/data_xtrct/ush/run_minmon_namrr.sh b/util/Minimization_Monitor/data_xtrct/ush/run_minmon_namrr.sh deleted file mode 100755 index 5dffb778d..000000000 --- a/util/Minimization_Monitor/data_xtrct/ush/run_minmon_namrr.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/sh - -scripts=/gpfs/gd2/emc/da/noscrub/Edward.Safford/MinMon_585/util/Minimization_Monitor/data_xtrct/ush -export jobfile=/gpfs/gd2/emc/da/noscrub/Edward.Safford/MinMon_585/util/Minimization_Monitor/nwprod/nam_minmon.v1.0.0/jobs/JNAM_MINMON - -NDATE=/nwprod/util/exec/ndate - -export RUN=namrr -export MINMON_SUFFIX=namrr -export PROJECT=NDAS-T2O -export GLB_AREA=0 -export CYCLE_INTERVAL=1 - -export M_TANKverf=~/nbns -tank=~/nbns/stats/regional/namrr -ldate=`${scripts}/find_cycle.pl ${MINMON_SUFFIX} 1 ${tank}` - -#export PDATE=2016080300 -export PDATE=`${NDATE} +${CYCLE_INTERVAL} $ldate` -export PDY=`echo $PDATE|cut -c1-8` -export cyc=`echo $PDATE|cut -c9-10` - -export COMROOT=/ptmpd3/Eric.Rogers/com/namrr/para/ -export COM_IN=/ptmpd3/Eric.Rogers/com/namrr/para/ - -export REGIONAL_RR=1 - -${scripts}/MinMon_DE.sh ${MINMON_SUFFIX} ${PDATE} 1>log 2>err - diff --git a/util/Minimization_Monitor/data_xtrct/ush/run_script.sh b/util/Minimization_Monitor/data_xtrct/ush/run_script.sh index 4d6a2fdb7..b794b5797 100755 --- a/util/Minimization_Monitor/data_xtrct/ush/run_script.sh +++ b/util/Minimization_Monitor/data_xtrct/ush/run_script.sh @@ -1,52 +1,71 @@ -#!/bin/sh - -idev=`cat /etc/dev | cut -c1` -iprod=`cat /etc/prod | cut -c1` - -package= -suffix= -echo "user = $USER" - -export KEEPDATA=NO -export DO_ERROR_RPT=1 -export MAIL_TO="" -export MAIL_CC="" - -scripts=/gpfs/hps3/emc/da/noscrub/${LOGNAME}/${package}/util/Minimization_Monitor/data_xtrct/ush -echo "scripts = $scripts" - -export jobfile=/gpfs/hps3/emc/da/noscrub/${LOGNAME}/${package}/util/Minimization_Monitor/nwprod/gdas.v1.0.0/jobs/JGDAS_VMINMON -echo "jobfile = $jobfile" - -export MODULESHOME=/opt/modules/3.2.6.7 - -. $MODULESHOME/init/sh - -module use -a /gpfs/hps/nco/ops/nwprod/modulefiles - -module load prod_util +#!/bin/ksh + +#---------------------------------------------------------------------- +# +# This is a generic data extraction leader script. +# +# The MinMon_DE.sh script may be called directly, or this script, +# which calls MinMon_DE.sh can be used to overwrite specific +# values in MinMon_DE.sh and/or parm files. +# +# Set MINMON_SUFFIX, RUN to match your data source and run +# value. +# +# COMIN is the location of the gsistat file repository, which +# contains the specific $RUN.$PDATE subdirectories. +# +# Use pdate to run a specific cycle. If commented out then the +# M_TANKverf directory will be examined and the pdate will +# be the last cycle run + 6 hrs. +# +#---------------------------------------------------------------------- + +MINMON_SUFFIX=testmm +RUN=gfs +COMIN=/scratch1/NCEPDEV/da/Edward.Safford/noscrub/test_data + +#pdate=2016030700 + + +#---------------------------------------------------------------------- +# No changes should be necessary below this point. +#---------------------------------------------------------------------- + +. ../../parm/MinMon.ver +. ../../parm/MinMon_config + +if [[ $RUN == "gfs" ]]; then + export jobfile=${HOMEgfs}/jobs/JGFS_VMINMON +else + export jobfile=${HOMEgdas}/jobs/JGDAS_VMINMON +fi echo NDATE = $NDATE -export COMIN=/gpfs/hps3/emc/global/noscrub/emc.glopara/archive/prfv3rt1 +echo "LOGdir = ${LOGdir}" +if [[ ! -e ${LOGdir} ]]; then + mkdir -p ${LOGdir} +fi -tank=~/nbns/stats/${suffix} -logdir=/gpfs/hps2/ptmp/Edward.Safford/logs/${suffix}/minmon +if [[ $pdate == "" ]]; then + ldate=`${M_DE_SCRIPTS}/find_cycle.pl --dir ${M_TANKverf}/stats/${MINMON_SUFFIX} --cyc 1 --run ${RUN}` + pdate=`${NDATE} +06 $ldate` +fi -ldate=`${scripts}/find_cycle.pl ${suffix} 1 ${tank}` -export PDATE=`${NDATE} +06 $ldate` +pdy=`echo $pdate|cut -c1-8` +cyc=`echo $pdate|cut -c9-10` +export gsistat=${COMIN}/${RUN}.${pdy}/${cyc}/${RUN}.t${cyc}z.gsistat -export PDY=`echo $PDATE|cut -c1-8` -export cyc=`echo $PDATE|cut -c9-10` +if [[ ! -e $gsistat ]]; then + echo " unable to locate $gsistat" +fi -module unload prod_util - -export gsistat=${COMIN}/gsistat.gdas.${PDATE} - -echo PDATE = $PDATE +echo pdate = $pdate echo gsistat = $gsistat -${scripts}/MinMon_DE.sh ${suffix} ${PDATE} 1>$logdir/MinMon_DE.log 2>$logdir/MinMon_DE.err + +${M_DE_SCRIPTS}/MinMon_DE.sh ${MINMON_SUFFIX} -p ${pdate} -r ${RUN} \ + 1>$LOGdir/MinMon_DE.log 2>$LOGdir/MinMon_DE.err diff --git a/util/Minimization_Monitor/data_xtrct/ush/run_v16rt1.sh b/util/Minimization_Monitor/data_xtrct/ush/run_v16rt1.sh new file mode 100755 index 000000000..842f150d0 --- /dev/null +++ b/util/Minimization_Monitor/data_xtrct/ush/run_v16rt1.sh @@ -0,0 +1,60 @@ +#!/bin/sh + +idev=`cat /etc/dev | cut -c1` +iprod=`cat /etc/prod | cut -c1` + +package=MinMon +#package=ProdGSI/util/Minimization_Monitor +suffix=v16rt1 +export run=gdas + +echo "user = $USER" + +export KEEPDATA=YES +export DO_ERROR_RPT=1 +export MAIL_TO="" +export MAIL_CC="" + +scripts=/gpfs/dell2/emc/modeling/noscrub/${USER}/${package}/data_xtrct/ush +echo "scripts = $scripts" + +export jobfile=/gpfs/dell2/emc/modeling/noscrub/${USER}/${package}/nwprod/gdas.v1.0.0/jobs/JGDAS_VMINMON +echo "jobfile = $jobfile" + +shell=sh +source /usrx/local/prod/lmod/lmod/init/${shell} + +MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core:/usrx/local/prod/modulefiles/core_third:/usrx/local/prod/modulefiles/defs:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod:/usrx/local/dev/modulefiles + +module purge +module load ips/18.0.1.163 +module load metplus/2.1 +module load lsf +module load prod_util/1.1.2 + +echo NDATE = $NDATE + +#export COMIN=/gpfs/hps3/emc/global/noscrub/emc.glopara/archive/prfv3rt1 +export COMIN=/gpfs/dell2/emc/modeling/noscrub/emc.glopara/archive/v16rt1 + +tank=~/nbns/stats/${suffix} +logdir=/gpfs/dell2/ptmp/Edward.Safford/logs/${suffix}/${run}/minmon + +ldate=`${scripts}/find_cycle.pl --cyc 1 --dir ${tank} --run ${run}` +echo ldate = $ldate +export PDATE=`${NDATE} +06 $ldate` +#PDATE=2019082806 + +export PDY=`echo $PDATE|cut -c1-8` +export cyc=`echo $PDATE|cut -c9-10` + +#module unload prod_util + +export gsistat=${COMIN}/gsistat.${run}.${PDATE} + +echo PDATE = $PDATE +echo gsistat = $gsistat + +${scripts}/MinMon_DE.sh ${suffix} --pdate ${PDATE} 1>$logdir/MinMon_DE.log 2>$logdir/MinMon_DE.err + + diff --git a/util/Minimization_Monitor/get_hostname.pl b/util/Minimization_Monitor/get_hostname.pl index 9d0af1b92..47f782d67 100755 --- a/util/Minimization_Monitor/get_hostname.pl +++ b/util/Minimization_Monitor/get_hostname.pl @@ -4,35 +4,18 @@ # get_hostname.pl # # This script determines the hostname of the current machine. The -# possiblities are wcoss, theia, cray, or "" if the host is -# determined to not be one of those three. +# possiblities are wcoss, wcoss_d, cray, hera or "" if the host is +# determined to not be one of those four. #------------------------------------------------------------------- -# use IO::File; -# use File::Copy qw(move); - - my $arch; - $arch = ` uname -s | tr '[:upper:]' '[:lower:]' `; - $arch =~ s/^\s+|\s+$//g; - my $my_os = "export MY_OS=$arch"; - - # - # Determine if installation is on WCOSS, Theia, or Zeus. - # -# if( $arch ne "linux" && $arch ne "aix" ) { -# die( "only linux and aix are supported, $arch is not\n" ); -# } -# print "\n"; -# print "arch = $arch\n"; my $machine = ""; # - # zeus login nodes are fe1-fe8, and hostname command only returns the node name, + # Hera login nodes are he1-he8, and hostname command only returns the node name, # while ccs and (perhaps) wcoss return [hostname].ncep.noaa.gov. Keep only the # actual hostname and see if it matches the node names for zeus, tide, or gyre. # -# my $host_zeus = 0; my $host = ""; $host = ` hostname `; chomp( $host ); @@ -42,18 +25,18 @@ $host = $hostnames[0]; } - if( $host =~ /tfe/ ) { - $machine = "theia"; + if( $host =~ /hfe/ ) { + $machine = "hera"; } -# elsif( $host =~ /fe/ ) { -# $machine = "zeus"; -# } elsif( $host =~ /login/ ) { $machine = "cray"; } elsif( $host =~ /t/ || $host =~ /g/ ){ # wcoss nodes are tXXaY and gXXaY $machine = "wcoss"; } + elsif( $host =~ /m/ || $host =~ /v/ ){ # wcoss_d nodes are mXXaY and vXXaY + $machine = "wcoss_d"; + } print "$machine"; diff --git a/util/Minimization_Monitor/image_gen/parm/plot_minmon_conf b/util/Minimization_Monitor/image_gen/parm/plot_minmon_conf index 86a3077ce..94cee5d5c 100755 --- a/util/Minimization_Monitor/image_gen/parm/plot_minmon_conf +++ b/util/Minimization_Monitor/image_gen/parm/plot_minmon_conf @@ -2,38 +2,17 @@ # # plot_minmon_conf # -# Contains definitions for export for image processing -# common to all scripts. +# Contains definitions and module loads for image +# processing. # #------------------------------------------------------- - - -#------------------------------------------------------- -# Internal reference definitions. These should not -# be edited. -# -#export PTMP_USER=${PTMP}/${USER} -#export STMP_USER=${STMP}/${USER} - -#export SCRIPTS=${RADMON_IMAGE_GEN}/ush -#export PARM=${RADMON_IMAGE_GEN}/parm -#export GSCRIPTS=${RADMON_IMAGE_GEN}/gscripts -#export EXEDIR=${RADMON_IMAGE_GEN}/exec - -#export PLOT_COMP_DIR=${STMP_USER}/plot_comp_jobs -#export LOGDIR=${LOGSverf_rad}/rad${SUFFIX} -#export PLOT_WORK_DIR=${STMP_USER}/plotjobs_${SUFFIX} - if [[ $MY_MACHINE = "wcoss" ]]; then -# export GRADS=/usrx/local/GrADS/2.0.1/bin/grads -# export STNMAP=/usrx/local/GrADS/2.0.1/bin/stnmap -# export GADDIR=/usrx/local/GrADS/2.0.1/lib shell=sh . /usrx/local/Modules/default/init/${shell} - module load GrADS/2.0.1 + module load GrADS/2.0.2 export GRADS=`which grads` -elif [[ $MY_MACHINE = "zeus" ]]; then +elif [[ $MY_MACHINE = "theia" ]]; then export GRADS=/apps/grads/2.0.1a/bin/grads export STNMAP=/apps/grads/2.0.1a/bin/stnmap shell=sh diff --git a/util/Minimization_Monitor/image_gen/ush/MinMon_Plt.sh b/util/Minimization_Monitor/image_gen/ush/MinMon_Plt.sh index 97229f1fb..7b9f62a03 100755 --- a/util/Minimization_Monitor/image_gen/ush/MinMon_Plt.sh +++ b/util/Minimization_Monitor/image_gen/ush/MinMon_Plt.sh @@ -6,9 +6,9 @@ function usage { echo "Usage: MinMonPlt.sh MINMON_SUFFIX " echo " MINMON_SUFFIX is data source identifier that matches data in " echo " the $M_TANKverf/stats directory." - echo " -p | -pdate yyyymmddcc to specify the cycle to be plotted" + echo " -p | --pdate yyyymmddcc to specify the cycle to be plotted" echo " if unspecified the last available date will be plotted" - echo " -r | -run the gdas|gfs run to be plotted" + echo " -r | --run the gdas|gfs run to be plotted" echo " use only if data in TANKdir stores both runs" echo " " } @@ -21,7 +21,7 @@ if [[ $nargs -lt 1 || $nargs -gt 5 ]]; then exit 1 fi - +RUN=gdas while [[ $# -ge 1 ]] do key="$1" @@ -45,6 +45,10 @@ do shift done +if [[ ${#RUN} -le 0 ]]; then + export RUN=gdas +fi + echo "MINMON_SUFFIX = $MINMON_SUFFIX" echo "PDATE = $PDATE" echo "RUN = $RUN" @@ -57,7 +61,6 @@ else run_suffix=${MINMON_SUFFIX} fi -this_file=`basename $0` this_dir=`dirname $0` #-------------------------------------------------- @@ -92,26 +95,6 @@ else exit 4 fi -plot_minmon_conf=${plot_minmon_conf:-${M_IG_PARM}/plot_minmon_conf} -if [[ -s ${plot_minmon_conf} ]]; then - . ${plot_minmon_conf} - echo "able to source ${plot_minmon_conf}" -else - echo "Unable to source ${plot_minmon_conf} file" - exit 5 -fi - - -#-------------------------------------------------------------------- -# Check for my monitoring use. Abort if running on prod machine. -#-------------------------------------------------------------------- -if [[ RUN_ONLY_ON_DEV = 1 ]]; then - is_prod=`${M_IG_SCRIPTS}/onprod.sh` - if [[ $is_prod = 1 ]]; then - exit 10 - fi -fi - #-------------------------------------------------------------------- # Specify TANKDIR for this suffix @@ -128,7 +111,7 @@ fi #-------------------------------------------------------------------- if [[ ${#PDATE} -le 0 ]]; then echo "PDATE not specified: setting PDATE using last cycle" - export PDATE=`${M_IG_SCRIPTS}/find_cycle.pl ${MINMON_SUFFIX} 1 ${TANKDIR}` + export PDATE=`${M_IG_SCRIPTS}/find_cycle.pl --cyc 1 --dir ${TANKDIR}` else echo "PDATE was specified: $PDATE" fi @@ -154,24 +137,12 @@ cd $WORKDIR # Copy gnorm_data.txt file to WORKDIR. #-------------------------------------------------------------------- pdy=`echo $PDATE|cut -c1-8` -if [[ ${#RUN} -gt 0 ]]; then - gnorm_dir=${TANKDIR}/${RUN}.${pdy} - if [[ -d $gnorm_dir/minmon ]]; then - gnorm_dir=${gnorm_dir}/minmon - fi -else - gnorm_dir=${TANKDIR}/minmon.${pdy} -fi +cyc=`echo $PDATE|cut -c9-10` +echo TANKDIR = ${TANKDIR} -if [[ ! -d $gnorm_dir ]]; then - gnorm_dir=${TANKDIR}/minmon_${MINMON_SUFFIX}.${pdy} -fi +gnorm_dir=${TANKDIR}/${RUN}.${pdy}/${cyc}/minmon -gnorm_file=${gnorm_dir}/${MINMON_SUFFIX}.gnorm_data.txt -if [[ ! -e $gnorm_file ]]; then - gnorm_file=${gnorm_dir}/gnorm_data.txt -fi -local_gnorm=gnorm_data.txt +gnorm_file=${gnorm_dir}/gnorm_data.txt if [[ -s ${gnorm_file} ]]; then cp ${gnorm_file} ./${local_gnorm} @@ -185,15 +156,8 @@ fi # These aren't used for processing but will be pushed to the # server from the tmp dir. #------------------------------------------------------------------ -costs=${gnorm_dir}/${MINMON_SUFFIX}.${PDATE}.costs.txt -if [[ ! -e $costs ]]; then - costs=${gnorm_dir}/${PDATE}.costs.txt -fi - -cost_terms=${gnorm_dir}/${MINMON_SUFFIX}.${PDATE}.cost_terms.txt -if [[ ! -e $cost_terms ]]; then - cost_terms=${gnorm_dir}/${PDATE}.cost_terms.txt -fi +costs=${gnorm_dir}/${PDATE}.costs.txt +cost_terms=${gnorm_dir}/${PDATE}.cost_terms.txt if [[ -s ${costs} ]]; then cp ${costs} ${WORKDIR}/${run_suffix}.${PDATE}.costs.txt @@ -217,28 +181,16 @@ cdate=$bdate #------------------------------------------------------------------ while [[ $cdate -le $edate ]]; do echo "processing cdate = $cdate" - pdy=`echo $cdate|cut -c1-8` - if [[ ${#RUN} -gt 0 ]]; then - gnorm_dir=${TANKDIR}/${RUN}.${pdy} - if [[ -d $gnorm_dir/minmon ]]; then - gnorm_dir=${gnorm_dir}/minmon - fi - fi - if [[ ! -d $gnorm_dir ]]; then - gnorm_dir=${TANKDIR}/minmon_${MINMON_SUFFIX}.${pdy} - fi + pdy=`echo $cdate | cut -c1-8` + cyc=`echo $cdate | cut -c9-10` - gnorms_file=${gnorm_dir}/${MINMON_SUFFIX}.${cdate}.gnorms.ieee_d - if [[ ! -e $gnorms_file ]]; then - gnorms_file=${gnorm_dir}/${cdate}.gnorms.ieee_d - fi + gnorm_dir=${TANKDIR}/${RUN}.${pdy}/${cyc}/minmon + + gnorms_file=${gnorm_dir}/${cdate}.gnorms.ieee_d local_gnorm=${cdate}.gnorms.ieee_d - reduct_file=${gnorm_dir}/${MINMON_SUFFIX}.${cdate}.reduction.ieee_d - if [[ ! -e $reduct_file ]]; then - reduct_file=${gnorm_dir}/${cdate}.reduction.ieee_d - fi + reduct_file=${gnorm_dir}/${cdate}.reduction.ieee_d local_reduct=${cdate}.reduction.ieee_d if [[ -s ${gnorms_file} ]]; then @@ -300,17 +252,13 @@ while [ $not_done -eq 1 ] && [ $ctr -le 20 ]; do ${M_IG_SCRIPTS}/update_ctl_tdef.sh ${WORKDIR}/reduction.ctl ${bdate} -# if [[ $AREA = "glb" ]]; then -# ${SCRIPTS}/update_ctl_xdef.sh ${WORKDIR}/allgnorm.ctl 202 -# fi - ####################### # Q: does NDAS really use 101 instead of 102? That can't be somehow.... ####################### - if [[ $MINMON_SUFFIX = "RAP" ]]; then - ${M_IG_SCRIPTS}/update_ctl_xdef.sh ${WORKDIR}/allgnorm.ctl 102 - fi +# if [[ $MINMON_SUFFIX = "RAP" ]]; then +# ${M_IG_SCRIPTS}/update_ctl_xdef.sh ${WORKDIR}/allgnorm.ctl 102 +# fi #----------------------------------------------------------------- # Copy the plot script and build the plot driver script @@ -380,11 +328,7 @@ cp *cost*.txt tmp/. #-------------------------------------------------------------------- if [[ ${DO_ERROR_RPT} -eq 1 ]]; then - if [[ ${#RUN} -gt 0 ]]; then - err_msg=${TANKDIR}/${RUN}.${pdy}/minmon/${PDATE}.errmsg.txt - else - err_msg=${TANKDIR}/minmon.${pdy}/${run_suffix}.${PDATE}.errmsg.txt - fi + err_msg=${TANKDIR}/${RUN}.${pdy}/${cyc}/minmon/${PDATE}.errmsg.txt if [[ -e $err_msg ]]; then err_rpt="./err_rpt.txt" @@ -396,7 +340,7 @@ if [[ ${DO_ERROR_RPT} -eq 1 ]]; then echo "THIS IS AN AUTOMATED EMAIL. REPLIES TO SENDER WILL NOT BE" >> $err_rpt echo "RECEIVED. PLEASE DIRECT REPLIES TO $MAIL_TO" >> $err_rpt echo "*********************** WARNING ***************************" >> $err_rpt - + if [[ $MAIL_CC == "" ]]; then /bin/mail -s MinMon_error_report ${MAIL_TO}< ${err_rpt} else @@ -409,7 +353,8 @@ fi #-------------------------------------------------------------------- # Push the image & txt files over to the server #-------------------------------------------------------------------- - if [[ ${MY_MACHINE} = "wcoss" || ${MY_MACHINE} = "cray" ]]; then + if [[ ${MY_MACHINE} = "wcoss" || ${MY_MACHINE} = "cray" || \ + ${MY_MACHINE} = "wcoss_d" ]]; then cd ./tmp $RSYNC -ave ssh --exclude *.ctl* ./ \ ${WEBUSER}@${WEBSERVER}:${WEBDIR}/$run_suffix/ @@ -419,13 +364,13 @@ fi # Call nu_make_archive.sh to write archive files to hpss and # update the prod machine with any missing M_TANKDIR directories. #-------------------------------------------------------------------- - if [[ ${DO_ARCHIVE} -eq 1 ]]; then - ${M_IG_SCRIPTS}/nu_make_archive.sh - fi +# if [[ ${DO_ARCHIVE} -eq 1 ]]; then +# ${M_IG_SCRIPTS}/nu_make_archive.sh +# fi -cd ${WORKDIR} -cd .. -rm -rf ${WORKDIR} +#cd ${WORKDIR} +#cd .. +#rm -rf ${WORKDIR} -echo end MinMonPlt.sh +echo "end MinMonPlt.sh" exit diff --git a/util/Minimization_Monitor/image_gen/ush/find_cycle.pl b/util/Minimization_Monitor/image_gen/ush/find_cycle.pl deleted file mode 100755 index ebe46035d..000000000 --- a/util/Minimization_Monitor/image_gen/ush/find_cycle.pl +++ /dev/null @@ -1,204 +0,0 @@ -#! /usr/bin/perl - -#----------------------------------------------------------------------- -# find_cycle.pl -# -# Given a directory containing ${SUFFIX}_minmon.YYYYMMDDHH -# subdirectories, determine the first or last cycle for which ieee_d -# data files exist. -# -# Return that first/last cycle as a text string in YYYYMMDDHH format, -# or return nothing if none of the expected data files are found. -# -# NOTE: This has been updated to work with TANK_USE_DIR configuration -# of ~/nbns/stats/$suffix, but with the 0 option (first) it's -# returning first+1 for some reason. I'll have to worry about -# that later. -#----------------------------------------------------------------------- - - use strict; - use warnings; - - use Scalar::Util qw(looks_like_number); - - #------------------------------------------------------------------- - # - # Subroutine uniq - # - # Given an input array, return all unique values in an array. - # - #------------------------------------------------------------------- - sub uniq { - my %seen; - return grep { !$seen{$_}++ } @_; - } - - - ##------------------------------------------------------------------ - ##------------------------------------------------------------------ - ## - ## begin main - ## - ##------------------------------------------------------------------ - ##------------------------------------------------------------------ - - if ($#ARGV != 2 ) { - print "usage: find_cycle.pl suffix 0/1 /path_to_directory/containing/minmon.YYYYMMDDHH subdirectories. \n"; - print " 0 = first, 1 = last \n"; - exit; - } - my $suffix = $ARGV[0]; - my $target = $ARGV[1]; - my $dirpath = $ARGV[2]; - my @alldirs; - - - # Get list of minmon.* sub-directories - # - opendir(DIR, $dirpath) or die "Cannot open directory $!"; - while (my $file = readdir(DIR)) { - next unless (-d "$dirpath/$file"); - push( @alldirs, $file ); - } - closedir DIR; - my @mmdirs = grep { /minmon/ } @alldirs; - if( $#mmdirs < 0 ) { - @mmdirs = grep { /gdas/ } @alldirs; - } - - # If there are no minmon* subdirectories, then exit without - # returning any date string. - # - if( $#mmdirs < 0 ) { - print "exiting with 0 mmdirs\n"; - exit; - } - - # Sort the mmdirs array and loop through it from end to beginning - # - if( $target == 1 ){ # search is for latest date/time - - my @sortmm = sort( @mmdirs ); - my $ctr = $#sortmm + 1; - - my $found_cycle = 0; - - # Start with the latest directory and attempt to locate the - # gnorm_data.txt file. The last line will contain the - # latest cycle processed. - do { - - $ctr--; - - - # In each subdirectory attempt to locate the last - # and parse out all unique date values. The oldest is the answer - # we're looking for. - # - # If there are no time.*ieee_d* files, step to the next iteration. - # - my $newdir; - - if( -d "${dirpath}/${sortmm[$ctr]}/minmon" ){ - $newdir = "${dirpath}/${sortmm[$ctr]}/minmon"; - } - elsif( -d "${dirpath}/${sortmm[$ctr]}" ){ - $newdir = "${dirpath}/${sortmm[$ctr]}"; - } - - - opendir DIR, $newdir or die "Cannot open the current directory: $!"; - - my @timefiles = grep { /costs.txt/ } readdir DIR; - - if( $#timefiles >= 0 ) { - my @sorttime = sort( @timefiles ); - my @times; - my $idx = 0; - - # Find the first string of 10 digits; that's the date. Use that $idx - # number to process all files. - # - my @vals = split( '\.', $timefiles[0] ); - for ( my $ii=$#vals; $ii >= 0; $ii-- ) { - if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ - $idx = $ii; - } - } - - for ( my $ii=$#sorttime; $ii >= 0; $ii-- ) { - my $teststr = $sorttime[$ii]; - - my @values = split( '\.', $teststr ); - push( @times, $values[$idx] ); - - } - - if ( $#times >= 0 ) { - $found_cycle = 1; - my @utimes = sort( uniq( @times ) ); - print "$utimes[$#utimes]"; - } - } - - } while $found_cycle == 0 && $ctr > 0; - } - else { # search is for earliest date/time - - my @sortmm = sort( @mmdirs ); - my $ctr = -1; - - my $found_cycle = 0; - do { - - $ctr++; - - - # In each subdirectory build a list of time.*ieee_d* files - # and parse out all unique date values. The oldest is the answer - # we're looking for. - # - # If there are no time.*ieee_d* files, step to the next iteration. - # - my $newdir; - - if( -d "${dirpath}/${sortmm[$ctr]}/minmon" ){ - $newdir = "${dirpath}/${sortmm[$ctr]}/minmon"; - } - elsif( -d "${dirpath}/${sortmm[$ctr]}" ){ - $newdir = "${dirpath}/${sortmm[$ctr]}"; - } - - opendir DIR, $newdir or die "Cannot open the current directory: $!"; - - my @timefiles = grep { /costs.txt/ } readdir DIR; - - if( $#timefiles >= 0 ) { - my @sorttime = sort( @timefiles ); - my @times; - - for ( my $ii=0; $ii <= $#sorttime; $ii++ ) { - my $teststr = $sorttime[$ii]; - - # Find the first string of 10 digits; that's the date. - # - my @vals = split( '\.', $sorttime[$ii] ); -# my @vals = split( '\.', $timefiles[0] ); - for ( my $ii=$#vals; $ii >= 0; $ii-- ) { - if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ - push( @times, $vals[$ii] ); - } - } - } - - if ( $#times >= 0 ) { - $found_cycle = 1; - my @utimes = sort( uniq( @times ) ); - print "$utimes[0]"; - } - } - - } while $found_cycle == 0 && $ctr < $#sortmm ; - } - - diff --git a/util/Minimization_Monitor/image_gen/ush/find_cycle.pl b/util/Minimization_Monitor/image_gen/ush/find_cycle.pl new file mode 120000 index 000000000..c254910ac --- /dev/null +++ b/util/Minimization_Monitor/image_gen/ush/find_cycle.pl @@ -0,0 +1 @@ +../../data_xtrct/ush/find_cycle.pl \ No newline at end of file diff --git a/util/Minimization_Monitor/image_gen/ush/pen_data_map.xml b/util/Minimization_Monitor/image_gen/ush/pen_data_map.xml new file mode 100644 index 000000000..501ea916e --- /dev/null +++ b/util/Minimization_Monitor/image_gen/ush/pen_data_map.xml @@ -0,0 +1,16 @@ + + + + glb + /com/gfs/prod + + + /u/${LOGNAME}/nbns/stats + 1 + + + glb + 1 + 2016030706 + + diff --git a/util/Minimization_Monitor/image_gen/ush/run_gdas_IG.sh b/util/Minimization_Monitor/image_gen/ush/run_gdas_IG.sh new file mode 100755 index 000000000..51f2da85c --- /dev/null +++ b/util/Minimization_Monitor/image_gen/ush/run_gdas_IG.sh @@ -0,0 +1,48 @@ +#!/bin/sh + +set -ax + +#package=MinMon +package=ProdGSI/util/Minimization_Monitor + +suffix=GFS +run=gdas + +NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.0/exec/ips/ndate +echo NDATE = $NDATE +ch=`hostname | cut -c1` + +scripts=/gpfs/dell2/emc/modeling/noscrub/${LOGNAME}/${package}/image_gen/ush +ptmp=/gpfs/dell2/ptmp/Edward.Safford + +export DO_ARCHIVE=0 +export JOB_QUEUE=dev_shared +export DO_ERROR_RPT=1 + +export MAIL_CC="russ.treadon@noaa.gov, andrew.collard@noaa.gov" +export MAIL_TO="edward.safford@noaa.gov" + +data_map=${scripts}/pen_data_map.xml + +tankdir=/u/Edward.Safford/nbns/stats/${suffix} + +imgdate=`${scripts}/query_data_map.pl ${data_map} ${suffix}_${run} imgdate` +idate=`$NDATE +6 $imgdate` +PDY=`echo $idate | cut -c1-8` +cyc=`echo $idate | cut -c9-10` + +prodate=`${scripts}/find_cycle.pl --run $run --cyc 1 --dir ${tankdir}` +echo "imgdate, prodate = $imgdate, $prodate" +if [[ $idate -le $prodate ]]; then + + echo " firing MinMon_Plt.sh" + ${scripts}/MinMon_Plt.sh ${suffix} -p $idate -r $run \ + 1>${ptmp}/logs/${suffix}/${run}/minmon/IG.${run}.${PDY}.${cyc}.log \ + 2>${ptmp}/logs/${suffix}/${run}/minmon/IG.${run}.${PDY}.${cyc}.err + + rc=`${scripts}/update_data_map.pl ${data_map} ${suffix}_${run} imgdate ${idate}` + +fi + + +exit diff --git a/util/Minimization_Monitor/image_gen/ush/run_gfs_IG.sh b/util/Minimization_Monitor/image_gen/ush/run_gfs_IG.sh new file mode 100755 index 000000000..70b90b233 --- /dev/null +++ b/util/Minimization_Monitor/image_gen/ush/run_gfs_IG.sh @@ -0,0 +1,48 @@ +#!/bin/sh + +set -ax + +#package=MinMon +package=ProdGSI/util/Minimization_Monitor + +suffix=GFS +run=gfs + +NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.0/exec/ips/ndate +echo NDATE = $NDATE +ch=`hostname | cut -c1` + +scripts=/gpfs/dell2/emc/modeling/noscrub/${LOGNAME}/${package}/image_gen/ush +ptmp=/gpfs/dell2/ptmp/Edward.Safford + +export DO_ARCHIVE=0 +export JOB_QUEUE=dev_shared +export DO_ERROR_RPT=1 + +export MAIL_CC="russ.treadon@noaa.gov, andrew.collard@noaa.gov" +export MAIL_TO="edward.safford@noaa.gov" + +data_map=${scripts}/pen_data_map.xml + +tankdir=/u/Edward.Safford/nbns/stats/${suffix} + +imgdate=`${scripts}/query_data_map.pl ${data_map} ${suffix}_${run} imgdate` +idate=`$NDATE +6 $imgdate` +PDY=`echo $idate | cut -c1-8` +cyc=`echo $idate | cut -c9-10` + +prodate=`${scripts}/find_cycle.pl --run $run --cyc 1 --dir ${tankdir}` +echo "imgdate, prodate = $imgdate, $prodate" +if [[ $idate -le $prodate ]]; then + + echo " firing MinMon_Plt.sh" + ${scripts}/MinMon_Plt.sh ${suffix} -p $idate -r $run \ + 1>${ptmp}/logs/${suffix}/${run}/minmon/IG.${run}.${PDY}.${cyc}.log \ + 2>${ptmp}/logs/${suffix}/${run}/minmon/IG.${run}.${PDY}.${cyc}.err + + rc=`${scripts}/update_data_map.pl ${data_map} ${suffix}_${run} imgdate ${idate}` + +fi + + +exit diff --git a/util/Minimization_Monitor/image_gen/ush/run_script.sh b/util/Minimization_Monitor/image_gen/ush/run_script.sh index f474ba8d5..d55bd586c 100755 --- a/util/Minimization_Monitor/image_gen/ush/run_script.sh +++ b/util/Minimization_Monitor/image_gen/ush/run_script.sh @@ -1,48 +1,68 @@ #!/bin/sh -package=ProdGSI -suffix=fv3rt1 -run=gdas +#---------------------------------------------------------------------- +# +# This is a generic image generation leader script. +# The MinMon_Plt.sh script may be called directly or this script +# may be used to override specific default values in the parm files +# and/or MinMon_Plt.sh script. +# +# MINMON_SUFFIX corresponds to the $NET value +# +# RUN is either gfs or gdas +# +# MAIL_CC list is used if warnings messages are set to on. +# +# idate, if set, will override the next value in the local +# pen_data_map.xml file. +#---------------------------------------------------------------------- -idev=`cat /etc/dev | cut -c1` -iprod=`cat /etc/prod | cut -c1` +MINMON_SUFFIX=testmm +RUN=gfs -. /opt/modules/3.2.6.7/init/sh -module use -a /gpfs/hps/nco/ops/nwprod/modulefiles -module use -a /usrx/local/dev/modulefiles -module load GrADS +#export MAIL_CC= +#idate= -scripts=/gpfs/hps3/emc/da/noscrub/${LOGNAME}/${package}/util/Minimization_Monitor/image_gen/ush -ptmp=/gpfs/hps2/ptmp/Edward.Safford -export NDATE=/gpfs/hps/nco/ops/nwprod/prod_util.v1.0.14/exec/ndate -export DO_ARCHIVE=0 -export JOB_QUEUE=dev_shared -export DO_ERROR_RPT=1 +#---------------------------------------------------------------------- +# no changes should be necessary below this point. +#---------------------------------------------------------------------- +. ../../parm/MinMon.ver +. ../../parm/MinMon_config -#export MAIL_CC="russ.treadon@noaa.gov, john.derber@noaa.gov, andrew.collard@noaa.gov" -export MAIL_CC="edward.c.safford@gmail.com" +if [[ $idate == "" ]]; then + data_map=${M_IG_SCRIPTS}/pen_data_map.xml -data_map=${scripts}/pen_data_map.xml + imgdate=`${M_IG_SCRIPTS}/query_data_map.pl \ + ${data_map} ${MINMON_SUFFIX}_${RUN} imgdate` + echo "imgdate = $imgdate" -tankdir=/u/Edward.Safford/nbns/stats/${suffix} -#tankdir=/gpfs/hps/emc/global/noscrub/emc.glopara/minmon/stats/${suffix} -imgdate=`${scripts}/query_data_map.pl ${data_map} ${suffix}_${run} imgdate` -idate=`$NDATE +6 $imgdate` -PDY=`echo $idate | cut -c1-8` + idate=`$NDATE +6 $imgdate` +fi + +pdy=`echo $idate | cut -c1-8` cyc=`echo $idate | cut -c9-10` +echo "idate = $idate" + +echo "tank = ${M_TANKverf}/stats/${MINMON_SUFFIX}" + +prodate=`${M_IG_SCRIPTS}/find_cycle.pl \ + --dir ${M_TANKverf}/stats/${MINMON_SUFFIX} \ + --cyc 1 --run ${RUN}` -prodate=`${scripts}/find_cycle.pl ${suffix} 1 ${tankdir}` echo "imgdate, prodate = $imgdate, $prodate" + + if [[ $idate -le $prodate ]]; then echo " firing MinMon_Plt.sh" - ${scripts}/MinMon_Plt.sh ${suffix} -p $idate -r $run \ - 1>${ptmp}/logs/${suffix}/minmon/IG.${run}.${PDY}.${cyc}.log \ - 2>${ptmp}/logs/${suffix}/minmon/IG.${run}.${PDY}.${cyc}.err + ${M_IG_SCRIPTS}/MinMon_Plt.sh ${MINMON_SUFFIX} -p $idate -r $RUN \ + 1>${LOGdir}/IG.${run}.${PDY}.${cyc}.log \ + 2>${LOGdir}/IG.${run}.${PDY}.${cyc}.err - rc=`${scripts}/update_data_map.pl ${data_map} ${suffix}_${run} imgdate ${idate}` + rc=`${M_IG_SCRIPTS}/update_data_map.pl ${data_map} \ + ${MINMON_SUFFIX}_${RUN} imgdate ${idate}` fi diff --git a/util/Minimization_Monitor/image_gen/ush/run_v16rt1_IG.sh b/util/Minimization_Monitor/image_gen/ush/run_v16rt1_IG.sh new file mode 100755 index 000000000..5df811a0e --- /dev/null +++ b/util/Minimization_Monitor/image_gen/ush/run_v16rt1_IG.sh @@ -0,0 +1,61 @@ +#!/bin/sh + +package=MinMon +#package=ProdGSI/util/Minimization_Monitor + +suffix=v16rt1 +run=gdas + +idev=`cat /etc/dev | cut -c1` +iprod=`cat /etc/prod | cut -c1` + + shell=sh + source /usrx/local/prod/lmod/lmod/init/${shell} + + export MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core:/usrx/local/prod/modulefiles/core_third:/usrx/local/prod/modulefiles/defs:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod:/usrx/local/dev/modulefiles + module load ips/18.0.1.163 + module load metplus/2.1 + module load lsf/10.1 + module load prod_util/1.1.2 + module load GrADS/2.2.0 + +echo NDATE = $NDATE +ch=`hostname | cut -c1` + +#scripts=/gpfs/${ch}d2/emc/da/noscrub/${LOGNAME}/${package}/image_gen/ush +scripts=/gpfs/dell2/emc/modeling/noscrub/${LOGNAME}/${package}/image_gen/ush + +#export NDATE=/gpfs/hps/nco/ops/nwprod/prod_util.v1.0.14/exec/ndate +export DO_ARCHIVE=0 +export JOB_QUEUE=dev_shared +export DO_ERROR_RPT=1 + +export MAIL_CC="russ.treadon@noaa.gov, andrew.collard@noaa.gov" +export MAIL_TO="edward.safford@noaa.gov" + +data_map=${scripts}/pen_data_map.xml + +tankdir=/u/Edward.Safford/nbns/stats/${suffix} + +imgdate=`${scripts}/query_data_map.pl ${data_map} ${suffix}_${run} imgdate` +idate=`$NDATE +6 $imgdate` +PDY=`echo $idate | cut -c1-8` +cyc=`echo $idate | cut -c9-10` + +ptmp=/gpfs/dell2/ptmp/Edward.Safford + +prodate=`${scripts}/find_cycle.pl --run gdas --cyc 1 --dir ${tankdir}` +echo "imgdate, prodate = $imgdate, $prodate" +if [[ $idate -le $prodate ]]; then + + echo " firing MinMon_Plt.sh" + ${scripts}/MinMon_Plt.sh ${suffix} -p $idate -r $run \ + 1>${ptmp}/logs/${suffix}/${run}/minmon/IG.${run}.${PDY}.${cyc}.log \ + 2>${ptmp}/logs/${suffix}/${run}/minmon/IG.${run}.${PDY}.${cyc}.err + + rc=`${scripts}/update_data_map.pl ${data_map} ${suffix}_${run} imgdate ${idate}` + +fi + + +exit diff --git a/util/Minimization_Monitor/nwprod/gdas.v1.0.0/driver/test_jgdas_vminmon_hera.sh b/util/Minimization_Monitor/nwprod/gdas.v1.0.0/driver/test_jgdas_vminmon_hera.sh new file mode 100755 index 000000000..39c812719 --- /dev/null +++ b/util/Minimization_Monitor/nwprod/gdas.v1.0.0/driver/test_jgdas_vminmon_hera.sh @@ -0,0 +1,74 @@ +#!/bin/ksh + +#SBATCH -o gdas_verfrad.o%j +#SBATCH -J gdas_verfrad +#SBATCH --ntasks=1 --mem=5g +#SBATCH --time=20 +#SBATCH --account=fv3-cpu +#SBATCH -D . + +set -x + +export PDATE=${PDATE:-2018070418} + + +############################################################# +# Specify whether the run is production or development +############################################################# +export PDY=`echo $PDATE | cut -c1-8` +export cyc=`echo $PDATE | cut -c9-10` +export job=gdas_vminmon.${cyc} +export pid=${pid:-$$} +export jobid=${job}.${pid} +export envir=para +export DATAROOT=${DATAROOT:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/test_data} +export COMROOT=${COMROOT:-/scratch2/NCEPDEV/stmp3/$LOGNAME/com} +export STMP_USER=${STMP_USER:-/scratch2/NCEPDEV/stmp3/$LOGNAME} + + +############################################################# +# Specify versions +############################################################# +export gdas_ver=v1.0.0 +export global_shared_ver=v1.0.1 + +############################################################# +# Add nwpara tools to path +############################################################# +#NWPROD=${NWPROD:-/scratch4/NCEPDEV/global/save/glopara/nwpara/util} +#NWPRODush=${NWPRODush:=${NWPROD}/ush} +#NWPRODexec=${NWPRODexec:=${NWPROD}/exec} +#export PATH=${PATH}:${NWPRODush}:${NWPRODexec} + + +############################################################# +# Set user specific variables +############################################################# +export MINMON_SUFFIX=${MINMON_SUFFIX:-testminmon} + +export NWTEST=${NWTEST:-/scratch1/NCEPDEV/da/${LOGNAME}/noscrub/ProdGSI/util/Minimization_Monitor/nwprod} +export HOMEgdas=${HOMEgdas:-${NWTEST}/gdas.${gdas_ver}} +export HOMEgfs=${HOMEgfs:-${HOMEgdas}} +export JOBGLOBAL=${HOMEgdas}/jobs +export HOMEminmon=${HOMEminmon:-${NWTEST}/minmon_shared.${global_shared_ver}} +export COM_IN=${COM_IN:-${DATAROOT}} +export M_TANKverf=${M_TANKverf:-${COMROOT}/${MINMON_SUFFIX}} +export M_FIXgdas=${M_FIXgdas:-${HOMEgdas}/fix} + +####################################################################### +# theia specific hacks for no prod_utils module (ndate) +####################################################################### +export MY_MACHINE=hera +export NDATE=/home/Edward.Safford/bin/ndate + +export PERL5LIB="/usr/lib64/perl5:/usr/share/perl5" +export VERBOSE=YES +export KEEPDATA=YES + +############################################################# +# Execute job +############################################################# +$JOBGLOBAL/JGDAS_VMINMON + +exit + diff --git a/util/Minimization_Monitor/nwprod/gdas.v1.0.0/driver/test_jgdas_vminmon_wcoss_d.sh b/util/Minimization_Monitor/nwprod/gdas.v1.0.0/driver/test_jgdas_vminmon_wcoss_d.sh new file mode 100755 index 000000000..0d6943d97 --- /dev/null +++ b/util/Minimization_Monitor/nwprod/gdas.v1.0.0/driver/test_jgdas_vminmon_wcoss_d.sh @@ -0,0 +1,83 @@ +#!/bin/ksh + +#BSUB -o gdas_vminmon.o%J +#BSUB -e gdas_vminmon.o%J +#BSUB -J gdas_vminmon +#BSUB -q dev_shared +#BSUB -n 1 +#BSUB -R affinity[core] +#BSUB -M 80 +#BSUB -W 00:05 +#BSUB -P GFS-T2O + +set -ax + +export PDATE=${PDATE:-2018011118} + +############################################################# +# Specify whether the run is production or development +############################################################# +export PDY=`echo $PDATE | cut -c1-8` +export cyc=`echo $PDATE | cut -c9-10` +export job=gdas_vminmon.${cyc} +export pid=${pid:-$$} +export jobid=${job}.${pid} +export envir=para + +export DATAROOT=${DATAROOT:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/test_data} +export COMROOT=${COMROOT:-/gpfs/dell2/ptmp/Edward.Safford/com} + + +############################################################# +# Specify versions +############################################################# +export gdas_ver=v14.1.0 +export global_shared_ver=v14.1.0 +export gdas_minmon_ver=v1.0.0 +export minmon_shared_ver=v1.0.1 + + +############################################################# +# Load modules +############################################################# + shell=ksh + source /usrx/local/prod/lmod/lmod/init/${shell} + + MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/core_third + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/defs + MODULEPATH=${MODULEPATH}:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod + export MODULEPATH=${MODULEPATH}:/usrx/local/dev/modulefiles + + module load ips/18.0.1.163 + module load metplus/2.1 + module load lsf/10.1 + module load prod_util/1.1.2 + module load util_shared/1.1.0 + module load pm5/1.0 + + module list + + +############################################################# +# Set user specific variables +############################################################# +export MINMON_SUFFIX=${MINMON_SUFFIX:-testminmon_gdas} +export NWTEST=${NWTEST:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Minimization_Monitor/nwprod} +export HOMEgdas=${NWTEST}/gdas.${gdas_minmon_ver} +export HOMEgfs=${HOMEgfs:-${HOMEgdas}} + +export JOBGLOBAL=${HOMEgdas}/jobs +export HOMEminmon=${NWTEST}/minmon_shared.${minmon_shared_ver} + +export COM_IN=${COM_IN:-${DATAROOT}} +export M_TANKverf=${COMROOT}/${MINMON_SUFFIX} +export M_FIXgdas=${HOMEgdas}/fix + +############################################################# +# Execute job +############################################################# +$JOBGLOBAL/JGDAS_VMINMON + +exit + diff --git a/util/Minimization_Monitor/nwprod/gdas.v1.0.0/jobs/JGDAS_VMINMON b/util/Minimization_Monitor/nwprod/gdas.v1.0.0/jobs/JGDAS_VMINMON index a3b0121c9..3c584893f 100755 --- a/util/Minimization_Monitor/nwprod/gdas.v1.0.0/jobs/JGDAS_VMINMON +++ b/util/Minimization_Monitor/nwprod/gdas.v1.0.0/jobs/JGDAS_VMINMON @@ -6,9 +6,6 @@ set -xa echo `date` $0 `date -u` begin export PS4='$SECONDS + ' -export RUN_ENVIR=${RUN_ENVIR:-nco} -export envir=${envir:-prod} - ############################### # Specify NET and RUN name ############################## @@ -21,134 +18,81 @@ export RUN=${RUN:-gdas} ########################################################### export pid=$$ export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} - -export DATAROOT=${DATAROOT:-/tmpnwprod2} -export DATA=${DATA:-${DATAROOT}/${jobid}} +export DATA=${DATA:-${DATAROOT}/${jobid:?}} mkdir -p $DATA cd $DATA -############################################################### -# This block can be modified for different test environment -############################################################### -#if [ $RUN_ENVIR = prod -a $envir != prod ]; then -# export SENDCOM=${SENDCOM:-NO} -#fi ########################################################### # obtain unique process id (pid) and make temp directories ########################################################### -export MINMON_SUFFIX=${MINMON_SUFFIX:-GDAS} +export MINMON_SUFFIX=${MINMON_SUFFIX:-${NET}} export m_job=${m_job:-${MINMON_SUFFIX}_mmDE} -#################################### -# File To Log Msgs -#################################### -export jlogfile=${jlogfile:-${COMROOT}/logs/jlogfiles/jlogfile.${m_job}.${pid}} - - -################################################## -# SENDECF - Flag Events on ECF -# SENDCOM - Copy Files From TMPDIR to $COMOUT -# SENDDBN - Issue DBNet Client Calls -# VERBOSE - Specify Verbose Output -################################################## -export SENDCOM=${SENDCOM:-YES} -export SENDDBN=${SENDDBN:-NO} -export SENDECF=${SENDECF:-NO} -export VERBOSE=${VERBOSE:-YES} - - -################################### -# Set up the UTILITIES -################################### -export utilscript=${utilscript:-${UTILROOT}/ush} -export utilexec=${utilexec:-${UTILROOT}/exec} - - ############################################## # Specify Package Areas ############################################## -# JY export HOMEgdas=${HOMEgdas:-${NWROOT}/gdas.${gdas_ver}} -export HOMEgdas=${HOMEgdas:-${NWROOT}/gdas_minmon.${gdas_minmon_ver}} -export PARMgdas=${PARMgdas:-$HOMEgdas/parm} -export SCRgdas=${SCRgdas:-$HOMEgdas/scripts} -export FIXgdas=${FIXgdas:-$HOMEgdas/fix} +export HOMEgfs=${HOMEgfs:-${NWROOT}/gfs.${gfs_ver}} +export SCRgfs=${SCRgfs:-$HOMEgfs/scripts} + +export M_FIXgdas=${M_FIXgdas:-$HOMEgfs/fix/gdas} -export HOMEminmon=${HOMEminmon:-${NWROOT}/minmon_shared.${minmon_shared_ver}} +export HOMEminmon=${HOMEminmon:-${HOMEgfs}} export EXECminmon=${EXECminmon:-$HOMEminmon/exec} export USHminmon=${USHminmon:-$HOMEminmon/ush} -export FIXminmon=${FIXminmon:-${HOMEminmon/fix}} - -################################### -# source the parm file -################################### -. ${PARMgdas}/gdas_minmon.parm ############################################# # Run setpdy and initialize PDY variables ############################################# -if [[ $MY_MACHINE != "theia" ]]; then +if [[ $MY_MACHINE != "hera" ]]; then export cycle=t${cyc}z setpdy.sh . ./PDY fi +############################################# +# determine PDY and cyc for previous cycle +############################################# + +cdate=`${NDATE} -6 ${PDY}${cyc}` +echo 'pdate = ${pdate}' + +export P_PDY=`echo ${cdate} | cut -c1-8` +export p_cyc=`echo ${cdate} | cut -c9-10` + + ############################################# # TANKverf - WHERE OUTPUT DATA WILL RESIDE ############################################# -M_TANKverf=${M_TANKverf:-${COMROOT}/verf/${envir}} - -echo "M_TANKverf = $M_TANKverf" -echo "TANK_USE_RUN = $TANK_USE_RUN" -echo "M_TANKverfM0 = $M_TANKverfM0" -echo "M_TANKverfM1 = $M_TANKverfM1" - -if [[ ${TANK_USE_RUN} -ne 1 ]]; then - M_TANKverfM0=${M_TANKverfM0:-${M_TANKverf}/minmon_${MINMON_SUFFIX}.${PDY}} - export M_TANKverfM1=${M_TANKverfM1:-${M_TANKverf}/minmon_${MINMON_SUFFIX}.${PDYm1}} -else - M_TANKverfM0=${M_TANKverfM0:-${M_TANKverf}/${RUN}.${PDY}/minmon} - export M_TANKverfM1=${M_TANKverfM1:-${M_TANKverf}/${RUN}.${PDYm1}/minmon} -fi +export COM_IN=${COM_IN:-${COMROOT}/${NET}/${envir}} +M_TANKverf=${M_TANKverf:-${COM_IN}} +M_TANKverfM0=${M_TANKverfM0:-${M_TANKverf}/${RUN}.${PDY}/${cyc}/minmon} +export M_TANKverfM1=${M_TANKverfM1:-${M_TANKverf}/${RUN}.${P_PDY}/${p_cyc}/minmon} export M_TANKverf=$M_TANKverfM0 -export COM_IN=${COM_IN:-${COMROOT}/${NET}/${envir}} -export COMIN=${COMIN:-$COM_IN/${RUN}.${PDY}} +export COMIN=${COMIN:-$COM_IN/${RUN}.${PDY}/${cyc}} mkdir -p -m 775 $M_TANKverf - + + ######################################## # Set necessary environment variables ######################################## export CYCLE_INTERVAL=6 export gsistat=${gsistat:-${COMIN}/gdas.t${cyc}z.gsistat} -if [[ ! -e ${gsistat} ]]; then - export gsistat=${COMIN}/gsistat.gdas.${PDATE} -fi -msg="JOB HAS STARTED" -postmsg "$jlogfile" "$msg" ######################################################## # Execute the script. -${GMONSH:-$SCRgdas/exgdas_vrfminmon.sh.ecf} ${PDY} ${cyc} - +${GMONSH:-$SCRgfs/exgdas_vrfminmon.sh.ecf} ${PDY} ${cyc} err=$? +[[ $err -ne 0 ]] && exit $err -######################################################## - -if [[ ${err} -ne 0 ]]; then - msg="WARNING: JOB DID NOT COMPLETE NORMALLY, error code $err" -else - msg="JOB COMPLETED NORMALLY" -fi -postmsg "$jlogfile" "$msg" ################################ # Remove the Working Directory diff --git a/util/Minimization_Monitor/nwprod/gdas.v1.0.0/scripts/exgdas_vrfminmon.sh.ecf b/util/Minimization_Monitor/nwprod/gdas.v1.0.0/scripts/exgdas_vrfminmon.sh.ecf index 1174f9416..f55d494fb 100755 --- a/util/Minimization_Monitor/nwprod/gdas.v1.0.0/scripts/exgdas_vrfminmon.sh.ecf +++ b/util/Minimization_Monitor/nwprod/gdas.v1.0.0/scripts/exgdas_vrfminmon.sh.ecf @@ -10,48 +10,7 @@ # Abstract: This script runs the data extract/validation portion of the # MinMon package. # -# Script history log: -# 2015-04-10 Ed Safford -# -# Input script positional parameters: -# 1 Current analysis date in yyyymmddhh format -# defaults to PDY; required -# 2 cycle time in cc format -# defaults to cyc; required -# -# Imported Shell Variables: -# M_TANKverf repository for minmon data files -# DATA data working space -# MINMON_SUFFIX data set identifier, defaults to GDAS -# FIXgdas fixed file directory, gdas specific -# FIXminmon fixed file directory -# USHminmon scripts directory -# PDY processing day; -# overridden by 1 -# cyc processing cycle; -# overridden by 2 -# -# Exported Shell Variables: -# PDATE Processing date -# err last return code -# VERBOSE switches on more/less log output -# mm_gnormfile $GDASfix/gdas_minmon_gnorm.txt file -# mm_costfile $GDASfix/gdas_minmon_cost.txt file -# -# Modules and files referenced: -# scripts : ${USHminmon}/minmon_xtrct_gnorms.pl -# ${USHminmon}/minmon_xtrct_costs.pl -# ${USHminmon}/minmon_xtrct_reduction.pl -# -# programs : $NDATE -# -# input data : $gsistat=${COMIN}/gdas.t${cyc}z.gsistat -# -# output data: -# -# Remarks: -# -# Condition codes +# Condition codes # 0 - no problem encountered # >0 - some problem encountered # @@ -69,8 +28,6 @@ fi export scr=exgdas_vrfyminmon.sh.ecf -msg="${scr} HAS STARTED" -postmsg "$jlogfile" "$msg" export RUN_ENVIR=${RUN_ENVIR:-nco} export NET=${NET:-gfs} @@ -83,7 +40,6 @@ export envir=${envir:-prod} export PDY=${1:-${PDY:?}} export cyc=${2:-${cyc:?}} - ######################################## # Directories ######################################## @@ -94,8 +50,8 @@ export DATA=${DATA:-$(pwd)} # Filenames ######################################## gsistat=${gsistat:-$COMIN/gdas.t${cyc}z.gsistat} -export mm_gnormfile=${gnormfile:-${FIXgdas}/gdas_minmon_gnorm.txt} -export mm_costfile=${costfile:-${FIXgdas}/gdas_minmon_cost.txt} +export mm_gnormfile=${gnormfile:-${M_FIXgdas}/gdas_minmon_gnorm.txt} +export mm_costfile=${costfile:-${M_FIXgdas}/gdas_minmon_cost.txt} ######################################## # Other variables @@ -106,13 +62,6 @@ export NCP=${NCP:-/bin/cp} export NDATE=${NDATE:-/nwprod/util/exec/ndate} export pgm=exgdas_vrfminmon.sh.ecf -######################################################### -# M_TANKverf is storage location for generated files -######################################################### -export M_TANKverf=${M_TANKverf:-${COMROOT}/${NET}/${envir}/minmon_${MINMON_SUFFIX}.${PDY}} -export M_TANKverfM1=${M_TANKverfM1:-${COMROOT}/${NET}/${envir}/minmmon_${MINMON_SUFFIX}.${PDYm1}} -##################################################################### - if [[ ! -d ${DATA} ]]; then mkdir $DATA fi @@ -130,28 +79,25 @@ if [[ -s ${gsistat} ]]; then # Copy the $MINMON_SUFFIX.gnorm_data.txt file to the working directory # It's ok if it doesn't exist; we'll create a new one if needed. #------------------------------------------------------------------ - if [[ -s ${M_TANKverf}/${MINMON_SUFFIX}.gnorm_data.txt ]]; then - $NCP ${M_TANKverf}/${MINMON_SUFFIX}.gnorm_data.txt gnorm_data.txt - elif [[ -s ${M_TANKverf}/gnorm_data.txt ]]; then - $NCP ${M_TANKverf}/gnorm_data.txt gnorm_data.txt - elif [[ -s ${M_TANKverfM1}/${MINMON_SUFFIX}.gnorm_data.txt ]]; then - $NCP ${M_TANKverfM1}/${MINMON_SUFFIX}.gnorm_data.txt gnorm_data.txt + if [[ -s ${M_TANKverf}/gnorm_data.txt ]]; then + $NCP ${M_TANKverf}/gnorm_data.txt gnorm_data.txt elif [[ -s ${M_TANKverfM1}/gnorm_data.txt ]]; then $NCP ${M_TANKverfM1}/gnorm_data.txt gnorm_data.txt fi + #------------------------------------------------------------------ # Run the child sccripts. #------------------------------------------------------------------ - ${USHminmon}/minmon_xtrct_costs.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} ${jlogfile} + ${USHminmon}/minmon_xtrct_costs.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} dummy rc_costs=$? echo "rc_costs = $rc_costs" - ${USHminmon}/minmon_xtrct_gnorms.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} ${jlogfile} + ${USHminmon}/minmon_xtrct_gnorms.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} dummy rc_gnorms=$? echo "rc_gnorms = $rc_gnorms" - ${USHminmon}/minmon_xtrct_reduct.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} ${jlogfile} + ${USHminmon}/minmon_xtrct_reduct.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} dummy rc_reduct=$? echo "rc_reduct = $rc_reduct" @@ -171,13 +117,10 @@ elif [[ $rc_reduct -ne 0 ]]; then err=$rc_reduct fi - if [[ "$VERBOSE" = "YES" ]]; then echo "end exgdas_vrfminmon.sh.ecf, exit value = ${err}" fi -msg="${scr} HAS ENDED" -postmsg "$jlogfile" "$msg" set +x exit ${err} diff --git a/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon.sh b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon.sh index 814b6b766..384e25cee 100755 --- a/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon.sh +++ b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon.sh @@ -13,7 +13,7 @@ set -x -export PDATE=${PDATE:-2016030712} +export PDATE=${PDATE:-2016030812} ############################################################# # Specify whether the run is production or development diff --git a/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon_hera.sh b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon_hera.sh new file mode 100755 index 000000000..0ffa2810a --- /dev/null +++ b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon_hera.sh @@ -0,0 +1,65 @@ +#!/bin/ksh + +#SBATCH -o gfs_verfrad.o%j +#SBATCH -J gfs_verfrad +#SBATCH --ntasks=1 --mem=5g +#SBATCH --time=20 +#SBATCH --account=fv3-cpu +#SBATCH -D . + +set -x + +export PDATE=${PDATE:-2016030706} + + +############################################################# +# Specify whether the run is production or development +############################################################# +export PDY=`echo $PDATE | cut -c1-8` +export cyc=`echo $PDATE | cut -c9-10` +export job=gfs_vminmon.${cyc} +export pid=${pid:-$$} +export jobid=${job}.${pid} +export envir=para +export DATAROOT=${DATAROOT:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/test_data} +export COMROOT=${COMROOT:-/scratch2/NCEPDEV/stmp3/$LOGNAME/com} +export STMP_USER=${STMP_USER:-/scratch2/NCEPDEV/stmp3/$LOGNAME} + + +############################################################# +# Specify versions +############################################################# +export gfs_ver=v1.0.0 +export global_shared_ver=v1.0.1 + + +############################################################# +# Set user specific variables +############################################################# +export MINMON_SUFFIX=${MINMON_SUFFIX:-testminmon} + +export NWTEST=${NWTEST:-/scratch1/NCEPDEV/da/${LOGNAME}/noscrub/ProdGSI/util/Minimization_Monitor/nwprod} +export HOMEgfs=${HOMEgfs:-${NWTEST}/gfs.${gfs_ver}} +export JOBGLOBAL=${HOMEgfs}/jobs +export HOMEminmon=${HOMEminmon:-${NWTEST}/minmon_shared.${global_shared_ver}} +export COM_IN=${COM_IN:-${DATAROOT}} +export M_TANKverf=${M_TANKverf:-${COMROOT}/${MINMON_SUFFIX}} +export M_FIXgfs=${M_FIXgfs:-${HOMEgfs}/fix} + +####################################################################### +# theia specific hacks for no prod_utils module (ndate) +####################################################################### +export MY_MACHINE=hera +export NDATE=/home/Edward.Safford/bin/ndate + +export PERL5LIB="/usr/lib64/perl5:/usr/share/perl5" +export VERBOSE=YES +export KEEPDATA=YES + +############################################################# +# Execute job +############################################################# +$JOBGLOBAL/JGFS_VMINMON + +exit + diff --git a/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon_wcoss_d.sh b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon_wcoss_d.sh new file mode 100755 index 000000000..52dbc0cf1 --- /dev/null +++ b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/driver/test_jgfs_vminmon_wcoss_d.sh @@ -0,0 +1,82 @@ +#!/bin/ksh + +#BSUB -o gfs_vminmon.o%J +#BSUB -e gfs_vminmon.o%J +#BSUB -J gfs_vminmon +#BSUB -q dev_shared +#BSUB -n 1 +#BSUB -R affinity[core] +#BSUB -M 80 +#BSUB -W 00:05 +#BSUB -P GFS-T2O + +set -ax + +export PDATE=${PDATE:-2018011118} + +############################################################# +# Specify whether the run is production or development +############################################################# +export PDY=`echo $PDATE | cut -c1-8` +export cyc=`echo $PDATE | cut -c9-10` +export job=gfs_vminmon.${cyc} +export pid=${pid:-$$} +export jobid=${job}.${pid} +export envir=para + +export DATAROOT=${DATAROOT:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/test_data} +export COMROOT=${COMROOT:-/gpfs/dell2/ptmp/Edward.Safford/com} + + +############################################################# +# Specify versions +############################################################# +export gdas_ver=v14.1.0 +export global_shared_ver=v14.1.0 +export gfs_minmon_ver=v1.0.0 +export minmon_shared_ver=v1.0.1 + + +############################################################# +# Load modules +############################################################# + shell=ksh + source /usrx/local/prod/lmod/lmod/init/${shell} + + MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/core_third + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/defs + MODULEPATH=${MODULEPATH}:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod + export MODULEPATH=${MODULEPATH}:/usrx/local/dev/modulefiles + + module load ips/18.0.1.163 + module load metplus/2.1 + module load lsf/10.1 + module load prod_util/1.1.2 + module load util_shared/1.1.0 + module load pm5/1.0 + + module list + + +############################################################# +# Set user specific variables +############################################################# +export MINMON_SUFFIX=${MINMON_SUFFIX:-testminmon_gfs} +export NWTEST=${NWTEST:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Minimization_Monitor/nwprod} +export HOMEgfs=${NWTEST}/gfs.${gfs_minmon_ver} + +export JOBGLOBAL=${HOMEgfs}/jobs +export HOMEminmon=${NWTEST}/minmon_shared.${minmon_shared_ver} + +export COM_IN=${COM_IN:-${DATAROOT}} +export M_TANKverf=${COMROOT}/${MINMON_SUFFIX} +export M_FIXgfs=${HOMEgfs}/fix + +############################################################# +# Execute job +############################################################# +$JOBGLOBAL/JGFS_VMINMON + +exit + diff --git a/util/Minimization_Monitor/nwprod/gfs.v1.0.0/jobs/JGFS_VMINMON b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/jobs/JGFS_VMINMON index c951ab9d9..bdc78268c 100755 --- a/util/Minimization_Monitor/nwprod/gfs.v1.0.0/jobs/JGFS_VMINMON +++ b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/jobs/JGFS_VMINMON @@ -6,10 +6,6 @@ set -xa echo `date` $0 `date -u` begin export PS4='$SECONDS + ' -export RUN_ENVIR=${RUN_ENVIR:-nco} -export envir=${envir:-prod} -##export PERL5LIB="/usrx/local/pm5/lib64/perl5:/usrx/local/pm5/share/perl5" - ############################### # Specify NET and RUN name ############################## @@ -22,20 +18,10 @@ export RUN=${RUN:-gfs} ########################################################### export pid=$$ export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} - -export DATAROOT=${DATAROOT:-/tmpnwprod2} -export DATA=${DATA:-${DATAROOT}/${jobid}} - +export DATA=${DATA:-${DATAROOT}/${jobid:?}} mkdir -p $DATA cd $DATA -############################################################### -# This block can be modified for different test environment -############################################################### -#if [ $RUN_ENVIR = prod -a $envir != prod ]; then -# export SENDCOM=${SENDCOM:-NO} -#fi ########################################################### # obtain unique process id (pid) and make temp directories @@ -44,69 +30,57 @@ export MINMON_SUFFIX=${MINMON_SUFFIX:-GFS} export m_job=${m_job:-${MINMON_SUFFIX}_mmDE} -#################################### -# File To Log Msgs -#################################### -export jlogfile=${jlogfile:-${COMROOT}/logs/jlogfiles/jlogfile.${m_job}.${pid}} - - -################################################## -# SENDECF - Flag Events on ECF -# SENDCOM - Copy Files From TMPDIR to $COMOUT -# SENDDBN - Issue DBNet Client Calls -# VERBOSE - Specify Verbose Output -################################################## -export SENDCOM=${SENDCOM:-YES} -export SENDDBN=${SENDDBN:-NO} -export SENDECF=${SENDECF:-NO} -export VERBOSE=${VERBOSE:-YES} - - -################################### -# Set up the UTILITIES -################################### -export utilscript=${utilscript:-${UTILROOT}/ush} -export utilexec=${utilexec:-${UTILROOT}/exec} - - ############################################## # Specify Package Areas ############################################## -# JY export HOMEgfs=${HOMEgfs:-${NWROOT}/gfs.${gfs_ver}} -export HOMEgfs=${HOMEgfs:-${NWROOT}/gfs_minmon.${gfs_minmon_ver}} -export PARMgfs=${PARMgfs:-$HOMEgfs/parm} +export HOMEgfs=${HOMEgfs:-${NWROOT}/gfs.${gfs_ver}} +#export PARMmon=${PARMmon:-$HOMEgfs/parm/mon} export SCRgfs=${SCRgfs:-$HOMEgfs/scripts} -export FIXgfs=${FIXgfs:-$HOMEgfs/fix} +export M_FIXgfs=${M_FIXgfs:-$HOMEgfs/fix/product} -export HOMEminmon=${HOMEminmon:-${NWROOT}/minmon_shared.${minmon_shared_ver}} +export HOMEminmon=${HOMEminmon:-${HOMEgfs}} export EXECminmon=${EXECminmon:-$HOMEminmon/exec} export USHminmon=${USHminmon:-$HOMEminmon/ush} -export FIXminmon=${FIXminmon:-${HOMEminmon/fix}} ################################### # source the parm file ################################### -. ${PARMgfs}/gfs_minmon.parm +#. ${PARMmon}/da_mon.parm ############################################# # Run setpdy and initialize PDY variables ############################################# -export cycle=t${cyc}z -setpdy.sh -. ./PDY +if [[ $MY_MACHINE != "hera" ]]; then + export cycle=t${cyc}z + setpdy.sh + . ./PDY +fi + +############################################# +# determine PDY and cyc for previous cycle +############################################# + +cdate=`${NDATE} -6 ${PDY}${cyc}` +echo 'pdate = ${pdate}' + +export P_PDY=`echo ${cdate} | cut -c1-8` +export p_cyc=`echo ${cdate} | cut -c9-10` ############################################# # TANKverf - WHERE OUTPUT DATA WILL RESIDE ############################################# -M_TANKverf=${M_TANKverf:-${COMROOT}/verf/${envir}} -M_TANKverfM0=${M_TANKverfM0:-${M_TANKverf}/minmon_${MINMON_SUFFIX}.${PDY}} -export M_TANKverfM1=${M_TANKverfM1:-${M_TANKverf}/minmon_${MINMON_SUFFIX}.${PDYm1}} -export M_TANKverf=$M_TANKverfM0 +TANK_USE_RUN=${TANK_USE_RUN:-1} export COM_IN=${COM_IN:-${COMROOT}/${NET}/${envir}} -export COMIN=${COMIN:-$COM_IN/${RUN}.${PDY}} + +M_TANKverf=${M_TANKverf:-${COM_IN}} +M_TANKverfM0=${M_TANKverfM0:-${M_TANKverf}/${RUN}.${PDY}/${cyc}/minmon} +export M_TANKverfM1=${M_TANKverfM1:-${M_TANKverf}/${RUN}.${P_PDY}/${p_cyc}/minmon} +export M_TANKverf=$M_TANKverfM0 + +export COMIN=${COMIN:-$COM_IN/${RUN}.${PDY}/${cyc}} mkdir -p -m 775 $M_TANKverf @@ -117,23 +91,13 @@ mkdir -p -m 775 $M_TANKverf export CYCLE_INTERVAL=6 export gsistat=${gsistat:-${COMIN}/gfs.t${cyc}z.gsistat} -msg="JOB HAS STARTED" -postmsg "$jlogfile" "$msg" ######################################################## # Execute the script. ${GMONSH:-$SCRgfs/exgfs_vrfminmon.sh.ecf} ${PDY} ${cyc} - err=$? +[[ $err -ne 0 ]] && exit $err -######################################################## - -if [[ ${err} -ne 0 ]]; then - msg="WARNING: JOB DID NOT COMPLETE NORMALLY, error code $err" -else - msg="JOB COMPLETED NORMALLY" -fi -postmsg "$jlogfile" "$msg" ################################ # Remove the Working Directory diff --git a/util/Minimization_Monitor/nwprod/gfs.v1.0.0/scripts/exgfs_vrfminmon.sh.ecf b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/scripts/exgfs_vrfminmon.sh.ecf index 16dfe998c..1a182f9fc 100755 --- a/util/Minimization_Monitor/nwprod/gfs.v1.0.0/scripts/exgfs_vrfminmon.sh.ecf +++ b/util/Minimization_Monitor/nwprod/gfs.v1.0.0/scripts/exgfs_vrfminmon.sh.ecf @@ -10,47 +10,6 @@ # Abstract: This script runs the data extract/validation portion of the # MinMon package. # -# Script history log: -# 2015-04-10 Ed Safford -# -# Input script positional parameters: -# 1 Current analysis date in yyyymmddhh format -# defaults to PDY; required -# 2 cycle time in cc format -# defaults to cyc; required -# -# Imported Shell Variables: -# M_TANKverf repository for minmon data files -# DATA data working space -# MINMON_SUFFIX data set identifier, defaults to GFS -# FIXgfs fixed file directory, gfs specific -# FIXminmon fixed file directory -# USHminmon scripts directory -# PDY processing day; -# overridden by 1 -# cyc processing cycle; -# overridden by 2 -# -# Exported Shell Variables: -# PDATE Processing date -# err last return code -# VERBOSE switches on more/less log output -# mm_gnormfile $GFSfix/gfs_minmon_gnorm.txt file -# mm_costfile $GFSfix/gfs_minmon_cost.txt file -# -# Modules and files referenced: -# scripts : ${USHminmon}/minmon_xtrct_gnorms.pl -# ${USHminmon}/minmon_xtrct_costs.pl -# ${USHminmon}/minmon_xtrct_reduction.pl -# -# programs : $NDATE -# -# input data : $gsistat=${COMIN}/gfs1.t${cyc}z.gsistat -# -# output data: -# -# Remarks: -# # Condition codes # 0 - no problem encountered # >0 - some problem encountered @@ -69,9 +28,6 @@ fi export scr=exgfs_vrfyminmon.sh.ecf -msg="${scr} HAS STARTED" -postmsg "$jlogfile" "$msg" - export RUN_ENVIR=${RUN_ENVIR:-nco} export NET=${NET:-gfs} export RUN=${RUN:-gfs} @@ -88,15 +44,13 @@ export cyc=${2:-${cyc:?}} ######################################## export DATA=${DATA:-$(pwd)} -#export HOMEgfs=${HOMEgfs:-/${NWROOT}/gfs_minmon.v${gfs_minmon_ver}} - ######################################## # Filenames ######################################## gsistat=${gsistat:-$COMIN/gfs.t${cyc}z.gsistat} -export mm_gnormfile=${gnormfile:-${FIXgfs}/gfs_minmon_gnorm.txt} -export mm_costfile=${costfile:-${FIXgfs}/gfs_minmon_cost.txt} +export mm_gnormfile=${gnormfile:-${M_FIXgfs}/gfs_minmon_gnorm.txt} +export mm_costfile=${costfile:-${M_FIXgfs}/gfs_minmon_cost.txt} ######################################## # Other variables @@ -107,12 +61,7 @@ export NCP=${NCP:-/bin/cp} export NDATE=${NDATE:-/nwprod/util/exec/ndate} export pgm=exgfs_vrfminmon.sh.ecf -######################################################### -# M_TANKverf is storage location for generated files -######################################################### -export M_TANKverf=${M_TANKverf:-${COMROOT}/${NET}/${envir}/minmon.${PDY}} -export M_TANKverfM1=${M_TANKverfM1:-${COMROOT}/${NET}/${envir}/minmmon.${PDYm1}} -##################################################################### + if [[ ! -d ${DATA} ]]; then mkdir $DATA @@ -131,28 +80,25 @@ if [[ -s ${gsistat} ]]; then # Copy the $MINMON_SUFFIX.gnorm_data.txt file to the working directory # It's ok if it doesn't exist; we'll create a new one if needed. #------------------------------------------------------------------ - if [[ -s ${M_TANKverf}/${MINMON_SUFFIX}.gnorm_data.txt ]]; then - $NCP ${M_TANKverf}/${MINMON_SUFFIX}.gnorm_data.txt gnorm_data.txt - elif [[ -s ${M_TANKverf}/gnorm_data.txt ]]; then - $NCP ${M_TANKverf}/gnorm_data.txt gnorm_data.txt - elif [[ -s ${M_TANKverfM1}/${MINMON_SUFFIX}.gnorm_data.txt ]]; then - $NCP ${M_TANKverfM1}/${MINMON_SUFFIX}.gnorm_data.txt gnorm_data.txt + if [[ -s ${M_TANKverf}/gnorm_data.txt ]]; then + $NCP ${M_TANKverf}/gnorm_data.txt gnorm_data.txt elif [[ -s ${M_TANKverfM1}/gnorm_data.txt ]]; then $NCP ${M_TANKverfM1}/gnorm_data.txt gnorm_data.txt fi + #------------------------------------------------------------------ # Run the child sccripts. #------------------------------------------------------------------ - ${USHminmon}/minmon_xtrct_costs.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} ${jlogfile} + ${USHminmon}/minmon_xtrct_costs.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} dummy rc_costs=$? echo "rc_costs = $rc_costs" - ${USHminmon}/minmon_xtrct_gnorms.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} ${jlogfile} + ${USHminmon}/minmon_xtrct_gnorms.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} dummy rc_gnorms=$? echo "rc_gnorms = $rc_gnorms" - ${USHminmon}/minmon_xtrct_reduct.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} ${jlogfile} + ${USHminmon}/minmon_xtrct_reduct.pl ${MINMON_SUFFIX} ${PDY} ${cyc} ${gsistat} dummy rc_reduct=$? echo "rc_reduct = $rc_reduct" @@ -176,8 +122,6 @@ if [[ "$VERBOSE" = "YES" ]]; then echo "end exgfs_vrfminmon.sh.ecf, exit value = ${err}" fi -msg="${scr} HAS ENDED" -postmsg "$jlogfile" "$msg" set +x exit ${err} diff --git a/util/Minimization_Monitor/nwprod/minmon_shared.v1.0.1/ush/minmon_xtrct_gnorms.pl b/util/Minimization_Monitor/nwprod/minmon_shared.v1.0.1/ush/minmon_xtrct_gnorms.pl index caab22509..b921fb7fa 100755 --- a/util/Minimization_Monitor/nwprod/minmon_shared.v1.0.1/ush/minmon_xtrct_gnorms.pl +++ b/util/Minimization_Monitor/nwprod/minmon_shared.v1.0.1/ush/minmon_xtrct_gnorms.pl @@ -175,7 +175,7 @@ sub updateGnormData { } if( length $mail_msg > 0 ){ - my $mail_link = "http://www.emc.ncep.noaa.gov/gmb/gdas/radiance/esafford/gsi_stat/index.html?src=$suffix&typ=gnorm&cyc=$cycle"; + my $mail_link = "http://www.emc.ncep.noaa.gov/gmb/gdas/gsi_stat/index.html?src=$suffix&typ=gnorm&cyc=$cycle"; open( OUTFILE, ">$out_file" ) or die "Can't open ${$out_file}: $!\n"; print OUTFILE $mail_msg; print OUTFILE "\n\n $mail_link"; @@ -224,17 +224,13 @@ sub updateGnormData { my $igrad_target; my $igrad_number; -my $gnorm_target; -my $gnorm_number; my $expected_gnorms; my $gross_check_val; my $rc = 0; my $cdate = sprintf '%s%s', $pdy, $cyc; -#my $FIXminmon = $ENV{"FIXminmon"}; my $gnormfile = $ENV{"mm_gnormfile"}; -#my $gnormfile = sprintf '%s', "./minmon_gnorm.txt"; if( (-e $gnormfile) ) { @@ -291,7 +287,6 @@ sub updateGnormData { # current outer & inner iteration number ############################################## if( $reset_iter_flag == 1 ) { -# if( $line =~ /${gnorm_target}/ ){ if( $line =~ /${igrad_target}/ ) { my @iterline = split( / +/, $line ); my $iter_str = $iterline[2] . "," . $iterline[3]; @@ -346,9 +341,9 @@ sub updateGnormData { my @lines = reverse ; foreach $line (@lines) { - if( $line =~ /${gnorm_target}/ ){ + if( $line =~ /${igrad_target}/ ){ my @iterline = split( / +/, $line ); - $stop_iter = $iterline[9] . "," . $iterline[10]; + $stop_iter = $iterline[2] . "," . $iterline[3]; last; } } diff --git a/util/Minimization_Monitor/parm/MinMon.ver b/util/Minimization_Monitor/parm/MinMon.ver index d235533ce..9de5a047c 100644 --- a/util/Minimization_Monitor/parm/MinMon.ver +++ b/util/Minimization_Monitor/parm/MinMon.ver @@ -1,4 +1,15 @@ -export gdas_minmon_ver=v1.0.0 -export gfs_minmon_ver=v1.0.0 -export nam_minmon_ver=v1.0.0 -export minmon_shared_ver=v1.0.1 +#!/bin/sh + +if [[ $MINMON_VER -ne 1 ]]; then + + export MINMON_VER=1 + + export gdas_minmon_ver=v1.0.0 + export gfs_minmon_ver=v1.0.0 + export nam_minmon_ver=v1.0.0 + export minmon_shared_ver=v1.0.1 + +else + echo "MinMon.ver is already loaded" +fi + diff --git a/util/Minimization_Monitor/parm/MinMon_config b/util/Minimization_Monitor/parm/MinMon_config index 13a1757f8..1825e13e8 100644 --- a/util/Minimization_Monitor/parm/MinMon_config +++ b/util/Minimization_Monitor/parm/MinMon_config @@ -3,103 +3,142 @@ ################################################################### # Note: MinMon/parm/MinMon.ver file must be sourced before this file ################################################################### -export MY_MACHINE=cray -export MY_MINMON=${MY_MINMON:-/gpfs/hps3/emc/da/noscrub/Edward.Safford/ProdGSI_MinMon/util/Minimization_Monitor} +if [[ $MINMON_CONFIG -ne 1 ]]; then -export HOMEgdas=${MY_MINMON}/nwprod/gdas.${gdas_minmon_ver} -export HOMEgfs=${MY_MINMON}/nwprod/gfs.${gfs_minmon_ver} -export HOMEnam=${MY_MINMON}/nwprod/nam_minmon.${nam_minmon_ver} -export HOMEminmon=${MY_MINMON}/nwprod/minmon_shared.${minmon_shared_ver} + export MINMON_CONFIG=1 -export MINMON_DE=${MINMON_DE:-${MY_MINMON}/data_xtrct} -export M_DE_SCRIPTS=${M_DE_SCRIPTS:-${MINMON_DE}/ush} + export MY_MACHINE=hera -export MINMON_IG=${MINMON_IG:-${MY_MINMON}/image_gen} -export M_IG_SCRIPTS=${M_IG_SCRIPTS:-${MINMON_IG}/ush} -export M_IG_GRDS=${M_IG_GRDS:-${MINMON_IG}/grds} -export M_IG_PARM=${M_IG_PARM:-${MINMON_IG}/parm} + export MY_MINMON=${MY_MINMON:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/ProdGSI/util/Minimization_Monitor} -export MY_STMP=${MY_STMP:-/gpfs/hps2/stmp} -export MY_PTMP=${MY_PTMP:-/gpfs/hps2/ptmp} -export envir=${RUN_ENVIR:-prod} + export HOMEgdas=${MY_MINMON}/nwprod/gdas.${gdas_minmon_ver} + export HOMEgfs=${MY_MINMON}/nwprod/gfs.${gfs_minmon_ver} -# -# working directory -# -export DATA_IN=${DATA_IN:-${MY_STMP}/${LOGNAME}/${MINMON_SUFFIX}/minmon} -export LOGdir=${LOGdir:-${MY_PTMP}/${LOGNAME}/logs/${MINMON_SUFFIX}/minmon} + export M_FIXgdas=${M_FIXgdas:-${HOMEgdas}/fix} + export M_FIXgfs=${M_FIXgfs:-${HOMEgfs}/fix} -export MY_TANKDIR=${MY_TANKDIR:-/u/Edward.Safford/nbns} -export M_TANKverf=${M_TANKverf:-${MY_TANKDIR}} + export HOMEnam=${MY_MINMON}/nwprod/nam_minmon.${nam_minmon_ver} + export HOMEminmon=${MY_MINMON}/nwprod/minmon_shared.${minmon_shared_ver} -export WEBUSER=${WEBUSER:-esafford} -export WEBSERVER=${WEBSERVER:-emcrzdm} -export WEBDIR=${WEBDIR:-/home/people/emc/www/htdocs/gmb/gdas/radiance/esafford/gsi_stat/pngs} + export MINMON_DE=${MINMON_DE:-${MY_MINMON}/data_xtrct} + export M_DE_SCRIPTS=${M_DE_SCRIPTS:-${MINMON_DE}/ush} + export MINMON_IG=${MINMON_IG:-${MY_MINMON}/image_gen} + export M_IG_SCRIPTS=${M_IG_SCRIPTS:-${MINMON_IG}/ush} + export M_IG_GRDS=${M_IG_GRDS:-${MINMON_IG}/grds} + export M_IG_PARM=${M_IG_PARM:-${MINMON_IG}/parm} -# -# Utilities used by the MinMon package -# -export NCP=${NCP:-"/bin/cp -f"} -export Z=${Z:-"gz"} + export MY_STMP=${MY_STMP:-/scratch2/NCEPDEV/stmp3/Edward.Safford} + export MY_PTMP=${MY_PTMP:-/scratch2/NCEPDEV/stmp3/Edward.Safford} -if [[ $MY_MACHINE = "wcoss" ]]; then - shell=sh - . /usrx/local/Modules/default/init/${shell} - module load lsf + export envir=${RUN_ENVIR:-prod} - export SUB="bsub" - export NWPROD=/nwprod - export COMPRESS=/usrx/local/bin/pigz - export UNCOMPRESS="/usrx/local/bin/unpigz -f" - export RSYNC=/usr/bin/rsync - export PERL5LIB="/usrx/local/pm5/lib64/perl5:/usrx/local/pm5/share/perl5" - -elif [[ $MY_MACHINE = "cray" ]]; then - - sys=`hostname` - sys1=`echo $sys | cut -c1` - echo $sys1 - - # - # module pm5 needs to have SITE set in order to load - # Why? Not at all clear, but it sure does fail w/o SITE set. # - if [[ $sys1 == "s" ]]; then - export SITE=SURGE - else - export SITE=LUNA - fi - - . /opt/modules/3.2.6.7/init/sh + # working directory + # + export DATA_IN=${DATA_IN:-${MY_STMP}/${MINMON_SUFFIX}/${RUN}/minmon} + export LOGdir=${LOGdir:-${MY_PTMP}/logs/${MINMON_SUFFIX}/${RUN}/minmon} - module use /opt/modulefiles - module load xt-lsfhpc + export MY_TANKDIR=${MY_TANKDIR:-/scratch1/NCEPDEV/da/Edward.Safford/nbns} + export M_TANKverf=${M_TANKverf:-${MY_TANKDIR}} - module use /gpfs/hps/nco/ops/nwprod/modulefiles - module load prod_util # defines $NDATE among other things - module load prod_envir + export WEBUSER=${WEBUSER:-esafford} + export WEBSERVER=${WEBSERVER:-emcrzdm} + export WEBDIR=${WEBDIR:-/home/people/emc/www/htdocs/gmb/gdas/radiance/esafford/gsi_stat/pngs} - module use /usrx/local/prod/modulefiles - module load pm5 - export SUB="bsub" - export NWPROD=${COMROOTp1} - export COMPRESS=gzip - export UNCOMPRESS="gunzip -f" - export RSYNC=/usr/bin/rsync + # + # Utilities used by the MinMon package + # + export NCP=${NCP:-"/bin/cp -f"} + export Z=${Z:-"gz"} + + if [[ $MY_MACHINE = "wcoss" ]]; then + shell=sh + . /usrx/local/Modules/default/init/${shell} + module load lsf + module load GrADS/2.0.2 + + export SUB="bsub" + export NWPROD=/nwprod + export COMPRESS=/usrx/local/bin/pigz + export UNCOMPRESS="/usrx/local/bin/unpigz -f" + export RSYNC=/usr/bin/rsync + export PERL5LIB="/usrx/local/pm5/lib64/perl5:/usrx/local/pm5/share/perl5" + + + elif [[ $MY_MACHINE = "wcoss_d" ]]; then + shell=sh + source /usrx/local/prod/lmod/lmod/init/${shell} + + MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core:/usrx/local/prod/modulefiles/core_third:/usrx/local/prod/modulefiles/defs:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod:/usrx/local/dev/modulefiles + + module purge + module load ips/18.0.1.163 + module load metplus/2.1 + module load lsf/10.1 + module load prod_util/1.1.2 + module load pm5/1.0 + module load GrADS/2.2.0 + + export SUB=`which bsub` + export COMPRESS=gzip + export UNCOMPRESS="gunzip -f" + export RSYNC=/usr/bin/rsync + + + elif [[ $MY_MACHINE = "cray" ]]; then + + sys=`hostname` + sys1=`echo $sys | cut -c1` + echo $sys1 + + # + # module pm5 needs to have SITE set in order to load + # Why? Not at all clear, but it sure does fail w/o SITE set. + # + if [[ $sys1 == "s" ]]; then + export SITE=SURGE + else + export SITE=LUNA + fi + + . /opt/modules/3.2.6.7/init/sh + + module use /opt/modulefiles + module load xt-lsfhpc + + module use /gpfs/hps/nco/ops/nwprod/modulefiles + module load prod_util # defines $NDATE among other things + module load prod_envir + + module use /usrx/local/prod/modulefiles + module load pm5 + + export SUB="bsub" + export COMPRESS=gzip + export UNCOMPRESS="gunzip -f" + export RSYNC=/usr/bin/rsync + + elif [[ $MY_MACHINE = "hera" ]]; then + shell=sh + . $MODULESHOME/init/$shell + module load grads/2.0.2 + + export GRADS=`which grads` + export STNMAP=`which stnmap` + + export SUB=/apps/slurm/default/bin/sbatch + export NWPROD=/home/Edward.Safford/bin + export NDATE=${NWPROD}/ndate + export COMPRESS=gzip + export UNCOMPRESS="gunzip -f" + fi -elif [[ $MY_MACHINE = "theia" ]]; then - shell=sh - /usr/bin/modulecmd $shell load ncep + export NDATE=${NDATE:-${NWPROD}/util/exec/ndate} - export SUB=/apps/torque/default/bin/qsub - export NWPROD=/scratch1/portfolios/NCEPDEV/da/save/Michael.Lueken/nwprod - export NDATE=${NWPROD}/util/exec/ndate - export COMPRESS=gzip - export UNCOMPRESS="gunzip -f" +else + echo "MinMon_config already loaded" fi - -export NDATE=${NDATE:-${NWPROD}/util/exec/ndate} diff --git a/util/Minimization_Monitor/parm/MinMon_user_settings b/util/Minimization_Monitor/parm/MinMon_user_settings index 47dc6fd20..40357a3fa 100644 --- a/util/Minimization_Monitor/parm/MinMon_user_settings +++ b/util/Minimization_Monitor/parm/MinMon_user_settings @@ -5,74 +5,88 @@ # # Modify this file in order to change behavior of the GMon package #------------------------------------------------------------------------------ -# -# ACCOUNT is used on zeus only for use with the qsub -a flag. It is -# empty on other platforms. -# -export ACCOUNT=${ACCOUNT:-} -# -# PROJECT is used on wcoss only with the bjob -P flag. It is -# empty on other platforms. -# -export PROJECT=${PROJECT:-GDAS-T2O} +if [[ $MINMON_USER_SETTINGS -ne 1 ]]; then + + export MINMON_USER_SETTINGS=1 -# -# JOB_QUEUE is used on wcoss only with the bjob -q flag. It is -# empty on other platforms. -# -export JOB_QUEUE=${JOB_QUEUE:-dev} + # + # ACCOUNT is used on zeus only for use with the qsub -a flag. It is + # empty on other platforms. + # + export ACCOUNT=${ACCOUNT:-fv3-cpu} -# -# RUN_ONLY_ON_DEV 1 = dev machine only, 0 = run anywhere -# -export RUN_ONLY_ON_DEV=${RUN_ONLY_ON_DEV:-1} + # + # PROJECT is used on wcoss only with the bjob -P flag. It is + # empty on other platforms. + # + export PROJECT=${PROJECT:-} -# -# WORKDIR is working directory (tmp space) -# -export WORKDIR=${MY_STMP}/${LOGNAME}/${MINMON_SUFFIX}/minmon + # + # JOB_QUEUE is used on wcoss only with the bjob -q flag. It is + # empty on other platforms. + # + export JOB_QUEUE=${JOB_QUEUE:-dev_shared} -# -# GLB_AREA indicates the valid area of the data source -# 1 = area is global -# 0 = area is regional (not global) -# -export GLB_AREA=${GLB_AREA:-1} + # + # RUN_ONLY_ON_DEV 1 = dev machine only, 0 = run anywhere + # + export RUN_ONLY_ON_DEV=${RUN_ONLY_ON_DEV:-1} -# -# DO_ERROR_RPT 1 = mail any error reports to the MAIL_TO and MAIL_CC lists -# 0 = take no action on any error reports (they will be in the -# ${TANKverf}/${suffix}/minmon_[yyyymmdd]/ directory) -export DO_ERROR_RPT=${DO_ERROR_RPT:-0} + # + # WORKDIR is working directory (tmp space) + # + if [[ ${#RUN} -le 0 ]]; then + export WORKDIR=${MY_STMP}/${LOGNAME}/${MINMON_SUFFIX}/minmon + else + export WORKDIR=${MY_STMP}/${LOGNAME}/${MINMON_SUFFIX}/${RUN}/minmon + fi -# -# DO_ARCHIVE 1 = copy data to hpss and to prod machine at completion of each day -# 0 = no data archiving (data will remain in TANKDIR on this machine) -# -export DO_ARCHIVE=${DO_ARCHIVE:-0} + # + # GLB_AREA indicates the valid area of the data source + # 1 = area is global + # 0 = area is regional (not global) + # + export GLB_AREA=${GLB_AREA:-1} -# -# MAIL_TO is the mail recpient list for error reporting -# -export MAIL_TO=${MAIL_TO:-""} + # + # DO_ERROR_RPT 1 = mail any error reports to the MAIL_TO and MAIL_CC lists + # 0 = take no action on any error reports (they will be in the + # ${TANKverf}/${suffix}/minmon_[yyyymmdd]/ directory) + export DO_ERROR_RPT=${DO_ERROR_RPT:-0} -# -# MAIL_CC is the mail recpient cc list for error reporting -# -export MAIL_CC=${MAIL_CC:-""} + # + # DO_ARCHIVE 1 = copy data to hpss and to prod machine at completion of each day + # 0 = no data archiving (data will remain in TANKDIR on this machine) + # + export DO_ARCHIVE=${DO_ARCHIVE:-0} -# -# KEEPDATA is the control flag for preserving/deleting the working -# directory. YES = keep the WORKDIR directory and contents -# NO = delete the WORKDIR directory and contents -# -export KEEPDATA=YES + # + # MAIL_TO is the mail recpient list for error reporting + # + export MAIL_TO=${MAIL_TO:-""} + + # + # MAIL_CC is the mail recpient cc list for error reporting + # + export MAIL_CC=${MAIL_CC:-""} + + # + # KEEPDATA is the control flag for preserving/deleting the working + # directory. YES = keep the WORKDIR directory and contents + # NO = delete the WORKDIR directory and contents + # + export KEEPDATA=YES + + # + # If TANK_USE_RUN =1 then the TANKdir will resolve to : + # ${MY_TANKDIR}/${MINMON_SUFFIX}/$RUN.$PDY/minmon/[data_files] + # instead of: + # ${MY_TANKDIR}/${MINMON_SUFFIX}/minmon.$RUN.$PDY/[data_files] + # + export TANK_USE_RUN=1 + +else + echo "MinMon_user_config already loaded" +fi -# -# If TANK_USE_RUN =1 then the TANKdir will resolve to : -# ${MY_TANKDIR}/${MINMON_SUFFIX}/$RUN.$PDY/minmon/[data_files] -# instead of: -# ${MY_TANKDIR}/${MINMON_SUFFIX}/minmon.$RUN.$PDY/[data_files] -# -export TANK_USE_RUN=1 diff --git a/util/NMC_Bkerror/py-bkerror/bkerror.f90 b/util/NMC_Bkerror/py-bkerror/bkerror.f90 index 6e14ffcbb..b1daee587 100644 --- a/util/NMC_Bkerror/py-bkerror/bkerror.f90 +++ b/util/NMC_Bkerror/py-bkerror/bkerror.f90 @@ -126,6 +126,8 @@ subroutine put_bkerror(i_fname, i_nsig, i_nlat, i_nlon, i_var, & write(lunit) i_nsig, i_nlat, i_nlon write(lunit) i_agvin, i_bgvin, i_wgvin + var=' ' + do i=1,6 call arr2str(i_var(i,:), var, 3) write(6,*) i, var, i_nsig diff --git a/util/NMC_Bkerror/py-bkerror/interp_bkerror.py b/util/NMC_Bkerror/py-bkerror/interp_bkerror.py index 07cd50a08..f5711e882 100755 --- a/util/NMC_Bkerror/py-bkerror/interp_bkerror.py +++ b/util/NMC_Bkerror/py-bkerror/interp_bkerror.py @@ -149,11 +149,11 @@ def print_summary(self): tmp_n = f(slon_n,slat_n) gsi_n.hsstin = np.array(tmp_n,dtype=np.float32) -f = interp1d(slat,gsi.corpin,kind=interp_kind) +f = interp1d(slat.astype(np.float),gsi.corpin.astype(np.float),kind=interp_kind,fill_value="extrapolate") tmp_n = f(slat_n) gsi_n.corpin = np.array(tmp_n,dtype=np.float32) -f = interp1d(slat,gsi.hscalespin,kind=interp_kind) +f = interp1d(slat.astype(np.float),gsi.hscalespin.astype(np.float),kind=interp_kind,fill_value="extrapolate") tmp_n = f(slat_n) gsi_n.hscalespin = np.array(tmp_n,dtype=np.float32) diff --git a/util/NMC_Bkerror/scripts/get_aernmcstats_C384_theia.sh b/util/NMC_Bkerror/scripts/get_aernmcstats_C384_theia.sh new file mode 100644 index 000000000..6f22e5fe0 --- /dev/null +++ b/util/NMC_Bkerror/scripts/get_aernmcstats_C384_theia.sh @@ -0,0 +1,125 @@ +#!/bin/bash +#SBATCH -A da-cpu +#SBATCH -J FV3AeroNMCStats +#SBATCH -q batch +#SBATCH -o SLURM_%x.o%j +#SBATCH -e SLURM_%x.e%j +#SBATCH --export=ALL +#SBATCH --time=02:00:00 +#SBATCH --nodes=8 +#SBATCH --tasks-per-node=1 + +set -x +export NTHREADS=2 + +export exp="test_FV3AeroNMCStats_386" +export base=/scratch4/NCEPDEV/da/save/Cory.R.Martin/GSI/ProdGSI/util/NMC_Bkerror/ +export calcstats=$base/sorc_aero/calcstats_aerosol.exe +export datadir=/scratch4/NCEPDEV/da/noscrub/Cory.R.Martin/FV3GFS-GSDChem/ +export season='test' +export resin='C384' +export tmpdir=/scratch3/NCEPDEV/stmp1/Cory.R.Martin/FV3GFS-GSDChem/tmp.$exp.$season +export outdir=/scratch3/NCEPDEV/stmp1/Cory.R.Martin/FV3GFS-GSDChem/Berror.$exp.$season + +case $season in +# note, this is not complete yet + 'MAM') + export y4m2="201903 201904 201905" + ;; + 'JJA') + export y4m2="201903 201904 201905" + ;; + 'SON') + export y4m2="201903 201904 201905" + ;; + 'DJF') + export y4m2="201903 201904 201905" + ;; + 'Year') + export y4m2="201903 201904 201905" + ;; + 'test') + export y4m2="201904 201905" + ;; +esac + + +if [ -d $tmpdir ]; then + rm -rf $tmpdir +fi + +mkdir -p $tmpdir +cd $tmpdir + +cp $calcstats ./stats.x + +#jcap=766,jcapin=766,jcapsmooth=766,nsig=64,nlat=386,nlon=768,maxcases=200,hybrid=.true.,smoothdeg=0.5, +cat << EOF > stats.parm + &NAMSTAT + jcap=766,jcapin=766,jcapsmooth=766,nsig=64,nlat=768,nlon=1536,maxcases=200,hybrid=.true.,smoothdeg=0.5, + biasrm=.true.,vertavg=.true.,use_nemsio=.true.,modelname='fv3' + / +EOF + +for hh in 024 048; do + for ymflag in $y4m2; do + ls $datadir/$resin/$ymflag*.gfs.t*z.atmf"$hh".nemsio >> infiles + #ls $datadir/gfs.$ymflag*/$resin/*.gfs.t*z.atmf"$hh".nemsio >> infiles + done +done + +ln -sf infiles fort.10 + +### load modules +source /apps/lmod/7.7.18/init/sh +# system installed +module load intel +module load impi +module load netcdf +module load grads +module load rocoto/1.3.0-RC3 +# /contrib modules +module use -a /contrib/modulefiles +module load anaconda/anaconda2 +# /contrib/da modules +module use -a /contrib/da/modulefiles +module load boost +module load eigen +# my modules +module use -a /scratch4/NCEPDEV/da/save/Cory.R.Martin/modulefiles +# NCEPLIBS +module use -a /scratch3/NCEPDEV/nwprod/lib/modulefiles +module load nemsio +module load bacio +module load w3nco +module load crtm/v2.2.3 +module load sp + +export MPI_BUFS_PER_PROC=2048 +export MPI_BUFS_PER_HOST=2048 +export MPI_GROUP_MAX=256 +export MPI_MEMMAP_OFF=1 +export MP_STDOUTMODE=ORDERED +export OMP_NUM_THREADS=$NTHREADS +export KMP_STACKSIZE=512MB #2048000 +export KMP_AFFINITY=scatter +export APRUN="srun" +ulimit -s unlimited + +$APRUN ./stats.x < stats.parm + +if [ -s gsir4.berror_stats.gcv ] && [ -s bgstats_sp.grd ]; then + echo "Generate NMC statistic error successfully" + if [ ! -d $outdir ]; then + mkdir $outdir + else + rm -rf $outdir + fi + mv gsir4.berror_stats.gcv $outdir/. + mv bgstats_sp.grd $outdir/. +# mv biascor.grd $outdir +else + echo "Failed to generate NMC statistic error" +fi + +exit diff --git a/util/NMC_Bkerror/scripts/get_aernmcstats_C96_theia.sh b/util/NMC_Bkerror/scripts/get_aernmcstats_C96_theia.sh new file mode 100644 index 000000000..55dfc4e8c --- /dev/null +++ b/util/NMC_Bkerror/scripts/get_aernmcstats_C96_theia.sh @@ -0,0 +1,126 @@ +#!/bin/bash +#SBATCH -A da-cpu +#SBATCH -J FV3AeroNMCStats +#SBATCH -q batch +#SBATCH -o SLURM_%x.o%j +#SBATCH -e SLURM_%x.e%j +#SBATCH --export=ALL +#SBATCH --time=02:00:00 +#SBATCH --nodes=8 +#SBATCH --tasks-per-node=4 + +set -x +export NTHREADS=2 + +export exp="jcap192_newtry_FV3AeroNMCStats_194" +export base=/scratch4/NCEPDEV/da/save/Cory.R.Martin/GSI/ProdGSI/util/NMC_Bkerror/ +export calcstats=$base/sorc_aero_me/calcstats_aerosol.exe +export datadir=/scratch4/NCEPDEV/da/noscrub/Cory.R.Martin/FV3GFS-GSDChem/ +export season='test' +export resin='C384' +export tmpdir=/scratch3/NCEPDEV/stmp1/Cory.R.Martin/FV3GFS-GSDChem/tmp.$exp.$season +export outdir=/scratch3/NCEPDEV/stmp1/Cory.R.Martin/FV3GFS-GSDChem/Berror.$exp.$season + +case $season in +# note, this is not complete yet + 'MAM') + export y4m2="201903 201904 201905" + ;; + 'JJA') + export y4m2="201903 201904 201905" + ;; + 'SON') + export y4m2="201903 201904 201905" + ;; + 'DJF') + export y4m2="201903 201904 201905" + ;; + 'Year') + export y4m2="201903 201904 201905" + ;; + 'test') + export y4m2="201904 201905 201906 201907" + ;; +esac + + +if [ -d $tmpdir ]; then + rm -rf $tmpdir +fi + +mkdir -p $tmpdir +cd $tmpdir + +cp $calcstats ./stats.x + +#jcap=766,jcapin=766,jcapsmooth=766,nsig=64,nlat=386,nlon=768,maxcases=200,hybrid=.true.,smoothdeg=0.5, + #biasrm=.true.,vertavg=.true.,use_gfs_nemsio=.true.,aeromodel='fv3' +cat << EOF > stats.parm + &NAMSTAT + jcap=192,jcapin=768,jcapsmooth=192,nsig=64,nlat=194,nlon=384,maxcases=200,hybrid=.true.,smoothdeg=0.5, + biasrm=.true.,vertavg=.true.,use_gfs_nemsio=.true.,aeromodel='fv3' + / +EOF + +for hh in 024 048; do + for ymflag in $y4m2; do + ls $datadir/$resin/$ymflag*.gfs.t*z.atmf"$hh".nemsio >> infiles + #ls $datadir/gfs.$ymflag*/$resin/*.gfs.t*z.atmf"$hh".nemsio >> infiles + done +done + +ln -sf infiles fort.10 + +### load modules +source /apps/lmod/7.7.18/init/sh +# system installed +module load intel +module load impi +module load netcdf +# /contrib modules +module use -a /contrib/modulefiles +module load anaconda/anaconda2 +# /contrib/da modules +module use -a /contrib/da/modulefiles +module load boost +module load eigen +# my modules +module use -a /scratch4/NCEPDEV/da/save/Cory.R.Martin/modulefiles +# NCEPLIBS +module use -a /scratch3/NCEPDEV/nwprod/lib/modulefiles +module load nemsio +module load bacio +module load w3nco +module load sp + +export MPI_BUFS_PER_PROC=2048 +export MPI_BUFS_PER_HOST=2048 +export MPI_GROUP_MAX=256 +export MPI_MEMMAP_OFF=1 +export MP_STDOUTMODE=ORDERED +export OMP_NUM_THREADS=$NTHREADS +export KMP_STACKSIZE=512MB #2048000 +export KMP_AFFINITY=scatter +export APRUN="srun" +export I_MPI_ADJUST_GATHERV=3 +export PSM2_MQ_RECVREQS_MAX=4000000 + +ulimit -s unlimited + +$APRUN ./stats.x < stats.parm + +if [ -s gsir4.berror_stats.gcv ] && [ -s bgstats_sp.grd ]; then + echo "Generate NMC statistic error successfully" + if [ ! -d $outdir ]; then + mkdir $outdir + else + rm -rf $outdir + fi + mv gsir4.berror_stats.gcv $outdir/. + mv bgstats_sp.grd $outdir/. +# mv biascor.grd $outdir +else + echo "Failed to generate NMC statistic error" +fi + +exit diff --git a/util/NMC_Bkerror/scripts/get_aernmcstats_t126_s4 b/util/NMC_Bkerror/scripts/get_aernmcstats_t126_s4 new file mode 100644 index 000000000..c3e099063 --- /dev/null +++ b/util/NMC_Bkerror/scripts/get_aernmcstats_t126_s4 @@ -0,0 +1,119 @@ +#!/bin/csh -x + +#SBATCH --job-name=berror_stats +#SBATCH --partition=s4 +#SBATCH --time=04:00:00 +#SBATCH --exclusive +#SBATCH --account=star +#SBATCH --ntasks=10 +#SBATCH --cpus-per-task=2 +#SBATCH --export=ALL +#SBATCH --mem-per-cpu=3000 +#SBATCH --distribution=block:block +#SBATCH --output=./log/nmcbe.%j.out + +#set -x + +setenv NTHREADS 2 + +# exp: directory name to save output files +# base: path with scripts, source code and other directories +# calstats: executable +# datdir: save cases to generate the BE statistics +# tmpdir: work directory +# outdir: the path to save output files + + +set exp="test_kgkg" +set base="/data/users/swei/DA_Project/AODDA_genbe/NMC_Bkerror" +set calstats="/data/users/swei/DA_Project/AODDA_genbe/NMC_Bkerror/sorc_aero/calcstats_aerosol.dp.exe" + +set season="test" +switch ($season) + case "MAM": + set y4m2="201603 201604 201605" + breaksw + case "JJA": + set y4m2="201606 201607 201608" + breaksw + case "SON": + set y4m2="201609 201610 201611" + breaksw + case "DJF": + set y4m2="201612 201701 201702" + breaksw + case "Year": + set y4m2="201603 201604 201605 201606 201607 201608 201609 201610 201611 201612 201701 201702" + breaksw + case "test": + set y4m2="201509" +endsw + +set datdir="/data/users/swei/DA_Project/retro_test/ptmpd2/AODDA_gbbepx" +set tmpdir="/scratch/short/swei/$exp.$season" +set outdir="$base/scripts/output/$exp.$season" + +if ( -d $tmpdir ) then + rm -rf $tmpdir +endif + +mkdir -p $tmpdir +cd $tmpdir + +cp $calstats ./stats.x + +cat << EOF > stats.parm + &NAMSTAT + jcap=126,jcapin=126,jcapsmooth=126,nsig=64,nlat=192,nlon=384,maxcases=450,hybrid=.true.,smoothdeg=0.5, + biasrm=.true.,vertavg=.true.,use_nemsio=.true.,modelname='ngac' + / +EOF +# biasrm=.false.,vertavg=.false.,use_nemsio=.true. + +foreach hh ( 24 48 ) + foreach ymflag ( $y4m2 ) + ls $datdir/ngac.$ymflag*/ngac.t00z.sigf$hh >> infiles + end +end +#ls $datdir/sigf24.*.201507* >> infiles +#ls $datdir/sigf48.*.201507* >> infiles +#ls $datdir/sigf24.*.201606* >> infiles +#ls $datdir/sigf48.*.201606* >> infiles + +ln -s -f infiles fort.10 + +# Configure MPI environment for GSI +module load license_intel/S4 +module load intel/15.0-2 +module load impi/5.0.3.048 + +setenv MPI_BUFS_PER_PROC 2048 +setenv MPI_BUFS_PER_HOST 2048 +setenv MPI_GROUP_MAX 256 +setenv MPI_MEMMAP_OFF 1 +setenv MP_STDOUTMODE ORDERED +setenv OMP_NUM_THREADS $NTHREADS +setenv KMP_STACKSIZE 512MB #2048000 +setenv KMP_AFFINITY scatter +setenv APRUN "srun" + +${APRUN} ./stats.x < stats.parm #> gsistats.out +#@ rc = $status + +#rm $tmpdir/fort.[0-9]* + +if ( -s gsir4.berror_stats.gcv && -s bgstats_sp.grd ) then + echo "Generate NMC statistic error successfully" + if ( ! -d $outdir ) then + mkdir $outdir + else + rm -rf $outdir + endif + mv gsir4.berror_stats.gcv $outdir + mv bgstats_sp.grd $outdir +# mv biascor.grd $outdir +else + echo "Failed to generate NMC statistic error" +endif + +exit diff --git a/util/NMC_Bkerror/scripts/run_theia_slurm.sh b/util/NMC_Bkerror/scripts/run_theia_slurm.sh new file mode 100644 index 000000000..4045f9509 --- /dev/null +++ b/util/NMC_Bkerror/scripts/run_theia_slurm.sh @@ -0,0 +1,71 @@ +#!/bin/ksh --login +#SBATCH -J bkgnmc_test +#SBATCH -t 6:00:00 +#SBATCH --nodes=20 --ntasks-per-node=4 +#SBATCH -q batch +#SBATCH -A da-cpu +#SBATCH -o test.out_slurm + +set -x + +exp=nmc_master_t254 +base=/scratch4/NCEPDEV/da/save/$LOGNAME + +calstats=$base/gsi/ProdGSI/util/NMC_Bkerror/sorc/calcstats.exe +sststats=$base/gsi/fix/sst2dvar_stat0.5.ufs + +datdir=/scratch4/NCEPDEV/stmp4/Daryl.Kleist/bkerrdat_every3rd + +set -x + +tmpdir=/scratch3/NCEPDEV/stmp1/$LOGNAME/nmc/$exp +rm -rf $tmpdir +mkdir -p $tmpdir +cd $tmpdir + +export MPI_BUFS_PER_PROC=256 +export MPI_BUFS_PER_HOST=256 +export MPI_GROUP_MAX=256 +export OMP_NUM_THREADS=1 +export OMP_STACKSIZE=1024M +export I_MPI_ADJUST_GATHERV=3 +export PSM2_MQ_RECVREQS_MAX=4000000 + +module load intel +module load impi + +cp $calstats ./stats.x +cp $sststats ./berror_sst + +cat << EOF > stats.parm + &NAMSTAT + jcap=254,jcapin=574,jcapsmooth=254,nsig=64,nlat=258,nlon=512,maxcases=100,hybrid=.true.,smoothdeg=0.5, + biasrm=.true.,vertavg=.true.,use_gfs_nemsio=.false., + / +EOF + +ls $datdir/sigf24.gfs.* >> infiles +ls $datdir/sigf48.gfs.* >> infiles + + +set -x +ln -s -f infiles fort.10 + +echo "I AM IN " $PWD + +eval "srun $tmpdir/stats.x < stats.parm > nmcstats.out" + +rc=$? + +rm $tmpdir/fort.1* +rm $tmpdir/fort.2* +rm $tmpdir/fort.3* +rm $tmpdir/fort.4* +rm $tmpdir/fort.5* +rm $tmpdir/fort.6* +rm $tmpdir/fort.7* +rm $tmpdir/fort.8* +rm $tmpdir/fort.9* +rm $tmpdir/fort.0* + +exit diff --git a/util/NMC_Bkerror/scripts/run_theia_slurm_enkf.sh b/util/NMC_Bkerror/scripts/run_theia_slurm_enkf.sh new file mode 100644 index 000000000..a31746381 --- /dev/null +++ b/util/NMC_Bkerror/scripts/run_theia_slurm_enkf.sh @@ -0,0 +1,88 @@ +#!/bin/ksh --login +#SBATCH -J bkgnmc_test +#SBATCH -t 0:30:00 +#SBATCH --nodes=20 --ntasks-per-node=4 +#SBATCH -q debug +#SBATCH -A gsienkf +#SBATCH -o test.out_slurm + +set -x + +exp=C192_enkf_ens +base=/scratch3/BMC/gsienkf/whitaker/sfgens + +calstats=$base/calcstats.exe +sststats=/scratch4/NCEPDEV/da/save/Catherine.Thomas/gsi/fix/sst2dvar_stat0.5.ufs + +datdir=$base + +set -x + +tmpdir=/scratch3/NCEPDEV/stmp1/$LOGNAME/nmc/$exp +rm -rf $tmpdir +mkdir -p $tmpdir +cd $tmpdir + +export MPI_BUFS_PER_PROC=256 +export MPI_BUFS_PER_HOST=256 +export MPI_GROUP_MAX=256 +export OMP_NUM_THREADS=1 +export OMP_STACKSIZE=1024M +export I_MPI_ADJUST_GATHERV=3 +export PSM2_MQ_RECVREQS_MAX=4000000 + +module load intel +module load impi + +cp $calstats ./stats.x +cp $sststats ./berror_sst + +date1='2016010200' +date2='2016010300' +date=$date1 +/bin/rm -f infiles +touch infiles +# ens member files go first +while [ $date -le $date2 ]; do + ls $datdir/sfg*${date}*mem* >> infiles + date=`incdate $date 24` +done +# then corresponding ens mean files +date=$date1 +while [ $date -le $date2 ]; do + for filename in $datdir/sfg*${date}*mem*; do + echo "$datdir/sfg_${date}_fhr06_ensmean" >> infiles + done + date=`incdate $date 24` +done + +maxcases=`wc -l infiles | cut -f1 -d " "` + +cat << EOF > stats.parm + &NAMSTAT + jcap=382,jcapin=382,jcapsmooth=382,nsig=64,nlat=386,nlon=768,maxcases=${maxcases},hybrid=.true.,smoothdeg=0.5, + biasrm=.true.,vertavg=.true.,use_gfs_nemsio=.true.,use_enkf=.true. + / +EOF + +set -x +ln -s -f infiles fort.10 + +echo "I AM IN " $PWD + +eval "srun $tmpdir/stats.x < stats.parm > nmcstats.out" + +rc=$? + +rm $tmpdir/fort.1* +rm $tmpdir/fort.2* +rm $tmpdir/fort.3* +rm $tmpdir/fort.4* +rm $tmpdir/fort.5* +rm $tmpdir/fort.6* +rm $tmpdir/fort.7* +rm $tmpdir/fort.8* +rm $tmpdir/fort.9* +rm $tmpdir/fort.0* + +exit diff --git a/util/NMC_Bkerror/sorc/Makefile.conf.cray b/util/NMC_Bkerror/sorc/Makefile.conf.cray new file mode 100755 index 000000000..8f6b5f6a4 --- /dev/null +++ b/util/NMC_Bkerror/sorc/Makefile.conf.cray @@ -0,0 +1,57 @@ +# ---------------------------- +# Fortran compiler and options +# ---------------------------- + + CF = ftn + +#--- Normal mode options + + FFLAGS_F90 = -free -D_LAPACK_ + #FFLAGS_COM_N = -I ./ -I $(SIGIO_INC4) -I $(W3EMC_INCd) -I $(NEMSIO_INC) -O3 -fp-model strict -convert big_endian -g -debug all -check all,noarg_temp_created -traceback + FFLAGS_COM_N = -I ./ -I $(SIGIO_INC4) -I $(W3EMC_INCd) -I $(NEMSIO_INC) -O3 -fp-model strict -convert big_endian -g -traceback -heap-arrays 1024 + FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) + + +#--- Debug mode options + + FFLAGS_COM_D = -I ./ -I $(SIGIO_INC4) -I $(W3EMC_INCd) -I $(NEMSIO_INC) -O0 -fp-model strict -convert big_endian -g -traceback -warn + + FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) + + + +# ---------------------- +# C Compiler and options +# ---------------------- + + CC = cc + +#--- Normal mode options + + CFLAGS_N = -I ./ -O3 + +#--- Debug mode options + + CFLAGS_D = -I ./ -g + + +# ------------------ +# Linker and options +# ------------------ + + LD = $(CF) -mkl + +#--- Normal mode options + + + LIBS_N = $(SP_LIB4) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIBd) $(W3EMC_LIBd) + LIBS_N8 = $(LIBS_N) + + LDFLAGS_N = + + +#--- Debug mode options + + LIBS_D = $(LIBS_N) -lhmd + + LDFLAGS_D = $(LDFLAGS_N) diff --git a/util/NMC_Bkerror/sorc/Makefile.conf.theia b/util/NMC_Bkerror/sorc/Makefile.conf.theia index f868f15c4..3ac0dde1c 100644 --- a/util/NMC_Bkerror/sorc/Makefile.conf.theia +++ b/util/NMC_Bkerror/sorc/Makefile.conf.theia @@ -19,22 +19,27 @@ W3EMC_LIBd=$(CORELIB)/w3emc/v$(W3EMC_VER)/libw3emc_v$(W3EMC_VER)_d.a W3NCO_VER = 2.0.6 W3NCO_LIBd=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_d.a +NEMSIO_VER = 2.2.1 +INCnemsio= $(CORELIB)/nemsio/v$(NEMSIO_VER)/incmod/nemsio_v$(NEMSIO_VER) +NEMSIO_LIB=$(CORELIB)/nemsio/v$(NEMSIO_VER)/libnemsio_v$(NEMSIO_VER).a + + # ---------------------------- # Fortran compiler and options # ---------------------------- - CF = mpif90 -f90=ifort + CF = mpiifort #--- Normal mode options FFLAGS_F90 = -free -D_LAPACK_ - FFLAGS_COM_N = -I ./ -I $(INCsigio) -I $(INCw3) -O3 -fp-model strict -convert big_endian -g -traceback + FFLAGS_COM_N = -I ./ -I $(INCsigio) -I $(INCw3) -I $(INCnemsio) -O3 -fp-model strict -convert big_endian -g -traceback FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) #--- Debug mode options - FFLAGS_COM_D = -I ./ -I $(INCsigio) -I $(INCw3) -O0 -fp-model strict -convert big_endian -g -traceback -warn + FFLAGS_COM_D = -I ./ -I $(INCsigio) -I $(INCw3) -I $(INCnemsio) -O0 -fp-model strict -convert big_endian -g -traceback -warn FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) @@ -64,7 +69,7 @@ W3NCO_LIBd=$(CORELIB)/w3nco/v$(W3NCO_VER)/libw3nco_v$(W3NCO_VER)_d.a #--- Normal mode options - LIBS_N = $(SP_LIB4) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIBd) $(W3EMC_LIBd) + LIBS_N = $(SP_LIB4) $(NEMSIO_LIB) $(BACIO_LIB4) $(SIGIO_LIB4) $(W3NCO_LIBd) $(W3EMC_LIBd) LIBS_N8 = $(LIBS_N) LDFLAGS_N = diff --git a/util/NMC_Bkerror/sorc/biascor.f90 b/util/NMC_Bkerror/sorc/biascor.f90 index 8f384ea76..46f3060e3 100644 --- a/util/NMC_Bkerror/sorc/biascor.f90 +++ b/util/NMC_Bkerror/sorc/biascor.f90 @@ -21,8 +21,9 @@ subroutine biascor(numcases,mype) real(r_kind),dimension(nlat,nlon,nsig):: bcz,bcd,bct,bbz,bbd,bbt real(r_kind),dimension(nlat,nlon):: bbp,bcp - real(r_single),dimension(nlon,nlat,nsig):: bcz4,bcd4,bct4,bbz4,bbd4,bbt4 - real(r_single),dimension(nlon,nlat):: bcp4,bbp4 + real(r_kind),dimension(nlon,nlat,nsig):: bcz4,bcd4,bct4,bbz4,bbd4,bbt4 + real(r_kind),dimension(nlon,nlat):: bcp4,bbp4 + character(255) grdfile integer ncfggg,ifile diff --git a/util/NMC_Bkerror/sorc/comm_mod.f90 b/util/NMC_Bkerror/sorc/comm_mod.f90 index 594aba4ce..3187b3cef 100644 --- a/util/NMC_Bkerror/sorc/comm_mod.f90 +++ b/util/NMC_Bkerror/sorc/comm_mod.f90 @@ -415,4 +415,34 @@ subroutine grid2sub(workin,st,vp,tv,rh,oz,cw,ps) return end subroutine grid2sub +subroutine create_task_info(nfields, nprocs, taskid) +! 2017-10-25 Gael Descombes (NCAR) + implicit none + + integer, intent(in) :: nfields, nprocs + integer, intent(out) :: taskid(nfields) + + integer :: i, n, inum1, inum2, icount + integer :: ista, iend + + inum1 = nfields/nprocs + inum2 = mod(nfields, nprocs) + icount = 0 + do i = 1, inum1 + do n = 1, nprocs + icount = icount + 1 + taskid(icount) = n-1 + end do + end do + if ( inum2 > 0 ) then + do i = 1, nfields-(inum1*nprocs) + icount = icount + 1 + taskid(icount) = i-1 + end do + end if + + return +end subroutine create_task_info + + end module comm_mod diff --git a/util/NMC_Bkerror/sorc/getcases.f90 b/util/NMC_Bkerror/sorc/getcases.f90 index e13f77843..33cc9b0d8 100644 --- a/util/NMC_Bkerror/sorc/getcases.f90 +++ b/util/NMC_Bkerror/sorc/getcases.f90 @@ -1,13 +1,18 @@ subroutine getcases(numcases,mype) +! 2017-10-25 Gael Descombes (NCAR) - capability to read nemsio files ! This routine gets the names and number of available ! forecast pairs - use kinds, only: r_kind + use kinds, only: r_kind,r_single use variables, only: ak5,bk5,ck5,maxcases,nsig,dimbig,hybrid,& - filename,na,nb,zero,idpsfc5,idvm5,idthrm5,idvc5,ntrac5,cp5 + filename,na,nb,zero,idpsfc5,idvm5,idthrm5,idvc5,ntrac5,cp5,& + use_enkf,use_gfs_nemsio,ncepgfs_head,nlonin,nlatin use sigio_module, only: sigio_head,sigio_srhead,sigio_sclose,& sigio_sropen + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close + use nemsio_module, only: nemsio_gfile,nemsio_getfilehead implicit none - + + integer,parameter:: i_missing=-9999 integer,dimension(4):: idate4 integer nmin24(dimbig),nmin48(dimbig),idate5(5) integer nmina,nminb @@ -20,75 +25,152 @@ subroutine getcases(numcases,mype) real(r_kind) fhour5,ps0 real(r_kind),allocatable,dimension(:,:):: vcoord5 + ! for nemsio + character(8) filetype, mdlname + character(100) fname + integer,dimension(7):: idate + integer :: nfhour, nfminute, nfsecondn, nfsecondd, ncount24, ncount48 + real(r_single),allocatable,dimension(:,:,:) :: nems_vcoord + type(sigio_head):: sighead + type(ncepgfs_head):: gfshead + type(nemsio_gfile) :: gfile + logical :: isfile if (mype==0) write(6,*) 'BEGIN TESTCASES' rewind 10 ncases=0 do loop=1,dimbig - read(10,'(a100)',err=20,end=20)filename(loop) + read(10,'(a)',err=20,end=20)filename(loop) ncases=ncases+1 end do 20 continue close(10) - nmin24=-1 nmin48=-1 + ncount24 = 0 + ncount48 = 0 inges=50 do loop=1,ncases - call sigio_sropen(inges,filename(loop),iret) - call sigio_srhead(inges,sighead,iret2) + if ( use_gfs_nemsio ) then + call nemsio_init(iret=iret2) + if ( iret2 /= 0 ) then + write(6,*)' getcases: ***ERROR*** problem nemsio_init file = ', & + trim(filename(loop)),', Status = ',iret2 + stop + end if + call nemsio_open(gfile,filename(loop),'READ',iret=iret2) + if ( iret2 /= 0 ) then + write(6,*)' getcases: ***ERROR*** problem opening file = ', & + trim(filename(loop)),', Status = ',iret2 + stop + end if + + idate = i_missing + nfhour = i_missing + nfminute = i_missing + nfsecondn = i_missing + nfsecondd = i_missing + gfshead%idsl = i_missing + call nemsio_getfilehead(gfile, idate=idate, gtype=filetype, & + modelname=mdlname, nfhour=nfhour, nfminute=nfminute, & + nfsecondn=nfsecondn, nfsecondd=nfsecondd, & + dimx=gfshead%lonb, dimy=gfshead%latb, dimz=gfshead%levs, & + jcap=gfshead%jcap, ntrac=gfshead%ntrac, idvc=gfshead%idvc, & + idsl=gfshead%idsl, ncldt=gfshead%ncldt, iret=iret2) + fhour5 = float(nfhour) + float(nfminute)/60.0 + & + float(nfsecondn)/float(nfsecondd)/3600.0 + idate5(1) = idate(1) !year + idate5(2) = idate(2) !month + idate5(3) = idate(3) !day + idate5(4) = idate(4) !hour + idate5(5) = 0 + call nemsio_close(gfile,iret=iret2) + + nlonin=gfshead%lonb + nlatin=gfshead%latb + + else ! not use_gfs_nemsio + + call sigio_sropen(inges,filename(loop),iret) + call sigio_srhead(inges,sighead,iret2) - if (iret==0 .and. iret2==0) then - fhour4=sighead%fhour - idate4=sighead%idate - else - fhour4=9999 - idate4=9999 - end if - - call sigio_sclose(inges,iret) - - fhour5 = fhour4 - idate5(1)=idate4(4) - idate5(2)=idate4(2) - idate5(3)=idate4(3) - idate5(4)=idate4(1) - idate5(5)=0 + if (iret==0 .and. iret2==0) then + fhour4=sighead%fhour + idate4=sighead%idate + else + fhour4=9999 + idate4=9999 + end if + + call sigio_sclose(inges,iret) + + fhour5 = fhour4 + idate5(1)=idate4(4) + idate5(2)=idate4(2) + idate5(3)=idate4(3) + idate5(4)=idate4(1) + idate5(5)=0 + endif + call w3fs21(idate5,nming) - nming=nming+60*fhour5 - if(nint(fhour5).eq.24) nmin24(loop)=nming - if(nint(fhour5).eq.48) nmin48(loop)=nming + if (use_enkf) then + ! file contains ensmean file names and ens member file names + ! (ens mean files first, ens mem files after or vice versa) + fname = filename(loop) + if (fname(INDEX(fname,'_',BACK=.TRUE.)+1:len(fname)) == 'ensmean') then + nmin24(loop) = nming + ncount24 = ncount24 + 1 + na(ncount24) = loop + else + ncount48 = ncount48 + 1 + nmin48(loop) = nming + nb(ncount48) = loop + endif + else + nming=nming+60*fhour5 + if(nint(fhour5).eq.24) nmin24(loop)=nming + if(nint(fhour5).eq.48) nmin48(loop)=nming + endif 25 continue enddo - ncase=0 - ncount=0 - do loop=1,ncases - i24=-1 - nmina=-1 - nminb=-1 - if(nmin24(loop).gt.0) then - ncount=ncount+1 - if(ncount.eq.1)then - nmina=nmin24(loop) - i24=loop - j48=-1 - do j=1,ncases - if(nmin48(j).eq.nmin24(loop)) then - nminb=nmin48(j) - ncase=ncase+1 - na(ncase)=i24 - nb(ncase)=j -! write(6,*) 'nmin,na,nb=',ncase,nmin24(loop),na(ncase),nb(ncase) - end if - end do - ncount=0 - end if ! endif ncount - end if ! endif nmin24(loop) - enddo ! end loop to ncases + if (.not. use_enkf) then + ncase=0 + ncount=0 + do loop=1,ncases + i24=-1 + nmina=-1 + nminb=-1 + if(nmin24(loop).gt.0) then + ncount=ncount+1 + if(ncount.eq.1)then + nmina=nmin24(loop) + i24=loop + j48=-1 + do j=1,ncases + if(nmin48(j).eq.nmin24(loop)) then + nminb=nmin48(j) + ncase=ncase+1 + na(ncase)=i24 + nb(ncase)=j + end if + end do + ncount=0 + end if ! endif ncount + end if ! endif nmin24(loop) + enddo ! end loop to ncases + else + if (ncount24 .ne. ncount48) then + write(6,*) '# of ensmean filenames not equal to # of ens mem filenames',ncount24,ncount48 + call mpi_finalize(ierror) + stop + else + ncase = ncount24 + endif + endif if(mype==0)write(6,*)' number of cases available = ',ncase if(ncase.eq.0) then @@ -100,61 +182,110 @@ subroutine getcases(numcases,mype) numcases=min(ncase,maxcases) if(mype==0)write(6,*)' number of cases to process for generating background stats = ',numcases + if ( use_gfs_nemsio ) then + ! hardwired for now + idpsfc5 = 2 + idvc5 = 2 + idthrm5 = 2 + ntrac5 = 3 + + call nemsio_init(iret=iret2) + if ( iret2 /= 0 ) then + write(6,*)' GESINFO: ***ERROR*** problem nemsio_init file = ', & + trim(filename(1)),', Status = ',iret2 + stop + end if + call nemsio_open(gfile,filename(1),'READ',iret=iret2) + if ( iret2 /= 0 ) then + write(6,*)' GESINFO: ***ERROR*** problem opening file = ', & + trim(filename(1)),', Status = ',iret2 + stop + end if + + allocate(nems_vcoord(nsig+1,3,2)) + call nemsio_getfilehead(gfile,iret=iret2,vcoord=nems_vcoord) + if ( iret2 /= 0 ) then + write(6,*)' GESINFO: ***ERROR*** problem reading header ', & + 'vcoord, Status = ',iret2 + stop + endif + +! Determine the type of vertical coordinate used by model because that +! gfshead%nvcoord is no longer part of NEMSIO header output. + nvcoord5=3 + if(maxval(nems_vcoord(:,3,1))==zero .and. & + minval(nems_vcoord(:,3,1))==zero ) then + nvcoord5=2 + if(maxval(nems_vcoord(:,2,1))==zero .and. & + minval(nems_vcoord(:,2,1))==zero ) then + nvcoord5=1 + end if + end if + + allocate(vcoord5(nsig+1,nvcoord5)) + vcoord5(:,1:nvcoord5)=nems_vcoord(:,1:nvcoord5,1) + + deallocate(nems_vcoord) + + else ! not use_gfs_nemsio ! DTK NEW EXTRACT SOME STUFF FROM THE FIRST LISTED FILE - call sigio_sropen(inges,filename(1),iret) - call sigio_srhead(inges,sighead,iret2) + call sigio_sropen(inges,filename(1),iret) + call sigio_srhead(inges,sighead,iret2) - idvc5=sighead%idvc - idvm5=sighead%idvm - ntrac5=sighead%ntrac - nvcoord5=sighead%nvcoord + idvc5=sighead%idvc + idvm5=sighead%idvm + ntrac5=sighead%ntrac + nvcoord5=sighead%nvcoord + + allocate(vcoord5(nsig+1,nvcoord5)) + vcoord5=sighead%vcoord + + idpsfc5 = mod ( sighead%idvm,10 ) + idthrm5 = mod ( sighead%idvm/10,10 ) + + write(6,*) 'GETCASES: idpsfc5,idthrm5 = ',idpsfc5,idthrm5 - idpsfc5 = mod ( sighead%idvm,10 ) - idthrm5 = mod ( sighead%idvm/10,10 ) - write(6,*) 'GETCASES: idpsfc5,idthrm5 = ',idpsfc5,idthrm5 + allocate(cp5(ntrac5+1)) + + if (idthrm5==3) then + do k=1,sighead%ntrac+1 + cp5(k)=sighead%cpi(k) + if (mype==0) write(6,*) 'k,cp5 = ',cp5(k) + end do + else + do k=1,ntrac5+1 + cp5(k)=zero + end do + end if - allocate(vcoord5(nsig+1,nvcoord5)) - vcoord5=sighead%vcoord + call sigio_sclose(inges,iret) + endif !no use_gfs_nemsio do k=1,nsig+1 - ak5(k)=zero - bk5(k)=zero - ck5(k)=zero + ak5(k)=zero + bk5(k)=zero + ck5(k)=zero end do do k=1,nsig+1 - if (nvcoord5 ==1 ) then - bk5(k)=vcoord5(k,1) - else if (nvcoord5 >= 2) then - ak5(k)=vcoord5(k,1)*0.001_r_kind - bk5(k)=vcoord5(k,2) - else if (nvcoord5 >= 3) then - ck5(k)=vcoord5(k,3)*0.001_r_kind - end if + if (nvcoord5 ==1 ) then + bk5(k)=vcoord5(k,1) + else if (nvcoord5 >= 2) then + ak5(k)=vcoord5(k,1)*0.001_r_kind + bk5(k)=vcoord5(k,2) + else if (nvcoord5 >= 3) then + ck5(k)=vcoord5(k,3)*0.001_r_kind + end if end do - + deallocate(vcoord5) - allocate(cp5(ntrac5+1)) - - if (idthrm5==3) then - do k=1,sighead%ntrac+1 - cp5(k)=sighead%cpi(k) - if (mype==0) write(6,*) 'k,cp5 = ',cp5(k) - end do - else - do k=1,ntrac5+1 - cp5(k)=zero - end do - end if - - call sigio_sclose(inges,iret) if (mype==0) write(6,*) 'END GETCASES' return - end subroutine getcases +end subroutine getcases diff --git a/util/NMC_Bkerror/sorc/grdsphdp.f90 b/util/NMC_Bkerror/sorc/grdsphdp.f90 index 3afb723f6..ff28cfc10 100755 --- a/util/NMC_Bkerror/sorc/grdsphdp.f90 +++ b/util/NMC_Bkerror/sorc/grdsphdp.f90 @@ -909,7 +909,7 @@ subroutine inisph(r,yor,tau,nx,ny) coef(lacoy1+ix-1)=(float(ix)-half)*pi2onx enddo - call cdcoef(nxh,noq,zero,pi,coef(lacoy1),w& + call cdcoef(nxh,noq,dble(zero),dble(pi),coef(lacoy1),w& ,coef(lacox1),coef(lbcox1),coef(lacox2),coef(lbcox2)& ,nxh,nxh,nxh,nxh) do i=0,nxa-1 diff --git a/util/NMC_Bkerror/sorc/initvars.f90 b/util/NMC_Bkerror/sorc/initvars.f90 index cf92050ad..8797baf65 100644 --- a/util/NMC_Bkerror/sorc/initvars.f90 +++ b/util/NMC_Bkerror/sorc/initvars.f90 @@ -4,12 +4,13 @@ subroutine initvars(mype,npe) deg2rad,rlons,nsig,& dimbig,filename,nlat,sweight,& na,nb,pi,db_prec,coriolis, & - two,omega,idpsfc5,idvm5,idvc5,idthrm5 + two,omega,idpsfc5,idvm5,idvc5,idthrm5,& + scaling,varscale use specgrid, only: wlat,slat,jb,je implicit none integer,intent(in):: mype,npe - integer i,ii,l,m,i1 + integer i,ii,l,m,i1,k real(r_kind) anlon,dlon,pih real(r_kind) onetest real(r_double) onedouble @@ -55,12 +56,10 @@ subroutine initvars(mype,npe) wgtlats(1)=0.0_r_kind wgtlats(nlat)=0.0_r_kind - do i=1,nlat coriolis(i)=two*omega*sin(rlats(i)) end do - ! test for precision at which code was compiled onetest=1.; onedouble=1. if(digits(onetest).lt.digits(onedouble)) then @@ -70,6 +69,15 @@ subroutine initvars(mype,npe) endif if (mype==0) write(6,*) 'INITVARS: DB_PREC = ',db_prec + if (scaling == .true.) then + allocate (varscale(nsig)) + open(12,file='scaling.txt',form='formatted') + do k=1,nsig + read(12,'(F4.2)') varscale(k) + print*,varscale(k) + enddo + endif + return end subroutine initvars diff --git a/util/NMC_Bkerror/sorc/postmod.f90 b/util/NMC_Bkerror/sorc/postmod.f90 index f549aa441..ced6277ec 100644 --- a/util/NMC_Bkerror/sorc/postmod.f90 +++ b/util/NMC_Bkerror/sorc/postmod.f90 @@ -105,7 +105,7 @@ subroutine writefiles real(r_single),allocatable,dimension(:) :: psvar4,pshln4 real(r_kind),dimension(nlat) :: slat,glat - integer :: i,j,k,m,outf,ncfggg,iret,isig,n + integer :: i,j,k,m,outf,ncfggg,iret,isig,n,ntotal character(len=255) :: grdfile character(len=5) :: var(40) @@ -266,6 +266,8 @@ subroutine writefiles call baclose(22,iret) ! ALSO CREATE GRADS CTL FILE + ntotal = 23 + nsig + open(24,file='bgstats_sp.ctl',form='formatted',status='replace',iostat=iret) write(24,'("DSET ",a)') trim(grdfile) write(24,'("UNDEF -9.99E+33")') @@ -275,7 +277,7 @@ subroutine writefiles write(24,'(5f12.6)') slat write(24,'("ZDEF",i6," LINEAR 1 1")') nsig write(24,'("TDEF",i6,1x,"LINEAR",1x,"00Z01Jan2000",1x,i3,"hr")') 1,12 - write(24,'("VARS",i6)') 87 + write(24,'("VARS",i6)') ntotal write(24,'("SF ",i3," 0 SF VAR")') nsig write(24,'("VP ",i3," 0 VP VAR")') nsig write(24,'("T ",i3," 0 T VAR")') nsig diff --git a/util/NMC_Bkerror/sorc/readpairs.f90 b/util/NMC_Bkerror/sorc/readpairs.f90 index 129846c66..1a1fcc71a 100644 --- a/util/NMC_Bkerror/sorc/readpairs.f90 +++ b/util/NMC_Bkerror/sorc/readpairs.f90 @@ -1,23 +1,32 @@ subroutine readpairs(npe,mype,numcases) +! 2017-10-25 Gael Descombes (NCAR) - capability to read nemsio files use variables, only: nlat,nlon,nsig,ak5,bk5,ck5,& na,nb,filename,hybrid,db_prec,zero,one,fv,& idpsfc5,idthrm5,cp5,ntrac5,idvc5,idvm5,lat1,lon1,& iglobal,ijn_s,displs_s,filunit1,filunit2,& - ird_s,irc_s,displs_g + ird_s,irc_s,displs_g, ijn,nlonin,nlatin + use variables, only: use_gfs_nemsio use specgrid, only: sptez_s,nc,ncin,factvml,& - factsml,enn1,ncd2,jcaptrans,jcap,jcapin,unload_grid + factsml,enn1,ncd2,jcaptrans,jcap,jcapin,unload_grid,& + sptezv_s,sptez_sin,sptezv_sin,init_spec_varsin use sigio_module, only: sigio_intkind,sigio_head,sigio_data,& sigio_srohdc,sigio_axdata,sigio_sclose use comm_mod, only: levs_id,nvar_id,grid2sub,nsig1o,spec_send,& - disp_spec + disp_spec,create_task_info use kinds, only: r_kind,r_single,r_double + use nemsio_module, only: nemsio_gfile,nemsio_open,nemsio_close,& + nemsio_getfilehead,nemsio_getheadvar,& + nemsio_readrecv,nemsio_init,nemsio_realkind + implicit none include 'mpif.h' integer npe,mype,numcases,ierror,mpi_rtype,iret,iret2 integer mm1,kk,proc1,proc2 integer i,j,k,m,n,inges,inge2,i2,i2m1 - integer k1,k2,k3,k4,k5,k6 + integer k1,k2,k3,k4,k5,k6,jj + integer nfields, icount + integer, allocatable :: taskid(:) real(r_kind),dimension(lat1,lon1,nsig):: sf1,sf2,vp1,vp2,t1,t2,& rh1,rh2,oz1,oz2,cw1,cw2,q1,q2,ts1,ts2,qs1,qs2 @@ -25,18 +34,23 @@ subroutine readpairs(npe,mype,numcases) real(r_kind),dimension(lat1,lon1,nsig,ntrac5):: trac1,trac2 real(r_kind),dimension(nc):: z,z2 - real(r_single),dimension(ncin,nsig1o):: z41,z42 - real(r_single),dimension(ncin,6*nsig+1):: z4all + real(r_kind),dimension(ncin,nsig1o):: z41,z42 + real(r_kind),dimension(ncin,6*nsig+1):: z4all, z4all2 + real(r_kind),dimension(ncin,nsig):: zwork1,zwork2 real(r_kind),dimension(nlon,nlat-2):: grid1,grid2 - real(r_kind),dimension(iglobal,nsig1o):: work1,work2 - - real(r_kind),dimension(iglobal,ntrac5):: gridtrac1,gridtrac2 + real(r_kind),dimension(nlonin,nlatin-2):: grid1in,grid2in + real(r_kind),dimension(nlonin,nlatin-2):: tmpgridin + real(r_kind),dimension(iglobal,nsig1o):: work1,work2 type(sigio_head):: sighead1,sighead2 type(sigio_data):: sigdata1,sigdata2 + type(nemsio_gfile) :: gfile1 + type(nemsio_gfile) :: gfile2 + real(nemsio_realkind),dimension((nlatin-2)*nlonin):: nems_wk + logical ice if (db_prec) then mpi_rtype=mpi_real8 @@ -50,159 +64,344 @@ subroutine readpairs(npe,mype,numcases) proc1=0 proc2=npe-1 + z4all = 0.0 + z4all2 = 0.0 + + if (use_gfs_nemsio) then + nfields = 1+5*nsig !ps, (u,v), t, q, oz, cw + allocate(taskid(nfields)) + call create_task_info(nfields, npe, taskid) + endif + filunit1=(10000+(mype+1)) filunit2=(20000+(mype+1)) + if (use_gfs_nemsio) call init_spec_varsin(nlatin,nlonin,nsig) + ! Each mpi task will carry two files, which contains all variables, for each of the time levels open(filunit1,form='unformatted',action='write') rewind(filunit1) open(filunit2,form='unformatted',action='write') rewind(filunit2) - do n=1,numcases - if (mype==0) write(6,*)'opening=', inges,filename(na(n)) - if (mype==0) write(6,*)'opening=', inge2,filename(nb(n)) + call nemsio_init(iret=iret) + if(iret/=0) then + write(6,*)'readpairs: problem with nemsio_init, iret=',iret + stop + end if -! Get spectral information from - if (mype==proc1) call sigio_srohdc(inges,filename(na(n)),sighead1,sigdata1,iret) - if (mype==proc2) call sigio_srohdc(inge2,filename(nb(n)),sighead1,sigdata1,iret) - call mpi_barrier(mpi_comm_world,iret2) + do n=1,numcases + if ( use_gfs_nemsio ) then + if (mype==0) write(6,*)'reading from', trim(filename(na(n))) + call nemsio_open(gfile1,trim(adjustl(filename(na(n)))),'read',iret=iret) + if (iret/=0) then + write(6,*)'readpairs_1: problem with nemsio_open, mype, iret=',mype,iret + stop + endif + if (mype==0) write(6,*)'reading from', trim(filename(nb(n))) + call nemsio_open(gfile2,trim(adjustl(filename(nb(n)))),'read',iret=iret) + if (iret/=0) then + write(6,*)'readpairs_2: problem with nemsio_open, mype, iret=',mype,iret + stop + endif + + ! convert from grid to wave + icount = 0 + icount = icount + 1 + !ps + if ( mype == taskid(icount) ) then + call nemsio_readrecv(gfile1,'pres','sfc',lev=1,data=nems_wk(:),iret=iret) + nems_wk(:) = nems_wk(:)*0.001 !Pa to cbar + grid1in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call nemsio_readrecv(gfile2,'pres','sfc',lev=1,data=nems_wk(:),iret=iret) + nems_wk(:) = nems_wk(:)*0.001 !Pa to cbar + grid2in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call sptez_sin(z4all (:,6*nsig+1),grid1in,-1) + call sptez_sin(z4all2(:,6*nsig+1),grid2in,-1) + end if + !t + do k=1,nsig + icount = icount + 1 + if ( mype == taskid(icount) ) then + call nemsio_readrecv(gfile1,'tmp','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid1in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call nemsio_readrecv(gfile2,'tmp','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid2in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call sptez_sin(z4all (:,2*nsig+k),grid1in,-1) + call sptez_sin(z4all2(:,2*nsig+k),grid2in,-1) + end if + end do + !q + do k=1,nsig + icount = icount + 1 + if ( mype == taskid(icount) ) then + call nemsio_readrecv(gfile1,'spfh','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid1in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call nemsio_readrecv(gfile2,'spfh','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid2in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call sptez_sin(z4all (:,3*nsig+k),grid1in,-1) + call sptez_sin(z4all2(:,3*nsig+k),grid2in,-1) + end if + end do + !oz + do k=1,nsig + icount = icount + 1 + if ( mype == taskid(icount) ) then + call nemsio_readrecv(gfile1,'o3mr','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid1in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call nemsio_readrecv(gfile2,'o3mr','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid2in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call sptez_sin(z4all (:,4*nsig+k),grid1in,-1) + call sptez_sin(z4all2(:,4*nsig+k),grid2in,-1) + end if + end do - if (mype==proc1 .or. mype==proc2) then - do k=1,nsig - k1=nsig - k2=2*nsig - k3=3*nsig - k4=4*nsig - k5=5*nsig + !cw + do k=1,nsig + icount = icount + 1 + if ( mype == taskid(icount) ) then + call nemsio_readrecv(gfile1,'clwmr','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid1in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call nemsio_readrecv(gfile2,'clwmr','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid2in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + call nemsio_readrecv(gfile1,'icmr','mid layer',lev=k,data=nems_wk(:),iret=iret) + if ( iret == 0 ) then + tmpgridin = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + grid1in = grid1in + tmpgridin + + call nemsio_readrecv(gfile2,'icmr','mid layer',lev=k,data=nems_wk(:),iret=iret) + tmpgridin = reshape(nems_wk(:),(/nlonin,nlatin-2/)) + grid2in = grid2in + tmpgridin + endif + call sptez_sin(z4all (:,5*nsig+k),grid1in,-1) + call sptez_sin(z4all2(:,5*nsig+k),grid2in,-1) + end if + end do + ! u,v to div,vor + do k=1,nsig + icount = icount + 1 + if ( mype == taskid(icount) ) then + call nemsio_readrecv(gfile1,'ugrd','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid1in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) !ugrd of file1 + call nemsio_readrecv(gfile1,'vgrd','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid2in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) !vgrd of file1 + call sptezv_sin(z4all(:,nsig+k),z4all(:,k),grid1in,grid2in,-1) + call nemsio_readrecv(gfile2,'ugrd','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid1in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) !ugrd of file2 + call nemsio_readrecv(gfile2,'vgrd','mid layer',lev=k,data=nems_wk(:),iret=iret) + grid2in = reshape(nems_wk(:),(/nlonin,nlatin-2/)) !vgrd of file2 + call sptezv_sin(z4all2(:,nsig+k),z4all2(:,k),grid1in,grid2in,-1) + end if + end do + + ! need to improve in the future + ! broadcast the data on various processors to all processors + icount = 0 + icount = icount + 1 + !ps + call mpi_bcast(z4all(:,6*nsig+1),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + call mpi_bcast(z4all2(:,6*nsig+1),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + do k=1,nsig + icount = icount + 1 + !t + call mpi_bcast(z4all(:,2*nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + call mpi_bcast(z4all2(:,2*nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + end do + do k=1,nsig + icount = icount + 1 + !q + call mpi_bcast(z4all(:,3*nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + call mpi_bcast(z4all2(:,3*nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + end do + do k=1,nsig + icount = icount + 1 + !oz + call mpi_bcast(z4all(:,4*nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + call mpi_bcast(z4all2(:,4*nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + end do + do k=1,nsig + icount = icount + 1 + !cw + call mpi_bcast(z4all(:,5*nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + call mpi_bcast(z4all2(:,5*nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + end do + do k=1,nsig + icount = icount + 1 + !z (vor) + call mpi_bcast(z4all(:,k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + call mpi_bcast(z4all2(:,k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + !d (div) + call mpi_bcast(z4all(:,nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + call mpi_bcast(z4all2(:,nsig+k),ncin,mpi_rtype,taskid(icount), & + & mpi_comm_world,ierror) + end do + call mpi_scatterv(z4all,spec_send,disp_spec,mpi_rtype,& + z41,spec_send(mm1),mpi_rtype,0,mpi_comm_world,ierror) + call mpi_scatterv(z4all2,spec_send,disp_spec,mpi_rtype,& + z42,spec_send(mm1),mpi_rtype,0,mpi_comm_world,ierror) + + call mpi_barrier(mpi_comm_world,iret2) + + call nemsio_close(gfile1,iret=iret) + call nemsio_close(gfile2,iret=iret) + + else !if not use_gfs_nemsio + if (mype==0) write(6,*)'opening=', inges,filename(na(n)) + if (mype==0) write(6,*)'opening=', inge2,filename(nb(n)) + + ! Get spectral information from + if (mype==proc1) call sigio_srohdc(inges,filename(na(n)),sighead1,sigdata1,iret) + if (mype==proc2) call sigio_srohdc(inge2,filename(nb(n)),sighead1,sigdata1,iret) + call mpi_barrier(mpi_comm_world,iret2) + + if (mype==proc1 .or. mype==proc2) then + do k=1,nsig + k1=nsig + k2=2*nsig + k3=3*nsig + k4=4*nsig + k5=5*nsig + do i=1,ncin + z4all(i,k)=sigdata1%z(i,k) + z4all(i,k1+k)=sigdata1%d(i,k) + z4all(i,k2+k)=sigdata1%t(i,k) + z4all(i,k3+k)=sigdata1%q(i,k,1) + z4all(i,k4+k)=sigdata1%q(i,k,2) + z4all(i,k5+k)=sigdata1%q(i,k,3) + end do + end do + k6=6*nsig do i=1,ncin - z4all(i,k)=sigdata1%z(i,k) - z4all(i,k1+k)=sigdata1%d(i,k) - z4all(i,k2+k)=sigdata1%t(i,k) - z4all(i,k3+k)=sigdata1%q(i,k,1) - z4all(i,k4+k)=sigdata1%q(i,k,2) - z4all(i,k5+k)=sigdata1%q(i,k,3) + z4all(i,k6+1)=sigdata1%ps(i) end do - end do - k6=6*nsig - do i=1,ncin - z4all(i,k6+1)=sigdata1%ps(i) - end do - end if + end if + call mpi_scatterv(z4all,spec_send,disp_spec,mpi_rtype,& + z41,spec_send(mm1),mpi_rtype,proc1,mpi_comm_world,ierror) + call mpi_scatterv(z4all,spec_send,disp_spec,mpi_rtype,& + z42,spec_send(mm1),mpi_rtype,proc2,mpi_comm_world,ierror) + + end if ! use_gfs_nemsio - call mpi_scatterv(z4all,spec_send,disp_spec,mpi_rtype,& - z41,spec_send(mm1),mpi_rtype,proc1,mpi_comm_world,ierror) - call mpi_scatterv(z4all,spec_send,disp_spec,mpi_rtype,& - z42,spec_send(mm1),mpi_rtype,proc2,mpi_comm_world,ierror) + call mpi_barrier(mpi_comm_world,iret2) - work1=zero ; work2=zero + work1=zero ; work2=zero - do k=1,nsig1o -! Check: Streamfunction level? - if(nvar_id(k).eq.1) then ! SF + do k=1,nsig1o + ! Check: Streamfunction level? + if(nvar_id(k).eq.1) then ! SF kk=levs_id(k) if (kk.gt.0 .and. kk.le.nsig) then - call jcaptrans(z,factvml,z41(1,k)) - call jcaptrans(z2,factvml,z42(1,k)) - - call splaplac(0,jcap,enn1,z,z,-1) - call splaplac(0,jcap,enn1,z2,z2,-1) - z(1:2)=zero - z2(1:2)=zero - call sptez_s(z,grid1,1) - call sptez_s(z2,grid2,1) - call unload_grid(grid1,work1(1,k)) - call unload_grid(grid2,work2(1,k)) + call jcaptrans(z,factvml,z41(1,k)) + call jcaptrans(z2,factvml,z42(1,k)) + + call splaplac(0,jcap,enn1,z,z,-1) + call splaplac(0,jcap,enn1,z2,z2,-1) + z(1:2)=zero + z2(1:2)=zero + call sptez_s(z,grid1,1) + call sptez_s(z2,grid2,1) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) end if !end if kk check -! Check: Velocity Potential level? - else if(nvar_id(k).eq.2) then + ! Check: Velocity Potential level? + else if(nvar_id(k).eq.2) then kk=levs_id(k) if (kk.gt.0 .and. kk.le.nsig) then - call jcaptrans(z,factvml,z41(1,k)) - call jcaptrans(z2,factvml,z42(1,k)) - - call splaplac(0,jcap,enn1,z,z,-1) - call splaplac(0,jcap,enn1,z2,z2,-1) - z(1:2)=zero - z2(1:2)=zero - call sptez_s(z,grid1,1) - call sptez_s(z2,grid2,1) - call unload_grid(grid1,work1(1,k)) - call unload_grid(grid2,work2(1,k)) + call jcaptrans(z,factvml,z41(1,k)) + call jcaptrans(z2,factvml,z42(1,k)) + + call splaplac(0,jcap,enn1,z,z,-1) + call splaplac(0,jcap,enn1,z2,z2,-1) + z(1:2)=zero + z2(1:2)=zero + call sptez_s(z,grid1,1) + call sptez_s(z2,grid2,1) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) end if !end if kk check -! Check: Temperature Level? - else if(nvar_id(k).eq.3) then ! SF + ! Check: Temperature Level? + else if(nvar_id(k).eq.3) then ! SF kk=levs_id(k) if (kk.gt.0 .and. kk.le.nsig) then - call jcaptrans(z,factsml,z41(1,k)) - call jcaptrans(z2,factsml,z42(1,k)) - call sptez_s(z,grid1,1) - call unload_grid(grid1,work1(1,k)) - call sptez_s(z2,grid2,1) - call unload_grid(grid2,work2(1,k)) - end if + call jcaptrans(z,factsml,z41(1,k)) + call jcaptrans(z2,factsml,z42(1,k)) + call sptez_s(z,grid1,1) + call unload_grid(grid1,work1(1,k)) + call sptez_s(z2,grid2,1) + call unload_grid(grid2,work2(1,k)) + end if -! Check: Relative Humidity level? - else if(nvar_id(k).eq.4) then ! Q + ! Check: Relative Humidity level? + else if(nvar_id(k).eq.4) then ! Q kk=levs_id(k) if (kk.gt.0 .and. kk.le.nsig) then - call jcaptrans(z,factsml,z41(1,k)) - call jcaptrans(z2,factsml,z42(1,k)) - call sptez_s(z,grid1,1) - call unload_grid(grid1,work1(1,k)) - call sptez_s(z2,grid2,1) - call unload_grid(grid2,work2(1,k)) + call jcaptrans(z,factsml,z41(1,k)) + call jcaptrans(z2,factsml,z42(1,k)) + call sptez_s(z,grid1,1) + call unload_grid(grid1,work1(1,k)) + call sptez_s(z2,grid2,1) + call unload_grid(grid2,work2(1,k)) end if -! Check: Ozone Level? - else if(nvar_id(k).eq.5) then ! SF + ! Check: Ozone Level? + else if(nvar_id(k).eq.5) then ! SF kk=levs_id(k) if (kk.gt.0 .and. kk.le.nsig) then - call jcaptrans(z,factsml,z41(1,k)) - call jcaptrans(z2,factsml,z42(1,k)) - call sptez_s(z,grid1,1) - call unload_grid(grid1,work1(1,k)) - call sptez_s(z2,grid2,1) - call unload_grid(grid2,work2(1,k)) + call jcaptrans(z,factsml,z41(1,k)) + call jcaptrans(z2,factsml,z42(1,k)) + call sptez_s(z,grid1,1) + call unload_grid(grid1,work1(1,k)) + call sptez_s(z2,grid2,1) + call unload_grid(grid2,work2(1,k)) end if -! Check: Cloud Water Level? - else if(nvar_id(k).eq.6) then ! SF + ! Check: Cloud Water Level? + else if(nvar_id(k).eq.6) then ! SF kk=levs_id(k) if (kk.gt.0 .and. kk.le.nsig) then - call jcaptrans(z,factsml,z41(1,k)) - call jcaptrans(z2,factsml,z42(1,k)) - call sptez_s(z,grid1,1) - call unload_grid(grid1,work1(1,k)) - call sptez_s(z2,grid2,1) - call unload_grid(grid2,work2(1,k)) + call jcaptrans(z,factsml,z41(1,k)) + call jcaptrans(z2,factsml,z42(1,k)) + call sptez_s(z,grid1,1) + call unload_grid(grid1,work1(1,k)) + call sptez_s(z2,grid2,1) + call unload_grid(grid2,work2(1,k)) end if -! Check: Surface pressure level ? - else if(nvar_id(k).eq.7) then ! PS + ! Check: Surface pressure level ? + else if(nvar_id(k).eq.7) then ! PS kk=levs_id(k) if (kk.eq.1) then - call jcaptrans(z,factsml,z41(1,k)) - call jcaptrans(z2,factsml,z42(1,k)) - call sptez_s(z,grid1,1) - call sptez_s(z2,grid2,1) - - call unload_grid(grid1,work1(1,k)) - call unload_grid(grid2,work2(1,k)) - + call jcaptrans(z,factsml,z41(1,k)) + call jcaptrans(z2,factsml,z42(1,k)) + call sptez_s(z,grid1,1) + call sptez_s(z2,grid2,1) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) end if - else ! No nsig1o level to process + else ! No nsig1o level to process !! write(6,*) 'READPAIRS: No Level to process, k,mype,levs_id,nvar_id = ',k,mype,levs_id(k),nvar_id(k) - endif - end do !End do nsig1o levs + endif + end do !End do nsig1o levs ! CALL GRID2SUB HERE call grid2sub(work1,sf1,vp1,t1,q1,oz1,cw1,ps1) call grid2sub(work2,sf2,vp2,t2,q2,oz2,cw2,ps2) - if (idpsfc5 /=2) then do j=1,lon1 do i=1,lat1 @@ -219,32 +418,40 @@ subroutine readpairs(npe,mype,numcases) ! idthrm5 = 2 = sensible (dry) temperature (T) ! idthrm5 = 3 = enthalpy (h=CpT) ! The GSI analysis variable is Tv - do k=1,nsig - do j=1,lon1 - do i=1,lat1 - trac1(i,j,k,1)=q1(i,j,k) - trac1(i,j,k,2)=oz1(i,j,k) - trac1(i,j,k,3)=cw1(i,j,k) - trac2(i,j,k,1)=q2(i,j,k) - trac2(i,j,k,2)=oz2(i,j,k) - trac2(i,j,k,3)=cw2(i,j,k) - end do - end do - end do + if ( .not. use_gfs_nemsio ) then + do k=1,nsig + do j=1,lon1 + do i=1,lat1 + trac1(i,j,k,1)=q1(i,j,k) + trac1(i,j,k,2)=oz1(i,j,k) + trac1(i,j,k,3)=cw1(i,j,k) + trac2(i,j,k,1)=q2(i,j,k) + trac2(i,j,k,2)=oz2(i,j,k) + trac2(i,j,k,3)=cw2(i,j,k) + end do + end do + end do ! Convert input thermodynamic variable to dry temperature - call sigio_cnvtdv2(lat1*lon1,lat1*lon1,nsig,idvc5,& - idvm5,ntrac5,iret,t1,trac1,cp5,1) - call sigio_cnvtdv2(lat1*lon1,lat1*lon1,nsig,idvc5,& - idvm5,ntrac5,iret,t2,trac2,cp5,1) + call sigio_cnvtdv2(lat1*lon1,lat1*lon1,nsig,idvc5,& + idvm5,ntrac5,iret,t1,trac1,cp5,1) + call sigio_cnvtdv2(lat1*lon1,lat1*lon1,nsig,idvc5,& + idvm5,ntrac5,iret,t2,trac2,cp5,1) + end if ! not use_gfs_nemsio + if ( use_gfs_nemsio ) then + ! the nemsio t is t sensible + ts1 = t1 + ts2 = t2 + end if + ! Make sure we have Virtual Temperature - do k=1,nsig - do j=1,lon1 - do i=1,lat1 - t1(i,j,k) = t1(i,j,k)*(one+fv*q1(i,j,k)) - t2(i,j,k) = t2(i,j,k)*(one+fv*q2(i,j,k)) + do k=1,nsig + do j=1,lon1 + do i=1,lat1 + t1(i,j,k) = t1(i,j,k)*(one+fv*q1(i,j,k)) + t2(i,j,k) = t2(i,j,k)*(one+fv*q2(i,j,k)) + end do end do - end do - end do + end do end if ! END IF CHECK ON THERMO VARIABLE @@ -253,15 +460,18 @@ subroutine readpairs(npe,mype,numcases) do k=1,nsig do j=1,lon1 do i=1,lat1 + if ( .not. use_gfs_nemsio ) then ! create sensible temperature for qsat calculations - ts1(i,j,k)=t1(i,j,k)/(one+fv*max(zero,q1(i,j,k))) - ts2(i,j,k)=t2(i,j,k)/(one+fv*max(zero,q2(i,j,k))) - qs1(i,j,k)=q1(i,j,k) - qs2(i,j,k)=q2(i,j,k) + ts1(i,j,k)=t1(i,j,k)/(one+fv*max(zero,q1(i,j,k))) + ts2(i,j,k)=t2(i,j,k)/(one+fv*max(zero,q2(i,j,k))) + end if !not use_gfs_nemsio + qs1(i,j,k)=q1(i,j,k) + qs2(i,j,k)=q2(i,j,k) end do end do end do ice=.true. + !ice=.false. call genqsat(ts1,qs1,lat1,lon1,& ps1,ice,ak5,bk5,ck5) call genqsat(ts2,qs2,lat1,lon1,& @@ -289,9 +499,12 @@ subroutine readpairs(npe,mype,numcases) write(filunit1) sf1,vp1,t1,rh1,oz1,cw1,ps1 write(filunit2) sf2,vp2,t2,rh2,oz2,cw2,ps2 + call mpi_barrier(mpi_comm_world,iret2) + end do ! END DO LOOP OVER CASES close(filunit1) close(filunit2) + if (use_gfs_nemsio) deallocate(taskid) call mpi_barrier(mpi_comm_world,iret2) @@ -337,6 +550,7 @@ subroutine sigio_cnvtdv2(im,ix,km,idvc,idvm,ntrac,iret,t,q,cpi,cnflg) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - thermodyn_id = mod(IDVM/10,10) ! + iret = 0 if (thermodyn_id == 3 .and. idvc == 3) then xcp(1:im,:) = zero diff --git a/util/NMC_Bkerror/sorc/specgrid.f90 b/util/NMC_Bkerror/sorc/specgrid.f90 index b1e05b049..727c5175b 100644 --- a/util/NMC_Bkerror/sorc/specgrid.f90 +++ b/util/NMC_Bkerror/sorc/specgrid.f90 @@ -1,14 +1,18 @@ module specgrid - use kinds, only: r_kind,r_double + use kinds, only: r_kind,r_double,i_kind implicit none - integer jcap,jcapin,jcapsmooth,nc,ncin,ncd2 + integer jcap,jcapin,jcapsmooth,nc,ncin,ncd2,ncd2in integer iromb,idrt,imax,jmax,ijmax,jn,js,kw,jb,je,jc,ioffset + integer imaxin,jmaxin,ijmaxin,jnin,jsin,kwin,jbin,jein,ioffsetin real(r_kind),allocatable,dimension(:):: factsml,factvml real(r_kind),allocatable,dimension(:):: eps,epstop,enn1,elonn1,eon,eontop real(r_kind),allocatable,dimension(:):: clat,slat,wlat + real(r_kind),allocatable,dimension(:):: epsin,epstopin,enn1in,elonn1in,eonin,eontopin + real(r_kind),allocatable,dimension(:):: clatin,slatin,wlatin real(r_kind),allocatable,dimension(:,:):: pln,plntop - real(r_double),allocatable,dimension(:):: afft + real(r_kind),allocatable,dimension(:,:):: plnin,plntopin + real(r_double),allocatable,dimension(:):: afft_save,afft_savein contains @@ -36,6 +40,7 @@ subroutine init_spec_vars(nlat,nlon,nsig) factvml(ii)=1.; factvml(ii1)=zero1 end do end do + factvml(1)=0. ! Set other constants used in transforms @@ -58,17 +63,30 @@ subroutine init_spec_vars(nlat,nlon,nsig) allocate( elonn1(ncd2) ) allocate( eon(ncd2) ) allocate( eontop(jcap+1) ) - allocate( afft(50000+4*imax) ) + allocate( afft_save(50000+4*imax) ) allocate( clat(jb:je) ) allocate( slat(jb:je) ) allocate( wlat(jb:je) ) allocate( pln(ncd2,jb:je) ) allocate( plntop(jcap+1,jb:je) ) + eps(:) = 0 + epstop(:)=0 + enn1(:) = 0 + elonn1(:) = 0 + eon(:) = 0 + eontop(:) = 0 + afft_save(:) = 0 + clat(:) = 0 + slat(:) = 0 + wlat(:) = 0 + pln(:,:) = 0 + plntop(:,:) = 0 + ! Initialize arrays used in transforms call sptranf0(iromb,jcap,idrt,imax,jmax,jb,je, & eps,epstop,enn1,elonn1,eon,eontop, & - afft,clat,slat,wlat,pln,plntop) + afft_save,clat,slat,wlat,pln,plntop) return end subroutine init_spec_vars @@ -104,7 +122,7 @@ end subroutine sptez_s subroutine destroy_spec_vars deallocate(factsml,factvml) - deallocate(eps,epstop,enn1,elonn1,eon,eontop,afft,& + deallocate(eps,epstop,enn1,elonn1,eon,eontop,afft_save,& clat,slat,wlat,pln,plntop) return end subroutine destroy_spec_vars @@ -124,6 +142,10 @@ subroutine sptranf_s(wave,gridn,grids,idir) integer i,j,jj,ij,ijn,ijs,mp real(r_kind),dimension(2*(jcap+1)):: wtop real(r_kind),dimension(imax,2):: g + real(r_double),dimension(50000+4*imax):: afft + +! this is needed for thread safety. + afft = afft_save ! Initialize local variables mp=0 @@ -277,7 +299,8 @@ subroutine jcaptrans(z,fact,z4) implicit none integer j,iiin,iiout,l,m real(r_kind),dimension(nc):: z,fact - real(r_single),dimension(ncin):: z4 + real(r_kind),dimension(ncin):: z4 + !real(r_single),dimension(ncin):: z4 do j=1,nc z(j)=0.0 end do @@ -299,6 +322,691 @@ subroutine jcaptrans(z,fact,z4) return end subroutine jcaptrans +subroutine sptezv_s(waved,wavez,gridu,gridv,idir) +!$$$ subprogram documentation block +! . . . . +! subprogram: sptez_v perform a simple vector spherical transform +! prgmmr: iredell org: np23 date: 1996-02-29 +! +! abstract: this subprogram performs a spherical transform +! between spectral coefficients of divergence and curl +! and a vector field on a global cylindrical grid. +! the wave-space is triangular. +! the grid-space can be either an equally-spaced grid +! (with or without pole points) or a gaussian grid. +! the wave field is in sequential 'ibm order'. +! the grid fiels is indexed east to west, then north to south. +! for more flexibility and efficiency, call sptran. +! subprogram can be called from a multiprocessing environment. +! +! This routine differs from splib routine sptezv in that +! 1) the calling list only contains the in/out arrays and +! flag for the direction in which to transform +! 2) it calls a version of sptranfv that does not invoke +! initialization routines on each entry +! 3) some generality built into the splib version is +! removed in the code below +! +! program history log: +! 1996-02-29 iredell +! 2004-08-23 treadon - adapt splib routine sptezv for gsi use +! 2008-02-01 whitaker - modifications for use in ensemble kalman filter. +! +! input arguments: +! waved - real (2*mx) wave divergence field if idir>0 +! where mx=(maxwv+1)*(maxwv+2)/2 +! wavez - real (2*mx) wave vorticity field if idir>0 +! where mx=(maxwv+1)*(maxwv+2)/2 +! gridu - real (imax,jmax) grid u-wind (e->w,n->s) if idir<0 +! gridv - real (imax,jmax) grid v-wind (e->w,n->s) if idir<0 +! idir - integer transform flag +! (idir>0 for wave to grid, idir<0 for grid to wave) +! +! output arguments: +! waved - real (2*mx) wave divergence field if idir<0 +! where mx=(maxwv+1)*(maxwv+2)/2 +! wavez - real (2*mx) wave vorticity field if idir>0 +! where mx=(maxwv+1)*(maxwv+2)/2 +! gridu - real (imax,jmax) grid u-wind (e->w,n->s) if idir>0 +! gridv - real (imax,jmax) grid v-wind (e->w,n->s) if idir>0 +! +! subprograms called: +! sptranf_v - perform a vector spherical transform +! +! remarks: minimum grid dimensions for unaliased transforms to spectral: +! dimension linear quadratic +! ----------------------- --------- ------------- +! imax 2*maxwv+2 3*maxwv/2*2+2 +! jmax (idrt=4) 1*maxwv+1 3*maxwv/2+1 +! jmax (idrt=0) 2*maxwv+3 3*maxwv/2*2+3 +! jmax (idrt=256) 2*maxwv+1 3*maxwv/2*2+1 +! ----------------------- --------- ------------- +! +! attributes: +! language: fortran 77 +! +!$$$ + implicit none + +! Declare passed variables + integer(i_kind),intent(in):: idir + real(r_kind),dimension(nc),intent(inout):: waved,wavez + real(r_kind),dimension(ijmax),intent(inout):: gridu,gridv + +! Declare local variables + integer(i_kind) i + +! Zero appropriate output array based on direction of transform + if (idir < 0) then + do i=1,nc + waved(i)=0._r_kind + wavez(i)=0._r_kind + end do + elseif (idir > 0) then + do i=1,ijmax + gridu(i)=0._r_kind + gridv(i)=0._r_kind + end do + endif + +! Call spectral <--> grid transform + call sptranf_v(waved,wavez,gridu,gridu,gridv,gridv,idir) + +end subroutine sptezv_s + +subroutine sptranf_v(waved,wavez,gridun,gridus,gridvn,gridvs,idir) +!$$$ subprogram documentation block +! . . . . +! subprogram: sptranf_v perform a vecor spherical transform +! prgmmr: iredell org: np23 date: 1996-02-29 +! +! abstract: this subprogram performs a spherical transform +! between spectral coefficients of divergences and curls +! and vector fields on a global cylindrical grid. +! the wave-space is triangular. +! the grid-space can be either an equally-spaced grid +! (with or without pole points) or a gaussian grid. +! the wave and grid fields may have general indexing, +! but each wave field is in sequential 'ibm order', +! i.e. with zonal wavenumber as the slower index. +! transforms are done in latitude pairs for efficiency; +! thus grid arrays for each hemisphere must be passed. +! if so requested, just a subset of the latitude pairs +! may be transformed in each invocation of the subprogram. +! the transforms are all multiprocessed over latitude except +! the transform from fourier to spectral is multiprocessed +! over zonal wavenumber to ensure reproducibility. +! transform several fields at a time to improve vectorization. +! subprogram can be called from a multiprocessing environment. +! +! This routine differs from splib routine sptranfv in that +! it does not call sptranf0 (an initialization routine). +! +! +! program history log: +! 1996-02-29 iredell +! 1998-12-15 iredell generic fft used +! 2004-08-23 treadon - adapt splib routine sptranfv for gsi use +! 2006-05-03 treadon - remove jc from specmod list since not used +! 2006-07-07 kleist - correct bug in indexing of j=1,2*ncd2 loop +! 2008-02-01 whitaker - modifications for use in ensemble kalman filter. +! +! input arguments: +! waved - real (*) wave divergence fields if idir>0 +! wavez - real (*) wave vorticity fields if idir>0 +! gridun - real (*) n.h. grid u-winds (starting at jb) if idir<0 +! gridus - real (*) s.h. grid u-winds (starting at jb) if idir<0 +! gridvn - real (*) n.h. grid v-winds (starting at jb) if idir<0 +! gridvs - real (*) s.h. grid v-winds (starting at jb) if idir<0 +! idir - integer transform flag +! (idir>0 for wave to grid, idir<0 for grid to wave) +! +! output arguments: +! waved - real (*) wave divergence fields if idir<0 +! [waved=(d(gridu)/dlam+d(clat*gridv)/dphi)/(clat*rerth)] +! wavez - real (*) wave vorticity fields if idir<0 +! [wavez=(d(gridv)/dlam-d(clat*gridu)/dphi)/(clat*rerth)] +! gridun - real (*) n.h. grid u-winds (starting at jb) if idir>0 +! gridus - real (*) s.h. grid u-winds (starting at jb) if idir>0 +! gridvn - real (*) n.h. grid v-winds (starting at jb) if idir>0 +! gridvs - real (*) s.h. grid v-winds (starting at jb) if idir>0 +! +! subprograms called: +! sptranf1 sptranf spectral transform +! spdz2uv compute winds from divergence and vorticity +! spuv2dz compute divergence and vorticity from winds +! +! remarks: +! This routine assumes that splib routine sptranf0 has been +! previously called. sptranf0 initializes arrays needed in +! the transforms. +! +! minimum grid dimensions for unaliased transforms to spectral: +! dimension linear quadratic +! ----------------------- --------- ------------- +! imax 2*maxwv+2 3*maxwv/2*2+2 +! jmax (idrt=4) 1*maxwv+1 3*maxwv/2+1 +! jmax (idrt=0) 2*maxwv+3 3*maxwv/2*2+3 +! jmax (idrt=256) 2*maxwv+1 3*maxwv/2*2+1 +! ----------------------- --------- ------------- +! +! attributes: +! language: fortran 77 +! +!$$$ + implicit none + +! Declare passed variables + integer(i_kind),intent(in):: idir + real(r_kind),dimension(nc):: waved,wavez + real(r_kind),dimension(ijmax):: gridun,gridus,gridvn,gridvs + +! Declare local variables + integer(i_kind) i,j,jj,ijn,ijs + integer(i_kind),dimension(2):: mp + real(r_kind),dimension(ncd2*2,2):: w + real(r_kind),dimension(2*(jcap+1),2):: wtop + real(r_kind),dimension(imax,2,2):: g + real(8),dimension(50000+4*imax):: afft + +! Set parameters + mp=1 +! this is needed for thread safety. + afft = afft_save + +! Transform wave to grid + if(idir > 0) then + call spdz2uv(iromb,jcap,enn1,elonn1,eon,eontop, & + waved,wavez, & + w(1,1),w(1,2),wtop(1,1),wtop(1,2)) + do j=jb,je + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + w(1,1),wtop(1,1),g(1,1,1),idir) + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + w(1,2),wtop(1,2),g(1,1,2),idir) + do i=1,imax + jj = j-jb + ijn = i + jj*jn + ijs = i + jj*js + ioffset + gridun(ijn)=g(i,1,1) + gridus(ijs)=g(i,2,1) + gridvn(ijn)=g(i,1,2) + gridvs(ijs)=g(i,2,2) + + enddo + enddo + +! Transform grid to wave + else + w=0 + wtop=0 + do j=jb,je + if(wlat(j) > 0._r_kind) then + do i=1,imax + jj = j-jb + ijn = i + jj*jn + ijs = i + jj*js + ioffset + + g(i,1,1)=gridun(ijn)/clat(j)**2 + g(i,2,1)=gridus(ijs)/clat(j)**2 + g(i,1,2)=gridvn(ijn)/clat(j)**2 + g(i,2,2)=gridvs(ijs)/clat(j)**2 + enddo + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + w(1,1),wtop(1,1),g(1,1,1),idir) + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + w(1,2),wtop(1,2),g(1,1,2),idir) + endif + enddo + call spuv2dz(iromb,jcap,enn1,elonn1,eon,eontop, & + w(1,1),w(1,2),wtop(1,1),wtop(1,2), & + waved(1),wavez(1)) + endif + + end subroutine sptranf_v + subroutine init_spec_varsin(nlat,nlon,nsig) + implicit none + + integer,intent(in):: nlat,nlon,nsig + integer ii,ii1,l,m,ncpus + real(r_kind) zero1 + +! Set constants +! nc=(jcap+1)*(jcap+2) +! ncin=(jcapin+1)*(jcapin+2) +! ncd2=nc/2 + ncd2in=ncin/2 + +! Allocate more arrays related to transforms +! allocate(factsml(nc),factvml(nc)) +! Set up factsml and factvml +! ii=-1; ii1=0 +! do l=0,jcap +! zero1=float(min(1,l)) +! do m=0,jcap-l +! ii=ii+2; ii1=ii1+2 +! factsml(ii)=1.; factsml(ii1)=zero1 +! factvml(ii)=1.; factvml(ii1)=zero1 +! end do +! end do + +! factvml(1)=0. + +! Set other constants used in transforms +! idrt=4 + imaxin=nlon + jmaxin=nlat-2 + ijmaxin=imaxin*jmaxin + ioffsetin=imaxin*(jmaxin-1) + jnin=imaxin + jsin=-jnin + kwin=2*ncd2in + jbin=1 + jein=(jmaxin+1)/2 +! jc=ncpus() + +! Allocate arrays + allocate( epsin(ncd2in) ) + allocate( epstopin(jcapin+1) ) + allocate( enn1in(ncd2in) ) + allocate( elonn1in(ncd2in) ) + allocate( eonin(ncd2in) ) + allocate( eontopin(jcapin+1) ) + allocate( afft_savein(50000+4*imaxin) ) + allocate( clatin(jbin:jein) ) + allocate( slatin(jbin:jein) ) + allocate( wlatin(jbin:jein) ) + allocate( plnin(ncd2in,jbin:jein) ) + allocate( plntopin(jcapin+1,jbin:jein) ) + + epsin(:) = 0 + epstopin(:)=0 + enn1in(:) = 0 + elonn1in(:) = 0 + eonin(:) = 0 + eontopin(:) = 0 + afft_savein(:) = 0 + clatin(:) = 0 + slatin(:) = 0 + wlatin(:) = 0 + plnin(:,:) = 0 + plntopin(:,:) = 0 + +! Initialize arrays used in transforms + call sptranf0(iromb,jcapin,idrt,imaxin,jmaxin,jbin,jein, & + epsin,epstopin,enn1in,elonn1in,eonin,eontopin, & + afft_savein,clatin,slatin,wlatin,plnin,plntopin) + + return + end subroutine init_spec_varsin + + subroutine sptez_sin(wave,grid,idir) + use kinds, only: r_kind + implicit none + +! Declare passed variables + integer,intent(in):: idir + real(r_kind),dimension(ncin),intent(inout):: wave + real(r_kind),dimension(ijmaxin),intent(inout):: grid + +! Declare local variables + integer i + +! Zero appropriate output array based on direction of transform + if (idir<0) then + do i=1,ncin + wave(i)=0. + end do + elseif (idir>0) then + do i=1,ijmaxin + grid(i)=0. + end do + endif + +! Call spectral <--> grid transform + call sptranf_sin(wave,grid,grid,idir) + + return + end subroutine sptez_sin + + subroutine destroy_spec_varsin +! deallocate(factsml,factvml) + deallocate(epsin,epstopin,enn1in,elonn1in,eonin,eontopin,& + afft_savein,clatin,slatin,wlatin,plnin,plntopin) + return + end subroutine destroy_spec_varsin + + + subroutine sptranf_sin(wave,gridn,grids,idir) + use kinds, only: r_kind + implicit none + +! Declare passed variables + integer,intent(in):: idir + real(r_kind),dimension(ncin),intent(inout):: wave + real(r_kind),dimension(ijmaxin),intent(inout):: gridn + real(r_kind),dimension(ijmaxin),intent(inout):: grids + +! Declare local variables + integer i,j,jj,ij,ijn,ijs,mp + real(r_kind),dimension(2*(jcapin+1)):: wtop + real(r_kind),dimension(imaxin,2):: g + real(r_double),dimension(50000+4*imaxin):: afft + +! this is needed for thread safety. + afft = afft_savein + +! Initialize local variables + mp=0 + + do i=1,2*(jcapin+1) + wtop(i)=0. + end do + +! Transform wave to grid + if(idir.gt.0) then + do j=jbin,jein + call sptranf1(iromb,jcapin,idrt,imaxin,jmaxin,j,j, & + epsin,epstopin,enn1in,elonn1in,eonin,eontopin, & + afft,clatin(j),slatin(j),wlatin(j), & + plnin(1,j),plntopin(1,j),mp, & + wave,wtop,g,idir) + do i=1,imaxin + jj = j-jbin + ijn = i + jj*jnin + ijs = i + jj*jsin + ioffsetin + gridn(ijn)=g(i,1) + grids(ijs)=g(i,2) + enddo + enddo +! Transform grid to wave + else + do j=jbin,jein + if(wlatin(j).gt.0.) then + do i=1,imaxin + jj = j-jbin + ijn = i + jj*jnin + ijs = i + jj*jsin + ioffsetin + g(i,1)=gridn(ijn) + g(i,2)=grids(ijs) + enddo + call sptranf1(iromb,jcapin,idrt,imaxin,jmaxin,j,j, & + epsin,epstopin,enn1in,elonn1in,eonin,eontopin, & + afft,clatin(j),slatin(j),wlatin(j), & + plnin(1,j),plntopin(1,j),mp, & + wave,wtop,g,idir) + endif + enddo + endif + return + end subroutine sptranf_sin + +subroutine sptezv_sin(waved,wavez,gridu,gridv,idir) +!$$$ subprogram documentation block +! . . . . +! subprogram: sptez_v perform a simple vector spherical transform +! prgmmr: iredell org: np23 date: 1996-02-29 +! +! abstract: this subprogram performs a spherical transform +! between spectral coefficients of divergence and curl +! and a vector field on a global cylindrical grid. +! the wave-space is triangular. +! the grid-space can be either an equally-spaced grid +! (with or without pole points) or a gaussian grid. +! the wave field is in sequential 'ibm order'. +! the grid fiels is indexed east to west, then north to south. +! for more flexibility and efficiency, call sptran. +! subprogram can be called from a multiprocessing environment. +! +! This routine differs from splib routine sptezv in that +! 1) the calling list only contains the in/out arrays and +! flag for the direction in which to transform +! 2) it calls a version of sptranfv that does not invoke +! initialization routines on each entry +! 3) some generality built into the splib version is +! removed in the code below +! +! program history log: +! 1996-02-29 iredell +! 2004-08-23 treadon - adapt splib routine sptezv for gsi use +! 2008-02-01 whitaker - modifications for use in ensemble kalman filter. +! +! input arguments: +! waved - real (2*mx) wave divergence field if idir>0 +! where mx=(maxwv+1)*(maxwv+2)/2 +! wavez - real (2*mx) wave vorticity field if idir>0 +! where mx=(maxwv+1)*(maxwv+2)/2 +! gridu - real (imax,jmax) grid u-wind (e->w,n->s) if idir<0 +! gridv - real (imax,jmax) grid v-wind (e->w,n->s) if idir<0 +! idir - integer transform flag +! (idir>0 for wave to grid, idir<0 for grid to wave) +! +! output arguments: +! waved - real (2*mx) wave divergence field if idir<0 +! where mx=(maxwv+1)*(maxwv+2)/2 +! wavez - real (2*mx) wave vorticity field if idir>0 +! where mx=(maxwv+1)*(maxwv+2)/2 +! gridu - real (imax,jmax) grid u-wind (e->w,n->s) if idir>0 +! gridv - real (imax,jmax) grid v-wind (e->w,n->s) if idir>0 +! +! subprograms called: +! sptranf_v - perform a vector spherical transform +! +! remarks: minimum grid dimensions for unaliased transforms to spectral: +! dimension linear quadratic +! ----------------------- --------- ------------- +! imax 2*maxwv+2 3*maxwv/2*2+2 +! jmax (idrt=4) 1*maxwv+1 3*maxwv/2+1 +! jmax (idrt=0) 2*maxwv+3 3*maxwv/2*2+3 +! jmax (idrt=256) 2*maxwv+1 3*maxwv/2*2+1 +! ----------------------- --------- ------------- +! +! attributes: +! language: fortran 77 +! +!$$$ + implicit none + +! Declare passed variables + integer(i_kind),intent(in):: idir + real(r_kind),dimension(ncin),intent(inout):: waved,wavez + real(r_kind),dimension(ijmaxin),intent(inout):: gridu,gridv + +! Declare local variables + integer(i_kind) i + +! Zero appropriate output array based on direction of transform + if (idir < 0) then + do i=1,ncin + waved(i)=0._r_kind + wavez(i)=0._r_kind + end do + elseif (idir > 0) then + do i=1,ijmaxin + gridu(i)=0._r_kind + gridv(i)=0._r_kind + end do + endif + +! Call spectral <--> grid transform + call sptranf_vin(waved,wavez,gridu,gridu,gridv,gridv,idir) + +end subroutine sptezv_sin + +subroutine sptranf_vin(waved,wavez,gridun,gridus,gridvn,gridvs,idir) +!$$$ subprogram documentation block +! . . . . +! subprogram: sptranf_v perform a vecor spherical transform +! prgmmr: iredell org: np23 date: 1996-02-29 +! +! abstract: this subprogram performs a spherical transform +! between spectral coefficients of divergences and curls +! and vector fields on a global cylindrical grid. +! the wave-space is triangular. +! the grid-space can be either an equally-spaced grid +! (with or without pole points) or a gaussian grid. +! the wave and grid fields may have general indexing, +! but each wave field is in sequential 'ibm order', +! i.e. with zonal wavenumber as the slower index. +! transforms are done in latitude pairs for efficiency; +! thus grid arrays for each hemisphere must be passed. +! if so requested, just a subset of the latitude pairs +! may be transformed in each invocation of the subprogram. +! the transforms are all multiprocessed over latitude except +! the transform from fourier to spectral is multiprocessed +! over zonal wavenumber to ensure reproducibility. +! transform several fields at a time to improve vectorization. +! subprogram can be called from a multiprocessing environment. +! +! This routine differs from splib routine sptranfv in that +! it does not call sptranf0 (an initialization routine). +! +! +! program history log: +! 1996-02-29 iredell +! 1998-12-15 iredell generic fft used +! 2004-08-23 treadon - adapt splib routine sptranfv for gsi use +! 2006-05-03 treadon - remove jc from specmod list since not used +! 2006-07-07 kleist - correct bug in indexing of j=1,2*ncd2 loop +! 2008-02-01 whitaker - modifications for use in ensemble kalman filter. +! +! input arguments: +! waved - real (*) wave divergence fields if idir>0 +! wavez - real (*) wave vorticity fields if idir>0 +! gridun - real (*) n.h. grid u-winds (starting at jb) if idir<0 +! gridus - real (*) s.h. grid u-winds (starting at jb) if idir<0 +! gridvn - real (*) n.h. grid v-winds (starting at jb) if idir<0 +! gridvs - real (*) s.h. grid v-winds (starting at jb) if idir<0 +! idir - integer transform flag +! (idir>0 for wave to grid, idir<0 for grid to wave) +! +! output arguments: +! waved - real (*) wave divergence fields if idir<0 +! [waved=(d(gridu)/dlam+d(clat*gridv)/dphi)/(clat*rerth)] +! wavez - real (*) wave vorticity fields if idir<0 +! [wavez=(d(gridv)/dlam-d(clat*gridu)/dphi)/(clat*rerth)] +! gridun - real (*) n.h. grid u-winds (starting at jb) if idir>0 +! gridus - real (*) s.h. grid u-winds (starting at jb) if idir>0 +! gridvn - real (*) n.h. grid v-winds (starting at jb) if idir>0 +! gridvs - real (*) s.h. grid v-winds (starting at jb) if idir>0 +! +! subprograms called: +! sptranf1 sptranf spectral transform +! spdz2uv compute winds from divergence and vorticity +! spuv2dz compute divergence and vorticity from winds +! +! remarks: +! This routine assumes that splib routine sptranf0 has been +! previously called. sptranf0 initializes arrays needed in +! the transforms. +! +! minimum grid dimensions for unaliased transforms to spectral: +! dimension linear quadratic +! ----------------------- --------- ------------- +! imax 2*maxwv+2 3*maxwv/2*2+2 +! jmax (idrt=4) 1*maxwv+1 3*maxwv/2+1 +! jmax (idrt=0) 2*maxwv+3 3*maxwv/2*2+3 +! jmax (idrt=256) 2*maxwv+1 3*maxwv/2*2+1 +! ----------------------- --------- ------------- +! +! attributes: +! language: fortran 77 +! +!$$$ + implicit none +! Declare passed variables + integer(i_kind),intent(in):: idir + real(r_kind),dimension(ncin):: waved,wavez + real(r_kind),dimension(ijmaxin):: gridun,gridus,gridvn,gridvs + +! Declare local variables + integer(i_kind) i,j,jj,ijn,ijs + integer(i_kind),dimension(2):: mp + real(r_kind),dimension(ncd2in*2,2):: w + real(r_kind),dimension(2*(jcapin+1),2):: wtop + real(r_kind),dimension(imaxin,2,2):: g + real(8),dimension(50000+4*imaxin):: afft + +! Set parameters + mp=1 +! this is needed for thread safety. + afft = afft_savein + +! Transform wave to grid + if(idir > 0) then + call spdz2uv(iromb,jcapin,enn1in,elonn1in,eonin,eontopin, & + waved,wavez, & + w(1,1),w(1,2),wtop(1,1),wtop(1,2)) + do j=jbin,jein + call sptranf1(iromb,jcapin,idrt,imaxin,jmaxin,j,j, & + epsin,epstopin,enn1in,elonn1in,eonin,eontopin, & + afft,clatin(j),slatin(j),wlatin(j), & + plnin(1,j),plntopin(1,j),mp, & + w(1,1),wtop(1,1),g(1,1,1),idir) + call sptranf1(iromb,jcapin,idrt,imaxin,jmaxin,j,j, & + epsin,epstopin,enn1in,elonn1in,eonin,eontopin, & + afft,clatin(j),slatin(j),wlatin(j), & + plnin(1,j),plntopin(1,j),mp, & + w(1,2),wtop(1,2),g(1,1,2),idir) + do i=1,imaxin + jj = j-jbin + ijn = i + jj*jnin + ijs = i + jj*jsin + ioffsetin + gridun(ijn)=g(i,1,1) + gridus(ijs)=g(i,2,1) + gridvn(ijn)=g(i,1,2) + gridvs(ijs)=g(i,2,2) + + enddo + enddo + +! Transform grid to wave + else + w=0 + wtop=0 + do j=jbin,jein + if(wlatin(j) > 0._r_kind) then + do i=1,imaxin + jj = j-jbin + ijn = i + jj*jnin + ijs = i + jj*jsin + ioffsetin + + g(i,1,1)=gridun(ijn)/clatin(j)**2 + g(i,2,1)=gridus(ijs)/clatin(j)**2 + g(i,1,2)=gridvn(ijn)/clatin(j)**2 + g(i,2,2)=gridvs(ijs)/clatin(j)**2 + enddo + call sptranf1(iromb,jcapin,idrt,imaxin,jmaxin,j,j, & + epsin,epstopin,enn1in,elonn1in,eonin,eontopin, & + afft,clatin(j),slatin(j),wlatin(j), & + plnin(1,j),plntopin(1,j),mp, & + w(1,1),wtop(1,1),g(1,1,1),idir) + call sptranf1(iromb,jcapin,idrt,imaxin,jmaxin,j,j, & + epsin,epstopin,enn1in,elonn1in,eonin,eontopin, & + afft,clatin(j),slatin(j),wlatin(j), & + plnin(1,j),plntopin(1,j),mp, & + w(1,2),wtop(1,2),g(1,1,2),idir) + endif + enddo + call spuv2dz(iromb,jcapin,enn1in,elonn1in,eonin,eontopin, & + w(1,1),w(1,2),wtop(1,1),wtop(1,2), & + waved(1),wavez(1)) + endif + + end subroutine sptranf_vin + end module specgrid diff --git a/util/NMC_Bkerror/sorc/sstmod.f90 b/util/NMC_Bkerror/sorc/sstmod.f90 index aee393ff2..b16150767 100644 --- a/util/NMC_Bkerror/sorc/sstmod.f90 +++ b/util/NMC_Bkerror/sorc/sstmod.f90 @@ -34,7 +34,8 @@ subroutine sst_stats integer i,j,k,errsst,mype,ilt,iln,idx,istat - real(r_single),dimension(720,360,10):: sstvarsin + real(r_kind),dimension(720,360,10):: sstvarsin + !real(r_single),dimension(720,360,10):: sstvarsin real(r_kind),dimension(360,720):: sstvin,sstcin real(r_kind) linlat(360) @@ -49,16 +50,19 @@ subroutine sst_stats open(errsst,file='berror_sst',form='unformatted',& convert='big_endian',iostat=istat) rewind(errsst) - do k=1,10 - read(errsst) ((sstvarsin(i,j,k),i=1,iln),j=1,ilt) - end do +! do k=1,10 +! read(errsst) ((sstvarsin(i,j,k),i=1,iln),j=1,ilt) +! end do + read(errsst) ((sstvarsin(i,j,1),i=1,iln),j=1,ilt) do j=1,iln do i=1,ilt sstvin(i,j)=sstvarsin(j,i,1) - sstcin(i,j)=sstvarsin(j,i,9) +! sstcin(i,j)=sstvarsin(j,i,9) end do end do + sstcin(:,:)=600.0 !hcl assign some value + ! the sst variances has missing values in it, which need to be filled ! with more realistic values diff --git a/util/NMC_Bkerror/sorc/statsmain.f90 b/util/NMC_Bkerror/sorc/statsmain.f90 index e672515eb..f13710d7d 100644 --- a/util/NMC_Bkerror/sorc/statsmain.f90 +++ b/util/NMC_Bkerror/sorc/statsmain.f90 @@ -14,6 +14,9 @@ program statsmain ! 2009-02-xx kleist perform complete overhaul of MPI usage to use ! subdomain structure of GSI and significanlty reduce ! memory requirements +! 2017-10-25 Razvan Stefanescu (Spire) +! added the capability of reading nemsio files using +! Gael Descombes code ! ! abstract: ! This code computes background error statistics to be used with the @@ -44,14 +47,18 @@ program statsmain smoothdeg,init_defaults,create_grids,destroy_grids,& destroy_variables,rearth,rlats,wgtlats,mype,npe,& create_mapping,destroy_mapping,biasrm,destroy_biasrm,& - vertavg - use specgrid, only: jcap,jcapin,jcapsmooth,init_spec_vars,destroy_spec_vars + vertavg,use_enkf,use_gfs_nemsio,scaling + use specgrid, only: jcap,jcapin,jcapsmooth,init_spec_vars,& + destroy_spec_vars,destroy_spec_varsin use postmod, only: writefiles use comm_mod, only: init_mpi_vars,destroy_mpi_vars implicit none include 'mpif.h' integer k,n,total,numcases,mycases,ierror + integer :: namelist_unit + + character*10 :: variable ! define namelist ! NAMSTAT @@ -64,9 +71,13 @@ program statsmain ! maxcases - maximum number of forecast pairs to process ! hybrid - logical for hybrid vertical coordinate ! smoothdeg - degree of horizontal smoothing to apply in latitudinal direction +! use_gfs_nemsio - if T, NEMS I/O file format is used +! use_enkf - if T, use enkf perturbations. +! scaling - if T, read in scaling.txt and apply to variances namelist/namstat/jcap,jcapin,jcapsmooth,nsig,nlat,nlon,maxcases, & - hybrid,smoothdeg,biasrm,vertavg + hybrid,smoothdeg,biasrm,vertavg,use_gfs_nemsio, & + use_enkf,scaling ! MPI initial setup call mpi_init(ierror) @@ -141,6 +152,7 @@ program statsmain call destroy_grids call destroy_mapping call destroy_spec_vars + if (use_gfs_nemsio) call destroy_spec_varsin call destroy_mpi_vars call destroy_variables if(biasrm) call destroy_biasrm diff --git a/util/NMC_Bkerror/sorc/variables.f90 b/util/NMC_Bkerror/sorc/variables.f90 index ce546bccf..5986f5f9a 100644 --- a/util/NMC_Bkerror/sorc/variables.f90 +++ b/util/NMC_Bkerror/sorc/variables.f90 @@ -12,8 +12,9 @@ module variables integer,allocatable,dimension(:):: na,nb ! from GSI gridmod: - logical hybrid,db_prec,biasrm,vertavg + logical hybrid,db_prec,biasrm,vertavg,use_gfs_nemsio,use_enkf integer nlat,nlon,nsig,dimbig,option,noq,lat1,lon1 + integer nlatin,nlonin integer ntrac5,idvc5,idvm5,idpsfc5,idthrm5 real(r_kind),allocatable,dimension(:):: rlons,ak5,bk5,ck5,cp5 real(r_double),allocatable,dimension(:):: wgtlats,rlats @@ -52,6 +53,8 @@ module variables ! variances real(r_kind),allocatable,dimension(:,:):: sfvar,vpvar,tvar,qvar,ozvar,cvar,nrhvar real(r_kind),allocatable,dimension(:):: psvar + real(r_kind),allocatable,dimension(:):: varscale + logical scaling ! horizontal length scales real(r_kind),allocatable,dimension(:,:):: sfhln,vphln,thln,qhln,ozhln,chln @@ -99,6 +102,42 @@ module variables ! Derived constants parameter(fv = rv/rd-1._r_kind) ! used in virtual temp. equation () + type:: ncepgfs_head + integer:: ivs + integer:: version + real(r_kind) :: fhour + integer:: idate(4) + integer:: nrec + integer:: latb + integer:: lonb + integer:: levs + integer:: jcap + integer:: itrun + integer:: iorder + integer:: irealf + integer:: igen + integer:: latf + integer:: lonf + integer:: latr + integer:: lonr + integer:: ntrac + integer:: icen2 + integer:: iens(2) + integer:: idpp + integer:: idsl + integer:: idvc + integer:: idvm + integer:: idvt + integer:: idrun + integer:: idusr + real(r_kind) :: pdryini + integer:: ncldt + integer:: ixgr + integer:: nvcoord + integer:: idrt + end type ncepgfs_head + + contains subroutine init_defaults @@ -109,12 +148,17 @@ subroutine init_defaults maxcases=10 nlat=258 nlon=512 + nlatin=258 + nlonin=512 hybrid=.false. biasrm=.false. vertavg=.false. smoothdeg=4.0 - dimbig=5000 + dimbig=50000 noq=5 + use_gfs_nemsio=.false. + use_enkf=.false. + scaling=.false. end subroutine init_defaults @@ -210,9 +254,11 @@ end subroutine destroy_grids subroutine destroy_variables deallocate(rlats,rlons) - deallocate(ak5,bk5,ck5,cp5) + deallocate(ak5,bk5,ck5) + if (.not. use_gfs_nemsio) deallocate(cp5) deallocate(coef) deallocate(coriolis) + if (scaling) deallocate(varscale) return end subroutine destroy_variables diff --git a/util/NMC_Bkerror/sorc/variances.f90 b/util/NMC_Bkerror/sorc/variances.f90 index 4f30a9e82..a17fad4b7 100644 --- a/util/NMC_Bkerror/sorc/variances.f90 +++ b/util/NMC_Bkerror/sorc/variances.f90 @@ -5,7 +5,8 @@ subroutine variances(numcases,mype) displs_g,ijn,two,db_prec,istart,ilat1,jstart,npe,& bbiasz,bbiasd,bbiast,bcorrz,bcorrd,bcorrt,bbiasp,bcorrp,& sfvar,vpvar,tvar,qvar,ozvar,cvar,nrhvar,psvar,tcon,vpcon,pscon,& - iglobal,ltosi,ltosj,half,one,ione,two,smoothdeg,vertavg + iglobal,ltosi,ltosj,half,one,ione,two,smoothdeg,vertavg,& + scaling,varscale implicit none include 'mpif.h' @@ -295,6 +296,21 @@ subroutine variances(numcases,mype) call smoothlat(psvar,1,smoothdeg) end if +! Scale the variances with height + + if (scaling .and. mype==mype_work) then + do k=1,nsig + if (varscale(k) /= 1.0) then + sfvar(:,k) = sfvar(:,k) / varscale(k) + vpvar(:,k) = vpvar(:,k) / varscale(k) + tvar(:,k) = tvar(:,k) / varscale(k) + qvar(:,k) = qvar(:,k) / varscale(k) + ozvar(:,k) = ozvar(:,k) / varscale(k) + cvar(:,k) = cvar(:,k) / varscale(k) + endif + enddo + endif + call mpi_bcast(sfvar,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) call mpi_bcast(vpvar,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) call mpi_bcast(tvar,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) diff --git a/util/NMC_Bkerror/sorc/variances3d.f90 b/util/NMC_Bkerror/sorc/variances3d.f90 index f5589cae3..ed35b7ce4 100644 --- a/util/NMC_Bkerror/sorc/variances3d.f90 +++ b/util/NMC_Bkerror/sorc/variances3d.f90 @@ -18,11 +18,11 @@ subroutine variances3d(numcases,mype) ! Global Grid real(r_kind),dimension(iglobal):: work - real(r_single),dimension(nlat,nlon,nsig):: sfg,vpg,tg,qg,ozg,cwg - real(r_single),dimension(nlat,nlon):: psg + real(r_kind),dimension(nlat,nlon,nsig):: sfg,vpg,tg,qg,ozg,cwg + real(r_kind),dimension(nlat,nlon):: psg ! Variables for grads file (re-ordered) - real(r_single),dimension(nlon,nlat,nsig):: sf4,vp4,t4,q4,oz4,cw4 - real(r_single),dimension(nlon,nlat):: ps4 + real(r_kind),dimension(nlon,nlat,nsig):: sf4,vp4,t4,q4,oz4,cw4 + real(r_kind),dimension(nlon,nlat):: ps4 integer(i_kind) i,j,k,n,mype_post,ncfggg,mm1,ierror,iret,i1,i2,kk integer(i_kind) mpi_rtype diff --git a/util/NMC_Bkerror/sorc_aero/Makefile b/util/NMC_Bkerror/sorc_aero/Makefile new file mode 100755 index 000000000..0ab0f720a --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/Makefile @@ -0,0 +1,295 @@ +SHELL=/bin/sh + +#============================================================================== +# +# stats Makefile +# +#----------------------------------------------------------------------------- +# -- Parent make (calls child make) -- +#----------------------------------------------------------------------------- +# Default configuration, possibily redefined in Makefile.conf +# ----------------------------------------------------------- + +SED = sed +DASPERL = /usr/bin/perl +COREROOT = ../../.. +COREBIN = $(COREROOT)/bin +CORELIB = $(COREROOT)/lib +COREINC = $(COREROOT)/include +COREETC = $(COREROOT)/etc + +# ------------- +# General Rules +# ------------- + +CP = /bin/cp -p +MKDIR = /bin/mkdir -p + +# --------- +# Libraries +# --------- +LIBgsi = $(CORELIB)/libgsi.a +LIBsp = $(CORELIB)/libsp.a +LIBw3 = $(CORELIB)/libw3.a +LIBbacio = $(CORELIB)/libbacio.a +LIBmpi = -lmpi + +#------------ +# need to know what compiling options to use +#------------ + +include Makefile.conf + + +# ------------- +# This makefile +# ------------- + + MAKE_FILE = Makefile + + +# ----------- +# Load module +# ----------- + + EXE_FILE = calcstats_aerosol.exe +# EXE_SP_FILE = calcstats_aerosol.sp.exe +# EXE_DP_FILE = calcstats_aerosol.dp.exe + + +# -------------------- +# Installing directory +# -------------------- + + INSTALL_DIR = ../bin + + +# -------- +# Log file +# -------- + + LOG_FILE = log.make.$(EXE_FILE) + + +# --------------- +# Call child make +# --------------- + +"" : + @$(MAKE) -f $(MAKE_FILE) all + + +# ------------ +# Make install +# ------------ + +install: + @echo + @echo '==== INSTALL =================================================' + @if [ -e $(INSTALL_DIR) ]; then \ + if [ ! -d $(INSTALL_DIR) ]; then \ + echo '### Fail to create installing directory ###' ;\ + echo '### Stop the installation ###' ;\ + exit ;\ + fi ;\ + else \ + echo " mkdir -p $(INSTALL_DIR)" ;\ + mkdir -p $(INSTALL_DIR) ;\ + fi + cp $(EXE_FILE) $(INSTALL_DIR) + @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) + + +# ---------- +# Make clean +# ---------- + +clean: + @echo + @echo '==== CLEAN ===================================================' + - rm -f $(EXE_FILE) *.o *.mod *.MOD *.lst + + +#----------------------------------------------------------------------------- +# -- Child make -- +#----------------------------------------------------------------------------- + +# ------------ +# Source files +# ------------ + + SRCSF90C = \ + comm_mod.f90 \ + delvars_aerosol.f90 \ + deter_subdomain.f90 \ + getcases_nems.f90 \ + grdsphdp.f90 \ + horizsc_aerosol.f90 \ + init_commvars.f90 \ + initvars.f90 \ + kinds.F90 \ + mat.f90 \ + postmod.f90 \ + readpairs_aerosol.f90 \ + smoothz.f90 \ + specgrid.f90 \ + statsmain_aerosol.f90 \ + variables.f90 \ + variances_aerosol.f90 \ + vertsc_aerosol.f90 \ + + SRCSF77 = + + SRCSC = + + SRCS = $(SRCSF90C) $(SRCSF77) $(SRCSC) + + +# ------------ +# Object files +# ------------ + + SRCSF90 = ${SRCSF90C:.F90=.f90} + + OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} ${SRCSC:.c=.o} + + +# ----------------------- +# Default compiling rules +# ----------------------- + +.SUFFIXES : .F90 .f90 .f .c + +.F90.o : + @echo + @echo '---> Compiling $<' + $(CF) $(FFLAGS) -c $< + +.f90.o : + @echo + @echo '---> Compiling $<' + $(CF) $(FFLAGS) -c $< + +.c.o : + @echo + @echo '---> Compiling $<' + $(CC) $(CFLAGS) -c $< + + +# ------------ +# Dependencies +# ------------ + +comm_mod.o: kinds.o variables.o +delvars_aerosol.o: kinds.o variables.o +deter_subdomain.o: kinds.o variables.o +getcases_nems.o: kinds.o variables.o +grdsphdp.o: kinds.o variables.o +horizsc_aerosol.o: kinds.o variables.o comm_mod.o specgrid.o postmod.o +init_commvars.o: kinds.o comm_mod.o variables.o +initvars.o: kinds.o specgrid.o variables.o +mat.o: +postmod.o: kinds.o variables.o +readpairs_aerosol.o: kinds.o specgrid.o comm_mod.o variables.o +smoothz.o: +specgrid.o: kinds.o variables.o +statsmain_aerosol.o: postmod.o specgrid.o comm_mod.o kinds.o variables.o +kinds.o: +variables.o: kinds.o +variances_aerosol.o: postmod.o kinds.o variables.o +vertsc_aerosol.o: postmod.o kinds.o variables.o + +# ---- +# Link +# ---- + +$(EXE_FILE) : $(OBJS) + $(LD) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) + +calcstats.x: $(EXE_FILE) + mv $(EXE_FILE) $@ + + +# ------------------------ +# Call compiler and linker +# ------------------------ + +all : + @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode + @echo + @echo '==== COMPILE =================================================' + @$(MAKE) -f $(MAKE_FILE) \ + "FFLAGS=$(FFLAGS_N)" \ + "CFLAGS=$(CFLAGS_N)" \ + $(OBJS) + @echo + @echo '==== LINK ====================================================' + @$(MAKE) -f $(MAKE_FILE) \ + "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ + $(EXE_FILE) + +single : + @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode + @echo + @echo '==== COMPILE =================================================' + @$(MAKE) -f $(MAKE_FILE) \ + "FFLAGS=$(FFLAGS_N)" \ + "CFLAGS=$(CFLAGS_N)" \ + $(OBJS) + @echo + @echo '==== LINK ====================================================' + @$(MAKE) -f $(MAKE_FILE) \ + "LIBS=$(LIBS_N)" "LDFLAGS=$(LDFLAGS_N)" \ + $(EXE_SP_FILE) + +double : + @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode + @echo + @echo '==== COMPILE =================================================' + @$(MAKE) -f $(MAKE_FILE) \ + "FFLAGS=$(FFLAGS_N8)" \ + "CFLAGS=$(CFLAGS_N)" \ + $(OBJS) + @echo + @echo '==== LINK ====================================================' + @$(MAKE) -f $(MAKE_FILE) \ + "LIBS=$(LIBS_N8)" "LDFLAGS=$(LDFLAGS_N)" \ + $(EXE_DP_FILE) + +debug : + @$(MAKE) -f $(MAKE_FILE) "COMP_MODE=$@" check_mode + @echo + @echo '==== COMPILE =================================================' + @$(MAKE) -f $(MAKE_FILE) \ + "FFLAGS=$(FFLAGS_D)" \ + "CFLAGS=$(CFLAGS_D)" \ + $(OBJS) + @echo + @echo '==== LINK ====================================================' + @$(MAKE) -f $(MAKE_FILE) \ + "LIBS=$(LIBS_D)" "LDFLAGS=$(LDFLAGS_N)" \ + $(EXE_FILE) + +check_mode : + @if [ -e $(LOG_FILE) ]; then \ + if [ '$(COMP_MODE)' != `head -n 1 $(LOG_FILE)` ]; then \ + echo ;\ + echo "### COMPILE MODE WAS CHANGED ###" ;\ + make clean ;\ + fi ;\ + else \ + echo ;\ + echo "### NO LOG FILE ###" ;\ + make clean ;\ + fi + @echo $(COMP_MODE) > $(LOG_FILE) + +# ------------------------- +# GMAO Nomenclature/targets +# ------------------------- + +export: $(EXE_FILE) + $(MKDIR) $(COREBIN) + $(CP) $(EXE_FILE) $(COREBIN)/calcstats.x + $(CP) stats.parm.sample $(COREETC)/stats.parm + diff --git a/util/NMC_Bkerror/sorc_aero/Makefile.conf.s4 b/util/NMC_Bkerror/sorc_aero/Makefile.conf.s4 new file mode 100755 index 000000000..46a57d29f --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/Makefile.conf.s4 @@ -0,0 +1,82 @@ +# This config file contains the compile options for compilation +# of the GSI code on the NCEP IBM SP. All production builds +# on NCEP IBM SP are 64-bit + +# ---------------------------------- +# Redefine variables for NCEP IBM SP +# ---------------------------------- +COREINC = $(CORELIB)/incmod +INCsigio = $(COREINC)/sigio_v2.0.1 +LIBsigio = $(CORELIB)/libsigio_v2.0.1.a +INCnemsio = $(COREINC)/nemsio_v2.2.2 +LIBnemsio = $(CORELIB)/libnemsio_v2.2.2.a + +# ---------------------------- +# Fortran compiler and options +# ---------------------------- + + CF = mpif90 + FC = $(CF) + +#--- Normal mode options + + PROF= #-g -pg -qfullpath + #OMP = -openmp + + FFLAGS_F90 = -openmp -fp-model strict -xSSE2 -align rec32byte -assume byterecl -free -traceback -D_REAL4_ -D_LAPACK_ -convert big_endian + FFLAGS_F90_8 = -openmp -fp-model strict -xSSE2 -align rec32byte -assume byterecl -free -traceback -D_REAL8_ -D_LAPACK_ -convert big_endian + + FFLAGS_COM_N = -I ./ -I $(INCsigio) -I $(INCnemsio) -O3 + FFLAGS_COM_N8 = -I ./ -I $(INCsigio) -I $(INCnemsio) -O3 + + FFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) $(PROF) + FFLAGS_N8 = $(FFLAGS_F90_8) $(FFLAGS_COM_N8) $(PROF) + +#--- Debug mode options +# -qflttrap=overflow:zero:enable \ is ok +# -qflttrap=overflow:zero:underflow:enable \ fails + FFLAGS_COM_D = -I ./ -I $(INCcrtm) -I $(INCsfcio) -I $(INCsigio) -I $(INCgfsio) -I $(INCnemsio) \ + -I $(INCnetcdf) -I $(INCw3lib) -O0 \ + -implicitnone -g -debug -ftrapuv -check all -fp-stack-check -fstack-protector -warn + + FFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) + + + +# ---------------------- +# C Compiler and options +# ---------------------- + + CC = gcc + +#--- Normal mode options + + CFLAGS_N = -I. -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -O2 -Dfunder + +#--- Debug mode options + + CFLAGS_D = -I ./ -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -g -Dfunder + + +# ------------------ +# Linker and options +# ------------------ + + LD = $(CF) + +#--- Normal mode options + + LIBS_N = $(LIBsigio) $(LIBnemsio) -L$(CORELIB) -lw3nco_v2.0.6_d -lsp_2.0.2g_4 -lbacio_v2.0.2_4 -mkl + LIBS_N8 = $(LIBsigio) $(LIBnemsio) -L$(CORELIB) -lw3nco_v2.0.6_d -lsp_2.0.2g_d -lbacio_v2.0.2_4 -mkl + + LDFLAGS_N = $(FFLAGS_F90) $(FFLAGS_COM_N) + +#--- Debug mode options + + LIBS_D = $(LIBS_N) + + LDFLAGS_D = $(FFLAGS_F90) $(FFLAGS_COM_D) + +#--- Empty out mpi library definition: embedded in compiler + + LIBmpi = diff --git a/util/NMC_Bkerror/sorc_aero/comm_mod.f90 b/util/NMC_Bkerror/sorc_aero/comm_mod.f90 new file mode 100644 index 000000000..9593f4408 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/comm_mod.f90 @@ -0,0 +1,459 @@ +module comm_mod + use kinds, only: r_kind,i_kind + implicit none + + integer(i_kind) nsig1o + ! comm. array, displacement ... + integer(i_kind),allocatable,dimension(:):: isdsp_g ! for send to nsig1o slabs + integer(i_kind),allocatable,dimension(:):: irdsp_g ! for receive from nsig1o slabs + integer(i_kind),allocatable,dimension(:):: isdsp_s ! for send from nsig1o slabs + integer(i_kind),allocatable,dimension(:):: irdsp_s ! for receive from nsig1o slabs + + ! comm. array, count ... + integer(i_kind),allocatable,dimension(:):: iscnt_g ! for send to nsig1o slabs + integer(i_kind),allocatable,dimension(:):: ircnt_g ! for receive from nsig1o slabs + integer(i_kind),allocatable,dimension(:):: iscnt_s ! for send from nsig1o slabs + integer(i_kind),allocatable,dimension(:):: ircnt_s ! for receive from nsig1o slabs + + integer(i_kind),allocatable,dimension(:):: spec_send ! for receive from nsig1o slabs + integer(i_kind),allocatable,dimension(:):: disp_spec ! for receive from nsig1o slabs + + integer(i_kind),allocatable,dimension(:):: levs_id + integer(i_kind),allocatable,dimension(:):: nvar_id + + +contains + + subroutine init_mpi_vars(nsig,mype) + use variables, only: izero,ione,npe + implicit none + + integer(i_kind),intent(in):: nsig ! number of levels + integer(i_kind),intent(in):: mype ! task identifier + + integer n,vlevs,kk,kchk,mm1,k,varcnt + integer(i_kind) d1s,d2s,d3s,d4s,d5s,s1s,s2s,s3s,s4s,so4s,oc1s,oc2s,bc1s,bc2s + + allocate(iscnt_g(npe),isdsp_g(npe),ircnt_g(npe),& + irdsp_g(npe),iscnt_s(npe),isdsp_s(npe),ircnt_s(npe),& + irdsp_s(npe)) + + allocate(spec_send(npe),disp_spec(npe)) + mm1=mype+ione + +! Initialize slab/subdomain communicators, redefined in +! init_commvars + do n=1,npe + iscnt_g(n) = izero + isdsp_g(n) = izero + ircnt_g(n) = izero + irdsp_g(n) = izero + iscnt_s(n) = izero + isdsp_s(n) = izero + ircnt_s(n) = izero + irdsp_s(n) = izero + spec_send(n) = izero + disp_spec(n) = izero + end do + +! Initialize nsig1o to distribute levs/variables +! as evenly as possible over the tasks + vlevs=(14*nsig) + nsig1o=vlevs/npe + if(mod(vlevs,npe)/=0) nsig1o=nsig1o+1 + +! Allocate nsig1o identifiers + allocate(levs_id(nsig1o),nvar_id(nsig1o)) + +! Distribute evenly over npe tasks +! Add aerosol field here + d1s=1 ; d2s=d1s+nsig ; d3s=d2s+nsig ; d4s=d3s+nsig ; d5s=d4s+nsig + s1s=d5s+nsig ; s2s=s1s+nsig ; s3s=s2s+nsig ; s4s=s3s+nsig ; so4s=s4s+nsig + oc1s=so4s+nsig ; oc2s=oc1s+nsig ; bc1s=oc2s+nsig ; bc2s=bc1s+nsig + +! Need to use a variable to know which tasks have a full nsig1o +! array, and which one have the last level irrelevant + if (mod((14*nsig),npe)==izero) then + kchk=npe + else + kchk=mod((nsig*14),npe) + end if + + nvar_id=izero + levs_id=izero +! Define which variable/level each task has for the +! global slabs (levs_id,nvar_id) + varcnt=izero + do n=1,npe + if(n.le.kchk) then + kk=nsig1o + else + kk=nsig1o-1 + end if + do k=1,kk + varcnt=varcnt+1 + if (n==mm1) then + if (varcnt.lt.d2s) then ! for dust1 + nvar_id(k)=1 + levs_id(k)=varcnt + else if (varcnt.ge.d2s .and. varcnt.lt.d3s) then ! for dust2 + nvar_id(k)=2 + levs_id(k)=varcnt-d2s+1 + else if (varcnt.ge.d3s .and. varcnt.lt.d4s) then ! for dust3 + nvar_id(k)=3 + levs_id(k)=varcnt-d3s+1 + else if (varcnt.ge.d4s .and. varcnt.lt.d5s) then ! for dust4 + nvar_id(k)=4 + levs_id(k)=varcnt-d4s+1 + else if (varcnt.ge.d5s .and. varcnt.lt.s1s) then ! for dust5 + nvar_id(k)=5 + levs_id(k)=varcnt-d5s+1 + else if (varcnt.ge.s1s .and. varcnt.lt.s2s) then ! for seas1 + nvar_id(k)=6 + levs_id(k)=varcnt-s1s+1 + else if (varcnt.ge.s2s .and. varcnt.lt.s3s) then ! for seas2 + nvar_id(k)=7 + levs_id(k)=varcnt-s2s+1 + else if (varcnt.ge.s3s .and. varcnt.lt.s4s) then ! for seas3 + nvar_id(k)=8 + levs_id(k)=varcnt-s3s+1 + else if (varcnt.ge.s4s .and. varcnt.lt.so4s) then ! for seas4 + nvar_id(k)=9 + levs_id(k)=varcnt-s4s+1 + else if (varcnt.ge.so4s .and. varcnt.lt.oc1s) then ! for sulf + nvar_id(k)=10 + levs_id(k)=varcnt-so4s+1 + else if (varcnt.ge.oc1s .and. varcnt.lt.oc2s) then ! for oc1 + nvar_id(k)=11 + levs_id(k)=varcnt-oc1s+1 + else if (varcnt.ge.oc2s .and. varcnt.lt.bc1s) then ! for oc2 + nvar_id(k)=12 + levs_id(k)=varcnt-oc2s+1 + else if (varcnt.ge.bc1s .and. varcnt.lt.bc2s) then ! for bc1 + nvar_id(k)=13 + levs_id(k)=varcnt-bc1s+1 + else ! for bc2 + nvar_id(k)=14 + levs_id(k)=varcnt-bc2s+1 + end if ! end if for varcnt + end if ! end if for task id + end do ! enddo over levs + end do ! enddo over npe + +! do k=1,nsig1o +! write(300+mype,*) 'COMM-MOD: k,nvar_id,levs_id = ',k,nvar_id(k),levs_id(k) +! end do + + return + end subroutine init_mpi_vars + + subroutine destroy_mpi_vars + deallocate(iscnt_g,isdsp_g,ircnt_g,& + irdsp_g,iscnt_s,isdsp_s,ircnt_s,& + irdsp_s) + deallocate(spec_send,disp_spec) + deallocate(levs_id,nvar_id) + return + end subroutine destroy_mpi_vars + + subroutine reorder_post(work,k_in) + use kinds, only: r_kind + use variables, only: zero,ijn,iglobal,npe + implicit none + + integer(i_kind), intent(in) :: k_in ! number of levs in work array + real(r_kind),dimension(iglobal*k_in),intent(inout):: work ! array to reorder + integer(i_kind) iloc,iskip,i,k,n + real(r_kind),dimension(iglobal,k_in):: temp + +! Zero out temp array +! do k=1,k_in +! do i=1,iglobal +! temp(i,k)=zero +! end do +! end do + +! Load temp array in desired order + do k=1,k_in + iskip=0 + iloc=0 + do n=1,npe + if (n/=1) then + iskip=iskip+ijn(n-1)*k_in + end if + do i=1,ijn(n) + iloc=iloc+1 + temp(iloc,k)=work(i + iskip + (k-1)*ijn(n)) + end do + end do + end do + +! Load the temp array back into work + iloc=0 + do k=1,k_in + do i=1,iglobal + iloc=iloc+1 + work(iloc)=temp(i,k) + end do + end do + + return + end subroutine reorder_post + + subroutine reorder_pre(work,k_in) + use kinds, only: r_kind + use variables, only: zero,ijn,iglobal,npe + implicit none + + integer(i_kind), intent(in) :: k_in ! number of levs in work array + + real(r_kind),dimension(iglobal,k_in),intent(inout):: work + + integer(i_kind) iloc,iskip,i,k,n + real(r_kind),dimension(iglobal*k_in):: temp + +! Load temp array in order of subdomains + iloc=0 + iskip=0 + do n=1,npe + do k=1,k_in + do i=1,ijn(n) + iloc=iloc+1 + temp(iloc)=work(iskip+i,k) + end do + end do + iskip=iskip+ijn(n) + end do + +! Now load the tmp array back into work + iloc=0 + do k=1,k_in + do i=1,iglobal + iloc=iloc+1 + work(i,k)=temp(iloc) + end do + end do + + return + end subroutine reorder_pre + + + subroutine vectosub(fld_in,nz,fld_out) + use kinds, only: r_kind + use variables, only: lat1,lon1 + implicit none + + integer(i_kind), intent(in) :: nz ! number of levs in subdomain array + real(r_kind),dimension(lat1*lon1*nz),intent(in):: fld_in ! subdomain array + ! in vector form + + real(r_kind),dimension(lat1,lon1,nz),intent(out):: fld_out ! three dimensional + ! subdomain variable array +!------------------------------------------------------------------------- + + integer(i_kind) i,j,k,iloc + + iloc=0 + do k=1,nz + do j=1,lon1 + do i=1,lat1 + iloc=iloc+1 + fld_out(i,j,k)=fld_in(iloc) + end do + end do + end do + + return + end subroutine vectosub + + subroutine reload(work_in,work_out) + use kinds, only: r_kind + use variables, only: lat1,lon1,nsig + implicit none + + real(r_kind),dimension(lat1*lon1,nsig),intent(in):: work_in ! 2-d array + real(r_kind),dimension(lat1,lon1,nsig),intent(out) :: work_out ! 3-d array + + integer(i_kind) i,j,k,ij + + do k=1,nsig + ij=0 + do j=1,lon1 + do i=1,lat1 + ij=ij+1 + work_out(i,j,k)=work_in(ij,k) + end do + end do + end do + return + end subroutine reload + + subroutine sub2grid(workout,d1,d2,d3,d4,d5, & + s1,s2,s3,s4,so4,oc1,oc2,bc1,bc2) + use kinds, only: r_kind,i_kind + use variables, only: iglobal,lat1,lon1,nlat,nlon,nsig,& + ltosi,ltosj,zero,db_prec + implicit none + include 'mpif.h' + +! Passed variables + real(r_kind),dimension(lat1,lon1,nsig),intent(in):: d1,d2,d3,d4,d5, & + s1,s2,s3,s4,so4,oc1,oc2,bc1,bc2 + real(r_kind),dimension(nlat,nlon,nsig1o),intent(out):: workout + +! Declare local variables + integer(i_kind) j,k,l,ni1,ni2,ierror,mpi_rtype,displ,i,npt + integer(i_kind) d1s,d2s,d3s,d4s,d5s,s1s,s2s,s3s,s4s,so4s,oc1s,oc2s,bc1s,bc2s + real(r_kind),dimension(lat1*lon1*(nsig*14)):: vector + real(r_kind),dimension(iglobal,nsig1o):: work1 ! contain nsig1o slab of any variables + + if (db_prec) then + mpi_rtype=mpi_real8 + else + mpi_rtype=mpi_real4 + end if + +! zero out work arrays + do k=1,nsig1o + do j=1,iglobal + work1(j,k)=zero + end do + end do + +! Load xhatsm with appropriate elements + displ=lat1*lon1 + d1s=1 + d2s=d1s+(displ*nsig) + d3s=d2s+(displ*nsig) + d4s=d3s+(displ*nsig) + d5s=d4s+(displ*nsig) + s1s=d5s+(displ*nsig) + s2s=s1s+(displ*nsig) + s3s=s2s+(displ*nsig) + s4s=s3s+(displ*nsig) + so4s=s4s+(displ*nsig) + oc1s=so4s+(displ*nsig) + oc2s=oc1s+(displ*nsig) + bc1s=oc2s+(displ*nsig) + bc2s=bc1s+(displ*nsig) + + + npt=0 + do k=1,nsig + do j=1,lon1 + do i=1,lat1 + vector(d1s+npt)=d1(i,j,k) + vector(d2s+npt)=d2(i,j,k) + vector(d3s+npt)=d3(i,j,k) + vector(d4s+npt)=d4(i,j,k) + vector(d5s+npt)=d5(i,j,k) + vector(s1s+npt)=s1(i,j,k) + vector(s2s+npt)=s2(i,j,k) + vector(s3s+npt)=s3(i,j,k) + vector(s4s+npt)=s4(i,j,k) + vector(so4s+npt)=so4(i,j,k) + vector(oc1s+npt)=oc1(i,j,k) + vector(oc2s+npt)=oc2(i,j,k) + vector(bc1s+npt)=bc1(i,j,k) + vector(bc2s+npt)=bc2(i,j,k) + npt=npt+1 + end do + end do + end do + +! send subdomain vector to global slabs + call mpi_alltoallv(vector(1),iscnt_g,isdsp_g,mpi_rtype,& + work1(1,1),ircnt_g,irdsp_g,mpi_rtype,& + mpi_comm_world,ierror) + +! reorder work1 array post communication + call reorder_post(work1,nsig1o) + + do k=1,nsig1o + do l=1,iglobal + ni1=ltosi(l); ni2=ltosj(l) + workout(ni1,ni2,k)=work1(l,k) + end do + end do + + return + end subroutine sub2grid + + subroutine grid2sub(workin,d1,d2,d3,d4,d5, & + s1,s2,s3,s4,so4,oc1,oc2,bc1,bc2) + use kinds, only: r_kind,i_kind + use variables, only: iglobal,lat1,lon1,nlat,nlon,nsig,& + ltosi,ltosj,zero,db_prec + implicit none + include 'mpif.h' + +! Passed variables + real(r_kind),dimension(nlat,nlon,nsig1o),intent(in):: workin + real(r_kind),dimension(lat1,lon1,nsig),intent(out):: d1,d2,d3,d4,d5, & + s1,s2,s3,s4,so4,oc1,oc2,bc1,bc2 + +! Declare local variables + integer(i_kind) j,k,l,ni1,ni2,ierror,mpi_rtype,i,npt,displ + integer(i_kind) d1s,d2s,d3s,d4s,d5s,s1s,s2s,s3s,s4s,so4s,oc1s,oc2s,bc1s,bc2s + + real(r_kind),dimension(lat1*lon1*(nsig*14)):: vector + real(r_kind),dimension(iglobal,nsig1o):: work1 ! contain nsig1o slab of any variables + + if (db_prec) then + mpi_rtype=mpi_real8 + else + mpi_rtype=mpi_real4 + end if + +! Transfer input array to local work array + do k=1,nsig1o + do l=1,iglobal + ni1=ltosi(l); ni2=ltosj(l) + work1(l,k)=workin(ni1,ni2,k) + end do + end do + + call reorder_pre(work1,nsig1o) + +! send global slabs to subdomains + call mpi_alltoallv(work1(1,1),iscnt_s,isdsp_s,& + mpi_rtype,vector(1),ircnt_s,irdsp_s,& + mpi_rtype,mpi_comm_world,ierror) + +! Define start point of array for each variable + displ=lat1*lon1 + d1s=1 + d2s=d1s+(displ*nsig) + d3s=d2s+(displ*nsig) + d4s=d3s+(displ*nsig) + d5s=d4s+(displ*nsig) + s1s=d5s+(displ*nsig) + s2s=s1s+(displ*nsig) + s3s=s2s+(displ*nsig) + s4s=s3s+(displ*nsig) + so4s=s4s+(displ*nsig) + oc1s=so4s+(displ*nsig) + oc2s=oc1s+(displ*nsig) + bc1s=oc2s+(displ*nsig) + bc2s=bc1s+(displ*nsig) + +! load the received subdomain vector + call vectosub(vector(d1s),nsig,d1) + call vectosub(vector(d2s),nsig,d2) + call vectosub(vector(d3s),nsig,d3) + call vectosub(vector(d4s),nsig,d4) + call vectosub(vector(d5s),nsig,d5) + call vectosub(vector(s1s),nsig,s1) + call vectosub(vector(s2s),nsig,s2) + call vectosub(vector(s3s),nsig,s3) + call vectosub(vector(s4s),nsig,s4) + call vectosub(vector(so4s),nsig,so4) + call vectosub(vector(oc1s),nsig,oc1) + call vectosub(vector(oc2s),nsig,oc2) + call vectosub(vector(bc1s),nsig,bc1) + call vectosub(vector(bc2s),nsig,bc2) + + return + end subroutine grid2sub + +end module comm_mod diff --git a/util/NMC_Bkerror/sorc_aero/configure b/util/NMC_Bkerror/sorc_aero/configure new file mode 100755 index 000000000..efc913c55 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/configure @@ -0,0 +1,91 @@ +#!/bin/sh +# +# Creates configuration Makefile. Before attempting to make anything +# in this directory, enter +# +# ./configure +# +# !REVISION HISTORY +# +# 09oct97 da Silva Initial code. +# 19oct97 da Silva Simplified. +# 22oct97 Jing Guo Converted to libpsas.a environment +# - special configuration for CRAY +# - fool-prove configuration +# - additional information +# 23dec99 da Silva Modified error messages. +# +#..................................................................... + +c=`basename $0 .sh` + +type=${1:-"unknown"} +echo $type + + +# If type=clean, remove soft links and exit +# ----------------------------------------- +if [ "$type" = "clean" ]; then + if [ -r makefile ]; then + echo "$c: remove makefile" 1>&2 + rm makefile + fi + if [ -r Makefile.conf ]; then + echo "$c: remove Makefile.conf" 1>&2 + rm Makefile.conf + fi + exit +fi + + +# Set makeconf based on user input +# --------------------------------------- +makeconf="Makefile.conf.$type" + + +# Node specific configuration +# --------------------------------------- +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" +fi + +# Machine specific +# ---------------- +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + machine="`uname -m | awk '{print $1}'`" + machine=`echo $machine | tr "[a-z]" "[A-Z]"` + compiler=$F90 + makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" + makeconf="${makeconf}.${machine}.${compiler}" +fi + +# Site specific configuration +# --------------------------- +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" +fi + +# if the OS is UNICOS, it does not follow the convention +# ------------------------------------------------------ +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + mech="`uname -m | awk '{print $1}'`" + if [ "${mech}" = CRAY ]; then + makeconf="Makefile.conf.UNICOS" + fi +fi + +# Create soft link for Makefile.conf +# ------------------------------------------------------ +if [ -r Makefile.conf ]; then + echo "$c: remove Makefile.conf" 1>&2 + rm Makefile.conf +fi +ln -s ${makeconf} Makefile.conf + +echo "$c: using ${makeconf} in `pwd`" 1>&2 + +#. diff --git a/util/NMC_Bkerror/sorc_aero/delvars_aerosol.f90 b/util/NMC_Bkerror/sorc_aero/delvars_aerosol.f90 new file mode 100644 index 000000000..201ce9fff --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/delvars_aerosol.f90 @@ -0,0 +1,46 @@ +subroutine delvars_aerosol(d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a, & + d1b,d2b,d3b,d4b,d5b,s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b,mype) + use kinds, only: r_kind,r_single,i_kind + use variables,only: nlat,nlon,nsig,lat1,lon1,zero,biasrm,& + bbiasz,bbiasd,bbiast,bcorrz,bcorrd,bcorrt,bbiasp,bcorrp,& + half,vertavg,istart + implicit none + + real(r_kind),dimension(lat1,lon1,nsig),intent(inout):: d1a,d2a,d3a,d4a,d5a, & + s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a + real(r_kind),dimension(lat1,lon1,nsig),intent(inout):: d1b,d2b,d3b,d4b,d5b, & + s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b + integer(i_kind),intent(in):: mype + + real(r_kind) r025 + integer(i_kind) i,j,k,m,ix,mm1 + + mm1=mype+1 + + if (mype==0) write(6,*) 'delvars_aerosol' + + do k=1,nsig + do j=1,lon1 + do i=1,lat1 + d1a(i,j,k) = d1a(i,j,k)-d1b(i,j,k) + d2a(i,j,k) = d2a(i,j,k)-d2b(i,j,k) + d3a(i,j,k) = d3a(i,j,k)-d3b(i,j,k) + d4a(i,j,k) = d4a(i,j,k)-d4b(i,j,k) + d5a(i,j,k) = d5a(i,j,k)-d5b(i,j,k) + s1a(i,j,k) = s1a(i,j,k)-s1b(i,j,k) + s2a(i,j,k) = s2a(i,j,k)-s2b(i,j,k) + s3a(i,j,k) = s3a(i,j,k)-s3b(i,j,k) + s4a(i,j,k) = s4a(i,j,k)-s4b(i,j,k) + so4a(i,j,k) = so4a(i,j,k)-so4b(i,j,k) + oc1a(i,j,k) = oc1a(i,j,k)-oc1b(i,j,k) + oc2a(i,j,k) = oc2a(i,j,k)-oc2b(i,j,k) + bc1a(i,j,k) = bc1a(i,j,k)-bc1b(i,j,k) + bc2a(i,j,k) = bc2a(i,j,k)-bc2b(i,j,k) + end do + end do + end do + + return +end subroutine delvars_aerosol + + diff --git a/util/NMC_Bkerror/sorc_aero/deter_subdomain.f90 b/util/NMC_Bkerror/sorc_aero/deter_subdomain.f90 new file mode 100755 index 000000000..7c04da59a --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/deter_subdomain.f90 @@ -0,0 +1,65 @@ +subroutine deter_subdomain(mype) + use kinds, only: r_kind,i_kind + use variables, only: lon1,lat1,nlon,nlat,ilat1,istart,jlon1,jstart,npe + implicit none + +! Declare passed variables + integer(i_kind),intent(in):: mype + +! Declare local variables + integer(i_kind) npts,nrnc,iinum,iileft,jrows,jleft,k,i,jjnum + integer(i_kind) j,mm1,iicnt,ipts,jjleft + integer(i_kind),dimension(npe+1):: iiend,jjend,iistart + real(r_kind):: anperpe + +!************************************************************************ +! Compute number of points on full grid and target number of +! point per mpi task (pe) + npts=nlat*nlon + anperpe=float(npts)/float(npe) + +! Start with square subdomains + nrnc=sqrt(anperpe) + iinum=nlon/nrnc + if (iinum==0) iinum=1 + iicnt=nlon/iinum + iileft=nlon-iicnt*iinum + jrows=npe/iinum + jleft=npe-jrows*iinum + +! Adjust subdomain boundaries + k=0 + istart=1 + jstart=1 + iistart(1)=1 + do i=1,iinum + ipts = iicnt + if(i <= iileft)ipts=ipts+1 + iiend(i)=iistart(i)+ipts-1 + iistart(i+1)=iiend(i)+1 + jjnum=jrows + if(i <= jleft)jjnum=jrows+1 + do j=1,jjnum + k=k+1 + jlon1(k)=ipts + jstart(k)= iistart(i) + ilat1(k)=nlat/jjnum + jjleft=nlat-ilat1(k)*jjnum + if(j <= jjleft)ilat1(k)=ilat1(k)+1 + if(j > 1)istart(k)=jjend(j-1)+1 + jjend(j)=istart(k)+ilat1(k)-1 + + if(mype == 0) & + write(6,100) k-1,istart(k),jstart(k),ilat1(k),jlon1(k) + end do + end do +100 format('DETER_SUBDOMAIN: task,istart,jstart,ilat1,jlon1=',6(i6,1x)) + + +! Set number of latitude and longitude for given subdomain + mm1=mype+1 + lat1=ilat1(mm1) + lon1=jlon1(mm1) + + return +end subroutine deter_subdomain diff --git a/util/NMC_Bkerror/sorc_aero/getcases_nems.f90 b/util/NMC_Bkerror/sorc_aero/getcases_nems.f90 new file mode 100644 index 000000000..dec1318cc --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/getcases_nems.f90 @@ -0,0 +1,174 @@ +subroutine getcases_nems(numcases,mype) +! This routine gets the names and number of available +! forecast pairs + use kinds, only: r_single,r_double,r_kind, i_kind + use variables, only: ak5,bk5,ck5,maxcases,nlat,nlon,nsig,dimbig,hybrid,& + filename,na,nb,zero,idpsfc5,idvm5,idthrm5,idvc5,ntrac5,cp5, & + r60,r3600 +!>swei + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close, & + nemsio_gfile,nemsio_getfilehead +!2. +! Output: +! A is the vector of NA A-coefficients, A(1), .. A(NA) +! B is the vector of NB B-coefficients, B(1), ...B(NB) +! (For a Lagrange scheme B(1) = -B(2) = 1/("delta sigma".) +! +! WORK is an array of work-space used for the intermediate +! calculations - it contains nothing of interest on input or output. +! It must be given a size of at least 2*(NA+NB)*(NA+NB+1) in the +! routine that calls this one (it is the same as in DFCO except now +! using r_double precision) +! +! Differencing: +! The only changes from the case of quadrature are that: +! Z0 is the coordinate of the particular target point, which is +! no longer arbitrary; +! ZA are coordinates of TARGET template point(s); +! ZB are coordinates of SOURCE template points; +! A is the vector of NA A-coefficients; +! B is the vector of NB (=ND) D-coefficients +! (For a Lagrange scheme NA=1 and, trivially, A(1) = 1. ) +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_double + use variables, only: zero,one + implicit none + +! Declare passed variables + integer,intent(in):: na,nb + real(r_double),intent(in):: z0 + real(r_double),dimension(*),intent(in):: za,zb + real(r_double),dimension(*),intent(out):: work,a,b + +! Declare local variables + integer nc,ncs,ncsp,j,iw,i + real(r_double) p,z + + nc=na+nb + ncs=nc*nc + ncsp=ncs+1 + do j=1,na + iw=1+(j-1)*nc + work(iw)=one + work(iw+1)=zero + work(iw+2)=one + enddo + do j=1,nb + iw=1+(j+na-1)*nc + work(iw)=zero + work(iw+1)=one + enddo + do j=1,na + z=za(j)-z0 + p=one + do i=4,nc + p=p*z + work(i+(j-1)*nc)=p*(i-2) + enddo + enddo + do j=1,nb + z=zb(j)-z0 + p=one + do i=3,nc + p=p*z + work(i+(j+na-1)*nc)=-p + enddo + enddo + work(ncsp)=one + do i=2,nc + work(ncs+i)=zero + enddo + +! Find the following routine qlinvmv (a linear equation solver) amongst +! all the other basic matrix routines (here, the r_double precision +! version is used). + call dlinvmm(work,work(ncsp),nc,1,nc,nc) + do i=1,na + a(i)=work(ncs+i) + enddo + do i=1,nb + b(i)=work(ncs+na+i) + enddo + return + end subroutine dfcd + + subroutine aldub(a,n,nbh1,nbh2,na) +!$$$ subprogram documentation block +! . . . . +! subprogram: aldub ldu decomposition +! prgmmr: purser, r.j. org: np20 date: 1994-01-01 +! +! abstract: This routine computes the (L)*(D**-1)*(U) decomposition +! of asymmetric band-matrix compact differencing on +! a spherical grid. +! +! program history log: +! 1994-01-01 purser +! 2004-06-21 treadon - update documentation +! 2004-07-28 treadon - add only to module use, add intent in/out +! +! input argument list: +! "a" - asymmetric band matrix +! n - number of rows assumed for A and for V +! nbh1 - left half-bandwidth of fortran array A +! nbh2 - right half-bandwidth of fortran array A +! na - first fortran dimension of A +! +! output argument list: +! "a" - contains the (L)*(D**-1)*(U) factorization of the +! input matrix, where +! (L) is lower triangular with unit main diagonal +! (D) is a diagonal matrix +! (U) is upper triangular with unit main diagonal +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_double + use variables, only: zero,one + implicit none + +! Declare passed variables + integer,intent(in):: n,nbh1,nbh2,na + real(r_double),dimension(na,-nbh1:nbh2),intent(inout):: a + +! Declare local variables + integer j,jp,i,k,imost,jmost + real(r_double) ajj,aij,ajji + + do j=1,n + imost=min(n,j+nbh1) + jmost=min(n,j+nbh2) + jp=j+1 + ajj=a(j,0) + if(ajj.eq.zero)then + write(6,*)'ALDUB: ***ERROR***' + write(6,'(" FAILURE: matrix requires pivoting or is singular")') +!! call stop2(63) + STOP + endif + ajji=one/ajj + a(j,0)=ajji + do i=jp,imost + aij=ajji*a(i,j-i) + a(i,j-i)=aij + do k=jp,jmost + a(i,k-i)=a(i,k-i)-aij*a(j,k-j) + enddo + enddo + do k=jp,jmost + a(j,k-j)=ajji*a(j,k-j) + enddo + enddo + return + end subroutine aldub + + subroutine dlinvmm(a,b,m,mm,na,nb) +!$$$ subprogram documentation block +! . . . . +! subprogram: dlinvmm invert linear systems +! prgmmr: purser, r.j. org: np20 date: 1993-01-01 +! +! abstract: This routine inverts linear systems sharing the same square +! system matrix in R_DOUBLE PRECISION. +! +! program history log: +! 1993-01-01 purser +! 2004-06-21 treadon - update documentation +! 2004-07-28 treadon - add only to module use, add intent in/out +! +! input argument list: +! "a" - square system matrix +! "b" - right-hands-sides +! m - degree of (active part of) b and a +! mm - number of right-hand-side vectors (active columns of b) +! na - first fortran dimension of a +! nb - first fortran dimension of b +! +! output argument list: +! "a" - L-D-U factorization of input matrix "a" +! "b" - matrix solution of vectors +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_double + implicit none + +! Declare passed variables + integer,intent(in):: m,mm,na,nb + real(r_double),dimension(na,*),intent(inout):: a + real(r_double),dimension(nb,*),intent(inout):: b + +! Declare local parameters + integer,parameter:: nn = 500 + +! Declare local variables + integer,dimension(nn):: ipiv + real(r_double) d + + call dlufm(a,ipiv,d,m,na) + call dlubmm(a,b,ipiv,m,mm,na,nb) + return + end subroutine dlinvmm + + subroutine dlufm(a,ipiv,d,m,na) +!$$$ subprogram documentation block +! . . . . +! subprogram: dlufm perform l-u decomposition +! prgmmr: purser, r.j. org: np20 date: 1993-01-01 +! +! abstract: This routine performs l-u decomposition of square matrix +! "a" in place with partial pivoting in R_DOUBLE PRECISION. +! +! program history log: +! 1993-01-01 purser +! 2004-06-21 treadon - update documentation +! 2004-07-28 treadon - add only to module use, add intent in/out +! +! input argument list: +! "a" - square matrix to be factorized +! m - degree of (active part of) a +! na - first fortran dimension of a +! +! output argument list: +! "a" - L-U factorization of input matrix "a" +! ipiv - array encoding the pivoting sequence +! d - indicator for possible sign change of determinant +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_double + use variables, only: zero,one + implicit none + +! Declare passed variables + integer,intent(in):: m,na + integer,dimension(*),intent(out):: ipiv + real(r_double),intent(out):: d + real(r_double),dimension(na,*),intent(inout):: a + +! Declare local variables + integer j,jp,ibig,jm,i,k + real(r_double) ajj,aij,ajji,t,abig,aa + + d=one + ipiv(m)=m + do j=1,m-1 + jp=j+1 + abig=abs(a(j,j)) + ibig=j + do i=jp,m + aa=abs(a(i,j)) + if(aa.gt.abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig.ne.j)then + d=-d + do k=1,m + t=a(j,k) + a(j,k)=a(ibig,k) + a(ibig,k)=t + enddo + endif + ajj=a(j,j) + if(ajj.eq.zero)then + jm=j-1 + write(6,*)'DLUFM: ***ERROR***' + write(6,'("DLUFM: failure due to singular matrix,r, rank=",i3)') jm +!! call stop2(64) + STOP + endif + ajji=one/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + do k=jp,m + a(i,k)=a(i,k)-aij*a(j,k) + enddo + enddo + enddo + return + end subroutine dlufm + + subroutine dlubmm(a,b,ipiv,m,mm,na,nb) +!$$$ subprogram documentation block +! . . . . +! subprogram: dlubmm invert matrix +! prgmmr: purser, r.j. org: np20 date: 1993-01-01 +! +! abstract: This routine inverts matrix "a" +! +! program history log: +! 1993-01-01 purser +! 2004-06-21 treadon - update documentation +! 2004-07-28 treadon - add only to module use, add intent in/out +! +! input argument list: +! "a" - square matrix to be factorized +! m - degree of (active part of) a +! mm - number of columns (active part of) b +! na - first fortran dimension of a +! nb - first fortran dimension of b +! ipiv - array encoding the pivoting sequence +! +! output argument list: +! "b" - matrix solution of vectors +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_double + implicit none + +! Declare passed variables + integer,intent(in):: m,mm,na,nb + integer,dimension(*),intent(in):: ipiv + real(r_double),dimension(na,*),intent(in):: a + real(r_double),dimension(nb,*),intent(out):: b + +! Declare local variables + integer k,i,l,j + real(r_double) s + + do k=1,mm !loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + do j=1,i-1 + s=s-a(i,j)*b(j,k) + enddo + b(i,k)=s + enddo + do i=m,1,-1 + s=b(i,k) + do j=i+1,m + s=s-a(i,j)*b(j,k) + enddo + b(i,k)=s/a(i,i) + enddo + enddo + return + end subroutine dlubmm diff --git a/util/NMC_Bkerror/sorc_aero/horizsc_aerosol.f90 b/util/NMC_Bkerror/sorc_aero/horizsc_aerosol.f90 new file mode 100644 index 000000000..1d7c62764 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/horizsc_aerosol.f90 @@ -0,0 +1,475 @@ +subroutine horizsc_aerosol(numcases,mype) + use kinds, only: r_kind,i_kind + use postmod, only: smoothlat + use variables,only: nlat,nlon,nsig,lat1,lon1,zero,& + displs_g,ijn,db_prec,filunit1,filunit2,npe,& + d1hln,d2hln,d3hln,d4hln,d5hln,s1hln,s2hln,s3hln,s4hln, & + so4hln,oc1hln,oc2hln,bc1hln,bc2hln, & + d1var,d2var,d3var,d4var,d5var,s1var,s2var,s3var,s4var, & + so4var,oc1var,oc2var,bc1var,bc2var, & + istart,iglobal,ltosi,ltosj,smoothdeg + use comm_mod, only: sub2grid,grid2sub,nsig1o + use specgrid, only: enn1,nc,jcap,sptez_s,load_grid,& + factsml,ncd2,unload_grid + implicit none + include 'mpif.h' + + integer(i_kind),intent(in):: numcases,mype + + real(r_kind),dimension(lat1,lon1,nsig):: d1a,d2a,d3a,d4a,d5a, & + s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a + real(r_kind),dimension(lat1,lon1,nsig):: d1b,d2b,d3b,d4b,d5b, & + s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b + real(r_kind),dimension(lat1,lon1,nsig):: d1c,d2c,d3c,d4c,d5c, & + s1c,s2c,s3c,s4c,so4c,oc1c,oc2c,bc1c,bc2c + + real(r_kind),dimension(nlat,nsig):: d1lap,d2lap,d3lap,d4lap,d5lap, & + s1lap,s2lap,s3lap,s4lap,so4lap,oc1lap,oc2lap,bc1lap,bc2lap + real(r_kind),dimension(nlat):: pslap + + real(r_kind),dimension(nlat,nlon,nsig1o):: work + real(r_kind),dimension(nlat,nlon):: workgrd + real(r_kind),dimension(iglobal):: work1 + real(r_kind),dimension(nlon,nlat-2):: grid + real(r_kind),dimension(nc):: wrkspec + real(r_kind) eight,quarter,r_norm + + integer(i_kind) i,j,k,m,n,ix,mpi_rtype,mm1,mype_work,ierror + integer(i_kind) i2,i2m1,jj,j2,kk,ni1,ni2 + + if (db_prec) then + mpi_rtype=mpi_real8 + else + mpi_rtype=mpi_real4 + end if + + mype_work=npe/2 + mm1=mype+1 + r_norm=1./float(numcases) + eight=8.0_r_kind + quarter=0.25_r_kind + + d1c=zero ; d2c=zero ; d3c=zero ; d4c=zero ; d5c=zero ; + s1c=zero ; s2c=zero ; s3c=zero ; s4c=zero ; so4c=zero ; + oc1c=zero ; oc2c=zero ; bc1c=zero ; bc2c=zero + + d1lap=zero ; d2lap=zero ; d3lap=zero ; d4lap=zero ; d5lap=zero ; + s1lap=zero ; s2lap=zero ; s3lap=zero ; s4lap=zero ; so4lap=zero ; + oc1lap=zero ; oc2lap=zero ; bc1lap=zero ; bc2lap=zero + + open(filunit1,form='unformatted',action='read') + rewind(filunit1) + open(filunit2,form='unformatted',action='read') + rewind(filunit2) + + do n=1,numcases + if (mype==0) write(6,*) 'HORIZSC, PROCESSING PAIR # ',n +! Read in subdomain grids + read(filunit1) d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a + read(filunit2) d1b,d2b,d3b,d4b,d5b,s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b + + call delvars_aerosol(d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a, & + d1b,d2b,d3b,d4b,d5b,s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b,mype) + +! Normalize by standard deviation + do k=1,nsig + do j=1,lon1 + do i=1,lat1 + ix=istart(mype+1)+i-1 + d1a(i,j,k) = d1a(i,j,k)/sqrt(d1var(ix,k)) + d2a(i,j,k) = d2a(i,j,k)/sqrt(d2var(ix,k)) + d3a(i,j,k) = d3a(i,j,k)/sqrt(d3var(ix,k)) + d4a(i,j,k) = d4a(i,j,k)/sqrt(d4var(ix,k)) + d5a(i,j,k) = d5a(i,j,k)/sqrt(d5var(ix,k)) + s1a(i,j,k) = s1a(i,j,k)/sqrt(s1var(ix,k)) + s2a(i,j,k) = s2a(i,j,k)/sqrt(s2var(ix,k)) + s3a(i,j,k) = s3a(i,j,k)/sqrt(s3var(ix,k)) + s4a(i,j,k) = s4a(i,j,k)/sqrt(s4var(ix,k)) + so4a(i,j,k) = so4a(i,j,k)/sqrt(so4var(ix,k)) + oc1a(i,j,k) = oc1a(i,j,k)/sqrt(oc1var(ix,k)) + oc2a(i,j,k) = oc2a(i,j,k)/sqrt(oc2var(ix,k)) + bc1a(i,j,k) = bc1a(i,j,k)/sqrt(bc1var(ix,k)) + bc2a(i,j,k) = bc2a(i,j,k)/sqrt(bc2var(ix,k)) + end do + end do + end do + +! Place on evenly distrubuted horizontal slabs + call sub2grid(work,d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a) + +! Loop over nsig1o levels + do k=1,nsig1o + + do j=1,nlon + do i=1,nlat + workgrd(i,j)=work(i,j,k) + end do + end do + + call load_grid(workgrd,grid) + wrkspec=zero +! Transform to spectral space + call sptez_s(wrkspec,grid,-1) +! Take laplacian + wrkspec(1)=0. + wrkspec(2)=0. + + call splaplac(0,jcap,enn1,wrkspec,wrkspec,1) + + do i=1,ncd2 + i2=2*i; i2m1=i2-1 + wrkspec(i2)=factsml(i2)*wrkspec(i2) + wrkspec(i2m1)=factsml(i2m1)*wrkspec(i2m1) + end do + +! Transform back to grid + call sptez_s(wrkspec,grid,1) + call unload_grid(grid,workgrd) + + do j=1,nlon + do i=1,nlat + work(i,j,k)=workgrd(i,j) + end do + end do + end do !end do nsig1o loop + +! Transform work array back to subdomain + call grid2sub(work,d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a) + +! Load into average laplacian arrays + do k=1,nsig + do j=1,lon1 + do i=1,lat1 + d1c(i,j,k) = d1c(i,j,k) + d1a(i,j,k)*d1a(i,j,k)*r_norm + d2c(i,j,k) = d2c(i,j,k) + d2a(i,j,k)*d2a(i,j,k)*r_norm + d3c(i,j,k) = d3c(i,j,k) + d3a(i,j,k)*d3a(i,j,k)*r_norm + d4c(i,j,k) = d4c(i,j,k) + d4a(i,j,k)*d4a(i,j,k)*r_norm + d5c(i,j,k) = d5c(i,j,k) + d5a(i,j,k)*d5a(i,j,k)*r_norm + s1c(i,j,k) = s1c(i,j,k) + s1a(i,j,k)*s1a(i,j,k)*r_norm + s2c(i,j,k) = s2c(i,j,k) + s2a(i,j,k)*s2a(i,j,k)*r_norm + s3c(i,j,k) = s3c(i,j,k) + s3a(i,j,k)*s3a(i,j,k)*r_norm + s4c(i,j,k) = s4c(i,j,k) + s4a(i,j,k)*s4a(i,j,k)*r_norm + so4c(i,j,k) = so4c(i,j,k) + so4a(i,j,k)*so4a(i,j,k)*r_norm + oc1c(i,j,k) = oc1c(i,j,k) + oc1a(i,j,k)*oc1a(i,j,k)*r_norm + oc2c(i,j,k) = oc2c(i,j,k) + oc2a(i,j,k)*oc2a(i,j,k)*r_norm + bc1c(i,j,k) = bc1c(i,j,k) + bc1a(i,j,k)*bc1a(i,j,k)*r_norm + bc2c(i,j,k) = bc2c(i,j,k) + bc2a(i,j,k)*bc2a(i,j,k)*r_norm + end do + end do + end do + end do ! end do over numcases + close(filunit1) + close(filunit2) + +! Convert to zonal mean quantities + do k=1,nsig + call mpi_gatherv(d1c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d1lap(i,k) = d1lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(d2c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d2lap(i,k) = d2lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(d3c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d3lap(i,k) = d3lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(d4c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d4lap(i,k) = d4lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(d5c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d5lap(i,k) = d5lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(s1c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s1lap(i,k) = s1lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(s2c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s2lap(i,k) = s2lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(s3c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s3lap(i,k) = s3lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(s4c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s4lap(i,k) = s4lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(so4c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + so4lap(i,k) = so4lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(oc1c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + oc1lap(i,k) = oc1lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(oc2c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + oc2lap(i,k) = oc2lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(bc1c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + bc1lap(i,k) = bc1lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(bc2c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + bc2lap(i,k) = bc2lap(i,k) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + + if (mype==mype_work) then + do k=1,nsig + do i=1,nlat + d1hln(i,k)=(eight/d1lap(i,k))**quarter + d2hln(i,k)=(eight/d2lap(i,k))**quarter + d3hln(i,k)=(eight/d3lap(i,k))**quarter + d4hln(i,k)=(eight/d4lap(i,k))**quarter + d5hln(i,k)=(eight/d5lap(i,k))**quarter + s1hln(i,k)=(eight/s1lap(i,k))**quarter + s2hln(i,k)=(eight/s2lap(i,k))**quarter + s3hln(i,k)=(eight/s3lap(i,k))**quarter + s4hln(i,k)=(eight/s4lap(i,k))**quarter + so4hln(i,k)=(eight/so4lap(i,k))**quarter + oc1hln(i,k)=(eight/oc1lap(i,k))**quarter + oc2hln(i,k)=(eight/oc2lap(i,k))**quarter + bc1hln(i,k)=(eight/bc1lap(i,k))**quarter + bc2hln(i,k)=(eight/bc2lap(i,k))**quarter + end do + end do + +!! Put bounds on cloud water horizontal scales, consider aerosol + do k=1,nsig + do i=1,nlat + d1hln(i,k)=max(min(5.e5_r_kind,d1hln(i,k)),2.5e3_r_kind) + d2hln(i,k)=max(min(5.e5_r_kind,d2hln(i,k)),2.5e3_r_kind) + d3hln(i,k)=max(min(5.e5_r_kind,d3hln(i,k)),2.5e3_r_kind) + d4hln(i,k)=max(min(5.e5_r_kind,d4hln(i,k)),2.5e3_r_kind) + d5hln(i,k)=max(min(5.e5_r_kind,d5hln(i,k)),2.5e3_r_kind) + s1hln(i,k)=max(min(5.e5_r_kind,s1hln(i,k)),2.5e3_r_kind) + s2hln(i,k)=max(min(5.e5_r_kind,s2hln(i,k)),2.5e3_r_kind) + s3hln(i,k)=max(min(5.e5_r_kind,s3hln(i,k)),2.5e3_r_kind) + s4hln(i,k)=max(min(5.e5_r_kind,s4hln(i,k)),2.5e3_r_kind) + so4hln(i,k)=max(min(5.e5_r_kind,so4hln(i,k)),2.5e3_r_kind) + oc1hln(i,k)=max(min(5.e5_r_kind,oc1hln(i,k)),2.5e3_r_kind) + oc2hln(i,k)=max(min(5.e5_r_kind,oc2hln(i,k)),2.5e3_r_kind) + bc1hln(i,k)=max(min(5.e5_r_kind,bc1hln(i,k)),2.5e3_r_kind) + bc2hln(i,k)=max(min(5.e5_r_kind,bc2hln(i,k)),2.5e3_r_kind) + end do + end do + + call smoothlat(d1hln,nsig,smoothdeg) + call smoothlat(d2hln,nsig,smoothdeg) + call smoothlat(d3hln,nsig,smoothdeg) + call smoothlat(d4hln,nsig,smoothdeg) + call smoothlat(d5hln,nsig,smoothdeg) + call smoothlat(s1hln,nsig,smoothdeg) + call smoothlat(s2hln,nsig,smoothdeg) + call smoothlat(s3hln,nsig,smoothdeg) + call smoothlat(s4hln,nsig,smoothdeg) + call smoothlat(so4hln,nsig,smoothdeg) + call smoothlat(oc1hln,nsig,smoothdeg) + call smoothlat(oc2hln,nsig,smoothdeg) + call smoothlat(bc1hln,nsig,smoothdeg) + call smoothlat(bc2hln,nsig,smoothdeg) + end if ! end if mype_work + + call mpi_bcast(d1hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d2hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d3hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d4hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d5hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s1hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s2hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s3hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s4hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(so4hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(oc1hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(oc2hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(bc1hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(bc2hln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + + return +end subroutine horizsc_aerosol diff --git a/util/NMC_Bkerror/sorc_aero/init_commvars.f90 b/util/NMC_Bkerror/sorc_aero/init_commvars.f90 new file mode 100755 index 000000000..3f8cb638f --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/init_commvars.f90 @@ -0,0 +1,139 @@ +subroutine init_commvars(mype) + use kinds, only: r_kind,i_kind + use variables, only: displs_s,ird_s,istart,ltosj,& + jstart,itotsub,iglobal,nsig,nlon,ltosi_s,ltosj_s,nlat,& + ijn_s,irc_s,ijn,ilat1,jlon1,displs_g,& + ltosi,isc_g,isd_g,npe,izero + use comm_mod, only: nsig1o,irdsp_g,isdsp_g,ircnt_g,& + iscnt_g,ircnt_s,isdsp_s,irdsp_s,iscnt_s,& + spec_send,disp_spec + use specgrid, only: ncin + implicit none + + integer(i_kind) ns,mm1,mype + integer(i_kind) i,j,n,kchk + + mm1=mype+1 + iglobal=nlat*nlon + + +! Set number of latitude and longitude for given subdomain +! Transfer/compute indices to global arrays. Some of these +! arrays are used in the spectral to grid transforms + do i=1,npe + ijn(i)=ilat1(i)*jlon1(i) + ijn_s(i)=(ilat1(i))*(jlon1(i)) + end do + + do i=1,npe + irc_s(i)=ijn_s(mm1) + isc_g(i)=ijn(mm1) + end do + allocate(ltosi(nlat*nlon),ltosj(nlat*nlon)) + do i=1,nlat*nlon + ltosi(i)=izero + ltosj(i)=izero + end do + +! Load arrays dealing with global grids + isd_g(1)=izero + displs_g(1)=izero + do n=1,npe + if(n/=1) then + isd_g(n)=isd_g(n-1)+isc_g(n-1) + displs_g(n)=displs_g(n-1)+ijn(n-1) + end if + do j=1,jlon1(n) + ns=displs_g(n)+(j-1)*ilat1(n) + do i=1,ilat1(n) + ns=ns+1 + ltosi(ns)=istart(n)+i-1 + ltosj(ns)=jstart(n)+j-1 + end do + end do + end do + +! Load arrays dealing with subdomain grids + ird_s(1)=izero + displs_s(1)=izero + do n=1,npe + if(n/=1) then + ird_s(n)=ird_s(n-1)+irc_s(n-1) + displs_s(n)=displs_s(n-1)+ijn_s(n-1) + end if + end do +! set total number of points from all subdomain grids + itotsub=displs_s(npe)+ijn_s(npe) + allocate(ltosi_s(itotsub),ltosj_s(itotsub)) + + do i=1,itotsub + ltosi_s(i)=izero + ltosj_s(i)=izero + end do + + do n=1,npe + do j=1,jlon1(n) + ns=displs_s(n)+(j-1)*(ilat1(n)) + do i=1,ilat1(n) + ns=ns+1 + ltosi_s(ns)=istart(n)+i-1 + ltosj_s(ns)=jstart(n)+j-1 + end do + end do + end do ! end do over npe + + +! vertical column / horizontal slice communicator arrays + isdsp_g(1)=izero + irdsp_g(1)=izero + isdsp_s(1)=izero + irdsp_s(1)=izero + + if (mod((14*nsig),npe)==izero) then + kchk=npe + else + kchk=mod((nsig*14),npe) + end if + + do n=1,npe + if (n.le.kchk) then + iscnt_g(n)=ijn(mm1)*nsig1o + ircnt_s(n)=ijn_s(mm1)*nsig1o + else + iscnt_g(n)=ijn(mm1)*(nsig1o-1) + ircnt_s(n)=ijn_s(mm1)*(nsig1o-1) + end if + + if (mm1.le.kchk) then + ircnt_g(n)=ijn(n)*nsig1o + iscnt_s(n)=ijn_s(n)*nsig1o + else + ircnt_g(n)=ijn(n)*(nsig1o-1) + iscnt_s(n)=ijn_s(n)*(nsig1o-1) + end if + + if (n/=1) then + isdsp_g(n)=isdsp_g(n-1)+iscnt_g(n-1) + irdsp_g(n)=irdsp_g(n-1)+ijn(n-1)*nsig1o + isdsp_s(n)=isdsp_s(n-1)+ijn_s(n-1)*nsig1o + irdsp_s(n)=irdsp_s(n-1)+ircnt_s(n-1) + end if + end do + + do n=1,npe + if (n.le.kchk) then + spec_send(n) = ncin*nsig1o + else + spec_send(n) = ncin*(nsig1o-1) + end if + end do + + disp_spec(1)=izero + do n=1,npe + if(n/=1) then + disp_spec(n)=disp_spec(n-1)+spec_send(n-1) + end if + end do + + return +end subroutine init_commvars diff --git a/util/NMC_Bkerror/sorc_aero/initvars.f90 b/util/NMC_Bkerror/sorc_aero/initvars.f90 new file mode 100644 index 000000000..cf92050ad --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/initvars.f90 @@ -0,0 +1,75 @@ +subroutine initvars(mype,npe) + use kinds, only: r_kind,r_double + use variables, only: nlon,rlats,wgtlats,ak5,bk5,ck5,& + deg2rad,rlons,nsig,& + dimbig,filename,nlat,sweight,& + na,nb,pi,db_prec,coriolis, & + two,omega,idpsfc5,idvm5,idvc5,idthrm5 + use specgrid, only: wlat,slat,jb,je + implicit none + + integer,intent(in):: mype,npe + integer i,ii,l,m,i1 + real(r_kind) anlon,dlon,pih + real(r_kind) onetest + real(r_double) onedouble + + allocate(filename(dimbig)) + allocate(na(dimbig),nb(dimbig)) + + allocate(rlats(nlat),rlons(nlon),wgtlats(nlat)) + allocate(ak5(nsig+1),bk5(nsig+1),ck5(nsig+1)) + +! constant for deg/radians conversion + deg2rad=acos(-1.0)/180.0 + +! Set local constants + anlon=float(nlon) + pih=0.5*pi + dlon=4*pih/anlon + +! Init grid stuff to defaults + idpsfc5=1 + idvm5=1 + idvc5=1 + idthrm5=1 + +! Load grid lat,lon arrays. rbs2 is used in pcp. + do i=1,nlon + rlons(i)=float(i-1)*dlon + end do + + do i=jb,je + i1=i+1 + rlats(i1)=-asin(slat(i)) + wgtlats(i1)=wlat(i) + + i1=nlat-i + rlats(i1)=asin(slat(i)) + wgtlats(i1)=wlat(i) + end do + + rlats(1)=-pih + rlats(nlat)=pih + + wgtlats(1)=0.0_r_kind + wgtlats(nlat)=0.0_r_kind + + + do i=1,nlat + coriolis(i)=two*omega*sin(rlats(i)) + end do + + +! test for precision at which code was compiled + onetest=1.; onedouble=1. + if(digits(onetest).lt.digits(onedouble)) then + db_prec=.false. + else + db_prec=.true. + endif + if (mype==0) write(6,*) 'INITVARS: DB_PREC = ',db_prec + + return +end subroutine initvars + diff --git a/util/NMC_Bkerror/sorc_aero/kinds.F90 b/util/NMC_Bkerror/sorc_aero/kinds.F90 new file mode 100755 index 000000000..dd5692e2e --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/kinds.F90 @@ -0,0 +1,103 @@ +module kinds +!$$$ module documentation block +! . . . . +! module: kinds +! prgmmr: treadon org: np23 date: 2004-08-15 +! +! abstract: Module to hold specification kinds for variable declaration. +! This module is based on (copied from) Paul vanDelst's +! type_kinds module found in the community radiative transfer +! model +! +! module history log: +! 2004-08-15 treadon +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! The numerical data types defined in this module are: +! i_byte - specification kind for byte (1-byte) integer variable +! i_short - specification kind for short (2-byte) integer variable +! i_long - specification kind for long (4-byte) integer variable +! i_llong - specification kind for double long (8-byte) integer variable +! r_single - specification kind for single precision (4-byte) real variable +! r_double - specification kind for double precision (8-byte) real variable +! r_quad - specification kind for quad precision (16-byte) real variable +! +! i_kind - generic specification kind for default integer +! r_kind - generic specification kind for default floating point +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + implicit none + private + +! Integer type definitions below + +! Integer types + integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer + integer, parameter, public :: i_short = selected_int_kind(4) ! short integer + integer, parameter, public :: i_long = selected_int_kind(8) ! long integer + integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer + integer, parameter, public :: i_llong = max( llong_t, i_long ) + +! Expected 8-bit byte sizes of the integer kinds + integer, parameter, public :: num_bytes_for_i_byte = 1 + integer, parameter, public :: num_bytes_for_i_short = 2 + integer, parameter, public :: num_bytes_for_i_long = 4 + integer, parameter, public :: num_bytes_for_i_llong = 8 + +! Define arrays for default definition + integer, parameter, private :: num_i_kinds = 4 + integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & + i_byte, i_short, i_long, i_llong /) + integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & + num_bytes_for_i_byte, num_bytes_for_i_short, & + num_bytes_for_i_long, num_bytes_for_i_llong /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** + integer, parameter, private :: default_integer = 3 ! 1=byte, + ! 2=short, + ! 3=long, + ! 4=llong + integer, parameter, public :: i_kind = integer_types( default_integer ) + integer, parameter, public :: num_bytes_for_i_kind = & + integer_byte_sizes( default_integer ) + + +! Real definitions below + +! Real types + integer, parameter, public :: r_single = selected_real_kind(6) ! single precision + integer, parameter, public :: r_double = selected_real_kind(15) ! double precision + integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision + integer, parameter, public :: r_quad = max( quad_t, r_double ) + +! Expected 8-bit byte sizes of the real kinds + integer, parameter, public :: num_bytes_for_r_single = 4 + integer, parameter, public :: num_bytes_for_r_double = 8 + integer, parameter, public :: num_bytes_for_r_quad = 16 + +! Define arrays for default definition + integer, parameter, private :: num_r_kinds = 3 + integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & + r_single, r_double, r_quad /) + integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & + num_bytes_for_r_single, num_bytes_for_r_double, & + num_bytes_for_r_quad /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** + integer, parameter, private :: default_real = 1 ! 1=single, + integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: num_bytes_for_r_kind = & + real_byte_sizes( default_real ) + +end module kinds diff --git a/util/NMC_Bkerror/sorc_aero/mat.f90 b/util/NMC_Bkerror/sorc_aero/mat.f90 new file mode 100644 index 000000000..2a1f09850 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/mat.f90 @@ -0,0 +1,3672 @@ +! ***************** +! * MAT1.FOR * +! * PURSER 1994 * +! ***************** +! Routines for basic algebraic operations on general matrices and vectors +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! These routines, perform basic algebraic operations on real vectors and +! matrices. The task performed by each routine is, as far as possible, +! encoded in each routine's name; three letters describe the +! operation, the remainder defining the type of operand and, if needed to +! an ambiguity, the type of result. +! +! OPERATIONS: +! ADD add first two operands, return result as third argument +! ADF add first two operands, "flip" (reverse order), put into 3rd. +! ANF add negative of 1st to negative of 2nd and "flip" result into 3rd +! CNF copy negative of flipped (order-reversed) 1st operand to 2nd +! CPF copy positive of flipped (order-reversed) 1st operand to 2nd +! CON copy negative +! COP copy positive +! DAD dot product of first two operands added to third +! DET evaluate log-determinant +! DIF differentiate +! DIV divide first operand by second +! DOT dot product of first two operands +! DSB dot product of first two operands subtracted from third +! FAD "flip" 1st operand, (reverse order of elements), add to 2nd +! FDA "flip" 1st operand, dot product with 2nd, add to 3rd +! FDO "flip" (reverse order of) 1st operand and form dot product with 2nd +! FDS "flip" 1st operand, dot product with 2nd, subtract result from 3rd +! FSB "flip" 1st operand, subtract 2nd (cf. FAD) +! FSN "flip" 1st operand, subtract it from 2nd operand (negtve of FSB) +! INT integrate +! INV invert the matrix, or linear system involving the matrix operand +! L1L Cholesky LU decomposition, where U is just L-transpose +! L1U L-U decomposition of first arg, with 1's along diagonal of L and U +! LDL Cholesky LDU decomposition, where U is just L-transpose and D diag. +! LDU LDU decomposition +! MAD multiply first two operands, but then add result to third +! MUL multiply first two operands, return result as third argument +! MSB multiply first two operands, but then subtract result from third +! NEG replace operand by its negative +! NOR evaluate norm of operand +! POL polynomial (first argument) of second argument +! POW raise operand to some integer power +! SBF subtract from 1st operand the 2nd, "flip" result into 3rd (cf ADF) +! SUB subtract first two operands, return result as third argument +! SUM sum the elements of first operand +! SWP swap first two operands +! TPS replace operand by its transpose +! TRC evaluate trace of operand +! U1L back substitution with matrix decomposed into LU form, 1's on diag. +! UDL back substitution with matrix decomposed into LDU form +! WRT write out +! ZER set operand to zero +! +! OPERAND TYPES: +! B banded matrix +! C circulant matrix +! D diagonal matrix +! H symmetric or hermitian matrix +! L lower triangular matrix +! M matrix (rectangular, in general) +! P polynomial or power-series coefficient vector +! Q sQuare matrix with Fortan dimension same as logical dimension +! R row of a matrix +! S scalar +! T transpose of the matrix +! U upper triangular matrix +! V vector, or column of a matrix +! X field of parallel X-vectors (aligned like "columns" of a matrix) +! Y field of parallel Y-vectors (aligned like "rows" of a matrix) +! +! For those matrix routines with a "Q" in the last part of the name, +! denoting operation upon a square matrix, the Fortran dimensions and +! matrix order are implicitly assumed identical. If this is not the case, +! the general matrix routines, (those without a "Q" in the name) allow +! the arguments, MI, MJ, which denote the algebraic dimensions, to be +! different from each other (for rectangular matrices) and different from +! the Fortran dimensions NA, NB, etc., which are therefore listed as +! additional parameters. +! +!------------------------------------------------------------------------------ + SUBROUTINE ZERV(D,M) ! set elements of a vector to zero + DIMENSION D(M) + DO I=1,M + D(I)=0. + ENDDO + RETURN + ENTRY NEGV(D,M) ! Replace vector by its negative + DO I=1,M + D(I)=-D(I) + ENDDO + RETURN + ENTRY COPSD(S,D,M) ! Copy a scalar to a diagonal matrix + DO I=1,M + D(I)=S + ENDDO + RETURN + ENTRY CONSD(S,D,M) ! Copy negative of a scalar to a diagonal + DO I=1,M + D(I)=-S + ENDDO + RETURN + END + SUBROUTINE ZERM(A,MI,MJ,NA) ! Set the elements of general matrix to zero + DIMENSION A(NA,*) + DO J=1,MJ + CALL ZERV(A(1,J),MI) + ENDDO + RETURN + ENTRY NEGM(A,MI,MJ,NA) ! Replace general matrix A by its negative + DO J=1,MJ + CALL NEGV(A(1,J),MI) + ENDDO + RETURN + END + + SUBROUTINE ADDRR(A,B,C,M,NA,NB,NC) + DIMENSION A(NA,*),B(NB,*),C(NC,*) + DO I=1,M + C(1,I)=A(1,I)+B(1,I) + ENDDO + RETURN + ENTRY SUBRR(A,B,C,M,NA,NB,NC) + DO I=1,M + C(1,I)=A(1,I)-B(1,I) + ENDDO + RETURN + ENTRY ADNRR(A,B,C,M,NA,NB,NC) + DO I=1,M + C(1,I)=-A(1,I)-B(1,I) + ENDDO + RETURN + ENTRY MULRR(A,B,C,M,NA,NB,NC) + DO I=1,M + C(1,I)=A(1,I)*B(1,I) + ENDDO + RETURN + ENTRY MADRR(A,B,C,M,NA,NB,NC) + DO I=1,M + C(1,I)=C(1,I)+A(1,I)*B(1,I) + ENDDO + RETURN + ENTRY MSBRR(A,B,C,M,NA,NB,NC) + DO I=1,M + C(1,I)=C(1,I)-A(1,I)*B(1,I) + ENDDO + RETURN + ENTRY FADRR(A,B,C,M,NA,NB,NC) + MP=M+1 + DO I=1,M + C(1,I)=B(1,I)+A(1,MP-I) + ENDDO + RETURN + ENTRY FSBRR(A,B,C,M,NA,NB,NC) + MP=M+1 + DO I=1,M + C(1,I)=A(1,MP-I)-B(1,I) + ENDDO + RETURN + ENTRY FSNRR(A,B,C,M,NA,NB,NC) + MP=M+1 + DO I=1,M + C(1,I)=-A(1,MP-I)+B(1,I) + ENDDO + RETURN + ENTRY ADFRR(A,B,C,M,NA,NB,NC) + MP=M+1 + DO I=1,M + C(1,MP-I)=A(1,I)+B(1,I) + ENDDO + RETURN + ENTRY ANFRR(A,B,C,M,NA,NB,NC) + MP=M+1 + DO I=1,M + C(1,MP-I)=-A(1,I)-B(1,I) + ENDDO + RETURN + ENTRY SBFRR(A,B,C,M,NA,NB,NC) + MP=M+1 + DO I=1,M + C(1,MP-I)=A(1,I)-B(1,I) + ENDDO + RETURN + ENTRY ZERR(A,M,NA) + DO I=1,M + A(1,I)=0. + ENDDO + RETURN + END + + SUBROUTINE COPR(A,B,M,NA,NB) + DIMENSION A(NA,M),B(NB,M) + DO I=1,M + B(1,I)=A(1,I) + ENDDO + RETURN + ENTRY CONR(A,B,M,NA,NB) + DO I=1,M + B(1,I)=-A(1,I) + ENDDO + RETURN + ENTRY CPFR(A,B,M,NA,NB) + MP=M+1 + DO I=1,M + B(1,I)=A(1,MP-I) + ENDDO + RETURN + ENTRY CNFR(A,B,M,NA,NB) + MP=M+1 + DO I=1,M + B(1,I)=-A(1,MP-I) + ENDDO + RETURN + END + SUBROUTINE COPVR(D,A,M,NA) + DIMENSION D(M),A(NA,M),B(NB,M) + DO I=1,M + A(1,I)=D(I) + ENDDO + RETURN + ENTRY CONVR(D,A,M,NA) + DO I=1,M + A(1,I)=-D(I) + ENDDO + RETURN + ENTRY COPRV(A,D,M,NA) + DO I=1,M + D(I)=A(1,I) + ENDDO + RETURN + ENTRY CONRV(A,D,M,NA) + DO I=1,M + D(I)=-A(1,I) + ENDDO + RETURN + + ENTRY MULVR(D,A,B,M,NA,NB) + ENTRY MULDR(D,A,B,M,NA,NB) + DO I=1,M + B(1,I)=D(I)*A(1,I) + ENDDO + RETURN + ENTRY MADVR(D,A,B,M,NA,NB) + ENTRY MADDR(D,A,B,M,NA,NB) + DO I=1,M + B(1,I)=B(1,I)+D(I)*A(1,I) + ENDDO + RETURN + ENTRY MSBVR(D,A,B,M,NA,NB) + ENTRY MSBDR(D,A,B,M,NA,NB) + DO I=1,M + B(1,I)=B(1,I)-D(I)*A(1,I) + ENDDO + RETURN + END + + SUBROUTINE MULVS(D,S,E,M) + DIMENSION D(*),E(*) + DO I=1,M + E(I)=D(I)*S + ENDDO + RETURN + ENTRY MADVS(D,S,E,M) + DO I=1,M + E(I)=E(I)+D(I)*S + ENDDO + RETURN + ENTRY MSBVS(D,S,E,M) + DO I=1,M + E(I)=E(I)-D(I)*S + ENDDO + RETURN + END + + SUBROUTINE MULRS(A,S,B,M,NA,NB) + DIMENSION A(NA,*),B(NB,*) + DO I=1,M + B(1,I)=A(1,I)*S + ENDDO + RETURN + ENTRY MADRS(A,S,B,M,NA,NB) + DO I=1,M + B(1,I)=B(1,I)+A(1,I)*S + ENDDO + RETURN + ENTRY MSBRS(A,S,B,M,NA,NB) + DO I=1,M + B(1,I)=B(1,I)-A(1,I)*S + ENDDO + RETURN + END + + FUNCTION DOT(D,E,M) + DIMENSION D(M),E(M) + DOT=0. + DO I=1,M + DOT=DOT+D(I)*E(I) + ENDDO + RETURN + END + + SUBROUTINE DOTVV(D,E,S,M) + DIMENSION D(M),E(M) + S=0. + ENTRY DADVV(D,E,S,M) + DO I=1,M + S=S+D(I)*E(I) + ENDDO + RETURN + ENTRY DSBVV(D,E,S,M) + DO I=1,M + S=S-D(I)*E(I) + ENDDO + RETURN + END + + SUBROUTINE DOTVR(D,A,S,M,NA) + DIMENSION D(M),A(NA,*) + S=0. + ENTRY DADVR(D,A,S,M,NA) + DO I=1,M + S=S+D(I)*A(1,I) + ENDDO + RETURN + ENTRY DSBVR(D,A,S,M,NA) + DO I=1,M + S=S-D(I)*A(1,I) + ENDDO + RETURN + END + + SUBROUTINE DOTRR(A,B,S,M,NA,NB) + DIMENSION A(NA,*),B(NB,*) + S=0. + ENTRY DADRR(A,B,S,M,NA,NB) + DO I=1,M + S=S+A(1,I)*B(1,I) + ENDDO + RETURN + ENTRY DSBRR(A,B,S,M,NA,NB) + DO I=1,M + S=S-A(1,I)*B(1,I) + ENDDO + RETURN + END + + FUNCTION PRO333(D,E,F) ! TRIPLE PRODUCT OF 3 3-VECTORS + DIMENSION D(3),E(3),F(3),G(3) + CALL CRO33(E,F,G) + CALL DOTVV(D,G,PRO333,3) + RETURN + END + + SUBROUTINE NORV(D,S,M) ! NORM OF VECTOR.. + DIMENSION D(M) + S=SQRT(DOT(D,D,M)) + RETURN + ENTRY NORQ(D,S,M) ! ...OF SQUARE MATRIX. + S=SQRT(DOT(Q,Q,M*M)) + RETURN + END + + SUBROUTINE NORR(A,S,M,NA) + DIMENSION A(NA,M) + CALL DOTRR(A,A,S,M,NA,NA) + S=SQRT(S) + RETURN + END + + SUBROUTINE CRO33(A,B,C) ! SPECIAL CASE OF 3-DIMENSIONS: CROSS-PRODUCT + DIMENSION A(3),B(3),C(3) + C(1)=A(2)*B(3)-A(3)*B(2) + C(2)=A(3)*B(1)-A(1)*B(3) + C(3)=A(1)*B(2)-A(2)*B(1) + RETURN + END + + SUBROUTINE MULVV(A,B,C,M) + DIMENSION A(*),B(*),C(*) + DO I=1,M + C(I)=A(I)*B(I) + ENDDO + RETURN + ENTRY MADVV(A,B,C,M) + DO I=1,M + C(I)=C(I)+A(I)*B(I) + ENDDO + RETURN + ENTRY MSBVV(A,B,C,M) + DO I=1,M + C(I)=C(I)-A(I)*B(I) + ENDDO + RETURN + ENTRY ADDVV(A,B,C,M) + DO I=1,M + C(I)=A(I)+B(I) + ENDDO + RETURN + ENTRY SUBVV(A,B,C,M) + DO I=1,M + C(I)=A(I)-B(I) + ENDDO + RETURN + ENTRY ADNVV(A,B,C,M) + DO I=1,M + C(I)=-A(I)-B(I) + ENDDO + RETURN + ENTRY FADVV(A,B,C,M) + MP=M+1 + DO I=1,M + C(I)=B(I)+A(MP-I) + ENDDO + RETURN + ENTRY FSBVV(A,B,C,M) + MP=M+1 + DO I=1,M + C(I)=A(MP-I)-B(I) + ENDDO + RETURN + ENTRY FSNVV(A,B,C,M) + MP=M+1 + DO I=1,M + C(I)=-A(MP-I)+B(I) + ENDDO + RETURN + ENTRY DIVVV(A,B,C,M) + DO I=1,M + C(I)=A(I)/B(I) + ENDDO + RETURN + ENTRY COPV(A,B,M) + DO I=1,M + B(I)=A(I) + ENDDO + RETURN + ENTRY CONV(A,B,M) + DO I=1,M + B(I)=-A(I) + ENDDO + RETURN + ENTRY ADFVV(A,B,C,M) + MP=M+1 + DO I=1,M + C(MP-I)=A(I)+B(I) + ENDDO + RETURN + ENTRY ANFVV(A,B,C,M) + MP=M+1 + DO I=1,M + C(MP-I)=-A(I)-B(I) + ENDDO + RETURN + ENTRY SBFVV(A,B,C,M) + MP=M+1 + DO I=1,M + C(MP-I)=A(I)-B(I) + ENDDO + RETURN + END + + SUBROUTINE SWPVV(D,E,M) + DIMENSION D(M),E(M) + DO I=1,M + T=D(I) + D(I)=E(I) + E(I)=T + ENDDO + RETURN + END + + SUBROUTINE SWPRR(A,B,M,NA,NB) ! Row swap + DIMENSION A(NA,*),B(NB,*) + DO J=1,M + T=A(1,J) + A(1,J)=B(1,J) + B(1,J)=T + ENDDO + RETURN + END + + SUBROUTINE TPSM(A,MI,MJ,NA) ! Transpose, in place, a general matrix + DIMENSION A(NA,*) + M=MAX(MI,MJ) + IF(M.GT.NA)STOP +! &'first array bound in TPSM too small to allow transpose to fit' + NAP=NA+1 + DO I=1,M-1 + IP=I+1 + CALL SWPRR(A(IP,1),A(1,IP),M-I,NAP,NAP) + ENDDO + RETURN + END + + SUBROUTINE MULMV(A,D,E,MI,MJ,NA) + DIMENSION A(NA,*),D(*),E(*) + CALL ZERV(E,MJ) + ENTRY MADMV(A,D,E,MI,MJ,NA) + DO J=1,MJ + CALL MADVS(A(1,J),D(J),E,MI) + ENDDO + RETURN + ENTRY MSBMV(A,D,E,MI,MJ,NA) + DO J=1,MJ + CALL MSBVS(A(1,J),D(J),E,MI) + ENDDO + RETURN + END + + SUBROUTINE MULVM(D,A,E,MI,MJ,NA) + DIMENSION A(NA,*),D(*),E(*) + CALL ZERV(E,MJ) + ENTRY MADVM(D,A,E,MI,MJ,NA) + DO I=1,MI + CALL MADRS(A,D(I),E,MJ,NA,1) + ENDDO + RETURN + ENTRY MSBVM(D,A,E,MI,MJ,NA) + DO I=1,MI + CALL MSBRS(A,D(I),E,MJ,NA,1) + ENDDO + RETURN + END + + SUBROUTINE MULMM(A,B,C,MI,MJ,MK,NA,NB,NC) + DIMENSION A(NA,*),B(NB,*),C(NC,*) + CALL ZERM(C,MI,MK,NC) + ENTRY MADMM(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL MADVS(A(1,J),B(J,K),C(1,K),MI) + ENDDO + ENDDO + RETURN + ENTRY MSBMM(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL MSBVS(A(1,J),B(J,K),C(1,K),MI) + ENDDO + ENDDO + RETURN + + ENTRY MULMT(A,B,C,MI,MJ,MK,NA,NB,NC) + CALL ZERM(C,MI,MK,NC) + ENTRY MADMT(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL MADVS(A(1,J),B(K,J),C(1,K),MI) + ENDDO + ENDDO + RETURN + ENTRY MSBMT(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL MSBVS(A(1,J),B(K,J),C(1,K),MI) + ENDDO + ENDDO + RETURN + + ENTRY MULTM(A,B,C,MI,MJ,MK,NA,NB,NC) + CALL ZERM(C,MI,MK,NC) + ENTRY MADTM(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL MADRS(A(J,1),B(J,K),C(1,K),MI,NA,1) + ENDDO + ENDDO + RETURN + ENTRY MSBTM(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL MSBRS(A(J,1),B(J,K),C(1,K),MI,NA,1) + ENDDO + ENDDO + RETURN + + ENTRY MULTT(A,B,C,MI,MJ,MK,NA,NB,NC) + CALL ZERM(C,MI,MK,NC) + ENTRY MADTT(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL MADRS(A(J,1),B(K,J),C(1,K),MI,NA,1) + ENDDO + ENDDO + RETURN + ENTRY MSBTT(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL MSBRS(A(J,1),B(K,J),C(1,K),MI,NA,1) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE ADDMM(A,B,C,MI,MJ,NA,NB,NC) + DIMENSION A(NA,*),B(NB,*),C(NC,*) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(I,J)+B(I,J) + ENDDO + ENDDO + RETURN + ENTRY ADDMT(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(I,J)+B(J,I) + ENDDO + ENDDO + RETURN + ENTRY ADDTM(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(J,I)+B(I,J) + ENDDO + ENDDO + RETURN + ENTRY ADDTT(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(J,I)+B(J,I) + ENDDO + ENDDO + RETURN + ENTRY SUBMM(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(I,J)-B(I,J) + ENDDO + ENDDO + RETURN + ENTRY SUBMT(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(I,J)-B(J,I) + ENDDO + ENDDO + RETURN + ENTRY SUBTM(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(J,I)-B(I,J) + ENDDO + ENDDO + RETURN + ENTRY SUBTT(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(J,I)-B(J,I) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE COPM(A,B,MI,MJ,NA,NB) + DIMENSION A(NA,*),B(NB,*) + DO J=1,MJ + DO I=1,MI + B(I,J)=A(I,J) + ENDDO + ENDDO + RETURN + ENTRY CONM(A,B,MI,MJ,NA,NB) + DO J=1,MJ + DO I=1,MI + B(I,J)=-A(I,J) + ENDDO + ENDDO + RETURN + ENTRY MULMS(A,SS,B,MI,MJ,NA,NB) + DO J=1,MJ + DO I=1,MI + B(I,J)=A(I,J)*SS + ENDDO + ENDDO + RETURN + ENTRY COPT(A,B,MI,MJ,NA,NB) + DO J=1,MJ + DO I=1,MI + B(I,J)=A(J,I) + ENDDO + ENDDO + RETURN + ENTRY CONT(A,B,MI,MJ,NA,NB) + DO J=1,MJ + DO I=1,MI + B(I,J)=-A(J,I) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE MULMD(A,D,B,MI,MJ,NA,NB) + DIMENSION A(NA,*),B(NB,*),D(*) + DO J=1,MJ + CALL MULVS(A(1,J),D(J),B(1,J),MI) + ENDDO + RETURN + ENTRY MULTD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL MULRS(A(J,1),D(J),B(1,J),MI,NA,1) + ENDDO + RETURN + ENTRY MULDM(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL MULRS(A(I,1),D(I),B(I,1),MJ,NA,NB) + ENDDO + RETURN + ENTRY MULDT(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL MULRS(A(1,I),D(I),B(I,1),MJ,1,NB) + ENDDO + RETURN + ENTRY MADMD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL MADVS(A(1,J),D(J),B(1,J),MI) + ENDDO + RETURN + ENTRY MADTD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL MADRS(A(J,1),D(J),B(1,J),MI,NA,1) + ENDDO + RETURN + ENTRY MADDM(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL MADRS(A(I,1),D(I),B(I,1),MJ,NA,NB) + ENDDO + RETURN + ENTRY MADDT(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL MADRS(A(1,I),D(I),B(I,1),MJ,1,NB) + ENDDO + RETURN + ENTRY MSBMD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL MSBVS(A(1,J),D(J),B(1,J),MI) + ENDDO + RETURN + ENTRY MSBTD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL MSBRS(A(J,1),D(J),B(1,J),MI,NA,1) + ENDDO + RETURN + ENTRY MSBDM(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL MSBRS(A(I,1),D(I),B(I,1),MJ,NA,NB) + ENDDO + RETURN + ENTRY MSBDT(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL MSBRS(A(1,I),D(I),B(I,1),MJ,1,NB) + ENDDO + RETURN + END + + FUNCTION MCMAX(A,B,M) + DIMENSION A(0:M),B(0:M) + MCMAX=0 ! Default for when ALL elements of C are zero + DO MA=M,0,-1 ! Seek last nonzero coefficient of polynomial A + IF(A(MA).NE.0.)THEN + DO MB=M,0,-1 ! Seek last nonzero coefficient of polynomial B + IF(B(MB).NE.0.)THEN + MCMAX=MIN(M,MA+MB)+1 ! Hence, 1+last non-0 element of their product + RETURN + ENDIF + ENDDO + RETURN + ENDIF + ENDDO + RETURN + END + + SUBROUTINE MULPP(A,B,C,M) ! multiply polynomials, possibly in place + DIMENSION A(0:M),B(0:M),C(0:M) + MCP=MCMAX(A,B,M) + DO I=MCP,M + C(I)=0. + ENDDO + DO J=MCP,1,-1 + CALL FDOVV(A,B,S,J) + C(J-1)=S + ENDDO + RETURN + ENTRY MADPP(A,B,C,M) + MCP=MCMAX(A,B,M) + DO J=MCP,1,-1 + CALL FDOVV(A,B,S,J) + C(J-1)=C(J-1)+S + ENDDO + RETURN + ENTRY MSBPP(A,B,C,M) + MCP=MCMAX(A,B,M) + DO J=MCP,1,-1 + CALL FDOVV(A,B,S,J) + C(J-1)=C(J-1)-S + ENDDO + RETURN + ENTRY DIFP(A,B,M) ! Symbolically differentiate polynomial + DO I=1,M ! possibly with coincident storage for A and B + B(I-1)=I*A(I) + ENDDO + B(M)=0. + RETURN + ENTRY INTP(A,B,M) ! Symbolically integrate polynomial + DO I=M,1,-1 ! possibly with coincident storage for A and B + B(I)=A(I-1)/I + ENDDO + B(0)=0. + RETURN + ENTRY INVP(A,B,M) ! Invert polynomial or power-series + B0=1./A(0) ! Storage of A and B must NOT be the same + B(0)=B0 + DO I=1,M + CALL FDOVV(B,A(1),S,I) + B(I)=-B0*S + ENDDO + RETURN + END + + SUBROUTINE PRGV(D,M) + PARAMETER(CRIT=1.E-60) + DIMENSION D(*) + DO I=1,M + IF(ABS(D(I)).LE.CRIT)D(I)=0. + ENDDO + RETURN + END + + SUBROUTINE FDOVV(D,E,S,M) ! dot-product of "flipped" vector D with E + DIMENSION D(*),E(*) ! (order of the elements of E is reversed) + S=0. + ENTRY FDAVV(D,E,S,M) ! like FDOVV but result added to existing S + MP=M+1 + DO I=1,M + S=S+D(MP-I)*E(I) + ENDDO + RETURN + ENTRY FDSVV(D,E,S,M) ! like FDAVV but result subtracted from S + MP=M+1 + DO I=1,M + S=S-D(MP-I)*E(I) + ENDDO + RETURN + END + + SUBROUTINE FDORR(A,B,S,M,NA,NB) + DIMENSION A(NA,M),B(NB,M) + S=0. + ENTRY FDARR(A,B,S,M,NA,NB) + MP=M+1 + DO I=1,M + S=S+A(1,MP-I)*B(1,I) + ENDDO + RETURN + ENTRY FDSRR(A,B,S,M,NA,NB) + MP=M+1 + DO I=1,M + S=S-A(1,MP-I)*B(1,I) + ENDDO + RETURN + END + + SUBROUTINE POWP(A,B,N,M) ! Raise power series A to the power + DIMENSION A(0:M),B(0:M),C(0:M) ! of N and output as B + B(0)=1. + CALL ZERV(B(1),M) + DO K=1,N + CALL MULPP(A,B,B,M) + ENDDO + RETURN + ENTRY POLPS(A,S1,S2,M) ! Apply series A to scalar S1 to obtain S2 + S2=A(M) + DO K=M-1,0,-1 + S2=S2*S1+A(K) + ENDDO + RETURN + ENTRY POLPP(A,B,C,M) ! Apply power series A to power series B and put + C(0)=A(M) ! the result out as power-series C. + CALL ZERV(C(1),M) + DO K=M-1,0,-1 + CALL MULPP(B,C,C,M) + C(0)=C(0)+A(K) + ENDDO + RETURN + END + + SUBROUTINE MULCC(A,B,C,M) ! Multiply circulant matrices of period M + DIMENSION A(0:M-1),B(0:M-1),C(0:M-1) + CALL ZERV(C,M) + ENTRY MADCC(A,B,C,M) + MM=M-1 + DO J=0,MM + MMJ=M-J + CALL MADVS(A,B(J),C(J),MMJ) + CALL MADVS(A(MMJ),B(J),C,J) + ENDDO + RETURN + ENTRY MSBCC(A,B,C,M) + MM=M-1 + DO J=0,MM + MMJ=M-J + CALL MSBVS(A,B(J),C(J),MMJ) + CALL MSBVS(A(MMJ),B(J),C,J) + ENDDO + RETURN + END + + SUBROUTINE ADDQQ(A,B,C,M) + DIMENSION A(M,M),B(M,M),C(M,M),D(M) + CALL ADDVV(A,B,C,M*M) + RETURN + ENTRY ADDQT(A,B,C,M) + CALL ADDMT(A,B,C,M,M,M,M,M) + RETURN + ENTRY SUBQQ(A,B,C,M) + CALL SUBVV(A,B,C,M*M) + RETURN + ENTRY SUBQT(A,B,C,M) + CALL SUBMT(A,B,C,M,M,M,M,M) + RETURN + ENTRY SUBTQ(A,B,C,M) + CALL SUBTM(A,B,C,M,M,M,M,M) + RETURN + ENTRY INVQ(A,M) + CALL INVM(A,A,M,M,M) + RETURN + ENTRY LINQV(A,D,M) + CALL LINMM(A,D,M,1,M,M) + RETURN + END + + SUBROUTINE TPSQ(A,M) ! Transpose, in place, a square matrix. + DIMENSION A(M,M) + MP=M+1 + DO I=1,M-1 + IP=I+1 + CALL SWPRR(A(IP,1),A(1,IP),M-I,MP,MP) + ENDDO + RETURN + END + + FUNCTION TRCQ(A,M) ! Trace of square matrix A + DIMENSION A(M,M) + TRCQ=0. + DO I=1,M + TRCQ=TRCQ+A(I,I) + ENDDO + RETURN + END + + SUBROUTINE ZERQ(A,M) ! Set elements of a square matrix to zero + DIMENSION A(M,M) + CALL ZERV(A,M*M) + RETURN + ENTRY ZERL(A,M) ! Zero out the strictly lower triangle of elements + DO J=1,M + DO I=J+1,M + A(I,J)=0. + ENDDO + ENDDO + RETURN + ENTRY ZERU(A,M) ! Zero out the strictly upper triangle of elements + DO J=1,M + DO I=1,J-1 + A(I,J)=0. + ENDDO + ENDDO + RETURN + ENTRY NEGQ(A,M) ! Replace square matrix A by its negative + CALL NEGV(A,M*M) + RETURN + END + + SUBROUTINE MULQQ(A,B,C,M) + DIMENSION A(M,M),B(M,M),C(M,M) + CALL ZERQ(C,M) + ENTRY MADQQ(A,B,C,M) + DO K=1,M + DO J=1,M + CALL MADVS(A(1,J),B(J,K),C(1,K),M) + ENDDO + ENDDO + RETURN + ENTRY MSBQQ(A,B,C,M) + DO K=1,M + DO J=1,M + CALL MSBVS(A(1,J),B(J,K),C(1,K),M) + ENDDO + ENDDO + RETURN + ENTRY MULQT(A,B,C,M) + CALL ZERQ(C,M) + ENTRY MADQT(A,B,C,M) + DO K=1,M + DO J=1,M + CALL MADVS(A(1,J),B(K,J),C(1,K),M) + ENDDO + ENDDO + RETURN + ENTRY MSBQT(A,B,C,M) + DO K=1,M + DO J=1,M + CALL MSBVS(A(1,J),B(K,J),C(1,K),M) + ENDDO + ENDDO + RETURN + ENTRY MULTQ(A,B,C,M) + CALL ZERQ(C,M) + ENTRY MADTQ(A,B,C,M) + DO K=1,M + DO J=1,M + CALL MADRS(A(J,1),B(J,K),C(1,K),M,M,1) + ENDDO + ENDDO + RETURN + ENTRY MSBTQ(A,B,C,M) + DO K=1,M + DO J=1,M + CALL MSBRS(A(J,1),B(J,K),C(1,K),M,M,1) + ENDDO + ENDDO + RETURN + END +! WD23JP +! ***************** +! * MAT2.FOR * +! * PURSER 1996 * +! ***************** +! + SUBROUTINE COPQ(A,B,M) + DIMENSION A(M,M),B(M,M),D(M),E(M) + CALL COPV(A,B,M*M) + RETURN + ENTRY CONQ(A,B,M) + CALL CONV(A,B,M*M) + RETURN + ENTRY COPTQ(A,B,M) + DO J=1,M + DO I=1,M + B(I,J)=A(J,I) + ENDDO + ENDDO + RETURN + ENTRY CONTQ(A,B,M) + DO J=1,M + DO I=1,M + B(I,J)=-A(J,I) + ENDDO + ENDDO + RETURN + ENTRY COPDQ(D,A,M) + CALL ZERV(A,M*M) + DO I=1,M + A(I,I)=D(I) + ENDDO + RETURN + ENTRY CONDQ(D,A,M) + CALL ZERV(A,M*M) + DO I=1,M + A(I,I)=-D(I) + ENDDO + RETURN + ENTRY COPSQ(S,A,M) + CALL ZERV(A,M*M) + DO I=1,M + A(I,I)=S + ENDDO + RETURN + ENTRY CONSQ(S,A,M) + CALL ZERV(A,M*M) + DO I=1,M + A(I,I)=-S + ENDDO + RETURN + ENTRY ADDQD(A,B,D,M) + CALL COPV(A,B,M*M) + DO I=1,M + B(I,I)=B(I,I)+D(I) + ENDDO + RETURN + ENTRY SUBQD(A,B,D,M) + CALL COPV(A,B,M*M) + DO I=1,M + B(I,I)=B(I,I)-D(I) + ENDDO + RETURN + ENTRY ADDQS(A,B,S,M) + CALL COPV(A,B,M*M) + DO I=1,M + B(I,I)=B(I,I)+S + ENDDO + RETURN + ENTRY SUBQS(A,B,S,M) + CALL COPV(A,B,M*M) + DO I=1,M + B(I,I)=B(I,I)-S + ENDDO + RETURN + ENTRY MULQS(A,B,S,M) + CALL MULVS(A,B,S,M*M) + RETURN + ENTRY MADQS(A,B,S,M) + CALL MADVS(A,B,S,M*M) + RETURN + ENTRY MSBQS(A,B,S,M) + CALL MSBVS(A,B,S,M*M) + ENTRY MULQD(A,B,D,M) + DO J=1,M + CALL MULVS(A(1,J),B(1,J),D(J),M) + ENDDO + RETURN + ENTRY MADQD(A,B,D,M) + DO J=1,M + CALL MADVS(A(1,J),B(1,J),D(J),M) + ENDDO + RETURN + ENTRY MSBQD(A,B,D,M) + DO J=1,M + CALL MSBVS(A(1,J),B(1,J),D(J),M) + ENDDO + RETURN + ENTRY MULDQ(D,A,B,M) + CALL MULDM(D,A,B,M,M,M,M) + RETURN + ENTRY MADDQ(D,A,B,M) + CALL MADDM(D,A,B,M,M,M,M) + RETURN + ENTRY MSBDQ(D,A,B,M) + CALL MSBDM(D,A,B,M,M,M,M) + RETURN + ENTRY MULQV(A,D,E,M) + CALL ZERV(E,M) + ENTRY MADQV(A,D,E,M) + DO J=1,M + CALL MADVS(A(1,J),D(J),E,M) + ENDDO + RETURN + ENTRY MSBQV(A,D,E,M) + DO J=1,M + CALL MSBVS(A(1,J),D(J),E,M) + ENDDO + RETURN + ENTRY MULVQ(D,A,E,M) + CALL ZERV(E,M) + ENTRY MADVQ(D,A,E,M) + CALL MADVM(D,A,E,M,M,M) + RETURN + ENTRY MSBVQ(D,A,E,M) + CALL MSBVM(D,A,E,M,M,M) + RETURN + END + + + + SUBROUTINE L1LM(A,B,MI,NA,NB) ! Cholesky, M -> L*U, U(i,j)=L(j,i) + DIMENSION A(NA,*),B(NB,*) + DO J=1,MI + JM=J-1 + JP=J+1 + S=A(J,J) + CALL DSBRR(B(J,1),B(J,1),S,JM,NB,NB) + IF(S.LE.0.)THEN + PRINT'('' L1LM detects non-positivity at diagonal index'',i2)',J + STOP + ENDIF + B(J,J)=SQRT(S) + BJJI=1./B(J,J) + DO I=JP,MI + S=A(I,J) + CALL DSBRR(B(I,1),B(J,1),S,JM,NB,NB) + B(I,J)=S*BJJI + ENDDO + CALL ZERV(B(1,J),JM) + ENDDO + RETURN + END + + SUBROUTINE LDLM(A,B,M,NA,NB) ! M -> L*D*U, U(i,j)=L(j,i) + DIMENSION A(NA,*),B(NB,*) + DO J=1,M + JM=J-1 + JP=J+1 + S=A(J,J) + CALL DSBVR(B(1,J),B(J,1),S,JM,NB) + B(J,J)=S + IF(S.EQ.0.)THEN + PRINT'('' LDLML detects singularity at diagonal index'',i2)',J + STOP + ENDIF + BJJI=1./S + DO I=JP,M + S=A(I,J) + CALL DSBVR(B(1,J),B(I,1),S,JM,NB) + B(J,I)=S + B(I,J)=S*BJJI + ENDDO + ENDDO + DO J=1,M + CALL ZERV(B(1,J),J-1) + ENDDO + RETURN + END + + SUBROUTINE L1LQ(A,B,M) ! Cholesky decompose Q --> L*U, U(i,j)=L(j,i) + DIMENSION A(M,M),B(M,M) ! Fortran dimensions same as matrix order. + DO J=1,M + JM=J-1 + JP=J+1 + S=A(J,J) + CALL DSBRR(B(J,1),B(J,1),S,JM,M,M) + IF(S.LE.0.)THEN + PRINT'('' L1LQ detects non-positivity at diagonal index'',i2)',J + STOP + ENDIF + B(J,J)=SQRT(S) + BJJI=1./B(J,J) + DO I=JP,M + S=A(I,J) + CALL DSBRR(B(I,1),B(J,1),S,JM,M,M) + B(I,J)=S*BJJI + ENDDO + CALL ZERV(B(1,J),JM) + ENDDO + RETURN + END + + SUBROUTINE LDLQ(A,B,M) ! Cholesky decompose Q --> L*D*U, U(i,j)=L(j,i) + DIMENSION A(M,M),B(M,M) ! "Q" signifies square matrix form, Fortran + DO J=1,M ! dimensions same as the order of the matrix. + JM=J-1 + JP=J+1 + S=A(J,J) + CALL DSBVR(B(1,J),B(J,1),S,JM,M) + B(J,J)=S + IF(S.EQ.0.)THEN + PRINT'('' LDLQ detects singularity at diagonal index'',i2)',J + STOP + ENDIF + BJJI=1./S + DO I=JP,M + S=A(I,J) + CALL DSBVR(B(1,J),B(I,1),S,JM,M) + B(J,I)=S + B(I,J)=S*BJJI + ENDDO + ENDDO + CALL ZERU(B,M) + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! SUBROUTINE DFCO +! +! Compute one row of the coefficients for either the compact differencing or +! quadrature scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! In either case, d is the derivative of c. +! +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! <-- AB: the NC=NA+NB concatenated coefficients A and B for this row +! <-- W: work-array of size NC**2. On exit, the first element contains +! a measure of the conditioning of the matrix of the linear system +! (determinant/{product of row-lengths}). +!------------------------------------------------------------------------------ + SUBROUTINE DFCO(ZA,ZB,Z0,NA,NB,AB,W) + DIMENSION ZA(*),ZB(*),AB(*),W(NA+NB,*) + NC=NA+NB + DO J=1,NA + W(1,J)=1. + W(2,J)=0. + W(3,J)=0. + Z=ZA(J)-Z0 + P=Z + DO I=4,NC + W(I,J)=P*(I-2) + P=P*Z + ENDDO + ENDDO + DO J=1,NB + W(1,NA+J)=0. + Z=ZB(J)-Z0 + P=-1. + DO I=2,NC + W(I,NA+J)=P + P=P*Z + ENDDO + ENDDO + AB(1)=1. + DO I=2,NC + AB(I)=0. + ENDDO + AB(3)=-1. + CALL LINVAN(W,AB,NC) ! Solve the linear system + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! ENTRY AVCO +! +! Compute one row of the coefficients for the compact mid-interval +! interpolation scheme characterized by matrix equation of the form, +! A.t = B.s (*) +! Where s is the vector of "source" values, t the staggered "target" values. +! +! --> ZA: coordinates of t-points used in this row of (*) +! --> ZB: coordinates of s-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! --> NA: number of t-points operated on by this row of the A of (*) +! --> NB: number of s-points operated on by this row of the B of (*) +! <-- AB: the NC=NA+NB concatenated coefficients A and B for this row +! <-- W: work-array of size NC**2. On exit, the first element contains +! a measure of the conditioning of the matrix of the linear system +! (determinant/{product of row-lengths}). +!------------------------------------------------------------------------------ + SUBROUTINE AVCO(ZA,ZB,Z0,NA,NB,AB,W) + DIMENSION ZA(*),ZB(*),AB(*),W(NA+NB,*) + NC=NA+NB + DO J=1,NA + W(1,J)=1. + Z=ZA(J)-Z0 + P=1. + DO I=2,NC + W(I,J)=P + P=P*Z + ENDDO + ENDDO + DO J=1,NB + W(1,NA+J)=0. + Z=ZB(J)-Z0 + P=-1. + DO I=2,NC + W(I,NA+J)=P + P=P*Z + ENDDO + ENDDO + AB(1)=1. + DO I=2,NC + AB(I)=0. + ENDDO + CALL LINVAN(W,AB,NC) ! Solve the linear system + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! ENTRY DFCO2 +! +! Compute one row of the coefficients for either the compact second- +! differencing scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! Where d is the second-derivative of c. +! +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! <-- AB: the NC=NA+NB concatenated coefficients A and B for this row +! <-- W: work-array of size NC**2. On exit, the first element contains +! a measure of the conditioning of the matrix of the linear system +! (determinant/{product of row-lengths}). +!------------------------------------------------------------------------------ + SUBROUTINE DFCO2(ZA,ZB,Z0,NA,NB,AB,W) + DIMENSION ZA(*),ZB(*),AB(*),W(NA+NB,*) + NC=NA+NB + DO J=1,NA + W(1,J)=1. + W(2,J)=0. + W(3,J)=0. + W(4,J)=0. + Z=ZA(J)-Z0 + P=Z + DO I=5,NC + W(I,J)=P*(I-2)*(I-3) + P=P*Z + ENDDO + ENDDO + DO J=1,NB + W(1,NA+J)=0. + Z=ZB(J)-Z0 + P=-1. + DO I=2,NC + W(I,NA+J)=P + P=P*Z + ENDDO + ENDDO + AB(1)=1. + DO I=2,NC + AB(I)=0. + ENDDO + AB(4)=-2. + CALL LINVAN(W,AB,NC) ! Solve the linear system + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, NCEP, Washington D.C. 1996 +! SUBROUTINE LDUM +! perform l-d-u decomposition of square matrix a in place with +! IMPLICIT pivoting +! +! --> a square matrix to be factorized +! <-- ipiv array encoding the pivoting sequence +! <-- d indicator for possible sign change of determinant +! --> m degree of (active part of) a +! --> na first fortran dimension of a +! +! LIMITATION: +! S is an array, internal to this routine, containing the +! scaling factors of each row used for pivoting decisions. It is given a +! fortran dimension of NN=500 in the parameter statement below. +! If the order of the linear system exceeds NN, increase NN. +!------------------------------------------------------------------------------ + SUBROUTINE LDUM(A,IPIV,D,M,NA) + PARAMETER(NN=500) + DIMENSION A(NA,*),IPIV(*),S(NN) +! IF(M.GT.NN)STOP'MATRIX TOO LARGE FOR LDUM' + IF(M.GT.NN)STOP + DO I=1,M + AAM=0. + DO J=1,M + AA=ABS(A(I,J)) + IF(AA.GT.AAM)AAM=AA + ENDDO + IF(AAM.EQ.0.)THEN + PRINT'('' ROW '',I3,'' OF MATRIX IN LUFM VANISHES'')',I + STOP + ENDIF + S(I)=1./AAM + ENDDO + D=1. + IPIV(M)=M + DO J=1,M-1 + JP=J+1 + ABIG=S(J)*ABS(A(J,J)) + IBIG=J + DO I=JP,M + AA=S(I)*ABS(A(I,J)) + IF(AA.GT.ABIG)THEN + IBIG=I + ABIG=AA + ENDIF + ENDDO +! swap rows, recording changed sign of determinant + IPIV(J)=IBIG + IF(IBIG.NE.J)THEN + D=-D + DO K=1,M + T=A(J,K) + A(J,K)=A(IBIG,K) + A(IBIG,K)=T + ENDDO + S(IBIG)=S(J) + ENDIF + AJJ=A(J,J) + IF(AJJ.EQ.0.)THEN + JM=J-1 + PRINT'('' FAILURE IN LDUM:''/'' MATRIX SINGULAR, RANK='',i3)',JM + STOP + ENDIF + AJJI=1./AJJ + DO I=JP,M + AIJ=AJJI*A(I,J) + A(I,J)=AIJ + DO K=JP,M + A(I,K)=A(I,K)-AIJ*A(J,K) + ENDDO + ENDDO + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMM +! use l-u factors in a to back-substitute for mm rhs in b, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrux +! <-> B right-hand-sides on entry, corresponding matrix of solution +! vectors on return +! --> IPIV array encoding the pivoting sequence +! --> M degree of (active part of) B and A +! --> MM number of right-hand-side vectors (active columns of B) +! --> NA first fortran dimension of A +! --> NB first fortran dimension of B +!------------------------------------------------------------------------------ + SUBROUTINE UDLMM(A,B,IPIV,M,MM,NA,NB) + DIMENSION A(NA,*),B(NB,*),IPIV(*) + DO K=1,MM !loop over columns of B + DO I=1,M + L=IPIV(I) + S=B(L,K) + B(L,K)=B(I,K) + CALL DSBVR(B(1,K),A(I,1),S,I-1,NA) + B(I,K)=S + ENDDO + B(M,K)=B(M,K)/A(M,M) + DO I=M-1,1,-1 + AIII=1./A(I,I) + CALL DSBVR(B(I+1,K),A(I,I+1),B(I,K),M-I,NA) + B(I,K)=B(I,K)*AIII + ENDDO + ENDDO + RETURN + END + + SUBROUTINE INVM(B,A,M,NB,NA) ! copy matrix B to A, in-place invert A. + PARAMETER (NN=500) + DIMENSION IPIV(NN) + DIMENSION A(NA,*),B(NB,*) + CALL COPM(B,A,M,M,NB,NA) + CALL LDUM(A,IPIV,D,M,NA) + +! INVERT U IN PLACE: + DO I=1,M + A(I,I)=1./A(I,I) + ENDDO + DO I=1,M-1 + DO J=I+1,M + CALL DOTVR(A(I,J),A(I,I),S,J-I,NA) + A(I,J)=-A(J,J)*S + ENDDO + ENDDO + +! INVERT L IN PLACE ASSUMING IMPLICITLY DIAGONAL ELEMENTS OF UNITY + DO J=1,M-1 + JP=J+1 + DO I=J+1,M + CALL DADVR(A(JP,J),A(I,JP),A(I,J),I-JP,NA) + A(I,J)=-A(I,J) + ENDDO + ENDDO + +! FORM THE PRODUCT OF U**-1 AND L**-1 IN PLACE + DO J=1,M-1 + JP=J+1 + DO I=1,J + CALL DADVR(A(JP,J),A(I,JP),A(I,J),M-J,NA) + ENDDO + DO I=JP,M + CALL DOTVR(A(I,J),A(I,I),S,M+1-I,NA) + A(I,J)=S + ENDDO + ENDDO + +! PERMUTE COLUMNS ACCORDING TO IPIV + DO J=M-1,1,-1 + L=IPIV(J) + CALL SWPVV(A(1,J),A(1,L),M) + ENDDO + RETURN + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! ENTRY LINMM +! invert linear systems sharing the same square system matrix +! +! <-> A square system matrix on entry, its L-D-U factorization on return +! <-> B right-hand-sides on entry, corresponding matrix of solution +! vectors on return +! --> M degree of (active part of) B and A +! --> MM number of right-hand-side vectors (active columns of b) +! --> NA first fortran dimension of A +! --> NB first fortran dimension of B +!------------------------------------------------------------------------------ + ENTRY LINMM(a,b,m,mm,na,nb) + CALL LDUM(A,IPIV,D,M,NA) + CALL UDLMM(A,B,IPIV,M,MM,NA,NB) + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE INVH +! Invert, possibly in place, a symmetric matrix +! +! --> B symmetric square input matrix +! <-- A inverse of B +! --> M degree of (active part of) A and B +! --> NB first fortran dimension of B +! --> NA first fortran dimension of A +! +! LIMITATION +! This routine incorporates no pivoting - it is intended for matrices +! that are already diagonally dominant +!------------------------------------------------------------------------------ + SUBROUTINE INVH(B,A,M,NB,NA) + DIMENSION B(NB,*),A(NA,*) + +! PERFORM L.D.U DECOMPOSITION OF THE SYMMETRIC MATRIX: + CALL LDLM(B,A,M,NB,NA) + +! INVERT (IN PLACE) THE LOWER TRIANGULAR PART OF A, (ASSUMING UNIT +! DIAGONAL ELEMENTS), AND INVERT THE DIAGONAL PART OF A (ASSUMING +! ZERO OFF-DIAGONAL ELEMENTS). PUT TRANSPOSE OF LOWER, TIMES DIAGONAL, +! INTO UPPER PART OF A. + DO K=1,M + KP=K+1 + A(K,K)=1./A(K,K) + DO I=KP,M + CALL DADVR(A(KP,K),A(I,KP),A(I,K),I-KP,NA) + A(I,K)=-A(I,K) + ENDDO + ENDDO + +! MULTIPLY: THE TRANSPOSE OF THE LOWER PART OF A (ASSUMING UNIT DIAGS), +! TIMES THE DIAGONAL PART (ASSUMING ZERO OFF-DIAGS), TIMES THE LOWER +! PART. THIS PRODUCT IS THE SYMMETRIC INVERSE OF THE ORIGINAL B. + DO I=2,M + CALL MULRS(A(I,1),A(I,I),A(1,I),I-1,NA,1) + ENDDO + DO I=1,M + IP=I+1 + DO J=1,I-1 + CALL DADVR(A(IP,I),A(J,IP),A(J,I),M-I,NA) + A(I,J)=A(J,I) + ENDDO + CALL DADVR(A(IP,I),A(I,IP),A(I,I),M-I,NA) + ENDDO + + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE INVL +! Invert lower triangular matrix, possibly in place if A and B are same +!------------------------------------------------------------------------------ + SUBROUTINE INVL(A,B,M,NA,NB) + DIMENSION A(NA,*),B(NB,*) + DO J=M,1,-1 + CALL ZERV(B(1,J),J-1) + B(J,J)=1./A(J,J) + DO I=J+1,M + IM=I-1 + CALL DOTVR(B(J,J),A(I,J),S,I-J,NA) + B(I,J)=-B(I,I)*S + ENDDO + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE LINLV +! Solve linear system involving lower triangular (LINLV) or upper +! triangular (LINUV) matrix, right-hand-side vector U and output vector V +! +!------------------------------------------------------------------------------ + SUBROUTINE LINLV(A,U,V,M,NA) + DIMENSION A(NA,*),U(*),V(*) + DO I=1,M + S=U(I) + CALL DSBVR(V,A(I,1),S,I-1,NA) + V(I)=S/A(I,I) + ENDDO + RETURN + ENTRY LINUV(A,U,V,M,NA) + DO J=M,1,-1 + JP=J+1 + S=U(J) + CALL DSBVV(A(JP,J),V(JP),S,M-J) + V(J)=S/A(J,J) + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! SUBROUTINE LINVAN +! +! Take square matrix W and seek row and column scalings to produce non- +! vanishing elements of rescaled W having magnitudes as close to unity +! as possible. The approach is make the geometric mean of the nonvanishing +! elements of each row and of each column +1 or -1. Having rescaled the +! matrix and the r.h.s. vector AB, compute the product P of row-vector +! norms, then compute the determinant D and solve the linear system. +! Rescale the solution vector (now AB) and put the conditioning indicator +! formed by the ratio D/P into the first element of W. +! +! <-> W: Generalized Vandermonde matrix in, conditioning indicator out. +! <-> AB: R.h.s. vector in, solution vector of numerical coefficients out. +! --> NC: Order of the linear problem. +!------------------------------------------------------------------------------ + SUBROUTINE LINVAN(W,AB,NC) + PARAMETER(NN=20,NIT=20) + DIMENSION W(NC,*),AB(NC),D1(NN),D2(NN),IPIV(NN)& + ,W2(NN,NN),V(NN) + CALL COPM(W,W2,NC,NC,NC,NN) ! Preserve original W and AB for use + CALL COPV(AB,V,NC) ! in later "clean-up" operation. + + DO I=1,NC + D1(I)=1. ! Row scaling factors set to default + D2(I)=1. ! Column scaling factors set to default + ENDDO + C=1.E-16 ! Set initial criterion for "negligible" elements of W + +! In first attempt to estimate row and column scalings, use logarithms +! to avoid the risk of under- or over-flows of the line products of W: + DO I=1,NC + P=0. + E=0. + DO J=1,NC + DW=ABS(W(I,J)) + IF(DW.GT.C)THEN + E=E+1. + P=P+LOG(DW) + ENDIF + ENDDO +! IF(E.EQ.0.)STOP'W effectively singular in LINVAN' + IF(E.EQ.0.)STOP + D1(I)=EXP(-P/E) + ENDDO + CALL MULVX(D1,W2,W,NC,NC,NN,NC) ! Rescale rows of W by D1 + + DO J=1,NC + P=0. + E=0. + DO I=1,NC + DW=ABS(W(I,J)) + IF(DW.GT.C)THEN + E=E+1. + P=P+LOG(DW) + ENDIF + ENDDO +! IF(E.EQ.0.)STOP'W effectively singular in LINVAN' + IF(E.EQ.0.)STOP + D2(J)=EXP(-P/E) + ENDDO + CALL MULVY(D2,W,W,NC,NC,NC,NC) ! Rescale columns of W by D2 + + C=1.E-8 ! reset the criterion for "negligible" elements + +! Revert to iterations of the more efficient method without logarithms: + DO JT=1,2 + DO IT=1,NIT ! Perform NIT relaxation iterations + DO I=1,NC ! Do rows: + P=1. + E=0. + DO J=1,NC + DW=ABS(W(I,J)) + IF(DW.GT.C)THEN + E=E+1. + P=P*DW + ENDIF + ENDDO + P=1./(P**(1./E)) + CALL MULRS(W(I,1),P,W(I,1),NC,NC,NC) ! Rescale this row of W.. + D1(I)=D1(I)*P ! ..and update D1 consistently + ENDDO + DO J=1,NC ! Do columns: + P=1. + E=0. + D2J=D2(J) + DO I=1,NC + DW=ABS(W(I,J)) + IF(DW.GT.C)THEN + E=E+1. + P=P*DW + ENDIF + ENDDO + P=1./(P**(1./E)) + CALL MULVS(W(1,J),P,W(1,J),NC) ! Rescale this column of W.. + D2(J)=D2(J)*P ! ..and update D2 consistently + ENDDO + ENDDO + C=1.E-3 ! Final setting for criterion for "negligible" elements + ENDDO + CALL MULVV(D1,AB,AB,NC) ! Rescale r.h.s vector by D1 + P=1. ! P becomes product of row-lengths: + DO I=1,NC + CALL NORR(W(I,1),S,NC,NC) + P=P*S + ENDDO + CALL LDUM(W,IPIV,D,NC,NC) + DO I=1,NC + D=D*W(I,I) ! D becomes the determinant of W + ENDDO + CALL UDLMM(W,AB,IPIV,NC,1,NC,NC) + CALL MULVV(AB,D2,AB,NC) ! Rescale solution vector by D2 +! Note: it is very likely that round-off errors have accumulated during +! the iterative rescaling of W. We invoke original matrix elements W2 and +! substitute the tentative solution vector into the original (unscaled) +! equation in order to estimate the residual components of roundoff error. + +! Begin "clean-up" process. Substitute solution vector in original +! equation and leave the residual difference in V + CALL MSBMM(W2,AB,V,NC,NC,1,NN,NC,NC) + CALL MULVV(V,D1,V,NC) ! Rescale the residual vector by D1 + CALL UDLMM(W,V,IPIV,NC,1,NC,NC) ! Solve linear system with THIS rhs. + CALL MADVV(V,D2,AB,NC) ! Add residual solution vector, scaled, to AB + ! This will remove most of the round-off error. + W(1,1)=D/P ! this ratio is an indicator of the overall conditioning + RETURN ! When D/P is very small, treat the results with suspicion! + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE LDUB +! Compute [L]*[D**-1]*[U] decomposition of asymmetric band-matrix +! +! <-> A input as the asymmetric band matrix. On output, it contains +! the [L]*[D**-1]*[U] factorization of the input matrix, where +! [L] is lower triangular with unit main diagonal +! [D] is a diagonal matrix +! [U] is upper triangular with unit main diagonal +! --> M the number of rows assumed for [A] +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> NA the first fortran dimension of A +!------------------------------------------------------------------------------ + SUBROUTINE LDUB(A,M,MAH1,MAH2,NA) + DIMENSION A(NA,-MAH1:MAH2) + DO J=1,M + IMOST=MIN(M,J+MAH1) + JMOST=MIN(M,J+MAH2) + JP=J+1 + AJJ=A(J,0) + IF(AJJ.EQ.0.)THEN + PRINT'('' Failure in LDUB:''/'' Matrix requires pivoting or is singular'')' + STOP + ENDIF + AJJI=1./AJJ + A(J,0)=AJJI + DO I=JP,IMOST + AIJ=AJJI*A(I,J-I) + A(I,J-I)=AIJ + DO K=JP,JMOST + A(I,K-I)=A(I,K-I)-AIJ*A(J,K-J) + ENDDO + ENDDO + DO K=JP,JMOST + A(J,K-J)=AJJI*A(J,K-J) + ENDDO + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE L1UBB +! Form the [L]*[D]*[U] decomposition of asymmetric band-matrix [A] replace +! lower triangular elements of [A] by [D**-1]*[L]*[D], the upper by [U], +! replace matrix [B] by [D**-1]*[B]. +! +! <-> A input as band matrix, output as lower and upper triangulars with 1s +! implicitly assumed to lie on the main diagonal. The product of these +! triangular matrices is [D**-1]*[A], where [D] is a diagonal matrix. +! <-> B in as band matrix, out as same but premultiplied by diagonal [D**-1] +! --> M number of rows of A and B +! --> MAH1 left half-width of fortran array A +! --> MAH2 right half-width of fortran array A +! --> MBH1 left half-width of fortran array B +! --> MBH2 right half-width of fortran array B +! --> NA first fortran dimension of A +! --> NB first fortran dimension of B +!------------------------------------------------------------------------------ + SUBROUTINE L1UBB(A,B,M,MAH1,MAH2,MBH1,MBH2,NA,NB) + DIMENSION A(NA,-MAH1:MAH2),B(NB,-MBH1:MBH2) + DO J=1,M + IMOST=MIN(M,J+MAH1) + JMOST=MIN(M,J+MAH2) + JLEAST=MAX(1,J-MAH1) + JP=J+1 + AJJ=A(J,0) +! IF(AJJ.EQ.0.)STOP'failure in L1UBB' + IF(AJJ.EQ.0.)STOP + AJJI=1./AJJ + DO K=JLEAST,JMOST + A(J,K-J)=AJJI*A(J,K-J) + ENDDO + DO I=JP,IMOST + AIJ=A(I,J-I) + DO K=JP,JMOST + A(I,K-I)=A(I,K-I)-AIJ*A(J,K-J) + ENDDO + ENDDO + A(J,0)=1. + DO K=-MBH1,MBH2 + B(J,K)=AJJI*B(J,K) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE MULVX(D,V1,V2,M,MY,NV1,NV2) + DIMENSION D(M),V1(NV1,MY),V2(NV2,MY) + DO I=1,M + DI=D(I) + DO IY=1,MY + V2(I,IY)=DI*V1(I,IY) + ENDDO + ENDDO + RETURN + ENTRY MADVX(D,V1,V2,M,MY,NV1,NV2) + DO I=1,M + DI=D(I) + DO IY=1,MY + V2(I,IY)=V2(I,IY)+DI*V1(I,IY) + ENDDO + ENDDO + RETURN + ENTRY MSBVX(D,V1,V2,M,MY,NV1,NV2) + DO I=1,M + DI=D(I) + DO IY=1,MY + V2(I,IY)=V2(I,IY)-DI*V1(I,IY) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE MULVY(D,V1,V2,M,MX,NV1,NV2) + DIMENSION D(M),V1(NV1,M),V2(NV2,M) + DO I=1,M + DI=D(I) + DO IX=1,MX + V2(IX,I)=DI*V1(IX,I) + ENDDO + ENDDO + RETURN + ENTRY MADVY(D,V1,V2,M,MX,NV1,NV2) + DO I=1,M + DI=D(I) + DO IX=1,MX + V2(IX,I)=V2(IX,I)+DI*V1(IX,I) + ENDDO + ENDDO + RETURN + ENTRY MSBVY(D,V1,V2,M,MX,NV1,NV2) + DO I=1,M + DI=D(I) + DO IX=1,MX + V2(IX,I)=V2(IX,I)-DI*V1(IX,I) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE SUMM(A,S,MI,MJ,NA) + DIMENSION A(NA,*),D(*) + S=0. + DO J=1,MJ + DO I=1,MI + S=S+A(I,J) + ENDDO + ENDDO + RETURN + ENTRY SUMR(A,S,M,NA) + S=0. + DO J=1,M + S=S+A(1,J) + ENDDO + RETURN + ENTRY SUMV(D,S,M) + S=0. + DO I=1,M + S=S+D(I) + ENDDO + RETURN + ENTRY SUMQ(A,S,NA) + S=0. + DO J=1,NA + DO I=1,NA + S=S+A(I,J) + ENDDO + ENDDO + RETURN + END +! ***************** +! * MAT3.FOR * +! * PURSER 1993 * +! ***************** +! DOUBLE PRECISION VERSIONS OF ROUTINES IN MAT1.FOR +! Routines for basic algebraic operations on general matrices and vectors +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! These routines, perform basic algebraic operations on real vectors and +! matrices. The task performed by each routine is, as far as possible, +! encoded in each routine's name; three letters describe the +! operation, the remainder defining the type of operand and, if needed to +! an ambiguity, the type of result. +! +! OPERATIONS: +! ADD add first two operands, return result as third argument +! CON copy negative +! COP copy positive +! DAD dot product of first two operands added to third +! DET evaluate log-determinant +! DIF differentiate +! DIV divide first operand by second +! DOT dot product of first two operands +! DSB dot product of first two operands subtracted from third +! FDA folded dot product of first two operands added to third +! FDO "flip" (reverse order of) 1st operand and form dot product with 2nd +! FDS "flip" 1st operand, dot product with 2nd, subtract result from 3rd +! INT integrate +! INV invert the matrix, or linear system involving the matrix operand +! L1L Cholesky LU decomposition, where U is just L-transpose +! L1U L-U decomposition of first arg, with 1's along diagonal of L and U +! LDL Cholesky LDU decomposition, where U is just L-transpose and D diag. +! LDU LDU decomposition +! MAD multiply first two operands, but then add result to third +! MUL multiply first two operands, return result as third argument +! MSB multiply first two operands, but then subtract result from third +! NEG replace operand by its negative +! NOR evaluate norm of operand +! POL polynomial (first argument) of second argument +! POW raise operand to some integer power +! SUB subtract first two operands, return result as third argument +! SWP swap first two operands +! TPS replace operand by its transpose +! TRC evaluate trace of operand +! U1L back substitution with matrix decomposed into LU form, 1's on diag. +! UDL back substitution with matrix decomposed into LDU form +! WRT write out +! ZER set operand to zero +! +! OPERAND TYPES: +! B banded matrix +! C circulant matrix +! D diagonal matrix +! H symmetric or hermitian matrix +! L lower triangular matrix +! M matrix (rectangular, in general) +! P polynomial or power-series coefficient vector +! Q sQuare matrix with Fortan dimension same as logical dimension +! R row of a matrix +! S scalar +! T transpose of the matrix +! U upper triangular matrix +! V vector, or column of a matrix +! X field of parallel X-vectors (aligned like "columns" of a matrix) +! Y field of parallel Y-vectors (aligned like "rows" of a matrix) +! +! For those matrix routines with a "Q" in the last part of the name, +! denoting operation upon a square matrix, the Fortran dimensions and +! matrix order are implicitly assumed identical. If this is not the case, +! the general matrix routines, (those without a "Q" in the name) allow +! the arguments, MI, MJ, which denote the algebraic dimensions, to be +! different from each other (for rectangular matrices) and different from +! the Fortran dimensions NA, NB, etc., which are therefore listed as +! additional parameters. +! +!------------------------------------------------------------------------------ + SUBROUTINE DZERV(D,M) ! set elements of a vector to zero + DIMENSION D(M) + DO I=1,M + D(I)=0. + ENDDO + RETURN + ENTRY DNEGV(D,M) ! Replace vector by its negative + DO I=1,M + D(I)=-D(I) + ENDDO + RETURN + ENTRY DCOPSD(S,D,M) ! Copy a scalar to a diagonal matrix + DO I=1,M + D(I)=S + ENDDO + RETURN + ENTRY DCONSD(S,D,M) ! Copy negative of a scalar to a diagonal + DO I=1,M + D(I)=-S + ENDDO + RETURN + END + SUBROUTINE DZERM(A,MI,MJ,NA) ! Set the elements of general matrix to 0 + DIMENSION A(NA,*) + DO J=1,MJ + CALL DZERV(A(1,J),MI) + ENDDO + RETURN + ENTRY DNEGM(A,MI,MJ,NA) ! Replace general matrix A by its negative + DO J=1,MJ + CALL DNEGV(A(1,J),MI) + ENDDO + RETURN + END + + SUBROUTINE DZERR(A,M,NA) + DIMENSION A(NA,*) + DO I=1,M + A(1,I)=0. + ENDDO + RETURN + END + + SUBROUTINE DCOPR(A,B,M,NA,NB) + DIMENSION A(NA,M),B(NB,M) + DO I=1,M + B(1,I)=A(1,I) + ENDDO + RETURN + ENTRY DCONR(A,B,M,NA,NB) + DO I=1,M + B(1,I)=-A(1,I) + ENDDO + RETURN + END + + SUBROUTINE DMULVS(D,S,E,M) + DIMENSION D(*),E(*) + DO I=1,M + E(I)=D(I)*S + ENDDO + RETURN + ENTRY DMADVS(D,S,E,M) + DO I=1,M + E(I)=E(I)+D(I)*S + ENDDO + RETURN + ENTRY DMSBVS(D,S,E,M) + DO I=1,M + E(I)=E(I)-D(I)*S + ENDDO + RETURN + END + + SUBROUTINE DMULRS(A,S,B,M,NA,NB) + DIMENSION A(NA,*),B(NB,*) + DO I=1,M + B(1,I)=A(1,I)*S + ENDDO + RETURN + ENTRY DMADRS(A,S,B,M,NA,NB) + DO I=1,M + B(1,I)=B(1,I)+A(1,I)*S + ENDDO + RETURN + ENTRY DMSBRS(A,S,B,M,NA,NB) + DO I=1,M + B(1,I)=B(1,I)-A(1,I)*S + ENDDO + RETURN + END + + FUNCTION DDOT(D,E,M) + DIMENSION D(M),E(M) + DDOT=0. + DO I=1,M + DDOT=DDOT+D(I)*E(I) + ENDDO + RETURN + END + + SUBROUTINE DDOTVV(D,E,S,M) + DIMENSION D(M),E(M) + S=0. + ENTRY DDADVV(D,E,S,M) + DO I=1,M + S=S+D(I)*E(I) + ENDDO + RETURN + ENTRY DDSBVV(D,E,S,M) + DO I=1,M + S=S-D(I)*E(I) + ENDDO + RETURN + END + + SUBROUTINE DDOTVR(D,A,S,M,NA) + DIMENSION D(M),A(NA,*) + S=0. + ENTRY DDADVR(D,A,S,M,NA) + DO I=1,M + S=S+D(I)*A(1,I) + ENDDO + RETURN + ENTRY DDSBVR(D,A,S,M,NA) + DO I=1,M + S=S-D(I)*A(1,I) + ENDDO + RETURN + END + + SUBROUTINE DDOTRR(A,B,S,M,NA,NB) + DIMENSION A(NA,*),B(NB,*) + S=0. + ENTRY DDADRR(A,B,S,M,NA,NB) + DO I=1,M + S=S+A(1,I)*B(1,I) + ENDDO + RETURN + ENTRY DDSBRR(A,B,S,M,NA,NB) + DO I=1,M + S=S-A(1,I)*B(1,I) + ENDDO + RETURN + END + + FUNCTION DPRO333(D,E,F) ! TRIPLE PRODUCT OF 3 3-VECTORS + DIMENSION D(3),E(3),F(3),G(3) + CALL DCRO33(E,F,G) + CALL DDOTVV(D,G,DPRO333,3) + RETURN + END + + SUBROUTINE DNORV(D,S,M) ! NORM OF VECTOR.. + DIMENSION D(M) + S=SQRT(DDOT(D,D,M)) + RETURN + ENTRY DNORQ(D,S,M) ! ...OF SQUARE MATRIX. + S=SQRT(DDOT(Q,Q,M*M)) + RETURN + END + + SUBROUTINE DNORR(A,S,M,NA) + DIMENSION A(NA,M) + CALL DDOTRR(A,A,S,M,NA,NA) + S=SQRT(S) + RETURN + END + + SUBROUTINE DCRO33(A,B,C) ! SPECIAL CASE OF 3-DIMENSIONS: CROSS-PRODUCT + DIMENSION A(3),B(3),C(3) + C(1)=A(2)*B(3)-A(3)*B(2) + C(2)=A(3)*B(1)-A(1)*B(3) + C(3)=A(1)*B(2)-A(2)*B(1) + RETURN + END + + SUBROUTINE DMULVV(A,B,C,M) + DIMENSION A(*),B(*),C(*) + DO I=1,M + C(I)=A(I)*B(I) + ENDDO + RETURN + ENTRY DMADVV(A,B,C,M) + DO I=1,M + C(I)=C(I)+A(I)*B(I) + ENDDO + RETURN + ENTRY DMSBVV(A,B,C,M) + DO I=1,M + C(I)=C(I)-A(I)*B(I) + ENDDO + RETURN + ENTRY DADDVV(A,B,C,M) + DO I=1,M + C(I)=A(I)+B(I) + ENDDO + RETURN + ENTRY DSUBVV(A,B,C,M) + DO I=1,M + C(I)=A(I)-B(I) + ENDDO + RETURN + ENTRY DDIVVV(A,B,C,M) + DO I=1,M + C(I)=A(I)/B(I) + ENDDO + RETURN + ENTRY DCOPV(A,B,M) + DO I=1,M + B(I)=A(I) + ENDDO + RETURN + ENTRY DCONV(A,B,M) + DO I=1,M + B(I)=-A(I) + ENDDO + RETURN + END + + SUBROUTINE DSWPVV(D,E,M) + DIMENSION D(M),E(M) + DO I=1,M + T=D(I) + D(I)=E(I) + E(I)=T + ENDDO + RETURN + END + + SUBROUTINE DSWPRR(A,B,M,NA,NB) ! Row swap + DIMENSION A(NA,*),B(NB,*) + DO J=1,M + T=A(1,J) + A(1,J)=B(1,J) + B(1,J)=T + ENDDO + RETURN + END + + SUBROUTINE DTPSM(A,MI,MJ,NA) ! Transpose, in place, a general matrix + DIMENSION A(NA,*) + M=MAX(MI,MJ) + IF(M.GT.NA)STOP +! &'first array bound in DTPSM too small to allow transpose to fit' + NAP=NA+1 + DO I=1,M-1 + IP=I+1 + CALL DSWPRR(A(IP,1),A(1,IP),M-I,NAP,NAP) + ENDDO + RETURN + END + + SUBROUTINE DMULMV(A,D,E,MI,MJ,NA) + DIMENSION A(NA,*),D(*),E(*) + CALL DZERV(E,MJ) + ENTRY DMADMV(A,D,E,MI,MJ,NA) + DO J=1,MJ + CALL DMADVS(A(1,J),D(J),E,MI) + ENDDO + RETURN + ENTRY DMSBMV(A,D,E,MI,MJ,NA) + DO J=1,MJ + CALL DMSBVS(A(1,J),D(J),E,MI) + ENDDO + RETURN + END + + SUBROUTINE DMULVM(D,A,E,MI,MJ,NA) + DIMENSION A(NA,*),D(*),E(*) + CALL DZERV(E,MJ) + ENTRY DMADVM(D,A,E,MI,MJ,NA) + DO I=1,MI + CALL DMADRS(A,D(I),E,MJ,NA,1) + ENDDO + RETURN + ENTRY DMSBVM(D,A,E,MI,MJ,NA) + DO I=1,MI + CALL DMSBRS(A,D(I),E,MJ,NA,1) + ENDDO + RETURN + END + + SUBROUTINE DMULMM(A,B,C,MI,MJ,MK,NA,NB,NC) + DIMENSION A(NA,*),B(NB,*),C(NC,*) + CALL DZERM(C,MI,MK,NC) + ENTRY DMADMM(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL DMADVS(A(1,J),B(J,K),C(1,K),MI) + ENDDO + ENDDO + RETURN + ENTRY DMSBMM(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL DMSBVS(A(1,J),B(J,K),C(1,K),MI) + ENDDO + ENDDO + RETURN + + ENTRY DMULMT(A,B,C,MI,MJ,MK,NA,NB,NC) + CALL DZERM(C,MI,MK,NC) + ENTRY DMADMT(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL DMADVS(A(1,J),B(K,J),C(1,K),MI) + ENDDO + ENDDO + RETURN + ENTRY DMSBMT(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL DMSBVS(A(1,J),B(K,J),C(1,K),MI) + ENDDO + ENDDO + RETURN + + ENTRY DMULTM(A,B,C,MI,MJ,MK,NA,NB,NC) + CALL DZERM(C,MI,MK,NC) + ENTRY DMADTM(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL DMADRS(A(J,1),B(J,K),C(1,K),MI,NA,1) + ENDDO + ENDDO + RETURN + ENTRY DMSBTM(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL DMSBRS(A(J,1),B(J,K),C(1,K),MI,NA,1) + ENDDO + ENDDO + RETURN + + ENTRY DMULTT(A,B,C,MI,MJ,MK,NA,NB,NC) + CALL DZERM(C,MI,MK,NC) + ENTRY DMADTT(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL DMADRS(A(J,1),B(K,J),C(1,K),MI,NA,1) + ENDDO + ENDDO + RETURN + ENTRY DMSBTT(A,B,C,MI,MJ,MK,NA,NB,NC) + DO K=1,MK + DO J=1,MJ + CALL DMSBRS(A(J,1),B(K,J),C(1,K),MI,NA,1) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE DADDMM(A,B,C,MI,MJ,NA,NB,NC) + DIMENSION A(NA,*),B(NB,*),C(NC,*) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(I,J)+B(I,J) + ENDDO + ENDDO + RETURN + ENTRY DADDMT(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(I,J)+B(J,I) + ENDDO + ENDDO + RETURN + ENTRY DADDTM(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(J,I)+B(I,J) + ENDDO + ENDDO + RETURN + ENTRY DADDTT(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(J,I)+B(J,I) + ENDDO + ENDDO + RETURN + ENTRY DSUBMM(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(I,J)-B(I,J) + ENDDO + ENDDO + RETURN + ENTRY DSUBMT(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(I,J)-B(J,I) + ENDDO + ENDDO + RETURN + ENTRY DSUBTM(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(J,I)-B(I,J) + ENDDO + ENDDO + RETURN + ENTRY DSUBTT(A,B,C,MI,MJ,NA,NB,NC) + DO J=1,MJ + DO I=1,MI + C(I,J)=A(J,I)-B(J,I) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE DL1LM(A,B,MI,NA,NB) ! Cholesky, M -> L*U, U(i,j)=L(j,i) + DIMENSION A(NA,*),B(NB,*) + DO J=1,MI + JM=J-1 + JP=J+1 + S=A(J,J) + CALL DDSBRR(B(J,1),B(J,1),S,JM,NB,NB) + IF(S.LE.0.)THEN + PRINT'('' DL1LM detects non-positivity at diagonal index'',i2)',J + STOP + ENDIF + B(J,J)=SQRT(S) + BJJI=1./B(J,J) + DO I=JP,MI + S=A(I,J) + CALL DDSBRR(B(I,1),B(J,1),S,JM,NB,NB) + B(I,J)=S*BJJI + ENDDO + CALL DZERV(B(1,J),JM) + ENDDO + RETURN + END + + SUBROUTINE DLDLM(A,B,M,NA,NB) ! M -> L*D*U, U(i,j)=L(j,i) + DIMENSION A(NA,*),B(NB,*) + DO J=1,M + JM=J-1 + JP=J+1 + S=A(J,J) + CALL DDSBVR(B(1,J),B(J,1),S,JM,NB) + B(J,J)=S + IF(S.EQ.0.)THEN + PRINT'('' DLDLM detects singularity at diagonal index'',i2)',J + STOP + ENDIF + BJJI=1./S + DO I=JP,M + S=A(I,J) + CALL DDSBVR(B(1,J),B(I,1),S,JM,NB) + B(J,I)=S + B(I,J)=S*BJJI + ENDDO + ENDDO + DO J=1,M + CALL DZERV(B(1,J),J-1) + ENDDO + RETURN + END + + SUBROUTINE DCOPM(A,B,MI,MJ,NA,NB) + DIMENSION A(NA,*),B(NB,*) + DO J=1,MJ + DO I=1,MI + B(I,J)=A(I,J) + ENDDO + ENDDO + RETURN + ENTRY DCONM(A,B,MI,MJ,NA,NB) + DO J=1,MJ + DO I=1,MI + B(I,J)=-A(I,J) + ENDDO + ENDDO + RETURN + ENTRY DMULMS(A,SS,B,MI,MJ,NA,NB) + DO J=1,MJ + DO I=1,MI + B(I,J)=A(I,J)*SS + ENDDO + ENDDO + RETURN + ENTRY DCOPT(A,B,MI,MJ,NA,NB) + DO J=1,MJ + DO I=1,MI + B(I,J)=A(J,I) + ENDDO + ENDDO + RETURN + ENTRY DCONT(A,B,MI,MJ,NA,NB) + DO J=1,MJ + DO I=1,MI + B(I,J)=-A(J,I) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE DMULMD(A,D,B,MI,MJ,NA,NB) + DIMENSION A(NA,*),B(NB,*),D(*) + DO J=1,MJ + CALL DMULVS(A(1,J),D(J),B(1,J),MI) + ENDDO + RETURN + ENTRY DMULTD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL DMULRS(A(J,1),D(J),B(1,J),MI,NA,1) + ENDDO + RETURN + ENTRY DMULDM(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL DMULRS(A(I,1),D(I),B(I,1),MJ,NA,NB) + ENDDO + RETURN + ENTRY DMULDT(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL DMULRS(A(1,I),D(I),B(I,1),MJ,1,NB) + ENDDO + RETURN + ENTRY DMADMD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL DMADVS(A(1,J),D(J),B(1,J),MI) + ENDDO + RETURN + ENTRY DMADTD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL DMADRS(A(J,1),D(J),B(1,J),MI,NA,1) + ENDDO + RETURN + ENTRY DMADDM(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL DMADRS(A(I,1),D(I),B(I,1),MJ,NA,NB) + ENDDO + RETURN + ENTRY DMADDT(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL DMADRS(A(1,I),D(I),B(I,1),MJ,1,NB) + ENDDO + RETURN + ENTRY DMSBMD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL DMSBVS(A(1,J),D(J),B(1,J),MI) + ENDDO + RETURN + ENTRY DMSBTD(A,D,B,MI,MJ,NA,NB) + DO J=1,MJ + CALL DMSBRS(A(J,1),D(J),B(1,J),MI,NA,1) + ENDDO + RETURN + ENTRY DMSBDM(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL DMSBRS(A(I,1),D(I),B(I,1),MJ,NA,NB) + ENDDO + RETURN + ENTRY DMSBDT(D,A,B,MI,MJ,NA,NB) + DO I=1,MI + CALL DMSBRS(A(1,I),D(I),B(I,1),MJ,1,NB) + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, NCEP, Washington D.C. 1996 +! SUBROUTINE DLDUM +! perform l-d-u decomposition of square matrix a in place with +! IMPLICIT pivoting +! +! --> a square matrix to be factorized +! <-- ipiv array encoding the pivoting sequence +! <-- d indicator for possible sign change of determinant +! --> m degree of (active part of) a +! --> na first fortran dimension of a +! +! LIMITATION: +! S is an array, internal to this routine, containing the +! scaling factors of each row used for pivoting decisions. It is given a +! fortran dimension of NN=500 in the parameter statement below. +! If the order of the linear system exceeds NN, increase NN. +!------------------------------------------------------------------------------ + SUBROUTINE DLDUM(A,IPIV,D,M,NA) + PARAMETER(NN=500) + DIMENSION A(NA,*),IPIV(*),S(NN) +! IF(M.GT.NN)STOP'MATRIX TOO LARGE FOR LDUM' + IF(M.GT.NN)STOP + DO I=1,M + AAM=0. + DO J=1,M + AA=ABS(A(I,J)) + IF(AA.GT.AAM)AAM=AA + ENDDO + IF(AAM.EQ.0.)THEN + PRINT'('' ROW '',I3,'' OF MATRIX IN LUFM VANISHES'')',I + STOP + ENDIF + S(I)=1./AAM + ENDDO + D=1. + IPIV(M)=M + DO J=1,M-1 + JP=J+1 + ABIG=S(J)*ABS(A(J,J)) + IBIG=J + DO I=JP,M + AA=S(I)*ABS(A(I,J)) + IF(AA.GT.ABIG)THEN + IBIG=I + ABIG=AA + ENDIF + ENDDO +! swap rows, recording changed sign of determinant + IPIV(J)=IBIG + IF(IBIG.NE.J)THEN + D=-D + DO K=1,M + T=A(J,K) + A(J,K)=A(IBIG,K) + A(IBIG,K)=T + ENDDO + S(IBIG)=S(J) + ENDIF + AJJ=A(J,J) + IF(AJJ.EQ.0.)THEN + JM=J-1 + PRINT'('' FAILURE IN LDUM:''/'' MATRIX SINGULAR, RANK='',i3)',JM + STOP + ENDIF + AJJI=1./AJJ + DO I=JP,M + AIJ=AJJI*A(I,J) + A(I,J)=AIJ + DO K=JP,M + A(I,K)=A(I,K)-AIJ*A(J,K) + ENDDO + ENDDO + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE DUDLMM +! use l-u factors in a to back-substitute for mm rhs in b, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrux +! <-> B right-hand-sides on entry, corresponding matrix of solution +! vectors on return +! --> IPIV array encoding the pivoting sequence +! --> M degree of (active part of) B and A +! --> MM number of right-hand-side vectors (active columns of B) +! --> NA first fortran dimension of A +! --> NB first fortran dimension of B +!------------------------------------------------------------------------------ + SUBROUTINE DUDLMM(A,B,IPIV,M,MM,NA,NB) + DIMENSION A(NA,*),B(NB,*),IPIV(*) + DO K=1,MM !loop over columns of B + DO I=1,M + L=IPIV(I) + S=B(L,K) + B(L,K)=B(I,K) + CALL DDSBVR(B(1,K),A(I,1),S,I-1,NA) + B(I,K)=S + ENDDO + B(M,K)=B(M,K)/A(M,M) + DO I=M-1,1,-1 + AIII=1./A(I,I) + CALL DDSBVR(B(I+1,K),A(I,I+1),B(I,K),M-I,NA) + B(I,K)=B(I,K)*AIII + ENDDO + ENDDO + RETURN + END +! WD23JP +! ***************** +! * MAT4.FOR * +! * PURSER 1996 * +! ***************** +! + SUBROUTINE DINVM(B,A,M,NB,NA) ! copy matrix B to A, in-place invert A. + PARAMETER (NN=500) + DIMENSION IPIV(NN) + DIMENSION A(NA,*),B(NB,*) + CALL DCOPM(B,A,M,M,NB,NA) + CALL DLDUM(A,IPIV,D,M,NA) + +! INVERT U IN PLACE: + DO I=1,M + A(I,I)=1./A(I,I) + ENDDO + DO I=1,M-1 + DO J=I+1,M + CALL DDOTVR(A(I,J),A(I,I),S,J-I,NA) + A(I,J)=-A(J,J)*S + ENDDO + ENDDO + +! INVERT L IN PLACE ASSUMING IMPLICITLY DIAGONAL ELEMENTS OF UNITY + DO J=1,M-1 + JP=J+1 + DO I=J+1,M + CALL DDADVR(A(JP,J),A(I,JP),A(I,J),I-JP,NA) + A(I,J)=-A(I,J) + ENDDO + ENDDO + +! FORM THE PRODUCT OF U**-1 AND L**-1 IN PLACE + DO J=1,M-1 + JP=J+1 + DO I=1,J + CALL DDADVR(A(JP,J),A(I,JP),A(I,J),M-J,NA) + ENDDO + DO I=JP,M + CALL DDOTVR(A(I,J),A(I,I),S,M+1-I,NA) + A(I,J)=S + ENDDO + ENDDO + +! PERMUTE COLUMNS ACCORDING TO IPIV + DO J=M-1,1,-1 + L=IPIV(J) + CALL DSWPVV(A(1,J),A(1,L),M) + ENDDO + RETURN +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! ENTRY DLINMM +! invert linear systems sharing the same square system matrix +! +! <-> A square system matrix on entry, its L-D-U factorization on return +! <-> B right-hand-sides on entry, corresponding matrix of solution +! vectors on return +! --> M degree of (active part of) B and A +! --> MM number of right-hand-side vectors (active columns of b) +! --> NA first fortran dimension of A +! --> NB first fortran dimension of B +!------------------------------------------------------------------------------ + ENTRY DLINMM(a,b,m,mm,na,nb) + CALL DLDUM(A,IPIV,D,M,NA) + CALL DUDLMM(A,B,IPIV,M,MM,NA,NB) + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE DINVH +! Invert, possibly in place, a symmetric matrix +! +! --> B symmetric square input matrix +! <-- A inverse of B +! --> M degree of (active part of) A and B +! --> NB first fortran dimension of B +! --> NA first fortran dimension of A +! +! LIMITATION +! This routine incorporates no pivoting - it is intended for matrices +! that are already diagonally dominant +!------------------------------------------------------------------------------ + SUBROUTINE DINVH(B,A,M,NB,NA) + DIMENSION B(NB,*),A(NA,*) + +! PERFORM L.D.U DECOMPOSITION OF THE SYMMETRIC MATRIX: + CALL DLDLM(B,A,M,NB,NA) + +! INVERT (IN PLACE) THE LOWER TRIANGULAR PART OF A, (ASSUMING UNIT +! DIAGONAL ELEMENTS), AND INVERT THE DIAGONAL PART OF A (ASSUMING +! ZERO OFF-DIAGONAL ELEMENTS). PUT TRANSPOSE OF LOWER, TIMES DIAGONAL, +! INTO UPPER PART OF A. + DO K=1,M + KP=K+1 + A(K,K)=1./A(K,K) + DO I=KP,M + CALL DDADVR(A(KP,K),A(I,KP),A(I,K),I-KP,NA) + A(I,K)=-A(I,K) + ENDDO + ENDDO + +! MULTIPLY: THE TRANSPOSE OF THE LOWER PART OF A (ASSUMING UNIT DIAGS), +! TIMES THE DIAGONAL PART (ASSUMING ZERO OFF-DIAGS), TIMES THE LOWER +! PART. THIS PRODUCT IS THE SYMMETRIC INVERSE OF THE ORIGINAL B. + DO I=2,M + CALL DMULRS(A(I,1),A(I,I),A(1,I),I-1,NA,1) + ENDDO + DO I=1,M + IP=I+1 + DO J=1,I-1 + CALL DDADVR(A(IP,I),A(J,IP),A(J,I),M-I,NA) + A(I,J)=A(J,I) + ENDDO + CALL DDADVR(A(IP,I),A(I,IP),A(I,I),M-I,NA) + ENDDO + + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE DINVL +! Invert lower triangular matrix, possibly in place if A and B are same +!------------------------------------------------------------------------------ + SUBROUTINE DINVL(A,B,M,NA,NB) + DIMENSION A(NA,*),B(NB,*) + DO J=M,1,-1 + CALL DZERV(B(1,J),J-1) + B(J,J)=1./A(J,J) + DO I=J+1,M + IM=I-1 + CALL DDOTVR(B(J,J),A(I,J),S,I-J,NA) + B(I,J)=-B(I,I)*S + ENDDO + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE DLINLV +! Solve linear system involving lower triangular (LINLV) or upper +! triangular (LINUV) matrix, right-hand-side vector U and output vector V +! +!------------------------------------------------------------------------------ + SUBROUTINE DLINLV(A,U,V,M,NA) + DIMENSION A(NA,*),U(*),V(*) + DO I=1,M + S=U(I) + CALL DDSBVR(V,A(I,1),S,I-1,NA) + V(I)=S/A(I,I) + ENDDO + RETURN + ENTRY DLINUV(A,U,V,M,NA) + DO J=M,1,-1 + JP=J+1 + S=U(J) + CALL DDSBVV(A(JP,J),V(JP),S,M-J) + V(J)=S/A(J,J) + ENDDO + RETURN + END + + FUNCTION MCMAXD(A,B,M) + DIMENSION A(0:M),B(0:M) + MCMAXD=0 ! Default for when ALL elements of C are zero + DO MA=M,0,-1 ! Seek last nonzero coefficient of polynomial A + IF(A(MA).NE.0.)THEN + DO MB=M,0,-1 ! Seek last nonzero coefficient of polynomial B + IF(B(MB).NE.0.)THEN + MCMAXD=MIN(M,MA+MB)+1 ! Hence, 1+last non-0 element of their product + RETURN + ENDIF + ENDDO + RETURN + ENDIF + ENDDO + RETURN + END + + SUBROUTINE DMULPP(A,B,C,M) ! multiply polynomials, possibly in place + DIMENSION A(0:M),B(0:M),C(0:M) + MCP=MCMAXD(A,B,M) + DO I=MCP,M + C(I)=0. + ENDDO + DO J=MCP,1,-1 + CALL DFDOVV(A,B,S,J) + C(J-1)=S + ENDDO + RETURN + ENTRY DMADPP(A,B,C,M) + MCP=MCMAXD(A,B,M) + DO J=MCP,1,-1 + CALL DFDOVV(A,B,S,J) + C(J-1)=C(J-1)+S + ENDDO + RETURN + ENTRY DMSBPP(A,B,C,M) + MCP=MCMAXD(A,B,M) + DO J=MCP,1,-1 + CALL DFDOVV(A,B,S,J) + C(J-1)=C(J-1)-S + ENDDO + RETURN + ENTRY DDIFP(A,B,M) ! Symbolically differentiate polynomial + DO I=1,M ! possibly with coincident storage for A and B + B(I-1)=I*A(I) + ENDDO + B(M)=0. + RETURN + ENTRY DINTP(A,B,M) ! Symbolically integrate polynomial + DO I=M,1,-1 ! possibly with coincident storage for A and B + B(I)=A(I-1)/I + ENDDO + B(0)=0. + RETURN + ENTRY DINVP(A,B,M) ! Invert polynomial or power-series + B0=1./A(0) ! Storage of A and B must NOT be the same + B(0)=B0 + DO I=1,M + CALL DFDOVV(B,A(1),S,I) + B(I)=-B0*S + ENDDO + RETURN + END + + SUBROUTINE DPRGV(D,M) + PARAMETER(CRIT=1.D-60) + DIMENSION D(*) + DO I=1,M + IF(ABS(D(I)).LE.CRIT)D(I)=0. + ENDDO + RETURN + END + + SUBROUTINE DFDOVV(D,E,S,M) ! Folded dot-product + DIMENSION D(*),E(*) + S=0. + ENTRY DFDAVV(D,E,S,M) + MP=M+1 + DO I=1,M + S=S+D(MP-I)*E(I) + ENDDO + RETURN + ENTRY DFDSVV(D,E,S,M) + MP=M+1 + DO I=1,M + S=S-D(MP-I)*E(I) + ENDDO + RETURN + END + SUBROUTINE DFDORR(A,B,S,M,NA,NB) + DIMENSION A(NA,M),B(NB,M) + S=0. + ENTRY DFDARR(A,B,S,M,NA,NB) + MP=M+1 + DO I=1,M + S=S+A(1,MP-I)*B(1,I) + ENDDO + RETURN + ENTRY DFDSRR(A,B,S,M,NA,NB) + MP=M+1 + DO I=1,M + S=S-A(1,MP-I)*B(1,I) + ENDDO + RETURN + END + + SUBROUTINE DPOWP(A,B,N,M) ! Raise power series A to the power + DIMENSION A(0:M),B(0:M),C(0:M) ! of N and output as B + B(0)=1. + CALL DZERV(B(1),M) + DO K=1,N + CALL DMULPP(A,B,B,M) + ENDDO + RETURN + ENTRY DPOLPS(A,S1,S2,M) ! Apply series A to scalar S1 to obtain S2 + S2=A(M) + DO K=M-1,0,-1 + S2=S2*S1+A(K) + ENDDO + RETURN + ENTRY DPOLPP(A,B,C,M) ! Apply power series A to power series B and put + C(0)=A(M) ! the result out as power-series C. + CALL DZERV(C(1),M) + DO K=M-1,0,-1 + CALL DMULPP(B,C,C,M) + C(0)=C(0)+A(K) + ENDDO + RETURN + END + + SUBROUTINE DMULCC(A,B,C,M) ! Multiply circulant matrices of period M + DIMENSION A(0:M-1),B(0:M-1),C(0:M-1) + CALL DZERV(C,M) + ENTRY DMADCC(A,B,C,M) + MM=M-1 + DO J=0,MM + MMJ=M-J + CALL DMADVS(A,B(J),C(J),MMJ) + CALL DMADVS(A(MMJ),B(J),C,J) + ENDDO + RETURN + ENTRY DMSBCC(A,B,C,M) + MM=M-1 + DO J=0,MM + MMJ=M-J + CALL DMSBVS(A,B(J),C(J),MMJ) + CALL DMSBVS(A(MMJ),B(J),C,J) + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! SUBROUTINE DLINVAN +! +! Take square matrix W and seek row and column scalings to produce non- +! vanishing elements of rescaled W having magnitudes as close to unity +! as possible. The approach is make the geometric mean of the nonvanishing +! elements of each row and of each column +1 or -1. Having rescaled the +! matrix and the r.h.s. vector AB, compute the product P of row-vector +! norms, then compute the determinant D and solve the linear system. +! Rescale the solution vector (now AB) and put the conditioning indicator +! formed by the ratio D/P into the first element of W. +! +! <-> W: Generalized Vandermonde matrix in, conditioning indicator out. +! <-> AB: R.h.s. vector in, solution vector of numerical coefficients out. +! --> NC: Order of the linear problem. +!------------------------------------------------------------------------------ + SUBROUTINE DLINVAN(W,AB,NC) + PARAMETER(NN=20,NIT=20) + DIMENSION W(NC,*),AB(NC),D1(NN),D2(NN),IPIV(NN)& + ,W2(NN,NN),V(NN) + CALL DCOPM(W,W2,NC,NC,NC,NN) ! Preserve original W and AB for use + CALL DCOPV(AB,V,NC) ! in later "clean-up" operation. + + DO I=1,NC + D1(I)=1. ! Row scaling factors set to default + D2(I)=1. ! Column scaling factors set to default + ENDDO + C=1.D-16 ! Set initial criterion for "negligible" elements of W + +! In first attempt to estimate row and column scalings, use logarithms +! to avoid the risk of under- or over-flows of the line products of W: + DO I=1,NC + P=0. + E=0. + DO J=1,NC + DW=ABS(W(I,J)) + IF(DW.GT.C)THEN + E=E+1. + P=P+LOG(DW) + ENDIF + ENDDO +! IF(E.EQ.0.)STOP'W effectively singular in LINVAN' + IF(E.EQ.0.)STOP + D1(I)=EXP(-P/E) + ENDDO + CALL DMULVX(D1,W2,W,NC,NC,NN,NC) ! Rescale rows of W by D1 + + DO J=1,NC + P=0. + E=0. + DO I=1,NC + DW=ABS(W(I,J)) + IF(DW.GT.C)THEN + E=E+1. + P=P+LOG(DW) + ENDIF + ENDDO +! IF(E.EQ.0.)STOP'W effectively singular in LINVAN' + IF(E.EQ.0.)STOP + D2(J)=EXP(-P/E) + ENDDO + CALL DMULVY(D2,W,W,NC,NC,NC,NC) ! Rescale columns of W by D2 + + C=1.D-8 ! reset the criterion for "negligible" elements + +! Revert to iterations of the more efficient method without logarithms: + DO JT=1,2 + DO IT=1,NIT ! Perform NIT relaxation iterations + DO I=1,NC ! Do rows: + P=1. + E=0. + DO J=1,NC + DW=ABS(W(I,J)) + IF(DW.GT.C)THEN + E=E+1. + P=P*DW + ENDIF + ENDDO + P=1./(P**(1./E)) + CALL DMULRS(W(I,1),P,W(I,1),NC,NC,NC) ! Rescale this row of W.. + D1(I)=D1(I)*P ! ..and update D1 consistently + ENDDO + DO J=1,NC ! Do columns: + P=1. + E=0. + D2J=D2(J) + DO I=1,NC + DW=ABS(W(I,J)) + IF(DW.GT.C)THEN + E=E+1. + P=P*DW + ENDIF + ENDDO + P=1./(P**(1./E)) + CALL DMULVS(W(1,J),P,W(1,J),NC) ! Rescale this column of W.. + D2(J)=D2(J)*P ! ..and update D2 consistently + ENDDO + ENDDO + C=1.D-3 ! Final setting for criterion for "negligible" elements + ENDDO + CALL DMULVV(D1,AB,AB,NC) ! Rescale r.h.s vector by D1 + P=1. ! P becomes product of row-lengths: + DO I=1,NC + CALL DNORR(W(I,1),S,NC,NC) + P=P*S + ENDDO + CALL DLDUM(W,IPIV,D,NC,NC) + DO I=1,NC + D=D*W(I,I) ! D becomes the determinant of W + ENDDO + CALL DUDLMM(W,AB,IPIV,NC,1,NC,NC) + CALL DMULVV(AB,D2,AB,NC) ! Rescale solution vector by D2 +! Note: it is very likely that round-off errors have accumulated during +! the iterative rescaling of W. We invoke original matrix elements W2 and +! substitute the tentative solution vector into the original (unscaled) +! equation in order to estimate the residual components of roundoff error. + +! Begin "clean-up" process. Substitute solution vector in original +! equation and leave the residual difference in V + CALL DMSBMM(W2,AB,V,NC,NC,1,NN,NC,NC) + CALL DMULVV(V,D1,V,NC) ! Rescale the residual vector by D1 + CALL DUDLMM(W,V,IPIV,NC,1,NC,NC) ! Solve linear system with THIS rhs. + CALL DMADVV(V,D2,AB,NC) ! Add residual solution vector, scaled, to AB + ! This will remove most of the round-off error. + W(1,1)=D/P ! this ratio is an indicator of the overall conditioning + RETURN ! When D/P is very small, treat the results with suspicion! + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! SUBROUTINE DTSINI +!!!!!!!!!!!! THIS IS PROBABLY OBSOLETE - SEE FUNCTION SINMINT !!!!! +! +! Initialize the Taylor coefficients used by DFUNTS to evaluate the +! integrals of integer powers of the sine function near the origin. +! NI is the maximum number of non-trivial coefficients available +! NK is the largest power of the sine function accommodated +!------------------------------------------------------------------------------ + SUBROUTINE DTSINI + PARAMETER(NI=30,NK=20) + COMMON/DTSCOF/ TS(0:NI,NK) +! SET UP TAYLOR SERIES OF SIN(X)**K..... + T=1 + TS(0,1)=T + KSIG=-1 + DO I=1,NI + IF(ABS(T).LE.1.E-60)THEN + TS(I,1)=0 + ELSE + I2=I*2 + T=-T/(I2*(I2+1)) + TS(I,1)=T + ENDIF + ENDDO + DO K=2,NK + CALL DMULPP(TS(0,1),TS(0,K-1),TS(0,K),NI) + ENDDO +! ...AND INTEGRATE: + DO K=1,NK + DO I=0,NI + TS(I,K)=TS(I,K)/(I*2+K+1) + ENDDO + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! FUNCTION DFUNTS +!!!!!!!!!!!!!!!! THIS FUNCTION IS PROBABLY OBSOLETE - SEE FUNCTION SINMINT +! Evaluate the integral of sin(A)**K using a power series in A**2 +!------------------------------------------------------------------------------ + FUNCTION DFUNTS(A,K) + PARAMETER(NI=30,NK=20) + COMMON/DTSCOF/ TS(0:NI,NK) + IF(K.EQ.0)THEN + DFUNTS=A + ELSE + DFUNTS=0. + AP=A**(K+1) + AS=A*A + DO I=0,NI + IF(ABS(AP).LE.1.D-60)RETURN + DFUNTS=DFUNTS+AP*TS(I,K) + AP=AP*AS + ENDDO + ENDIF + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! SUBROUTINE DCNVLV +! Convolve two series in such a way that the output can, if necessary, +! occupy the same space as one of the inputs and with a check to ensure that +! extremely small products are reset to zero. SINGLE PRECISION of DCNVLV +! +! ?-> A: first input series (possibly overwritten as "C" on output) +! ?-> B: second input (possibly overwritten as "C" on output) +! <-- C: output series +! --> N: maximum index of the series whose first index is zero +!------------------------------------------------------------------------------ +! SUBROUTINE DCNVLV(A,B,C,N) +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) +! DIMENSION A(0:N),B(0:N),C(0:N) +! DO IA=N,0,-1 +! NA=IA +! IF(A(IA).NE.0.)GOTO 300 +! ENDDO +!300 DO IB=N,0,-1 +! NB=IB +! IF(B(IB).NE.0.)GOTO 301 +! ENDDO +!301 DO IC=0,N +! C(IC)=0 +! ENDDO +! NC=MIN(N,NA+NB) +! DO IA=0,NA +! AIA=A(IA) +! IF(AIA.NE.0.)THEN +! DO IB=0,MIN(NC-IA,NB) +! IC=IA+IB +! C(IC)=C(IC)+AIA*B(IB) +! ENDDO +! ENDIF +! ENDDO +! DO IC=0,NC +! IF(ABS(C(IC)).LE.1.D-60)C(IC)=0. +! ENDDO +! RETURN +! END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! SUBROUTINE DDFCO +! +! Compute one row of the coefficients for either the compact differencing or +! quadrature scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! In either case, d is the derivative of c. +! +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! <-- AB: the NC=NA+NB concatenated coefficients A and B for this row +! <-- W: work-array of size NC**2. On exit, the first element contains +! a measure of the conditioning of the matrix of the linear system +! (determinant/{product of row-lengths}). +!------------------------------------------------------------------------------ + SUBROUTINE DDFCO(ZA,ZB,Z0,NA,NB,AB,W) + DIMENSION ZA(*),ZB(*),AB(*),W(NA+NB,*) + NC=NA+NB + DO J=1,NA + W(1,J)=1. + W(2,J)=0. + W(3,J)=0. + Z=ZA(J)-Z0 + P=Z + DO I=4,NC + W(I,J)=P*(I-2) + P=P*Z + ENDDO + ENDDO + DO J=1,NB + W(1,NA+J)=0. + Z=ZB(J)-Z0 + P=-1. + DO I=2,NC + W(I,NA+J)=P + P=P*Z + ENDDO + ENDDO + AB(1)=1. + DO I=2,NC + AB(I)=0. + ENDDO + AB(3)=-1. + CALL DLINVAN(W,AB,NC) ! Solve the linear system + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! ENTRY DAVCO +! +! Compute one row of the coefficients for the compact mid-interval +! interpolation scheme characterized by matrix equation of the form, +! A.t = B.s (*) +! Where s is the vector of "source" values, t the staggered "target" values. +! +! --> ZA: coordinates of t-points used in this row of (*) +! --> ZB: coordinates of s-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! --> NA: number of t-points operated on by this row of the A of (*) +! --> NB: number of s-points operated on by this row of the B of (*) +! <-- AB: the NC=NA+NB concatenated coefficients A and B for this row +! <-- W: work-array of size NC**2. On exit, the first element contains +! a measure of the conditioning of the matrix of the linear system +! (determinant/{product of row-lengths}). +!------------------------------------------------------------------------------ + SUBROUTINE DAVCO(ZA,ZB,Z0,NA,NB,AB,W) + DIMENSION ZA(*),ZB(*),AB(*),W(NA+NB,*) + NC=NA+NB + DO J=1,NA + W(1,J)=1. + Z=ZA(J)-Z0 + P=1. + DO I=2,NC + W(I,J)=P + P=P*Z + ENDDO + ENDDO + DO J=1,NB + W(1,NA+J)=0. + Z=ZB(J)-Z0 + P=-1. + DO I=2,NC + W(I,NA+J)=P + P=P*Z + ENDDO + ENDDO + AB(1)=1. + DO I=2,NC + AB(I)=0. + ENDDO + CALL DLINVAN(W,AB,NC) ! Solve the linear system + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! ENTRY DDFCO2 +! +! Compute one row of the coefficients for either the compact second- +! differencing scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! Where d is the second-derivative of c. +! +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! <-- AB: the NC=NA+NB concatenated coefficients A and B for this row +! <-- W: work-array of size NC**2. On exit, the first element contains +! a measure of the conditioning of the matrix of the linear system +! (determinant/{product of row-lengths}). +!------------------------------------------------------------------------------ + SUBROUTINE DDFCO2(ZA,ZB,Z0,NA,NB,AB,W) + DIMENSION ZA(*),ZB(*),AB(*),W(NA+NB,*) + NC=NA+NB + DO J=1,NA + W(1,J)=1. + W(2,J)=0. + W(3,J)=0. + W(4,J)=0. + Z=ZA(J)-Z0 + P=Z + DO I=5,NC + W(I,J)=P*(I-2)*(I-3) + P=P*Z + ENDDO + ENDDO + DO J=1,NB + W(1,NA+J)=0. + Z=ZB(J)-Z0 + P=-1. + DO I=2,NC + W(I,NA+J)=P + P=P*Z + ENDDO + ENDDO + AB(1)=1. + DO I=2,NC + AB(I)=0. + ENDDO + AB(4)=-2. + CALL DLINVAN(W,AB,NC) ! Solve the linear system + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! wd23jp@sun1.wwb.noaa.gov 1996 +! SUBROUTINE DYQDCO +! +! Compute one row of the coefficients for the special compact differencing or +! quadrature scheme characterized by matrix equation of the form, +! A.d = B.c (*) +!!!!!!!! THIS ROUTINE IS PROBABLY OBSOLETE !!!!!!!!!!!!! +!!!! SEE SUBROUTINE YQDBB +! +! --> YA: latitudes of d-points used in this row of (*) +! --> YB: latitudes of c-points used in this row of (*) +! --> Y0: nominal point of application of this row of (*) +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! <-- AB: the NC=NA+NB concatenated coefficients A and B for this row +! <-- W: work-array of size NC**2. On exit, the first element contains +! a measure of the conditioning of the matrix of the linear system +! (determinant/{product of row-lengths}). +!------------------------------------------------------------------------------ +! SUBROUTINE DYQDCO(YA,YB,Y0,NA,NB,AB,W) +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) +! LOGICAL LFIRST +! SAVE +! DIMENSION YA(*),YB(*),AB(*),W(NA+NB,*) +! DATA LFIRST/.TRUE./ +! +!! IF THIS IS THE FIRST INVOKATION, INITIALIZE TAYLOR COEFs USED BY DFUNTS +! IF(LFIRST)THEN +! CALL DTSINI +! LFIRST=.FALSE. +! ENDIF +! +! NC=NA+NB +! CY0=COS(Y0) +! SY0=SIN(Y0) +! DO J=1,NA ! Begin constructing generalized Vandermonde matrix +! W(1,J)=1. ! associated with this row of this particular +! W(2,J)=0. ! compact finite differencing scheme. +! W(3,J)=0. ! First three rows are mandatory. +! YR=YA(J)-Y0 +! Z=SIN(YR) +! P=Z +! DO I=4,NC +! W(I,J)=P +! P=P*Z +! ENDDO +! ENDDO +! DO J=1,NB +! W(1,NA+J)=0. +! W(2,NA+J)=-1. +! YR=YB(J)-Y0 +! Z=SIN(YR) +! DO I=3,NC +! M=I-2 +! W(I,NA+J)=SY0*DFUNTS(YR,M)-CY0*Z**M/M +! ENDDO +! ENDDO +! AB(1)=1. ! Construct the right-hand-side vector +! DO I=2,NC ! for this problem +! AB(I)=0. +! ENDDO +! AB(3)=-1. +! CALL DLINVAN(W,AB,NC) ! Solve the linear system. +! RETURN +! END + + SUBROUTINE DMULVX(D,V1,V2,M,MY,NV1,NV2) + DIMENSION D(M),V1(NV1,MY),V2(NV2,MY) + DO I=1,M + DI=D(I) + DO IY=1,MY + V2(I,IY)=DI*V1(I,IY) + ENDDO + ENDDO + RETURN + ENTRY DMADVX(D,V1,V2,M,MY,NV1,NV2) + DO I=1,M + DI=D(I) + DO IY=1,MY + V2(I,IY)=V2(I,IY)+DI*V1(I,IY) + ENDDO + ENDDO + RETURN + ENTRY DMSBVX(D,V1,V2,M,MY,NV1,NV2) + DO I=1,M + DI=D(I) + DO IY=1,MY + V2(I,IY)=V2(I,IY)-DI*V1(I,IY) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE DMULVY(D,V1,V2,M,MX,NV1,NV2) + DIMENSION D(M),V1(NV1,M),V2(NV2,M) + DO I=1,M + DI=D(I) + DO IX=1,MX + V2(IX,I)=DI*V1(IX,I) + ENDDO + ENDDO + RETURN + ENTRY DMADVY(D,V1,V2,M,MX,NV1,NV2) + DO I=1,M + DI=D(I) + DO IX=1,MX + V2(IX,I)=V2(IX,I)+DI*V1(IX,I) + ENDDO + ENDDO + RETURN + ENTRY DMSBVY(D,V1,V2,M,MX,NV1,NV2) + DO I=1,M + DI=D(I) + DO IX=1,MX + V2(IX,I)=V2(IX,I)-DI*V1(IX,I) + ENDDO + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE DLDUB +! Compute [L]*[D**-1]*[U] decomposition of asymmetric band-matrix +! +! <-> A input as the asymmetric band matrix. On output, it contains +! the [L]*[D**-1]*[U] factorization of the input matrix, where +! [L] is lower triangular with unit main diagonal +! [D] is a diagonal matrix +! [U] is upper triangular with unit main diagonal +! --> M the number of rows assumed for [A] +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> NA the first fortran dimension of A +!------------------------------------------------------------------------------ + SUBROUTINE DLDUB(A,M,MAH1,MAH2,NA) + DIMENSION A(NA,-MAH1:MAH2) + DO J=1,M + IMOST=MIN(M,J+MAH1) + JMOST=MIN(M,J+MAH2) + JP=J+1 + AJJ=A(J,0) + IF(AJJ.EQ.0.)THEN + PRINT'('' Failure in LDUB:''/'' Matrix requires pivoting or is singular'')' + STOP + ENDIF + AJJI=1./AJJ + A(J,0)=AJJI + DO I=JP,IMOST + AIJ=AJJI*A(I,J-I) + A(I,J-I)=AIJ + DO K=JP,JMOST + A(I,K-I)=A(I,K-I)-AIJ*A(J,K-J) + ENDDO + ENDDO + DO K=JP,JMOST + A(J,K-J)=AJJI*A(J,K-J) + ENDDO + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE DL1UBB +! Form the [L]*[D]*[U] decomposition of asymmetric band-matrix [A] replace +! lower triangular elements of [A] by [D**-1]*[L]*[D], the upper by [U], +! replace matrix [B] by [D**-1]*[B]. +! +! <-> A input as band matrix, output as lower and upper triangulars with 1s +! implicitly assumed to lie on the main diagonal. The product of these +! triangular matrices is [D**-1]*[A], where [D] is a diagonal matrix. +! <-> B in as band matrix, out as same but premultiplied by diagonal [D**-1] +! --> M number of rows of A and B +! --> MAH1 left half-width of fortran array A +! --> MAH2 right half-width of fortran array A +! --> MBH1 left half-width of fortran array B +! --> MBH2 right half-width of fortran array B +! --> NA first fortran dimension of A +! --> NB first fortran dimension of B +!------------------------------------------------------------------------------ + SUBROUTINE DL1UBB(A,B,M,MAH1,MAH2,MBH1,MBH2,NA,NB) + DIMENSION A(NA,-MAH1:MAH2),B(NB,-MBH1:MBH2) + DO J=1,M + IMOST=MIN(M,J+MAH1) + JMOST=MIN(M,J+MAH2) + JLEAST=MAX(1,J-MAH1) + JP=J+1 + AJJ=A(J,0) +! IF(AJJ.EQ.0.)STOP'failure in DL1UBB' + IF(AJJ.EQ.0.)STOP + AJJI=1./AJJ + DO K=JLEAST,JMOST + A(J,K-J)=AJJI*A(J,K-J) + ENDDO + DO I=JP,IMOST + AIJ=A(I,J-I) + DO K=JP,JMOST + A(I,K-I)=A(I,K-I)-AIJ*A(J,K-J) + ENDDO + ENDDO + A(J,0)=1. + DO K=-MBH1,MBH2 + B(J,K)=AJJI*B(J,K) + ENDDO + ENDDO + RETURN + END + +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE DWRTM +! Write out contents of a real matrix +! +! --> A matrix +! --> MI,MJ number of active rows and columns of matrix +! --> JCOLS number of columns output at a time +! --> NA first fortran dimension of matrix +!------------------------------------------------------------------------------ + SUBROUTINE DWRTM(A,MI,MJ,JCOLS,NA) + DIMENSION A(NA,*) + DO J1=1,MJ,JCOLS + J2=MIN(MJ,J1+JCOLS-1) + PRINT'(8X,10(I3,9X))',(J,J=J1,J2) + DO I=1,MI + PRINT'(1X,I3,10(1X,E11.5))',I,(A(I,J),J=J1,J2) + ENDDO + PRINT'()' + ENDDO + RETURN + END diff --git a/util/NMC_Bkerror/sorc_aero/postmod.f90 b/util/NMC_Bkerror/sorc_aero/postmod.f90 new file mode 100644 index 000000000..1f57d7201 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/postmod.f90 @@ -0,0 +1,243 @@ +module postmod + + use kinds, only: r_kind + implicit none + + integer ndeg,nasm + parameter(ndeg=6,nasm=560) + +contains + + subroutine smoothlat(field,nlevs,degs) + use variables,only: nlat + implicit none + + real(r_kind),dimension(nlat,nlevs):: field + real(r_kind),dimension(nlat):: field_sm + real(r_kind),dimension(nlat,nlat):: weights + real(r_kind) degs + integer j,j2,k,nlevs + +! get weights for smoothing in lat direction + call get_weights(degs,weights) + +! smooth the field array based on weights computed + do k=1,nlevs + field_sm=0.0 + do j2=2,nlat-1 + do j=2,nlat-1 + field_sm(j)=field_sm(j)+weights(j,j2)*field(j2,k) + end do + end do + +! redefine field to be smoothed + do j=2,nlat-1 + field(j,k)=field_sm(j) + end do + field(1,k)=field(2,k) + field(nlat,k)=field(nlat-1,k) + + end do !end do loop over levs + + return + end subroutine smoothlat + + + subroutine get_weights(degs,wsmooth) + use variables,only: nlat,deg2rad,rlats + implicit none + + real(r_kind),dimension(nlat):: rnorm,slat + real(r_kind),dimension(nlat,nlat):: wsmooth + + real(r_kind) sum,errmax,degs,arg,denom + integer j,jj + +! use difference in sin(lat) to calculate weighting + do j=2,nlat-1 + slat(j)=sin(rlats(j)) + end do + denom=1.0/(deg2rad*degs) + rnorm=0. + do j=2,nlat-1 + do jj=2,nlat-1 + arg=.5*(denom*(slat(j)-slat(jj)))**2 + wsmooth(j,jj)=exp(-arg) + rnorm(j)=rnorm(j)+wsmooth(j,jj) + end do + end do + + do j=2,nlat-1 + rnorm(j)=1./rnorm(j) + end do + + errmax=0. + do j=2,nlat-1 + sum=0.0 + do jj=2,nlat-1 + wsmooth(j,jj)=rnorm(j)*wsmooth(j,jj) + sum=sum+wsmooth(j,jj) + end do + errmax=max(abs(sum-1._r_kind),errmax) + end do + + return + end subroutine get_weights + + subroutine writefiles_aerosol + use variables,only:d1var,d2var,d3var,d4var,d5var,s1var,s2var,s3var,s4var, & + so4var,oc1var,oc2var,bc1var,bc2var,d1hln,d2hln,d3hln,d4hln,d5hln, & + s1hln,s2hln,s3hln,s4hln,so4hln,oc1hln,oc2hln,bc1hln,bc2hln, & + d1vln,d2vln,d3vln,d4vln,d5vln,s1vln,s2vln,s3vln,s4vln, & + so4vln,oc1vln,oc2vln,bc1vln,bc2vln,nlat,nlon,nsig + use kinds, only: r_single,r_double +! use sstmod + implicit none + +! Single precision variables for visualization + real(r_single),allocatable,dimension(:,:,:):: stdev3d4,hscale3d4,vscale3d4 + + integer i,j,k,m,outf,ncfggg,iret,isig,n + character(255) grdfile + character*5 var(40) + +! Interpolate sst statistics +! go file for use in GSI analysis code +! call create_sstvars(nlat,nlon) +! call sst_stats + +! allocate single precision arrays + allocate(stdev3d4(nlat,nsig,14),hscale3d4(nlat,nsig,14),vscale3d4(nlat,nsig,14)) + +! Load single precision arrays for visualization + do k=1,nsig + do i=1,nlat + stdev3d4(i,k,1)=sqrt(d1var(i,k)) + stdev3d4(i,k,2)=sqrt(d2var(i,k)) + stdev3d4(i,k,3)=sqrt(d3var(i,k)) + stdev3d4(i,k,4)=sqrt(d4var(i,k)) + stdev3d4(i,k,5)=sqrt(d5var(i,k)) + stdev3d4(i,k,6)=sqrt(s1var(i,k)) + stdev3d4(i,k,7)=sqrt(s2var(i,k)) + stdev3d4(i,k,8)=sqrt(s3var(i,k)) + stdev3d4(i,k,9)=sqrt(s4var(i,k)) + stdev3d4(i,k,10)=sqrt(so4var(i,k)) + stdev3d4(i,k,11)=sqrt(oc1var(i,k)) + stdev3d4(i,k,12)=sqrt(oc2var(i,k)) + stdev3d4(i,k,13)=sqrt(bc1var(i,k)) + stdev3d4(i,k,14)=sqrt(bc2var(i,k)) + + hscale3d4(i,k,1)=d1hln(i,k) + hscale3d4(i,k,2)=d2hln(i,k) + hscale3d4(i,k,3)=d3hln(i,k) + hscale3d4(i,k,4)=d4hln(i,k) + hscale3d4(i,k,5)=d5hln(i,k) + hscale3d4(i,k,6)=s1hln(i,k) + hscale3d4(i,k,7)=s2hln(i,k) + hscale3d4(i,k,8)=s3hln(i,k) + hscale3d4(i,k,9)=s4hln(i,k) + hscale3d4(i,k,10)=so4hln(i,k) + hscale3d4(i,k,11)=oc1hln(i,k) + hscale3d4(i,k,12)=oc2hln(i,k) + hscale3d4(i,k,13)=bc1hln(i,k) + hscale3d4(i,k,14)=bc2hln(i,k) + + vscale3d4(i,k,1)=d1vln(i,k) + vscale3d4(i,k,2)=d2vln(i,k) + vscale3d4(i,k,3)=d3vln(i,k) + vscale3d4(i,k,4)=d4vln(i,k) + vscale3d4(i,k,5)=d5vln(i,k) + vscale3d4(i,k,6)=s1vln(i,k) + vscale3d4(i,k,7)=s2vln(i,k) + vscale3d4(i,k,8)=s3vln(i,k) + vscale3d4(i,k,9)=s4vln(i,k) + vscale3d4(i,k,10)=so4vln(i,k) + vscale3d4(i,k,11)=oc1vln(i,k) + vscale3d4(i,k,12)=oc2vln(i,k) + vscale3d4(i,k,13)=bc1vln(i,k) + vscale3d4(i,k,14)=bc2vln(i,k) + end do + end do + +! write out files; +! outf=45 +! open(outf,file='gsir4.berror_stats',form='unformatted') +! rewind outf +! write(outf) nsig,nlat,& +! sfvar4,vpvar4,tvar4,qvar4,nrhvar4,ozvar4,cvar4,psvar4,& +! sfhln4,vphln4,thln4,qhln4,ozhln4,chln4,pshln4,& +! sfvln4,vpvln4,tvln4,qvln4,ozvln4,cvln4,& +! tcon4,vpcon4,pscon4,& +! varsst4,corlsst4 +! close(outf) + + var=' ' + var(1)='dust1' + var(2)='dust2' + var(3)='dust3' + var(4)='dust4' + var(5)='dust5' + var(6)='seas1' + var(7)='seas2' + var(8)='seas3' + var(9)='seas4' + var(10)='sulf' + var(11)='oc1' + var(12)='oc2' + var(13)='bc1' + var(14)='bc2' + +! write out files; + outf=45 + open(outf,file='gsir4.berror_stats.gcv',form='unformatted') + rewind outf + write(outf) nsig,nlat,nlon + + do i=1,14 + write(6,*) i,var(i),nsig + write(outf) var(i),nsig + write(outf) stdev3d4(:,:,i) + write(outf) hscale3d4(:,:,i) + write(outf) vscale3d4(:,:,i) + end do + +! write(201,*) stdev3d4 +! write(202,*) hscale3d4 +! write(203,*) vscale3d4 + + close(outf) + + do n=1,14 + do k=1,nsig + do i=1,nlat + vscale3d4(i,k,n)=1./vscale3d4(i,k,n) + end do + end do + end do + +! CREATE SINGLE PRECISION BYTE-ADDRESSABLE FILE FOR GRADS +! OF LATIDUDE DEPENDENT VARIABLES + grdfile='bgstats_sp.grd' + ncfggg=len_trim(grdfile) + call baopenwt(22,grdfile(1:ncfggg),iret) + do n=1,14 + call wryte(22,4*nlat*nsig,stdev3d4(:,:,n)) + end do + do n=1,14 + call wryte(22,4*nlat*nsig,hscale3d4(:,:,n)) + end do + do n=1,14 + call wryte(22,4*nlat*nsig,vscale3d4(:,:,n)) + end do + call baclose(22,iret) + +! CREATE SINGLE PRECISION BYTE-ADDRESSABLE FILE FOR GRADS +! OF SST STATISTICS + deallocate(stdev3d4,hscale3d4,vscale3d4) + +! call destroy_sstvars + + return + end subroutine writefiles_aerosol + +end module postmod diff --git a/util/NMC_Bkerror/sorc_aero/readpairs_aerosol.f90 b/util/NMC_Bkerror/sorc_aero/readpairs_aerosol.f90 new file mode 100644 index 000000000..3043a0507 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/readpairs_aerosol.f90 @@ -0,0 +1,297 @@ +subroutine readpairs_aerosol(npe,mype,numcases) + use variables, only: nlat,nlon,nsig,ak5,bk5,ck5,& + na,nb,filename,hybrid,db_prec,zero,one,grav,fv,& + idpsfc5,idthrm5,cp5,ntrac5,idvc5,idvm5,lat1,lon1,& + iglobal,ijn_s,displs_s,filunit1,filunit2,& + ird_s,irc_s,displs_g,modelname,fv3aeroname,ngacaeroname,aeroname + use specgrid, only: sptez_s,sptezv_s,nc,ncin,factvml,& + factsml,enn1,ncd2,jcaptrans,jcap,jcapin,unload_grid + use comm_mod, only: levs_id,nvar_id,grid2sub,nsig1o,spec_send,& + disp_spec + use kinds, only: r_kind,r_single,r_double + use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close, & + nemsio_gfile,nemsio_getfilehead,nemsio_readrecv + implicit none + include 'mpif.h' + + integer npe,mype,numcases,ierror,mpi_rtype,iret,iret2 + integer mm1,kk,proc1,proc2 + integer i,j,k,m,n,inges,inge2,i2,i2m1 + integer k1,k2,k3,k4,k5,k6,k7,k8,k9,k10,k11,k12,k13 + + real(r_kind),dimension(lat1,lon1,nsig):: d1a,d2a,d3a,d4a,d5a, & + s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a,d1b,d2b,d3b,d4b,d5b, & + s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b + + real(r_kind),dimension(nc):: z,z2,wd,wd2,wz,wz2 + real(r_kind),dimension(ncin):: s1tmp,s2tmp,tmp + real(r_kind),dimension(ncin,nsig1o):: z41,z42 + real(r_kind),dimension(ncin,14*nsig):: z4all + + real(r_kind),dimension(nlon,nlat-2):: grid1,grid2 + real(r_kind),dimension(iglobal,nsig1o):: work1,work2 + + real(r_kind),dimension(iglobal,ntrac5):: gridtrac1,gridtrac2 + + type(nemsio_gfile) :: gfile + + logical ice + if (db_prec) then + mpi_rtype=mpi_real8 + else + mpi_rtype=mpi_real4 + end if + + if (modelname=='fv3') then + aeroname=fv3aeroname + else if (modelname=='ngac') then + aeroname=ngacaeroname + end if + + inges=50 + inge2=51 + mm1=mype+1 + proc1=0 + proc2=npe-1 + + filunit1=(10000+(mype+1)) + filunit2=(20000+(mype+1)) + +! Each mpi task will carry two files, which contains all variables, for each of the time levels + open(filunit1,form='unformatted',action='write') + rewind(filunit1) + open(filunit2,form='unformatted',action='write') + rewind(filunit2) + + do n=1,numcases + if (mype==0) write(6,*)'opening=', filename(na(n)) + if (mype==0) write(6,*)'opening=', filename(nb(n)) + +! Get information from NEMSIO + if (mype==proc1) then + call nemsio_init(iret=iret) + call nemsio_open(gfile,filename(na(n)),'READ',iret=iret) + end if + if (mype==proc2) then + call nemsio_init(iret=iret) + call nemsio_open(gfile,filename(nb(n)),'READ',iret=iret) + end if + call mpi_barrier(mpi_comm_world,iret2) + + if (mype==proc1 .or. mype==proc2) then + k1=nsig ; k2=2*nsig ; k3=3*nsig ; k4=4*nsig ; k5=5*nsig + k6=6*nsig ; k7=7*nsig ; k8=8*nsig ; k9=9*nsig ; k10=10*nsig + k11=11*nsig ; k12=12*nsig ; k13=13*nsig + + do k=1,nsig + call nemsio_readrecv(gfile,trim(aeroname(1)),'mid layer',k,tmp,iret=iret) + z4all(:,k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(2)),'mid layer',k,tmp,iret=iret) + z4all(:,k1+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(3)),'mid layer',k,tmp,iret=iret) + z4all(:,k2+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(4)),'mid layer',k,tmp,iret=iret) + z4all(:,k3+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(5)),'mid layer',k,tmp,iret=iret) + z4all(:,k4+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(6)),'mid layer',k,s1tmp,iret=iret) + call nemsio_readrecv(gfile,trim(aeroname(7)),'mid layer',k,s2tmp,iret=iret) + z4all(:,k5+k)=(s1tmp+s2tmp) + call nemsio_readrecv(gfile,trim(aeroname(8)),'mid layer',k,tmp,iret=iret) + z4all(:,k6+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(9)),'mid layer',k,tmp,iret=iret) + z4all(:,k7+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(10)),'mid layer',k,tmp,iret=iret) + z4all(:,k8+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(11)),'mid layer',k,tmp,iret=iret) + z4all(:,k9+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(12)),'mid layer',k,tmp,iret=iret) + z4all(:,k10+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(13)),'mid layer',k,tmp,iret=iret) + z4all(:,k11+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(14)),'mid layer',k,tmp,iret=iret) + z4all(:,k12+k)=tmp + call nemsio_readrecv(gfile,trim(aeroname(15)),'mid layer',k,tmp,iret=iret) + z4all(:,k13+k)=tmp + if (iret/=0) then + write(6,*) 'read in aerosol failed' + call exit(999) + end if + end do + if (modelname=='ngac') z4all=z4all*1e+09 ! convert the units from kg/kg to µg/kg + end if + + call mpi_scatterv(z4all,spec_send,disp_spec,mpi_rtype,& + z41,spec_send(mm1),mpi_rtype,proc1,mpi_comm_world,ierror) + call mpi_scatterv(z4all,spec_send,disp_spec,mpi_rtype,& + z42,spec_send(mm1),mpi_rtype,proc2,mpi_comm_world,ierror) + +! write(6,*) 'mype is ',mype,'z41 shape is ',shape(z41) + + work1=zero ; work2=zero + + do k=1,nsig1o +! Check: Dust1 level? + if(nvar_id(k).eq.1) then ! SF + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if !end if kk check + +! Check: Dust2 level? + else if(nvar_id(k).eq.2) then + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if !end if kk check + +! Check: Dust3 Level? + else if(nvar_id(k).eq.3) then ! Temp + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: Dust4 level? + else if(nvar_id(k).eq.4) then ! Q + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: Dust5 Level? + else if(nvar_id(k).eq.5) then ! SF + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: Seasalt1 Level? + else if(nvar_id(k).eq.6) then ! SF + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: Seasalt2 level ? + else if(nvar_id(k).eq.7) then ! PS + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: Seasalt3 level ? + else if(nvar_id(k).eq.8) then ! PS + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: Seasalt4 level ? + else if(nvar_id(k).eq.9) then ! PS + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: Sulfate level ? + else if(nvar_id(k).eq.10) then ! PS + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: OC phobic level ? + else if(nvar_id(k).eq.11) then ! PS + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: OC philic level ? + else if(nvar_id(k).eq.12) then ! PS + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: BC phobic level ? + else if(nvar_id(k).eq.13) then ! PS + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + +! Check: BC philic level ? + else if(nvar_id(k).eq.14) then ! PS + kk=levs_id(k) + if (kk.gt.0 .and. kk.le.nsig) then + grid1=reshape(z41(:,k),(/nlon,nlat-2/)) + grid2=reshape(z42(:,k),(/nlon,nlat-2/)) + call unload_grid(grid1,work1(1,k)) + call unload_grid(grid2,work2(1,k)) + end if + else ! No nsig1o level to process +!! write(6,*) 'READPAIRS: No Level to process, k,mype,levs_id,nvar_id = ',k,mype,levs_id(k),nvar_id(k) + endif + end do !End do nsig1o levs + +! CALL GRID2SUB HERE + call grid2sub(work1,d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a) + call grid2sub(work2,d1b,d2b,d3b,d4b,d5b,s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b) + +! Write out the grids + write(filunit1) d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a + write(filunit2) d1b,d2b,d3b,d4b,d5b,s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b + +! write(1000+mype,*) s4a,s4b +! write(1100+mype,*) so4a,so4b + + end do ! END DO LOOP OVER CASES + close(filunit1) + close(filunit2) + + call mpi_barrier(mpi_comm_world,iret2) + + return +end subroutine readpairs_aerosol + diff --git a/util/NMC_Bkerror/sorc_aero/smoothz.f90 b/util/NMC_Bkerror/sorc_aero/smoothz.f90 new file mode 100755 index 000000000..437a780f2 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/smoothz.f90 @@ -0,0 +1,366 @@ +subroutine smoothz(p1,n,nc,m,al,be,dss,iflg) + DIMENSION DSS(N),P1(nc,N),P2(nc,N),BE(M),AL(N,M),GA(nc,M),DE(nc,M) + nm=n-1 +! recursive filter in the vertical direction + if(iflg.eq.2)then + do j=1,n + do i=1,nc + p2(i,j)=p1(i,j)*dss(j) + enddo + enddo + CALL RF0V(GA,DE,M*nc) + CALL RFHV(P2,p1,nc,Nm,M,AL,BE,GA,DE) + endif +! adjoint of filter in the vertical direction + if(iflg.eq.1)then + CALL RF0V(GA,DE,M*nc) + CALL RFHV(P1,p2,nc,Nm,M,AL,BE,GA,DE) + do i=1,n + do j=1,nc + p1(j,i)=p2(j,i)*dss(i) + enddo + enddo + endif + RETURN + END + SUBROUTINE RF0V(GAP,DEP,M) + DIMENSION GAP(M),DEP(M) + DO I=1,M + GAP(I)=0. + DEP(I)=0. + ENDDO + RETURN + END +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1998 +! SUBROUTINE RFHV +! Apply pseudo-Gaussian "right-plus-left" smoother to a single "vector" +! of data. +! +! --> P1: Input data. +! <-- P2: Output data. +! --> N: Number of grid intervals (one less than number of points). +! --> M: Degree of approximation of smoother to a Gaussian. +! --> AL: Matrix of "Alpha" coefficients (computed in RFDPARV). +! --> BE: Vector of "Beta" coefficients (computed in RFDPAR1). +! <-> GAP: Gamma vector of exponential amplitudes of P decaying to the right. +! <-> DEP: Delta vector of exponential amplitudes of P decaying to the left. +!------------------------------------------------------------------------------ + SUBROUTINE RFHV(P1,p2,nc,N,M,AL,BE,GA,DE) + DIMENSION P1(nc,0:N),P2(nc,0:N),AL(0:N,M),BE(M),GA(nc,M),DE(nc,M) + dimension dss(0:n) + KMOD2=MOD(M,2) + do j=0,n + do i=1,nc + p2(i,j)=0. + enddo + enddo +! Advancing filter: + DO I=0,N +! P1I=P1(I) +! P2(I)=0. + IF(KMOD2.EQ.1)THEN ! Treat the real root: + do j=1,nc + GA(j,1)=AL(I,1)*GA(j,1)+BE(1)*P1(j,i) + enddo + do j=1,nc + P2(j,I)=P2(j,I)+GA(j,1) + enddo + ENDIF + ! Treat remaining complex roots: + DO KR=KMOD2+1,M,2 ! <-- Index of "real" components + KI=KR+1 ! <-- Index of "imag" components + do j=1,nc + GAKR=GA(j,KR) + GAKI=GA(j,KI) + GA(j,KR)=AL(I,KR)*GAKR-AL(I,KI)*GAKI+BE(KR)*P1(j,i) + GA(j,KI)=AL(I,KI)*GAKR+AL(I,KR)*GAKI+BE(KI)*P1(j,i) + enddo + do j=1,nc + P2(j,I)=P2(j,I)+GA(j,KR) + enddo + ENDDO + ENDDO + +! Backing filter: + DO I=N,0,-1 +! P1I=P1(I) + IF(KMOD2.EQ.1)THEN ! Treat the real root: + do j=1,nc + P2(j,I)=P2(j,I)+DE(j,1) + enddo + do j=1,nc + DE(j,1)=AL(I,1)*(DE(j,1)+BE(1)*P1(j,i)) + enddo + ENDIF + ! Treat remaining complex roots: + DO KR=KMOD2+1,M,2 ! <-- Index of "real" components + KI=KR+1 ! <-- Index of "imag" components + do j=1,nc + P2(j,I)=P2(j,I)+DE(j,KR) + enddo + do j=1,nc + DEKR=DE(j,KR)+BE(KR)*P1(j,i) + DEKI=DE(j,KI)+BE(KI)*P1(j,i) + DE(j,KR)=AL(I,KR)*DEKR-AL(I,KI)*DEKI + DE(j,KI)=AL(I,KI)*DEKR+AL(I,KR)*DEKI + enddo + ENDDO + ENDDO + RETURN + END +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1998 +! SUBROUTINE RFDPAR1 +! Initialize the Beta and exponential Rate vectors characterizing the unit- +! width pseudo-Gaussian of degree M. +! +! <-- BE: Beta vector of coupling coefficients between input and each +! exponential component. For complex exponentials (which occur in +! conjugate pairs) store REAL, then IMAGINARY, of one member of pair. +! <-- RATE: Vector of "decay rates" characteristic of the exponential +! components. For paired complex rates, same convention as for BE. +! --> M: Degree of approximation to the Gaussian [FT of this pseudo- +! Gaussian is proportional to 1./(1+k**2+ ...+k**(2M)/M!)]. +!------------------------------------------------------------------------------ + SUBROUTINE RFDPAR1(BE,RATE,M) + IMPLICIT COMPLEX(C) + PARAMETER(QCRIT=1.E-3) + PARAMETER(NN=12) + LOGICAL POLISH + DIMENSION COF(0:NN),CROOT(NN),VAN(NN,NN),BE(m),RATE(m) + DATA POLISH/.TRUE./ + polish=.true. + KMOD2=MOD(M,2) + COF(0)=1. + DO I=1,M + COF(I)=.5*COF(I-1)/I + ENDDO + CALL ZROOTS(COF,M,CROOT,POLISH) + IF(KMOD2.EQ.1)THEN ! Treat the single real root: + R=-REAL(CROOT(1)) + Q=-AIMAG(CROOT(1)) + QA=ABS(Q) + IF(QA.GT.QCRIT)STOP + R=SQRT(R) + RATE(1)=R + VAN(1,1)=1. + VAN(2,1)=r + DO I=3,M + VAN(I,1)=VAN(I-1,1)*R*R + ENDDO + ENDIF + DO J2=2,M,2 ! Loop over remaining independent complex roots + JREAL=KMOD2+J2-1 + JIMAG=KMOD2+J2 + CA=-CROOT(J2) + CB=CSQRT(CA) + R=REAL(CB) + Q=AIMAG(CB) + IF(R.LT.0.)THEN + CB=-CB + R=-R + Q=-Q + ENDIF + RATE(JREAL)=R + RATE(JIMAG)=Q + VAN(1,JREAL)=1. + VAN(1,JIMAG)=0. + DO I=2,M + IPOW=I*2-3 + CC=CB**IPOW + VAN(I,JREAL)=REAL(CC) + VAN(I,JIMAG)=-AIMAG(CC) + ENDDO + ENDDO + BE(1)=1. + DO I=2,M + BE(I)=0. + ENDDO + CALL LINMM(VAN,BE,M,1,NN,M) + RETURN + END +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1998 +! SUBROUTINE RFDPAR2 +! Initialize the "turning" matrix and the amplitude rescaling factor +! of the pseudo-Gaussian smoother of degree M +! +! --> BE: Beta vector (computed in previous call to RFDPAR1). +! --> RATE: Rate vector of the (in general complex) exponential contributions. +! <-- TURN: Turning matrix for 2nd sweep of filter along a line. +! <-- SAMP: Factor by which the amplitude at second sweep is normalized. +! --> M: Degree of pseudo-Gaussian +!------------------------------------------------------------------------------ + SUBROUTINE RFDPAR2(BE,RATE,TURN,SAMP,M) + PARAMETER(NN=12) + IMPLICIT COMPLEX(C) + DIMENSION BE(M),RATE(M),TURN(M,M) + KMOD2=MOD(M,2) + S=0. + IF(KMOD2.EQ.1)THEN ! The first root is real: + R1=RATE(1) + BE1=BE(1) + TURN(1,1)=BE1/(2*R1) + S=S+TURN(1,1)*BE1 + DO LR=KMOD2+1,M,2 + LI=LR+1 + CBE=CMPLX(BE(LR),BE(LI)) + CRL=CMPLX(RATE(LR),RATE(LI)) + CL1=CBE/(R1+CRL) + TURN(LR,1)=REAL(CL1) + TURN(LI,1)=AIMAG(CL1) + C1L=BE1/(R1+CRL) + TURN(1,LR)=REAL(C1L) + TURN(1,LI)=-AIMAG(C1L) + S=S+TURN(LR,1)*BE1+TURN(1,LR)*BE(LR)+TURN(1,LI)*BE(LI) + ENDDO + ENDIF + DO KR=KMOD2+1,M,2 + KI=KR+1 + CRK=CMPLX(RATE(KR),RATE(KI)) + CRJ=CONJG(CRK) + BEKR=BE(KR) + BEKI=BE(KI) + DO LR=KMOD2+1,M,2 + LI=LR+1 + CBEH=.5*CMPLX(BE(LR),BE(LI)) + CRL=CMPLX(RATE(LR),RATE(LI)) + CLK=CBEH/(CRL+CRK) + CLJ=CBEH/(CRL+CRJ) + CLKR=CLK+CLJ + CLKI=CLK-CLJ + TURN(LR,KR)= REAL(CLKR) + TURN(LI,KR)= AIMAG(CLKR) + TURN(LR,KI)=-AIMAG(CLKI) + TURN(LI,KI)= REAL(CLKI) + S=S+TURN(LR,KR)*BEKR+TURN(LR,KI)*BEKI + ENDDO + ENDDO + SAMP=.5/S + RETURN + END + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ +! R.J.Purser, National Meteorological Center, Washington D.C. 1998 +! SUBROUTINE RFDPARV +! Initialize Alpha coefficients for pseudo-Gaussian smoother of degree M +! along a line with varying effective scale at each point +! +! --> DSH: Array of "effective" spacing (in stretched space S) between gridpts +! --> RATE: Exponential rates in this degree of approximation to the Gaussian. +! <-- AL: Array of "transfer function" coefficients to propagate vectors +! GAP and DEP of amplitudes of the exponential contributions to +! a filtered field along this grid line. +! --> N: Number of grid spaces along this line (ie, number of grdpts = N+1) +! --> M: Degree of approximation to pseudo-Gaussian. +!------------------------------------------------------------------------------ + + SUBROUTINE RFDPARV(DSH,RATE,AL,N,M) + IMPLICIT COMPLEX(C) + DIMENSION DSH(N),RATE(M),AL(n,m) + + KMOD2=MOD(M,2) + IF(KMOD2.EQ.1)THEN + R1=RATE(1) + DO I=1,N + AL(I,1)=EXP(-R1*DSH(I)) + ENDDO + ENDIF + DO KR=KMOD2+1,M,2 + KI=KR+1 + CRK=CMPLX(RATE(KR),RATE(KI)) + DO I=1,N + CRDS=CRK*DSH(I) + CAL=CEXP(-CRDS) + AL(i,KR)=REAL(CAL) + AL(i,KI)=AIMAG(CAL) + ENDDO + ENDDO + RETURN + END + + + SUBROUTINE ZROOTS(A,M,ROOTS,POLISH) + PARAMETER (EPS=1.E-6,MAXM=101) + COMPLEX A(*),ROOTS(M),AD(MAXM),X,B,C + LOGICAL POLISH + DO 11 J=1,M+1 + AD(J)=A(J) +11 CONTINUE + DO 13 J=M,1,-1 + X=CMPLX(0.,0.) + CALL LAGUER(AD,J,X,EPS,.FALSE.) + IF(ABS(AIMAG(X)).LE.2.*EPS**2*ABS(REAL(X))) X=CMPLX(REAL(X),0.) + ROOTS(J)=X + B=AD(J+1) + DO 12 JJ=J,1,-1 + C=AD(JJ) + AD(JJ)=B + B=X*B+C +12 CONTINUE +13 CONTINUE + IF (POLISH) THEN + DO 14 J=1,M + CALL LAGUER(A,M,ROOTS(J),EPS,.TRUE.) +14 CONTINUE + ENDIF + DO 16 J=2,M + X=ROOTS(J) + DO 15 I=J-1,1,-1 + IF(REAL(ROOTS(I)).LE.REAL(X))GO TO 10 + ROOTS(I+1)=ROOTS(I) +15 CONTINUE + I=0 +10 ROOTS(I+1)=X +16 CONTINUE + RETURN + END + + SUBROUTINE LAGUER(A,M,X,EPS,POLISH) + COMPLEX A(*),X,DX,X1,B,D,F,G,H,SQ,GP,GM,G2,ZERO + LOGICAL POLISH + PARAMETER (ZERO=(0.,0.),EPSS=6.E-8,MAXIT=100) + DXOLD=CABS(X) + DO 12 ITER=1,MAXIT + B=A(M+1) + ERR=CABS(B) + D=ZERO + F=ZERO + ABX=CABS(X) + DO 11 J=M,1,-1 + F=X*F+D + D=X*D+B + B=X*B+A(J) + ERR=CABS(B)+ABX*ERR +11 CONTINUE + ERR=EPSS*ERR + IF(CABS(B).LE.ERR) THEN + RETURN + ELSE + G=D/B + G2=G*G + H=G2-2.*F/B + SQ=CSQRT((M-1)*(M*H-G2)) + GP=G+SQ + GM=G-SQ + IF(CABS(GP).LT.CABS(GM)) GP=GM + DX=M/GP + ENDIF + X1=X-DX + IF(X.EQ.X1)RETURN + X=X1 + CDX=CABS(DX) + DXOLD=CDX + IF(.NOT.POLISH)THEN + IF(CDX.LE.EPS*CABS(X))RETURN + ENDIF +12 CONTINUE + PAUSE 'too many iterations' + RETURN + END + diff --git a/util/NMC_Bkerror/sorc_aero/specgrid.f90 b/util/NMC_Bkerror/sorc_aero/specgrid.f90 new file mode 100644 index 000000000..e0cc57485 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/specgrid.f90 @@ -0,0 +1,430 @@ +module specgrid + use kinds, only: r_kind,r_double + use variables, only: use_nemsio + implicit none + + integer jcap,jcapin,jcapsmooth,nc,ncin,ncd2 + integer iromb,idrt,imax,jmax,ijmax,jn,js,kw,jb,je,jc,ioffset + real(r_kind),allocatable,dimension(:):: factsml,factvml + real(r_kind),allocatable,dimension(:):: eps,epstop,enn1,elonn1,eon,eontop + real(r_kind),allocatable,dimension(:):: clat,slat,wlat + real(r_kind),allocatable,dimension(:,:):: pln,plntop + real(r_double),allocatable,dimension(:):: afft + +contains + + subroutine init_spec_vars(nlat,nlon,nsig) + implicit none + + integer,intent(in):: nlat,nlon,nsig + integer ii,ii1,l,m,ncpus + real(r_kind) zero1 + +! Set constants + nc=(jcap+1)*(jcap+2) +!>swei for nemsio + if ( use_nemsio ) then + ncin=nlat*nlon + else + ncin=(jcapin+1)*(jcapin+2) + end if +!>swei + ncd2=nc/2 + +! Allocate more arrays related to transforms + allocate(factsml(nc),factvml(nc)) +! Set up factsml and factvml + ii=-1; ii1=0 + do l=0,jcap + zero1=float(min(1,l)) + do m=0,jcap-l + ii=ii+2; ii1=ii1+2 + factsml(ii)=1.; factsml(ii1)=zero1 + factvml(ii)=1.; factvml(ii1)=zero1 + end do + end do + factvml(1)=0. + +! Set other constants used in transforms +!>swei + iromb=0 +!0) then + do i=1,ijmax + grid(i)=0. + end do + endif + +! Call spectral <--> grid transform + call sptranf_s(wave,grid,grid,idir) + + return + end subroutine sptez_s + + subroutine destroy_spec_vars + deallocate(factsml,factvml) + deallocate(eps,epstop,enn1,elonn1,eon,eontop,afft,& + clat,slat,wlat,pln,plntop) + return + end subroutine destroy_spec_vars + + + subroutine sptranf_s(wave,gridn,grids,idir) + use kinds, only: r_kind + implicit none + +! Declare passed variables + integer,intent(in):: idir + real(r_kind),dimension(nc),intent(inout):: wave + real(r_kind),dimension(ijmax),intent(inout):: gridn + real(r_kind),dimension(ijmax),intent(inout):: grids + +! Declare local variables + integer i,j,jj,ij,ijn,ijs,mp + real(r_kind),dimension(2*(jcap+1)):: wtop + real(r_kind),dimension(imax,2):: g + +! Initialize local variables + mp=0 + + do i=1,2*(jcap+1) + wtop(i)=0. + end do + +! Transform wave to grid + if(idir.gt.0) then + do j=jb,je + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + wave,wtop,g,idir) + do i=1,imax + jj = j-jb + ijn = i + jj*jn + ijs = i + jj*js + ioffset + gridn(ijn)=g(i,1) + grids(ijs)=g(i,2) + enddo + enddo +! Transform grid to wave + else + do j=jb,je + if(wlat(j).gt.0.) then + do i=1,imax + jj = j-jb + ijn = i + jj*jn + ijs = i + jj*js + ioffset + g(i,1)=gridn(ijn) + g(i,2)=grids(ijs) + enddo + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + wave,wtop,g,idir) + endif + enddo + endif + return + end subroutine sptranf_s + +!>swei +! Try to port sptranfv to here similar to sptranf to sptranf_s + subroutine sptezv_s(waved,wavez,gridu,gridv,idir) + use kinds, only: r_kind + implicit none + +! Declare passed variables + integer,intent(in):: idir + real(r_kind),dimension(nc),intent(inout):: waved,wavez + real(r_kind),dimension(ijmax),intent(inout):: gridu,gridv + +! Declare local variables + integer i + +! Zero appropriate output array based on direction of transform + if (idir<0) then + do i=1,nc + waved(i)=0. + wavez(i)=0. + end do + elseif (idir>0) then + do i=1,ijmax + gridu(i)=0. + gridv(i)=0. + end do + endif + +! Call spectral <--> grid transform + call sptranfv_s(waved,wavez,gridu,gridu,gridv,gridv,idir) + + return + + end subroutine sptezv_s + + + subroutine sptranfv_s(waved,wavez,gridun,gridus,gridvn,gridvs,idir) + use kinds, only: r_kind + implicit none + +! Declare passed variables + integer,intent(in):: idir + real(r_kind),dimension(nc),intent(inout):: waved,wavez + real(r_kind),dimension(ijmax),intent(inout):: gridun,gridvn + real(r_kind),dimension(ijmax),intent(inout):: gridus,gridvs + +! Declare local variables + integer i,j,jj,ij,ijn,ijs,mp + real(r_kind),dimension(2*(jcap+1)):: utop,vtop + real(r_kind),dimension(nc) :: u,v + real(r_kind),dimension(imax,2):: ug,vg + +! Initialize local variables + mp=1 + utop=0. ; vtop=0. + u=0. ; v=0. + +! Transform wave to grid + if (idir.gt.0) then + call spdz2uv(iromb,jcap,enn1,elonn1,eon,eontop, & + waved,wavez,u,v,utop,vtop) + do j=jb,je + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + u,utop,ug,idir) + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + v,vtop,vg,idir) + do i=1,imax + jj = j-jb + ijn = i + jj*jn + ijs = i + jj*js + ioffset + gridun(ijn)=ug(i,1) + gridus(ijs)=ug(i,2) + gridvn(ijn)=vg(i,1) + gridvs(ijs)=vg(i,2) + enddo + enddo + else + do j=jb,je + if(wlat(j).gt.0.) then + do i=1,imax + jj = j-jb + ijn = i + jj*jn + ijs = i + jj*js + ioffset + ug(i,1)=gridun(ijn)/clat(j)**2 + ug(i,2)=gridus(ijs)/clat(j)**2 + vg(i,1)=gridvn(ijn)/clat(j)**2 + vg(i,2)=gridvs(ijs)/clat(j)**2 + enddo + endif + write(6,*) 'tranf1' + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + u,utop,ug,idir) + call sptranf1(iromb,jcap,idrt,imax,jmax,j,j, & + eps,epstop,enn1,elonn1,eon,eontop, & + afft,clat(j),slat(j),wlat(j), & + pln(1,j),plntop(1,j),mp, & + v,vtop,vg,idir) + enddo + call spuv2dz(iromb,jcap,enn1,elonn1,eon,eontop, & + u,v,utop,vtop,waved,wavez) + endif + return + + end subroutine sptranfv_s +!s to s-->n + do j=2,nlat-1 + jj=nlat-j + do i=1,nlon + gridtmp(j,i)=grid_in(i,jj) + end do + end do + +! Compute mean along southern and northern latitudes + sumn=zero + sums=zero + nlatm2=nlat-2 + do i=1,nlon + sumn=sumn+grid_in(i,1) + sums=sums+grid_in(i,nlatm2) + end do + rnlon=1./float(nlon) + sumn=sumn*rnlon + sums=sums*rnlon + +! Load means into local work array + do i=1,nlon + gridtmp(1,i) =sums + gridtmp(nlat,i)=sumn + end do + +! Transfer local work array to output grid + do k=1,iglobal + i=ltosi(k) + j=ltosj(k) + grid_out(k)=gridtmp(i,j) + end do + + + return + end subroutine fill_ns + + subroutine load_grid(grid_in,grid_out) + use variables, only: nlat,nlon + use kinds, only: r_kind,i_kind + implicit none + + real(r_kind),dimension(nlat,nlon),intent(in):: grid_in ! input grid + real(r_kind),dimension(nlon,nlat-2),intent(out):: grid_out ! output grid + + integer(i_kind) i,j,k,nlatm1,jj,j2 + +! Transfer contents of local array to output array. + nlatm1=nlat-1 + do j=2,nlatm1 + jj=nlat-j+1 + j2=j-1 + do i=1,nlon + grid_out(i,j2)=grid_in(jj,i) + end do + end do + + return + end subroutine load_grid + + subroutine unload_grid(grid_in,grid_out) + use variables, only: nlat,nlon + use kinds, only: r_kind,i_kind + implicit none + + real(r_kind),dimension(nlon,nlat-2),intent(in):: grid_in ! input grid + real(r_kind),dimension(nlat,nlon),intent(out):: grid_out ! output grid + + integer(i_kind) i,j,k,nlatm1,jj,j2 + +! Transfer contents of local array to output array. + do j=2,nlat-1 + jj=nlat-j + do i=1,nlon + grid_out(j,i)=grid_in(i,jj) + end do + end do + +! for now attempt something stupid at pole + do j=1,nlon + grid_out(1,j)=grid_out(2,j) + grid_out(nlat,j)=grid_out(nlat-1,j) + end do + + return + end subroutine unload_grid + + + subroutine jcaptrans(z,fact,z4) + use kinds, only: r_kind,r_single + implicit none + integer j,iiin,iiout,l,m + real(r_kind),dimension(nc):: z,fact + real(r_single),dimension(ncin):: z4 + do j=1,nc + z(j)=0.0 + end do + iiin=1 + iiout=1 + do l=0,min(jcap,jcapin) + do m=0,min(jcap,jcapin)-l + if(m < jcapsmooth .and. l < jcapsmooth)then + z(iiout+2*m) =fact(iiout+2*m)*z4(iiin+2*m) + z(iiout+2*m+1)=fact(iiout+2*m+1)*z4(iiin+2*m+1) + else + z(iiout+2*m) =0.0 + z(iiout+2*m+1)=0.0 + end if + end do + iiin=iiin+2*(jcapin-l+1) + iiout=iiout+2*(jcap-l+1) + end do + return + end subroutine jcaptrans + + +end module specgrid + diff --git a/util/NMC_Bkerror/sorc_aero/statsmain_aerosol.f90 b/util/NMC_Bkerror/sorc_aero/statsmain_aerosol.f90 new file mode 100644 index 000000000..8dd677cf3 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/statsmain_aerosol.f90 @@ -0,0 +1,159 @@ +program statsmain_aerosol +!$$$ main program documentation block +! . . . . +! main program: statsmain +! prgrmmr: kleist org: np20 date: 2005-01-15 +! +! program history log: +! 2005-01-xx kleist initial version of stats code +! 2005-04-18 kleist use sp library calls, add ability to easily run +! in single or double precision, modify post module +! to create byte addressable files for viewing using +! GRADS, compute variances for pseudo-RH and normalized +! RH, use IO on gridded fields to reduce memory usage +! 2009-02-xx kleist perform complete overhaul of MPI usage to use +! subdomain structure of GSI and significanlty reduce +! memory requirements +! +! abstract: +! This code computes background error statistics to be used with the +! GSI analysis code. The NMC method, utilizing 24/48 hour forecast +! pairs valid at the same time, is used to compute variance, length +! scale, and linear balance projection estimates. +! +! input files: +! fort.10 - listing of NCEP global model forecast files +! berror_sst - fixed, global sst statistics file +! +! output files: +! gsi.berror_stats - double precision stats output (serves as input to GSI) +! bgstats_sp.grd - single precision byte-addressable file for latidude +! dependent variables +! sststats_sp.grd - single precision byte-addressable file SST statistics +! +! remarks: +! This code is primarily a research code, and has not been well tested. If +! problems are found, please contact Daryl (daryl.kleist@noaa.gov) +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use variables, only: nsig,nlat,nlon,maxcases,hybrid,& + smoothdeg,init_defaults,create_grids,destroy_grids,& + destroy_variables,rearth,rlats,wgtlats,mype,npe,& + create_mapping,destroy_mapping,biasrm,destroy_biasrm,& + vertavg,use_nemsio,modelname + use specgrid, only: jcap,jcapin,jcapsmooth,init_spec_vars,destroy_spec_vars + use postmod, only: writefiles_aerosol + use comm_mod, only: init_mpi_vars,destroy_mpi_vars + implicit none + include 'mpif.h' + + integer k,n,total,numcases,mycases,ierror + +! define namelist +! NAMSTAT +! jcapin - spectral resolution of forecast pairs +! jcap - spectral resolution for spectral to grid transform(default = jcap) +! jcapsmooth- spectral resolution for smoothing of input fields (default = min(jcap,jcapin)) +! nsig - number of vertical levels +! nlat - number of latitudes +! nlon - number of longitudes +! maxcases - maximum number of forecast pairs to process +! hybrid - logical for hybrid vertical coordinate +! smoothdeg - degree of horizontal smoothing to apply in latitudinal direction + + namelist/namstat/jcap,jcapin,jcapsmooth,nsig,nlat,nlon,maxcases, & + hybrid,smoothdeg,biasrm,vertavg,use_nemsio,modelname !swei add use_nemsio + + +! MPI initial setup + call mpi_init(ierror) + call mpi_comm_size(mpi_comm_world,npe,ierror) + call mpi_comm_rank(mpi_comm_world,mype,ierror) + +! Initialize defaults for namelist variables + call init_defaults + +! Read in namelist + jcapin=0 + jcap=0 + jcapsmooth=99999 + open(11,file='stats.parm') + read(11,namstat) + if(jcapin == 0)jcapin=jcap + if(jcap == 0)jcap=jcapin + + if(mype==0) then + write(6,*)'starting computation of background stats with ',npe,' tasks' + write(6,namstat) + endif + +!!!! Initialization +! + if(mype==0) write(6,*) 'INITIALIZE VARIABLES' + call create_grids + call create_mapping +!>swei +! This subroutine initialize all variables for spectrum transform + call init_spec_vars(nlat,nlon,nsig) + + call initvars(mype,npe) + call init_mpi_vars(nsig,mype) + +! need coefficients for finite differencing + if(mype==0) write(6,*) 'GET FINITE DIFFERENCE COEFFS' + call inisph(rearth,rlats(2),wgtlats(2),nlon,nlat-2) + +! Call routine to do subdomain decomposition based on +! grid size and number of pe's + call deter_subdomain(mype) + call init_commvars(mype) +! +!!!! End Initialization + + +! Make call to see how many available files there are + if(mype==0) write(6,*) 'COUNT NUMBER OF AVAILABLE CASES' + call getcases_nems(numcases,mype) + call readpairs_aerosol(npe,mype,numcases) + +! Read in spectral coeffs and right out subdomain grids to scratch files + +! if(biasrm) call biascor(numcases,mype) + +! Get balance projection matrices +! call balprojs(numcases,mype) + +! Compute Three-Dimensional Variances (Full variables +!! call variances3d(numcases,mype) + +! Get lat-dependend variances + call variances_aerosol(numcases,mype) + +! Vertical length scales + call vertsc_aerosol(numcases,mype) + +! Horizontal length scales + call horizsc_aerosol(numcases,mype) + +! post Processing + if (mype==0) then + write(6,*) 'WRITE OUT BACKGROUND ERROR STATISTICS' + call writefiles_aerosol + end if + +! finish up, deallocate memory + call destroy_grids + call destroy_mapping + call destroy_spec_vars + call destroy_mpi_vars + call destroy_variables +! if(biasrm) call destroy_biasrm + + if (mype==0) write(6,*) '*** STATS CODE COMPLETE! ***' + call mpi_finalize(ierror) + +end program statsmain_aerosol diff --git a/util/NMC_Bkerror/sorc_aero/variables.f90 b/util/NMC_Bkerror/sorc_aero/variables.f90 new file mode 100644 index 000000000..22c1881f5 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/variables.f90 @@ -0,0 +1,246 @@ +module variables +!$$$ module documentation block + use kinds, only: r_kind,r_single,r_double,i_kind + implicit none + +! general + integer maxcases,filunit1,filunit2 + real(r_kind) smoothdeg + +! forecast pair file variables + character(100),allocatable,dimension(:):: filename + integer,allocatable,dimension(:):: na,nb + +! from GSI gridmod: + logical hybrid,db_prec,biasrm,vertavg + integer nlat,nlon,nsig,dimbig,option,noq,lat1,lon1 + integer ntrac5,idvc5,idvm5,idpsfc5,idthrm5 + real(r_single),allocatable,dimension(:):: rlons,ak5,bk5,ck5,cp5 + real(r_double),allocatable,dimension(:):: wgtlats,rlats + logical use_nemsio + +! MPI related stuff + integer mype,npe,iglobal,itotsub + integer(i_kind),allocatable,dimension(:):: jstart ! start lon of the whole array on each pe + integer(i_kind),allocatable,dimension(:):: istart ! start lat of the whole array on each pe + integer(i_kind),allocatable,dimension(:):: ilat1 ! no. of lats for each subdomain (no buffer) + integer(i_kind),allocatable,dimension(:):: jlon1 ! no. of lons for each subdomain (no buffer) + integer(i_kind),allocatable,dimension(:):: ijn_s ! no. of horiz. points for each subdomain (with buffer) + integer(i_kind),allocatable,dimension(:):: ijn ! no. of horiz. points for each subdomain (no buffer) + integer(i_kind),allocatable,dimension(:):: isc_g ! no. array, count for send to global; size of subdomain + + ! comm. array ... + integer(i_kind),allocatable,dimension(:):: irc_s ! count for receive on subdomain + integer(i_kind),allocatable,dimension(:):: ird_s ! displacement for receive on subdomain + integer(i_kind),allocatable,dimension(:):: isd_g ! displacement for send to global + integer(i_kind),allocatable,dimension(:):: displs_s ! displacement for send from subdomain + integer(i_kind),allocatable,dimension(:):: displs_g ! displacement for receive on global grid + + ! array element indices for location of ... + integer(i_kind),allocatable,dimension(:):: ltosi ! lats in iglobal array excluding buffer + integer(i_kind),allocatable,dimension(:):: ltosj ! lons in iglobal array excluding buffer + integer(i_kind),allocatable,dimension(:):: ltosi_s ! lats in itotsub array including buffer + integer(i_kind),allocatable,dimension(:):: ltosj_s ! lons in itotsub array including buffer + + +! allocateable arrays + real(r_kind),allocatable,dimension(:):: sweight + +! Bias correction arrays + real(r_kind),allocatable,dimension(:,:,:):: bbiasz,bbiasd,bbiast,bcorrz,bcorrd,bcorrt + real(r_kind),allocatable,dimension(:,:):: bbiasp,bcorrp + +! variances + real(r_kind),allocatable,dimension(:,:):: d1var,d2var,d3var,d4var,d5var, & + s1var,s2var,s3var,s4var, & + so4var,oc1var,oc2var,bc1var,bc2var + +! horizontal length scales + real(r_kind),allocatable,dimension(:,:):: d1hln,d2hln,d3hln,d4hln,d5hln, & + s1hln,s2hln,s3hln,s4hln, & + so4hln,oc1hln,oc2hln,bc1hln,bc2hln + +! vertical length scales + real(r_kind),allocatable,dimension(:,:):: d1vln,d2vln,d3vln,d4vln,d5vln, & + s1vln,s2vln,s3vln,s4vln, & + so4vln,oc1vln,oc2vln,bc1vln,bc2vln + +! balance constraints +! real(r_kind),allocatable,dimension(:,:,:):: tcon +! real(r_kind),allocatable,dimension(:,:):: pscon,vpcon + +! other variables + real(r_double),allocatable,dimension(:):: coef,coriolis + +! from GSI constants: + integer izero + real(r_kind) rd,rv,cvap,cliq,zero,one,hvap,& + psat,ttp,fv,pi,hfus,csol,deg2rad,grav,& + half,two,omega + real(r_double) rearth + integer(i_kind) ione + +! define parms + parameter(rearth = 6.3712e+6_r_double) ! radius of earth (m) + parameter(omega = 7.2921e-5_r_kind) ! angular velocity of earth (1/s) + parameter(rd = 2.8705e+2_r_kind) ! gas constant of dry air (J/kg/K) + parameter(rv = 4.6150e+2_r_kind) ! gas constant of h2o vapor (J/kg/K) + parameter(cvap = 1.8460e+3_r_kind) ! specific heat of h2o vapor (J/kg/K) + parameter(cliq = 4.1855e+3_r_kind) ! specific heat of liquid h2o (J/kg/K) + parameter(hvap = 2.5000e+6_r_kind) ! latent heat of h2o condensation (J/kg) + parameter(psat = 6.1078e+2_r_kind) ! pressure at h2o triple point (Pa) + parameter(csol = 2.1060e+3_r_kind) ! specific heat of solid h2o (ice)(J/kg/K) + parameter(ttp = 2.7316e+2_r_kind) ! temperature at h2o triple point (K) + parameter(hfus = 3.3358e+5_r_kind) ! latent heat of h2o fusion (J/kg) + parameter(pi = 3.141593e+0_r_kind)! pi () + parameter(grav = 9.80665_r_kind) ! gravity + parameter(izero = 0) + parameter(zero = 0.0_r_kind) + parameter(one = 1.0_r_kind) + parameter(two = 2.0_r_kind) + parameter(half = one/two) + parameter(ione = 1_i_kind) + + real(r_kind),parameter:: r60 = 60._r_kind + real(r_kind),parameter:: r3600 = 3600._r_kind + +! Derived constants + parameter(fv = rv/rd-1._r_kind) ! used in virtual temp. equation () + +! aerosol name in different model + character(len=4) :: modelname + character(len=8),dimension(15):: aeroname,ngacaeroname,fv3aeroname + data ngacaeroname /'du001','du002','du003','du004','du005', & + 'se001','se002','se003','se004','se005', & + 'so4','ocphobic','ocphilic','bcphobic','bcphilic'/ + data fv3aeroname /'dust1','dust2','dust3','dust4','dust5', & + 'seas1','seas2','seas3','seas4','seas5', & + 'sulf','oc1','oc2','bc1','bc2'/ + +contains + + subroutine init_defaults + + implicit none + + nsig=64 + maxcases=10 + nlat=258 + nlon=512 + hybrid=.false. + biasrm=.false. + vertavg=.false. + smoothdeg=4.0 + dimbig=5000 + noq=5 + use_nemsio=.false. + modelname='ngac' + + end subroutine init_defaults + + subroutine create_grids + implicit none + + allocate(coef(3*nlat+4*(2*(noq+5)+1)*(nlat+nlon/2))) + allocate(coriolis(nlat)) + + allocate(d1var(nlat,nsig),d2var(nlat,nsig),d3var(nlat,nsig),d4var(nlat,nsig),d5var(nlat,nsig), & + s1var(nlat,nsig),s2var(nlat,nsig),s3var(nlat,nsig),s4var(nlat,nsig),so4var(nlat,nsig), & + oc1var(nlat,nsig),oc2var(nlat,nsig),bc1var(nlat,nsig),bc2var(nlat,nsig)) + + allocate(d1hln(nlat,nsig),d2hln(nlat,nsig),d3hln(nlat,nsig),d4hln(nlat,nsig),d5hln(nlat,nsig), & + s1hln(nlat,nsig),s2hln(nlat,nsig),s3hln(nlat,nsig),s4hln(nlat,nsig),so4hln(nlat,nsig), & + oc1hln(nlat,nsig),oc2hln(nlat,nsig),bc1hln(nlat,nsig),bc2hln(nlat,nsig)) + + allocate(d1vln(nlat,nsig),d2vln(nlat,nsig),d3vln(nlat,nsig),d4vln(nlat,nsig),d5vln(nlat,nsig), & + s1vln(nlat,nsig),s2vln(nlat,nsig),s3vln(nlat,nsig),s4vln(nlat,nsig),so4vln(nlat,nsig), & + oc1vln(nlat,nsig),oc2vln(nlat,nsig),bc1vln(nlat,nsig),bc2vln(nlat,nsig)) + + +! initialize all variables to zero + d1var=zero ; d2var=zero ; d3var=zero ; d4var=zero ; d5var=zero + s1var=zero ; s2var=zero ; s3var=zero ; s4var=zero ; so4var=zero + oc1var=zero ; oc2var=zero ; bc1var=zero ; bc2var=zero + + d1hln=zero ; d2hln=zero ; d3hln=zero ; d4hln=zero ; d5hln=zero + s1hln=zero ; s2hln=zero ; s3hln=zero ; s4hln=zero ; so4hln=zero + oc1hln=zero ; oc2hln=zero ; bc1hln=zero ; bc2hln=zero + + d1vln=zero ; d2vln=zero ; d3vln=zero ; d4vln=zero ; d5vln=zero + s1vln=zero ; s2vln=zero ; s3vln=zero ; s4vln=zero ; so4vln=zero + oc1vln=zero ; oc2vln=zero ; bc1vln=zero ; bc2vln=zero + + end subroutine create_grids + + subroutine create_mapping + implicit none + integer(i_kind) i + + allocate(jstart(npe),istart(npe),& + ilat1(npe),jlon1(npe),& + ijn_s(npe),irc_s(npe),ird_s(npe),displs_s(npe),& + ijn(npe),isc_g(npe),isd_g(npe),displs_g(npe)) + + do i=1,npe + jstart(i) = izero + istart(i) = izero + ilat1(i) = izero + jlon1(i) = izero + ijn_s(i) = izero + irc_s(i) = izero + ird_s(i) = izero + displs_s(i) = izero + ijn(i) = izero + isc_g(i) = izero + isd_g(i) = izero + displs_g(i) = izero + end do + + return + end subroutine create_mapping + + subroutine destroy_mapping + implicit none + deallocate(ltosi,ltosj,ltosi_s,ltosj_s) + deallocate(jstart,istart,ilat1,jlon1,& + ijn_s,displs_s,& + ijn,isc_g,isd_g,displs_g) + + return + end subroutine destroy_mapping + + subroutine destroy_biasrm + implicit none + deallocate(bbiasz,bbiasd,bbiast,bcorrz,bcorrd,bcorrt) + deallocate(bbiasp,bcorrp) + + return + end subroutine destroy_biasrm + + subroutine destroy_grids + implicit none + + deallocate(filename,na,nb) + deallocate(d1var,d2var,d3var,d4var,d5var, & + s1var,s2var,s3var,s4var,so4var, & + oc1var,oc2var,bc1var,bc2var) + deallocate(d1hln,d2hln,d3hln,d4hln,d5hln, & + s1hln,s2hln,s3hln,s4hln,so4hln, & + oc1hln,oc2hln,bc1hln,bc2hln) + deallocate(d1vln,d2vln,d3vln,d4vln,d5vln, & + s1vln,s2vln,s3vln,s4vln,so4vln, & + oc1vln,oc2vln,bc1vln,bc2vln) + + + end subroutine destroy_grids + + subroutine destroy_variables + deallocate(rlats,rlons) + deallocate(ak5,bk5,ck5,cp5) + deallocate(coef) + deallocate(coriolis) + + return + end subroutine destroy_variables + +end module variables diff --git a/util/NMC_Bkerror/sorc_aero/variances_aerosol.f90 b/util/NMC_Bkerror/sorc_aero/variances_aerosol.f90 new file mode 100644 index 000000000..8887c51e3 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/variances_aerosol.f90 @@ -0,0 +1,390 @@ +subroutine variances_aerosol(numcases,mype) + use kinds, only: r_kind,r_single,i_kind + use postmod, only: smoothlat + use variables,only: nlat,nlon,nsig,lat1,lon1,filunit1,filunit2,zero,& + displs_g,ijn,two,db_prec,istart,ilat1,jstart,npe,& + d1var,d2var,d3var,d4var,d5var,s1var,s2var,s3var,s4var, & + so4var,oc1var,oc2var,bc1var,bc2var,& + iglobal,ltosi,ltosj,half,zero,one,ione,two,smoothdeg,vertavg + implicit none + include 'mpif.h' + + integer(i_kind),intent(in):: numcases,mype + + real(r_kind),dimension(lat1,lon1,nsig):: d1a,d2a,d3a,d4a,d5a, & + s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a + real(r_kind),dimension(lat1,lon1,nsig):: d1b,d2b,d3b,d4b,d5b, & + s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b + + real(r_kind),dimension(lat1,lon1,nsig):: d1c,d2c,d3c,d4c,d5c, & + s1c,s2c,s3c,s4c,so4c,oc1c,oc2c,bc1c,bc2c + + real(r_kind),dimension(iglobal):: work1 + real(r_kind),dimension(nlat,nlon):: workgrd + +! Normalized RH variance arrays + real(r_kind),dimension(25,nsig):: qcount,qamp,qamp2,qcount2 + real(r_kind),dimension(25):: qcavg + real(r_kind) :: qctot,qdiff,tiny_r_kind + + real(r_kind) r_norm,r025 + + integer(i_kind) i,j,k,m,n,mype_work,mm1,ierror,iret + integer(i_kind) mpi_rtype,ix,ni1,ni2,kk,ll,ibin + + if (db_prec) then + mpi_rtype=mpi_real8 + else + mpi_rtype=mpi_real4 + end if + + tiny_r_kind = tiny(zero) + + mype_work=npe-1 + mm1=mype+1 + r_norm=1./float(numcases) + ibin=25 + r025=0.25_r_kind + +! Initialize subdomain variance arrays + d1var=zero ; d2var=zero ; d3var=zero ; d4var=zero ; d5var=zero ; + s1var=zero ; s2var=zero ; s3var=zero ; s4var=zero ; + so4var=zero ; oc1var=zero ; oc2var=zero ; bc1var=zero ; bc2var=zero + + d1c=zero ; d2c=zero ; d3c=zero ; d4c=zero ; d5c=zero ; + s1c=zero ; s2c=zero ; s3c=zero ; s4c=zero ; + so4c=zero ; oc1c=zero ; oc2c=zero ; bc1c=zero ; bc2c=zero + + open(filunit1,form='unformatted',action='read') + rewind(filunit1) + open(filunit2,form='unformatted',action='read') + rewind(filunit2) + + do n=1,numcases + if (mype==0) write(6,*) 'VARIANCES, PROCESSING PAIR # ',n +! Read in subdomain grids + read(filunit1) d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a + read(filunit2) d1b,d2b,d3b,d4b,d5b,s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b + +! write(200+mype,*) 'after read in',so4a-s4a +! write(250+mype,*) 'after read in',so4b-s4b + + call delvars_aerosol(d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a, & + d1b,d2b,d3b,d4b,d5b,s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b,mype) + + + do k=1,nsig + do j=1,lon1 + do i=1,lat1 + d1c(i,j,k) = d1c(i,j,k) + (d1a(i,j,k)*d1a(i,j,k))*r_norm + d2c(i,j,k) = d2c(i,j,k) + (d2a(i,j,k)*d2a(i,j,k))*r_norm + d3c(i,j,k) = d3c(i,j,k) + (d3a(i,j,k)*d3a(i,j,k))*r_norm + d4c(i,j,k) = d4c(i,j,k) + (d4a(i,j,k)*d4a(i,j,k))*r_norm + d5c(i,j,k) = d5c(i,j,k) + (d5a(i,j,k)*d5a(i,j,k))*r_norm + s1c(i,j,k) = s1c(i,j,k) + (s1a(i,j,k)*s1a(i,j,k))*r_norm + s2c(i,j,k) = s2c(i,j,k) + (s2a(i,j,k)*s2a(i,j,k))*r_norm + s3c(i,j,k) = s3c(i,j,k) + (s3a(i,j,k)*s3a(i,j,k))*r_norm + s4c(i,j,k) = s4c(i,j,k) + (s4a(i,j,k)*s4a(i,j,k))*r_norm + so4c(i,j,k) = so4c(i,j,k) + (so4a(i,j,k)*so4a(i,j,k))*r_norm + oc1c(i,j,k) = oc1c(i,j,k) + (oc1a(i,j,k)*oc1a(i,j,k))*r_norm + oc2c(i,j,k) = oc2c(i,j,k) + (oc2a(i,j,k)*oc2a(i,j,k))*r_norm + bc1c(i,j,k) = bc1c(i,j,k) + (bc1a(i,j,k)*bc1a(i,j,k))*r_norm + bc2c(i,j,k) = bc2c(i,j,k) + (bc2a(i,j,k)*bc2a(i,j,k))*r_norm + end do + end do + end do + + end do ! end do over ncases + + + close(filunit1) + close(filunit2) + + do k=1,nsig + call mpi_gatherv(d1c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d1var(i,k) = d1var(i,k) + workgrd(i,j)/float(nlon) + end do + d1var(i,k) = max(tiny_r_kind,d1var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(d2c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d2var(i,k) = d2var(i,k) + workgrd(i,j)/float(nlon) + end do + d2var(i,k) = max(tiny_r_kind,d2var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(d3c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d3var(i,k) = d3var(i,k) + workgrd(i,j)/float(nlon) + end do + d3var(i,k) = max(tiny_r_kind,d3var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(d4c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d4var(i,k) = d4var(i,k) + workgrd(i,j)/float(nlon) + end do + d4var(i,k) = max(tiny_r_kind,d4var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(d5c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d5var(i,k) = d5var(i,k) + workgrd(i,j)/float(nlon) + end do + d5var(i,k) = max(tiny_r_kind,d5var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(s1c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s1var(i,k) = s1var(i,k) + workgrd(i,j)/float(nlon) + end do + s1var(i,k) = max(tiny_r_kind,s1var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(s2c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s2var(i,k) = s2var(i,k) + workgrd(i,j)/float(nlon) + end do + s2var(i,k) = max(tiny_r_kind,s2var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(s3c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s3var(i,k) = s3var(i,k) + workgrd(i,j)/float(nlon) + end do + s3var(i,k) = max(tiny_r_kind,s3var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(s4c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s4var(i,k) = s4var(i,k) + workgrd(i,j)/float(nlon) + end do + s4var(i,k) = max(tiny_r_kind,s4var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(so4c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + so4var(i,k) = so4var(i,k) + workgrd(i,j)/float(nlon) + end do + so4var(i,k) = max(tiny_r_kind,so4var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(oc1c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + oc1var(i,k) = oc1var(i,k) + workgrd(i,j)/float(nlon) + end do + oc1var(i,k) = max(tiny_r_kind,oc1var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(oc2c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + oc2var(i,k) = oc2var(i,k) + workgrd(i,j)/float(nlon) + end do + oc2var(i,k) = max(tiny_r_kind,oc2var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(bc1c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + bc1var(i,k) = bc1var(i,k) + workgrd(i,j)/float(nlon) + end do + bc1var(i,k) = max(tiny_r_kind,bc1var(i,k)) + end do + end if + end do + + do k=1,nsig + call mpi_gatherv(bc2c(1,1,k),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + bc2var(i,k) = bc2var(i,k) + workgrd(i,j)/float(nlon) + end do + bc2var(i,k) = max(tiny_r_kind,bc2var(i,k)) + end do + end if + end do + + if (mype==mype_work) then + call smoothlat(d1var,nsig,smoothdeg) + call smoothlat(d2var,nsig,smoothdeg) + call smoothlat(d3var,nsig,smoothdeg) + call smoothlat(d4var,nsig,smoothdeg) + call smoothlat(d5var,nsig,smoothdeg) + call smoothlat(s1var,nsig,smoothdeg) + call smoothlat(s2var,nsig,smoothdeg) + call smoothlat(s3var,nsig,smoothdeg) + call smoothlat(s4var,nsig,smoothdeg) + call smoothlat(so4var,nsig,smoothdeg) + call smoothlat(oc1var,nsig,smoothdeg) + call smoothlat(oc2var,nsig,smoothdeg) + call smoothlat(bc1var,nsig,smoothdeg) + call smoothlat(bc2var,nsig,smoothdeg) + end if + + call mpi_bcast(d1var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d2var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d3var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d4var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d5var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s1var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s2var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s3var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s4var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(so4var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(oc1var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(oc2var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(bc1var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(bc2var,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + + return +end subroutine variances_aerosol + + diff --git a/util/NMC_Bkerror/sorc_aero/vertsc_aerosol.f90 b/util/NMC_Bkerror/sorc_aero/vertsc_aerosol.f90 new file mode 100644 index 000000000..f18e1ae13 --- /dev/null +++ b/util/NMC_Bkerror/sorc_aero/vertsc_aerosol.f90 @@ -0,0 +1,628 @@ +subroutine vertsc_aerosol(numcases,mype) + use kinds, only: r_kind,r_single,i_kind,r_double + use postmod, only: smoothlat + use variables,only: nlat,nlon,nsig,lat1,lon1,zero,& + displs_g,ijn,db_prec,filunit1,filunit2,npe,& + d1vln,d2vln,d3vln,d4vln,d5vln,s1vln,s2vln,s3vln,s4vln, & + so4vln,oc1vln,oc2vln,bc1vln,bc2vln, & + iglobal,ltosi,ltosj,smoothdeg,one + implicit none + include 'mpif.h' + + integer,intent(in):: numcases,mype + + real(r_kind),dimension(lat1,lon1,nsig):: d1a,d2a,d3a,d4a,d5a, & + s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a + real(r_kind),dimension(lat1,lon1,nsig):: d1b,d2b,d3b,d4b,d5b, & + s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b + + real(r_kind),dimension(lat1,lon1,nsig,nsig):: d1d,d2d,d3d,d4d,d5d, & + s1d,s2d,s3d,s4d,so4d,oc1d,oc2d,bc1d,bc2d + + real(r_kind),dimension(iglobal):: work1 + real(r_double),dimension(nlat,nlon):: workgrd + real(r_kind),dimension(nlat,nsig*14):: vsc_out + real(r_kind) r_norm + + real(r_double),dimension(nlat,nsig,nsig):: d1vc,d2vc,d3vc,d4vc,d5vc, & + s1vc,s2vc,s3vc,s4vc,so4vc,oc1vc,oc2vc,bc1vc,bc2vc + real(r_double),dimension(nsig,14):: diag + real(r_double) small + + integer i,j,k,m,n,mpi_rtype,mm1,mype_work,ierror + integer kk,ni1,ni2 + + if (db_prec) then + mpi_rtype=mpi_real8 + else + mpi_rtype=mpi_real4 + end if + + mype_work=0 + mm1=mype+1 + r_norm=one/float(numcases) + + small=1.e-8_r_double + + + d1d=zero ; d2d=zero ; d3d=zero ; d4d=zero ; d5d=zero ; + s1d=zero ; s2d=zero ; s3d=zero ; s4d=zero ; so4d=zero ; + oc1d=zero ; oc2d=zero ; bc1d=zero ; bc2d=zero + + d1vc=0._r_double ; d2vc=0._r_double ; d3vc=0._r_double ; d4vc=0._r_double ; d5vc=0._r_double ; + s1vc=0._r_double ; s2vc=0._r_double ; s3vc=0._r_double ; s4vc=0._r_double ; so4vc=0._r_double ; + oc1vc=0._r_double ; oc2vc=0._r_double ; bc1vc=0._r_double ; bc2vc=0._r_double + + open(filunit1,form='unformatted',action='read') + rewind(filunit1) + open(filunit2,form='unformatted',action='read') + rewind(filunit2) + + do n=1,numcases + if (mype==0) write(6,*) 'VERTSC, PROCESSING PAIR # ',n +! Read in subdomain grids + read(filunit1) d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a + read(filunit2) d1b,d2b,d3b,d4b,d5b,s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b + + call delvars_aerosol(d1a,d2a,d3a,d4a,d5a,s1a,s2a,s3a,s4a,so4a,oc1a,oc2a,bc1a,bc2a, & + d1b,d2b,d3b,d4b,d5b,s1b,s2b,s3b,s4b,so4b,oc1b,oc2b,bc1b,bc2b,mype) + + do m=1,nsig + do k=1,nsig + do j=1,lon1 + do i=1,lat1 + d1d(i,j,k,m) = d1d(i,j,k,m) + d1a(i,j,k)*d1a(i,j,m) + d2d(i,j,k,m) = d2d(i,j,k,m) + d2a(i,j,k)*d2a(i,j,m) + d3d(i,j,k,m) = d3d(i,j,k,m) + d3a(i,j,k)*d3a(i,j,m) + d4d(i,j,k,m) = d4d(i,j,k,m) + d4a(i,j,k)*d4a(i,j,m) + d5d(i,j,k,m) = d5d(i,j,k,m) + d5a(i,j,k)*d5a(i,j,m) + s1d(i,j,k,m) = s1d(i,j,k,m) + s1a(i,j,k)*s1a(i,j,m) + s2d(i,j,k,m) = s2d(i,j,k,m) + s2a(i,j,k)*s2a(i,j,m) + s3d(i,j,k,m) = s3d(i,j,k,m) + s3a(i,j,k)*s3a(i,j,m) + s4d(i,j,k,m) = s4d(i,j,k,m) + s4a(i,j,k)*s4a(i,j,m) + so4d(i,j,k,m) = so4d(i,j,k,m) + so4a(i,j,k)*so4a(i,j,m) + oc1d(i,j,k,m) = oc1d(i,j,k,m) + oc1a(i,j,k)*oc1a(i,j,m) + oc2d(i,j,k,m) = oc2d(i,j,k,m) + oc2a(i,j,k)*oc2a(i,j,m) + bc1d(i,j,k,m) = bc1d(i,j,k,m) + bc1a(i,j,k)*bc1a(i,j,m) + bc2d(i,j,k,m) = bc2d(i,j,k,m) + bc2a(i,j,k)*bc2a(i,j,m) + end do + end do + end do + end do + end do ! end do numcases + close(filunit1) + close(filunit2) + + d1d=d1d*r_norm ; d2d=d2d*r_norm ; d3d=d3d*r_norm ; d4d=d4d*r_norm ; d5d=d5d*r_norm + s1d=s1d*r_norm ; s2d=s2d*r_norm ; s3d=s3d*r_norm ; s4d=s4d*r_norm ; so4d=so4d*r_norm + oc1d=oc1d*r_norm ; oc2d=oc2d*r_norm ; bc1d=bc1d*r_norm ; bc2d=bc2d*r_norm + +! Need to convert full subdomain corrleation matrices into arrays +! That contain zonal mean + do n=1,nsig + do k=1,nsig + call mpi_gatherv(d1d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d1vc(i,k,n) = d1vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at dust1' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(d2d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d2vc(i,k,n) = d2vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at dust2' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(d3d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d3vc(i,k,n) = d3vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at dust3' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(d4d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d4vc(i,k,n) = d4vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at dust4' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(d5d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + d5vc(i,k,n) = d5vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at dust5' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(s1d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s1vc(i,k,n) = s1vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at seas1' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(s2d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s2vc(i,k,n) = s2vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at seas2' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(s3d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s3vc(i,k,n) = s3vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at seas3' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(s4d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + s4vc(i,k,n) = s4vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at seas4' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(so4d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + so4vc(i,k,n) = so4vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at sulfate' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(oc1d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + oc1vc(i,k,n) = oc1vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at oc1' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(oc2d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + oc2vc(i,k,n) = oc2vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at oc2' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(bc1d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + bc1vc(i,k,n) = bc1vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at bc1' + + do n=1,nsig + do k=1,nsig + call mpi_gatherv(bc2d(1,1,k,n),ijn(mm1),mpi_rtype,& + work1,ijn,displs_g,mpi_rtype,& + mype_work,mpi_comm_world,ierror) + if (mype==mype_work) then + do kk=1,iglobal + ni1=ltosi(kk); ni2=ltosj(kk) + workgrd(ni1,ni2)=work1(kk) + end do + do i=1,nlat + do j=1,nlon + bc2vc(i,k,n) = bc2vc(i,k,n) + workgrd(i,j)/float(nlon) + end do + end do + end if + end do + end do + if (mype==mype_work) write(6,*) 'vertsc process at bc2' + + if (mype==mype_work) write(150,*) d1vc(:,:,1) + + if (mype==mype_work) then + do i=1,nlat + do k=1,nsig + diag(k, 1)=max(small,sqrt( d1vc(i,k,k))) + diag(k, 2)=max(small,sqrt( d2vc(i,k,k))) + diag(k, 3)=max(small,sqrt( d3vc(i,k,k))) + diag(k, 4)=max(small,sqrt( d4vc(i,k,k))) + diag(k, 5)=max(small,sqrt( d5vc(i,k,k))) + diag(k, 6)=max(small,sqrt( s1vc(i,k,k))) + diag(k, 7)=max(small,sqrt( s2vc(i,k,k))) + diag(k, 8)=max(small,sqrt( s3vc(i,k,k))) + diag(k, 9)=max(small,sqrt( s4vc(i,k,k))) + diag(k,10)=max(small,sqrt(so4vc(i,k,k))) + diag(k,11)=max(small,sqrt(oc1vc(i,k,k))) + diag(k,12)=max(small,sqrt(oc2vc(i,k,k))) + diag(k,13)=max(small,sqrt(bc1vc(i,k,k))) + diag(k,14)=max(small,sqrt(bc2vc(i,k,k))) + end do + do m=1,nsig + do k=1,nsig + d1vc(i,k,m)=d1vc(i,k,m)/(diag(k,1)*diag(m,1)) + d2vc(i,k,m)=d2vc(i,k,m)/(diag(k,2)*diag(m,2)) + d3vc(i,k,m)=d3vc(i,k,m)/(diag(k,3)*diag(m,3)) + d4vc(i,k,m)=d4vc(i,k,m)/(diag(k,4)*diag(m,4)) + d5vc(i,k,m)=d5vc(i,k,m)/(diag(k,5)*diag(m,5)) + s1vc(i,k,m)=s1vc(i,k,m)/(diag(k,6)*diag(m,6)) + s2vc(i,k,m)=s2vc(i,k,m)/(diag(k,7)*diag(m,7)) + s3vc(i,k,m)=s3vc(i,k,m)/(diag(k,8)*diag(m,8)) + s4vc(i,k,m)=s4vc(i,k,m)/(diag(k,9)*diag(m,9)) + so4vc(i,k,m)=so4vc(i,k,m)/(diag(k,10)*diag(m,10)) + oc1vc(i,k,m)=oc1vc(i,k,m)/(diag(k,11)*diag(m,11)) + oc2vc(i,k,m)=oc2vc(i,k,m)/(diag(k,12)*diag(m,12)) + bc1vc(i,k,m)=bc1vc(i,k,m)/(diag(k,13)*diag(m,13)) + bc2vc(i,k,m)=bc2vc(i,k,m)/(diag(k,14)*diag(m,14)) + end do + end do + end do !end do over lat + + write(151,*) d1vc(:,:,1) + + call smoothvsc(d1vc,d2vc,d3vc,d4vc,d5vc,s1vc,s2vc,s3vc,s4vc, & + so4vc,oc1vc,oc2vc,bc1vc,bc2vc,vsc_out) + + do k=1,nsig + do i=1,nlat + d1vln(i,k)=vsc_out(i,k) + d2vln(i,k)=vsc_out(i,nsig+k) + d3vln(i,k)=vsc_out(i,2*nsig+k) + d4vln(i,k)=vsc_out(i,3*nsig+k) + d5vln(i,k)=vsc_out(i,4*nsig+k) + s1vln(i,k)=vsc_out(i,5*nsig+k) + s2vln(i,k)=vsc_out(i,6*nsig+k) + s3vln(i,k)=vsc_out(i,7*nsig+k) + s4vln(i,k)=vsc_out(i,8*nsig+k) + so4vln(i,k)=vsc_out(i,9*nsig+k) + oc1vln(i,k)=vsc_out(i,10*nsig+k) + oc2vln(i,k)=vsc_out(i,11*nsig+k) + bc1vln(i,k)=vsc_out(i,12*nsig+k) + bc2vln(i,k)=vsc_out(i,13*nsig+k) + end do + end do + write(152,*) d1vln + +! set bounds on q vertical length scales +! do k=41,nsig +! do i=1,nlat +! qvln(i,k)=max(2.0_r_kind,qvln(i,k)) +! end do +! end do +! Make sure that vertical scales for cloud water are real values, else set to rh +! + do k=1,nsig + do i=1,nlat +! cvln(i,k)=max(min(10.0_r_kind,cvln(i,k)),0.1) + d1vln(i,k)=max(min(10.0_r_kind,d1vln(i,k)),0.1) + d2vln(i,k)=max(min(10.0_r_kind,d2vln(i,k)),0.1) + d3vln(i,k)=max(min(10.0_r_kind,d3vln(i,k)),0.1) + d4vln(i,k)=max(min(10.0_r_kind,d4vln(i,k)),0.1) + d5vln(i,k)=max(min(10.0_r_kind,d5vln(i,k)),0.1) + s1vln(i,k)=max(min(10.0_r_kind,s1vln(i,k)),0.1) + s2vln(i,k)=max(min(10.0_r_kind,s2vln(i,k)),0.1) + s3vln(i,k)=max(min(10.0_r_kind,s3vln(i,k)),0.1) + s4vln(i,k)=max(min(10.0_r_kind,s4vln(i,k)),0.1) + so4vln(i,k)=max(min(10.0_r_kind,so4vln(i,k)),0.1) + oc1vln(i,k)=max(min(10.0_r_kind,oc1vln(i,k)),0.1) + oc2vln(i,k)=max(min(10.0_r_kind,oc2vln(i,k)),0.1) + bc1vln(i,k)=max(min(10.0_r_kind,bc1vln(i,k)),0.1) + bc2vln(i,k)=max(min(10.0_r_kind,bc2vln(i,k)),0.1) + end do + end do + + call smoothlat(d1vln,nsig,smoothdeg) + call smoothlat(d2vln,nsig,smoothdeg) + call smoothlat(d3vln,nsig,smoothdeg) + call smoothlat(d4vln,nsig,smoothdeg) + call smoothlat(d5vln,nsig,smoothdeg) + call smoothlat(s1vln,nsig,smoothdeg) + call smoothlat(s2vln,nsig,smoothdeg) + call smoothlat(s3vln,nsig,smoothdeg) + call smoothlat(s4vln,nsig,smoothdeg) + call smoothlat(so4vln,nsig,smoothdeg) + call smoothlat(oc1vln,nsig,smoothdeg) + call smoothlat(oc2vln,nsig,smoothdeg) + call smoothlat(bc1vln,nsig,smoothdeg) + call smoothlat(bc2vln,nsig,smoothdeg) + + end if ! end if mype_work + + call mpi_bcast(d1vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d2vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d3vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d4vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(d5vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s1vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s2vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s3vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(s4vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(so4vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(oc1vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(oc2vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(bc1vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + call mpi_bcast(bc2vln,nlat*nsig,mpi_rtype,mype_work,mpi_comm_world,ierror) + + return +end subroutine vertsc_aerosol + +subroutine smoothvsc(d1vc,d2vc,d3vc,d4vc,d5vc,s1vc,s2vc,s3vc,s4vc, & + so4vc,oc1vc,oc2vc,bc1vc,bc2vc,vsc_out) + use kinds,only: r_kind,r_double + use postmod, only: ndeg,nasm ! ndeg=6, nasm=560 + use variables,only: nlat,nsig,one + implicit none + + real(r_double),dimension(nlat,nsig,nsig),intent(in):: d1vc,d2vc,d3vc,d4vc,d5vc, & + s1vc,s2vc,s3vc,s4vc,so4vc,oc1vc,oc2vc,bc1vc,bc2vc + real(r_kind),dimension(nlat,nsig*14),intent(out):: vsc_out + + + real(r_double),dimension(nsig,nasm):: table + real(r_double),dimension(nasm)::sum + real(r_kind) amin,scale + integer i,j,l,k,ll,kkkk + + real(r_kind),dimension(nsig,ndeg):: alv + real(r_kind),dimension(nsig):: be,rate,dssv,vwl + real(r_kind) samp,fact,ak,delta,awgt + real(r_kind) turn(ndeg,ndeg) + real(r_kind) w(nsig) + real(r_double) weights(nsig) + integer nav + + vwl=1.3_r_kind + call rfdpar1(be,rate,ndeg) + call rfdpar2(be,rate,turn,samp,ndeg) + + scale=.01 + nav=530 + vsc_out=0. + + do l=1,nsig + do i=1,nasm + vwl=scale*float(i) + w=0. + w(l)=1. + call rfdparv(vwl,rate,alv,nsig,ndeg) + do k=1,nsig + dssv(k)=sqrt(samp*vwl(k)) + enddo + + call smoothz(w,nsig,1,ndeg,alv,be,dssv,1) + call smoothz(w,nsig,1,ndeg,alv,be,dssv,2) + fact=1./w(l) + do k=1,nsig + table(k,i)=w(k)*fact + enddo + enddo + + awgt=10.0 + do k=1-l,nsig-l + weights(l+k)=exp(-(awgt*k*k)/(nsig*nsig)) + end do +!! print *,weights + + do ll=1,14 +! ll=1 z +! ll=2 d +! ll=3 t +! ll=4 q +! ll=5 oz +! ll=6 clw + do j=1,nlat + ak=0. + amin=999. + sum=0. + do i=1,nav + do k=1-l,nsig-l + if (ll.eq.1) then + sum(i)=sum(i)+weights(l+k)*(d1vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.2) then + sum(i)=sum(i)+weights(l+k)*(d2vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.3) then + sum(i)=sum(i)+weights(l+k)*(d3vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.4) then + sum(i)=sum(i)+weights(l+k)*(d4vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.5) then + sum(i)=sum(i)+weights(l+k)*(d5vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.6) then + sum(i)=sum(i)+weights(l+k)*(s1vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.7) then + sum(i)=sum(i)+weights(l+k)*(s2vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.8) then + sum(i)=sum(i)+weights(l+k)*(s3vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.9) then + sum(i)=sum(i)+weights(l+k)*(s4vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.10) then + sum(i)=sum(i)+weights(l+k)*(so4vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.11) then + sum(i)=sum(i)+weights(l+k)*(oc1vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.12) then + sum(i)=sum(i)+weights(l+k)*(oc2vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.13) then + sum(i)=sum(i)+weights(l+k)*(bc1vc(j,l,l+k)-table(l+k,i))**2. + else if (ll.eq.14) then + sum(i)=sum(i)+weights(l+k)*(bc2vc(j,l,l+k)-table(l+k,i))**2. + end if + enddo + if(sum(i) < amin)then + amin=sum(i) + kkkk=i + endif + enddo + i=kkkk + ak=float(i) + delta=0. + if(i > 1 .and. i < nav)delta=.5*(sum(i-1)-sum(i+1))/ & + (sum(i+1)+sum(i-1)-2.*sum(i)) + vsc_out(j,(ll-1)*nsig+l)=scale*(ak+delta) + enddo !enddo nlat + enddo !enddo ll + enddo ! end l -- nsig + + return +end subroutine smoothvsc + + diff --git a/util/NMC_Bkerror/util/combine_met_aero.f90 b/util/NMC_Bkerror/util/combine_met_aero.f90 new file mode 100644 index 000000000..54479c193 --- /dev/null +++ b/util/NMC_Bkerror/util/combine_met_aero.f90 @@ -0,0 +1,123 @@ +! combine_met_aero +! combine GSI Berror stats standard files +! with that from the aerosol NMC code +! because GSI needs certain fields to run properly +! cory.r.martin@noaa.gov - 2019/06/12 +! ifort combine_met_aero.f90 -o combine_met_aero.x -convert big_endian +! needs metfile.bin and aerfile.bin symbolically linked as input files + +program combine_met_aero + implicit none + character(11) :: metfile, aerfile, outfile + integer :: nsig, nlat, nlon + integer :: nsiga, nlata, nlona + integer :: i, nsigi + real, allocatable, dimension(:,:,:) :: stdev3, hscale3, vscale3 + real, allocatable, dimension(:,:,:) :: stdeva, hscalea, vscalea + real, allocatable, dimension(:,:,:) :: tcon + real, allocatable, dimension(:,:) :: stdevsst, hscalesst, rh + real, allocatable, dimension(:,:) :: pscon, vpcon + real, allocatable, dimension(:) :: stdevps, hscaleps + integer, parameter :: nvarsa=14 + integer, parameter :: nvars3=6 + integer, parameter :: nvars2=2 + character(5), dimension(nvars3+nvars2+nvarsa) :: var + + metfile = 'metfile.bin' + aerfile = 'aerfile.bin' + outfile = 'outfile.bin' + + print *, 'Combine B error stats from meteorology and aerosol species' + + ! open the files + open(unit=45, form='unformatted', status='old', file=metfile) + open(unit=46, form='unformatted', status='old', file=aerfile) + open(unit=47, form='unformatted', file=outfile) + + read(45) nsig, nlat, nlon + read(46) nsiga, nlata, nlona + + ! fail if the dimensions are different between the met and aer files + if (nsig /= nsiga .or. nlat /= nlata .or. nlon /= nlona) then + write(*,*) 'ERROR: input files have different dimensions!' + write(*,*) 'Filename: nsig, nlat, nlon' + write(*,*) 'metfile.bin:',nsig,nlat,nlon + write(*,*) 'aerfile.bin:',nsiga,nlata,nlona + write(*,*) 'Terminating program' + stop + end if + + ! allocate arrays + allocate(stdev3(nlat,nsig,nvars3),hscale3(nlat,nsig,nvars3),vscale3(nlat,nsig,nvars3)) + allocate(stdevsst(nlat,nlon),hscalesst(nlat,nlon)) + allocate(rh(nlat,nsig)) + allocate(stdevps(nlat),hscaleps(nlat)) + allocate(stdeva(nlat,nsig,nvarsa),hscalea(nlat,nsig,nvarsa),vscalea(nlat,nsig,nvarsa)) + allocate(tcon(nlat,nsig,nsig),pscon(nlat,nsig),vpcon(nlat,nsig)) + + ! read in met vars + write(*,*) 'Reading in met vars from metfile.bin' + read(45) tcon,vpcon,pscon + do i=1,nvars3 + read(45) var(i), nsigi + print *, var(i), nsigi + if (i==4) then + read(45) stdev3(:,:,i), rh + else + read(45) stdev3(:,:,i) + end if + read(45) hscale3(:,:,i) + read(45) vscale3(:,:,i) + end do + read(45) var(1+nvars3), nsigi + print *, var(1+nvars3), nsigi + read(45) stdevps + read(45) hscaleps + read(45) var(2+nvars3), nsigi + print *, var(2+nvars3), nsigi + read(45) stdevsst + read(45) hscalesst + ! read in aerosol vars + write(*,*) 'Reading in aero vars from aerfile.bin' + do i=1,nvarsa + read(46) var(i+nvars3+nvars2), nsigi + print *, var(i+nvars3+nvars2), nsigi + read(46) stdeva(:,:,i) + read(46) hscalea(:,:,i) + read(46) vscalea(:,:,i) + end do + ! write out concatenated file + write(*,*) 'Writing out to outfile.bin' + write(47) nsig, nlat, nlon + write(47) tcon, vpcon, pscon + do i=1,nvars3 + write(47) var(i), nsigi + print *, var(i), nsigi + if (i==4) then + write(47) stdev3(:,:,i), rh + else + write(47) stdev3(:,:,i) + print *, stdev3(:,:,i) + end if + write(47) hscale3(:,:,i) + write(47) vscale3(:,:,i) + end do + write(47) var(1+nvars3), 1 + print *, var(1+nvars3), 1 + write(47) stdevps + write(47) hscaleps + write(47) var(2+nvars3), 1 + print *, var(2+nvars3), 1 + write(47) stdevsst + write(47) hscalesst + do i=1,nvarsa + write(47) var(i+nvars3+nvars2), nsigi + print *, var(i+nvars3+nvars2), nsigi + print *, stdeva(:,:,i) + write(47) stdeva(:,:,i) + write(47) hscalea(:,:,i) + write(47) vscalea(:,:,i) + end do + write(*,*) 'Program Complete!' + +end program combine_met_aero diff --git a/util/Ozone_Monitor/CMakeLists.txt b/util/Ozone_Monitor/CMakeLists.txt new file mode 100644 index 000000000..b8f928a61 --- /dev/null +++ b/util/Ozone_Monitor/CMakeLists.txt @@ -0,0 +1,89 @@ +cmake_minimum_required(VERSION 2.6) +if(CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) + # I am top-level project. + if( NOT DEFINED ENV{CC} ) + find_path( crayComp "ftn" ) +# find_path( wcossIntel "mpfort" ) + find_path( intelComp "ifort" ) + find_path( pgiComp "pgf90" ) + if( crayComp ) + message("Setting CrayLinuxEnvironment") + set(CMAKE_SYSTEM_NAME "CrayLinuxEnvironment") + set(CMAKE_C_COMPILER "${crayComp}/cc") + set(CMAKE_CXX_COMPILER "${crayComp}/CC") + set(CMAKE_Fortran_COMPILER "${crayComp}/ftn") + endif() + if( intelComp ) + set(ENV{CC} "icc") + set(ENV{CXX} "icpc") + set(ENV{FC} "ifort") + endif() + if( wcossIntel ) + message("Setting env for wcoss intel") + set(ENV{CC} "mpcc") + set(ENV{CXX} "mpCC") +# set(ENV{FC} "mpfort") + endif() + if( pgiComp ) + set(ENV{CC} "pgcc") + set(ENV{CXX} "pgCC") + set(ENV{FC} "pgf90") + endif() + endif() + project(COV_Calc) + enable_language (Fortran) +# find_package(OpenMP) + set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/../../cmake/Modules/") + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setPlatformVariables.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setIntelFlags.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setGNUFlags.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setPGIFlags.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setHOST.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Cheyenne.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Discover.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Generic.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Gaea.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Jet.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/S4.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Hera.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/WCOSS-C.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/WCOSS-D.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/WCOSS.cmake) + if (NOT CMAKE_BUILD_TYPE) + set (CMAKE_BUILD_TYPE RELEASE CACHE STRING + "Choose the type of build, options are: PRODUCTION Debug Release." + FORCE) + endif (NOT CMAKE_BUILD_TYPE) + if (CMAKE_CXX_COMPILER_ID MATCHES "GNU*") + message("Setting GNU flags") + setGNU() + elseif(CMAKE_CXX_COMPILER_ID STREQUAL "Intel") + message("Setting Intel flags") + setIntel() + elseif(CMAKE_C_COMPILER MATCHES "pgc*") + message("Setting PGI flags") + setPGI() + endif() + setHOST() + find_package(MPI REQUIRED) + add_definitions(${MPI_Fortran_COMPILE_FLAGS}) + include_directories(${MPI_Fortran_INCLUDE_DIRS} ${MPI_INCLUDE_PATH} "./" ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}) + link_directories(${MPI_Fortran_LIBRARIES} ${ARCHIVE_OUTPUT_PATH} ) + find_package( NetCDF REQUIRED) + if(FIND_HDF5_HL) + find_package(HDF5 COMPONENTS C HL Fortran_HL ) + elseif(FIND_HDF5) + find_package(HDF5) + endif() + find_package( W3NCO ) + set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/libsrc/ncdiag") + set(BUILD_NCDIAG ON) + add_subdirectory(${PROJECT_SOURCE_DIR}/../../src/ncdiag ${PROJECT_BINARY_DIR}/libsrc/ncdiag) + set(NCDIAG_LIBRARIES ncdiag ) + set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) +endif() + +add_subdirectory(nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd) +add_subdirectory(nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd) +add_subdirectory(data_xtrct/sorc/make_base.fd) + diff --git a/util/Ozone_Monitor/OznMon_install.pl b/util/Ozone_Monitor/OznMon_install.pl index 1ae913a33..87b2ae65e 100755 --- a/util/Ozone_Monitor/OznMon_install.pl +++ b/util/Ozone_Monitor/OznMon_install.pl @@ -5,8 +5,8 @@ # # This script makes sets all necessary configuration definitions # and calls the makeall.sh script to build all the necessary -# executables. This script works for zeus, theia, and ibm -# machines. +# executables. This script works for hera, wcoss, cray, and +# wcoss_d machines. # #------------------------------------------------------------------- @@ -16,7 +16,7 @@ my $machine = `/usr/bin/perl get_hostname.pl`; my $my_machine="export MY_MACHINE=$machine"; - if( $machine ne "cray" && $machine ne "theia" && $machine ne "ibm" ) { + if( $machine ne "cray" && $machine ne "hera" && $machine ne "wcoss" && $machine ne "wcoss_d" ) { die( "ERROR --- Unrecognized machine hostname, $machine. Exiting now...\n" ); } else { @@ -24,7 +24,7 @@ } # - # surge, theia, and ibm are all little endian machines, and all run linux + # hera, wcoss, cray, wcoss_d are all little endian machines, and all run linux # my $little_endian = "export LITTLE_ENDIAN=\${LITTLE_ENDIAN:-0}"; my $my_os = "linux"; @@ -53,8 +53,11 @@ # TANKDIR location # my $user_name = $ENV{ 'USER' }; - if( $machine eq "theia" ){ - $tankdir = "/scratch4/NCEPDEV/da/save/$user_name/nbns"; + if( $machine eq "hera" ){ + $tankdir = "/scratch1/NCEPDEV/da/$user_name/nbns"; + } + elsif( $machine eq "wcoss_d" ){ + $tankdir = "/gpfs/dell2/emc/modeling/noscrub/$user_name/nbns"; } elsif( $machine eq "cray" ){ $tankdir = "/gpfs/hps/emc/da/noscrub/$user_name/nbns"; @@ -123,17 +126,19 @@ # # Web directory # -# my $webdir = "/home/people/emc/www/htdocs/gmb/gdas/radiance/${webuser}"; -# print "Please specify the top level web site directory $server.\n"; -# print " Return to accept default directory location or enter new location.\n"; -# print " \n"; -# print " Default directory on $server: $webdir\n"; -# print " ?\n"; -# my $new_webdir =<>; -# $new_webdir =~ s/^\s+|\s+$//g; -# if( length($new_webdir ) > 0 ) { -# $webdir = $new_webdir; -# } + my $webdir = "/home/people/emc/www/htdocs/gmb/gdas/es_ozn"; + + print "Please specify the top level web site directory $server.\n"; + print " Return to accept default directory location or enter new location.\n"; + print " \n"; + print " Default directory on $server: $webdir\n"; + print " ?\n"; + my $new_webdir =<>; + $new_webdir =~ s/^\s+|\s+$//g; + if( length($new_webdir ) > 0 ) { + $webdir = $new_webdir; + } + my $my_webdir="export WEBDIR=\${WEBDIR:-$webdir}"; print "my_webdir = $my_webdir\n"; print "\n\n"; @@ -146,7 +151,7 @@ my $my_ptmp; my $my_stmp; - if( $machine eq "ibm" ) { + if( $machine eq "wcoss" ) { $ptmp = "/ptmpd1"; print "Please specify PTMP location. This is used for temporary work space.\n"; print " Available options are: \n"; @@ -196,13 +201,54 @@ sleep( 1 ); } + elsif( $machine eq "wcoss_d" ) { + $my_ptmp="export OZN_PTMP=\${OZN_PTMP:-/gpfs/dell2/ptmp}"; + $my_stmp="export OZN_STMP=\${OZN_STMP:-/gpfs/dell2/stmp}"; + } elsif( $machine eq "cray" ) { $my_ptmp="export OZN_PTMP=\${OZN_PTMP:-/gpfs/hps2/ptmp}"; $my_stmp="export OZN_STMP=\${OZN_STMP:-/gpfs/hps2/stmp}"; } - elsif( $machine eq "theia" ){ - $my_ptmp="export OZN_PTMP=\${OZN_PTMP:-/scratch4/NCEPDEV/stmp4}"; - $my_stmp="export OZN_STMP=\${OZN_STMP:-/scratch4/NCEPDEV/stmp3}"; + elsif( $machine eq "hera" ){ + $ptmp = "/scratch2/NCEPDEV/stmp3"; + + print "Please specify PTMP location. This is used for temporary work space.\n"; + print "\n"; + print " Return to accept default location or enter new location now.\n"; + print "\n"; + print " Default PTMP: $ptmp \n"; + print " ?\n"; + my $new_ptmp = <>; + $new_ptmp =~ s/^\s+|\s+$//g; + + if( length($new_ptmp ) > 0 ) { + $ptmp = $new_ptmp; + } + $my_ptmp="export OZN_PTMP=\${OZN_PTMP:-$ptmp}"; + print "my_ptmp = $my_ptmp\n"; + print "\n\n"; + sleep( 1 ); + + + $stmp = "/scratch2/NCEPDEV/stmp1"; + + print "Please specify STMP location. This is used for temporary work space.\n"; + print "\n"; + print " Return to accept default location or enter new location now.\n"; + print "\n"; + print " Default STMP: $stmp \n"; + print " ?\n"; + my $new_stmp = <>; + $new_stmp =~ s/^\s+|\s+$//g; + + if( length($new_stmp ) > 0 ) { + $stmp = $new_stmp; + } + $my_stmp="export OZN_STMP=\${OZN_STMP:-$stmp}"; + print "my_stmp = $my_stmp\n"; + print "\n\n"; + sleep( 1 ); + } print "my_ptmp = $my_ptmp\n"; @@ -248,6 +294,30 @@ close $in; move "$oznmon_config.new", $oznmon_config; + sleep( 1 ); + + print "\n\n"; + + my $rpt = 0; + print " The DO_DATA_RPT flag is used to set the validation and notification process\n"; + print " to off/on. The default is off.\n"; + print " Return to accept default setting of 0 (off) or enter 1 to turn it on.\n"; + print "\n"; + print " Default DO_DATA_RPT $rpt \n"; + print " ?\n"; + + my $new_rpt = <>; + $new_rpt =~ s/^\s+|\s+$//g; + + if( length($new_rpt ) > 0 ) { + if( $new_rpt =~ '1' ) { + $rpt = 1; + } + } + my $my_rpt="export DO_DATA_RPT=\${DO_DATA_RPT:-$rpt}"; + print "my_rpt = $my_rpt\n"; + print "\n\n"; + sleep( 1 ); # # Update the default account settings in the OznMon_user_settings script. @@ -256,19 +326,19 @@ print "Updating parm/OznMon_user_settings\n"; my $account = "export ACCOUNT=\${ACCOUNT:-fv3-cpu}"; - if( $machine ne "zeus" && $machine ne "theia" ) { + if( $machine ne "theia" && $machine ne "hera" ) { $account = "export ACCOUNT=\${ACCOUNT:-}"; } - my $project = "export PROJECT=\${PROJECT:-GDAS-T2O}"; - if( $machine ne "ibm" && $machine ne "cray" ) { + my $project = "export PROJECT=\${PROJECT:-GFS-DEV}"; + if( $machine ne "wcoss" && $machine ne "cray" && $machine ne "wcoss_d" ) { $project="export PROJECT="; } my $job_queue="export JOB_QUEUE="; if( $machine eq "cray" ) { $job_queue="export JOB_QUEUE=\${JOB_QUEUE:-dev}"; - } elsif( $machine eq "ibm" ){ + } elsif( $machine eq "wcoss" || $machine eq "wcoss_d" ){ $job_queue = "export JOB_QUEUE=\${JOB_QUEUE:-dev_shared}"; } @@ -296,6 +366,9 @@ elsif( $line =~ m/export HPSS_DIR/ ){ $line = $hpss_dir; } + elsif( $line =~ m/export DO_DATA_RPT/ ){ + $line = $my_rpt; + } print OUT "$line\n"; } close OUT; @@ -303,12 +376,11 @@ move $outfile, $infile; - print "\n"; print "Making all executables\n"; - `./makeall.sh clean`; - `./makeall.sh`; + `./build_OznMon_cmake.sh`; + exit 0; diff --git a/util/Ozone_Monitor/build_OznMon_cmake.sh b/util/Ozone_Monitor/build_OznMon_cmake.sh new file mode 100755 index 000000000..7f7265287 --- /dev/null +++ b/util/Ozone_Monitor/build_OznMon_cmake.sh @@ -0,0 +1,125 @@ +#! /bin/bash + +#------------------------------------------------------------------ +# build_OznMon_cmake.sh +# +# This script builds all of the executables in the +# nwprod/oznmon_shared/exec and data_xtrct/exec subdirectories. +# +# The operational OznMon executables (in nwprod/oznmon_shared/exec) +# may also be built as part of the whole GSI package. To do this +# ensure BUILD_UTIL=ON when running cmake or use the +# ProdGSI/ush/build_all_cmake.sh script. +#------------------------------------------------------------------ +set -ax + +mode=${1:-} +top_level=${PWD} +echo "top_level = ${top_level}" + +#module purge + +if [[ -d /dcom && -d /hwrf ]] ; then + . /usrx/local/Modules/3.2.10/init/sh + target=wcoss + . $MODULESHOME/init/sh +elif [[ -d /cm ]] ; then +# MODULESHOME=/opt/modules/3.2.10.3 + . $MODULESHOME/init/sh + target=wcoss_c +elif [[ -d /ioddev_dell ]]; then + . $MODULESHOME/init/sh + target=wcoss_d +elif [[ -d /scratch1 ]] ; then + . /apps/lmod/lmod/init/sh + target=hera +else + echo "unknown target = $target" + exit 9 +fi + +GSI_Pkg=${top_level}/../.. +echo "GSI_Pkg = ${GSI_Pkg}" + +#machine=`./get_hostname.pl` +echo "target = $target" + +dir_modules=${GSI_Pkg}/modulefiles +if [ ! -d $dir_modules ]; then + echo "modulefiles does not exist in $dir_modules" + exit 10 +fi + + +#--------------------------------------------------- +# Verify this is a supported machine +#--------------------------------------------------- + +if [[ ${target} = "hera" || ${target} = "wcoss" \ + || ${target} = "wcoss_c" || ${target} = "wcoss_d" ]]; then + echo Building nwprod executables on ${target} + echo + + + #------------------------------------- + # load modules + #------------------------------------- + if [ $target = wcoss_d ]; then + module purge + module use -a $dir_modules + module load modulefile.ProdGSI.$target + elif [ $target = wcoss -o $target = gaea ]; then + module purge + module load $dir_modules/modulefile.ProdGSI.$target + elif [ $target = hera -o $target = cheyenne ]; then + module purge + source $dir_modules/modulefile.ProdGSI.$target + elif [ $target = wcoss_c ]; then + module purge + module use -a $dir_modules + module load $dir_modules/modulefile.ProdGSI.$target + fi + + + #------------------------------------- + # use cmake to build the executables + #------------------------------------- + if [[ -d ./build ]]; then + rm -rf ./build + fi + mkdir build + cd ./build + + cmake .. + make -j8 + + cd bin + + #------------------------------ + # source OznMon_config + #------------------------------ + . ${top_level}/parm/OznMon.ver + . ${top_level}/parm/OznMon_config + + #------------------------------------------------------- + # move the executables to the correct exec directories + #------------------------------------------------------- + + file_list1="oznmon_horiz.x oznmon_time.x" + for file in $file_list1; do + cp $file $HOMEoznmon/exec/. + done + + file_list_de="oznmon_make_base.x" + for file in $file_list_de; do + cp $file $OZN_DE_EXEC/. + done + +else + echo ${machine} is not supported +fi + + +set +x + +exit diff --git a/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/CMakeLists.txt b/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/CMakeLists.txt new file mode 100644 index 000000000..68e1da7c6 --- /dev/null +++ b/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/CMakeLists.txt @@ -0,0 +1,14 @@ +cmake_minimum_required(VERSION 2.6) + file(GLOB OZNMON_MAKE_BASE_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90 ) + set(OZNMON_MAKE_BASE_Fortran_FLAGS "-fp-model strict -assume byterecl -convert big_endian -O3 ") + set_source_files_properties( ${OZNMON_MAKE_BASE_SRC} PROPERTIES COMPILE_FLAGS ${OZNMON_MAKE_BASE_Fortran_FLAGS} ) + set(Util_MODULE_DIR ${PROJECT_BINARY_DIR}/include/oznmon_make_base ) + add_executable(oznmon_make_base.x ${OZNMON_MAKE_BASE_SRC} ) + set_target_properties( oznmon_make_base.x PROPERTIES COMPILE_FLAGS ${OZNMON_MAKE_BASE_Fortran_FLAGS} ) + set_target_properties( oznmon_make_base.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) + include_directories( ${CORE_INCS} ) + target_link_libraries( oznmon_make_base.x ${W3NCO_4_LIBRARY} ) + if(BUILD_W3NCO) + add_dependencies( oznmon_make_base.x ${W3NCO_4_LIBRARY} ) + endif() + diff --git a/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/make_base.f90 b/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/make_base.f90 index 741c29540..49efdafe2 100755 --- a/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/make_base.f90 +++ b/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/make_base.f90 @@ -83,7 +83,9 @@ program oznmon_make_base max_penalty(j,k) = rmiss end do end do - + + file_ctr=0 + do j=1,nlev iuse(j) = -1 end do @@ -141,7 +143,7 @@ program oznmon_make_base ! loop over the data files, ! read count and penalty values for each channel/region ! - counter = 0 + counter = 1 read_ctr = 0 ierror = 0 do while( ierror == 0 .AND. counter <= nfile ) @@ -172,17 +174,18 @@ program oznmon_make_base ! ! accumulate sums and min/max values ! - do ii=1,nfile - do k=1,nregion - do j=1,nlev - if( (count(j,k,ii) > 0.0) .AND. (iuse(j) > 0) ) then - temp = penalty(j,k,ii)/count(j,k,ii) - penalty(j,k,ii) = temp -! write(6,*)'penalty(j,k,ii),count(j,k,ii)',j,k,ii,penalty(j,k,ii), count(j,k,ii) - end if - end do - end do - end do + +! do ii=1,nfile +! do k=1,nregion +! do j=1,nlev +! if( (count(j,k,ii) > 0.0) .AND. (iuse(j) > 0) ) then +! temp = penalty(j,k,ii)/count(j,k,ii) +! penalty(j,k,ii) = temp +!! write(6,*)'penalty(j,k,ii),count(j,k,ii)',j,k,ii,penalty(j,k,ii), count(j,k,ii) +! end if +! end do +! end do +! end do write(6,*) ' number of files read = ', read_ctr do ii=1,nfile @@ -192,6 +195,7 @@ program oznmon_make_base total_count(j,k) = total_count(j,k) + count(j,k,ii) total_penalty(j,k) = total_penalty(j,k) + penalty(j,k,ii) file_ctr(j,k) = file_ctr(j,k) + 1 + write(6,*) 'file_ctr(j,k),filenum = ', j, k, file_ctr(j,k),ii if( min_count(j,k) == rmiss ) then min_count(j,k) = count( j,k,ii ) @@ -261,7 +265,7 @@ program oznmon_make_base write(6,*) 'writing output to ', out_file open(lunout,file=out_file,form='formatted') write(lunout,*) satname, nlev, nregion - write(lunout,*) 'fields: region, level, avg_count, sdv_count, min_count, max_count, avg_pen, sdv_pen, min_pen, max_pen' + write(lunout,*) 'fields: level, region, avg_count, sdv_count, min_count, max_count, avg_pen, sdv_pen, min_pen, max_pen' do k=1,nregion do j=1,nlev diff --git a/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/makefile b/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/makefile index d62d3c495..292875a04 100755 --- a/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/makefile +++ b/util/Ozone_Monitor/data_xtrct/sorc/make_base.fd/makefile @@ -9,7 +9,7 @@ # to use the automated validation mechanism. # ***************************************************************** -BINDIR = ../../exec +BINDIR = $(dir_root)/exec LIBS = $(W3NCO_LIB4) diff --git a/util/Ozone_Monitor/data_xtrct/ush/OznMon_DE.sh b/util/Ozone_Monitor/data_xtrct/ush/OznMon_DE.sh index 028f4e291..268e347d5 100755 --- a/util/Ozone_Monitor/data_xtrct/ush/OznMon_DE.sh +++ b/util/Ozone_Monitor/data_xtrct/ush/OznMon_DE.sh @@ -6,9 +6,9 @@ function usage { echo "Usage: OznMon_DE.sh suffix [pdate]" echo " Suffix is the indentifier for this data source." - echo " -p | -pdate yyyymmddcc to specify the cycle to be plotted" - echo " if unspecified the last available date will be plotted" - echo " -r | -run the gdas|gfs run to be plotted" + echo " -p | -pdate yyyymmddcc to specify the cycle to be processed" + echo " if unspecified the last available date will be processed" + echo " -r | -run the gdas|gfs run to be processed" echo " use only if data in TANKdir stores both runs" echo " " } @@ -16,6 +16,8 @@ function usage { #-------------------------------------------------------------------- # OznMon_DE.sh begins here #-------------------------------------------------------------------- +set -ax + nargs=$# if [[ $nargs -lt 1 || $nargs -gt 5 ]]; then usage @@ -55,7 +57,7 @@ echo "OZNMON_SUFFIX = $OZNMON_SUFFIX" echo "RUN = $RUN" echo "PDATE = $PDATE" -top_parm=${this_dir}/../parm +top_parm=${this_dir}/../../parm oznmon_version_file=${oznmon_version:-${top_parm}/OznMon.ver} if [[ -s ${oznmon_version_file} ]]; then @@ -86,10 +88,15 @@ else fi #------------------------------------------- -# J-Job needs this OZN_TANKDIR assignment +# J-Job needs these assignments to override +# operational defaults. # export OZN_TANKDIR=$OZN_STATS_TANKDIR +export DATAROOT=${STMP_USER} +if [[ -e ${OZN_TANKDIR}/info/gdas_oznmon_satype.txt ]]; then + export satype_file=${satype_file:-${OZN_TANKDIR}/info/gdas_oznmon_satype.txt} +fi #-------------------------------------------------------------- # Determine next cycle @@ -133,7 +140,7 @@ fi #------------------------------------------------------------- # define job, jobid for submitted job # -export job=${job:-ozmon_de_${OZNMON_SUFFIX}} +export job=${job:-oznmon_de_${OZNMON_SUFFIX}} export jobid=${jobid:-${job}.${cyc}.${pid}} #------------------------------------------------------------- @@ -143,8 +150,8 @@ export jobid=${jobid:-${job}.${cyc}.${pid}} export COMROOT=${PTMP_USER} #------------------------------------------------------------- -# This is default for ibm/cray machines. Need to reset -# COM_IN in parm files for theia. +# This is default for wcoss/cray machines. Need to reset +# COM_IN in parm files for hera. # export COM_IN=${COM_IN:-/gpfs/hps/nco/ops/com/gfs/prod} @@ -186,7 +193,7 @@ echo "jobfile = $jobfile" #--------------------------------------------------------------- # expand OZN_WORK_DIR to make unique for this cycle time # -export OZN_WORK_DIR=${OZN_WORK_DIR}.DE.${PDY}.${cyc} +export OZN_WORK_DIR=${OZN_WORK_DIR}/DE.${PDY}.${cyc} if [[ -e $OZN_WORK_DIR ]]; then rm -rf ${OZN_WORK_DIR} fi @@ -197,25 +204,32 @@ echo "jobfile = $jobfile" echo "out: $OZN_LOGdir/DE.$PDY.$cyc.log" echo "err: $OZN_LOGdir/DE.$PDY.$cyc.err" -if [[ $MY_MACHINE = "theia" ]]; then - - $SUB -A ${ACCOUNT} -l procs=1,walltime=0:05:00 -N ${job} -V \ +if [[ $MY_MACHINE = "hera" ]]; then + $SUB --account=${ACCOUNT} --time=05 -J ${job} -D . \ -o ${OZN_LOGdir}/DE.${PDY}.${cyc}.log \ - -e ${OZN_LOGdir}/DE.${PDY}.${cyc}.err ${jobfile} - -elif [[ $MY_MACHINE = "ibm" ]]; then + --ntasks=1 --mem=5g \ + ${jobfile} + +elif [[ $MY_MACHINE = "wcoss" ]]; then $SUB -q $JOB_QUEUE -P $PROJECT -M 50 -R affinity[core] \ -o ${OZN_LOGdir}/DE.${PDY}.${cyc}.log \ -e ${OZN_LOGdir}/DE.${PDY}.${cyc}.err \ -W 0:05 -J ${job} -cwd ${PWD} $jobfile +elif [[ $MY_MACHINE = "wcoss_d" ]]; then + + $SUB -q $JOB_QUEUE -P $PROJECT -M 400 -R affinity[core] \ + -o ${OZN_LOGdir}/DE.${PDY}.${cyc}.log \ + -e ${OZN_LOGdir}/DE.${PDY}.${cyc}.err \ + -W 0:05 -J ${job} -cwd ${PWD} $jobfile + elif [[ $MY_MACHINE = "cray" ]]; then $SUB -q $JOB_QUEUE -P $PROJECT -o ${OZN_LOGdir}/DE.${PDY}.${cyc}.log \ - -e ${OZN_LOGdir}/DE.${PDY}.${cyc}.err \ - -R "select[mem>100] rusage[mem=100]" \ - -M 100 -W 0:05 -J ${job} -cwd ${PWD} $jobfile + -e ${OZN_LOGdir}/DE.${PDY}.${cyc}.err \ + -R "select[mem>100] rusage[mem=100]" \ + -M 100 -W 0:05 -J ${job} -cwd ${PWD} $jobfile fi diff --git a/util/Ozone_Monitor/data_xtrct/ush/OznMon_MkBase.sh b/util/Ozone_Monitor/data_xtrct/ush/OznMon_MkBase.sh index fbfcc7f63..d8dd20ba2 100755 --- a/util/Ozone_Monitor/data_xtrct/ush/OznMon_MkBase.sh +++ b/util/Ozone_Monitor/data_xtrct/ush/OznMon_MkBase.sh @@ -20,18 +20,20 @@ function usage { echo "Usage: OznMon_MkBase.sh [-s|--sat sat_name] suffix " echo " Suffix is data source identifier that matches data in " echo " the TANKverf/stats directory." - echo " Sat (optional) restricts the list of satellite sources." - echo " No sat means all satellite sources will be included." + echo " -s|--sat (optional) restricts the list of sat/instrument " + echo " sources. If no sat is specified then all " + echo " sat/instrument sources will be included." + echo " -r|--run indicates RUN value, usually gfs|gdas" } nargs=$# -if [[ $nargs -lt 1 || $nargs -gt 4 ]]; then +if [[ $nargs -lt 1 || $nargs -gt 5 ]]; then usage exit 1 fi SINGLE_SAT=0 -run=gdas +RUN=gdas #----------------------------------------------- # Process command line arguments @@ -43,7 +45,7 @@ do case $key in -r|--run) - run="$2" + RUN="$2" shift # past argument ;; -s|--sat) @@ -77,50 +79,44 @@ export GLB_AREA=${GLB_AREA:-1} #------------------------------------------------------------------- top_parm=${this_dir}/../../parm -export OZNMON_VERSION=${OZNMON_VERSION:-${top_parm}/OznMon.ver} -if [[ -s ${OZNMON_VERSION} ]]; then - . ${OZNMON_VERSION} +oznmon_version=${oznmon_version:-${top_parm}/OznMon.ver} +if [[ -s ${oznmon_version} ]]; then + . ${oznmon_version} else - echo "Unable to source ${OZNMON_VERSION} file" + echo "Unable to source ${oznmon_version} file" exit 2 fi -export OZNMON_USER_SETTINGS=${OZNMON_USER_SETTINGS:-${top_parm}/OznMon_user_settings} -if [[ -s ${OZNMON_USER_SETTINGS} ]]; then - . ${OZNMON_USER_SETTINGS} +oznmon_user_settings=${oznmon_user_settings:-${top_parm}/OznMon_user_settings} +if [[ -s ${oznmon_user_settings} ]]; then + . ${oznmon_user_settings} else - echo "Unable to source ${OZNMON_USER_SETTINGS} file" + echo "Unable to source ${oznmon_user_settings} file" exit 3 fi -export OZNMON_CONFIG=${OZNMON_CONFIG:-${top_parm}/OznMon_config} -if [[ -s ${OZNMON_CONFIG} ]]; then - . ${OZNMON_CONFIG} + +oznmon_config=${oznmon_config:-${top_parm}/OznMon_config} +if [[ -s ${oznmon_config} ]]; then + . ${oznmon_config} else - echo "Unable to source ${OZNMON_CONFIG} file" + echo "Unable to source ${oznmon_config} file" exit 4 fi -#. ${DE_PARM}/data_extract_config -# -# -# -#REGIONAL_RR=${REGIONAL_RR:-0} -#echo "REGIONAL_RR = $REGIONAL_RR" -#echo "CYCLE_INTERVAL = $CYCLE_INTERVAL" - #------------------------------------------------------------------- # Set dates # BDATE is beginning date for the 30/60 day range # EDATE is ending date for 30/60 day range (always use 00 cycle) #------------------------------------------------------------------- -EDATE=`${OZN_DE_SCRIPTS}/find_cycle.pl --cyc 1 --run ${run} --dir ${OZN_STATS_TANKDIR}` +EDATE=`${OZN_DE_SCRIPTS}/find_cycle.pl --cyc 1 --run ${RUN} --dir ${OZN_STATS_TANKDIR}` echo $EDATE sdate=`echo $EDATE|cut -c1-8` EDATE=${sdate}00 -BDATE=`$NDATE -1080 $EDATE` +BDATE=`$NDATE -1080 $EDATE` # 45 days +#BDATE=`$NDATE -240 $EDATE` # 10 days echo EDATE = $EDATE echo BDATE = $BDATE @@ -140,8 +136,9 @@ if [[ $SINGLE_SAT -eq 0 ]]; then SATYPE=`cat ${HOMEgdas_ozn}/fix/gdas_oznmon_satype.txt` else PDY=`echo $EDATE|cut -c1-8` + cyc=`echo $EDATE|cut -c9-10` - test_dir=${OZN_STATS_TANKDIR}/${run}.${PDY}/oznmon/time + test_dir=${OZN_STATS_TANKDIR}/${RUN}.${PDY}/${cyc}/oznmon/time if [[ -d ${test_dir} ]]; then test_list=`ls ${test_dir}/*.${EDATE}.ieee_d*` @@ -184,14 +181,14 @@ for type in ${SATYPE}; do #------------------------------------------------------------------- # Create the cycle_hrs.txt file #------------------------------------------------------------------- - cdate=$BDATE - nfiles=0 - while [[ $cdate -le $EDATE ]]; do - echo $cdate >> cycle_hrs.txt - adate=`$NDATE +${CYCLE_INTERVAL} $cdate` - cdate=$adate - nfiles=`expr $nfiles + 1` - done +# cdate=$BDATE +# nfiles=0 +# while [[ $cdate -le $EDATE ]]; do +# echo $cdate >> cycle_hrs.txt +# adate=`$NDATE +${CYCLE_INTERVAL} $cdate` +# cdate=$adate +# nfiles=`expr $nfiles + 1` +# done #------------------------------------------------------------------- @@ -199,37 +196,26 @@ for type in ${SATYPE}; do #------------------------------------------------------------------- have_ctl=0 cdate=$BDATE + while [[ $cdate -le $EDATE ]]; do -# if [[ $REGIONAL_RR -eq 1 ]]; then -# tdate=`$NDATE +6 $cdate` -# day=`echo $tdate | cut -c1-8 ` -# hh=`echo $cdate | cut -c9-10` -# . ${IG_SCRIPTS}/rr_set_tz.sh $hh -# else -# day=`echo $cdate | cut -c1-8 ` -# fi pdy=`echo $cdate | cut -c1-8 ` + cyc=`echo $cdate | cut -c9-10` + + test_dir=${OZN_STATS_TANKDIR}/${RUN}.${pdy}/${cyc}/oznmon/time - test_dir=${OZN_STATS_TANKDIR}/${run}.${pdy}/oznmon/time if [[ -d ${test_dir} ]]; then test_file=${test_dir}/${type}.${cdate}.ieee_d - fi -# elif [[ -d ${TANKverf}/radmon.${day} ]]; then -# if [[ $REGIONAL_RR -eq 1 ]]; then -# test_file=${TANKverf}/radmon.${day}/${rgnHH}.time.${type}.${cdate}.ieee_d.${rgnTM} -# else -# test_file=${TANKverf}/radmon.${day}/time.${type}.${cdate}.ieee_d -# fi -# fi -# - if [[ -s $test_file ]]; then - $NCP ${test_file} ./${type}.${cdate}.ieee_d - elif [[ -s ${test_file}.${Z} ]]; then - $NCP ${test_file}.${Z} ./${type}.${cdate}.ieee_d.${Z} - else - echo "WARNING: unable to loate ${test_file}" + if [[ -s $test_file ]]; then + $NCP ${test_file} ./${type}.${cdate}.ieee_d + echo $cdate >> cycle_hrs.txt + elif [[ -s ${test_file}.${Z} ]]; then + $NCP ${test_file}.${Z} ./${type}.${cdate}.ieee_d.${Z} + echo $cdate >> cycle_hrs.txt + else + echo "WARNING: unable to locate ${test_file}" + fi fi @@ -247,19 +233,6 @@ for type in ${SATYPE}; do cdate=$adate done -# test_file=${test_dir}${MONITOR}/time.${type}.ctl -# else -# test_file=${TANKverf}/radmon.${day}/time.${type}.ctl -# fi -# -# if [[ -s ${test_file} ]]; then -# $NCP ${test_file} ${type}.ctl -# elif [[ -s ${test_file}.${Z} ]]; then -# $NCP ${test_file}.${Z} ${type}.ctl.${Z} -# else -# $NCP $TANKverf/time/${type}.ctl* ./ -# fi -# ${UNCOMPRESS} *.${Z} #------------------------------------------------------------------- @@ -281,6 +254,8 @@ for type in ${SATYPE}; do out_file=${type}.base $NCP ${OZN_DE_EXEC}/oznmon_make_base.x ./ + nfiles=`ls -1 ${type}*ieee_d | wc -l` + cat << EOF > input &INPUT satname='${type}', @@ -315,7 +290,6 @@ if [[ ! -d ${OZN_STATS_TANKDIR}/info ]]; then mkdir -p ${OZN_STATS_TANKDIR}/info fi -#cd $tmpdir basefile=gdas_oznmon_base.tar if [[ $SINGLE_SAT -eq 0 ]]; then @@ -326,7 +300,9 @@ else mkdir $newbase cd $newbase + #--------------------------------------- # copy over existing $basefile + # if [[ -s ${OZN_STATS_TANKDIR}/info/${basefile} ]]; then $NCP ${OZN_STATS_TANKDIR}/info/${basefile} ./${basefile} elif [[ -s ${HOMEgdas_ozn}/fix/${basefile} ]]; then @@ -336,17 +312,19 @@ else tar -xvf ${basefile} rm ${basefile} + #---------------------------------------------------------------------- # copy new *.base file from $tmpdir and build new $basefile (tar file) + # cp -f $tmpdir/*.base . tar -cvf ${basefile} *.base mv -f ${basefile} $tmpdir/. cd $tmpdir -# keep for testing -# rm -rf $newbase fi +#--------------------------------------------- # Remove the old version of the $basefile +# if [[ -e ${OZN_STATS_TANKDIR}/info/${basefile} || -e ${OZN_STATS_TANKDIR}/info/${basefile}.${Z} ]]; then rm -f ${OZN_STATS_TANKDIR}/info/${basefile}* fi @@ -357,7 +335,7 @@ $NCP ${basefile} ${OZN_STATS_TANKDIR}/info/. #------------------------------------------------------------------- # Clean up $tmpdir #------------------------------------------------------------------- -#cd .. +cd .. #rm -rf $tmpdir exit diff --git a/util/Ozone_Monitor/data_xtrct/ush/find_cycle.pl b/util/Ozone_Monitor/data_xtrct/ush/find_cycle.pl index 0a2cbced7..165e4cca6 100755 --- a/util/Ozone_Monitor/data_xtrct/ush/find_cycle.pl +++ b/util/Ozone_Monitor/data_xtrct/ush/find_cycle.pl @@ -9,8 +9,8 @@ # 1 = last cycle (default) # 2 = 2nd to last cycle # 0 = first cycle -# --run : Optional run name, generally 'gdas' or 'gfs'. -# This should be used if $OZN_USE_RUN is set to 1. +# --run : Run name, generally 'gdas' or 'gfs'. +# If not specified 'gdas' will be used. # # Return that first/last cycle as a text string in YYYYMMDDHH format, # or return nothing if none of the expected data files are found. @@ -48,7 +48,7 @@ ##------------------------------------------------------------------ ##------------------------------------------------------------------ - my $run = ''; + my $run = 'gdas'; my $dir = ''; my $lcm = 'oznmon'; my $cyc = '1'; @@ -72,22 +72,16 @@ } closedir DIR; - my $run_len = length($run); - my $search_string; - my $use_run; if( length($run) == 0 ){ $search_string = $lcm; - $use_run = 0; } else { $search_string = $run; - $use_run = 1; } my @mmdirs = grep { /$search_string/ } @alldirs; - #----------------------------------------------------------------------- # If there are no $run.yyyymmdd subdirectories, then exit without # returning any date string. @@ -121,11 +115,12 @@ # Start with the latest directory and attempt to locate monitor # subdirectories. # + + my @hrs = qw( 00 06 12 18 ); + do { - $ctr = $ctr + $incr; - - + # In each subdirectory attempt to locate all *ieee_d files # and parse out all unique date values. The latest is the answer # we're looking for. @@ -134,56 +129,59 @@ # my $newdir; - if( $use_run == 1 ){ - $newdir = "${dirpath}/${sortmm[$ctr]}/oznmon/time"; - } else { - $newdir = "${dirpath}/${sortmm[$ctr]}/time"; - $newdir = "${dirpath}/${sortmm[$ctr]}"; - } - - if( -d $newdir ) { - opendir DIR, $newdir or die "Cannot open the current directory: $!"; - - my @timefiles = grep { /ieee_d/ } readdir DIR; - - if( $#timefiles >= 0 ) { - my @sorttime = sort( @timefiles ); - my @times; - my $idx = 0; - - # Find the first string of 10 digits; that's the date. Use that - # $idx number to process all files. - # - my @vals = split( '\.', $timefiles[0] ); - for ( my $ii=$#vals; $ii >= 0; $ii-- ) { - if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ - $idx = $ii; + my $hr_ctr = $#hrs + 1; + + do { + + $hr_ctr = $hr_ctr - 1; + + $newdir = "${dirpath}/${sortmm[$ctr]}/${hrs[$hr_ctr]}/oznmon/time"; + + if( -d $newdir ) { + opendir DIR, $newdir or die "Cannot open the current directory: $!"; + + my @timefiles = grep { /ieee_d/ } readdir DIR; + + if( $#timefiles >= 0 ) { + my @sorttime = sort( @timefiles ); + my @times; + my $idx = 0; + + # Find the first string of 10 digits; that's the date. Use that + # $idx number to process all files. + # + my @vals = split( '\.', $timefiles[0] ); + for ( my $ii=$#vals; $ii >= 0; $ii-- ) { + if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ + $idx = $ii; + } } - } - for ( my $ii=$#sorttime; $ii >= 0; $ii-- ) { - my $teststr = $sorttime[$ii]; + for ( my $ii=$#sorttime; $ii >= 0; $ii-- ) { + my $teststr = $sorttime[$ii]; - my @values = split( '\.', $teststr ); - push( @times, $values[$idx] ); + my @values = split( '\.', $teststr ); + push( @times, $values[$idx] ); - } - if ( $#times >= 0 ) { - my @utimes = sort( uniq( @times ) ); - if( $cyc == 1 ) { - print "$utimes[$#utimes]"; - $found_cycle = 1; - } elsif( $cyc == 2 && $#utimes >= 1 ) { - print "$utimes[$#utimes-1]"; - $found_cycle = 1; - } else { - print "$utimes[0]"; - $found_cycle = 1; + } + if ( $#times >= 0 ) { + my @utimes = sort( uniq( @times ) ); + if( $cyc == 1 ) { + print "$utimes[$#utimes]"; + $found_cycle = 1; + } elsif( $cyc == 2 && $#utimes >= 1 ) { + print "$utimes[$#utimes-1]"; + $found_cycle = 1; + } else { + print "$utimes[0]"; + $found_cycle = 1; + } } } - } - } + } + + } while $hr_ctr > 0 && $found_cycle == 0; } while $found_cycle == 0 && $ctr > 0; diff --git a/util/Ozone_Monitor/data_xtrct/ush/run_GEOIRctl3.sh b/util/Ozone_Monitor/data_xtrct/ush/run_GEOIRctl3.sh new file mode 100755 index 000000000..7f117456e --- /dev/null +++ b/util/Ozone_Monitor/data_xtrct/ush/run_GEOIRctl3.sh @@ -0,0 +1,71 @@ +#!/bin/sh + +set -xa + +OZN_SUFFIX=GEOIRctl3 +run=gdas + +NET=gfs +envir=prod + +MY_MACHINE=wcoss_d +package="ProdGSI/util/Ozone_Monitor" +#package="OznMon" + +if [[ $MY_MACHINE = "cray" ]]; then + . /opt/modules/3.2.6.7/init/sh + module use -a /gpfs/hps/nco/ops/nwprod/modulefiles + module load prod_util +elif [[ $MY_MACHINE = "wcoss" ]]; then + shell=sh + . /usrx/local/Modules/default/init/${shell} + module load prod_util +elif [[ $MY_MACHINE = "wcoss_d" ]]; then + shell=sh + . /usrx/local/prod/modules/default/init/${shell} + module load prod_util/1.1.0 + MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/core_third + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/defs + MODULEPATH=${MODULEPATH}:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod + export MODULEPATH=${MODULEPATH}:/usrx/local/dev/modulefiles +fi + + +if [[ $MY_MACHINE = "theia" ]]; then + scripts=/scratch4/NCEPDEV/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct/ush +elif [[ $MY_MACHINE = "wcoss" ]]; then + scripts=/gpfs/gd2/emc/da/noscrub/Edward.Safford/${package}/data_xtrct/ush +elif [[ $MY_MACHINE = "wcoss_d" ]]; then + scripts=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct/ush +elif [[ $MY_MACHINE = "cray" ]]; then + scripts=/gpfs/hps3/emc/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct/ush +fi + +idate=`${scripts}/find_cycle.pl -dir ~/nbns/stats/${OZN_SUFFIX} -cyc 1 -run ${run}` +echo "idate = $idate" + +export NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.1/exec/ips/ndate +export START_DATE=2019052006 +#START_DATE=`${NDATE} +06 $idate` + +PDY=`echo $START_DATE | cut -c1-8` +cyc=`echo $START_DATE | cut -c9-10` + + +#export COM_IN=/gpfs/dell1/nco/ops/com/${NET}/${envir}/${run}.${PDY}/${cyc} +export COM_IN=/gpfs/dell3/ptmp/Haixia.Liu/ROTDIRS/prfv3_GEOIRctl3/${run}.${PDY}/${cyc} + +export oznstat=${COM_IN}/${run}.t${cyc}z.oznstat + +export OZN_TANKDIR=/u/${LOGNAME}/nbns + +log=/gpfs/dell2/ptmp/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.log +#log=/ptmpd1/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.log +#log=./log + +#err=/ptmpd1/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.err +err=/gpfs/dell2/ptmp/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.err +#err=./err + +${scripts}/OznMon_DE.sh $OZN_SUFFIX -p $START_DATE -r gdas 1>$log 2>$err diff --git a/util/Ozone_Monitor/data_xtrct/ush/run_GEOIRimg4.sh b/util/Ozone_Monitor/data_xtrct/ush/run_GEOIRimg4.sh new file mode 100755 index 000000000..5b9160ee7 --- /dev/null +++ b/util/Ozone_Monitor/data_xtrct/ush/run_GEOIRimg4.sh @@ -0,0 +1,72 @@ +#!/bin/sh + +set -xa + +OZN_SUFFIX=GEOIRimg4 +run=gdas + +NET=gfs +envir=prod + +MY_MACHINE=wcoss_d +package="ProdGSI/util/Ozone_Monitor" +#package="OznMon" + +if [[ $MY_MACHINE = "cray" ]]; then + . /opt/modules/3.2.6.7/init/sh + module use -a /gpfs/hps/nco/ops/nwprod/modulefiles + module load prod_util +elif [[ $MY_MACHINE = "wcoss" ]]; then + shell=sh + . /usrx/local/Modules/default/init/${shell} + module load prod_util +elif [[ $MY_MACHINE = "wcoss_d" ]]; then + shell=sh + . /usrx/local/prod/modules/default/init/${shell} + module load prod_util/1.1.0 + MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/core_third + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/defs + MODULEPATH=${MODULEPATH}:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod + export MODULEPATH=${MODULEPATH}:/usrx/local/dev/modulefiles +fi + + +if [[ $MY_MACHINE = "theia" ]]; then + scripts=/scratch4/NCEPDEV/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct/ush +elif [[ $MY_MACHINE = "wcoss" ]]; then + scripts=/gpfs/gd2/emc/da/noscrub/Edward.Safford/${package}/data_xtrct/ush +elif [[ $MY_MACHINE = "wcoss_d" ]]; then + scripts=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct/ush +elif [[ $MY_MACHINE = "cray" ]]; then + scripts=/gpfs/hps3/emc/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct/ush +fi + +idate=`${scripts}/find_cycle.pl -dir ~/nbns/stats/${OZN_SUFFIX} -cyc 1 -run ${run}` +echo "idate = $idate" + +export NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.1/exec/ips/ndate +#export START_DATE=2019062812 +START_DATE=`${NDATE} +06 $idate` + +PDY=`echo $START_DATE | cut -c1-8` +cyc=`echo $START_DATE | cut -c9-10` + + +#export COM_IN=/gpfs/dell1/nco/ops/com/${NET}/${envir}/${run}.${PDY}/${cyc} +export COM_IN=/gpfs/dell3/ptmp/Haixia.Liu/ROTDIRS/prfv3_${OZN_SUFFIX}/${run}.${PDY}/${cyc} + +export oznstat=${COM_IN}/${run}.t${cyc}z.oznstat + +export OZN_TANKDIR=/u/${LOGNAME}/nbns +export OZNMON_NEW_HDR=1 + +log=/gpfs/dell2/ptmp/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.log +#log=/ptmpd1/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.log +#log=./log + +#err=/ptmpd1/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.err +err=/gpfs/dell2/ptmp/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.err +#err=./err + +${scripts}/OznMon_DE.sh $OZN_SUFFIX -p $START_DATE -r gdas 1>$log 2>$err diff --git a/util/Ozone_Monitor/data_xtrct/ush/run_fv3rt1.sh b/util/Ozone_Monitor/data_xtrct/ush/run_fv3rt1.sh deleted file mode 100755 index 445d04926..000000000 --- a/util/Ozone_Monitor/data_xtrct/ush/run_fv3rt1.sh +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/sh - -OZN_SUFFIX=fv3rt1 -run=gdas - -MY_MACHINE=cray - -if [[ $MY_MACHINE = "cray" ]]; then - . /opt/modules/3.2.6.7/init/sh - module use -a /gpfs/hps/nco/ops/nwprod/modulefiles - module load prod_util -fi - -scripts=/gpfs/hps3/emc/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct - -idate=`${scripts}/find_cycle.pl -dir ~/nbns/stats/${OZN_SUFFIX} -cyc 1 -run ${run}` - -#START_DATE=2017112306 -export START_DATE=`${NDATE} +06 $idate` - -PDY=`echo $START_DATE | cut -c1-8` -cyc=`echo $START_DATE | cut -c9-10` - -export COM_IN=/gpfs/hps3/ptmp/emc.glopara/ROTDIRS/prfv3rt1/${run}.${PDY}/${cyc} -export oznstat=${COM_IN}/${run}.t${cyc}z.oznstat - -${scripts}/OznMon_DE.sh $OZN_SUFFIX -p $START_DATE -r gdas 1>log 2>err diff --git a/util/Ozone_Monitor/data_xtrct/ush/run_gfs_gdas.sh b/util/Ozone_Monitor/data_xtrct/ush/run_gfs_gdas.sh new file mode 100755 index 000000000..92bbaec9e --- /dev/null +++ b/util/Ozone_Monitor/data_xtrct/ush/run_gfs_gdas.sh @@ -0,0 +1,72 @@ +#!/bin/sh + +set -xa + +OZN_SUFFIX=GFS +run=gdas + +NET=gfs +envir=prod + +MY_MACHINE=wcoss_d +package="ProdGSI/util/Ozone_Monitor" +#package="OznMon" + +if [[ $MY_MACHINE = "cray" ]]; then + . /opt/modules/3.2.6.7/init/sh + module use -a /gpfs/hps/nco/ops/nwprod/modulefiles + module load prod_util +elif [[ $MY_MACHINE = "wcoss" ]]; then + shell=sh + . /usrx/local/Modules/default/init/${shell} + module load prod_util +elif [[ $MY_MACHINE = "wcoss_d" ]]; then + shell=sh + . /usrx/local/prod/modules/default/init/${shell} + module load prod_util/1.1.0 + MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/core_third + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/defs + MODULEPATH=${MODULEPATH}:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod + export MODULEPATH=${MODULEPATH}:/usrx/local/dev/modulefiles +fi + + +if [[ $MY_MACHINE = "hera" ]]; then + scripts=/scratch4/NCEPDEV/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct/ush +elif [[ $MY_MACHINE = "wcoss" ]]; then + scripts=/gpfs/gd2/emc/da/noscrub/Edward.Safford/${package}/data_xtrct/ush +elif [[ $MY_MACHINE = "wcoss_d" ]]; then + scripts=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct/ush +elif [[ $MY_MACHINE = "cray" ]]; then + scripts=/gpfs/hps3/emc/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/data_xtrct/ush +fi + +idate=`${scripts}/find_cycle.pl -dir ~/nbns/stats/${OZN_SUFFIX} -cyc 1 -run ${run}` +echo "idate = $idate" + +export NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.1/exec/ips/ndate +#export START_DATE=2020010500 +START_DATE=`${NDATE} +06 $idate` + +PDY=`echo $START_DATE | cut -c1-8` +cyc=`echo $START_DATE | cut -c9-10` + + +export COM_IN=/gpfs/dell1/nco/ops/com/${NET}/${envir}/${run}.${PDY}/${cyc} +#export COM_IN=/scratch4/NCEPDEV/da/noscrub/Edward.Safford/test_data/${run}.${PDY}/${cyc} + +export oznstat=${COM_IN}/${run}.t${cyc}z.oznstat + +export OZN_TANKDIR=/u/${LOGNAME}/nbns +#export OZN_TANKDIR=/home/${LOGNAME}/nbns + +log=/gpfs/dell2/ptmp/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.log +#log=/ptmpd1/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.log +#log=./log + +err=/gpfs/dell2/ptmp/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.err +#err=/ptmpd1/Edward.Safford/logs/${OZN_SUFFIX}/${run}/oznmon/OznMon_DE.err +#err=./err + +${scripts}/OznMon_DE.sh $OZN_SUFFIX -p $START_DATE -r gdas 1>$log 2>$err diff --git a/util/Ozone_Monitor/get_hostname.pl b/util/Ozone_Monitor/get_hostname.pl index d1e5a67cc..8d2d6d5b9 100755 --- a/util/Ozone_Monitor/get_hostname.pl +++ b/util/Ozone_Monitor/get_hostname.pl @@ -4,35 +4,23 @@ # get_hostname.pl # # This script determines the hostname of the current machine. The -# possiblities are cray, theia, ibm or "" if the host is not +# possiblities are cray, theia, wcoss or "" if the host is not # one of those three. #------------------------------------------------------------------- -# use IO::File; -# use File::Copy qw(move); - my $arch; - $arch = ` uname -s | tr '[:upper:]' '[:lower:]' `; - $arch =~ s/^\s+|\s+$//g; - my $my_os = "export MY_OS=$arch"; - - # - # Determine if installation is on WCOSS, Theia, or Zeus. - # - if( $arch ne "linux" && $arch ne "aix" ) { - die( "only linux and aix are supported, $arch is not\n" ); - } -# print "\n"; -# print "arch = $arch\n"; +# my $arch; +# $arch = ` uname -s | tr '[:upper:]' '[:lower:]' `; +# $arch =~ s/^\s+|\s+$//g; +# my $my_os = "export MY_OS=$arch"; my $machine = ""; # - # theia login nodes are tfe1-tfe8, and hostname command only returns the node name, - # while ccs and (perhaps) ibm return [hostname].ncep.noaa.gov. Keep only the - # actual hostname and see if it matches the node names for zeus, tide, or gyre. + # hera login nodes are hfe1-hfeN, and hostname command only returns the node name, + # while wcoss_c and wcoss_d return [hostname].ncep.noaa.gov. Keep only the + # actual hostname and see if it matches the node names for hera, wcoss_d, or cray. # - my $host_zeus = 0; my $host = ""; $host = ` hostname `; chomp( $host ); @@ -42,14 +30,17 @@ $host = $hostnames[0]; } - if( $host =~ /tfe/ ) { - $machine = "theia"; + if( $host =~ /hfe/ ) { + $machine = "hera"; } elsif( $host =~ /login/ ) { $machine = "cray"; } - elsif( $host =~ /t/ || $host =~ /g/ ){ # ibm nodes are tXXaY and gXXaY - $machine = "ibm"; + elsif( $host =~ /t/ || $host =~ /g/ ){ # wcoss nodes are tXXaY and gXXaY + $machine = "wcoss"; + } + elsif( $host =~ /v/ || $host =~ /m/ ){ # wcoss_d nodes are vXXaY and mXXaY + $machine = "wcoss_d"; } print "$machine"; diff --git a/util/Ozone_Monitor/image_gen/gscripts/plot_count.gs b/util/Ozone_Monitor/image_gen/gscripts/plot_count.gs index 93cbac1a8..eba5757ba 100755 --- a/util/Ozone_Monitor/image_gen/gscripts/plot_count.gs +++ b/util/Ozone_Monitor/image_gen/gscripts/plot_count.gs @@ -1,16 +1,22 @@ * Script to plot given bias correction term for given satellite instrument * -* Two arguments are expected +* Expected arguments: +* net = $NET value or identifying source (e.g. GFS|fv3rt1) +* run = $RUN value (e.g. gfs|gdas) * plotfile = satellite id (name and number ... e.g., msu.014 = noaa-14 msu) -* field = field to plot (valid strings are: count total fixang lapse lapse2 const scangl clw +* field = field to plot (valid strings are: cnt total fixang lapse lapse2 const scangl clw +* xsize = horiz image size +* ysize = vert image size *'reinit' function plottime (args) -plotfile=subwrd(args,1) -field=subwrd(args,2) -xsize=subwrd(args,3) -ysize=subwrd(args,4) +net=subwrd(args,1) +run=subwrd(args,2) +plotfile=subwrd(args,3) +field=subwrd(args,4) +xsize=subwrd(args,5) +ysize=subwrd(args,6) platform=plotfile *say 'process 'field' from 'plotfile @@ -24,7 +30,7 @@ satnam=subwrd(lin1,4) satnum=subwrd(lin1,5) nlev=subwrd(lin1,6) -if (field = count) +if (field = cnt) type="number of observations" endif @@ -184,10 +190,11 @@ while (levn<=nlev) fr=fr+1 'set string 1 l 6' 'set strsiz 0.15 0.15' - 'draw string 0.2 10.80 platform: 'plotfile - 'draw string 0.2 10.55 region : 'area - 'draw string 0.2 10.30 variable: 'type - 'draw string 0.2 10.05 valid : 'date1' to 'date2 + 'draw string 02. 10.80 Net, run: 'net','run + 'draw string 0.2 10.55 platform: 'plotfile + 'draw string 0.2 10.30 region : 'area + 'draw string 0.2 10.05 variable: 'type + 'draw string 0.2 09.80 valid : 'date1' to 'date2 outfile=plotfile'.'field'_region'region'_fr'fr'.png' 'printim 'outfile' 'xsize' 'ysize' white' * say 'output to file 'outfile diff --git a/util/Ozone_Monitor/image_gen/gscripts/plot_horiz_anl.gs b/util/Ozone_Monitor/image_gen/gscripts/plot_horiz_anl.gs index 504e73a54..76d1f5c98 100755 --- a/util/Ozone_Monitor/image_gen/gscripts/plot_horiz_anl.gs +++ b/util/Ozone_Monitor/image_gen/gscripts/plot_horiz_anl.gs @@ -1,15 +1,21 @@ * Script to plot horizontal maps of given field for given satellite instrument * -* Two arguments are expected +* Expected arguments +* net = $NET value or the identifying source (e.g. GFS | prfv3rt1) +* run = $RUN value (e.g. gfs | gdas) * plotfile = satellite id (name and number ... e.g., sbuv2_n17 = noaa-17 sbuv/2) -* field = field to plot (valid strings are: obs, ges, obsges) +* field = field to plot (valid strings are: obs, anl, obsanl) +* xsize = horiz image size +* ysize = vert image size function plottime (args) -plotfile=subwrd(args,1) -field=subwrd(args,2) -xsize=subwrd(args,3) -ysize=subwrd(args,4) +net=subwrd(args,1) +run=subwrd(args,2) +plotfile=subwrd(args,3) +field=subwrd(args,4) +xsize=subwrd(args,5) +ysize=subwrd(args,6) platform=plotfile *say 'plotfile='plotfile @@ -29,10 +35,10 @@ nlev=subwrd(lin1,6) if (field = obs) type="observation " endif -if (field = ges) +if (field = anl) type=" analysis " endif -if (field = obsges) +if (field = obsanl) type="obs - anl " endif if (field = sza) @@ -145,7 +151,7 @@ while (levn<=mxlev) endwhile '!rm -f info.txt' - '!cat 'plotfile'.ctl |grep " 'levn', level" > info.txt' + '!cat 'plotfile'.anl.ctl |grep " 'levn', level" > info.txt' result=read(info.txt) rc=sublin(result,1) iuse=0 @@ -163,12 +169,13 @@ while (levn<=mxlev) 'set string 1 r 6' 'set string 1 l 6' 'set strsiz 0.15 0.15' + 'draw string 0.2 8.3 Net, run : 'net', 'run if (iuse>0) - 'draw string 0.2 8.3 platform: 'satnam' 'satnum + 'draw string 4.0 8.3 platform: 'satnam' 'satnum endif if (iuse<=0) 'set string 2 l 6' - 'draw string 0.2 8.3 platform: 'satnam' 'satnum' (NOT ASSIMILATED)' + 'draw string 4.0 8.3 platform: 'satnam' 'satnum' (NOT ASSIMILATED)' endif if ( level > 0.0 ) 'set string 1 l 6' @@ -184,7 +191,7 @@ while (levn<=mxlev) endif * say 'iuse='iuse * say plotfile'.'field'_'levn'.png' - 'printim 'plotfile'.'field'_'levn'.png 'xsize' 'ysize' white' + 'printim 'plotfile'.anl.'field'_'levn'.png 'xsize' 'ysize' white' * 'enable print 'plotfile'.'field'_'levn * 'print' * 'disable print' @@ -194,16 +201,17 @@ while (levn<=mxlev) 'set string 1 r 6' 'set string 1 l 6' 'set strsiz 0.15 0.15' + 'draw string 0.2 8.3 Net,run : 'net', 'run if (iuse>0) - 'draw string 0.2 8.3 platform: 'satnam' 'satnum + 'draw string 4.2 8.3 platform: 'satnam' 'satnum endif if (iuse<=0) 'set string 2 l 6' - 'draw string 0.2 8.3 platform: 'satnam' 'satnum' (NOT ASSIMILATED)' + 'draw string 4.2 8.3 platform: 'satnam' 'satnum' (NOT ASSIMILATED)' endif 'set string 1 l 6' 'draw string 0.2 8.1 variable: level 'levn' 'type - 'printim 'plotfile'.'field'_'levn'.png 'xsize' 'ysize + 'printim 'plotfile'.anl.'field'_'levn'.png 'xsize' 'ysize endif diff --git a/util/Ozone_Monitor/image_gen/gscripts/plot_horiz_ges.gs b/util/Ozone_Monitor/image_gen/gscripts/plot_horiz_ges.gs index 39b740577..6167ecda2 100755 --- a/util/Ozone_Monitor/image_gen/gscripts/plot_horiz_ges.gs +++ b/util/Ozone_Monitor/image_gen/gscripts/plot_horiz_ges.gs @@ -1,15 +1,21 @@ * Script to plot horizontal maps of given field for given satellite instrument * -* Two arguments are expected +* Expected Arguments: +* net = $NET value, or data source identifier (e.g. GFS|fv3rt1) +* run = $RUN value (e.g. gfs|gdas) * plotfile = satellite id (name and number ... e.g., sbuv2_n17 = noaa-17 sbuv/2) -* field = field to plot (valid strings are: obs, ges, obsges) +* field = field to plot (valid strings are: obs, ges, obsges) +* xsize = horiz plot image size +* ysize = vert plot image size function plottime (args) -plotfile=subwrd(args,1) -field=subwrd(args,2) -xsize=subwrd(args,3) -ysize=subwrd(args,4) +net=subwrd(args,1) +run=subwrd(args,2) +plotfile=subwrd(args,3) +field=subwrd(args,4) +xsize=subwrd(args,5) +ysize=subwrd(args,6) platform=plotfile *say 'plotfile='plotfile @@ -145,7 +151,7 @@ while (levn<=mxlev) endwhile '!rm -f info.txt' - '!cat 'plotfile'.ctl |grep " 'levn', level" > info.txt' + '!cat 'plotfile'.ges.ctl | grep " 'levn', level" > info.txt' result=read(info.txt) rc=sublin(result,1) iuse=0 @@ -163,12 +169,13 @@ while (levn<=mxlev) 'set string 1 r 6' 'set string 1 l 6' 'set strsiz 0.15 0.15' + 'draw string 0.2 8.3 Net, run : 'net', 'run if (iuse>0) - 'draw string 0.2 8.3 platform: 'satnam' 'satnum + 'draw string 4.0 8.3 platform: 'satnam' 'satnum endif if (iuse<=0) 'set string 2 l 6' - 'draw string 0.2 8.3 platform: 'satnam' 'satnum' (NOT ASSIMILATED)' + 'draw string 4.0 8.3 platform: 'satnam' 'satnum' (NOT ASSIMILATED)' endif if ( level > 0.0 ) 'set string 1 l 6' @@ -184,7 +191,7 @@ while (levn<=mxlev) endif * say 'iuse='iuse * say plotfile'.'field'_'levn'.png' - 'printim 'plotfile'.'field'_'levn'.png 'xsize' 'ysize' white' + 'printim 'plotfile'.ges.'field'_'levn'.png 'xsize' 'ysize' white' * 'enable print 'plotfile'.'field'_'levn * 'print' * 'disable print' @@ -203,7 +210,7 @@ while (levn<=mxlev) endif 'set string 1 l 6' 'draw string 0.2 8.1 variable: level 'levn' 'type - 'printim 'plotfile'.'field'_'levn'.png 'xsize' 'ysize + 'printim 'plotfile'.ges.'field'_'levn'.png 'xsize' 'ysize endif diff --git a/util/Ozone_Monitor/image_gen/gscripts/plot_summary.gs b/util/Ozone_Monitor/image_gen/gscripts/plot_summary.gs index ea115ffa4..1baa04468 100755 --- a/util/Ozone_Monitor/image_gen/gscripts/plot_summary.gs +++ b/util/Ozone_Monitor/image_gen/gscripts/plot_summary.gs @@ -1,17 +1,25 @@ * Script to plot given bias correction term for given satellite instrument * -* Two arguments are expected +* Expected arguments: +* net = $NET value, or identifying source (e.g. GFS|fv3rt1) +* run = $RUN value (e.g. gfs|gdas) * plotfile = satellite id (name and number ... e.g., msu.014 = noaa-14 msu) +* ptype = 'ges' or 'anl' +* xsize = horiz image size +* ysize = vert image size + function plotsummary (args) -plotfile=subwrd(args,1) -xsize=subwrd(args,3) -ysize=subwrd(args,4) +net=subwrd(args,1) +run=subwrd(args,2) +plotfile=subwrd(args,3) +ptype=subwrd(args,4) +xsize=subwrd(args,5) +ysize=subwrd(args,6) platform=plotfile say 'process plotfile 'plotfile -*'open 'plotfile'.ctl' 'q file' lin1=sublin(result,1) @@ -21,12 +29,18 @@ nlev=subwrd(lin1,6) *say 'nlev='nlev nfield=3 -field.1=count +field.1=cnt field.2=omg +if (ptype = "anl") + field.2=oma +endif field.3=cpen title.1="number of observations passing quality control" title.2="obs - ges" +if (ptype = "anl") + title.2="obs - anl" +endif title.3="contribution to penalty" color.1=7 @@ -65,9 +79,11 @@ t7days=tlast-27 i=1 while (i<=nfield) +*--------------------- * Counts plot -if (field.i = "count") - y1=8.1 +*--------------------- +if (field.i = "cnt") + y1=7.5 t1=t1day t2=tlast 'set t 't1' 't2 @@ -131,7 +147,7 @@ if (field.i = "count") xpos=subwrd(result,3) ypos=subwrd(result,6) '!rm -f info.txt' - '!cat 'plotfile'.ctl |grep "'ic', level" > info.txt' + '!cat 'plotfile'.'ptype'.ctl |grep "'ic', level" > info.txt' result=read(info.txt) rc=sublin(result,1) iuse=0 @@ -168,9 +184,11 @@ if (field.i = "count") endif -* obs - ges plot +*--------------------- +* obs - ges|anl plot +*--------------------- * say 'i,field.i='i' 'field.i -if (field.i = "omg") +if (field.i = "omg" | field.i = "oma") y1=y1-2.5 'set t 'tlast t1=tlast @@ -412,7 +430,9 @@ if (field.i = "omg") endif +*------------------------- * Contribution to penalty +*------------------------- if (field.i = "cpen") y1=y1-2.5 'set t 'tlast @@ -528,12 +548,13 @@ endwhile 'set string 1 l 6' 'set strsiz 0.15 0.15' -'draw string 0.2 10.80 platform: 'plotfile -'draw string 0.2 10.55 valid : 'date1 +'draw string 0.2 10.80 Net, run: 'net','run +'draw string 0.2 10.55 platform: 'plotfile +'draw string 0.2 10.30 valid : 'date1 'set string 1 c 6' -'draw string 4.05 2.5 l e v e l n u m b e r' +'draw string 4.05 2.0 l e v e l n u m b e r' -outfile=plotfile'.summary.png' +outfile=plotfile'.'ptype'.summary.png' 'printim 'outfile' 'xsize' 'ysize' white' return diff --git a/util/Ozone_Monitor/image_gen/gscripts/plot_time_anl.gs b/util/Ozone_Monitor/image_gen/gscripts/plot_time_anl.gs index 5d657d7bf..86fe15ace 100755 --- a/util/Ozone_Monitor/image_gen/gscripts/plot_time_anl.gs +++ b/util/Ozone_Monitor/image_gen/gscripts/plot_time_anl.gs @@ -1,20 +1,26 @@ * Script to plot given bias correction term for given satellite instrument * -* Two arguments are expected +* Expected arguments: +* net = $NET value or identifying source (e.g. GFS|fv3rt1) +* run = $RUN value (e.g. gfs|gdas) * plotfile = satellite id (name and number ... e.g., msu.014 = noaa-14 msu) -* field = field to plot (valid strings are: count total fixang lapse lapse2 const scangl clw +* field = field to plot (valid strings are: cnt total fixang lapse lapse2 const scangl clw +* xsize = horiz image size +* ysize = vert image size *'reinit' function plottime (args) -plotfile=subwrd(args,1) -field=subwrd(args,2) -xsize=subwrd(args,3) -ysize=subwrd(args,4) +net=subwrd(args,1) +run=subwrd(args,2) +plotfile=subwrd(args,3) +field=subwrd(args,4) +xsize=subwrd(args,5) +ysize=subwrd(args,6) platform=plotfile *say 'process 'field' from 'plotfile -*'open 'plotfile'.ctl' +*'open 'plotfile'.anl.ctl' debug=0 @@ -24,10 +30,10 @@ satnam=subwrd(lin1,4) satnum=subwrd(lin1,5) nlev=subwrd(lin1,6) -if (field = count) +if (field = cnt) type="number of observations" endif -if (field = omg ) +if (field = oma ) type="obs-anl" endif if (field = cpen ) @@ -60,7 +66,7 @@ while (region<=nregion) *say 'top of region loop with region='region '!rm -f area.txt' -'!cat 'plotfile'.ctl |grep "region= 'region' " > area.txt' +'!cat 'plotfile'.anl.ctl |grep "region= 'region' " > area.txt' result=read(area.txt) rc=sublin(result,1) area="uknown" @@ -87,11 +93,11 @@ levn=1 while (levn<=nlev) * say 'top of level loop with levn= 'levn 'set x 'levn - if (field != "count" & field != "cpen") + if (field != "cnt" & field != "cpen") 'define avg=avg'field 'define sdv=sdv'field endif - if (field = "count" | field = "cpen") + if (field = "cnt" | field = "cpen") 'define avg='field 'define sdv='field 'set gxout stat' @@ -122,7 +128,7 @@ while (levn<=nlev) avgvar=subwrd(rec11,2) * say 'avg'field' min,max,avg='minvar','maxvar','avgvar','valvar - if (field != "count" & field != "cpen") + if (field != "cnt" & field != "cpen") 'd sdv' rec7=sublin(result,7) rec8=sublin(result,8) @@ -134,14 +140,14 @@ while (levn<=nlev) * say 'sdv'var' min,max,avg='minsdv','maxsdv','avgsdv','valsdv endif - if (field = "count" | field = "cpen") + if (field = "cnt" | field = "cpen") minsdv=minvar maxsdv=maxvar valsdv=valvar endif '!rm -f info.txt' - '!cat 'plotfile'.ctl |grep "'levn', level" > info.txt' + '!cat 'plotfile'.anl.ctl |grep "'levn', level" > info.txt' result=read(info.txt) rc=sublin(result,1) iuse=0 @@ -186,7 +192,7 @@ while (levn<=nlev) 'set gxout line' 'set vrange 'ymin' 'ymax - if (field != "count" & field != "cpen") + if (field != "cnt" & field != "cpen") aymin=ymin if(ymin <0) aymin=-ymin @@ -212,7 +218,7 @@ while (levn<=nlev) 'd avg' 'set parea off' - if (field != "count" & field != "cpen") + if (field != "cnt" & field != "cpen") 'set parea 2.1 7.8 'y1+1.25' 'y1+2.1 'set grads off' 'set tlsupp year' @@ -251,11 +257,12 @@ while (levn<=nlev) fr=fr+1 'set string 1 l 6' 'set strsiz 0.15 0.15' - 'draw string 0.2 10.80 platform: 'plotfile - 'draw string 0.2 10.55 region : 'area - 'draw string 0.2 10.30 variable: 'type - 'draw string 0.2 10.05 valid : 'date1' to 'date2 - outfile=plotfile'.'field'_region'region'_fr'fr'.png' + 'draw string 0.2 10.80 Net,run : 'net', 'run + 'draw string 0.2 10.55 platform: 'plotfile + 'draw string 0.2 10.30 region : 'area + 'draw string 0.2 10.05 variable: 'type + 'draw string 0.2 09.80 valid : 'date1' to 'date2 + outfile=plotfile'.anl.'field'_region'region'_fr'fr'.png' 'printim 'outfile' 'xsize' 'ysize' white' * say 'output to file 'outfile if (debug=1) diff --git a/util/Ozone_Monitor/image_gen/gscripts/plot_time_anl_2x.gs b/util/Ozone_Monitor/image_gen/gscripts/plot_time_anl_2x.gs new file mode 100755 index 000000000..3ae75044d --- /dev/null +++ b/util/Ozone_Monitor/image_gen/gscripts/plot_time_anl_2x.gs @@ -0,0 +1,392 @@ +* Script to plot given bias correction term for given satellite instrument +* +* Expected arguments: +* net = $NET value, or the identifying data source (e.g. GFS|fv3rt1) +* run = $RUN value, typically gfs|gdas +* plotfile1 = satellite id (name and number ... e.g., msu.014 = noaa-14 msu) +* plotfile2 = satellite id (name and number ... e.g., msu.014 = noaa-14 msu) +* field = field to plot (valid strings are: cnt total fixang lapse lapse2 const scangl clw +* xsize = horiz size of plotted image +* ysize = vert size of plotted image + +*'reinit' +function plottime (args) + +net=subwrd(args,1) +run=subwrd(args,2) +plotfile1=subwrd(args,3) +plotfile2=subwrd(args,4) +field=subwrd(args,5) +xsize=subwrd(args,6) +ysize=subwrd(args,7) +*platform1=plotfile1 +*platform2=plotfile2 + +say 'process 'field' from 'plotfile1 +say 'process 'field' from 'plotfile2 +* 'open 'plotfile1'.anl.ctl' +* 'open 'plotfile2'.anl.ctl' + +debug=0 + +'q file' +lin1=sublin(result,1) +satnam=subwrd(lin1,4) +satnum=subwrd(lin1,5) +nlev=subwrd(lin1,6) + +if (field = cnt) + type="number of observations" +endif +if (field = oma ) + type="obs-anl" +endif +if (field = cpen ) + type="contribution to penalty" +endif + +* Determine number of levels and regions +'q file' +lin1=sublin(result,1) +nlev=subwrd(lin1,6) +lin5=sublin(result,5) +nregion=subwrd(lin5,6) + + +*say 'nlev='nlev +*say 'nregion='nregion + +* Set time +'set t 1 last' +'query time' +date1=subwrd(result,3) +date2=subwrd(result,5) + +*say 'date1='date1 +*say 'date2='date2 + +region=1 +while (region<=nregion) + +*say 'top of region loop with region='region + +'!rm -f area.txt' +'!cat 'plotfile1'.anl.ctl |grep "region= 'region' " > area.txt' +result=read(area.txt) +rc=sublin(result,1) +area="uknown" +if (rc = 0) + info=sublin(result,2) + area=substr(info,14,60) +endif +result=close(area.txt) +*say 'area = 'area + + +'clear' +'set grads off' +'set y 'region + +'set string 1 l 5' +'set strsiz 0.11 0.11' +'set xlopts 1 4 0.11' +'set ylopts 1 2 0.09' + +fr=0 +i=1 +levn=1 +while (levn<=nlev) +* say 'top of level loop with levn= 'levn +* +*----------------------------------------------------- +* Note: here avg and sdv are being (mis)used in +* the cases of cnt and cpen. They are not avg +* and sdv values, but someone was being cute and +* rather than add another if( ) case, decided all +* cases could use avg and sdv when actually +* plotting. That, predictably, took a while to +* understand. I'd fix it but ultimately I'm +* going to do away with GrADS plots in favour of +* using javascript to make things on-the-fly. +* So for now think of this note as a sort of +* +* "Warning: Logical Minefield" +* +*----------------------------------------------------- + 'set x 'levn + if (field != "cnt" & field != "cpen") + 'define avg1=avg'field'.1' + 'define sdv1=sdv'field'.1' + 'define avg2=avg'field'.2' + 'define sdv2=sdv'field'.2' + endif + if (field = "cnt" | field = "cpen") + 'define avg1='field'.1' + 'define sdv1='field'.1' + 'define avg2='field'.2' + 'define sdv2='field'.2' + + + 'set gxout stat' + 'd avg1' + rec14=sublin(result,14) + avgsdv1=subwrd(rec14,2) + endif + levi=levn + if (i=1) + 'clear' + y1=7.65 + endif + if (i>1 & i<4) + y1=y1-2.45 + endif + if (i=4) + y1=y1-2.45 + endif + + 'set gxout stat' + 'd avg1' + rec7=sublin(result,7) + rec8=sublin(result,8) + rec11=sublin(result,11) + valvar1=subwrd(rec7,8) + minvar1=subwrd(rec8,4) + maxvar1=subwrd(rec8,5) + avgvar1=subwrd(rec11,2) + + 'set gxout stat' + 'd avg2' + rec7=sublin(result,7) + rec8=sublin(result,8) + rec11=sublin(result,11) + valvar2=subwrd(rec7,8) + minvar2=subwrd(rec8,4) + maxvar2=subwrd(rec8,5) + avgvar2=subwrd(rec11,2) + + minvar=minvar1 + if (minvar2 <= minvar) + minvar=minvar2 + endif +* say 'minvar1, minvar1, minvar = 'minvar1', 'minvar2', 'minvar + + maxvar=maxvar1 + if (maxvar2 >= maxvar) + maxvar=maxvar2 + endif +* say 'maxvar1, maxvar1, maxvar = 'maxvar1', 'maxvar2', 'maxvar + + say 'avg1'field' min,max,avg1='minvar1','maxvar1','avgvar1','valvar1 + + if (field != "cnt" & field != "cpen") + 'set gxout stat' + 'd sdv1' + rec7=sublin(result,7) + rec8=sublin(result,8) + rec11=sublin(result,11) + valsdv1=subwrd(rec7,8) + minsdv1=subwrd(rec8,4) + maxsdv1=subwrd(rec8,5) + avgsdv1=subwrd(rec11,2) + + 'set gxout stat' + 'd sdv2' + rec7=sublin(result,7) + rec8=sublin(result,8) + rec11=sublin(result,11) + valsdv2=subwrd(rec7,8) + minsdv2=subwrd(rec8,4) + maxsdv2=subwrd(rec8,5) + avgsdv2=subwrd(rec11,2) + + minsdv=minsdv1 + if (minsdv2 <= minsdv) + minsdv=minsdv2 + endif + + maxsdv=maxsdv1 + if (maxsdv2 >= maxsdv) + maxsdv=maxsdv2 + endif +* say 'sdv'var' min,max,avg1='minsdv','maxsdv','avgsdv + endif + + if (field = "cnt" | field = "cpen") + minsdv=minvar + maxsdv=maxvar +* valsdv=valvar1 + endif + + '!rm -f info.txt' + '!cat 'plotfile1'.anl.ctl |grep "'levn', level" > info.txt' + result=read(info.txt) + rc=sublin(result,1) + iuse=0 + if (rc = 0) + info=sublin(result,2) + level=subwrd(info,5) + iuse=subwrd(info,8) + error=subwrd(info,11) + endif + result=close(info.txt) +* say 'level,iuse,error = 'level', 'iuse', 'error' + + 'set strsiz 0.12 0.12' + 'set string 1 l 6' + if ( level > 0.0 ) + 'draw string 0.1 'y1+1.5' pressure 'level + endif + + if ( level = 0.0 ) + 'draw string 0.1 'y1+1.5' pressure total' + endif + + 'set string 1 l 6' + + 'draw string 0.1 'y1+1.3' level 'levn + 'set string 4 l 6' + 'draw string 0.1 'y1+1.1' avg: 'digs(avgvar1,14) +* 'set string 2 l 6' + 'draw string 0.1 'y1+0.9' sdv: 'digs(avgsdv1,14) + + if (iuse<=0) + 'set string 9 l 6' + 'draw string 0.1 'y1+0.5' ** IS NOT **' + 'set string 3 l 6' + 'draw string 0.1 'y1+0.3' ASSIMILATED' + endif + + 'set parea 2.1 7.8 'y1' 'y1+1.2 + 'set grads off' + 'set tlsupp year' + 'set ylpos 0 r' + yrange=maxvar-minvar + dy=0.2*yrange + ymin=minvar-dy + ymax=maxvar+dy + yrange=ymax-ymin + 'set gxout line' + 'set vrange 'ymin' 'ymax +* say 'minvar, dy, maxvar, yrange,ymin,ymax = 'minvar','dy','maxvar','yrange','ymin','ymax + + + if (field != "cnt" & field != "cpen") + aymin=ymin + if(ymin <0) + aymin=-ymin + endif + if( aymin >0.0001) + 'set ylab %.4f' + endif + dy=0.2*yrange + 'set ylint 'dy + +* 'set yaxis 'ymin' 'ymax +* 'set ylab %.4f' +* yr=(ymax-ymin)/2 +* ymid=ymin+yr +* ym1=ymin+yr*0.5 +* ym2=ymid+yr*0.5 +* say ' ymid='ymid +* say ' ym1='ym1 +* say ' ym2='ym2 +* 'set ylevs 'ymin' 'ym1' 'ymid' 'ym2' 'ymax + endif + 'set ccolor 4' + 'set cmark 1' + 'd avg1' + 'set ccolor 2' + 'set cmark 1' + 'd avg2' + 'set parea off' + + if (field != "cnt" & field != "cpen") + 'set parea 2.1 7.8 'y1+1.25' 'y1+2.1 + 'set grads off' + 'set tlsupp year' + 'set tlsupp month' + 'set timelab off' + 'set ylpos 0 r' + yrange=maxsdv-minsdv + dy=0.1*yrange + ymin=minsdv-dy + ymax=maxsdv+dy + yrange=ymax-ymin + + 'set gxout line' + 'set vrange 'ymin' 'ymax +* 'set yaxis 'ymin' 'ymax + if( ymin >0.0001) + 'set ylab %.4f' + endif + +* yr=(ymax-ymin)/2 +* ymid=ymin+yr +* ym1=ymin+yr*0.5 +* ym2=ymid+yr*0.5 +* say ' ymid='ymid +* say ' ym1='ym1 +* say ' ym2='ym2 +* 'set ylevs 'ymin' 'ym1' 'ymid' 'ym2' 'ymax + + ymid=0.2*yrange + 'set ylint 'ymid + + 'set ccolor 4' + 'set cmark 1' + 'd sdv1' + 'set ccolor 2' + 'set cmark 1' + 'd sdv2' + + 'set parea off' + endif + + i=i+1 + if (i=5 | levn=nlev) + fr=fr+1 + 'set string 1 l 6' + 'set strsiz 0.15 0.15' + 'draw string 0.2 10.80 Net,run : 'net', 'run + + 'draw string 0.2 10.55 platform: ' + 'set string 4 l 6' + 'draw string 1.5 10.55 'plotfile1 + 'set string 2 l 6' + 'draw string 3.5 10.55 'plotfile2 + + 'set string 1 l 6' + 'draw string 0.2 10.30 region : 'area + 'draw string 0.2 10.05 variable : 'type + 'draw string 0.2 9.80 valid : 'date1' to 'date2 + outfile=plotfile1'.anl.'field'_region'region'_fr'fr'.png' + 'printim 'outfile' 'xsize' 'ysize' white' + +* say 'output to file 'outfile + if (debug=1) + say 'press any key to continue' + pull var + endif + i=1 + endif + levn=levn+1 +endwhile + +region=region+1 +endwhile + +return +endfile + +function digs(string,num) + nc=0 + pt="" + while(pt = "") + nc=nc+1 + zzz=substr(string,nc,1) + if(zzz = "." | zzz = ""); break; endif + endwhile + end=nc+num + str=substr(string,1,end) +return str + diff --git a/util/Ozone_Monitor/image_gen/gscripts/plot_time_ges.gs b/util/Ozone_Monitor/image_gen/gscripts/plot_time_ges.gs index 46103980c..e6f5caa9f 100755 --- a/util/Ozone_Monitor/image_gen/gscripts/plot_time_ges.gs +++ b/util/Ozone_Monitor/image_gen/gscripts/plot_time_ges.gs @@ -1,20 +1,26 @@ * Script to plot given bias correction term for given satellite instrument * -* Two arguments are expected +* Expected arguments: +* net = $NET value, or the identifying data source (e.g. GFS|fv3rt1) +* run = $RUN value, typically gfs|gdas * plotfile = satellite id (name and number ... e.g., msu.014 = noaa-14 msu) -* field = field to plot (valid strings are: count total fixang lapse lapse2 const scangl clw +* field = field to plot (valid strings are: cnt total fixang lapse lapse2 const scangl clw +* xsize = horiz size of plotted image +* ysize = vert size of plotted image *'reinit' function plottime (args) -plotfile=subwrd(args,1) -field=subwrd(args,2) -xsize=subwrd(args,3) -ysize=subwrd(args,4) +net=subwrd(args,1) +run=subwrd(args,2) +plotfile=subwrd(args,3) +field=subwrd(args,4) +xsize=subwrd(args,5) +ysize=subwrd(args,6) platform=plotfile *say 'process 'field' from 'plotfile -*'open 'plotfile'.ctl' +*'open 'plotfile'.ges.ctl' debug=0 @@ -24,7 +30,7 @@ satnam=subwrd(lin1,4) satnum=subwrd(lin1,5) nlev=subwrd(lin1,6) -if (field = count) +if (field = cnt) type="number of observations" endif if (field = omg ) @@ -60,7 +66,7 @@ while (region<=nregion) *say 'top of region loop with region='region '!rm -f area.txt' -'!cat 'plotfile'.ctl |grep "region= 'region' " > area.txt' +'!cat 'plotfile'.ges.ctl |grep "region= 'region' " > area.txt' result=read(area.txt) rc=sublin(result,1) area="uknown" @@ -87,11 +93,11 @@ levn=1 while (levn<=nlev) * say 'top of level loop with levn= 'levn 'set x 'levn - if (field != "count" & field != "cpen") + if (field != "cnt" & field != "cpen") 'define avg=avg'field 'define sdv=sdv'field endif - if (field = "count" | field = "cpen") + if (field = "cnt" | field = "cpen") 'define avg='field 'define sdv='field 'set gxout stat' @@ -122,7 +128,7 @@ while (levn<=nlev) avgvar=subwrd(rec11,2) * say 'avg'field' min,max,avg='minvar','maxvar','avgvar','valvar - if (field != "count" & field != "cpen") + if (field != "cnt" & field != "cpen") 'd sdv' rec7=sublin(result,7) rec8=sublin(result,8) @@ -134,14 +140,14 @@ while (levn<=nlev) * say 'sdv'var' min,max,avg='minsdv','maxsdv','avgsdv','valsdv endif - if (field = "count" | field = "cpen") + if (field = "cnt" | field = "cpen") minsdv=minvar maxsdv=maxvar valsdv=valvar endif '!rm -f info.txt' - '!cat 'plotfile'.ctl |grep "'levn', level" > info.txt' + '!cat 'plotfile'.ges.ctl |grep "'levn', level" > info.txt' result=read(info.txt) rc=sublin(result,1) iuse=0 @@ -186,7 +192,7 @@ while (levn<=nlev) 'set gxout line' 'set vrange 'ymin' 'ymax - if (field != "count" & field != "cpen") + if (field != "cnt" & field != "cpen") aymin=ymin if(ymin <0) aymin=-ymin @@ -212,7 +218,7 @@ while (levn<=nlev) 'd avg' 'set parea off' - if (field != "count" & field != "cpen") + if (field != "cnt" & field != "cpen") 'set parea 2.1 7.8 'y1+1.25' 'y1+2.1 'set grads off' 'set tlsupp year' @@ -251,11 +257,12 @@ while (levn<=nlev) fr=fr+1 'set string 1 l 6' 'set strsiz 0.15 0.15' - 'draw string 0.2 10.80 platform: 'plotfile - 'draw string 0.2 10.55 region : 'area - 'draw string 0.2 10.30 variable: 'type - 'draw string 0.2 10.05 valid : 'date1' to 'date2 - outfile=plotfile'.'field'_region'region'_fr'fr'.png' + 'draw string 0.2 10.80 Net,run : 'net', 'run + 'draw string 0.2 10.55 platform: 'plotfile + 'draw string 0.2 10.30 region : 'area + 'draw string 0.2 10.05 variable: 'type + 'draw string 0.2 9.80 valid : 'date1' to 'date2 + outfile=plotfile'.ges.'field'_region'region'_fr'fr'.png' 'printim 'outfile' 'xsize' 'ysize' white' * say 'output to file 'outfile if (debug=1) diff --git a/util/Ozone_Monitor/image_gen/gscripts/plot_time_ges_2x.gs b/util/Ozone_Monitor/image_gen/gscripts/plot_time_ges_2x.gs new file mode 100755 index 000000000..f4febe921 --- /dev/null +++ b/util/Ozone_Monitor/image_gen/gscripts/plot_time_ges_2x.gs @@ -0,0 +1,392 @@ +* Script to plot given bias correction term for given satellite instrument +* +* Expected arguments: +* net = $NET value, or the identifying data source (e.g. GFS|fv3rt1) +* run = $RUN value, typically gfs|gdas +* plotfile1 = satellite id (name and number ... e.g., msu.014 = noaa-14 msu) +* plotfile2 = satellite id (name and number ... e.g., msu.014 = noaa-14 msu) +* field = field to plot (valid strings are: cnt total fixang lapse lapse2 const scangl clw +* xsize = horiz size of plotted image +* ysize = vert size of plotted image + +*'reinit' +function plottime (args) + +net=subwrd(args,1) +run=subwrd(args,2) +plotfile1=subwrd(args,3) +plotfile2=subwrd(args,4) +field=subwrd(args,5) +xsize=subwrd(args,6) +ysize=subwrd(args,7) +*platform1=plotfile1 +*platform2=plotfile2 + +say 'process 'field' from 'plotfile1 +say 'process 'field' from 'plotfile2 +* 'open 'plotfile1'.ges.ctl' +* 'open 'plotfile2'.ges.ctl' + +debug=0 + +'q file' +lin1=sublin(result,1) +satnam=subwrd(lin1,4) +satnum=subwrd(lin1,5) +nlev=subwrd(lin1,6) + +if (field = cnt) + type="number of observations" +endif +if (field = omg ) + type="obs-ges" +endif +if (field = cpen ) + type="contribution to penalty" +endif + +* Determine number of levels and regions +'q file' +lin1=sublin(result,1) +nlev=subwrd(lin1,6) +lin5=sublin(result,5) +nregion=subwrd(lin5,6) + + +*say 'nlev='nlev +*say 'nregion='nregion + +* Set time +'set t 1 last' +'query time' +date1=subwrd(result,3) +date2=subwrd(result,5) + +*say 'date1='date1 +*say 'date2='date2 + +region=1 +while (region<=nregion) + +*say 'top of region loop with region='region + +'!rm -f area.txt' +'!cat 'plotfile1'.ges.ctl |grep "region= 'region' " > area.txt' +result=read(area.txt) +rc=sublin(result,1) +area="uknown" +if (rc = 0) + info=sublin(result,2) + area=substr(info,14,60) +endif +result=close(area.txt) +*say 'area = 'area + + +'clear' +'set grads off' +'set y 'region + +'set string 1 l 5' +'set strsiz 0.11 0.11' +'set xlopts 1 4 0.11' +'set ylopts 1 2 0.09' + +fr=0 +i=1 +levn=1 +while (levn<=nlev) +* say 'top of level loop with levn= 'levn +* +*----------------------------------------------------- +* Note: here avg and sdv are being (mis)used in +* the cases of cnt and cpen. They are not avg +* and sdv values, but someone was being cute and +* rather than add another if( ) case, decided all +* cases could use avg and sdv when actually +* plotting. That, predictably, took a while to +* understand. I'd fix it but ultimately I'm +* going to do away with GrADS plots in favour of +* using javascript to make things on-the-fly. +* So for now think of this note as a sort of +* +* "Warning: Logical Minefield" +* +*----------------------------------------------------- + 'set x 'levn + if (field != "cnt" & field != "cpen") + 'define avg1=avg'field'.1' + 'define sdv1=sdv'field'.1' + 'define avg2=avg'field'.2' + 'define sdv2=sdv'field'.2' + endif + if (field = "cnt" | field = "cpen") + 'define avg1='field'.1' + 'define sdv1='field'.1' + 'define avg2='field'.2' + 'define sdv2='field'.2' + + + 'set gxout stat' + 'd avg1' + rec14=sublin(result,14) + avgsdv1=subwrd(rec14,2) + endif + levi=levn + if (i=1) + 'clear' + y1=7.65 + endif + if (i>1 & i<4) + y1=y1-2.45 + endif + if (i=4) + y1=y1-2.45 + endif + + 'set gxout stat' + 'd avg1' + rec7=sublin(result,7) + rec8=sublin(result,8) + rec11=sublin(result,11) + valvar1=subwrd(rec7,8) + minvar1=subwrd(rec8,4) + maxvar1=subwrd(rec8,5) + avgvar1=subwrd(rec11,2) + + 'set gxout stat' + 'd avg2' + rec7=sublin(result,7) + rec8=sublin(result,8) + rec11=sublin(result,11) + valvar2=subwrd(rec7,8) + minvar2=subwrd(rec8,4) + maxvar2=subwrd(rec8,5) + avgvar2=subwrd(rec11,2) + + minvar=minvar1 + if (minvar2 <= minvar) + minvar=minvar2 + endif +* say 'minvar1, minvar1, minvar = 'minvar1', 'minvar2', 'minvar + + maxvar=maxvar1 + if (maxvar2 >= maxvar) + maxvar=maxvar2 + endif +* say 'maxvar1, maxvar1, maxvar = 'maxvar1', 'maxvar2', 'maxvar + + say 'avg1'field' min,max,avg1='minvar1','maxvar1','avgvar1','valvar1 + + if (field != "cnt" & field != "cpen") + 'set gxout stat' + 'd sdv1' + rec7=sublin(result,7) + rec8=sublin(result,8) + rec11=sublin(result,11) + valsdv1=subwrd(rec7,8) + minsdv1=subwrd(rec8,4) + maxsdv1=subwrd(rec8,5) + avgsdv1=subwrd(rec11,2) + + 'set gxout stat' + 'd sdv2' + rec7=sublin(result,7) + rec8=sublin(result,8) + rec11=sublin(result,11) + valsdv2=subwrd(rec7,8) + minsdv2=subwrd(rec8,4) + maxsdv2=subwrd(rec8,5) + avgsdv2=subwrd(rec11,2) + + minsdv=minsdv1 + if (minsdv2 <= minsdv) + minsdv=minsdv2 + endif + + maxsdv=maxsdv1 + if (maxsdv2 >= maxsdv) + maxsdv=maxsdv2 + endif +* say 'sdv'var' min,max,avg1='minsdv','maxsdv','avgsdv + endif + + if (field = "cnt" | field = "cpen") + minsdv=minvar + maxsdv=maxvar +* valsdv=valvar1 + endif + + '!rm -f info.txt' + '!cat 'plotfile1'.ges.ctl |grep "'levn', level" > info.txt' + result=read(info.txt) + rc=sublin(result,1) + iuse=0 + if (rc = 0) + info=sublin(result,2) + level=subwrd(info,5) + iuse=subwrd(info,8) + error=subwrd(info,11) + endif + result=close(info.txt) +* say 'level,iuse,error = 'level', 'iuse', 'error' + + 'set strsiz 0.12 0.12' + 'set string 1 l 6' + if ( level > 0.0 ) + 'draw string 0.1 'y1+1.5' pressure 'level + endif + + if ( level = 0.0 ) + 'draw string 0.1 'y1+1.5' pressure total' + endif + + 'set string 1 l 6' + + 'draw string 0.1 'y1+1.3' level 'levn + 'set string 4 l 6' + 'draw string 0.1 'y1+1.1' avg: 'digs(avgvar1,14) +* 'set string 2 l 6' + 'draw string 0.1 'y1+0.9' sdv: 'digs(avgsdv1,14) + + if (iuse<=0) + 'set string 9 l 6' + 'draw string 0.1 'y1+0.5' ** IS NOT **' + 'set string 3 l 6' + 'draw string 0.1 'y1+0.3' ASSIMILATED' + endif + + 'set parea 2.1 7.8 'y1' 'y1+1.2 + 'set grads off' + 'set tlsupp year' + 'set ylpos 0 r' + yrange=maxvar-minvar + dy=0.2*yrange + ymin=minvar-dy + ymax=maxvar+dy + yrange=ymax-ymin + 'set gxout line' + 'set vrange 'ymin' 'ymax +* say 'minvar, dy, maxvar, yrange,ymin,ymax = 'minvar','dy','maxvar','yrange','ymin','ymax + + + if (field != "cnt" & field != "cpen") + aymin=ymin + if(ymin <0) + aymin=-ymin + endif + if( aymin >0.0001) + 'set ylab %.4f' + endif + dy=0.2*yrange + 'set ylint 'dy + +* 'set yaxis 'ymin' 'ymax +* 'set ylab %.4f' +* yr=(ymax-ymin)/2 +* ymid=ymin+yr +* ym1=ymin+yr*0.5 +* ym2=ymid+yr*0.5 +* say ' ymid='ymid +* say ' ym1='ym1 +* say ' ym2='ym2 +* 'set ylevs 'ymin' 'ym1' 'ymid' 'ym2' 'ymax + endif + 'set ccolor 4' + 'set cmark 1' + 'd avg1' + 'set ccolor 2' + 'set cmark 1' + 'd avg2' + 'set parea off' + + if (field != "cnt" & field != "cpen") + 'set parea 2.1 7.8 'y1+1.25' 'y1+2.1 + 'set grads off' + 'set tlsupp year' + 'set tlsupp month' + 'set timelab off' + 'set ylpos 0 r' + yrange=maxsdv-minsdv + dy=0.1*yrange + ymin=minsdv-dy + ymax=maxsdv+dy + yrange=ymax-ymin + + 'set gxout line' + 'set vrange 'ymin' 'ymax +* 'set yaxis 'ymin' 'ymax + if( ymin >0.0001) + 'set ylab %.4f' + endif + +* yr=(ymax-ymin)/2 +* ymid=ymin+yr +* ym1=ymin+yr*0.5 +* ym2=ymid+yr*0.5 +* say ' ymid='ymid +* say ' ym1='ym1 +* say ' ym2='ym2 +* 'set ylevs 'ymin' 'ym1' 'ymid' 'ym2' 'ymax + + ymid=0.2*yrange + 'set ylint 'ymid + + 'set ccolor 4' + 'set cmark 1' + 'd sdv1' + 'set ccolor 2' + 'set cmark 1' + 'd sdv2' + + 'set parea off' + endif + + i=i+1 + if (i=5 | levn=nlev) + fr=fr+1 + 'set string 1 l 6' + 'set strsiz 0.15 0.15' + 'draw string 0.2 10.80 Net,run : 'net', 'run + + 'draw string 0.2 10.55 platform: ' + 'set string 4 l 6' + 'draw string 1.5 10.55 'plotfile1 + 'set string 2 l 6' + 'draw string 3.5 10.55 'plotfile2 + + 'set string 1 l 6' + 'draw string 0.2 10.30 region : 'area + 'draw string 0.2 10.05 variable : 'type + 'draw string 0.2 9.80 valid : 'date1' to 'date2 + outfile=plotfile1'.ges.'field'_region'region'_fr'fr'.png' + 'printim 'outfile' 'xsize' 'ysize' white' + +* say 'output to file 'outfile + if (debug=1) + say 'press any key to continue' + pull var + endif + i=1 + endif + levn=levn+1 +endwhile + +region=region+1 +endwhile + +return +endfile + +function digs(string,num) + nc=0 + pt="" + while(pt = "") + nc=nc+1 + zzz=substr(string,nc,1) + if(zzz = "." | zzz = ""); break; endif + endwhile + end=nc+num + str=substr(string,1,end) +return str + diff --git a/util/Ozone_Monitor/image_gen/ush/OznMon_Plt.sh b/util/Ozone_Monitor/image_gen/ush/OznMon_Plt.sh index 9e216f569..4b0bbec70 100755 --- a/util/Ozone_Monitor/image_gen/ush/OznMon_Plt.sh +++ b/util/Ozone_Monitor/image_gen/ush/OznMon_Plt.sh @@ -1,18 +1,44 @@ -#!/bin/sh +#!/bin/sh -l + +#----------------------------------------------------------------------- +# OznMon_Plt.sh +# +# Main plot script for OznMon. +# +# Usage: +# +# OznMon_Plt.sh OZNMON_SUFFIX [-p|pdate yyyymmddcc] [-r|run gdas|gfs] +# +# OZNMON_SUFFIX = data source identifier which matches data +# in the TANKverf/stats directory. +# -p --pdate = specified cycle to plot. If not specified the +# last available date will be plotted. +# -r --run = $RUN value, gdas|gfs, default is gdas. +# -c1|--comp1 = define first source to plot as comparison (time +# series plots only) +# -c2|--comp2 = define second source to plot as comparison (time +# series plots only) +# +# NOTE: Both COMP1 and COMP2 have to be defined to +# generate comparison plots as part of the COMP1 +# source's time plots. +#----------------------------------------------------------------------- function usage { echo " " echo "Usage: OznMon_Plt.sh OZNMON_SUFFIX " - echo " OZNMON_SUFFIX is data source identifier that matches data in " + echo " OZNMON_SUFFIX is data source identifier which matches data in " echo " the $TANKverf/stats directory." - echo " -p | -pdate yyyymmddcc to specify the cycle to be plotted" - echo " if unspecified the last available date will be plotted" - echo " -r | -run the gdas|gfs run to be plotted" - echo " use only if data in TANKdir stores both runs" + echo " -p | --pdate yyyymmddcc to specify the cycle to be plotted." + echo " If unspecified the last available date will be plotted." + echo " -r | --run the gdas|gfs run to be plotted, gdas is default" + echo " -c1| --comp1 first instrument/sat source to plotted as a comparision" + echo " -c2| --comp2 first instrument/sat source to plotted as a comparision" echo " " } echo start OznMon_Plt.sh +set -ax nargs=$# echo nargs = $nargs @@ -33,6 +59,14 @@ do export RUN="$2" shift # past argument ;; + -c1|--comp1) + export COMP1="$2" + shift # past argument + ;; + -c2|--comp2) + export COMP2="$2" + shift # past argument + ;; *) #any unspecified key is OZNMON_SUFFIX export OZNMON_SUFFIX=$key @@ -42,7 +76,7 @@ do shift done -if [[ $nargs -lt 0 || $nargs -gt 5 ]]; then +if [[ $nargs -lt 0 || $nargs -gt 9 ]]; then usage exit 1 fi @@ -66,7 +100,10 @@ echo "PDATE = $PDATE" echo "RUN = $RUN" -set -ax +export DO_COMP=0 +if [[ ${#COMP1} > 0 && ${#COMP2} > 0 ]]; then + export DO_COMP=1 +fi this_file=`basename $0` @@ -152,7 +189,7 @@ export cyc=`echo $PDATE|cut -c9-10` #-------------------------------------------------------------------- # Create the WORKDIR and link the data files to it #-------------------------------------------------------------------- -WORKDIR=${STMP_USER}/ozn.${OZNMON_SUFFIX}.IG.${PDY}.${cyc} +export WORKDIR=${STMP_USER}/${OZNMON_SUFFIX}/${RUN}/oznmon/IG.${PDY}.${cyc} if [[ -d $WORKDIR ]]; then rm -rf $WORKDIR fi @@ -175,14 +212,24 @@ cd $WORKDIR # gdas.v2.0.0/fix/gdas_oznmon_satype.txt file. Eventually DE will # need to compare actual files vs this list (or an updated one in # TANKDIR/info like RadMon. +# +# Update the search order to use the local copy in $TANKDIR/info +# if available. #-------------------------------------------------------------------- -export SATYPE=`cat ${HOMEgdas_ozn}/fix/gdas_oznmon_satype.txt` +if [[ -e ${TANKDIR}/info/gdas_oznmon_satype.txt ]]; then + export SATYPE=${SATYPE:-`cat ${TANKDIR}/info/${RUN}_oznmon_satype.txt`} +else + export SATYPE=${SATYPE:-`cat ${HOMEgdas_ozn}/fix/${RUN}_oznmon_satype.txt`} +fi ${OZN_IG_SCRIPTS}/mk_horiz.sh ${OZN_IG_SCRIPTS}/mk_time.sh ${OZN_IG_SCRIPTS}/mk_summary.sh +if [[ $DO_DATA_RPT -eq 1 ]]; then + ${OZN_IG_SCRIPTS}/mk_err_rpt.sh +fi echo "end OznMon_Plt.sh" exit diff --git a/util/Ozone_Monitor/image_gen/ush/OznMon_Transfer.sh b/util/Ozone_Monitor/image_gen/ush/OznMon_Transfer.sh index e89133310..22eecc2f4 100755 --- a/util/Ozone_Monitor/image_gen/ush/OznMon_Transfer.sh +++ b/util/Ozone_Monitor/image_gen/ush/OznMon_Transfer.sh @@ -16,6 +16,7 @@ function usage { } echo start OznMon_Transfer.sh +set -ax nargs=$# @@ -46,7 +47,6 @@ fi echo "OZNMON_SUFFIX, RUN = $OZNMON_SUFFIX, $RUN" -set -ax #-------------------------------------------------------------------- # Check for my monitoring use. Abort if running on prod machine. @@ -112,15 +112,19 @@ fi transfer_script=${OZN_IG_SCRIPTS}/transfer.sh job=${OZNMON_SUFFIX}_ozn_transfer -if [[ $MY_MACHINE = "ibm" ]]; then +if [[ $MY_MACHINE = "wcoss" || $MY_MACHINE = "wcoss_d" ]]; then + + job_queue="transfer" + if [[ $MY_MACHINE = "wcoss_d" ]]; then + job_queue="dev_transfer" + fi - JOB_QUEUE="transfer" echo "PROJECT = $PROJECT" echo "logf = $logf" echo "errf = $errf" echo "transfer_script = $transfer_script" - $SUB -P $PROJECT -q $JOB_QUEUE -o ${logf} -e ${errf} -M 50 -W 0:20 \ + $SUB -P $PROJECT -q $job_queue -o ${logf} -e ${errf} -M 50 -W 0:20 \ -R affinity[core] -J ${job} -cwd ${OZN_IG_SCRIPTS} \ ${transfer_script} diff --git a/util/Ozone_Monitor/image_gen/ush/data_map.xml b/util/Ozone_Monitor/image_gen/ush/data_map.xml new file mode 100644 index 000000000..b63102d77 --- /dev/null +++ b/util/Ozone_Monitor/image_gen/ush/data_map.xml @@ -0,0 +1,15 @@ + + + + glb + /com/gfs/prod + + + /u/${LOGNAME}/nbns/stats + 1 + + + glb + 2019091106 + + diff --git a/util/Ozone_Monitor/image_gen/ush/find_cycle.pl b/util/Ozone_Monitor/image_gen/ush/find_cycle.pl new file mode 120000 index 000000000..c254910ac --- /dev/null +++ b/util/Ozone_Monitor/image_gen/ush/find_cycle.pl @@ -0,0 +1 @@ +../../data_xtrct/ush/find_cycle.pl \ No newline at end of file diff --git a/util/Ozone_Monitor/image_gen/ush/mk_err_rpt.sh b/util/Ozone_Monitor/image_gen/ush/mk_err_rpt.sh new file mode 100755 index 000000000..de8f8d8eb --- /dev/null +++ b/util/Ozone_Monitor/image_gen/ush/mk_err_rpt.sh @@ -0,0 +1,364 @@ +#! /bin/bash + +#----------------------------------------------------------------- +# +# mk_err_rpt.sh +# +# Put together the 3 possible elements of an error report for +# a given cycle and mail to the recipient list. +# +#----------------------------------------------------------------- + + +function usage { + echo " " + echo "Usage: mk_err_rpt.sh OZNMON_SUFFIX -p|--pdate yyyymmddcc -r|--run gdas|gfs" + echo " OZNMON_SUFFIX is data source identifier that matches data in " + echo " the $TANKverf/stats directory." + echo " -p | --pdate yyyymmddcc to specify the cycle to be plotted" + echo " if unspecified the last available date will be plotted" + echo " -r | --run the gdas|gfs run to be plotted" + echo " " +} + +set -ax + +echo start mk_err_rpt.sh +err=0 + +#------------------------------------------------------- +# set standalone=1 to run from the command line instead +# of from OznMon_Plot.sh +# +standalone=0 + + +if [[ "$standalone" -eq 1 ]]; then + nargs=$# + echo "args = $nargs" + + if [[ $nargs -ne 5 ]]; then + usage + exit 1 + fi + + + while [[ $# -ge 1 ]]; do + key="$1" + echo $key + + case $key in + -p|--pdate) + PDATE="$2" + shift # past argument + ;; + -r|--run) + export RUN="$2" + shift # past argument + ;; + *) + #any unspecified key is OZNMON_SUFFIX + export OZNMON_SUFFIX=$key + ;; + esac + + shift + done +fi + +echo "OZNMON_SUFFIX = $OZNMON_SUFFIX" +echo "PDATE = $PDATE" +echo "RUN = $RUN" +PDY=`echo $PDATE | cut -c1-8` +cyc=`echo $PDATE | cut -c9-10` + +hyperlink_base="http://www.emc.ncep.noaa.gov/gmb/gdas/es_ozn/index.html?" + + + +if [[ "$standalone" -eq 1 ]]; then + #-------------------------------------------------- + # source verison, config, and user_settings files + #-------------------------------------------------- + this_dir=`dirname $0` + top_parm=${this_dir}/../../parm + + + oznmon_version_file=${oznmon_version:-${top_parm}/OznMon.ver} + if [[ -s ${oznmon_version_file} ]]; then + . ${oznmon_version_file} + echo "able to source ${oznmon_version_file}" + else + echo "Unable to source ${oznmon_version_file} file" + exit 2 + fi + + oznmon_user_settings=${oznmon_user_settings:-${top_parm}/OznMon_user_settings} + if [[ -s ${oznmon_user_settings} ]]; then + . ${oznmon_user_settings} + echo "able to source ${oznmon_user_settings}" + else + echo "Unable to source ${oznmon_user_settings} file" + exit 4 + fi + + oznmon_config=${oznmon_config:-${top_parm}/OznMon_config} + if [[ -s ${oznmon_config} ]]; then + . ${oznmon_config} + echo "able to source ${oznmon_config}" + else + echo "Unable to source ${oznmon_config} file" + exit 3 + fi + +fi + + +#-------------------------------------------------------------------- +# Specify TANKDIR for this suffix +#-------------------------------------------------------------------- +if [[ $GLB_AREA -eq 1 ]]; then + TANKDIR=${OZN_TANKDIR}/stats/${OZNMON_SUFFIX} +else + TANKDIR=${OZN_TANKDIR}/stats/regional/${OZNMON_SUFFIX} +fi + + +OZN_TANKDIR_TIME=${TANKDIR}/${RUN}.${PDY}/${cyc}/oznmon/time +echo "OZN_TANKDIR_TIME = $OZN_TANKDIR_TIME" + + +bad_cnt=`ls $OZN_TANKDIR_TIME/bad_cnt.${PDATE}` +bad_diag=`ls $OZN_TANKDIR_TIME/bad_diag.${PDATE}` +bad_pen=`ls $OZN_TANKDIR_TIME/bad_pen.${PDATE}` + +echo "bad_cnt = $bad_cnt" +echo "bad_diag = $bad_diag" +echo "bad_pen = $bad_pen" + +prev_cycle=`$NDATE -6 $PDATE` +prev_pdy=`echo $prev_cycle | cut -c1-8` +prev_cyc=`echo $prev_cycle | cut -c9-10` + +OZN_TANKDIR_PREV=${TANKDIR}/${RUN}.${prev_pdy}/${prev_cyc}/oznmon/time +echo "OZN_TANKDIR_PREV = $OZN_TANKDIR_PREV" + +prev_bad_cnt=`ls $OZN_TANKDIR_PREV/bad_cnt.${prev_cycle}` +prev_bad_pen=`ls $OZN_TANKDIR_PREV/bad_pen.${prev_cycle}` + +echo "prev_bad_cnt = $prev_bad_cnt" +echo "prev_bad_pen = $prev_bad_pen" + +have_err_rpt=0 + +if [[ -s $bad_cnt || -s $bad_diag || -s $bad_pen ]]; then + + echo "Making error report" + err_rpt="err_rpt.txt" + + echo "Net, Run = $OZNMON_SUFFIX, $RUN" > $err_rpt + echo "Cycle Data Integrity Report $PDATE" >> $err_rpt + echo " " >> $err_rpt + echo " " >> $err_rpt + echo " Region Definitions:" >> $err_rpt + echo " " >> $err_rpt + echo " 1, Global (90S-90N, 0-360E)" >> $err_rpt + echo " " >> $err_rpt + + if [[ -s ${bad_diag} ]]; then + have_err_rpt=1 + diag_files=`cat ${bad_diag}` + echo " Missing diagnostic files:" >> $err_rpt + + for word in ${diag_files}; do + echo " word = ${word}" + if [[ $word =~ .*${PDATE}*. ]]; then + echo " ${word} " >> $err_rpt + fi + done + + echo " " >> $err_rpt + fi + + + #----------------------------------------------------- + # Process the bad_cnt file contents. + # + # Report any bad_cnt results that are in both this + # cycle's results and the previous cycle's results. + # + # + if [[ -s ${bad_cnt} && -s ${prev_bad_cnt} ]]; then + added_hdr=0 + hdr=" Sat/Instrument levels with low observational counts:" + + #----------------------------------------------- + # 1. read the bad_cnt file line by line, + # 2. cut the line on '=' and keep the first 3 + # fields (sat, level, region). + # + # NOTE: setting IFS (Internal Field Separator) to + # something other than ' ' preserves white space, + # and allows the grep to work correctly. + # + # 3. grep on that substring in the previous + # cycle's bad_cnt file. + # 4. if grep matches then report a bad cnt for + # for the 2 cycle periods + # 5. add a hyperlink for report + # + cat ${bad_cnt} | while read LINE; do + IFS='%' + substr=$(echo $LINE | cut -d'=' -f 1-3) + echo "substr = $substr" + + test=`grep "$substr" $prev_bad_cnt` + echo "test,len = $test, ${#test}" + + remains=`echo $test | gawk '{printf "%s %s %s %s", $5, $6, $7, $8}'` + echo "remains = $remains" + + #------------------------------------------------ + # Pull sat and lev for hyperlink construction. + # Only concerned (for now) with region 1 (global) + # + sat=`echo $test | gawk '{print $1}' | xargs` + lev=`echo $test | gawk '{print $3}'` + reg=1 + stat="obs" + + link="${hyperlink_base}sat=${sat}" + link="${link}&level=${lev}" + link="${link}®ion=${reg}" + link="${link}&stat=${stat}" + link="${link}&src=${OZNMON_SUFFIX}/${RUN}" + +# echo "link = $link" + + if [[ ${#test} -gt 0 ]]; then + + if [[ "$added_hdr" -eq 0 ]]; then + echo "$hdr" >> $err_rpt + added_hdr=1 + fi + + echo " $LINE" >> $err_rpt + echo " previous cycle: $remains" >> $err_rpt + echo " $link" >> $err_rpt + + fi + done + + #---------------------------------------------------------------------- + # learned the hard way, assiging $have_err_rpt inside the while loop + # fails because bash implements while loops as subshells and the + # assignment is out of scope upon return. + # + added_cnt=`cat $err_rpt | grep "$hdr"` + if [[ ${#added_cnt} -gt 0 ]]; then + have_err_rpt=1 + echo " " >> $err_rpt + fi + + fi + + + #----------------------------------------------------- + # Process the bad_pen file contents. + # + # Report any bad_pen results that are in both this + # cycle's results and the previous cycle's results. + # + if [[ -s ${bad_pen} && -s ${prev_bad_pen} ]]; then + added_hdr=0 + hdr=" Sat/Instrument levels with high penalty values:" + + #--------------------------------------------------------- + # Algorithm is the same as for the bad_cnt above. + # + # NOTE: setting IFS (Internal Field Separator) to + # something other than ' ' preserves white space and + # allows the grep to work correctly. + # + cat ${bad_pen} | while read LINE; do + IFS='%' + substr=$(echo $LINE | cut -d'=' -f 1-3) + echo "substr = $substr" + + test=`grep "$substr" $prev_bad_pen` + echo "test,len = $test, ${#test}" + + remains=`echo $test | gawk '{printf "%s %s %s %s", $5, $6, $7, $8}'` + echo "remains = $remains" + + #------------------------------------------------ + # Pull sat and lev for hyperlink construction. + # Only concerned (for now) with region 1 (global) + # + sat=`echo $test | gawk '{print $1}' | xargs` + lev=`echo $test | gawk '{print $3}'` + reg=1 + stat="pen" + + link="${hyperlink_base}sat=${sat}" + link="${link}&level=${lev}" + link="${link}®ion=${reg}" + link="${link}&stat=${stat}" + link="${link}&src=${OZNMON_SUFFIX}/${RUN}" + + if [[ ${#test} -gt 0 ]]; then + + if [[ "$added_hdr" -eq 0 ]]; then + echo "$hdr" >> $err_rpt + added_hdr=1 + fi + + echo " $LINE" >> $err_rpt + echo " previous cycle: $remains" >> $err_rpt + echo " $link" >> $err_rpt + fi + done + + #---------------------------------------------------------------------- + # learned the hard way, assiging $have_err_rpt inside the while loop + # fails because bash implements while loops as subshells and the + # assignment is out of scope upon return. + # + added_pen=`cat $err_rpt | grep "$hdr"` + if [[ ${#added_pen} -gt 0 ]]; then + have_err_rpt=1 + echo " " >> $err_rpt + fi + + fi + + if [[ "$have_err_rpt" -gt 0 ]]; then + + echo " " >> $err_rpt + echo " " >> $err_rpt + + echo " *********************** WARNING ***************************" >> $err_rpt + echo " " >> $err_rpt + echo " This is an automated email. Replies to sender " >> $err_rpt + echo " will not be received. Please direct replies to:" >> $err_rpt + echo " " >> $err_rpt + echo " edward.safford@noaa.gov" >> $err_rpt + echo " " >> $err_rpt + echo " *********************** WARNING ***************************" >> $err_rpt + + #---------------------------------------------------------------- + # Now mail it! + # + if [[ ${#MAIL_CC} -gt 1 ]]; then + mail -s "OznMon Error Report" -c "${MAIL_CC}" ${MAIL_TO} < ${err_rpt} + else + mail -s "OznMon Error Report" ${MAIL_TO} < ${err_rpt} + fi + + fi + +fi + +echo end mk_err_rpt.sh + +#exit( $err ) diff --git a/util/Ozone_Monitor/image_gen/ush/mk_horiz.sh b/util/Ozone_Monitor/image_gen/ush/mk_horiz.sh index 98f89bd3b..9a23c4a38 100755 --- a/util/Ozone_Monitor/image_gen/ush/mk_horiz.sh +++ b/util/Ozone_Monitor/image_gen/ush/mk_horiz.sh @@ -1,4 +1,4 @@ -#!/bin/ksh +#!/bin/ksh -l #------------------------------------------------------------------ # mk_horiz.sh @@ -11,7 +11,6 @@ echo "begin mk_horiz.sh" set -ax - echo "GRADS = $GRADS" echo "STNMAP = $STNMAP" @@ -39,54 +38,74 @@ fi # suffix=a -cmdfile=cmdfile_phoriz -rm -f $cmdfile +data_source="ges anl" +for dsrc in ${data_source}; do + cmdfile=cmdfile_${dsrc}_phoriz + rm -f $cmdfile >$cmdfile -for type in ${SATYPE}; do -# if [[ $type == 'omi_aura' || $type == 'gome_metop-a' ]] ; then -# list="obs ges obsges sza fovn" -# else - list="obs ges obsges" -# fi - echo "${OZN_IG_SCRIPTS}/plot_horiz.sh $type $suffix '$list'" >> $cmdfile -done -chmod a+x $cmdfile -job=${OZNMON_SUFFIX}_ozn_phoriz -o_logfile=${OZN_LOGdir}/plot_horiz.${PDATE} + ctr=0 + for type in ${SATYPE}; do -logf=${OZN_LOGdir}/IG.${PDY}.${cyc}.horiz.log -errf=${OZN_LOGdir}/IG.${PDY}.${cyc}.horiz.err + if [[ ${dsrc} = "ges" ]]; then + list="obs ges obsges" + else + list="obs anl obsanl" + fi -if [[ -e $logf ]]; then - rm -f $logf -fi + if [[ ${MY_MACHINE} = "hera" ]]; then + echo "$ctr ${OZN_IG_SCRIPTS}/plot_horiz.sh $type $suffix '$list' $dsrc" >> $cmdfile + else + echo "${OZN_IG_SCRIPTS}/plot_horiz.sh $type $suffix '$list' $dsrc" >> $cmdfile + fi + ((ctr=ctr+1)) + done -if [[ -e $errf ]]; then - rm -f $errf -fi + chmod a+x $cmdfile + + job=${OZNMON_SUFFIX}_ozn_${dsrc}_phoriz + o_logfile=${OZN_LOGdir}/plot_horiz.${dsrc}.${PDATE} + + logf=${OZN_LOGdir}/IG.${PDY}.${cyc}.${dsrc}.horiz.log + if [[ -e $logf ]]; then + rm -f $logf + fi + errf=${OZN_LOGdir}/IG.${PDY}.${cyc}.${dsrc}.horiz.err + if [[ -e $errf ]]; then + rm -f $errf + fi -if [[ ${MY_MACHINE} = "ibm" ]]; then - $SUB -q ${JOB_QUEUE} -P ${PROJECT} -M 50 -R affinity[core] \ - -o ${logf} -e ${errf} -W 0:05 -J ${job} -cwd ${WORKDIR} ${WORKDIR}/${cmdfile} + if [[ ${MY_MACHINE} = "wcoss" ]]; then -elif [[ ${MY_MACHINE} = "theia" ]]; then + $SUB -q ${JOB_QUEUE} -P ${PROJECT} -M 50 -R affinity[core] \ + -o ${logf} -e ${errf} -W 0:05 -J ${job} -cwd ${WORKDIR} \ + ${WORKDIR}/${cmdfile} - $SUB -A ${ACCOUNT} -l procs=1,walltime=0:05:00 -N ${job} -V \ - -o ${logf} -e ${errf} ${cmdfile} + elif [[ ${MY_MACHINE} = "hera" ]]; then -elif [[ ${MY_MACHINE} = "cray" ]]; then + $SUB --account ${ACCOUNT} -n $ctr -o ${logf} -D . -J ${job} \ + --time=10 --wrap "srun -l --multi-prog ${cmdfile}" - $SUB -q ${JOB_QUEUE} -P ${PROJECT} -o ${logf} -e ${errf} \ + elif [[ ${MY_MACHINE} = "cray" ]]; then + + $SUB -q ${JOB_QUEUE} -P ${PROJECT} -o ${logf} -e ${errf} \ -R "select[mem>100] rusage[mem=100]" \ -M 100 -W 0:05 -J ${job} -cwd ${WORKDIR} ${WORKDIR}/${cmdfile} -fi + elif [[ ${MY_MACHINE} = "wcoss_d" ]]; then + + $SUB -q ${JOB_QUEUE} -P ${PROJECT} -M 50 -R affinity[core] \ + -o ${logf} -e ${errf} -W 0:05 -J ${job} -cwd ${WORKDIR} \ + ${WORKDIR}/${cmdfile} + + + fi +done echo "end mk_horiz.sh" exit diff --git a/util/Ozone_Monitor/image_gen/ush/mk_summary.sh b/util/Ozone_Monitor/image_gen/ush/mk_summary.sh index 36df390f5..c400504d0 100755 --- a/util/Ozone_Monitor/image_gen/ush/mk_summary.sh +++ b/util/Ozone_Monitor/image_gen/ush/mk_summary.sh @@ -1,4 +1,4 @@ -#!/bin/ksh +#!/bin/ksh -l #------------------------------------------------------------------ # mk_summary.sh @@ -11,7 +11,7 @@ echo "begin mk_summary.sh" set -ax -export string=ges +export process_type="ges anl" #------------------------------------------------------------------ @@ -36,56 +36,74 @@ fi # Loop over sat types and create entry in cmdfile for each. # -if [[ ${string} = "ges" ]]; then +for ptype in ${process_type}; do + + if [[ ${ptype} = "ges" ]]; then + list="count omg cpen" + else + list="count oma cpen" + fi suffix=a - list="count omg cpen" - cmdfile=cmdfile_psummary + cmdfile=cmdfile_${ptype}_psummary rm -f $cmdfile + ctr=0 >$cmdfile for type in ${SATYPE}; do if [[ $type != "omi_aura" && $type != "gome_metop-a" && $type != "gome_metop-b" ]]; then - echo "${OZN_IG_SCRIPTS}/plot_summary.sh $type" >> $cmdfile + if [[ ${MY_MACHINE} = "hera" ]]; then + echo "${ctr} ${OZN_IG_SCRIPTS}/plot_summary.sh $type $ptype" >> $cmdfile + else + echo "${OZN_IG_SCRIPTS}/plot_summary.sh $type $ptype" >> $cmdfile + fi + ((ctr=ctr+1)) fi done chmod a+x $cmdfile - job=${OZNMON_SUFFIX}_ozn_psummary - o_logfile=${OZN_LOGdir}/plot_summary.${PDATE} + job=${OZNMON_SUFFIX}_ozn_${ptype}_psummary + o_logfile=${OZN_LOGdir}/plot_summary.${ptype}.${PDATE} if [[ -e ${o_logfile} ]]; then rm -f ${o_logfile} fi - logf=${OZN_LOGdir}/IG.${PDY}.${cyc}.summary.log + logf=${OZN_LOGdir}/IG.${PDY}.${cyc}.${ptype}.summary.log if [[ -e $logf ]]; then rm -f $logf fi - errf=${OZN_LOGdir}/IG.${PDY}.${cyc}.summary.err + errf=${OZN_LOGdir}/IG.${PDY}.${cyc}.${ptype}.summary.err if [[ -e $errf ]]; then rm -f $errf fi - if [[ ${MY_MACHINE} = "ibm" ]]; then + if [[ ${MY_MACHINE} = "wcoss" ]]; then $SUB -q ${JOB_QUEUE} -P ${PROJECT} -M 50 -R affinity[core] \ -o ${logf} -e ${errf} -W 0:05 -J ${job} -cwd ${WORKDIR} ${WORKDIR}/${cmdfile} - elif [[ ${MY_MACHINE} = "theia" ]]; then - - $SUB -A ${ACCOUNT} -l procs=1,walltime=0:05:00 -N ${job} -V \ - -o ${logf} -e ${errf} ${cmdfile} + elif [[ ${MY_MACHINE} = "hera" ]]; then + + $SUB --account ${ACCOUNT} -n $ctr -o ${logf} -D . -J ${job} --time=10 \ + --wrap "srun -l --multi-prog ${cmdfile}" elif [[ ${MY_MACHINE} = "cray" ]]; then $SUB -q ${JOB_QUEUE} -P ${PROJECT} -o ${logf} -e ${errf} \ -R "select[mem>100] rusage[mem=100]" \ -M 100 -W 0:05 -J ${job} -cwd ${WORKDIR} ${WORKDIR}/${cmdfile} + + elif [[ ${MY_MACHINE} = "wcoss_d" ]]; then + + $SUB -q ${JOB_QUEUE} -P ${PROJECT} -M 50 -R affinity[core] \ + -o ${logf} -e ${errf} -W 0:05 -J ${job} \ + -cwd ${WORKDIR} ${WORKDIR}/${cmdfile} + fi -fi +done echo "end mk_summary.sh" exit diff --git a/util/Ozone_Monitor/image_gen/ush/mk_time.sh b/util/Ozone_Monitor/image_gen/ush/mk_time.sh index 730ec1f2d..2b4bfdaf2 100755 --- a/util/Ozone_Monitor/image_gen/ush/mk_time.sh +++ b/util/Ozone_Monitor/image_gen/ush/mk_time.sh @@ -1,4 +1,4 @@ -#!/bin/ksh +#!/bin/ksh -l #------------------------------------------------------------------ # mk_time.sh @@ -11,7 +11,7 @@ echo "begin mk_time.sh" set -ax -export string="ges" +export data_source="ges anl" #------------------------------------------------------------------ @@ -36,47 +36,67 @@ fi #------------------------------------------------------------------ # Loop over sat types & create entry in cmdfile for each. # -suffix=a -list="count omg cpen" -cmdfile=cmdfile_ptime -rm -f $cmdfile +for dsrc in ${data_source}; do + suffix=a + if [[ $dsrc = "ges" ]]; then + list="cnt omg cpen" + else + list="cnt oma cpen" + fi + + cmdfile=cmdfile_${dsrc}_ptime + rm -f $cmdfile + ctr=0 >$cmdfile -for type in ${SATYPE}; do - echo "${OZN_IG_SCRIPTS}/plot_time.sh $type $suffix '$list'" >> $cmdfile -done -chmod a+x $cmdfile + for type in ${SATYPE}; do + if [[ ${MY_MACHINE} = "hera" ]]; then + echo "${ctr} ${OZN_IG_SCRIPTS}/plot_time.sh $type $suffix '$list' $dsrc" >> $cmdfile + ((ctr=ctr+1)) + else + echo "${OZN_IG_SCRIPTS}/plot_time.sh $type $suffix '$list' $dsrc" >> $cmdfile + fi + done + chmod a+x $cmdfile -job=${OZNMON_SUFFIX}_ozn_ptime + job=${OZNMON_SUFFIX}_ozn_${dsrc}_ptime -logf=${OZN_LOGdir}/IG.${PDY}.${cyc}.time.log -if [[ -e $logf ]]; then - rm -f $logf -fi + logf=${OZN_LOGdir}/IG.${PDY}.${cyc}.${dsrc}.time.log + if [[ -e $logf ]]; then + rm -f $logf + fi -errf=${OZN_LOGdir}/IG.${PDY}.${cyc}.time.err -if [[ -e $errf ]]; then - rm -f $errf -fi + errf=${OZN_LOGdir}/IG.${PDY}.${cyc}.${dsrc}.time.err + if [[ -e $errf ]]; then + rm -f $errf + fi -if [[ ${MY_MACHINE} = "ibm" ]]; then + if [[ ${MY_MACHINE} = "wcoss" ]]; then - $SUB -q ${JOB_QUEUE} -P ${PROJECT} -M 50 -R affinity[core] \ - -o ${logf} -e ${errf} -W 0:05 -J ${job} -cwd ${WORKDIR} ${WORKDIR}/${cmdfile} + $SUB -q ${JOB_QUEUE} -P ${PROJECT} -M 50 -R affinity[core] \ + -o ${logf} -e ${errf} -W 0:05 -J ${job} -cwd ${WORKDIR} ${WORKDIR}/${cmdfile} -elif [[ ${MY_MACHINE} = "theia" ]]; then + elif [[ ${MY_MACHINE} = "hera" ]]; then - $SUB -A ${ACCOUNT} -l procs=1,walltime=0:05:00 -N ${job} -V \ - -o ${logf} -e ${errf} ${cmdfile} + $SUB --account ${ACCOUNT} -n $ctr -o ${logf} -D . -J ${job} --time=10 \ + --wrap "srun -l --multi-prog ${cmdfile}" -elif [[ ${MY_MACHINE} = "cray" ]]; then + elif [[ ${MY_MACHINE} = "cray" ]]; then $SUB -q ${JOB_QUEUE} -P ${PROJECT} -o ${logf} -e ${errf} \ -R "select[mem>100] rusage[mem=100]" \ -M 100 -W 0:05 -J ${job} -cwd ${WORKDIR} ${WORKDIR}/${cmdfile} -fi + elif [[ ${MY_MACHINE} = "wcoss_d" ]]; then + + $SUB -q ${JOB_QUEUE} -P ${PROJECT} -M 50 -R affinity[core] \ + -o ${logf} -e ${errf} -W 0:05 -J ${job} -cwd ${WORKDIR} ${WORKDIR}/${cmdfile} + + fi + + +done echo "end mk_time.sh" exit diff --git a/util/Ozone_Monitor/image_gen/ush/plot_horiz.sh b/util/Ozone_Monitor/image_gen/ush/plot_horiz.sh index f1e8b0a6b..c812bdbc1 100755 --- a/util/Ozone_Monitor/image_gen/ush/plot_horiz.sh +++ b/util/Ozone_Monitor/image_gen/ush/plot_horiz.sh @@ -1,118 +1,93 @@ -#! /bin/ksh +#! /bin/ksh -l #------------------------------------------------------------------ # plot_horiz.sh # echo "begin plot_horiz.sh" - set -ax -export SATYPE2=$1 + +if [[ ${MY_MACHINE} = "hera" ]]; then + module load grads +fi + +export SATYPE=$1 export PVAR=$2 -export PTYPE=$3 -export string=ges +export PTYPE=$3 # plot type(s) +export dsrc=$4 # data source -- ges | anl -echo "SATYPE2, PVAR, PTYPE = $SATYPE2, $PVAR, $PTYPE" +echo "SATYPE, PVAR, PTYPE dsrc = $SATYPE, $PVAR, $PTYPE, $dsrc" echo "RUN = $RUN" #------------------------------------------------------------------ -# Set work space for this SATYPE2 source. +# Set work space for this SATYPE source. # -tmpdir=${WORKDIR}/${SATYPE2}.$PDATE.${PVAR} +tmpdir=${WORKDIR}/${SATYPE}.${dsrc}.$PDATE.${PVAR} rm -rf $tmpdir mkdir -p $tmpdir cd $tmpdir #------------------------------------------------------------------ -# Set dates +# Set dates and copy data +# +# 4 cycles worth of data are required for horiz plots. +# Start with PDATE and back up 3 times to get what we need. # -bdate=`$NDATE -18 $PDATE` -edate=$PDATE -bdate0=`echo $bdate|cut -c1-8` -edate0=`echo $edate|cut -c1-8` +ctr=0 +cdate=$PDATE + +while [[ $ctr -le 3 ]]; do + c_pdy=`echo $cdate|cut -c1-8` + c_cyc=`echo $cdate|cut -c9-10` + tankdir_cdate=${TANKDIR}/${RUN}.${c_pdy}/${c_cyc}/oznmon/horiz + $NCP ${tankdir_cdate}/${SATYPE}.${dsrc}.ctl ./ + $NCP ${tankdir_cdate}/${SATYPE}.${dsrc}.${c_pdy}* ./ + + cdate=`$NDATE -6 $cdate` + ctr=`expr $ctr + 1` +done +$UNCOMPRESS *${Z} -#-------------------------------------------------------------------- -# Copy control and data files to $tmpdir +#---------------------------------------------------------------- +# Modify tdef line in .ctl file to start at bdate. # -tankdir_bdate0=${TANKDIR}/${RUN}.${bdate0}/oznmon/horiz -tankdir_edate0=${TANKDIR}/${RUN}.${edate0}/oznmon/horiz +if [[ -e ${SATYPE}.${dsrc}.ctl ]]; then + edate=`$NDATE -18 $PDATE` + ${OZN_IG_SCRIPTS}/update_ctl_tdef.sh ${SATYPE}.${dsrc}.ctl ${edate} 4 +fi -$NCP ${tankdir_bdate0}/${SATYPE2}.ctl ./ -############################################# -# NOTE: need to modify tdef line in .ctl file for this cycle!! -############################################# - -$NCP ${tankdir_bdate0}/${SATYPE2}*${bdate0}* ./ -$NCP ${tankdir_edate0}/${SATYPE2}*${edate0}* ./ $NCP ${OZN_IG_GSCRPTS}/cbarnew.gs ./ -for type in ${SATYPE2}; do - date - - $STNMAP -i ${type}.ctl +$STNMAP -i ${SATYPE}.${dsrc}.ctl - for var in ${PTYPE}; do +for var in ${PTYPE}; do -cat << EOF > ${type}_${var}.gs -'open ${type}.ctl' -'run ${OZN_IG_GSCRPTS}/plot_horiz_${string}.gs ${type} ${var} x800 y700' +cat << EOF > ${SATYPE}_${var}.gs +'open ${SATYPE}.${dsrc}.ctl' +'run ${OZN_IG_GSCRPTS}/plot_horiz_${dsrc}.gs ${OZNMON_SUFFIX} ${RUN} ${SATYPE} ${var} x800 y700' 'quit' EOF - $GRADS -blc "run ${tmpdir}/${type}_${var}.gs" - - #------------------------------ - # rename the analysis plots - # -# if [[ $string == 'anl' ]] ; then -# levlist='1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22' -# if [[ ${var} == 'ges' ]] ; then -# if [[ $type == 'omi_aura' || $type == 'gome_metop-a' || $type == 'gome_metop-b' ]] ; then -# mv ${type}.ges_1.png ${type}.anl_1.png -# else -# for level in $levlist ; do -# mv ${type}.ges_${level}.png ${type}.anl_${level}.png -# done -# fi -# fi -# if [[ ${var} == 'obsges' ]] ; then -# if [[ $type == 'omi_aura' || $type == 'gome_metop-a' || $type == 'gome_metop-b' ]] ; then -# mv ${type}.obsges_1.png ${type}.obsanl_1.png -# else -# for level in $levlist ; do -# mv ${type}.obsges_${level}.png ${type}.obsanl_${level}.png -# done -# fi -# fi -# fi - - done - - #-------------------------------------------------------------------- - # Move image files to TANK - # - - ${NCP} *.png ${OZN_IMGN_TANKDIR}/. - - -# if [[ $transfer_plot -eq 1 ]] ; then -## transfer plots from ibm to rzdm -# rm -f $LOGDIR/transfer_horiz_${SATYPE2}.log -# export subdir=horiz -# export listvar1=PDATE,webpsw,webmch,webid,WEBDIR,LOGDIR,USER,SUB,SUFFIX,SATYPE2,string,PVAR,subdir,tmpdir,listvar1 -# $SUB -P ${PROJECT} -q transfer -o $LOGDIR/transfer_horiz_${SATYPE2}.log -M 30 -W 0:45 -R affinity[core] -J transfer_horiz ${SCRIPTS}/transfer.sh -# fi - -done + $GRADS -blc "run ${tmpdir}/${SATYPE}_${var}.gs" + + +done + + +#-------------------------------------------------------------------- +# Move image files to TANK +# + +${NCP} *.png ${OZN_IMGN_TANKDIR}/. #-------------------------------------------------------------------- # Clean $tmpdir. Submit done job. #cd $tmpdir #cd ../ -##rm -rf $tmpdir +#rm -rf $tmpdir echo "end plot_horiz.sh" exit diff --git a/util/Ozone_Monitor/image_gen/ush/plot_summary.sh b/util/Ozone_Monitor/image_gen/ush/plot_summary.sh index b5d73957d..40c8168f0 100755 --- a/util/Ozone_Monitor/image_gen/ush/plot_summary.sh +++ b/util/Ozone_Monitor/image_gen/ush/plot_summary.sh @@ -1,4 +1,4 @@ -#! /bin/ksh +#! /bin/ksh -l #------------------------------------------------------------------ # plot_summary.sh @@ -6,75 +6,82 @@ set -ax -SATYPE2=$1 +if [[ ${MY_MACHINE} = "hera" ]]; then + module load grads +fi +SATYPE=$1 +ptype=$2 #------------------------------------------------------------------ -# Set work space for this SATYPE2 source. +# Set work space for this SATYPE source. # -tmpdir=${WORKDIR}/${SATYPE2}.$PDATE +tmpdir=${WORKDIR}/${SATYPE}.${ptype}.${PDATE} rm -rf $tmpdir mkdir -p $tmpdir cd $tmpdir #------------------------------------------------------------------ -# Set dates -bdate=`$NDATE -168 $PDATE` -edate=$PDATE -bdate0=`echo $bdate|cut -c1-8` -edate0=`echo $edate|cut -c1-8` - - -#-------------------------------------------------------------------- -# Copy control and data files to $tmpdir +# Set dates and copy data files +# +# 120 cycles worth of data (30 days) are required for summary +# plots. Start with PDATE and back up 119 times. # -tankdir_bdate0=${TANKDIR}/${RUN}.${bdate0}/oznmon/time -tankdir_edate0=${TANKDIR}/${RUN}.${edate0}/oznmon/time -for type in ${SATYPE2}; do - cdate=$bdate +ctr=0 +cdate=$PDATE - while [[ $cdate -le $edate ]]; do - cdate0=`echo $cdate|cut -c1-8` - tankdir_cdate0=${TANKDIR}/${RUN}.${cdate0}/oznmon/time +while [[ $ctr -le 120 ]]; do + c_pdy=`echo $cdate|cut -c1-8` + c_cyc=`echo $cdate|cut -c9-10` + tankdir_cdate=${TANKDIR}/${RUN}.${c_pdy}/${c_cyc}/oznmon/time - if [[ ! -e ${type}.ctl ]]; then - $NCP ${tankdir_cdate0}/${type}.ctl ./ + if [[ ! -e ./${SATYPE}.${ptype}.ctl ]]; then + $NCP ${tankdir_cdate}/${SATYPE}.${ptype}.ctl ./ + fi + + data_file=${tankdir_cdate}/${SATYPE}.${ptype}.${cdate}.ieee_d + if [[ -s ${data_file} ]]; then + $NCP ${data_file} ./ + else + data_file=${data_file}.${Z} + if [[ -s ${data_file} ]]; then + $NCP ${data_file} ./ + $UNCOMPRESS ${data_file} fi - - $NCP ${tankdir_cdate0}/${type}.${cdate}.ieee_d ./ - adate=`$NDATE +6 $cdate` - cdate=$adate - done - - #---------------------------------------------------------------- - # Modify tdef line in .ctl file to start at bdate. - # - if [[ -e ${type}.ctl ]]; then -# ${OZN_IG_SCRIPTS}/update_ctl_tdef.sh ${type}.ctl ${bdate} 28 - ${OZN_IG_SCRIPTS}/update_ctl_tdef.sh ${type}.ctl ${bdate} 29 fi -cat << EOF > ${type}.gs -'open ${type}.ctl' -'run ${OZN_IG_GSCRPTS}/plot_summary.gs ${type} x750 y700' + cdate=`$NDATE -6 $cdate` + ctr=`expr $ctr + 1` +done + + +#---------------------------------------------------------------- +# Modify tdef line in .ctl file to start at bdate. tdef line +# should be 1 more than the total number of cycles so the last +# cycle will be the cycle specified by $PDATE. +# +if [[ -e ${SATYPE}.${ptype}.ctl ]]; then + bdate=`$NDATE -720 $PDATE` + ${OZN_IG_SCRIPTS}/update_ctl_tdef.sh ${SATYPE}.${ptype}.ctl ${bdate} 121 +fi + +cat << EOF > ${SATYPE}.gs +'open ${SATYPE}.${ptype}.ctl' +'run ${OZN_IG_GSCRPTS}/plot_summary.gs ${OZNMON_SUFFIX} ${RUN} ${SATYPE} ${ptype} x750 y700' 'quit' EOF - $GRADS -bpc "run ${tmpdir}/${type}.gs" +$GRADS -bpc "run ${tmpdir}/${SATYPE}.gs" -# rm -f ${type}.ctl -# rm -f ${type}*.ieee_d -# rm -f ${type}.summary.png - -done #-------------------------------------------------------------------- # copy image files to TANKDIR # ${NCP} *.png ${OZN_IMGN_TANKDIR}/. + #-------------------------------------------------------------------- # Clean $tmpdir. #cd $tmpdir diff --git a/util/Ozone_Monitor/image_gen/ush/plot_time.sh b/util/Ozone_Monitor/image_gen/ush/plot_time.sh index e44f63d06..f0c7289c4 100755 --- a/util/Ozone_Monitor/image_gen/ush/plot_time.sh +++ b/util/Ozone_Monitor/image_gen/ush/plot_time.sh @@ -1,4 +1,4 @@ -#! /bin/ksh +#! /bin/ksh -l #------------------------------------------------------------------ # plot_time.sh @@ -6,156 +6,143 @@ set -ax -export SATYPE2=$1 +if [[ ${MY_MACHINE} = "hera" ]]; then + module load grads +fi + + +export SATYPE=$1 export PVAR=$2 export PTYPE=$3 +dsrc=$4 -echo "SATYPE2, PVAR, PTYPE = $SATYPE2, $PVAR, $PTYPE" +echo "SATYPE, PVAR, PTYPE, dsrc = $SATYPE, $PVAR, $PTYPE $dsrc" echo "RUN = $RUN" -#if [[ "$SUFFIX" != "opr" ]]; then -# export plot_2files=0 -#else -# export plot_2files=0 -#fi +echo COMP1, COMP2, DO_COMP = $COMP1, $COMP2, $DO_COMP + +ADD_COMP=0 +if [[ $SATYPE = $COMP1 ]]; then + ADD_COMP=1 +fi #------------------------------------------------------------------ -# Set work space for this SATYPE2 source. +# Set work space for this SATYPE source. # -tmpdir=${WORKDIR}/${SATYPE2}.$PDATE.${PVAR} +tmpdir=${WORKDIR}/${SATYPE}.${dsrc}.$PDATE.${PVAR} rm -rf $tmpdir mkdir -p $tmpdir cd $tmpdir #------------------------------------------------------------------ -# Set dates -bdate=`$NDATE -720 $PDATE` -edate=$PDATE -bdate0=`echo $bdate|cut -c1-8` -edate0=`echo $edate|cut -c1-8` - -#-------------------------------------------------------------------- -# Copy control and data files to $tmpdir +# Set dates and copy data files # -tankdir_bdate0=${TANKDIR}/${RUN}.${bdate0}/oznmon/time -tankdir_edate0=${TANKDIR}/${RUN}.${edate0}/oznmon/time +# 120 cycles worth of data (30 days) are required for time plots. +# Start with PDATE and back up 119 times to get what we need. +# + +ctr=0 +cdate=$PDATE -for type in ${SATYPE2}; do - cdate=$bdate +while [[ $ctr -le 119 ]]; do + c_pdy=`echo $cdate|cut -c1-8` + c_cyc=`echo $cdate|cut -c9-10` + tankdir_cdate=${TANKDIR}/${RUN}.${c_pdy}/${c_cyc}/oznmon/time - while [[ $cdate -le $edate ]]; do - cdate0=`echo $cdate|cut -c1-8` - tankdir_cdate0=${TANKDIR}/${RUN}.${cdate0}/oznmon/time + if [[ ! -e ./${SATYPE}.${dsrc}.ctl ]]; then + $NCP ${tankdir_cdate}/${SATYPE}.${dsrc}.ctl ./ + fi - if [[ ! -e ${type}.ctl ]]; then - $NCP ${tankdir_cdate0}/${type}.ctl ./ + data_file=${tankdir_cdate}/${SATYPE}.${dsrc}.${cdate}.ieee_d + if [[ -s ${data_file} ]]; then + $NCP ${data_file} ./ + else + data_file=${data_file}.${Z} + if [[ -s ${data_file} ]]; then + $NCP ${data_file} ./ + $UNCOMPRESS ${data_file} fi + fi - $NCP ${tankdir_cdate0}/${type}.${cdate}.ieee_d ./ - adate=`$NDATE +6 $cdate` - cdate=$adate - done + if [[ $ADD_COMP -eq 1 ]]; then + if [[ ! -e ./${COMP2}.${dsrc}.ctl ]]; then + $NCP ${tankdir_cdate}/${COMP2}.${dsrc}.ctl ./ + fi + + data_file=${tankdir_cdate}/${COMP2}.${dsrc}.${cdate}.ieee_d + if [[ -s ${data_file} ]]; then + $NCP ${data_file} ./ + else + data_file=${data_file}.${Z} + if [[ -s ${data_file} ]]; then + $NCP ${data_file} ./ + $UNCOMPRESS ${data_file} + fi + fi - #---------------------------------------------------------------- - # Modify tdef line in .ctl file to start at bdate. - # - if [[ -e ${type}.ctl ]]; then - ${OZN_IG_SCRIPTS}/update_ctl_tdef.sh ${type}.ctl ${bdate} 121 fi + cdate=`$NDATE -6 $cdate` + ctr=`expr $ctr + 1` +done -# if [[ $plot_2files == 1 ]] ; then -# ln -s /da/noscrub/Haixia.Liu/ozone/monitor/stats/opr/ges/time time_opr -# -# for var in ${PTYPE}; do -# echo $var -#cat << EOF > ${type}_${var}.gs -#'reinit' -#'clear' -#'open ${type}.ctl' -#'open time_opr/${type}.ctl' -#'run ${OZN_IG_GSCRPTS}/plot_time_${string}.gs.2files ${type} ${var} x750 y700' -#'quit' -#EOF -# -# echo ${tmpdir}/${type}_${var}.gs -# -# $GRADS -bpc "run ${tmpdir}/${type}_${var}.gs" -# done + + +#---------------------------------------------------------------- +# Modify tdef line in .ctl file to start at bdate. # -# else - for var in ${PTYPE}; do - echo $var +if [[ -e ${SATYPE}.${dsrc}.ctl ]]; then + edate=`$NDATE -720 $PDATE` + ${OZN_IG_SCRIPTS}/update_ctl_tdef.sh ${SATYPE}.${dsrc}.ctl ${edate} 121 -cat << EOF > ${type}_${var}.gs + if [[ $ADD_COMP -eq 1 ]]; then + ${OZN_IG_SCRIPTS}/update_ctl_tdef.sh ${COMP2}.${dsrc}.ctl ${edate} 121 + fi +fi + + +for var in ${PTYPE}; do + echo $var + + if [[ $ADD_COMP -eq 0 ]]; then + +cat << EOF > ${SATYPE}_${var}.gs 'reinit' 'clear' -'open ${type}.ctl' -'run ${OZN_IG_GSCRPTS}/plot_time_${string}.gs ${type} ${var} x750 y700' +'open ${SATYPE}.${dsrc}.ctl' +'run ${OZN_IG_GSCRPTS}/plot_time_${dsrc}.gs ${OZNMON_SUFFIX} ${RUN} ${SATYPE} ${var} x750 y700' 'quit' EOF - echo ${tmpdir}/${type}_${var}.gs - - $GRADS -bpc "run ${tmpdir}/${type}_${var}.gs" - - #---------------------------------------------- - # rename the analysis plots - # -# if [[ $string == 'anl' ]] ; then -# reglist='region1 region2 region3 region4 region5 region6' -# frlist='fr1 fr2 fr3 fr4 fr5 fr6' -# if [[ ${var} == 'count' ]] ; then -# if [[ $type == 'omi_aura' || $type == 'gome_metop-a' || $type == 'gome_metop-b' ]] ; then -# for region in $reglist ; do -# mv ${type}.count_${region}_fr1.png ${type}.countanl_${region}_fr1.png -# done -# else -# for region in $reglist ; do -# for fr in $frlist ; do -# mv ${type}.count_${region}_${fr}.png ${type}.countanl_${region}_${fr}.png -# done -# done -# fi -# elif [[ ${var} == 'omg' ]] ; then -# if [[ $type == 'omi_aura' || $type == 'gome_metop-a' || $type == 'gome_metop-b' ]] ; then -# for region in $reglist ; do -# mv ${type}.omg_${region}_fr1.png ${type}.oma_${region}_fr1.png -# done -# else -# for region in $reglist ; do -# for fr in $frlist ; do -# mv ${type}.omg_${region}_${fr}.png ${type}.oma_${region}_${fr}.png -# done -# done -# fi -# else -# if [[ $type == 'omi_aura' || $type == 'gome_metop-a' || $type == 'gome_metop-b' ]] ; then -# for region in $reglist ; do -# mv ${type}.cpen_${region}_fr1.png ${type}.cpenanl_${region}_fr1.png -# done -# else -# for region in $reglist ; do -# for fr in $frlist ; do -# mv ${type}.cpen_${region}_${fr}.png ${type}.cpenanl_${region}_${fr}.png -# done -# done -# fi -# fi -# fi - done -# fi -done + else + +cat << EOF > ${SATYPE}_${var}.gs +'reinit' +'clear' +'open ${SATYPE}.${dsrc}.ctl' +'open ${COMP2}.${dsrc}.ctl' +'run ${OZN_IG_GSCRPTS}/plot_time_${dsrc}_2x.gs ${OZNMON_SUFFIX} ${RUN} ${SATYPE} ${COMP2} ${var} x750 y700' +'quit' +EOF + + fi + + echo ${tmpdir}/${SATYPE}_${var}.gs + $GRADS -bpc "run ${tmpdir}/${SATYPE}_${var}.gs" + +done + #-------------------------------------------------------------------- # copy image files to TANKDIR # ${NCP} *.png ${OZN_IMGN_TANKDIR}/. + #-------------------------------------------------------------------- # Clean $tmpdir. Submit done job. -cd $tmpdir -cd ../ +#cd $tmpdir +#cd ../ #rm -rf $tmpdir exit diff --git a/util/Ozone_Monitor/image_gen/ush/run_plot_GEOIRimg4.sh b/util/Ozone_Monitor/image_gen/ush/run_plot_GEOIRimg4.sh new file mode 100755 index 000000000..2052183cc --- /dev/null +++ b/util/Ozone_Monitor/image_gen/ush/run_plot_GEOIRimg4.sh @@ -0,0 +1,66 @@ +#!/bin/sh +set -ax + +package=ProdGSI/util/Ozone_Monitor +#package=OznMon + +DO_COMP=1 +COMP1=sbuv2_n19 +COMP2=ompsnp_npp + +ozn_suffix=GEOIRimg4 +run=gdas + +my_machine=wcoss_d + + +export NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.0/exec/ips/ndate + +echo "NDATE = $NDATE" + +scripts=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/${package}/image_gen/ush +data_map=${scripts}/data_map.xml + +export JOB_QUEUE=dev +export MAIL_TO="edward.safford@noaa.gov" + +export OZN_USE_RUN=1 + +export CYCLE_INTERVAL=6 + +tankdir=/u/Edward.Safford/nbns/stats/${ozn_suffix} +#imgdate=`${scripts}/query_data_map.pl ${data_map} ${ozn_suffix}_${run} imgdate` +#idate=`$NDATE +${CYCLE_INTERVAL} $imgdate` + +logdir=/gpfs/dell2/ptmp/Edward.Safford/logs + +#export SATYPE=`cat ${tankdir}/info/gdas_oznmon_satype.txt` + +prodate=`${scripts}/find_cycle.pl -run ${run} -cyc 1 -dir ${tankdir}` +echo "imgdate, idate, prodate = $imgdate, $idate, $prodate" +idate=2019063018 + +if [[ $idate -le $prodate ]]; then + + echo " firing OznMon_Plt.sh" + + if [[ $DO_COMP -eq 1 ]]; then + ${scripts}/OznMon_Plt.sh $ozn_suffix -p $idate -r $run \ + -c1 $COMP1 -c2 $COMP2 \ + 1>${logdir}/${ozn_suffix}/${run}/oznmon/OznMon_Plt.log \ + 2>${logdir}/${ozn_suffix}/${run}/oznmon/OznMon_Plt.err + else + + ${scripts}/OznMon_Plt.sh $ozn_suffix -p $idate -r $run \ + 1>${logdir}/${ozn_suffix}/${run}/oznmon/OznMon_Plt.log \ + 2>${logdir}/${ozn_suffix}/${run}/oznmon/OznMon_Plt.err + fi + + rc=`${scripts}/update_data_map.pl ${data_map} \ + ${ozn_suffix}_${run} imgdate ${idate}` + + echo "rc from update_data_map.pl = $rc" + +fi + +exit diff --git a/util/Ozone_Monitor/image_gen/ush/run_plot_gdas.sh b/util/Ozone_Monitor/image_gen/ush/run_plot_gdas.sh new file mode 100755 index 000000000..4558f4fd9 --- /dev/null +++ b/util/Ozone_Monitor/image_gen/ush/run_plot_gdas.sh @@ -0,0 +1,68 @@ +#!/bin/sh + +package=ProdGSI/util/Ozone_Monitor +#package=OznMon + +suffix=GFS +run=gdas + +DO_COMP=1 +COMP1=sbuv2_n19 +COMP2=ompsnp_npp + +idev=`cat /etc/dev | cut -c1` +iprod=`cat /etc/prod | cut -c1` + +#scripts=/gpfs/${idev}d2/emc/da/noscrub/Edward.Safford/${package}/image_gen/ush +#scripts=/scratch4/NCEPDEV/da/noscrub/Edward.Safford/${package}/image_gen/ush +scripts=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/${package}/image_gen/ush + +data_map=${scripts}/data_map.xml + +#export NDATE=/nwprod/util/exec/ndate +export NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.0/exec/ips/ndate + +export MAIL_CC="russ.treadon@noaa.gov, andrew.collard@noaa.gov, haixia.liu@noaa.gov" +export MAIL_TO="edward.safford@noaa.gov" + +export OZN_USE_RUN=1 + +export CYCLE_INTERVAL=6 + +#tankdir=/gpfs/${idev}d2/emc/da/noscrub/Edward.Safford/nbns/stats/${suffix} +#tankdir=/scratch4/NCEPDEV/da/save/Edward.Safford/nbns/stats/${suffix} +tankdir=/u/Edward.Safford/nbns/stats/${suffix} + +imgdate=`${scripts}/query_data_map.pl ${data_map} ${suffix}_${run} imgdate` +idate=`$NDATE +${CYCLE_INTERVAL} $imgdate` +#idate=2019071306 + +prodate=`${scripts}/find_cycle.pl -run ${run} -cyc 1 -dir ${tankdir}` + +logdir=/gpfs/dell2/ptmp/Edward.Safford/logs + +echo "imgdate, idate, prodate = $imgdate, $idate, $prodate" +if [[ $idate -le $prodate ]]; then + + echo " firing OznMon_Plt.sh" + + if [[ $DO_COMP -eq 1 ]]; then + ${scripts}/OznMon_Plt.sh $suffix -p $idate -r $run \ + -c1 $COMP1 -c2 $COMP2 \ + 1>${logdir}/${suffix}/${run}/oznmon/OznMon_Plt.log \ + 2>${logdir}/${suffix}/${run}/oznmon/OznMon_Plt.err + + else + ${scripts}/OznMon_Plt.sh $suffix -p $idate -r $run \ + 1>${logdir}/${suffix}/${run}/oznmon/OznMon_Plt.log \ + 2>${logdir}/${suffix}/${run}/oznmon/OznMon_Plt.err + fi + + rc=`${scripts}/update_data_map.pl ${data_map} \ + ${suffix}_${run} imgdate ${idate}` + + echo "rc from update_data_map.pl = $rc" + +fi + +exit diff --git a/util/Ozone_Monitor/image_gen/ush/run_transfer_gfs.sh b/util/Ozone_Monitor/image_gen/ush/run_transfer_gfs.sh new file mode 100755 index 000000000..b74e07713 --- /dev/null +++ b/util/Ozone_Monitor/image_gen/ush/run_transfer_gfs.sh @@ -0,0 +1,17 @@ +#!/bin/sh + +package=ProdGSI/util/Ozone_Monitor +#package=OznMon + +ozn_suffix=GFS +run=gdas + +ch=`hostname | cut -c1` + +#export WEB_DIR=/home/people/emc/www/htdocs/gmb/gdas/es_ozn/pngs + +scripts=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/${package}/image_gen/ush + +${scripts}/OznMon_Transfer.sh ${ozn_suffix} --run ${run} + +exit diff --git a/util/Ozone_Monitor/image_gen/ush/transfer.sh b/util/Ozone_Monitor/image_gen/ush/transfer.sh index 6b29276b5..71a645d0f 100755 --- a/util/Ozone_Monitor/image_gen/ush/transfer.sh +++ b/util/Ozone_Monitor/image_gen/ush/transfer.sh @@ -32,7 +32,8 @@ set -ax if [[ ${OZN_IMGN_TANKDIR} != "/" ]]; then # sanity check - if [[ $MY_MACHINE = "ibm" || $MY_MACHINE = "cray" ]]; then + if [[ $MY_MACHINE = "wcoss" || $MY_MACHINE = "wcoss_d" || \ + $MY_MACHINE = "cray" ]]; then #---------------------------------------------------------------- # expand WEB_DIR to include the suffix and conditionally the RUN diff --git a/util/Ozone_Monitor/makeall.sh b/util/Ozone_Monitor/makeall.sh index 972455d7d..d1e8c4a16 100755 --- a/util/Ozone_Monitor/makeall.sh +++ b/util/Ozone_Monitor/makeall.sh @@ -30,7 +30,7 @@ echo "machine = $machine" HOMEoznmon=${MY_OZNMON}/nwprod/oznmon_shared.${shared_oznmon_ver} echo HOMEoznmon = $HOMEoznmon -if [[ ${machine} = "theia" || ${machine} = "ibm" || ${machine} = "cray" ]]; then +if [[ ${machine} = "theia" || ${machine} = "wcoss" || ${machine} = "cray" || ${machine} = "dell" ]]; then echo Building executables on ${machine} echo @@ -43,6 +43,7 @@ if [[ ${machine} = "theia" || ${machine} = "ibm" || ${machine} = "cray" ]]; then executables="oznmon_horiz oznmon_time" echo "Making executables in nwprod/oznmon_shared.${shared_oznmon_ver}/sorc:" + export dir_root=${HOMEoznmon} for var in ${executables}; do cd ${HOMEoznmon}/sorc/${var}.fd @@ -57,8 +58,9 @@ if [[ ${machine} = "theia" || ${machine} = "ibm" || ${machine} = "cray" ]]; then executables="make_base" echo "Making executables in data_xtrc/sorc:" + export dir_root=${MY_OZNMON}/data_xtrct/ for var in ${executables}; do - cd ${OZN_DE_SORC}/data_xtrct/sorc/${var}.fd + cd ${OZN_DE_SORC}/${var}.fd make ${mode} if [[ $mode = "" ]]; then diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn.sh b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn.sh index 76ce1dc92..3edbccf3c 100755 --- a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn.sh +++ b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn.sh @@ -9,7 +9,7 @@ #BSUB -M 100 #BSUB -W 00:05 #BSUB -a poe -#BSUB -P GFS-T2O +#BSUB -P GFS-DEV ##------------------------------------------------------------ ## This is the test driver script for the wcoss/ibm systems @@ -18,7 +18,8 @@ set -x -export PDATE=${PDATE:-2017072300} +export OZNMON_NEW_HDR=${OZN_NEW_HDR:-0} +export PDATE=${PDATE:-2017072206} export NET=${NET:-gfs} export RUN=${RUN:-gdas} @@ -63,20 +64,30 @@ export POE=YES # export OZNMON_SUFFIX=${OZNMON_SUFFIX:-testozn} export NWTEST=${NWTEST:-/gpfs/gd2/emc/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/nwprod} - export HOMEgdas_ozn=${NWTEST}/gdas_oznmon.${gdas_oznmon_ver} export PARMgdas_ozn=${HOMEgdas_ozn}/parm -export SCRgdas_ozn=${HOMEgdas_ozn}/scripts -JOBgdas_ozn=${HOMEgdas_ozn}/jobs +export FIXgdas_ozn=${FIXgdas_ozn:-${HOMEgdas_ozn}/fix} + + +export HOMEgfs_ozn=${HOMEgfs_ozn:-${HOMEgdas_ozn}} +export PARMgfs_ozn=${PARMgfs_ozn:-${PARMgdas_ozn}} +export FIXgfs_ozn=${FIXgfs_ozn:-${FIXgdas_ozn}} + +export JOBGLOBAL=${JOBGLOBAL:-${HOMEgdas_ozn}/jobs} +export HOMEoznmon=${HOMEoznmon:-${NWTEST}/oznmon_shared.${shared_oznmon_ver}} + +#export SCRgdas_ozn=${HOMEgdas_ozn}/scripts +#JOBgdas_ozn=${HOMEgdas_ozn}/jobs export HOMEoznmon=${NWTEST}/oznmon_shared.${oznmon_shared_ver} export COM_IN=${COM_IN:-$DATAROOT} export OZN_TANKDIR=${OZN_TANKDIR:-${COMROOT}/${OZNMON_SUFFIX}} + #------------------------------------------------------------ # Execute job # -${JOBgdas_ozn}/JGDAS_VERFOZN +${JOBGLOBAL}/JGDAS_VERFOZN exit diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_cray.sh b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_cray.sh deleted file mode 100755 index 1d48e41e5..000000000 --- a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_cray.sh +++ /dev/null @@ -1,81 +0,0 @@ -#!/bin/ksh - -#BSUB -o gdas_verfozn.o%J -#BSUB -e gdas_verfozn.o%J -#BSUB -J gdas_verfozn -#BSUB -q dev -#BSUB -M 100 -#BSUB -W 00:05 -#BSUB -P GFS-T2O -#BSUB -R "select[mem>100] rusage[mem=100]" - -##BSUB -cwd /gpfs/hps/ptmp/Edward.Safford -##BSUB -cwd ${PWD} - -##------------------------------------------------------------ -## This is the test driver script for the wcoss/cray systems -## to run the JGDAS_VERFOZN job. -##------------------------------------------------------------ - -set -x - -export PDATE=${PDATE:-2017072212} -export NET=${NET:-gfs} -export RUN=${RUN:-gdas} - -export PDY=`echo $PDATE | cut -c1-8` -export cyc=`echo $PDATE | cut -c9-10` -export job=gdas_verfozn.${cyc} -export pid=${pid:-$$} -export jobid=${job}.${pid} -export envir=${envir:-test} - -export DATAROOT=${DATAROOT:-/gpfs/hps/emc/da/noscrub/${LOGNAME}/test_data} -export COMROOT=${COMROOT:-/gpfs/hps/ptmp/${LOGNAME}/com} -export OZN_WORK_DIR=${OZN_WORK_DIR:-/gpfs/hps/stmp/${LOGNAME}/oznmon.${pid}} - -#------------------------------------------------------------ -# Specify versions -# -export gdas_oznmon_ver=v2.0.0 -export oznmon_shared_ver=v2.0.0 - - -############################################################# -# Load modules -############################################################# -. $MODULESHOME/init/ksh - -module load prod_util -module load util_shared - -module list - - -#------------------------------------------------------------ -# WCOSS environment settings -# -export POE=YES - -#------------------------------------------------------------ -# Set user specific variables -# -export OZNMON_SUFFIX=${OZNMON_SUFFIX:-testozn} -export NWTEST=${NWTEST:-/gpfs/hps/emc/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/nwprod} - -export HOMEgdas_ozn=${NWTEST}/gdas_oznmon.${gdas_oznmon_ver} -export PARMgdas_ozn=${HOMEgdas_ozn}/parm -export SCRgdas_ozn=${HOMEgdas_ozn}/scripts -JOBgdas_ozn=${HOMEgdas_ozn}/jobs - -export HOMEoznmon=${NWTEST}/oznmon_shared.${oznmon_shared_ver} -export COM_IN=${COM_IN:-$DATAROOT} -export OZN_TANKDIR=${OZN_TANKDIR:-${COMROOT}/${OZNMON_SUFFIX}} - -#------------------------------------------------------------ -# Execute job -# -${JOBgdas_ozn}/JGDAS_VERFOZN - -exit - diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_hera.sh b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_hera.sh new file mode 100755 index 000000000..b26a8fb72 --- /dev/null +++ b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_hera.sh @@ -0,0 +1,88 @@ +#!/bin/ksh + +#SBATCH -o gdas_verfozn.o%j +#SBATCH -J gdas_verfozn +#SBATCH --ntasks=1 --mem=5g +#SBATCH --time=10 +#SBATCH --account=fv3-cpu +#SBATCH -D . + +set -x + +export OZNMON_NEW_HDR=${OZN_NEW_HDR:-0} + +#export PDATE=${PDATE:-2019083100} # netcdf +export PDATE=${PDATE:-2018091706} # bin +export NET=${NET:-gfs} +export RUN=${RUN:-gdas} + +export PDY=`echo $PDATE | cut -c1-8` +export cyc=`echo $PDATE | cut -c9-10` +export job=${job:-gdas_verfozn.${cyc}} +export pid=${pid:-$$} +export jobid=${job}.${pid} +export envir=${envir:-test} +export DATAROOT=${DATAROOT:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/test_data} +export COMROOT=${COMROOT:-/scratch2/NCEPDEV/stmp3/${LOGNAME}/com} +export OZN_WORK_DIR=${OZN_WORK_DIR:-/scratch2/NCEPDEV/stmp3/${LOGNAME}/oznmon.${pid}} + +#------------------------------------------------------------ +# Specify versions +# +export gdas_oznmon_ver=v2.0.0 +export shared_oznmon_ver=v2.0.0 + + +#------------------------------------------------------------ +# Add nwpara tools to path +# +#NWPROD=${NWPROD:-/scratch4/NCEPDEV/global/save/glopara/nwpara/util} +#NWPRODush=${NWPRODush:=${NWPROD}/ush} +#NWPRODexec=${NWPRODexec:=${NWPROD}/exec} +#export PATH=${PATH}:${NWPRODush}:${NWPRODexec} + +#------------------------------------------------------------ +# Set user specific variables +# + +export OZNMON_SUFFIX=${OZNMON_SUFFIX:-testozn} +export NWTEST=${NWTEST:-/scratch1/NCEPDEV/da/${LOGNAME}/noscrub/ProdGSI/util/Ozone_Monitor/nwprod} +export HOMEgdas_ozn=${HOMEgdas_ozn:-${NWTEST}/gdas_oznmon.${gdas_oznmon_ver}} +export PARMgdas_ozn=${PARMgdas_ozn:-${HOMEgdas_ozn}/parm} +export FIXgdas_ozn=${FIXgdas_ozn:-${HOMEgdas_ozn}/fix} + +export HOMEgfs_ozn=${HOMEgfs_ozn:-${HOMEgdas_ozn}} +export PARMgfs_ozn=${PARMgfs_ozn:-${PARMgdas_ozn}} +export FIXgfs_ozn=${FIXgfs_ozn:-${FIXgdas_ozn}} + +export JOBGLOBAL=${JOBGLOBAL:-${HOMEgdas_ozn}/jobs} +export HOMEoznmon=${HOMEoznmon:-${NWTEST}/oznmon_shared.${shared_oznmon_ver}} +export COM_IN=${COM_IN:-${DATAROOT}} +export OZN_TANKDIR=${OZN_TANKDIR:-${COMROOT}/${OZNMON_SUFFIX}} + +export SUB=${SUB:-/apps/slurm/default/bin/sbatch} +export NDATE=${NDATE:-/home/Edward.Safford/bin/ndate} + + + +#------------------------------------------------------------ +# theia specific hacks for no prod_utils module & no setpdy.sh script +# +export MY_MACHINE=hera +prevday=`$NDATE -24 $PDATE` +export PDYm1=`echo $prevday | cut -c1-8` +#ln -s ${NWPRODush}/startmsg.sh ${COMROOT}/startmsg +#ln -s ${NWPRODush}/postmsg.sh ${COMROOT}/postmsg +#ln -s ${NWPRODush}/prep_step.sh ${COMROOT}/prep_step +#ln -s ${NWPRODush}/err_chk.sh ${COMROOT}/err_chk +export PATH=$PATH:${COMROOT} +#export utilscript=${utilscript:-${NWPRODush}} # err_chk calls postmsg.sh + # directly so need to override + # utilscript location for theia +#------------------------------------------------------------ +# Execute job +# +$JOBGLOBAL/JGDAS_VERFOZN + +exit + diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_theia.sh b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_theia.sh deleted file mode 100755 index 173d2415c..000000000 --- a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_theia.sh +++ /dev/null @@ -1,81 +0,0 @@ -#!/bin/ksh - -#PBS -o gdas_verfozn.log -#PBS -e gdas_verfozn.err -#PBS -N gdas_verfozn -#PBS -A fv3-cpu -#PBS -l procs=1,walltime=0:10:00 -#PBS -V - -set -x - -export PDATE=${PDATE:-2017072600} -export NET=${NET:-gfs} -export RUN=${RUN:-gdas} - -#------------------------------------------------------------ -# Specify whether the run is production or development -# -export PDY=`echo $PDATE | cut -c1-8` -export cyc=`echo $PDATE | cut -c9-10` -export job=${job:-gdas_verfozn.${cyc}} -export pid=${pid:-$$} -export jobid=${job}.${pid} -export envir=${envir:-test} -export DATAROOT=${DATAROOT:-/scratch4/NCEPDEV/da/noscrub/Edward.Safford/test_data} -export COMROOT=${COMROOT:-/scratch4/NCEPDEV/stmp3/${LOGNAME}/com} -export OZN_WORK_DIR=${OZN_WORK_DIR:-/scratch4/NCEPDEV/stmp3/${LOGNAME}/oznmon.${pid}} - -#------------------------------------------------------------ -# Specify versions -# -export gdas_oznmon_ver=v2.0.0 -export shared_oznmon_ver=v2.0.0 - - -#------------------------------------------------------------ -# Add nwpara tools to path -# -NWPROD=${NWPROD:-/scratch4/NCEPDEV/global/save/glopara/nwpara/util} -NWPRODush=${NWPRODush:=${NWPROD}/ush} -NWPRODexec=${NWPRODexec:=${NWPROD}/exec} -export PATH=${PATH}:${NWPRODush}:${NWPRODexec} - -#------------------------------------------------------------ -# Set user specific variables -# - -export OZNMON_SUFFIX=${OZNMON_SUFFIX:-testozn} -export NWTEST=${NWTEST:-/scratch4/NCEPDEV/da/noscrub/${LOGNAME}/comgsi/util/Ozone_Monitor/nwprod} -export HOMEgdas_ozn=${HOMEgdas_ozn:-${NWTEST}/gdas_oznmon.${gdas_oznmon_ver}} -export JOBGLOBAL=${JOBGLOBAL:-${HOMEgdas_ozn}/jobs} -export HOMEoznmon=${HOMEoznmon:-${NWTEST}/oznmon_shared.${shared_oznmon_ver}} -export COM_IN=${COM_IN:-${DATAROOT}} -export OZN_TANKDIR=${OZN_TANKDIR:-${COMROOT}/${OZNMON_SUFFIX}} - -export SUB=${SUB:-/apps/torque/default/bin/qsub} -export NDATE=${NDATE:-ndate} - - - -#------------------------------------------------------------ -# theia specific hacks for no prod_utils module & no setpdy.sh script -# -export MY_MACHINE=theia -prevday=`$NDATE -24 $PDATE` -export PDYm1=`echo $prevday | cut -c1-8` -ln -s ${NWPRODush}/startmsg.sh ${COMROOT}/startmsg -ln -s ${NWPRODush}/postmsg.sh ${COMROOT}/postmsg -ln -s ${NWPRODush}/prep_step.sh ${COMROOT}/prep_step -ln -s ${NWPRODush}/err_chk.sh ${COMROOT}/err_chk -export PATH=$PATH:${COMROOT} -export utilscript=${utilscript:-${NWPRODush}} # err_chk calls postmsg.sh - # directly so need to override - # utilscript location for theia -#------------------------------------------------------------ -# Execute job -# -$JOBGLOBAL/JGDAS_VERFOZN - -exit - diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_wcoss_c.sh b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_wcoss_c.sh new file mode 100755 index 000000000..e16500899 --- /dev/null +++ b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_wcoss_c.sh @@ -0,0 +1,86 @@ +#!/bin/ksh + +#BSUB -o gdas_verfozn.o%J +#BSUB -e gdas_verfozn.o%J +#BSUB -J gdas_verfozn +#BSUB -q dev +#BSUB -M 100 +#BSUB -W 00:05 +#BSUB -P GFS-DEV +#BSUB -R "select[mem>100] rusage[mem=100]" + +##BSUB -cwd /gpfs/hps/ptmp/Edward.Safford +##BSUB -cwd ${PWD} + +##------------------------------------------------------------ +## This is the test driver script for the wcoss/cray systems +## to run the JGDAS_VERFOZN job. +##------------------------------------------------------------ + +set -x +export OZNMON_NEW_HDR=${OZN_NEW_HDR:-0} +export PDATE=${PDATE:-2019083100} +export NET=${NET:-gfs} +export RUN=${RUN:-gdas} + +export PDY=`echo $PDATE | cut -c1-8` +export cyc=`echo $PDATE | cut -c9-10` +export job=gdas_verfozn.${cyc} +export pid=${pid:-$$} +export jobid=${job}.${pid} +export envir=${envir:-test} + +export DATAROOT=${DATAROOT:-/gpfs/hps3/emc/da/noscrub/${LOGNAME}/test_data} +export COMROOT=/gpfs/hps2/ptmp/${LOGNAME}/com +export OZN_WORK_DIR=${OZN_WORK_DIR:-/gpfs/hps2/stmp/${LOGNAME}/oznmon.${pid}} + +#------------------------------------------------------------ +# Specify versions +# +export gdas_oznmon_ver=v2.0.0 +export oznmon_shared_ver=v2.0.0 + + +############################################################# +# Load modules +############################################################# +. $MODULESHOME/init/ksh + +module load prod_util +module load util_shared + +module list + + +#------------------------------------------------------------ +# WCOSS environment settings +# +export POE=YES + +#------------------------------------------------------------ +# Set user specific variables +# +export OZNMON_SUFFIX=${OZNMON_SUFFIX:-testozn} +export NWTEST=${NWTEST:-/gpfs/hps3/emc/da/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/nwprod} + +export HOMEgdas_ozn=${NWTEST}/gdas_oznmon.${gdas_oznmon_ver} +export PARMgdas_ozn=${HOMEgdas_ozn}/parm +export SCRgdas_ozn=${HOMEgdas_ozn}/scripts +export FIXgdas_ozn=${HOMEgdas_ozn}/fix +JOBgdas_ozn=${HOMEgdas_ozn}/jobs + +export HOMEgfs_ozn=${HOMEgfs_ozn:-${HOMEgdas_ozn}} +export PARMgfs_ozn=${PARMgfs_ozn:-${PARMgdas_ozn}} +export FIXgfs_ozn=${FIXgfs_ozn:-${FIXgdas_ozn}} + +export HOMEoznmon=${NWTEST}/oznmon_shared.${oznmon_shared_ver} +export COM_IN=${COM_IN:-$DATAROOT} +export OZN_TANKDIR=${OZN_TANKDIR:-${COMROOT}/${OZNMON_SUFFIX}} + +#------------------------------------------------------------ +# Execute job +# +${JOBgdas_ozn}/JGDAS_VERFOZN + +exit + diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_wcoss_d.sh b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_wcoss_d.sh new file mode 100755 index 000000000..2c54897e0 --- /dev/null +++ b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/driver/test_jgdas_verfozn_wcoss_d.sh @@ -0,0 +1,116 @@ +#!/bin/ksh + +#BSUB -o gdas_verfozn.o%J +#BSUB -e gdas_verfozn.o%J +#BSUB -J gdas_verfozn +#BSUB -q dev_shared +#BSUB -n 1 +#BSUB -R affinity[core] +#BSUB -M 500 +#BSUB -W 00:05 +#BSUB -P GFS-DEV + +##------------------------------------------------------------ +## This is the test driver script for the wcoss/ibm systems +## to run the JGDAS_VERFOZN job. +##------------------------------------------------------------ + +set -x + +export OZNMON_NEW_HDR=${OZN_NEW_HDR:-0} + +#------------------------------------------------------------- +# PDATE settings for this test driver script correspond to +# available data in the $DATAROOT space (defined below). +# References to netcdf and binary indicate available files in +# the test_data space. +# +#export PDATE=${PDATE:-2019083100} # netcdf +export PDATE=${PDATE:-2018091706} # binary +export NET=${NET:-gfs} +export RUN=${RUN:-gdas} + + +export PDY=`echo $PDATE | cut -c1-8` +export cyc=`echo $PDATE | cut -c9-10` +export job=gdas_verfozn.${cyc} +export pid=${pid:-$$} +export jobid=${job}.${pid} +export envir=${envir:-test} +export DATAROOT=${DATAROOT:-/gpfs/dell2/emc/modeling/noscrub/${LOGNAME}/test_data} +export COMROOT=/gpfs/dell2/ptmp/${LOGNAME}/com +export OZN_WORK_DIR=${OZN_WORK_DIR:-/gpfs/dell2/stmp/${LOGNAME}/oznmon.${pid}} + +#------------------------------------------------------------ +# Specify versions +# +export gdas_oznmon_ver=v2.0.0 +export oznmon_shared_ver=v2.0.0 + + +#------------------------------------------------------------ +# Load modules +# +#. /usrx/local/Modules/3.2.9/init/ksh +#module use /nwprod2/modulefiles + +shell=ksh +source /usrx/local/prod/lmod/lmod/init/${shell} + +MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core +MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/core_third +MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/defs +MODULEPATH=${MODULEPATH}:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod +export MODULEPATH=${MODULEPATH}:/usrx/local/dev/modulefiles + +module purge + +module load lsf/10.1 +module load ips/18.0.1.163 +module load impi/18.0.1 +module load prod_util/1.1.0 +module load grib_util/1.1.0 +module load util_shared/1.1.0 + + +module list + + +#------------------------------------------------------------ +# WCOSS environment settings +# +export POE=YES + + +#------------------------------------------------------------ +# Set user specific variables +# +export OZNMON_SUFFIX=${OZNMON_SUFFIX:-testozn} +export NWTEST=${NWTEST:-/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/ProdGSI/util/Ozone_Monitor/nwprod} +export HOMEgdas_ozn=${NWTEST}/gdas_oznmon.${gdas_oznmon_ver} +export PARMgdas_ozn=${HOMEgdas_ozn}/parm +export FIXgdas_ozn=${FIXgdas_ozn:-${HOMEgdas_ozn}/fix} + + +export HOMEgfs_ozn=${HOMEgfs_ozn:-${HOMEgdas_ozn}} +export PARMgfs_ozn=${PARMgfs_ozn:-${PARMgdas_ozn}} +export FIXgfs_ozn=${FIXgfs_ozn:-${FIXgdas_ozn}} + +export JOBGLOBAL=${JOBGLOBAL:-${HOMEgdas_ozn}/jobs} +export HOMEoznmon=${HOMEoznmon:-${NWTEST}/oznmon_shared.${shared_oznmon_ver}} + +#export SCRgdas_ozn=${HOMEgdas_ozn}/scripts +#JOBgdas_ozn=${HOMEgdas_ozn}/jobs + +export HOMEoznmon=${NWTEST}/oznmon_shared.${oznmon_shared_ver} +export COM_IN=${COM_IN:-$DATAROOT} +export OZN_TANKDIR=${OZN_TANKDIR:-${COMROOT}/${OZNMON_SUFFIX}} + + +#------------------------------------------------------------ +# Execute job +# +${JOBGLOBAL}/JGDAS_VERFOZN + +exit + diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/fix/gdas_oznmon_satype.txt b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/fix/gdas_oznmon_satype.txt index af2ac1952..42951f326 100644 --- a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/fix/gdas_oznmon_satype.txt +++ b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/fix/gdas_oznmon_satype.txt @@ -1 +1 @@ -gome_metop-a gome_metop-b omi_aura sbuv2_n19 +gome_metop-a gome_metop-b omi_aura sbuv2_n19 ompslp_npp ompsnp_npp ompstc8_npp diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/jobs/JGDAS_VERFOZN b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/jobs/JGDAS_VERFOZN index c01d1aa79..cc0754954 100755 --- a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/jobs/JGDAS_VERFOZN +++ b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/jobs/JGDAS_VERFOZN @@ -1,64 +1,37 @@ #!/bin/sh - -#--------------------------------------------------------------- +############################################################# # Set up environment for GDAS Ozone Monitor job -# +############################################################# set -xa echo `date` $0 `date -u` begin export PS4='$SECONDS + ' -export RUN_ENVIR=${RUN_ENVIR:-nco} -export envir=${envir:-test} - -#------------------------------ +############################### # Specify NET and RUN name -# +############################## export NET=${NET:-gfs} export RUN=${RUN:-gdas} -#--------------------------------------------------------------- +########################################################### # obtain unique process id (pid) and make temp directories -# +########################################################### export pid=$$ export outid=${outid:-"LL$job"} -export jobid=${jobid:-"${outid}.o${pid}"} - -export DATAROOT=${DATAROOT:-/tmpnwprod2} -export DATA=${DATA:-${DATAROOT}/${jobid}} +export DATA=${DATA:-${DATAROOT}/${jobid:?}} export OZNMON_SUFFIX=${OZNMON_SUFFIX:-${NET}} -export COMROOT=${COMROOT:-/gpfs/hps/nco/ops/com} -#mkdir -p $DATA -#cd $DATA +mkdir -p $DATA +cd $DATA -#------------------------------------- -# File To Log Msgs -# -export jlogdir=${jlogdir:-${COMROOT}/logs/jlogfiles} -if [[ ! -d ${jlogdir} ]]; then - mkdir -p ${jlogdir} -fi -export jlogfile=${jlogfile:-${jlogdir}/jlogfile.${job}.${pid}} - -#------------------------------------- +#################################### # Determine Job Output Name on System -# +#################################### export pgmout="OUTPUT.${pid}" export pgmerr=errfile export cycle=t${cyc}z -#---------------------------------------------- -# SENDECF - Flag Events on ECF -# SENDCOM - Copy Files From TMPDIR to $COMOUT -# SENDDBN - Issue DBNet Client Calls -# VERBOSE - Specify Verbose Output in exglobal -# -export SENDCOM=${SENDCOM:-YES} -export SENDDBN=${SENDDBN:-NO} -export SENDECF=${SENDECF:-NO} -export VERBOSE=${VERBOSE:-YES} #---------------------------------- # Set up the UTILITIES @@ -70,12 +43,12 @@ export utilexec=${utilexec:-${UTILROOT}/exec} #--------------------------------------------- # Specify Execution Areas # -export HOMEgdas_ozn=${HOMEgdas_ozn:-${NWROOT}/gdas.$gdas_oznmon_ver} -export PARMgdas_ozn=${PARMgdas_ozn:-$HOMEgdas_ozn/parm} -export SCRgdas_ozn=${SCRgdas_ozn:-$HOMEgdas_ozn/scripts} -export FIXgdas_ozn=${FIXgdas_ozn:-$HOMEgdas_ozn/fix} +export HOMEgdas_ozn=${HOMEgfs_ozn:-${NWROOT}/gfs.$gfs_ver} +export PARMgdas_ozn=${PARMgfs_ozn:-$HOMEgfs_ozn/parm/mon} +export SCRgdas_ozn=${SCRgfs_ozn:-$HOMEgfs_ozn/scripts} +export FIXgdas_ozn=${FIXgfs_ozn:-$HOMEgfs_ozn/fix/gdas} -export HOMEoznmon=${HOMEoznmon:-${NWROOT}/global_shared.${shared_oznmon_ver}} +export HOMEoznmon=${HOMEoznmon:-${HOMEgfs_ozn}} export EXECoznmon=${EXECoznmon:-$HOMEoznmon/exec} export FIXoznmon=${FIXoznmon:-${HOMEoznmon}/fix} export USHoznmon=${USHoznmon:-$HOMEoznmon/ush} @@ -87,32 +60,36 @@ export USHoznmon=${USHoznmon:-$HOMEoznmon/ush} . ${PARMgdas_ozn}/gdas_oznmon.parm -#-------------------------------------------- -# Run setpdy and initialize PDY variables -# -# Question: is setpdy necessary? -# -if [[ $MY_MACHINE != "theia" ]]; then - setpdy.sh - . ./PDY -fi +############################################# +# determine PDY and cyc for previous cycle +############################################# + +cdate=`${NDATE} -6 ${PDY}${cyc}` +echo 'pdate = ${pdate}' + +export P_PDY=`echo ${cdate} | cut -c1-8` +export p_cyc=`echo ${cdate} | cut -c9-10` #--------------------------------------------- # COMOUT - WHERE GSI OUTPUT RESIDES # OZN_TANKDIR - WHERE OUTPUT DATA WILL RESIDE # echo "pre-assignment, OZN_TANKDIR = $OZN_TANKDIR" -export OZN_TANKDIR=${OZN_TANKDIR:-${COMROOT}/${NET}/${envir}} -export TANKverf_ozn=${TANKverf_ozn:-${OZN_TANKDIR}/${RUN}.${PDY}/oznmon} -export TANKverf_oznM1=${TANKverf_oznM1:-${OZN_TANKDIR}/${RUN}.${PDYm1}/oznmon} +export TANKverf_ozn=${TANKverf_ozn:-${OZN_TANKDIR}/${RUN}.${PDY}/${cyc}/oznmon} +export TANKverf_oznM1=${TANKverf_oznM1:-${OZN_TANKDIR}/${RUN}.${P_PDY}/${p_cyc}/oznmon} export COM_IN=${COM_IN:-${COMROOT}/${NET}/${envir}} -export COMIN=${COMIN:-${COM_IN}/${RUN}.${PDY}} +export COMIN=${COMIN:-${COM_IN}/${RUN}.${PDY}/${cyc}} if [[ ! -d ${TANKverf_ozn} ]]; then mkdir -p -m 775 $TANKverf_ozn fi -env +#--------------------------------------- +# set up validation file +# +if [[ $VALIDATE_DATA -eq 1 ]]; then + export ozn_val_file=${ozn_val_file:-${FIXgdas_ozn}/gdas_oznmon_base.tar} +fi #--------------------------------------- # Set necessary environment variables @@ -121,24 +98,23 @@ export OZN_AREA=${OZN_AREA:-glb} export oznstat=${oznstat:-$COMIN/gdas.t${cyc}z.oznstat} -msg="JOB HAS STARTED" -postmsg "$jlogfile" "$msg" #------------------------------------------------------- # Execute the script. # ${OZNMONSH:-${SCRgdas_ozn}/exgdas_vrfyozn.sh.ecf} ${PDY} ${cyc} -iret=$? +err=$? +[[ $err -ne 0 ]] && exit $err -echo "iret = $iret" - -msg="JOB COMPLETED NORMALLY" -if [[ $iret != 0 ]]; then - msg="WARNING: JOB DID NOT COMPLETE NORMALLY" +################################ +# Remove the Working Directory +################################ +KEEPDATA=${KEEPDATA:-YES} +cd $DATAROOT +if [ ${KEEPDATA} = NO ] ; then + rm -rf $DATA fi -postmsg "$jlogfile" "$msg" - date diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/parm/gdas_oznmon.parm b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/parm/gdas_oznmon.parm index 5b3f08287..d5a2070c4 100644 --- a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/parm/gdas_oznmon.parm +++ b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/parm/gdas_oznmon.parm @@ -4,4 +4,5 @@ export LITTLE_ENDIAN=${LITTLE_ENDIAN:-0} export COMPRESS=${COMPRESS:-gzip} export UNCOMPRESS=${UNCOMPRESS:-gunzip} +export VALIDATE_DATA=${VALIDATE_DATA:-1} export Z=${Z:-gz} diff --git a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/scripts/exgdas_vrfyozn.sh.ecf b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/scripts/exgdas_vrfyozn.sh.ecf index a9304aba8..8a937e1be 100755 --- a/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/scripts/exgdas_vrfyozn.sh.ecf +++ b/util/Ozone_Monitor/nwprod/gdas_oznmon.v2.0.0/scripts/exgdas_vrfyozn.sh.ecf @@ -1,4 +1,7 @@ #/bin/sh + +set -ax + ################################################################################ #### UNIX Script Documentation Block # . . @@ -8,10 +11,9 @@ # Author: Ed Safford Org: NP23 Date: 2012-01-18 # # Abstract: This script runs the data extract/validation portion of the -# RadMon package. +# OznMon package. # # Script history log: -# 2012-01-18 Ed Safford # # Input script positional parameters: # 1 Current analysis date in yyyymmddhh format @@ -19,41 +21,6 @@ # 2 cycle time in cc format # defaults to cyc; required # -# Imported Shell Variables: -# RAD_AREA flag for global or regional -# TANKDIR repository for oznmon data files -# FIXgdas fixed file directory, gdas specific -# FIXoznmon oznmon fixed file directory -# USHoznmon oznmon scripts directory -# PDY processing day; -# overridden by 1 -# cyc processing cycle; -# overridden by 2 -# LITTLE_ENDIAN Flag to indicate LE machine -# defaults to 0 (big endian) -# -# Exported Shell Variables: -# RAD_AREA flag for global or regional -# PDATE Processing date -# MAKE_CTL Signal to make ctl files, set to 1 (on) -# MAKE_DATA Signal to make data files, set to 1 (on) -# USE_ANL Signal to use analysis input files -# in addition to ges files, set to 0 (off) -# USE_MAIL Signal to send error reports by mail, set to 0 (off) -# SATYPE list of satellite/instrument sources to process -# err last return code -# DO_DIAG_RPT Signal to build the diag report, set to 1 (on) -# DO_DATA_RPT Signal to build the data report, set to 1 (on) -# MAIL_TO Mail recipients list, set to "" (no recipients) -# MAIL_CC Mail cc recipients list, set to "" (no recipients) -# -# Modules and files referenced: -# scripts : -# -# programs : $NDATE -# -# fixed data : $SATANGL -# # input data : $oznstat # # output data: @@ -67,20 +34,11 @@ ################################################################################ export scr=exgdas_vrfyozn.sh.ecf -msg="${scr} HAS STARTED" -postmsg "$jlogfile" "$msg" err=0 #------------------------------------------------------------------------------- # Set environment # -export VERBOSE=${VERBOSE:-"NO"} -if [[ "$VERBOSE" = "YES" ]] -then - set -x -fi - - export RUN_ENVIR=${RUN_ENVIR:-nco} export NET=${NET:-gfs} export RUN=${RUN:-gdas} @@ -92,7 +50,7 @@ export cyc=${2:-${cyc:?}} # Directories export OZN_WORK_DIR=${OZN_WORK_DIR:-$(pwd)} -export COM_IN=${COMROOT}/${NET}/${envir} +export COM_IN=${COM_IN:-${COMROOT}/${NET}/${envir}} export COMIN=${COMIN:-$COM_IN/${RUN}.${PDY}} export HOMEgdas_ozn=${HOMEgdas_ozn:-${NWROOT}/gdas.${gdas_oznmon_ver}} @@ -106,21 +64,16 @@ export USHoznmon=${USHoznmon:-$HOMEoznmon/ush} # Filenames export oznstat=${oznstat:-$COMIN/gdas.t${cyc}z.oznstat} +export satype_file=${satype_file:-$FIXgdas_ozn/gdas_oznmon_satype.txt} # Other variables -#export RAD_AREA=${RAD_AREA:-glb} -#export MAKE_CTL=${MAKE_CTL:-1} -#export MAKE_DATA=${MAKE_DATA:-1} #export USE_ANL=${USE_ANL:-1} export PDATE=${PDY}${cyc} -#export DO_DIAG_RPT=${DO_DIAG_RPT:-1} -#export DO_DATA_RPT=${DO_DATA_RPT:-1} -#export USE_MAIL=${USE_MAIL:-0} -#export MAIL_TO=${MAIL_TO:-" "} -#export MAIL_CC=${MAIL_CC:-" "} +export DO_DATA_RPT=${DO_DATA_RPT:-1} export NCP=${NCP:-/bin/cp} export NDATE=${NDATE:-/nwprod/util/exec/ndate} + ################################################################## # ensure work and TANK dirs exist, verify oznstat is available if [[ ! -d ${OZN_WORK_DIR} ]]; then @@ -139,6 +92,7 @@ fi ##################################################################### data_available=0 + if [[ -s ${oznstat} ]]; then data_available=1 @@ -152,34 +106,17 @@ if [[ -s ${oznstat} ]]; then tar -xvf oznstat.$PDATE rm oznstat.$PDATE - #------------------------------------------------------------------ - # Rename the diag files and uncompress - #------------------------------------------------------------------ - -# for type in ${SATYPE}; do -# mv diag_${type}_ges.${PDATE}.${Z} ${type}.${Z} -# ${UNCOMPRESS} ./${type}.${Z} -# -# if [[ $USE_ANL -eq 1 ]]; then -# mv diag_${type}_anl.${PDATE}.${Z} ${type}_anl.${Z} -# ${UNCOMPRESS} ./${type}_anl.${Z} -# fi -# done - - #------------------------------------------------------------------ - # Run the child sccripts. - #------------------------------------------------------------------ -# ${USHoznmon}/radmon_verf_angle.sh ${PDATE} -# rc_angle=$? -# -# ${USHradmon}/radmon_verf_bcoef.sh ${PDATE} -# rc_bcoef=$? -# -# ${USHradmon}/radmon_verf_bcor.sh ${PDATE} -# rc_bcor=$? -# -# ${USHradmon}/radmon_verf_time.sh ${PDATE} -# rc_time=$? + netcdf=0 + count=`ls diag* | grep ".nc4" | wc -l` + if [ $count -gt 0 ] ; then + netcdf=1 + for filenc4 in `ls diag*nc4.gz`; do + file=`echo $filenc4 | cut -d'.' -f1-2`.gz + mv $filenc4 $file + done + fi + + export OZNMON_NETCDF=${netcdf} ${HOMEoznmon}/ush/ozn_xtrct.sh err=$? @@ -190,26 +127,10 @@ else fi - -#if [[ ${data_available} -ne 1 ]]; then -# err=1 -#elif [[ $rc_angle -ne 0 ]]; then -# err=$rc_angle -#elif [[ $rc_bcoef -ne 0 ]]; then -# err=$rc_bcoef -#elif [[ $rc_bcor -ne 0 ]]; then -# err=$rc_bcor -#elif [[ $rc_time -ne 0 ]]; then -# err=$rc_time -#fi - - if [[ "$VERBOSE" = "YES" ]]; then echo "end exgdas_vrfyozn.sh.ecf, exit value = ${err}" fi -msg="${scr} HAS ENDED" -postmsg "$jlogfile" "$msg" set +x exit ${err} diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/modulefiles/dell/OznMonBuild b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/modulefiles/dell/OznMonBuild new file mode 100644 index 000000000..ea48fbadd --- /dev/null +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/modulefiles/dell/OznMonBuild @@ -0,0 +1,18 @@ +#%Module################################################################# +proc ModulesHelp { } { + puts stderr "Set environment variables for WCOSS(dell) ozmon build" +} + +module-whatis "Set environment variables for WCOSS(dell) ozmon build" + +set ver 2.0.2 +set FCOMP ifort + +setenv CF $FCOMP +setenv FC $FCOMP +setenv FFLAGS "-O3 -fp-model strict -convert big_endian -assume byterecl" + +setenv D_FFLAGS "-O3 -fp-model strict -convert big_endian -assume byterecl -debug" +module load ips/18.0.1.163 +module load w3nco/2.0.6 + diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/modulefiles/ibm/OznMonBuild b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/modulefiles/wcoss/OznMonBuild similarity index 100% rename from util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/modulefiles/ibm/OznMonBuild rename to util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/modulefiles/wcoss/OznMonBuild diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/CMakeLists.txt b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/CMakeLists.txt new file mode 100644 index 000000000..d7d502a48 --- /dev/null +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/CMakeLists.txt @@ -0,0 +1,14 @@ +cmake_minimum_required(VERSION 2.6) + file(GLOB OZNMON_HORIZ_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90 ) + set(OZNMON_HORIZ_Fortran_FLAGS "-fp-model strict -assume byterecl -convert big_endian -O3 ") + set_source_files_properties( ${OZNMON_HORIZ_SRC} PROPERTIES COMPILE_FLAGS ${OZNMON_HORIZ_Fortran_FLAGS} ) + set(Util_MODULE_DIR ${PROJECT_BINARY_DIR}/include/oznmon_horiz ) + add_executable(oznmon_horiz.x ${OZNMON_HORIZ_SRC} ) + set_target_properties( oznmon_horiz.x PROPERTIES COMPILE_FLAGS ${OZNMON_HORIZ_Fortran_FLAGS} ) + set_target_properties( oznmon_horiz.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) + include_directories( ${CORE_INCS} ${NCDIAG_INCS} ) + target_link_libraries( oznmon_horiz.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ) + if(BUILD_W3NCO) + add_dependencies( oznmon_horiz.x ${W3NCO_4_LIBRARY} ) + endif() + diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/create_ctl_horiz.f90 b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/create_ctl_horiz.f90 index 1c93cbd9c..4d0e97d5f 100755 --- a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/create_ctl_horiz.f90 +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/create_ctl_horiz.f90 @@ -1,4 +1,4 @@ -subroutine create_ctl_horiz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,& +subroutine create_ctl_horiz(ntype,ptype,var_list,n_levs,iyy,imm,idd,ihh,idhh,& incr,ctl_file,lunctl,rmiss,satname,prs_nlev,& error,iuse,satype,dplat) @@ -8,10 +8,10 @@ subroutine create_ctl_horiz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,& character(3),dimension(12):: mon character(4) obsnum - character(6),dimension(ntype):: ftype + character(6),dimension(ntype):: var_list character(13) stringd character(20) satname - character(10) satype,dplat + character(10) satype,dplat,ptype character(40) ctl_file,grad_file character(80) string @@ -54,7 +54,7 @@ subroutine create_ctl_horiz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,& open(lunctl,file=ctl_file,form='formatted') ! Write header information - grad_file = trim(satname) // stringd // '.ieee_d' + grad_file = trim(satname) // '.' // trim(ptype) // stringd // '.ieee_d' write(lunctl,100) grad_file write(lunctl,110) string = trim(satname) // '.map' @@ -84,8 +84,8 @@ subroutine create_ctl_horiz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,& do i=1,ntype do j=1,n_levs write(obsnum,'(i4)') j - string = trim(ftype(i)) // adjustl(obsnum) - write(lunctl,180) adjustl(string),trim(ftype(i)) + string = trim(var_list(i)) // adjustl(obsnum) + write(lunctl,180) adjustl(string),trim(var_list(i)) 180 format(a10,' 0 0 ',a6) end do end do diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/horiz.f90 b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/horiz.f90 index b3c65d558..60744fdde 100644 --- a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/horiz.f90 +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_horiz.fd/horiz.f90 @@ -9,11 +9,14 @@ program horiz logical first - character(6),dimension(ntype):: ftype + character(6),dimension(ntype):: var_list + character(6),dimension(ntype):: ges_vars + character(6),dimension(ntype):: anl_vars character(8) stid character(20) satname,stringd,satsis character(10) dum,satype,dplat - character(40) string,diag_oz,grad_file,ctl_file + character(40) string,grad_file,ctl_file + character(500) diag_oz integer luname,lungrd,lunctl,lndiag,isave integer iyy,imm,idd,ihh,idhh,incr,iread,irite,iflag @@ -30,7 +33,7 @@ program horiz integer,allocatable,dimension(:):: jmax,jmin real :: tmp_ozmp - integer :: nobs_mls_oncpu + integer :: nobs_mls_oncpu,istatus real,allocatable,dimension(:,:) :: ozmp,ozmr ! Variables for reading satellite data @@ -41,15 +44,26 @@ program horiz type(diag_data_extra_list) ,pointer :: data_extra(:,:) - namelist /input/ satname,iyy,imm,idd,ihh,idhh,incr +! Namelist with defaults + logical :: new_hdr = .true. + character(10) :: ptype = 'ges' + logical :: netcdf = .false. + namelist /input/ satname,iyy,imm,idd,ihh,idhh,incr,new_hdr,ptype,netcdf data luname,lungrd,lunctl,lndiag / 5, 100, 51, 21 / data rmiss /-999./ - data ftype / 'obs', 'ges', 'obsges', 'ozmp' / + + !*************************************************** + ! anl_vars and ges_vars are the lists of variables + ! used in the output GrADS control (.ctl) files + ! + data anl_vars / 'obs', 'anl', 'obsanl', 'ozmp' / + data ges_vars / 'obs', 'ges', 'obsges', 'ozmp' / + data first / .true. / data stringd / '.%y4%m2%d2%h2' / - + !************************************************************************ ! @@ -62,30 +76,38 @@ program horiz write(6,input) write(6,*)' ' -! Create filenames for diagnostic input, GrADS output, and -! GrADS control files + print*, 'netcdf = ', netcdf + print*, 'satname = ', satname +!********************************************** +! Create filenames for diagnostic input, +! GrADS output, and GrADS control files +! write(stringd,100) iyy,imm,idd,ihh 100 format('.',i4.4,3i2.2) - diag_oz = trim(satname) - grad_file= trim(satname) // trim(stringd) // '.ieee_d' - ctl_file = trim(satname) // '.ctl' + + diag_oz = trim(satname) // '.' // trim(ptype) + grad_file = trim(satname) // '.' // trim(ptype) // trim(stringd) // '.ieee_d' + ctl_file = trim(satname) // '.' // trim(ptype) // '.ctl' write(6,*)'diag_oz =',diag_oz write(6,*)'grad_file=',grad_file write(6,*)'ctl_file =',ctl_file -! Open unit to diagnostic file. Read portion of header to -! see if file exists - open(lndiag,file=diag_oz,form='unformatted') - read(lndiag,err=900,end=900) dum - rewind lndiag +!************************ +! Open diagnostic file. +! + call set_netcdf_read( netcdf ) + call open_ozndiag( diag_oz, lndiag, istatus ) + write(6,*) 'istatus from open_ozndiag = ', istatus + + + call read_ozndiag_header( lndiag, header_fix, header_nlev, new_hdr, istatus ) -! File exists. Read header - write(6,*)'call read_diag_header' - call read_diag_header( lndiag, header_fix, header_nlev ) -! Extract observation type, satellite id, and number of levels +!**************************************************** +! Extract observation type, satellite id, num levels +! satype = header_fix%obstype satsis = header_fix%isis dplat = header_fix%id @@ -98,10 +120,9 @@ program horiz n_levs = mls3_levs end if - write(6,*)'satype,dplat,n_levs=',satype,' ',dplat,n_levs + write(6,*)'satype,satsis,dplat,n_levs = ', satype, satsis, dplat, n_levs string = trim(satype)//'_'//trim(dplat) - write(6,*)'string,satname=',string,' ',satname if ( trim(string) /= trim(satname) ) then write(6,*)'***ERROR*** inconsistent instrument types' write(6,*)' satname,string =',satname,' ',string @@ -109,17 +130,20 @@ program horiz endif +!****************************************************** ! Allocate arrays to hold observational information - write(6,*)'allocate arrays' +! allocate ( prs_nlev(n_levs)) - allocate (var(n_levs,ntype), iuse(n_levs), & - error(n_levs)) + allocate (var(n_levs,ntype), iuse(n_levs), error(n_levs)) allocate(maxval(n_levs)) allocate(minobs(n_levs)) allocate(jmax(n_levs)) allocate(jmin(n_levs)) + +!********************************************** ! Extract ozinfo relative index +! do j=1,n_levs error(j) = real( header_nlev(j)%err, 4) prs_nlev(j) = real( header_nlev(j)%pob, 4) @@ -127,13 +151,24 @@ program horiz end do +!********************************************** ! Create GrADS control file - write(6,*)'call create_ctl_horiz' - call create_ctl_horiz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,incr,& +! + if( trim(ptype) == 'ges' )then + var_list = ges_vars + else + var_list = anl_vars + end if + + call create_ctl_horiz(ntype,ptype,var_list, & + n_levs,iyy,imm,idd,ihh,idhh,incr,& ctl_file,lunctl,rmiss,satname,prs_nlev,& error,iuse,satype,dplat) + +!********************************************** ! Loop to read entries in diagnostic file +! iflag = 0 m_levs=n_levs if(index(satype,'mls')/=0 ) then @@ -147,10 +182,15 @@ program horiz lev_nobs=0 end if + + !********************************************** + ! Read a record. If read flag, iflag does not + ! equal zero, exit loopd + ! loopd: do while (iflag == 0) -! Read a record. If read flag, iflag does not equal zero, exit loopd - call read_diag_data( lndiag, header_fix, data_fix, data_nlev, data_extra, iread, iflag ) + call read_ozndiag_data( lndiag, header_fix, data_fix, data_nlev, data_extra, iread, iflag ) + if( iflag /= 0 ) exit loopd nobs=nobs+iread @@ -161,145 +201,172 @@ program horiz allocate(var1(iread,ntype)) end if -! Extract obervation location + !********************************************** + ! Extract obervation location - do iobs=1,iread + do iobs=1,iread - rlat = data_fix(iobs)%lat - rlon = data_fix(iobs)%lon - if(index(satype,'mls')/=0) then - dlat(iobs)=rlat - dlon(iobs)=rlon - end if + rlat = data_fix(iobs)%lat + rlon = data_fix(iobs)%lon + if(index(satype,'mls')/=0) then + dlat(iobs)=rlat + dlon(iobs)=rlon + end if -! Level loop - isave=0 - do j = 1, m_levs + !********************************************** + ! Level loop + ! + isave=0 + do j = 1, m_levs -! If observation was assimilated, save it -! if (data_nlev(j,iobs)%varinv > 1.e-6 ) then isave = 1 obs = data_nlev(j,iobs)%ozobs ges = data_nlev(j,iobs)%ozobs - data_nlev(j,iobs)%ozone_inv obsges = data_nlev(j,iobs)%ozone_inv tmp_ozmp = data_nlev(j,iobs)%toqf -! MLS v2 obs between levels 8 and 23 should be good - if(index(satype,'mls')/=0 .and. j<24 .and. j>7 .and. (obs<1.0e-8 .or. ges<1.0e-8) ) print*, 'obs,ges,omg=',obs,ges,obsges, m_levs,rlat,rlon,iobs -! Set data values to missing flag -! else -! obs = rmiss -! ges = rmiss -! obsges = rmiss -! tmp_ozmp = rmiss -! endif - -! Load into output array - var(j,1) = obs - var(j,2) = ges - var(j,3) = obsges - var(j,4) = tmp_ozmp - if(index(satype,'mls')/=0) then - do i=1,ntype - var1(iobs,i)=var(1,i) !MLS is set to 1 level - end do -! MLS obs between levels 8 and 23 should be good - klev=mod(iobs,n_levs) - if(klev==0) klev=n_levs - if( klev<24 .and. klev>7 ) then - if( (var1(iobs,1)<=0. .or. var1(iobs,1)>100.0) .and. (var1(iobs,1) /= rmiss) ) then !if obs<0. or obs>100 - print*, 'iobs= ', iobs, ' obs is unreasonable', klev, iobs, var(1,1), var1(iobs,1),var1(iobs,3) -! var1(iobs,1)=rmiss -! var1(iobs,2)=rmiss -! var1(iobs,3)=rmiss - end if - if( (var1(iobs,2)<=0. .or. var1(iobs,2)>100.0) .and. (var1(iobs,1) /= rmiss) ) then !if ges<0. or ges>100 - print*, 'iobs= ', iobs, ' ges is unreasonable', klev, iobs, var(1,2), var1(iobs,2),var1(iobs,3) -! var1(iobs,1)=rmiss -! var1(iobs,2)=rmiss -! var1(iobs,3)=rmiss - end if - end if - end if - enddo ! level loop - -! Write GrADS record - if (isave==1) then - if (first) then - first=.false. - open(lungrd,file=grad_file,form='unformatted') - endif - irite=irite+1 - if(index(satype,'mls')==0 ) then !non-MLS case - write(stid,'(i8)') irite - write(lungrd) stid,rlat,rlon,rtim,nlev,nflag - write(lungrd) ((var(j,i),j=1,m_levs),i=1,ntype) - end if - end if - enddo ! do iobs=1,iread - - if(index(satype,'mls')/=0 ) then - allocate(ozmp(n_levs,1000)) - allocate(ozmr(n_levs,1000)) - ozmp=rmiss - ozmr=rmiss - nobs_mls_oncpu=0 - print*, 'total # of MLS obs is: ', iobs-1 - do i=1,iread,n_levs - lev_nobs=lev_nobs+1 !lev_nobs represents the profile ID - nobs_mls_oncpu=nobs_mls_oncpu+1 - write(stid,'(i8)') lev_nobs - write(lungrd) stid,dlat(i),dlon(i),rtim,nlev,nflag - write(lungrd) ((var1(k,j),k=i,i+n_levs-1),j=1,ntype) - do k=i,i+n_levs-1 - klev=mod(k,n_levs) - if(klev==0) klev=n_levs - if(var1(k,4)>0.) then - ozmp(klev,nobs_mls_oncpu)=var1(k,4) - ozmr(klev,nobs_mls_oncpu)=var1(k,1) - end if - if(var1(k,1)>maxval(klev) .and. var1(k,1)/=rmiss ) then - maxval(klev)=var1(k,1) - jmax(klev)=lev_nobs + + !***************************************************** + ! MLS v2 obs between levels 8 and 23 should be good + ! + if( index( satype,'mls' ) /=0 .and. j<24 .and. j>7 & + .and. ( obs<1.0e-8 .or. ges<1.0e-8 ) ) then + print*, 'obs,ges,omg=',obs,ges,obsges, m_levs,rlat,rlon,iobs end if - if(var1(k,1)7 ) then + if( (var1(iobs,1)<=0. .or. var1(iobs,1)>100.0) & + .and. (var1(iobs,1) /= rmiss) ) then ! if obs<0. or obs>100 + print*, 'iobs= ', iobs, ' obs is unreasonable', & + klev, iobs, var(1,1), var1(iobs,1),var1(iobs,3) + end if + + if( (var1(iobs,2)<=0. .or. var1(iobs,2)>100.0) & + .and. (var1(iobs,1) /= rmiss) ) then ! if ges<0. or ges>100 + print*, 'iobs= ', iobs, ' ges is unreasonable', & + klev, iobs, var(1,2), var1(iobs,2),var1(iobs,3) + end if + + end if end if - end do -! write(60,*) stid,dlat(i),dlon(i),rtim,nlev,nflag -! write(60,*) ((var1(k,j),k=i,i+n_levs-1),j=1,ntype) - end do - deallocate(dlat) - deallocate(dlon) - deallocate(var1) - open(10,file='ozmp.dat',form='unformatted') - do k=1,n_levs - write(10) (ozmr(k,i),i=1,nobs_mls_oncpu) - end do - do k=1,n_levs - write(10) (ozmp(k,i),i=1,nobs_mls_oncpu) - end do - close(10) - write(20,*) nobs_mls_oncpu,header_fix%iint - do i=1,nobs_mls_oncpu - write(30,*) i,ozmp(:,i) - end do - deallocate(ozmp) - deallocate(ozmr) - end if + enddo ! level loop + + !***************************************************** + ! Write GrADS record + ! + if (isave==1) then + if (first) then + first=.false. + open(lungrd,file=grad_file,form='unformatted') + endif + + irite=irite+1 + if(index(satype,'mls')==0 ) then !non-MLS case + write(stid,'(i8)') irite + write(lungrd) stid,rlat,rlon,rtim,nlev,nflag + write(lungrd) ((var(j,i),j=1,m_levs),i=1,ntype) + end if + end if + + enddo ! do iobs=1,iread -! End of loop over diagnostic file - enddo loopd + if(index(satype,'mls')/=0 ) then + + allocate(ozmp(n_levs,1000)) + allocate(ozmr(n_levs,1000)) + ozmp=rmiss + ozmr=rmiss + nobs_mls_oncpu=0 + print*, 'total # of MLS obs is: ', iobs-1 + + do i=1,iread,n_levs + lev_nobs=lev_nobs+1 !lev_nobs represents the profile ID + nobs_mls_oncpu=nobs_mls_oncpu+1 + write(stid,'(i8)') lev_nobs + write(lungrd) stid,dlat(i),dlon(i),rtim,nlev,nflag + write(lungrd) ((var1(k,j),k=i,i+n_levs-1),j=1,ntype) + + do k=i,i+n_levs-1 + klev=mod(k,n_levs) + if(klev==0) klev=n_levs + + if(var1(k,4)>0.) then + ozmp(klev,nobs_mls_oncpu)=var1(k,4) + ozmr(klev,nobs_mls_oncpu)=var1(k,1) + end if + + if(var1(k,1)>maxval(klev) .and. var1(k,1)/=rmiss ) then + maxval(klev)=var1(k,1) + jmax(klev)=lev_nobs + end if + + if(var1(k,1)= MAX_OPEN_NCDIAG) then + write(6,*) 'OPEN_RADIAG: ***ERROR*** Cannot open more than ', & + MAX_OPEN_NCDIAG, ' netcdf diag files.' + istatus = -1 + endif + + if ( istatus /= 0 ) then + call nc_diag_read_init(filename,ftin) + istatus=0 + + do i = 1, MAX_OPEN_NCDIAG + + if (ncdiag_open_id(i) < 0) then + + ncdiag_open_id(i) = ftin + ncdiag_open_status(i)%nc_read = .false. + ncdiag_open_status(i)%cur_ob_idx = 1 + + if (allocated(ncdiag_open_status(i)%all_data_fix)) then + deallocate(ncdiag_open_status(i)%all_data_fix) + endif + if (allocated(ncdiag_open_status(i)%all_data_nlev)) then + deallocate(ncdiag_open_status(i)%all_data_nlev) + endif + if (allocated(ncdiag_open_status(i)%all_data_extra)) then + deallocate(ncdiag_open_status(i)%all_data_extra) + endif + + ncdiag_open_status(i)%num_records = nc_diag_read_get_dim(ftin,'nobs') + nopen_ncdiag = nopen_ncdiag + 1 + + write(6,*) '' + write(6,*) 'ncdiag_open_status(i) dump, i = ', i + write(6,*) ' %nc_read = ', ncdiag_open_status(i)%nc_read + write(6,*) ' %cur_ob_idx = ', ncdiag_open_status(i)%cur_ob_idx + write(6,*) ' %num_records= ', ncdiag_open_status(i)%num_records + write(6,*) 'nopen_ncdiag = ', nopen_ncdiag + write(6,*) 'ncdiag_open_id(i) = ', ncdiag_open_id(i) + write(6,*) '' + exit + + endif + + enddo + endif + + call load_file_vars_nc( ftin ) + + else + open(ftin,form="unformatted",file=filename,iostat=istatus) + rewind(ftin) + endif + + end subroutine open_ozndiag + + + !------------------------------------------------------------ + ! subroutine close_ozndiag + !------------------------------------------------------------ + subroutine close_ozndiag(filename, ftin) + character*500, intent(in) :: filename + integer(i_kind), intent(inout) :: ftin + + integer(i_kind) :: id + + if (netcdf) then + id = find_ncdiag_id(ftin) + if (id < 0) then + write(6,*) 'CLOSE_RADIAG: ***ERROR*** ncdiag file ', filename, & + ' was not opened' + endif + call nc_diag_read_close(filename) + ncdiag_open_id(id) = -1 + ncdiag_open_status(id)%nc_read = .false. + ncdiag_open_status(id)%cur_ob_idx = -9999 + ncdiag_open_status(id)%num_records = -9999 + if (allocated(ncdiag_open_status(id)%all_data_fix)) then + deallocate(ncdiag_open_status(id)%all_data_fix) + endif + if (allocated(ncdiag_open_status(id)%all_data_nlev)) then + deallocate(ncdiag_open_status(id)%all_data_nlev) + endif + if (allocated(ncdiag_open_status(id)%all_data_extra)) then + deallocate(ncdiag_open_status(id)%all_data_extra) + endif + nopen_ncdiag = nopen_ncdiag - 1 + + num_global_attrs = 0 + attr_name_mlen = 0 + attr_names = '' + + num_vars = 0 + var_name_mlen = 0 + var_names = '' + + else + close(ftin) + endif + + end subroutine close_ozndiag + !------------------------------------------------------------ - ! Read a header record of a diagnostic file + ! subroutine set_netcdf_read + ! + ! set the use_netcdf flag to read either binary (default) or + ! netcdf formatted diagnostic files. !------------------------------------------------------------ + subroutine set_netcdf_read( use_netcdf ) + logical,intent(in) :: use_netcdf - subroutine read_diag_header( ftin, header_fix, header_nlev ) + + netcdf = use_netcdf + + end subroutine set_netcdf_read + + + !------------------------------------------------------------ + ! read_ozndiag_header + ! + ! Read a header record of a diagnostic file in either + ! NetCDF for binary format. + !------------------------------------------------------------ + subroutine read_ozndiag_header( ftin, header_fix, header_nlev, new_hdr, istatus ) !--- interface integer ,intent(in) :: ftin type(diag_header_fix_list ),intent(out) :: header_fix type(diag_header_nlev_list),pointer :: header_nlev(:) + logical :: new_hdr + integer(i_kind),intent(out) :: istatus + + istatus = 0 + + if ( netcdf ) then + call read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istatus ) + else + call read_ozndiag_header_bin( ftin, header_fix, header_nlev, new_hdr, istatus ) + endif + + print*, 'ftin = ', ftin + print*, 'header_fix%isis = ', header_fix%isis + print*, 'header_fix%id = ', header_fix%id + print*, 'header_fix%obstype = ', header_fix%obstype + print*, 'header_fix%jiter = ', header_fix%jiter + print*, 'header_fix%nlevs = ', header_fix%nlevs + print*, 'header_fix%ianldate = ', header_fix%ianldate + print*, 'header_fix%iint = ', header_fix%iint + print*, 'header_fix%ireal = ', header_fix%ireal + print*, 'header_fix%iextra = ', header_fix%iextra + + print*, 'istatus = ', istatus + print*, '' + + end subroutine read_ozndiag_header + + + + !------------------------------------------------------------ + ! subroutine read_ozndiag_header_nc + !------------------------------------------------------------ + subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istatus ) + + !--- interface + + integer ,intent(in) :: ftin + type(diag_header_fix_list ),intent(out) :: header_fix + type(diag_header_nlev_list),pointer :: header_nlev(:) + logical :: new_hdr + integer(i_kind),intent(out) :: istatus + + !--- variables + + integer,save :: nlevs_last = -1 + + character(len=10):: sat,obstype + character(len=20):: isis + integer(i_kind):: jiter,nlevs + integer(i_kind),dimension(:),allocatable :: iouse + real(r_double),dimension(:),allocatable :: pobs,gross,tnoise + + integer(i_kind) :: nsdim,k,idate + integer(i_kind),dimension(:),allocatable :: iuse_flag + integer(i_kind) :: analysis_use_flag,idx + + + istatus = 0 + + !--- get global attr + ! + ! This may look like overkill with a check on each variable + ! name, but due to the genius of the ncdiag library, a + ! failure on these read operations is fatal, because, reasons + ! I guess. Thus, this abundance of caution. + ! + if( verify_var_name_nc( "date_time" ) ) then + call nc_diag_read_get_global_attr(ftin, "date_time", idate) + else + write(6,*) 'WARNING: unable to read global var data_time from file ' + end if + + if( verify_var_name_nc( "Satellite_Sensor" ) ) then + call nc_diag_read_get_global_attr(ftin, "Satellite_Sensor", isis) + else + write(6,*) 'WARNING: unable to read global var Satellite_Sensor from file ' + end if + + if( verify_var_name_nc( "Satellite" ) ) then + call nc_diag_read_get_global_attr(ftin, "Satellite", sat) + else + write(6,*) 'WARNING: unable to read global var Satellite from file ' + end if + + if( verify_var_name_nc( "Observation_type" ) ) then + call nc_diag_read_get_global_attr(ftin, "Observation_type", obstype) ; + else + write(6,*) 'WARNING: unable to read global var Observation_type from file ' + end if + + if( verify_var_name_nc( "Number_of_state_vars" ) ) then + call nc_diag_read_get_global_attr(ftin, "Number_of_state_vars", nsdim ) + else + write(6,*) 'WARNING: unable to read global var Number_of_state_vars from file ' + end if + + if( verify_var_name_nc( "pobs" ) ) then + call nc_diag_read_get_global_attr(ftin, "pobs", pobs ) + else + write(6,*) 'WARNING: unable to read global var pobs from file ' + end if + + if( verify_var_name_nc( "gross" ) ) then + call nc_diag_read_get_global_attr(ftin, "gross", gross ) + else + write(6,*) 'WARNING: unable to read global var gross from file ' + end if + + if( verify_var_name_nc( "tnoise" ) ) then + call nc_diag_read_get_global_attr(ftin, "tnoise", tnoise ) + else + write(6,*) 'WARNING: unable to read global var tnoise from file ' + end if + + + !------------------------------------------------------------------- + ! The Anaysis_Use_Flag in the netcdf file resides in the + ! obs data rather than global (equivalent of binary file header + ! location. So we need read that in a different way. Also, iuse + ! assignment by level is not possible, so the first value is good + ! for all (or so I've been told). + + idx = find_ncdiag_id(ftin) + + if( verify_var_name_nc( "Analysis_Use_Flag" ) ) then + if( ncdiag_open_status(idx)%num_records > 0 ) then + allocate( iuse_flag( ncdiag_open_status(idx)%num_records )) + + call nc_diag_read_get_var( ftin, 'Analysis_Use_Flag', iuse_flag ) + analysis_use_flag = iuse_flag(1) + + deallocate( iuse_flag ) + else + analysis_use_flag = -1 + end if + else + write(6,*) 'WARNING: unable to read global var Analysis_Use_Flag from file ' + end if + + nlevs = SIZE( pobs ) + + header_fix%isis = isis + header_fix%id = sat + header_fix%obstype = obstype +! header_fix%jiter = jiter ! This is not in the NetCDF file. It's not + ! used by the OznMon so, fortunately, no loss. + header_fix%nlevs = nlevs + header_fix%ianldate = idate + + !--- allocate if necessary + + if( header_fix%nlevs /= nlevs_last )then + if( nlevs_last > 0 )then + deallocate( header_nlev ) + endif + allocate( header_nlev( header_fix%nlevs ) ) + nlevs_last = header_fix%nlevs + endif + + !--- read header (level part) + do k=1,header_fix%nlevs + header_nlev(k)%pob = pobs(k) + header_nlev(k)%grs = gross(k) + header_nlev(k)%err = tnoise(k) + header_nlev(k)%iouse = analysis_use_flag + + end do + deallocate( pobs,gross,tnoise ) + + + end subroutine read_ozndiag_header_nc + + + + !------------------------------------------------------------ + ! subroutine read_ozndiag_header_bin + !------------------------------------------------------------ + subroutine read_ozndiag_header_bin( ftin, header_fix, header_nlev, new_hdr, istatus ) + + !--- interface + + integer ,intent(in) :: ftin + type(diag_header_fix_list ),intent(out) :: header_fix + type(diag_header_nlev_list),pointer :: header_nlev(:) + logical :: new_hdr + integer(i_kind),intent(out) :: istatus + + !--- variables integer,save :: nlevs_last = -1 - integer :: ilev,k + integer :: ilev,k,ioff0 character(len=10):: id,obstype character(len=20):: isis integer(i_kind):: jiter,nlevs,ianldate,iint,ireal,iextra integer(i_kind),dimension(:),allocatable:: iouse real(r_single),dimension(:),allocatable:: pob,grs,err + istatus = 0 + !--- read header (fix part) + !--- the new header format contains one additional integer value + ! + if ( new_hdr ) then + read(ftin) isis,id,obstype,jiter,nlevs,ianldate,iint,ireal,iextra,ioff0 + else + read(ftin) isis,id,obstype,jiter,nlevs,ianldate,iint,ireal,iextra + endif - read(ftin) isis,id,obstype,jiter,nlevs,ianldate,iint,ireal,iextra header_fix%isis = isis header_fix%id = id header_fix%obstype = obstype @@ -137,10 +508,6 @@ subroutine read_diag_header( ftin, header_fix, header_nlev ) header_fix%ireal = ireal header_fix%iextra = iextra - - print*,'header_fix=', header_fix - print*,'header_fix%mpi=', header_fix%iint - !--- check header if( header_fix%ireal /= IREAL_RESERVE ) then @@ -164,14 +531,14 @@ subroutine read_diag_header( ftin, header_fix, header_nlev ) endif allocate( header_nlev( header_fix%nlevs ) ) nlevs_last = header_fix%nlevs - allocate (pob(header_fix%nlevs)) - allocate (grs(header_fix%nlevs)) - allocate (err(header_fix%nlevs)) - allocate (iouse(header_fix%nlevs)) endif !--- read header (level part) + allocate (pob(header_fix%nlevs)) + allocate (grs(header_fix%nlevs)) + allocate (err(header_fix%nlevs)) + allocate (iouse(header_fix%nlevs)) read(ftin) pob,grs,err,iouse do k=1,header_fix%nlevs header_nlev(k)%pob = pob(k) @@ -180,35 +547,258 @@ subroutine read_diag_header( ftin, header_fix, header_nlev ) header_nlev(k)%iouse = iouse(k) end do deallocate (pob,grs,err,iouse) -! print*,'header_nlev%pob=', header_nlev%pob -! print*,'header_nlev%grs=', header_nlev%grs -! print*,'header_nlev%err=', header_nlev%err -! print*,'header_nlev%iouse=', header_nlev%iouse - - end subroutine read_diag_header + end subroutine read_ozndiag_header_bin !------------------------------------------------------------ - ! Read a data record of the diagnostic file + ! subroutine read_ozndiag_data + ! + ! Read a data record of the diagnostic file in either + ! NetCDF or binary format. !------------------------------------------------------------ - subroutine read_diag_data( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + subroutine read_ozndiag_data( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) !--- interface integer ,intent(in) :: ftin type(diag_header_fix_list ),intent(in) :: header_fix + + !--- NOTE: These pointers are used to build an array numbering + ! iobs. They should be allocated every time this + ! routine is called and should not be deallocated + ! here. + type(diag_data_fix_list), pointer :: data_fix(:) + type(diag_data_nlev_list) ,pointer :: data_nlev(:,:) + type(diag_data_extra_list) ,pointer :: data_extra(:,:) + integer ,intent(out) :: iflag + integer(i_kind) ,intent(out) :: ntobs + + + if ( netcdf ) then + call read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + else + call read_ozndiag_data_bin( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + end if + + end subroutine read_ozndiag_data + + + + !------------------------------------------------ + ! subroutine read_ozndiag_data_nc + !------------------------------------------------ + subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + + !--- interface + + integer ,intent(in) :: ftin + type(diag_header_fix_list ),intent(in) :: header_fix + + !--- NOTE: These pointers are used to build an array numbering + ! iobs. They should be allocated every time this + ! routine is called and should not be deallocated + ! here. + ! type(diag_data_fix_list), pointer :: data_fix(:) type(diag_data_nlev_list) ,pointer :: data_nlev(:,:) type(diag_data_extra_list) ,pointer :: data_extra(:,:) + + integer ,intent(out) :: iflag + integer(i_kind) ,intent(out) :: ntobs + integer(i_kind) :: id,ii,jj,cur_idx + integer(i_kind),allocatable :: Use_Flag(:) + + real(r_single),allocatable :: lat(:) ! latitude (deg) + real(r_single),allocatable :: lon(:) ! longitude (deg) + real(r_single),allocatable :: obstime(:) ! observation time relative to analysis + + real(r_single),allocatable :: ozobs(:) ! observation + real(r_single),allocatable :: ozone_inv(:) ! obs-forecast adjusted + real(r_single),allocatable :: varinv(:) ! inverse obs error + real(r_single),allocatable :: sza(:) ! solar zenith angle + real(r_single),allocatable :: fovn(:) ! scan position (fielf of view) + real(r_single),allocatable :: toqf(:) ! row anomaly index + + logical :: test + + cur_idx = ncdiag_open_id( nopen_ncdiag ) + + !---------------------------------------------------------- + ! The binary file read (the original version of the file + ! read) is designed to be called in a loop, as it reads + ! each obs from the file. + ! + ! The newer netcdf read processes each field for all obs + ! so it can grab all the obs data in a single call. The + ! calling routine in time.f90 uses the iflag value to + ! process the results, and non-zero value to indicate + ! everything has been read. In order to use this same + ! iflag mechanism we'll use the ncdiag_open_status%nc_read + ! field, setting it to true and iflag to 0 after reading, + ! and if nc_read is already true then set iflag to -1. + ! + ! It's not as clear or clean as it should be, so I'll + ! leave this comment in as a note-to-self to redesign this + ! when able. + + + if( ncdiag_open_status(cur_idx)%nc_read == .true. ) then + iflag = -1 + else + iflag = 0 + ntobs = 0 + + id = find_ncdiag_id(ftin) + ntobs = ncdiag_open_status(id)%num_records + + !------------------------------------ + ! allocate the returned structures + ! + allocate( data_fix( ntobs ) ) + allocate( data_nlev( header_fix%nlevs,ntobs ) ) + + + !--------------------------------- + ! load data_fix structure + ! + allocate( lat(ntobs) ) + allocate( lon(ntobs) ) + allocate( obstime(ntobs) ) + + !--- get obs data + ! + ! This may look like overkill with a check on each variable + ! name, but due to the genius of the ncdiag library, a + ! failure on these read operations is fatal, because, reasons + ! I guess. Thus, this abundance of caution. + ! + + if( verify_var_name_nc( "Latitude" ) ) then + call nc_diag_read_get_var( ftin, 'Latitude', lat ) + else + write(6,*) 'WARNING: unable to read global var Latitude from file ' + end if + + if( verify_var_name_nc( "Longitude" ) ) then + call nc_diag_read_get_var( ftin, 'Longitude', lon ) + else + write(6,*) 'WARNING: unable to read global var Longitude from file ' + end if + + if( verify_var_name_nc( "Time" ) ) then + call nc_diag_read_get_var( ftin, 'Time', obstime ) + else + write(6,*) 'WARNING: unable to read global var Time from file ' + end if + + do ii=1,ntobs + data_fix(ii)%lat = lat(ii) + data_fix(ii)%lon = lon(ii) + data_fix(ii)%obstime = obstime(ii) + end do + + deallocate( lat, lon, obstime ) + + !--------------------------------- + ! load data_nlev structure + ! + allocate( data_nlev( header_fix%nlevs,ntobs ) ) + allocate( ozobs(ntobs) ) + allocate( ozone_inv(ntobs) ) + allocate( varinv(ntobs) ) + allocate( sza(ntobs) ) + allocate( fovn(ntobs) ) + allocate( toqf(ntobs) ) + + if( verify_var_name_nc( "Observation" ) ) then + call nc_diag_read_get_var( ftin, 'Observation', ozobs ) + else + write(6,*) 'WARNING: unable to read var Observation from file ' + end if + + if( verify_var_name_nc( "Obs_Minus_Forecast_adjusted" ) ) then + call nc_diag_read_get_var( ftin, 'Obs_Minus_Forecast_adjusted', ozone_inv ) + else + write(6,*) 'WARNING: unable to read var Obs_Minus_Forecast_adjusted from file ' + end if + + if( verify_var_name_nc( "Inverse_Observation_Error" ) ) then + call nc_diag_read_get_var( ftin, 'Inverse_Observation_Error', varinv ) + else + write(6,*) 'WARNING: unable to read var Invers_Observation_Error from file ' + end if + + if( verify_var_name_nc( "Solar_Zenith_Angle" ) ) then + call nc_diag_read_get_var( ftin, 'Solar_Zenith_Angle', sza ) + else + write(6,*) 'WARNING: unable to read var Solar_Zenith_Angle from file ' + end if + + if( verify_var_name_nc( "Scan_Position" ) ) then + call nc_diag_read_get_var( ftin, 'Scan_Position', fovn ) + else + write(6,*) 'WARNING: unable to read var Scan_Position from file ' + end if + + if( verify_var_name_nc( "Row_Anomaly_Index" ) ) then + call nc_diag_read_get_var( ftin, 'Row_Anomaly_Index', toqf ) + else + write(6,*) 'WARNING: unable to read var Row_Anomaly_Index from file ' + end if + + do jj=1,ntobs + do ii=1,header_fix%nlevs + data_nlev(ii,jj)%ozobs = ozobs( jj ) + data_nlev(ii,jj)%ozone_inv = ozone_inv( jj ) + data_nlev(ii,jj)%varinv = varinv( jj ) + data_nlev(ii,jj)%sza = sza( jj ) + data_nlev(ii,jj)%fovn = fovn( jj ) + data_nlev(ii,jj)%toqf = toqf( jj ) + end do + end do + + deallocate( ozobs ) + deallocate( ozone_inv ) + deallocate( varinv ) + deallocate( sza ) + deallocate( fovn ) + deallocate( toqf ) + + ncdiag_open_status(cur_idx)%nc_read = .true. + + end if + + end subroutine read_ozndiag_data_nc + + + + !------------------------------------------------ + ! subroutine read_ozndiag_data_bin + !------------------------------------------------ + subroutine read_ozndiag_data_bin( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + + !--- interface + + integer ,intent(in) :: ftin + type(diag_header_fix_list ),intent(in) :: header_fix + + !--- NOTE: These pointers are used to build an array numbering + ! ntobs. So they should be allocated every time this + ! routine is called and should not be deallocated + ! here. + + type(diag_data_fix_list), pointer :: data_fix(:) + type(diag_data_nlev_list) ,pointer :: data_nlev(:,:) + type(diag_data_extra_list) ,pointer :: data_extra(:,:) + integer ,intent(out) :: iflag integer(i_kind) ,intent(out) :: ntobs integer(i_kind) ,pointer :: data_mpi(:) !--- variables - integer,save :: nlevs_last = -1 integer,save :: iextra_last = -1 integer :: iev,iobs,i,j @@ -218,75 +808,142 @@ subroutine read_diag_data( ftin, header_fix, data_fix, data_nlev, data_extra, nt !--- allocate if necessary - print*, 'nlevs_last, header_fix%nlevs=',nlevs_last,header_fix%nlevs - read(ftin,IOSTAT=iflag) ntobs - print*,'ntobs=',ntobs + write(6,*) ' READ 1, ntobs, iflag = ', ntobs, iflag if( header_fix%nlevs /= nlevs_last )then if( nlevs_last > 0 )then - print*, 'deallocate array data_nlev, data_mpi and data_fix' + write(6,*) ' DEALLOCATING data_nlev, data_fix, data_mpi' deallocate( data_nlev ) deallocate( data_fix ) deallocate( data_mpi ) endif - print*, 'allocate array data_nlev, data_mpi and data_fix' - allocate( data_mpi( ntobs ) ) + allocate( data_fix( ntobs ) ) + allocate( data_mpi( ntobs ) ) allocate( data_nlev( header_fix%nlevs,ntobs ) ) - allocate( tmp_fix(3,ntobs)) - allocate( tmp_nlev(6,header_fix%nlevs,ntobs)) nlevs_last = header_fix%nlevs endif - if (header_fix%iextra /= iextra_last) then - if (iextra_last > 0) then - deallocate (data_extra) - endif - allocate( data_extra(header_fix%iextra,ntobs) ) - allocate( tmp_extra(header_fix%iextra,ntobs) ) - iextra_last = header_fix%iextra + if (iextra_last > 0) then + deallocate (data_extra) endif + allocate( data_extra(header_fix%iextra,ntobs) ) + iextra_last = header_fix%iextra + !--- read a record -! print*, 'iextra=', header_fix%iextra + allocate( tmp_fix( fix_list_size, ntobs )) + allocate( tmp_nlev( nlev_list_size, header_fix%nlevs,ntobs )) + if (header_fix%iextra == 0) then read(ftin,IOSTAT=iflag) data_mpi, tmp_fix, tmp_nlev else + allocate( tmp_extra(header_fix%iextra,ntobs) ) read(ftin,IOSTAT=iflag) data_mpi, tmp_fix, tmp_nlev, tmp_extra + do j=1,ntobs do i=1,header_fix%iextra data_extra(i,j)%extra=tmp_extra(i,j) end do end do + deallocate(tmp_extra) endif + do j=1,ntobs data_fix(j)%lat = tmp_fix(1,j) data_fix(j)%lon = tmp_fix(2,j) data_fix(j)%obstime = tmp_fix(3,j) end do deallocate(tmp_fix) + do j=1,ntobs do i=1,header_fix%nlevs - data_nlev(i,j)%ozobs = tmp_nlev(1,i,j) - data_nlev(i,j)%ozone_inv= tmp_nlev(2,i,j) - data_nlev(i,j)%varinv = tmp_nlev(3,i,j) - data_nlev(i,j)%sza = tmp_nlev(4,i,j) - data_nlev(i,j)%fovn = tmp_nlev(5,i,j) - data_nlev(i,j)%toqf = tmp_nlev(6,i,j) + data_nlev(i,j)%ozobs = tmp_nlev(1,i,j) + data_nlev(i,j)%ozone_inv = tmp_nlev(2,i,j) + data_nlev(i,j)%varinv = tmp_nlev(3,i,j) + data_nlev(i,j)%sza = tmp_nlev(4,i,j) + data_nlev(i,j)%fovn = tmp_nlev(5,i,j) + data_nlev(i,j)%toqf = tmp_nlev(6,i,j) end do end do deallocate(tmp_nlev) -! do iobs=1,ntobs -! print*,'iobs,data_mpi,data_fix%lat,data_nlev%ozobs= ', iobs,data_mpi(iobs),data_fix(iobs)%lat,data_nlev(1,iobs)%ozobs -! end do - nlevs_last = -1 - end subroutine read_diag_data + end subroutine read_ozndiag_data_bin + + + !------------------------------------------------ + ! function find_ncdiag_id + !------------------------------------------------ + integer( i_kind ) function find_ncdiag_id( ftin ) + + integer(i_kind), intent(in) :: ftin + + integer(i_kind) :: i + + find_ncdiag_id = -1 + do i = 1, MAX_OPEN_NCDIAG + if ( ncdiag_open_id(i) == ftin ) then + find_ncdiag_id = i + return + endif + enddo + + return + end function find_ncdiag_id + + + !------------------------------------------------ + ! load_file_vars_nc + ! + ! Query the netcdf file and load all the global + ! and variable attribute names into memory. + !------------------------------------------------ + subroutine load_file_vars_nc( ftin ) + integer(i_kind), intent(in) :: ftin + + + call nc_diag_read_get_global_attr_names(ftin, num_global_attrs, & + attr_name_mlen, attr_names) + + call nc_diag_read_get_var_names(ftin, num_vars, var_name_mlen, var_names) + + + end subroutine load_file_vars_nc + + + !------------------------------------------------ + ! function verify_var_name_nc + !------------------------------------------------ + logical function verify_var_name_nc( test_name ) + + character(*),intent(in) :: test_name + integer(i_kind) :: k + + verify_var_name_nc = .false. + + + do k=1,num_global_attrs + if( test_name == attr_names(k) ) then + verify_var_name_nc = .true. + exit + end if + end do + + if( verify_var_name_nc == .false. ) then + do k=1,num_vars + if( test_name == var_names(k) ) then + verify_var_name_nc = .true. + exit + end if + end do + end if + + end function verify_var_name_nc end module read_diag diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/CMakeLists.txt b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/CMakeLists.txt new file mode 100644 index 000000000..b9f0fa1bd --- /dev/null +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/CMakeLists.txt @@ -0,0 +1,14 @@ +cmake_minimum_required(VERSION 2.6) + file(GLOB OZNMON_TIME_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90 ) + set(OZNMON_TIME_Fortran_FLAGS "-fp-model strict -assume byterecl -convert big_endian -O3 ") + set(Util_MODULE_DIR ${PROJECT_BINARY_DIR}/include/oznmon_time ) + set_source_files_properties( ${OZNMON_TIME_SRC} PROPERTIES COMPILE_FLAGS ${OZNMON_TIME_Fortran_FLAGS} ) + add_executable(oznmon_time.x ${OZNMON_TIME_SRC} ) + set_target_properties( oznmon_time.x PROPERTIES COMPILE_FLAGS ${OZNMON_TIME_Fortran_FLAGS} ) + set_target_properties( oznmon_time.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) + include_directories( ${CORE_INCS} ${NCDIAG_INCS} ) + target_link_libraries( oznmon_time.x ${W3NCO_4_LIBRARY} ${NCDIAG_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${HDF5_LIBRARIES} ) + if(BUILD_W3NCO) + add_dependencies( oznmon_time.x ${W3NCO_4_LIBRARY} ) + endif() + diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/create_ctl_time.f90 b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/create_ctl_time.f90 index 1850a5661..86fb599d1 100755 --- a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/create_ctl_time.f90 +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/create_ctl_time.f90 @@ -1,4 +1,4 @@ -subroutine create_ctl_oz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,& +subroutine create_ctl_oz(ntype,ptype,var_list,n_levs,iyy,imm,idd,ihh,idhh,& incr,ctl_file,lunctl,rmiss,satname,satype,dplat,nregion,& region,rlonmin,rlonmax,rlatmin,rlatmax,nu_nlev,use,error) @@ -10,10 +10,10 @@ subroutine create_ctl_oz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,& character(3),dimension(12):: mon character(3):: clatmin,clatmax character(4):: clonmin,clonmax - character(10),dimension(ntype):: ftype + character(10),dimension(ntype):: var_list character(13) stringd character(20) satname - character(10) satype,dplat + character(10) satype,dplat,ptype character(40) ctl_file,grad_file character(80) string character(40),dimension(nregion):: region @@ -89,7 +89,7 @@ subroutine create_ctl_oz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,& 40 format(i3,'W') ! Write header information - grad_file = trim(satname) // stringd // '.ieee_d' + grad_file = trim(satname) // '.' // trim(ptype) // stringd // '.ieee_d' write(lunctl,100) grad_file write(lunctl,110) write(lunctl,120) rmiss @@ -127,8 +127,8 @@ subroutine create_ctl_oz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,& ! Write data portion of GraDS control file do i=1,ntype - string = trim(ftype(i)) - write(lunctl,190) adjustl(string),trim(ftype(i)) + string = trim(var_list(i)) + write(lunctl,190) adjustl(string),trim(var_list(i)) 190 format(a10,' 0 0 ',a10) end do diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/makefile b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/makefile index 43f6b8f0f..2323c7c2c 100755 --- a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/makefile +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/makefile @@ -21,15 +21,16 @@ SHELL=/bin/sh -BINDIR = ../../exec +BINDIR = $(dir_root)/exec LIBS = $(W3NCO_LIB4) -SRCS = kinds.f90 read_diag.f90 time.f90 create_ctl_time.f90 avgsdv.f90 \ +SRCS = kinds.f90 read_diag.f90 \ + valid.f90 time.f90 create_ctl_time.f90 avgsdv.f90 \ update_ctl_time.f90 -OBJS = kinds.o read_diag.o time.o create_ctl_time.o avgsdv.o \ - update_ctl_time.o +OBJS = kinds.o read_diag.o valid.o time.o \ + create_ctl_time.o avgsdv.o update_ctl_time.o # # ***************************************************************** @@ -59,6 +60,9 @@ kinds.o : kinds.f90 read_diag.o : read_diag.f90 $(CF) $(FFLAGS) -c $(*).f90 +valid.o : valid.f90 + $(CF) $(FFLAGS) -c $(*).f90 + time.o : time.f90 $(CF) $(FFLAGS) -c $(*).f90 diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/read_diag.f90 b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/read_diag.f90 index 97fa23c37..bc8b4d6df 100644 --- a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/read_diag.f90 +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/read_diag.f90 @@ -1,6 +1,6 @@ !$$$ subprogram documentation block ! . . . . -! subprogram: read_diag read ozone diag file +! subprogram: read_diag read ozone diag file ! prgmmr: hliu org: np20 date: 2009-04-15 ! ! abstract: This module contains code to process ozone @@ -12,28 +12,35 @@ ! program history log: ! ! contains -! read_diag_header - read ozone diagnostic file header -! read_diag_data - read ozone diagnostic file data -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ +! read_ozndiag_header - read ozone diagnostic file header +! read_ozndiag_data - read ozone diagnostic file data +! set_netcdf_read - call set_netcdf_read(.true.) to use nc4 hooks, +! otherwise read file as binary format +! open_ozndiag - open a diag file for reading +! close_ozndiag - close an open diag file !------------------------------------------------------------ ! module read_diag - ! USE: - use kinds, only: r_single,i_kind + !--- use ---! + + use kinds, only: r_single,r_double,i_kind + use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_close, & + nc_diag_read_get_dim, nc_diag_read_get_global_attr, & + nc_diag_read_get_var_names, & + nc_diag_read_get_global_attr_names, & + nc_diag_read_get_var + + use ncdr_vars, only: nc_diag_read_check_var + - !--- implicit + !--- implicit ---! implicit none - !--- public & private + !--- public & private ---! private @@ -43,19 +50,22 @@ module read_diag public :: diag_data_nlev_list public :: diag_data_extra_list - public :: read_diag_header - public :: read_diag_data + public :: open_ozndiag + public :: close_ozndiag + public :: read_ozndiag_header + public :: read_ozndiag_data + public :: set_netcdf_read - !--- diagnostic file format - header + !--- diagnostic file format - header ---! type diag_header_fix_list sequence character(len=20) :: isis ! sat and sensor type character(len=10) :: id ! sat type character(len=10) :: obstype ! observation type - integer(i_kind) :: jiter ! outer loop counter + integer(i_kind) :: jiter ! outer loop counter (1 = ges, 3 = anl) integer(i_kind) :: nlevs ! number of levels (layer amounts + total column) per obs integer(i_kind) :: ianldate ! analysis date in YYYYMMDDHH integer(i_kind) :: iint ! mpi task number @@ -71,7 +81,7 @@ module read_diag integer(i_kind):: iouse ! use flag end type diag_header_nlev_list - !--- diagnostic file format - data + !--- diagnostic file format - data ---! integer,parameter :: IREAL_RESERVE = 3 @@ -81,6 +91,7 @@ module read_diag real(r_single) :: lon ! longitude (deg) real(r_single) :: obstime ! observation time relative to analysis end type diag_data_fix_list + integer(i_kind), parameter :: fix_list_size = 3 type diag_data_nlev_list sequence @@ -91,42 +102,402 @@ module read_diag real(r_single) :: fovn ! scan position (field of view) real(r_single) :: toqf ! omi row anomaly index or MLS o3mr precision end type diag_data_nlev_list + integer(i_kind), parameter :: nlev_list_size = 6 type diag_data_extra_list sequence real(r_single) :: extra ! extra information end type diag_data_extra_list + logical,save :: netcdf = .false. + integer(i_kind),save :: num_global_attrs = 0 + integer(i_kind),save :: attr_name_mlen = 0 + integer(i_kind),save :: num_vars = 0 + integer(i_kind),save :: var_name_mlen = 0 + + character(len=:),dimension(:), allocatable,save :: var_names,attr_names + + type ncdiag_status + logical :: nc_read + integer(i_kind) :: cur_ob_idx + integer(i_kind) :: num_records + type(diag_data_fix_list), allocatable :: all_data_fix(:) + type(diag_data_nlev_list), allocatable :: all_data_nlev(:,:) + type(diag_data_extra_list), allocatable :: all_data_extra(:,:,:) + end type ncdiag_status + + integer(i_kind), parameter :: MAX_OPEN_NCDIAG = 2 + integer(i_kind), save :: nopen_ncdiag = 0 + integer(i_kind), dimension(MAX_OPEN_NCDIAG), save :: ncdiag_open_id = (/-1, -1/) + type(ncdiag_status), dimension(MAX_OPEN_NCDIAG), save :: ncdiag_open_status + contains + !------------------------------------------------------------ + ! subroutine open_ozndiag + !------------------------------------------------------------ + subroutine open_ozndiag(filename, ftin, istatus) + character*500, intent(in) :: filename + + !---------------------------------------------------------------------------- + ! Note: This use of ftin here as inout is pretty sloppy. Internally this + ! module should translate ftin (file id from time.f90) into the proper index + ! for use w/in this module. Encapsulation is cleaner than modification of + ! external variables. I got this directly from the src/gsi read_diag.f90 + ! but that doesn't make it right. I'll clean this up when all is working. + ! + integer(i_kind), intent(inout) :: ftin + integer(i_kind), intent(out) :: istatus + integer(i_kind) :: i !,ncd_nobs + + + istatus = -999 + + + if (netcdf) then + + if (nopen_ncdiag >= MAX_OPEN_NCDIAG) then + write(6,*) 'OPEN_RADIAG: ***ERROR*** Cannot open more than ', & + MAX_OPEN_NCDIAG, ' netcdf diag files.' + istatus = -1 + endif + + if ( istatus /= 0 ) then + call nc_diag_read_init(filename,ftin) + istatus=0 + + do i = 1, MAX_OPEN_NCDIAG + + if (ncdiag_open_id(i) < 0) then + + ncdiag_open_id(i) = ftin + ncdiag_open_status(i)%nc_read = .false. + ncdiag_open_status(i)%cur_ob_idx = 1 + + if (allocated(ncdiag_open_status(i)%all_data_fix)) then + deallocate(ncdiag_open_status(i)%all_data_fix) + endif + if (allocated(ncdiag_open_status(i)%all_data_nlev)) then + deallocate(ncdiag_open_status(i)%all_data_nlev) + endif + if (allocated(ncdiag_open_status(i)%all_data_extra)) then + deallocate(ncdiag_open_status(i)%all_data_extra) + endif + + ncdiag_open_status(i)%num_records = nc_diag_read_get_dim(ftin,'nobs') + nopen_ncdiag = nopen_ncdiag + 1 + + write(6,*) '' + write(6,*) 'ncdiag_open_status(i) dump, i = ', i + write(6,*) ' %nc_read = ', ncdiag_open_status(i)%nc_read + write(6,*) ' %cur_ob_idx = ', ncdiag_open_status(i)%cur_ob_idx + write(6,*) ' %num_records= ', ncdiag_open_status(i)%num_records + write(6,*) 'nopen_ncdiag = ', nopen_ncdiag + write(6,*) 'ncdiag_open_id(i) = ', ncdiag_open_id(i) + write(6,*) '' + exit + + endif + + enddo + endif + + call load_file_vars_nc( ftin ) + + else + open(ftin,form="unformatted",file=filename,iostat=istatus) + rewind(ftin) + endif + + end subroutine open_ozndiag + + + !------------------------------------------------------------ + ! subroutine close_ozndiag + !------------------------------------------------------------ + subroutine close_ozndiag(filename, ftin) + character*500, intent(in) :: filename + integer(i_kind), intent(inout) :: ftin + + integer(i_kind) :: id + + if (netcdf) then + id = find_ncdiag_id(ftin) + if (id < 0) then + write(6,*) 'CLOSE_RADIAG: ***ERROR*** ncdiag file ', filename, & + ' was not opened' + endif + call nc_diag_read_close(filename) + ncdiag_open_id(id) = -1 + ncdiag_open_status(id)%nc_read = .false. + ncdiag_open_status(id)%cur_ob_idx = -9999 + ncdiag_open_status(id)%num_records = -9999 + if (allocated(ncdiag_open_status(id)%all_data_fix)) then + deallocate(ncdiag_open_status(id)%all_data_fix) + endif + if (allocated(ncdiag_open_status(id)%all_data_nlev)) then + deallocate(ncdiag_open_status(id)%all_data_nlev) + endif + if (allocated(ncdiag_open_status(id)%all_data_extra)) then + deallocate(ncdiag_open_status(id)%all_data_extra) + endif + nopen_ncdiag = nopen_ncdiag - 1 + + num_global_attrs = 0 + attr_name_mlen = 0 + attr_names = '' + + num_vars = 0 + var_name_mlen = 0 + var_names = '' + + else + close(ftin) + endif + + end subroutine close_ozndiag + !------------------------------------------------------------ - ! Read a header record of a diagnostic file + ! subroutine set_netcdf_read + ! + ! set the use_netcdf flag to read either binary (default) or + ! netcdf formatted diagnostic files. !------------------------------------------------------------ + subroutine set_netcdf_read( use_netcdf ) + logical,intent(in) :: use_netcdf - subroutine read_diag_header( ftin, header_fix, header_nlev ) + + netcdf = use_netcdf + + end subroutine set_netcdf_read + + + !------------------------------------------------------------ + ! read_ozndiag_header + ! + ! Read a header record of a diagnostic file in either + ! NetCDF for binary format. + !------------------------------------------------------------ + subroutine read_ozndiag_header( ftin, header_fix, header_nlev, new_hdr, istatus ) !--- interface integer ,intent(in) :: ftin type(diag_header_fix_list ),intent(out) :: header_fix type(diag_header_nlev_list),pointer :: header_nlev(:) + logical :: new_hdr + integer(i_kind),intent(out) :: istatus + + istatus = 0 + + if ( netcdf ) then + call read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istatus ) + else + call read_ozndiag_header_bin( ftin, header_fix, header_nlev, new_hdr, istatus ) + endif + + print*, 'ftin = ', ftin + print*, 'header_fix%isis = ', header_fix%isis + print*, 'header_fix%id = ', header_fix%id + print*, 'header_fix%obstype = ', header_fix%obstype + print*, 'header_fix%jiter = ', header_fix%jiter + print*, 'header_fix%nlevs = ', header_fix%nlevs + print*, 'header_fix%ianldate = ', header_fix%ianldate + print*, 'header_fix%iint = ', header_fix%iint + print*, 'header_fix%ireal = ', header_fix%ireal + print*, 'header_fix%iextra = ', header_fix%iextra + + print*, 'istatus = ', istatus + print*, '' + + end subroutine read_ozndiag_header + + + + !------------------------------------------------------------ + ! subroutine read_ozndiag_header_nc + !------------------------------------------------------------ + subroutine read_ozndiag_header_nc( ftin, header_fix, header_nlev, new_hdr, istatus ) + + !--- interface + + integer ,intent(in) :: ftin + type(diag_header_fix_list ),intent(out) :: header_fix + type(diag_header_nlev_list),pointer :: header_nlev(:) + logical :: new_hdr + integer(i_kind),intent(out) :: istatus + + !--- variables + + integer,save :: nlevs_last = -1 + + character(len=10):: sat,obstype + character(len=20):: isis + integer(i_kind):: jiter,nlevs + integer(i_kind),dimension(:),allocatable :: iouse + real(r_double),dimension(:),allocatable :: pobs,gross,tnoise + + integer(i_kind) :: nsdim,k,idate + integer(i_kind),dimension(:),allocatable :: iuse_flag + integer(i_kind) :: analysis_use_flag,idx + + + istatus = 0 + + !--- get global attr + ! + ! This may look like overkill with a check on each variable + ! name, but due to the genius of the ncdiag library, a + ! failure on these read operations is fatal, because, reasons + ! I guess. Thus, this abundance of caution. + ! + if( verify_var_name_nc( "date_time" ) ) then + call nc_diag_read_get_global_attr(ftin, "date_time", idate) + else + write(6,*) 'WARNING: unable to read global var data_time from file ' + end if + + if( verify_var_name_nc( "Satellite_Sensor" ) ) then + call nc_diag_read_get_global_attr(ftin, "Satellite_Sensor", isis) + else + write(6,*) 'WARNING: unable to read global var Satellite_Sensor from file ' + end if + + if( verify_var_name_nc( "Satellite" ) ) then + call nc_diag_read_get_global_attr(ftin, "Satellite", sat) + else + write(6,*) 'WARNING: unable to read global var Satellite from file ' + end if + + if( verify_var_name_nc( "Observation_type" ) ) then + call nc_diag_read_get_global_attr(ftin, "Observation_type", obstype) ; + else + write(6,*) 'WARNING: unable to read global var Observation_type from file ' + end if + + if( verify_var_name_nc( "Number_of_state_vars" ) ) then + call nc_diag_read_get_global_attr(ftin, "Number_of_state_vars", nsdim ) + else + write(6,*) 'WARNING: unable to read global var Number_of_state_vars from file ' + end if + + if( verify_var_name_nc( "pobs" ) ) then + call nc_diag_read_get_global_attr(ftin, "pobs", pobs ) + else + write(6,*) 'WARNING: unable to read global var pobs from file ' + end if + + if( verify_var_name_nc( "gross" ) ) then + call nc_diag_read_get_global_attr(ftin, "gross", gross ) + else + write(6,*) 'WARNING: unable to read global var gross from file ' + end if + + if( verify_var_name_nc( "tnoise" ) ) then + call nc_diag_read_get_global_attr(ftin, "tnoise", tnoise ) + else + write(6,*) 'WARNING: unable to read global var tnoise from file ' + end if + + + !------------------------------------------------------------------- + ! The Anaysis_Use_Flag in the netcdf file resides in the + ! obs data rather than global (equivalent of binary file header + ! location. So we need read that in a different way. Also, iuse + ! assignment by level is not possible, so the first value is good + ! for all (or so I've been told). + + idx = find_ncdiag_id(ftin) + + if( verify_var_name_nc( "Analysis_Use_Flag" ) ) then + if( ncdiag_open_status(idx)%num_records > 0 ) then + allocate( iuse_flag( ncdiag_open_status(idx)%num_records )) + + call nc_diag_read_get_var( ftin, 'Analysis_Use_Flag', iuse_flag ) + analysis_use_flag = iuse_flag(1) + + deallocate( iuse_flag ) + else + analysis_use_flag = -1 + end if + else + write(6,*) 'WARNING: unable to read global var Analysis_Use_Flag from file ' + end if + + nlevs = SIZE( pobs ) + + header_fix%isis = isis + header_fix%id = sat + header_fix%obstype = obstype +! header_fix%jiter = jiter ! This is not in the NetCDF file. It's not + ! used by the OznMon so, fortunately, no loss. + header_fix%nlevs = nlevs + header_fix%ianldate = idate + + !--- allocate if necessary + + if( header_fix%nlevs /= nlevs_last )then + if( nlevs_last > 0 )then + deallocate( header_nlev ) + endif + allocate( header_nlev( header_fix%nlevs ) ) + nlevs_last = header_fix%nlevs + endif + + !--- read header (level part) + do k=1,header_fix%nlevs + header_nlev(k)%pob = pobs(k) + header_nlev(k)%grs = gross(k) + header_nlev(k)%err = tnoise(k) + header_nlev(k)%iouse = analysis_use_flag + + end do + deallocate( pobs,gross,tnoise ) + + + end subroutine read_ozndiag_header_nc + + + + !------------------------------------------------------------ + ! subroutine read_ozndiag_header_bin + !------------------------------------------------------------ + subroutine read_ozndiag_header_bin( ftin, header_fix, header_nlev, new_hdr, istatus ) + + !--- interface + + integer ,intent(in) :: ftin + type(diag_header_fix_list ),intent(out) :: header_fix + type(diag_header_nlev_list),pointer :: header_nlev(:) + logical :: new_hdr + integer(i_kind),intent(out) :: istatus + + !--- variables integer,save :: nlevs_last = -1 - integer :: ilev,k + integer :: ilev,k,ioff0 character(len=10):: id,obstype character(len=20):: isis integer(i_kind):: jiter,nlevs,ianldate,iint,ireal,iextra integer(i_kind),dimension(:),allocatable:: iouse real(r_single),dimension(:),allocatable:: pob,grs,err + istatus = 0 + !--- read header (fix part) + !--- the new header format contains one additional integer value + ! + if ( new_hdr ) then + read(ftin) isis,id,obstype,jiter,nlevs,ianldate,iint,ireal,iextra,ioff0 + else + read(ftin) isis,id,obstype,jiter,nlevs,ianldate,iint,ireal,iextra + endif - read(ftin) isis,id,obstype,jiter,nlevs,ianldate,iint,ireal,iextra header_fix%isis = isis header_fix%id = id header_fix%obstype = obstype @@ -137,10 +508,6 @@ subroutine read_diag_header( ftin, header_fix, header_nlev ) header_fix%ireal = ireal header_fix%iextra = iextra - - print*,'header_fix=', header_fix - print*,'header_fix%mpi=', header_fix%iint - !--- check header if( header_fix%ireal /= IREAL_RESERVE ) then @@ -164,14 +531,14 @@ subroutine read_diag_header( ftin, header_fix, header_nlev ) endif allocate( header_nlev( header_fix%nlevs ) ) nlevs_last = header_fix%nlevs - allocate (pob(header_fix%nlevs)) - allocate (grs(header_fix%nlevs)) - allocate (err(header_fix%nlevs)) - allocate (iouse(header_fix%nlevs)) endif !--- read header (level part) + allocate (pob(header_fix%nlevs)) + allocate (grs(header_fix%nlevs)) + allocate (err(header_fix%nlevs)) + allocate (iouse(header_fix%nlevs)) read(ftin) pob,grs,err,iouse do k=1,header_fix%nlevs header_nlev(k)%pob = pob(k) @@ -180,35 +547,258 @@ subroutine read_diag_header( ftin, header_fix, header_nlev ) header_nlev(k)%iouse = iouse(k) end do deallocate (pob,grs,err,iouse) -! print*,'header_nlev%pob=', header_nlev%pob -! print*,'header_nlev%grs=', header_nlev%grs -! print*,'header_nlev%err=', header_nlev%err -! print*,'header_nlev%iouse=', header_nlev%iouse - - end subroutine read_diag_header + end subroutine read_ozndiag_header_bin !------------------------------------------------------------ - ! Read a data record of the diagnostic file + ! subroutine read_ozndiag_data + ! + ! Read a data record of the diagnostic file in either + ! NetCDF or binary format. !------------------------------------------------------------ - subroutine read_diag_data( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + subroutine read_ozndiag_data( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) !--- interface integer ,intent(in) :: ftin type(diag_header_fix_list ),intent(in) :: header_fix + + !--- NOTE: These pointers are used to build an array numbering + ! iobs. They should be allocated every time this + ! routine is called and should not be deallocated + ! here. + type(diag_data_fix_list), pointer :: data_fix(:) + type(diag_data_nlev_list) ,pointer :: data_nlev(:,:) + type(diag_data_extra_list) ,pointer :: data_extra(:,:) + integer ,intent(out) :: iflag + integer(i_kind) ,intent(out) :: ntobs + + + if ( netcdf ) then + call read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + else + call read_ozndiag_data_bin( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + end if + + end subroutine read_ozndiag_data + + + + !------------------------------------------------ + ! subroutine read_ozndiag_data_nc + !------------------------------------------------ + subroutine read_ozndiag_data_nc( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + + !--- interface + + integer ,intent(in) :: ftin + type(diag_header_fix_list ),intent(in) :: header_fix + + !--- NOTE: These pointers are used to build an array numbering + ! iobs. They should be allocated every time this + ! routine is called and should not be deallocated + ! here. + ! type(diag_data_fix_list), pointer :: data_fix(:) type(diag_data_nlev_list) ,pointer :: data_nlev(:,:) type(diag_data_extra_list) ,pointer :: data_extra(:,:) + + integer ,intent(out) :: iflag + integer(i_kind) ,intent(out) :: ntobs + integer(i_kind) :: id,ii,jj,cur_idx + integer(i_kind),allocatable :: Use_Flag(:) + + real(r_single),allocatable :: lat(:) ! latitude (deg) + real(r_single),allocatable :: lon(:) ! longitude (deg) + real(r_single),allocatable :: obstime(:) ! observation time relative to analysis + + real(r_single),allocatable :: ozobs(:) ! observation + real(r_single),allocatable :: ozone_inv(:) ! obs-forecast adjusted + real(r_single),allocatable :: varinv(:) ! inverse obs error + real(r_single),allocatable :: sza(:) ! solar zenith angle + real(r_single),allocatable :: fovn(:) ! scan position (fielf of view) + real(r_single),allocatable :: toqf(:) ! row anomaly index + + logical :: test + + cur_idx = ncdiag_open_id( nopen_ncdiag ) + + !---------------------------------------------------------- + ! The binary file read (the original version of the file + ! read) is designed to be called in a loop, as it reads + ! each obs from the file. + ! + ! The newer netcdf read processes each field for all obs + ! so it can grab all the obs data in a single call. The + ! calling routine in time.f90 uses the iflag value to + ! process the results, and non-zero value to indicate + ! everything has been read. In order to use this same + ! iflag mechanism we'll use the ncdiag_open_status%nc_read + ! field, setting it to true and iflag to 0 after reading, + ! and if nc_read is already true then set iflag to -1. + ! + ! It's not as clear or clean as it should be, so I'll + ! leave this comment in as a note-to-self to redesign this + ! when able. + + + if( ncdiag_open_status(cur_idx)%nc_read == .true. ) then + iflag = -1 + else + iflag = 0 + ntobs = 0 + + id = find_ncdiag_id(ftin) + ntobs = ncdiag_open_status(id)%num_records + + !------------------------------------ + ! allocate the returned structures + ! + allocate( data_fix( ntobs ) ) + allocate( data_nlev( header_fix%nlevs,ntobs ) ) + + + !--------------------------------- + ! load data_fix structure + ! + allocate( lat(ntobs) ) + allocate( lon(ntobs) ) + allocate( obstime(ntobs) ) + + !--- get obs data + ! + ! This may look like overkill with a check on each variable + ! name, but due to the genius of the ncdiag library, a + ! failure on these read operations is fatal, because, reasons + ! I guess. Thus, this abundance of caution. + ! + + if( verify_var_name_nc( "Latitude" ) ) then + call nc_diag_read_get_var( ftin, 'Latitude', lat ) + else + write(6,*) 'WARNING: unable to read global var Latitude from file ' + end if + + if( verify_var_name_nc( "Longitude" ) ) then + call nc_diag_read_get_var( ftin, 'Longitude', lon ) + else + write(6,*) 'WARNING: unable to read global var Longitude from file ' + end if + + if( verify_var_name_nc( "Time" ) ) then + call nc_diag_read_get_var( ftin, 'Time', obstime ) + else + write(6,*) 'WARNING: unable to read global var Time from file ' + end if + + do ii=1,ntobs + data_fix(ii)%lat = lat(ii) + data_fix(ii)%lon = lon(ii) + data_fix(ii)%obstime = obstime(ii) + end do + + deallocate( lat, lon, obstime ) + + !--------------------------------- + ! load data_nlev structure + ! + allocate( data_nlev( header_fix%nlevs,ntobs ) ) + allocate( ozobs(ntobs) ) + allocate( ozone_inv(ntobs) ) + allocate( varinv(ntobs) ) + allocate( sza(ntobs) ) + allocate( fovn(ntobs) ) + allocate( toqf(ntobs) ) + + if( verify_var_name_nc( "Observation" ) ) then + call nc_diag_read_get_var( ftin, 'Observation', ozobs ) + else + write(6,*) 'WARNING: unable to read var Observation from file ' + end if + + if( verify_var_name_nc( "Obs_Minus_Forecast_adjusted" ) ) then + call nc_diag_read_get_var( ftin, 'Obs_Minus_Forecast_adjusted', ozone_inv ) + else + write(6,*) 'WARNING: unable to read var Obs_Minus_Forecast_adjusted from file ' + end if + + if( verify_var_name_nc( "Inverse_Observation_Error" ) ) then + call nc_diag_read_get_var( ftin, 'Inverse_Observation_Error', varinv ) + else + write(6,*) 'WARNING: unable to read var Invers_Observation_Error from file ' + end if + + if( verify_var_name_nc( "Solar_Zenith_Angle" ) ) then + call nc_diag_read_get_var( ftin, 'Solar_Zenith_Angle', sza ) + else + write(6,*) 'WARNING: unable to read var Solar_Zenith_Angle from file ' + end if + + if( verify_var_name_nc( "Scan_Position" ) ) then + call nc_diag_read_get_var( ftin, 'Scan_Position', fovn ) + else + write(6,*) 'WARNING: unable to read var Scan_Position from file ' + end if + + if( verify_var_name_nc( "Row_Anomaly_Index" ) ) then + call nc_diag_read_get_var( ftin, 'Row_Anomaly_Index', toqf ) + else + write(6,*) 'WARNING: unable to read var Row_Anomaly_Index from file ' + end if + + do jj=1,ntobs + do ii=1,header_fix%nlevs + data_nlev(ii,jj)%ozobs = ozobs( jj ) + data_nlev(ii,jj)%ozone_inv = ozone_inv( jj ) + data_nlev(ii,jj)%varinv = varinv( jj ) + data_nlev(ii,jj)%sza = sza( jj ) + data_nlev(ii,jj)%fovn = fovn( jj ) + data_nlev(ii,jj)%toqf = toqf( jj ) + end do + end do + + deallocate( ozobs ) + deallocate( ozone_inv ) + deallocate( varinv ) + deallocate( sza ) + deallocate( fovn ) + deallocate( toqf ) + + ncdiag_open_status(cur_idx)%nc_read = .true. + + end if + + end subroutine read_ozndiag_data_nc + + + + !------------------------------------------------ + ! subroutine read_ozndiag_data_bin + !------------------------------------------------ + subroutine read_ozndiag_data_bin( ftin, header_fix, data_fix, data_nlev, data_extra, ntobs, iflag ) + + !--- interface + + integer ,intent(in) :: ftin + type(diag_header_fix_list ),intent(in) :: header_fix + + !--- NOTE: These pointers are used to build an array numbering + ! ntobs. So they should be allocated every time this + ! routine is called and should not be deallocated + ! here. + + type(diag_data_fix_list), pointer :: data_fix(:) + type(diag_data_nlev_list) ,pointer :: data_nlev(:,:) + type(diag_data_extra_list) ,pointer :: data_extra(:,:) + integer ,intent(out) :: iflag integer(i_kind) ,intent(out) :: ntobs integer(i_kind) ,pointer :: data_mpi(:) !--- variables - integer,save :: nlevs_last = -1 integer,save :: iextra_last = -1 integer :: iev,iobs,i,j @@ -218,75 +808,142 @@ subroutine read_diag_data( ftin, header_fix, data_fix, data_nlev, data_extra, nt !--- allocate if necessary - print*, 'nlevs_last, header_fix%nlevs=',nlevs_last,header_fix%nlevs - read(ftin,IOSTAT=iflag) ntobs - print*,'ntobs=',ntobs + write(6,*) ' READ 1, ntobs, iflag = ', ntobs, iflag if( header_fix%nlevs /= nlevs_last )then if( nlevs_last > 0 )then - print*, 'deallocate array data_nlev, data_mpi and data_fix' + write(6,*) ' DEALLOCATING data_nlev, data_fix, data_mpi' deallocate( data_nlev ) deallocate( data_fix ) deallocate( data_mpi ) endif - print*, 'allocate array data_nlev, data_mpi and data_fix' - allocate( data_mpi( ntobs ) ) + allocate( data_fix( ntobs ) ) + allocate( data_mpi( ntobs ) ) allocate( data_nlev( header_fix%nlevs,ntobs ) ) - allocate( tmp_fix(3,ntobs)) - allocate( tmp_nlev(6,header_fix%nlevs,ntobs)) nlevs_last = header_fix%nlevs endif - if (header_fix%iextra /= iextra_last) then - if (iextra_last > 0) then - deallocate (data_extra) - endif - allocate( data_extra(header_fix%iextra,ntobs) ) - allocate( tmp_extra(header_fix%iextra,ntobs) ) - iextra_last = header_fix%iextra + if (iextra_last > 0) then + deallocate (data_extra) endif + allocate( data_extra(header_fix%iextra,ntobs) ) + iextra_last = header_fix%iextra + !--- read a record -! print*, 'iextra=', header_fix%iextra + allocate( tmp_fix( fix_list_size, ntobs )) + allocate( tmp_nlev( nlev_list_size, header_fix%nlevs,ntobs )) + if (header_fix%iextra == 0) then read(ftin,IOSTAT=iflag) data_mpi, tmp_fix, tmp_nlev else + allocate( tmp_extra(header_fix%iextra,ntobs) ) read(ftin,IOSTAT=iflag) data_mpi, tmp_fix, tmp_nlev, tmp_extra + do j=1,ntobs do i=1,header_fix%iextra data_extra(i,j)%extra=tmp_extra(i,j) end do end do + deallocate(tmp_extra) endif + do j=1,ntobs data_fix(j)%lat = tmp_fix(1,j) data_fix(j)%lon = tmp_fix(2,j) data_fix(j)%obstime = tmp_fix(3,j) end do deallocate(tmp_fix) + do j=1,ntobs do i=1,header_fix%nlevs - data_nlev(i,j)%ozobs = tmp_nlev(1,i,j) - data_nlev(i,j)%ozone_inv= tmp_nlev(2,i,j) - data_nlev(i,j)%varinv = tmp_nlev(3,i,j) - data_nlev(i,j)%sza = tmp_nlev(4,i,j) - data_nlev(i,j)%fovn = tmp_nlev(5,i,j) - data_nlev(i,j)%toqf = tmp_nlev(6,i,j) + data_nlev(i,j)%ozobs = tmp_nlev(1,i,j) + data_nlev(i,j)%ozone_inv = tmp_nlev(2,i,j) + data_nlev(i,j)%varinv = tmp_nlev(3,i,j) + data_nlev(i,j)%sza = tmp_nlev(4,i,j) + data_nlev(i,j)%fovn = tmp_nlev(5,i,j) + data_nlev(i,j)%toqf = tmp_nlev(6,i,j) end do end do deallocate(tmp_nlev) -! do iobs=1,ntobs -! print*,'iobs,data_mpi,data_fix%lat,data_nlev%ozobs= ', iobs,data_mpi(iobs),data_fix(iobs)%lat,data_nlev(1,iobs)%ozobs -! end do - nlevs_last = -1 - end subroutine read_diag_data + end subroutine read_ozndiag_data_bin + + + !------------------------------------------------ + ! function find_ncdiag_id + !------------------------------------------------ + integer( i_kind ) function find_ncdiag_id( ftin ) + + integer(i_kind), intent(in) :: ftin + + integer(i_kind) :: i + + find_ncdiag_id = -1 + do i = 1, MAX_OPEN_NCDIAG + if ( ncdiag_open_id(i) == ftin ) then + find_ncdiag_id = i + return + endif + enddo + + return + end function find_ncdiag_id + + + !------------------------------------------------ + ! load_file_vars_nc + ! + ! Query the netcdf file and load all the global + ! and variable attribute names into memory. + !------------------------------------------------ + subroutine load_file_vars_nc( ftin ) + integer(i_kind), intent(in) :: ftin + + + call nc_diag_read_get_global_attr_names(ftin, num_global_attrs, & + attr_name_mlen, attr_names) + + call nc_diag_read_get_var_names(ftin, num_vars, var_name_mlen, var_names) + + + end subroutine load_file_vars_nc + + + !------------------------------------------------ + ! function verify_var_name_nc + !------------------------------------------------ + logical function verify_var_name_nc( test_name ) + + character(*),intent(in) :: test_name + integer(i_kind) :: k + + verify_var_name_nc = .false. + + + do k=1,num_global_attrs + if( test_name == attr_names(k) ) then + verify_var_name_nc = .true. + exit + end if + end do + + if( verify_var_name_nc == .false. ) then + do k=1,num_vars + if( test_name == var_names(k) ) then + verify_var_name_nc = .true. + exit + end if + end do + end if + + end function verify_var_name_nc end module read_diag diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/time.f90 b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/time.f90 index dff8f75d4..cb90f48fa 100755 --- a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/time.f90 +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/time.f90 @@ -1,340 +1,397 @@ program main - use read_diag - - implicit none - integer ntype,mregion,mls2_levs,mls3_levs - parameter (ntype=4,mregion=25,mls2_levs=37,mls3_levs=55) - - character(10),dimension(ntype):: ftype - character(20) satname,stringd,satsis - character(10) dum,satype,dplat - character(40) string,diag_oz,grad_file,ctl_file - character(40),dimension(mregion):: region - - integer luname,lungrd,lunctl,lndiag,nregion - integer iyy,imm,idd,ihh,idhh,incr,iflag - integer n_levs,j,idsat,i,k,ii,nreg,nlevs,iobs,iread,nobs - integer,dimension(mregion):: jsub - real,allocatable,dimension(:):: prs_nlev - - real pen - real weight,rlat,rlon,rmiss,obs,biascor,obsges,obsgesnbc,rterm - real,dimension(2):: cor_omg - real,dimension(mregion):: rlatmin,rlatmax,rlonmin,rlonmax - - real,allocatable,dimension(:,:):: count,error,use,penalty - real,allocatable,dimension(:,:,:):: omg_cor - - -! Variables for reading ozone data - type(diag_header_fix_list ) :: header_fix - type(diag_header_nlev_list),pointer :: header_nlev(:) - type(diag_data_fix_list ),pointer :: data_fix(:) - type(diag_data_nlev_list ),pointer :: data_nlev(:,:) - type(diag_data_extra_list) ,pointer :: data_extra(:,:) - - - namelist /input/ satname,iyy,imm,idd,ihh,idhh,incr,& - nregion,region,rlonmin,rlonmax,rlatmin,rlatmax - - data luname,lungrd,lunctl,lndiag / 5, 100, 51, 21 / - data rmiss /-999./ - data stringd / '.%y4%m2%d2%h2' / - data ftype / 'count', 'cpen', 'avgomg', 'sdvomg' / - - + use read_diag + use valid + use kinds, only: i_kind + + implicit none + + integer ntype,mregion,mls2_levs,mls3_levs + parameter (ntype=4,mregion=25,mls2_levs=37,mls3_levs=55) + + character(10),dimension(ntype):: var_list + character(10),dimension(ntype):: anl_vars + character(10),dimension(ntype):: ges_vars + character(20) satname,stringd,satsis + character(10) dum,obstype,dplat + character(40) string,grad_file,ctl_file + character(500) diag_oz + character(40) bad_pen_file, bad_cnt_file + character(40),dimension(mregion):: region + + integer luname,lungrd,lunctl,lndiag,nregion + integer lupen, lucnt, fiosp, fiosc + integer iyy,imm,idd,ihh,idhh,incr,iflag,ier,iret + integer n_levs,j,idsat,i,k,ii,nreg,nlevs,iobs,iread,nobs + integer,dimension(mregion):: jsub + real,allocatable,dimension(:):: prs_nlev + + real pen,pbound,cbound + real weight,rlat,rlon,rmiss,obs,biascor,obsges,obsgesnbc,rterm + real,dimension(2):: cor_omg + real,dimension(mregion):: rlatmin,rlatmax,rlonmin,rlonmax + + real,allocatable,dimension(:,:):: cnt,error,use,penalty + real,allocatable,dimension(:,:,:):: omg_cor + logical validate, valid_penalty, valid_count + character(60) penformat,cntformat + + integer( i_kind ) :: istatus + + +! Variables for reading ozone data + type(diag_header_fix_list ) :: header_fix + type(diag_header_nlev_list),pointer :: header_nlev(:) + type(diag_data_fix_list ),pointer :: data_fix(:) + type(diag_data_nlev_list ),pointer :: data_nlev(:,:) + type(diag_data_extra_list) ,pointer :: data_extra(:,:) + +! Namelist with defaults + logical :: new_hdr = .false. + character(10) :: ptype = "ges" + logical :: netcdf = .false. + namelist /input/ satname,iyy,imm,idd,ihh,idhh,incr,& + nregion,region,rlonmin,rlonmax,rlatmin,rlatmax,validate,new_hdr,ptype,netcdf + + data luname,lungrd,lunctl,lndiag,lupen,lucnt / 5, 100, 51, 21, 52, 53 / + data rmiss /-999./ + data stringd / '.%y4%m2%d2%h2' / + data anl_vars / 'cnt', 'cpen', 'avgoma', 'sdvoma' / + data ges_vars / 'cnt', 'cpen', 'avgomg', 'sdvomg' / + + + penformat = "(A15,A7,I3,A8,I1,A10,ES13.7E2,A8,ES13.7E2)" + cntformat = "(A15,A7,I3,A8,I1,A10,F7.2,A8,F7.2)" !************************************************************************ ! ! Initialize variables - nobs=0 - region=' ' - rlatmin=0.; rlatmax=0.; rlonmin=0.; rlonmax=0. + nobs=0 + region=' ' + rlatmin=0.; rlatmax=0.; rlonmin=0.; rlonmax=0. ! Read namelist input - read(luname,input) - write(6,input) - write(6,*)' ' + read(luname,input) + write(6,input) + write(6,*)' ' ! Ensure number of requested regions does not exceed specified upper limit - if (nregion>mregion) then - write(6,*)'***ERROR*** too many regions specified' - write(6,*)' maximum allowed: mregion=',mregion - write(6,*)' user requested: nregion=',nregion - call errexit(91) - endif + if (nregion>mregion) then + write(6,*)'***ERROR*** too many regions specified' + write(6,*)' maximum allowed: mregion=',mregion + write(6,*)' user requested: nregion=',nregion + call errexit(91) + endif ! Create filenames for diagnostic input, GrADS output, and GrADS control files - write(stringd,100) iyy,imm,idd,ihh + write(stringd,100) iyy,imm,idd,ihh 100 format('.',i4.4,3i2.2) - diag_oz = trim(satname) - grad_file= trim(satname) // trim(stringd) // '.ieee_d' - ctl_file = trim(satname) // '.ctl' - write(6,*)'diag_oz =',diag_oz - write(6,*)'grad_file=',grad_file - write(6,*)'ctl_file =',ctl_file + diag_oz = trim(satname) // '.' // trim(ptype) + grad_file = trim(satname) // '.' // trim(ptype) // trim(stringd) // '.ieee_d' + ctl_file = trim(satname) // '.' // trim(ptype) // '.ctl' + + bad_pen_file = 'bad_pen' // trim(stringd) + bad_cnt_file = 'bad_cnt' // trim(stringd) + + write(6,*)'diag_oz =',diag_oz + write(6,*)'grad_file=',grad_file + write(6,*)'ctl_file =',ctl_file + write(6,*)'bad_pen_file =', bad_pen_file + write(6,*)'bad_cnt_file =', bad_cnt_file + write(6,*)'netcdf =', netcdf + call set_netcdf_read( netcdf ) -! Open unit to diagnostic file. Read portion of header to -! see if file exists - open(lndiag,file=diag_oz,form='unformatted') -! open(lndiag,file='omi_aura.txt',status='old') - read(lndiag,err=900,end=900) dum - print*, 'dum=', dum - rewind lndiag + call open_ozndiag( diag_oz, lndiag, istatus ) + if ( istatus /= 0 ) then + write(6,*)'***PROBLEM opening diagnostic file. diag_oz=',diag_oz + write(6,*)'*** exiting with error code 93' + close(lndiag) + call errexit(93) + end if -! File exists. Read header - write(6,*)'call read_diag_header' - call read_diag_header( lndiag, header_fix, header_nlev ) +! File exists. Read header + + call read_ozndiag_header( lndiag, header_fix, header_nlev, new_hdr, istatus ) + ! Extract observation type, satellite id, and number of levels - satype = header_fix%obstype - satsis = header_fix%isis - dplat = header_fix%id - n_levs = header_fix%nlevs - - if(index(satype,'mls2')/=0 ) then - n_levs = mls2_levs - end if - if(index(satype,'mls3')/=0 ) then - n_levs = mls3_levs - end if - - write(6,*)'satype,dplat,n_levs=',satype,' ',dplat,n_levs - - string = trim(satype)//'_'//trim(dplat) - write(6,*)'string,satname=',string,' ',satname - if ( trim(string) /= trim(satname) ) then - write(6,*)'***ERROR*** inconsistent instrument types' - write(6,*)' satname,string =',satname,' ',string - call errexit(92) - endif - - -! Allocate arrays to hold observational information - write(6,*)' ' - write(6,*)'allocate arrays' - allocate ( prs_nlev(n_levs)) - allocate (omg_cor(n_levs,mregion,2), & - count(n_levs,mregion), & + obstype = header_fix%obstype + satsis = header_fix%isis + dplat = header_fix%id + n_levs = header_fix%nlevs + + !---------------------------------------------------------------- + ! mls = microwave limb sounder + ! + ! This assignment potentially overrides the nlevs values from + ! the file header. We don't currently have any mls data + ! available so it doesn't do any harm. I'll leave this note + ! here as a reminder if/when we get mls instrument data this + ! may need to change if the header level number doesn't agree + ! with these settings. + ! + if(index(obstype,'mls2')/=0 ) then + n_levs = mls2_levs + end if + if(index(obstype,'mls3')/=0 ) then + n_levs = mls3_levs + end if + + + string = trim(obstype)//'_'//trim(dplat) + if ( trim(string) /= trim(satname) ) then + write(6,*)'***ERROR*** inconsistent instrument types' + write(6,*)' satname,string =',satname,' ',string + call errexit(92) + endif + +!------------------------------------------------------ +! Allocate arrays to hold observational information +! + allocate ( prs_nlev(n_levs)) + allocate (omg_cor(n_levs,mregion,2), & + cnt(n_levs,mregion), & penalty(n_levs,mregion), & error(n_levs,mregion), use(n_levs,mregion)) ! Zero accumulator arrays - do ii=1,2 - do k=1,mregion - do j=1,n_levs - if (ii==1) then - count(j,k) = 0.0 - penalty(j,k) = 0.0 - endif - omg_cor(j,k,ii) = 0.0 - end do - end do - end do + do ii=1,2 + do k=1,mregion + do j=1,n_levs + if (ii==1) then + cnt(j,k) = 0.0 + penalty(j,k) = 0.0 + endif + omg_cor(j,k,ii) = 0.0 + end do + end do + end do ! Extract ozinfo relative index - do j=1,n_levs - prs_nlev(j) = real( header_nlev(j)%pob, 4) - end do - do k=1,mregion - do j=1,n_levs - error(j,k) = real( header_nlev(j)%err, 4) - use(j,k) = real( header_nlev(j)%iouse, 4 ) - end do - end do + do j=1,n_levs + prs_nlev(j) = real( header_nlev(j)%pob, 4) + end do + do k=1,mregion + do j=1,n_levs + error(j,k) = real( header_nlev(j)%err, 4) + use(j,k) = real( header_nlev(j)%iouse, 4 ) + end do + end do -! Create GrADS control file - write(6,*)'call create_ctl_oz' - call create_ctl_oz(ntype,ftype,n_levs,iyy,imm,idd,ihh,idhh,& - incr,ctl_file,lunctl,rmiss,satname,satype,dplat,nregion,& +! ---------------------------------------------------- +! Set the var_list list to use either the ges or anl +! version per the ptype value + + if( trim(ptype) == 'ges' ) then + var_list=ges_vars + else + var_list=anl_vars + end if + +!----------------------------------------------------- +! create GrADS contol file +! + call create_ctl_oz(ntype,ptype, var_list,n_levs,iyy,imm,idd,ihh,idhh,& + incr,ctl_file,lunctl,rmiss,satname,obstype,dplat,nregion,& region,rlonmin,rlonmax,rlatmin,rlatmax,prs_nlev,use(1,1),error(1,1)) ! Loop to read entries in diagnostic file - iflag = 0 - if(index(satype,'mls')/=0 ) then - print*, 'deal with MLS data' - end if - - loopd: do while (iflag == 0) - -! Read a record. If read flag, iflag does not equal zero, exit loopd - call read_diag_data( lndiag, header_fix, data_fix, data_nlev, data_extra, iread, iflag ) - if( iflag /= 0 ) exit loopd - nobs=nobs+iread - -! Extract obervation location and mpi weight. Convert (0-360) lon to (-180,180) - - do iobs=1,iread - rlat = data_fix(iobs)%lat - rlon = data_fix(iobs)%lon - if (rlon>180.) rlon = rlon - 360. -! print*,'rlat,rlon=',rlat,rlon - -! Detemine subdomain based on observation location - ii=0; jsub=0 - do k=1,nregion - if ( (rlonmin(k)<=rlon .and. rlon 1.e-6) then - pen = data_nlev(j,iobs)%varinv*(data_nlev(j,iobs)%ozone_inv)**2 - cor_omg(1) = data_nlev(j,iobs)%ozone_inv - cor_omg(2) = (cor_omg(1))**2 - do i=1,nreg - k=jsub(i) - count(j,k) = count(j,k) +1.0 - penalty(j,k) = penalty(j,k) + pen - do ii=1,2 - omg_cor(j,k,ii) = omg_cor(j,k,ii) + cor_omg(ii) - end do - end do -! endif - enddo ! level loop - else -! If observation was assimilated, accumulate sums in appropriate regions - if (data_nlev(1,iobs)%varinv > 1.e-6) then -! since the old gsi executable contains the case where the obs is above model top and ratio_error is set to 0 -! but varinv is not set to 0 and the ozone_inv is still calculated. -! if (abs(data_nlev(1,iobs)%ozone_inv) < 1.0e+02 .and. data_nlev(1,iobs)%varinv<1.0e+04) then -! if (abs(data_nlev(1,iobs)%ozone_inv) < 1.0e+02 ) then - pen = data_nlev(1,iobs)%varinv*(data_nlev(1,iobs)%ozone_inv)**2 - cor_omg(1) = data_nlev(1,iobs)%ozone_inv - cor_omg(2) = (cor_omg(1))**2 - j=mod(iobs,n_levs) - if(j==0) j=n_levs - do i=1,nreg - k=jsub(i) - count(j,k) = count(j,k) +1.0 - penalty(j,k) = penalty(j,k) + pen - do ii=1,2 - omg_cor(j,k,ii) = omg_cor(j,k,ii) + cor_omg(ii) - end do - end do - endif - endif - - enddo ! END do iobs=1,iread - -! End of loop over diagnostic file - enddo loopd - - close(lndiag) - print*, 'read in ', nobs, ' observations in total',count(12,1),count(12,4),sum(omg_cor),sum(penalty) - write(6,*)' ' - write(6,*)' ' - -! Compute average and standard deviation - do k=1,nregion - do j=1,n_levs - call avgsdv(count(j,k),omg_cor(j,k,1), omg_cor(j,k,2), rmiss) - write(6,*)'level j=',j,', region k=',k,' with count,avg,sdv=', & - count(j,k),omg_cor(j,k,1),omg_cor(j,k,2) - if (count(j,k)>0) then - penalty(j,k)=penalty(j,k)/count(j,k) ! convert penalty to cpen - else - count(j,k)=rmiss - penalty(j,k)=rmiss - endif - end do - end do - -! Write output to GrADS ready file - write(6,*)' ' - open(lungrd,file=grad_file,form='unformatted') - write(lungrd) ((count(j,k),j=1,n_levs),k=1,nregion) - write(lungrd) ((penalty(j,k),j=1,n_levs),k=1,nregion) -if(index(satype,'mls')/=0 ) then - print*, ' write out the data to temp.txt' - open(8,file='temp.txt',form='formatted') - write(8,*) ((count(j,k),j=1,n_levs),k=1,nregion) - write(8,*) ((penalty(j,k),j=1,n_levs),k=1,nregion) -end if - do ii=1,2 - write(lungrd) ((omg_cor (j,k,ii),j=1,n_levs),k=1,nregion) - if(index(satype,'mls')/=0 ) then - write(8,*) 'ii=',ii, ((omg_cor (j,k,ii),j=1,n_levs),k=1,nregion) - end if - end do - write(6,*)'write output to lungrd=',lungrd,', file=',trim(grad_file) - close(lungrd) -if(index(satype,'mls')/=0 ) then - close(8) -end if - - -! Deallocate arrays - write(6,*)' ' - write(6,*)'deallocate arrays' - deallocate(prs_nlev,omg_cor,count,penalty,error,use) - goto 950 - -! Jump to here if eof or error reading diagnostic file. -900 continue - write(6,*)'***PROBLEM reading diagnostic file. diag_oz=',diag_oz - close(lndiag) - - if (n_levs<=0) then - write(6,*)'***ERROR*** invalid nlevs=',n_levs,' STOP program' - call errexit(93) - endif - - write(6,*)'update date for control file' - call update_ctl_oz(n_levs,iyy,imm,idd,ihh,idhh,incr,& - ctl_file,lunctl) - - write(6,*)'load missing value ',rmiss,' into output arrays. ',& - nregion,n_levs - allocate(count(n_levs,nregion),penalty(n_levs,nregion)) - allocate(omg_cor(n_levs,mregion,2)) - - write(6,*)'load missing value ',rmiss,' into output arrays' - do ii=1,2 - do k=1,nregion - do j=1,n_levs - if (ii==1) then - count(j,k) =rmiss - penalty(j,k)=rmiss - endif - omg_cor(j,k,ii) =rmiss - end do - end do - end do - open(lungrd,file=grad_file,form='unformatted') - write(lungrd) ((count(j,k),j=1,n_levs),k=1,nregion) - write(lungrd) ((penalty(j,k),j=1,n_levs),k=1,nregion) -if(index(satype,'mls')/=0 ) then - open(8,file='temp.txt',form='formatted',status='new') - write(8,*) ((count(j,k),j=1,n_levs),k=1,nregion) - write(8,*) ((penalty(j,k),j=1,n_levs),k=1,nregion) -end if - do ii=1,2 - write(lungrd) ((omg_cor (j,k,ii),j=1,n_levs),k=1,nregion) -if(index(satype,'mls')/=0 ) then - write(8,*) 'ii=',ii,((omg_cor (j,k,ii),j=1,n_levs),k=1,nregion) -end if - end do - write(6,*)'write output to lungrd=',lungrd,', file=',trim(grad_file) - close(lungrd) -if(index(satype,'mls')/=0 ) then - close(8) -end if - deallocate(count,penalty,omg_cor) - -! End of program -950 continue + iflag = 0 + + loopd: do while (iflag == 0) + + !--------------------------------------------------------------------- + ! Read a record. If read flag, iflag does not equal zero, exit loopd + ! + call read_ozndiag_data( lndiag, header_fix, data_fix, data_nlev, data_extra, iread, iflag ) + if( iflag /= 0 ) exit loopd + + nobs=nobs+iread + write(6,*) ' iread, nobs now = ', iread, nobs + +! Extract obervation location and mpi weight. Convert (0-360) lon to (-180,180) + + do iobs=1,iread + rlat = data_fix(iobs)%lat + rlon = data_fix(iobs)%lon + if (rlon>180.) rlon = rlon - 360. + +! Determine subdomain based on observation location + ii=0; jsub=0 + do k=1,nregion + if ( (rlonmin(k)<=rlon .and. rlon 1.e-6) then + ! + ! around the code (below) encompassing everything with this + ! do loop (above). Adding this check back into the code + ! results in all non-assimilates sources producing + ! zeroed out plots, which isn't desireable. I've preserved the + ! check in this comment just in case it's needed some day. + ! + + write(6,*) 'data_nlev(j,iobs)%varinv = ', j, iobs, data_nlev(j,iobs)%varinv + pen = data_nlev(j,iobs)%varinv*(data_nlev(j,iobs)%ozone_inv)**2 + cor_omg(1) = data_nlev(j,iobs)%ozone_inv + cor_omg(2) = (cor_omg(1))**2 + + do i=1,nreg + k=jsub(i) + cnt(j,k) = cnt(j,k) +1.0 + penalty(j,k) = penalty(j,k) + pen + + do ii=1,2 + omg_cor(j,k,ii) = omg_cor(j,k,ii) + cor_omg(ii) + end do + + end do + + enddo + + else ! mls data sources + + !------------------------------------------------------------------------ + ! If observation was assimilated, accumulate sums in appropriate regions + ! + ! Note that this block still has a check for assimilated data. This + ! is only used by mls data sources. Currently there are no mls data + ! sources. If they do get added at some point be advised that this + ! check will produce zeroed output files if the sources are not + ! assimilated. + ! + + if (data_nlev(1,iobs)%varinv > 1.e-6) then + + pen = data_nlev(1,iobs)%varinv*(data_nlev(1,iobs)%ozone_inv)**2 + cor_omg(1) = data_nlev(1,iobs)%ozone_inv + cor_omg(2) = (cor_omg(1))**2 + j=mod(iobs,n_levs) + if(j==0) j=n_levs + + do i=1,nreg + k=jsub(i) + cnt(j,k) = cnt(j,k) +1.0 + penalty(j,k) = penalty(j,k) + pen + + do ii=1,2 + omg_cor(j,k,ii) = omg_cor(j,k,ii) + cor_omg(ii) + end do + end do + endif + + endif + + enddo ! END do iobs=1,iread + + enddo loopd ! End of loop over diagnostic file + + + call close_ozndiag( diag_oz, lndiag ) + + write(6,*)' ' + print*, 'read in ', nobs, ' observations in total' + write(6,*)' ' + +! Compute average and standard deviation + do k=1,nregion + do j=1,n_levs + call avgsdv(cnt(j,k),omg_cor(j,k,1), omg_cor(j,k,2), rmiss) + + if (cnt(j,k)>0) then + penalty(j,k)=penalty(j,k)/cnt(j,k) ! convert penalty to cpen + else + cnt(j,k)=rmiss + penalty(j,k)=rmiss + endif + end do + end do + +! Do validation + if( validate == .TRUE. ) then + call load_base( satname, ier ) + + open(lupen,file=bad_pen_file,form='formatted') + open(lucnt,file=bad_cnt_file,form='formatted') + + endif + +! Validate penalty values + + k=1 + do j=1,n_levs + if ( use(j,k) > 0.0 ) then + + if( validate == .TRUE. ) then + + pbound = 0.00 + call validate_penalty( j, k, penalty(j,k), valid_penalty, pbound, iret ) + + if( (iret == 0) .AND. (valid_penalty .eqv. .FALSE.) ) then + write(6,*) 'BAD PEN j,k,penalty, valid_penalty,bound = ', & + j,k,penalty(j,k), valid_penalty, pbound + write(lupen,penformat) satname, ' level= ',j, ' region= ', k, & + ' penalty= ', penalty(j,k), ' bound= ', pbound + endif + + cbound = 0.00 + call validate_count( j, k, cnt(j,k), valid_count, cbound, iret ) + + if( (iret == 0) .AND. (valid_count .eqv. .FALSE.) ) then + write(6,*) 'BAD CNT j,k, count = ', j,k,cnt(j,k), valid_count + write(lucnt,cntformat) satname, ' level= ',j, ' region= ', k, & + ' count= ', cnt(j,k), ' bound= ', cbound + endif + + endif + endif + end do + + if( validate == .TRUE. ) then + close( lupen ) + close( lucnt ) + endif + + !------------------------------------ + ! Write output to GrADS ready file + ! + + open(lungrd,file=grad_file,form='unformatted') + write(lungrd) ((cnt(j,k),j=1,n_levs),k=1,nregion) + write(lungrd) ((penalty(j,k),j=1,n_levs),k=1,nregion) + do ii=1,2 + write(lungrd) ((omg_cor (j,k,ii),j=1,n_levs),k=1,nregion) + end do + + write(6,*)'' + write(6,*)'finished writing output to lungrd=',lungrd,', file=',trim(grad_file) + close(lungrd) + + + !------------------------ + ! Deallocate arrays + ! + deallocate(prs_nlev,omg_cor,cnt,penalty,error,use) + + stop end program main diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/valid.f90 b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/valid.f90 new file mode 100755 index 000000000..a98f2ce98 --- /dev/null +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/sorc/oznmon_time.fd/valid.f90 @@ -0,0 +1,281 @@ +!$$$ subprogram documentation block +! . . . +! subprogram: valid validate the obs and penalty values +! prgmmr: safford date: 2009-12 +! +! abstract: This module contains code to read a given satellite's +! base file and then validate new obs(count) and penalty +! values by comparing them to the baseline values. +! +! program history log: +! 2009-12-07 safford - initial coding +! +! contains: +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +module valid + + implicit none + + private + +! --- module routines + public :: load_base + public :: validate_count + public :: validate_penalty + +! --- module parameters + integer, parameter :: funit = 17 + real,parameter :: rmiss = -999.0 + +! --- module vars + logical :: base_loaded = .FALSE. + integer :: nlevel, nregion, j, k, dummy + + real,allocatable,dimension(:,:):: avg_count, sdv_count + real,allocatable,dimension(:,:):: min_count, max_count + real,allocatable,dimension(:,:):: avg_penalty, sdv_penalty + real,allocatable,dimension(:,:):: min_penalty, max_penalty + + integer,allocatable,dimension(:):: nu_chan + + contains + + !------------------------------------------------------------- + ! load the base file for the given satellite + !------------------------------------------------------------- + + subroutine load_base( satname, iret ) + + !--- interface + character(20), intent( in ) :: satname + integer, intent( out ) :: iret + + !--- variables + character(20) fname + character(40) test_satname + character(10) base_date + character(20) dum1, dum2, dum3, dum4, dum5, dum6, dum7, dum8, dum9, dum10, dum11 + character(20) dum + integer fios + integer level, region + + logical fexist + + + !--- initialization + iret = -1 + fname = trim(satname) // '.base' + fexist = .FALSE. + + + !--- verify file exists and open the file + inquire( file = fname, exist = fexist ) + if( fexist .eqv. .FALSE. ) then + fios = -1 + else + open( UNIT=funit, FILE=fname, IOSTAT=fios ) + end if + write(*,*) ' fios from inquire = ', fios + + if( fios == 0 ) then + !--- read the file header + read(funit,*) test_satname, nlevel, nregion + + write(*,*) ' test_satname = ', test_satname + !--- line 2 of header file + read(funit,*) dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8,dum9,dum10,dum11 + + allocate( avg_count(nlevel,nregion), sdv_count(nlevel,nregion), & + avg_penalty(nlevel,nregion), sdv_penalty(nlevel,nregion), & + min_count(nlevel,nregion), max_count(nlevel,nregion), & + min_penalty(nlevel,nregion), max_penalty(nlevel,nregion) ) + + ! --- set all missing + do k=1,nregion + do j=1,nlevel + avg_count(j,k) = rmiss + sdv_count(j,k) = rmiss + min_count(j,k) = rmiss + max_count(j,k) = rmiss + avg_penalty(j,k) = rmiss + sdv_penalty(j,k) = rmiss + min_penalty(j,k) = rmiss + max_penalty(j,k) = rmiss + end do + end do + + write(*,*) 'nregion, nlevel = ', nregion, nlevel + + do k=1,nregion + do j=1,nlevel + read(funit,*) level, region, & + avg_count(j,k), sdv_count(j,k), & + min_count(j,k), max_count(j,k), & + avg_penalty(j,k), sdv_penalty(j,k), & + min_penalty(j,k), max_penalty(j,k) + end do + end do + + iret = 0 + base_loaded = .TRUE. + else + write(*,*) 'WARNING: unable to load fname for data error checking' + end if + + + end subroutine load_base + + + !--------------------------------------------------------------- + ! validate a count + ! given a count value for a level and region, determine + ! if the count is within +/- 2*sdv + ! + ! iret 0 = normal + ! -1 = invalid level + ! -2 = invalid region + ! 1 = base file wasn't loaded, unable to validate + !--------------------------------------------------------------- + subroutine validate_count( level, region, count, valid, bound, iret ) + + !--- interface + integer, intent( in ) :: level + integer, intent( in ) :: region + real, intent( in ) :: count + logical, intent( out ) :: valid + real, intent( out ) :: bound + integer, intent( out ) :: iret + + !--- vars + real cnt, hi, lo, sdv2 + + write(*,*) '--> validate_count, level, region, count ', level, region, count + !--- initialize vars + iret = 0 + cnt = count + valid = .FALSE. + + if( base_loaded .eqv. .TRUE. ) then + if( level < 1 .OR. level > nlevel ) then + iret = -1 + write(*,*) 'Warning: In validate_count attempt to validate level out of range', level + valid = .TRUE. + else if( region < 1 .OR. region > nregion ) then + iret = -2 + write(*,*) 'Warning: In validate_count attempt to validate region out of range', region + valid = .TRUE. + else + ! + ! all unassimilated level in the base files will have an rmiss + ! value and are considered valid for verification purposes + ! + if( avg_count(level,region) < 0.0 ) then + valid = .TRUE. + else + sdv2 = 2 * sdv_count( level, region ) + hi = avg_count(level,region) + sdv2 + lo = avg_count(level,region) - sdv2 + bound = lo + + ! + ! Consider any count valid if + ! cnt is 2 sdv from avg + ! + if( cnt >= lo ) then + valid = .TRUE. + end if + + end if + + end if + + if ( valid .eqv. .FALSE. ) then + write(*,*) ' avg_count(level,region), sdv2, hi, lo = ', avg_count(level,region), sdv2, hi, lo + end if + + else + !--- base file was not loaded, so return a warning that validation isn't possible + iret = 1 + end if + end subroutine validate_count + + + !------------------------------------------------------------- + ! validate a penalty value + ! given a penalty value for a level and region, determine + ! if the penalty is within +/- 2*sdv + ! + ! iret 0 = normal + ! -1 = invalid level + ! -2 = invalid region + !------------------------------------------------------------- + subroutine validate_penalty( level, region, penalty, valid, bound, iret ) + + !--- interface + integer, intent( in ) :: level + integer, intent( in ) :: region + real, intent( in ) :: penalty + logical, intent( out ) :: valid + real, intent( out ) :: bound + integer, intent( out ) :: iret + + !--- vars + real sdv2 + + + !--- initialize vars + iret = 0 + valid = .FALSE. + bound = rmiss + + if( base_loaded .eqv. .TRUE. .AND. nlevel > 1 ) then + if( level < 1 .OR. level > nlevel ) then + iret = -1 + write(*,*) 'Warning: In validate_penalty attempt to validate level out of range', level + valid = .TRUE. + else if( region < 1 .OR. region > nregion ) then + iret = -2 + write(*,*) 'Warning: In validate_penalty attempt to validate region out of range', region + valid = .TRUE. + else + ! + ! all unassimilated level in the base files will have an rmiss + ! value and are considered valid for verification purposes + ! + bound = max_penalty(level,region) * 1.2 + + if( avg_penalty(level,region) < 0.0 ) then + valid = .TRUE. + else + + ! + ! Penalty value less than bound is valid + ! + if( penalty <= bound ) then + valid = .TRUE. + end if + + end if + end if + + if ( valid .eqv. .FALSE. ) then + write(*,*) ' BAD: penalty, max_penalty(level,region), bound = ', penalty, max_penalty(level,region), bound + end if + + else + !--- base file was not loaded, or nlevel was 0 so return + !--- a warning that validation isn't possible + write (*,*) 'Warning: base file not loaded or nlevel < 1, nlevel= ', nlevel + iret = 1 + end if + end subroutine validate_penalty + + +end module valid diff --git a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/ush/ozn_xtrct.sh b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/ush/ozn_xtrct.sh index ed0d94829..5ee05253f 100755 --- a/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/ush/ozn_xtrct.sh +++ b/util/Ozone_Monitor/nwprod/oznmon_shared.v2.0.0/ush/ozn_xtrct.sh @@ -19,24 +19,82 @@ #------------------------------------------------------------------ set -ax -echo "start ozn_xtrct.sh" -msg="ozn_xtrct.sh HAS STARTED" -postmsg "$jlogfile" "$msg" + +#-------------------------------------------------- +# check_diag_files +# +# Compare SATYPE (which contains the contents of +# gdas_oznmon_satype.txt to $avail_satype which is +# determined by the contents of the oznstat file. +# Report any missing diag files in a file named +# bad_diag.$PDATE +# +check_diag_files() { + PDATE=$1 + SATYPE=$2 + avail_satype=$3 + + out_file="bad_diag.${PDATE}" + echo "--> check_diag_files" + + for type in ${SATYPE}; do + check=`echo $avail_satype | grep $type` + len_check=`echo -n "$check" | wc -c` + + if [[ $len_check -le 1 ]]; then + echo "missing diag file -- diag_$type.${PDATE}.gz not found " >> ./$out_file + fi + done + + echo "<-- check_diag_files" +} + + +echo "start ozn_xtrct.sh" iret=0 export NCP=${NCP:-/bin/cp} +VALIDATE_DATA=${VALIDATE_DATA:-0} nregion=${nregion:-6} +DO_DATA_RPT=${DO_DATA_RPT:-0} + +netcdf_boolean=".false." +if [[ $OZNMON_NETCDF -eq 1 ]]; then + netcdf_boolean=".true." +fi + +OZNMON_NEW_HDR=${OZNMON_NEW_HDR:-0} +new_hdr="F" +if [[ $OZNMON_NEW_HDR -eq 1 ]]; then + new_hdr="T" +fi + +#------------------------------------------------------------------ +# if VALIDATE_DATA then locate and untar base file +# +validate=".FALSE." +if [[ $VALIDATE_DATA -eq 1 ]]; then + if [[ ! -e $ozn_val_file ]]; then + echo "WARNING: VALIDATE_DATA set to 1, but unable to locate $ozn_val_file" + echo " Setting VALIDATE_DATA to 0/OFF" + VALIDATE_DATA=0 + else + validate=".TRUE." + val_file=`basename ${ozn_val_file}` + ${NCP} $ozn_val_file $val_file + tar -xvf $val_file + fi +fi +echo "VALIDATE_DATA, validate = $VALIDATE_DATA, $validate " + + #------------------------------------------------------------------ # ptype here is the processing type which is intended to be "ges" # or "anl". Default is "ges". # -# If this needs to change to include __both__ then the extraction -# executables will need to be modified to handle the ges && anl -# inputs in the diag file names. -# -ozn_ptype=${ozn_ptype:-"ges"} +ozn_ptype=${ozn_ptype:-"ges anl"} #--------------------------------------------------------------------------- @@ -49,31 +107,35 @@ ozn_ptype=${ozn_ptype:-"ges"} # An empty SATYPE list means there are no diag files to process. That's # a problem, reported by an iret value of 2 # -SATYPE=`ls -l d*ges* | sed -e 's/_/ /g;s/\./ /' | gawk '{ print $11 "_" $12 }'` + +avail_satype=`ls -l d*ges* | sed -e 's/_/ /g;s/\./ /' | gawk '{ print $11 "_" $12 }'` + +if [[ $DO_DATA_RPT -eq 1 ]]; then + if [[ -e ${satype_file} ]]; then + SATYPE=`cat ${satype_file}` + check_diag_files ${PDATE} "${SATYPE}" "${avail_satype}" + else + echo "WARNING: missing ${satype_file}" + fi +fi + echo $SATYPE len_satype=`echo -n "$SATYPE" | wc -c` -if [[ $len_satype -lt 1 ]]; then - iret=2 +if [[ $len_satype -le 1 ]]; then + SATYPE=$aval_satype +fi -else +echo $SATYPE - #--------------------------------------------------------------------------- - # NOTE: If ges && anl are to be processed then add an outer for loop on - # $ozn_ptype - # - if [[ -e ${type}.gz ]]; then - rm -f ${type}.gz - fi - if [[ -e ${type} ]]; then - rm -f ${type} - fi - for type in ${SATYPE}; do - mv diag_${type}_${ozn_ptype}.${PDATE}.gz ${type}.gz - gunzip ./${type}.gz - done +len_satype=`echo -n "$SATYPE" | wc -c` + +if [[ $DO_DATA_RPT -eq 1 && $len_satype -lt 1 ]]; then + iret=2 + +else #-------------------------------------------------------------------- # Copy extraction programs to working directory @@ -90,16 +152,32 @@ else fi - #-------------------------------------------------------------------- - # Run programs for given time + #--------------------------------------------------------------------------- + # NOTE: If ges && anl are to be processed then add an outer for loop on + # $ozn_ptype + # + echo "ozn_ptype = $ozn_ptype" + for ptype in ${ozn_ptype}; do + echo "ptype = $ptype" - iyy=`echo $PDATE | cut -c1-4` - imm=`echo $PDATE | cut -c5-6` - idd=`echo $PDATE | cut -c7-8` - ihh=`echo $PDATE | cut -c9-10` + + for type in ${SATYPE}; do + mv diag_${type}_${ptype}.${PDATE}.gz ${type}.${ptype}.gz + gunzip ./${type}.${ptype}.gz + done - for type in ${SATYPE}; do - rm -f input + + #-------------------------------------------------------------------- + # Run programs for given time + + iyy=`echo $PDATE | cut -c1-4` + imm=`echo $PDATE | cut -c5-6` + idd=`echo $PDATE | cut -c7-8` + ihh=`echo $PDATE | cut -c9-10` + + for type in ${SATYPE}; do + echo "processing ptype, type: $ptype, $type" + rm -f input cat << EOF > input &INPUT @@ -117,26 +195,31 @@ cat << EOF > input region(4)='20S-20N', rlonmin(4)=-180.0,rlonmax(4)=180.0,rlatmin(4)=-20.0,rlatmax(4)= 20.0, region(5)='20S-70S', rlonmin(5)=-180.0,rlonmax(5)=180.0,rlatmin(5)=-70.0,rlatmax(5)=-20.0, region(6)='70S-90S', rlonmin(6)=-180.0,rlonmax(6)=180.0,rlatmin(6)=-90.0,rlatmax(6)=-70.0, + validate=$validate, + new_hdr=${new_hdr}, + ptype=${ptype}, + netcdf=${netcdf_boolean} / EOF - msg="oznmon_time.x HAS STARTED $type" - postmsg "$jlogfile" "$msg" + echo "oznmon_time.x HAS STARTED $type" + + ./oznmon_time.x < input > stdout.time.${type}.${ptype} - ./oznmon_time.x < input > stdout.time.$type + echo "oznmon_time.x HAS ENDED $type" - msg="oznmon_time.x HAS ENDED $type" - postmsg "$jlogfile" "$msg" + if [[ ! -d ${TANKverf_ozn}/time ]]; then + mkdir -p ${TANKverf_ozn}/time + fi + $NCP ${type}.${ptype}.ctl ${TANKverf_ozn}/time/ + $NCP ${type}.${ptype}.${PDATE}.ieee_d ${TANKverf_ozn}/time/ - if [[ ! -d ${TANKverf_ozn}/time ]]; then - mkdir -p ${TANKverf_ozn}/time - fi - $NCP ${type}.ctl ${TANKverf_ozn}/time/ - $NCP ${type}.${PDATE}.ieee_d ${TANKverf_ozn}/time/ - $NCP stdout.time.${type} ${TANKverf_ozn}/time/ +# $COMPRESS stdout.time.${type}.${ptype} +# $NCP stdout.time.${type}.${ptype}.${Z} ${TANKverf_ozn}/time/ + $NCP bad* ${TANKverf_ozn}/time/ - rm -f input + rm -f input cat << EOF > input &INPUT @@ -147,28 +230,43 @@ cat << EOF > input ihh=${ihh}, idhh=-18, incr=6, + new_hdr=${new_hdr}, + ptype=${ptype}, + netcdf=${netcdf_boolean} / EOF - msg="oznmon_horiz.x HAS STARTED $type" - postmsg "$jlogfile" "$msg" + echo "oznmon_horiz.x HAS STARTED $type" + + ./oznmon_horiz.x < input > stdout.horiz.${type}.${ptype} - ./oznmon_horiz.x < input > stdout.horiz.$type + echo "oznmon_horiz.x HAS ENDED $type" - msg="oznmon_horiz.x HAS ENDED $type" - postmsg "$jlogfile" "$msg" + if [[ ! -d ${TANKverf_ozn}/horiz ]]; then + mkdir -p ${TANKverf_ozn}/horiz + fi + $NCP ${type}.${ptype}.ctl ${TANKverf_ozn}/horiz/ - if [[ ! -d ${TANKverf_ozn}/horiz ]]; then - mkdir -p ${TANKverf_ozn}/horiz - fi - $NCP ${type}.ctl ${TANKverf_ozn}/horiz/ - $NCP ${type}.${PDATE}.ieee_d ${TANKverf_ozn}/horiz/ - $NCP stdout.horiz.${type} ${TANKverf_ozn}/horiz/ + $COMPRESS ${type}.${ptype}.${PDATE}.ieee_d + $NCP ${type}.${ptype}.${PDATE}.ieee_d.${Z} ${TANKverf_ozn}/horiz/ + +# $COMPRESS stdout.horiz.${type}.${ptype} +# $NCP stdout.horiz.${type}.${ptype}.${Z} ${TANKverf_ozn}/horiz/ - done + echo "finished processing ptype, type: $ptype, $type" + done # type in SATYPE + + done # ptype in $ozn_ptype + + tar -cvf stdout.horiz.tar stdout.horiz* + $COMPRESS stdout.horiz.tar + $NCP stdout.horiz.tar.${Z} ${TANKverf_ozn}/horiz/ + + tar -cvf stdout.time.tar stdout.time* + $COMPRESS stdout.time.tar + $NCP stdout.time.tar.${Z} ${TANKverf_ozn}/time/ fi -msg="ozn_xtrct.sh HAS ENDED, iret = $iret" -postmsg "$jlogfile" "$msg" +echo "ozn_xtrct.sh HAS ENDED, iret = $iret" exit $iret diff --git a/util/Ozone_Monitor/parm/OznMon_config b/util/Ozone_Monitor/parm/OznMon_config index a28ee8b81..758849716 100644 --- a/util/Ozone_Monitor/parm/OznMon_config +++ b/util/Ozone_Monitor/parm/OznMon_config @@ -9,142 +9,197 @@ echo "begin OznMon_config" -export MY_MACHINE=ibm - -# -# MY_OZNMON should point to your working directory which contains the -# top level directory to the OznMon package. If you checked out the package -# as part of the GSI point to the GSI's util/Ozone_Monitor directory. If -# you checked out only the Ozone_Monitor portion of the branch then -# MY_RADMON should point to that. -# -export MY_OZNMON=${MY_OZNMON:-} - -export OZN_SCRIPTS=${OZN_SCRIPTS:-${MY_OZNMON}/scripts} -export OZN_DE_SCRIPTS=${OZN_DE_SCRIPTS:-${MY_OZNMON}/data_xtrct/ush} -export OZN_DE_SORC=${OZN_DE_SORC:-${MY_OZNMON}/data_xtrct/sorc} -export OZN_DE_EXEC=${OZN_DE_EXEC:-${MY_OZNMON}/data_xtrct/exec} -export OZN_IG_SCRIPTS=${OZN_IG_SCRIPTS:-${MY_OZNMON}/image_gen/ush} -export OZN_IG_GSCRPTS=${OZN_IG_GSCRPTS:-${MY_OZNMON}/image_gen/gscripts} -export OZN_EXEDIR=${OZN_EXEDIR:-${MY_OZNMON}/exec} - -export HOMEgdas_ozn=${HOMEgdas_ozn:-${MY_OZNMON}/nwprod/gdas_oznmon.${gdas_oznmon_ver}} -export HOMEoznmon=${HOMEoznmon:-${MY_OZNMON}/nwprod/oznmon_shared.${shared_oznmon_ver}} - -# -# The OZN_TANKDIR will be the location for the extracted data files and -# the control files used for image plotting. This is the base definition -# and the succedding scripts will construct and use subdirectories under -# this location. -# -export OZN_TANKDIR=${OZN_TANKDIR:~/u/$LOGNAME/nbns} - -if [[ $GLB_AREA -eq 1 ]]; then - OZN_IMGN_TANKDIR=${OZN_TANKDIR}/imgn/${OZNMON_SUFFIX} -else - OZN_IMGN_TANKDIR=${OZN_TANKDIR}/imgn/regional/${OZNMON_SUFFIX} -fi - -if [[ $OZN_USE_RUN -eq 1 ]]; then - OZN_IMGN_TANKDIR=${OZN_IMGN_TANKDIR}/${RUN} -fi - -export OZN_IMGN_TANKDIR=$OZN_IMGN_TANKDIR/oznmon/pngs - -if [[ $GLB_AREA -eq 0 ]]; then - NEWtank=${OZN_TANKDIR}/stats/regional/${OZNMON_SUFFIX} -else - NEWtank=${OZN_TANKDIR}/stats/${OZNMON_SUFFIX} -fi - -export OZN_STATS_TANKDIR=$NEWtank - - -# -# -# -# Log and work space definitions -# -export OZN_PTMP=${OZN_PTMP:-/ptmpp1} -export PTMP_USER=${PTMP_USER:-${OZN_PTMP}/${LOGNAME}} -export OZN_STMP=${OZN_STMP:-/stmpp1} -export STMP_USER=${STMP_USER:-${OZN_STMP}/${LOGNAME}} - -OZN_LOGdir=${LOGdir:-${PTMP_USER}/logs/${OZNMON_SUFFIX}} -if [[ $OZN_USE_RUN -eq 1 ]]; then - OZN_LOGdir=${OZN_LOGdir}/${RUN} -fi -export OZN_LOGdir=$OZN_LOGdir/oznmon - - -export OZN_WORK_DIR=${OZN_WORK_DIR:-${STMP_USER}/${OZNMON_SUFFIX}/oznmon} - - - -# -# Webserver settings -# +#----------------------------------------------------------------- +# This check ensures this file only gets loaded once. Some of +# the definitions are built in steps and loading more than once +# would make them incorrect. +#----------------------------------------------------------------- +if [[ $OZNMON_CONFIG -ne 1 ]]; then + + export OZNMON_CONFIG=1 + +export MY_MACHINE=hera + + #------------------------------------------------------------------- + # Note: The file header in the oznstat file has slightly changed. + # The default setting is to use that new header format, but + # at the moment there is no operational source doing so. So + # setting this to 0 will make all file header reads assum the + # older format (which does work with the new file header). + # Once sources begin to use the new format this can either be + # set to 1 or may go away. + # + export OZNMON_NEW_HDR=${OZNMON_NEW_HDR:-0} + + # + # MY_OZNMON should point to your working directory which contains the + # top level directory to the OznMon package. If you checked out the package + # as part of the GSI point to the GSI's util/Ozone_Monitor directory. If + # you checked out only the Ozone_Monitor portion of the branch then + # MY_RADMON should point to that. + # +export MY_OZNMON=${MY_OZNMON:-/scratch1/NCEPDEV/da/Edward.Safford/noscrub/ProdGSI/util/Ozone_Monitor} + + export OZN_SCRIPTS=${OZN_SCRIPTS:-${MY_OZNMON}/scripts} + export OZN_DE_SCRIPTS=${OZN_DE_SCRIPTS:-${MY_OZNMON}/data_xtrct/ush} + export OZN_DE_SORC=${OZN_DE_SORC:-${MY_OZNMON}/data_xtrct/sorc} + export OZN_DE_EXEC=${OZN_DE_EXEC:-${MY_OZNMON}/data_xtrct/exec} + export OZN_IG_SCRIPTS=${OZN_IG_SCRIPTS:-${MY_OZNMON}/image_gen/ush} + export OZN_IG_GSCRPTS=${OZN_IG_GSCRPTS:-${MY_OZNMON}/image_gen/gscripts} + export OZN_EXEDIR=${OZN_EXEDIR:-${MY_OZNMON}/exec} + + export HOMEgdas_ozn=${HOMEgdas_ozn:-${MY_OZNMON}/nwprod/gdas_oznmon.${gdas_oznmon_ver}} + export HOMEoznmon=${HOMEoznmon:-${MY_OZNMON}/nwprod/oznmon_shared.${shared_oznmon_ver}} + + # + # Add these gfs definitions to accomodate the changes + # to the J-Job from the fv3_impl merge + # + export PARMgfs_ozn=${PARMgfs_ozn:-${HOMEgdas_ozn}/parm} + export SCRgfs_ozn=${SCRgfs_ozn:-${HOMEgdas_ozn}/scripts} + export FIXgfs_ozn=${FIXgfs_ozn:-${HOMEgdas_ozn}/fix} + + # + # The OZN_TANKDIR will be the location for the extracted data files and + # the control files used for image plotting. This is the base definition + # and the succedding scripts will construct and use subdirectories under + # this location. + # +export OZN_TANKDIR=${OZN_TANKDIR:-/scratch1/NCEPDEV/da/Edward.Safford/nbns} + + if [[ $GLB_AREA -eq 1 ]]; then + OZN_IMGN_TANKDIR=${OZN_TANKDIR}/imgn/${OZNMON_SUFFIX} + else + OZN_IMGN_TANKDIR=${OZN_TANKDIR}/imgn/regional/${OZNMON_SUFFIX} + fi + + if [[ $OZN_USE_RUN -eq 1 ]]; then + OZN_IMGN_TANKDIR=${OZN_IMGN_TANKDIR}/${RUN} + fi + + export OZN_IMGN_TANKDIR=$OZN_IMGN_TANKDIR/oznmon/pngs + + if [[ $GLB_AREA -eq 0 ]]; then + NEWtank=${OZN_TANKDIR}/stats/regional/${OZNMON_SUFFIX} + else + NEWtank=${OZN_TANKDIR}/stats/${OZNMON_SUFFIX} + fi + + export OZN_STATS_TANKDIR=$NEWtank + + + # + # Log and work space definitions + # +export OZN_PTMP=${OZN_PTMP:-/scratch2/NCEPDEV/stmp3} + export PTMP_USER=${PTMP_USER:-${OZN_PTMP}/${LOGNAME}} +export OZN_STMP=${OZN_STMP:-/scratch2/NCEPDEV/stmp1} + export STMP_USER=${STMP_USER:-${OZN_STMP}/${LOGNAME}} + + + OZN_LOGdir=${LOGdir:-${PTMP_USER}/logs/${OZNMON_SUFFIX}} + OZN_WORK_DIR=${OZN_WORK_DIR:-${STMP_USER}/${OZNMON_SUFFIX}} + + if [[ $OZN_USE_RUN -eq 1 ]]; then + OZN_LOGdir=${OZN_LOGdir}/${RUN} + OZN_WORK_DIR=${OZN_WORK_DIR}/${RUN} + fi + export OZN_LOGdir=$OZN_LOGdir/oznmon + export OZN_WORK_DIR=${OZN_WORK_DIR}/oznmon + + + # + # Webserver settings + # export WEB_SVR=${WEB_SVR:-emcrzdm} -export WEB_USER=${WEB_USER:-} -export WEB_DIR=${WEB_DIR:-} - - -# -# Utilities used by the OznMon package -# -export NCP=${NCP:-"/bin/cp -f"} -export Z=${Z:-"gz"} - -if [[ $MY_MACHINE = "ibm" ]]; then - shell=sh - . /usrx/local/Modules/default/init/${shell} - module load lsf - module load prod_util - module load util_shared - module load GrADS - - export GRADS=`which grads` - export STNMAP=`which stnmap` - export SUB=`which bsub` - - export NWPROD=/nwprod - export NDATE=${NWPROD}/util/exec/ndate - export COMPRESS=/bin/gzip - export UNCOMPRESS="/bin/gunzip -f" - export RSYNC=`which rsync` - -elif [[ $MY_MACHINE = "cray" ]]; then - . /opt/modules/3.2.6.7/init/sh - module use -a /gpfs/hps/nco/ops/nwprod/modulefiles - module use -a /usrx/local/dev/modulefiles - module use -a /opt/modulefiles - - module load prod_util # defines $NDATE among other things - module load prod_envir # defines data sources - module load GrADS - module load xt-lsfhpc - - export GRADS=`which grads` - export STNMAP=`which stnmap` - export SUB=`which bsub` - - export COMPRESS=gzip - export UNCOMPRESS="gunzip -f" - export ACCOUNT=GFS-T2O - export RSYNC=`which rsync` - -elif [[ $MY_MACHINE = "theia" ]]; then - - export GRADS=/apps/grads/2.0.1a/bin/grads - export STNMAP=/apps/grads/2.0.1a/bin/stnmap - - export SUB=/apps/torque/default/bin/qsub - export NWPROD=/scratch4/NCEPDEV/da/save/Michael.Lueken/nwprod - export NDATE=${NWPROD}/util/exec/ndate - export COMPRESS=gzip - export UNCOMPRESS="gunzip -f" - +export WEB_USER=${WEB_USER:-esafford} +export WEB_DIR=${WEB_DIR:-/home/people/emc/www/htdocs/gmb/gdas/es_ozn/pngs} + + + # + # Utilities used by the OznMon package + # + export NCP=${NCP:-"/bin/cp -f"} + export Z=${Z:-"gz"} + + if [[ $MY_MACHINE = "wcoss" ]]; then + shell=sh + . /usrx/local/Modules/default/init/${shell} + module load lsf + module load prod_util + module load util_shared + module load GrADS + + export GRADS=`which grads` + export STNMAP=`which stnmap` + export SUB=`which bsub` + + export NWPROD=/nwprod + export NDATE=${NWPROD}/util/exec/ndate + export COMPRESS=${COMPRESS:-/bin/gzip} + export UNCOMPRESS=${UNCOMPRESS:-"/bin/gunzip -f"} + export RSYNC=`which rsync` + + + elif [[ $MY_MACHINE = "wcoss_d" ]]; then + + shell=sh + source /usrx/local/prod/lmod/lmod/init/${shell} + + MODULEPATH=/usrx/local/prod/lmod/lmod/modulefiles/Core + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/core_third + MODULEPATH=${MODULEPATH}:/usrx/local/prod/modulefiles/defs + MODULEPATH=${MODULEPATH}:/gpfs/dell1/nco/ops/nwprod/modulefiles/core_prod + export MODULEPATH=${MODULEPATH}:/usrx/local/dev/modulefiles + + module purge + module load ips/18.0.1.163 + module load metplus/2.1 + module load lsf/10.1 + module load prod_util/1.1.2 + module load GrADS/2.2.0 + + export SUB="bsub" + export COMPRESS=/usr/bin/gzip + export UNCOMPRESS="/usr/bin/gunzip -f" + export RSYNC=`which rsync` + export GRADS=`which grads` + export STNMAP=`which stnmap` + + elif [[ $MY_MACHINE = "cray" ]]; then + . /opt/modules/3.2.6.7/init/sh + module use -a /gpfs/hps/nco/ops/nwprod/modulefiles + module use -a /usrx/local/dev/modulefiles + module use -a /opt/modulefiles + + module load prod_util # defines $NDATE among other things + module load prod_envir # defines data sources + module load GrADS + module load xt-lsfhpc + + export GRADS=`which grads` + export STNMAP=`which stnmap` + export SUB=`which bsub` + + export COMPRESS=${COMPRESS:-gzip} + export UNCOMPRESS=${UNCOMPRESS:-"gunzip -f"} + export ACCOUNT=GFS-T2O + export RSYNC=`which rsync` + + elif [[ $MY_MACHINE = "hera" ]]; then + + export GRADS=/apps/grads/2.0.2/bin/grads + export STNMAP=/apps/grads/2.0.2/bin/stnmap + + export SUB=/apps/slurm/default/bin/sbatch + export NDATE=/home/Edward.Safford/bin/ndate + export COMPRESS=${COMPRESS:-gzip} + export UNCOMPRESS=${UNCOMPRESS:-"gunzip -f"} + + fi + +else + echo "OznMon_config already loaded" fi - echo "end OznMon_config" diff --git a/util/Ozone_Monitor/parm/OznMon_user_settings b/util/Ozone_Monitor/parm/OznMon_user_settings index 3ee7adefd..70fbc1b9c 100644 --- a/util/Ozone_Monitor/parm/OznMon_user_settings +++ b/util/Ozone_Monitor/parm/OznMon_user_settings @@ -10,19 +10,19 @@ # ACCOUNT is used on zeus only for use with the qsub -a flag. It is # empty on other platforms. # -export ACCOUNT=${ACCOUNT:-} +export ACCOUNT=${ACCOUNT:-fv3-cpu} # -# PROJECT is used on ibm only with the bjob -P flag. It is +# PROJECT is used on wcoss only with the bjob -P flag. It is # empty on other platforms. # -export PROJECT=${PROJECT:-GDAS-T2O} +export PROJECT= # -# JOB_QUEUE is used on ibm only with the bjob -q flag. It is +# JOB_QUEUE is used on wcoss only with the bjob -q flag. It is # empty on other platforms. # -export JOB_QUEUE=${JOB_QUEUE:-dev} +export JOB_QUEUE= # # GLB_AREA is either 1 (global) or 0 (regional) @@ -44,7 +44,7 @@ export OZNSTAT_LOCATION=${OZNSTAT_LOCATION:-/com2/gfs/prod} # # 0 = off, 1 = on # -export USE_ANL=${USE_ANL:-0} +export USE_ANL=${USE_ANL:-1} # # OZN_USE_RUN affects the data, image, and log file naming scheme, and is @@ -72,6 +72,7 @@ export OZN_USE_RUN=${OZN_USE_RUN:-1} # of drifting channel(s) on specific sat/instrument sources is # desirable. It is not normally necesary to apply this to parallels. # 0 = off, 1 = on +# export DO_DATA_RPT=${DO_DATA_RPT:-0} # MAIL_TO is the the primary recipient of generated email warning messages diff --git a/util/Radiance_Monitor/CMakeLists.txt b/util/Radiance_Monitor/CMakeLists.txt new file mode 100644 index 000000000..6a9cf3353 --- /dev/null +++ b/util/Radiance_Monitor/CMakeLists.txt @@ -0,0 +1,96 @@ +cmake_minimum_required(VERSION 2.6) +if(CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR) + # I am top-level project. + if( NOT DEFINED ENV{CC} ) + find_path( crayComp "ftn" ) + find_path( wcossIntel "mpfort" ) + find_path( intelComp "ifort" ) + find_path( pgiComp "pgf90" ) + if( crayComp ) + message("Setting CrayLinuxEnvironment") + set(CMAKE_SYSTEM_NAME "CrayLinuxEnvironment") + set(CMAKE_C_COMPILER "${crayComp}/cc") + set(CMAKE_CXX_COMPILER "${crayComp}/CC") + set(CMAKE_Fortran_COMPILER "${crayComp}/ftn") + endif() + if( intelComp ) + set(ENV{CC} "icc") + set(ENV{CXX} "icpc") + set(ENV{FC} "ifort") + endif() + if( wcossIntel ) + message("Setting env for wcoss intel") + set(ENV{CC} "mpcc") + set(ENV{CXX} "mpCC") + set(ENV{FC} "mpfort") + endif() + if( pgiComp ) + set(ENV{CC} "pgcc") + set(ENV{CXX} "pgCC") + set(ENV{FC} "pgf90") + endif() + endif() + project(COV_Calc) + enable_language (Fortran) + find_package(OpenMP) + set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/../../cmake/Modules/") + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setPlatformVariables.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setIntelFlags.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setGNUFlags.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setPGIFlags.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/setHOST.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Cheyenne.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Discover.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Generic.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Gaea.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Jet.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/S4.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/Hera.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/WCOSS-C.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/WCOSS-D.cmake) + include(${CMAKE_SOURCE_DIR}/../../cmake/Modules/platforms/WCOSS.cmake) + if (NOT CMAKE_BUILD_TYPE) + set (CMAKE_BUILD_TYPE RELEASE CACHE STRING + "Choose the type of build, options are: PRODUCTION Debug Release." + FORCE) + endif (NOT CMAKE_BUILD_TYPE) + if (CMAKE_CXX_COMPILER_ID MATCHES "GNU*") + message("Setting GNU flags") + setGNU() + elseif(CMAKE_CXX_COMPILER_ID STREQUAL "Intel") + message("Setting Intel flags") + setIntel() + elseif(CMAKE_C_COMPILER MATCHES "pgc*") + message("Setting PGI flags") + setPGI() + endif() + setHOST() + find_package(MPI REQUIRED) + add_definitions(${MPI_Fortran_COMPILE_FLAGS}) + include_directories(${MPI_Fortran_INCLUDE_DIRS} ${MPI_INCLUDE_PATH} "./" ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}) + link_directories(${MPI_Fortran_LIBRARIES} ${ARCHIVE_OUTPUT_PATH} ) + find_package( NetCDF REQUIRED) + if(FIND_HDF5_HL) + find_package(HDF5 COMPONENTS C HL Fortran_HL ) + elseif(FIND_HDF5) + find_package(HDF5) + endif() + find_package( W3NCO ) + set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/libsrc/ncdiag") + set(BUILD_NCDIAG ON) + add_subdirectory(${PROJECT_SOURCE_DIR}/../../src/ncdiag ${PROJECT_BINARY_DIR}/libsrc/ncdiag) + set(NCDIAG_LIBRARIES ncdiag ) + set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) +endif() + +add_subdirectory(nwprod/radmon_shared.v3.0.0/sorc/verf_radang.fd) +add_subdirectory(nwprod/radmon_shared.v3.0.0/sorc/verf_radbcoef.fd) +add_subdirectory(nwprod/radmon_shared.v3.0.0/sorc/verf_radbcor.fd) +add_subdirectory(nwprod/radmon_shared.v3.0.0/sorc/verf_radtime.fd) +add_subdirectory(data_extract/sorc/radmon_mk_base.fd) +add_subdirectory(data_extract/sorc/radmon_validate_tm.fd) +add_subdirectory(image_gen/src/radmon_ig_angle.fd) +add_subdirectory(image_gen/src/radmon_ig_bcoef.fd) +add_subdirectory(image_gen/src/radmon_ig_horiz.fd) +add_subdirectory(image_gen/src/radmon_ig_summary.fd) +add_subdirectory(image_gen/src/radmon_ig_time.fd) diff --git a/util/Radiance_Monitor/RadMon_install.pl b/util/Radiance_Monitor/RadMon_install.pl index ad3662e7a..1881da850 100755 --- a/util/Radiance_Monitor/RadMon_install.pl +++ b/util/Radiance_Monitor/RadMon_install.pl @@ -5,8 +5,8 @@ # # This script makes sets all necessary configuration definitions # and calls the makeall.sh script to build all the necessary -# executables. This script works for zeus, theia, and wcoss -# machines. +# executables. This script works for hera, wcoss, wcoss_c, and +# wcoss_d machines. # #------------------------------------------------------------------- @@ -16,7 +16,7 @@ my $machine = `/usr/bin/perl get_hostname.pl`; my $my_machine="export MY_MACHINE=$machine"; - if( $machine ne "cray" && $machine ne "theia" && $machine ne "wcoss" ) { + if( $machine ne "cray" && $machine ne "hera" && $machine ne "wcoss" && $machine ne "wcoss_d" ) { die( "ERROR --- Unrecognized machine hostname, $machine. Exiting now...\n" ); } else { @@ -24,7 +24,7 @@ } # - # surge, theia, and wcoss are all little endian machines, and all run linux + # surge, hera, and wcoss are all little endian machines, and all run linux # my $little_endian = "export LITTLE_ENDIAN=\${LITTLE_ENDIAN:-0}"; my $my_os = "linux"; @@ -53,15 +53,18 @@ # TANKDIR location # my $user_name = $ENV{ 'USER' }; - if( $machine eq "theia" ){ - $tankdir = "/scratch4/NCEPDEV/da/save/$user_name/nbns"; + if( $machine eq "hera" ){ + $tankdir = "/scratch1/NCEPDEV/da/$user_name/nbns"; } elsif( $machine eq "cray" ){ $tankdir = "/gpfs/hps/emc/da/noscrub/$user_name/nbns"; } - else { + elsif( $machine eq "wcoss" ){ $tankdir = "/global/save/$user_name/nbns"; } + elsif( $machine eq "wcoss_d" ){ + $tankdir = "/gpfs/dell2/emc/modeling/noscrub/$user_name/nbns"; + } print "Please specify TANKDIR location for storage of data and image files.\n"; print " Return to accept default location or enter new location now.\n"; @@ -196,13 +199,17 @@ sleep( 1 ); } + elsif( $machine eq "wcoss_d" ){ + $my_ptmp="export MY_PTMP=\${MY_PTMP:-/gpfs/dell2/ptmp}"; + $my_stmp="export MY_STMP=\${MY_STMP:-/gpfs/dell2/stmp}"; + } elsif( $machine eq "cray" ) { $my_ptmp="export MY_PTMP=\${MY_PTMP:-/gpfs/hps/ptmp}"; $my_stmp="export MY_STMP=\${MY_STMP:-/gpfs/hps/stmp}"; } - elsif( $machine eq "theia" ){ - $my_ptmp="export MY_PTMP=\${MY_PTMP:-/scratch4/NCEPDEV/stmp4}"; - $my_stmp="export MY_STMP=\${MY_STMP:-/scratch4/NCEPDEV/stmp3}"; + elsif( $machine eq "hera" ){ + $my_ptmp="export MY_PTMP=\${MY_PTMP:-/scratch2/NCEPDEV/stmp3}"; + $my_stmp="export MY_STMP=\${MY_STMP:-/scratch2/NCEPDEV/stmp1}"; } print "my_ptmp = $my_ptmp\n"; @@ -255,20 +262,20 @@ print "\n"; print "Updating parm/RadMon_user_settings\n"; - my $account = "export ACCOUNT=\${ACCOUNT:-glbss}"; - if( $machine ne "zeus" && $machine ne "theia" ) { + my $account = "export ACCOUNT=\${ACCOUNT:-fv3-cpu}"; + if( $machine ne "hera" ) { $account = "export ACCOUNT=\${ACCOUNT:-}"; } my $project = "export PROJECT=\${PROJECT:-GDAS-T2O}"; - if( $machine ne "wcoss" && $machine ne "cray" ) { + if( $machine ne "wcoss" && $machine ne "cray" && $machine ne "wcoss_d" ) { $project="export PROJECT="; } my $job_queue="export JOB_QUEUE="; if( $machine eq "cray" ) { $job_queue="export JOB_QUEUE=\${JOB_QUEUE:-dev}"; - } elsif( $machine eq "wcoss" ){ + } elsif( $machine eq "wcoss" || $machine eq "wcoss_d" ){ $job_queue = "export JOB_QUEUE=\${JOB_QUEUE:-dev_shared}"; } @@ -307,8 +314,7 @@ print "\n"; print "Making all executables\n"; - `./makeall.sh clean`; - `./makeall.sh`; - + `./build_RadMon_cmake.sh`; + exit 0; diff --git a/util/Radiance_Monitor/build_RadMon_cmake.sh b/util/Radiance_Monitor/build_RadMon_cmake.sh new file mode 100755 index 000000000..d323a354a --- /dev/null +++ b/util/Radiance_Monitor/build_RadMon_cmake.sh @@ -0,0 +1,125 @@ +#! /bin/bash + +#------------------------------------------------------------------ +# build_RadMon_cmake.sh +# +# This script builds all of the executables in the +# nwprod/radmon_shared/exec, data_extract/exec, and image_gen/exec +# subdirectories. +# +# The operational RadMon executables (in nwprod/radmon_shared/exec) +# may also be built as part of the whole GSI package. To do this +# ensure BUILD_UTIL=ON when running cmake or use the +# ProdGSI/ush/build_all_cmake.sh script. +#------------------------------------------------------------------ +set -ax + +mode=${1:-} +top_level=${PWD} +echo "top_level = ${top_level}" + +if [[ -d /dcom && -d /hwrf ]] ; then + . /usrx/local/Modules/3.2.10/init/sh + target=wcoss + . $MODULESHOME/init/sh +elif [[ -d /cm ]] ; then + . $MODULESHOME/init/sh + target=wcoss_c +elif [[ -d /ioddev_dell ]]; then + . $MODULESHOME/init/sh + target=wcoss_d +elif [[ -d /scratch1 ]] ; then + . /apps/lmod/lmod/init/sh + target=hera +else + echo "unknown target = $target" + exit 9 +fi + +GSI_Pkg=${top_level}/../.. +echo "GSI_Pkg = ${GSI_Pkg}" + +echo "target = $target" + +dir_modules=${GSI_Pkg}/modulefiles +if [ ! -d $dir_modules ]; then + echo "modulefiles does not exist in $dir_modules" + exit 10 +fi + + +#------------------------------ +# source RadMon_config +#------------------------------ +. ${top_level}/parm/RadMon_config + + +#--------------------------------------------------- +# Verify this is a supported machine +#--------------------------------------------------- + +if [[ ${target} = "hera" || ${target} = "wcoss" \ + || ${target} = "wcoss_c" || ${target} = "wcoss_d" ]]; then + echo Building nwprod executables on ${target} + echo + + + #------------------------------------- + # load modules + #------------------------------------- + if [ $target = wcoss_d ]; then + module purge + module use -a $dir_modules + module load modulefile.ProdGSI.$target + elif [ $target = wcoss -o $target = gaea ]; then + module purge + module load $dir_modules/modulefile.ProdGSI.$target + elif [ $target = hera -o $target = cheyenne ]; then + module purge + source $dir_modules/modulefile.ProdGSI.$target + elif [ $target = wcoss_c ]; then + module purge + module load $dir_modules/modulefile.ProdGSI.$target + fi + + + #------------------------------------- + # use cmake to build the executables + #------------------------------------- + if [[ -d ./build ]]; then + rm -rf ./build + fi + mkdir build + cd ./build + + cmake .. + make -j8 + + cd bin + + #------------------------------------------------------- + # move the executables to the correct exec directories + #------------------------------------------------------- + file_list1="radmon_angle.x radmon_bcoef.x radmon_bcor.x radmon_time.x" + for file in $file_list1; do + cp $file $HOMEradmon/exec/. + done + + file_list_de="radmon_mk_base.x radmon_validate_tm.x" + for file in $file_list_de; do + cp $file $DE_EXEC/. + done + + file_list_ig="radmon_ig_angle.x radmon_ig_bcoef.x radmon_ig_horiz.x radmon_ig_summary.x radmon_ig_time.x" + for file in $file_list_ig; do + cp $file $IG_EXEC/. + done + +else + echo ${machine} is not supported +fi + + +set +x + +exit diff --git a/util/Radiance_Monitor/data_extract/exec/.gitignore b/util/Radiance_Monitor/data_extract/exec/.gitignore new file mode 100644 index 000000000..d6b7ef32c --- /dev/null +++ b/util/Radiance_Monitor/data_extract/exec/.gitignore @@ -0,0 +1,2 @@ +* +!.gitignore diff --git a/util/Radiance_Monitor/data_extract/sorc/radmon_mk_base.fd/CMakeLists.txt b/util/Radiance_Monitor/data_extract/sorc/radmon_mk_base.fd/CMakeLists.txt new file mode 100644 index 000000000..7089ff113 --- /dev/null +++ b/util/Radiance_Monitor/data_extract/sorc/radmon_mk_base.fd/CMakeLists.txt @@ -0,0 +1,14 @@ +cmake_minimum_required(VERSION 2.6) + file(GLOB RADMON_MK_BASE_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90 ) + set(RADMON_MK_BASE_Fortran_FLAGS "-fp-model strict -assume byterecl -convert big_endian -O3 -traceback -D_REAL8_ ") + set(Util_MODULE_DIR ${PROJECT_BINARY_DIR}/include/radmon_mk_base ) + set_source_files_properties( ${RADMON_MK_BASE_SRC} PROPERTIES COMPILE_FLAGS ${RADMON_MK_BASE_Fortran_FLAGS} ) + add_executable(radmon_mk_base.x ${RADMON_MK_BASE_SRC} ) + set_target_properties( radmon_mk_base.x PROPERTIES COMPILE_FLAGS ${RADMON_MK_BASE_Fortran_FLAGS} ) + set_target_properties( radmon_mk_base.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) + include_directories( ${CORE_INCS} ) + target_link_libraries( radmon_mk_base.x ${W3NCO_4_LIBRARY} ) + if(BUILD_W3NCO) + add_dependencies( radmon_mk_base.x ${W3NCO_4_LIBRARY} ) + endif() + diff --git a/util/Radiance_Monitor/data_extract/sorc/make_base.fd/make_base.f90 b/util/Radiance_Monitor/data_extract/sorc/radmon_mk_base.fd/make_base.f90 similarity index 100% rename from util/Radiance_Monitor/data_extract/sorc/make_base.fd/make_base.f90 rename to util/Radiance_Monitor/data_extract/sorc/radmon_mk_base.fd/make_base.f90 diff --git a/util/Radiance_Monitor/data_extract/sorc/make_base.fd/makefile b/util/Radiance_Monitor/data_extract/sorc/radmon_mk_base.fd/makefile similarity index 100% rename from util/Radiance_Monitor/data_extract/sorc/make_base.fd/makefile rename to util/Radiance_Monitor/data_extract/sorc/radmon_mk_base.fd/makefile diff --git a/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/CMakeLists.txt b/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/CMakeLists.txt new file mode 100644 index 000000000..be546a960 --- /dev/null +++ b/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/CMakeLists.txt @@ -0,0 +1,14 @@ +cmake_minimum_required(VERSION 2.6) + file(GLOB RADMON_VALIDATE_TM_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90 ) + set(RADMON_VALIDATE_TM_Fortran_FLAGS "-fp-model strict -assume byterecl -convert big_endian -O3 -traceback -D_REAL8_ ") + set(Util_MODULE_DIR ${PROJECT_BINARY_DIR}/include/radmon_validate_tm.x ) + set_source_files_properties( ${RADMON_VALIDATE_TM_SRC} PROPERTIES COMPILE_FLAGS ${RADMON_VALIDATE_TM_Fortran_FLAGS} ) + add_executable(radmon_validate_tm.x ${RADMON_VALIDATE_TM_SRC} ) + set_target_properties( radmon_validate_tm.x PROPERTIES COMPILE_FLAGS ${RADMON_VALIDATE_TM_Fortran_FLAGS} ) + set_target_properties( radmon_validate_tm.x PROPERTIES Fortran_MODULE_DIRECTORY ${Util_MODULE_DIR} ) + include_directories( ${CORE_INCS} ) + target_link_libraries( radmon_validate_tm.x ${W3NCO_4_LIBRARY} ) + if(BUILD_W3NCO) + add_dependencies( radmon_validate_tm.x ${W3NCO_4_LIBRARY} ) + endif() + diff --git a/util/Radiance_Monitor/data_extract/sorc/validate_time.fd/bad_chan.f90 b/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/bad_chan.f90 similarity index 100% rename from util/Radiance_Monitor/data_extract/sorc/validate_time.fd/bad_chan.f90 rename to util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/bad_chan.f90 diff --git a/util/Radiance_Monitor/data_extract/sorc/validate_time.fd/bad_obs.f90 b/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/bad_obs.f90 similarity index 100% rename from util/Radiance_Monitor/data_extract/sorc/validate_time.fd/bad_obs.f90 rename to util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/bad_obs.f90 diff --git a/util/Radiance_Monitor/data_extract/sorc/validate_time.fd/bad_penalty.f90 b/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/bad_penalty.f90 similarity index 100% rename from util/Radiance_Monitor/data_extract/sorc/validate_time.fd/bad_penalty.f90 rename to util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/bad_penalty.f90 diff --git a/util/Radiance_Monitor/data_extract/sorc/validate_time.fd/kinds.F90 b/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/kinds.F90 similarity index 100% rename from util/Radiance_Monitor/data_extract/sorc/validate_time.fd/kinds.F90 rename to util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/kinds.F90 diff --git a/util/Radiance_Monitor/data_extract/sorc/validate_time.fd/makefile b/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/makefile similarity index 100% rename from util/Radiance_Monitor/data_extract/sorc/validate_time.fd/makefile rename to util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/makefile diff --git a/util/Radiance_Monitor/data_extract/sorc/validate_time.fd/valid.f90 b/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/valid.f90 similarity index 100% rename from util/Radiance_Monitor/data_extract/sorc/validate_time.fd/valid.f90 rename to util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/valid.f90 diff --git a/util/Radiance_Monitor/data_extract/sorc/validate_time.fd/validate_time.f90 b/util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/validate_time.f90 similarity index 100% rename from util/Radiance_Monitor/data_extract/sorc/validate_time.fd/validate_time.f90 rename to util/Radiance_Monitor/data_extract/sorc/radmon_validate_tm.fd/validate_time.f90 diff --git a/util/Radiance_Monitor/data_extract/ush/Copy_glbl.sh b/util/Radiance_Monitor/data_extract/ush/Copy_glbl.sh index ed7178fd2..3c5d57d61 100755 --- a/util/Radiance_Monitor/data_extract/ush/Copy_glbl.sh +++ b/util/Radiance_Monitor/data_extract/ush/Copy_glbl.sh @@ -4,11 +4,16 @@ # Copy_glbl.sh # # This script searches for new radmon output from the global GDAS -# and copies those filess to the user's $TANKDIR directory under the -# specified suffix argument. -# The bad_penalty files are regenerated using the local copy of the -# base file. +# and copies those filess to the user's $TANKDIR directory under +# the specified suffix argument. +# +# The bad_penalty findings and missing diag reports are +# reevaluated using local copies of the base file and satype +# files in the $TANKdir/$suffix/info directory. New missing diag +# and bad penalty reports are created and replace any existing +# ones in the cycle DE log file. # +# Note that processing occurs within TANKdir, not in stmp space. #-------------------------------------------------------------------- function usage { @@ -31,7 +36,6 @@ fi this_file=`basename $0` this_dir=`dirname $0` -compress="/usrx/local/bin/pigz -f" no_diag_rpt=0 no_error_rpt=0 @@ -73,7 +77,6 @@ else exit 3 fi -. ${DE_PARM}/data_extract_config export USHradmon=${USHradmon:-$HOMEradmon/ush} @@ -113,44 +116,30 @@ next_cyc=`echo $next|cut -c9-10` echo prev_day, prev_cyc = $prev_day, $prev_cyc echo next_day, next_cyc = $next_day, $next_cyc -DATA=${DATA:-/gpfs/hps/nco/ops/com/gfs/prod} -DATDIR=${DATDIR:-${DATA}/${RUN}.${day}}/radmon -LOGDIR=${LOGDIR:-/gpfs/hps/nco/ops/com/output/prod} +DATA=${DATA:-/gpfs/dell1/nco/ops/com/gfs/prod} + +if [[ $USE_HR -eq 1 ]]; then + DATDIR=${DATDIR:-${DATA}/${RUN}.${day}/${cycle}/radmon} +else + DATDIR=${DATDIR:-${DATA}/${RUN}.${day}/radmon} +fi + +LOGDIR=${LOGDIR:-/gpfs/dell1/nco/ops/com/output/prod} if [[ $TANK_USE_RUN -eq 1 ]]; then - test_dir=${TANKverf}/${RUN}.${day}/${MONITOR} + test_dir=${TANKverf}/${RUN}.${day}/${cycle}/${MONITOR} else test_dir=${TANKverf}/radmon.${day} fi -#if [[ ! -d ${test_dir} ]]; then -# mkdir -p ${test_dir} -#fi -#cd ${test_dir} satype_file=${TANKverf}/info/${RUN}_radmon_satype.txt if [[ ! -s ${satype_file} ]]; then -# if [[ $TANK_USE_RUN -eq 1 ]]; then -# -# satype_dir=${TANKverf}/${RUN}.${prev_day}/${MONITOR} -# -# if [[ -s ${satype_dir}/${satype_file} ]]; then -# $NCP ${satype_dir}/${satype_file} . -# else -# echo "WARNING: unable to locate ${satype_dir}/${satype_file}" -# fi -# -# else -# satype_dir=${TANKverf}/${MONITOR}.${prev_day} -# -# if [[ -s ${satype_dir}/${satype_file} ]]; then -# $NCP ${satype_dir}/${satype_file} . -# else -# echo "WARNING: unable to locate ${satype_dir}/${satype_file}" -# fi -# fi + satype_file=${FIXgdas}/gdas_radmon_satype.txt +fi +if [[ ! -s ${satype_file} ]]; then echo "WARNING: unable to locate ${satype_file}" fi @@ -162,6 +151,12 @@ if [[ $nfile_src -gt 0 ]]; then mkdir -p ${test_dir} fi cd ${test_dir} + if [[ $RADMON_SUFFIX = "fv3rt1" ]]; then + $NCP $DE_SCRIPTS/ck_radstat.sh ${test_dir}/. + + radstat_file=${radstat_file:-${DATA}/${RUN}.${day}/${cycle}/gdas.t${cycle}z.radstat} + missing_from_radstat=`./ck_radstat.sh -s $satype_file -r $radstat_file` + fi type_list="angle bcoef bcor time" @@ -183,7 +178,7 @@ if [[ $nfile_src -gt 0 ]]; then $NCP ${DATDIR}/*.ctl* ${test_dir}/. - +#----------------------------------------------------------- # run validate.sh # 1. copy validate.sh and validate_data.x locally # 2. run validate.sh @@ -191,9 +186,9 @@ if [[ $nfile_src -gt 0 ]]; then # rm validate.sh, validate_data.x # rm stdout files? # make sure *.base and *.tar are removed - +#----------------------------------------------------------- if [[ $DO_DATA_RPT -eq 1 ]]; then - $NCP ${DE_EXEC}/validate_time.x ${test_dir}/. + $NCP ${DE_EXEC}/radmon_validate_tm.x ${test_dir}/. $NCP $DE_SCRIPTS/validate.sh ${test_dir}/. ./validate.sh ${PDATE} fi @@ -208,6 +203,7 @@ if [[ $exit_value == 0 ]]; then # Tar up the stdout.validation files #-------------------------------------------------------------------- if [[ $DO_DATA_RPT -eq 1 ]]; then + valid_tar=stdout.validate.tar if [[ $cycle -eq "00" ]]; then @@ -216,6 +212,9 @@ if [[ $exit_value == 0 ]]; then tar -rvf ${valid_tar} stdout.validate.*.${cycle} fi + rm -f stdout.validate.*.${cycle} + + #-------------------------------------------------------------------- # Remove extra spaces in new bad_pen file #-------------------------------------------------------------------- @@ -227,12 +226,20 @@ if [[ $exit_value == 0 ]]; then # Create a new penalty error report using the new bad_pen file #-------------------------------------------------------------------- $NCP $DE_SCRIPTS/radmon_err_rpt.sh ${test_dir}/. - $NCP $HOMEradmon/ush/radmon_getchgrp.pl ${test_dir}/. + if [[ -s $HOMEradmon/ush/radmon_getchgrp.pl ]]; then + $NCP $HOMEradmon/ush/radmon_getchgrp.pl ${test_dir}/. + fi + + if [[ $TANK_USE_RUN -eq 1 ]]; then + prev_bad_pen=${TANKverf}/${RUN}.${prev_day}/${prev_cyc}/${MONITOR}/bad_pen.${prev} + else + prev_bad_pen=${TANKverf}/radmon.${prev_day}/bad_pen.${prev} + fi - prev_bad_pen=${TANKverf}/radmon.${prev_day}/bad_pen.${prev} bad_pen=bad_pen.${PDATE} diag_rpt="diag.txt" outfile="pen.${PDATE}.txt" + err_rpt="err.${PDATE}.txt" ./radmon_err_rpt.sh $prev_bad_pen $bad_pen pen ${prev} ${PDATE} $diag_rpt $outfile @@ -252,11 +259,11 @@ if [[ $exit_value == 0 ]]; then opr_log=opr_${PDATE}.log tmp_log=tmp_${PDATE}.log new_log=new_opr_${PDATE}.log - if [[ $cycle = 18 ]]; then - $NCP ${LOGDIR}/${next_day}/gdas_verfrad_${cycle}.o* ${opr_log} - else - $NCP ${LOGDIR}/${day}/gdas_verfrad_${cycle}.o* ${opr_log} - fi +# if [[ $cycle = 18 ]]; then +# $NCP ${LOGDIR}/${next_day}/gdas_verfrad_${cycle}.o* ${opr_log} +# else +# $NCP ${LOGDIR}/${day}/gdas_verfrad_${cycle}.o* ${opr_log} +# fi #-------------------------------------------------------------------- # Diag report processing @@ -275,30 +282,57 @@ if [[ $exit_value == 0 ]]; then echo diag_end = $diag_end gawk "NR>=$diag_start && NR<=$diag_end" ${opr_log} >> $tmp_diag - + + reported_missing="" while read line; do new_sat=`echo $line | grep PROBLEM` len=`expr length "$new_sat"` if [[ $len -gt 0 ]]; then sat=`echo $new_sat | gawk '{print $1}'` -# test_satype=`grep $sat gdas_radmon_satype.txt` test_satype=`grep $sat ${satype_file}` len_test=`expr length "$test_satype"` if [[ $len_test -gt 0 ]]; then echo $line >> $new_diag + reported_missing="$reported_missing $sat" fi else echo $line >> $new_diag fi - done <${tmp_diag} + done <${tmp_diag} + + #------------------------------------------------------------------- + # now check the other direction, are all of the missing diag files + # reported in $missing_from_radstat in the report? + #------------------------------------------------------------------- + for mfr in $missing_from_radstat; do + test=`echo $reported_missing | grep $mfr` + len_test=`expr length "$test"` + if [[ $len_test -eq 0 ]]; then + line1=" $mfr ges ***PROBLEM reading diagnostic file." + line2=" $mfr anl ***PROBLEM reading diagnostic file." +# lines=`cat $new_diag | wc -l` +# echo "lines = $lines" + + sed "\$i $line1" ./$new_diag >fish.tmp + mv fish.tmp $new_diag + sed "\$i $line2" ./$new_diag >fish.tmp + mv fish.tmp $new_diag + + fi + + done + #-------------------------------------------------------------------- # if $new_diag still contains errors with reading diag files # then return $new_diag to the $opr_log #-------------------------------------------------------------------- test_new_diag=`cat $new_diag | grep "PROBLEM"` + len_test_new_diag=`expr length "$test_new_diag"` + echo "test_new_diag, len = $test_new_diag, $len_test_new_diag" + l_end=`wc -l $opr_log` log_end=`echo $l_end | sed 's/:/ /g' | gawk '{print $1}'` @@ -330,22 +364,22 @@ if [[ $exit_value == 0 ]]; then opr_log_start=1 - #------------------------------------------------------------------------ + #--------------------------------------------------------------------- # If $outfile exists, replace existing penalty report with $outfile # contents or remove the penalty report altogether if there is no # $outfile - #------------------------------------------------------------------------ + #--------------------------------------------------------------------- if [[ -s $outfile ]]; then echo "OUTFILE -s $outfile is TRUE" opr_log_end=`expr $opr_log_end + 1` gawk "NR>=$opr_log_start && NR<=$opr_log_end" ${opr_log} >> $new_log cat $outfile >> $new_log + echo "End Cycle Data Integrity Report" >> $new_log else echo "OUTFILE -s $outfile is FALSE" opr_log_end=`expr $opr_log_end - 15` gawk "NR>=$opr_log_start && NR<=$opr_log_end" ${opr_log} >> $new_log -# echo "NO ERROR REPORT" >> $new_log no_error_rpt=1 fi @@ -353,6 +387,7 @@ if [[ $exit_value == 0 ]]; then if [[ -s $outfile ]]; then rm -f report.txt + cp $opr_log $new_log echo "Begin Cycle Data Integrity Report" > report.txt @@ -387,6 +422,7 @@ if [[ $exit_value == 0 ]]; then fi fi + if [[ $no_diag_rpt -eq 1 ]]; then echo "NO DIAG REPORT" >> $new_log fi @@ -397,19 +433,19 @@ if [[ $exit_value == 0 ]]; then $NCP ./$new_log ${LOGdir}/data_extract.${day}.${cycle}.log #rm -f $new_log - rm -f $opr_log + #rm -f $opr_log #rm -f $new_diag $tmp_diag - rm -f $tmp_log + #rm -f $tmp_log fi - $compress *.ctl + $COMPRESS *.ctl #-------------------------------------------------------------------- # Remove processing scripts/executables and exit. #-------------------------------------------------------------------- - rm -f validate_time.x + rm -f radmon_validate_tm.x rm -f validate.sh rm -f radmon_err_rpt.sh rm -f radmon_getchgrp.pl diff --git a/util/Radiance_Monitor/data_extract/ush/MkBase.sh b/util/Radiance_Monitor/data_extract/ush/MkBase.sh index ff7d9aed4..396e9d756 100755 --- a/util/Radiance_Monitor/data_extract/ush/MkBase.sh +++ b/util/Radiance_Monitor/data_extract/ush/MkBase.sh @@ -17,23 +17,56 @@ set -ax date function usage { - echo "Usage: MkBase.sh suffix [sat] 1>log 2>err" + echo "Usage: MkBase.sh suffix [--sat SAT/INSTRUMENT --run gdas|gfs] " echo " Suffix is data source identifier that matches data in " echo " the $TANKverf/stats directory." - echo " Sat (optional) restricts the list of satellite sources." - echo " No sat means all satellite sources will be included." + echo "" + echo " -s,--sat SAT/INSTRUMENT (optional) limits the action of" + echo " MkBase.sh to processing only this specified source." + echo " Not using --sat means all satellite sources will be" + echo " included in the new base file." + echo "" + echo " -r,--run gdas|gfs (optional) specifies the run. Use this" + echo " if TANK_USE_RUN=1 in the parm/RadMon_user_settings file" } nargs=$# -if [[ $nargs -lt 1 || $nargs -gt 2 ]]; then +if [[ $nargs -lt 1 || $nargs -gt 5 ]]; then usage exit 1 fi -RADMON_SUFFIX=$1 +while [[ $# -ge 1 ]] +do + key="$1" + echo $key + + case $key in + -s|--sat) + export SATYPE="$2" + shift # past argument + ;; + -r|--run) + export RUN="$2" + shift # past argument + ;; + *) + #any unspecified key is RADMON_SUFFIX + export RADMON_SUFFIX=$key + ;; + esac + + shift +done + +echo "RADMON_SUFFIX = $RADMON_SUFFIX" +echo "RUN = $RUN" +echo "SATYPE = $SATYPE" +satlen=`echo ${#SATYPE}` +echo "satlen = $satlen" -if [[ $nargs -eq 2 ]]; then - SATYPE=$2 +SINGLE_SAT=0 +if [[ $satlen -gt 0 ]]; then SINGLE_SAT=1 fi @@ -45,7 +78,7 @@ this_dir=`dirname $0` #-------------------------------------------------------------------- RAD_AREA=${RAD_AREA:-glb} area=$RAD_AREA -echo $area, $REGIONAL_RR +echo $area #------------------------------------------------------------------ # Set environment variables. @@ -81,19 +114,21 @@ fi REGIONAL_RR=${REGIONAL_RR:-0} echo "REGIONAL_RR = $REGIONAL_RR" -echo "CYCLE_ITERVAL = $CYCLE_INTERVAL" +echo "CYCLE_INTERVAL = $CYCLE_INTERVAL" #------------------------------------------------------------------- # Set dates # BDATE is beginning date for the 30/60 day range # EDATE is ending date for 30/60 day range (always use 00 cycle) #------------------------------------------------------------------- -EDATE=`${DE_SCRIPTS}/find_cycle.pl 1 ${TANKverf}` +echo "TANKverf = $TANKverf" +EDATE=`${DE_SCRIPTS}/find_cycle.pl --cyc 1 --dir ${TANKverf} --run $RUN` echo $EDATE sdate=`echo $EDATE|cut -c1-8` EDATE=${sdate}00 BDATE=`$NDATE -1080 $EDATE` +BDATE=`$NDATE -336 $EDATE` echo EDATE = $EDATE echo BDATE = $BDATE @@ -113,8 +148,15 @@ if [[ $SINGLE_SAT -eq 0 ]]; then else PDY=`echo $EDATE|cut -c1-8` - if [[ -d ${TANKverf}/radmon.${PDY} ]]; then - test_list=`ls ${TANKverf}/radmon.${PDY}/angle.*${EDATE}.ieee_d*` + if [[ $TANK_USE_RUN -eq 1 ]]; then + testdir=${TANKverf}/${RUN}.${PDY}/radmon + else + testdir=${TANKverf}/radmon.${PDY} + fi + echo "testdir = $testdir" + + if [[ -d ${testdir} ]]; then + test_list=`ls ${testdir}/angle.*${EDATE}.ieee_d*` for test in ${test_list}; do this_file=`basename $test` tmp=`echo "$this_file" | cut -d. -f2` @@ -134,8 +176,8 @@ if [[ $SINGLE_SAT -eq 0 ]]; then fi fi -echo $SATYPE - +echo SATYPE = $SATYPE +echo TANK_USE_RUN = $TANK_USE_RUN #------------------------------------------------------------------- # Loop over $SATYPE and build base files for each @@ -178,11 +220,18 @@ for type in ${SATYPE}; do day=`echo $cdate | cut -c1-8 ` - if [[ -d ${TANKverf}/radmon.${day} ]]; then + if [[ $TANK_USE_RUN -eq 1 ]]; then + testday=${TANKverf}/${RUN}.${day}/radmon + else + testday=${TANKverf}/radmon.${day} + fi + echo "testday = $testday" + + if [[ -d ${testday} ]]; then if [[ $REGIONAL_RR -eq 1 ]]; then - test_file=${TANKverf}/radmon.${day}/${rgnHH}.time.${type}.${cdate}.ieee_d.${rgnTM} + test_file=${testday}/${rgnHH}.time.${type}.${cdate}.ieee_d.${rgnTM} else - test_file=${TANKverf}/radmon.${day}/time.${type}.${cdate}.ieee_d + test_file=${testday}/time.${type}.${cdate}.ieee_d fi if [[ -s $test_file ]]; then @@ -198,14 +247,12 @@ for type in ${SATYPE}; do - test_file=${TANKverf}/radmon.${day}/time.${type}.ctl + test_file=${testday}/time.${type}.ctl if [[ -s ${test_file} ]]; then - $NCP $TANKverf/radmon.${day}/time.${type}.ctl ${type}.ctl + $NCP ${test_file} ${type}.ctl elif [[ -s ${test_file}.${Z} ]]; then - $NCP $TANKverf/radmon.${day}/time.${type}.ctl.${Z} ${type}.ctl.${Z} - else - $NCP $TANKverf/time/${type}.ctl* ./ + $NCP $test_file.${Z} ${type}.ctl.${Z} fi ${UNCOMPRESS} *.${Z} @@ -227,7 +274,7 @@ for type in ${SATYPE}; do # Copy the executable and run it #------------------------------------------------------------------ out_file=${type}.base - $NCP ${DE_EXEC}/make_base ./ + $NCP ${DE_EXEC}/radmon_make_base.x ./make_base cat << EOF > input &INPUT @@ -247,9 +294,6 @@ EOF #------------------------------------------------------------------- $NCP $out_file ${tmpdir}/. - #------------------------------------------------------------------- - # Clean up - #------------------------------------------------------------------- cd $tmpdir done @@ -282,7 +326,7 @@ else $UNCOMPRESS ${basefile}.${Z} fi tar -xvf ${basefile} - rm ${basefile} +# rm ${basefile} fi # copy new *.base file from $tmpdir and build new $basefile (tar file) diff --git a/util/Radiance_Monitor/data_extract/ush/VrfyRad_glbl.sh b/util/Radiance_Monitor/data_extract/ush/VrfyRad_glbl.sh index af624a1fb..170b13589 100755 --- a/util/Radiance_Monitor/data_extract/ush/VrfyRad_glbl.sh +++ b/util/Radiance_Monitor/data_extract/ush/VrfyRad_glbl.sh @@ -138,7 +138,7 @@ jobname=$DATA_EXTRACT_JOBNAME if [[ $RUN_ENVIR = dev ]]; then if [[ $MY_MACHINE = "wcoss" ]]; then total=`bjobs -l | grep ${jobname} | wc -l` - elif [[ $MY_MACHINE = "zeus" || $MY_MACHINE = "theia" ]]; then + elif [[ $MY_MACHINE = "hera" || $MY_MACHINE = "theia" ]]; then total=0 line=`qstat -u ${LOGNAME} | grep ${jobname}` test=`echo $line | gawk '{print $10}'` @@ -167,7 +167,7 @@ if [[ $RUN_ENVIR = dev ]]; then # Get date of cycle to process. #--------------------------------------------------------------- if [[ $PDATE = "" ]]; then - pdate=`${DE_SCRIPTS}/find_cycle.pl 1 ${TANKverf}` + pdate=`${DE_SCRIPTS}/find_cycle.pl --cyc 1 --dir ${TANKverf}` if [[ ${#pdate} -ne 10 ]]; then echo "ERROR: Unable to locate any previous cycle's data files" echo " Please re-run this script with a specified starting cycle as the last argument" @@ -185,11 +185,22 @@ if [[ $RUN_ENVIR = dev ]]; then #--------------------------------------------------------------- # Locate required files. #--------------------------------------------------------------- - if [[ -d ${DATDIR}/gdas.$PDY ]]; then + if [[ -d ${DATDIR}/gdas.${PDY}/${CYC} ]]; then + export DATDIR=${DATDIR}/gdas.${PDY}/${CYC} + + export biascr=$DATDIR/gdas.t${CYC}z.abias + export radstat=$DATDIR/gdas.t${CYC}z.radstat + + elif [[ -d ${DATDIR}/gdas.$PDY ]]; then export DATDIR=${DATDIR}/gdas.${PDY} - export biascr=$DATDIR/gdas1.t${CYC}z.abias - export radstat=$DATDIR/gdas1.t${CYC}z.radstat + export biascr=$DATDIR/gdas.t${CYC}z.abias + export radstat=$DATDIR/gdas.t${CYC}z.radstat + elif [[ -s ${DATDIR}/gdas.t${CYC}z.radstat ]]; then + + export biascr=$DATDIR/gdas.t${CYC}z.abias + export radstat=$DATDIR/gdas.t${CYC}z.radstat + else export biascr=$DATDIR/biascr.gdas.${PDATE} export radstat=$DATDIR/radstat.gdas.${PDATE} @@ -242,43 +253,19 @@ if [[ -e ${radstat} ]]; then export VERBOSE=${VERBOSE:-YES} prev_day=`${NDATE} -06 $PDATE | cut -c1-8` - if [[ $TANK_USE_RUN -eq 1 ]]; then - export TANKverf_rad=${TANKverf_rad:-${TANKverf}/${RUN}.${PDY}/${MONITOR}} - export TANKverf_radM1=${TANKverf_radM1:-${TANKverf}/${RUN}.${prev_day}/${MONITOR}} - else + if [[ $TANK_USE_RUN -eq 0 ]]; then +# export TANKverf_rad=${TANKverf_rad:-${TANKverf}/${RUN}.${PDY}/${MONITOR}} +# export TANKverf_radM1=${TANKverf_radM1:-${TANKverf}/${RUN}.${prev_day}/${MONITOR}} +# else export TANKverf_rad=${TANKverf_rad:-${TANKverf}/${MONITOR}.${PDY}} export TANKverf_radM1=${TAKverf_radM1:-${TANKverf}/${MONITOR}.${prev_day}} fi - #---------------------------------------------------------------------------- - # Advance the satype file from previous day. - # If it isn't found then create one using the contents of the radstat file. - #---------------------------------------------------------------------------- - export satype_file=${TANKverf}/info/${RUN}_radmon_satype.txt - if [[ $CYC = "00" ]]; then echo "Making new day directory for 00 cycle" mkdir -p ${TANKverf_rad} -# prev_day=`${NDATE} -06 $PDATE | cut -c1-8` - -# if [[ -s ${TANKverf}/radmon.${prev_day}/${RADMON_SUFFIX}_radmon_satype.txt ]]; then -# if [[ -s ${satype_file} ]]; then -# cp ${TANKverf}/radmon.${prev_day}/${RADMON_SUFFIX}_radmon_satype.txt ${TANKverf}/radmon.${PDY}/. -# cp ${satype_file} ${TANKverf_rad}. -# fi fi - echo "TESTING for $satype_file" - if [[ -s ${satype_file} ]]; then - echo "${satype_file} is good to go" - else - echo "CREATING satype file" - radstat_satype=`tar -tvf $radstat | grep _ges | awk -F_ '{ print $2 "_" $3 }'` - echo $radstat_satype > ${satype_file} - echo "CREATED ${satype_file}" - fi - -# export satype_file=${RADMON_SUFFIX}_radmon_satype.txt #------------------------------------------------------------------ # Override the default base_file declaration if there is an @@ -291,18 +278,20 @@ if [[ -e ${radstat} ]]; then #------------------------------------------------------------------ # Submit data processing jobs. #------------------------------------------------------------------ - if [[ $MY_MACHINE = "wcoss" ]]; then + if [[ $MY_MACHINE = "wcoss" || $MY_MACHINE = "wcoss_d" ]]; then $SUB -q $JOB_QUEUE -P $PROJECT -o $LOGdir/data_extract.${PDY}.${cyc}.log \ -M 100 -R affinity[core] -W 0:20 -J ${jobname} -cwd ${PWD} \ $HOMEgdas/jobs/JGDAS_VERFRAD + elif [[ $MY_MACHINE = "cray" ]]; then $SUB -q $JOB_QUEUE -P $PROJECT -o $LOGdir/data_extract.${PDY}.${cyc}.log \ -M 100 -W 0:20 -J ${jobname} -cwd ${PWD} $HOMEgdas/jobs/JGDAS_VERFRAD - elif [[ $MY_MACHINE = "theia" ]]; then - $SUB -A $ACCOUNT -l procs=1,walltime=0:10:00 -N ${jobname} -V \ - -o $LOGdir/Rad_DE.${PDY}.${CYC}.log \ - -e $LOGdir/Rad_DE.${PDY}.${CYC}.err \ - $HOMEgdas/jobs/JGDAS_VERFRAD + + elif [[ $MY_MACHINE = "hera" ]]; then + $SUB --account=${ACCOUNT} --time=10 -J ${jobname} -D . \ + -o ${LOGdir}/DE.${PDY}.${cyc}.log \ + --ntasks=1 --mem=5g \ + ${HOMEgdas}/jobs/JGDAS_VERFRAD fi fi @@ -310,9 +299,9 @@ fi #-------------------------------------------------------------------- # Clean up and exit #-------------------------------------------------------------------- -#cd $tmpdir -#cd ../ -#rm -rf $tmpdir +cd $tmpdir +cd ../ +rm -rf $tmpdir exit_value=0 if [[ ${data_available} -ne 1 ]]; then diff --git a/util/Radiance_Monitor/data_extract/ush/VrfyRad_rgnl.sh b/util/Radiance_Monitor/data_extract/ush/VrfyRad_rgnl.sh index 435dcb6fd..6106cc627 100755 --- a/util/Radiance_Monitor/data_extract/ush/VrfyRad_rgnl.sh +++ b/util/Radiance_Monitor/data_extract/ush/VrfyRad_rgnl.sh @@ -15,7 +15,6 @@ echo start VrfyRad_rgnl.sh #-------------------------------------------------------------------- function usage { echo "Usage: VrfyRad_rgnl.sh suffix [pdate] " - echo " File name for VrfyRad_rgnl.sh can be full or relative path" echo " Suffix is the indentifier for this data source." echo " Pdate is the full YYYYMMDDHH cycle to run. This param is optional" } @@ -135,7 +134,7 @@ jobname=$DATA_EXTRACT_JOBNAME if [[ ${RUN_ENVIR} = dev ]]; then if [[ $MY_MACHINE = "wcoss" ]]; then total=`bjobs -l | grep ${jobname} | wc -l` - elif [[ $MY_MACHINE = "zeus" || $MY_MACHINE = "theia" ]]; then + elif [[ $MY_MACHINE = "hera" || $MY_MACHINE = "theia" ]]; then total=0 line=`qstat -u ${LOGNAME} | grep ${jobname}` test=`echo $line | gawk '{print $10}'` @@ -182,7 +181,7 @@ if [[ $RUN_ENVIR = dev ]]; then export com=${RADSTAT_LOCATION} if [[ $PDATE = "" ]]; then - pdate=`${DE_SCRIPTS}/find_cycle.pl 1 ${TANKverf}` + pdate=`${DE_SCRIPTS}/find_cycle.pl --cyc 1 --dir ${TANKverf}` if [[ ${#pdate} -ne 10 ]]; then echo "ERROR: Unable to locate any previous cycle's data files" @@ -453,7 +452,7 @@ if [ -s $radstat -a -s $biascr ]; then elif [[ $MY_MACHINE = "cray" ]]; then $SUB -q $JOB_QUEUE -P $PROJECT -M 40 -o ${logfile} -W 0:10 \ -J ${jobname} -cwd ${PWD} $HOMEnam/jobs/JNAM_VERFRAD - elif [[ $MY_MACHINE = "zeus" || $MY_MACHINE = "theia" ]]; then + elif [[ $MY_MACHINE = "hera" || $MY_MACHINE = "theia" ]]; then $SUB -A $ACCOUNT -l procs=1,walltime=0:05:00 -N ${jobname} -V \ -j oe -o ${logfile} ${HOMEnam}/jobs/JNAM_VERFRAD fi diff --git a/util/Radiance_Monitor/data_extract/ush/find_cycle.pl b/util/Radiance_Monitor/data_extract/ush/find_cycle.pl index 74573b238..55807a229 100755 --- a/util/Radiance_Monitor/data_extract/ush/find_cycle.pl +++ b/util/Radiance_Monitor/data_extract/ush/find_cycle.pl @@ -3,12 +3,17 @@ #----------------------------------------------------------------------- # find_cycle.pl # -# Given a directory containing radmon.YYYYMMDDHH subdirectories, -# determine the first or last cycle for which ieee_d data files -# exist. +# Arguments: +# --dir : Required string value containing $TANKdir/$SUFFIX. +# --cyc : Optional integer value: +# 1 = last cycle (default) +# 2 = 2nd to last cycle +# 0 = first cycle +# --run : Optional run name, generally 'gdas' or 'gfs'. +# This should be used if $TANK_USE_RUN is set to 1. # -# Return that first/last cycle as a text string in YYYYMMDDHH format, -# or return nothing if none of the expected data files are found. +# Return the requested cycle time or nothing if none of the expected +# data files are found. # # NOTE: This version has been modified to add case 2 returning # the 2nd to latest cycle time. This is to counter a timing @@ -17,7 +22,7 @@ use strict; use warnings; - + use Getopt::Long; use Scalar::Util qw(looks_like_number); #------------------------------------------------------------------- @@ -41,16 +46,20 @@ ##------------------------------------------------------------------ ##------------------------------------------------------------------ - if ($#ARGV != 1 ) { - print "usage: find_cycle.pl 0|1|2 /path_to_directory/containing/radmon.YYYYMMDDHH subdirectories. \n"; - print " 0 = first, 1 = last, 2 = 2nd to last \n"; - exit; - } - my $target = $ARGV[0]; - my $dirpath = $ARGV[1]; + my $run = 'gdas'; + my $dir = ''; + my $lcm = 'radmon'; + my $cyc = '1'; + + GetOptions( 'cyc:i' => \$cyc, + 'run:s' => \$run, + 'dir=s' => \$dir, + 'lcm:s' => \$lcm ); + + my $target = $cyc; + my $dirpath = $dir; my @alldirs; - # Get list of radmon.* sub-directories # opendir(DIR, $dirpath) or die "Cannot open directory $!"; @@ -140,7 +149,7 @@ # at least 2 directories. In order to potentially rerturn the 2nd # to the last time here on the crays. #------------------------------------------------------------------ - if ( $#times >= 0 && $ctr < $#sortrad ) { + if ( $#times >= 0 && $ctr <= $#sortrad ) { $found_cycle = 1; my @utimes = sort( uniq( @times ) ); if ( $target == 2 ) { # 2nd to last time diff --git a/util/Radiance_Monitor/data_extract/ush/nu_find_cycle.pl b/util/Radiance_Monitor/data_extract/ush/nu_find_cycle.pl new file mode 100755 index 000000000..af13f64d8 --- /dev/null +++ b/util/Radiance_Monitor/data_extract/ush/nu_find_cycle.pl @@ -0,0 +1,221 @@ +#! /usr/bin/perl + +#----------------------------------------------------------------------- +# nu_find_cycle.pl +# +# Arguments: +# --dir : Required string value containing $TANKdir/$SUFFIX. +# --cyc : Optional integer value: +# 1 = last cycle (default) +# 0 = first cycle +# --run : Run name, generally 'gdas' or 'gfs'. +# If not specified 'gdas' will be used. +# +# Return that first/last cycle as a text string in YYYYMMDDHH format, +# or return nothing if none of the expected data files are found. +# +# Note that this is designed to be used by a shell script which will +# pick up the returned cycle string. If debug statements are left +# in this perl script then the calling shell script will have +# problems. +# +# Note further: this utility is designed to replace find_cycle.pl, +# which has been intentionally retained. There are older TANKdir +# directory structures in use, which the find_cycle.pl utility can +# support. But integrating support for all types of TANKdir +# structures within a single script was +# more complicated than simply adding a new version of the utility. +# So if TANK_USE_RUN is 1, then this is the script to use because +# it knows to look in $TANKdir/$NET/$run.$pdy/$cyc/radmon. +#----------------------------------------------------------------------- + + use strict; + use warnings; + use Getopt::Long; + use Scalar::Util qw(looks_like_number); + + + #------------------------------------------------------------------- + # + # Subroutine uniq + # + # Given an input array, return all unique values in an array. + # + #------------------------------------------------------------------- + sub uniq { + my %seen; + return grep { !$seen{$_}++ } @_; + } + + + ##------------------------------------------------------------------ + ##------------------------------------------------------------------ + ## + ## begin main + ## + ##------------------------------------------------------------------ + ##------------------------------------------------------------------ + + my $run = 'gdas'; + my $dir = ''; + my $lcm = 'radmon'; + my $cyc = '1'; + + GetOptions( 'cyc:i' => \$cyc, + 'run:s' => \$run, + 'dir=s' => \$dir, + 'lcm:s' => \$lcm ); + + + my @alldirs; + my $dirpath = $dir; + + #-------------------------------------------------------------------- + # Get list of $run.* directories which contain radmon subdirectories + # + opendir(DIR, $dirpath) or die "Cannot open directory $!"; + while (my $file = readdir(DIR)) { + next unless (-d "$dirpath/$file"); + push( @alldirs, $file ); + } + closedir DIR; + + my $search_string; + + if( length($run) == 0 ){ + $search_string = $lcm; + } else { + $search_string = $run; + } + + my @mmdirs = grep { /$search_string/ } @alldirs; + + #----------------------------------------------------------------------- + # If there are no $run.yyyymmdd subdirectories, then exit without + # returning any date string. + # + if( $#mmdirs < 0 ) { + print "exiting with 0 mmdirs\n"; + exit; + } + + + #----------------------------------------------------------------------- + # Sort the mmdirs array and loop through it from end to beginning + # + + my @sortmm = sort( @mmdirs ); + + my $ctr; + my $incr; + my $end_ctr; + my @hrs; + + #----------------------------------------------------------------------- + # Arrange the logic here for accessing either the first or last + # cycle. If we're after the first cycle the directories will be + # processed from 0 to max. Note below the cycle hours are processed + # from max to 0, so the cycle order is reversed (18..00) when looking + # for the first cycle. + # + if( $cyc == 0 ){ + $ctr = -1; + $incr = 1; + $end_ctr = $#sortmm; + @hrs = qw( 18 12 06 00 ); + } else { + $ctr = $#sortmm + 1; + $incr = -1; + @hrs = qw( 00 06 12 18 ); + $end_ctr = 0; + } + + + my $found_cycle = 0; + + # Start with the latest directory and attempt to locate monitor + # subdirectories. + # + + my $exit_flag = 0; + + do { + $ctr = $ctr + $incr; + + # In each subdirectory attempt to locate all *ieee_d files + # and parse out all unique date values. The latest is the answer + # we're looking for. + # + # If there are no time.*ieee_d* files, step to the next iteration. + # + + my $newdir; + my $hr_ctr = $#hrs + 1; + + do { + + $hr_ctr = $hr_ctr - 1; + + $newdir = "${dirpath}/${sortmm[$ctr]}/${hrs[$hr_ctr]}/${lcm}"; +# print " newdir = $newdir \n"; + + + if( -d $newdir ) { + opendir DIR, $newdir or die "Cannot open the current directory: $!"; + + my @timefiles = grep { /ieee_d/ } readdir DIR; + + if( $#timefiles >= 0 ) { + my @sorttime = sort( @timefiles ); + my @times; + my $idx = 0; + + # Find the first string of 10 digits; that's the date. Use that + # $idx number to process all files. + # + my @vals = split( '\.', $timefiles[0] ); + for ( my $ii=$#vals; $ii >= 0; $ii-- ) { + if( looks_like_number( $vals[$ii] ) && length($vals[$ii] ) == 10 ){ + $idx = $ii; + } + } + + for ( my $ii=$#sorttime; $ii >= 0; $ii-- ) { + my $teststr = $sorttime[$ii]; + + my @values = split( '\.', $teststr ); + push( @times, $values[$idx] ); + + } + if ( $#times >= 0 ) { + my @utimes = sort( uniq( @times ) ); + if( $cyc == 1 ) { + print "$utimes[$#utimes]"; + $found_cycle = 1; + } elsif( $cyc == 2 && $#utimes >= 1 ) { + print "$utimes[$#utimes-1]"; + $found_cycle = 1; + } else { + print "$utimes[0]"; + $found_cycle = 1; + } + } + } + + } + + } while $hr_ctr > 0 && $found_cycle == 0; + +# print " found_cycle, ctr, end_ctr = $found_cycle, $ctr, $end_ctr \n"; + + if( $cyc == 0 && $ctr >= $end_ctr ){ +# print " exiting from if\n"; + $exit_flag = 1; + } elsif( $cyc == 1 && $ctr <= $end_ctr ){ +# print " exiting from elsif\n"; + $exit_flag = 1; + } + + + } while $found_cycle == 0 && $exit_flag == 0; + diff --git a/util/Radiance_Monitor/data_extract/ush/run_control_V02.sh b/util/Radiance_Monitor/data_extract/ush/run_control_V02.sh new file mode 100755 index 000000000..7d050ced5 --- /dev/null +++ b/util/Radiance_Monitor/data_extract/ush/run_control_V02.sh @@ -0,0 +1,58 @@ +#!/bin/bash + +suffix=control_V02 +RUN=gdas +tank=/home/${LOGNAME}/nbns/stats/${suffix} + +export RADSTAT_LOCATION=/scratch4/NAGAPE/jcsda-datagap/Erin.Jones/ROTDIRS/noscrub/archive/control_V02/radstat + +export PROJECT=GDAS-T2O +export USE_ANL=1 +export JOB_QUEUE=dev_shared +export DO_DIAG_RPT=1 +export DO_DATA_RPT=1 +export RAD_AREA=glb +export CYCLE_INTERVAL=6 +export REGIONAL_RR=0 +export TANK_USE_RUN=1 + +export COMROOT=/com +export jlogfile=/ptmpp1/$LOGNAME/logs/fv3rt1/radmon/DE.log + +package=ProdGSI/util/Radiance_Monitor +#idev=`cat /etc/dev | cut -c1` +#iprod=`cat /etc/prod | cut -c1` + +#scripts=/gpfs/${idev}d2/emc/da/noscrub/Edward.Safford/${package}/data_extract/ush +scripts=/scratch4/NCEPDEV/da/noscrub/Edward.Safford/${package}/data_extract/ush + +#-------------------------------------------------------------------- +# Check for my monitoring use. Abort if running on prod machine. +#-------------------------------------------------------------------- + +#is_prod=`${scripts}/onprod.sh` +#if [[ $is_prod = 1 ]]; then +# exit 10 +#fi + +#-------------------------------------------------------------------- +#NDATE=/nwprod/util/exec/ndate +NDATE=/home/Edward.Safford/bin/ndate + +ldate=`${scripts}/nu_find_cycle.pl --run $RUN --cyc 1 --dir $tank` +echo "ldate = $ldate" + +pdate=`${NDATE} +6 ${ldate}` +#pdate=2018120100 +echo "processing pdate = $pdate" + +pdy=`echo $pdate | cut -c1-8` +cyc=`echo $pdate | cut -c9-10` + +export RADSTAT_LOCATION=${RADSTAT_LOCATION}/gdas.${pdy}/${cyc} +echo RADSTAT_LOCATION= $RADSTAT_LOCATION +ptmp_user=/scratch4/NCEPDEV/stmp4/Edward.Safford + +${scripts}/VrfyRad_glbl.sh ${suffix} ${pdate} 1>${ptmp_user}/logs/${suffix}/${RUN}/radmon/VrfyRad.log 2>${ptmp_user}/logs/${suffix}/${RUN}/radmon/VrfyRad.err + +exit diff --git a/util/Radiance_Monitor/data_extract/ush/run_cp_v16rt0.sh b/util/Radiance_Monitor/data_extract/ush/run_cp_v16rt0.sh new file mode 100755 index 000000000..9c1c9fed1 --- /dev/null +++ b/util/Radiance_Monitor/data_extract/ush/run_cp_v16rt0.sh @@ -0,0 +1,63 @@ +#!/bin/sh +set -ax + +export RADSTAT_LOCATION=/com2/gfs/prod +export SOURCE_DIR=/gpfs/dell2/emc/modeling/noscrub/emc.glopara/monitor/radmon/stats/v16rt0 + +export ACCOUNT=dev +export USE_ANL=1 +export DO_DIAG_RPT=1 +export DO_DATA_RPT=1 +export MAIL_TO="Edward.Safford@noaa.gov" +#export MAIL_CC="Russ.Treadon@noaa.gov" +export MAIL_CC="edward.c.safford@gmail.com" +export JOB_QUEUE=dev_shared + +me=`hostname | cut -c1` +package=ProdGSI/util/Radiance_Monitor +#package=RadMon +export TANK_USE_RUN=1 + +scripts=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/${package}/data_extract/ush + + +#-------------------------------------------------------------------- +# Check for my monitoring use. Abort if running on prod machine. +#-------------------------------------------------------------------- + +is_prod=`${scripts}/onprod.sh` +if [[ $is_prod = 1 ]]; then + exit 10 +fi + +#-------------------------------------------------------------------- +export RADMON_SUFFIX=v16rt0 +export RUN=gdas +export RAD_AREA=glb + +TANKverf=/u/Edward.Safford/nbns/stats +NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.2/exec/ips/ndate + +ldate=`${scripts}/nu_find_cycle.pl --run $RUN --cyc 1 --dir ${TANKverf}/${RADMON_SUFFIX}` +echo "last cycle processed is $ldate" + +ldate_len=`echo ${#ldate}` +if [[ ${ldate_len} -ne 10 ]]; then + exit 1 +fi +START_DATE=`${NDATE} +06 $ldate` +#START_DATE=2019070100 + +day=`echo $START_DATE | cut -c1-8` +export DATDIR=/gpfs/dell2/emc/modeling/noscrub/emc.glopara/monitor/radmon/stats/v16rt0/gdas.${day} + +logs=/gpfs/dell2/ptmp/Edward.Safford/logs/${RADMON_SUFFIX}/${RUN}/radmon + +echo ldate, START_DATE = $ldate, $START_DATE + +${scripts}/Copy_glbl.sh \ + ${RADMON_SUFFIX} ${START_DATE} \ + 1>${logs}/CopyRad_${RADMON_SUFFIX}.log \ + 2>${logs}/CopyRad_${RADMON_SUFFIX}.err + +exit diff --git a/util/Radiance_Monitor/data_extract/ush/run_cp_wopr.sh b/util/Radiance_Monitor/data_extract/ush/run_cp_wopr.sh new file mode 100755 index 000000000..5c9923c28 --- /dev/null +++ b/util/Radiance_Monitor/data_extract/ush/run_cp_wopr.sh @@ -0,0 +1,51 @@ +#!/bin/sh +set -ax + +#export RADSTAT_LOCATION=/com2/gfs/prod +export SOURCE_DIR=/gpfs/dell1/nco/ops/com/gfs/prod +export ACCOUNT=dev +export USE_ANL=1 +export DO_DIAG_RPT=1 +export DO_DATA_RPT=1 +export MAIL_TO="Edward.Safford@noaa.gov" +#export MAIL_CC="Russ.Treadon@noaa.gov" +export MAIL_CC="edward.c.safford@gmail.com" +export JOB_QUEUE=dev_shared + +me=`hostname | cut -c1` +#package=ProdGSI/util/Radiance_Monitor +package=RadMon + +export TANK_USE_RUN=1 +export USE_HR=1 + +scripts=/gpfs/dell2/emc/modeling/noscrub/Edward.Safford/${package}/data_extract/ush + +#-------------------------------------------------------------------- +export RADMON_SUFFIX=GFS +export RUN=gdas +export RAD_AREA=glb + +TANKverf=/u/Edward.Safford/nbns/stats +NDATE=/gpfs/dell1/nco/ops/nwprod/prod_util.v1.1.2/exec/ips/ndate + +idate=`${scripts}/nu_find_cycle.pl --run $RUN --cyc 1 --dir ${TANKverf}/${RADMON_SUFFIX}` + +idate_len=`echo ${#idate}` +if [[ ${idate_len} -ne 10 ]]; then + exit 1 +fi +START_DATE=`${NDATE} +06 $idate` +#START_DATE=2019062900 + +echo idate, START_DATE = $idate, $START_DATE + +logdir=/gpfs/dell2/ptmp/Edward.Safford/logs/${RADMON_SUFFIX}/${RUN}/radmon + +${scripts}/Copy_glbl.sh \ + ${RADMON_SUFFIX} ${START_DATE} \ + 1>${logdir}/CopyRad_${RADMON_SUFFIX}.log \ + 2>${logdir}/CopyRad_${RADMON_SUFFIX}.err + +set +ax +exit diff --git a/util/Radiance_Monitor/data_extract/ush/run_nam.sh b/util/Radiance_Monitor/data_extract/ush/run_nam.sh new file mode 100755 index 000000000..c9f9d9f61 --- /dev/null +++ b/util/Radiance_Monitor/data_extract/ush/run_nam.sh @@ -0,0 +1,40 @@ +#!/bin/sh + +export RADSTAT_LOCATION=/com2/nam/prod +export PROJECT=NDAS-T2O +export JOB_QUEUE=dev_shared + +export USE_ANL=1 +export DO_DIAG_RPT=1 +export DO_DATA_RPT=1 + +export RAD_AREA=rgn +export REGIONAL_RR=1 +export CYCLE_INTERVAL=1 +export TANK_USE_RUN=0 + +package=ProdGSI/util/Radiance_Monitor +idev=`cat /etc/dev | cut -c1` +iprod=`cat /etc/prod | cut -c1` + +export COMROOT=/com +export jlogfile=/ptmpp1/$LOGNAME/logs/nam/radmon/run_nrx.log + +scripts=/gpfs/${idev}d2/emc/da/noscrub/Edward.Safford/${package}/data_extract/ush + + +#-------------------------------------------------------------------- +# Check for my monitoring use. Abort if running on prod machine. +#-------------------------------------------------------------------- + +is_prod=`${scripts}/onprod.sh` +if [[ $is_prod = 1 ]]; then + exit 10 +fi + +#-------------------------------------------------------------------- + + +${scripts}/VrfyRad_rgnl.sh nam 1>/ptmpp1/Edward.Safford/logs/nam/radmon/VrfyRad_nam.log 2>/ptmpp1/Edward.Safford/logs/nam/radmon/VrfyRad_nam.err + +exit diff --git a/util/Radiance_Monitor/data_extract/ush/run_test.sh b/util/Radiance_Monitor/data_extract/ush/run_test.sh new file mode 100755 index 000000000..078d7678d --- /dev/null +++ b/util/Radiance_Monitor/data_extract/ush/run_test.sh @@ -0,0 +1,53 @@ +#!/bin/sh + +suffix=testrad +RUN=gdas +tank=/home/${LOGNAME}/nbns/stats/${suffix} + +export RADSTAT_LOCATION=/scratch4/NCEPDEV/da/noscrub/Edward.Safford/test_data +export PROJECT=GDAS-T2O +export USE_ANL=1 +export JOB_QUEUE=dev_shared +export DO_DIAG_RPT=1 +export DO_DATA_RPT=1 +export RAD_AREA=glb +export CYCLE_INTERVAL=6 +export REGIONAL_RR=0 +export TANK_USE_RUN=1 + +export COMROOT=/com +export jlogfile=/scratch4/NCEPDEV/stmp4/Edward.Safford/logs/${suffix}/radmon/DE.log + +package=ProdGSI/util/Radiance_Monitor +#idev=`cat /etc/dev | cut -c1` +#iprod=`cat /etc/prod | cut -c1` + +scripts=/scratch4/NCEPDEV/da/noscrub/Edward.Safford/${package}/data_extract/ush + +#-------------------------------------------------------------------- +# Check for my monitoring use. Abort if running on prod machine. +#-------------------------------------------------------------------- + +#is_prod=`${scripts}/onprod.sh` +#if [[ $is_prod = 1 ]]; then +# exit 10 +#fi + +#-------------------------------------------------------------------- +#NDATE=/nwprod/util/exec/ndate +#NDATE=/scratch4/NCEPDEV/global/save/glopara/nwpara/util/exec/ndate + +#ldate=`${scripts}/find_cycle.pl --run $RUN --cyc 1 --dir $tank` +#pdate=`${NDATE} +6 ${ldate}` +pdate=2018091700 + +pdy=`echo $pdate | cut -c1-8` +cyc=`echo $pdate | cut -c9-10` + +export RADSTAT_LOCATION=${RADSTAT_LOCATION}/gdas.${pdy}/${cyc} +echo RADSTAT_LOCATION= $RADSTAT_LOCATION +logs=/scratch4/NCEPDEV/stmp4/Edward.Safford/logs/${suffix} + +${scripts}/VrfyRad_glbl.sh ${suffix} ${pdate} 1>${logs}/${RUN}/radmon/VrfyRad.log 2>${logs}/${RUN}/radmon/VrfyRad.err + +exit diff --git a/util/Radiance_Monitor/data_extract/ush/validate.sh b/util/Radiance_Monitor/data_extract/ush/validate.sh index b74068799..b2759af03 100755 --- a/util/Radiance_Monitor/data_extract/ush/validate.sh +++ b/util/Radiance_Monitor/data_extract/ush/validate.sh @@ -18,8 +18,8 @@ ############################################################## echo "--> start validate.sh" -echo " TEST: COMPRESS = $COMPRESS" -echo " TEST: RADMON_SUFFIX = $RADMON_SUFFIX" + +set -ax nargs=$# if [[ $nargs -ne 1 ]]; then @@ -36,16 +36,29 @@ echo " TEST: RADMON_SUFFIX = $RADMON_SUFFIX" idd=`echo $PDATE | cut -c7-8` ihh=`echo $PDATE | cut -c9-10` -# +#--------------------------------------------------- # Get the gdas_radmon_base.tar file and open it -# - cp ${TANKverf}/info/${RUN}_radmon_base.tar* . -# cp /nwprod2/gdas_radmon.v2.0.2/fix/gdas_radmon_base.tar . - if [[ -s gdas_radmon_base.tar.gz ]]; then - gunzip gdas_radmon_base.tar.gz +# + base_file=${RUN}_radmon_base.tar + + if [[ -s ${TANKverf}/info/${base_file} || \ + -s ${TANKverf}/info/${base_file}.${Z} ]]; then + cp ${TANKverf}/info/${base_file}* . + fi + + if [[ ! -s ${base_file} && ! -s ${base_file}.${Z} ]]; then + cp ${FIXgdas}/${base_file}* . + fi + if [[ ! -s ${base_file} && ! -s ${base_file}.${Z} ]]; then + echo "WARNING: Unable to locate ${base_file}" + fi + + if [[ -s ${base_file}.${Z} ]]; then + $UNCOMPRESS ${base_file}.${Z} fi - tar -xvf gdas_radmon_base.tar - rm -f gdas_radmon_base.tar + + tar -xvf ${base_file} + rm -f ${base_file} # # Get satype list, loop over satype @@ -61,10 +74,6 @@ echo " TEST: RADMON_SUFFIX = $RADMON_SUFFIX" done echo $SATYPE_LIST -# testing -# SATYPE_LIST="sndrd4_g15" - - # # loop over SATYPE_LIST @@ -72,8 +81,8 @@ echo " TEST: RADMON_SUFFIX = $RADMON_SUFFIX" for sat in ${SATYPE_LIST}; do echo sat = $sat - gunzip time.${sat}.${PDATE}.ieee_d.gz - gunzip time.${sat}.ctl.gz + gunzip time.${sat}.${PDATE}.ieee_d.${Z} + gunzip time.${sat}.ctl.${Z} nchan=`cat time.${sat}.ctl | gawk '/title/{print $NF}'` @@ -108,10 +117,10 @@ cat << EOF > input / EOF - ./validate_time.x < input > stdout.validate.$sat.$ihh + ./radmon_validate_tm.x < input > stdout.validate.$sat.$ihh - gzip time.${sat}.${PDATE}.ieee_d + ${COMPRESS} time.${sat}.${PDATE}.ieee_d done # end loop over SATYPE_LIST diff --git a/util/Radiance_Monitor/get_hostname.pl b/util/Radiance_Monitor/get_hostname.pl index f10243bcd..ac3d971fc 100755 --- a/util/Radiance_Monitor/get_hostname.pl +++ b/util/Radiance_Monitor/get_hostname.pl @@ -42,15 +42,15 @@ $host = $hostnames[0]; } - if( $host =~ /tfe/ ) { - $machine = "theia"; - } - elsif( $host =~ /fe/ ) { - $machine = "zeus"; + if( $host =~ /hfe/ ) { + $machine = "hera"; } elsif( $host =~ /login/ ) { $machine = "cray"; } + elsif( $host =~ /m/ || $host =~ /v/ ){ + $machine = "wcoss_d"; # dell machines are mXXaY/vXXaY + } elsif( $host =~ /t/ || $host =~ /g/ ){ # wcoss nodes are tXXaY and gXXaY $machine = "wcoss"; } diff --git a/util/Radiance_Monitor/image_gen/exec/.gitignore b/util/Radiance_Monitor/image_gen/exec/.gitignore new file mode 100644 index 000000000..d6b7ef32c --- /dev/null +++ b/util/Radiance_Monitor/image_gen/exec/.gitignore @@ -0,0 +1,2 @@ +* +!.gitignore diff --git a/util/Radiance_Monitor/image_gen/gscripts/plot_horiz.gs b/util/Radiance_Monitor/image_gen/gscripts/plot_horiz.gs index 46825398a..78b615fd3 100755 --- a/util/Radiance_Monitor/image_gen/gscripts/plot_horiz.gs +++ b/util/Radiance_Monitor/image_gen/gscripts/plot_horiz.gs @@ -43,10 +43,10 @@ if (field = cor) type="bias correction (K)" endif if (field = obsges) - type="ges_(w/bias cor) - obs (K)" + type="obs (K) - ges_(w/bias cor)" endif if (field = obsnbc) - type="ges_(w/o bias cor) - obs (K)" + type="obs (K) - ges_(w/o bias cor)" endif * Set (lat,lon) box to plot diff --git a/util/Radiance_Monitor/image_gen/html/clim_chan.php b/util/Radiance_Monitor/image_gen/html/clim_chan.php new file mode 100644 index 000000000..947622cfc --- /dev/null +++ b/util/Radiance_Monitor/image_gen/html/clim_chan.php @@ -0,0 +1,40 @@ + + + + 0) && (strlen( $sat ) > 0) ) { + + $pdir = "../../../../../GFDPT/site/clim/" . $cycle . "/" . $sat . "/"; + + $files = glob( "$pdir*N*.png" ); + $nfiles = count( $files ); + + echo ","; /* add this so the calling script can + break on "," and remove all the + returned html preceeding the src list */ + + +foreach( $files as $file ){ + $strs = explode( '_', $file ); + $chan = preg_replace( '/Ch/', '', $strs[4] ); + + echo "$chan,"; + } + + +} +?> + + diff --git a/util/Radiance_Monitor/image_gen/html/clim_date.php b/util/Radiance_Monitor/image_gen/html/clim_date.php new file mode 100644 index 000000000..e5bd7507c --- /dev/null +++ b/util/Radiance_Monitor/image_gen/html/clim_date.php @@ -0,0 +1,51 @@ + + + clim date + + + + + diff --git a/util/Radiance_Monitor/image_gen/html/clim_src.php b/util/Radiance_Monitor/image_gen/html/clim_src.php new file mode 100644 index 000000000..3edfd21e6 --- /dev/null +++ b/util/Radiance_Monitor/image_gen/html/clim_src.php @@ -0,0 +1,42 @@ + + + + + 0 ) { + + $pdir="../../../../../GFDPT/site/clim/" . $cycle . "/."; + $subdirs = glob( $pdir . '/*' , GLOB_ONLYDIR ); + sort( $subdirs ); + $cnt = count( $subdirs ); + + + if( $cnt > 0 ) { + echo ","; /* add this so the calling script can + break on "," and remove all the + returned html preceeding the src list */ + + for ($i = 0; $i <= count( $subdirs ); $i++) { + $sdir = explode( '/', $subdirs[$i] ); + $src = $sdir[count($sdir)-1]; + if( strlen( $src ) > 2 ){ + echo "$src,"; + } + } + } +} + +?> + + diff --git a/util/Radiance_Monitor/image_gen/html/install_glb.sh b/util/Radiance_Monitor/image_gen/html/install_glb.sh index 8359dc4bd..d2ff2c1b8 100755 --- a/util/Radiance_Monitor/image_gen/html/install_glb.sh +++ b/util/Radiance_Monitor/image_gen/html/install_glb.sh @@ -33,21 +33,21 @@ RAD_AREA="glb" this_file=`basename $0` this_dir=`dirname $0` -top_parm=${this_dir}/../../parm - -if [[ -s ${top_parm}/RadMon_config ]]; then - . ${top_parm}/RadMon_config -else - echo "ERROR: Unable to source ${top_parm}/RadMon_config" - exit -fi - -if [[ -s ${top_parm}/RadMon_user_settings ]]; then - . ${top_parm}/RadMon_user_settings -else - echo "ERROR: Unable to source ${top_parm}/RadMon_user_settings" - exit -fi +#top_parm=${this_dir}/../../parm +# +#if [[ -s ${top_parm}/RadMon_config ]]; then +# . ${top_parm}/RadMon_config +#else +# echo "ERROR: Unable to source ${top_parm}/RadMon_config" +# exit +#fi +# +#if [[ -s ${top_parm}/RadMon_user_settings ]]; then +# . ${top_parm}/RadMon_user_settings +#else +# echo "ERROR: Unable to source ${top_parm}/RadMon_user_settings" +# exit +#fi #-------------------------------------------------------------- @@ -85,7 +85,7 @@ cd $workdir # Find the first date with data. Start at today and work # backwards. Stop after 90 days and exit. # -PDATE=`${IG_SCRIPTS}/find_cycle.pl 1 ${TANKverf}` +PDATE=`${IG_SCRIPTS}/find_cycle.pl --dir ${TANKverf} --cyc 1` echo PDATE= $PDATE limit=`$NDATE -2160 $PDATE` # 90 days diff --git a/util/Radiance_Monitor/image_gen/html/plot_2d.html b/util/Radiance_Monitor/image_gen/html/plot_2d.html new file mode 100644 index 000000000..74aa1ff41 --- /dev/null +++ b/util/Radiance_Monitor/image_gen/html/plot_2d.html @@ -0,0 +1,357 @@ + + + + + + + + 2-D Radiance Plots + + + + + + + + + + + + + +

2-D Radiance Plots

+ +
+ +
+ + + + + + + + diff --git a/util/Radiance_Monitor/image_gen/html/plot_summary.html b/util/Radiance_Monitor/image_gen/html/plot_summary.html index 1d8b02a3e..bf80efda6 100644 --- a/util/Radiance_Monitor/image_gen/html/plot_summary.html +++ b/util/Radiance_Monitor/image_gen/html/plot_summary.html @@ -15,8 +15,7 @@ - - +